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 6808 for branches/NERC/dev_r5549_BDY_ZEROGRAD/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90 – NEMO

Ignore:
Timestamp:
2016-07-19T10:38:35+02:00 (8 years ago)
Author:
jamesharle
Message:

merge with trunk@6232 for consistency with SSB code

File:
1 edited

Legend:

Unmodified
Added
Removed

  • branches/NERC/dev_r5549_BDY_ZEROGRAD/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90

    r4491 r6808  
    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) 
    2526   !!---------------------------------------------------------------------- 
    26  
    2727CONTAINS 
    2828 
    29    SUBROUTINE Agrif_Update_Tra( kt ) 
     29   RECURSIVE SUBROUTINE Agrif_Update_Tra( ) 
    3030      !!--------------------------------------------- 
    3131      !!   *** ROUTINE Agrif_Update_Tra *** 
     32      !!--------------------------------------------- 
     33      !  
     34      IF (Agrif_Root()) RETURN 
     35      ! 
     36#if defined TWO_WAY   
     37      IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update tracers  from grid Number',Agrif_Fixed(), 'nbcline', nbcline 
     38 
     39      Agrif_UseSpecialValueInUpdate = .TRUE. 
     40      Agrif_SpecialValueFineGrid = 0. 
     41      !  
     42      IF (MOD(nbcline,nbclineupdate) == 0) THEN 
     43# if ! defined DECAL_FEEDBACK 
     44         CALL Agrif_Update_Variable(tsn_id, procname=updateTS) 
     45# else 
     46         CALL Agrif_Update_Variable(tsn_id, locupdate=(/1,0/),procname=updateTS) 
     47# endif 
     48      ELSE 
     49# if ! defined DECAL_FEEDBACK 
     50         CALL Agrif_Update_Variable(tsn_id,locupdate=(/0,2/), procname=updateTS) 
     51# else 
     52         CALL Agrif_Update_Variable(tsn_id,locupdate=(/1,2/), procname=updateTS) 
     53# endif 
     54      ENDIF 
     55      ! 
     56      Agrif_UseSpecialValueInUpdate = .FALSE. 
     57      ! 
     58      IF ( lk_agrif_doupd ) THEN ! Initialisation: do recursive update: 
     59         CALL Agrif_ChildGrid_To_ParentGrid() 
     60         CALL Agrif_Update_Tra() 
     61         CALL Agrif_ParentGrid_To_ChildGrid() 
     62      ENDIF 
     63      ! 
     64#endif 
     65      ! 
     66   END SUBROUTINE Agrif_Update_Tra 
     67 
     68 
     69   RECURSIVE SUBROUTINE Agrif_Update_Dyn( ) 
     70      !!--------------------------------------------- 
     71      !!   *** ROUTINE Agrif_Update_Dyn *** 
     72      !!--------------------------------------------- 
     73      !  
     74      IF (Agrif_Root()) RETURN 
     75      ! 
     76#if defined TWO_WAY 
     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      !      
     82      IF (mod(nbcline,nbclineupdate) == 0) 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 
     109         ! Update time integrated transports 
     110         IF (mod(nbcline,nbclineupdate) == 0) THEN 
     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 
     118         ELSE 
     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 
     126         ENDIF 
     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      !  
     140#endif 
     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 
     153   SUBROUTINE Agrif_Update_Tke( kt ) 
     154      !!--------------------------------------------- 
     155      !!   *** ROUTINE Agrif_Update_Tke *** 
    32156      !!--------------------------------------------- 
    33157      !! 
    34158      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 ) 
     159      !        
     160      IF( ( Agrif_NbStepint() .NE. 0 ) .AND. (kt /= 0) ) RETURN 
     161#  if defined TWO_WAY 
    41162 
    42163      Agrif_UseSpecialValueInUpdate = .TRUE. 
    43164      Agrif_SpecialValueFineGrid = 0. 
    44165 
    45       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 
     166      CALL Agrif_Update_Variable( en_id, locupdate=(/0,0/), procname=updateEN  ) 
     167      CALL Agrif_Update_Variable(avt_id, locupdate=(/0,0/), procname=updateAVT ) 
     168      CALL Agrif_Update_Variable(avm_id, locupdate=(/0,0/), procname=updateAVM ) 
    50169 
    51170      Agrif_UseSpecialValueInUpdate = .FALSE. 
    52171 
    53       CALL wrk_dealloc( jpi, jpj, jpk, jpts, ztab ) 
    54 #endif 
    55  
    56    END SUBROUTINE Agrif_Update_Tra 
    57  
    58    SUBROUTINE Agrif_Update_Dyn( kt ) 
    59       !!--------------------------------------------- 
    60       !!   *** ROUTINE Agrif_Update_Dyn *** 
    61       !!--------------------------------------------- 
    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 
    69 #if defined TWO_WAY 
    70       CALL wrk_alloc( jpi, jpj,      ztab2d ) 
    71       CALL wrk_alloc( jpi, jpj, jpk, ztab   ) 
    72  
    73       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 
    86          ! Update time integrated transports 
    87          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) 
    90          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) 
    93          ENDIF 
    94       END IF  
    95 #endif 
    96  
    97       nbcline = nbcline + 1 
    98  
    99       Agrif_UseSpecialValueInUpdate = .TRUE.  
    100       Agrif_SpecialValueFineGrid = 0. 
    101       CALL Agrif_Update_Variable(ztab2d,sshn_id,procname = updateSSH) 
    102       Agrif_UseSpecialValueInUpdate = .FALSE. 
    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  
    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 
     172#  endif 
     173       
     174   END SUBROUTINE Agrif_Update_Tke 
     175    
     176# endif /* key_zdftke */ 
    123177 
    124178   SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) 
    … …  
    126180      !!           *** ROUTINE updateT *** 
    127181      !!--------------------------------------------- 
    128 #  include "domzgr_substitute.h90" 
    129  
    130182      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
    131183      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 
    132       LOGICAL, iNTENT(in) :: before 
    133  
     184      LOGICAL, INTENT(in) :: before 
     185      !! 
    134186      INTEGER :: ji,jj,jk,jn 
    135  
     187      !!--------------------------------------------- 
     188      ! 
    136189      IF (before) THEN 
    137190         DO jn = n1,n2 
    … …  
    146199      ELSE 
    147200         IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 
    148          ! Add asselin part 
     201            ! Add asselin part 
    149202            DO jn = n1,n2 
    150203               DO jk=k1,k2 
    … …  
    153206                        IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN 
    154207                           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) 
     208                                 & + atfp * ( tabres(ji,jj,jk,jn) & 
     209                                 &             - tsn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 
    157210                        ENDIF 
    158211                     ENDDO 
    … …  
    161214            ENDDO 
    162215         ENDIF 
    163  
    164216         DO jn = n1,n2 
    165217            DO jk=k1,k2 
    … …  
    174226         END DO 
    175227      ENDIF 
    176  
     228      !  
    177229   END SUBROUTINE updateTS 
    178230 
     231 
    179232   SUBROUTINE updateu( tabres, i1, i2, j1, j2, k1, k2, before ) 
    180233      !!--------------------------------------------- 
    181234      !!           *** ROUTINE updateu *** 
    182235      !!--------------------------------------------- 
    183 #  include "domzgr_substitute.h90" 
    184  
    185       INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 
     236      INTEGER                               , INTENT(in   ) :: i1, i2, j1, j2, k1, k2 
    186237      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 
    187       LOGICAL, INTENT(in) :: before 
    188  
    189       INTEGER :: ji, jj, jk 
    190       REAL(wp) :: zrhoy 
    191  
    192       IF (before) THEN 
     238      LOGICAL                               , INTENT(in   ) :: before 
     239      ! 
     240      INTEGER  ::   ji, jj, jk 
     241      REAL(wp) ::   zrhoy 
     242      !!--------------------------------------------- 
     243      !  
     244      IF( before ) THEN 
    193245         zrhoy = Agrif_Rhoy() 
     246         DO jk = k1, k2 
     247            tabres(i1:i2,j1:j2,jk) = zrhoy * e2u(i1:i2,j1:j2) * e3u_n(i1:i2,j1:j2,jk) * un(i1:i2,j1:j2,jk) 
     248         END DO 
     249      ELSE 
    194250         DO jk=k1,k2 
    195251            DO jj=j1,j2 
    196252               DO ji=i1,i2 
    197                   tabres(ji,jj,jk) = e2u(ji,jj) * un(ji,jj,jk) 
    198                   tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3u_n(ji,jj,jk) 
    199                END DO 
    200             END DO 
    201          END DO 
    202          tabres = zrhoy * tabres 
    203       ELSE 
    204          DO jk=k1,k2 
    205             DO jj=j1,j2 
    206                DO ji=i1,i2 
    207                   tabres(ji,jj,jk) = tabres(ji,jj,jk) / e2u(ji,jj) / fse3u_n(ji,jj,jk) 
     253                  tabres(ji,jj,jk) = tabres(ji,jj,jk) * r1_e2u(ji,jj) / e3u_n(ji,jj,jk) 
    208254                  ! 
    209255                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 
    210256                     ub(ji,jj,jk) = ub(ji,jj,jk) &  
    211                        & + atfp * ( tabres(ji,jj,jk) - un(ji,jj,jk) ) * umask(ji,jj,jk) 
     257                           & + atfp * ( tabres(ji,jj,jk) - un(ji,jj,jk) ) * umask(ji,jj,jk) 
    212258                  ENDIF 
    213259                  ! 
    … …  
    217263         END DO 
    218264      ENDIF 
    219  
     265      !  
    220266   END SUBROUTINE updateu 
    221267 
     268 
    222269   SUBROUTINE updatev( tabres, i1, i2, j1, j2, k1, k2, before ) 
    223270      !!--------------------------------------------- 
    224271      !!           *** ROUTINE updatev *** 
    225272      !!--------------------------------------------- 
    226 #  include "domzgr_substitute.h90" 
    227  
    228273      INTEGER :: i1,i2,j1,j2,k1,k2 
    229274      INTEGER :: ji,jj,jk 
    230275      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: tabres 
    231276      LOGICAL :: before 
    232  
     277      !! 
    233278      REAL(wp) :: zrhox 
    234  
     279      !!---------------------------------------------       
     280      ! 
    235281      IF (before) THEN 
    236282         zrhox = Agrif_Rhox() 
    … …  
    238284            DO jj=j1,j2 
    239285               DO ji=i1,i2 
    240                   tabres(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk) 
    241                   tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3v_n(ji,jj,jk) 
    242                END DO 
    243             END DO 
    244          END DO 
    245          tabres = zrhox * tabres 
     286                  tabres(ji,jj,jk) = zrhox * e1v(ji,jj) * e3v_n(ji,jj,jk) * vn(ji,jj,jk) 
     287               END DO 
     288            END DO 
     289         END DO 
    246290      ELSE 
    247291         DO jk=k1,k2 
    248292            DO jj=j1,j2 
    249293               DO ji=i1,i2 
    250                   tabres(ji,jj,jk) = tabres(ji,jj,jk) / e1v(ji,jj) / fse3v_n(ji,jj,jk) 
     294                  tabres(ji,jj,jk) = tabres(ji,jj,jk) * r1_e1v(ji,jj) / e3v_n(ji,jj,jk) 
    251295                  ! 
    252296                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 
    253297                     vb(ji,jj,jk) = vb(ji,jj,jk) &  
    254                        & + atfp * ( tabres(ji,jj,jk) - vn(ji,jj,jk) ) * vmask(ji,jj,jk) 
     298                           & + atfp * ( tabres(ji,jj,jk) - vn(ji,jj,jk) ) * vmask(ji,jj,jk) 
    255299                  ENDIF 
    256300                  ! 
    … …  
    260304         END DO 
    261305      ENDIF 
    262  
     306      !  
    263307   END SUBROUTINE updatev 
    264308 
     309 
    265310   SUBROUTINE updateu2d( tabres, i1, i2, j1, j2, before ) 
    266311      !!--------------------------------------------- 
    267312      !!          *** ROUTINE updateu2d *** 
    268313      !!--------------------------------------------- 
    269 #  include "domzgr_substitute.h90" 
    270  
    271314      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    272315      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    273316      LOGICAL, INTENT(in) :: before 
    274  
     317      !!  
    275318      INTEGER :: ji, jj, jk 
    276319      REAL(wp) :: zrhoy 
    277320      REAL(wp) :: zcorr 
    278  
     321      !!--------------------------------------------- 
     322      ! 
    279323      IF (before) THEN 
    280324         zrhoy = Agrif_Rhoy() 
    281325         DO jj=j1,j2 
    282326            DO ji=i1,i2 
    283                tabres(ji,jj) = un_b(ji,jj) * hu(ji,jj) * e2u(ji,jj) 
    284             END DO 
    285          END DO 
    286          tabres = zrhoy * tabres 
    287       ELSE 
    288          DO jj=j1,j2 
    289             DO ji=i1,i2 
    290                tabres(ji,jj) =  tabres(ji,jj) * hur(ji,jj) / e2u(ji,jj)   
     327               tabres(ji,jj) = zrhoy * un_b(ji,jj) * hu_n(ji,jj) * e2u(ji,jj) 
     328            END DO 
     329         END DO 
     330      ELSE 
     331         DO jj=j1,j2 
     332            DO ji=i1,i2 
     333               tabres(ji,jj) =  tabres(ji,jj) * r1_hu_n(ji,jj) * r1_e2u(ji,jj)   
    291334               !     
    292335               ! Update "now" 3d velocities: 
    293                spgu(ji,jj) = 0.e0 
     336               spgu(ji,jj) = 0._wp 
    294337               DO jk=1,jpkm1 
    295                   spgu(ji,jj) = spgu(ji,jj) + fse3u_n(ji,jj,jk) * un(ji,jj,jk) 
    296                END DO 
    297                spgu(ji,jj) = spgu(ji,jj) * hur(ji,jj) 
     338                  spgu(ji,jj) = spgu(ji,jj) + e3u_n(ji,jj,jk) * un(ji,jj,jk) 
     339               END DO 
     340               spgu(ji,jj) = spgu(ji,jj) * r1_hu_n(ji,jj) 
    298341               ! 
    299342               zcorr = tabres(ji,jj) - spgu(ji,jj) 
    … …  
    303346               ! 
    304347               ! 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                
     348               IF ( .NOT.ln_dynspg_ts .OR. (ln_dynspg_ts.AND.(.NOT.ln_bt_fw)) ) THEN 
     349                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 
     350                     zcorr = tabres(ji,jj) - un_b(ji,jj) 
     351                     ub_b(ji,jj) = ub_b(ji,jj) + atfp * zcorr * umask(ji,jj,1) 
     352                  END IF 
     353               ENDIF              
    311354               un_b(ji,jj) = tabres(ji,jj) * umask(ji,jj,1) 
    312355               !        
    … …  
    314357               spgu(ji,jj) = 0.e0 
    315358               DO jk=1,jpkm1 
    316                   spgu(ji,jj) = spgu(ji,jj) + fse3u_b(ji,jj,jk) * ub(ji,jj,jk) 
    317                END DO 
    318                spgu(ji,jj) = spgu(ji,jj) * hur_b(ji,jj) 
     359                  spgu(ji,jj) = spgu(ji,jj) + e3u_b(ji,jj,jk) * ub(ji,jj,jk) 
     360               END DO 
     361               spgu(ji,jj) = spgu(ji,jj) * r1_hu_b(ji,jj) 
    319362               ! 
    320363               zcorr = ub_b(ji,jj) - spgu(ji,jj) 
    … …  
    326369         END DO 
    327370      ENDIF 
    328  
     371      ! 
    329372   END SUBROUTINE updateu2d 
    330373 
     374 
    331375   SUBROUTINE updatev2d( tabres, i1, i2, j1, j2, before ) 
    332376      !!--------------------------------------------- 
    333377      !!          *** ROUTINE updatev2d *** 
    334378      !!--------------------------------------------- 
    335  
    336379      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    337380      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    338381      LOGICAL, INTENT(in) :: before 
    339  
     382      !!  
    340383      INTEGER :: ji, jj, jk 
    341384      REAL(wp) :: zrhox 
    342385      REAL(wp) :: zcorr 
    343  
     386      !!--------------------------------------------- 
     387      ! 
    344388      IF (before) THEN 
    345389         zrhox = Agrif_Rhox() 
    346390         DO jj=j1,j2 
    347391            DO ji=i1,i2 
    348                tabres(ji,jj) = vn_b(ji,jj) * hv(ji,jj) * e1v(ji,jj)  
    349             END DO 
    350          END DO 
    351          tabres = zrhox * tabres 
    352       ELSE 
    353          DO jj=j1,j2 
    354             DO ji=i1,i2 
    355                tabres(ji,jj) =  tabres(ji,jj) * hvr(ji,jj) / e1v(ji,jj)   
     392               tabres(ji,jj) = zrhox * vn_b(ji,jj) * hv_n(ji,jj) * e1v(ji,jj)  
     393            END DO 
     394         END DO 
     395      ELSE 
     396         DO jj=j1,j2 
     397            DO ji=i1,i2 
     398               tabres(ji,jj) =  tabres(ji,jj) * r1_hv_n(ji,jj) * r1_e1v(ji,jj)   
    356399               !     
    357400               ! Update "now" 3d velocities: 
    358401               spgv(ji,jj) = 0.e0 
    359402               DO jk=1,jpkm1 
    360                   spgv(ji,jj) = spgv(ji,jj) + fse3v_n(ji,jj,jk) * vn(ji,jj,jk) 
    361                END DO 
    362                spgv(ji,jj) = spgv(ji,jj) * hvr(ji,jj) 
     403                  spgv(ji,jj) = spgv(ji,jj) + e3v_n(ji,jj,jk) * vn(ji,jj,jk) 
     404               END DO 
     405               spgv(ji,jj) = spgv(ji,jj) * r1_hv_n(ji,jj) 
    363406               ! 
    364407               zcorr = tabres(ji,jj) - spgv(ji,jj) 
    … …  
    368411               ! 
    369412               ! 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                
     413               IF ( .NOT.ln_dynspg_ts .OR. (ln_dynspg_ts.AND.(.NOT.ln_bt_fw)) ) THEN 
     414                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 
     415                     zcorr = tabres(ji,jj) - vn_b(ji,jj) 
     416                     vb_b(ji,jj) = vb_b(ji,jj) + atfp * zcorr * vmask(ji,jj,1) 
     417                  END IF 
     418               ENDIF               
    376419               vn_b(ji,jj) = tabres(ji,jj) * vmask(ji,jj,1) 
    377420               !        
    … …  
    379422               spgv(ji,jj) = 0.e0 
    380423               DO jk=1,jpkm1 
    381                   spgv(ji,jj) = spgv(ji,jj) + fse3v_b(ji,jj,jk) * vb(ji,jj,jk) 
    382                END DO 
    383                spgv(ji,jj) = spgv(ji,jj) * hvr_b(ji,jj) 
     424                  spgv(ji,jj) = spgv(ji,jj) + e3v_b(ji,jj,jk) * vb(ji,jj,jk) 
     425               END DO 
     426               spgv(ji,jj) = spgv(ji,jj) * r1_hv_b(ji,jj) 
    384427               ! 
    385428               zcorr = vb_b(ji,jj) - spgv(ji,jj) 
    … …  
    391434         END DO 
    392435      ENDIF 
    393  
     436      !  
    394437   END SUBROUTINE updatev2d 
    395438 
     439 
    396440   SUBROUTINE updateSSH( tabres, i1, i2, j1, j2, before ) 
    397441      !!--------------------------------------------- 
    398442      !!          *** ROUTINE updateSSH *** 
    399443      !!--------------------------------------------- 
    400 #  include "domzgr_substitute.h90" 
    401  
    402444      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    403445      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    404446      LOGICAL, INTENT(in) :: before 
    405  
     447      !! 
    406448      INTEGER :: ji, jj 
    407  
     449      !!--------------------------------------------- 
     450      !  
    408451      IF (before) THEN 
    409452         DO jj=j1,j2 
    … …  
    413456         END DO 
    414457      ELSE 
    415  
    416 #if ! defined key_dynspg_ts 
    417          IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 
     458         IF( .NOT.ln_dynspg_ts .OR. ( ln_dynspg_ts .AND. .NOT.ln_bt_fw ) ) THEN 
     459            IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 
     460               DO jj=j1,j2 
     461                  DO ji=i1,i2 
     462                     sshb(ji,jj) =   sshb(ji,jj) & 
     463                           & + atfp * ( tabres(ji,jj) - sshn(ji,jj) ) * tmask(ji,jj,1) 
     464                  END DO 
     465               END DO 
     466            ENDIF 
     467         ENDIF 
     468         ! 
     469         DO jj=j1,j2 
     470            DO ji=i1,i2 
     471               sshn(ji,jj) = tabres(ji,jj) * tmask(ji,jj,1) 
     472            END DO 
     473         END DO 
     474      ENDIF 
     475      ! 
     476   END SUBROUTINE updateSSH 
     477 
     478 
     479   SUBROUTINE updateub2b( tabres, i1, i2, j1, j2, before ) 
     480      !!--------------------------------------------- 
     481      !!          *** ROUTINE updateub2b *** 
     482      !!--------------------------------------------- 
     483      INTEGER, INTENT(in) :: i1, i2, j1, j2 
     484      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
     485      LOGICAL, INTENT(in) :: before 
     486      !! 
     487      INTEGER :: ji, jj 
     488      REAL(wp) :: zrhoy 
     489      !!--------------------------------------------- 
     490      ! 
     491      IF (before) THEN 
     492         zrhoy = Agrif_Rhoy() 
     493         DO jj=j1,j2 
     494            DO ji=i1,i2 
     495               tabres(ji,jj) = ub2_i_b(ji,jj) * e2u(ji,jj) 
     496            END DO 
     497         END DO 
     498         tabres = zrhoy * tabres 
     499      ELSE 
     500         DO jj=j1,j2 
     501            DO ji=i1,i2 
     502               ub2_b(ji,jj) = tabres(ji,jj) / e2u(ji,jj) 
     503            END DO 
     504         END DO 
     505      ENDIF 
     506      ! 
     507   END SUBROUTINE updateub2b 
     508 
     509 
     510   SUBROUTINE updatevb2b( tabres, i1, i2, j1, j2, before ) 
     511      !!--------------------------------------------- 
     512      !!          *** ROUTINE updatevb2b *** 
     513      !!--------------------------------------------- 
     514      INTEGER, INTENT(in) :: i1, i2, j1, j2 
     515      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
     516      LOGICAL, INTENT(in) :: before 
     517      !! 
     518      INTEGER :: ji, jj 
     519      REAL(wp) :: zrhox 
     520      !!--------------------------------------------- 
     521      ! 
     522      IF (before) THEN 
     523         zrhox = Agrif_Rhox() 
     524         DO jj=j1,j2 
     525            DO ji=i1,i2 
     526               tabres(ji,jj) = vb2_i_b(ji,jj) * e1v(ji,jj)  
     527            END DO 
     528         END DO 
     529         tabres = zrhox * tabres 
     530      ELSE 
     531         DO jj=j1,j2 
     532            DO ji=i1,i2 
     533               vb2_b(ji,jj) = tabres(ji,jj) / e1v(ji,jj) 
     534            END DO 
     535         END DO 
     536      ENDIF 
     537      ! 
     538   END SUBROUTINE updatevb2b 
     539 
     540 
     541   SUBROUTINE update_scales( tabres, i1, i2, j1, j2, k1, k2, n1,n2, before ) 
     542      ! currently not used 
     543      !!--------------------------------------------- 
     544      !!           *** ROUTINE updateT *** 
     545      !!--------------------------------------------- 
     546      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
     547      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 
     548      LOGICAL, iNTENT(in) :: before 
     549      ! 
     550      INTEGER :: ji,jj,jk 
     551      REAL(wp) :: ztemp 
     552      !!--------------------------------------------- 
     553 
     554      IF (before) THEN 
     555         DO jk=k1,k2 
    418556            DO jj=j1,j2 
    419557               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 
     558                  tabres(ji,jj,jk,1) = e1t(ji,jj)*e2t(ji,jj)*tmask(ji,jj,jk) 
     559                  tabres(ji,jj,jk,2) = e1t(ji,jj)*tmask(ji,jj,jk) 
     560                  tabres(ji,jj,jk,3) = e2t(ji,jj)*tmask(ji,jj,jk) 
     561               END DO 
     562            END DO 
     563         END DO 
     564         tabres(:,:,:,1)=tabres(:,:,:,1)*Agrif_Rhox()*Agrif_Rhoy() 
     565         tabres(:,:,:,2)=tabres(:,:,:,2)*Agrif_Rhox() 
     566         tabres(:,:,:,3)=tabres(:,:,:,3)*Agrif_Rhoy() 
     567      ELSE 
     568         DO jk=k1,k2 
     569            DO jj=j1,j2 
     570               DO ji=i1,i2 
     571                  IF( tabres(ji,jj,jk,1) .NE. 0. ) THEN  
     572                     print *,'VAL = ',ji,jj,jk,tabres(ji,jj,jk,1),e1t(ji,jj)*e2t(ji,jj)*tmask(ji,jj,jk) 
     573                     print *,'VAL2 = ',ji,jj,jk,tabres(ji,jj,jk,2),e1t(ji,jj)*tmask(ji,jj,jk) 
     574                     print *,'VAL3 = ',ji,jj,jk,tabres(ji,jj,jk,3),e2t(ji,jj)*tmask(ji,jj,jk) 
     575                     ztemp = sqrt(tabres(ji,jj,jk,1)/(tabres(ji,jj,jk,2)*tabres(ji,jj,jk,3))) 
     576                     print *,'CORR = ',ztemp-1. 
     577                     print *,'NEW VALS = ',tabres(ji,jj,jk,2)*ztemp,tabres(ji,jj,jk,3)*ztemp, & 
     578                           tabres(ji,jj,jk,2)*ztemp*tabres(ji,jj,jk,3)*ztemp 
     579                     e1t(ji,jj) = tabres(ji,jj,jk,2)*ztemp 
     580                     e2t(ji,jj) = tabres(ji,jj,jk,3)*ztemp 
     581                  END IF 
     582               END DO 
     583            END DO 
     584         END DO 
     585      ENDIF 
     586      ! 
     587   END SUBROUTINE update_scales 
     588 
     589# if defined key_zdftke 
     590 
     591   SUBROUTINE updateEN( ptab, i1, i2, j1, j2, k1, k2, before ) 
     592      !!--------------------------------------------- 
     593      !!           *** ROUTINE updateen *** 
     594      !!--------------------------------------------- 
     595      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 
     596      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     597      LOGICAL, INTENT(in) :: before 
     598      !!--------------------------------------------- 
     599      ! 
     600      IF (before) THEN 
     601         ptab (i1:i2,j1:j2,k1:k2) = en(i1:i2,j1:j2,k1:k2) 
     602      ELSE 
     603         en(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2)  
     604      ENDIF 
     605      ! 
     606   END SUBROUTINE updateEN 
     607 
     608 
     609   SUBROUTINE updateAVT( ptab, i1, i2, j1, j2, k1, k2, before ) 
     610      !!--------------------------------------------- 
     611      !!           *** ROUTINE updateavt *** 
     612      !!--------------------------------------------- 
     613      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 
     614      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     615      LOGICAL, INTENT(in) :: before 
     616      !!--------------------------------------------- 
     617      ! 
     618      IF (before) THEN 
     619         ptab (i1:i2,j1:j2,k1:k2) = avt_k(i1:i2,j1:j2,k1:k2) 
     620      ELSE 
     621         avt_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2)  
     622      ENDIF 
     623      ! 
     624   END SUBROUTINE updateAVT 
     625 
     626 
     627   SUBROUTINE updateAVM( ptab, i1, i2, j1, j2, k1, k2, before ) 
     628      !!--------------------------------------------- 
     629      !!           *** ROUTINE updateavm *** 
     630      !!--------------------------------------------- 
     631      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 
     632      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     633      LOGICAL, INTENT(in) :: before 
     634      !!--------------------------------------------- 
     635      ! 
     636      IF (before) THEN 
     637         ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2) 
     638      ELSE 
     639         avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2)  
     640      ENDIF 
     641      ! 
     642   END SUBROUTINE updateAVM 
     643 
     644# endif /* key_zdftke */  
    494645 
    495646#else 
Note: See TracChangeset for help on using the changeset viewer.