Changeset 85 for trunk


Ignore:
Timestamp:
12/17/13 23:25:54 (10 years ago)
Author:
smasson
Message:

agrif fixes

Location:
trunk/NEMOGCM/NEMO
Files:
9 edited

Legend:

Unmodified
Added
Removed

  • trunk/NEMOGCM/NEMO/NST_SRC/agrif_oce.F90

    r7 r85  
    3737   INTEGER :: tsn_id,tsb_id,tsa_id 
    3838   INTEGER :: un_id, vn_id, ua_id, va_id 
     39   INTEGER :: e3t_id 
    3940   INTEGER :: e1u_id, e2v_id, sshn_id, gcb_id 
    4041   INTEGER :: trn_id, trb_id, tra_id 
     42   INTEGER :: glamt_id, gphit_id 
     43   INTEGER :: avt_id, avm_id, avmu_id, avmv_id 
    4144 
    4245   !!---------------------------------------------------------------------- 

  • trunk/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90

    r7 r85  
     1 
    12MODULE agrif_opa_interp 
    23   !!====================================================================== 
    … …  
    2829   USE lib_mpp 
    2930   USE wrk_nemo   
     31   USE zdf_oce        ! vertical physics: ocean variables 
    3032 
    3133   IMPLICIT NONE 
    3234   PRIVATE 
    3335     
    34    PUBLIC   Agrif_tra, Agrif_dyn, Agrif_ssh, interpu, interpv 
     36   PUBLIC   Agrif_tra, Agrif_dyn, Agrif_ssh, Agrif_tke 
     37   PUBLIC   interpu, interpv, interpe3t, interpavt, interpavm, interpavmu, interpavmv  
    3538 
    3639#  include "domzgr_substitute.h90"   
    … …  
    4447   CONTAINS 
    4548    
    46    SUBROUTINE Agrif_tra 
     49   SUBROUTINE Agrif_tra( kt ) 
    4750      !!---------------------------------------------------------------------- 
    4851      !!                  ***  ROUTINE Agrif_Tra  *** 
    4952      !!---------------------------------------------------------------------- 
     53      INTEGER, INTENT(in) ::   kt 
    5054      !! 
    5155      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    … …  
    5761      IF( Agrif_Root() )   RETURN 
    5862 
     63      IF( kt == nit000 ) CALL Agrif_e3t 
     64 
    5965      CALL wrk_alloc( jpi, jpj, jpk, jpts, ztsa )  
    6066 
    … …  
    6672      Agrif_UseSpecialValue = .FALSE. 
    6773 
    68       zrhox = Agrif_Rhox() 
    69  
    70       alpha1 = ( zrhox - 1. ) * 0.5 
    71       alpha2 = 1. - alpha1 
    72  
    73       alpha3 = ( zrhox - 1. ) / ( zrhox + 1. ) 
    74       alpha4 = 1. - alpha3 
    75  
    76       alpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 
    77       alpha7 =    - ( zrhox - 1. ) / ( zrhox + 3. ) 
    78       alpha5 = 1. - alpha6 - alpha7 
     74      zrhox = Agrif_Rhox()     ! if = 3 : 
     75 
     76      alpha1 = ( zrhox - 1. ) * 0.5    ! (3-1)/2 = 1 
     77      alpha2 = 1. - alpha1             ! 0 
     78 
     79      alpha3 = ( zrhox - 1. ) / ( zrhox + 1. )  ! (3-1)/(3+1) = 0.5 
     80      alpha4 = 1. - alpha3                      ! 0.5 
     81 
     82      alpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. )   ! 2*(3-1)/(3+1) = 1 
     83      alpha7 =    - ( zrhox - 1. ) / ( zrhox + 3. )   ! - (3-1)/(3+3) = -1/3 
     84      alpha5 = 1. - alpha6 - alpha7                   ! 1-1+1/3 = 1/3 
    7985 
    8086      IF( nbondi == 1 .OR. nbondi == 2 ) THEN 
    … …  
    118124      ENDIF 
    119125 
    120       IF( nbondi == -1 .OR. nbondi == 2 ) THEN 
     126      IF( nbondi == -1 .OR. nbondi == 2 ) THEN   ! west 
    121127         DO jn = 1, jpts 
    122             tsa(1,:,:,jn) = alpha1 * ztsa(1,:,:,jn) + alpha2 * ztsa(2,:,:,jn) 
     128            tsa(1,:,:,jn) = alpha1 * ztsa(1,:,:,jn) + alpha2 * ztsa(2,:,:,jn)  ! tsa(1,:,:,jn) = ztsa(1,:,:,jn) 
    123129            DO jk = 1, jpkm1 
    124130               DO jj = 1, jpj 
    … …  
    126132                     tsa(2,jj,jk,jn) = tsa(1,jj,jk,jn) * tmask(2,jj,jk) 
    127133                  ELSE 
    128                      tsa(2,jj,jk,jn)=(alpha4*tsa(1,jj,jk,jn)+alpha3*tsa(3,jj,jk,jn))*tmask(2,jj,jk)         
    129                      IF( un(2,jj,jk) < 0.e0 ) THEN 
     134                     tsa(2,jj,jk,jn)=(alpha4*tsa(1,jj,jk,jn)+alpha3*tsa(3,jj,jk,jn))*tmask(2,jj,jk) ! tsa1(2) = (tsa(1)+tsa(3))/2   
     135                     IF( un(2,jj,jk) < 0.e0 ) THEN ! if outgoing current: tsa1(2) = tsa1(3)+1/3*tsa1(1)-1/3*tsa(4) 
    130136                        tsa(2,jj,jk,jn)=(alpha6*tsa(3,jj,jk,jn)+alpha5*tsa(1,jj,jk,jn)+alpha7*tsa(4,jj,jk,jn))*tmask(2,jj,jk) 
    131137                     ENDIF 
    … …  
    196202      zua = 0. 
    197203      zva = 0. 
    198       CALL Agrif_Bc_variable(zua,un_id,procname=interpu) 
     204      CALL Agrif_Bc_variable(zua,un_id,procname=interpu)   ! zua = zonal tansport at now time: e2u*e3u*un 
    199205      CALL Agrif_Bc_variable(zva,vn_id,procname=interpv) 
    200206      zua2d = 0. 
    … …  
    203209      Agrif_SpecialValue=0. 
    204210      Agrif_UseSpecialValue = ln_spc_dyn 
    205       CALL Agrif_Bc_variable(zua2d,e1u_id,calledweight=1.,procname=interpu2d) 
     211      CALL Agrif_Bc_variable(zua2d,e1u_id,calledweight=1.,procname=interpu2d)! zua2d = zonal gradient of temporal derivative of eta 
    206212      CALL Agrif_Bc_variable(zva2d,e2v_id,calledweight=1.,procname=interpv2d) 
    207213      Agrif_UseSpecialValue = .FALSE. 
    208214 
    209215 
    210       IF((nbondi == -1).OR.(nbondi == 2)) THEN 
     216      IF((nbondi == -1).OR.(nbondi == 2)) THEN   ! west 
    211217 
    212218         DO jj=1,jpj 
    … …  
    214220         END DO 
    215221 
    216          DO jk=1,jpkm1 
     222         DO jk=1,jpkm1     ! move back zonal transport to zonal current 
    217223            DO jj=1,jpj 
    218224               ua(1:2,jj,jk) = (zua(1:2,jj,jk)/(rhoy*e2u(1:2,jj))) 
    … …  
    241247         END DO 
    242248 
    243          DO jk=1,jpkm1 
     249         DO jk=1,jpkm1   ! 1/4 1/2 1/4 filter 
    244250            DO jj=1,jpj 
    245251               ua(2,jj,jk) = 0.25*(ua(1,jj,jk)+2.*ua(2,jj,jk)+ua(3,jj,jk)) 
    … …  
    498504   SUBROUTINE Agrif_ssh( kt ) 
    499505      !!---------------------------------------------------------------------- 
    500       !!                  ***  ROUTINE Agrif_DYN  *** 
     506      !!                  ***  ROUTINE Agrif_ssh  *** 
    501507      !!----------------------------------------------------------------------   
    502508      INTEGER, INTENT(in) ::   kt 
    … …  
    528534 
    529535   END SUBROUTINE Agrif_ssh 
     536 
     537 
     538   SUBROUTINE Agrif_tke 
     539      !!---------------------------------------------------------------------- 
     540      !!                  ***  ROUTINE Agrif_tke  *** 
     541      !!----------------------------------------------------------------------   
     542      REAL(wp), POINTER, DIMENSION(:,:,:) :: z3d 
     543      !!----------------------------------------------------------------------   
     544      IF( Agrif_Root() )   RETURN 
     545 
     546      CALL wrk_alloc( jpi, jpj, jpk, z3d ) 
     547       
     548      Agrif_SpecialValue    = 0.e0 
     549      Agrif_UseSpecialValue = .TRUE. 
     550      z3d(:,:,:) = 0. 
     551       
     552      CALL Agrif_Bc_variable(z3d,avt_id,calledweight=1.,procname=interpavt) 
     553       
     554      avt_k(mi0(       1):mi1(     2),:,:) = z3d(mi0(       1):mi1(     2),:,:)   ! west 
     555      avt_k(mi0(jpiglo-1):mi1(jpiglo),:,:) = z3d(mi0(jpiglo-1):mi1(jpiglo),:,:)   ! east 
     556      avt_k(:,mj0(       1):mj1(     2),:) = z3d(:,mj0(       1):mj1(     2),:)   ! south 
     557      avt_k(:,mj0(jpjglo-1):mj1(jpjglo),:) = z3d(:,mj0(jpjglo-1):mj1(jpjglo),:)   ! north 
     558        
     559      CALL Agrif_Bc_variable(z3d,avm_id,calledweight=1.,procname=interpavm) 
     560       
     561      avm_k(mi0(       1):mi1(     2),:,:) = z3d(mi0(       1):mi1(     2),:,:)   ! west 
     562      avm_k(mi0(jpiglo-1):mi1(jpiglo),:,:) = z3d(mi0(jpiglo-1):mi1(jpiglo),:,:)   ! east 
     563      avm_k(:,mj0(       1):mj1(     2),:) = z3d(:,mj0(       1):mj1(     2),:)   ! south 
     564      avm_k(:,mj0(jpjglo-1):mj1(jpjglo),:) = z3d(:,mj0(jpjglo-1):mj1(jpjglo),:)   ! north 
     565        
     566      CALL Agrif_Bc_variable(z3d,avmu_id,calledweight=1.,procname=interpavmu) 
     567       
     568      avmu_k(mi0(       1):mi1(     2),:,:) = z3d(mi0(       1):mi1(     2),:,:)   ! west 
     569      avmu_k(mi0(jpiglo-1):mi1(jpiglo),:,:) = z3d(mi0(jpiglo-1):mi1(jpiglo),:,:)   ! east 
     570      avmu_k(:,mj0(       1):mj1(     2),:) = z3d(:,mj0(       1):mj1(     2),:)   ! south 
     571      avmu_k(:,mj0(jpjglo-1):mj1(jpjglo),:) = z3d(:,mj0(jpjglo-1):mj1(jpjglo),:)   ! north 
     572 
     573      CALL Agrif_Bc_variable(z3d,avmv_id,calledweight=1.,procname=interpavmv) 
     574       
     575      avmv_k(mi0(       1):mi1(     2),:,:) = z3d(mi0(       1):mi1(     2),:,:)   ! west 
     576      avmv_k(mi0(jpiglo-1):mi1(jpiglo),:,:) = z3d(mi0(jpiglo-1):mi1(jpiglo),:,:)   ! east 
     577      avmv_k(:,mj0(       1):mj1(     2),:) = z3d(:,mj0(       1):mj1(     2),:)   ! south 
     578      avmv_k(:,mj0(jpjglo-1):mj1(jpjglo),:) = z3d(:,mj0(jpjglo-1):mj1(jpjglo),:)   ! north 
     579               
     580      Agrif_UseSpecialValue = .FALSE. 
     581      CALL wrk_dealloc( jpi, jpj, jpk, z3d ) 
     582 
     583   END SUBROUTINE Agrif_tke 
     584 
     585 
     586   SUBROUTINE Agrif_e3t 
     587      !!---------------------------------------------------------------------- 
     588      !!                  ***  ROUTINE Agrif_e3t  *** 
     589      !!----------------------------------------------------------------------   
     590      !! 
     591      INTEGER :: ji,jj,jk 
     592      INTEGER :: icnt 
     593      REAL(wp) :: zrhox, zrhoy 
     594      REAL(wp), POINTER, DIMENSION(:,:,:) :: ze3t 
     595      !!----------------------------------------------------------------------   
     596      IF( Agrif_Root() )   RETURN 
     597       
     598      CALL wrk_alloc( jpi, jpj, jpk, ze3t ) 
     599      zrhox = Agrif_Rhox() 
     600      zrhoy = Agrif_Rhoy() 
     601      ze3t(:,:,:) = 0. 
     602      icnt = 0  
     603       
     604      CALL Agrif_Bc_variable(ze3t,e3t_id,calledweight=1.,procname=interpe3t) 
     605       
     606      ! Warning: do not take into account the fist/last column/line that are masked in the child grid 
     607       
     608      DO jk=1,jpkm1    !    west 
     609         DO jj=mj0(2),mj1(jpjglo-1) 
     610            DO ji=mi0(2),mi1(2 + 3*zrhox) 
     611               IF( ABS(ze3t(ji,jj,jk) - fse3t(ji,jj,jk))*tmask(ji,jj,jk) > 1.e-2 ) THEN 
     612                  WRITE(numout,*) 'ERROR bathymetry merge at the western border ji,jj,jk ', ji,jj,jk 
     613                  WRITE(numout,*) '      ze3t(ji,jj,jk), fse3t(ji,jj,jk) ', ze3t(ji,jj,jk), fse3t(ji,jj,jk) 
     614                  icnt = icnt + 1 
     615               END IF 
     616            END DO 
     617         END DO 
     618      END DO 
     619       
     620      DO jk=1,jpkm1    !    east 
     621         DO jj=mj0(2),mj1(jpjglo-1) 
     622            DO ji=mi0(jpiglo - 1 - 3*zrhox),mi1(jpiglo-1) 
     623               IF( ABS(ze3t(ji,jj,jk) - fse3t(ji,jj,jk))*tmask(ji,jj,jk) > 1.e-2 ) THEN 
     624                  WRITE(numout,*) 'ERROR bathymetry merge at the eastern border ji,jj,jk ', ji,jj,jk 
     625                  WRITE(numout,*) '      ze3t(ji,jj,jk), fse3t(ji,jj,jk) ', ze3t(ji,jj,jk), fse3t(ji,jj,jk) 
     626                  icnt = icnt + 1 
     627               END IF 
     628            END DO 
     629         END DO 
     630      END DO 
     631       
     632      DO jk=1,jpkm1    ! south 
     633         DO jj=mj0(2),mj1(2 + 3*zrhoy) 
     634            DO ji=mi0(2),mi1(jpiglo-1) 
     635               IF( ABS(ze3t(ji,jj,jk) - fse3t(ji,jj,jk))*tmask(ji,jj,jk) > 1.e-2 ) THEN  
     636                  WRITE(numout,*) 'ERROR bathymetry merge at the southern border ji,jj,jk', ji,jj,jk 
     637                  WRITE(numout,*) '      ze3t(ji,jj,jk), fse3t(ji,jj,jk) ', ze3t(ji,jj,jk), fse3t(ji,jj,jk) 
     638                  icnt = icnt + 1 
     639               END IF 
     640            END DO 
     641         END DO 
     642      END DO 
     643      DO jk=1,jpkm1   ! north 
     644         DO jj=mj0(jpjglo - 1 - 3*zrhoy),mj1(jpjglo-1) 
     645            DO ji=mi0(2),mi1(jpiglo-1) 
     646               IF( ABS(ze3t(ji,jj,jk) - fse3t(ji,jj,jk))*tmask(ji,jj,jk) > 1.e-2 ) THEN 
     647                  WRITE(numout,*) 'ERROR bathymetry merge at the northen border ji,jj,jk', ji,jj,jk 
     648                  WRITE(numout,*) '      ze3t(ji,jj,jk), fse3t(ji,jj,jk) ', ze3t(ji,jj,jk), fse3t(ji,jj,jk) 
     649                  icnt = icnt + 1 
     650               END IF 
     651            END DO 
     652         END DO 
     653      END DO 
     654 
     655      CALL wrk_dealloc( jpi, jpj, jpk, ze3t ) 
     656       
     657      IF(icnt /= 0) THEN  
     658         CALL ctl_stop('ERROR in bathymetry merge between parent and child grids...') 
     659      ELSE 
     660         IF(lwp) WRITE(numout,*) 'interp e3t ok...' 
     661      END IF 
     662       
     663   END SUBROUTINE Agrif_e3t 
    530664 
    531665 
    … …  
    543677         DO jj=j1,j2 
    544678            DO ji=i1,i2 
    545                tabres(ji,jj,jk) = e2u(ji,jj) * un(ji,jj,jk) 
    546                tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3u(ji,jj,jk) 
     679               tabres(ji,jj,jk) = e2u(ji,jj) * un(ji,jj,jk) * fse3u(ji,jj,jk) 
    547680            END DO 
    548681         END DO 
    549682      END DO 
     683 
    550684   END SUBROUTINE interpu 
    551685 
    … …  
    584718         DO jj=j1,j2 
    585719            DO ji=i1,i2 
    586                tabres(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk) 
    587                tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3v(ji,jj,jk) 
     720               tabres(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk) * fse3v(ji,jj,jk) 
    588721            END DO 
    589722         END DO 
    … …  
    592725   END SUBROUTINE interpv 
    593726 
    594  
     727    
    595728   SUBROUTINE interpv2d(tabres,i1,i2,j1,j2) 
    596729      !!---------------------------------------------------------------------- 
    … …  
    611744 
    612745   END SUBROUTINE interpv2d 
     746 
     747 
     748   SUBROUTINE interpe3t(tabres,i1,i2,j1,j2,k1,k2) 
     749      !!---------------------------------------------------------------------- 
     750      !!                  ***  ROUTINE interpv  *** 
     751      !!----------------------------------------------------------------------   
     752      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
     753      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 
     754      !! 
     755      INTEGER :: ji, jj, jk 
     756      !!----------------------------------------------------------------------   
     757       
     758      DO jk=k1,k2 
     759         DO jj=j1,j2 
     760            DO ji=i1,i2 
     761               tabres(ji,jj,jk) = tmask(ji,jj,jk) * fse3t(ji,jj,jk) 
     762            END DO 
     763         END DO 
     764      END DO 
     765       
     766   END SUBROUTINE interpe3t 
     767 
     768 
     769   SUBROUTINE interpavt(tabres,i1,i2,j1,j2,k1,k2) 
     770      !!---------------------------------------------------------------------- 
     771      !!                  ***  ROUTINE interavt  *** 
     772      !!----------------------------------------------------------------------   
     773      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
     774      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 
     775       
     776      tabres(i1:i2,j1:j2,k1:k2) = avt_k(i1:i2,j1:j2,k1:k2) 
     777       
     778   END SUBROUTINE interpavt 
     779 
     780 
     781   SUBROUTINE interpavm(tabres,i1,i2,j1,j2,k1,k2) 
     782      !!---------------------------------------------------------------------- 
     783      !!                  ***  ROUTINE interavm  *** 
     784      !!----------------------------------------------------------------------   
     785      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
     786      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 
     787       
     788      tabres(i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2) 
     789       
     790   END SUBROUTINE interpavm 
     791 
     792 
     793   SUBROUTINE interpavmu(tabres,i1,i2,j1,j2,k1,k2) 
     794      !!---------------------------------------------------------------------- 
     795      !!                  ***  ROUTINE interavmu  *** 
     796      !!----------------------------------------------------------------------   
     797      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
     798      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 
     799       
     800      tabres(i1:i2,j1:j2,k1:k2) = avmu_k(i1:i2,j1:j2,k1:k2) 
     801       
     802   END SUBROUTINE interpavmu 
     803 
     804 
     805   SUBROUTINE interpavmv(tabres,i1,i2,j1,j2,k1,k2) 
     806      !!---------------------------------------------------------------------- 
     807      !!                  ***  ROUTINE interavmv  *** 
     808      !!----------------------------------------------------------------------   
     809      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
     810      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 
     811       
     812      tabres(i1:i2,j1:j2,k1:k2) = avmv_k(i1:i2,j1:j2,k1:k2) 
     813       
     814   END SUBROUTINE interpavmv 
     815 
    613816 
    614817#else 

  • trunk/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90

    r7 r85  
    1010   USE lib_mpp 
    1111   USE wrk_nemo   
     12   USE zdf_oce        ! vertical physics: ocean variables 
    1213 
    1314   IMPLICIT NONE 
    … …  
    1516 
    1617   PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn 
     18   PUBLIC Agrif_Update_Tke 
    1719 
    1820   INTEGER, PUBLIC :: nbcline = 0 
    … …  
    3234      !! 
    3335      INTEGER, INTENT(in) :: kt 
     36      REAL(wp), POINTER, DIMENSION(:,:) :: ztab2d 
    3437      REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztab 
    3538 
     39      IF( kt == nit000 ) THEN 
     40         CALL wrk_alloc( jpi, jpj, ztab2d ) 
     41         CALL Agrif_Update_Variable(ztab2d,glamt_id, procname= updateglamT)   ! check that updating glamt has not impact 
     42         CALL Agrif_Update_Variable(ztab2d,gphit_id, procname= updategphiT)   ! check that updating gphit has not impact 
     43         CALL wrk_dealloc( jpi, jpj, ztab2d ) 
     44      ENDIF 
    3645        
    3746      IF((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) RETURN 
    … …  
    3948      CALL wrk_alloc( jpi, jpj, jpk, jpts, ztab ) 
    4049 
     50 
    4151      Agrif_UseSpecialValueInUpdate = .TRUE. 
    4252      Agrif_SpecialValueFineGrid = 0. 
    … …  
    100110   END SUBROUTINE Agrif_Update_Dyn 
    101111 
     112 
     113   SUBROUTINE Agrif_Update_Tke( kt ) 
     114      !!--------------------------------------------- 
     115      !!   *** ROUTINE Agrif_Update_Tke *** 
     116      !!--------------------------------------------- 
     117      !! 
     118      INTEGER, INTENT(in) :: kt 
     119      REAL(wp), POINTER, DIMENSION(:,:,:) :: ztab 
     120 
     121        
     122      IF((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) RETURN 
     123#if defined TWO_WAY 
     124      CALL wrk_alloc( jpi, jpj, jpk, ztab ) 
     125 
     126      Agrif_UseSpecialValueInUpdate = .TRUE. 
     127      Agrif_SpecialValueFineGrid = 0. 
     128 
     129      CALL Agrif_Update_Variable(ztab,avt_id ,locupdate=(/0,0/), procname=updateAVT ) 
     130      CALL Agrif_Update_Variable(ztab,avm_id ,locupdate=(/0,0/), procname=updateAVM ) 
     131      CALL Agrif_Update_Variable(ztab,avmu_id,locupdate=(/0,0/), procname=updateAVMu) 
     132      CALL Agrif_Update_Variable(ztab,avmv_id,locupdate=(/0,0/), procname=updateAVMv) 
     133 
     134      Agrif_UseSpecialValueInUpdate = .FALSE. 
     135 
     136      CALL wrk_dealloc( jpi, jpj, jpk, ztab ) 
     137#endif 
     138       
     139   END SUBROUTINE Agrif_Update_Tke 
     140 
     141 
    102142   SUBROUTINE recompute_diags( kt ) 
    103143      !!--------------------------------------------- 
    … …  
    112152      !!           *** ROUTINE updateT *** 
    113153      !!--------------------------------------------- 
    114 #  include "domzgr_substitute.h90" 
    115154 
    116155      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
    … …  
    119158 
    120159      INTEGER :: ji,jj,jk,jn 
     160      REAL(wp):: ztemp 
    121161 
    122162      IF (before) THEN 
    … …  
    136176                  DO ji=i1,i2 
    137177                     IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN  
     178                         ztemp = tsn(ji,jj,jk,jn) 
    138179                         tsn(ji,jj,jk,jn) = tabres(ji,jj,jk,jn) * tmask(ji,jj,jk) 
     180                         tsb(ji,jj,jk,jn) = tsb(ji,jj,jk,jn) + atfp * ( tsn(ji,jj,jk,jn) - ztemp ) 
    139181                     END IF 
    140182                  END DO 
    … …  
    157199 
    158200      INTEGER :: ji, jj, jk 
    159       REAL(wp) :: zrhoy 
     201      REAL(wp) :: zrhoy, ztemp 
    160202 
    161203      IF (before) THEN 
    … …  
    164206            DO jj=j1,j2 
    165207               DO ji=i1,i2 
    166                   tabres(ji,jj,jk) = e2u(ji,jj) * un(ji,jj,jk) 
    167                   tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3u(ji,jj,jk) 
     208                  tabres(ji,jj,jk) = e2u(ji,jj) * un(ji,jj,jk) * fse3u(ji,jj,jk) 
    168209               END DO 
    169210            END DO 
    … …  
    174215            DO jj=j1,j2 
    175216               DO ji=i1,i2 
    176                   un(ji,jj,jk) = tabres(ji,jj,jk) / (e2u(ji,jj)) 
    177                   un(ji,jj,jk) = un(ji,jj,jk) * umask(ji,jj,jk) 
    178                   un(ji,jj,jk) = un(ji,jj,jk) / fse3u(ji,jj,jk) 
     217                  ztemp        = un(ji,jj,jk)  
     218                  un(ji,jj,jk) = tabres(ji,jj,jk) / (e2u(ji,jj)*fse3u(ji,jj,jk)) * umask(ji,jj,jk) 
     219                  ub(ji,jj,jk) = ub(ji,jj,jk) + atfp * ( un(ji,jj,jk) - ztemp ) 
    179220               END DO 
    180221            END DO 
    … …  
    195236      LOGICAL :: before 
    196237 
    197       REAL(wp) :: zrhox 
     238      REAL(wp) :: zrhox, ztemp 
    198239 
    199240      IF (before) THEN 
    … …  
    202243            DO jj=j1,j2 
    203244               DO ji=i1,i2 
    204                   tabres(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk) 
    205                   tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3v(ji,jj,jk) 
     245                  tabres(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk) * fse3v(ji,jj,jk) 
    206246               END DO 
    207247            END DO 
    … …  
    212252            DO jj=j1,j2 
    213253               DO ji=i1,i2 
    214                   vn(ji,jj,jk) = tabres(ji,jj,jk) / (e1v(ji,jj)) 
    215                   vn(ji,jj,jk) = vn(ji,jj,jk) * vmask(ji,jj,jk) 
    216                   vn(ji,jj,jk) = vn(ji,jj,jk) / fse3v(ji,jj,jk) 
     254                  ztemp        = vn(ji,jj,jk) 
     255                  vn(ji,jj,jk) = tabres(ji,jj,jk) / (e1v(ji,jj)*fse3v(ji,jj,jk)) * vmask(ji,jj,jk) 
     256                  vb(ji,jj,jk) = vb(ji,jj,jk) + atfp * ( vn(ji,jj,jk) - ztemp ) 
    217257               END DO 
    218258            END DO 
    … …  
    234274      INTEGER :: ji, jj, jk 
    235275      REAL(wp) :: zrhoy 
    236       REAL(wp) :: zhinv 
     276      REAL(wp) :: zhinv, ztemp 
    237277 
    238278      IF (before) THEN 
    … …  
    262302                  zhinv = (tabres(ji,jj)-spgu(ji,jj))/(hu(ji,jj)*e2u(ji,jj)) 
    263303                  Do jk=1,jpk               
    264                      un(ji,jj,jk) = un(ji,jj,jk) + zhinv 
    265                      un(ji,jj,jk) = un(ji,jj,jk) * umask(ji,jj,jk)             
     304                     ztemp        = un(ji,jj,jk)               
     305                     un(ji,jj,jk) = ( ztemp + zhinv ) * umask(ji,jj,jk)             
     306                     ub(ji,jj,jk) = ub(ji,jj,jk) + atfp * ( un(ji,jj,jk) - ztemp ) 
    266307                  END DO 
    267308               ENDIF 
    … …  
    283324      INTEGER :: ji, jj, jk 
    284325      REAL(wp) :: zrhox 
    285       REAL(wp) :: zhinv 
     326      REAL(wp) :: zhinv, ztemp 
    286327 
    287328      IF (before) THEN 
    … …  
    312353                  zhinv = (tabres(ji,jj)-spgv(ji,jj))/(hv(ji,jj)*e1v(ji,jj)) 
    313354                  DO jk=1,jpk              
    314                      vn(ji,jj,jk) = vn(ji,jj,jk) + zhinv 
    315                      vn(ji,jj,jk) = vn(ji,jj,jk) * vmask(ji,jj,jk) 
     355                     ztemp        = vn(ji,jj,jk)              
     356                     vn(ji,jj,jk) = ( ztemp + zhinv ) * vmask(ji,jj,jk) 
     357                     vb(ji,jj,jk) = vb(ji,jj,jk) + atfp * ( vn(ji,jj,jk) - ztemp ) 
    316358                  END DO 
    317359               ENDIF 
    … …  
    333375 
    334376      INTEGER :: ji, jj 
    335       REAL(wp) :: zrhox, zrhoy 
     377      REAL(wp) :: zrhox, zrhoy, ztemp 
    336378 
    337379      IF (before) THEN 
    … …  
    347389         DO jj=j1,j2 
    348390            DO ji=i1,i2 
    349                sshn(ji,jj) = tabres(ji,jj) / (e1t(ji,jj) * e2t(ji,jj)) 
    350                sshn(ji,jj) = sshn(ji,jj) * tmask(ji,jj,1) 
     391               ztemp       = sshn(ji,jj) 
     392               sshn(ji,jj) = tabres(ji,jj) / (e1t(ji,jj) * e2t(ji,jj)) * tmask(ji,jj,1) 
     393               sshb(ji,jj) = sshb(ji,jj) + atfp * ( sshn(ji,jj) - ztemp ) 
    351394            END DO 
    352395         END DO 
    … …  
    354397 
    355398   END SUBROUTINE updateSSH 
     399 
     400 
     401   SUBROUTINE updateglamT( tabres, i1, i2, j1, j2, before ) 
     402 
     403      INTEGER, INTENT(in) :: i1, i2, j1, j2 
     404      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
     405      LOGICAL, INTENT(in) :: before 
     406 
     407      INTEGER :: ji, jj 
     408      INTEGER :: icnt 
     409 
     410      IF (before) THEN 
     411         tabres(i1:i2,j1:j2) = glamt(i1:i2,j1:j2) 
     412      ELSE 
     413         icnt = 0  
     414         DO jj=j1,j2 
     415            DO ji=i1,i2 
     416               IF( ABS( glamt(ji,jj) - tabres(ji,jj)) > 1.e-2 ) THEN 
     417                  WRITE(numout,*) 'ERROR in glamt update at point ji,jj ', ji,jj 
     418                  WRITE(numout,*) '      glamt(ji,jj), tabres(ji,jj)) ', glamt(ji,jj), tabres(ji,jj) 
     419                  icnt = icnt + 1 
     420               ENDIF 
     421            END DO 
     422         END DO 
     423         IF(icnt /= 0) THEN  
     424            CALL ctl_stop('ERROR in glamt update...') 
     425         ELSE 
     426            IF(lwp) WRITE(numout,*) 'Update glamt ok...' 
     427         END IF 
     428      ENDIF 
     429 
     430   END SUBROUTINE updateglamT 
     431 
     432 
     433   SUBROUTINE updategphiT( tabres, i1, i2, j1, j2, before ) 
     434 
     435      INTEGER, INTENT(in) :: i1, i2, j1, j2 
     436      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
     437      LOGICAL, INTENT(in) :: before 
     438 
     439      INTEGER :: ji, jj 
     440      INTEGER :: icnt 
     441 
     442      IF (before) THEN 
     443         tabres(i1:i2,j1:j2) = gphit(i1:i2,j1:j2) 
     444      ELSE 
     445         icnt = 0  
     446         DO jj=j1,j2 
     447            DO ji=i1,i2 
     448               IF( ABS( gphit(ji,jj) - tabres(ji,jj)) > 1.e-2 ) THEN 
     449                  WRITE(numout,*) 'ERROR in gphit update at point ji,jj ', ji,jj 
     450                  WRITE(numout,*) '      gphit(ji,jj), tabres(ji,jj)) ', gphit(ji,jj), tabres(ji,jj) 
     451                  icnt = icnt + 1 
     452               ENDIF 
     453            END DO 
     454         END DO 
     455         IF(icnt /= 0) THEN  
     456            CALL ctl_stop('ERROR in gphit update...') 
     457         ELSE 
     458            IF(lwp) WRITE(numout,*) 'Update gphit ok...' 
     459         END IF 
     460      ENDIF 
     461 
     462   END SUBROUTINE updategphiT 
     463 
     464 
     465   SUBROUTINE updateAVT( tabres, i1, i2, j1, j2, k1, k2, before ) 
     466 
     467      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 
     468      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 
     469      LOGICAL, INTENT(in) :: before 
     470 
     471      IF (before) THEN 
     472         tabres(i1:i2,j1:j2,k1:k2) = avt_k(i1:i2,j1:j2,k1:k2) 
     473      ELSE 
     474         avt_k(i1:i2,j1:j2,k1:k2) = tabres(i1:i2,j1:j2,k1:k2)  
     475      ENDIF 
     476 
     477   END SUBROUTINE updateAVT 
     478 
     479 
     480   SUBROUTINE updateAVM( tabres, i1, i2, j1, j2, k1, k2, before ) 
     481 
     482      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 
     483      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 
     484      LOGICAL, INTENT(in) :: before 
     485 
     486      IF (before) THEN 
     487         tabres(i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2) 
     488      ELSE 
     489         avm_k(i1:i2,j1:j2,k1:k2) = tabres(i1:i2,j1:j2,k1:k2)  
     490      ENDIF 
     491 
     492   END SUBROUTINE updateAVM 
     493 
     494 
     495   SUBROUTINE updateAVMu( tabres, i1, i2, j1, j2, k1, k2, before ) 
     496 
     497      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 
     498      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 
     499      LOGICAL, INTENT(in) :: before 
     500 
     501      IF (before) THEN 
     502         tabres(i1:i2,j1:j2,k1:k2) = avmu_k(i1:i2,j1:j2,k1:k2) 
     503      ELSE 
     504         avmu_k(i1:i2,j1:j2,k1:k2) = tabres(i1:i2,j1:j2,k1:k2)  
     505      ENDIF 
     506 
     507   END SUBROUTINE updateAVMu 
     508 
     509 
     510   SUBROUTINE updateAVMv( tabres, i1, i2, j1, j2, k1, k2, before ) 
     511 
     512      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 
     513      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 
     514      LOGICAL, INTENT(in) :: before 
     515 
     516      IF (before) THEN 
     517         tabres(i1:i2,j1:j2,k1:k2) = avmv_k(i1:i2,j1:j2,k1:k2) 
     518      ELSE 
     519         avmv_k(i1:i2,j1:j2,k1:k2) = tabres(i1:i2,j1:j2,k1:k2)  
     520      ENDIF 
     521 
     522   END SUBROUTINE updateAVMv 
     523 
    356524 
    357525#else 

  • trunk/NEMOGCM/NEMO/NST_SRC/agrif_user.F90

    r7 r85  
    105105      IMPLICIT NONE 
    106106      ! 
     107#  include "domzgr_substitute.h90"   
     108      ! 
    107109      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: tabtstemp 
    108110      REAL(wp), DIMENSION(:,:,:  ), ALLOCATABLE :: tabuvtemp 
    109111      LOGICAL :: check_namelist 
     112      INTEGER :: ji,jj,jk 
    110113      !!---------------------------------------------------------------------- 
    111114 
    … …  
    209212      CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts/),tsb_id) 
    210213 
     214      CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avt_id) 
     215      CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avm_id) 
     216      CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avmu_id) 
     217      CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avmv_id) 
     218 
    211219      CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),un_id) 
    212220      CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),vn_id) 
    213221      CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),ua_id) 
    214222      CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),va_id) 
     223 
     224      CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),e3t_id) 
    215225    
    216226      CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),e1u_id) 
    … …  
    220230      CALL agrif_declare_variable((/2,2/),(/3,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),gcb_id) 
    221231        
     232      CALL agrif_declare_variable((/2,2/),(/3,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),glamt_id) 
     233      CALL agrif_declare_variable((/2,2/),(/3,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),gphit_id) 
     234 
    222235      ! 2. Type of interpolation 
    223236      !------------------------- 
    224237      CALL Agrif_Set_bcinterp(tsn_id,interp=AGRIF_linear) 
    225238      CALL Agrif_Set_bcinterp(tsa_id,interp=AGRIF_linear) 
    226     
     239 
     240      CALL Agrif_Set_bcinterp(avt_id,interp=AGRIF_linear) 
     241      CALL Agrif_Set_bcinterp(avm_id,interp=AGRIF_linear) 
     242      CALL Agrif_Set_bcinterp(avmu_id,interp=AGRIF_linear) 
     243      CALL Agrif_Set_bcinterp(avmv_id,interp=AGRIF_linear) 
     244 
    227245      Call Agrif_Set_bcinterp(un_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    228246      Call Agrif_Set_bcinterp(vn_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
    … …  
    231249      Call Agrif_Set_bcinterp(va_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
    232250 
     251      Call Agrif_Set_bcinterp(e3t_id,interp=AGRIF_constant) 
     252 
    233253      Call Agrif_Set_bcinterp(e1u_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    234254      Call Agrif_Set_bcinterp(e2v_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
    … …  
    236256      ! 3. Location of interpolation 
    237257      !----------------------------- 
    238       Call Agrif_Set_bc(un_id,(/0,1/)) 
     258      Call Agrif_Set_bc(un_id,(/0,1/)) ! if west: column 1 and 2  
    239259      Call Agrif_Set_bc(vn_id,(/0,1/)) 
     260 
     261      Call Agrif_Set_bc(e3t_id,(/-3*Agrif_irhox(),0/))   ! if west and rhox=3: column 2 to 11 
    240262 
    241263      Call Agrif_Set_bc(e1u_id,(/0,0/)) 
    242264      Call Agrif_Set_bc(e2v_id,(/0,0/)) 
    243265 
    244       Call Agrif_Set_bc(tsn_id,(/0,1/)) 
     266      Call Agrif_Set_bc(tsn_id,(/0,1/)) ! if west: column 1 and 2  
    245267      Call Agrif_Set_bc(tsa_id,(/-3*Agrif_irhox(),0/)) 
     268 
     269      Call Agrif_Set_bc(avt_id,(/0,1/)) 
     270      Call Agrif_Set_bc(avm_id,(/0,1/)) 
     271      Call Agrif_Set_bc(avmu_id,(/0,1/)) 
     272      Call Agrif_Set_bc(avmv_id,(/0,1/)) 
    246273 
    247274      Call Agrif_Set_bc(ua_id,(/-2*Agrif_irhox(),0/)) 
    … …  
    254281 
    255282      Call Agrif_Set_Updatetype(sshn_id, update = AGRIF_Update_Average) 
    256       Call Agrif_Set_Updatetype(gcb_id,update = AGRIF_Update_Average) 
     283      Call Agrif_Set_Updatetype(gcb_id, update = AGRIF_Update_Average) 
    257284 
    258285      Call Agrif_Set_Updatetype(un_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 
    … …  
    261288      Call Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Copy, update2=Agrif_Update_Average) 
    262289      Call Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Average, update2=Agrif_Update_Copy) 
     290 
     291      CALL Agrif_Set_Updatetype(glamt_id, update = AGRIF_Update_Average) 
     292      CALL Agrif_Set_Updatetype(gphit_id, update = AGRIF_Update_Average) 
     293 
     294      CALL Agrif_Set_Updatetype(avt_id, update = AGRIF_Update_Average) 
     295      CALL Agrif_Set_Updatetype(avm_id, update = AGRIF_Update_Average) 
     296      CALL Agrif_Set_Updatetype(avmu_id, update = AGRIF_Update_Average) 
     297      CALL Agrif_Set_Updatetype(avmv_id, update = AGRIF_Update_Average) 
    263298 
    264299   END SUBROUTINE agrif_declare_var 

  • trunk/NEMOGCM/NEMO/OPA_SRC/DOM/domzgr.F90

    r72 r85  
    970970      CALL lbc_lnk( e3v , 'V', 1._wp )   ;   CALL lbc_lnk( e3vw, 'V', 1._wp ) 
    971971      ! 
     972      DO jk = 1,jpkm1                         ! Computed as the minimum of neighbooring scale factors 
     973         DO jj = 1, jpj 
     974            DO ji = mi0(1),mi1(1) 
     975               e3u(ji,jj,jk) = MIN(e3t(ji,jj,jk),e3t(ji+1,jj,jk)) 
     976            END DO 
     977         END DO 
     978      END DO 
     979      DO jk = 1,jpkm1                         ! Computed as the minimum of neighbooring scale factors 
     980         DO jj = mj0(1),mj1(1) 
     981            DO ji = 1, jpi 
     982               e3v(ji,jj,jk) = MIN(e3t(ji,jj,jk),e3t(ji,jj+1,jk)) 
     983            END DO 
     984         END DO 
     985      END DO 
     986 
    972987      DO jk = 1, jpk                        ! set to z-scale factor if zero (i.e. along closed boundaries) 
    973988         WHERE( e3u (:,:,jk) == 0._wp )   e3u (:,:,jk) = e3t_0(jk) 
    … …  
    976991         WHERE( e3vw(:,:,jk) == 0._wp )   e3vw(:,:,jk) = e3w_0(jk) 
    977992      END DO 
     993      
    978994       
    979995      ! Scale factor at F-point 
    … …  
    9951011!!gm  bug ? :  must be a do loop with mj0,mj1 
    9961012      !  
    997       e3t(:,mj0(1),:) = e3t(:,mj0(2),:)     ! we duplicate factor scales for jj = 1 and jj = 2 
    998       e3w(:,mj0(1),:) = e3w(:,mj0(2),:)  
    999       e3u(:,mj0(1),:) = e3u(:,mj0(2),:)  
    1000       e3v(:,mj0(1),:) = e3v(:,mj0(2),:)  
    1001       e3f(:,mj0(1),:) = e3f(:,mj0(2),:)  
     1013!!$      e3t(:,mj0(1),:) = e3t(:,mj0(2),:)     ! we duplicate factor scales for jj = 1 and jj = 2 
     1014!!$      e3w(:,mj0(1),:) = e3w(:,mj0(2),:)  
     1015!!$      e3u(:,mj0(1),:) = e3u(:,mj0(2),:)  
     1016!!$      e3v(:,mj0(1),:) = e3v(:,mj0(2),:)  
     1017!!$      e3f(:,mj0(1),:) = e3f(:,mj0(2),:)  
    10021018 
    10031019      ! Control of the sign 

  • trunk/NEMOGCM/NEMO/OPA_SRC/TRA/tranxt.F90

    r7 r85  
    119119#endif 
    120120#if defined key_agrif 
    121       CALL Agrif_tra                     ! AGRIF zoom boundaries 
     121      CALL Agrif_tra( kt )               ! AGRIF zoom boundaries 
    122122#endif 
    123123  

  • trunk/NEMOGCM/NEMO/OPA_SRC/ZDF/zdf_oce.F90

    r1 r85  
    4242   REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::   avmu , avmv    !: vertical viscosity coef at uw- & vw-pts       [m2/s] 
    4343   REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::   avm  , avt     !: vertical viscosity & diffusivity coef at w-pt [m2/s] 
     44   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avt_k , avm_k  ! not enhanced Kz 
     45   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avmu_k, avmv_k ! not enhanced Kz 
    4446  
    4547   !!---------------------------------------------------------------------- 
    … …  
    5860         &     avtb(jpk) , bfrva(jpi,jpj) , avtb_2d(jpi,jpj) ,      & 
    5961         &     avmu(jpi,jpj,jpk), avm(jpi,jpj,jpk)           ,      & 
    60          &     avmv(jpi,jpj,jpk), avt(jpi,jpj,jpk)           , STAT = zdf_oce_alloc ) 
     62         &     avmv(jpi,jpj,jpk), avt(jpi,jpj,jpk)           ,      & 
     63         &     avt_k (jpi,jpj,jpk), avm_k (jpi,jpj,jpk)      ,      & 
     64         &     avmu_k(jpi,jpj,jpk), avmv_k(jpi,jpj,jpk)      ,      & 
     65         &     STAT = zdf_oce_alloc ) 
    6166         ! 
    6267      IF( zdf_oce_alloc /= 0 )   CALL ctl_warn('zdf_oce_alloc: failed to allocate arrays') 

  • trunk/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftke.F90

    r46 r85  
    5151   USE wrk_nemo       ! work arrays 
    5252   USE timing         ! Timing 
     53#if defined key_agrif 
     54   USE agrif_opa_interp 
     55   USE agrif_opa_update 
     56#endif 
    5357 
    5458   IMPLICIT NONE 
    … …  
    8690   REAL(wp)        , ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   htau           ! depth of tke penetration (nn_htau) 
    8791   REAL(wp)        , ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   dissl          ! now mixing lenght of dissipation 
    88    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avt_k , avm_k  ! not enhanced Kz 
    89    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avmu_k, avmv_k ! not enhanced Kz 
    9092#if defined key_c1d 
    9193   !                                                                        !!** 1D cfg only  **   ('key_c1d') 
    … …  
    9395   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e_pdl, e_ric   !: prandl and local Richardson numbers 
    9496#endif 
     97   REAL(wp)        , ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   wei3d          !  
     98   REAL(wp)        , ALLOCATABLE, SAVE, DIMENSION(:,:  ) ::   wmix           !  
    9599 
    96100   !! * Substitutions 
    … …  
    113117         &      e_pdl(jpi,jpj,jpk) , e_ric(jpi,jpj,jpk) ,                          & 
    114118#endif 
    115          &      en    (jpi,jpj,jpk) , htau  (jpi,jpj)    , dissl(jpi,jpj,jpk) ,     &  
    116          &      avt_k (jpi,jpj,jpk) , avm_k (jpi,jpj,jpk),                          & 
    117          &      avmu_k(jpi,jpj,jpk) , avmv_k(jpi,jpj,jpk), STAT= zdf_tke_alloc      ) 
     119         &      en    (jpi,jpj,jpk) , htau  (jpi,jpj)    , dissl(jpi,jpj,jpk) ,    &  
     120         &      STAT= zdf_tke_alloc      ) 
    118121         ! 
    119122      IF( lk_mpp             )   CALL mpp_sum ( zdf_tke_alloc ) 
    120123      IF( zdf_tke_alloc /= 0 )   CALL ctl_warn('zdf_tke_alloc: failed to allocate arrays') 
     124      ! 
     125      IF(.NOT. Agrif_Root()) THEN 
     126         ALLOCATE( wei3d(jpi,jpj,jpk), wmix(jpi,jpj), STAT= zdf_tke_alloc ) 
     127         IF( lk_mpp             )   CALL mpp_sum ( zdf_tke_alloc ) 
     128         IF( zdf_tke_alloc /= 0 )   CALL ctl_warn('zdf_tke_alloc2: failed to allocate arrays') 
     129      ENDIF 
    121130      ! 
    122131   END FUNCTION zdf_tke_alloc 
    … …  
    172181      ! 
    173182      IF( kt /= nit000 ) THEN   ! restore before value to compute tke 
     183#if defined key_agrif  
     184         ! interpolation parent grid => child grid for avt_k, avm_k, avmu_k, avmv_k (at west border: update column 1 and 2) 
     185         CALL Agrif_Tke    
     186#endif 
    174187         avt (:,:,:) = avt_k (:,:,:)  
    175188         avm (:,:,:) = avm_k (:,:,:)  
    … …  
    187200      avmv_k(:,:,:) = avmv(:,:,:)  
    188201      ! 
     202#if defined key_agrif 
     203      ! Update child grid f => parent grid  
     204      IF( .NOT.Agrif_Root() )    CALL Agrif_Update_Tke( kt )      ! children only 
     205#endif       
     206 
     207 
    189208   END SUBROUTINE zdf_tke 
    190209 
    … …  
    491510      REAL(wp) ::   zdku, zpdlr, zri, zsqen     !   -      - 
    492511      REAL(wp) ::   zdkv, zemxl, zemlm, zemlp   !   -      - 
     512      REAL(wp), POINTER, DIMENSION(:,:  ) :: ztmp2d 
    493513      REAL(wp), POINTER, DIMENSION(:,:,:) :: zmpdl, zmxlm, zmxld 
    494514      !!-------------------------------------------------------------------- 
    … …  
    496516      IF( nn_timing == 1 )  CALL timing_start('tke_avn') 
    497517 
     518      CALL wrk_alloc( jpi,jpj, ztmp2d )  
    498519      CALL wrk_alloc( jpi,jpj,jpk, zmpdl, zmxlm, zmxld )  
    499520 
    … …  
    626647      END DO 
    627648      CALL lbc_lnk( avm, 'W', 1. )      ! Lateral boundary conditions (sign unchanged) 
     649      ! 
     650      IF(.NOT. Agrif_Root()) THEN 
     651          
     652         DO jk = 1, jpkm1 
     653            DO jj = 2, jpjm1 
     654               DO ji = 2, jpim1 
     655                  ztmp2d(ji,jj) = 1. * avm(ji-1,jj-1,jk) * tmask(ji-1,jj-1,jk)   & 
     656                     &          + 2. * avm(ji  ,jj-1,jk) * tmask(ji  ,jj-1,jk)   & 
     657                     &          + 1. * avm(ji+1,jj-1,jk) * tmask(ji+1,jj-1,jk)   & 
     658                     &          + 2. * avm(ji-1,jj  ,jk) * tmask(ji-1,jj  ,jk)   & 
     659                     &          + 4. * avm(ji  ,jj  ,jk) * tmask(ji  ,jj  ,jk)   & 
     660                     &          + 2. * avm(ji+1,jj  ,jk) * tmask(ji+1,jj  ,jk)   & 
     661                     &          + 1. * avm(ji-1,jj+1,jk) * tmask(ji-1,jj+1,jk)   & 
     662                     &          + 2. * avm(ji  ,jj+1,jk) * tmask(ji  ,jj+1,jk)   & 
     663                     &          + 1. * avm(ji+1,jj+1,jk) * tmask(ji+1,jj+1,jk) 
     664               END DO 
     665            END DO 
     666            DO jj = 2, jpjm1 
     667               DO ji = 2, jpim1 
     668                  avm(ji,jj,jk) = ztmp2d(ji,jj) * wei3d(ji,jj,jk) * wmix(ji,jj) + avm(ji,jj,jk) * ( 1. - wmix(ji,jj) ) 
     669               END DO 
     670            END DO 
     671         END DO 
     672         CALL lbc_lnk( avm, 'W', 1. )      ! Lateral boundary conditions (sign unchanged) 
     673         DO jk = 1, jpkm1 
     674            DO jj = 2, jpjm1 
     675               DO ji = 2, jpim1 
     676                  ztmp2d(ji,jj) = 1. * avt(ji-1,jj-1,jk) * tmask(ji-1,jj-1,jk)   & 
     677                     &          + 2. * avt(ji  ,jj-1,jk) * tmask(ji  ,jj-1,jk)   & 
     678                     &          + 1. * avt(ji+1,jj-1,jk) * tmask(ji+1,jj-1,jk)   & 
     679                     &          + 2. * avt(ji-1,jj  ,jk) * tmask(ji-1,jj  ,jk)   & 
     680                     &          + 4. * avt(ji  ,jj  ,jk) * tmask(ji  ,jj  ,jk)   & 
     681                     &          + 2. * avt(ji+1,jj  ,jk) * tmask(ji+1,jj  ,jk)   & 
     682                     &          + 1. * avt(ji-1,jj+1,jk) * tmask(ji-1,jj+1,jk)   & 
     683                     &          + 2. * avt(ji  ,jj+1,jk) * tmask(ji  ,jj+1,jk)   & 
     684                     &          + 1. * avt(ji+1,jj+1,jk) * tmask(ji+1,jj+1,jk) 
     685               END DO 
     686            END DO 
     687            DO jj = 2, jpjm1 
     688               DO ji = 2, jpim1 
     689                  avt(ji,jj,jk) = ztmp2d(ji,jj) * wei3d(ji,jj,jk) * wmix(ji,jj) + avt(ji,jj,jk) * ( 1. - wmix(ji,jj) ) 
     690               END DO 
     691            END DO 
     692         END DO 
     693         CALL lbc_lnk( avt, 'W', 1. )      ! Lateral boundary conditions (sign unchanged) 
     694 
     695      END IF 
    628696      ! 
    629697      DO jk = 2, jpkm1            !* vertical eddy viscosity at u- and v-points 
    … …  
    662730      ENDIF 
    663731      CALL lbc_lnk( avt, 'W', 1. )                      ! Lateral boundary conditions on avt  (sign unchanged) 
    664  
     732      ! 
    665733      IF(ln_ctl) THEN 
    666734         CALL prt_ctl( tab3d_1=en  , clinfo1=' tke  - e: ', tab3d_2=avt, clinfo2=' t: ', ovlap=1, kdim=jpk) 
    … …  
    669737      ENDIF 
    670738      ! 
     739      CALL wrk_dealloc( jpi,jpj, ztmp2d )  
    671740      CALL wrk_dealloc( jpi,jpj,jpk, zmpdl, zmxlm, zmxld )  
    672741      ! 
    … …  
    766835      CALL tke_rst( nit000, 'READ' )  !* read or initialize all required files 
    767836      ! 
     837      IF(.NOT. Agrif_Root()) THEN 
     838 
     839         wei3d(:,:,:) = 1. 
     840         DO jk = 1, jpkm1 
     841            DO jj = 2, jpjm1 
     842               DO ji = 2, jpim1   
     843                  wei3d(ji,jj,jk) =   & 
     844                     &   1.*tmask(ji-1,jj-1,jk) + 2.*tmask(ji,jj-1,jk) + 1.*tmask(ji+1,jj-1,jk)& 
     845                     & + 2.*tmask(ji-1,jj  ,jk) + 4.*tmask(ji,jj  ,jk) + 2.*tmask(ji+1,jj  ,jk)& 
     846                     & + 1.*tmask(ji-1,jj+1,jk) + 2.*tmask(ji,jj+1,jk) + 1.*tmask(ji+1,jj+1,jk) 
     847                  wei3d(ji,jj,jk) = tmask(ji,jj,jk) / MAX( 1., wei3d(ji,jj,jk) ) 
     848               END DO 
     849            END DO 
     850         END DO 
     851         CALL lbc_lnk( wei3d, 'T', 1. ) 
     852 
     853         wmix(:,:) = 0. 
     854         wmix(mi0(2):mi1(jpiglo-1),mj0(2):mj1(jpjglo-1)) = 1. 
     855         wmix(mi0(6):mi1(jpiglo-5),mj0(6):mj1(jpjglo-5)) = 0.75 
     856         wmix(mi0(7):mi1(jpiglo-6),mj0(7):mj1(jpjglo-6)) = 0.5 
     857         wmix(mi0(8):mi1(jpiglo-7),mj0(8):mj1(jpjglo-7)) = 0.25 
     858         wmix(mi0(9):mi1(jpiglo-8),mj0(9):mj1(jpjglo-8)) = 0. 
     859 
     860      END IF 
     861 
    768862   END SUBROUTINE zdf_tke_init 
    769863 

  • trunk/NEMOGCM/NEMO/OPA_SRC/step.F90

    r80 r85  
    3333   USE trcstp           ! passive tracer time-stepping      (trc_stp routine) 
    3434#endif 
    35 #if defined key_agrif 
    36    USE agrif_opa_sponge ! Momemtum and tracers sponges 
    37 #endif 
    3835 
    3936   IMPLICIT NONE 
    … …  
    218215                             CALL tra_nxt( kstp )                ! tracer fields at next time step 
    219216      ENDIF  
    220  
    221217      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    222218      ! Dynamics                                    (tsa used as workspace) 
Note: See TracChangeset for help on using the changeset viewer.