Changeset 1920 for branches/DEV_1879_mpp_rep/NEMO/OPA_SRC/lib_mpp.F90
- Timestamp:
- 2010-06-07T13:45:58+02:00 (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/DEV_1879_mpp_rep/NEMO/OPA_SRC/lib_mpp.F90
r1874 r1920 75 75 #endif 76 76 77 # if defined key_mpp_rep1 78 PUBLIC mpp_allgatherv 79 # endif 80 77 81 !! * Interfaces 78 82 !! define generic interface for these routine as they are called sometimes … … 86 90 END INTERFACE 87 91 INTERFACE mpp_sum 92 # if defined key_mpp_rep2 93 MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real, & 94 mppsum_realdd, mppsum_a_realdd 95 # else 88 96 MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real 97 # endif 89 98 END INTERFACE 90 99 INTERFACE mpp_lbc_north … … 97 106 MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 98 107 END INTERFACE 99 108 109 # if defined key_mpp_rep1 110 INTERFACE mpp_allgatherv 111 MODULE PROCEDURE mpp_allgatherv_real, mpp_allgatherv_int 112 END INTERFACE 113 # endif 100 114 101 115 !! ========================= !! … … 112 126 INTEGER :: mppsize ! number of process 113 127 INTEGER :: mpprank ! process number [ 0 - size-1 ] 114 !$AGRIF_DO_NOT_TREAT 115 INTEGER, PUBLIC :: mpi_comm_opa ! opa local communicator 116 !$AGRIF_END_DO_NOT_TREAT 128 INTEGER :: mpi_comm_opa ! opa local communicator 129 130 INTEGER, PUBLIC :: MPI_SUMDD 117 131 118 132 ! variables used in case of sea-ice … … 193 207 WRITE(ldtxt(6),*) ' size in bytes of exported buffer nn_buffer = ', nn_buffer 194 208 195 CALL mpi_initialized ( mpi_was_called, code ) 196 IF( code /= MPI_SUCCESS ) THEN 197 WRITE(*, cform_err) 198 WRITE(*, *) 'lib_mpp: Error in routine mpi_initialized' 199 CALL mpi_abort( mpi_comm_world, code, ierr ) 200 ENDIF 201 202 IF( mpi_was_called ) THEN 203 ! 209 #if defined key_agrif 210 IF( Agrif_Root() ) THEN 211 #endif 212 !!bug RB : should be clean to use Agrif in coupled mode 213 #if ! defined key_agrif 214 CALL mpi_initialized ( mpi_was_called, code ) 215 IF( code /= MPI_SUCCESS ) THEN 216 WRITE(*, cform_err) 217 WRITE(*, *) 'lib_mpp: Error in routine mpi_initialized' 218 CALL mpi_abort( mpi_comm_world, code, ierr ) 219 ENDIF 220 221 IF( PRESENT(localComm) .and. mpi_was_called ) THEN 222 mpi_comm_opa = localComm 223 SELECT CASE ( cn_mpi_send ) 224 CASE ( 'S' ) ! Standard mpi send (blocking) 225 WRITE(ldtxt(7),*) ' Standard blocking mpi send (send)' 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 CASE DEFAULT 233 WRITE(ldtxt(7),cform_err) 234 WRITE(ldtxt(8),*) ' bad value for cn_mpi_send = ', cn_mpi_send 235 nstop = nstop + 1 236 END SELECT 237 ELSE IF ( PRESENT(localComm) .and. .not. mpi_was_called ) THEN 238 WRITE(ldtxt(7),*) ' lib_mpp: You cannot provide a local communicator ' 239 WRITE(ldtxt(8),*) ' without calling MPI_Init before ! ' 240 nstop = nstop + 1 241 ELSE 242 #endif 243 SELECT CASE ( cn_mpi_send ) 244 CASE ( 'S' ) ! Standard mpi send (blocking) 245 WRITE(ldtxt(7),*) ' Standard blocking mpi send (send)' 246 CALL mpi_init( ierr ) 247 CASE ( 'B' ) ! Buffer mpi send (blocking) 248 WRITE(ldtxt(7),*) ' Buffer blocking mpi send (bsend)' 249 CALL mpi_init_opa( ierr ) 250 CASE ( 'I' ) ! Immediate mpi send (non-blocking send) 251 WRITE(ldtxt(7),*) ' Immediate non-blocking send (isend)' 252 l_isend = .TRUE. 253 CALL mpi_init( ierr ) 254 CASE DEFAULT 255 WRITE(ldtxt(7),cform_err) 256 WRITE(ldtxt(8),*) ' bad value for cn_mpi_send = ', cn_mpi_send 257 nstop = nstop + 1 258 END SELECT 259 260 #if ! defined key_agrif 261 CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code) 262 IF( code /= MPI_SUCCESS ) THEN 263 WRITE(*, cform_err) 264 WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup' 265 CALL mpi_abort( mpi_comm_world, code, ierr ) 266 ENDIF 267 ! 268 ENDIF 269 #endif 270 #if defined key_agrif 271 ELSE 204 272 SELECT CASE ( cn_mpi_send ) 205 273 CASE ( 'S' ) ! Standard mpi send (blocking) … … 207 275 CASE ( 'B' ) ! Buffer mpi send (blocking) 208 276 WRITE(ldtxt(7),*) ' Buffer blocking mpi send (bsend)' 209 CALL mpi_init_opa( ierr )210 277 CASE ( 'I' ) ! Immediate mpi send (non-blocking send) 211 278 WRITE(ldtxt(7),*) ' Immediate non-blocking send (isend)' … … 216 283 nstop = nstop + 1 217 284 END SELECT 218 ELSE IF ( PRESENT(localComm) .and. .not. mpi_was_called ) THEN219 WRITE(ldtxt(7),*) ' lib_mpp: You cannot provide a local communicator '220 WRITE(ldtxt(8),*) ' without calling MPI_Init before ! '221 nstop = nstop + 1222 ELSE223 SELECT CASE ( cn_mpi_send )224 CASE ( 'S' ) ! Standard mpi send (blocking)225 WRITE(ldtxt(7),*) ' Standard blocking mpi send (send)'226 CALL mpi_init( ierr )227 CASE ( 'B' ) ! Buffer mpi send (blocking)228 WRITE(ldtxt(7),*) ' Buffer blocking mpi send (bsend)'229 CALL mpi_init_opa( ierr )230 CASE ( 'I' ) ! Immediate mpi send (non-blocking send)231 WRITE(ldtxt(7),*) ' Immediate non-blocking send (isend)'232 l_isend = .TRUE.233 CALL mpi_init( ierr )234 CASE DEFAULT235 WRITE(ldtxt(7),cform_err)236 WRITE(ldtxt(8),*) ' bad value for cn_mpi_send = ', cn_mpi_send237 nstop = nstop + 1238 END SELECT239 !240 285 ENDIF 241 286 242 IF( PRESENT(localComm) ) THEN 243 IF( Agrif_Root() ) THEN 244 mpi_comm_opa = localComm 245 ENDIF 246 ELSE 247 CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code) 248 IF( code /= MPI_SUCCESS ) THEN 249 WRITE(*, cform_err) 250 WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup' 251 CALL mpi_abort( mpi_comm_world, code, ierr ) 252 ENDIF 253 ENDIF 254 287 mpi_comm_opa = mpi_comm_world 288 #endif 255 289 CALL mpi_comm_rank( mpi_comm_opa, mpprank, ierr ) 256 290 CALL mpi_comm_size( mpi_comm_opa, mppsize, ierr ) 257 291 mynode = mpprank 292 ! 293 #if defined key_mpp_rep2 294 CALL MPI_OP_CREATE(DDPDD_MPI, .TRUE., MPI_SUMDD, ierr) 295 #endif 258 296 ! 259 297 END FUNCTION mynode … … 1394 1432 END SUBROUTINE mppsum_real 1395 1433 1396 1434 # if defined key_mpp_rep2 1435 SUBROUTINE mppsum_realdd( ytab, kcom ) 1436 !!---------------------------------------------------------------------- 1437 !! *** routine mppsum_realdd *** 1438 !! 1439 !! ** Purpose : global sum in Massively Parallel Processing 1440 !! SCALAR argument case for double-double precision 1441 !! 1442 !!----------------------------------------------------------------------- 1443 COMPLEX(wp), INTENT(inout) :: ytab ! input scalar 1444 INTEGER , INTENT( in ), OPTIONAL :: kcom 1445 1446 !! * Local variables (MPI version) 1447 INTEGER :: ierror 1448 INTEGER :: localcomm 1449 COMPLEX(wp) :: zwork 1450 1451 localcomm = mpi_comm_opa 1452 IF( PRESENT(kcom) ) localcomm = kcom 1453 1454 ! reduce local sums into global sum 1455 CALL MPI_ALLREDUCE (ytab, zwork, 1, MPI_DOUBLE_COMPLEX, & 1456 MPI_SUMDD,localcomm,ierror) 1457 ytab = zwork 1458 1459 END SUBROUTINE mppsum_realdd 1460 1461 1462 SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom ) 1463 !!---------------------------------------------------------------------- 1464 !! *** routine mppsum_a_realdd *** 1465 !! 1466 !! ** Purpose : global sum in Massively Parallel Processing 1467 !! COMPLEX ARRAY case for double-double precision 1468 !! 1469 !!----------------------------------------------------------------------- 1470 INTEGER , INTENT( in ) :: kdim ! size of ytab 1471 COMPLEX(wp), DIMENSION(kdim), INTENT( inout ) :: ytab ! input array 1472 INTEGER , INTENT( in ), OPTIONAL :: kcom 1473 1474 !! * Local variables (MPI version) 1475 INTEGER :: ierror ! temporary integer 1476 INTEGER :: localcomm 1477 COMPLEX(wp), DIMENSION(kdim) :: zwork ! temporary workspace 1478 1479 localcomm = mpi_comm_opa 1480 IF( PRESENT(kcom) ) localcomm = kcom 1481 1482 CALL MPI_ALLREDUCE (ytab, zwork, kdim, MPI_DOUBLE_COMPLEX, & 1483 MPI_SUMDD,localcomm,ierror) 1484 ytab(:) = zwork(:) 1485 1486 END SUBROUTINE mppsum_a_realdd 1487 # endif 1488 1397 1489 SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki,kj ) 1398 1490 !!------------------------------------------------------------------------ … … 2049 2141 ijpj = 4 2050 2142 ijpjm1 = 3 2051 ztab(:,:,:) = 0.e02052 2143 ! 2053 2144 DO jj = nlcj - ijpj +1, nlcj ! put in znorthloc the last 4 jlines of pt3d … … 2115 2206 ijpj = 4 2116 2207 ijpjm1 = 3 2117 ztab(:,:) = 0.e02118 2208 ! 2119 2209 DO jj = nlcj-ijpj+1, nlcj ! put in znorthloc the last 4 jlines of pt2d … … 2181 2271 ! 2182 2272 ijpj=4 2183 ztab(:,:) = 0.e02184 2273 2185 2274 ij=0 … … 2265 2354 END SUBROUTINE mpi_init_opa 2266 2355 2356 #if defined key_mpp_rep1 2357 SUBROUTINE mpp_allgatherv_real( pvalsin, knoin, pvalsout, ksizeout, & 2358 & knoout, kstartout ) 2359 !!---------------------------------------------------------------------- 2360 !! *** ROUTINE mpp_allgatherv_real *** 2361 !! 2362 !! ** Purpose : Gather a real array on all processors 2363 !! 2364 !! ** Method : MPI all gatherv 2365 !! 2366 !! ** Action : This does only work for MPI. 2367 !! It does not work for SHMEM. 2368 !! 2369 !! References : http://www.mpi-forum.org 2370 !! 2371 !! History : 2372 !! ! 08-08 (K. Mogensen) Original code 2373 !!---------------------------------------------------------------------- 2374 2375 !! * Arguments 2376 INTEGER, INTENT(IN) :: & 2377 & knoin, & 2378 & ksizeout 2379 REAL(wp), DIMENSION(knoin), INTENT(IN) :: & 2380 & pvalsin 2381 REAL(wp), DIMENSION(ksizeout), INTENT(OUT) :: & 2382 & pvalsout 2383 INTEGER, DIMENSION(jpnij), INTENT(OUT) :: & 2384 & kstartout, & 2385 & knoout 2386 2387 !! * Local declarations 2388 INTEGER :: & 2389 & ierr 2390 INTEGER :: & 2391 & ji 2392 !----------------------------------------------------------------------- 2393 ! Call the MPI library to get number of data per processor 2394 !----------------------------------------------------------------------- 2395 CALL mpi_allgather( knoin, 1, mpi_integer, & 2396 & knoout, 1, mpi_integer, & 2397 & mpi_comm_opa, ierr ) 2398 !----------------------------------------------------------------------- 2399 ! Compute starts of each processors contribution 2400 !----------------------------------------------------------------------- 2401 kstartout(1) = 0 2402 DO ji = 2, jpnij 2403 kstartout(ji) = kstartout(ji-1) + knoout(ji-1) 2404 ENDDO 2405 !----------------------------------------------------------------------- 2406 ! Call the MPI library to do the gathering of the data 2407 !----------------------------------------------------------------------- 2408 CALL mpi_allgatherv( pvalsin, knoin, MPI_DOUBLE_PRECISION, & 2409 & pvalsout, knoout, kstartout, MPI_DOUBLE_PRECISION, & 2410 & mpi_comm_opa, ierr ) 2411 2412 END SUBROUTINE mpp_allgatherv_real 2413 2414 SUBROUTINE mpp_allgatherv_int( kvalsin, knoin, kvalsout, ksizeout, & 2415 & knoout, kstartout ) 2416 !!---------------------------------------------------------------------- 2417 !! *** ROUTINE mpp_allgatherv *** 2418 !! 2419 !! ** Purpose : Gather an integer array on all processors 2420 !! 2421 !! ** Method : MPI all gatherv 2422 !! 2423 !! ** Action : This does only work for MPI. 2424 !! It does not work for SHMEM. 2425 !! 2426 !! References : http://www.mpi-forum.org 2427 !! 2428 !! History : 2429 !! ! 06-07 (K. Mogensen) Original code 2430 !!---------------------------------------------------------------------- 2431 2432 !! * Arguments 2433 INTEGER, INTENT(IN) :: & 2434 & knoin, & 2435 & ksizeout 2436 INTEGER, DIMENSION(knoin), INTENT(IN) :: & 2437 & kvalsin 2438 INTEGER, DIMENSION(ksizeout), INTENT(OUT) :: & 2439 & kvalsout 2440 INTEGER, DIMENSION(jpnij), INTENT(OUT) :: & 2441 & kstartout, & 2442 & knoout 2443 2444 !! * Local declarations 2445 INTEGER :: & 2446 & ierr 2447 INTEGER :: & 2448 & ji 2449 !----------------------------------------------------------------------- 2450 ! Call the MPI library to get number of data per processor 2451 !----------------------------------------------------------------------- 2452 CALL mpi_allgather( knoin, 1, mpi_integer, & 2453 & knoout, 1, mpi_integer, & 2454 & mpi_comm_opa, ierr ) 2455 !----------------------------------------------------------------------- 2456 ! Compute starts of each processors contribution 2457 !----------------------------------------------------------------------- 2458 kstartout(1) = 0 2459 DO ji = 2, jpnij 2460 kstartout(ji) = kstartout(ji-1) + knoout(ji-1) 2461 ENDDO 2462 !----------------------------------------------------------------------- 2463 ! Call the MPI library to do the gathering of the data 2464 !----------------------------------------------------------------------- 2465 CALL mpi_allgatherv( kvalsin, knoin, mpi_integer, & 2466 & kvalsout, knoout, kstartout, mpi_integer, & 2467 & mpi_comm_opa, ierr ) 2468 2469 END SUBROUTINE mpp_allgatherv_int 2470 #endif 2471 2472 #if defined key_mpp_rep2 2473 SUBROUTINE DDPDD_MPI (ydda, yddb, ilen, itype) 2474 !!--------------------------------------------------------------------- 2475 !! Routine DDPDD_MPI: used by reduction operator MPI_SUMDD 2476 !! 2477 !! Modification of original codes written by David H. Bailey 2478 !! This subroutine computes yddb(i) = ydda(i)+yddb(i) 2479 !!--------------------------------------------------------------------- 2480 INTEGER, INTENT(in) :: ilen, itype 2481 COMPLEX(wp), DIMENSION(ilen), INTENT(in) :: ydda 2482 COMPLEX(wp), DIMENSION(ilen), INTENT(inout) :: yddb 2483 ! 2484 REAL(wp) :: zerr, zt1, zt2 ! local work variables 2485 INTEGER :: ji, ztmp ! local scalar 2486 2487 ztmp = itype ! avoid compilation warning 2488 2489 DO ji=1,ilen 2490 ! Compute ydda + yddb using Knuth's trick. 2491 zt1 = real(ydda(ji)) + real(yddb(ji)) 2492 zerr = zt1 - real(ydda(ji)) 2493 zt2 = ((real(yddb(ji)) - zerr) + (real(ydda(ji)) - (zt1 - zerr))) & 2494 + aimag(ydda(ji)) + aimag(yddb(ji)) 2495 2496 ! The result is zt1 + zt2, after normalization. 2497 yddb(ji) = cmplx ( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1),wp ) 2498 END DO 2499 2500 END SUBROUTINE DDPDD_MPI 2501 #endif 2502 2267 2503 #else 2268 2504 !!---------------------------------------------------------------------- 2269 2505 !! Default case: Dummy module share memory computing 2270 2506 !!---------------------------------------------------------------------- 2507 # if defined key_mpp_rep1 2508 USE par_kind 2509 USE par_oce 2510 2511 PUBLIC mpp_allgatherv 2512 # endif 2513 2271 2514 INTERFACE mpp_sum 2272 MODULE PROCEDURE mpp_sum_a2s, mpp_sum_as, mpp_sum_ai, mpp_sum_s, mpp_sum_i 2515 MODULE PROCEDURE mpp_sum_a2s, mpp_sum_as, mpp_sum_ai, mpp_sum_s, mpp_sum_i, & 2516 & mpp_sum_c, mpp_sum_ac 2273 2517 END INTERFACE 2274 2518 INTERFACE mpp_max … … 2288 2532 END INTERFACE 2289 2533 2534 # if defined key_mpp_rep1 2535 INTERFACE mpp_allgatherv 2536 MODULE PROCEDURE mpp_allgatherv_real, mpp_allgatherv_int 2537 END INTERFACE 2538 # endif 2539 2290 2540 2291 2541 LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .FALSE. !: mpp flag … … 2325 2575 END SUBROUTINE mpp_sum_ai 2326 2576 2577 SUBROUTINE mpp_sum_ac( yarr, kdim, kcom ) ! Dummy routine 2578 COMPLEX, DIMENSION(:) :: yarr 2579 INTEGER :: kdim 2580 INTEGER, OPTIONAL :: kcom 2581 WRITE(*,*) 'mpp_sum_ac: You should not have seen this print! error?', kdim, yarr(1), kcom 2582 END SUBROUTINE mpp_sum_ac 2583 2327 2584 SUBROUTINE mpp_sum_s( psca, kcom ) ! Dummy routine 2328 2585 REAL :: psca … … 2330 2587 WRITE(*,*) 'mpp_sum_s: You should not have seen this print! error?', psca, kcom 2331 2588 END SUBROUTINE mpp_sum_s 2332 2589 2333 2590 SUBROUTINE mpp_sum_i( kint, kcom ) ! Dummy routine 2334 2591 integer :: kint 2335 INTEGER, OPTIONAL :: kcom 2592 INTEGER, OPTIONAL :: kcom 2336 2593 WRITE(*,*) 'mpp_sum_i: You should not have seen this print! error?', kint, kcom 2337 2594 END SUBROUTINE mpp_sum_i 2595 2596 SUBROUTINE mpp_sum_c( ysca, kcom ) ! Dummy routine 2597 COMPLEX :: ysca 2598 INTEGER, OPTIONAL :: kcom 2599 WRITE(*,*) 'mpp_sum_c: You should not have seen this print! error?', ysca, kcom 2600 END SUBROUTINE mpp_sum_c 2338 2601 2339 2602 SUBROUTINE mppmax_a_real( parr, kdim, kcom ) … … 2459 2722 END SUBROUTINE mpp_comm_free 2460 2723 2724 # if defined key_mpp_rep1 2725 SUBROUTINE mpp_allgatherv_real( pvalsin, knoin, pvalsout, ksizeout, & 2726 & knoout, kstartout ) 2727 INTEGER, INTENT(IN) :: & 2728 & knoin, & 2729 & ksizeout 2730 REAL(wp), DIMENSION(knoin), INTENT(IN) :: & 2731 & pvalsin 2732 REAL(wp), DIMENSION(ksizeout), INTENT(OUT) :: & 2733 & pvalsout 2734 INTEGER, DIMENSION(jpnij), INTENT(OUT) :: & 2735 & kstartout, & 2736 & knoout 2737 pvalsout(1:knoin) = pvalsin(1:knoin) 2738 kstartout(1) = 0 2739 knoout(1) = knoin 2740 END SUBROUTINE mpp_allgatherv_real 2741 2742 SUBROUTINE mpp_allgatherv_int( kvalsin, knoin, kvalsout, ksizeout, & 2743 & knoout, kstartout ) 2744 INTEGER, INTENT(IN) :: & 2745 & knoin, & 2746 & ksizeout 2747 INTEGER, DIMENSION(knoin), INTENT(IN) :: & 2748 & kvalsin 2749 INTEGER, DIMENSION(ksizeout), INTENT(OUT) :: & 2750 & kvalsout 2751 INTEGER, DIMENSION(jpnij), INTENT(OUT) :: & 2752 & kstartout, & 2753 & knoout 2754 2755 kvalsout(1:knoin) = kvalsin(1:knoin) 2756 kstartout(1) = 0 2757 knoout(1) = knoin 2758 END SUBROUTINE mpp_allgatherv_int 2759 # endif 2760 2461 2761 #endif 2462 2762 !!----------------------------------------------------------------------
Note: See TracChangeset
for help on using the changeset viewer.