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_
