! ====================================================================================== ! 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