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 (6 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)%pt2