! ======================================================================================
! This file was generated by the version 5.3.6 of DFT on 08/10/2010. The differentiation
! transforming system(DFT) was jointly developed and sponsored by LASG of IAP(1998-2010)
! and LSEC of ICMSEC, AMSS(2001-2003)
! The copyright of the DFT system was declared by Walls at LASG, 1998-2010
! ======================================================================================
MODULE g_module_diffusion_em
USE g_module_bc, only: g_set_physical_bc3d
USE module_state_description, only: p_m23, p_m13, p_m22, p_m33, p_r23, p_r13, p_r12, p_m12, p_m11
USE g_module_big_step_utilities_em, only: grid_config_rec_type, param_first_scalar, p_qv, p_qi, p_qc
USE module_model_constants
CONTAINS
SUBROUTINE g_cal_deform_and_div(config_flags,u,g_u,v,g_v,w,g_w,div, &
g_div,defor11,g_defor11,defor22,g_defor22,defor33,g_defor33,defor12, &
g_defor12,defor13,g_defor13,defor23,g_defor23,nba_rij,g_nba_rij, &
n_nba_rij,u_base,v_base,msfux,msfuy,msfvx,msfvy,msftx,msfty,rdx,rdy,dn,dnw,rdz, &
g_rdz,rdzw,g_rdzw,fnm,fnp,cf1,cf2,cf3,zx,g_zx,zy,g_zy,ids,ide,jds,jde, &
kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
IMPLICIT NONE
REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2,Tmpv3,g_Tmpv3,Tmpv4,g_Tmpv4,Tmpv5, &
g_Tmpv5,Tmpv6,g_Tmpv6
TYPE(grid_config_rec_type) :: config_flags
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
REAL :: rdx,rdy,cf1,cf2,cf3
REAL,DIMENSION(kms:kme) :: fnm,fnp,dn,dnw,u_base,v_base
REAL,DIMENSION(ims:ime,jms:jme) :: msfux,msfuy,msfvx,msfvy,msftx,msfty
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: u,g_u,v,g_v,w,g_w,zx,g_zx,zy, &
g_zy,rdz,g_rdz,rdzw,g_rdzw
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor11,g_defor11,defor22,g_defor22, &
defor33,g_defor33,defor12,g_defor12,defor13,g_defor13,defor23,g_defor23, &
div,g_div
INTEGER :: n_nba_rij
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_nba_rij) :: nba_rij,g_nba_rij
INTEGER :: i,j,k,ktf,ktes1,ktes2,i_start,i_end,j_start,j_end
REAL :: tmp,g_tmp,tmpzx,g_tmpzx,tmpzy,g_tmpzy,tmpzeta_z,g_tmpzeta_z,cft1, &
g_cft1,cft2,g_cft2
REAL,DIMENSION(its:ite,jts:jte) :: mm,g_mm,zzavg,g_zzavg,zeta_zd12,g_zeta_zd12
REAL,DIMENSION(its-2:ite+2,kts:kte,jts-2:jte+2) :: tmp1,g_tmp1,hat,g_hat, &
hatavg,g_hatavg
ktes1 =kte-1
ktes2 =kte-2
g_cft2 =0.0
cft2 =-0.5 *dnw(ktes1)/dn(ktes1)
g_cft1 =-g_cft2
cft1 =1.0 -cft2
ktf =min(kte,kde-1)
i_start =its
i_end =min(ite,ide-1)
j_start =jts
j_end =min(jte,jde-1)
DO j =j_start,j_end
DO i =i_start,i_end
g_mm(i,j) =0.0
mm(i,j) =msftx(i,j) *msfty(i,j)
ENDDO
ENDDO
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end+1
g_hat(i,k,j) =g_u(i,k,j)/msfuy(i,j)
hat(i,k,j) =u(i,k,j)/msfuy(i,j)
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO k =kts+1,ktf
DO i =i_start,i_end
g_hatavg(i,k,j) =0.5*(fnm(k)*(g_hat(i,k,j) +g_hat(i+1,k,j)) +fnp(k) &
*(g_hat(i,k-1,j) +g_hat(i+1,k-1,j)))
hatavg(i,k,j) =0.5*(fnm(k)*(hat(i,k,j) +hat(i+1,k,j)) +fnp(k)*(hat(i,k-1,j) &
+hat(i+1,k-1,j)))
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO i =i_start,i_end
g_hatavg(i,1,j) =0.5*(cf1*g_hat(i,1,j) +cf2*g_hat(i,2,j) +cf3*g_hat(i,3, &
j) +cf1*g_hat(i+1,1,j) +cf2*g_hat(i+1,2,j) +cf3*g_hat(i+1,3,j))
hatavg(i,1,j) =0.5*(cf1*hat(i,1,j) +cf2*hat(i,2,j) +cf3*hat(i,3,j) +cf1*hat(i+1,1,j) &
+cf2*hat(i+1,2,j) +cf3*hat(i+1,3,j))
g_Tmpv1 =cft1*(g_hat(i,ktes1,j) +g_hat(i+1,ktes1,j)) +g_cft1*(hat(i, &
ktes1,j) +hat(i+1,ktes1,j))
Tmpv1 =cft1*(hat(i,ktes1,j) +hat(i+1,ktes1,j))
g_Tmpv2 =cft2*(g_hat(i,ktes2,j) +g_hat(i+1,ktes2,j)) +g_cft2*(hat(i, &
ktes2,j) +hat(i+1,ktes2,j))
Tmpv2 =cft2*(hat(i,ktes2,j) +hat(i+1,ktes2,j))
g_hatavg(i,kte,j) =0.5*(g_Tmpv1 +g_Tmpv2)
hatavg(i,kte,j) =0.5*(Tmpv1 +Tmpv2)
ENDDO
ENDDO
!LPB[5]
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_tmpzx =0.25*(g_zx(i,k,j) +g_zx(i+1,k,j) +g_zx(i,k+1,j) +g_zx(i+1,k+1,j))
tmpzx =0.25*(zx(i,k,j) +zx(i+1,k,j) +zx(i,k+1,j) +zx(i+1,k+1,j))
g_Tmpv1 =(hatavg(i,k+1,j) -hatavg(i,k,j))*g_tmpzx +(g_hatavg(i,k+1,j) &
-g_hatavg(i,k,j))*tmpzx
Tmpv1 =(hatavg(i,k+1,j) -hatavg(i,k,j))*tmpzx
g_Tmpv2 =Tmpv1*g_rdzw(i,k,j) +g_Tmpv1*rdzw(i,k,j)
Tmpv2 =Tmpv1*rdzw(i,k,j)
g_tmp1(i,k,j) =g_Tmpv2
tmp1(i,k,j) =Tmpv2
ENDDO
ENDDO
ENDDO
!LPB[6]
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_Tmpv1 =mm(i,j)*(rdx*(g_hat(i+1,k,j) -g_hat(i,k,j)) -g_tmp1(i,k,j)) &
+g_mm(i,j)*(rdx*(hat(i+1,k,j) -hat(i,k,j)) -tmp1(i,k,j))
Tmpv1 =mm(i,j)*(rdx*(hat(i+1,k,j) -hat(i,k,j)) -tmp1(i,k,j))
g_tmp1(i,k,j) =g_Tmpv1
tmp1(i,k,j) =Tmpv1
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_defor11(i,k,j) =2.0*g_tmp1(i,k,j)
defor11(i,k,j) =2.0*tmp1(i,k,j)
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_div(i,k,j) =g_tmp1(i,k,j)
div(i,k,j) =tmp1(i,k,j)
ENDDO
ENDDO
ENDDO
!LPB[9]
DO j =j_start,j_end+1
DO k =kts,ktf
DO i =i_start,i_end
IF((config_flags%polar) .AND. ((j == jds) .OR. (j == jde))) THEN
g_hat(i,k,j) =0.0
hat(i,k,j) =0.
ELSE
g_hat(i,k,j) =g_v(i,k,j)/msfvx(i,j)
hat(i,k,j) =v(i,k,j)/msfvx(i,j)
ENDIF
ENDDO
ENDDO
ENDDO
!LPB[10]
DO j =j_start,j_end
DO k =kts+1,ktf
DO i =i_start,i_end
g_hatavg(i,k,j) =0.5*(fnm(k)*(g_hat(i,k,j) +g_hat(i,k,j+1)) +fnp(k) &
*(g_hat(i,k-1,j) +g_hat(i,k-1,j+1)))
hatavg(i,k,j) =0.5*(fnm(k)*(hat(i,k,j) +hat(i,k,j+1)) +fnp(k)*(hat(i,k-1,j) &
+hat(i,k-1,j+1)))
ENDDO
ENDDO
ENDDO
!LPB[11]
DO j =j_start,j_end
DO i =i_start,i_end
g_hatavg(i,1,j) =0.5*(cf1*g_hat(i,1,j) +cf2*g_hat(i,2,j) +cf3*g_hat(i,3, &
j) +cf1*g_hat(i,1,j+1) +cf2*g_hat(i,2,j+1) +cf3*g_hat(i,3,j+1))
hatavg(i,1,j) =0.5*(cf1*hat(i,1,j) +cf2*hat(i,2,j) +cf3*hat(i,3,j) +cf1*hat(i,1,j+1) &
+cf2*hat(i,2,j+1) +cf3*hat(i,3,j+1))
g_Tmpv1 =cft1*(g_hat(i,ktes1,j) +g_hat(i,ktes1,j+1)) +g_cft1*(hat(i, &
ktes1,j) +hat(i,ktes1,j+1))
Tmpv1 =cft1*(hat(i,ktes1,j) +hat(i,ktes1,j+1))
g_Tmpv2 =cft2*(g_hat(i,ktes2,j) +g_hat(i,ktes2,j+1)) +g_cft2*(hat(i, &
ktes2,j) +hat(i,ktes2,j+1))
Tmpv2 =cft2*(hat(i,ktes2,j) +hat(i,ktes2,j+1))
g_hatavg(i,kte,j) =0.5*(g_Tmpv1 +g_Tmpv2)
hatavg(i,kte,j) =0.5*(Tmpv1 +Tmpv2)
ENDDO
ENDDO
!LPB[12]
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_tmpzy =0.25*(g_zy(i,k,j) +g_zy(i,k,j+1) +g_zy(i,k+1,j) +g_zy(i,k+1,j+1))
tmpzy =0.25*(zy(i,k,j) +zy(i,k,j+1) +zy(i,k+1,j) +zy(i,k+1,j+1))
g_Tmpv1 =(hatavg(i,k+1,j) -hatavg(i,k,j))*g_tmpzy +(g_hatavg(i,k+1,j) &
-g_hatavg(i,k,j))*tmpzy
Tmpv1 =(hatavg(i,k+1,j) -hatavg(i,k,j))*tmpzy
g_Tmpv2 =Tmpv1*g_rdzw(i,k,j) +g_Tmpv1*rdzw(i,k,j)
Tmpv2 =Tmpv1*rdzw(i,k,j)
g_tmp1(i,k,j) =g_Tmpv2
tmp1(i,k,j) =Tmpv2
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_Tmpv1 =mm(i,j)*(rdy*(g_hat(i,k,j+1) -g_hat(i,k,j)) -g_tmp1(i,k,j)) &
+g_mm(i,j)*(rdy*(hat(i,k,j+1) -hat(i,k,j)) -tmp1(i,k,j))
Tmpv1 =mm(i,j)*(rdy*(hat(i,k,j+1) -hat(i,k,j)) -tmp1(i,k,j))
g_tmp1(i,k,j) =g_Tmpv1
tmp1(i,k,j) =Tmpv1
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_defor22(i,k,j) =2.0*g_tmp1(i,k,j)
defor22(i,k,j) =2.0*tmp1(i,k,j)
ENDDO
ENDDO
ENDDO
!LPB[15]
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_div(i,k,j) =g_div(i,k,j) +g_tmp1(i,k,j)
div(i,k,j) =div(i,k,j) +tmp1(i,k,j)
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_Tmpv1 =(w(i,k+1,j) -w(i,k,j))*g_rdzw(i,k,j) +(g_w(i,k+1,j) -g_w(i,k, &
j))*rdzw(i,k,j)
Tmpv1 =(w(i,k+1,j) -w(i,k,j))*rdzw(i,k,j)
g_tmp1(i,k,j) =g_Tmpv1
tmp1(i,k,j) =Tmpv1
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_defor33(i,k,j) =2.0*g_tmp1(i,k,j)
defor33(i,k,j) =2.0*tmp1(i,k,j)
ENDDO
ENDDO
ENDDO
!LPB[18]
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_div(i,k,j) =g_div(i,k,j) +g_tmp1(i,k,j)
div(i,k,j) =div(i,k,j) +tmp1(i,k,j)
ENDDO
ENDDO
ENDDO
!LPB[19]
i_start =its
i_end =ite
j_start =jts
j_end =jte
IF( config_flags%open_xs .OR. config_flags%specified .OR. &
config_flags%nested) i_start =max(ids+1,its)
IF( config_flags%open_xe .OR. config_flags%specified .OR. &
config_flags%nested) i_end =min(ide-1,ite)
IF( config_flags%open_ys .OR. config_flags%specified .OR. &
config_flags%nested) j_start =max(jds+1,jts)
IF( config_flags%open_ye .OR. config_flags%specified .OR. &
config_flags%nested) j_end =min(jde-1,jte)
IF( config_flags%periodic_x ) i_start =its
IF( config_flags%periodic_x ) i_end =ite
DO j =j_start,j_end
DO i =i_start,i_end
g_mm(i,j) =0.0
mm(i,j) =0.25 *(msfux(i,j-1)+msfux(i,j)) *(msfvy(i-1,j)+msfvy(i,j))
ENDDO
ENDDO
DO j =j_start-1,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_hat(i,k,j) =g_u(i,k,j)/msfux(i,j)
hat(i,k,j) =u(i,k,j)/msfux(i,j)
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO k =kts+1,ktf
DO i =i_start,i_end
g_hatavg(i,k,j) =0.5*(fnm(k)*(g_hat(i,k,j-1) +g_hat(i,k,j)) +fnp(k) &
*(g_hat(i,k-1,j-1) +g_hat(i,k-1,j)))
hatavg(i,k,j) =0.5*(fnm(k)*(hat(i,k,j-1) +hat(i,k,j)) +fnp(k)*(hat(i,k-1,j-1) &
+hat(i,k-1,j)))
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO i =i_start,i_end
g_hatavg(i,1,j) =0.5*(cf1*g_hat(i,1,j-1) +cf2*g_hat(i,2,j-1) +cf3*g_hat( &
i,3,j-1) +cf1*g_hat(i,1,j) +cf2*g_hat(i,2,j) +cf3*g_hat(i,3,j))
hatavg(i,1,j) =0.5*(cf1*hat(i,1,j-1) +cf2*hat(i,2,j-1) +cf3*hat(i,3,j-1) &
+cf1*hat(i,1,j) +cf2*hat(i,2,j) +cf3*hat(i,3,j))
g_Tmpv1 =cft1*(g_hat(i,ktes1,j-1) +g_hat(i,ktes1,j)) +g_cft1*(hat(i, &
ktes1,j-1) +hat(i,ktes1,j))
Tmpv1 =cft1*(hat(i,ktes1,j-1) +hat(i,ktes1,j))
g_Tmpv2 =cft2*(g_hat(i,ktes2,j-1) +g_hat(i,ktes2,j)) +g_cft2*(hat(i, &
ktes2,j-1) +hat(i,ktes2,j))
Tmpv2 =cft2*(hat(i,ktes2,j-1) +hat(i,ktes2,j))
g_hatavg(i,kte,j) =0.5*(g_Tmpv1 +g_Tmpv2)
hatavg(i,kte,j) =0.5*(Tmpv1 +Tmpv2)
ENDDO
ENDDO
!LPB[35]
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_tmpzy =0.25*(g_zy(i-1,k,j) +g_zy(i,k,j) +g_zy(i-1,k+1,j) +g_zy(i,k+1,j))
tmpzy =0.25*(zy(i-1,k,j) +zy(i,k,j) +zy(i-1,k+1,j) +zy(i,k+1,j))
g_Tmpv1 =(hatavg(i,k+1,j) -hatavg(i,k,j))*0.25*g_tmpzy +(g_hatavg(i,k+1,j) &
-g_hatavg(i,k,j))*0.25*tmpzy
Tmpv1 =(hatavg(i,k+1,j) -hatavg(i,k,j))*0.25*tmpzy
g_Tmpv2 =Tmpv1*(g_rdzw(i,k,j) +g_rdzw(i-1,k,j) +g_rdzw(i-1,k,j-1) &
+g_rdzw(i,k,j-1)) +g_Tmpv1*(rdzw(i,k,j) +rdzw(i-1,k,j) +rdzw(i-1,k,j-1) +rdzw(i,k,j-1))
Tmpv2 =Tmpv1*(rdzw(i,k,j) +rdzw(i-1,k,j) +rdzw(i-1,k,j-1) +rdzw(i,k,j-1))
g_tmp1(i,k,j) =g_Tmpv2
tmp1(i,k,j) =Tmpv2
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_Tmpv1 =mm(i,j)*(rdy*(g_hat(i,k,j) -g_hat(i,k,j-1)) -g_tmp1(i,k,j)) &
+g_mm(i,j)*(rdy*(hat(i,k,j) -hat(i,k,j-1)) -tmp1(i,k,j))
Tmpv1 =mm(i,j)*(rdy*(hat(i,k,j) -hat(i,k,j-1)) -tmp1(i,k,j))
g_defor12(i,k,j) =g_Tmpv1
defor12(i,k,j) =Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[37]
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start-1,i_end
g_hat(i,k,j) =g_v(i,k,j)/msfvy(i,j)
hat(i,k,j) =v(i,k,j)/msfvy(i,j)
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO k =kts+1,ktf
DO i =i_start,i_end
g_hatavg(i,k,j) =0.5*(fnm(k)*(g_hat(i-1,k,j) +g_hat(i,k,j)) +fnp(k) &
*(g_hat(i-1,k-1,j) +g_hat(i,k-1,j)))
hatavg(i,k,j) =0.5*(fnm(k)*(hat(i-1,k,j) +hat(i,k,j)) +fnp(k)*(hat(i-1,k-1,j) &
+hat(i,k-1,j)))
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO i =i_start,i_end
g_hatavg(i,1,j) =0.5*(cf1*g_hat(i-1,1,j) +cf2*g_hat(i-1,2,j) +cf3*g_hat( &
i-1,3,j) +cf1*g_hat(i,1,j) +cf2*g_hat(i,2,j) +cf3*g_hat(i,3,j))
hatavg(i,1,j) =0.5*(cf1*hat(i-1,1,j) +cf2*hat(i-1,2,j) +cf3*hat(i-1,3,j) &
+cf1*hat(i,1,j) +cf2*hat(i,2,j) +cf3*hat(i,3,j))
g_Tmpv1 =cft1*(g_hat(i,ktes1,j) +g_hat(i-1,ktes1,j)) +g_cft1*(hat(i, &
ktes1,j) +hat(i-1,ktes1,j))
Tmpv1 =cft1*(hat(i,ktes1,j) +hat(i-1,ktes1,j))
g_Tmpv2 =cft2*(g_hat(i,ktes2,j) +g_hat(i-1,ktes2,j)) +g_cft2*(hat(i, &
ktes2,j) +hat(i-1,ktes2,j))
Tmpv2 =cft2*(hat(i,ktes2,j) +hat(i-1,ktes2,j))
g_hatavg(i,kte,j) =0.5*(g_Tmpv1 +g_Tmpv2)
hatavg(i,kte,j) =0.5*(Tmpv1 +Tmpv2)
ENDDO
ENDDO
!LPB[40]
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_tmpzx =0.25*(g_zx(i,k,j-1) +g_zx(i,k,j) +g_zx(i,k+1,j-1) +g_zx(i,k+1,j))
tmpzx =0.25*(zx(i,k,j-1) +zx(i,k,j) +zx(i,k+1,j-1) +zx(i,k+1,j))
g_Tmpv1 =(hatavg(i,k+1,j) -hatavg(i,k,j))*0.25*g_tmpzx +(g_hatavg(i,k+1,j) &
-g_hatavg(i,k,j))*0.25*tmpzx
Tmpv1 =(hatavg(i,k+1,j) -hatavg(i,k,j))*0.25*tmpzx
g_Tmpv2 =Tmpv1*(g_rdzw(i,k,j) +g_rdzw(i,k,j-1) +g_rdzw(i-1,k,j-1) &
+g_rdzw(i-1,k,j)) +g_Tmpv1*(rdzw(i,k,j) +rdzw(i,k,j-1) +rdzw(i-1,k,j-1) +rdzw(i-1,k,j))
Tmpv2 =Tmpv1*(rdzw(i,k,j) +rdzw(i,k,j-1) +rdzw(i-1,k,j-1) +rdzw(i-1,k,j))
g_tmp1(i,k,j) =g_Tmpv2
tmp1(i,k,j) =Tmpv2
ENDDO
ENDDO
ENDDO
!LPB[42]
IF( config_flags%sfs_opt .GT. 0 ) THEN
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_Tmpv1 =mm(i,j)*(rdx*(g_hat(i,k,j) -g_hat(i-1,k,j)) -g_tmp1(i,k,j)) &
+g_mm(i,j)*(rdx*(hat(i,k,j) -hat(i-1,k,j)) -tmp1(i,k,j))
Tmpv1 =mm(i,j)*(rdx*(hat(i,k,j) -hat(i-1,k,j)) -tmp1(i,k,j))
g_nba_rij(i,k,j,P_r12) =g_defor12(i,k,j) -g_Tmpv1
nba_rij(i,k,j,P_r12) =defor12(i,k,j) -Tmpv1
g_Tmpv1 =mm(i,j)*(rdx*(g_hat(i,k,j) -g_hat(i-1,k,j)) -g_tmp1(i,k,j)) &
+g_mm(i,j)*(rdx*(hat(i,k,j) -hat(i-1,k,j)) -tmp1(i,k,j))
Tmpv1 =mm(i,j)*(rdx*(hat(i,k,j) -hat(i-1,k,j)) -tmp1(i,k,j))
g_defor12(i,k,j) =g_defor12(i,k,j) +g_Tmpv1
defor12(i,k,j) =defor12(i,k,j) +Tmpv1
ENDDO
ENDDO
ENDDO
IF( .NOT. config_flags%periodic_x .AND. i_start .EQ. ids+1 ) THEN
DO j =jts,jte
DO k =kts,kte
g_defor12(ids,k,j) =g_defor12(ids+1,k,j)
defor12(ids,k,j) =defor12(ids+1,k,j)
g_nba_rij(ids,k,j,P_r12) =g_nba_rij(ids+1,k,j,P_r12)
nba_rij(ids,k,j,P_r12) =nba_rij(ids+1,k,j,P_r12)
ENDDO
ENDDO
END IF
IF( .NOT. config_flags%periodic_y .AND. j_start .EQ. jds+1) THEN
DO k =kts,kte
DO i =its,ite
g_defor12(i,k,jds) =g_defor12(i,k,jds+1)
defor12(i,k,jds) =defor12(i,k,jds+1)
g_nba_rij(i,k,jds,P_r12) =g_nba_rij(i,k,jds+1,P_r12)
nba_rij(i,k,jds,P_r12) =nba_rij(i,k,jds+1,P_r12)
ENDDO
ENDDO
END IF
IF( .NOT. config_flags%periodic_x .AND. i_end .EQ. ide-1) THEN
DO j =jts,jte
DO k =kts,kte
g_defor12(ide,k,j) =g_defor12(ide-1,k,j)
defor12(ide,k,j) =defor12(ide-1,k,j)
g_nba_rij(ide,k,j,P_r12) =g_nba_rij(ide-1,k,j,P_r12)
nba_rij(ide,k,j,P_r12) =nba_rij(ide-1,k,j,P_r12)
ENDDO
ENDDO
END IF
IF( .NOT. config_flags%periodic_y .AND. j_end .EQ. jde-1) THEN
DO k =kts,kte
DO i =its,ite
g_defor12(i,k,jde) =g_defor12(i,k,jde-1)
defor12(i,k,jde) =defor12(i,k,jde-1)
g_nba_rij(i,k,jde,P_r12) =g_nba_rij(i,k,jde-1,P_r12)
nba_rij(i,k,jde,P_r12) =nba_rij(i,k,jde-1,P_r12)
ENDDO
ENDDO
END IF
ELSE
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_Tmpv1 =mm(i,j)*(rdx*(g_hat(i,k,j) -g_hat(i-1,k,j)) -g_tmp1(i,k,j)) &
+g_mm(i,j)*(rdx*(hat(i,k,j) -hat(i-1,k,j)) -tmp1(i,k,j))
Tmpv1 =mm(i,j)*(rdx*(hat(i,k,j) -hat(i-1,k,j)) -tmp1(i,k,j))
g_defor12(i,k,j) =g_defor12(i,k,j) +g_Tmpv1
defor12(i,k,j) =defor12(i,k,j) +Tmpv1
ENDDO
ENDDO
ENDDO
IF( .NOT. config_flags%periodic_x .AND. i_start .EQ. ids+1 ) THEN
DO j =jts,jte
DO k =kts,kte
g_defor12(ids,k,j) =g_defor12(ids+1,k,j)
defor12(ids,k,j) =defor12(ids+1,k,j)
ENDDO
ENDDO
END IF
IF( .NOT. config_flags%periodic_y .AND. j_start .EQ. jds+1) THEN
DO k =kts,kte
DO i =its,ite
g_defor12(i,k,jds) =g_defor12(i,k,jds+1)
defor12(i,k,jds) =defor12(i,k,jds+1)
ENDDO
ENDDO
END IF
IF( .NOT. config_flags%periodic_x .AND. i_end .EQ. ide-1) THEN
DO j =jts,jte
DO k =kts,kte
g_defor12(ide,k,j) =g_defor12(ide-1,k,j)
defor12(ide,k,j) =defor12(ide-1,k,j)
ENDDO
ENDDO
END IF
IF( .NOT. config_flags%periodic_y .AND. j_end .EQ. jde-1) THEN
DO k =kts,kte
DO i =its,ite
g_defor12(i,k,jde) =g_defor12(i,k,jde-1)
defor12(i,k,jde) =defor12(i,k,jde-1)
ENDDO
ENDDO
END IF
ENDIF
i_start =its
i_end =min(ite,ide-1)
j_start =jts
j_end =min(jte,jde-1)
IF( config_flags%open_xs .OR. config_flags%specified .OR. &
config_flags%nested) i_start =max(ids+1,its)
IF( config_flags%open_ys .OR. config_flags%specified .OR. &
config_flags%nested) j_start =max(jds+1,jts)
IF( config_flags%periodic_x ) i_start =its
IF( config_flags%periodic_x ) i_end =min(ite,ide)
IF( config_flags%periodic_y ) j_end =min(jte,jde)
DO j =jts,jte
DO i =its,ite
g_mm(i,j) =0.0
mm(i,j) =msfux(i,j) *msfuy(i,j)
ENDDO
ENDDO
DO j =j_start,j_end
DO k =kts,kte
DO i =i_start,i_end
g_hat(i,k,j) =g_w(i,k,j)/msfty(i,j)
hat(i,k,j) =w(i,k,j)/msfty(i,j)
ENDDO
ENDDO
ENDDO
i =i_start-1
DO j =j_start,min(jte,jde-1)
DO k =kts,kte
g_hat(i,k,j) =g_w(i,k,j)/msfty(i,j)
hat(i,k,j) =w(i,k,j)/msfty(i,j)
ENDDO
ENDDO
j =j_start-1
DO k =kts,kte
DO i =i_start,min(ite,ide-1)
g_hat(i,k,j) =g_w(i,k,j)/msfty(i,j)
hat(i,k,j) =w(i,k,j)/msfty(i,j)
ENDDO
ENDDO
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_hatavg(i,k,j) =0.25*(g_hat(i,k,j) +g_hat(i,k+1,j) +g_hat(i-1,k,j) &
+g_hat(i-1,k+1,j))
hatavg(i,k,j) =0.25*(hat(i,k,j) +hat(i,k+1,j) +hat(i-1,k,j) +hat(i-1,k+1,j))
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO k =kts+1,ktf
DO i =i_start,i_end
g_Tmpv1 =(hatavg(i,k,j) -hatavg(i,k-1,j))*g_zx(i,k,j) +(g_hatavg(i,k,j) &
-g_hatavg(i,k-1,j))*zx(i,k,j)
Tmpv1 =(hatavg(i,k,j) -hatavg(i,k-1,j))*zx(i,k,j)
g_Tmpv2 =Tmpv1*0.5*(g_rdz(i,k,j) +g_rdz(i-1,k,j)) +g_Tmpv1*0.5*(rdz(i,k, &
j) +rdz(i-1,k,j))
Tmpv2 =Tmpv1*0.5*(rdz(i,k,j) +rdz(i-1,k,j))
g_tmp1(i,k,j) =g_Tmpv2
tmp1(i,k,j) =Tmpv2
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO k =kts+1,ktf
DO i =i_start,i_end
g_Tmpv1 =mm(i,j)*(rdx*(g_hat(i,k,j) -g_hat(i-1,k,j)) -g_tmp1(i,k,j)) &
+g_mm(i,j)*(rdx*(hat(i,k,j) -hat(i-1,k,j)) -tmp1(i,k,j))
Tmpv1 =mm(i,j)*(rdx*(hat(i,k,j) -hat(i-1,k,j)) -tmp1(i,k,j))
g_defor13(i,k,j) =g_Tmpv1
defor13(i,k,j) =Tmpv1
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO i =i_start,i_end
g_defor13(i,kts,j) =0.0
defor13(i,kts,j) =0.0
g_defor13(i,ktf+1,j) =0.0
defor13(i,ktf+1,j) =0.0
ENDDO
ENDDO
IF( config_flags%mix_full_fields ) THEN
DO j =j_start,j_end
DO k =kts+1,ktf
DO i =i_start,i_end
g_Tmpv1 =(u(i,k,j) -u(i,k-1,j))*0.5*(g_rdz(i,k,j) +g_rdz(i-1,k,j)) &
+(g_u(i,k,j) -g_u(i,k-1,j))*0.5*(rdz(i,k,j) +rdz(i-1,k,j))
Tmpv1 =(u(i,k,j) -u(i,k-1,j))*0.5*(rdz(i,k,j) +rdz(i-1,k,j))
g_tmp1(i,k,j) =g_Tmpv1
tmp1(i,k,j) =Tmpv1
ENDDO
ENDDO
ENDDO
ELSE
DO j =j_start,j_end
DO k =kts+1,ktf
DO i =i_start,i_end
g_Tmpv1 =(u(i,k,j) -u_base(k) -u(i,k-1,j) +u_base(k-1))*0.5*(g_rdz(i,k,j) &
+g_rdz(i-1,k,j)) +(g_u(i,k,j) -g_u(i,k-1,j))*0.5*(rdz(i,k,j) +rdz(i-1,k,j))
Tmpv1 =(u(i,k,j) -u_base(k) -u(i,k-1,j) +u_base(k-1))*0.5*(rdz(i,k,j) +rdz(i-1,k,j))
g_tmp1(i,k,j) =g_Tmpv1
tmp1(i,k,j) =Tmpv1
ENDDO
ENDDO
ENDDO
END IF
!LPB[66]
IF( config_flags%sfs_opt .GT. 0 ) THEN
DO j =j_start,j_end
DO k =kts+1,ktf
DO i =i_start,i_end
g_nba_rij(i,k,j,P_r13) =g_tmp1(i,k,j) -g_defor13(i,k,j)
nba_rij(i,k,j,P_r13) =tmp1(i,k,j) -defor13(i,k,j)
g_defor13(i,k,j) =g_defor13(i,k,j) +g_tmp1(i,k,j)
defor13(i,k,j) =defor13(i,k,j) +tmp1(i,k,j)
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO i =i_start,i_end
g_nba_rij(i,kts,j,P_r13) =0.0
nba_rij(i,kts,j,P_r13) =0.0
g_nba_rij(i,ktf+1,j,P_r13) =0.0
nba_rij(i,ktf+1,j,P_r13) =0.0
ENDDO
ENDDO
ELSE
DO j =j_start,j_end
DO k =kts+1,ktf
DO i =i_start,i_end
g_defor13(i,k,j) =g_defor13(i,k,j) +g_tmp1(i,k,j)
defor13(i,k,j) =defor13(i,k,j) +tmp1(i,k,j)
ENDDO
ENDDO
ENDDO
ENDIF
!LPB[67]
i_start =its
i_end =min(ite,ide-1)
j_start =jts
j_end =min(jte,jde-1)
IF( config_flags%open_xs .OR. config_flags%specified .OR. &
config_flags%nested) i_start =max(ids+1,its)
IF( config_flags%open_ys .OR. config_flags%specified .OR. &
config_flags%nested) j_start =max(jds+1,jts)
IF( config_flags%periodic_y ) j_end =min(jte,jde)
IF( config_flags%periodic_x ) i_start =its
IF( config_flags%periodic_x ) i_end =min(ite,ide-1)
DO j =jts,jte
DO i =its,ite
g_mm(i,j) =0.0
mm(i,j) =msfvx(i,j) *msfvy(i,j)
ENDDO
ENDDO
DO j =j_start,j_end
DO k =kts,kte
DO i =i_start,i_end
g_hat(i,k,j) =g_w(i,k,j)/msftx(i,j)
hat(i,k,j) =w(i,k,j)/msftx(i,j)
ENDDO
ENDDO
ENDDO
i =i_start-1
DO j =j_start,min(jte,jde-1)
DO k =kts,kte
g_hat(i,k,j) =g_w(i,k,j)/msftx(i,j)
hat(i,k,j) =w(i,k,j)/msftx(i,j)
ENDDO
ENDDO
j =j_start-1
DO k =kts,kte
DO i =i_start,min(ite,ide-1)
g_hat(i,k,j) =g_w(i,k,j)/msftx(i,j)
hat(i,k,j) =w(i,k,j)/msftx(i,j)
ENDDO
ENDDO
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_hatavg(i,k,j) =0.25*(g_hat(i,k,j) +g_hat(i,k+1,j) +g_hat(i,k,j-1) &
+g_hat(i,k+1,j-1))
hatavg(i,k,j) =0.25*(hat(i,k,j) +hat(i,k+1,j) +hat(i,k,j-1) +hat(i,k+1,j-1))
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO k =kts+1,ktf
DO i =i_start,i_end
g_Tmpv1 =(hatavg(i,k,j) -hatavg(i,k-1,j))*g_zy(i,k,j) +(g_hatavg(i,k,j) &
-g_hatavg(i,k-1,j))*zy(i,k,j)
Tmpv1 =(hatavg(i,k,j) -hatavg(i,k-1,j))*zy(i,k,j)
g_Tmpv2 =Tmpv1*0.5*(g_rdz(i,k,j) +g_rdz(i,k,j-1)) +g_Tmpv1*0.5*(rdz(i,k, &
j) +rdz(i,k,j-1))
Tmpv2 =Tmpv1*0.5*(rdz(i,k,j) +rdz(i,k,j-1))
g_tmp1(i,k,j) =g_Tmpv2
tmp1(i,k,j) =Tmpv2
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO k =kts+1,ktf
DO i =i_start,i_end
g_Tmpv1 =mm(i,j)*(rdy*(g_hat(i,k,j) -g_hat(i,k,j-1)) -g_tmp1(i,k,j)) &
+g_mm(i,j)*(rdy*(hat(i,k,j) -hat(i,k,j-1)) -tmp1(i,k,j))
Tmpv1 =mm(i,j)*(rdy*(hat(i,k,j) -hat(i,k,j-1)) -tmp1(i,k,j))
g_defor23(i,k,j) =g_Tmpv1
defor23(i,k,j) =Tmpv1
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO i =i_start,i_end
g_defor23(i,kts,j) =0.0
defor23(i,kts,j) =0.0
g_defor23(i,ktf+1,j) =0.0
defor23(i,ktf+1,j) =0.0
ENDDO
ENDDO
IF( config_flags%mix_full_fields ) THEN
DO j =j_start,j_end
DO k =kts+1,ktf
DO i =i_start,i_end
g_Tmpv1 =(v(i,k,j) -v(i,k-1,j))*0.5*(g_rdz(i,k,j) +g_rdz(i,k,j-1)) &
+(g_v(i,k,j) -g_v(i,k-1,j))*0.5*(rdz(i,k,j) +rdz(i,k,j-1))
Tmpv1 =(v(i,k,j) -v(i,k-1,j))*0.5*(rdz(i,k,j) +rdz(i,k,j-1))
g_tmp1(i,k,j) =g_Tmpv1
tmp1(i,k,j) =Tmpv1
ENDDO
ENDDO
ENDDO
ELSE
DO j =j_start,j_end
DO k =kts+1,ktf
DO i =i_start,i_end
g_Tmpv1 =(v(i,k,j) -v_base(k) -v(i,k-1,j) +v_base(k-1))*0.5*(g_rdz(i,k,j) &
+g_rdz(i,k,j-1)) +(g_v(i,k,j) -g_v(i,k-1,j))*0.5*(rdz(i,k,j) +rdz(i,k,j-1))
Tmpv1 =(v(i,k,j) -v_base(k) -v(i,k-1,j) +v_base(k-1))*0.5*(rdz(i,k,j) +rdz(i,k,j-1))
g_tmp1(i,k,j) =g_Tmpv1
tmp1(i,k,j) =Tmpv1
ENDDO
ENDDO
ENDDO
END IF
IF( config_flags%sfs_opt .GT. 0 ) THEN
DO j =j_start,j_end
DO k =kts+1,ktf
DO i =i_start,i_end
g_nba_rij(i,k,j,P_r23) =g_tmp1(i,k,j) -g_defor23(i,k,j)
nba_rij(i,k,j,P_r23) =tmp1(i,k,j) -defor23(i,k,j)
g_defor23(i,k,j) =g_defor23(i,k,j) +g_tmp1(i,k,j)
defor23(i,k,j) =defor23(i,k,j) +tmp1(i,k,j)
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO i =i_start,i_end
g_nba_rij(i,kts,j,P_r23) =0.0
nba_rij(i,kts,j,P_r23) =0.0
g_nba_rij(i,ktf+1,j,P_r23) =0.0
nba_rij(i,ktf+1,j,P_r23) =0.0
ENDDO
ENDDO
IF( .NOT. config_flags%periodic_x .AND. i_start .EQ. ids+1) THEN
DO j =jts,jte
DO k =kts,kte
g_defor13(ids,k,j) =g_defor13(ids+1,k,j)
defor13(ids,k,j) =defor13(ids+1,k,j)
g_defor23(ids,k,j) =g_defor23(ids+1,k,j)
defor23(ids,k,j) =defor23(ids+1,k,j)
g_nba_rij(ids,k,j,P_r13) =g_nba_rij(ids+1,k,j,P_r13)
nba_rij(ids,k,j,P_r13) =nba_rij(ids+1,k,j,P_r13)
g_nba_rij(ids,k,j,P_r23) =g_nba_rij(ids+1,k,j,P_r23)
nba_rij(ids,k,j,P_r23) =nba_rij(ids+1,k,j,P_r23)
ENDDO
ENDDO
END IF
IF( .NOT. config_flags%periodic_y .AND. j_start .EQ. jds+1) THEN
DO k =kts,kte
DO i =its,ite
g_defor13(i,k,jds) =g_defor13(i,k,jds+1)
defor13(i,k,jds) =defor13(i,k,jds+1)
g_defor23(i,k,jds) =g_defor23(i,k,jds+1)
defor23(i,k,jds) =defor23(i,k,jds+1)
g_nba_rij(i,k,jds,P_r13) =g_nba_rij(i,k,jds+1,P_r13)
nba_rij(i,k,jds,P_r13) =nba_rij(i,k,jds+1,P_r13)
g_nba_rij(i,k,jds,P_r23) =g_nba_rij(i,k,jds+1,P_r23)
nba_rij(i,k,jds,P_r23) =nba_rij(i,k,jds+1,P_r23)
ENDDO
ENDDO
END IF
IF( .NOT. config_flags%periodic_x .AND. i_end .EQ. ide-1) THEN
DO j =jts,jte
DO k =kts,kte
g_defor13(ide,k,j) =g_defor13(ide-1,k,j)
defor13(ide,k,j) =defor13(ide-1,k,j)
g_defor23(ide,k,j) =g_defor23(ide-1,k,j)
defor23(ide,k,j) =defor23(ide-1,k,j)
g_nba_rij(ide,k,j,P_r13) =g_nba_rij(ide-1,k,j,P_r13)
nba_rij(ide,k,j,P_r13) =nba_rij(ide-1,k,j,P_r13)
g_nba_rij(ide,k,j,P_r23) =g_nba_rij(ide-1,k,j,P_r23)
nba_rij(ide,k,j,P_r23) =nba_rij(ide-1,k,j,P_r23)
ENDDO
ENDDO
END IF
IF( .NOT. config_flags%periodic_y .AND. j_end .EQ. jde-1) THEN
DO k =kts,kte
DO i =its,ite
g_defor13(i,k,jde) =g_defor13(i,k,jde-1)
defor13(i,k,jde) =defor13(i,k,jde-1)
g_defor23(i,k,jde) =g_defor23(i,k,jde-1)
defor23(i,k,jde) =defor23(i,k,jde-1)
g_nba_rij(i,k,jde,P_r13) =g_nba_rij(i,k,jde-1,P_r13)
nba_rij(i,k,jde,P_r13) =nba_rij(i,k,jde-1,P_r13)
g_nba_rij(i,k,jde,P_r23) =g_nba_rij(i,k,jde-1,P_r23)
nba_rij(i,k,jde,P_r23) =nba_rij(i,k,jde-1,P_r23)
ENDDO
ENDDO
END IF
ELSE
DO j =j_start,j_end
DO k =kts+1,ktf
DO i =i_start,i_end
g_defor23(i,k,j) =g_defor23(i,k,j) +g_tmp1(i,k,j)
defor23(i,k,j) =defor23(i,k,j) +tmp1(i,k,j)
ENDDO
ENDDO
ENDDO
IF( .NOT. config_flags%periodic_x .AND. i_start .EQ. ids+1) THEN
DO j =jts,jte
DO k =kts,kte
g_defor13(ids,k,j) =g_defor13(ids+1,k,j)
defor13(ids,k,j) =defor13(ids+1,k,j)
g_defor23(ids,k,j) =g_defor23(ids+1,k,j)
defor23(ids,k,j) =defor23(ids+1,k,j)
ENDDO
ENDDO
END IF
IF( .NOT. config_flags%periodic_y .AND. j_start .EQ. jds+1) THEN
DO k =kts,kte
DO i =its,ite
g_defor13(i,k,jds) =g_defor13(i,k,jds+1)
defor13(i,k,jds) =defor13(i,k,jds+1)
g_defor23(i,k,jds) =g_defor23(i,k,jds+1)
defor23(i,k,jds) =defor23(i,k,jds+1)
ENDDO
ENDDO
END IF
IF( .NOT. config_flags%periodic_x .AND. i_end .EQ. ide-1) THEN
DO j =jts,jte
DO k =kts,kte
g_defor13(ide,k,j) =g_defor13(ide-1,k,j)
defor13(ide,k,j) =defor13(ide-1,k,j)
g_defor23(ide,k,j) =g_defor23(ide-1,k,j)
defor23(ide,k,j) =defor23(ide-1,k,j)
ENDDO
ENDDO
END IF
IF( .NOT. config_flags%periodic_y .AND. j_end .EQ. jde-1) THEN
DO k =kts,kte
DO i =its,ite
g_defor13(i,k,jde) =g_defor13(i,k,jde-1)
defor13(i,k,jde) =defor13(i,k,jde-1)
g_defor23(i,k,jde) =g_defor23(i,k,jde-1)
defor23(i,k,jde) =defor23(i,k,jde-1)
ENDDO
ENDDO
END IF
ENDIF
END SUBROUTINE g_cal_deform_and_div
SUBROUTINE g_calculate_km_kh(config_flags,dt,dampcoef,zdamp,damp_opt,xkmh, &
g_xkmh,xkmv,g_xkmv,xkhh,g_xkhh,xkhv,g_xkhv,BN2,g_BN2,khdif,kvdif,div, &
g_div,defor11,g_defor11,defor22,g_defor22,defor33,g_defor33,defor12, &
g_defor12,defor13,g_defor13,defor23,g_defor23,tke,g_tke,p8w,g_p8w,t8w, &
g_t8w,theta,g_theta,t,g_t,p,g_p,moist,g_moist,dn,dnw,dx,dy,rdz, &
g_rdz,rdzw,g_rdzw,isotropic,n_moist,cf1,cf2,cf3,warm_rain,mix_upper_bound, &
msftx,msfty,zx,g_zx,zy,g_zy,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
IMPLICIT NONE
REAL :: Tmpv1,g_Tmpv1
TYPE(grid_config_rec_type) :: config_flags
INTEGER :: n_moist,damp_opt,isotropic,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms, &
kme,its,ite,jts,jte,kts,kte
LOGICAL :: warm_rain
REAL :: dx,dy,zdamp,dt,dampcoef,cf1,cf2,cf3,khdif,kvdif
REAL,DIMENSION(kms:kme) :: dnw,dn
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_moist) :: moist,g_moist
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: xkmv,g_xkmv,xkmh,g_xkmh,xkhv, &
g_xkhv,xkhh,g_xkhh,BN2,g_BN2
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor11,g_defor11,defor22,g_defor22, &
defor33,g_defor33,defor12,g_defor12,defor13,g_defor13,defor23,g_defor23, &
div,g_div,rdz,g_rdz,rdzw,g_rdzw,p8w,g_p8w,t8w,g_t8w,theta,g_theta, &
t,g_t,p,g_p,zx,g_zx,zy,g_zy
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tke,g_tke
REAL :: mix_upper_bound
REAL,DIMENSION(ims:ime,jms:jme) :: msftx,msfty
INTEGER :: i_start,i_end,j_start,j_end,ktf,i,j,k!,km_opt
ktf =min(kte,kde-1)
i_start =its
i_end =min(ite,ide-1)
j_start =jts
j_end =min(jte,jde-1)
CALL g_calculate_N2(config_flags,BN2,g_BN2,moist,g_moist,theta,g_theta,t, &
g_t,p,g_p,p8w,g_p8w,t8w,g_t8w,dnw,dn,rdz,g_rdz,rdzw,g_rdzw,n_moist, &
cf1,cf2,cf3,warm_rain,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts, &
jte,kts,kte)
!ALL THE FOLLOWING STRUNCTURE ARE REVISED BY WALLS
!ALL THE FOLLOWING STRUNCTURE ARE REVISED BY WALLS
!km_opt =config_flags%km_opt
!km_opt =3
!PRINT*, 'km_opt =', km_opt
!Select a scheme for calculating diffusion coefficients.
km_coef: SELECT CASE( config_flags%km_opt )
!km_coef: SELECT CASE( km_opt )
CASE (1)
CALL g_isotropic_km(config_flags,xkmh,g_xkmh,xkmv,g_xkmv,xkhh,g_xkhh, &
xkhv,g_xkhv,khdif,kvdif,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite, &
jts,jte,kts,kte)
CASE (2)
CALL g_tke_km(config_flags,xkmh,g_xkmh,xkmv,g_xkmv,xkhh,g_xkhh,xkhv, &
g_xkhv,BN2,g_BN2,tke,g_tke,p8w,g_p8w,t8w,g_t8w,theta,g_theta,rdz, &
g_rdz,rdzw,g_rdzw,dx,dy,dt,isotropic,mix_upper_bound,msftx,msfty,ids,ide,jds, &
jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
CASE (3)
CALL g_smag_km(config_flags,xkmh,g_xkmh,xkmv,g_xkmv,xkhh,g_xkhh,xkhv, &
g_xkhv,BN2,g_BN2,div,g_div,defor11,g_defor11,defor22,g_defor22, &
defor33,g_defor33,defor12,g_defor12,defor13,g_defor13,defor23,g_defor23, &
rdzw,g_rdzw,dx,dy,dt,isotropic,mix_upper_bound,msftx,msfty,ids,ide,jds,jde,kds, &
kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
CASE (4)
CALL g_smag2d_km(config_flags,xkmh,g_xkmh,xkmv,g_xkmv,xkhh,g_xkhh,xkhv, &
g_xkhv,defor11,g_defor11,defor22,g_defor22,defor12,g_defor12,rdzw, &
g_rdzw,dx,dy,msftx,msfty,zx,g_zx,zy,g_zy,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite, &
jts,jte,kts,kte)
CASE DEFAULT
!REVISED BY WALLS
!CALL g_wrf_error_fatal('Please choose diffusion coefficient scheme')
CALL wrf_error_fatal( 'Please choose diffusion coefficient scheme' )
END SELECT km_coef
IF( damp_opt .eq. 1 ) THEN
CALL g_cal_dampkm(config_flags,xkmh,g_xkmh,xkhh,g_xkhh,xkmv,g_xkmv,xkhv, &
g_xkhv,dx,dy,dt,dampcoef,rdz,g_rdz,rdzw,g_rdzw,zdamp,msftx,msfty,ids,ide, &
jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
END IF
END SUBROUTINE g_calculate_km_kh
SUBROUTINE g_cal_dampkm(config_flags,xkmh,g_xkmh,xkhh,g_xkhh,xkmv,g_xkmv, &
xkhv,g_xkhv,dx,dy,dt,dampcoef,rdz,g_rdz,rdzw,g_rdzw,zdamp,msftx,msfty,ids, &
ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
IMPLICIT NONE
REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2,Tmpv3,g_Tmpv3,Tmpv4,g_Tmpv4,Tmpv5,g_Tmpv5
TYPE(grid_config_rec_type) :: config_flags
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
REAL :: zdamp,dx,dy,dt,dampcoef
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: xkmh,g_xkmh,xkhh,g_xkhh,xkmv, &
g_xkmv,xkhv,g_xkhv
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: rdz,g_rdz,rdzw,g_rdzw
REAL,DIMENSION(ims:ime,jms:jme) :: msftx,msfty
INTEGER :: i_start,i_end,j_start,j_end,ktf,ktfm1,i,j,k
REAL :: kmmax,kmmvmax,g_kmmvmax,degrad90,dz,g_dz,tmp,g_tmp
REAL :: ds
REAL,DIMENSION(its:ite) :: deltaz,g_deltaz
REAL,DIMENSION(its:ite,kts:kte,jts:jte) :: dampk,g_dampk,dampkv,g_dampkv
ktf =min(kte,kde-1)
ktfm1 =ktf-1
i_start =its
i_end =min(ite,ide-1)
j_start =jts
j_end =min(jte,jde-1)
IF(config_flags%specified .OR. config_flags%nested) THEN
i_start =max(i_start,ids +config_flags%spec_bdy_width -1)
i_end =min(i_end,ide -config_flags%spec_bdy_width)
j_start =max(j_start,jds +config_flags%spec_bdy_width -1)
j_end =min(j_end,jde -config_flags%spec_bdy_width)
ENDIF
kmmax =dx *dx/dt
degrad90 =DEGRAD *90.
DO j =j_start,j_end
k =ktf
DO i =i_start,i_end
ds =min(dx/msftx(i,j),dy/msfty(i,j))
kmmax =ds *ds/dt
g_dz =-1.*g_rdzw(i,k,j)/(rdzw(i,k,j)*rdzw(i,k,j))
dz =1./rdzw(i,k,j)
g_deltaz(i) =0.5*g_dz
deltaz(i) =0.5*dz
g_Tmpv1 =2.0*dz*g_dz
Tmpv1 =dz*dz
g_kmmvmax =g_Tmpv1/dt
kmmvmax =Tmpv1/dt
g_tmp =(g_deltaz(i)/zdamp +0.0 -(g_deltaz(i)/zdamp -0.0)*sign(1.0, deltaz(i) &
/zdamp -(1.)))*0.5
tmp =min(deltaz(i)/zdamp,1.)
g_Tmpv1 =2.0*cos(degrad90*tmp)*(-degrad90*g_tmp*sin(degrad90*tmp))
Tmpv1 =cos(degrad90*tmp)*cos(degrad90*tmp)
g_dampk(i,k,j) =g_Tmpv1*kmmax*dampcoef
dampk(i,k,j) =Tmpv1*kmmax*dampcoef
g_Tmpv1 =2.0*cos(degrad90*tmp)*(-degrad90*g_tmp*sin(degrad90*tmp))
Tmpv1 =cos(degrad90*tmp)*cos(degrad90*tmp)
g_Tmpv2 =Tmpv1*g_kmmvmax +g_Tmpv1*kmmvmax
Tmpv2 =Tmpv1*kmmvmax
g_dampkv(i,k,j) =g_Tmpv2*dampcoef
dampkv(i,k,j) =Tmpv2*dampcoef
g_dampkv(i,k,j) =(g_dampkv(i,k,j) +g_dampk(i,k,j) -(g_dampkv(i,k,j) &
-g_dampk(i,k,j))*sign(1.0, dampkv(i,k,j) -(dampk(i,k,j))))*0.5
dampkv(i,k,j) =min(dampkv(i,k,j),dampk(i,k,j))
ENDDO
DO k =ktfm1,kts,-1
DO i =i_start,i_end
ds =min(dx/msftx(i,j),dy/msfty(i,j))
kmmax =ds *ds/dt
g_dz =-1.*g_rdz(i,k,j)/(rdz(i,k,j)*rdz(i,k,j))
dz =1./rdz(i,k,j)
g_deltaz(i) =g_deltaz(i) +g_dz
deltaz(i) =deltaz(i) +dz
g_dz =-1.*g_rdzw(i,k,j)/(rdzw(i,k,j)*rdzw(i,k,j))
dz =1./rdzw(i,k,j)
g_Tmpv1 =2.0*dz*g_dz
Tmpv1 =dz*dz
g_kmmvmax =g_Tmpv1/dt
kmmvmax =Tmpv1/dt
g_tmp =(g_deltaz(i)/zdamp +0.0 -(g_deltaz(i)/zdamp -0.0)*sign(1.0, deltaz(i) &
/zdamp -(1.)))*0.5
tmp =min(deltaz(i)/zdamp,1.)
g_Tmpv1 =2.0*cos(degrad90*tmp)*(-degrad90*g_tmp*sin(degrad90*tmp))
Tmpv1 =cos(degrad90*tmp)*cos(degrad90*tmp)
g_dampk(i,k,j) =g_Tmpv1*kmmax*dampcoef
dampk(i,k,j) =Tmpv1*kmmax*dampcoef
g_Tmpv1 =2.0*cos(degrad90*tmp)*(-degrad90*g_tmp*sin(degrad90*tmp))
Tmpv1 =cos(degrad90*tmp)*cos(degrad90*tmp)
g_Tmpv2 =Tmpv1*g_kmmvmax +g_Tmpv1*kmmvmax
Tmpv2 =Tmpv1*kmmvmax
g_dampkv(i,k,j) =g_Tmpv2*dampcoef
dampkv(i,k,j) =Tmpv2*dampcoef
g_dampkv(i,k,j) =(g_dampkv(i,k,j) +g_dampk(i,k,j) -(g_dampkv(i,k,j) &
-g_dampk(i,k,j))*sign(1.0, dampkv(i,k,j) -(dampk(i,k,j))))*0.5
dampkv(i,k,j) =min(dampkv(i,k,j),dampk(i,k,j))
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_xkmh(i,k,j) =(g_xkmh(i,k,j) +g_dampk(i,k,j) +(g_xkmh(i,k,j) &
-g_dampk(i,k,j))*sign(1.0, xkmh(i,k,j) -(dampk(i,k,j))))*0.5
xkmh(i,k,j) =max(xkmh(i,k,j),dampk(i,k,j))
g_xkhh(i,k,j) =(g_xkhh(i,k,j) +g_dampk(i,k,j) +(g_xkhh(i,k,j) &
-g_dampk(i,k,j))*sign(1.0, xkhh(i,k,j) -(dampk(i,k,j))))*0.5
xkhh(i,k,j) =max(xkhh(i,k,j),dampk(i,k,j))
g_xkmv(i,k,j) =(g_xkmv(i,k,j) +g_dampkv(i,k,j) +(g_xkmv(i,k,j) &
-g_dampkv(i,k,j))*sign(1.0, xkmv(i,k,j) -(dampkv(i,k,j))))*0.5
xkmv(i,k,j) =max(xkmv(i,k,j),dampkv(i,k,j))
g_xkhv(i,k,j) =(g_xkhv(i,k,j) +g_dampkv(i,k,j) +(g_xkhv(i,k,j) &
-g_dampkv(i,k,j))*sign(1.0, xkhv(i,k,j) -(dampkv(i,k,j))))*0.5
xkhv(i,k,j) =max(xkhv(i,k,j),dampkv(i,k,j))
ENDDO
ENDDO
ENDDO
END SUBROUTINE g_cal_dampkm
! Generated by TAPENADE (INRIA, Tropics team)
! Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
!
! Differentiation of calculate_n2 in forward (tangent) mode:
! variations of useful results: bn2
! with respect to varying inputs: p t t8w bn2 theta rdzw rdz
! moist p8w
! RW status of diff variables: p:in t:in t8w:in bn2:in-out theta:in
! rdzw:in rdz:in moist:in p8w:in
SUBROUTINE G_CALCULATE_N2(config_flags, bn2, bn2d, moist, moistd, theta&
& , thetad, t, td, p, pd, p8w, p8wd, t8w, t8wd, dnw, dn, rdz, rdzd, rdzw&
& , rdzwd, n_moist, cf1, cf2, cf3, warm_rain, ids, ide, jds, jde, kds, &
& kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte)
IMPLICIT NONE
! end of MARTA/WCS change
TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
INTEGER, INTENT(IN) :: n_moist, ids, ide, jds, jde, kds, kde, ims, ime&
& , jms, jme, kms, kme, its, ite, jts, jte, kts, kte
LOGICAL, INTENT(IN) :: warm_rain
REAL, INTENT(IN) :: cf1, cf2, cf3
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: bn2
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: bn2d
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: rdz, rdzw, &
& theta, t, p, p8w, t8w
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: rdzd, rdzwd&
& , thetad, td, pd, p8wd, t8wd
REAL, DIMENSION(kms:kme), INTENT(IN) :: dnw, dn
REAL, DIMENSION(ims:ime, kms:kme, jms:jme, n_moist), INTENT(INOUT) :: &
& moist
REAL, DIMENSION(ims:ime, kms:kme, jms:jme, n_moist), INTENT(INOUT) :: &
& moistd
! Local variables.
INTEGER :: i, j, k, ktf, ispe, ktes1, ktes2, i_start, i_end, j_start, &
& j_end
REAL :: coefa, thetaep1, thetaem1, qc_cr, es, tc, qlpqi, qsw, qsi, &
& tmpdz, xlvqv, thetaesfc, thetasfc, qvtop, qvsfc, thetatop, thetaetop
REAL :: coefad, thetaep1d, thetaem1d, esd, tcd, tmpdzd, xlvqvd, &
& thetaesfcd, thetasfcd, qvsfcd
REAL, DIMENSION(its:ite, jts:jte) :: tmp1sfc, tmp1top
REAL, DIMENSION(its:ite, jts:jte) :: tmp1sfcd
REAL, DIMENSION(its:ite, kts:kte, jts:jte) :: tmp1, qvs, qctmp
REAL, DIMENSION(its:ite, kts:kte, jts:jte) :: tmp1d, qvsd
REAL :: arg1
REAL :: arg1d
REAL :: pwx1
REAL :: pwx1d
REAL :: pwy1
REAL :: pwr1
REAL :: pwr1d
! End declarations.
!-----------------------------------------------------------------------
! in Kg/Kg
qc_cr = 0.00001
IF (kte .GT. kde - 1) THEN
ktf = kde - 1
ELSE
ktf = kte
END IF
ktes1 = kte - 1
ktes2 = kte - 2
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
IF ((config_flags%open_xs .OR. config_flags%specified) .OR. &
& config_flags%nested) THEN
IF (ids + 1 .LT. its) THEN
i_start = its
ELSE
i_start = ids + 1
END IF
END IF
IF ((config_flags%open_xe .OR. config_flags%specified) .OR. &
& config_flags%nested) THEN
IF (ide - 2 .GT. ite) THEN
i_end = ite
ELSE
i_end = ide - 2
END IF
END IF
IF ((config_flags%open_ys .OR. config_flags%specified) .OR. &
& config_flags%nested) THEN
IF (jds + 1 .LT. jts) THEN
j_start = jts
ELSE
j_start = jds + 1
END IF
END IF
IF ((config_flags%open_ye .OR. config_flags%specified) .OR. &
& config_flags%nested) THEN
IF (jde - 2 .GT. jte) THEN
j_end = jte
ELSE
j_end = jde - 2
END IF
END IF
IF (config_flags%periodic_x) i_start = its
IF (config_flags%periodic_x) THEN
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
END IF
IF (p_qc .GT. param_first_scalar) THEN
DO j=j_start,j_end
DO k=kts,ktf
DO i=i_start,i_end
qctmp(i, k, j) = moist(i, k, j, p_qc)
END DO
END DO
END DO
ELSE
DO j=j_start,j_end
DO k=kts,ktf
DO i=i_start,i_end
qctmp(i, k, j) = 0.0
END DO
END DO
END DO
END IF
DO j=jts,jte
DO k=kts,kte
DO i=its,ite
tmp1d(i, k, j) = 0.0
tmp1(i, k, j) = 0.0
END DO
END DO
END DO
DO j=jts,jte
DO i=its,ite
tmp1sfcd(i, j) = 0.0
tmp1sfc(i, j) = 0.0
tmp1top(i, j) = 0.0
END DO
END DO
tmp1d = 0.0
tmp1sfcd = 0.0
DO ispe=param_first_scalar,n_moist
IF ((ispe .EQ. p_qv .OR. ispe .EQ. p_qc) .OR. ispe .EQ. p_qi) THEN
DO j=j_start,j_end
DO k=kts,ktf
DO i=i_start,i_end
tmp1d(i, k, j) = tmp1d(i, k, j) + moistd(i, k, j, ispe)
tmp1(i, k, j) = tmp1(i, k, j) + moist(i, k, j, ispe)
END DO
END DO
END DO
DO j=j_start,j_end
DO i=i_start,i_end
tmp1sfcd(i, j) = tmp1sfcd(i, j) + cf1*moistd(i, 1, j, ispe) + &
& cf2*moistd(i, 2, j, ispe) + cf3*moistd(i, 3, j, ispe)
tmp1sfc(i, j) = tmp1sfc(i, j) + cf1*moist(i, 1, j, ispe) + cf2&
& *moist(i, 2, j, ispe) + cf3*moist(i, 3, j, ispe)
tmp1top(i, j) = tmp1top(i, j) + moist(i, ktes1, j, ispe) + (&
& moist(i, ktes1, j, ispe)-moist(i, ktes2, j, ispe))*0.5*dnw(&
& ktes1)/dn(ktes1)
END DO
END DO
END IF
END DO
qvsd = 0.0
! Calculate saturation mixing ratio.
DO j=j_start,j_end
DO k=kts,ktf
DO i=i_start,i_end
tcd = td(i, k, j)
tc = t(i, k, j) - svpt0
arg1d = (svp2*tcd*(t(i, k, j)-svp3)-svp2*tc*td(i, k, j))/(t(i, k&
& , j)-svp3)**2
arg1 = svp2*tc/(t(i, k, j)-svp3)
esd = 1000.0*svp1*arg1d*EXP(arg1)
es = 1000.0*svp1*EXP(arg1)
qvsd(i, k, j) = (ep_2*esd*(p(i, k, j)-es)-ep_2*es*(pd(i, k, j)-&
& esd))/(p(i, k, j)-es)**2
qvs(i, k, j) = ep_2*es/(p(i, k, j)-es)
END DO
END DO
END DO
DO j=j_start,j_end
DO k=kts+1,ktf-1
DO i=i_start,i_end
tmpdzd = -(rdzd(i, k, j)/rdz(i, k, j)**2) - rdzd(i, k+1, j)/rdz(&
& i, k+1, j)**2
tmpdz = 1.0/rdz(i, k, j) + 1.0/rdz(i, k+1, j)
IF (moist(i, k, j, p_qv) .GE. qvs(i, k, j) .OR. qctmp(i, k, j) &
& .GE. qc_cr) THEN
xlvqvd = xlv*moistd(i, k, j, p_qv)
xlvqv = xlv*moist(i, k, j, p_qv)
coefad = (((xlvqvd*t(i, k, j)/r_d-xlvqv*td(i, k, j)/r_d)*(1.0+&
& xlv*xlvqv/cp/r_v/t(i, k, j)/t(i, k, j))/t(i, k, j)**2-(1.0+&
& xlvqv/r_d/t(i, k, j))*((xlv*xlvqvd*t(i, k, j)/(cp*r_v)-xlv*&
& xlvqv*td(i, k, j)/(cp*r_v))/t(i, k, j)-xlv*xlvqv*td(i, k, j)&
& /(cp*r_v*t(i, k, j)))/t(i, k, j)**2)*theta(i, k, j)/(1.0+xlv&
& *xlvqv/cp/r_v/t(i, k, j)/t(i, k, j))**2-(1.0+xlvqv/r_d/t(i, &
& k, j))*thetad(i, k, j)/(1.0+xlv*xlvqv/cp/r_v/t(i, k, j)/t(i&
& , k, j)))/theta(i, k, j)**2
coefa = (1.0+xlvqv/r_d/t(i, k, j))/(1.0+xlv*xlvqv/cp/r_v/t(i, &
& k, j)/t(i, k, j))/theta(i, k, j)
thetaep1d = thetad(i, k+1, j)*(1.0+xlv*qvs(i, k+1, j)/cp/t(i, &
& k+1, j)) + theta(i, k+1, j)*(xlv*qvsd(i, k+1, j)*t(i, k+1, j&
& )/cp-xlv*qvs(i, k+1, j)*td(i, k+1, j)/cp)/t(i, k+1, j)**2
thetaep1 = theta(i, k+1, j)*(1.0+xlv*qvs(i, k+1, j)/cp/t(i, k+&
& 1, j))
thetaem1d = thetad(i, k-1, j)*(1.0+xlv*qvs(i, k-1, j)/cp/t(i, &
& k-1, j)) + theta(i, k-1, j)*(xlv*qvsd(i, k-1, j)*t(i, k-1, j&
& )/cp-xlv*qvs(i, k-1, j)*td(i, k-1, j)/cp)/t(i, k-1, j)**2
thetaem1 = theta(i, k-1, j)*(1.0+xlv*qvs(i, k-1, j)/cp/t(i, k-&
& 1, j))
bn2d(i, k, j) = g*(((coefad*(thetaep1-thetaem1)+coefa*(&
& thetaep1d-thetaem1d))*tmpdz-coefa*(thetaep1-thetaem1)*tmpdzd&
& )/tmpdz**2-((tmp1d(i, k+1, j)-tmp1d(i, k-1, j))*tmpdz-(tmp1(&
& i, k+1, j)-tmp1(i, k-1, j))*tmpdzd)/tmpdz**2)
bn2(i, k, j) = g*(coefa*(thetaep1-thetaem1)/tmpdz-(tmp1(i, k+1&
& , j)-tmp1(i, k-1, j))/tmpdz)
ELSE
bn2d(i, k, j) = g*((((thetad(i, k+1, j)-thetad(i, k-1, j))*&
& theta(i, k, j)-(theta(i, k+1, j)-theta(i, k-1, j))*thetad(i&
& , k, j))*tmpdz/theta(i, k, j)**2-(theta(i, k+1, j)-theta(i, &
& k-1, j))*tmpdzd/theta(i, k, j))/tmpdz**2+(1.61*(moistd(i, k+&
& 1, j, p_qv)-moistd(i, k-1, j, p_qv))*tmpdz-1.61*(moist(i, k+&
& 1, j, p_qv)-moist(i, k-1, j, p_qv))*tmpdzd)/tmpdz**2-((tmp1d&
& (i, k+1, j)-tmp1d(i, k-1, j))*tmpdz-(tmp1(i, k+1, j)-tmp1(i&
& , k-1, j))*tmpdzd)/tmpdz**2)
bn2(i, k, j) = g*((theta(i, k+1, j)-theta(i, k-1, j))/theta(i&
& , k, j)/tmpdz+1.61*(moist(i, k+1, j, p_qv)-moist(i, k-1, j, &
& p_qv))/tmpdz-(tmp1(i, k+1, j)-tmp1(i, k-1, j))/tmpdz)
END IF
END DO
END DO
END DO
k = kts
DO j=j_start,j_end
DO i=i_start,i_end
tmpdzd = -(rdzd(i, k+1, j)/rdz(i, k+1, j)**2) - 0.5*rdzwd(i, k, j)&
& /rdzw(i, k, j)**2
tmpdz = 1.0/rdz(i, k+1, j) + 0.5/rdzw(i, k, j)
pwx1d = p8wd(i, k, j)/p1000mb
pwx1 = p8w(i, k, j)/p1000mb
pwy1 = r_d/cp
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pwy1 .EQ. INT(pwy1))) &
& THEN
pwr1d = pwy1*pwx1**(pwy1-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pwy1 .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pwy1
thetasfcd = (t8wd(i, kts, j)*pwr1-t8w(i, kts, j)*pwr1d)/pwr1**2
thetasfc = t8w(i, kts, j)/pwr1
IF (moist(i, k, j, p_qv) .GE. qvs(i, k, j) .OR. qctmp(i, k, j) &
& .GE. qc_cr) THEN
qvsfcd = cf1*qvsd(i, 1, j) + cf2*qvsd(i, 2, j) + cf3*qvsd(i, 3, &
& j)
qvsfc = cf1*qvs(i, 1, j) + cf2*qvs(i, 2, j) + cf3*qvs(i, 3, j)
xlvqvd = xlv*moistd(i, k, j, p_qv)
xlvqv = xlv*moist(i, k, j, p_qv)
coefad = (((xlvqvd*t(i, k, j)/r_d-xlvqv*td(i, k, j)/r_d)*(1.0+&
& xlv*xlvqv/cp/r_v/t(i, k, j)/t(i, k, j))/t(i, k, j)**2-(1.0+&
& xlvqv/r_d/t(i, k, j))*((xlv*xlvqvd*t(i, k, j)/(cp*r_v)-xlv*&
& xlvqv*td(i, k, j)/(cp*r_v))/t(i, k, j)-xlv*xlvqv*td(i, k, j)/(&
& cp*r_v*t(i, k, j)))/t(i, k, j)**2)*theta(i, k, j)/(1.0+xlv*&
& xlvqv/cp/r_v/t(i, k, j)/t(i, k, j))**2-(1.0+xlvqv/r_d/t(i, k, &
& j))*thetad(i, k, j)/(1.0+xlv*xlvqv/cp/r_v/t(i, k, j)/t(i, k, j&
& )))/theta(i, k, j)**2
coefa = (1.0+xlvqv/r_d/t(i, k, j))/(1.0+xlv*xlvqv/cp/r_v/t(i, k&
& , j)/t(i, k, j))/theta(i, k, j)
thetaep1d = thetad(i, k+1, j)*(1.0+xlv*qvs(i, k+1, j)/cp/t(i, k+&
& 1, j)) + theta(i, k+1, j)*(xlv*qvsd(i, k+1, j)*t(i, k+1, j)/cp&
& -xlv*qvs(i, k+1, j)*td(i, k+1, j)/cp)/t(i, k+1, j)**2
thetaep1 = theta(i, k+1, j)*(1.0+xlv*qvs(i, k+1, j)/cp/t(i, k+1&
& , j))
thetaesfcd = thetasfcd*(1.0+xlv*qvsfc/cp/t8w(i, kts, j)) + &
& thetasfc*(xlv*qvsfcd*t8w(i, kts, j)/cp-xlv*qvsfc*t8wd(i, kts, &
& j)/cp)/t8w(i, kts, j)**2
thetaesfc = thetasfc*(1.0+xlv*qvsfc/cp/t8w(i, kts, j))
bn2d(i, k, j) = g*(((coefad*(thetaep1-thetaesfc)+coefa*(&
& thetaep1d-thetaesfcd))*tmpdz-coefa*(thetaep1-thetaesfc)*tmpdzd&
& )/tmpdz**2-((tmp1d(i, k+1, j)-tmp1sfcd(i, j))*tmpdz-(tmp1(i, k&
& +1, j)-tmp1sfc(i, j))*tmpdzd)/tmpdz**2)
bn2(i, k, j) = g*(coefa*(thetaep1-thetaesfc)/tmpdz-(tmp1(i, k+1&
& , j)-tmp1sfc(i, j))/tmpdz)
ELSE
qvsfcd = cf1*moistd(i, 1, j, p_qv) + cf2*moistd(i, 2, j, p_qv) +&
& cf3*moistd(i, 3, j, p_qv)
qvsfc = cf1*moist(i, 1, j, p_qv) + cf2*moist(i, 2, j, p_qv) + &
& cf3*moist(i, 3, j, p_qv)
! BN2(i,k,j) = g * ( ( theta(i,k+1,j) - thetasfc ) / &
! theta(i,k,j) / tmpdz + &
! 1.61 * ( moist(i,k+1,j,P_QV) - qvsfc ) / &
! tmpdz - &
! ( tmp1(i,k+1,j) - tmp1sfc(i,j) ) / tmpdz )
!...... MARTA: change in computation of BN2 at the surface, WCS 040331
! controlare come calcola rdzw
tmpdzd = -(rdzwd(i, k, j)/rdzw(i, k, j)**2)
tmpdz = 1./rdzw(i, k, j)
bn2d(i, k, j) = g*((((thetad(i, k+1, j)-thetad(i, k, j))*theta(i&
& , k, j)-(theta(i, k+1, j)-theta(i, k, j))*thetad(i, k, j))*&
& tmpdz/theta(i, k, j)**2-(theta(i, k+1, j)-theta(i, k, j))*&
& tmpdzd/theta(i, k, j))/tmpdz**2+(1.61*(moistd(i, k+1, j, p_qv)&
& -qvsfcd)*tmpdz-1.61*(moist(i, k+1, j, p_qv)-qvsfc)*tmpdzd)/&
& tmpdz**2-((tmp1d(i, k+1, j)-tmp1sfcd(i, j))*tmpdz-(tmp1(i, k+1&
& , j)-tmp1sfc(i, j))*tmpdzd)/tmpdz**2)
bn2(i, k, j) = g*((theta(i, k+1, j)-theta(i, k, j))/theta(i, k, &
& j)/tmpdz+1.61*(moist(i, k+1, j, p_qv)-qvsfc)/tmpdz-(tmp1(i, k+&
& 1, j)-tmp1sfc(i, j))/tmpdz)
! end of MARTA/WCS change
END IF
END DO
END DO
!...... MARTA: change in computation of BN2 at the top, WCS 040331
DO j=j_start,j_end
DO i=i_start,i_end
bn2d(i, ktf, j) = bn2d(i, ktf-1, j)
bn2(i, ktf, j) = bn2(i, ktf-1, j)
END DO
END DO
END SUBROUTINE G_CALCULATE_N2
SUBROUTINE g_isotropic_km(config_flags,xkmh,g_xkmh,xkmv,g_xkmv,xkhh, &
g_xkhh,xkhv,g_xkhv,khdif,kvdif,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme, &
its,ite,jts,jte,kts,kte)
IMPLICIT NONE
REAL :: Tmpv1,g_Tmpv1
TYPE(grid_config_rec_type) :: config_flags
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
REAL :: khdif,kvdif
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: xkmh,g_xkmh,xkmv,g_xkmv,xkhh, &
g_xkhh,xkhv,g_xkhv
INTEGER :: i_start,i_end,j_start,j_end,ktf,i,j,k
REAL :: khdif3,kvdif3
ktf =kte
i_start =its
i_end =min(ite,ide-1)
j_start =jts
j_end =min(jte,jde-1)
khdif3 =khdif/prandtl
kvdif3 =kvdif/prandtl
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_xkmh(i,k,j) =0.0
xkmh(i,k,j) =khdif
g_xkmv(i,k,j) =0.0
xkmv(i,k,j) =kvdif
g_xkhh(i,k,j) =0.0
xkhh(i,k,j) =khdif3
g_xkhv(i,k,j) =0.0
xkhv(i,k,j) =kvdif3
ENDDO
ENDDO
ENDDO
END SUBROUTINE g_isotropic_km
SUBROUTINE g_smag_km(config_flags,xkmh,g_xkmh,xkmv,g_xkmv,xkhh,g_xkhh, &
xkhv,g_xkhv,BN2,g_BN2,div,g_div,defor11,g_defor11,defor22,g_defor22, &
defor33,g_defor33,defor12,g_defor12,defor13,g_defor13,defor23,g_defor23, &
rdzw,g_rdzw,dx,dy,dt,isotropic,mix_upper_bound,msftx,msfty,ids,ide,jds,jde,kds, &
kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
IMPLICIT NONE
REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2,Tmpv3,g_Tmpv3,Tmpv4,g_Tmpv4,Tmpv5,g_Tmpv5
REAL :: g_Sqrt
TYPE(grid_config_rec_type) :: config_flags
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
INTEGER :: isotropic
REAL :: dx,dy,dt,mix_upper_bound
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: BN2,g_BN2,rdzw,g_rdzw
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: xkmh,g_xkmh,xkmv,g_xkmv,xkhh, &
g_xkhh,xkhv,g_xkhv
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor11,g_defor11,defor22,g_defor22, &
defor33,g_defor33,defor12,g_defor12,defor13,g_defor13,defor23,g_defor23, &
div,g_div
REAL,DIMENSION(ims:ime,jms:jme) :: msftx,msfty
INTEGER :: i_start,i_end,j_start,j_end,ktf,i,j,k
REAL :: deltas,g_deltas,tmp,g_tmp,pr,g_pr,mlen_h,g_mlen_h,mlen_v, &
g_mlen_v,c_s,g_c_s
REAL,DIMENSION(its:ite,kts:kte,jts:jte) :: def2,g_def2
ktf =min(kte,kde-1)
i_start =its
i_end =min(ite,ide-1)
j_start =jts
j_end =min(jte,jde-1)
IF( config_flags%open_xs .or. config_flags%specified .or. &
config_flags%nested) i_start =max(ids+1,its)
IF( config_flags%open_xe .or. config_flags%specified .or. &
config_flags%nested) i_end =min(ide-2,ite)
IF( config_flags%open_ys .or. config_flags%specified .or. &
config_flags%nested) j_start =max(jds+1,jts)
IF( config_flags%open_ye .or. config_flags%specified .or. &
config_flags%nested) j_end =min(jde-2,jte)
IF( config_flags%periodic_x ) i_start =its
IF( config_flags%periodic_x ) i_end =min(ite,ide-1)
g_pr =0.0
pr =prandtl
!REVISED BY WALLS
!g_c_s =g_config_flags%c_s
g_c_s =0.0
c_s =config_flags%c_s
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_Tmpv1 =2.0*defor11(i,k,j)*g_defor11(i,k,j)
Tmpv1 =defor11(i,k,j)*defor11(i,k,j)
g_Tmpv2 =2.0*defor22(i,k,j)*g_defor22(i,k,j)
Tmpv2 =defor22(i,k,j)*defor22(i,k,j)
g_Tmpv3 =2.0*defor33(i,k,j)*g_defor33(i,k,j)
Tmpv3 =defor33(i,k,j)*defor33(i,k,j)
g_def2(i,k,j) =0.5*(g_Tmpv1 +g_Tmpv2 +g_Tmpv3)
def2(i,k,j) =0.5*(Tmpv1 +Tmpv2 +Tmpv3)
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_tmp =0.25*(g_defor12(i,k,j) +g_defor12(i,k,j+1) +g_defor12(i+1,k,j) &
+g_defor12(i+1,k,j+1))
tmp =0.25*(defor12(i,k,j) +defor12(i,k,j+1) +defor12(i+1,k,j) +defor12(i+1,k,j+1))
g_Tmpv1 =2.0*tmp*g_tmp
Tmpv1 =tmp*tmp
g_def2(i,k,j) =g_def2(i,k,j) +g_Tmpv1
def2(i,k,j) =def2(i,k,j) +Tmpv1
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_tmp =0.25*(g_defor13(i,k+1,j) +g_defor13(i,k,j) +g_defor13(i+1,k+1,j) &
+g_defor13(i+1,k,j))
tmp =0.25*(defor13(i,k+1,j) +defor13(i,k,j) +defor13(i+1,k+1,j) +defor13(i+1,k,j))
g_Tmpv1 =2.0*tmp*g_tmp
Tmpv1 =tmp*tmp
g_def2(i,k,j) =g_def2(i,k,j) +g_Tmpv1
def2(i,k,j) =def2(i,k,j) +Tmpv1
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_tmp =0.25*(g_defor23(i,k+1,j) +g_defor23(i,k,j) +g_defor23(i,k+1,j+1) &
+g_defor23(i,k,j+1))
tmp =0.25*(defor23(i,k+1,j) +defor23(i,k,j) +defor23(i,k+1,j+1) +defor23(i,k,j+1))
g_Tmpv1 =2.0*tmp*g_tmp
Tmpv1 =tmp*tmp
g_def2(i,k,j) =g_def2(i,k,j) +g_Tmpv1
def2(i,k,j) =def2(i,k,j) +Tmpv1
ENDDO
ENDDO
ENDDO
IF(isotropic .EQ. 0) THEN
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_mlen_h =0.0
mlen_h =sqrt(dx/msftx(i,j) *dy/msfty(i,j))
g_mlen_v =-1.*g_rdzw(i,k,j)/(rdzw(i,k,j)*rdzw(i,k,j))
mlen_v =1./rdzw(i,k,j)
g_Tmpv1 =(g_BN2(i,k,j)*pr -g_pr*BN2(i,k,j))/(pr*pr)
Tmpv1 =BN2(i,k,j)/pr
g_tmp =(0.0 +(g_def2(i,k,j) -g_Tmpv1) +(0.0 -(g_def2(i,k,j) -g_Tmpv1)) &
*sign(1.0, 0. -(def2(i,k,j) -Tmpv1)))*0.5
tmp =max(0.,def2(i,k,j) -Tmpv1)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!REVISED AND ADDED BY WALLS
IF(tmp.NE.0.0) THEN
g_tmp =0.5*g_tmp*tmp**(0.5 -1.0)
ELSE
! Reivsed by Ning Pan, 2010-08-18
g_tmp =0.0
! g_tmp =0.5*g_tmp/(tmp**0.5+1.e-10)
ENDIF
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
tmp =tmp**0.5
g_Tmpv1 =2.0*c_s*g_c_s
Tmpv1 =c_s*c_s
g_Tmpv2 =Tmpv1*g_mlen_h +g_Tmpv1*mlen_h
Tmpv2 =Tmpv1*mlen_h
g_Tmpv3 =Tmpv2*g_mlen_h +g_Tmpv2*mlen_h
Tmpv3 =Tmpv2*mlen_h
g_Tmpv4 =Tmpv3*g_tmp +g_Tmpv3*tmp
Tmpv4 =Tmpv3*tmp
g_Tmpv5 =1.0E-6*mlen_h*g_mlen_h +1.0E-6*g_mlen_h*mlen_h
Tmpv5 =1.0E-6*mlen_h*mlen_h
g_xkmh(i,k,j) =(g_Tmpv4 +g_Tmpv5 +(g_Tmpv4 -g_Tmpv5)*sign(1.0, Tmpv4 - &
(Tmpv5)))*0.5
xkmh(i,k,j) =max(Tmpv4,Tmpv5)
g_Tmpv1 =mix_upper_bound*mlen_h*g_mlen_h +mix_upper_bound*g_mlen_h*mlen_h
Tmpv1 =mix_upper_bound*mlen_h*mlen_h
g_xkmh(i,k,j) =(g_xkmh(i,k,j) +(g_Tmpv1/dt) -(g_xkmh(i,k,j) &
-(g_Tmpv1/dt))*sign(1.0, xkmh(i,k,j) -(Tmpv1/dt)))*0.5
xkmh(i,k,j) =min(xkmh(i,k,j),Tmpv1/dt)
g_Tmpv1 =2.0*c_s*g_c_s
Tmpv1 =c_s*c_s
g_Tmpv2 =Tmpv1*g_mlen_v +g_Tmpv1*mlen_v
Tmpv2 =Tmpv1*mlen_v
g_Tmpv3 =Tmpv2*g_mlen_v +g_Tmpv2*mlen_v
Tmpv3 =Tmpv2*mlen_v
g_Tmpv4 =Tmpv3*g_tmp +g_Tmpv3*tmp
Tmpv4 =Tmpv3*tmp
g_Tmpv5 =1.0E-6*mlen_v*g_mlen_v +1.0E-6*g_mlen_v*mlen_v
Tmpv5 =1.0E-6*mlen_v*mlen_v
g_xkmv(i,k,j) =(g_Tmpv4 +g_Tmpv5 +(g_Tmpv4 -g_Tmpv5)*sign(1.0, Tmpv4 - &
(Tmpv5)))*0.5
xkmv(i,k,j) =max(Tmpv4,Tmpv5)
g_Tmpv1 =mix_upper_bound*mlen_v*g_mlen_v +mix_upper_bound*g_mlen_v*mlen_v
Tmpv1 =mix_upper_bound*mlen_v*mlen_v
g_xkmv(i,k,j) =(g_xkmv(i,k,j) +(g_Tmpv1/dt) -(g_xkmv(i,k,j) &
-(g_Tmpv1/dt))*sign(1.0, xkmv(i,k,j) -(Tmpv1/dt)))*0.5
xkmv(i,k,j) =min(xkmv(i,k,j),Tmpv1/dt)
g_Tmpv1 =(g_xkmh(i,k,j)*pr -g_pr*xkmh(i,k,j))/(pr*pr)
Tmpv1 =xkmh(i,k,j)/pr
g_xkhh(i,k,j) =g_Tmpv1
xkhh(i,k,j) =Tmpv1
g_Tmpv1 =mix_upper_bound*mlen_h*g_mlen_h +mix_upper_bound*g_mlen_h*mlen_h
Tmpv1 =mix_upper_bound*mlen_h*mlen_h
g_xkhh(i,k,j) =(g_xkhh(i,k,j) +(g_Tmpv1/dt) -(g_xkhh(i,k,j) &
-(g_Tmpv1/dt))*sign(1.0, xkhh(i,k,j) -(Tmpv1/dt)))*0.5
xkhh(i,k,j) =min(xkhh(i,k,j),Tmpv1/dt)
g_Tmpv1 =(g_xkmv(i,k,j)*pr -g_pr*xkmv(i,k,j))/(pr*pr)
Tmpv1 =xkmv(i,k,j)/pr
g_xkhv(i,k,j) =g_Tmpv1
xkhv(i,k,j) =Tmpv1
g_Tmpv1 =mix_upper_bound*mlen_v*g_mlen_v +mix_upper_bound*g_mlen_v*mlen_v
Tmpv1 =mix_upper_bound*mlen_v*mlen_v
g_xkhv(i,k,j) =(g_xkhv(i,k,j) +(g_Tmpv1/dt) -(g_xkhv(i,k,j) &
-(g_Tmpv1/dt))*sign(1.0, xkhv(i,k,j) -(Tmpv1/dt)))*0.5
xkhv(i,k,j) =min(xkhv(i,k,j),Tmpv1/dt)
ENDDO
ENDDO
ENDDO
ELSE
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_deltas =0.33333333*(-dx/msftx(i,j) *dy/msfty(i,j)*g_rdzw(i,k,j)/(rdzw(i,k,j) &
*rdzw(i,k,j)))*(dx/msftx(i,j) *dy/msfty(i,j)/rdzw(i,k,j))**(0.33333333 -1.0)
deltas =(dx/msftx(i,j) *dy/msfty(i,j)/rdzw(i,k,j))**0.33333333
g_Tmpv1 =(g_BN2(i,k,j)*pr -g_pr*BN2(i,k,j))/(pr*pr)
Tmpv1 =BN2(i,k,j)/pr
g_tmp =(0.0 +(g_def2(i,k,j) -g_Tmpv1) +(0.0 -(g_def2(i,k,j) -g_Tmpv1)) &
*sign(1.0, 0. -(def2(i,k,j) -Tmpv1)))*0.5
tmp =max(0.,def2(i,k,j) -Tmpv1)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!REVISED AND ADDED BY WALLS
IF(tmp.NE.0.0) THEN
g_tmp =0.5*g_tmp*tmp**(0.5 -1.0)
ELSE
! Revised by Ning Pan, 2010-08-18
g_tmp =0.0
! g_tmp =0.5*g_tmp/(tmp**0.5+1.e-10)
ENDIF
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
tmp =tmp**0.5 ! Added by Ning Pan, 2010-08-18
g_Tmpv1 =2.0*c_s*g_c_s
Tmpv1 =c_s*c_s
g_Tmpv2 =Tmpv1*g_deltas +g_Tmpv1*deltas
Tmpv2 =Tmpv1*deltas
g_Tmpv3 =Tmpv2*g_deltas +g_Tmpv2*deltas
Tmpv3 =Tmpv2*deltas
g_Tmpv4 =Tmpv3*g_tmp +g_Tmpv3*tmp
Tmpv4 =Tmpv3*tmp
g_Tmpv5 =1.0E-6*deltas*g_deltas +1.0E-6*g_deltas*deltas
Tmpv5 =1.0E-6*deltas*deltas
g_xkmh(i,k,j) =(g_Tmpv4 +g_Tmpv5 +(g_Tmpv4 -g_Tmpv5)*sign(1.0, Tmpv4 - &
(Tmpv5)))*0.5
xkmh(i,k,j) =max(Tmpv4,Tmpv5)
g_xkmh(i,k,j) =(g_xkmh(i,k,j) +0.0 -(g_xkmh(i,k,j) -0.0)*sign(1.0, xkmh(i,k, &
j) -(mix_upper_bound *dx/msftx(i,j) *dy/msfty(i,j)/dt)))*0.5
xkmh(i,k,j) =min(xkmh(i,k,j),mix_upper_bound *dx/msftx(i,j) *dy/msfty(i,j)/dt)
g_xkmv(i,k,j) =g_xkmh(i,k,j)
xkmv(i,k,j) =xkmh(i,k,j)
g_Tmpv1 =((-mix_upper_bound*g_rdzw(i,k,j)/(rdzw(i,k,j)*rdzw(i,k,j))) &
*rdzw(i,k,j) -g_rdzw(i,k,j)*mix_upper_bound/rdzw(i,k,j))/(rdzw(i,k,j)*rdzw(i,k,j))
Tmpv1 =mix_upper_bound/rdzw(i,k,j)/rdzw(i,k,j)
g_xkmv(i,k,j) =(g_xkmv(i,k,j) +(g_Tmpv1/dt) -(g_xkmv(i,k,j) &
-(g_Tmpv1/dt))*sign(1.0, xkmv(i,k,j) -(Tmpv1/dt)))*0.5
xkmv(i,k,j) =min(xkmv(i,k,j),Tmpv1/dt)
g_Tmpv1 =(g_xkmh(i,k,j)*pr -g_pr*xkmh(i,k,j))/(pr*pr)
Tmpv1 =xkmh(i,k,j)/pr
g_xkhh(i,k,j) =g_Tmpv1
xkhh(i,k,j) =Tmpv1
g_xkhh(i,k,j) =(g_xkhh(i,k,j) +0.0 -(g_xkhh(i,k,j) -0.0)*sign(1.0, xkhh(i,k, &
j) -(mix_upper_bound *dx/msftx(i,j) *dy/msfty(i,j)/dt)))*0.5
xkhh(i,k,j) =min(xkhh(i,k,j),mix_upper_bound *dx/msftx(i,j) *dy/msfty(i,j)/dt)
g_Tmpv1 =(g_xkmv(i,k,j)*pr -g_pr*xkmv(i,k,j))/(pr*pr)
Tmpv1 =xkmv(i,k,j)/pr
g_xkhv(i,k,j) =g_Tmpv1
xkhv(i,k,j) =Tmpv1
g_Tmpv1 =((-mix_upper_bound*g_rdzw(i,k,j)/(rdzw(i,k,j)*rdzw(i,k,j))) &
*rdzw(i,k,j) -g_rdzw(i,k,j)*mix_upper_bound/rdzw(i,k,j))/(rdzw(i,k,j)*rdzw(i,k,j))
Tmpv1 =mix_upper_bound/rdzw(i,k,j)/rdzw(i,k,j)
g_xkhv(i,k,j) =(g_xkhv(i,k,j) +(g_Tmpv1/dt) -(g_xkhv(i,k,j) &
-(g_Tmpv1/dt))*sign(1.0, xkhv(i,k,j) -(Tmpv1/dt)))*0.5
xkhv(i,k,j) =min(xkhv(i,k,j),Tmpv1/dt)
ENDDO
ENDDO
ENDDO
ENDIF
END SUBROUTINE g_smag_km
! Generated by TAPENADE (INRIA, Tropics team)
! Tapenade 3.10 (r5363) - 9 Sep 2014 09:54
!
! Differentiation of smag2d_km in forward (tangent) mode:
! variations of useful results: xkmh xkmv xkhh xkhv
! with respect to varying inputs: defor11 defor12 zx zy xkmh
! defor22 xkmv rdzw xkhh xkhv
! RW status of diff variables: defor11:in defor12:in zx:in zy:in
! xkmh:in-out defor22:in xkmv:in-out rdzw:in xkhh:in-out
! xkhv:in-out
SUBROUTINE G_SMAG2D_KM(config_flags, xkmh, xkmhd, xkmv, xkmvd, xkhh, &
& xkhhd, xkhv, xkhvd, defor11, defor11d, defor22, defor22d, defor12, &
& defor12d, rdzw, rdzwd, dx, dy, msftx, msfty, zx, zxd, zy, zyd, ids, &
& ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, &
& jte, kts, kte)
IMPLICIT NONE
TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
& jme, kms, kme, its, ite, jts, jte, kts, kte
REAL, INTENT(IN) :: dx, dy
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: rdzw, zx, zy
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: rdzwd, zxd, &
& zyd
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: xkmh, &
& xkmv, xkhh, xkhv
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: xkmhd, &
& xkmvd, xkhhd, xkhvd
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: defor11, &
& defor22, defor12
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: defor11d, &
& defor22d, defor12d
REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msftx, msfty
! LOCAL VARS
INTEGER :: i_start, i_end, j_start, j_end, ktf, i, j, k
REAL :: deltas, tmp, pr, mlen_h, c_s
REAL :: tmpd
REAL :: dxm, dym, tmpzx, tmpzy, alpha, def_limit
REAL :: tmpzxd, tmpzyd, alphad
REAL, DIMENSION(its:ite, kts:kte, jts:jte) :: def2
REAL, DIMENSION(its:ite, kts:kte, jts:jte) :: def2d
REAL :: arg1
REAL :: arg1d
REAL :: abs1d
REAL :: abs4d
REAL :: abs7d
REAL :: x1
REAL :: abs0d
REAL :: abs3d
REAL :: abs6d
REAL :: x1d
REAL :: abs7
REAL :: abs6
REAL :: abs5
REAL :: abs4
REAL :: abs3
REAL :: abs2
REAL :: abs2d
REAL :: abs1
REAL :: abs0
REAL :: abs5d
IF (kte .GT. kde - 1) THEN
ktf = kde - 1
ELSE
ktf = kte
END IF
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
IF ((config_flags%open_xs .OR. config_flags%specified) .OR. &
& config_flags%nested) THEN
IF (ids + 1 .LT. its) THEN
i_start = its
ELSE
i_start = ids + 1
END IF
END IF
IF ((config_flags%open_xe .OR. config_flags%specified) .OR. &
& config_flags%nested) THEN
IF (ide - 2 .GT. ite) THEN
i_end = ite
ELSE
i_end = ide - 2
END IF
END IF
IF ((config_flags%open_ys .OR. config_flags%specified) .OR. &
& config_flags%nested) THEN
IF (jds + 1 .LT. jts) THEN
j_start = jts
ELSE
j_start = jds + 1
END IF
END IF
IF ((config_flags%open_ye .OR. config_flags%specified) .OR. &
& config_flags%nested) THEN
IF (jde - 2 .GT. jte) THEN
j_end = jte
ELSE
j_end = jde - 2
END IF
END IF
IF (config_flags%periodic_x) i_start = its
IF (config_flags%periodic_x) THEN
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
END IF
pr = prandtl
c_s = config_flags%c_s
def2d = 0.0_8
DO j=j_start,j_end
DO k=kts,ktf
DO i=i_start,i_end
def2d(i, k, j) = 0.25*((defor11d(i, k, j)-defor22d(i, k, j))*(&
& defor11(i, k, j)-defor22(i, k, j))+(defor11(i, k, j)-defor22(i&
& , k, j))*(defor11d(i, k, j)-defor22d(i, k, j)))
def2(i, k, j) = 0.25*((defor11(i, k, j)-defor22(i, k, j))*(&
& defor11(i, k, j)-defor22(i, k, j)))
tmpd = 0.25*(defor12d(i, k, j)+defor12d(i, k, j+1)+defor12d(i+1&
& , k, j)+defor12d(i+1, k, j+1))
tmp = 0.25*(defor12(i, k, j)+defor12(i, k, j+1)+defor12(i+1, k, &
& j)+defor12(i+1, k, j+1))
def2d(i, k, j) = def2d(i, k, j) + tmpd*tmp + tmp*tmpd
def2(i, k, j) = def2(i, k, j) + tmp*tmp
END DO
END DO
END DO
!
DO j=j_start,j_end
DO k=kts,ktf
DO i=i_start,i_end
arg1 = dx/msftx(i, j)*dy/msfty(i, j)
mlen_h = SQRT(arg1)
IF (def2(i, k, j) .EQ. 0.0_8) THEN
tmpd = 0.0_8
ELSE
tmpd = def2d(i, k, j)/(2.0*SQRT(def2(i, k, j)))
END IF
tmp = SQRT(def2(i, k, j))
! xkmh(i,k,j)=max(c_s*c_s*mlen_h*mlen_h*tmp, 1.0E-6*mlen_h*mlen_h )
xkmhd(i, k, j) = c_s**2*mlen_h**2*tmpd
xkmh(i, k, j) = c_s*c_s*mlen_h*mlen_h*tmp
IF (xkmh(i, k, j) .GT. 10.*mlen_h) THEN
xkmhd(i, k, j) = 0.0_8
xkmh(i, k, j) = 10.*mlen_h
ELSE
xkmh(i, k, j) = xkmh(i, k, j)
END IF
xkmvd(i, k, j) = 0.0_8
xkmv(i, k, j) = 0.
xkhhd(i, k, j) = xkmhd(i, k, j)/pr
xkhh(i, k, j) = xkmh(i, k, j)/pr
xkhvd(i, k, j) = 0.0_8
xkhv(i, k, j) = 0.
IF (config_flags%diff_opt .EQ. 2) THEN
! jd: reduce diffusion coefficient by slope factor (modified by JB August 2014)
dxm = dx/msftx(i, j)
dym = dy/msfty(i, j)
IF (zx(i, k, j) .GE. 0.0_8) THEN
abs0d = zxd(i, k, j)
abs0 = zx(i, k, j)
ELSE
abs0d = -zxd(i, k, j)
abs0 = -zx(i, k, j)
END IF
IF (zx(i+1, k, j) .GE. 0.0_8) THEN
abs2d = zxd(i+1, k, j)
abs2 = zx(i+1, k, j)
ELSE
abs2d = -zxd(i+1, k, j)
abs2 = -zx(i+1, k, j)
END IF
IF (zx(i, k+1, j) .GE. 0.0_8) THEN
abs4d = zxd(i, k+1, j)
abs4 = zx(i, k+1, j)
ELSE
abs4d = -zxd(i, k+1, j)
abs4 = -zx(i, k+1, j)
END IF
IF (zx(i+1, k+1, j) .GE. 0.0_8) THEN
abs6d = zxd(i+1, k+1, j)
abs6 = zx(i+1, k+1, j)
ELSE
abs6d = -zxd(i+1, k+1, j)
abs6 = -zx(i+1, k+1, j)
END IF
tmpzxd = 0.25*dxm*((abs0d+abs2d+abs4d+abs6d)*rdzw(i, k, j)+(&
& abs0+abs2+abs4+abs6)*rdzwd(i, k, j))
tmpzx = 0.25*(abs0+abs2+abs4+abs6)*rdzw(i, k, j)*dxm
IF (zy(i, k, j) .GE. 0.0_8) THEN
abs1d = zyd(i, k, j)
abs1 = zy(i, k, j)
ELSE
abs1d = -zyd(i, k, j)
abs1 = -zy(i, k, j)
END IF
IF (zy(i, k, j+1) .GE. 0.0_8) THEN
abs3d = zyd(i, k, j+1)
abs3 = zy(i, k, j+1)
ELSE
abs3d = -zyd(i, k, j+1)
abs3 = -zy(i, k, j+1)
END IF
IF (zy(i, k+1, j) .GE. 0.0_8) THEN
abs5d = zyd(i, k+1, j)
abs5 = zy(i, k+1, j)
ELSE
abs5d = -zyd(i, k+1, j)
abs5 = -zy(i, k+1, j)
END IF
IF (zy(i, k+1, j+1) .GE. 0.0_8) THEN
abs7d = zyd(i, k+1, j+1)
abs7 = zy(i, k+1, j+1)
ELSE
abs7d = -zyd(i, k+1, j+1)
abs7 = -zy(i, k+1, j+1)
END IF
tmpzyd = 0.25*dym*((abs1d+abs3d+abs5d+abs7d)*rdzw(i, k, j)+(&
& abs1+abs3+abs5+abs7)*rdzwd(i, k, j))
tmpzy = 0.25*(abs1+abs3+abs5+abs7)*rdzw(i, k, j)*dym
arg1d = tmpzxd*tmpzx + tmpzx*tmpzxd + tmpzyd*tmpzy + tmpzy*&
& tmpzyd
arg1 = tmpzx*tmpzx + tmpzy*tmpzy
IF (arg1 .EQ. 0.0_8) THEN
x1d = 0.0_8
ELSE
x1d = arg1d/(2.0*SQRT(arg1))
END IF
x1 = SQRT(arg1)
IF (x1 .LT. 1.0) THEN
alpha = 1.0
alphad = 0.0_8
ELSE
alphad = x1d
alpha = x1
END IF
IF (10.0/mlen_h .LT. 1.e-3) THEN
def_limit = 1.e-3
ELSE
def_limit = 10.0/mlen_h
END IF
IF (tmp .GT. def_limit) THEN
xkmhd(i, k, j) = (xkmhd(i, k, j)*alpha**2-xkmh(i, k, j)*(&
& alphad*alpha+alpha*alphad))/(alpha*alpha)**2
xkmh(i, k, j) = xkmh(i, k, j)/(alpha*alpha)
ELSE
xkmhd(i, k, j) = (xkmhd(i, k, j)*alpha-xkmh(i, k, j)*alphad)&
& /alpha**2
xkmh(i, k, j) = xkmh(i, k, j)/alpha
END IF
xkhhd(i, k, j) = xkmhd(i, k, j)/pr
xkhh(i, k, j) = xkmh(i, k, j)/pr
END IF
END DO
END DO
END DO
END SUBROUTINE G_SMAG2D_KM
SUBROUTINE g_phy_bc(config_flags,div,g_div,defor11,g_defor11,defor22, &
g_defor22,defor33,g_defor33,defor12,g_defor12,defor13,g_defor13,defor23, &
g_defor23,xkmh,g_xkmh,xkmv,g_xkmv,xkhh,g_xkhh,xkhv,g_xkhv,tke, &
g_tke,RUBLTEN,g_RUBLTEN,RVBLTEN,g_RVBLTEN,RUCUTEN,g_RUCUTEN,RVCUTEN,g_RVCUTEN,&
RUSHTEN,g_RUSHTEN,RVSHTEN,g_RVSHTEN,ids,ide,jds,jde,kds,kde,ims,ime, &
jms,jme,kms,kme,ips,ipe,jps,jpe,kps,kpe,its,ite,jts,jte,kts,kte)
IMPLICIT NONE
REAL :: Tmpv1,g_Tmpv1
TYPE(grid_config_rec_type) :: config_flags
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,ips,ipe,jps,jpe,kps,kpe, &
its,ite,jts,jte,kts,kte
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: RUBLTEN,g_RUBLTEN,RVBLTEN,g_RVBLTEN, &
RUCUTEN,g_RUCUTEN,RVCUTEN,g_RVCUTEN, RUSHTEN,g_RUSHTEN,RVSHTEN,g_RVSHTEN, &
defor11,g_defor11,defor22,g_defor22,defor33,g_defor33,defor12,g_defor12, &
defor13,g_defor13,defor23,g_defor23,xkmh,g_xkmh,xkmv,g_xkmv,xkhh, &
g_xkhh,xkhv,g_xkhv,tke,g_tke,div,g_div
IF(config_flags%bl_pbl_physics .GT. 0) THEN
CALL g_set_physical_bc3d(RUBLTEN,g_RUBLTEN,'t',config_flags,ids,ide,jds,jde, &
kds,kde,ims,ime,jms,jme,kms,kme,ips,ipe,jps,jpe,kps,kpe,its,ite,jts,jte,kts,kte)
CALL g_set_physical_bc3d(RVBLTEN,g_RVBLTEN,'t',config_flags,ids,ide,jds,jde, &
kds,kde,ims,ime,jms,jme,kms,kme,ips,ipe,jps,jpe,kps,kpe,its,ite,jts,jte,kts,kte)
ENDIF
!Tiedtke ZCX&YQW
IF(config_flags%cu_physics .GT. 0) THEN
CALL g_set_physical_bc3d(RUCUTEN,g_RUCUTEN,'t',config_flags,ids,ide,jds,jde, &
kds,kde,ims,ime,jms,jme,kms,kme,ips,ipe,jps,jpe,kps,kpe,its,ite,jts,jte,kts,kte)
CALL g_set_physical_bc3d(RVCUTEN,g_RVCUTEN,'t',config_flags,ids,ide,jds,jde, &
kds,kde,ims,ime,jms,jme,kms,kme,ips,ipe,jps,jpe,kps,kpe,its,ite,jts,jte,kts,kte)
ENDIF
IF(config_flags%shcu_physics .GT. 0) THEN
CALL g_set_physical_bc3d( RUSHTEN, g_RUSHTEN,'t', config_flags, &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
ips, ipe, jps, jpe, kps, kpe, &
its, ite, jts, jte, kts, kte )
CALL g_set_physical_bc3d( RVSHTEN, g_RVSHTEN,'t', config_flags, &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
ips, ipe, jps, jpe, kps, kpe, &
its, ite, jts, jte, kts, kte )
ENDIF
CALL g_set_physical_bc3d(xkmh,g_xkmh,'t',config_flags,ids,ide,jds,jde,kds,kde, &
ims,ime,jms,jme,kms,kme,ips,ipe,jps,jpe,kps,kpe,its,ite,jts,jte,kts,kte)
CALL g_set_physical_bc3d(xkhh,g_xkhh,'t',config_flags,ids,ide,jds,jde,kds,kde, &
ims,ime,jms,jme,kms,kme,ips,ipe,jps,jpe,kps,kpe,its,ite,jts,jte,kts,kte)
IF(config_flags%diff_opt .eq. 2) THEN
CALL g_set_physical_bc3d(xkmv,g_xkmv,'t',config_flags,ids,ide,jds,jde,kds,kde, &
ims,ime,jms,jme,kms,kme,ips,ipe,jps,jpe,kps,kpe,its,ite,jts,jte,kts,kte)
CALL g_set_physical_bc3d(xkhv,g_xkhv,'t',config_flags,ids,ide,jds,jde,kds,kde, &
ims,ime,jms,jme,kms,kme,ips,ipe,jps,jpe,kps,kpe,its,ite,jts,jte,kts,kte)
CALL g_set_physical_bc3d(div,g_div,'t',config_flags,ids,ide,jds,jde,kds,kde, &
ims,ime,jms,jme,kms,kme,ips,ipe,jps,jpe,kps,kpe,its,ite,jts,jte,kts,kte)
CALL g_set_physical_bc3d(defor11,g_defor11,'t',config_flags,ids,ide,jds,jde, &
kds,kde,ims,ime,jms,jme,kms,kme,ips,ipe,jps,jpe,kps,kpe,its,ite,jts,jte,kts,kte)
CALL g_set_physical_bc3d(defor22,g_defor22,'t',config_flags,ids,ide,jds,jde, &
kds,kde,ims,ime,jms,jme,kms,kme,ips,ipe,jps,jpe,kps,kpe,its,ite,jts,jte,kts,kte)
CALL g_set_physical_bc3d(defor33,g_defor33,'t',config_flags,ids,ide,jds,jde, &
kds,kde,ims,ime,jms,jme,kms,kme,ips,ipe,jps,jpe,kps,kpe,its,ite,jts,jte,kts,kte)
CALL g_set_physical_bc3d(defor12,g_defor12,'d',config_flags,ids,ide,jds,jde, &
kds,kde,ims,ime,jms,jme,kms,kme,ips,ipe,jps,jpe,kps,kpe,its,ite,jts,jte,kts,kte)
CALL g_set_physical_bc3d(defor13,g_defor13,'e',config_flags,ids,ide,jds,jde, &
kds,kde,ims,ime,jms,jme,kms,kme,ips,ipe,jps,jpe,kps,kpe,its,ite,jts,jte,kts,kte)
CALL g_set_physical_bc3d(defor23,g_defor23,'f',config_flags,ids,ide,jds,jde, &
kds,kde,ims,ime,jms,jme,kms,kme,ips,ipe,jps,jpe,kps,kpe,its,ite,jts,jte,kts,kte)
ENDIF
END SUBROUTINE g_phy_bc
SUBROUTINE g_tke_km(config_flags,xkmh,g_xkmh,xkmv,g_xkmv,xkhh,g_xkhh, &
xkhv,g_xkhv,bn2,g_bn2,tke,g_tke,p8w,g_p8w,t8w,g_t8w,theta,g_theta, &
rdz,g_rdz,rdzw,g_rdzw,dx,dy,dt,isotropic,mix_upper_bound,msftx,msfty,ids,ide, &
jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
IMPLICIT NONE
REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2,Tmpv3,g_Tmpv3,Tmpv4,g_Tmpv4,Tmpv5, &
g_Tmpv5,Tmpv6,g_Tmpv6
REAL :: g_Sqrt
TYPE(grid_config_rec_type) :: config_flags
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
INTEGER :: isotropic
REAL :: dx,dy,dt
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tke,g_tke,p8w,g_p8w,t8w,g_t8w, &
theta,g_theta,rdz,g_rdz,rdzw,g_rdzw,bn2,g_bn2
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: xkmh,g_xkmh,xkmv,g_xkmv,xkhh, &
g_xkhh,xkhv,g_xkhv
REAL :: mix_upper_bound
REAL,DIMENSION(ims:ime,jms:jme) :: msftx,msfty
REAL,DIMENSION(its:ite,kts:kte,jts:jte) :: l_scale,g_l_scale
REAL,DIMENSION(its:ite,kts:kte,jts:jte) :: dthrdn,g_dthrdn
REAL :: deltas,g_deltas,tmp,g_tmp,mlen_s,g_mlen_s,mlen_h,g_mlen_h,mlen_v, &
g_mlen_v,tmpdz,g_tmpdz,thetasfc,g_thetasfc,thetatop,g_thetatop,minkx, &
g_minkx,pr_inv,g_pr_inv,pr_inv_h,g_pr_inv_h,pr_inv_v,g_pr_inv_v,c_k,g_c_k
INTEGER :: i_start,i_end,j_start,j_end,ktf,i,j,k
REAL,PARAMETER :: tke_seed_value =1.e-06
REAL :: tke_seed
REAL,PARAMETER :: epsilon =1.e-10
ktf =min(kte,kde-1)
i_start =its
i_end =min(ite,ide-1)
j_start =jts
j_end =min(jte,jde-1)
IF( config_flags%open_xs .OR. config_flags%specified .OR. &
config_flags%nested) i_start =max(ids+1,its)
IF( config_flags%open_xe .OR. config_flags%specified .OR. &
config_flags%nested) i_end =min(ide-2,ite)
IF( config_flags%open_ys .OR. config_flags%specified .OR. &
config_flags%nested) j_start =max(jds+1,jts)
IF( config_flags%open_ye .OR. config_flags%specified .OR. &
config_flags%nested) j_end =min(jde-2,jte)
IF( config_flags%periodic_x ) i_start =its
IF( config_flags%periodic_x ) i_end =min(ite,ide-1)
!REVISED BY WALLS
g_c_k =0.0
c_k =config_flags%c_k
tke_seed =tke_seed_value
if( (config_flags%tke_drag_coefficient .gt. epsilon) .or. &
(config_flags%tke_heat_flux .gt. epsilon) ) tke_seed =0.
DO j =j_start,j_end
DO k =kts+1,ktf-1
DO i =i_start,i_end
g_tmpdz = -(g_rdz(i,k+1,j)/(rdz(i,k+1,j)*rdz(i,k+1,j))) - &
& g_rdz(i,k,j)/(rdz(i,k,j)*rdz(i,k,j))
tmpdz = 1.0/rdz(i,k+1,j) + 1.0/rdz(i,k,j)
g_Tmpv1 = ((g_theta(i,k+1,j)-g_theta(i,k-1,j))*tmpdz- &
& g_tmpdz*(theta(i,k+1,j)-theta(i,k-1,j)))/(tmpdz*tmpdz)
Tmpv1 = (theta(i,k+1,j)-theta(i,k-1,j))/tmpdz
g_dthrdn(i,k,j) =g_Tmpv1
dthrdn(i,k,j) =Tmpv1
ENDDO
ENDDO
ENDDO
k =kts
DO j =j_start,j_end
DO i =i_start,i_end
g_tmpdz = -(g_rdzw(i,k+1,j)/(rdzw(i,k+1,j)*rdzw(i,k+1,j))) - &
& g_rdzw(i,k,j)/(rdzw(i,k,j)*rdzw(i,k,j))
tmpdz = 1.0/rdzw(i,k+1,j) + 1.0/rdzw(i,k,j)
g_Tmpv1 =(g_T8w(i,kts,j)*(p8w(i,k,j)/p1000mb)**(R_d/Cp) -(R_d/Cp) &
*(g_p8w(i,k,j)/p1000mb)*(p8w(i,k,j)/p1000mb)**((R_d/Cp) -1.0)*T8w(i,kts,j)) &
/((p8w(i,k,j)/p1000mb)**(R_d/Cp)*(p8w(i,k,j)/p1000mb)**(R_d/Cp))
Tmpv1 =T8w(i,kts,j)/(p8w(i,k,j)/p1000mb)**(R_d/Cp)
g_thetasfc =g_Tmpv1
thetasfc =Tmpv1
g_Tmpv1 =((g_theta(i,k+1,j) -g_thetasfc)*tmpdz -g_tmpdz*(theta(i,k+1,j) &
-thetasfc))/(tmpdz*tmpdz)
Tmpv1 =(theta(i,k+1,j) -thetasfc)/tmpdz
g_dthrdn(i,k,j) =g_Tmpv1
dthrdn(i,k,j) =Tmpv1
ENDDO
ENDDO
k =ktf
DO j =j_start,j_end
DO i =i_start,i_end
g_tmpdz =-1.0*g_rdz(i,k,j)/(rdz(i,k,j)*rdz(i,k,j)) +(-0.5*g_rdzw(i,k,j) &
/(rdzw(i,k,j)*rdzw(i,k,j)))
tmpdz =1.0/rdz(i,k,j)+0.5/rdzw(i,k,j)
g_Tmpv1 =(g_T8w(i,kde,j)*(p8w(i,kde,j)/p1000mb)**(R_d/Cp) -(R_d/Cp) &
*(g_p8w(i,kde,j)/p1000mb)*(p8w(i,kde,j)/p1000mb)**((R_d/Cp) -1.0)*T8w(i,kde,j)) &
/((p8w(i,kde,j)/p1000mb)**(R_d/Cp)*(p8w(i,kde,j)/p1000mb)**(R_d/Cp))
Tmpv1 =T8w(i,kde,j)/(p8w(i,kde,j)/p1000mb)**(R_d/Cp)
g_thetatop =g_Tmpv1
thetatop =Tmpv1
g_Tmpv1 =((g_thetatop -g_theta(i,k-1,j))*tmpdz -g_tmpdz*(thetatop - &
theta(i,k-1,j)))/(tmpdz*tmpdz)
Tmpv1 =(thetatop -theta(i,k-1,j))/tmpdz
g_dthrdn(i,k,j) =g_Tmpv1
dthrdn(i,k,j) =Tmpv1
ENDDO
ENDDO
!ADDED BY WALLS
!isotropic=1
IF( isotropic .EQ. 0 ) THEN
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_mlen_h =0.0
mlen_h =sqrt(dx/msftx(i,j) *dy/msfty(i,j))
g_tmp =g_Sqrt((g_tke(i,k,j) +0.0 +(g_tke(i,k,j) -0.0)*sign(1.0, tke(i,k, &
j) -(tke_seed)))*0.5, max(tke(i,k,j),tke_seed))
tmp =sqrt(max(tke(i,k,j),tke_seed))
g_deltas =-1.0*g_rdzw(i,k,j)/(rdzw(i,k,j)*rdzw(i,k,j))
deltas =1.0/rdzw(i,k,j)
g_mlen_v =g_deltas
mlen_v =deltas
IF( dthrdn(i,k,j) .GT. 0.) THEN
g_Tmpv1 =g/theta(i,k,j)*g_dthrdn(i,k,j) +(-g*g_theta(i,k,j)/(theta(i,k,j) &
*theta(i,k,j)))*dthrdn(i,k,j)
Tmpv1 =g/theta(i,k,j)*dthrdn(i,k,j)
g_Tmpv2 =(0.76*g_tmp*(abs(Tmpv1))**0.5 -0.5*(sign(1.0, Tmpv1)*g_Tmpv1) &
*(abs(Tmpv1))**(0.5 -1.0)*0.76*tmp)/((abs(Tmpv1))**0.5*(abs(Tmpv1))**0.5)
Tmpv2 =0.76*tmp/(abs(Tmpv1))**0.5
g_mlen_s =g_Tmpv2
mlen_s =Tmpv2
g_mlen_v =(g_mlen_v +g_mlen_s -(g_mlen_v -g_mlen_s)*sign(1.0, mlen_v - &
(mlen_s)))*0.5
mlen_v =min(mlen_v,mlen_s)
END IF
g_Tmpv1 =c_k*g_tmp +g_c_k*tmp
Tmpv1 =c_k*tmp
g_Tmpv2 =Tmpv1*g_mlen_h +g_Tmpv1*mlen_h
Tmpv2 =Tmpv1*mlen_h
g_Tmpv3 =1.0E-6*mlen_h*g_mlen_h +1.0E-6*g_mlen_h*mlen_h
Tmpv3 =1.0E-6*mlen_h*mlen_h
g_xkmh(i,k,j) =(g_Tmpv2 +g_Tmpv3 +(g_Tmpv2 -g_Tmpv3)*sign(1.0, Tmpv2 - &
(Tmpv3)))*0.5
xkmh(i,k,j) =max(Tmpv2,Tmpv3)
g_Tmpv1 =mix_upper_bound*mlen_h*g_mlen_h +mix_upper_bound*g_mlen_h*mlen_h
Tmpv1 =mix_upper_bound*mlen_h*mlen_h
g_xkmh(i,k,j) =(g_xkmh(i,k,j) +(g_Tmpv1/dt) -(g_xkmh(i,k,j) &
-(g_Tmpv1/dt))*sign(1.0, xkmh(i,k,j) -(Tmpv1/dt)))*0.5
xkmh(i,k,j) =min(xkmh(i,k,j),Tmpv1/dt)
g_Tmpv1 =c_k*g_tmp +g_c_k*tmp
Tmpv1 =c_k*tmp
g_Tmpv2 =Tmpv1*g_mlen_v +g_Tmpv1*mlen_v
Tmpv2 =Tmpv1*mlen_v
g_Tmpv3 =1.0E-6*deltas*g_deltas +1.0E-6*g_deltas*deltas
Tmpv3 =1.0E-6*deltas*deltas
g_xkmv(i,k,j) =(g_Tmpv2 +g_Tmpv3 +(g_Tmpv2 -g_Tmpv3)*sign(1.0, Tmpv2 - &
(Tmpv3)))*0.5
xkmv(i,k,j) =max(Tmpv2,Tmpv3)
g_Tmpv1 =mix_upper_bound*deltas*g_deltas +mix_upper_bound*g_deltas*deltas
Tmpv1 =mix_upper_bound*deltas*deltas
g_xkmv(i,k,j) =(g_xkmv(i,k,j) +(g_Tmpv1/dt) -(g_xkmv(i,k,j) &
-(g_Tmpv1/dt))*sign(1.0, xkmv(i,k,j) -(Tmpv1/dt)))*0.5
xkmv(i,k,j) =min(xkmv(i,k,j),Tmpv1/dt)
g_pr_inv_h =0.0
pr_inv_h =1./prandtl
g_Tmpv1 =(2.0*g_mlen_v*deltas -g_deltas*2.0*mlen_v)/(deltas*deltas)
Tmpv1 =2.0*mlen_v/deltas
g_pr_inv_v =g_Tmpv1
pr_inv_v =1.0 +Tmpv1
g_Tmpv1 =xkmh(i,k,j)*g_pr_inv_h +g_xkmh(i,k,j)*pr_inv_h
Tmpv1 =xkmh(i,k,j)*pr_inv_h
g_xkhh(i,k,j) =g_Tmpv1
xkhh(i,k,j) =Tmpv1
g_Tmpv1 =xkmv(i,k,j)*g_pr_inv_v +g_xkmv(i,k,j)*pr_inv_v
Tmpv1 =xkmv(i,k,j)*pr_inv_v
g_xkhv(i,k,j) =g_Tmpv1
xkhv(i,k,j) =Tmpv1
ENDDO
ENDDO
ENDDO
ELSE
CALL g_calc_l_scale(config_flags,tke,g_tke,BN2,g_BN2,l_scale,g_l_scale, &
i_start,i_end,ktf,j_start,j_end,dx,dy,rdzw,g_rdzw,msftx,msfty,ids,ide,jds,jde,kds, &
kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_tmp =g_Sqrt((g_tke(i,k,j) +0.0 +(g_tke(i,k,j) -0.0)*sign(1.0, tke(i,k, &
j) -(tke_seed)))*0.5, max(tke(i,k,j),tke_seed))
tmp =sqrt(max(tke(i,k,j),tke_seed))
g_deltas =0.33333333*(-dx/msftx(i,j) *dy/msfty(i,j)*g_rdzw(i,k,j)/(rdzw(i,k,j) &
*rdzw(i,k,j)))*(dx/msftx(i,j) *dy/msfty(i,j)/rdzw(i,k,j))**(0.33333333 -1.0)
deltas =(dx/msftx(i,j) *dy/msfty(i,j)/rdzw(i,k,j))**0.33333333
g_Tmpv1 =c_k*g_tmp +g_c_k*tmp
Tmpv1 =c_k*tmp
g_Tmpv2 =Tmpv1*g_l_scale(i,k,j) +g_Tmpv1*l_scale(i,k,j)
Tmpv2 =Tmpv1*l_scale(i,k,j)
g_xkmh(i,k,j) =g_Tmpv2
xkmh(i,k,j) =Tmpv2
g_xkmh(i,k,j) =(0.0 +g_xkmh(i,k,j) -(0.0 -g_xkmh(i,k,j))*sign(1.0, &
mix_upper_bound *dx/msftx(i,j) *dy/msfty(i,j)/dt -(xkmh(i,k,j))))*0.5
xkmh(i,k,j) =min(mix_upper_bound *dx/msftx(i,j) *dy/msfty(i,j)/dt,xkmh(i,k,j))
g_Tmpv1 =c_k*g_tmp +g_c_k*tmp
Tmpv1 =c_k*tmp
g_Tmpv2 =Tmpv1*g_l_scale(i,k,j) +g_Tmpv1*l_scale(i,k,j)
Tmpv2 =Tmpv1*l_scale(i,k,j)
g_xkmv(i,k,j) =g_Tmpv2
xkmv(i,k,j) =Tmpv2
g_Tmpv1 =((-mix_upper_bound*g_rdzw(i,k,j)/(rdzw(i,k,j)*rdzw(i,k,j))) &
*rdzw(i,k,j) -g_rdzw(i,k,j)*mix_upper_bound/rdzw(i,k,j))/(rdzw(i,k,j)*rdzw(i,k,j))
! Added by Ning Pan, 2010-08-13
Tmpv1 =mix_upper_bound/rdzw(i,k,j)/rdzw(i,k,j)
g_xkmv(i,k,j) =(g_Tmpv1/dt +g_xkmv(i,k,j) -(g_Tmpv1/dt -g_xkmv(i,k,j)) &
*sign(1.0, Tmpv1/dt -(xkmv(i,k,j))))*0.5
xkmv(i,k,j) =min(mix_upper_bound/rdzw(i,k,j)/rdzw(i,k,j)/dt,xkmv(i,k,j))
g_Tmpv1 =(2.0*g_l_scale(i,k,j)*deltas -g_deltas*2.0*l_scale(i,k,j))/(deltas*deltas)
Tmpv1 =2.0*l_scale(i,k,j)/deltas
g_pr_inv =g_Tmpv1
pr_inv =1.0 +Tmpv1
g_Tmpv1 =xkmh(i,k,j)*g_pr_inv +g_xkmh(i,k,j)*pr_inv
Tmpv1 =xkmh(i,k,j)*pr_inv
g_xkhh(i,k,j) =(0.0 +g_Tmpv1 -(0.0 -g_Tmpv1)*sign(1.0, mix_upper_bound *dx/ &
msftx(i,j) *dy/msfty(i,j)/dt -(Tmpv1)))*0.5
xkhh(i,k,j) =min(mix_upper_bound *dx/msftx(i,j) *dy/msfty(i,j)/dt,Tmpv1)
g_Tmpv1 =((-mix_upper_bound*g_rdzw(i,k,j)/(rdzw(i,k,j)*rdzw(i,k,j))) &
*rdzw(i,k,j) -g_rdzw(i,k,j)*mix_upper_bound/rdzw(i,k,j))/(rdzw(i,k,j)*rdzw(i,k,j))
Tmpv1 =mix_upper_bound/rdzw(i,k,j)/rdzw(i,k,j)
g_Tmpv2 =xkmv(i,k,j)*g_pr_inv +g_xkmv(i,k,j)*pr_inv
Tmpv2 =xkmv(i,k,j)*pr_inv
g_xkhv(i,k,j) =(g_Tmpv1/dt +g_Tmpv2 -(g_Tmpv1/dt -g_Tmpv2) &
*sign(1.0, Tmpv1/dt -(Tmpv2)))*0.5
xkhv(i,k,j) =min(Tmpv1/dt,Tmpv2)
ENDDO
ENDDO
ENDDO
END IF
END SUBROUTINE g_tke_km
SUBROUTINE g_tke_rhs(tendency,g_tendency,BN2,g_BN2,config_flags,defor11, &
g_defor11,defor22,g_defor22,defor33,g_defor33,defor12,g_defor12,defor13, &
g_defor13,defor23,g_defor23,u,g_u,v,g_v,w,g_w,div,g_div,tke, &
g_tke,mu,g_mu,theta,g_theta,p,g_p,p8w,g_p8w,t8w,g_t8w,z,g_z,fnm, &
fnp,cf1,cf2,cf3,msftx,msfty,xkmh,g_xkmh,xkmv,g_xkmv,xkhv,g_xkhv,rdx,rdy,dx, &
dy,dt,zx,g_zx,zy,g_zy,rdz,g_rdz,rdzw,g_rdzw,dn,dnw,isotropic,hfx, &
g_hfx,qfx,g_qfx,qv,g_qv,ust,g_ust,rho,g_rho,ids,ide,jds,jde,kds,kde, &
ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
IMPLICIT NONE
REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2
TYPE(grid_config_rec_type) :: config_flags
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
INTEGER :: isotropic
REAL :: cf1,cf2,cf3,dt,rdx,rdy,dx,dy
REAL,DIMENSION(kms:kme) :: fnm,fnp,dnw,dn
REAL,DIMENSION(ims:ime,jms:jme) :: msftx,msfty
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,g_tendency
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor11,g_defor11,defor22,g_defor22, &
defor33,g_defor33,defor12,g_defor12,defor13,g_defor13,defor23,g_defor23, &
div,g_div,BN2,g_BN2,tke,g_tke,xkmh,g_xkmh,xkmv,g_xkmv,xkhv,g_xkhv, &
zx,g_zx,zy,g_zy,u,g_u,v,g_v,w,g_w,theta,g_theta,p,g_p,p8w, &
g_p8w,t8w,g_t8w,z,g_z,rdz,g_rdz,rdzw,g_rdzw
REAL,DIMENSION(ims:ime,jms:jme) :: mu,g_mu
REAL,DIMENSION(ims:ime,jms:jme) :: hfx,g_hfx,ust,g_ust,qfx,g_qfx
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: qv,g_qv,rho,g_rho
INTEGER :: i,j,k,ktf,i_start,i_end,j_start,j_end
CALL g_tke_shear(tendency,g_tendency,config_flags,defor11,g_defor11,defor22, &
g_defor22,defor33,g_defor33,defor12,g_defor12,defor13,g_defor13,defor23, &
g_defor23,u,g_u,v,g_v,w,g_w,tke,g_tke,ust,g_ust,mu,g_mu,fnm,fnp, &
cf1,cf2,cf3,msftx,msfty,xkmh,g_xkmh,xkmv,g_xkmv,rdx,rdy,zx,g_zx,zy,g_zy, &
rdz,g_rdz,rdzw,g_rdzw,dnw,dn,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme, &
its,ite,jts,jte,kts,kte)
CALL g_tke_buoyancy(tendency,g_tendency,config_flags,mu,g_mu,tke,g_tke, &
xkhv,g_xkhv,BN2,g_BN2,theta,g_theta,dt,hfx,g_hfx,qfx,g_qfx,qv,g_qv, &
rho,g_rho,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
CALL g_tke_dissip(tendency,g_tendency,config_flags,mu,g_mu,tke,g_tke,bn2, &
g_bn2,theta,g_theta,p8w,g_p8w,t8w,g_t8w,z,g_z,dx,dy,rdz,g_rdz,rdzw, &
g_rdzw,isotropic,msftx,msfty,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its, &
ite,jts,jte,kts,kte)
ktf =min(kte,kde-1)
i_start =its
i_end =min(ite,ide-1)
j_start =jts
j_end =min(jte,jde-1)
IF( config_flags%open_xs .or. config_flags%specified .or. &
config_flags%nested) i_start =max(ids+1,its)
IF( config_flags%open_xe .or. config_flags%specified .or. &
config_flags%nested) i_end =min(ide-2,ite)
IF( config_flags%open_ys .or. config_flags%specified .or. &
config_flags%nested) j_start =max(jds+1,jts)
IF( config_flags%open_ye .or. config_flags%specified .or. &
config_flags%nested) j_end =min(jde-2,jte)
IF( config_flags%periodic_x ) i_start =its
IF( config_flags%periodic_x ) i_end =min(ite,ide-1)
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_Tmpv1 =-mu(i,j)*(0.0 +g_tke(i,k,j) +(0.0 -g_tke(i,k,j))*sign(1.0, 0.0 -( &
tke(i,k,j))))*0.5 -g_mu(i,j)*max(0.0,tke(i,k,j))
Tmpv1 =-mu(i,j)*max(0.0,tke(i,k,j))
g_tendency(i,k,j) =(g_tendency(i,k,j) +(g_Tmpv1/dt) +(g_tendency(i,k,j) &
-(g_Tmpv1/dt))*sign(1.0, tendency(i,k,j) -(Tmpv1/dt)))*0.5
tendency(i,k,j) =max(tendency(i,k,j),Tmpv1/dt)
ENDDO
ENDDO
ENDDO
END SUBROUTINE g_tke_rhs
SUBROUTINE g_calc_l_scale(config_flags,tke,g_tke,BN2,g_BN2,l_scale, &
g_l_scale,i_start,i_end,ktf,j_start,j_end,dx,dy,rdzw,g_rdzw,msftx,msfty,ids, &
ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
IMPLICIT NONE
REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2,Tmpv3,g_Tmpv3,Tmpv4,g_Tmpv4
REAL :: g_Sqrt
TYPE(grid_config_rec_type) :: config_flags
INTEGER :: i_start,i_end,ktf,j_start,j_end,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme, &
kms,kme,its,ite,jts,jte,kts,kte
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: BN2,g_BN2,tke,g_tke,rdzw,g_rdzw
REAL :: dx,dy
REAL,DIMENSION(its:ite,kts:kte,jts:jte) :: l_scale,g_l_scale
REAL,DIMENSION(ims:ime,jms:jme) :: msftx,msfty
INTEGER :: i,j,k
REAL :: deltas,g_deltas,tmp,g_tmp
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_deltas =0.33333333*(-dx/msftx(i,j) *dy/msfty(i,j)*g_rdzw(i,k,j)/(rdzw(i,k,j) &
*rdzw(i,k,j)))*(dx/msftx(i,j) *dy/msfty(i,j)/rdzw(i,k,j))**(0.33333333 -1.0)
deltas =(dx/msftx(i,j) *dy/msfty(i,j)/rdzw(i,k,j))**0.33333333
g_l_scale(i,k,j) =g_deltas
l_scale(i,k,j) =deltas
IF( BN2(i,k,j) .gt. 1.0e-6 ) THEN
g_tmp =g_Sqrt((g_tke(i,k,j) +0.0 +(g_tke(i,k,j) -0.0)*sign(1.0, tke(i,k, &
j) -(1.0e-6)))*0.5, max(tke(i,k,j),1.0e-6))
tmp =sqrt(max(tke(i,k,j),1.0e-6))
g_Tmpv1 =(0.76*g_tmp*sqrt(BN2(i,k,j)) -g_Sqrt(g_BN2(i,k,j), BN2(i,k,j)) &
*0.76*tmp)/(sqrt(BN2(i,k,j))*sqrt(BN2(i,k,j)))
Tmpv1 =0.76*tmp/sqrt(BN2(i,k,j))
g_l_scale(i,k,j) =g_Tmpv1
l_scale(i,k,j) =Tmpv1
g_l_scale(i,k,j) =(g_l_scale(i,k,j) +g_deltas -(g_l_scale(i,k,j) &
-g_deltas)*sign(1.0, l_scale(i,k,j) -(deltas)))*0.5
l_scale(i,k,j) =min(l_scale(i,k,j),deltas)
g_l_scale(i,k,j) =(g_l_scale(i,k,j) +0.001*g_deltas +(g_l_scale(i,k,j) &
-0.001*g_deltas)*sign(1.0, l_scale(i,k,j) -(0.001*deltas)))*0.5
l_scale(i,k,j) =max(l_scale(i,k,j),0.001*deltas)
END IF
ENDDO
ENDDO
ENDDO
END SUBROUTINE g_calc_l_scale
SUBROUTINE g_tke_buoyancy(tendency,g_tendency,config_flags,mu,g_mu,tke, &
g_tke,xkhv,g_xkhv,BN2,g_BN2,theta,g_theta,dt,hfx,g_hfx,qfx,g_qfx, &
qv,g_qv,rho,g_rho,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts, &
jte,kts,kte)
IMPLICIT NONE
REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2,Tmpv3,g_Tmpv3
TYPE(grid_config_rec_type) :: config_flags
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
REAL :: dt
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,g_tendency
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: xkhv,g_xkhv,tke,g_tke,BN2,g_BN2, &
theta,g_theta
REAL,DIMENSION(ims:ime,jms:jme) :: mu,g_mu
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: qv,g_qv,rho,g_rho
REAL,DIMENSION(ims:ime,jms:jme) :: hfx,g_hfx,qfx,g_qfx
INTEGER :: i,j,k,ktf
INTEGER :: i_start,i_end,j_start,j_end
REAL :: heat_flux,g_heat_flux,heat_flux0,g_heat_flux0
REAL :: cpm,g_cpm
ktf =min(kte,kde-1)
i_start =its
i_end =min(ite,ide-1)
j_start =jts
j_end =min(jte,jde-1)
IF( config_flags%open_xs .OR. config_flags%specified .OR. &
config_flags%nested ) i_start =max(ids+1,its)
IF( config_flags%open_xe .OR. config_flags%specified .OR. &
config_flags%nested ) i_end =min(ide-2,ite)
IF( config_flags%open_ys .OR. config_flags%specified .OR. &
config_flags%nested ) j_start =max(jds+1,jts)
IF( config_flags%open_ye .OR. config_flags%specified .OR. &
config_flags%nested ) j_end =min(jde-2,jte)
IF( config_flags%periodic_x ) i_start =its
IF( config_flags%periodic_x ) i_end =min(ite,ide-1)
DO j =j_start,j_end
DO k =kts+1,ktf
DO i =i_start,i_end
g_Tmpv1 =mu(i,j)*g_xkhv(i,k,j) +g_mu(i,j)*xkhv(i,k,j)
Tmpv1 =mu(i,j)*xkhv(i,k,j)
g_Tmpv2 =Tmpv1*g_BN2(i,k,j) +g_Tmpv1*BN2(i,k,j)
Tmpv2 =Tmpv1*BN2(i,k,j)
g_tendency(i,k,j) =g_tendency(i,k,j) -g_Tmpv2
tendency(i,k,j) =tendency(i,k,j) -Tmpv2
ENDDO
ENDDO
ENDDO
! Added by Ning Pan, 2010-08-12
tl_hflux: SELECT CASE( config_flags%isfflx )
CASE (0,2)
! g_heat_flux0 =g_config_flags%tke_heat_flux ! Remarked by Ning Pan, 2010-08-12
heat_flux0 =config_flags%tke_heat_flux
K =KTS
DO j =j_start,j_end
DO i =i_start,i_end
! g_heat_flux =g_heat_flux0 ! Remarked by Ning Pan, 2010-08-12
heat_flux =heat_flux0
g_Tmpv1 =xkhv(i,k,j)*g_BN2(i,k,j) +g_xkhv(i,k,j)*BN2(i,k,j)
Tmpv1 =xkhv(i,k,j)*BN2(i,k,j)
! Revised by Ning Pan, 2010-08-12
! g_Tmpv2 =(g/theta(i,k,j))*g_heat_flux +(-g*g_theta(i,k,j)/(theta(i,k,j) &
!*theta(i,k,j)))*heat_flux
g_Tmpv2 =(-g*g_theta(i,k,j)/(theta(i,k,j) &
*theta(i,k,j)))*heat_flux
Tmpv2 =(g/theta(i,k,j))*heat_flux
g_Tmpv3 =mu(i,j)*((g_Tmpv1) -g_Tmpv2) +g_mu(i,j)*((Tmpv1) -Tmpv2)
Tmpv3 =mu(i,j)*((Tmpv1) -Tmpv2)
g_tendency(i,k,j) =g_tendency(i,k,j) -(g_Tmpv3/2.)
tendency(i,k,j) =tendency(i,k,j) -Tmpv3/2.
ENDDO
ENDDO
CASE (1) ! Added by Ning Pan, 2010-08-12
K =KTS
DO j =j_start,j_end
DO i =i_start,i_end
g_cpm =cp*(0.8*g_qv(i,k,j))
cpm =cp*(1. +0.8*qv(i,k,j))
g_Tmpv1 =(g_hfx(i,j)*cpm -g_cpm*hfx(i,j))/(cpm*cpm)
Tmpv1 =hfx(i,j)/cpm
g_Tmpv2 =((g_Tmpv1)*rho(i,k,j) -g_rho(i,k,j)*(Tmpv1))/(rho(i,k,j)*rho(i,k,j))
Tmpv2 =(Tmpv1)/rho(i,k,j)
g_heat_flux =g_Tmpv2
heat_flux =Tmpv2
g_Tmpv1 =xkhv(i,k,j)*g_BN2(i,k,j) +g_xkhv(i,k,j)*BN2(i,k,j)
Tmpv1 =xkhv(i,k,j)*BN2(i,k,j)
g_Tmpv2 =(g/theta(i,k,j))*g_heat_flux +(-g*g_theta(i,k,j)/(theta(i,k,j) &
*theta(i,k,j)))*heat_flux
Tmpv2 =(g/theta(i,k,j))*heat_flux
g_Tmpv3 =mu(i,j)*((g_Tmpv1) -g_Tmpv2) +g_mu(i,j)*((Tmpv1) -Tmpv2)
Tmpv3 =mu(i,j)*((Tmpv1) -Tmpv2)
g_tendency(i,k,j) =g_tendency(i,k,j) -(g_Tmpv3/2.)
tendency(i,k,j) =tendency(i,k,j) -Tmpv3/2.
ENDDO
ENDDO
CASE DEFAULT ! Added by Ning Pan, 2010-08-12
! Revised by Ning Pan, 2010-08-12
! CALL g_wrf_error_fatal('isfflx value invalid for diff_opt=2')
CALL wrf_error_fatal( 'isfflx value invalid for diff_opt=2' )
END SELECT tl_hflux ! Added by Ning Pan, 2010-08-12
END SUBROUTINE g_tke_buoyancy
SUBROUTINE g_tke_dissip(tendency,g_tendency,config_flags,mu,g_mu,tke, &
g_tke,bn2,g_bn2,theta,g_theta,p8w,g_p8w,t8w,g_t8w,z,g_z,dx,dy,rdz, &
g_rdz,rdzw,g_rdzw,isotropic,msftx,msfty,ids,ide,jds,jde,kds,kde,ims,ime,jms, &
jme,kms,kme,its,ite,jts,jte,kts,kte)
IMPLICIT NONE
REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2,Tmpv3,g_Tmpv3,Tmpv4,g_Tmpv4
TYPE(grid_config_rec_type) :: config_flags
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
INTEGER :: isotropic
REAL :: dx,dy
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,g_tendency
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tke,g_tke,bn2,g_bn2,theta, &
g_theta,p8w,g_p8w,t8w,g_t8w,z,g_z,rdz,g_rdz,rdzw,g_rdzw
REAL,DIMENSION(ims:ime,jms:jme) :: mu,g_mu
REAL,DIMENSION(ims:ime,jms:jme) :: msftx,msfty
REAL,DIMENSION(its:ite,kts:kte,jts:jte) :: dthrdn,g_dthrdn
REAL,DIMENSION(its:ite,kts:kte,jts:jte) :: l_scale,g_l_scale
REAL,DIMENSION(its:ite) :: sumtke,g_sumtke,sumtkez,g_sumtkez
INTEGER :: i,j,k,ktf,i_start,i_end,j_start,j_end
REAL :: disp_len,g_disp_len,deltas,g_deltas,coefc,g_coefc,tmpdz,g_tmpdz, &
len_s,g_len_s,thetasfc,g_thetasfc,thetatop,g_thetatop,len_0,g_len_0, &
tketmp,g_tketmp,tmp,g_tmp,ce1,g_ce1,ce2,g_ce2,c_k,g_c_k
! g_c_k =g_config_flags%c_k ! Remarked by Ning Pan, 2010-08-12
c_k =config_flags%c_k
! g_ce1 =(g_c_k/0.10)*0.19 ! Remarked by Ning Pan, 2010-08-12
ce1 =(c_k/0.10)*0.19
! g_ce2 =(0.0 +-g_ce1 +(0.0 --g_ce1)*sign(1.0, 0.0 -(0.93 -ce1)))*0.5 ! Remarked by Ning Pan, 2010-08-12
ce2 =max(0.0,0.93 -ce1)
ktf =min(kte,kde-1)
i_start =its
i_end =min(ite,ide-1)
j_start =jts
j_end =min(jte,jde-1)
IF( config_flags%open_xs .OR. config_flags%specified .OR. &
config_flags%nested) i_start =max(ids+1,its)
IF( config_flags%open_xe .OR. config_flags%specified .OR. &
config_flags%nested) i_end =min(ide-2,ite)
IF( config_flags%open_ys .OR. config_flags%specified .OR. &
config_flags%nested) j_start =max(jds+1,jts)
IF( config_flags%open_ye .OR. config_flags%specified .OR. &
config_flags%nested) j_end =min(jde-2,jte)
IF( config_flags%periodic_x ) i_start =its
IF( config_flags%periodic_x ) i_end =min(ite,ide-1)
CALL g_calc_l_scale(config_flags,tke,g_tke,BN2,g_BN2,l_scale,g_l_scale, &
i_start,i_end,ktf,j_start,j_end,dx,dy,rdzw,g_rdzw,msftx,msfty,ids,ide,jds,jde,kds, &
kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_deltas =0.33333333*(-dx/msftx(i,j) *dy/msfty(i,j)*g_rdzw(i,k,j)/(rdzw(i,k,j) &
*rdzw(i,k,j)))*(dx/msftx(i,j) *dy/msfty(i,j)/rdzw(i,k,j))**(0.33333333 -1.0)
deltas =(dx/msftx(i,j) *dy/msfty(i,j)/rdzw(i,k,j))**0.33333333
g_tketmp =(g_tke(i,k,j) +0.0 +(g_tke(i,k,j) -0.0)*sign(1.0, tke(i,k,j) &
-(1.0e-6)))*0.5
tketmp =max(tke(i,k,j),1.0e-6)
IF( k .eq. kts .or. k .eq. ktf ) THEN
g_coefc =0.0
coefc =3.9
ELSE
! Revised by Ning Pan, 2010-08-12
! g_Tmpv1 =ce2*g_l_scale(i,k,j) +g_ce2*l_scale(i,k,j)
g_Tmpv1 =ce2*g_l_scale(i,k,j)
Tmpv1 =ce2*l_scale(i,k,j)
g_Tmpv2 =(g_Tmpv1*deltas -g_deltas*Tmpv1)/(deltas*deltas)
Tmpv2 =Tmpv1/deltas
! Revised by Ning Pan, 2010-08-12
! g_coefc =g_ce1 +g_Tmpv2
g_coefc =g_Tmpv2
coefc =ce1 +Tmpv2
END IF
g_Tmpv1 =mu(i,j)*g_coefc +g_mu(i,j)*coefc
Tmpv1 =mu(i,j)*coefc
g_Tmpv2 =Tmpv1*1.5*g_tketmp*tketmp**(1.5 -1.0) +g_Tmpv1*tketmp**1.5
Tmpv2 =Tmpv1*tketmp**1.5
g_Tmpv3 =(g_Tmpv2*l_scale(i,k,j) -g_l_scale(i,k,j)*Tmpv2)/(l_scale(i,k,j) &
*l_scale(i,k,j))
Tmpv3 =Tmpv2/l_scale(i,k,j)
g_tendency(i,k,j) =g_tendency(i,k,j) -g_Tmpv3
tendency(i,k,j) =tendency(i,k,j) -Tmpv3
ENDDO
ENDDO
ENDDO
END SUBROUTINE g_tke_dissip
SUBROUTINE g_tke_shear(tendency,g_tendency,config_flags,defor11,g_defor11, &
defor22,g_defor22,defor33,g_defor33,defor12,g_defor12,defor13,g_defor13, &
defor23,g_defor23,u,g_u,v,g_v,w,g_w,tke,g_tke,ust,g_ust,mu,g_mu, &
fnm,fnp,cf1,cf2,cf3,msftx,msfty,xkmh,g_xkmh,xkmv,g_xkmv,rdx,rdy,zx,g_zx,zy, &
g_zy,rdz,g_rdz,rdzw,g_rdzw,dn,dnw,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme, &
kms,kme,its,ite,jts,jte,kts,kte)
IMPLICIT NONE
REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2,Tmpv3,g_Tmpv3,Tmpv4,g_Tmpv4
REAL :: g_Sqrt
TYPE(grid_config_rec_type) :: config_flags
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
REAL :: cf1,cf2,cf3,rdx,rdy
REAL,DIMENSION(kms:kme) :: fnm,fnp,dn,dnw
REAL,DIMENSION(ims:ime,jms:jme) :: msftx,msfty
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,g_tendency
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor11,g_defor11,defor22,g_defor22, &
defor33,g_defor33,defor12,g_defor12,defor13,g_defor13,defor23,g_defor23, &
tke,g_tke,xkmh,g_xkmh,xkmv,g_xkmv,zx,g_zx,zy,g_zy,u,g_u,v,g_v,w, &
g_w,rdz,g_rdz,rdzw,g_rdzw
REAL,DIMENSION(ims:ime,jms:jme) :: mu,g_mu
REAL,DIMENSION(ims:ime,jms:jme) :: ust,g_ust
INTEGER :: i,j,k,ktf,ktes1,ktes2,i_start,i_end,j_start,j_end,is_ext,ie_ext,js_ext,je_ext
REAL :: mtau,g_mtau
REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: avg,g_avg,titau,g_titau, &
tmp2,g_tmp2
REAL,DIMENSION(its:ite,kts:kte,jts:jte) :: titau12,g_titau12,tmp1,g_tmp1,zxavg, &
g_zxavg,zyavg,g_zyavg
REAL :: absU,g_absU,cd0,g_cd0,Cd,g_Cd
ktf =min(kte,kde-1)
ktes1 =kte-1
ktes2 =kte-2
i_start =its
i_end =min(ite,ide-1)
j_start =jts
j_end =min(jte,jde-1)
IF( config_flags%open_xs .OR. config_flags%specified .OR. &
config_flags%nested ) i_start =max(ids+1,its)
IF( config_flags%open_xe .OR. config_flags%specified .OR. &
config_flags%nested ) i_end =min(ide-2,ite)
IF( config_flags%open_ys .OR. config_flags%specified .OR. &
config_flags%nested ) j_start =max(jds+1,jts)
IF( config_flags%open_ye .OR. config_flags%specified .OR. &
config_flags%nested ) j_end =min(jde-2,jte)
IF( config_flags%periodic_x ) i_start =its
IF( config_flags%periodic_x ) i_end =min(ite,ide-1)
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_zxavg(i,k,j) =0.25*(g_zx(i,k,j) +g_zx(i+1,k,j) +g_zx(i,k+1,j) &
+g_zx(i+1,k+1,j))
zxavg(i,k,j) =0.25*(zx(i,k,j) +zx(i+1,k,j) +zx(i,k+1,j) +zx(i+1,k+1,j))
g_zyavg(i,k,j) =0.25*(g_zy(i,k,j) +g_zy(i,k,j+1) +g_zy(i,k+1,j) &
+g_zy(i,k+1,j+1))
zyavg(i,k,j) =0.25*(zy(i,k,j) +zy(i,k,j+1) +zy(i,k+1,j) +zy(i,k+1,j+1))
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_Tmpv1 =0.5*mu(i,j)*g_xkmh(i,k,j) +0.5*g_mu(i,j)*xkmh(i,k,j)
Tmpv1 =0.5*mu(i,j)*xkmh(i,k,j)
g_Tmpv2 =Tmpv1*(2.0*(g_defor11(i,k,j))*(defor11(i,k,j))) +g_Tmpv1*(( &
defor11(i,k,j))**2)
Tmpv2 =Tmpv1*((defor11(i,k,j))**2)
g_tendency(i,k,j) =g_tendency(i,k,j) +g_Tmpv2
tendency(i,k,j) =tendency(i,k,j) +Tmpv2
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_Tmpv1 =0.5*mu(i,j)*g_xkmh(i,k,j) +0.5*g_mu(i,j)*xkmh(i,k,j)
Tmpv1 =0.5*mu(i,j)*xkmh(i,k,j)
g_Tmpv2 =Tmpv1*(2.0*(g_defor22(i,k,j))*(defor22(i,k,j))) +g_Tmpv1*(( &
defor22(i,k,j))**2)
Tmpv2 =Tmpv1*((defor22(i,k,j))**2)
g_tendency(i,k,j) =g_tendency(i,k,j) +g_Tmpv2
tendency(i,k,j) =tendency(i,k,j) +Tmpv2
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_Tmpv1 =0.5*mu(i,j)*g_xkmv(i,k,j) +0.5*g_mu(i,j)*xkmv(i,k,j)
Tmpv1 =0.5*mu(i,j)*xkmv(i,k,j)
g_Tmpv2 =Tmpv1*(2.0*(g_defor33(i,k,j))*(defor33(i,k,j))) +g_Tmpv1*(( &
defor33(i,k,j))**2)
Tmpv2 =Tmpv1*((defor33(i,k,j))**2)
g_tendency(i,k,j) =g_tendency(i,k,j) +g_Tmpv2
tendency(i,k,j) =tendency(i,k,j) +Tmpv2
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_avg(i,k,j) =0.25*((2.0*g_defor12(i,k,j)*defor12(i,k,j)) +(2.0*g_defor12(i, &
k,j+1)*defor12(i,k,j+1)) +(2.0*g_defor12(i+1,k,j)*defor12(i+1,k,j)) +(2.0* &
g_defor12(i+1,k,j+1)*defor12(i+1,k,j+1)))
avg(i,k,j) =0.25*((defor12(i,k,j)**2) +(defor12(i,k,j+1)**2) +(defor12(i+1,k,j)**2) &
+(defor12(i+1,k,j+1)**2))
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_Tmpv1 =mu(i,j)*g_xkmh(i,k,j) +g_mu(i,j)*xkmh(i,k,j)
Tmpv1 =mu(i,j)*xkmh(i,k,j)
g_Tmpv2 =Tmpv1*g_avg(i,k,j) +g_Tmpv1*avg(i,k,j)
Tmpv2 =Tmpv1*avg(i,k,j)
g_tendency(i,k,j) =g_tendency(i,k,j) +g_Tmpv2
tendency(i,k,j) =tendency(i,k,j) +Tmpv2
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO k =kts+1,ktf
DO i =i_start,i_end+1
g_tmp2(i,k,j) =g_defor13(i,k,j)
tmp2(i,k,j) =defor13(i,k,j)
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO i =i_start,i_end+1
g_tmp2(i,kts,j) =0.0
tmp2(i,kts,j) =0.0
g_tmp2(i,ktf+1,j) =0.0
tmp2(i,ktf+1,j) =0.0
ENDDO
ENDDO
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_avg(i,k,j) =0.25*((2.0*g_tmp2(i,k+1,j)*tmp2(i,k+1,j)) +(2.0*g_tmp2(i,k,j) &
*tmp2(i,k,j)) +(2.0*g_tmp2(i+1,k+1,j)*tmp2(i+1,k+1,j)) +(2.0*g_tmp2(i+1,k,j) &
*tmp2(i+1,k,j)))
avg(i,k,j) =0.25*((tmp2(i,k+1,j)**2) +(tmp2(i,k,j)**2) +(tmp2(i+1,k+1,j)**2) &
+(tmp2(i+1,k,j)**2))
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_Tmpv1 =mu(i,j)*g_xkmv(i,k,j) +g_mu(i,j)*xkmv(i,k,j)
Tmpv1 =mu(i,j)*xkmv(i,k,j)
g_Tmpv2 =Tmpv1*g_avg(i,k,j) +g_Tmpv1*avg(i,k,j)
Tmpv2 =Tmpv1*avg(i,k,j)
g_tendency(i,k,j) =g_tendency(i,k,j) +g_Tmpv2
tendency(i,k,j) =tendency(i,k,j) +Tmpv2
ENDDO
ENDDO
ENDDO
K =KTS
! Added by Ning Pan, 2010-08-12
tl_uflux: SELECT CASE( config_flags%isfflx )
CASE (0)
! g_cd0 =g_config_flags%tke_drag_coefficient ! Remarked by Ning Pan, 2010-08-12
cd0 =config_flags%tke_drag_coefficient
DO j =j_start,j_end
DO i =i_start,i_end
g_absU =0.5*g_Sqrt(2.0*(g_u(i,k,j) +g_u(i+1,k,j))*(u(i,k,j) +u(i+1,k,j)) &
+2.0*(g_v(i,k,j) +g_v(i,k,j+1))*(v(i,k,j) +v(i,k,j+1)), (u(i,k,j) +u(i+1,k,j)) &
**2 +(v(i,k,j) +v(i,k,j+1))**2)
absU =0.5*sqrt((u(i,k,j) +u(i+1,k,j))**2 +(v(i,k,j) +v(i,k,j+1))**2)
! Revised by Ning Pan, 2010-08-12
! g_Cd =g_cd0
g_Cd =0.0
Cd =cd0
g_Tmpv1 =(u(i,k,j) +u(i+1,k,j))*0.5*g_Cd +(g_u(i,k,j) +g_u(i+1,k,j))*0.5*Cd
Tmpv1 =(u(i,k,j) +u(i+1,k,j))*0.5*Cd
g_Tmpv2 =Tmpv1*g_absU +g_Tmpv1*absU
Tmpv2 =Tmpv1*absU
g_Tmpv3 =Tmpv2*(g_defor13(i,kts+1,j) +g_defor13(i+1,kts+1,j)) &
+g_Tmpv2*(defor13(i,kts+1,j) +defor13(i+1,kts+1,j))
Tmpv3 =Tmpv2*(defor13(i,kts+1,j) +defor13(i+1,kts+1,j))
g_Tmpv4 =mu(i,j)*(g_Tmpv3*0.5) +g_mu(i,j)*(Tmpv3*0.5)
Tmpv4 =mu(i,j)*(Tmpv3*0.5)
g_tendency(i,k,j) =g_tendency(i,k,j) +g_Tmpv4
tendency(i,k,j) =tendency(i,k,j) +Tmpv4
ENDDO
ENDDO
CASE (1,2) ! Added by Ning Pan, 2010-08-12
DO j =j_start,j_end
DO i =i_start,i_end
g_absU =0.5*g_Sqrt(2.0*(g_u(i,k,j) +g_u(i+1,k,j))*(u(i,k,j) +u(i+1,k,j)) &
+2.0*(g_v(i,k,j) +g_v(i,k,j+1))*(v(i,k,j) +v(i,k,j+1)), (u(i,k,j) +u(i+1,k,j)) &
**2 +(v(i,k,j) +v(i,k,j+1))**2)
absU =0.5*sqrt((u(i,k,j) +u(i+1,k,j))**2 +(v(i,k,j) +v(i,k,j+1))**2) +epsilon
g_Tmpv1 =((2.0*g_ust(i,j)*ust(i,j))*(absU**2) -(2.0*g_absU*absU)*(ust(i,j) &
**2))/((absU**2)*(absU**2))
Tmpv1 =(ust(i,j)**2)/(absU**2)
g_Cd =g_Tmpv1
Cd =Tmpv1
g_Tmpv1 =(u(i,k,j) +u(i+1,k,j))*0.5*g_Cd +(g_u(i,k,j) +g_u(i+1,k,j))*0.5*Cd
Tmpv1 =(u(i,k,j) +u(i+1,k,j))*0.5*Cd
g_Tmpv2 =Tmpv1*g_absU +g_Tmpv1*absU
Tmpv2 =Tmpv1*absU
g_Tmpv3 =Tmpv2*(g_defor13(i,kts+1,j) +g_defor13(i+1,kts+1,j)) &
+g_Tmpv2*(defor13(i,kts+1,j) +defor13(i+1,kts+1,j))
Tmpv3 =Tmpv2*(defor13(i,kts+1,j) +defor13(i+1,kts+1,j))
g_Tmpv4 =mu(i,j)*(g_Tmpv3*0.5) +g_mu(i,j)*(Tmpv3*0.5)
Tmpv4 =mu(i,j)*(Tmpv3*0.5)
g_tendency(i,k,j) =g_tendency(i,k,j) +g_Tmpv4
tendency(i,k,j) =tendency(i,k,j) +Tmpv4
ENDDO
ENDDO
CASE DEFAULT ! Added by Ning Pan, 2010-08-12
! Revised by Ning Pan, 2010-08-12
! CALL g_wrf_error_fatal('isfflx value invalid for diff_opt=2')
CALL wrf_error_fatal('isfflx value invalid for diff_opt=2')
END SELECT tl_uflux ! Added by Ning Pan, 2010-08-12
DO j =j_start,j_end+1
DO k =kts+1,ktf
DO i =i_start,i_end
g_tmp2(i,k,j) =g_defor23(i,k,j)
tmp2(i,k,j) =defor23(i,k,j)
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end+1
DO i =i_start,i_end
g_tmp2(i,kts,j) =0.0
tmp2(i,kts,j) =0.0
g_tmp2(i,ktf+1,j) =0.0
tmp2(i,ktf+1,j) =0.0
ENDDO
ENDDO
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_avg(i,k,j) =0.25*((2.0*g_tmp2(i,k+1,j)*tmp2(i,k+1,j)) +(2.0*g_tmp2(i,k,j) &
*tmp2(i,k,j)) +(2.0*g_tmp2(i,k+1,j+1)*tmp2(i,k+1,j+1)) +(2.0*g_tmp2(i,k,j+1) &
*tmp2(i,k,j+1)))
avg(i,k,j) =0.25*((tmp2(i,k+1,j)**2) +(tmp2(i,k,j)**2) +(tmp2(i,k+1,j+1)**2) &
+(tmp2(i,k,j+1)**2))
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_Tmpv1 =mu(i,j)*g_xkmv(i,k,j) +g_mu(i,j)*xkmv(i,k,j)
Tmpv1 =mu(i,j)*xkmv(i,k,j)
g_Tmpv2 =Tmpv1*g_avg(i,k,j) +g_Tmpv1*avg(i,k,j)
Tmpv2 =Tmpv1*avg(i,k,j)
g_tendency(i,k,j) =g_tendency(i,k,j) +g_Tmpv2
tendency(i,k,j) =tendency(i,k,j) +Tmpv2
ENDDO
ENDDO
ENDDO
K =KTS
! Added by Ning Pan, 2010-08-12
tl_vflux: SELECT CASE( config_flags%isfflx )
CASE (0)
! g_cd0 =g_config_flags%tke_drag_coefficient ! Remarked by Ning Pan, 2010-08-12
cd0 =config_flags%tke_drag_coefficient
DO j =j_start,j_end
DO i =i_start,i_end
g_absU =0.5*g_Sqrt(2.0*(g_u(i,k,j) +g_u(i+1,k,j))*(u(i,k,j) +u(i+1,k,j)) &
+2.0*(g_v(i,k,j) +g_v(i,k,j+1))*(v(i,k,j) +v(i,k,j+1)), (u(i,k,j) +u(i+1,k,j)) &
**2 +(v(i,k,j) +v(i,k,j+1))**2)
absU =0.5*sqrt((u(i,k,j) +u(i+1,k,j))**2 +(v(i,k,j) +v(i,k,j+1))**2)
! Revised by Ning Pan, 2010-08-12
! g_Cd =g_cd0
g_Cd =0.0
Cd =cd0
g_Tmpv1 =(v(i,k,j) +v(i,k,j+1))*0.5*g_Cd +(g_v(i,k,j) +g_v(i,k,j+1))*0.5*Cd
Tmpv1 =(v(i,k,j) +v(i,k,j+1))*0.5*Cd
g_Tmpv2 =Tmpv1*g_absU +g_Tmpv1*absU
Tmpv2 =Tmpv1*absU
g_Tmpv3 =Tmpv2*(g_defor23(i,kts+1,j) +g_defor23(i,kts+1,j+1)) &
+g_Tmpv2*(defor23(i,kts+1,j) +defor23(i,kts+1,j+1))
Tmpv3 =Tmpv2*(defor23(i,kts+1,j) +defor23(i,kts+1,j+1))
g_Tmpv4 =mu(i,j)*(g_Tmpv3*0.5) +g_mu(i,j)*(Tmpv3*0.5)
Tmpv4 =mu(i,j)*(Tmpv3*0.5)
g_tendency(i,k,j) =g_tendency(i,k,j) +g_Tmpv4
tendency(i,k,j) =tendency(i,k,j) +Tmpv4
ENDDO
ENDDO
CASE (1,2) ! Added by Ning Pan, 2010-08-12
DO j =j_start,j_end
DO i =i_start,i_end
g_absU =0.5*g_Sqrt(2.0*(g_u(i,k,j) +g_u(i+1,k,j))*(u(i,k,j) +u(i+1,k,j)) &
+2.0*(g_v(i,k,j) +g_v(i,k,j+1))*(v(i,k,j) +v(i,k,j+1)), (u(i,k,j) +u(i+1,k,j)) &
**2 +(v(i,k,j) +v(i,k,j+1))**2)
absU =0.5*sqrt((u(i,k,j) +u(i+1,k,j))**2 +(v(i,k,j) +v(i,k,j+1))**2) +epsilon
g_Tmpv1 =((2.0*g_ust(i,j)*ust(i,j))*(absU**2) -(2.0*g_absU*absU)*(ust(i,j) &
**2))/((absU**2)*(absU**2))
Tmpv1 =(ust(i,j)**2)/(absU**2)
g_Cd =g_Tmpv1
Cd =Tmpv1
g_Tmpv1 =(v(i,k,j) +v(i,k,j+1))*0.5*g_Cd +(g_v(i,k,j) +g_v(i,k,j+1))*0.5*Cd
Tmpv1 =(v(i,k,j) +v(i,k,j+1))*0.5*Cd
g_Tmpv2 =Tmpv1*g_absU +g_Tmpv1*absU
Tmpv2 =Tmpv1*absU
g_Tmpv3 =Tmpv2*(g_defor23(i,kts+1,j) +g_defor23(i,kts+1,j+1)) &
+g_Tmpv2*(defor23(i,kts+1,j) +defor23(i,kts+1,j+1))
Tmpv3 =Tmpv2*(defor23(i,kts+1,j) +defor23(i,kts+1,j+1))
g_Tmpv4 =mu(i,j)*(g_Tmpv3*0.5) +g_mu(i,j)*(Tmpv3*0.5)
Tmpv4 =mu(i,j)*(Tmpv3*0.5)
g_tendency(i,k,j) =g_tendency(i,k,j) +g_Tmpv4
tendency(i,k,j) =tendency(i,k,j) +Tmpv4
ENDDO
ENDDO
CASE DEFAULT ! Added by Ning Pan, 2010-08-12
! Revised by Ning Pan, 2010-08-12
! CALL g_wrf_error_fatal('isfflx value invalid for diff_opt=2')
CALL wrf_error_fatal( 'isfflx value invalid for diff_opt=2' )
END SELECT tl_vflux ! Added by Ning Pan, 2010-08-12
END SUBROUTINE g_tke_shear
! Generated by TAPENADE (INRIA, Tropics team)
! Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
!
! Differentiation of compute_diff_metrics in forward (tangent) mode:
! variations of useful results: zx zy z rdzw rdz
! with respect to varying inputs: zx zy z rdzw rdz ph
! RW status of diff variables: zx:in-out zy:in-out z:in-out rdzw:in-out
! rdz:in-out ph:in
SUBROUTINE G_COMPUTE_DIFF_METRICS(config_flags, ph, phd, phb, z, zd, rdz&
& , rdzd, rdzw, rdzwd, zx, zxd, zy, zyd, rdx, rdy, ids, ide, jds, jde, &
& kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte)
IMPLICIT NONE
TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
& jme, kms, kme, its, ite, jts, jte, kts, kte
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: ph, phb
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: phd
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(OUT) :: rdz, rdzw, &
& zx, zy, z
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(OUT) :: rdzd, rdzwd&
& , zxd, zyd, zd
REAL, INTENT(IN) :: rdx, rdy
! Local variables.
REAL, DIMENSION(its - 1:ite, kts:kte, jts - 1:jte) :: z_at_w
REAL, DIMENSION(its-1:ite, kts:kte, jts-1:jte) :: z_at_wd
INTEGER :: i, j, k, i_start, i_end, j_start, j_end, ktf
INTEGER :: min1
INTEGER :: max4
INTEGER :: max3
INTEGER :: max2
INTEGER :: max1
IF (kte .GT. kde - 1) THEN
ktf = kde - 1
ELSE
ktf = kte
END IF
! Bug fix, WCS, 22 april 2002.
! We need rdzw in halo for average to u and v points.
j_start = jts - 1
j_end = jte
z_at_wd = 0.0
! Begin with dz computations.
DO j=j_start,j_end
IF (jte .GT. jde - 1) THEN
min1 = jde - 1
ELSE
min1 = jte
END IF
IF (j_start .GE. jts .AND. j_end .LE. min1) THEN
i_start = its - 1
i_end = ite
ELSE
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
END IF
! Compute z at w points for rdz and rdzw computations. We'll switch z
! to z at p points before returning
DO k=1,kte
! Bug fix, WCS, 22 april 2002
DO i=i_start,i_end
z_at_wd(i, k, j) = phd(i, k, j)/g
z_at_w(i, k, j) = (ph(i, k, j)+phb(i, k, j))/g
END DO
END DO
DO k=1,ktf
DO i=i_start,i_end
rdzwd(i, k, j) = -((z_at_wd(i, k+1, j)-z_at_wd(i, k, j))/(z_at_w&
& (i, k+1, j)-z_at_w(i, k, j))**2)
rdzw(i, k, j) = 1.0/(z_at_w(i, k+1, j)-z_at_w(i, k, j))
END DO
END DO
DO k=2,ktf
DO i=i_start,i_end
rdzd(i, k, j) = -(2.0*(z_at_wd(i, k+1, j)-z_at_wd(i, k-1, j))/(&
& z_at_w(i, k+1, j)-z_at_w(i, k-1, j))**2)
rdz(i, k, j) = 2.0/(z_at_w(i, k+1, j)-z_at_w(i, k-1, j))
END DO
END DO
! Bug fix, WCS, 22 april 2002; added the following code
DO i=i_start,i_end
rdzd(i, 1, j) = -(2.*(z_at_wd(i, 2, j)-z_at_wd(i, 1, j))/(z_at_w(i&
& , 2, j)-z_at_w(i, 1, j))**2)
rdz(i, 1, j) = 2./(z_at_w(i, 2, j)-z_at_w(i, 1, j))
END DO
END DO
! End bug fix.
! Now compute zx and zy; we'll assume that the halo for ph and phb is
! properly filled.
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
DO j=j_start,j_end
DO k=1,kte
IF (ids + 1 .LT. its) THEN
max1 = its
ELSE
max1 = ids + 1
END IF
DO i=max1,i_end
zxd(i, k, j) = 0.0
zx(i, k, j) = rdx*(phb(i, k, j)-phb(i-1, k, j))/g
END DO
END DO
END DO
DO j=j_start,j_end
DO k=1,kte
IF (ids + 1 .LT. its) THEN
max2 = its
ELSE
max2 = ids + 1
END IF
DO i=max2,i_end
zxd(i, k, j) = zxd(i, k, j) + rdx*(phd(i, k, j)-phd(i-1, k, j))/&
& g
zx(i, k, j) = zx(i, k, j) + rdx*(ph(i, k, j)-ph(i-1, k, j))/g
END DO
END DO
END DO
IF (jds + 1 .LT. jts) THEN
max3 = jts
ELSE
max3 = jds + 1
END IF
DO j=max3,j_end
DO k=1,kte
DO i=i_start,i_end
zyd(i, k, j) = 0.0
zy(i, k, j) = rdy*(phb(i, k, j)-phb(i, k, j-1))/g
END DO
END DO
END DO
IF (jds + 1 .LT. jts) THEN
max4 = jts
ELSE
max4 = jds + 1
END IF
DO j=max4,j_end
DO k=1,kte
DO i=i_start,i_end
zyd(i, k, j) = zyd(i, k, j) + rdy*(phd(i, k, j)-phd(i, k, j-1))/&
& g
zy(i, k, j) = zy(i, k, j) + rdy*(ph(i, k, j)-ph(i, k, j-1))/g
END DO
END DO
END DO
! Some b.c. on zx and zy.
IF (.NOT.config_flags%periodic_x) THEN
IF (ite .EQ. ide) THEN
DO j=j_start,j_end
DO k=1,ktf
zxd(ide, k, j) = 0.0
zx(ide, k, j) = 0.0
END DO
END DO
END IF
IF (its .EQ. ids) THEN
DO j=j_start,j_end
DO k=1,ktf
zxd(ids, k, j) = 0.0
zx(ids, k, j) = 0.0
END DO
END DO
END IF
ELSE
IF (ite .EQ. ide) THEN
DO j=j_start,j_end
DO k=1,ktf
zxd(ide, k, j) = 0.0
zx(ide, k, j) = rdx*(phb(ide, k, j)-phb(ide-1, k, j))/g
END DO
END DO
DO j=j_start,j_end
DO k=1,ktf
zxd(ide, k, j) = zxd(ide, k, j) + rdx*(phd(ide, k, j)-phd(ide-&
& 1, k, j))/g
zx(ide, k, j) = zx(ide, k, j) + rdx*(ph(ide, k, j)-ph(ide-1, k&
& , j))/g
END DO
END DO
END IF
IF (its .EQ. ids) THEN
DO j=j_start,j_end
DO k=1,ktf
zxd(ids, k, j) = 0.0
zx(ids, k, j) = rdx*(phb(ids, k, j)-phb(ids-1, k, j))/g
END DO
END DO
DO j=j_start,j_end
DO k=1,ktf
zxd(ids, k, j) = zxd(ids, k, j) + rdx*(phd(ids, k, j)-phd(ids-&
& 1, k, j))/g
zx(ids, k, j) = zx(ids, k, j) + rdx*(ph(ids, k, j)-ph(ids-1, k&
& , j))/g
END DO
END DO
END IF
END IF
IF (.NOT.config_flags%periodic_y) THEN
IF (jte .EQ. jde) THEN
DO k=1,ktf
DO i=i_start,i_end
zyd(i, k, jde) = 0.0
zy(i, k, jde) = 0.0
END DO
END DO
END IF
IF (jts .EQ. jds) THEN
DO k=1,ktf
DO i=i_start,i_end
zyd(i, k, jds) = 0.0
zy(i, k, jds) = 0.0
END DO
END DO
END IF
ELSE
IF (jte .EQ. jde) THEN
DO k=1,ktf
DO i =i_start, i_end
zyd(i, k, jde) = 0.0
zy(i, k, jde) = rdy*(phb(i, k, jde)-phb(i, k, jde-1))/g
END DO
END DO
DO k=1,ktf
DO i =i_start, i_end
zyd(i, k, jde) = zyd(i, k, jde) + rdy*(phd(i, k, jde)-phd(i, k&
& , jde-1))/g
zy(i, k, jde) = zy(i, k, jde) + rdy*(ph(i, k, jde)-ph(i, k, &
& jde-1))/g
END DO
END DO
END IF
IF (jts .EQ. jds) THEN
DO k=1,ktf
DO i =i_start, i_end
zyd(i, k, jds) = 0.0
zy(i, k, jds) = rdy*(phb(i, k, jds)-phb(i, k, jds-1))/g
END DO
END DO
DO k=1,ktf
DO i =i_start, i_end
zyd(i, k, jds) = zyd(i, k, jds) + rdy*(phd(i, k, jds)-phd(i, k&
& , jds-1))/g
zy(i, k, jds) = zy(i, k, jds) + rdy*(ph(i, k, jds)-ph(i, k, &
& jds-1))/g
END DO
END DO
END IF
END IF
! Calculate z at p points.
DO j=j_start,j_end
DO k=1,ktf
DO i=i_start,i_end
zd(i, k, j) = 0.5*(phd(i, k, j)+phd(i, k+1, j))/g
z(i, k, j) = 0.5*(ph(i, k, j)+phb(i, k, j)+ph(i, k+1, j)+phb(i, &
& k+1, j))/g
END DO
END DO
END DO
END SUBROUTINE G_COMPUTE_DIFF_METRICS
SUBROUTINE g_horizontal_diffusion_2(rt_tendf,g_rt_tendf,ru_tendf,g_ru_tendf, &
rv_tendf,g_rv_tendf,rw_tendf,g_rw_tendf,tke_tendf,g_tke_tendf,moist_tendf, &
g_moist_tendf,n_moist,chem_tendf,g_chem_tendf,n_chem,scalar_tendf, &
g_scalar_tendf,n_scalar,tracer_tendf,g_tracer_tendf,n_tracer,thp,g_thp, &
theta,g_theta,mu,g_mu,tke,g_tke,config_flags,defor11,g_defor11,defor22, &
g_defor22,defor12,g_defor12,defor13,g_defor13,defor23,g_defor23,nba_mij, &
g_nba_mij,n_nba_mij,div,g_div,moist,g_moist,chem,g_chem,scalar, &
g_scalar,tracer,g_tracer,msfux,msfuy,msfvx,msfvy,msftx,msfty,xkmh,g_xkmh, &
xkhh,g_xkhh,km_opt,rdx,rdy,rdz,g_rdz,rdzw,g_rdzw,fnm,fnp,cf1,cf2,cf3,zx, &
g_zx,zy,g_zy,dn,dnw,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite, &
jts,jte,kts,kte)
IMPLICIT NONE
REAL :: Tmpv1,g_Tmpv1
TYPE(grid_config_rec_type) :: config_flags
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
INTEGER :: n_moist,n_chem,n_scalar,n_tracer,km_opt
REAL :: cf1,cf2,cf3
REAL,DIMENSION(kms:kme) :: fnm
REAL,DIMENSION(kms:kme) :: fnp
REAL,DIMENSION(kms:kme) :: dnw
REAL,DIMENSION(kms:kme) :: dn
REAL,DIMENSION(ims:ime,jms:jme) :: msfux,msfuy,msfvx,msfvy,msftx,msfty,mu,g_mu
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: rt_tendf,g_rt_tendf,ru_tendf, &
g_ru_tendf,rv_tendf,g_rv_tendf,rw_tendf,g_rw_tendf,tke_tendf,g_tke_tendf
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_moist) :: moist_tendf,g_moist_tendf
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_chem) :: chem_tendf,g_chem_tendf
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_scalar) :: scalar_tendf,g_scalar_tendf
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_tracer) :: tracer_tendf,g_tracer_tendf
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_moist) :: moist,g_moist
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_chem) :: chem,g_chem
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_scalar) :: scalar,g_scalar
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_tracer) :: tracer,g_tracer
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor11,g_defor11,defor22,g_defor22, &
defor12,g_defor12,defor13,g_defor13,defor23,g_defor23,div,g_div,xkmh, &
g_xkmh,xkhh,g_xkhh,zx,g_zx,zy,g_zy,theta,g_theta,thp,g_thp,tke, &
g_tke,rdz,g_rdz,rdzw,g_rdzw
REAL :: rdx,rdy
INTEGER :: n_nba_mij
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_nba_mij) :: nba_mij,g_nba_mij
INTEGER :: im,ic,is
CALL g_horizontal_diffusion_u_2(ru_tendf,g_ru_tendf,mu,g_mu,config_flags, &
defor11,g_defor11,defor12,g_defor12,div,g_div,nba_mij,g_nba_mij, &
n_nba_mij,tke(ims,kms,jms),g_tke(ims,kms,jms),msfux,msfuy,xkmh,g_xkmh,rdx,rdy, &
fnm,fnp,zx,g_zx,zy,g_zy,rdzw,g_rdzw,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme, &
kms,kme,its,ite,jts,jte,kts,kte)
CALL g_horizontal_diffusion_v_2(rv_tendf,g_rv_tendf,mu,g_mu,config_flags, &
defor12,g_defor12,defor22,g_defor22,div,g_div,nba_mij,g_nba_mij, &
n_nba_mij,tke(ims,kms,jms),g_tke(ims,kms,jms),msfvx,msfvy,xkmh,g_xkmh,rdx,rdy, &
fnm,fnp,zx,g_zx,zy,g_zy,rdzw,g_rdzw,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme, &
kms,kme,its,ite,jts,jte,kts,kte)
CALL g_horizontal_diffusion_w_2(rw_tendf,g_rw_tendf,mu,g_mu,config_flags, &
defor13,g_defor13,defor23,g_defor23,div,g_div,nba_mij,g_nba_mij, &
n_nba_mij,tke(ims,kms,jms),g_tke(ims,kms,jms),msftx,msfty,xkmh,g_xkmh,rdx,rdy, &
fnm,fnp,zx,g_zx,zy,g_zy,rdz,g_rdz,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme, &
kms,kme,its,ite,jts,jte,kts,kte)
CALL g_horizontal_diffusion_s(rt_tendf,g_rt_tendf,mu,g_mu,config_flags,thp, &
g_thp,msftx,msfty,msfux,msfuy,msfvx,msfvy,xkhh,g_xkhh,rdx,rdy,fnm,fnp,cf1,cf2, &
cf3,zx,g_zx,zy,g_zy,rdz,g_rdz,rdzw,g_rdzw,dnw,dn,.false.,ids,ide,jds,jde, &
kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
IF(km_opt .eq. 2) CALL g_horizontal_diffusion_s(tke_tendf(ims,kms,jms) &
,g_tke_tendf(ims,kms,jms),mu,g_mu,config_flags,tke(ims,kms,jms),g_tke(ims, &
kms,jms),msftx,msfty,msfux,msfuy,msfvx,msfvy,xkhh,g_xkhh,rdx,rdy,fnm,fnp,cf1,cf2, &
cf3,zx,g_zx,zy,g_zy,rdz,g_rdz,rdzw,g_rdzw,dnw,dn,.true.,ids,ide,jds,jde, &
kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
IF(n_moist .ge. PARAM_FIRST_SCALAR) THEN
DO im =PARAM_FIRST_SCALAR,n_moist
CALL g_horizontal_diffusion_s(moist_tendf(ims,kms,jms,im),g_moist_tendf(ims, &
kms,jms,im),mu,g_mu,config_flags,moist(ims,kms,jms,im),g_moist(ims,kms,jms,im) &
,msftx,msfty,msfux,msfuy,msfvx,msfvy,xkhh,g_xkhh,rdx,rdy,fnm,fnp,cf1,cf2,cf3,zx, &
g_zx,zy,g_zy,rdz,g_rdz,rdzw,g_rdzw,dnw,dn,.false.,ids,ide,jds,jde,kds, &
kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
ENDDO
ENDIF
IF(n_chem .ge. PARAM_FIRST_SCALAR) THEN
DO ic =PARAM_FIRST_SCALAR,n_chem
CALL g_horizontal_diffusion_s(chem_tendf(ims,kms,jms,ic),g_chem_tendf(ims,kms, &
jms,ic),mu,g_mu,config_flags,chem(ims,kms,jms,ic),g_chem(ims,kms,jms,ic) &
,msftx,msfty,msfux,msfuy,msfvx,msfvy,xkhh,g_xkhh,rdx,rdy,fnm,fnp,cf1,cf2,cf3,zx, &
g_zx,zy,g_zy,rdz,g_rdz,rdzw,g_rdzw,dnw,dn,.false.,ids,ide,jds,jde,kds, &
kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
ENDDO
ENDIF
IF(n_tracer .ge. PARAM_FIRST_SCALAR) THEN
DO ic =PARAM_FIRST_SCALAR,n_tracer
CALL g_horizontal_diffusion_s(tracer_tendf(ims,kms,jms,ic),g_tracer_tendf(ims, &
kms,jms,ic),mu,g_mu,config_flags,tracer(ims,kms,jms,ic),g_tracer(ims,kms,jms, &
ic),msftx,msfty,msfux,msfuy,msfvx,msfvy,xkhh,g_xkhh,rdx,rdy,fnm,fnp,cf1,cf2,cf3, &
zx,g_zx,zy,g_zy,rdz,g_rdz,rdzw,g_rdzw,dnw,dn,.false.,ids,ide,jds,jde,kds, &
kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
ENDDO
ENDIF
IF(n_scalar .ge. PARAM_FIRST_SCALAR) THEN
DO is =PARAM_FIRST_SCALAR,n_scalar
CALL g_horizontal_diffusion_s(scalar_tendf(ims,kms,jms,is),g_scalar_tendf(ims, &
kms,jms,is),mu,g_mu,config_flags,scalar(ims,kms,jms,is),g_scalar(ims,kms,jms, &
is),msftx,msfty,msfux,msfuy,msfvx,msfvy,xkhh,g_xkhh,rdx,rdy,fnm,fnp,cf1,cf2,cf3, &
zx,g_zx,zy,g_zy,rdz,g_rdz,rdzw,g_rdzw,dnw,dn,.false.,ids,ide,jds,jde,kds, &
kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
ENDDO
ENDIF
END SUBROUTINE g_horizontal_diffusion_2
SUBROUTINE g_horizontal_diffusion_u_2(tendency,g_tendency,mu,g_mu, &
config_flags,defor11,g_defor11,defor12,g_defor12,div,g_div,nba_mij, &
g_nba_mij,n_nba_mij,tke,g_tke,msfux,msfuy,xkmh,g_xkmh,rdx,rdy,fnm,fnp,zx, &
g_zx,zy,g_zy,rdzw,g_rdzw,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme, &
its,ite,jts,jte,kts,kte)
IMPLICIT NONE
REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2,Tmpv3,g_Tmpv3,Tmpv4,g_Tmpv4
TYPE(grid_config_rec_type) :: config_flags
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
REAL,DIMENSION(kms:kme) :: fnm
REAL,DIMENSION(kms:kme) :: fnp
REAL,DIMENSION(ims:ime,jms:jme) :: msfux,msfuy,mu,g_mu
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,g_tendency
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: rdzw,g_rdzw
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor11,g_defor11,defor12,g_defor12, &
div,g_div,tke,g_tke,xkmh,g_xkmh,zx,g_zx,zy,g_zy
INTEGER :: n_nba_mij
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_nba_mij) :: nba_mij,g_nba_mij
REAL :: rdx,rdy
INTEGER :: i,j,k,ktf
INTEGER :: i_start,i_end,j_start,j_end
INTEGER :: is_ext,ie_ext,js_ext,je_ext
REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: titau1avg,g_titau1avg, &
titau2avg,g_titau2avg,titau1,g_titau1,titau2,g_titau2,xkxavg,g_xkxavg, &
rravg,g_rravg
REAL :: mrdx,g_mrdx,mrdy,g_mrdy,rcoup,g_rcoup
REAL :: tmpzy,g_tmpzy,tmpzeta_z,g_tmpzeta_z
REAL :: term1,g_term1,term2,g_term2,term3,g_term3
ktf =min(kte,kde-1)
i_start =its
i_end =ite
j_start =jts
j_end =min(jte,jde-1)
IF( config_flags%open_xs .or. config_flags%specified .or. &
config_flags%nested) i_start =max(ids+1,its)
IF( config_flags%open_xe .or. config_flags%specified .or. &
config_flags%nested) i_end =min(ide-1,ite)
IF( config_flags%open_ys .or. config_flags%specified .or. &
config_flags%nested) j_start =max(jds+1,jts)
IF( config_flags%open_ye .or. config_flags%specified .or. &
config_flags%nested) j_end =min(jde-2,jte)
IF( config_flags%periodic_x ) i_start =its
IF( config_flags%periodic_x ) i_end =ite
is_ext =1
ie_ext =0
js_ext =0
je_ext =0
CALL g_cal_titau_11_22_33(config_flags,titau1,g_titau1,mu,g_mu,tke,g_tke, &
xkmh,g_xkmh,defor11,g_defor11,nba_mij(ims,kms,jms,P_m11),g_nba_mij(ims,kms, &
jms,P_m11),is_ext,ie_ext,js_ext,je_ext,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms, &
kme,its,ite,jts,jte,kts,kte)
is_ext =0
ie_ext =0
js_ext =0
je_ext =1
CALL g_cal_titau_12_21(config_flags,titau2,g_titau2,mu,g_mu,xkmh,g_xkmh, &
defor12,g_defor12,nba_mij(ims,kms,jms,P_m12),g_nba_mij(ims,kms,jms,P_m12) &
,is_ext,ie_ext,js_ext,je_ext,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite, &
jts,jte,kts,kte)
DO j =j_start,j_end
DO k =kts+1,ktf
DO i =i_start,i_end
g_titau1avg(i,k,j) =0.5*(fnm(k)*(g_titau1(i-1,k,j) +g_titau1(i,k,j)) +fnp(k) &
*(g_titau1(i-1,k-1,j) +g_titau1(i,k-1,j)))
titau1avg(i,k,j) =0.5*(fnm(k)*(titau1(i-1,k,j) +titau1(i,k,j)) +fnp(k)*(titau1(i-1,k- &
1,j) +titau1(i,k-1,j)))
g_titau2avg(i,k,j) =0.5*(fnm(k)*(g_titau2(i,k,j+1) +g_titau2(i,k,j)) +fnp(k) &
*(g_titau2(i,k-1,j+1) +g_titau2(i,k-1,j)))
titau2avg(i,k,j) =0.5*(fnm(k)*(titau2(i,k,j+1) +titau2(i,k,j)) +fnp(k)*(titau2(i,k-1, &
j+1) +titau2(i,k-1,j)))
g_tmpzy =0.25*(g_zy(i-1,k,j) +g_zy(i,k,j) +g_zy(i-1,k,j+1) +g_zy(i,k,j+1))
tmpzy =0.25*(zy(i-1,k,j) +zy(i,k,j) +zy(i-1,k,j+1) +zy(i,k,j+1))
g_Tmpv1 =titau1avg(i,k,j)*g_zx(i,k,j) +g_titau1avg(i,k,j)*zx(i,k,j)
Tmpv1 =titau1avg(i,k,j)*zx(i,k,j)
g_titau1avg(i,k,j) =g_Tmpv1
titau1avg(i,k,j) =Tmpv1
g_Tmpv1 =titau2avg(i,k,j)*g_tmpzy +g_titau2avg(i,k,j)*tmpzy
Tmpv1 =titau2avg(i,k,j)*tmpzy
g_titau2avg(i,k,j) =g_Tmpv1
titau2avg(i,k,j) =Tmpv1
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO i =i_start,i_end
g_titau1avg(i,kts,j) =0.0
titau1avg(i,kts,j) =0.
g_titau1avg(i,ktf+1,j) =0.0
titau1avg(i,ktf+1,j) =0.
g_titau2avg(i,kts,j) =0.0
titau2avg(i,kts,j) =0.
g_titau2avg(i,ktf+1,j) =0.0
titau2avg(i,ktf+1,j) =0.
ENDDO
ENDDO
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
! g_mrdx =0.0 ! Remarked by Ning Pan, 2010-08-10
mrdx =msfux(i,j) *rdx
! g_mrdy =0.0 ! Remarked by Ning Pan, 2010-08-10
mrdy =msfuy(i,j) *rdy
! Revised by Ning Pan, 2010-08-10
! g_Tmpv1 =mrdx*(g_titau1(i,k,j) -g_titau1(i-1,k,j)) +g_mrdx*(titau1(i,k, &
! j) -titau1(i-1,k,j))
g_Tmpv1 =mrdx*(g_titau1(i,k,j) -g_titau1(i-1,k,j))
Tmpv1 =mrdx*(titau1(i,k,j) -titau1(i-1,k,j))
! Revised by Ning Pan, 2010-08-10
! g_Tmpv2 =mrdy*(g_titau2(i,k,j+1) -g_titau2(i,k,j)) +g_mrdy*(titau2(i,k, &
! j+1) -titau2(i,k,j))
g_Tmpv2 =mrdy*(g_titau2(i,k,j+1) -g_titau2(i,k,j))
Tmpv2 =mrdy*(titau2(i,k,j+1) -titau2(i,k,j))
g_Tmpv3 =msfuy(i,j)*rdzw(i,k,j)*((g_titau1avg(i,k+1,j) -g_titau1avg(i,k,j)) &
+(g_titau2avg(i,k+1,j) -g_titau2avg(i,k,j))) +msfuy(i,j)*g_rdzw(i,k,j) &
*((titau1avg(i,k+1,j) -titau1avg(i,k,j)) +(titau2avg(i,k+1,j) -titau2avg(i,k,j)))
Tmpv3 =msfuy(i,j)*rdzw(i,k,j)*((titau1avg(i,k+1,j) -titau1avg(i,k,j)) +(titau2avg(i, &
k+1,j) -titau2avg(i,k,j)))
g_tendency(i,k,j) =g_tendency(i,k,j) -(g_Tmpv1 +g_Tmpv2 -g_Tmpv3)
tendency(i,k,j) =tendency(i,k,j) -(Tmpv1 +Tmpv2 -Tmpv3)
ENDDO
ENDDO
ENDDO
END SUBROUTINE g_horizontal_diffusion_u_2
SUBROUTINE g_horizontal_diffusion_v_2(tendency,g_tendency,mu,g_mu, &
config_flags,defor12,g_defor12,defor22,g_defor22,div,g_div,nba_mij, &
g_nba_mij,n_nba_mij,tke,g_tke,msfvx,msfvy,xkmh,g_xkmh,rdx,rdy,fnm,fnp,zx, &
g_zx,zy,g_zy,rdzw,g_rdzw,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme, &
its,ite,jts,jte,kts,kte)
IMPLICIT NONE
REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2,Tmpv3,g_Tmpv3,Tmpv4,g_Tmpv4
TYPE(grid_config_rec_type) :: config_flags
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
REAL,DIMENSION(kms:kme) :: fnm
REAL,DIMENSION(kms:kme) :: fnp
REAL,DIMENSION(ims:ime,jms:jme) :: msfvx,msfvy,mu,g_mu
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,g_tendency
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor12,g_defor12,defor22,g_defor22, &
div,g_div,tke,g_tke,xkmh,g_xkmh,zx,g_zx,zy,g_zy,rdzw,g_rdzw
INTEGER :: n_nba_mij
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_nba_mij) :: nba_mij,g_nba_mij
REAL :: rdx,rdy
INTEGER :: i,j,k,ktf
INTEGER :: i_start,i_end,j_start,j_end
INTEGER :: is_ext,ie_ext,js_ext,je_ext
REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: titau1avg,g_titau1avg, &
titau2avg,g_titau2avg,titau1,g_titau1,titau2,g_titau2,xkxavg,g_xkxavg, &
rravg,g_rravg
REAL :: mrdx,g_mrdx,mrdy,g_mrdy,rcoup,g_rcoup
REAL :: tmpzx,g_tmpzx,tmpzeta_z,g_tmpzeta_z
ktf =min(kte,kde-1)
i_start =its
i_end =min(ite,ide-1)
j_start =jts
j_end =jte
IF( config_flags%open_xs .or. config_flags%specified .or. &
config_flags%nested) i_start =max(ids+1,its)
IF( config_flags%open_xe .or. config_flags%specified .or. &
config_flags%nested) i_end =min(ide-2,ite)
IF( config_flags%open_ys .or. config_flags%specified .or. &
config_flags%nested) j_start =max(jds+1,jts)
IF( config_flags%open_ye .or. config_flags%specified .or. &
config_flags%nested) j_end =min(jde-1,jte)
IF( config_flags%periodic_x ) i_start =its
IF( config_flags%periodic_x ) i_end =min(ite,ide-1)
is_ext =0
ie_ext =1
js_ext =0
je_ext =0
CALL g_cal_titau_12_21(config_flags,titau1,g_titau1,mu,g_mu,xkmh,g_xkmh, &
defor12,g_defor12,nba_mij(ims,kms,jms,P_m12),g_nba_mij(ims,kms,jms,P_m12) &
,is_ext,ie_ext,js_ext,je_ext,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite, &
jts,jte,kts,kte)
is_ext =0
ie_ext =0
js_ext =1
je_ext =0
CALL g_cal_titau_11_22_33(config_flags,titau2,g_titau2,mu,g_mu,tke,g_tke, &
xkmh,g_xkmh,defor22,g_defor22,nba_mij(ims,kms,jms,P_m22),g_nba_mij(ims,kms, &
jms,P_m22),is_ext,ie_ext,js_ext,je_ext,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms, &
kme,its,ite,jts,jte,kts,kte)
DO j =j_start,j_end
DO k =kts+1,ktf
DO i =i_start,i_end
g_titau1avg(i,k,j) =0.5*(fnm(k)*(g_titau1(i+1,k,j) +g_titau1(i,k,j)) +fnp(k) &
*(g_titau1(i+1,k-1,j) +g_titau1(i,k-1,j)))
titau1avg(i,k,j) =0.5*(fnm(k)*(titau1(i+1,k,j) +titau1(i,k,j)) +fnp(k)*(titau1(i+1,k- &
1,j) +titau1(i,k-1,j)))
g_titau2avg(i,k,j) =0.5*(fnm(k)*(g_titau2(i,k,j-1) +g_titau2(i,k,j)) +fnp(k) &
*(g_titau2(i,k-1,j-1) +g_titau2(i,k-1,j)))
titau2avg(i,k,j) =0.5*(fnm(k)*(titau2(i,k,j-1) +titau2(i,k,j)) +fnp(k)*(titau2(i,k-1, &
j-1) +titau2(i,k-1,j)))
g_tmpzx =0.25*(g_zx(i,k,j) +g_zx(i+1,k,j) +g_zx(i,k,j-1) +g_zx(i+1,k,j-1))
tmpzx =0.25*(zx(i,k,j) +zx(i+1,k,j) +zx(i,k,j-1) +zx(i+1,k,j-1))
g_Tmpv1 =titau1avg(i,k,j)*g_tmpzx +g_titau1avg(i,k,j)*tmpzx
Tmpv1 =titau1avg(i,k,j)*tmpzx
g_titau1avg(i,k,j) =g_Tmpv1
titau1avg(i,k,j) =Tmpv1
g_Tmpv1 =titau2avg(i,k,j)*g_zy(i,k,j) +g_titau2avg(i,k,j)*zy(i,k,j)
Tmpv1 =titau2avg(i,k,j)*zy(i,k,j)
g_titau2avg(i,k,j) =g_Tmpv1
titau2avg(i,k,j) =Tmpv1
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO i =i_start,i_end
g_titau1avg(i,kts,j) =0.0
titau1avg(i,kts,j) =0.
g_titau1avg(i,ktf+1,j) =0.0
titau1avg(i,ktf+1,j) =0.
g_titau2avg(i,kts,j) =0.0
titau2avg(i,kts,j) =0.
g_titau2avg(i,ktf+1,j) =0.0
titau2avg(i,ktf+1,j) =0.
ENDDO
ENDDO
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
! g_mrdx =0.0 ! Remarked by Ning Pan, 2010-08-10
mrdx =msfvx(i,j) *rdx
! g_mrdy =0.0 ! Remarked by Ning Pan, 2010-08-10
mrdy =msfvy(i,j) *rdy
! Revised by Ning Pan, 2010-08-10
! g_Tmpv1 =mrdy*(g_titau2(i,k,j) -g_titau2(i,k,j-1)) +g_mrdy*(titau2(i,k, &
! j) -titau2(i,k,j-1))
g_Tmpv1 =mrdy*(g_titau2(i,k,j) -g_titau2(i,k,j-1))
Tmpv1 =mrdy*(titau2(i,k,j) -titau2(i,k,j-1))
! Revised by Ning Pan, 2010-08-10
! g_Tmpv2 =mrdx*(g_titau1(i+1,k,j) -g_titau1(i,k,j)) +g_mrdx*(titau1(i+1, &
! k,j) -titau1(i,k,j))
g_Tmpv2 =mrdx*(g_titau1(i+1,k,j) -g_titau1(i,k,j))
Tmpv2 =mrdx*(titau1(i+1,k,j) -titau1(i,k,j))
g_Tmpv3 =msfvy(i,j)*rdzw(i,k,j)*((g_titau1avg(i,k+1,j) -g_titau1avg(i,k,j)) &
+(g_titau2avg(i,k+1,j) -g_titau2avg(i,k,j))) +msfvy(i,j)*g_rdzw(i,k,j) &
*((titau1avg(i,k+1,j) -titau1avg(i,k,j)) +(titau2avg(i,k+1,j) -titau2avg(i,k,j)))
Tmpv3 =msfvy(i,j)*rdzw(i,k,j)*((titau1avg(i,k+1,j) -titau1avg(i,k,j)) +(titau2avg(i, &
k+1,j) -titau2avg(i,k,j)))
g_tendency(i,k,j) =g_tendency(i,k,j) -(g_Tmpv1 +g_Tmpv2 -g_Tmpv3)
tendency(i,k,j) =tendency(i,k,j) -(Tmpv1 +Tmpv2 -Tmpv3)
ENDDO
ENDDO
ENDDO
END SUBROUTINE g_horizontal_diffusion_v_2
SUBROUTINE g_horizontal_diffusion_w_2(tendency,g_tendency,mu,g_mu, &
config_flags,defor13,g_defor13,defor23,g_defor23,div,g_div,nba_mij, &
g_nba_mij,n_nba_mij,tke,g_tke,msftx,msfty,xkmh,g_xkmh,rdx,rdy,fnm,fnp,zx, &
g_zx,zy,g_zy,rdz,g_rdz,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its, &
ite,jts,jte,kts,kte)
IMPLICIT NONE
REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2,Tmpv3,g_Tmpv3,Tmpv4,g_Tmpv4
TYPE(grid_config_rec_type) :: config_flags
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
REAL,DIMENSION(kms:kme) :: fnm
REAL,DIMENSION(kms:kme) :: fnp
REAL,DIMENSION(ims:ime,jms:jme) :: msftx,msfty,mu,g_mu
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,g_tendency
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor13,g_defor13,defor23,g_defor23, &
div,g_div,tke,g_tke,xkmh,g_xkmh,zx,g_zx,zy,g_zy,rdz,g_rdz
INTEGER :: n_nba_mij
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_nba_mij) :: nba_mij,g_nba_mij
REAL :: rdx,rdy
INTEGER :: i,j,k,ktf
INTEGER :: i_start,i_end,j_start,j_end
INTEGER :: is_ext,ie_ext,js_ext,je_ext
REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: titau1avg,g_titau1avg, &
titau2avg,g_titau2avg,titau1,g_titau1,titau2,g_titau2,xkxavg,g_xkxavg, &
rravg,g_rravg
REAL :: mrdx,g_mrdx,mrdy,g_mrdy,rcoup,g_rcoup
REAL :: tmpzx,g_tmpzx,tmpzy,g_tmpzy,tmpzeta_z,g_tmpzeta_z
ktf =min(kte,kde-1)
i_start =its
i_end =min(ite,ide-1)
j_start =jts
j_end =min(jte,jde-1)
IF( config_flags%open_xs .or. config_flags%specified .or. &
config_flags%nested) i_start =max(ids+1,its)
IF( config_flags%open_xe .or. config_flags%specified .or. &
config_flags%nested) i_end =min(ide-2,ite)
IF( config_flags%open_ys .or. config_flags%specified .or. &
config_flags%nested) j_start =max(jds+1,jts)
IF( config_flags%open_ye .or. config_flags%specified .or. &
config_flags%nested) j_end =min(jde-2,jte)
IF( config_flags%periodic_x ) i_start =its
IF( config_flags%periodic_x ) i_end =min(ite,ide-1)
is_ext =0
ie_ext =1
js_ext =0
je_ext =0
CALL g_cal_titau_13_31(config_flags,titau1,g_titau1,defor13,g_defor13, &
nba_mij(ims,kms,jms,P_m13),g_nba_mij(ims,kms,jms,P_m13),mu,g_mu,xkmh,g_xkmh, &
fnm,fnp,is_ext,ie_ext,js_ext,je_ext,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme, &
its,ite,jts,jte,kts,kte)
is_ext =0
ie_ext =0
js_ext =0
je_ext =1
CALL g_cal_titau_23_32(config_flags,titau2,g_titau2,defor23,g_defor23, &
nba_mij(ims,kms,jms,P_m23),g_nba_mij(ims,kms,jms,P_m23),mu,g_mu,xkmh,g_xkmh, &
fnm,fnp,is_ext,ie_ext,js_ext,je_ext,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme, &
its,ite,jts,jte,kts,kte)
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_titau1avg(i,k,j) =0.25*(g_titau1(i+1,k+1,j) +g_titau1(i,k+1,j) &
+g_titau1(i+1,k,j) +g_titau1(i,k,j))
titau1avg(i,k,j) =0.25*(titau1(i+1,k+1,j) +titau1(i,k+1,j) +titau1(i+1,k,j) +titau1(i,k,j))
g_titau2avg(i,k,j) =0.25*(g_titau2(i,k+1,j+1) +g_titau2(i,k+1,j) &
+g_titau2(i,k,j+1) +g_titau2(i,k,j))
titau2avg(i,k,j) =0.25*(titau2(i,k+1,j+1) +titau2(i,k+1,j) +titau2(i,k,j+1) +titau2(i,k,j))
g_tmpzx =0.25*(g_zx(i,k,j) +g_zx(i+1,k,j) +g_zx(i,k+1,j) +g_zx(i+1,k+1,j))
tmpzx =0.25*(zx(i,k,j) +zx(i+1,k,j) +zx(i,k+1,j) +zx(i+1,k+1,j))
g_tmpzy =0.25*(g_zy(i,k,j) +g_zy(i,k,j+1) +g_zy(i,k+1,j) +g_zy(i,k+1,j+1))
tmpzy =0.25*(zy(i,k,j) +zy(i,k,j+1) +zy(i,k+1,j) +zy(i,k+1,j+1))
g_Tmpv1 =titau1avg(i,k,j)*g_tmpzx +g_titau1avg(i,k,j)*tmpzx
Tmpv1 =titau1avg(i,k,j)*tmpzx
g_titau1avg(i,k,j) =g_Tmpv1
titau1avg(i,k,j) =Tmpv1
g_Tmpv1 =titau2avg(i,k,j)*g_tmpzy +g_titau2avg(i,k,j)*tmpzy
Tmpv1 =titau2avg(i,k,j)*tmpzy
g_titau2avg(i,k,j) =g_Tmpv1
titau2avg(i,k,j) =Tmpv1
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO i =i_start,i_end
g_titau1avg(i,ktf+1,j) =0.0
titau1avg(i,ktf+1,j) =0.
g_titau2avg(i,ktf+1,j) =0.0
titau2avg(i,ktf+1,j) =0.
ENDDO
ENDDO
DO j =j_start,j_end
DO k =kts+1,ktf
DO i =i_start,i_end
! g_mrdx =0.0 ! Remarked by Ning Pan, 2010-08-10
mrdx =msftx(i,j) *rdx
! g_mrdy =0.0 ! Remarked by Ning Pan, 2010-08-10
mrdy =msfty(i,j) *rdy
! Revised by Ning Pan, 2010-08-10
! g_Tmpv1 =mrdx*(g_titau1(i+1,k,j) -g_titau1(i,k,j)) +g_mrdx*(titau1(i+1, &
! k,j) -titau1(i,k,j))
g_Tmpv1 =mrdx*(g_titau1(i+1,k,j) -g_titau1(i,k,j))
Tmpv1 =mrdx*(titau1(i+1,k,j) -titau1(i,k,j))
! Revised by Ning Pan, 2010-08-10
! g_Tmpv2 =mrdy*(g_titau2(i,k,j+1) -g_titau2(i,k,j)) +g_mrdy*(titau2(i,k, &
! j+1) -titau2(i,k,j))
g_Tmpv2 =mrdy*(g_titau2(i,k,j+1) -g_titau2(i,k,j))
Tmpv2 =mrdy*(titau2(i,k,j+1) -titau2(i,k,j))
g_Tmpv3 =msfty(i,j)*rdz(i,k,j)*(g_titau1avg(i,k,j) -g_titau1avg(i,k-1,j) &
+g_titau2avg(i,k,j) -g_titau2avg(i,k-1,j)) +msfty(i,j)*g_rdz(i,k,j) &
*(titau1avg(i,k,j) -titau1avg(i,k-1,j) +titau2avg(i,k,j) -titau2avg(i,k-1,j))
Tmpv3 =msfty(i,j)*rdz(i,k,j)*(titau1avg(i,k,j) -titau1avg(i,k-1,j) +titau2avg(i,k,j) &
-titau2avg(i,k-1,j))
g_tendency(i,k,j) =g_tendency(i,k,j) -(g_Tmpv1 +g_Tmpv2 -g_Tmpv3)
tendency(i,k,j) =tendency(i,k,j) -(Tmpv1 +Tmpv2 -Tmpv3)
ENDDO
ENDDO
ENDDO
END SUBROUTINE g_horizontal_diffusion_w_2
SUBROUTINE g_horizontal_diffusion_s(tendency,g_tendency,mu,g_mu, &
config_flags,var,g_var,msftx,msfty,msfux,msfuy,msfvx,msfvy,xkhh,g_xkhh,rdx,rdy, &
fnm,fnp,cf1,cf2,cf3,zx,g_zx,zy,g_zy,rdz,g_rdz,rdzw,g_rdzw,dnw,dn, &
doing_tke,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
IMPLICIT NONE
REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2,Tmpv3,g_Tmpv3,Tmpv4,g_Tmpv4,Tmpv5, &
g_Tmpv5,Tmpv6,g_Tmpv6,Tmpv7,g_Tmpv7,Tmpv8,g_Tmpv8,Tmpv9,g_Tmpv9
TYPE(grid_config_rec_type) :: config_flags
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
LOGICAL :: doing_tke
REAL :: cf1,cf2,cf3
REAL,DIMENSION(kms:kme) :: fnm
REAL,DIMENSION(kms:kme) :: fnp
REAL,DIMENSION(kms:kme) :: dn
REAL,DIMENSION(kms:kme) :: dnw
REAL,DIMENSION(ims:ime,jms:jme) :: msfux
REAL,DIMENSION(ims:ime,jms:jme) :: msfuy
REAL,DIMENSION(ims:ime,jms:jme) :: msfvx
REAL,DIMENSION(ims:ime,jms:jme) :: msfvy
REAL,DIMENSION(ims:ime,jms:jme) :: msftx
REAL,DIMENSION(ims:ime,jms:jme) :: msfty
REAL,DIMENSION(ims:ime,jms:jme) :: mu,g_mu
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,g_tendency
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: xkhh,g_xkhh,rdz,g_rdz,rdzw,g_rdzw
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: var,g_var,zx,g_zx,zy,g_zy
REAL :: rdx,rdy
INTEGER :: i,j,k,ktf
INTEGER :: i_start,i_end,j_start,j_end
REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: H1avg,g_H1avg,H2avg,g_H2avg, &
H1,g_H1,H2,g_H2,xkxavg,g_xkxavg
REAL,DIMENSION(its:ite,kts:kte,jts:jte) :: tmptendf,g_tmptendf
REAL :: mrdx,g_mrdx,mrdy,g_mrdy,rcoup,g_rcoup
REAL :: tmpzx,g_tmpzx,tmpzy,g_tmpzy,tmpzeta_z,g_tmpzeta_z,rdzu,g_rdzu, &
rdzv,g_rdzv
INTEGER :: ktes1,ktes2
ktf =min(kte,kde-1)
ktes1 =kte-1
ktes2 =kte-2
i_start =its
i_end =min(ite,ide-1)
j_start =jts
j_end =min(jte,jde-1)
IF( config_flags%open_xs .or. config_flags%specified .or. &
config_flags%nested) i_start =max(ids+1,its)
IF( config_flags%open_xe .or. config_flags%specified .or. &
config_flags%nested) i_end =min(ide-2,ite)
IF( config_flags%open_ys .or. config_flags%specified .or. &
config_flags%nested) j_start =max(jds+1,jts)
IF( config_flags%open_ye .or. config_flags%specified .or. &
config_flags%nested) j_end =min(jde-2,jte)
IF( config_flags%periodic_x ) i_start =its
IF( config_flags%periodic_x ) i_end =min(ite,ide-1)
IF( doing_tke ) THEN
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_tmptendf(i,k,j) =g_tendency(i,k,j)
tmptendf(i,k,j) =tendency(i,k,j)
ENDDO
ENDDO
ENDDO
ENDIF
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end+1
g_xkxavg(i,k,j) =0.5*(g_xkhh(i-1,k,j) +g_xkhh(i,k,j))
xkxavg(i,k,j) =0.5*(xkhh(i-1,k,j) +xkhh(i,k,j))
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO k =kts+1,ktf
DO i =i_start,i_end+1
g_H1avg(i,k,j) =0.5*(fnm(k)*(g_var(i-1,k,j) +g_var(i,k,j)) +fnp(k) &
*(g_var(i-1,k-1,j) +g_var(i,k-1,j)))
H1avg(i,k,j) =0.5*(fnm(k)*(var(i-1,k,j) +var(i,k,j)) +fnp(k)*(var(i-1,k-1,j) +var(i,k-1,j)))
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO i =i_start,i_end+1
g_H1avg(i,kts,j) =0.5*(cf1*g_var(i,1,j) +cf2*g_var(i,2,j) +cf3*g_var(i,3, &
j) +cf1*g_var(i-1,1,j) +cf2*g_var(i-1,2,j) +cf3*g_var(i-1,3,j))
H1avg(i,kts,j) =0.5*(cf1*var(i,1,j) +cf2*var(i,2,j) +cf3*var(i,3,j) +cf1*var(i-1,1,j) &
+cf2*var(i-1,2,j) +cf3*var(i-1,3,j))
g_H1avg(i,ktf+1,j) =0.5*(g_var(i,ktes1,j) +((g_var(i,ktes1,j) -g_var(i, &
ktes2,j))*0.5*dnw(ktes1)/dn(ktes1)) +g_var(i-1,ktes1,j) +((g_var(i-1,ktes1,j) &
-g_var(i-1,ktes2,j))*0.5*dnw(ktes1)/dn(ktes1)))
H1avg(i,ktf+1,j) =0.5*(var(i,ktes1,j) +(var(i,ktes1,j) -var(i,ktes2,j)) &
*0.5*dnw(ktes1)/dn(ktes1) +var(i-1,ktes1,j) +(var(i-1,ktes1,j) -var(i-1,ktes2,j)) &
*0.5*dnw(ktes1)/dn(ktes1))
ENDDO
ENDDO
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end+1
g_tmpzx =0.5*(g_zx(i,k,j) +g_zx(i,k+1,j))
tmpzx =0.5*(zx(i,k,j) +zx(i,k+1,j))
g_rdzu =-2.*(-1.*g_rdzw(i,k,j)/(rdzw(i,k,j)*rdzw(i,k,j)) +(-1.*g_rdzw(i-1,k, &
j)/(rdzw(i-1,k,j)*rdzw(i-1,k,j))))/((1./rdzw(i,k,j) +1./rdzw(i-1,k,j))*(1./rdzw(i,k, &
j) +1./rdzw(i-1,k,j)))
rdzu =2./(1./rdzw(i,k,j) +1./rdzw(i-1,k,j))
g_Tmpv1 =tmpzx*(g_H1avg(i,k+1,j) -g_H1avg(i,k,j)) +g_tmpzx*(H1avg(i,k+1, &
j) -H1avg(i,k,j))
Tmpv1 =tmpzx*(H1avg(i,k+1,j) -H1avg(i,k,j))
g_Tmpv2 =Tmpv1*g_rdzu +g_Tmpv1*rdzu
Tmpv2 =Tmpv1*rdzu
g_Tmpv3 =-msfuy(i,j)*xkxavg(i,k,j)*(rdx*(g_var(i,k,j) -g_var(i-1,k,j)) &
-g_Tmpv2) -msfuy(i,j)*g_xkxavg(i,k,j)*(rdx*(var(i,k,j) -var(i-1,k,j)) -Tmpv2)
Tmpv3 =-msfuy(i,j)*xkxavg(i,k,j)*(rdx*(var(i,k,j) -var(i-1,k,j)) -Tmpv2)
g_H1(i,k,j) =g_Tmpv3
H1(i,k,j) =Tmpv3
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end+1
DO k =kts,ktf
DO i =i_start,i_end
g_xkxavg(i,k,j) =0.5*(g_xkhh(i,k,j-1) +g_xkhh(i,k,j))
xkxavg(i,k,j) =0.5*(xkhh(i,k,j-1) +xkhh(i,k,j))
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end+1
DO k =kts+1,ktf
DO i =i_start,i_end
g_H2avg(i,k,j) =0.5*(fnm(k)*(g_var(i,k,j-1) +g_var(i,k,j)) +fnp(k) &
*(g_var(i,k-1,j-1) +g_var(i,k-1,j)))
H2avg(i,k,j) =0.5*(fnm(k)*(var(i,k,j-1) +var(i,k,j)) +fnp(k)*(var(i,k-1,j-1) +var(i,k-1,j)))
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end+1
DO i =i_start,i_end
g_H2avg(i,kts,j) =0.5*(cf1*g_var(i,1,j) +cf2*g_var(i,2,j) +cf3*g_var(i,3, &
j) +cf1*g_var(i,1,j-1) +cf2*g_var(i,2,j-1) +cf3*g_var(i,3,j-1))
H2avg(i,kts,j) =0.5*(cf1*var(i,1,j) +cf2*var(i,2,j) +cf3*var(i,3,j) +cf1*var(i,1,j-1) &
+cf2*var(i,2,j-1) +cf3*var(i,3,j-1))
g_H2avg(i,ktf+1,j) =0.5*(g_var(i,ktes1,j) +((g_var(i,ktes1,j) -g_var(i, &
ktes2,j))*0.5*dnw(ktes1)/dn(ktes1)) +g_var(i,ktes1,j-1) +((g_var(i,ktes1,j-1) &
-g_var(i,ktes2,j-1))*0.5*dnw(ktes1)/dn(ktes1)))
H2avg(i,ktf+1,j) =0.5*(var(i,ktes1,j) +(var(i,ktes1,j) -var(i,ktes2,j)) &
*0.5*dnw(ktes1)/dn(ktes1) +var(i,ktes1,j-1) +(var(i,ktes1,j-1) -var(i,ktes2,j-1)) &
*0.5*dnw(ktes1)/dn(ktes1))
ENDDO
ENDDO
DO j =j_start,j_end+1
DO k =kts,ktf
DO i =i_start,i_end
g_tmpzy =0.5*(g_zy(i,k,j) +g_zy(i,k+1,j))
tmpzy =0.5*(zy(i,k,j) +zy(i,k+1,j))
g_rdzv =-2.*(-1.*g_rdzw(i,k,j)/(rdzw(i,k,j)*rdzw(i,k,j)) +(-1.*g_rdzw(i,k,j- &
1)/(rdzw(i,k,j-1)*rdzw(i,k,j-1))))/((1./rdzw(i,k,j) +1./rdzw(i,k,j-1))*(1./rdzw(i,k, &
j) +1./rdzw(i,k,j-1)))
rdzv =2./(1./rdzw(i,k,j) +1./rdzw(i,k,j-1))
g_Tmpv1 =tmpzy*(g_H2avg(i,k+1,j) -g_H2avg(i,k,j)) +g_tmpzy*(H2avg(i,k+1, &
j) -H2avg(i,k,j))
Tmpv1 =tmpzy*(H2avg(i,k+1,j) -H2avg(i,k,j))
g_Tmpv2 =Tmpv1*g_rdzv +g_Tmpv1*rdzv
Tmpv2 =Tmpv1*rdzv
g_Tmpv3 =-msfvy(i,j)*xkxavg(i,k,j)*(rdy*(g_var(i,k,j) -g_var(i,k,j-1)) &
-g_Tmpv2) -msfvy(i,j)*g_xkxavg(i,k,j)*(rdy*(var(i,k,j) -var(i,k,j-1)) -Tmpv2)
Tmpv3 =-msfvy(i,j)*xkxavg(i,k,j)*(rdy*(var(i,k,j) -var(i,k,j-1)) -Tmpv2)
g_H2(i,k,j) =g_Tmpv3
H2(i,k,j) =Tmpv3
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO k =kts+1,ktf
DO i =i_start,i_end
g_H1avg(i,k,j) =0.5*(fnm(k)*(g_H1(i+1,k,j) +g_H1(i,k,j)) +fnp(k) &
*(g_H1(i+1,k-1,j) +g_H1(i,k-1,j)))
H1avg(i,k,j) =0.5*(fnm(k)*(H1(i+1,k,j) +H1(i,k,j)) +fnp(k)*(H1(i+1,k-1,j) +H1(i,k-1,j)))
g_H2avg(i,k,j) =0.5*(fnm(k)*(g_H2(i,k,j+1) +g_H2(i,k,j)) +fnp(k) &
*(g_H2(i,k-1,j+1) +g_H2(i,k-1,j)))
H2avg(i,k,j) =0.5*(fnm(k)*(H2(i,k,j+1) +H2(i,k,j)) +fnp(k)*(H2(i,k-1,j+1) +H2(i,k-1,j)))
g_tmpzx =0.5*(g_zx(i,k,j) +g_zx(i+1,k,j))
tmpzx =0.5*(zx(i,k,j) +zx(i+1,k,j))
g_tmpzy =0.5*(g_zy(i,k,j) +g_zy(i,k,j+1))
tmpzy =0.5*(zy(i,k,j) +zy(i,k,j+1))
g_Tmpv1 =H1avg(i,k,j)*g_tmpzx +g_H1avg(i,k,j)*tmpzx
Tmpv1 =H1avg(i,k,j)*tmpzx
g_H1avg(i,k,j) =g_Tmpv1
H1avg(i,k,j) =Tmpv1
g_Tmpv1 =H2avg(i,k,j)*g_tmpzy +g_H2avg(i,k,j)*tmpzy
Tmpv1 =H2avg(i,k,j)*tmpzy
g_H2avg(i,k,j) =g_Tmpv1
H2avg(i,k,j) =Tmpv1
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO i =i_start,i_end
g_H1avg(i,kts,j) =0.0
H1avg(i,kts,j) =0.
g_H1avg(i,ktf+1,j) =0.0
H1avg(i,ktf+1,j) =0.
g_H2avg(i,kts,j) =0.0
H2avg(i,kts,j) =0.
g_H2avg(i,ktf+1,j) =0.0
H2avg(i,ktf+1,j) =0.
ENDDO
ENDDO
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
! g_mrdx =0.0 ! Remarked by Ning Pan, 2010-08-10
mrdx =msftx(i,j) *rdx
! g_mrdy =0.0 ! Remarked by Ning Pan, 2010-08-10
mrdy =msfty(i,j) *rdy
g_Tmpv1 =(mu(i+1,j) +mu(i,j))*g_H1(i+1,k,j) +(g_mu(i+1,j) +g_mu(i,j))*H1(i+1,k,j)
Tmpv1 =(mu(i+1,j) +mu(i,j))*H1(i+1,k,j)
g_Tmpv2 =(mu(i-1,j) +mu(i,j))*g_H1(i,k,j) +(g_mu(i-1,j) +g_mu(i,j))*H1(i,k,j)
Tmpv2 =(mu(i-1,j) +mu(i,j))*H1(i,k,j)
! Revised by Ning Pan, 2010-08-10
! g_Tmpv3 =mrdx*0.5*(g_Tmpv1 -g_Tmpv2) +g_mrdx*0.5*(Tmpv1 -Tmpv2)
g_Tmpv3 =mrdx*0.5*(g_Tmpv1 -g_Tmpv2)
Tmpv3 =mrdx*0.5*(Tmpv1 -Tmpv2)
g_Tmpv4 =(mu(i,j+1) +mu(i,j))*g_H2(i,k,j+1) +(g_mu(i,j+1) +g_mu(i,j))*H2(i,k,j+1)
Tmpv4 =(mu(i,j+1) +mu(i,j))*H2(i,k,j+1)
g_Tmpv5 =(mu(i,j-1) +mu(i,j))*g_H2(i,k,j) +(g_mu(i,j-1) +g_mu(i,j))*H2(i,k,j)
Tmpv5 =(mu(i,j-1) +mu(i,j))*H2(i,k,j)
! Revised by Ning Pan, 2010-08-10
! g_Tmpv6 =mrdy*0.5*(g_Tmpv4 -g_Tmpv5) +g_mrdy*0.5*(Tmpv4 -Tmpv5)
g_Tmpv6 =mrdy*0.5*(g_Tmpv4 -g_Tmpv5)
Tmpv6 =mrdy*0.5*(Tmpv4 -Tmpv5)
g_Tmpv7 =msfty(i,j)*mu(i,j)*(g_H1avg(i,k+1,j) -g_H1avg(i,k,j) &
+g_H2avg(i,k+1,j) -g_H2avg(i,k,j)) +msfty(i,j)*g_mu(i,j)*(H1avg(i,k+1,j) &
-H1avg(i,k,j) +H2avg(i,k+1,j) -H2avg(i,k,j))
Tmpv7 =msfty(i,j)*mu(i,j)*(H1avg(i,k+1,j) -H1avg(i,k,j) +H2avg(i,k+1,j) -H2avg(i,k,j))
g_Tmpv8 =Tmpv7*g_rdzw(i,k,j) +g_Tmpv7*rdzw(i,k,j)
Tmpv8 =Tmpv7*rdzw(i,k,j)
g_tendency(i,k,j) =g_tendency(i,k,j) -(g_Tmpv3 +g_Tmpv6 -g_Tmpv8)
tendency(i,k,j) =tendency(i,k,j) -(Tmpv3 +Tmpv6 -Tmpv8)
ENDDO
ENDDO
ENDDO
IF( doing_tke ) THEN
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_tendency(i,k,j) =g_tmptendf(i,k,j) +2.*(g_tendency(i,k,j) -g_tmptendf(i,k,j))
tendency(i,k,j) =tmptendf(i,k,j) +2.*(tendency(i,k,j) -tmptendf(i,k,j))
ENDDO
ENDDO
ENDDO
ENDIF
END SUBROUTINE g_horizontal_diffusion_s
SUBROUTINE g_vertical_diffusion_2(ru_tendf,g_ru_tendf,rv_tendf,g_rv_tendf, &
rw_tendf,g_rw_tendf,rt_tendf,g_rt_tendf,tke_tendf,g_tke_tendf,moist_tendf, &
g_moist_tendf,n_moist,chem_tendf,g_chem_tendf,n_chem,scalar_tendf, &
g_scalar_tendf,n_scalar,tracer_tendf,g_tracer_tendf,n_tracer,u_2,g_u_2,v_2, &
g_v_2,thp,g_thp,u_base,v_base,t_base,qv_base,mu,g_mu,tke,g_tke, &
config_flags,defor13,g_defor13,defor23,g_defor23,defor33,g_defor33,nba_mij, &
g_nba_mij,n_nba_mij,div,g_div,moist,g_moist,chem,g_chem,scalar, &
g_scalar,tracer,g_tracer,xkmv,g_xkmv,xkhv,g_xkhv,km_opt,fnm,fnp,dn,dnw, &
rdz,g_rdz,rdzw,g_rdzw,hfx,g_hfx,qfx,g_qfx,ust,g_ust,rho,g_rho,ids, &
ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
IMPLICIT NONE
REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2,Tmpv3,g_Tmpv3
REAL :: g_Sqrt
TYPE(grid_config_rec_type) :: config_flags
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
INTEGER :: n_moist,n_chem,n_scalar,n_tracer,km_opt
REAL,DIMENSION(kms:kme) :: fnm
REAL,DIMENSION(kms:kme) :: fnp
REAL,DIMENSION(kms:kme) :: dnw
REAL,DIMENSION(kms:kme) :: dn
REAL,DIMENSION(ims:ime,jms:jme) :: mu,g_mu
REAL,DIMENSION(kms:kme) :: qv_base
REAL,DIMENSION(kms:kme) :: u_base
REAL,DIMENSION(kms:kme) :: v_base
REAL,DIMENSION(kms:kme) :: t_base
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: ru_tendf,g_ru_tendf,rv_tendf, &
g_rv_tendf,rw_tendf,g_rw_tendf,tke_tendf,g_tke_tendf,rt_tendf,g_rt_tendf
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_moist) :: moist_tendf,g_moist_tendf
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_chem) :: chem_tendf,g_chem_tendf
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_scalar) :: scalar_tendf,g_scalar_tendf
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_tracer) :: tracer_tendf,g_tracer_tendf
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_moist) :: moist,g_moist
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_chem) :: chem,g_chem
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_scalar) :: scalar,g_scalar
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_tracer) :: tracer,g_tracer
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor13,g_defor13,defor23,g_defor23, &
defor33,g_defor33,div,g_div,xkmv,g_xkmv,xkhv,g_xkhv,tke,g_tke,rdz, &
g_rdz,u_2,g_u_2,v_2,g_v_2,rdzw,g_rdzw
INTEGER :: n_nba_mij
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_nba_mij) :: nba_mij,g_nba_mij
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: rho,g_rho
REAL,DIMENSION(ims:ime,jms:jme) :: hfx,g_hfx,qfx,g_qfx
REAL,DIMENSION(ims:ime,jms:jme) :: ust,g_ust
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: thp,g_thp
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: var_mix,g_var_mix
INTEGER :: im,i,j,k
INTEGER :: i_start,i_end,j_start,j_end
REAL :: V0_u,g_V0_u,V0_v,g_V0_v,tao_xz,g_tao_xz,tao_yz,g_tao_yz,ustar, &
g_ustar,cd0,g_cd0
REAL :: xsfc,g_xsfc,psi1,g_psi1,vk2,g_vk2,zrough,g_zrough,lnz,g_lnz
REAL :: heat_flux,g_heat_flux,moist_flux,g_moist_flux,heat_flux0,g_heat_flux0
REAL :: cpm,g_cpm
i_start =its
i_end =min(ite,ide-1)
j_start =jts
j_end =min(jte,jde-1)
CALL g_vertical_diffusion_u_2(ru_tendf,g_ru_tendf,config_flags,mu,g_mu, &
defor13,g_defor13,xkmv,g_xkmv,nba_mij,g_nba_mij,n_nba_mij,dnw,rdzw, &
g_rdzw,fnm,fnp,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
CALL g_vertical_diffusion_v_2(rv_tendf,g_rv_tendf,config_flags,mu,g_mu, &
defor23,g_defor23,xkmv,g_xkmv,nba_mij,g_nba_mij,n_nba_mij,dnw,rdzw, &
g_rdzw,fnm,fnp,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
CALL g_vertical_diffusion_w_2(rw_tendf,g_rw_tendf,config_flags,mu,g_mu, &
defor33,g_defor33,tke(ims,kms,jms),g_tke(ims,kms,jms),nba_mij,g_nba_mij, &
n_nba_mij,div,g_div,xkmv,g_xkmv,dn,rdz,g_rdz,ids,ide,jds,jde,kds,kde,ims, &
ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
! Added by Ning Pan, 2010-08-11
tl_vflux: SELECT CASE( config_flags%isfflx )
CASE (0)
! Remarked by Ning Pan, 2010-08-09
! g_cd0 =g_config_flags%tke_drag_coefficient
cd0 =config_flags%tke_drag_coefficient
DO j =j_start,j_end
DO i =i_start,ite
g_V0_u =0.0
V0_u =0.
g_tao_xz =0.0
tao_xz =0.
g_V0_u =g_Sqrt((2.0*g_u_2(i,kts,j)*u_2(i,kts,j)) +(2.0*((g_v_2(i,kts,j) &
+g_v_2(i,kts,j+1) +g_v_2(i-1,kts,j) +g_v_2(i-1,kts,j+1))/4)*((v_2(i,kts,j) &
+v_2(i,kts,j+1) +v_2(i-1,kts,j) +v_2(i-1,kts,j+1))/4)), (u_2(i,kts,j)**2) &
+(((v_2(i,kts,j) +v_2(i,kts,j+1) +v_2(i-1,kts,j) +v_2(i-1,kts,j+1))/4)**2))
V0_u =sqrt((u_2(i,kts,j)**2) +(((v_2(i,kts,j) +v_2(i,kts,j+1) +v_2(i-1,kts,j) &
+v_2(i-1,kts,j+1))/4)**2)) +epsilon
! Revised by Ning Pan, 2010-08-11
! g_Tmpv1 =cd0*g_V0_u +g_cd0*V0_u
g_Tmpv1 =cd0*g_V0_u
Tmpv1 =cd0*V0_u
g_Tmpv2 =Tmpv1*g_u_2(i,kts,j) +g_Tmpv1*u_2(i,kts,j)
Tmpv2 =Tmpv1*u_2(i,kts,j)
g_tao_xz =g_Tmpv2
tao_xz =Tmpv2
g_Tmpv1 =0.25*(mu(i,j) +mu(i-1,j))*g_tao_xz +0.25*(g_mu(i,j) +g_mu(i-1,j))*tao_xz
Tmpv1 =0.25*(mu(i,j) +mu(i-1,j))*tao_xz
g_Tmpv2 =Tmpv1*(g_rdzw(i,kts,j) +g_rdzw(i-1,kts,j)) +g_Tmpv1*(rdzw(i, &
kts,j) +rdzw(i-1,kts,j))
Tmpv2 =Tmpv1*(rdzw(i,kts,j) +rdzw(i-1,kts,j))
g_ru_tendf(i,kts,j) =g_ru_tendf(i,kts,j) -g_Tmpv2
ru_tendf(i,kts,j) =ru_tendf(i,kts,j) -Tmpv2
IF ( (config_flags%m_opt .EQ. 1) .OR. (config_flags%sfs_opt .GT. 0) ) THEN
g_nba_mij(i,kts,j,P_m13) = -g_tao_xz
nba_mij(i,kts,j,P_m13) = -tao_xz
ENDIF
ENDDO
ENDDO
DO j =j_start,jte
DO i =i_start,i_end
g_V0_v =0.0
V0_v =0.
g_tao_yz =0.0
tao_yz =0.
g_V0_v =g_Sqrt((2.0*g_v_2(i,kts,j)*v_2(i,kts,j)) +(2.0*((g_u_2(i,kts,j) &
+g_u_2(i,kts,j-1) +g_u_2(i+1,kts,j) +g_u_2(i+1,kts,j-1))/4)*((u_2(i,kts,j) &
+u_2(i,kts,j-1) +u_2(i+1,kts,j) +u_2(i+1,kts,j-1))/4)), (v_2(i,kts,j)**2) &
+(((u_2(i,kts,j) +u_2(i,kts,j-1) +u_2(i+1,kts,j) +u_2(i+1,kts,j-1))/4)**2))
V0_v =sqrt((v_2(i,kts,j)**2) +(((u_2(i,kts,j) +u_2(i,kts,j-1) +u_2(i+1,kts,j) &
+u_2(i+1,kts,j-1))/4)**2)) +epsilon
! Revised by Ning Pan, 2010-08-11
! g_Tmpv1 =cd0*g_V0_v +g_cd0*V0_v
g_Tmpv1 =cd0*g_V0_v
Tmpv1 =cd0*V0_v
g_Tmpv2 =Tmpv1*g_v_2(i,kts,j) +g_Tmpv1*v_2(i,kts,j)
Tmpv2 =Tmpv1*v_2(i,kts,j)
g_tao_yz =g_Tmpv2
tao_yz =Tmpv2
g_Tmpv1 =0.25*(mu(i,j) +mu(i,j-1))*g_tao_yz +0.25*(g_mu(i,j) +g_mu(i,j-1))*tao_yz
Tmpv1 =0.25*(mu(i,j) +mu(i,j-1))*tao_yz
g_Tmpv2 =Tmpv1*(g_rdzw(i,kts,j) +g_rdzw(i,kts,j-1)) +g_Tmpv1*(rdzw(i, &
kts,j) +rdzw(i,kts,j-1))
Tmpv2 =Tmpv1*(rdzw(i,kts,j) +rdzw(i,kts,j-1))
g_rv_tendf(i,kts,j) =g_rv_tendf(i,kts,j) -g_Tmpv2
rv_tendf(i,kts,j) =rv_tendf(i,kts,j) -Tmpv2
IF ( (config_flags%m_opt .EQ. 1) .OR. (config_flags%sfs_opt .GT. 0) ) THEN
g_nba_mij(i,kts,j,P_m23) = -g_tao_yz
nba_mij(i,kts,j,P_m23) = -tao_yz
ENDIF
ENDDO
ENDDO
CASE (1,2) ! Added by Ning Pan, 2010-08-11
DO j =j_start,j_end
DO i =i_start,ite
g_V0_u =0.0
V0_u =0.
g_tao_xz =0.0
tao_xz =0.
g_V0_u =g_Sqrt((2.0*g_u_2(i,kts,j)*u_2(i,kts,j)) +(2.0*((g_v_2(i,kts,j) &
+g_v_2(i,kts,j+1) +g_v_2(i-1,kts,j) +g_v_2(i-1,kts,j+1))/4)*((v_2(i,kts,j) &
+v_2(i,kts,j+1) +v_2(i-1,kts,j) +v_2(i-1,kts,j+1))/4)), (u_2(i,kts,j)**2) &
+(((v_2(i,kts,j) +v_2(i,kts,j+1) +v_2(i-1,kts,j) +v_2(i-1,kts,j+1))/4)**2))
V0_u =sqrt((u_2(i,kts,j)**2) +(((v_2(i,kts,j) +v_2(i,kts,j+1) +v_2(i-1,kts,j) &
+v_2(i-1,kts,j+1))/4)**2)) +epsilon
g_ustar =0.5*(g_ust(i,j) +g_ust(i-1,j))
ustar =0.5*(ust(i,j) +ust(i-1,j))
g_Tmpv1 =2.0*ustar*g_ustar
Tmpv1 =ustar*ustar
g_Tmpv2 =Tmpv1*g_u_2(i,kts,j) +g_Tmpv1*u_2(i,kts,j)
Tmpv2 =Tmpv1*u_2(i,kts,j)
g_Tmpv3 =(g_Tmpv2*V0_u -g_V0_u*Tmpv2)/(V0_u*V0_u)
Tmpv3 =Tmpv2/V0_u
g_tao_xz =g_Tmpv3
tao_xz =Tmpv3
g_Tmpv1 =0.25*(mu(i,j) +mu(i-1,j))*g_tao_xz +0.25*(g_mu(i,j) +g_mu(i-1,j))*tao_xz
Tmpv1 =0.25*(mu(i,j) +mu(i-1,j))*tao_xz
g_Tmpv2 =Tmpv1*(g_rdzw(i,kts,j) +g_rdzw(i-1,kts,j)) +g_Tmpv1*(rdzw(i, &
kts,j) +rdzw(i-1,kts,j))
Tmpv2 =Tmpv1*(rdzw(i,kts,j) +rdzw(i-1,kts,j))
g_ru_tendf(i,kts,j) =g_ru_tendf(i,kts,j) -g_Tmpv2
ru_tendf(i,kts,j) =ru_tendf(i,kts,j) -Tmpv2
IF ( (config_flags%m_opt .EQ. 1) .OR. (config_flags%sfs_opt .GT. 0) ) THEN
g_nba_mij(i,kts,j,P_m13) = -g_tao_xz
nba_mij(i,kts,j,P_m13) = -tao_xz
ENDIF
ENDDO
ENDDO
DO j =j_start,jte
DO i =i_start,i_end
g_V0_v =0.0
V0_v =0.
g_tao_yz =0.0
tao_yz =0.
g_V0_v =g_Sqrt((2.0*g_v_2(i,kts,j)*v_2(i,kts,j)) +(2.0*((g_u_2(i,kts,j) &
+g_u_2(i,kts,j-1) +g_u_2(i+1,kts,j) +g_u_2(i+1,kts,j-1))/4)*((u_2(i,kts,j) &
+u_2(i,kts,j-1) +u_2(i+1,kts,j) +u_2(i+1,kts,j-1))/4)), (v_2(i,kts,j)**2) &
+(((u_2(i,kts,j) +u_2(i,kts,j-1) +u_2(i+1,kts,j) +u_2(i+1,kts,j-1))/4)**2))
V0_v =sqrt((v_2(i,kts,j)**2) +(((u_2(i,kts,j) +u_2(i,kts,j-1) +u_2(i+1,kts,j) &
+u_2(i+1,kts,j-1))/4)**2)) +epsilon
g_ustar =0.5*(g_ust(i,j) +g_ust(i,j-1))
ustar =0.5*(ust(i,j) +ust(i,j-1))
g_Tmpv1 =2.0*ustar*g_ustar
Tmpv1 =ustar*ustar
g_Tmpv2 =Tmpv1*g_v_2(i,kts,j) +g_Tmpv1*v_2(i,kts,j)
Tmpv2 =Tmpv1*v_2(i,kts,j)
g_Tmpv3 =(g_Tmpv2*V0_v -g_V0_v*Tmpv2)/(V0_v*V0_v)
Tmpv3 =Tmpv2/V0_v
g_tao_yz =g_Tmpv3
tao_yz =Tmpv3
g_Tmpv1 =0.25*(mu(i,j) +mu(i,j-1))*g_tao_yz +0.25*(g_mu(i,j) +g_mu(i,j-1))*tao_yz
Tmpv1 =0.25*(mu(i,j) +mu(i,j-1))*tao_yz
g_Tmpv2 =Tmpv1*(g_rdzw(i,kts,j) +g_rdzw(i,kts,j-1)) +g_Tmpv1*(rdzw(i, &
kts,j) +rdzw(i,kts,j-1))
Tmpv2 =Tmpv1*(rdzw(i,kts,j) +rdzw(i,kts,j-1))
g_rv_tendf(i,kts,j) =g_rv_tendf(i,kts,j) -g_Tmpv2
rv_tendf(i,kts,j) =rv_tendf(i,kts,j) -Tmpv2
IF ( (config_flags%m_opt .EQ. 1) .OR. (config_flags%sfs_opt .GT. 0) ) THEN
g_nba_mij(i,kts,j,P_m23) = -g_tao_yz
nba_mij(i,kts,j,P_m23) = -tao_yz
ENDIF
ENDDO
ENDDO
CASE DEFAULT ! Added by Ning Pan, 2010-08-11
! Revised by Ning Pan, 2010-08-10
! CALL g_wrf_error_fatal('isfflx value invalid for diff_opt=2')
CALL wrf_error_fatal('isfflx value invalid for diff_opt=2')
END SELECT tl_vflux ! Added by Ning Pan, 2010-08-11
IF( config_flags%mix_full_fields ) THEN
DO j =jts,min(jte,jde-1)
DO k =kts,kte-1
DO i =its,min(ite,ide-1)
g_var_mix(i,k,j) =g_thp(i,k,j)
var_mix(i,k,j) =thp(i,k,j)
ENDDO
ENDDO
ENDDO
ELSE
DO j =jts,min(jte,jde-1)
DO k =kts,kte-1
DO i =its,min(ite,ide-1)
g_var_mix(i,k,j) =g_thp(i,k,j)
var_mix(i,k,j) =thp(i,k,j) -t_base(k)
ENDDO
ENDDO
ENDDO
END IF
CALL g_vertical_diffusion_s(rt_tendf,g_rt_tendf,config_flags,var_mix, &
g_var_mix,mu,g_mu,xkhv,g_xkhv,dn,dnw,rdz,g_rdz,rdzw,g_rdzw,fnm,fnp, &
.false.,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
! Added by Ning Pan, 2010-08-11
tl_hflux: SELECT CASE( config_flags%isfflx )
CASE (0,2)
! Remarked by Ning Pan, 2010-08-09
! g_heat_flux =g_config_flags%tke_heat_flux
heat_flux =config_flags%tke_heat_flux
DO j =j_start,j_end
DO i =i_start,i_end
g_cpm =cp*(0.8*g_moist(i,kts,j,P_QV))
cpm =cp*(1. +0.8*moist(i,kts,j,P_QV))
g_hfx(i,j)= heat_flux*cpm*g_rho(i,1,j) + heat_flux*g_cpm*rho(i,1,j)
! Revised by Ning Pan, 2010-08-11
! g_Tmpv1 =mu(i,j)*g_heat_flux +g_mu(i,j)*heat_flux
g_Tmpv1 =g_mu(i,j)*heat_flux
Tmpv1 =mu(i,j)*heat_flux
g_Tmpv2 =Tmpv1*g_rdzw(i,kts,j) +g_Tmpv1*rdzw(i,kts,j)
Tmpv2 =Tmpv1*rdzw(i,kts,j)
g_rt_tendf(i,kts,j) =g_rt_tendf(i,kts,j) +g_Tmpv2
rt_tendf(i,kts,j) =rt_tendf(i,kts,j) +Tmpv2
ENDDO
ENDDO
CASE (1) ! Added by Ning Pan, 2010-08-11
DO j =j_start,j_end
DO i =i_start,i_end
g_cpm =cp*(0.8*g_moist(i,kts,j,P_QV))
cpm =cp*(1. +0.8*moist(i,kts,j,P_QV))
g_Tmpv1 =(g_hfx(i,j)*cpm -g_cpm*hfx(i,j))/(cpm*cpm)
Tmpv1 =hfx(i,j)/cpm
g_Tmpv2 =(g_Tmpv1*rho(i,1,j) -g_rho(i,1,j)*Tmpv1)/(rho(i,1,j)*rho(i,1,j))
Tmpv2 =Tmpv1/rho(i,1,j)
g_heat_flux =g_Tmpv2
heat_flux =Tmpv2
g_Tmpv1 =mu(i,j)*g_heat_flux +g_mu(i,j)*heat_flux
Tmpv1 =mu(i,j)*heat_flux
g_Tmpv2 =Tmpv1*g_rdzw(i,kts,j) +g_Tmpv1*rdzw(i,kts,j)
Tmpv2 =Tmpv1*rdzw(i,kts,j)
g_rt_tendf(i,kts,j) =g_rt_tendf(i,kts,j) +g_Tmpv2
rt_tendf(i,kts,j) =rt_tendf(i,kts,j) +Tmpv2
ENDDO
ENDDO
CASE DEFAULT ! Added by Ning Pan, 2010-08-11
! Revised by Ning Pan, 2010-08-10
! CALL g_wrf_error_fatal('isfflx value invalid for diff_opt=2')
CALL wrf_error_fatal('isfflx value invalid for diff_opt=2')
END SELECT tl_hflux ! Added by Ning Pan, 2010-08-11
IF(km_opt .eq. 2) THEN
CALL g_vertical_diffusion_s(tke_tendf(ims,kms,jms),g_tke_tendf(ims,kms,jms) &
,config_flags,tke(ims,kms,jms),g_tke(ims,kms,jms),mu,g_mu,xkhv,g_xkhv,dn, &
dnw,rdz,g_rdz,rdzw,g_rdzw,fnm,fnp,.true.,ids,ide,jds,jde,kds,kde,ims,ime,jms, &
jme,kms,kme,its,ite,jts,jte,kts,kte)
endif
IF(n_moist .ge. PARAM_FIRST_SCALAR) THEN
DO im =PARAM_FIRST_SCALAR,n_moist
IF( (.not. config_flags%mix_full_fields) .and. (im == P_QV) ) THEN
DO j =jts,min(jte,jde-1)
DO k =kts,kte-1
DO i =its,min(ite,ide-1)
g_var_mix(i,k,j) =g_moist(i,k,j,im)
var_mix(i,k,j) =moist(i,k,j,im) -qv_base(k)
ENDDO
ENDDO
ENDDO
ELSE
DO j =jts,min(jte,jde-1)
DO k =kts,kte-1
DO i =its,min(ite,ide-1)
g_var_mix(i,k,j) =g_moist(i,k,j,im)
var_mix(i,k,j) =moist(i,k,j,im)
ENDDO
ENDDO
ENDDO
END IF
CALL g_vertical_diffusion_s(moist_tendf(ims,kms,jms,im),g_moist_tendf(ims,kms, &
jms,im),config_flags,var_mix,g_var_mix,mu,g_mu,xkhv,g_xkhv,dn,dnw,rdz, &
g_rdz,rdzw,g_rdzw,fnm,fnp,.false.,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms, &
kme,its,ite,jts,jte,kts,kte)
! Added by Ning Pan, 2010-08-11
tl_qflux: SELECT CASE( config_flags%isfflx )
CASE (0)
CASE (1,2)
IF( im == P_QV ) THEN
DO j =j_start,j_end
DO i =i_start,i_end
g_Tmpv1 =(g_qfx(i,j)*rho(i,1,j) -g_rho(i,1,j)*qfx(i,j))/(rho(i,1,j)*rho(i,1,j))
Tmpv1 =qfx(i,j)/rho(i,1,j)
g_Tmpv2 =(g_Tmpv1*(1. +moist(i,kts,j,P_QV)) -(g_moist(i,kts,j,P_QV))*Tmpv1) &
/((1. +moist(i,kts,j,P_QV))*(1. +moist(i,kts,j,P_QV)))
Tmpv2 =Tmpv1/(1. +moist(i,kts,j,P_QV))
g_moist_flux =g_Tmpv2
moist_flux =Tmpv2
g_Tmpv1 =mu(i,j)*g_moist_flux +g_mu(i,j)*moist_flux
Tmpv1 =mu(i,j)*moist_flux
g_Tmpv2 =Tmpv1*g_rdzw(i,kts,j) +g_Tmpv1*rdzw(i,kts,j)
Tmpv2 =Tmpv1*rdzw(i,kts,j)
g_moist_tendf(i,kts,j,im) =g_moist_tendf(i,kts,j,im) +g_Tmpv2
moist_tendf(i,kts,j,im) =moist_tendf(i,kts,j,im) +Tmpv2
ENDDO
ENDDO
ENDIF
CASE DEFAULT ! Added by Ning Pan, 2010-08-11
! Revised by Ning Pan, 2010-08-10
! CALL g_wrf_error_fatal('isfflx value invalid for diff_opt=2')
CALL wrf_error_fatal('isfflx value invalid for diff_opt=2')
END SELECT tl_qflux ! Added by Ning Pan, 2010-08-11
ENDDO
ENDIF
IF(n_chem .ge. PARAM_FIRST_SCALAR) THEN
DO im =PARAM_FIRST_SCALAR,n_chem
CALL g_vertical_diffusion_s(chem_tendf(ims,kms,jms,im),g_chem_tendf(ims,kms, &
jms,im),config_flags,chem(ims,kms,jms,im),g_chem(ims,kms,jms,im),mu,g_mu,xkhv, &
g_xkhv,dn,dnw,rdz,g_rdz,rdzw,g_rdzw,fnm,fnp,.false.,ids,ide,jds,jde,kds,kde, &
ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
ENDDO
ENDIF
IF(n_tracer .ge. PARAM_FIRST_SCALAR) THEN
DO im =PARAM_FIRST_SCALAR,n_tracer
CALL g_vertical_diffusion_s(tracer_tendf(ims,kms,jms,im),g_tracer_tendf(ims, &
kms,jms,im),config_flags,tracer(ims,kms,jms,im),g_tracer(ims,kms,jms,im) &
,mu,g_mu,xkhv,g_xkhv,dn,dnw,rdz,g_rdz,rdzw,g_rdzw,fnm,fnp,.false.,ids, &
ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
ENDDO
ENDIF
IF(n_scalar .ge. PARAM_FIRST_SCALAR) THEN
DO im =PARAM_FIRST_SCALAR,n_scalar
CALL g_vertical_diffusion_s(scalar_tendf(ims,kms,jms,im),g_scalar_tendf(ims, &
kms,jms,im),config_flags,scalar(ims,kms,jms,im),g_scalar(ims,kms,jms,im) &
,mu,g_mu,xkhv,g_xkhv,dn,dnw,rdz,g_rdz,rdzw,g_rdzw,fnm,fnp,.false.,ids, &
ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
ENDDO
ENDIF
END SUBROUTINE g_vertical_diffusion_2
SUBROUTINE g_vertical_diffusion_u_2(tendency,g_tendency,config_flags,mu, &
g_mu,defor13,g_defor13,xkmv,g_xkmv,nba_mij,g_nba_mij,n_nba_mij,dnw,rdzw, &
g_rdzw,fnm,fnp,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
IMPLICIT NONE
REAL :: Tmpv1,g_Tmpv1
TYPE(grid_config_rec_type) :: config_flags
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
REAL,DIMENSION(kms:kme) :: fnm
REAL,DIMENSION(kms:kme) :: fnp
REAL,DIMENSION(kms:kme) :: dnw
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,g_tendency
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor13,g_defor13,xkmv,g_xkmv,rdzw,g_rdzw
INTEGER :: n_nba_mij
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_nba_mij) :: nba_mij,g_nba_mij
REAL,DIMENSION(ims:ime,jms:jme) :: mu,g_mu
INTEGER :: i,j,k,ktf
INTEGER :: i_start,i_end,j_start,j_end
INTEGER :: is_ext,ie_ext,js_ext,je_ext
REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: titau3,g_titau3
REAL,DIMENSION(its:ite,jts:jte) :: zzavg,g_zzavg
REAL :: rdzu,g_rdzu
ktf =min(kte,kde-1)
i_start =its
i_end =ite
j_start =jts
j_end =min(jte,jde-1)
IF( config_flags%open_xs .or. config_flags%specified .or. &
config_flags%nested) i_start =max(ids+1,its)
IF( config_flags%open_xe .or. config_flags%specified .or. &
config_flags%nested) i_end =min(ide-1,ite)
IF( config_flags%open_ys .or. config_flags%specified .or. &
config_flags%nested) j_start =max(jds+1,jts)
IF( config_flags%open_ye .or. config_flags%specified .or. &
config_flags%nested) j_end =min(jde-2,jte)
IF( config_flags%periodic_x ) i_start =its
IF( config_flags%periodic_x ) i_end =ite
is_ext =0
ie_ext =0
js_ext =0
je_ext =0
CALL g_cal_titau_13_31(config_flags,titau3,g_titau3,defor13,g_defor13, &
nba_mij(ims,kms,jms,P_m13),g_nba_mij(ims,kms,jms,P_m13),mu,g_mu,xkmv,g_xkmv, &
fnm,fnp,is_ext,ie_ext,js_ext,je_ext,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme, &
its,ite,jts,jte,kts,kte)
DO j =j_start,j_end
DO k =kts+1,ktf
DO i =i_start,i_end
g_rdzu =-2.*(-1.*g_rdzw(i,k,j)/(rdzw(i,k,j)*rdzw(i,k,j)) +(-1.*g_rdzw(i-1,k, &
j)/(rdzw(i-1,k,j)*rdzw(i-1,k,j))))/((1./rdzw(i,k,j) +1./rdzw(i-1,k,j))*(1./rdzw(i,k, &
j) +1./rdzw(i-1,k,j)))
rdzu =2./(1./rdzw(i,k,j) +1./rdzw(i-1,k,j))
g_Tmpv1 =rdzu*(g_titau3(i,k+1,j) -g_titau3(i,k,j)) +g_rdzu*(titau3(i,k+ &
1,j) -titau3(i,k,j))
Tmpv1 =rdzu*(titau3(i,k+1,j) -titau3(i,k,j))
g_tendency(i,k,j) =g_tendency(i,k,j) -g_Tmpv1
tendency(i,k,j) =tendency(i,k,j) -Tmpv1
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
k =kts
DO i =i_start,i_end
g_rdzu =-2.*(-1.*g_rdzw(i,k,j)/(rdzw(i,k,j)*rdzw(i,k,j)) +(-1.*g_rdzw(i-1,k, &
j)/(rdzw(i-1,k,j)*rdzw(i-1,k,j))))/((1./rdzw(i,k,j) +1./rdzw(i-1,k,j))*(1./rdzw(i,k, &
j) +1./rdzw(i-1,k,j)))
rdzu =2./(1./rdzw(i,k,j) +1./rdzw(i-1,k,j))
g_Tmpv1 =rdzu*(g_titau3(i,k+1,j)) +g_rdzu*(titau3(i,k+1,j))
Tmpv1 =rdzu*(titau3(i,k+1,j))
g_tendency(i,k,j) =g_tendency(i,k,j) -g_Tmpv1
tendency(i,k,j) =tendency(i,k,j) -Tmpv1
ENDDO
ENDDO
END SUBROUTINE g_vertical_diffusion_u_2
SUBROUTINE g_vertical_diffusion_v_2(tendency,g_tendency,config_flags,mu, &
g_mu,defor23,g_defor23,xkmv,g_xkmv,nba_mij,g_nba_mij,n_nba_mij,dnw,rdzw, &
g_rdzw,fnm,fnp,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
IMPLICIT NONE
REAL :: Tmpv1,g_Tmpv1
TYPE(grid_config_rec_type) :: config_flags
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
REAL,DIMENSION(kms:kme) :: fnm
REAL,DIMENSION(kms:kme) :: fnp
REAL,DIMENSION(kms:kme) :: dnw
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,g_tendency
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor23,g_defor23,xkmv,g_xkmv,rdzw,g_rdzw
INTEGER :: n_nba_mij
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_nba_mij) :: nba_mij,g_nba_mij
REAL,DIMENSION(ims:ime,jms:jme) :: mu,g_mu
INTEGER :: i,j,k,ktf
INTEGER :: i_start,i_end,j_start,j_end
INTEGER :: is_ext,ie_ext,js_ext,je_ext
REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: titau3,g_titau3
REAL,DIMENSION(its:ite,jts:jte) :: zzavg,g_zzavg
REAL :: rdzv,g_rdzv
ktf =min(kte,kde-1)
i_start =its
i_end =min(ite,ide-1)
j_start =jts
j_end =jte
IF( config_flags%open_xs .or. config_flags%specified .or. &
config_flags%nested) i_start =max(ids+1,its)
IF( config_flags%open_xe .or. config_flags%specified .or. &
config_flags%nested) i_end =min(ide-2,ite)
IF( config_flags%open_ys .or. config_flags%specified .or. &
config_flags%nested) j_start =max(jds+1,jts)
IF( config_flags%open_ye .or. config_flags%specified .or. &
config_flags%nested) j_end =min(jde-1,jte)
IF( config_flags%periodic_x ) i_start =its
IF( config_flags%periodic_x ) i_end =min(ite,ide-1)
is_ext =0
ie_ext =0
js_ext =0
je_ext =0
CALL g_cal_titau_23_32(config_flags,titau3,g_titau3,defor23,g_defor23, &
nba_mij(ims,kms,jms,P_m23),g_nba_mij(ims,kms,jms,P_m23),mu,g_mu,xkmv,g_xkmv, &
fnm,fnp,is_ext,ie_ext,js_ext,je_ext,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme, &
its,ite,jts,jte,kts,kte)
DO j =j_start,j_end
DO k =kts+1,ktf
DO i =i_start,i_end
g_rdzv =-2.*(-1.*g_rdzw(i,k,j)/(rdzw(i,k,j)*rdzw(i,k,j)) +(-1.*g_rdzw(i,k,j- &
1)/(rdzw(i,k,j-1)*rdzw(i,k,j-1))))/((1./rdzw(i,k,j) +1./rdzw(i,k,j-1))*(1./rdzw(i,k, &
j) +1./rdzw(i,k,j-1)))
rdzv =2./(1./rdzw(i,k,j) +1./rdzw(i,k,j-1))
g_Tmpv1 =rdzv*(g_titau3(i,k+1,j) -g_titau3(i,k,j)) +g_rdzv*(titau3(i,k+ &
1,j) -titau3(i,k,j))
Tmpv1 =rdzv*(titau3(i,k+1,j) -titau3(i,k,j))
g_tendency(i,k,j) =g_tendency(i,k,j) -g_Tmpv1
tendency(i,k,j) =tendency(i,k,j) -Tmpv1
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
k =kts
DO i =i_start,i_end
g_rdzv =-2.*(-1.*g_rdzw(i,k,j)/(rdzw(i,k,j)*rdzw(i,k,j)) +(-1.*g_rdzw(i,k,j- &
1)/(rdzw(i,k,j-1)*rdzw(i,k,j-1))))/((1./rdzw(i,k,j) +1./rdzw(i,k,j-1))*(1./rdzw(i,k, &
j) +1./rdzw(i,k,j-1)))
rdzv =2./(1./rdzw(i,k,j) +1./rdzw(i,k,j-1))
g_Tmpv1 =rdzv*(g_titau3(i,k+1,j)) +g_rdzv*(titau3(i,k+1,j))
Tmpv1 =rdzv*(titau3(i,k+1,j))
g_tendency(i,k,j) =g_tendency(i,k,j) -g_Tmpv1
tendency(i,k,j) =tendency(i,k,j) -Tmpv1
ENDDO
ENDDO
END SUBROUTINE g_vertical_diffusion_v_2
SUBROUTINE g_vertical_diffusion_w_2(tendency,g_tendency,config_flags,mu, &
g_mu,defor33,g_defor33,tke,g_tke,nba_mij,g_nba_mij,n_nba_mij,div, &
g_div,xkmv,g_xkmv,dn,rdz,g_rdz,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms, &
kme,its,ite,jts,jte,kts,kte)
IMPLICIT NONE
REAL :: Tmpv1,g_Tmpv1
TYPE(grid_config_rec_type) :: config_flags
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
REAL,DIMENSION(kms:kme) :: dn
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,g_tendency
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor33,g_defor33,tke,g_tke,div, &
g_div,xkmv,g_xkmv,rdz,g_rdz
INTEGER :: n_nba_mij
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_nba_mij) :: nba_mij,g_nba_mij
REAL,DIMENSION(ims:ime,jms:jme) :: mu,g_mu
INTEGER :: i,j,k,ktf
INTEGER :: i_start,i_end,j_start,j_end
INTEGER :: is_ext,ie_ext,js_ext,je_ext
REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: titau3,g_titau3
ktf =min(kte,kde-1)
i_start =its
i_end =min(ite,ide-1)
j_start =jts
j_end =min(jte,jde-1)
IF( config_flags%open_xs .or. config_flags%specified .or. &
config_flags%nested) i_start =max(ids+1,its)
IF( config_flags%open_xe .or. config_flags%specified .or. &
config_flags%nested) i_end =min(ide-2,ite)
IF( config_flags%open_ys .or. config_flags%specified .or. &
config_flags%nested) j_start =max(jds+1,jts)
IF( config_flags%open_ye .or. config_flags%specified .or. &
config_flags%nested) j_end =min(jde-2,jte)
IF( config_flags%periodic_x ) i_start =its
IF( config_flags%periodic_x ) i_end =min(ite,ide-1)
is_ext =0
ie_ext =0
js_ext =0
je_ext =0
CALL g_cal_titau_11_22_33(config_flags,titau3,g_titau3,mu,g_mu,tke,g_tke, &
xkmv,g_xkmv,defor33,g_defor33,nba_mij(ims,kms,jms,P_m33),g_nba_mij(ims,kms, &
jms,P_m33),is_ext,ie_ext,js_ext,je_ext,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms, &
kme,its,ite,jts,jte,kts,kte)
DO j =j_start,j_end
DO k =kts+1,ktf
DO i =i_start,i_end
g_Tmpv1 =rdz(i,k,j)*(g_titau3(i,k,j) -g_titau3(i,k-1,j)) +g_rdz(i,k,j) &
*(titau3(i,k,j) -titau3(i,k-1,j))
Tmpv1 =rdz(i,k,j)*(titau3(i,k,j) -titau3(i,k-1,j))
g_tendency(i,k,j) =g_tendency(i,k,j) -g_Tmpv1
tendency(i,k,j) =tendency(i,k,j) -Tmpv1
ENDDO
ENDDO
ENDDO
END SUBROUTINE g_vertical_diffusion_w_2
SUBROUTINE g_vertical_diffusion_s(tendency,g_tendency,config_flags,var, &
g_var,mu,g_mu,xkhv,g_xkhv,dn,dnw,rdz,g_rdz,rdzw,g_rdzw,fnm,fnp, &
doing_tke,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
IMPLICIT NONE
REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2
TYPE(grid_config_rec_type) :: config_flags
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
LOGICAL :: doing_tke
REAL,DIMENSION(kms:kme) :: fnm
REAL,DIMENSION(kms:kme) :: fnp
REAL,DIMENSION(kms:kme) :: dn
REAL,DIMENSION(kms:kme) :: dnw
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,g_tendency
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: xkhv,g_xkhv
REAL,DIMENSION(ims:ime,jms:jme) :: mu,g_mu
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: var,g_var,rdz,g_rdz,rdzw,g_rdzw
INTEGER :: i,j,k,ktf
INTEGER :: i_start,i_end,j_start,j_end
REAL,DIMENSION(its:ite,kts:kte,jts:jte) :: H3,g_H3,xkxavg,g_xkxavg,rravg,g_rravg
REAL,DIMENSION(its:ite,kts:kte,jts:jte) :: tmptendf,g_tmptendf
ktf =min(kte,kde-1)
i_start =its
i_end =min(ite,ide-1)
j_start =jts
j_end =min(jte,jde-1)
IF( config_flags%open_xs .or. config_flags%specified .or. &
config_flags%nested) i_start =max(ids+1,its)
IF( config_flags%open_xe .or. config_flags%specified .or. &
config_flags%nested) i_end =min(ide-2,ite)
IF( config_flags%open_ys .or. config_flags%specified .or. &
config_flags%nested) j_start =max(jds+1,jts)
IF( config_flags%open_ye .or. config_flags%specified .or. &
config_flags%nested) j_end =min(jde-2,jte)
IF( config_flags%periodic_x ) i_start =its
IF( config_flags%periodic_x ) i_end =min(ite,ide-1)
IF(doing_tke) THEN
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_tmptendf(i,k,j) =g_tendency(i,k,j)
tmptendf(i,k,j) =tendency(i,k,j)
ENDDO
ENDDO
ENDDO
ENDIF
g_xkxavg =0.0
xkxavg =0.
DO j =j_start,j_end
DO k =kts+1,ktf
DO i =i_start,i_end
g_xkxavg(i,k,j) =fnm(k)*g_xkhv(i,k,j) +fnp(k)*g_xkhv(i,k-1,j)
xkxavg(i,k,j) =fnm(k)*xkhv(i,k,j) +fnp(k)*xkhv(i,k-1,j)
g_Tmpv1 =-xkxavg(i,k,j)*(g_var(i,k,j) -g_var(i,k-1,j)) -g_xkxavg(i,k,j) &
*(var(i,k,j) -var(i,k-1,j))
Tmpv1 =-xkxavg(i,k,j)*(var(i,k,j) -var(i,k-1,j))
g_Tmpv2 =Tmpv1*g_rdz(i,k,j) +g_Tmpv1*rdz(i,k,j)
Tmpv2 =Tmpv1*rdz(i,k,j)
g_H3(i,k,j) =g_Tmpv2
H3(i,k,j) =Tmpv2
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO i =i_start,i_end
g_H3(i,kts,j) =0.0
H3(i,kts,j) =0.
g_H3(i,ktf+1,j) =0.0
H3(i,ktf+1,j) =0.
ENDDO
ENDDO
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_Tmpv1 =mu(i,j)*(g_H3(i,k+1,j) -g_H3(i,k,j)) +g_mu(i,j)*(H3(i,k+1,j) -H3(i,k,j))
Tmpv1 =mu(i,j)*(H3(i,k+1,j) -H3(i,k,j))
g_Tmpv2 =Tmpv1*g_rdzw(i,k,j) +g_Tmpv1*rdzw(i,k,j)
Tmpv2 =Tmpv1*rdzw(i,k,j)
g_tendency(i,k,j) =g_tendency(i,k,j) -g_Tmpv2
tendency(i,k,j) =tendency(i,k,j) -Tmpv2
ENDDO
ENDDO
ENDDO
IF(doing_tke) THEN
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_tendency(i,k,j) =g_tmptendf(i,k,j) +2.*(g_tendency(i,k,j) -g_tmptendf(i,k,j))
tendency(i,k,j) =tmptendf(i,k,j) +2.*(tendency(i,k,j) -tmptendf(i,k,j))
ENDDO
ENDDO
ENDDO
ENDIF
END SUBROUTINE g_vertical_diffusion_s
SUBROUTINE g_cal_titau_11_22_33(config_flags,titau,g_titau,mu,g_mu,tke, &
g_tke,xkx,g_xkx,defor,g_defor,mtau,g_mtau,is_ext,ie_ext,js_ext,je_ext, &
ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
IMPLICIT NONE
REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2
TYPE(grid_config_rec_type) :: config_flags
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
INTEGER :: is_ext,ie_ext,js_ext,je_ext
REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: titau,g_titau
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor,g_defor,xkx,g_xkx,tke,g_tke
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: mtau,g_mtau
REAL,DIMENSION(ims:ime,jms:jme) :: mu,g_mu
INTEGER :: i,j,k,ktf,i_start,i_end,j_start,j_end
ktf =min(kte,kde-1)
i_start =its
i_end =ite
j_start =jts
j_end =jte
IF( config_flags%open_xs .OR. config_flags%specified .OR. &
config_flags%nested) i_start =max(ids+1,its)
IF( config_flags%open_xe .OR. config_flags%specified .OR. &
config_flags%nested) i_end =min(ide-1,ite)
IF( config_flags%open_ys .OR. config_flags%specified .OR. &
config_flags%nested) j_start =max(jds+1,jts)
IF( config_flags%open_ye .OR. config_flags%specified .OR. &
config_flags%nested) j_end =min(jde-1,jte)
IF( config_flags%periodic_x ) i_start =its
IF( config_flags%periodic_x ) i_end =ite
i_start =i_start-is_ext
i_end =i_end+ie_ext
j_start =j_start-js_ext
j_end =j_end+je_ext
IF( config_flags%sfs_opt .GT. 0 ) THEN
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_Tmpv1 =mu(i,j)*g_mtau(i,k,j) +g_mu(i,j)*mtau(i,k,j)
Tmpv1 =mu(i,j)*mtau(i,k,j)
g_titau(i,k,j) =g_Tmpv1
titau(i,k,j) =Tmpv1
ENDDO
ENDDO
ENDDO
ELSE
IF( config_flags%m_opt .EQ. 1 ) THEN
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_Tmpv1 =-mu(i,j)*g_xkx(i,k,j) -g_mu(i,j)*xkx(i,k,j)
Tmpv1 =-mu(i,j)*xkx(i,k,j)
g_Tmpv2 =Tmpv1*g_defor(i,k,j) +g_Tmpv1*defor(i,k,j)
Tmpv2 =Tmpv1*defor(i,k,j)
g_titau(i,k,j) =g_Tmpv2
titau(i,k,j) =Tmpv2
g_Tmpv1 =-xkx(i,k,j)*g_defor(i,k,j) -g_xkx(i,k,j)*defor(i,k,j)
Tmpv1 =-xkx(i,k,j)*defor(i,k,j)
g_mtau(i,k,j) =g_Tmpv1
mtau(i,k,j) =Tmpv1
ENDDO
ENDDO
ENDDO
ELSE
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_Tmpv1 =-mu(i,j)*g_xkx(i,k,j) -g_mu(i,j)*xkx(i,k,j)
Tmpv1 =-mu(i,j)*xkx(i,k,j)
g_Tmpv2 =Tmpv1*g_defor(i,k,j) +g_Tmpv1*defor(i,k,j)
Tmpv2 =Tmpv1*defor(i,k,j)
g_titau(i,k,j) =g_Tmpv2
titau(i,k,j) =Tmpv2
ENDDO
ENDDO
ENDDO
ENDIF
ENDIF
END SUBROUTINE g_cal_titau_11_22_33
SUBROUTINE g_cal_titau_12_21(config_flags,titau,g_titau,mu,g_mu,xkx, &
g_xkx,defor,g_defor,mtau,g_mtau,is_ext,ie_ext,js_ext,je_ext,ids,ide,jds,jde, &
kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
IMPLICIT NONE
REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2
TYPE(grid_config_rec_type) :: config_flags
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
INTEGER :: is_ext,ie_ext,js_ext,je_ext
REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: titau,g_titau
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor,g_defor,xkx,g_xkx
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: mtau,g_mtau
REAL,DIMENSION(ims:ime,jms:jme) :: mu,g_mu
INTEGER :: i,j,k,ktf,i_start,i_end,j_start,j_end
REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: xkxavg,g_xkxavg
REAL,DIMENSION(its-1:ite+1,jts-1:jte+1) :: muavg,g_muavg
ktf =min(kte,kde-1)
i_start =its
i_end =ite
j_start =jts
j_end =jte
IF( config_flags%open_xs .OR. config_flags%specified .OR. &
config_flags%nested ) i_start =max(ids+1,its)
IF( config_flags%open_xe .OR. config_flags%specified .OR. &
config_flags%nested ) i_end =min(ide-1,ite)
IF( config_flags%open_ys .OR. config_flags%specified .OR. &
config_flags%nested ) j_start =max(jds+1,jts)
IF( config_flags%open_ye .OR. config_flags%specified .OR. &
config_flags%nested ) j_end =min(jde-1,jte)
IF( config_flags%periodic_x ) i_start =its
IF( config_flags%periodic_x ) i_end =ite
i_start =i_start-is_ext
i_end =i_end+ie_ext
j_start =j_start-js_ext
j_end =j_end+je_ext
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_xkxavg(i,k,j) =0.25*(g_xkx(i-1,k,j) +g_xkx(i,k,j) +g_xkx(i-1,k,j-1) &
+g_xkx(i,k,j-1))
xkxavg(i,k,j) =0.25*(xkx(i-1,k,j) +xkx(i,k,j) +xkx(i-1,k,j-1) +xkx(i,k,j-1))
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO i =i_start,i_end
g_muavg(i,j) =0.25*(g_mu(i-1,j) +g_mu(i,j) +g_mu(i-1,j-1) +g_mu(i,j-1))
muavg(i,j) =0.25*(mu(i-1,j) +mu(i,j) +mu(i-1,j-1) +mu(i,j-1))
ENDDO
ENDDO
IF( config_flags%sfs_opt .GT. 0 ) THEN
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_Tmpv1 =muavg(i,j)*g_mtau(i,k,j) +g_muavg(i,j)*mtau(i,k,j)
Tmpv1 =muavg(i,j)*mtau(i,k,j)
g_titau(i,k,j) =g_Tmpv1
titau(i,k,j) =Tmpv1
ENDDO
ENDDO
ENDDO
ELSE
IF( config_flags%m_opt .EQ. 1 ) THEN
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_Tmpv1 =-muavg(i,j)*g_xkxavg(i,k,j) -g_muavg(i,j)*xkxavg(i,k,j)
Tmpv1 =-muavg(i,j)*xkxavg(i,k,j)
g_Tmpv2 =Tmpv1*g_defor(i,k,j) +g_Tmpv1*defor(i,k,j)
Tmpv2 =Tmpv1*defor(i,k,j)
g_titau(i,k,j) =g_Tmpv2
titau(i,k,j) =Tmpv2
g_Tmpv1 =-xkxavg(i,k,j)*g_defor(i,k,j) -g_xkxavg(i,k,j)*defor(i,k,j)
Tmpv1 =-xkxavg(i,k,j)*defor(i,k,j)
g_mtau(i,k,j) =g_Tmpv1
mtau(i,k,j) =Tmpv1
ENDDO
ENDDO
ENDDO
ELSE
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_Tmpv1 =-muavg(i,j)*g_xkxavg(i,k,j) -g_muavg(i,j)*xkxavg(i,k,j)
Tmpv1 =-muavg(i,j)*xkxavg(i,k,j)
g_Tmpv2 =Tmpv1*g_defor(i,k,j) +g_Tmpv1*defor(i,k,j)
Tmpv2 =Tmpv1*defor(i,k,j)
g_titau(i,k,j) =g_Tmpv2
titau(i,k,j) =Tmpv2
ENDDO
ENDDO
ENDDO
ENDIF
ENDIF
END SUBROUTINE g_cal_titau_12_21
SUBROUTINE g_cal_titau_13_31(config_flags,titau,g_titau,defor,g_defor,mtau, &
g_mtau,mu,g_mu,xkx,g_xkx,fnm,fnp,is_ext,ie_ext,js_ext,je_ext,ids,ide,jds, &
jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
IMPLICIT NONE
REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2
TYPE(grid_config_rec_type) :: config_flags
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
INTEGER :: is_ext,ie_ext,js_ext,je_ext
REAL,DIMENSION(kms:kme) :: fnm,fnp
REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: titau,g_titau
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor,g_defor,xkx,g_xkx
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: mtau,g_mtau
REAL,DIMENSION(ims:ime,jms:jme) :: mu,g_mu
INTEGER :: i,j,k,ktf,i_start,i_end,j_start,j_end
REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: xkxavg,g_xkxavg
REAL,DIMENSION(its-1:ite+1,jts-1:jte+1) :: muavg,g_muavg
ktf =min(kte,kde-1)
i_start =its
i_end =ite
j_start =jts
j_end =min(jte,jde-1)
IF( config_flags%open_xs .OR. config_flags%specified .OR. &
config_flags%nested) i_start =max(ids+1,its)
IF( config_flags%open_xe .OR. config_flags%specified .OR. &
config_flags%nested) i_end =min(ide-1,ite)
IF( config_flags%open_ys .OR. config_flags%specified .OR. &
config_flags%nested) j_start =max(jds+1,jts)
IF( config_flags%open_ye .OR. config_flags%specified .OR. &
config_flags%nested) j_end =min(jde-2,jte)
IF( config_flags%periodic_x ) i_start =its
IF( config_flags%periodic_x ) i_end =ite
i_start =i_start-is_ext
i_end =i_end+ie_ext
j_start =j_start-js_ext
j_end =j_end+je_ext
DO j =j_start,j_end
DO k =kts+1,ktf
DO i =i_start,i_end
g_xkxavg(i,k,j) =0.5*(fnm(k)*(g_xkx(i,k,j) +g_xkx(i-1,k,j)) +fnp(k) &
*(g_xkx(i,k-1,j) +g_xkx(i-1,k-1,j)))
xkxavg(i,k,j) =0.5*(fnm(k)*(xkx(i,k,j) +xkx(i-1,k,j)) +fnp(k)*(xkx(i,k-1,j) &
+xkx(i-1,k-1,j)))
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO i =i_start,i_end
g_muavg(i,j) =0.5*(g_mu(i,j) +g_mu(i-1,j))
muavg(i,j) =0.5*(mu(i,j) +mu(i-1,j))
ENDDO
ENDDO
IF( config_flags%sfs_opt .GT. 0 ) THEN
DO j =j_start,j_end
DO k =kts+1,ktf
DO i =i_start,i_end
g_Tmpv1 =muavg(i,j)*g_mtau(i,k,j) +g_muavg(i,j)*mtau(i,k,j)
Tmpv1 =muavg(i,j)*mtau(i,k,j)
g_titau(i,k,j) =g_Tmpv1
titau(i,k,j) =Tmpv1
ENDDO
ENDDO
ENDDO
ELSE
IF( config_flags%m_opt .EQ. 1 ) THEN
DO j =j_start,j_end
DO k =kts+1,ktf
DO i =i_start,i_end
g_Tmpv1 =-muavg(i,j)*g_xkxavg(i,k,j) -g_muavg(i,j)*xkxavg(i,k,j)
Tmpv1 =-muavg(i,j)*xkxavg(i,k,j)
g_Tmpv2 =Tmpv1*g_defor(i,k,j) +g_Tmpv1*defor(i,k,j)
Tmpv2 =Tmpv1*defor(i,k,j)
g_titau(i,k,j) =g_Tmpv2
titau(i,k,j) =Tmpv2
g_Tmpv1 =-xkxavg(i,k,j)*g_defor(i,k,j) -g_xkxavg(i,k,j)*defor(i,k,j)
Tmpv1 =-xkxavg(i,k,j)*defor(i,k,j)
g_mtau(i,k,j) =g_Tmpv1
mtau(i,k,j) =Tmpv1
ENDDO
ENDDO
ENDDO
ELSE
DO j =j_start,j_end
DO k =kts+1,ktf
DO i =i_start,i_end
g_Tmpv1 =-muavg(i,j)*g_xkxavg(i,k,j) -g_muavg(i,j)*xkxavg(i,k,j)
Tmpv1 =-muavg(i,j)*xkxavg(i,k,j)
g_Tmpv2 =Tmpv1*g_defor(i,k,j) +g_Tmpv1*defor(i,k,j)
Tmpv2 =Tmpv1*defor(i,k,j)
g_titau(i,k,j) =g_Tmpv2
titau(i,k,j) =Tmpv2
ENDDO
ENDDO
ENDDO
ENDIF
ENDIF
DO j =j_start,j_end
DO i =i_start,i_end
g_titau(i,kts,j) =0.0
titau(i,kts,j) =0.0
g_titau(i,ktf+1,j) =0.0
titau(i,ktf+1,j) =0.0
ENDDO
ENDDO
END SUBROUTINE g_cal_titau_13_31
SUBROUTINE g_cal_titau_23_32(config_flags,titau,g_titau,defor,g_defor,mtau, &
g_mtau,mu,g_mu,xkx,g_xkx,fnm,fnp,is_ext,ie_ext,js_ext,je_ext,ids,ide,jds, &
jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
IMPLICIT NONE
REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2
TYPE(grid_config_rec_type) :: config_flags
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
INTEGER :: is_ext,ie_ext,js_ext,je_ext
REAL,DIMENSION(kms:kme) :: fnm,fnp
REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: titau,g_titau
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor,g_defor,xkx,g_xkx
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: mtau,g_mtau
REAL,DIMENSION(ims:ime,jms:jme) :: mu,g_mu
INTEGER :: i,j,k,ktf,i_start,i_end,j_start,j_end
REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: xkxavg,g_xkxavg
REAL,DIMENSION(its-1:ite+1,jts-1:jte+1) :: muavg,g_muavg
ktf =min(kte,kde-1)
i_start =its
i_end =min(ite,ide-1)
j_start =jts
j_end =jte
IF( config_flags%open_xs .OR. config_flags%specified .OR. &
config_flags%nested) i_start =max(ids+1,its)
IF( config_flags%open_xe .OR. config_flags%specified .OR. &
config_flags%nested) i_end =min(ide-2,ite)
IF( config_flags%open_ys .OR. config_flags%specified .OR. &
config_flags%nested) j_start =max(jds+1,jts)
IF( config_flags%open_ye .OR. config_flags%specified .OR. &
config_flags%nested) j_end =min(jde-1,jte)
IF( config_flags%periodic_x ) i_start =its
IF( config_flags%periodic_x ) i_end =min(ite,ide-1)
i_start =i_start-is_ext
i_end =i_end+ie_ext
j_start =j_start-js_ext
j_end =j_end+je_ext
DO j =j_start,j_end
DO k =kts+1,ktf
DO i =i_start,i_end
g_xkxavg(i,k,j) =0.5*(fnm(k)*(g_xkx(i,k,j) +g_xkx(i,k,j-1)) +fnp(k) &
*(g_xkx(i,k-1,j) +g_xkx(i,k-1,j-1)))
xkxavg(i,k,j) =0.5*(fnm(k)*(xkx(i,k,j) +xkx(i,k,j-1)) +fnp(k)*(xkx(i,k-1,j) &
+xkx(i,k-1,j-1)))
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO i =i_start,i_end
g_muavg(i,j) =0.5*(g_mu(i,j) +g_mu(i,j-1))
muavg(i,j) =0.5*(mu(i,j) +mu(i,j-1))
ENDDO
ENDDO
IF( config_flags%sfs_opt .EQ. 1 ) THEN
DO j =j_start,j_end
DO k =kts+1,ktf
DO i =i_start,i_end
g_Tmpv1 =muavg(i,j)*g_mtau(i,k,j) +g_muavg(i,j)*mtau(i,k,j)
Tmpv1 =muavg(i,j)*mtau(i,k,j)
g_titau(i,k,j) =g_Tmpv1
titau(i,k,j) =Tmpv1
ENDDO
ENDDO
ENDDO
ELSE
IF( config_flags%m_opt .EQ. 1 ) THEN
DO j =j_start,j_end
DO k =kts+1,ktf
DO i =i_start,i_end
g_Tmpv1 =-muavg(i,j)*g_xkxavg(i,k,j) -g_muavg(i,j)*xkxavg(i,k,j)
Tmpv1 =-muavg(i,j)*xkxavg(i,k,j)
g_Tmpv2 =Tmpv1*g_defor(i,k,j) +g_Tmpv1*defor(i,k,j)
Tmpv2 =Tmpv1*defor(i,k,j)
g_titau(i,k,j) =g_Tmpv2
titau(i,k,j) =Tmpv2
g_Tmpv1 =-xkxavg(i,k,j)*g_defor(i,k,j) -g_xkxavg(i,k,j)*defor(i,k,j)
Tmpv1 =-xkxavg(i,k,j)*defor(i,k,j)
g_mtau(i,k,j) =g_Tmpv1
mtau(i,k,j) =Tmpv1
ENDDO
ENDDO
ENDDO
ELSE
DO j =j_start,j_end
DO k =kts+1,ktf
DO i =i_start,i_end
g_Tmpv1 =-muavg(i,j)*g_xkxavg(i,k,j) -g_muavg(i,j)*xkxavg(i,k,j)
Tmpv1 =-muavg(i,j)*xkxavg(i,k,j)
g_Tmpv2 =Tmpv1*g_defor(i,k,j) +g_Tmpv1*defor(i,k,j)
Tmpv2 =Tmpv1*defor(i,k,j)
g_titau(i,k,j) =g_Tmpv2
titau(i,k,j) =Tmpv2
ENDDO
ENDDO
ENDDO
ENDIF
ENDIF
DO j =j_start,j_end
DO i =i_start,i_end
g_titau(i,kts,j) =0.0
titau(i,kts,j) =0.0
g_titau(i,ktf+1,j) =0.0
titau(i,ktf+1,j) =0.0
ENDDO
ENDDO
END SUBROUTINE g_cal_titau_23_32
END MODULE g_module_diffusion_em
REAL Function g_Sqrt(g_x,x)
REAL g_x,x
IF(x.GT.0.0) THEN
g_Sqrt =0.5*g_x/sqrt(x)
ELSE
! Revised by Ning Pan, 2010-08-10
! Print*,''
! Print*,'g_Sqrt is incorrectly evaluated by 0!'
! Print*,'Aborted from compute_diff_metrics'
! g_Sqrt =0.0
g_Sqrt =0.5*g_x/(sqrt(x)+1.e-6)
END IF
RETURN
END