New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
Changeset 496 for trunk/NEMO/OFF_SRC/lib_mpp.F90 – NEMO

Ignore:
Timestamp:
2006-09-12T12:59:38+02:00 (18 years ago)
Author:
opalod
Message:

nemo_v1_update_063:CE:integration of the control print option for debugging

File:
1 edited

Legend:

Unmodified
Added
Removed

  • trunk/NEMO/OFF_SRC/lib_mpp.F90

    r343 r496  
    1414   !!   mpp_lnk     : generic interface (defined in lbclnk) for : 
    1515   !!                 mpp_lnk_2d, mpp_lnk_3d 
     16   !!   mpp_lnk_3d_gather :  Message passing manadgement for two 3D arrays 
    1617   !!   mpp_lnk_e   : interface defined in lbclnk 
    1718   !!   mpplnks 
    … …  
    2829   !!   mpp_sum    : generic interface for : 
    2930   !!                mppsum_int , mppsum_a_int , mppsum_real, mppsum_a_real 
     31   !!   mpp_minloc 
     32   !!   mpp_maxloc 
    3033   !!   mppsync 
    3134   !!   mppstop 
    … …  
    4851   !!--------------------------------------------------------------------- 
    4952   !! * Modules used 
    50    USE dom_oce         ! ocean space and time domain  
    51    USE in_out_manager  ! I/O manager 
     53   USE dom_oce                    ! ocean space and time domain  
     54   USE in_out_manager             ! I/O manager 
    5255 
    5356   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 
    5462 
    5563   !! * Interfaces 
    … …  
    8492   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .TRUE.       !: mpp flag 
    8593 
    86  
    87    !! * Module variables 
    8894   !! The processor number is a required power of two : 1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024,... 
    8995   INTEGER, PARAMETER ::   & 
    … …  
    95101   !!  MPI  variable definition !! 
    96102   !! ========================= !! 
     103!$AGRIF_DO_NOT_TREAT 
    97104#  include <mpif.h> 
     105!$AGRIF_END_DO_NOT_TREAT 
    98106 
    99107   INTEGER ::   & 
    … …  
    234242#endif 
    235243 
     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 
    236250   REAL(wp), DIMENSION(jpi,jprecj,jpk,2) ::   & 
    237251       t3ns, t3sn  ! 3d message passing arrays north-south & south-north 
    … …  
    283297      WRITE(numout,*) '           mpi send type            c_mpi_send = ', c_mpi_send 
    284298 
    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 
    301321 
    302322      CALL mpi_comm_rank( mpi_comm_world, rank, ierr ) 
    … …  
    337357            npvm_me = 0 
    338358            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 
    341362            ELSE 
    342363               npvm_nproc = ndim_mpp 
    … …  
    456477         !          --- END receive dimension --- 
    457478         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 ) 
    460481         ELSE 
    461482            nt3d_nproc =  ndim_mpp 
    … …  
    517538#endif 
    518539 
    519    SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn ) 
     540   SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp ) 
    520541      !!---------------------------------------------------------------------- 
    521542      !!                  ***  routine mpp_lnk_3d  *** 
    … …  
    550571      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( inout ) ::   & 
    551572         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  
    552575 
    553576      !! * Local variables 
    … …  
    560583      ! 1. standard boundary treatment 
    561584      ! ------------------------------ 
    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         !                                        ! ====================== 
    570611         SELECT CASE ( cd_type ) 
    571612         CASE ( 'T', 'U', 'V', 'W' ) 
    572             ptab(     1       :jpreci,:,:) = 0.e0 
    573             ptab(nlci-jpreci+1:jpi   ,:,:) = 0.e0 
     613            ptab(:,     1       :jprecj,:) = 0.e0 
     614            ptab(:,nlcj-jprecj+1:jpj   ,:) = 0.e0 
    574615         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      
    577619      ENDIF 
    578  
    579       !                                        ! North-South boundaries 
    580       !                                        ! ====================== 
    581       SELECT CASE ( cd_type ) 
    582       CASE ( 'T', 'U', 'V', 'W' ) 
    583          ptab(:,     1       :jprecj,:) = 0.e0 
    584          ptab(:,nlcj-jprecj+1:jpj   ,:) = 0.e0 
    585       CASE ( 'F' ) 
    586          ptab(:,nlcj-jprecj+1:jpj   ,:) = 0.e0 
    587       END SELECT 
    588  
    589620 
    590621      ! 2. East and west directions exchange 
    … …  
    749780      ! ----------------------- 
    750781 
     782      IF (PRESENT(cd_mpp)) THEN 
     783         ! No north fold treatment (it is assumed to be already OK) 
     784      
     785      ELSE       
     786 
    751787      ! 4.1 treatment without exchange (jpni odd) 
    752788      !     T-point pivot   
    … …  
    860896      END SELECT ! jpni  
    861897 
     898      ENDIF 
     899       
    862900 
    863901      ! 5. East and west directions exchange 
    … …  
    950988 
    951989 
    952    SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn ) 
     990   SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp ) 
    953991      !!---------------------------------------------------------------------- 
    954992      !!                  ***  routine mpp_lnk_2d  *** 
    … …  
    9821020      REAL(wp), DIMENSION(jpi,jpj), INTENT( inout ) ::   & 
    9831021         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  
    9841024 
    9851025      !! * Local variables 
    … …  
    9941034      ! 1. standard boundary treatment 
    9951035      ! ------------------------------ 
    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         !                                        ! ====================== 
    10051062         SELECT CASE ( cd_type ) 
    10061063         CASE ( 'T', 'U', 'V', 'W' , 'I' ) 
    1007             pt2d(     1       :jpreci,:) = 0.e0 
    1008             pt2d(nlci-jpreci+1:jpi   ,:) = 0.e0 
     1064            pt2d(:,     1       :jprecj) = 0.e0 
     1065            pt2d(:,nlcj-jprecj+1:jpj   ) = 0.e0 
    10091066         CASE ( 'F' ) 
    1010             pt2d(nlci-jpreci+1:jpi   ,:) = 0.e0 
     1067            pt2d(:,nlcj-jprecj+1:jpj   ) = 0.e0 
    10111068         END SELECT 
     1069 
    10121070      ENDIF 
    1013  
    1014       !                                        ! North-South boundaries 
    1015       !                                        ! ====================== 
    1016       SELECT CASE ( cd_type ) 
    1017       CASE ( 'T', 'U', 'V', 'W' , 'I' ) 
    1018          pt2d(:,     1       :jprecj) = 0.e0 
    1019          pt2d(:,nlcj-jprecj+1:jpj   ) = 0.e0 
    1020       CASE ( 'F' ) 
    1021          pt2d(:,nlcj-jprecj+1:jpj   ) = 0.e0 
    1022       END SELECT 
    10231071 
    10241072 
    … …  
    11831231      ! ----------------------- 
    11841232   
     1233      IF (PRESENT(cd_mpp)) THEN 
     1234         ! No north fold treatment (it is assumed to be already OK) 
     1235      
     1236      ELSE       
     1237 
    11851238      ! 4.1 treatment without exchange (jpni odd) 
    11861239       
    … …  
    12921345      END SELECT   ! jpni 
    12931346 
     1347      ENDIF 
    12941348 
    12951349      ! 5. East and west directions 
    … …  
    13801434   
    13811435   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 
    13821997 
    13831998 
    … …  
    22912906      INTEGER, SAVE :: ibool=0 
    22922907 
    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' ) 
    22982910 
    22992911      DO ji = 1, kdim 
    … …  
    24093021      INTEGER, SAVE :: ibool=0 
    24103022   
    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' ) 
    24163025   
    24173026      DO ji = 1, kdim 
    … …  
    25143123      INTEGER, SAVE :: ibool=0 
    25153124 
    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' ) 
    25213127 
    25223128      DO ji = 1, kdim 
    … …  
    26183224    INTEGER, SAVE :: ibool=0 
    26193225 
    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' ) 
    26253228 
    26263229    DO ji = 1, kdim 
    … …  
    27553358    INTEGER, SAVE :: ibool=0 
    27563359 
    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' ) 
    27623362 
    27633363    DO ji = 1, kdim 
    … …  
    28553455    INTEGER, SAVE :: ibool=0 
    28563456 
    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' ) 
    28623459 
    28633460    DO ji = 1, kdim 
    … …  
    29563553    INTEGER, SAVE :: ibool=0 
    29573554 
    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' ) 
    29633557 
    29643558    DO ji = 1, kdim 
    … …  
    30543648    !!-------------------------------------------------------------------------- 
    30553649#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' ) 
    30603651# elif key_mpp_mpi 
    30613652    !! * Arguments 
    … …  
    31073698    !!-------------------------------------------------------------------------- 
    31083699#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' ) 
    31133701# elif key_mpp_mpi 
    31143702    !! * Arguments 
    … …  
    31623750    !!-------------------------------------------------------------------------- 
    31633751#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' ) 
    31683753# elif key_mpp_mpi 
    31693754    !! * Arguments 
    … …  
    32143799    !!-------------------------------------------------------------------------- 
    32153800#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' ) 
    32203802# elif key_mpp_mpi 
    32213803    !! * Arguments 
    … …  
    33633945       ilpt1 = MAX( 1, MIN(kd2 - njmpp+1, nlcj     ) ) 
    33643946    ELSE 
    3365        IF(lwp)WRITE(numout,*) 'mppobc: bad ktype' 
    3366        STOP 'mppobc' 
     3947       CALL ctl_stop( 'mppobc: bad ktype' ) 
    33673948    ENDIF 
    33683949 
    … …  
    35704151    !!---------------------------------------------------------------------- 
    35714152#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' ) 
    35764154# elif key_mpp_mpi 
    35774155    INTEGER :: ierr 
    … …  
    39094487    REAL(wp), DIMENSION(jpi,4,jpni) :: znorthgloio 
    39104488    REAL(wp), DIMENSION(jpi,4) :: znorthloc 
    3911  
     4489    !!---------------------------------------------------------------------- 
     4490    !!  OPA 8.5, LODYC-IPSL (2002) 
     4491    !!---------------------------------------------------------------------- 
    39124492    ! If we get in this routine it s because : North fold condition and mpp with more 
    39134493    !   than one proc across i : we deal only with the North condition 
    … …  
    40514631                ztab( 2 ,ijpj) = 0.e0 
    40524632                DO ji = 2 , jpiglo-1 
    4053                    ijt = jpi - ji + 2 
     4633                   ijt = jpiglo - ji + 2 
    40544634                   ztab(ji,ijpj)= 0.5 * ( ztab(ji,ijpj-1) + psgn * ztab(ijt,ijpj-1) ) 
    40554635                END DO 
    … …  
    43154895                DO jl = 0, jpr2dj 
    43164896                   DO ji = 2 , jpiglo-1 
    4317                       ijt = jpi - ji + 2 
     4897                      ijt = jpiglo - ji + 2 
    43184898                      ztab(ji,ijpj+jl)= 0.5 * ( ztab(ji,ijpj-1-jl) + psgn * ztab(ijt,ijpj-1-jl) ) 
    43194899                   END DO 
    … …  
    43964976   SUBROUTINE mpi_init_opa(code) 
    43974977      IMPLICIT NONE 
     4978 
     4979!$AGRIF_DO_NOT_TREAT 
    43984980#     include <mpif.h> 
     4981!$AGRIF_END_DO_NOT_TREAT 
    43994982 
    44004983      INTEGER                                 :: code,rang 
    … …  
    44485031 
    44495032   END SUBROUTINE mpi_init_opa 
    4450  
    44515033 
    44525034#else 
Note: See TracChangeset for help on using the changeset viewer.