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 5682 for branches/2015/dev_r5072_UKMO2_OBS_simplification/NEMOGCM/NEMO/NST_SRC – NEMO

Ignore:
Timestamp:
2015-08-12T17:46:45+02:00 (9 years ago)
Author:
mattmartin
Message:

OBS simplification changes committed to branch after running SETTE tests to make sure we get the same results as the trunk for ORCA2_LIM_OBS.

Location:
branches/2015/dev_r5072_UKMO2_OBS_simplification/NEMOGCM/NEMO/NST_SRC
Files:
11 edited

Legend:

Unmodified
Added
Removed

  • branches/2015/dev_r5072_UKMO2_OBS_simplification/NEMOGCM/NEMO/NST_SRC/agrif2model.F90

    r3680 r5682  
    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/2015/dev_r5072_UKMO2_OBS_simplification/NEMOGCM/NEMO/NST_SRC/agrif_lim2_interp.F90

    r3680 r5682  
    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/2015/dev_r5072_UKMO2_OBS_simplification/NEMOGCM/NEMO/NST_SRC/agrif_lim2_update.F90

    r3680 r5682  
    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/2015/dev_r5072_UKMO2_OBS_simplification/NEMOGCM/NEMO/NST_SRC/agrif_oce.F90

    r4491 r5682  
    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/2015/dev_r5072_UKMO2_OBS_simplification/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90

    r4486 r5682  
    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 
    … …  
    2930   USE wrk_nemo 
    3031   USE dynspg_oce 
    31  
     32   USE zdf_oce 
     33  
    3234   IMPLICIT NONE 
    3335   PRIVATE 
    3436 
    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      
     37   INTEGER :: bdy_tinterp = 0 
     38 
    4239   PUBLIC   Agrif_tra, Agrif_dyn, Agrif_ssh, Agrif_dyn_ts, Agrif_ssh_ts, Agrif_dta_ts 
    43    PUBLIC   interpu, interpv, interpunb, interpvnb, interpsshn 
     40   PUBLIC   interpun, interpvn, interpun2d, interpvn2d  
     41   PUBLIC   interptsn,  interpsshn 
     42   PUBLIC   interpunb, interpvnb, interpub2b, interpvb2b 
     43   PUBLIC   interpe3t, interpumsk, interpvmsk 
     44# if defined key_zdftke 
     45   PUBLIC   Agrif_tke, interpavm 
     46# endif 
    4447 
    4548#  include "domzgr_substitute.h90"   
    4649#  include "vectopt_loop_substitute.h90" 
    4750   !!---------------------------------------------------------------------- 
    48    !! NEMO/NST 3.3 , NEMO Consortium (2010) 
     51   !! NEMO/NST 3.6 , NEMO Consortium (2010) 
    4952   !! $Id$ 
    5053   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    5154   !!---------------------------------------------------------------------- 
    5255 
    53    CONTAINS 
    54     
     56CONTAINS 
     57 
    5558   SUBROUTINE Agrif_tra 
    5659      !!---------------------------------------------------------------------- 
    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 
     60      !!                  ***  ROUTINE Agrif_tra  *** 
    6461      !!---------------------------------------------------------------------- 
    6562      ! 
    6663      IF( Agrif_Root() )   RETURN 
    67  
    68       CALL wrk_alloc( jpi, jpj, jpk, jpts, ztsa )  
    6964 
    7065      Agrif_SpecialValue    = 0.e0 
    7166      Agrif_UseSpecialValue = .TRUE. 
    72       ztsa(:,:,:,:) = 0.e0 
    73  
    74       CALL Agrif_Bc_variable( ztsa, tsn_id, procname=interptsn ) 
     67 
     68      CALL Agrif_Bc_variable( tsn_id, procname=interptsn ) 
    7569      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 )  
    16670      ! 
    16771   END SUBROUTINE Agrif_tra 
    … …  
    17579      INTEGER, INTENT(in) ::   kt 
    17680      !! 
    177       INTEGER :: ji,jj,jk 
     81      INTEGER :: ji,jj,jk, j1,j2, i1,i2 
    17882      REAL(wp) :: timeref 
    17983      REAL(wp) :: z2dt, znugdt 
    18084      REAL(wp) :: zrhox, zrhoy 
    181       REAL(wp), POINTER, DIMENSION(:,:,:) :: zua, zva 
    182       REAL(wp), POINTER, DIMENSION(:,:) :: spgv1, spgu1, zua2d, zva2d 
     85      REAL(wp), POINTER, DIMENSION(:,:) :: spgv1, spgu1 
    18386      !!----------------------------------------------------------------------   
    18487 
    18588      IF( Agrif_Root() )   RETURN 
    18689 
    187       CALL wrk_alloc( jpi, jpj, spgv1, spgu1, zua2d, zva2d ) 
    188       CALL wrk_alloc( jpi, jpj, jpk, zua, zva ) 
     90      CALL wrk_alloc( jpi, jpj, spgv1, spgu1 ) 
     91 
     92      Agrif_SpecialValue=0. 
     93      Agrif_UseSpecialValue = ln_spc_dyn 
     94 
     95      CALL Agrif_Bc_variable(un_interp_id,procname=interpun) 
     96      CALL Agrif_Bc_variable(vn_interp_id,procname=interpvn) 
     97 
     98#if defined key_dynspg_flt 
     99      CALL Agrif_Bc_variable(e1u_id,calledweight=1., procname=interpun2d) 
     100      CALL Agrif_Bc_variable(e2v_id,calledweight=1., procname=interpvn2d) 
     101#endif 
     102 
     103      Agrif_UseSpecialValue = .FALSE. 
    189104 
    190105      zrhox = Agrif_Rhox() 
    … …  
    192107 
    193108      timeref = 1. 
    194  
    195109      ! time step: leap-frog 
    196110      z2dt = 2. * rdt 
    … …  
    200114      znugdt =  grav * z2dt     
    201115 
    202       Agrif_SpecialValue=0. 
    203       Agrif_UseSpecialValue = ln_spc_dyn 
    204  
    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  
     116      ! prevent smoothing in ghost cells 
     117      i1=1 
     118      i2=jpi 
     119      j1=1 
     120      j2=jpj 
     121      IF((nbondj == -1).OR.(nbondj == 2)) j1 = 3 
     122      IF((nbondj == +1).OR.(nbondj == 2)) j2 = nlcj-2 
     123      IF((nbondi == -1).OR.(nbondi == 2)) i1 = 3 
     124      IF((nbondi == +1).OR.(nbondi == 2)) i2 = nlci-2 
     125 
     126 
     127      IF((nbondi == -1).OR.(nbondi == 2)) THEN 
    212128#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 
    218       Agrif_UseSpecialValue = .FALSE. 
    219  
    220  
    221       IF((nbondi == -1).OR.(nbondi == 2)) THEN 
    222  
    223 #if defined key_dynspg_flt 
    224          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 
     129         DO jk=1,jpkm1 
     130            DO jj=j1,j2 
     131               ua(2,jj,jk) = (ua(2,jj,jk) - z2dt * znugdt * laplacu(2,jj))*umask(2,jj,jk) 
     132            END DO 
     133         END DO 
     134 
     135         spgu(2,:)=0. 
    228136 
    229137         DO jk=1,jpkm1 
    230138            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 
    238             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  
    245          DO jk=1,jpkm1 
    246             DO jj=1,jpj 
    247                spgu(2,jj)=spgu(2,jj)+fse3u_a(2,jj,jk)*ua(2,jj,jk) 
     139               spgu(2,jj)=spgu(2,jj)+fse3u(2,jj,jk)*ua(2,jj,jk) 
    248140            END DO 
    249141         END DO 
    … …  
    251143         DO jj=1,jpj 
    252144            IF (umask(2,jj,1).NE.0.) THEN 
    253                spgu(2,jj)=spgu(2,jj)*hur_a(2,jj) 
     145               spgu(2,jj)=spgu(2,jj)/hu(2,jj) 
    254146            ENDIF 
    255147         END DO 
    … …  
    259151 
    260152         DO jk=1,jpkm1 
    261             DO jj=1,jpj 
     153            DO jj=j1,j2 
    262154               ua(2,jj,jk) = 0.25*(ua(1,jj,jk)+2.*ua(2,jj,jk)+ua(3,jj,jk)) 
    263155               ua(2,jj,jk) = ua(2,jj,jk) * umask(2,jj,jk) 
    … …  
    269161         DO jk=1,jpkm1 
    270162            DO jj=1,jpj 
    271                spgu1(2,jj)=spgu1(2,jj)+fse3u_a(2,jj,jk)*ua(2,jj,jk) 
     163               spgu1(2,jj)=spgu1(2,jj)+fse3u(2,jj,jk)*ua(2,jj,jk) 
    272164            END DO 
    273165         END DO 
    … …  
    275167         DO jj=1,jpj 
    276168            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  
    281          DO jk=1,jpkm1 
    282             DO jj=1,jpj 
     169               spgu1(2,jj)=spgu1(2,jj)/hu(2,jj) 
     170            ENDIF 
     171         END DO 
     172 
     173         DO jk=1,jpkm1 
     174            DO jj=j1,j2 
    283175               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) 
    291176            END DO 
    292177         END DO 
    … …  
    300185            END DO 
    301186         END DO 
    302  
    303187         DO jj=1,jpj 
    304188            spgv1(2,jj)=spgv1(2,jj)*hvr_a(2,jj) 
    305189         END DO 
    306  
    307190         DO jk=1,jpkm1 
    308191            DO jj=1,jpj 
    … …  
    316199      IF((nbondi == 1).OR.(nbondi == 2)) THEN 
    317200#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  
     201         DO jk=1,jpkm1 
     202            DO jj=j1,j2 
     203               ua(nlci-2,jj,jk) = (ua(nlci-2,jj,jk)- z2dt * znugdt * laplacu(nlci-2,jj))*umask(nlci-2,jj,jk) 
     204            END DO 
     205         END DO 
     206         spgu(nlci-2,:)=0. 
    323207         DO jk=1,jpkm1 
    324208            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  
     209               spgu(nlci-2,jj)=spgu(nlci-2,jj)+fse3u(nlci-2,jj,jk)*ua(nlci-2,jj,jk) 
     210            ENDDO 
     211         ENDDO 
    346212         DO jj=1,jpj 
    347213            IF (umask(nlci-2,jj,1).NE.0.) THEN 
    348                spgu(nlci-2,jj)=spgu(nlci-2,jj)*hur_a(nlci-2,jj) 
     214               spgu(nlci-2,jj)=spgu(nlci-2,jj)/hu(nlci-2,jj) 
    349215            ENDIF 
    350216         END DO 
    … …  
    352218         spgu(nlci-2,:) = ua_b(nlci-2,:) 
    353219#endif 
    354  
     220         DO jk=1,jpkm1 
     221            DO jj=j1,j2 
     222               ua(nlci-2,jj,jk) = 0.25*(ua(nlci-3,jj,jk)+2.*ua(nlci-2,jj,jk)+ua(nlci-1,jj,jk)) 
     223 
     224               ua(nlci-2,jj,jk) = ua(nlci-2,jj,jk) * umask(nlci-2,jj,jk) 
     225 
     226            END DO 
     227         END DO 
     228         spgu1(nlci-2,:)=0. 
    355229         DO jk=1,jpkm1 
    356230            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  
     231               spgu1(nlci-2,jj)=spgu1(nlci-2,jj)+fse3u(nlci-2,jj,jk)*ua(nlci-2,jj,jk)*umask(nlci-2,jj,jk) 
     232            END DO 
     233         END DO 
    372234         DO jj=1,jpj 
    373235            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 
     236               spgu1(nlci-2,jj)=spgu1(nlci-2,jj)/hu(nlci-2,jj) 
     237            ENDIF 
     238         END DO 
     239         DO jk=1,jpkm1 
     240            DO jj=j1,j2 
    380241               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) 
    388242            END DO 
    389243         END DO 
    … …  
    414268 
    415269#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 
    422             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 
    429270         DO jk=1,jpkm1 
    430271            DO ji=1,jpi 
    … …  
    437278         DO jk=1,jpkm1 
    438279            DO ji=1,jpi 
    439                spgv(ji,2)=spgv(ji,2)+fse3v_a(ji,2,jk)*va(ji,2,jk) 
     280               spgv(ji,2)=spgv(ji,2)+fse3v(ji,2,jk)*va(ji,2,jk) 
    440281            END DO 
    441282         END DO 
    … …  
    443284         DO ji=1,jpi 
    444285            IF (vmask(ji,2,1).NE.0.) THEN 
    445                spgv(ji,2)=spgv(ji,2)*hvr_a(ji,2) 
     286               spgv(ji,2)=spgv(ji,2)/hv(ji,2) 
    446287            ENDIF 
    447288         END DO 
    … …  
    451292 
    452293         DO jk=1,jpkm1 
    453             DO ji=1,jpi 
     294            DO ji=i1,i2 
    454295               va(ji,2,jk)=0.25*(va(ji,1,jk)+2.*va(ji,2,jk)+va(ji,3,jk)) 
    455296               va(ji,2,jk)=va(ji,2,jk)*vmask(ji,2,jk) 
    … …  
    461302         DO jk=1,jpkm1 
    462303            DO ji=1,jpi 
    463                spgv1(ji,2)=spgv1(ji,2)+fse3v_a(ji,2,jk)*va(ji,2,jk)*vmask(ji,2,jk) 
     304               spgv1(ji,2)=spgv1(ji,2)+fse3v(ji,2,jk)*va(ji,2,jk)*vmask(ji,2,jk) 
    464305            END DO 
    465306         END DO 
    … …  
    467308         DO ji=1,jpi 
    468309            IF (vmask(ji,2,1).NE.0.) THEN 
    469                spgv1(ji,2)=spgv1(ji,2)*hvr_a(ji,2) 
     310               spgv1(ji,2)=spgv1(ji,2)/hv(ji,2) 
    470311            ENDIF 
    471312         END DO 
    … …  
    474315            DO ji=1,jpi 
    475316               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) 
    483317            END DO 
    484318         END DO 
    … …  
    508342 
    509343#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 
    523344         DO jk=1,jpkm1 
    524345            DO ji=1,jpi 
    … …  
    527348         END DO 
    528349 
     350 
    529351         spgv(:,nlcj-2)=0. 
    530352 
    531353         DO jk=1,jpkm1 
    532354            DO ji=1,jpi 
    533                spgv(ji,nlcj-2)=spgv(ji,nlcj-2)+fse3v_a(ji,nlcj-2,jk)*va(ji,nlcj-2,jk) 
     355               spgv(ji,nlcj-2)=spgv(ji,nlcj-2)+fse3v(ji,nlcj-2,jk)*va(ji,nlcj-2,jk) 
    534356            END DO 
    535357         END DO 
    … …  
    537359         DO ji=1,jpi 
    538360            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 
     361               spgv(ji,nlcj-2)=spgv(ji,nlcj-2)/hv(ji,nlcj-2) 
     362            ENDIF 
     363         END DO 
     364 
    542365#else 
    543366         spgv(:,nlcj-2)=va_b(:,nlcj-2) 
    … …  
    545368 
    546369         DO jk=1,jpkm1 
    547             DO ji=1,jpi 
     370            DO ji=i1,i2 
    548371               va(ji,nlcj-2,jk)=0.25*(va(ji,nlcj-3,jk)+2.*va(ji,nlcj-2,jk)+va(ji,nlcj-1,jk)) 
    549372               va(ji,nlcj-2,jk) = va(ji,nlcj-2,jk) * vmask(ji,nlcj-2,jk) 
    … …  
    555378         DO jk=1,jpkm1 
    556379            DO ji=1,jpi 
    557                spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)+fse3v_a(ji,nlcj-2,jk)*va(ji,nlcj-2,jk) 
     380               spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)+fse3v(ji,nlcj-2,jk)*va(ji,nlcj-2,jk) 
    558381            END DO 
    559382         END DO 
    … …  
    561384         DO ji=1,jpi 
    562385            IF (vmask(ji,nlcj-2,1).NE.0.) THEN 
    563                spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)*hvr_a(ji,nlcj-2) 
     386               spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)/hv(ji,nlcj-2) 
    564387            ENDIF 
    565388         END DO 
    … …  
    568391            DO ji=1,jpi 
    569392               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) 
    577393            END DO 
    578394         END DO 
    … …  
    600416      ENDIF 
    601417      ! 
    602       CALL wrk_dealloc( jpi, jpj, spgv1, spgu1, zua2d, zva2d ) 
    603       CALL wrk_dealloc( jpi, jpj, jpk, zua, zva ) 
     418      CALL wrk_dealloc( jpi, jpj, spgv1, spgu1 ) 
    604419      ! 
    605420   END SUBROUTINE Agrif_dyn 
    … …  
    620435         DO jj=1,jpj 
    621436            va_e(2,jj) = vbdy_w(jj) * hvr_e(2,jj) 
    622 ! Specified fluxes: 
     437            ! Specified fluxes: 
    623438            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)) ) 
     439            ! Characteristics method: 
     440            !alt            ua_e(2,jj) = 0.5_wp * ( ubdy_w(jj) * hur_e(2,jj) + ua_e(3,jj) & 
     441            !alt                       &           - sqrt(grav * hur_e(2,jj)) * (sshn_e(3,jj) - hbdy_w(jj)) ) 
    627442         END DO 
    628443      ENDIF 
    … …  
    631446         DO jj=1,jpj 
    632447            va_e(nlci-1,jj) = vbdy_e(jj) * hvr_e(nlci-1,jj) 
    633 ! Specified fluxes: 
     448            ! Specified fluxes: 
    634449            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)) ) 
     450            ! Characteristics method: 
     451            !alt            ua_e(nlci-2,jj) = 0.5_wp * ( ubdy_e(jj) * hur_e(nlci-2,jj) + ua_e(nlci-3,jj) & 
     452            !alt                            &           + sqrt(grav * hur_e(nlci-2,jj)) * (sshn_e(nlci-2,jj) - hbdy_e(jj)) ) 
    638453         END DO 
    639454      ENDIF 
    … …  
    642457         DO ji=1,jpi 
    643458            ua_e(ji,2) = ubdy_s(ji) * hur_e(ji,2) 
    644 ! Specified fluxes: 
     459            ! Specified fluxes: 
    645460            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)) ) 
     461            ! Characteristics method: 
     462            !alt            va_e(ji,2) = 0.5_wp * ( vbdy_s(ji) * hvr_e(ji,2) + va_e(ji,3) & 
     463            !alt                       &           - sqrt(grav * hvr_e(ji,2)) * (sshn_e(ji,3) - hbdy_s(ji)) ) 
    649464         END DO 
    650465      ENDIF 
    … …  
    653468         DO ji=1,jpi 
    654469            ua_e(ji,nlcj-1) = ubdy_n(ji) * hur_e(ji,nlcj-1) 
    655 ! Specified fluxes: 
     470            ! Specified fluxes: 
    656471            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)) ) 
     472            ! Characteristics method: 
     473            !alt            va_e(ji,nlcj-2) = 0.5_wp * ( vbdy_n(ji) * hvr_e(ji,nlcj-2)  + va_e(ji,nlcj-3) & 
     474            !alt                            &           + sqrt(grav * hvr_e(ji,nlcj-2)) * (sshn_e(ji,nlcj-2) - hbdy_n(ji)) ) 
    660475         END DO 
    661476      ENDIF 
    … …  
    672487      INTEGER :: ji, jj 
    673488      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 
     489      REAL(wp) :: zrhot, zt 
    679490      !!----------------------------------------------------------------------   
    680491 
    … …  
    682493 
    683494      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() 
     495      ! the forward case only 
     496 
    688497      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 ) 
    698498 
    699499      ! "Central" time index for interpolation: 
    … …  
    707507      Agrif_SpecialValue    = 0.e0 
    708508      Agrif_UseSpecialValue = .TRUE. 
    709       CALL Agrif_Bc_variable(zsshn, sshn_id,calledweight=zt, procname=interpsshn ) 
     509      CALL Agrif_Bc_variable(sshn_id,calledweight=zt, procname=interpsshn ) 
    710510      Agrif_UseSpecialValue = .FALSE. 
    711511 
    … …  
    715515 
    716516      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           
     517         ! orders matters here !!!!!! 
     518         CALL Agrif_Bc_variable(ub2b_interp_id,calledweight=1._wp, procname=interpub2b) ! Time integrated 
     519         CALL Agrif_Bc_variable(vb2b_interp_id,calledweight=1._wp, procname=interpvb2b) 
     520         bdy_tinterp = 1 
     521         CALL Agrif_Bc_variable(unb_id ,calledweight=1._wp, procname=interpunb) ! After 
     522         CALL Agrif_Bc_variable(vnb_id ,calledweight=1._wp, procname=interpvnb) 
     523         bdy_tinterp = 2 
     524         CALL Agrif_Bc_variable(unb_id ,calledweight=0._wp, procname=interpunb) ! Before 
     525         CALL Agrif_Bc_variable(vnb_id ,calledweight=0._wp, procname=interpvnb)          
     526      ELSE ! Linear interpolation 
     527         bdy_tinterp = 0 
     528         ubdy_w(:) = 0.e0 ; vbdy_w(:) = 0.e0  
     529         ubdy_e(:) = 0.e0 ; vbdy_e(:) = 0.e0  
     530         ubdy_n(:) = 0.e0 ; vbdy_n(:) = 0.e0  
     531         ubdy_s(:) = 0.e0 ; vbdy_s(:) = 0.e0  
     532         CALL Agrif_Bc_variable(unb_id,calledweight=zt, procname=interpunb) 
     533         CALL Agrif_Bc_variable(vnb_id,calledweight=zt, procname=interpvnb) 
     534      ENDIF 
     535      Agrif_UseSpecialValue = .FALSE. 
     536      !  
     537   END SUBROUTINE Agrif_dta_ts 
     538 
     539   SUBROUTINE Agrif_ssh( kt ) 
     540      !!---------------------------------------------------------------------- 
     541      !!                  ***  ROUTINE Agrif_DYN  *** 
     542      !!----------------------------------------------------------------------   
     543      INTEGER, INTENT(in) ::   kt 
     544      !! 
     545      !!----------------------------------------------------------------------   
     546 
     547      IF( Agrif_Root() )   RETURN 
     548 
     549      IF((nbondi == -1).OR.(nbondi == 2)) THEN 
     550         ssha(2,:)=ssha(3,:) 
     551         sshn(2,:)=sshn(3,:) 
     552      ENDIF 
     553 
     554      IF((nbondi == 1).OR.(nbondi == 2)) THEN 
     555         ssha(nlci-1,:)=ssha(nlci-2,:) 
     556         sshn(nlci-1,:)=sshn(nlci-2,:) 
     557      ENDIF 
     558 
     559      IF((nbondj == -1).OR.(nbondj == 2)) THEN 
     560         ssha(:,2)=ssha(:,3) 
     561         sshn(:,2)=sshn(:,3) 
     562      ENDIF 
     563 
     564      IF((nbondj == 1).OR.(nbondj == 2)) THEN 
     565         ssha(:,nlcj-1)=ssha(:,nlcj-2) 
     566         sshn(:,nlcj-1)=sshn(:,nlcj-2) 
     567      ENDIF 
     568 
     569   END SUBROUTINE Agrif_ssh 
     570 
     571   SUBROUTINE Agrif_ssh_ts( jn ) 
     572      !!---------------------------------------------------------------------- 
     573      !!                  ***  ROUTINE Agrif_ssh_ts  *** 
     574      !!----------------------------------------------------------------------   
     575      INTEGER, INTENT(in) ::   jn 
     576      !! 
     577      INTEGER :: ji,jj 
     578      !!----------------------------------------------------------------------   
     579 
     580      IF((nbondi == -1).OR.(nbondi == 2)) THEN 
     581         DO jj=1,jpj 
     582            ssha_e(2,jj) = hbdy_w(jj) 
     583         END DO 
     584      ENDIF 
     585 
     586      IF((nbondi == 1).OR.(nbondi == 2)) THEN 
     587         DO jj=1,jpj 
     588            ssha_e(nlci-1,jj) = hbdy_e(jj) 
     589         END DO 
     590      ENDIF 
     591 
     592      IF((nbondj == -1).OR.(nbondj == 2)) THEN 
     593         DO ji=1,jpi 
     594            ssha_e(ji,2) = hbdy_s(ji) 
     595         END DO 
     596      ENDIF 
     597 
     598      IF((nbondj == 1).OR.(nbondj == 2)) THEN 
     599         DO ji=1,jpi 
     600            ssha_e(ji,nlcj-1) = hbdy_n(ji) 
     601         END DO 
     602      ENDIF 
     603 
     604   END SUBROUTINE Agrif_ssh_ts 
     605 
     606# if defined key_zdftke 
     607   SUBROUTINE Agrif_tke 
     608      !!---------------------------------------------------------------------- 
     609      !!                  ***  ROUTINE Agrif_tke  *** 
     610      !!----------------------------------------------------------------------   
     611      REAL(wp) ::   zalpha 
     612      ! 
     613      zalpha = REAL( Agrif_NbStepint() + Agrif_IRhot() - 1, wp ) / REAL( Agrif_IRhot(), wp ) 
     614      IF( zalpha > 1. )   zalpha = 1. 
     615       
     616      Agrif_SpecialValue    = 0.e0 
     617      Agrif_UseSpecialValue = .TRUE. 
     618       
     619      CALL Agrif_Bc_variable(avm_id ,calledweight=zalpha, procname=interpavm)        
     620               
     621      Agrif_UseSpecialValue = .FALSE. 
     622      ! 
     623   END SUBROUTINE Agrif_tke 
     624# endif 
     625 
     626   SUBROUTINE interptsn(ptab,i1,i2,j1,j2,k1,k2,n1,n2,before,nb,ndir) 
     627      !!--------------------------------------------- 
     628      !!   *** ROUTINE interptsn *** 
     629      !!--------------------------------------------- 
     630      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab 
     631      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
     632      LOGICAL, INTENT(in) :: before 
     633      INTEGER, INTENT(in) :: nb , ndir 
     634      ! 
     635      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
     636      INTEGER :: imin, imax, jmin, jmax 
     637      REAL(wp) ::   zrhox , zalpha1, zalpha2, zalpha3 
     638      REAL(wp) ::   zalpha4, zalpha5, zalpha6, zalpha7 
     639      LOGICAL :: western_side, eastern_side,northern_side,southern_side 
     640 
     641      IF (before) THEN          
     642         ptab(i1:i2,j1:j2,k1:k2,n1:n2) = tsn(i1:i2,j1:j2,k1:k2,n1:n2) 
     643      ELSE 
     644         ! 
     645         western_side  = (nb == 1).AND.(ndir == 1) 
     646         eastern_side  = (nb == 1).AND.(ndir == 2) 
     647         southern_side = (nb == 2).AND.(ndir == 1) 
     648         northern_side = (nb == 2).AND.(ndir == 2) 
     649         ! 
     650         zrhox = Agrif_Rhox() 
     651         !  
     652         zalpha1 = ( zrhox - 1. ) * 0.5 
     653         zalpha2 = 1. - zalpha1 
     654         !  
     655         zalpha3 = ( zrhox - 1. ) / ( zrhox + 1. ) 
     656         zalpha4 = 1. - zalpha3 
     657         !  
     658         zalpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 
     659         zalpha7 =    - ( zrhox - 1. ) / ( zrhox + 3. ) 
     660         zalpha5 = 1. - zalpha6 - zalpha7 
     661         ! 
     662         imin = i1 
     663         imax = i2 
     664         jmin = j1 
     665         jmax = j2 
     666         !  
     667         ! Remove CORNERS 
     668         IF((nbondj == -1).OR.(nbondj == 2)) jmin = 3 
     669         IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj-2 
     670         IF((nbondi == -1).OR.(nbondi == 2)) imin = 3 
     671         IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci-2         
     672         ! 
     673         IF( eastern_side) THEN 
     674            DO jn = 1, jpts 
     675               tsa(nlci,j1:j2,k1:k2,jn) = zalpha1 * ptab(nlci,j1:j2,k1:k2,jn) + zalpha2 * ptab(nlci-1,j1:j2,k1:k2,jn) 
     676               DO jk = 1, jpkm1 
     677                  DO jj = jmin,jmax 
     678                     IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN 
     679                        tsa(nlci-1,jj,jk,jn) = tsa(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 
     680                     ELSE 
     681                        tsa(nlci-1,jj,jk,jn)=(zalpha4*tsa(nlci,jj,jk,jn)+zalpha3*tsa(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 
     682                        IF( un(nlci-2,jj,jk) > 0.e0 ) THEN 
     683                           tsa(nlci-1,jj,jk,jn)=( zalpha6*tsa(nlci-2,jj,jk,jn)+zalpha5*tsa(nlci,jj,jk,jn) &  
     684                                 + zalpha7*tsa(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 
     685                        ENDIF 
     686                     ENDIF 
     687                  END DO 
     688               END DO 
     689            ENDDO 
     690         ENDIF 
     691         !  
     692         IF( northern_side ) THEN             
     693            DO jn = 1, jpts 
     694               tsa(i1:i2,nlcj,k1:k2,jn) = zalpha1 * ptab(i1:i2,nlcj,k1:k2,jn) + zalpha2 * ptab(i1:i2,nlcj-1,k1:k2,jn) 
     695               DO jk = 1, jpkm1 
     696                  DO ji = imin,imax 
     697                     IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN 
     698                        tsa(ji,nlcj-1,jk,jn) = tsa(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 
     699                     ELSE 
     700                        tsa(ji,nlcj-1,jk,jn)=(zalpha4*tsa(ji,nlcj,jk,jn)+zalpha3*tsa(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk)         
     701                        IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN 
     702                           tsa(ji,nlcj-1,jk,jn)=( zalpha6*tsa(ji,nlcj-2,jk,jn)+zalpha5*tsa(ji,nlcj,jk,jn)  & 
     703                                 + zalpha7*tsa(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 
     704                        ENDIF 
     705                     ENDIF 
     706                  END DO 
     707               END DO 
     708            ENDDO 
     709         ENDIF 
     710         ! 
     711         IF( western_side) THEN             
     712            DO jn = 1, jpts 
     713               tsa(1,j1:j2,k1:k2,jn) = zalpha1 * ptab(1,j1:j2,k1:k2,jn) + zalpha2 * ptab(2,j1:j2,k1:k2,jn) 
     714               DO jk = 1, jpkm1 
     715                  DO jj = jmin,jmax 
     716                     IF( umask(2,jj,jk) == 0.e0 ) THEN 
     717                        tsa(2,jj,jk,jn) = tsa(1,jj,jk,jn) * tmask(2,jj,jk) 
     718                     ELSE 
     719                        tsa(2,jj,jk,jn)=(zalpha4*tsa(1,jj,jk,jn)+zalpha3*tsa(3,jj,jk,jn))*tmask(2,jj,jk)         
     720                        IF( un(2,jj,jk) < 0.e0 ) THEN 
     721                           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) 
     722                        ENDIF 
     723                     ENDIF 
     724                  END DO 
     725               END DO 
     726            END DO 
     727         ENDIF 
     728         ! 
     729         IF( southern_side ) THEN            
     730            DO jn = 1, jpts 
     731               tsa(i1:i2,1,k1:k2,jn) = zalpha1 * ptab(i1:i2,1,k1:k2,jn) + zalpha2 * ptab(i1:i2,2,k1:k2,jn) 
     732               DO jk=1,jpk       
     733                  DO ji=imin,imax 
     734                     IF( vmask(ji,2,jk) == 0.e0 ) THEN 
     735                        tsa(ji,2,jk,jn)=tsa(ji,1,jk,jn) * tmask(ji,2,jk) 
     736                     ELSE 
     737                        tsa(ji,2,jk,jn)=(zalpha4*tsa(ji,1,jk,jn)+zalpha3*tsa(ji,3,jk,jn))*tmask(ji,2,jk) 
     738                        IF( vn(ji,2,jk) < 0.e0 ) THEN 
     739                           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) 
     740                        ENDIF 
     741                     ENDIF 
     742                  END DO 
     743               END DO 
     744            ENDDO 
     745         ENDIF 
     746         ! 
     747         ! Treatment of corners 
     748         !  
     749         ! East south 
     750         IF ((eastern_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 
     751            tsa(nlci-1,2,:,:) = ptab(nlci-1,2,:,:) 
     752         ENDIF 
     753         ! East north 
     754         IF ((eastern_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 
     755            tsa(nlci-1,nlcj-1,:,:) = ptab(nlci-1,nlcj-1,:,:) 
     756         ENDIF 
     757         ! West south 
     758         IF ((western_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 
     759            tsa(2,2,:,:) = ptab(2,2,:,:) 
     760         ENDIF 
     761         ! West north 
     762         IF ((western_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 
     763            tsa(2,nlcj-1,:,:) = ptab(2,nlcj-1,:,:) 
     764         ENDIF 
     765         ! 
     766      ENDIF 
     767      ! 
     768   END SUBROUTINE interptsn 
     769 
     770   SUBROUTINE interpsshn(ptab,i1,i2,j1,j2,before,nb,ndir) 
     771      !!---------------------------------------------------------------------- 
     772      !!                  ***  ROUTINE interpsshn  *** 
     773      !!----------------------------------------------------------------------   
     774      INTEGER, INTENT(in) :: i1,i2,j1,j2 
     775      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 
     776      LOGICAL, INTENT(in) :: before 
     777      INTEGER, INTENT(in) :: nb , ndir 
     778      LOGICAL :: western_side, eastern_side,northern_side,southern_side 
     779      !!----------------------------------------------------------------------   
     780      ! 
     781      IF( before) THEN 
     782         ptab(i1:i2,j1:j2) = sshn(i1:i2,j1:j2) 
     783      ELSE 
     784         western_side  = (nb == 1).AND.(ndir == 1) 
     785         eastern_side  = (nb == 1).AND.(ndir == 2) 
     786         southern_side = (nb == 2).AND.(ndir == 1) 
     787         northern_side = (nb == 2).AND.(ndir == 2) 
     788         IF(western_side)  hbdy_w(j1:j2) = ptab(i1,j1:j2) * tmask(i1,j1:j2,1) 
     789         IF(eastern_side)  hbdy_e(j1:j2) = ptab(i1,j1:j2) * tmask(i1,j1:j2,1) 
     790         IF(southern_side) hbdy_s(i1:i2) = ptab(i1:i2,j1) * tmask(i1:i2,j1,1) 
     791         IF(northern_side) hbdy_n(i1:i2) = ptab(i1:i2,j1) * tmask(i1:i2,j1,1) 
     792      ENDIF 
     793      ! 
     794   END SUBROUTINE interpsshn 
     795 
     796   SUBROUTINE interpun(ptab,i1,i2,j1,j2,k1,k2, before) 
     797      !!--------------------------------------------- 
     798      !!   *** ROUTINE interpun *** 
     799      !!---------------------------------------------     
     800      !! 
     801      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
     802      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     803      LOGICAL, INTENT(in) :: before 
     804      !! 
     805      INTEGER :: ji,jj,jk 
     806      REAL(wp) :: zrhoy  
     807      !!---------------------------------------------     
     808      ! 
     809      IF (before) THEN  
     810         DO jk=1,jpk 
     811            DO jj=j1,j2 
     812               DO ji=i1,i2 
     813                  ptab(ji,jj,jk) = e2u(ji,jj) * un(ji,jj,jk) 
     814                  ptab(ji,jj,jk) = ptab(ji,jj,jk) * fse3u(ji,jj,jk) 
     815               END DO 
     816            END DO 
     817         END DO 
     818      ELSE 
     819         zrhoy = Agrif_Rhoy() 
     820         DO jk=1,jpkm1 
     821            DO jj=j1,j2 
     822               ua(i1:i2,jj,jk) = (ptab(i1:i2,jj,jk)/(zrhoy*e2u(i1:i2,jj))) 
     823               ua(i1:i2,jj,jk) = ua(i1:i2,jj,jk) / fse3u(i1:i2,jj,jk) 
     824            END DO 
     825         END DO 
     826      ENDIF 
     827      !  
     828   END SUBROUTINE interpun 
     829 
     830 
     831   SUBROUTINE interpun2d(ptab,i1,i2,j1,j2,before) 
     832      !!--------------------------------------------- 
     833      !!   *** ROUTINE interpun *** 
     834      !!---------------------------------------------     
     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      ! 
     840      INTEGER :: ji,jj 
     841      REAL(wp) :: ztref 
     842      REAL(wp) :: zrhoy  
     843      !!---------------------------------------------     
     844      ! 
     845      ztref = 1. 
     846 
     847      IF (before) THEN  
     848         DO jj=j1,j2 
     849            DO ji=i1,MIN(i2,nlci-1) 
     850               ptab(ji,jj) = e2u(ji,jj) * ((gcx(ji+1,jj) - gcx(ji,jj))/e1u(ji,jj))  
     851            END DO 
     852         END DO 
     853      ELSE 
     854         zrhoy = Agrif_Rhoy() 
     855         DO jj=j1,j2 
     856            laplacu(i1:i2,jj) = ztref * (ptab(i1:i2,jj)/(zrhoy*e2u(i1:i2,jj))) !*umask(i1:i2,jj,1) 
     857         END DO 
     858      ENDIF 
     859      !  
     860   END SUBROUTINE interpun2d 
     861 
     862 
     863   SUBROUTINE interpvn(ptab,i1,i2,j1,j2,k1,k2, before) 
     864      !!--------------------------------------------- 
     865      !!   *** ROUTINE interpvn *** 
     866      !!---------------------------------------------     
     867      ! 
     868      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
     869      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     870      LOGICAL, INTENT(in) :: before 
     871      ! 
     872      INTEGER :: ji,jj,jk 
     873      REAL(wp) :: zrhox  
     874      !!---------------------------------------------     
     875      !       
     876      IF (before) THEN           
     877         !interpv entre 1 et k2 et interpv2d en jpkp1 
     878         DO jk=k1,jpk 
     879            DO jj=j1,j2 
     880               DO ji=i1,i2 
     881                  ptab(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk) 
     882                  ptab(ji,jj,jk) = ptab(ji,jj,jk) * fse3v(ji,jj,jk) 
     883               END DO 
     884            END DO 
     885         END DO 
     886      ELSE           
     887         zrhox= Agrif_Rhox() 
     888         DO jk=1,jpkm1 
     889            DO jj=j1,j2 
     890               va(i1:i2,jj,jk) = (ptab(i1:i2,jj,jk)/(zrhox*e1v(i1:i2,jj))) 
     891               va(i1:i2,jj,jk) = va(i1:i2,jj,jk) / fse3v(i1:i2,jj,jk) 
     892            END DO 
     893         END DO 
     894      ENDIF 
     895      !         
     896   END SUBROUTINE interpvn 
     897 
     898   SUBROUTINE interpvn2d(ptab,i1,i2,j1,j2,before) 
     899      !!--------------------------------------------- 
     900      !!   *** ROUTINE interpvn *** 
     901      !!---------------------------------------------     
     902      ! 
     903      INTEGER, INTENT(in) :: i1,i2,j1,j2 
     904      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 
     905      LOGICAL, INTENT(in) :: before 
     906      ! 
     907      INTEGER :: ji,jj 
     908      REAL(wp) :: zrhox  
     909      REAL(wp) :: ztref 
     910      !!---------------------------------------------     
     911      !  
     912      ztref = 1.     
     913      IF (before) THEN  
     914         !interpv entre 1 et k2 et interpv2d en jpkp1 
     915         DO jj=j1,MIN(j2,nlcj-1) 
     916            DO ji=i1,i2 
     917               ptab(ji,jj) = e1v(ji,jj) * ((gcx(ji,jj+1) - gcx(ji,jj))/e2v(ji,jj)) * vmask(ji,jj,1) 
     918            END DO 
     919         END DO 
     920      ELSE            
     921         zrhox = Agrif_Rhox() 
     922         DO ji=i1,i2 
     923            laplacv(ji,j1:j2) = ztref * (ptab(ji,j1:j2)/(zrhox*e1v(ji,j1:j2))) 
     924         END DO 
     925      ENDIF 
     926      !       
     927   END SUBROUTINE interpvn2d 
     928 
     929   SUBROUTINE interpunb(ptab,i1,i2,j1,j2,before,nb,ndir) 
     930      !!---------------------------------------------------------------------- 
     931      !!                  ***  ROUTINE interpunb  *** 
     932      !!----------------------------------------------------------------------   
     933      INTEGER, INTENT(in) :: i1,i2,j1,j2 
     934      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 
     935      LOGICAL, INTENT(in) :: before 
     936      INTEGER, INTENT(in) :: nb , ndir 
     937      !! 
     938      INTEGER :: ji,jj 
     939      REAL(wp) :: zrhoy, zrhot, zt0, zt1, ztcoeff 
     940      LOGICAL :: western_side, eastern_side,northern_side,southern_side 
     941      !!----------------------------------------------------------------------   
     942      ! 
     943      IF (before) THEN  
     944         DO jj=j1,j2 
     945            DO ji=i1,i2 
     946               ptab(ji,jj) = un_b(ji,jj) * e2u(ji,jj) * hu(ji,jj)  
     947            END DO 
     948         END DO 
     949      ELSE 
     950         western_side  = (nb == 1).AND.(ndir == 1) 
     951         eastern_side  = (nb == 1).AND.(ndir == 2) 
     952         southern_side = (nb == 2).AND.(ndir == 1) 
     953         northern_side = (nb == 2).AND.(ndir == 2) 
     954         zrhoy = Agrif_Rhoy() 
     955         zrhot = Agrif_rhot() 
     956         ! Time indexes bounds for integration 
     957         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot 
     958         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot       
     959         ! Polynomial interpolation coefficients: 
     960         IF( bdy_tinterp == 1 ) THEN 
     961            ztcoeff = zrhot * (  zt1**2._wp * (       zt1 - 1._wp)        & 
     962                  &      - zt0**2._wp * (       zt0 - 1._wp)        ) 
     963         ELSEIF( bdy_tinterp == 2 ) THEN 
     964            ztcoeff = zrhot * (  zt1        * (       zt1 - 1._wp)**2._wp & 
     965                  &      - zt0        * (       zt0 - 1._wp)**2._wp )  
     966 
     967         ELSE 
     968            ztcoeff = 1 
     969         ENDIF 
     970         !    
     971         IF(western_side) THEN 
     972            ubdy_w(j1:j2) = ubdy_w(j1:j2) + ztcoeff * ptab(i1,j1:j2)   
     973         ENDIF 
     974         IF(eastern_side) THEN 
     975            ubdy_e(j1:j2) = ubdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2)   
     976         ENDIF 
     977         IF(southern_side) THEN 
     978            ubdy_s(i1:i2) = ubdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j1)  
     979         ENDIF 
     980         IF(northern_side) THEN 
     981            ubdy_n(i1:i2) = ubdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1)  
     982         ENDIF 
     983         !             
     984         IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN 
     985            IF(western_side) THEN 
     986               ubdy_w(j1:j2) = ubdy_w(j1:j2) / (zrhoy*e2u(i1,j1:j2))   & 
     987                     &                                  * umask(i1,j1:j2,1) 
     988            ENDIF 
     989            IF(eastern_side) THEN 
     990               ubdy_e(j1:j2) = ubdy_e(j1:j2) / (zrhoy*e2u(i1,j1:j2))   & 
     991                     &                                  * umask(i1,j1:j2,1) 
     992            ENDIF 
     993            IF(southern_side) THEN 
     994               ubdy_s(i1:i2) = ubdy_s(i1:i2) / (zrhoy*e2u(i1:i2,j1))   & 
     995                     &                                  * umask(i1:i2,j1,1) 
     996            ENDIF 
     997            IF(northern_side) THEN 
     998               ubdy_n(i1:i2) = ubdy_n(i1:i2) / (zrhoy*e2u(i1:i2,j1))   & 
     999                     &                                  * umask(i1:i2,j1,1) 
     1000            ENDIF 
     1001         ENDIF 
     1002      ENDIF 
     1003      !  
     1004   END SUBROUTINE interpunb 
     1005 
     1006   SUBROUTINE interpvnb(ptab,i1,i2,j1,j2,before,nb,ndir) 
     1007      !!---------------------------------------------------------------------- 
     1008      !!                  ***  ROUTINE interpvnb  *** 
     1009      !!----------------------------------------------------------------------   
     1010      INTEGER, INTENT(in) :: i1,i2,j1,j2 
     1011      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 
     1012      LOGICAL, INTENT(in) :: before 
     1013      INTEGER, INTENT(in) :: nb , ndir 
     1014      !! 
     1015      INTEGER :: ji,jj 
     1016      REAL(wp) :: zrhox, zrhot, zt0, zt1, ztcoeff    
     1017      LOGICAL :: western_side, eastern_side,northern_side,southern_side 
     1018      !!----------------------------------------------------------------------   
     1019      !  
     1020      IF (before) THEN  
     1021         DO jj=j1,j2 
     1022            DO ji=i1,i2 
     1023               ptab(ji,jj) = vn_b(ji,jj) * e1v(ji,jj) * hv(ji,jj)  
     1024            END DO 
     1025         END DO 
     1026      ELSE 
     1027         western_side  = (nb == 1).AND.(ndir == 1) 
     1028         eastern_side  = (nb == 1).AND.(ndir == 2) 
     1029         southern_side = (nb == 2).AND.(ndir == 1) 
     1030         northern_side = (nb == 2).AND.(ndir == 2) 
     1031         zrhox = Agrif_Rhox() 
     1032         zrhot = Agrif_rhot() 
     1033         ! Time indexes bounds for integration 
     1034         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot 
     1035         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot       
     1036         IF( bdy_tinterp == 1 ) THEN 
     1037            ztcoeff = zrhot * (  zt1**2._wp * (       zt1 - 1._wp)        & 
     1038                  &      - zt0**2._wp * (       zt0 - 1._wp)        ) 
     1039         ELSEIF( bdy_tinterp == 2 ) THEN 
     1040            ztcoeff = zrhot * (  zt1        * (       zt1 - 1._wp)**2._wp & 
     1041                  &      - zt0        * (       zt0 - 1._wp)**2._wp )  
     1042 
     1043         ELSE 
     1044            ztcoeff = 1 
     1045         ENDIF 
     1046         ! 
     1047         IF(western_side) THEN 
     1048            vbdy_w(j1:j2) = vbdy_w(j1:j2) + ztcoeff * ptab(i1,j1:j2)   
     1049         ENDIF 
     1050         IF(eastern_side) THEN 
     1051            vbdy_e(j1:j2) = vbdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2)   
     1052         ENDIF 
     1053         IF(southern_side) THEN 
     1054            vbdy_s(i1:i2) = vbdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j1) 
     1055         ENDIF 
     1056         IF(northern_side) THEN 
     1057            vbdy_n(i1:i2) = vbdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1)  
     1058         ENDIF 
     1059         !             
     1060         IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN 
     1061            IF(western_side) THEN 
     1062               vbdy_w(j1:j2) = vbdy_w(j1:j2) / (zrhox*e1v(i1,j1:j2))   & 
     1063                     &                                  * vmask(i1,j1:j2,1) 
     1064            ENDIF 
     1065            IF(eastern_side) THEN 
     1066               vbdy_e(j1:j2) = vbdy_e(j1:j2) / (zrhox*e1v(i1,j1:j2))   & 
     1067                     &                                  * vmask(i1,j1:j2,1) 
     1068            ENDIF 
     1069            IF(southern_side) THEN 
     1070               vbdy_s(i1:i2) = vbdy_s(i1:i2) / (zrhox*e1v(i1:i2,j1))   & 
     1071                     &                                  * vmask(i1:i2,j1,1) 
     1072            ENDIF 
     1073            IF(northern_side) THEN 
     1074               vbdy_n(i1:i2) = vbdy_n(i1:i2) / (zrhox*e1v(i1:i2,j1))   & 
     1075                     &                                  * vmask(i1:i2,j1,1) 
     1076            ENDIF 
     1077         ENDIF 
     1078      ENDIF 
     1079      ! 
     1080   END SUBROUTINE interpvnb 
     1081 
     1082   SUBROUTINE interpub2b(ptab,i1,i2,j1,j2,before,nb,ndir) 
     1083      !!---------------------------------------------------------------------- 
     1084      !!                  ***  ROUTINE interpub2b  *** 
     1085      !!----------------------------------------------------------------------   
     1086      INTEGER, INTENT(in) :: i1,i2,j1,j2 
     1087      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 
     1088      LOGICAL, INTENT(in) :: before 
     1089      INTEGER, INTENT(in) :: nb , ndir 
     1090      !! 
     1091      INTEGER :: ji,jj 
     1092      REAL(wp) :: zrhot, zt0, zt1,zat 
     1093      LOGICAL :: western_side, eastern_side,northern_side,southern_side 
     1094      !!----------------------------------------------------------------------   
     1095      IF( before ) THEN 
     1096         DO jj=j1,j2 
     1097            DO ji=i1,i2 
     1098               ptab(ji,jj) = ub2_b(ji,jj) * e2u(ji,jj) 
     1099            END DO 
     1100         END DO 
     1101      ELSE 
     1102         western_side  = (nb == 1).AND.(ndir == 1) 
     1103         eastern_side  = (nb == 1).AND.(ndir == 2) 
     1104         southern_side = (nb == 2).AND.(ndir == 1) 
     1105         northern_side = (nb == 2).AND.(ndir == 2) 
     1106         zrhot = Agrif_rhot() 
    7281107         ! Time indexes bounds for integration 
    7291108         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot 
    7301109         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot 
    731  
    7321110         ! 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 ) 
    7371111         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 
     1112               &      - zt0**2._wp * (-2._wp*zt0 + 3._wp)        )  
     1113         !  
     1114         IF(western_side ) ubdy_w(j1:j2) = zat * ptab(i1,j1:j2)   
     1115         IF(eastern_side ) ubdy_e(j1:j2) = zat * ptab(i1,j1:j2)   
     1116         IF(southern_side) ubdy_s(i1:i2) = zat * ptab(i1:i2,j1)  
     1117         IF(northern_side) ubdy_n(i1:i2) = zat * ptab(i1:i2,j1)  
     1118      ENDIF 
     1119      !  
     1120   END SUBROUTINE interpub2b 
     1121 
     1122   SUBROUTINE interpvb2b(ptab,i1,i2,j1,j2,before,nb,ndir) 
     1123      !!---------------------------------------------------------------------- 
     1124      !!                  ***  ROUTINE interpvb2b  *** 
     1125      !!----------------------------------------------------------------------   
     1126      INTEGER, INTENT(in) :: i1,i2,j1,j2 
     1127      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 
     1128      LOGICAL, INTENT(in) :: before 
     1129      INTEGER, INTENT(in) :: nb , ndir 
    8491130      !! 
    8501131      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 
     1132      REAL(wp) :: zrhot, zt0, zt1,zat 
     1133      LOGICAL :: western_side, eastern_side,northern_side,southern_side 
     1134      !!----------------------------------------------------------------------   
     1135      ! 
     1136      IF( before ) THEN 
    9041137         DO jj=j1,j2 
    9051138            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       !!----------------------------------------------------------------------   
     1139               ptab(ji,jj) = vb2_b(ji,jj) * e1v(ji,jj) 
     1140            END DO 
     1141         END DO 
     1142      ELSE       
     1143         western_side  = (nb == 1).AND.(ndir == 1) 
     1144         eastern_side  = (nb == 1).AND.(ndir == 2) 
     1145         southern_side = (nb == 2).AND.(ndir == 1) 
     1146         northern_side = (nb == 2).AND.(ndir == 2) 
     1147         zrhot = Agrif_rhot() 
     1148         ! Time indexes bounds for integration 
     1149         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot 
     1150         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot 
     1151         ! Polynomial interpolation coefficients: 
     1152         zat = zrhot * (  zt1**2._wp * (-2._wp*zt1 + 3._wp)        & 
     1153               &      - zt0**2._wp * (-2._wp*zt0 + 3._wp)        )  
     1154         ! 
     1155         IF(western_side ) vbdy_w(j1:j2) = zat * ptab(i1,j1:j2)   
     1156         IF(eastern_side ) vbdy_e(j1:j2) = zat * ptab(i1,j1:j2)   
     1157         IF(southern_side) vbdy_s(i1:i2) = zat * ptab(i1:i2,j1)  
     1158         IF(northern_side) vbdy_n(i1:i2) = zat * ptab(i1:i2,j1)  
     1159      ENDIF 
     1160      !       
     1161   END SUBROUTINE interpvb2b 
     1162 
     1163   SUBROUTINE interpe3t(ptab,i1,i2,j1,j2,k1,k2,before,nb,ndir) 
     1164      !!---------------------------------------------------------------------- 
     1165      !!                  ***  ROUTINE interpe3t  *** 
     1166      !!----------------------------------------------------------------------   
     1167      !  
    9381168      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
    939       REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 
    940       !! 
     1169      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     1170      LOGICAL :: before 
     1171      INTEGER, INTENT(in) :: nb , ndir 
     1172      ! 
    9411173      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 
     1174      LOGICAL :: western_side, eastern_side, northern_side, southern_side 
     1175      REAL(wp) :: ztmpmsk       
     1176      !!----------------------------------------------------------------------   
     1177      !     
     1178      IF (before) THEN 
     1179         DO jk=k1,k2 
     1180            DO jj=j1,j2 
     1181               DO ji=i1,i2 
     1182                  ptab(ji,jj,jk) = tmask(ji,jj,jk) * e3t_0(ji,jj,jk) 
     1183               END DO 
     1184            END DO 
     1185         END DO 
     1186      ELSE 
     1187         western_side  = (nb == 1).AND.(ndir == 1) 
     1188         eastern_side  = (nb == 1).AND.(ndir == 2) 
     1189         southern_side = (nb == 2).AND.(ndir == 1) 
     1190         northern_side = (nb == 2).AND.(ndir == 2) 
     1191 
     1192         DO jk=k1,k2 
     1193            DO jj=j1,j2 
     1194               DO ji=i1,i2 
     1195                  ! Get velocity mask at boundary edge points: 
     1196                  IF (western_side)  ztmpmsk = umask(ji    ,jj    ,1) 
     1197                  IF (eastern_side)  ztmpmsk = umask(nlci-2,jj    ,1) 
     1198                  IF (northern_side) ztmpmsk = vmask(ji    ,nlcj-2,1) 
     1199                  IF (southern_side) ztmpmsk = vmask(ji    ,2     ,1) 
     1200 
     1201                  IF (ABS(ptab(ji,jj,jk) - tmask(ji,jj,jk) * e3t_0(ji,jj,jk))*ztmpmsk > 1.D-2) THEN 
     1202                     IF (western_side) THEN 
     1203                        WRITE(numout,*) 'ERROR bathymetry merge at the western border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 
     1204                     ELSEIF (eastern_side) THEN 
     1205                        WRITE(numout,*) 'ERROR bathymetry merge at the eastern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 
     1206                     ELSEIF (southern_side) THEN 
     1207                        WRITE(numout,*) 'ERROR bathymetry merge at the southern border ji,jj,jk', ji+nimpp-1,jj+njmpp-1,jk 
     1208                     ELSEIF (northern_side) THEN 
     1209                        WRITE(numout,*) 'ERROR bathymetry merge at the northen border ji,jj,jk', ji+nimpp-1,jj+njmpp-1,jk 
     1210                     ENDIF 
     1211                     WRITE(numout,*) '      ptab(ji,jj,jk), fse3t(ji,jj,jk) ', ptab(ji,jj,jk), e3t_0(ji,jj,jk) 
     1212                     kindic_agr = kindic_agr + 1 
     1213                  ENDIF 
     1214               END DO 
     1215            END DO 
     1216         END DO 
     1217 
     1218      ENDIF 
     1219      !  
     1220   END SUBROUTINE interpe3t 
     1221 
     1222   SUBROUTINE interpumsk(ptab,i1,i2,j1,j2,k1,k2,before,nb,ndir) 
     1223      !!---------------------------------------------------------------------- 
     1224      !!                  ***  ROUTINE interpumsk  *** 
     1225      !!----------------------------------------------------------------------   
     1226      !  
     1227      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
     1228      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     1229      LOGICAL :: before 
     1230      INTEGER, INTENT(in) :: nb , ndir 
     1231      ! 
     1232      INTEGER :: ji, jj, jk 
     1233      LOGICAL :: western_side, eastern_side    
     1234      !!----------------------------------------------------------------------   
     1235      !     
     1236      IF (before) THEN 
     1237         DO jk=k1,k2 
     1238            DO jj=j1,j2 
     1239               DO ji=i1,i2 
     1240                  ptab(ji,jj,jk) = umask(ji,jj,jk) 
     1241               END DO 
     1242            END DO 
     1243         END DO 
     1244      ELSE 
     1245 
     1246         western_side  = (nb == 1).AND.(ndir == 1) 
     1247         eastern_side  = (nb == 1).AND.(ndir == 2) 
     1248         DO jk=k1,k2 
     1249            DO jj=j1,j2 
     1250               DO ji=i1,i2 
     1251                   ! Velocity mask at boundary edge points: 
     1252                  IF (ABS(ptab(ji,jj,jk) - umask(ji,jj,jk)) > 1.D-2) THEN 
     1253                     IF (western_side) THEN 
     1254                        WRITE(numout,*) 'ERROR with umask at the western border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 
     1255                        WRITE(numout,*) '      masks: parent, child ', ptab(ji,jj,jk), umask(ji,jj,jk) 
     1256                        kindic_agr = kindic_agr + 1 
     1257                     ELSEIF (eastern_side) THEN 
     1258                        WRITE(numout,*) 'ERROR with umask at the eastern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 
     1259                        WRITE(numout,*) '      masks: parent, child ', ptab(ji,jj,jk), umask(ji,jj,jk) 
     1260                        kindic_agr = kindic_agr + 1 
     1261                     ENDIF 
     1262                  ENDIF 
     1263               END DO 
     1264            END DO 
     1265         END DO 
     1266 
     1267      ENDIF 
     1268      !  
     1269   END SUBROUTINE interpumsk 
     1270 
     1271   SUBROUTINE interpvmsk(ptab,i1,i2,j1,j2,k1,k2,before,nb,ndir) 
     1272      !!---------------------------------------------------------------------- 
     1273      !!                  ***  ROUTINE interpvmsk  *** 
     1274      !!----------------------------------------------------------------------   
     1275      !  
     1276      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
     1277      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     1278      LOGICAL :: before 
     1279      INTEGER, INTENT(in) :: nb , ndir 
     1280      ! 
     1281      INTEGER :: ji, jj, jk 
     1282      LOGICAL :: northern_side, southern_side      
     1283      !!----------------------------------------------------------------------   
     1284      !     
     1285      IF (before) THEN 
     1286         DO jk=k1,k2 
     1287            DO jj=j1,j2 
     1288               DO ji=i1,i2 
     1289                  ptab(ji,jj,jk) = vmask(ji,jj,jk) 
     1290               END DO 
     1291            END DO 
     1292         END DO 
     1293      ELSE 
     1294 
     1295         southern_side = (nb == 2).AND.(ndir == 1) 
     1296         northern_side = (nb == 2).AND.(ndir == 2) 
     1297         DO jk=k1,k2 
     1298            DO jj=j1,j2 
     1299               DO ji=i1,i2 
     1300                   ! Velocity mask at boundary edge points: 
     1301                  IF (ABS(ptab(ji,jj,jk) - vmask(ji,jj,jk)) > 1.D-2) THEN 
     1302                     IF (southern_side) THEN 
     1303                        WRITE(numout,*) 'ERROR with vmask at the southern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 
     1304                        WRITE(numout,*) '      masks: parent, child ', ptab(ji,jj,jk), vmask(ji,jj,jk) 
     1305                        kindic_agr = kindic_agr + 1 
     1306                     ELSEIF (northern_side) THEN 
     1307                        WRITE(numout,*) 'ERROR with vmask at the northern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 
     1308                        WRITE(numout,*) '      masks: parent, child ', ptab(ji,jj,jk), vmask(ji,jj,jk) 
     1309                        kindic_agr = kindic_agr + 1 
     1310                     ENDIF 
     1311                  ENDIF 
     1312               END DO 
     1313            END DO 
     1314         END DO 
     1315 
     1316      ENDIF 
     1317      !  
     1318   END SUBROUTINE interpvmsk 
     1319 
     1320# if defined key_zdftke 
     1321 
     1322   SUBROUTINE interpavm(ptab,i1,i2,j1,j2,k1,k2,before) 
     1323      !!---------------------------------------------------------------------- 
     1324      !!                  ***  ROUTINE interavm  *** 
     1325      !!----------------------------------------------------------------------   
     1326      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
     1327      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     1328      LOGICAL, INTENT(in) :: before 
     1329      !!----------------------------------------------------------------------   
     1330      !       
     1331      IF( before) THEN 
     1332         ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2) 
     1333      ELSE 
     1334         avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 
     1335      ENDIF 
     1336      ! 
     1337   END SUBROUTINE interpavm 
     1338 
     1339# endif /* key_zdftke */ 
    10461340 
    10471341#else 

  • branches/2015/dev_r5072_UKMO2_OBS_simplification/NEMOGCM/NEMO/NST_SRC/agrif_opa_sponge.F90

    r4153 r5682  
    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) * re2u_e1u(ji,jj) * fse3u_n(ji,jj,jk) 
     213                     zabe2 = fsaht_spv(ji,jj) * vmask(ji,jj,jk) * re1v_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_e12t(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_e12t(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_e12f(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_e12t(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_e12f(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/2015/dev_r5072_UKMO2_OBS_simplification/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90

    r4491 r5682  
    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 
    … …  
    1112   USE wrk_nemo   
    1213   USE dynspg_oce 
     14   USE zdf_oce        ! vertical physics: ocean variables  
    1315 
    1416   IMPLICIT NONE 
    1517   PRIVATE 
    1618 
    17    PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn 
    18  
    19    INTEGER, PUBLIC :: nbcline = 0 
    20  
     19   PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn,Update_Scales 
     20# if defined key_zdftke 
     21   PUBLIC Agrif_Update_Tke 
     22# endif 
    2123   !!---------------------------------------------------------------------- 
    22    !! NEMO/NST 3.3 , NEMO Consortium (2010) 
     24   !! NEMO/NST 3.6 , NEMO Consortium (2010) 
    2325   !! $Id$ 
    2426   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    … …  
    2729CONTAINS 
    2830 
    29    SUBROUTINE Agrif_Update_Tra( kt ) 
     31   RECURSIVE SUBROUTINE Agrif_Update_Tra( ) 
    3032      !!--------------------------------------------- 
    3133      !!   *** ROUTINE Agrif_Update_Tra *** 
    3234      !!--------------------------------------------- 
    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 ) 
     35      !  
     36      IF (Agrif_Root()) RETURN 
     37      ! 
     38#if defined TWO_WAY   
     39      IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update tracers  from grid Number',Agrif_Fixed(), 'nbcline', nbcline 
    4140 
    4241      Agrif_UseSpecialValueInUpdate = .TRUE. 
    4342      Agrif_SpecialValueFineGrid = 0. 
    44  
     43      !  
    4544      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  
     45# if ! defined DECAL_FEEDBACK 
     46         CALL Agrif_Update_Variable(tsn_id, procname=updateTS) 
     47# else 
     48         CALL Agrif_Update_Variable(tsn_id, locupdate=(/1,0/),procname=updateTS) 
     49# endif 
     50      ELSE 
     51# if ! defined DECAL_FEEDBACK 
     52         CALL Agrif_Update_Variable(tsn_id,locupdate=(/0,2/), procname=updateTS) 
     53# else 
     54         CALL Agrif_Update_Variable(tsn_id,locupdate=(/1,2/), procname=updateTS) 
     55# endif 
     56      ENDIF 
     57      ! 
    5158      Agrif_UseSpecialValueInUpdate = .FALSE. 
    52  
    53       CALL wrk_dealloc( jpi, jpj, jpk, jpts, ztab ) 
     59      ! 
     60      IF ( lk_agrif_doupd ) THEN ! Initialisation: do recursive update: 
     61         CALL Agrif_ChildGrid_To_ParentGrid() 
     62         CALL Agrif_Update_Tra() 
     63         CALL Agrif_ParentGrid_To_ChildGrid() 
     64      ENDIF 
     65      ! 
    5466#endif 
    55  
     67      ! 
    5668   END SUBROUTINE Agrif_Update_Tra 
    5769 
    58    SUBROUTINE Agrif_Update_Dyn( kt ) 
     70   RECURSIVE SUBROUTINE Agrif_Update_Dyn( ) 
    5971      !!--------------------------------------------- 
    6072      !!   *** ROUTINE Agrif_Update_Dyn *** 
    6173      !!--------------------------------------------- 
    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 
     74      !  
     75      IF (Agrif_Root()) RETURN 
     76      ! 
    6977#if defined TWO_WAY 
    70       CALL wrk_alloc( jpi, jpj,      ztab2d ) 
    71       CALL wrk_alloc( jpi, jpj, jpk, ztab   ) 
    72  
     78      IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update momentum from grid Number',Agrif_Fixed(), 'nbcline', nbcline 
     79 
     80      Agrif_UseSpecialValueInUpdate = .FALSE. 
     81      Agrif_SpecialValueFineGrid = 0. 
     82      !      
    7383      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 
     84# if ! defined DECAL_FEEDBACK 
     85         CALL Agrif_Update_Variable(un_update_id,procname = updateU) 
     86         CALL Agrif_Update_Variable(vn_update_id,procname = updateV) 
     87# else 
     88         CALL Agrif_Update_Variable(un_update_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateU) 
     89         CALL Agrif_Update_Variable(vn_update_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updateV) 
     90# endif 
     91      ELSE 
     92# if ! defined DECAL_FEEDBACK 
     93         CALL Agrif_Update_Variable(un_update_id,locupdate=(/0,1/),procname = updateU) 
     94         CALL Agrif_Update_Variable(vn_update_id,locupdate=(/0,1/),procname = updateV)          
     95# else 
     96         CALL Agrif_Update_Variable(un_update_id,locupdate1=(/0,1/),locupdate2=(/1,1/),procname = updateU) 
     97         CALL Agrif_Update_Variable(vn_update_id,locupdate1=(/1,1/),locupdate2=(/0,1/),procname = updateV) 
     98# endif 
     99      ENDIF 
     100 
     101# if ! defined DECAL_FEEDBACK 
     102      CALL Agrif_Update_Variable(e1u_id,procname = updateU2d) 
     103      CALL Agrif_Update_Variable(e2v_id,procname = updateV2d)   
     104# else 
     105      CALL Agrif_Update_Variable(e1u_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateU2d) 
     106      CALL Agrif_Update_Variable(e2v_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updateV2d)   
     107# endif 
     108 
     109# if defined key_dynspg_ts 
    85110      IF (ln_bt_fw) THEN 
    86111         ! Update time integrated transports 
    87112         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) 
     113#  if ! defined DECAL_FEEDBACK 
     114            CALL Agrif_Update_Variable(ub2b_update_id,procname = updateub2b) 
     115            CALL Agrif_Update_Variable(vb2b_update_id,procname = updatevb2b) 
     116#  else 
     117            CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateub2b) 
     118            CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updatevb2b) 
     119#  endif 
    90120         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) 
     121#  if ! defined DECAL_FEEDBACK 
     122            CALL Agrif_Update_Variable(ub2b_update_id,locupdate=(/0,1/),procname = updateub2b) 
     123            CALL Agrif_Update_Variable(vb2b_update_id,locupdate=(/0,1/),procname = updatevb2b) 
     124#  else 
     125            CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/0,1/),locupdate2=(/1,1/),procname = updateub2b) 
     126            CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1,1/),locupdate2=(/0,1/),procname = updatevb2b) 
     127#  endif 
    93128         ENDIF 
    94       END IF  
     129      END IF 
     130# endif 
     131      ! 
     132      nbcline = nbcline + 1 
     133      ! 
     134      Agrif_UseSpecialValueInUpdate = .TRUE. 
     135      Agrif_SpecialValueFineGrid = 0. 
     136# if ! defined DECAL_FEEDBACK 
     137      CALL Agrif_Update_Variable(sshn_id,procname = updateSSH) 
     138# else 
     139      CALL Agrif_Update_Variable(sshn_id,locupdate=(/1,0/),procname = updateSSH) 
     140# endif 
     141      Agrif_UseSpecialValueInUpdate = .FALSE. 
     142      !  
    95143#endif 
    96  
    97       nbcline = nbcline + 1 
    98  
    99       Agrif_UseSpecialValueInUpdate = .TRUE.  
     144      ! 
     145      ! Do recursive update: 
     146      IF ( lk_agrif_doupd ) THEN ! Initialisation: do recursive update: 
     147         CALL Agrif_ChildGrid_To_ParentGrid() 
     148         CALL Agrif_Update_Dyn() 
     149         CALL Agrif_ParentGrid_To_ChildGrid() 
     150      ENDIF 
     151      ! 
     152   END SUBROUTINE Agrif_Update_Dyn 
     153 
     154# if defined key_zdftke 
     155   SUBROUTINE Agrif_Update_Tke( kt ) 
     156      !!--------------------------------------------- 
     157      !!   *** ROUTINE Agrif_Update_Tke *** 
     158      !!--------------------------------------------- 
     159      !! 
     160      INTEGER, INTENT(in) :: kt 
     161      !        
     162      IF( ( Agrif_NbStepint() .NE. 0 ) .AND. (kt /= 0) ) RETURN 
     163#  if defined TWO_WAY 
     164 
     165      Agrif_UseSpecialValueInUpdate = .TRUE. 
    100166      Agrif_SpecialValueFineGrid = 0. 
    101       CALL Agrif_Update_Variable(ztab2d,sshn_id,procname = updateSSH) 
     167 
     168      CALL Agrif_Update_Variable( en_id, locupdate=(/0,0/), procname=updateEN  ) 
     169      CALL Agrif_Update_Variable(avt_id, locupdate=(/0,0/), procname=updateAVT ) 
     170      CALL Agrif_Update_Variable(avm_id, locupdate=(/0,0/), procname=updateAVM ) 
     171 
    102172      Agrif_UseSpecialValueInUpdate = .FALSE. 
    103173 
    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 
     174#  endif 
     175       
     176   END SUBROUTINE Agrif_Update_Tke 
     177# endif /* key_zdftke */ 
    123178 
    124179   SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) 
    … …  
    127182      !!--------------------------------------------- 
    128183#  include "domzgr_substitute.h90" 
    129  
    130184      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
    131185      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 
    132       LOGICAL, iNTENT(in) :: before 
    133  
     186      LOGICAL, INTENT(in) :: before 
     187      !! 
    134188      INTEGER :: ji,jj,jk,jn 
    135  
     189      !!--------------------------------------------- 
     190      ! 
    136191      IF (before) THEN 
    137192         DO jn = n1,n2 
    … …  
    146201      ELSE 
    147202         IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 
    148          ! Add asselin part 
     203            ! Add asselin part 
    149204            DO jn = n1,n2 
    150205               DO jk=k1,k2 
    … …  
    153208                        IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN 
    154209                           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) 
     210                                 & + atfp * ( tabres(ji,jj,jk,jn) & 
     211                                 &             - tsn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 
    157212                        ENDIF 
    158213                     ENDDO 
    … …  
    161216            ENDDO 
    162217         ENDIF 
    163  
    164218         DO jn = n1,n2 
    165219            DO jk=k1,k2 
    … …  
    174228         END DO 
    175229      ENDIF 
    176  
     230      !  
    177231   END SUBROUTINE updateTS 
    178232 
    … …  
    182236      !!--------------------------------------------- 
    183237#  include "domzgr_substitute.h90" 
    184  
     238      !! 
    185239      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 
    186240      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 
    187241      LOGICAL, INTENT(in) :: before 
    188  
     242      !!  
    189243      INTEGER :: ji, jj, jk 
    190244      REAL(wp) :: zrhoy 
    191  
     245      !!--------------------------------------------- 
     246      !  
    192247      IF (before) THEN 
    193248         zrhoy = Agrif_Rhoy() 
    … …  
    209264                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 
    210265                     ub(ji,jj,jk) = ub(ji,jj,jk) &  
    211                        & + atfp * ( tabres(ji,jj,jk) - un(ji,jj,jk) ) * umask(ji,jj,jk) 
     266                           & + atfp * ( tabres(ji,jj,jk) - un(ji,jj,jk) ) * umask(ji,jj,jk) 
    212267                  ENDIF 
    213268                  ! 
    … …  
    217272         END DO 
    218273      ENDIF 
    219  
     274      !  
    220275   END SUBROUTINE updateu 
    221276 
    … …  
    225280      !!--------------------------------------------- 
    226281#  include "domzgr_substitute.h90" 
    227  
     282      !! 
    228283      INTEGER :: i1,i2,j1,j2,k1,k2 
    229284      INTEGER :: ji,jj,jk 
    230285      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: tabres 
    231286      LOGICAL :: before 
    232  
     287      !! 
    233288      REAL(wp) :: zrhox 
    234  
     289      !!---------------------------------------------       
     290      ! 
    235291      IF (before) THEN 
    236292         zrhox = Agrif_Rhox() 
    … …  
    252308                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 
    253309                     vb(ji,jj,jk) = vb(ji,jj,jk) &  
    254                        & + atfp * ( tabres(ji,jj,jk) - vn(ji,jj,jk) ) * vmask(ji,jj,jk) 
     310                           & + atfp * ( tabres(ji,jj,jk) - vn(ji,jj,jk) ) * vmask(ji,jj,jk) 
    255311                  ENDIF 
    256312                  ! 
    … …  
    260316         END DO 
    261317      ENDIF 
    262  
     318      !  
    263319   END SUBROUTINE updatev 
    264320 
    … …  
    268324      !!--------------------------------------------- 
    269325#  include "domzgr_substitute.h90" 
    270  
     326      !! 
    271327      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    272328      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    273329      LOGICAL, INTENT(in) :: before 
    274  
     330      !!  
    275331      INTEGER :: ji, jj, jk 
    276332      REAL(wp) :: zrhoy 
    277333      REAL(wp) :: zcorr 
    278  
     334      !!--------------------------------------------- 
     335      ! 
    279336      IF (before) THEN 
    280337         zrhoy = Agrif_Rhoy() 
    … …  
    326383         END DO 
    327384      ENDIF 
    328  
     385      ! 
    329386   END SUBROUTINE updateu2d 
    330387 
    … …  
    333390      !!          *** ROUTINE updatev2d *** 
    334391      !!--------------------------------------------- 
    335  
    336392      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    337393      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    338394      LOGICAL, INTENT(in) :: before 
    339  
     395      !!  
    340396      INTEGER :: ji, jj, jk 
    341397      REAL(wp) :: zrhox 
    342398      REAL(wp) :: zcorr 
    343  
     399      !!--------------------------------------------- 
     400      ! 
    344401      IF (before) THEN 
    345402         zrhox = Agrif_Rhox() 
    … …  
    391448         END DO 
    392449      ENDIF 
    393  
     450      !  
    394451   END SUBROUTINE updatev2d 
    395452 
     453 
    396454   SUBROUTINE updateSSH( tabres, i1, i2, j1, j2, before ) 
    397455      !!--------------------------------------------- 
    398456      !!          *** ROUTINE updateSSH *** 
    399457      !!--------------------------------------------- 
    400 #  include "domzgr_substitute.h90" 
    401  
    402458      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    403459      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    404460      LOGICAL, INTENT(in) :: before 
    405  
     461      !! 
    406462      INTEGER :: ji, jj 
    407  
     463      !!--------------------------------------------- 
     464      !  
    408465      IF (before) THEN 
    409466         DO jj=j1,j2 
    … …  
    413470         END DO 
    414471      ELSE 
    415  
    416472#if ! defined key_dynspg_ts 
    417473         IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 
    418474            DO jj=j1,j2 
    419475               DO ji=i1,i2 
    420                 sshb(ji,jj) =   sshb(ji,jj) & 
    421                  & + atfp * ( tabres(ji,jj) - sshn(ji,jj) ) * tmask(ji,jj,1) 
     476                  sshb(ji,jj) =   sshb(ji,jj) & 
     477                        & + atfp * ( tabres(ji,jj) - sshn(ji,jj) ) * tmask(ji,jj,1) 
    422478               END DO 
    423479            END DO 
    … …  
    430486         END DO 
    431487      ENDIF 
    432  
     488      ! 
    433489   END SUBROUTINE updateSSH 
    434490 
    … …  
    437493      !!          *** ROUTINE updateub2b *** 
    438494      !!--------------------------------------------- 
    439  
    440495      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    441496      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    442497      LOGICAL, INTENT(in) :: before 
    443  
     498      !! 
    444499      INTEGER :: ji, jj 
    445500      REAL(wp) :: zrhoy 
    446  
     501      !!--------------------------------------------- 
     502      ! 
    447503      IF (before) THEN 
    448504         zrhoy = Agrif_Rhoy() 
    … …  
    460516         END DO 
    461517      ENDIF 
    462  
     518      ! 
    463519   END SUBROUTINE updateub2b 
    464520 
    … …  
    467523      !!          *** ROUTINE updatevb2b *** 
    468524      !!--------------------------------------------- 
    469  
    470525      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    471526      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    472527      LOGICAL, INTENT(in) :: before 
    473  
     528      !! 
    474529      INTEGER :: ji, jj 
    475530      REAL(wp) :: zrhox 
    476  
     531      !!--------------------------------------------- 
     532      ! 
    477533      IF (before) THEN 
    478534         zrhox = Agrif_Rhox() 
    … …  
    490546         END DO 
    491547      ENDIF 
    492  
     548      ! 
    493549   END SUBROUTINE updatevb2b 
     550 
     551 
     552   SUBROUTINE update_scales( tabres, i1, i2, j1, j2, k1, k2, n1,n2, before ) 
     553      ! currently not used 
     554      !!--------------------------------------------- 
     555      !!           *** ROUTINE updateT *** 
     556      !!--------------------------------------------- 
     557#  include "domzgr_substitute.h90" 
     558 
     559      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
     560      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 
     561      LOGICAL, iNTENT(in) :: before 
     562 
     563      INTEGER :: ji,jj,jk 
     564      REAL(wp) :: ztemp 
     565 
     566      IF (before) THEN 
     567         DO jk=k1,k2 
     568            DO jj=j1,j2 
     569               DO ji=i1,i2 
     570                  tabres(ji,jj,jk,1) = e1t(ji,jj)*e2t(ji,jj)*tmask(ji,jj,jk) 
     571                  tabres(ji,jj,jk,2) = e1t(ji,jj)*tmask(ji,jj,jk) 
     572                  tabres(ji,jj,jk,3) = e2t(ji,jj)*tmask(ji,jj,jk) 
     573               END DO 
     574            END DO 
     575         END DO 
     576         tabres(:,:,:,1)=tabres(:,:,:,1)*Agrif_Rhox()*Agrif_Rhoy() 
     577         tabres(:,:,:,2)=tabres(:,:,:,2)*Agrif_Rhox() 
     578         tabres(:,:,:,3)=tabres(:,:,:,3)*Agrif_Rhoy() 
     579      ELSE 
     580         DO jk=k1,k2 
     581            DO jj=j1,j2 
     582               DO ji=i1,i2 
     583                  IF( tabres(ji,jj,jk,1) .NE. 0. ) THEN  
     584                     print *,'VAL = ',ji,jj,jk,tabres(ji,jj,jk,1),e1t(ji,jj)*e2t(ji,jj)*tmask(ji,jj,jk) 
     585                     print *,'VAL2 = ',ji,jj,jk,tabres(ji,jj,jk,2),e1t(ji,jj)*tmask(ji,jj,jk) 
     586                     print *,'VAL3 = ',ji,jj,jk,tabres(ji,jj,jk,3),e2t(ji,jj)*tmask(ji,jj,jk) 
     587                     ztemp = sqrt(tabres(ji,jj,jk,1)/(tabres(ji,jj,jk,2)*tabres(ji,jj,jk,3))) 
     588                     print *,'CORR = ',ztemp-1. 
     589                     print *,'NEW VALS = ',tabres(ji,jj,jk,2)*ztemp,tabres(ji,jj,jk,3)*ztemp, & 
     590                           tabres(ji,jj,jk,2)*ztemp*tabres(ji,jj,jk,3)*ztemp 
     591                     e1t(ji,jj) = tabres(ji,jj,jk,2)*ztemp 
     592                     e2t(ji,jj) = tabres(ji,jj,jk,3)*ztemp 
     593                  END IF 
     594               END DO 
     595            END DO 
     596         END DO 
     597      ENDIF 
     598      ! 
     599   END SUBROUTINE update_scales 
     600 
     601# if defined key_zdftke 
     602   SUBROUTINE updateEN( ptab, i1, i2, j1, j2, k1, k2, before ) 
     603      !!--------------------------------------------- 
     604      !!           *** ROUTINE updateen *** 
     605      !!--------------------------------------------- 
     606      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 
     607      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     608      LOGICAL, INTENT(in) :: before 
     609      !!--------------------------------------------- 
     610      ! 
     611      IF (before) THEN 
     612         ptab (i1:i2,j1:j2,k1:k2) = en(i1:i2,j1:j2,k1:k2) 
     613      ELSE 
     614         en(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2)  
     615      ENDIF 
     616      ! 
     617   END SUBROUTINE updateEN 
     618 
     619 
     620   SUBROUTINE updateAVT( ptab, i1, i2, j1, j2, k1, k2, before ) 
     621      !!--------------------------------------------- 
     622      !!           *** ROUTINE updateavt *** 
     623      !!--------------------------------------------- 
     624      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 
     625      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     626      LOGICAL, INTENT(in) :: before 
     627      !!--------------------------------------------- 
     628      ! 
     629      IF (before) THEN 
     630         ptab (i1:i2,j1:j2,k1:k2) = avt_k(i1:i2,j1:j2,k1:k2) 
     631      ELSE 
     632         avt_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2)  
     633      ENDIF 
     634      ! 
     635   END SUBROUTINE updateAVT 
     636 
     637 
     638   SUBROUTINE updateAVM( ptab, i1, i2, j1, j2, k1, k2, before ) 
     639      !!--------------------------------------------- 
     640      !!           *** ROUTINE updateavm *** 
     641      !!--------------------------------------------- 
     642      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 
     643      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     644      LOGICAL, INTENT(in) :: before 
     645      !!--------------------------------------------- 
     646      ! 
     647      IF (before) THEN 
     648         ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2) 
     649      ELSE 
     650         avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2)  
     651      ENDIF 
     652      ! 
     653   END SUBROUTINE updateAVM 
     654 
     655# endif /* key_zdftke */  
    494656 
    495657#else 

  • branches/2015/dev_r5072_UKMO2_OBS_simplification/NEMOGCM/NEMO/NST_SRC/agrif_top_interp.F90

    r3680 r5682  
    77   USE agrif_oce 
    88   USE agrif_top_sponge 
     9   USE par_trc 
    910   USE trc 
    1011   USE lib_mpp 
    … …  
    1415   PRIVATE 
    1516 
    16    PUBLIC Agrif_trc 
     17   PUBLIC Agrif_trc, interptrn 
    1718 
    1819#  include "domzgr_substitute.h90"   
    1920#  include "vectopt_loop_substitute.h90" 
    2021  !!---------------------------------------------------------------------- 
    21    !! NEMO/NST 3.3 , NEMO Consortium (2010) 
     22   !! NEMO/NST 3.6 , NEMO Consortium (2010) 
    2223   !! $Id$ 
    2324   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    … …  
    2829   SUBROUTINE Agrif_trc 
    2930      !!---------------------------------------------------------------------- 
    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 
     31      !!                  ***  ROUTINE Agrif_trc  *** 
    3732      !!---------------------------------------------------------------------- 
    3833      ! 
    3934      IF( Agrif_Root() )   RETURN 
    4035 
    41       CALL wrk_alloc( jpi, jpj, jpk, jptra, ztra ) 
    42  
    4336      Agrif_SpecialValue    = 0.e0 
    4437      Agrif_UseSpecialValue = .TRUE. 
    45       ztra(:,:,:,:) = 0.e0 
    4638 
    47       CALL Agrif_Bc_variable( ztra, trn_id, procname=interptrn ) 
     39      CALL Agrif_Bc_variable( trn_id, procname=interptrn ) 
    4840      Agrif_UseSpecialValue = .FALSE. 
     41      ! 
     42   END SUBROUTINE Agrif_trc 
    4943 
    50       zrhox = Agrif_Rhox() 
     44   SUBROUTINE interptrn(ptab,i1,i2,j1,j2,k1,k2,n1,n2,before,nb,ndir) 
     45      !!--------------------------------------------- 
     46      !!   *** ROUTINE interptrn *** 
     47      !!--------------------------------------------- 
     48      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab 
     49      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
     50      LOGICAL, INTENT(in) :: before 
     51      INTEGER, INTENT(in) :: nb , ndir 
     52      ! 
     53      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
     54      INTEGER :: imin, imax, jmin, jmax 
     55      REAL(wp) ::   zrhox , zalpha1, zalpha2, zalpha3 
     56      REAL(wp) ::   zalpha4, zalpha5, zalpha6, zalpha7 
     57      LOGICAL :: western_side, eastern_side,northern_side,southern_side 
    5158 
    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) 
     59      IF (before) THEN          
     60         ptab(i1:i2,j1:j2,k1:k2,n1:n2) = trn(i1:i2,j1:j2,k1:k2,n1:n2) 
     61      ELSE 
     62         ! 
     63         western_side  = (nb == 1).AND.(ndir == 1) 
     64         eastern_side  = (nb == 1).AND.(ndir == 2) 
     65         southern_side = (nb == 2).AND.(ndir == 1) 
     66         northern_side = (nb == 2).AND.(ndir == 2) 
     67         ! 
     68         zrhox = Agrif_Rhox() 
     69         !  
     70         zalpha1 = ( zrhox - 1. ) * 0.5 
     71         zalpha2 = 1. - zalpha1 
     72         !  
     73         zalpha3 = ( zrhox - 1. ) / ( zrhox + 1. ) 
     74         zalpha4 = 1. - zalpha3 
     75         !  
     76         zalpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 
     77         zalpha7 =    - ( zrhox - 1. ) / ( zrhox + 3. ) 
     78         zalpha5 = 1. - zalpha6 - zalpha7 
     79         ! 
     80         imin = i1 
     81         imax = i2 
     82         jmin = j1 
     83         jmax = j2 
     84         !  
     85         ! Remove CORNERS 
     86         IF((nbondj == -1).OR.(nbondj == 2)) jmin = 3 
     87         IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj-2 
     88         IF((nbondi == -1).OR.(nbondi == 2)) imin = 3 
     89         IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci-2         
     90         ! 
     91         IF( eastern_side) THEN 
     92            DO jn = 1, jptra 
     93               tra(nlci,j1:j2,k1:k2,jn) = zalpha1 * ptab(nlci,j1:j2,k1:k2,jn) + zalpha2 * ptab(nlci-1,j1:j2,k1:k2,jn) 
     94               DO jk = 1, jpkm1 
     95                  DO jj = jmin,jmax 
     96                     IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN 
     97                        tra(nlci-1,jj,jk,jn) = tra(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 
     98                     ELSE 
     99                        tra(nlci-1,jj,jk,jn)=(zalpha4*tra(nlci,jj,jk,jn)+zalpha3*tra(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 
     100                        IF( un(nlci-2,jj,jk) > 0.e0 ) THEN 
     101                           tra(nlci-1,jj,jk,jn)=( zalpha6*tra(nlci-2,jj,jk,jn)+zalpha5*tra(nlci,jj,jk,jn) &  
     102                                 + zalpha7*tra(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 
     103                        ENDIF 
    74104                     ENDIF 
    75                   ENDIF 
     105                  END DO 
     106               END DO 
     107            ENDDO 
     108         ENDIF 
     109         !  
     110         IF( northern_side ) THEN             
     111            DO jn = 1, jptra 
     112               tra(i1:i2,nlcj,k1:k2,jn) = zalpha1 * ptab(i1:i2,nlcj,k1:k2,jn) + zalpha2 * ptab(i1:i2,nlcj-1,k1:k2,jn) 
     113               DO jk = 1, jpkm1 
     114                  DO ji = imin,imax 
     115                     IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN 
     116                        tra(ji,nlcj-1,jk,jn) = tra(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 
     117                     ELSE 
     118                        tra(ji,nlcj-1,jk,jn)=(zalpha4*tra(ji,nlcj,jk,jn)+zalpha3*tra(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk)         
     119                        IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN 
     120                           tra(ji,nlcj-1,jk,jn)=( zalpha6*tra(ji,nlcj-2,jk,jn)+zalpha5*tra(ji,nlcj,jk,jn)  & 
     121                                 + zalpha7*tra(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( western_side) THEN             
     130            DO jn = 1, jptra 
     131               tra(1,j1:j2,k1:k2,jn) = zalpha1 * ptab(1,j1:j2,k1:k2,jn) + zalpha2 * ptab(2,j1:j2,k1:k2,jn) 
     132               DO jk = 1, jpkm1 
     133                  DO jj = jmin,jmax 
     134                     IF( umask(2,jj,jk) == 0.e0 ) THEN 
     135                        tra(2,jj,jk,jn) = tra(1,jj,jk,jn) * tmask(2,jj,jk) 
     136                     ELSE 
     137                        tra(2,jj,jk,jn)=(zalpha4*tra(1,jj,jk,jn)+zalpha3*tra(3,jj,jk,jn))*tmask(2,jj,jk)         
     138                        IF( un(2,jj,jk) < 0.e0 ) THEN 
     139                           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) 
     140                        ENDIF 
     141                     ENDIF 
     142                  END DO 
    76143               END DO 
    77144            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) 
     145         ENDIF 
     146         ! 
     147         IF( southern_side ) THEN            
     148            DO jn = 1, jptra 
     149               tra(i1:i2,1,k1:k2,jn) = zalpha1 * ptab(i1:i2,1,k1:k2,jn) + zalpha2 * ptab(i1:i2,2,k1:k2,jn) 
     150               DO jk=1,jpk       
     151                  DO ji=imin,imax 
     152                     IF( vmask(ji,2,jk) == 0.e0 ) THEN 
     153                        tra(ji,2,jk,jn)=tra(ji,1,jk,jn) * tmask(ji,2,jk) 
     154                     ELSE 
     155                        tra(ji,2,jk,jn)=(zalpha4*tra(ji,1,jk,jn)+zalpha3*tra(ji,3,jk,jn))*tmask(ji,2,jk) 
     156                        IF( vn(ji,2,jk) < 0.e0 ) THEN 
     157                           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) 
     158                        ENDIF 
    94159                     ENDIF 
    95                   ENDIF 
     160                  END DO 
    96161               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 
     162            ENDDO 
     163         ENDIF 
     164         ! 
     165         ! Treatment of corners 
     166         !  
     167         ! East south 
     168         IF ((eastern_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 
     169            tra(nlci-1,2,:,:) = ptab(nlci-1,2,:,:) 
     170         ENDIF 
     171         ! East north 
     172         IF ((eastern_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 
     173            tra(nlci-1,nlcj-1,:,:) = ptab(nlci-1,nlcj-1,:,:) 
     174         ENDIF 
     175         ! West south 
     176         IF ((western_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 
     177            tra(2,2,:,:) = ptab(2,2,:,:) 
     178         ENDIF 
     179         ! West north 
     180         IF ((western_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 
     181            tra(2,nlcj-1,:,:) = ptab(2,nlcj-1,:,:) 
     182         ENDIF 
     183         ! 
    134184      ENDIF 
    135185      ! 
    136       CALL wrk_dealloc( jpi, jpj, jpk, jptra, ztra ) 
    137       ! 
    138  
    139    END SUBROUTINE Agrif_trc 
     186   END SUBROUTINE interptrn 
    140187 
    141188#else 

  • branches/2015/dev_r5072_UKMO2_OBS_simplification/NEMOGCM/NEMO/NST_SRC/agrif_top_sponge.F90

    r3680 r5682  
    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) * re2u_e1u(ji,jj) * fse3u_n(ji,jj,jk) 
     77                     zabe2 = fsaht_spv(ji,jj) * vmask(ji,jj,jk) * re1v_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_e12t(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/2015/dev_r5072_UKMO2_OBS_simplification/NEMOGCM/NEMO/NST_SRC/agrif_top_update.F90

    r4491 r5682  
    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/2015/dev_r5072_UKMO2_OBS_simplification/NEMOGCM/NEMO/NST_SRC/agrif_user.F90

    r4624 r5682  
    1717   USE par_oce 
    1818   USE dom_oce 
    19    USE Agrif_Util 
    2019   USE nemogcm 
    2120   ! 
    … …  
    3130      jpi     = ( jpiglo-2*jpreci + (jpni-1+0) ) / jpni + 2*jpreci 
    3231      jpj     = ( jpjglo-2*jprecj + (jpnj-1+0) ) / jpnj + 2*jprecj 
    33       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  
    3437      jpim1   = jpi-1  
    3538      jpjm1   = jpj-1  
    … …  
    6467   ! 0. Initializations 
    6568   !------------------- 
    66    IF( cp_cfg == 'orca' ) then 
     69   IF( cp_cfg == 'orca' ) THEN 
    6770      IF ( jp_cfg == 2 .OR. jp_cfg == 025 .OR. jp_cfg == 05 & 
    68   &                      .OR. jp_cfg == 4 ) THEN 
     71            &                      .OR. jp_cfg == 4 ) THEN 
    6972         jp_cfg = -1    ! set special value for jp_cfg on fine grids 
    7073         cp_cfg = "default" 
    … …  
    120123SUBROUTINE agrif_declare_var_dom 
    121124   !!---------------------------------------------------------------------- 
    122    !!                 *** ROUTINE agrif_declarE_var *** 
     125   !!                 *** ROUTINE agrif_declare_var *** 
    123126   !! 
    124127   !! ** Purpose :: Declaration of variables to be interpolated 
    125128   !!---------------------------------------------------------------------- 
    126129   USE agrif_util 
    127    USE par_oce       !   ONLY : jpts 
     130   USE par_oce        
    128131   USE oce 
    129132   IMPLICIT NONE 
    … …  
    132135   ! 1. Declaration of the type of variable which have to be interpolated 
    133136   !--------------------------------------------------------------------- 
    134    CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),e1u_id) 
    135    CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/jpi,jpj/),e2v_id) 
    136  
     137   CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),e1u_id) 
     138   CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),e2v_id) 
    137139 
    138140   ! 2. Type of interpolation 
    139141   !------------------------- 
    140    Call Agrif_Set_bcinterp(e1u_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    141    Call Agrif_Set_bcinterp(e2v_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     142   CALL Agrif_Set_bcinterp(e1u_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
     143   CALL Agrif_Set_bcinterp(e2v_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
    142144 
    143145   ! 3. Location of interpolation 
    144146   !----------------------------- 
    145    Call Agrif_Set_bc(e1u_id,(/0,0/)) 
    146    Call Agrif_Set_bc(e2v_id,(/0,0/)) 
     147   CALL Agrif_Set_bc(e1u_id,(/0,0/)) 
     148   CALL Agrif_Set_bc(e2v_id,(/0,0/)) 
    147149 
    148150   ! 5. Update type 
    149151   !---------------  
    150    Call Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Copy, update2=Agrif_Update_Average) 
    151    Call Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Average, update2=Agrif_Update_Copy) 
    152  
     152   CALL Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Copy, update2=Agrif_Update_Average) 
     153   CALL Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Average, update2=Agrif_Update_Copy) 
     154 
     155! High order updates 
     156!   CALL Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Average,            update2=Agrif_Update_Full_Weighting) 
     157!   CALL Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Full_Weighting,     update2=Agrif_Update_Average) 
     158    ! 
    153159END SUBROUTINE agrif_declare_var_dom 
    154160 
    … …  
    167173   USE nemogcm 
    168174   USE sol_oce 
     175   USE lib_mpp 
    169176   USE in_out_manager 
    170177   USE agrif_opa_update 
    … …  
    174181   IMPLICIT NONE 
    175182   ! 
    176    REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: tabtstemp 
    177    REAL(wp), DIMENSION(:,:,:  ), ALLOCATABLE :: tabuvtemp 
    178    REAL(wp), DIMENSION(:,:    ), ALLOCATABLE :: tab2d 
    179183   LOGICAL :: check_namelist 
    180    !!---------------------------------------------------------------------- 
    181  
    182    ALLOCATE( tabtstemp(jpi, jpj, jpk, jpts) ) 
    183    ALLOCATE( tabuvtemp(jpi, jpj, jpk)       ) 
    184    ALLOCATE( tab2d(jpi, jpj)                ) 
    185  
     184   CHARACTER(len=15) :: cl_check1, cl_check2, cl_check3 
     185   !!---------------------------------------------------------------------- 
    186186 
    187187   ! 1. Declaration of the type of variable which have to be interpolated 
    … …  
    193193   Agrif_SpecialValue=0. 
    194194   Agrif_UseSpecialValue = .TRUE. 
    195    Call Agrif_Bc_variable(tabtstemp,tsn_id,calledweight=1.,procname=interptsn) 
    196    Call Agrif_Bc_variable(tabtstemp,tsa_id,calledweight=1.,procname=interptsn) 
    197  
    198    Call Agrif_Bc_variable(tabuvtemp,un_id,calledweight=1.,procname=interpu) 
    199    Call Agrif_Bc_variable(tabuvtemp,vn_id,calledweight=1.,procname=interpv) 
    200    Call Agrif_Bc_variable(tabuvtemp,ua_id,calledweight=1.,procname=interpun) 
    201    Call Agrif_Bc_variable(tabuvtemp,va_id,calledweight=1.,procname=interpvn) 
    202  
    203    Call Agrif_Bc_variable(tab2d,unb_id,calledweight=1.,procname=interpunb) 
    204    Call Agrif_Bc_variable(tab2d,vnb_id,calledweight=1.,procname=interpvnb) 
    205    Call Agrif_Bc_variable(tab2d,sshn_id,calledweight=1.,procname=interpsshn) 
    206    Agrif_UseSpecialValue = .FALSE. 
     195   CALL Agrif_Bc_variable(tsn_id,calledweight=1.,procname=interptsn) 
     196   CALL Agrif_Sponge 
     197   tabspongedone_tsn = .FALSE. 
     198   CALL Agrif_Bc_variable(tsn_sponge_id,calledweight=1.,procname=interptsn_sponge) 
     199   ! reset tsa to zero 
     200   tsa(:,:,:,:) = 0. 
     201 
     202   Agrif_UseSpecialValue = ln_spc_dyn 
     203   CALL Agrif_Bc_variable(un_interp_id,calledweight=1.,procname=interpun) 
     204   CALL Agrif_Bc_variable(vn_interp_id,calledweight=1.,procname=interpvn) 
     205   tabspongedone_u = .FALSE. 
     206   tabspongedone_v = .FALSE. 
     207   CALL Agrif_Bc_variable(un_sponge_id,calledweight=1.,procname=interpun_sponge) 
     208   tabspongedone_u = .FALSE. 
     209   tabspongedone_v = .FALSE. 
     210   CALL Agrif_Bc_variable(vn_sponge_id,calledweight=1.,procname=interpvn_sponge) 
     211 
     212#if defined key_dynspg_ts 
     213   Agrif_UseSpecialValue = .TRUE. 
     214   CALL Agrif_Bc_variable(sshn_id,calledweight=1., procname=interpsshn ) 
     215 
     216   Agrif_UseSpecialValue = ln_spc_dyn 
     217   CALL Agrif_Bc_variable(unb_id,calledweight=1.,procname=interpunb) 
     218   CALL Agrif_Bc_variable(vnb_id,calledweight=1.,procname=interpvnb) 
     219   CALL Agrif_Bc_variable(ub2b_interp_id,calledweight=1.,procname=interpub2b) 
     220   CALL Agrif_Bc_variable(vb2b_interp_id,calledweight=1.,procname=interpvb2b) 
     221   ubdy_w(:) = 0.e0 ; vbdy_w(:) = 0.e0 ; hbdy_w(:) =0.e0 
     222   ubdy_e(:) = 0.e0 ; vbdy_e(:) = 0.e0 ; hbdy_e(:) =0.e0  
     223   ubdy_n(:) = 0.e0 ; vbdy_n(:) = 0.e0 ; hbdy_n(:) =0.e0  
     224   ubdy_s(:) = 0.e0 ; vbdy_s(:) = 0.e0 ; hbdy_s(:) =0.e0 
     225#endif 
     226 
     227   Agrif_UseSpecialValue = .FALSE.  
     228   ! reset velocities to zero 
     229   ua(:,:,:) = 0. 
     230   va(:,:,:) = 0. 
    207231 
    208232   ! 3. Some controls 
    209233   !----------------- 
    210    check_namelist = .true. 
    211  
    212    IF( check_namelist ) THEN 
     234   check_namelist = .TRUE. 
     235 
     236   IF( check_namelist ) THEN  
    213237 
    214238      ! Check time steps            
    215       IF( NINT(Agrif_Rhot()) * nint(rdt) /= Agrif_Parent(rdt) ) THEN 
    216          WRITE(*,*) 'incompatible time step between grids' 
    217          WRITE(*,*) 'parent grid value : ',Agrif_Parent(rdt) 
    218          WRITE(*,*) 'child  grid value : ',nint(rdt) 
    219          WRITE(*,*) 'value on parent grid should be : ',rdt*Agrif_Rhot() 
    220          STOP 
     239      IF( NINT(Agrif_Rhot()) * NINT(rdt) .NE. Agrif_Parent(rdt) ) THEN 
     240         WRITE(cl_check1,*)  NINT(Agrif_Parent(rdt)) 
     241         WRITE(cl_check2,*)  NINT(rdt) 
     242         WRITE(cl_check3,*)  NINT(Agrif_Parent(rdt)/Agrif_Rhot()) 
     243         CALL ctl_warn( 'incompatible time step between grids',   & 
     244               &               'parent grid value : '//cl_check1    ,   &  
     245               &               'child  grid value : '//cl_check2    ,   &  
     246               &               'value on child grid will be changed to : '//cl_check3 ) 
     247         rdt=Agrif_Parent(rdt)/Agrif_Rhot() 
    221248      ENDIF 
    222249 
    223250      ! Check run length 
    224251      IF( Agrif_IRhot() * (Agrif_Parent(nitend)- & 
    225            Agrif_Parent(nit000)+1) .ne. (nitend-nit000+1) ) THEN 
    226          WRITE(*,*) 'incompatible run length between grids' 
    227          WRITE(*,*) 'parent grid value : ',(Agrif_Parent(nitend)- & 
    228               Agrif_Parent(nit000)+1),' time step' 
    229          WRITE(*,*) 'child  grid value : ', & 
    230               (nitend-nit000+1),' time step' 
    231          WRITE(*,*) 'value on child grid should be : ', & 
    232               Agrif_IRhot() * (Agrif_Parent(nitend)- & 
    233               Agrif_Parent(nit000)+1) 
    234          STOP 
     252            Agrif_Parent(nit000)+1) .NE. (nitend-nit000+1) ) THEN 
     253         WRITE(cl_check1,*)  (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 
     254         WRITE(cl_check2,*)   Agrif_Parent(nitend)   *Agrif_IRhot() 
     255         CALL ctl_warn( 'incompatible run length between grids'               ,   & 
     256               &              ' nit000 on fine grid will be change to : '//cl_check1,   & 
     257               &              ' nitend on fine grid will be change to : '//cl_check2    ) 
     258         nit000 = (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 
     259         nitend =  Agrif_Parent(nitend)   *Agrif_IRhot() 
    235260      ENDIF 
    236261 
    … …  
    238263      IF( ln_zps ) THEN 
    239264         ! check parameters for partial steps  
    240          IF( Agrif_Parent(e3zps_min) .ne. e3zps_min ) THEN 
     265         IF( Agrif_Parent(e3zps_min) .NE. e3zps_min ) THEN 
    241266            WRITE(*,*) 'incompatible e3zps_min between grids' 
    242267            WRITE(*,*) 'parent grid :',Agrif_Parent(e3zps_min) 
    … …  
    253278         ENDIF 
    254279      ENDIF 
     280      ! check if masks and bathymetries match 
     281      IF(ln_chk_bathy) THEN 
     282         ! 
     283         IF(lwp) WRITE(numout,*) 'AGRIF: Check Bathymetry and masks near bdys. Level: ', Agrif_Level() 
     284         ! 
     285         kindic_agr = 0 
     286         ! check if umask agree with parent along western and eastern boundaries: 
     287         CALL Agrif_Bc_variable(umsk_id,calledweight=1.,procname=interpumsk) 
     288         ! check if vmask agree with parent along northern and southern boundaries: 
     289         CALL Agrif_Bc_variable(vmsk_id,calledweight=1.,procname=interpvmsk) 
     290    ! check if tmask and vertical scale factors agree with parent over first two coarse grid points: 
     291         CALL Agrif_Bc_variable(e3t_id,calledweight=1.,procname=interpe3t) 
     292         ! 
     293         IF (lk_mpp) CALL mpp_sum( kindic_agr ) 
     294         IF( kindic_agr /= 0 ) THEN                    
     295            CALL ctl_stop('Child Bathymetry is not correct near boundaries.') 
     296         ELSE 
     297            IF(lwp) WRITE(numout,*) 'Child Bathymetry is ok near boundaries.' 
     298         END IF 
     299      ENDIF 
     300      ! 
    255301   ENDIF 
    256  
    257    CALL Agrif_Update_tra(0) 
    258    CALL Agrif_Update_dyn(0) 
    259  
     302   !  
     303   ! Do update at initialisation because not done before writing restarts 
     304   ! This would indeed change boundary conditions values at initial time 
     305   ! hence produce restartability issues. 
     306   ! Note that update below is recursive (with lk_agrif_doupd=T): 
     307   !  
     308! JC: I am not sure if Agrif_MaxLevel() is the "relative" 
     309!     or the absolute maximum nesting level...TBC                         
     310   IF ( Agrif_Level().EQ.Agrif_MaxLevel() ) THEN  
     311      ! NB: Do tracers first, dynamics after because nbcline incremented in dynamics 
     312      CALL Agrif_Update_tra() 
     313      CALL Agrif_Update_dyn() 
     314   ENDIF 
     315   ! 
     316# if defined key_zdftke 
     317   CALL Agrif_Update_tke(0) 
     318# endif 
     319   ! 
     320   Agrif_UseSpecialValueInUpdate = .FALSE. 
    260321   nbcline = 0 
    261    ! 
    262    DEALLOCATE(tabtstemp) 
    263    DEALLOCATE(tabuvtemp) 
    264    DEALLOCATE(tab2d) 
     322   lk_agrif_doupd = .FALSE. 
    265323   ! 
    266324END SUBROUTINE Agrif_InitValues_cont 
    … …  
    276334   USE par_oce       !   ONLY : jpts 
    277335   USE oce 
     336   USE agrif_oce 
    278337   IMPLICIT NONE 
    279338   !!---------------------------------------------------------------------- 
    … …  
    281340   ! 1. Declaration of the type of variable which have to be interpolated 
    282341   !--------------------------------------------------------------------- 
    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/),tsn_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/),tsa_id) 
    285    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) 
    286  
    287    CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),un_id) 
    288    CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),vn_id) 
    289    CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),ua_id) 
    290    CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),va_id) 
    291  
    292    CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),unb_id) 
    293    CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/jpi,jpj/),vnb_id) 
    294    CALL agrif_declare_variable((/2,2/),(/3,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),sshn_id) 
    295    CALL agrif_declare_variable((/2,2/),(/3,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),gcb_id) 
    296    CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),ub2b_id) 
    297    CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/jpi,jpj/),vb2b_id) 
     342   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) 
     343   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) 
     344 
     345   CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),un_interp_id) 
     346   CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vn_interp_id) 
     347   CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),un_update_id) 
     348   CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vn_update_id) 
     349   CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),un_sponge_id) 
     350   CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vn_sponge_id) 
     351 
     352   CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),e3t_id) 
     353   CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),umsk_id) 
     354   CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vmsk_id) 
     355 
     356   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) 
     357 
     358   CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),unb_id) 
     359   CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vnb_id) 
     360   CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ub2b_interp_id) 
     361   CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vb2b_interp_id) 
     362   CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ub2b_update_id) 
     363   CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vb2b_update_id) 
     364 
     365   CALL agrif_declare_variable((/2,2/),(/3,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),sshn_id) 
     366 
     367# if defined key_zdftke 
     368   CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/), en_id) 
     369   CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avt_id) 
     370   CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avm_id) 
     371# endif 
    298372 
    299373   ! 2. Type of interpolation 
    300374   !------------------------- 
    301375   CALL Agrif_Set_bcinterp(tsn_id,interp=AGRIF_linear) 
    302    CALL Agrif_Set_bcinterp(tsa_id,interp=AGRIF_linear) 
    303  
    304    Call Agrif_Set_bcinterp(un_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    305    Call Agrif_Set_bcinterp(vn_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
    306  
    307    Call Agrif_Set_bcinterp(ua_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    308    Call Agrif_Set_bcinterp(va_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     376 
     377   CALL Agrif_Set_bcinterp(un_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
     378   CALL Agrif_Set_bcinterp(vn_interp_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     379 
     380   CALL Agrif_Set_bcinterp(tsn_sponge_id,interp=AGRIF_linear) 
    309381 
    310382   CALL Agrif_Set_bcinterp(sshn_id,interp=AGRIF_linear) 
    311    Call Agrif_Set_bcinterp(unb_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    312    Call Agrif_Set_bcinterp(vnb_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
    313    Call Agrif_Set_bcinterp(ub2b_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    314    Call Agrif_Set_bcinterp(vb2b_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     383   CALL Agrif_Set_bcinterp(unb_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
     384   CALL Agrif_Set_bcinterp(vnb_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     385   CALL Agrif_Set_bcinterp(ub2b_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
     386   CALL Agrif_Set_bcinterp(vb2b_interp_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     387 
     388 
     389   CALL Agrif_Set_bcinterp(un_sponge_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
     390   CALL Agrif_Set_bcinterp(vn_sponge_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     391 
     392   CALL Agrif_Set_bcinterp(e3t_id,interp=AGRIF_constant) 
     393   CALL Agrif_Set_bcinterp(umsk_id,interp=AGRIF_constant) 
     394   CALL Agrif_Set_bcinterp(vmsk_id,interp=AGRIF_constant) 
     395 
     396# if defined key_zdftke 
     397   CALL Agrif_Set_bcinterp(avm_id ,interp=AGRIF_linear) 
     398# endif 
     399 
    315400 
    316401   ! 3. Location of interpolation 
    317402   !----------------------------- 
    318    Call Agrif_Set_bc(un_id,(/0,1/)) 
    319    Call Agrif_Set_bc(vn_id,(/0,1/)) 
    320  
    321    Call Agrif_Set_bc(sshn_id,(/0,1/)) 
    322    Call Agrif_Set_bc(unb_id,(/0,1/)) 
    323    Call Agrif_Set_bc(vnb_id,(/0,1/)) 
    324    Call Agrif_Set_bc(ub2b_id,(/0,1/)) 
    325    Call Agrif_Set_bc(vb2b_id,(/0,1/)) 
    326  
    327    Call Agrif_Set_bc(tsn_id,(/0,1/)) 
    328    Call Agrif_Set_bc(tsa_id,(/-3*Agrif_irhox(),0/)) 
    329  
    330    Call Agrif_Set_bc(ua_id,(/-2*Agrif_irhox(),0/)) 
    331    Call Agrif_Set_bc(va_id,(/-2*Agrif_irhox(),0/)) 
     403   CALL Agrif_Set_bc(tsn_id,(/0,1/)) 
     404   CALL Agrif_Set_bc(un_interp_id,(/0,1/)) 
     405   CALL Agrif_Set_bc(vn_interp_id,(/0,1/)) 
     406 
     407!   CALL Agrif_Set_bc(tsn_sponge_id,(/-3*Agrif_irhox(),0/)) 
     408!   CALL Agrif_Set_bc(un_sponge_id,(/-2*Agrif_irhox()-1,0/)) 
     409!   CALL Agrif_Set_bc(vn_sponge_id,(/-2*Agrif_irhox()-1,0/)) 
     410   CALL Agrif_Set_bc(tsn_sponge_id,(/-nn_sponge_len*Agrif_irhox()-1,0/)) 
     411   CALL Agrif_Set_bc(un_sponge_id ,(/-nn_sponge_len*Agrif_irhox()-1,0/)) 
     412   CALL Agrif_Set_bc(vn_sponge_id ,(/-nn_sponge_len*Agrif_irhox()-1,0/)) 
     413 
     414   CALL Agrif_Set_bc(sshn_id,(/0,0/)) 
     415   CALL Agrif_Set_bc(unb_id ,(/0,0/)) 
     416   CALL Agrif_Set_bc(vnb_id ,(/0,0/)) 
     417   CALL Agrif_Set_bc(ub2b_interp_id,(/0,0/)) 
     418   CALL Agrif_Set_bc(vb2b_interp_id,(/0,0/)) 
     419 
     420   CALL Agrif_Set_bc(e3t_id,(/-2*Agrif_irhox()-1,0/))   ! if west and rhox=3: column 2 to 9 
     421   CALL Agrif_Set_bc(umsk_id,(/0,0/)) 
     422   CALL Agrif_Set_bc(vmsk_id,(/0,0/)) 
     423 
     424# if defined key_zdftke 
     425   CALL Agrif_Set_bc(avm_id ,(/0,1/)) 
     426# endif 
    332427 
    333428   ! 5. Update type 
    334429   !---------------  
    335    Call Agrif_Set_Updatetype(tsn_id, update = AGRIF_Update_Average) 
    336    Call Agrif_Set_Updatetype(tsb_id, update = AGRIF_Update_Average) 
    337  
    338    Call Agrif_Set_Updatetype(sshn_id, update = AGRIF_Update_Average) 
    339    Call Agrif_Set_Updatetype(gcb_id,update = AGRIF_Update_Average) 
    340  
    341    Call Agrif_Set_Updatetype(un_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 
    342    Call Agrif_Set_Updatetype(vn_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 
    343  
    344    Call Agrif_Set_Updatetype(ub2b_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 
    345    Call Agrif_Set_Updatetype(vb2b_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 
    346  
     430   CALL Agrif_Set_Updatetype(tsn_id, update = AGRIF_Update_Average) 
     431 
     432   CALL Agrif_Set_Updatetype(scales_t_id, update = AGRIF_Update_Average) 
     433 
     434   CALL Agrif_Set_Updatetype(un_update_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 
     435   CALL Agrif_Set_Updatetype(vn_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 
     436 
     437   CALL Agrif_Set_Updatetype(sshn_id, update = AGRIF_Update_Average) 
     438 
     439   CALL Agrif_Set_Updatetype(ub2b_update_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 
     440   CALL Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 
     441 
     442# if defined key_zdftke 
     443   CALL Agrif_Set_Updatetype( en_id, update = AGRIF_Update_Average) 
     444   CALL Agrif_Set_Updatetype(avt_id, update = AGRIF_Update_Average) 
     445   CALL Agrif_Set_Updatetype(avm_id, update = AGRIF_Update_Average) 
     446# endif 
     447 
     448! High order updates 
     449!   CALL Agrif_Set_Updatetype(tsn_id, update = Agrif_Update_Full_Weighting) 
     450!   CALL Agrif_Set_Updatetype(un_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Full_Weighting) 
     451!   CALL Agrif_Set_Updatetype(vn_update_id,update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average) 
     452! 
     453!   CALL Agrif_Set_Updatetype(ub2b_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Full_Weighting) 
     454!   CALL Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average) 
     455!   CALL Agrif_Set_Updatetype(sshn_id, update = Agrif_Update_Full_Weighting) 
     456  
     457   ! 
    347458END SUBROUTINE agrif_declare_var 
    348459# endif 
    … …  
    365476   IMPLICIT NONE 
    366477   ! 
    367    REAL(wp), DIMENSION(:,:)  , ALLOCATABLE :: zvel 
    368    REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zadv 
    369    !!---------------------------------------------------------------------- 
    370  
    371    ALLOCATE( zvel(jpi,jpj), zadv(jpi,jpj,7)) 
     478   !!---------------------------------------------------------------------- 
    372479 
    373480   ! 1. Declaration of the type of variable which have to be interpolated 
    … …  
    401508   CALL Agrif_Update_lim2(0) 
    402509   ! 
    403    DEALLOCATE( zvel, zadv ) 
    404    ! 
    405510END SUBROUTINE Agrif_InitValues_cont_lim2 
    406511 
    … …  
    431536   !------------------------- 
    432537   CALL Agrif_Set_bcinterp(adv_ice_id ,interp=AGRIF_linear) 
    433    Call Agrif_Set_bcinterp(u_ice_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    434    Call Agrif_Set_bcinterp(v_ice_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     538   CALL Agrif_Set_bcinterp(u_ice_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
     539   CALL Agrif_Set_bcinterp(v_ice_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
    435540 
    436541   ! 3. Location of interpolation 
    437542   !----------------------------- 
    438    Call Agrif_Set_bc(adv_ice_id ,(/0,1/)) 
    439    Call Agrif_Set_bc(u_ice_id,(/0,1/)) 
    440    Call Agrif_Set_bc(v_ice_id,(/0,1/)) 
     543   CALL Agrif_Set_bc(adv_ice_id ,(/0,1/)) 
     544   CALL Agrif_Set_bc(u_ice_id,(/0,1/)) 
     545   CALL Agrif_Set_bc(v_ice_id,(/0,1/)) 
    441546 
    442547   ! 5. Update type 
    443548   !--------------- 
    444    Call Agrif_Set_Updatetype(adv_ice_id , update = AGRIF_Update_Average) 
    445    Call Agrif_Set_Updatetype(u_ice_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 
    446    Call Agrif_Set_Updatetype(v_ice_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 
    447  
     549   CALL Agrif_Set_Updatetype(adv_ice_id , update = AGRIF_Update_Average) 
     550   CALL Agrif_Set_Updatetype(u_ice_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 
     551   CALL Agrif_Set_Updatetype(v_ice_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 
     552   !  
    448553END SUBROUTINE agrif_declare_var_lim2 
    449554#  endif 
    … …  
    462567   USE nemogcm 
    463568   USE par_trc 
     569   USE lib_mpp 
    464570   USE trc 
    465571   USE in_out_manager 
     572   USE agrif_opa_sponge 
    466573   USE agrif_top_update 
    467574   USE agrif_top_interp 
    … …  
    470577   IMPLICIT NONE 
    471578   ! 
    472    REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: tabtrtemp 
     579   CHARACTER(len=10) :: cl_check1, cl_check2, cl_check3 
    473580   LOGICAL :: check_namelist 
    474581   !!---------------------------------------------------------------------- 
    475  
    476    ALLOCATE( tabtrtemp(jpi,jpj,jpk,jptra) ) 
    477582 
    478583 
    … …  
    485590   Agrif_SpecialValue=0. 
    486591   Agrif_UseSpecialValue = .TRUE. 
    487    Call Agrif_Bc_variable(tabtrtemp,trn_id,calledweight=1.,procname=interptrn) 
    488    Call Agrif_Bc_variable(tabtrtemp,tra_id,calledweight=1.,procname=interptrn) 
     592   CALL Agrif_Bc_variable(trn_id,calledweight=1.,procname=interptrn) 
    489593   Agrif_UseSpecialValue = .FALSE. 
     594   CALL Agrif_Sponge 
     595   tabspongedone_trn = .FALSE. 
     596   CALL Agrif_Bc_variable(trn_sponge_id,calledweight=1.,procname=interptrn_sponge) 
     597   ! reset tsa to zero 
     598   tra(:,:,:,:) = 0. 
     599 
    490600 
    491601   ! 3. Some controls 
    492602   !----------------- 
    493    check_namelist = .true. 
     603   check_namelist = .TRUE. 
    494604 
    495605   IF( check_namelist ) THEN 
    496 #  if defined offline      
     606# if defined key_offline 
    497607      ! Check time steps 
    498       IF( nint(Agrif_Rhot()) * nint(rdt) .ne. Agrif_Parent(rdt) ) THEN 
    499          WRITE(*,*) 'incompatible time step between grids' 
    500          WRITE(*,*) 'parent grid value : ',Agrif_Parent(rdt) 
    501          WRITE(*,*) 'child  grid value : ',nint(rdt) 
    502          WRITE(*,*) 'value on parent grid should be : ',rdt*Agrif_Rhot() 
    503          STOP 
     608      IF( NINT(Agrif_Rhot()) * NINT(rdt) .NE. Agrif_Parent(rdt) ) THEN 
     609         WRITE(cl_check1,*)  Agrif_Parent(rdt) 
     610         WRITE(cl_check2,*)  rdt 
     611         WRITE(cl_check3,*)  rdt*Agrif_Rhot() 
     612         CALL ctl_warn( 'incompatible time step between grids',   & 
     613               &               'parent grid value : '//cl_check1    ,   &  
     614               &               'child  grid value : '//cl_check2    ,   &  
     615               &               'value on child grid will be changed to  & 
     616               &               :'//cl_check3  ) 
     617         rdt=rdt*Agrif_Rhot() 
    504618      ENDIF 
    505619 
    506620      ! Check run length 
    507621      IF( Agrif_IRhot() * (Agrif_Parent(nitend)- & 
    508            Agrif_Parent(nit000)+1) .ne. (nitend-nit000+1) ) THEN 
    509          WRITE(*,*) 'incompatible run length between grids' 
    510          WRITE(*,*) 'parent grid value : ',(Agrif_Parent(nitend)- & 
    511               Agrif_Parent(nit000)+1),' time step' 
    512          WRITE(*,*) 'child  grid value : ', & 
    513               (nitend-nit000+1),' time step' 
    514          WRITE(*,*) 'value on child grid should be : ', & 
    515               Agrif_IRhot() * (Agrif_Parent(nitend)- & 
    516               Agrif_Parent(nit000)+1) 
    517          STOP 
     622            Agrif_Parent(nit000)+1) .NE. (nitend-nit000+1) ) THEN 
     623         WRITE(cl_check1,*)  (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 
     624         WRITE(cl_check2,*)   Agrif_Parent(nitend)   *Agrif_IRhot() 
     625         CALL ctl_warn( 'incompatible run length between grids'               ,   & 
     626               &              ' nit000 on fine grid will be change to : '//cl_check1,   & 
     627               &              ' nitend on fine grid will be change to : '//cl_check2    ) 
     628         nit000 = (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 
     629         nitend =  Agrif_Parent(nitend)   *Agrif_IRhot() 
    518630      ENDIF 
    519631 
    … …  
    521633      IF( ln_zps ) THEN 
    522634         ! check parameters for partial steps  
    523          IF( Agrif_Parent(e3zps_min) .ne. e3zps_min ) THEN 
     635         IF( Agrif_Parent(e3zps_min) .NE. e3zps_min ) THEN 
    524636            WRITE(*,*) 'incompatible e3zps_min between grids' 
    525637            WRITE(*,*) 'parent grid :',Agrif_Parent(e3zps_min) 
    … …  
    528640            STOP 
    529641         ENDIF 
    530          IF( Agrif_Parent(e3zps_rat) .ne. e3zps_rat ) THEN 
     642         IF( Agrif_Parent(e3zps_rat) .NE. e3zps_rat ) THEN 
    531643            WRITE(*,*) 'incompatible e3zps_rat between grids' 
    532644            WRITE(*,*) 'parent grid :',Agrif_Parent(e3zps_rat) 
    … …  
    538650#  endif          
    539651      ! Check passive tracer cell 
    540       IF( nn_dttrc .ne. 1 ) THEN 
     652      IF( nn_dttrc .NE. 1 ) THEN 
    541653         WRITE(*,*) 'nn_dttrc should be equal to 1' 
    542654      ENDIF 
    543655   ENDIF 
    544656 
    545 !ch   CALL Agrif_Update_trc(0) 
     657   CALL Agrif_Update_trc(0) 
     658   ! 
     659   Agrif_UseSpecialValueInUpdate = .FALSE. 
    546660   nbcline_trc = 0 
    547    ! 
    548    DEALLOCATE(tabtrtemp) 
    549661   ! 
    550662END SUBROUTINE Agrif_InitValues_cont_top 
    … …  
    558670   !!---------------------------------------------------------------------- 
    559671   USE agrif_util 
     672   USE agrif_oce 
    560673   USE dom_oce 
    561674   USE trc 
    … …  
    565678   ! 1. Declaration of the type of variable which have to be interpolated 
    566679   !--------------------------------------------------------------------- 
    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/),trn_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/),trb_id) 
    569    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) 
     680   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) 
     681   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) 
    570682 
    571683   ! 2. Type of interpolation 
    572684   !------------------------- 
    573685   CALL Agrif_Set_bcinterp(trn_id,interp=AGRIF_linear) 
    574    CALL Agrif_Set_bcinterp(tra_id,interp=AGRIF_linear) 
     686   CALL Agrif_Set_bcinterp(trn_sponge_id,interp=AGRIF_linear) 
    575687 
    576688   ! 3. Location of interpolation 
    577689   !----------------------------- 
    578    Call Agrif_Set_bc(trn_id,(/0,1/)) 
    579    Call Agrif_Set_bc(tra_id,(/-3*Agrif_irhox(),0/)) 
     690   CALL Agrif_Set_bc(trn_id,(/0,1/)) 
     691!   CALL Agrif_Set_bc(trn_sponge_id,(/-3*Agrif_irhox(),0/)) 
     692   CALL Agrif_Set_bc(trn_sponge_id,(/-nn_sponge_len*Agrif_irhox()-1,0/)) 
    580693 
    581694   ! 5. Update type 
    582695   !---------------  
    583    Call Agrif_Set_Updatetype(trn_id, update = AGRIF_Update_Average) 
    584    Call Agrif_Set_Updatetype(trb_id, update = AGRIF_Update_Average) 
    585  
    586  
     696   CALL Agrif_Set_Updatetype(trn_id, update = AGRIF_Update_Average) 
     697 
     698!   Higher order update 
     699!   CALL Agrif_Set_Updatetype(tsn_id, update = Agrif_Update_Full_Weighting) 
     700 
     701   ! 
    587702END SUBROUTINE agrif_declare_var_top 
    588703# endif 
    … …  
    592707   !!   *** ROUTINE Agrif_detect *** 
    593708   !!---------------------------------------------------------------------- 
    594    USE Agrif_Types 
    595709   ! 
    596710   INTEGER, DIMENSION(2) :: ksizex 
    … …  
    614728   ! 
    615729   INTEGER  ::   ios                 ! Local integer output status for namelist read 
    616    NAMELIST/namagrif/ nn_cln_update, rn_sponge_tra, rn_sponge_dyn, ln_spc_dyn 
    617    !!---------------------------------------------------------------------- 
    618    ! 
    619       REWIND( numnam_ref )              ! Namelist namagrif in reference namelist : AGRIF zoom 
    620       READ  ( numnam_ref, namagrif, IOSTAT = ios, ERR = 901) 
    621 901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namagrif in reference namelist', lwp ) 
    622  
    623       REWIND( numnam_cfg )              ! Namelist namagrif in configuration namelist : AGRIF zoom 
    624       READ  ( numnam_cfg, namagrif, IOSTAT = ios, ERR = 902 ) 
    625 902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namagrif in configuration namelist', lwp ) 
    626       IF(lwm) WRITE ( numond, namagrif ) 
     730   INTEGER  ::   iminspon 
     731   NAMELIST/namagrif/ nn_cln_update, rn_sponge_tra, rn_sponge_dyn, ln_spc_dyn, ln_chk_bathy 
     732   !!-------------------------------------------------------------------------------------- 
     733   ! 
     734   REWIND( numnam_ref )              ! Namelist namagrif in reference namelist : AGRIF zoom 
     735   READ  ( numnam_ref, namagrif, IOSTAT = ios, ERR = 901) 
     736901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namagrif in reference namelist', lwp ) 
     737 
     738   REWIND( numnam_cfg )              ! Namelist namagrif in configuration namelist : AGRIF zoom 
     739   READ  ( numnam_cfg, namagrif, IOSTAT = ios, ERR = 902 ) 
     740902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namagrif in configuration namelist', lwp ) 
     741   IF(lwm) WRITE ( numond, namagrif ) 
    627742   ! 
    628743   IF(lwp) THEN                    ! control print 
    … …  
    635750      WRITE(numout,*) '      sponge coefficient for dynamics   rn_sponge_tra = ', rn_sponge_dyn, ' s' 
    636751      WRITE(numout,*) '      use special values for dynamics   ln_spc_dyn    = ', ln_spc_dyn 
     752      WRITE(numout,*) '      check bathymetry                  ln_chk_bathy  = ', ln_chk_bathy 
    637753      WRITE(numout,*)  
    638754   ENDIF 
    … …  
    643759   visc_dyn      = rn_sponge_dyn 
    644760   ! 
    645    IF( agrif_oce_alloc()  > 0 )   CALL ctl_warn('agrif sol_oce_alloc: allocation of arrays failed') 
     761   ! Check sponge length: 
     762   iminspon = MIN(FLOOR(REAL(jpiglo-4)/REAL(2*Agrif_irhox())), FLOOR(REAL(jpjglo-4)/REAL(2*Agrif_irhox())) ) 
     763   IF (lk_mpp) iminspon = MIN(iminspon,FLOOR(REAL(jpi-2)/REAL(Agrif_irhox())), FLOOR(REAL(jpj-2)/REAL(Agrif_irhox())) ) 
     764   IF (nn_sponge_len > iminspon)  CALL ctl_stop('agrif sponge length is too large') 
     765   ! 
     766   IF( agrif_oce_alloc()  > 0 )   CALL ctl_warn('agrif agrif_oce_alloc: allocation of arrays failed') 
    646767# if defined key_lim2 
    647768   IF( agrif_ice_alloc()  > 0 )   CALL ctl_stop('agrif agrif_ice_alloc: allocation of arrays failed') 
    … …  
    664785   SELECT CASE( i ) 
    665786   CASE(1)   ;   indglob = indloc + nimppt(nprocloc+1) - 1 
    666    CASE(2)   ;   indglob = indloc + njmppt(nprocloc+1) - 1  
    667    CASE(3)   ;   indglob = indloc 
    668    CASE(4)   ;   indglob = indloc 
     787   CASE(2)   ;   indglob = indloc + njmppt(nprocloc+1) - 1 
     788   CASE DEFAULT 
     789      indglob = indloc 
    669790   END SELECT 
    670791   ! 
    671792END SUBROUTINE Agrif_InvLoc 
     793 
     794SUBROUTINE Agrif_get_proc_info( imin, imax, jmin, jmax ) 
     795   !!---------------------------------------------------------------------- 
     796   !!                 *** ROUTINE Agrif_get_proc_info *** 
     797   !!---------------------------------------------------------------------- 
     798   USE par_oce 
     799   IMPLICIT NONE 
     800   ! 
     801   INTEGER, INTENT(out) :: imin, imax 
     802   INTEGER, INTENT(out) :: jmin, jmax 
     803   !!---------------------------------------------------------------------- 
     804   ! 
     805   imin = nimppt(Agrif_Procrank+1)  ! ????? 
     806   jmin = njmppt(Agrif_Procrank+1)  ! ????? 
     807   imax = imin + jpi - 1 
     808   jmax = jmin + jpj - 1 
     809   !  
     810END SUBROUTINE Agrif_get_proc_info 
     811 
     812SUBROUTINE Agrif_estimate_parallel_cost(imin, imax,jmin, jmax, nbprocs, grid_cost) 
     813   !!---------------------------------------------------------------------- 
     814   !!                 *** ROUTINE Agrif_estimate_parallel_cost *** 
     815   !!---------------------------------------------------------------------- 
     816   USE par_oce 
     817   IMPLICIT NONE 
     818   ! 
     819   INTEGER,  INTENT(in)  :: imin, imax 
     820   INTEGER,  INTENT(in)  :: jmin, jmax 
     821   INTEGER,  INTENT(in)  :: nbprocs 
     822   REAL(wp), INTENT(out) :: grid_cost 
     823   !!---------------------------------------------------------------------- 
     824   ! 
     825   grid_cost = REAL(imax-imin+1,wp)*REAL(jmax-jmin+1,wp) / REAL(nbprocs,wp) 
     826   ! 
     827END SUBROUTINE Agrif_estimate_parallel_cost 
    672828 
    673829# endif 
Note: See TracChangeset for help on using the changeset viewer.