Changeset 2480
- Timestamp:
- 2010-12-17T17:46: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
r2442 r2480 53 53 !! ! 09 (R. Benshila) SHMEM suppression, north fold in lbc_nfd 54 54 !!---------------------------------------------------------------------- 55 !! NEMO/OPA 3.3 , NEMO Consortium (2010)56 !! $Id$57 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)58 !!---------------------------------------------------------------------59 !! * Modules used60 55 USE dom_oce ! ocean space and time domain 61 56 USE in_out_manager ! I/O manager … … 69 64 PUBLIC mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 70 65 PUBLIC mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e 71 PUBLIC mpprecv, mppsend, mppscatter, mppgather72 66 PUBLIC mppobc, mpp_ini_ice, mpp_ini_znl 73 PUBLIC mppsize, mpprank74 67 75 68 !! * Interfaces … … 118 111 !$AGRIF_END_DO_NOT_TREAT 119 112 120 INTEGER, PUBLIC :: MPI_SUMDD 113 # if defined key_mpp_rep 114 INTEGER :: MPI_SUMDD 115 # endif 121 116 122 117 ! variables used in case of sea-ice … … 197 192 WRITE(ldtxt(6),*) ' size in bytes of exported buffer nn_buffer = ', nn_buffer 198 193 199 #if defined key_agrif 200 IF( Agrif_Root() ) THEN 201 #endif 202 !!bug RB : should be clean to use Agrif in coupled mode 203 #if ! defined key_agrif 204 CALL mpi_initialized ( mpi_was_called, code ) 205 IF( code /= MPI_SUCCESS ) THEN 206 WRITE(*, cform_err) 207 WRITE(*, *) 'lib_mpp: Error in routine mpi_initialized' 208 CALL mpi_abort( mpi_comm_world, code, ierr ) 209 ENDIF 210 211 IF( PRESENT(localComm) .and. mpi_was_called ) THEN 212 mpi_comm_opa = localComm 213 SELECT CASE ( cn_mpi_send ) 214 CASE ( 'S' ) ! Standard mpi send (blocking) 215 WRITE(ldtxt(7),*) ' Standard blocking mpi send (send)' 216 CASE ( 'B' ) ! Buffer mpi send (blocking) 217 WRITE(ldtxt(7),*) ' Buffer blocking mpi send (bsend)' 218 CALL mpi_init_opa( ierr ) 219 CASE ( 'I' ) ! Immediate mpi send (non-blocking send) 220 WRITE(ldtxt(7),*) ' Immediate non-blocking send (isend)' 221 l_isend = .TRUE. 222 CASE DEFAULT 223 WRITE(ldtxt(7),cform_err) 224 WRITE(ldtxt(8),*) ' bad value for cn_mpi_send = ', cn_mpi_send 225 nstop = nstop + 1 226 END SELECT 227 ELSE IF ( PRESENT(localComm) .and. .not. mpi_was_called ) THEN 228 WRITE(ldtxt(7),*) ' lib_mpp: You cannot provide a local communicator ' 229 WRITE(ldtxt(8),*) ' without calling MPI_Init before ! ' 230 nstop = nstop + 1 231 ELSE 232 #endif 233 SELECT CASE ( cn_mpi_send ) 234 CASE ( 'S' ) ! Standard mpi send (blocking) 235 WRITE(ldtxt(7),*) ' Standard blocking mpi send (send)' 236 CALL mpi_init( ierr ) 237 CASE ( 'B' ) ! Buffer mpi send (blocking) 238 WRITE(ldtxt(7),*) ' Buffer blocking mpi send (bsend)' 239 CALL mpi_init_opa( ierr ) 240 CASE ( 'I' ) ! Immediate mpi send (non-blocking send) 241 WRITE(ldtxt(7),*) ' Immediate non-blocking send (isend)' 242 l_isend = .TRUE. 243 CALL mpi_init( ierr ) 244 CASE DEFAULT 245 WRITE(ldtxt(7),cform_err) 246 WRITE(ldtxt(8),*) ' bad value for cn_mpi_send = ', cn_mpi_send 247 nstop = nstop + 1 248 END SELECT 249 250 #if ! defined key_agrif 251 CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code) 252 IF( code /= MPI_SUCCESS ) THEN 253 WRITE(*, cform_err) 254 WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup' 255 CALL mpi_abort( mpi_comm_world, code, ierr ) 256 ENDIF 257 ! 258 ENDIF 259 #endif 260 #if defined key_agrif 261 ELSE 194 CALL mpi_initialized ( mpi_was_called, code ) 195 IF( code /= MPI_SUCCESS ) THEN 196 WRITE(*, cform_err) 197 WRITE(*, *) 'lib_mpp: Error in routine mpi_initialized' 198 CALL mpi_abort( mpi_comm_world, code, ierr ) 199 ENDIF 200 201 IF( mpi_was_called ) THEN 202 ! 262 203 SELECT CASE ( cn_mpi_send ) 263 204 CASE ( 'S' ) ! Standard mpi send (blocking) … … 265 206 CASE ( 'B' ) ! Buffer mpi send (blocking) 266 207 WRITE(ldtxt(7),*) ' Buffer blocking mpi send (bsend)' 208 CALL mpi_init_opa( ierr ) 267 209 CASE ( 'I' ) ! Immediate mpi send (non-blocking send) 268 210 WRITE(ldtxt(7),*) ' Immediate non-blocking send (isend)' … … 273 215 nstop = nstop + 1 274 216 END SELECT 217 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 ! ' 220 nstop = nstop + 1 221 ELSE 222 SELECT CASE ( cn_mpi_send ) 223 CASE ( 'S' ) ! Standard mpi send (blocking) 224 WRITE(ldtxt(7),*) ' Standard blocking mpi send (send)' 225 CALL mpi_init( ierr ) 226 CASE ( 'B' ) ! Buffer mpi send (blocking) 227 WRITE(ldtxt(7),*) ' Buffer blocking mpi send (bsend)' 228 CALL mpi_init_opa( ierr ) 229 CASE ( 'I' ) ! Immediate mpi send (non-blocking send) 230 WRITE(ldtxt(7),*) ' Immediate non-blocking send (isend)' 231 l_isend = .TRUE. 232 CALL mpi_init( ierr ) 233 CASE DEFAULT 234 WRITE(ldtxt(7),cform_err) 235 WRITE(ldtxt(8),*) ' bad value for cn_mpi_send = ', cn_mpi_send 236 nstop = nstop + 1 237 END SELECT 238 ! 275 239 ENDIF 276 240 277 mpi_comm_opa = mpi_comm_world 278 #endif 241 IF( PRESENT(localComm) ) THEN 242 IF( Agrif_Root() ) THEN 243 mpi_comm_opa = localComm 244 ENDIF 245 ELSE 246 CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code) 247 IF( code /= MPI_SUCCESS ) THEN 248 WRITE(*, cform_err) 249 WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup' 250 CALL mpi_abort( mpi_comm_world, code, ierr ) 251 ENDIF 252 ENDIF 253 279 254 CALL mpi_comm_rank( mpi_comm_opa, mpprank, ierr ) 280 255 CALL mpi_comm_size( mpi_comm_opa, mppsize, ierr ) 281 256 mynode = mpprank 282 ! 257 ! 283 258 #if defined key_mpp_rep 284 259 CALL MPI_OP_CREATE(DDPDD_MPI, .TRUE., MPI_SUMDD, ierr) … … 2131 2106 ijpj = 4 2132 2107 ijpjm1 = 3 2108 ztab(:,:,:) = 0.e0 2133 2109 ! 2134 2110 DO jj = nlcj - ijpj +1, nlcj ! put in znorthloc the last 4 jlines of pt3d … … 2196 2172 ijpj = 4 2197 2173 ijpjm1 = 3 2174 ztab(:,:) = 0.e0 2198 2175 ! 2199 2176 DO jj = nlcj-ijpj+1, nlcj ! put in znorthloc the last 4 jlines of pt2d … … 2261 2238 ! 2262 2239 ijpj=4 2240 ztab(:,:) = 0.e0 2263 2241 2264 2242 ij=0 … … 2381 2359 2382 2360 INTERFACE mpp_sum 2383 MODULE PROCEDURE mpp_sum_a2s, mpp_sum_as, mpp_sum_ai, mpp_sum_s, mpp_sum_i, & 2384 & mpp_sum_c, mpp_sum_ac 2361 MODULE PROCEDURE mpp_sum_a2s, mpp_sum_as, mpp_sum_ai, mpp_sum_s, mpp_sum_i 2385 2362 END INTERFACE 2386 2363 INTERFACE mpp_max … … 2400 2377 END INTERFACE 2401 2378 2379 2402 2380 LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .FALSE. !: mpp flag 2403 2381 INTEGER :: ncomm_ice … … 2436 2414 END SUBROUTINE mpp_sum_ai 2437 2415 2438 SUBROUTINE mpp_sum_ac( yarr, kdim, kcom ) ! Dummy routine2439 COMPLEX, DIMENSION(:) :: yarr2440 INTEGER :: kdim2441 INTEGER, OPTIONAL :: kcom2442 WRITE(*,*) 'mpp_sum_ac: You should not have seen this print! error?', kdim, yarr(1), kcom2443 END SUBROUTINE mpp_sum_ac2444 2445 2416 SUBROUTINE mpp_sum_s( psca, kcom ) ! Dummy routine 2446 2417 REAL :: psca … … 2448 2419 WRITE(*,*) 'mpp_sum_s: You should not have seen this print! error?', psca, kcom 2449 2420 END SUBROUTINE mpp_sum_s 2450 2421 2451 2422 SUBROUTINE mpp_sum_i( kint, kcom ) ! Dummy routine 2452 2423 integer :: kint 2453 INTEGER, OPTIONAL :: kcom 2424 INTEGER, OPTIONAL :: kcom 2454 2425 WRITE(*,*) 'mpp_sum_i: You should not have seen this print! error?', kint, kcom 2455 2426 END SUBROUTINE mpp_sum_i 2456 2457 SUBROUTINE mpp_sum_c( ysca, kcom ) ! Dummy routine2458 COMPLEX :: ysca2459 INTEGER, OPTIONAL :: kcom2460 WRITE(*,*) 'mpp_sum_c: You should not have seen this print! error?', ysca, kcom2461 END SUBROUTINE mpp_sum_c2462 2427 2463 2428 SUBROUTINE mppmax_a_real( parr, kdim, kcom )
Note: See TracChangeset
for help on using the changeset viewer.
