doc-doxygen/html/mpp__transmit_8h_source.html

00001 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00002 !                                                                             !
00003 !                                  MPP_TRANSMIT                               !
00004 !                                                                             !
00005 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00006
00007     subroutine MPP_TRANSMIT_( put_data, put_len, to_pe, get_data, get_len, from_pe )
00008 !a message-passing routine intended to be reminiscent equally of both MPI and SHMEM
00009
00010 !put_data and get_data are contiguous MPP_TYPE_ arrays
00011
00012 !at each call, your put_data array is put to   to_pe's get_data
00013 !              your get_data array is got from from_pe's put_data
00014 !i.e we assume that typically (e.g updating halo regions) each PE performs a put _and_ a get
00015
00016 !special PE designations:
00017 !      NULL_PE: to disable a put or a get (e.g at boundaries)
00018 !      ANY_PE:  if remote PE for the put or get is to be unspecific
00019 !      ALL_PES: broadcast and collect operations (collect not yet implemented)
00020
00021 !ideally we would not pass length, but this f77-style call performs better (arrays passed by address, not descriptor)
00022 !further, this permits <length> contiguous words from an array of any rank to be passed (avoiding f90 rank conformance check)
00023
00024 !caller is responsible for completion checks (mpp_sync_self) before and after
00025
00026       integer, intent(in) :: put_len, to_pe, get_len, from_pe
00027       MPP_TYPE_, intent(in)  :: put_data(*)
00028       MPP_TYPE_, intent(out) :: get_data(*)
00029       integer :: i
00030 #ifdef use_libSMA
00031       integer :: np
00032       integer(LONG_KIND) :: data_loc
00033 !pointer to remote data
00034       MPP_TYPE_ :: remote_data(get_len)
00035       pointer( ptr_remote_data, remote_data )
00036       MPP_TYPE_ :: broadcast_data(get_len)
00037       pointer( ptr, broadcast_data )
00038       integer :: words
00039       character(len=8) :: text
00040 #endif
00041       MPP_TYPE_, allocatable, save :: local_data(:) !local copy used by non-parallel code (no SHMEM or MPI)
00042
00043       if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_TRANSMIT: You must first call mpp_init.' )
00044       if( to_pe.EQ.NULL_PE .AND. from_pe.EQ.NULL_PE )return
00045
00046       if( debug )then
00047           call SYSTEM_CLOCK(tick)
00048           write( stdout(),'(a,i18,a,i5,a,2i5,2i8)' )&
00049                'T=',tick, ' PE=',pe, ' MPP_TRANSMIT begin: to_pe, from_pe, put_len, get_len=', to_pe, from_pe, put_len, get_len
00050       end if
00051
00052 !do put first and then get
00053       if( to_pe.GE.0 .AND. to_pe.LT.npes )then
00054 #ifdef use_libSMA
00055 !send data pointer to to_pe
00056 #ifdef _CRAYT90
00057           call SHMEM_UDCFLUSH !invalidate data cache
00058 #endif
00059           if( current_clock.NE.0 )call SYSTEM_CLOCK(start_tick)
00060           call SHMEM_INT8_WAIT( status(to_pe), MPP_WAIT )
00061           status(to_pe) = MPP_WAIT !prohibit puts to to_pe until it has retrieved this message
00062           if( current_clock.NE.0 )call increment_current_clock(EVENT_WAIT)
00063           data_loc = LOC(put_data)
00064           if( current_clock.NE.0 )call SYSTEM_CLOCK(start_tick)
00065           call SHMEM_INTEGER_PUT( mpp_from_pe, pe, 1, to_pe )
00066           call SHMEM_PUT8( remote_data_loc(pe), data_loc, 1, to_pe )
00067           if( current_clock.NE.0 )call increment_current_clock( EVENT_SEND, put_len*MPP_TYPE_BYTELEN_ )
00068 #elif use_libMPI
00069 !use non-blocking sends
00070           if( current_clock.NE.0 )call SYSTEM_CLOCK(start_tick)
00071           if( mpp_request(to_pe).NE.MPI_REQUEST_NULL )then !only one message from pe->to_pe in queue
00072 !              if( debug )write( stderr(),* )'PE waiting ', pe, to_pe
00073               call MPI_WAIT( mpp_request(to_pe), stat, error )
00074           end if
00075           call MPI_ISEND( put_data, put_len, MPI_TYPE_, to_pe, tag, peset(0)%id, mpp_request(to_pe), error )
00076           if( current_clock.NE.0 )call increment_current_clock( EVENT_SEND, put_len*MPP_TYPE_BYTELEN_ )
00077 #else                           !neither SHMEM nor MPI
00078           if( allocated(local_data) ) &
00079                call mpp_error( FATAL, 'MPP_TRANSMIT: local_data should have been deallocated by prior receive.' )
00080           allocate( local_data(put_len) )
00081           do i = 1,put_len
00082              local_data(i) = put_data(i)
00083           end do
00084 #endif
00085
00086       else if( to_pe.EQ.ALL_PES )then !this is a broadcast from from_pe
00087           if( from_pe.LT.0 .OR. from_pe.GE.npes )call mpp_error( FATAL, 'MPP_TRANSMIT: broadcasting from invalid PE.' )
00088           if( put_len.GT.get_len )call mpp_error( FATAL, 'MPP_TRANSMIT: size mismatch between put_data and get_data.' )
00089           if( pe.EQ.from_pe )then
00090 #ifdef use_CRI_pointers
00091               if( LOC(get_data).NE.LOC(put_data) )then
00092 !dir$ IVDEP
00093 #endif
00094                   do i = 1,get_len
00095                      get_data(i) = put_data(i)
00096                   end do
00097 #ifdef use_CRI_pointers
00098               end if
00099 #endif
00100           end if
00101           call mpp_broadcast( get_data, get_len, from_pe )
00102           return
00103
00104       else if( to_pe.EQ.ANY_PE )then !we don't have a destination to do puts to, so only do gets
00105 #ifdef use_libSMA
00106           if( from_pe.LT.0 .OR. from_pe.GE.npes )call mpp_error( FATAL, 'MPP_TRANSMIT: invalid from_pe along with to_pe=ANY_PE.' )
00107           if( current_clock.NE.0 )call SYSTEM_CLOCK(start_tick)
00108           call SHMEM_GET_( get_data, put_data, get_len, from_pe )
00109           call SHMEM_PUT8( status(pe), MPP_READY, 1, from_pe ) !tell from_pe that you have retrieved this message
00110           if( current_clock.NE.0 )call increment_current_clock( EVENT_RECV, get_len*MPP_TYPE_BYTELEN_ )
00111           return
00112 #endif
00113 #ifdef use_libMPI
00114 !...but you cannot have a pure get with MPI
00115           call mpp_error( FATAL, 'MPP_TRANSMIT: you cannot transmit to ANY_PE using MPI.' )
00116 #endif
00117
00118       else if( to_pe.NE.NULL_PE )then   !no other valid cases except NULL_PE
00119           call mpp_error( FATAL, 'MPP_TRANSMIT: invalid to_pe.' )
00120       end if
00121
00122 !do the get: for libSMA, a get means do a wait to ensure put on remote PE is complete
00123       if( from_pe.GE.0 .AND. from_pe.LT.npes )then
00124 #ifdef use_libSMA
00125 #ifdef _CRAYT90
00126           call SHMEM_UDCFLUSH !invalidate data cache
00127 #endif
00128           if( current_clock.NE.0 )call SYSTEM_CLOCK(start_tick)
00129           if( debug )write( stderr(),* )'pe, from_pe, remote_data_loc(from_pe)=', pe, from_pe, remote_data_loc(from_pe)
00130           call SHMEM_INT8_WAIT( remote_data_loc(from_pe), MPP_WAIT )
00131           if( current_clock.NE.0 )call increment_current_clock(EVENT_WAIT)
00132           ptr_remote_data = remote_data_loc(from_pe)
00133           remote_data_loc(from_pe) = MPP_WAIT !reset
00134 !          call SHMEM_PUT8( status(pe), MPP_READY, 1, from_pe ) !tell from_pe we have retrieved the location
00135           if( current_clock.NE.0 )call SYSTEM_CLOCK(start_tick)
00136 #if defined(CRAYPVP) || defined(sgi_mipspro)
00137 !since we have the pointer to remote data, just retrieve it with a simple copy
00138           if( LOC(get_data).NE.LOC(remote_data) )then
00139 !dir$ IVDEP
00140               do i = 1,get_len
00141                  get_data(i) = remote_data(i)
00142               end do
00143           else
00144               call mpp_error(FATAL)
00145           end if
00146 #else
00147           call SHMEM_GET_( get_data, remote_data, get_len, from_pe )
00148 #endif
00149           call SHMEM_PUT8( status(pe), MPP_READY, 1, from_pe ) !tell from_pe we have retrieved the location
00150           if( current_clock.NE.0 )call increment_current_clock( EVENT_RECV, get_len*MPP_TYPE_BYTELEN_ )
00151 #elif  use_libMPI
00152 !receive from from_pe
00153           if( current_clock.NE.0 )call SYSTEM_CLOCK(start_tick)
00154           call MPI_RECV( get_data, get_len, MPI_TYPE_, from_pe, MPI_ANY_TAG, peset(0)%id, stat, error )
00155           if( current_clock.NE.0 )call increment_current_clock( EVENT_RECV, get_len*MPP_TYPE_BYTELEN_ )
00156 #else                           !neither SHMEM nor MPI
00157           if( .NOT.allocated(local_data) ) &
00158                call mpp_error( FATAL, 'MPP_TRANSMIT: local_data should have been allocated by prior send.' )
00159           do i = 1,get_len
00160              get_data(i) = local_data(i)
00161           end do
00162           deallocate(local_data)
00163 !#else !neither use_libSMA nor use_libMPI
00164 !          if( pe.EQ.from_pe )then
00165 !#ifdef use_CRI_pointers
00166 !!dir$ IVDEP
00167 !              if( LOC(get_data).NE.LOC(put_data) ) &
00168 !#endif
00169 !                   get_data(1:put_len) = put_data(1:put_len)
00170 !          end if
00171 #endif
00172
00173       else if( from_pe.EQ.ANY_PE )then
00174 #ifdef use_libSMA
00175 #ifdef _CRAYT90
00176           call SHMEM_UDCFLUSH !invalidate data cache
00177 #endif
00178 !since we don't know which PE is sending us data, we wait for remote PE to send us its ID
00179 !this is only required for !CRAYPVP  && !sgi_mipspro, but is done there too, so that we can send put_is_done back.
00180           call shmem_integer_wait( mpp_from_pe, ANY_PE )
00181           if( current_clock.NE.0 )call SYSTEM_CLOCK(start_tick)
00182           call SHMEM_INT8_WAIT( remote_data_loc(mpp_from_pe), MPP_WAIT )
00183           if( current_clock.NE.0 )call increment_current_clock(EVENT_WAIT)
00184           ptr_remote_data = remote_data_loc(mpp_from_pe)
00185           remote_data_loc(mpp_from_pe) = MPP_WAIT !reset
00186           call SHMEM_PUT8( status(pe), MPP_READY, 1, mpp_from_pe ) !tell mpp_from_pe we have retrieved the location
00187 #if defined(CRAYPVP) || defined(sgi_mipspro)
00188 !since we have the pointer to remote data, just retrieve it with a simple copy
00189           if( current_clock.NE.0 )call SYSTEM_CLOCK(start_tick)
00190           if( LOC(get_data).NE.LOC(remote_data) )then
00191 !dir$ IVDEP
00192               do i = 1,get_len
00193                  get_data(i) = remote_data(i)
00194               end do
00195           end if
00196 #else
00197           call SHMEM_GET_( get_data, remote_data, get_len, mpp_from_pe )
00198 #endif
00199           if( current_clock.NE.0 )call increment_current_clock( EVENT_RECV, get_len*MPP_TYPE_BYTELEN_ )
00200           mpp_from_pe = ANY_PE   !reset
00201 #endif use_libSMA
00202 #ifdef use_libMPI
00203 !receive from MPI_ANY_SOURCE
00204           if( current_clock.NE.0 )call SYSTEM_CLOCK(start_tick)
00205           call MPI_RECV( get_data, get_len, MPI_TYPE_, MPI_ANY_SOURCE, MPI_ANY_TAG, peset(0)%id, stat, error )
00206           if( current_clock.NE.0 )call increment_current_clock( EVENT_RECV, get_len*MPP_TYPE_BYTELEN_ )
00207 #endif
00208
00209       else if( from_pe.EQ.ALL_PES )then
00210           call mpp_error( FATAL, 'MPP_TRANSMIT: from_pe=ALL_PES has ambiguous meaning, and hence is not implemented.' )
00211
00212       else if( from_pe.NE.NULL_PE )then !only remaining valid choice is NULL_PE
00213           call mpp_error( FATAL, 'MPP_TRANSMIT: invalid from_pe.' )
00214       end if
00215
00216       if( debug )then
00217           call SYSTEM_CLOCK(tick)
00218           write( stdout(),'(a,i18,a,i5,a,2i5,2i8)' )&
00219                'T=',tick, ' PE=',pe, ' MPP_TRANSMIT end: to_pe, from_pe, put_len, get_len=', to_pe, from_pe, put_len, get_len
00220       end if
00221       return
00222     end subroutine MPP_TRANSMIT_
00223
00224     subroutine MPP_TRANSMIT_SCALAR_( put_data, to_pe, get_data, from_pe )
00225       integer, intent(in) :: to_pe, from_pe
00226       MPP_TYPE_, intent(in)  :: put_data
00227       MPP_TYPE_, intent(out) :: get_data
00228       MPP_TYPE_ :: put_data1D(1), get_data1D(1)
00229 #ifdef use_CRI_pointers
00230       pointer( ptrp, put_data1D )
00231       pointer( ptrg, get_data1D )
00232
00233       ptrp = LOC(put_data)
00234       ptrg = LOC(get_data)
00235       call MPP_TRANSMIT_ ( put_data1D, 1, to_pe, get_data1D, 1, from_pe )
00236 #else
00237       put_data1D(1) = put_data
00238       call MPP_TRANSMIT_ ( put_data1D, 1, to_pe, get_data1D, 1, from_pe )
00239       get_data = get_data1D(1)
00240 #endif
00241       return
00242     end subroutine MPP_TRANSMIT_SCALAR_
00243
00244     subroutine MPP_TRANSMIT_2D_( put_data, put_len, to_pe, get_data, get_len, from_pe )
00245       integer, intent(in) :: put_len, to_pe, get_len, from_pe
00246       MPP_TYPE_, intent(in)  :: put_data(:,:)
00247       MPP_TYPE_, intent(out) :: get_data(:,:)
00248       MPP_TYPE_ :: put_data1D(put_len), get_data1D(get_len)
00249 #ifdef use_CRI_pointers
00250       pointer( ptrp, put_data1D )
00251       pointer( ptrg, get_data1D )
00252       ptrp = LOC(put_data)
00253       ptrg = LOC(get_data)
00254       call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe )
00255 #else
00256 !faster than RESHAPE? length is probably redundant
00257       if( to_pe.NE.NULL_PE )put_data1D = TRANSFER( put_data, put_data1D, get_len )
00258 !      if( to_pe.NE.NULL_PE )put_data1D = RESHAPE( put_data, SHAPE(put_data1D) )
00259       call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe )
00260       if( from_pe.NE.NULL_PE )get_data = RESHAPE( get_data1D, SHAPE(get_data) )
00261 #endif
00262       return
00263     end subroutine MPP_TRANSMIT_2D_
00264
00265     subroutine MPP_TRANSMIT_3D_( put_data, put_len, to_pe, get_data, get_len, from_pe )
00266       integer, intent(in) :: put_len, to_pe, get_len, from_pe
00267       MPP_TYPE_, intent(in)  :: put_data(:,:,:)
00268       MPP_TYPE_, intent(out) :: get_data(:,:,:)
00269       MPP_TYPE_ :: put_data1D(put_len), get_data1D(get_len)
00270 #ifdef use_CRI_pointers
00271       pointer( ptrp, put_data1D )
00272       pointer( ptrg, get_data1D )
00273       ptrp = LOC(put_data)
00274       ptrg = LOC(get_data)
00275       call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe )
00276 #else
00277 !faster than RESHAPE? length is probably redundant
00278       if( to_pe.NE.NULL_PE )put_data1D = TRANSFER( put_data, put_data1D, get_len )
00279 !      if( to_pe.NE.NULL_PE )put_data1D = RESHAPE( put_data, SHAPE(put_data1D) )
00280       call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe )
00281       if( from_pe.NE.NULL_PE )get_data = RESHAPE( get_data1D, SHAPE(get_data) )
00282 #endif
00283       return
00284     end subroutine MPP_TRANSMIT_3D_
00285
00286     subroutine MPP_TRANSMIT_4D_( put_data, put_len, to_pe, get_data, get_len, from_pe )
00287       integer, intent(in) :: put_len, to_pe, get_len, from_pe
00288       MPP_TYPE_, intent(in)  :: put_data(:,:,:,:)
00289       MPP_TYPE_, intent(out) :: get_data(:,:,:,:)
00290       MPP_TYPE_ :: put_data1D(put_len), get_data1D(get_len)
00291 #ifdef use_CRI_pointers
00292       pointer( ptrp, put_data1D )
00293       pointer( ptrg, get_data1D )
00294       ptrp = LOC(put_data)
00295       ptrg = LOC(get_data)
00296       call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe )
00297 #else
00298 !faster than RESHAPE? length is probably redundant
00299       if( to_pe.NE.NULL_PE )put_data1D = TRANSFER( put_data, put_data1D, get_len )
00300 !      if( to_pe.NE.NULL_PE )put_data1D = RESHAPE( put_data, SHAPE(put_data1D) )
00301       call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe )
00302       if( from_pe.NE.NULL_PE )get_data = RESHAPE( get_data1D, SHAPE(get_data) )
00303 #endif
00304       return
00305     end subroutine MPP_TRANSMIT_4D_
00306
00307     subroutine MPP_TRANSMIT_5D_( put_data, put_len, to_pe, get_data, get_len, from_pe )
00308       integer, intent(in) :: put_len, to_pe, get_len, from_pe
00309       MPP_TYPE_, intent(in)  :: put_data(:,:,:,:,:)
00310       MPP_TYPE_, intent(out) :: get_data(:,:,:,:,:)
00311       MPP_TYPE_ :: put_data1D(put_len), get_data1D(get_len)
00312 #ifdef use_CRI_pointers
00313       pointer( ptrp, put_data1D )
00314       pointer( ptrg, get_data1D )
00315       ptrp = LOC(put_data)
00316       ptrg = LOC(get_data)
00317       call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe )
00318 #else
00319 !faster than RESHAPE? length is probably redundant
00320       if( to_pe.NE.NULL_PE )put_data1D = TRANSFER( put_data, put_data1D, get_len )
00321 !      if( to_pe.NE.NULL_PE )put_data1D = RESHAPE( put_data, SHAPE(put_data1D) )
00322       call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe )
00323       if( from_pe.NE.NULL_PE )get_data = RESHAPE( get_data1D, SHAPE(get_data) )
00324 #endif
00325       return
00326     end subroutine MPP_TRANSMIT_5D_
00327 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00328 !                                                                             !
00329 !                              MPP_SEND and RECV                              !
00330 !                                                                             !
00331 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00332
00333     subroutine MPP_RECV_( get_data, get_len, from_pe )
00334 !a mpp_transmit with null arguments on the put side
00335       integer, intent(in) :: get_len, from_pe
00336       MPP_TYPE_, intent(out) :: get_data(*)
00337       MPP_TYPE_ :: dummy(1)
00338       call mpp_transmit( dummy, 1, NULL_PE, get_data, get_len, from_pe )
00339     end subroutine MPP_RECV_
00340
00341     subroutine MPP_SEND_( put_data, put_len, to_pe )
00342 !a mpp_transmit with null arguments on the get side
00343       integer, intent(in) :: put_len, to_pe
00344       MPP_TYPE_, intent(in) :: put_data(*)
00345       MPP_TYPE_ :: dummy(1)
00346       call mpp_transmit( put_data, put_len, to_pe, dummy, 1, NULL_PE )
00347     end subroutine MPP_SEND_
00348
00349     subroutine MPP_RECV_SCALAR_( get_data, from_pe )
00350 !a mpp_transmit with null arguments on the put side
00351       integer, intent(in) :: from_pe
00352       MPP_TYPE_, intent(out) :: get_data
00353       MPP_TYPE_ :: get_data1D(1)
00354       MPP_TYPE_ :: dummy(1)
00355 #ifdef use_CRI_pointers
00356       pointer( ptr, get_data1D )
00357       ptr = LOC(get_data)
00358       call mpp_transmit( dummy, 1, NULL_PE, get_data1D, 1, from_pe )
00359 #else
00360       call mpp_transmit( dummy, 1, NULL_PE, get_data1D, 1, from_pe )
00361       get_data = get_data1D(1)
00362 #endif
00363     end subroutine MPP_RECV_SCALAR_
00364
00365     subroutine MPP_SEND_SCALAR_( put_data, to_pe )
00366 !a mpp_transmit with null arguments on the get side
00367       integer, intent(in) :: to_pe
00368       MPP_TYPE_, intent(in) :: put_data
00369       MPP_TYPE_ :: put_data1D(1)
00370       MPP_TYPE_ :: dummy(1)
00371 #ifdef use_CRI_pointers
00372       pointer( ptr, put_data1D )
00373       ptr = LOC(put_data)
00374       call mpp_transmit( put_data1D, 1, to_pe, dummy, 1, NULL_PE )
00375 #else
00376       put_data1D(1) = put_data
00377       call mpp_transmit( put_data1D, 1, to_pe, dummy, 1, NULL_PE )
00378 #endif
00379     end subroutine MPP_SEND_SCALAR_
00380
00381     subroutine MPP_RECV_2D_( get_data, get_len, from_pe )
00382 !a mpp_transmit with null arguments on the put side
00383       integer, intent(in) :: get_len, from_pe
00384       MPP_TYPE_, intent(out) :: get_data(:,:)
00385       MPP_TYPE_ :: dummy(1,1)
00386       call mpp_transmit( dummy, 1, NULL_PE, get_data, get_len, from_pe )
00387     end subroutine MPP_RECV_2D_
00388
00389     subroutine MPP_SEND_2D_( put_data, put_len, to_pe )
00390 !a mpp_transmit with null arguments on the get side
00391       integer, intent(in) :: put_len, to_pe
00392       MPP_TYPE_, intent(in) :: put_data(:,:)
00393       MPP_TYPE_ :: dummy(1,1)
00394       call mpp_transmit( put_data, put_len, to_pe, dummy, 1, NULL_PE )
00395     end subroutine MPP_SEND_2D_
00396
00397     subroutine MPP_RECV_3D_( get_data, get_len, from_pe )
00398 !a mpp_transmit with null arguments on the put side
00399       integer, intent(in) :: get_len, from_pe
00400       MPP_TYPE_, intent(out) :: get_data(:,:,:)
00401       MPP_TYPE_ :: dummy(1,1,1)
00402       call mpp_transmit( dummy, 1, NULL_PE, get_data, get_len, from_pe )
00403     end subroutine MPP_RECV_3D_
00404
00405     subroutine MPP_SEND_3D_( put_data, put_len, to_pe )
00406 !a mpp_transmit with null arguments on the get side
00407       integer, intent(in) :: put_len, to_pe
00408       MPP_TYPE_, intent(in) :: put_data(:,:,:)
00409       MPP_TYPE_ :: dummy(1,1,1)
00410       call mpp_transmit( put_data, put_len, to_pe, dummy, 1, NULL_PE )
00411     end subroutine MPP_SEND_3D_
00412
00413     subroutine MPP_RECV_4D_( get_data, get_len, from_pe )
00414 !a mpp_transmit with null arguments on the put side
00415       integer, intent(in) :: get_len, from_pe
00416       MPP_TYPE_, intent(out) :: get_data(:,:,:,:)
00417       MPP_TYPE_ :: dummy(1,1,1,1)
00418       call mpp_transmit( dummy, 1, NULL_PE, get_data, get_len, from_pe )
00419     end subroutine MPP_RECV_4D_
00420
00421     subroutine MPP_SEND_4D_( put_data, put_len, to_pe )
00422 !a mpp_transmit with null arguments on the get side
00423       integer, intent(in) :: put_len, to_pe
00424       MPP_TYPE_, intent(in) :: put_data(:,:,:,:)
00425       MPP_TYPE_ :: dummy(1,1,1,1)
00426       call mpp_transmit( put_data, put_len, to_pe, dummy, 1, NULL_PE )
00427     end subroutine MPP_SEND_4D_
00428
00429     subroutine MPP_RECV_5D_( get_data, get_len, from_pe )
00430 !a mpp_transmit with null arguments on the put side
00431       integer, intent(in) :: get_len, from_pe
00432       MPP_TYPE_, intent(out) :: get_data(:,:,:,:,:)
00433       MPP_TYPE_ :: dummy(1,1,1,1,1)
00434       call mpp_transmit( dummy, 1, NULL_PE, get_data, get_len, from_pe )
00435     end subroutine MPP_RECV_5D_
00436
00437     subroutine MPP_SEND_5D_( put_data, put_len, to_pe )
00438 !a mpp_transmit with null arguments on the get side
00439       integer, intent(in) :: put_len, to_pe
00440       MPP_TYPE_, intent(in) :: put_data(:,:,:,:,:)
00441       MPP_TYPE_ :: dummy(1,1,1,1,1)
00442       call mpp_transmit( put_data, put_len, to_pe, dummy, 1, NULL_PE )
00443     end subroutine MPP_SEND_5D_
00444
00445 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00446 !                                                                             !
00447 !                                MPP_BROADCAST                                !
00448 !                                                                             !
00449 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00450
00451     subroutine MPP_BROADCAST_( data, length, from_pe, pelist )
00452 !this call was originally bundled in with mpp_transmit, but that doesn't allow
00453 !broadcast to a subset of PEs. This version will, and mpp_transmit will remain
00454 !backward compatible.
00455       MPP_TYPE_, intent(inout) :: data(*)
00456       integer, intent(in) :: length, from_pe
00457       integer, intent(in), optional :: pelist(:)
00458       integer :: n
00459 #ifdef use_libSMA
00460       integer :: np, i
00461       integer(LONG_KIND) :: data_loc
00462 !pointer to remote data
00463       MPP_TYPE_ :: bdata(length)
00464       pointer( ptr, bdata )
00465       integer :: words
00466       character(len=8) :: text
00467 #endif
00468
00469       if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_BROADCAST: You must first call mpp_init.' )
00470       n = get_peset(pelist); if( peset(n)%count.EQ.1 )return
00471
00472       if( debug )then
00473           call SYSTEM_CLOCK(tick)
00474           write( stdout(),'(a,i18,a,i5,a,2i5,2i8)' )&
00475                'T=',tick, ' PE=',pe, ' MPP_BROADCAST begin: from_pe, length=', from_pe, length
00476       end if
00477
00478       if( .NOT.ANY(from_pe.EQ.peset(current_peset_num)%list) ) &
00479            call mpp_error( FATAL, 'MPP_BROADCAST: broadcasting from invalid PE.' )
00480
00481       if( current_clock.NE.0 )call SYSTEM_CLOCK(start_tick)
00482 #ifdef use_libSMA
00483       ptr = LOC(mpp_stack)
00484       words = size(bdata)*size(transfer(bdata(1),word))
00485       if( words.GT.mpp_stack_size )then
00486           write( text, '(i8)' )words
00487           call mpp_error( FATAL, 'MPP_BROADCAST user stack overflow: call mpp_set_stack_size('//text//') from all PEs.' )
00488       end if
00489       mpp_stack_hwm = max( words, mpp_stack_hwm )
00490       if( mpp_npes().GT.1 )then
00491 !dir$ IVDEP
00492           do i = 1,length
00493              bdata(i) = data(i)
00494           end do
00495           call mpp_sync(pelist) !eliminate?
00496 #ifdef _CRAYT90
00497           call SHMEM_UDCFLUSH !invalidate data cache
00498 #endif
00499           call SHMEM_BROADCAST_( bdata, bdata, length, from_pe, peset(n)%start, peset(n)%log2stride, peset(n)%count, sync )
00500           call mpp_sync(pelist) !eliminate?
00501 !dir$ IVDEP
00502           do i = 1,length
00503              data(i) = bdata(i)
00504           end do
00505       end if
00506 #endif
00507 #ifdef use_libMPI
00508       if( mpp_npes().GT.1 )call MPI_BCAST( data, length, MPI_TYPE_, from_pe, peset(n)%id, error )
00509 #endif
00510       if( current_clock.NE.0 )call increment_current_clock( EVENT_BROADCAST, length*MPP_TYPE_BYTELEN_ )
00511       return
00512     end subroutine MPP_BROADCAST_
00513
00514     subroutine MPP_BROADCAST_SCALAR_( data, from_pe, pelist )
00515       MPP_TYPE_, intent(inout) :: data
00516       integer, intent(in) :: from_pe
00517       integer, intent(in), optional :: pelist(:)
00518       MPP_TYPE_ :: data1D(1)
00519 #ifdef use_CRI_pointers
00520       pointer( ptr, data1D )
00521
00522       ptr = LOC(data)
00523       call MPP_BROADCAST_( data1D, 1, from_pe, pelist )
00524 #else
00525       data1D(1) = data
00526       call MPP_BROADCAST_( data1D, 1, from_pe, pelist )
00527       data = data1D(1)
00528 #endif
00529       return
00530     end subroutine MPP_BROADCAST_SCALAR_
00531
00532     subroutine MPP_BROADCAST_2D_( data, length, from_pe, pelist )
00533 !this call was originally bundled in with mpp_transmit, but that doesn't allow
00534 !broadcast to a subset of PEs. This version will, and mpp_transmit will remain
00535 !backward compatible.
00536       MPP_TYPE_, intent(inout) :: data(:,:)
00537       integer, intent(in) :: length, from_pe
00538       integer, intent(in), optional :: pelist(:)
00539       MPP_TYPE_ :: data1D(length)
00540 #ifdef use_CRI_pointers
00541       pointer( ptr, data1D )
00542       ptr = LOC(data)
00543       call mpp_broadcast( data1D, length, from_pe, pelist )
00544 #else
00545 !faster than RESHAPE? length is probably redundant
00546       data1D = TRANSFER( data, data1D, length )
00547 !      data1D = RESHAPE( data, SHAPE(data1D) )
00548       call mpp_broadcast( data1D, length, from_pe, pelist )
00549       data = RESHAPE( data1D, SHAPE(data) )
00550 #endif
00551       return
00552     end subroutine MPP_BROADCAST_2D_
00553
00554     subroutine MPP_BROADCAST_3D_( data, length, from_pe, pelist )
00555 !this call was originally bundled in with mpp_transmit, but that doesn't allow
00556 !broadcast to a subset of PEs. This version will, and mpp_transmit will remain
00557 !backward compatible.
00558       MPP_TYPE_, intent(inout) :: data(:,:,:)
00559       integer, intent(in) :: length, from_pe
00560       integer, intent(in), optional :: pelist(:)
00561       MPP_TYPE_ :: data1D(length)
00562 #ifdef use_CRI_pointers
00563       pointer( ptr, data1D )
00564       ptr = LOC(data)
00565       call mpp_broadcast( data1D, length, from_pe, pelist )
00566 #else
00567 !faster than RESHAPE? length is probably redundant
00568       data1D = TRANSFER( data, data1D, length )
00569 !      data1D = RESHAPE( data, SHAPE(data1D) )
00570       call mpp_broadcast( data1D, length, from_pe, pelist )
00571       data = RESHAPE( data1D, SHAPE(data) )
00572 #endif
00573       return
00574     end subroutine MPP_BROADCAST_3D_
00575
00576     subroutine MPP_BROADCAST_4D_( data, length, from_pe, pelist )
00577 !this call was originally bundled in with mpp_transmit, but that doesn't allow
00578 !broadcast to a subset of PEs. This version will, and mpp_transmit will remain
00579 !backward compatible.
00580       MPP_TYPE_, intent(inout) :: data(:,:,:,:)
00581       integer, intent(in) :: length, from_pe
00582       integer, intent(in), optional :: pelist(:)
00583       MPP_TYPE_ :: data1D(length)
00584 #ifdef use_CRI_pointers
00585       pointer( ptr, data1D )
00586       ptr = LOC(data)
00587       call mpp_broadcast( data1D, length, from_pe, pelist )
00588 #else
00589 !faster than RESHAPE? length is probably redundant
00590       data1D = TRANSFER( data, data1D, length )
00591 !      data1D = RESHAPE( data, SHAPE(data1D) )
00592       call mpp_broadcast( data1D, length, from_pe, pelist )
00593       data = RESHAPE( data1D, SHAPE(data) )
00594 #endif
00595       return
00596     end subroutine MPP_BROADCAST_4D_
00597
00598     subroutine MPP_BROADCAST_5D_( data, length, from_pe, pelist )
00599 !this call was originally bundled in with mpp_transmit, but that doesn't allow
00600 !broadcast to a subset of PEs. This version will, and mpp_transmit will remain
00601 !backward compatible.
00602       MPP_TYPE_, intent(inout) :: data(:,:,:,:,:)
00603       integer, intent(in) :: length, from_pe
00604       integer, intent(in), optional :: pelist(:)
00605       MPP_TYPE_ :: data1D(length)
00606 #ifdef use_CRI_pointers
00607       pointer( ptr, data1D )
00608       ptr = LOC(data)
00609       call mpp_broadcast( data1D, length, from_pe, pelist )
00610 #else
00611 !faster than RESHAPE? length is probably redundant
00612       data1D = TRANSFER( data, data1D, length )
00613 !      data1D = RESHAPE( data, SHAPE(data1D) )
00614       call mpp_broadcast( data1D, length, from_pe, pelist )
00615       data = RESHAPE( data1D, SHAPE(data) )
00616 #endif
00617       return
00618     end subroutine MPP_BROADCAST_5D_