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 8186 for branches/2017/dev_r8126_ROBUST08_no_ghost/NEMOGCM/NEMO/OPA_SRC – NEMO

Ignore:
Timestamp:
2017-06-19T11:25:07+02:00 (7 years ago)
Author:
acc
Message:

Branch 2017/dev_r8126_ROBUST08_no_ghost. Incorporation of re-written lbc routines. This introduces generic routines for: lbc_lnk, lbc_lnk_multi, lbc_nfd, mpp_bdy, mpp_lnk and mpp_nfd in .h90 files which are pre-processor included multiple times (with different arguments) to recreate equivalences to all the original variants from a much smaller code base (more than 2000 lines shorter). These changes have been SETTE tested and shown to reproduce identical results to the branch base revision. There are a few caveats: the ice cavity routine: iscplhsb.F90, needs to be rewritten to avoid sums over the overlap regions; this will be done elsewhere and has merely been disabled on this branch. The work is not yet complete for the nogather option for the north-fold. The default MPI ALLGATHER option is working but do not activate ln_nogather until further notice.

Location:
branches/2017/dev_r8126_ROBUST08_no_ghost/NEMOGCM/NEMO/OPA_SRC
Files:
6 added
6 edited

Legend:

Unmodified
Added
Removed
  • branches/2017/dev_r8126_ROBUST08_no_ghost/NEMOGCM/NEMO/OPA_SRC/CRS/crslbclnk.F90

    r6140 r8186  
    1515    
    1616   INTERFACE crs_lbc_lnk 
    17       MODULE PROCEDURE crs_lbc_lnk_3d, crs_lbc_lnk_3d_gather, crs_lbc_lnk_2d 
     17      MODULE PROCEDURE crs_lbc_lnk_3d, crs_lbc_lnk_2d 
    1818   END INTERFACE 
    1919    
     
    5656      ! 
    5757      IF( PRESENT( cd_mpp ) ) THEN ; CALL lbc_lnk( pt3d1, cd_type1, psgn, cd_mpp, pval=zval  ) 
    58       ELSE                         ; CALL lbc_lnk( pt3d1, cd_type1, psgn, pval=zval  ) 
     58      ELSE                         ; CALL lbc_lnk( pt3d1, cd_type1, psgn        , pval=zval  ) 
    5959      ENDIF 
    6060      ! 
     
    6262      ! 
    6363   END SUBROUTINE crs_lbc_lnk_3d 
    64     
    65     
    66    SUBROUTINE crs_lbc_lnk_3d_gather( pt3d1, cd_type1, pt3d2, cd_type2, psgn ) 
    67       !!--------------------------------------------------------------------- 
    68       !!                  ***  SUBROUTINE crs_lbc_lnk  *** 
    69       !! 
    70       !! ** Purpose :   set lateral boundary conditions for coarsened grid 
    71       !! 
    72       !! ** Method  :   Swap domain indices from full to coarse domain 
    73       !!                before arguments are passed directly to lbc_lnk. 
    74       !!                Upon exiting, switch back to full domain indices. 
    75       !!---------------------------------------------------------------------- 
    76       CHARACTER(len=1)                        , INTENT(in   ) ::   cd_type1, cd_type2 ! grid type 
    77       REAL(wp)                                , INTENT(in   ) ::   psgn               ! control of the sign 
    78       REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) ::   pt3d1   , pt3d2    ! 3D array on which the lbc is applied 
    79       ! 
    80       LOGICAL ::   ll_grid_crs 
    81       !!---------------------------------------------------------------------- 
    82       ! 
    83       ll_grid_crs = ( jpi == jpi_crs ) 
    84       ! 
    85       IF( .NOT.ll_grid_crs )   CALL dom_grid_crs   ! Save the parent grid information  & Switch to coarse grid domain 
    86       ! 
    87       CALL lbc_lnk( pt3d1, cd_type1, pt3d2, cd_type2, psgn  ) 
    88       ! 
    89       IF( .NOT.ll_grid_crs )   CALL dom_grid_glo   ! Return to parent grid domain 
    90       ! 
    91    END SUBROUTINE crs_lbc_lnk_3d_gather 
    92  
    9364    
    9465    
     
    12192      IF( .NOT.ll_grid_crs )   CALL dom_grid_crs   ! Save the parent grid information  & Switch to coarse grid domain 
    12293      ! 
    123       IF( PRESENT( cd_mpp ) ) THEN ; CALL lbc_lnk( pt2d, cd_type, psgn, cd_mpp, pval=zval  ) 
    124       ELSE                         ; CALL lbc_lnk( pt2d, cd_type, psgn, pval=zval  ) 
     94      IF( PRESENT( cd_mpp ) ) THEN   ;  CALL lbc_lnk( pt2d, cd_type, psgn, cd_mpp, pval=zval  ) 
     95      ELSE                           ;   CALL lbc_lnk( pt2d, cd_type, psgn,        pval=zval  ) 
    12596      ENDIF 
    12697      ! 
  • branches/2017/dev_r8126_ROBUST08_no_ghost/NEMOGCM/NEMO/OPA_SRC/DOM/iscplhsb.F90

    r7646 r8186  
    184184      END DO 
    185185 
    186       CALL lbc_sum(pvol_flx(:,:,:       ),'T',1.) 
    187       CALL lbc_sum(pts_flx (:,:,:,jp_sal),'T',1.) 
    188       CALL lbc_sum(pts_flx (:,:,:,jp_tem),'T',1.) 
    189  
     186!!gm  ERROR !!!! 
     187!!    juste use tmask_i  or in case of ISF smask_i (to be created to compute the sum without halos) 
     188! 
     189!      CALL lbc_sum(pvol_flx(:,:,:       ),'T',1.) 
     190!      CALL lbc_sum(pts_flx (:,:,:,jp_sal),'T',1.) 
     191!      CALL lbc_sum(pts_flx (:,:,:,jp_tem),'T',1.) 
     192      STOP ' iscpl_cons:   please modify this module !' 
     193!!gm end 
    190194      ! if no neighbour wet cell in case of 2close a cell", need to find the nearest wet point  
    191195      ! allocation and initialisation of the list of problematic point 
     
    283287      pts_flx (:,:,:,jp_tem) = pts_flx (:,:,:,jp_tem) * tmask(:,:,:) 
    284288 
    285       ! compute sum over the halo and set it to 0. 
    286       CALL lbc_sum(pvol_flx(:,:,:       ),'T',1._wp) 
    287       CALL lbc_sum(pts_flx (:,:,:,jp_sal),'T',1._wp) 
    288       CALL lbc_sum(pts_flx (:,:,:,jp_tem),'T',1._wp) 
     289!!gm  ERROR !!!! 
     290!!    juste use tmask_i  or in case of ISF smask_i (to be created to compute the sum without halos) 
     291! 
     292!      ! compute sum over the halo and set it to 0. 
     293!      CALL lbc_sum(pvol_flx(:,:,:       ),'T',1._wp) 
     294!      CALL lbc_sum(pts_flx (:,:,:,jp_sal),'T',1._wp) 
     295!      CALL lbc_sum(pts_flx (:,:,:,jp_tem),'T',1._wp) 
     296!!gm end 
    289297 
    290298      ! deallocate variables 
  • branches/2017/dev_r8126_ROBUST08_no_ghost/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90

    r8170 r8186  
    77   !!   NEMO     1.0  ! 2002-09  (G. Madec)  F90: Free form and module 
    88   !!            3.2  ! 2009-03  (R. Benshila)  External north fold treatment   
    9    !!            3.5  ! 2012     (S.Mocavero, I. Epicoco) optimization of BDY comm. via lbc_bdy_lnk and lbc_obc_lnk 
     9   !!            3.5  ! 2012     (S.Mocavero, I. Epicoco)  optimization of BDY comm. via lbc_bdy_lnk and lbc_obc_lnk 
    1010   !!            3.4  ! 2012-12  (R. Bourdalle-Badie, G. Reffray)  add a C1D case   
    1111   !!            3.6  ! 2015-06  (O. Tintó and M. Castrillo)  add lbc_lnk_multi   
    1212   !!            4.0  ! 2017-03  (G. Madec) automatique allocation of array size (use with any 3rd dim size) 
    1313   !!             -   ! 2017-04  (G. Madec) remove duplicated routines (lbc_lnk_2d_9, lbc_lnk_2d_multiple, lbc_lnk_3d_gather) 
     14   !!             -   ! 2017-05  (G. Madec) create generic.h90 files to generate all lbc and north fold routines 
    1415   !!---------------------------------------------------------------------- 
    1516#if defined key_mpp_mpi 
     
    2021   !!---------------------------------------------------------------------- 
    2122   !!   lbc_lnk       : generic interface for mpp_lnk_3d and mpp_lnk_2d routines defined in lib_mpp 
    22    !!   lbc_sum       : generic interface for mpp_lnk_sum_3d and mpp_lnk_sum_2d routines defined in lib_mpp 
    2323   !!   lbc_lnk_e     : generic interface for mpp_lnk_2d_e routine defined in lib_mpp 
    2424   !!   lbc_bdy_lnk   : generic interface for mpp_lnk_bdy_2d and mpp_lnk_bdy_3d routines defined in lib_mpp 
    2525   !!---------------------------------------------------------------------- 
     26   USE par_oce        ! ocean dynamics and tracers    
    2627   USE lib_mpp        ! distributed memory computing library 
    27  
     28   USE lbcnfd         ! north fold 
     29 
     30   INTERFACE lbc_lnk 
     31      MODULE PROCEDURE   mpp_lnk_2d      , mpp_lnk_3d      , mpp_lnk_4d 
     32   END INTERFACE 
     33   INTERFACE lbc_lnk_ptr 
     34      MODULE PROCEDURE   mpp_lnk_2d_ptr  , mpp_lnk_3d_ptr  , mpp_lnk_4d_ptr 
     35   END INTERFACE 
    2836   INTERFACE lbc_lnk_multi 
    29       MODULE PROCEDURE mpp_lnk_2d_9, mpp_lnk_2d_multiple 
    30    END INTERFACE 
    31    ! 
    32    INTERFACE lbc_lnk 
    33       MODULE PROCEDURE mpp_lnk_3d_gather, mpp_lnk_3d, mpp_lnk_2d 
    34    END INTERFACE 
    35    ! 
    36    INTERFACE lbc_sum 
    37       MODULE PROCEDURE mpp_lnk_sum_3d, mpp_lnk_sum_2d 
     37      MODULE PROCEDURE   lbc_lnk_2d_multi, lbc_lnk_3d_multi, lbc_lnk_4d_multi 
    3838   END INTERFACE 
    3939   ! 
     
    5252   PUBLIC   lbc_lnk       ! ocean/ice lateral boundary conditions 
    5353   PUBLIC   lbc_lnk_multi ! modified ocean/ice lateral boundary conditions 
    54    PUBLIC   lbc_sum       ! sum across processors 
    5554   PUBLIC   lbc_lnk_e     ! extended ocean/ice lateral boundary conditions 
    5655   PUBLIC   lbc_bdy_lnk   ! ocean lateral BDY boundary conditions 
     
    6261   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    6362   !!---------------------------------------------------------------------- 
     63CONTAINS 
     64 
    6465#else 
    6566   !!---------------------------------------------------------------------- 
     
    6970   !!         on first and last row and column of the global domain 
    7071   !!---------------------------------------------------------------------- 
    71    !!   lbc_sum       : generic interface for mpp_lnk_sum_3d and mpp_lnk_sum_2d  
    7272   !!   lbc_lnk_sum_3d: compute sum over the halos on a 3D variable on ocean mesh 
    7373   !!   lbc_lnk_sum_3d: compute sum over the halos on a 2D variable on ocean mesh 
     
    8686 
    8787   INTERFACE lbc_lnk 
    88       MODULE PROCEDURE lbc_lnk_3d_gather, lbc_lnk_3d, lbc_lnk_2d 
    89    END INTERFACE 
    90    ! 
    91    INTERFACE lbc_sum 
    92       MODULE PROCEDURE lbc_lnk_sum_3d, lbc_lnk_sum_2d 
     88      MODULE PROCEDURE   lbc_lnk_2d      , lbc_lnk_3d      , lbc_lnk_4d 
     89   END INTERFACE 
     90   INTERFACE lbc_lnk_ptr 
     91      MODULE PROCEDURE   lbc_lnk_2d_ptr  , lbc_lnk_3d_ptr  , lbc_lnk_4d_ptr 
     92   END INTERFACE 
     93   INTERFACE lbc_lnk_multi 
     94      MODULE PROCEDURE   lbc_lnk_2d_multi, lbc_lnk_3d_multi, lbc_lnk_4d_multi 
    9395   END INTERFACE 
    9496   ! 
     
    9799   END INTERFACE 
    98100   ! 
    99    INTERFACE lbc_lnk_multi 
    100       MODULE PROCEDURE lbc_lnk_2d_9, lbc_lnk_2d_multiple 
    101    END INTERFACE 
    102    ! 
    103101   INTERFACE lbc_bdy_lnk 
    104102      MODULE PROCEDURE lbc_bdy_lnk_2d, lbc_bdy_lnk_3d 
     
    109107   END INTERFACE 
    110108    
    111    TYPE arrayptr 
    112       REAL , DIMENSION (:,:),  POINTER :: pt2d 
    113    END TYPE arrayptr 
    114    ! 
    115    PUBLIC   arrayptr 
    116  
    117109   PUBLIC   lbc_lnk       ! ocean/ice  lateral boundary conditions 
    118    PUBLIC   lbc_sum       ! ocean/ice  lateral boundary conditions (sum of the overlap region) 
    119110   PUBLIC   lbc_lnk_e     ! extended ocean/ice lateral boundary conditions 
    120111   PUBLIC   lbc_lnk_multi ! modified ocean/ice lateral boundary conditions 
     
    130121 
    131122# if defined key_c1d 
    132    !!---------------------------------------------------------------------- 
     123   !!====================================================================== 
    133124   !!   'key_c1d'                                          1D configuration 
    134    !!---------------------------------------------------------------------- 
     125   !!====================================================================== 
    135126   !!     central point value replicated over the 8 surrounding points 
    136127   !!---------------------------------------------------------------------- 
     
    185176    
    186177#else 
    187    !!---------------------------------------------------------------------- 
     178   !!====================================================================== 
    188179   !!   Default option                           3D shared memory computing 
    189    !!---------------------------------------------------------------------- 
     180   !!====================================================================== 
    190181   !!          routines setting land point, or east-west cyclic, 
    191182   !!             or north-south cyclic, or north fold values 
     
    193184   !!---------------------------------------------------------------------- 
    194185 
    195    SUBROUTINE lbc_lnk_3d( pt3d, cd_type, psgn, cd_mpp, pval ) 
    196       !!--------------------------------------------------------------------- 
    197       !!                  ***  ROUTINE lbc_lnk_3d  *** 
    198       !! 
    199       !! ** Purpose :   set lateral boundary conditions on a 3D array (non mpp case) 
    200       !! 
    201       !! ** Method  :   psign = -1 :    change the sign across the north fold 
    202       !!                      =  1 : no change of the sign across the north fold 
    203       !!                      =  0 : no change of the sign across the north fold and 
    204       !!                             strict positivity preserved: use inner row/column 
    205       !!                             for closed boundaries. 
    206       !!---------------------------------------------------------------------- 
    207       REAL(wp), DIMENSION(:,:,:), INTENT(inout)           ::   pt3d      ! 3D array on which the lbc is applied 
    208       CHARACTER(len=1)          , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points 
    209       REAL(wp)                  , INTENT(in   )           ::   psgn      ! sign used across north fold  
    210       CHARACTER(len=3)          , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing) 
    211       REAL(wp)                  , INTENT(in   ), OPTIONAL ::   pval      ! background value (for closed boundaries) 
    212       ! 
    213       REAL(wp) ::   zland 
    214       !!---------------------------------------------------------------------- 
    215       ! 
    216       IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value (zero by default) 
    217       ELSE                         ;   zland = 0._wp 
    218       ENDIF 
    219       ! 
    220       IF( PRESENT( cd_mpp ) ) THEN 
    221          ! only fill the overlap area and extra allows  
    222          ! this is in mpp case. In this module, just do nothing 
    223       ELSE 
    224          !                                     !  East-West boundaries 
    225          !                                     ! ====================== 
    226          SELECT CASE ( nperio ) 
    227          ! 
    228          CASE ( 1 , 4 , 6 )                       !**  cyclic east-west 
    229             pt3d( 1 ,:,:) = pt3d(jpim1,:,:)            ! all points 
    230             pt3d(jpi,:,:) = pt3d(  2  ,:,:) 
    231             ! 
    232          CASE DEFAULT                             !**  East closed  --  West closed 
    233             SELECT CASE ( cd_type ) 
    234             CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points 
    235                pt3d( 1 ,:,:) = zland 
    236                pt3d(jpi,:,:) = zland 
    237             CASE ( 'F' )                               ! F-point 
    238                pt3d(jpi,:,:) = zland 
    239             END SELECT 
    240             ! 
    241          END SELECT 
    242          !                                     ! North-South boundaries 
    243          !                                     ! ====================== 
    244          SELECT CASE ( nperio ) 
    245          ! 
    246          CASE ( 2 )                               !**  South symmetric  --  North closed 
    247             SELECT CASE ( cd_type ) 
    248             CASE ( 'T' , 'U' , 'W' )                   ! T-, U-, W-points 
    249                pt3d(:, 1 ,:) = pt3d(:,3,:) 
    250                pt3d(:,jpj,:) = zland 
    251             CASE ( 'V' , 'F' )                         ! V-, F-points 
    252                pt3d(:, 1 ,:) = psgn * pt3d(:,2,:) 
    253                pt3d(:,jpj,:) = zland 
    254             END SELECT 
    255             ! 
    256          CASE ( 3 , 4 , 5 , 6 )                   !**  North fold  T or F-point pivot  --  South closed 
    257             SELECT CASE ( cd_type )                    ! South : closed 
    258             CASE ( 'T' , 'U' , 'V' , 'W' , 'I' )             ! all points except F-point 
    259                pt3d(:, 1 ,:) = zland 
    260             END SELECT 
    261             !                                          ! North fold 
    262             CALL lbc_nfd( pt3d(:,:,:), cd_type, psgn ) 
    263             ! 
    264          CASE DEFAULT                             !**  North closed  --  South closed 
    265             SELECT CASE ( cd_type ) 
    266             CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points 
    267                pt3d(:, 1 ,:) = zland 
    268                pt3d(:,jpj,:) = zland 
    269             CASE ( 'F' )                               ! F-point 
    270                pt3d(:,jpj,:) = zland 
    271             END SELECT 
    272             ! 
    273          END SELECT 
    274          ! 
    275       ENDIF 
    276       ! 
    277    END SUBROUTINE lbc_lnk_3d 
    278  
    279  
    280    SUBROUTINE lbc_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 
    281       !!--------------------------------------------------------------------- 
    282       !!                 ***  ROUTINE lbc_lnk_2d  *** 
    283       !! 
    284       !! ** Purpose :   set lateral boundary conditions on a 2D array (non mpp case) 
    285       !! 
    286       !! ** Method  :   psign = -1 :    change the sign across the north fold 
    287       !!                      =  1 : no change of the sign across the north fold 
    288       !!                      =  0 : no change of the sign across the north fold and 
    289       !!                             strict positivity preserved: use inner row/column 
    290       !!                             for closed boundaries. 
    291       !!---------------------------------------------------------------------- 
    292       CHARACTER(len=1)            , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points 
    293       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout)           ::   pt2d      ! 2D array on which the lbc is applied 
    294       REAL(wp)                    , INTENT(in   )           ::   psgn      ! sign used across north fold 
    295       CHARACTER(len=3)            , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing) 
    296       REAL(wp)                    , INTENT(in   ), OPTIONAL ::   pval      ! background value (for closed boundaries) 
    297       !! 
    298       REAL(wp) ::   zland 
    299       !!---------------------------------------------------------------------- 
    300  
    301       IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value (zero by default) 
    302       ELSE                         ;   zland = 0._wp 
    303       ENDIF 
    304  
    305       IF (PRESENT(cd_mpp)) THEN 
    306          ! only fill the overlap area and extra allows  
    307          ! this is in mpp case. In this module, just do nothing 
    308       ELSE       
    309          !                                     ! East-West boundaries 
    310          !                                     ! ==================== 
    311          SELECT CASE ( nperio ) 
    312          ! 
    313          CASE ( 1 , 4 , 6 )                       !** cyclic east-west 
    314             pt2d( 1 ,:) = pt2d(jpim1,:)               ! all points 
    315             pt2d(jpi,:) = pt2d(  2  ,:) 
    316             ! 
    317          CASE DEFAULT                             !** East closed  --  West closed 
    318             SELECT CASE ( cd_type ) 
    319             CASE ( 'T' , 'U' , 'V' , 'W' )            ! T-, U-, V-, W-points 
    320                pt2d( 1 ,:) = zland 
    321                pt2d(jpi,:) = zland 
    322             CASE ( 'F' )                              ! F-point 
    323                pt2d(jpi,:) = zland 
    324             END SELECT 
    325             ! 
    326          END SELECT 
    327          !                                     ! North-South boundaries 
    328          !                                     ! ====================== 
    329          SELECT CASE ( nperio ) 
    330          ! 
    331          CASE ( 2 )                               !**  South symmetric  --  North closed 
    332             SELECT CASE ( cd_type ) 
    333             CASE ( 'T' , 'U' , 'W' )                   ! T-, U-, W-points 
    334                pt2d(:, 1 ) = pt2d(:,3) 
    335                pt2d(:,jpj) = zland 
    336             CASE ( 'V' , 'F' )                         ! V-, F-points 
    337                pt2d(:, 1 ) = psgn * pt2d(:,2) 
    338                pt2d(:,jpj) = zland 
    339             END SELECT 
    340             ! 
    341          CASE ( 3 , 4 , 5 , 6 )                   !**  North fold  T or F-point pivot  --  South closed 
    342             SELECT CASE ( cd_type )                    ! South : closed 
    343             CASE ( 'T' , 'U' , 'V' , 'W' , 'I' )             ! all points except F-point 
    344                pt2d(:, 1 ) = zland 
    345             END SELECT 
    346             !                                          ! North fold 
    347             CALL lbc_nfd( pt2d(:,:), cd_type, psgn ) 
    348             ! 
    349          CASE DEFAULT                             !**  North closed  --  South closed 
    350             SELECT CASE ( cd_type ) 
    351             CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points 
    352                pt2d(:, 1 ) = zland 
    353                pt2d(:,jpj) = zland 
    354             CASE ( 'F' )                               ! F-point 
    355                pt2d(:,jpj) = zland 
    356             END SELECT 
    357             ! 
    358          END SELECT 
    359          ! 
    360       ENDIF 
    361       !     
    362    END SUBROUTINE lbc_lnk_2d 
     186   !!---------------------------------------------------------------------- 
     187   !!                   ***  routine lbc_lnk_(2,3,4)d  *** 
     188   !! 
     189   !!   * Argument : dummy argument use in lbc_lnk_... routines 
     190   !!                ptab   :   array or pointer of arrays on which the boundary condition is applied 
     191   !!                cd_nat :   nature of array grid-points 
     192   !!                psgn   :   sign used across the north fold boundary 
     193   !!                kfld   :   optional, number of pt3d arrays 
     194   !!                cd_mpp :   optional, fill the overlap area only 
     195   !!                pval   :   optional, background value (used at closed boundaries) 
     196   !!---------------------------------------------------------------------- 
     197   ! 
     198   !                       !==  2D array and array of 2D pointer  ==! 
     199   ! 
     200#  define DIM_2d 
     201#     define ROUTINE_LNK           lbc_lnk_2d 
     202#     include "lbc_lnk_generic.h90" 
     203#     undef ROUTINE_LNK 
     204#     define MULTI 
     205#     define ROUTINE_LNK           lbc_lnk_2d_ptr 
     206#     include "lbc_lnk_generic.h90" 
     207#     undef ROUTINE_LNK 
     208#     undef MULTI 
     209#  undef DIM_2d 
     210   ! 
     211   !                       !==  3D array and array of 3D pointer  ==! 
     212   ! 
     213#  define DIM_3d 
     214#     define ROUTINE_LNK           lbc_lnk_3d 
     215#     include "lbc_lnk_generic.h90" 
     216#     undef ROUTINE_LNK 
     217#     define MULTI 
     218#     define ROUTINE_LNK           lbc_lnk_3d_ptr 
     219#     include "lbc_lnk_generic.h90" 
     220#     undef ROUTINE_LNK 
     221#     undef MULTI 
     222#  undef DIM_3d 
     223   ! 
     224   !                       !==  4D array and array of 4D pointer  ==! 
     225   ! 
     226#  define DIM_4d 
     227#     define ROUTINE_LNK           lbc_lnk_4d 
     228#     include "lbc_lnk_generic.h90" 
     229#     undef ROUTINE_LNK 
     230#     define MULTI 
     231#     define ROUTINE_LNK           lbc_lnk_4d_ptr 
     232#     include "lbc_lnk_generic.h90" 
     233#     undef ROUTINE_LNK 
     234#     undef MULTI 
     235#  undef DIM_4d 
    363236    
    364237#endif 
    365238 
    366    !!---------------------------------------------------------------------- 
    367    !!   identical routines in both C1D and shared memory computing cases 
    368    !!---------------------------------------------------------------------- 
    369  
    370    SUBROUTINE lbc_lnk_3d_gather( pt3d1, cd_type1, pt3d2, cd_type2, psgn ) 
    371       !!--------------------------------------------------------------------- 
    372       !!                  ***  ROUTINE lbc_lnk_3d_gather  *** 
    373       !! 
    374       !! ** Purpose :   set lateral boundary conditions on two 3D arrays (C1D case) 
    375       !! 
    376       !! ** Method  :   call lbc_lnk_3d on pt3d1 and pt3d2 
    377       !!---------------------------------------------------------------------- 
    378       REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pt3d1   , pt3d2      ! 3D array on which the lbc is applied 
    379       CHARACTER(len=1)          , INTENT(in   ) ::   cd_type1, cd_type2   ! nature of pt3d1 & pt3d2 grid-points 
    380       REAL(wp)                  , INTENT(in   ) ::   psgn                 ! sign used across north fold  
    381       !!---------------------------------------------------------------------- 
    382       ! 
    383       CALL lbc_lnk_3d( pt3d1, cd_type1, psgn) 
    384       CALL lbc_lnk_3d( pt3d2, cd_type2, psgn) 
    385       ! 
    386    END SUBROUTINE lbc_lnk_3d_gather 
    387  
    388    
    389    SUBROUTINE lbc_lnk_2d_multiple( pt2d_array, type_array, psgn_array, kfld ) 
    390       !!--------------------------------------------------------------------- 
    391       TYPE( arrayptr ), DIMENSION(:), INTENT(inout) ::   pt2d_array   ! pointer array of 2D fields 
    392       CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   type_array   ! nature of ptab_array grid-points 
    393       REAL(wp)        , DIMENSION(:), INTENT(in   ) ::   psgn_array   ! sign used across the north fold boundary 
    394       INTEGER                       , INTENT(in   ) ::   kfld         ! number of 2D fields 
    395       ! 
    396       INTEGER  ::   jf    !dummy loop index 
    397       !!--------------------------------------------------------------------- 
    398       ! 
    399       DO jf = 1, kfld 
    400         CALL lbc_lnk_2d( pt2d_array(jf)%pt2d, type_array(jf), psgn_array(jf) ) 
    401       END DO      
    402       ! 
    403    END SUBROUTINE lbc_lnk_2d_multiple 
    404  
    405  
    406    SUBROUTINE lbc_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC,   & 
    407       &                     pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF,   & 
    408       &                     pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI,   & 
    409       &                     cd_mpp, pval ) 
    410       !!--------------------------------------------------------------------- 
    411       REAL(wp), DIMENSION(jpi,jpj), TARGET          , INTENT(inout) ::   pt2dA    ! 2D arrays on which the lbc is applied 
    412       REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dB , pt2dC , pt2dD , pt2dE 
    413       REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dF , pt2dG , pt2dH , pt2dI 
    414       CHARACTER(len=1)                              , INTENT(in   ) ::   cd_typeA ! nature of pt2D. array grid-points 
    415       CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeB , cd_typeC , cd_typeD , cd_typeE 
    416       CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeF , cd_typeG , cd_typeH , cd_typeI 
    417       REAL(wp)                                      , INTENT(in   ) ::   psgnA    ! sign used across the north fold 
    418       REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnB , psgnC , psgnD , psgnE 
    419       REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnF , psgnG , psgnH , psgnI 
    420       CHARACTER(len=3)                    , OPTIONAL, INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
    421       REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
    422       !! 
    423       !!--------------------------------------------------------------------- 
    424       ! 
    425                               CALL lbc_lnk( pt2dA, cd_typeA, psgnA )    ! The first array 
    426       !           
    427       IF( PRESENT (psgnB) )   CALL lbc_lnk( pt2dB, cd_typeB, psgnB )    ! Look if more arrays to process 
    428       IF( PRESENT (psgnC) )   CALL lbc_lnk( pt2dC, cd_typeC, psgnC )  
    429       IF( PRESENT (psgnD) )   CALL lbc_lnk( pt2dD, cd_typeD, psgnD )  
    430       IF( PRESENT (psgnE) )   CALL lbc_lnk( pt2dE, cd_typeE, psgnE )  
    431       IF( PRESENT (psgnF) )   CALL lbc_lnk( pt2dF, cd_typeF, psgnF )  
    432       IF( PRESENT (psgnG) )   CALL lbc_lnk( pt2dG, cd_typeG, psgnG )  
    433       IF( PRESENT (psgnH) )   CALL lbc_lnk( pt2dH, cd_typeH, psgnH )  
    434       IF( PRESENT (psgnI) )   CALL lbc_lnk( pt2dI, cd_typeI, psgnI )  
    435       ! 
    436    END SUBROUTINE lbc_lnk_2d_9 
    437  
    438  
     239   !!====================================================================== 
     240   !!   identical routines in both C1D and shared memory computing 
     241   !!====================================================================== 
     242 
     243   !!---------------------------------------------------------------------- 
     244   !!                   ***  routine lbc_bdy_lnk_(2,3)d  *** 
     245   !! 
     246   !!   wrapper rountine to 'lbc_lnk_3d'. This wrapper is used 
     247   !!   to maintain the same interface with regards to the mpp case 
     248   !!---------------------------------------------------------------------- 
     249    
    439250   SUBROUTINE lbc_bdy_lnk_3d( pt3d, cd_type, psgn, ib_bdy ) 
    440       !!--------------------------------------------------------------------- 
    441       !!                  ***  ROUTINE lbc_bdy_lnk  *** 
    442       !! 
    443       !! ** Purpose :   wrapper rountine to 'lbc_lnk_3d'. This wrapper is used 
    444       !!              to maintain the same interface with regards to the mpp case 
    445251      !!---------------------------------------------------------------------- 
    446252      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pt3d      ! 3D array on which the lbc is applied 
     
    449255      INTEGER                   , INTENT(in   ) ::   ib_bdy    ! BDY boundary set 
    450256      !!---------------------------------------------------------------------- 
    451       ! 
    452257      CALL lbc_lnk_3d( pt3d, cd_type, psgn) 
    453       ! 
    454258   END SUBROUTINE lbc_bdy_lnk_3d 
    455259 
    456260 
    457261   SUBROUTINE lbc_bdy_lnk_2d( pt2d, cd_type, psgn, ib_bdy ) 
    458       !!--------------------------------------------------------------------- 
    459       !!                  ***  ROUTINE lbc_bdy_lnk  *** 
    460       !! 
    461       !! ** Purpose :   wrapper rountine to 'lbc_lnk_2d'. This wrapper is used 
    462       !!              to maintain the same interface with regards to the mpp case 
    463262      !!---------------------------------------------------------------------- 
    464263      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d      ! 3D array on which the lbc is applied 
     
    467266      INTEGER                 , INTENT(in   ) ::   ib_bdy    ! BDY boundary set 
    468267      !!---------------------------------------------------------------------- 
    469       ! 
    470268      CALL lbc_lnk_2d( pt2d, cd_type, psgn) 
    471       ! 
    472269   END SUBROUTINE lbc_bdy_lnk_2d 
    473270 
    474271 
     272!!gm  This routine should be remove with an optional halos size added in orgument of generic routines 
     273 
    475274   SUBROUTINE lbc_lnk_2d_e( pt2d, cd_type, psgn, ki, kj ) 
    476       !!--------------------------------------------------------------------- 
    477       !!                 ***  ROUTINE lbc_lnk_2d  *** 
    478       !! 
    479       !! ** Purpose :   set lateral boundary conditions on a 2D array (non mpp case) 
    480       !!                special dummy routine to allow for use of halo indexing in mpp case 
    481275      !!---------------------------------------------------------------------- 
    482276      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d      ! 2D array on which the lbc is applied 
     
    485279      INTEGER                 , INTENT(in   ) ::   ki, kj    ! sizes of extra halo (not needed in non-mpp) 
    486280      !!---------------------------------------------------------------------- 
    487       ! 
    488281      CALL lbc_lnk_2d( pt2d, cd_type, psgn ) 
    489       !     
    490282   END SUBROUTINE lbc_lnk_2d_e 
    491  
    492  
    493    SUBROUTINE lbc_lnk_sum_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 
    494       !!--------------------------------------------------------------------- 
    495       !!                 ***  ROUTINE lbc_lnk_sum_2d  *** 
    496       !! 
    497       !! ** Purpose :   set lateral boundary conditions on a 2D array (non mpp case) 
    498       !! 
    499       !! ** Comments:   compute the sum of the common cell (overlap region) for the ice sheet/ocean  
    500       !!                coupling if conservation option activated. As no ice shelf are present along 
    501       !!                this line, nothing is done along the north fold. 
    502       !!---------------------------------------------------------------------- 
    503       CHARACTER(len=1)            , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points 
    504       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout)           ::   pt2d      ! 2D array on which the lbc is applied 
    505       REAL(wp)                    , INTENT(in   )           ::   psgn      ! sign used across north fold  
    506       CHARACTER(len=3)            , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing) 
    507       REAL(wp)                    , INTENT(in   ), OPTIONAL ::   pval      ! background value (for closed boundaries) 
    508       !! 
    509       REAL(wp) ::   zland 
    510       !!---------------------------------------------------------------------- 
    511       ! 
    512       IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value (zero by default) 
    513       ELSE                         ;   zland = 0._wp 
    514       ENDIF 
    515       ! 
    516       IF (PRESENT(cd_mpp)) THEN 
    517          ! only fill the overlap area and extra allows  
    518          ! this is in mpp case. In this module, just do nothing 
    519       ELSE 
    520          !                                     ! East-West boundaries 
    521          !                                     ! ==================== 
    522          SELECT CASE ( nperio ) 
    523          ! 
    524          CASE ( 1 , 4 , 6 )                       !** cyclic east-west 
    525             pt2d(jpim1,:) = pt2d(jpim1,:) + pt2d( 1 ,:) 
    526             pt2d(  2  ,:) = pt2d(  2  ,:) + pt2d(jpi,:) 
    527             pt2d( 1 ,:) = 0.0_wp               ! all points 
    528             pt2d(jpi,:) = 0.0_wp 
    529             ! 
    530          CASE DEFAULT                             !** East closed  --  West closed 
    531             SELECT CASE ( cd_type ) 
    532             CASE ( 'T' , 'U' , 'V' , 'W' )            ! T-, U-, V-, W-points 
    533                pt2d( 1 ,:) = zland 
    534                pt2d(jpi,:) = zland 
    535             CASE ( 'F' )                              ! F-point 
    536                pt2d(jpi,:) = zland 
    537             END SELECT 
    538             ! 
    539          END SELECT 
    540          !                                     ! North-South boundaries 
    541          !                                     ! ====================== 
    542          ! Nothing to do for the north fold, there is no ice shelf along this line. 
    543          ! 
    544       END IF 
    545       ! 
    546    END SUBROUTINE 
    547  
    548  
    549    SUBROUTINE lbc_lnk_sum_3d( pt3d, cd_type, psgn, cd_mpp, pval ) 
    550       !!--------------------------------------------------------------------- 
    551       !!                 ***  ROUTINE lbc_lnk_sum_3d  *** 
    552       !! 
    553       !! ** Purpose :   set lateral boundary conditions on a 3D array (non mpp case) 
    554       !! 
    555       !! ** Comments:   compute the sum of the common cell (overlap region) for the ice sheet/ocean  
    556       !!                coupling if conservation option activated. As no ice shelf are present along 
    557       !!                this line, nothing is done along the north fold. 
    558       !!---------------------------------------------------------------------- 
    559       REAL(wp), DIMENSION(:,:,:), INTENT(inout)           ::   pt3d      ! 3D array on which the lbc is applied 
    560       CHARACTER(len=1)          , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points 
    561       REAL(wp)                  , INTENT(in   )           ::   psgn      ! sign used across north fold  
    562       CHARACTER(len=3)          , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing) 
    563       REAL(wp)                  , INTENT(in   ), OPTIONAL ::   pval      ! background value (for closed boundaries) 
    564       ! 
    565       REAL(wp) ::   zland 
    566       !!---------------------------------------------------------------------- 
    567       ! 
    568       IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value (zero by default) 
    569       ELSE                         ;   zland = 0._wp 
    570       ENDIF 
    571       ! 
    572       IF( PRESENT( cd_mpp ) ) THEN 
    573          ! only fill the overlap area and extra allows  
    574          ! this is in mpp case. In this module, just do nothing 
    575       ELSE 
    576          !                                     !  East-West boundaries 
    577          !                                     ! ====================== 
    578          SELECT CASE ( nperio ) 
    579          ! 
    580          CASE ( 1 , 4 , 6 )                       !**  cyclic east-west 
    581             pt3d(jpim1,:,:) = pt3d(jpim1,:,:) + pt3d( 1 ,:,:) 
    582             pt3d(  2  ,:,:) = pt3d(  2  ,:,:) + pt3d(jpi,:,:)  
    583             pt3d( 1 ,:,:) = 0._wp 
    584             pt3d(jpi,:,:) = 0._wp 
    585             ! 
    586          CASE DEFAULT                             !**  East closed  --  West closed 
    587             SELECT CASE ( cd_type ) 
    588             CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points 
    589                pt3d( 1 ,:,:) = zland 
    590                pt3d(jpi,:,:) = zland 
    591             CASE ( 'F' )                               ! F-point 
    592                pt3d(jpi,:,:) = zland 
    593             END SELECT 
    594             ! 
    595          END SELECT 
    596          !                                     ! North-South boundaries 
    597          !                                     ! ====================== 
    598          ! Nothing to do for the north fold, there is no ice shelf along this line. 
    599          ! 
    600       END IF 
    601       ! 
    602    END SUBROUTINE 
     283!!gm end 
    603284 
    604285#endif 
    605286 
    606287   !!====================================================================== 
     288   !!   identical routines in both distributed and shared memory computing 
     289   !!====================================================================== 
     290 
     291   !!---------------------------------------------------------------------- 
     292   !!                   ***   load_ptr_(2,3,4)d   *** 
     293   !! 
     294   !!   * Dummy Argument : 
     295   !!       in    ==>   ptab       ! array to be loaded (2D, 3D or 4D) 
     296   !!                   cd_nat     ! nature of pt2d array grid-points 
     297   !!                   psgn       ! sign used across the north fold boundary 
     298   !!       inout <=>   ptab_ptr   ! array of 2D, 3D or 4D pointers 
     299   !!                   cdna_ptr   ! nature of ptab array grid-points 
     300   !!                   psgn_ptr   ! sign used across the north fold boundary 
     301   !!                   kfld       ! number of elements that has been attributed 
     302   !!---------------------------------------------------------------------- 
     303 
     304   !!---------------------------------------------------------------------- 
     305   !!                  ***   lbc_lnk_(2,3,4)d_multi   *** 
     306   !!                     ***   load_ptr_(2,3,4)d   *** 
     307   !! 
     308   !!   * Argument : dummy argument use in lbc_lnk_multi_... routines 
     309   !! 
     310   !!---------------------------------------------------------------------- 
     311 
     312#  define DIM_2d 
     313#     define ROUTINE_MULTI          lbc_lnk_2d_multi 
     314#     define ROUTINE_LOAD           load_ptr_2d 
     315#     include "lbc_lnk_multi_generic.h90" 
     316#     undef ROUTINE_MULTI 
     317#     undef ROUTINE_LOAD 
     318#  undef DIM_2d 
     319 
     320 
     321#  define DIM_3d 
     322#     define ROUTINE_MULTI          lbc_lnk_3d_multi 
     323#     define ROUTINE_LOAD           load_ptr_3d 
     324#     include "lbc_lnk_multi_generic.h90" 
     325#     undef ROUTINE_MULTI 
     326#     undef ROUTINE_LOAD 
     327#  undef DIM_3d 
     328 
     329 
     330#  define DIM_4d 
     331#     define ROUTINE_MULTI          lbc_lnk_4d_multi 
     332#     define ROUTINE_LOAD           load_ptr_4d 
     333#     include "lbc_lnk_multi_generic.h90" 
     334#     undef ROUTINE_MULTI 
     335#     undef ROUTINE_LOAD 
     336#  undef DIM_4d 
     337 
     338   !!====================================================================== 
    607339END MODULE lbclnk 
    608340 
  • branches/2017/dev_r8126_ROBUST08_no_ghost/NEMOGCM/NEMO/OPA_SRC/LBC/lbcnfd.F90

    r8170 r8186  
    1313   !!   lbc_nfd_3d    : lateral boundary condition: North fold treatment for a 3D arrays   (lbc_nfd) 
    1414   !!   lbc_nfd_2d    : lateral boundary condition: North fold treatment for a 2D arrays   (lbc_nfd) 
    15    !!   mpp_lbc_nfd_3d: North fold treatment for a 3D arrays optimized for MPP 
    16    !!   mpp_lbc_nfd_2d: North fold treatment for a 2D arrays optimized for MPP 
     15!   !!   mpp_lbc_nfd_3d: North fold treatment for a 3D arrays optimized for MPP 
     16!   !!   mpp_lbc_nfd_2d: North fold treatment for a 2D arrays optimized for MPP 
    1717   !!---------------------------------------------------------------------- 
    1818   USE dom_oce        ! ocean space and time domain  
     
    2323 
    2424   INTERFACE lbc_nfd 
    25       MODULE PROCEDURE   lbc_nfd_3d, lbc_nfd_2d 
     25      MODULE PROCEDURE   lbc_nfd_2d    , lbc_nfd_3d    , lbc_nfd_4d 
     26      MODULE PROCEDURE   lbc_nfd_2d_ptr, lbc_nfd_3d_ptr, lbc_nfd_4d_ptr 
    2627   END INTERFACE 
    2728   ! 
    28    INTERFACE mpp_lbc_nfd 
    29       MODULE PROCEDURE   mpp_lbc_nfd_3d, mpp_lbc_nfd_2d 
    30    END INTERFACE 
     29!!gm   INTERFACE mpp_lbc_nfd 
     30!!gm      MODULE PROCEDURE   mpp_lbc_nfd_3d, mpp_lbc_nfd_2d 
     31!!gm   END INTERFACE 
     32 
     33   TYPE, PUBLIC ::   PTR_2D   !: array of 2D pointers (also used in lib_mpp) 
     34      REAL(wp), DIMENSION (:,:)    , POINTER ::   pt2d 
     35   END TYPE PTR_2D 
     36   TYPE, PUBLIC ::   PTR_3D   !: array of 3D pointers (also used in lib_mpp) 
     37      REAL(wp), DIMENSION (:,:,:)  , POINTER ::   pt3d 
     38   END TYPE PTR_3D 
     39   TYPE, PUBLIC ::   PTR_4D   !: array of 4D pointers (also used in lib_mpp) 
     40      REAL(wp), DIMENSION (:,:,:,:), POINTER ::   pt4d 
     41   END TYPE PTR_4D 
    3142 
    3243   PUBLIC   lbc_nfd       ! north fold conditions 
    33    PUBLIC   mpp_lbc_nfd   ! north fold conditions (parallel case) 
     44!!gm   PUBLIC   mpp_lbc_nfd   ! north fold conditions (parallel case) 
    3445 
    3546   INTEGER, PUBLIC, PARAMETER            ::   jpmaxngh = 3               !: 
     
    4455CONTAINS 
    4556 
    46    SUBROUTINE lbc_nfd_3d( pt3d, cd_type, psgn ) 
    47       !!---------------------------------------------------------------------- 
    48       !!                  ***  routine lbc_nfd_3d  *** 
    49       !! 
    50       !! ** Purpose :   3D lateral boundary condition : North fold treatment 
    51       !!              without processor exchanges.  
    52       !! 
    53       !! ** Method  :    
    54       !! 
    55       !! ** Action  :   pt3d with updated values along the north fold 
    56       !!---------------------------------------------------------------------- 
    57       REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pt3d      ! 3D array on which the boundary condition is applied 
    58       CHARACTER(len=1)          , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-point 
    59       REAL(wp)                  , INTENT(in   ) ::   psgn      ! sign used across north fold 
    60       ! 
    61       INTEGER  ::   ji, jk 
    62       INTEGER  ::   ijt, iju, ijpj, ijpjm1 
    63       !!---------------------------------------------------------------------- 
    64       ! 
    65       SELECT CASE ( jpni ) 
    66       CASE ( 1 )     ;   ijpj = nlcj      ! 1 proc only  along the i-direction 
    67       CASE DEFAULT   ;   ijpj = 4         ! several proc along the i-direction 
    68       END SELECT 
    69       ijpjm1 = ijpj-1 
    70  
    71       DO jk = 1, SIZE( pt3d, 3 ) 
    72          ! 
    73          SELECT CASE ( npolj ) 
    74          ! 
    75          CASE ( 3 , 4 )                        ! *  North fold  T-point pivot 
    76             ! 
    77             SELECT CASE ( cd_type ) 
    78             CASE ( 'T' , 'W' )                         ! T-, W-point 
    79                DO ji = 2, jpiglo 
    80                   ijt = jpiglo-ji+2 
    81                   pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-2,jk) 
    82                END DO 
    83                pt3d(1,ijpj,jk) = psgn * pt3d(3,ijpj-2,jk) 
    84                DO ji = jpiglo/2+1, jpiglo 
    85                   ijt = jpiglo-ji+2 
    86                   pt3d(ji,ijpjm1,jk) = psgn * pt3d(ijt,ijpjm1,jk) 
    87                END DO 
    88             CASE ( 'U' )                               ! U-point 
    89                DO ji = 1, jpiglo-1 
    90                   iju = jpiglo-ji+1 
    91                   pt3d(ji,ijpj,jk) = psgn * pt3d(iju,ijpj-2,jk) 
    92                END DO 
    93                pt3d(   1  ,ijpj,jk) = psgn * pt3d(    2   ,ijpj-2,jk) 
    94                pt3d(jpiglo,ijpj,jk) = psgn * pt3d(jpiglo-1,ijpj-2,jk)  
    95                DO ji = jpiglo/2, jpiglo-1 
    96                   iju = jpiglo-ji+1 
    97                   pt3d(ji,ijpjm1,jk) = psgn * pt3d(iju,ijpjm1,jk) 
    98                END DO 
    99             CASE ( 'V' )                               ! V-point 
    100                DO ji = 2, jpiglo 
    101                   ijt = jpiglo-ji+2 
    102                   pt3d(ji,ijpj-1,jk) = psgn * pt3d(ijt,ijpj-2,jk) 
    103                   pt3d(ji,ijpj  ,jk) = psgn * pt3d(ijt,ijpj-3,jk) 
    104                END DO 
    105                pt3d(1,ijpj,jk) = psgn * pt3d(3,ijpj-3,jk)  
    106             CASE ( 'F' )                               ! F-point 
    107                DO ji = 1, jpiglo-1 
    108                   iju = jpiglo-ji+1 
    109                   pt3d(ji,ijpj-1,jk) = psgn * pt3d(iju,ijpj-2,jk) 
    110                   pt3d(ji,ijpj  ,jk) = psgn * pt3d(iju,ijpj-3,jk) 
    111                END DO 
    112                pt3d(   1  ,ijpj,jk) = psgn * pt3d(    2   ,ijpj-3,jk) 
    113                pt3d(jpiglo,ijpj,jk) = psgn * pt3d(jpiglo-1,ijpj-3,jk)  
    114             END SELECT 
    115             ! 
    116          CASE ( 5 , 6 )                        ! *  North fold  F-point pivot 
    117             ! 
    118             SELECT CASE ( cd_type ) 
    119             CASE ( 'T' , 'W' )                         ! T-, W-point 
    120                DO ji = 1, jpiglo 
    121                   ijt = jpiglo-ji+1 
    122                   pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-1,jk) 
    123                END DO 
    124             CASE ( 'U' )                               ! U-point 
    125                DO ji = 1, jpiglo-1 
    126                   iju = jpiglo-ji 
    127                   pt3d(ji,ijpj,jk) = psgn * pt3d(iju,ijpj-1,jk) 
    128                END DO 
    129                pt3d(jpiglo,ijpj,jk) = psgn * pt3d(1,ijpj-1,jk) 
    130             CASE ( 'V' )                               ! V-point 
    131                DO ji = 1, jpiglo 
    132                   ijt = jpiglo-ji+1 
    133                   pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-2,jk) 
    134                END DO 
    135                DO ji = jpiglo/2+1, jpiglo 
    136                   ijt = jpiglo-ji+1 
    137                   pt3d(ji,ijpjm1,jk) = psgn * pt3d(ijt,ijpjm1,jk) 
    138                END DO 
    139             CASE ( 'F' )                               ! F-point 
    140                DO ji = 1, jpiglo-1 
    141                   iju = jpiglo-ji 
    142                   pt3d(ji,ijpj  ,jk) = psgn * pt3d(iju,ijpj-2,jk) 
    143                END DO 
    144                pt3d(jpiglo,ijpj,jk) = psgn * pt3d(1,ijpj-2,jk) 
    145                DO ji = jpiglo/2+1, jpiglo-1 
    146                   iju = jpiglo-ji 
    147                   pt3d(ji,ijpjm1,jk) = psgn * pt3d(iju,ijpjm1,jk) 
    148                END DO 
    149             END SELECT 
    150             ! 
    151          CASE DEFAULT                           ! *  closed : the code probably never go through 
    152             ! 
    153             SELECT CASE ( cd_type) 
    154             CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points 
    155                pt3d(:, 1  ,jk) = 0._wp 
    156                pt3d(:,ijpj,jk) = 0._wp 
    157             CASE ( 'F' )                               ! F-point 
    158                pt3d(:,ijpj,jk) = 0._wp 
    159             END SELECT 
    160             ! 
    161          END SELECT     !  npolj 
    162          ! 
    163       END DO 
    164       ! 
    165    END SUBROUTINE lbc_nfd_3d 
    166  
    167  
    168    SUBROUTINE lbc_nfd_2d( pt2d, cd_type, psgn, pr2dj ) 
     57   !!---------------------------------------------------------------------- 
     58   !!                   ***  routine lbc_nfd_(2,3,4)d  *** 
     59   !!---------------------------------------------------------------------- 
     60   !! 
     61   !! ** Purpose :   lateral boundary condition  
     62   !!                North fold treatment without processor exchanges.  
     63   !! 
     64   !! ** Method  :    
     65   !! 
     66   !! ** Action  :   ptab with updated values along the north fold 
     67   !!---------------------------------------------------------------------- 
     68   ! 
     69   !                       !==  2D array and array of 2D pointer  ==! 
     70   ! 
     71#  define DIM_2d 
     72#     define ROUTINE_NFD           lbc_nfd_2d 
     73#     include "lbc_nfd_generic.h90" 
     74#     undef ROUTINE_NFD 
     75#     define MULTI 
     76#     define ROUTINE_NFD           lbc_nfd_2d_ptr 
     77#     include "lbc_nfd_generic.h90" 
     78#     undef ROUTINE_NFD 
     79#     undef MULTI 
     80#  undef DIM_2d 
     81   ! 
     82   !                       !==  3D array and array of 3D pointer  ==! 
     83   ! 
     84#  define DIM_3d 
     85#     define ROUTINE_NFD           lbc_nfd_3d 
     86#     include "lbc_nfd_generic.h90" 
     87#     undef ROUTINE_NFD 
     88#     define MULTI 
     89#     define ROUTINE_NFD           lbc_nfd_3d_ptr 
     90#     include "lbc_nfd_generic.h90" 
     91#     undef ROUTINE_NFD 
     92#     undef MULTI 
     93#  undef DIM_3d 
     94   ! 
     95   !                       !==  4D array and array of 4D pointer  ==! 
     96   ! 
     97#  define DIM_4d 
     98#     define ROUTINE_NFD           lbc_nfd_4d 
     99#     include "lbc_nfd_generic.h90" 
     100#     undef ROUTINE_NFD 
     101#     define MULTI 
     102#     define ROUTINE_NFD           lbc_nfd_4d_ptr 
     103#     include "lbc_nfd_generic.h90" 
     104#     undef ROUTINE_NFD 
     105#     undef MULTI 
     106#  undef DIM_4d 
     107 
     108   !!---------------------------------------------------------------------- 
     109 
     110 
     111!!gm   CAUTION HERE  optional pr2dj  not implemented in generic case 
     112!!gm                 furthermore, in the _org routine it is OK only for T-point pivot !! 
     113 
     114 
     115   SUBROUTINE lbc_nfd_2d_org( pt2d, cd_nat, psgn, pr2dj ) 
    169116      !!---------------------------------------------------------------------- 
    170117      !!                  ***  routine lbc_nfd_2d  *** 
     
    178125      !!---------------------------------------------------------------------- 
    179126      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d      ! 2D array on which the boundary condition is applied 
    180       CHARACTER(len=1)        , INTENT(in   ) ::   cd_type   ! nature of pt2d grid-point 
     127      CHARACTER(len=1)        , INTENT(in   ) ::   cd_nat   ! nature of pt2d grid-point 
    181128      REAL(wp)                , INTENT(in   ) ::   psgn      ! sign used across north fold 
    182129      INTEGER , OPTIONAL      , INTENT(in   ) ::   pr2dj     ! number of additional halos 
     
    205152      CASE ( 3, 4 )                       ! *  North fold  T-point pivot 
    206153         ! 
    207          SELECT CASE ( cd_type ) 
     154         SELECT CASE ( cd_nat ) 
    208155         ! 
    209156         CASE ( 'T' , 'W' )                               ! T- , W-points 
     
    264211      CASE ( 5, 6 )                        ! *  North fold  F-point pivot 
    265212         ! 
    266          SELECT CASE ( cd_type ) 
     213         SELECT CASE ( cd_nat ) 
    267214         CASE ( 'T' , 'W' )                               ! T-, W-point 
    268215            DO jl = 0, ipr2dj 
     
    315262      CASE DEFAULT                           ! *  closed : the code probably never go through 
    316263         ! 
    317          SELECT CASE ( cd_type) 
     264         SELECT CASE ( cd_nat) 
    318265         CASE ( 'T' , 'U' , 'V' , 'W' )                 ! T-, U-, V-, W-points 
    319266            pt2d(:, 1:1-ipr2dj     ) = 0._wp 
     
    328275      END SELECT 
    329276      ! 
    330    END SUBROUTINE lbc_nfd_2d 
    331  
    332  
    333    SUBROUTINE mpp_lbc_nfd_3d( pt3dl, pt3dr, cd_type, psgn ) 
    334       !!---------------------------------------------------------------------- 
    335       !!                  ***  routine mpp_lbc_nfd_3d  *** 
    336       !! 
    337       !! ** Purpose :   3D lateral boundary condition : North fold treatment 
    338       !!              without processor exchanges.  
    339       !! 
    340       !! ** Method  :    
    341       !! 
    342       !! ** Action  :   pt3d with updated values along the north fold 
    343       !!---------------------------------------------------------------------- 
    344       REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pt3dl     ! 3D array on which the boundary condition is applied 
    345       REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   pt3dr     ! 3D array on which the boundary condition is applied 
    346       CHARACTER(len=1)          , INTENT(in   ) ::   cd_type   ! nature of pt3d(l/r) grid-point 
    347       REAL(wp)                  , INTENT(in   ) ::   psgn      ! sign used across north fold 
    348       ! 
    349       INTEGER  ::   ji, jk      ! dummy loop indices 
    350       INTEGER  ::   ipk         ! 3rd dimension of the input array 
    351       INTEGER  ::   ijt, iju, ijpj, ijpjm1, ijta, ijua, jia, startloop, endloop 
    352       !!---------------------------------------------------------------------- 
    353       ! 
    354       ipk = SIZE( pt3dl, 3 ) 
    355       ! 
    356       SELECT CASE ( jpni ) 
    357       CASE ( 1 )     ;   ijpj = nlcj      ! 1 proc only  along the i-direction 
    358       CASE DEFAULT   ;   ijpj = 4         ! several proc along the i-direction 
    359       END SELECT 
    360       ijpjm1 = ijpj-1 
    361       ! 
    362       ! 
    363       SELECT CASE ( npolj ) 
    364       ! 
    365       CASE ( 3 , 4 )                        ! *  North fold  T-point pivot 
    366          ! 
    367          SELECT CASE ( cd_type ) 
    368             CASE ( 'T' , 'W' )                         ! T-, W-point 
    369                IF ( nimpp /= 1 ) THEN   ;   startloop = 1 
    370                ELSE                     ;   startloop = 2 
    371                ENDIF 
    372                ! 
    373                DO jk = 1, ipk 
    374                   DO ji = startloop, nlci 
    375                      ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    376                      pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-2,jk) 
    377                   END DO 
    378                   IF(nimpp .eq. 1) THEN 
    379                      pt3dl(1,ijpj,jk) = psgn * pt3dl(3,ijpj-2,jk) 
    380                   ENDIF 
    381                END DO 
    382  
    383                IF( nimpp >= jpiglo/2+1 ) THEN 
    384                  startloop = 1 
    385                ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 
    386                  startloop = jpiglo/2+1 - nimpp + 1 
    387                ELSE 
    388                  startloop = nlci + 1 
    389                ENDIF 
    390                IF(startloop <= nlci) THEN 
    391                  DO jk = 1, ipk 
    392                     DO ji = startloop, nlci 
    393                        ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    394                        jia = ji + nimpp - 1 
    395                        ijta = jpiglo - jia + 2 
    396                        IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN 
    397                           pt3dl(ji,ijpjm1,jk) = psgn * pt3dl(ijta-nimpp+1,ijpjm1,jk) 
    398                        ELSE 
    399                           pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(ijt,ijpjm1,jk) 
    400                        ENDIF 
    401                     END DO 
    402                  END DO 
    403                ENDIF 
    404                ! 
    405             CASE ( 'U' )                               ! U-point 
    406                IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    407                   endloop = nlci 
    408                ELSE 
    409                   endloop = nlci - 1 
    410                ENDIF 
    411                DO jk = 1, ipk 
    412                   DO ji = 1, endloop 
    413                      iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    414                      pt3dl(ji,ijpj,jk) = psgn * pt3dr(iju,ijpj-2,jk) 
    415                   END DO 
    416                   IF(nimpp .eq. 1) THEN 
    417                      pt3dl(   1  ,ijpj,jk) = psgn * pt3dl(    2   ,ijpj-2,jk) 
    418                   ENDIF 
    419                   IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
    420                      pt3dl(nlci,ijpj,jk) = psgn * pt3dl(nlci-1,ijpj-2,jk) 
    421                   ENDIF 
    422                END DO 
    423                ! 
    424                IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    425                   endloop = nlci 
    426                ELSE 
    427                   endloop = nlci - 1 
    428                ENDIF 
    429                IF( nimpp >= jpiglo/2 ) THEN 
    430                   startloop = 1 
    431                ELSEIF( ( nimpp+nlci-1 >= jpiglo/2 ) .AND. ( nimpp < jpiglo/2 ) ) THEN 
    432                   startloop = jpiglo/2 - nimpp + 1 
    433                ELSE 
    434                   startloop = endloop + 1 
    435                ENDIF 
    436                IF( startloop <= endloop ) THEN 
    437                  DO jk = 1, ipk 
    438                     DO ji = startloop, endloop 
    439                       iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    440                       jia = ji + nimpp - 1 
    441                       ijua = jpiglo - jia + 1 
    442                       IF( ijua >= startloop+nimpp-1 .AND. ijua < jia ) THEN 
    443                         pt3dl(ji,ijpjm1,jk) = psgn * pt3dl(ijua-nimpp+1,ijpjm1,jk) 
    444                       ELSE 
    445                         pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(iju,ijpjm1,jk) 
    446                       ENDIF 
    447                     END DO 
    448                  END DO 
    449                ENDIF 
    450                ! 
    451             CASE ( 'V' )                               ! V-point 
    452                IF( nimpp /= 1 ) THEN 
    453                   startloop = 1 
    454                ELSE 
    455                   startloop = 2 
    456                ENDIF 
    457                DO jk = 1, ipk 
    458                   DO ji = startloop, nlci 
    459                      ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    460                      pt3dl(ji,ijpj-1,jk) = psgn * pt3dr(ijt,ijpj-2,jk) 
    461                      pt3dl(ji,ijpj  ,jk) = psgn * pt3dr(ijt,ijpj-3,jk) 
    462                   END DO 
    463                   IF(nimpp .eq. 1) THEN 
    464                      pt3dl(1,ijpj,jk) = psgn * pt3dl(3,ijpj-3,jk) 
    465                   ENDIF 
    466                END DO 
    467             CASE ( 'F' )                               ! F-point 
    468                IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    469                   endloop = nlci 
    470                ELSE 
    471                   endloop = nlci - 1 
    472                ENDIF 
    473                DO jk = 1, ipk 
    474                   DO ji = 1, endloop 
    475                      iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    476                      pt3dl(ji,ijpj-1,jk) = psgn * pt3dr(iju,ijpj-2,jk) 
    477                      pt3dl(ji,ijpj  ,jk) = psgn * pt3dr(iju,ijpj-3,jk) 
    478                   END DO 
    479                   IF(nimpp .eq. 1) THEN 
    480                      pt3dl(   1  ,ijpj,jk) = psgn * pt3dl(    2   ,ijpj-3,jk) 
    481                   ENDIF 
    482                   IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
    483                      pt3dl(nlci,ijpj,jk) = psgn * pt3dl(nlci-1,ijpj-3,jk) 
    484                   ENDIF 
    485                END DO 
    486          END SELECT 
    487          ! 
    488       CASE ( 5 , 6 )                        ! *  North fold  F-point pivot 
    489          ! 
    490          SELECT CASE ( cd_type ) 
    491             CASE ( 'T' , 'W' )                         ! T-, W-point 
    492                DO jk = 1, ipk 
    493                   DO ji = 1, nlci 
    494                      ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    495                      pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-1,jk) 
    496                   END DO 
    497                END DO 
    498                ! 
    499             CASE ( 'U' )                               ! U-point 
    500                IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    501                   endloop = nlci 
    502                ELSE 
    503                   endloop = nlci - 1 
    504                ENDIF 
    505                DO jk = 1, ipk 
    506                   DO ji = 1, endloop 
    507                      iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
    508                      pt3dl(ji,ijpj,jk) = psgn * pt3dr(iju,ijpj-1,jk) 
    509                   END DO 
    510                   IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
    511                      pt3dl(nlci,ijpj,jk) = psgn * pt3dr(1,ijpj-1,jk) 
    512                   ENDIF 
    513                END DO 
    514                ! 
    515             CASE ( 'V' )                               ! V-point 
    516                DO jk = 1, ipk 
    517                   DO ji = 1, nlci 
    518                      ijt = jpiglo - ji- nimpp - nfiimpp(isendto(1),jpnj) + 3 
    519                      pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-2,jk) 
    520                   END DO 
    521                END DO 
    522                ! 
    523                IF( nimpp >= jpiglo/2+1 ) THEN 
    524                   startloop = 1 
    525                ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 
    526                   startloop = jpiglo/2+1 - nimpp + 1 
    527                ELSE 
    528                   startloop = nlci + 1 
    529                ENDIF 
    530                IF( startloop <= nlci ) THEN 
    531                  DO jk = 1, ipk 
    532                     DO ji = startloop, nlci 
    533                        ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    534                        pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(ijt,ijpjm1,jk) 
    535                     END DO 
    536                  END DO 
    537                ENDIF 
    538                ! 
    539             CASE ( 'F' )                               ! F-point 
    540                IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    541                   endloop = nlci 
    542                ELSE 
    543                   endloop = nlci - 1 
    544                ENDIF 
    545                DO jk = 1, ipk 
    546                   DO ji = 1, endloop 
    547                      iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
    548                      pt3dl(ji,ijpj ,jk) = psgn * pt3dr(iju,ijpj-2,jk) 
    549                   END DO 
    550                   IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
    551                      pt3dl(nlci,ijpj,jk) = psgn * pt3dr(1,ijpj-2,jk) 
    552                   ENDIF 
    553                END DO 
    554                ! 
    555                IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    556                   endloop = nlci 
    557                ELSE 
    558                   endloop = nlci - 1 
    559                ENDIF 
    560                IF( nimpp >= jpiglo/2+1 ) THEN 
    561                   startloop = 1 
    562                ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 
    563                   startloop = jpiglo/2+1 - nimpp + 1 
    564                ELSE 
    565                   startloop = endloop + 1 
    566                ENDIF 
    567                IF( startloop <= endloop ) THEN 
    568                   DO jk = 1, ipk 
    569                      DO ji = startloop, endloop 
    570                         iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
    571                         pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(iju,ijpjm1,jk) 
    572                      END DO 
    573                   END DO 
    574                ENDIF 
    575                ! 
    576          END SELECT 
    577          ! 
    578       CASE DEFAULT                           ! *  closed : the code probably never go through 
    579          ! 
    580          SELECT CASE ( cd_type) 
    581             CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points 
    582                pt3dl(:, 1  ,jk) = 0._wp 
    583                pt3dl(:,ijpj,jk) = 0._wp 
    584             CASE ( 'F' )                               ! F-point 
    585                pt3dl(:,ijpj,jk) = 0._wp 
    586          END SELECT 
    587          ! 
    588       END SELECT     !  npolj 
    589       ! 
    590    END SUBROUTINE mpp_lbc_nfd_3d 
    591  
    592  
    593    SUBROUTINE mpp_lbc_nfd_2d( pt2dl, pt2dr, cd_type, psgn ) 
    594       !!---------------------------------------------------------------------- 
    595       !!                  ***  routine mpp_lbc_nfd_2d  *** 
    596       !! 
    597       !! ** Purpose :   2D lateral boundary condition : North fold treatment 
    598       !!              without processor exchanges.  
    599       !! 
    600       !! ** Method  :    
    601       !! 
    602       !! ** Action  :   pt2dl with updated values along the north fold 
    603       !!---------------------------------------------------------------------- 
    604       REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2dl     ! 2D array on which the boundary condition is applied 
    605       REAL(wp), DIMENSION(:,:), INTENT(in   ) ::   pt2dr     ! 2D array on which the boundary condition is applied 
    606       CHARACTER(len=1)        , INTENT(in   ) ::   cd_type   ! nature of pt3d(l/r) grid-point 
    607       REAL(wp)                , INTENT(in   ) ::   psgn      ! sign used across north fold 
    608       ! 
    609       INTEGER  ::   ji 
    610       INTEGER  ::   ijt, iju, ijpj, ijpjm1, ijta, ijua, jia, startloop, endloop 
    611       !!---------------------------------------------------------------------- 
    612  
    613       SELECT CASE ( jpni ) 
    614       CASE ( 1 )     ;   ijpj = nlcj      ! 1 proc only  along the i-direction 
    615       CASE DEFAULT   ;   ijpj = 4         ! several proc along the i-direction 
    616       END SELECT 
    617       ! 
    618       ijpjm1 = ijpj-1 
    619       ! 
    620       ! 
    621       SELECT CASE ( npolj ) 
    622       ! 
    623       CASE ( 3, 4 )                       ! *  North fold  T-point pivot 
    624          ! 
    625          SELECT CASE ( cd_type ) 
    626          ! 
    627          CASE ( 'T' , 'W' )                               ! T- , W-points 
    628             IF( nimpp /= 1 ) THEN 
    629               startloop = 1 
    630             ELSE 
    631               startloop = 2 
    632             ENDIF 
    633             DO ji = startloop, nlci 
    634               ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    635               pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-1) 
    636             END DO 
    637             IF( nimpp == 1 ) THEN 
    638               pt2dl(1,ijpj) = psgn * pt2dl(3,ijpj-2) 
    639             ENDIF 
    640             ! 
    641             IF( nimpp >= jpiglo/2+1 ) THEN 
    642                startloop = 1 
    643             ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 
    644                startloop = jpiglo/2+1 - nimpp + 1 
    645             ELSE 
    646                startloop = nlci + 1 
    647             ENDIF 
    648             DO ji = startloop, nlci 
    649                ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    650                jia = ji + nimpp - 1 
    651                ijta = jpiglo - jia + 2 
    652                IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN 
    653                   pt2dl(ji,ijpjm1) = psgn * pt2dl(ijta-nimpp+1,ijpjm1) 
    654                ELSE 
    655                   pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1) 
    656                ENDIF 
    657             END DO 
    658             ! 
    659          CASE ( 'U' )                                     ! U-point 
    660             IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    661                endloop = nlci 
    662             ELSE 
    663                endloop = nlci - 1 
    664             ENDIF 
    665             DO ji = 1, endloop 
    666                iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    667                pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-1) 
    668             END DO 
    669             ! 
    670             IF (nimpp .eq. 1) THEN 
    671               pt2dl(   1  ,ijpj  ) = psgn * pt2dl(    2   ,ijpj-2) 
    672               pt2dl(1     ,ijpj-1) = psgn * pt2dr(jpiglo - nfiimpp(isendto(1), jpnj) + 1, ijpj-1) 
    673             ENDIF 
    674             IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
    675               pt2dl(nlci,ijpj  ) = psgn * pt2dl(nlci-1,ijpj-2) 
    676             ENDIF 
    677             ! 
    678             IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    679                endloop = nlci 
    680             ELSE 
    681                endloop = nlci - 1 
    682             ENDIF 
    683             IF( nimpp >= jpiglo/2 ) THEN 
    684                startloop = 1 
    685             ELSEIF( nimpp+nlci-1 >= jpiglo/2 .AND. nimpp < jpiglo/2 ) THEN 
    686                startloop = jpiglo/2 - nimpp + 1 
    687             ELSE 
    688                startloop = endloop + 1 
    689             ENDIF 
    690             DO ji = startloop, endloop 
    691                iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    692                jia = ji + nimpp - 1 
    693                ijua = jpiglo - jia + 1 
    694                IF( ijua >= startloop+nimpp-1 .AND. ijua < jia ) THEN 
    695                   pt2dl(ji,ijpjm1) = psgn * pt2dl(ijua-nimpp+1,ijpjm1) 
    696                ELSE 
    697                   pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1) 
    698                ENDIF 
    699             END DO 
    700             ! 
    701          CASE ( 'V' )                                     ! V-point 
    702             IF( nimpp /= 1 ) THEN 
    703               startloop = 1 
    704             ELSE 
    705               startloop = 2 
    706             ENDIF 
    707             DO ji = startloop, nlci 
    708               ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    709               pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1-1) 
    710               pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-2) 
    711             END DO 
    712             IF (nimpp .eq. 1) THEN 
    713               pt2dl( 1 ,ijpj)   = psgn * pt2dl( 3 ,ijpj-3)  
    714             ENDIF 
    715             ! 
    716          CASE ( 'F' )                                     ! F-point 
    717             IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    718                endloop = nlci 
    719             ELSE 
    720                endloop = nlci - 1 
    721             ENDIF 
    722             DO ji = 1, endloop 
    723                iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    724                pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1-1) 
    725                pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-2) 
    726             END DO 
    727             IF (nimpp .eq. 1) THEN 
    728               pt2dl(   1  ,ijpj)   = psgn * pt2dl(    2   ,ijpj-3) 
    729               pt2dl(   1  ,ijpj-1) = psgn * pt2dl(    2   ,ijpj-2) 
    730             ENDIF 
    731             IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
    732               pt2dl(nlci,ijpj)   = psgn * pt2dl(nlci-1,ijpj-3) 
    733               pt2dl(nlci,ijpj-1) = psgn * pt2dl(nlci-1,ijpj-2)  
    734             ENDIF 
    735             ! 
    736          CASE ( 'I' )                                     ! ice U-V point (I-point) 
    737             IF( nimpp /= 1 ) THEN 
    738                startloop = 1 
    739             ELSE 
    740                startloop = 3 
    741                pt2dl(2,ijpj) = psgn * pt2dr(3,ijpjm1) 
    742             ENDIF 
    743             DO ji = startloop, nlci 
    744                iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 5 
    745                pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 
    746             END DO 
    747             ! 
    748          END SELECT 
    749          ! 
    750       CASE ( 5, 6 )                        ! *  North fold  F-point pivot 
    751          ! 
    752          SELECT CASE ( cd_type ) 
    753          CASE ( 'T' , 'W' )                               ! T-, W-point 
    754             DO ji = 1, nlci 
    755                ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    756                pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1) 
    757             END DO 
    758             ! 
    759          CASE ( 'U' )                                     ! U-point 
    760             IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    761                endloop = nlci 
    762             ELSE 
    763                endloop = nlci - 1 
    764             ENDIF 
    765             DO ji = 1, endloop 
    766                iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
    767                pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 
    768             END DO 
    769             IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
    770                pt2dl(nlci,ijpj) = psgn * pt2dr(1,ijpj-1) 
    771             ENDIF 
    772             ! 
    773          CASE ( 'V' )                                     ! V-point 
    774             DO ji = 1, nlci 
    775                ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    776                pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-1) 
    777             END DO 
    778             IF( nimpp >= jpiglo/2+1 ) THEN 
    779                startloop = 1 
    780             ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 
    781                startloop = jpiglo/2+1 - nimpp + 1 
    782             ELSE 
    783                startloop = nlci + 1 
    784             ENDIF 
    785             DO ji = startloop, nlci 
    786                ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    787                pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1) 
    788             END DO 
    789             ! 
    790          CASE ( 'F' )                               ! F-point 
    791             IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    792                endloop = nlci 
    793             ELSE 
    794                endloop = nlci - 1 
    795             ENDIF 
    796             DO ji = 1, endloop 
    797                iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
    798                pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-1) 
    799             END DO 
    800             IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
    801                 pt2dl(nlci,ijpj) = psgn * pt2dr(1,ijpj-2) 
    802             ENDIF 
    803             ! 
    804             IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    805                endloop = nlci 
    806             ELSE 
    807                endloop = nlci - 1 
    808             ENDIF 
    809             IF( nimpp >= jpiglo/2+1 ) THEN 
    810                startloop = 1 
    811             ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 
    812                startloop = jpiglo/2+1 - nimpp + 1 
    813             ELSE 
    814                startloop = endloop + 1 
    815             ENDIF 
    816             ! 
    817             DO ji = startloop, endloop 
    818                iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
    819                pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1) 
    820             END DO 
    821             ! 
    822          CASE ( 'I' )                                  ! ice U-V point (I-point) 
    823                IF( nimpp /= 1 ) THEN 
    824                   startloop = 1 
    825                ELSE 
    826                   startloop = 2 
    827                ENDIF 
    828                IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    829                   endloop = nlci 
    830                ELSE 
    831                   endloop = nlci - 1 
    832                ENDIF 
    833                DO ji = startloop , endloop 
    834                   ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    835                   pt2dl(ji,ijpj) = 0.5 * (pt2dl(ji,ijpjm1) + psgn * pt2dr(ijt,ijpjm1)) 
    836                END DO 
    837                ! 
    838          END SELECT 
    839          ! 
    840       CASE DEFAULT                           ! *  closed : the code probably never go through 
    841          ! 
    842          SELECT CASE ( cd_type) 
    843          CASE ( 'T' , 'U' , 'V' , 'W' )                 ! T-, U-, V-, W-points 
    844             pt2dl(:, 1  ) = 0._wp 
    845             pt2dl(:,ijpj) = 0._wp 
    846          CASE ( 'F' )                                   ! F-point 
    847             pt2dl(:,ijpj) = 0._wp 
    848          CASE ( 'I' )                                   ! ice U-V point 
    849             pt2dl(:, 1  ) = 0._wp 
    850             pt2dl(:,ijpj) = 0._wp 
    851          END SELECT 
    852          ! 
    853       END SELECT 
    854       ! 
    855    END SUBROUTINE mpp_lbc_nfd_2d 
     277   END SUBROUTINE lbc_nfd_2d_org 
    856278 
    857279   !!====================================================================== 
  • branches/2017/dev_r8126_ROBUST08_no_ghost/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90

    r8170 r8186  
    1919   !!            3.2  !  2009  (O. Marti)    add mpp_ini_znl 
    2020   !!            4.0  !  2011  (G. Madec)  move ctl_ routines from in_out_manager 
    21    !!            3.5  !  2012  (S.Mocavero, I. Epicoco) Add 'mpp_lnk_bdy_3d', 'mpp_lnk_obc_3d',  
    22    !!                          'mpp_lnk_bdy_2d' and 'mpp_lnk_obc_2d' routines and update 
    23    !!                          the mppobc routine to optimize the BDY and OBC communications 
    24    !!            3.5  !  2013  ( C. Ethe, G. Madec ) message passing arrays as local variables  
     21   !!            3.5  !  2012  (S.Mocavero, I. Epicoco) Add mpp_lnk_bdy_3d/2d routines to optimize the BDY comm. 
     22   !!            3.5  !  2013  (C. Ethe, G. Madec)  message passing arrays as local variables  
    2523   !!            3.5  !  2013  (S.Mocavero, I.Epicoco - CMCC) north fold optimizations 
    2624   !!            3.6  !  2015  (O. Tintó and M. Castrillo - BSC) Added '_multiple' case for 2D lbc and max 
    2725   !!            4.0  !  2017  (G. Madec) automatique allocation of array argument (use any 3rd dimension) 
     26   !!             -   !  2017  (G. Madec) create generic.h90 files to generate all lbc and north fold routines 
    2827   !!---------------------------------------------------------------------- 
    2928 
     
    4241   !!   mynode        : indentify the processor unit 
    4342   !!   mpp_lnk       : interface (defined in lbclnk) for message passing of 2d or 3d arrays (mpp_lnk_2d, mpp_lnk_3d) 
    44    !!   mpp_lnk_3d_gather :  Message passing manadgement for two 3D arrays 
    4543   !!   mpp_lnk_e     : interface (defined in lbclnk) for message passing of 2d array with extra halo (mpp_lnk_2d_e) 
    4644   !!   mpp_lnk_icb   : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb) 
     
    5755   !!   mppstop       : 
    5856   !!   mpp_ini_north : initialisation of north fold 
    59    !!   mpp_lbc_north : north fold processors gathering 
     57!!gm   !!   mpp_lbc_north : north fold processors gathering 
    6058   !!   mpp_lbc_north_e : variant of mpp_lbc_north for extra outer halo 
    6159   !!   mpp_lbc_north_icb : variant of mpp_lbc_north for extra outer halo with icebergs 
     
    6866   IMPLICIT NONE 
    6967   PRIVATE 
    70     
     68 
     69   INTERFACE mpp_nfd 
     70      MODULE PROCEDURE   mpp_nfd_2d      , mpp_nfd_3d      , mpp_nfd_4d 
     71      MODULE PROCEDURE   mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr 
     72   END INTERFACE 
     73 
     74   ! Interface associated to the mpp_lnk_... routines is defined in lbclnk 
     75   PUBLIC   mpp_lnk_2d      , mpp_lnk_3d      , mpp_lnk_4d 
     76   PUBLIC   mpp_lnk_2d_ptr, mpp_lnk_3d_ptr, mpp_lnk_4d_ptr 
     77   PUBLIC   mpp_lnk_2d_e 
     78   ! 
     79!!gm  this should be useless 
     80   PUBLIC   mpp_nfd_2d    , mpp_nfd_3d    , mpp_nfd_4d 
     81   PUBLIC   mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr 
     82!!gm end 
     83   ! 
    7184   PUBLIC   ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam 
    7285   PUBLIC   mynode, mppstop, mppsync, mpp_comm_free 
    73    PUBLIC   mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e 
     86   PUBLIC   mpp_ini_north, mpp_lbc_north_e 
     87!!gm   PUBLIC   mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e 
     88   PUBLIC   mpp_lbc_north_icb, mpp_lnk_2d_icb 
    7489   PUBLIC   mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 
    7590   PUBLIC   mpp_max_multiple 
    76    PUBLIC   mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e 
    77    PUBLIC   mpp_lnk_2d_9 , mpp_lnk_2d_multiple  
    78    PUBLIC   mpp_lnk_sum_3d, mpp_lnk_sum_2d 
     91!!gm   PUBLIC   mpp_lnk_2d_9  
     92!!gm   PUBLIC   mpp_lnk_sum_3d, mpp_lnk_sum_2d 
    7993   PUBLIC   mppscatter, mppgather 
    8094   PUBLIC   mpp_ini_ice, mpp_ini_znl 
     
    8296   PUBLIC   mppsend, mpprecv                          ! needed by TAM and ICB routines 
    8397   PUBLIC   mpp_lnk_bdy_2d, mpp_lnk_bdy_3d 
    84    PUBLIC   mpp_lbc_north_icb, mpp_lnk_2d_icb 
    8598   PUBLIC   mpprank 
    86  
    87    TYPE arrayptr 
    88       REAL(wp), DIMENSION (:,:),  POINTER ::   pt2d 
    89    END TYPE arrayptr 
    90    ! 
    91    PUBLIC   arrayptr 
    9299    
    93100   !! * Interfaces 
     
    105112         &             mppsum_realdd, mppsum_a_realdd 
    106113   END INTERFACE 
    107    INTERFACE mpp_lbc_north 
    108       MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d 
    109    END INTERFACE 
     114!!gm   INTERFACE mpp_lbc_north 
     115!!gm      MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d 
     116!!gm   END INTERFACE 
    110117   INTERFACE mpp_minloc 
    111118      MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d 
     
    327334   END FUNCTION mynode 
    328335 
    329  
    330    SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp, pval ) 
    331       !!---------------------------------------------------------------------- 
    332       !!                  ***  routine mpp_lnk_3d  *** 
    333       !! 
    334       !! ** Purpose :   Message passing manadgement 
    335       !! 
    336       !! ** Method  :   Use mppsend and mpprecv function for passing mask 
    337       !!              between processors following neighboring subdomains. 
    338       !!                domain parameters 
    339       !!                    nlci   : first dimension of the local subdomain 
    340       !!                    nlcj   : second dimension of the local subdomain 
    341       !!                    nbondi : mark for "east-west local boundary" 
    342       !!                    nbondj : mark for "north-south local boundary" 
    343       !!                    noea   : number for local neighboring processors 
    344       !!                    nowe   : number for local neighboring processors 
    345       !!                    noso   : number for local neighboring processors 
    346       !!                    nono   : number for local neighboring processors 
    347       !! 
    348       !! ** Action  :   ptab with update value at its periphery 
    349       !!---------------------------------------------------------------------- 
    350       REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied 
    351       CHARACTER(len=1)          , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points 
    352       REAL(wp)                  , INTENT(in   ) ::   psgn     ! sign used across the north fold boundary 
    353       CHARACTER(len=3), OPTIONAL, INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
    354       REAL(wp)        , OPTIONAL, INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
    355       ! 
    356       INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices 
    357       INTEGER  ::   ipk                        ! 3rd dimension of the input array 
    358       INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
    359       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    360       REAL(wp) ::   zland 
    361       INTEGER , DIMENSION(MPI_STATUS_SIZE)      ::   ml_stat        ! for key_mpi_isend 
    362       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ns, zt3sn   ! 3d for north-south & south-north 
    363       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ew, zt3we   ! 3d for east-west & west-east 
    364       !!---------------------------------------------------------------------- 
    365       ! 
    366       ipk = SIZE( ptab, 3 ) 
    367       ! 
    368       ALLOCATE( zt3ns(jpi,jprecj,ipk,2), zt3sn(jpi,jprecj,ipk,2),   & 
    369          &      zt3ew(jpj,jpreci,ipk,2), zt3we(jpj,jpreci,ipk,2)  ) 
    370  
    371       ! 
    372       IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
    373       ELSE                         ;   zland = 0._wp     ! zero by default 
    374       ENDIF 
    375  
    376       ! 1. standard boundary treatment 
    377       ! ------------------------------ 
    378       IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values 
    379          ! 
    380          ! WARNING ptab is defined only between nld and nle 
    381          DO jk = 1, ipk 
    382             DO jj = nlcj+1, jpj                 ! added line(s)   (inner only) 
    383                ptab(nldi  :nlei  , jj          ,jk) = ptab(nldi:nlei,     nlej,jk) 
    384                ptab(1     :nldi-1, jj          ,jk) = ptab(nldi     ,     nlej,jk) 
    385                ptab(nlei+1:nlci  , jj          ,jk) = ptab(     nlei,     nlej,jk) 
    386             END DO 
    387             DO ji = nlci+1, jpi                 ! added column(s) (full) 
    388                ptab(ji           ,nldj  :nlej  ,jk) = ptab(     nlei,nldj:nlej,jk) 
    389                ptab(ji           ,1     :nldj-1,jk) = ptab(     nlei,nldj     ,jk) 
    390                ptab(ji           ,nlej+1:jpj   ,jk) = ptab(     nlei,     nlej,jk) 
    391             END DO 
    392          END DO 
    393          ! 
    394       ELSE                              ! standard close or cyclic treatment 
    395          ! 
    396          !                                   ! East-West boundaries 
    397          !                                        !* Cyclic 
    398          IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
    399             ptab( 1 ,:,:) = ptab(jpim1,:,:) 
    400             ptab(jpi,:,:) = ptab(  2  ,:,:) 
    401          ELSE                                     !* closed 
    402             IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:,:) = zland    ! south except F-point 
    403                                          ptab(nlci-jpreci+1:jpi   ,:,:) = zland    ! north 
    404          ENDIF 
    405          !                                   ! North-South boundaries 
    406          !                                        !* cyclic (only with no mpp j-split) 
    407          IF( nbondj == 2 .AND. jperio == 7 ) THEN  
    408             ptab(:,1 , :) = ptab(:, jpjm1,:) 
    409             ptab(:,jpj,:) = ptab(:,     2,:) 
    410          ELSE                                     !* closed 
    411             IF( .NOT. cd_type == 'F' )   ptab(:,     1       :jprecj,:) = zland       ! south except F-point 
    412                                          ptab(:,nlcj-jprecj+1:jpj   ,:) = zland       ! north 
    413          ENDIF 
    414          ! 
    415       ENDIF 
    416  
    417       ! 2. East and west directions exchange 
    418       ! ------------------------------------ 
    419       ! we play with the neigbours AND the row number because of the periodicity 
    420       ! 
    421       SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
    422       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    423          iihom = nlci-nreci 
    424          DO jl = 1, jpreci 
    425             zt3ew(:,jl,:,1) = ptab(jpreci+jl,:,:) 
    426             zt3we(:,jl,:,1) = ptab(iihom +jl,:,:) 
    427          END DO 
    428       END SELECT 
    429       ! 
    430       !                           ! Migrations 
    431       imigr = jpreci * jpj * ipk 
    432       ! 
    433       SELECT CASE ( nbondi ) 
    434       CASE ( -1 ) 
    435          CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 ) 
    436          CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 
    437          IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    438       CASE ( 0 ) 
    439          CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
    440          CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 ) 
    441          CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 
    442          CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 
    443          IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    444          IF(l_isend)   CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    445       CASE ( 1 ) 
    446          CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
    447          CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 
    448          IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err ) 
    449       END SELECT 
    450       ! 
    451       !                           ! Write Dirichlet lateral conditions 
    452       iihom = nlci-jpreci 
    453       ! 
    454       SELECT CASE ( nbondi ) 
    455       CASE ( -1 ) 
    456          DO jl = 1, jpreci 
    457             ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2) 
    458          END DO 
    459       CASE ( 0 ) 
    460          DO jl = 1, jpreci 
    461             ptab(jl      ,:,:) = zt3we(:,jl,:,2) 
    462             ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2) 
    463          END DO 
    464       CASE ( 1 ) 
    465          DO jl = 1, jpreci 
    466             ptab(jl      ,:,:) = zt3we(:,jl,:,2) 
    467          END DO 
    468       END SELECT 
    469  
    470       ! 3. North and south directions 
    471       ! ----------------------------- 
    472       ! always closed : we play only with the neigbours 
    473       ! 
    474       IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    475          ijhom = nlcj-nrecj 
    476          DO jl = 1, jprecj 
    477             zt3sn(:,jl,:,1) = ptab(:,ijhom +jl,:) 
    478             zt3ns(:,jl,:,1) = ptab(:,jprecj+jl,:) 
    479          END DO 
    480       ENDIF 
    481       ! 
    482       !                           ! Migrations 
    483       imigr = jprecj * jpi * ipk 
    484       ! 
    485       SELECT CASE ( nbondj ) 
    486       CASE ( -1 ) 
    487          CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 ) 
    488          CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 
    489          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 
    490       CASE ( 0 ) 
    491          CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 
    492          CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 ) 
    493          CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 
    494          CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 
    495          IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err ) 
    496          IF(l_isend)   CALL mpi_wait(ml_req2, ml_stat, ml_err ) 
    497       CASE ( 1 ) 
    498          CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 
    499          CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 
    500          IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err ) 
    501       END SELECT 
    502       ! 
    503       !                           ! Write Dirichlet lateral conditions 
    504       ijhom = nlcj-jprecj 
    505       ! 
    506       SELECT CASE ( nbondj ) 
    507       CASE ( -1 ) 
    508          DO jl = 1, jprecj 
    509             ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2) 
    510          END DO 
    511       CASE ( 0 ) 
    512          DO jl = 1, jprecj 
    513             ptab(:,jl      ,:) = zt3sn(:,jl,:,2) 
    514             ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2) 
    515          END DO 
    516       CASE ( 1 ) 
    517          DO jl = 1, jprecj 
    518             ptab(:,jl,:) = zt3sn(:,jl,:,2) 
    519          END DO 
    520       END SELECT 
    521  
    522       ! 4. north fold treatment 
    523       ! ----------------------- 
    524       ! 
    525       IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
    526          ! 
    527          SELECT CASE ( jpni ) 
    528          CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp 
    529          CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs. 
    530          END SELECT 
    531          ! 
    532       ENDIF 
    533       ! 
    534       DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we ) 
    535       ! 
    536    END SUBROUTINE mpp_lnk_3d 
    537  
    538  
    539    SUBROUTINE mpp_lnk_2d_multiple( pt2d_array, type_array, psgn_array, kfld, cd_mpp, pval ) 
    540       !!---------------------------------------------------------------------- 
    541       !!                  ***  routine mpp_lnk_2d_multiple  *** 
    542       !! 
    543       !! ** Purpose :   Message passing management for multiple 2d arrays 
    544       !! 
    545       !! ** Method  :   Use mppsend and mpprecv function for passing mask 
    546       !!      between processors following neighboring subdomains. 
    547       !!            domain parameters 
    548       !!                    nlci   : first dimension of the local subdomain 
    549       !!                    nlcj   : second dimension of the local subdomain 
    550       !!                    nbondi : mark for "east-west local boundary" 
    551       !!                    nbondj : mark for "north-south local boundary" 
    552       !!                    noea   : number for local neighboring processors 
    553       !!                    nowe   : number for local neighboring processors 
    554       !!                    noso   : number for local neighboring processors 
    555       !!                    nono   : number for local neighboring processors 
    556       !!---------------------------------------------------------------------- 
    557       TYPE( arrayptr ), DIMENSION(:), INTENT(inout) ::   pt2d_array   ! pointer array of 2D fields  
    558       CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   type_array   ! nature of pt2d_array grid-points 
    559       REAL(wp)        , DIMENSION(:), INTENT(in   ) ::   psgn_array   ! sign used across the north fold boundary 
    560       INTEGER                       , INTENT(in   ) ::   kfld         ! number of pt2d arrays 
    561       CHARACTER(len=3), OPTIONAL    , INTENT(in   ) ::   cd_mpp       ! fill the overlap area only 
    562       REAL(wp)        , OPTIONAL    , INTENT(in   ) ::   pval         ! background value (used at closed boundaries) 
    563       ! 
    564       INTEGER  ::   ji, jj, jl, jf   ! dummy loop indices 
    565       INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
    566       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    567       REAL(wp) ::   zland 
    568       INTEGER , DIMENSION(MPI_STATUS_SIZE)    ::   ml_stat       ! for key_mpi_isend 
    569       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ns, zt2sn   ! 2d for north-south & south-north 
    570       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ew, zt2we   ! 2d for east-west & west-east 
    571       !!---------------------------------------------------------------------- 
    572       ! 
    573       ALLOCATE( zt2ns(jpi,jprecj,2*kfld), zt2sn(jpi,jprecj,2*kfld),  & 
    574          &      zt2ew(jpj,jpreci,2*kfld), zt2we(jpj,jpreci,2*kfld)   ) 
    575       ! 
    576       IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
    577       ELSE                         ;   zland = 0._wp     ! zero by default 
    578       ENDIF 
    579  
    580       ! 1. standard boundary treatment 
    581       ! ------------------------------ 
    582       ! 
    583       !First Array 
    584       DO jf = 1 , kfld 
    585          IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values 
    586             ! 
    587             ! WARNING pt2d is defined only between nld and nle 
    588             DO jj = nlcj+1, jpj                 ! added line(s)   (inner only) 
    589                pt2d_array(jf)%pt2d(nldi  :nlei  , jj) = pt2d_array(jf)%pt2d(nldi:nlei, nlej) 
    590                pt2d_array(jf)%pt2d(1     :nldi-1, jj) = pt2d_array(jf)%pt2d(nldi     , nlej) 
    591                pt2d_array(jf)%pt2d(nlei+1:nlci  , jj) = pt2d_array(jf)%pt2d(     nlei, nlej)  
    592             END DO 
    593             DO ji = nlci+1, jpi                 ! added column(s) (full) 
    594                pt2d_array(jf)%pt2d(ji, nldj  :nlej  ) = pt2d_array(jf)%pt2d(nlei, nldj:nlej) 
    595                pt2d_array(jf)%pt2d(ji, 1     :nldj-1) = pt2d_array(jf)%pt2d(nlei, nldj     ) 
    596                pt2d_array(jf)%pt2d(ji, nlej+1:jpj   ) = pt2d_array(jf)%pt2d(nlei,      nlej) 
    597             END DO 
    598             ! 
    599          ELSE                              ! standard close or cyclic treatment 
    600             ! 
    601             !                                   ! East-West boundaries 
    602             IF( nbondi == 2 .AND.   &                !* Cyclic 
    603                &    (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
    604                pt2d_array(jf)%pt2d(  1  , : ) = pt2d_array(jf)%pt2d( jpim1, : )                             ! west 
    605                pt2d_array(jf)%pt2d( jpi , : ) = pt2d_array(jf)%pt2d(   2  , : )                             ! east 
    606             ELSE                                     !* Closed 
    607                IF( .NOT. type_array(jf) == 'F' )   pt2d_array(jf)%pt2d(            1 : jpreci,:) = zland    ! south except F-point 
    608                                                    pt2d_array(jf)%pt2d(nlci-jpreci+1 : jpi   ,:) = zland    ! north 
    609             ENDIF 
    610             !                                   ! North-South boundaries 
    611             !                                        !* Cyclic 
    612             IF( nbondj == 2 .AND. jperio == 7 ) THEN 
    613                pt2d_array(jf)%pt2d(:,  1  ) =   pt2d_array(jf)%pt2d(:, jpjm1 ) 
    614                pt2d_array(jf)%pt2d(:, jpj ) =   pt2d_array(jf)%pt2d(:,   2   )           
    615             ELSE                                     !* Closed              
    616                IF( .NOT. type_array(jf) == 'F' )   pt2d_array(jf)%pt2d(:,             1:jprecj ) = zland    ! south except F-point 
    617                                                    pt2d_array(jf)%pt2d(:, nlcj-jprecj+1:jpj    ) = zland    ! north 
    618             ENDIF 
    619          ENDIF 
    620       END DO 
    621  
    622       ! 2. East and west directions exchange 
    623       ! ------------------------------------ 
    624       ! we play with the neigbours AND the row number because of the periodicity 
    625       ! 
    626       DO jf = 1 , kfld 
    627          SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
    628          CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    629             iihom = nlci-nreci 
    630             DO jl = 1, jpreci 
    631                zt2ew( : , jl , jf ) = pt2d_array(jf)%pt2d( jpreci+jl , : ) 
    632                zt2we( : , jl , jf ) = pt2d_array(jf)%pt2d( iihom +jl , : ) 
    633             END DO 
    634          END SELECT 
    635       END DO 
    636       ! 
    637       !                           ! Migrations 
    638       imigr = jpreci * jpj 
    639       ! 
    640       SELECT CASE ( nbondi ) 
    641       CASE ( -1 ) 
    642          CALL mppsend( 2, zt2we(1,1,1), kfld*imigr, noea, ml_req1 ) 
    643          CALL mpprecv( 1, zt2ew(1,1,kfld+1), kfld*imigr, noea ) 
    644          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    645       CASE ( 0 ) 
    646          CALL mppsend( 1, zt2ew(1,1,1), kfld*imigr, nowe, ml_req1 ) 
    647          CALL mppsend( 2, zt2we(1,1,1), kfld*imigr, noea, ml_req2 ) 
    648          CALL mpprecv( 1, zt2ew(1,1,kfld+1), kfld*imigr, noea ) 
    649          CALL mpprecv( 2, zt2we(1,1,kfld+1), kfld*imigr, nowe ) 
    650          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    651          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    652       CASE ( 1 ) 
    653          CALL mppsend( 1, zt2ew(1,1,1), kfld*imigr, nowe, ml_req1 ) 
    654          CALL mpprecv( 2, zt2we(1,1,kfld+1), kfld*imigr, nowe ) 
    655          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    656       END SELECT 
    657       ! 
    658       !                           ! Write Dirichlet lateral conditions 
    659       iihom = nlci - jpreci 
    660       ! 
    661  
    662       DO jf = 1 , kfld 
    663          SELECT CASE ( nbondi ) 
    664          CASE ( -1 ) 
    665             DO jl = 1, jpreci 
    666                pt2d_array(jf)%pt2d( iihom+jl ,:) = zt2ew(:,jl,kfld+jf) 
    667             END DO 
    668          CASE ( 0 ) 
    669             DO jl = 1, jpreci 
    670                pt2d_array(jf)%pt2d(       jl ,:) = zt2we(:,jl,kfld+jf) 
    671                pt2d_array(jf)%pt2d( iihom+jl ,:) = zt2ew(:,jl,kfld+jf) 
    672             END DO 
    673          CASE ( 1 ) 
    674             DO jl = 1, jpreci 
    675                pt2d_array(jf)%pt2d( jl ,:)= zt2we(:,jl,kfld+jf) 
    676             END DO 
    677          END SELECT 
    678       END DO 
    679        
    680       ! 3. North and south directions 
    681       ! ----------------------------- 
    682       ! always closed : we play only with the neigbours 
    683       ! 
    684       !First Array 
    685       DO jf = 1 , kfld 
    686          IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    687             ijhom = nlcj-nrecj 
    688             DO jl = 1, jprecj 
    689                zt2sn(:,jl,jf) = pt2d_array(jf)%pt2d(:, ijhom +jl ) 
    690                zt2ns(:,jl,jf) = pt2d_array(jf)%pt2d(:, jprecj+jl ) 
    691             END DO 
    692          ENDIF 
    693       END DO 
    694       ! 
    695       !                           ! Migrations 
    696       imigr = jprecj * jpi 
    697       ! 
    698       SELECT CASE ( nbondj ) 
    699       CASE ( -1 ) 
    700          CALL mppsend( 4, zt2sn(1,1,     1), kfld*imigr, nono, ml_req1 ) 
    701          CALL mpprecv( 3, zt2ns(1,1,kfld+1), kfld*imigr, nono ) 
    702          IF(l_isend)   CALL mpi_wait( ml_req1, ml_stat, ml_err ) 
    703       CASE ( 0 ) 
    704          CALL mppsend( 3, zt2ns(1,1,     1), kfld*imigr, noso, ml_req1 ) 
    705          CALL mppsend( 4, zt2sn(1,1,     1), kfld*imigr, nono, ml_req2 ) 
    706          CALL mpprecv( 3, zt2ns(1,1,kfld+1), kfld*imigr, nono ) 
    707          CALL mpprecv( 4, zt2sn(1,1,kfld+1), kfld*imigr, noso ) 
    708          IF(l_isend)   CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    709          IF(l_isend)   CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    710       CASE ( 1 ) 
    711          CALL mppsend( 3, zt2ns(1,1,     1), kfld*imigr, noso, ml_req1 ) 
    712          CALL mpprecv( 4, zt2sn(1,1,kfld+1), kfld*imigr, noso ) 
    713          IF(l_isend)   CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    714       END SELECT 
    715       ! 
    716       !                           ! Write Dirichlet lateral conditions 
    717       ijhom = nlcj - jprecj 
    718       ! 
    719       DO jf = 1 , kfld 
    720          SELECT CASE ( nbondj ) 
    721          CASE ( -1 ) 
    722             DO jl = 1, jprecj 
    723                pt2d_array(jf)%pt2d(:, ijhom+jl ) = zt2ns(:,jl, kfld+jf ) 
    724             END DO 
    725          CASE ( 0 ) 
    726             DO jl = 1, jprecj 
    727                pt2d_array(jf)%pt2d(:,       jl ) = zt2sn(:,jl, kfld+jf ) 
    728                pt2d_array(jf)%pt2d(:, ijhom+jl ) = zt2ns(:,jl, kfld+jf ) 
    729             END DO 
    730          CASE ( 1 ) 
    731             DO jl = 1, jprecj 
    732                pt2d_array(jf)%pt2d(:,       jl ) = zt2sn(:,jl, kfld+jf ) 
    733             END DO 
    734          END SELECT 
    735       END DO 
    736        
    737       ! 4. north fold treatment 
    738       ! ----------------------- 
    739       ! 
    740       IF( npolj /= 0 .AND. .NOT.PRESENT(cd_mpp) ) THEN 
    741          ! 
    742          SELECT CASE ( jpni ) 
    743          CASE ( 1 )   
    744             DO jf = 1, kfld   
    745                CALL lbc_nfd( pt2d_array(jf)%pt2d(:,:), type_array(jf), psgn_array(jf) )  ! only 1 northern proc, no mpp 
    746             END DO 
    747          CASE DEFAULT    
    748             CALL mpp_lbc_north_2d_multiple( pt2d_array, type_array, psgn_array, kfld )   ! for all northern procs. 
    749          END SELECT 
    750          ! 
    751       ENDIF 
    752       ! 
    753       DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 
    754       ! 
    755    END SUBROUTINE mpp_lnk_2d_multiple 
    756  
    757     
    758    SUBROUTINE load_array( pt2d, cd_type, psgn, pt2d_array, type_array, psgn_array, kfld ) 
    759       !!--------------------------------------------------------------------- 
    760       REAL(wp)        , DIMENSION(:,:), TARGET, INTENT(inout) ::   pt2d         ! 2D array on which the boundary condition is applied 
    761       CHARACTER(len=1)                        , INTENT(in   ) ::   cd_type      ! nature of pt2d array grid-points 
    762       REAL(wp)                                , INTENT(in   ) ::   psgn         ! sign used across the north fold boundary 
    763       TYPE(arrayptr)  , DIMENSION(:)          , INTENT(inout) ::   pt2d_array   !  
    764       CHARACTER(len=1), DIMENSION(:)          , INTENT(inout) ::   type_array   ! nature of pt2d_array array grid-points 
    765       REAL(wp)        , DIMENSION(:)          , INTENT(inout) ::   psgn_array   ! sign used across the north fold boundary 
    766       INTEGER                                 , INTENT(inout) ::   kfld         ! 
    767       !!--------------------------------------------------------------------- 
    768       ! 
    769       kfld                  =  kfld + 1 
    770       pt2d_array(kfld)%pt2d => pt2d 
    771       type_array(kfld)      =  cd_type 
    772       psgn_array(kfld)      =  psgn 
    773       ! 
    774    END SUBROUTINE load_array 
     336   !!---------------------------------------------------------------------- 
     337   !!                   ***  routine mpp_lnk_(2,3,4)d  *** 
     338   !! 
     339   !!   * Argument : dummy argument use in mpp_lnk_... routines 
     340   !!                ptab   :   array or pointer of arrays on which the boundary condition is applied 
     341   !!                cd_nat :   nature of array grid-points 
     342   !!                psgn   :   sign used across the north fold boundary 
     343   !!                kfld   :   optional, number of pt3d arrays 
     344   !!                cd_mpp :   optional, fill the overlap area only 
     345   !!                pval   :   optional, background value (used at closed boundaries) 
     346   !!---------------------------------------------------------------------- 
     347   ! 
     348   !                       !==  2D array and array of 2D pointer  ==! 
     349   ! 
     350#  define DIM_2d 
     351#     define ROUTINE_LNK           mpp_lnk_2d 
     352#     include "mpp_lnk_generic.h90" 
     353#     undef ROUTINE_LNK 
     354#     define MULTI 
     355#     define ROUTINE_LNK           mpp_lnk_2d_ptr 
     356#     include "mpp_lnk_generic.h90" 
     357#     undef ROUTINE_LNK 
     358#     undef MULTI 
     359#  undef DIM_2d 
     360   ! 
     361   !                       !==  3D array and array of 3D pointer  ==! 
     362   ! 
     363#  define DIM_3d 
     364#     define ROUTINE_LNK           mpp_lnk_3d 
     365#     include "mpp_lnk_generic.h90" 
     366#     undef ROUTINE_LNK 
     367#     define MULTI 
     368#     define ROUTINE_LNK           mpp_lnk_3d_ptr 
     369#     include "mpp_lnk_generic.h90" 
     370#     undef ROUTINE_LNK 
     371#     undef MULTI 
     372#  undef DIM_3d 
     373   ! 
     374   !                       !==  4D array and array of 4D pointer  ==! 
     375   ! 
     376#  define DIM_4d 
     377#     define ROUTINE_LNK           mpp_lnk_4d 
     378#     include "mpp_lnk_generic.h90" 
     379#     undef ROUTINE_LNK 
     380#     define MULTI 
     381#     define ROUTINE_LNK           mpp_lnk_4d_ptr 
     382#     include "mpp_lnk_generic.h90" 
     383#     undef ROUTINE_LNK 
     384#     undef MULTI 
     385#  undef DIM_4d 
     386 
     387   !!---------------------------------------------------------------------- 
     388   !!                   ***  routine mpp_nfd_(2,3,4)d  *** 
     389   !! 
     390   !!   * Argument : dummy argument use in mpp_nfd_... routines 
     391   !!                ptab   :   array or pointer of arrays on which the boundary condition is applied 
     392   !!                cd_nat :   nature of array grid-points 
     393   !!                psgn   :   sign used across the north fold boundary 
     394   !!                kfld   :   optional, number of pt3d arrays 
     395   !!                cd_mpp :   optional, fill the overlap area only 
     396   !!                pval   :   optional, background value (used at closed boundaries) 
     397   !!---------------------------------------------------------------------- 
     398   ! 
     399   !                       !==  2D array and array of 2D pointer  ==! 
     400   ! 
     401#  define DIM_2d 
     402#     define ROUTINE_NFD           mpp_nfd_2d 
     403#     include "mpp_nfd_generic.h90" 
     404#     undef ROUTINE_NFD 
     405#     define MULTI 
     406#     define ROUTINE_NFD           mpp_nfd_2d_ptr 
     407#     include "mpp_nfd_generic.h90" 
     408#     undef ROUTINE_NFD 
     409#     undef MULTI 
     410#  undef DIM_2d 
     411   ! 
     412   !                       !==  3D array and array of 3D pointer  ==! 
     413   ! 
     414#  define DIM_3d 
     415#     define ROUTINE_NFD           mpp_nfd_3d 
     416#     include "mpp_nfd_generic.h90" 
     417#     undef ROUTINE_NFD 
     418#     define MULTI 
     419#     define ROUTINE_NFD           mpp_nfd_3d_ptr 
     420#     include "mpp_nfd_generic.h90" 
     421#     undef ROUTINE_NFD 
     422#     undef MULTI 
     423#  undef DIM_3d 
     424   ! 
     425   !                       !==  4D array and array of 4D pointer  ==! 
     426   ! 
     427#  define DIM_4d 
     428#     define ROUTINE_NFD           mpp_nfd_4d 
     429#     include "mpp_nfd_generic.h90" 
     430#     undef ROUTINE_NFD 
     431#     define MULTI 
     432#     define ROUTINE_NFD           mpp_nfd_4d_ptr 
     433#     include "mpp_nfd_generic.h90" 
     434#     undef ROUTINE_NFD 
     435#     undef MULTI 
     436#  undef DIM_4d 
     437 
     438 
     439   !!---------------------------------------------------------------------- 
     440   !!                   ***  routine mpp_lnk_bdy_(2,3,4)d  *** 
     441   !! 
     442   !!   * Argument : dummy argument use in mpp_lnk_... routines 
     443   !!                ptab   :   array or pointer of arrays on which the boundary condition is applied 
     444   !!                cd_nat :   nature of array grid-points 
     445   !!                psgn   :   sign used across the north fold boundary 
     446   !!                kb_bdy :   BDY boundary set 
     447   !!                kfld   :   optional, number of pt3d arrays 
     448   !!---------------------------------------------------------------------- 
     449   ! 
     450   !                       !==  2D array and array of 2D pointer  ==! 
     451   ! 
     452#  define DIM_2d 
     453#     define ROUTINE_BDY           mpp_lnk_bdy_2d 
     454#     include "mpp_bdy_generic.h90" 
     455#     undef ROUTINE_BDY 
     456#     define MULTI 
     457#     define ROUTINE_BDY           mpp_lnk_bdy_2d_ptr 
     458#     include "mpp_bdy_generic.h90" 
     459#     undef ROUTINE_BDY 
     460#     undef MULTI 
     461#  undef DIM_2d 
     462   ! 
     463   !                       !==  3D array and array of 3D pointer  ==! 
     464   ! 
     465#  define DIM_3d 
     466#     define ROUTINE_BDY           mpp_lnk_bdy_3d 
     467#     include "mpp_bdy_generic.h90" 
     468#     undef ROUTINE_BDY 
     469#     define MULTI 
     470#     define ROUTINE_BDY           mpp_lnk_bdy_3d_ptr 
     471#     include "mpp_bdy_generic.h90" 
     472#     undef ROUTINE_BDY 
     473#     undef MULTI 
     474#  undef DIM_3d 
     475   ! 
     476   !                       !==  4D array and array of 4D pointer  ==! 
     477   ! 
     478!!#  define DIM_4d 
     479!!#     define ROUTINE_BDY           mpp_lnk_bdy_4d 
     480!!#     include "mpp_bdy_generic.h90" 
     481!!#     undef ROUTINE_BDY 
     482!!#     define MULTI 
     483!!#     define ROUTINE_BDY           mpp_lnk_bdy_4d_ptr 
     484!!#     include "mpp_bdy_generic.h90" 
     485!!#     undef ROUTINE_BDY 
     486!!#     undef MULTI 
     487!!#  undef DIM_4d 
     488 
     489   !!---------------------------------------------------------------------- 
     490   !! 
     491   !!   load_array  &   mpp_lnk_2d_9    à generaliser a 3D et 4D 
    775492    
    776493    
    777    SUBROUTINE mpp_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC   & 
    778       &                   , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF   & 
    779       &                   , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 
    780       !!--------------------------------------------------------------------- 
    781       REAL(wp), DIMENSION(jpi,jpj), TARGET          , INTENT(inout) ::   pt2dA    ! 2D arrays on which the lbc is applied 
    782       REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dB , pt2dC , pt2dD , pt2dE 
    783       REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dF , pt2dG , pt2dH , pt2dI  
    784       CHARACTER(len=1)                              , INTENT(in   ) ::   cd_typeA ! nature of pt2D. array grid-points 
    785       CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeB , cd_typeC , cd_typeD , cd_typeE 
    786       CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeF , cd_typeG , cd_typeH , cd_typeI 
    787       REAL(wp)                                      , INTENT(in   ) ::   psgnA    ! sign used across the north fold 
    788       REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnB , psgnC , psgnD , psgnE 
    789       REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnF , psgnG , psgnH , psgnI    
    790       CHARACTER(len=3)                    , OPTIONAL, INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
    791       REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
    792       !! 
    793       INTEGER :: kfld 
    794       TYPE(arrayptr)   , DIMENSION(9) ::   pt2d_array  
    795       CHARACTER(len=1) , DIMENSION(9) ::   type_array    ! define the nature of pt2d array grid-points 
    796       REAL(wp)         , DIMENSION(9) ::   psgn_array    ! sign used across the north fold boundary 
    797       !!--------------------------------------------------------------------- 
    798       ! 
    799       kfld = 0 
    800       ! 
    801       !                 ! Load the first array 
    802       CALL load_array( pt2dA, cd_typeA, psgnA, pt2d_array, type_array, psgn_array, kfld ) 
    803       ! 
    804       !                 ! Look if more arrays are added 
    805       IF( PRESENT(psgnB) )   CALL load_array( pt2dB, cd_typeB, psgnB, pt2d_array, type_array, psgn_array, kfld ) 
    806       IF( PRESENT(psgnC) )   CALL load_array( pt2dC, cd_typeC, psgnC, pt2d_array, type_array, psgn_array, kfld ) 
    807       IF( PRESENT(psgnD) )   CALL load_array( pt2dD, cd_typeD, psgnD, pt2d_array, type_array, psgn_array, kfld ) 
    808       IF( PRESENT(psgnE) )   CALL load_array( pt2dE, cd_typeE, psgnE, pt2d_array, type_array, psgn_array, kfld ) 
    809       IF( PRESENT(psgnF) )   CALL load_array( pt2dF, cd_typeF, psgnF, pt2d_array, type_array, psgn_array, kfld ) 
    810       IF( PRESENT(psgnG) )   CALL load_array( pt2dG, cd_typeG, psgnG, pt2d_array, type_array, psgn_array, kfld ) 
    811       IF( PRESENT(psgnH) )   CALL load_array( pt2dH, cd_typeH, psgnH, pt2d_array, type_array, psgn_array, kfld ) 
    812       IF( PRESENT(psgnI) )   CALL load_array( pt2dI, cd_typeI, psgnI, pt2d_array, type_array, psgn_array, kfld ) 
    813       ! 
    814       CALL mpp_lnk_2d_multiple( pt2d_array, type_array, psgn_array, kfld, cd_mpp,pval ) 
    815       ! 
    816    END SUBROUTINE mpp_lnk_2d_9 
    817  
    818  
    819    SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 
    820       !!---------------------------------------------------------------------- 
    821       !!                  ***  routine mpp_lnk_2d  *** 
    822       !! 
    823       !! ** Purpose :   Message passing manadgement for 2d array 
    824       !! 
    825       !! ** Method  :   Use mppsend and mpprecv function for passing mask 
    826       !!      between processors following neighboring subdomains. 
    827       !!            domain parameters 
    828       !!                    nlci   : first dimension of the local subdomain 
    829       !!                    nlcj   : second dimension of the local subdomain 
    830       !!                    nbondi : mark for "east-west local boundary" 
    831       !!                    nbondj : mark for "north-south local boundary" 
    832       !!                    noea   : number for local neighboring processors 
    833       !!                    nowe   : number for local neighboring processors 
    834       !!                    noso   : number for local neighboring processors 
    835       !!                    nono   : number for local neighboring processors 
    836       !! 
    837       !!---------------------------------------------------------------------- 
    838       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d     ! 2D array on which the boundary condition is applied 
    839       CHARACTER(len=1)            , INTENT(in   ) ::   cd_type  ! nature of pt2d array grid-points 
    840       REAL(wp)                    , INTENT(in   ) ::   psgn     ! sign used across the north fold boundary 
    841       CHARACTER(len=3), OPTIONAL  , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
    842       REAL(wp)        , OPTIONAL  , INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
    843       !! 
    844       INTEGER  ::   ji, jj, jl   ! dummy loop indices 
    845       INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
    846       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    847       REAL(wp) ::   zland 
    848       INTEGER, DIMENSION(MPI_STATUS_SIZE)     ::   ml_stat       ! for key_mpi_isend 
    849       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ns, zt2sn   ! 2d for north-south & south-north 
    850       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ew, zt2we   ! 2d for east-west & west-east 
    851       !!---------------------------------------------------------------------- 
    852       ! 
    853       ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2),  & 
    854          &      zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2)   ) 
    855       ! 
    856       IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
    857       ELSE                         ;   zland = 0._wp     ! zero by default 
    858       ENDIF 
    859  
    860       ! 1. standard boundary treatment 
    861       ! ------------------------------ 
    862       ! 
    863       IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values 
    864          ! 
    865          ! WARNING pt2d is defined only between nld and nle 
    866          DO jj = nlcj+1, jpj                 ! added line(s)   (inner only) 
    867             pt2d(nldi  :nlei  , jj          ) = pt2d(nldi:nlei,     nlej) 
    868             pt2d(1     :nldi-1, jj          ) = pt2d(nldi     ,     nlej) 
    869             pt2d(nlei+1:nlci  , jj          ) = pt2d(     nlei,     nlej) 
    870          END DO 
    871          DO ji = nlci+1, jpi                 ! added column(s) (full) 
    872             pt2d(ji           ,nldj  :nlej  ) = pt2d(     nlei,nldj:nlej) 
    873             pt2d(ji           ,1     :nldj-1) = pt2d(     nlei,nldj     ) 
    874             pt2d(ji           ,nlej+1:jpj   ) = pt2d(     nlei,     nlej) 
    875          END DO 
    876          ! 
    877       ELSE                              ! standard close or cyclic treatment 
    878          ! 
    879          !                                   ! East-West boundaries 
    880          IF( nbondi == 2 .AND.   &                !* cyclic 
    881             &    (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
    882             pt2d( 1 ,:) = pt2d(jpim1,:)                                          ! west 
    883             pt2d(jpi,:) = pt2d(  2  ,:)                                          ! east 
    884          ELSE                                     !* closed 
    885             IF( .NOT. cd_type == 'F' )   pt2d(     1       :jpreci,:) = zland    ! south except F-point 
    886                                          pt2d(nlci-jpreci+1:jpi   ,:) = zland    ! north 
    887          ENDIF 
    888          !                                   ! North-South boundaries 
    889          !                                        !* cyclic 
    890          IF( nbondj == 2 .AND. jperio == 7 ) THEN 
    891             pt2d(:,  1 ) = pt2d(:,jpjm1) 
    892             pt2d(:, jpj) = pt2d(:,    2) 
    893          ELSE                                     !* closed 
    894             IF( .NOT. cd_type == 'F' )   pt2d(:,     1       :jprecj) = zland    !south except F-point 
    895                                          pt2d(:,nlcj-jprecj+1:jpj   ) = zland    ! north 
    896          ENDIF 
    897       ENDIF 
    898  
    899       ! 2. East and west directions exchange 
    900       ! ------------------------------------ 
    901       ! we play with the neigbours AND the row number because of the periodicity 
    902       ! 
    903       SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
    904       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    905          iihom = nlci-nreci 
    906          DO jl = 1, jpreci 
    907             zt2ew(:,jl,1) = pt2d(jpreci+jl,:) 
    908             zt2we(:,jl,1) = pt2d(iihom +jl,:) 
    909          END DO 
    910       END SELECT 
    911       ! 
    912       !                           ! Migrations 
    913       imigr = jpreci * jpj 
    914       ! 
    915       SELECT CASE ( nbondi ) 
    916       CASE ( -1 ) 
    917          CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 ) 
    918          CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 
    919          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    920       CASE ( 0 ) 
    921          CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 
    922          CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 ) 
    923          CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 
    924          CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 
    925          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    926          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    927       CASE ( 1 ) 
    928          CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 
    929          CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 
    930          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    931       END SELECT 
    932       ! 
    933       !                           ! Write Dirichlet lateral conditions 
    934       iihom = nlci - jpreci 
    935       ! 
    936       SELECT CASE ( nbondi ) 
    937       CASE ( -1 ) 
    938          DO jl = 1, jpreci 
    939             pt2d(iihom+jl,:) = zt2ew(:,jl,2) 
    940          END DO 
    941       CASE ( 0 ) 
    942          DO jl = 1, jpreci 
    943             pt2d(jl      ,:) = zt2we(:,jl,2) 
    944             pt2d(iihom+jl,:) = zt2ew(:,jl,2) 
    945          END DO 
    946       CASE ( 1 ) 
    947          DO jl = 1, jpreci 
    948             pt2d(jl      ,:) = zt2we(:,jl,2) 
    949          END DO 
    950       END SELECT 
    951  
    952       ! 3. North and south directions 
    953       ! ----------------------------- 
    954       ! always closed : we play only with the neigbours 
    955       ! 
    956       IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    957          ijhom = nlcj-nrecj 
    958          DO jl = 1, jprecj 
    959             zt2sn(:,jl,1) = pt2d(:,ijhom +jl) 
    960             zt2ns(:,jl,1) = pt2d(:,jprecj+jl) 
    961          END DO 
    962       ENDIF 
    963       ! 
    964       !                           ! Migrations 
    965       imigr = jprecj * jpi 
    966       ! 
    967       SELECT CASE ( nbondj ) 
    968       CASE ( -1 ) 
    969          CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 ) 
    970          CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 
    971          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    972       CASE ( 0 ) 
    973          CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 
    974          CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 ) 
    975          CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 
    976          CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 
    977          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    978          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    979       CASE ( 1 ) 
    980          CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 
    981          CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 
    982          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    983       END SELECT 
    984       ! 
    985       !                           ! Write Dirichlet lateral conditions 
    986       ijhom = nlcj - jprecj 
    987       ! 
    988       SELECT CASE ( nbondj ) 
    989       CASE ( -1 ) 
    990          DO jl = 1, jprecj 
    991             pt2d(:,ijhom+jl) = zt2ns(:,jl,2) 
    992          END DO 
    993       CASE ( 0 ) 
    994          DO jl = 1, jprecj 
    995             pt2d(:,jl      ) = zt2sn(:,jl,2) 
    996             pt2d(:,ijhom+jl) = zt2ns(:,jl,2) 
    997          END DO 
    998       CASE ( 1 ) 
    999          DO jl = 1, jprecj 
    1000             pt2d(:,jl      ) = zt2sn(:,jl,2) 
    1001          END DO 
    1002       END SELECT 
    1003  
    1004       ! 4. north fold treatment 
    1005       ! ----------------------- 
    1006       ! 
    1007       IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
    1008          ! 
    1009          SELECT CASE ( jpni ) 
    1010          CASE ( 1 )     ;   CALL lbc_nfd      ( pt2d, cd_type, psgn )   ! only 1 northern proc, no mpp 
    1011          CASE DEFAULT   ;   CALL mpp_lbc_north( pt2d, cd_type, psgn )   ! for all northern procs. 
    1012          END SELECT 
    1013          ! 
    1014       ENDIF 
    1015       ! 
    1016       DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 
    1017       ! 
    1018    END SUBROUTINE mpp_lnk_2d 
    1019  
    1020  
    1021    SUBROUTINE mpp_lnk_3d_gather( ptab1, cd_type1, ptab2, cd_type2, psgn ) 
    1022       !!---------------------------------------------------------------------- 
    1023       !!                  ***  routine mpp_lnk_3d_gather  *** 
    1024       !! 
    1025       !! ** Purpose :   Message passing manadgement for two 3D arrays 
    1026       !! 
    1027       !! ** Method  :   Use mppsend and mpprecv function for passing mask 
    1028       !!      between processors following neighboring subdomains. 
    1029       !!            domain parameters 
    1030       !!                    nlci   : first dimension of the local subdomain 
    1031       !!                    nlcj   : second dimension of the local subdomain 
    1032       !!                    nbondi : mark for "east-west local boundary" 
    1033       !!                    nbondj : mark for "north-south local boundary" 
    1034       !!                    noea   : number for local neighboring processors 
    1035       !!                    nowe   : number for local neighboring processors 
    1036       !!                    noso   : number for local neighboring processors 
    1037       !!                    nono   : number for local neighboring processors 
    1038       !! 
    1039       !! ** Action  :   ptab1 and ptab2  with update value at its periphery 
    1040       !! 
    1041       !!---------------------------------------------------------------------- 
    1042       REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   ptab1     ! 1st 3D array on which the boundary condition is applied 
    1043       CHARACTER(len=1)          , INTENT(in   ) ::   cd_type1  ! nature of ptab1 arrays 
    1044       REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   ptab2     ! 3nd 3D array on which the boundary condition is applied 
    1045       CHARACTER(len=1)          , INTENT(in   ) ::   cd_type2  ! nature of ptab2 arrays 
    1046       REAL(wp)                  , INTENT(in   ) ::   psgn      ! sign used across the north fold boundary 
    1047       ! 
    1048       INTEGER  ::   jl                         ! dummy loop indices 
    1049       INTEGER  ::   ipk                        ! 3rd dimension of the input array 
    1050       INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
    1051       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    1052       INTEGER , DIMENSION(MPI_STATUS_SIZE)        ::   ml_stat   ! for key_mpi_isend 
    1053       REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE ::   zt4ns, zt4sn   ! 2 x 3d for north-south & south-north 
    1054       REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE ::   zt4ew, zt4we   ! 2 x 3d for east-west & west-east 
    1055       !!---------------------------------------------------------------------- 
    1056       ! 
    1057       ipk = SIZE( ptab1, 3 ) 
    1058       ! 
    1059       ALLOCATE( zt4ns(jpi,jprecj,ipk,2,2), zt4sn(jpi,jprecj,ipk,2,2) ,    & 
    1060          &      zt4ew(jpj,jpreci,ipk,2,2), zt4we(jpj,jpreci,ipk,2,2) ) 
    1061  
    1062       ! 1. standard boundary treatment 
    1063       ! ------------------------------ 
    1064       !                                      ! East-West boundaries 
    1065       !                                           !* Cyclic  
    1066       IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
    1067          ptab1( 1 ,:,:) = ptab1(jpim1,:,:) 
    1068          ptab1(jpi,:,:) = ptab1(  2  ,:,:) 
    1069          ptab2( 1 ,:,:) = ptab2(jpim1,:,:) 
    1070          ptab2(jpi,:,:) = ptab2(  2  ,:,:) 
    1071       ELSE                                        !* closed 
    1072          IF( .NOT. cd_type1 == 'F' )   ptab1(     1       :jpreci,:,:) = 0._wp   ! south except at F-point 
    1073          IF( .NOT. cd_type2 == 'F' )   ptab2(     1       :jpreci,:,:) = 0._wp 
    1074                                        ptab1(nlci-jpreci+1:jpi   ,:,:) = 0._wp   ! north 
    1075                                        ptab2(nlci-jpreci+1:jpi   ,:,:) = 0._wp 
    1076       ENDIF 
    1077       !                                     ! North-South boundaries 
    1078       !                                           !* cyclic 
    1079       IF( nbondj == 2 .AND. jperio == 7 ) THEN 
    1080          ptab1(:,  1  ,:) = ptab1(:, jpjm1 , :) 
    1081          ptab1(:, jpj ,:) = ptab1(:,   2   , :) 
    1082          ptab2(:,  1  ,:) = ptab2(:, jpjm1 , :) 
    1083          ptab2(:, jpj ,:) = ptab2(:,   2   , :) 
    1084       ELSE      
    1085          !                                        !* closed 
    1086          IF( .NOT. cd_type1 == 'F' )   ptab1(:,     1       :jprecj,:) = 0._wp   ! south except at F-point 
    1087          IF( .NOT. cd_type2 == 'F' )   ptab2(:,     1       :jprecj,:) = 0._wp 
    1088                                        ptab1(:,nlcj-jprecj+1:jpj   ,:) = 0._wp   ! north 
    1089                                        ptab2(:,nlcj-jprecj+1:jpj   ,:) = 0._wp 
    1090       ENDIF 
    1091  
    1092       ! 2. East and west directions exchange 
    1093       ! ------------------------------------ 
    1094       ! we play with the neigbours AND the row number because of the periodicity 
    1095       ! 
    1096       SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
    1097       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    1098          iihom = nlci-nreci 
    1099          DO jl = 1, jpreci 
    1100             zt4ew(:,jl,:,1,1) = ptab1(jpreci+jl,:,:) 
    1101             zt4we(:,jl,:,1,1) = ptab1(iihom +jl,:,:) 
    1102             zt4ew(:,jl,:,2,1) = ptab2(jpreci+jl,:,:) 
    1103             zt4we(:,jl,:,2,1) = ptab2(iihom +jl,:,:) 
    1104          END DO 
    1105       END SELECT 
    1106       ! 
    1107       !                           ! Migrations 
    1108       imigr = jpreci * jpj * ipk *2 
    1109       ! 
    1110       SELECT CASE ( nbondi ) 
    1111       CASE ( -1 ) 
    1112          CALL mppsend( 2, zt4we(1,1,1,1,1), imigr, noea, ml_req1 ) 
    1113          CALL mpprecv( 1, zt4ew(1,1,1,1,2), imigr, noea ) 
    1114          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1115       CASE ( 0 ) 
    1116          CALL mppsend( 1, zt4ew(1,1,1,1,1), imigr, nowe, ml_req1 ) 
    1117          CALL mppsend( 2, zt4we(1,1,1,1,1), imigr, noea, ml_req2 ) 
    1118          CALL mpprecv( 1, zt4ew(1,1,1,1,2), imigr, noea ) 
    1119          CALL mpprecv( 2, zt4we(1,1,1,1,2), imigr, nowe ) 
    1120          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1121          IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    1122       CASE ( 1 ) 
    1123          CALL mppsend( 1, zt4ew(1,1,1,1,1), imigr, nowe, ml_req1 ) 
    1124          CALL mpprecv( 2, zt4we(1,1,1,1,2), imigr, nowe ) 
    1125          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1126       END SELECT 
    1127       ! 
    1128       !                           ! Write Dirichlet lateral conditions 
    1129       iihom = nlci - jpreci 
    1130       ! 
    1131       SELECT CASE ( nbondi ) 
    1132       CASE ( -1 ) 
    1133          DO jl = 1, jpreci 
    1134             ptab1(iihom+jl,:,:) = zt4ew(:,jl,:,1,2) 
    1135             ptab2(iihom+jl,:,:) = zt4ew(:,jl,:,2,2) 
    1136          END DO 
    1137       CASE ( 0 ) 
    1138          DO jl = 1, jpreci 
    1139             ptab1(jl      ,:,:) = zt4we(:,jl,:,1,2) 
    1140             ptab1(iihom+jl,:,:) = zt4ew(:,jl,:,1,2) 
    1141             ptab2(jl      ,:,:) = zt4we(:,jl,:,2,2) 
    1142             ptab2(iihom+jl,:,:) = zt4ew(:,jl,:,2,2) 
    1143          END DO 
    1144       CASE ( 1 ) 
    1145          DO jl = 1, jpreci 
    1146             ptab1(jl      ,:,:) = zt4we(:,jl,:,1,2) 
    1147             ptab2(jl      ,:,:) = zt4we(:,jl,:,2,2) 
    1148          END DO 
    1149       END SELECT 
    1150  
    1151       ! 3. North and south directions 
    1152       ! ----------------------------- 
    1153       ! always closed : we play only with the neigbours 
    1154       ! 
    1155       IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    1156          ijhom = nlcj - nrecj 
    1157          DO jl = 1, jprecj 
    1158             zt4sn(:,jl,:,1,1) = ptab1(:,ijhom +jl,:) 
    1159             zt4ns(:,jl,:,1,1) = ptab1(:,jprecj+jl,:) 
    1160             zt4sn(:,jl,:,2,1) = ptab2(:,ijhom +jl,:) 
    1161             zt4ns(:,jl,:,2,1) = ptab2(:,jprecj+jl,:) 
    1162          END DO 
    1163       ENDIF 
    1164       ! 
    1165       !                           ! Migrations 
    1166       imigr = jprecj * jpi * ipk * 2 
    1167       ! 
    1168       SELECT CASE ( nbondj ) 
    1169       CASE ( -1 ) 
    1170          CALL mppsend( 4, zt4sn(1,1,1,1,1), imigr, nono, ml_req1 ) 
    1171          CALL mpprecv( 3, zt4ns(1,1,1,1,2), imigr, nono ) 
    1172          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1173       CASE ( 0 ) 
    1174          CALL mppsend( 3, zt4ns(1,1,1,1,1), imigr, noso, ml_req1 ) 
    1175          CALL mppsend( 4, zt4sn(1,1,1,1,1), imigr, nono, ml_req2 ) 
    1176          CALL mpprecv( 3, zt4ns(1,1,1,1,2), imigr, nono ) 
    1177          CALL mpprecv( 4, zt4sn(1,1,1,1,2), imigr, noso ) 
    1178          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1179          IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    1180       CASE ( 1 ) 
    1181          CALL mppsend( 3, zt4ns(1,1,1,1,1), imigr, noso, ml_req1 ) 
    1182          CALL mpprecv( 4, zt4sn(1,1,1,1,2), imigr, noso ) 
    1183          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1184       END SELECT 
    1185       ! 
    1186       !                           ! Write Dirichlet lateral conditions 
    1187       ijhom = nlcj - jprecj 
    1188       ! 
    1189       SELECT CASE ( nbondj ) 
    1190       CASE ( -1 ) 
    1191          DO jl = 1, jprecj 
    1192             ptab1(:,ijhom+jl,:) = zt4ns(:,jl,:,1,2) 
    1193             ptab2(:,ijhom+jl,:) = zt4ns(:,jl,:,2,2) 
    1194          END DO 
    1195       CASE ( 0 ) 
    1196          DO jl = 1, jprecj 
    1197             ptab1(:,jl      ,:) = zt4sn(:,jl,:,1,2) 
    1198             ptab1(:,ijhom+jl,:) = zt4ns(:,jl,:,1,2) 
    1199             ptab2(:,jl      ,:) = zt4sn(:,jl,:,2,2) 
    1200             ptab2(:,ijhom+jl,:) = zt4ns(:,jl,:,2,2) 
    1201          END DO 
    1202       CASE ( 1 ) 
    1203          DO jl = 1, jprecj 
    1204             ptab1(:,jl,:) = zt4sn(:,jl,:,1,2) 
    1205             ptab2(:,jl,:) = zt4sn(:,jl,:,2,2) 
    1206          END DO 
    1207       END SELECT 
    1208  
    1209       ! 4. north fold treatment 
    1210       ! ----------------------- 
    1211       IF( npolj /= 0 ) THEN 
    1212          ! 
    1213          SELECT CASE ( jpni ) 
    1214          CASE ( 1 ) 
    1215             CALL lbc_nfd      ( ptab1, cd_type1, psgn )   ! only for northern procs. 
    1216             CALL lbc_nfd      ( ptab2, cd_type2, psgn ) 
    1217          CASE DEFAULT 
    1218             CALL mpp_lbc_north( ptab1, cd_type1, psgn )   ! for all northern procs. 
    1219             CALL mpp_lbc_north (ptab2, cd_type2, psgn) 
    1220          END SELECT 
    1221          ! 
    1222       ENDIF 
    1223       ! 
    1224       DEALLOCATE( zt4ns, zt4sn, zt4ew, zt4we ) 
    1225       ! 
    1226    END SUBROUTINE mpp_lnk_3d_gather 
     494   !!    mpp_lnk_2d_e     utilisé dans ICB  
     495 
     496 
     497   !!    mpp_lnk_sum_2d et 3D   ====>>>>>>   à virer du code !!!! 
     498    
     499    
     500   !!---------------------------------------------------------------------- 
    1227501 
    1228502 
     
    1297571         ! 
    1298572         SELECT CASE ( jpni ) 
    1299          CASE ( 1 )     ;   CALL lbc_nfd        ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj ) 
    1300          CASE DEFAULT   ;   CALL mpp_lbc_north_e( pt2d                  , cd_type, psgn             ) 
     573!!gm ERROR        CASE ( 1 )     ;   CALL lbc_nfd        ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj ) 
     574!!gm ERROR         CASE DEFAULT   ;   CALL mpp_lbc_north_e( pt2d                  , cd_type, psgn             ) 
    1301575         END SELECT 
    1302576         ! 
     
    1411685 
    1412686 
    1413    SUBROUTINE mpp_lnk_sum_3d( ptab, cd_type, psgn, cd_mpp, pval ) 
    1414       !!---------------------------------------------------------------------- 
    1415       !!                  ***  routine mpp_lnk_sum_3d  *** 
    1416       !! 
    1417       !! ** Purpose :   Message passing manadgement (sum the overlap region) 
    1418       !! 
    1419       !! ** Method  :   Use mppsend and mpprecv function for passing mask 
    1420       !!      between processors following neighboring subdomains. 
    1421       !!            domain parameters 
    1422       !!                    nlci   : first dimension of the local subdomain 
    1423       !!                    nlcj   : second dimension of the local subdomain 
    1424       !!                    nbondi : mark for "east-west local boundary" 
    1425       !!                    nbondj : mark for "north-south local boundary" 
    1426       !!                    noea   : number for local neighboring processors 
    1427       !!                    nowe   : number for local neighboring processors 
    1428       !!                    noso   : number for local neighboring processors 
    1429       !!                    nono   : number for local neighboring processors 
    1430       !! 
    1431       !! ** Action  :   ptab with update value at its periphery 
    1432       !! 
    1433       !!---------------------------------------------------------------------- 
    1434       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied 
    1435       CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  !  nature of ptab array grid-points 
    1436       REAL(wp)                        , INTENT(in   ) ::   psgn     ! sign used across the north fold boundary 
    1437       CHARACTER(len=3), OPTIONAL      , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
    1438       REAL(wp)        , OPTIONAL      , INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
    1439       ! 
    1440       INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices 
    1441       INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
    1442       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    1443       REAL(wp) ::   zland 
    1444       INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
    1445       ! 
    1446       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ns, zt3sn   ! 3d for north-south & south-north 
    1447       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ew, zt3we   ! 3d for east-west & west-east 
    1448       !!---------------------------------------------------------------------- 
    1449       ! 
    1450       ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2),   & 
    1451          &      zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2)  ) 
    1452       ! 
    1453       IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
    1454       ELSE                         ;   zland = 0._wp     ! zero by default 
    1455       ENDIF 
    1456  
    1457       ! 1. standard boundary treatment 
    1458       ! ------------------------------ 
    1459       ! 2. East and west directions exchange 
    1460       ! ------------------------------------ 
    1461       ! we play with the neigbours AND the row number because of the periodicity 
    1462       ! 
    1463       SELECT CASE ( nbondi )      ! Read lateral conditions 
    1464       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    1465       iihom = nlci-jpreci 
    1466          DO jl = 1, jpreci 
    1467             zt3ew(:,jl,:,1) = ptab(jl      ,:,:) ; ptab(jl      ,:,:) = 0._wp 
    1468             zt3we(:,jl,:,1) = ptab(iihom+jl,:,:) ; ptab(iihom+jl,:,:) = 0._wp  
    1469          END DO 
    1470       END SELECT 
    1471       ! 
    1472       !                           ! Migrations 
    1473       imigr = jpreci * jpj * jpk 
    1474       ! 
    1475       SELECT CASE ( nbondi ) 
    1476       CASE ( -1 ) 
    1477          CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 ) 
    1478          CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 
    1479          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1480       CASE ( 0 ) 
    1481          CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
    1482          CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 ) 
    1483          CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 
    1484          CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 
    1485          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1486          IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    1487       CASE ( 1 ) 
    1488          CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
    1489          CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 
    1490          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1491       END SELECT 
    1492       ! 
    1493       !                           ! Write lateral conditions 
    1494       iihom = nlci-nreci 
    1495       ! 
    1496       SELECT CASE ( nbondi ) 
    1497       CASE ( -1 ) 
    1498          DO jl = 1, jpreci 
    1499             ptab(iihom +jl,:,:) = ptab(iihom +jl,:,:) + zt3ew(:,jl,:,2) 
    1500          END DO 
    1501       CASE ( 0 ) 
    1502          DO jl = 1, jpreci 
    1503             ptab(jpreci+jl,:,:) = ptab(jpreci+jl,:,:) + zt3we(:,jl,:,2) 
    1504             ptab(iihom +jl,:,:) = ptab(iihom +jl,:,:) + zt3ew(:,jl,:,2) 
    1505          END DO 
    1506       CASE ( 1 ) 
    1507          DO jl = 1, jpreci 
    1508             ptab(jpreci+jl,:,:) = ptab(jpreci+jl,:,:) + zt3we(:,jl,:,2) 
    1509          END DO 
    1510       END SELECT 
    1511  
    1512       ! 3. North and south directions 
    1513       ! ----------------------------- 
    1514       ! always closed : we play only with the neigbours 
    1515       ! 
    1516       IF( nbondj /= 2 ) THEN      ! Read lateral conditions 
    1517          ijhom = nlcj-jprecj 
    1518          DO jl = 1, jprecj 
    1519             zt3sn(:,jl,:,1) = ptab(:,ijhom+jl,:)   ;   ptab(:,ijhom+jl,:) = 0._wp 
    1520             zt3ns(:,jl,:,1) = ptab(:,jl      ,:)   ;   ptab(:,jl      ,:) = 0._wp 
    1521          END DO 
    1522       ENDIF 
    1523       ! 
    1524       !                           ! Migrations 
    1525       imigr = jprecj * jpi * jpk 
    1526       ! 
    1527       SELECT CASE ( nbondj ) 
    1528       CASE ( -1 ) 
    1529          CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 ) 
    1530          CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 
    1531          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1532       CASE ( 0 ) 
    1533          CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 
    1534          CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 ) 
    1535          CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 
    1536          CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 
    1537          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1538          IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    1539       CASE ( 1 ) 
    1540          CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 
    1541          CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 
    1542          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1543       END SELECT 
    1544       ! 
    1545       !                           ! Write lateral conditions 
    1546       ijhom = nlcj-nrecj 
    1547       ! 
    1548       SELECT CASE ( nbondj ) 
    1549       CASE ( -1 ) 
    1550          DO jl = 1, jprecj 
    1551             ptab(:,ijhom+jl,:) = ptab(:,ijhom+jl,:) + zt3ns(:,jl,:,2) 
    1552          END DO 
    1553       CASE ( 0 ) 
    1554          DO jl = 1, jprecj 
    1555             ptab(:,jprecj+jl,:) = ptab(:,jprecj+jl,:) + zt3sn(:,jl,:,2) 
    1556             ptab(:,ijhom +jl,:) = ptab(:,ijhom +jl,:) + zt3ns(:,jl,:,2) 
    1557          END DO 
    1558       CASE ( 1 ) 
    1559          DO jl = 1, jprecj 
    1560             ptab(:,jprecj+jl,:) = ptab(:,jprecj+jl,:) + zt3sn(:,jl   ,:,2) 
    1561          END DO 
    1562       END SELECT 
    1563  
    1564       ! 4. north fold treatment 
    1565       ! ----------------------- 
    1566       ! 
    1567       IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
    1568          ! 
    1569          SELECT CASE ( jpni ) 
    1570          CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp 
    1571          CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs. 
    1572          END SELECT 
    1573          ! 
    1574       ENDIF 
    1575       ! 
    1576       DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we ) 
    1577       ! 
    1578    END SUBROUTINE mpp_lnk_sum_3d 
    1579  
    1580  
    1581    SUBROUTINE mpp_lnk_sum_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 
    1582       !!---------------------------------------------------------------------- 
    1583       !!                  ***  routine mpp_lnk_sum_2d  *** 
    1584       !! 
    1585       !! ** Purpose :   Message passing manadgement for 2d array (sum the overlap region) 
    1586       !! 
    1587       !! ** Method  :   Use mppsend and mpprecv function for passing mask 
    1588       !!      between processors following neighboring subdomains. 
    1589       !!            domain parameters 
    1590       !!                    nlci   : first dimension of the local subdomain 
    1591       !!                    nlcj   : second dimension of the local subdomain 
    1592       !!                    nbondi : mark for "east-west local boundary" 
    1593       !!                    nbondj : mark for "north-south local boundary" 
    1594       !!                    noea   : number for local neighboring processors 
    1595       !!                    nowe   : number for local neighboring processors 
    1596       !!                    noso   : number for local neighboring processors 
    1597       !!                    nono   : number for local neighboring processors 
    1598       !!---------------------------------------------------------------------- 
    1599       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d     ! 2D array on which the boundary condition is applied 
    1600       CHARACTER(len=1)            , INTENT(in   ) ::   cd_type  ! nature of pt2d array grid-points 
    1601       REAL(wp)                    , INTENT(in   ) ::   psgn     ! sign used across the north fold boundary 
    1602       CHARACTER(len=3), OPTIONAL  , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
    1603       REAL(wp)        , OPTIONAL  , INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
    1604       !! 
    1605       INTEGER  ::   ji, jj, jl   ! dummy loop indices 
    1606       INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
    1607       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    1608       REAL(wp) ::   zland 
    1609       INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
    1610       ! 
    1611       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ns, zt2sn   ! 2d for north-south & south-north 
    1612       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ew, zt2we   ! 2d for east-west & west-east 
    1613       !!---------------------------------------------------------------------- 
    1614       ! 
    1615       ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2),  & 
    1616          &      zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2)   ) 
    1617       ! 
    1618       IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
    1619       ELSE                         ;   zland = 0._wp     ! zero by default 
    1620       ENDIF 
    1621  
    1622       ! 1. standard boundary treatment 
    1623       ! ------------------------------ 
    1624       ! 2. East and west directions exchange 
    1625       ! ------------------------------------ 
    1626       ! we play with the neigbours AND the row number because of the periodicity 
    1627       ! 
    1628       SELECT CASE ( nbondi )      ! Read lateral conditions 
    1629       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    1630          iihom = nlci - jpreci 
    1631          DO jl = 1, jpreci 
    1632             zt2ew(:,jl,1) = pt2d(jl       ,:) ; pt2d(jl       ,:) = 0.0_wp 
    1633             zt2we(:,jl,1) = pt2d(iihom +jl,:) ; pt2d(iihom +jl,:) = 0.0_wp 
    1634          END DO 
    1635       END SELECT 
    1636       ! 
    1637       !                           ! Migrations 
    1638       imigr = jpreci * jpj 
    1639       ! 
    1640       SELECT CASE ( nbondi ) 
    1641       CASE ( -1 ) 
    1642          CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 ) 
    1643          CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 
    1644          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1645       CASE ( 0 ) 
    1646          CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 
    1647          CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 ) 
    1648          CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 
    1649          CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 
    1650          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1651          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    1652       CASE ( 1 ) 
    1653          CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 
    1654          CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 
    1655          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1656       END SELECT 
    1657       ! 
    1658       !                           ! Write lateral conditions 
    1659       iihom = nlci-nreci 
    1660       ! 
    1661       SELECT CASE ( nbondi ) 
    1662       CASE ( -1 ) 
    1663          DO jl = 1, jpreci 
    1664             pt2d(iihom+jl,:) = pt2d(iihom+jl,:) + zt2ew(:,jl,2) 
    1665          END DO 
    1666       CASE ( 0 ) 
    1667          DO jl = 1, jpreci 
    1668             pt2d(jpreci+jl,:) = pt2d(jpreci+jl,:) + zt2we(:,jl,2) 
    1669             pt2d(iihom +jl,:) = pt2d(iihom +jl,:) + zt2ew(:,jl,2) 
    1670          END DO 
    1671       CASE ( 1 ) 
    1672          DO jl = 1, jpreci 
    1673             pt2d(jpreci+jl,:) = pt2d(jpreci+jl,:) + zt2we(:,jl,2) 
    1674          END DO 
    1675       END SELECT 
    1676  
    1677  
    1678       ! 3. North and south directions 
    1679       ! ----------------------------- 
    1680       ! always closed : we play only with the neigbours 
    1681       ! 
    1682       IF( nbondj /= 2 ) THEN      ! Read lateral conditions 
    1683          ijhom = nlcj - jprecj 
    1684          DO jl = 1, jprecj 
    1685             zt2sn(:,jl,1) = pt2d(:,ijhom +jl) ; pt2d(:,ijhom +jl) = 0.0_wp 
    1686             zt2ns(:,jl,1) = pt2d(:,jl       ) ; pt2d(:,jl       ) = 0.0_wp 
    1687          END DO 
    1688       ENDIF 
    1689       ! 
    1690       !                           ! Migrations 
    1691       imigr = jprecj * jpi 
    1692       ! 
    1693       SELECT CASE ( nbondj ) 
    1694       CASE ( -1 ) 
    1695          CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 ) 
    1696          CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 
    1697          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1698       CASE ( 0 ) 
    1699          CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 
    1700          CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 ) 
    1701          CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 
    1702          CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 
    1703          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1704          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    1705       CASE ( 1 ) 
    1706          CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 
    1707          CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 
    1708          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1709       END SELECT 
    1710       ! 
    1711       !                           ! Write lateral conditions 
    1712       ijhom = nlcj-nrecj 
    1713       ! 
    1714       SELECT CASE ( nbondj ) 
    1715       CASE ( -1 ) 
    1716          DO jl = 1, jprecj 
    1717             pt2d(:,ijhom+jl) = pt2d(:,ijhom+jl) + zt2ns(:,jl,2) 
    1718          END DO 
    1719       CASE ( 0 ) 
    1720          DO jl = 1, jprecj 
    1721             pt2d(:,jprecj+jl) = pt2d(:,jprecj+jl) + zt2sn(:,jl,2) 
    1722             pt2d(:,ijhom +jl) = pt2d(:,ijhom +jl) + zt2ns(:,jl,2) 
    1723          END DO 
    1724       CASE ( 1 ) 
    1725          DO jl = 1, jprecj 
    1726             pt2d(:,jprecj+jl) = pt2d(:,jprecj+jl) + zt2sn(:,jl,2) 
    1727          END DO 
    1728       END SELECT 
    1729  
    1730       ! 4. north fold treatment 
    1731       ! ----------------------- 
    1732       ! 
    1733       IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
    1734          ! 
    1735          SELECT CASE ( jpni ) 
    1736          CASE ( 1 )     ;   CALL lbc_nfd      ( pt2d, cd_type, psgn )   ! only 1 northern proc, no mpp 
    1737          CASE DEFAULT   ;   CALL mpp_lbc_north( pt2d, cd_type, psgn )   ! for all northern procs. 
    1738          END SELECT 
    1739          ! 
    1740       ENDIF 
    1741       ! 
    1742       DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 
    1743       ! 
    1744    END SUBROUTINE mpp_lnk_sum_2d 
    1745  
    1746  
    1747687   SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, md_req ) 
    1748688      !!---------------------------------------------------------------------- 
     
    1845785   END SUBROUTINE mppscatter 
    1846786 
    1847  
     787   !!---------------------------------------------------------------------- 
     788   !!    ***  mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real  *** 
     789   !!    
     790   !!---------------------------------------------------------------------- 
     791   !! 
    1848792   SUBROUTINE mppmax_a_int( ktab, kdim, kcom ) 
    1849       !!---------------------------------------------------------------------- 
    1850       !!                  ***  routine mppmax_a_int  *** 
    1851       !! 
    1852       !! ** Purpose :   Find maximum value in an integer layout array 
    1853       !! 
    1854793      !!---------------------------------------------------------------------- 
    1855794      INTEGER , INTENT(in   )                  ::   kdim   ! size of array 
    1856795      INTEGER , INTENT(inout), DIMENSION(kdim) ::   ktab   ! input array 
    1857796      INTEGER , INTENT(in   ), OPTIONAL        ::   kcom   ! 
    1858       ! 
    1859       INTEGER :: ierror, localcomm   ! temporary integer 
     797      INTEGER :: ierror, ilocalcomm   ! temporary integer 
    1860798      INTEGER, DIMENSION(kdim) ::   iwork 
    1861799      !!---------------------------------------------------------------------- 
    1862       ! 
    1863       localcomm = mpi_comm_opa 
    1864       IF( PRESENT(kcom) )   localcomm = kcom 
    1865       ! 
    1866       CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_max, localcomm, ierror ) 
    1867       ! 
     800      ilocalcomm = mpi_comm_opa 
     801      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     802      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_max, ilocalcomm, ierror ) 
    1868803      ktab(:) = iwork(:) 
    1869       ! 
    1870804   END SUBROUTINE mppmax_a_int 
    1871  
    1872  
     805   !! 
    1873806   SUBROUTINE mppmax_int( ktab, kcom ) 
    1874       !!---------------------------------------------------------------------- 
    1875       !!                  ***  routine mppmax_int  *** 
    1876       !! 
    1877       !! ** Purpose :   Find maximum value in an integer layout array 
    1878       !! 
    1879807      !!---------------------------------------------------------------------- 
    1880808      INTEGER, INTENT(inout)           ::   ktab   ! ??? 
    1881809      INTEGER, INTENT(in   ), OPTIONAL ::   kcom   ! ??? 
    1882       ! 
    1883       INTEGER ::   ierror, iwork, localcomm   ! temporary integer 
    1884       !!---------------------------------------------------------------------- 
    1885       ! 
    1886       localcomm = mpi_comm_opa 
    1887       IF( PRESENT(kcom) )   localcomm = kcom 
    1888       ! 
    1889       CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_max, localcomm, ierror ) 
    1890       ! 
     810      INTEGER ::   ierror, iwork, ilocalcomm   ! temporary integer 
     811      !!---------------------------------------------------------------------- 
     812      ilocalcomm = mpi_comm_opa 
     813      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     814      CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_max, ilocalcomm, ierror ) 
    1891815      ktab = iwork 
    1892       ! 
    1893816   END SUBROUTINE mppmax_int 
    1894  
    1895  
     817   !! 
     818   SUBROUTINE mppmax_a_real( ptab, kdim, kcom ) 
     819      !!---------------------------------------------------------------------- 
     820      REAL(wp), DIMENSION(kdim), INTENT(inout) ::   ptab 
     821      INTEGER                  , INTENT(in   ) ::   kdim 
     822      INTEGER , OPTIONAL       , INTENT(in   ) ::   kcom 
     823      INTEGER :: ierror, ilocalcomm 
     824      REAL(wp), DIMENSION(kdim) ::  zwork 
     825      !!---------------------------------------------------------------------- 
     826      ilocalcomm = mpi_comm_opa 
     827      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     828      CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_max, ilocalcomm, ierror ) 
     829      ptab(:) = zwork(:) 
     830   END SUBROUTINE mppmax_a_real 
     831   !! 
     832   SUBROUTINE mppmax_real( ptab, kcom ) 
     833      !!---------------------------------------------------------------------- 
     834      REAL(wp), INTENT(inout)           ::   ptab   ! ??? 
     835      INTEGER , INTENT(in   ), OPTIONAL ::   kcom   ! ??? 
     836      INTEGER  ::   ierror, ilocalcomm 
     837      REAL(wp) ::   zwork 
     838      !!---------------------------------------------------------------------- 
     839      ilocalcomm = mpi_comm_opa 
     840      IF( PRESENT(kcom) )   ilocalcomm = kcom! 
     841      CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_max, ilocalcomm, ierror ) 
     842      ptab = zwork 
     843   END SUBROUTINE mppmax_real 
     844 
     845 
     846   !!---------------------------------------------------------------------- 
     847   !!    ***  mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real  *** 
     848   !!    
     849   !!---------------------------------------------------------------------- 
     850   !! 
    1896851   SUBROUTINE mppmin_a_int( ktab, kdim, kcom ) 
    1897       !!---------------------------------------------------------------------- 
    1898       !!                  ***  routine mppmin_a_int  *** 
    1899       !! 
    1900       !! ** Purpose :   Find minimum value in an integer layout array 
    1901       !! 
    1902852      !!---------------------------------------------------------------------- 
    1903853      INTEGER , INTENT( in  )                  ::   kdim   ! size of array 
     
    1905855      INTEGER , INTENT( in  ), OPTIONAL        ::   kcom   ! input array 
    1906856      !! 
    1907       INTEGER ::   ierror, localcomm   ! temporary integer 
     857      INTEGER ::   ierror, ilocalcomm   ! temporary integer 
    1908858      INTEGER, DIMENSION(kdim) ::   iwork 
    1909859      !!---------------------------------------------------------------------- 
    1910       ! 
    1911       localcomm = mpi_comm_opa 
    1912       IF( PRESENT(kcom) )   localcomm = kcom 
    1913       ! 
    1914       CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_min, localcomm, ierror ) 
    1915       ! 
     860      ilocalcomm = mpi_comm_opa 
     861      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     862      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_min, ilocalcomm, ierror ) 
    1916863      ktab(:) = iwork(:) 
    1917       ! 
    1918864   END SUBROUTINE mppmin_a_int 
    1919  
    1920  
     865   !! 
    1921866   SUBROUTINE mppmin_int( ktab, kcom ) 
    1922       !!---------------------------------------------------------------------- 
    1923       !!                  ***  routine mppmin_int  *** 
    1924       !! 
    1925       !! ** Purpose :   Find minimum value in an integer layout array 
    1926       !! 
    1927867      !!---------------------------------------------------------------------- 
    1928868      INTEGER, INTENT(inout) ::   ktab      ! ??? 
    1929869      INTEGER , INTENT( in  ), OPTIONAL        ::   kcom        ! input array 
    1930870      !! 
    1931       INTEGER ::  ierror, iwork, localcomm 
    1932       !!---------------------------------------------------------------------- 
    1933       ! 
    1934       localcomm = mpi_comm_opa 
    1935       IF( PRESENT(kcom) )   localcomm = kcom 
    1936       ! 
    1937       CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_min, localcomm, ierror ) 
    1938       ! 
     871      INTEGER ::  ierror, iwork, ilocalcomm 
     872      !!---------------------------------------------------------------------- 
     873      ilocalcomm = mpi_comm_opa 
     874      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     875      CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_min, ilocalcomm, ierror ) 
    1939876      ktab = iwork 
    1940       ! 
    1941877   END SUBROUTINE mppmin_int 
    1942  
    1943  
     878   !! 
     879   SUBROUTINE mppmin_a_real( ptab, kdim, kcom ) 
     880      !!---------------------------------------------------------------------- 
     881      INTEGER , INTENT(in   )                  ::   kdim 
     882      REAL(wp), INTENT(inout), DIMENSION(kdim) ::   ptab 
     883      INTEGER , INTENT(in   ), OPTIONAL        ::   kcom 
     884      INTEGER :: ierror, ilocalcomm 
     885      REAL(wp), DIMENSION(kdim) ::   zwork 
     886      !!----------------------------------------------------------------------- 
     887      ilocalcomm = mpi_comm_opa 
     888      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     889      CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_min, ilocalcomm, ierror ) 
     890      ptab(:) = zwork(:) 
     891   END SUBROUTINE mppmin_a_real 
     892   !! 
     893   SUBROUTINE mppmin_real( ptab, kcom ) 
     894      !!----------------------------------------------------------------------- 
     895      REAL(wp), INTENT(inout)           ::   ptab        ! 
     896      INTEGER , INTENT(in   ), OPTIONAL :: kcom 
     897      INTEGER  ::   ierror, ilocalcomm 
     898      REAL(wp) ::   zwork 
     899      !!----------------------------------------------------------------------- 
     900      ilocalcomm = mpi_comm_opa 
     901      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     902      CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_min, ilocalcomm, ierror ) 
     903      ptab = zwork 
     904   END SUBROUTINE mppmin_real 
     905 
     906 
     907   !!---------------------------------------------------------------------- 
     908   !!    ***  mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real  *** 
     909   !!    
     910   !!   Global sum of 1D array or a variable (integer, real or complex) 
     911   !!---------------------------------------------------------------------- 
     912   !! 
    1944913   SUBROUTINE mppsum_a_int( ktab, kdim ) 
    1945       !!---------------------------------------------------------------------- 
    1946       !!                  ***  routine mppsum_a_int  *** 
    1947       !! 
    1948       !! ** Purpose :   Global integer sum, 1D array case 
    1949       !! 
    1950914      !!---------------------------------------------------------------------- 
    1951915      INTEGER, INTENT(in   )                   ::   kdim   ! ??? 
    1952916      INTEGER, INTENT(inout), DIMENSION (kdim) ::   ktab   ! ??? 
    1953       ! 
    1954917      INTEGER :: ierror 
    1955918      INTEGER, DIMENSION (kdim) ::  iwork 
    1956919      !!---------------------------------------------------------------------- 
    1957       ! 
    1958920      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_sum, mpi_comm_opa, ierror ) 
    1959       ! 
    1960921      ktab(:) = iwork(:) 
    1961       ! 
    1962922   END SUBROUTINE mppsum_a_int 
    1963  
    1964  
     923   !! 
    1965924   SUBROUTINE mppsum_int( ktab ) 
    1966925      !!---------------------------------------------------------------------- 
    1967       !!                 ***  routine mppsum_int  *** 
    1968       !! 
    1969       !! ** Purpose :   Global integer sum 
    1970       !! 
    1971       !!---------------------------------------------------------------------- 
    1972926      INTEGER, INTENT(inout) ::   ktab 
    1973       !! 
    1974927      INTEGER :: ierror, iwork 
    1975928      !!---------------------------------------------------------------------- 
    1976       ! 
    1977929      CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_sum, mpi_comm_opa, ierror ) 
    1978       ! 
    1979930      ktab = iwork 
    1980       ! 
    1981931   END SUBROUTINE mppsum_int 
    1982  
    1983  
    1984    SUBROUTINE mppmax_a_real( ptab, kdim, kcom ) 
    1985       !!---------------------------------------------------------------------- 
    1986       !!                 ***  routine mppmax_a_real  *** 
    1987       !! 
    1988       !! ** Purpose :   Maximum of a 1D array 
    1989       !! 
    1990       !!---------------------------------------------------------------------- 
    1991       REAL(wp), DIMENSION(kdim), INTENT(inout) ::   ptab 
    1992       INTEGER                  , INTENT(in   ) ::   kdim 
    1993       INTEGER , OPTIONAL       , INTENT(in   ) ::   kcom 
    1994       ! 
    1995       INTEGER :: ierror, localcomm 
    1996       REAL(wp), DIMENSION(kdim) ::  zwork 
    1997       !!---------------------------------------------------------------------- 
    1998       ! 
    1999       localcomm = mpi_comm_opa 
    2000       IF( PRESENT(kcom) ) localcomm = kcom 
    2001       ! 
    2002       CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_max, localcomm, ierror ) 
     932   !! 
     933   SUBROUTINE mppsum_a_real( ptab, kdim, kcom ) 
     934      !!----------------------------------------------------------------------- 
     935      INTEGER                  , INTENT(in   ) ::   kdim   ! size of ptab 
     936      REAL(wp), DIMENSION(kdim), INTENT(inout) ::   ptab   ! input array 
     937      INTEGER , OPTIONAL       , INTENT(in   ) ::   kcom   ! specific communicator 
     938      INTEGER  ::   ierror, ilocalcomm    ! local integer 
     939      REAL(wp) ::   zwork(kdim)           ! local workspace 
     940      !!----------------------------------------------------------------------- 
     941      ilocalcomm = mpi_comm_opa 
     942      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     943      CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_sum, ilocalcomm, ierror ) 
    2003944      ptab(:) = zwork(:) 
    2004       ! 
    2005    END SUBROUTINE mppmax_a_real 
    2006  
    2007  
    2008    SUBROUTINE mppmax_real( ptab, kcom ) 
     945   END SUBROUTINE mppsum_a_real 
     946   !! 
     947   SUBROUTINE mppsum_real( ptab, kcom ) 
     948      !!----------------------------------------------------------------------- 
     949      REAL(wp)          , INTENT(inout)           ::   ptab   ! input scalar 
     950      INTEGER , OPTIONAL, INTENT(in   ) ::   kcom 
     951      INTEGER  ::   ierror, ilocalcomm 
     952      REAL(wp) ::   zwork 
     953      !!----------------------------------------------------------------------- 
     954      ilocalcomm = mpi_comm_opa 
     955      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     956      CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_sum, ilocalcomm, ierror ) 
     957      ptab = zwork 
     958   END SUBROUTINE mppsum_real 
     959   !! 
     960   SUBROUTINE mppsum_realdd( ytab, kcom ) 
     961      !!----------------------------------------------------------------------- 
     962      COMPLEX(wp)          , INTENT(inout) ::   ytab    ! input scalar 
     963      INTEGER    , OPTIONAL, INTENT(in   ) ::   kcom 
     964      INTEGER     ::   ierror, ilocalcomm 
     965      COMPLEX(wp) ::   zwork 
     966      !!----------------------------------------------------------------------- 
     967      ilocalcomm = mpi_comm_opa 
     968      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     969      CALL MPI_ALLREDUCE( ytab, zwork, 1, MPI_DOUBLE_COMPLEX, MPI_SUMDD, ilocalcomm, ierror ) 
     970      ytab = zwork 
     971   END SUBROUTINE mppsum_realdd 
     972   !! 
     973   SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom ) 
     974      !!---------------------------------------------------------------------- 
     975      INTEGER                     , INTENT(in   ) ::   kdim   ! size of ytab 
     976      COMPLEX(wp), DIMENSION(kdim), INTENT(inout) ::   ytab   ! input array 
     977      INTEGER    , OPTIONAL       , INTENT(in   ) ::   kcom 
     978      INTEGER:: ierror, ilocalcomm    ! local integer 
     979      COMPLEX(wp), DIMENSION(kdim) :: zwork     ! temporary workspace 
     980      !!----------------------------------------------------------------------- 
     981      ilocalcomm = mpi_comm_opa 
     982      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     983      CALL MPI_ALLREDUCE( ytab, zwork, kdim, MPI_DOUBLE_COMPLEX, MPI_SUMDD, ilocalcomm, ierror ) 
     984      ytab(:) = zwork(:) 
     985   END SUBROUTINE mppsum_a_realdd 
     986    
     987 
     988   SUBROUTINE mppmax_real_multiple( pt1d, kdim, kcom  ) 
    2009989      !!---------------------------------------------------------------------- 
    2010990      !!                  ***  routine mppmax_real  *** 
    2011991      !! 
    2012       !! ** Purpose :   Maximum for each element of a 1D array 
    2013       !! 
    2014       !!---------------------------------------------------------------------- 
    2015       REAL(wp), INTENT(inout)           ::   ptab   ! ??? 
    2016       INTEGER , INTENT(in   ), OPTIONAL ::   kcom   ! ??? 
    2017       !! 
    2018       INTEGER  ::   ierror, localcomm 
    2019       REAL(wp) ::   zwork 
    2020       !!---------------------------------------------------------------------- 
    2021       ! 
    2022       localcomm = mpi_comm_opa 
    2023       IF( PRESENT(kcom) )   localcomm = kcom 
    2024       ! 
    2025       CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_max, localcomm, ierror ) 
    2026       ptab = zwork 
    2027       ! 
    2028    END SUBROUTINE mppmax_real 
    2029  
    2030  
    2031    SUBROUTINE mppmax_real_multiple( pt1d, kdim, kcom  ) 
    2032       !!---------------------------------------------------------------------- 
    2033       !!                  ***  routine mppmax_real  *** 
    2034       !! 
    2035       !! ** Purpose :   Maximum 
     992      !! ** Purpose :   Maximum across processor of each element of a 1D arrays 
    2036993      !! 
    2037994      !!---------------------------------------------------------------------- 
     
    2040997      INTEGER , OPTIONAL       , INTENT(in   ) ::   kcom   ! local communicator 
    2041998      !! 
    2042       INTEGER  ::   ierror, localcomm 
     999      INTEGER  ::   ierror, ilocalcomm 
    20431000      REAL(wp), DIMENSION(kdim) ::  zwork 
    20441001      !!---------------------------------------------------------------------- 
    2045       ! 
    2046       localcomm = mpi_comm_opa 
    2047       IF( PRESENT(kcom) )   localcomm = kcom 
    2048       ! 
    2049       CALL mpi_allreduce( pt1d, zwork, kdim, mpi_double_precision, mpi_max, localcomm, ierror ) 
     1002      ilocalcomm = mpi_comm_opa 
     1003      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     1004      ! 
     1005      CALL mpi_allreduce( pt1d, zwork, kdim, mpi_double_precision, mpi_max, ilocalcomm, ierror ) 
    20501006      pt1d(:) = zwork(:) 
    20511007      ! 
    20521008   END SUBROUTINE mppmax_real_multiple 
    2053  
    2054  
    2055    SUBROUTINE mppmin_a_real( ptab, kdim, kcom ) 
    2056       !!---------------------------------------------------------------------- 
    2057       !!                 ***  routine mppmin_a_real  *** 
    2058       !! 
    2059       !! ** Purpose :   Minimum of REAL, array case 
    2060       !! 
    2061       !!----------------------------------------------------------------------- 
    2062       INTEGER , INTENT(in   )                  ::   kdim 
    2063       REAL(wp), INTENT(inout), DIMENSION(kdim) ::   ptab 
    2064       INTEGER , INTENT(in   ), OPTIONAL        ::   kcom 
    2065       !! 
    2066       INTEGER :: ierror, localcomm 
    2067       REAL(wp), DIMENSION(kdim) ::   zwork 
    2068       !!----------------------------------------------------------------------- 
    2069       ! 
    2070       localcomm = mpi_comm_opa 
    2071       IF( PRESENT(kcom) ) localcomm = kcom 
    2072       ! 
    2073       CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_min, localcomm, ierror ) 
    2074       ptab(:) = zwork(:) 
    2075       ! 
    2076    END SUBROUTINE mppmin_a_real 
    2077  
    2078  
    2079    SUBROUTINE mppmin_real( ptab, kcom ) 
    2080       !!---------------------------------------------------------------------- 
    2081       !!                  ***  routine mppmin_real  *** 
    2082       !! 
    2083       !! ** Purpose :   minimum of REAL, scalar case 
    2084       !! 
    2085       !!----------------------------------------------------------------------- 
    2086       REAL(wp), INTENT(inout)           ::   ptab        ! 
    2087       INTEGER , INTENT(in   ), OPTIONAL :: kcom 
    2088       !! 
    2089       INTEGER  ::   ierror 
    2090       REAL(wp) ::   zwork 
    2091       INTEGER :: localcomm 
    2092       !!----------------------------------------------------------------------- 
    2093       ! 
    2094       localcomm = mpi_comm_opa 
    2095       IF( PRESENT(kcom) )   localcomm = kcom 
    2096       ! 
    2097       CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_min, localcomm, ierror ) 
    2098       ptab = zwork 
    2099       ! 
    2100    END SUBROUTINE mppmin_real 
    2101  
    2102  
    2103    SUBROUTINE mppsum_a_real( ptab, kdim, kcom ) 
    2104       !!---------------------------------------------------------------------- 
    2105       !!                  ***  routine mppsum_a_real  *** 
    2106       !! 
    2107       !! ** Purpose :   global sum, REAL ARRAY argument case 
    2108       !! 
    2109       !!----------------------------------------------------------------------- 
    2110       INTEGER , INTENT( in )                     ::   kdim      ! size of ptab 
    2111       REAL(wp), DIMENSION(kdim), INTENT( inout ) ::   ptab      ! input array 
    2112       INTEGER , INTENT( in ), OPTIONAL           :: kcom 
    2113       !! 
    2114       INTEGER                   ::   ierror    ! temporary integer 
    2115       INTEGER                   ::   localcomm 
    2116       REAL(wp), DIMENSION(kdim) ::   zwork     ! temporary workspace 
    2117       !!----------------------------------------------------------------------- 
    2118       ! 
    2119       localcomm = mpi_comm_opa 
    2120       IF( PRESENT(kcom) )   localcomm = kcom 
    2121       ! 
    2122       CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_sum, localcomm, ierror ) 
    2123       ptab(:) = zwork(:) 
    2124       ! 
    2125    END SUBROUTINE mppsum_a_real 
    2126  
    2127  
    2128    SUBROUTINE mppsum_real( ptab, kcom ) 
    2129       !!---------------------------------------------------------------------- 
    2130       !!                  ***  routine mppsum_real  *** 
    2131       !! 
    2132       !! ** Purpose :   global sum, SCALAR argument case 
    2133       !! 
    2134       !!----------------------------------------------------------------------- 
    2135       REAL(wp), INTENT(inout)           ::   ptab   ! input scalar 
    2136       INTEGER , INTENT(in   ), OPTIONAL ::   kcom 
    2137       !! 
    2138       INTEGER  ::   ierror, localcomm 
    2139       REAL(wp) ::   zwork 
    2140       !!----------------------------------------------------------------------- 
    2141       ! 
    2142       localcomm = mpi_comm_opa 
    2143       IF( PRESENT(kcom) ) localcomm = kcom 
    2144       ! 
    2145       CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_sum, localcomm, ierror ) 
    2146       ptab = zwork 
    2147       ! 
    2148    END SUBROUTINE mppsum_real 
    2149  
    2150  
    2151    SUBROUTINE mppsum_realdd( ytab, kcom ) 
    2152       !!---------------------------------------------------------------------- 
    2153       !!                  ***  routine mppsum_realdd *** 
    2154       !! 
    2155       !! ** Purpose :   global sum in Massively Parallel Processing 
    2156       !!                SCALAR argument case for double-double precision 
    2157       !! 
    2158       !!----------------------------------------------------------------------- 
    2159       COMPLEX(wp), INTENT(inout)           ::   ytab    ! input scalar 
    2160       INTEGER    , INTENT(in   ), OPTIONAL ::   kcom 
    2161       ! 
    2162       INTEGER     ::   ierror 
    2163       INTEGER     ::   localcomm 
    2164       COMPLEX(wp) ::   zwork 
    2165       !!----------------------------------------------------------------------- 
    2166       ! 
    2167       localcomm = mpi_comm_opa 
    2168       IF( PRESENT(kcom) )   localcomm = kcom 
    2169       ! 
    2170       ! reduce local sums into global sum 
    2171       CALL MPI_ALLREDUCE (ytab, zwork, 1, MPI_DOUBLE_COMPLEX, MPI_SUMDD, localcomm, ierror ) 
    2172       ytab = zwork 
    2173       ! 
    2174    END SUBROUTINE mppsum_realdd 
    2175  
    2176  
    2177    SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom ) 
    2178       !!---------------------------------------------------------------------- 
    2179       !!                  ***  routine mppsum_a_realdd  *** 
    2180       !! 
    2181       !! ** Purpose :   global sum in Massively Parallel Processing 
    2182       !!                COMPLEX ARRAY case for double-double precision 
    2183       !! 
    2184       !!----------------------------------------------------------------------- 
    2185       INTEGER                     , INTENT(in   ) ::   kdim   ! size of ytab 
    2186       COMPLEX(wp), DIMENSION(kdim), INTENT(inout) ::   ytab   ! input array 
    2187       INTEGER    , OPTIONAL       , INTENT(in   ) ::   kcom 
    2188       ! 
    2189       INTEGER:: ierror, localcomm    ! local integer 
    2190       COMPLEX(wp), DIMENSION(kdim) :: zwork     ! temporary workspace 
    2191       !!----------------------------------------------------------------------- 
    2192       ! 
    2193       localcomm = mpi_comm_opa 
    2194       IF( PRESENT(kcom) )   localcomm = kcom 
    2195       ! 
    2196       CALL MPI_ALLREDUCE( ytab, zwork, kdim, MPI_DOUBLE_COMPLEX, MPI_SUMDD, localcomm, ierror ) 
    2197       ytab(:) = zwork(:) 
    2198       ! 
    2199    END SUBROUTINE mppsum_a_realdd 
    22001009 
    22011010 
     
    26491458 
    26501459 
    2651    SUBROUTINE mpp_lbc_north_3d( pt3d, cd_type, psgn ) 
    2652       !!--------------------------------------------------------------------- 
    2653       !!                   ***  routine mpp_lbc_north_3d  *** 
    2654       !! 
    2655       !! ** Purpose :   Ensure proper north fold horizontal bondary condition 
    2656       !!              in mpp configuration in case of jpn1 > 1 
    2657       !! 
    2658       !! ** Method  :   North fold condition and mpp with more than one proc 
    2659       !!              in i-direction require a specific treatment. We gather 
    2660       !!              the 4 northern lines of the global domain on 1 processor 
    2661       !!              and apply lbc north-fold on this sub array. Then we 
    2662       !!              scatter the north fold array back to the processors. 
    2663       !!---------------------------------------------------------------------- 
    2664       REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pt3d      ! 3D array on which the b.c. is applied 
    2665       CHARACTER(len=1)          , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points 
    2666       REAL(wp)                  , INTENT(in   ) ::   psgn      ! sign used across the north fold 
    2667       ! 
    2668       INTEGER ::   ji, jj, jr, jk 
    2669       INTEGER ::   ipk                  ! 3rd dimension of the input array 
    2670       INTEGER ::   ierr, itaille, ildi, ilei, iilb 
    2671       INTEGER ::   ijpj, ijpjm1, ij, iproc 
    2672       INTEGER, DIMENSION (jpmaxngh)          ::   ml_req_nf          !for mpi_isend when avoiding mpi_allgather 
    2673       INTEGER                                ::   ml_err             ! for mpi_isend when avoiding mpi_allgather 
    2674       INTEGER, DIMENSION(MPI_STATUS_SIZE)    ::   ml_stat            ! for mpi_isend when avoiding mpi_allgather 
    2675       !                                                              ! Workspace for message transfers avoiding mpi_allgather 
    2676       REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztab 
    2677       REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: znorthloc, zfoldwk       
    2678       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE   :: znorthgloio 
    2679       REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztabl, ztabr 
    2680  
    2681       INTEGER :: istatus(mpi_status_size) 
    2682       INTEGER :: iflag 
    2683       !!---------------------------------------------------------------------- 
    2684       ! 
    2685       ipk = SIZE( pt3d, 3 ) 
    2686       ! 
    2687       ALLOCATE( ztab (jpiglo,4,ipk), znorthloc(jpi,4,ipk), zfoldwk(jpi,4,ipk), znorthgloio(jpi,4,ipk,jpni) ) 
    2688       ALLOCATE( ztabl(jpi   ,4,ipk), ztabr(jpi*jpmaxngh,4,ipk)   )  
    2689  
    2690       ijpj   = 4 
    2691       ijpjm1 = 3 
    2692       ! 
    2693       znorthloc(:,:,:) = 0._wp 
    2694       DO jk = 1, ipk 
    2695          DO jj = nlcj - ijpj +1, nlcj          ! put in xnorthloc the last 4 jlines of pt3d 
    2696             ij = jj - nlcj + ijpj 
    2697             znorthloc(:,ij,jk) = pt3d(:,jj,jk) 
    2698          END DO 
    2699       END DO 
    2700       ! 
    2701       !                                     ! Build in procs of ncomm_north the znorthgloio 
    2702       itaille = jpi * ipk * ijpj 
    2703  
    2704       IF ( l_north_nogather ) THEN 
    2705          ! 
    2706         ztabr(:,:,:) = 0._wp 
    2707         ztabl(:,:,:) = 0._wp 
    2708  
    2709         DO jk = 1, ipk 
    2710            DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array 
    2711               ij = jj - nlcj + ijpj 
    2712               DO ji = nfsloop, nfeloop 
    2713                  ztabl(ji,ij,jk) = pt3d(ji,jj,jk) 
    2714               END DO 
    2715            END DO 
    2716         END DO 
    2717  
    2718          DO jr = 1,nsndto 
    2719             IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 
    2720               CALL mppsend( 5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) ) 
    2721             ENDIF 
    2722          END DO 
    2723          DO jr = 1,nsndto 
    2724             iproc = nfipproc(isendto(jr),jpnj) 
    2725             IF(iproc /= -1) THEN 
    2726                ilei = nleit (iproc+1) 
    2727                ildi = nldit (iproc+1) 
    2728                iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 
    2729             ENDIF 
    2730             IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 
    2731               CALL mpprecv(5, zfoldwk, itaille, iproc) 
    2732               DO jk = 1, ipk 
    2733                  DO jj = 1, ijpj 
    2734                     DO ji = ildi, ilei 
    2735                        ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk) 
    2736                     END DO 
    2737                  END DO 
    2738               END DO 
    2739            ELSE IF( iproc == narea-1 ) THEN 
    2740               DO jk = 1, ipk 
    2741                  DO jj = 1, ijpj 
    2742                     DO ji = ildi, ilei 
    2743                        ztabr(iilb+ji,jj,jk) = pt3d(ji,nlcj-ijpj+jj,jk) 
    2744                     END DO 
    2745                  END DO 
    2746               END DO 
    2747            ENDIF 
    2748          END DO 
    2749          IF (l_isend) THEN 
    2750             DO jr = 1,nsndto 
    2751                IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 
    2752                   CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err ) 
    2753                ENDIF     
    2754             END DO 
    2755          ENDIF 
    2756          CALL mpp_lbc_nfd( ztabl, ztabr, cd_type, psgn )   ! North fold boundary condition 
    2757          DO jk = 1, ipk 
    2758             DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt3d 
    2759                ij = jj - nlcj + ijpj 
    2760                DO ji= 1, nlci 
    2761                   pt3d(ji,jj,jk) = ztabl(ji,ij,jk) 
    2762                END DO 
    2763             END DO 
    2764          END DO 
    2765          ! 
    2766       ELSE 
    2767          CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,                & 
    2768             &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
    2769          ! 
    2770          ztab(:,:,:) = 0._wp 
    2771          DO jr = 1, ndim_rank_north         ! recover the global north array 
    2772             iproc = nrank_north(jr) + 1 
    2773             ildi  = nldit (iproc) 
    2774             ilei  = nleit (iproc) 
    2775             iilb  = nimppt(iproc) 
    2776             DO jk = 1, ipk 
    2777                DO jj = 1, ijpj 
    2778                   DO ji = ildi, ilei 
    2779                     ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr) 
    2780                   END DO 
    2781                END DO 
    2782             END DO 
    2783          END DO 
    2784          CALL lbc_nfd( ztab, cd_type, psgn )   ! North fold boundary condition 
    2785          ! 
    2786          DO jk = 1, ipk 
    2787             DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt3d 
    2788                ij = jj - nlcj + ijpj 
    2789                DO ji= 1, nlci 
    2790                   pt3d(ji,jj,jk) = ztab(ji+nimpp-1,ij,jk) 
    2791                END DO 
    2792             END DO 
    2793          END DO 
    2794          ! 
    2795       ENDIF 
    2796       ! 
    2797       ! The ztab array has been either: 
    2798       !  a. Fully populated by the mpi_allgather operation or 
    2799       !  b. Had the active points for this domain and northern neighbours populated 
    2800       !     by peer to peer exchanges 
    2801       ! Either way the array may be folded by lbc_nfd and the result for the span of 
    2802       ! this domain will be identical. 
    2803       ! 
    2804       DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio ) 
    2805       DEALLOCATE( ztabl, ztabr )  
    2806       ! 
    2807    END SUBROUTINE mpp_lbc_north_3d 
    2808  
    2809  
    2810    SUBROUTINE mpp_lbc_north_2d( pt2d, cd_type, psgn) 
    2811       !!--------------------------------------------------------------------- 
    2812       !!                   ***  routine mpp_lbc_north_2d  *** 
    2813       !! 
    2814       !! ** Purpose :   Ensure proper north fold horizontal bondary condition 
    2815       !!              in mpp configuration in case of jpn1 > 1 (for 2d array ) 
    2816       !! 
    2817       !! ** Method  :   North fold condition and mpp with more than one proc 
    2818       !!              in i-direction require a specific treatment. We gather 
    2819       !!              the 4 northern lines of the global domain on 1 processor 
    2820       !!              and apply lbc north-fold on this sub array. Then we 
    2821       !!              scatter the north fold array back to the processors. 
    2822       !! 
    2823       !!---------------------------------------------------------------------- 
    2824       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d      ! 2D array on which the b.c. is applied 
    2825       CHARACTER(len=1)            , INTENT(in   ) ::   cd_type   ! nature of pt2d grid-points 
    2826       !                                                          !   = T ,  U , V , F or W  gridpoints 
    2827       REAL(wp)                    , INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold  
    2828       !!                                                             ! =  1. , the sign is kept 
    2829       INTEGER ::   ji, jj, jr 
    2830       INTEGER ::   ierr, itaille, ildi, ilei, iilb 
    2831       INTEGER ::   ijpj, ijpjm1, ij, iproc 
    2832       INTEGER, DIMENSION (jpmaxngh)      ::   ml_req_nf          !for mpi_isend when avoiding mpi_allgather 
    2833       INTEGER                            ::   ml_err             ! for mpi_isend when avoiding mpi_allgather 
    2834       INTEGER, DIMENSION(MPI_STATUS_SIZE)::   ml_stat            ! for mpi_isend when avoiding mpi_allgather 
    2835       !                                                              ! Workspace for message transfers avoiding mpi_allgather 
    2836       REAL(wp), DIMENSION(:,:)  , ALLOCATABLE   :: ztab 
    2837       REAL(wp), DIMENSION(:,:)  , ALLOCATABLE   :: znorthloc, zfoldwk       
    2838       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE   :: znorthgloio 
    2839       REAL(wp), DIMENSION(:,:)  , ALLOCATABLE   :: ztabl, ztabr 
    2840       INTEGER :: istatus(mpi_status_size) 
    2841       INTEGER :: iflag 
    2842       !!---------------------------------------------------------------------- 
    2843       ! 
    2844       ALLOCATE( ztab(jpiglo,4), znorthloc(jpi,4), zfoldwk(jpi,4), znorthgloio(jpi,4,jpni) ) 
    2845       ALLOCATE( ztabl(jpi,4), ztabr(jpi*jpmaxngh, 4) )  
    2846       ! 
    2847       ijpj   = 4 
    2848       ijpjm1 = 3 
    2849       ! 
    2850       DO jj = nlcj-ijpj+1, nlcj             ! put in znorthloc the last 4 jlines of pt2d 
    2851          ij = jj - nlcj + ijpj 
    2852          znorthloc(:,ij) = pt2d(:,jj) 
    2853       END DO 
    2854  
    2855       !                                     ! Build in procs of ncomm_north the znorthgloio 
    2856       itaille = jpi * ijpj 
    2857       IF ( l_north_nogather ) THEN 
    2858          ! 
    2859          ! Avoid the use of mpi_allgather by exchanging only with the processes already identified  
    2860          ! (in nemo_northcomms) as being  involved in this process' northern boundary exchange 
    2861          ! 
    2862          ztabr(:,:) = 0 
    2863          ztabl(:,:) = 0 
    2864  
    2865          DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array 
    2866             ij = jj - nlcj + ijpj 
    2867               DO ji = nfsloop, nfeloop 
    2868                ztabl(ji,ij) = pt2d(ji,jj) 
    2869             END DO 
    2870          END DO 
    2871  
    2872          DO jr = 1,nsndto 
    2873             IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 
    2874                CALL mppsend( 5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) ) 
    2875             ENDIF 
    2876          END DO 
    2877          DO jr = 1,nsndto 
    2878             iproc = nfipproc(isendto(jr),jpnj) 
    2879             IF( iproc /= -1 ) THEN 
    2880                ilei = nleit (iproc+1) 
    2881                ildi = nldit (iproc+1) 
    2882                iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 
    2883             ENDIF 
    2884             IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 
    2885               CALL mpprecv(5, zfoldwk, itaille, iproc) 
    2886               DO jj = 1, ijpj 
    2887                  DO ji = ildi, ilei 
    2888                     ztabr(iilb+ji,jj) = zfoldwk(ji,jj) 
    2889                  END DO 
    2890               END DO 
    2891             ELSEIF( iproc == narea-1 ) THEN 
    2892               DO jj = 1, ijpj 
    2893                  DO ji = ildi, ilei 
    2894                     ztabr(iilb+ji,jj) = pt2d(ji,nlcj-ijpj+jj) 
    2895                  END DO 
    2896               END DO 
    2897             ENDIF 
    2898          END DO 
    2899          IF(l_isend) THEN 
    2900             DO jr = 1,nsndto 
    2901                IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 
    2902                   CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 
    2903                ENDIF 
    2904             END DO 
    2905          ENDIF 
    2906          CALL mpp_lbc_nfd( ztabl, ztabr, cd_type, psgn )   ! North fold boundary condition 
    2907          ! 
    2908          DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
    2909             ij = jj - nlcj + ijpj 
    2910             DO ji = 1, nlci 
    2911                pt2d(ji,jj) = ztabl(ji,ij) 
    2912             END DO 
    2913          END DO 
    2914          ! 
    2915       ELSE 
    2916          CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,        & 
    2917             &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
    2918          ! 
    2919          ztab(:,:) = 0._wp 
    2920          DO jr = 1, ndim_rank_north            ! recover the global north array 
    2921             iproc = nrank_north(jr) + 1 
    2922             ildi = nldit (iproc) 
    2923             ilei = nleit (iproc) 
    2924             iilb = nimppt(iproc) 
    2925             DO jj = 1, ijpj 
    2926                DO ji = ildi, ilei 
    2927                   ztab(ji+iilb-1,jj) = znorthgloio(ji,jj,jr) 
    2928                END DO 
    2929             END DO 
    2930          END DO 
    2931          CALL lbc_nfd( ztab, cd_type, psgn )   ! North fold boundary condition 
    2932          ! 
    2933          DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
    2934             ij = jj - nlcj + ijpj 
    2935             DO ji = 1, nlci 
    2936                pt2d(ji,jj) = ztab(ji+nimpp-1,ij) 
    2937             END DO 
    2938          END DO 
    2939          ! 
    2940       ENDIF 
    2941       DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio ) 
    2942       DEALLOCATE( ztabl, ztabr )  
    2943       ! 
    2944    END SUBROUTINE mpp_lbc_north_2d 
    2945  
    2946  
    2947    SUBROUTINE mpp_lbc_north_2d_multiple( pt2d_array, cd_type, psgn, kfld ) 
    2948       !!--------------------------------------------------------------------- 
    2949       !!                   ***  routine mpp_lbc_north_2d  *** 
    2950       !! 
    2951       !! ** Purpose :   Ensure proper north fold horizontal bondary condition 
    2952       !!              in mpp configuration in case of jpn1 > 1 
    2953       !!              (for multiple 2d arrays ) 
    2954       !! 
    2955       !! ** Method  :   North fold condition and mpp with more than one proc 
    2956       !!              in i-direction require a specific treatment. We gather 
    2957       !!              the 4 northern lines of the global domain on 1 processor 
    2958       !!              and apply lbc north-fold on this sub array. Then we 
    2959       !!              scatter the north fold array back to the processors. 
    2960       !! 
    2961       !!---------------------------------------------------------------------- 
    2962       TYPE( arrayptr ), DIMENSION(:), INTENT(inout) ::   pt2d_array   ! pointer array of 2D fields 
    2963       CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   cd_type      ! nature of pt2d grid-points 
    2964       REAL(wp)        , DIMENSION(:), INTENT(in   ) ::   psgn         ! sign used across the north fold  
    2965       INTEGER                       , INTENT(in   ) ::   kfld         ! number of variables contained in pt2d 
    2966       ! 
    2967       INTEGER ::   ji, jj, jr, jk 
    2968       INTEGER ::   ierr, itaille, ildi, ilei, iilb 
    2969       INTEGER ::   ijpj, ijpjm1, ij, iproc, iflag 
    2970       INTEGER, DIMENSION (jpmaxngh)      ::   ml_req_nf   ! for mpi_isend when avoiding mpi_allgather 
    2971       INTEGER                            ::   ml_err      ! for mpi_isend when avoiding mpi_allgather 
    2972       INTEGER, DIMENSION(MPI_STATUS_SIZE)::   ml_stat     ! for mpi_isend when avoiding mpi_allgather 
    2973       !                                                   ! Workspace for message transfers avoiding mpi_allgather 
    2974       INTEGER :: istatus(mpi_status_size) 
    2975       REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztab 
    2976       REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: znorthloc, zfoldwk 
    2977       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE   :: znorthgloio 
    2978       REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztabl, ztabr 
    2979       !!---------------------------------------------------------------------- 
    2980       ! 
    2981       ALLOCATE( ztab(jpiglo,4,kfld), znorthloc  (jpi,4,kfld),        & 
    2982          &      zfoldwk(jpi,4,kfld), znorthgloio(jpi,4,kfld,jpni),   & 
    2983          &      ztabl  (jpi,4,kfld), ztabr(jpi*jpmaxngh, 4,kfld)   ) 
    2984       ! 
    2985       ijpj   = 4 
    2986       ijpjm1 = 3 
    2987       ! 
    2988        
    2989       DO jk = 1, kfld 
    2990          DO jj = nlcj-ijpj+1, nlcj             ! put in znorthloc the last 4 jlines of pt2d (for every variable) 
    2991             ij = jj - nlcj + ijpj 
    2992             znorthloc(:,ij,jk) = pt2d_array(jk)%pt2d(:,jj) 
    2993          END DO 
    2994       END DO 
    2995       !                                     ! Build in procs of ncomm_north the znorthgloio 
    2996       itaille = jpi * ijpj 
    2997                                                                    
    2998       IF ( l_north_nogather ) THEN 
    2999          ! 
    3000          ! Avoid the use of mpi_allgather by exchanging only with the processes already identified  
    3001          ! (in nemo_northcomms) as being  involved in this process' northern boundary exchange 
    3002          ! 
    3003          ztabr(:,:,:) = 0._wp 
    3004          ztabl(:,:,:) = 0._wp 
    3005  
    3006          DO jk = 1, kfld 
    3007             DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array 
    3008                ij = jj - nlcj + ijpj 
    3009                DO ji = nfsloop, nfeloop 
    3010                   ztabl(ji,ij,jk) = pt2d_array(jk)%pt2d(ji,jj) 
    3011                END DO 
    3012             END DO 
    3013          END DO 
    3014  
    3015          DO jr = 1, nsndto 
    3016             IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 
    3017                CALL mppsend(5, znorthloc, itaille*kfld, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) ! Buffer expanded "kfld" times 
    3018             ENDIF 
    3019          END DO 
    3020          DO jr = 1, nsndto 
    3021             iproc = nfipproc(isendto(jr),jpnj) 
    3022             IF( iproc /= -1 ) THEN 
    3023                ilei = nleit (iproc+1) 
    3024                ildi = nldit (iproc+1) 
    3025                iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 
    3026             ENDIF 
    3027             IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 
    3028               CALL mpprecv(5, zfoldwk, itaille*kfld, iproc) ! Buffer expanded "kfld" times 
    3029               DO jk = 1 , kfld 
    3030                  DO jj = 1, ijpj 
    3031                     DO ji = ildi, ilei 
    3032                        ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk)       ! Modified to 3D 
    3033                     END DO 
    3034                  END DO 
    3035               END DO 
    3036             ELSEIF ( iproc == narea-1 ) THEN 
    3037               DO jk = 1, kfld 
    3038                  DO jj = 1, ijpj 
    3039                     DO ji = ildi, ilei 
    3040                           ztabr(iilb+ji,jj,jk) = pt2d_array(jk)%pt2d(ji,nlcj-ijpj+jj)       ! Modified to 3D 
    3041                     END DO 
    3042                  END DO 
    3043               END DO 
    3044             ENDIF 
    3045          END DO 
    3046          IF( l_isend ) THEN 
    3047             DO jr = 1, nsndto 
    3048                IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 
    3049                   CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 
    3050                ENDIF 
    3051             END DO 
    3052          ENDIF 
    3053          ! 
    3054          DO ji = 1, kfld     ! Loop to manage 3D variables 
    3055             CALL mpp_lbc_nfd( ztabl(:,:,ji), ztabr(:,:,ji), cd_type(ji), psgn(ji) )  ! North fold boundary condition 
    3056          END DO 
    3057          ! 
    3058          DO jk = 1, kfld 
    3059             DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
    3060                ij = jj - nlcj + ijpj 
    3061                DO ji = 1, nlci 
    3062                   pt2d_array(jk)%pt2d(ji,jj) = ztabl(ji,ij,jk)       ! Modified to 3D 
    3063                END DO 
    3064             END DO 
    3065          END DO 
    3066           
    3067          ! 
    3068       ELSE 
    3069          ! 
    3070          CALL MPI_ALLGATHER( znorthloc  , itaille*kfld, MPI_DOUBLE_PRECISION,        & 
    3071             &                znorthgloio, itaille*kfld, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
    3072          ! 
    3073          ztab(:,:,:) = 0._wp 
    3074          DO jk = 1, kfld 
    3075             DO jr = 1, ndim_rank_north            ! recover the global north array 
    3076                iproc = nrank_north(jr) + 1 
    3077                ildi = nldit (iproc) 
    3078                ilei = nleit (iproc) 
    3079                iilb = nimppt(iproc) 
    3080                DO jj = 1, ijpj 
    3081                   DO ji = ildi, ilei 
    3082                      ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr) 
    3083                   END DO 
    3084                END DO 
    3085             END DO 
    3086          END DO 
    3087           
    3088          DO ji = 1, kfld 
    3089             CALL lbc_nfd( ztab(:,:,ji), cd_type(ji), psgn(ji) )   ! North fold boundary condition 
    3090          END DO 
    3091          ! 
    3092          DO jk = 1, kfld 
    3093             DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
    3094                ij = jj - nlcj + ijpj 
    3095                DO ji = 1, nlci 
    3096                   pt2d_array(jk)%pt2d(ji,jj) = ztab(ji+nimpp-1,ij,jk) 
    3097                END DO 
    3098             END DO 
    3099          END DO 
    3100          ! 
    3101          ! 
    3102       ENDIF 
    3103       DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio ) 
    3104       DEALLOCATE( ztabl, ztabr ) 
    3105       ! 
    3106    END SUBROUTINE mpp_lbc_north_2d_multiple 
    3107  
    3108  
    31091460   SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn) 
    31101461      !!--------------------------------------------------------------------- 
     
    31651516      ! 2. North-Fold boundary conditions 
    31661517      ! ---------------------------------- 
    3167       CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = jpr2dj ) 
     1518!!gm ERROR      CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = jpr2dj ) 
    31681519 
    31691520      ij = jpr2dj 
     
    31791530      ! 
    31801531   END SUBROUTINE mpp_lbc_north_e 
    3181  
    3182  
    3183    SUBROUTINE mpp_lnk_bdy_3d( ptab, cd_type, psgn, ib_bdy ) 
    3184       !!---------------------------------------------------------------------- 
    3185       !!                  ***  routine mpp_lnk_bdy_3d  *** 
    3186       !! 
    3187       !! ** Purpose :   Message passing management 
    3188       !! 
    3189       !! ** Method  :   Use mppsend and mpprecv function for passing BDY boundaries  
    3190       !!      between processors following neighboring subdomains. 
    3191       !!            domain parameters 
    3192       !!                    nlci   : first dimension of the local subdomain 
    3193       !!                    nlcj   : second dimension of the local subdomain 
    3194       !!                    nbondi_bdy : mark for "east-west local boundary" 
    3195       !!                    nbondj_bdy : mark for "north-south local boundary" 
    3196       !!                    noea   : number for local neighboring processors  
    3197       !!                    nowe   : number for local neighboring processors 
    3198       !!                    noso   : number for local neighboring processors 
    3199       !!                    nono   : number for local neighboring processors 
    3200       !! 
    3201       !! ** Action  :   ptab with update value at its periphery 
    3202       !! 
    3203       !!---------------------------------------------------------------------- 
    3204       REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied 
    3205       CHARACTER(len=1)          , INTENT(in   ) ::   cd_type  ! nature of ptab grid point 
    3206       REAL(wp)                  , INTENT(in   ) ::   psgn     ! sign used across the north fold boundary 
    3207       INTEGER                   , INTENT(in   ) ::   ib_bdy   ! BDY boundary set 
    3208       ! 
    3209       INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices 
    3210       INTEGER  ::   ipk                        ! 3rd dimension of the input array 
    3211       INTEGER  ::   imigr, iihom, ijhom        ! local integers 
    3212       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    3213       REAL(wp) ::   zland                      ! local scalar 
    3214       INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
    3215       ! 
    3216       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ns, zt3sn   ! 3d for north-south & south-north 
    3217       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ew, zt3we   ! 3d for east-west & west-east 
    3218       !!---------------------------------------------------------------------- 
    3219       ! 
    3220       ipk = SIZE( ptab, 3 ) 
    3221       !       
    3222       ALLOCATE( zt3ns(jpi,jprecj,ipk,2), zt3sn(jpi,jprecj,ipk,2),   & 
    3223          &      zt3ew(jpj,jpreci,ipk,2), zt3we(jpj,jpreci,ipk,2)  ) 
    3224  
    3225       zland = 0._wp 
    3226  
    3227       ! 1. standard boundary treatment 
    3228       ! ------------------------------ 
    3229       !                                   ! East-West boundaries 
    3230       !                                        !* Cyclic 
    3231       IF( nbondi == 2) THEN 
    3232          IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN 
    3233             ptab( 1 ,:,:) = ptab(jpim1,:,:) 
    3234             ptab(jpi,:,:) = ptab(  2  ,:,:) 
    3235          ELSE 
    3236             IF( .NOT. cd_type == 'F' )   ptab(1:jpreci,:,:) = zland    ! south except F-point 
    3237             ptab(nlci-jpreci+1:jpi,:,:) = zland    ! north 
    3238          ENDIF 
    3239       ELSEIF(nbondi == -1) THEN 
    3240          IF( .NOT. cd_type == 'F' )   ptab(1:jpreci,:,:) = zland       ! south except F-point 
    3241       ELSEIF(nbondi == 1) THEN 
    3242          ptab(nlci-jpreci+1:jpi,:,:) = zland    ! north 
    3243       ENDIF                                     !* closed 
    3244  
    3245       IF (nbondj == 2 .OR. nbondj == -1) THEN 
    3246         IF( .NOT. cd_type == 'F' )   ptab(:,1:jprecj,:) = zland       ! south except F-point 
    3247       ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN 
    3248         ptab(:,nlcj-jprecj+1:jpj,:) = zland       ! north 
    3249       ENDIF 
    3250       ! 
    3251       ! 2. East and west directions exchange 
    3252       ! ------------------------------------ 
    3253       ! we play with the neigbours AND the row number because of the periodicity  
    3254       ! 
    3255       SELECT CASE ( nbondi_bdy(ib_bdy) )      ! Read Dirichlet lateral conditions 
    3256       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    3257          iihom = nlci-nreci 
    3258          DO jl = 1, jpreci 
    3259             zt3ew(:,jl,:,1) = ptab(jpreci+jl,:,:) 
    3260             zt3we(:,jl,:,1) = ptab(iihom +jl,:,:) 
    3261          END DO 
    3262       END SELECT 
    3263       ! 
    3264       !                           ! Migrations 
    3265       imigr = jpreci * jpj * ipk 
    3266       ! 
    3267       SELECT CASE ( nbondi_bdy(ib_bdy) ) 
    3268       CASE ( -1 ) 
    3269          CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 ) 
    3270       CASE ( 0 ) 
    3271          CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
    3272          CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 ) 
    3273       CASE ( 1 ) 
    3274          CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
    3275       END SELECT 
    3276       ! 
    3277       SELECT CASE ( nbondi_bdy_b(ib_bdy) ) 
    3278       CASE ( -1 ) 
    3279          CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 
    3280       CASE ( 0 ) 
    3281          CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 
    3282          CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 
    3283       CASE ( 1 ) 
    3284          CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 
    3285       END SELECT 
    3286       ! 
    3287       SELECT CASE ( nbondi_bdy(ib_bdy) ) 
    3288       CASE ( -1 ) 
    3289          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    3290       CASE ( 0 ) 
    3291          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    3292          IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    3293       CASE ( 1 ) 
    3294          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    3295       END SELECT 
    3296       ! 
    3297       !                           ! Write Dirichlet lateral conditions 
    3298       iihom = nlci-jpreci 
    3299       ! 
    3300       SELECT CASE ( nbondi_bdy_b(ib_bdy) ) 
    3301       CASE ( -1 ) 
    3302          DO jl = 1, jpreci 
    3303             ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2) 
    3304          END DO 
    3305       CASE ( 0 ) 
    3306          DO jl = 1, jpreci 
    3307             ptab(      jl,:,:) = zt3we(:,jl,:,2) 
    3308             ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2) 
    3309          END DO 
    3310       CASE ( 1 ) 
    3311          DO jl = 1, jpreci 
    3312             ptab(      jl,:,:) = zt3we(:,jl,:,2) 
    3313          END DO 
    3314       END SELECT 
    3315  
    3316       ! 3. North and south directions 
    3317       ! ----------------------------- 
    3318       ! always closed : we play only with the neigbours 
    3319       ! 
    3320       IF( nbondj_bdy(ib_bdy) /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    3321          ijhom = nlcj-nrecj 
    3322          DO jl = 1, jprecj 
    3323             zt3sn(:,jl,:,1) = ptab(:,ijhom +jl,:) 
    3324             zt3ns(:,jl,:,1) = ptab(:,jprecj+jl,:) 
    3325          END DO 
    3326       ENDIF 
    3327       ! 
    3328       !                           ! Migrations 
    3329       imigr = jprecj * jpi * ipk 
    3330       ! 
    3331       SELECT CASE ( nbondj_bdy(ib_bdy) ) 
    3332       CASE ( -1 ) 
    3333          CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 ) 
    3334       CASE ( 0 ) 
    3335          CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 
    3336          CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 ) 
    3337       CASE ( 1 ) 
    3338          CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 
    3339       END SELECT 
    3340       ! 
    3341       SELECT CASE ( nbondj_bdy_b(ib_bdy) ) 
    3342       CASE ( -1 ) 
    3343          CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 
    3344       CASE ( 0 ) 
    3345          CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 
    3346          CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 
    3347       CASE ( 1 ) 
    3348          CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 
    3349       END SELECT 
    3350       ! 
    3351       SELECT CASE ( nbondj_bdy(ib_bdy) ) 
    3352       CASE ( -1 ) 
    3353          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    3354       CASE ( 0 ) 
    3355          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    3356          IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    3357       CASE ( 1 ) 
    3358          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    3359       END SELECT 
    3360       ! 
    3361       !                           ! Write Dirichlet lateral conditions 
    3362       ijhom = nlcj-jprecj 
    3363       ! 
    3364       SELECT CASE ( nbondj_bdy_b(ib_bdy) ) 
    3365       CASE ( -1 ) 
    3366          DO jl = 1, jprecj 
    3367             ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2) 
    3368          END DO 
    3369       CASE ( 0 ) 
    3370          DO jl = 1, jprecj 
    3371             ptab(:,jl      ,:) = zt3sn(:,jl,:,2) 
    3372             ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2) 
    3373          END DO 
    3374       CASE ( 1 ) 
    3375          DO jl = 1, jprecj 
    3376             ptab(:,jl,:) = zt3sn(:,jl,:,2) 
    3377          END DO 
    3378       END SELECT 
    3379  
    3380       ! 4. north fold treatment 
    3381       ! ----------------------- 
    3382       ! 
    3383       IF( npolj /= 0) THEN 
    3384          ! 
    3385          SELECT CASE ( jpni ) 
    3386          CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp 
    3387          CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs. 
    3388          END SELECT 
    3389          ! 
    3390       ENDIF 
    3391       ! 
    3392       DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we  ) 
    3393       ! 
    3394    END SUBROUTINE mpp_lnk_bdy_3d 
    3395  
    3396  
    3397    SUBROUTINE mpp_lnk_bdy_2d( ptab, cd_type, psgn, ib_bdy ) 
    3398       !!---------------------------------------------------------------------- 
    3399       !!                  ***  routine mpp_lnk_bdy_2d  *** 
    3400       !! 
    3401       !! ** Purpose :   Message passing management 
    3402       !! 
    3403       !! ** Method  :   Use mppsend and mpprecv function for passing BDY boundaries  
    3404       !!      between processors following neighboring subdomains. 
    3405       !!            domain parameters 
    3406       !!                    nlci   : first dimension of the local subdomain 
    3407       !!                    nlcj   : second dimension of the local subdomain 
    3408       !!                    nbondi_bdy : mark for "east-west local boundary" 
    3409       !!                    nbondj_bdy : mark for "north-south local boundary" 
    3410       !!                    noea   : number for local neighboring processors  
    3411       !!                    nowe   : number for local neighboring processors 
    3412       !!                    noso   : number for local neighboring processors 
    3413       !!                    nono   : number for local neighboring processors 
    3414       !! 
    3415       !! ** Action  :   ptab with update value at its periphery 
    3416       !! 
    3417       !!---------------------------------------------------------------------- 
    3418       REAL(wp), DIMENSION(jpi,jpj)    , INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied 
    3419       CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points 
    3420       REAL(wp)                        , INTENT(in   ) ::   psgn     ! sign used across the north fold boundary 
    3421       INTEGER                         , INTENT(in   ) ::   ib_bdy   ! BDY boundary set 
    3422       ! 
    3423       INTEGER  ::   ji, jj, jl                 ! dummy loop indices 
    3424       INTEGER  ::   imigr, iihom, ijhom        ! local integers 
    3425       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    3426       REAL(wp) ::   zland 
    3427       INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
    3428       ! 
    3429       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ns, zt2sn   ! 2d for north-south & south-north 
    3430       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ew, zt2we   ! 2d for east-west & west-east 
    3431       !!---------------------------------------------------------------------- 
    3432  
    3433       ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2),  & 
    3434          &      zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2)   ) 
    3435  
    3436       zland = 0._wp 
    3437  
    3438       ! 1. standard boundary treatment 
    3439       ! ------------------------------ 
    3440       !                                   ! East-West boundaries 
    3441       !                                         !* Cyclic 
    3442       IF( nbondi == 2 ) THEN 
    3443          IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN 
    3444             ptab( 1 ,:) = ptab(jpim1,:) 
    3445             ptab(jpi,:) = ptab(  2  ,:) 
    3446          ELSE 
    3447             IF(.NOT.cd_type == 'F' )   ptab(     1       :jpreci,:) = zland    ! south except F-point 
    3448                                        ptab(nlci-jpreci+1:jpi   ,:) = zland    ! north 
    3449          ENDIF 
    3450       ELSEIF(nbondi == -1) THEN 
    3451          IF(.NOT.cd_type == 'F' )      ptab(     1       :jpreci,:) = zland    ! south except F-point 
    3452       ELSEIF(nbondi == 1) THEN 
    3453                                        ptab(nlci-jpreci+1:jpi   ,:) = zland    ! north 
    3454       ENDIF 
    3455       !                                      !* closed 
    3456       IF( nbondj == 2 .OR. nbondj == -1 ) THEN 
    3457          IF( .NOT.cd_type == 'F' )    ptab(:,     1       :jprecj) = zland    ! south except F-point 
    3458       ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN 
    3459                                       ptab(:,nlcj-jprecj+1:jpj   ) = zland    ! north 
    3460       ENDIF 
    3461       ! 
    3462       ! 2. East and west directions exchange 
    3463       ! ------------------------------------ 
    3464       ! we play with the neigbours AND the row number because of the periodicity  
    3465       ! 
    3466       SELECT CASE ( nbondi_bdy(ib_bdy) )      ! Read Dirichlet lateral conditions 
    3467       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    3468          iihom = nlci-nreci 
    3469          DO jl = 1, jpreci 
    3470             zt2ew(:,jl,1) = ptab(jpreci+jl,:) 
    3471             zt2we(:,jl,1) = ptab(iihom +jl,:) 
    3472          END DO 
    3473       END SELECT 
    3474       ! 
    3475       !                           ! Migrations 
    3476       imigr = jpreci * jpj 
    3477       ! 
    3478       SELECT CASE ( nbondi_bdy(ib_bdy) ) 
    3479       CASE ( -1 ) 
    3480          CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 ) 
    3481       CASE ( 0 ) 
    3482          CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 
    3483          CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 ) 
    3484       CASE ( 1 ) 
    3485          CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 
    3486       END SELECT 
    3487       ! 
    3488       SELECT CASE ( nbondi_bdy_b(ib_bdy) ) 
    3489       CASE ( -1 ) 
    3490          CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 
    3491       CASE ( 0 ) 
    3492          CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 
    3493          CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 
    3494       CASE ( 1 ) 
    3495          CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 
    3496       END SELECT 
    3497       ! 
    3498       SELECT CASE ( nbondi_bdy(ib_bdy) ) 
    3499       CASE ( -1 ) 
    3500          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 
    3501       CASE ( 0 ) 
    3502          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 
    3503          IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err ) 
    3504       CASE ( 1 ) 
    3505          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 
    3506       END SELECT 
    3507       ! 
    3508       !                           ! Write Dirichlet lateral conditions 
    3509       iihom = nlci-jpreci 
    3510       ! 
    3511       SELECT CASE ( nbondi_bdy_b(ib_bdy) ) 
    3512       CASE ( -1 ) 
    3513          DO jl = 1, jpreci 
    3514             ptab(iihom+jl,:) = zt2ew(:,jl,2) 
    3515          END DO 
    3516       CASE ( 0 ) 
    3517          DO jl = 1, jpreci 
    3518             ptab(jl      ,:) = zt2we(:,jl,2) 
    3519             ptab(iihom+jl,:) = zt2ew(:,jl,2) 
    3520          END DO 
    3521       CASE ( 1 ) 
    3522          DO jl = 1, jpreci 
    3523             ptab(jl      ,:) = zt2we(:,jl,2) 
    3524          END DO 
    3525       END SELECT 
    3526  
    3527  
    3528       ! 3. North and south directions 
    3529       ! ----------------------------- 
    3530       ! always closed : we play only with the neigbours 
    3531       ! 
    3532       IF( nbondj_bdy(ib_bdy) /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    3533          ijhom = nlcj-nrecj 
    3534          DO jl = 1, jprecj 
    3535             zt2sn(:,jl,1) = ptab(:,ijhom +jl) 
    3536             zt2ns(:,jl,1) = ptab(:,jprecj+jl) 
    3537          END DO 
    3538       ENDIF 
    3539       ! 
    3540       !                           ! Migrations 
    3541       imigr = jprecj * jpi 
    3542       ! 
    3543       SELECT CASE ( nbondj_bdy(ib_bdy) ) 
    3544       CASE ( -1 ) 
    3545          CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 ) 
    3546       CASE ( 0 ) 
    3547          CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 
    3548          CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 ) 
    3549       CASE ( 1 ) 
    3550          CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 
    3551       END SELECT 
    3552       ! 
    3553       SELECT CASE ( nbondj_bdy_b(ib_bdy) ) 
    3554       CASE ( -1 ) 
    3555          CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 
    3556       CASE ( 0 ) 
    3557          CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 
    3558          CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 
    3559       CASE ( 1 ) 
    3560          CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 
    3561       END SELECT 
    3562       ! 
    3563       SELECT CASE ( nbondj_bdy(ib_bdy) ) 
    3564       CASE ( -1 ) 
    3565          IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err ) 
    3566       CASE ( 0 ) 
    3567          IF(l_isend) CALL mpi_wait (ml_req1, ml_stat, ml_err ) 
    3568          IF(l_isend) CALL mpi_wait( ml_req2, ml_stat, ml_err ) 
    3569       CASE ( 1 ) 
    3570          IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err ) 
    3571       END SELECT 
    3572       ! 
    3573       !                           ! Write Dirichlet lateral conditions 
    3574       ijhom = nlcj-jprecj 
    3575       ! 
    3576       SELECT CASE ( nbondj_bdy_b(ib_bdy) ) 
    3577       CASE ( -1 ) 
    3578          DO jl = 1, jprecj 
    3579             ptab(:,ijhom+jl) = zt2ns(:,jl,2) 
    3580          END DO 
    3581       CASE ( 0 ) 
    3582          DO jl = 1, jprecj 
    3583             ptab(:,jl      ) = zt2sn(:,jl,2) 
    3584             ptab(:,ijhom+jl) = zt2ns(:,jl,2) 
    3585          END DO 
    3586       CASE ( 1 ) 
    3587          DO jl = 1, jprecj 
    3588             ptab(:,jl) = zt2sn(:,jl,2) 
    3589          END DO 
    3590       END SELECT 
    3591  
    3592       ! 4. north fold treatment 
    3593       ! ----------------------- 
    3594       ! 
    3595       IF( npolj /= 0) THEN 
    3596          ! 
    3597          SELECT CASE ( jpni ) 
    3598          CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp 
    3599          CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs. 
    3600          END SELECT 
    3601          ! 
    3602       ENDIF 
    3603       ! 
    3604       DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we  ) 
    3605       ! 
    3606    END SUBROUTINE mpp_lnk_bdy_2d 
    36071532 
    36081533 
     
    36661591   END SUBROUTINE mpi_init_opa 
    36671592 
    3668    SUBROUTINE DDPDD_MPI (ydda, yddb, ilen, itype) 
     1593 
     1594   SUBROUTINE DDPDD_MPI( ydda, yddb, ilen, itype ) 
    36691595      !!--------------------------------------------------------------------- 
    36701596      !!   Routine DDPDD_MPI: used by reduction operator MPI_SUMDD 
     
    36801606      INTEGER  :: ji, ztmp           ! local scalar 
    36811607      !!--------------------------------------------------------------------- 
    3682  
     1608      ! 
    36831609      ztmp = itype   ! avoid compilation warning 
    3684  
     1610      ! 
    36851611      DO ji=1,ilen 
    36861612      ! Compute ydda + yddb using Knuth's trick. 
     
    36931619         yddb(ji) = cmplx ( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1),wp ) 
    36941620      END DO 
    3695  
     1621      ! 
    36961622   END SUBROUTINE DDPDD_MPI 
    36971623 
     
    37631689      END DO 
    37641690 
    3765  
    37661691      ! 2. North-Fold boundary conditions 
    37671692      ! ---------------------------------- 
    3768       CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = ipr2dj ) 
     1693!!gm ERROR      CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = ipr2dj ) 
    37691694 
    37701695      ij = ipr2dj 
     
    38091734      ! 
    38101735      INTEGER  ::   jl   ! dummy loop indices 
    3811       INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
    3812       INTEGER  ::   ipreci, iprecj             ! temporary integers 
     1736      INTEGER  ::   imigr, iihom, ijhom        ! local integers 
     1737      INTEGER  ::   ipreci, iprecj             !   -       - 
    38131738      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    38141739      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
    38151740      !! 
    3816       REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dns 
    3817       REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dsn 
    3818       REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dwe 
    3819       REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dew 
     1741      REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) ::   r2dns, r2dsn 
     1742      REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) ::   r2dwe, r2dew 
    38201743      !!---------------------------------------------------------------------- 
    38211744 
     
    38451768         ! 
    38461769         SELECT CASE ( jpni ) 
    3847          CASE ( 1 )     ;   CALL lbc_nfd        ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj ) 
    3848          CASE DEFAULT   ;   CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+jprj)  , cd_type, psgn , pr2dj=jprj  ) 
     1770!!gm ERROR         CASE ( 1 )     ;   CALL lbc_nfd        ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj ) 
     1771!!gm ERROR         CASE DEFAULT   ;   CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+jprj)  , cd_type, psgn , pr2dj=jprj  ) 
    38491772         END SELECT 
    38501773         ! 
  • branches/2017/dev_r8126_ROBUST08_no_ghost/NEMOGCM/NEMO/OPA_SRC/SBC/sbcwave.F90

    r7864 r8186  
    137137         END DO 
    138138      END DO    
    139       CALL lbc_lnk( usd(:,:,:), 'U', vsd(:,:,:), 'V', -1. ) 
     139!!gm      CALL lbc_lnk( usd(:,:,:), 'U', vsd(:,:,:), 'V', -1. ) 
     140      CALL lbc_lnk( usd(:,:,:), 'U', -1. ) 
     141      CALL lbc_lnk( vsd(:,:,:), 'V', -1. ) 
     142 
     143 
    140144      ! 
    141145      !                       !==  vertical Stokes Drift 3D velocity  ==! 
Note: See TracChangeset for help on using the changeset viewer.