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 473 for trunk/NEMO/OPA_SRC/lib_mpp.F90 – NEMO

Ignore:
Timestamp:
2006-05-11T17:04:37+02:00 (18 years ago)
Author:
opalod
Message:

nemo_v1_update_060: SM: IOM + 301 levels + CORE + begining of ctl_stop

File:
1 edited

Legend:

Unmodified
Added
Removed

  • trunk/NEMO/OPA_SRC/lib_mpp.F90

    r415 r473  
    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 
    … …  
    5558   PRIVATE 
    5659   PUBLIC  mynode, mpparent, mpp_isl, mpp_min, mpp_max, mpp_sum,  mpp_lbc_north 
    57    PUBLIC  mpp_lbc_north_e, mpp_minloc, mpp_maxloc, mpp_lnk_3d, mpp_lnk_2d, mpp_lnk_2d_e, mpplnks 
     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 
    5861   PUBLIC  mpprecv, mppsend, mppscatter, mppgather, mppobc, mpp_ini_north, mppstop, mppsync 
    5962 
    … …  
    8992   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .TRUE.       !: mpp flag 
    9093 
    91  
    92    !! * Module variables 
    9394   !! The processor number is a required power of two : 1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024,... 
    9495   INTEGER, PARAMETER ::   & 
    … …  
    241242#endif 
    242243 
     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 
    243250   REAL(wp), DIMENSION(jpi,jprecj,jpk,2) ::   & 
    244251       t3ns, t3sn  ! 3d message passing arrays north-south & south-north 
    … …  
    305312            CALL mpi_init( ierr ) 
    306313         CASE DEFAULT 
    307             WRITE(numout,cform_err) 
    308             WRITE(numout,*) '           bad value for c_mpi_send = ', c_mpi_send 
    309             nstop = nstop + 1 
     314            WRITE(ctmp1,*) '           bad value for c_mpi_send = ', c_mpi_send 
     315            CALL ctl_stop( ctmp1 ) 
    310316         END SELECT 
    311317 
    … …  
    351357            npvm_me = 0 
    352358            IF( ndim_mpp > nprocmax ) THEN 
    353                WRITE(numout,*) 'npvm_mytid=', npvm_mytid, ' too great' 
    354                STOP  ' mynode ' 
     359               WRITE(ctmp1,*) 'npvm_mytid=', npvm_mytid, ' too great' 
     360               CALL ctl_stop( ctmp1 ) 
     361 
    355362            ELSE 
    356363               npvm_nproc = ndim_mpp 
    … …  
    470477         !          --- END receive dimension --- 
    471478         IF( ndim_mpp > nprocmax ) THEN 
    472             WRITE(numout,*) 'mytid=',nt3d_mytid,' too great' 
    473             STOP  ' mpparent ' 
     479            WRITE(ctmp1,*) 'mytid=',nt3d_mytid,' too great' 
     480            CALL ctl_stop( ctmp1 ) 
    474481         ELSE 
    475482            nt3d_nproc =  ndim_mpp 
    … …  
    531538#endif 
    532539 
    533    SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn ) 
     540   SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp ) 
    534541      !!---------------------------------------------------------------------- 
    535542      !!                  ***  routine mpp_lnk_3d  *** 
    … …  
    564571      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( inout ) ::   & 
    565572         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  
    566575 
    567576      !! * Local variables 
    … …  
    574583      ! 1. standard boundary treatment 
    575584      ! ------------------------------ 
    576       !                                        ! East-West boundaries 
    577       !                                        ! ==================== 
    578       IF( nbondi == 2 .AND.   &      ! Cyclic east-west 
    579          &   (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
    580          ptab( 1 ,:,:) = ptab(jpim1,:,:) 
    581          ptab(jpi,:,:) = ptab(  2  ,:,:) 
    582  
    583       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         !                                        ! ====================== 
    584611         SELECT CASE ( cd_type ) 
    585612         CASE ( 'T', 'U', 'V', 'W' ) 
    586             ptab(     1       :jpreci,:,:) = 0.e0 
    587             ptab(nlci-jpreci+1:jpi   ,:,:) = 0.e0 
     613            ptab(:,     1       :jprecj,:) = 0.e0 
     614            ptab(:,nlcj-jprecj+1:jpj   ,:) = 0.e0 
    588615         CASE ( 'F' ) 
    589             ptab(nlci-jpreci+1:jpi   ,:,:) = 0.e0 
    590          END SELECT  
     616            ptab(:,nlcj-jprecj+1:jpj   ,:) = 0.e0 
     617         END SELECT 
     618      
    591619      ENDIF 
    592  
    593       !                                        ! North-South boundaries 
    594       !                                        ! ====================== 
    595       SELECT CASE ( cd_type ) 
    596       CASE ( 'T', 'U', 'V', 'W' ) 
    597          ptab(:,     1       :jprecj,:) = 0.e0 
    598          ptab(:,nlcj-jprecj+1:jpj   ,:) = 0.e0 
    599       CASE ( 'F' ) 
    600          ptab(:,nlcj-jprecj+1:jpj   ,:) = 0.e0 
    601       END SELECT 
    602  
    603620 
    604621      ! 2. East and west directions exchange 
    … …  
    763780      ! ----------------------- 
    764781 
     782      IF (PRESENT(cd_mpp)) THEN 
     783         ! No north fold treatment (it is assumed to be already OK) 
     784      
     785      ELSE       
     786 
    765787      ! 4.1 treatment without exchange (jpni odd) 
    766788      !     T-point pivot   
    … …  
    874896      END SELECT ! jpni  
    875897 
     898      ENDIF 
     899       
    876900 
    877901      ! 5. East and west directions exchange 
    … …  
    964988 
    965989 
    966    SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn ) 
     990   SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp ) 
    967991      !!---------------------------------------------------------------------- 
    968992      !!                  ***  routine mpp_lnk_2d  *** 
    … …  
    9961020      REAL(wp), DIMENSION(jpi,jpj), INTENT( inout ) ::   & 
    9971021         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  
    9981024 
    9991025      !! * Local variables 
    … …  
    10081034      ! 1. standard boundary treatment 
    10091035      ! ------------------------------ 
    1010  
    1011       !                                        ! East-West boundaries 
    1012       !                                        ! ==================== 
    1013       IF( nbondi == 2 .AND.   &      ! Cyclic east-west 
    1014          &    (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
    1015          pt2d( 1 ,:) = pt2d(jpim1,:) 
    1016          pt2d(jpi,:) = pt2d(  2  ,:) 
    1017  
    1018       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         !                                        ! ====================== 
    10191062         SELECT CASE ( cd_type ) 
    10201063         CASE ( 'T', 'U', 'V', 'W' , 'I' ) 
    1021             pt2d(     1       :jpreci,:) = 0.e0 
    1022             pt2d(nlci-jpreci+1:jpi   ,:) = 0.e0 
     1064            pt2d(:,     1       :jprecj) = 0.e0 
     1065            pt2d(:,nlcj-jprecj+1:jpj   ) = 0.e0 
    10231066         CASE ( 'F' ) 
    1024             pt2d(nlci-jpreci+1:jpi   ,:) = 0.e0 
     1067            pt2d(:,nlcj-jprecj+1:jpj   ) = 0.e0 
    10251068         END SELECT 
     1069 
    10261070      ENDIF 
    1027  
    1028       !                                        ! North-South boundaries 
    1029       !                                        ! ====================== 
    1030       SELECT CASE ( cd_type ) 
    1031       CASE ( 'T', 'U', 'V', 'W' , 'I' ) 
    1032          pt2d(:,     1       :jprecj) = 0.e0 
    1033          pt2d(:,nlcj-jprecj+1:jpj   ) = 0.e0 
    1034       CASE ( 'F' ) 
    1035          pt2d(:,nlcj-jprecj+1:jpj   ) = 0.e0 
    1036       END SELECT 
    10371071 
    10381072 
    … …  
    11971231      ! ----------------------- 
    11981232   
     1233      IF (PRESENT(cd_mpp)) THEN 
     1234         ! No north fold treatment (it is assumed to be already OK) 
     1235      
     1236      ELSE       
     1237 
    11991238      ! 4.1 treatment without exchange (jpni odd) 
    12001239       
    … …  
    13061345      END SELECT   ! jpni 
    13071346 
     1347      ENDIF 
    13081348 
    13091349      ! 5. East and west directions 
    … …  
    13941434   
    13951435   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 
    13961997 
    13971998 
    … …  
    23052906      INTEGER, SAVE :: ibool=0 
    23062907 
    2307       IF( kdim > jpmppsum ) THEN 
    2308          WRITE(numout,*) 'mppisl_a_int routine : kdim is too big' 
    2309          WRITE(numout,*) 'change jpmppsum dimension in mpp.h' 
    2310          STOP 'mppisl_a_int' 
    2311       ENDIF 
     2908      IF( kdim > jpmppsum ) CALL ctl_stop( 'mppisl_a_int routine : kdim is too big', & 
     2909           &                               'change jpmppsum dimension in mpp.h' ) 
    23122910 
    23132911      DO ji = 1, kdim 
    … …  
    24233021      INTEGER, SAVE :: ibool=0 
    24243022   
    2425       IF( kdim > jpmppsum ) THEN 
    2426          WRITE(numout,*) 'mppmin_a_int routine : kdim is too big' 
    2427          WRITE(numout,*) 'change jpmppsum dimension in mpp.h' 
    2428          STOP 'min_a_int' 
    2429       ENDIF 
     3023      IF( kdim > jpmppsum ) CALL ctl_stop( 'mppmin_a_int routine : kdim is too big', & 
     3024           &                               'change jpmppsum dimension in mpp.h' ) 
    24303025   
    24313026      DO ji = 1, kdim 
    … …  
    25283123      INTEGER, SAVE :: ibool=0 
    25293124 
    2530       IF( kdim > jpmppsum ) THEN 
    2531          WRITE(numout,*) 'mppsum_a_int routine : kdim is too big' 
    2532          WRITE(numout,*) 'change jpmppsum dimension in mpp.h' 
    2533          STOP 'mppsum_a_int' 
    2534       ENDIF 
     3125      IF( kdim > jpmppsum ) CALL ctl_stop( 'mppsum_a_int routine : kdim is too big', & 
     3126           &                               'change jpmppsum dimension in mpp.h' ) 
    25353127 
    25363128      DO ji = 1, kdim 
    … …  
    26323224    INTEGER, SAVE :: ibool=0 
    26333225 
    2634     IF( kdim > jpmppsum ) THEN 
    2635        WRITE(numout,*) 'mppisl_a_real routine : kdim is too big' 
    2636        WRITE(numout,*) 'change jpmppsum dimension in mpp.h' 
    2637        STOP 'mppisl_a_real' 
    2638     ENDIF 
     3226    IF( kdim > jpmppsum ) CALL ctl_stop( 'mppisl_a_real routine : kdim is too big', & 
     3227         &                               'change jpmppsum dimension in mpp.h' ) 
    26393228 
    26403229    DO ji = 1, kdim 
    … …  
    27693358    INTEGER, SAVE :: ibool=0 
    27703359 
    2771     IF( kdim > jpmppsum ) THEN 
    2772        WRITE(numout,*) 'mppmax_a_real routine : kdim is too big' 
    2773        WRITE(numout,*) 'change jpmppsum dimension in mpp.h' 
    2774        STOP 'mppmax_a_real' 
    2775     ENDIF 
     3360    IF( kdim > jpmppsum ) CALL ctl_stop( 'mppmax_a_real routine : kdim is too big', & 
     3361         &                               'change jpmppsum dimension in mpp.h' ) 
    27763362 
    27773363    DO ji = 1, kdim 
    … …  
    28693455    INTEGER, SAVE :: ibool=0 
    28703456 
    2871     IF( kdim > jpmppsum ) THEN 
    2872        WRITE(numout,*) 'mpprmin routine : kdim is too big' 
    2873        WRITE(numout,*) 'change jpmppsum dimension in mpp.h' 
    2874        STOP 'mpprmin' 
    2875     ENDIF 
     3457    IF( kdim > jpmppsum ) CALL ctl_stop( 'mpprmin routine : kdim is too big', & 
     3458         &                               'change jpmppsum dimension in mpp.h' ) 
    28763459 
    28773460    DO ji = 1, kdim 
    … …  
    29703553    INTEGER, SAVE :: ibool=0 
    29713554 
    2972     IF( kdim > jpmppsum ) THEN 
    2973        WRITE(numout,*) 'mppsum_a_real routine : kdim is too big' 
    2974        WRITE(numout,*) 'change jpmppsum dimension in mpp.h' 
    2975        STOP 'mppsum_a_real' 
    2976     ENDIF 
     3555    IF( kdim > jpmppsum ) CALL ctl_stop( 'mppsum_a_real routine : kdim is too big', & 
     3556         &                               'change jpmppsum dimension in mpp.h' ) 
    29773557 
    29783558    DO ji = 1, kdim 
    … …  
    30683648    !!-------------------------------------------------------------------------- 
    30693649#ifdef key_mpp_shmem 
    3070     IF (lwp) THEN 
    3071        WRITE(numout,*) ' mpp_minloc not yet available in SHMEM' 
    3072        STOP 
    3073     ENDIF 
     3650    CALL ctl_stop( ' mpp_minloc not yet available in SHMEM' ) 
    30743651# elif key_mpp_mpi 
    30753652    !! * Arguments 
    … …  
    31213698    !!-------------------------------------------------------------------------- 
    31223699#ifdef key_mpp_shmem 
    3123     IF (lwp) THEN 
    3124        WRITE(numout,*) ' mpp_minloc not yet available in SHMEM' 
    3125        STOP 
    3126     ENDIF 
     3700    CALL ctl_stop( ' mpp_minloc not yet available in SHMEM' ) 
    31273701# elif key_mpp_mpi 
    31283702    !! * Arguments 
    … …  
    31763750    !!-------------------------------------------------------------------------- 
    31773751#ifdef key_mpp_shmem 
    3178     IF (lwp) THEN 
    3179        WRITE(numout,*) ' mpp_maxloc not yet available in SHMEM' 
    3180        STOP 
    3181     ENDIF 
     3752    CALL ctl_stop( ' mpp_maxloc not yet available in SHMEM' ) 
    31823753# elif key_mpp_mpi 
    31833754    !! * Arguments 
    … …  
    32283799    !!-------------------------------------------------------------------------- 
    32293800#ifdef key_mpp_shmem 
    3230     IF (lwp) THEN 
    3231        WRITE(numout,*) ' mpp_maxloc not yet available in SHMEM' 
    3232        STOP 
    3233     ENDIF 
     3801    CALL ctl_stop( ' mpp_maxloc not yet available in SHMEM' ) 
    32343802# elif key_mpp_mpi 
    32353803    !! * Arguments 
    … …  
    33773945       ilpt1 = MAX( 1, MIN(kd2 - njmpp+1, nlcj     ) ) 
    33783946    ELSE 
    3379        IF(lwp)WRITE(numout,*) 'mppobc: bad ktype' 
    3380        STOP 'mppobc' 
     3947       CALL ctl_stop( 'mppobc: bad ktype' ) 
    33813948    ENDIF 
    33823949 
    … …  
    35844151    !!---------------------------------------------------------------------- 
    35854152#ifdef key_mpp_shmem 
    3586     IF (lwp) THEN 
    3587        WRITE(numout,*) ' mpp_ini_north not available in SHMEM' 
    3588        STOP 
    3589     ENDIF 
     4153    CALL ctl_stop( ' mpp_ini_north not available in SHMEM' ) 
    35904154# elif key_mpp_mpi 
    35914155    INTEGER :: ierr 
    … …  
    44685032   END SUBROUTINE mpi_init_opa 
    44695033 
    4470  
    44715034#else 
    44725035   !!---------------------------------------------------------------------- 
Note: See TracChangeset for help on using the changeset viewer.