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 8226 – NEMO

Changeset 8226


Ignore:
Timestamp:
2017-06-28T10:02:58+02:00 (7 years ago)
Author:
clem
Message:

merge with dev_r8127_AGRIF_LIM3_GHOST@r8189 and dev_r8126_ROBUST08_no_ghost@r8196

Location:
branches/2017/dev_r8183_ICEMODEL/NEMOGCM
Files:
30 edited
7 copied

Legend:

Unmodified
Added
Removed
  • branches/2017/dev_r8183_ICEMODEL/NEMOGCM/NEMO/LIM_SRC_3/limhdf.F90

    r7753 r8226  
    6969      REAL(wp), POINTER, DIMENSION(:,:)   ::  zflu, zflv, zdiv 
    7070      !!------------------------------------------------------------------- 
    71       TYPE(arrayptr)   , ALLOCATABLE, DIMENSION(:) ::   pt2d_array, zrlx_array 
     71      TYPE(PTR_2D)   , ALLOCATABLE, DIMENSION(:) ::   pt2d_array, zrlx_array 
    7272      CHARACTER(len=1) , ALLOCATABLE, DIMENSION(:) ::   type_array      ! define the nature of ptab array grid-points 
    7373      !                                                                 ! = T , U , V , F , W and I points 
     
    156156         END DO 
    157157 
    158          CALL lbc_lnk_multi( zrlx_array, type_array , psgn_array , isize ) ! Multiple interchange of all the variables 
     158         CALL lbc_lnk_ptr( zrlx_array, type_array , psgn_array , isize ) ! Multiple interchange of all the variables 
    159159         ! 
    160160 
     
    195195      END DO 
    196196 
    197       CALL lbc_lnk_multi( pt2d_array, type_array , psgn_array , isize ) ! Multiple interchange of all the variables 
     197      CALL lbc_lnk_ptr( pt2d_array, type_array , psgn_array , isize ) ! Multiple interchange of all the variables 
    198198 
    199199      ! 
  • branches/2017/dev_r8183_ICEMODEL/NEMOGCM/NEMO/NST_SRC/agrif_lim3_interp.F90

    r7761 r8226  
    5252      !!----------------------------------------------------------------------- 
    5353      ! 
    54       IF( Agrif_Root() )  RETURN 
     54      IF( Agrif_Root() .OR. nn_ice==0 )  RETURN   ! clem2017: do not interpolate if inside Parent domain or if child domain does not have ice 
    5555      ! 
    5656      SELECT CASE(cd_type) 
     
    9090      !! i1 i2 j1 j2 are the index of the boundaries parent(when before) and child (when after) 
    9191      !! To solve issues when parent grid is "land" masked but not all the corresponding child grid points, 
    92       !! put -9999 WHERE the parent grid is masked. The child solution will be found in the 9(?) points around 
     92      !! put -999 WHERE the parent grid is masked. The child solution will be found in the 9(?) points around 
    9393      !!----------------------------------------------------------------------- 
    9494      INTEGER , INTENT(in) :: i1, i2, j1, j2 
     
    101101      IF( before ) THEN  ! parent grid 
    102102         ptab(:,:) = e2u(i1:i2,j1:j2) * u_ice_b(i1:i2,j1:j2) 
    103          WHERE( umask(i1:i2,j1:j2,1) == 0. )  ptab(:,:) = -9999. 
     103         WHERE( umask(i1:i2,j1:j2,1) == 0. )   ptab(i1:i2,j1:j2) = Agrif_SpecialValue 
    104104      ELSE               ! child grid 
    105105         zrhoy = Agrif_Rhoy() 
    106          u_ice(i1:i2,j1:j2) = ptab(:,:) / ( e2u(i1:i2,j1:j2) * zrhoy ) * umask(i1:i2,j1:j2,1) 
     106         u_ice(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) / ( e2u(i1:i2,j1:j2) * zrhoy ) * umask(i1:i2,j1:j2,1) 
    107107      ENDIF 
    108108      ! 
     
    116116      !! i1 i2 j1 j2 are the index of the boundaries parent(when before) and child (when after) 
    117117      !! To solve issues when parent grid is "land" masked but not all the corresponding child grid points, 
    118       !! put -9999 WHERE the parent grid is masked. The child solution will be found in the 9(?) points around 
     118      !! put -999 WHERE the parent grid is masked. The child solution will be found in the 9(?) points around 
    119119      !!-----------------------------------------------------------------------       
    120120      INTEGER , INTENT(in) :: i1, i2, j1, j2 
     
    127127      IF( before ) THEN  ! parent grid 
    128128         ptab(:,:) = e1v(i1:i2,j1:j2) * v_ice_b(i1:i2,j1:j2) 
    129          WHERE( vmask(i1:i2,j1:j2,1) == 0. )  ptab(:,:) = -9999. 
     129         WHERE( vmask(i1:i2,j1:j2,1) == 0. )  ptab(i1:i2,j1:j2) = Agrif_SpecialValue 
    130130      ELSE               ! child grid 
    131131         zrhox = Agrif_Rhox() 
    132          v_ice(i1:i2,j1:j2) = ptab(:,:) / ( e1v(i1:i2,j1:j2) * zrhox ) * vmask(i1:i2,j1:j2,1) 
     132         v_ice(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) / ( e1v(i1:i2,j1:j2) * zrhox ) * vmask(i1:i2,j1:j2,1) 
    133133      ENDIF 
    134134      ! 
     
    142142      !! i1 i2 j1 j2 are the index of the boundaries parent(when before) and child (when after) 
    143143      !! To solve issues when parent grid is "land" masked but not all the corresponding child grid points, 
    144       !! put -9999 WHERE the parent grid is masked. The child solution will be found in the 9(?) points around 
     144      !! put -999 WHERE the parent grid is masked. The child solution will be found in the 9(?) points around 
    145145      !!----------------------------------------------------------------------- 
    146146      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     
    158158      ! tracers are not multiplied by grid cell here => before: * e12t ; after: * r1_e12t / rhox / rhoy 
    159159      ! and it is ok since we conserve tracers (same as in the ocean). 
    160       ALLOCATE( ztab(SIZE(a_i_b,1),SIZE(a_i_b,2),SIZE(ptab,3)) ) 
     160      ALLOCATE( ztab(SIZE(a_i,1),SIZE(a_i,2),SIZE(ptab,3)) ) 
    161161      
    162162      IF( before ) THEN  ! parent grid 
    163163         jm = 1 
    164164         DO jl = 1, jpl 
    165             ptab(i1:i2,j1:j2,jm) = a_i_b  (i1:i2,j1:j2,jl) ; jm = jm + 1 
    166             ptab(i1:i2,j1:j2,jm) = v_i_b  (i1:i2,j1:j2,jl) ; jm = jm + 1 
    167             ptab(i1:i2,j1:j2,jm) = v_s_b  (i1:i2,j1:j2,jl) ; jm = jm + 1 
    168             ptab(i1:i2,j1:j2,jm) = smv_i_b(i1:i2,j1:j2,jl) ; jm = jm + 1 
    169             ptab(i1:i2,j1:j2,jm) = oa_i_b (i1:i2,j1:j2,jl) ; jm = jm + 1 
     165            ptab(i1:i2,j1:j2,jm  ) = a_i_b  (i1:i2,j1:j2,jl) 
     166            ptab(i1:i2,j1:j2,jm+1) = v_i_b  (i1:i2,j1:j2,jl) 
     167            ptab(i1:i2,j1:j2,jm+2) = v_s_b  (i1:i2,j1:j2,jl) 
     168            ptab(i1:i2,j1:j2,jm+3) = smv_i_b(i1:i2,j1:j2,jl) 
     169            ptab(i1:i2,j1:j2,jm+4) = oa_i_b (i1:i2,j1:j2,jl) 
     170            jm = jm + 5 
    170171            DO jk = 1, nlay_s 
    171172               ptab(i1:i2,j1:j2,jm) = e_s_b(i1:i2,j1:j2,jk,jl) ; jm = jm + 1 
     
    177178          
    178179         DO jk = k1, k2 
    179             WHERE( tmask(i1:i2,j1:j2,1) == 0. )  ptab(i1:i2,j1:j2,jk) = -9999. 
     180            WHERE( tmask(i1:i2,j1:j2,1) == 0. )  ptab(i1:i2,j1:j2,jk) = Agrif_SpecialValue 
    180181         ENDDO 
    181182          
    182183      ELSE               ! child grid 
    183 !! ==> The easiest interpolation is the following commented lines 
    184          jm = 1 
    185          DO jl = 1, jpl 
    186             a_i  (i1:i2,j1:j2,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 
    187             v_i  (i1:i2,j1:j2,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 
    188             v_s  (i1:i2,j1:j2,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 
    189             smv_i(i1:i2,j1:j2,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 
    190             oa_i (i1:i2,j1:j2,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 
    191             DO jk = 1, nlay_s 
    192                e_s(i1:i2,j1:j2,jk,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 
    193             ENDDO 
    194             DO jk = 1, nlay_i 
    195                e_i(i1:i2,j1:j2,jk,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 
    196             ENDDO 
    197          ENDDO 
    198  
    199 !! ==> this is a more complex interpolation since we mix solutions over a couple of grid points 
    200 !!     it is advised to use it for fields modified by high order schemes (e.g. advection UM5...) 
    201 !!        clem: for some reason (I don't know why), the following lines do not work  
    202 !!              with mpp (or in realistic configurations?). It makes the model crash 
    203 !         ! record ztab 
    204 !         jm = 1 
    205 !         DO jl = 1, jpl 
    206 !            ztab(:,:,jm) = a_i  (:,:,jl) ; jm = jm + 1 
    207 !            ztab(:,:,jm) = v_i  (:,:,jl) ; jm = jm + 1 
    208 !            ztab(:,:,jm) = v_s  (:,:,jl) ; jm = jm + 1 
    209 !            ztab(:,:,jm) = smv_i(:,:,jl) ; jm = jm + 1 
    210 !            ztab(:,:,jm) = oa_i (:,:,jl) ; jm = jm + 1 
    211 !            DO jk = 1, nlay_s 
    212 !               ztab(:,:,jm) = e_s(:,:,jk,jl) ; jm = jm + 1 
    213 !            ENDDO 
    214 !            DO jk = 1, nlay_i 
    215 !               ztab(:,:,jm) = e_i(:,:,jk,jl) ; jm = jm + 1 
    216 !            ENDDO 
    217 !         ENDDO 
    218 !         ! 
    219 !         ! borders of the domain 
    220 !         western_side  = (nb == 1).AND.(ndir == 1)  ;  eastern_side  = (nb == 1).AND.(ndir == 2) 
    221 !         southern_side = (nb == 2).AND.(ndir == 1)  ;  northern_side = (nb == 2).AND.(ndir == 2) 
    222 !         ! 
    223 !         ! spatial smoothing 
    224 !         zrhox = Agrif_Rhox() 
    225 !         z1 =      ( zrhox - 1. ) * 0.5  
    226 !         z3 =      ( zrhox - 1. ) / ( zrhox + 1. ) 
    227 !         z6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 
    228 !         z7 =    - ( zrhox - 1. ) / ( zrhox + 3. ) 
    229 !         z2 = 1. - z1 
    230 !         z4 = 1. - z3 
    231 !         z5 = 1. - z6 - z7 
    232 !         ! 
    233 !         ! Remove corners 
    234 !         imin = i1  ;  imax = i2  ;  jmin = j1  ;  jmax = j2 
    235 !         IF( (nbondj == -1) .OR. (nbondj == 2) )   jmin = 3 
    236 !         IF( (nbondj == +1) .OR. (nbondj == 2) )   jmax = nlcj-2 
    237 !         IF( (nbondi == -1) .OR. (nbondi == 2) )   imin = 3 
    238 !         IF( (nbondi == +1) .OR. (nbondi == 2) )   imax = nlci-2 
    239 ! 
    240 !         ! smoothed fields 
    241 !         IF( eastern_side ) THEN 
    242 !            ztab(nlci,j1:j2,:) = z1 * ptab(nlci,j1:j2,:) + z2 * ptab(nlci-1,j1:j2,:) 
    243 !            DO jj = jmin, jmax 
    244 !               rswitch = 0. 
    245 !               IF( u_ice(nlci-2,jj) > 0._wp ) rswitch = 1. 
    246 !               ztab(nlci-1,jj,:) = ( 1. - umask(nlci-2,jj,1) ) * ztab(nlci,jj,:)  & 
    247 !                  &                +      umask(nlci-2,jj,1)   *  & 
    248 !                  &                ( ( 1. - rswitch ) * ( z4 * ztab(nlci,jj,:)   + z3 * ztab(nlci-2,jj,:) )  & 
    249 !                  &                  +      rswitch   * ( z6 * ztab(nlci-2,jj,:) + z5 * ztab(nlci,jj,:) + z7 * ztab(nlci-3,jj,:) ) ) 
    250 !               ztab(nlci-1,jj,:) = ztab(nlci-1,jj,:) * tmask(nlci-1,jj,1) 
    251 !            END DO 
    252 !         ENDIF 
    253 !         !  
    254 !         IF( northern_side ) THEN 
    255 !            ztab(i1:i2,nlcj,:) = z1 * ptab(i1:i2,nlcj,:) + z2 * ptab(i1:i2,nlcj-1,:) 
    256 !            DO ji = imin, imax 
    257 !               rswitch = 0. 
    258 !               IF( v_ice(ji,nlcj-2) > 0._wp ) rswitch = 1. 
    259 !               ztab(ji,nlcj-1,:) = ( 1. - vmask(ji,nlcj-2,1) ) * ztab(ji,nlcj,:)  & 
    260 !                  &                +      vmask(ji,nlcj-2,1)   *  & 
    261 !                  &                ( ( 1. - rswitch ) * ( z4 * ztab(ji,nlcj,:)   + z3 * ztab(ji,nlcj-2,:) ) & 
    262 !                  &                  +      rswitch   * ( z6 * ztab(ji,nlcj-2,:) + z5 * ztab(ji,nlcj,:) + z7 * ztab(ji,nlcj-3,:) ) ) 
    263 !               ztab(ji,nlcj-1,:) = ztab(ji,nlcj-1,:) * tmask(ji,nlcj-1,1) 
    264 !            END DO 
    265 !         END IF 
    266 !         ! 
    267 !         IF( western_side) THEN 
    268 !            ztab(1,j1:j2,:) = z1 * ptab(1,j1:j2,:) + z2 * ptab(2,j1:j2,:) 
    269 !            DO jj = jmin, jmax 
    270 !               rswitch = 0. 
    271 !               IF( u_ice(2,jj) < 0._wp ) rswitch = 1. 
    272 !               ztab(2,jj,:) = ( 1. - umask(2,jj,1) ) * ztab(1,jj,:)  & 
    273 !                  &           +      umask(2,jj,1)   *   & 
    274 !                  &           ( ( 1. - rswitch ) * ( z4 * ztab(1,jj,:) + z3 * ztab(3,jj,:) ) & 
    275 !                  &             +      rswitch   * ( z6 * ztab(3,jj,:) + z5 * ztab(1,jj,:) + z7 * ztab(4,jj,:) ) ) 
    276 !               ztab(2,jj,:) = ztab(2,jj,:) * tmask(2,jj,1) 
    277 !            END DO 
    278 !         ENDIF 
    279 !         ! 
    280 !         IF( southern_side ) THEN 
    281 !            ztab(i1:i2,1,:) = z1 * ptab(i1:i2,1,:) + z2 * ptab(i1:i2,2,:) 
    282 !            DO ji = imin, imax 
    283 !               rswitch = 0. 
    284 !               IF( v_ice(ji,2) < 0._wp ) rswitch = 1. 
    285 !               ztab(ji,2,:) = ( 1. - vmask(ji,2,1) ) * ztab(ji,1,:)  & 
    286 !                  &           +      vmask(ji,2,1)   *  & 
    287 !                  &           ( ( 1. - rswitch ) * ( z4 * ztab(ji,1,:) + z3 * ztab(ji,3,:) ) & 
    288 !                  &             +      rswitch   * ( z6 * ztab(ji,3,:) + z5 * ztab(ji,1,:) + z7 * ztab(ji,4,:) ) ) 
    289 !               ztab(ji,2,:) = ztab(ji,2,:) * tmask(ji,2,1) 
    290 !            END DO 
    291 !         END IF 
    292 !         ! 
    293 !         ! Treatment of corners 
    294 !         IF( (eastern_side) .AND. ((nbondj == -1).OR.(nbondj == 2)) )  ztab(nlci-1,2,:)      = ptab(nlci-1,2,:)      ! East south 
    295 !         IF( (eastern_side) .AND. ((nbondj ==  1).OR.(nbondj == 2)) )  ztab(nlci-1,nlcj-1,:) = ptab(nlci-1,nlcj-1,:) ! East north 
    296 !         IF( (western_side) .AND. ((nbondj == -1).OR.(nbondj == 2)) )  ztab(2,2,:)           = ptab(2,2,:)           ! West south 
    297 !         IF( (western_side) .AND. ((nbondj ==  1).OR.(nbondj == 2)) )  ztab(2,nlcj-1,:)      = ptab(2,nlcj-1,:)      ! West north 
    298 ! 
    299 !         ! retrieve ice tracers 
    300 !         jm = 1 
    301 !         DO jl = 1, jpl 
    302 !            a_i  (i1:i2,j1:j2,jl) = ztab(i1:i2,j1:j2,jm) ; jm = jm + 1 
    303 !            v_i  (i1:i2,j1:j2,jl) = ztab(i1:i2,j1:j2,jm) ; jm = jm + 1 
    304 !            v_s  (i1:i2,j1:j2,jl) = ztab(i1:i2,j1:j2,jm) ; jm = jm + 1 
    305 !            smv_i(i1:i2,j1:j2,jl) = ztab(i1:i2,j1:j2,jm) ; jm = jm + 1 
    306 !            oa_i (i1:i2,j1:j2,jl) = ztab(i1:i2,j1:j2,jm) ; jm = jm + 1 
    307 !            DO jk = 1, nlay_s 
    308 !               e_s(i1:i2,j1:j2,jk,jl) = ztab(i1:i2,j1:j2,jm) ; jm = jm + 1 
    309 !            ENDDO 
    310 !            DO jk = 1, nlay_i 
    311 !               e_i(i1:i2,j1:j2,jk,jl) = ztab(i1:i2,j1:j2,jm) ; jm = jm + 1 
    312 !            ENDDO 
    313 !         ENDDO 
    314         
     184 
     185         IF( nbghostcells > 1 ) THEN 
     186            !! ==> The easiest interpolation is the following lines 
     187 
     188            jm = 1 
     189            DO jl = 1, jpl 
     190               ! 
     191               DO jj = j1, j2 
     192                  DO ji = i1, i2 
     193                     a_i  (ji,jj,jl) = ptab(ji,jj,jm  ) * tmask(ji,jj,1) 
     194                     v_i  (ji,jj,jl) = ptab(ji,jj,jm+1) * tmask(ji,jj,1) 
     195                     v_s  (ji,jj,jl) = ptab(ji,jj,jm+2) * tmask(ji,jj,1) 
     196                     smv_i(ji,jj,jl) = ptab(ji,jj,jm+3) * tmask(ji,jj,1) 
     197                     oa_i (ji,jj,jl) = ptab(ji,jj,jm+4) * tmask(ji,jj,1) 
     198                  ENDDO 
     199               ENDDO 
     200               jm = jm + 5 
     201               ! 
     202               DO jk = 1, nlay_s 
     203                  e_s(i1:i2,j1:j2,jk,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) 
     204                  jm = jm + 1 
     205               ENDDO 
     206               ! 
     207               DO jk = 1, nlay_i 
     208                  e_i(i1:i2,j1:j2,jk,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) 
     209                  jm = jm + 1 
     210               ENDDO 
     211               ! 
     212            ENDDO 
     213             
     214         ELSE 
     215            !! ==> this is a more complex interpolation since we mix solutions over a couple of grid points 
     216            !!     it is advised to use it for fields modified by high order schemes (e.g. advection UM5...) 
     217            !!        clem: for some reason (I don't know why), the following lines do not work  
     218            !!              with mpp (or in realistic configurations?). It makes the model crash 
     219            !      I think there is an issue with Agrif_SpecialValue here (not taken into account properly) 
     220            ! record ztab 
     221            jm = 1 
     222            DO jl = 1, jpl 
     223               ztab(:,:,jm  ) = a_i  (:,:,jl) 
     224               ztab(:,:,jm+1) = v_i  (:,:,jl) 
     225               ztab(:,:,jm+2) = v_s  (:,:,jl) 
     226               ztab(:,:,jm+3) = smv_i(:,:,jl) 
     227               ztab(:,:,jm+4) = oa_i (:,:,jl) 
     228               jm = jm + 5 
     229               DO jk = 1, nlay_s 
     230                  ztab(:,:,jm) = e_s(:,:,jk,jl) 
     231                  jm = jm + 1 
     232               ENDDO 
     233               DO jk = 1, nlay_i 
     234                  ztab(:,:,jm) = e_i(:,:,jk,jl) 
     235                  jm = jm + 1 
     236               ENDDO 
     237               ! 
     238            ENDDO 
     239            ! 
     240            ! borders of the domain 
     241            western_side  = (nb == 1).AND.(ndir == 1)  ;  eastern_side  = (nb == 1).AND.(ndir == 2) 
     242            southern_side = (nb == 2).AND.(ndir == 1)  ;  northern_side = (nb == 2).AND.(ndir == 2) 
     243            ! 
     244            ! spatial smoothing 
     245            zrhox = Agrif_Rhox() 
     246            z1 =      ( zrhox - 1. ) * 0.5  
     247            z3 =      ( zrhox - 1. ) / ( zrhox + 1. ) 
     248            z6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 
     249            z7 =    - ( zrhox - 1. ) / ( zrhox + 3. ) 
     250            z2 = 1. - z1 
     251            z4 = 1. - z3 
     252            z5 = 1. - z6 - z7 
     253            ! 
     254            ! Remove corners 
     255            imin = i1  ;  imax = i2  ;  jmin = j1  ;  jmax = j2 
     256            IF( (nbondj == -1) .OR. (nbondj == 2) )   jmin = 3 
     257            IF( (nbondj == +1) .OR. (nbondj == 2) )   jmax = nlcj-2 
     258            IF( (nbondi == -1) .OR. (nbondi == 2) )   imin = 3 
     259            IF( (nbondi == +1) .OR. (nbondi == 2) )   imax = nlci-2 
     260 
     261            ! smoothed fields 
     262            IF( eastern_side ) THEN 
     263               ztab(nlci,j1:j2,:) = z1 * ptab(nlci,j1:j2,:) + z2 * ptab(nlci-1,j1:j2,:) 
     264               DO jj = jmin, jmax 
     265                  rswitch = 0. 
     266                  IF( u_ice(nlci-2,jj) > 0._wp ) rswitch = 1. 
     267                  ztab(nlci-1,jj,:) = ( 1. - umask(nlci-2,jj,1) ) * ztab(nlci,jj,:)  & 
     268                     &                +      umask(nlci-2,jj,1)   *  & 
     269                     &                ( ( 1. - rswitch ) * ( z4 * ztab(nlci,jj,:)   + z3 * ztab(nlci-2,jj,:) )  & 
     270                     &                  +      rswitch   * ( z6 * ztab(nlci-2,jj,:) + z5 * ztab(nlci,jj,:) + z7 * ztab(nlci-3,jj,:) ) ) 
     271                  ztab(nlci-1,jj,:) = ztab(nlci-1,jj,:) * tmask(nlci-1,jj,1) 
     272               END DO 
     273            ENDIF 
     274            !  
     275            IF( northern_side ) THEN 
     276               ztab(i1:i2,nlcj,:) = z1 * ptab(i1:i2,nlcj,:) + z2 * ptab(i1:i2,nlcj-1,:) 
     277               DO ji = imin, imax 
     278                  rswitch = 0. 
     279                  IF( v_ice(ji,nlcj-2) > 0._wp ) rswitch = 1. 
     280                  ztab(ji,nlcj-1,:) = ( 1. - vmask(ji,nlcj-2,1) ) * ztab(ji,nlcj,:)  & 
     281                     &                +      vmask(ji,nlcj-2,1)   *  & 
     282                     &                ( ( 1. - rswitch ) * ( z4 * ztab(ji,nlcj,:)   + z3 * ztab(ji,nlcj-2,:) ) & 
     283                     &                  +      rswitch   * ( z6 * ztab(ji,nlcj-2,:) + z5 * ztab(ji,nlcj,:) + z7 * ztab(ji,nlcj-3,:) ) ) 
     284                  ztab(ji,nlcj-1,:) = ztab(ji,nlcj-1,:) * tmask(ji,nlcj-1,1) 
     285               END DO 
     286            END IF 
     287            ! 
     288            IF( western_side) THEN 
     289               ztab(1,j1:j2,:) = z1 * ptab(1,j1:j2,:) + z2 * ptab(2,j1:j2,:) 
     290               DO jj = jmin, jmax 
     291                  rswitch = 0. 
     292                  IF( u_ice(2,jj) < 0._wp ) rswitch = 1. 
     293                  ztab(2,jj,:) = ( 1. - umask(2,jj,1) ) * ztab(1,jj,:)  & 
     294                     &           +      umask(2,jj,1)   *   & 
     295                     &           ( ( 1. - rswitch ) * ( z4 * ztab(1,jj,:) + z3 * ztab(3,jj,:) ) & 
     296                     &             +      rswitch   * ( z6 * ztab(3,jj,:) + z5 * ztab(1,jj,:) + z7 * ztab(4,jj,:) ) ) 
     297                  ztab(2,jj,:) = ztab(2,jj,:) * tmask(2,jj,1) 
     298               END DO 
     299            ENDIF 
     300            ! 
     301            IF( southern_side ) THEN 
     302               ztab(i1:i2,1,:) = z1 * ptab(i1:i2,1,:) + z2 * ptab(i1:i2,2,:) 
     303               DO ji = imin, imax 
     304                  rswitch = 0. 
     305                  IF( v_ice(ji,2) < 0._wp ) rswitch = 1. 
     306                  ztab(ji,2,:) = ( 1. - vmask(ji,2,1) ) * ztab(ji,1,:)  & 
     307                     &           +      vmask(ji,2,1)   *  & 
     308                     &           ( ( 1. - rswitch ) * ( z4 * ztab(ji,1,:) + z3 * ztab(ji,3,:) ) & 
     309                     &             +      rswitch   * ( z6 * ztab(ji,3,:) + z5 * ztab(ji,1,:) + z7 * ztab(ji,4,:) ) ) 
     310                  ztab(ji,2,:) = ztab(ji,2,:) * tmask(ji,2,1) 
     311               END DO 
     312            END IF 
     313            ! 
     314            ! Treatment of corners 
     315            IF( (eastern_side) .AND. ((nbondj == -1).OR.(nbondj == 2)) )  ztab(nlci-1,2,:)      = ptab(nlci-1,2,:)      ! East south 
     316            IF( (eastern_side) .AND. ((nbondj ==  1).OR.(nbondj == 2)) )  ztab(nlci-1,nlcj-1,:) = ptab(nlci-1,nlcj-1,:) ! East north 
     317            IF( (western_side) .AND. ((nbondj == -1).OR.(nbondj == 2)) )  ztab(2,2,:)           = ptab(2,2,:)           ! West south 
     318            IF( (western_side) .AND. ((nbondj ==  1).OR.(nbondj == 2)) )  ztab(2,nlcj-1,:)      = ptab(2,nlcj-1,:)      ! West north 
     319             
     320            ! retrieve ice tracers 
     321            jm = 1 
     322            DO jl = 1, jpl 
     323               ! 
     324               DO jj = j1, j2 
     325                  DO ji = i1, i2 
     326                     a_i  (ji,jj,jl) = ztab(ji,jj,jm  ) * tmask(ji,jj,1) 
     327                     v_i  (ji,jj,jl) = ztab(ji,jj,jm+1) * tmask(ji,jj,1) 
     328                     v_s  (ji,jj,jl) = ztab(ji,jj,jm+2) * tmask(ji,jj,1) 
     329                     smv_i(ji,jj,jl) = ztab(ji,jj,jm+3) * tmask(ji,jj,1) 
     330                     oa_i (ji,jj,jl) = ztab(ji,jj,jm+4) * tmask(ji,jj,1) 
     331                  ENDDO 
     332               ENDDO 
     333               jm = jm + 5 
     334               ! 
     335               DO jk = 1, nlay_s 
     336                  e_s(i1:i2,j1:j2,jk,jl) = ztab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) 
     337                  jm = jm + 1 
     338               ENDDO 
     339               ! 
     340               DO jk = 1, nlay_i 
     341                  e_i(i1:i2,j1:j2,jk,jl) = ztab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) 
     342                  jm = jm + 1 
     343               ENDDO 
     344               ! 
     345            ENDDO 
     346           
     347         ENDIF  ! nbghostcells=1 
     348          
    315349         ! integrated values 
    316350         vt_i (i1:i2,j1:j2) = SUM( v_i(i1:i2,j1:j2,:), dim=3 ) 
     
    319353         et_s(i1:i2,j1:j2)  = SUM( SUM( e_s(i1:i2,j1:j2,:,:), dim=4 ), dim=3 ) 
    320354         et_i(i1:i2,j1:j2)  = SUM( SUM( e_i(i1:i2,j1:j2,:,:), dim=4 ), dim=3 ) 
    321  
     355          
    322356      ENDIF 
     357 
     358      DEALLOCATE( ztab ) 
    323359       
    324       DEALLOCATE( ztab ) 
    325360      ! 
    326361   END SUBROUTINE interp_tra_ice 
  • branches/2017/dev_r8183_ICEMODEL/NEMOGCM/NEMO/NST_SRC/agrif_lim3_update.F90

    r7761 r8226  
    5656      IF( ( MOD( (kt-nit000)/nn_fsbc + 1, Agrif_irhot() * Agrif_Parent(nn_fsbc) / nn_fsbc ) /=0 ) .AND. (kt /= 0) ) RETURN ! do not update if nb of child time steps differ from time refinement 
    5757                                                                                                                           ! i.e. update only at the parent time step 
     58      IF( nn_ice == 0 ) RETURN   ! clem2017: do not update if child domain does not have ice 
     59      ! 
     60      Agrif_SpecialValueFineGrid = -9999. 
    5861      Agrif_UseSpecialValueInUpdate = .TRUE. 
    59       Agrif_SpecialValueFineGrid = -9999. 
    6062# if defined TWO_WAY 
    6163      IF( MOD(nbcline,nbclineupdate) == 0) THEN ! update the whole basin at each nbclineupdate (=nn_cln_update) baroclinic parent time steps 
     
    7072      ENDIF 
    7173# endif 
     74      Agrif_SpecialValueFineGrid = 0. 
    7275      Agrif_UseSpecialValueInUpdate = .FALSE. 
    7376      ! 
     
    8891      LOGICAL , INTENT(in) :: before 
    8992      !! 
    90       INTEGER  :: jk, jl, jm 
     93      INTEGER  :: ji, jj, jk, jl, jm 
    9194      !!----------------------------------------------------------------------- 
    9295      ! it is ok not to multiply by e1*e2 since we conserve tracers here (same as in the ocean). 
     
    9497         jm = 1 
    9598         DO jl = 1, jpl 
    96             ptab(:,:,jm) = a_i  (i1:i2,j1:j2,jl) ; jm = jm + 1 
    97             ptab(:,:,jm) = v_i  (i1:i2,j1:j2,jl) ; jm = jm + 1 
    98             ptab(:,:,jm) = v_s  (i1:i2,j1:j2,jl) ; jm = jm + 1 
    99             ptab(:,:,jm) = smv_i(i1:i2,j1:j2,jl) ; jm = jm + 1 
    100             ptab(:,:,jm) = oa_i (i1:i2,j1:j2,jl) ; jm = jm + 1 
     99            ptab(i1:i2,j1:j2,jm  ) = a_i  (i1:i2,j1:j2,jl) 
     100            ptab(i1:i2,j1:j2,jm+1) = v_i  (i1:i2,j1:j2,jl) 
     101            ptab(i1:i2,j1:j2,jm+2) = v_s  (i1:i2,j1:j2,jl) 
     102            ptab(i1:i2,j1:j2,jm+3) = smv_i(i1:i2,j1:j2,jl) 
     103            ptab(i1:i2,j1:j2,jm+4) = oa_i (i1:i2,j1:j2,jl) 
     104            jm = jm + 5 
    101105            DO jk = 1, nlay_s 
    102                ptab(:,:,jm) = e_s(i1:i2,j1:j2,jk,jl) ; jm = jm + 1 
     106               ptab(i1:i2,j1:j2,jm) = e_s(i1:i2,j1:j2,jk,jl) ; jm = jm + 1 
    103107            ENDDO 
    104108            DO jk = 1, nlay_i 
    105                ptab(:,:,jm) = e_i(i1:i2,j1:j2,jk,jl) ; jm = jm + 1 
     109               ptab(i1:i2,j1:j2,jm) = e_i(i1:i2,j1:j2,jk,jl) ; jm = jm + 1 
    106110            ENDDO 
    107111         ENDDO 
    108  
     112         ! 
    109113         DO jk = k1, k2 
    110             WHERE( tmask(i1:i2,j1:j2,1) == 0. )  ptab(:,:,jk) = -9999. 
     114            WHERE( tmask(i1:i2,j1:j2,1) == 0. )  ptab(i1:i2,j1:j2,jk) = Agrif_SpecialValueFineGrid  
    111115         ENDDO 
    112                    
     116         ! 
    113117      ELSE 
     118         ! 
    114119         jm = 1 
    115120         DO jl = 1, jpl 
    116             a_i  (i1:i2,j1:j2,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 
    117             v_i  (i1:i2,j1:j2,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 
    118             v_s  (i1:i2,j1:j2,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 
    119             smv_i(i1:i2,j1:j2,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 
    120             oa_i (i1:i2,j1:j2,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 
     121            ! 
     122            DO jj = j1, j2 
     123               DO ji = i1, i2 
     124                  IF( ptab(ji,jj,jm) /= Agrif_SpecialValueFineGrid ) THEN 
     125                     a_i  (ji,jj,jl) = ptab(ji,jj,jm  ) * tmask(ji,jj,1) 
     126                     v_i  (ji,jj,jl) = ptab(ji,jj,jm+1) * tmask(ji,jj,1) 
     127                     v_s  (ji,jj,jl) = ptab(ji,jj,jm+2) * tmask(ji,jj,1) 
     128                     smv_i(ji,jj,jl) = ptab(ji,jj,jm+3) * tmask(ji,jj,1) 
     129                     oa_i (ji,jj,jl) = ptab(ji,jj,jm+4) * tmask(ji,jj,1) 
     130                  ENDIF 
     131               ENDDO 
     132            ENDDO 
     133            jm = jm + 5 
     134            ! 
    121135            DO jk = 1, nlay_s 
    122                e_s(i1:i2,j1:j2,jk,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 
    123             ENDDO 
     136               WHERE( ptab(i1:i2,j1:j2,jm) /= Agrif_SpecialValueFineGrid ) 
     137                  e_s(i1:i2,j1:j2,jk,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) 
     138               ENDWHERE 
     139               jm = jm + 1 
     140            ENDDO 
     141            ! 
    124142            DO jk = 1, nlay_i 
    125                e_i(i1:i2,j1:j2,jk,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 
    126             ENDDO 
     143               WHERE( ptab(i1:i2,j1:j2,jm) /= Agrif_SpecialValueFineGrid ) 
     144                  e_i(i1:i2,j1:j2,jk,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) 
     145               ENDWHERE 
     146               jm = jm + 1 
     147            ENDDO 
     148            ! 
    127149         ENDDO 
    128  
     150         ! 
    129151         ! integrated values 
    130152         vt_i (i1:i2,j1:j2) = SUM( v_i(i1:i2,j1:j2,:), dim=3 ) 
     
    154176         zrhoy = Agrif_Rhoy() 
    155177         ptab(:,:) = e2u(i1:i2,j1:j2) * u_ice(i1:i2,j1:j2) * zrhoy 
    156          WHERE( umask(i1:i2,j1:j2,1) == 0. )  ptab(:,:) = -9999. 
     178         WHERE( umask(i1:i2,j1:j2,1) == 0. )  ptab(:,:) = Agrif_SpecialValueFineGrid 
    157179      ELSE 
    158          u_ice(i1:i2,j1:j2) = ptab(:,:) / e2u(i1:i2,j1:j2) * umask(i1:i2,j1:j2,1) 
     180         WHERE( ptab(i1:i2,j1:j2) /= Agrif_SpecialValueFineGrid ) 
     181            u_ice(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) / e2u(i1:i2,j1:j2) * umask(i1:i2,j1:j2,1) 
     182         ENDWHERE 
    159183      ENDIF 
    160184      !  
     
    177201         zrhox = Agrif_Rhox() 
    178202         ptab(:,:) = e1v(i1:i2,j1:j2) * v_ice(i1:i2,j1:j2) * zrhox 
    179          WHERE( vmask(i1:i2,j1:j2,1) == 0. )  ptab(:,:) = -9999. 
     203         WHERE( vmask(i1:i2,j1:j2,1) == 0. )  ptab(:,:) = Agrif_SpecialValueFineGrid 
    180204      ELSE 
    181          v_ice(i1:i2,j1:j2) = ptab(:,:) / e1v(i1:i2,j1:j2) * vmask(i1:i2,j1:j2,1) 
     205         WHERE( ptab(i1:i2,j1:j2) /= Agrif_SpecialValueFineGrid ) 
     206            v_ice(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) / e1v(i1:i2,j1:j2) * vmask(i1:i2,j1:j2,1) 
     207         ENDWHERE 
    182208      ENDIF 
    183209      ! 
  • branches/2017/dev_r8183_ICEMODEL/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90

    r7646 r8226  
    3535   PUBLIC   Agrif_tra, Agrif_dyn, Agrif_ssh, Agrif_dyn_ts, Agrif_ssh_ts, Agrif_dta_ts 
    3636   PUBLIC   interpun, interpvn 
    37    PUBLIC   interptsn,  interpsshn 
     37   PUBLIC   interptsn, interpsshn 
    3838   PUBLIC   interpunb, interpvnb, interpub2b, interpvb2b 
    3939   PUBLIC   interpe3t, interpumsk, interpvmsk 
     
    100100      IF( nbondi == +1 .OR. nbondi == 2 )   i2 = nlci-2 
    101101 
     102      ! --- West --- ! 
    102103      IF( nbondi == -1 .OR. nbondi == 2 ) THEN 
    103104         ! 
    104          ! Smoothing 
    105          ! --------- 
    106105         IF( .NOT.ln_dynspg_ts ) THEN  ! Store transport 
    107             ua_b(2,:) = 0._wp 
     106            ua_b(2:1+nbghostcells,:) = 0._wp 
    108107            DO jk = 1, jpkm1 
    109108               DO jj = 1, jpj 
    110                   ua_b(2,jj) = ua_b(2,jj) + e3u_a(2,jj,jk) * ua(2,jj,jk) 
     109                  ua_b(2:1+nbghostcells,jj) = ua_b(2:1+nbghostcells,jj) + e3u_a(2:1+nbghostcells,jj,jk) * ua(2:1+nbghostcells,jj,jk) 
    111110               END DO 
    112111            END DO 
    113112            DO jj = 1, jpj 
    114                ua_b(2,jj) = ua_b(2,jj) * r1_hu_a(2,jj)             
    115             END DO 
    116          ENDIF 
    117          ! 
    118          DO jk=1,jpkm1                 ! Smooth 
    119             DO jj=j1,j2 
    120                ua(2,jj,jk) = 0.25_wp*(ua(1,jj,jk)+2._wp*ua(2,jj,jk)+ua(3,jj,jk)) 
    121                ua(2,jj,jk) = ua(2,jj,jk) * umask(2,jj,jk) 
    122             END DO 
    123          END DO 
    124          ! 
    125          zub(2,:) = 0._wp              ! Correct transport 
    126          DO jk = 1, jpkm1 
    127             DO jj = 1, jpj 
    128                zub(2,jj) = zub(2,jj) + e3u_a(2,jj,jk) * ua(2,jj,jk) 
    129             END DO 
    130          END DO 
    131          DO jj=1,jpj 
    132             zub(2,jj) = zub(2,jj) * r1_hu_a(2,jj) 
    133          END DO 
    134  
    135          DO jk=1,jpkm1 
    136             DO jj=1,jpj 
    137                ua(2,jj,jk) = (ua(2,jj,jk)+ua_b(2,jj)-zub(2,jj))*umask(2,jj,jk) 
    138             END DO 
    139          END DO 
    140  
    141          ! Set tangential velocities to time splitting estimate 
    142          !----------------------------------------------------- 
    143          IF( ln_dynspg_ts ) THEN 
    144             zvb(2,:) = 0._wp 
     113               ua_b(2:1+nbghostcells,jj) = ua_b(2:1+nbghostcells,jj) * r1_hu_a(2:1+nbghostcells,jj) 
     114            END DO 
     115         ENDIF 
     116         ! 
     117         ! Smoothing if only 1 ghostcell 
     118         ! ----------------------------- 
     119         IF( nbghostcells == 1 ) THEN 
     120            DO jk=1,jpkm1                 ! Smooth 
     121               DO jj=j1,j2 
     122                  ua(2,jj,jk) = 0.25_wp*(ua(1,jj,jk)+2._wp*ua(2,jj,jk)+ua(3,jj,jk)) 
     123                  ua(2,jj,jk) = ua(2,jj,jk) * umask(2,jj,jk) 
     124               END DO 
     125            END DO 
     126            ! 
     127            zub(2,:) = 0._wp              ! Correct transport 
    145128            DO jk = 1, jpkm1 
    146129               DO jj = 1, jpj 
    147                   zvb(2,jj) = zvb(2,jj) + e3v_a(2,jj,jk) * va(2,jj,jk) 
    148                END DO 
    149             END DO 
    150             DO jj = 1, jpj 
    151                zvb(2,jj) = zvb(2,jj) * r1_hv_a(2,jj) 
    152             END DO 
     130                  zub(2,jj) = zub(2,jj) + e3u_a(2,jj,jk) * ua(2,jj,jk) 
     131               END DO 
     132            END DO 
     133            DO jj=1,jpj 
     134               zub(2,jj) = zub(2,jj) * r1_hu_a(2,jj) 
     135            END DO 
     136             
     137            DO jk=1,jpkm1 
     138               DO jj=1,jpj 
     139                  ua(2,jj,jk) = (ua(2,jj,jk)+ua_b(2,jj)-zub(2,jj))*umask(2,jj,jk) 
     140               END DO 
     141            END DO 
     142             
     143            IF( ln_dynspg_ts ) THEN       ! Set tangential velocities to time splitting estimate 
     144               zvb(2,:) = 0._wp 
     145               DO jk = 1, jpkm1 
     146                  DO jj = 1, jpj 
     147                     zvb(2,jj) = zvb(2,jj) + e3v_a(2,jj,jk) * va(2,jj,jk) 
     148                  END DO 
     149               END DO 
     150               DO jj = 1, jpj 
     151                  zvb(2,jj) = zvb(2,jj) * r1_hv_a(2,jj) 
     152               END DO 
     153               DO jk = 1, jpkm1 
     154                  DO jj = 1, jpj 
     155                     va(2,jj,jk) = (va(2,jj,jk)+va_b(2,jj)-zvb(2,jj)) * vmask(2,jj,jk) 
     156                  END DO 
     157               END DO 
     158            ENDIF 
     159            ! 
     160         ENDIF 
     161         ! 
     162      ENDIF 
     163 
     164      ! --- East --- ! 
     165      IF( nbondi == 1 .OR. nbondi == 2 ) THEN 
     166 
     167         IF( .NOT.ln_dynspg_ts ) THEN  ! Store transport 
     168            ua_b(nlci-nbghostcells-1:nlci-2,:) = 0._wp 
     169            DO jk=1,jpkm1 
     170               DO jj=1,jpj 
     171                  ua_b(nlci-nbghostcells-1:nlci-2,jj) = ua_b(nlci-nbghostcells-1:nlci-2,jj) + e3u_a(nlci-nbghostcells-1:nlci-2,jj,jk)  & 
     172                     &                                                                         * ua(nlci-nbghostcells-1:nlci-2,jj,jk) 
     173               END DO 
     174            END DO 
     175            DO jj=1,jpj 
     176               ua_b(nlci-nbghostcells-1:nlci-2,jj) = ua_b(nlci-nbghostcells-1:nlci-2,jj) * r1_hu_a(nlci-nbghostcells-1:nlci-2,jj)  
     177            END DO 
     178         ENDIF 
     179         ! 
     180         ! Smoothing if only 1 ghostcell 
     181         ! ----------------------------- 
     182         IF( nbghostcells == 1 ) THEN 
     183            DO jk = 1, jpkm1              ! Smooth 
     184               DO jj = j1, j2 
     185                  ua(nlci-2,jj,jk) = 0.25_wp * umask(nlci-2,jj,jk)      & 
     186                     &             * ( ua(nlci-3,jj,jk) + 2._wp*ua(nlci-2,jj,jk) + ua(nlci-1,jj,jk) ) 
     187               END DO 
     188            END DO 
     189             
     190            zub(nlci-2,:) = 0._wp        ! Correct transport 
    153191            DO jk = 1, jpkm1 
    154192               DO jj = 1, jpj 
    155                   va(2,jj,jk) = (va(2,jj,jk)+va_b(2,jj)-zvb(2,jj)) * vmask(2,jj,jk) 
    156                END DO 
    157             END DO 
    158          ENDIF 
    159          ! 
    160          ! Mask domain edges: 
    161          !------------------- 
    162          DO jk = 1, jpkm1 
     193                  zub(nlci-2,jj) = zub(nlci-2,jj) + e3u_a(nlci-2,jj,jk) * ua(nlci-2,jj,jk) 
     194               END DO 
     195            END DO 
    163196            DO jj = 1, jpj 
    164                ua(1,jj,jk) = 0._wp 
    165                va(1,jj,jk) = 0._wp 
    166             END DO 
    167          END DO          
    168          ! 
    169       ENDIF 
    170  
    171       IF( nbondi == 1 .OR. nbondi == 2 ) THEN 
    172  
    173          ! Smoothing 
    174          ! --------- 
    175          IF( .NOT.ln_dynspg_ts ) THEN  ! Store transport 
    176             ua_b(nlci-2,:) = 0._wp 
    177             DO jk=1,jpkm1 
    178                DO jj=1,jpj 
    179                   ua_b(nlci-2,jj) = ua_b(nlci-2,jj) + e3u_a(nlci-2,jj,jk) * ua(nlci-2,jj,jk) 
    180                END DO 
    181             END DO 
    182             DO jj=1,jpj 
    183                ua_b(nlci-2,jj) = ua_b(nlci-2,jj) * r1_hu_a(nlci-2,jj)             
    184             END DO 
    185          ENDIF 
    186  
    187          DO jk = 1, jpkm1              ! Smooth 
    188             DO jj = j1, j2 
    189                ua(nlci-2,jj,jk) = 0.25_wp * umask(nlci-2,jj,jk)      & 
    190                   &             * ( ua(nlci-3,jj,jk) + 2._wp*ua(nlci-2,jj,jk) + ua(nlci-1,jj,jk) ) 
    191             END DO 
    192          END DO 
    193  
    194          zub(nlci-2,:) = 0._wp        ! Correct transport 
    195          DO jk = 1, jpkm1 
    196             DO jj = 1, jpj 
    197                zub(nlci-2,jj) = zub(nlci-2,jj) + e3u_a(nlci-2,jj,jk) * ua(nlci-2,jj,jk) 
    198             END DO 
    199          END DO 
    200          DO jj = 1, jpj 
    201             zub(nlci-2,jj) = zub(nlci-2,jj) * r1_hu_a(nlci-2,jj) 
    202          END DO 
    203  
    204          DO jk = 1, jpkm1 
    205             DO jj = 1, jpj 
    206                ua(nlci-2,jj,jk) = ( ua(nlci-2,jj,jk) + ua_b(nlci-2,jj) - zub(nlci-2,jj) ) * umask(nlci-2,jj,jk) 
    207             END DO 
    208          END DO 
    209          ! 
    210          ! Set tangential velocities to time splitting estimate 
    211          !----------------------------------------------------- 
    212          IF( ln_dynspg_ts ) THEN 
    213             zvb(nlci-1,:) = 0._wp 
     197               zub(nlci-2,jj) = zub(nlci-2,jj) * r1_hu_a(nlci-2,jj) 
     198            END DO 
     199             
    214200            DO jk = 1, jpkm1 
    215201               DO jj = 1, jpj 
    216                   zvb(nlci-1,jj) = zvb(nlci-1,jj) + e3v_a(nlci-1,jj,jk) * va(nlci-1,jj,jk) 
    217                END DO 
    218             END DO 
    219             DO jj=1,jpj 
    220                zvb(nlci-1,jj) = zvb(nlci-1,jj) * r1_hv_a(nlci-1,jj) 
    221             END DO 
    222             DO jk = 1, jpkm1 
    223                DO jj = 1, jpj 
    224                   va(nlci-1,jj,jk) = ( va(nlci-1,jj,jk) + va_b(nlci-1,jj) - zvb(nlci-1,jj) ) * vmask(nlci-1,jj,jk) 
    225                END DO 
    226             END DO 
    227          ENDIF 
    228          ! 
    229          ! Mask domain edges: 
    230          !------------------- 
    231          DO jk = 1, jpkm1 
    232             DO jj = 1, jpj 
    233                ua(nlci-1,jj,jk) = 0._wp 
    234                va(nlci  ,jj,jk) = 0._wp 
    235             END DO 
    236          END DO  
    237          ! 
    238       ENDIF 
    239  
     202                  ua(nlci-2,jj,jk) = ( ua(nlci-2,jj,jk) + ua_b(nlci-2,jj) - zub(nlci-2,jj) ) * umask(nlci-2,jj,jk) 
     203               END DO 
     204            END DO 
     205            ! 
     206            IF( ln_dynspg_ts ) THEN       ! Set tangential velocities to time splitting estimate 
     207               zvb(nlci-1,:) = 0._wp 
     208               DO jk = 1, jpkm1 
     209                  DO jj = 1, jpj 
     210                     zvb(nlci-1,jj) = zvb(nlci-1,jj) + e3v_a(nlci-1,jj,jk) * va(nlci-1,jj,jk) 
     211                  END DO 
     212               END DO 
     213               DO jj=1,jpj 
     214                  zvb(nlci-1,jj) = zvb(nlci-1,jj) * r1_hv_a(nlci-1,jj) 
     215               END DO 
     216               DO jk = 1, jpkm1 
     217                  DO jj = 1, jpj 
     218                     va(nlci-1,jj,jk) = ( va(nlci-1,jj,jk) + va_b(nlci-1,jj) - zvb(nlci-1,jj) ) * vmask(nlci-1,jj,jk) 
     219                  END DO 
     220               END DO 
     221            ENDIF 
     222            ! 
     223         ENDIF 
     224         ! 
     225      ENDIF 
     226 
     227      ! --- South --- ! 
    240228      IF( nbondj == -1 .OR. nbondj == 2 ) THEN 
    241229 
    242          ! Smoothing 
    243          ! --------- 
    244230         IF( .NOT.ln_dynspg_ts ) THEN  ! Store transport 
    245             va_b(:,2) = 0._wp 
     231            va_b(:,2:nbghostcells+1) = 0._wp 
    246232            DO jk = 1, jpkm1 
    247233               DO ji = 1, jpi 
    248                   va_b(ji,2) = va_b(ji,2) + e3v_a(ji,2,jk) * va(ji,2,jk) 
     234                  va_b(ji,2:nbghostcells+1) = va_b(ji,2:nbghostcells+1) + e3v_a(ji,2:nbghostcells+1,jk) * va(ji,2:nbghostcells+1,jk) 
    249235               END DO 
    250236            END DO 
    251237            DO ji=1,jpi 
    252                va_b(ji,2) = va_b(ji,2) * r1_hv_a(ji,2)             
    253             END DO 
    254          ENDIF 
    255          ! 
    256          DO jk = 1, jpkm1              ! Smooth 
    257             DO ji = i1, i2 
    258                va(ji,2,jk) = 0.25_wp * vmask(ji,2,jk)    & 
    259                   &        * ( va(ji,1,jk) + 2._wp*va(ji,2,jk) + va(ji,3,jk) ) 
    260             END DO 
    261          END DO 
    262          ! 
    263          zvb(:,2) = 0._wp              ! Correct transport 
    264          DO jk=1,jpkm1 
    265             DO ji=1,jpi 
    266                zvb(ji,2) = zvb(ji,2) + e3v_a(ji,2,jk) * va(ji,2,jk) * vmask(ji,2,jk) 
    267             END DO 
    268          END DO 
    269          DO ji = 1, jpi 
    270             zvb(ji,2) = zvb(ji,2) * r1_hv_a(ji,2) 
    271          END DO 
    272          DO jk = 1, jpkm1 
     238               va_b(ji,2:nbghostcells+1) = va_b(ji,2:nbghostcells+1) * r1_hv_a(ji,2:nbghostcells+1) 
     239            END DO 
     240         ENDIF 
     241         ! 
     242         ! Smoothing if only 1 ghostcell 
     243         ! ----------------------------- 
     244         IF( nbghostcells == 1 ) THEN 
     245            DO jk = 1, jpkm1              ! Smooth 
     246               DO ji = i1, i2 
     247                  va(ji,2,jk) = 0.25_wp * vmask(ji,2,jk)    & 
     248                     &        * ( va(ji,1,jk) + 2._wp*va(ji,2,jk) + va(ji,3,jk) ) 
     249               END DO 
     250            END DO 
     251            ! 
     252            zvb(:,2) = 0._wp              ! Correct transport 
     253            DO jk=1,jpkm1 
     254               DO ji=1,jpi 
     255                  zvb(ji,2) = zvb(ji,2) + e3v_a(ji,2,jk) * va(ji,2,jk) * vmask(ji,2,jk) 
     256               END DO 
     257            END DO 
    273258            DO ji = 1, jpi 
    274                va(ji,2,jk) = ( va(ji,2,jk) + va_b(ji,2) - zvb(ji,2) ) * vmask(ji,2,jk) 
    275             END DO 
    276          END DO 
    277  
    278          ! Set tangential velocities to time splitting estimate 
    279          !----------------------------------------------------- 
    280          IF( ln_dynspg_ts ) THEN 
    281             zub(:,2) = 0._wp 
     259               zvb(ji,2) = zvb(ji,2) * r1_hv_a(ji,2) 
     260            END DO 
    282261            DO jk = 1, jpkm1 
    283262               DO ji = 1, jpi 
    284                   zub(ji,2) = zub(ji,2) + e3u_a(ji,2,jk) * ua(ji,2,jk) * umask(ji,2,jk) 
    285                END DO 
    286             END DO 
    287             DO ji = 1, jpi 
    288                zub(ji,2) = zub(ji,2) * r1_hu_a(ji,2) 
    289             END DO 
    290  
     263                  va(ji,2,jk) = ( va(ji,2,jk) + va_b(ji,2) - zvb(ji,2) ) * vmask(ji,2,jk) 
     264               END DO 
     265            END DO 
     266             
     267            IF( ln_dynspg_ts ) THEN       ! Set tangential velocities to time splitting estimate 
     268               zub(:,2) = 0._wp 
     269               DO jk = 1, jpkm1 
     270                  DO ji = 1, jpi 
     271                     zub(ji,2) = zub(ji,2) + e3u_a(ji,2,jk) * ua(ji,2,jk) * umask(ji,2,jk) 
     272                  END DO 
     273               END DO 
     274               DO ji = 1, jpi 
     275                  zub(ji,2) = zub(ji,2) * r1_hu_a(ji,2) 
     276               END DO 
     277                
     278               DO jk = 1, jpkm1 
     279                  DO ji = 1, jpi 
     280                     ua(ji,2,jk) = ( ua(ji,2,jk) + ua_b(ji,2) - zub(ji,2) ) * umask(ji,2,jk) 
     281                  END DO 
     282               END DO 
     283            ENDIF 
     284            ! 
     285         ENDIF 
     286         ! 
     287      ENDIF 
     288 
     289      ! --- North --- ! 
     290      IF( nbondj == 1 .OR. nbondj == 2 ) THEN 
     291         ! 
     292         IF( .NOT.ln_dynspg_ts ) THEN  ! Store transport 
     293            va_b(:,nlcj-nbghostcells-1:nlcj-2) = 0._wp 
    291294            DO jk = 1, jpkm1 
    292295               DO ji = 1, jpi 
    293                   ua(ji,2,jk) = ( ua(ji,2,jk) + ua_b(ji,2) - zub(ji,2) ) * umask(ji,2,jk) 
    294                END DO 
    295             END DO 
    296          ENDIF 
    297  
    298          ! Mask domain edges: 
    299          !------------------- 
    300          DO jk = 1, jpkm1 
     296                  va_b(ji,nlcj-nbghostcells-1:nlcj-2) = va_b(ji,nlcj-nbghostcells-1:nlcj-2) + e3v_a(ji,nlcj-nbghostcells-1:nlcj-2,jk)  & 
     297                     &                                                                         * va(ji,nlcj-nbghostcells-1:nlcj-2,jk) 
     298               END DO 
     299            END DO 
    301300            DO ji = 1, jpi 
    302                ua(ji,1,jk) = 0._wp 
    303                va(ji,1,jk) = 0._wp 
    304             END DO 
    305          END DO  
    306  
    307       ENDIF 
    308  
    309       IF( nbondj == 1 .OR. nbondj == 2 ) THEN 
    310          ! 
    311          ! Smoothing 
    312          ! --------- 
    313          IF( .NOT.ln_dynspg_ts ) THEN  ! Store transport 
    314             va_b(:,nlcj-2) = 0._wp 
     301               va_b(ji,nlcj-nbghostcells-1:nlcj-2) = va_b(ji,nlcj-nbghostcells-1:nlcj-2) * r1_hv_a(ji,nlcj-nbghostcells-1:nlcj-2) 
     302            END DO 
     303         ENDIF 
     304         ! 
     305         ! Smoothing if only 1 ghostcell 
     306         ! ----------------------------- 
     307         IF( nbghostcells == 1 ) THEN 
     308            DO jk = 1, jpkm1              ! Smooth 
     309               DO ji = i1, i2 
     310                  va(ji,nlcj-2,jk) = 0.25_wp * vmask(ji,nlcj-2,jk)   & 
     311                     &             * ( va(ji,nlcj-3,jk) + 2._wp * va(ji,nlcj-2,jk) + va(ji,nlcj-1,jk) ) 
     312               END DO 
     313            END DO 
     314            ! 
     315            zvb(:,nlcj-2) = 0._wp         ! Correct transport 
    315316            DO jk = 1, jpkm1 
    316317               DO ji = 1, jpi 
    317                   va_b(ji,nlcj-2) = va_b(ji,nlcj-2) + e3v_a(ji,nlcj-2,jk) * va(ji,nlcj-2,jk) 
     318                  zvb(ji,nlcj-2) = zvb(ji,nlcj-2) + e3v_a(ji,nlcj-2,jk) * va(ji,nlcj-2,jk) * vmask(ji,nlcj-2,jk) 
    318319               END DO 
    319320            END DO 
    320321            DO ji = 1, jpi 
    321                va_b(ji,nlcj-2) = va_b(ji,nlcj-2) * r1_hv_a(ji,nlcj-2)             
    322             END DO 
    323          ENDIF 
    324          ! 
    325          DO jk = 1, jpkm1              ! Smooth 
    326             DO ji = i1, i2 
    327                va(ji,nlcj-2,jk) = 0.25_wp * vmask(ji,nlcj-2,jk)   & 
    328                   &             * ( va(ji,nlcj-3,jk) + 2._wp * va(ji,nlcj-2,jk) + va(ji,nlcj-1,jk) ) 
    329             END DO 
    330          END DO 
    331          ! 
    332          zvb(:,nlcj-2) = 0._wp         ! Correct transport 
    333          DO jk = 1, jpkm1 
    334             DO ji = 1, jpi 
    335                zvb(ji,nlcj-2) = zvb(ji,nlcj-2) + e3v_a(ji,nlcj-2,jk) * va(ji,nlcj-2,jk) * vmask(ji,nlcj-2,jk) 
    336             END DO 
    337          END DO 
    338          DO ji = 1, jpi 
    339             zvb(ji,nlcj-2) = zvb(ji,nlcj-2) * r1_hv_a(ji,nlcj-2) 
    340          END DO 
    341          DO jk = 1, jpkm1 
    342             DO ji = 1, jpi 
    343                va(ji,nlcj-2,jk) = ( va(ji,nlcj-2,jk) + va_b(ji,nlcj-2) - zvb(ji,nlcj-2) ) * vmask(ji,nlcj-2,jk) 
    344             END DO 
    345          END DO 
    346          ! 
    347          ! Set tangential velocities to time splitting estimate 
    348          !----------------------------------------------------- 
    349          IF( ln_dynspg_ts ) THEN 
    350             zub(:,nlcj-1) = 0._wp 
     322               zvb(ji,nlcj-2) = zvb(ji,nlcj-2) * r1_hv_a(ji,nlcj-2) 
     323            END DO 
    351324            DO jk = 1, jpkm1 
    352325               DO ji = 1, jpi 
    353                   zub(ji,nlcj-1) = zub(ji,nlcj-1) + e3u_a(ji,nlcj-1,jk) * ua(ji,nlcj-1,jk) * umask(ji,nlcj-1,jk) 
    354                END DO 
    355             END DO 
    356             DO ji = 1, jpi 
    357                zub(ji,nlcj-1) = zub(ji,nlcj-1) * r1_hu_a(ji,nlcj-1) 
    358             END DO 
    359             ! 
    360             DO jk = 1, jpkm1 
     326                  va(ji,nlcj-2,jk) = ( va(ji,nlcj-2,jk) + va_b(ji,nlcj-2) - zvb(ji,nlcj-2) ) * vmask(ji,nlcj-2,jk) 
     327               END DO 
     328            END DO 
     329            ! 
     330            IF( ln_dynspg_ts ) THEN       ! Set tangential velocities to time splitting estimate 
     331               zub(:,nlcj-1) = 0._wp 
     332               DO jk = 1, jpkm1 
     333                  DO ji = 1, jpi 
     334                     zub(ji,nlcj-1) = zub(ji,nlcj-1) + e3u_a(ji,nlcj-1,jk) * ua(ji,nlcj-1,jk) * umask(ji,nlcj-1,jk) 
     335                  END DO 
     336               END DO 
    361337               DO ji = 1, jpi 
    362                   ua(ji,nlcj-1,jk) = ( ua(ji,nlcj-1,jk) + ua_b(ji,nlcj-1) - zub(ji,nlcj-1) ) * umask(ji,nlcj-1,jk) 
    363                END DO 
    364             END DO 
    365          ENDIF 
    366          ! 
    367          ! Mask domain edges: 
    368          !------------------- 
    369          DO jk = 1, jpkm1 
    370             DO ji = 1, jpi 
    371                ua(ji,nlcj  ,jk) = 0._wp 
    372                va(ji,nlcj-1,jk) = 0._wp 
    373             END DO 
    374          END DO  
     338                  zub(ji,nlcj-1) = zub(ji,nlcj-1) * r1_hu_a(ji,nlcj-1) 
     339               END DO 
     340               ! 
     341               DO jk = 1, jpkm1 
     342                  DO ji = 1, jpi 
     343                     ua(ji,nlcj-1,jk) = ( ua(ji,nlcj-1,jk) + ua_b(ji,nlcj-1) - zub(ji,nlcj-1) ) * umask(ji,nlcj-1,jk) 
     344                  END DO 
     345               END DO 
     346            ENDIF 
     347            ! 
     348         ENDIF 
    375349         ! 
    376350      ENDIF 
     
    392366      ! 
    393367      IF( Agrif_Root() )   RETURN 
    394       ! 
     368      !! clem ghost 
    395369      IF((nbondi == -1).OR.(nbondi == 2)) THEN 
    396370         DO jj=1,jpj 
    397             va_e(2,jj) = vbdy_w(jj) * hvr_e(2,jj) 
    398             ! Specified fluxes: 
    399             ua_e(2,jj) = ubdy_w(jj) * hur_e(2,jj) 
    400             ! Characteristics method: 
    401             !alt            ua_e(2,jj) = 0.5_wp * ( ubdy_w(jj) * hur_e(2,jj) + ua_e(3,jj) & 
    402             !alt                       &           - sqrt(grav * hur_e(2,jj)) * (sshn_e(3,jj) - hbdy_w(jj)) ) 
     371            IF( vmask(2,jj,1) == 1._wp ) THEN !clem: avoid interpolation if coast at the boundary 
     372               va_e(2:nbghostcells+1,jj) = vbdy_w(jj) * hvr_e(2:nbghostcells+1,jj) 
     373               ! Specified fluxes: 
     374               ua_e(2:nbghostcells+1,jj) = ubdy_w(jj) * hur_e(2:nbghostcells+1,jj) 
     375               ! Characteristics method (only if ghostcells=1): 
     376               !alt            ua_e(2,jj) = 0.5_wp * ( ubdy_w(jj) * hur_e(2,jj) + ua_e(3,jj) & 
     377               !alt                       &           - sqrt(grav * hur_e(2,jj)) * (sshn_e(3,jj) - hbdy_w(jj)) ) 
     378            ENDIF 
    403379         END DO 
    404380      ENDIF 
     
    406382      IF((nbondi == 1).OR.(nbondi == 2)) THEN 
    407383         DO jj=1,jpj 
    408             va_e(nlci-1,jj) = vbdy_e(jj) * hvr_e(nlci-1,jj) 
    409             ! Specified fluxes: 
    410             ua_e(nlci-2,jj) = ubdy_e(jj) * hur_e(nlci-2,jj) 
    411             ! Characteristics method: 
    412             !alt            ua_e(nlci-2,jj) = 0.5_wp * ( ubdy_e(jj) * hur_e(nlci-2,jj) + ua_e(nlci-3,jj) & 
    413             !alt                            &           + sqrt(grav * hur_e(nlci-2,jj)) * (sshn_e(nlci-2,jj) - hbdy_e(jj)) ) 
     384            IF( vmask(nlci-1,jj,1) == 1._wp ) THEN !clem: avoid interpolation if coast at the boundary 
     385               va_e(nlci-nbghostcells:nlci-1,jj)   = vbdy_e(jj) * hvr_e(nlci-nbghostcells:nlci-1,jj) 
     386               ! Specified fluxes: 
     387               ua_e(nlci-nbghostcells-1:nlci-2,jj) = ubdy_e(jj) * hur_e(nlci-nbghostcells-1:nlci-2,jj) 
     388               ! Characteristics method (only if ghostcells=1): 
     389               !alt            ua_e(nlci-2,jj) = 0.5_wp * ( ubdy_e(jj) * hur_e(nlci-2,jj) + ua_e(nlci-3,jj) & 
     390               !alt                            &           + sqrt(grav * hur_e(nlci-2,jj)) * (sshn_e(nlci-2,jj) - hbdy_e(jj)) ) 
     391            ENDIF 
    414392         END DO 
    415393      ENDIF 
     
    417395      IF((nbondj == -1).OR.(nbondj == 2)) THEN 
    418396         DO ji=1,jpi 
    419             ua_e(ji,2) = ubdy_s(ji) * hur_e(ji,2) 
    420             ! Specified fluxes: 
    421             va_e(ji,2) = vbdy_s(ji) * hvr_e(ji,2) 
    422             ! Characteristics method: 
    423             !alt            va_e(ji,2) = 0.5_wp * ( vbdy_s(ji) * hvr_e(ji,2) + va_e(ji,3) & 
    424             !alt                       &           - sqrt(grav * hvr_e(ji,2)) * (sshn_e(ji,3) - hbdy_s(ji)) ) 
     397            IF( umask(ji,2,1) == 1._wp ) THEN !clem: avoid interpolation if coast at the boundary 
     398               ua_e(ji,2:nbghostcells+1) = ubdy_s(ji) * hur_e(ji,2:nbghostcells+1) 
     399               ! Specified fluxes: 
     400               va_e(ji,2:nbghostcells+1) = vbdy_s(ji) * hvr_e(ji,2:nbghostcells+1) 
     401               ! Characteristics method (only if ghostcells=1): 
     402               !alt            va_e(ji,2) = 0.5_wp * ( vbdy_s(ji) * hvr_e(ji,2) + va_e(ji,3) & 
     403               !alt                       &           - sqrt(grav * hvr_e(ji,2)) * (sshn_e(ji,3) - hbdy_s(ji)) ) 
     404            ENDIF 
    425405         END DO 
    426406      ENDIF 
     
    428408      IF((nbondj == 1).OR.(nbondj == 2)) THEN 
    429409         DO ji=1,jpi 
    430             ua_e(ji,nlcj-1) = ubdy_n(ji) * hur_e(ji,nlcj-1) 
    431             ! Specified fluxes: 
    432             va_e(ji,nlcj-2) = vbdy_n(ji) * hvr_e(ji,nlcj-2) 
    433             ! Characteristics method: 
    434             !alt            va_e(ji,nlcj-2) = 0.5_wp * ( vbdy_n(ji) * hvr_e(ji,nlcj-2)  + va_e(ji,nlcj-3) & 
    435             !alt                            &           + sqrt(grav * hvr_e(ji,nlcj-2)) * (sshn_e(ji,nlcj-2) - hbdy_n(ji)) ) 
     410            IF( umask(ji,nlcj-1,1) == 1._wp ) THEN !clem: avoid interpolation if coast at the boundary 
     411               ua_e(ji,nlcj-nbghostcells:nlcj-1)   = ubdy_n(ji) * hur_e(ji,nlcj-nbghostcells:nlcj-1) 
     412               ! Specified fluxes: 
     413               va_e(ji,nlcj-nbghostcells-1:nlcj-2) = vbdy_n(ji) * hvr_e(ji,nlcj-nbghostcells-1:nlcj-2) 
     414               ! Characteristics method (only if ghostcells=1): 
     415               !alt            va_e(ji,nlcj-2) = 0.5_wp * ( vbdy_n(ji) * hvr_e(ji,nlcj-2)  + va_e(ji,nlcj-3) & 
     416               !alt                            &           + sqrt(grav * hvr_e(ji,nlcj-2)) * (sshn_e(ji,nlcj-2) - hbdy_n(ji)) ) 
     417            ENDIF 
    436418         END DO 
    437419      ENDIF 
     
    476458      ! 
    477459      IF( ll_int_cons ) THEN  ! Conservative interpolation 
    478          ! orders matters here !!!!!! 
     460         ! order matters here !!!!!! 
    479461         CALL Agrif_Bc_variable( ub2b_interp_id, calledweight=1._wp, procname=interpub2b ) ! Time integrated 
    480462         CALL Agrif_Bc_variable( vb2b_interp_id, calledweight=1._wp, procname=interpvb2b ) 
     
    504486      !!----------------------------------------------------------------------   
    505487      INTEGER, INTENT(in) ::   kt 
    506       !! 
     488      ! 
     489      INTEGER  :: ji, jj, indx 
    507490      !!----------------------------------------------------------------------   
    508491      ! 
    509492      IF( Agrif_Root() )   RETURN 
    510       ! 
     493      !! clem ghost 
     494      ! --- West --- ! 
    511495      IF((nbondi == -1).OR.(nbondi == 2)) THEN 
    512          ssha(2,:)=ssha(3,:) 
    513          sshn(2,:)=sshn(3,:) 
    514       ENDIF 
    515       ! 
     496         indx = 1+nbghostcells 
     497         DO jj = 1, jpj 
     498            DO ji = 2, indx 
     499               IF( tmask(2,jj,1) == 1._wp ) THEN !clem: avoid interpolation if coast at the boundary 
     500                  ssha(ji,jj)=ssha(indx+1,jj) 
     501                  sshn(ji,jj)=sshn(indx+1,jj) 
     502               ENDIF 
     503            ENDDO 
     504         ENDDO 
     505      ENDIF 
     506      ! 
     507      ! --- East --- ! 
    516508      IF((nbondi == 1).OR.(nbondi == 2)) THEN 
    517          ssha(nlci-1,:)=ssha(nlci-2,:) 
    518          sshn(nlci-1,:)=sshn(nlci-2,:) 
    519       ENDIF 
    520       ! 
     509         indx = nlci-nbghostcells 
     510         DO jj = 1, jpj 
     511            DO ji = indx, nlci-1 
     512               IF( tmask(nlci-1,jj,1) == 1._wp ) THEN !clem: avoid interpolation if coast at the boundary 
     513                  ssha(ji,jj)=ssha(indx-1,jj) 
     514                  sshn(ji,jj)=sshn(indx-1,jj) 
     515               ENDIF 
     516            ENDDO 
     517         ENDDO 
     518      ENDIF 
     519      ! 
     520      ! --- South --- ! 
    521521      IF((nbondj == -1).OR.(nbondj == 2)) THEN 
    522          ssha(:,2)=ssha(:,3) 
    523          sshn(:,2)=sshn(:,3) 
    524       ENDIF 
    525       ! 
     522         indx = 1+nbghostcells 
     523         DO jj = 2, indx 
     524            DO ji = 1, jpi 
     525               IF( tmask(ji,2,1) == 1._wp ) THEN !clem: avoid interpolation if coast at the boundary 
     526                  ssha(ji,jj)=ssha(ji,indx+1) 
     527                  sshn(ji,jj)=sshn(ji,indx+1) 
     528               ENDIF 
     529            ENDDO 
     530         ENDDO 
     531      ENDIF 
     532      ! 
     533      ! --- North --- ! 
    526534      IF((nbondj == 1).OR.(nbondj == 2)) THEN 
    527          ssha(:,nlcj-1)=ssha(:,nlcj-2) 
    528          sshn(:,nlcj-1)=sshn(:,nlcj-2) 
     535         indx = nlcj-nbghostcells 
     536         DO jj = indx, nlcj-1 
     537            DO ji = 1, jpi 
     538               IF( tmask(ji,nlcj-1,1) == 1._wp ) THEN !clem: avoid interpolation if coast at the boundary 
     539                  ssha(ji,jj)=ssha(ji,indx-1) 
     540                  sshn(ji,jj)=sshn(ji,indx-1) 
     541               ENDIF 
     542            ENDDO 
     543         ENDDO 
    529544      ENDIF 
    530545      ! 
     
    538553      INTEGER, INTENT(in) ::   jn 
    539554      !! 
    540       INTEGER :: ji,jj 
    541       !!----------------------------------------------------------------------   
    542       ! 
     555      INTEGER :: ji, jj 
     556      !!----------------------------------------------------------------------   
     557      !! clem ghost (starting at i,j=1 is important I think otherwise you introduce a grad(ssh)/=0 at point 2) 
    543558      IF((nbondi == -1).OR.(nbondi == 2)) THEN 
    544559         DO jj = 1, jpj 
    545             ssha_e(2,jj) = hbdy_w(jj) 
     560            IF( tmask(2,jj,1) == 1._wp ) THEN !clem: avoid interpolation if coast at the boundary 
     561               ssha_e(2:nbghostcells+1,jj) = hbdy_w(jj) 
     562            ENDIF 
    546563         END DO 
    547564      ENDIF 
     
    549566      IF((nbondi == 1).OR.(nbondi == 2)) THEN 
    550567         DO jj = 1, jpj 
    551             ssha_e(nlci-1,jj) = hbdy_e(jj) 
     568            IF( tmask(nlci-1,jj,1) == 1._wp ) THEN !clem: avoid interpolation if coast at the boundary 
     569               ssha_e(nlci-nbghostcells:nlci-1,jj) = hbdy_e(jj) 
     570            ENDIF 
    552571         END DO 
    553572      ENDIF 
     
    555574      IF((nbondj == -1).OR.(nbondj == 2)) THEN 
    556575         DO ji = 1, jpi 
    557             ssha_e(ji,2) = hbdy_s(ji) 
     576            IF( tmask(ji,2,1) == 1._wp ) THEN !clem: avoid interpolation if coast at the boundary 
     577               ssha_e(ji,2:nbghostcells+1) = hbdy_s(ji) 
     578            ENDIF 
    558579         END DO 
    559580      ENDIF 
     
    561582      IF((nbondj == 1).OR.(nbondj == 2)) THEN 
    562583         DO ji = 1, jpi 
    563             ssha_e(ji,nlcj-1) = hbdy_n(ji) 
     584            IF( tmask(ji,nlcj-1,1) == 1._wp ) THEN !clem: avoid interpolation if coast at the boundary 
     585               ssha_e(ji,nlcj-nbghostcells:nlcj-1) = hbdy_n(ji) 
     586            ENDIF 
    564587         END DO 
    565588      ENDIF 
     
    601624      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    602625      INTEGER  ::   imin, imax, jmin, jmax 
    603       REAL(wp) ::   zrhox , zalpha1, zalpha2, zalpha3 
    604       REAL(wp) ::   zalpha4, zalpha5, zalpha6, zalpha7 
     626      REAL(wp) ::   zrhox, z1, z2, z3, z4, z5, z6, z7 
    605627      LOGICAL  ::   western_side, eastern_side,northern_side,southern_side 
    606628      !!---------------------------------------------------------------------- 
     
    610632      ELSE 
    611633         ! 
    612          western_side  = (nb == 1).AND.(ndir == 1) 
    613          eastern_side  = (nb == 1).AND.(ndir == 2) 
    614          southern_side = (nb == 2).AND.(ndir == 1) 
    615          northern_side = (nb == 2).AND.(ndir == 2) 
    616          ! 
    617          zrhox = Agrif_Rhox() 
    618          !  
    619          zalpha1 = ( zrhox - 1. ) * 0.5 
    620          zalpha2 = 1. - zalpha1 
    621          !  
    622          zalpha3 = ( zrhox - 1. ) / ( zrhox + 1. ) 
    623          zalpha4 = 1. - zalpha3 
    624          !  
    625          zalpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 
    626          zalpha7 =    - ( zrhox - 1. ) / ( zrhox + 3. ) 
    627          zalpha5 = 1. - zalpha6 - zalpha7 
    628          ! 
    629          imin = i1 
    630          imax = i2 
    631          jmin = j1 
    632          jmax = j2 
    633          !  
    634          ! Remove CORNERS 
    635          IF((nbondj == -1).OR.(nbondj == 2)) jmin = 3 
    636          IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj-2 
    637          IF((nbondi == -1).OR.(nbondi == 2)) imin = 3 
    638          IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci-2         
    639          ! 
    640          IF( eastern_side ) THEN 
    641             DO jn = 1, jpts 
    642                tsa(nlci,j1:j2,k1:k2,jn) = zalpha1 * ptab(nlci,j1:j2,k1:k2,jn) + zalpha2 * ptab(nlci-1,j1:j2,k1:k2,jn) 
    643                DO jk = 1, jpkm1 
    644                   DO jj = jmin,jmax 
    645                      IF( umask(nlci-2,jj,jk) == 0._wp ) THEN 
    646                         tsa(nlci-1,jj,jk,jn) = tsa(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 
    647                      ELSE 
    648                         tsa(nlci-1,jj,jk,jn)=(zalpha4*tsa(nlci,jj,jk,jn)+zalpha3*tsa(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 
    649                         IF( un(nlci-2,jj,jk) > 0._wp ) THEN 
    650                            tsa(nlci-1,jj,jk,jn)=( zalpha6*tsa(nlci-2,jj,jk,jn)+zalpha5*tsa(nlci,jj,jk,jn) &  
    651                                  + zalpha7*tsa(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 
     634         western_side  = (nb == 1).AND.(ndir == 1)  ;  eastern_side  = (nb == 1).AND.(ndir == 2) 
     635         southern_side = (nb == 2).AND.(ndir == 1)  ;  northern_side = (nb == 2).AND.(ndir == 2) 
     636         ! 
     637         IF( nbghostcells > 1 ) THEN  ! no smoothing 
     638            tsa(i1:i2,j1:j2,k1:k2,n1:n2) = ptab(i1:i2,j1:j2,k1:k2,n1:n2) 
     639         ELSE                         ! smoothing 
     640            ! 
     641            zrhox = Agrif_Rhox() 
     642            z1 = ( zrhox - 1. ) * 0.5 
     643            z3 = ( zrhox - 1. ) / ( zrhox + 1. ) 
     644            z6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 
     645            z7 =    - ( zrhox - 1. ) / ( zrhox + 3. ) 
     646            ! 
     647            z2 = 1. - z1 
     648            z4 = 1. - z3 
     649            z5 = 1. - z6 - z7 
     650            ! 
     651            imin = i1 ; imax = i2 
     652            jmin = j1 ; jmax = j2 
     653            !  
     654            ! Remove CORNERS 
     655            IF((nbondj == -1).OR.(nbondj == 2)) jmin = 3 
     656            IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj-2 
     657            IF((nbondi == -1).OR.(nbondi == 2)) imin = 3 
     658            IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci-2         
     659            ! 
     660            IF( eastern_side ) THEN 
     661               DO jn = 1, jpts 
     662                  tsa(nlci,j1:j2,k1:k2,jn) = z1 * ptab(nlci,j1:j2,k1:k2,jn) + z2 * ptab(nlci-1,j1:j2,k1:k2,jn) 
     663                  DO jk = 1, jpkm1 
     664                     DO jj = jmin,jmax 
     665                        IF( umask(nlci-2,jj,jk) == 0._wp ) THEN 
     666                           tsa(nlci-1,jj,jk,jn) = tsa(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 
     667                        ELSE 
     668                           tsa(nlci-1,jj,jk,jn)=(z4*tsa(nlci,jj,jk,jn)+z3*tsa(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 
     669                           IF( un(nlci-2,jj,jk) > 0._wp ) THEN 
     670                              tsa(nlci-1,jj,jk,jn)=( z6*tsa(nlci-2,jj,jk,jn)+z5*tsa(nlci,jj,jk,jn) &  
     671                                                   + z7*tsa(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 
     672                           ENDIF 
    652673                        ENDIF 
    653                      ENDIF 
     674                     END DO 
    654675                  END DO 
    655                END DO 
    656                tsa(nlci,j1:j2,k1:k2,jn) = 0._wp 
    657             END DO 
    658          ENDIF 
    659          !  
    660          IF( northern_side ) THEN             
    661             DO jn = 1, jpts 
    662                tsa(i1:i2,nlcj,k1:k2,jn) = zalpha1 * ptab(i1:i2,nlcj,k1:k2,jn) + zalpha2 * ptab(i1:i2,nlcj-1,k1:k2,jn) 
    663                DO jk = 1, jpkm1 
    664                   DO ji = imin,imax 
    665                      IF( vmask(ji,nlcj-2,jk) == 0._wp ) THEN 
    666                         tsa(ji,nlcj-1,jk,jn) = tsa(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 
    667                      ELSE 
    668                         tsa(ji,nlcj-1,jk,jn)=(zalpha4*tsa(ji,nlcj,jk,jn)+zalpha3*tsa(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk)         
    669                         IF (vn(ji,nlcj-2,jk) > 0._wp ) THEN 
    670                            tsa(ji,nlcj-1,jk,jn)=( zalpha6*tsa(ji,nlcj-2,jk,jn)+zalpha5*tsa(ji,nlcj,jk,jn)  & 
    671                                  + zalpha7*tsa(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 
     676                  tsa(nlci,j1:j2,k1:k2,jn) = 0._wp 
     677               END DO 
     678            ENDIF 
     679            !  
     680            IF( northern_side ) THEN             
     681               DO jn = 1, jpts 
     682                  tsa(i1:i2,nlcj,k1:k2,jn) = z1 * ptab(i1:i2,nlcj,k1:k2,jn) + z2 * ptab(i1:i2,nlcj-1,k1:k2,jn) 
     683                  DO jk = 1, jpkm1 
     684                     DO ji = imin,imax 
     685                        IF( vmask(ji,nlcj-2,jk) == 0._wp ) THEN 
     686                           tsa(ji,nlcj-1,jk,jn) = tsa(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 
     687                        ELSE 
     688                           tsa(ji,nlcj-1,jk,jn)=(z4*tsa(ji,nlcj,jk,jn)+z3*tsa(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk)         
     689                           IF (vn(ji,nlcj-2,jk) > 0._wp ) THEN 
     690                              tsa(ji,nlcj-1,jk,jn)=( z6*tsa(ji,nlcj-2,jk,jn)+z5*tsa(ji,nlcj,jk,jn)  & 
     691                                                   + z7*tsa(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 
     692                           ENDIF 
    672693                        ENDIF 
    673                      ENDIF 
     694                     END DO 
    674695                  END DO 
    675                END DO 
    676                tsa(i1:i2,nlcj,k1:k2,jn) = 0._wp 
    677             END DO 
    678          ENDIF 
    679          ! 
    680          IF( western_side ) THEN             
    681             DO jn = 1, jpts 
    682                tsa(1,j1:j2,k1:k2,jn) = zalpha1 * ptab(1,j1:j2,k1:k2,jn) + zalpha2 * ptab(2,j1:j2,k1:k2,jn) 
    683                DO jk = 1, jpkm1 
    684                   DO jj = jmin,jmax 
    685                      IF( umask(2,jj,jk) == 0._wp ) THEN 
    686                         tsa(2,jj,jk,jn) = tsa(1,jj,jk,jn) * tmask(2,jj,jk) 
    687                      ELSE 
    688                         tsa(2,jj,jk,jn)=(zalpha4*tsa(1,jj,jk,jn)+zalpha3*tsa(3,jj,jk,jn))*tmask(2,jj,jk)         
    689                         IF( un(2,jj,jk) < 0._wp ) THEN 
    690                            tsa(2,jj,jk,jn)=(zalpha6*tsa(3,jj,jk,jn)+zalpha5*tsa(1,jj,jk,jn)+zalpha7*tsa(4,jj,jk,jn))*tmask(2,jj,jk) 
     696                  tsa(i1:i2,nlcj,k1:k2,jn) = 0._wp 
     697               END DO 
     698            ENDIF 
     699            ! 
     700            IF( western_side ) THEN             
     701               DO jn = 1, jpts 
     702                  tsa(1,j1:j2,k1:k2,jn) = z1 * ptab(1,j1:j2,k1:k2,jn) + z2 * ptab(2,j1:j2,k1:k2,jn) 
     703                  DO jk = 1, jpkm1 
     704                     DO jj = jmin,jmax 
     705                        IF( umask(2,jj,jk) == 0._wp ) THEN 
     706                           tsa(2,jj,jk,jn) = tsa(1,jj,jk,jn) * tmask(2,jj,jk) 
     707                        ELSE 
     708                           tsa(2,jj,jk,jn)=(z4*tsa(1,jj,jk,jn)+z3*tsa(3,jj,jk,jn))*tmask(2,jj,jk)         
     709                           IF( un(2,jj,jk) < 0._wp ) THEN 
     710                              tsa(2,jj,jk,jn)=(z6*tsa(3,jj,jk,jn)+z5*tsa(1,jj,jk,jn)+z7*tsa(4,jj,jk,jn))*tmask(2,jj,jk) 
     711                           ENDIF 
    691712                        ENDIF 
    692                      ENDIF 
     713                     END DO 
    693714                  END DO 
    694                END DO 
    695                tsa(1,j1:j2,k1:k2,jn) = 0._wp 
    696             END DO 
    697          ENDIF 
    698          ! 
    699          IF( southern_side ) THEN            
    700             DO jn = 1, jpts 
    701                tsa(i1:i2,1,k1:k2,jn) = zalpha1 * ptab(i1:i2,1,k1:k2,jn) + zalpha2 * ptab(i1:i2,2,k1:k2,jn) 
    702                DO jk = 1, jpk       
    703                   DO ji=imin,imax 
    704                      IF( vmask(ji,2,jk) == 0._wp ) THEN 
    705                         tsa(ji,2,jk,jn)=tsa(ji,1,jk,jn) * tmask(ji,2,jk) 
    706                      ELSE 
    707                         tsa(ji,2,jk,jn)=(zalpha4*tsa(ji,1,jk,jn)+zalpha3*tsa(ji,3,jk,jn))*tmask(ji,2,jk) 
    708                         IF( vn(ji,2,jk) < 0._wp ) THEN 
    709                            tsa(ji,2,jk,jn)=(zalpha6*tsa(ji,3,jk,jn)+zalpha5*tsa(ji,1,jk,jn)+zalpha7*tsa(ji,4,jk,jn))*tmask(ji,2,jk) 
     715                  tsa(1,j1:j2,k1:k2,jn) = 0._wp 
     716               END DO 
     717            ENDIF 
     718            ! 
     719            IF( southern_side ) THEN            
     720               DO jn = 1, jpts 
     721                  tsa(i1:i2,1,k1:k2,jn) = z1 * ptab(i1:i2,1,k1:k2,jn) + z2 * ptab(i1:i2,2,k1:k2,jn) 
     722                  DO jk = 1, jpk       
     723                     DO ji=imin,imax 
     724                        IF( vmask(ji,2,jk) == 0._wp ) THEN 
     725                           tsa(ji,2,jk,jn)=tsa(ji,1,jk,jn) * tmask(ji,2,jk) 
     726                        ELSE 
     727                           tsa(ji,2,jk,jn)=(z4*tsa(ji,1,jk,jn)+z3*tsa(ji,3,jk,jn))*tmask(ji,2,jk) 
     728                           IF( vn(ji,2,jk) < 0._wp ) THEN 
     729                              tsa(ji,2,jk,jn)=(z6*tsa(ji,3,jk,jn)+z5*tsa(ji,1,jk,jn)+z7*tsa(ji,4,jk,jn))*tmask(ji,2,jk) 
     730                           ENDIF 
    710731                        ENDIF 
    711                      ENDIF 
     732                     END DO 
    712733                  END DO 
    713                END DO 
    714                tsa(i1:i2,1,k1:k2,jn) = 0._wp 
    715             END DO 
    716          ENDIF 
    717          ! 
    718          ! Treatment of corners 
    719          !  
    720          ! East south 
    721          IF ((eastern_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 
    722             tsa(nlci-1,2,:,:) = ptab(nlci-1,2,:,:) 
    723          ENDIF 
    724          ! East north 
    725          IF ((eastern_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 
    726             tsa(nlci-1,nlcj-1,:,:) = ptab(nlci-1,nlcj-1,:,:) 
    727          ENDIF 
    728          ! West south 
    729          IF ((western_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 
    730             tsa(2,2,:,:) = ptab(2,2,:,:) 
    731          ENDIF 
    732          ! West north 
    733          IF ((western_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 
    734             tsa(2,nlcj-1,:,:) = ptab(2,nlcj-1,:,:) 
    735          ENDIF 
    736          ! 
     734                  tsa(i1:i2,1,k1:k2,jn) = 0._wp 
     735               END DO 
     736            ENDIF 
     737            ! 
     738            ! Treatment of corners 
     739            IF ((eastern_side).AND.((nbondj == -1).OR.(nbondj == 2)))   tsa(nlci-1,2,:,:) = ptab(nlci-1,2,:,:)            ! East south 
     740            IF ((eastern_side).AND.((nbondj ==  1).OR.(nbondj == 2)))   tsa(nlci-1,nlcj-1,:,:) = ptab(nlci-1,nlcj-1,:,:)  ! East north 
     741            IF ((western_side).AND.((nbondj == -1).OR.(nbondj == 2)))   tsa(2,2,:,:) = ptab(2,2,:,:)                      ! West south 
     742            IF ((western_side).AND.((nbondj ==  1).OR.(nbondj == 2)))   tsa(2,nlcj-1,:,:) = ptab(2,nlcj-1,:,:)            ! West north 
     743            ! 
     744         ENDIF 
    737745      ENDIF 
    738746      ! 
     
    759767         southern_side = (nb == 2).AND.(ndir == 1) 
    760768         northern_side = (nb == 2).AND.(ndir == 2) 
    761          IF(western_side)  hbdy_w(j1:j2) = ptab(i1,j1:j2) * tmask(i1,j1:j2,1) 
    762          IF(eastern_side)  hbdy_e(j1:j2) = ptab(i1,j1:j2) * tmask(i1,j1:j2,1) 
    763          IF(southern_side) hbdy_s(i1:i2) = ptab(i1:i2,j1) * tmask(i1:i2,j1,1) 
     769         !! clem ghost 
     770         IF(western_side)  hbdy_w(j1:j2) = ptab(i2,j1:j2) * tmask(i2,j1:j2,1) 
     771         IF(eastern_side)  hbdy_e(j1:j2) = ptab(i1,j1:j2) * tmask(i1,j1:j2,1) !clem previously i1 
     772         IF(southern_side) hbdy_s(i1:i2) = ptab(i1:i2,j2) * tmask(i1:i2,j2,1) !clem previously j1 
    764773         IF(northern_side) hbdy_n(i1:i2) = ptab(i1:i2,j1) * tmask(i1:i2,j1,1) 
    765774      ENDIF 
     
    854863         ELSEIF( bdy_tinterp == 2 ) THEN 
    855864            ztcoeff = zrhot * (  zt1        * (       zt1 - 1._wp)**2._wp & 
    856                &               - zt0        * (       zt0 - 1._wp)**2._wp )  
    857  
     865               &               - zt0        * (       zt0 - 1._wp)**2._wp ) 
    858866         ELSE 
    859867            ztcoeff = 1 
    860868         ENDIF 
    861          !    
    862          IF(western_side) THEN 
    863             ubdy_w(j1:j2) = ubdy_w(j1:j2) + ztcoeff * ptab(i1,j1:j2)   
    864          ENDIF 
    865          IF(eastern_side) THEN 
    866             ubdy_e(j1:j2) = ubdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2)   
    867          ENDIF 
    868          IF(southern_side) THEN 
    869             ubdy_s(i1:i2) = ubdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j1)  
    870          ENDIF 
    871          IF(northern_side) THEN 
    872             ubdy_n(i1:i2) = ubdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1)  
    873          ENDIF 
     869         !! clem ghost    
     870         IF(western_side)   ubdy_w(j1:j2) = ubdy_w(j1:j2) + ztcoeff * ptab(i2,j1:j2)   
     871         IF(eastern_side)   ubdy_e(j1:j2) = ubdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2) !clem previously i1   
     872         IF(southern_side)  ubdy_s(i1:i2) = ubdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j2) !clem previously j1 
     873         IF(northern_side)  ubdy_n(i1:i2) = ubdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1)  
    874874         !             
    875875         IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN 
    876             IF(western_side) THEN 
    877                ubdy_w(j1:j2) = ubdy_w(j1:j2) / (zrhoy*e2u(i1,j1:j2)) * umask(i1,j1:j2,1) 
    878             ENDIF 
    879             IF(eastern_side) THEN 
    880                ubdy_e(j1:j2) = ubdy_e(j1:j2) / (zrhoy*e2u(i1,j1:j2)) * umask(i1,j1:j2,1) 
    881             ENDIF 
    882             IF(southern_side) THEN 
    883                ubdy_s(i1:i2) = ubdy_s(i1:i2) / (zrhoy*e2u(i1:i2,j1)) * umask(i1:i2,j1,1) 
    884             ENDIF 
    885             IF(northern_side) THEN 
    886                ubdy_n(i1:i2) = ubdy_n(i1:i2) / (zrhoy*e2u(i1:i2,j1)) * umask(i1:i2,j1,1) 
    887             ENDIF 
     876            IF(western_side)   ubdy_w(j1:j2) = ubdy_w(j1:j2) / (zrhoy*e2u(i2,j1:j2)) * umask(i2,j1:j2,1) 
     877            IF(eastern_side)   ubdy_e(j1:j2) = ubdy_e(j1:j2) / (zrhoy*e2u(i1,j1:j2)) * umask(i1,j1:j2,1) 
     878            IF(southern_side)  ubdy_s(i1:i2) = ubdy_s(i1:i2) / (zrhoy*e2u(i1:i2,j2)) * umask(i1:i2,j2,1) 
     879            IF(northern_side)  ubdy_n(i1:i2) = ubdy_n(i1:i2) / (zrhoy*e2u(i1:i2,j1)) * umask(i1:i2,j1,1) 
    888880         ENDIF 
    889881      ENDIF 
     
    927919            ztcoeff = 1 
    928920         ENDIF 
    929          ! 
    930          IF(western_side) THEN 
    931             vbdy_w(j1:j2) = vbdy_w(j1:j2) + ztcoeff * ptab(i1,j1:j2)   
    932          ENDIF 
    933          IF(eastern_side) THEN 
    934             vbdy_e(j1:j2) = vbdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2)   
    935          ENDIF 
    936          IF(southern_side) THEN 
    937             vbdy_s(i1:i2) = vbdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j1) 
    938          ENDIF 
    939          IF(northern_side) THEN 
    940             vbdy_n(i1:i2) = vbdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1)  
    941          ENDIF 
     921         !! clem ghost 
     922         IF(western_side)   vbdy_w(j1:j2) = vbdy_w(j1:j2) + ztcoeff * ptab(i2,j1:j2)   
     923         IF(eastern_side)   vbdy_e(j1:j2) = vbdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2) !clem previously i1   
     924         IF(southern_side)  vbdy_s(i1:i2) = vbdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j2) !clem previously j1 
     925         IF(northern_side)  vbdy_n(i1:i2) = vbdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1)  
    942926         !             
    943927         IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN 
    944             IF(western_side) THEN 
    945                vbdy_w(j1:j2) = vbdy_w(j1:j2) / (zrhox*e1v(i1,j1:j2))   & 
    946                      &                                  * vmask(i1,j1:j2,1) 
    947             ENDIF 
    948             IF(eastern_side) THEN 
    949                vbdy_e(j1:j2) = vbdy_e(j1:j2) / (zrhox*e1v(i1,j1:j2))   & 
    950                      &                                  * vmask(i1,j1:j2,1) 
    951             ENDIF 
    952             IF(southern_side) THEN 
    953                vbdy_s(i1:i2) = vbdy_s(i1:i2) / (zrhox*e1v(i1:i2,j1))   & 
    954                      &                                  * vmask(i1:i2,j1,1) 
    955             ENDIF 
    956             IF(northern_side) THEN 
    957                vbdy_n(i1:i2) = vbdy_n(i1:i2) / (zrhox*e1v(i1:i2,j1))   & 
    958                      &                                  * vmask(i1:i2,j1,1) 
    959             ENDIF 
     928            IF(western_side)   vbdy_w(j1:j2) = vbdy_w(j1:j2) / (zrhox*e1v(i2,j1:j2)) * vmask(i2,j1:j2,1) 
     929            IF(eastern_side)   vbdy_e(j1:j2) = vbdy_e(j1:j2) / (zrhox*e1v(i1,j1:j2)) * vmask(i1,j1:j2,1) 
     930            IF(southern_side)  vbdy_s(i1:i2) = vbdy_s(i1:i2) / (zrhox*e1v(i1:i2,j2)) * vmask(i1:i2,j2,1) 
     931            IF(northern_side)  vbdy_n(i1:i2) = vbdy_n(i1:i2) / (zrhox*e1v(i1:i2,j1)) * vmask(i1:i2,j1,1) 
    960932         ENDIF 
    961933      ENDIF 
     
    991963         zat = zrhot * (  zt1**2._wp * (-2._wp*zt1 + 3._wp)    & 
    992964            &           - zt0**2._wp * (-2._wp*zt0 + 3._wp)    )  
    993          !  
    994          IF(western_side ) ubdy_w(j1:j2) = zat * ptab(i1,j1:j2)   
    995          IF(eastern_side ) ubdy_e(j1:j2) = zat * ptab(i1,j1:j2)  
    996          IF(southern_side) ubdy_s(i1:i2) = zat * ptab(i1:i2,j1)  
     965         !! clem ghost 
     966         IF(western_side ) ubdy_w(j1:j2) = zat * ptab(i2,j1:j2)   
     967         IF(eastern_side ) ubdy_e(j1:j2) = zat * ptab(i1,j1:j2) !clem previously i1  
     968         IF(southern_side) ubdy_s(i1:i2) = zat * ptab(i1:i2,j2) !clem previously j1 
    997969         IF(northern_side) ubdy_n(i1:i2) = zat * ptab(i1:i2,j1)  
    998970      ENDIF 
     
    10301002            &           - zt0**2._wp * (-2._wp*zt0 + 3._wp)    )  
    10311003         ! 
    1032          IF(western_side )   vbdy_w(j1:j2) = zat * ptab(i1,j1:j2)   
    1033          IF(eastern_side )   vbdy_e(j1:j2) = zat * ptab(i1,j1:j2)  
    1034          IF(southern_side)   vbdy_s(i1:i2) = zat * ptab(i1:i2,j1)  
     1004         IF(western_side )   vbdy_w(j1:j2) = zat * ptab(i2,j1:j2)   
     1005         IF(eastern_side )   vbdy_e(j1:j2) = zat * ptab(i1,j1:j2) !clem previously i1  
     1006         IF(southern_side)   vbdy_s(i1:i2) = zat * ptab(i1:i2,j2) !clem previously j1  
    10351007         IF(northern_side)   vbdy_n(i1:i2) = zat * ptab(i1:i2,j1)  
    10361008      ENDIF 
     
    10501022      INTEGER :: ji, jj, jk 
    10511023      LOGICAL :: western_side, eastern_side, northern_side, southern_side 
    1052       REAL(wp) :: ztmpmsk       
    10531024      !!----------------------------------------------------------------------   
    10541025      !     
     
    10601031         southern_side = (nb == 2).AND.(ndir == 1) 
    10611032         northern_side = (nb == 2).AND.(ndir == 2) 
    1062  
     1033         ! 
    10631034         DO jk = k1, k2 
    10641035            DO jj = j1, j2 
    10651036               DO ji = i1, i2 
    1066                   ! Get velocity mask at boundary edge points: 
    1067                   IF( western_side )   ztmpmsk = umask(ji    ,jj    ,1) 
    1068                   IF( eastern_side )   ztmpmsk = umask(nlci-2,jj    ,1) 
    1069                   IF( northern_side)   ztmpmsk = vmask(ji    ,nlcj-2,1) 
    1070                   IF( southern_side)   ztmpmsk = vmask(ji    ,2     ,1) 
    10711037                  ! 
    1072                   IF( ABS( ptab(ji,jj,jk) - tmask(ji,jj,jk) * e3t_0(ji,jj,jk) )*ztmpmsk > 1.D-2) THEN 
     1038                  IF( ABS( ptab(ji,jj,jk) - tmask(ji,jj,jk) * e3t_0(ji,jj,jk) ) > 1.D-2) THEN 
    10731039                     IF (western_side) THEN 
    10741040                        WRITE(numout,*) 'ERROR bathymetry merge at the western border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 
  • branches/2017/dev_r8183_ICEMODEL/NEMOGCM/NEMO/NST_SRC/agrif_opa_sponge.F90

    r7646 r8226  
    3434      !!   *** ROUTINE Agrif_Sponge_Tra *** 
    3535      !!--------------------------------------------- 
    36       REAL(wp) :: timecoeff 
     36      REAL(wp) :: zcoef 
    3737      !!--------------------------------------------- 
    3838      ! 
    3939#if defined SPONGE 
    40       timecoeff = REAL(Agrif_NbStepint(),wp)/Agrif_rhot() 
     40      zcoef = REAL(Agrif_NbStepint(),wp)/Agrif_rhot() 
    4141 
    4242      CALL Agrif_Sponge 
     
    4545      tabspongedone_tsn = .FALSE. 
    4646 
    47       CALL Agrif_Bc_Variable(tsn_sponge_id,calledweight=timecoeff,procname=interptsn_sponge) 
     47      CALL Agrif_Bc_Variable(tsn_sponge_id,calledweight=zcoef,procname=interptsn_sponge) 
    4848 
    4949      Agrif_UseSpecialValue = .FALSE. 
     
    5757      !!   *** ROUTINE Agrif_Sponge_dyn *** 
    5858      !!--------------------------------------------- 
    59       REAL(wp) :: timecoeff 
     59      REAL(wp) :: zcoef 
    6060      !!--------------------------------------------- 
    6161 
    6262#if defined SPONGE 
    63       timecoeff = REAL(Agrif_NbStepint(),wp)/Agrif_rhot() 
     63      zcoef = REAL(Agrif_NbStepint(),wp)/Agrif_rhot() 
    6464 
    6565      Agrif_SpecialValue=0. 
     
    6868      tabspongedone_u = .FALSE. 
    6969      tabspongedone_v = .FALSE.          
    70       CALL Agrif_Bc_Variable(un_sponge_id,calledweight=timecoeff,procname=interpun_sponge) 
     70      CALL Agrif_Bc_Variable(un_sponge_id,calledweight=zcoef,procname=interpun_sponge) 
    7171 
    7272      tabspongedone_u = .FALSE. 
    7373      tabspongedone_v = .FALSE. 
    74       CALL Agrif_Bc_Variable(vn_sponge_id,calledweight=timecoeff,procname=interpvn_sponge) 
     74      CALL Agrif_Bc_Variable(vn_sponge_id,calledweight=zcoef,procname=interpvn_sponge) 
    7575 
    7676      Agrif_UseSpecialValue = .FALSE. 
     
    8484      !!   *** ROUTINE  Agrif_Sponge *** 
    8585      !!--------------------------------------------- 
    86       INTEGER  :: ji,jj,jk 
    87       INTEGER  :: ispongearea, ilci, ilcj 
    88       LOGICAL  :: ll_spdone 
    89       REAL(wp) :: z1spongearea, zramp 
    90       REAL(wp), POINTER, DIMENSION(:,:) :: ztabramp 
     86      REAL(wp), DIMENSION(jpi,jpj) :: ztabramp 
     87      ! 
     88      INTEGER  :: ji, jj, ind1, ind2 
     89      INTEGER  :: ispongearea 
     90      REAL(wp) :: z1_spongearea 
     91      !!--------------------------------------------- 
    9192 
    9293#if defined SPONGE || defined SPONGE_TOP 
    93       ll_spdone=.TRUE. 
    9494      IF (( .NOT. spongedoneT ).OR.( .NOT. spongedoneU )) THEN 
    95          ! Define ramp from boundaries towards domain interior 
    96          ! at T-points 
     95         ! Define ramp from boundaries towards domain interior at T-points 
    9796         ! Store it in ztabramp 
    98          ll_spdone=.FALSE. 
    99  
    100          CALL wrk_alloc( jpi, jpj, ztabramp ) 
    10197 
    10298         ispongearea  = 2 + nn_sponge_len * Agrif_irhox() 
    103          ilci = nlci - ispongearea 
    104          ilcj = nlcj - ispongearea  
    105          z1spongearea = 1._wp / REAL( ispongearea - 2 ) 
    106  
     99         z1_spongearea = 1._wp / REAL( ispongearea - 1 ) 
     100          
    107101         ztabramp(:,:) = 0._wp 
    108102 
     103         ! --- West --- ! 
    109104         IF( (nbondi == -1) .OR. (nbondi == 2) ) THEN 
     105            ind1 = 1+nbghostcells 
     106            ind2 = 1+nbghostcells + (ispongearea-1) 
    110107            DO jj = 1, jpj 
    111                IF ( umask(2,jj,1) == 1._wp ) THEN 
    112                  DO ji = 2, ispongearea                   
    113                     ztabramp(ji,jj) = ( ispongearea-ji ) * z1spongearea 
    114                  END DO 
    115                ENDIF 
     108               DO ji = ind1, ind2                   
     109                  ztabramp(ji,jj) = REAL( ind2 - ji ) * z1_spongearea * umask(ind1,jj,1) 
     110               END DO 
    116111            ENDDO 
    117112         ENDIF 
    118113 
     114         ! --- East --- ! 
    119115         IF( (nbondi == 1) .OR. (nbondi == 2) ) THEN 
     116            ind1 = nlci - (1+nbghostcells) - (ispongearea-1) 
     117            ind2 = nlci - (1+nbghostcells) 
    120118            DO jj = 1, jpj 
    121                IF ( umask(nlci-2,jj,1) == 1._wp ) THEN 
    122                   DO ji = ilci+1,nlci-1 
    123                      zramp = (ji - (ilci+1) ) * z1spongearea 
    124                      ztabramp(ji,jj) = MAX( ztabramp(ji,jj), zramp ) 
    125                   ENDDO 
    126                ENDIF 
     119               DO ji = ind1, ind2 
     120                  ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( ji - ind2 ) * z1_spongearea * umask(ind2-1,jj,1) ) 
     121               ENDDO 
    127122            ENDDO 
    128123         ENDIF 
    129124 
     125         ! --- South --- ! 
    130126         IF( (nbondj == -1) .OR. (nbondj == 2) ) THEN 
    131             DO ji = 1, jpi 
    132                IF ( vmask(ji,2,1) == 1._wp ) THEN 
    133                   DO jj = 2, ispongearea 
    134                      zramp = ( ispongearea-jj ) * z1spongearea 
    135                      ztabramp(ji,jj) = MAX( ztabramp(ji,jj), zramp ) 
    136                   END DO 
    137                ENDIF 
     127            ind1 = 1+nbghostcells 
     128            ind2 = 1+nbghostcells + (ispongearea-1) 
     129            DO jj = ind1, ind2 
     130               DO ji = 1, jpi 
     131                  ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( ind2 - jj ) * z1_spongearea * vmask(ji,ind1,1) ) 
     132               END DO 
    138133            ENDDO 
    139134         ENDIF 
    140135 
     136         ! --- North --- ! 
    141137         IF( (nbondj == 1) .OR. (nbondj == 2) ) THEN 
    142             DO ji = 1, jpi 
    143                IF ( vmask(ji,nlcj-2,1) == 1._wp ) THEN 
    144                   DO jj = ilcj+1,nlcj-1 
    145                      zramp = (jj - (ilcj+1) ) * z1spongearea 
    146                      ztabramp(ji,jj) = MAX( ztabramp(ji,jj), zramp ) 
    147                   END DO 
    148                ENDIF 
     138            ind1 = nlcj - (1+nbghostcells) - (ispongearea-1) 
     139            ind2 = nlcj - (1+nbghostcells) 
     140            DO jj = ind1, ind2 
     141               DO ji = 1, jpi 
     142                  ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( jj - ind2 ) * z1_spongearea * vmask(ji,ind2-1,1) ) 
     143               END DO 
    149144            ENDDO 
    150145         ENDIF 
     
    158153         DO jj = 2, jpjm1 
    159154            DO ji = 2, jpim1   ! vector opt. 
    160                fsaht_spu(ji,jj) = 0.5_wp * visc_tra * (ztabramp(ji,jj) + ztabramp(ji+1,jj  )) 
    161                fsaht_spv(ji,jj) = 0.5_wp * visc_tra * (ztabramp(ji,jj) + ztabramp(ji  ,jj+1)) 
    162             END DO 
    163          END DO 
    164  
     155               fsaht_spu(ji,jj) = 0.5_wp * visc_tra * ( ztabramp(ji,jj) + ztabramp(ji+1,jj  ) ) 
     156               fsaht_spv(ji,jj) = 0.5_wp * visc_tra * ( ztabramp(ji,jj) + ztabramp(ji  ,jj+1) ) 
     157            END DO 
     158         END DO 
    165159         CALL lbc_lnk( fsaht_spu, 'U', 1. )   ! Lateral boundary conditions 
    166160         CALL lbc_lnk( fsaht_spv, 'V', 1. ) 
     161          
    167162         spongedoneT = .TRUE. 
    168163      ENDIF 
     
    179174            END DO 
    180175         END DO 
    181  
    182176         CALL lbc_lnk( fsahm_spt, 'T', 1. )   ! Lateral boundary conditions 
    183177         CALL lbc_lnk( fsahm_spf, 'F', 1. ) 
     178          
    184179         spongedoneU = .TRUE. 
    185180      ENDIF 
    186       ! 
    187       IF (.NOT.ll_spdone) CALL wrk_dealloc( jpi, jpj, ztabramp ) 
    188181      ! 
    189182#endif 
     
    205198      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: ztu, ztv 
    206199      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2) ::tsbdiff 
     200      !!---------------------------------------------     
    207201      ! 
    208202      IF( before ) THEN 
     
    327321 
    328322         jmax = j2-1 
    329          IF ((nbondj == 1).OR.(nbondj == 2)) jmax = MIN(jmax,nlcj-3) 
     323         IF ((nbondj == 1).OR.(nbondj == 2)) jmax = MIN(jmax,nlcj-nbghostcells-2)   ! North 
    330324 
    331325         DO jj = j1+1, jmax 
     
    404398 
    405399         imax = i2-1 
    406          IF ((nbondi == 1).OR.(nbondi == 2))   imax = MIN(imax,nlci-3) 
     400         IF ((nbondi == 1).OR.(nbondi == 2))   imax = MIN(imax,nlci-nbghostcells-2)   ! East 
    407401 
    408402         DO jj = j1+1, j2 
  • branches/2017/dev_r8183_ICEMODEL/NEMOGCM/NEMO/NST_SRC/agrif_top_interp.F90

    r6140 r8226  
    5050      ! 
    5151      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    52       INTEGER :: imin, imax, jmin, jmax 
    53       REAL(wp) ::   zrhox , zalpha1, zalpha2, zalpha3 
    54       REAL(wp) ::   zalpha4, zalpha5, zalpha6, zalpha7 
    55       LOGICAL :: western_side, eastern_side,northern_side,southern_side 
    56  
     52      INTEGER  ::  imin, imax, jmin, jmax 
     53      REAL(wp) ::   zrhox, z1, z2, z3, z4, z5, z6, z7 
     54      LOGICAL  ::   western_side, eastern_side,northern_side,southern_side 
     55      !!----------------------------------------------------------------------- 
     56      ! 
    5757      IF (before) THEN          
    5858         ptab(i1:i2,j1:j2,k1:k2,n1:n2) = trn(i1:i2,j1:j2,k1:k2,n1:n2) 
    5959      ELSE 
    6060         ! 
    61          western_side  = (nb == 1).AND.(ndir == 1) 
    62          eastern_side  = (nb == 1).AND.(ndir == 2) 
    63          southern_side = (nb == 2).AND.(ndir == 1) 
    64          northern_side = (nb == 2).AND.(ndir == 2) 
    65          ! 
    66          zrhox = Agrif_Rhox() 
    67          !  
    68          zalpha1 = ( zrhox - 1. ) * 0.5 
    69          zalpha2 = 1. - zalpha1 
    70          !  
    71          zalpha3 = ( zrhox - 1. ) / ( zrhox + 1. ) 
    72          zalpha4 = 1. - zalpha3 
    73          !  
    74          zalpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 
    75          zalpha7 =    - ( zrhox - 1. ) / ( zrhox + 3. ) 
    76          zalpha5 = 1. - zalpha6 - zalpha7 
    77          ! 
    78          imin = i1 
    79          imax = i2 
    80          jmin = j1 
    81          jmax = j2 
    82          !  
    83          ! Remove CORNERS 
    84          IF((nbondj == -1).OR.(nbondj == 2)) jmin = 3 
    85          IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj-2 
    86          IF((nbondi == -1).OR.(nbondi == 2)) imin = 3 
    87          IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci-2         
    88          ! 
    89          IF( eastern_side) THEN 
    90             DO jn = 1, jptra 
    91                tra(nlci,j1:j2,k1:k2,jn) = zalpha1 * ptab(nlci,j1:j2,k1:k2,jn) + zalpha2 * ptab(nlci-1,j1:j2,k1:k2,jn) 
    92                DO jk = 1, jpkm1 
    93                   DO jj = jmin,jmax 
    94                      IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN 
    95                         tra(nlci-1,jj,jk,jn) = tra(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 
    96                      ELSE 
    97                         tra(nlci-1,jj,jk,jn)=(zalpha4*tra(nlci,jj,jk,jn)+zalpha3*tra(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 
    98                         IF( un(nlci-2,jj,jk) > 0.e0 ) THEN 
    99                            tra(nlci-1,jj,jk,jn)=( zalpha6*tra(nlci-2,jj,jk,jn)+zalpha5*tra(nlci,jj,jk,jn) &  
    100                                  + zalpha7*tra(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 
     61         IF( nbghostcells > 1 ) THEN  ! no smoothing 
     62            tra(i1:i2,j1:j2,k1:k2,n1:n2) = ptab(i1:i2,j1:j2,k1:k2,n1:n2) 
     63         ELSE                         ! smoothing 
     64            ! 
     65            western_side  = (nb == 1).AND.(ndir == 1)  ;  eastern_side  = (nb == 1).AND.(ndir == 2) 
     66            southern_side = (nb == 2).AND.(ndir == 1)  ;  northern_side = (nb == 2).AND.(ndir == 2) 
     67            ! 
     68            zrhox = Agrif_Rhox() 
     69            z1 = ( zrhox - 1. ) * 0.5 
     70            z3 = ( zrhox - 1. ) / ( zrhox + 1. ) 
     71            z6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 
     72            z7 =    - ( zrhox - 1. ) / ( zrhox + 3. ) 
     73            ! 
     74            z2 = 1. - z1 
     75            z4 = 1. - z3 
     76            z5 = 1. - z6 - z7 
     77            ! 
     78            imin = i1 ; imax = i2 
     79            jmin = j1 ; jmax = j2 
     80            !  
     81            ! Remove CORNERS 
     82            IF((nbondj == -1).OR.(nbondj == 2)) jmin = 3 
     83            IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj-2 
     84            IF((nbondi == -1).OR.(nbondi == 2)) imin = 3 
     85            IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci-2         
     86            ! 
     87            IF( eastern_side) THEN 
     88               DO jn = 1, jptra 
     89                  tra(nlci,j1:j2,k1:k2,jn) = z1 * ptab(nlci,j1:j2,k1:k2,jn) + z2 * ptab(nlci-1,j1:j2,k1:k2,jn) 
     90                  DO jk = 1, jpkm1 
     91                     DO jj = jmin,jmax 
     92                        IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN 
     93                           tra(nlci-1,jj,jk,jn) = tra(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 
     94                        ELSE 
     95                           tra(nlci-1,jj,jk,jn)=(z4*tra(nlci,jj,jk,jn)+z3*tra(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 
     96                           IF( un(nlci-2,jj,jk) > 0.e0 ) THEN 
     97                              tra(nlci-1,jj,jk,jn)=( z6*tra(nlci-2,jj,jk,jn)+z5*tra(nlci,jj,jk,jn) &  
     98                                                   + z7*tra(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 
     99                           ENDIF 
    101100                        ENDIF 
    102                      ENDIF 
     101                     END DO 
     102                  END DO 
     103               ENDDO 
     104            ENDIF 
     105            !  
     106            IF( northern_side ) THEN             
     107               DO jn = 1, jptra 
     108                  tra(i1:i2,nlcj,k1:k2,jn) = z1 * ptab(i1:i2,nlcj,k1:k2,jn) + z2 * ptab(i1:i2,nlcj-1,k1:k2,jn) 
     109                  DO jk = 1, jpkm1 
     110                     DO ji = imin,imax 
     111                        IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN 
     112                           tra(ji,nlcj-1,jk,jn) = tra(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 
     113                        ELSE 
     114                           tra(ji,nlcj-1,jk,jn)=(z4*tra(ji,nlcj,jk,jn)+z3*tra(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk)         
     115                           IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN 
     116                              tra(ji,nlcj-1,jk,jn)=( z6*tra(ji,nlcj-2,jk,jn)+z5*tra(ji,nlcj,jk,jn)  & 
     117                                                   + z7*tra(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 
     118                           ENDIF 
     119                        ENDIF 
     120                     END DO 
     121                  END DO 
     122               ENDDO 
     123            ENDIF 
     124            ! 
     125            IF( western_side) THEN             
     126               DO jn = 1, jptra 
     127                  tra(1,j1:j2,k1:k2,jn) = z1 * ptab(1,j1:j2,k1:k2,jn) + z2 * ptab(2,j1:j2,k1:k2,jn) 
     128                  DO jk = 1, jpkm1 
     129                     DO jj = jmin,jmax 
     130                        IF( umask(2,jj,jk) == 0.e0 ) THEN 
     131                           tra(2,jj,jk,jn) = tra(1,jj,jk,jn) * tmask(2,jj,jk) 
     132                        ELSE 
     133                           tra(2,jj,jk,jn)=(z4*tra(1,jj,jk,jn)+z3*tra(3,jj,jk,jn))*tmask(2,jj,jk)         
     134                           IF( un(2,jj,jk) < 0.e0 ) THEN 
     135                              tra(2,jj,jk,jn)=(z6*tra(3,jj,jk,jn)+z5*tra(1,jj,jk,jn)+z7*tra(4,jj,jk,jn))*tmask(2,jj,jk) 
     136                           ENDIF 
     137                        ENDIF 
     138                     END DO 
    103139                  END DO 
    104140               END DO 
    105             ENDDO 
     141            ENDIF 
     142            ! 
     143            IF( southern_side ) THEN            
     144               DO jn = 1, jptra 
     145                  tra(i1:i2,1,k1:k2,jn) = z1 * ptab(i1:i2,1,k1:k2,jn) + z2 * ptab(i1:i2,2,k1:k2,jn) 
     146                  DO jk=1,jpk       
     147                     DO ji=imin,imax 
     148                        IF( vmask(ji,2,jk) == 0.e0 ) THEN 
     149                           tra(ji,2,jk,jn)=tra(ji,1,jk,jn) * tmask(ji,2,jk) 
     150                        ELSE 
     151                           tra(ji,2,jk,jn)=(z4*tra(ji,1,jk,jn)+z3*tra(ji,3,jk,jn))*tmask(ji,2,jk) 
     152                           IF( vn(ji,2,jk) < 0.e0 ) THEN 
     153                              tra(ji,2,jk,jn)=(z6*tra(ji,3,jk,jn)+z5*tra(ji,1,jk,jn)+z7*tra(ji,4,jk,jn))*tmask(ji,2,jk) 
     154                           ENDIF 
     155                        ENDIF 
     156                     END DO 
     157                  END DO 
     158               ENDDO 
     159            ENDIF 
     160            ! 
     161            ! Treatment of corners 
     162            IF ((eastern_side).AND.((nbondj == -1).OR.(nbondj == 2)))  tra(nlci-1,2,:,:) = ptab(nlci-1,2,:,:)            ! East south 
     163            IF ((eastern_side).AND.((nbondj ==  1).OR.(nbondj == 2)))  tra(nlci-1,nlcj-1,:,:) = ptab(nlci-1,nlcj-1,:,:)  ! East north 
     164            IF ((western_side).AND.((nbondj == -1).OR.(nbondj == 2)))  tra(2,2,:,:) = ptab(2,2,:,:)                      ! West south 
     165            IF ((western_side).AND.((nbondj ==  1).OR.(nbondj == 2)))  tra(2,nlcj-1,:,:) = ptab(2,nlcj-1,:,:)            ! West north 
     166            ! 
    106167         ENDIF 
    107          !  
    108          IF( northern_side ) THEN             
    109             DO jn = 1, jptra 
    110                tra(i1:i2,nlcj,k1:k2,jn) = zalpha1 * ptab(i1:i2,nlcj,k1:k2,jn) + zalpha2 * ptab(i1:i2,nlcj-1,k1:k2,jn) 
    111                DO jk = 1, jpkm1 
    112                   DO ji = imin,imax 
    113                      IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN 
    114                         tra(ji,nlcj-1,jk,jn) = tra(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 
    115                      ELSE 
    116                         tra(ji,nlcj-1,jk,jn)=(zalpha4*tra(ji,nlcj,jk,jn)+zalpha3*tra(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk)         
    117                         IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN 
    118                            tra(ji,nlcj-1,jk,jn)=( zalpha6*tra(ji,nlcj-2,jk,jn)+zalpha5*tra(ji,nlcj,jk,jn)  & 
    119                                  + zalpha7*tra(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 
    120                         ENDIF 
    121                      ENDIF 
    122                   END DO 
    123                END DO 
    124             ENDDO 
    125          ENDIF 
    126          ! 
    127          IF( western_side) THEN             
    128             DO jn = 1, jptra 
    129                tra(1,j1:j2,k1:k2,jn) = zalpha1 * ptab(1,j1:j2,k1:k2,jn) + zalpha2 * ptab(2,j1:j2,k1:k2,jn) 
    130                DO jk = 1, jpkm1 
    131                   DO jj = jmin,jmax 
    132                      IF( umask(2,jj,jk) == 0.e0 ) THEN 
    133                         tra(2,jj,jk,jn) = tra(1,jj,jk,jn) * tmask(2,jj,jk) 
    134                      ELSE 
    135                         tra(2,jj,jk,jn)=(zalpha4*tra(1,jj,jk,jn)+zalpha3*tra(3,jj,jk,jn))*tmask(2,jj,jk)         
    136                         IF( un(2,jj,jk) < 0.e0 ) THEN 
    137                            tra(2,jj,jk,jn)=(zalpha6*tra(3,jj,jk,jn)+zalpha5*tra(1,jj,jk,jn)+zalpha7*tra(4,jj,jk,jn))*tmask(2,jj,jk) 
    138                         ENDIF 
    139                      ENDIF 
    140                   END DO 
    141                END DO 
    142             END DO 
    143          ENDIF 
    144          ! 
    145          IF( southern_side ) THEN            
    146             DO jn = 1, jptra 
    147                tra(i1:i2,1,k1:k2,jn) = zalpha1 * ptab(i1:i2,1,k1:k2,jn) + zalpha2 * ptab(i1:i2,2,k1:k2,jn) 
    148                DO jk=1,jpk       
    149                   DO ji=imin,imax 
    150                      IF( vmask(ji,2,jk) == 0.e0 ) THEN 
    151                         tra(ji,2,jk,jn)=tra(ji,1,jk,jn) * tmask(ji,2,jk) 
    152                      ELSE 
    153                         tra(ji,2,jk,jn)=(zalpha4*tra(ji,1,jk,jn)+zalpha3*tra(ji,3,jk,jn))*tmask(ji,2,jk) 
    154                         IF( vn(ji,2,jk) < 0.e0 ) THEN 
    155                            tra(ji,2,jk,jn)=(zalpha6*tra(ji,3,jk,jn)+zalpha5*tra(ji,1,jk,jn)+zalpha7*tra(ji,4,jk,jn))*tmask(ji,2,jk) 
    156                         ENDIF 
    157                      ENDIF 
    158                   END DO 
    159                END DO 
    160             ENDDO 
    161          ENDIF 
    162          ! 
    163          ! Treatment of corners 
    164          !  
    165          ! East south 
    166          IF ((eastern_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 
    167             tra(nlci-1,2,:,:) = ptab(nlci-1,2,:,:) 
    168          ENDIF 
    169          ! East north 
    170          IF ((eastern_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 
    171             tra(nlci-1,nlcj-1,:,:) = ptab(nlci-1,nlcj-1,:,:) 
    172          ENDIF 
    173          ! West south 
    174          IF ((western_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 
    175             tra(2,2,:,:) = ptab(2,2,:,:) 
    176          ENDIF 
    177          ! West north 
    178          IF ((western_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 
    179             tra(2,nlcj-1,:,:) = ptab(2,nlcj-1,:,:) 
    180          ENDIF 
    181          ! 
    182168      ENDIF 
    183169      ! 
  • branches/2017/dev_r8183_ICEMODEL/NEMOGCM/NEMO/NST_SRC/agrif_user.F90

    r7761 r8226  
    127127   !! 
    128128   IMPLICIT NONE 
     129   ! 
     130   INTEGER :: ind1, ind2, ind3 
    129131   !!---------------------------------------------------------------------- 
    130132 
    131133   ! 1. Declaration of the type of variable which have to be interpolated 
    132134   !--------------------------------------------------------------------- 
    133    CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),e1u_id) 
    134    CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),e2v_id) 
     135   !!clem ghost 
     136   ind1 =     nbghostcells 
     137   ind2 = 1 + nbghostcells 
     138   ind3 = 2 + nbghostcells 
     139   CALL agrif_declare_variable((/1,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),e1u_id) 
     140   CALL agrif_declare_variable((/2,1/),(/ind3,ind2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),e2v_id) 
     141   !!clem ghost 
    135142 
    136143   ! 2. Type of interpolation 
     
    141148   ! 3. Location of interpolation 
    142149   !----------------------------- 
    143    CALL Agrif_Set_bc(e1u_id,(/0,0/)) 
    144    CALL Agrif_Set_bc(e2v_id,(/0,0/)) 
     150   !!clem ghost (previously set to /0,0/) 
     151   CALL Agrif_Set_bc(e1u_id,(/0,ind1-1/)) 
     152   CALL Agrif_Set_bc(e2v_id,(/0,ind1-1/)) 
     153   !!clem ghost 
    145154 
    146155   ! 5. Update type 
     
    337346   !!---------------------------------------------------------------------- 
    338347   USE agrif_util 
    339    USE par_oce       !   ONLY : jpts 
     348   USE par_oce       !   ONLY : jpts and ghostcells 
    340349   USE oce 
    341350   USE agrif_oce 
    342351   !! 
    343352   IMPLICIT NONE 
     353   ! 
     354   INTEGER :: ind1, ind2, ind3 
    344355   !!---------------------------------------------------------------------- 
    345356 
    346357   ! 1. Declaration of the type of variable which have to be interpolated 
    347358   !--------------------------------------------------------------------- 
    348    CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts/),tsn_id) 
    349    CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts/),tsn_sponge_id) 
    350  
    351    CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),un_interp_id) 
    352    CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vn_interp_id) 
    353    CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),un_update_id) 
    354    CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vn_update_id) 
    355    CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),un_sponge_id) 
    356    CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vn_sponge_id) 
    357  
    358    CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),e3t_id) 
    359    CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),umsk_id) 
    360    CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vmsk_id) 
    361  
    362    CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,3/),scales_t_id) 
    363  
    364    CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),unb_id) 
    365    CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vnb_id) 
    366    CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ub2b_interp_id) 
    367    CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vb2b_interp_id) 
    368    CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ub2b_update_id) 
    369    CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vb2b_update_id) 
    370  
    371    CALL agrif_declare_variable((/2,2/),(/3,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),sshn_id) 
     359   !!clem ghost 
     360   ind1 =     nbghostcells 
     361   ind2 = 1 + nbghostcells 
     362   ind3 = 2 + nbghostcells 
     363   CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts/),tsn_id) 
     364   CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts/),tsn_sponge_id) 
     365 
     366   CALL agrif_declare_variable((/1,2,0/),(/ind2,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),un_interp_id) 
     367   CALL agrif_declare_variable((/2,1,0/),(/ind3,ind2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vn_interp_id) 
     368   CALL agrif_declare_variable((/1,2,0/),(/ind2,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),un_update_id) 
     369   CALL agrif_declare_variable((/2,1,0/),(/ind3,ind2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vn_update_id) 
     370   CALL agrif_declare_variable((/1,2,0/),(/ind2,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),un_sponge_id) 
     371   CALL agrif_declare_variable((/2,1,0/),(/ind3,ind2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vn_sponge_id) 
     372 
     373   CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),e3t_id) 
     374   CALL agrif_declare_variable((/1,2,0/),(/ind2,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),umsk_id) 
     375   CALL agrif_declare_variable((/2,1,0/),(/ind3,ind2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vmsk_id) 
     376 
     377   CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,3/),scales_t_id) 
     378 
     379   CALL agrif_declare_variable((/1,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),unb_id) 
     380   CALL agrif_declare_variable((/2,1/),(/ind3,ind2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vnb_id) 
     381   CALL agrif_declare_variable((/1,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ub2b_interp_id) 
     382   CALL agrif_declare_variable((/2,1/),(/ind3,ind2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vb2b_interp_id) 
     383   CALL agrif_declare_variable((/1,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ub2b_update_id) 
     384   CALL agrif_declare_variable((/2,1/),(/ind3,ind2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vb2b_update_id) 
     385 
     386   CALL agrif_declare_variable((/2,2/),(/ind3,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),sshn_id) 
    372387 
    373388# if defined key_zdftke 
    374    CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/), en_id) 
    375    CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avt_id) 
    376    CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avm_id) 
     389   CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/), en_id) 
     390   CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avt_id) 
     391   CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avm_id) 
    377392# endif 
     393   !!clem ghost 
    378394 
    379395   ! 2. Type of interpolation 
     
    407423   ! 3. Location of interpolation 
    408424   !----------------------------- 
    409    CALL Agrif_Set_bc(tsn_id,(/0,1/)) 
    410    CALL Agrif_Set_bc(un_interp_id,(/0,1/)) 
    411    CALL Agrif_Set_bc(vn_interp_id,(/0,1/)) 
    412  
    413 !   CALL Agrif_Set_bc(tsn_sponge_id,(/-3*Agrif_irhox(),0/)) 
    414 !   CALL Agrif_Set_bc(un_sponge_id,(/-2*Agrif_irhox()-1,0/)) 
    415 !   CALL Agrif_Set_bc(vn_sponge_id,(/-2*Agrif_irhox()-1,0/)) 
    416    CALL Agrif_Set_bc(tsn_sponge_id,(/-nn_sponge_len*Agrif_irhox()-1,0/)) 
     425   !!clem ghost 
     426   CALL Agrif_Set_bc(tsn_id,(/0,ind1/)) 
     427   CALL Agrif_Set_bc(un_interp_id,(/0,ind1/)) 
     428   CALL Agrif_Set_bc(vn_interp_id,(/0,ind1/)) 
     429 
     430   ! clem: previously set to /-,0/ 
     431   CALL Agrif_Set_bc(tsn_sponge_id,(/-nn_sponge_len*Agrif_irhox()-1,0/))  ! if west and rhox=3 and sponge=2 and ghost=1: columns 2 to 9  
    417432   CALL Agrif_Set_bc(un_sponge_id ,(/-nn_sponge_len*Agrif_irhox()-1,0/)) 
    418433   CALL Agrif_Set_bc(vn_sponge_id ,(/-nn_sponge_len*Agrif_irhox()-1,0/)) 
    419434 
    420    CALL Agrif_Set_bc(sshn_id,(/0,0/)) 
    421    CALL Agrif_Set_bc(unb_id ,(/0,0/)) 
    422    CALL Agrif_Set_bc(vnb_id ,(/0,0/)) 
    423    CALL Agrif_Set_bc(ub2b_interp_id,(/0,0/)) 
    424    CALL Agrif_Set_bc(vb2b_interp_id,(/0,0/)) 
    425  
    426    CALL Agrif_Set_bc(e3t_id,(/-2*Agrif_irhox()-1,0/))   ! if west and rhox=3: column 2 to 9 
    427    CALL Agrif_Set_bc(umsk_id,(/0,0/)) 
    428    CALL Agrif_Set_bc(vmsk_id,(/0,0/)) 
    429  
     435   CALL Agrif_Set_bc(sshn_id,(/0,ind1-1/)) 
     436   CALL Agrif_Set_bc(unb_id ,(/0,ind1-1/)) 
     437   CALL Agrif_Set_bc(vnb_id ,(/0,ind1-1/)) 
     438   CALL Agrif_Set_bc(ub2b_interp_id,(/0,ind1-1/)) 
     439   CALL Agrif_Set_bc(vb2b_interp_id,(/0,ind1-1/)) 
     440 
     441   CALL Agrif_Set_bc(e3t_id,(/-2*Agrif_irhox()-1,ind1-1/))   ! if west and rhox=3 and ghost=1: column 2 to 9 
     442   CALL Agrif_Set_bc(umsk_id,(/0,ind1-1/)) 
     443   CALL Agrif_Set_bc(vmsk_id,(/0,ind1-1/)) 
     444 
     445   ! clem: previously set to /0,1/ 
    430446# if defined key_zdftke 
    431    CALL Agrif_Set_bc(avm_id ,(/0,1/)) 
     447   CALL Agrif_Set_bc(avm_id ,(/0,ind1/)) 
    432448# endif 
     449   !!clem ghost 
    433450 
    434451   ! 5. Update type 
     
    623640   USE Agrif_Util 
    624641   USE ice 
    625  
    626    IMPLICIT NONE 
     642   USE par_oce, ONLY : nbghostcells 
     643   ! 
     644   IMPLICIT NONE 
     645   ! 
     646   INTEGER :: ind1, ind2, ind3 
    627647   !!---------------------------------------------------------------------- 
    628648   ! 
     
    634654   !                            2,2 = two ghost lines 
    635655   !------------------------------------------------------------------------------------- 
    636    CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpl*(5+nlay_s+nlay_i)/),tra_ice_id ) 
    637    CALL agrif_declare_variable((/1,2/)    ,(/2,3/),(/'x','y'/)    ,(/1,1/)  ,(/nlci,nlcj/)                      ,u_ice_id   ) 
    638    CALL agrif_declare_variable((/2,1/)    ,(/3,2/),(/'x','y'/)    ,(/1,1/)  ,(/nlci,nlcj/)                      ,v_ice_id   ) 
     656   !!clem ghost 
     657   ind1 =     nbghostcells 
     658   ind2 = 1 + nbghostcells 
     659   ind3 = 2 + nbghostcells 
     660   CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpl*(5+nlay_s+nlay_i)/),tra_ice_id ) 
     661   CALL agrif_declare_variable((/1,2/)  ,(/ind2,ind3/)  ,(/'x','y'/)    ,(/1,1/)  ,(/nlci,nlcj/)                      ,u_ice_id   ) 
     662   CALL agrif_declare_variable((/2,1/)  ,(/ind3,ind2/)  ,(/'x','y'/)    ,(/1,1/)  ,(/nlci,nlcj/)                      ,v_ice_id   ) 
     663   !!clem ghost 
    639664 
    640665   ! 2. Set interpolations (normal & tangent to the grid cell for velocities) 
     
    646671   ! 3. Set location of interpolations 
    647672   !---------------------------------- 
    648    CALL Agrif_Set_bc(tra_ice_id,(/0,1/)) 
    649    CALL Agrif_Set_bc(u_ice_id  ,(/0,1/)) 
    650    CALL Agrif_Set_bc(v_ice_id  ,(/0,1/)) 
     673   !!clem ghost 
     674   CALL Agrif_Set_bc(tra_ice_id,(/0,ind1/)) 
     675   CALL Agrif_Set_bc(u_ice_id  ,(/0,ind1/)) 
     676   CALL Agrif_Set_bc(v_ice_id  ,(/0,ind1/)) 
     677   !!clem ghost 
    651678 
    652679   ! 4. Set update type in case 2 ways (child=>parent) (normal & tangent to the grid cell for velocities) 
     
    777804   !! 
    778805   IMPLICIT NONE 
     806   ! 
     807   INTEGER :: ind1, ind2, ind3 
    779808   !!---------------------------------------------------------------------- 
    780809 
    781810   ! 1. Declaration of the type of variable which have to be interpolated 
    782811   !--------------------------------------------------------------------- 
    783    CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra/),trn_id) 
    784    CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra/),trn_sponge_id) 
     812   !!clem ghost 
     813   ind1 =     nbghostcells 
     814   ind2 = 1 + nbghostcells 
     815   ind3 = 2 + nbghostcells 
     816   CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra/),trn_id) 
     817   CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra/),trn_sponge_id) 
    785818 
    786819   ! 2. Type of interpolation 
     
    791824   ! 3. Location of interpolation 
    792825   !----------------------------- 
    793    CALL Agrif_Set_bc(trn_id,(/0,1/)) 
    794 !   CALL Agrif_Set_bc(trn_sponge_id,(/-3*Agrif_irhox(),0/)) 
     826   !!clem ghost 
     827   CALL Agrif_Set_bc(trn_id,(/0,ind1/)) 
     828   !clem: previously set to /-,0/ 
    795829   CALL Agrif_Set_bc(trn_sponge_id,(/-nn_sponge_len*Agrif_irhox()-1,0/)) 
    796830 
  • branches/2017/dev_r8183_ICEMODEL/NEMOGCM/NEMO/OPA_SRC/CRS/crslbclnk.F90

    r6140 r8226  
    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_r8183_ICEMODEL/NEMOGCM/NEMO/OPA_SRC/DIA/diawri.F90

    r7753 r8226  
    10121012      CALL lim_wri_state_2( kt, id_i, nh_i ) 
    10131013#elif defined key_lim3 
    1014       CALL lim_wri_state( kt, id_i, nh_i ) 
     1014      IF( nn_ice == 3 ) THEN   ! clem2017: condition in case agrif + lim but no-ice in child grid 
     1015         CALL lim_wri_state( kt, id_i, nh_i ) 
     1016      ENDIF 
    10151017#else 
    10161018      CALL histend( id_i, snc4chunks=snc4set ) 
  • branches/2017/dev_r8183_ICEMODEL/NEMOGCM/NEMO/OPA_SRC/DOM/iscplhsb.F90

    r7646 r8226  
    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_r8183_ICEMODEL/NEMOGCM/NEMO/OPA_SRC/DYN/divhor.F90

    r7753 r8226  
    8282            END DO   
    8383         END DO   
    84          IF( .NOT. AGRIF_Root() ) THEN 
    85             IF( nbondi ==  1 .OR. nbondi == 2 )   hdivn(nlci-1,   :  ,jk) = 0._wp      ! east 
    86             IF( nbondi == -1 .OR. nbondi == 2 )   hdivn(  2   ,   :  ,jk) = 0._wp      ! west 
    87             IF( nbondj ==  1 .OR. nbondj == 2 )   hdivn(  :   ,nlcj-1,jk) = 0._wp      ! north 
    88             IF( nbondj == -1 .OR. nbondj == 2 )   hdivn(  :   ,  2   ,jk) = 0._wp      ! south 
    89          ENDIF 
    9084      END DO 
     85      IF( .NOT. Agrif_Root() ) THEN 
     86         IF( nbondi == -1 .OR. nbondi == 2 )   hdivn( 2:nbghostcells+1,:        ,:) = 0._wp      ! west 
     87         IF( nbondi ==  1 .OR. nbondi == 2 )   hdivn( nlci-nbghostcells:nlci-1,:,:) = 0._wp      ! east 
     88         IF( nbondj == -1 .OR. nbondj == 2 )   hdivn( :,2:nbghostcells+1        ,:) = 0._wp      ! south 
     89         IF( nbondj ==  1 .OR. nbondj == 2 )   hdivn( :,nlcj-nbghostcells:nlcj-1,:) = 0._wp      ! north 
     90      ENDIF 
    9191      ! 
    9292      IF( ln_rnf )   CALL sbc_rnf_div( hdivn )      !==  runoffs    ==!   (update hdivn field) 
  • branches/2017/dev_r8183_ICEMODEL/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_ts.F90

    r7831 r8226  
    686686            IF((nbondi == -1).OR.(nbondi == 2)) THEN 
    687687               DO jj=1,jpj 
    688                   zwx(2,jj) = ubdy_w(jj) * e2u(2,jj) 
     688                  zwx(2:nbghostcells+1,jj) = ubdy_w(jj) * e2u(2:nbghostcells+1,jj) 
    689689               END DO 
    690690            ENDIF 
    691691            IF((nbondi ==  1).OR.(nbondi == 2)) THEN 
    692692               DO jj=1,jpj 
    693                   zwx(nlci-2,jj) = ubdy_e(jj) * e2u(nlci-2,jj) 
     693                  zwx(nlci-nbghostcells-1:nlci-2,jj) = ubdy_e(jj) * e2u(nlci-nbghostcells-1:nlci-2,jj) 
    694694               END DO 
    695695            ENDIF 
    696696            IF((nbondj == -1).OR.(nbondj == 2)) THEN 
    697697               DO ji=1,jpi 
    698                   zwy(ji,2) = vbdy_s(ji) * e1v(ji,2) 
     698                  zwy(ji,2:nbghostcells+1) = vbdy_s(ji) * e1v(ji,2:nbghostcells+1) 
    699699               END DO 
    700700            ENDIF 
    701701            IF((nbondj ==  1).OR.(nbondj == 2)) THEN 
    702702               DO ji=1,jpi 
    703                   zwy(ji,nlcj-2) = vbdy_n(ji) * e1v(ji,nlcj-2) 
     703                  zwy(ji,nlcj-nbghostcells-1:nlcj-2) = vbdy_n(ji) * e1v(ji,nlcj-nbghostcells-1:nlcj-2) 
    704704               END DO 
    705705            ENDIF 
  • branches/2017/dev_r8183_ICEMODEL/NEMOGCM/NEMO/OPA_SRC/IOM/in_out_manager.F90

    r7646 r8226  
    126126   INTEGER ::   numoni          =   -1      !: logical unit for Output Namelist Ice 
    127127   INTEGER ::   numevo_ice      =   -1      !: logical unit for ice variables (temp. evolution) 
    128    INTEGER ::   numsol          =   -1      !: logical unit for solver statistics 
     128   INTEGER ::   numrun          =   -1      !: logical unit for run statistics 
    129129   INTEGER ::   numdct_in       =   -1      !: logical unit for transports computing 
    130130   INTEGER ::   numdct_vol      =   -1      !: logical unit for voulume transports output 
  • branches/2017/dev_r8183_ICEMODEL/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90

    r8114 r8226  
    22   !!====================================================================== 
    33   !!                       ***  MODULE  lbclnk  *** 
    4    !! Ocean        : lateral boundary conditions 
     4   !! NEMO        : lateral boundary conditions 
    55   !!===================================================================== 
    66   !! History :  OPA  ! 1997-06  (G. Madec)  Original code 
    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   
     12   !!            4.0  ! 2017-03  (G. Madec) automatique allocation of array size (use with any 3rd dim size) 
     13   !!             -   ! 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 
    1215   !!---------------------------------------------------------------------- 
    1316#if defined key_mpp_mpi 
     
    1518   !!   'key_mpp_mpi'             MPI massively parallel processing library 
    1619   !!---------------------------------------------------------------------- 
    17    !!   lbc_lnk      : generic interface for mpp_lnk_3d and mpp_lnk_2d routines defined in lib_mpp 
    18    !!   lbc_sum      : generic interface for mpp_lnk_sum_3d and mpp_lnk_sum_2d routines defined in lib_mpp 
    19    !!   lbc_lnk_e    : generic interface for mpp_lnk_2d_e routine defined in lib_mpp 
    20    !!   lbc_bdy_lnk  : generic interface for mpp_lnk_bdy_2d and mpp_lnk_bdy_3d routines defined in lib_mpp 
    21    !!---------------------------------------------------------------------- 
     20   !!           define the generic interfaces of lib_mpp routines 
     21   !!---------------------------------------------------------------------- 
     22   !!   lbc_lnk       : generic interface for mpp_lnk_3d and mpp_lnk_2d routines defined in lib_mpp 
     23   !!   lbc_lnk_e     : generic interface for mpp_lnk_2d_e routine defined in lib_mpp 
     24   !!   lbc_bdy_lnk   : generic interface for mpp_lnk_bdy_2d and mpp_lnk_bdy_3d routines defined in lib_mpp 
     25   !!---------------------------------------------------------------------- 
     26   USE par_oce        ! ocean dynamics and tracers    
    2227   USE lib_mpp        ! distributed memory computing library 
    23  
     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 
    2436   INTERFACE lbc_lnk_multi 
    25       MODULE PROCEDURE mpp_lnk_2d_9, mpp_lnk_2d_multiple 
    26    END INTERFACE 
    27    ! 
    28    INTERFACE lbc_lnk 
    29       MODULE PROCEDURE mpp_lnk_3d_gather, mpp_lnk_3d, mpp_lnk_2d 
    30    END INTERFACE 
    31    ! 
    32    INTERFACE lbc_sum 
    33       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 
    3438   END INTERFACE 
    3539   ! 
     
    4650   END INTERFACE 
    4751 
    48    PUBLIC   lbc_lnk       ! ocean lateral boundary conditions 
    49    PUBLIC   lbc_lnk_multi ! modified ocean lateral boundary conditions 
    50    PUBLIC   lbc_sum 
    51    PUBLIC   lbc_lnk_e     ! 
     52   PUBLIC   lbc_lnk       ! ocean/ice lateral boundary conditions 
     53   PUBLIC   lbc_lnk_multi ! modified ocean/ice lateral boundary conditions 
     54   PUBLIC   lbc_lnk_e     ! extended ocean/ice lateral boundary conditions 
    5255   PUBLIC   lbc_bdy_lnk   ! ocean lateral BDY boundary conditions 
    53    PUBLIC   lbc_lnk_icb   ! 
    54  
    55    !!---------------------------------------------------------------------- 
    56    !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
     56   PUBLIC   lbc_lnk_icb   ! iceberg lateral boundary conditions 
     57 
     58   !!---------------------------------------------------------------------- 
     59   !! NEMO/OPA 4.0 , NEMO Consortium (2017) 
    5760   !! $Id$ 
    5861   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    5962   !!---------------------------------------------------------------------- 
     63CONTAINS 
     64 
    6065#else 
    6166   !!---------------------------------------------------------------------- 
    6267   !!   Default option                              shared memory computing 
    6368   !!---------------------------------------------------------------------- 
    64    !!   lbc_sum       : generic interface for mpp_lnk_sum_3d and mpp_lnk_sum_2d  
     69   !!                routines setting the appropriate values 
     70   !!         on first and last row and column of the global domain 
     71   !!---------------------------------------------------------------------- 
    6572   !!   lbc_lnk_sum_3d: compute sum over the halos on a 3D variable on ocean mesh 
    6673   !!   lbc_lnk_sum_3d: compute sum over the halos on a 2D variable on ocean mesh 
     
    7077   !!   lbc_bdy_lnk   : set the lateral BDY boundary condition 
    7178   !!---------------------------------------------------------------------- 
    72    USE oce             ! ocean dynamics and tracers    
    73    USE dom_oce         ! ocean space and time domain  
    74    USE in_out_manager  ! I/O manager 
    75    USE lbcnfd          ! north fold 
     79   USE oce            ! ocean dynamics and tracers    
     80   USE dom_oce        ! ocean space and time domain  
     81   USE in_out_manager ! I/O manager 
     82   USE lbcnfd         ! north fold 
    7683 
    7784   IMPLICIT NONE 
     
    7986 
    8087   INTERFACE lbc_lnk 
    81       MODULE PROCEDURE lbc_lnk_3d_gather, lbc_lnk_3d, lbc_lnk_2d 
    82    END INTERFACE 
    83    ! 
    84    INTERFACE lbc_sum 
    85       MODULE PROCEDURE lbc_lnk_sum_3d, lbc_lnk_sum_2d 
    86    END INTERFACE 
    87  
     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 
     95   END INTERFACE 
     96   ! 
    8897   INTERFACE lbc_lnk_e 
    8998      MODULE PROCEDURE lbc_lnk_2d_e 
    9099   END INTERFACE 
    91100   ! 
    92    INTERFACE lbc_lnk_multi 
    93       MODULE PROCEDURE lbc_lnk_2d_9, lbc_lnk_2d_multiple 
    94    END INTERFACE 
    95  
    96101   INTERFACE lbc_bdy_lnk 
    97102      MODULE PROCEDURE lbc_bdy_lnk_2d, lbc_bdy_lnk_3d 
     
    102107   END INTERFACE 
    103108    
    104    TYPE arrayptr 
    105       REAL , DIMENSION (:,:),  POINTER :: pt2d 
    106    END TYPE arrayptr 
    107    PUBLIC   arrayptr 
    108  
    109109   PUBLIC   lbc_lnk       ! ocean/ice  lateral boundary conditions 
    110    PUBLIC   lbc_sum       ! ocean/ice  lateral boundary conditions (sum of the overlap region) 
    111    PUBLIC   lbc_lnk_e     ! 
    112    PUBLIC   lbc_lnk_multi ! modified ocean lateral boundary conditions 
     110   PUBLIC   lbc_lnk_e     ! extended ocean/ice lateral boundary conditions 
     111   PUBLIC   lbc_lnk_multi ! modified ocean/ice lateral boundary conditions 
    113112   PUBLIC   lbc_bdy_lnk   ! ocean lateral BDY boundary conditions 
    114    PUBLIC   lbc_lnk_icb   ! 
    115     
    116    !!---------------------------------------------------------------------- 
    117    !! NEMO/OPA 3.7 , NEMO Consortium (2015) 
     113   PUBLIC   lbc_lnk_icb   ! iceberg lateral boundary conditions 
     114    
     115   !!---------------------------------------------------------------------- 
     116   !! NEMO/OPA 4.0 , NEMO Consortium (2017) 
    118117   !! $Id$ 
    119118   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
     
    122121 
    123122# if defined key_c1d 
    124    !!---------------------------------------------------------------------- 
     123   !!====================================================================== 
    125124   !!   'key_c1d'                                          1D configuration 
    126    !!---------------------------------------------------------------------- 
    127  
    128    SUBROUTINE lbc_lnk_3d_gather( pt3d1, cd_type1, pt3d2, cd_type2, psgn ) 
    129       !!--------------------------------------------------------------------- 
    130       !!                  ***  ROUTINE lbc_lnk_3d_gather  *** 
    131       !! 
    132       !! ** Purpose :   set lateral boundary conditions on two 3D arrays (C1D case) 
    133       !! 
    134       !! ** Method  :   call lbc_lnk_3d on pt3d1 and pt3d2 
    135       !!---------------------------------------------------------------------- 
    136       CHARACTER(len=1)                , INTENT(in   ) ::   cd_type1, cd_type2   ! nature of pt3d grid-points 
    137       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pt3d1   , pt3d2      ! 3D array on which the lbc is applied 
    138       REAL(wp)                        , INTENT(in   ) ::   psgn                 ! control of the sign  
    139       !!---------------------------------------------------------------------- 
    140       ! 
    141       CALL lbc_lnk_3d( pt3d1, cd_type1, psgn) 
    142       CALL lbc_lnk_3d( pt3d2, cd_type2, psgn) 
    143       ! 
    144    END SUBROUTINE lbc_lnk_3d_gather 
    145  
     125   !!====================================================================== 
     126   !!     central point value replicated over the 8 surrounding points 
     127   !!---------------------------------------------------------------------- 
    146128 
    147129   SUBROUTINE lbc_lnk_3d( pt3d, cd_type, psgn, cd_mpp, pval ) 
     
    153135      !! ** Method  :   1D case, the central water column is set everywhere 
    154136      !!---------------------------------------------------------------------- 
    155       CHARACTER(len=1)                , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points 
    156       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout)           ::   pt3d      ! 3D array on which the lbc is applied 
    157       REAL(wp)                        , INTENT(in   )           ::   psgn      ! control of the sign  
    158       CHARACTER(len=3)                , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing) 
    159       REAL(wp)                        , INTENT(in   ), OPTIONAL ::   pval      ! background value (for closed boundaries) 
     137      REAL(wp), DIMENSION(:,:,:), INTENT(inout)           ::   pt3d      ! 3D array on which the lbc is applied 
     138      CHARACTER(len=1)          , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points 
     139      REAL(wp)                  , INTENT(in   )           ::   psgn      ! sign used across north fold  
     140      CHARACTER(len=3)          , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing) 
     141      REAL(wp)                  , INTENT(in   ), OPTIONAL ::   pval      ! background value (for closed boundaries) 
    160142      ! 
    161143      INTEGER  ::   jk     ! dummy loop index 
     
    163145      !!---------------------------------------------------------------------- 
    164146      ! 
    165       DO jk = 1, jpk 
     147      DO jk = 1, SIZE( pt3d, 3 ) 
    166148         ztab = pt3d(2,2,jk) 
    167149         pt3d(:,:,jk) = ztab 
     
    179161      !! ** Method  :   1D case, the central water column is set everywhere 
    180162      !!---------------------------------------------------------------------- 
     163      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout)           ::   pt2d      ! 2D array on which the lbc is applied 
    181164      CHARACTER(len=1)            , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points 
    182       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout)           ::   pt2d      ! 2D array on which the lbc is applied 
    183       REAL(wp)                    , INTENT(in   )           ::   psgn      ! control of the sign  
     165      REAL(wp)                    , INTENT(in   )           ::   psgn      ! sign used across north fold  
    184166      CHARACTER(len=3)            , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing) 
    185167      REAL(wp)                    , INTENT(in   ), OPTIONAL ::   pval      ! background value (for closed boundaries) 
     
    193175   END SUBROUTINE lbc_lnk_2d 
    194176    
    195    SUBROUTINE lbc_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields ) 
    196       !! 
    197       INTEGER :: num_fields 
    198       TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 
    199       CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   type_array   ! define the nature of ptab array grid-points 
    200       !                                                               ! = T , U , V , F , W and I points 
    201       REAL(wp)        , DIMENSION(:), INTENT(in   ) ::   psgn_array   ! =-1 the sign change across the north fold boundary 
    202       !                                                               ! =  1. , the sign is kept 
    203       ! 
    204       INTEGER  ::   ii    !!MULTI SEND DUMMY LOOP INDICES 
    205       ! 
    206       DO ii = 1, num_fields 
    207         CALL lbc_lnk_2d( pt2d_array(ii)%pt2d, type_array(ii), psgn_array(ii) ) 
    208       END DO      
    209       ! 
    210    END SUBROUTINE lbc_lnk_2d_multiple 
    211  
    212    SUBROUTINE lbc_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC   & 
    213       &                   , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF   & 
    214       &                   , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 
    215       !!--------------------------------------------------------------------- 
    216       ! Second 2D array on which the boundary condition is applied 
    217       REAL(wp), DIMENSION(jpi,jpj), TARGET          , INTENT(inout) ::   pt2dA 
    218       REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dB , pt2dC , pt2dD , pt2dE 
    219       REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dF , pt2dG , pt2dH , pt2dI 
    220       ! define the nature of ptab array grid-points 
    221       CHARACTER(len=1)                              , INTENT(in   ) ::   cd_typeA 
    222       CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeB , cd_typeC , cd_typeD , cd_typeE 
    223       CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeF , cd_typeG , cd_typeH , cd_typeI 
    224       ! =-1 the sign change across the north fold boundary 
    225       REAL(wp)                                      , INTENT(in   ) ::   psgnA 
    226       REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnB , psgnC , psgnD , psgnE 
    227       REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnF , psgnG , psgnH , psgnI 
    228       CHARACTER(len=3)                    , OPTIONAL, INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
    229       REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
    230       !! 
    231       !!--------------------------------------------------------------------- 
    232  
    233       !!The first array 
    234       CALL lbc_lnk( pt2dA, cd_typeA, psgnA )  
    235  
    236       !! Look if more arrays to process 
    237       IF(PRESENT (psgnB) )CALL lbc_lnk( pt2dB, cd_typeB, psgnB ) 
    238       IF(PRESENT (psgnC) )CALL lbc_lnk( pt2dC, cd_typeC, psgnC )  
    239       IF(PRESENT (psgnD) )CALL lbc_lnk( pt2dD, cd_typeD, psgnD )  
    240       IF(PRESENT (psgnE) )CALL lbc_lnk( pt2dE, cd_typeE, psgnE )  
    241       IF(PRESENT (psgnF) )CALL lbc_lnk( pt2dF, cd_typeF, psgnF )  
    242       IF(PRESENT (psgnG) )CALL lbc_lnk( pt2dG, cd_typeG, psgnG )  
    243       IF(PRESENT (psgnH) )CALL lbc_lnk( pt2dH, cd_typeH, psgnH )  
    244       IF(PRESENT (psgnI) )CALL lbc_lnk( pt2dI, cd_typeI, psgnI )  
    245  
    246    END SUBROUTINE lbc_lnk_2d_9 
    247  
    248  
    249  
    250  
    251  
    252177#else 
    253    !!---------------------------------------------------------------------- 
     178   !!====================================================================== 
    254179   !!   Default option                           3D shared memory computing 
    255    !!---------------------------------------------------------------------- 
    256  
    257    SUBROUTINE lbc_lnk_3d_gather( pt3d1, cd_type1, pt3d2, cd_type2, psgn ) 
    258       !!--------------------------------------------------------------------- 
    259       !!                  ***  ROUTINE lbc_lnk_3d_gather  *** 
    260       !! 
    261       !! ** Purpose :   set lateral boundary conditions on two 3D arrays (non mpp case) 
    262       !! 
    263       !! ** Method  :   psign = -1 :    change the sign across the north fold 
    264       !!                      =  1 : no change of the sign across the north fold 
    265       !!                      =  0 : no change of the sign across the north fold and 
    266       !!                             strict positivity preserved: use inner row/column 
    267       !!                             for closed boundaries. 
    268       !!---------------------------------------------------------------------- 
    269       CHARACTER(len=1)                , INTENT(in   ) ::   cd_type1, cd_type2   ! nature of pt3d grid-points 
    270       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pt3d1   , pt3d2      ! 3D array on which the lbc is applied 
    271       REAL(wp)                        , INTENT(in   ) ::   psgn                 ! control of the sign  
    272       !!---------------------------------------------------------------------- 
    273       ! 
    274       CALL lbc_lnk_3d( pt3d1, cd_type1, psgn) 
    275       CALL lbc_lnk_3d( pt3d2, cd_type2, psgn) 
    276       ! 
    277    END SUBROUTINE lbc_lnk_3d_gather 
    278  
    279  
    280    SUBROUTINE lbc_lnk_3d( pt3d, cd_type, psgn, cd_mpp, pval ) 
    281       !!--------------------------------------------------------------------- 
    282       !!                  ***  ROUTINE lbc_lnk_3d  *** 
    283       !! 
    284       !! ** Purpose :   set lateral boundary conditions on a 3D 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,jpk), INTENT(inout)           ::   pt3d      ! 3D array on which the lbc is applied 
    294       REAL(wp)                        , INTENT(in   )           ::   psgn      ! control of the sign  
    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  
    306       IF( PRESENT( cd_mpp ) ) THEN 
    307          ! only fill the overlap area and extra allows  
    308          ! this is in mpp case. In this module, just do nothing 
    309       ELSE 
    310          !                                     !  East-West boundaries 
    311          !                                     ! ====================== 
    312          SELECT CASE ( nperio ) 
    313          ! 
    314          CASE ( 1 , 4 , 6 )                       !**  cyclic east-west 
    315             pt3d( 1 ,:,:) = pt3d(jpim1,:,:)            ! all points 
    316             pt3d(jpi,:,:) = pt3d(  2  ,:,:) 
    317             ! 
    318          CASE DEFAULT                             !**  East closed  --  West closed 
    319             SELECT CASE ( cd_type ) 
    320             CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points 
    321                pt3d( 1 ,:,:) = zland 
    322                pt3d(jpi,:,:) = zland 
    323             CASE ( 'F' )                               ! F-point 
    324                pt3d(jpi,:,:) = zland 
    325             END SELECT 
    326             ! 
    327          END SELECT 
    328          !                                     ! North-South boundaries 
    329          !                                     ! ====================== 
    330          SELECT CASE ( nperio ) 
    331          ! 
    332          CASE ( 2 )                               !**  South symmetric  --  North closed 
    333             SELECT CASE ( cd_type ) 
    334             CASE ( 'T' , 'U' , 'W' )                   ! T-, U-, W-points 
    335                pt3d(:, 1 ,:) = pt3d(:,3,:) 
    336                pt3d(:,jpj,:) = zland 
    337             CASE ( 'V' , 'F' )                         ! V-, F-points 
    338                pt3d(:, 1 ,:) = psgn * pt3d(:,2,:) 
    339                pt3d(:,jpj,:) = zland 
    340             END SELECT 
    341             ! 
    342          CASE ( 3 , 4 , 5 , 6 )                   !**  North fold  T or F-point pivot  --  South closed 
    343             SELECT CASE ( cd_type )                    ! South : closed 
    344             CASE ( 'T' , 'U' , 'V' , 'W' , 'I' )             ! all points except F-point 
    345                pt3d(:, 1 ,:) = zland 
    346             END SELECT 
    347             !                                          ! North fold 
    348             CALL lbc_nfd( pt3d(:,:,:), cd_type, psgn ) 
    349             ! 
    350          CASE DEFAULT                             !**  North closed  --  South closed 
    351             SELECT CASE ( cd_type ) 
    352             CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points 
    353                pt3d(:, 1 ,:) = zland 
    354                pt3d(:,jpj,:) = zland 
    355             CASE ( 'F' )                               ! F-point 
    356                pt3d(:,jpj,:) = zland 
    357             END SELECT 
    358             ! 
    359          END SELECT 
    360          ! 
    361       ENDIF 
    362       ! 
    363    END SUBROUTINE lbc_lnk_3d 
    364  
    365  
    366    SUBROUTINE lbc_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 
    367       !!--------------------------------------------------------------------- 
    368       !!                 ***  ROUTINE lbc_lnk_2d  *** 
    369       !! 
    370       !! ** Purpose :   set lateral boundary conditions on a 2D array (non mpp case) 
    371       !! 
    372       !! ** Method  :   psign = -1 :    change the sign across the north fold 
    373       !!                      =  1 : no change of the sign across the north fold 
    374       !!                      =  0 : no change of the sign across the north fold and 
    375       !!                             strict positivity preserved: use inner row/column 
    376       !!                             for closed boundaries. 
    377       !!---------------------------------------------------------------------- 
    378       CHARACTER(len=1)            , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points 
    379       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout)           ::   pt2d      ! 2D array on which the lbc is applied 
    380       REAL(wp)                    , INTENT(in   )           ::   psgn      ! control of the sign  
    381       CHARACTER(len=3)            , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing) 
    382       REAL(wp)                    , INTENT(in   ), OPTIONAL ::   pval      ! background value (for closed boundaries) 
    383       !! 
    384       REAL(wp) ::   zland 
    385       !!---------------------------------------------------------------------- 
    386  
    387       IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value (zero by default) 
    388       ELSE                         ;   zland = 0._wp 
    389       ENDIF 
    390  
    391       IF (PRESENT(cd_mpp)) THEN 
    392          ! only fill the overlap area and extra allows  
    393          ! this is in mpp case. In this module, just do nothing 
    394       ELSE       
    395          !                                     ! East-West boundaries 
    396          !                                     ! ==================== 
    397          SELECT CASE ( nperio ) 
    398          ! 
    399          CASE ( 1 , 4 , 6 )                       !** cyclic east-west 
    400             pt2d( 1 ,:) = pt2d(jpim1,:)               ! all points 
    401             pt2d(jpi,:) = pt2d(  2  ,:) 
    402             ! 
    403          CASE DEFAULT                             !** East closed  --  West closed 
    404             SELECT CASE ( cd_type ) 
    405             CASE ( 'T' , 'U' , 'V' , 'W' )            ! T-, U-, V-, W-points 
    406                pt2d( 1 ,:) = zland 
    407                pt2d(jpi,:) = zland 
    408             CASE ( 'F' )                              ! F-point 
    409                pt2d(jpi,:) = zland 
    410             END SELECT 
    411             ! 
    412          END SELECT 
    413          !                                     ! North-South boundaries 
    414          !                                     ! ====================== 
    415          SELECT CASE ( nperio ) 
    416          ! 
    417          CASE ( 2 )                               !**  South symmetric  --  North closed 
    418             SELECT CASE ( cd_type ) 
    419             CASE ( 'T' , 'U' , 'W' )                   ! T-, U-, W-points 
    420                pt2d(:, 1 ) = pt2d(:,3) 
    421                pt2d(:,jpj) = zland 
    422             CASE ( 'V' , 'F' )                         ! V-, F-points 
    423                pt2d(:, 1 ) = psgn * pt2d(:,2) 
    424                pt2d(:,jpj) = zland 
    425             END SELECT 
    426             ! 
    427          CASE ( 3 , 4 , 5 , 6 )                   !**  North fold  T or F-point pivot  --  South closed 
    428             SELECT CASE ( cd_type )                    ! South : closed 
    429             CASE ( 'T' , 'U' , 'V' , 'W' , 'I' )             ! all points except F-point 
    430                pt2d(:, 1 ) = zland 
    431             END SELECT 
    432             !                                          ! North fold 
    433             CALL lbc_nfd( pt2d(:,:), cd_type, psgn ) 
    434             ! 
    435          CASE DEFAULT                             !**  North closed  --  South closed 
    436             SELECT CASE ( cd_type ) 
    437             CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points 
    438                pt2d(:, 1 ) = zland 
    439                pt2d(:,jpj) = zland 
    440             CASE ( 'F' )                               ! F-point 
    441                pt2d(:,jpj) = zland 
    442             END SELECT 
    443             ! 
    444          END SELECT 
    445          ! 
    446       ENDIF 
    447       !     
    448    END SUBROUTINE lbc_lnk_2d 
    449     
    450    SUBROUTINE lbc_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields ) 
    451       !! 
    452       INTEGER :: num_fields 
    453       TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 
    454       CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   type_array   ! define the nature of ptab array grid-points 
    455       !                                                               ! = T , U , V , F , W and I points 
    456       REAL(wp)        , DIMENSION(:), INTENT(in   ) ::   psgn_array   ! =-1 the sign change across the north fold boundary 
    457       !                                                               ! =  1. , the sign is kept 
    458       ! 
    459       INTEGER  ::   ii    !!MULTI SEND DUMMY LOOP INDICES 
    460       ! 
    461       DO ii = 1, num_fields 
    462         CALL lbc_lnk_2d( pt2d_array(ii)%pt2d, type_array(ii), psgn_array(ii) ) 
    463       END DO      
    464       ! 
    465    END SUBROUTINE lbc_lnk_2d_multiple 
    466  
    467    SUBROUTINE lbc_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC   & 
    468       &                   , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF   & 
    469       &                   , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 
    470       !!--------------------------------------------------------------------- 
    471       ! Second 2D array on which the boundary condition is applied 
    472       REAL(wp), DIMENSION(jpi,jpj), TARGET          , INTENT(inout) ::   pt2dA 
    473       REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dB , pt2dC , pt2dD , pt2dE 
    474       REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dF , pt2dG , pt2dH , pt2dI 
    475       ! define the nature of ptab array grid-points 
    476       CHARACTER(len=1)                              , INTENT(in   ) ::   cd_typeA 
    477       CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeB , cd_typeC , cd_typeD , cd_typeE 
    478       CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeF , cd_typeG , cd_typeH , cd_typeI 
    479       ! =-1 the sign change across the north fold boundary 
    480       REAL(wp)                                      , INTENT(in   ) ::   psgnA 
    481       REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnB , psgnC , psgnD , psgnE 
    482       REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnF , psgnG , psgnH , psgnI 
    483       CHARACTER(len=3)                    , OPTIONAL, INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
    484       REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
    485       !! 
    486       !!--------------------------------------------------------------------- 
    487  
    488       !!The first array 
    489       CALL lbc_lnk( pt2dA, cd_typeA, psgnA )  
    490  
    491       !! Look if more arrays to process 
    492       IF(PRESENT (psgnB) )CALL lbc_lnk( pt2dB, cd_typeB, psgnB ) 
    493       IF(PRESENT (psgnC) )CALL lbc_lnk( pt2dC, cd_typeC, psgnC )  
    494       IF(PRESENT (psgnD) )CALL lbc_lnk( pt2dD, cd_typeD, psgnD )  
    495       IF(PRESENT (psgnE) )CALL lbc_lnk( pt2dE, cd_typeE, psgnE )  
    496       IF(PRESENT (psgnF) )CALL lbc_lnk( pt2dF, cd_typeF, psgnF )  
    497       IF(PRESENT (psgnG) )CALL lbc_lnk( pt2dG, cd_typeG, psgnG )  
    498       IF(PRESENT (psgnH) )CALL lbc_lnk( pt2dH, cd_typeH, psgnH )  
    499       IF(PRESENT (psgnI) )CALL lbc_lnk( pt2dI, cd_typeI, psgnI )  
    500  
    501    END SUBROUTINE lbc_lnk_2d_9 
    502  
    503    SUBROUTINE lbc_lnk_sum_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 
    504       !!--------------------------------------------------------------------- 
    505       !!                 ***  ROUTINE lbc_lnk_sum_2d  *** 
    506       !! 
    507       !! ** Purpose :   set lateral boundary conditions on a 2D array (non mpp case) 
    508       !! 
    509       !! ** Comments:   compute the sum of the common cell (overlap region) for the ice sheet/ocean  
    510       !!                coupling if conservation option activated. As no ice shelf are present along 
    511       !!                this line, nothing is done along the north fold. 
    512       !!---------------------------------------------------------------------- 
    513       CHARACTER(len=1)            , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points 
    514       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout)           ::   pt2d      ! 2D array on which the lbc is applied 
    515       REAL(wp)                    , INTENT(in   )           ::   psgn      ! control of the sign  
    516       CHARACTER(len=3)            , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing) 
    517       REAL(wp)                    , INTENT(in   ), OPTIONAL ::   pval      ! background value (for closed boundaries) 
    518       !! 
    519       REAL(wp) ::   zland 
    520       !!---------------------------------------------------------------------- 
    521  
    522       IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value (zero by default) 
    523       ELSE                         ;   zland = 0._wp 
    524       ENDIF 
    525  
    526       IF (PRESENT(cd_mpp)) THEN 
    527          ! only fill the overlap area and extra allows  
    528          ! this is in mpp case. In this module, just do nothing 
    529       ELSE 
    530          !                                     ! East-West boundaries 
    531          !                                     ! ==================== 
    532          SELECT CASE ( nperio ) 
    533          ! 
    534          CASE ( 1 , 4 , 6 )                       !** cyclic east-west 
    535             pt2d(jpim1,:) = pt2d(jpim1,:) + pt2d( 1 ,:) 
    536             pt2d(  2  ,:) = pt2d(  2  ,:) + pt2d(jpi,:) 
    537             pt2d( 1 ,:) = 0.0_wp               ! all points 
    538             pt2d(jpi,:) = 0.0_wp 
    539             ! 
    540          CASE DEFAULT                             !** East closed  --  West closed 
    541             SELECT CASE ( cd_type ) 
    542             CASE ( 'T' , 'U' , 'V' , 'W' )            ! T-, U-, V-, W-points 
    543                pt2d( 1 ,:) = zland 
    544                pt2d(jpi,:) = zland 
    545             CASE ( 'F' )                              ! F-point 
    546                pt2d(jpi,:) = zland 
    547             END SELECT 
    548             ! 
    549          END SELECT 
    550          !                                     ! North-South boundaries 
    551          !                                     ! ====================== 
    552          ! Nothing to do for the north fold, there is no ice shelf along this line. 
    553          ! 
    554       END IF 
    555  
    556    END SUBROUTINE 
    557  
    558    SUBROUTINE lbc_lnk_sum_3d( pt3d, cd_type, psgn, cd_mpp, pval ) 
    559       !!--------------------------------------------------------------------- 
    560       !!                 ***  ROUTINE lbc_lnk_sum_3d  *** 
    561       !! 
    562       !! ** Purpose :   set lateral boundary conditions on a 3D array (non mpp case) 
    563       !! 
    564       !! ** Comments:   compute the sum of the common cell (overlap region) for the ice sheet/ocean  
    565       !!                coupling if conservation option activated. As no ice shelf are present along 
    566       !!                this line, nothing is done along the north fold. 
    567       !!---------------------------------------------------------------------- 
    568       CHARACTER(len=1)                , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points 
    569       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout)           ::   pt3d      ! 3D array on which the lbc is applied 
    570       REAL(wp)                        , INTENT(in   )           ::   psgn      ! control of the sign  
    571       CHARACTER(len=3)                , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing) 
    572       REAL(wp)                        , INTENT(in   ), OPTIONAL ::   pval      ! background value (for closed boundaries) 
    573       !! 
    574       REAL(wp) ::   zland 
    575       !!---------------------------------------------------------------------- 
    576  
    577       IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value (zero by default) 
    578       ELSE                         ;   zland = 0._wp 
    579       ENDIF 
    580  
    581  
    582       IF( PRESENT( cd_mpp ) ) THEN 
    583          ! only fill the overlap area and extra allows  
    584          ! this is in mpp case. In this module, just do nothing 
    585       ELSE 
    586          !                                     !  East-West boundaries 
    587          !                                     ! ====================== 
    588          SELECT CASE ( nperio ) 
    589          ! 
    590          CASE ( 1 , 4 , 6 )                       !**  cyclic east-west 
    591             pt3d(jpim1,:,:) = pt3d(jpim1,:,:) + pt3d( 1 ,:,:) 
    592             pt3d(  2  ,:,:) = pt3d(  2  ,:,:) + pt3d(jpi,:,:)  
    593             pt3d( 1 ,:,:) = 0.0_wp            ! all points 
    594             pt3d(jpi,:,:) = 0.0_wp 
    595             ! 
    596          CASE DEFAULT                             !**  East closed  --  West closed 
    597             SELECT CASE ( cd_type ) 
    598             CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points 
    599                pt3d( 1 ,:,:) = zland 
    600                pt3d(jpi,:,:) = zland 
    601             CASE ( 'F' )                               ! F-point 
    602                pt3d(jpi,:,:) = zland 
    603             END SELECT 
    604             ! 
    605          END SELECT 
    606          !                                     ! North-South boundaries 
    607          !                                     ! ====================== 
    608          ! Nothing to do for the north fold, there is no ice shelf along this line. 
    609          ! 
    610       END IF 
    611    END SUBROUTINE 
    612  
    613  
     180   !!====================================================================== 
     181   !!          routines setting land point, or east-west cyclic, 
     182   !!             or north-south cyclic, or north fold values 
     183   !!         on first and last row and column of the global domain 
     184   !!---------------------------------------------------------------------- 
     185 
     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 
     236    
    614237#endif 
    615238 
     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    
    616250   SUBROUTINE lbc_bdy_lnk_3d( pt3d, cd_type, psgn, ib_bdy ) 
    617       !!--------------------------------------------------------------------- 
    618       !!                  ***  ROUTINE lbc_bdy_lnk  *** 
    619       !! 
    620       !! ** Purpose :   wrapper rountine to 'lbc_lnk_3d'. This wrapper is used 
    621       !!              to maintain the same interface with regards to the mpp case 
    622       !! 
    623       !!---------------------------------------------------------------------- 
    624       CHARACTER(len=1)                , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points 
    625       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pt3d      ! 3D array on which the lbc is applied 
    626       REAL(wp)                        , INTENT(in   ) ::   psgn      ! control of the sign  
    627       INTEGER                         , INTENT(in   ) ::   ib_bdy    ! BDY boundary set 
    628       !!---------------------------------------------------------------------- 
    629       ! 
     251      !!---------------------------------------------------------------------- 
     252      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pt3d      ! 3D array on which the lbc is applied 
     253      CHARACTER(len=1)          , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points 
     254      REAL(wp)                  , INTENT(in   ) ::   psgn      ! sign used across north fold  
     255      INTEGER                   , INTENT(in   ) ::   ib_bdy    ! BDY boundary set 
     256      !!---------------------------------------------------------------------- 
    630257      CALL lbc_lnk_3d( pt3d, cd_type, psgn) 
    631       ! 
    632258   END SUBROUTINE lbc_bdy_lnk_3d 
    633259 
    634260 
    635261   SUBROUTINE lbc_bdy_lnk_2d( pt2d, cd_type, psgn, ib_bdy ) 
    636       !!--------------------------------------------------------------------- 
    637       !!                  ***  ROUTINE lbc_bdy_lnk  *** 
    638       !! 
    639       !! ** Purpose :   wrapper rountine to 'lbc_lnk_3d'. This wrapper is used 
    640       !!              to maintain the same interface with regards to the mpp case 
    641       !! 
    642       !!---------------------------------------------------------------------- 
    643       CHARACTER(len=1)            , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points 
    644       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d      ! 3D array on which the lbc is applied 
    645       REAL(wp)                    , INTENT(in   ) ::   psgn      ! control of the sign  
    646       INTEGER                     , INTENT(in   ) ::   ib_bdy    ! BDY boundary set 
    647       !!---------------------------------------------------------------------- 
    648       ! 
     262      !!---------------------------------------------------------------------- 
     263      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d      ! 3D array on which the lbc is applied 
     264      CHARACTER(len=1)        , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points 
     265      REAL(wp)                , INTENT(in   ) ::   psgn      ! sign used across north fold  
     266      INTEGER                 , INTENT(in   ) ::   ib_bdy    ! BDY boundary set 
     267      !!---------------------------------------------------------------------- 
    649268      CALL lbc_lnk_2d( pt2d, cd_type, psgn) 
    650       ! 
    651269   END SUBROUTINE lbc_bdy_lnk_2d 
    652270 
    653271 
    654    SUBROUTINE lbc_lnk_2d_e( pt2d, cd_type, psgn, jpri, jprj ) 
    655       !!--------------------------------------------------------------------- 
    656       !!                 ***  ROUTINE lbc_lnk_2d  *** 
    657       !! 
    658       !! ** Purpose :   set lateral boundary conditions on a 2D array (non mpp case) 
    659       !!                special dummy routine to allow for use of halo indexing in mpp case 
    660       !! 
    661       !! ** Method  :   psign = -1 :    change the sign across the north fold 
    662       !!                      =  1 : no change of the sign across the north fold 
    663       !!                      =  0 : no change of the sign across the north fold and 
    664       !!                             strict positivity preserved: use inner row/column 
    665       !!                             for closed boundaries. 
    666       !!---------------------------------------------------------------------- 
    667       CHARACTER(len=1)            , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points 
    668       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d      ! 2D array on which the lbc is applied 
    669       REAL(wp)                    , INTENT(in   ) ::   psgn      ! control of the sign  
    670       INTEGER                     , INTENT(in   ) ::   jpri      ! size of extra halo (not needed in non-mpp) 
    671       INTEGER                     , INTENT(in   ) ::   jprj      ! size of extra halo (not needed in non-mpp) 
    672       !!---------------------------------------------------------------------- 
    673       ! 
     272!!gm  This routine should be remove with an optional halos size added in orgument of generic routines 
     273 
     274   SUBROUTINE lbc_lnk_2d_e( pt2d, cd_type, psgn, ki, kj ) 
     275      !!---------------------------------------------------------------------- 
     276      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d      ! 2D array on which the lbc is applied 
     277      CHARACTER(len=1)        , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points 
     278      REAL(wp)                , INTENT(in   ) ::   psgn      ! sign used across north fold  
     279      INTEGER                 , INTENT(in   ) ::   ki, kj    ! sizes of extra halo (not needed in non-mpp) 
     280      !!---------------------------------------------------------------------- 
    674281      CALL lbc_lnk_2d( pt2d, cd_type, psgn ) 
    675       !     
    676282   END SUBROUTINE lbc_lnk_2d_e 
     283!!gm end 
    677284 
    678285#endif 
    679286 
    680287   !!====================================================================== 
     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   !!====================================================================== 
    681339END MODULE lbclnk 
    682340 
  • branches/2017/dev_r8183_ICEMODEL/NEMOGCM/NEMO/OPA_SRC/LBC/lbcnfd.F90

    r7646 r8226  
    55   !!====================================================================== 
    66   !! History :  3.2  ! 2009-03  (R. Benshila)  Original code  
    7    !!            3.5  ! 2013-07 (I. Epicoco, S. Mocavero - CMCC) MPP optimization  
     7   !!            3.5  ! 2013-07  (I. Epicoco, S. Mocavero - CMCC) MPP optimization 
     8   !!            4.0  ! 2017-04  (G. Madec) automatique allocation of array argument (use any 3rd dimension) 
    89   !!---------------------------------------------------------------------- 
    910 
     
    1213   !!   lbc_nfd_3d    : lateral boundary condition: North fold treatment for a 3D arrays   (lbc_nfd) 
    1314   !!   lbc_nfd_2d    : lateral boundary condition: North fold treatment for a 2D arrays   (lbc_nfd) 
    14    !!   mpp_lbc_nfd_3d    : North fold treatment for a 3D arrays optimized for MPP 
    15    !!   mpp_lbc_nfd_2d    : North fold treatment for a 2D arrays optimized for MPP 
     15   !!   lbc_nfd_nogather       : generic interface for lbc_nfd_nogather_3d and  
     16   !!                            lbc_nfd_nogather_2d routines (designed for use 
     17   !!                            with ln_nnogather to avoid global width arrays 
     18   !!                            mpi all gather operations) 
    1619   !!---------------------------------------------------------------------- 
    1720   USE dom_oce        ! ocean space and time domain  
     
    2225 
    2326   INTERFACE lbc_nfd 
    24       MODULE PROCEDURE   lbc_nfd_3d, lbc_nfd_2d 
     27      MODULE PROCEDURE   lbc_nfd_2d    , lbc_nfd_3d    , lbc_nfd_4d 
     28      MODULE PROCEDURE   lbc_nfd_2d_ptr, lbc_nfd_3d_ptr, lbc_nfd_4d_ptr 
    2529   END INTERFACE 
    2630   ! 
    27    INTERFACE mpp_lbc_nfd 
    28       MODULE PROCEDURE   mpp_lbc_nfd_3d, mpp_lbc_nfd_2d 
     31   INTERFACE lbc_nfd_nogather 
     32!                        ! Currently only 4d array version is needed 
     33!     MODULE PROCEDURE   lbc_nfd_nogather_2d    , lbc_nfd_nogather_3d 
     34      MODULE PROCEDURE   lbc_nfd_nogather_4d 
     35!     MODULE PROCEDURE   lbc_nfd_nogather_2d_ptr, lbc_nfd_nogather_3d_ptr 
     36!     MODULE PROCEDURE   lbc_nfd_nogather_4d_ptr 
    2937   END INTERFACE 
    3038 
    31    PUBLIC   lbc_nfd       ! north fold conditions 
    32    PUBLIC   mpp_lbc_nfd   ! north fold conditions (parallel case) 
     39   TYPE, PUBLIC ::   PTR_2D   !: array of 2D pointers (also used in lib_mpp) 
     40      REAL(wp), DIMENSION (:,:)    , POINTER ::   pt2d 
     41   END TYPE PTR_2D 
     42   TYPE, PUBLIC ::   PTR_3D   !: array of 3D pointers (also used in lib_mpp) 
     43      REAL(wp), DIMENSION (:,:,:)  , POINTER ::   pt3d 
     44   END TYPE PTR_3D 
     45   TYPE, PUBLIC ::   PTR_4D   !: array of 4D pointers (also used in lib_mpp) 
     46      REAL(wp), DIMENSION (:,:,:,:), POINTER ::   pt4d 
     47   END TYPE PTR_4D 
     48 
     49   PUBLIC   lbc_nfd            ! north fold conditions 
     50   PUBLIC   lbc_nfd_nogather   ! north fold conditions (no allgather case) 
    3351 
    3452   INTEGER, PUBLIC, PARAMETER            ::   jpmaxngh = 3               !: 
     
    4361CONTAINS 
    4462 
    45    SUBROUTINE lbc_nfd_3d( pt3d, cd_type, psgn ) 
    46       !!---------------------------------------------------------------------- 
    47       !!                  ***  routine lbc_nfd_3d  *** 
    48       !! 
    49       !! ** Purpose :   3D lateral boundary condition : North fold treatment 
    50       !!              without processor exchanges.  
    51       !! 
    52       !! ** Method  :    
    53       !! 
    54       !! ** Action  :   pt3d with updated values along the north fold 
    55       !!---------------------------------------------------------------------- 
    56       CHARACTER(len=1)          , INTENT(in   ) ::   cd_type   ! define the nature of ptab array grid-points 
    57       !                                                        !   = T , U , V , F , W points 
    58       REAL(wp)                  , INTENT(in   ) ::   psgn      ! control of the sign change 
    59       !                                                        !   = -1. , the sign is changed if north fold boundary 
    60       !                                                        !   =  1. , the sign is kept  if north fold boundary 
    61       REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pt3d      ! 3D array on which the boundary condition is applied 
    62       ! 
    63       INTEGER  ::   ji, jk 
    64       INTEGER  ::   ijt, iju, ijpj, ijpjm1 
    65       !!---------------------------------------------------------------------- 
    66  
    67       SELECT CASE ( jpni ) 
    68       CASE ( 1 )     ;   ijpj = nlcj      ! 1 proc only  along the i-direction 
    69       CASE DEFAULT   ;   ijpj = 4         ! several proc along the i-direction 
    70       END SELECT 
    71       ijpjm1 = ijpj-1 
    72  
    73       DO jk = 1, jpk 
    74          ! 
    75          SELECT CASE ( npolj ) 
    76          ! 
    77          CASE ( 3 , 4 )                        ! *  North fold  T-point pivot 
    78             ! 
    79             SELECT CASE ( cd_type ) 
    80             CASE ( 'T' , 'W' )                         ! T-, W-point 
    81                DO ji = 2, jpiglo 
    82                   ijt = jpiglo-ji+2 
    83                   pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-2,jk) 
    84                END DO 
    85                pt3d(1,ijpj,jk) = psgn * pt3d(3,ijpj-2,jk) 
    86                DO ji = jpiglo/2+1, jpiglo 
    87                   ijt = jpiglo-ji+2 
    88                   pt3d(ji,ijpjm1,jk) = psgn * pt3d(ijt,ijpjm1,jk) 
    89                END DO 
    90             CASE ( 'U' )                               ! U-point 
    91                DO ji = 1, jpiglo-1 
    92                   iju = jpiglo-ji+1 
    93                   pt3d(ji,ijpj,jk) = psgn * pt3d(iju,ijpj-2,jk) 
    94                END DO 
    95                pt3d(   1  ,ijpj,jk) = psgn * pt3d(    2   ,ijpj-2,jk) 
    96                pt3d(jpiglo,ijpj,jk) = psgn * pt3d(jpiglo-1,ijpj-2,jk)  
    97                DO ji = jpiglo/2, jpiglo-1 
    98                   iju = jpiglo-ji+1 
    99                   pt3d(ji,ijpjm1,jk) = psgn * pt3d(iju,ijpjm1,jk) 
    100                END DO 
    101             CASE ( 'V' )                               ! V-point 
    102                DO ji = 2, jpiglo 
    103                   ijt = jpiglo-ji+2 
    104                   pt3d(ji,ijpj-1,jk) = psgn * pt3d(ijt,ijpj-2,jk) 
    105                   pt3d(ji,ijpj  ,jk) = psgn * pt3d(ijt,ijpj-3,jk) 
    106                END DO 
    107                pt3d(1,ijpj,jk) = psgn * pt3d(3,ijpj-3,jk)  
    108             CASE ( 'F' )                               ! F-point 
    109                DO ji = 1, jpiglo-1 
    110                   iju = jpiglo-ji+1 
    111                   pt3d(ji,ijpj-1,jk) = psgn * pt3d(iju,ijpj-2,jk) 
    112                   pt3d(ji,ijpj  ,jk) = psgn * pt3d(iju,ijpj-3,jk) 
    113                END DO 
    114                pt3d(   1  ,ijpj,jk) = psgn * pt3d(    2   ,ijpj-3,jk) 
    115                pt3d(jpiglo,ijpj,jk) = psgn * pt3d(jpiglo-1,ijpj-3,jk)  
    116             END SELECT 
    117             ! 
    118          CASE ( 5 , 6 )                        ! *  North fold  F-point pivot 
    119             ! 
    120             SELECT CASE ( cd_type ) 
    121             CASE ( 'T' , 'W' )                         ! T-, W-point 
    122                DO ji = 1, jpiglo 
    123                   ijt = jpiglo-ji+1 
    124                   pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-1,jk) 
    125                END DO 
    126             CASE ( 'U' )                               ! U-point 
    127                DO ji = 1, jpiglo-1 
    128                   iju = jpiglo-ji 
    129                   pt3d(ji,ijpj,jk) = psgn * pt3d(iju,ijpj-1,jk) 
    130                END DO 
    131                pt3d(jpiglo,ijpj,jk) = psgn * pt3d(1,ijpj-1,jk) 
    132             CASE ( 'V' )                               ! V-point 
    133                DO ji = 1, jpiglo 
    134                   ijt = jpiglo-ji+1 
    135                   pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-2,jk) 
    136                END DO 
    137                DO ji = jpiglo/2+1, jpiglo 
    138                   ijt = jpiglo-ji+1 
    139                   pt3d(ji,ijpjm1,jk) = psgn * pt3d(ijt,ijpjm1,jk) 
    140                END DO 
    141             CASE ( 'F' )                               ! F-point 
    142                DO ji = 1, jpiglo-1 
    143                   iju = jpiglo-ji 
    144                   pt3d(ji,ijpj  ,jk) = psgn * pt3d(iju,ijpj-2,jk) 
    145                END DO 
    146                pt3d(jpiglo,ijpj,jk) = psgn * pt3d(1,ijpj-2,jk) 
    147                DO ji = jpiglo/2+1, jpiglo-1 
    148                   iju = jpiglo-ji 
    149                   pt3d(ji,ijpjm1,jk) = psgn * pt3d(iju,ijpjm1,jk) 
    150                END DO 
    151             END SELECT 
    152             ! 
    153          CASE DEFAULT                           ! *  closed : the code probably never go through 
    154             ! 
    155             SELECT CASE ( cd_type) 
    156             CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points 
    157                pt3d(:, 1  ,jk) = 0.e0 
    158                pt3d(:,ijpj,jk) = 0.e0 
    159             CASE ( 'F' )                               ! F-point 
    160                pt3d(:,ijpj,jk) = 0.e0 
    161             END SELECT 
    162             ! 
    163          END SELECT     !  npolj 
    164          ! 
    165       END DO 
    166       ! 
    167    END SUBROUTINE lbc_nfd_3d 
    168  
    169  
    170    SUBROUTINE lbc_nfd_2d( pt2d, cd_type, psgn, pr2dj ) 
     63   !!---------------------------------------------------------------------- 
     64   !!                   ***  routine lbc_nfd_(2,3,4)d  *** 
     65   !!---------------------------------------------------------------------- 
     66   !! 
     67   !! ** Purpose :   lateral boundary condition  
     68   !!                North fold treatment without processor exchanges.  
     69   !! 
     70   !! ** Method  :    
     71   !! 
     72   !! ** Action  :   ptab with updated values along the north fold 
     73   !!---------------------------------------------------------------------- 
     74   ! 
     75   !                       !==  2D array and array of 2D pointer  ==! 
     76   ! 
     77#  define DIM_2d 
     78#     define ROUTINE_NFD           lbc_nfd_2d 
     79#     include "lbc_nfd_generic.h90" 
     80#     undef ROUTINE_NFD 
     81#     define MULTI 
     82#     define ROUTINE_NFD           lbc_nfd_2d_ptr 
     83#     include "lbc_nfd_generic.h90" 
     84#     undef ROUTINE_NFD 
     85#     undef MULTI 
     86#  undef DIM_2d 
     87   ! 
     88   !                       !==  3D array and array of 3D pointer  ==! 
     89   ! 
     90#  define DIM_3d 
     91#     define ROUTINE_NFD           lbc_nfd_3d 
     92#     include "lbc_nfd_generic.h90" 
     93#     undef ROUTINE_NFD 
     94#     define MULTI 
     95#     define ROUTINE_NFD           lbc_nfd_3d_ptr 
     96#     include "lbc_nfd_generic.h90" 
     97#     undef ROUTINE_NFD 
     98#     undef MULTI 
     99#  undef DIM_3d 
     100   ! 
     101   !                       !==  4D array and array of 4D pointer  ==! 
     102   ! 
     103#  define DIM_4d 
     104#     define ROUTINE_NFD           lbc_nfd_4d 
     105#     include "lbc_nfd_generic.h90" 
     106#     undef ROUTINE_NFD 
     107#     define MULTI 
     108#     define ROUTINE_NFD           lbc_nfd_4d_ptr 
     109#     include "lbc_nfd_generic.h90" 
     110#     undef ROUTINE_NFD 
     111#     undef MULTI 
     112#  undef DIM_4d 
     113   ! 
     114   !  lbc_nfd_nogather routines 
     115   ! 
     116   !                       !==  2D array and array of 2D pointer  ==! 
     117   ! 
     118!#  define DIM_2d 
     119!#     define ROUTINE_NFD           lbc_nfd_nogather_2d 
     120!#     include "lbc_nfd_nogather_generic.h90" 
     121!#     undef ROUTINE_NFD 
     122!#     define MULTI 
     123!#     define ROUTINE_NFD           lbc_nfd_nogather_2d_ptr 
     124!#     include "lbc_nfd_nogather_generic.h90" 
     125!#     undef ROUTINE_NFD 
     126!#     undef MULTI 
     127!#  undef DIM_2d 
     128   ! 
     129   !                       !==  3D array and array of 3D pointer  ==! 
     130   ! 
     131!#  define DIM_3d 
     132!#     define ROUTINE_NFD           lbc_nfd_nogather_3d 
     133!#     include "lbc_nfd_nogather_generic.h90" 
     134!#     undef ROUTINE_NFD 
     135!#     define MULTI 
     136!#     define ROUTINE_NFD           lbc_nfd_nogather_3d_ptr 
     137!#     include "lbc_nfd_nogather_generic.h90" 
     138!#     undef ROUTINE_NFD 
     139!#     undef MULTI 
     140!#  undef DIM_3d 
     141   ! 
     142   !                       !==  4D array and array of 4D pointer  ==! 
     143   ! 
     144#  define DIM_4d 
     145#     define ROUTINE_NFD           lbc_nfd_nogather_4d 
     146#     include "lbc_nfd_nogather_generic.h90" 
     147#     undef ROUTINE_NFD 
     148!#     define MULTI 
     149!#     define ROUTINE_NFD           lbc_nfd_nogather_4d_ptr 
     150!#     include "lbc_nfd_nogather_generic.h90" 
     151!#     undef ROUTINE_NFD 
     152!#     undef MULTI 
     153#  undef DIM_4d 
     154 
     155   !!---------------------------------------------------------------------- 
     156 
     157 
     158!!gm   CAUTION HERE  optional pr2dj  not implemented in generic case 
     159!!gm                 furthermore, in the _org routine it is OK only for T-point pivot !! 
     160 
     161 
     162   SUBROUTINE lbc_nfd_2d_org( pt2d, cd_nat, psgn, pr2dj ) 
    171163      !!---------------------------------------------------------------------- 
    172164      !!                  ***  routine lbc_nfd_2d  *** 
     
    179171      !! ** Action  :   pt2d with updated values along the north fold 
    180172      !!---------------------------------------------------------------------- 
    181       CHARACTER(len=1)        , INTENT(in   ) ::   cd_type   ! define the nature of ptab array grid-points 
    182       !                                                      ! = T , U , V , F , W points 
    183       REAL(wp)                , INTENT(in   ) ::   psgn      ! control of the sign change 
    184       !                                                      !   = -1. , the sign is changed if north fold boundary 
    185       !                                                      !   =  1. , the sign is kept  if north fold boundary 
    186173      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d      ! 2D array on which the boundary condition is applied 
     174      CHARACTER(len=1)        , INTENT(in   ) ::   cd_nat   ! nature of pt2d grid-point 
     175      REAL(wp)                , INTENT(in   ) ::   psgn      ! sign used across north fold 
    187176      INTEGER , OPTIONAL      , INTENT(in   ) ::   pr2dj     ! number of additional halos 
    188177      ! 
     
    210199      CASE ( 3, 4 )                       ! *  North fold  T-point pivot 
    211200         ! 
    212          SELECT CASE ( cd_type ) 
     201         SELECT CASE ( cd_nat ) 
    213202         ! 
    214203         CASE ( 'T' , 'W' )                               ! T- , W-points 
     
    265254               END DO 
    266255            END DO 
    267          CASE ( 'J' )                                     ! first ice U-V point 
    268             DO jl =0, ipr2dj 
    269                pt2d(2,ijpj+jl) = psgn * pt2d(3,ijpj-1+jl) 
    270                DO ji = 3, jpiglo 
    271                   iju = jpiglo - ji + 3 
    272                   pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl) 
    273                END DO 
    274             END DO 
    275          CASE ( 'K' )                                     ! second ice U-V point 
    276             DO jl =0, ipr2dj 
    277                pt2d(2,ijpj+jl) = psgn * pt2d(3,ijpj-1+jl) 
    278                DO ji = 3, jpiglo 
    279                   iju = jpiglo - ji + 3 
    280                   pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl) 
    281                END DO 
    282             END DO 
    283256         END SELECT 
    284257         ! 
    285258      CASE ( 5, 6 )                        ! *  North fold  F-point pivot 
    286259         ! 
    287          SELECT CASE ( cd_type ) 
     260         SELECT CASE ( cd_nat ) 
    288261         CASE ( 'T' , 'W' )                               ! T-, W-point 
    289262            DO jl = 0, ipr2dj 
     
    325298            END DO 
    326299         CASE ( 'I' )                                  ! ice U-V point (I-point) 
    327             pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0.e0 
     300            pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0._wp 
    328301            DO jl = 0, ipr2dj 
    329302               DO ji = 2 , jpiglo-1 
     
    332305               END DO 
    333306            END DO 
    334          CASE ( 'J' )                                  ! first ice U-V point 
    335             pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0.e0 
    336             DO jl = 0, ipr2dj 
    337                DO ji = 2 , jpiglo-1 
    338                   ijt = jpiglo - ji + 2 
    339                   pt2d(ji,ijpj+jl)= pt2d(ji,ijpj-1-jl) 
    340                END DO 
    341             END DO 
    342          CASE ( 'K' )                                  ! second ice U-V point 
    343             pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0.e0 
    344             DO jl = 0, ipr2dj 
    345                DO ji = 2 , jpiglo-1 
    346                   ijt = jpiglo - ji + 2 
    347                   pt2d(ji,ijpj+jl)= pt2d(ijt,ijpj-1-jl) 
    348                END DO 
    349             END DO 
    350307         END SELECT 
    351308         ! 
    352309      CASE DEFAULT                           ! *  closed : the code probably never go through 
    353310         ! 
    354          SELECT CASE ( cd_type) 
     311         SELECT CASE ( cd_nat) 
    355312         CASE ( 'T' , 'U' , 'V' , 'W' )                 ! T-, U-, V-, W-points 
    356             pt2d(:, 1:1-ipr2dj     ) = 0.e0 
    357             pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0 
     313            pt2d(:, 1:1-ipr2dj     ) = 0._wp 
     314            pt2d(:,ijpj:ijpj+ipr2dj) = 0._wp 
    358315         CASE ( 'F' )                                   ! F-point 
    359             pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0 
     316            pt2d(:,ijpj:ijpj+ipr2dj) = 0._wp 
    360317         CASE ( 'I' )                                   ! ice U-V point 
    361             pt2d(:, 1:1-ipr2dj     ) = 0.e0 
    362             pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0 
    363          CASE ( 'J' )                                   ! first ice U-V point 
    364             pt2d(:, 1:1-ipr2dj     ) = 0.e0 
    365             pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0 
    366          CASE ( 'K' )                                   ! second ice U-V point 
    367             pt2d(:, 1:1-ipr2dj     ) = 0.e0 
    368             pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0 
     318            pt2d(:, 1:1-ipr2dj     ) = 0._wp 
     319            pt2d(:,ijpj:ijpj+ipr2dj) = 0._wp 
    369320         END SELECT 
    370321         ! 
    371322      END SELECT 
    372323      ! 
    373    END SUBROUTINE lbc_nfd_2d 
    374  
    375  
    376    SUBROUTINE mpp_lbc_nfd_3d( pt3dl, pt3dr, cd_type, psgn ) 
    377       !!---------------------------------------------------------------------- 
    378       !!                  ***  routine mpp_lbc_nfd_3d  *** 
    379       !! 
    380       !! ** Purpose :   3D lateral boundary condition : North fold treatment 
    381       !!              without processor exchanges.  
    382       !! 
    383       !! ** Method  :    
    384       !! 
    385       !! ** Action  :   pt3d with updated values along the north fold 
    386       !!---------------------------------------------------------------------- 
    387       CHARACTER(len=1)          , INTENT(in   ) ::   cd_type   ! define the nature of ptab array grid-points 
    388       !                                                        !   = T , U , V , F , W points 
    389       REAL(wp)                  , INTENT(in   ) ::   psgn      ! control of the sign change 
    390       !                                                        !   = -1. , the sign is changed if north fold boundary 
    391       !                                                        !   =  1. , the sign is kept    if north fold boundary 
    392       REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pt3dl     ! 3D array on which the boundary condition is applied 
    393       REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   pt3dr     ! 3D array on which the boundary condition is applied 
    394       ! 
    395       INTEGER  ::   ji, jk 
    396       INTEGER  ::   ijt, iju, ijpj, ijpjm1, ijta, ijua, jia, startloop, endloop 
    397       !!---------------------------------------------------------------------- 
    398       ! 
    399       SELECT CASE ( jpni ) 
    400       CASE ( 1 )     ;   ijpj = nlcj      ! 1 proc only  along the i-direction 
    401       CASE DEFAULT   ;   ijpj = 4         ! several proc along the i-direction 
    402       END SELECT 
    403       ijpjm1 = ijpj-1 
    404  
    405          ! 
    406          SELECT CASE ( npolj ) 
    407          ! 
    408          CASE ( 3 , 4 )                        ! *  North fold  T-point pivot 
    409             ! 
    410             SELECT CASE ( cd_type ) 
    411             CASE ( 'T' , 'W' )                         ! T-, W-point 
    412                IF (nimpp .ne. 1) THEN 
    413                  startloop = 1 
    414                ELSE 
    415                  startloop = 2 
    416                ENDIF 
    417  
    418                DO jk = 1, jpk 
    419                   DO ji = startloop, nlci 
    420                      ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    421                      pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-2,jk) 
    422                   END DO 
    423                   IF(nimpp .eq. 1) THEN 
    424                      pt3dl(1,ijpj,jk) = psgn * pt3dl(3,ijpj-2,jk) 
    425                   ENDIF 
    426                END DO 
    427  
    428                IF(nimpp .ge. (jpiglo/2+1)) THEN 
    429                  startloop = 1 
    430                ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 
    431                  startloop = jpiglo/2+1 - nimpp + 1 
    432                ELSE 
    433                  startloop = nlci + 1 
    434                ENDIF 
    435                IF(startloop .le. nlci) THEN 
    436                  DO jk = 1, jpk 
    437                     DO ji = startloop, nlci 
    438                        ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    439                        jia = ji + nimpp - 1 
    440                        ijta = jpiglo - jia + 2 
    441                        IF((ijta .ge. (startloop + nimpp - 1)) .and. (ijta .lt. jia)) THEN 
    442                           pt3dl(ji,ijpjm1,jk) = psgn * pt3dl(ijta-nimpp+1,ijpjm1,jk) 
    443                        ELSE 
    444                           pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(ijt,ijpjm1,jk) 
    445                        ENDIF 
    446                     END DO 
    447                  END DO 
    448                ENDIF 
    449  
    450  
    451             CASE ( 'U' )                               ! U-point 
    452                IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    453                   endloop = nlci 
    454                ELSE 
    455                   endloop = nlci - 1 
    456                ENDIF 
    457                DO jk = 1, jpk 
    458                   DO ji = 1, endloop 
    459                      iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    460                      pt3dl(ji,ijpj,jk) = psgn * pt3dr(iju,ijpj-2,jk) 
    461                   END DO 
    462                   IF(nimpp .eq. 1) THEN 
    463                      pt3dl(   1  ,ijpj,jk) = psgn * pt3dl(    2   ,ijpj-2,jk) 
    464                   ENDIF 
    465                   IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
    466                      pt3dl(nlci,ijpj,jk) = psgn * pt3dl(nlci-1,ijpj-2,jk) 
    467                   ENDIF 
    468                END DO 
    469  
    470                IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    471                   endloop = nlci 
    472                ELSE 
    473                   endloop = nlci - 1 
    474                ENDIF 
    475                IF(nimpp .ge. (jpiglo/2)) THEN 
    476                   startloop = 1 
    477                ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2)) .AND. (nimpp .lt. (jpiglo/2))) THEN 
    478                   startloop = jpiglo/2 - nimpp + 1 
    479                ELSE 
    480                   startloop = endloop + 1 
    481                ENDIF 
    482                IF (startloop .le. endloop) THEN 
    483                  DO jk = 1, jpk 
    484                     DO ji = startloop, endloop 
    485                       iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    486                       jia = ji + nimpp - 1 
    487                       ijua = jpiglo - jia + 1 
    488                       IF((ijua .ge. (startloop + nimpp - 1)) .and. (ijua .lt. jia)) THEN 
    489                         pt3dl(ji,ijpjm1,jk) = psgn * pt3dl(ijua-nimpp+1,ijpjm1,jk) 
    490                       ELSE 
    491                         pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(iju,ijpjm1,jk) 
    492                       ENDIF 
    493                     END DO 
    494                  END DO 
    495                ENDIF 
    496  
    497             CASE ( 'V' )                               ! V-point 
    498                IF (nimpp .ne. 1) THEN 
    499                   startloop = 1 
    500                ELSE 
    501                   startloop = 2 
    502                ENDIF 
    503                DO jk = 1, jpk 
    504                   DO ji = startloop, nlci 
    505                      ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    506                      pt3dl(ji,ijpj-1,jk) = psgn * pt3dr(ijt,ijpj-2,jk) 
    507                      pt3dl(ji,ijpj  ,jk) = psgn * pt3dr(ijt,ijpj-3,jk) 
    508                   END DO 
    509                   IF(nimpp .eq. 1) THEN 
    510                      pt3dl(1,ijpj,jk) = psgn * pt3dl(3,ijpj-3,jk) 
    511                   ENDIF 
    512                END DO 
    513             CASE ( 'F' )                               ! F-point 
    514                IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    515                   endloop = nlci 
    516                ELSE 
    517                   endloop = nlci - 1 
    518                ENDIF 
    519                DO jk = 1, jpk 
    520                   DO ji = 1, endloop 
    521                      iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    522                      pt3dl(ji,ijpj-1,jk) = psgn * pt3dr(iju,ijpj-2,jk) 
    523                      pt3dl(ji,ijpj  ,jk) = psgn * pt3dr(iju,ijpj-3,jk) 
    524                   END DO 
    525                   IF(nimpp .eq. 1) THEN 
    526                      pt3dl(   1  ,ijpj,jk) = psgn * pt3dl(    2   ,ijpj-3,jk) 
    527                   ENDIF 
    528                   IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
    529                      pt3dl(nlci,ijpj,jk) = psgn * pt3dl(nlci-1,ijpj-3,jk) 
    530                   ENDIF 
    531                END DO 
    532             END SELECT 
    533             ! 
    534  
    535          CASE ( 5 , 6 )                        ! *  North fold  F-point pivot 
    536             ! 
    537             SELECT CASE ( cd_type ) 
    538             CASE ( 'T' , 'W' )                         ! T-, W-point 
    539                DO jk = 1, jpk 
    540                   DO ji = 1, nlci 
    541                      ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    542                      pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-1,jk) 
    543                   END DO 
    544                END DO 
    545  
    546             CASE ( 'U' )                               ! U-point 
    547                IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    548                   endloop = nlci 
    549                ELSE 
    550                   endloop = nlci - 1 
    551                ENDIF 
    552                DO jk = 1, jpk 
    553                   DO ji = 1, endloop 
    554                      iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
    555                      pt3dl(ji,ijpj,jk) = psgn * pt3dr(iju,ijpj-1,jk) 
    556                   END DO 
    557                   IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
    558                      pt3dl(nlci,ijpj,jk) = psgn * pt3dr(1,ijpj-1,jk) 
    559                   ENDIF 
    560                END DO 
    561  
    562             CASE ( 'V' )                               ! V-point 
    563                DO jk = 1, jpk 
    564                   DO ji = 1, nlci 
    565                      ijt = jpiglo - ji- nimpp - nfiimpp(isendto(1),jpnj) + 3 
    566                      pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-2,jk) 
    567                   END DO 
    568                END DO 
    569  
    570                IF(nimpp .ge. (jpiglo/2+1)) THEN 
    571                   startloop = 1 
    572                ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 
    573                   startloop = jpiglo/2+1 - nimpp + 1 
    574                ELSE 
    575                   startloop = nlci + 1 
    576                ENDIF 
    577                IF(startloop .le. nlci) THEN 
    578                  DO jk = 1, jpk 
    579                     DO ji = startloop, nlci 
    580                        ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    581                        pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(ijt,ijpjm1,jk) 
    582                     END DO 
    583                  END DO 
    584                ENDIF 
    585  
    586             CASE ( 'F' )                               ! F-point 
    587                IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    588                   endloop = nlci 
    589                ELSE 
    590                   endloop = nlci - 1 
    591                ENDIF 
    592                DO jk = 1, jpk 
    593                   DO ji = 1, endloop 
    594                      iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
    595                      pt3dl(ji,ijpj ,jk) = psgn * pt3dr(iju,ijpj-2,jk) 
    596                   END DO 
    597                   IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
    598                      pt3dl(nlci,ijpj,jk) = psgn * pt3dr(1,ijpj-2,jk) 
    599                   ENDIF 
    600                END DO 
    601  
    602                IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    603                   endloop = nlci 
    604                ELSE 
    605                   endloop = nlci - 1 
    606                ENDIF 
    607                IF(nimpp .ge. (jpiglo/2+1)) THEN 
    608                   startloop = 1 
    609                ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 
    610                   startloop = jpiglo/2+1 - nimpp + 1 
    611                ELSE 
    612                   startloop = endloop + 1 
    613                ENDIF 
    614                IF (startloop .le. endloop) THEN 
    615                   DO jk = 1, jpk 
    616                      DO ji = startloop, endloop 
    617                         iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
    618                         pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(iju,ijpjm1,jk) 
    619                      END DO 
    620                   END DO 
    621                ENDIF 
    622  
    623             END SELECT 
    624  
    625          CASE DEFAULT                           ! *  closed : the code probably never go through 
    626             ! 
    627             SELECT CASE ( cd_type) 
    628             CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points 
    629                pt3dl(:, 1  ,jk) = 0.e0 
    630                pt3dl(:,ijpj,jk) = 0.e0 
    631             CASE ( 'F' )                               ! F-point 
    632                pt3dl(:,ijpj,jk) = 0.e0 
    633             END SELECT 
    634             ! 
    635          END SELECT     !  npolj 
    636          ! 
    637       ! 
    638    END SUBROUTINE mpp_lbc_nfd_3d 
    639  
    640  
    641    SUBROUTINE mpp_lbc_nfd_2d( pt2dl, pt2dr, cd_type, psgn ) 
    642       !!---------------------------------------------------------------------- 
    643       !!                  ***  routine mpp_lbc_nfd_2d  *** 
    644       !! 
    645       !! ** Purpose :   2D lateral boundary condition : North fold treatment 
    646       !!       without processor exchanges.  
    647       !! 
    648       !! ** Method  :    
    649       !! 
    650       !! ** Action  :   pt2d with updated values along the north fold 
    651       !!---------------------------------------------------------------------- 
    652       CHARACTER(len=1)        , INTENT(in   ) ::   cd_type   ! define the nature of ptab array grid-points 
    653       !                                                      ! = T , U , V , F , W points 
    654       REAL(wp)                , INTENT(in   ) ::   psgn      ! control of the sign change 
    655       !                                                      !   = -1. , the sign is changed if north fold boundary 
    656       !                                                      !   =  1. , the sign is kept  if north fold boundary 
    657       REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2dl     ! 2D array on which the boundary condition is applied 
    658       REAL(wp), DIMENSION(:,:), INTENT(in   ) ::   pt2dr     ! 2D array on which the boundary condition is applied 
    659       ! 
    660       INTEGER  ::   ji 
    661       INTEGER  ::   ijt, iju, ijpj, ijpjm1, ijta, ijua, jia, startloop, endloop 
    662       !!---------------------------------------------------------------------- 
    663  
    664       SELECT CASE ( jpni ) 
    665       CASE ( 1 )     ;   ijpj = nlcj      ! 1 proc only  along the i-direction 
    666       CASE DEFAULT   ;   ijpj = 4         ! several proc along the i-direction 
    667       END SELECT 
    668       ! 
    669       ijpjm1 = ijpj-1 
    670  
    671  
    672       SELECT CASE ( npolj ) 
    673       ! 
    674       CASE ( 3, 4 )                       ! *  North fold  T-point pivot 
    675          ! 
    676          SELECT CASE ( cd_type ) 
    677          ! 
    678          CASE ( 'T' , 'W' )                               ! T- , W-points 
    679             IF (nimpp .ne. 1) THEN 
    680               startloop = 1 
    681             ELSE 
    682               startloop = 2 
    683             ENDIF 
    684             DO ji = startloop, nlci 
    685               ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    686               pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-1) 
    687             END DO 
    688             IF (nimpp .eq. 1) THEN 
    689               pt2dl(1,ijpj)   = psgn * pt2dl(3,ijpj-2) 
    690             ENDIF 
    691  
    692             IF(nimpp .ge. (jpiglo/2+1)) THEN 
    693                startloop = 1 
    694             ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 
    695                startloop = jpiglo/2+1 - nimpp + 1 
    696             ELSE 
    697                startloop = nlci + 1 
    698             ENDIF 
    699             DO ji = startloop, nlci 
    700                ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    701                jia = ji + nimpp - 1 
    702                ijta = jpiglo - jia + 2 
    703                IF((ijta .ge. (startloop + nimpp - 1)) .and. (ijta .lt. jia)) THEN 
    704                   pt2dl(ji,ijpjm1) = psgn * pt2dl(ijta-nimpp+1,ijpjm1) 
    705                ELSE 
    706                   pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1) 
    707                ENDIF 
    708             END DO 
    709  
    710          CASE ( 'U' )                                     ! U-point 
    711             IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    712                endloop = nlci 
    713             ELSE 
    714                endloop = nlci - 1 
    715             ENDIF 
    716             DO ji = 1, endloop 
    717                iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    718                pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-1) 
    719             END DO 
    720  
    721             IF (nimpp .eq. 1) THEN 
    722               pt2dl(   1  ,ijpj  ) = psgn * pt2dl(    2   ,ijpj-2) 
    723               pt2dl(1     ,ijpj-1) = psgn * pt2dr(jpiglo - nfiimpp(isendto(1), jpnj) + 1, ijpj-1) 
    724             ENDIF 
    725             IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
    726               pt2dl(nlci,ijpj  ) = psgn * pt2dl(nlci-1,ijpj-2) 
    727             ENDIF 
    728  
    729             IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    730                endloop = nlci 
    731             ELSE 
    732                endloop = nlci - 1 
    733             ENDIF 
    734             IF(nimpp .ge. (jpiglo/2)) THEN 
    735                startloop = 1 
    736             ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2)) .AND. (nimpp .lt. (jpiglo/2))) THEN 
    737                startloop = jpiglo/2 - nimpp + 1 
    738             ELSE 
    739                startloop = endloop + 1 
    740             ENDIF 
    741             DO ji = startloop, endloop 
    742                iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    743                jia = ji + nimpp - 1 
    744                ijua = jpiglo - jia + 1 
    745                IF((ijua .ge. (startloop + nimpp - 1)) .and. (ijua .lt. jia)) THEN 
    746                   pt2dl(ji,ijpjm1) = psgn * pt2dl(ijua-nimpp+1,ijpjm1) 
    747                ELSE 
    748                   pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1) 
    749                ENDIF 
    750             END DO 
    751  
    752          CASE ( 'V' )                                     ! V-point 
    753             IF (nimpp .ne. 1) THEN 
    754               startloop = 1 
    755             ELSE 
    756               startloop = 2 
    757             ENDIF 
    758             DO ji = startloop, nlci 
    759               ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    760               pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1-1) 
    761               pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-2) 
    762             END DO 
    763             IF (nimpp .eq. 1) THEN 
    764               pt2dl( 1 ,ijpj)   = psgn * pt2dl( 3 ,ijpj-3)  
    765             ENDIF 
    766  
    767          CASE ( 'F' )                                     ! F-point 
    768             IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    769                endloop = nlci 
    770             ELSE 
    771                endloop = nlci - 1 
    772             ENDIF 
    773             DO ji = 1, endloop 
    774                iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    775                pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1-1) 
    776                pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-2) 
    777             END DO 
    778             IF (nimpp .eq. 1) THEN 
    779               pt2dl(   1  ,ijpj)   = psgn * pt2dl(    2   ,ijpj-3) 
    780               pt2dl(   1  ,ijpj-1) = psgn * pt2dl(    2   ,ijpj-2) 
    781             ENDIF 
    782             IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
    783               pt2dl(nlci,ijpj)   = psgn * pt2dl(nlci-1,ijpj-3) 
    784               pt2dl(nlci,ijpj-1) = psgn * pt2dl(nlci-1,ijpj-2)  
    785             ENDIF 
    786  
    787          CASE ( 'I' )                                     ! ice U-V point (I-point) 
    788             IF (nimpp .ne. 1) THEN 
    789                startloop = 1 
    790             ELSE 
    791                startloop = 3 
    792                pt2dl(2,ijpj) = psgn * pt2dr(3,ijpjm1) 
    793             ENDIF 
    794             DO ji = startloop, nlci 
    795                iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 5 
    796                pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 
    797             END DO 
    798  
    799          CASE ( 'J' )                                     ! first ice U-V point 
    800             IF (nimpp .ne. 1) THEN 
    801                startloop = 1 
    802             ELSE 
    803                startloop = 3 
    804                pt2dl(2,ijpj) = psgn * pt2dl(3,ijpjm1) 
    805             ENDIF 
    806             DO ji = startloop, nlci 
    807                iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 5 
    808                pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 
    809             END DO 
    810  
    811          CASE ( 'K' )                                     ! second ice U-V point 
    812             IF (nimpp .ne. 1) THEN 
    813                startloop = 1 
    814             ELSE 
    815                startloop = 3 
    816                pt2dl(2,ijpj) = psgn * pt2dl(3,ijpjm1) 
    817             ENDIF 
    818             DO ji = startloop, nlci 
    819                iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 5 
    820                pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 
    821             END DO 
    822  
    823          END SELECT 
    824          ! 
    825       CASE ( 5, 6 )                        ! *  North fold  F-point pivot 
    826          ! 
    827          SELECT CASE ( cd_type ) 
    828          CASE ( 'T' , 'W' )                               ! T-, W-point 
    829             DO ji = 1, nlci 
    830                ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    831                pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1) 
    832             END DO 
    833  
    834          CASE ( 'U' )                                     ! U-point 
    835             IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    836                endloop = nlci 
    837             ELSE 
    838                endloop = nlci - 1 
    839             ENDIF 
    840             DO ji = 1, endloop 
    841                iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
    842                pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 
    843             END DO 
    844             IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
    845                pt2dl(nlci,ijpj) = psgn * pt2dr(1,ijpj-1) 
    846             ENDIF 
    847  
    848          CASE ( 'V' )                                     ! V-point 
    849             DO ji = 1, nlci 
    850                ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    851                pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-1) 
    852             END DO 
    853             IF(nimpp .ge. (jpiglo/2+1)) THEN 
    854                startloop = 1 
    855             ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 
    856                startloop = jpiglo/2+1 - nimpp + 1 
    857             ELSE 
    858                startloop = nlci + 1 
    859             ENDIF 
    860             DO ji = startloop, nlci 
    861                ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    862                pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1) 
    863             END DO 
    864  
    865          CASE ( 'F' )                               ! F-point 
    866             IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    867                endloop = nlci 
    868             ELSE 
    869                endloop = nlci - 1 
    870             ENDIF 
    871             DO ji = 1, endloop 
    872                iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
    873                pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-1) 
    874             END DO 
    875             IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
    876                 pt2dl(nlci,ijpj) = psgn * pt2dr(1,ijpj-2) 
    877             ENDIF 
    878  
    879             IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    880                endloop = nlci 
    881             ELSE 
    882                endloop = nlci - 1 
    883             ENDIF 
    884             IF(nimpp .ge. (jpiglo/2+1)) THEN 
    885                startloop = 1 
    886             ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 
    887                startloop = jpiglo/2+1 - nimpp + 1 
    888             ELSE 
    889                startloop = endloop + 1 
    890             ENDIF 
    891  
    892             DO ji = startloop, endloop 
    893                iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
    894                pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1) 
    895             END DO 
    896  
    897          CASE ( 'I' )                                  ! ice U-V point (I-point) 
    898                IF (nimpp .ne. 1) THEN 
    899                   startloop = 1 
    900                ELSE 
    901                   startloop = 2 
    902                ENDIF 
    903                IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    904                   endloop = nlci 
    905                ELSE 
    906                   endloop = nlci - 1 
    907                ENDIF 
    908                DO ji = startloop , endloop 
    909                   ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    910                   pt2dl(ji,ijpj)= 0.5 * (pt2dl(ji,ijpjm1) + psgn * pt2dr(ijt,ijpjm1)) 
    911                END DO 
    912  
    913          CASE ( 'J' )                                  ! first ice U-V point 
    914                IF (nimpp .ne. 1) THEN 
    915                   startloop = 1 
    916                ELSE 
    917                   startloop = 2 
    918                ENDIF 
    919                IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    920                   endloop = nlci 
    921                ELSE 
    922                   endloop = nlci - 1 
    923                ENDIF 
    924                DO ji = startloop , endloop 
    925                   ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    926                   pt2dl(ji,ijpj) = pt2dl(ji,ijpjm1) 
    927                END DO 
    928  
    929          CASE ( 'K' )                                  ! second ice U-V point 
    930                IF (nimpp .ne. 1) THEN 
    931                   startloop = 1 
    932                ELSE 
    933                   startloop = 2 
    934                ENDIF 
    935                IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 
    936                   endloop = nlci 
    937                ELSE 
    938                   endloop = nlci - 1 
    939                ENDIF 
    940                DO ji = startloop, endloop 
    941                   ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    942                   pt2dl(ji,ijpj) = pt2dr(ijt,ijpjm1) 
    943                END DO 
    944  
    945          END SELECT 
    946          ! 
    947       CASE DEFAULT                           ! *  closed : the code probably never go through 
    948          ! 
    949          SELECT CASE ( cd_type) 
    950          CASE ( 'T' , 'U' , 'V' , 'W' )                 ! T-, U-, V-, W-points 
    951             pt2dl(:, 1     ) = 0.e0 
    952             pt2dl(:,ijpj) = 0.e0 
    953          CASE ( 'F' )                                   ! F-point 
    954             pt2dl(:,ijpj) = 0.e0 
    955          CASE ( 'I' )                                   ! ice U-V point 
    956             pt2dl(:, 1     ) = 0.e0 
    957             pt2dl(:,ijpj) = 0.e0 
    958          CASE ( 'J' )                                   ! first ice U-V point 
    959             pt2dl(:, 1     ) = 0.e0 
    960             pt2dl(:,ijpj) = 0.e0 
    961          CASE ( 'K' )                                   ! second ice U-V point 
    962             pt2dl(:, 1     ) = 0.e0 
    963             pt2dl(:,ijpj) = 0.e0 
    964          END SELECT 
    965          ! 
    966       END SELECT 
    967       ! 
    968    END SUBROUTINE mpp_lbc_nfd_2d 
     324   END SUBROUTINE lbc_nfd_2d_org 
    969325 
    970326   !!====================================================================== 
  • branches/2017/dev_r8183_ICEMODEL/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90

    r7753 r8226  
    88   !!            8.0  !  1998  (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI 
    99   !!                 !  1998  (J.M. Molines) Open boundary conditions 
    10    !!   NEMO     1.0  !  2003  (J.-M. Molines, G. Madec)  F90, free form 
     10   !!   NEMO     1.0  !  2003  (J.M. Molines, G. Madec)  F90, free form 
    1111   !!                 !  2003  (J.M. Molines) add mpp_ini_north(_3d,_2d) 
    1212   !!             -   !  2004  (R. Bourdalle Badie)  isend option in mpi 
     
    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 
    26    !!            3.6  !  2015 (O. Tintó and M. Castrillo - BSC) Added 'mpp_lnk_2d_multiple', 'mpp_lbc_north_2d_multiple', 'mpp_max_multiple'  
     24   !!            3.6  !  2015  (O. Tintó and M. Castrillo - BSC) Added '_multiple' case for 2D lbc and max 
     25   !!            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 
    2727   !!---------------------------------------------------------------------- 
    2828 
     
    4141   !!   mynode        : indentify the processor unit 
    4242   !!   mpp_lnk       : interface (defined in lbclnk) for message passing of 2d or 3d arrays (mpp_lnk_2d, mpp_lnk_3d) 
    43    !!   mpp_lnk_3d_gather :  Message passing manadgement for two 3D arrays 
    4443   !!   mpp_lnk_e     : interface (defined in lbclnk) for message passing of 2d array with extra halo (mpp_lnk_2d_e) 
    4544   !!   mpp_lnk_icb   : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb) 
    4645   !!   mpprecv       : 
    47    !!   mppsend       :   SUBROUTINE mpp_ini_znl 
     46   !!   mppsend       : 
    4847   !!   mppscatter    : 
    4948   !!   mppgather     : 
     
    5655   !!   mppstop       : 
    5756   !!   mpp_ini_north : initialisation of north fold 
    58    !!   mpp_lbc_north : north fold processors gathering 
     57!!gm   !!   mpp_lbc_north : north fold processors gathering 
    5958   !!   mpp_lbc_north_e : variant of mpp_lbc_north for extra outer halo 
    6059   !!   mpp_lbc_north_icb : variant of mpp_lbc_north for extra outer halo with icebergs 
     
    6766   IMPLICIT NONE 
    6867   PRIVATE 
    69     
     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   ! 
    7084   PUBLIC   ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam 
    7185   PUBLIC   mynode, mppstop, mppsync, mpp_comm_free 
    72    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 
    7389   PUBLIC   mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 
    7490   PUBLIC   mpp_max_multiple 
    75    PUBLIC   mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e 
    76    PUBLIC   mpp_lnk_2d_9 , mpp_lnk_2d_multiple  
    77    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 
    7893   PUBLIC   mppscatter, mppgather 
    7994   PUBLIC   mpp_ini_ice, mpp_ini_znl 
     
    8196   PUBLIC   mppsend, mpprecv                          ! needed by TAM and ICB routines 
    8297   PUBLIC   mpp_lnk_bdy_2d, mpp_lnk_bdy_3d 
    83    PUBLIC   mpp_lbc_north_icb, mpp_lnk_2d_icb 
    8498   PUBLIC   mpprank 
    85  
    86    TYPE arrayptr 
    87       REAL , DIMENSION (:,:),  POINTER :: pt2d 
    88    END TYPE arrayptr 
    89    PUBLIC   arrayptr 
    9099    
    91100   !! * Interfaces 
     
    101110   INTERFACE mpp_sum 
    102111      MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real,   & 
    103                        mppsum_realdd, mppsum_a_realdd 
     112         &             mppsum_realdd, mppsum_a_realdd 
    104113   END INTERFACE 
    105    INTERFACE mpp_lbc_north 
    106       MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d 
    107    END INTERFACE 
     114!!gm   INTERFACE mpp_lbc_north 
     115!!gm      MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d 
     116!!gm   END INTERFACE 
    108117   INTERFACE mpp_minloc 
    109118      MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d 
     
    112121      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 
    113122   END INTERFACE 
    114  
    115123   INTERFACE mpp_max_multiple 
    116124      MODULE PROCEDURE mppmax_real_multiple 
     
    138146   ! variables used in case of sea-ice 
    139147   INTEGER, PUBLIC ::   ncomm_ice       !: communicator made by the processors with sea-ice (public so that it can be freed in limthd) 
    140    INTEGER ::   ngrp_iworld     !  group ID for the world processors (for rheology) 
    141    INTEGER ::   ngrp_ice        !  group ID for the ice processors (for rheology) 
    142    INTEGER ::   ndim_rank_ice   !  number of 'ice' processors 
    143    INTEGER ::   n_ice_root      !  number (in the comm_ice) of proc 0 in the ice comm 
     148   INTEGER         ::   ngrp_iworld     !  group ID for the world processors (for rheology) 
     149   INTEGER         ::   ngrp_ice        !  group ID for the ice processors (for rheology) 
     150   INTEGER         ::   ndim_rank_ice   !  number of 'ice' processors 
     151   INTEGER         ::   n_ice_root      !  number (in the comm_ice) of proc 0 in the ice comm 
    144152   INTEGER, DIMENSION(:), ALLOCATABLE, SAVE ::   nrank_ice     ! dimension ndim_rank_ice 
    145153 
    146154   ! variables used for zonal integration 
    147155   INTEGER, PUBLIC ::   ncomm_znl       !: communicator made by the processors on the same zonal average 
    148    LOGICAL, PUBLIC ::   l_znl_root      ! True on the 'left'most processor on the same row 
    149    INTEGER ::   ngrp_znl        ! group ID for the znl processors 
    150    INTEGER ::   ndim_rank_znl   ! number of processors on the same zonal average 
     156   LOGICAL, PUBLIC ::   l_znl_root      !: True on the 'left'most processor on the same row 
     157   INTEGER         ::   ngrp_znl        ! group ID for the znl processors 
     158   INTEGER         ::   ndim_rank_znl   ! number of processors on the same zonal average 
    151159   INTEGER, DIMENSION(:), ALLOCATABLE, SAVE ::   nrank_znl  ! dimension ndim_rank_znl, number of the procs into the same znl domain 
    152160 
    153161   ! North fold condition in mpp_mpi with jpni > 1 (PUBLIC for TAM) 
    154    INTEGER, PUBLIC ::   ngrp_world        ! group ID for the world processors 
    155    INTEGER, PUBLIC ::   ngrp_opa          ! group ID for the opa processors 
    156    INTEGER, PUBLIC ::   ngrp_north        ! group ID for the northern processors (to be fold) 
    157    INTEGER, PUBLIC ::   ncomm_north       ! communicator made by the processors belonging to ngrp_north 
    158    INTEGER, PUBLIC ::   ndim_rank_north   ! number of 'sea' processor in the northern line (can be /= jpni !) 
    159    INTEGER, PUBLIC ::   njmppmax          ! value of njmpp for the processors of the northern line 
    160    INTEGER, PUBLIC ::   north_root        ! number (in the comm_opa) of proc 0 in the northern comm 
    161    INTEGER, DIMENSION(:), ALLOCATABLE, SAVE, PUBLIC ::   nrank_north   ! dimension ndim_rank_north 
     162   INTEGER, PUBLIC ::   ngrp_world        !: group ID for the world processors 
     163   INTEGER, PUBLIC ::   ngrp_opa          !: group ID for the opa processors 
     164   INTEGER, PUBLIC ::   ngrp_north        !: group ID for the northern processors (to be fold) 
     165   INTEGER, PUBLIC ::   ncomm_north       !: communicator made by the processors belonging to ngrp_north 
     166   INTEGER, PUBLIC ::   ndim_rank_north   !: number of 'sea' processor in the northern line (can be /= jpni !) 
     167   INTEGER, PUBLIC ::   njmppmax          !: value of njmpp for the processors of the northern line 
     168   INTEGER, PUBLIC ::   north_root        !: number (in the comm_opa) of proc 0 in the northern comm 
     169   INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE, SAVE ::   nrank_north   !: dimension ndim_rank_north 
    162170 
    163171   ! Type of send : standard, buffered, immediate 
    164    CHARACTER(len=1), PUBLIC ::   cn_mpi_send   ! type od mpi send/recieve (S=standard, B=bsend, I=isend) 
    165    LOGICAL, PUBLIC          ::   l_isend = .FALSE.   ! isend use indicator (T if cn_mpi_send='I') 
    166    INTEGER, PUBLIC          ::   nn_buffer     ! size of the buffer in case of mpi_bsend 
    167  
    168    REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: tampon  ! buffer in case of bsend 
    169  
    170    LOGICAL, PUBLIC                                  ::   ln_nnogather       ! namelist control of northfold comms 
    171    LOGICAL, PUBLIC                                  ::   l_north_nogather = .FALSE.  ! internal control of northfold comms 
    172    INTEGER, PUBLIC                                  ::   ityp 
    173    !!---------------------------------------------------------------------- 
    174    !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
     172   CHARACTER(len=1), PUBLIC ::   cn_mpi_send        !: type od mpi send/recieve (S=standard, B=bsend, I=isend) 
     173   LOGICAL         , PUBLIC ::   l_isend = .FALSE.  !: isend use indicator (T if cn_mpi_send='I') 
     174   INTEGER         , PUBLIC ::   nn_buffer          !: size of the buffer in case of mpi_bsend 
     175 
     176   REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE ::   tampon   ! buffer in case of bsend 
     177 
     178   LOGICAL, PUBLIC ::   ln_nnogather                !: namelist control of northfold comms 
     179   LOGICAL, PUBLIC ::   l_north_nogather = .FALSE.  !: internal control of northfold comms 
     180 
     181   !!---------------------------------------------------------------------- 
     182   !! NEMO/OPA 4.0 , NEMO Consortium (2017) 
    175183   !! $Id$ 
    176184   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
     
    178186CONTAINS 
    179187 
    180  
    181    FUNCTION mynode( ldtxt, ldname, kumnam_ref , kumnam_cfg , kumond , kstop, localComm ) 
     188   FUNCTION mynode( ldtxt, ldname, kumnam_ref, kumnam_cfg, kumond, kstop, localComm ) 
    182189      !!---------------------------------------------------------------------- 
    183190      !!                  ***  routine mynode  *** 
     
    204211      WRITE(ldtxt(ii),*) '~~~~~~ '                                                        ;   ii = ii + 1 
    205212      ! 
    206  
    207213      REWIND( kumnam_ref )              ! Namelist nammpp in reference namelist: mpi variables 
    208214      READ  ( kumnam_ref, nammpp, IOSTAT = ios, ERR = 901) 
    209215901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'nammpp in reference namelist', lwp ) 
    210  
     216      ! 
    211217      REWIND( kumnam_cfg )              ! Namelist nammpp in configuration namelist: mpi variables 
    212218      READ  ( kumnam_cfg, nammpp, IOSTAT = ios, ERR = 902 ) 
    213219902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'nammpp in configuration namelist', lwp ) 
    214  
     220      ! 
    215221      !                              ! control print 
    216222      WRITE(ldtxt(ii),*) '   Namelist nammpp'                                             ;   ii = ii + 1 
    217223      WRITE(ldtxt(ii),*) '      mpi send type          cn_mpi_send = ', cn_mpi_send       ;   ii = ii + 1 
    218224      WRITE(ldtxt(ii),*) '      size exported buffer   nn_buffer   = ', nn_buffer,' bytes';   ii = ii + 1 
    219  
     225      ! 
    220226#if defined key_agrif 
    221227      IF( .NOT. Agrif_Root() ) THEN 
     
    225231      ENDIF 
    226232#endif 
    227  
    228       IF(jpnij < 1)THEN 
    229          ! If jpnij is not specified in namelist then we calculate it - this 
    230          ! means there will be no land cutting out. 
    231          jpnij = jpni * jpnj 
    232       END IF 
    233  
    234       IF( (jpni < 1) .OR. (jpnj < 1) )THEN 
     233      ! 
     234      IF( jpnij < 1 ) THEN         ! If jpnij is not specified in namelist then we calculate it 
     235         jpnij = jpni * jpnj       ! this means there will be no land cutting out. 
     236      ENDIF 
     237 
     238      IF( jpni < 1 .OR. jpnj < 1  ) THEN 
    235239         WRITE(ldtxt(ii),*) '      jpni, jpnj and jpnij will be calculated automatically' ;   ii = ii + 1 
    236240      ELSE 
     
    238242         WRITE(ldtxt(ii),*) '      processor grid extent in j         jpnj = ',jpnj       ;   ii = ii + 1 
    239243         WRITE(ldtxt(ii),*) '      number of local domains           jpnij = ',jpnij      ;   ii = ii + 1 
    240       END IF 
     244      ENDIF 
    241245 
    242246      WRITE(ldtxt(ii),*) '      avoid use of mpi_allgather at the north fold  ln_nnogather = ', ln_nnogather  ; ii = ii + 1 
     
    268272            kstop = kstop + 1 
    269273         END SELECT 
    270       ELSE IF ( PRESENT(localComm) .and. .not. mpi_was_called ) THEN 
     274         ! 
     275      ELSEIF ( PRESENT(localComm) .AND. .NOT. mpi_was_called ) THEN 
    271276         WRITE(ldtxt(ii),*) ' lib_mpp: You cannot provide a local communicator '          ;   ii = ii + 1 
    272277         WRITE(ldtxt(ii),*) '          without calling MPI_Init before ! '                ;   ii = ii + 1 
     
    309314 
    310315#if defined key_agrif 
    311       IF (Agrif_Root()) THEN 
     316      IF( Agrif_Root() ) THEN 
    312317         CALL Agrif_MPI_Init(mpi_comm_opa) 
    313318      ELSE 
     
    329334   END FUNCTION mynode 
    330335 
    331  
    332    SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp, pval ) 
    333       !!---------------------------------------------------------------------- 
    334       !!                  ***  routine mpp_lnk_3d  *** 
    335       !! 
    336       !! ** Purpose :   Message passing manadgement 
    337       !! 
    338       !! ** Method  :   Use mppsend and mpprecv function for passing mask 
    339       !!      between processors following neighboring subdomains. 
    340       !!            domain parameters 
    341       !!                    nlci   : first dimension of the local subdomain 
    342       !!                    nlcj   : second dimension of the local subdomain 
    343       !!                    nbondi : mark for "east-west local boundary" 
    344       !!                    nbondj : mark for "north-south local boundary" 
    345       !!                    noea   : number for local neighboring processors 
    346       !!                    nowe   : number for local neighboring processors 
    347       !!                    noso   : number for local neighboring processors 
    348       !!                    nono   : number for local neighboring processors 
    349       !! 
    350       !! ** Action  :   ptab with update value at its periphery 
    351       !! 
    352       !!---------------------------------------------------------------------- 
    353       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied 
    354       CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points 
    355       !                                                             ! = T , U , V , F , W points 
    356       REAL(wp)                        , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary 
    357       !                                                             ! =  1. , the sign is kept 
    358       CHARACTER(len=3), OPTIONAL      , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
    359       REAL(wp)        , OPTIONAL      , INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
    360       ! 
    361       INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices 
    362       INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
    363       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    364       REAL(wp) ::   zland 
    365       INTEGER , DIMENSION(MPI_STATUS_SIZE)      ::   ml_stat        ! for key_mpi_isend 
    366       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ns, zt3sn   ! 3d for north-south & south-north 
    367       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ew, zt3we   ! 3d for east-west & west-east 
    368       !!---------------------------------------------------------------------- 
    369        
    370       ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2),   & 
    371          &      zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2)  ) 
    372  
    373       ! 
    374       IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
    375       ELSE                         ;   zland = 0._wp     ! zero by default 
    376       ENDIF 
    377  
    378       ! 1. standard boundary treatment 
    379       ! ------------------------------ 
    380       IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values 
    381          ! 
    382          ! WARNING ptab is defined only between nld and nle 
    383          DO jk = 1, jpk 
    384             DO jj = nlcj+1, jpj                 ! added line(s)   (inner only) 
    385                ptab(nldi  :nlei  , jj          ,jk) = ptab(nldi:nlei,     nlej,jk) 
    386                ptab(1     :nldi-1, jj          ,jk) = ptab(nldi     ,     nlej,jk) 
    387                ptab(nlei+1:nlci  , jj          ,jk) = ptab(     nlei,     nlej,jk) 
    388             END DO 
    389             DO ji = nlci+1, jpi                 ! added column(s) (full) 
    390                ptab(ji           ,nldj  :nlej  ,jk) = ptab(     nlei,nldj:nlej,jk) 
    391                ptab(ji           ,1     :nldj-1,jk) = ptab(     nlei,nldj     ,jk) 
    392                ptab(ji           ,nlej+1:jpj   ,jk) = ptab(     nlei,     nlej,jk) 
    393             END DO 
    394          END DO 
    395          ! 
    396       ELSE                              ! standard close or cyclic treatment 
    397          ! 
    398          !                                   ! East-West boundaries 
    399          !                                        !* Cyclic east-west 
    400          IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
    401             ptab( 1 ,:,:) = ptab(jpim1,:,:) 
    402             ptab(jpi,:,:) = ptab(  2  ,:,:) 
    403          ELSE                                     !* closed 
    404             IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:,:) = zland    ! south except F-point 
    405                                          ptab(nlci-jpreci+1:jpi   ,:,:) = zland    ! north 
    406          ENDIF 
    407                                           ! North-south cyclic 
    408          IF ( nbondj == 2 .AND. jperio == 7 )    THEN !* cyclic north south only with no mpp split in latitude 
    409             ptab(:,1 , :) = ptab(:, jpjm1,:) 
    410             ptab(:,jpj,:) = ptab(:,     2,:) 
    411          ELSE   !                                   ! North-South boundaries (closed) 
    412             IF( .NOT. cd_type == 'F' )   ptab(:,     1       :jprecj,:) = zland       ! south except F-point 
    413                                          ptab(:,nlcj-jprecj+1:jpj   ,:) = zland       ! north 
    414          ENDIF 
    415          ! 
    416       ENDIF 
    417  
    418       ! 2. East and west directions exchange 
    419       ! ------------------------------------ 
    420       ! we play with the neigbours AND the row number because of the periodicity 
    421       ! 
    422       SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
    423       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    424          iihom = nlci-nreci 
    425          DO jl = 1, jpreci 
    426             zt3ew(:,jl,:,1) = ptab(jpreci+jl,:,:) 
    427             zt3we(:,jl,:,1) = ptab(iihom +jl,:,:) 
    428          END DO 
    429       END SELECT 
    430       ! 
    431       !                           ! Migrations 
    432       imigr = jpreci * jpj * jpk 
    433       ! 
    434       SELECT CASE ( nbondi ) 
    435       CASE ( -1 ) 
    436          CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 ) 
    437          CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 
    438          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    439       CASE ( 0 ) 
    440          CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
    441          CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 ) 
    442          CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 
    443          CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 
    444          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    445          IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    446       CASE ( 1 ) 
    447          CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
    448          CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 
    449          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    450       END SELECT 
    451       ! 
    452       !                           ! Write Dirichlet lateral conditions 
    453       iihom = nlci-jpreci 
    454       ! 
    455       SELECT CASE ( nbondi ) 
    456       CASE ( -1 ) 
    457          DO jl = 1, jpreci 
    458             ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2) 
    459          END DO 
    460       CASE ( 0 ) 
    461          DO jl = 1, jpreci 
    462             ptab(jl      ,:,:) = zt3we(:,jl,:,2) 
    463             ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2) 
    464          END DO 
    465       CASE ( 1 ) 
    466          DO jl = 1, jpreci 
    467             ptab(jl      ,:,:) = zt3we(:,jl,:,2) 
    468          END DO 
    469       END SELECT 
    470  
    471       ! 3. North and south directions 
    472       ! ----------------------------- 
    473       ! always closed : we play only with the neigbours 
    474       ! 
    475       IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    476          ijhom = nlcj-nrecj 
    477          DO jl = 1, jprecj 
    478             zt3sn(:,jl,:,1) = ptab(:,ijhom +jl,:) 
    479             zt3ns(:,jl,:,1) = ptab(:,jprecj+jl,:) 
    480          END DO 
    481       ENDIF 
    482       ! 
    483       !                           ! Migrations 
    484       imigr = jprecj * jpi * jpk 
    485       ! 
    486       SELECT CASE ( nbondj ) 
    487       CASE ( -1 ) 
    488          CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 ) 
    489          CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 
    490          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    491       CASE ( 0 ) 
    492          CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 
    493          CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 ) 
    494          CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 
    495          CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 
    496          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    497          IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    498       CASE ( 1 ) 
    499          CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 
    500          CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 
    501          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    502       END SELECT 
    503       ! 
    504       !                           ! Write Dirichlet lateral conditions 
    505       ijhom = nlcj-jprecj 
    506       ! 
    507       SELECT CASE ( nbondj ) 
    508       CASE ( -1 ) 
    509          DO jl = 1, jprecj 
    510             ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2) 
    511          END DO 
    512       CASE ( 0 ) 
    513          DO jl = 1, jprecj 
    514             ptab(:,jl      ,:) = zt3sn(:,jl,:,2) 
    515             ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2) 
    516          END DO 
    517       CASE ( 1 ) 
    518          DO jl = 1, jprecj 
    519             ptab(:,jl,:) = zt3sn(:,jl,:,2) 
    520          END DO 
    521       END SELECT 
    522  
    523       ! 4. north fold treatment 
    524       ! ----------------------- 
    525       ! 
    526       IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
    527          ! 
    528          SELECT CASE ( jpni ) 
    529          CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp 
    530          CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs. 
    531          END SELECT 
    532          ! 
    533       ENDIF 
    534       ! 
    535       DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we ) 
    536       ! 
    537    END SUBROUTINE mpp_lnk_3d 
    538  
    539  
    540    SUBROUTINE mpp_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields , cd_mpp, pval ) 
    541       !!---------------------------------------------------------------------- 
    542       !!                  ***  routine mpp_lnk_2d_multiple  *** 
    543       !! 
    544       !! ** Purpose :   Message passing management for multiple 2d arrays 
    545       !! 
    546       !! ** Method  :   Use mppsend and mpprecv function for passing mask 
    547       !!      between processors following neighboring subdomains. 
    548       !!            domain parameters 
    549       !!                    nlci   : first dimension of the local subdomain 
    550       !!                    nlcj   : second dimension of the local subdomain 
    551       !!                    nbondi : mark for "east-west local boundary" 
    552       !!                    nbondj : mark for "north-south local boundary" 
    553       !!                    noea   : number for local neighboring processors 
    554       !!                    nowe   : number for local neighboring processors 
    555       !!                    noso   : number for local neighboring processors 
    556       !!                    nono   : number for local neighboring processors 
    557       !!---------------------------------------------------------------------- 
    558       CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   type_array   ! define the nature of ptab array grid-points 
    559       !                                                               ! = T , U , V , F , W and I points 
    560       REAL(wp)        , DIMENSION(:), INTENT(in   ) ::   psgn_array   ! =-1 the sign change across the north fold boundary 
    561       !                                                               ! =  1. , the sign is kept 
    562       CHARACTER(len=3), OPTIONAL    , INTENT(in   ) ::   cd_mpp       ! fill the overlap area only 
    563       REAL(wp)        , OPTIONAL    , INTENT(in   ) ::   pval         ! background value (used at closed boundaries) 
    564       !! 
    565       INTEGER  ::   ji, jj, jl   ! dummy loop indices 
    566       INTEGER  ::   ii    !!MULTI SEND DUMMY LOOP INDICES 
    567       INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
    568       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    569       INTEGER :: num_fields 
    570       TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 
    571       REAL(wp) ::   zland 
    572       INTEGER , DIMENSION(MPI_STATUS_SIZE)    ::   ml_stat       ! for key_mpi_isend 
    573       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ns, zt2sn   ! 2d for north-south & south-north 
    574       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ew, zt2we   ! 2d for east-west & west-east 
    575  
    576       !!---------------------------------------------------------------------- 
    577       ! 
    578       ALLOCATE( zt2ns(jpi,jprecj,2*num_fields), zt2sn(jpi,jprecj,2*num_fields),  & 
    579          &      zt2ew(jpj,jpreci,2*num_fields), zt2we(jpj,jpreci,2*num_fields)   ) 
    580       ! 
    581       IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
    582       ELSE                         ;   zland = 0._wp     ! zero by default 
    583       ENDIF 
    584  
    585       ! 1. standard boundary treatment 
    586       ! ------------------------------ 
    587       ! 
    588       !First Array 
    589       DO ii = 1 , num_fields 
    590          IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values 
    591             ! 
    592             ! WARNING pt2d is defined only between nld and nle 
    593             DO jj = nlcj+1, jpj                 ! added line(s)   (inner only) 
    594                pt2d_array(ii)%pt2d(nldi  :nlei  , jj) = pt2d_array(ii)%pt2d(nldi:nlei, nlej) 
    595                pt2d_array(ii)%pt2d(1     :nldi-1, jj) = pt2d_array(ii)%pt2d(nldi     , nlej) 
    596                pt2d_array(ii)%pt2d(nlei+1:nlci  , jj) = pt2d_array(ii)%pt2d(     nlei, nlej)  
    597             END DO 
    598             DO ji = nlci+1, jpi                 ! added column(s) (full) 
    599                pt2d_array(ii)%pt2d(ji, nldj  :nlej  ) = pt2d_array(ii)%pt2d(nlei, nldj:nlej) 
    600                pt2d_array(ii)%pt2d(ji, 1     :nldj-1) = pt2d_array(ii)%pt2d(nlei, nldj     ) 
    601                pt2d_array(ii)%pt2d(ji, nlej+1:jpj   ) = pt2d_array(ii)%pt2d(nlei,      nlej) 
    602             END DO 
    603             ! 
    604          ELSE                              ! standard close or cyclic treatment 
    605             ! 
    606             !                                   ! East-West boundaries 
    607             IF( nbondi == 2 .AND.   &                ! Cyclic east-west 
    608                &    (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
    609                pt2d_array(ii)%pt2d(  1  , : ) = pt2d_array(ii)%pt2d( jpim1, : )                                    ! west 
    610                pt2d_array(ii)%pt2d( jpi , : ) = pt2d_array(ii)%pt2d(   2  , : )                                    ! east 
    611             ELSE                                     ! closed 
    612                IF( .NOT. type_array(ii) == 'F' )   pt2d_array(ii)%pt2d(            1 : jpreci,:) = zland    ! south except F-point 
    613                                                    pt2d_array(ii)%pt2d(nlci-jpreci+1 : jpi   ,:) = zland    ! north 
    614             ENDIF 
    615                                                 ! Noth-South boundaries 
    616             IF ( nbondj == 2 .AND. jperio == 7 )    THEN !* cyclic north south 
    617                pt2d_array(ii)%pt2d(:, 1   ) =   pt2d_array(ii)%pt2d(:, jpjm1 ) 
    618                pt2d_array(ii)%pt2d(:, jpj ) =   pt2d_array(ii)%pt2d(:, 2 )           
    619             ELSE   !              
    620                !                                   ! North-South boundaries (closed) 
    621                IF( .NOT. type_array(ii) == 'F' )   pt2d_array(ii)%pt2d(:,             1:jprecj ) = zland    ! south except F-point 
    622                                                    pt2d_array(ii)%pt2d(:, nlcj-jprecj+1:jpj    ) = zland    ! north 
    623             ! 
    624             ENDIF 
    625           ENDIF 
    626       END DO 
    627  
    628       ! 2. East and west directions exchange 
    629       ! ------------------------------------ 
    630       ! we play with the neigbours AND the row number because of the periodicity 
    631       ! 
    632       DO ii = 1 , num_fields 
    633          SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
    634          CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    635             iihom = nlci-nreci 
    636             DO jl = 1, jpreci 
    637                zt2ew( : , jl , ii ) = pt2d_array(ii)%pt2d( jpreci+jl , : ) 
    638                zt2we( : , jl , ii ) = pt2d_array(ii)%pt2d( iihom +jl , : ) 
    639             END DO 
    640          END SELECT 
    641       END DO 
    642       ! 
    643       !                           ! Migrations 
    644       imigr = jpreci * jpj 
    645       ! 
    646       SELECT CASE ( nbondi ) 
    647       CASE ( -1 ) 
    648          CALL mppsend( 2, zt2we(1,1,1), num_fields*imigr, noea, ml_req1 ) 
    649          CALL mpprecv( 1, zt2ew(1,1,num_fields+1), num_fields*imigr, noea ) 
    650          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    651       CASE ( 0 ) 
    652          CALL mppsend( 1, zt2ew(1,1,1), num_fields*imigr, nowe, ml_req1 ) 
    653          CALL mppsend( 2, zt2we(1,1,1), num_fields*imigr, noea, ml_req2 ) 
    654          CALL mpprecv( 1, zt2ew(1,1,num_fields+1), num_fields*imigr, noea ) 
    655          CALL mpprecv( 2, zt2we(1,1,num_fields+1), num_fields*imigr, nowe ) 
    656          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    657          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    658       CASE ( 1 ) 
    659          CALL mppsend( 1, zt2ew(1,1,1), num_fields*imigr, nowe, ml_req1 ) 
    660          CALL mpprecv( 2, zt2we(1,1,num_fields+1), num_fields*imigr, nowe ) 
    661          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    662       END SELECT 
    663       ! 
    664       !                           ! Write Dirichlet lateral conditions 
    665       iihom = nlci - jpreci 
    666       ! 
    667  
    668       DO ii = 1 , num_fields 
    669          SELECT CASE ( nbondi ) 
    670          CASE ( -1 ) 
    671             DO jl = 1, jpreci 
    672                pt2d_array(ii)%pt2d( iihom+jl , : ) = zt2ew(:,jl,num_fields+ii) 
    673             END DO 
    674          CASE ( 0 ) 
    675             DO jl = 1, jpreci 
    676                pt2d_array(ii)%pt2d( jl , : ) = zt2we(:,jl,num_fields+ii) 
    677                pt2d_array(ii)%pt2d( iihom+jl , : ) = zt2ew(:,jl,num_fields+ii) 
    678             END DO 
    679          CASE ( 1 ) 
    680             DO jl = 1, jpreci 
    681                pt2d_array(ii)%pt2d( jl , : )= zt2we(:,jl,num_fields+ii) 
    682             END DO 
    683          END SELECT 
    684       END DO 
    685        
    686       ! 3. North and south directions 
    687       ! ----------------------------- 
    688       ! always closed : we play only with the neigbours 
    689       ! 
    690       !First Array 
    691       DO ii = 1 , num_fields 
    692          IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    693             ijhom = nlcj-nrecj 
    694             DO jl = 1, jprecj 
    695                zt2sn(:,jl , ii) = pt2d_array(ii)%pt2d( : , ijhom +jl ) 
    696                zt2ns(:,jl , ii) = pt2d_array(ii)%pt2d( : , jprecj+jl ) 
    697             END DO 
    698          ENDIF 
    699       END DO 
    700       ! 
    701       !                           ! Migrations 
    702       imigr = jprecj * jpi 
    703       ! 
    704       SELECT CASE ( nbondj ) 
    705       CASE ( -1 ) 
    706          CALL mppsend( 4, zt2sn(1,1,1), num_fields*imigr, nono, ml_req1 ) 
    707          CALL mpprecv( 3, zt2ns(1,1,num_fields+1), num_fields*imigr, nono ) 
    708          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    709       CASE ( 0 ) 
    710          CALL mppsend( 3, zt2ns(1,1,1), num_fields*imigr, noso, ml_req1 ) 
    711          CALL mppsend( 4, zt2sn(1,1,1), num_fields*imigr, nono, ml_req2 ) 
    712          CALL mpprecv( 3, zt2ns(1,1,num_fields+1), num_fields*imigr, nono ) 
    713          CALL mpprecv( 4, zt2sn(1,1,num_fields+1), num_fields*imigr, noso ) 
    714          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    715          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    716       CASE ( 1 ) 
    717          CALL mppsend( 3, zt2ns(1,1,1), num_fields*imigr, noso, ml_req1 ) 
    718          CALL mpprecv( 4, zt2sn(1,1,num_fields+1), num_fields*imigr, noso ) 
    719          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    720       END SELECT 
    721       ! 
    722       !                           ! Write Dirichlet lateral conditions 
    723       ijhom = nlcj - jprecj 
    724       ! 
    725  
    726       DO ii = 1 , num_fields 
    727          !First Array 
    728          SELECT CASE ( nbondj ) 
    729          CASE ( -1 ) 
    730             DO jl = 1, jprecj 
    731                pt2d_array(ii)%pt2d( : , ijhom+jl ) = zt2ns( : , jl , num_fields+ii ) 
    732             END DO 
    733          CASE ( 0 ) 
    734             DO jl = 1, jprecj 
    735                pt2d_array(ii)%pt2d( : , jl ) = zt2sn( : , jl , num_fields + ii) 
    736                pt2d_array(ii)%pt2d( : , ijhom + jl ) = zt2ns( : , jl , num_fields + ii ) 
    737             END DO 
    738          CASE ( 1 ) 
    739             DO jl = 1, jprecj 
    740                pt2d_array(ii)%pt2d( : , jl ) = zt2sn( : , jl , num_fields + ii ) 
    741             END DO 
    742          END SELECT 
    743       END DO 
    744        
    745       ! 4. north fold treatment 
    746       ! ----------------------- 
    747       ! 
    748          !First Array 
    749       IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
    750          ! 
    751          SELECT CASE ( jpni ) 
    752          CASE ( 1 )     ;    
    753              DO ii = 1 , num_fields   
    754                        CALL lbc_nfd      ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) )   ! only 1 northern proc, no mpp 
    755              END DO 
    756          CASE DEFAULT   ;   CALL mpp_lbc_north_2d_multiple( pt2d_array, type_array, psgn_array, num_fields )   ! for all northern procs. 
    757          END SELECT 
    758          ! 
    759       ENDIF 
    760         ! 
    761       ! 
    762       DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 
    763       ! 
    764    END SUBROUTINE mpp_lnk_2d_multiple 
    765  
    766     
    767    SUBROUTINE load_array( pt2d, cd_type, psgn, pt2d_array, type_array, psgn_array, num_fields ) 
    768       !!--------------------------------------------------------------------- 
    769       REAL(wp), DIMENSION(jpi,jpj), TARGET, INTENT(inout) ::   pt2d    ! Second 2D array on which the boundary condition is applied 
    770       CHARACTER(len=1)                    , INTENT(in   ) ::   cd_type ! define the nature of ptab array grid-points 
    771       REAL(wp)                            , INTENT(in   ) ::   psgn    ! =-1 the sign change across the north fold boundary 
    772       TYPE(arrayptr)   , DIMENSION(9) ::   pt2d_array 
    773       CHARACTER(len=1) , DIMENSION(9) ::   type_array    ! define the nature of ptab array grid-points 
    774       REAL(wp)         , DIMENSION(9) ::   psgn_array    ! =-1 the sign change across the north fold boundary 
    775       INTEGER                            , INTENT (inout) :: num_fields  
    776       !!--------------------------------------------------------------------- 
    777       num_fields = num_fields + 1 
    778       pt2d_array(num_fields)%pt2d => pt2d 
    779       type_array(num_fields)      =  cd_type 
    780       psgn_array(num_fields)      =  psgn 
    781    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 
    782492    
    783493    
    784    SUBROUTINE mpp_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC   & 
    785       &                   , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF   & 
    786       &                   , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 
    787       !!--------------------------------------------------------------------- 
    788       ! Second 2D array on which the boundary condition is applied 
    789       REAL(wp), DIMENSION(jpi,jpj), TARGET          , INTENT(inout) ::   pt2dA     
    790       REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dB , pt2dC , pt2dD , pt2dE 
    791       REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dF , pt2dG , pt2dH , pt2dI  
    792       ! define the nature of ptab array grid-points 
    793       CHARACTER(len=1)                              , INTENT(in   ) ::   cd_typeA 
    794       CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeB , cd_typeC , cd_typeD , cd_typeE 
    795       CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeF , cd_typeG , cd_typeH , cd_typeI 
    796       ! =-1 the sign change across the north fold boundary 
    797       REAL(wp)                                      , INTENT(in   ) ::   psgnA     
    798       REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnB , psgnC , psgnD , psgnE 
    799       REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnF , psgnG , psgnH , psgnI    
    800       CHARACTER(len=3)                    , OPTIONAL, INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
    801       REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
    802       !! 
    803       TYPE(arrayptr)   , DIMENSION(9) ::   pt2d_array  
    804       CHARACTER(len=1) , DIMENSION(9) ::   type_array    ! define the nature of ptab array grid-points 
    805       !                                                         ! = T , U , V , F , W and I points 
    806       REAL(wp)         , DIMENSION(9) ::   psgn_array    ! =-1 the sign change across the north fold boundary 
    807       INTEGER :: num_fields 
    808       !!--------------------------------------------------------------------- 
    809       ! 
    810       num_fields = 0 
    811       ! 
    812       ! Load the first array 
    813       CALL load_array( pt2dA, cd_typeA, psgnA, pt2d_array, type_array, psgn_array, num_fields ) 
    814       ! 
    815       ! Look if more arrays are added 
    816       IF( PRESENT(psgnB) )   CALL load_array(pt2dB,cd_typeB,psgnB,pt2d_array, type_array, psgn_array,num_fields) 
    817       IF( PRESENT(psgnC) )   CALL load_array(pt2dC,cd_typeC,psgnC,pt2d_array, type_array, psgn_array,num_fields) 
    818       IF( PRESENT(psgnD) )   CALL load_array(pt2dD,cd_typeD,psgnD,pt2d_array, type_array, psgn_array,num_fields) 
    819       IF( PRESENT(psgnE) )   CALL load_array(pt2dE,cd_typeE,psgnE,pt2d_array, type_array, psgn_array,num_fields) 
    820       IF( PRESENT(psgnF) )   CALL load_array(pt2dF,cd_typeF,psgnF,pt2d_array, type_array, psgn_array,num_fields) 
    821       IF( PRESENT(psgnG) )   CALL load_array(pt2dG,cd_typeG,psgnG,pt2d_array, type_array, psgn_array,num_fields) 
    822       IF( PRESENT(psgnH) )   CALL load_array(pt2dH,cd_typeH,psgnH,pt2d_array, type_array, psgn_array,num_fields) 
    823       IF( PRESENT(psgnI) )   CALL load_array(pt2dI,cd_typeI,psgnI,pt2d_array, type_array, psgn_array,num_fields) 
    824       ! 
    825       CALL mpp_lnk_2d_multiple( pt2d_array, type_array, psgn_array, num_fields, cd_mpp,pval ) 
    826       ! 
    827    END SUBROUTINE mpp_lnk_2d_9 
    828  
    829  
    830    SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 
    831       !!---------------------------------------------------------------------- 
    832       !!                  ***  routine mpp_lnk_2d  *** 
    833       !! 
    834       !! ** Purpose :   Message passing manadgement for 2d array 
    835       !! 
    836       !! ** Method  :   Use mppsend and mpprecv function for passing mask 
    837       !!      between processors following neighboring subdomains. 
    838       !!            domain parameters 
    839       !!                    nlci   : first dimension of the local subdomain 
    840       !!                    nlcj   : second dimension of the local subdomain 
    841       !!                    nbondi : mark for "east-west local boundary" 
    842       !!                    nbondj : mark for "north-south local boundary" 
    843       !!                    noea   : number for local neighboring processors 
    844       !!                    nowe   : number for local neighboring processors 
    845       !!                    noso   : number for local neighboring processors 
    846       !!                    nono   : number for local neighboring processors 
    847       !! 
    848       !!---------------------------------------------------------------------- 
    849       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d     ! 2D array on which the boundary condition is applied 
    850       CHARACTER(len=1)            , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points 
    851       !                                                         ! = T , U , V , F , W and I points 
    852       REAL(wp)                    , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary 
    853       !                                                         ! =  1. , the sign is kept 
    854       CHARACTER(len=3), OPTIONAL  , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
    855       REAL(wp)        , OPTIONAL  , INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
    856       !! 
    857       INTEGER  ::   ji, jj, jl   ! dummy loop indices 
    858       INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
    859       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    860       REAL(wp) ::   zland 
    861       INTEGER, DIMENSION(MPI_STATUS_SIZE)     ::   ml_stat       ! for key_mpi_isend 
    862       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ns, zt2sn   ! 2d for north-south & south-north 
    863       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ew, zt2we   ! 2d for east-west & west-east 
    864       !!---------------------------------------------------------------------- 
    865       ! 
    866       ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2),  & 
    867          &      zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2)   ) 
    868       ! 
    869       IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
    870       ELSE                         ;   zland = 0._wp     ! zero by default 
    871       ENDIF 
    872  
    873       ! 1. standard boundary treatment 
    874       ! ------------------------------ 
    875       ! 
    876       IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values 
    877          ! 
    878          ! WARNING pt2d is defined only between nld and nle 
    879          DO jj = nlcj+1, jpj                 ! added line(s)   (inner only) 
    880             pt2d(nldi  :nlei  , jj          ) = pt2d(nldi:nlei,     nlej) 
    881             pt2d(1     :nldi-1, jj          ) = pt2d(nldi     ,     nlej) 
    882             pt2d(nlei+1:nlci  , jj          ) = pt2d(     nlei,     nlej) 
    883          END DO 
    884          DO ji = nlci+1, jpi                 ! added column(s) (full) 
    885             pt2d(ji           ,nldj  :nlej  ) = pt2d(     nlei,nldj:nlej) 
    886             pt2d(ji           ,1     :nldj-1) = pt2d(     nlei,nldj     ) 
    887             pt2d(ji           ,nlej+1:jpj   ) = pt2d(     nlei,     nlej) 
    888          END DO 
    889          ! 
    890       ELSE                              ! standard close or cyclic treatment 
    891          ! 
    892          !                                   ! East-West boundaries 
    893          IF( nbondi == 2 .AND.   &                ! Cyclic east-west 
    894             &    (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
    895             pt2d( 1 ,:) = pt2d(jpim1,:)                                    ! west 
    896             pt2d(jpi,:) = pt2d(  2  ,:)                                    ! east 
    897          ELSE                                     ! closed 
    898             IF( .NOT. cd_type == 'F' )   pt2d(     1       :jpreci,:) = zland    ! south except F-point 
    899                                          pt2d(nlci-jpreci+1:jpi   ,:) = zland    ! north 
    900          ENDIF 
    901                                             ! North-South boudaries 
    902          IF ( nbondj == 2 .AND. jperio == 7 )    THEN !* cyclic north south 
    903             pt2d(:,  1 ) = pt2d(:,jpjm1) 
    904             pt2d(:, jpj) = pt2d(:,    2) 
    905          ELSE     
    906          !                                   ! North-South boundaries (closed) 
    907             IF( .NOT. cd_type == 'F' )   pt2d(:,     1       :jprecj) = zland    !south except F-point 
    908                                          pt2d(:,nlcj-jprecj+1:jpj   ) = zland    ! north 
    909          ENDIF      
    910       ENDIF 
    911  
    912       ! 2. East and west directions exchange 
    913       ! ------------------------------------ 
    914       ! we play with the neigbours AND the row number because of the periodicity 
    915       ! 
    916       SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
    917       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    918          iihom = nlci-nreci 
    919          DO jl = 1, jpreci 
    920             zt2ew(:,jl,1) = pt2d(jpreci+jl,:) 
    921             zt2we(:,jl,1) = pt2d(iihom +jl,:) 
    922          END DO 
    923       END SELECT 
    924       ! 
    925       !                           ! Migrations 
    926       imigr = jpreci * jpj 
    927       ! 
    928       SELECT CASE ( nbondi ) 
    929       CASE ( -1 ) 
    930          CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 ) 
    931          CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 
    932          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    933       CASE ( 0 ) 
    934          CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 
    935          CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 ) 
    936          CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 
    937          CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 
    938          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    939          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    940       CASE ( 1 ) 
    941          CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 
    942          CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 
    943          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    944       END SELECT 
    945       ! 
    946       !                           ! Write Dirichlet lateral conditions 
    947       iihom = nlci - jpreci 
    948       ! 
    949       SELECT CASE ( nbondi ) 
    950       CASE ( -1 ) 
    951          DO jl = 1, jpreci 
    952             pt2d(iihom+jl,:) = zt2ew(:,jl,2) 
    953          END DO 
    954       CASE ( 0 ) 
    955          DO jl = 1, jpreci 
    956             pt2d(jl      ,:) = zt2we(:,jl,2) 
    957             pt2d(iihom+jl,:) = zt2ew(:,jl,2) 
    958          END DO 
    959       CASE ( 1 ) 
    960          DO jl = 1, jpreci 
    961             pt2d(jl      ,:) = zt2we(:,jl,2) 
    962          END DO 
    963       END SELECT 
    964  
    965  
    966       ! 3. North and south directions 
    967       ! ----------------------------- 
    968       ! always closed : we play only with the neigbours 
    969       ! 
    970       IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    971          ijhom = nlcj-nrecj 
    972          DO jl = 1, jprecj 
    973             zt2sn(:,jl,1) = pt2d(:,ijhom +jl) 
    974             zt2ns(:,jl,1) = pt2d(:,jprecj+jl) 
    975          END DO 
    976       ENDIF 
    977       ! 
    978       !                           ! Migrations 
    979       imigr = jprecj * jpi 
    980       ! 
    981       SELECT CASE ( nbondj ) 
    982       CASE ( -1 ) 
    983          CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 ) 
    984          CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 
    985          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    986       CASE ( 0 ) 
    987          CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 
    988          CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 ) 
    989          CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 
    990          CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 
    991          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    992          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    993       CASE ( 1 ) 
    994          CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 
    995          CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 
    996          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    997       END SELECT 
    998       ! 
    999       !                           ! Write Dirichlet lateral conditions 
    1000       ijhom = nlcj - jprecj 
    1001       ! 
    1002       SELECT CASE ( nbondj ) 
    1003       CASE ( -1 ) 
    1004          DO jl = 1, jprecj 
    1005             pt2d(:,ijhom+jl) = zt2ns(:,jl,2) 
    1006          END DO 
    1007       CASE ( 0 ) 
    1008          DO jl = 1, jprecj 
    1009             pt2d(:,jl      ) = zt2sn(:,jl,2) 
    1010             pt2d(:,ijhom+jl) = zt2ns(:,jl,2) 
    1011          END DO 
    1012       CASE ( 1 ) 
    1013          DO jl = 1, jprecj 
    1014             pt2d(:,jl      ) = zt2sn(:,jl,2) 
    1015          END DO 
    1016       END SELECT 
    1017  
    1018  
    1019       ! 4. north fold treatment 
    1020       ! ----------------------- 
    1021       ! 
    1022       IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
    1023          ! 
    1024          SELECT CASE ( jpni ) 
    1025          CASE ( 1 )     ;   CALL lbc_nfd      ( pt2d, cd_type, psgn )   ! only 1 northern proc, no mpp 
    1026          CASE DEFAULT   ;   CALL mpp_lbc_north( pt2d, cd_type, psgn )   ! for all northern procs. 
    1027          END SELECT 
    1028          ! 
    1029       ENDIF 
    1030       ! 
    1031       DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 
    1032       ! 
    1033    END SUBROUTINE mpp_lnk_2d 
    1034  
    1035  
    1036    SUBROUTINE mpp_lnk_3d_gather( ptab1, cd_type1, ptab2, cd_type2, psgn ) 
    1037       !!---------------------------------------------------------------------- 
    1038       !!                  ***  routine mpp_lnk_3d_gather  *** 
    1039       !! 
    1040       !! ** Purpose :   Message passing manadgement for two 3D arrays 
    1041       !! 
    1042       !! ** Method  :   Use mppsend and mpprecv function for passing mask 
    1043       !!      between processors following neighboring subdomains. 
    1044       !!            domain parameters 
    1045       !!                    nlci   : first dimension of the local subdomain 
    1046       !!                    nlcj   : second dimension of the local subdomain 
    1047       !!                    nbondi : mark for "east-west local boundary" 
    1048       !!                    nbondj : mark for "north-south local boundary" 
    1049       !!                    noea   : number for local neighboring processors 
    1050       !!                    nowe   : number for local neighboring processors 
    1051       !!                    noso   : number for local neighboring processors 
    1052       !!                    nono   : number for local neighboring processors 
    1053       !! 
    1054       !! ** Action  :   ptab1 and ptab2  with update value at its periphery 
    1055       !! 
    1056       !!---------------------------------------------------------------------- 
    1057       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab1     ! first and second 3D array on which 
    1058       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab2     ! the boundary condition is applied 
    1059       CHARACTER(len=1)                , INTENT(in   ) ::   cd_type1  ! nature of ptab1 and ptab2 arrays 
    1060       CHARACTER(len=1)                , INTENT(in   ) ::   cd_type2  ! i.e. grid-points = T , U , V , F or W points 
    1061       REAL(wp)                        , INTENT(in   ) ::   psgn      ! =-1 the sign change across the north fold boundary 
    1062       !!                                                             ! =  1. , the sign is kept 
    1063       INTEGER  ::   jl   ! dummy loop indices 
    1064       INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
    1065       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    1066       INTEGER , DIMENSION(MPI_STATUS_SIZE)        ::   ml_stat   ! for key_mpi_isend 
    1067       REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE ::   zt4ns, zt4sn   ! 2 x 3d for north-south & south-north 
    1068       REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE ::   zt4ew, zt4we   ! 2 x 3d for east-west & west-east 
    1069       !!---------------------------------------------------------------------- 
    1070       ! 
    1071       ALLOCATE( zt4ns(jpi,jprecj,jpk,2,2), zt4sn(jpi,jprecj,jpk,2,2) ,    & 
    1072          &      zt4ew(jpj,jpreci,jpk,2,2), zt4we(jpj,jpreci,jpk,2,2) ) 
    1073       ! 
    1074       ! 1. standard boundary treatment 
    1075       ! ------------------------------ 
    1076       !                                      ! East-West boundaries 
    1077       !                                           !* Cyclic east-west 
    1078       IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
    1079          ptab1( 1 ,:,:) = ptab1(jpim1,:,:) 
    1080          ptab1(jpi,:,:) = ptab1(  2  ,:,:) 
    1081          ptab2( 1 ,:,:) = ptab2(jpim1,:,:) 
    1082          ptab2(jpi,:,:) = ptab2(  2  ,:,:) 
    1083       ELSE                                        !* closed 
    1084          IF( .NOT. cd_type1 == 'F' )   ptab1(     1       :jpreci,:,:) = 0.e0    ! south except at F-point 
    1085          IF( .NOT. cd_type2 == 'F' )   ptab2(     1       :jpreci,:,:) = 0.e0 
    1086                                        ptab1(nlci-jpreci+1:jpi   ,:,:) = 0.e0    ! north 
    1087                                        ptab2(nlci-jpreci+1:jpi   ,:,:) = 0.e0 
    1088       ENDIF 
    1089                                             ! North-South boundaries 
    1090       IF ( nbondj == 2 .AND. jperio == 7 )    THEN !* cyclic north south 
    1091          ptab1(:,     1       ,:) = ptab1(: ,  jpjm1 , :) 
    1092          ptab1(:,   jpj       ,:) = ptab1(: ,      2 , :) 
    1093          ptab2(:,     1       ,:) = ptab2(: ,  jpjm1 , :) 
    1094          ptab2(:,   jpj       ,:) = ptab2(: ,      2 , :) 
    1095       ELSE      
    1096       !                                      ! North-South boundaries closed 
    1097       IF( .NOT. cd_type1 == 'F' )   ptab1(:,     1       :jprecj,:) = 0.e0    ! south except at F-point 
    1098       IF( .NOT. cd_type2 == 'F' )   ptab2(:,     1       :jprecj,:) = 0.e0 
    1099                                     ptab1(:,nlcj-jprecj+1:jpj   ,:) = 0.e0    ! north 
    1100                                     ptab2(:,nlcj-jprecj+1:jpj   ,:) = 0.e0 
    1101       ENDIF      
    1102  
    1103       ! 2. East and west directions exchange 
    1104       ! ------------------------------------ 
    1105       ! we play with the neigbours AND the row number because of the periodicity 
    1106       ! 
    1107       SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
    1108       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    1109          iihom = nlci-nreci 
    1110          DO jl = 1, jpreci 
    1111             zt4ew(:,jl,:,1,1) = ptab1(jpreci+jl,:,:) 
    1112             zt4we(:,jl,:,1,1) = ptab1(iihom +jl,:,:) 
    1113             zt4ew(:,jl,:,2,1) = ptab2(jpreci+jl,:,:) 
    1114             zt4we(:,jl,:,2,1) = ptab2(iihom +jl,:,:) 
    1115          END DO 
    1116       END SELECT 
    1117       ! 
    1118       !                           ! Migrations 
    1119       imigr = jpreci * jpj * jpk *2 
    1120       ! 
    1121       SELECT CASE ( nbondi ) 
    1122       CASE ( -1 ) 
    1123          CALL mppsend( 2, zt4we(1,1,1,1,1), imigr, noea, ml_req1 ) 
    1124          CALL mpprecv( 1, zt4ew(1,1,1,1,2), imigr, noea ) 
    1125          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1126       CASE ( 0 ) 
    1127          CALL mppsend( 1, zt4ew(1,1,1,1,1), imigr, nowe, ml_req1 ) 
    1128          CALL mppsend( 2, zt4we(1,1,1,1,1), imigr, noea, ml_req2 ) 
    1129          CALL mpprecv( 1, zt4ew(1,1,1,1,2), imigr, noea ) 
    1130          CALL mpprecv( 2, zt4we(1,1,1,1,2), imigr, nowe ) 
    1131          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1132          IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    1133       CASE ( 1 ) 
    1134          CALL mppsend( 1, zt4ew(1,1,1,1,1), imigr, nowe, ml_req1 ) 
    1135          CALL mpprecv( 2, zt4we(1,1,1,1,2), imigr, nowe ) 
    1136          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1137       END SELECT 
    1138       ! 
    1139       !                           ! Write Dirichlet lateral conditions 
    1140       iihom = nlci - jpreci 
    1141       ! 
    1142       SELECT CASE ( nbondi ) 
    1143       CASE ( -1 ) 
    1144          DO jl = 1, jpreci 
    1145             ptab1(iihom+jl,:,:) = zt4ew(:,jl,:,1,2) 
    1146             ptab2(iihom+jl,:,:) = zt4ew(:,jl,:,2,2) 
    1147          END DO 
    1148       CASE ( 0 ) 
    1149          DO jl = 1, jpreci 
    1150             ptab1(jl      ,:,:) = zt4we(:,jl,:,1,2) 
    1151             ptab1(iihom+jl,:,:) = zt4ew(:,jl,:,1,2) 
    1152             ptab2(jl      ,:,:) = zt4we(:,jl,:,2,2) 
    1153             ptab2(iihom+jl,:,:) = zt4ew(:,jl,:,2,2) 
    1154          END DO 
    1155       CASE ( 1 ) 
    1156          DO jl = 1, jpreci 
    1157             ptab1(jl      ,:,:) = zt4we(:,jl,:,1,2) 
    1158             ptab2(jl      ,:,:) = zt4we(:,jl,:,2,2) 
    1159          END DO 
    1160       END SELECT 
    1161  
    1162  
    1163       ! 3. North and south directions 
    1164       ! ----------------------------- 
    1165       ! always closed : we play only with the neigbours 
    1166       ! 
    1167       IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    1168          ijhom = nlcj - nrecj 
    1169          DO jl = 1, jprecj 
    1170             zt4sn(:,jl,:,1,1) = ptab1(:,ijhom +jl,:) 
    1171             zt4ns(:,jl,:,1,1) = ptab1(:,jprecj+jl,:) 
    1172             zt4sn(:,jl,:,2,1) = ptab2(:,ijhom +jl,:) 
    1173             zt4ns(:,jl,:,2,1) = ptab2(:,jprecj+jl,:) 
    1174          END DO 
    1175       ENDIF 
    1176       ! 
    1177       !                           ! Migrations 
    1178       imigr = jprecj * jpi * jpk * 2 
    1179       ! 
    1180       SELECT CASE ( nbondj ) 
    1181       CASE ( -1 ) 
    1182          CALL mppsend( 4, zt4sn(1,1,1,1,1), imigr, nono, ml_req1 ) 
    1183          CALL mpprecv( 3, zt4ns(1,1,1,1,2), imigr, nono ) 
    1184          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1185       CASE ( 0 ) 
    1186          CALL mppsend( 3, zt4ns(1,1,1,1,1), imigr, noso, ml_req1 ) 
    1187          CALL mppsend( 4, zt4sn(1,1,1,1,1), imigr, nono, ml_req2 ) 
    1188          CALL mpprecv( 3, zt4ns(1,1,1,1,2), imigr, nono ) 
    1189          CALL mpprecv( 4, zt4sn(1,1,1,1,2), imigr, noso ) 
    1190          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1191          IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    1192       CASE ( 1 ) 
    1193          CALL mppsend( 3, zt4ns(1,1,1,1,1), imigr, noso, ml_req1 ) 
    1194          CALL mpprecv( 4, zt4sn(1,1,1,1,2), imigr, noso ) 
    1195          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1196       END SELECT 
    1197       ! 
    1198       !                           ! Write Dirichlet lateral conditions 
    1199       ijhom = nlcj - jprecj 
    1200       ! 
    1201       SELECT CASE ( nbondj ) 
    1202       CASE ( -1 ) 
    1203          DO jl = 1, jprecj 
    1204             ptab1(:,ijhom+jl,:) = zt4ns(:,jl,:,1,2) 
    1205             ptab2(:,ijhom+jl,:) = zt4ns(:,jl,:,2,2) 
    1206          END DO 
    1207       CASE ( 0 ) 
    1208          DO jl = 1, jprecj 
    1209             ptab1(:,jl      ,:) = zt4sn(:,jl,:,1,2) 
    1210             ptab1(:,ijhom+jl,:) = zt4ns(:,jl,:,1,2) 
    1211             ptab2(:,jl      ,:) = zt4sn(:,jl,:,2,2) 
    1212             ptab2(:,ijhom+jl,:) = zt4ns(:,jl,:,2,2) 
    1213          END DO 
    1214       CASE ( 1 ) 
    1215          DO jl = 1, jprecj 
    1216             ptab1(:,jl,:) = zt4sn(:,jl,:,1,2) 
    1217             ptab2(:,jl,:) = zt4sn(:,jl,:,2,2) 
    1218          END DO 
    1219       END SELECT 
    1220  
    1221  
    1222       ! 4. north fold treatment 
    1223       ! ----------------------- 
    1224       IF( npolj /= 0 ) THEN 
    1225          ! 
    1226          SELECT CASE ( jpni ) 
    1227          CASE ( 1 ) 
    1228             CALL lbc_nfd      ( ptab1, cd_type1, psgn )   ! only for northern procs. 
    1229             CALL lbc_nfd      ( ptab2, cd_type2, psgn ) 
    1230          CASE DEFAULT 
    1231             CALL mpp_lbc_north( ptab1, cd_type1, psgn )   ! for all northern procs. 
    1232             CALL mpp_lbc_north (ptab2, cd_type2, psgn) 
    1233          END SELECT 
    1234          ! 
    1235       ENDIF 
    1236       ! 
    1237       DEALLOCATE( zt4ns, zt4sn, zt4ew, zt4we ) 
    1238       ! 
    1239    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   !!---------------------------------------------------------------------- 
    1240501 
    1241502 
     
    1284545 
    1285546 
    1286       ! 1. standard boundary treatment 
     547      ! 1. standard boundary treatment   (CAUTION: the order matters Here !!!! ) 
    1287548      ! ------------------------------ 
    1288       ! Order matters Here !!!! 
    1289       ! 
    1290                                            ! North-South cyclic 
    1291       IF ( nbondj == 2 .AND. jperio == 7 )    THEN !* cyclic north south 
    1292          pt2d(:, 1-jprj:  1     ) = pt2d ( :, jpjm1-jprj:jpjm1) 
     549      !                                !== North-South boundaries 
     550      !                                      !* cyclic 
     551      IF( nbondj == 2 .AND. jperio == 7 ) THEN 
     552         pt2d(:, 1-jprj:  1     ) = pt2d ( :, jpjm1-jprj:jpjm1 ) 
    1293553         pt2d(:, jpj   :jpj+jprj) = pt2d ( :, 2         :2+jprj) 
    1294       ELSE 
    1295          
    1296       !                                      !* North-South boundaries (closed) 
    1297       IF( .NOT. cd_type == 'F' )   pt2d(:,  1-jprj   :  jprecj  ) = 0.e0    ! south except at F-point 
    1298                                    pt2d(:,nlcj-jprecj+1:jpj+jprj) = 0.e0    ! north 
    1299       ENDIF 
    1300                                  
    1301       !                                      ! East-West boundaries 
    1302       !                                           !* Cyclic east-west 
     554      ELSE                                   !* closed 
     555         IF( .NOT. cd_type == 'F' )   pt2d(:,  1-jprj   :  jprecj  ) = 0._wp     ! south except at F-point 
     556                                      pt2d(:,nlcj-jprecj+1:jpj+jprj) = 0._wp     ! north 
     557      ENDIF 
     558      !                                !== East-West boundaries 
     559      !                                      !* Cyclic east-west 
    1303560      IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
    1304          pt2d(1-jpri:     1    ,:) = pt2d(jpim1-jpri:  jpim1 ,:)       ! east 
    1305          pt2d(   jpi  :jpi+jpri,:) = pt2d(     2      :2+jpri,:)       ! west 
    1306          ! 
    1307       ELSE                                        !* closed 
    1308          IF( .NOT. cd_type == 'F' )   pt2d(  1-jpri   :jpreci    ,:) = 0.e0    ! south except at F-point 
    1309                                       pt2d(nlci-jpreci+1:jpi+jpri,:) = 0.e0    ! north 
    1310       ENDIF 
    1311       ! 
    1312  
     561         pt2d(1-jpri:     1    ,:) = pt2d(jpim1-jpri:  jpim1 ,:)              ! east 
     562         pt2d(   jpi  :jpi+jpri,:) = pt2d(     2      :2+jpri,:)              ! west 
     563      ELSE                                   !* closed 
     564         IF( .NOT. cd_type == 'F' )   pt2d(  1-jpri   :jpreci    ,:) = 0._wp  ! south except at F-point 
     565                                      pt2d(nlci-jpreci+1:jpi+jpri,:) = 0._wp  ! north 
     566      ENDIF 
     567      ! 
    1313568      ! north fold treatment 
    1314       ! ----------------------- 
     569      ! -------------------- 
    1315570      IF( npolj /= 0 ) THEN 
    1316571         ! 
    1317572         SELECT CASE ( jpni ) 
    1318          CASE ( 1 )     ;   CALL lbc_nfd        ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj ) 
    1319          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             ) 
    1320575         END SELECT 
    1321576         ! 
     
    1375630      END SELECT 
    1376631 
    1377  
    1378632      ! 3. North and south directions 
    1379633      ! ----------------------------- 
     
    1430684   END SUBROUTINE mpp_lnk_2d_e 
    1431685 
    1432    SUBROUTINE mpp_lnk_sum_3d( ptab, cd_type, psgn, cd_mpp, pval ) 
    1433       !!---------------------------------------------------------------------- 
    1434       !!                  ***  routine mpp_lnk_sum_3d  *** 
    1435       !! 
    1436       !! ** Purpose :   Message passing manadgement (sum the overlap region) 
    1437       !! 
    1438       !! ** Method  :   Use mppsend and mpprecv function for passing mask 
    1439       !!      between processors following neighboring subdomains. 
    1440       !!            domain parameters 
    1441       !!                    nlci   : first dimension of the local subdomain 
    1442       !!                    nlcj   : second dimension of the local subdomain 
    1443       !!                    nbondi : mark for "east-west local boundary" 
    1444       !!                    nbondj : mark for "north-south local boundary" 
    1445       !!                    noea   : number for local neighboring processors 
    1446       !!                    nowe   : number for local neighboring processors 
    1447       !!                    noso   : number for local neighboring processors 
    1448       !!                    nono   : number for local neighboring processors 
    1449       !! 
    1450       !! ** Action  :   ptab with update value at its periphery 
    1451       !! 
    1452       !!---------------------------------------------------------------------- 
    1453       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied 
    1454       CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points 
    1455       !                                                             ! = T , U , V , F , W points 
    1456       REAL(wp)                        , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary 
    1457       !                                                             ! =  1. , the sign is kept 
    1458       CHARACTER(len=3), OPTIONAL      , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
    1459       REAL(wp)        , OPTIONAL      , INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
    1460       !! 
    1461       INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices 
    1462       INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
    1463       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    1464       REAL(wp) ::   zland 
    1465       INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
    1466       ! 
    1467       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ns, zt3sn   ! 3d for north-south & south-north 
    1468       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ew, zt3we   ! 3d for east-west & west-east 
    1469  
    1470       !!---------------------------------------------------------------------- 
    1471        
    1472       ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2),   & 
    1473          &      zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2)  ) 
    1474  
    1475       ! 
    1476       IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
    1477       ELSE                         ;   zland = 0.e0      ! zero by default 
    1478       ENDIF 
    1479  
    1480       ! 1. standard boundary treatment 
    1481       ! ------------------------------ 
    1482       ! 2. East and west directions exchange 
    1483       ! ------------------------------------ 
    1484       ! we play with the neigbours AND the row number because of the periodicity 
    1485       ! 
    1486       SELECT CASE ( nbondi )      ! Read lateral conditions 
    1487       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    1488       iihom = nlci-jpreci 
    1489          DO jl = 1, jpreci 
    1490             zt3ew(:,jl,:,1) = ptab(jl      ,:,:) ; ptab(jl      ,:,:) = 0.0_wp 
    1491             zt3we(:,jl,:,1) = ptab(iihom+jl,:,:) ; ptab(iihom+jl,:,:) = 0.0_wp  
    1492          END DO 
    1493       END SELECT 
    1494       ! 
    1495       !                           ! Migrations 
    1496       imigr = jpreci * jpj * jpk 
    1497       ! 
    1498       SELECT CASE ( nbondi ) 
    1499       CASE ( -1 ) 
    1500          CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 ) 
    1501          CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 
    1502          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1503       CASE ( 0 ) 
    1504          CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
    1505          CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 ) 
    1506          CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 
    1507          CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 
    1508          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1509          IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    1510       CASE ( 1 ) 
    1511          CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
    1512          CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 
    1513          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1514       END SELECT 
    1515       ! 
    1516       !                           ! Write lateral conditions 
    1517       iihom = nlci-nreci 
    1518       ! 
    1519       SELECT CASE ( nbondi ) 
    1520       CASE ( -1 ) 
    1521          DO jl = 1, jpreci 
    1522             ptab(iihom+jl,:,:) = ptab(iihom+jl,:,:) + zt3ew(:,jl,:,2) 
    1523          END DO 
    1524       CASE ( 0 ) 
    1525          DO jl = 1, jpreci 
    1526             ptab(jpreci+jl,:,:) = ptab(jpreci+jl,:,:) + zt3we(:,jl,:,2) 
    1527             ptab(iihom +jl,:,:) = ptab(iihom +jl,:,:) + zt3ew(:,jl,:,2) 
    1528          END DO 
    1529       CASE ( 1 ) 
    1530          DO jl = 1, jpreci 
    1531             ptab(jpreci+jl,:,:) = ptab(jpreci+jl,:,:) + zt3we(:,jl,:,2) 
    1532          END DO 
    1533       END SELECT 
    1534  
    1535  
    1536       ! 3. North and south directions 
    1537       ! ----------------------------- 
    1538       ! always closed : we play only with the neigbours 
    1539       ! 
    1540       IF( nbondj /= 2 ) THEN      ! Read lateral conditions 
    1541          ijhom = nlcj-jprecj 
    1542          DO jl = 1, jprecj 
    1543             zt3sn(:,jl,:,1) = ptab(:,ijhom+jl,:) ; ptab(:,ijhom+jl,:) = 0.0_wp 
    1544             zt3ns(:,jl,:,1) = ptab(:,jl      ,:) ; ptab(:,jl      ,:) = 0.0_wp 
    1545          END DO 
    1546       ENDIF 
    1547       ! 
    1548       !                           ! Migrations 
    1549       imigr = jprecj * jpi * jpk 
    1550       ! 
    1551       SELECT CASE ( nbondj ) 
    1552       CASE ( -1 ) 
    1553          CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 ) 
    1554          CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 
    1555          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1556       CASE ( 0 ) 
    1557          CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 
    1558          CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 ) 
    1559          CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 
    1560          CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 
    1561          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1562          IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    1563       CASE ( 1 ) 
    1564          CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 
    1565          CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 
    1566          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1567       END SELECT 
    1568       ! 
    1569       !                           ! Write lateral conditions 
    1570       ijhom = nlcj-nrecj 
    1571       ! 
    1572       SELECT CASE ( nbondj ) 
    1573       CASE ( -1 ) 
    1574          DO jl = 1, jprecj 
    1575             ptab(:,ijhom+jl,:) = ptab(:,ijhom+jl,:) + zt3ns(:,jl,:,2) 
    1576          END DO 
    1577       CASE ( 0 ) 
    1578          DO jl = 1, jprecj 
    1579             ptab(:,jprecj+jl,:) = ptab(:,jprecj+jl,:) + zt3sn(:,jl,:,2) 
    1580             ptab(:,ijhom +jl,:) = ptab(:,ijhom +jl,:) + zt3ns(:,jl,:,2) 
    1581          END DO 
    1582       CASE ( 1 ) 
    1583          DO jl = 1, jprecj 
    1584             ptab(:,jprecj+jl,:) = ptab(:,jprecj+jl,:) + zt3sn(:,jl   ,:,2) 
    1585          END DO 
    1586       END SELECT 
    1587  
    1588  
    1589       ! 4. north fold treatment 
    1590       ! ----------------------- 
    1591       ! 
    1592       IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
    1593          ! 
    1594          SELECT CASE ( jpni ) 
    1595          CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp 
    1596          CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs. 
    1597          END SELECT 
    1598          ! 
    1599       ENDIF 
    1600       ! 
    1601       DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we ) 
    1602       ! 
    1603    END SUBROUTINE mpp_lnk_sum_3d 
    1604  
    1605    SUBROUTINE mpp_lnk_sum_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 
    1606       !!---------------------------------------------------------------------- 
    1607       !!                  ***  routine mpp_lnk_sum_2d  *** 
    1608       !! 
    1609       !! ** Purpose :   Message passing manadgement for 2d array (sum the overlap region) 
    1610       !! 
    1611       !! ** Method  :   Use mppsend and mpprecv function for passing mask 
    1612       !!      between processors following neighboring subdomains. 
    1613       !!            domain parameters 
    1614       !!                    nlci   : first dimension of the local subdomain 
    1615       !!                    nlcj   : second dimension of the local subdomain 
    1616       !!                    nbondi : mark for "east-west local boundary" 
    1617       !!                    nbondj : mark for "north-south local boundary" 
    1618       !!                    noea   : number for local neighboring processors 
    1619       !!                    nowe   : number for local neighboring processors 
    1620       !!                    noso   : number for local neighboring processors 
    1621       !!                    nono   : number for local neighboring processors 
    1622       !! 
    1623       !!---------------------------------------------------------------------- 
    1624       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d     ! 2D array on which the boundary condition is applied 
    1625       CHARACTER(len=1)            , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points 
    1626       !                                                         ! = T , U , V , F , W and I points 
    1627       REAL(wp)                    , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary 
    1628       !                                                         ! =  1. , the sign is kept 
    1629       CHARACTER(len=3), OPTIONAL  , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
    1630       REAL(wp)        , OPTIONAL  , INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
    1631       !! 
    1632       INTEGER  ::   ji, jj, jl   ! dummy loop indices 
    1633       INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
    1634       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    1635       REAL(wp) ::   zland 
    1636       INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
    1637       ! 
    1638       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ns, zt2sn   ! 2d for north-south & south-north 
    1639       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ew, zt2we   ! 2d for east-west & west-east 
    1640  
    1641       !!---------------------------------------------------------------------- 
    1642  
    1643       ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2),  & 
    1644          &      zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2)   ) 
    1645  
    1646       ! 
    1647       IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
    1648       ELSE                         ;   zland = 0.e0      ! zero by default 
    1649       ENDIF 
    1650  
    1651       ! 1. standard boundary treatment 
    1652       ! ------------------------------ 
    1653       ! 2. East and west directions exchange 
    1654       ! ------------------------------------ 
    1655       ! we play with the neigbours AND the row number because of the periodicity 
    1656       ! 
    1657       SELECT CASE ( nbondi )      ! Read lateral conditions 
    1658       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    1659          iihom = nlci - jpreci 
    1660          DO jl = 1, jpreci 
    1661             zt2ew(:,jl,1) = pt2d(jl       ,:) ; pt2d(jl       ,:) = 0.0_wp 
    1662             zt2we(:,jl,1) = pt2d(iihom +jl,:) ; pt2d(iihom +jl,:) = 0.0_wp 
    1663          END DO 
    1664       END SELECT 
    1665       ! 
    1666       !                           ! Migrations 
    1667       imigr = jpreci * jpj 
    1668       ! 
    1669       SELECT CASE ( nbondi ) 
    1670       CASE ( -1 ) 
    1671          CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 ) 
    1672          CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 
    1673          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1674       CASE ( 0 ) 
    1675          CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 
    1676          CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 ) 
    1677          CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 
    1678          CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 
    1679          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1680          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    1681       CASE ( 1 ) 
    1682          CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 
    1683          CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 
    1684          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1685       END SELECT 
    1686       ! 
    1687       !                           ! Write lateral conditions 
    1688       iihom = nlci-nreci 
    1689       ! 
    1690       SELECT CASE ( nbondi ) 
    1691       CASE ( -1 ) 
    1692          DO jl = 1, jpreci 
    1693             pt2d(iihom+jl,:) = pt2d(iihom+jl,:) + zt2ew(:,jl,2) 
    1694          END DO 
    1695       CASE ( 0 ) 
    1696          DO jl = 1, jpreci 
    1697             pt2d(jpreci+jl,:) = pt2d(jpreci+jl,:) + zt2we(:,jl,2) 
    1698             pt2d(iihom +jl,:) = pt2d(iihom +jl,:) + zt2ew(:,jl,2) 
    1699          END DO 
    1700       CASE ( 1 ) 
    1701          DO jl = 1, jpreci 
    1702             pt2d(jpreci+jl,:) = pt2d(jpreci+jl,:) + zt2we(:,jl,2) 
    1703          END DO 
    1704       END SELECT 
    1705  
    1706  
    1707       ! 3. North and south directions 
    1708       ! ----------------------------- 
    1709       ! always closed : we play only with the neigbours 
    1710       ! 
    1711       IF( nbondj /= 2 ) THEN      ! Read lateral conditions 
    1712          ijhom = nlcj - jprecj 
    1713          DO jl = 1, jprecj 
    1714             zt2sn(:,jl,1) = pt2d(:,ijhom +jl) ; pt2d(:,ijhom +jl) = 0.0_wp 
    1715             zt2ns(:,jl,1) = pt2d(:,jl       ) ; pt2d(:,jl       ) = 0.0_wp 
    1716          END DO 
    1717       ENDIF 
    1718       ! 
    1719       !                           ! Migrations 
    1720       imigr = jprecj * jpi 
    1721       ! 
    1722       SELECT CASE ( nbondj ) 
    1723       CASE ( -1 ) 
    1724          CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 ) 
    1725          CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 
    1726          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1727       CASE ( 0 ) 
    1728          CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 
    1729          CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 ) 
    1730          CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 
    1731          CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 
    1732          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1733          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    1734       CASE ( 1 ) 
    1735          CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 
    1736          CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 
    1737          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1738       END SELECT 
    1739       ! 
    1740       !                           ! Write lateral conditions 
    1741       ijhom = nlcj-nrecj 
    1742       ! 
    1743       SELECT CASE ( nbondj ) 
    1744       CASE ( -1 ) 
    1745          DO jl = 1, jprecj 
    1746             pt2d(:,ijhom+jl) = pt2d(:,ijhom+jl) + zt2ns(:,jl,2) 
    1747          END DO 
    1748       CASE ( 0 ) 
    1749          DO jl = 1, jprecj 
    1750             pt2d(:,jprecj+jl) = pt2d(:,jprecj+jl) + zt2sn(:,jl,2) 
    1751             pt2d(:,ijhom +jl) = pt2d(:,ijhom +jl) + zt2ns(:,jl,2) 
    1752          END DO 
    1753       CASE ( 1 ) 
    1754          DO jl = 1, jprecj 
    1755             pt2d(:,jprecj+jl) = pt2d(:,jprecj+jl) + zt2sn(:,jl,2) 
    1756          END DO 
    1757       END SELECT 
    1758  
    1759  
    1760       ! 4. north fold treatment 
    1761       ! ----------------------- 
    1762       ! 
    1763       IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
    1764          ! 
    1765          SELECT CASE ( jpni ) 
    1766          CASE ( 1 )     ;   CALL lbc_nfd      ( pt2d, cd_type, psgn )   ! only 1 northern proc, no mpp 
    1767          CASE DEFAULT   ;   CALL mpp_lbc_north( pt2d, cd_type, psgn )   ! for all northern procs. 
    1768          END SELECT 
    1769          ! 
    1770       ENDIF 
    1771       ! 
    1772       DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 
    1773       ! 
    1774    END SUBROUTINE mpp_lnk_sum_2d 
    1775686 
    1776687   SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, md_req ) 
     
    1874785   END SUBROUTINE mppscatter 
    1875786 
    1876  
     787   !!---------------------------------------------------------------------- 
     788   !!    ***  mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real  *** 
     789   !!    
     790   !!---------------------------------------------------------------------- 
     791   !! 
    1877792   SUBROUTINE mppmax_a_int( ktab, kdim, kcom ) 
    1878       !!---------------------------------------------------------------------- 
    1879       !!                  ***  routine mppmax_a_int  *** 
    1880       !! 
    1881       !! ** Purpose :   Find maximum value in an integer layout array 
    1882       !! 
    1883793      !!---------------------------------------------------------------------- 
    1884794      INTEGER , INTENT(in   )                  ::   kdim   ! size of array 
    1885795      INTEGER , INTENT(inout), DIMENSION(kdim) ::   ktab   ! input array 
    1886796      INTEGER , INTENT(in   ), OPTIONAL        ::   kcom   ! 
    1887       ! 
    1888       INTEGER :: ierror, localcomm   ! temporary integer 
     797      INTEGER :: ierror, ilocalcomm   ! temporary integer 
    1889798      INTEGER, DIMENSION(kdim) ::   iwork 
    1890799      !!---------------------------------------------------------------------- 
    1891       ! 
    1892       localcomm = mpi_comm_opa 
    1893       IF( PRESENT(kcom) )   localcomm = kcom 
    1894       ! 
    1895       CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_max, localcomm, ierror ) 
    1896       ! 
     800      ilocalcomm = mpi_comm_opa 
     801      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     802      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_max, ilocalcomm, ierror ) 
    1897803      ktab(:) = iwork(:) 
    1898       ! 
    1899804   END SUBROUTINE mppmax_a_int 
    1900  
    1901  
     805   !! 
    1902806   SUBROUTINE mppmax_int( ktab, kcom ) 
    1903       !!---------------------------------------------------------------------- 
    1904       !!                  ***  routine mppmax_int  *** 
    1905       !! 
    1906       !! ** Purpose :   Find maximum value in an integer layout array 
    1907       !! 
    1908807      !!---------------------------------------------------------------------- 
    1909808      INTEGER, INTENT(inout)           ::   ktab   ! ??? 
    1910809      INTEGER, INTENT(in   ), OPTIONAL ::   kcom   ! ??? 
    1911       ! 
    1912       INTEGER ::   ierror, iwork, localcomm   ! temporary integer 
    1913       !!---------------------------------------------------------------------- 
    1914       ! 
    1915       localcomm = mpi_comm_opa 
    1916       IF( PRESENT(kcom) )   localcomm = kcom 
    1917       ! 
    1918       CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_max, localcomm, ierror ) 
    1919       ! 
     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 ) 
    1920815      ktab = iwork 
    1921       ! 
    1922816   END SUBROUTINE mppmax_int 
    1923  
    1924  
     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   !! 
    1925851   SUBROUTINE mppmin_a_int( ktab, kdim, kcom ) 
    1926       !!---------------------------------------------------------------------- 
    1927       !!                  ***  routine mppmin_a_int  *** 
    1928       !! 
    1929       !! ** Purpose :   Find minimum value in an integer layout array 
    1930       !! 
    1931852      !!---------------------------------------------------------------------- 
    1932853      INTEGER , INTENT( in  )                  ::   kdim   ! size of array 
     
    1934855      INTEGER , INTENT( in  ), OPTIONAL        ::   kcom   ! input array 
    1935856      !! 
    1936       INTEGER ::   ierror, localcomm   ! temporary integer 
     857      INTEGER ::   ierror, ilocalcomm   ! temporary integer 
    1937858      INTEGER, DIMENSION(kdim) ::   iwork 
    1938859      !!---------------------------------------------------------------------- 
    1939       ! 
    1940       localcomm = mpi_comm_opa 
    1941       IF( PRESENT(kcom) )   localcomm = kcom 
    1942       ! 
    1943       CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_min, localcomm, ierror ) 
    1944       ! 
     860      ilocalcomm = mpi_comm_opa 
     861      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     862      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_min, ilocalcomm, ierror ) 
    1945863      ktab(:) = iwork(:) 
    1946       ! 
    1947864   END SUBROUTINE mppmin_a_int 
    1948  
    1949  
     865   !! 
    1950866   SUBROUTINE mppmin_int( ktab, kcom ) 
    1951       !!---------------------------------------------------------------------- 
    1952       !!                  ***  routine mppmin_int  *** 
    1953       !! 
    1954       !! ** Purpose :   Find minimum value in an integer layout array 
    1955       !! 
    1956867      !!---------------------------------------------------------------------- 
    1957868      INTEGER, INTENT(inout) ::   ktab      ! ??? 
    1958869      INTEGER , INTENT( in  ), OPTIONAL        ::   kcom        ! input array 
    1959870      !! 
    1960       INTEGER ::  ierror, iwork, localcomm 
    1961       !!---------------------------------------------------------------------- 
    1962       ! 
    1963       localcomm = mpi_comm_opa 
    1964       IF( PRESENT(kcom) )   localcomm = kcom 
    1965       ! 
    1966       CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_min, localcomm, ierror ) 
    1967       ! 
     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 ) 
    1968876      ktab = iwork 
    1969       ! 
    1970877   END SUBROUTINE mppmin_int 
    1971  
    1972  
    1973    SUBROUTINE mppsum_a_int( ktab, kdim ) 
    1974       !!---------------------------------------------------------------------- 
    1975       !!                  ***  routine mppsum_a_int  *** 
    1976       !! 
    1977       !! ** Purpose :   Global integer sum, 1D array case 
    1978       !! 
    1979       !!---------------------------------------------------------------------- 
    1980       INTEGER, INTENT(in   )                   ::   kdim   ! ??? 
    1981       INTEGER, INTENT(inout), DIMENSION (kdim) ::   ktab   ! ??? 
    1982       ! 
    1983       INTEGER :: ierror 
    1984       INTEGER, DIMENSION (kdim) ::  iwork 
    1985       !!---------------------------------------------------------------------- 
    1986       ! 
    1987       CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_sum, mpi_comm_opa, ierror ) 
    1988       ! 
    1989       ktab(:) = iwork(:) 
    1990       ! 
    1991    END SUBROUTINE mppsum_a_int 
    1992  
    1993  
    1994    SUBROUTINE mppsum_int( ktab ) 
    1995       !!---------------------------------------------------------------------- 
    1996       !!                 ***  routine mppsum_int  *** 
    1997       !! 
    1998       !! ** Purpose :   Global integer sum 
    1999       !! 
    2000       !!---------------------------------------------------------------------- 
    2001       INTEGER, INTENT(inout) ::   ktab 
    2002       !! 
    2003       INTEGER :: ierror, iwork 
    2004       !!---------------------------------------------------------------------- 
    2005       ! 
    2006       CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_sum, mpi_comm_opa, ierror ) 
    2007       ! 
    2008       ktab = iwork 
    2009       ! 
    2010    END SUBROUTINE mppsum_int 
    2011  
    2012  
    2013    SUBROUTINE mppmax_a_real( ptab, kdim, kcom ) 
    2014       !!---------------------------------------------------------------------- 
    2015       !!                 ***  routine mppmax_a_real  *** 
    2016       !! 
    2017       !! ** Purpose :   Maximum 
    2018       !! 
     878   !! 
     879   SUBROUTINE mppmin_a_real( ptab, kdim, kcom ) 
    2019880      !!---------------------------------------------------------------------- 
    2020881      INTEGER , INTENT(in   )                  ::   kdim 
    2021882      REAL(wp), INTENT(inout), DIMENSION(kdim) ::   ptab 
    2022883      INTEGER , INTENT(in   ), OPTIONAL        ::   kcom 
    2023       ! 
    2024       INTEGER :: ierror, localcomm 
    2025       REAL(wp), DIMENSION(kdim) ::  zwork 
    2026       !!---------------------------------------------------------------------- 
    2027       ! 
    2028       localcomm = mpi_comm_opa 
    2029       IF( PRESENT(kcom) ) localcomm = kcom 
    2030       ! 
    2031       CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_max, localcomm, ierror ) 
    2032       ptab(:) = zwork(:) 
    2033       ! 
    2034    END SUBROUTINE mppmax_a_real 
    2035  
    2036  
    2037    SUBROUTINE mppmax_real( ptab, kcom ) 
    2038       !!---------------------------------------------------------------------- 
    2039       !!                  ***  routine mppmax_real  *** 
    2040       !! 
    2041       !! ** Purpose :   Maximum 
    2042       !! 
    2043       !!---------------------------------------------------------------------- 
    2044       REAL(wp), INTENT(inout)           ::   ptab   ! ??? 
    2045       INTEGER , INTENT(in   ), OPTIONAL ::   kcom   ! ??? 
    2046       !! 
    2047       INTEGER  ::   ierror, localcomm 
    2048       REAL(wp) ::   zwork 
    2049       !!---------------------------------------------------------------------- 
    2050       ! 
    2051       localcomm = mpi_comm_opa 
    2052       IF( PRESENT(kcom) )   localcomm = kcom 
    2053       ! 
    2054       CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_max, localcomm, ierror ) 
    2055       ptab = zwork 
    2056       ! 
    2057    END SUBROUTINE mppmax_real 
    2058  
    2059    SUBROUTINE mppmax_real_multiple( ptab, NUM , kcom  ) 
    2060       !!---------------------------------------------------------------------- 
    2061       !!                  ***  routine mppmax_real  *** 
    2062       !! 
    2063       !! ** Purpose :   Maximum 
    2064       !! 
    2065       !!---------------------------------------------------------------------- 
    2066       REAL(wp), DIMENSION(:) ,  INTENT(inout)           ::   ptab   ! ??? 
    2067       INTEGER , INTENT(in   )           ::   NUM 
    2068       INTEGER , INTENT(in   ), OPTIONAL ::   kcom   ! ??? 
    2069       !! 
    2070       INTEGER  ::   ierror, localcomm 
    2071       REAL(wp) , POINTER , DIMENSION(:) ::   zwork 
    2072       !!---------------------------------------------------------------------- 
    2073       ! 
    2074       CALL wrk_alloc(NUM , zwork) 
    2075       localcomm = mpi_comm_opa 
    2076       IF( PRESENT(kcom) )   localcomm = kcom 
    2077       ! 
    2078       CALL mpi_allreduce( ptab, zwork, NUM, mpi_double_precision, mpi_max, localcomm, ierror ) 
    2079       ptab = zwork 
    2080       CALL wrk_dealloc(NUM , zwork) 
    2081       ! 
    2082    END SUBROUTINE mppmax_real_multiple 
    2083  
    2084  
    2085    SUBROUTINE mppmin_a_real( ptab, kdim, kcom ) 
    2086       !!---------------------------------------------------------------------- 
    2087       !!                 ***  routine mppmin_a_real  *** 
    2088       !! 
    2089       !! ** Purpose :   Minimum of REAL, array case 
    2090       !! 
    2091       !!----------------------------------------------------------------------- 
    2092       INTEGER , INTENT(in   )                  ::   kdim 
    2093       REAL(wp), INTENT(inout), DIMENSION(kdim) ::   ptab 
    2094       INTEGER , INTENT(in   ), OPTIONAL        ::   kcom 
    2095       !! 
    2096       INTEGER :: ierror, localcomm 
     884      INTEGER :: ierror, ilocalcomm 
    2097885      REAL(wp), DIMENSION(kdim) ::   zwork 
    2098886      !!----------------------------------------------------------------------- 
    2099       ! 
    2100       localcomm = mpi_comm_opa 
    2101       IF( PRESENT(kcom) ) localcomm = kcom 
    2102       ! 
    2103       CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_min, localcomm, ierror ) 
     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 ) 
    2104890      ptab(:) = zwork(:) 
    2105       ! 
    2106891   END SUBROUTINE mppmin_a_real 
    2107  
    2108  
     892   !! 
    2109893   SUBROUTINE mppmin_real( ptab, kcom ) 
    2110       !!---------------------------------------------------------------------- 
    2111       !!                  ***  routine mppmin_real  *** 
    2112       !! 
    2113       !! ** Purpose :   minimum of REAL, scalar case 
    2114       !! 
    2115894      !!----------------------------------------------------------------------- 
    2116895      REAL(wp), INTENT(inout)           ::   ptab        ! 
    2117896      INTEGER , INTENT(in   ), OPTIONAL :: kcom 
    2118       !! 
    2119       INTEGER  ::   ierror 
    2120       REAL(wp) ::   zwork 
    2121       INTEGER :: localcomm 
    2122       !!----------------------------------------------------------------------- 
    2123       ! 
    2124       localcomm = mpi_comm_opa 
    2125       IF( PRESENT(kcom) )   localcomm = kcom 
    2126       ! 
    2127       CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_min, localcomm, ierror ) 
    2128       ptab = zwork 
    2129       ! 
    2130    END SUBROUTINE mppmin_real 
    2131  
    2132  
    2133    SUBROUTINE mppsum_a_real( ptab, kdim, kcom ) 
    2134       !!---------------------------------------------------------------------- 
    2135       !!                  ***  routine mppsum_a_real  *** 
    2136       !! 
    2137       !! ** Purpose :   global sum, REAL ARRAY argument case 
    2138       !! 
    2139       !!----------------------------------------------------------------------- 
    2140       INTEGER , INTENT( in )                     ::   kdim      ! size of ptab 
    2141       REAL(wp), DIMENSION(kdim), INTENT( inout ) ::   ptab      ! input array 
    2142       INTEGER , INTENT( in ), OPTIONAL           :: kcom 
    2143       !! 
    2144       INTEGER                   ::   ierror    ! temporary integer 
    2145       INTEGER                   ::   localcomm 
    2146       REAL(wp), DIMENSION(kdim) ::   zwork     ! temporary workspace 
    2147       !!----------------------------------------------------------------------- 
    2148       ! 
    2149       localcomm = mpi_comm_opa 
    2150       IF( PRESENT(kcom) )   localcomm = kcom 
    2151       ! 
    2152       CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_sum, localcomm, ierror ) 
    2153       ptab(:) = zwork(:) 
    2154       ! 
    2155    END SUBROUTINE mppsum_a_real 
    2156  
    2157  
    2158    SUBROUTINE mppsum_real( ptab, kcom ) 
    2159       !!---------------------------------------------------------------------- 
    2160       !!                  ***  routine mppsum_real  *** 
    2161       !! 
    2162       !! ** Purpose :   global sum, SCALAR argument case 
    2163       !! 
    2164       !!----------------------------------------------------------------------- 
    2165       REAL(wp), INTENT(inout)           ::   ptab   ! input scalar 
    2166       INTEGER , INTENT(in   ), OPTIONAL ::   kcom 
    2167       !! 
    2168       INTEGER  ::   ierror, localcomm 
     897      INTEGER  ::   ierror, ilocalcomm 
    2169898      REAL(wp) ::   zwork 
    2170899      !!----------------------------------------------------------------------- 
    2171       ! 
    2172       localcomm = mpi_comm_opa 
    2173       IF( PRESENT(kcom) ) localcomm = kcom 
    2174       ! 
    2175       CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_sum, localcomm, ierror ) 
     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 ) 
    2176903      ptab = zwork 
    2177       ! 
     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   !! 
     913   SUBROUTINE mppsum_a_int( ktab, kdim ) 
     914      !!---------------------------------------------------------------------- 
     915      INTEGER, INTENT(in   )                   ::   kdim   ! ??? 
     916      INTEGER, INTENT(inout), DIMENSION (kdim) ::   ktab   ! ??? 
     917      INTEGER :: ierror 
     918      INTEGER, DIMENSION (kdim) ::  iwork 
     919      !!---------------------------------------------------------------------- 
     920      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_sum, mpi_comm_opa, ierror ) 
     921      ktab(:) = iwork(:) 
     922   END SUBROUTINE mppsum_a_int 
     923   !! 
     924   SUBROUTINE mppsum_int( ktab ) 
     925      !!---------------------------------------------------------------------- 
     926      INTEGER, INTENT(inout) ::   ktab 
     927      INTEGER :: ierror, iwork 
     928      !!---------------------------------------------------------------------- 
     929      CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_sum, mpi_comm_opa, ierror ) 
     930      ktab = iwork 
     931   END SUBROUTINE mppsum_int 
     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 ) 
     944      ptab(:) = zwork(:) 
     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 
    2178958   END SUBROUTINE mppsum_real 
    2179  
    2180  
     959   !! 
    2181960   SUBROUTINE mppsum_realdd( ytab, kcom ) 
    2182       !!---------------------------------------------------------------------- 
    2183       !!                  ***  routine mppsum_realdd *** 
    2184       !! 
    2185       !! ** Purpose :   global sum in Massively Parallel Processing 
    2186       !!                SCALAR argument case for double-double precision 
    2187       !! 
    2188961      !!----------------------------------------------------------------------- 
    2189       COMPLEX(wp), INTENT(inout)           ::   ytab    ! input scalar 
    2190       INTEGER    , INTENT(in   ), OPTIONAL ::   kcom 
    2191       ! 
    2192       INTEGER     ::   ierror 
    2193       INTEGER     ::   localcomm 
     962      COMPLEX(wp)          , INTENT(inout) ::   ytab    ! input scalar 
     963      INTEGER    , OPTIONAL, INTENT(in   ) ::   kcom 
     964      INTEGER     ::   ierror, ilocalcomm 
    2194965      COMPLEX(wp) ::   zwork 
    2195966      !!----------------------------------------------------------------------- 
    2196       ! 
    2197       localcomm = mpi_comm_opa 
    2198       IF( PRESENT(kcom) )   localcomm = kcom 
    2199       ! 
    2200       ! reduce local sums into global sum 
    2201       CALL MPI_ALLREDUCE (ytab, zwork, 1, MPI_DOUBLE_COMPLEX, MPI_SUMDD, localcomm, ierror ) 
     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 ) 
    2202970      ytab = zwork 
    2203       ! 
    2204971   END SUBROUTINE mppsum_realdd 
    2205  
    2206  
     972   !! 
    2207973   SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom ) 
    2208974      !!---------------------------------------------------------------------- 
    2209       !!                  ***  routine mppsum_a_realdd  *** 
    2210       !! 
    2211       !! ** Purpose :   global sum in Massively Parallel Processing 
    2212       !!                COMPLEX ARRAY case for double-double precision 
    2213       !! 
    2214       !!----------------------------------------------------------------------- 
    2215975      INTEGER                     , INTENT(in   ) ::   kdim   ! size of ytab 
    2216976      COMPLEX(wp), DIMENSION(kdim), INTENT(inout) ::   ytab   ! input array 
    2217977      INTEGER    , OPTIONAL       , INTENT(in   ) ::   kcom 
    2218       ! 
    2219       INTEGER:: ierror, localcomm    ! local integer 
     978      INTEGER:: ierror, ilocalcomm    ! local integer 
    2220979      COMPLEX(wp), DIMENSION(kdim) :: zwork     ! temporary workspace 
    2221980      !!----------------------------------------------------------------------- 
    2222       ! 
    2223       localcomm = mpi_comm_opa 
    2224       IF( PRESENT(kcom) )   localcomm = kcom 
    2225       ! 
    2226       CALL MPI_ALLREDUCE( ytab, zwork, kdim, MPI_DOUBLE_COMPLEX, MPI_SUMDD, localcomm, ierror ) 
     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 ) 
    2227984      ytab(:) = zwork(:) 
    2228       ! 
    2229985   END SUBROUTINE mppsum_a_realdd 
     986    
     987 
     988   SUBROUTINE mppmax_real_multiple( pt1d, kdim, kcom  ) 
     989      !!---------------------------------------------------------------------- 
     990      !!                  ***  routine mppmax_real  *** 
     991      !! 
     992      !! ** Purpose :   Maximum across processor of each element of a 1D arrays 
     993      !! 
     994      !!---------------------------------------------------------------------- 
     995      REAL(wp), DIMENSION(kdim), INTENT(inout) ::   pt1d   ! 1D arrays 
     996      INTEGER                  , INTENT(in   ) ::   kdim 
     997      INTEGER , OPTIONAL       , INTENT(in   ) ::   kcom   ! local communicator 
     998      !! 
     999      INTEGER  ::   ierror, ilocalcomm 
     1000      REAL(wp), DIMENSION(kdim) ::  zwork 
     1001      !!---------------------------------------------------------------------- 
     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 ) 
     1006      pt1d(:) = zwork(:) 
     1007      ! 
     1008   END SUBROUTINE mppmax_real_multiple 
    22301009 
    22311010 
     
    22431022      REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   pmask   ! Local mask 
    22441023      REAL(wp)                     , INTENT(  out) ::   pmin    ! Global minimum of ptab 
    2245       INTEGER                      , INTENT(  out) ::   ki, kj   ! index of minimum in global frame 
     1024      INTEGER                      , INTENT(  out) ::   ki, kj  ! index of minimum in global frame 
    22461025      ! 
    22471026      INTEGER :: ierror 
     
    22511030      !!----------------------------------------------------------------------- 
    22521031      ! 
    2253       zmin  = MINVAL( ptab(:,:) , mask= pmask == 1.e0 ) 
    2254       ilocs = MINLOC( ptab(:,:) , mask= pmask == 1.e0 ) 
     1032      zmin  = MINVAL( ptab(:,:) , mask= pmask == 1._wp ) 
     1033      ilocs = MINLOC( ptab(:,:) , mask= pmask == 1._wp ) 
    22551034      ! 
    22561035      ki = ilocs(1) + nimpp - 1 
     
    22791058      !! 
    22801059      !!-------------------------------------------------------------------------- 
    2281       REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   ptab         ! Local 2D array 
    2282       REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   pmask        ! Local mask 
    2283       REAL(wp)                         , INTENT(  out) ::   pmin         ! Global minimum of ptab 
    2284       INTEGER                          , INTENT(  out) ::   ki, kj, kk   ! index of minimum in global frame 
    2285       !! 
     1060      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   ptab         ! Local 2D array 
     1061      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   pmask        ! Local mask 
     1062      REAL(wp)                  , INTENT(  out) ::   pmin         ! Global minimum of ptab 
     1063      INTEGER                   , INTENT(  out) ::   ki, kj, kk   ! index of minimum in global frame 
     1064      ! 
    22861065      INTEGER  ::   ierror 
    22871066      REAL(wp) ::   zmin     ! local minimum 
     
    22901069      !!----------------------------------------------------------------------- 
    22911070      ! 
    2292       zmin  = MINVAL( ptab(:,:,:) , mask= pmask == 1.e0 ) 
    2293       ilocs = MINLOC( ptab(:,:,:) , mask= pmask == 1.e0 ) 
     1071      zmin  = MINVAL( ptab(:,:,:) , mask= pmask == 1._wp ) 
     1072      ilocs = MINLOC( ptab(:,:,:) , mask= pmask == 1._wp ) 
    22941073      ! 
    22951074      ki = ilocs(1) + nimpp - 1 
     
    22971076      kk = ilocs(3) 
    22981077      ! 
    2299       zain(1,:)=zmin 
    2300       zain(2,:)=ki+10000.*kj+100000000.*kk 
     1078      zain(1,:) = zmin 
     1079      zain(2,:) = ki + 10000.*kj + 100000000.*kk 
    23011080      ! 
    23021081      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror) 
     
    23311110      !!----------------------------------------------------------------------- 
    23321111      ! 
    2333       zmax  = MAXVAL( ptab(:,:) , mask= pmask == 1.e0 ) 
    2334       ilocs = MAXLOC( ptab(:,:) , mask= pmask == 1.e0 ) 
     1112      zmax  = MAXVAL( ptab(:,:) , mask= pmask == 1._wp ) 
     1113      ilocs = MAXLOC( ptab(:,:) , mask= pmask == 1._wp ) 
    23351114      ! 
    23361115      ki = ilocs(1) + nimpp - 1 
     
    23591138      !! 
    23601139      !!-------------------------------------------------------------------------- 
    2361       REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   ptab         ! Local 2D array 
    2362       REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   pmask        ! Local mask 
    2363       REAL(wp)                         , INTENT(  out) ::   pmax         ! Global maximum of ptab 
    2364       INTEGER                          , INTENT(  out) ::   ki, kj, kk   ! index of maximum in global frame 
    2365       !! 
    2366       REAL(wp) :: zmax   ! local maximum 
     1140      REAL(wp), DIMENSION (:,:,:), INTENT(in   ) ::   ptab         ! Local 2D array 
     1141      REAL(wp), DIMENSION (:,:,:), INTENT(in   ) ::   pmask        ! Local mask 
     1142      REAL(wp)                   , INTENT(  out) ::   pmax         ! Global maximum of ptab 
     1143      INTEGER                    , INTENT(  out) ::   ki, kj, kk   ! index of maximum in global frame 
     1144      ! 
     1145      INTEGER  ::   ierror   ! local integer 
     1146      REAL(wp) ::   zmax     ! local maximum 
    23671147      REAL(wp), DIMENSION(2,1) ::   zain, zaout 
    23681148      INTEGER , DIMENSION(3)   ::   ilocs 
    2369       INTEGER :: ierror 
    23701149      !!----------------------------------------------------------------------- 
    23711150      ! 
    2372       zmax  = MAXVAL( ptab(:,:,:) , mask= pmask == 1.e0 ) 
    2373       ilocs = MAXLOC( ptab(:,:,:) , mask= pmask == 1.e0 ) 
     1151      zmax  = MAXVAL( ptab(:,:,:) , mask= pmask == 1._wp ) 
     1152      ilocs = MAXLOC( ptab(:,:,:) , mask= pmask == 1._wp ) 
    23741153      ! 
    23751154      ki = ilocs(1) + nimpp - 1 
     
    23771156      kk = ilocs(3) 
    23781157      ! 
    2379       zain(1,:)=zmax 
    2380       zain(2,:)=ki+10000.*kj+100000000.*kk 
     1158      zain(1,:) = zmax 
     1159      zain(2,:) = ki + 10000.*kj + 100000000.*kk 
    23811160      ! 
    23821161      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror) 
     
    24221201 
    24231202   SUBROUTINE mpp_comm_free( kcom ) 
    2424       !!---------------------------------------------------------------------- 
    24251203      !!---------------------------------------------------------------------- 
    24261204      INTEGER, INTENT(in) ::   kcom 
     
    26801458 
    26811459 
    2682    SUBROUTINE mpp_lbc_north_3d( pt3d, cd_type, psgn ) 
    2683       !!--------------------------------------------------------------------- 
    2684       !!                   ***  routine mpp_lbc_north_3d  *** 
    2685       !! 
    2686       !! ** Purpose :   Ensure proper north fold horizontal bondary condition 
    2687       !!              in mpp configuration in case of jpn1 > 1 
    2688       !! 
    2689       !! ** Method  :   North fold condition and mpp with more than one proc 
    2690       !!              in i-direction require a specific treatment. We gather 
    2691       !!              the 4 northern lines of the global domain on 1 processor 
    2692       !!              and apply lbc north-fold on this sub array. Then we 
    2693       !!              scatter the north fold array back to the processors. 
    2694       !! 
    2695       !!---------------------------------------------------------------------- 
    2696       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pt3d      ! 3D array on which the b.c. is applied 
    2697       CHARACTER(len=1)                , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points 
    2698       !                                                              !   = T ,  U , V , F or W  gridpoints 
    2699       REAL(wp)                        , INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold  
    2700       !!                                                             ! =  1. , the sign is kept 
    2701       INTEGER ::   ji, jj, jr, jk 
    2702       INTEGER ::   ierr, itaille, ildi, ilei, iilb 
    2703       INTEGER ::   ijpj, ijpjm1, ij, iproc 
    2704       INTEGER, DIMENSION (jpmaxngh)          ::   ml_req_nf          !for mpi_isend when avoiding mpi_allgather 
    2705       INTEGER                                ::   ml_err             ! for mpi_isend when avoiding mpi_allgather 
    2706       INTEGER, DIMENSION(MPI_STATUS_SIZE)    ::   ml_stat            ! for mpi_isend when avoiding mpi_allgather 
    2707       !                                                              ! Workspace for message transfers avoiding mpi_allgather 
    2708       REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztab 
    2709       REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: znorthloc, zfoldwk       
    2710       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE   :: znorthgloio 
    2711       REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztabl, ztabr 
    2712  
    2713       INTEGER :: istatus(mpi_status_size) 
    2714       INTEGER :: iflag 
    2715       !!---------------------------------------------------------------------- 
    2716       ! 
    2717       ALLOCATE( ztab(jpiglo,4,jpk) , znorthloc(jpi,4,jpk), zfoldwk(jpi,4,jpk), znorthgloio(jpi,4,jpk,jpni) ) 
    2718       ALLOCATE( ztabl(jpi,4,jpk), ztabr(jpi*jpmaxngh, 4, jpk) )  
    2719  
    2720       ijpj   = 4 
    2721       ijpjm1 = 3 
    2722       ! 
    2723       znorthloc(:,:,:) = 0 
    2724       DO jk = 1, jpk 
    2725          DO jj = nlcj - ijpj +1, nlcj          ! put in xnorthloc the last 4 jlines of pt3d 
    2726             ij = jj - nlcj + ijpj 
    2727             znorthloc(:,ij,jk) = pt3d(:,jj,jk) 
    2728          END DO 
    2729       END DO 
    2730       ! 
    2731       !                                     ! Build in procs of ncomm_north the znorthgloio 
    2732       itaille = jpi * jpk * ijpj 
    2733  
    2734       IF ( l_north_nogather ) THEN 
    2735          ! 
    2736         ztabr(:,:,:) = 0 
    2737         ztabl(:,:,:) = 0 
    2738  
    2739         DO jk = 1, jpk 
    2740            DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array 
    2741               ij = jj - nlcj + ijpj 
    2742               DO ji = nfsloop, nfeloop 
    2743                  ztabl(ji,ij,jk) = pt3d(ji,jj,jk) 
    2744               END DO 
    2745            END DO 
    2746         END DO 
    2747  
    2748          DO jr = 1,nsndto 
    2749             IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
    2750               CALL mppsend( 5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) ) 
    2751             ENDIF 
    2752          END DO 
    2753          DO jr = 1,nsndto 
    2754             iproc = nfipproc(isendto(jr),jpnj) 
    2755             IF(iproc .ne. -1) THEN 
    2756                ilei = nleit (iproc+1) 
    2757                ildi = nldit (iproc+1) 
    2758                iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 
    2759             ENDIF 
    2760             IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN 
    2761               CALL mpprecv(5, zfoldwk, itaille, iproc) 
    2762               DO jk = 1, jpk 
    2763                  DO jj = 1, ijpj 
    2764                     DO ji = ildi, ilei 
    2765                        ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk) 
    2766                     END DO 
    2767                  END DO 
    2768               END DO 
    2769            ELSE IF (iproc .eq. (narea-1)) THEN 
    2770               DO jk = 1, jpk 
    2771                  DO jj = 1, ijpj 
    2772                     DO ji = ildi, ilei 
    2773                        ztabr(iilb+ji,jj,jk) = pt3d(ji,nlcj-ijpj+jj,jk) 
    2774                     END DO 
    2775                  END DO 
    2776               END DO 
    2777            ENDIF 
    2778          END DO 
    2779          IF (l_isend) THEN 
    2780             DO jr = 1,nsndto 
    2781                IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
    2782                   CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 
    2783                ENDIF     
    2784             END DO 
    2785          ENDIF 
    2786          CALL mpp_lbc_nfd( ztabl, ztabr, cd_type, psgn )   ! North fold boundary condition 
    2787          DO jk = 1, jpk 
    2788             DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt3d 
    2789                ij = jj - nlcj + ijpj 
    2790                DO ji= 1, nlci 
    2791                   pt3d(ji,jj,jk) = ztabl(ji,ij,jk) 
    2792                END DO 
    2793             END DO 
    2794          END DO 
    2795          ! 
    2796  
    2797       ELSE 
    2798          CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,                & 
    2799             &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
    2800          ! 
    2801          ztab(:,:,:) = 0.e0 
    2802          DO jr = 1, ndim_rank_north         ! recover the global north array 
    2803             iproc = nrank_north(jr) + 1 
    2804             ildi  = nldit (iproc) 
    2805             ilei  = nleit (iproc) 
    2806             iilb  = nimppt(iproc) 
    2807             DO jk = 1, jpk 
    2808                DO jj = 1, ijpj 
    2809                   DO ji = ildi, ilei 
    2810                     ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr) 
    2811                   END DO 
    2812                END DO 
    2813             END DO 
    2814          END DO 
    2815          CALL lbc_nfd( ztab, cd_type, psgn )   ! North fold boundary condition 
    2816          ! 
    2817          DO jk = 1, jpk 
    2818             DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt3d 
    2819                ij = jj - nlcj + ijpj 
    2820                DO ji= 1, nlci 
    2821                   pt3d(ji,jj,jk) = ztab(ji+nimpp-1,ij,jk) 
    2822                END DO 
    2823             END DO 
    2824          END DO 
    2825          ! 
    2826       ENDIF 
    2827       ! 
    2828       ! The ztab array has been either: 
    2829       !  a. Fully populated by the mpi_allgather operation or 
    2830       !  b. Had the active points for this domain and northern neighbours populated 
    2831       !     by peer to peer exchanges 
    2832       ! Either way the array may be folded by lbc_nfd and the result for the span of 
    2833       ! this domain will be identical. 
    2834       ! 
    2835       DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio ) 
    2836       DEALLOCATE( ztabl, ztabr )  
    2837       ! 
    2838    END SUBROUTINE mpp_lbc_north_3d 
    2839  
    2840  
    2841    SUBROUTINE mpp_lbc_north_2d( pt2d, cd_type, psgn) 
    2842       !!--------------------------------------------------------------------- 
    2843       !!                   ***  routine mpp_lbc_north_2d  *** 
    2844       !! 
    2845       !! ** Purpose :   Ensure proper north fold horizontal bondary condition 
    2846       !!              in mpp configuration in case of jpn1 > 1 (for 2d array ) 
    2847       !! 
    2848       !! ** Method  :   North fold condition and mpp with more than one proc 
    2849       !!              in i-direction require a specific treatment. We gather 
    2850       !!              the 4 northern lines of the global domain on 1 processor 
    2851       !!              and apply lbc north-fold on this sub array. Then we 
    2852       !!              scatter the north fold array back to the processors. 
    2853       !! 
    2854       !!---------------------------------------------------------------------- 
    2855       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d      ! 2D array on which the b.c. is applied 
    2856       CHARACTER(len=1)            , INTENT(in   ) ::   cd_type   ! nature of pt2d grid-points 
    2857       !                                                          !   = T ,  U , V , F or W  gridpoints 
    2858       REAL(wp)                    , INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold  
    2859       !!                                                             ! =  1. , the sign is kept 
    2860       INTEGER ::   ji, jj, jr 
    2861       INTEGER ::   ierr, itaille, ildi, ilei, iilb 
    2862       INTEGER ::   ijpj, ijpjm1, ij, iproc 
    2863       INTEGER, DIMENSION (jpmaxngh)      ::   ml_req_nf          !for mpi_isend when avoiding mpi_allgather 
    2864       INTEGER                            ::   ml_err             ! for mpi_isend when avoiding mpi_allgather 
    2865       INTEGER, DIMENSION(MPI_STATUS_SIZE)::   ml_stat            ! for mpi_isend when avoiding mpi_allgather 
    2866       !                                                              ! Workspace for message transfers avoiding mpi_allgather 
    2867       REAL(wp), DIMENSION(:,:)  , ALLOCATABLE   :: ztab 
    2868       REAL(wp), DIMENSION(:,:)  , ALLOCATABLE   :: znorthloc, zfoldwk       
    2869       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE   :: znorthgloio 
    2870       REAL(wp), DIMENSION(:,:)  , ALLOCATABLE   :: ztabl, ztabr 
    2871       INTEGER :: istatus(mpi_status_size) 
    2872       INTEGER :: iflag 
    2873       !!---------------------------------------------------------------------- 
    2874       ! 
    2875       ALLOCATE( ztab(jpiglo,4), znorthloc(jpi,4), zfoldwk(jpi,4), znorthgloio(jpi,4,jpni) ) 
    2876       ALLOCATE( ztabl(jpi,4), ztabr(jpi*jpmaxngh, 4) )  
    2877       ! 
    2878       ijpj   = 4 
    2879       ijpjm1 = 3 
    2880       ! 
    2881       DO jj = nlcj-ijpj+1, nlcj             ! put in znorthloc the last 4 jlines of pt2d 
    2882          ij = jj - nlcj + ijpj 
    2883          znorthloc(:,ij) = pt2d(:,jj) 
    2884       END DO 
    2885  
    2886       !                                     ! Build in procs of ncomm_north the znorthgloio 
    2887       itaille = jpi * ijpj 
    2888       IF ( l_north_nogather ) THEN 
    2889          ! 
    2890          ! Avoid the use of mpi_allgather by exchanging only with the processes already identified  
    2891          ! (in nemo_northcomms) as being  involved in this process' northern boundary exchange 
    2892          ! 
    2893          ztabr(:,:) = 0 
    2894          ztabl(:,:) = 0 
    2895  
    2896          DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array 
    2897             ij = jj - nlcj + ijpj 
    2898               DO ji = nfsloop, nfeloop 
    2899                ztabl(ji,ij) = pt2d(ji,jj) 
    2900             END DO 
    2901          END DO 
    2902  
    2903          DO jr = 1,nsndto 
    2904             IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
    2905                CALL mppsend(5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) 
    2906             ENDIF 
    2907          END DO 
    2908          DO jr = 1,nsndto 
    2909             iproc = nfipproc(isendto(jr),jpnj) 
    2910             IF(iproc .ne. -1) THEN 
    2911                ilei = nleit (iproc+1) 
    2912                ildi = nldit (iproc+1) 
    2913                iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 
    2914             ENDIF 
    2915             IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN 
    2916               CALL mpprecv(5, zfoldwk, itaille, iproc) 
    2917               DO jj = 1, ijpj 
    2918                  DO ji = ildi, ilei 
    2919                     ztabr(iilb+ji,jj) = zfoldwk(ji,jj) 
    2920                  END DO 
    2921               END DO 
    2922             ELSE IF (iproc .eq. (narea-1)) THEN 
    2923               DO jj = 1, ijpj 
    2924                  DO ji = ildi, ilei 
    2925                     ztabr(iilb+ji,jj) = pt2d(ji,nlcj-ijpj+jj) 
    2926                  END DO 
    2927               END DO 
    2928             ENDIF 
    2929          END DO 
    2930          IF (l_isend) THEN 
    2931             DO jr = 1,nsndto 
    2932                IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
    2933                   CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 
    2934                ENDIF 
    2935             END DO 
    2936          ENDIF 
    2937          CALL mpp_lbc_nfd( ztabl, ztabr, cd_type, psgn )   ! North fold boundary condition 
    2938          ! 
    2939          DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
    2940             ij = jj - nlcj + ijpj 
    2941             DO ji = 1, nlci 
    2942                pt2d(ji,jj) = ztabl(ji,ij) 
    2943             END DO 
    2944          END DO 
    2945          ! 
    2946       ELSE 
    2947          CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,        & 
    2948             &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
    2949          ! 
    2950          ztab(:,:) = 0.e0 
    2951          DO jr = 1, ndim_rank_north            ! recover the global north array 
    2952             iproc = nrank_north(jr) + 1 
    2953             ildi = nldit (iproc) 
    2954             ilei = nleit (iproc) 
    2955             iilb = nimppt(iproc) 
    2956             DO jj = 1, ijpj 
    2957                DO ji = ildi, ilei 
    2958                   ztab(ji+iilb-1,jj) = znorthgloio(ji,jj,jr) 
    2959                END DO 
    2960             END DO 
    2961          END DO 
    2962          CALL lbc_nfd( ztab, cd_type, psgn )   ! North fold boundary condition 
    2963          ! 
    2964          DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
    2965             ij = jj - nlcj + ijpj 
    2966             DO ji = 1, nlci 
    2967                pt2d(ji,jj) = ztab(ji+nimpp-1,ij) 
    2968             END DO 
    2969          END DO 
    2970          ! 
    2971       ENDIF 
    2972       DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio ) 
    2973       DEALLOCATE( ztabl, ztabr )  
    2974       ! 
    2975    END SUBROUTINE mpp_lbc_north_2d 
    2976  
    2977    SUBROUTINE mpp_lbc_north_2d_multiple( pt2d_array, cd_type, psgn, num_fields) 
    2978       !!--------------------------------------------------------------------- 
    2979       !!                   ***  routine mpp_lbc_north_2d  *** 
    2980       !! 
    2981       !! ** Purpose :   Ensure proper north fold horizontal bondary condition 
    2982       !!              in mpp configuration in case of jpn1 > 1 
    2983       !!              (for multiple 2d arrays ) 
    2984       !! 
    2985       !! ** Method  :   North fold condition and mpp with more than one proc 
    2986       !!              in i-direction require a specific treatment. We gather 
    2987       !!              the 4 northern lines of the global domain on 1 processor 
    2988       !!              and apply lbc north-fold on this sub array. Then we 
    2989       !!              scatter the north fold array back to the processors. 
    2990       !! 
    2991       !!---------------------------------------------------------------------- 
    2992       INTEGER ,  INTENT (in   ) ::   num_fields  ! number of variables contained in pt2d 
    2993       TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 
    2994       CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   cd_type   ! nature of pt2d grid-points 
    2995       !                                                          !   = T ,  U , V , F or W  gridpoints 
    2996       REAL(wp), DIMENSION(:), INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold  
    2997       !!                                                             ! =  1. , the sign is kept 
    2998       INTEGER ::   ji, jj, jr, jk 
    2999       INTEGER ::   ierr, itaille, ildi, ilei, iilb 
    3000       INTEGER ::   ijpj, ijpjm1, ij, iproc 
    3001       INTEGER, DIMENSION (jpmaxngh)      ::   ml_req_nf          !for mpi_isend when avoiding mpi_allgather 
    3002       INTEGER                            ::   ml_err             ! for mpi_isend when avoiding mpi_allgather 
    3003       INTEGER, DIMENSION(MPI_STATUS_SIZE)::   ml_stat            ! for mpi_isend when avoiding mpi_allgather 
    3004       !                                                              ! Workspace for message transfers avoiding mpi_allgather 
    3005       REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztab 
    3006       REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: znorthloc, zfoldwk 
    3007       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE   :: znorthgloio 
    3008       REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztabl, ztabr 
    3009       INTEGER :: istatus(mpi_status_size) 
    3010       INTEGER :: iflag 
    3011       !!---------------------------------------------------------------------- 
    3012       ! 
    3013       ALLOCATE( ztab(jpiglo,4,num_fields), znorthloc(jpi,4,num_fields), zfoldwk(jpi,4,num_fields),   & 
    3014             &   znorthgloio(jpi,4,num_fields,jpni) )   ! expanded to 3 dimensions 
    3015       ALLOCATE( ztabl(jpi,4,num_fields), ztabr(jpi*jpmaxngh, 4,num_fields) ) 
    3016       ! 
    3017       ijpj   = 4 
    3018       ijpjm1 = 3 
    3019       ! 
    3020        
    3021       DO jk = 1, num_fields 
    3022          DO jj = nlcj-ijpj+1, nlcj             ! put in znorthloc the last 4 jlines of pt2d (for every variable) 
    3023             ij = jj - nlcj + ijpj 
    3024             znorthloc(:,ij,jk) = pt2d_array(jk)%pt2d(:,jj) 
    3025          END DO 
    3026       END DO 
    3027       !                                     ! Build in procs of ncomm_north the znorthgloio 
    3028       itaille = jpi * ijpj 
    3029                                                                    
    3030       IF ( l_north_nogather ) THEN 
    3031          ! 
    3032          ! Avoid the use of mpi_allgather by exchanging only with the processes already identified  
    3033          ! (in nemo_northcomms) as being  involved in this process' northern boundary exchange 
    3034          ! 
    3035          ztabr(:,:,:) = 0 
    3036          ztabl(:,:,:) = 0 
    3037  
    3038          DO jk = 1, num_fields 
    3039             DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array 
    3040                ij = jj - nlcj + ijpj 
    3041                DO ji = nfsloop, nfeloop 
    3042                   ztabl(ji,ij,jk) = pt2d_array(jk)%pt2d(ji,jj) 
    3043                END DO 
    3044             END DO 
    3045          END DO 
    3046  
    3047          DO jr = 1,nsndto 
    3048             IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
    3049                CALL mppsend(5, znorthloc, itaille*num_fields, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) ! Buffer expanded "num_fields" times 
    3050             ENDIF 
    3051          END DO 
    3052          DO jr = 1,nsndto 
    3053             iproc = nfipproc(isendto(jr),jpnj) 
    3054             IF(iproc .ne. -1) THEN 
    3055                ilei = nleit (iproc+1) 
    3056                ildi = nldit (iproc+1) 
    3057                iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 
    3058             ENDIF 
    3059             IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN 
    3060               CALL mpprecv(5, zfoldwk, itaille*num_fields, iproc) ! Buffer expanded "num_fields" times 
    3061               DO jk = 1 , num_fields 
    3062                  DO jj = 1, ijpj 
    3063                     DO ji = ildi, ilei 
    3064                        ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk)       ! Modified to 3D 
    3065                     END DO 
    3066                  END DO 
    3067               END DO 
    3068             ELSE IF (iproc .eq. (narea-1)) THEN 
    3069               DO jk = 1, num_fields 
    3070                  DO jj = 1, ijpj 
    3071                     DO ji = ildi, ilei 
    3072                           ztabr(iilb+ji,jj,jk) = pt2d_array(jk)%pt2d(ji,nlcj-ijpj+jj)       ! Modified to 3D 
    3073                     END DO 
    3074                  END DO 
    3075               END DO 
    3076             ENDIF 
    3077          END DO 
    3078          IF (l_isend) THEN 
    3079             DO jr = 1,nsndto 
    3080                IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
    3081                   CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 
    3082                ENDIF 
    3083             END DO 
    3084          ENDIF 
    3085          ! 
    3086          DO ji = 1, num_fields     ! Loop to manage 3D variables 
    3087             CALL mpp_lbc_nfd( ztabl(:,:,ji), ztabr(:,:,ji), cd_type(ji), psgn(ji) )  ! North fold boundary condition 
    3088          END DO 
    3089          ! 
    3090          DO jk = 1, num_fields 
    3091             DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
    3092                ij = jj - nlcj + ijpj 
    3093                DO ji = 1, nlci 
    3094                   pt2d_array(jk)%pt2d(ji,jj) = ztabl(ji,ij,jk)       ! Modified to 3D 
    3095                END DO 
    3096             END DO 
    3097          END DO 
    3098           
    3099          ! 
    3100       ELSE 
    3101          ! 
    3102          CALL MPI_ALLGATHER( znorthloc  , itaille*num_fields, MPI_DOUBLE_PRECISION,        & 
    3103             &                znorthgloio, itaille*num_fields, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
    3104          ! 
    3105          ztab(:,:,:) = 0.e0 
    3106          DO jk = 1, num_fields 
    3107             DO jr = 1, ndim_rank_north            ! recover the global north array 
    3108                iproc = nrank_north(jr) + 1 
    3109                ildi = nldit (iproc) 
    3110                ilei = nleit (iproc) 
    3111                iilb = nimppt(iproc) 
    3112                DO jj = 1, ijpj 
    3113                   DO ji = ildi, ilei 
    3114                      ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr) 
    3115                   END DO 
    3116                END DO 
    3117             END DO 
    3118          END DO 
    3119           
    3120          DO ji = 1, num_fields 
    3121             CALL lbc_nfd( ztab(:,:,ji), cd_type(ji), psgn(ji) )   ! North fold boundary condition 
    3122          END DO 
    3123          ! 
    3124          DO jk = 1, num_fields 
    3125             DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
    3126                ij = jj - nlcj + ijpj 
    3127                DO ji = 1, nlci 
    3128                   pt2d_array(jk)%pt2d(ji,jj) = ztab(ji+nimpp-1,ij,jk) 
    3129                END DO 
    3130             END DO 
    3131          END DO 
    3132          ! 
    3133          ! 
    3134       ENDIF 
    3135       DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio ) 
    3136       DEALLOCATE( ztabl, ztabr ) 
    3137       ! 
    3138    END SUBROUTINE mpp_lbc_north_2d_multiple 
    3139  
    31401460   SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn) 
    31411461      !!--------------------------------------------------------------------- 
     
    31551475      REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
    31561476      CHARACTER(len=1)                                            , INTENT(in   ) ::   cd_type  ! nature of pt3d grid-points 
    3157       !                                                                                         !   = T ,  U , V , F or W -points 
    3158       REAL(wp)                                                    , INTENT(in   ) ::   psgn     ! = -1. the sign change across the 
    3159       !!                                                                                        ! north fold, =  1. otherwise 
     1477      REAL(wp)                                                    , INTENT(in   ) ::   psgn     ! sign used across the north fold 
     1478      ! 
    31601479      INTEGER ::   ji, jj, jr 
    31611480      INTEGER ::   ierr, itaille, ildi, ilei, iilb 
    31621481      INTEGER ::   ijpj, ij, iproc 
    3163       ! 
    31641482      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE  ::  ztab_e, znorthloc_e 
    31651483      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE  ::  znorthgloio_e 
    3166  
    31671484      !!---------------------------------------------------------------------- 
    31681485      ! 
    31691486      ALLOCATE( ztab_e(jpiglo,4+2*jpr2dj), znorthloc_e(jpi,4+2*jpr2dj), znorthgloio_e(jpi,4+2*jpr2dj,jpni) ) 
    3170  
    31711487      ! 
    31721488      ijpj=4 
    3173       ztab_e(:,:) = 0.e0 
    3174  
    3175       ij=0 
     1489      ztab_e(:,:) = 0._wp 
     1490 
     1491      ij = 0 
    31761492      ! put in znorthloc_e the last 4 jlines of pt2d 
    31771493      DO jj = nlcj - ijpj + 1 - jpr2dj, nlcj +jpr2dj 
    31781494         ij = ij + 1 
    31791495         DO ji = 1, jpi 
    3180             znorthloc_e(ji,ij)=pt2d(ji,jj) 
     1496            znorthloc_e(ji,ij) = pt2d(ji,jj) 
    31811497         END DO 
    31821498      END DO 
    31831499      ! 
    31841500      itaille = jpi * ( ijpj + 2 * jpr2dj ) 
    3185       CALL MPI_ALLGATHER( znorthloc_e(1,1)  , itaille, MPI_DOUBLE_PRECISION,    & 
     1501      CALL MPI_ALLGATHER( znorthloc_e(1,1)    , itaille, MPI_DOUBLE_PRECISION,    & 
    31861502         &                znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
    31871503      ! 
    31881504      DO jr = 1, ndim_rank_north            ! recover the global north array 
    31891505         iproc = nrank_north(jr) + 1 
    3190          ildi = nldit (iproc) 
    3191          ilei = nleit (iproc) 
    3192          iilb = nimppt(iproc) 
     1506         ildi  = nldit (iproc) 
     1507         ilei  = nleit (iproc) 
     1508         iilb  = nimppt(iproc) 
    31931509         DO jj = 1, ijpj+2*jpr2dj 
    31941510            DO ji = ildi, ilei 
     
    31981514      END DO 
    31991515 
    3200  
    32011516      ! 2. North-Fold boundary conditions 
    32021517      ! ---------------------------------- 
    3203       CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = jpr2dj ) 
     1518!!gm ERROR      CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = jpr2dj ) 
    32041519 
    32051520      ij = jpr2dj 
     
    32151530      ! 
    32161531   END SUBROUTINE mpp_lbc_north_e 
    3217  
    3218  
    3219    SUBROUTINE mpp_lnk_bdy_3d( ptab, cd_type, psgn, ib_bdy ) 
    3220       !!---------------------------------------------------------------------- 
    3221       !!                  ***  routine mpp_lnk_bdy_3d  *** 
    3222       !! 
    3223       !! ** Purpose :   Message passing management 
    3224       !! 
    3225       !! ** Method  :   Use mppsend and mpprecv function for passing BDY boundaries  
    3226       !!      between processors following neighboring subdomains. 
    3227       !!            domain parameters 
    3228       !!                    nlci   : first dimension of the local subdomain 
    3229       !!                    nlcj   : second dimension of the local subdomain 
    3230       !!                    nbondi_bdy : mark for "east-west local boundary" 
    3231       !!                    nbondj_bdy : mark for "north-south local boundary" 
    3232       !!                    noea   : number for local neighboring processors  
    3233       !!                    nowe   : number for local neighboring processors 
    3234       !!                    noso   : number for local neighboring processors 
    3235       !!                    nono   : number for local neighboring processors 
    3236       !! 
    3237       !! ** Action  :   ptab with update value at its periphery 
    3238       !! 
    3239       !!---------------------------------------------------------------------- 
    3240       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied 
    3241       CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points 
    3242       !                                                             ! = T , U , V , F , W points 
    3243       REAL(wp)                        , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary 
    3244       !                                                             ! =  1. , the sign is kept 
    3245       INTEGER                         , INTENT(in   ) ::   ib_bdy   ! BDY boundary set 
    3246       ! 
    3247       INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices 
    3248       INTEGER  ::   imigr, iihom, ijhom        ! local integers 
    3249       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    3250       REAL(wp) ::   zland                      ! local scalar 
    3251       INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
    3252       ! 
    3253       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ns, zt3sn   ! 3d for north-south & south-north 
    3254       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ew, zt3we   ! 3d for east-west & west-east 
    3255       !!---------------------------------------------------------------------- 
    3256       ! 
    3257       ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2),   & 
    3258          &      zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2)  ) 
    3259  
    3260       zland = 0._wp 
    3261  
    3262       ! 1. standard boundary treatment 
    3263       ! ------------------------------ 
    3264       !                                   ! East-West boundaries 
    3265       !                                        !* Cyclic east-west 
    3266       IF( nbondi == 2) THEN 
    3267          IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN 
    3268             ptab( 1 ,:,:) = ptab(jpim1,:,:) 
    3269             ptab(jpi,:,:) = ptab(  2  ,:,:) 
    3270          ELSE 
    3271             IF( .NOT. cd_type == 'F' )   ptab(1:jpreci,:,:) = zland    ! south except F-point 
    3272             ptab(nlci-jpreci+1:jpi,:,:) = zland    ! north 
    3273          ENDIF 
    3274       ELSEIF(nbondi == -1) THEN 
    3275          IF( .NOT. cd_type == 'F' )   ptab(1:jpreci,:,:) = zland    ! south except F-point 
    3276       ELSEIF(nbondi == 1) THEN 
    3277          ptab(nlci-jpreci+1:jpi,:,:) = zland    ! north 
    3278       ENDIF                                     !* closed 
    3279  
    3280       IF (nbondj == 2 .OR. nbondj == -1) THEN 
    3281         IF( .NOT. cd_type == 'F' )   ptab(:,1:jprecj,:) = zland       ! south except F-point 
    3282       ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN 
    3283         ptab(:,nlcj-jprecj+1:jpj,:) = zland       ! north 
    3284       ENDIF 
    3285       ! 
    3286       ! 2. East and west directions exchange 
    3287       ! ------------------------------------ 
    3288       ! we play with the neigbours AND the row number because of the periodicity  
    3289       ! 
    3290       SELECT CASE ( nbondi_bdy(ib_bdy) )      ! Read Dirichlet lateral conditions 
    3291       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    3292          iihom = nlci-nreci 
    3293          DO jl = 1, jpreci 
    3294             zt3ew(:,jl,:,1) = ptab(jpreci+jl,:,:) 
    3295             zt3we(:,jl,:,1) = ptab(iihom +jl,:,:) 
    3296          END DO 
    3297       END SELECT 
    3298       ! 
    3299       !                           ! Migrations 
    3300       imigr = jpreci * jpj * jpk 
    3301       ! 
    3302       SELECT CASE ( nbondi_bdy(ib_bdy) ) 
    3303       CASE ( -1 ) 
    3304          CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 ) 
    3305       CASE ( 0 ) 
    3306          CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
    3307          CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 ) 
    3308       CASE ( 1 ) 
    3309          CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
    3310       END SELECT 
    3311       ! 
    3312       SELECT CASE ( nbondi_bdy_b(ib_bdy) ) 
    3313       CASE ( -1 ) 
    3314          CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 
    3315       CASE ( 0 ) 
    3316          CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 
    3317          CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 
    3318       CASE ( 1 ) 
    3319          CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 
    3320       END SELECT 
    3321       ! 
    3322       SELECT CASE ( nbondi_bdy(ib_bdy) ) 
    3323       CASE ( -1 ) 
    3324          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    3325       CASE ( 0 ) 
    3326          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    3327          IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    3328       CASE ( 1 ) 
    3329          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    3330       END SELECT 
    3331       ! 
    3332       !                           ! Write Dirichlet lateral conditions 
    3333       iihom = nlci-jpreci 
    3334       ! 
    3335       SELECT CASE ( nbondi_bdy_b(ib_bdy) ) 
    3336       CASE ( -1 ) 
    3337          DO jl = 1, jpreci 
    3338             ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2) 
    3339          END DO 
    3340       CASE ( 0 ) 
    3341          DO jl = 1, jpreci 
    3342             ptab(      jl,:,:) = zt3we(:,jl,:,2) 
    3343             ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2) 
    3344          END DO 
    3345       CASE ( 1 ) 
    3346          DO jl = 1, jpreci 
    3347             ptab(      jl,:,:) = zt3we(:,jl,:,2) 
    3348          END DO 
    3349       END SELECT 
    3350  
    3351  
    3352       ! 3. North and south directions 
    3353       ! ----------------------------- 
    3354       ! always closed : we play only with the neigbours 
    3355       ! 
    3356       IF( nbondj_bdy(ib_bdy) /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    3357          ijhom = nlcj-nrecj 
    3358          DO jl = 1, jprecj 
    3359             zt3sn(:,jl,:,1) = ptab(:,ijhom +jl,:) 
    3360             zt3ns(:,jl,:,1) = ptab(:,jprecj+jl,:) 
    3361          END DO 
    3362       ENDIF 
    3363       ! 
    3364       !                           ! Migrations 
    3365       imigr = jprecj * jpi * jpk 
    3366       ! 
    3367       SELECT CASE ( nbondj_bdy(ib_bdy) ) 
    3368       CASE ( -1 ) 
    3369          CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 ) 
    3370       CASE ( 0 ) 
    3371          CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 
    3372          CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 ) 
    3373       CASE ( 1 ) 
    3374          CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 
    3375       END SELECT 
    3376       ! 
    3377       SELECT CASE ( nbondj_bdy_b(ib_bdy) ) 
    3378       CASE ( -1 ) 
    3379          CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 
    3380       CASE ( 0 ) 
    3381          CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 
    3382          CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 
    3383       CASE ( 1 ) 
    3384          CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 
    3385       END SELECT 
    3386       ! 
    3387       SELECT CASE ( nbondj_bdy(ib_bdy) ) 
    3388       CASE ( -1 ) 
    3389          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    3390       CASE ( 0 ) 
    3391          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    3392          IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    3393       CASE ( 1 ) 
    3394          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    3395       END SELECT 
    3396       ! 
    3397       !                           ! Write Dirichlet lateral conditions 
    3398       ijhom = nlcj-jprecj 
    3399       ! 
    3400       SELECT CASE ( nbondj_bdy_b(ib_bdy) ) 
    3401       CASE ( -1 ) 
    3402          DO jl = 1, jprecj 
    3403             ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2) 
    3404          END DO 
    3405       CASE ( 0 ) 
    3406          DO jl = 1, jprecj 
    3407             ptab(:,jl      ,:) = zt3sn(:,jl,:,2) 
    3408             ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2) 
    3409          END DO 
    3410       CASE ( 1 ) 
    3411          DO jl = 1, jprecj 
    3412             ptab(:,jl,:) = zt3sn(:,jl,:,2) 
    3413          END DO 
    3414       END SELECT 
    3415  
    3416  
    3417       ! 4. north fold treatment 
    3418       ! ----------------------- 
    3419       ! 
    3420       IF( npolj /= 0) THEN 
    3421          ! 
    3422          SELECT CASE ( jpni ) 
    3423          CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp 
    3424          CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs. 
    3425          END SELECT 
    3426          ! 
    3427       ENDIF 
    3428       ! 
    3429       DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we  ) 
    3430       ! 
    3431    END SUBROUTINE mpp_lnk_bdy_3d 
    3432  
    3433  
    3434    SUBROUTINE mpp_lnk_bdy_2d( ptab, cd_type, psgn, ib_bdy ) 
    3435       !!---------------------------------------------------------------------- 
    3436       !!                  ***  routine mpp_lnk_bdy_2d  *** 
    3437       !! 
    3438       !! ** Purpose :   Message passing management 
    3439       !! 
    3440       !! ** Method  :   Use mppsend and mpprecv function for passing BDY boundaries  
    3441       !!      between processors following neighboring subdomains. 
    3442       !!            domain parameters 
    3443       !!                    nlci   : first dimension of the local subdomain 
    3444       !!                    nlcj   : second dimension of the local subdomain 
    3445       !!                    nbondi_bdy : mark for "east-west local boundary" 
    3446       !!                    nbondj_bdy : mark for "north-south local boundary" 
    3447       !!                    noea   : number for local neighboring processors  
    3448       !!                    nowe   : number for local neighboring processors 
    3449       !!                    noso   : number for local neighboring processors 
    3450       !!                    nono   : number for local neighboring processors 
    3451       !! 
    3452       !! ** Action  :   ptab with update value at its periphery 
    3453       !! 
    3454       !!---------------------------------------------------------------------- 
    3455       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied 
    3456       CHARACTER(len=1)            , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points 
    3457       !                                                         ! = T , U , V , F , W points 
    3458       REAL(wp)                    , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary 
    3459       !                                                         ! =  1. , the sign is kept 
    3460       INTEGER                     , INTENT(in   ) ::   ib_bdy   ! BDY boundary set 
    3461       ! 
    3462       INTEGER  ::   ji, jj, jl             ! dummy loop indices 
    3463       INTEGER  ::   imigr, iihom, ijhom        ! local integers 
    3464       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    3465       REAL(wp) ::   zland 
    3466       INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
    3467       ! 
    3468       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ns, zt2sn   ! 2d for north-south & south-north 
    3469       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ew, zt2we   ! 2d for east-west & west-east 
    3470       !!---------------------------------------------------------------------- 
    3471  
    3472       ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2),  & 
    3473          &      zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2)   ) 
    3474  
    3475       zland = 0._wp 
    3476  
    3477       ! 1. standard boundary treatment 
    3478       ! ------------------------------ 
    3479       !                                   ! East-West boundaries 
    3480       !                                      !* Cyclic east-west 
    3481       IF( nbondi == 2 ) THEN 
    3482          IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN 
    3483             ptab( 1 ,:) = ptab(jpim1,:) 
    3484             ptab(jpi,:) = ptab(  2  ,:) 
    3485          ELSE 
    3486             IF(.NOT.cd_type == 'F' )  ptab(     1       :jpreci,:) = zland    ! south except F-point 
    3487                                       ptab(nlci-jpreci+1:jpi   ,:) = zland    ! north 
    3488          ENDIF 
    3489       ELSEIF(nbondi == -1) THEN 
    3490          IF( .NOT.cd_type == 'F' )    ptab(     1       :jpreci,:) = zland    ! south except F-point 
    3491       ELSEIF(nbondi == 1) THEN 
    3492                                       ptab(nlci-jpreci+1:jpi   ,:) = zland    ! north 
    3493       ENDIF 
    3494       !                                      !* closed 
    3495       IF( nbondj == 2 .OR. nbondj == -1 ) THEN 
    3496          IF( .NOT.cd_type == 'F' )    ptab(:,     1       :jprecj) = zland    ! south except F-point 
    3497       ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN 
    3498                                       ptab(:,nlcj-jprecj+1:jpj   ) = zland    ! north 
    3499       ENDIF 
    3500       ! 
    3501       ! 2. East and west directions exchange 
    3502       ! ------------------------------------ 
    3503       ! we play with the neigbours AND the row number because of the periodicity  
    3504       ! 
    3505       SELECT CASE ( nbondi_bdy(ib_bdy) )      ! Read Dirichlet lateral conditions 
    3506       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    3507          iihom = nlci-nreci 
    3508          DO jl = 1, jpreci 
    3509             zt2ew(:,jl,1) = ptab(jpreci+jl,:) 
    3510             zt2we(:,jl,1) = ptab(iihom +jl,:) 
    3511          END DO 
    3512       END SELECT 
    3513       ! 
    3514       !                           ! Migrations 
    3515       imigr = jpreci * jpj 
    3516       ! 
    3517       SELECT CASE ( nbondi_bdy(ib_bdy) ) 
    3518       CASE ( -1 ) 
    3519          CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 ) 
    3520       CASE ( 0 ) 
    3521          CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 
    3522          CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 ) 
    3523       CASE ( 1 ) 
    3524          CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 
    3525       END SELECT 
    3526       ! 
    3527       SELECT CASE ( nbondi_bdy_b(ib_bdy) ) 
    3528       CASE ( -1 ) 
    3529          CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 
    3530       CASE ( 0 ) 
    3531          CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 
    3532          CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 
    3533       CASE ( 1 ) 
    3534          CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 
    3535       END SELECT 
    3536       ! 
    3537       SELECT CASE ( nbondi_bdy(ib_bdy) ) 
    3538       CASE ( -1 ) 
    3539          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    3540       CASE ( 0 ) 
    3541          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    3542          IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    3543       CASE ( 1 ) 
    3544          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    3545       END SELECT 
    3546       ! 
    3547       !                           ! Write Dirichlet lateral conditions 
    3548       iihom = nlci-jpreci 
    3549       ! 
    3550       SELECT CASE ( nbondi_bdy_b(ib_bdy) ) 
    3551       CASE ( -1 ) 
    3552          DO jl = 1, jpreci 
    3553             ptab(iihom+jl,:) = zt2ew(:,jl,2) 
    3554          END DO 
    3555       CASE ( 0 ) 
    3556          DO jl = 1, jpreci 
    3557             ptab(jl      ,:) = zt2we(:,jl,2) 
    3558             ptab(iihom+jl,:) = zt2ew(:,jl,2) 
    3559          END DO 
    3560       CASE ( 1 ) 
    3561          DO jl = 1, jpreci 
    3562             ptab(jl      ,:) = zt2we(:,jl,2) 
    3563          END DO 
    3564       END SELECT 
    3565  
    3566  
    3567       ! 3. North and south directions 
    3568       ! ----------------------------- 
    3569       ! always closed : we play only with the neigbours 
    3570       ! 
    3571       IF( nbondj_bdy(ib_bdy) /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    3572          ijhom = nlcj-nrecj 
    3573          DO jl = 1, jprecj 
    3574             zt2sn(:,jl,1) = ptab(:,ijhom +jl) 
    3575             zt2ns(:,jl,1) = ptab(:,jprecj+jl) 
    3576          END DO 
    3577       ENDIF 
    3578       ! 
    3579       !                           ! Migrations 
    3580       imigr = jprecj * jpi 
    3581       ! 
    3582       SELECT CASE ( nbondj_bdy(ib_bdy) ) 
    3583       CASE ( -1 ) 
    3584          CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 ) 
    3585       CASE ( 0 ) 
    3586          CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 
    3587          CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 ) 
    3588       CASE ( 1 ) 
    3589          CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 
    3590       END SELECT 
    3591       ! 
    3592       SELECT CASE ( nbondj_bdy_b(ib_bdy) ) 
    3593       CASE ( -1 ) 
    3594          CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 
    3595       CASE ( 0 ) 
    3596          CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 
    3597          CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 
    3598       CASE ( 1 ) 
    3599          CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 
    3600       END SELECT 
    3601       ! 
    3602       SELECT CASE ( nbondj_bdy(ib_bdy) ) 
    3603       CASE ( -1 ) 
    3604          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    3605       CASE ( 0 ) 
    3606          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    3607          IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    3608       CASE ( 1 ) 
    3609          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    3610       END SELECT 
    3611       ! 
    3612       !                           ! Write Dirichlet lateral conditions 
    3613       ijhom = nlcj-jprecj 
    3614       ! 
    3615       SELECT CASE ( nbondj_bdy_b(ib_bdy) ) 
    3616       CASE ( -1 ) 
    3617          DO jl = 1, jprecj 
    3618             ptab(:,ijhom+jl) = zt2ns(:,jl,2) 
    3619          END DO 
    3620       CASE ( 0 ) 
    3621          DO jl = 1, jprecj 
    3622             ptab(:,jl      ) = zt2sn(:,jl,2) 
    3623             ptab(:,ijhom+jl) = zt2ns(:,jl,2) 
    3624          END DO 
    3625       CASE ( 1 ) 
    3626          DO jl = 1, jprecj 
    3627             ptab(:,jl) = zt2sn(:,jl,2) 
    3628          END DO 
    3629       END SELECT 
    3630  
    3631  
    3632       ! 4. north fold treatment 
    3633       ! ----------------------- 
    3634       ! 
    3635       IF( npolj /= 0) THEN 
    3636          ! 
    3637          SELECT CASE ( jpni ) 
    3638          CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp 
    3639          CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs. 
    3640          END SELECT 
    3641          ! 
    3642       ENDIF 
    3643       ! 
    3644       DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we  ) 
    3645       ! 
    3646    END SUBROUTINE mpp_lnk_bdy_2d 
    36471532 
    36481533 
     
    37061591   END SUBROUTINE mpi_init_opa 
    37071592 
    3708    SUBROUTINE DDPDD_MPI (ydda, yddb, ilen, itype) 
     1593 
     1594   SUBROUTINE DDPDD_MPI( ydda, yddb, ilen, itype ) 
    37091595      !!--------------------------------------------------------------------- 
    37101596      !!   Routine DDPDD_MPI: used by reduction operator MPI_SUMDD 
     
    37131599      !!   This subroutine computes yddb(i) = ydda(i)+yddb(i) 
    37141600      !!--------------------------------------------------------------------- 
    3715       INTEGER, INTENT(in)                         :: ilen, itype 
    3716       COMPLEX(wp), DIMENSION(ilen), INTENT(in)     :: ydda 
    3717       COMPLEX(wp), DIMENSION(ilen), INTENT(inout)  :: yddb 
     1601      INTEGER                     , INTENT(in)    ::  ilen, itype 
     1602      COMPLEX(wp), DIMENSION(ilen), INTENT(in)    ::  ydda 
     1603      COMPLEX(wp), DIMENSION(ilen), INTENT(inout) ::  yddb 
    37181604      ! 
    37191605      REAL(wp) :: zerr, zt1, zt2    ! local work variables 
    3720       INTEGER :: ji, ztmp           ! local scalar 
    3721  
     1606      INTEGER  :: ji, ztmp           ! local scalar 
     1607      !!--------------------------------------------------------------------- 
     1608      ! 
    37221609      ztmp = itype   ! avoid compilation warning 
    3723  
     1610      ! 
    37241611      DO ji=1,ilen 
    37251612      ! Compute ydda + yddb using Knuth's trick. 
     
    37321619         yddb(ji) = cmplx ( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1),wp ) 
    37331620      END DO 
    3734  
     1621      ! 
    37351622   END SUBROUTINE DDPDD_MPI 
    37361623 
     
    38021689      END DO 
    38031690 
    3804  
    38051691      ! 2. North-Fold boundary conditions 
    38061692      ! ---------------------------------- 
    3807       CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = ipr2dj ) 
     1693!!gm ERROR      CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = ipr2dj ) 
    38081694 
    38091695      ij = ipr2dj 
     
    38411727      !!                    nono   : number for local neighboring processors 
    38421728      !!---------------------------------------------------------------------- 
     1729      REAL(wp), DIMENSION(1-jpri:jpi+jpri,1-jprj:jpj+jprj), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
     1730      CHARACTER(len=1)                                    , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points 
     1731      REAL(wp)                                            , INTENT(in   ) ::   psgn     ! sign used across the north fold 
    38431732      INTEGER                                             , INTENT(in   ) ::   jpri 
    38441733      INTEGER                                             , INTENT(in   ) ::   jprj 
    3845       REAL(wp), DIMENSION(1-jpri:jpi+jpri,1-jprj:jpj+jprj), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
    3846       CHARACTER(len=1)                                    , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points 
    3847       !                                                                                 ! = T , U , V , F , W and I points 
    3848       REAL(wp)                                            , INTENT(in   ) ::   psgn     ! =-1 the sign change across the 
    3849       !!                                                                                ! north boundary, =  1. otherwise 
     1734      ! 
    38501735      INTEGER  ::   jl   ! dummy loop indices 
    3851       INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
    3852       INTEGER  ::   ipreci, iprecj             ! temporary integers 
     1736      INTEGER  ::   imigr, iihom, ijhom        ! local integers 
     1737      INTEGER  ::   ipreci, iprecj             !   -       - 
    38531738      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    38541739      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
    38551740      !! 
    3856       REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dns 
    3857       REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dsn 
    3858       REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dwe 
    3859       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 
    38601743      !!---------------------------------------------------------------------- 
    38611744 
     
    38751758         ! 
    38761759      ELSE                                        !* closed 
    3877          IF( .NOT. cd_type == 'F' )   pt2d(  1-jpri   :jpreci    ,:) = 0.e0    ! south except at F-point 
    3878                                       pt2d(nlci-jpreci+1:jpi+jpri,:) = 0.e0    ! north 
     1760         IF( .NOT. cd_type == 'F' )   pt2d(  1-jpri   :jpreci    ,:) = 0._wp    ! south except at F-point 
     1761                                      pt2d(nlci-jpreci+1:jpi+jpri,:) = 0._wp    ! north 
    38791762      ENDIF 
    38801763      ! 
     
    38851768         ! 
    38861769         SELECT CASE ( jpni ) 
    3887          CASE ( 1 )     ;   CALL lbc_nfd        ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj ) 
    3888          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  ) 
    38891772         END SELECT 
    38901773         ! 
     
    39961879         END DO 
    39971880      END SELECT 
    3998  
     1881      ! 
    39991882   END SUBROUTINE mpp_lnk_2d_icb 
    40001883    
     
    40201903      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 
    40211904   END INTERFACE 
     1905   INTERFACE mpp_max_multiple 
     1906      MODULE PROCEDURE mppmax_real_multiple 
     1907   END INTERFACE 
    40221908 
    40231909   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .FALSE.      !: mpp flag 
     
    41912077      WRITE(*,*) 'mpp_comm_free: You should not have seen this print! error?', kcom 
    41922078   END SUBROUTINE mpp_comm_free 
     2079    
     2080   SUBROUTINE mppmax_real_multiple( ptab, kdim , kcom  ) 
     2081      REAL, DIMENSION(:) ::   ptab   !  
     2082      INTEGER            ::   kdim   !  
     2083      INTEGER, OPTIONAL  ::   kcom   !  
     2084      WRITE(*,*) 'mppmax_real_multiple: You should not have seen this print! error?', ptab(1), kdim 
     2085   END SUBROUTINE mppmax_real_multiple 
     2086 
    41932087#endif 
    41942088 
     
    42252119                               CALL FLUSH(numout    ) 
    42262120      IF( numstp     /= -1 )   CALL FLUSH(numstp    ) 
    4227       IF( numsol     /= -1 )   CALL FLUSH(numsol    ) 
     2121      IF( numrun     /= -1 )   CALL FLUSH(numrun    ) 
    42282122      IF( numevo_ice /= -1 )   CALL FLUSH(numevo_ice) 
    42292123      ! 
     
    43322226            WRITE(kout,*) 
    43332227         ENDIF 
    4334          CALL FLUSH(kout)  
     2228         CALL FLUSH( kout )  
    43352229         STOP 'ctl_opn bad opening' 
    43362230      ENDIF 
  • branches/2017/dev_r8183_ICEMODEL/NEMOGCM/NEMO/OPA_SRC/SBC/fldread.F90

    r7646 r8226  
    116116   END TYPE WGT 
    117117 
    118    INTEGER,     PARAMETER             ::   tot_wgts = 10 
     118   INTEGER,     PARAMETER             ::   tot_wgts = 20 
    119119   TYPE( WGT ), DIMENSION(tot_wgts)   ::   ref_wgts     ! array of wgts 
    120120   INTEGER                            ::   nxt_wgt = 1  ! point to next available space in ref_wgts array 
  • branches/2017/dev_r8183_ICEMODEL/NEMOGCM/NEMO/OPA_SRC/SBC/sbcmod.F90

    r7822 r8226  
    328328      IF( ln_ssr      )   CALL sbc_ssr_init            ! Sea-Surface Restoring initialization 
    329329      ! 
    330       IF( ln_isf      )   CALL sbc_isf_init               ! Compute iceshelves 
     330      IF( ln_isf      )   CALL sbc_isf_init            ! Compute iceshelves 
    331331      ! 
    332332                          CALL sbc_rnf_init            ! Runof initialization 
    333333      ! 
    334       IF( nn_ice == 3 )   CALL sbc_lim_init            ! LIM3 initialization 
    335       ! 
    336       IF( nn_ice == 4 )   CALL cice_sbc_init( nsbc )   ! CICE initialization 
     334      IF    ( lk_agrif .AND. nn_ice == 0 ) THEN 
     335                         IF( sbc_ice_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'sbc_ice_alloc : unable to allocate arrays' )  ! clem2017: allocate ice arrays in case agrif + lim + no-ice in child grid               
     336      ELSEIF(                nn_ice == 3 ) THEN   ;   CALL sbc_lim_init            ! LIM3 initialization 
     337      ELSEIF(                nn_ice == 4 ) THEN   ;   CALL cice_sbc_init( nsbc )   ! CICE initialization 
     338      ENDIF 
    337339      ! 
    338340      IF( ln_wave     )   CALL sbc_wave_init              ! surface wave initialisation 
  • branches/2017/dev_r8183_ICEMODEL/NEMOGCM/NEMO/OPA_SRC/SBC/sbcwave.F90

    r7864 r8226  
    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  ==! 
     
    152156      END DO 
    153157      ! 
    154       IF( .NOT. AGRIF_Root() ) THEN 
    155          IF( nbondi ==  1 .OR. nbondi == 2 )   ze3divh(nlci-1,   :  ,:) = 0._wp      ! east 
    156          IF( nbondi == -1 .OR. nbondi == 2 )   ze3divh(  2   ,   :  ,:) = 0._wp      ! west 
    157          IF( nbondj ==  1 .OR. nbondj == 2 )   ze3divh(  :   ,nlcj-1,:) = 0._wp      ! north 
    158          IF( nbondj == -1 .OR. nbondj == 2 )   ze3divh(  :   ,  2   ,:) = 0._wp      ! south 
     158      IF( .NOT. Agrif_Root() ) THEN 
     159         IF( nbondi == -1 .OR. nbondi == 2 )   ze3divh( 2:nbghostcells+1,:        ,:) = 0._wp      ! west 
     160         IF( nbondi ==  1 .OR. nbondi == 2 )   ze3divh( nlci-nbghostcells:nlci-1,:,:) = 0._wp      ! east 
     161         IF( nbondj == -1 .OR. nbondj == 2 )   ze3divh( :,2:nbghostcells+1        ,:) = 0._wp      ! south 
     162         IF( nbondj ==  1 .OR. nbondj == 2 )   ze3divh( :,nlcj-nbghostcells:nlcj-1,:) = 0._wp      ! north 
    159163      ENDIF 
    160164      ! 
  • branches/2017/dev_r8183_ICEMODEL/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90

    r7761 r8226  
    206206      ! 
    207207#if defined key_agrif 
    208       IF( .NOT. Agrif_Root() ) THEN 
     208!!clem2017      IF( .NOT. Agrif_Root() ) THEN 
    209209                         CALL Agrif_ParentGrid_To_ChildGrid() 
    210210         IF( ln_diaobs ) CALL dia_obs_wri 
    211211         IF( nn_timing == 1 )   CALL timing_finalize 
    212212                                CALL Agrif_ChildGrid_To_ParentGrid() 
    213       ENDIF 
     213!!clem2017      ENDIF 
    214214#endif 
    215215      IF( nn_timing == 1 )   CALL timing_finalize 
     
    622622      ! 
    623623      IF( numstp          /= -1 )   CLOSE( numstp          )   ! time-step file 
    624       IF( numsol          /= -1 )   CLOSE( numsol          )   ! solver file 
     624      IF( numrun          /= -1 )   CLOSE( numrun          )   ! run statistics file 
    625625      IF( numnam_ref      /= -1 )   CLOSE( numnam_ref      )   ! oce reference namelist 
    626626      IF( numnam_cfg      /= -1 )   CLOSE( numnam_cfg      )   ! oce configuration namelist 
  • branches/2017/dev_r8183_ICEMODEL/NEMOGCM/NEMO/OPA_SRC/stpctl.F90

    r7852 r8226  
    99   !!   NEMO     1.0  ! 2002-06  (G. Madec)  F90: Free form and module 
    1010   !!            2.0  ! 2009-07  (G. Madec)  Add statistic for time-spliting 
     11   !!            3.7  ! 2016-09  (G. Madec)  Remove solver 
     12   !!            4.0  ! 2017-04  (G. Madec)  regroup global communications 
    1113   !!---------------------------------------------------------------------- 
    1214 
     
    2123   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    2224   USE lib_mpp         ! distributed memory computing 
    23    USE lib_fortran     ! Fortran routines library  
    2425 
    2526   IMPLICIT NONE 
     
    2829   PUBLIC stp_ctl           ! routine called by step.F90 
    2930   !!---------------------------------------------------------------------- 
    30    !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
     31   !! NEMO/OPA 4.0 , NEMO Consortium (2017) 
    3132   !! $Id$ 
    3233   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
     
    4243      !! ** Method  : - Save the time step in numstp 
    4344      !!              - Print it each 50 time steps 
    44       !!              - Stop the run IF problem ( indic < 0 ) 
     45      !!              - Stop the run IF problem encountered by setting indic=-3 
     46      !!                Problems checked: |ssh| maximum larger than 10 m 
     47      !!                                  |U|   maximum larger than 10 m/s  
     48      !!                                  negative sea surface salinity 
    4549      !! 
    46       !! ** Actions :   'time.step' file containing the last ocean time-step 
    47       !!                 
     50      !! ** Actions :   "time.step" file = last ocean time-step 
     51      !!                "run.stat"  file = run statistics 
    4852      !!---------------------------------------------------------------------- 
    4953      INTEGER, INTENT(in   ) ::   kt       ! ocean time-step index 
     
    5155      !! 
    5256      INTEGER  ::   ji, jj, jk             ! dummy loop indices 
    53       INTEGER  ::   ii, ij, ik             ! local integers 
    54       REAL(wp) ::   zumax, zsmin, zssh2, zsshmax    ! local scalars 
    55       INTEGER, DIMENSION(3) ::   ilocu     !  
    56       INTEGER, DIMENSION(2) ::   ilocs     !  
     57      INTEGER  ::   iih, ijh               ! local integers 
     58      INTEGER  ::   iiu, iju, iku          !   -       - 
     59      INTEGER  ::   iis, ijs               !   -       - 
     60      REAL(wp) ::   zzz                    ! local real  
     61      INTEGER , DIMENSION(3) ::   ilocu 
     62      INTEGER , DIMENSION(2) ::   ilocs, iloch 
     63      REAL(wp), DIMENSION(3) ::   zmax 
    5764      !!---------------------------------------------------------------------- 
    5865      ! 
     
    6168         WRITE(numout,*) 'stp_ctl : time-stepping control' 
    6269         WRITE(numout,*) '~~~~~~~' 
    63          ! open time.step file 
     70         !                                ! open time.step file 
    6471         CALL ctl_opn( numstp, 'time.step', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 
     72         !                                ! open run.stat file 
     73         CALL ctl_opn( numrun, 'run.stat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 
    6574      ENDIF 
    6675      ! 
    67       IF(lwp) WRITE ( numstp, '(1x, i8)' )   kt      !* save the current time step in numstp 
    68       IF(lwp) REWIND( numstp )                       !  -------------------------- 
     76      IF(lwp) THEN                        !==  current time step  ==!   ("time.step" file) 
     77         WRITE ( numstp, '(1x, i8)' )   kt 
     78         REWIND( numstp ) 
     79      ENDIF 
    6980      ! 
    70       !                                              !* Test maximum of velocity (zonal only) 
    71       !                                              !  ------------------------ 
    72       !! zumax = MAXVAL( ABS( un(:,:,:) ) )                ! slower than the following loop on NEC SX5 
    73       zumax = 0.e0 
    74       DO jk = 1, jpk 
    75          DO jj = 1, jpj 
    76             DO ji = 1, jpi 
    77                zumax = MAX(zumax,ABS(un(ji,jj,jk))) 
    78           END DO  
    79         END DO  
    80       END DO         
    81       IF( lk_mpp )   CALL mpp_max( zumax )                 ! max over the global domain 
     81      !                                   !==  test of extrema  ==! 
     82      zmax(1) = MAXVAL(  ABS( sshn(:,:) )  )                                  ! ssh max 
     83      zmax(2) = MAXVAL(  ABS( un(:,:,:) )  )                                  ! velocity max (zonal only) 
     84      zmax(3) = MAXVAL( -tsn(:,:,1,jp_sal) , mask = tmask(:,:,1) == 1._wp )   ! minus surface salinity max 
    8285      ! 
    83       IF( MOD( kt, nwrite ) == 1 .AND. lwp )   WRITE(numout,*) ' ==>> time-step= ',kt,' abs(U) max: ', zumax 
     86      IF( lk_mpp )   CALL mpp_max_multiple( zmax(:), 3 ) ! max over the global domain 
    8487      ! 
    85       IF( zumax > 20.e0 ) THEN 
     88      IF( MOD( kt, nwrite ) == 1 .AND. lwp ) THEN 
     89         WRITE(numout,*) ' ==>> time-step= ', kt, ' |ssh| max: ',   zmax(1), ' |U| max: ', zmax(2),   & 
     90            &                                     ' SSS min: '  , - zmax(3) 
     91      ENDIF 
     92      ! 
     93      IF ( zmax(1) > 10._wp .OR.   &                     ! too large sea surface height ( > 10 m) 
     94         & zmax(2) > 10._wp .OR.   &                     ! too large velocity ( > 10 m/s) 
     95         & zmax(3) >  0._wp ) THEN                       ! negative sea surface salinity 
    8696         IF( lk_mpp ) THEN 
    87             CALL mpp_maxloc(ABS(un),umask,zumax,ii,ij,ik) 
     97            CALL mpp_maxloc( ABS(sshn)        , tmask(:,:,1), zzz, iih, ijh ) 
     98            CALL mpp_maxloc( ABS(un)          , umask       , zzz, iiu, iju, iku ) 
     99            CALL mpp_minloc( tsn(:,:,1,jp_sal), tmask(:,:,1), zzz, iis, ijs ) 
    88100         ELSE 
     101            iloch = MINLOC( ABS( sshn(:,:) ) ) 
    89102            ilocu = MAXLOC( ABS( un(:,:,:) ) ) 
    90             ii = ilocu(1) + nimpp - 1 
    91             ij = ilocu(2) + njmpp - 1 
    92             ik = ilocu(3) 
     103            ilocs = MINLOC( tsn(:,:,1,jp_sal), mask = tmask(:,:,1) == 1._wp ) 
     104            iih = iloch(1) + nimpp - 1   ;   ijh = iloch(2) + njmpp - 1 
     105            iiu = ilocu(1) + nimpp - 1   ;   iju = ilocu(2) + njmpp - 1   ;   iku = ilocu(3) 
     106            iis = ilocs(1) + nimpp - 1   ;   ijs = ilocs(2) + njmpp - 1 
    93107         ENDIF 
    94108         IF(lwp) THEN 
    95109            WRITE(numout,cform_err) 
    96             WRITE(numout,*) ' stpctl: the zonal velocity is larger than 20 m/s' 
     110            WRITE(numout,*) ' stpctl: |ssh| > 10 m   or   |U| > 10 m/s   or   SSS < 0' 
    97111            WRITE(numout,*) ' ====== ' 
    98             WRITE(numout,9400) kt, zumax, ii, ij, ik 
     112            WRITE(numout,9100) kt,   zmax(1), iih, ijh 
     113            WRITE(numout,9200) kt,   zmax(2), iiu, iju, iku 
     114            WRITE(numout,9300) kt, - zmax(3), iis, ijs 
    99115            WRITE(numout,*) 
    100             WRITE(numout,*) '          output of last fields in numwso' 
     116            WRITE(numout,*) '          output of last computed fields in output.abort.nc file' 
    101117         ENDIF 
    102118         kindic = -3 
    103119      ENDIF 
    104 9400  FORMAT (' kt=',i6,' max abs(U): ',1pg11.4,', i j k: ',3i5) 
     1209100  FORMAT (' kt=',i8,'   |ssh| max: ',1pg11.4,', at  i j  : ',2i5) 
     1219200  FORMAT (' kt=',i8,'   |U|   max: ',1pg11.4,', at  i j k: ',3i5) 
     1229300  FORMAT (' kt=',i8,'   SSS   min: ',1pg11.4,', at  i j  : ',2i5) 
    105123      ! 
    106       !                                              !* Test minimum of salinity 
    107       !                                              !  ------------------------ 
    108       !! zsmin = MINVAL( tsn(:,:,1,jp_sal), mask = tmask(:,:,1) == 1.e0 )  slower than the following loop on NEC SX5 
    109       zsmin = 100._wp 
    110       DO jj = 2, jpjm1 
    111          DO ji = 1, jpi 
    112             IF( tmask(ji,jj,1) == 1) zsmin = MIN(zsmin,tsn(ji,jj,1,jp_sal)) 
    113          END DO 
    114       END DO 
    115       IF( lk_mpp )   CALL mpp_min( zsmin )                ! min over the global domain 
     124      !                                            !==  run statistics  ==!   ("run.stat" file) 
     125      IF(lwp) WRITE(numrun,9400) kt, zmax(1), zmax(2), - zmax(3) 
    116126      ! 
    117       IF( MOD( kt, nwrite ) == 1 .AND. lwp )   WRITE(numout,*) ' ==>> time-step= ',kt,' SSS min:', zsmin 
    118       ! 
    119       IF( zsmin < 0.) THEN  
    120          IF (lk_mpp) THEN 
    121             CALL mpp_minloc ( tsn(:,:,1,jp_sal),tmask(:,:,1), zsmin, ii,ij ) 
    122          ELSE 
    123             ilocs = MINLOC( tsn(:,:,1,jp_sal), mask = tmask(:,:,1) == 1.e0 ) 
    124             ii = ilocs(1) + nimpp - 1 
    125             ij = ilocs(2) + njmpp - 1 
    126          ENDIF 
    127          ! 
    128          IF(lwp) THEN 
    129             WRITE(numout,cform_err) 
    130             WRITE(numout,*) 'stp_ctl : NEGATIVE sea surface salinity' 
    131             WRITE(numout,*) '======= ' 
    132             WRITE(numout,9500) kt, zsmin, ii, ij 
    133             WRITE(numout,*) 
    134             WRITE(numout,*) '          output of last fields in numwso' 
    135          ENDIF 
    136          kindic = -3 
    137       ENDIF 
    138 9500  FORMAT (' kt=',i6,' min SSS: ',1pg11.4,', i j: ',2i5) 
    139       ! 
    140       ! 
    141       IF( lk_c1d )  RETURN          ! No log file in case of 1D vertical configuration 
    142  
    143       ! log file (ssh statistics) 
    144       ! --------                                   !* ssh statistics (and others...) 
    145       IF( kt == nit000 .AND. lwp ) THEN   ! open ssh statistics file (put in solver.stat file) 
    146          CALL ctl_opn( numsol, 'solver.stat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 
    147       ENDIF 
    148       ! 
    149       zsshmax = 0.e0 
    150       DO jj = 1, jpj 
    151          DO ji = 1, jpi 
    152             IF( tmask(ji,jj,1) == 1) zsshmax = MAX( zsshmax, ABS(sshn(ji,jj)) ) 
    153          END DO 
    154       END DO 
    155       IF( lk_mpp )   CALL mpp_max( zsshmax )                ! min over the global domain 
    156       ! 
    157       IF( MOD( kt, nwrite ) == 1 .AND. lwp )   WRITE(numout,*) ' ==>> time-step= ',kt,' ssh max:', zsshmax 
    158       ! 
    159       IF( zsshmax > 10.e0 ) THEN  
    160          IF (lk_mpp) THEN 
    161             CALL mpp_maxloc( ABS(sshn(:,:)),tmask(:,:,1),zsshmax,ii,ij) 
    162          ELSE 
    163             ilocs = MAXLOC( ABS(sshn(:,:)) ) 
    164             ii = ilocs(1) + nimpp - 1 
    165             ij = ilocs(2) + njmpp - 1 
    166          ENDIF 
    167          ! 
    168          IF(lwp) THEN 
    169             WRITE(numout,cform_err) 
    170             WRITE(numout,*) 'stp_ctl : the ssh is larger than 10m' 
    171             WRITE(numout,*) '======= ' 
    172             WRITE(numout,9600) kt, zsshmax, ii, ij 
    173             WRITE(numout,*) 
    174             WRITE(numout,*) '          output of last fields in numwso' 
    175          ENDIF 
    176          kindic = -3 
    177       ENDIF 
    178 9600  FORMAT (' kt=',i6,' max ssh: ',1pg11.4,', i j: ',2i5) 
    179       ! 
    180       zssh2 = glob_sum( sshn(:,:) * sshn(:,:) ) 
    181       ! 
    182       IF(lwp) WRITE(numsol,9700) kt, zssh2, zumax, zsmin      ! ssh statistics 
    183       ! 
    184 9700  FORMAT(' it :', i8, ' ssh2: ', d23.16, ' Umax: ',d23.16,' Smin: ',d23.16) 
     1279400  FORMAT(' it :', i8, '    |ssh|_max: ', e16.10, ' |U|_max: ',e16.10,' SSS_min: ',e16.10) 
    185128      ! 
    186129   END SUBROUTINE stp_ctl 
  • branches/2017/dev_r8183_ICEMODEL/NEMOGCM/NEMO/SAS_SRC/diawri.F90

    r7761 r8226  
    400400      CALL lim_wri_state_2( kt, id_i, nh_i ) 
    401401#elif defined key_lim3 
    402       CALL lim_wri_state( kt, id_i, nh_i ) 
     402      IF( nn_ice == 3 ) THEN   ! clem2017: condition in case agrif + lim but no-ice in child grid 
     403         CALL lim_wri_state( kt, id_i, nh_i ) 
     404      ENDIF 
    403405#else 
    404406      CALL histend( id_i, snc4chunks=snc4set ) 
  • branches/2017/dev_r8183_ICEMODEL/NEMOGCM/NEMO/SAS_SRC/nemogcm.F90

    r7761 r8226  
    134134      ! 
    135135#if defined key_agrif 
    136       IF( .NOT. Agrif_Root() ) THEN 
     136!!clem2017      IF( .NOT. Agrif_Root() ) THEN 
    137137         CALL Agrif_ParentGrid_To_ChildGrid() 
    138138         IF( nn_timing == 1 )   CALL timing_finalize 
    139139         CALL Agrif_ChildGrid_To_ParentGrid() 
    140       ENDIF 
     140!!clem2017      ENDIF 
    141141#endif 
    142142      IF( nn_timing == 1 )   CALL timing_finalize 
  • branches/2017/dev_r8183_ICEMODEL/NEMOGCM/SETTE/BATCH_TEMPLATE/batch-X64_MOBILIS

    r7646 r8226  
    88module load intel/compiler/64/14.0/2013_sp1.2.144 
    99module load openmpi/intel/64/1.6.5 
    10 module load slurm/2.5.7 
     10module load slurm/16.05.8 
    1111 
    1212# 
  • branches/2017/dev_r8183_ICEMODEL/NEMOGCM/SETTE/README

    r7646 r8226  
    4545               INPUT_DIR         : directory in which store input files (tar file) 
    4646               TMPDIR            : temporary directory NEEDED ONLY FOR IBM machines (put EXP00 directory) 
    47           NEMO_VALIDATION_DIR : directory in which create NEMO_VALIDATION tree, and store restart, solver.stat, tracer.stat and ocean.output files in 
     47          NEMO_VALIDATION_DIR : directory in which create NEMO_VALIDATION tree, and store restart, run.stat, tracer.stat and ocean.output files in 
    4848                            tree NEMO_VALIDATION_DIR/WCONFIG_NAME/WCOMPILER_NAME/TEST_NAME/REVISION_NUMBER(or DATE) 
    4949 in fcm_job.sh : 
  • branches/2017/dev_r8183_ICEMODEL/NEMOGCM/SETTE/all_functions.sh

    r7715 r8226  
    219219    fi 
    220220    # Save output & debug files in NEMO_VALIDATION tree 
    221     echo "saving ocean & ice output, solver.stat, tracer.stat files ...." >> ${SETTE_DIR}/output.sette 
     221    echo "saving ocean & ice output, run.stat, tracer.stat files ...." >> ${SETTE_DIR}/output.sette 
    222222    echo "            " >> ${SETTE_DIR}/output.sette 
    223223    [ -f ${EXE_DIR}/ocean.output ] && cp ${EXE_DIR}/*ocean.output ${NEMO_VALID}/. 
    224     [ -f ${EXE_DIR}/solver.stat ] && cp ${EXE_DIR}/*solver.stat ${NEMO_VALID}/. 
     224    [ -f ${EXE_DIR}/run.stat ] && cp ${EXE_DIR}/*run.stat ${NEMO_VALID}/. 
    225225    [ -f ${EXE_DIR}/output.namelist.dyn ] && cp ${EXE_DIR}/*output.nam* ${NEMO_VALID}/. 
    226226    [ -f ${EXE_DIR}/tracer.stat ] && cp ${EXE_DIR}/*tracer.stat ${NEMO_VALID}/. 
    227227 
    228     if [ -n "$(ls ${NEMO_VALID}/*solver*)" ] ; then 
    229    echo "moved solver.stat in ${NEMO_VALID} directory"  >> ${SETTE_DIR}/output.sette 
    230    echo "moved solver.stat in ${NEMO_VALID} directory"   
     228    if [ -n "$(ls ${NEMO_VALID}/*run*)" ] ; then 
     229   echo "moved run.stat in ${NEMO_VALID} directory"  >> ${SETTE_DIR}/output.sette 
     230   echo "moved run.stat in ${NEMO_VALID} directory"   
    231231    else 
    232    echo "problem in looking for solver.stat file in ${NEMO_VALID} directory"  >> ${SETTE_DIR}/output.sette 
    233    echo "solver.stat IS NOT in ${NEMO_VALID} directory"  
     232   echo "problem in looking for run.stat file in ${NEMO_VALID} directory"  >> ${SETTE_DIR}/output.sette 
     233   echo "run.stat IS NOT in ${NEMO_VALID} directory"  
    234234    fi 
    235235    if [ -n "$(ls ${NEMO_VALID}/*ocean.output*)" ] ; then 
  • branches/2017/dev_r8183_ICEMODEL/NEMOGCM/SETTE/sette.sh

    r7756 r8226  
    5656#   set_namelist     : function declared in all_functions that sets namelist parameters  
    5757#   post_test_tidyup : creates validation storage directory and copies required output files  
    58 #                      (solver.stat and ocean.output) in it after execution of test. 
     58#                      (run.stat and ocean.output) in it after execution of test. 
    5959# 
    6060#  VALIDATION tree is: 
     
    137137# ORCA2_OFF_PISCES  :  5 &  6 
    138138# AMM12             :  7 &  8  
    139 # SAS               :  9     fos SAS there is no solver so is useless to test REPRO 
     139# SAS               :  9     fos SAS there is no run.stat so is useless to test REPRO 
    140140# ISOMIP            : 10 & 11 
    141141# ORCA2_LIM3_OBS    : 12 
     
    661661    export TEST_NAME="LONG" 
    662662    cd ${CONFIG_DIR0} 
    663     . ./makenemo -m ${CMP_NAM} -n AMM12_LONG -r AMM12 -j 8 add_key "key_tide" del_key ${DEL_KEYS} 
     663    . ./makenemo -m ${CMP_NAM} -n AMM12_LONG -r AMM12 -j 8 del_key ${DEL_KEYS} 
    664664    cd ${SETTE_DIR} 
    665665    . ./param.cfg 
     
    11211121    set_namelist 1_namelist_cfg nn_it000 1 
    11221122    set_namelist 1_namelist_cfg nn_itend 150 
     1123    set_namelist 1_namelist_cfg nn_fsbc 1 
    11231124    set_namelist 1_namelist_cfg ln_ctl .false. 
    11241125    set_namelist 1_namelist_cfg ln_clobber .true. 
     
    12451246    set_namelist 1_namelist_cfg nn_itend 300 
    12461247    set_namelist 1_namelist_cfg nn_stock 150 
     1248    set_namelist 1_namelist_cfg nn_fsbc 1 
    12471249    set_namelist 1_namelist_cfg ln_ctl .false. 
    12481250    set_namelist 1_namelist_cfg ln_clobber .true. 
     
    12831285    set_namelist 1_namelist_cfg nn_itend 300 
    12841286    set_namelist 1_namelist_cfg nn_stock 150 
     1287    set_namelist 1_namelist_cfg nn_fsbc 1 
    12851288    set_namelist 1_namelist_cfg ln_rstart .true. 
    12861289    set_namelist 1_namelist_cfg nn_rstctl 2 
     
    13391342    set_namelist 1_namelist_cfg nn_it000 1 
    13401343    set_namelist 1_namelist_cfg nn_itend 150 
     1344    set_namelist 1_namelist_cfg nn_fsbc 1 
    13411345    set_namelist 1_namelist_cfg ln_ctl .false. 
    13421346    set_namelist 1_namelist_cfg ln_clobber .true. 
     
    13781382    set_namelist 1_namelist_cfg nn_itend 150 
    13791383    set_namelist 1_namelist_cfg ln_ctl .false. 
     1384    set_namelist 1_namelist_cfg nn_fsbc 1 
    13801385    set_namelist 1_namelist_cfg ln_clobber .true. 
    13811386    set_namelist 1_namelist_cfg ln_read_cfg .true. 
  • branches/2017/dev_r8183_ICEMODEL/NEMOGCM/SETTE/sette_beginner.sh

    r4796 r8226  
    5555#   set_namelist     : function declared in all_functions that sets namelist parameters  
    5656#   post_test_tidyup : creates validation storage directory and copies required output files  
    57 #                      (solver.stat and ocean.output) in it after execution of test. 
     57#                      (run.stat and ocean.output) in it after execution of test. 
    5858# 
    5959#  VALIDATION tree is: 
  • branches/2017/dev_r8183_ICEMODEL/NEMOGCM/SETTE/sette_rpt.sh

    r7715 r8226  
    11#!/bin/bash -f 
    22# 
     3# set -vx 
    34# simple SETTE report generator. 
    45# 
     
    2324    dorv=`echo $dorv | sed -e 's:.*/::'` 
    2425    f1o=$vdir/$nam/$mach/$dorv/LONG/ocean.output 
    25     f1s=$vdir/$nam/$mach/$dorv/LONG/solver.stat 
     26    f1s=$vdir/$nam/$mach/$dorv/LONG/run.stat 
    2627    f1t=$vdir/$nam/$mach/$dorv/LONG/tracer.stat 
    2728    f2o=$vdir/$nam/$mach/$dorv/SHORT/ocean.output 
    28     f2s=$vdir/$nam/$mach/$dorv/SHORT/solver.stat 
     29    f2s=$vdir/$nam/$mach/$dorv/SHORT/run.stat 
    2930    f2t=$vdir/$nam/$mach/$dorv/SHORT/tracer.stat 
    3031 
     
    4647      if [ $? == 0 ]; then 
    4748        if [ $pass == 0 ]; then  
    48           printf "%-20s %s %s\n" $nam  " solver.stat restartability  passed : " $dorv 
    49         fi 
    50       else 
    51         printf "%-20s %s %s\n" $nam  " solver.stat restartability  FAILED : " $dorv  
    52 # 
    53 # Offer view of differences on the second pass 
    54 # 
    55         if [ $pass == 1 ]; then 
    56           echo "<return> to view solver.stat differences" 
     49          printf "%-20s %s %s\n" $nam  " run.stat    restartability  passed : " $dorv 
     50        fi 
     51      else 
     52        printf "%-20s %s %s\n" $nam  " run.stat    restartability  FAILED : " $dorv  
     53# 
     54# Offer view of differences on the second pass 
     55# 
     56        if [ $pass == 1 ]; then 
     57          echo "<return> to view run.stat differences" 
    5758          read y 
    5859          sdiff f1.tmp$$ $f2s 
     
    118119    rep2=`ls -1rt $vdir/$nam/$mach/$dorv/ | tail -1l` 
    119120    f1o=$vdir/$nam/$mach/$dorv/$rep1/ocean.output 
    120     f1s=$vdir/$nam/$mach/$dorv/$rep1/solver.stat 
     121    f1s=$vdir/$nam/$mach/$dorv/$rep1/run.stat 
    121122    f1t=$vdir/$nam/$mach/$dorv/$rep1/tracer.stat 
    122123    f2o=$vdir/$nam/$mach/$dorv/$rep2/ocean.output 
    123     f2s=$vdir/$nam/$mach/$dorv/$rep2/solver.stat 
     124    f2s=$vdir/$nam/$mach/$dorv/$rep2/run.stat 
    124125    f2t=$vdir/$nam/$mach/$dorv/$rep2/tracer.stat 
    125126 
     
    139140      if [ $? == 0 ]; then 
    140141        if [ $pass == 0 ]; then  
    141           printf "%-20s %s %s\n" $nam  " solver.stat reproducibility passed : " $dorv 
    142         fi 
    143       else 
    144         printf "%-20s %s %s\n" $nam  " solver.stat reproducibility FAILED : " $dorv  
    145 # 
    146 # Offer view of differences on the second pass 
    147 # 
    148         if [ $pass == 1 ]; then 
    149           echo "<return> to view solver.stat differences" 
     142          printf "%-20s %s %s\n" $nam  " run.stat    reproducibility passed : " $dorv 
     143        fi 
     144      else 
     145        printf "%-20s %s %s\n" $nam  " run.stat    reproducibility FAILED : " $dorv  
     146# 
     147# Offer view of differences on the second pass 
     148# 
     149        if [ $pass == 1 ]; then 
     150          echo "<return> to view run.stat differences" 
    150151          read y 
    151152          sdiff f1.tmp$$ $f2s 
     
    199200  mach=`grep "COMPILER=" ./sette.sh | sed -e 's/COMPILER=//'` 
    200201  NEMO_VALID=`grep "NEMO_VALIDATION_DIR=" ./param.cfg | sed -e 's/NEMO_VALIDATION_DIR=//'` 
     202  NEMO_VALID=`eval "echo $NEMO_VALID"` 
    201203# 
    202204  if [ ! -d $NEMO_VALID ]; then 
  • branches/2017/dev_r8183_ICEMODEL/NEMOGCM/SETTE/sette_xios.sh

    r4990 r8226  
    5252#   set_namelist     : function declared in all_functions that sets namelist parameters  
    5353#   post_test_tidyup : creates validation storage directory and copies required output files  
    54 #                      (solver.stat and ocean.output) in it after execution of test. 
     54#                      (run.stat and ocean.output) in it after execution of test. 
    5555# 
    5656#  VALIDATION tree is: 
Note: See TracChangeset for help on using the changeset viewer.