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 4785 for branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90 – NEMO

Ignore:
Timestamp:
2014-09-24T14:03:02+02:00 (10 years ago)
Author:
rblod
Message:

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

File:
1 edited

Legend:

Unmodified
Added
Removed

  • branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90

    r4491 r4785  
    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 
    … …  
    1516   PRIVATE 
    1617 
    17    PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn 
    18  
    19    INTEGER, PUBLIC :: nbcline = 0 
     18   PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn,Update_Scales 
    2019 
    2120   !!---------------------------------------------------------------------- 
    … …  
    3130      !!   *** ROUTINE Agrif_Update_Tra *** 
    3231      !!--------------------------------------------- 
    33       !! 
    3432      INTEGER, INTENT(in) :: kt 
    35       REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztab 
    36  
    37  
     33      !!--------------------------------------------- 
     34      !  
    3835      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 ) 
    41  
     36#if defined TWO_WAY    
    4237      Agrif_UseSpecialValueInUpdate = .TRUE. 
    4338      Agrif_SpecialValueFineGrid = 0. 
    44  
     39      !  
    4540      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  
     41# if ! defined DECAL_FEEDBACK 
     42         CALL Agrif_Update_Variable(tsn_id, procname=updateTS) 
     43# else 
     44         CALL Agrif_Update_Variable(tsn_id, locupdate=(/1,0/),procname=updateTS) 
     45# endif 
     46      ELSE 
     47# if ! defined DECAL_FEEDBACK 
     48         CALL Agrif_Update_Variable(tsn_id,locupdate=(/0,2/), procname=updateTS) 
     49# else 
     50         CALL Agrif_Update_Variable(tsn_id,locupdate=(/1,2/), procname=updateTS) 
     51# endif 
     52      ENDIF 
     53      ! 
    5154      Agrif_UseSpecialValueInUpdate = .FALSE. 
    52  
    53       CALL wrk_dealloc( jpi, jpj, jpk, jpts, ztab ) 
    5455#endif 
    55  
     56      ! 
    5657   END SUBROUTINE Agrif_Update_Tra 
    5758 
    … …  
    6061      !!   *** ROUTINE Agrif_Update_Dyn *** 
    6162      !!--------------------------------------------- 
    62       !! 
    6363      INTEGER, INTENT(in) :: kt 
    64       REAL(wp), POINTER, DIMENSION(:,:) :: ztab2d 
    65       REAL(wp), POINTER, DIMENSION(:,:,:) :: ztab 
    66  
    67  
     64      !!--------------------------------------------- 
     65      !  
    6866      IF ((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) Return 
    6967#if defined TWO_WAY 
    70       CALL wrk_alloc( jpi, jpj,      ztab2d ) 
    71       CALL wrk_alloc( jpi, jpj, jpk, ztab   ) 
    72  
     68      Agrif_UseSpecialValueInUpdate = .FALSE. 
     69      Agrif_SpecialValueFineGrid = 0. 
     70      !      
    7371      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 
     72# if ! defined DECAL_FEEDBACK 
     73         CALL Agrif_Update_Variable(un_update_id,procname = updateU) 
     74         CALL Agrif_Update_Variable(vn_update_id,procname = updateV) 
     75# else 
     76         CALL Agrif_Update_Variable(un_update_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateU) 
     77         CALL Agrif_Update_Variable(vn_update_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updateV) 
     78# endif 
     79      ELSE 
     80# if ! defined DECAL_FEEDBACK 
     81         CALL Agrif_Update_Variable(un_update_id,locupdate=(/0,1/),procname = updateU) 
     82         CALL Agrif_Update_Variable(vn_update_id,locupdate=(/0,1/),procname = updateV)          
     83# else 
     84         CALL Agrif_Update_Variable(un_update_id,locupdate1=(/0,1/),locupdate2=(/1,1/),procname = updateU) 
     85         CALL Agrif_Update_Variable(vn_update_id,locupdate1=(/1,1/),locupdate2=(/0,1/),procname = updateV) 
     86# endif 
     87      ENDIF 
     88 
     89# if ! defined DECAL_FEEDBACK 
     90      CALL Agrif_Update_Variable(e1u_id,procname = updateU2d) 
     91      CALL Agrif_Update_Variable(e2v_id,procname = updateV2d)   
     92# else 
     93      CALL Agrif_Update_Variable(e1u_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateU2d) 
     94      CALL Agrif_Update_Variable(e2v_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updateV2d)   
     95# endif 
     96 
     97# if defined key_dynspg_ts 
    8598      IF (ln_bt_fw) THEN 
    8699         ! Update time integrated transports 
    87100         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) 
     101#  if ! defined DECAL_FEEDBACK 
     102            CALL Agrif_Update_Variable(ub2b_update_id,procname = updateub2b) 
     103            CALL Agrif_Update_Variable(vb2b_update_id,procname = updatevb2b) 
     104#  else 
     105            CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateub2b) 
     106            CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updatevb2b) 
     107#  endif 
    90108         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) 
     109#  if ! defined DECAL_FEEDBACK 
     110            CALL Agrif_Update_Variable(ub2b_update_id,locupdate=(/0,1/),procname = updateub2b) 
     111            CALL Agrif_Update_Variable(vb2b_update_id,locupdate=(/0,1/),procname = updatevb2b) 
    93112         ENDIF 
     113#  else 
     114         CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/0,1/),locupdate2=(/1,1/),procname = updateub2b) 
     115         CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1,1/),locupdate2=(/0,1/),procname = updatevb2b) 
     116#  endif 
    94117      END IF  
     118# endif 
     119      ! 
     120      nbcline = nbcline + 1 
     121      ! 
     122      Agrif_UseSpecialValueInUpdate = .TRUE. 
     123      Agrif_SpecialValueFineGrid = 0. 
     124# if ! defined DECAL_FEEDBACK 
     125      CALL Agrif_Update_Variable(sshn_id,procname = updateSSH) 
     126# else 
     127      CALL Agrif_Update_Variable(sshn_id,locupdate=(/1,0/),procname = updateSSH) 
     128# endif 
     129      Agrif_UseSpecialValueInUpdate = .FALSE. 
     130      !  
    95131#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  
    114132   END SUBROUTINE Agrif_Update_Dyn 
    115133 
    116    SUBROUTINE recompute_diags( kt ) 
    117       !!--------------------------------------------- 
    118       !!   *** ROUTINE recompute_diags *** 
    119       !!--------------------------------------------- 
    120       INTEGER, INTENT(in) :: kt 
    121  
    122    END SUBROUTINE recompute_diags 
    123134 
    124135   SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) 
    … …  
    127138      !!--------------------------------------------- 
    128139#  include "domzgr_substitute.h90" 
    129  
    130140      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
    131141      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 
    132       LOGICAL, iNTENT(in) :: before 
    133  
     142      LOGICAL, INTENT(in) :: before 
     143      !! 
    134144      INTEGER :: ji,jj,jk,jn 
    135  
     145      !!--------------------------------------------- 
     146      ! 
    136147      IF (before) THEN 
    137148         DO jn = n1,n2 
    … …  
    146157      ELSE 
    147158         IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 
    148          ! Add asselin part 
     159            ! Add asselin part 
    149160            DO jn = n1,n2 
    150161               DO jk=k1,k2 
    … …  
    161172            ENDDO 
    162173         ENDIF 
    163  
    164174         DO jn = n1,n2 
    165175            DO jk=k1,k2 
    … …  
    174184         END DO 
    175185      ENDIF 
    176  
     186      !  
    177187   END SUBROUTINE updateTS 
    178188 
    … …  
    182192      !!--------------------------------------------- 
    183193#  include "domzgr_substitute.h90" 
    184  
     194      !! 
    185195      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 
    186196      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 
    187197      LOGICAL, INTENT(in) :: before 
    188  
     198      !!  
    189199      INTEGER :: ji, jj, jk 
    190200      REAL(wp) :: zrhoy 
    191  
     201      !!--------------------------------------------- 
     202      !  
    192203      IF (before) THEN 
    193204         zrhoy = Agrif_Rhoy() 
    … …  
    217228         END DO 
    218229      ENDIF 
    219  
     230      !  
    220231   END SUBROUTINE updateu 
    221232 
    … …  
    225236      !!--------------------------------------------- 
    226237#  include "domzgr_substitute.h90" 
    227  
     238      !! 
    228239      INTEGER :: i1,i2,j1,j2,k1,k2 
    229240      INTEGER :: ji,jj,jk 
    230241      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: tabres 
    231242      LOGICAL :: before 
    232  
     243      !! 
    233244      REAL(wp) :: zrhox 
    234  
     245      !!---------------------------------------------       
     246      ! 
    235247      IF (before) THEN 
    236248         zrhox = Agrif_Rhox() 
    … …  
    260272         END DO 
    261273      ENDIF 
    262  
     274      !  
    263275   END SUBROUTINE updatev 
    264276 
    … …  
    268280      !!--------------------------------------------- 
    269281#  include "domzgr_substitute.h90" 
    270  
     282      !! 
    271283      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    272284      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    273285      LOGICAL, INTENT(in) :: before 
    274  
     286      !!  
    275287      INTEGER :: ji, jj, jk 
    276288      REAL(wp) :: zrhoy 
    277289      REAL(wp) :: zcorr 
    278  
     290      !!--------------------------------------------- 
     291      ! 
    279292      IF (before) THEN 
    280293         zrhoy = Agrif_Rhoy() 
    … …  
    326339         END DO 
    327340      ENDIF 
    328  
     341      ! 
    329342   END SUBROUTINE updateu2d 
    330343 
    … …  
    333346      !!          *** ROUTINE updatev2d *** 
    334347      !!--------------------------------------------- 
    335  
    336348      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    337349      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    338350      LOGICAL, INTENT(in) :: before 
    339  
     351      !!  
    340352      INTEGER :: ji, jj, jk 
    341353      REAL(wp) :: zrhox 
    342354      REAL(wp) :: zcorr 
    343  
     355      !!--------------------------------------------- 
     356      ! 
    344357      IF (before) THEN 
    345358         zrhox = Agrif_Rhox() 
    … …  
    391404         END DO 
    392405      ENDIF 
    393  
     406      !  
    394407   END SUBROUTINE updatev2d 
     408       
    395409 
    396410   SUBROUTINE updateSSH( tabres, i1, i2, j1, j2, before ) 
    … …  
    398412      !!          *** ROUTINE updateSSH *** 
    399413      !!--------------------------------------------- 
    400 #  include "domzgr_substitute.h90" 
    401  
    402414      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    403415      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    404416      LOGICAL, INTENT(in) :: before 
    405  
     417      !! 
    406418      INTEGER :: ji, jj 
    407  
     419      !!--------------------------------------------- 
     420      !  
    408421      IF (before) THEN 
    409422         DO jj=j1,j2 
    … …  
    413426         END DO 
    414427      ELSE 
    415  
    416428#if ! defined key_dynspg_ts 
    417429         IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 
    … …  
    430442         END DO 
    431443      ENDIF 
    432  
     444      ! 
    433445   END SUBROUTINE updateSSH 
    434446 
    … …  
    437449      !!          *** ROUTINE updateub2b *** 
    438450      !!--------------------------------------------- 
    439  
    440451      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    441452      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    442453      LOGICAL, INTENT(in) :: before 
    443  
     454      !! 
    444455      INTEGER :: ji, jj 
    445456      REAL(wp) :: zrhoy 
    446  
     457      !!--------------------------------------------- 
     458      ! 
    447459      IF (before) THEN 
    448460         zrhoy = Agrif_Rhoy() 
    … …  
    460472         END DO 
    461473      ENDIF 
    462  
     474      ! 
    463475   END SUBROUTINE updateub2b 
    464476 
    … …  
    467479      !!          *** ROUTINE updatevb2b *** 
    468480      !!--------------------------------------------- 
    469  
    470481      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    471482      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    472483      LOGICAL, INTENT(in) :: before 
    473  
     484      !! 
    474485      INTEGER :: ji, jj 
    475486      REAL(wp) :: zrhox 
    476  
     487      !!--------------------------------------------- 
     488      ! 
    477489      IF (before) THEN 
    478490         zrhox = Agrif_Rhox() 
    … …  
    490502         END DO 
    491503      ENDIF 
    492  
     504      ! 
    493505   END SUBROUTINE updatevb2b 
     506 
     507 
     508   SUBROUTINE update_scales( tabres, i1, i2, j1, j2, k1, k2, n1,n2, before ) 
     509   ! currently not used 
     510      !!--------------------------------------------- 
     511      !!           *** ROUTINE updateT *** 
     512      !!--------------------------------------------- 
     513#  include "domzgr_substitute.h90" 
     514 
     515      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
     516      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 
     517      LOGICAL, iNTENT(in) :: before 
     518 
     519      INTEGER :: ji,jj,jk 
     520      REAL(wp) :: ztemp 
     521 
     522      IF (before) THEN 
     523            DO jk=k1,k2 
     524               DO jj=j1,j2 
     525                  DO ji=i1,i2 
     526                     tabres(ji,jj,jk,1) = e1t(ji,jj)*e2t(ji,jj)*tmask(ji,jj,jk) 
     527                     tabres(ji,jj,jk,2) = e1t(ji,jj)*tmask(ji,jj,jk) 
     528                     tabres(ji,jj,jk,3) = e2t(ji,jj)*tmask(ji,jj,jk) 
     529                  END DO 
     530               END DO 
     531            END DO 
     532            tabres(:,:,:,1)=tabres(:,:,:,1)*Agrif_Rhox()*Agrif_Rhoy() 
     533            tabres(:,:,:,2)=tabres(:,:,:,2)*Agrif_Rhox() 
     534            tabres(:,:,:,3)=tabres(:,:,:,3)*Agrif_Rhoy() 
     535      ELSE 
     536            DO jk=k1,k2 
     537               DO jj=j1,j2 
     538                  DO ji=i1,i2 
     539                     IF( tabres(ji,jj,jk,1) .NE. 0. ) THEN  
     540                     print *,'VAL = ',ji,jj,jk,tabres(ji,jj,jk,1),e1t(ji,jj)*e2t(ji,jj)*tmask(ji,jj,jk) 
     541                     print *,'VAL2 = ',ji,jj,jk,tabres(ji,jj,jk,2),e1t(ji,jj)*tmask(ji,jj,jk) 
     542                     print *,'VAL3 = ',ji,jj,jk,tabres(ji,jj,jk,3),e2t(ji,jj)*tmask(ji,jj,jk) 
     543                     ztemp = sqrt(tabres(ji,jj,jk,1)/(tabres(ji,jj,jk,2)*tabres(ji,jj,jk,3))) 
     544                     print *,'CORR = ',ztemp-1. 
     545                     print *,'NEW VALS = ',tabres(ji,jj,jk,2)*ztemp,tabres(ji,jj,jk,3)*ztemp, & 
     546                     tabres(ji,jj,jk,2)*ztemp*tabres(ji,jj,jk,3)*ztemp 
     547                     e1t(ji,jj) = tabres(ji,jj,jk,2)*ztemp 
     548                     e2t(ji,jj) = tabres(ji,jj,jk,3)*ztemp 
     549                     END IF 
     550                  END DO 
     551               END DO 
     552            END DO 
     553      ENDIF 
     554 
     555   END SUBROUTINE update_scales 
    494556 
    495557#else 
Note: See TracChangeset for help on using the changeset viewer.