Changeset 496 for trunk/NEMO/OFF_SRC/lib_mpp.F90
- Timestamp:
- 2006-09-12T12:59:38+02:00 (18 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/NEMO/OFF_SRC/lib_mpp.F90
r343 r496 14 14 !! mpp_lnk : generic interface (defined in lbclnk) for : 15 15 !! mpp_lnk_2d, mpp_lnk_3d 16 !! mpp_lnk_3d_gather : Message passing manadgement for two 3D arrays 16 17 !! mpp_lnk_e : interface defined in lbclnk 17 18 !! mpplnks … … 28 29 !! mpp_sum : generic interface for : 29 30 !! mppsum_int , mppsum_a_int , mppsum_real, mppsum_a_real 31 !! mpp_minloc 32 !! mpp_maxloc 30 33 !! mppsync 31 34 !! mppstop … … 48 51 !!--------------------------------------------------------------------- 49 52 !! * Modules used 50 USE dom_oce ! ocean space and time domain51 USE in_out_manager ! I/O manager53 USE dom_oce ! ocean space and time domain 54 USE in_out_manager ! I/O manager 52 55 53 56 IMPLICIT NONE 57 58 PRIVATE 59 PUBLIC mynode, mpparent, mpp_isl, mpp_min, mpp_max, mpp_sum, mpp_lbc_north 60 PUBLIC mpp_lbc_north_e, mpp_minloc, mpp_maxloc, mpp_lnk_3d, mpp_lnk_2d, mpp_lnk_3d_gather, mpp_lnk_2d_e, mpplnks 61 PUBLIC mpprecv, mppsend, mppscatter, mppgather, mppobc, mpp_ini_north, mppstop, mppsync 54 62 55 63 !! * Interfaces … … 84 92 LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .TRUE. !: mpp flag 85 93 86 87 !! * Module variables88 94 !! The processor number is a required power of two : 1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024,... 89 95 INTEGER, PARAMETER :: & … … 95 101 !! MPI variable definition !! 96 102 !! ========================= !! 103 !$AGRIF_DO_NOT_TREAT 97 104 # include <mpif.h> 105 !$AGRIF_END_DO_NOT_TREAT 98 106 99 107 INTEGER :: & … … 234 242 #endif 235 243 244 REAL(wp), DIMENSION(jpi,jprecj,jpk,2,2) :: & 245 t4ns, t4sn ! 3d message passing arrays north-south & south-north 246 REAL(wp), DIMENSION(jpj,jpreci,jpk,2,2) :: & 247 t4ew, t4we ! 3d message passing arrays east-west & west-east 248 REAL(wp), DIMENSION(jpi,jprecj,jpk,2,2) :: & 249 t4p1, t4p2 ! 3d message passing arrays north fold 236 250 REAL(wp), DIMENSION(jpi,jprecj,jpk,2) :: & 237 251 t3ns, t3sn ! 3d message passing arrays north-south & south-north … … 283 297 WRITE(numout,*) ' mpi send type c_mpi_send = ', c_mpi_send 284 298 285 SELECT CASE ( c_mpi_send ) 286 CASE ( 'S' ) ! Standard mpi send (blocking) 287 WRITE(numout,*) ' Standard blocking mpi send (send)' 288 CALL mpi_init( ierr ) 289 CASE ( 'B' ) ! Buffer mpi send (blocking) 290 WRITE(numout,*) ' Buffer blocking mpi send (bsend)' 291 CALL mpi_init_opa( ierr ) 292 CASE ( 'I' ) ! Immediate mpi send (non-blocking send) 293 WRITE(numout,*) ' Immediate non-blocking send (isend)' 294 l_isend = .TRUE. 295 CALL mpi_init( ierr ) 296 CASE DEFAULT 297 WRITE(numout,cform_err) 298 WRITE(numout,*) ' bad value for c_mpi_send = ', c_mpi_send 299 nstop = nstop + 1 300 END SELECT 299 #if defined key_agrif 300 IF( Agrif_Root() ) THEN 301 #endif 302 SELECT CASE ( c_mpi_send ) 303 CASE ( 'S' ) ! Standard mpi send (blocking) 304 WRITE(numout,*) ' Standard blocking mpi send (send)' 305 CALL mpi_init( ierr ) 306 CASE ( 'B' ) ! Buffer mpi send (blocking) 307 WRITE(numout,*) ' Buffer blocking mpi send (bsend)' 308 CALL mpi_init_opa( ierr ) 309 CASE ( 'I' ) ! Immediate mpi send (non-blocking send) 310 WRITE(numout,*) ' Immediate non-blocking send (isend)' 311 l_isend = .TRUE. 312 CALL mpi_init( ierr ) 313 CASE DEFAULT 314 WRITE(ctmp1,*) ' bad value for c_mpi_send = ', c_mpi_send 315 CALL ctl_stop( ctmp1 ) 316 END SELECT 317 318 #if defined key_agrif 319 ENDIF 320 #endif 301 321 302 322 CALL mpi_comm_rank( mpi_comm_world, rank, ierr ) … … 337 357 npvm_me = 0 338 358 IF( ndim_mpp > nprocmax ) THEN 339 WRITE(numout,*) 'npvm_mytid=', npvm_mytid, ' too great' 340 STOP ' mynode ' 359 WRITE(ctmp1,*) 'npvm_mytid=', npvm_mytid, ' too great' 360 CALL ctl_stop( ctmp1 ) 361 341 362 ELSE 342 363 npvm_nproc = ndim_mpp … … 456 477 ! --- END receive dimension --- 457 478 IF( ndim_mpp > nprocmax ) THEN 458 WRITE( numout,*) 'mytid=',nt3d_mytid,' too great'459 STOP ' mpparent '479 WRITE(ctmp1,*) 'mytid=',nt3d_mytid,' too great' 480 CALL ctl_stop( ctmp1 ) 460 481 ELSE 461 482 nt3d_nproc = ndim_mpp … … 517 538 #endif 518 539 519 SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn )540 SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp ) 520 541 !!---------------------------------------------------------------------- 521 542 !! *** routine mpp_lnk_3d *** … … 550 571 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( inout ) :: & 551 572 ptab ! 3D array on which the boundary condition is applied 573 CHARACTER(len=3), INTENT( in ), OPTIONAL :: & 574 cd_mpp ! fill the overlap area only 552 575 553 576 !! * Local variables … … 560 583 ! 1. standard boundary treatment 561 584 ! ------------------------------ 562 ! ! East-West boundaries 563 ! ! ==================== 564 IF( nbondi == 2 .AND. & ! Cyclic east-west 565 & (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 566 ptab( 1 ,:,:) = ptab(jpim1,:,:) 567 ptab(jpi,:,:) = ptab( 2 ,:,:) 568 569 ELSE ! closed 585 586 IF( PRESENT( cd_mpp ) ) THEN 587 ! only fill extra allows with 1. 588 ptab( 1:nlci, nlcj+1:jpj, :) = 1.e0 589 ptab(nlci+1:jpi , : , :) = 1.e0 590 ELSE 591 592 ! ! East-West boundaries 593 ! ! ==================== 594 IF( nbondi == 2 .AND. & ! Cyclic east-west 595 & (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 596 ptab( 1 ,:,:) = ptab(jpim1,:,:) 597 ptab(jpi,:,:) = ptab( 2 ,:,:) 598 599 ELSE ! closed 600 SELECT CASE ( cd_type ) 601 CASE ( 'T', 'U', 'V', 'W' ) 602 ptab( 1 :jpreci,:,:) = 0.e0 603 ptab(nlci-jpreci+1:jpi ,:,:) = 0.e0 604 CASE ( 'F' ) 605 ptab(nlci-jpreci+1:jpi ,:,:) = 0.e0 606 END SELECT 607 ENDIF 608 609 ! ! North-South boundaries 610 ! ! ====================== 570 611 SELECT CASE ( cd_type ) 571 612 CASE ( 'T', 'U', 'V', 'W' ) 572 ptab( 1 :jpreci,:,:) = 0.e0573 ptab( nlci-jpreci+1:jpi ,:,:) = 0.e0613 ptab(:, 1 :jprecj,:) = 0.e0 614 ptab(:,nlcj-jprecj+1:jpj ,:) = 0.e0 574 615 CASE ( 'F' ) 575 ptab(nlci-jpreci+1:jpi ,:,:) = 0.e0 576 END SELECT 616 ptab(:,nlcj-jprecj+1:jpj ,:) = 0.e0 617 END SELECT 618 577 619 ENDIF 578 579 ! ! North-South boundaries580 ! ! ======================581 SELECT CASE ( cd_type )582 CASE ( 'T', 'U', 'V', 'W' )583 ptab(:, 1 :jprecj,:) = 0.e0584 ptab(:,nlcj-jprecj+1:jpj ,:) = 0.e0585 CASE ( 'F' )586 ptab(:,nlcj-jprecj+1:jpj ,:) = 0.e0587 END SELECT588 589 620 590 621 ! 2. East and west directions exchange … … 749 780 ! ----------------------- 750 781 782 IF (PRESENT(cd_mpp)) THEN 783 ! No north fold treatment (it is assumed to be already OK) 784 785 ELSE 786 751 787 ! 4.1 treatment without exchange (jpni odd) 752 788 ! T-point pivot … … 860 896 END SELECT ! jpni 861 897 898 ENDIF 899 862 900 863 901 ! 5. East and west directions exchange … … 950 988 951 989 952 SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn )990 SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp ) 953 991 !!---------------------------------------------------------------------- 954 992 !! *** routine mpp_lnk_2d *** … … 982 1020 REAL(wp), DIMENSION(jpi,jpj), INTENT( inout ) :: & 983 1021 pt2d ! 2D array on which the boundary condition is applied 1022 CHARACTER(len=3), INTENT( in ), OPTIONAL :: & 1023 cd_mpp ! fill the overlap area only 984 1024 985 1025 !! * Local variables … … 994 1034 ! 1. standard boundary treatment 995 1035 ! ------------------------------ 996 997 ! ! East-West boundaries 998 ! ! ==================== 999 IF( nbondi == 2 .AND. & ! Cyclic east-west 1000 & (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 1001 pt2d( 1 ,:) = pt2d(jpim1,:) 1002 pt2d(jpi,:) = pt2d( 2 ,:) 1003 1004 ELSE ! ... closed 1036 IF (PRESENT(cd_mpp)) THEN 1037 ! only fill extra allows with 1. 1038 pt2d( 1:nlci, nlcj+1:jpj) = 1.e0 1039 pt2d(nlci+1:jpi , : ) = 1.e0 1040 1041 ELSE 1042 1043 ! ! East-West boundaries 1044 ! ! ==================== 1045 IF( nbondi == 2 .AND. & ! Cyclic east-west 1046 & (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 1047 pt2d( 1 ,:) = pt2d(jpim1,:) 1048 pt2d(jpi,:) = pt2d( 2 ,:) 1049 1050 ELSE ! ... closed 1051 SELECT CASE ( cd_type ) 1052 CASE ( 'T', 'U', 'V', 'W' , 'I' ) 1053 pt2d( 1 :jpreci,:) = 0.e0 1054 pt2d(nlci-jpreci+1:jpi ,:) = 0.e0 1055 CASE ( 'F' ) 1056 pt2d(nlci-jpreci+1:jpi ,:) = 0.e0 1057 END SELECT 1058 ENDIF 1059 1060 ! ! North-South boundaries 1061 ! ! ====================== 1005 1062 SELECT CASE ( cd_type ) 1006 1063 CASE ( 'T', 'U', 'V', 'W' , 'I' ) 1007 pt2d( 1 :jpreci,:) = 0.e01008 pt2d( nlci-jpreci+1:jpi ,:) = 0.e01064 pt2d(:, 1 :jprecj) = 0.e0 1065 pt2d(:,nlcj-jprecj+1:jpj ) = 0.e0 1009 1066 CASE ( 'F' ) 1010 pt2d( nlci-jpreci+1:jpi ,:) = 0.e01067 pt2d(:,nlcj-jprecj+1:jpj ) = 0.e0 1011 1068 END SELECT 1069 1012 1070 ENDIF 1013 1014 ! ! North-South boundaries1015 ! ! ======================1016 SELECT CASE ( cd_type )1017 CASE ( 'T', 'U', 'V', 'W' , 'I' )1018 pt2d(:, 1 :jprecj) = 0.e01019 pt2d(:,nlcj-jprecj+1:jpj ) = 0.e01020 CASE ( 'F' )1021 pt2d(:,nlcj-jprecj+1:jpj ) = 0.e01022 END SELECT1023 1071 1024 1072 … … 1183 1231 ! ----------------------- 1184 1232 1233 IF (PRESENT(cd_mpp)) THEN 1234 ! No north fold treatment (it is assumed to be already OK) 1235 1236 ELSE 1237 1185 1238 ! 4.1 treatment without exchange (jpni odd) 1186 1239 … … 1292 1345 END SELECT ! jpni 1293 1346 1347 ENDIF 1294 1348 1295 1349 ! 5. East and west directions … … 1380 1434 1381 1435 END SUBROUTINE mpp_lnk_2d 1436 1437 1438 SUBROUTINE mpp_lnk_3d_gather( ptab1, cd_type1, ptab2, cd_type2, psgn ) 1439 !!---------------------------------------------------------------------- 1440 !! *** routine mpp_lnk_3d_gather *** 1441 !! 1442 !! ** Purpose : Message passing manadgement for two 3D arrays 1443 !! 1444 !! ** Method : Use mppsend and mpprecv function for passing mask 1445 !! between processors following neighboring subdomains. 1446 !! domain parameters 1447 !! nlci : first dimension of the local subdomain 1448 !! nlcj : second dimension of the local subdomain 1449 !! nbondi : mark for "east-west local boundary" 1450 !! nbondj : mark for "north-south local boundary" 1451 !! noea : number for local neighboring processors 1452 !! nowe : number for local neighboring processors 1453 !! noso : number for local neighboring processors 1454 !! nono : number for local neighboring processors 1455 !! 1456 !! ** Action : ptab1 and ptab2 with update value at its periphery 1457 !! 1458 !!---------------------------------------------------------------------- 1459 !! * Arguments 1460 CHARACTER(len=1) , INTENT( in ) :: & 1461 cd_type1, cd_type2 ! define the nature of ptab array grid-points 1462 ! ! = T , U , V , F , W points 1463 ! ! = S : T-point, north fold treatment ??? 1464 ! ! = G : F-point, north fold treatment ??? 1465 REAL(wp), INTENT( in ) :: & 1466 psgn ! control of the sign change 1467 ! ! = -1. , the sign is changed if north fold boundary 1468 ! ! = 1. , the sign is kept if north fold boundary 1469 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( inout ) :: & 1470 ptab1, ptab2 ! 3D array on which the boundary condition is applied 1471 1472 !! * Local variables 1473 INTEGER :: ji, jk, jl ! dummy loop indices 1474 INTEGER :: imigr, iihom, ijhom, iloc, ijt, iju ! temporary integers 1475 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 1476 INTEGER :: ml_stat(MPI_STATUS_SIZE) ! for key_mpi_isend 1477 !!---------------------------------------------------------------------- 1478 1479 ! 1. standard boundary treatment 1480 ! ------------------------------ 1481 ! ! East-West boundaries 1482 ! ! ==================== 1483 IF( nbondi == 2 .AND. & ! Cyclic east-west 1484 & (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 1485 ptab1( 1 ,:,:) = ptab1(jpim1,:,:) 1486 ptab1(jpi,:,:) = ptab1( 2 ,:,:) 1487 ptab2( 1 ,:,:) = ptab2(jpim1,:,:) 1488 ptab2(jpi,:,:) = ptab2( 2 ,:,:) 1489 1490 ELSE ! closed 1491 SELECT CASE ( cd_type1 ) 1492 CASE ( 'T', 'U', 'V', 'W' ) 1493 ptab1( 1 :jpreci,:,:) = 0.e0 1494 ptab1(nlci-jpreci+1:jpi ,:,:) = 0.e0 1495 CASE ( 'F' ) 1496 ptab1(nlci-jpreci+1:jpi ,:,:) = 0.e0 1497 END SELECT 1498 SELECT CASE ( cd_type2 ) 1499 CASE ( 'T', 'U', 'V', 'W' ) 1500 ptab2( 1 :jpreci,:,:) = 0.e0 1501 ptab2(nlci-jpreci+1:jpi ,:,:) = 0.e0 1502 CASE ( 'F' ) 1503 ptab2(nlci-jpreci+1:jpi ,:,:) = 0.e0 1504 END SELECT 1505 ENDIF 1506 1507 ! ! North-South boundaries 1508 ! ! ====================== 1509 SELECT CASE ( cd_type1 ) 1510 CASE ( 'T', 'U', 'V', 'W' ) 1511 ptab1(:, 1 :jprecj,:) = 0.e0 1512 ptab1(:,nlcj-jprecj+1:jpj ,:) = 0.e0 1513 CASE ( 'F' ) 1514 ptab1(:,nlcj-jprecj+1:jpj ,:) = 0.e0 1515 END SELECT 1516 1517 SELECT CASE ( cd_type2 ) 1518 CASE ( 'T', 'U', 'V', 'W' ) 1519 ptab2(:, 1 :jprecj,:) = 0.e0 1520 ptab2(:,nlcj-jprecj+1:jpj ,:) = 0.e0 1521 CASE ( 'F' ) 1522 ptab2(:,nlcj-jprecj+1:jpj ,:) = 0.e0 1523 END SELECT 1524 1525 1526 ! 2. East and west directions exchange 1527 ! ------------------------------------ 1528 1529 ! 2.1 Read Dirichlet lateral conditions 1530 1531 SELECT CASE ( nbondi ) 1532 CASE ( -1, 0, 1 ) ! all exept 2 1533 iihom = nlci-nreci 1534 DO jl = 1, jpreci 1535 t4ew(:,jl,:,1,1) = ptab1(jpreci+jl,:,:) 1536 t4we(:,jl,:,1,1) = ptab1(iihom +jl,:,:) 1537 t4ew(:,jl,:,2,1) = ptab2(jpreci+jl,:,:) 1538 t4we(:,jl,:,2,1) = ptab2(iihom +jl,:,:) 1539 END DO 1540 END SELECT 1541 1542 ! 2.2 Migrations 1543 1544 #if defined key_mpp_shmem 1545 !! * SHMEM version 1546 1547 imigr = jpreci * jpj * jpk *2 1548 1549 SELECT CASE ( nbondi ) 1550 CASE ( -1 ) 1551 CALL shmem_put( t4we(1,1,1,1,2), t4we(1,1,1,1,1), imigr, noea ) 1552 CASE ( 0 ) 1553 CALL shmem_put( t4ew(1,1,1,1,2), t4ew(1,1,1,1,1), imigr, nowe ) 1554 CALL shmem_put( t4we(1,1,1,1,2), t4we(1,1,1,1,1), imigr, noea ) 1555 CASE ( 1 ) 1556 CALL shmem_put( t4ew(1,1,1,1,2), t4ew(1,1,1,1,1), imigr, nowe ) 1557 END SELECT 1558 1559 CALL barrier() 1560 CALL shmem_udcflush() 1561 1562 #elif defined key_mpp_mpi 1563 !! * Local variables (MPI version) 1564 1565 imigr = jpreci * jpj * jpk *2 1566 1567 SELECT CASE ( nbondi ) 1568 CASE ( -1 ) 1569 CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req1 ) 1570 CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr ) 1571 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1572 CASE ( 0 ) 1573 CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 ) 1574 CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req2 ) 1575 CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr ) 1576 CALL mpprecv( 2, t4we(1,1,1,1,2), imigr ) 1577 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1578 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 1579 CASE ( 1 ) 1580 CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 ) 1581 CALL mpprecv( 2, t4we(1,1,1,1,2), imigr ) 1582 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1583 END SELECT 1584 #endif 1585 1586 ! 2.3 Write Dirichlet lateral conditions 1587 1588 iihom = nlci-jpreci 1589 1590 SELECT CASE ( nbondi ) 1591 CASE ( -1 ) 1592 DO jl = 1, jpreci 1593 ptab1(iihom+jl,:,:) = t4ew(:,jl,:,1,2) 1594 ptab2(iihom+jl,:,:) = t4ew(:,jl,:,2,2) 1595 END DO 1596 CASE ( 0 ) 1597 DO jl = 1, jpreci 1598 ptab1(jl ,:,:) = t4we(:,jl,:,1,2) 1599 ptab1(iihom+jl,:,:) = t4ew(:,jl,:,1,2) 1600 ptab2(jl ,:,:) = t4we(:,jl,:,2,2) 1601 ptab2(iihom+jl,:,:) = t4ew(:,jl,:,2,2) 1602 END DO 1603 CASE ( 1 ) 1604 DO jl = 1, jpreci 1605 ptab1(jl ,:,:) = t4we(:,jl,:,1,2) 1606 ptab2(jl ,:,:) = t4we(:,jl,:,2,2) 1607 END DO 1608 END SELECT 1609 1610 1611 ! 3. North and south directions 1612 ! ----------------------------- 1613 1614 ! 3.1 Read Dirichlet lateral conditions 1615 1616 IF( nbondj /= 2 ) THEN 1617 ijhom = nlcj-nrecj 1618 DO jl = 1, jprecj 1619 t4sn(:,jl,:,1,1) = ptab1(:,ijhom +jl,:) 1620 t4ns(:,jl,:,1,1) = ptab1(:,jprecj+jl,:) 1621 t4sn(:,jl,:,2,1) = ptab2(:,ijhom +jl,:) 1622 t4ns(:,jl,:,2,1) = ptab2(:,jprecj+jl,:) 1623 END DO 1624 ENDIF 1625 1626 ! 3.2 Migrations 1627 1628 #if defined key_mpp_shmem 1629 !! * SHMEM version 1630 1631 imigr = jprecj * jpi * jpk * 2 1632 1633 SELECT CASE ( nbondj ) 1634 CASE ( -1 ) 1635 CALL shmem_put( t4sn(1,1,1,1,2), t4sn(1,1,1,1,1), imigr, nono ) 1636 CASE ( 0 ) 1637 CALL shmem_put( t4ns(1,1,1,1,2), t4ns(1,1,1,1,1), imigr, noso ) 1638 CALL shmem_put( t4sn(1,1,1,1,2), t4sn(1,1,1,1,1), imigr, nono ) 1639 CASE ( 1 ) 1640 CALL shmem_put( t4ns(1,1,1,1,2), t4ns(1,1,1,1;,1), imigr, noso ) 1641 END SELECT 1642 1643 CALL barrier() 1644 CALL shmem_udcflush() 1645 1646 #elif defined key_mpp_mpi 1647 !! * Local variables (MPI version) 1648 1649 imigr=jprecj * jpi * jpk * 2 1650 1651 SELECT CASE ( nbondj ) 1652 CASE ( -1 ) 1653 CALL mppsend( 4, t4sn(1,1,1,1,1), imigr, nono, ml_req1 ) 1654 CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr ) 1655 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1656 CASE ( 0 ) 1657 CALL mppsend( 3, t4ns(1,1,1,1,1), imigr, noso, ml_req1 ) 1658 CALL mppsend( 4, t4sn(1,1,1,1,1), imigr, nono, ml_req2 ) 1659 CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr ) 1660 CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr ) 1661 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1662 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 1663 CASE ( 1 ) 1664 CALL mppsend( 3, t4ns(1,1,1,1,1), imigr, noso, ml_req1 ) 1665 CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr ) 1666 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1667 END SELECT 1668 1669 #endif 1670 1671 ! 3.3 Write Dirichlet lateral conditions 1672 1673 ijhom = nlcj-jprecj 1674 1675 SELECT CASE ( nbondj ) 1676 CASE ( -1 ) 1677 DO jl = 1, jprecj 1678 ptab1(:,ijhom+jl,:) = t4ns(:,jl,:,1,2) 1679 ptab2(:,ijhom+jl,:) = t4ns(:,jl,:,2,2) 1680 END DO 1681 CASE ( 0 ) 1682 DO jl = 1, jprecj 1683 ptab1(:,jl ,:) = t4sn(:,jl,:,1,2) 1684 ptab1(:,ijhom+jl,:) = t4ns(:,jl,:,1,2) 1685 ptab2(:,jl ,:) = t4sn(:,jl,:,2,2) 1686 ptab2(:,ijhom+jl,:) = t4ns(:,jl,:,2,2) 1687 END DO 1688 CASE ( 1 ) 1689 DO jl = 1, jprecj 1690 ptab1(:,jl,:) = t4sn(:,jl,:,1,2) 1691 ptab2(:,jl,:) = t4sn(:,jl,:,2,2) 1692 END DO 1693 END SELECT 1694 1695 1696 ! 4. north fold treatment 1697 ! ----------------------- 1698 1699 ! 4.1 treatment without exchange (jpni odd) 1700 ! T-point pivot 1701 1702 SELECT CASE ( jpni ) 1703 1704 CASE ( 1 ) ! only one proc along I, no mpp exchange 1705 1706 SELECT CASE ( npolj ) 1707 1708 CASE ( 3 , 4 ) ! T pivot 1709 iloc = jpiglo - 2 * ( nimpp - 1 ) 1710 1711 SELECT CASE ( cd_type1 ) 1712 1713 CASE ( 'T' , 'S', 'W' ) 1714 DO jk = 1, jpk 1715 DO ji = 2, nlci 1716 ijt=iloc-ji+2 1717 ptab1(ji,nlcj,jk) = psgn * ptab1(ijt,nlcj-2,jk) 1718 END DO 1719 DO ji = nlci/2+1, nlci 1720 ijt=iloc-ji+2 1721 ptab1(ji,nlcj-1,jk) = psgn * ptab1(ijt,nlcj-1,jk) 1722 END DO 1723 END DO 1724 1725 CASE ( 'U' ) 1726 DO jk = 1, jpk 1727 DO ji = 1, nlci-1 1728 iju=iloc-ji+1 1729 ptab1(ji,nlcj,jk) = psgn * ptab1(iju,nlcj-2,jk) 1730 END DO 1731 DO ji = nlci/2, nlci-1 1732 iju=iloc-ji+1 1733 ptab1(ji,nlcj-1,jk) = psgn * ptab1(iju,nlcj-1,jk) 1734 END DO 1735 END DO 1736 1737 CASE ( 'V' ) 1738 DO jk = 1, jpk 1739 DO ji = 2, nlci 1740 ijt=iloc-ji+2 1741 ptab1(ji,nlcj-1,jk) = psgn * ptab1(ijt,nlcj-2,jk) 1742 ptab1(ji,nlcj ,jk) = psgn * ptab1(ijt,nlcj-3,jk) 1743 END DO 1744 END DO 1745 1746 CASE ( 'F', 'G' ) 1747 DO jk = 1, jpk 1748 DO ji = 1, nlci-1 1749 iju=iloc-ji+1 1750 ptab1(ji,nlcj-1,jk) = psgn * ptab1(iju,nlcj-2,jk) 1751 ptab1(ji,nlcj ,jk) = psgn * ptab1(iju,nlcj-3,jk) 1752 END DO 1753 END DO 1754 1755 END SELECT 1756 1757 SELECT CASE ( cd_type2 ) 1758 1759 CASE ( 'T' , 'S', 'W' ) 1760 DO jk = 1, jpk 1761 DO ji = 2, nlci 1762 ijt=iloc-ji+2 1763 ptab2(ji,nlcj,jk) = psgn * ptab2(ijt,nlcj-2,jk) 1764 END DO 1765 DO ji = nlci/2+1, nlci 1766 ijt=iloc-ji+2 1767 ptab2(ji,nlcj-1,jk) = psgn * ptab2(ijt,nlcj-1,jk) 1768 END DO 1769 END DO 1770 1771 CASE ( 'U' ) 1772 DO jk = 1, jpk 1773 DO ji = 1, nlci-1 1774 iju=iloc-ji+1 1775 ptab2(ji,nlcj,jk) = psgn * ptab2(iju,nlcj-2,jk) 1776 END DO 1777 DO ji = nlci/2, nlci-1 1778 iju=iloc-ji+1 1779 ptab2(ji,nlcj-1,jk) = psgn * ptab2(iju,nlcj-1,jk) 1780 END DO 1781 END DO 1782 1783 CASE ( 'V' ) 1784 DO jk = 1, jpk 1785 DO ji = 2, nlci 1786 ijt=iloc-ji+2 1787 ptab2(ji,nlcj-1,jk) = psgn * ptab2(ijt,nlcj-2,jk) 1788 ptab2(ji,nlcj ,jk) = psgn * ptab2(ijt,nlcj-3,jk) 1789 END DO 1790 END DO 1791 1792 CASE ( 'F', 'G' ) 1793 DO jk = 1, jpk 1794 DO ji = 1, nlci-1 1795 iju=iloc-ji+1 1796 ptab2(ji,nlcj-1,jk) = psgn * ptab2(iju,nlcj-2,jk) 1797 ptab2(ji,nlcj ,jk) = psgn * ptab2(iju,nlcj-3,jk) 1798 END DO 1799 END DO 1800 1801 END SELECT 1802 1803 CASE ( 5 , 6 ) ! F pivot 1804 iloc=jpiglo-2*(nimpp-1) 1805 1806 SELECT CASE ( cd_type1 ) 1807 1808 CASE ( 'T' , 'S', 'W' ) 1809 DO jk = 1, jpk 1810 DO ji = 1, nlci 1811 ijt=iloc-ji+1 1812 ptab1(ji,nlcj,jk) = psgn * ptab1(ijt,nlcj-1,jk) 1813 END DO 1814 END DO 1815 1816 CASE ( 'U' ) 1817 DO jk = 1, jpk 1818 DO ji = 1, nlci-1 1819 iju=iloc-ji 1820 ptab1(ji,nlcj,jk) = psgn * ptab1(iju,nlcj-1,jk) 1821 END DO 1822 END DO 1823 1824 CASE ( 'V' ) 1825 DO jk = 1, jpk 1826 DO ji = 1, nlci 1827 ijt=iloc-ji+1 1828 ptab1(ji,nlcj ,jk) = psgn * ptab1(ijt,nlcj-2,jk) 1829 END DO 1830 DO ji = nlci/2+1, nlci 1831 ijt=iloc-ji+1 1832 ptab1(ji,nlcj-1,jk) = psgn * ptab1(ijt,nlcj-1,jk) 1833 END DO 1834 END DO 1835 1836 CASE ( 'F', 'G' ) 1837 DO jk = 1, jpk 1838 DO ji = 1, nlci-1 1839 iju=iloc-ji 1840 ptab1(ji,nlcj,jk) = psgn * ptab1(iju,nlcj-2,jk) 1841 END DO 1842 DO ji = nlci/2+1, nlci-1 1843 iju=iloc-ji 1844 ptab1(ji,nlcj-1,jk) = psgn * ptab1(iju,nlcj-1,jk) 1845 END DO 1846 END DO 1847 END SELECT ! cd_type1 1848 1849 SELECT CASE ( cd_type2 ) 1850 1851 CASE ( 'T' , 'S', 'W' ) 1852 DO jk = 1, jpk 1853 DO ji = 1, nlci 1854 ijt=iloc-ji+1 1855 ptab2(ji,nlcj,jk) = psgn * ptab2(ijt,nlcj-1,jk) 1856 END DO 1857 END DO 1858 1859 CASE ( 'U' ) 1860 DO jk = 1, jpk 1861 DO ji = 1, nlci-1 1862 iju=iloc-ji 1863 ptab2(ji,nlcj,jk) = psgn * ptab2(iju,nlcj-1,jk) 1864 END DO 1865 END DO 1866 1867 CASE ( 'V' ) 1868 DO jk = 1, jpk 1869 DO ji = 1, nlci 1870 ijt=iloc-ji+1 1871 ptab2(ji,nlcj ,jk) = psgn * ptab2(ijt,nlcj-2,jk) 1872 END DO 1873 DO ji = nlci/2+1, nlci 1874 ijt=iloc-ji+1 1875 ptab2(ji,nlcj-1,jk) = psgn * ptab2(ijt,nlcj-1,jk) 1876 END DO 1877 END DO 1878 1879 CASE ( 'F', 'G' ) 1880 DO jk = 1, jpk 1881 DO ji = 1, nlci-1 1882 iju=iloc-ji 1883 ptab2(ji,nlcj,jk) = psgn * ptab2(iju,nlcj-2,jk) 1884 END DO 1885 DO ji = nlci/2+1, nlci-1 1886 iju=iloc-ji 1887 ptab2(ji,nlcj-1,jk) = psgn * ptab2(iju,nlcj-1,jk) 1888 END DO 1889 END DO 1890 1891 END SELECT ! cd_type2 1892 1893 END SELECT ! npolj 1894 1895 CASE DEFAULT ! more than 1 proc along I 1896 IF ( npolj /= 0 ) THEN 1897 CALL mpp_lbc_north (ptab1, cd_type1, psgn) ! only for northern procs. 1898 CALL mpp_lbc_north (ptab2, cd_type2, psgn) ! only for northern procs. 1899 ENDIF 1900 1901 END SELECT ! jpni 1902 1903 1904 ! 5. East and west directions exchange 1905 ! ------------------------------------ 1906 1907 SELECT CASE ( npolj ) 1908 1909 CASE ( 3, 4, 5, 6 ) 1910 1911 ! 5.1 Read Dirichlet lateral conditions 1912 1913 SELECT CASE ( nbondi ) 1914 1915 CASE ( -1, 0, 1 ) 1916 iihom = nlci-nreci 1917 DO jl = 1, jpreci 1918 t4ew(:,jl,:,1,1) = ptab1(jpreci+jl,:,:) 1919 t4we(:,jl,:,1,1) = ptab1(iihom +jl,:,:) 1920 t4ew(:,jl,:,2,1) = ptab2(jpreci+jl,:,:) 1921 t4we(:,jl,:,2,1) = ptab2(iihom +jl,:,:) 1922 END DO 1923 1924 END SELECT 1925 1926 ! 5.2 Migrations 1927 1928 #if defined key_mpp_shmem 1929 !! SHMEM version 1930 1931 imigr = jpreci * jpj * jpk * 2 1932 1933 SELECT CASE ( nbondi ) 1934 CASE ( -1 ) 1935 CALL shmem_put( t4we(1,1,1,1,2), t4we(1,1,1,1,1), imigr, noea ) 1936 CASE ( 0 ) 1937 CALL shmem_put( t4ew(1,1,1,1,2), t4ew(1,1,1,1,1), imigr, nowe ) 1938 CALL shmem_put( t4we(1,1,1,1,2), t4we(1,1,1,1,1), imigr, noea ) 1939 CASE ( 1 ) 1940 CALL shmem_put( t4ew(1,1,1,1,2), t4ew(1,1,1,1,1), imigr, nowe ) 1941 END SELECT 1942 1943 CALL barrier() 1944 CALL shmem_udcflush() 1945 1946 #elif defined key_mpp_mpi 1947 !! MPI version 1948 1949 imigr = jpreci * jpj * jpk * 2 1950 1951 SELECT CASE ( nbondi ) 1952 CASE ( -1 ) 1953 CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req1 ) 1954 CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr ) 1955 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1956 CASE ( 0 ) 1957 CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 ) 1958 CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req2 ) 1959 CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr ) 1960 CALL mpprecv( 2, t4we(1,1,1,1,2), imigr ) 1961 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1962 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 1963 CASE ( 1 ) 1964 CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 ) 1965 CALL mpprecv( 2, t4we(1,1,1,1,2), imigr ) 1966 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1967 END SELECT 1968 #endif 1969 1970 ! 5.3 Write Dirichlet lateral conditions 1971 1972 iihom = nlci-jpreci 1973 1974 SELECT CASE ( nbondi) 1975 CASE ( -1 ) 1976 DO jl = 1, jpreci 1977 ptab1(iihom+jl,:,:) = t4ew(:,jl,:,1,2) 1978 ptab2(iihom+jl,:,:) = t4ew(:,jl,:,2,2) 1979 END DO 1980 CASE ( 0 ) 1981 DO jl = 1, jpreci 1982 ptab1(jl ,:,:) = t4we(:,jl,:,1,2) 1983 ptab1(iihom+jl,:,:) = t4ew(:,jl,:,1,2) 1984 ptab2(jl ,:,:) = t4we(:,jl,:,2,2) 1985 ptab2(iihom+jl,:,:) = t4ew(:,jl,:,2,2) 1986 END DO 1987 CASE ( 1 ) 1988 DO jl = 1, jpreci 1989 ptab1(jl ,:,:) = t4we(:,jl,:,1,2) 1990 ptab2(jl ,:,:) = t4we(:,jl,:,2,2) 1991 END DO 1992 END SELECT 1993 1994 END SELECT ! npolj 1995 1996 END SUBROUTINE mpp_lnk_3d_gather 1382 1997 1383 1998 … … 2291 2906 INTEGER, SAVE :: ibool=0 2292 2907 2293 IF( kdim > jpmppsum ) THEN 2294 WRITE(numout,*) 'mppisl_a_int routine : kdim is too big' 2295 WRITE(numout,*) 'change jpmppsum dimension in mpp.h' 2296 STOP 'mppisl_a_int' 2297 ENDIF 2908 IF( kdim > jpmppsum ) CALL ctl_stop( 'mppisl_a_int routine : kdim is too big', & 2909 & 'change jpmppsum dimension in mpp.h' ) 2298 2910 2299 2911 DO ji = 1, kdim … … 2409 3021 INTEGER, SAVE :: ibool=0 2410 3022 2411 IF( kdim > jpmppsum ) THEN 2412 WRITE(numout,*) 'mppmin_a_int routine : kdim is too big' 2413 WRITE(numout,*) 'change jpmppsum dimension in mpp.h' 2414 STOP 'min_a_int' 2415 ENDIF 3023 IF( kdim > jpmppsum ) CALL ctl_stop( 'mppmin_a_int routine : kdim is too big', & 3024 & 'change jpmppsum dimension in mpp.h' ) 2416 3025 2417 3026 DO ji = 1, kdim … … 2514 3123 INTEGER, SAVE :: ibool=0 2515 3124 2516 IF( kdim > jpmppsum ) THEN 2517 WRITE(numout,*) 'mppsum_a_int routine : kdim is too big' 2518 WRITE(numout,*) 'change jpmppsum dimension in mpp.h' 2519 STOP 'mppsum_a_int' 2520 ENDIF 3125 IF( kdim > jpmppsum ) CALL ctl_stop( 'mppsum_a_int routine : kdim is too big', & 3126 & 'change jpmppsum dimension in mpp.h' ) 2521 3127 2522 3128 DO ji = 1, kdim … … 2618 3224 INTEGER, SAVE :: ibool=0 2619 3225 2620 IF( kdim > jpmppsum ) THEN 2621 WRITE(numout,*) 'mppisl_a_real routine : kdim is too big' 2622 WRITE(numout,*) 'change jpmppsum dimension in mpp.h' 2623 STOP 'mppisl_a_real' 2624 ENDIF 3226 IF( kdim > jpmppsum ) CALL ctl_stop( 'mppisl_a_real routine : kdim is too big', & 3227 & 'change jpmppsum dimension in mpp.h' ) 2625 3228 2626 3229 DO ji = 1, kdim … … 2755 3358 INTEGER, SAVE :: ibool=0 2756 3359 2757 IF( kdim > jpmppsum ) THEN 2758 WRITE(numout,*) 'mppmax_a_real routine : kdim is too big' 2759 WRITE(numout,*) 'change jpmppsum dimension in mpp.h' 2760 STOP 'mppmax_a_real' 2761 ENDIF 3360 IF( kdim > jpmppsum ) CALL ctl_stop( 'mppmax_a_real routine : kdim is too big', & 3361 & 'change jpmppsum dimension in mpp.h' ) 2762 3362 2763 3363 DO ji = 1, kdim … … 2855 3455 INTEGER, SAVE :: ibool=0 2856 3456 2857 IF( kdim > jpmppsum ) THEN 2858 WRITE(numout,*) 'mpprmin routine : kdim is too big' 2859 WRITE(numout,*) 'change jpmppsum dimension in mpp.h' 2860 STOP 'mpprmin' 2861 ENDIF 3457 IF( kdim > jpmppsum ) CALL ctl_stop( 'mpprmin routine : kdim is too big', & 3458 & 'change jpmppsum dimension in mpp.h' ) 2862 3459 2863 3460 DO ji = 1, kdim … … 2956 3553 INTEGER, SAVE :: ibool=0 2957 3554 2958 IF( kdim > jpmppsum ) THEN 2959 WRITE(numout,*) 'mppsum_a_real routine : kdim is too big' 2960 WRITE(numout,*) 'change jpmppsum dimension in mpp.h' 2961 STOP 'mppsum_a_real' 2962 ENDIF 3555 IF( kdim > jpmppsum ) CALL ctl_stop( 'mppsum_a_real routine : kdim is too big', & 3556 & 'change jpmppsum dimension in mpp.h' ) 2963 3557 2964 3558 DO ji = 1, kdim … … 3054 3648 !!-------------------------------------------------------------------------- 3055 3649 #ifdef key_mpp_shmem 3056 IF (lwp) THEN 3057 WRITE(numout,*) ' mpp_minloc not yet available in SHMEM' 3058 STOP 3059 ENDIF 3650 CALL ctl_stop( ' mpp_minloc not yet available in SHMEM' ) 3060 3651 # elif key_mpp_mpi 3061 3652 !! * Arguments … … 3107 3698 !!-------------------------------------------------------------------------- 3108 3699 #ifdef key_mpp_shmem 3109 IF (lwp) THEN 3110 WRITE(numout,*) ' mpp_minloc not yet available in SHMEM' 3111 STOP 3112 ENDIF 3700 CALL ctl_stop( ' mpp_minloc not yet available in SHMEM' ) 3113 3701 # elif key_mpp_mpi 3114 3702 !! * Arguments … … 3162 3750 !!-------------------------------------------------------------------------- 3163 3751 #ifdef key_mpp_shmem 3164 IF (lwp) THEN 3165 WRITE(numout,*) ' mpp_maxloc not yet available in SHMEM' 3166 STOP 3167 ENDIF 3752 CALL ctl_stop( ' mpp_maxloc not yet available in SHMEM' ) 3168 3753 # elif key_mpp_mpi 3169 3754 !! * Arguments … … 3214 3799 !!-------------------------------------------------------------------------- 3215 3800 #ifdef key_mpp_shmem 3216 IF (lwp) THEN 3217 WRITE(numout,*) ' mpp_maxloc not yet available in SHMEM' 3218 STOP 3219 ENDIF 3801 CALL ctl_stop( ' mpp_maxloc not yet available in SHMEM' ) 3220 3802 # elif key_mpp_mpi 3221 3803 !! * Arguments … … 3363 3945 ilpt1 = MAX( 1, MIN(kd2 - njmpp+1, nlcj ) ) 3364 3946 ELSE 3365 IF(lwp)WRITE(numout,*) 'mppobc: bad ktype' 3366 STOP 'mppobc' 3947 CALL ctl_stop( 'mppobc: bad ktype' ) 3367 3948 ENDIF 3368 3949 … … 3570 4151 !!---------------------------------------------------------------------- 3571 4152 #ifdef key_mpp_shmem 3572 IF (lwp) THEN 3573 WRITE(numout,*) ' mpp_ini_north not available in SHMEM' 3574 STOP 3575 ENDIF 4153 CALL ctl_stop( ' mpp_ini_north not available in SHMEM' ) 3576 4154 # elif key_mpp_mpi 3577 4155 INTEGER :: ierr … … 3909 4487 REAL(wp), DIMENSION(jpi,4,jpni) :: znorthgloio 3910 4488 REAL(wp), DIMENSION(jpi,4) :: znorthloc 3911 4489 !!---------------------------------------------------------------------- 4490 !! OPA 8.5, LODYC-IPSL (2002) 4491 !!---------------------------------------------------------------------- 3912 4492 ! If we get in this routine it s because : North fold condition and mpp with more 3913 4493 ! than one proc across i : we deal only with the North condition … … 4051 4631 ztab( 2 ,ijpj) = 0.e0 4052 4632 DO ji = 2 , jpiglo-1 4053 ijt = jpi - ji + 24633 ijt = jpiglo - ji + 2 4054 4634 ztab(ji,ijpj)= 0.5 * ( ztab(ji,ijpj-1) + psgn * ztab(ijt,ijpj-1) ) 4055 4635 END DO … … 4315 4895 DO jl = 0, jpr2dj 4316 4896 DO ji = 2 , jpiglo-1 4317 ijt = jpi - ji + 24897 ijt = jpiglo - ji + 2 4318 4898 ztab(ji,ijpj+jl)= 0.5 * ( ztab(ji,ijpj-1-jl) + psgn * ztab(ijt,ijpj-1-jl) ) 4319 4899 END DO … … 4396 4976 SUBROUTINE mpi_init_opa(code) 4397 4977 IMPLICIT NONE 4978 4979 !$AGRIF_DO_NOT_TREAT 4398 4980 # include <mpif.h> 4981 !$AGRIF_END_DO_NOT_TREAT 4399 4982 4400 4983 INTEGER :: code,rang … … 4448 5031 4449 5032 END SUBROUTINE mpi_init_opa 4450 4451 5033 4452 5034 #else
Note: See TracChangeset
for help on using the changeset viewer.