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

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

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

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

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/2015/dev_r5072_UKMO2_OBS_simplification/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90

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