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 10251 for branches/UKMO/dev_r5518_AMM15_package/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90 – NEMO

Ignore:
Timestamp:
2018-10-29T15:20:26+01:00 (5 years ago)
Author:
kingr
Message:

Rolled back to r10247 - i.e., undid merge of pkg br and 3.6_stable br

File:
1 edited

Legend:

Unmodified
Added
Removed

  • branches/UKMO/dev_r5518_AMM15_package/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90

    r10248 r10251  
    1 #define TWO_WAY        /* TWO WAY NESTING */ 
    2 #undef DECAL_FEEDBACK /* SEPARATION of INTERFACES*/ 
    3   
     1#define TWO_WAY 
     2 
    43MODULE agrif_opa_update 
    54#if defined key_agrif  && ! defined key_offline 
    … …  
    1211   USE wrk_nemo   
    1312   USE dynspg_oce 
    14    USE zdf_oce        ! vertical physics: ocean variables  
    1513 
    1614   IMPLICIT NONE 
    1715   PRIVATE 
    1816 
    19    PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn,Update_Scales 
    20 # if defined key_zdftke 
    21    PUBLIC Agrif_Update_Tke 
    22 # endif 
     17   PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn 
     18 
     19   INTEGER, PUBLIC :: nbcline = 0 
     20 
    2321   !!---------------------------------------------------------------------- 
    24    !! NEMO/NST 3.6 , NEMO Consortium (2010) 
     22   !! NEMO/NST 3.3 , NEMO Consortium (2010) 
    2523   !! $Id$ 
    2624   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    … …  
    2927CONTAINS 
    3028 
    31    RECURSIVE SUBROUTINE Agrif_Update_Tra( ) 
     29   SUBROUTINE Agrif_Update_Tra( kt ) 
    3230      !!--------------------------------------------- 
    3331      !!   *** ROUTINE Agrif_Update_Tra *** 
    3432      !!--------------------------------------------- 
    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 
     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 ) 
    4041 
    4142      Agrif_UseSpecialValueInUpdate = .TRUE. 
    4243      Agrif_SpecialValueFineGrid = 0. 
    43       !  
     44 
    4445      IF (MOD(nbcline,nbclineupdate) == 0) THEN 
    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       ! 
     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 
    5851      Agrif_UseSpecialValueInUpdate = .FALSE. 
    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       ! 
     52 
     53      CALL wrk_dealloc( jpi, jpj, jpk, jpts, ztab ) 
    6654#endif 
    67       ! 
     55 
    6856   END SUBROUTINE Agrif_Update_Tra 
    6957 
    70    RECURSIVE SUBROUTINE Agrif_Update_Dyn( ) 
     58   SUBROUTINE Agrif_Update_Dyn( kt ) 
    7159      !!--------------------------------------------- 
    7260      !!   *** ROUTINE Agrif_Update_Dyn *** 
    7361      !!--------------------------------------------- 
    74       !  
    75       IF (Agrif_Root()) RETURN 
    76       ! 
     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 
    7769#if defined TWO_WAY 
    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       !      
     70      CALL wrk_alloc( jpi, jpj,      ztab2d ) 
     71      CALL wrk_alloc( jpi, jpj, jpk, ztab   ) 
     72 
    8373      IF (mod(nbcline,nbclineupdate) == 0) THEN 
    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 
     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 
    11085      IF (ln_bt_fw) THEN 
    11186         ! Update time integrated transports 
    11287         IF (mod(nbcline,nbclineupdate) == 0) THEN 
    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 
     88            CALL Agrif_Update_Variable(ztab2d,ub2b_id,procname = updateub2b) 
     89            CALL Agrif_Update_Variable(ztab2d,vb2b_id,procname = updatevb2b) 
    12090         ELSE 
    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 
     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) 
    12893         ENDIF 
    129       END IF 
    130 # endif 
    131       ! 
     94      END IF  
     95#endif 
     96 
    13297      nbcline = nbcline + 1 
    133       ! 
    134       Agrif_UseSpecialValueInUpdate = .TRUE. 
     98 
     99      Agrif_UseSpecialValueInUpdate = .TRUE.  
    135100      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 
     101      CALL Agrif_Update_Variable(ztab2d,sshn_id,procname = updateSSH) 
    141102      Agrif_UseSpecialValueInUpdate = .FALSE. 
    142       !  
     103 
     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 
    143112#endif 
    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       ! 
     113 
    152114   END SUBROUTINE Agrif_Update_Dyn 
    153115 
    154 # if defined key_zdftke 
    155    SUBROUTINE Agrif_Update_Tke( kt ) 
    156       !!--------------------------------------------- 
    157       !!   *** ROUTINE Agrif_Update_Tke *** 
    158       !!--------------------------------------------- 
    159       !! 
     116   SUBROUTINE recompute_diags( kt ) 
     117      !!--------------------------------------------- 
     118      !!   *** ROUTINE recompute_diags *** 
     119      !!--------------------------------------------- 
    160120      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. 
    166       Agrif_SpecialValueFineGrid = 0. 
    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  
    172       Agrif_UseSpecialValueInUpdate = .FALSE. 
    173  
    174 #  endif 
    175        
    176    END SUBROUTINE Agrif_Update_Tke 
    177 # endif /* key_zdftke */ 
     121 
     122   END SUBROUTINE recompute_diags 
    178123 
    179124   SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) 
    … …  
    182127      !!--------------------------------------------- 
    183128#  include "domzgr_substitute.h90" 
     129 
    184130      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
    185131      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 
    186       LOGICAL, INTENT(in) :: before 
    187       !! 
     132      LOGICAL, iNTENT(in) :: before 
     133 
    188134      INTEGER :: ji,jj,jk,jn 
    189       !!--------------------------------------------- 
    190       ! 
     135 
    191136      IF (before) THEN 
    192137         DO jn = n1,n2 
    … …  
    201146      ELSE 
    202147         IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 
    203             ! Add asselin part 
     148         ! Add asselin part 
    204149            DO jn = n1,n2 
    205150               DO jk=k1,k2 
    … …  
    208153                        IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN 
    209154                           tsb(ji,jj,jk,jn) = tsb(ji,jj,jk,jn) &  
    210                                  & + atfp * ( tabres(ji,jj,jk,jn) & 
    211                                  &             - tsn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 
     155                              & + atfp * ( tabres(ji,jj,jk,jn) & 
     156                              &             - tsn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 
    212157                        ENDIF 
    213158                     ENDDO 
    … …  
    216161            ENDDO 
    217162         ENDIF 
     163 
    218164         DO jn = n1,n2 
    219165            DO jk=k1,k2 
    … …  
    228174         END DO 
    229175      ENDIF 
    230       !  
     176 
    231177   END SUBROUTINE updateTS 
    232178 
    … …  
    236182      !!--------------------------------------------- 
    237183#  include "domzgr_substitute.h90" 
    238       !! 
     184 
    239185      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 
    240186      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 
    241187      LOGICAL, INTENT(in) :: before 
    242       !!  
     188 
    243189      INTEGER :: ji, jj, jk 
    244190      REAL(wp) :: zrhoy 
    245       !!--------------------------------------------- 
    246       !  
     191 
    247192      IF (before) THEN 
    248193         zrhoy = Agrif_Rhoy() 
    … …  
    264209                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 
    265210                     ub(ji,jj,jk) = ub(ji,jj,jk) &  
    266                            & + atfp * ( tabres(ji,jj,jk) - un(ji,jj,jk) ) * umask(ji,jj,jk) 
     211                       & + atfp * ( tabres(ji,jj,jk) - un(ji,jj,jk) ) * umask(ji,jj,jk) 
    267212                  ENDIF 
    268213                  ! 
    … …  
    272217         END DO 
    273218      ENDIF 
    274       !  
     219 
    275220   END SUBROUTINE updateu 
    276221 
    … …  
    280225      !!--------------------------------------------- 
    281226#  include "domzgr_substitute.h90" 
    282       !! 
     227 
    283228      INTEGER :: i1,i2,j1,j2,k1,k2 
    284229      INTEGER :: ji,jj,jk 
    285230      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: tabres 
    286231      LOGICAL :: before 
    287       !! 
     232 
    288233      REAL(wp) :: zrhox 
    289       !!---------------------------------------------       
    290       ! 
     234 
    291235      IF (before) THEN 
    292236         zrhox = Agrif_Rhox() 
    … …  
    308252                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 
    309253                     vb(ji,jj,jk) = vb(ji,jj,jk) &  
    310                            & + atfp * ( tabres(ji,jj,jk) - vn(ji,jj,jk) ) * vmask(ji,jj,jk) 
     254                       & + atfp * ( tabres(ji,jj,jk) - vn(ji,jj,jk) ) * vmask(ji,jj,jk) 
    311255                  ENDIF 
    312256                  ! 
    … …  
    316260         END DO 
    317261      ENDIF 
    318       !  
     262 
    319263   END SUBROUTINE updatev 
    320264 
    … …  
    324268      !!--------------------------------------------- 
    325269#  include "domzgr_substitute.h90" 
    326       !! 
     270 
    327271      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    328272      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    329273      LOGICAL, INTENT(in) :: before 
    330       !!  
     274 
    331275      INTEGER :: ji, jj, jk 
    332276      REAL(wp) :: zrhoy 
    333277      REAL(wp) :: zcorr 
    334       !!--------------------------------------------- 
    335       ! 
     278 
    336279      IF (before) THEN 
    337280         zrhoy = Agrif_Rhoy() 
    … …  
    383326         END DO 
    384327      ENDIF 
    385       ! 
     328 
    386329   END SUBROUTINE updateu2d 
    387330 
    … …  
    390333      !!          *** ROUTINE updatev2d *** 
    391334      !!--------------------------------------------- 
     335 
    392336      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    393337      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    394338      LOGICAL, INTENT(in) :: before 
    395       !!  
     339 
    396340      INTEGER :: ji, jj, jk 
    397341      REAL(wp) :: zrhox 
    398342      REAL(wp) :: zcorr 
    399       !!--------------------------------------------- 
    400       ! 
     343 
    401344      IF (before) THEN 
    402345         zrhox = Agrif_Rhox() 
    … …  
    448391         END DO 
    449392      ENDIF 
    450       !  
     393 
    451394   END SUBROUTINE updatev2d 
    452395 
    453  
    454396   SUBROUTINE updateSSH( tabres, i1, i2, j1, j2, before ) 
    455397      !!--------------------------------------------- 
    456398      !!          *** ROUTINE updateSSH *** 
    457399      !!--------------------------------------------- 
     400#  include "domzgr_substitute.h90" 
     401 
    458402      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    459403      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    460404      LOGICAL, INTENT(in) :: before 
    461       !! 
     405 
    462406      INTEGER :: ji, jj 
    463       !!--------------------------------------------- 
    464       !  
     407 
    465408      IF (before) THEN 
    466409         DO jj=j1,j2 
    … …  
    470413         END DO 
    471414      ELSE 
     415 
    472416#if ! defined key_dynspg_ts 
    473417         IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 
    474418            DO jj=j1,j2 
    475419               DO ji=i1,i2 
    476                   sshb(ji,jj) =   sshb(ji,jj) & 
    477                         & + atfp * ( tabres(ji,jj) - sshn(ji,jj) ) * tmask(ji,jj,1) 
     420                sshb(ji,jj) =   sshb(ji,jj) & 
     421                 & + atfp * ( tabres(ji,jj) - sshn(ji,jj) ) * tmask(ji,jj,1) 
    478422               END DO 
    479423            END DO 
    … …  
    486430         END DO 
    487431      ENDIF 
    488       ! 
     432 
    489433   END SUBROUTINE updateSSH 
    490434 
    … …  
    493437      !!          *** ROUTINE updateub2b *** 
    494438      !!--------------------------------------------- 
     439 
    495440      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    496441      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    497442      LOGICAL, INTENT(in) :: before 
    498       !! 
     443 
    499444      INTEGER :: ji, jj 
    500445      REAL(wp) :: zrhoy 
    501       !!--------------------------------------------- 
    502       ! 
     446 
    503447      IF (before) THEN 
    504448         zrhoy = Agrif_Rhoy() 
    … …  
    516460         END DO 
    517461      ENDIF 
    518       ! 
     462 
    519463   END SUBROUTINE updateub2b 
    520464 
    … …  
    523467      !!          *** ROUTINE updatevb2b *** 
    524468      !!--------------------------------------------- 
     469 
    525470      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    526471      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    527472      LOGICAL, INTENT(in) :: before 
    528       !! 
     473 
    529474      INTEGER :: ji, jj 
    530475      REAL(wp) :: zrhox 
    531       !!--------------------------------------------- 
    532       ! 
     476 
    533477      IF (before) THEN 
    534478         zrhox = Agrif_Rhox() 
    … …  
    546490         END DO 
    547491      ENDIF 
    548       ! 
     492 
    549493   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 */  
    656494 
    657495#else 
Note: See TracChangeset for help on using the changeset viewer.