New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
Changeset 5948 for branches/2014/dev_r4650_UKMO12_CFL_diags_take2/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90 – NEMO

Ignore:
Timestamp:
2015-11-30T11:47:24+01:00 (8 years ago)
Author:
timgraham
Message:

Merged in head of trunk (r5936)

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/2014/dev_r4650_UKMO12_CFL_diags_take2/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90

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