Changeset 2481
- Timestamp:
- 2010-12-17T18:27:02+01:00 (13 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/nemo_v3_3_beta/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r2480 r2481 175 175 CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt 176 176 INTEGER, OPTIONAL , INTENT(in ) :: localComm 177 INTEGER :: mynode, ierr, code 177 INTEGER :: mynode, ierr, code, ji, ii 178 178 LOGICAL :: mpi_was_called 179 179 … … 181 181 !!---------------------------------------------------------------------- 182 182 ! 183 WRITE(ldtxt(1),*) 184 WRITE(ldtxt(2),*) 'mynode : mpi initialisation' 185 WRITE(ldtxt(3),*) '~~~~~~ ' 183 ii = 1 184 WRITE(ldtxt(ii),*) ; ii = ii + 1 185 WRITE(ldtxt(ii),*) 'mynode : mpi initialisation' ; ii = ii + 1 186 WRITE(ldtxt(ii),*) '~~~~~~ ' ; ii = ii + 1 186 187 ! 187 188 REWIND( numnam ) ! Namelist namrun : parameters of the run 188 189 READ ( numnam, nammpp ) 189 190 ! ! control print 190 WRITE(ldtxt( 4),*) ' Namelist nammpp'191 WRITE(ldtxt( 5),*) ' mpi send type cn_mpi_send = ', cn_mpi_send192 WRITE(ldtxt( 6),*) ' size in bytes of exported buffer nn_buffer = ', nn_buffer191 WRITE(ldtxt(ii),*) ' Namelist nammpp' ; ii = ii + 1 192 WRITE(ldtxt(ii),*) ' mpi send type cn_mpi_send = ', cn_mpi_send ; ii = ii + 1 193 WRITE(ldtxt(ii),*) ' size in bytes of exported buffer nn_buffer = ', nn_buffer ; ii = ii + 1 193 194 194 195 CALL mpi_initialized ( mpi_was_called, code ) 195 196 IF( code /= MPI_SUCCESS ) THEN 197 DO ji = 1, SIZE(ldtxt) 198 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode 199 END DO 196 200 WRITE(*, cform_err) 197 201 WRITE(*, *) 'lib_mpp: Error in routine mpi_initialized' … … 203 207 SELECT CASE ( cn_mpi_send ) 204 208 CASE ( 'S' ) ! Standard mpi send (blocking) 205 WRITE(ldtxt( 7),*) ' Standard blocking mpi send (send)'209 WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' ; ii = ii + 1 206 210 CASE ( 'B' ) ! Buffer mpi send (blocking) 207 WRITE(ldtxt( 7),*) ' Buffer blocking mpi send (bsend)'208 CALL mpi_init_opa(ierr )211 WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' ; ii = ii + 1 212 IF( Agrif_Root() ) CALL mpi_init_opa( ldtxt, ii, ierr ) 209 213 CASE ( 'I' ) ! Immediate mpi send (non-blocking send) 210 WRITE(ldtxt( 7),*) ' Immediate non-blocking send (isend)'214 WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' ; ii = ii + 1 211 215 l_isend = .TRUE. 212 216 CASE DEFAULT 213 WRITE(ldtxt( 7),cform_err)214 WRITE(ldtxt( 8),*) ' bad value for cn_mpi_send = ', cn_mpi_send217 WRITE(ldtxt(ii),cform_err) ; ii = ii + 1 218 WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send ; ii = ii + 1 215 219 nstop = nstop + 1 216 220 END SELECT 217 221 ELSE IF ( PRESENT(localComm) .and. .not. mpi_was_called ) THEN 218 WRITE(ldtxt( 7),*) ' lib_mpp: You cannot provide a local communicator '219 WRITE(ldtxt( 8),*) ' without calling MPI_Init before ! '222 WRITE(ldtxt(ii),*) ' lib_mpp: You cannot provide a local communicator ' ; ii = ii + 1 223 WRITE(ldtxt(ii),*) ' without calling MPI_Init before ! ' ; ii = ii + 1 220 224 nstop = nstop + 1 221 225 ELSE 222 226 SELECT CASE ( cn_mpi_send ) 223 227 CASE ( 'S' ) ! Standard mpi send (blocking) 224 WRITE(ldtxt( 7),*) ' Standard blocking mpi send (send)'228 WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' ; ii = ii + 1 225 229 CALL mpi_init( ierr ) 226 230 CASE ( 'B' ) ! Buffer mpi send (blocking) 227 WRITE(ldtxt( 7),*) ' Buffer blocking mpi send (bsend)'228 CALL mpi_init_opa(ierr )231 WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' ; ii = ii + 1 232 IF( Agrif_Root() ) CALL mpi_init_opa( ldtxt, ii, ierr ) 229 233 CASE ( 'I' ) ! Immediate mpi send (non-blocking send) 230 WRITE(ldtxt( 7),*) ' Immediate non-blocking send (isend)'234 WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' ; ii = ii + 1 231 235 l_isend = .TRUE. 232 236 CALL mpi_init( ierr ) 233 237 CASE DEFAULT 234 WRITE(ldtxt( 7),cform_err)235 WRITE(ldtxt( 8),*) ' bad value for cn_mpi_send = ', cn_mpi_send238 WRITE(ldtxt(ii),cform_err) ; ii = ii + 1 239 WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send ; ii = ii + 1 236 240 nstop = nstop + 1 237 241 END SELECT … … 246 250 CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code) 247 251 IF( code /= MPI_SUCCESS ) THEN 252 DO ji = 1, SIZE(ldtxt) 253 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode 254 END DO 248 255 WRITE(*, cform_err) 249 256 WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup' … … 2282 2289 2283 2290 2284 SUBROUTINE mpi_init_opa( code )2291 SUBROUTINE mpi_init_opa( ldtxt, ksft, code ) 2285 2292 !!--------------------------------------------------------------------- 2286 2293 !! *** routine mpp_init.opa *** … … 2294 2301 !! 08/04 :: R. Benshila, generalisation 2295 2302 !!--------------------------------------------------------------------- 2296 INTEGER :: code, ierr 2297 LOGICAL :: mpi_was_called 2303 CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt 2304 INTEGER , INTENT(inout) :: ksft 2305 INTEGER , INTENT( out) :: code 2306 INTEGER :: ierr, ji 2307 LOGICAL :: mpi_was_called 2298 2308 !!--------------------------------------------------------------------- 2299 2309 ! 2300 2310 CALL mpi_initialized( mpi_was_called, code ) ! MPI initialization 2301 2311 IF ( code /= MPI_SUCCESS ) THEN 2302 CALL ctl_stop( ' lib_mpp: Error in routine mpi_initialized' ) 2312 DO ji = 1, SIZE(ldtxt) 2313 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode 2314 END DO 2315 WRITE(*, cform_err) 2316 WRITE(*, *) ' lib_mpp: Error in routine mpi_initialized' 2303 2317 CALL mpi_abort( mpi_comm_world, code, ierr ) 2304 2318 ENDIF … … 2308 2322 CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code ) 2309 2323 IF ( code /= MPI_SUCCESS ) THEN 2310 CALL ctl_stop( ' lib_mpp: Error in routine mpi_comm_dup' ) 2324 DO ji = 1, SIZE(ldtxt) 2325 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode 2326 END DO 2327 WRITE(*, cform_err) 2328 WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup' 2311 2329 CALL mpi_abort( mpi_comm_world, code, ierr ) 2312 2330 ENDIF … … 2314 2332 ! 2315 2333 IF( nn_buffer > 0 ) THEN 2316 IF ( lwp ) WRITE(numout,*) 'mpi_bsend, buffer allocation of : ', nn_buffer2334 WRITE(ldtxt(ksft),*) 'mpi_bsend, buffer allocation of : ', nn_buffer ; ksft = ksft + 1 2317 2335 ! Buffer allocation and attachment 2318 ALLOCATE( tampon(nn_buffer) ) 2319 CALL mpi_buffer_attach( tampon, nn_buffer,code ) 2336 ALLOCATE( tampon(nn_buffer), stat = ierr ) 2337 IF (ierr /= 0) THEN 2338 DO ji = 1, SIZE(ldtxt) 2339 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode 2340 END DO 2341 WRITE(*, cform_err) 2342 WRITE(*, *) ' lib_mpp: Error in ALLOCATE', ierr 2343 CALL mpi_abort( mpi_comm_world, code, ierr ) 2344 END IF 2345 CALL mpi_buffer_attach( tampon, nn_buffer, code ) 2320 2346 ENDIF 2321 2347 !
Note: See TracChangeset
for help on using the changeset viewer.
