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 5955 for branches/NERC/dev_r5589_is_oce_cpl/NEMOGCM/NEMO/NST_SRC – NEMO

Ignore:
Timestamp:
2015-11-30T17:43:24+01:00 (8 years ago)
Author:
mathiot
Message:

ice sheet coupling: merged in head of trunk (r5936)

Location:
branches/NERC/dev_r5589_is_oce_cpl/NEMOGCM/NEMO/NST_SRC
Files:
11 edited

Legend:

Unmodified
Added
Removed

  • branches/NERC/dev_r5589_is_oce_cpl/NEMOGCM/NEMO/NST_SRC/agrif2model.F90

    r3680 r5955  
    11#if defined key_agrif 
    2    !!---------------------------------------------------------------------- 
    3    !! NEMO/NST 3.3 , NEMO Consortium (2010) 
    4    !! $Id$ 
    5    !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    6    !!---------------------------------------------------------------------- 
    7    SUBROUTINE Agrif2Model 
    8       !!--------------------------------------------- 
    9       !!   *** ROUTINE Agrif2Model *** 
    10       !!---------------------------------------------  
    11    END SUBROUTINE Agrif2model 
     2!!---------------------------------------------------------------------- 
     3!! NEMO/NST 3.6 , NEMO Consortium (2010) 
     4!! $Id$ 
     5!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
     6!!---------------------------------------------------------------------- 
     7SUBROUTINE Agrif2Model 
     8   !!--------------------------------------------- 
     9   !!   *** ROUTINE Agrif2Model *** 
     10   !!---------------------------------------------  
     11END SUBROUTINE Agrif2model 
    1212 
    13    SUBROUTINE Agrif_Set_numberofcells(Agrif_Gr) 
    14       !!--------------------------------------------- 
    15       !!   *** ROUTINE Agrif_Set_numberofcells *** 
    16       !!---------------------------------------------  
    17       USE Agrif_Types 
    18       IMPLICIT NONE 
     13SUBROUTINE Agrif_Set_numberofcells(Agrif_Gr) 
     14   !!--------------------------------------------- 
     15   !!   *** ROUTINE Agrif_Set_numberofcells *** 
     16   !!---------------------------------------------  
     17   USE Agrif_Grids 
     18   IMPLICIT NONE 
    1919 
    20       Type(Agrif_Grid), Pointer :: Agrif_Gr 
     20   TYPE(Agrif_Grid), POINTER :: Agrif_Gr 
    2121 
    22       IF ( associated(Agrif_Curgrid) )THEN 
     22   IF ( ASSOCIATED(Agrif_Curgrid) )THEN 
    2323#include "SetNumberofcells.h" 
    24       ENDIF 
     24   ENDIF 
    2525 
    26    END SUBROUTINE Agrif_Set_numberofcells 
     26END SUBROUTINE Agrif_Set_numberofcells 
    2727 
    28    SUBROUTINE Agrif_Get_numberofcells(Agrif_Gr) 
    29       !!--------------------------------------------- 
    30       !!   *** ROUTINE Agrif_Get_numberofcells *** 
    31       !!---------------------------------------------  
    32       USE Agrif_Types 
    33       IMPLICIT NONE 
     28SUBROUTINE Agrif_Get_numberofcells(Agrif_Gr) 
     29   !!--------------------------------------------- 
     30   !!   *** ROUTINE Agrif_Get_numberofcells *** 
     31   !!---------------------------------------------  
     32   USE Agrif_Grids 
     33   IMPLICIT NONE 
    3434 
    35       Type(Agrif_Grid), Pointer :: Agrif_Gr 
     35   TYPE(Agrif_Grid), POINTER :: Agrif_Gr 
    3636 
     37   IF ( ASSOCIATED(Agrif_Curgrid) ) THEN 
    3738#include "GetNumberofcells.h" 
     39   ENDIF 
    3840 
    39    END SUBROUTINE Agrif_Get_numberofcells 
     41END SUBROUTINE Agrif_Get_numberofcells 
    4042 
    41    SUBROUTINE Agrif_Allocationcalls(Agrif_Gr) 
    42       !!--------------------------------------------- 
    43       !!   *** ROUTINE Agrif_Allocationscalls *** 
    44       !!---------------------------------------------  
    45       USE Agrif_Types  
     43SUBROUTINE Agrif_Allocationcalls(Agrif_Gr) 
     44   !!--------------------------------------------- 
     45   !!   *** ROUTINE Agrif_Allocationscalls *** 
     46   !!---------------------------------------------  
     47   USE Agrif_Grids  
    4648#include "include_use_Alloc_agrif.h" 
    47       IMPLICIT NONE 
     49   IMPLICIT NONE 
    4850 
    49       Type(Agrif_Grid), Pointer :: Agrif_Gr 
     51   TYPE(Agrif_Grid), POINTER :: Agrif_Gr 
    5052 
    5153#include "allocations_calls_agrif.h" 
    5254 
    53    END SUBROUTINE Agrif_Allocationcalls 
     55END SUBROUTINE Agrif_Allocationcalls 
    5456 
    55    SUBROUTINE Agrif_probdim_modtype_def() 
    56       !!--------------------------------------------- 
    57       !!   *** ROUTINE Agrif_probdim_modtype_def *** 
    58       !!---------------------------------------------  
    59       USE Agrif_Types 
    60       IMPLICIT NONE 
     57SUBROUTINE Agrif_probdim_modtype_def() 
     58   !!--------------------------------------------- 
     59   !!   *** ROUTINE Agrif_probdim_modtype_def *** 
     60   !!---------------------------------------------  
     61   USE Agrif_Types 
     62   IMPLICIT NONE 
    6163 
    6264#include "modtype_agrif.h" 
    … …  
    6466#include "keys_agrif.h" 
    6567 
    66       Return 
     68   RETURN 
    6769 
    68    END SUBROUTINE Agrif_probdim_modtype_def 
     70END SUBROUTINE Agrif_probdim_modtype_def 
    6971 
    70    SUBROUTINE Agrif_clustering_def() 
    71       !!--------------------------------------------- 
    72       !!   *** ROUTINE Agrif_clustering_def *** 
    73       !!---------------------------------------------  
    74       Use Agrif_Types 
    75       IMPLICIT NONE 
     72SUBROUTINE Agrif_clustering_def() 
     73   !!--------------------------------------------- 
     74   !!   *** ROUTINE Agrif_clustering_def *** 
     75   !!---------------------------------------------  
     76   IMPLICIT NONE 
    7677 
    77       Return 
     78   RETURN 
    7879 
    79    END SUBROUTINE Agrif_clustering_def 
     80END SUBROUTINE Agrif_clustering_def 
    8081 
    81    SUBROUTINE Agrif_comm_def(modelcomm) 
    82  
    83       !!--------------------------------------------- 
    84       !!   *** ROUTINE Agrif_clustering_def *** 
    85       !!---------------------------------------------  
    86       Use Agrif_Types 
    87       Use lib_mpp 
    88  
    89       IMPLICIT NONE 
    90  
    91       INTEGER :: modelcomm 
    92  
    93 #if defined key_mpp_mpi 
    94       modelcomm = mpi_comm_opa 
     82#else 
     83SUBROUTINE Agrif2Model 
     84   !!--------------------------------------------- 
     85   !!   *** ROUTINE Agrif2Model *** 
     86   !!---------------------------------------------  
     87   WRITE(*,*) 'Impossible to bet here' 
     88END SUBROUTINE Agrif2model 
    9589#endif 
    96       Return 
    97  
    98    END SUBROUTINE Agrif_comm_def 
    99 #else 
    100    SUBROUTINE Agrif2Model 
    101       !!--------------------------------------------- 
    102       !!   *** ROUTINE Agrif2Model *** 
    103       !!---------------------------------------------  
    104       WRITE(*,*) 'Impossible to bet here' 
    105    END SUBROUTINE Agrif2model 
    106 #endif 

  • branches/NERC/dev_r5589_is_oce_cpl/NEMOGCM/NEMO/NST_SRC/agrif_lim2_interp.F90

    r3680 r5955  
    99   !!            3.4   !  09-2012  (R. Benshila, C. Herbaut) update and EVP 
    1010   !!---------------------------------------------------------------------- 
    11 #if defined key_agrif && defined key_lim2 
     11#if defined key_agrif && defined key_lim2  
    1212   !!---------------------------------------------------------------------- 
    1313   !!   'key_lim2'  :                                 LIM 2.0 sea-ice model 
    … …  
    4141   PUBLIC interp_adv_ice 
    4242 
     43   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE, PRIVATE :: uice_agr, vice_agr 
     44   REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, PRIVATE :: tabice_agr  
     45 
     46 
    4347   !!---------------------------------------------------------------------- 
    4448   !! NEMO/NST 3.4 , NEMO Consortium (2012) 
    … …  
    6569      u_ice_nst(:,:) = 0. 
    6670      v_ice_nst(:,:) = 0. 
    67       CALL Agrif_Bc_variable( u_ice_nst, u_ice_id ,procname=interp_u_ice, calledweight=1. ) 
    68       CALL Agrif_Bc_variable( v_ice_nst, v_ice_id ,procname=interp_v_ice, calledweight=1. ) 
     71      CALL Agrif_Bc_variable( u_ice_id ,procname=interp_u_ice, calledweight=1. ) 
     72      CALL Agrif_Bc_variable( v_ice_id ,procname=interp_v_ice, calledweight=1. ) 
    6973      Agrif_SpecialValue=0. 
    7074      Agrif_UseSpecialValue = .FALSE. 
    … …  
    138142      !!  we are in inside a new parent ice time step 
    139143      !!----------------------------------------------------------------------- 
    140       REAL(wp), DIMENSION(jpi,jpj) :: zuice, zvice 
    141144      INTEGER :: ji,jj 
    142145      REAL(wp) :: zrhox, zrhoy 
    … …  
    155158         Agrif_SpecialValue=-9999. 
    156159         Agrif_UseSpecialValue = .TRUE. 
    157          zuice = 0. 
    158          zvice = 0. 
    159          CALL Agrif_Bc_variable(zuice,u_ice_id,procname=interp_u_ice, calledweight=1.) 
    160          CALL Agrif_Bc_variable(zvice,v_ice_id,procname=interp_v_ice, calledweight=1.) 
     160         IF( .NOT. ALLOCATED(uice_agr) )THEN 
     161            ALLOCATE(uice_agr(jpi,jpj), vice_agr(jpi,jpj)) 
     162         ENDIF 
     163         uice_agr = 0. 
     164         vice_agr = 0. 
     165         CALL Agrif_Bc_variable(u_ice_id,procname=interp_u_ice, calledweight=1.) 
     166         CALL Agrif_Bc_variable(v_ice_id,procname=interp_v_ice, calledweight=1.) 
    161167         Agrif_SpecialValue=0. 
    162168         Agrif_UseSpecialValue = .FALSE. 
    163169         !   
    164170         zrhox = agrif_rhox() ;    zrhoy = agrif_rhoy()       
    165          zuice(:,:) =  zuice(:,:)/(zrhoy*e2u(:,:))*umask(:,:,1) 
    166          zvice(:,:) =  zvice(:,:)/(zrhox*e1v(:,:))*vmask(:,:,1) 
     171         uice_agr(:,:) =  uice_agr(:,:)/(zrhoy*e2u(:,:))*umask(:,:,1) 
     172         vice_agr(:,:) =  vice_agr(:,:)/(zrhox*e1v(:,:))*vmask(:,:,1) 
    167173         ! fill  boundaries 
    168174         DO jj = 1, jpj 
    169175            DO ji = 1, 2 
    170                u_ice_oe(ji,  jj,2) = zuice(ji       ,jj)  
    171                u_ice_oe(ji+2,jj,2) = zuice(nlci+ji-3,jj) 
     176               u_ice_oe(ji,  jj,2) = uice_agr(ji       ,jj)  
     177               u_ice_oe(ji+2,jj,2) = uice_agr(nlci+ji-3,jj) 
    172178            END DO 
    173179         END DO 
    174180         DO jj = 1, jpj 
    175             v_ice_oe(2,jj,2) = zvice(2     ,jj)  
    176             v_ice_oe(4,jj,2) = zvice(nlci-1,jj) 
     181            v_ice_oe(2,jj,2) = vice_agr(2     ,jj)  
     182            v_ice_oe(4,jj,2) = vice_agr(nlci-1,jj) 
    177183         END DO 
    178184         DO ji = 1, jpi 
    179             u_ice_sn(ji,2,2) = zuice(ji,2     )  
    180             u_ice_sn(ji,4,2) = zuice(ji,nlcj-1) 
     185            u_ice_sn(ji,2,2) = uice_agr(ji,2     )  
     186            u_ice_sn(ji,4,2) = uice_agr(ji,nlcj-1) 
    181187         END DO 
    182188         DO jj = 1, 2 
    183189            DO ji = 1, jpi 
    184                v_ice_sn(ji,jj  ,2) = zvice(ji,jj       )  
    185                v_ice_sn(ji,jj+2,2) = zvice(ji,nlcj+jj-3) 
     190               v_ice_sn(ji,jj  ,2) = vice_agr(ji,jj       )  
     191               v_ice_sn(ji,jj+2,2) = vice_agr(ji,nlcj+jj-3) 
    186192            END DO 
    187193         END DO 
    … …  
    334340      !!  we are in inside a new parent ice time step 
    335341     !!----------------------------------------------------------------------- 
    336       REAL(wp), DIMENSION(jpi,jpj,7) :: ztab  
    337342      INTEGER :: ji,jj,jn 
    338343      !!----------------------------------------------------------------------- 
    … …  
    345350         adv_ice_sn(:,:,:,1) =  adv_ice_sn(:,:,:,2) 
    346351         ! interpolation of boundaries 
    347          ztab(:,:,:) = 0. 
     352         IF(.NOT.ALLOCATED(tabice_agr))THEN 
     353            ALLOCATE(tabice_agr(jpi,jpj,7))    
     354         ENDIF 
     355         tabice_agr(:,:,:) = 0. 
    348356         Agrif_SpecialValue=-9999. 
    349357         Agrif_UseSpecialValue = .TRUE. 
    350          CALL Agrif_Bc_variable( ztab, adv_ice_id ,procname=interp_adv_ice,calledweight=1. ) 
     358         CALL Agrif_Bc_variable( adv_ice_id ,procname=interp_adv_ice,calledweight=1. ) 
    351359         Agrif_SpecialValue=0. 
    352360         Agrif_UseSpecialValue = .FALSE. 
    … …  
    356364            DO jj = 1, jpj 
    357365               DO ji=1,2 
    358                   adv_ice_oe(ji  ,jj,jn,2) = ztab(ji       ,jj,jn)  
    359                   adv_ice_oe(ji+2,jj,jn,2) = ztab(nlci-2+ji,jj,jn) 
     366                  adv_ice_oe(ji  ,jj,jn,2) = tabice_agr(ji       ,jj,jn)  
     367                  adv_ice_oe(ji+2,jj,jn,2) = tabice_agr(nlci-2+ji,jj,jn) 
    360368               END DO 
    361369            END DO 
    … …  
    365373            Do jj =1,2 
    366374               DO ji = 1, jpi 
    367                   adv_ice_sn(ji,jj  ,jn,2) = ztab(ji,jj       ,jn)  
    368                   adv_ice_sn(ji,jj+2,jn,2) = ztab(ji,nlcj-2+jj,jn) 
     375                  adv_ice_sn(ji,jj  ,jn,2) = tabice_agr(ji,jj       ,jn)  
     376                  adv_ice_sn(ji,jj+2,jn,2) = tabice_agr(ji,nlcj-2+jj,jn) 
    369377               END DO 
    370378            END DO 
    … …  
    384392      INTEGER :: ji,jj,jn 
    385393      REAL(wp) :: zalpha 
    386       REAL(wp), DIMENSION(jpi,jpj,7) :: ztab  
     394      REAL(wp), DIMENSION(jpi,jpj,7) :: tabice_agr  
    387395      !!-----------------------------------------------------------------------       
    388396      ! 
    … …  
    391399      zalpha = REAL(lim_nbstep,wp) / (Agrif_Rhot()*Agrif_PArent(nn_fsbc)/REAL(nn_fsbc)) 
    392400      ! 
    393       ztab(:,:,:) = 0.e0 
     401      tabice_agr(:,:,:) = 0.e0 
    394402      DO jn =1,7 
    395403         DO jj =1,2 
    396404            DO ji = 1, jpi 
    397                ztab(ji,jj        ,jn) = (1-zalpha)*adv_ice_sn(ji,jj  ,jn,1) + zalpha*adv_ice_sn(ji,jj  ,jn,2)  
    398                ztab(ji,nlcj-2+jj ,jn) = (1-zalpha)*adv_ice_sn(ji,jj+2,jn,1) + zalpha*adv_ice_sn(ji,jj+2,jn,2)  
     405               tabice_agr(ji,jj        ,jn) = (1-zalpha)*adv_ice_sn(ji,jj  ,jn,1) + zalpha*adv_ice_sn(ji,jj  ,jn,2)  
     406               tabice_agr(ji,nlcj-2+jj ,jn) = (1-zalpha)*adv_ice_sn(ji,jj+2,jn,1) + zalpha*adv_ice_sn(ji,jj+2,jn,2)  
    399407            END DO 
    400408         END DO 
    … …  
    404412         DO jj = 1, jpj 
    405413            DO ji=1,2 
    406                ztab(ji       ,jj,jn) = (1-zalpha)*adv_ice_oe(ji  ,jj,jn,1) + zalpha*adv_ice_oe(ji  ,jj,jn,2)  
    407                ztab(nlci-2+ji,jj,jn) = (1-zalpha)*adv_ice_oe(ji+2,jj,jn,1) + zalpha*adv_ice_oe(ji+2,jj,jn,2)  
     414               tabice_agr(ji       ,jj,jn) = (1-zalpha)*adv_ice_oe(ji  ,jj,jn,1) + zalpha*adv_ice_oe(ji  ,jj,jn,2)  
     415               tabice_agr(nlci-2+ji,jj,jn) = (1-zalpha)*adv_ice_oe(ji+2,jj,jn,1) + zalpha*adv_ice_oe(ji+2,jj,jn,2)  
    408416            END DO 
    409417         END DO 
    410418      END DO 
    411419      ! 
    412       CALL parcoursT( ztab(:,:, 1), frld  ) 
    413       CALL parcoursT( ztab(:,:, 2), hicif ) 
    414       CALL parcoursT( ztab(:,:, 3), hsnif ) 
    415       CALL parcoursT( ztab(:,:, 4), tbif(:,:,1) ) 
    416       CALL parcoursT( ztab(:,:, 5), tbif(:,:,2) ) 
    417       CALL parcoursT( ztab(:,:, 6), tbif(:,:,3) ) 
    418       CALL parcoursT( ztab(:,:, 7), qstoif ) 
     420      CALL parcoursT( tabice_agr(:,:, 1), frld  ) 
     421      CALL parcoursT( tabice_agr(:,:, 2), hicif ) 
     422      CALL parcoursT( tabice_agr(:,:, 3), hsnif ) 
     423      CALL parcoursT( tabice_agr(:,:, 4), tbif(:,:,1) ) 
     424      CALL parcoursT( tabice_agr(:,:, 5), tbif(:,:,2) ) 
     425      CALL parcoursT( tabice_agr(:,:, 6), tbif(:,:,3) ) 
     426      CALL parcoursT( tabice_agr(:,:, 7), qstoif ) 
    419427      ! 
    420428   END SUBROUTINE agrif_trp_lim2 
    … …  
    499507 
    500508 
    501    SUBROUTINE interp_u_ice( tabres, i1, i2, j1, j2 ) 
     509   SUBROUTINE interp_u_ice( tabres, i1, i2, j1, j2, before ) 
    502510      !!----------------------------------------------------------------------- 
    503511      !!                     *** ROUTINE interp_u_ice *** 
    … …  
    505513      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    506514      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
     515      LOGICAL, INTENT(in) :: before 
    507516      !! 
    508517      INTEGER :: ji,jj 
    … …  
    510519      ! 
    511520#if defined key_lim2_vp 
    512       DO jj=MAX(j1,2),j2 
    513          DO ji=MAX(i1,2),i2 
    514             IF( tmu(ji,jj) == 0. ) THEN 
    515                tabres(ji,jj) = -9999. 
    516             ELSE 
    517                tabres(ji,jj) = e2f(ji-1,jj-1) * u_ice(ji,jj) 
    518             ENDIF 
    519          END DO 
    520       END DO 
     521      IF( before ) THEN 
     522         DO jj=MAX(j1,2),j2 
     523            DO ji=MAX(i1,2),i2 
     524               IF( tmu(ji,jj) == 0. ) THEN 
     525                  tabres(ji,jj) = -9999. 
     526               ELSE 
     527                  tabres(ji,jj) = e2f(ji-1,jj-1) * u_ice(ji,jj) 
     528               ENDIF 
     529            END DO 
     530         END DO 
     531      ENDIF 
    521532#else 
    522       DO jj= j1, j2 
    523          DO ji= i1, i2 
    524             IF( umask(ji,jj,1) == 0. ) THEN 
    525                tabres(ji,jj) = -9999. 
    526             ELSE 
    527                tabres(ji,jj) = e2u(ji,jj) * u_ice(ji,jj) 
    528             ENDIF 
    529          END DO 
    530       END DO 
     533      IF( before ) THEN 
     534         DO jj= j1, j2 
     535            DO ji= i1, i2 
     536               IF( umask(ji,jj,1) == 0. ) THEN 
     537                  tabres(ji,jj) = -9999. 
     538               ELSE 
     539                  tabres(ji,jj) = e2u(ji,jj) * u_ice(ji,jj) 
     540               ENDIF 
     541            END DO 
     542         END DO 
     543      ENDIF 
    531544#endif 
    532545   END SUBROUTINE interp_u_ice 
    533546 
    534547 
    535    SUBROUTINE interp_v_ice( tabres, i1, i2, j1, j2 ) 
     548   SUBROUTINE interp_v_ice( tabres, i1, i2, j1, j2, before ) 
    536549      !!----------------------------------------------------------------------- 
    537550      !!                    *** ROUTINE interp_v_ice *** 
    … …  
    539552      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    540553      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
     554      LOGICAL, INTENT(in) :: before 
    541555      !! 
    542556      INTEGER :: ji, jj 
    … …  
    544558      ! 
    545559#if defined key_lim2_vp 
    546       DO jj=MAX(j1,2),j2 
    547          DO ji=MAX(i1,2),i2 
    548             IF( tmu(ji,jj) == 0. ) THEN 
    549                tabres(ji,jj) = -9999. 
    550             ELSE 
    551                tabres(ji,jj) = e1f(ji-1,jj-1) * v_ice(ji,jj) 
    552             ENDIF 
    553          END DO 
    554       END DO 
     560      IF( before ) THEN 
     561         DO jj=MAX(j1,2),j2 
     562            DO ji=MAX(i1,2),i2 
     563               IF( tmu(ji,jj) == 0. ) THEN 
     564                  tabres(ji,jj) = -9999. 
     565               ELSE 
     566                  tabres(ji,jj) = e1f(ji-1,jj-1) * v_ice(ji,jj) 
     567               ENDIF 
     568            END DO 
     569         END DO 
     570      ENDIF    
    555571#else 
    556       DO jj= j1 ,j2 
    557          DO ji = i1, i2 
    558             IF( vmask(ji,jj,1) == 0. ) THEN 
    559                tabres(ji,jj) = -9999. 
    560             ELSE 
    561                tabres(ji,jj) = e1v(ji,jj) * v_ice(ji,jj) 
    562             ENDIF 
    563          END DO 
    564       END DO 
     572      IF( before ) THEN 
     573         DO jj= j1 ,j2 
     574            DO ji = i1, i2 
     575               IF( vmask(ji,jj,1) == 0. ) THEN 
     576                  tabres(ji,jj) = -9999. 
     577               ELSE 
     578                  tabres(ji,jj) = e1v(ji,jj) * v_ice(ji,jj) 
     579               ENDIF 
     580            END DO 
     581         END DO 
     582      ENDIF 
    565583#endif 
    566584   END SUBROUTINE interp_v_ice 
    567585 
    568586 
    569    SUBROUTINE interp_adv_ice( tabres, i1, i2, j1, j2 ) 
     587   SUBROUTINE interp_adv_ice( tabres, i1, i2, j1, j2, before ) 
    570588      !!----------------------------------------------------------------------- 
    571589      !!                    *** ROUTINE interp_adv_ice ***                            
    … …  
    577595      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    578596      REAL(wp), DIMENSION(i1:i2,j1:j2,7), INTENT(inout) :: tabres 
     597      LOGICAL, INTENT(in) :: before 
    579598      !! 
    580599      INTEGER :: ji, jj, jk 
    581600      !!----------------------------------------------------------------------- 
    582601      ! 
    583       DO jj=j1,j2 
    584          DO ji=i1,i2 
    585             IF( tms(ji,jj) == 0. ) THEN 
    586                tabres(ji,jj,:) = -9999.  
    587             ELSE 
    588                tabres(ji,jj, 1) = frld  (ji,jj) 
    589                tabres(ji,jj, 2) = hicif (ji,jj) 
    590                tabres(ji,jj, 3) = hsnif (ji,jj) 
    591                tabres(ji,jj, 4) = tbif  (ji,jj,1) 
    592                tabres(ji,jj, 5) = tbif  (ji,jj,2) 
    593                tabres(ji,jj, 6) = tbif  (ji,jj,3) 
    594                tabres(ji,jj, 7) = qstoif(ji,jj) 
    595             ENDIF 
    596          END DO 
    597       END DO 
     602      IF( before ) THEN 
     603         DO jj=j1,j2 
     604            DO ji=i1,i2 
     605               IF( tms(ji,jj) == 0. ) THEN 
     606                  tabres(ji,jj,:) = -9999.  
     607               ELSE 
     608                  tabres(ji,jj, 1) = frld  (ji,jj) 
     609                  tabres(ji,jj, 2) = hicif (ji,jj) 
     610                  tabres(ji,jj, 3) = hsnif (ji,jj) 
     611                  tabres(ji,jj, 4) = tbif  (ji,jj,1) 
     612                  tabres(ji,jj, 5) = tbif  (ji,jj,2) 
     613                  tabres(ji,jj, 6) = tbif  (ji,jj,3) 
     614                  tabres(ji,jj, 7) = qstoif(ji,jj) 
     615               ENDIF 
     616            END DO 
     617         END DO 
     618      ENDIF 
    598619      ! 
    599620   END SUBROUTINE interp_adv_ice 

  • branches/NERC/dev_r5589_is_oce_cpl/NEMOGCM/NEMO/NST_SRC/agrif_lim2_update.F90

    r3680 r5955  
    5252      INTEGER, INTENT(in) :: kt 
    5353      !! 
    54       REAL(wp), DIMENSION(jpi,jpj)  :: zvel 
    55       REAL(wp), DIMENSION(jpi,jpj,7):: zadv 
    5654      !!---------------------------------------------------------------------- 
    5755      ! 
    … …  
    6058      Agrif_UseSpecialValueInUpdate = .TRUE. 
    6159      Agrif_SpecialValueFineGrid = 0. 
    62  
    6360# if defined TWO_WAY 
    6461      IF( MOD(nbcline,nbclineupdate) == 0) THEN 
    65          CALL Agrif_Update_Variable( zadv , adv_ice_id , procname = update_adv_ice  ) 
    66          CALL Agrif_Update_Variable( zvel , u_ice_id   , procname = update_u_ice    ) 
    67          CALL Agrif_Update_Variable( zvel , v_ice_id   , procname = update_v_ice    ) 
    68       ELSE 
    69          CALL Agrif_Update_Variable( zadv , adv_ice_id , locupdate=(/0,2/), procname = update_adv_ice  ) 
    70          CALL Agrif_Update_Variable( zvel , u_ice_id   , locupdate=(/0,1/), procname = update_u_ice    ) 
    71          CALL Agrif_Update_Variable( zvel , v_ice_id   , locupdate=(/0,1/), procname = update_v_ice    ) 
     62         CALL Agrif_Update_Variable( adv_ice_id , procname = update_adv_ice  ) 
     63         CALL Agrif_Update_Variable( u_ice_id   , procname = update_u_ice    ) 
     64         CALL Agrif_Update_Variable( v_ice_id   , procname = update_v_ice    ) 
     65      ELSE 
     66         CALL Agrif_Update_Variable( adv_ice_id , locupdate=(/0,2/), procname = update_adv_ice  ) 
     67         CALL Agrif_Update_Variable( u_ice_id   , locupdate=(/0,1/), procname = update_u_ice    ) 
     68         CALL Agrif_Update_Variable( v_ice_id   , locupdate=(/0,1/), procname = update_v_ice    ) 
    7269      ENDIF 
    7370# endif 

  • branches/NERC/dev_r5589_is_oce_cpl/NEMOGCM/NEMO/NST_SRC/agrif_oce.F90

    r4491 r5955  
    1212   USE par_oce      ! ocean parameters 
    1313   USE dom_oce      ! domain parameters 
    14     
     14 
    1515   IMPLICIT NONE 
    1616   PRIVATE  
    … …  
    1919 
    2020   !                                              !!* Namelist namagrif: AGRIF parameters 
    21    LOGICAL , PUBLIC ::   ln_spc_dyn      !: 
    22    INTEGER , PUBLIC ::   nn_cln_update   !: update frequency  
    23    REAL(wp), PUBLIC ::   rn_sponge_tra   !: sponge coeff. for tracers 
    24    REAL(wp), PUBLIC ::   rn_sponge_dyn   !: sponge coeff. for dynamics 
     21   LOGICAL , PUBLIC ::   ln_spc_dyn    = .FALSE.   !: 
     22   INTEGER , PUBLIC ::   nn_cln_update = 3         !: update frequency  
     23   INTEGER , PUBLIC, PARAMETER ::   nn_sponge_len = 2  !: Sponge width (in number of parent grid points) 
     24   REAL(wp), PUBLIC ::   rn_sponge_tra = 2800.     !: sponge coeff. for tracers 
     25   REAL(wp), PUBLIC ::   rn_sponge_dyn = 2800.     !: sponge coeff. for dynamics 
     26   LOGICAL , PUBLIC ::   ln_chk_bathy  = .FALSE.   !: check of parent bathymetry  
    2527 
    2628   !                                              !!! OLD namelist names 
    … …  
    3032   REAL(wp), PUBLIC ::   visc_dyn                  !: sponge coeff. for dynamics 
    3133 
    32    LOGICAL , PUBLIC :: spongedoneT = .FALSE.   !: tracer   sponge layer indicator 
    33    LOGICAL , PUBLIC :: spongedoneU = .FALSE.   !: dynamics sponge layer indicator 
    34    LOGICAL , PUBLIC :: lk_agrif_fstep = .TRUE. !: if true: first step 
     34   LOGICAL , PUBLIC :: spongedoneT = .FALSE.       !: tracer   sponge layer indicator 
     35   LOGICAL , PUBLIC :: spongedoneU = .FALSE.       !: dynamics sponge layer indicator 
     36   LOGICAL , PUBLIC :: lk_agrif_fstep = .TRUE.     !: if true: first step 
     37   LOGICAL , PUBLIC :: lk_agrif_doupd = .TRUE.     !: if true: send update from current grid 
     38   LOGICAL , PUBLIC :: lk_agrif_debug = .FALSE.    !: if true: print debugging info 
    3539 
    36    REAL(wp), PUBLIC, ALLOCATABLE, SAVE,  DIMENSION(:,:) ::   spe1ur , spe2vr , spbtr2   !: ??? 
    37    REAL(wp), PUBLIC, ALLOCATABLE, SAVE,  DIMENSION(:,:) ::   spe1ur2, spe2vr2, spbtr3   !: ??? 
    38     
    39    INTEGER :: tsn_id,tsb_id,tsa_id 
    40    INTEGER :: un_id, vn_id, ua_id, va_id 
    41    INTEGER :: e1u_id, e2v_id, sshn_id, gcb_id 
    42    INTEGER :: trn_id, trb_id, tra_id 
    43    INTEGER :: unb_id, vnb_id, ub2b_id, vb2b_id 
     40   LOGICAL , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tabspongedone_tsn 
     41# if defined key_top 
     42   LOGICAL , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tabspongedone_trn 
     43# endif 
     44   LOGICAL , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tabspongedone_u 
     45   LOGICAL , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tabspongedone_v 
     46   REAL(wp), PUBLIC, ALLOCATABLE, SAVE,  DIMENSION(:,:) :: fsaht_spu, fsaht_spv !: sponge diffusivities 
     47   REAL(wp), PUBLIC, ALLOCATABLE, SAVE,  DIMENSION(:,:) :: fsahm_spt, fsahm_spf !: sponge viscosities 
     48 
     49   ! Barotropic arrays used to store open boundary data during 
     50   ! time-splitting loop: 
     51   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) ::  ubdy_w, vbdy_w, hbdy_w 
     52   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) ::  ubdy_e, vbdy_e, hbdy_e 
     53   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) ::  ubdy_n, vbdy_n, hbdy_n 
     54   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) ::  ubdy_s, vbdy_s, hbdy_s 
     55 
     56   INTEGER :: tsn_id                                                  ! AGRIF profile for tracers interpolation and update 
     57   INTEGER :: un_interp_id, vn_interp_id                              ! AGRIF profiles for interpolations 
     58   INTEGER :: un_update_id, vn_update_id                              ! AGRIF profiles for udpates 
     59   INTEGER :: tsn_sponge_id, un_sponge_id, vn_sponge_id               ! AGRIF profiles for sponge layers 
     60# if defined key_top 
     61   INTEGER :: trn_id, trn_sponge_id 
     62# endif   
     63   INTEGER :: unb_id, vnb_id, ub2b_interp_id, vb2b_interp_id 
     64   INTEGER :: ub2b_update_id, vb2b_update_id 
     65   INTEGER :: e3t_id, e1u_id, e2v_id, sshn_id 
     66   INTEGER :: scales_t_id 
     67# if defined key_zdftke 
     68   INTEGER :: avt_id, avm_id, en_id 
     69# endif   
     70   INTEGER :: umsk_id, vmsk_id 
     71   INTEGER :: kindic_agr 
    4472 
    4573   !!---------------------------------------------------------------------- 
    … …  
    5482      !!                ***  FUNCTION agrif_oce_alloc  *** 
    5583      !!---------------------------------------------------------------------- 
    56       ALLOCATE( spe1ur (jpi,jpj) , spe2vr (jpi,jpj) , spbtr2(jpi,jpj) ,      & 
    57          &      spe1ur2(jpi,jpj) , spe2vr2(jpi,jpj) , spbtr3(jpi,jpj) , STAT = agrif_oce_alloc )  
     84      INTEGER, DIMENSION(2) :: ierr 
     85      !!---------------------------------------------------------------------- 
     86      ierr(:) = 0 
     87      ! 
     88      ALLOCATE( fsaht_spu(jpi,jpj), fsaht_spv(jpi,jpj),   & 
     89         &      fsahm_spt(jpi,jpj), fsahm_spf(jpi,jpj),   & 
     90         &      tabspongedone_tsn(jpi,jpj),           & 
     91# if defined key_top          
     92         &      tabspongedone_trn(jpi,jpj),           & 
     93# endif          
     94         &      tabspongedone_u  (jpi,jpj),           & 
     95         &      tabspongedone_v  (jpi,jpj), STAT = ierr(1) ) 
     96 
     97      ALLOCATE( ubdy_w(jpj), vbdy_w(jpj), hbdy_w(jpj),   & 
     98         &      ubdy_e(jpj), vbdy_e(jpj), hbdy_e(jpj),   &  
     99         &      ubdy_n(jpi), vbdy_n(jpi), hbdy_n(jpi),   &  
     100         &      ubdy_s(jpi), vbdy_s(jpi), hbdy_s(jpi), STAT = ierr(2) ) 
     101 
     102      agrif_oce_alloc = MAXVAL(ierr) 
     103      ! 
    58104   END FUNCTION agrif_oce_alloc 
    59105 

  • branches/NERC/dev_r5589_is_oce_cpl/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90

    r4486 r5955  
    77   !!             -   !  2005-11  (XXX)  
    88   !!            3.2  !  2009-04  (R. Benshila)  
     9   !!            3.6  !  2014-09  (R. Benshila)  
    910   !!---------------------------------------------------------------------- 
    1011#if defined key_agrif && ! defined key_offline 
    … …  
    2122   USE oce 
    2223   USE dom_oce       
    23    USE sol_oce 
    2424   USE agrif_oce 
    2525   USE phycst 
    … …  
    2828   USE lib_mpp 
    2929   USE wrk_nemo 
    30    USE dynspg_oce 
    31  
     30   USE zdf_oce 
     31  
    3232   IMPLICIT NONE 
    3333   PRIVATE 
    3434 
    35    ! Barotropic arrays used to store open boundary data during 
    36    ! time-splitting loop: 
    37    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) ::  ubdy_w, vbdy_w, hbdy_w 
    38    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) ::  ubdy_e, vbdy_e, hbdy_e 
    39    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) ::  ubdy_n, vbdy_n, hbdy_n 
    40    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) ::  ubdy_s, vbdy_s, hbdy_s 
    41      
     35   INTEGER :: bdy_tinterp = 0 
     36 
    4237   PUBLIC   Agrif_tra, Agrif_dyn, Agrif_ssh, Agrif_dyn_ts, Agrif_ssh_ts, Agrif_dta_ts 
    43    PUBLIC   interpu, interpv, interpunb, interpvnb, interpsshn 
     38   PUBLIC   interpun, interpvn 
     39   PUBLIC   interptsn,  interpsshn 
     40   PUBLIC   interpunb, interpvnb, interpub2b, interpvb2b 
     41   PUBLIC   interpe3t, interpumsk, interpvmsk 
     42# if defined key_zdftke 
     43   PUBLIC   Agrif_tke, interpavm 
     44# endif 
    4445 
    4546#  include "domzgr_substitute.h90"   
    4647#  include "vectopt_loop_substitute.h90" 
    4748   !!---------------------------------------------------------------------- 
    48    !! NEMO/NST 3.3 , NEMO Consortium (2010) 
     49   !! NEMO/NST 3.6 , NEMO Consortium (2010) 
    4950   !! $Id$ 
    5051   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    5152   !!---------------------------------------------------------------------- 
    5253 
    53    CONTAINS 
    54     
     54CONTAINS 
     55 
    5556   SUBROUTINE Agrif_tra 
    5657      !!---------------------------------------------------------------------- 
    57       !!                  ***  ROUTINE Agrif_Tra  *** 
    58       !!---------------------------------------------------------------------- 
    59       !! 
    60       INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    61       REAL(wp) ::   zrhox , alpha1, alpha2, alpha3 
    62       REAL(wp) ::   alpha4, alpha5, alpha6, alpha7 
    63       REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztsa 
     58      !!                  ***  ROUTINE Agrif_tra  *** 
    6459      !!---------------------------------------------------------------------- 
    6560      ! 
    6661      IF( Agrif_Root() )   RETURN 
    67  
    68       CALL wrk_alloc( jpi, jpj, jpk, jpts, ztsa )  
    6962 
    7063      Agrif_SpecialValue    = 0.e0 
    7164      Agrif_UseSpecialValue = .TRUE. 
    72       ztsa(:,:,:,:) = 0.e0 
    73  
    74       CALL Agrif_Bc_variable( ztsa, tsn_id, procname=interptsn ) 
     65 
     66      CALL Agrif_Bc_variable( tsn_id, procname=interptsn ) 
    7567      Agrif_UseSpecialValue = .FALSE. 
    76  
    77       zrhox = Agrif_Rhox() 
    78  
    79       alpha1 = ( zrhox - 1. ) * 0.5 
    80       alpha2 = 1. - alpha1 
    81  
    82       alpha3 = ( zrhox - 1. ) / ( zrhox + 1. ) 
    83       alpha4 = 1. - alpha3 
    84  
    85       alpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 
    86       alpha7 =    - ( zrhox - 1. ) / ( zrhox + 3. ) 
    87       alpha5 = 1. - alpha6 - alpha7 
    88  
    89       IF( nbondi == 1 .OR. nbondi == 2 ) THEN 
    90  
    91          DO jn = 1, jpts 
    92             tsa(nlci,:,:,jn) = alpha1 * ztsa(nlci,:,:,jn) + alpha2 * ztsa(nlci-1,:,:,jn) 
    93             DO jk = 1, jpkm1 
    94                DO jj = 1, jpj 
    95                   IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN 
    96                      tsa(nlci-1,jj,jk,jn) = tsa(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 
    97                   ELSE 
    98                      tsa(nlci-1,jj,jk,jn)=(alpha4*tsa(nlci,jj,jk,jn)+alpha3*tsa(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 
    99                      IF( un(nlci-2,jj,jk) > 0.e0 ) THEN 
    100                         tsa(nlci-1,jj,jk,jn)=( alpha6*tsa(nlci-2,jj,jk,jn)+alpha5*tsa(nlci,jj,jk,jn)  & 
    101                            &                 + alpha7*tsa(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 
    102                      ENDIF 
    103                   ENDIF 
    104                END DO 
    105             END DO 
    106          ENDDO 
    107       ENDIF 
    108  
    109       IF( nbondj == 1 .OR. nbondj == 2 ) THEN 
    110  
    111          DO jn = 1, jpts 
    112             tsa(:,nlcj,:,jn) = alpha1 * ztsa(:,nlcj,:,jn) + alpha2 * ztsa(:,nlcj-1,:,jn) 
    113             DO jk = 1, jpkm1 
    114                DO ji = 1, jpi 
    115                   IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN 
    116                      tsa(ji,nlcj-1,jk,jn) = tsa(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 
    117                   ELSE 
    118                      tsa(ji,nlcj-1,jk,jn)=(alpha4*tsa(ji,nlcj,jk,jn)+alpha3*tsa(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk)         
    119                      IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN 
    120                         tsa(ji,nlcj-1,jk,jn)=( alpha6*tsa(ji,nlcj-2,jk,jn)+alpha5*tsa(ji,nlcj,jk,jn)  & 
    121                            &                 + alpha7*tsa(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 
    122                      ENDIF 
    123                   ENDIF 
    124                END DO 
    125             END DO 
    126          ENDDO  
    127       ENDIF 
    128  
    129       IF( nbondi == -1 .OR. nbondi == 2 ) THEN 
    130          DO jn = 1, jpts 
    131             tsa(1,:,:,jn) = alpha1 * ztsa(1,:,:,jn) + alpha2 * ztsa(2,:,:,jn) 
    132             DO jk = 1, jpkm1 
    133                DO jj = 1, jpj 
    134                   IF( umask(2,jj,jk) == 0.e0 ) THEN 
    135                      tsa(2,jj,jk,jn) = tsa(1,jj,jk,jn) * tmask(2,jj,jk) 
    136                   ELSE 
    137                      tsa(2,jj,jk,jn)=(alpha4*tsa(1,jj,jk,jn)+alpha3*tsa(3,jj,jk,jn))*tmask(2,jj,jk)         
    138                      IF( un(2,jj,jk) < 0.e0 ) THEN 
    139                         tsa(2,jj,jk,jn)=(alpha6*tsa(3,jj,jk,jn)+alpha5*tsa(1,jj,jk,jn)+alpha7*tsa(4,jj,jk,jn))*tmask(2,jj,jk) 
    140                      ENDIF 
    141                   ENDIF 
    142                END DO 
    143             END DO 
    144          END DO 
    145       ENDIF 
    146  
    147       IF( nbondj == -1 .OR. nbondj == 2 ) THEN 
    148          DO jn = 1, jpts 
    149             tsa(:,1,:,jn) = alpha1 * ztsa(:,1,:,jn) + alpha2 * ztsa(:,2,:,jn) 
    150             DO jk=1,jpk       
    151                DO ji=1,jpi 
    152                   IF( vmask(ji,2,jk) == 0.e0 ) THEN 
    153                      tsa(ji,2,jk,jn)=tsa(ji,1,jk,jn) * tmask(ji,2,jk) 
    154                   ELSE 
    155                      tsa(ji,2,jk,jn)=(alpha4*tsa(ji,1,jk,jn)+alpha3*tsa(ji,3,jk,jn))*tmask(ji,2,jk) 
    156                      IF( vn(ji,2,jk) < 0.e0 ) THEN 
    157                         tsa(ji,2,jk,jn)=(alpha6*tsa(ji,3,jk,jn)+alpha5*tsa(ji,1,jk,jn)+alpha7*tsa(ji,4,jk,jn))*tmask(ji,2,jk) 
    158                      ENDIF 
    159                   ENDIF 
    160                END DO 
    161             END DO 
    162          ENDDO 
    163       ENDIF 
    164       ! 
    165       CALL wrk_dealloc( jpi, jpj, jpk, jpts, ztsa )  
    16668      ! 
    16769   END SUBROUTINE Agrif_tra 
    … …  
    17577      INTEGER, INTENT(in) ::   kt 
    17678      !! 
    177       INTEGER :: ji,jj,jk 
    178       REAL(wp) :: timeref 
    179       REAL(wp) :: z2dt, znugdt 
    180       REAL(wp) :: zrhox, zrhoy 
    181       REAL(wp), POINTER, DIMENSION(:,:,:) :: zua, zva 
    182       REAL(wp), POINTER, DIMENSION(:,:) :: spgv1, spgu1, zua2d, zva2d 
     79      INTEGER :: ji,jj,jk, j1,j2, i1,i2 
     80      REAL(wp), POINTER, DIMENSION(:,:) :: zub, zvb 
    18381      !!----------------------------------------------------------------------   
    18482 
    18583      IF( Agrif_Root() )   RETURN 
    18684 
    187       CALL wrk_alloc( jpi, jpj, spgv1, spgu1, zua2d, zva2d ) 
    188       CALL wrk_alloc( jpi, jpj, jpk, zua, zva ) 
    189  
    190       zrhox = Agrif_Rhox() 
    191       zrhoy = Agrif_Rhoy() 
    192  
    193       timeref = 1. 
    194  
    195       ! time step: leap-frog 
    196       z2dt = 2. * rdt 
    197       ! time step: Euler if restart from rest 
    198       IF( neuler == 0 .AND. kt == nit000 ) z2dt = rdt 
    199       ! coefficients 
    200       znugdt =  grav * z2dt     
     85      CALL wrk_alloc( jpi, jpj, zub, zvb ) 
    20186 
    20287      Agrif_SpecialValue=0. 
    20388      Agrif_UseSpecialValue = ln_spc_dyn 
    20489 
    205       zua = 0. 
    206       zva = 0. 
    207       CALL Agrif_Bc_variable(zua,un_id,procname=interpu) 
    208       CALL Agrif_Bc_variable(zva,vn_id,procname=interpv) 
    209       zua2d = 0. 
    210       zva2d = 0. 
    211  
    212 #if defined key_dynspg_flt 
    213       Agrif_SpecialValue=0. 
    214       Agrif_UseSpecialValue = ln_spc_dyn 
    215       CALL Agrif_Bc_variable(zua2d,e1u_id,calledweight=1.,procname=interpu2d) 
    216       CALL Agrif_Bc_variable(zva2d,e2v_id,calledweight=1.,procname=interpv2d) 
    217 #endif 
     90      CALL Agrif_Bc_variable(un_interp_id,procname=interpun) 
     91      CALL Agrif_Bc_variable(vn_interp_id,procname=interpvn) 
     92 
    21893      Agrif_UseSpecialValue = .FALSE. 
     94  
     95      ! prevent smoothing in ghost cells 
     96      i1=1 
     97      i2=jpi 
     98      j1=1 
     99      j2=jpj 
     100      IF((nbondj == -1).OR.(nbondj == 2)) j1 = 3 
     101      IF((nbondj == +1).OR.(nbondj == 2)) j2 = nlcj-2 
     102      IF((nbondi == -1).OR.(nbondi == 2)) i1 = 3 
     103      IF((nbondi == +1).OR.(nbondi == 2)) i2 = nlci-2 
    219104 
    220105 
    221106      IF((nbondi == -1).OR.(nbondi == 2)) THEN 
    222107 
    223 #if defined key_dynspg_flt 
     108         ! Smoothing 
     109         ! --------- 
     110         IF ( .NOT.ln_dynspg_ts ) THEN ! Store transport 
     111            ua_b(2,:)=0._wp 
     112            DO jk=1,jpkm1 
     113               DO jj=1,jpj 
     114                  ua_b(2,jj) = ua_b(2,jj) + fse3u_a(2,jj,jk) * ua(2,jj,jk) 
     115               END DO 
     116            END DO 
     117            DO jj=1,jpj 
     118               ua_b(2,jj) = ua_b(2,jj) * hur_a(2,jj)             
     119            END DO 
     120         ENDIF 
     121 
     122         DO jk=1,jpkm1                 ! Smooth 
     123            DO jj=j1,j2 
     124               ua(2,jj,jk) = 0.25_wp*(ua(1,jj,jk)+2._wp*ua(2,jj,jk)+ua(3,jj,jk)) 
     125               ua(2,jj,jk) = ua(2,jj,jk) * umask(2,jj,jk) 
     126            END DO 
     127         END DO 
     128 
     129         zub(2,:)=0._wp                ! Correct transport 
     130         DO jk=1,jpkm1 
     131            DO jj=1,jpj 
     132               zub(2,jj) = zub(2,jj) + fse3u_a(2,jj,jk) * ua(2,jj,jk) 
     133            END DO 
     134         END DO 
    224135         DO jj=1,jpj 
    225             laplacu(2,jj) = timeref * (zua2d(2,jj)/(zrhoy*e2u(2,jj)))*umask(2,jj,1) 
    226          END DO 
    227 #endif 
     136            zub(2,jj) = zub(2,jj) * hur_a(2,jj) 
     137         END DO 
    228138 
    229139         DO jk=1,jpkm1 
    230140            DO jj=1,jpj 
    231                ua(1:2,jj,jk) = (zua(1:2,jj,jk)/(zrhoy*e2u(1:2,jj))) 
    232                ua(1:2,jj,jk) = ua(1:2,jj,jk) / fse3u_a(1:2,jj,jk) 
    233             END DO 
    234          END DO 
    235  
    236 #if defined key_dynspg_flt 
    237          DO jk=1,jpkm1 
     141               ua(2,jj,jk) = (ua(2,jj,jk)+ua_b(2,jj)-zub(2,jj))*umask(2,jj,jk) 
     142            END DO 
     143         END DO 
     144 
     145         ! Set tangential velocities to time splitting estimate 
     146         !----------------------------------------------------- 
     147         IF ( ln_dynspg_ts) THEN 
     148            zvb(2,:)=0._wp 
     149            DO jk=1,jpkm1 
     150               DO jj=1,jpj 
     151                  zvb(2,jj) = zvb(2,jj) + fse3v_a(2,jj,jk) * va(2,jj,jk) 
     152               END DO 
     153            END DO 
    238154            DO jj=1,jpj 
    239                ua(2,jj,jk) = (ua(2,jj,jk) - z2dt * znugdt * laplacu(2,jj))*umask(2,jj,jk) 
    240             END DO 
    241          END DO 
    242  
    243          spgu(2,:)=0. 
    244  
     155               zvb(2,jj) = zvb(2,jj) * hvr_a(2,jj) 
     156            END DO 
     157            DO jk=1,jpkm1 
     158               DO jj=1,jpj 
     159                  va(2,jj,jk) = (va(2,jj,jk)+va_b(2,jj)-zvb(2,jj))*vmask(2,jj,jk) 
     160               END DO 
     161            END DO 
     162         ENDIF 
     163 
     164         ! Mask domain edges: 
     165         !------------------- 
    245166         DO jk=1,jpkm1 
    246167            DO jj=1,jpj 
    247                spgu(2,jj)=spgu(2,jj)+fse3u_a(2,jj,jk)*ua(2,jj,jk) 
    248             END DO 
    249          END DO 
    250  
     168               ua(1,jj,jk) = 0._wp 
     169               va(1,jj,jk) = 0._wp 
     170            END DO 
     171         END DO          
     172 
     173      ENDIF 
     174 
     175      IF((nbondi == 1).OR.(nbondi == 2)) THEN 
     176 
     177         ! Smoothing 
     178         ! --------- 
     179         IF ( .NOT.ln_dynspg_ts ) THEN ! Store transport 
     180            ua_b(nlci-2,:)=0._wp 
     181            DO jk=1,jpkm1 
     182               DO jj=1,jpj 
     183                  ua_b(nlci-2,jj) = ua_b(nlci-2,jj) + fse3u_a(nlci-2,jj,jk) * ua(nlci-2,jj,jk) 
     184               END DO 
     185            END DO 
     186            DO jj=1,jpj 
     187               ua_b(nlci-2,jj) = ua_b(nlci-2,jj) * hur_a(nlci-2,jj)             
     188            END DO 
     189         ENDIF 
     190 
     191         DO jk=1,jpkm1                 ! Smooth 
     192            DO jj=j1,j2 
     193               ua(nlci-2,jj,jk) = 0.25_wp*(ua(nlci-3,jj,jk)+2._wp*ua(nlci-2,jj,jk)+ua(nlci-1,jj,jk)) 
     194               ua(nlci-2,jj,jk) = ua(nlci-2,jj,jk) * umask(nlci-2,jj,jk) 
     195            END DO 
     196         END DO 
     197 
     198         zub(nlci-2,:)=0._wp           ! Correct transport 
     199         DO jk=1,jpkm1 
     200            DO jj=1,jpj 
     201               zub(nlci-2,jj) = zub(nlci-2,jj) + fse3u_a(nlci-2,jj,jk) * ua(nlci-2,jj,jk) 
     202            END DO 
     203         END DO 
    251204         DO jj=1,jpj 
    252             IF (umask(2,jj,1).NE.0.) THEN 
    253                spgu(2,jj)=spgu(2,jj)*hur_a(2,jj) 
    254             ENDIF 
    255          END DO 
    256 #else 
    257          spgu(2,:) = ua_b(2,:) 
    258 #endif 
     205            zub(nlci-2,jj) = zub(nlci-2,jj) * hur_a(nlci-2,jj) 
     206         END DO 
    259207 
    260208         DO jk=1,jpkm1 
    261209            DO jj=1,jpj 
    262                ua(2,jj,jk) = 0.25*(ua(1,jj,jk)+2.*ua(2,jj,jk)+ua(3,jj,jk)) 
    263                ua(2,jj,jk) = ua(2,jj,jk) * umask(2,jj,jk) 
    264             END DO 
    265          END DO 
    266  
    267          spgu1(2,:)=0. 
    268  
    269          DO jk=1,jpkm1 
     210               ua(nlci-2,jj,jk) = (ua(nlci-2,jj,jk)+ua_b(nlci-2,jj)-zub(nlci-2,jj))*umask(nlci-2,jj,jk) 
     211            END DO 
     212         END DO 
     213 
     214         ! Set tangential velocities to time splitting estimate 
     215         !----------------------------------------------------- 
     216         IF ( ln_dynspg_ts) THEN 
     217            zvb(nlci-1,:)=0._wp 
     218            DO jk=1,jpkm1 
     219               DO jj=1,jpj 
     220                  zvb(nlci-1,jj) = zvb(nlci-1,jj) + fse3v_a(nlci-1,jj,jk) * va(nlci-1,jj,jk) 
     221               END DO 
     222            END DO 
    270223            DO jj=1,jpj 
    271                spgu1(2,jj)=spgu1(2,jj)+fse3u_a(2,jj,jk)*ua(2,jj,jk) 
    272             END DO 
    273          END DO 
    274  
    275          DO jj=1,jpj 
    276             IF (umask(2,jj,1).NE.0.) THEN 
    277                spgu1(2,jj)=spgu1(2,jj)*hur_a(2,jj) 
    278             ENDIF 
    279          END DO 
    280  
     224               zvb(nlci-1,jj) = zvb(nlci-1,jj) * hvr_a(nlci-1,jj) 
     225            END DO 
     226            DO jk=1,jpkm1 
     227               DO jj=1,jpj 
     228                  va(nlci-1,jj,jk) = (va(nlci-1,jj,jk)+va_b(nlci-1,jj)-zvb(nlci-1,jj))*vmask(nlci-1,jj,jk) 
     229               END DO 
     230            END DO 
     231         ENDIF 
     232 
     233         ! Mask domain edges: 
     234         !------------------- 
    281235         DO jk=1,jpkm1 
    282236            DO jj=1,jpj 
    283                ua(2,jj,jk) = (ua(2,jj,jk)+spgu(2,jj)-spgu1(2,jj))*umask(2,jj,jk) 
    284             END DO 
    285          END DO 
    286  
    287          DO jk=1,jpkm1 
    288             DO jj=1,jpj 
    289                va(2,jj,jk) = (zva(2,jj,jk)/(zrhox*e1v(2,jj)))*vmask(2,jj,jk) 
    290                va(2,jj,jk) = va(2,jj,jk) / fse3v_a(2,jj,jk) 
    291             END DO 
    292          END DO 
    293  
    294 #if defined key_dynspg_ts 
     237               ua(nlci-1,jj,jk) = 0._wp 
     238               va(nlci  ,jj,jk) = 0._wp 
     239            END DO 
     240         END DO  
     241 
     242      ENDIF 
     243 
     244      IF((nbondj == -1).OR.(nbondj == 2)) THEN 
     245 
     246         ! Smoothing 
     247         ! --------- 
     248         IF ( .NOT.ln_dynspg_ts ) THEN ! Store transport 
     249            va_b(:,2)=0._wp 
     250            DO jk=1,jpkm1 
     251               DO ji=1,jpi 
     252                  va_b(ji,2) = va_b(ji,2) + fse3v_a(ji,2,jk) * va(ji,2,jk) 
     253               END DO 
     254            END DO 
     255            DO ji=1,jpi 
     256               va_b(ji,2) = va_b(ji,2) * hvr_a(ji,2)             
     257            END DO 
     258         ENDIF 
     259 
     260         DO jk=1,jpkm1                 ! Smooth 
     261            DO ji=i1,i2 
     262               va(ji,2,jk)=0.25_wp*(va(ji,1,jk)+2._wp*va(ji,2,jk)+va(ji,3,jk)) 
     263               va(ji,2,jk)=va(ji,2,jk)*vmask(ji,2,jk) 
     264            END DO 
     265         END DO 
     266 
     267         zvb(:,2)=0._wp                ! Correct transport 
     268         DO jk=1,jpkm1 
     269            DO ji=1,jpi 
     270               zvb(ji,2) = zvb(ji,2) + fse3v_a(ji,2,jk) * va(ji,2,jk) * vmask(ji,2,jk) 
     271            END DO 
     272         END DO 
     273         DO ji=1,jpi 
     274            zvb(ji,2) = zvb(ji,2) * hvr_a(ji,2) 
     275         END DO 
     276         DO jk=1,jpkm1 
     277            DO ji=1,jpi 
     278               va(ji,2,jk) = (va(ji,2,jk)+va_b(ji,2)-zvb(ji,2))*vmask(ji,2,jk) 
     279            END DO 
     280         END DO 
     281 
    295282         ! Set tangential velocities to time splitting estimate 
    296          spgv1(2,:)=0. 
    297          DO jk=1,jpkm1 
    298             DO jj=1,jpj 
    299                spgv1(2,jj)=spgv1(2,jj)+fse3v_a(2,jj,jk)*va(2,jj,jk) 
    300             END DO 
    301          END DO 
    302  
    303          DO jj=1,jpj 
    304             spgv1(2,jj)=spgv1(2,jj)*hvr_a(2,jj) 
    305          END DO 
    306  
    307          DO jk=1,jpkm1 
    308             DO jj=1,jpj 
    309                va(2,jj,jk) = (va(2,jj,jk)+va_b(2,jj)-spgv1(2,jj))*vmask(2,jj,jk) 
    310             END DO 
    311          END DO 
    312 #endif 
    313  
    314       ENDIF 
    315  
    316       IF((nbondi == 1).OR.(nbondi == 2)) THEN 
    317 #if defined key_dynspg_flt 
    318          DO jj=1,jpj 
    319             laplacu(nlci-2,jj) = timeref * (zua2d(nlci-2,jj)/(zrhoy*e2u(nlci-2,jj))) 
    320          END DO 
    321 #endif 
    322  
    323          DO jk=1,jpkm1 
    324             DO jj=1,jpj 
    325                ua(nlci-2:nlci-1,jj,jk) = (zua(nlci-2:nlci-1,jj,jk)/(zrhoy*e2u(nlci-2:nlci-1,jj))) 
    326                ua(nlci-2:nlci-1,jj,jk) = ua(nlci-2:nlci-1,jj,jk) / fse3u_a(nlci-2:nlci-1,jj,jk) 
    327             END DO 
    328          END DO 
    329  
    330 #if defined key_dynspg_flt 
    331          DO jk=1,jpkm1 
    332             DO jj=1,jpj 
    333                ua(nlci-2,jj,jk) = (ua(nlci-2,jj,jk)- z2dt * znugdt * laplacu(nlci-2,jj))*umask(nlci-2,jj,jk) 
    334             END DO 
    335          END DO 
    336  
    337  
    338          spgu(nlci-2,:)=0. 
    339  
    340          do jk=1,jpkm1 
    341             do jj=1,jpj 
    342                spgu(nlci-2,jj)=spgu(nlci-2,jj)+fse3u_a(nlci-2,jj,jk)*ua(nlci-2,jj,jk) 
    343             enddo 
    344          enddo 
    345  
    346          DO jj=1,jpj 
    347             IF (umask(nlci-2,jj,1).NE.0.) THEN 
    348                spgu(nlci-2,jj)=spgu(nlci-2,jj)*hur_a(nlci-2,jj) 
    349             ENDIF 
    350          END DO 
    351 #else 
    352          spgu(nlci-2,:) = ua_b(nlci-2,:) 
    353 #endif 
    354  
    355          DO jk=1,jpkm1 
    356             DO jj=1,jpj 
    357                ua(nlci-2,jj,jk) = 0.25*(ua(nlci-3,jj,jk)+2.*ua(nlci-2,jj,jk)+ua(nlci-1,jj,jk)) 
    358  
    359                ua(nlci-2,jj,jk) = ua(nlci-2,jj,jk) * umask(nlci-2,jj,jk) 
    360  
    361             END DO 
    362          END DO 
    363  
    364          spgu1(nlci-2,:)=0. 
    365  
    366          DO jk=1,jpkm1 
    367             DO jj=1,jpj 
    368                spgu1(nlci-2,jj)=spgu1(nlci-2,jj)+fse3u_a(nlci-2,jj,jk)*ua(nlci-2,jj,jk)*umask(nlci-2,jj,jk) 
    369             END DO 
    370          END DO 
    371  
    372          DO jj=1,jpj 
    373             IF (umask(nlci-2,jj,1).NE.0.) THEN 
    374                spgu1(nlci-2,jj)=spgu1(nlci-2,jj)*hur_a(nlci-2,jj) 
    375             ENDIF 
    376          END DO 
    377  
    378          DO jk=1,jpkm1 
    379             DO jj=1,jpj 
    380                ua(nlci-2,jj,jk) = (ua(nlci-2,jj,jk)+spgu(nlci-2,jj)-spgu1(nlci-2,jj))*umask(nlci-2,jj,jk) 
    381             END DO 
    382          END DO 
    383  
    384          DO jk=1,jpkm1 
    385             DO jj=1,jpj-1 
    386                va(nlci-1,jj,jk) = (zva(nlci-1,jj,jk)/(zrhox*e1v(nlci-1,jj)))*vmask(nlci-1,jj,jk) 
    387                va(nlci-1,jj,jk) = va(nlci-1,jj,jk) / fse3v_a(nlci-1,jj,jk) 
    388             END DO 
    389          END DO 
    390  
    391 #if defined key_dynspg_ts 
     283         !----------------------------------------------------- 
     284         IF ( ln_dynspg_ts ) THEN 
     285            zub(:,2)=0._wp 
     286            DO jk=1,jpkm1 
     287               DO ji=1,jpi 
     288                  zub(ji,2) = zub(ji,2) + fse3u_a(ji,2,jk) * ua(ji,2,jk) * umask(ji,2,jk) 
     289               END DO 
     290            END DO 
     291            DO ji=1,jpi 
     292               zub(ji,2) = zub(ji,2) * hur_a(ji,2) 
     293            END DO 
     294 
     295            DO jk=1,jpkm1 
     296               DO ji=1,jpi 
     297                  ua(ji,2,jk) = (ua(ji,2,jk)+ua_b(ji,2)-zub(ji,2))*umask(ji,2,jk) 
     298               END DO 
     299            END DO 
     300         ENDIF 
     301 
     302         ! Mask domain edges: 
     303         !------------------- 
     304         DO jk=1,jpkm1 
     305            DO ji=1,jpi 
     306               ua(ji,1,jk) = 0._wp 
     307               va(ji,1,jk) = 0._wp 
     308            END DO 
     309         END DO  
     310 
     311      ENDIF 
     312 
     313      IF((nbondj == 1).OR.(nbondj == 2)) THEN 
     314         ! Smoothing 
     315         ! --------- 
     316         IF ( .NOT.ln_dynspg_ts ) THEN ! Store transport 
     317            va_b(:,nlcj-2)=0._wp 
     318            DO jk=1,jpkm1 
     319               DO ji=1,jpi 
     320                  va_b(ji,nlcj-2) = va_b(ji,nlcj-2) + fse3v_a(ji,nlcj-2,jk) * va(ji,nlcj-2,jk) 
     321               END DO 
     322            END DO 
     323            DO ji=1,jpi 
     324               va_b(ji,nlcj-2) = va_b(ji,nlcj-2) * hvr_a(ji,nlcj-2)             
     325            END DO 
     326         ENDIF 
     327 
     328         DO jk=1,jpkm1                 ! Smooth 
     329            DO ji=i1,i2 
     330               va(ji,nlcj-2,jk)=0.25_wp*(va(ji,nlcj-3,jk)+2._wp*va(ji,nlcj-2,jk)+va(ji,nlcj-1,jk)) 
     331               va(ji,nlcj-2,jk)=va(ji,nlcj-2,jk)*vmask(ji,nlcj-2,jk) 
     332            END DO 
     333         END DO 
     334 
     335         zvb(:,nlcj-2)=0._wp           ! Correct transport 
     336         DO jk=1,jpkm1 
     337            DO ji=1,jpi 
     338               zvb(ji,nlcj-2) = zvb(ji,nlcj-2) + fse3v_a(ji,nlcj-2,jk) * va(ji,nlcj-2,jk) * vmask(ji,nlcj-2,jk) 
     339            END DO 
     340         END DO 
     341         DO ji=1,jpi 
     342            zvb(ji,nlcj-2) = zvb(ji,nlcj-2) * hvr_a(ji,nlcj-2) 
     343         END DO 
     344         DO jk=1,jpkm1 
     345            DO ji=1,jpi 
     346               va(ji,nlcj-2,jk) = (va(ji,nlcj-2,jk)+va_b(ji,nlcj-2)-zvb(ji,nlcj-2))*vmask(ji,nlcj-2,jk) 
     347            END DO 
     348         END DO 
     349 
    392350         ! Set tangential velocities to time splitting estimate 
    393          spgv1(nlci-1,:)=0._wp 
    394          DO jk=1,jpkm1 
    395             DO jj=1,jpj 
    396                spgv1(nlci-1,jj)=spgv1(nlci-1,jj)+fse3v_a(nlci-1,jj,jk)*va(nlci-1,jj,jk)*vmask(nlci-1,jj,jk) 
    397             END DO 
    398          END DO 
    399  
    400          DO jj=1,jpj 
    401             spgv1(nlci-1,jj)=spgv1(nlci-1,jj)*hvr_a(nlci-1,jj) 
    402          END DO 
    403  
    404          DO jk=1,jpkm1 
    405             DO jj=1,jpj 
    406                va(nlci-1,jj,jk) = (va(nlci-1,jj,jk)+va_b(nlci-1,jj)-spgv1(nlci-1,jj))*vmask(nlci-1,jj,jk) 
    407             END DO 
    408          END DO 
    409 #endif 
    410  
    411       ENDIF 
    412  
    413       IF((nbondj == -1).OR.(nbondj == 2)) THEN 
    414  
    415 #if defined key_dynspg_flt 
    416          DO ji=1,jpi 
    417             laplacv(ji,2) = timeref * (zva2d(ji,2)/(zrhox*e1v(ji,2))) 
    418          END DO 
    419 #endif 
    420  
    421          DO jk=1,jpkm1 
     351         !----------------------------------------------------- 
     352         IF ( ln_dynspg_ts ) THEN 
     353            zub(:,nlcj-1)=0._wp 
     354            DO jk=1,jpkm1 
     355               DO ji=1,jpi 
     356                  zub(ji,nlcj-1) = zub(ji,nlcj-1) + fse3u_a(ji,nlcj-1,jk) * ua(ji,nlcj-1,jk) * umask(ji,nlcj-1,jk) 
     357               END DO 
     358            END DO 
    422359            DO ji=1,jpi 
    423                va(ji,1:2,jk) = (zva(ji,1:2,jk)/(zrhox*e1v(ji,1:2))) 
    424                va(ji,1:2,jk) = va(ji,1:2,jk) / fse3v_a(ji,1:2,jk) 
    425             END DO 
    426          END DO 
    427  
    428 #if defined key_dynspg_flt 
     360               zub(ji,nlcj-1) = zub(ji,nlcj-1) * hur_a(ji,nlcj-1) 
     361            END DO 
     362 
     363            DO jk=1,jpkm1 
     364               DO ji=1,jpi 
     365                  ua(ji,nlcj-1,jk) = (ua(ji,nlcj-1,jk)+ua_b(ji,nlcj-1)-zub(ji,nlcj-1))*umask(ji,nlcj-1,jk) 
     366               END DO 
     367            END DO 
     368         ENDIF 
     369 
     370         ! Mask domain edges: 
     371         !------------------- 
    429372         DO jk=1,jpkm1 
    430373            DO ji=1,jpi 
    431                va(ji,2,jk) = (va(ji,2,jk) - z2dt * znugdt * laplacv(ji,2))*vmask(ji,2,jk) 
    432             END DO 
    433          END DO 
    434  
    435          spgv(:,2)=0. 
    436  
    437          DO jk=1,jpkm1 
    438             DO ji=1,jpi 
    439                spgv(ji,2)=spgv(ji,2)+fse3v_a(ji,2,jk)*va(ji,2,jk) 
    440             END DO 
    441          END DO 
    442  
    443          DO ji=1,jpi 
    444             IF (vmask(ji,2,1).NE.0.) THEN 
    445                spgv(ji,2)=spgv(ji,2)*hvr_a(ji,2) 
    446             ENDIF 
    447          END DO 
    448 #else 
    449          spgv(:,2)=va_b(:,2) 
    450 #endif 
    451  
    452          DO jk=1,jpkm1 
    453             DO ji=1,jpi 
    454                va(ji,2,jk)=0.25*(va(ji,1,jk)+2.*va(ji,2,jk)+va(ji,3,jk)) 
    455                va(ji,2,jk)=va(ji,2,jk)*vmask(ji,2,jk) 
    456             END DO 
    457          END DO 
    458  
    459          spgv1(:,2)=0. 
    460  
    461          DO jk=1,jpkm1 
    462             DO ji=1,jpi 
    463                spgv1(ji,2)=spgv1(ji,2)+fse3v_a(ji,2,jk)*va(ji,2,jk)*vmask(ji,2,jk) 
    464             END DO 
    465          END DO 
    466  
    467          DO ji=1,jpi 
    468             IF (vmask(ji,2,1).NE.0.) THEN 
    469                spgv1(ji,2)=spgv1(ji,2)*hvr_a(ji,2) 
    470             ENDIF 
    471          END DO 
    472  
    473          DO jk=1,jpkm1 
    474             DO ji=1,jpi 
    475                va(ji,2,jk) = (va(ji,2,jk)+spgv(ji,2)-spgv1(ji,2))*vmask(ji,2,jk) 
    476             END DO 
    477          END DO 
    478  
    479          DO jk=1,jpkm1 
    480             DO ji=1,jpi 
    481                ua(ji,2,jk) = (zua(ji,2,jk)/(zrhoy*e2u(ji,2)))*umask(ji,2,jk)  
    482                ua(ji,2,jk) = ua(ji,2,jk) / fse3u_a(ji,2,jk) 
    483             END DO 
    484          END DO 
    485  
    486 #if defined key_dynspg_ts 
    487          ! Set tangential velocities to time splitting estimate 
    488          spgu1(:,2)=0._wp 
    489          DO jk=1,jpkm1 
    490             DO ji=1,jpi 
    491                spgu1(ji,2)=spgu1(ji,2)+fse3u_a(ji,2,jk)*ua(ji,2,jk)*umask(ji,2,jk) 
    492             END DO 
    493          END DO 
    494  
    495          DO ji=1,jpi 
    496             spgu1(ji,2)=spgu1(ji,2)*hur_a(ji,2) 
    497          END DO 
    498  
    499          DO jk=1,jpkm1 
    500             DO ji=1,jpi 
    501                ua(ji,2,jk) = (ua(ji,2,jk)+ua_b(ji,2)-spgu1(ji,2))*umask(ji,2,jk) 
    502             END DO 
    503          END DO 
    504 #endif 
    505       ENDIF 
    506  
    507       IF((nbondj == 1).OR.(nbondj == 2)) THEN 
    508  
    509 #if defined key_dynspg_flt 
    510          DO ji=1,jpi 
    511             laplacv(ji,nlcj-2) = timeref * (zva2d(ji,nlcj-2)/(zrhox*e1v(ji,nlcj-2))) 
    512          END DO 
    513 #endif 
    514  
    515          DO jk=1,jpkm1 
    516             DO ji=1,jpi 
    517                va(ji,nlcj-2:nlcj-1,jk) = (zva(ji,nlcj-2:nlcj-1,jk)/(zrhox*e1v(ji,nlcj-2:nlcj-1))) 
    518                va(ji,nlcj-2:nlcj-1,jk) = va(ji,nlcj-2:nlcj-1,jk) / fse3v_a(ji,nlcj-2:nlcj-1,jk) 
    519             END DO 
    520          END DO 
    521  
    522 #if defined key_dynspg_flt 
    523          DO jk=1,jpkm1 
    524             DO ji=1,jpi 
    525                va(ji,nlcj-2,jk) = (va(ji,nlcj-2,jk)-z2dt * znugdt * laplacv(ji,nlcj-2))*vmask(ji,nlcj-2,jk) 
    526             END DO 
    527          END DO 
    528  
    529          spgv(:,nlcj-2)=0. 
    530  
    531          DO jk=1,jpkm1 
    532             DO ji=1,jpi 
    533                spgv(ji,nlcj-2)=spgv(ji,nlcj-2)+fse3v_a(ji,nlcj-2,jk)*va(ji,nlcj-2,jk) 
    534             END DO 
    535          END DO 
    536  
    537          DO ji=1,jpi 
    538             IF (vmask(ji,nlcj-2,1).NE.0.) THEN 
    539                spgv(ji,nlcj-2)=spgv(ji,nlcj-2)*hvr_a(ji,nlcj-2) 
    540             ENDIF 
    541          END DO 
    542 #else 
    543          spgv(:,nlcj-2)=va_b(:,nlcj-2) 
    544 #endif 
    545  
    546          DO jk=1,jpkm1 
    547             DO ji=1,jpi 
    548                va(ji,nlcj-2,jk)=0.25*(va(ji,nlcj-3,jk)+2.*va(ji,nlcj-2,jk)+va(ji,nlcj-1,jk)) 
    549                va(ji,nlcj-2,jk) = va(ji,nlcj-2,jk) * vmask(ji,nlcj-2,jk) 
    550             END DO 
    551          END DO 
    552  
    553          spgv1(:,nlcj-2)=0. 
    554  
    555          DO jk=1,jpkm1 
    556             DO ji=1,jpi 
    557                spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)+fse3v_a(ji,nlcj-2,jk)*va(ji,nlcj-2,jk) 
    558             END DO 
    559          END DO 
    560  
    561          DO ji=1,jpi 
    562             IF (vmask(ji,nlcj-2,1).NE.0.) THEN 
    563                spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)*hvr_a(ji,nlcj-2) 
    564             ENDIF 
    565          END DO 
    566  
    567          DO jk=1,jpkm1 
    568             DO ji=1,jpi 
    569                va(ji,nlcj-2,jk) = (va(ji,nlcj-2,jk)+spgv(ji,nlcj-2)-spgv1(ji,nlcj-2))*vmask(ji,nlcj-2,jk) 
    570             END DO 
    571          END DO 
    572  
    573          DO jk=1,jpkm1 
    574             DO ji=1,jpi 
    575                ua(ji,nlcj-1,jk) = (zua(ji,nlcj-1,jk)/(zrhoy*e2u(ji,nlcj-1)))*umask(ji,nlcj-1,jk) 
    576                ua(ji,nlcj-1,jk) = ua(ji,nlcj-1,jk) / fse3u_a(ji,nlcj-1,jk) 
    577             END DO 
    578          END DO 
    579  
    580 #if defined key_dynspg_ts 
    581          ! Set tangential velocities to time splitting estimate 
    582          spgu1(:,nlcj-1)=0._wp 
    583          DO jk=1,jpkm1 
    584             DO ji=1,jpi 
    585                spgu1(ji,nlcj-1)=spgu1(ji,nlcj-1)+fse3u_a(ji,nlcj-1,jk)*ua(ji,nlcj-1,jk) 
    586             END DO 
    587          END DO 
    588  
    589          DO ji=1,jpi 
    590             spgu1(ji,nlcj-1)=spgu1(ji,nlcj-1)*hur_a(ji,nlcj-1) 
    591          END DO 
    592  
    593          DO jk=1,jpkm1 
    594             DO ji=1,jpi 
    595                ua(ji,nlcj-1,jk) = (ua(ji,nlcj-1,jk)+ua_b(ji,nlcj-1)-spgu1(ji,nlcj-1))*umask(ji,nlcj-1,jk) 
    596             END DO 
    597          END DO 
    598 #endif 
    599  
    600       ENDIF 
    601       ! 
    602       CALL wrk_dealloc( jpi, jpj, spgv1, spgu1, zua2d, zva2d ) 
    603       CALL wrk_dealloc( jpi, jpj, jpk, zua, zva ) 
     374               ua(ji,nlcj  ,jk) = 0._wp 
     375               va(ji,nlcj-1,jk) = 0._wp 
     376            END DO 
     377         END DO  
     378 
     379      ENDIF 
     380      ! 
     381      CALL wrk_dealloc( jpi, jpj, zub, zvb ) 
    604382      ! 
    605383   END SUBROUTINE Agrif_dyn 
    … …  
    620398         DO jj=1,jpj 
    621399            va_e(2,jj) = vbdy_w(jj) * hvr_e(2,jj) 
    622 ! Specified fluxes: 
     400            ! Specified fluxes: 
    623401            ua_e(2,jj) = ubdy_w(jj) * hur_e(2,jj) 
    624 ! Characteristics method: 
    625 !alt            ua_e(2,jj) = 0.5_wp * ( ubdy_w(jj) * hur_e(2,jj) + ua_e(3,jj) & 
    626 !alt                       &           - sqrt(grav * hur_e(2,jj)) * (sshn_e(3,jj) - hbdy_w(jj)) ) 
     402            ! Characteristics method: 
     403            !alt            ua_e(2,jj) = 0.5_wp * ( ubdy_w(jj) * hur_e(2,jj) + ua_e(3,jj) & 
     404            !alt                       &           - sqrt(grav * hur_e(2,jj)) * (sshn_e(3,jj) - hbdy_w(jj)) ) 
    627405         END DO 
    628406      ENDIF 
    … …  
    631409         DO jj=1,jpj 
    632410            va_e(nlci-1,jj) = vbdy_e(jj) * hvr_e(nlci-1,jj) 
    633 ! Specified fluxes: 
     411            ! Specified fluxes: 
    634412            ua_e(nlci-2,jj) = ubdy_e(jj) * hur_e(nlci-2,jj) 
    635 ! Characteristics method: 
    636 !alt            ua_e(nlci-2,jj) = 0.5_wp * ( ubdy_e(jj) * hur_e(nlci-2,jj) + ua_e(nlci-3,jj) & 
    637 !alt                            &           + sqrt(grav * hur_e(nlci-2,jj)) * (sshn_e(nlci-2,jj) - hbdy_e(jj)) ) 
     413            ! Characteristics method: 
     414            !alt            ua_e(nlci-2,jj) = 0.5_wp * ( ubdy_e(jj) * hur_e(nlci-2,jj) + ua_e(nlci-3,jj) & 
     415            !alt                            &           + sqrt(grav * hur_e(nlci-2,jj)) * (sshn_e(nlci-2,jj) - hbdy_e(jj)) ) 
    638416         END DO 
    639417      ENDIF 
    … …  
    642420         DO ji=1,jpi 
    643421            ua_e(ji,2) = ubdy_s(ji) * hur_e(ji,2) 
    644 ! Specified fluxes: 
     422            ! Specified fluxes: 
    645423            va_e(ji,2) = vbdy_s(ji) * hvr_e(ji,2) 
    646 ! Characteristics method: 
    647 !alt            va_e(ji,2) = 0.5_wp * ( vbdy_s(ji) * hvr_e(ji,2) + va_e(ji,3) & 
    648 !alt                       &           - sqrt(grav * hvr_e(ji,2)) * (sshn_e(ji,3) - hbdy_s(ji)) ) 
     424            ! Characteristics method: 
     425            !alt            va_e(ji,2) = 0.5_wp * ( vbdy_s(ji) * hvr_e(ji,2) + va_e(ji,3) & 
     426            !alt                       &           - sqrt(grav * hvr_e(ji,2)) * (sshn_e(ji,3) - hbdy_s(ji)) ) 
    649427         END DO 
    650428      ENDIF 
    … …  
    653431         DO ji=1,jpi 
    654432            ua_e(ji,nlcj-1) = ubdy_n(ji) * hur_e(ji,nlcj-1) 
    655 ! Specified fluxes: 
     433            ! Specified fluxes: 
    656434            va_e(ji,nlcj-2) = vbdy_n(ji) * hvr_e(ji,nlcj-2) 
    657 ! Characteristics method: 
    658 !alt            va_e(ji,nlcj-2) = 0.5_wp * ( vbdy_n(ji) * hvr_e(ji,nlcj-2)  + va_e(ji,nlcj-3) & 
    659 !alt                            &           + sqrt(grav * hvr_e(ji,nlcj-2)) * (sshn_e(ji,nlcj-2) - hbdy_n(ji)) ) 
     435            ! Characteristics method: 
     436            !alt            va_e(ji,nlcj-2) = 0.5_wp * ( vbdy_n(ji) * hvr_e(ji,nlcj-2)  + va_e(ji,nlcj-3) & 
     437            !alt                            &           + sqrt(grav * hvr_e(ji,nlcj-2)) * (sshn_e(ji,nlcj-2) - hbdy_n(ji)) ) 
    660438         END DO 
    661439      ENDIF 
    … …  
    672450      INTEGER :: ji, jj 
    673451      LOGICAL :: ll_int_cons 
    674       REAL(wp) :: zrhox, zrhoy, zrhot, zt 
    675       REAL(wp) :: zaa, zab, zat 
    676       REAL(wp) :: zt0, zt1 
    677       REAL(wp), POINTER, DIMENSION(:,:) :: zunb, zvnb, zsshn 
    678       REAL(wp), POINTER, DIMENSION(:,:) :: zuab, zvab, zubb, zvbb, zutn, zvtn 
     452      REAL(wp) :: zrhot, zt 
    679453      !!----------------------------------------------------------------------   
    680454 
    … …  
    682456 
    683457      ll_int_cons = ln_bt_fw ! Assume conservative temporal integration in 
    684                              ! the forward case only 
    685  
    686       zrhox = Agrif_Rhox() 
    687       zrhoy = Agrif_Rhoy() 
     458      ! the forward case only 
     459 
    688460      zrhot = Agrif_rhot() 
    689  
    690       IF ( kt==nit000 ) THEN ! Allocate boundary data arrays 
    691          ALLOCATE( ubdy_w(jpj), vbdy_w(jpj), hbdy_w(jpj)) 
    692          ALLOCATE( ubdy_e(jpj), vbdy_e(jpj), hbdy_e(jpj)) 
    693          ALLOCATE( ubdy_n(jpi), vbdy_n(jpi), hbdy_n(jpi)) 
    694          ALLOCATE( ubdy_s(jpi), vbdy_s(jpi), hbdy_s(jpi)) 
    695       ENDIF 
    696  
    697       CALL wrk_alloc( jpi, jpj, zunb, zvnb, zsshn ) 
    698461 
    699462      ! "Central" time index for interpolation: 
    … …  
    707470      Agrif_SpecialValue    = 0.e0 
    708471      Agrif_UseSpecialValue = .TRUE. 
    709       CALL Agrif_Bc_variable(zsshn, sshn_id,calledweight=zt, procname=interpsshn ) 
     472      CALL Agrif_Bc_variable(sshn_id,calledweight=zt, procname=interpsshn ) 
    710473      Agrif_UseSpecialValue = .FALSE. 
    711474 
    … …  
    715478 
    716479      IF (ll_int_cons) THEN ! Conservative interpolation 
    717          CALL wrk_alloc( jpi, jpj, zuab, zvab, zubb, zvbb, zutn, zvtn ) 
    718          zuab(:,:) = 0._wp ; zvab(:,:) = 0._wp 
    719          zubb(:,:) = 0._wp ; zvbb(:,:) = 0._wp 
    720          zutn(:,:) = 0._wp ; zvtn(:,:) = 0._wp 
    721          CALL Agrif_Bc_variable(zubb,unb_id ,calledweight=0._wp, procname=interpunb) ! Before 
    722          CALL Agrif_Bc_variable(zvbb,vnb_id ,calledweight=0._wp, procname=interpvnb) 
    723          CALL Agrif_Bc_variable(zuab,unb_id ,calledweight=1._wp, procname=interpunb) ! After 
    724          CALL Agrif_Bc_variable(zvab,vnb_id ,calledweight=1._wp, procname=interpvnb) 
    725          CALL Agrif_Bc_variable(zutn,ub2b_id,calledweight=1._wp, procname=interpub2b)! Time integrated 
    726          CALL Agrif_Bc_variable(zvtn,vb2b_id,calledweight=1._wp, procname=interpvb2b) 
    727           
     480         ! orders matters here !!!!!! 
     481         CALL Agrif_Bc_variable(ub2b_interp_id,calledweight=1._wp, procname=interpub2b) ! Time integrated 
     482         CALL Agrif_Bc_variable(vb2b_interp_id,calledweight=1._wp, procname=interpvb2b) 
     483         bdy_tinterp = 1 
     484         CALL Agrif_Bc_variable(unb_id ,calledweight=1._wp, procname=interpunb) ! After 
     485         CALL Agrif_Bc_variable(vnb_id ,calledweight=1._wp, procname=interpvnb) 
     486         bdy_tinterp = 2 
     487         CALL Agrif_Bc_variable(unb_id ,calledweight=0._wp, procname=interpunb) ! Before 
     488         CALL Agrif_Bc_variable(vnb_id ,calledweight=0._wp, procname=interpvnb)          
     489      ELSE ! Linear interpolation 
     490         bdy_tinterp = 0 
     491         ubdy_w(:) = 0.e0 ; vbdy_w(:) = 0.e0  
     492         ubdy_e(:) = 0.e0 ; vbdy_e(:) = 0.e0  
     493         ubdy_n(:) = 0.e0 ; vbdy_n(:) = 0.e0  
     494         ubdy_s(:) = 0.e0 ; vbdy_s(:) = 0.e0  
     495         CALL Agrif_Bc_variable(unb_id,calledweight=zt, procname=interpunb) 
     496         CALL Agrif_Bc_variable(vnb_id,calledweight=zt, procname=interpvnb) 
     497      ENDIF 
     498      Agrif_UseSpecialValue = .FALSE. 
     499      !  
     500   END SUBROUTINE Agrif_dta_ts 
     501 
     502   SUBROUTINE Agrif_ssh( kt ) 
     503      !!---------------------------------------------------------------------- 
     504      !!                  ***  ROUTINE Agrif_DYN  *** 
     505      !!----------------------------------------------------------------------   
     506      INTEGER, INTENT(in) ::   kt 
     507      !! 
     508      !!----------------------------------------------------------------------   
     509 
     510      IF( Agrif_Root() )   RETURN 
     511 
     512      IF((nbondi == -1).OR.(nbondi == 2)) THEN 
     513         ssha(2,:)=ssha(3,:) 
     514         sshn(2,:)=sshn(3,:) 
     515      ENDIF 
     516 
     517      IF((nbondi == 1).OR.(nbondi == 2)) THEN 
     518         ssha(nlci-1,:)=ssha(nlci-2,:) 
     519         sshn(nlci-1,:)=sshn(nlci-2,:) 
     520      ENDIF 
     521 
     522      IF((nbondj == -1).OR.(nbondj == 2)) THEN 
     523         ssha(:,2)=ssha(:,3) 
     524         sshn(:,2)=sshn(:,3) 
     525      ENDIF 
     526 
     527      IF((nbondj == 1).OR.(nbondj == 2)) THEN 
     528         ssha(:,nlcj-1)=ssha(:,nlcj-2) 
     529         sshn(:,nlcj-1)=sshn(:,nlcj-2) 
     530      ENDIF 
     531 
     532   END SUBROUTINE Agrif_ssh 
     533 
     534   SUBROUTINE Agrif_ssh_ts( jn ) 
     535      !!---------------------------------------------------------------------- 
     536      !!                  ***  ROUTINE Agrif_ssh_ts  *** 
     537      !!----------------------------------------------------------------------   
     538      INTEGER, INTENT(in) ::   jn 
     539      !! 
     540      INTEGER :: ji,jj 
     541      !!----------------------------------------------------------------------   
     542 
     543      IF((nbondi == -1).OR.(nbondi == 2)) THEN 
     544         DO jj=1,jpj 
     545            ssha_e(2,jj) = hbdy_w(jj) 
     546         END DO 
     547      ENDIF 
     548 
     549      IF((nbondi == 1).OR.(nbondi == 2)) THEN 
     550         DO jj=1,jpj 
     551            ssha_e(nlci-1,jj) = hbdy_e(jj) 
     552         END DO 
     553      ENDIF 
     554 
     555      IF((nbondj == -1).OR.(nbondj == 2)) THEN 
     556         DO ji=1,jpi 
     557            ssha_e(ji,2) = hbdy_s(ji) 
     558         END DO 
     559      ENDIF 
     560 
     561      IF((nbondj == 1).OR.(nbondj == 2)) THEN 
     562         DO ji=1,jpi 
     563            ssha_e(ji,nlcj-1) = hbdy_n(ji) 
     564         END DO 
     565      ENDIF 
     566 
     567   END SUBROUTINE Agrif_ssh_ts 
     568 
     569# if defined key_zdftke 
     570   SUBROUTINE Agrif_tke 
     571      !!---------------------------------------------------------------------- 
     572      !!                  ***  ROUTINE Agrif_tke  *** 
     573      !!----------------------------------------------------------------------   
     574      REAL(wp) ::   zalpha 
     575      ! 
     576      zalpha = REAL( Agrif_NbStepint() + Agrif_IRhot() - 1, wp ) / REAL( Agrif_IRhot(), wp ) 
     577      IF( zalpha > 1. )   zalpha = 1. 
     578       
     579      Agrif_SpecialValue    = 0.e0 
     580      Agrif_UseSpecialValue = .TRUE. 
     581       
     582      CALL Agrif_Bc_variable(avm_id ,calledweight=zalpha, procname=interpavm)        
     583               
     584      Agrif_UseSpecialValue = .FALSE. 
     585      ! 
     586   END SUBROUTINE Agrif_tke 
     587# endif 
     588 
     589   SUBROUTINE interptsn(ptab,i1,i2,j1,j2,k1,k2,n1,n2,before,nb,ndir) 
     590      !!--------------------------------------------- 
     591      !!   *** ROUTINE interptsn *** 
     592      !!--------------------------------------------- 
     593      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab 
     594      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
     595      LOGICAL, INTENT(in) :: before 
     596      INTEGER, INTENT(in) :: nb , ndir 
     597      ! 
     598      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
     599      INTEGER :: imin, imax, jmin, jmax 
     600      REAL(wp) ::   zrhox , zalpha1, zalpha2, zalpha3 
     601      REAL(wp) ::   zalpha4, zalpha5, zalpha6, zalpha7 
     602      LOGICAL :: western_side, eastern_side,northern_side,southern_side 
     603 
     604      IF (before) THEN          
     605         ptab(i1:i2,j1:j2,k1:k2,n1:n2) = tsn(i1:i2,j1:j2,k1:k2,n1:n2) 
     606      ELSE 
     607         ! 
     608         western_side  = (nb == 1).AND.(ndir == 1) 
     609         eastern_side  = (nb == 1).AND.(ndir == 2) 
     610         southern_side = (nb == 2).AND.(ndir == 1) 
     611         northern_side = (nb == 2).AND.(ndir == 2) 
     612         ! 
     613         zrhox = Agrif_Rhox() 
     614         !  
     615         zalpha1 = ( zrhox - 1. ) * 0.5 
     616         zalpha2 = 1. - zalpha1 
     617         !  
     618         zalpha3 = ( zrhox - 1. ) / ( zrhox + 1. ) 
     619         zalpha4 = 1. - zalpha3 
     620         !  
     621         zalpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 
     622         zalpha7 =    - ( zrhox - 1. ) / ( zrhox + 3. ) 
     623         zalpha5 = 1. - zalpha6 - zalpha7 
     624         ! 
     625         imin = i1 
     626         imax = i2 
     627         jmin = j1 
     628         jmax = j2 
     629         !  
     630         ! Remove CORNERS 
     631         IF((nbondj == -1).OR.(nbondj == 2)) jmin = 3 
     632         IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj-2 
     633         IF((nbondi == -1).OR.(nbondi == 2)) imin = 3 
     634         IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci-2         
     635         ! 
     636         IF( eastern_side) THEN 
     637            DO jn = 1, jpts 
     638               tsa(nlci,j1:j2,k1:k2,jn) = zalpha1 * ptab(nlci,j1:j2,k1:k2,jn) + zalpha2 * ptab(nlci-1,j1:j2,k1:k2,jn) 
     639               DO jk = 1, jpkm1 
     640                  DO jj = jmin,jmax 
     641                     IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN 
     642                        tsa(nlci-1,jj,jk,jn) = tsa(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 
     643                     ELSE 
     644                        tsa(nlci-1,jj,jk,jn)=(zalpha4*tsa(nlci,jj,jk,jn)+zalpha3*tsa(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 
     645                        IF( un(nlci-2,jj,jk) > 0.e0 ) THEN 
     646                           tsa(nlci-1,jj,jk,jn)=( zalpha6*tsa(nlci-2,jj,jk,jn)+zalpha5*tsa(nlci,jj,jk,jn) &  
     647                                 + zalpha7*tsa(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 
     648                        ENDIF 
     649                     ENDIF 
     650                  END DO 
     651               END DO 
     652               tsa(nlci,j1:j2,k1:k2,jn) = 0._wp 
     653            ENDDO 
     654         ENDIF 
     655         !  
     656         IF( northern_side ) THEN             
     657            DO jn = 1, jpts 
     658               tsa(i1:i2,nlcj,k1:k2,jn) = zalpha1 * ptab(i1:i2,nlcj,k1:k2,jn) + zalpha2 * ptab(i1:i2,nlcj-1,k1:k2,jn) 
     659               DO jk = 1, jpkm1 
     660                  DO ji = imin,imax 
     661                     IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN 
     662                        tsa(ji,nlcj-1,jk,jn) = tsa(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 
     663                     ELSE 
     664                        tsa(ji,nlcj-1,jk,jn)=(zalpha4*tsa(ji,nlcj,jk,jn)+zalpha3*tsa(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk)         
     665                        IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN 
     666                           tsa(ji,nlcj-1,jk,jn)=( zalpha6*tsa(ji,nlcj-2,jk,jn)+zalpha5*tsa(ji,nlcj,jk,jn)  & 
     667                                 + zalpha7*tsa(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 
     668                        ENDIF 
     669                     ENDIF 
     670                  END DO 
     671               END DO 
     672               tsa(i1:i2,nlcj,k1:k2,jn) = 0._wp 
     673            ENDDO 
     674         ENDIF 
     675         ! 
     676         IF( western_side) THEN             
     677            DO jn = 1, jpts 
     678               tsa(1,j1:j2,k1:k2,jn) = zalpha1 * ptab(1,j1:j2,k1:k2,jn) + zalpha2 * ptab(2,j1:j2,k1:k2,jn) 
     679               DO jk = 1, jpkm1 
     680                  DO jj = jmin,jmax 
     681                     IF( umask(2,jj,jk) == 0.e0 ) THEN 
     682                        tsa(2,jj,jk,jn) = tsa(1,jj,jk,jn) * tmask(2,jj,jk) 
     683                     ELSE 
     684                        tsa(2,jj,jk,jn)=(zalpha4*tsa(1,jj,jk,jn)+zalpha3*tsa(3,jj,jk,jn))*tmask(2,jj,jk)         
     685                        IF( un(2,jj,jk) < 0.e0 ) THEN 
     686                           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) 
     687                        ENDIF 
     688                     ENDIF 
     689                  END DO 
     690               END DO 
     691               tsa(1,j1:j2,k1:k2,jn) = 0._wp 
     692            END DO 
     693         ENDIF 
     694         ! 
     695         IF( southern_side ) THEN            
     696            DO jn = 1, jpts 
     697               tsa(i1:i2,1,k1:k2,jn) = zalpha1 * ptab(i1:i2,1,k1:k2,jn) + zalpha2 * ptab(i1:i2,2,k1:k2,jn) 
     698               DO jk=1,jpk       
     699                  DO ji=imin,imax 
     700                     IF( vmask(ji,2,jk) == 0.e0 ) THEN 
     701                        tsa(ji,2,jk,jn)=tsa(ji,1,jk,jn) * tmask(ji,2,jk) 
     702                     ELSE 
     703                        tsa(ji,2,jk,jn)=(zalpha4*tsa(ji,1,jk,jn)+zalpha3*tsa(ji,3,jk,jn))*tmask(ji,2,jk) 
     704                        IF( vn(ji,2,jk) < 0.e0 ) THEN 
     705                           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) 
     706                        ENDIF 
     707                     ENDIF 
     708                  END DO 
     709               END DO 
     710               tsa(i1:i2,1,k1:k2,jn) = 0._wp 
     711            ENDDO 
     712         ENDIF 
     713         ! 
     714         ! Treatment of corners 
     715         !  
     716         ! East south 
     717         IF ((eastern_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 
     718            tsa(nlci-1,2,:,:) = ptab(nlci-1,2,:,:) 
     719         ENDIF 
     720         ! East north 
     721         IF ((eastern_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 
     722            tsa(nlci-1,nlcj-1,:,:) = ptab(nlci-1,nlcj-1,:,:) 
     723         ENDIF 
     724         ! West south 
     725         IF ((western_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 
     726            tsa(2,2,:,:) = ptab(2,2,:,:) 
     727         ENDIF 
     728         ! West north 
     729         IF ((western_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 
     730            tsa(2,nlcj-1,:,:) = ptab(2,nlcj-1,:,:) 
     731         ENDIF 
     732         ! 
     733      ENDIF 
     734      ! 
     735   END SUBROUTINE interptsn 
     736 
     737   SUBROUTINE interpsshn(ptab,i1,i2,j1,j2,before,nb,ndir) 
     738      !!---------------------------------------------------------------------- 
     739      !!                  ***  ROUTINE interpsshn  *** 
     740      !!----------------------------------------------------------------------   
     741      INTEGER, INTENT(in) :: i1,i2,j1,j2 
     742      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 
     743      LOGICAL, INTENT(in) :: before 
     744      INTEGER, INTENT(in) :: nb , ndir 
     745      LOGICAL :: western_side, eastern_side,northern_side,southern_side 
     746      !!----------------------------------------------------------------------   
     747      ! 
     748      IF( before) THEN 
     749         ptab(i1:i2,j1:j2) = sshn(i1:i2,j1:j2) 
     750      ELSE 
     751         western_side  = (nb == 1).AND.(ndir == 1) 
     752         eastern_side  = (nb == 1).AND.(ndir == 2) 
     753         southern_side = (nb == 2).AND.(ndir == 1) 
     754         northern_side = (nb == 2).AND.(ndir == 2) 
     755         IF(western_side)  hbdy_w(j1:j2) = ptab(i1,j1:j2) * tmask(i1,j1:j2,1) 
     756         IF(eastern_side)  hbdy_e(j1:j2) = ptab(i1,j1:j2) * tmask(i1,j1:j2,1) 
     757         IF(southern_side) hbdy_s(i1:i2) = ptab(i1:i2,j1) * tmask(i1:i2,j1,1) 
     758         IF(northern_side) hbdy_n(i1:i2) = ptab(i1:i2,j1) * tmask(i1:i2,j1,1) 
     759      ENDIF 
     760      ! 
     761   END SUBROUTINE interpsshn 
     762 
     763   SUBROUTINE interpun(ptab,i1,i2,j1,j2,k1,k2, before) 
     764      !!--------------------------------------------- 
     765      !!   *** ROUTINE interpun *** 
     766      !!---------------------------------------------     
     767      !! 
     768      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
     769      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     770      LOGICAL, INTENT(in) :: before 
     771      !! 
     772      INTEGER :: ji,jj,jk 
     773      REAL(wp) :: zrhoy  
     774      !!---------------------------------------------     
     775      ! 
     776      IF (before) THEN  
     777         DO jk=1,jpk 
     778            DO jj=j1,j2 
     779               DO ji=i1,i2 
     780                  ptab(ji,jj,jk) = e2u(ji,jj) * un(ji,jj,jk) 
     781                  ptab(ji,jj,jk) = ptab(ji,jj,jk) * fse3u(ji,jj,jk) 
     782               END DO 
     783            END DO 
     784         END DO 
     785      ELSE 
     786         zrhoy = Agrif_Rhoy() 
     787         DO jk=1,jpkm1 
     788            DO jj=j1,j2 
     789               ua(i1:i2,jj,jk) = (ptab(i1:i2,jj,jk)/(zrhoy*e2u(i1:i2,jj))) 
     790               ua(i1:i2,jj,jk) = ua(i1:i2,jj,jk) / fse3u(i1:i2,jj,jk) 
     791            END DO 
     792         END DO 
     793      ENDIF 
     794      !  
     795   END SUBROUTINE interpun 
     796 
     797   SUBROUTINE interpvn(ptab,i1,i2,j1,j2,k1,k2, before) 
     798      !!--------------------------------------------- 
     799      !!   *** ROUTINE interpvn *** 
     800      !!---------------------------------------------     
     801      ! 
     802      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
     803      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     804      LOGICAL, INTENT(in) :: before 
     805      ! 
     806      INTEGER :: ji,jj,jk 
     807      REAL(wp) :: zrhox  
     808      !!---------------------------------------------     
     809      !       
     810      IF (before) THEN           
     811         !interpv entre 1 et k2 et interpv2d en jpkp1 
     812         DO jk=k1,jpk 
     813            DO jj=j1,j2 
     814               DO ji=i1,i2 
     815                  ptab(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk) 
     816                  ptab(ji,jj,jk) = ptab(ji,jj,jk) * fse3v(ji,jj,jk) 
     817               END DO 
     818            END DO 
     819         END DO 
     820      ELSE           
     821         zrhox= Agrif_Rhox() 
     822         DO jk=1,jpkm1 
     823            DO jj=j1,j2 
     824               va(i1:i2,jj,jk) = (ptab(i1:i2,jj,jk)/(zrhox*e1v(i1:i2,jj))) 
     825               va(i1:i2,jj,jk) = va(i1:i2,jj,jk) / fse3v(i1:i2,jj,jk) 
     826            END DO 
     827         END DO 
     828      ENDIF 
     829      !         
     830   END SUBROUTINE interpvn 
     831 
     832   SUBROUTINE interpunb(ptab,i1,i2,j1,j2,before,nb,ndir) 
     833      !!---------------------------------------------------------------------- 
     834      !!                  ***  ROUTINE interpunb  *** 
     835      !!----------------------------------------------------------------------   
     836      INTEGER, INTENT(in) :: i1,i2,j1,j2 
     837      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 
     838      LOGICAL, INTENT(in) :: before 
     839      INTEGER, INTENT(in) :: nb , ndir 
     840      !! 
     841      INTEGER :: ji,jj 
     842      REAL(wp) :: zrhoy, zrhot, zt0, zt1, ztcoeff 
     843      LOGICAL :: western_side, eastern_side,northern_side,southern_side 
     844      !!----------------------------------------------------------------------   
     845      ! 
     846      IF (before) THEN  
     847         DO jj=j1,j2 
     848            DO ji=i1,i2 
     849               ptab(ji,jj) = un_b(ji,jj) * e2u(ji,jj) * hu(ji,jj)  
     850            END DO 
     851         END DO 
     852      ELSE 
     853         western_side  = (nb == 1).AND.(ndir == 1) 
     854         eastern_side  = (nb == 1).AND.(ndir == 2) 
     855         southern_side = (nb == 2).AND.(ndir == 1) 
     856         northern_side = (nb == 2).AND.(ndir == 2) 
     857         zrhoy = Agrif_Rhoy() 
     858         zrhot = Agrif_rhot() 
     859         ! Time indexes bounds for integration 
     860         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot 
     861         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot       
     862         ! Polynomial interpolation coefficients: 
     863         IF( bdy_tinterp == 1 ) THEN 
     864            ztcoeff = zrhot * (  zt1**2._wp * (       zt1 - 1._wp)        & 
     865                  &      - zt0**2._wp * (       zt0 - 1._wp)        ) 
     866         ELSEIF( bdy_tinterp == 2 ) THEN 
     867            ztcoeff = zrhot * (  zt1        * (       zt1 - 1._wp)**2._wp & 
     868                  &      - zt0        * (       zt0 - 1._wp)**2._wp )  
     869 
     870         ELSE 
     871            ztcoeff = 1 
     872         ENDIF 
     873         !    
     874         IF(western_side) THEN 
     875            ubdy_w(j1:j2) = ubdy_w(j1:j2) + ztcoeff * ptab(i1,j1:j2)   
     876         ENDIF 
     877         IF(eastern_side) THEN 
     878            ubdy_e(j1:j2) = ubdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2)   
     879         ENDIF 
     880         IF(southern_side) THEN 
     881            ubdy_s(i1:i2) = ubdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j1)  
     882         ENDIF 
     883         IF(northern_side) THEN 
     884            ubdy_n(i1:i2) = ubdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1)  
     885         ENDIF 
     886         !             
     887         IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN 
     888            IF(western_side) THEN 
     889               ubdy_w(j1:j2) = ubdy_w(j1:j2) / (zrhoy*e2u(i1,j1:j2))   & 
     890                     &                                  * umask(i1,j1:j2,1) 
     891            ENDIF 
     892            IF(eastern_side) THEN 
     893               ubdy_e(j1:j2) = ubdy_e(j1:j2) / (zrhoy*e2u(i1,j1:j2))   & 
     894                     &                                  * umask(i1,j1:j2,1) 
     895            ENDIF 
     896            IF(southern_side) THEN 
     897               ubdy_s(i1:i2) = ubdy_s(i1:i2) / (zrhoy*e2u(i1:i2,j1))   & 
     898                     &                                  * umask(i1:i2,j1,1) 
     899            ENDIF 
     900            IF(northern_side) THEN 
     901               ubdy_n(i1:i2) = ubdy_n(i1:i2) / (zrhoy*e2u(i1:i2,j1))   & 
     902                     &                                  * umask(i1:i2,j1,1) 
     903            ENDIF 
     904         ENDIF 
     905      ENDIF 
     906      !  
     907   END SUBROUTINE interpunb 
     908 
     909   SUBROUTINE interpvnb(ptab,i1,i2,j1,j2,before,nb,ndir) 
     910      !!---------------------------------------------------------------------- 
     911      !!                  ***  ROUTINE interpvnb  *** 
     912      !!----------------------------------------------------------------------   
     913      INTEGER, INTENT(in) :: i1,i2,j1,j2 
     914      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 
     915      LOGICAL, INTENT(in) :: before 
     916      INTEGER, INTENT(in) :: nb , ndir 
     917      !! 
     918      INTEGER :: ji,jj 
     919      REAL(wp) :: zrhox, zrhot, zt0, zt1, ztcoeff    
     920      LOGICAL :: western_side, eastern_side,northern_side,southern_side 
     921      !!----------------------------------------------------------------------   
     922      !  
     923      IF (before) THEN  
     924         DO jj=j1,j2 
     925            DO ji=i1,i2 
     926               ptab(ji,jj) = vn_b(ji,jj) * e1v(ji,jj) * hv(ji,jj)  
     927            END DO 
     928         END DO 
     929      ELSE 
     930         western_side  = (nb == 1).AND.(ndir == 1) 
     931         eastern_side  = (nb == 1).AND.(ndir == 2) 
     932         southern_side = (nb == 2).AND.(ndir == 1) 
     933         northern_side = (nb == 2).AND.(ndir == 2) 
     934         zrhox = Agrif_Rhox() 
     935         zrhot = Agrif_rhot() 
     936         ! Time indexes bounds for integration 
     937         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot 
     938         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot       
     939         IF( bdy_tinterp == 1 ) THEN 
     940            ztcoeff = zrhot * (  zt1**2._wp * (       zt1 - 1._wp)        & 
     941                  &      - zt0**2._wp * (       zt0 - 1._wp)        ) 
     942         ELSEIF( bdy_tinterp == 2 ) THEN 
     943            ztcoeff = zrhot * (  zt1        * (       zt1 - 1._wp)**2._wp & 
     944                  &      - zt0        * (       zt0 - 1._wp)**2._wp )  
     945 
     946         ELSE 
     947            ztcoeff = 1 
     948         ENDIF 
     949         ! 
     950         IF(western_side) THEN 
     951            vbdy_w(j1:j2) = vbdy_w(j1:j2) + ztcoeff * ptab(i1,j1:j2)   
     952         ENDIF 
     953         IF(eastern_side) THEN 
     954            vbdy_e(j1:j2) = vbdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2)   
     955         ENDIF 
     956         IF(southern_side) THEN 
     957            vbdy_s(i1:i2) = vbdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j1) 
     958         ENDIF 
     959         IF(northern_side) THEN 
     960            vbdy_n(i1:i2) = vbdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1)  
     961         ENDIF 
     962         !             
     963         IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN 
     964            IF(western_side) THEN 
     965               vbdy_w(j1:j2) = vbdy_w(j1:j2) / (zrhox*e1v(i1,j1:j2))   & 
     966                     &                                  * vmask(i1,j1:j2,1) 
     967            ENDIF 
     968            IF(eastern_side) THEN 
     969               vbdy_e(j1:j2) = vbdy_e(j1:j2) / (zrhox*e1v(i1,j1:j2))   & 
     970                     &                                  * vmask(i1,j1:j2,1) 
     971            ENDIF 
     972            IF(southern_side) THEN 
     973               vbdy_s(i1:i2) = vbdy_s(i1:i2) / (zrhox*e1v(i1:i2,j1))   & 
     974                     &                                  * vmask(i1:i2,j1,1) 
     975            ENDIF 
     976            IF(northern_side) THEN 
     977               vbdy_n(i1:i2) = vbdy_n(i1:i2) / (zrhox*e1v(i1:i2,j1))   & 
     978                     &                                  * vmask(i1:i2,j1,1) 
     979            ENDIF 
     980         ENDIF 
     981      ENDIF 
     982      ! 
     983   END SUBROUTINE interpvnb 
     984 
     985   SUBROUTINE interpub2b(ptab,i1,i2,j1,j2,before,nb,ndir) 
     986      !!---------------------------------------------------------------------- 
     987      !!                  ***  ROUTINE interpub2b  *** 
     988      !!----------------------------------------------------------------------   
     989      INTEGER, INTENT(in) :: i1,i2,j1,j2 
     990      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 
     991      LOGICAL, INTENT(in) :: before 
     992      INTEGER, INTENT(in) :: nb , ndir 
     993      !! 
     994      INTEGER :: ji,jj 
     995      REAL(wp) :: zrhot, zt0, zt1,zat 
     996      LOGICAL :: western_side, eastern_side,northern_side,southern_side 
     997      !!----------------------------------------------------------------------   
     998      IF( before ) THEN 
     999         DO jj=j1,j2 
     1000            DO ji=i1,i2 
     1001               ptab(ji,jj) = ub2_b(ji,jj) * e2u(ji,jj) 
     1002            END DO 
     1003         END DO 
     1004      ELSE 
     1005         western_side  = (nb == 1).AND.(ndir == 1) 
     1006         eastern_side  = (nb == 1).AND.(ndir == 2) 
     1007         southern_side = (nb == 2).AND.(ndir == 1) 
     1008         northern_side = (nb == 2).AND.(ndir == 2) 
     1009         zrhot = Agrif_rhot() 
    7281010         ! Time indexes bounds for integration 
    7291011         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot 
    7301012         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot 
    731  
    7321013         ! Polynomial interpolation coefficients: 
    733          zaa = zrhot * (  zt1**2._wp * (       zt1 - 1._wp)        & 
    734                  &      - zt0**2._wp * (       zt0 - 1._wp)        ) 
    735          zab = zrhot * (  zt1        * (       zt1 - 1._wp)**2._wp & 
    736                  &      - zt0        * (       zt0 - 1._wp)**2._wp ) 
    7371014         zat = zrhot * (  zt1**2._wp * (-2._wp*zt1 + 3._wp)        & 
    738                  &      - zt0**2._wp * (-2._wp*zt0 + 3._wp)        )  
    739  
    740          ! Do time interpolation 
    741          IF((nbondi == -1).OR.(nbondi == 2)) THEN 
    742             DO jj=1,jpj 
    743                zunb(2,jj) = zaa * zuab(2,jj) + zab * zubb(2,jj) + zat * zutn(2,jj) 
    744                zvnb(2,jj) = zaa * zvab(2,jj) + zab * zvbb(2,jj) + zat * zvtn(2,jj) 
    745             END DO 
    746          ENDIF 
    747          IF((nbondi == 1).OR.(nbondi == 2)) THEN 
    748             DO jj=1,jpj 
    749                zunb(nlci-2,jj) = zaa * zuab(nlci-2,jj) + zab * zubb(nlci-2,jj) + zat * zutn(nlci-2,jj) 
    750                zvnb(nlci-1,jj) = zaa * zvab(nlci-1,jj) + zab * zvbb(nlci-1,jj) + zat * zvtn(nlci-1,jj) 
    751             END DO 
    752          ENDIF 
    753          IF((nbondj == -1).OR.(nbondj == 2)) THEN 
    754             DO ji=1,jpi 
    755                zunb(ji,2) = zaa * zuab(ji,2) + zab * zubb(ji,2) + zat * zutn(ji,2) 
    756                zvnb(ji,2) = zaa * zvab(ji,2) + zab * zvbb(ji,2) + zat * zvtn(ji,2) 
    757             END DO 
    758          ENDIF 
    759          IF((nbondj == 1).OR.(nbondj == 2)) THEN 
    760             DO ji=1,jpi 
    761                zunb(ji,nlcj-1) = zaa * zuab(ji,nlcj-1) + zab * zubb(ji,nlcj-1) + zat * zutn(ji,nlcj-1) 
    762                zvnb(ji,nlcj-2) = zaa * zvab(ji,nlcj-2) + zab * zvbb(ji,nlcj-2) + zat * zvtn(ji,nlcj-2) 
    763             END DO 
    764          ENDIF 
    765          CALL wrk_dealloc( jpi, jpj, zuab, zvab, zubb, zvbb, zutn, zvtn ) 
    766  
    767       ELSE ! Linear interpolation 
    768          zunb(:,:) = 0._wp ; zvnb(:,:) = 0._wp 
    769          CALL Agrif_Bc_variable(zunb,unb_id,calledweight=zt, procname=interpunb) 
    770          CALL Agrif_Bc_variable(zvnb,vnb_id,calledweight=zt, procname=interpvnb) 
    771       ENDIF 
    772       Agrif_UseSpecialValue = .FALSE. 
    773  
    774       ! Fill boundary data arrays: 
    775       IF((nbondi == -1).OR.(nbondi == 2)) THEN 
    776          DO jj=1,jpj 
    777                ubdy_w(jj) = (zunb(2,jj)/(zrhoy*e2u(2,jj))) * umask(2,jj,1) 
    778                vbdy_w(jj) = (zvnb(2,jj)/(zrhox*e1v(2,jj))) * vmask(2,jj,1) 
    779                hbdy_w(jj) = zsshn(2,jj) * tmask(2,jj,1) 
    780          END DO 
    781       ENDIF 
    782  
    783       IF((nbondi == 1).OR.(nbondi == 2)) THEN 
    784          DO jj=1,jpj 
    785                ubdy_e(jj) = zunb(nlci-2,jj)/(zrhoy*e2u(nlci-2,jj)) * umask(nlci-2,jj,1) 
    786                vbdy_e(jj) = zvnb(nlci-1,jj)/(zrhox*e1v(nlci-1,jj)) * vmask(nlci-1,jj,1) 
    787                hbdy_e(jj) = zsshn(nlci-1,jj) * tmask(nlci-1,jj,1) 
    788          END DO 
    789       ENDIF 
    790  
    791       IF((nbondj == -1).OR.(nbondj == 2)) THEN 
    792          DO ji=1,jpi 
    793                ubdy_s(ji) = zunb(ji,2)/(zrhoy*e2u(ji,2)) * umask(ji,2,1) 
    794                vbdy_s(ji) = zvnb(ji,2)/(zrhox*e1v(ji,2)) * vmask(ji,2,1) 
    795                hbdy_s(ji) = zsshn(ji,2) * tmask(ji,2,1) 
    796          END DO 
    797       ENDIF 
    798  
    799       IF((nbondj == 1).OR.(nbondj == 2)) THEN 
    800          DO ji=1,jpi 
    801             ubdy_n(ji) = zunb(ji,nlcj-1)/(zrhoy*e2u(ji,nlcj-1)) * umask(ji,nlcj-1,1) 
    802             vbdy_n(ji) = zvnb(ji,nlcj-2)/(zrhox*e1v(ji,nlcj-2)) * vmask(ji,nlcj-2,1) 
    803             hbdy_n(ji) = zsshn(ji,nlcj-1) * tmask(ji,nlcj-1,1) 
    804          END DO 
    805       ENDIF 
    806  
    807       CALL wrk_dealloc( jpi, jpj, zunb, zvnb, zsshn ) 
    808  
    809    END SUBROUTINE Agrif_dta_ts 
    810  
    811    SUBROUTINE Agrif_ssh( kt ) 
    812       !!---------------------------------------------------------------------- 
    813       !!                  ***  ROUTINE Agrif_DYN  *** 
    814       !!----------------------------------------------------------------------   
    815       INTEGER, INTENT(in) ::   kt 
    816       !! 
    817       !!----------------------------------------------------------------------   
    818  
    819       IF( Agrif_Root() )   RETURN 
    820  
    821  
    822       IF((nbondi == -1).OR.(nbondi == 2)) THEN 
    823          ssha(2,:)=ssha(3,:) 
    824          sshn(2,:)=sshn(3,:) 
    825       ENDIF 
    826  
    827       IF((nbondi == 1).OR.(nbondi == 2)) THEN 
    828          ssha(nlci-1,:)=ssha(nlci-2,:) 
    829          sshn(nlci-1,:)=sshn(nlci-2,:)         
    830       ENDIF 
    831  
    832       IF((nbondj == -1).OR.(nbondj == 2)) THEN 
    833          ssha(:,2)=ssha(:,3) 
    834          sshn(:,2)=sshn(:,3) 
    835       ENDIF 
    836  
    837       IF((nbondj == 1).OR.(nbondj == 2)) THEN 
    838          ssha(:,nlcj-1)=ssha(:,nlcj-2) 
    839          sshn(:,nlcj-1)=sshn(:,nlcj-2)                 
    840       ENDIF 
    841  
    842    END SUBROUTINE Agrif_ssh 
    843  
    844    SUBROUTINE Agrif_ssh_ts( jn ) 
    845       !!---------------------------------------------------------------------- 
    846       !!                  ***  ROUTINE Agrif_ssh_ts  *** 
    847       !!----------------------------------------------------------------------   
    848       INTEGER, INTENT(in) ::   jn 
     1015               &      - zt0**2._wp * (-2._wp*zt0 + 3._wp)        )  
     1016         !  
     1017         IF(western_side ) ubdy_w(j1:j2) = zat * ptab(i1,j1:j2)   
     1018         IF(eastern_side ) ubdy_e(j1:j2) = zat * ptab(i1,j1:j2)   
     1019         IF(southern_side) ubdy_s(i1:i2) = zat * ptab(i1:i2,j1)  
     1020         IF(northern_side) ubdy_n(i1:i2) = zat * ptab(i1:i2,j1)  
     1021      ENDIF 
     1022      !  
     1023   END SUBROUTINE interpub2b 
     1024 
     1025   SUBROUTINE interpvb2b(ptab,i1,i2,j1,j2,before,nb,ndir) 
     1026      !!---------------------------------------------------------------------- 
     1027      !!                  ***  ROUTINE interpvb2b  *** 
     1028      !!----------------------------------------------------------------------   
     1029      INTEGER, INTENT(in) :: i1,i2,j1,j2 
     1030      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 
     1031      LOGICAL, INTENT(in) :: before 
     1032      INTEGER, INTENT(in) :: nb , ndir 
    8491033      !! 
    8501034      INTEGER :: ji,jj 
    851       !!----------------------------------------------------------------------   
    852  
    853       IF((nbondi == -1).OR.(nbondi == 2)) THEN 
    854          DO jj=1,jpj 
    855             ssha_e(2,jj) = hbdy_w(jj) 
    856          END DO 
    857       ENDIF 
    858  
    859       IF((nbondi == 1).OR.(nbondi == 2)) THEN 
    860          DO jj=1,jpj 
    861             ssha_e(nlci-1,jj) = hbdy_e(jj) 
    862          END DO 
    863       ENDIF 
    864  
    865       IF((nbondj == -1).OR.(nbondj == 2)) THEN 
    866          DO ji=1,jpi 
    867             ssha_e(ji,2) = hbdy_s(ji) 
    868          END DO 
    869       ENDIF 
    870  
    871       IF((nbondj == 1).OR.(nbondj == 2)) THEN 
    872          DO ji=1,jpi 
    873             ssha_e(ji,nlcj-1) = hbdy_n(ji) 
    874          END DO 
    875       ENDIF 
    876  
    877    END SUBROUTINE Agrif_ssh_ts 
    878  
    879    SUBROUTINE interpsshn(tabres,i1,i2,j1,j2) 
    880       !!---------------------------------------------------------------------- 
    881       !!                  ***  ROUTINE interpsshn  *** 
    882       !!----------------------------------------------------------------------   
    883       INTEGER, INTENT(in) :: i1,i2,j1,j2 
    884       REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    885       !! 
    886       INTEGER :: ji,jj 
    887       !!----------------------------------------------------------------------   
    888  
    889       tabres(i1:i2,j1:j2) = sshn(i1:i2,j1:j2) 
    890  
    891    END SUBROUTINE interpsshn 
    892  
    893    SUBROUTINE interpu(tabres,i1,i2,j1,j2,k1,k2) 
    894       !!---------------------------------------------------------------------- 
    895       !!                  ***  ROUTINE interpu  *** 
    896       !!----------------------------------------------------------------------   
    897       INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
    898       REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 
    899       !! 
    900       INTEGER :: ji,jj,jk 
    901       !!----------------------------------------------------------------------   
    902  
    903       DO jk=k1,k2 
     1035      REAL(wp) :: zrhot, zt0, zt1,zat 
     1036      LOGICAL :: western_side, eastern_side,northern_side,southern_side 
     1037      !!----------------------------------------------------------------------   
     1038      ! 
     1039      IF( before ) THEN 
    9041040         DO jj=j1,j2 
    9051041            DO ji=i1,i2 
    906                tabres(ji,jj,jk) = e2u(ji,jj) * un(ji,jj,jk) 
    907                tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3u_n(ji,jj,jk) 
    908             END DO 
    909          END DO 
    910       END DO 
    911    END SUBROUTINE interpu 
    912  
    913  
    914    SUBROUTINE interpu2d(tabres,i1,i2,j1,j2) 
    915       !!---------------------------------------------------------------------- 
    916       !!                  ***  ROUTINE interpu2d  *** 
    917       !!----------------------------------------------------------------------   
    918       INTEGER, INTENT(in) :: i1,i2,j1,j2 
    919       REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    920       !! 
    921       INTEGER :: ji,jj 
    922       !!----------------------------------------------------------------------   
    923  
    924       DO jj=j1,j2 
    925          DO ji=i1,i2 
    926             tabres(ji,jj) = e2u(ji,jj) * ((gcx(ji+1,jj) - gcx(ji,jj))/e1u(ji,jj)) & 
    927                * umask(ji,jj,1) 
    928          END DO 
    929       END DO 
    930  
    931    END SUBROUTINE interpu2d 
    932  
    933  
    934    SUBROUTINE interpv(tabres,i1,i2,j1,j2,k1,k2) 
    935       !!---------------------------------------------------------------------- 
    936       !!                  ***  ROUTINE interpv  *** 
    937       !!----------------------------------------------------------------------   
     1042               ptab(ji,jj) = vb2_b(ji,jj) * e1v(ji,jj) 
     1043            END DO 
     1044         END DO 
     1045      ELSE       
     1046         western_side  = (nb == 1).AND.(ndir == 1) 
     1047         eastern_side  = (nb == 1).AND.(ndir == 2) 
     1048         southern_side = (nb == 2).AND.(ndir == 1) 
     1049         northern_side = (nb == 2).AND.(ndir == 2) 
     1050         zrhot = Agrif_rhot() 
     1051         ! Time indexes bounds for integration 
     1052         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot 
     1053         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot 
     1054         ! Polynomial interpolation coefficients: 
     1055         zat = zrhot * (  zt1**2._wp * (-2._wp*zt1 + 3._wp)        & 
     1056               &      - zt0**2._wp * (-2._wp*zt0 + 3._wp)        )  
     1057         ! 
     1058         IF(western_side ) vbdy_w(j1:j2) = zat * ptab(i1,j1:j2)   
     1059         IF(eastern_side ) vbdy_e(j1:j2) = zat * ptab(i1,j1:j2)   
     1060         IF(southern_side) vbdy_s(i1:i2) = zat * ptab(i1:i2,j1)  
     1061         IF(northern_side) vbdy_n(i1:i2) = zat * ptab(i1:i2,j1)  
     1062      ENDIF 
     1063      !       
     1064   END SUBROUTINE interpvb2b 
     1065 
     1066   SUBROUTINE interpe3t(ptab,i1,i2,j1,j2,k1,k2,before,nb,ndir) 
     1067      !!---------------------------------------------------------------------- 
     1068      !!                  ***  ROUTINE interpe3t  *** 
     1069      !!----------------------------------------------------------------------   
     1070      !  
    9381071      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
    939       REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 
    940       !! 
     1072      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     1073      LOGICAL :: before 
     1074      INTEGER, INTENT(in) :: nb , ndir 
     1075      ! 
    9411076      INTEGER :: ji, jj, jk 
    942       !!----------------------------------------------------------------------   
    943  
    944       DO jk=k1,k2 
    945          DO jj=j1,j2 
    946             DO ji=i1,i2 
    947                tabres(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk) 
    948                tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3v_n(ji,jj,jk) 
    949             END DO 
    950          END DO 
    951       END DO 
    952  
    953    END SUBROUTINE interpv 
    954  
    955  
    956    SUBROUTINE interpv2d(tabres,i1,i2,j1,j2) 
    957       !!---------------------------------------------------------------------- 
    958       !!                  ***  ROUTINE interpu2d  *** 
    959       !!----------------------------------------------------------------------   
    960       INTEGER, INTENT(in) :: i1,i2,j1,j2 
    961       REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    962       !! 
    963       INTEGER :: ji,jj 
    964       !!----------------------------------------------------------------------   
    965  
    966       DO jj=j1,j2 
    967          DO ji=i1,i2 
    968             tabres(ji,jj) = e1v(ji,jj) * ((gcx(ji,jj+1) - gcx(ji,jj))/e2v(ji,jj)) & 
    969                * vmask(ji,jj,1) 
    970          END DO 
    971       END DO 
    972  
    973    END SUBROUTINE interpv2d 
    974  
    975    SUBROUTINE interpunb(tabres,i1,i2,j1,j2) 
    976       !!---------------------------------------------------------------------- 
    977       !!                  ***  ROUTINE interpunb  *** 
    978       !!----------------------------------------------------------------------   
    979       INTEGER, INTENT(in) :: i1,i2,j1,j2 
    980       REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    981       !! 
    982       INTEGER :: ji,jj 
    983       !!----------------------------------------------------------------------   
    984  
    985       DO jj=j1,j2 
    986          DO ji=i1,i2 
    987             tabres(ji,jj) = un_b(ji,jj) * e2u(ji,jj) * hu(ji,jj)  
    988          END DO 
    989       END DO 
    990  
    991    END SUBROUTINE interpunb 
    992  
    993    SUBROUTINE interpvnb(tabres,i1,i2,j1,j2) 
    994       !!---------------------------------------------------------------------- 
    995       !!                  ***  ROUTINE interpvnb  *** 
    996       !!----------------------------------------------------------------------   
    997       INTEGER, INTENT(in) :: i1,i2,j1,j2 
    998       REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    999       !! 
    1000       INTEGER :: ji,jj 
    1001       !!----------------------------------------------------------------------   
    1002  
    1003       DO jj=j1,j2 
    1004          DO ji=i1,i2 
    1005             tabres(ji,jj) = vn_b(ji,jj) * e1v(ji,jj) * hv(ji,jj) 
    1006          END DO 
    1007       END DO 
    1008  
    1009    END SUBROUTINE interpvnb 
    1010  
    1011    SUBROUTINE interpub2b(tabres,i1,i2,j1,j2) 
    1012       !!---------------------------------------------------------------------- 
    1013       !!                  ***  ROUTINE interpub2b  *** 
    1014       !!----------------------------------------------------------------------   
    1015       INTEGER, INTENT(in) :: i1,i2,j1,j2 
    1016       REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    1017       !! 
    1018       INTEGER :: ji,jj 
    1019       !!----------------------------------------------------------------------   
    1020  
    1021       DO jj=j1,j2 
    1022          DO ji=i1,i2 
    1023             tabres(ji,jj) = ub2_b(ji,jj) * e2u(ji,jj) 
    1024          END DO 
    1025       END DO 
    1026  
    1027    END SUBROUTINE interpub2b 
    1028  
    1029    SUBROUTINE interpvb2b(tabres,i1,i2,j1,j2) 
    1030       !!---------------------------------------------------------------------- 
    1031       !!                  ***  ROUTINE interpvb2b  *** 
    1032       !!----------------------------------------------------------------------   
    1033       INTEGER, INTENT(in) :: i1,i2,j1,j2 
    1034       REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    1035       !! 
    1036       INTEGER :: ji,jj 
    1037       !!----------------------------------------------------------------------   
    1038  
    1039       DO jj=j1,j2 
    1040          DO ji=i1,i2 
    1041             tabres(ji,jj) = vb2_b(ji,jj) * e1v(ji,jj) 
    1042          END DO 
    1043       END DO 
    1044  
    1045    END SUBROUTINE interpvb2b 
     1077      LOGICAL :: western_side, eastern_side, northern_side, southern_side 
     1078      REAL(wp) :: ztmpmsk       
     1079      !!----------------------------------------------------------------------   
     1080      !     
     1081      IF (before) THEN 
     1082         DO jk=k1,k2 
     1083            DO jj=j1,j2 
     1084               DO ji=i1,i2 
     1085                  ptab(ji,jj,jk) = tmask(ji,jj,jk) * e3t_0(ji,jj,jk) 
     1086               END DO 
     1087            END DO 
     1088         END DO 
     1089      ELSE 
     1090         western_side  = (nb == 1).AND.(ndir == 1) 
     1091         eastern_side  = (nb == 1).AND.(ndir == 2) 
     1092         southern_side = (nb == 2).AND.(ndir == 1) 
     1093         northern_side = (nb == 2).AND.(ndir == 2) 
     1094 
     1095         DO jk=k1,k2 
     1096            DO jj=j1,j2 
     1097               DO ji=i1,i2 
     1098                  ! Get velocity mask at boundary edge points: 
     1099                  IF (western_side)  ztmpmsk = umask(ji    ,jj    ,1) 
     1100                  IF (eastern_side)  ztmpmsk = umask(nlci-2,jj    ,1) 
     1101                  IF (northern_side) ztmpmsk = vmask(ji    ,nlcj-2,1) 
     1102                  IF (southern_side) ztmpmsk = vmask(ji    ,2     ,1) 
     1103 
     1104                  IF (ABS(ptab(ji,jj,jk) - tmask(ji,jj,jk) * e3t_0(ji,jj,jk))*ztmpmsk > 1.D-2) THEN 
     1105                     IF (western_side) THEN 
     1106                        WRITE(numout,*) 'ERROR bathymetry merge at the western border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 
     1107                     ELSEIF (eastern_side) THEN 
     1108                        WRITE(numout,*) 'ERROR bathymetry merge at the eastern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 
     1109                     ELSEIF (southern_side) THEN 
     1110                        WRITE(numout,*) 'ERROR bathymetry merge at the southern border ji,jj,jk', ji+nimpp-1,jj+njmpp-1,jk 
     1111                     ELSEIF (northern_side) THEN 
     1112                        WRITE(numout,*) 'ERROR bathymetry merge at the northen border ji,jj,jk', ji+nimpp-1,jj+njmpp-1,jk 
     1113                     ENDIF 
     1114                     WRITE(numout,*) '      ptab(ji,jj,jk), fse3t(ji,jj,jk) ', ptab(ji,jj,jk), e3t_0(ji,jj,jk) 
     1115                     kindic_agr = kindic_agr + 1 
     1116                  ENDIF 
     1117               END DO 
     1118            END DO 
     1119         END DO 
     1120 
     1121      ENDIF 
     1122      !  
     1123   END SUBROUTINE interpe3t 
     1124 
     1125   SUBROUTINE interpumsk(ptab,i1,i2,j1,j2,k1,k2,before,nb,ndir) 
     1126      !!---------------------------------------------------------------------- 
     1127      !!                  ***  ROUTINE interpumsk  *** 
     1128      !!----------------------------------------------------------------------   
     1129      !  
     1130      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
     1131      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     1132      LOGICAL :: before 
     1133      INTEGER, INTENT(in) :: nb , ndir 
     1134      ! 
     1135      INTEGER :: ji, jj, jk 
     1136      LOGICAL :: western_side, eastern_side    
     1137      !!----------------------------------------------------------------------   
     1138      !     
     1139      IF (before) THEN 
     1140         DO jk=k1,k2 
     1141            DO jj=j1,j2 
     1142               DO ji=i1,i2 
     1143                  ptab(ji,jj,jk) = umask(ji,jj,jk) 
     1144               END DO 
     1145            END DO 
     1146         END DO 
     1147      ELSE 
     1148 
     1149         western_side  = (nb == 1).AND.(ndir == 1) 
     1150         eastern_side  = (nb == 1).AND.(ndir == 2) 
     1151         DO jk=k1,k2 
     1152            DO jj=j1,j2 
     1153               DO ji=i1,i2 
     1154                   ! Velocity mask at boundary edge points: 
     1155                  IF (ABS(ptab(ji,jj,jk) - umask(ji,jj,jk)) > 1.D-2) THEN 
     1156                     IF (western_side) THEN 
     1157                        WRITE(numout,*) 'ERROR with umask at the western border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 
     1158                        WRITE(numout,*) '      masks: parent, child ', ptab(ji,jj,jk), umask(ji,jj,jk) 
     1159                        kindic_agr = kindic_agr + 1 
     1160                     ELSEIF (eastern_side) THEN 
     1161                        WRITE(numout,*) 'ERROR with umask at the eastern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 
     1162                        WRITE(numout,*) '      masks: parent, child ', ptab(ji,jj,jk), umask(ji,jj,jk) 
     1163                        kindic_agr = kindic_agr + 1 
     1164                     ENDIF 
     1165                  ENDIF 
     1166               END DO 
     1167            END DO 
     1168         END DO 
     1169 
     1170      ENDIF 
     1171      !  
     1172   END SUBROUTINE interpumsk 
     1173 
     1174   SUBROUTINE interpvmsk(ptab,i1,i2,j1,j2,k1,k2,before,nb,ndir) 
     1175      !!---------------------------------------------------------------------- 
     1176      !!                  ***  ROUTINE interpvmsk  *** 
     1177      !!----------------------------------------------------------------------   
     1178      !  
     1179      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
     1180      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     1181      LOGICAL :: before 
     1182      INTEGER, INTENT(in) :: nb , ndir 
     1183      ! 
     1184      INTEGER :: ji, jj, jk 
     1185      LOGICAL :: northern_side, southern_side      
     1186      !!----------------------------------------------------------------------   
     1187      !     
     1188      IF (before) THEN 
     1189         DO jk=k1,k2 
     1190            DO jj=j1,j2 
     1191               DO ji=i1,i2 
     1192                  ptab(ji,jj,jk) = vmask(ji,jj,jk) 
     1193               END DO 
     1194            END DO 
     1195         END DO 
     1196      ELSE 
     1197 
     1198         southern_side = (nb == 2).AND.(ndir == 1) 
     1199         northern_side = (nb == 2).AND.(ndir == 2) 
     1200         DO jk=k1,k2 
     1201            DO jj=j1,j2 
     1202               DO ji=i1,i2 
     1203                   ! Velocity mask at boundary edge points: 
     1204                  IF (ABS(ptab(ji,jj,jk) - vmask(ji,jj,jk)) > 1.D-2) THEN 
     1205                     IF (southern_side) THEN 
     1206                        WRITE(numout,*) 'ERROR with vmask at the southern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 
     1207                        WRITE(numout,*) '      masks: parent, child ', ptab(ji,jj,jk), vmask(ji,jj,jk) 
     1208                        kindic_agr = kindic_agr + 1 
     1209                     ELSEIF (northern_side) THEN 
     1210                        WRITE(numout,*) 'ERROR with vmask at the northern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 
     1211                        WRITE(numout,*) '      masks: parent, child ', ptab(ji,jj,jk), vmask(ji,jj,jk) 
     1212                        kindic_agr = kindic_agr + 1 
     1213                     ENDIF 
     1214                  ENDIF 
     1215               END DO 
     1216            END DO 
     1217         END DO 
     1218 
     1219      ENDIF 
     1220      !  
     1221   END SUBROUTINE interpvmsk 
     1222 
     1223# if defined key_zdftke 
     1224 
     1225   SUBROUTINE interpavm(ptab,i1,i2,j1,j2,k1,k2,before) 
     1226      !!---------------------------------------------------------------------- 
     1227      !!                  ***  ROUTINE interavm  *** 
     1228      !!----------------------------------------------------------------------   
     1229      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
     1230      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     1231      LOGICAL, INTENT(in) :: before 
     1232      !!----------------------------------------------------------------------   
     1233      !       
     1234      IF( before) THEN 
     1235         ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2) 
     1236      ELSE 
     1237         avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 
     1238      ENDIF 
     1239      ! 
     1240   END SUBROUTINE interpavm 
     1241 
     1242# endif /* key_zdftke */ 
    10461243 
    10471244#else 

  • branches/NERC/dev_r5589_is_oce_cpl/NEMOGCM/NEMO/NST_SRC/agrif_opa_sponge.F90

    r4153 r5955  
    11#define SPONGE && define SPONGE_TOP 
    22 
    3 Module agrif_opa_sponge 
     3MODULE agrif_opa_sponge 
    44#if defined key_agrif  && ! defined key_offline 
    55   USE par_oce 
    … …  
    99   USE agrif_oce 
    1010   USE wrk_nemo   
     11   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    1112 
    1213   IMPLICIT NONE 
    1314   PRIVATE 
    1415 
    15    PUBLIC Agrif_Sponge, Agrif_Sponge_Tra, Agrif_Sponge_Dyn, interptsn, interpun, interpvn 
    16  
    17   !! * Substitutions 
     16   PUBLIC Agrif_Sponge, Agrif_Sponge_Tra, Agrif_Sponge_Dyn 
     17   PUBLIC interptsn_sponge, interpun_sponge, interpvn_sponge 
     18 
     19   !! * Substitutions 
    1820#  include "domzgr_substitute.h90" 
    1921   !!---------------------------------------------------------------------- 
    … …  
    2325   !!---------------------------------------------------------------------- 
    2426 
    25    CONTAINS 
     27CONTAINS 
    2628 
    2729   SUBROUTINE Agrif_Sponge_Tra 
    … …  
    3032      !!--------------------------------------------- 
    3133      !! 
    32       INTEGER :: ji,jj,jk,jn 
    3334      REAL(wp) :: timecoeff 
    34       REAL(wp) :: ztsa, zabe1, zabe2, zbtr 
    35       REAL(wp), POINTER, DIMENSION(:,:    ) :: ztu, ztv 
    36       REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztab 
    37       REAL(wp), POINTER, DIMENSION(:,:,:,:) :: tsbdiff 
    3835 
    3936#if defined SPONGE 
    40       CALL wrk_alloc( jpi, jpj, ztu, ztv ) 
    41       CALL wrk_alloc( jpi, jpj, jpk, jpts, ztab, tsbdiff  ) 
    42  
    4337      timecoeff = REAL(Agrif_NbStepint(),wp)/Agrif_rhot() 
    4438 
     39      CALL Agrif_Sponge 
    4540      Agrif_SpecialValue=0. 
    4641      Agrif_UseSpecialValue = .TRUE. 
    47       ztab = 0.e0 
    48       CALL Agrif_Bc_Variable(ztab, tsa_id,calledweight=timecoeff,procname=interptsn) 
     42      tabspongedone_tsn = .FALSE. 
     43 
     44      CALL Agrif_Bc_Variable(tsn_sponge_id,calledweight=timecoeff,procname=interptsn_sponge) 
     45 
    4946      Agrif_UseSpecialValue = .FALSE. 
    50  
    51       tsbdiff(:,:,:,:) = tsb(:,:,:,:) - ztab(:,:,:,:) 
    52  
    53       CALL Agrif_Sponge 
    54  
    55       DO jn = 1, jpts 
    56          DO jk = 1, jpkm1 
    57             ! 
    58             DO jj = 1, jpjm1 
    59                DO ji = 1, jpim1 
    60                   zabe1 = umask(ji,jj,jk) * spe1ur(ji,jj) * fse3u(ji,jj,jk) 
    61                   zabe2 = vmask(ji,jj,jk) * spe2vr(ji,jj) * fse3v(ji,jj,jk) 
    62                   ztu(ji,jj) = zabe1 * ( tsbdiff(ji+1,jj  ,jk,jn) - tsbdiff(ji,jj,jk,jn) ) 
    63                   ztv(ji,jj) = zabe2 * ( tsbdiff(ji  ,jj+1,jk,jn) - tsbdiff(ji,jj,jk,jn) ) 
    64                ENDDO 
    65             ENDDO 
    66  
    67             DO jj = 2, jpjm1 
    68                DO ji = 2, jpim1 
    69                   zbtr = spbtr2(ji,jj) / fse3t(ji,jj,jk) 
    70                   ! horizontal diffusive trends 
    71                   ztsa = zbtr * (  ztu(ji,jj) - ztu(ji-1,jj  )   & 
    72                   &              + ztv(ji,jj) - ztv(ji  ,jj-1)  ) 
    73                   ! add it to the general tracer trends 
    74                   tsa(ji,jj,jk,jn) = tsa(ji,jj,jk,jn) + ztsa 
    75                END DO 
    76             END DO 
    77             ! 
    78          ENDDO 
    79       ENDDO 
    80  
    81       CALL wrk_dealloc( jpi, jpj, ztu, ztv ) 
    82       CALL wrk_dealloc( jpi, jpj, jpk, jpts, ztab, tsbdiff  ) 
    8347#endif 
    8448 
    … …  
    9054      !!--------------------------------------------- 
    9155      !! 
    92       INTEGER :: ji,jj,jk 
    9356      REAL(wp) :: timecoeff 
    94       REAL(wp) :: ze2u, ze1v, zua, zva, zbtr 
    95       REAL(wp), POINTER, DIMENSION(:,:,:) :: ubdiff, vbdiff 
    96       REAL(wp), POINTER, DIMENSION(:,:,:) :: rotdiff, hdivdiff 
    97       REAL(wp), POINTER, DIMENSION(:,:,:) :: ztab 
    9857 
    9958#if defined SPONGE 
    100       CALL wrk_alloc( jpi, jpj, jpk, ztab, ubdiff, vbdiff, rotdiff, hdivdiff ) 
    101  
    10259      timecoeff = REAL(Agrif_NbStepint(),wp)/Agrif_rhot() 
    10360 
    10461      Agrif_SpecialValue=0. 
    10562      Agrif_UseSpecialValue = ln_spc_dyn 
    106       ztab = 0.e0 
    107       CALL Agrif_Bc_Variable(ztab, ua_id,calledweight=timecoeff,procname=interpun) 
     63 
     64      tabspongedone_u = .FALSE. 
     65      tabspongedone_v = .FALSE.          
     66      CALL Agrif_Bc_Variable(un_sponge_id,calledweight=timecoeff,procname=interpun_sponge) 
     67 
     68      tabspongedone_u = .FALSE. 
     69      tabspongedone_v = .FALSE. 
     70      CALL Agrif_Bc_Variable(vn_sponge_id,calledweight=timecoeff,procname=interpvn_sponge) 
     71 
    10872      Agrif_UseSpecialValue = .FALSE. 
    109  
    110       ubdiff(:,:,:) = ( ub(:,:,:) - ztab(:,:,:) ) * umask(:,:,:) 
    111  
    112       ztab = 0.e0 
    113       Agrif_SpecialValue=0. 
    114       Agrif_UseSpecialValue = ln_spc_dyn 
    115       CALL Agrif_Bc_Variable(ztab, va_id,calledweight=timecoeff,procname=interpvn) 
    116       Agrif_UseSpecialValue = .FALSE. 
    117  
    118       vbdiff(:,:,:) = ( vb(:,:,:) - ztab(:,:,:) ) * vmask(:,:,:) 
    119  
    120       CALL Agrif_Sponge 
    121  
    122       DO jk = 1,jpkm1 
    123          ubdiff(:,:,jk) = ubdiff(:,:,jk) * spe1ur2(:,:) 
    124          vbdiff(:,:,jk) = vbdiff(:,:,jk) * spe2vr2(:,:) 
    125       ENDDO 
    126        
    127       hdivdiff = 0. 
    128       rotdiff = 0. 
    129  
    130       DO jk = 1, jpkm1                                 ! Horizontal slab 
    131          !                                             ! =============== 
    132  
    133          !                                             ! -------- 
    134          ! Horizontal divergence                       !   div 
    135          !                                             ! -------- 
    136          DO jj = 2, jpjm1 
    137             DO ji = 2, jpim1   ! vector opt. 
    138                zbtr = spbtr2(ji,jj) / fse3t(ji,jj,jk) 
    139                hdivdiff(ji,jj,jk) =  (  e2u(ji  ,jj  ) * fse3u(ji  ,jj  ,jk) * ubdiff(ji  ,jj  ,jk)     & 
    140                   &                   - e2u(ji-1,jj  ) * fse3u(ji-1,jj  ,jk) * ubdiff(ji-1,jj  ,jk)     & 
    141                   &                   + e1v(ji  ,jj  ) * fse3v(ji  ,jj  ,jk) * vbdiff(ji  ,jj  ,jk)     & 
    142                   &                   - e1v(ji  ,jj-1) * fse3v(ji  ,jj-1,jk) * vbdiff(ji  ,jj-1,jk)  ) * zbtr 
    143             END DO 
    144          END DO 
    145  
    146          DO jj = 1, jpjm1 
    147             DO ji = 1, jpim1   ! vector opt. 
    148                zbtr = spbtr3(ji,jj) * fse3f(ji,jj,jk) 
    149                rotdiff(ji,jj,jk) = (  e2v(ji+1,jj  ) * vbdiff(ji+1,jj  ,jk) - e2v(ji,jj) * vbdiff(ji,jj,jk)    & 
    150                   &                 - e1u(ji  ,jj+1) * ubdiff(ji  ,jj+1,jk) + e1u(ji,jj) * ubdiff(ji,jj,jk)  ) & 
    151                   &               * fmask(ji,jj,jk) * zbtr 
    152             END DO 
    153          END DO 
    154  
    155       ENDDO 
    156  
    157       !                                                ! =============== 
    158       DO jk = 1, jpkm1                                 ! Horizontal slab 
    159          !                                             ! =============== 
    160          DO jj = 2, jpjm1 
    161             DO ji = 2, jpim1   ! vector opt. 
    162                ! horizontal diffusive trends 
    163                zua = - ( rotdiff (ji  ,jj,jk) - rotdiff (ji,jj-1,jk) ) / ( e2u(ji,jj) * fse3u(ji,jj,jk) )   & 
    164                      + ( hdivdiff(ji+1,jj,jk) - hdivdiff(ji,jj  ,jk) ) / e1u(ji,jj) 
    165  
    166                zva = + ( rotdiff (ji,jj  ,jk) - rotdiff (ji-1,jj,jk) ) / ( e1v(ji,jj) * fse3v(ji,jj,jk) )   & 
    167                      + ( hdivdiff(ji,jj+1,jk) - hdivdiff(ji  ,jj,jk) ) / e2v(ji,jj) 
    168                ! add it to the general momentum trends 
    169                ua(ji,jj,jk) = ua(ji,jj,jk) + zua 
    170                va(ji,jj,jk) = va(ji,jj,jk) + zva 
    171             END DO 
    172          END DO 
    173          !                                             ! =============== 
    174       END DO                                           !   End of slab 
    175       !                                                ! =============== 
    176       CALL wrk_dealloc( jpi, jpj, jpk, ztab, ubdiff, vbdiff, rotdiff, hdivdiff ) 
    17773#endif 
    17874 
    … …  
    19995         CALL wrk_alloc( jpi, jpj, ztabramp ) 
    20096 
    201          ispongearea  = 2 + 2 * Agrif_irhox() 
     97         ispongearea  = 2 + nn_sponge_len * Agrif_irhox() 
    20298         ilci = nlci - ispongearea 
    20399         ilcj = nlcj - ispongearea  
    204100         z1spongearea = 1._wp / REAL( ispongearea - 2 ) 
    205          spbtr2(:,:) = 1. / ( e1t(:,:) * e2t(:,:) ) 
    206  
    207          ztabramp(:,:) = 0. 
     101 
     102         ztabramp(:,:) = 0._wp 
    208103 
    209104         IF( (nbondi == -1) .OR. (nbondi == 2) ) THEN 
    … …  
    254149      ! Tracers 
    255150      IF( .NOT. spongedoneT ) THEN 
    256          spe1ur(:,:) = 0. 
    257          spe2vr(:,:) = 0. 
    258  
    259          IF( (nbondi == -1) .OR. (nbondi == 2) ) THEN 
    260             spe1ur(2:ispongearea-1,:       ) = visc_tra                                        & 
    261                &                             *    0.5 * (  ztabramp(2:ispongearea-1,:      )   & 
    262                &                                         + ztabramp(3:ispongearea  ,:      ) ) & 
    263                &                             * e2u(2:ispongearea-1,:) / e1u(2:ispongearea-1,:) 
    264  
    265             spe2vr(2:ispongearea  ,1:jpjm1 ) = visc_tra                                        & 
    266                &                             *    0.5 * (  ztabramp(2:ispongearea  ,1:jpjm1)   & 
    267                &                                         + ztabramp(2:ispongearea,2  :jpj  ) ) & 
    268                &                             * e1v(2:ispongearea,1:jpjm1) / e2v(2:ispongearea,1:jpjm1) 
    269          ENDIF 
    270  
    271          IF( (nbondi == 1) .OR. (nbondi == 2) ) THEN 
    272             spe1ur(ilci+1:nlci-2,:        ) = visc_tra                                   & 
    273                &                            * 0.5 * (  ztabramp(ilci+1:nlci-2,:      )   &  
    274                &                                     + ztabramp(ilci+2:nlci-1,:      ) ) & 
    275                &                            * e2u(ilci+1:nlci-2,:) / e1u(ilci+1:nlci-2,:) 
    276  
    277             spe2vr(ilci+1:nlci-1,1:jpjm1  )  = visc_tra                                  & 
    278                &                            * 0.5 * (  ztabramp(ilci+1:nlci-1,1:jpjm1)   &  
    279                &                                     + ztabramp(ilci+1:nlci-1,2:jpj  ) ) &  
    280                &                            * e1v(ilci+1:nlci-1,1:jpjm1) / e2v(ilci+1:nlci-1,1:jpjm1) 
    281          ENDIF 
    282  
    283          IF( (nbondj == -1) .OR. (nbondj == 2) ) THEN 
    284             spe1ur(1:jpim1,2:ispongearea  ) = visc_tra                                     & 
    285                &                            * 0.5 * (  ztabramp(1:jpim1,2:ispongearea  )   &  
    286                &                                     + ztabramp(2:jpi  ,2:ispongearea  ) ) & 
    287                &                            * e2u(1:jpim1,2:ispongearea) / e1u(1:jpim1,2:ispongearea) 
    288     
    289             spe2vr(:      ,2:ispongearea-1) = visc_tra                                     & 
    290                &                            * 0.5 * (  ztabramp(:      ,2:ispongearea-1)   & 
    291                &                                     + ztabramp(:      ,3:ispongearea  ) ) & 
    292                &                            * e1v(:,2:ispongearea-1) / e2v(:,2:ispongearea-1) 
    293          ENDIF 
    294  
    295          IF( (nbondj == 1) .OR. (nbondj == 2) ) THEN 
    296             spe1ur(1:jpim1,ilcj+1:nlcj-1) = visc_tra                                   & 
    297                &                          * 0.5 * (  ztabramp(1:jpim1,ilcj+1:nlcj-1)   & 
    298                &                                   + ztabramp(2:jpi  ,ilcj+1:nlcj-1) ) & 
    299                &                                * e2u(1:jpim1,ilcj+1:nlcj-1) / e1u(1:jpim1,ilcj+1:nlcj-1) 
    300  
    301             spe2vr(:      ,ilcj+1:nlcj-2) = visc_tra                                   & 
    302                &                          * 0.5 * (  ztabramp(:      ,ilcj+1:nlcj-2)   & 
    303                &                                   + ztabramp(:      ,ilcj+2:nlcj-1) ) & 
    304                &                                * e1v(:,ilcj+1:nlcj-2) / e2v(:,ilcj+1:nlcj-2) 
    305          ENDIF 
     151         fsaht_spu(:,:) = 0._wp 
     152         fsaht_spv(:,:) = 0._wp 
     153         DO jj = 2, jpjm1 
     154            DO ji = 2, jpim1   ! vector opt. 
     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 
     159 
     160         CALL lbc_lnk( fsaht_spu, 'U', 1. )   ! Lateral boundary conditions 
     161         CALL lbc_lnk( fsaht_spv, 'V', 1. ) 
    306162         spongedoneT = .TRUE. 
    307163      ENDIF 
    … …  
    309165      ! Dynamics 
    310166      IF( .NOT. spongedoneU ) THEN 
    311          spe1ur2(:,:) = 0. 
    312          spe2vr2(:,:) = 0. 
    313  
    314          IF( (nbondi == -1) .OR. (nbondi == 2) ) THEN 
    315             spe1ur2(2:ispongearea-1,:      ) = visc_dyn                                   & 
    316                &                             * 0.5 * (  ztabramp(2:ispongearea-1,:      ) & 
    317                &                                      + ztabramp(3:ispongearea  ,:      ) ) 
    318             spe2vr2(2:ispongearea  ,1:jpjm1) = visc_dyn                                   & 
    319                &                             * 0.5 * (  ztabramp(2:ispongearea  ,1:jpjm1) & 
    320                &                                      + ztabramp(2:ispongearea  ,2:jpj  ) )  
    321          ENDIF 
    322  
    323          IF( (nbondi == 1) .OR. (nbondi == 2) ) THEN 
    324             spe1ur2(ilci+1:nlci-2  ,:      ) = visc_dyn                                   & 
    325                &                             * 0.5 * (  ztabramp(ilci+1:nlci-2, :       ) & 
    326                &                                      + ztabramp(ilci+2:nlci-1, :       ) )                       
    327             spe2vr2(ilci+1:nlci-1  ,1:jpjm1) = visc_dyn                                   & 
    328                &                             * 0.5 * (  ztabramp(ilci+1:nlci-1,1:jpjm1  ) & 
    329                &                                      + ztabramp(ilci+1:nlci-1,2:jpj    ) )  
    330          ENDIF 
    331  
    332          IF( (nbondj == -1) .OR. (nbondj == 2) ) THEN 
    333             spe1ur2(1:jpim1,2:ispongearea  ) = visc_dyn                                   &   
    334                &                             * 0.5 * (  ztabramp(1:jpim1,2:ispongearea  ) & 
    335                &                                      + ztabramp(2:jpi  ,2:ispongearea  ) )  
    336             spe2vr2(:      ,2:ispongearea-1) = visc_dyn                                   & 
    337                &                             * 0.5 * (  ztabramp(:      ,2:ispongearea-1) & 
    338                &                                      + ztabramp(:      ,3:ispongearea  ) ) 
    339          ENDIF 
    340  
    341          IF( (nbondj == 1) .OR. (nbondj == 2) ) THEN 
    342             spe1ur2(1:jpim1,ilcj+1:nlcj-1  ) = visc_dyn                                   & 
    343                &                             * 0.5 * (  ztabramp(1:jpim1,ilcj+1:nlcj-1  ) & 
    344                &                                      + ztabramp(2:jpi  ,ilcj+1:nlcj-1  ) )  
    345             spe2vr2(:      ,ilcj+1:nlcj-2  ) = visc_dyn                                   & 
    346                &                             * 0.5 * (  ztabramp(:      ,ilcj+1:nlcj-2  ) & 
    347                &                                      + ztabramp(:      ,ilcj+2:nlcj-1  ) ) 
    348          ENDIF 
     167         fsahm_spt(:,:) = 0._wp 
     168         fsahm_spf(:,:) = 0._wp 
     169         DO jj = 2, jpjm1 
     170            DO ji = 2, jpim1   ! vector opt. 
     171               fsahm_spt(ji,jj) = visc_dyn * ztabramp(ji,jj) 
     172               fsahm_spf(ji,jj) = 0.25_wp * visc_dyn * ( ztabramp(ji,jj) + ztabramp(ji  ,jj+1) & 
     173                                                     &  +ztabramp(ji,jj) + ztabramp(ji+1,jj  ) ) 
     174            END DO 
     175         END DO 
     176 
     177         CALL lbc_lnk( fsahm_spt, 'T', 1. )   ! Lateral boundary conditions 
     178         CALL lbc_lnk( fsahm_spf, 'F', 1. ) 
    349179         spongedoneU = .TRUE. 
    350          spbtr3(:,:) = 1. / ( e1f(:,:) * e2f(:,:) ) 
    351180      ENDIF 
    352181      ! 
    … …  
    357186   END SUBROUTINE Agrif_Sponge 
    358187 
    359    SUBROUTINE interptsn(tabres,i1,i2,j1,j2,k1,k2,n1,n2) 
    360       !!--------------------------------------------- 
    361       !!   *** ROUTINE interptsn *** 
     188   SUBROUTINE interptsn_sponge(tabres,i1,i2,j1,j2,k1,k2,n1,n2,before) 
     189      !!--------------------------------------------- 
     190      !!   *** ROUTINE interptsn_sponge *** 
    362191      !!--------------------------------------------- 
    363192      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
    364193      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 
    365  
    366       tabres(i1:i2,j1:j2,k1:k2,n1:n2) = tsn(i1:i2,j1:j2,k1:k2,n1:n2) 
    367  
    368    END SUBROUTINE interptsn 
    369  
    370    SUBROUTINE interpun(tabres,i1,i2,j1,j2,k1,k2) 
    371       !!--------------------------------------------- 
    372       !!   *** ROUTINE interpun *** 
    373       !!--------------------------------------------- 
     194      LOGICAL, INTENT(in) :: before 
     195 
     196 
     197      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
     198      INTEGER  ::   iku, ikv 
     199      REAL(wp) :: ztsa, zabe1, zabe2, zbtr 
     200      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: ztu, ztv 
     201      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2) ::tsbdiff 
     202      ! 
     203      IF (before) THEN 
     204         tabres(i1:i2,j1:j2,k1:k2,n1:n2) = tsn(i1:i2,j1:j2,k1:k2,n1:n2) 
     205      ELSE    
     206    
     207         tsbdiff(:,:,:,:) = tsb(i1:i2,j1:j2,:,:) - tabres(:,:,:,:)     
     208         DO jn = 1, jpts             
     209            DO jk = 1, jpkm1 
     210               DO jj = j1,j2-1 
     211                  DO ji = i1,i2-1 
     212                     zabe1 = fsaht_spu(ji,jj) * umask(ji,jj,jk) * e2_e1u(ji,jj) * fse3u_n(ji,jj,jk) 
     213                     zabe2 = fsaht_spv(ji,jj) * vmask(ji,jj,jk) * e1_e2v(ji,jj) * fse3v_n(ji,jj,jk) 
     214                     ztu(ji,jj,jk) = zabe1 * ( tsbdiff(ji+1,jj  ,jk,jn) - tsbdiff(ji,jj,jk,jn) )  
     215                     ztv(ji,jj,jk) = zabe2 * ( tsbdiff(ji  ,jj+1,jk,jn) - tsbdiff(ji,jj,jk,jn) ) 
     216                  ENDDO 
     217               ENDDO 
     218 
     219               IF( ln_zps ) THEN      ! set gradient at partial step level 
     220                  DO jj = j1,j2-1 
     221                     DO ji = i1,i2-1 
     222                        ! last level 
     223                        iku = mbku(ji,jj) 
     224                        ikv = mbkv(ji,jj) 
     225                        IF( iku == jk ) THEN 
     226                           ztu(ji,jj,jk) = 0._wp 
     227                        ENDIF 
     228                        IF( ikv == jk ) THEN 
     229                           ztv(ji,jj,jk) = 0._wp 
     230                        ENDIF 
     231                     END DO 
     232                  END DO 
     233               ENDIF 
     234            ENDDO 
     235 
     236            DO jk = 1, jpkm1 
     237               DO jj = j1+1,j2-1 
     238                  DO ji = i1+1,i2-1 
     239 
     240                     IF (.NOT. tabspongedone_tsn(ji,jj)) THEN  
     241                        zbtr = r1_e1e2t(ji,jj) / fse3t_n(ji,jj,jk) 
     242                        ! horizontal diffusive trends 
     243                        ztsa = zbtr * (  ztu(ji,jj,jk) - ztu(ji-1,jj,jk) + ztv(ji,jj,jk) - ztv(ji  ,jj-1,jk)  ) 
     244                        ! add it to the general tracer trends 
     245                        tsa(ji,jj,jk,jn) = tsa(ji,jj,jk,jn) + ztsa 
     246                     ENDIF 
     247 
     248                  ENDDO 
     249               ENDDO 
     250 
     251            ENDDO 
     252         ENDDO 
     253 
     254         tabspongedone_tsn(i1+1:i2-1,j1+1:j2-1) = .TRUE. 
     255 
     256      ENDIF 
     257 
     258   END SUBROUTINE interptsn_sponge 
     259 
     260   SUBROUTINE interpun_sponge(tabres,i1,i2,j1,j2,k1,k2, before) 
     261      !!--------------------------------------------- 
     262      !!   *** ROUTINE interpun_sponge *** 
     263      !!---------------------------------------------     
    374264      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
    375265      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 
    376  
    377       tabres(i1:i2,j1:j2,k1:k2) = un(i1:i2,j1:j2,k1:k2) 
    378  
    379    END SUBROUTINE interpun 
    380  
    381    SUBROUTINE interpvn(tabres,i1,i2,j1,j2,k1,k2) 
    382       !!--------------------------------------------- 
    383       !!   *** ROUTINE interpvn *** 
    384       !!--------------------------------------------- 
     266      LOGICAL, INTENT(in) :: before 
     267 
     268      INTEGER :: ji,jj,jk 
     269 
     270      ! sponge parameters  
     271      REAL(wp) :: ze2u, ze1v, zua, zva, zbtr 
     272      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: ubdiff 
     273      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: rotdiff, hdivdiff 
     274      INTEGER :: jmax 
     275      ! 
     276 
     277 
     278      IF (before) THEN 
     279         tabres = un(i1:i2,j1:j2,:) 
     280      ELSE 
     281 
     282         ubdiff(i1:i2,j1:j2,:) = (ub(i1:i2,j1:j2,:) - tabres(:,:,:))*umask(i1:i2,j1:j2,:) 
     283 
     284         DO jk = 1, jpkm1                                 ! Horizontal slab 
     285            !                                             ! =============== 
     286 
     287            !                                             ! -------- 
     288            ! Horizontal divergence                       !   div 
     289            !                                             ! -------- 
     290            DO jj = j1,j2 
     291               DO ji = i1+1,i2   ! vector opt. 
     292                  zbtr = r1_e1e2t(ji,jj) / fse3t_n(ji,jj,jk) * fsahm_spt(ji,jj) 
     293                  hdivdiff(ji,jj,jk) = (  e2u(ji  ,jj)*fse3u_n(ji  ,jj,jk) * ubdiff(ji  ,jj,jk) & 
     294                                     &   -e2u(ji-1,jj)*fse3u_n(ji-1,jj,jk) * ubdiff(ji-1,jj,jk) ) * zbtr 
     295               END DO 
     296            END DO 
     297 
     298            DO jj = j1,j2-1 
     299               DO ji = i1,i2   ! vector opt. 
     300                  zbtr = r1_e1e2f(ji,jj) * fse3f_n(ji,jj,jk) * fsahm_spf(ji,jj) 
     301                  rotdiff(ji,jj,jk) = (-e1u(ji,jj+1) * ubdiff(ji,jj+1,jk) & 
     302                                       +e1u(ji,jj  ) * ubdiff(ji,jj  ,jk) &  
     303                                    & ) * fmask(ji,jj,jk) * zbtr  
     304               END DO 
     305            END DO 
     306         ENDDO 
     307 
     308         ! 
     309 
     310 
     311 
     312         DO jj = j1+1, j2-1 
     313            DO ji = i1+1, i2-1   ! vector opt. 
     314 
     315               IF (.NOT. tabspongedone_u(ji,jj)) THEN 
     316                  DO jk = 1, jpkm1                                 ! Horizontal slab 
     317                     ze2u = rotdiff (ji,jj,jk) 
     318                     ze1v = hdivdiff(ji,jj,jk) 
     319                     ! horizontal diffusive trends 
     320                     zua = - ( ze2u - rotdiff (ji,jj-1,jk)) / ( e2u(ji,jj) * fse3u_n(ji,jj,jk) )   & 
     321                           + ( hdivdiff(ji+1,jj,jk) - ze1v  ) / e1u(ji,jj) 
     322 
     323                     ! add it to the general momentum trends 
     324                     ua(ji,jj,jk) = ua(ji,jj,jk) + zua 
     325 
     326                  END DO 
     327               ENDIF 
     328 
     329            END DO 
     330         END DO 
     331 
     332         tabspongedone_u(i1+1:i2-1,j1+1:j2-1) = .TRUE. 
     333 
     334         jmax = j2-1 
     335         IF ((nbondj == 1).OR.(nbondj == 2)) jmax = MIN(jmax,nlcj-3) 
     336 
     337         DO jj = j1+1, jmax 
     338            DO ji = i1+1, i2   ! vector opt. 
     339 
     340               IF (.NOT. tabspongedone_v(ji,jj)) THEN 
     341                  DO jk = 1, jpkm1                                 ! Horizontal slab 
     342                     ze2u = rotdiff (ji,jj,jk) 
     343                     ze1v = hdivdiff(ji,jj,jk) 
     344 
     345                     ! horizontal diffusive trends 
     346                     zva = + ( ze2u - rotdiff (ji-1,jj,jk)) / ( e1v(ji,jj) * fse3v_n(ji,jj,jk) )   & 
     347                           + ( hdivdiff(ji,jj+1,jk) - ze1v  ) / e2v(ji,jj) 
     348 
     349                     ! add it to the general momentum trends 
     350                     va(ji,jj,jk) = va(ji,jj,jk) + zva 
     351                  END DO 
     352               ENDIF 
     353 
     354            END DO 
     355         END DO 
     356 
     357 
     358         tabspongedone_v(i1+1:i2,j1+1:jmax) = .TRUE. 
     359 
     360      ENDIF 
     361 
     362 
     363   END SUBROUTINE interpun_sponge 
     364 
     365 
     366   SUBROUTINE interpvn_sponge(tabres,i1,i2,j1,j2,k1,k2, before,nb,ndir) 
     367      !!--------------------------------------------- 
     368      !!   *** ROUTINE interpvn_sponge *** 
     369      !!---------------------------------------------  
    385370      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
    386371      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 
    387  
    388       tabres(i1:i2,j1:j2,k1:k2) = vn(i1:i2,j1:j2,k1:k2) 
    389  
    390    END SUBROUTINE interpvn 
     372      LOGICAL, INTENT(in) :: before 
     373      INTEGER, INTENT(in) :: nb , ndir 
     374 
     375      INTEGER :: ji,jj,jk 
     376 
     377      REAL(wp) :: ze2u, ze1v, zua, zva, zbtr 
     378 
     379      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: vbdiff 
     380      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: rotdiff, hdivdiff 
     381      INTEGER :: imax 
     382      ! 
     383 
     384      IF (before) THEN  
     385         tabres = vn(i1:i2,j1:j2,:) 
     386      ELSE 
     387 
     388         vbdiff(i1:i2,j1:j2,:) = (vb(i1:i2,j1:j2,:) - tabres(:,:,:))*vmask(i1:i2,j1:j2,:) 
     389 
     390         DO jk = 1, jpkm1                                 ! Horizontal slab 
     391            !                                             ! =============== 
     392 
     393            !                                             ! -------- 
     394            ! Horizontal divergence                       !   div 
     395            !                                             ! -------- 
     396            DO jj = j1+1,j2 
     397               DO ji = i1,i2   ! vector opt. 
     398                  zbtr = r1_e1e2t(ji,jj) / fse3t_n(ji,jj,jk) * fsahm_spt(ji,jj) 
     399                  hdivdiff(ji,jj,jk) = ( e1v(ji,jj  ) * fse3v(ji,jj  ,jk) * vbdiff(ji,jj  ,jk)  & 
     400                                     &  -e1v(ji,jj-1) * fse3v(ji,jj-1,jk) * vbdiff(ji,jj-1,jk)  ) * zbtr 
     401               END DO 
     402            END DO 
     403            DO jj = j1,j2 
     404               DO ji = i1,i2-1   ! vector opt. 
     405                  zbtr = r1_e1e2f(ji,jj) * fse3f_n(ji,jj,jk) * fsahm_spf(ji,jj) 
     406                  rotdiff(ji,jj,jk) = ( e2v(ji+1,jj) * vbdiff(ji+1,jj,jk) &  
     407                                    &  -e2v(ji  ,jj) * vbdiff(ji  ,jj,jk) & 
     408                                    & ) * fmask(ji,jj,jk) * zbtr 
     409               END DO 
     410            END DO 
     411         ENDDO 
     412 
     413         !                                                ! =============== 
     414         !                                                 
     415 
     416         imax = i2-1 
     417         IF ((nbondi == 1).OR.(nbondi == 2)) imax = MIN(imax,nlci-3) 
     418 
     419         DO jj = j1+1, j2 
     420            DO ji = i1+1, imax   ! vector opt. 
     421               IF (.NOT. tabspongedone_u(ji,jj)) THEN 
     422                  DO jk = 1, jpkm1                                 ! Horizontal slab 
     423                     ze2u = rotdiff (ji,jj,jk) 
     424                     ze1v = hdivdiff(ji,jj,jk) 
     425                     ! horizontal diffusive trends 
     426                     zua = - ( ze2u - rotdiff (ji,jj-1,jk)) / ( e2u(ji,jj) * fse3u_n(ji,jj,jk) ) + ( hdivdiff(ji+1,jj,jk) - ze1v) & 
     427                           / e1u(ji,jj) 
     428 
     429 
     430                     ! add it to the general momentum trends 
     431                     ua(ji,jj,jk) = ua(ji,jj,jk) + zua 
     432                  END DO 
     433 
     434               ENDIF 
     435            END DO 
     436         END DO 
     437 
     438         tabspongedone_u(i1+1:imax,j1+1:j2) = .TRUE. 
     439 
     440         DO jj = j1+1, j2-1 
     441            DO ji = i1+1, i2-1   ! vector opt. 
     442               IF (.NOT. tabspongedone_v(ji,jj)) THEN 
     443                  DO jk = 1, jpkm1                                 ! Horizontal slab 
     444                     ze2u = rotdiff (ji,jj,jk) 
     445                     ze1v = hdivdiff(ji,jj,jk) 
     446                     ! horizontal diffusive trends 
     447 
     448                     zva = + ( ze2u - rotdiff (ji-1,jj,jk)) / ( e1v(ji,jj) * fse3v_n(ji,jj,jk) ) + ( hdivdiff(ji,jj+1,jk) - ze1v) & 
     449                           / e2v(ji,jj) 
     450 
     451                     ! add it to the general momentum trends 
     452                     va(ji,jj,jk) = va(ji,jj,jk) + zva 
     453                  END DO 
     454               ENDIF 
     455            END DO 
     456         END DO 
     457         tabspongedone_v(i1+1:i2-1,j1+1:j2-1) = .TRUE. 
     458      ENDIF 
     459 
     460   END SUBROUTINE interpvn_sponge 
    391461 
    392462#else 

  • branches/NERC/dev_r5589_is_oce_cpl/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90

    r4491 r5955  
    1 #define TWO_WAY 
    2  
     1#define TWO_WAY        /* TWO WAY NESTING */ 
     2#undef DECAL_FEEDBACK /* SEPARATION of INTERFACES*/ 
     3  
    34MODULE agrif_opa_update 
    45#if defined key_agrif  && ! defined key_offline 
    … …  
    1011   USE lib_mpp 
    1112   USE wrk_nemo   
    12    USE dynspg_oce 
     13   USE zdf_oce        ! vertical physics: ocean variables  
    1314 
    1415   IMPLICIT NONE 
    1516   PRIVATE 
    1617 
    17    PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn 
    18  
    19    INTEGER, PUBLIC :: nbcline = 0 
    20  
     18   PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn,Update_Scales 
     19# if defined key_zdftke 
     20   PUBLIC Agrif_Update_Tke 
     21# endif 
    2122   !!---------------------------------------------------------------------- 
    22    !! NEMO/NST 3.3 , NEMO Consortium (2010) 
     23   !! NEMO/NST 3.6 , NEMO Consortium (2010) 
    2324   !! $Id$ 
    2425   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    … …  
    2728CONTAINS 
    2829 
    29    SUBROUTINE Agrif_Update_Tra( kt ) 
     30   RECURSIVE SUBROUTINE Agrif_Update_Tra( ) 
    3031      !!--------------------------------------------- 
    3132      !!   *** ROUTINE Agrif_Update_Tra *** 
    3233      !!--------------------------------------------- 
    33       !! 
    34       INTEGER, INTENT(in) :: kt 
    35       REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztab 
    36  
    37  
    38       IF((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) RETURN 
    39 #if defined TWO_WAY 
    40       CALL wrk_alloc( jpi, jpj, jpk, jpts, ztab ) 
     34      !  
     35      IF (Agrif_Root()) RETURN 
     36      ! 
     37#if defined TWO_WAY   
     38      IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update tracers  from grid Number',Agrif_Fixed(), 'nbcline', nbcline 
    4139 
    4240      Agrif_UseSpecialValueInUpdate = .TRUE. 
    4341      Agrif_SpecialValueFineGrid = 0. 
    44  
     42      !  
    4543      IF (MOD(nbcline,nbclineupdate) == 0) THEN 
    46          CALL Agrif_Update_Variable(ztab,tsn_id, procname=updateTS) 
    47       ELSE 
    48          CALL Agrif_Update_Variable(ztab,tsn_id,locupdate=(/0,2/), procname=updateTS) 
    49       ENDIF 
    50  
     44# if ! defined DECAL_FEEDBACK 
     45         CALL Agrif_Update_Variable(tsn_id, procname=updateTS) 
     46# else 
     47         CALL Agrif_Update_Variable(tsn_id, locupdate=(/1,0/),procname=updateTS) 
     48# endif 
     49      ELSE 
     50# if ! defined DECAL_FEEDBACK 
     51         CALL Agrif_Update_Variable(tsn_id,locupdate=(/0,2/), procname=updateTS) 
     52# else 
     53         CALL Agrif_Update_Variable(tsn_id,locupdate=(/1,2/), procname=updateTS) 
     54# endif 
     55      ENDIF 
     56      ! 
    5157      Agrif_UseSpecialValueInUpdate = .FALSE. 
    52  
    53       CALL wrk_dealloc( jpi, jpj, jpk, jpts, ztab ) 
     58      ! 
     59      IF ( lk_agrif_doupd ) THEN ! Initialisation: do recursive update: 
     60         CALL Agrif_ChildGrid_To_ParentGrid() 
     61         CALL Agrif_Update_Tra() 
     62         CALL Agrif_ParentGrid_To_ChildGrid() 
     63      ENDIF 
     64      ! 
    5465#endif 
    55  
     66      ! 
    5667   END SUBROUTINE Agrif_Update_Tra 
    5768 
    58    SUBROUTINE Agrif_Update_Dyn( kt ) 
     69   RECURSIVE SUBROUTINE Agrif_Update_Dyn( ) 
    5970      !!--------------------------------------------- 
    6071      !!   *** ROUTINE Agrif_Update_Dyn *** 
    6172      !!--------------------------------------------- 
    62       !! 
    63       INTEGER, INTENT(in) :: kt 
    64       REAL(wp), POINTER, DIMENSION(:,:) :: ztab2d 
    65       REAL(wp), POINTER, DIMENSION(:,:,:) :: ztab 
    66  
    67  
    68       IF ((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) Return 
     73      !  
     74      IF (Agrif_Root()) RETURN 
     75      ! 
    6976#if defined TWO_WAY 
    70       CALL wrk_alloc( jpi, jpj,      ztab2d ) 
    71       CALL wrk_alloc( jpi, jpj, jpk, ztab   ) 
    72  
     77      IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update momentum from grid Number',Agrif_Fixed(), 'nbcline', nbcline 
     78 
     79      Agrif_UseSpecialValueInUpdate = .FALSE. 
     80      Agrif_SpecialValueFineGrid = 0. 
     81      !      
    7382      IF (mod(nbcline,nbclineupdate) == 0) THEN 
    74          CALL Agrif_Update_Variable(ztab,un_id,procname = updateU) 
    75          CALL Agrif_Update_Variable(ztab,vn_id,procname = updateV) 
    76       ELSE 
    77          CALL Agrif_Update_Variable(ztab,un_id,locupdate=(/0,1/),procname = updateU) 
    78          CALL Agrif_Update_Variable(ztab,vn_id,locupdate=(/0,1/),procname = updateV)          
    79       ENDIF 
    80  
    81       CALL Agrif_Update_Variable(ztab2d,e1u_id,procname = updateU2d) 
    82       CALL Agrif_Update_Variable(ztab2d,e2v_id,procname = updateV2d) 
    83  
    84 #if defined key_dynspg_ts 
    85       IF (ln_bt_fw) THEN 
     83# if ! defined DECAL_FEEDBACK 
     84         CALL Agrif_Update_Variable(un_update_id,procname = updateU) 
     85         CALL Agrif_Update_Variable(vn_update_id,procname = updateV) 
     86# else 
     87         CALL Agrif_Update_Variable(un_update_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateU) 
     88         CALL Agrif_Update_Variable(vn_update_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updateV) 
     89# endif 
     90      ELSE 
     91# if ! defined DECAL_FEEDBACK 
     92         CALL Agrif_Update_Variable(un_update_id,locupdate=(/0,1/),procname = updateU) 
     93         CALL Agrif_Update_Variable(vn_update_id,locupdate=(/0,1/),procname = updateV)          
     94# else 
     95         CALL Agrif_Update_Variable(un_update_id,locupdate1=(/0,1/),locupdate2=(/1,1/),procname = updateU) 
     96         CALL Agrif_Update_Variable(vn_update_id,locupdate1=(/1,1/),locupdate2=(/0,1/),procname = updateV) 
     97# endif 
     98      ENDIF 
     99 
     100# if ! defined DECAL_FEEDBACK 
     101      CALL Agrif_Update_Variable(e1u_id,procname = updateU2d) 
     102      CALL Agrif_Update_Variable(e2v_id,procname = updateV2d)   
     103# else 
     104      CALL Agrif_Update_Variable(e1u_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateU2d) 
     105      CALL Agrif_Update_Variable(e2v_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updateV2d)   
     106# endif 
     107 
     108      IF ( ln_dynspg_ts.AND.ln_bt_fw ) THEN 
    86109         ! Update time integrated transports 
    87110         IF (mod(nbcline,nbclineupdate) == 0) THEN 
    88             CALL Agrif_Update_Variable(ztab2d,ub2b_id,procname = updateub2b) 
    89             CALL Agrif_Update_Variable(ztab2d,vb2b_id,procname = updatevb2b) 
     111#  if ! defined DECAL_FEEDBACK 
     112            CALL Agrif_Update_Variable(ub2b_update_id,procname = updateub2b) 
     113            CALL Agrif_Update_Variable(vb2b_update_id,procname = updatevb2b) 
     114#  else 
     115            CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateub2b) 
     116            CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updatevb2b) 
     117#  endif 
    90118         ELSE 
    91             CALL Agrif_Update_Variable(ztab2d,ub2b_id,locupdate=(/0,1/),procname = updateub2b) 
    92             CALL Agrif_Update_Variable(ztab2d,vb2b_id,locupdate=(/0,1/),procname = updatevb2b) 
     119#  if ! defined DECAL_FEEDBACK 
     120            CALL Agrif_Update_Variable(ub2b_update_id,locupdate=(/0,1/),procname = updateub2b) 
     121            CALL Agrif_Update_Variable(vb2b_update_id,locupdate=(/0,1/),procname = updatevb2b) 
     122#  else 
     123            CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/0,1/),locupdate2=(/1,1/),procname = updateub2b) 
     124            CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1,1/),locupdate2=(/0,1/),procname = updatevb2b) 
     125#  endif 
    93126         ENDIF 
    94       END IF  
     127      END IF 
     128      ! 
     129      nbcline = nbcline + 1 
     130      ! 
     131      Agrif_UseSpecialValueInUpdate = .TRUE. 
     132      Agrif_SpecialValueFineGrid = 0. 
     133# if ! defined DECAL_FEEDBACK 
     134      CALL Agrif_Update_Variable(sshn_id,procname = updateSSH) 
     135# else 
     136      CALL Agrif_Update_Variable(sshn_id,locupdate=(/1,0/),procname = updateSSH) 
     137# endif 
     138      Agrif_UseSpecialValueInUpdate = .FALSE. 
     139      !  
    95140#endif 
    96  
    97       nbcline = nbcline + 1 
    98  
    99       Agrif_UseSpecialValueInUpdate = .TRUE.  
     141      ! 
     142      ! Do recursive update: 
     143      IF ( lk_agrif_doupd ) THEN ! Initialisation: do recursive update: 
     144         CALL Agrif_ChildGrid_To_ParentGrid() 
     145         CALL Agrif_Update_Dyn() 
     146         CALL Agrif_ParentGrid_To_ChildGrid() 
     147      ENDIF 
     148      ! 
     149   END SUBROUTINE Agrif_Update_Dyn 
     150 
     151# if defined key_zdftke 
     152   SUBROUTINE Agrif_Update_Tke( kt ) 
     153      !!--------------------------------------------- 
     154      !!   *** ROUTINE Agrif_Update_Tke *** 
     155      !!--------------------------------------------- 
     156      !! 
     157      INTEGER, INTENT(in) :: kt 
     158      !        
     159      IF( ( Agrif_NbStepint() .NE. 0 ) .AND. (kt /= 0) ) RETURN 
     160#  if defined TWO_WAY 
     161 
     162      Agrif_UseSpecialValueInUpdate = .TRUE. 
    100163      Agrif_SpecialValueFineGrid = 0. 
    101       CALL Agrif_Update_Variable(ztab2d,sshn_id,procname = updateSSH) 
     164 
     165      CALL Agrif_Update_Variable( en_id, locupdate=(/0,0/), procname=updateEN  ) 
     166      CALL Agrif_Update_Variable(avt_id, locupdate=(/0,0/), procname=updateAVT ) 
     167      CALL Agrif_Update_Variable(avm_id, locupdate=(/0,0/), procname=updateAVM ) 
     168 
    102169      Agrif_UseSpecialValueInUpdate = .FALSE. 
    103170 
    104       CALL wrk_dealloc( jpi, jpj,      ztab2d ) 
    105       CALL wrk_dealloc( jpi, jpj, jpk, ztab   ) 
    106  
    107 !Done in step 
    108 !      CALL Agrif_ChildGrid_To_ParentGrid() 
    109 !      CALL recompute_diags( kt ) 
    110 !      CALL Agrif_ParentGrid_To_ChildGrid() 
    111  
    112 #endif 
    113  
    114    END SUBROUTINE Agrif_Update_Dyn 
    115  
    116    SUBROUTINE recompute_diags( kt ) 
    117       !!--------------------------------------------- 
    118       !!   *** ROUTINE recompute_diags *** 
    119       !!--------------------------------------------- 
    120       INTEGER, INTENT(in) :: kt 
    121  
    122    END SUBROUTINE recompute_diags 
     171#  endif 
     172       
     173   END SUBROUTINE Agrif_Update_Tke 
     174# endif /* key_zdftke */ 
    123175 
    124176   SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) 
    … …  
    127179      !!--------------------------------------------- 
    128180#  include "domzgr_substitute.h90" 
    129  
    130181      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
    131182      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 
    132       LOGICAL, iNTENT(in) :: before 
    133  
     183      LOGICAL, INTENT(in) :: before 
     184      !! 
    134185      INTEGER :: ji,jj,jk,jn 
    135  
     186      !!--------------------------------------------- 
     187      ! 
    136188      IF (before) THEN 
    137189         DO jn = n1,n2 
    … …  
    146198      ELSE 
    147199         IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 
    148          ! Add asselin part 
     200            ! Add asselin part 
    149201            DO jn = n1,n2 
    150202               DO jk=k1,k2 
    … …  
    153205                        IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN 
    154206                           tsb(ji,jj,jk,jn) = tsb(ji,jj,jk,jn) &  
    155                               & + atfp * ( tabres(ji,jj,jk,jn) & 
    156                               &             - tsn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 
     207                                 & + atfp * ( tabres(ji,jj,jk,jn) & 
     208                                 &             - tsn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 
    157209                        ENDIF 
    158210                     ENDDO 
    … …  
    161213            ENDDO 
    162214         ENDIF 
    163  
    164215         DO jn = n1,n2 
    165216            DO jk=k1,k2 
    … …  
    174225         END DO 
    175226      ENDIF 
    176  
     227      !  
    177228   END SUBROUTINE updateTS 
    178229 
    … …  
    182233      !!--------------------------------------------- 
    183234#  include "domzgr_substitute.h90" 
    184  
     235      !! 
    185236      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 
    186237      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 
    187238      LOGICAL, INTENT(in) :: before 
    188  
     239      !!  
    189240      INTEGER :: ji, jj, jk 
    190241      REAL(wp) :: zrhoy 
    191  
     242      !!--------------------------------------------- 
     243      !  
    192244      IF (before) THEN 
    193245         zrhoy = Agrif_Rhoy() 
    … …  
    209261                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 
    210262                     ub(ji,jj,jk) = ub(ji,jj,jk) &  
    211                        & + atfp * ( tabres(ji,jj,jk) - un(ji,jj,jk) ) * umask(ji,jj,jk) 
     263                           & + atfp * ( tabres(ji,jj,jk) - un(ji,jj,jk) ) * umask(ji,jj,jk) 
    212264                  ENDIF 
    213265                  ! 
    … …  
    217269         END DO 
    218270      ENDIF 
    219  
     271      !  
    220272   END SUBROUTINE updateu 
    221273 
    … …  
    225277      !!--------------------------------------------- 
    226278#  include "domzgr_substitute.h90" 
    227  
     279      !! 
    228280      INTEGER :: i1,i2,j1,j2,k1,k2 
    229281      INTEGER :: ji,jj,jk 
    230282      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: tabres 
    231283      LOGICAL :: before 
    232  
     284      !! 
    233285      REAL(wp) :: zrhox 
    234  
     286      !!---------------------------------------------       
     287      ! 
    235288      IF (before) THEN 
    236289         zrhox = Agrif_Rhox() 
    … …  
    252305                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 
    253306                     vb(ji,jj,jk) = vb(ji,jj,jk) &  
    254                        & + atfp * ( tabres(ji,jj,jk) - vn(ji,jj,jk) ) * vmask(ji,jj,jk) 
     307                           & + atfp * ( tabres(ji,jj,jk) - vn(ji,jj,jk) ) * vmask(ji,jj,jk) 
    255308                  ENDIF 
    256309                  ! 
    … …  
    260313         END DO 
    261314      ENDIF 
    262  
     315      !  
    263316   END SUBROUTINE updatev 
    264317 
    … …  
    268321      !!--------------------------------------------- 
    269322#  include "domzgr_substitute.h90" 
    270  
     323      !! 
    271324      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    272325      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    273326      LOGICAL, INTENT(in) :: before 
    274  
     327      !!  
    275328      INTEGER :: ji, jj, jk 
    276329      REAL(wp) :: zrhoy 
    277330      REAL(wp) :: zcorr 
    278  
     331      !!--------------------------------------------- 
     332      ! 
    279333      IF (before) THEN 
    280334         zrhoy = Agrif_Rhoy() 
    … …  
    303357               ! 
    304358               ! Update barotropic velocities: 
    305 #if defined key_dynspg_ts 
    306                IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 
    307                   zcorr = tabres(ji,jj) - un_b(ji,jj) 
    308                   ub_b(ji,jj) = ub_b(ji,jj) + atfp * zcorr * umask(ji,jj,1) 
    309                END IF 
    310 #endif                
     359               IF ( .NOT.ln_dynspg_ts .OR. (ln_dynspg_ts.AND.(.NOT.ln_bt_fw)) ) THEN 
     360                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 
     361                     zcorr = tabres(ji,jj) - un_b(ji,jj) 
     362                     ub_b(ji,jj) = ub_b(ji,jj) + atfp * zcorr * umask(ji,jj,1) 
     363                  END IF 
     364               ENDIF              
    311365               un_b(ji,jj) = tabres(ji,jj) * umask(ji,jj,1) 
    312366               !        
    … …  
    326380         END DO 
    327381      ENDIF 
    328  
     382      ! 
    329383   END SUBROUTINE updateu2d 
    330384 
    … …  
    333387      !!          *** ROUTINE updatev2d *** 
    334388      !!--------------------------------------------- 
    335  
    336389      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    337390      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    338391      LOGICAL, INTENT(in) :: before 
    339  
     392      !!  
    340393      INTEGER :: ji, jj, jk 
    341394      REAL(wp) :: zrhox 
    342395      REAL(wp) :: zcorr 
    343  
     396      !!--------------------------------------------- 
     397      ! 
    344398      IF (before) THEN 
    345399         zrhox = Agrif_Rhox() 
    … …  
    368422               ! 
    369423               ! Update barotropic velocities: 
    370 #if defined key_dynspg_ts 
    371                IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 
    372                   zcorr = tabres(ji,jj) - vn_b(ji,jj) 
    373                   vb_b(ji,jj) = vb_b(ji,jj) + atfp * zcorr * vmask(ji,jj,1) 
    374                END IF 
    375 #endif                
     424               IF ( .NOT.ln_dynspg_ts .OR. (ln_dynspg_ts.AND.(.NOT.ln_bt_fw)) ) THEN 
     425                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 
     426                     zcorr = tabres(ji,jj) - vn_b(ji,jj) 
     427                     vb_b(ji,jj) = vb_b(ji,jj) + atfp * zcorr * vmask(ji,jj,1) 
     428                  END IF 
     429               ENDIF               
    376430               vn_b(ji,jj) = tabres(ji,jj) * vmask(ji,jj,1) 
    377431               !        
    … …  
    391445         END DO 
    392446      ENDIF 
    393  
     447      !  
    394448   END SUBROUTINE updatev2d 
    395449 
     450 
    396451   SUBROUTINE updateSSH( tabres, i1, i2, j1, j2, before ) 
    397452      !!--------------------------------------------- 
    398453      !!          *** ROUTINE updateSSH *** 
    399454      !!--------------------------------------------- 
    400 #  include "domzgr_substitute.h90" 
    401  
    402455      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    403456      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    404457      LOGICAL, INTENT(in) :: before 
    405  
     458      !! 
    406459      INTEGER :: ji, jj 
    407  
     460      !!--------------------------------------------- 
     461      !  
    408462      IF (before) THEN 
    409463         DO jj=j1,j2 
    … …  
    413467         END DO 
    414468      ELSE 
    415  
    416 #if ! defined key_dynspg_ts 
    417          IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 
     469         IF ( .NOT.ln_dynspg_ts .OR. (ln_dynspg_ts.AND.(.NOT.ln_bt_fw)) ) THEN 
     470            IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 
     471               DO jj=j1,j2 
     472                  DO ji=i1,i2 
     473                     sshb(ji,jj) =   sshb(ji,jj) & 
     474                           & + atfp * ( tabres(ji,jj) - sshn(ji,jj) ) * tmask(ji,jj,1) 
     475                  END DO 
     476               END DO 
     477            ENDIF 
     478         ENDIF 
     479 
     480         DO jj=j1,j2 
     481            DO ji=i1,i2 
     482               sshn(ji,jj) = tabres(ji,jj) * tmask(ji,jj,1) 
     483            END DO 
     484         END DO 
     485      ENDIF 
     486      ! 
     487   END SUBROUTINE updateSSH 
     488 
     489   SUBROUTINE updateub2b( tabres, i1, i2, j1, j2, before ) 
     490      !!--------------------------------------------- 
     491      !!          *** ROUTINE updateub2b *** 
     492      !!--------------------------------------------- 
     493      INTEGER, INTENT(in) :: i1, i2, j1, j2 
     494      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
     495      LOGICAL, INTENT(in) :: before 
     496      !! 
     497      INTEGER :: ji, jj 
     498      REAL(wp) :: zrhoy 
     499      !!--------------------------------------------- 
     500      ! 
     501      IF (before) THEN 
     502         zrhoy = Agrif_Rhoy() 
     503         DO jj=j1,j2 
     504            DO ji=i1,i2 
     505               tabres(ji,jj) = ub2_i_b(ji,jj) * e2u(ji,jj) 
     506            END DO 
     507         END DO 
     508         tabres = zrhoy * tabres 
     509      ELSE 
     510         DO jj=j1,j2 
     511            DO ji=i1,i2 
     512               ub2_b(ji,jj) = tabres(ji,jj) / e2u(ji,jj) 
     513            END DO 
     514         END DO 
     515      ENDIF 
     516      ! 
     517   END SUBROUTINE updateub2b 
     518 
     519   SUBROUTINE updatevb2b( tabres, i1, i2, j1, j2, before ) 
     520      !!--------------------------------------------- 
     521      !!          *** ROUTINE updatevb2b *** 
     522      !!--------------------------------------------- 
     523      INTEGER, INTENT(in) :: i1, i2, j1, j2 
     524      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
     525      LOGICAL, INTENT(in) :: before 
     526      !! 
     527      INTEGER :: ji, jj 
     528      REAL(wp) :: zrhox 
     529      !!--------------------------------------------- 
     530      ! 
     531      IF (before) THEN 
     532         zrhox = Agrif_Rhox() 
     533         DO jj=j1,j2 
     534            DO ji=i1,i2 
     535               tabres(ji,jj) = vb2_i_b(ji,jj) * e1v(ji,jj)  
     536            END DO 
     537         END DO 
     538         tabres = zrhox * tabres 
     539      ELSE 
     540         DO jj=j1,j2 
     541            DO ji=i1,i2 
     542               vb2_b(ji,jj) = tabres(ji,jj) / e1v(ji,jj) 
     543            END DO 
     544         END DO 
     545      ENDIF 
     546      ! 
     547   END SUBROUTINE updatevb2b 
     548 
     549 
     550   SUBROUTINE update_scales( tabres, i1, i2, j1, j2, k1, k2, n1,n2, before ) 
     551      ! currently not used 
     552      !!--------------------------------------------- 
     553      !!           *** ROUTINE updateT *** 
     554      !!--------------------------------------------- 
     555#  include "domzgr_substitute.h90" 
     556 
     557      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
     558      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 
     559      LOGICAL, iNTENT(in) :: before 
     560 
     561      INTEGER :: ji,jj,jk 
     562      REAL(wp) :: ztemp 
     563 
     564      IF (before) THEN 
     565         DO jk=k1,k2 
    418566            DO jj=j1,j2 
    419567               DO ji=i1,i2 
    420                 sshb(ji,jj) =   sshb(ji,jj) & 
    421                  & + atfp * ( tabres(ji,jj) - sshn(ji,jj) ) * tmask(ji,jj,1) 
    422                END DO 
    423             END DO 
    424          ENDIF 
    425 #endif 
    426          DO jj=j1,j2 
    427             DO ji=i1,i2 
    428                sshn(ji,jj) = tabres(ji,jj) * tmask(ji,jj,1) 
    429             END DO 
    430          END DO 
    431       ENDIF 
    432  
    433    END SUBROUTINE updateSSH 
    434  
    435    SUBROUTINE updateub2b( tabres, i1, i2, j1, j2, before ) 
    436       !!--------------------------------------------- 
    437       !!          *** ROUTINE updateub2b *** 
    438       !!--------------------------------------------- 
    439  
    440       INTEGER, INTENT(in) :: i1, i2, j1, j2 
    441       REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    442       LOGICAL, INTENT(in) :: before 
    443  
    444       INTEGER :: ji, jj 
    445       REAL(wp) :: zrhoy 
    446  
    447       IF (before) THEN 
    448          zrhoy = Agrif_Rhoy() 
    449          DO jj=j1,j2 
    450             DO ji=i1,i2 
    451                tabres(ji,jj) = ub2_i_b(ji,jj) * e2u(ji,jj) 
    452             END DO 
    453          END DO 
    454          tabres = zrhoy * tabres 
    455       ELSE 
    456          DO jj=j1,j2 
    457             DO ji=i1,i2 
    458                ub2_b(ji,jj) = tabres(ji,jj) / e2u(ji,jj) 
    459             END DO 
    460          END DO 
    461       ENDIF 
    462  
    463    END SUBROUTINE updateub2b 
    464  
    465    SUBROUTINE updatevb2b( tabres, i1, i2, j1, j2, before ) 
    466       !!--------------------------------------------- 
    467       !!          *** ROUTINE updatevb2b *** 
    468       !!--------------------------------------------- 
    469  
    470       INTEGER, INTENT(in) :: i1, i2, j1, j2 
    471       REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    472       LOGICAL, INTENT(in) :: before 
    473  
    474       INTEGER :: ji, jj 
    475       REAL(wp) :: zrhox 
    476  
    477       IF (before) THEN 
    478          zrhox = Agrif_Rhox() 
    479          DO jj=j1,j2 
    480             DO ji=i1,i2 
    481                tabres(ji,jj) = vb2_i_b(ji,jj) * e1v(ji,jj)  
    482             END DO 
    483          END DO 
    484          tabres = zrhox * tabres 
    485       ELSE 
    486          DO jj=j1,j2 
    487             DO ji=i1,i2 
    488                vb2_b(ji,jj) = tabres(ji,jj) / e1v(ji,jj) 
    489             END DO 
    490          END DO 
    491       ENDIF 
    492  
    493    END SUBROUTINE updatevb2b 
     568                  tabres(ji,jj,jk,1) = e1t(ji,jj)*e2t(ji,jj)*tmask(ji,jj,jk) 
     569                  tabres(ji,jj,jk,2) = e1t(ji,jj)*tmask(ji,jj,jk) 
     570                  tabres(ji,jj,jk,3) = e2t(ji,jj)*tmask(ji,jj,jk) 
     571               END DO 
     572            END DO 
     573         END DO 
     574         tabres(:,:,:,1)=tabres(:,:,:,1)*Agrif_Rhox()*Agrif_Rhoy() 
     575         tabres(:,:,:,2)=tabres(:,:,:,2)*Agrif_Rhox() 
     576         tabres(:,:,:,3)=tabres(:,:,:,3)*Agrif_Rhoy() 
     577      ELSE 
     578         DO jk=k1,k2 
     579            DO jj=j1,j2 
     580               DO ji=i1,i2 
     581                  IF( tabres(ji,jj,jk,1) .NE. 0. ) THEN  
     582                     print *,'VAL = ',ji,jj,jk,tabres(ji,jj,jk,1),e1t(ji,jj)*e2t(ji,jj)*tmask(ji,jj,jk) 
     583                     print *,'VAL2 = ',ji,jj,jk,tabres(ji,jj,jk,2),e1t(ji,jj)*tmask(ji,jj,jk) 
     584                     print *,'VAL3 = ',ji,jj,jk,tabres(ji,jj,jk,3),e2t(ji,jj)*tmask(ji,jj,jk) 
     585                     ztemp = sqrt(tabres(ji,jj,jk,1)/(tabres(ji,jj,jk,2)*tabres(ji,jj,jk,3))) 
     586                     print *,'CORR = ',ztemp-1. 
     587                     print *,'NEW VALS = ',tabres(ji,jj,jk,2)*ztemp,tabres(ji,jj,jk,3)*ztemp, & 
     588                           tabres(ji,jj,jk,2)*ztemp*tabres(ji,jj,jk,3)*ztemp 
     589                     e1t(ji,jj) = tabres(ji,jj,jk,2)*ztemp 
     590                     e2t(ji,jj) = tabres(ji,jj,jk,3)*ztemp 
     591                  END IF 
     592               END DO 
     593            END DO 
     594         END DO 
     595      ENDIF 
     596      ! 
     597   END SUBROUTINE update_scales 
     598 
     599# if defined key_zdftke 
     600   SUBROUTINE updateEN( ptab, i1, i2, j1, j2, k1, k2, before ) 
     601      !!--------------------------------------------- 
     602      !!           *** ROUTINE updateen *** 
     603      !!--------------------------------------------- 
     604      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 
     605      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     606      LOGICAL, INTENT(in) :: before 
     607      !!--------------------------------------------- 
     608      ! 
     609      IF (before) THEN 
     610         ptab (i1:i2,j1:j2,k1:k2) = en(i1:i2,j1:j2,k1:k2) 
     611      ELSE 
     612         en(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2)  
     613      ENDIF 
     614      ! 
     615   END SUBROUTINE updateEN 
     616 
     617 
     618   SUBROUTINE updateAVT( ptab, i1, i2, j1, j2, k1, k2, before ) 
     619      !!--------------------------------------------- 
     620      !!           *** ROUTINE updateavt *** 
     621      !!--------------------------------------------- 
     622      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 
     623      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     624      LOGICAL, INTENT(in) :: before 
     625      !!--------------------------------------------- 
     626      ! 
     627      IF (before) THEN 
     628         ptab (i1:i2,j1:j2,k1:k2) = avt_k(i1:i2,j1:j2,k1:k2) 
     629      ELSE 
     630         avt_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2)  
     631      ENDIF 
     632      ! 
     633   END SUBROUTINE updateAVT 
     634 
     635 
     636   SUBROUTINE updateAVM( ptab, i1, i2, j1, j2, k1, k2, before ) 
     637      !!--------------------------------------------- 
     638      !!           *** ROUTINE updateavm *** 
     639      !!--------------------------------------------- 
     640      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 
     641      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     642      LOGICAL, INTENT(in) :: before 
     643      !!--------------------------------------------- 
     644      ! 
     645      IF (before) THEN 
     646         ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2) 
     647      ELSE 
     648         avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2)  
     649      ENDIF 
     650      ! 
     651   END SUBROUTINE updateAVM 
     652 
     653# endif /* key_zdftke */  
    494654 
    495655#else 

  • branches/NERC/dev_r5589_is_oce_cpl/NEMOGCM/NEMO/NST_SRC/agrif_top_interp.F90

    r3680 r5955  
    44   USE oce 
    55   USE dom_oce       
    6    USE sol_oce 
    76   USE agrif_oce 
    87   USE agrif_top_sponge 
     8   USE par_trc 
    99   USE trc 
    1010   USE lib_mpp 
    … …  
    1414   PRIVATE 
    1515 
    16    PUBLIC Agrif_trc 
     16   PUBLIC Agrif_trc, interptrn 
    1717 
    1818#  include "domzgr_substitute.h90"   
    1919#  include "vectopt_loop_substitute.h90" 
    2020  !!---------------------------------------------------------------------- 
    21    !! NEMO/NST 3.3 , NEMO Consortium (2010) 
     21   !! NEMO/NST 3.6 , NEMO Consortium (2010) 
    2222   !! $Id$ 
    2323   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    … …  
    2828   SUBROUTINE Agrif_trc 
    2929      !!---------------------------------------------------------------------- 
    30       !!                  ***  ROUTINE Agrif_Tra  *** 
    31       !!---------------------------------------------------------------------- 
    32       !! 
    33       INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    34       REAL(wp) ::   zrhox , alpha1, alpha2, alpha3 
    35       REAL(wp) ::   alpha4, alpha5, alpha6, alpha7 
    36       REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztra 
     30      !!                  ***  ROUTINE Agrif_trc  *** 
    3731      !!---------------------------------------------------------------------- 
    3832      ! 
    3933      IF( Agrif_Root() )   RETURN 
    4034 
    41       CALL wrk_alloc( jpi, jpj, jpk, jptra, ztra ) 
    42  
    4335      Agrif_SpecialValue    = 0.e0 
    4436      Agrif_UseSpecialValue = .TRUE. 
    45       ztra(:,:,:,:) = 0.e0 
    4637 
    47       CALL Agrif_Bc_variable( ztra, trn_id, procname=interptrn ) 
     38      CALL Agrif_Bc_variable( trn_id, procname=interptrn ) 
    4839      Agrif_UseSpecialValue = .FALSE. 
     40      ! 
     41   END SUBROUTINE Agrif_trc 
    4942 
    50       zrhox = Agrif_Rhox() 
     43   SUBROUTINE interptrn(ptab,i1,i2,j1,j2,k1,k2,n1,n2,before,nb,ndir) 
     44      !!--------------------------------------------- 
     45      !!   *** ROUTINE interptrn *** 
     46      !!--------------------------------------------- 
     47      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab 
     48      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
     49      LOGICAL, INTENT(in) :: before 
     50      INTEGER, INTENT(in) :: nb , ndir 
     51      ! 
     52      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
     53      INTEGER :: imin, imax, jmin, jmax 
     54      REAL(wp) ::   zrhox , zalpha1, zalpha2, zalpha3 
     55      REAL(wp) ::   zalpha4, zalpha5, zalpha6, zalpha7 
     56      LOGICAL :: western_side, eastern_side,northern_side,southern_side 
    5157 
    52       alpha1 = ( zrhox - 1. ) * 0.5 
    53       alpha2 = 1. - alpha1 
    54  
    55       alpha3 = ( zrhox - 1. ) / ( zrhox + 1. ) 
    56       alpha4 = 1. - alpha3 
    57  
    58       alpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 
    59       alpha7 =    - ( zrhox - 1. ) / ( zrhox + 3. ) 
    60       alpha5 = 1. - alpha6 - alpha7 
    61       IF( nbondi == 1 .OR. nbondi == 2 ) THEN 
    62  
    63          DO jn = 1, jptra 
    64             tra(nlci,:,:,jn) = alpha1 * ztra(nlci,:,:,jn) + alpha2 * ztra(nlci-1,:,:,jn) 
    65             DO jk = 1, jpkm1 
    66                DO jj = 1, jpj 
    67                   IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN 
    68                      tra(nlci-1,jj,jk,jn) = tra(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 
    69                   ELSE 
    70                      tra(nlci-1,jj,jk,jn)=(alpha4*tra(nlci,jj,jk,jn)+alpha3*tra(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 
    71                      IF( un(nlci-2,jj,jk) > 0.e0 ) THEN 
    72                         tra(nlci-1,jj,jk,jn)=( alpha6*tra(nlci-2,jj,jk,jn)+alpha5*tra(nlci,jj,jk,jn)  & 
    73                            &                 + alpha7*tra(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 
     58      IF (before) THEN          
     59         ptab(i1:i2,j1:j2,k1:k2,n1:n2) = trn(i1:i2,j1:j2,k1:k2,n1:n2) 
     60      ELSE 
     61         ! 
     62         western_side  = (nb == 1).AND.(ndir == 1) 
     63         eastern_side  = (nb == 1).AND.(ndir == 2) 
     64         southern_side = (nb == 2).AND.(ndir == 1) 
     65         northern_side = (nb == 2).AND.(ndir == 2) 
     66         ! 
     67         zrhox = Agrif_Rhox() 
     68         !  
     69         zalpha1 = ( zrhox - 1. ) * 0.5 
     70         zalpha2 = 1. - zalpha1 
     71         !  
     72         zalpha3 = ( zrhox - 1. ) / ( zrhox + 1. ) 
     73         zalpha4 = 1. - zalpha3 
     74         !  
     75         zalpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 
     76         zalpha7 =    - ( zrhox - 1. ) / ( zrhox + 3. ) 
     77         zalpha5 = 1. - zalpha6 - zalpha7 
     78         ! 
     79         imin = i1 
     80         imax = i2 
     81         jmin = j1 
     82         jmax = j2 
     83         !  
     84         ! Remove CORNERS 
     85         IF((nbondj == -1).OR.(nbondj == 2)) jmin = 3 
     86         IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj-2 
     87         IF((nbondi == -1).OR.(nbondi == 2)) imin = 3 
     88         IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci-2         
     89         ! 
     90         IF( eastern_side) THEN 
     91            DO jn = 1, jptra 
     92               tra(nlci,j1:j2,k1:k2,jn) = zalpha1 * ptab(nlci,j1:j2,k1:k2,jn) + zalpha2 * ptab(nlci-1,j1:j2,k1:k2,jn) 
     93               DO jk = 1, jpkm1 
     94                  DO jj = jmin,jmax 
     95                     IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN 
     96                        tra(nlci-1,jj,jk,jn) = tra(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 
     97                     ELSE 
     98                        tra(nlci-1,jj,jk,jn)=(zalpha4*tra(nlci,jj,jk,jn)+zalpha3*tra(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 
     99                        IF( un(nlci-2,jj,jk) > 0.e0 ) THEN 
     100                           tra(nlci-1,jj,jk,jn)=( zalpha6*tra(nlci-2,jj,jk,jn)+zalpha5*tra(nlci,jj,jk,jn) &  
     101                                 + zalpha7*tra(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 
     102                        ENDIF 
    74103                     ENDIF 
    75                   ENDIF 
     104                  END DO 
     105               END DO 
     106            ENDDO 
     107         ENDIF 
     108         !  
     109         IF( northern_side ) THEN             
     110            DO jn = 1, jptra 
     111               tra(i1:i2,nlcj,k1:k2,jn) = zalpha1 * ptab(i1:i2,nlcj,k1:k2,jn) + zalpha2 * ptab(i1:i2,nlcj-1,k1:k2,jn) 
     112               DO jk = 1, jpkm1 
     113                  DO ji = imin,imax 
     114                     IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN 
     115                        tra(ji,nlcj-1,jk,jn) = tra(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 
     116                     ELSE 
     117                        tra(ji,nlcj-1,jk,jn)=(zalpha4*tra(ji,nlcj,jk,jn)+zalpha3*tra(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk)         
     118                        IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN 
     119                           tra(ji,nlcj-1,jk,jn)=( zalpha6*tra(ji,nlcj-2,jk,jn)+zalpha5*tra(ji,nlcj,jk,jn)  & 
     120                                 + zalpha7*tra(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 
     121                        ENDIF 
     122                     ENDIF 
     123                  END DO 
     124               END DO 
     125            ENDDO 
     126         ENDIF 
     127         ! 
     128         IF( western_side) THEN             
     129            DO jn = 1, jptra 
     130               tra(1,j1:j2,k1:k2,jn) = zalpha1 * ptab(1,j1:j2,k1:k2,jn) + zalpha2 * ptab(2,j1:j2,k1:k2,jn) 
     131               DO jk = 1, jpkm1 
     132                  DO jj = jmin,jmax 
     133                     IF( umask(2,jj,jk) == 0.e0 ) THEN 
     134                        tra(2,jj,jk,jn) = tra(1,jj,jk,jn) * tmask(2,jj,jk) 
     135                     ELSE 
     136                        tra(2,jj,jk,jn)=(zalpha4*tra(1,jj,jk,jn)+zalpha3*tra(3,jj,jk,jn))*tmask(2,jj,jk)         
     137                        IF( un(2,jj,jk) < 0.e0 ) THEN 
     138                           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) 
     139                        ENDIF 
     140                     ENDIF 
     141                  END DO 
    76142               END DO 
    77143            END DO 
    78          ENDDO 
    79       ENDIF 
    80  
    81       IF( nbondj == 1 .OR. nbondj == 2 ) THEN 
    82  
    83          DO jn = 1, jptra 
    84             tra(:,nlcj,:,jn) = alpha1 * ztra(:,nlcj,:,jn) + alpha2 * ztra(:,nlcj-1,:,jn) 
    85             DO jk = 1, jpkm1 
    86                DO ji = 1, jpi 
    87                   IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN 
    88                      tra(ji,nlcj-1,jk,jn) = tra(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 
    89                   ELSE 
    90                      tra(ji,nlcj-1,jk,jn)=(alpha4*tra(ji,nlcj,jk,jn)+alpha3*tra(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk) 
    91                      IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN 
    92                         tra(ji,nlcj-1,jk,jn)=( alpha6*tra(ji,nlcj-2,jk,jn)+alpha5*tra(ji,nlcj,jk,jn)  & 
    93                            &                 + alpha7*tra(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 
     144         ENDIF 
     145         ! 
     146         IF( southern_side ) THEN            
     147            DO jn = 1, jptra 
     148               tra(i1:i2,1,k1:k2,jn) = zalpha1 * ptab(i1:i2,1,k1:k2,jn) + zalpha2 * ptab(i1:i2,2,k1:k2,jn) 
     149               DO jk=1,jpk       
     150                  DO ji=imin,imax 
     151                     IF( vmask(ji,2,jk) == 0.e0 ) THEN 
     152                        tra(ji,2,jk,jn)=tra(ji,1,jk,jn) * tmask(ji,2,jk) 
     153                     ELSE 
     154                        tra(ji,2,jk,jn)=(zalpha4*tra(ji,1,jk,jn)+zalpha3*tra(ji,3,jk,jn))*tmask(ji,2,jk) 
     155                        IF( vn(ji,2,jk) < 0.e0 ) THEN 
     156                           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) 
     157                        ENDIF 
    94158                     ENDIF 
    95                   ENDIF 
     159                  END DO 
    96160               END DO 
    97             END DO 
    98          ENDDO 
    99       ENDIF 
    100       IF( nbondi == -1 .OR. nbondi == 2 ) THEN 
    101          DO jn = 1, jptra 
    102             tra(1,:,:,jn) = alpha1 * ztra(1,:,:,jn) + alpha2 * ztra(2,:,:,jn) 
    103             DO jk = 1, jpkm1 
    104                DO jj = 1, jpj 
    105                   IF( umask(2,jj,jk) == 0.e0 ) THEN 
    106                      tra(2,jj,jk,jn) = tra(1,jj,jk,jn) * tmask(2,jj,jk) 
    107                   ELSE 
    108                      tra(2,jj,jk,jn)=(alpha4*tra(1,jj,jk,jn)+alpha3*tra(3,jj,jk,jn))*tmask(2,jj,jk) 
    109                      IF( un(2,jj,jk) < 0.e0 ) THEN 
    110                         tra(2,jj,jk,jn)=(alpha6*tra(3,jj,jk,jn)+alpha5*tra(1,jj,jk,jn)+alpha7*tra(4,jj,jk,jn))*tmask(2,jj,jk) 
    111                      ENDIF 
    112                   ENDIF 
    113                END DO 
    114             END DO 
    115          END DO 
    116       ENDIF 
    117  
    118       IF( nbondj == -1 .OR. nbondj == 2 ) THEN 
    119          DO jn = 1, jptra 
    120             tra(:,1,:,jn) = alpha1 * ztra(:,1,:,jn) + alpha2 * ztra(:,2,:,jn) 
    121             DO jk=1,jpk 
    122                DO ji=1,jpi 
    123                   IF( vmask(ji,2,jk) == 0.e0 ) THEN 
    124                      tra(ji,2,jk,jn)=tra(ji,1,jk,jn) * tmask(ji,2,jk) 
    125                   ELSE 
    126                      tra(ji,2,jk,jn)=(alpha4*tra(ji,1,jk,jn)+alpha3*tra(ji,3,jk,jn))*tmask(ji,2,jk) 
    127                      IF( vn(ji,2,jk) < 0.e0 ) THEN 
    128                         tra(ji,2,jk,jn)=(alpha6*tra(ji,3,jk,jn)+alpha5*tra(ji,1,jk,jn)+alpha7*tra(ji,4,jk,jn))*tmask(ji,2,jk) 
    129                      ENDIF 
    130                   ENDIF 
    131                END DO 
    132             END DO 
    133          ENDDO 
     161            ENDDO 
     162         ENDIF 
     163         ! 
     164         ! Treatment of corners 
     165         !  
     166         ! East south 
     167         IF ((eastern_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 
     168            tra(nlci-1,2,:,:) = ptab(nlci-1,2,:,:) 
     169         ENDIF 
     170         ! East north 
     171         IF ((eastern_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 
     172            tra(nlci-1,nlcj-1,:,:) = ptab(nlci-1,nlcj-1,:,:) 
     173         ENDIF 
     174         ! West south 
     175         IF ((western_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 
     176            tra(2,2,:,:) = ptab(2,2,:,:) 
     177         ENDIF 
     178         ! West north 
     179         IF ((western_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 
     180            tra(2,nlcj-1,:,:) = ptab(2,nlcj-1,:,:) 
     181         ENDIF 
     182         ! 
    134183      ENDIF 
    135184      ! 
    136       CALL wrk_dealloc( jpi, jpj, jpk, jptra, ztra ) 
    137       ! 
    138  
    139    END SUBROUTINE Agrif_trc 
     185   END SUBROUTINE interptrn 
    140186 
    141187#else 

  • branches/NERC/dev_r5589_is_oce_cpl/NEMOGCM/NEMO/NST_SRC/agrif_top_sponge.F90

    r3680 r5955  
    11#define SPONGE_TOP 
    22 
    3 Module agrif_top_sponge 
     3MODULE agrif_top_sponge 
    44#if defined key_agrif && defined key_top 
    55   USE par_oce 
     6   USE par_trc 
    67   USE oce 
    78   USE dom_oce 
    … …  
    1617   PRIVATE 
    1718 
    18    PUBLIC Agrif_Sponge_Trc, interptrn 
     19   PUBLIC Agrif_Sponge_trc, interptrn_sponge 
    1920 
    20   !! * Substitutions 
     21   !! * Substitutions 
    2122#  include "domzgr_substitute.h90" 
    2223   !!---------------------------------------------------------------------- 
    23    !! NEMO/NST 3.3 , NEMO Consortium (2010) 
     24   !! NEMO/NST 3.6 , NEMO Consortium (2010) 
    2425   !! $Id$ 
    2526   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    2627   !!---------------------------------------------------------------------- 
    2728 
    28    CONTAINS 
     29CONTAINS 
    2930 
    30    SUBROUTINE Agrif_Sponge_Trc 
     31   SUBROUTINE Agrif_Sponge_trc 
    3132      !!--------------------------------------------- 
    3233      !!   *** ROUTINE Agrif_Sponge_Trc *** 
    3334      !!--------------------------------------------- 
    3435      !!  
    35       INTEGER :: ji,jj,jk,jn 
    3636      REAL(wp) :: timecoeff 
    37       REAL(wp) :: ztra, zabe1, zabe2, zbtr 
    38       REAL(wp), POINTER, DIMENSION(:,:) :: ztru, ztrv 
    39       REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztabr 
    40       REAL(wp), POINTER, DIMENSION(:,:,:,:) :: trbdiff 
    4137 
    4238#if defined SPONGE_TOP 
    43       CALL wrk_alloc( jpi, jpj, ztru, ztrv ) 
    44       CALL wrk_alloc( jpi, jpj, jpk, jptra, ztabr, trbdiff ) 
    45  
    4639      timecoeff = REAL(Agrif_NbStepint(),wp)/Agrif_rhot() 
    47  
     40      CALL Agrif_sponge 
    4841      Agrif_SpecialValue=0. 
    4942      Agrif_UseSpecialValue = .TRUE. 
    50       ztabr = 0.e0 
    51       CALL Agrif_Bc_Variable(ztabr, tra_id,calledweight=timecoeff,procname=interptrn) 
     43      tabspongedone_trn = .FALSE. 
     44      CALL Agrif_Bc_Variable(trn_sponge_id,calledweight=timecoeff,procname=interptrn_sponge) 
    5245      Agrif_UseSpecialValue = .FALSE. 
    53  
    54       trbdiff(:,:,:,:) = trb(:,:,:,:) - ztabr(:,:,:,:) 
    55  
    56       CALL Agrif_sponge 
    57  
    58       DO jn = 1, jptra 
    59          DO jk = 1, jpkm1 
    60             ! 
    61             DO jj = 1, jpjm1 
    62                DO ji = 1, jpim1 
    63                   zabe1 = umask(ji,jj,jk) * spe1ur(ji,jj) * fse3u(ji,jj,jk) 
    64                   zabe2 = vmask(ji,jj,jk) * spe2vr(ji,jj) * fse3v(ji,jj,jk) 
    65                   ztru(ji,jj) = zabe1 * ( trbdiff(ji+1,jj  ,jk,jn) - trbdiff(ji,jj,jk,jn) ) 
    66                   ztrv(ji,jj) = zabe2 * ( trbdiff(ji  ,jj+1,jk,jn) - trbdiff(ji,jj,jk,jn) ) 
    67                ENDDO 
    68             ENDDO 
    69  
    70             DO jj = 2,jpjm1 
    71                DO ji = 2,jpim1 
    72                   zbtr = spbtr2(ji,jj) / fse3t(ji,jj,jk) 
    73                   ! horizontal diffusive trends 
    74                   ztra = zbtr * ( ztru(ji,jj) - ztru(ji-1,jj) + ztrv(ji,jj) - ztrv(ji,jj-1)  ) 
    75                   ! add it to the general tracer trends 
    76                   tra(ji,jj,jk,jn) = tra(ji,jj,jk,jn) + ztra 
    77                END DO 
    78             END DO 
    79             ! 
    80          ENDDO 
    81       ENDDO 
    82   
    83       CALL wrk_dealloc( jpi, jpj, ztru, ztrv ) 
    84       CALL wrk_dealloc( jpi, jpj, jpk, jptra, trbdiff, ztabr ) 
    8546 
    8647#endif 
    … …  
    8849   END SUBROUTINE Agrif_Sponge_Trc 
    8950 
    90    SUBROUTINE interptrn(tabres,i1,i2,j1,j2,k1,k2,n1,n2) 
     51   SUBROUTINE interptrn_sponge(tabres,i1,i2,j1,j2,k1,k2,n1,n2,before) 
    9152      !!--------------------------------------------- 
    92       !!   *** ROUTINE interptn *** 
     53      !!   *** ROUTINE interptrn_sponge *** 
    9354      !!--------------------------------------------- 
    9455      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
    9556      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 
     57      LOGICAL, INTENT(in) :: before 
     58 
     59 
     60      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
     61 
     62      REAL(wp) :: ztra, zabe1, zabe2, zbtr 
     63      REAL(wp), DIMENSION(i1:i2,j1:j2) :: ztu, ztv 
     64      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2) ::trbdiff 
    9665      ! 
    97       tabres(i1:i2,j1:j2,k1:k2,n1:n2) = trn(i1:i2,j1:j2,k1:k2,n1:n2) 
     66      IF (before) THEN 
     67         tabres(i1:i2,j1:j2,k1:k2,n1:n2) = trn(i1:i2,j1:j2,k1:k2,n1:n2) 
     68      ELSE       
    9869 
    99    END SUBROUTINE interptrn 
     70         trbdiff(:,:,:,:) = trb(i1:i2,j1:j2,:,:) - tabres(:,:,:,:)       
     71         DO jn = 1, jptra 
     72            DO jk = 1, jpkm1 
     73 
     74               DO jj = j1,j2-1 
     75                  DO ji = i1,i2-1 
     76                     zabe1 = fsaht_spu(ji,jj) * umask(ji,jj,jk) * e2_e1u(ji,jj) * fse3u_n(ji,jj,jk) 
     77                     zabe2 = fsaht_spv(ji,jj) * vmask(ji,jj,jk) * e1_e2v(ji,jj) * fse3v_n(ji,jj,jk) 
     78                     ztu(ji,jj) = zabe1 * ( trbdiff(ji+1,jj  ,jk,jn) - trbdiff(ji,jj,jk,jn) ) 
     79                     ztv(ji,jj) = zabe2 * ( trbdiff(ji  ,jj+1,jk,jn) - trbdiff(ji,jj,jk,jn) ) 
     80                  ENDDO 
     81               ENDDO 
     82 
     83               DO jj = j1+1,j2-1 
     84                  DO ji = i1+1,i2-1 
     85 
     86                     IF (.NOT. tabspongedone_trn(ji,jj)) THEN  
     87                        zbtr = r1_e1e2t(ji,jj) / fse3t(ji,jj,jk) 
     88                        ! horizontal diffusive trends 
     89                        ztra = zbtr * (  ztu(ji,jj) - ztu(ji-1,jj  ) + ztv(ji,jj) - ztv(ji  ,jj-1)  ) 
     90                        ! add it to the general tracer trends 
     91                        tra(ji,jj,jk,jn) = tra(ji,jj,jk,jn) + ztra 
     92                     ENDIF 
     93 
     94                  ENDDO 
     95               ENDDO 
     96 
     97            ENDDO 
     98         ENDDO 
     99 
     100         tabspongedone_trn(i1+1:i2-1,j1+1:j2-1) = .TRUE. 
     101      ENDIF 
     102      !                  
     103   END SUBROUTINE interptrn_sponge 
    100104 
    101105#else 

  • branches/NERC/dev_r5589_is_oce_cpl/NEMOGCM/NEMO/NST_SRC/agrif_top_update.F90

    r4491 r5955  
    11#define TWO_WAY 
     2#undef DECAL_FEEDBACK 
    23 
    34MODULE agrif_top_update 
    … …  
    89   USE dom_oce 
    910   USE agrif_oce 
     11   USE par_trc 
    1012   USE trc 
    1113   USE wrk_nemo   
    … …  
    2426   !!---------------------------------------------------------------------- 
    2527 
    26    CONTAINS 
     28CONTAINS 
    2729 
    2830   SUBROUTINE Agrif_Update_Trc( kt ) 
    … …  
    3032      !!   *** ROUTINE Agrif_Update_Trc *** 
    3133      !!--------------------------------------------- 
    32       !! 
    3334      INTEGER, INTENT(in) :: kt 
    34       REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztra 
    35  
    36    
    37       IF ((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) RETURN 
    38  
    39 #if defined TWO_WAY 
    40       CALL wrk_alloc( jpi, jpj, jpk, jptra, ztra ) 
    41  
     35      !!--------------------------------------------- 
     36      !  
     37      IF((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) RETURN 
     38#if defined TWO_WAY    
    4239      Agrif_UseSpecialValueInUpdate = .TRUE. 
    4340      Agrif_SpecialValueFineGrid = 0. 
    44   
    45      IF (MOD(nbcline_trc,nbclineupdate) == 0) THEN 
    46          CALL Agrif_Update_Variable(ztra,trn_id, procname=updateTRC) 
     41      !  
     42      IF (MOD(nbcline_trc,nbclineupdate) == 0) THEN 
     43# if ! defined DECAL_FEEDBACK 
     44         CALL Agrif_Update_Variable(trn_id, procname=updateTRC) 
     45# else 
     46         CALL Agrif_Update_Variable(trn_id, locupdate=(/1,0/),procname=updateTRC) 
     47# endif 
    4748      ELSE 
    48          CALL Agrif_Update_Variable(ztra,trn_id,locupdate=(/0,2/), procname=updateTRC) 
     49# if ! defined DECAL_FEEDBACK 
     50         CALL Agrif_Update_Variable(trn_id,locupdate=(/0,2/), procname=updateTRC) 
     51# else 
     52         CALL Agrif_Update_Variable(trn_id,locupdate=(/1,2/), procname=updateTRC) 
     53# endif 
    4954      ENDIF 
    50  
     55      ! 
    5156      Agrif_UseSpecialValueInUpdate = .FALSE. 
    5257      nbcline_trc = nbcline_trc + 1 
    53  
    54       CALL wrk_dealloc( jpi, jpj, jpk, jptra, ztra ) 
    5558#endif 
    56  
     59      ! 
    5760   END SUBROUTINE Agrif_Update_Trc 
    5861 
    59    SUBROUTINE updateTRC(tabres,i1,i2,j1,j2,k1,k2,n1,n2,before) 
     62   SUBROUTINE updateTRC( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before ) 
    6063      !!--------------------------------------------- 
    61       !!   *** ROUTINE UpdateTrc *** 
     64      !!           *** ROUTINE updateT *** 
    6265      !!--------------------------------------------- 
     66#  include "domzgr_substitute.h90" 
    6367      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
    64       REAL, DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 
     68      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab 
    6569      LOGICAL, INTENT(in) :: before 
    66     
     70      !! 
    6771      INTEGER :: ji,jj,jk,jn 
    68  
    69          IF( before ) THEN 
    70             DO jn = n1, n2 
    71                DO jk = k1, k2 
    72                   DO jj = j1, j2 
    73                      DO ji = i1, i2 
    74                         tabres(ji,jj,jk,jn) = trn(ji,jj,jk,jn) 
    75                      ENDDO 
    76                   ENDDO 
    77                ENDDO 
    78             ENDDO 
    79          ELSE 
    80             IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 
     72      !!--------------------------------------------- 
     73      ! 
     74      IF (before) THEN 
     75         DO jn = n1,n2 
     76            DO jk=k1,k2 
     77               DO jj=j1,j2 
     78                  DO ji=i1,i2 
     79                     ptab(ji,jj,jk,jn) = trn(ji,jj,jk,jn) 
     80                  END DO 
     81               END DO 
     82            END DO 
     83         END DO 
     84      ELSE 
     85         IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 
    8186            ! Add asselin part 
    82                DO jn = n1, n2 
    83                   DO jk = k1, k2 
    84                      DO jj = j1, j2 
    85                         DO ji = i1, i2 
    86                            IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN 
    87                               trb(ji,jj,jk,jn) = trb(ji,jj,jk,jn) &  
    88                                  & + atfp * ( tabres(ji,jj,jk,jn) & 
    89                                                - trn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 
    90                            ENDIF 
    91                         ENDDO 
    92                      ENDDO 
    93                   ENDDO 
    94                ENDDO 
    95             ENDIF 
    96  
    97             DO jn = n1, n2 
    98                DO jk = k1, k2 
    99                   DO jj = j1, j2 
    100                      DO ji = i1, i2 
    101                         IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN 
    102                            trn(ji,jj,jk,jn) = tabres(ji,jj,jk,jn) * tmask(ji,jj,jk) 
     87            DO jn = n1,n2 
     88               DO jk=k1,k2 
     89                  DO jj=j1,j2 
     90                     DO ji=i1,i2 
     91                        IF( ptab(ji,jj,jk,jn) .NE. 0. ) THEN 
     92                           trb(ji,jj,jk,jn) = trb(ji,jj,jk,jn) &  
     93                                 & + atfp * ( ptab(ji,jj,jk,jn) & 
     94                                 &             - trn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 
    10395                        ENDIF 
    10496                     ENDDO 
    … …  
    10799            ENDDO 
    108100         ENDIF 
    109  
     101         DO jn = n1,n2 
     102            DO jk=k1,k2 
     103               DO jj=j1,j2 
     104                  DO ji=i1,i2 
     105                     IF( ptab(ji,jj,jk,jn) .NE. 0. ) THEN  
     106                        trn(ji,jj,jk,jn) = ptab(ji,jj,jk,jn) * tmask(ji,jj,jk) 
     107                     END IF 
     108                  END DO 
     109               END DO 
     110            END DO 
     111         END DO 
     112      ENDIF 
     113      !  
    110114   END SUBROUTINE updateTRC 
    111115 
    … …  
    119123   END SUBROUTINE agrif_top_update_empty 
    120124#endif 
    121 END Module agrif_top_update 
     125END MODULE agrif_top_update 

  • branches/NERC/dev_r5589_is_oce_cpl/NEMOGCM/NEMO/NST_SRC/agrif_user.F90

    r5573 r5955  
    3030      jpi     = ( jpiglo-2*jpreci + (jpni-1+0) ) / jpni + 2*jpreci 
    3131      jpj     = ( jpjglo-2*jprecj + (jpnj-1+0) ) / jpnj + 2*jprecj 
    32       jpk     = jpkdta  
     32! JC: change to allow for different vertical levels 
     33!     jpk is already set 
     34!     keep it jpk possibly different from jpkdta which  
     35!     hold parent grid vertical levels number (set earlier) 
     36!      jpk     = jpkdta  
    3337      jpim1   = jpi-1  
    3438      jpjm1   = jpj-1  
    … …  
    6367   ! 0. Initializations 
    6468   !------------------- 
    65    IF( cp_cfg == 'orca' ) then 
     69   IF( cp_cfg == 'orca' ) THEN 
    6670      IF ( jp_cfg == 2 .OR. jp_cfg == 025 .OR. jp_cfg == 05 & 
    67   &                      .OR. jp_cfg == 4 ) THEN 
     71            &                      .OR. jp_cfg == 4 ) THEN 
    6872         jp_cfg = -1    ! set special value for jp_cfg on fine grids 
    6973         cp_cfg = "default" 
    … …  
    100104   USE dom_oce 
    101105   USE nemogcm 
    102    USE sol_oce 
    103106   USE in_out_manager 
    104107   USE agrif_opa_update 
    … …  
    119122SUBROUTINE agrif_declare_var_dom 
    120123   !!---------------------------------------------------------------------- 
    121    !!                 *** ROUTINE agrif_declarE_var *** 
     124   !!                 *** ROUTINE agrif_declare_var *** 
    122125   !! 
    123126   !! ** Purpose :: Declaration of variables to be interpolated 
    124127   !!---------------------------------------------------------------------- 
    125128   USE agrif_util 
    126    USE par_oce       !   ONLY : jpts 
     129   USE par_oce        
    127130   USE oce 
    128131   IMPLICIT NONE 
    … …  
    131134   ! 1. Declaration of the type of variable which have to be interpolated 
    132135   !--------------------------------------------------------------------- 
    133    CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),e1u_id) 
    134    CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/jpi,jpj/),e2v_id) 
    135  
     136   CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),e1u_id) 
     137   CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),e2v_id) 
    136138 
    137139   ! 2. Type of interpolation 
    138140   !------------------------- 
    139    Call Agrif_Set_bcinterp(e1u_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    140    Call Agrif_Set_bcinterp(e2v_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     141   CALL Agrif_Set_bcinterp(e1u_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
     142   CALL Agrif_Set_bcinterp(e2v_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
    141143 
    142144   ! 3. Location of interpolation 
    143145   !----------------------------- 
    144    Call Agrif_Set_bc(e1u_id,(/0,0/)) 
    145    Call Agrif_Set_bc(e2v_id,(/0,0/)) 
     146   CALL Agrif_Set_bc(e1u_id,(/0,0/)) 
     147   CALL Agrif_Set_bc(e2v_id,(/0,0/)) 
    146148 
    147149   ! 5. Update type 
    148150   !---------------  
    149    Call Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Copy, update2=Agrif_Update_Average) 
    150    Call Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Average, update2=Agrif_Update_Copy) 
    151  
     151   CALL Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Copy, update2=Agrif_Update_Average) 
     152   CALL Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Average, update2=Agrif_Update_Copy) 
     153 
     154! High order updates 
     155!   CALL Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Average,            update2=Agrif_Update_Full_Weighting) 
     156!   CALL Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Full_Weighting,     update2=Agrif_Update_Average) 
     157    ! 
    152158END SUBROUTINE agrif_declare_var_dom 
    153159 
    … …  
    165171   USE dom_oce 
    166172   USE nemogcm 
    167    USE sol_oce 
     173   USE lib_mpp 
    168174   USE in_out_manager 
    169175   USE agrif_opa_update 
    … …  
    173179   IMPLICIT NONE 
    174180   ! 
    175    REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: tabtstemp 
    176    REAL(wp), DIMENSION(:,:,:  ), ALLOCATABLE :: tabuvtemp 
    177    REAL(wp), DIMENSION(:,:    ), ALLOCATABLE :: tab2d 
    178181   LOGICAL :: check_namelist 
    179    !!---------------------------------------------------------------------- 
    180  
    181    ALLOCATE( tabtstemp(jpi, jpj, jpk, jpts) ) 
    182    ALLOCATE( tabuvtemp(jpi, jpj, jpk)       ) 
    183    ALLOCATE( tab2d(jpi, jpj)                ) 
    184  
     182   CHARACTER(len=15) :: cl_check1, cl_check2, cl_check3 
     183   !!---------------------------------------------------------------------- 
    185184 
    186185   ! 1. Declaration of the type of variable which have to be interpolated 
    … …  
    192191   Agrif_SpecialValue=0. 
    193192   Agrif_UseSpecialValue = .TRUE. 
    194    Call Agrif_Bc_variable(tabtstemp,tsn_id,calledweight=1.,procname=interptsn) 
    195    Call Agrif_Bc_variable(tabtstemp,tsa_id,calledweight=1.,procname=interptsn) 
    196  
    197    Call Agrif_Bc_variable(tabuvtemp,un_id,calledweight=1.,procname=interpu) 
    198    Call Agrif_Bc_variable(tabuvtemp,vn_id,calledweight=1.,procname=interpv) 
    199    Call Agrif_Bc_variable(tabuvtemp,ua_id,calledweight=1.,procname=interpun) 
    200    Call Agrif_Bc_variable(tabuvtemp,va_id,calledweight=1.,procname=interpvn) 
    201  
    202    Call Agrif_Bc_variable(tab2d,unb_id,calledweight=1.,procname=interpunb) 
    203    Call Agrif_Bc_variable(tab2d,vnb_id,calledweight=1.,procname=interpvnb) 
    204    Call Agrif_Bc_variable(tab2d,sshn_id,calledweight=1.,procname=interpsshn) 
    205    Agrif_UseSpecialValue = .FALSE. 
     193   CALL Agrif_Bc_variable(tsn_id,calledweight=1.,procname=interptsn) 
     194   CALL Agrif_Sponge 
     195   tabspongedone_tsn = .FALSE. 
     196   CALL Agrif_Bc_variable(tsn_sponge_id,calledweight=1.,procname=interptsn_sponge) 
     197   ! reset tsa to zero 
     198   tsa(:,:,:,:) = 0. 
     199 
     200   Agrif_UseSpecialValue = ln_spc_dyn 
     201   CALL Agrif_Bc_variable(un_interp_id,calledweight=1.,procname=interpun) 
     202   CALL Agrif_Bc_variable(vn_interp_id,calledweight=1.,procname=interpvn) 
     203   tabspongedone_u = .FALSE. 
     204   tabspongedone_v = .FALSE. 
     205   CALL Agrif_Bc_variable(un_sponge_id,calledweight=1.,procname=interpun_sponge) 
     206   tabspongedone_u = .FALSE. 
     207   tabspongedone_v = .FALSE. 
     208   CALL Agrif_Bc_variable(vn_sponge_id,calledweight=1.,procname=interpvn_sponge) 
     209 
     210   Agrif_UseSpecialValue = .TRUE. 
     211   CALL Agrif_Bc_variable(sshn_id,calledweight=1., procname=interpsshn ) 
     212 
     213   IF ( ln_dynspg_ts ) THEN 
     214      Agrif_UseSpecialValue = ln_spc_dyn 
     215      CALL Agrif_Bc_variable(unb_id,calledweight=1.,procname=interpunb) 
     216      CALL Agrif_Bc_variable(vnb_id,calledweight=1.,procname=interpvnb) 
     217      CALL Agrif_Bc_variable(ub2b_interp_id,calledweight=1.,procname=interpub2b) 
     218      CALL Agrif_Bc_variable(vb2b_interp_id,calledweight=1.,procname=interpvb2b) 
     219      ubdy_w(:) = 0.e0 ; vbdy_w(:) = 0.e0 ; hbdy_w(:) =0.e0 
     220      ubdy_e(:) = 0.e0 ; vbdy_e(:) = 0.e0 ; hbdy_e(:) =0.e0  
     221      ubdy_n(:) = 0.e0 ; vbdy_n(:) = 0.e0 ; hbdy_n(:) =0.e0  
     222      ubdy_s(:) = 0.e0 ; vbdy_s(:) = 0.e0 ; hbdy_s(:) =0.e0 
     223   ENDIF 
     224 
     225   Agrif_UseSpecialValue = .FALSE.  
     226   ! reset velocities to zero 
     227   ua(:,:,:) = 0. 
     228   va(:,:,:) = 0. 
    206229 
    207230   ! 3. Some controls 
    208231   !----------------- 
    209    check_namelist = .true. 
    210  
    211    IF( check_namelist ) THEN 
     232   check_namelist = .TRUE. 
     233 
     234   IF( check_namelist ) THEN  
    212235 
    213236      ! Check time steps            
    214       IF( NINT(Agrif_Rhot()) * nint(rdt) /= Agrif_Parent(rdt) ) THEN 
    215          WRITE(*,*) 'incompatible time step between grids' 
    216          WRITE(*,*) 'parent grid value : ',Agrif_Parent(rdt) 
    217          WRITE(*,*) 'child  grid value : ',nint(rdt) 
    218          WRITE(*,*) 'value on parent grid should be : ',rdt*Agrif_Rhot() 
    219          STOP 
     237      IF( NINT(Agrif_Rhot()) * NINT(rdt) .NE. Agrif_Parent(rdt) ) THEN 
     238         WRITE(cl_check1,*)  NINT(Agrif_Parent(rdt)) 
     239         WRITE(cl_check2,*)  NINT(rdt) 
     240         WRITE(cl_check3,*)  NINT(Agrif_Parent(rdt)/Agrif_Rhot()) 
     241         CALL ctl_warn( 'incompatible time step between grids',   & 
     242               &               'parent grid value : '//cl_check1    ,   &  
     243               &               'child  grid value : '//cl_check2    ,   &  
     244               &               'value on child grid will be changed to : '//cl_check3 ) 
     245         rdt=Agrif_Parent(rdt)/Agrif_Rhot() 
    220246      ENDIF 
    221247 
    222248      ! Check run length 
    223249      IF( Agrif_IRhot() * (Agrif_Parent(nitend)- & 
    224            Agrif_Parent(nit000)+1) .ne. (nitend-nit000+1) ) THEN 
    225          WRITE(*,*) 'incompatible run length between grids' 
    226          WRITE(*,*) 'parent grid value : ',(Agrif_Parent(nitend)- & 
    227               Agrif_Parent(nit000)+1),' time step' 
    228          WRITE(*,*) 'child  grid value : ', & 
    229               (nitend-nit000+1),' time step' 
    230          WRITE(*,*) 'value on child grid should be : ', & 
    231               Agrif_IRhot() * (Agrif_Parent(nitend)- & 
    232               Agrif_Parent(nit000)+1) 
    233          STOP 
     250            Agrif_Parent(nit000)+1) .NE. (nitend-nit000+1) ) THEN 
     251         WRITE(cl_check1,*)  (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 
     252         WRITE(cl_check2,*)   Agrif_Parent(nitend)   *Agrif_IRhot() 
     253         CALL ctl_warn( 'incompatible run length between grids'               ,   & 
     254               &              ' nit000 on fine grid will be change to : '//cl_check1,   & 
     255               &              ' nitend on fine grid will be change to : '//cl_check2    ) 
     256         nit000 = (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 
     257         nitend =  Agrif_Parent(nitend)   *Agrif_IRhot() 
    234258      ENDIF 
    235259 
    … …  
    237261      IF( ln_zps ) THEN 
    238262         ! check parameters for partial steps  
    239          IF( Agrif_Parent(e3zps_min) .ne. e3zps_min ) THEN 
     263         IF( Agrif_Parent(e3zps_min) .NE. e3zps_min ) THEN 
    240264            WRITE(*,*) 'incompatible e3zps_min between grids' 
    241265            WRITE(*,*) 'parent grid :',Agrif_Parent(e3zps_min) 
    … …  
    252276         ENDIF 
    253277      ENDIF 
     278 
     279      ! Check free surface scheme 
     280      IF ( ( Agrif_Parent(ln_dynspg_ts ).AND.ln_dynspg_exp ).OR.& 
     281         & ( Agrif_Parent(ln_dynspg_exp).AND.ln_dynspg_ts ) ) THEN 
     282         WRITE(*,*) 'incompatible free surface scheme between grids' 
     283         WRITE(*,*) 'parent grid ln_dynspg_ts  :', Agrif_Parent(ln_dynspg_ts ) 
     284         WRITE(*,*) 'parent grid ln_dynspg_exp :', Agrif_Parent(ln_dynspg_exp) 
     285         WRITE(*,*) 'child grid  ln_dynspg_ts  :', ln_dynspg_ts 
     286         WRITE(*,*) 'child grid  ln_dynspg_exp :', ln_dynspg_exp 
     287         WRITE(*,*) 'those logicals should be identical'                   
     288         STOP 
     289      ENDIF 
     290 
     291      ! check if masks and bathymetries match 
     292      IF(ln_chk_bathy) THEN 
     293         ! 
     294         IF(lwp) WRITE(numout,*) 'AGRIF: Check Bathymetry and masks near bdys. Level: ', Agrif_Level() 
     295         ! 
     296         kindic_agr = 0 
     297         ! check if umask agree with parent along western and eastern boundaries: 
     298         CALL Agrif_Bc_variable(umsk_id,calledweight=1.,procname=interpumsk) 
     299         ! check if vmask agree with parent along northern and southern boundaries: 
     300         CALL Agrif_Bc_variable(vmsk_id,calledweight=1.,procname=interpvmsk) 
     301    ! check if tmask and vertical scale factors agree with parent over first two coarse grid points: 
     302         CALL Agrif_Bc_variable(e3t_id,calledweight=1.,procname=interpe3t) 
     303         ! 
     304         IF (lk_mpp) CALL mpp_sum( kindic_agr ) 
     305         IF( kindic_agr /= 0 ) THEN                    
     306            CALL ctl_stop('Child Bathymetry is not correct near boundaries.') 
     307         ELSE 
     308            IF(lwp) WRITE(numout,*) 'Child Bathymetry is ok near boundaries.' 
     309         END IF 
     310      ENDIF 
     311      ! 
    254312   ENDIF 
    255  
    256    CALL Agrif_Update_tra(0) 
    257    CALL Agrif_Update_dyn(0) 
    258  
    259    nbcline = 0 
    260    ! 
    261    DEALLOCATE(tabtstemp) 
    262    DEALLOCATE(tabuvtemp) 
    263    DEALLOCATE(tab2d) 
     313   !  
     314   ! Do update at initialisation because not done before writing restarts 
     315   ! This would indeed change boundary conditions values at initial time 
     316   ! hence produce restartability issues. 
     317   ! Note that update below is recursive (with lk_agrif_doupd=T): 
     318   !  
     319! JC: I am not sure if Agrif_MaxLevel() is the "relative" 
     320!     or the absolute maximum nesting level...TBC                         
     321   IF ( Agrif_Level().EQ.Agrif_MaxLevel() ) THEN  
     322      ! NB: Do tracers first, dynamics after because nbcline incremented in dynamics 
     323      CALL Agrif_Update_tra() 
     324      CALL Agrif_Update_dyn() 
     325   ENDIF 
     326   ! 
     327# if defined key_zdftke 
     328   CALL Agrif_Update_tke(0) 
     329# endif 
     330   ! 
     331   Agrif_UseSpecialValueInUpdate = .FALSE. 
     332   nbcline = 0  
     333   lk_agrif_doupd = .FALSE. 
    264334   ! 
    265335END SUBROUTINE Agrif_InitValues_cont 
    … …  
    275345   USE par_oce       !   ONLY : jpts 
    276346   USE oce 
     347   USE agrif_oce 
    277348   IMPLICIT NONE 
    278349   !!---------------------------------------------------------------------- 
    … …  
    280351   ! 1. Declaration of the type of variable which have to be interpolated 
    281352   !--------------------------------------------------------------------- 
    282    CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts/),tsn_id) 
    283    CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts/),tsa_id) 
    284    CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts/),tsb_id) 
    285  
    286    CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),un_id) 
    287    CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),vn_id) 
    288    CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),ua_id) 
    289    CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),va_id) 
    290  
    291    CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),unb_id) 
    292    CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/jpi,jpj/),vnb_id) 
    293    CALL agrif_declare_variable((/2,2/),(/3,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),sshn_id) 
    294    CALL agrif_declare_variable((/2,2/),(/3,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),gcb_id) 
    295    CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),ub2b_id) 
    296    CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/jpi,jpj/),vb2b_id) 
     353   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) 
     354   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) 
     355 
     356   CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),un_interp_id) 
     357   CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vn_interp_id) 
     358   CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),un_update_id) 
     359   CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vn_update_id) 
     360   CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),un_sponge_id) 
     361   CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vn_sponge_id) 
     362 
     363   CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),e3t_id) 
     364   CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),umsk_id) 
     365   CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vmsk_id) 
     366 
     367   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) 
     368 
     369   CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),unb_id) 
     370   CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vnb_id) 
     371   CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ub2b_interp_id) 
     372   CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vb2b_interp_id) 
     373   CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ub2b_update_id) 
     374   CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vb2b_update_id) 
     375 
     376   CALL agrif_declare_variable((/2,2/),(/3,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),sshn_id) 
     377 
     378# if defined key_zdftke 
     379   CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/), en_id) 
     380   CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avt_id) 
     381   CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avm_id) 
     382# endif 
    297383 
    298384   ! 2. Type of interpolation 
    299385   !------------------------- 
    300386   CALL Agrif_Set_bcinterp(tsn_id,interp=AGRIF_linear) 
    301    CALL Agrif_Set_bcinterp(tsa_id,interp=AGRIF_linear) 
    302  
    303    Call Agrif_Set_bcinterp(un_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    304    Call Agrif_Set_bcinterp(vn_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
    305  
    306    Call Agrif_Set_bcinterp(ua_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    307    Call Agrif_Set_bcinterp(va_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     387 
     388   CALL Agrif_Set_bcinterp(un_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
     389   CALL Agrif_Set_bcinterp(vn_interp_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     390 
     391   CALL Agrif_Set_bcinterp(tsn_sponge_id,interp=AGRIF_linear) 
    308392 
    309393   CALL Agrif_Set_bcinterp(sshn_id,interp=AGRIF_linear) 
    310    Call Agrif_Set_bcinterp(unb_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    311    Call Agrif_Set_bcinterp(vnb_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
    312    Call Agrif_Set_bcinterp(ub2b_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    313    Call Agrif_Set_bcinterp(vb2b_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     394   CALL Agrif_Set_bcinterp(unb_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
     395   CALL Agrif_Set_bcinterp(vnb_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     396   CALL Agrif_Set_bcinterp(ub2b_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
     397   CALL Agrif_Set_bcinterp(vb2b_interp_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     398 
     399 
     400   CALL Agrif_Set_bcinterp(un_sponge_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
     401   CALL Agrif_Set_bcinterp(vn_sponge_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     402 
     403   CALL Agrif_Set_bcinterp(e3t_id,interp=AGRIF_constant) 
     404   CALL Agrif_Set_bcinterp(umsk_id,interp=AGRIF_constant) 
     405   CALL Agrif_Set_bcinterp(vmsk_id,interp=AGRIF_constant) 
     406 
     407# if defined key_zdftke 
     408   CALL Agrif_Set_bcinterp(avm_id ,interp=AGRIF_linear) 
     409# endif 
     410 
    314411 
    315412   ! 3. Location of interpolation 
    316413   !----------------------------- 
    317    Call Agrif_Set_bc(un_id,(/0,1/)) 
    318    Call Agrif_Set_bc(vn_id,(/0,1/)) 
    319  
    320    Call Agrif_Set_bc(sshn_id,(/0,1/)) 
    321    Call Agrif_Set_bc(unb_id,(/0,1/)) 
    322    Call Agrif_Set_bc(vnb_id,(/0,1/)) 
    323    Call Agrif_Set_bc(ub2b_id,(/0,1/)) 
    324    Call Agrif_Set_bc(vb2b_id,(/0,1/)) 
    325  
    326    Call Agrif_Set_bc(tsn_id,(/0,1/)) 
    327    Call Agrif_Set_bc(tsa_id,(/-3*Agrif_irhox(),0/)) 
    328  
    329    Call Agrif_Set_bc(ua_id,(/-2*Agrif_irhox(),0/)) 
    330    Call Agrif_Set_bc(va_id,(/-2*Agrif_irhox(),0/)) 
     414   CALL Agrif_Set_bc(tsn_id,(/0,1/)) 
     415   CALL Agrif_Set_bc(un_interp_id,(/0,1/)) 
     416   CALL Agrif_Set_bc(vn_interp_id,(/0,1/)) 
     417 
     418!   CALL Agrif_Set_bc(tsn_sponge_id,(/-3*Agrif_irhox(),0/)) 
     419!   CALL Agrif_Set_bc(un_sponge_id,(/-2*Agrif_irhox()-1,0/)) 
     420!   CALL Agrif_Set_bc(vn_sponge_id,(/-2*Agrif_irhox()-1,0/)) 
     421   CALL Agrif_Set_bc(tsn_sponge_id,(/-nn_sponge_len*Agrif_irhox()-1,0/)) 
     422   CALL Agrif_Set_bc(un_sponge_id ,(/-nn_sponge_len*Agrif_irhox()-1,0/)) 
     423   CALL Agrif_Set_bc(vn_sponge_id ,(/-nn_sponge_len*Agrif_irhox()-1,0/)) 
     424 
     425   CALL Agrif_Set_bc(sshn_id,(/0,0/)) 
     426   CALL Agrif_Set_bc(unb_id ,(/0,0/)) 
     427   CALL Agrif_Set_bc(vnb_id ,(/0,0/)) 
     428   CALL Agrif_Set_bc(ub2b_interp_id,(/0,0/)) 
     429   CALL Agrif_Set_bc(vb2b_interp_id,(/0,0/)) 
     430 
     431   CALL Agrif_Set_bc(e3t_id,(/-2*Agrif_irhox()-1,0/))   ! if west and rhox=3: column 2 to 9 
     432   CALL Agrif_Set_bc(umsk_id,(/0,0/)) 
     433   CALL Agrif_Set_bc(vmsk_id,(/0,0/)) 
     434 
     435# if defined key_zdftke 
     436   CALL Agrif_Set_bc(avm_id ,(/0,1/)) 
     437# endif 
    331438 
    332439   ! 5. Update type 
    333440   !---------------  
    334    Call Agrif_Set_Updatetype(tsn_id, update = AGRIF_Update_Average) 
    335    Call Agrif_Set_Updatetype(tsb_id, update = AGRIF_Update_Average) 
    336  
    337    Call Agrif_Set_Updatetype(sshn_id, update = AGRIF_Update_Average) 
    338    Call Agrif_Set_Updatetype(gcb_id,update = AGRIF_Update_Average) 
    339  
    340    Call Agrif_Set_Updatetype(un_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 
    341    Call Agrif_Set_Updatetype(vn_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 
    342  
    343    Call Agrif_Set_Updatetype(ub2b_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 
    344    Call Agrif_Set_Updatetype(vb2b_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 
    345  
     441   CALL Agrif_Set_Updatetype(tsn_id, update = AGRIF_Update_Average) 
     442 
     443   CALL Agrif_Set_Updatetype(scales_t_id, update = AGRIF_Update_Average) 
     444 
     445   CALL Agrif_Set_Updatetype(un_update_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 
     446   CALL Agrif_Set_Updatetype(vn_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 
     447 
     448   CALL Agrif_Set_Updatetype(sshn_id, update = AGRIF_Update_Average) 
     449 
     450   CALL Agrif_Set_Updatetype(ub2b_update_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 
     451   CALL Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 
     452 
     453# if defined key_zdftke 
     454   CALL Agrif_Set_Updatetype( en_id, update = AGRIF_Update_Average) 
     455   CALL Agrif_Set_Updatetype(avt_id, update = AGRIF_Update_Average) 
     456   CALL Agrif_Set_Updatetype(avm_id, update = AGRIF_Update_Average) 
     457# endif 
     458 
     459! High order updates 
     460!   CALL Agrif_Set_Updatetype(tsn_id, update = Agrif_Update_Full_Weighting) 
     461!   CALL Agrif_Set_Updatetype(un_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Full_Weighting) 
     462!   CALL Agrif_Set_Updatetype(vn_update_id,update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average) 
     463! 
     464!   CALL Agrif_Set_Updatetype(ub2b_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Full_Weighting) 
     465!   CALL Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average) 
     466!   CALL Agrif_Set_Updatetype(sshn_id, update = Agrif_Update_Full_Weighting) 
     467  
     468   ! 
    346469END SUBROUTINE agrif_declare_var 
    347470# endif 
    … …  
    364487   IMPLICIT NONE 
    365488   ! 
    366    REAL(wp), DIMENSION(:,:)  , ALLOCATABLE :: zvel 
    367    REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zadv 
    368    !!---------------------------------------------------------------------- 
    369  
    370    ALLOCATE( zvel(jpi,jpj), zadv(jpi,jpj,7)) 
     489   !!---------------------------------------------------------------------- 
    371490 
    372491   ! 1. Declaration of the type of variable which have to be interpolated 
    … …  
    400519   CALL Agrif_Update_lim2(0) 
    401520   ! 
    402    DEALLOCATE( zvel, zadv ) 
    403    ! 
    404521END SUBROUTINE Agrif_InitValues_cont_lim2 
    405522 
    … …  
    430547   !------------------------- 
    431548   CALL Agrif_Set_bcinterp(adv_ice_id ,interp=AGRIF_linear) 
    432    Call Agrif_Set_bcinterp(u_ice_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    433    Call Agrif_Set_bcinterp(v_ice_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     549   CALL Agrif_Set_bcinterp(u_ice_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
     550   CALL Agrif_Set_bcinterp(v_ice_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
    434551 
    435552   ! 3. Location of interpolation 
    436553   !----------------------------- 
    437    Call Agrif_Set_bc(adv_ice_id ,(/0,1/)) 
    438    Call Agrif_Set_bc(u_ice_id,(/0,1/)) 
    439    Call Agrif_Set_bc(v_ice_id,(/0,1/)) 
     554   CALL Agrif_Set_bc(adv_ice_id ,(/0,1/)) 
     555   CALL Agrif_Set_bc(u_ice_id,(/0,1/)) 
     556   CALL Agrif_Set_bc(v_ice_id,(/0,1/)) 
    440557 
    441558   ! 5. Update type 
    442559   !--------------- 
    443    Call Agrif_Set_Updatetype(adv_ice_id , update = AGRIF_Update_Average) 
    444    Call Agrif_Set_Updatetype(u_ice_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 
    445    Call Agrif_Set_Updatetype(v_ice_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 
    446  
     560   CALL Agrif_Set_Updatetype(adv_ice_id , update = AGRIF_Update_Average) 
     561   CALL Agrif_Set_Updatetype(u_ice_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 
     562   CALL Agrif_Set_Updatetype(v_ice_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 
     563   !  
    447564END SUBROUTINE agrif_declare_var_lim2 
    448565#  endif 
    … …  
    461578   USE nemogcm 
    462579   USE par_trc 
     580   USE lib_mpp 
    463581   USE trc 
    464582   USE in_out_manager 
     583   USE agrif_opa_sponge 
    465584   USE agrif_top_update 
    466585   USE agrif_top_interp 
    … …  
    469588   IMPLICIT NONE 
    470589   ! 
    471    REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: tabtrtemp 
     590   CHARACTER(len=10) :: cl_check1, cl_check2, cl_check3 
    472591   LOGICAL :: check_namelist 
    473592   !!---------------------------------------------------------------------- 
    474  
    475    ALLOCATE( tabtrtemp(jpi,jpj,jpk,jptra) ) 
    476593 
    477594 
    … …  
    484601   Agrif_SpecialValue=0. 
    485602   Agrif_UseSpecialValue = .TRUE. 
    486    Call Agrif_Bc_variable(tabtrtemp,trn_id,calledweight=1.,procname=interptrn) 
    487    Call Agrif_Bc_variable(tabtrtemp,tra_id,calledweight=1.,procname=interptrn) 
     603   CALL Agrif_Bc_variable(trn_id,calledweight=1.,procname=interptrn) 
    488604   Agrif_UseSpecialValue = .FALSE. 
     605   CALL Agrif_Sponge 
     606   tabspongedone_trn = .FALSE. 
     607   CALL Agrif_Bc_variable(trn_sponge_id,calledweight=1.,procname=interptrn_sponge) 
     608   ! reset tsa to zero 
     609   tra(:,:,:,:) = 0. 
     610 
    489611 
    490612   ! 3. Some controls 
    491613   !----------------- 
    492    check_namelist = .true. 
     614   check_namelist = .TRUE. 
    493615 
    494616   IF( check_namelist ) THEN 
    495 #  if defined offline      
     617# if defined key_offline 
    496618      ! Check time steps 
    497       IF( nint(Agrif_Rhot()) * nint(rdt) .ne. Agrif_Parent(rdt) ) THEN 
    498          WRITE(*,*) 'incompatible time step between grids' 
    499          WRITE(*,*) 'parent grid value : ',Agrif_Parent(rdt) 
    500          WRITE(*,*) 'child  grid value : ',nint(rdt) 
    501          WRITE(*,*) 'value on parent grid should be : ',rdt*Agrif_Rhot() 
    502          STOP 
     619      IF( NINT(Agrif_Rhot()) * NINT(rdt) .NE. Agrif_Parent(rdt) ) THEN 
     620         WRITE(cl_check1,*)  Agrif_Parent(rdt) 
     621         WRITE(cl_check2,*)  rdt 
     622         WRITE(cl_check3,*)  rdt*Agrif_Rhot() 
     623         CALL ctl_warn( 'incompatible time step between grids',   & 
     624               &               'parent grid value : '//cl_check1    ,   &  
     625               &               'child  grid value : '//cl_check2    ,   &  
     626               &               'value on child grid will be changed to  & 
     627               &               :'//cl_check3  ) 
     628         rdt=rdt*Agrif_Rhot() 
    503629      ENDIF 
    504630 
    505631      ! Check run length 
    506632      IF( Agrif_IRhot() * (Agrif_Parent(nitend)- & 
    507            Agrif_Parent(nit000)+1) .ne. (nitend-nit000+1) ) THEN 
    508          WRITE(*,*) 'incompatible run length between grids' 
    509          WRITE(*,*) 'parent grid value : ',(Agrif_Parent(nitend)- & 
    510               Agrif_Parent(nit000)+1),' time step' 
    511          WRITE(*,*) 'child  grid value : ', & 
    512               (nitend-nit000+1),' time step' 
    513          WRITE(*,*) 'value on child grid should be : ', & 
    514               Agrif_IRhot() * (Agrif_Parent(nitend)- & 
    515               Agrif_Parent(nit000)+1) 
    516          STOP 
     633            Agrif_Parent(nit000)+1) .NE. (nitend-nit000+1) ) THEN 
     634         WRITE(cl_check1,*)  (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 
     635         WRITE(cl_check2,*)   Agrif_Parent(nitend)   *Agrif_IRhot() 
     636         CALL ctl_warn( 'incompatible run length between grids'               ,   & 
     637               &              ' nit000 on fine grid will be change to : '//cl_check1,   & 
     638               &              ' nitend on fine grid will be change to : '//cl_check2    ) 
     639         nit000 = (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 
     640         nitend =  Agrif_Parent(nitend)   *Agrif_IRhot() 
    517641      ENDIF 
    518642 
    … …  
    520644      IF( ln_zps ) THEN 
    521645         ! check parameters for partial steps  
    522          IF( Agrif_Parent(e3zps_min) .ne. e3zps_min ) THEN 
     646         IF( Agrif_Parent(e3zps_min) .NE. e3zps_min ) THEN 
    523647            WRITE(*,*) 'incompatible e3zps_min between grids' 
    524648            WRITE(*,*) 'parent grid :',Agrif_Parent(e3zps_min) 
    … …  
    527651            STOP 
    528652         ENDIF 
    529          IF( Agrif_Parent(e3zps_rat) .ne. e3zps_rat ) THEN 
     653         IF( Agrif_Parent(e3zps_rat) .NE. e3zps_rat ) THEN 
    530654            WRITE(*,*) 'incompatible e3zps_rat between grids' 
    531655            WRITE(*,*) 'parent grid :',Agrif_Parent(e3zps_rat) 
    … …  
    537661#  endif          
    538662      ! Check passive tracer cell 
    539       IF( nn_dttrc .ne. 1 ) THEN 
     663      IF( nn_dttrc .NE. 1 ) THEN 
    540664         WRITE(*,*) 'nn_dttrc should be equal to 1' 
    541665      ENDIF 
    542666   ENDIF 
    543667 
    544 !ch   CALL Agrif_Update_trc(0) 
     668   CALL Agrif_Update_trc(0) 
     669   ! 
     670   Agrif_UseSpecialValueInUpdate = .FALSE. 
    545671   nbcline_trc = 0 
    546    ! 
    547    DEALLOCATE(tabtrtemp) 
    548672   ! 
    549673END SUBROUTINE Agrif_InitValues_cont_top 
    … …  
    557681   !!---------------------------------------------------------------------- 
    558682   USE agrif_util 
     683   USE agrif_oce 
    559684   USE dom_oce 
    560685   USE trc 
    … …  
    564689   ! 1. Declaration of the type of variable which have to be interpolated 
    565690   !--------------------------------------------------------------------- 
    566    CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra/),trn_id) 
    567    CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra/),trb_id) 
    568    CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra/),tra_id) 
     691   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) 
     692   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) 
    569693 
    570694   ! 2. Type of interpolation 
    571695   !------------------------- 
    572696   CALL Agrif_Set_bcinterp(trn_id,interp=AGRIF_linear) 
    573    CALL Agrif_Set_bcinterp(tra_id,interp=AGRIF_linear) 
     697   CALL Agrif_Set_bcinterp(trn_sponge_id,interp=AGRIF_linear) 
    574698 
    575699   ! 3. Location of interpolation 
    576700   !----------------------------- 
    577    Call Agrif_Set_bc(trn_id,(/0,1/)) 
    578    Call Agrif_Set_bc(tra_id,(/-3*Agrif_irhox(),0/)) 
     701   CALL Agrif_Set_bc(trn_id,(/0,1/)) 
     702!   CALL Agrif_Set_bc(trn_sponge_id,(/-3*Agrif_irhox(),0/)) 
     703   CALL Agrif_Set_bc(trn_sponge_id,(/-nn_sponge_len*Agrif_irhox()-1,0/)) 
    579704 
    580705   ! 5. Update type 
    581706   !---------------  
    582    Call Agrif_Set_Updatetype(trn_id, update = AGRIF_Update_Average) 
    583    Call Agrif_Set_Updatetype(trb_id, update = AGRIF_Update_Average) 
    584  
    585  
     707   CALL Agrif_Set_Updatetype(trn_id, update = AGRIF_Update_Average) 
     708 
     709!   Higher order update 
     710!   CALL Agrif_Set_Updatetype(tsn_id, update = Agrif_Update_Full_Weighting) 
     711 
     712   ! 
    586713END SUBROUTINE agrif_declare_var_top 
    587714# endif 
    … …  
    591718   !!   *** ROUTINE Agrif_detect *** 
    592719   !!---------------------------------------------------------------------- 
    593    USE Agrif_Types 
    594720   ! 
    595721   INTEGER, DIMENSION(2) :: ksizex 
    … …  
    613739   ! 
    614740   INTEGER  ::   ios                 ! Local integer output status for namelist read 
    615    NAMELIST/namagrif/ nn_cln_update, rn_sponge_tra, rn_sponge_dyn, ln_spc_dyn 
    616    !!---------------------------------------------------------------------- 
    617    ! 
    618       REWIND( numnam_ref )              ! Namelist namagrif in reference namelist : AGRIF zoom 
    619       READ  ( numnam_ref, namagrif, IOSTAT = ios, ERR = 901) 
    620 901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namagrif in reference namelist', lwp ) 
    621  
    622       REWIND( numnam_cfg )              ! Namelist namagrif in configuration namelist : AGRIF zoom 
    623       READ  ( numnam_cfg, namagrif, IOSTAT = ios, ERR = 902 ) 
    624 902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namagrif in configuration namelist', lwp ) 
    625       IF(lwm) WRITE ( numond, namagrif ) 
     741   INTEGER  ::   iminspon 
     742   NAMELIST/namagrif/ nn_cln_update, rn_sponge_tra, rn_sponge_dyn, ln_spc_dyn, ln_chk_bathy 
     743   !!-------------------------------------------------------------------------------------- 
     744   ! 
     745   REWIND( numnam_ref )              ! Namelist namagrif in reference namelist : AGRIF zoom 
     746   READ  ( numnam_ref, namagrif, IOSTAT = ios, ERR = 901) 
     747901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namagrif in reference namelist', lwp ) 
     748 
     749   REWIND( numnam_cfg )              ! Namelist namagrif in configuration namelist : AGRIF zoom 
     750   READ  ( numnam_cfg, namagrif, IOSTAT = ios, ERR = 902 ) 
     751902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namagrif in configuration namelist', lwp ) 
     752   IF(lwm) WRITE ( numond, namagrif ) 
    626753   ! 
    627754   IF(lwp) THEN                    ! control print 
    … …  
    634761      WRITE(numout,*) '      sponge coefficient for dynamics   rn_sponge_tra = ', rn_sponge_dyn, ' s' 
    635762      WRITE(numout,*) '      use special values for dynamics   ln_spc_dyn    = ', ln_spc_dyn 
     763      WRITE(numout,*) '      check bathymetry                  ln_chk_bathy  = ', ln_chk_bathy 
    636764      WRITE(numout,*)  
    637765   ENDIF 
    … …  
    642770   visc_dyn      = rn_sponge_dyn 
    643771   ! 
    644    IF( agrif_oce_alloc()  > 0 )   CALL ctl_warn('agrif sol_oce_alloc: allocation of arrays failed') 
     772   ! Check sponge length: 
     773   iminspon = MIN(FLOOR(REAL(jpiglo-4)/REAL(2*Agrif_irhox())), FLOOR(REAL(jpjglo-4)/REAL(2*Agrif_irhox())) ) 
     774   IF (lk_mpp) iminspon = MIN(iminspon,FLOOR(REAL(jpi-2)/REAL(Agrif_irhox())), FLOOR(REAL(jpj-2)/REAL(Agrif_irhox())) ) 
     775   IF (nn_sponge_len > iminspon)  CALL ctl_stop('agrif sponge length is too large') 
     776   ! 
     777   IF( agrif_oce_alloc()  > 0 )   CALL ctl_warn('agrif agrif_oce_alloc: allocation of arrays failed') 
    645778# if defined key_lim2 
    646779   IF( agrif_ice_alloc()  > 0 )   CALL ctl_stop('agrif agrif_ice_alloc: allocation of arrays failed') 
    … …  
    663796   SELECT CASE( i ) 
    664797   CASE(1)   ;   indglob = indloc + nimppt(nprocloc+1) - 1 
    665    CASE(2)   ;   indglob = indloc + njmppt(nprocloc+1) - 1  
    666    CASE(3)   ;   indglob = indloc 
    667    CASE(4)   ;   indglob = indloc 
     798   CASE(2)   ;   indglob = indloc + njmppt(nprocloc+1) - 1 
     799   CASE DEFAULT 
     800      indglob = indloc 
    668801   END SELECT 
    669802   ! 
    670803END SUBROUTINE Agrif_InvLoc 
     804 
     805SUBROUTINE Agrif_get_proc_info( imin, imax, jmin, jmax ) 
     806   !!---------------------------------------------------------------------- 
     807   !!                 *** ROUTINE Agrif_get_proc_info *** 
     808   !!---------------------------------------------------------------------- 
     809   USE par_oce 
     810   IMPLICIT NONE 
     811   ! 
     812   INTEGER, INTENT(out) :: imin, imax 
     813   INTEGER, INTENT(out) :: jmin, jmax 
     814   !!---------------------------------------------------------------------- 
     815   ! 
     816   imin = nimppt(Agrif_Procrank+1)  ! ????? 
     817   jmin = njmppt(Agrif_Procrank+1)  ! ????? 
     818   imax = imin + jpi - 1 
     819   jmax = jmin + jpj - 1 
     820   !  
     821END SUBROUTINE Agrif_get_proc_info 
     822 
     823SUBROUTINE Agrif_estimate_parallel_cost(imin, imax,jmin, jmax, nbprocs, grid_cost) 
     824   !!---------------------------------------------------------------------- 
     825   !!                 *** ROUTINE Agrif_estimate_parallel_cost *** 
     826   !!---------------------------------------------------------------------- 
     827   USE par_oce 
     828   IMPLICIT NONE 
     829   ! 
     830   INTEGER,  INTENT(in)  :: imin, imax 
     831   INTEGER,  INTENT(in)  :: jmin, jmax 
     832   INTEGER,  INTENT(in)  :: nbprocs 
     833   REAL(wp), INTENT(out) :: grid_cost 
     834   !!---------------------------------------------------------------------- 
     835   ! 
     836   grid_cost = REAL(imax-imin+1,wp)*REAL(jmax-jmin+1,wp) / REAL(nbprocs,wp) 
     837   ! 
     838END SUBROUTINE Agrif_estimate_parallel_cost 
    671839 
    672840# endif 
Note: See TracChangeset for help on using the changeset viewer.