Changeset 4789


Ignore:
Timestamp:
2014-09-25T18:26:34+02:00 (6 years ago)
Author:
rblod
Message:

dev_r4765_CNRS_agrif: First update of AGRIF for dynamic only (_flt and _ts), see ticket #1380 and associated wiki page

Location:
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM
Files:
13 edited

Legend:

Unmodified
Added
Removed
  • branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/CONFIG/SHARED/1_namelist_ref

    r4785 r4789  
    523523   rn_sponge_tra = 2880.   !  coefficient for tracer   sponge layer [m2/s] 
    524524   rn_sponge_dyn = 2880.   !  coefficient for dynamics sponge layer [m2/s] 
     525   ln_chk_bathy  = .FALSE. ! 
     526   ln_agrif_tle  = .FALSE. 
    525527/ 
    526528!----------------------------------------------------------------------- 
  • branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/NST_SRC/agrif2model.F90

    r4785 r4789  
    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_Grids 
    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_Grids 
    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 
     37   IF ( ASSOCIATED(Agrif_Curgrid) ) THEN 
    3838#include "GetNumberofcells.h" 
    39     endif 
     39   ENDIF 
    4040 
    41    END SUBROUTINE Agrif_Get_numberofcells 
     41END SUBROUTINE Agrif_Get_numberofcells 
    4242 
    43    SUBROUTINE Agrif_Allocationcalls(Agrif_Gr) 
    44       !!--------------------------------------------- 
    45       !!   *** ROUTINE Agrif_Allocationscalls *** 
    46       !!---------------------------------------------  
    47       USE Agrif_Grids  
     43SUBROUTINE Agrif_Allocationcalls(Agrif_Gr) 
     44   !!--------------------------------------------- 
     45   !!   *** ROUTINE Agrif_Allocationscalls *** 
     46   !!---------------------------------------------  
     47   USE Agrif_Grids  
    4848#include "include_use_Alloc_agrif.h" 
    49       IMPLICIT NONE 
     49   IMPLICIT NONE 
    5050 
    51       Type(Agrif_Grid), Pointer :: Agrif_Gr 
     51   TYPE(Agrif_Grid), POINTER :: Agrif_Gr 
    5252 
    5353#include "allocations_calls_agrif.h" 
    5454 
    55    END SUBROUTINE Agrif_Allocationcalls 
     55END SUBROUTINE Agrif_Allocationcalls 
    5656 
    57    SUBROUTINE Agrif_probdim_modtype_def() 
    58       !!--------------------------------------------- 
    59       !!   *** ROUTINE Agrif_probdim_modtype_def *** 
    60       !!---------------------------------------------  
    61       USE Agrif_Types 
    62       IMPLICIT NONE 
     57SUBROUTINE Agrif_probdim_modtype_def() 
     58   !!--------------------------------------------- 
     59   !!   *** ROUTINE Agrif_probdim_modtype_def *** 
     60   !!---------------------------------------------  
     61   USE Agrif_Types 
     62   IMPLICIT NONE 
    6363 
    6464#include "modtype_agrif.h" 
     
    6666#include "keys_agrif.h" 
    6767 
    68       Return 
     68   RETURN 
    6969 
    70    END SUBROUTINE Agrif_probdim_modtype_def 
     70END SUBROUTINE Agrif_probdim_modtype_def 
    7171 
    72    SUBROUTINE Agrif_clustering_def() 
    73       !!--------------------------------------------- 
    74       !!   *** ROUTINE Agrif_clustering_def *** 
    75       !!---------------------------------------------  
    76       IMPLICIT NONE 
     72SUBROUTINE Agrif_clustering_def() 
     73   !!--------------------------------------------- 
     74   !!   *** ROUTINE Agrif_clustering_def *** 
     75   !!---------------------------------------------  
     76   IMPLICIT NONE 
    7777 
    78       Return 
     78   RETURN 
    7979 
    80    END SUBROUTINE Agrif_clustering_def 
     80END SUBROUTINE Agrif_clustering_def 
    8181 
    8282#else 
    83    SUBROUTINE Agrif2Model 
    84       !!--------------------------------------------- 
    85       !!   *** ROUTINE Agrif2Model *** 
    86       !!---------------------------------------------  
    87       WRITE(*,*) 'Impossible to bet here' 
    88    END SUBROUTINE Agrif2model 
     83SUBROUTINE Agrif2Model 
     84   !!--------------------------------------------- 
     85   !!   *** ROUTINE Agrif2Model *** 
     86   !!---------------------------------------------  
     87   WRITE(*,*) 'Impossible to bet here' 
     88END SUBROUTINE Agrif2model 
    8989#endif 
  • branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/NST_SRC/agrif_oce.F90

    r4785 r4789  
    1212   USE par_oce      ! ocean parameters 
    1313   USE dom_oce      ! domain parameters 
    14     
     14 
    1515   IMPLICIT NONE 
    1616   PRIVATE  
     
    2323   REAL(wp), PUBLIC ::   rn_sponge_tra = 2800.     !: sponge coeff. for tracers 
    2424   REAL(wp), PUBLIC ::   rn_sponge_dyn = 2800.     !: sponge coeff. for dynamics 
     25   LOGICAL , PUBLIC ::   ln_chk_bathy  = .FALSE.   !: check of parent bathymetry  
     26   LOGICAL , PUBLIC ::   ln_agrif_tke  = .FALSE.   !: interp/extrap for TKE 
    2527 
    2628   !                                              !!! OLD namelist names 
     
    3436   LOGICAL , PUBLIC :: lk_agrif_fstep = .TRUE. !: if true: first step 
    3537 
    36    LOGICAL , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tabspongedone 
     38   LOGICAL , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tabspongedone_tsn 
     39# if defined key_top 
     40   LOGICAL , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tabspongedone_trn 
     41# endif 
    3742   LOGICAL , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tabspongedone_u 
    3843   LOGICAL , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tabspongedone_v 
    3944   REAL(wp), PUBLIC, ALLOCATABLE, SAVE,  DIMENSION(:,:) ::   spe1ur , spe2vr , spbtr2   !: ??? 
    4045   REAL(wp), PUBLIC, ALLOCATABLE, SAVE,  DIMENSION(:,:) ::   spe1ur2, spe2vr2, spbtr3   !: ??? 
    41 # if defined key_dynspg_ts 
    4246   ! Barotropic arrays used to store open boundary data during 
    4347   ! time-splitting loop: 
     
    4650   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) ::  ubdy_n, vbdy_n, hbdy_n 
    4751   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) ::  ubdy_s, vbdy_s, hbdy_s 
    48 # endif   
    49   
     52 
    5053   INTEGER :: tsn_id                                                  ! AGRIF profile for tracers interpolation and update 
    5154   INTEGER :: un_interp_id, vn_interp_id                              ! AGRIF profiles for interpolations 
    5255   INTEGER :: un_update_id, vn_update_id                              ! AGRIF profiles for udpates 
    5356   INTEGER :: tsn_sponge_id, un_sponge_id, vn_sponge_id               ! AGRIF profiles for sponge layers 
    54    INTEGER :: trn_id 
     57# if defined key_top 
     58   INTEGER :: trn_id, trn_sponge_id 
     59# endif   
    5560   INTEGER :: unb_id, vnb_id, ub2b_interp_id, vb2b_interp_id 
    5661   INTEGER :: ub2b_update_id, vb2b_update_id 
    5762   INTEGER :: e3t_id, e1u_id, e2v_id, sshn_id 
    5863   INTEGER :: scales_t_id 
     64   INTEGER :: avt_id, avm_id, avmu_id, avmv_id 
    5965 
    6066   !!---------------------------------------------------------------------- 
     
    7379      ierr(:) = 0 
    7480      ! 
    75       ALLOCATE( spe1ur         (jpi,jpj), spe2vr         (jpi,jpj),   & 
    76          &      spbtr2         (jpi,jpj), spe1ur2        (jpi,jpj),   & 
    77          &      spe2vr2        (jpi,jpj), spbtr3         (jpi,jpj),   & 
    78          &      tabspongedone  (jpi,jpj), tabspongedone_u(jpi,jpj),   & 
    79          &      tabspongedone_v(jpi,jpj), STAT = ierr(1) ) 
     81      ALLOCATE( spe1ur (jpi,jpj), spe2vr (jpi,jpj),   & 
     82         &      spbtr2 (jpi,jpj), spe1ur2(jpi,jpj),   & 
     83         &      spe2vr2(jpi,jpj), spbtr3(jpi,jpj),    & 
     84         &      tabspongedone_tsn(jpi,jpj),           & 
     85# if defined key_top          
     86         &      tabspongedone_trn(jpi,jpj),           & 
     87# endif          
     88         &      tabspongedone_u  (jpi,jpj),           & 
     89         &      tabspongedone_v  (jpi,jpj), STAT = ierr(1) ) 
    8090 
    81 # if defined key_dynspg_ts 
    8291      ALLOCATE( ubdy_w(jpj), vbdy_w(jpj), hbdy_w(jpj),   & 
    8392         &      ubdy_e(jpj), vbdy_e(jpj), hbdy_e(jpj),   &  
    8493         &      ubdy_n(jpi), vbdy_n(jpi), hbdy_n(jpi),   &  
    8594         &      ubdy_s(jpi), vbdy_s(jpi), hbdy_s(jpi), STAT = ierr(2) ) 
    86 # endif 
     95 
    8796      agrif_oce_alloc = MAXVAL(ierr) 
    8897      ! 
  • branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90

    r4785 r4789  
    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 
    3537   INTEGER :: bdy_tinterp = 0 
    36         
     38 
    3739   PUBLIC   Agrif_tra, Agrif_dyn, Agrif_ssh, Agrif_dyn_ts, Agrif_ssh_ts, Agrif_dta_ts 
    3840   PUBLIC   interpun, interpvn, interpun2d, interpvn2d  
    3941   PUBLIC   interptsn,  interpsshn 
    4042   PUBLIC   interpunb, interpvnb, interpub2b, interpvb2b 
     43   PUBLIC   interpe3t 
     44# if defined key_zdftke 
     45   PUBLIC   Agrif_tke, interpavt, interpavm, interpavmu, interpavmv 
     46# endif 
    4147 
    4248#  include "domzgr_substitute.h90"   
    4349#  include "vectopt_loop_substitute.h90" 
    4450   !!---------------------------------------------------------------------- 
    45    !! NEMO/NST 3.3 , NEMO Consortium (2010) 
     51   !! NEMO/NST 3.6 , NEMO Consortium (2010) 
    4652   !! $Id$ 
    4753   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    4854   !!---------------------------------------------------------------------- 
    4955 
    50    CONTAINS 
    51     
     56CONTAINS 
     57 
    5258   SUBROUTINE Agrif_tra 
    5359      !!---------------------------------------------------------------------- 
     
    199205         END DO 
    200206         spgu(nlci-2,:)=0. 
    201          do jk=1,jpkm1 
    202             do jj=1,jpj 
     207         DO jk=1,jpkm1 
     208            DO jj=1,jpj 
    203209               spgu(nlci-2,jj)=spgu(nlci-2,jj)+fse3u(nlci-2,jj,jk)*ua(nlci-2,jj,jk) 
    204             enddo 
    205          enddo 
     210            ENDDO 
     211         ENDDO 
    206212         DO jj=1,jpj 
    207213            IF (umask(nlci-2,jj,1).NE.0.) THEN 
     
    429435         DO jj=1,jpj 
    430436            va_e(2,jj) = vbdy_w(jj) * hvr_e(2,jj) 
    431 ! Specified fluxes: 
     437            ! Specified fluxes: 
    432438            ua_e(2,jj) = ubdy_w(jj) * hur_e(2,jj) 
    433 ! Characteristics method: 
    434 !alt            ua_e(2,jj) = 0.5_wp * ( ubdy_w(jj) * hur_e(2,jj) + ua_e(3,jj) & 
    435 !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)) ) 
    436442         END DO 
    437443      ENDIF 
     
    440446         DO jj=1,jpj 
    441447            va_e(nlci-1,jj) = vbdy_e(jj) * hvr_e(nlci-1,jj) 
    442 ! Specified fluxes: 
     448            ! Specified fluxes: 
    443449            ua_e(nlci-2,jj) = ubdy_e(jj) * hur_e(nlci-2,jj) 
    444 ! Characteristics method: 
    445 !alt            ua_e(nlci-2,jj) = 0.5_wp * ( ubdy_e(jj) * hur_e(nlci-2,jj) + ua_e(nlci-3,jj) & 
    446 !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)) ) 
    447453         END DO 
    448454      ENDIF 
     
    451457         DO ji=1,jpi 
    452458            ua_e(ji,2) = ubdy_s(ji) * hur_e(ji,2) 
    453 ! Specified fluxes: 
     459            ! Specified fluxes: 
    454460            va_e(ji,2) = vbdy_s(ji) * hvr_e(ji,2) 
    455 ! Characteristics method: 
    456 !alt            va_e(ji,2) = 0.5_wp * ( vbdy_s(ji) * hvr_e(ji,2) + va_e(ji,3) & 
    457 !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)) ) 
    458464         END DO 
    459465      ENDIF 
     
    462468         DO ji=1,jpi 
    463469            ua_e(ji,nlcj-1) = ubdy_n(ji) * hur_e(ji,nlcj-1) 
    464 ! Specified fluxes: 
     470            ! Specified fluxes: 
    465471            va_e(ji,nlcj-2) = vbdy_n(ji) * hvr_e(ji,nlcj-2) 
    466 ! Characteristics method: 
    467 !alt            va_e(ji,nlcj-2) = 0.5_wp * ( vbdy_n(ji) * hvr_e(ji,nlcj-2)  + va_e(ji,nlcj-3) & 
    468 !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)) ) 
    469475         END DO 
    470476      ENDIF 
     
    487493 
    488494      ll_int_cons = ln_bt_fw ! Assume conservative temporal integration in 
    489                              ! the forward case only 
     495      ! the forward case only 
    490496 
    491497      zrhot = Agrif_rhot() 
     
    598604   END SUBROUTINE Agrif_ssh_ts 
    599605 
     606# if defined key_zdftke 
     607   SUBROUTINE Agrif_tke 
     608      !!---------------------------------------------------------------------- 
     609      !!                  ***  ROUTINE Agrif_tke  *** 
     610      !!----------------------------------------------------------------------   
     611      ! 
     612      IF( Agrif_Root() )   RETURN 
     613 
     614       
     615      Agrif_SpecialValue    = 0.e0 
     616      Agrif_UseSpecialValue = .TRUE. 
     617       
     618      CALL Agrif_Bc_variable(avt_id , procname=interpavt)        
     619      CALL Agrif_Bc_variable(avm_id , procname=interpavm)        
     620      CALL Agrif_Bc_variable(avmu_id, procname=interpavmu) 
     621      CALL Agrif_Bc_variable(avmv_id, procname=interpavmv) 
     622               
     623      Agrif_UseSpecialValue = .FALSE. 
     624      ! 
     625   END SUBROUTINE Agrif_tke 
     626# endif 
     627 
    600628   SUBROUTINE interptsn(ptab,i1,i2,j1,j2,k1,k2,n1,n2,before,nb,ndir) 
    601629      !!--------------------------------------------- 
     
    612640      REAL(wp) ::   zalpha4, zalpha5, zalpha6, zalpha7 
    613641      LOGICAL :: western_side, eastern_side,northern_side,southern_side 
    614         
     642 
    615643      IF (before) THEN          
    616644         ptab(i1:i2,j1:j2,k1:k2,n1:n2) = tsn(i1:i2,j1:j2,k1:k2,n1:n2) 
     
    656684                        IF( un(nlci-2,jj,jk) > 0.e0 ) THEN 
    657685                           tsa(nlci-1,jj,jk,jn)=( zalpha6*tsa(nlci-2,jj,jk,jn)+zalpha5*tsa(nlci,jj,jk,jn) &  
    658                                                 + zalpha7*tsa(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 
     686                                 + zalpha7*tsa(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 
    659687                        ENDIF 
    660688                     ENDIF 
     
    675703                        IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN 
    676704                           tsa(ji,nlcj-1,jk,jn)=( zalpha6*tsa(ji,nlcj-2,jk,jn)+zalpha5*tsa(ji,nlcj,jk,jn)  & 
    677                                                 + zalpha7*tsa(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 
     705                                 + zalpha7*tsa(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 
    678706                        ENDIF 
    679707                     ENDIF 
    680708                  END DO 
    681709               END DO 
    682             ENDDO  
     710            ENDDO 
    683711         ENDIF 
    684712         ! 
     
    723751         ! East south 
    724752         IF ((eastern_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 
    725            tsa(nlci-1,2,:,:) = ptab(nlci-1,2,:,:) 
     753            tsa(nlci-1,2,:,:) = ptab(nlci-1,2,:,:) 
    726754         ENDIF 
    727755         ! East north 
    728756         IF ((eastern_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 
    729            tsa(nlci-1,nlcj-1,:,:) = ptab(nlci-1,nlcj-1,:,:) 
    730          ENDIF          
     757            tsa(nlci-1,nlcj-1,:,:) = ptab(nlci-1,nlcj-1,:,:) 
     758         ENDIF 
    731759         ! West south 
    732760         IF ((western_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 
    733            tsa(2,2,:,:) = ptab(2,2,:,:) 
     761            tsa(2,2,:,:) = ptab(2,2,:,:) 
    734762         ENDIF 
    735763         ! West north 
    736764         IF ((western_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 
    737            tsa(2,nlcj-1,:,:) = ptab(2,nlcj-1,:,:) 
     765            tsa(2,nlcj-1,:,:) = ptab(2,nlcj-1,:,:) 
    738766         ENDIF 
    739767         ! 
     
    818846      ! 
    819847      ztref = 1. 
    820        
     848 
    821849      IF (before) THEN  
    822850         DO jj=j1,j2 
    823             DO ji=i1,min(i2,nlci-1) 
     851            DO ji=i1,MIN(i2,nlci-1) 
    824852               ptab(ji,jj) = e2u(ji,jj) * ((gcx(ji+1,jj) - gcx(ji,jj))/e1u(ji,jj))  
    825853            END DO 
     
    855883                  ptab(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk) 
    856884                  ptab(ji,jj,jk) = ptab(ji,jj,jk) * fse3v(ji,jj,jk) 
    857                END DO    
     885               END DO 
    858886            END DO 
    859887         END DO 
     
    866894            END DO 
    867895         END DO 
    868        ENDIF 
    869        !         
     896      ENDIF 
     897      !         
    870898   END SUBROUTINE interpvn 
    871     
     899 
    872900   SUBROUTINE interpvn2d(ptab,i1,i2,j1,j2,before) 
    873901      !!--------------------------------------------- 
     
    887915      IF (before) THEN  
    888916         !interpv entre 1 et k2 et interpv2d en jpkp1 
    889          DO jj=j1,min(j2,nlcj-1) 
     917         DO jj=j1,MIN(j2,nlcj-1) 
    890918            DO ji=i1,i2 
    891919               ptab(ji,jj) = e1v(ji,jj) * ((gcx(ji,jj+1) - gcx(ji,jj))/e2v(ji,jj)) * vmask(ji,jj,1) 
    892920            END DO 
    893921         END DO 
    894        ELSE            
    895           zrhox = Agrif_Rhox() 
    896           DO ji=i1,i2 
    897              laplacv(ji,j1:j2) = ztref * (ptab(ji,j1:j2)/(zrhox*e1v(ji,j1:j2))) 
    898            END DO 
    899          ENDIF 
    900          !       
     922      ELSE            
     923         zrhox = Agrif_Rhox() 
     924         DO ji=i1,i2 
     925            laplacv(ji,j1:j2) = ztref * (ptab(ji,j1:j2)/(zrhox*e1v(ji,j1:j2))) 
     926         END DO 
     927      ENDIF 
     928      !       
    901929   END SUBROUTINE interpvn2d 
    902930 
     
    934962         IF( bdy_tinterp == 1 ) THEN 
    935963            ztcoeff = zrhot * (  zt1**2._wp * (       zt1 - 1._wp)        & 
    936                         &      - zt0**2._wp * (       zt0 - 1._wp)        ) 
     964                  &      - zt0**2._wp * (       zt0 - 1._wp)        ) 
    937965         ELSEIF( bdy_tinterp == 2 ) THEN 
    938966            ztcoeff = zrhot * (  zt1        * (       zt1 - 1._wp)**2._wp & 
    939                         &      - zt0        * (       zt0 - 1._wp)**2._wp )  
    940                       
     967                  &      - zt0        * (       zt0 - 1._wp)**2._wp )  
     968 
    941969         ELSE 
    942970            ztcoeff = 1 
     
    945973         IF(western_side) THEN 
    946974            ubdy_w(j1:j2) = ubdy_w(j1:j2) + ztcoeff * ptab(i1,j1:j2)   
    947          ENDIF    
     975         ENDIF 
    948976         IF(eastern_side) THEN 
    949977            ubdy_e(j1:j2) = ubdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2)   
    950          ENDIF    
     978         ENDIF 
    951979         IF(southern_side) THEN 
    952980            ubdy_s(i1:i2) = ubdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j1)  
    953          ENDIF    
     981         ENDIF 
    954982         IF(northern_side) THEN 
    955983            ubdy_n(i1:i2) = ubdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1)  
     
    957985         !             
    958986         IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN 
    959            IF(western_side) THEN 
    960               ubdy_w(j1:j2) = ubdy_w(j1:j2) / (zrhoy*e2u(i1,j1:j2))   & 
    961               &                                  * umask(i1,j1:j2,1) 
    962            ENDIF    
    963            IF(eastern_side) THEN 
    964               ubdy_e(j1:j2) = ubdy_e(j1:j2) / (zrhoy*e2u(i1,j1:j2))   & 
    965               &                                  * umask(i1,j1:j2,1) 
    966            ENDIF 
    967            IF(southern_side) THEN 
    968               ubdy_s(i1:i2) = ubdy_s(i1:i2) / (zrhoy*e2u(i1:i2,j1))   & 
    969               &                                  * umask(i1:i2,j1,1) 
    970            ENDIF   
    971            IF(northern_side) THEN 
    972               ubdy_n(i1:i2) = ubdy_n(i1:i2) / (zrhoy*e2u(i1:i2,j1))   & 
    973               &                                  * umask(i1:i2,j1,1) 
    974            ENDIF  
    975         ENDIF     
    976       ENDIF    
     987            IF(western_side) THEN 
     988               ubdy_w(j1:j2) = ubdy_w(j1:j2) / (zrhoy*e2u(i1,j1:j2))   & 
     989                     &                                  * umask(i1,j1:j2,1) 
     990            ENDIF 
     991            IF(eastern_side) THEN 
     992               ubdy_e(j1:j2) = ubdy_e(j1:j2) / (zrhoy*e2u(i1,j1:j2))   & 
     993                     &                                  * umask(i1,j1:j2,1) 
     994            ENDIF 
     995            IF(southern_side) THEN 
     996               ubdy_s(i1:i2) = ubdy_s(i1:i2) / (zrhoy*e2u(i1:i2,j1))   & 
     997                     &                                  * umask(i1:i2,j1,1) 
     998            ENDIF 
     999            IF(northern_side) THEN 
     1000               ubdy_n(i1:i2) = ubdy_n(i1:i2) / (zrhoy*e2u(i1:i2,j1))   & 
     1001                     &                                  * umask(i1:i2,j1,1) 
     1002            ENDIF 
     1003         ENDIF 
     1004      ENDIF 
    9771005      !  
    9781006   END SUBROUTINE interpunb 
     
    10101038         IF( bdy_tinterp == 1 ) THEN 
    10111039            ztcoeff = zrhot * (  zt1**2._wp * (       zt1 - 1._wp)        & 
    1012                         &      - zt0**2._wp * (       zt0 - 1._wp)        ) 
     1040                  &      - zt0**2._wp * (       zt0 - 1._wp)        ) 
    10131041         ELSEIF( bdy_tinterp == 2 ) THEN 
    10141042            ztcoeff = zrhot * (  zt1        * (       zt1 - 1._wp)**2._wp & 
    1015                         &      - zt0        * (       zt0 - 1._wp)**2._wp )  
    1016                       
     1043                  &      - zt0        * (       zt0 - 1._wp)**2._wp )  
     1044 
    10171045         ELSE 
    10181046            ztcoeff = 1 
     
    10211049         IF(western_side) THEN 
    10221050            vbdy_w(j1:j2) = vbdy_w(j1:j2) + ztcoeff * ptab(i1,j1:j2)   
    1023          ENDIF    
     1051         ENDIF 
    10241052         IF(eastern_side) THEN 
    10251053            vbdy_e(j1:j2) = vbdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2)   
    1026          ENDIF    
     1054         ENDIF 
    10271055         IF(southern_side) THEN 
    10281056            vbdy_s(i1:i2) = vbdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j1) 
    1029          ENDIF    
     1057         ENDIF 
    10301058         IF(northern_side) THEN 
    10311059            vbdy_n(i1:i2) = vbdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1)  
     
    10331061         !             
    10341062         IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN 
    1035            IF(western_side) THEN 
    1036               vbdy_w(j1:j2) = vbdy_w(j1:j2) / (zrhox*e1v(i1,j1:j2))   & 
    1037               &                                  * vmask(i1,j1:j2,1) 
    1038            ENDIF    
    1039            IF(eastern_side) THEN 
    1040               vbdy_e(j1:j2) = vbdy_e(j1:j2) / (zrhox*e1v(i1,j1:j2))   & 
    1041               &                                  * vmask(i1,j1:j2,1) 
    1042            ENDIF 
    1043            IF(southern_side) THEN 
    1044               vbdy_s(i1:i2) = vbdy_s(i1:i2) / (zrhox*e1v(i1:i2,j1))   & 
    1045               &                                  * vmask(i1:i2,j1,1) 
    1046            ENDIF   
    1047            IF(northern_side) THEN 
    1048               vbdy_n(i1:i2) = vbdy_n(i1:i2) / (zrhox*e1v(i1:i2,j1))   & 
    1049               &                                  * vmask(i1:i2,j1,1) 
    1050            ENDIF  
    1051         ENDIF     
    1052      ENDIF    
    1053      ! 
     1063            IF(western_side) THEN 
     1064               vbdy_w(j1:j2) = vbdy_w(j1:j2) / (zrhox*e1v(i1,j1:j2))   & 
     1065                     &                                  * vmask(i1,j1:j2,1) 
     1066            ENDIF 
     1067            IF(eastern_side) THEN 
     1068               vbdy_e(j1:j2) = vbdy_e(j1:j2) / (zrhox*e1v(i1,j1:j2))   & 
     1069                     &                                  * vmask(i1,j1:j2,1) 
     1070            ENDIF 
     1071            IF(southern_side) THEN 
     1072               vbdy_s(i1:i2) = vbdy_s(i1:i2) / (zrhox*e1v(i1:i2,j1))   & 
     1073                     &                                  * vmask(i1:i2,j1,1) 
     1074            ENDIF 
     1075            IF(northern_side) THEN 
     1076               vbdy_n(i1:i2) = vbdy_n(i1:i2) / (zrhox*e1v(i1:i2,j1))   & 
     1077                     &                                  * vmask(i1:i2,j1,1) 
     1078            ENDIF 
     1079         ENDIF 
     1080      ENDIF 
     1081      ! 
    10541082   END SUBROUTINE interpvnb 
    10551083 
     
    10841112         ! Polynomial interpolation coefficients: 
    10851113         zat = zrhot * (  zt1**2._wp * (-2._wp*zt1 + 3._wp)        & 
    1086                  &      - zt0**2._wp * (-2._wp*zt0 + 3._wp)        )  
     1114               &      - zt0**2._wp * (-2._wp*zt0 + 3._wp)        )  
    10871115         !  
    10881116         IF(western_side ) ubdy_w(j1:j2) = zat * ptab(i1,j1:j2)   
     
    10901118         IF(southern_side) ubdy_s(i1:i2) = zat * ptab(i1:i2,j1)  
    10911119         IF(northern_side) ubdy_n(i1:i2) = zat * ptab(i1:i2,j1)  
    1092       ENDIF    
     1120      ENDIF 
    10931121      !  
    10941122   END SUBROUTINE interpub2b 
     
    11251153         ! Polynomial interpolation coefficients: 
    11261154         zat = zrhot * (  zt1**2._wp * (-2._wp*zt1 + 3._wp)        & 
    1127                  &      - zt0**2._wp * (-2._wp*zt0 + 3._wp)        )  
     1155               &      - zt0**2._wp * (-2._wp*zt0 + 3._wp)        )  
    11281156         ! 
    11291157         IF(western_side ) vbdy_w(j1:j2) = zat * ptab(i1,j1:j2)   
     
    11471175      INTEGER :: ji, jj, jk 
    11481176      INTEGER :: icnt 
    1149       logical :: western_side, eastern_side,northern_side,southern_side       
     1177      LOGICAL :: western_side, eastern_side,northern_side,southern_side       
    11501178      !!----------------------------------------------------------------------   
    11511179      !     
    11521180      IF (before) THEN 
    1153       DO jk=k1,k2 
    1154          DO jj=j1,j2 
    1155             DO ji=i1,i2 
    1156                ptab(ji,jj,jk) = tmask(ji,jj,jk) * fse3t(ji,jj,jk) 
    1157             END DO 
    1158          END DO 
    1159       END DO 
     1181         DO jk=k1,k2 
     1182            DO jj=j1,j2 
     1183               DO ji=i1,i2 
     1184                  ptab(ji,jj,jk) = tmask(ji,jj,jk) * fse3t(ji,jj,jk) 
     1185               END DO 
     1186            END DO 
     1187         END DO 
    11601188      ELSE 
    11611189         western_side  = (nb == 1).AND.(ndir == 1) 
     
    11631191         southern_side = (nb == 2).AND.(ndir == 1) 
    11641192         northern_side = (nb == 2).AND.(ndir == 2) 
    1165           
    1166       icnt = 0 
    1167       DO jk=k1,k2 
    1168          DO jj=j1,j2 
    1169             DO ji=i1,i2 
    1170                IF (ABS(ptab(ji,jj,jk) - tmask(ji,jj,jk) * fse3t(ji,jj,jk)) > 1.D-2) THEN 
    1171                   IF (western_side) THEN 
    1172                   WRITE(numout,*) 'ERROR bathymetry merge at the western border ji,jj,jk ', ji,jj,jk 
    1173                   ELSEIF (eastern_side) THEN 
    1174                   WRITE(numout,*) 'ERROR bathymetry merge at the eastern border ji,jj,jk ', ji,jj,jk 
    1175                   ELSEIF (southern_side) THEN 
    1176                   WRITE(numout,*) 'ERROR bathymetry merge at the southern border ji,jj,jk', ji,jj,jk 
    1177                   ELSEIF (northern_side) THEN 
    1178                   WRITE(numout,*) 'ERROR bathymetry merge at the northen border ji,jj,jk', ji,jj,jk 
     1193 
     1194         icnt = 0 
     1195         DO jk=k1,k2 
     1196            DO jj=j1,j2 
     1197               DO ji=i1,i2 
     1198                  IF (ABS(ptab(ji,jj,jk) - tmask(ji,jj,jk) * fse3t(ji,jj,jk)) > 1.D-2) THEN 
     1199                     IF (western_side) THEN 
     1200                        WRITE(numout,*) 'ERROR bathymetry merge at the western border ji,jj,jk ', ji,jj,jk 
     1201                     ELSEIF (eastern_side) THEN 
     1202                        WRITE(numout,*) 'ERROR bathymetry merge at the eastern border ji,jj,jk ', ji,jj,jk 
     1203                     ELSEIF (southern_side) THEN 
     1204                        WRITE(numout,*) 'ERROR bathymetry merge at the southern border ji,jj,jk', ji,jj,jk 
     1205                     ELSEIF (northern_side) THEN 
     1206                        WRITE(numout,*) 'ERROR bathymetry merge at the northen border ji,jj,jk', ji,jj,jk 
     1207                     ENDIF 
     1208                     WRITE(numout,*) '      ptab(ji,jj,jk), fse3t(ji,jj,jk) ', ptab(ji,jj,jk), fse3t(ji,jj,jk) 
     1209                     icnt = icnt + 1 
    11791210                  ENDIF 
    1180                   WRITE(numout,*) '      ptab(ji,jj,jk), fse3t(ji,jj,jk) ', ptab(ji,jj,jk), fse3t(ji,jj,jk) 
    1181                   icnt = icnt + 1 
    1182                ENDIF 
    1183             END DO 
    1184          END DO 
    1185       END DO 
    1186       IF(icnt /= 0) THEN  
    1187          CALL ctl_stop('ERROR in bathymetry merge between parent and child grids...') 
    1188       ELSE 
    1189          IF(lwp) WRITE(numout,*) 'interp e3t ok...' 
    1190       END IF 
     1211               END DO 
     1212            END DO 
     1213         END DO 
     1214         IF(icnt /= 0) THEN  
     1215            CALL ctl_stop('ERROR in bathymetry merge between parent and child grids...') 
     1216         ELSE 
     1217            IF(lwp) WRITE(numout,*) 'interp e3t ok...' 
     1218         END IF 
    11911219      ENDIF 
    11921220      !  
    11931221   END SUBROUTINE interpe3t 
     1222 
     1223# if defined key_zdftke 
     1224   SUBROUTINE interpavt(ptab,i1,i2,j1,j2,k1,k2,before) 
     1225      !!---------------------------------------------------------------------- 
     1226      !!                  ***  ROUTINE interavt  *** 
     1227      !!----------------------------------------------------------------------   
     1228      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
     1229      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab       
     1230      LOGICAL, INTENT(in) :: before 
     1231      !!----------------------------------------------------------------------   
     1232      !       
     1233      IF( before) THEN 
     1234         ptab (i1:i2,j1:j2,k1:k2) = avt_k(i1:i2,j1:j2,k1:k2) 
     1235      ELSE 
     1236         avt_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 
     1237      ENDIF 
     1238      ! 
     1239       
     1240   END SUBROUTINE interpavt 
     1241 
     1242 
     1243   SUBROUTINE interpavm(ptab,i1,i2,j1,j2,k1,k2,before) 
     1244      !!---------------------------------------------------------------------- 
     1245      !!                  ***  ROUTINE interavm  *** 
     1246      !!----------------------------------------------------------------------   
     1247      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
     1248      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     1249      LOGICAL, INTENT(in) :: before 
     1250      !!----------------------------------------------------------------------   
     1251      !       
     1252      IF( before) THEN 
     1253         ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2) 
     1254      ELSE 
     1255         avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 
     1256      ENDIF 
     1257      ! 
     1258   END SUBROUTINE interpavm 
     1259 
     1260 
     1261   SUBROUTINE interpavmu(ptab,i1,i2,j1,j2,k1,k2,before) 
     1262      !!---------------------------------------------------------------------- 
     1263      !!                  ***  ROUTINE interavmu  *** 
     1264      !!----------------------------------------------------------------------   
     1265      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
     1266      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     1267      LOGICAL, INTENT(in) :: before 
     1268      !!----------------------------------------------------------------------   
     1269      ! 
     1270      IF( before) THEN 
     1271         ptab  (i1:i2,j1:j2,k1:k2) = avmu_k(i1:i2,j1:j2,k1:k2) 
     1272      ELSE 
     1273         avmu_k(i1:i2,j1:j2,k1:k2) = ptab   (i1:i2,j1:j2,k1:k2) 
     1274      ENDIF 
     1275      !       
     1276   END SUBROUTINE interpavmu 
     1277 
     1278 
     1279   SUBROUTINE interpavmv(ptab,i1,i2,j1,j2,k1,k2,before) 
     1280      !!---------------------------------------------------------------------- 
     1281      !!                  ***  ROUTINE interavmv  *** 
     1282      !!----------------------------------------------------------------------   
     1283      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
     1284      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     1285      LOGICAL, INTENT(in) :: before 
     1286      !!----------------------------------------------------------------------   
     1287      ! 
     1288      IF( before) THEN 
     1289         ptab  (i1:i2,j1:j2,k1:k2) = avmv_k(i1:i2,j1:j2,k1:k2) 
     1290      ELSE 
     1291         avmv_k(i1:i2,j1:j2,k1:k2) = ptab  (i1:i2,j1:j2,k1:k2) 
     1292      ENDIF 
     1293      ! 
     1294   END SUBROUTINE interpavmv 
     1295# endif /* key_zdftke */ 
    11941296 
    11951297#else 
  • branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/NST_SRC/agrif_opa_sponge.F90

    r4785 r4789  
    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 
     
    1616   PUBLIC interptsn_sponge, interpun_sponge, interpvn_sponge 
    1717 
    18   !! * Substitutions 
     18   !! * Substitutions 
    1919#  include "domzgr_substitute.h90" 
    2020   !!---------------------------------------------------------------------- 
     
    2424   !!---------------------------------------------------------------------- 
    2525 
    26    CONTAINS 
     26CONTAINS 
    2727 
    2828   SUBROUTINE Agrif_Sponge_Tra 
     
    3131      !!--------------------------------------------- 
    3232      !! 
    33       INTEGER :: ji,jj,jk,jn 
    3433      REAL(wp) :: timecoeff 
    35       REAL(wp) :: ztsa, zabe1, zabe2, zbtr 
    36       REAL(wp), POINTER, DIMENSION(:,:    ) :: ztu, ztv 
    37       REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztab 
    38       REAL(wp), POINTER, DIMENSION(:,:,:,:) :: tsbdiff 
    3934 
    4035#if defined SPONGE 
    4136      timecoeff = REAL(Agrif_NbStepint(),wp)/Agrif_rhot() 
    42        
     37 
    4338      CALL Agrif_Sponge 
    4439      Agrif_SpecialValue=0. 
    4540      Agrif_UseSpecialValue = .TRUE. 
    46       tabspongedone = .FALSE. 
     41      tabspongedone_tsn = .FALSE. 
    4742 
    4843      CALL Agrif_Bc_Variable(tsn_sponge_id,calledweight=timecoeff,procname=interptsn_sponge) 
     
    6358      timecoeff = REAL(Agrif_NbStepint(),wp)/Agrif_rhot() 
    6459 
    65          Agrif_SpecialValue=0. 
    66          Agrif_UseSpecialValue = ln_spc_dyn 
    67  
    68          tabspongedone_u = .FALSE. 
    69          tabspongedone_v = .FALSE.          
    70          CALL Agrif_Bc_Variable(un_sponge_id,calledweight=timecoeff,procname=interpun_sponge) 
    71  
    72          tabspongedone_u = .FALSE. 
    73          tabspongedone_v = .FALSE. 
    74          CALL Agrif_Bc_Variable(vn_sponge_id,calledweight=timecoeff,procname=interpvn_sponge) 
    75  
    76          Agrif_UseSpecialValue = .FALSE. 
     60      Agrif_SpecialValue=0. 
     61      Agrif_UseSpecialValue = ln_spc_dyn 
     62 
     63      tabspongedone_u = .FALSE. 
     64      tabspongedone_v = .FALSE.          
     65      CALL Agrif_Bc_Variable(un_sponge_id,calledweight=timecoeff,procname=interpun_sponge) 
     66 
     67      tabspongedone_u = .FALSE. 
     68      tabspongedone_v = .FALSE. 
     69      CALL Agrif_Bc_Variable(vn_sponge_id,calledweight=timecoeff,procname=interpvn_sponge) 
     70 
     71      Agrif_UseSpecialValue = .FALSE. 
    7772#endif 
    7873 
     
    109104            ENDDO 
    110105            spe1ur(2:ispongearea-1,:      ) = 0.5 * ( zlocalviscsponge(2:ispongearea-1,:      )   & 
    111                &                         +            zlocalviscsponge(3:ispongearea  ,:      ) ) & 
    112                &                         * e2u(2:ispongearea-1,:      ) / e1u(2:ispongearea-1,:      ) 
     106                  &                         +            zlocalviscsponge(3:ispongearea  ,:      ) ) & 
     107                  &                         * e2u(2:ispongearea-1,:      ) / e1u(2:ispongearea-1,:      ) 
    113108            spe2vr(2:ispongearea  ,1:jpjm1) = 0.5 * ( zlocalviscsponge(2:ispongearea  ,1:jpjm1)   & 
    114                &                         +            zlocalviscsponge(2:ispongearea,2  :jpj  ) ) & 
    115                &                         * e1v(2:ispongearea  ,1:jpjm1) / e2v(2:ispongearea  ,1:jpjm1) 
     109                  &                         +            zlocalviscsponge(2:ispongearea,2  :jpj  ) ) & 
     110                  &                         * e1v(2:ispongearea  ,1:jpjm1) / e2v(2:ispongearea  ,1:jpjm1) 
    116111         ENDIF 
    117112 
     
    120115               zlocalviscsponge(ji,:) = visc_tra * (ji - (ilci+1) ) * z1spongearea 
    121116            ENDDO 
    122    
     117 
    123118            spe1ur(ilci+1:nlci-2,:      ) = 0.5 * (  zlocalviscsponge(ilci+1:nlci-2,:)    &  
    124                &                          +          zlocalviscsponge(ilci+2:nlci-1,:) )  & 
    125                &                          * e2u(ilci+1:nlci-2,:) / e1u(ilci+1:nlci-2,:) 
     119                  &                          +          zlocalviscsponge(ilci+2:nlci-1,:) )  & 
     120                  &                          * e2u(ilci+1:nlci-2,:) / e1u(ilci+1:nlci-2,:) 
    126121 
    127122            spe2vr(ilci+1:nlci-1,1:jpjm1) = 0.5 * (  zlocalviscsponge(ilci+1:nlci-1,1:jpjm1)    &  
    128                &                            +        zlocalviscsponge(ilci+1:nlci-1,2:jpj  )  ) &  
    129                &                                   * e1v(ilci+1:nlci-1,1:jpjm1) / e2v(ilci+1:nlci-1,1:jpjm1) 
     123                  &                            +        zlocalviscsponge(ilci+1:nlci-1,2:jpj  )  ) &  
     124                  &                                   * e1v(ilci+1:nlci-1,1:jpjm1) / e2v(ilci+1:nlci-1,1:jpjm1) 
    130125         ENDIF 
    131126 
     
    135130            ENDDO 
    136131            spe1ur(1:jpim1,2:ispongearea  ) = 0.5 * ( zlocalviscsponge(1:jpim1,2:ispongearea  ) &  
    137                &                            +         zlocalviscsponge(2:jpi  ,2:ispongearea) ) & 
    138                &                            * e2u(1:jpim1,2:ispongearea) / e1u(1:jpim1,2:ispongearea) 
    139     
     132                  &                            +         zlocalviscsponge(2:jpi  ,2:ispongearea) ) & 
     133                  &                            * e2u(1:jpim1,2:ispongearea) / e1u(1:jpim1,2:ispongearea) 
     134 
    140135            spe2vr(:      ,2:ispongearea-1) = 0.5 * ( zlocalviscsponge(:,2:ispongearea-1)       & 
    141                &                            +         zlocalviscsponge(:,3:ispongearea  )     ) & 
    142                &                            * e1v(:,2:ispongearea-1) / e2v(:,2:ispongearea-1) 
     136                  &                            +         zlocalviscsponge(:,3:ispongearea  )     ) & 
     137                  &                            * e1v(:,2:ispongearea-1) / e2v(:,2:ispongearea-1) 
    143138         ENDIF 
    144139 
     
    148143            ENDDO 
    149144            spe1ur(1:jpim1,ilcj+1:nlcj-1) = 0.5 * ( zlocalviscsponge(1:jpim1,ilcj+1:nlcj-1)   & 
    150                &                          +         zlocalviscsponge(2:jpi  ,ilcj+1:nlcj-1) ) & 
    151                &                                * e2u(1:jpim1,ilcj+1:nlcj-1) / e1u(1:jpim1,ilcj+1:nlcj-1) 
     145                  &                          +         zlocalviscsponge(2:jpi  ,ilcj+1:nlcj-1) ) & 
     146                  &                                * e2u(1:jpim1,ilcj+1:nlcj-1) / e1u(1:jpim1,ilcj+1:nlcj-1) 
    152147            spe2vr(:      ,ilcj+1:nlcj-2) = 0.5 * ( zlocalviscsponge(:,ilcj+1:nlcj-2      )   & 
    153                &                          +         zlocalviscsponge(:,ilcj+2:nlcj-1)     )   & 
    154                &                                * e1v(:,ilcj+1:nlcj-2) / e2v(:,ilcj+1:nlcj-2) 
     148                  &                          +         zlocalviscsponge(:,ilcj+2:nlcj-1)     )   & 
     149                  &                                * e1v(:,ilcj+1:nlcj-2) / e2v(:,ilcj+1:nlcj-2) 
    155150         ENDIF 
    156151         spongedoneT = .TRUE. 
     
    168163            ENDDO 
    169164            spe1ur2(2:ispongearea-1,:      ) = 0.5 * ( zlocalviscsponge(2:ispongearea-1,:      ) & 
    170                                              &     +   zlocalviscsponge(3:ispongearea,:    ) ) 
     165                  &     +   zlocalviscsponge(3:ispongearea,:    ) ) 
    171166            spe2vr2(2:ispongearea  ,1:jpjm1) = 0.5 * ( zlocalviscsponge(2:ispongearea  ,1:jpjm1) & 
    172                                              &     +   zlocalviscsponge(2:ispongearea,2:jpj) )  
     167                  &     +   zlocalviscsponge(2:ispongearea,2:jpj) )  
    173168         ENDIF 
    174169 
     
    178173            ENDDO 
    179174            spe1ur2(ilci+1:nlci-2,:      ) = 0.5 * (  zlocalviscsponge(ilci+1:nlci-2,:) & 
    180                                            &        + zlocalviscsponge(ilci+2:nlci-1,:) )   
     175                  &        + zlocalviscsponge(ilci+2:nlci-1,:) )   
    181176            spe2vr2(ilci+1:nlci-1,1:jpjm1) = 0.5 * (  zlocalviscsponge(ilci+1:nlci-1,1:jpjm1) & 
    182                                            &        + zlocalviscsponge(ilci+1:nlci-1,2:jpj  )  )  
     177                  &        + zlocalviscsponge(ilci+1:nlci-1,2:jpj  )  )  
    183178         ENDIF 
    184179 
     
    188183            ENDDO 
    189184            spe1ur2(1:jpim1,2:ispongearea  ) = 0.5 * ( zlocalviscsponge(1:jpim1,2:ispongearea) & 
    190                                              &      + zlocalviscsponge(2:jpi,2:ispongearea) )  
     185                  &      + zlocalviscsponge(2:jpi,2:ispongearea) )  
    191186            spe2vr2(:      ,2:ispongearea-1) = 0.5 * ( zlocalviscsponge(:,2:ispongearea-1)     & 
    192                                              &      + zlocalviscsponge(:,3:ispongearea)     ) 
     187                  &      + zlocalviscsponge(:,3:ispongearea)     ) 
    193188         ENDIF 
    194189 
     
    198193            ENDDO 
    199194            spe1ur2(1:jpim1,ilcj+1:nlcj-1) = 0.5 * ( zlocalviscsponge(1:jpim1,ilcj+1:nlcj-1) & 
    200                                            &         + zlocalviscsponge(2:jpi,ilcj+1:nlcj-1) )  
     195                  &         + zlocalviscsponge(2:jpi,ilcj+1:nlcj-1) )  
    201196            spe2vr2(:      ,ilcj+1:nlcj-2) = 0.5 * ( zlocalviscsponge(:,ilcj+1:nlcj-2      ) & 
    202                                            &         + zlocalviscsponge(:,ilcj+2:nlcj-1)     ) 
     197                  &         + zlocalviscsponge(:,ilcj+2:nlcj-1)     ) 
    203198         ENDIF 
    204199         spongedoneU = .TRUE. 
     
    219214      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 
    220215      LOGICAL, INTENT(in) :: before 
    221         
    222       
     216 
     217 
    223218      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    224219 
     
    227222      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2) ::tsbdiff 
    228223      ! 
    229           
    230           
    231          IF (before) THEN 
    232             tabres(i1:i2,j1:j2,k1:k2,n1:n2) = tsn(i1:i2,j1:j2,k1:k2,n1:n2) 
    233          ELSE       
    234  
    235             tsbdiff(:,:,:,:) = tsb(i1:i2,j1:j2,:,:) - tabres(:,:,:,:)       
    236             DO jn = 1, jpts 
    237                DO jk = 1, jpkm1 
    238                   
    239                   DO jj = j1,j2-1 
    240                      DO ji = i1,i2-1 
    241                         zabe1 = umask(ji,jj,jk) * spe1ur(ji,jj) * fse3u(ji,jj,jk) 
    242                         zabe2 = vmask(ji,jj,jk) * spe2vr(ji,jj) * fse3v(ji,jj,jk) 
    243                         ztu(ji,jj) = zabe1 * ( tsbdiff(ji+1,jj  ,jk,jn) - tsbdiff(ji,jj,jk,jn) ) 
    244                         ztv(ji,jj) = zabe2 * ( tsbdiff(ji  ,jj+1,jk,jn) - tsbdiff(ji,jj,jk,jn) ) 
    245                      ENDDO 
     224 
     225 
     226      IF (before) THEN 
     227         tabres(i1:i2,j1:j2,k1:k2,n1:n2) = tsn(i1:i2,j1:j2,k1:k2,n1:n2) 
     228      ELSE       
     229 
     230         tsbdiff(:,:,:,:) = tsb(i1:i2,j1:j2,:,:) - tabres(:,:,:,:)       
     231         DO jn = 1, jpts 
     232            DO jk = 1, jpkm1 
     233 
     234               DO jj = j1,j2-1 
     235                  DO ji = i1,i2-1 
     236                     zabe1 = umask(ji,jj,jk) * spe1ur(ji,jj) * fse3u(ji,jj,jk) 
     237                     zabe2 = vmask(ji,jj,jk) * spe2vr(ji,jj) * fse3v(ji,jj,jk) 
     238                     ztu(ji,jj) = zabe1 * ( tsbdiff(ji+1,jj  ,jk,jn) - tsbdiff(ji,jj,jk,jn) ) 
     239                     ztv(ji,jj) = zabe2 * ( tsbdiff(ji  ,jj+1,jk,jn) - tsbdiff(ji,jj,jk,jn) ) 
    246240                  ENDDO 
    247                    
    248                   DO jj = j1+1,j2-1 
    249                      DO ji = i1+1,i2-1 
    250                          
    251                         if (.not. tabspongedone(ji,jj)) then  
    252                            zbtr = spbtr2(ji,jj) / fse3t(ji,jj,jk) 
    253             ! horizontal diffusive trends 
    254                            ztsa = zbtr * (  ztu(ji,jj) - ztu(ji-1,jj  ) + ztv(ji,jj) - ztv(ji  ,jj-1)  ) 
    255             ! add it to the general tracer trends 
    256                            tsa(ji,jj,jk,jn) = tsa(ji,jj,jk,jn) + ztsa 
    257                          endif  
    258   
    259                        ENDDO 
    260                     ENDDO 
    261                      
    262                 ENDDO 
    263              ENDDO 
    264               
    265              tabspongedone(i1+1:i2-1,j1+1:j2-1) = .TRUE. 
    266                           
    267     ENDIF 
    268                  
     241               ENDDO 
     242 
     243               DO jj = j1+1,j2-1 
     244                  DO ji = i1+1,i2-1 
     245 
     246                     IF (.NOT. tabspongedone_tsn(ji,jj)) THEN  
     247                        zbtr = spbtr2(ji,jj) / fse3t(ji,jj,jk) 
     248                        ! horizontal diffusive trends 
     249                        ztsa = zbtr * (  ztu(ji,jj) - ztu(ji-1,jj  ) + ztv(ji,jj) - ztv(ji  ,jj-1)  ) 
     250                        ! add it to the general tracer trends 
     251                        tsa(ji,jj,jk,jn) = tsa(ji,jj,jk,jn) + ztsa 
     252                     ENDIF 
     253 
     254                  ENDDO 
     255               ENDDO 
     256 
     257            ENDDO 
     258         ENDDO 
     259 
     260         tabspongedone_tsn(i1+1:i2-1,j1+1:j2-1) = .TRUE. 
     261 
     262      ENDIF 
     263 
    269264   END SUBROUTINE interptsn_sponge 
    270265 
     
    279274      INTEGER :: ji,jj,jk 
    280275 
    281    ! sponge parameters  
     276      ! sponge parameters  
    282277      REAL(wp) :: ze2u, ze1v, zua, zva, zbtr 
    283278      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: ubdiff 
    284279      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: rotdiff, hdivdiff 
    285280      INTEGER :: jmax 
    286    ! 
    287        
     281      ! 
     282 
    288283 
    289284      IF (before) THEN 
    290            
    291           tabres = un(i1:i2,j1:j2,:) 
     285 
     286         tabres = un(i1:i2,j1:j2,:) 
    292287 
    293288      ELSE 
    294           
     289 
    295290         ubdiff(i1:i2,j1:j2,:) = (ub(i1:i2,j1:j2,:) - tabres(:,:,:))*umask(i1:i2,j1:j2,:) 
    296           
     291 
    297292         DO jk=1,jpkm1 
    298293            ubdiff(i1:i2,j1:j2,jk) = ubdiff(i1:i2,j1:j2,jk) * spe1ur2(i1:i2,j1:j2) 
     
    300295 
    301296         DO jk = 1, jpkm1                                 ! Horizontal slab 
    302 !                                             ! =============== 
    303  
    304 !                                             ! -------- 
    305 ! Horizontal divergence                       !   div 
    306 !                                             ! -------- 
     297            !                                             ! =============== 
     298 
     299            !                                             ! -------- 
     300            ! Horizontal divergence                       !   div 
     301            !                                             ! -------- 
    307302            DO jj = j1,j2 
    308303               DO ji = i1+1,i2   ! vector opt. 
    309304                  zbtr = spbtr2(ji,jj) / fse3t(ji,jj,jk) 
    310305                  hdivdiff(ji,jj,jk) = (e2u(ji,jj)*fse3u(ji,jj,jk) * ubdiff(ji,jj,jk) - e2u(ji-1,jj)* fse3u(ji-1,jj  ,jk)  & 
    311                                        * ubdiff(ji-1,jj  ,jk) ) * zbtr 
     306                        * ubdiff(ji-1,jj  ,jk) ) * zbtr 
    312307               END DO 
    313308            END DO 
     
    317312                  zbtr = spbtr3(ji,jj) * fse3f(ji,jj,jk) 
    318313                  rotdiff(ji,jj,jk) = (- e1u(ji  ,jj+1) * ubdiff(ji  ,jj+1,jk) + e1u(ji,jj) * ubdiff(ji,jj,jk)  ) & 
    319                                       * fmask(ji,jj,jk) * zbtr  
     314                        * fmask(ji,jj,jk) * zbtr  
    320315               END DO 
    321316            END DO 
    322317         ENDDO 
    323318 
    324 ! 
    325  
    326  
    327  
    328             DO jj = j1+1, j2-1 
    329                DO ji = i1+1, i2-1   ! vector opt. 
    330                    
    331                   if (.not. tabspongedone_u(ji,jj)) then 
    332                      DO jk = 1, jpkm1                                 ! Horizontal slab 
    333                         ze2u = rotdiff (ji,jj,jk) 
    334                         ze1v = hdivdiff(ji,jj,jk) 
    335 ! horizontal diffusive trends 
    336                         zua = - ( ze2u - rotdiff (ji,jj-1,jk)) / ( e2u(ji,jj) * fse3u(ji,jj,jk) )   & 
    337                         + ( hdivdiff(ji+1,jj,jk) - ze1v  ) / e1u(ji,jj) 
    338  
    339 ! add it to the general momentum trends 
    340                         ua(ji,jj,jk) = ua(ji,jj,jk) + zua 
    341  
    342                      END DO                   
    343                   endif  
    344  
    345                END DO             
    346             END DO 
    347                    
    348             tabspongedone_u(i1+1:i2-1,j1+1:j2-1) = .true. 
    349   
     319         ! 
     320 
     321 
     322 
     323         DO jj = j1+1, j2-1 
     324            DO ji = i1+1, i2-1   ! vector opt. 
     325 
     326               IF (.NOT. tabspongedone_u(ji,jj)) THEN 
     327                  DO jk = 1, jpkm1                                 ! Horizontal slab 
     328                     ze2u = rotdiff (ji,jj,jk) 
     329                     ze1v = hdivdiff(ji,jj,jk) 
     330                     ! horizontal diffusive trends 
     331                     zua = - ( ze2u - rotdiff (ji,jj-1,jk)) / ( e2u(ji,jj) * fse3u(ji,jj,jk) )   & 
     332                           + ( hdivdiff(ji+1,jj,jk) - ze1v  ) / e1u(ji,jj) 
     333 
     334                     ! add it to the general momentum trends 
     335                     ua(ji,jj,jk) = ua(ji,jj,jk) + zua 
     336 
     337                  END DO 
     338               ENDIF 
     339 
     340            END DO 
     341         END DO 
     342 
     343         tabspongedone_u(i1+1:i2-1,j1+1:j2-1) = .TRUE. 
     344 
    350345         jmax = j2-1 
    351          If ((nbondj == 1).OR.(nbondj == 2)) jmax = min(jmax,nlcj-3) 
    352                                  
    353             DO jj = j1+1, jmax 
    354                DO ji = i1+1, i2   ! vector opt. 
    355                    
    356                   if (.not. tabspongedone_v(ji,jj)) then 
    357                      DO jk = 1, jpkm1                                 ! Horizontal slab 
    358                         ze2u = rotdiff (ji,jj,jk) 
    359                         ze1v = hdivdiff(ji,jj,jk) 
    360                          
    361 ! horizontal diffusive trends 
    362                         zva = + ( ze2u - rotdiff (ji-1,jj,jk)) / ( e1v(ji,jj) * fse3v(ji,jj,jk) )   & 
    363                         + ( hdivdiff(ji,jj+1,jk) - ze1v  ) / e2v(ji,jj) 
    364  
    365 ! add it to the general momentum trends 
    366                         va(ji,jj,jk) = va(ji,jj,jk) + zva 
    367                      END DO                   
    368                   endif  
    369  
    370                END DO             
    371             END DO 
    372  
    373              
    374             tabspongedone_v(i1+1:i2,j1+1:jmax) = .true. 
    375              
     346         IF ((nbondj == 1).OR.(nbondj == 2)) jmax = MIN(jmax,nlcj-3) 
     347 
     348         DO jj = j1+1, jmax 
     349            DO ji = i1+1, i2   ! vector opt. 
     350 
     351               IF (.NOT. tabspongedone_v(ji,jj)) THEN 
     352                  DO jk = 1, jpkm1                                 ! Horizontal slab 
     353                     ze2u = rotdiff (ji,jj,jk) 
     354                     ze1v = hdivdiff(ji,jj,jk) 
     355 
     356                     ! horizontal diffusive trends 
     357                     zva = + ( ze2u - rotdiff (ji-1,jj,jk)) / ( e1v(ji,jj) * fse3v(ji,jj,jk) )   & 
     358                           + ( hdivdiff(ji,jj+1,jk) - ze1v  ) / e2v(ji,jj) 
     359 
     360                     ! add it to the general momentum trends 
     361                     va(ji,jj,jk) = va(ji,jj,jk) + zva 
     362                  END DO 
     363               ENDIF 
     364 
     365            END DO 
     366         END DO 
     367 
     368 
     369         tabspongedone_v(i1+1:i2,j1+1:jmax) = .TRUE. 
     370 
    376371      ENDIF 
    377           
    378            
     372 
     373 
    379374   END SUBROUTINE interpun_sponge 
    380   
    381     
     375 
     376 
    382377   SUBROUTINE interpvn_sponge(tabres,i1,i2,j1,j2,k1,k2, before,nb,ndir) 
    383      !!--------------------------------------------- 
     378      !!--------------------------------------------- 
    384379      !!   *** ROUTINE interpvn_sponge *** 
    385380      !!---------------------------------------------  
     
    392387 
    393388      REAL(wp) :: ze2u, ze1v, zua, zva, zbtr 
    394        
     389 
    395390      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: vbdiff 
    396391      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: rotdiff, hdivdiff 
    397392      INTEGER :: imax 
    398    ! 
    399       
     393      ! 
     394 
    400395      IF (before) THEN  
    401         tabres = vn(i1:i2,j1:j2,:) 
     396         tabres = vn(i1:i2,j1:j2,:) 
    402397      ELSE 
    403398 
    404399         vbdiff(i1:i2,j1:j2,:) = (vb(i1:i2,j1:j2,:) - tabres(:,:,:))*vmask(i1:i2,j1:j2,:) 
    405              
     400 
    406401         DO jk=1,jpkm1 
    407402            vbdiff(i1:i2,j1:j2,jk) = vbdiff(i1:i2,j1:j2,jk) * spe2vr2(i1:i2,j1:j2) 
     
    409404 
    410405         DO jk = 1, jpkm1                                 ! Horizontal slab 
    411 !                                             ! =============== 
    412  
    413 !                                             ! -------- 
    414 ! Horizontal divergence                       !   div 
    415 !                                             ! -------- 
     406            !                                             ! =============== 
     407 
     408            !                                             ! -------- 
     409            ! Horizontal divergence                       !   div 
     410            !                                             ! -------- 
    416411            DO jj = j1+1,j2 
    417412               DO ji = i1,i2   ! vector opt. 
    418413                  zbtr = spbtr2(ji,jj) / fse3t(ji,jj,jk) 
    419414                  hdivdiff(ji,jj,jk) = (e1v(ji,jj) * fse3v(ji,jj,jk) * vbdiff(ji,jj,jk) - e1v(ji  ,jj-1) & 
    420                                        * fse3v(ji  ,jj-1,jk)  * vbdiff(ji  ,jj-1,jk)  ) * zbtr 
     415                        * fse3v(ji  ,jj-1,jk)  * vbdiff(ji  ,jj-1,jk)  ) * zbtr 
    421416               END DO 
    422417            END DO 
    423  
    424418            DO jj = j1,j2 
    425419               DO ji = i1,i2-1   ! vector opt. 
    426420                  zbtr = spbtr3(ji,jj) * fse3f(ji,jj,jk) 
    427421                  rotdiff(ji,jj,jk) = (e2v(ji+1,jj  ) * vbdiff(ji+1,jj  ,jk) - e2v(ji,jj) * vbdiff(ji,jj,jk)) & 
    428                                       * fmask(ji,jj,jk) * zbtr 
     422                        * fmask(ji,jj,jk) * zbtr 
    429423               END DO 
    430424            END DO 
    431  
    432425         ENDDO 
    433426 
    434 !                                                ! =============== 
    435 !                                                 
    436           
     427         !                                                ! =============== 
     428         !                                                 
     429 
    437430         imax = i2-1 
    438          If ((nbondi == 1).OR.(nbondi == 2)) imax = min(imax,nlci-3) 
    439                              
    440             DO jj = j1+1, j2 
    441                DO ji = i1+1, imax   ! vector opt. 
    442                   if (.not. tabspongedone_u(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                         zua = - ( ze2u - rotdiff (ji,jj-1,jk)) / ( e2u(ji,jj) * fse3u(ji,jj,jk) ) + ( hdivdiff(ji+1,jj,jk) - ze1v) & 
    448                         / e1u(ji,jj) 
    449  
    450  
    451 ! add it to the general momentum trends 
    452                        ua(ji,jj,jk) = ua(ji,jj,jk) + zua 
    453                      END DO 
    454  
    455                    endif 
    456             END DO             
    457          END DO   
    458    
    459          tabspongedone_u(i1+1:imax,j1+1:j2) = .true. 
    460           
    461             DO jj = j1+1, j2-1 
    462                DO ji = i1+1, i2-1   ! vector opt. 
    463                   if (.not. tabspongedone_v(ji,jj)) then 
    464                      DO jk = 1, jpkm1                                 ! Horizontal slab 
    465                         ze2u = rotdiff (ji,jj,jk) 
    466                         ze1v = hdivdiff(ji,jj,jk) 
    467 ! horizontal diffusive trends 
    468  
    469                         zva = + ( ze2u - rotdiff (ji-1,jj,jk)) / ( e1v(ji,jj) * fse3v(ji,jj,jk) ) + ( hdivdiff(ji,jj+1,jk) - ze1v) & 
    470                         / e2v(ji,jj) 
    471  
    472 ! add it to the general momentum trends 
    473                        va(ji,jj,jk) = va(ji,jj,jk) + zva 
    474                      END DO 
    475  
    476                    endif 
    477             END DO             
    478          END DO           
    479           
    480          tabspongedone_v(i1+1:i2-1,j1+1:j2-1) = .true. 
    481           
     431         IF ((nbondi == 1).OR.(nbondi == 2)) imax = MIN(imax,nlci-3) 
     432 
     433         DO jj = j1+1, j2 
     434            DO ji = i1+1, imax   ! vector opt. 
     435               IF (.NOT. tabspongedone_u(ji,jj)) THEN 
     436                  DO jk = 1, jpkm1                                 ! Horizontal slab 
     437                     ze2u = rotdiff (ji,jj,jk) 
     438                     ze1v = hdivdiff(ji,jj,jk) 
     439                     ! horizontal diffusive trends 
     440                     zua = - ( ze2u - rotdiff (ji,jj-1,jk)) / ( e2u(ji,jj) * fse3u(ji,jj,jk) ) + ( hdivdiff(ji+1,jj,jk) - ze1v) & 
     441                           / e1u(ji,jj) 
     442 
     443 
     444                     ! add it to the general momentum trends 
     445                     ua(ji,jj,jk) = ua(ji,jj,jk) + zua 
     446                  END DO 
     447 
     448               ENDIF 
     449            END DO 
     450         END DO 
     451 
     452         tabspongedone_u(i1+1:imax,j1+1:j2) = .TRUE. 
     453 
     454         DO jj = j1+1, j2-1 
     455            DO ji = i1+1, i2-1   ! vector opt. 
     456               IF (.NOT. tabspongedone_v(ji,jj)) THEN 
     457                  DO jk = 1, jpkm1                                 ! Horizontal slab 
     458                     ze2u = rotdiff (ji,jj,jk) 
     459                     ze1v = hdivdiff(ji,jj,jk) 
     460                     ! horizontal diffusive trends 
     461 
     462                     zva = + ( ze2u - rotdiff (ji-1,jj,jk)) / ( e1v(ji,jj) * fse3v(ji,jj,jk) ) + ( hdivdiff(ji,jj+1,jk) - ze1v) & 
     463                           / e2v(ji,jj) 
     464 
     465                     ! add it to the general momentum trends 
     466                     va(ji,jj,jk) = va(ji,jj,jk) + zva 
     467                  END DO 
     468               ENDIF 
     469            END DO 
     470         END DO 
     471         tabspongedone_v(i1+1:i2-1,j1+1:j2-1) = .TRUE. 
    482472      ENDIF 
    483       
     473 
    484474   END SUBROUTINE interpvn_sponge 
    485475 
  • branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90

    r4785 r4789  
    1212   USE wrk_nemo   
    1313   USE dynspg_oce 
     14   USE zdf_oce        ! vertical physics: ocean variables  
    1415 
    1516   IMPLICIT NONE 
     
    1718 
    1819   PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn,Update_Scales 
    19  
     20# if defined key_zdftke 
     21   PUBLIC Agrif_Update_Tke 
     22# endif 
    2023   !!---------------------------------------------------------------------- 
    21    !! NEMO/NST 3.3 , NEMO Consortium (2010) 
     24   !! NEMO/NST 3.6 , NEMO Consortium (2010) 
    2225   !! $Id$ 
    2326   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
     
    115118         CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1,1/),locupdate2=(/0,1/),procname = updatevb2b) 
    116119#  endif 
    117       END IF  
     120      END IF 
    118121# endif 
    119122      ! 
     
    132135   END SUBROUTINE Agrif_Update_Dyn 
    133136 
     137# if defined key_zdftke 
     138   SUBROUTINE Agrif_Update_Tke( kt ) 
     139      !!--------------------------------------------- 
     140      !!   *** ROUTINE Agrif_Update_Tke *** 
     141      !!--------------------------------------------- 
     142      !! 
     143      INTEGER, INTENT(in) :: kt 
     144      !        
     145      IF((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) RETURN 
     146#  if defined TWO_WAY 
     147 
     148      Agrif_UseSpecialValueInUpdate = .TRUE. 
     149      Agrif_SpecialValueFineGrid = 0. 
     150 
     151      CALL Agrif_Update_Variable(avt_id ,locupdate=(/0,0/), procname=updateAVT ) 
     152      CALL Agrif_Update_Variable(avm_id ,locupdate=(/0,0/), procname=updateAVM ) 
     153      CALL Agrif_Update_Variable(avmu_id,locupdate=(/0,0/), procname=updateAVMu) 
     154      CALL Agrif_Update_Variable(avmv_id,locupdate=(/0,0/), procname=updateAVMv) 
     155 
     156      Agrif_UseSpecialValueInUpdate = .FALSE. 
     157 
     158#  endif 
     159       
     160   END SUBROUTINE Agrif_Update_Tke 
     161# endif /* key_zdftke */ 
    134162 
    135163   SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) 
     
    164192                        IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN 
    165193                           tsb(ji,jj,jk,jn) = tsb(ji,jj,jk,jn) &  
    166                               & + atfp * ( tabres(ji,jj,jk,jn) & 
    167                               &             - tsn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 
     194                                 & + atfp * ( tabres(ji,jj,jk,jn) & 
     195                                 &             - tsn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 
    168196                        ENDIF 
    169197                     ENDDO 
     
    220248                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 
    221249                     ub(ji,jj,jk) = ub(ji,jj,jk) &  
    222                        & + atfp * ( tabres(ji,jj,jk) - un(ji,jj,jk) ) * umask(ji,jj,jk) 
     250                           & + atfp * ( tabres(ji,jj,jk) - un(ji,jj,jk) ) * umask(ji,jj,jk) 
    223251                  ENDIF 
    224252                  ! 
     
    264292                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 
    265293                     vb(ji,jj,jk) = vb(ji,jj,jk) &  
    266                        & + atfp * ( tabres(ji,jj,jk) - vn(ji,jj,jk) ) * vmask(ji,jj,jk) 
     294                           & + atfp * ( tabres(ji,jj,jk) - vn(ji,jj,jk) ) * vmask(ji,jj,jk) 
    267295                  ENDIF 
    268296                  ! 
     
    406434      !  
    407435   END SUBROUTINE updatev2d 
    408        
     436 
    409437 
    410438   SUBROUTINE updateSSH( tabres, i1, i2, j1, j2, before ) 
     
    430458            DO jj=j1,j2 
    431459               DO ji=i1,i2 
    432                 sshb(ji,jj) =   sshb(ji,jj) & 
    433                  & + atfp * ( tabres(ji,jj) - sshn(ji,jj) ) * tmask(ji,jj,1) 
     460                  sshb(ji,jj) =   sshb(ji,jj) & 
     461                        & + atfp * ( tabres(ji,jj) - sshn(ji,jj) ) * tmask(ji,jj,1) 
    434462               END DO 
    435463            END DO 
     
    507535 
    508536   SUBROUTINE update_scales( tabres, i1, i2, j1, j2, k1, k2, n1,n2, before ) 
    509    ! currently not used 
     537      ! currently not used 
    510538      !!--------------------------------------------- 
    511539      !!           *** ROUTINE updateT *** 
     
    521549 
    522550      IF (before) THEN 
    523             DO jk=k1,k2 
    524                DO jj=j1,j2 
    525                   DO ji=i1,i2 
    526                      tabres(ji,jj,jk,1) = e1t(ji,jj)*e2t(ji,jj)*tmask(ji,jj,jk) 
    527                      tabres(ji,jj,jk,2) = e1t(ji,jj)*tmask(ji,jj,jk) 
    528                      tabres(ji,jj,jk,3) = e2t(ji,jj)*tmask(ji,jj,jk) 
    529                   END DO 
    530                END DO 
    531             END DO 
    532             tabres(:,:,:,1)=tabres(:,:,:,1)*Agrif_Rhox()*Agrif_Rhoy() 
    533             tabres(:,:,:,2)=tabres(:,:,:,2)*Agrif_Rhox() 
    534             tabres(:,:,:,3)=tabres(:,:,:,3)*Agrif_Rhoy() 
    535       ELSE 
    536             DO jk=k1,k2 
    537                DO jj=j1,j2 
    538                   DO ji=i1,i2 
    539                      IF( tabres(ji,jj,jk,1) .NE. 0. ) THEN  
     551         DO jk=k1,k2 
     552            DO jj=j1,j2 
     553               DO ji=i1,i2 
     554                  tabres(ji,jj,jk,1) = e1t(ji,jj)*e2t(ji,jj)*tmask(ji,jj,jk) 
     555                  tabres(ji,jj,jk,2) = e1t(ji,jj)*tmask(ji,jj,jk) 
     556                  tabres(ji,jj,jk,3) = e2t(ji,jj)*tmask(ji,jj,jk) 
     557               END DO 
     558            END DO 
     559         END DO 
     560         tabres(:,:,:,1)=tabres(:,:,:,1)*Agrif_Rhox()*Agrif_Rhoy() 
     561         tabres(:,:,:,2)=tabres(:,:,:,2)*Agrif_Rhox() 
     562         tabres(:,:,:,3)=tabres(:,:,:,3)*Agrif_Rhoy() 
     563      ELSE 
     564         DO jk=k1,k2 
     565            DO jj=j1,j2 
     566               DO ji=i1,i2 
     567                  IF( tabres(ji,jj,jk,1) .NE. 0. ) THEN  
    540568                     print *,'VAL = ',ji,jj,jk,tabres(ji,jj,jk,1),e1t(ji,jj)*e2t(ji,jj)*tmask(ji,jj,jk) 
    541569                     print *,'VAL2 = ',ji,jj,jk,tabres(ji,jj,jk,2),e1t(ji,jj)*tmask(ji,jj,jk) 
     
    544572                     print *,'CORR = ',ztemp-1. 
    545573                     print *,'NEW VALS = ',tabres(ji,jj,jk,2)*ztemp,tabres(ji,jj,jk,3)*ztemp, & 
    546                      tabres(ji,jj,jk,2)*ztemp*tabres(ji,jj,jk,3)*ztemp 
     574                           tabres(ji,jj,jk,2)*ztemp*tabres(ji,jj,jk,3)*ztemp 
    547575                     e1t(ji,jj) = tabres(ji,jj,jk,2)*ztemp 
    548576                     e2t(ji,jj) = tabres(ji,jj,jk,3)*ztemp 
    549                      END IF 
    550                   END DO 
    551                END DO 
    552             END DO 
    553       ENDIF 
    554  
     577                  END IF 
     578               END DO 
     579            END DO 
     580         END DO 
     581      ENDIF 
     582      ! 
    555583   END SUBROUTINE update_scales 
     584 
     585# if defined key_zdftke 
     586   SUBROUTINE updateAVT( ptab, i1, i2, j1, j2, k1, k2, before ) 
     587      !!--------------------------------------------- 
     588      !!           *** ROUTINE updateavt *** 
     589      !!--------------------------------------------- 
     590      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 
     591      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     592      LOGICAL, INTENT(in) :: before 
     593      !!--------------------------------------------- 
     594      ! 
     595      IF (before) THEN 
     596         ptab (i1:i2,j1:j2,k1:k2) = avt_k(i1:i2,j1:j2,k1:k2) 
     597      ELSE 
     598         avt_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2)  
     599      ENDIF 
     600      ! 
     601   END SUBROUTINE updateAVT 
     602 
     603 
     604   SUBROUTINE updateAVM( ptab, i1, i2, j1, j2, k1, k2, before ) 
     605      !!--------------------------------------------- 
     606      !!           *** ROUTINE updateavm *** 
     607      !!--------------------------------------------- 
     608      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 
     609      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     610      LOGICAL, INTENT(in) :: before 
     611      !!--------------------------------------------- 
     612      ! 
     613      IF (before) THEN 
     614         ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2) 
     615      ELSE 
     616         avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2)  
     617      ENDIF 
     618      ! 
     619   END SUBROUTINE updateAVM 
     620 
     621 
     622   SUBROUTINE updateAVMu( ptab, i1, i2, j1, j2, k1, k2, before ) 
     623      !!--------------------------------------------- 
     624      !!           *** ROUTINE updateavmu *** 
     625      !!--------------------------------------------- 
     626      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 
     627      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     628      LOGICAL, INTENT(in) :: before 
     629      !!--------------------------------------------- 
     630      ! 
     631      IF (before) THEN 
     632         ptab  (i1:i2,j1:j2,k1:k2) = avmu_k(i1:i2,j1:j2,k1:k2) 
     633      ELSE 
     634         avmu_k(i1:i2,j1:j2,k1:k2) = ptab  (i1:i2,j1:j2,k1:k2)  
     635      ENDIF 
     636      ! 
     637   END SUBROUTINE updateAVMu 
     638 
     639 
     640   SUBROUTINE updateAVMv( ptab, i1, i2, j1, j2, k1, k2, before ) 
     641      !!--------------------------------------------- 
     642      !!           *** ROUTINE updateavmv *** 
     643      !!--------------------------------------------- 
     644      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 
     645      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     646      LOGICAL, INTENT(in) :: before 
     647      !!--------------------------------------------- 
     648      ! 
     649      IF (before) THEN 
     650         ptab  (i1:i2,j1:j2,k1:k2) = avmv_k(i1:i2,j1:j2,k1:k2) 
     651      ELSE 
     652         avmv_k(i1:i2,j1:j2,k1:k2) = ptab  (i1:i2,j1:j2,k1:k2)  
     653      ENDIF 
     654      ! 
     655   END SUBROUTINE updateAVMv 
     656 
     657# endif /* key_zdftke */  
    556658 
    557659#else 
  • branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/NST_SRC/agrif_top_interp.F90

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

    r3680 r4789  
    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 
     
    1616   PRIVATE 
    1717 
    18    PUBLIC Agrif_Sponge_Trc, interptrn 
     18   PUBLIC Agrif_Sponge_trc, interptrn 
    1919 
    20   !! * Substitutions 
     20   !! * Substitutions 
    2121#  include "domzgr_substitute.h90" 
    2222   !!---------------------------------------------------------------------- 
    23    !! NEMO/NST 3.3 , NEMO Consortium (2010) 
     23   !! NEMO/NST 3.6 , NEMO Consortium (2010) 
    2424   !! $Id$ 
    2525   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    2626   !!---------------------------------------------------------------------- 
    2727 
    28    CONTAINS 
     28CONTAINS 
    2929 
    30    SUBROUTINE Agrif_Sponge_Trc 
     30   SUBROUTINE Agrif_Sponge_trc 
    3131      !!--------------------------------------------- 
    3232      !!   *** ROUTINE Agrif_Sponge_Trc *** 
    3333      !!--------------------------------------------- 
    3434      !!  
    35       INTEGER :: ji,jj,jk,jn 
    3635      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 
    4136 
    4237#if defined SPONGE_TOP 
    43       CALL wrk_alloc( jpi, jpj, ztru, ztrv ) 
    44       CALL wrk_alloc( jpi, jpj, jpk, jptra, ztabr, trbdiff ) 
    45  
    4638      timecoeff = REAL(Agrif_NbStepint(),wp)/Agrif_rhot() 
    47  
     39      CALL Agrif_sponge 
    4840      Agrif_SpecialValue=0. 
    4941      Agrif_UseSpecialValue = .TRUE. 
    50       ztabr = 0.e0 
    51       CALL Agrif_Bc_Variable(ztabr, tra_id,calledweight=timecoeff,procname=interptrn) 
     42      tabspongetrn = .FALSE. 
     43      CALL Agrif_Bc_Variable(trn_sponge_id,calledweight=timecoeff,procname=interptrn_sponge) 
    5244      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 ) 
    8545 
    8646#endif 
     
    8848   END SUBROUTINE Agrif_Sponge_Trc 
    8949 
    90    SUBROUTINE interptrn(tabres,i1,i2,j1,j2,k1,k2,n1,n2) 
     50   SUBROUTINE interptrn_sponge(tabres,i1,i2,j1,j2,k1,k2,n1,n2,before) 
    9151      !!--------------------------------------------- 
    92       !!   *** ROUTINE interptn *** 
     52      !!   *** ROUTINE interptrn_sponge *** 
    9353      !!--------------------------------------------- 
    9454      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
    9555      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 
     56      LOGICAL, INTENT(in) :: before 
     57 
     58 
     59      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
     60 
     61      REAL(wp) :: ztra, zabe1, zabe2, zbtr 
     62      REAL(wp), DIMENSION(i1:i2,j1:j2) :: ztu, ztv 
     63      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2) ::trbdiff 
    9664      ! 
    97       tabres(i1:i2,j1:j2,k1:k2,n1:n2) = trn(i1:i2,j1:j2,k1:k2,n1:n2) 
     65      IF (before) THEN 
     66         tabres(i1:i2,j1:j2,k1:k2,n1:n2) = trn(i1:i2,j1:j2,k1:k2,n1:n2) 
     67      ELSE       
    9868 
    99    END SUBROUTINE interptrn 
     69         trbdiff(:,:,:,:) = trb(i1:i2,j1:j2,:,:) - tabres(:,:,:,:)       
     70         DO jn = 1, jptra 
     71            DO jk = 1, jpkm1 
     72 
     73               DO jj = j1,j2-1 
     74                  DO ji = i1,i2-1 
     75                     zabe1 = umask(ji,jj,jk) * spe1ur(ji,jj) * fse3u(ji,jj,jk) 
     76                     zabe2 = vmask(ji,jj,jk) * spe2vr(ji,jj) * fse3v(ji,jj,jk) 
     77                     ztu(ji,jj) = zabe1 * ( trbdiff(ji+1,jj  ,jk,jn) - trbdiff(ji,jj,jk,jn) ) 
     78                     ztv(ji,jj) = zabe2 * ( trbdiff(ji  ,jj+1,jk,jn) - trbdiff(ji,jj,jk,jn) ) 
     79                  ENDDO 
     80               ENDDO 
     81 
     82               DO jj = j1+1,j2-1 
     83                  DO ji = i1+1,i2-1 
     84 
     85                     IF (.NOT. tabspongedone_trn(ji,jj)) THEN  
     86                        zbtr = spbtr2(ji,jj) / fse3t(ji,jj,jk) 
     87                        ! horizontal diffusive trends 
     88                        ztra = zbtr * (  ztu(ji,jj) - ztu(ji-1,jj  ) + ztv(ji,jj) - ztv(ji  ,jj-1)  ) 
     89                        ! add it to the general tracer trends 
     90                        tra(ji,jj,jk,jn) = tra(ji,jj,jk,jn) + ztra 
     91                     ENDIF 
     92 
     93                  ENDDO 
     94               ENDDO 
     95 
     96            ENDDO 
     97         ENDDO 
     98 
     99         tabspongedone_trn(i1+1:i2-1,j1+1:j2-1) = .TRUE. 
     100      ENDIF 
     101      !                  
     102   END SUBROUTINE interptrn_sponge 
    100103 
    101104#else 
  • branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/NST_SRC/agrif_top_update.F90

    r4491 r4789  
    2424   !!---------------------------------------------------------------------- 
    2525 
    26    CONTAINS 
     26CONTAINS 
    2727 
    2828   SUBROUTINE Agrif_Update_Trc( kt ) 
     
    3030      !!   *** ROUTINE Agrif_Update_Trc *** 
    3131      !!--------------------------------------------- 
    32       !! 
    3332      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  
     33      !!--------------------------------------------- 
     34      !  
     35      IF((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) RETURN 
     36#if defined TWO_WAY    
    4237      Agrif_UseSpecialValueInUpdate = .TRUE. 
    4338      Agrif_SpecialValueFineGrid = 0. 
    44   
    45      IF (MOD(nbcline_trc,nbclineupdate) == 0) THEN 
    46          CALL Agrif_Update_Variable(ztra,trn_id, procname=updateTRC) 
     39      !  
     40      IF (MOD(nbcline_trc,nbclineupdate) == 0) THEN 
     41# if ! defined DECAL_FEEDBACK 
     42         CALL Agrif_Update_Variable(trn_id, procname=updateTRC) 
     43# else 
     44         CALL Agrif_Update_Variable(trn_id, locupdate=(/1,0/),procname=updateTRC) 
     45# endif 
    4746      ELSE 
    48          CALL Agrif_Update_Variable(ztra,trn_id,locupdate=(/0,2/), procname=updateTRC) 
     47# if ! defined DECAL_FEEDBACK 
     48         CALL Agrif_Update_Variable(trn_id,locupdate=(/0,2/), procname=updateTRC) 
     49# else 
     50         CALL Agrif_Update_Variable(trn_id,locupdate=(/1,2/), procname=updateTRC) 
     51# endif 
    4952      ENDIF 
    50  
     53      ! 
    5154      Agrif_UseSpecialValueInUpdate = .FALSE. 
    5255      nbcline_trc = nbcline_trc + 1 
    53  
    54       CALL wrk_dealloc( jpi, jpj, jpk, jptra, ztra ) 
    5556#endif 
    56  
     57      ! 
    5758   END SUBROUTINE Agrif_Update_Trc 
    5859 
    59    SUBROUTINE updateTRC(tabres,i1,i2,j1,j2,k1,k2,n1,n2,before) 
     60   SUBROUTINE updateTRC( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before ) 
    6061      !!--------------------------------------------- 
    61       !!   *** ROUTINE UpdateTrc *** 
     62      !!           *** ROUTINE updateT *** 
    6263      !!--------------------------------------------- 
     64#  include "domzgr_substitute.h90" 
    6365      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 
     66      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab 
    6567      LOGICAL, INTENT(in) :: before 
    66     
     68      !! 
    6769      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 
     70      !!--------------------------------------------- 
     71      ! 
     72      IF (before) THEN 
     73         DO jn = n1,n2 
     74            DO jk=k1,k2 
     75               DO jj=j1,j2 
     76                  DO ji=i1,i2 
     77                     ptab(ji,jj,jk,jn) = trn(ji,jj,jk,jn) 
     78                  END DO 
     79               END DO 
     80            END DO 
     81         END DO 
     82      ELSE 
     83         IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 
    8184            ! 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) 
     85            DO jn = n1,n2 
     86               DO jk=k1,k2 
     87                  DO jj=j1,j2 
     88                     DO ji=i1,i2 
     89                        IF( ptab(ji,jj,jk,jn) .NE. 0. ) THEN 
     90                           trb(ji,jj,jk,jn) = trb(ji,jj,jk,jn) &  
     91                                 & + atfp * ( ptab(ji,jj,jk,jn) & 
     92                                 &             - trn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 
    10393                        ENDIF 
    10494                     ENDDO 
     
    10797            ENDDO 
    10898         ENDIF 
    109  
     99         DO jn = n1,n2 
     100            DO jk=k1,k2 
     101               DO jj=j1,j2 
     102                  DO ji=i1,i2 
     103                     IF( ptab(ji,jj,jk,jn) .NE. 0. ) THEN  
     104                        trn(ji,jj,jk,jn) = ptab(ji,jj,jk,jn) * tmask(ji,jj,jk) 
     105                     END IF 
     106                  END DO 
     107               END DO 
     108            END DO 
     109         END DO 
     110      ENDIF 
     111      !  
    110112   END SUBROUTINE updateTRC 
    111113 
     
    119121   END SUBROUTINE agrif_top_update_empty 
    120122#endif 
    121 END Module agrif_top_update 
     123END MODULE agrif_top_update 
  • branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/NST_SRC/agrif_user.F90

    r4785 r4789  
    6464   ! 0. Initializations 
    6565   !------------------- 
    66    IF( cp_cfg == 'orca' ) then 
     66   IF( cp_cfg == 'orca' ) THEN 
    6767      IF ( jp_cfg == 2 .OR. jp_cfg == 025 .OR. jp_cfg == 05 & 
    68   &                      .OR. jp_cfg == 4 ) THEN 
     68            &                      .OR. jp_cfg == 4 ) THEN 
    6969         jp_cfg = -1    ! set special value for jp_cfg on fine grids 
    7070         cp_cfg = "default" 
     
    120120SUBROUTINE agrif_declare_var_dom 
    121121   !!---------------------------------------------------------------------- 
    122    !!                 *** ROUTINE agrif_declarE_var *** 
     122   !!                 *** ROUTINE agrif_declare_var *** 
    123123   !! 
    124124   !! ** Purpose :: Declaration of variables to be interpolated 
     
    137137   ! 2. Type of interpolation 
    138138   !------------------------- 
    139    Call Agrif_Set_bcinterp(e1u_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    140    Call Agrif_Set_bcinterp(e2v_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     139   CALL Agrif_Set_bcinterp(e1u_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
     140   CALL Agrif_Set_bcinterp(e2v_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
    141141 
    142142   ! 3. Location of interpolation 
    143143   !----------------------------- 
    144    Call Agrif_Set_bc(e1u_id,(/0,0/)) 
    145    Call Agrif_Set_bc(e2v_id,(/0,0/)) 
     144   CALL Agrif_Set_bc(e1u_id,(/0,0/)) 
     145   CALL Agrif_Set_bc(e2v_id,(/0,0/)) 
    146146 
    147147   ! 5. Update type 
    148148   !---------------  
    149    Call Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Copy, update2=Agrif_Update_Average) 
    150    Call Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Average, update2=Agrif_Update_Copy) 
     149   CALL Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Copy, update2=Agrif_Update_Average) 
     150   CALL Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Average, update2=Agrif_Update_Copy) 
    151151 
    152152END SUBROUTINE agrif_declare_var_dom 
     
    188188   CALL Agrif_Bc_variable(tsn_id,calledweight=1.,procname=interptsn) 
    189189   CALL Agrif_Sponge 
    190    tabspongedone = .FALSE. 
     190   tabspongedone_tsn = .FALSE. 
    191191   CALL Agrif_Bc_variable(tsn_sponge_id,calledweight=1.,procname=interptsn_sponge) 
    192192   ! reset tsa to zero 
     
    222222   ! 3. Some controls 
    223223   !----------------- 
    224    check_namelist = .true. 
     224   check_namelist = .TRUE. 
    225225 
    226226   IF( check_namelist ) THEN  
    227227 
    228228      ! Check time steps            
    229       IF( nint(Agrif_Rhot()) * nint(rdt) .ne. Agrif_Parent(rdt) ) THEN 
    230          write(cl_check1,*)  nint(Agrif_Parent(rdt)) 
    231          write(cl_check2,*)  nint(rdt) 
    232          write(cl_check3,*)  nint(Agrif_Parent(rdt)/Agrif_Rhot()) 
     229      IF( NINT(Agrif_Rhot()) * NINT(rdt) .NE. Agrif_Parent(rdt) ) THEN 
     230         WRITE(cl_check1,*)  NINT(Agrif_Parent(rdt)) 
     231         WRITE(cl_check2,*)  NINT(rdt) 
     232         WRITE(cl_check3,*)  NINT(Agrif_Parent(rdt)/Agrif_Rhot()) 
    233233         CALL ctl_warn( 'incompatible time step between grids',   & 
    234          &               'parent grid value : '//cl_check1    ,   &  
    235          &               'child  grid value : '//cl_check2    ,   &  
    236          &               'value on child grid will be changed to : '//cl_check3 ) 
     234               &               'parent grid value : '//cl_check1    ,   &  
     235               &               'child  grid value : '//cl_check2    ,   &  
     236               &               'value on child grid will be changed to : '//cl_check3 ) 
    237237         rdt=Agrif_Parent(rdt)/Agrif_Rhot() 
    238238      ENDIF 
     
    240240      ! Check run length 
    241241      IF( Agrif_IRhot() * (Agrif_Parent(nitend)- & 
    242            Agrif_Parent(nit000)+1) .ne. (nitend-nit000+1) ) THEN 
    243          write(cl_check1,*)  (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 
    244          write(cl_check2,*)   Agrif_Parent(nitend)   *Agrif_IRhot() 
     242            Agrif_Parent(nit000)+1) .NE. (nitend-nit000+1) ) THEN 
     243         WRITE(cl_check1,*)  (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 
     244         WRITE(cl_check2,*)   Agrif_Parent(nitend)   *Agrif_IRhot() 
    245245         CALL ctl_warn( 'incompatible run length between grids'               ,   & 
    246          &              ' nit000 on fine grid will be change to : '//cl_check1,   & 
    247          &              ' nitend on fine grid will be change to : '//cl_check2    ) 
     246               &              ' nit000 on fine grid will be change to : '//cl_check1,   & 
     247               &              ' nitend on fine grid will be change to : '//cl_check2    ) 
    248248         nit000 = (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 
    249249         nitend =  Agrif_Parent(nitend)   *Agrif_IRhot() 
     
    253253      IF( ln_zps ) THEN 
    254254         ! check parameters for partial steps  
    255          IF( Agrif_Parent(e3zps_min) .ne. e3zps_min ) THEN 
     255         IF( Agrif_Parent(e3zps_min) .NE. e3zps_min ) THEN 
    256256            WRITE(*,*) 'incompatible e3zps_min between grids' 
    257257            WRITE(*,*) 'parent grid :',Agrif_Parent(e3zps_min) 
     
    268268         ENDIF 
    269269      ENDIF 
     270      ! check if the bathy metry match 
     271      IF(ln_chk_bathy) CALL Agrif_Bc_variable(e3t_id,calledweight=1.,procname=interpe3t) 
     272      ! 
    270273   ENDIF 
    271274   !  
    272275   CALL Agrif_Update_tra(0) 
    273276   CALL Agrif_Update_dyn(0) 
     277# if defined key_zdftke 
     278   IF( ln_agrif_tke ) THEN 
     279   CALL Agrif_Update_tke(0) 
     280   ENDIF     
     281# endif 
    274282   ! 
    275283   Agrif_UseSpecialValueInUpdate = .FALSE. 
     
    304312 
    305313   CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),e3t_id) 
    306   
     314 
    307315   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) 
    308316 
     
    316324   CALL agrif_declare_variable((/2,2/),(/3,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),sshn_id) 
    317325 
     326# if defined key_zdftke 
     327   CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avt_id) 
     328   CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avm_id) 
     329   CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avmu_id) 
     330   CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avmv_id) 
     331# endif 
    318332 
    319333   ! 2. Type of interpolation 
    320334   !------------------------- 
    321335   CALL Agrif_Set_bcinterp(tsn_id,interp=AGRIF_linear) 
    322   
     336 
    323337   CALL Agrif_Set_bcinterp(un_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    324338   CALL Agrif_Set_bcinterp(vn_interp_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
    325   
     339 
    326340   CALL Agrif_Set_bcinterp(tsn_sponge_id,interp=AGRIF_linear) 
    327341 
     
    335349   CALL Agrif_Set_bcinterp(un_sponge_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    336350   CALL Agrif_Set_bcinterp(vn_sponge_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
    337   
     351 
    338352   CALL Agrif_Set_bcinterp(e3t_id,interp=AGRIF_constant) 
    339   
     353 
     354# if defined key_zdftke 
     355   CALL Agrif_Set_bcinterp(avt_id ,interp=AGRIF_linear) 
     356   CALL Agrif_Set_bcinterp(avm_id ,interp=AGRIF_linear) 
     357   CALL Agrif_Set_bcinterp(avmu_id,interp=AGRIF_linear) 
     358   CALL Agrif_Set_bcinterp(avmv_id,interp=AGRIF_linear) 
     359# endif 
     360 
    340361 
    341362   ! 3. Location of interpolation 
     
    352373   CALL Agrif_Set_bc(unb_id ,(/0,0/)) 
    353374   CALL Agrif_Set_bc(vnb_id ,(/0,0/)) 
    354    Call Agrif_Set_bc(ub2b_interp_id,(/0,0/)) 
    355    Call Agrif_Set_bc(vb2b_interp_id,(/0,0/)) 
     375   CALL Agrif_Set_bc(ub2b_interp_id,(/0,0/)) 
     376   CALL Agrif_Set_bc(vb2b_interp_id,(/0,0/)) 
    356377 
    357378   CALL Agrif_Set_bc(e3t_id,(/-3*Agrif_irhox(),0/))   ! if west and rhox=3: column 2 to 11 
     379 
     380# if defined key_zdftke 
     381   CALL Agrif_Set_bc(avt_id ,(/0,1/)) 
     382   CALL Agrif_Set_bc(avm_id ,(/0,1/)) 
     383   CALL Agrif_Set_bc(avmu_id,(/0,1/)) 
     384   CALL Agrif_Set_bc(avmv_id,(/0,1/)) 
     385# endif 
    358386 
    359387   ! 5. Update type 
     
    367395   CALL Agrif_Set_Updatetype(sshn_id, update = AGRIF_Update_Average) 
    368396 
    369    Call Agrif_Set_Updatetype(ub2b_update_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 
    370    Call Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 
    371  
     397   CALL Agrif_Set_Updatetype(ub2b_update_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 
     398   CALL Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 
     399 
     400# if defined key_zdftke 
     401   CALL Agrif_Set_Updatetype(avt_id, update = AGRIF_Update_Average) 
     402   CALL Agrif_Set_Updatetype(avm_id, update = AGRIF_Update_Average) 
     403   CALL Agrif_Set_Updatetype(avmu_id, update = AGRIF_Update_Average) 
     404   CALL Agrif_Set_Updatetype(avmv_id, update = AGRIF_Update_Average) 
     405# endif 
    372406   ! 
    373407END SUBROUTINE agrif_declare_var 
     
    457491   !------------------------- 
    458492   CALL Agrif_Set_bcinterp(adv_ice_id ,interp=AGRIF_linear) 
    459    Call Agrif_Set_bcinterp(u_ice_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    460    Call Agrif_Set_bcinterp(v_ice_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     493   CALL Agrif_Set_bcinterp(u_ice_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
     494   CALL Agrif_Set_bcinterp(v_ice_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
    461495 
    462496   ! 3. Location of interpolation 
    463497   !----------------------------- 
    464    Call Agrif_Set_bc(adv_ice_id ,(/0,1/)) 
    465    Call Agrif_Set_bc(u_ice_id,(/0,1/)) 
    466    Call Agrif_Set_bc(v_ice_id,(/0,1/)) 
     498   CALL Agrif_Set_bc(adv_ice_id ,(/0,1/)) 
     499   CALL Agrif_Set_bc(u_ice_id,(/0,1/)) 
     500   CALL Agrif_Set_bc(v_ice_id,(/0,1/)) 
    467501 
    468502   ! 5. Update type 
    469503   !--------------- 
    470    Call Agrif_Set_Updatetype(adv_ice_id , update = AGRIF_Update_Average) 
    471    Call Agrif_Set_Updatetype(u_ice_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 
    472    Call Agrif_Set_Updatetype(v_ice_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 
     504   CALL Agrif_Set_Updatetype(adv_ice_id , update = AGRIF_Update_Average) 
     505   CALL Agrif_Set_Updatetype(u_ice_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 
     506   CALL Agrif_Set_Updatetype(v_ice_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 
    473507 
    474508END SUBROUTINE agrif_declare_var_lim2 
     
    497531   IMPLICIT NONE 
    498532   ! 
    499    REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: tabtrtemp 
    500533   CHARACTER(len=10) :: cl_check1, cl_check2, cl_check3 
    501534   LOGICAL :: check_namelist 
    502535   !!---------------------------------------------------------------------- 
    503  
    504    ALLOCATE( tabtrtemp(jpi,jpj,jpk,jptra) ) 
    505536 
    506537 
     
    513544   Agrif_SpecialValue=0. 
    514545   Agrif_UseSpecialValue = .TRUE. 
    515    Call Agrif_Bc_variable(tabtrtemp,trn_id,calledweight=1.,procname=interptrn) 
    516    Call Agrif_Bc_variable(tabtrtemp,tra_id,calledweight=1.,procname=interptrn) 
     546   CALL Agrif_Bc_variable(trn_id,calledweight=1.,procname=interptrn) 
    517547   Agrif_UseSpecialValue = .FALSE. 
     548   CALL Agrif_Sponge 
     549   tabspongedone_trn = .FALSE. 
     550   CALL Agrif_Bc_variable(trn_sponge_id,calledweight=1.,procname=interptrn_sponge) 
     551   ! reset tsa to zero 
     552   tra(:,:,:,:) = 0. 
     553 
    518554 
    519555   ! 3. Some controls 
    520556   !----------------- 
    521    check_namelist = .true. 
     557   check_namelist = .TRUE. 
    522558 
    523559   IF( check_namelist ) THEN 
    524560# if defined key_offline 
    525561      ! Check time steps 
    526       IF( nint(Agrif_Rhot()) * nint(rdt) .ne. Agrif_Parent(rdt) ) THEN 
    527          write(cl_check1,*)  Agrif_Parent(rdt) 
    528          write(cl_check2,*)  rdt 
    529          write(cl_check3,*)  rdt*Agrif_Rhot() 
     562      IF( NINT(Agrif_Rhot()) * NINT(rdt) .NE. Agrif_Parent(rdt) ) THEN 
     563         WRITE(cl_check1,*)  Agrif_Parent(rdt) 
     564         WRITE(cl_check2,*)  rdt 
     565         WRITE(cl_check3,*)  rdt*Agrif_Rhot() 
    530566         CALL ctl_warn( 'incompatible time step between grids',   & 
    531          &               'parent grid value : '//cl_check1    ,   &  
    532          &               'child  grid value : '//cl_check2    ,   &  
    533          &               'value on child grid will be changed to  & 
    534          &               :'//cl_check3  ) 
     567               &               'parent grid value : '//cl_check1    ,   &  
     568               &               'child  grid value : '//cl_check2    ,   &  
     569               &               'value on child grid will be changed to  & 
     570               &               :'//cl_check3  ) 
    535571         rdt=rdt*Agrif_Rhot() 
    536572      ENDIF 
     
    538574      ! Check run length 
    539575      IF( Agrif_IRhot() * (Agrif_Parent(nitend)- & 
    540            Agrif_Parent(nit000)+1) .ne. (nitend-nit000+1) ) THEN 
    541          WRITE(*,*) 'incompatible run length between grids' 
    542          WRITE(*,*) 'parent grid value : ',(Agrif_Parent(nitend)- & 
    543               Agrif_Parent(nit000)+1),' time step' 
    544          WRITE(*,*) 'child  grid value : ', & 
    545               (nitend-nit000+1),' time step' 
    546          WRITE(*,*) 'value on child grid should be : ', & 
    547               Agrif_IRhot() * (Agrif_Parent(nitend)- & 
    548               Agrif_Parent(nit000)+1) 
    549          CALL ctl_warn( 'incompatible run length between grids',   & 
    550          &              'value on child grid will be change to '  & 
    551          &             ) 
    552  
    553  
     576            Agrif_Parent(nit000)+1) .NE. (nitend-nit000+1) ) THEN 
     577         WRITE(cl_check1,*)  (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 
     578         WRITE(cl_check2,*)   Agrif_Parent(nitend)   *Agrif_IRhot() 
     579         CALL ctl_warn( 'incompatible run length between grids'               ,   & 
     580               &              ' nit000 on fine grid will be change to : '//cl_check1,   & 
     581               &              ' nitend on fine grid will be change to : '//cl_check2    ) 
     582         nit000 = (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 
     583         nitend =  Agrif_Parent(nitend)   *Agrif_IRhot() 
    554584      ENDIF 
    555585 
     
    557587      IF( ln_zps ) THEN 
    558588         ! check parameters for partial steps  
    559          IF( Agrif_Parent(e3zps_min) .ne. e3zps_min ) THEN 
     589         IF( Agrif_Parent(e3zps_min) .NE. e3zps_min ) THEN 
    560590            WRITE(*,*) 'incompatible e3zps_min between grids' 
    561591            WRITE(*,*) 'parent grid :',Agrif_Parent(e3zps_min) 
     
    564594            STOP 
    565595         ENDIF 
    566          IF( Agrif_Parent(e3zps_rat) .ne. e3zps_rat ) THEN 
     596         IF( Agrif_Parent(e3zps_rat) .NE. e3zps_rat ) THEN 
    567597            WRITE(*,*) 'incompatible e3zps_rat between grids' 
    568598            WRITE(*,*) 'parent grid :',Agrif_Parent(e3zps_rat) 
     
    574604#  endif          
    575605      ! Check passive tracer cell 
    576       IF( nn_dttrc .ne. 1 ) THEN 
     606      IF( nn_dttrc .NE. 1 ) THEN 
    577607         WRITE(*,*) 'nn_dttrc should be equal to 1' 
    578608      ENDIF 
    579609   ENDIF 
    580610 
    581 !ch   CALL Agrif_Update_trc(0) 
     611   CALL Agrif_Update_trc(0) 
     612   ! 
     613   Agrif_UseSpecialValueInUpdate = .FALSE. 
    582614   nbcline_trc = 0 
    583615   ! 
     
    601633   ! 1. Declaration of the type of variable which have to be interpolated 
    602634   !--------------------------------------------------------------------- 
    603    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) 
    604    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) 
    605    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) 
     635   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) 
     636   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) 
    606637 
    607638   ! 2. Type of interpolation 
    608639   !------------------------- 
    609640   CALL Agrif_Set_bcinterp(trn_id,interp=AGRIF_linear) 
    610    CALL Agrif_Set_bcinterp(tra_id,interp=AGRIF_linear) 
     641   CALL Agrif_Set_bcinterp(trn_sponge_id,interp=AGRIF_linear) 
    611642 
    612643   ! 3. Location of interpolation 
    613644   !----------------------------- 
    614    Call Agrif_Set_bc(trn_id,(/0,1/)) 
    615    Call Agrif_Set_bc(tra_id,(/-3*Agrif_irhox(),0/)) 
     645   CALL Agrif_Set_bc(trn_id,(/0,1/)) 
     646   CALL Agrif_Set_bc(trn_sponge_id,(/-3*Agrif_irhox(),0/)) 
    616647 
    617648   ! 5. Update type 
    618649   !---------------  
    619    Call Agrif_Set_Updatetype(trn_id, update = AGRIF_Update_Average) 
    620    Call Agrif_Set_Updatetype(trb_id, update = AGRIF_Update_Average) 
    621  
    622  
     650   CALL Agrif_Set_Updatetype(trn_id, update = AGRIF_Update_Average) 
     651   ! 
    623652END SUBROUTINE agrif_declare_var_top 
    624653# endif 
     
    650679   ! 
    651680   INTEGER  ::   ios                 ! Local integer output status for namelist read 
    652    NAMELIST/namagrif/ nn_cln_update, rn_sponge_tra, rn_sponge_dyn, ln_spc_dyn 
    653    !!---------------------------------------------------------------------- 
    654    ! 
    655       REWIND( numnam_ref )              ! Namelist namagrif in reference namelist : AGRIF zoom 
    656       READ  ( numnam_ref, namagrif, IOSTAT = ios, ERR = 901) 
    657 901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namagrif in reference namelist', lwp ) 
    658  
    659       REWIND( numnam_cfg )              ! Namelist namagrif in configuration namelist : AGRIF zoom 
    660       READ  ( numnam_cfg, namagrif, IOSTAT = ios, ERR = 902 ) 
    661 902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namagrif in configuration namelist', lwp ) 
    662       IF(lwm) WRITE ( numond, namagrif ) 
     681   NAMELIST/namagrif/ nn_cln_update, rn_sponge_tra, rn_sponge_dyn, ln_spc_dyn, ln_chk_bathy,   & 
     682                 &    ln_agrif_tke 
     683   !!-------------------------------------------------------------------------------------- 
     684   ! 
     685   REWIND( numnam_ref )              ! Namelist namagrif in reference namelist : AGRIF zoom 
     686   READ  ( numnam_ref, namagrif, IOSTAT = ios, ERR = 901) 
     687901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namagrif in reference namelist', lwp ) 
     688 
     689   REWIND( numnam_cfg )              ! Namelist namagrif in configuration namelist : AGRIF zoom 
     690   READ  ( numnam_cfg, namagrif, IOSTAT = ios, ERR = 902 ) 
     691902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namagrif in configuration namelist', lwp ) 
     692   IF(lwm) WRITE ( numond, namagrif ) 
    663693   ! 
    664694   IF(lwp) THEN                    ! control print 
     
    671701      WRITE(numout,*) '      sponge coefficient for dynamics   rn_sponge_tra = ', rn_sponge_dyn, ' s' 
    672702      WRITE(numout,*) '      use special values for dynamics   ln_spc_dyn    = ', ln_spc_dyn 
     703      WRITE(numout,*) '      check bathymetry                  ln_chk_bathy  = ', ln_chk_bathy 
     704      WRITE(numout,*) '      use TKE interpolation/update      ln_agrif_tke  = ', ln_agrif_tke 
    673705      WRITE(numout,*)  
    674706   ENDIF 
     
    702734   CASE(2)   ;   indglob = indloc + njmppt(nprocloc+1) - 1 
    703735   CASE DEFAULT 
    704                  indglob = indloc 
     736      indglob = indloc 
    705737   END SELECT 
    706738   ! 
     
    742774END SUBROUTINE Agrif_estimate_parallel_cost 
    743775 
    744  
    745776# endif 
    746777 
  • branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/OPA_SRC/ZDF/zdf_oce.F90

    r4147 r4789  
    4242   REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::   avmu , avmv    !: vertical viscosity coef at uw- & vw-pts       [m2/s] 
    4343   REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::   avm  , avt     !: vertical viscosity & diffusivity coef at w-pt [m2/s] 
    44   
     44   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avt_k , avm_k  ! not enhanced Kz 
     45   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avmu_k, avmv_k ! not enhanced Kz 
     46 
    4547   !!---------------------------------------------------------------------- 
    4648   !! NEMO/OPA 4.0 , NEMO Consortium (2011) 
     
    5759      ALLOCATE(avmb(jpk) , bfrua(jpi,jpj) ,                         & 
    5860         &     avtb(jpk) , bfrva(jpi,jpj) , avtb_2d(jpi,jpj) ,      & 
    59          &     avmu(jpi,jpj,jpk), avm(jpi,jpj,jpk)           ,      & 
    60          &     avmv(jpi,jpj,jpk), avt(jpi,jpj,jpk)           , STAT = zdf_oce_alloc ) 
     61         &     avmu  (jpi,jpj,jpk), avm   (jpi,jpj,jpk),            & 
     62         &     avmv  (jpi,jpj,jpk), avt   (jpi,jpj,jpk),            & 
     63         &     avt_k (jpi,jpj,jpk), avm_k (jpi,jpj,jpk),            &  
     64         &     avmu_k(jpi,jpj,jpk), avmv_k(jpi,jpj,jpk), STAT = zdf_oce_alloc ) 
    6165         ! 
    6266      IF( zdf_oce_alloc /= 0 )   CALL ctl_warn('zdf_oce_alloc: failed to allocate arrays') 
  • branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfgls.F90

    r4624 r4789  
    4444   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   mxln    !: now mixing length 
    4545   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   zwall   !: wall function 
    46    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avt_k   ! not enhanced Kz 
    47    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avm_k   ! not enhanced Kz 
    48    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avmu_k  ! not enhanced Kz 
    49    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avmv_k  ! not enhanced Kz 
    5046   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ustars2 !: Squared surface velocity scale at T-points 
    5147   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ustarb2 !: Squared bottom  velocity scale at T-points 
     
    123119      !!---------------------------------------------------------------------- 
    124120      ALLOCATE( en(jpi,jpj,jpk),  mxln(jpi,jpj,jpk), zwall(jpi,jpj,jpk) ,     & 
    125          &      avt_k (jpi,jpj,jpk) , avm_k (jpi,jpj,jpk),                    & 
    126          &      avmu_k(jpi,jpj,jpk) , avmv_k(jpi,jpj,jpk),                    & 
    127121         &      ustars2(jpi,jpj), ustarb2(jpi,jpj)                      , STAT= zdf_gls_alloc ) 
    128122         ! 
  • branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftke.F90

    r4785 r4789  
    5252   USE timing         ! Timing 
    5353   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)   
     54#if defined key_agrif 
     55   USE agrif_opa_interp 
     56   USE agrif_opa_update 
     57#endif 
    5458 
    5559   IMPLICIT NONE 
     
    8791   REAL(wp)        , ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   htau           ! depth of tke penetration (nn_htau) 
    8892   REAL(wp)        , ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   dissl          ! now mixing lenght of dissipation 
    89    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avt_k , avm_k  ! not enhanced Kz 
    90    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avmu_k, avmv_k ! not enhanced Kz 
    9193#if defined key_c1d 
    9294   !                                                                        !!** 1D cfg only  **   ('key_c1d') 
     
    9496   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e_pdl, e_ric   !: prandl and local Richardson numbers 
    9597#endif 
     98   REAL(wp)        , ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   wei3d          !  
     99   REAL(wp)        , ALLOCATABLE, SAVE, DIMENSION(:,:  ) ::   wmix           !  
    96100 
    97101   !! * Substitutions 
     
    114118         &      e_pdl(jpi,jpj,jpk) , e_ric(jpi,jpj,jpk) ,                          & 
    115119#endif 
    116          &      en    (jpi,jpj,jpk) , htau  (jpi,jpj)    , dissl(jpi,jpj,jpk) ,     &  
    117          &      avt_k (jpi,jpj,jpk) , avm_k (jpi,jpj,jpk),                          & 
    118          &      avmu_k(jpi,jpj,jpk) , avmv_k(jpi,jpj,jpk), STAT= zdf_tke_alloc      ) 
     120         &      en    (jpi,jpj,jpk) , htau  (jpi,jpj)    , dissl(jpi,jpj,jpk) ,    &  
     121         &      STAT= zdf_tke_alloc      ) 
    119122         ! 
    120123      IF( lk_mpp             )   CALL mpp_sum ( zdf_tke_alloc ) 
    121124      IF( zdf_tke_alloc /= 0 )   CALL ctl_warn('zdf_tke_alloc: failed to allocate arrays') 
     125      ! 
     126      IF(.NOT. Agrif_Root()) THEN 
     127         ALLOCATE( wei3d(jpi,jpj,jpk), wmix(jpi,jpj), STAT= zdf_tke_alloc ) 
     128         IF( lk_mpp             )   CALL mpp_sum ( zdf_tke_alloc ) 
     129         IF( zdf_tke_alloc /= 0 )   CALL ctl_warn('zdf_tke_alloc2: failed to allocate arrays') 
     130      ENDIF 
    122131      ! 
    123132   END FUNCTION zdf_tke_alloc 
     
    173182      ! 
    174183      IF( kt /= nit000 ) THEN   ! restore before value to compute tke 
     184#if defined key_agrif  
     185         ! interpolation parent grid => child grid for avt_k, avm_k, avmu_k, avmv_k  
     186         !( ex : at west border: update column 1 and 2) 
     187         IF(ln_agrif_tke) CALL Agrif_Tke    
     188#endif 
    175189         avt (:,:,:) = avt_k (:,:,:)  
    176190         avm (:,:,:) = avm_k (:,:,:)  
     
    188202      avmv_k(:,:,:) = avmv(:,:,:)  
    189203      ! 
    190    END SUBROUTINE zdf_tke 
     204#if defined key_agrif 
     205      ! Update child grid f => parent grid  
     206      IF( .NOT.Agrif_Root() .AND. ln_agrif_tke)    CALL Agrif_Update_Tke( kt )      ! children only 
     207#endif       
     208     !  
     209  END SUBROUTINE zdf_tke 
    191210 
    192211 
     
    341360         END DO 
    342361      END DO 
    343       ! 
    344       IF( .NOT. AGRIF_Root() ) THEN 
    345          DO jk = 1, jpkm1 
    346             IF ((nbondi ==  1).OR.(nbondi == 2)) avmu(nlci-1 , :     ,jk) = avmu(nlci-2 , :     ,jk)     !   east 
    347             IF ((nbondi == -1).OR.(nbondi == 2)) avmu(1      , :     ,jk) = avmu(2      , :     ,jk)     !   west 
    348             IF ((nbondj ==  1).OR.(nbondj == 2)) avmv(:      ,nlcj-1 ,jk) = avmv(:      ,nlcj-2 ,jk)     !   north 
    349             IF ((nbondj == -1).OR.(nbondj == 2)) avmv(:      ,1      ,jk) = avmv(:      ,2      ,jk)     !   south 
    350          END DO 
    351       ENDIF 
    352362      ! 
    353363      DO jk = 2, jpkm1           !* Matrix and right hand side in en 
     
    501511      REAL(wp) ::   zdku, zpdlr, zri, zsqen     !   -      - 
    502512      REAL(wp) ::   zdkv, zemxl, zemlm, zemlp   !   -      - 
     513      REAL(wp), POINTER, DIMENSION(:,:  ) :: ztmp2d 
    503514      REAL(wp), POINTER, DIMENSION(:,:,:) :: zmpdl, zmxlm, zmxld 
    504515      !!-------------------------------------------------------------------- 
     
    506517      IF( nn_timing == 1 )  CALL timing_start('tke_avn') 
    507518 
     519      CALL wrk_alloc( jpi,jpj, ztmp2d )  
    508520      CALL wrk_alloc( jpi,jpj,jpk, zmpdl, zmxlm, zmxld )  
    509521 
     
    636648      END DO 
    637649      CALL lbc_lnk( avm, 'W', 1. )      ! Lateral boundary conditions (sign unchanged) 
     650      ! 
     651# if defined key_agrif 
     652      IF( .NOT. AGRIF_Root() ) THEN 
     653         IF( ln_agrif_tke ) THEN 
     654            DO jk = 1, jpkm1 
     655               DO jj = 2, jpjm1 
     656                  DO ji = 2, jpim1 
     657                     ztmp2d(ji,jj) = 1. * avm(ji-1,jj-1,jk) * tmask(ji-1,jj-1,jk)   & 
     658                           &          + 2. * avm(ji  ,jj-1,jk) * tmask(ji  ,jj-1,jk)   & 
     659                           &          + 1. * avm(ji+1,jj-1,jk) * tmask(ji+1,jj-1,jk)   & 
     660                           &          + 2. * avm(ji-1,jj  ,jk) * tmask(ji-1,jj  ,jk)   & 
     661                           &          + 4. * avm(ji  ,jj  ,jk) * tmask(ji  ,jj  ,jk)   & 
     662                           &          + 2. * avm(ji+1,jj  ,jk) * tmask(ji+1,jj  ,jk)   & 
     663                           &          + 1. * avm(ji-1,jj+1,jk) * tmask(ji-1,jj+1,jk)   & 
     664                           &          + 2. * avm(ji  ,jj+1,jk) * tmask(ji  ,jj+1,jk)   & 
     665                           &          + 1. * avm(ji+1,jj+1,jk) * tmask(ji+1,jj+1,jk) 
     666                  END DO 
     667               END DO 
     668               DO jj = 2, jpjm1 
     669                  DO ji = 2, jpim1 
     670                     avm(ji,jj,jk) = ztmp2d(ji,jj) * wei3d(ji,jj,jk) * wmix(ji,jj) + avm(ji,jj,jk) * ( 1. - wmix(ji,jj) ) 
     671                  END DO 
     672               END DO 
     673            END DO 
     674            CALL lbc_lnk( avm, 'W', 1. )      ! Lateral boundary conditions (sign unchanged) 
     675            DO jk = 1, jpkm1 
     676               DO jj = 2, jpjm1 
     677                  DO ji = 2, jpim1 
     678                     ztmp2d(ji,jj) = 1. * avt(ji-1,jj-1,jk) * tmask(ji-1,jj-1,jk)   & 
     679                           &          + 2. * avt(ji  ,jj-1,jk) * tmask(ji  ,jj-1,jk)   & 
     680                           &          + 1. * avt(ji+1,jj-1,jk) * tmask(ji+1,jj-1,jk)   & 
     681                           &          + 2. * avt(ji-1,jj  ,jk) * tmask(ji-1,jj  ,jk)   & 
     682                           &          + 4. * avt(ji  ,jj  ,jk) * tmask(ji  ,jj  ,jk)   & 
     683                           &          + 2. * avt(ji+1,jj  ,jk) * tmask(ji+1,jj  ,jk)   & 
     684                           &          + 1. * avt(ji-1,jj+1,jk) * tmask(ji-1,jj+1,jk)   & 
     685                           &          + 2. * avt(ji  ,jj+1,jk) * tmask(ji  ,jj+1,jk)   & 
     686                           &          + 1. * avt(ji+1,jj+1,jk) * tmask(ji+1,jj+1,jk) 
     687                  END DO 
     688               END DO 
     689               DO jj = 2, jpjm1 
     690                  DO ji = 2, jpim1 
     691                     avt(ji,jj,jk) = ztmp2d(ji,jj) * wei3d(ji,jj,jk) * wmix(ji,jj) + avt(ji,jj,jk) * ( 1. - wmix(ji,jj) ) 
     692                  END DO 
     693               END DO 
     694            END DO 
     695            CALL lbc_lnk( avt, 'W', 1. )      ! Lateral boundary conditions (sign unchanged) 
     696         ELSE    
     697            DO jk = 1, jpkm1 
     698               IF ((nbondi ==  1).OR.(nbondi == 2)) avmu(nlci-1 , :     ,jk) = avmu(nlci-2 , :     ,jk)     !   east 
     699               IF ((nbondi == -1).OR.(nbondi == 2)) avmu(1      , :     ,jk) = avmu(2      , :     ,jk)     !   west 
     700               IF ((nbondj ==  1).OR.(nbondj == 2)) avmv(:      ,nlcj-1 ,jk) = avmv(:      ,nlcj-2 ,jk)     !   north 
     701               IF ((nbondj == -1).OR.(nbondj == 2)) avmv(:      ,1      ,jk) = avmv(:      ,2      ,jk)     !   south 
     702            END DO 
     703         ENDIF 
     704      ENDIF 
     705# endif /* key_Agrif */ 
    638706      ! 
    639707      DO jk = 2, jpkm1            !* vertical eddy viscosity at u- and v-points 
     
    679747      ENDIF 
    680748      ! 
     749      CALL wrk_dealloc( jpi,jpj, ztmp2d )  
    681750      CALL wrk_dealloc( jpi,jpj,jpk, zmpdl, zmxlm, zmxld )  
    682751      ! 
Note: See TracChangeset for help on using the changeset viewer.