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

Ignore:
Timestamp:
2014-09-25T18:26:34+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

    r4785 r4789  
    1212   USE wrk_nemo   
    1313   USE dynspg_oce 
     14   USE zdf_oce        ! vertical physics: ocean variables  
    1415 
    1516   IMPLICIT NONE 
     
    1718 
    1819   PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn,Update_Scales 
    19  
     20# if defined key_zdftke 
     21   PUBLIC Agrif_Update_Tke 
     22# endif 
    2023   !!---------------------------------------------------------------------- 
    21    !! NEMO/NST 3.3 , NEMO Consortium (2010) 
     24   !! NEMO/NST 3.6 , NEMO Consortium (2010) 
    2225   !! $Id$ 
    2326   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
     
    115118         CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1,1/),locupdate2=(/0,1/),procname = updatevb2b) 
    116119#  endif 
    117       END IF  
     120      END IF 
    118121# endif 
    119122      ! 
     
    132135   END SUBROUTINE Agrif_Update_Dyn 
    133136 
     137# if defined key_zdftke 
     138   SUBROUTINE Agrif_Update_Tke( kt ) 
     139      !!--------------------------------------------- 
     140      !!   *** ROUTINE Agrif_Update_Tke *** 
     141      !!--------------------------------------------- 
     142      !! 
     143      INTEGER, INTENT(in) :: kt 
     144      !        
     145      IF((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) RETURN 
     146#  if defined TWO_WAY 
     147 
     148      Agrif_UseSpecialValueInUpdate = .TRUE. 
     149      Agrif_SpecialValueFineGrid = 0. 
     150 
     151      CALL Agrif_Update_Variable(avt_id ,locupdate=(/0,0/), procname=updateAVT ) 
     152      CALL Agrif_Update_Variable(avm_id ,locupdate=(/0,0/), procname=updateAVM ) 
     153      CALL Agrif_Update_Variable(avmu_id,locupdate=(/0,0/), procname=updateAVMu) 
     154      CALL Agrif_Update_Variable(avmv_id,locupdate=(/0,0/), procname=updateAVMv) 
     155 
     156      Agrif_UseSpecialValueInUpdate = .FALSE. 
     157 
     158#  endif 
     159       
     160   END SUBROUTINE Agrif_Update_Tke 
     161# endif /* key_zdftke */ 
    134162 
    135163   SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) 
     
    164192                        IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN 
    165193                           tsb(ji,jj,jk,jn) = tsb(ji,jj,jk,jn) &  
    166                               & + atfp * ( tabres(ji,jj,jk,jn) & 
    167                               &             - tsn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 
     194                                 & + atfp * ( tabres(ji,jj,jk,jn) & 
     195                                 &             - tsn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 
    168196                        ENDIF 
    169197                     ENDDO 
     
    220248                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 
    221249                     ub(ji,jj,jk) = ub(ji,jj,jk) &  
    222                        & + atfp * ( tabres(ji,jj,jk) - un(ji,jj,jk) ) * umask(ji,jj,jk) 
     250                           & + atfp * ( tabres(ji,jj,jk) - un(ji,jj,jk) ) * umask(ji,jj,jk) 
    223251                  ENDIF 
    224252                  ! 
     
    264292                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 
    265293                     vb(ji,jj,jk) = vb(ji,jj,jk) &  
    266                        & + atfp * ( tabres(ji,jj,jk) - vn(ji,jj,jk) ) * vmask(ji,jj,jk) 
     294                           & + atfp * ( tabres(ji,jj,jk) - vn(ji,jj,jk) ) * vmask(ji,jj,jk) 
    267295                  ENDIF 
    268296                  ! 
     
    406434      !  
    407435   END SUBROUTINE updatev2d 
    408        
     436 
    409437 
    410438   SUBROUTINE updateSSH( tabres, i1, i2, j1, j2, before ) 
     
    430458            DO jj=j1,j2 
    431459               DO ji=i1,i2 
    432                 sshb(ji,jj) =   sshb(ji,jj) & 
    433                  & + atfp * ( tabres(ji,jj) - sshn(ji,jj) ) * tmask(ji,jj,1) 
     460                  sshb(ji,jj) =   sshb(ji,jj) & 
     461                        & + atfp * ( tabres(ji,jj) - sshn(ji,jj) ) * tmask(ji,jj,1) 
    434462               END DO 
    435463            END DO 
     
    507535 
    508536   SUBROUTINE update_scales( tabres, i1, i2, j1, j2, k1, k2, n1,n2, before ) 
    509    ! currently not used 
     537      ! currently not used 
    510538      !!--------------------------------------------- 
    511539      !!           *** ROUTINE updateT *** 
     
    521549 
    522550      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  
     551         DO jk=k1,k2 
     552            DO jj=j1,j2 
     553               DO ji=i1,i2 
     554                  tabres(ji,jj,jk,1) = e1t(ji,jj)*e2t(ji,jj)*tmask(ji,jj,jk) 
     555                  tabres(ji,jj,jk,2) = e1t(ji,jj)*tmask(ji,jj,jk) 
     556                  tabres(ji,jj,jk,3) = e2t(ji,jj)*tmask(ji,jj,jk) 
     557               END DO 
     558            END DO 
     559         END DO 
     560         tabres(:,:,:,1)=tabres(:,:,:,1)*Agrif_Rhox()*Agrif_Rhoy() 
     561         tabres(:,:,:,2)=tabres(:,:,:,2)*Agrif_Rhox() 
     562         tabres(:,:,:,3)=tabres(:,:,:,3)*Agrif_Rhoy() 
     563      ELSE 
     564         DO jk=k1,k2 
     565            DO jj=j1,j2 
     566               DO ji=i1,i2 
     567                  IF( tabres(ji,jj,jk,1) .NE. 0. ) THEN  
    540568                     print *,'VAL = ',ji,jj,jk,tabres(ji,jj,jk,1),e1t(ji,jj)*e2t(ji,jj)*tmask(ji,jj,jk) 
    541569                     print *,'VAL2 = ',ji,jj,jk,tabres(ji,jj,jk,2),e1t(ji,jj)*tmask(ji,jj,jk) 
     
    544572                     print *,'CORR = ',ztemp-1. 
    545573                     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 
     574                           tabres(ji,jj,jk,2)*ztemp*tabres(ji,jj,jk,3)*ztemp 
    547575                     e1t(ji,jj) = tabres(ji,jj,jk,2)*ztemp 
    548576                     e2t(ji,jj) = tabres(ji,jj,jk,3)*ztemp 
    549                      END IF 
    550                   END DO 
    551                END DO 
    552             END DO 
    553       ENDIF 
    554  
     577                  END IF 
     578               END DO 
     579            END DO 
     580         END DO 
     581      ENDIF 
     582      ! 
    555583   END SUBROUTINE update_scales 
     584 
     585# if defined key_zdftke 
     586   SUBROUTINE updateAVT( ptab, i1, i2, j1, j2, k1, k2, before ) 
     587      !!--------------------------------------------- 
     588      !!           *** ROUTINE updateavt *** 
     589      !!--------------------------------------------- 
     590      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 
     591      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     592      LOGICAL, INTENT(in) :: before 
     593      !!--------------------------------------------- 
     594      ! 
     595      IF (before) THEN 
     596         ptab (i1:i2,j1:j2,k1:k2) = avt_k(i1:i2,j1:j2,k1:k2) 
     597      ELSE 
     598         avt_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2)  
     599      ENDIF 
     600      ! 
     601   END SUBROUTINE updateAVT 
     602 
     603 
     604   SUBROUTINE updateAVM( ptab, i1, i2, j1, j2, k1, k2, before ) 
     605      !!--------------------------------------------- 
     606      !!           *** ROUTINE updateavm *** 
     607      !!--------------------------------------------- 
     608      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 
     609      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     610      LOGICAL, INTENT(in) :: before 
     611      !!--------------------------------------------- 
     612      ! 
     613      IF (before) THEN 
     614         ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2) 
     615      ELSE 
     616         avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2)  
     617      ENDIF 
     618      ! 
     619   END SUBROUTINE updateAVM 
     620 
     621 
     622   SUBROUTINE updateAVMu( ptab, i1, i2, j1, j2, k1, k2, before ) 
     623      !!--------------------------------------------- 
     624      !!           *** ROUTINE updateavmu *** 
     625      !!--------------------------------------------- 
     626      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 
     627      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     628      LOGICAL, INTENT(in) :: before 
     629      !!--------------------------------------------- 
     630      ! 
     631      IF (before) THEN 
     632         ptab  (i1:i2,j1:j2,k1:k2) = avmu_k(i1:i2,j1:j2,k1:k2) 
     633      ELSE 
     634         avmu_k(i1:i2,j1:j2,k1:k2) = ptab  (i1:i2,j1:j2,k1:k2)  
     635      ENDIF 
     636      ! 
     637   END SUBROUTINE updateAVMu 
     638 
     639 
     640   SUBROUTINE updateAVMv( ptab, i1, i2, j1, j2, k1, k2, before ) 
     641      !!--------------------------------------------- 
     642      !!           *** ROUTINE updateavmv *** 
     643      !!--------------------------------------------- 
     644      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 
     645      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     646      LOGICAL, INTENT(in) :: before 
     647      !!--------------------------------------------- 
     648      ! 
     649      IF (before) THEN 
     650         ptab  (i1:i2,j1:j2,k1:k2) = avmv_k(i1:i2,j1:j2,k1:k2) 
     651      ELSE 
     652         avmv_k(i1:i2,j1:j2,k1:k2) = ptab  (i1:i2,j1:j2,k1:k2)  
     653      ENDIF 
     654      ! 
     655   END SUBROUTINE updateAVMv 
     656 
     657# endif /* key_zdftke */  
    556658 
    557659#else 
Note: See TracChangeset for help on using the changeset viewer.