! WRF:MODEL_LAYER:PHYSICS MODULE module_diffusion_em USE module_bc, only: set_physical_bc3d, set_physical_bc2d ! XZ USE module_state_description, only: p_m23, p_m13, p_m22, p_m33, p_r23, p_r13, p_r12, p_m12, p_m11, & P_QNS, P_QNR, P_QNG, P_QT, P_QNH, P_QVOLG ! XZ USE 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 cal_deform_and_div( config_flags, u, v, w, div, & defor11, defor22, defor33, & defor12, defor13, defor23, & nba_rij, n_nba_rij, & u_base, v_base, msfux, msfuy, & msfvx, msfvy, msftx, msfty, & rdx, rdy, dn, dnw, rdz, rdzw, & fnm, fnp, cf1, cf2, cf3, zx, zy, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) ! History: Sep 2003 Changes by Jason Knievel and George Bryan, NCAR ! Oct 2001 Converted to mass core by Bill Skamarock, NCAR ! ... ... ! Purpose: This routine calculates deformation and 3-d divergence. ! References: Klemp and Wilhelmson (JAS 1978) ! Chen and Dudhia (NCAR WRF physics report 2000) !----------------------------------------------------------------------- ! Comments 10-MAR-05 ! Equations 13a-f, Chen and Dudhia 2000, Appendix A: ! Eqn 13a: D11=defor11= 2m^2 * (partial du^/dX + partial dpsi/dx * partial du^/dpsi) ! Eqn 13b: D22=defor22= 2m^2 * (partial dv^/dY + partial dpsi/dy * partial dv^/dpsi) ! Eqn 13c: D33=defor33= 2 * partial dw/dz [SIMPLER FORM] ! Eqn 13d: D12=defor12= m^2 * (partial dv^/dX + partial du^/dY + ! partial dpsi/dx * partial dv^/dpsi + ! partial dpsi/dy * partial du^/dpsi) ! Eqn 13e: D13=defor13= m^2 * (partial dw^/dX + partial dpsi/dx * partial dw^/dpsi) ! + partial du/dz [SIMPLER FORM] ! Eqn 13f: D23=defor23= m^2 * (partial dw^/dY + partial dpsi/dy * partial dw^/dpsi) ! + partial dv/dz [SIMPLER FORM] !----------------------------------------------------------------------- ! Begin declarations. 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 ) & :: rdx, rdy, cf1, cf2, cf3 REAL, DIMENSION( kms:kme ), INTENT( IN ) & :: fnm, fnp, dn, dnw, u_base, v_base REAL, DIMENSION( ims:ime , jms:jme ), INTENT( IN ) & :: msfux, msfuy, msfvx, msfvy, msftx, msfty REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN ) & :: u, v, w, zx, zy, rdz, rdzw REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) & :: defor11, defor22, defor33, defor12, defor13, defor23, div INTEGER, INTENT( IN ) :: n_nba_rij REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_rij), INTENT(INOUT) & :: nba_rij ! Local variables. INTEGER & :: i, j, k, ktf, ktes1, ktes2, i_start, i_end, j_start, j_end REAL & :: tmp, tmpzx, tmpzy, tmpzeta_z, cft1, cft2 REAL, DIMENSION( its:ite, jts:jte ) & :: mm, zzavg, zeta_zd12 REAL, DIMENSION( its-2:ite+2, kts:kte, jts-2:jte+2 ) & :: tmp1, hat, hatavg ! End declarations. !----------------------------------------------------------------------- ! Comments 10-MAR-2005 ! Treat all differentials as 'div-style' [or 'curl-style'], ! i.e., du/dX becomes (in map coordinate space) mx*my * d(u/my)/dx, ! NB - all equations referred to here are from Chen and Dudhia 2002, from the ! WRF physics documents web pages: ! http://www.mmm.ucar.edu/wrf/users/docs/wrf-doc-physics.pdf !======================================================================= ! In the following section, calculate 3-d divergence and the first three ! (defor11, defor22, defor33) of six deformation terms. ktes1 = kte-1 ktes2 = kte-2 cft2 = - 0.5 * dnw(ktes1) / dn(ktes1) 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 ) ! Square the map scale factor. DO j = j_start, j_end DO i = i_start, i_end mm(i,j) = msftx(i,j) * msfty(i,j) END DO END DO !----------------------------------------------------------------------- ! Calculate du/dx. ! Apply a coordinate transformation to zonal velocity, u. DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end+1 hat(i,k,j) = u(i,k,j) / msfuy(i,j) END DO END DO END DO ! Average in x and z. DO j=j_start,j_end DO k=kts+1,ktf DO i=i_start,i_end 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) ) ) END DO END DO END DO ! Extrapolate to top and bottom of domain (to w levels). DO j = j_start, j_end DO i = i_start, i_end 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) ) hatavg(i,kte,j) = 0.5 * ( & cft1 * ( hat(i,ktes1,j) + hat(i+1,ktes1,j) ) + & cft2 * ( hat(i,ktes2,j) + hat(i+1,ktes2,j) ) ) END DO END DO ! Comments 10-MAR-05 ! Eqn 13a: D11=defor11= 2m^2 * (partial du^/dX + partial dpsi/dx * partial du^/dpsi) ! Below, D11 is set = 2*tmp1 ! => tmp1 = m^2 * (partial du^/dX + partial dpsi/dx * partial du^/dpsi) ! tmpzx = averaged value of dpsi/dx (=zx) DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end tmpzx = 0.25 * ( & zx(i,k ,j) + zx(i+1,k ,j) + & zx(i,k+1,j) + zx(i+1,k+1,j) ) tmp1(i,k,j) = ( hatavg(i,k+1,j) - hatavg(i,k,j) ) *tmpzx * rdzw(i,k,j) ! tmp1 to here = partial dpsi/dx * partial du^/dpsi: END DO END DO END DO DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end tmp1(i,k,j) = mm(i,j) * ( rdx * ( hat(i+1,k,j) - hat(i,k,j) ) - & tmp1(i,k,j)) END DO END DO END DO ! End calculation of du/dx. !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! Calculate defor11 (2*du/dx). ! Comments 10-MAR-05 ! Eqn 13a: D11=defor11= 2 m^2 * (partial du^/dX + partial dpsi/dx * partial du^/dpsi) ! = 2*tmp1 DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end defor11(i,k,j) = 2.0 * tmp1(i,k,j) END DO END DO END DO ! End calculation of defor11. !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! Calculate zonal divergence (du/dx) and add it to the divergence array. DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end div(i,k,j) = tmp1(i,k,j) END DO END DO END DO ! End calculation of zonal divergence. !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! Calculate dv/dy. ! Apply a coordinate transformation to meridional velocity, v. DO j = j_start, j_end+1 DO k = kts, ktf DO i = i_start, i_end ! Because msfvx at the poles will be undefined (1./0.), we will have ! trouble. But we are OK since v at the poles is 0., and that takes ! precedence in this case. IF ((config_flags%polar) .AND. ((j == jds) .OR. (j == jde))) THEN hat(i,k,j) = 0. ELSE ! normal code hat(i,k,j) = v(i,k,j) / msfvx(i,j) ENDIF END DO END DO END DO ! Account for the slope in y of eta surfaces. DO j=j_start,j_end DO k=kts+1,ktf DO i=i_start,i_end 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) ) ) END DO END DO END DO ! Extrapolate to top and bottom of domain (to w levels). DO j = j_start, j_end DO i = i_start, i_end 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) ) hatavg(i,kte,j) = 0.5 * ( & cft1 * ( hat(i,ktes1,j) + hat(i,ktes1,j+1) ) + & cft2 * ( hat(i,ktes2,j) + hat(i,ktes2,j+1) ) ) END DO END DO ! Comments 10-MAR-05 ! Eqn 13b: D22=defor22= 2m^2 * (partial dv^/dY + partial dpsi/dy * partial dv^/dpsi) ! Below, D22 is set = 2*tmp1 ! => tmp1 = m^2 * (partial dv^/dY + partial dpsi/dy * partial dv^/dpsi) ! tmpzy = averaged value of dpsi/dy (=zy) DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end tmpzy = 0.25 * ( & zy(i,k ,j) + zy(i,k ,j+1) + & zy(i,k+1,j) + zy(i,k+1,j+1) ) tmp1(i,k,j) = ( hatavg(i,k+1,j) - hatavg(i,k,j) ) * tmpzy * rdzw(i,k,j) ! tmp1 to here = partial dpsi/dy * partial dv^/dpsi: END DO END DO END DO DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end tmp1(i,k,j) = mm(i,j) * ( & rdy * ( hat(i,k,j+1) - hat(i,k,j) ) - tmp1(i,k,j) ) END DO END DO END DO ! End calculation of dv/dy. !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! Calculate defor22 (2*dv/dy). ! Comments 10-MAR-05 ! Eqn 13b: D22=defor22= 2 m^2 * (partial dv^/dY + partial dpsi/dy * partial dv^/dpsi) ! = 2*tmp1 DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end defor22(i,k,j) = 2.0 * tmp1(i,k,j) END DO END DO END DO ! End calculation of defor22. !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! Calculate meridional divergence (dv/dy) and add it to the divergence ! array. DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end div(i,k,j) = div(i,k,j) + tmp1(i,k,j) END DO END DO END DO ! End calculation of meridional divergence. !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! Comments 10-MAR-05 ! Eqn 13c: D33=defor33= 2 * partial dw/dz ! Below, D33 is set = 2*tmp1 ! => tmp1 = partial dw/dz ! Calculate dw/dz. DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end tmp1(i,k,j) = ( w(i,k+1,j) - w(i,k,j) ) * rdzw(i,k,j) END DO END DO END DO ! End calculation of dw/dz. !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! Calculate defor33 (2*dw/dz). DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end defor33(i,k,j) = 2.0 * tmp1(i,k,j) END DO END DO END DO ! End calculation of defor33. !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! Calculate vertical divergence (dw/dz) and add it to the divergence ! array. DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end div(i,k,j) = div(i,k,j) + tmp1(i,k,j) END DO END DO END DO ! End calculation of vertical divergence. !----------------------------------------------------------------------- ! Three-dimensional divergence is now finished and values are in array ! "div." Also, the first three (defor11, defor22, defor33) of six ! deformation terms are now calculated at pressure points. !======================================================================= ! Comments 10-MAR-2005 ! Treat all differentials as 'div-style' [or 'curl-style'], ! i.e., du/dY becomes (in map coordinate space) mx*my * d(u/mx)/dy, ! dv/dX becomes (in map coordinate space) mx*my * d(v/my)/dx, ! (see e.g. Haltiner and Williams p. 441) !======================================================================= ! Calculate the final three deformations (defor12, defor13, defor23) at ! vorticity points. 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 !----------------------------------------------------------------------- ! Calculate du/dy. ! First, calculate an average mapscale factor. ! Comments 10-MAR-05 ! du/dy => need u map scale factor in x (which is defined at u points) ! averaged over j and j-1 ! dv/dx => need v map scale factor in y (which is defined at v points) ! averaged over i and i-1 DO j = j_start, j_end DO i = i_start, i_end mm(i,j) = 0.25 * ( msfux(i,j-1) + msfux(i,j) ) * ( msfvy(i-1,j) + msfvy(i,j) ) END DO END DO ! Apply a coordinate transformation to zonal velocity, u. DO j =j_start-1, j_end DO k =kts, ktf DO i =i_start, i_end ! Fixes to set_physical_bc2/3d for polar boundary conditions ! remove issues with loop over j hat(i,k,j) = u(i,k,j) / msfux(i,j) END DO END DO END DO ! Average in y and z. DO j=j_start,j_end DO k=kts+1,ktf DO i=i_start,i_end 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) ) ) END DO END DO END DO ! Extrapolate to top and bottom of domain (to w levels). DO j = j_start, j_end DO i = i_start, i_end 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 ) ) hatavg(i,kte,j) = 0.5 * ( & cft1 * ( hat(i,ktes1,j-1) + hat(i,ktes1,j) ) + & cft2 * ( hat(i,ktes2,j-1) + hat(i,ktes2,j) ) ) END DO END DO ! tmpzy = averaged value of dpsi/dy (=zy) on vorticity grid ! tmp1 = partial dpsi/dy * partial du^/dpsi DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end tmpzy = 0.25 * ( & zy(i-1,k ,j) + zy(i,k ,j) + & zy(i-1,k+1,j) + zy(i,k+1,j) ) tmp1(i,k,j) = ( hatavg(i,k+1,j) - hatavg(i,k,j) ) * & 0.25 * tmpzy * ( rdzw(i,k,j) + rdzw(i-1,k,j) + & rdzw(i-1,k,j-1) + rdzw(i,k,j-1) ) END DO END DO END DO ! End calculation of du/dy. !---------------------------------------------------------------------- !----------------------------------------------------------------------- ! Add the first term to defor12 (du/dy+dv/dx) at vorticity points. ! Comments 10-MAR-05 ! Eqn 13d: D12=defor12= m^2 * (partial dv^/dX + partial du^/dY + ! partial dpsi/dx * partial dv^/dpsi + ! partial dpsi/dy * partial du^/dpsi) ! Here deal with m^2 * (partial du^/dY + partial dpsi/dy * partial du^/dpsi) ! Still need to add v^ terms: ! m^2 * (partial dv^/dX + partial dpsi/dx * partial dv^/dpsi) DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end defor12(i,k,j) = mm(i,j) * ( & rdy * ( hat(i,k,j) - hat(i,k,j-1) ) - tmp1(i,k,j) ) END DO END DO END DO ! End addition of the first term to defor12. !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! Calculate dv/dx. ! Apply a coordinate transformation to meridional velocity, v. DO j = j_start, j_end DO k = kts, ktf DO i = i_start-1, i_end hat(i,k,j) = v(i,k,j) / msfvy(i,j) END DO END DO END DO ! Account for the slope in x of eta surfaces. DO j = j_start, j_end DO k = kts+1, ktf DO i = i_start, i_end 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) ) ) END DO END DO END DO ! Extrapolate to top and bottom of domain (to w levels). DO j = j_start, j_end DO i = i_start, i_end 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) ) hatavg(i,kte,j) = 0.5 * ( & cft1 * ( hat(i,ktes1,j) + hat(i-1,ktes1,j) ) + & cft2 * ( hat(i,ktes2,j) + hat(i-1,ktes2,j) ) ) END DO END DO ! Fixes to set_physical_bc2/3d have made any check for polar B.C.'s ! unnecessary in this place. zx, rdzw, and hatavg are all defined ! in places they need to be and the values at the poles are replications ! of the values one grid point in, so the averaging over j and j-1 works ! to act as just using the value at j or j-1 (with out extra code). ! ! tmpzx = averaged value of dpsi/dx (=zx) on vorticity grid ! tmp1 = partial dpsi/dx * partial dv^/dpsi DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end tmpzx = 0.25 * ( & zx(i,k ,j-1) + zx(i,k ,j) + & zx(i,k+1,j-1) + zx(i,k+1,j) ) tmp1(i,k,j) = ( hatavg(i,k+1,j) - hatavg(i,k,j) ) * & 0.25 * tmpzx * ( rdzw(i,k,j) + rdzw(i,k,j-1) + & rdzw(i-1,k,j-1) + rdzw(i-1,k,j) ) END DO END DO END DO ! End calculation of dv/dx. !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! Add the second term to defor12 (du/dy+dv/dx) at vorticity points. ! Comments 10-MAR-05 ! Eqn 13d: D12=defor12= m^2 * (partial dv^/dX + partial du^/dY + ! partial dpsi/dx * partial dv^/dpsi + ! partial dpsi/dy * partial du^/dpsi) ! Here adding v^ terms: ! m^2 * (partial dv^/dX + partial dpsi/dx * partial dv^/dpsi) IF ( config_flags%sfs_opt .GT. 0 ) THEN ! NBA-- !JDM____________________________________________________________________ ! ! s12 = du/dy + dv/dx ! = (du/dy - dz/dy*du/dz) + (dv/dx - dz/dx*dv/dz) ! ______defor12______ ___tmp1___ ! ! r12 = du/dy - dv/dx ! = (du/dy - dz/dy*du/dz) - (dv/dx - dz/dx*dv/dz) ! ______defor12______ ___tmp1___ !_______________________________________________________________________ DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end nba_rij(i,k,j,P_r12) = defor12(i,k,j) - & mm(i,j) * ( & rdx * ( hat(i,k,j) - hat(i-1,k,j) ) - tmp1(i,k,j) ) defor12(i,k,j) = defor12(i,k,j) + & mm(i,j) * ( & rdx * ( hat(i,k,j) - hat(i-1,k,j) ) - tmp1(i,k,j) ) END DO END DO END DO ! End addition of the second term to defor12. !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! Update the boundary for defor12 (might need to change later). IF ( .NOT. config_flags%periodic_x .AND. i_start .EQ. ids+1 ) THEN DO j = jts, jte DO k = kts, kte defor12(ids,k,j) = defor12(ids+1,k,j) nba_rij(ids,k,j,P_r12) = nba_rij(ids+1,k,j,P_r12) END DO END DO END IF IF ( .NOT. config_flags%periodic_y .AND. j_start .EQ. jds+1) THEN DO k = kts, kte DO i = its, ite defor12(i,k,jds) = defor12(i,k,jds+1) nba_rij(i,k,jds,P_r12) = nba_rij(i,k,jds+1,P_r12) END DO END DO END IF IF ( .NOT. config_flags%periodic_x .AND. i_end .EQ. ide-1) THEN DO j = jts, jte DO k = kts, kte defor12(ide,k,j) = defor12(ide-1,k,j) nba_rij(ide,k,j,P_r12) = nba_rij(ide-1,k,j,P_r12) END DO END DO END IF IF ( .NOT. config_flags%periodic_y .AND. j_end .EQ. jde-1) THEN DO k = kts, kte DO i = its, ite defor12(i,k,jde) = defor12(i,k,jde-1) nba_rij(i,k,jde,P_r12) = nba_rij(i,k,jde-1,P_r12) END DO END DO END IF ELSE ! NOT NBA-------------------------------------------------------- DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end defor12(i,k,j) = defor12(i,k,j) + & mm(i,j) * ( & rdx * ( hat(i,k,j) - hat(i-1,k,j) ) - tmp1(i,k,j) ) END DO END DO END DO ! End addition of the second term to defor12. !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! Update the boundary for defor12 (might need to change later). IF ( .NOT. config_flags%periodic_x .AND. i_start .EQ. ids+1 ) THEN DO j = jts, jte DO k = kts, kte defor12(ids,k,j) = defor12(ids+1,k,j) END DO END DO END IF IF ( .NOT. config_flags%periodic_y .AND. j_start .EQ. jds+1) THEN DO k = kts, kte DO i = its, ite defor12(i,k,jds) = defor12(i,k,jds+1) END DO END DO END IF IF ( .NOT. config_flags%periodic_x .AND. i_end .EQ. ide-1) THEN DO j = jts, jte DO k = kts, kte defor12(ide,k,j) = defor12(ide-1,k,j) END DO END DO END IF IF ( .NOT. config_flags%periodic_y .AND. j_end .EQ. jde-1) THEN DO k = kts, kte DO i = its, ite defor12(i,k,jde) = defor12(i,k,jde-1) END DO END DO END IF ENDIF ! NBA----------------------------------------------------------- ! End update of boundary for defor12. !----------------------------------------------------------------------- ! Comments 10-MAR-05 ! Further deformation terms not needed for 2-dimensional Smagorinsky diffusion, ! so those terms have not been dealt with yet. ! A "y" has simply been added to all map scale factors to allow the model to ! compile without errors. !----------------------------------------------------------------------- ! Calculate dw/dx. 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 ) ! Square the mapscale factor. DO j = jts, jte DO i = its, ite mm(i,j) = msfux(i,j) * msfuy(i,j) END DO END DO ! Apply a coordinate transformation to vertical velocity, w. This is for both ! defor13 and defor23. DO j = j_start, j_end DO k = kts, kte DO i = i_start, i_end hat(i,k,j) = w(i,k,j) / msfty(i,j) END DO END DO END DO i = i_start-1 DO j = j_start, MIN( jte, jde-1 ) DO k = kts, kte hat(i,k,j) = w(i,k,j) / msfty(i,j) END DO END DO j = j_start-1 DO k = kts, kte DO i = i_start, MIN( ite, ide-1 ) hat(i,k,j) = w(i,k,j) / msfty(i,j) END DO END DO ! QUESTION: What is this for? DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end 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) ) END DO END DO END DO ! Calculate dw/dx. DO j = j_start, j_end DO k = kts+1, ktf DO i = i_start, i_end tmp1(i,k,j) = ( hatavg(i,k,j) - hatavg(i,k-1,j) ) * zx(i,k,j) * & 0.5 * ( rdz(i,k,j) + rdz(i-1,k,j) ) END DO END DO END DO ! End calculation of dw/dx. !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! Add the first term (dw/dx) to defor13 (dw/dx+du/dz) at vorticity ! points. DO j = j_start, j_end DO k = kts+1, ktf DO i = i_start, i_end defor13(i,k,j) = mm(i,j) * ( & rdx * ( hat(i,k,j) - hat(i-1,k,j) ) - tmp1(i,k,j) ) END DO END DO END DO DO j = j_start, j_end DO i = i_start, i_end defor13(i,kts,j ) = 0.0 defor13(i,ktf+1,j) = 0.0 END DO END DO ! End addition of the first term to defor13. !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! Calculate du/dz. IF ( config_flags%mix_full_fields ) THEN DO j = j_start, j_end DO k = kts+1, ktf DO i = i_start, i_end tmp1(i,k,j) = ( u(i,k,j) - u(i,k-1,j) ) * & 0.5 * ( rdz(i,k,j) + rdz(i-1,k,j) ) END DO END DO END DO ELSE DO j = j_start, j_end DO k = kts+1, ktf DO i = i_start, i_end tmp1(i,k,j) = ( 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) ) END DO END DO END DO END IF !----------------------------------------------------------------------- ! Add the second term (du/dz) to defor13 (dw/dx+du/dz) at vorticity ! points. IF ( config_flags%sfs_opt .GT. 0 ) THEN ! NBA-- !JDM____________________________________________________________________ ! ! s13 = du/dz + dw/dx ! = du/dz + (dw/dx - dz/dx*dw/dz) ! = tmp1 + ______defor13______ ! ! r13 = du/dz - dw/dx ! = du/dz - (dw/dx - dz/dx*dw/dz) ! = tmp1 - ______defor13______ !_______________________________________________________________________ DO j = j_start, j_end DO k = kts+1, ktf DO i = i_start, i_end nba_rij(i,k,j,P_r13) = tmp1(i,k,j) - defor13(i,k,j) defor13(i,k,j) = defor13(i,k,j) + tmp1(i,k,j) END DO END DO END DO DO j = j_start, j_end !change for different surface B. C. DO i = i_start, i_end nba_rij(i,kts ,j,P_r13) = 0.0 nba_rij(i,ktf+1,j,P_r13) = 0.0 END DO END DO ELSE ! NOT NBA-------------------------------------------------------- DO j = j_start, j_end DO k = kts+1, ktf DO i = i_start, i_end defor13(i,k,j) = defor13(i,k,j) + tmp1(i,k,j) END DO END DO END DO ENDIF ! NBA----------------------------------------------------------- ! End addition of the second term to defor13. !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! Calculate dw/dy. 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 ) ! Square mapscale factor. DO j = jts, jte DO i = its, ite mm(i,j) = msfvx(i,j) * msfvy(i,j) END DO END DO ! Apply a coordinate transformation to vertical velocity, w. Added by CW 7/19/07 DO j = j_start, j_end DO k = kts, kte DO i = i_start, i_end hat(i,k,j) = w(i,k,j) / msftx(i,j) END DO END DO END DO i = i_start-1 DO j = j_start, MIN( jte, jde-1 ) DO k = kts, kte hat(i,k,j) = w(i,k,j) / msftx(i,j) END DO END DO j = j_start-1 DO k = kts, kte DO i = i_start, MIN( ite, ide-1 ) hat(i,k,j) = w(i,k,j) / msftx(i,j) END DO END DO ! QUESTION: What is this for? DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end 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) ) END DO END DO END DO ! Calculate dw/dy and store in tmp1. DO j = j_start, j_end DO k = kts+1, ktf DO i = i_start, i_end tmp1(i,k,j) = ( hatavg(i,k,j) - hatavg(i,k-1,j) ) * zy(i,k,j) * & 0.5 * ( rdz(i,k,j) + rdz(i,k,j-1) ) END DO END DO END DO ! End calculation of dw/dy. !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! Add the first term (dw/dy) to defor23 (dw/dy+dv/dz) at vorticity ! points. DO j = j_start, j_end DO k = kts+1, ktf DO i = i_start, i_end defor23(i,k,j) = mm(i,j) * ( & rdy * ( hat(i,k,j) - hat(i,k,j-1) ) - tmp1(i,k,j) ) END DO END DO END DO DO j = j_start, j_end DO i = i_start, i_end defor23(i,kts,j ) = 0.0 defor23(i,ktf+1,j) = 0.0 END DO END DO ! End addition of the first term to defor23. !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! Calculate dv/dz. IF ( config_flags%mix_full_fields ) THEN DO j = j_start, j_end DO k = kts+1, ktf DO i = i_start, i_end tmp1(i,k,j) = ( v(i,k,j) - v(i,k-1,j) ) * & 0.5 * ( rdz(i,k,j) + rdz(i,k,j-1) ) END DO END DO END DO ELSE DO j = j_start, j_end DO k = kts+1, ktf DO i = i_start, i_end tmp1(i,k,j) = ( 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) ) END DO END DO END DO END IF ! End calculation of dv/dz. !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! Add the second term (dv/dz) to defor23 (dw/dy+dv/dz) at vorticity ! points. IF ( config_flags%sfs_opt .GT. 0 ) THEN ! NBA-- !JDM___________________________________________________________________ ! ! s23 = dv/dz + dw/dy ! = dv/dz + (dw/dy - dz/dy*dw/dz) ! tmp1 + ______defor23______ ! ! r23 = dv/dz - dw/dy ! = dv/dz - (dw/dy - dz/dy*dw/dz) ! = tmp1 - ______defor23______ ! Add tmp1 to defor23. DO j = j_start, j_end DO k = kts+1, ktf DO i = i_start, i_end nba_rij(i,k,j,P_r23) = tmp1(i,k,j) - defor23(i,k,j) defor23(i,k,j) = defor23(i,k,j) + tmp1(i,k,j) END DO END DO END DO DO j = j_start, j_end DO i = i_start, i_end nba_rij(i,kts ,j,P_r23) = 0.0 nba_rij(i,ktf+1,j,P_r23) = 0.0 END DO END DO ! End addition of the second term to defor23. !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! Update the boundary for defor13 and defor23 (might need to change ! later). IF ( .NOT. config_flags%periodic_x .AND. i_start .EQ. ids+1) THEN DO j = jts, jte DO k = kts, kte defor13(ids,k,j) = defor13(ids+1,k,j) defor23(ids,k,j) = defor23(ids+1,k,j) nba_rij(ids,k,j,P_r13) = nba_rij(ids+1,k,j,P_r13) nba_rij(ids,k,j,P_r23) = nba_rij(ids+1,k,j,P_r23) END DO END DO END IF IF ( .NOT. config_flags%periodic_y .AND. j_start .EQ. jds+1) THEN DO k = kts, kte DO i = its, ite defor13(i,k,jds) = defor13(i,k,jds+1) defor23(i,k,jds) = defor23(i,k,jds+1) nba_rij(i,k,jds,P_r13) = nba_rij(i,k,jds+1,P_r13) nba_rij(i,k,jds,P_r23) = nba_rij(i,k,jds+1,P_r23) END DO END DO END IF IF ( .NOT. config_flags%periodic_x .AND. i_end .EQ. ide-1) THEN DO j = jts, jte DO k = kts, kte defor13(ide,k,j) = defor13(ide-1,k,j) defor23(ide,k,j) = defor23(ide-1,k,j) nba_rij(ide,k,j,P_r13) = nba_rij(ide-1,k,j,P_r13) nba_rij(ide,k,j,P_r23) = nba_rij(ide-1,k,j,P_r23) END DO END DO END IF IF ( .NOT. config_flags%periodic_y .AND. j_end .EQ. jde-1) THEN DO k = kts, kte DO i = its, ite defor13(i,k,jde) = defor13(i,k,jde-1) defor23(i,k,jde) = defor23(i,k,jde-1) nba_rij(i,k,jde,P_r13) = nba_rij(i,k,jde-1,P_r13) nba_rij(i,k,jde,P_r23) = nba_rij(i,k,jde-1,P_r23) END DO END DO END IF ELSE ! NOT NBA-------------------------------------------------------- ! Add tmp1 to defor23. DO j = j_start, j_end DO k = kts+1, ktf DO i = i_start, i_end defor23(i,k,j) = defor23(i,k,j) + tmp1(i,k,j) END DO END DO END DO ! End addition of the second term to defor23. !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! Update the boundary for defor13 and defor23 (might need to change ! later). IF ( .NOT. config_flags%periodic_x .AND. i_start .EQ. ids+1) THEN DO j = jts, jte DO k = kts, kte defor13(ids,k,j) = defor13(ids+1,k,j) defor23(ids,k,j) = defor23(ids+1,k,j) END DO END DO END IF IF ( .NOT. config_flags%periodic_y .AND. j_start .EQ. jds+1) THEN DO k = kts, kte DO i = its, ite defor13(i,k,jds) = defor13(i,k,jds+1) defor23(i,k,jds) = defor23(i,k,jds+1) END DO END DO END IF IF ( .NOT. config_flags%periodic_x .AND. i_end .EQ. ide-1) THEN DO j = jts, jte DO k = kts, kte defor13(ide,k,j) = defor13(ide-1,k,j) defor23(ide,k,j) = defor23(ide-1,k,j) END DO END DO END IF IF ( .NOT. config_flags%periodic_y .AND. j_end .EQ. jde-1) THEN DO k = kts, kte DO i = its, ite defor13(i,k,jde) = defor13(i,k,jde-1) defor23(i,k,jde) = defor23(i,k,jde-1) END DO END DO END IF ENDIF ! NBA----------------------------------------------------------- ! End update of boundary for defor13 and defor23. !----------------------------------------------------------------------- ! The second three (defor12, defor13, defor23) of six deformation terms ! are now calculated at vorticity points. !======================================================================= END SUBROUTINE cal_deform_and_div !======================================================================= !======================================================================= SUBROUTINE calculate_km_kh( config_flags, dt, & dampcoef, zdamp, damp_opt, & xkmh, xkmv, xkhh, xkhv, & BN2, khdif, kvdif, div, & defor11, defor22, defor33, & defor12, defor13, defor23, & tke, p8w, t8w, theta, t, p, moist, & dn, dnw, dx, dy, rdz, rdzw, isotropic, & n_moist, cf1, cf2, cf3, warm_rain, & mix_upper_bound, & msftx, msfty, & zx, zy, & hpbl,dlk,xkmv_meso, & !XZ ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) ! History: Sep 2003 Changes by George Bryan and Jason Knievel, NCAR ! Oct 2001 Converted to mass core by Bill Skamarock, NCAR ! ... ... ! Purpose: This routine calculates exchange coefficients for the TKE ! scheme. ! References: Klemp and Wilhelmson (JAS 1978) ! Deardorff (B-L Meteor 1980) ! Chen and Dudhia (NCAR WRF physics report 2000) !----------------------------------------------------------------------- ! Begin declarations. IMPLICIT NONE TYPE( grid_config_rec_type ), INTENT( IN ) & :: config_flags INTEGER, INTENT( IN ) & :: n_moist, damp_opt, isotropic, & 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 ) & :: dx, dy, zdamp, dt, dampcoef, cf1, cf2, cf3, khdif, kvdif 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 ), INTENT( INOUT ) & :: xkmv, xkmh, xkhv, xkhh, BN2 REAL, DIMENSION( ims:ime , kms:kme, jms:jme ), INTENT( IN ) & :: defor11, defor22, defor33, defor12, defor13, defor23, & div, rdz, rdzw, p8w, t8w, theta, t, p, zx, zy REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) & :: tke REAL, INTENT( IN ) & :: mix_upper_bound REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN ) & :: msftx, msfty !XZ REAL, DIMENSION( ims:ime, jms:jme ), INTENT( INOUT ) & :: hpbl REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN ) & :: dlk REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) & :: xkmv_meso ! ! Local variables. INTEGER & :: i_start, i_end, j_start, j_end, ktf, i, j, k ! End declarations. !----------------------------------------------------------------------- ktf = MIN( kte, kde-1 ) i_start = its i_end = MIN( ite, ide-1 ) j_start = jts j_end = MIN( jte, jde-1 ) CALL calculate_N2( config_flags, BN2, moist, & theta, t, p, p8w, t8w, & dnw, dn, rdz, 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 ) ! Select a scheme for calculating diffusion coefficients. km_coef: SELECT CASE( config_flags%km_opt ) CASE (1) CALL isotropic_km( config_flags, xkmh, xkmv, & xkhh, xkhv, khdif, kvdif, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) CASE (2, 5) !XZ CALL tke_km( config_flags, xkmh, xkmv, & xkhh, xkhv, BN2, tke, p8w, t8w, theta, & rdz, rdzw, dx, dy, dt, isotropic, & mix_upper_bound, msftx, msfty, & hpbl,dlk,xkmv_meso, & ! XZ defor11,defor22,defor12,zx,zy, & ! XZ ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) CASE (3) CALL smag_km( config_flags, xkmh, xkmv, & xkhh, xkhv, BN2, div, & defor11, defor22, defor33, & defor12, defor13, defor23, & 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 smag2d_km( config_flags, xkmh, xkmv, & xkhh, xkhv, defor11, defor22, defor12, & rdzw, dx, dy, msftx, msfty, & zx, zy, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) CASE DEFAULT CALL wrf_error_fatal( 'Please choose diffusion coefficient scheme' ) END SELECT km_coef IF ( damp_opt .eq. 1 ) THEN CALL cal_dampkm( config_flags, xkmh, xkhh, xkmv, xkhv, & dx, dy, dt, dampcoef, rdz, 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 calculate_km_kh !======================================================================= SUBROUTINE cal_dampkm( config_flags,xkmh,xkhh,xkmv,xkhv, & dx,dy,dt,dampcoef, & rdz, rdzw ,zdamp, & msftx, msfty, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) !----------------------------------------------------------------------- ! Begin declarations. 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 ) :: zdamp,dx,dy,dt,dampcoef REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: xkmh , & xkhh , & xkmv , & xkhv REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN ) :: rdz, & rdzw REAL , DIMENSION( ims:ime, jms:jme), INTENT(IN ) :: msftx, & msfty ! LOCAL VARS INTEGER :: i_start, i_end, j_start, j_end, ktf, ktfm1, i, j, k REAL :: kmmax,kmmvmax,degrad90,dz,tmp REAL :: ds REAL , DIMENSION( its:ite ) :: deltaz REAL , DIMENSION( its:ite, kts:kte, jts:jte) :: dampk,dampkv ! End declarations. !----------------------------------------------------------------------- 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) ! keep upper damping diffusion away from relaxation zones at boundaries if used 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 ! Unmodified dx used above may produce very large diffusivities ! when msftx is very large. And the above formula ignores the fact ! that dy may now be different from dx as well. Let's fix that by ! defining a "ds" as the minimum of the "real-space" (physical ! distance) values of dx and dy, and then using that smallest value ! to calculate a point-by-point kmmax ds = MIN(dx/msftx(i,j),dy/msfty(i,j)) kmmax=ds*ds/dt ! deltaz(i)=0.5*dnw(k)/zeta_z(i,j) ! dz=dnw(k)/zeta_z(i,j) dz = 1./rdzw(i,k,j) deltaz(i) = 0.5*dz kmmvmax=dz*dz/dt tmp=min(deltaz(i)/zdamp,1.) dampk(i,k,j)=cos(degrad90*tmp)*cos(degrad90*tmp)*kmmax*dampcoef dampkv(i,k,j)=cos(degrad90*tmp)*cos(degrad90*tmp)*kmmvmax*dampcoef ! set upper limit on vertical K (based on horizontal K) 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 ! Unmodified dx used above may produce very large diffusivities ! when msftx is very large. And the above formula ignores the fact ! that dy may now be different from dx as well. Let's fix that by ! defining a "ds" as the minimum of the "real-space" (physical ! distance) values of dx and dy, and then using that smallest value ! to calculate a point-by-point kmmax ds = MIN(dx/msftx(i,j),dy/msfty(i,j)) kmmax=ds*ds/dt ! deltaz(i)=deltaz(i)+dn(k)/zeta_z(i,j) ! dz=dnw(k)/zeta_z(i,j) dz = 1./rdz(i,k,j) deltaz(i) = deltaz(i) + dz dz = 1./rdzw(i,k,j) kmmvmax=dz*dz/dt tmp=min(deltaz(i)/zdamp,1.) dampk(i,k,j)=cos(degrad90*tmp)*cos(degrad90*tmp)*kmmax*dampcoef dampkv(i,k,j)=cos(degrad90*tmp)*cos(degrad90*tmp)*kmmvmax*dampcoef ! set upper limit on vertical K (based on horizontal K) 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 xkmh(i,k,j)=max(xkmh(i,k,j),dampk(i,k,j)) xkhh(i,k,j)=max(xkhh(i,k,j),dampk(i,k,j)) xkmv(i,k,j)=max(xkmv(i,k,j),dampkv(i,k,j)) xkhv(i,k,j)=max(xkhv(i,k,j),dampkv(i,k,j)) ENDDO ENDDO ENDDO END SUBROUTINE cal_dampkm !======================================================================= !======================================================================= SUBROUTINE calculate_N2( config_flags, BN2, moist, & theta, t, p, p8w, t8w, & dnw, dn, rdz, 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 ) !----------------------------------------------------------------------- ! Begin declarations. IMPLICIT NONE 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( IN ) & :: rdz, rdzw, theta, t, p, p8w, t8w REAL, DIMENSION( kms:kme ), INTENT( IN ) & :: dnw, dn REAL, DIMENSION( ims:ime, kms:kme, jms:jme, n_moist), INTENT( INOUT ) & :: moist ! 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, DIMENSION( its:ite, jts:jte ) & :: tmp1sfc, tmp1top REAL, DIMENSION( its:ite, kts:kte, jts:jte ) & :: tmp1, qvs, qctmp ! End declarations. !----------------------------------------------------------------------- qc_cr = 0.00001 ! in Kg/Kg 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 ( 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 tmp1(i,k,j) = 0.0 END DO END DO END DO DO j = jts,jte DO i = its,ite tmp1sfc(i,j) = 0.0 tmp1top(i,j) = 0.0 END DO END DO 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 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 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 ! Calculate saturation mixing ratio. DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end tc = t(i,k,j) - SVPT0 es = 1000.0 * SVP1 * EXP( SVP2 * tc / ( t(i,k,j) - SVP3 ) ) 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 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 xlvqv = XLV * moist(i,k,j,P_QV) 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) thetaep1 = theta(i,k+1,j) * & ( 1.0 + XLV * qvs(i,k+1,j) / Cp / t(i,k+1,j) ) thetaem1 = theta(i,k-1,j) * & ( 1.0 + XLV * qvs(i,k-1,j) / Cp / t(i,k-1,j) ) BN2(i,k,j) = g * ( coefa * ( thetaep1 - thetaem1 ) / tmpdz - & ( tmp1(i,k+1,j) - tmp1(i,k-1,j) ) / tmpdz ) ELSE 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 ) ENDIF END DO END DO END DO k = kts DO j = j_start, j_end DO i = i_start, i_end tmpdz = 1.0 / rdz(i,k+1,j) + 0.5 / rdzw(i,k,j) thetasfc = T8w(i,kts,j) / ( p8w(i,k,j) / p1000mb )**( R_d / Cp ) IF ( moist(i,k,j,P_QV) .GE. qvs(i,k,j) .OR. qctmp(i,k,j) .GE. qc_cr) THEN qvsfc = cf1 * qvs(i,1,j) + & cf2 * qvs(i,2,j) + & cf3 * qvs(i,3,j) xlvqv = XLV * moist(i,k,j,P_QV) 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) thetaep1 = theta(i,k+1,j) * & ( 1.0 + XLV * qvs(i,k+1,j) / Cp / t(i,k+1,j) ) thetaesfc = thetasfc * & ( 1.0 + XLV * qvsfc / Cp / t8w(i,kts,j) ) BN2(i,k,j) = g * ( coefa * ( thetaep1 - thetaesfc ) / tmpdz - & ( tmp1(i,k+1,j) - tmp1sfc(i,j) ) / tmpdz ) ELSE 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 tmpdz= 1./rdzw(i,k,j) ! controlare come calcola rdzw 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 ENDIF 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 BN2(i,ktf,j)=BN2(i,ktf-1,j) END DO END DO ! end of MARTA/WCS change END SUBROUTINE calculate_N2 !======================================================================= !======================================================================= SUBROUTINE isotropic_km( config_flags, & xkmh,xkmv,xkhh,xkhv,khdif,kvdif, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) !----------------------------------------------------------------------- ! Begin declarations. 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 ) :: khdif,kvdif REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: xkmh, & xkmv, & xkhh, & xkhv ! LOCAL VARS INTEGER :: i_start, i_end, j_start, j_end, ktf, i, j, k REAL :: khdif3,kvdif3 ! End declarations. !----------------------------------------------------------------------- ktf = kte i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = MIN(jte,jde-1) ! khdif3=khdif*3. ! kvdif3=kvdif*3. khdif3=khdif/prandtl kvdif3=kvdif/prandtl DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end xkmh(i,k,j)=khdif xkmv(i,k,j)=kvdif xkhh(i,k,j)=khdif3 xkhv(i,k,j)=kvdif3 ENDDO ENDDO ENDDO END SUBROUTINE isotropic_km !======================================================================= !======================================================================= SUBROUTINE smag_km( config_flags,xkmh,xkmv,xkhh,xkhv,BN2, & div,defor11,defor22,defor33,defor12, & defor13,defor23, & 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 ) !----------------------------------------------------------------------- ! Begin declarations. 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 INTEGER , INTENT(IN ) :: isotropic REAL , INTENT(IN ) :: dx, dy, dt, mix_upper_bound REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: BN2, & rdzw REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: xkmh, & xkmv, & xkhh, & xkhv REAL , DIMENSION( ims:ime , kms:kme, jms:jme ), INTENT(IN ) :: & defor11, & defor22, & defor33, & defor12, & defor13, & defor23, & div 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, mlen_v, c_s REAL, DIMENSION( its:ite , kts:kte , jts:jte ) :: def2 ! End declarations. !----------------------------------------------------------------------- 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 ) pr = prandtl c_s = config_flags%c_s do j=j_start,j_end do k=kts,ktf do i=i_start,i_end def2(i,k,j)=0.5*(defor11(i,k,j)*defor11(i,k,j) + & defor22(i,k,j)*defor22(i,k,j) + & defor33(i,k,j)*defor33(i,k,j)) enddo enddo enddo do j=j_start,j_end do k=kts,ktf do i=i_start,i_end tmp=0.25*(defor12(i ,k,j)+defor12(i ,k,j+1)+ & defor12(i+1,k,j)+defor12(i+1,k,j+1)) def2(i,k,j)=def2(i,k,j)+tmp*tmp enddo enddo enddo do j=j_start,j_end do k=kts,ktf do i=i_start,i_end tmp=0.25*(defor13(i ,k+1,j)+defor13(i ,k,j)+ & defor13(i+1,k+1,j)+defor13(i+1,k,j)) def2(i,k,j)=def2(i,k,j)+tmp*tmp enddo enddo enddo do j=j_start,j_end do k=kts,ktf do i=i_start,i_end tmp=0.25*(defor23(i,k+1,j )+defor23(i,k,j )+ & defor23(i,k+1,j+1)+defor23(i,k,j+1)) def2(i,k,j)=def2(i,k,j)+tmp*tmp enddo enddo enddo ! IF (isotropic .EQ. 0) THEN DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end mlen_h=sqrt(dx/msftx(i,j) * dy/msfty(i,j)) mlen_v= 1./rdzw(i,k,j) tmp=max(0.,def2(i,k,j)-BN2(i,k,j)/pr) tmp=tmp**0.5 xkmh(i,k,j)=max(c_s*c_s*mlen_h*mlen_h*tmp, 1.0E-6*mlen_h*mlen_h ) xkmh(i,k,j)=min(xkmh(i,k,j), mix_upper_bound * mlen_h * mlen_h / dt ) xkmv(i,k,j)=max(c_s*c_s*mlen_v*mlen_v*tmp, 1.0E-6*mlen_v*mlen_v ) xkmv(i,k,j)=min(xkmv(i,k,j), mix_upper_bound * mlen_v * mlen_v / dt ) xkhh(i,k,j)=xkmh(i,k,j)/pr xkhh(i,k,j)=min(xkhh(i,k,j), mix_upper_bound * mlen_h * mlen_h / dt ) xkhv(i,k,j)=xkmv(i,k,j)/pr xkhv(i,k,j)=min(xkhv(i,k,j), mix_upper_bound * mlen_v * mlen_v / dt ) ENDDO ENDDO ENDDO ELSE DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end deltas=(dx/msftx(i,j) * dy/msfty(i,j)/rdzw(i,k,j))**0.33333333 tmp=max(0.,def2(i,k,j)-BN2(i,k,j)/pr) tmp=tmp**0.5 xkmh(i,k,j)=max(c_s*c_s*deltas*deltas*tmp, 1.0E-6*deltas*deltas ) xkmh(i,k,j)=min(xkmh(i,k,j), mix_upper_bound * dx/msftx(i,j) * dy/msfty(i,j) / dt ) xkmv(i,k,j)=xkmh(i,k,j) xkmv(i,k,j)=min(xkmv(i,k,j), mix_upper_bound / rdzw(i,k,j) / rdzw(i,k,j) / dt ) xkhh(i,k,j)=xkmh(i,k,j)/pr xkhh(i,k,j)=min(xkhh(i,k,j), mix_upper_bound * dx/msftx(i,j) * dy/msfty(i,j) / dt ) xkhv(i,k,j)=xkmv(i,k,j)/pr xkhv(i,k,j)=min(xkhv(i,k,j), mix_upper_bound / rdzw(i,k,j) / rdzw(i,k,j) / dt ) ENDDO ENDDO ENDDO ENDIF END SUBROUTINE smag_km !======================================================================= !======================================================================= SUBROUTINE smag2d_km( config_flags,xkmh,xkmv,xkhh,xkhv, & defor11,defor22,defor12, & rdzw,dx,dy,msftx, msfty,zx,zy, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) !----------------------------------------------------------------------- ! Begin declarations. 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(INOUT) :: xkmh, & xkmv, & xkhh, & xkhv REAL , DIMENSION( ims:ime , kms:kme, jms:jme ), INTENT(IN ) :: & defor11, & defor22, & defor12 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 :: dxm, dym, tmpzx, tmpzy, alpha, def_limit REAL, DIMENSION( its:ite , kts:kte , jts:jte ) :: def2 ! End declarations. !----------------------------------------------------------------------- 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 ) pr=prandtl c_s = config_flags%c_s do j=j_start,j_end do k=kts,ktf do i=i_start,i_end def2(i,k,j)=0.25*((defor11(i,k,j)-defor22(i,k,j))*(defor11(i,k,j)-defor22(i,k,j))) tmp=0.25*(defor12(i ,k,j)+defor12(i ,k,j+1)+ & defor12(i+1,k,j)+defor12(i+1,k,j+1)) def2(i,k,j)=def2(i,k,j)+tmp*tmp enddo enddo enddo ! DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end mlen_h=sqrt(dx/msftx(i,j) * dy/msfty(i,j)) 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 ) xkmh(i,k,j)=c_s*c_s*mlen_h*mlen_h*tmp xkmh(i,k,j)=min(xkmh(i,k,j), 10.*mlen_h ) xkmv(i,k,j)=xkmh(i,k,j) ! v4.2 and later, this is used for hor. diff. of w xkhh(i,k,j)=xkmh(i,k,j)/pr 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) tmpzx = (0.25*( abs(zx(i,k,j))+ abs(zx(i+1,k,j )) + abs(zx(i,k+1,j))+ abs(zx(i+1,k+1,j )))*rdzw(i,k,j)*dxm) tmpzy = (0.25*( abs(zy(i,k,j))+ abs(zy(i ,k,j+1)) + abs(zy(i,k+1,j))+ abs(zy(i ,k+1,j+1)))*rdzw(i,k,j)*dym) alpha = max(sqrt(tmpzx*tmpzx+tmpzy*tmpzy),1.0) ! If deformation is large, further reduce the diffusion coefficient def_limit = max(10./mlen_h,1.e-3) if ( tmp .gt. def_limit ) then xkmh(i,k,j)=xkmh(i,k,j)/(alpha*alpha) else xkmh(i,k,j)=xkmh(i,k,j)/(alpha) endif xkhh(i,k,j)=xkmh(i,k,j)/pr xkmv(i,k,j)=xkmh(i,k,j) ! v4.2 and later, this is used for hor. diff. of w ENDIF ENDDO ENDDO ENDDO END SUBROUTINE smag2d_km !======================================================================= !======================================================================= SUBROUTINE tke_km( config_flags, xkmh, xkmv, xkhh, xkhv, & bn2, tke, p8w, t8w, theta, & rdz, rdzw, dx,dy, dt, isotropic, & mix_upper_bound, msftx, msfty, & hpbl,dlk,xkmv_meso, & ! XZ defor11,defor22,defor12,zx,zy, & ! XZ ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) ! History: Sep 2003 Changes by Jason Knievel and George Bryan, NCAR ! Oct 2001 Converted to mass core by Bill Skamarock, NCAR ! ... ... ! Purpose: This routine calculates the exchange coefficients for the ! TKE turbulence parameterization. ! References: Klemp and Wilhelmson (JAS 1978) ! Chen and Dudhia (NCAR WRF physics report 2000) !----------------------------------------------------------------------- ! Begin declarations. 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 INTEGER, INTENT( IN ) :: isotropic REAL, INTENT( IN ) & :: dx, dy, dt REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN ) & :: tke, p8w, t8w, theta, rdz, rdzw, bn2 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) & :: xkmh, xkmv, xkhh, xkhv REAL, INTENT( IN ) & :: mix_upper_bound REAL , DIMENSION( ims:ime, jms:jme), INTENT(IN ) :: msftx, & msfty !XZ REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN ) & :: zx,zy REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN ) & :: defor11, defor22, defor12 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) & :: xkmv_meso REAL, DIMENSION( ims:ime, jms:jme), INTENT( INOUT ) & :: hpbl REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN ) & :: dlk ! ! Local variables. REAL, DIMENSION( its:ite, kts:kte, jts:jte ) & :: l_scale REAL, DIMENSION( its:ite, kts:kte, jts:jte ) & :: dthrdn REAL & :: deltas, tmp, mlen_s, mlen_h, mlen_v, tmpdz, & thetasfc, thetatop, minkx, pr_inv, pr_inv_h, pr_inv_v, 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 !XZ REAL :: pth1, delxy, pu1, xkmv_les, pr_inv_v_meso, pr_inv_v_les, pr REAL :: dxm, dym, tmpzx, tmpzy, alpha, def_limit, c_s, xkmh_t, xkhh_t REAL, DIMENSION( its:ite , kts:kte , jts:jte ) :: def2 REAL, DIMENSION( its:ite , kts:kte , jts:jte ) :: xkmh_s, xkhh_s REAL, PARAMETER :: xkmvo = 0.0, xkhvo = 0.0 !background diffusivity ! ! End declarations. !----------------------------------------------------------------------- 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 ) ! in the absence of surface drag or a surface heat flux, there ! is no way to generate tke without pre-existing tke. Use ! tke_seed if the drag and flux are off. 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 tmpdz = 1.0 / rdz(i,k+1,j) + 1.0 / rdz(i,k,j) dthrdn(i,k,j) = ( theta(i,k+1,j) - theta(i,k-1,j) ) / tmpdz END DO END DO END DO k = kts DO j = j_start, j_end DO i = i_start, i_end tmpdz = 1.0 / rdzw(i,k+1,j) + 1.0 / rdzw(i,k,j) thetasfc = T8w(i,kts,j) / ( p8w(i,k,j) / p1000mb )**( R_d / Cp ) dthrdn(i,k,j) = ( theta(i,k+1,j) - thetasfc ) / tmpdz END DO END DO k = ktf DO j = j_start, j_end DO i = i_start, i_end tmpdz = 1.0 / rdz(i,k,j) + 0.5 / rdzw(i,k,j) thetatop = T8w(i,kde,j) / ( p8w(i,kde,j) / p1000mb )**( R_d / Cp ) dthrdn(i,k,j) = ( thetatop - theta(i,k-1,j) ) / tmpdz END DO END DO IF ( config_flags%km_opt .EQ. 2 .and. isotropic .EQ. 0 ) THEN !XZ DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end mlen_h = SQRT( dx/msftx(i,j) * dy/msfty(i,j) ) tmp = SQRT( MAX( tke(i,k,j), tke_seed ) ) deltas = 1.0 / rdzw(i,k,j) mlen_v = deltas IF ( dthrdn(i,k,j) .GT. 0.) THEN mlen_s = 0.76 * tmp / ( ABS( g / theta(i,k,j) * dthrdn(i,k,j) ) )**0.5 mlen_v = MIN( mlen_v, mlen_s ) END IF xkmh(i,k,j) = MAX( c_k * tmp * mlen_h, 1.0E-6 * mlen_h * mlen_h ) xkmh(i,k,j) = MIN( xkmh(i,k,j), mix_upper_bound * mlen_h *mlen_h / dt ) xkmv(i,k,j) = MAX( c_k * tmp * mlen_v, 1.0E-6 * deltas * deltas ) xkmv(i,k,j) = MIN( xkmv(i,k,j), mix_upper_bound * deltas *deltas / dt ) pr_inv_h = 1./prandtl pr_inv_v = 1.0 + 2.0 * mlen_v / deltas xkhh(i,k,j) = xkmh(i,k,j) * pr_inv_h xkhv(i,k,j) = xkmv(i,k,j) * pr_inv_v END DO END DO END DO ENDIF !XZ IF ( config_flags%km_opt .eq.2.and.isotropic .NE. 0 ) THEN ! XZ CALL calc_l_scale( config_flags, tke, BN2, l_scale, & i_start, i_end, ktf, j_start, j_end, & dx, dy, 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 tmp = SQRT( MAX( tke(i,k,j), tke_seed ) ) deltas = ( dx/msftx(i,j) * dy/msfty(i,j) / rdzw(i,k,j) )**0.33333333 xkmh(i,k,j) = c_k * tmp * l_scale(i,k,j) xkmh(i,k,j) = MIN( mix_upper_bound * dx/msftx(i,j) * dy/msfty(i,j) / dt, xkmh(i,k,j) ) xkmv(i,k,j) = c_k * tmp * l_scale(i,k,j) xkmv(i,k,j) = MIN( mix_upper_bound / rdzw(i,k,j) / rdzw(i,k,j) / dt , xkmv(i,k,j) ) pr_inv = 1.0 + 2.0 * l_scale(i,k,j) / deltas xkhh(i,k,j) = MIN( mix_upper_bound * dx/msftx(i,j) * dy/msfty(i,j) / dt, xkmh(i,k,j) * pr_inv ) xkhv(i,k,j) = MIN( mix_upper_bound / rdzw(i,k,j) / rdzw(i,k,j) / dt, xkmv(i,k,j) * pr_inv ) END DO END DO END DO END IF !!!XZ IF(config_flags%km_opt .eq.5 ) THEN ! 3DTKE diffusivity ! smag_2d horizontal diffusivity pr=prandtl c_s = config_flags%c_s DO j=j_start,j_end DO k=kts,ktf DO i=i_start,i_end def2(i,k,j) = 0.25*((defor11(i,k,j)-defor22(i,k,j))*(defor11(i,k,j)-defor22(i,k,j))) tmp = 0.25*(defor12(i ,k,j)+defor12(i ,k,j+1)+ & defor12(i+1,k,j)+defor12(i+1,k,j+1)) def2(i,k,j)= def2(i,k,j)+tmp*tmp ENDDO ENDDO ENDDO DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end mlen_h = sqrt(dx/msftx(i,j) * dy/msfty(i,j)) tmp = sqrt(def2(i,k,j)) xkmh_s(i,k,j) = c_s*c_s*mlen_h*mlen_h*tmp xkmh_s(i,k,j) = min(xkmh_s(i,k,j), 10.*mlen_h ) xkhh_s(i,k,j) = xkmh_s(i,k,j)/pr IF(config_flags%diff_opt .EQ. 2)THEN dxm=dx/msftx(i,j) dym=dy/msfty(i,j) tmpzx = (0.25*( abs(zx(i,k,j))+ abs(zx(i+1,k,j )) + abs(zx(i,k+1,j))+ abs(zx(i+1,k+1,j )))*rdzw(i,k,j)*dxm) tmpzy = (0.25*( abs(zy(i,k,j))+ abs(zy(i ,k,j+1)) + abs(zy(i,k+1,j))+ abs(zy(i ,k+1,j+1)))*rdzw(i,k,j)*dym) alpha = max(sqrt(tmpzx*tmpzx+tmpzy*tmpzy),1.0) def_limit = max(10./mlen_h,1.e-3) IF ( tmp .GT. def_limit ) THEN xkmh_s(i,k,j)=xkmh_s(i,k,j)/(alpha*alpha) ELSE xkmh_s(i,k,j)=xkmh_s(i,k,j)/(alpha) ENDIF xkhh_s(i,k,j)=xkmh_s(i,k,j)/pr ENDIF ENDDO ENDDO ENDDO !! difusivity based on TKE DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end mlen_h = SQRT( dx/msftx(i,j) * dy/msfty(i,j) ) ! horizontal mixing length tmp = SQRT( MAX( tke(i,k,j), tke_seed ) ) deltas = 1.0 / rdzw(i,k,j) mlen_v = deltas IF ( dthrdn(i,k,j) .GT. 0.) THEN mlen_s = 0.76 * tmp / ( ABS( g / theta(i,k,j) * dthrdn(i,k,j)))**0.5 mlen_v = MIN( mlen_v, mlen_s ) END IF ! length scales multiplied by partial function for grid-size dependency delxy = SQRT(dx/msftx(i,j)*dy/msfty(i,j)) pth1= pthl(delxy,hpbl(i,j)) pu1 = pu (delxy,hpbl(i,j)) xkmh_t = c_k * tmp * mlen_h xkmv_meso(i,k,j) = 0.4 * tmp * dlk(i,k,j) ! diffusivity using mesoscale length scale xkmv_meso(i,k,j) = xkmv_meso(i,k,j) + xkmvo xkmv_les = c_k * tmp * mlen_v ! diffusivity using LES length scale xkmv(i,k,j) = ( 1.0 - pu1 ) * xkmv_les + pu1 * xkmv_meso(i,k,j) xkmv(i,k,j) = MIN(xkmv(i,k,j), 1000.) pr_inv_h = 1./prandtl pr_inv_v_les = 1.0 + 2.0 * mlen_v / deltas pr_inv_v_meso = 1.0 xkhh_t = xkmh_t * pr_inv_h xkhv(i,k,j) = xkmv(i,k,j) * (1.0-pth1) * pr_inv_v_les & + pth1 * (pr_inv_v_meso * xkmv(i,k,j) + xkhvo) xkhv(i,k,j) = MIN(xkhv(i,k,j), 1000.) ! blending of horizontal K(deformation) and K(TKE) xkmh(i,k,j) = pth1 * xkmh_s(i,k,j) + ( 1.0 - pth1 ) * xkmh_t xkhh(i,k,j) = pth1 * xkhh_s(i,k,j) + ( 1.0 - pth1 ) * xkhh_t ENDDO ENDDO ENDDO ENDIF !!! END SUBROUTINE tke_km !======================================================================= !======================================================================= SUBROUTINE calc_l_scale( config_flags, tke, BN2, l_scale, & i_start, i_end, ktf, j_start, j_end, & dx, dy, rdzw, msftx, msfty, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) ! History: Sep 2003 Written by Bryan and Knievel, NCAR ! Purpose: This routine calculates the length scale, based on stability, ! for TKE parameterization of subgrid-scale turbulence. !----------------------------------------------------------------------- ! Begin declarations. IMPLICIT NONE TYPE( grid_config_rec_type ), INTENT( IN ) & :: config_flags INTEGER, INTENT( IN ) & :: 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 ), INTENT( IN ) & :: BN2, tke, rdzw REAL, INTENT( IN ) & :: dx, dy REAL, DIMENSION( its:ite, kts:kte, jts:jte ), INTENT( OUT ) & :: l_scale REAL , DIMENSION( ims:ime, jms:jme), INTENT(IN ) :: msftx, & msfty ! Local variables. INTEGER & :: i, j, k REAL & :: deltas, tmp ! End declarations. !----------------------------------------------------------------------- DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end deltas = ( dx/msftx(i,j) * dy/msfty(i,j) / rdzw(i,k,j) )**0.33333333 l_scale(i,k,j) = deltas IF ( BN2(i,k,j) .gt. 1.0e-6 ) THEN tmp = SQRT( MAX( tke(i,k,j), 1.0e-6 ) ) l_scale(i,k,j) = 0.76 * tmp / SQRT( BN2(i,k,j) ) l_scale(i,k,j) = MIN( l_scale(i,k,j), deltas) l_scale(i,k,j) = MAX( l_scale(i,k,j), 0.001 * deltas ) END IF END DO END DO END DO END SUBROUTINE calc_l_scale !======================================================================= !======================================================================= !XZ SUBROUTINE meso_length_scale(config_flags,dx,dy,rdzw,rdz,tke, & p8w,t8w,theta,dlk,hpbl,elmin, & rmol,rho,hfx,qfx,moist,n_moist, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) ! ! The mesoscale length scale based on Nakanishi and Niino (2009) ! and modified by X. Zhang 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 INTEGER, INTENT( IN ) & :: n_moist REAL, INTENT( IN ) & :: dx,dy REAL, DIMENSION( ims:ime, kms:kme, jms:jme, n_moist ), INTENT( INOUT ) & :: moist REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN ) & :: tke, rdzw, rdz, p8w, t8w REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN ) & :: theta,rho REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) & :: dlk,elmin REAL, DIMENSION( ims:ime, jms:jme ), INTENT( INOUT ) & :: rmol,hfx,qfx,hpbl !Local variables. REAL, DIMENSION( its:ite, kts:kte, jts:jte ) :: zfull,za REAL, DIMENSION( its:ite, kts:kte, jts:jte ) :: elb,qtke,els,elf REAL, DIMENSION( its:ite, jts:jte ) :: sflux,elt,vsc REAL, DIMENSION( its:ite, kts:kte, jts:jte ) :: dthrdn INTEGER :: izz,i,k,j INTEGER :: i_start, i_end, ktf, j_start, j_end REAL,PARAMETER :: alp1 = 0.8, alp2 = 1.0, alp3 = 1.0, alp4 = 100.0 ! REAL :: cpm,qcv,N2,tmpdz,thetasfc,thetatop,heat_flux,gtr,qdz,coe REAL :: zi2,h1,h2,wt REAL, PARAMETER :: minzi = 300. !min mixed-layer height REAL, PARAMETER :: maxdz = 750. !max (half) transition layer depth !=0.3*2500 m PBLH, so the transition !layer stops growing for PBLHs > 2.5 km. REAL, PARAMETER :: mindz = 300. !min (half) transition layer depth 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 i = i_start, i_end zfull(i,1,j) = 0. ENDDO ENDDO DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end zfull(i,k+1,j) = 1.0/rdzw(i,k,j) + zfull(i,k,j) ENDDO ENDDO ENDDO DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end za(i,k,j) = (zfull(i,k,j) + zfull(i,k+1,j))/2.0 ENDDO ENDDO ENDDO DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end dlk(i,k,j) = 0.0 ENDDO ENDDO ENDDO DO j = j_start, j_end DO k = kts+1, ktf-1 DO i = i_start, i_end tmpdz = 1.0 / rdz(i,k+1,j) + 1.0 / rdz(i,k,j) dthrdn(i,k,j) = ( theta(i,k+1,j) - theta(i,k-1,j) ) / tmpdz END DO END DO END DO k = kts DO j = j_start, j_end DO i = i_start, i_end tmpdz = 1.0 / rdzw(i,k+1,j) + 1.0 / rdzw(i,k,j) thetasfc = T8w(i,kts,j) / ( p8w(i,k,j) / p1000mb )**( R_d / Cp ) dthrdn(i,k,j) = ( theta(i,k+1,j) - thetasfc ) / tmpdz END DO END DO k = ktf DO j = j_start, j_end DO i = i_start, i_end tmpdz = 1.0 / rdz(i,k,j) + 0.5 / rdzw(i,k,j) thetatop = T8w(i,kde,j) / ( p8w(i,kde,j) / p1000mb )**( R_d / Cp ) dthrdn(i,k,j) = ( thetatop - theta(i,k-1,j) ) / tmpdz END DO END DO DO j = j_start, j_end DO k = kts,ktf DO i = i_start, i_end qtke(i,k,j) = sqrt(2.0*tke(i,k,j)) ENDDO ENDDO ENDDO DO j = j_start, j_end DO i = i_start, i_end elt(i,j) = 1.0e-5 vsc(i,j) = 1.0e-5 ENDDO ENDDO DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end qdz = qtke(i,k,j)*(1.0/rdzw(i,k,j)) elt(i,j) = elt(i,j) + qdz*za(i,k,j) vsc(i,j) = vsc(i,j) + qdz ENDDO ENDDO ENDDO DO j = j_start, j_end DO i = i_start, i_end elt(i,j) = alp1*elt(i,j)/vsc(i,j) ENDDO ENDDO hflux: SELECT CASE( config_flags%isfflx ) CASE (0,2) ! with fixed surface heat flux given in the namelist heat_flux = config_flags%tke_heat_flux ! constant heat flux value DO j = j_start, j_end DO i = i_start, i_end cpm = cp * (1. + 0.8 * moist(i,kts,j,P_QV)) hfx(i,j)= heat_flux*cpm*rho(i,1,j) ENDDO ENDDO CASE (1) ! use surface heat flux computed from surface routine DO j = j_start, j_end DO i = i_start, i_end cpm = cp * (1. + 0.8 * moist(i,kts,j,P_QV)) heat_flux = hfx(i,j)/cpm/rho(i,1,j) ENDDO ENDDO CASE DEFAULT CALL wrf_error_fatal( 'isfflx value invalid for diff_opt=2' ) END SELECT hflux DO j = j_start,j_end DO i = i_start,i_end cpm = cp * (1. + 0.8*moist(i,1,j,P_QV)) sflux(i,j) = (hfx(i,j)/cpm)/rho(i,1,j) ENDDO ENDDO !-------Length scale limited by bouyancy effect----- gtr = g/300. DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end IF( dthrdn(i,k,j).GT.0.0 ) THEN N2 = gtr*dthrdn(i,k,j) qcv = (gtr*MAX(sflux(i,j),0.0)*elt(i,j))**(1.0/3.0) elb(i,k,j) = qtke(i,k,j)/sqrt(N2)*(alp2 + alp3*sqrt(qcv/(elt(i,j)*sqrt(N2)))) elf(i,k,j) = alp2*qtke(i,k,j)/sqrt(N2) ELSE elb(i,k,j) = 1.0e10 elf(i,k,j) = elb(i,k,j) ENDIF ENDDO ENDDO ENDDO !------Length scale in the surface layer------- DO j = j_start, j_end DO k = kts, ktf DO i = i_start,i_end IF (rmol(i,j) .GT. 0.0) THEN els(i,k,j) = karman*za(i,k,j)/(1.0+2.7*min(za(i,k,j)*rmol(i,j),1.0)) ELSE coe = (1.0 - alp4*za(i,k,j)*rmol(i,j))**0.2 els(i,k,j) = 1.0*karman*za(i,k,j)*coe ENDIF ENDDO ENDDO ENDDO !----Harmonic averaging of mixing length scales----- DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end dlk(i,k,j) = MIN(elb(i,k,j)/(elb(i,k,j)/elt(i,j)+elb(i,k,j)/els(i,k,j)+1.0),elf(i,k,j)) ENDDO ENDDO ENDDO !add blending to use BouLac mixing length in free atmos; !defined relative to the PBLH (zi) + transition layer (h1) DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end zi2=MAX(hpbl(i,j),minzi) h1=MAX(0.3*zi2,mindz) h1=MIN(h1,maxdz) ! 1/2 transition layer depth h2=h1/2.0 ! 1/4 transition layer depth wt=.5*TANH((za(i,k,j) - (zi2+h1))/h2) + .5 dlk(i,k,j) = dlk(i,k,j)*(1.-wt) + 0.4*elmin(i,k,j)*wt ENDDO ENDDO ENDDO END SUBROUTINE meso_length_scale !======================================================================= !======================================================================= SUBROUTINE free_atmos_length(config_flags,dx,dy,rdzw,rdz,tke,theta,elmin, & hfx,qfx,moist,n_moist, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) ! ! NOTE: This subroutine is based on the BouLac PBL to calculate mixing length ! in the free atmosphere and modified for integration into the 3DTKE scheme. ! Modified by X.Zhang ! ! dlu = the distance a parcel can be lifted upwards give a finite ! amount of TKE. ! dld = the distance a parcel can be displaced downwards given a ! finite amount of TKE. ! compute the length scales up and down 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 INTEGER, INTENT( IN ) & :: n_moist REAL, INTENT( IN ) & :: dx,dy REAL, DIMENSION( ims:ime, kms:kme, jms:jme, n_moist ), INTENT( INOUT ) & :: moist REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN ) & :: tke, rdzw, rdz REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN ) & :: theta REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) & :: elmin REAL, DIMENSION( ims:ime, jms:jme ), INTENT( INOUT ) & :: hfx,qfx !Local variables REAL, DIMENSION( its:ite, kts:kte, jts:jte ) :: zfull,za REAL, DIMENSION( its:ite, kts:kte, jts:jte ) :: dlg,dlu,dld INTEGER :: izz, found, i, k, j REAL :: dzt,zup,beta,zup_inf,bbb,tl,zdo,zdo_sup,zzz INTEGER :: i_start, i_end, ktf, j_start, j_end 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 i = i_start, i_end zfull(i,1,j)= 0. ENDDO ENDDO DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end zfull(i,k+1,j) = 1.0/rdzw(i,k,j) + zfull(i,k,j) ENDDO ENDDO ENDDO DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end za(i,k,j) = (zfull(i,k,j) + zfull(i,k+1,j))/2.0 ENDDO ENDDO ENDDO DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end elmin(i,k,j) = 0.0 ENDDO ENDDO ENDDO DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end zup=0. dlu(i,k,j) = zfull(i,ktf+1,j) - zfull(i,k,j) - 1.0/rdzw(i,k,j)/2. zzz=0. zup_inf=0. beta=g/300. !th(i,1,j) !Buoyancy coefficient IF (k.LT.ktf) THEN found = 0 izz = k DO WHILE (found.EQ.0) IF (izz .LT. ktf) THEN dzt = (1.0/rdzw(i,izz+1,j) + 1.0/rdzw(i,izz,j))/2. zup = zup - beta * theta(i,k,j) * dzt zup = zup + beta * (theta(i,izz+1,j) + theta(i,izz,j)) * dzt/2. zzz = zzz + dzt IF (tke(i,k,j).LT.zup.and.tke(i,k,j).GE.zup_inf) THEN bbb=(theta(i,izz+1,j)-theta(i,izz,j))/dzt IF(bbb.NE.0) THEN tl = (-beta * (theta(i,izz,j) - theta(i,k,j)) & + sqrt(max(0.,(beta*(theta(i,izz,j)-theta(i,k,j)))**2. & + 2.*bbb*beta*(tke(i,k,j) - zup_inf))))/bbb/beta ELSE IF (theta(i,izz,j) .NE. theta(i,k,j)) THEN tl = (tke(i,k,j) - zup_inf)/(beta*(theta(i,izz,j) - theta(i,k,j))) ELSE tl = 0. ENDIF ENDIF dlu(i,k,j) = zzz - dzt + tl found = 1 ENDIF zup_inf = zup izz = izz + 1 ELSE found = 1 ENDIF ENDDO ENDIF zdo = 0. zdo_sup = 0. dld(i,k,j) = zfull(i,k,j) + 1.0/rdzw(i,k,j)/2. zzz = 0. IF (k .GT. kts) THEN found = 0 izz = k DO WHILE (found.EQ.0) IF (izz .GT. kts) THEN dzt = (1.0/rdzw(i,izz-1,j) + 1.0/rdzw(i,izz,j))/2. zdo = zdo + beta*theta(i,k,j)*dzt zdo = zdo - beta*(theta(i,izz-1,j) + theta(i,izz,j))*dzt/2. zzz = zzz + dzt IF(tke(i,k,j) .LT. zdo .and. tke(i,k,j).GE.zdo_sup) THEN bbb = (theta(i,izz,j) - theta(i,izz-1,j))/dzt IF(bbb.NE.0.) THEN tl = (beta*(theta(i,izz,j) - theta(i,k,j)) & + sqrt(max(0.,(beta*(theta(i,izz,j) - theta(i,k,j)))**2. & + 2.*bbb*beta*(tke(i,k,j) - zdo_sup))))/bbb/beta ELSE IF(theta(i,izz,j).NE.theta(i,k,j)) THEN tl = (tke(i,k,j) - zdo_sup)/(beta*(theta(i,izz,j) - theta(i,k,j))) ELSE tl = 0. ENDIF ENDIF dld(i,k,j) = zzz - dzt + tl found = 1 ENDIF zdo_sup = zdo izz = izz - 1 ELSE found = 1 ENDIF ENDDO ENDIF dlg(i,k,j) = (zfull(i,k,j)+zfull(i,k+1,j))/2.0 dld(i,k,j) = min(dld(i,k,j),dlg(i,k,j)) elmin(i,k,j) = min(dlu(i,k,j),dld(i,k,j)) elmin(i,k,j) = elmin(i,k,j)/(1. + (elmin(i,k,j)/2000.)) ENDDO ENDDO ENDDO END SUBROUTINE free_atmos_length !======================================================================= !======================================================================= SUBROUTINE horizontal_diffusion_2 ( rt_tendf, ru_tendf, rv_tendf, rw_tendf, & tke_tendf, & moist_tendf, n_moist, & chem_tendf, n_chem, & scalar_tendf, n_scalar, & tracer_tendf, n_tracer, & thp, theta, tke, config_flags, & defor11, defor22, defor12, & defor13, defor23, & nba_mij, n_nba_mij, & div, & moist, chem, scalar,tracer, & msfux, msfuy, msfvx, msfvy, & msftx, msfty, xkmh, xkmv, xkhh, km_opt, & rdx, rdy, rdz, rdzw, fnm, fnp, & cf1, cf2, cf3, zx, zy, dn, dnw, rho, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) !----------------------------------------------------------------------- ! Begin declarations. 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 INTEGER , INTENT(IN ) :: n_moist,n_chem,n_scalar,n_tracer,km_opt REAL , INTENT(IN ) :: cf1, cf2, cf3 REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnm REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnp REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: dnw REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: dn REAL , DIMENSION( ims:ime, jms:jme) , INTENT(IN ) :: msfux, & msfuy, & msfvx, & msfvy, & msftx, & msfty REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) ::rt_tendf,& ru_tendf,& rv_tendf,& rw_tendf,& tke_tendf REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_moist), & INTENT(INOUT) :: moist_tendf REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_chem), & INTENT(INOUT) :: chem_tendf REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_scalar), & INTENT(INOUT) :: scalar_tendf REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_tracer), & INTENT(INOUT) :: tracer_tendf REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_moist), & INTENT(IN ) :: moist REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_chem), & INTENT(IN ) :: chem REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_scalar) , & INTENT(IN ) :: scalar REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_tracer) , & INTENT(IN ) :: tracer REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN ) ::defor11, & defor22, & defor12, & defor13, & defor23, & div, & xkmh, & xkmv, & xkhh, & zx, & zy, & theta, & thp, & tke, & rdz, & rdzw, & rho REAL , INTENT(IN ) :: rdx, & rdy INTEGER, INTENT( IN ) :: n_nba_mij REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij), INTENT(INOUT) & :: nba_mij ! LOCAL VARS INTEGER :: im, ic, is ! REAL , DIMENSION(its-1:ite+1, kts:kte, jts-1:jte+1) :: xkhh ! End declarations. !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! Call diffusion subroutines. CALL horizontal_diffusion_u_2( ru_tendf, config_flags, & defor11, defor12, div, & nba_mij, n_nba_mij, & tke(ims,kms,jms), & msfux, msfuy, xkmh, rdx, rdy, fnm, fnp, & dnw, zx, zy, rdzw, rho, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) CALL horizontal_diffusion_v_2( rv_tendf, config_flags, & defor12, defor22, div, & nba_mij, n_nba_mij, & tke(ims,kms,jms), & msfvx, msfvy, xkmh, rdx, rdy, fnm, fnp, & dnw, zx, zy, rdzw, rho, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) CALL horizontal_diffusion_w_2( rw_tendf, config_flags, & defor13, defor23, div, & nba_mij, n_nba_mij, & tke(ims,kms,jms), & msftx, msfty, xkmv, rdx, rdy, fnm, fnp, & dn, zx, zy, rdz, rho, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) CALL horizontal_diffusion_s ( rt_tendf, config_flags, & thp, & msftx, msfty, msfux, msfuy, & msfvx, msfvy, xkhh, rdx, rdy, & fnm, fnp, cf1, cf2, cf3, & zx, zy, rdz, rdzw, dnw, dn, rho, & .false., & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) IF ( ((km_opt .eq. 2) .and. (.not.config_flags%tke_mix2_off)) & !XZ .or. (km_opt .eq. 5) ) & !XZ CALL horizontal_diffusion_s ( tke_tendf(ims,kms,jms), & config_flags, & tke(ims,kms,jms), & msftx, msfty, msfux, msfuy, & msfvx, msfvy, xkhh, rdx, rdy, & fnm, fnp, cf1, cf2, cf3, & zx, zy, rdz, rdzw, dnw, dn, rho, & .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) .and. (.not.config_flags%moist_mix2_off)) THEN moist_loop: do im = PARAM_FIRST_SCALAR, n_moist CALL horizontal_diffusion_s( moist_tendf(ims,kms,jms,im), & config_flags, & moist(ims,kms,jms,im), & msftx, msfty, msfux, msfuy, & msfvx, msfvy, xkhh, rdx, rdy, & fnm, fnp, cf1, cf2, cf3, & zx, zy, rdz, rdzw, dnw, dn, rho, & .false., & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) ENDDO moist_loop ENDIF IF ((n_chem .ge. PARAM_FIRST_SCALAR) .and. (.not.config_flags%chem_mix2_off)) THEN chem_loop: do ic = PARAM_FIRST_SCALAR, n_chem CALL horizontal_diffusion_s( chem_tendf(ims,kms,jms,ic), & config_flags, & chem(ims,kms,jms,ic), & msftx, msfty, msfux, msfuy, & msfvx, msfvy, xkhh, rdx, rdy, & fnm, fnp, cf1, cf2, cf3, & zx, zy, rdz, rdzw, dnw, dn, rho,& .false., & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) ENDDO chem_loop ENDIF IF ((n_tracer .ge. PARAM_FIRST_SCALAR) .and. (.not.config_flags%tracer_mix2_off)) THEN tracer_loop: do ic = PARAM_FIRST_SCALAR, n_tracer CALL horizontal_diffusion_s( tracer_tendf(ims,kms,jms,ic), & config_flags, & tracer(ims,kms,jms,ic), & msftx, msfty, msfux, msfuy, & msfvx, msfvy, xkhh, rdx, rdy, & fnm, fnp, cf1, cf2, cf3, & zx, zy, rdz, rdzw, dnw, dn, rho, & .false., & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) ENDDO tracer_loop ENDIF IF ((n_scalar .ge. PARAM_FIRST_SCALAR) .and. (.not.config_flags%scalar_mix2_off)) THEN scalar_loop: do is = PARAM_FIRST_SCALAR, n_scalar CALL horizontal_diffusion_s( scalar_tendf(ims,kms,jms,is), & config_flags, & scalar(ims,kms,jms,is), & msftx, msfty, msfux, msfuy, & msfvx, msfvy, xkhh, rdx, rdy, & fnm, fnp, cf1, cf2, cf3, & zx, zy, rdz, rdzw, dnw, dn, rho, & .false., & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) ENDDO scalar_loop ENDIF END SUBROUTINE horizontal_diffusion_2 !======================================================================= !======================================================================= SUBROUTINE horizontal_diffusion_u_2( tendency, config_flags, & defor11, defor12, div, & nba_mij, n_nba_mij, & tke, & msfux, msfuy, & xkmh, rdx, rdy, fnm, fnp, & dnw, zx, zy, rdzw, rho, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) !----------------------------------------------------------------------- ! Begin declarations. 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( kms:kme ) , INTENT(IN ) :: fnm REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnp REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: dnw REAL , DIMENSION( ims:ime, jms:jme) , INTENT(IN ) :: msfux, & msfuy REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) ::tendency REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN ) :: rdzw, & rho REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN ) ::defor11, & defor12, & div, & tke, & xkmh, & zx, & zy INTEGER, INTENT( IN ) :: n_nba_mij REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij), INTENT(INOUT) & :: nba_mij REAL , INTENT(IN ) :: rdx, & rdy ! Local data 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, & titau2avg, & titau1, & titau2, & xkxavg, & rravg, & zy_at_u, & zx_at_u ! new ! zxavg, & ! zyavg REAL :: mrdx, mrdy, rcoup REAL :: tmpzy, tmpzeta_z REAL :: tmpdz REAL :: term1, term2, term3 ! End declarations. !----------------------------------------------------------------------- ktf=MIN(kte,kde-1) !----------------------------------------------------------------------- ! u : p (.), u(|), w(-) ! ! p u p u u u ! ! p | . | . | . | k+1 | . | . | . | k+1 ! ! w - 13 - - k+1 13 k+1 ! ! p | 11 O 11 | . | k | 12 O 12 | . | k ! ! w - 13 - - k 13 k ! ! p | . | . | . | k-1 | . | . | . | k-1 ! ! i-1 i i i+1 j-1 j j j+1 j+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 ! titau1 = titau11 is_ext=1 ie_ext=0 js_ext=0 je_ext=0 CALL cal_titau_11_22_33( config_flags, titau1, & tke, xkmh, defor11, & nba_mij(ims,kms,jms,P_m11), rho, & 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 ) ! titau2 = titau12 is_ext=0 ie_ext=0 js_ext=0 je_ext=1 CALL cal_titau_12_21( config_flags, titau2, & xkmh, defor12, & nba_mij(ims,kms,jms,P_m12), rho, & 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 ) ! titau1avg = titau11avg ! titau2avg = titau12avg DO j = j_start, j_end DO k = kts+1,ktf DO i = i_start, i_end 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))) 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))) ! tmpzy = 0.25*( zy(i-1,k,j )+zy(i,k,j )+ & ! zy(i-1,k,j+1)+zy(i,k,j+1) ) ! tmpzeta_z = 0.5*(zeta_z(i,j)+zeta_z(i-1,j)) ! titau1avg(i,k,j)=titau1avg(i,k,j)*zx(i,k,j)*tmpzeta_z ! titau2avg(i,k,j)=titau2avg(i,k,j)*tmpzy *tmpzeta_z zx_at_u(i, k, j) = 0.5 * (zx(i, k, j) + zx(i, k + 1 , j)) zy_at_u(i, k, j) = 0.125 * (zy(i - 1, k, j) + zy(i, k, j) + & zy(i - 1, k, j + 1) + zy(i, k, j + 1) + zy(i - 1, k + 1, j) + & zy(i, k + 1, j) + zy(i - 1, k + 1, j + 1) + zy(i, k + 1, j + 1)) ! titau1avg(i,k,j)=titau1avg(i,k,j)*zx(i,k,j) ! titau2avg(i,k,j)=titau2avg(i,k,j)*tmpzy ENDDO ENDDO ENDDO ! DO j = j_start, j_end DO i = i_start, i_end titau1avg(i,kts,j)=0. titau1avg(i,ktf+1,j)=0. titau2avg(i,kts,j)=0. titau2avg(i,ktf+1,j)=0. zx_at_u(i, kts, j) = 0.5 * (zx(i, kts, j) + zx(i, kts + 1 , j)) zy_at_u(i, kts, j) = 0.125 * (zy(i - 1, kts, j) + zy(i, kts, j) + & zy(i - 1, kts, j + 1) + zy(i, kts, j + 1) + zy(i - 1, kts + 1, j) + & zy(i, kts + 1, j) + zy(i - 1, kts + 1, j + 1) + zy(i, kts + 1, j + 1)) ENDDO ENDDO ! DO j = j_start, j_end DO k = kts,ktf DO i = i_start, i_end mrdx=msfux(i,j)*rdx mrdy=msfuy(i,j)*rdy tmpdz = (1./rdzw(i,k,j)+1./rdzw(i-1,k,j))/2. tendency(i,k,j)=tendency(i,k,j) + g*tmpdz/dnw(k) * & (mrdx*(titau1(i,k,j ) - titau1(i-1,k,j)) + & mrdy*(titau2(i,k,j+1) - titau2(i ,k,j)) - & msfux(i,j)*zx_at_u(i,k,j)*(titau1avg(i,k+1,j)-titau1avg(i,k,j)) / tmpdz - & msfuy(i,j)*zy_at_u(i,k,j)*(titau2avg(i,k+1,j)-titau2avg(i,k,j)) / tmpdz & ) ENDDO ENDDO ENDDO END SUBROUTINE horizontal_diffusion_u_2 !======================================================================= !======================================================================= SUBROUTINE horizontal_diffusion_v_2( tendency, config_flags, & defor12, defor22, div, & nba_mij, n_nba_mij, & tke, & msfvx, msfvy, & xkmh, rdx, rdy, fnm, fnp, & dnw, zx, zy, rdzw, rho, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) !----------------------------------------------------------------------- ! Begin declarations. 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( kms:kme ) , INTENT(IN ) :: fnm REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnp REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: dnw REAL , DIMENSION( ims:ime, jms:jme) , INTENT(IN ) :: msfvx, & msfvy REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN ) ::defor12, & defor22, & div, & tke, & xkmh, & zx, & zy, & rdzw, & rho INTEGER, INTENT( IN ) :: n_nba_mij REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij), INTENT(INOUT) & :: nba_mij REAL , INTENT(IN ) :: rdx, & rdy ! Local data 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, & titau2avg, & titau1, & titau2, & xkxavg, & rravg, & zy_at_v, & zx_at_v ! new ! zxavg, & ! zyavg REAL :: mrdx, mrdy, rcoup REAL :: tmpdz REAL :: tmpzx, tmpzeta_z ! End declarations. !----------------------------------------------------------------------- ktf=MIN(kte,kde-1) !----------------------------------------------------------------------- ! v : p (.), v(+), w(-) ! ! p v p v v v ! ! p + . + . + . + k+1 + . + . + . + k+1 ! ! w - 23 - - k+1 23 k+1 ! ! p + 22 O 22 + . + k + 21 O 21 + . + k ! ! w - 23 - - k 23 k ! ! p + . + . + . + k-1 + . + . + . + k-1 ! ! j-1 j j j+1 i-1 i i i+1 i+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) ! titau1 = titau21 is_ext=0 ie_ext=1 js_ext=0 je_ext=0 CALL cal_titau_12_21( config_flags, titau1, & xkmh, defor12, & nba_mij(ims,kms,jms,P_m12),rho, & 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 ) ! titau2 = titau22 is_ext=0 ie_ext=0 js_ext=1 je_ext=0 CALL cal_titau_11_22_33( config_flags, titau2, & tke, xkmh, defor22, & nba_mij(ims,kms,jms,P_m22),rho, & 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 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))) 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))) ! tmpzx = 0.25*( zx(i,k,j )+zx(i+1,k,j )+ & ! zx(i,k,j-1)+zx(i+1,k,j-1) ) zx_at_v(i, k, j) = 0.125 * (zx(i, k, j) + zx(i + 1, k, j) + & zx(i, k, j - 1) + zx(i + 1, k, j - 1) + zx(i, k + 1, j) + & zx(i + 1, k + 1, j) + zx(i, k + 1, j - 1) + zx(i + 1, k + 1, j - 1)) zy_at_v(i, k, j) = 0.5 * (zy(i, k, j) + zy(i, k + 1 , j)) ! titau1avg(i,k,j)=titau1avg(i,k,j)*tmpzx ! titau2avg(i,k,j)=titau2avg(i,k,j)*zy(i,k,j) ENDDO ENDDO ENDDO DO j = j_start, j_end DO i = i_start, i_end titau1avg(i,kts,j)=0. titau1avg(i,ktf+1,j)=0. titau2avg(i,kts,j)=0. titau2avg(i,ktf+1,j)=0. zx_at_v(i, kts, j) = 0.125 * (zx(i, kts, j) + zx(i + 1, kts, j) + & zx(i, kts, j - 1) + zx(i + 1, kts, j - 1) + zx(i, kts + 1, j) + & zx(i + 1, kts + 1, j) + zx(i, kts + 1, j - 1) + zx(i + 1, kts + 1, j - 1)) zy_at_v(i, kts, j) = 0.5 * (zy(i, kts, j) + zy(i, kts + 1 , j)) ENDDO ENDDO ! DO j = j_start, j_end DO k = kts,ktf DO i = i_start, i_end mrdx=msfvx(i,j)*rdx mrdy=msfvy(i,j)*rdy tmpdz = (1./rdzw(i,k,j)+1./rdzw(i,k,j-1))/2. tendency(i,k,j)=tendency(i,k,j) + g*tmpdz/dnw(k) * & (mrdy*(titau2(i,k,j ) - titau2(i,k,j-1)) + & mrdx*(titau1(i+1,k,j) - titau1(i ,k,j)) - & msfvx(i,j)*zx_at_v(i,k,j)*(titau1avg(i,k+1,j)-titau1avg(i,k,j)) / tmpdz - & msfvy(i,j)*zy_at_v(i,k,j)*(titau2avg(i,k+1,j)-titau2avg(i,k,j)) / tmpdz & ) ENDDO ENDDO ENDDO END SUBROUTINE horizontal_diffusion_v_2 !======================================================================= !======================================================================= SUBROUTINE horizontal_diffusion_w_2( tendency, config_flags, & defor13, defor23, div, & nba_mij, n_nba_mij, & tke, & msftx, msfty, & xkmv, rdx, rdy, fnm, fnp, & dn, zx, zy, rdz, rho, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) !----------------------------------------------------------------------- ! Begin declarations. 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( kms:kme ) , INTENT(IN ) :: fnm REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnp REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: dn REAL , DIMENSION( ims:ime, jms:jme) , INTENT(IN ) :: msftx, & msfty REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN ) ::defor13, & defor23, & div, & tke, & xkmv, & zx, & zy, & rdz, & rho INTEGER, INTENT( IN ) :: n_nba_mij REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij), INTENT(INOUT) & :: nba_mij REAL , INTENT(IN ) :: rdx, & rdy ! Local data 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, & titau2avg, & titau1, & titau2, & xkxavg, & rravg, & zx_at_w, & zy_at_w ! new ! zxavg, & ! zyavg REAL :: mrdx, mrdy, rcoup REAL :: tmpzx, tmpzy, tmpzeta_z ! ! End declarations. !----------------------------------------------------------------------- ktf=MIN(kte,kde-1) !----------------------------------------------------------------------- ! w : p (.), u(|), v(+), w(-) ! ! p u p u p v p v ! ! w - - - k+1 w - - - k+1 ! ! p . | 33 | . k p . + 33 + . k ! ! w - 31 O 31 - k w - 32 O 32 - k ! ! p . | 33 | . k-1 p . | 33 | . k-1 ! ! w - - - k-1 w - - - k-1 ! ! i-1 i i i+1 j-1 j j j+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) ! titau1 = titau31 is_ext=0 ie_ext=1 js_ext=0 je_ext=0 CALL cal_titau_13_31( config_flags, titau1, defor13, & nba_mij(ims,kms,jms,P_m13), & xkmv, fnm, fnp, rho, & 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 ) ! titau2 = titau32 is_ext=0 ie_ext=0 js_ext=0 je_ext=1 CALL cal_titau_23_32( config_flags, titau2, defor23, & nba_mij(ims,kms,jms,P_m23), & xkmv, fnm, fnp, rho, & 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 ) ! titau1avg = titau31avg * zx * zeta_z = titau13avg * zx * zeta_z ! titau2avg = titau32avg * zy * zeta_z = titau23avg * zy * zeta_z DO j = j_start, j_end DO k = kts,ktf DO i = i_start, i_end 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)) 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)) zx_at_w(i, k, j) = 0.5 * (zx(i, k, j) + zx(i + 1, k, j)) zy_at_w(i, k, j) = 0.5 * (zy(i, k, j) + zy(i, k, j + 1)) ! new ! tmpzx =0.25*( zx(i,k ,j)+zx(i+1,k ,j)+ & ! zx(i,k+1,j)+zx(i+1,k+1,j) ) ! tmpzy =0.25*( zy(i,k ,j)+zy(i,k ,j+1)+ & ! zy(i,k+1,j)+zy(i,k+1,j+1) ) ! titau1avg(i,k,j)=titau1avg(i,k,j)*tmpzx ! titau2avg(i,k,j)=titau2avg(i,k,j)*tmpzy ! titau1avg(i,k,j)=titau1avg(i,k,j)*tmpzx*zeta_z(i,j) ! titau2avg(i,k,j)=titau2avg(i,k,j)*tmpzy*zeta_z(i,j) ENDDO ENDDO ENDDO DO j = j_start, j_end DO i = i_start, i_end titau1avg(i,ktf+1,j)=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 mrdx=msftx(i,j)*rdx mrdy=msfty(i,j)*rdy tendency(i,k,j)=tendency(i,k,j) + g/(dn(k)*rdz(i,k,j)) * & (mrdx*(titau1(i+1,k,j)-titau1(i,k,j))+ & mrdy*(titau2(i,k,j+1)-titau2(i,k,j))- & msfty(i,j)*rdz(i,k,j)*(zx_at_w(i,k,j)*(titau1avg(i,k,j)-titau1avg(i,k-1,j))+ & zy_at_w(i,k,j)*(titau2avg(i,k,j)-titau2avg(i,k-1,j)) & ) & ) ENDDO ENDDO ENDDO END SUBROUTINE horizontal_diffusion_w_2 !======================================================================= !======================================================================= SUBROUTINE horizontal_diffusion_s (tendency, config_flags, & var, & msftx, msfty, msfux, msfuy, & msfvx, msfvy, xkhh, rdx, rdy, & fnm, fnp, cf1, cf2, cf3, & zx, zy, rdz, rdzw, dnw, dn, rho, & doing_tke, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) !----------------------------------------------------------------------- ! Begin declarations. 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 LOGICAL, INTENT(IN ) :: doing_tke REAL , INTENT(IN ) :: cf1, cf2, cf3 REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnm REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnp REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: dn REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: dnw REAL , DIMENSION( ims:ime, jms:jme) , INTENT(IN ) :: msfux REAL , DIMENSION( ims:ime, jms:jme) , INTENT(IN ) :: msfuy REAL , DIMENSION( ims:ime, jms:jme) , INTENT(IN ) :: msfvx REAL , DIMENSION( ims:ime, jms:jme) , INTENT(IN ) :: msfvy REAL , DIMENSION( ims:ime, jms:jme) , INTENT(IN ) :: msftx REAL , DIMENSION( ims:ime, jms:jme) , INTENT(IN ) :: msfty REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN ) :: & xkhh, & rdz, & rdzw, & rho REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN ) :: var, & zx, & zy REAL , INTENT(IN ) :: rdx, & rdy ! Local data 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, & H2avg, & H1, & H2, & xkxavg, & zx_at_m, & zy_at_m REAL , DIMENSION( its:ite, kts:kte, jts:jte) :: tmptendf REAL :: mrdx, mrdy, rcoup REAL :: tmpzx, tmpzy, tmpzeta_z, rdzu, rdzv INTEGER :: ktes1,ktes2 ! ! End declarations. !----------------------------------------------------------------------- ktf=MIN(kte,kde-1) !----------------------------------------------------------------------- ! scalars: t (.), u(|), v(+), w(-) ! ! t u t u t v t v ! ! w - 3 - k+1 w - 3 - k+1 ! ! t . 1 O 1 . k t . 2 O 2 . k ! ! w - 3 - k w - 3 - k ! ! t . | . | . k-1 t . + . + . k-1 ! ! w - - - k-1 w - - - k-1 ! ! t i-1 i i i+1 j-1 j j j+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) ! diffusion of the TKE needs mutiple 2 IF ( doing_tke ) THEN DO j = j_start, j_end DO k = kts,ktf DO i = i_start, i_end tmptendf(i,k,j)=tendency(i,k,j) ENDDO ENDDO ENDDO ENDIF ! H1 = partial var over partial x DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end + 1 xkxavg(i,k,j)=0.5*(xkhh(i-1,k,j)+xkhh(i,k,j))*0.5*(rho(i-1,k,j)+rho(i,k,j)) ENDDO ENDDO ENDDO DO j = j_start, j_end DO k = kts+1, ktf DO i = i_start, i_end + 1 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 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)) 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 ! new tmpzx = 0.5*( zx(i,k,j)+ zx(i,k+1,j)) rdzu = 2./(1./rdzw(i,k,j) + 1./rdzw(i-1,k,j)) H1(i,k,j)=-msfux(i,j)*xkxavg(i,k,j)*( & rdx*(var(i,k,j)-var(i-1,k,j)) - tmpzx* & (H1avg(i,k+1,j)-H1avg(i,k,j))*rdzu ) ! tmpzeta_z = 0.5*(zeta_z(i,j)+zeta_z(i-1,j)) ! H1(i,k,j)=-msfuy(i,j)*xkxavg(i,k,j)*( & ! rdx*(var(i,k,j)-var(i-1,k,j)) - tmpzx*tmpzeta_z* & ! (H1avg(i,k+1,j)-H1avg(i,k,j))/dnw(k)) ENDDO ENDDO ENDDO ! H2 = partial var over partial y DO j = j_start, j_end + 1 DO k = kts, ktf DO i = i_start, i_end xkxavg(i,k,j)=0.5*(xkhh(i,k,j-1)+xkhh(i,k,j))*0.5*(rho(i,k,j-1)+rho(i,k,j)) ENDDO ENDDO ENDDO DO j = j_start, j_end + 1 DO k = kts+1, ktf DO i = i_start, i_end 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 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)) 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 ! new tmpzy = 0.5*( zy(i,k,j)+ zy(i,k+1,j)) rdzv = 2./(1./rdzw(i,k,j) + 1./rdzw(i,k,j-1)) H2(i,k,j)=-msfvy(i,j)*xkxavg(i,k,j)*( & rdy*(var(i,k,j)-var(i,k,j-1)) - tmpzy* & (H2avg(i ,k+1,j)-H2avg(i,k,j))*rdzv) ! tmpzeta_z = 0.5*(zeta_z(i,j)+zeta_z(i,j-1)) ! H2(i,k,j)=-msfvy(i,j)*xkxavg(i,k,j)*( & ! rdy*(var(i,k,j)-var(i,k,j-1)) - tmpzy*tmpzeta_z* & ! (H2avg(i ,k+1,j)-H2avg(i,k,j))/dnw(k)) ENDDO ENDDO ENDDO DO j = j_start, j_end DO k = kts+1, ktf DO i = i_start, i_end 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))) 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))) ! new ! zxavg(i,k,j)=fnm(k)*zx(i,k,j)+fnp(k)*zx(i,k-1,j) ! zyavg(i,k,j)=fnm(k)*zy(i,k,j)+fnp(k)*zy(i,k-1,j) ! H1avg(i,k,j)=zx*H1avg*zeta_z ! H2avg(i,k,j)=zy*H2avg*zeta_z zx_at_m(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)) zy_at_m(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)) ! H1avg(i,k,j)=H1avg(i,k,j)*tmpzx*zeta_z(i,j) ! H2avg(i,k,j)=H2avg(i,k,j)*tmpzy*zeta_z(i,j) ENDDO ENDDO ENDDO DO j = j_start, j_end DO i = i_start, i_end H1avg(i,kts ,j)=0. H1avg(i,ktf+1,j)=0. H2avg(i,kts ,j)=0. H2avg(i,ktf+1,j)=0. zx_at_m(i, kts, j) = 0.25*(zx(i,kts,j)+ zx(i+1,kts,j) + zx(i,kts+1,j)+ zx(i+1,kts+1,j)) zy_at_m(i, kts, j) = 0.25*(zy(i,kts,j)+ zy(i,kts,j+1) + zy(i,kts+1,j)+ zy(i,kts+1,j+1)) ENDDO ENDDO DO j = j_start, j_end DO k = kts,ktf DO i = i_start, i_end mrdx=msftx(i,j)*rdx mrdy=msfty(i,j)*rdy tendency(i,k,j)=tendency(i,k,j) + g/(dnw(k)*rdzw(i,k,j)) * & (mrdx*(H1(i+1,k,j)-H1(i ,k,j)) + & mrdy*(H2(i,k,j+1)-H2(i,k,j )) - & msftx(i,j)*zx_at_m(i, k, j)*(H1avg(i,k+1,j)-H1avg(i,k,j))*rdzw(i,k,j) - & msfty(i,j)*zy_at_m(i, k, j)*(H2avg(i,k+1,j)-H2avg(i,k,j))*rdzw(i,k,j) & ) ENDDO ENDDO ENDDO IF ( doing_tke ) THEN DO j = j_start, j_end DO k = kts,ktf DO i = i_start, i_end tendency(i,k,j)=tmptendf(i,k,j)+2.* & (tendency(i,k,j)-tmptendf(i,k,j)) ENDDO ENDDO ENDDO ENDIF END SUBROUTINE horizontal_diffusion_s !======================================================================= !======================================================================= SUBROUTINE vertical_diffusion_2 ( ru_tendf, rv_tendf, rw_tendf, rt_tendf, & tke_tendf, moist_tendf, n_moist, & chem_tendf, n_chem, & scalar_tendf, n_scalar, & tracer_tendf, n_tracer, & u_2, v_2, & thp,u_base,v_base,t_base,qv_base,tke, & theta, & config_flags,defor13,defor23,defor33, & nba_mij, n_nba_mij, & div, & moist,chem,scalar,tracer, & xkmv,xkhv,xkmh,km_opt, & ! xkmh added fnm, fnp, dn, dnw, rdz, rdzw, & hfx, qfx, ust, rho, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) !----------------------------------------------------------------------- ! Begin declarations. 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 INTEGER , INTENT(IN ) :: n_moist,n_chem,n_scalar,n_tracer,km_opt REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnm REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnp REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: dnw REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: dn REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: qv_base REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: u_base REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: v_base REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: t_base REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) ::ru_tendf,& rv_tendf,& rw_tendf,& tke_tendf,& rt_tendf REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_moist), & INTENT(INOUT) :: moist_tendf REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_chem), & INTENT(INOUT) :: chem_tendf REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_scalar) , & INTENT(INOUT) :: scalar_tendf REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_tracer) , & INTENT(INOUT) :: tracer_tendf REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_moist), & INTENT(INOUT) :: moist REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_chem), & INTENT(INOUT) :: chem REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_scalar) , & INTENT(IN ) :: scalar REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_tracer) , & INTENT(IN ) :: tracer REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN ) ::defor13, & defor23, & defor33, & div, & xkmv, & xkhv, & xkmh, & tke, & theta, & rdz, & u_2, & v_2, & rdzw INTEGER, INTENT( IN ) :: n_nba_mij REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij), INTENT(INOUT) & :: nba_mij REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN ) :: rho REAL , DIMENSION( ims:ime, jms:jme), INTENT(INOUT) :: hfx, & qfx REAL , DIMENSION( ims:ime, jms:jme), INTENT(IN ) :: ust REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: thp ! LOCAL VAR REAL , DIMENSION( ims:ime, kms:kme, jms:jme) :: var_mix INTEGER :: im, i,j,k INTEGER :: i_start, i_end, j_start, j_end ! REAL , DIMENSION( its:ite, kts:kte, jts:jte) :: xkhv !*************************************************************************** !*************************************************************************** !MODIFICA VARIABILI PER I FLUSSI ! REAL :: V0_u,V0_v,tao_xz,tao_yz,ustar,cd0 REAL :: xsfc,psi1,vk2,zrough,lnz REAL :: heat_flux, moist_flux, heat_flux0 REAL :: cpm ! !FINE MODIFICA VARIABILI PER I FLUSSI !*************************************************************************** ! ! End declarations. !----------------------------------------------------------------------- i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = MIN(jte,jde-1) ! !----------------------------------------------------------------------- CALL vertical_diffusion_u_2( ru_tendf, config_flags, & defor13, xkmv, & nba_mij, n_nba_mij, & dnw, rdzw, fnm, fnp, rho, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) CALL vertical_diffusion_v_2( rv_tendf, config_flags, & defor23, xkmv, & nba_mij, n_nba_mij, & dnw, rdzw, fnm, fnp, rho, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) CALL vertical_diffusion_w_2( rw_tendf, config_flags, & defor33, tke(ims,kms,jms), & nba_mij, n_nba_mij, & div, xkmh, & dn, rdz, fnm, fnp, rho, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) !***************************************** !***************************************** ! MODIFICA al flusso di momento alla parete ! vflux: SELECT CASE( config_flags%isfflx ) CASE (0) ! Assume cd a constant, specified in namelist cd0 = config_flags%tke_drag_coefficient ! constant drag coefficient ! set in namelist.input ! !calcolo del modulo della velocita DO j = j_start, j_end DO i = i_start, ite V0_u=0. tao_xz=0. 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 tao_xz=cd0*V0_u*u_2(i,kts,j) ru_tendf(i,kts,j)=ru_tendf(i,kts,j) + g*tao_xz*0.5*(rho(i,kts,j)+rho(i-1,kts,j))/dnw(kts) IF ( (config_flags%m_opt .EQ. 1) .OR. (config_flags%sfs_opt .GT. 0) ) THEN nba_mij(i,kts,j,P_m13) = -tao_xz ENDIF ENDDO ENDDO ! DO j = j_start, jte DO i = i_start, i_end V0_v=0. tao_yz=0. 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 tao_yz=cd0*V0_v*v_2(i,kts,j) rv_tendf(i,kts,j)=rv_tendf(i,kts,j) + g*tao_yz*0.5*(rho(i,kts,j)+rho(i,kts,j-1))/dnw(kts) IF ( (config_flags%m_opt .EQ. 1) .OR. (config_flags%sfs_opt .GT. 0) ) THEN nba_mij(i,kts,j,P_m23) = -tao_yz ENDIF ENDDO ENDDO CASE (1,2) ! ustar computed from surface routine DO j = j_start, j_end DO i = i_start, ite V0_u=0. tao_xz=0. 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 ustar=0.5*(ust(i,j)+ust(i-1,j)) tao_xz=ustar*ustar*u_2(i,kts,j)/V0_u ru_tendf(i,kts,j)=ru_tendf(i,kts,j) + g*tao_xz*0.5*(rho(i,kts,j)+rho(i-1,kts,j))/dnw(kts) IF ( (config_flags%m_opt .EQ. 1) .OR. (config_flags%sfs_opt .GT. 0) ) THEN nba_mij(i,kts,j,P_m13) = -tao_xz ENDIF ENDDO ENDDO DO j = j_start, jte DO i = i_start, i_end V0_v=0. tao_yz=0. 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 ustar=0.5*(ust(i,j)+ust(i,j-1)) tao_yz=ustar*ustar*v_2(i,kts,j)/V0_v rv_tendf(i,kts,j)=rv_tendf(i,kts,j) + g*tao_yz*0.5*(rho(i,kts,j)+rho(i,kts,j-1))/dnw(kts) IF ( (config_flags%m_opt .EQ. 1) .OR. (config_flags%sfs_opt .GT. 0) ) THEN nba_mij(i,kts,j,P_m23) = -tao_yz ENDIF ENDDO ENDDO CASE DEFAULT CALL wrf_error_fatal( 'isfflx value invalid for diff_opt=2' ) END SELECT vflux ! ! FINE MODIFICA al flusso di momento alla parete !***************************************** !***************************************** 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) 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) var_mix(i,k,j) = thp(i,k,j) - t_base(k) ENDDO ENDDO ENDDO END IF CALL vertical_diffusion_s( rt_tendf, config_flags, var_mix, xkhv, & dn, dnw, rdz, rdzw, fnm, fnp, rho, & .false., & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) !***************************************** !***************************************** !MODIFICA al flusso di calore ! ! hflux: SELECT CASE( config_flags%isfflx ) CASE (0,2) ! with fixed surface heat flux given in the namelist heat_flux = config_flags%tke_heat_flux ! constant heat flux value ! set in namelist.input DO j = j_start, j_end DO i = i_start, i_end cpm = cp * (1. + 0.8 * moist(i,kts,j,P_QV)) hfx(i,j)=heat_flux*cpm*rho(i,kts,j) ! provided for output only rt_tendf(i,kts,j)=rt_tendf(i,kts,j) & -g*heat_flux*rho(i,kts,j)/dnw(kts) if(config_flags%use_theta_m == 1)THEN rt_tendf(i,kts,j)=rt_tendf(i,kts,j) & -g*1.61*theta(i,kts,j)*qfx(i,j)/dnw(kts) ENDIF ENDDO ENDDO CASE (1) ! use surface heat flux computed from surface routine DO j = j_start, j_end DO i = i_start, i_end cpm = cp * (1. + 0.8 * moist(i,kts,j,P_QV)) heat_flux = hfx(i,j)/cpm rt_tendf(i,kts,j)=rt_tendf(i,kts,j) & -g*heat_flux/dnw(kts) if(config_flags%use_theta_m == 1)THEN rt_tendf(i,kts,j)=rt_tendf(i,kts,j) & -g*1.61*theta(i,kts,j)*qfx(i,j)/dnw(kts) ENDIF ENDDO ENDDO CASE DEFAULT CALL wrf_error_fatal( 'isfflx value invalid for diff_opt=2' ) END SELECT hflux ! ! FINE MODIFICA al flusso di calore !***************************************** !***************************************** If (km_opt .eq. 2) then CALL vertical_diffusion_s( tke_tendf(ims,kms,jms), & config_flags, tke(ims,kms,jms), & xkhv, & dn, dnw, rdz, rdzw, fnm, fnp, rho, & .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 moist_loop: 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) 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) var_mix(i,k,j) = moist(i,k,j,im) ENDDO ENDDO ENDDO END IF CALL vertical_diffusion_s( moist_tendf(ims,kms,jms,im), & config_flags, var_mix, & xkhv, & dn, dnw, rdz, rdzw, fnm, fnp, rho, & .false., & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) !***************************************** !***************************************** !MODIFICATIONS for water vapor flux ! ! qflux: SELECT CASE( config_flags%isfflx ) CASE (0) ! do nothing CASE (1,2) ! with surface moisture flux IF ( im == P_QV ) THEN DO j = j_start, j_end DO i = i_start, i_end moist_flux = qfx(i,j) moist_tendf(i,kts,j,im)=moist_tendf(i,kts,j,im) & -g*moist_flux/dnw(kts) ENDDO ENDDO ENDIF CASE DEFAULT CALL wrf_error_fatal( 'isfflx value invalid for diff_opt=2' ) END SELECT qflux ! ! END MODIFICATIONS for water vapor flux !***************************************** !***************************************** ENDDO moist_loop ENDIF IF (n_chem .ge. PARAM_FIRST_SCALAR) THEN chem_loop: do im = PARAM_FIRST_SCALAR, n_chem CALL vertical_diffusion_s( chem_tendf(ims,kms,jms,im), & config_flags, chem(ims,kms,jms,im), & xkhv, & dn, dnw, rdz, rdzw, fnm, fnp, rho, & .false., & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) ENDDO chem_loop ENDIF IF (n_tracer .ge. PARAM_FIRST_SCALAR) THEN tracer_loop: do im = PARAM_FIRST_SCALAR, n_tracer CALL vertical_diffusion_s( tracer_tendf(ims,kms,jms,im), & config_flags, tracer(ims,kms,jms,im), & xkhv, & dn, dnw, rdz, rdzw, fnm, fnp, rho, & .false., & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) ENDDO tracer_loop ENDIF IF (n_scalar .ge. PARAM_FIRST_SCALAR) THEN scalar_loop: do im = PARAM_FIRST_SCALAR, n_scalar CALL vertical_diffusion_s( scalar_tendf(ims,kms,jms,im), & config_flags, scalar(ims,kms,jms,im), & xkhv, & dn, dnw, rdz, rdzw, fnm, fnp, rho, & .false., & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) ENDDO scalar_loop ENDIF END SUBROUTINE vertical_diffusion_2 !======================================================================= !======================================================================= SUBROUTINE vertical_diffusion_u_2( tendency, config_flags, & defor13, xkmv, & nba_mij, n_nba_mij, & dnw, rdzw, fnm, fnp, rho, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) !----------------------------------------------------------------------- ! Begin declarations. 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( kms:kme ) , INTENT(IN ) :: fnm REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnp REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: dnw ! REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: zeta_z REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) ::tendency REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , & INTENT(IN ) ::defor13, & xkmv, & rdzw, & rho INTEGER, INTENT( IN ) :: n_nba_mij REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij), INTENT(INOUT) & :: nba_mij ! LOCAL VARS 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 REAL , DIMENSION( its:ite, jts:jte) :: zzavg REAL :: rdzu ! End declarations. !----------------------------------------------------------------------- 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 ! titau3 = titau13 is_ext=0 ie_ext=0 js_ext=0 je_ext=0 CALL cal_titau_13_31( config_flags, titau3, defor13, & nba_mij(ims,kms,jms,P_m13), & xkmv, fnm, fnp, rho, & 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 rdzu = -g/(dnw(k)) tendency(i,k,j)=tendency(i,k,j)-rdzu*(titau3(i,k+1,j)-titau3(i,k,j)) ENDDO ENDDO ENDDO ! ******** MODIF... ! we will pick up the surface drag (titau3(i,kts,j)) later ! DO j = j_start, j_end k=kts DO i = i_start, i_end rdzu = -g/dnw(k) tendency(i,k,j)=tendency(i,k,j)-rdzu*(titau3(i,k+1,j)) ENDDO ENDDO ! ******** MODIF... END SUBROUTINE vertical_diffusion_u_2 !======================================================================= !======================================================================= SUBROUTINE vertical_diffusion_v_2( tendency, config_flags, & defor23, xkmv, & nba_mij, n_nba_mij, & dnw, rdzw, fnm, fnp, rho, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) !----------------------------------------------------------------------- ! Begin declarations. 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( kms:kme ) , INTENT(IN ) :: fnm REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnp REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: dnw ! REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: zeta_z REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) ::tendency REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , & INTENT(IN ) ::defor23, & xkmv, & rdzw, & rho INTEGER, INTENT( IN ) :: n_nba_mij REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij), INTENT(INOUT) & :: nba_mij ! LOCAL VARS 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 REAL , DIMENSION( its:ite, jts:jte) :: zzavg REAL :: rdzv ! End declarations. !----------------------------------------------------------------------- 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) ! titau3 = titau23 is_ext=0 ie_ext=0 js_ext=0 je_ext=0 CALL cal_titau_23_32( config_flags, titau3, defor23, & nba_mij(ims,kms,jms,P_m23), & xkmv, fnm, fnp, rho, & 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 rdzv = - g / dnw(k) tendency(i,k,j)=tendency(i,k,j)-rdzv*(titau3(i,k+1,j)-titau3(i,k,j)) ENDDO ENDDO ENDDO ! ******** MODIF... ! we will pick up the surface drag (titau3(i,kts,j)) later ! DO j = j_start, j_end k=kts DO i = i_start, i_end rdzv = - g / dnw(k) tendency(i,k,j)=tendency(i,k,j)-rdzv*(titau3(i,k+1,j)) ENDDO ENDDO ! ******** MODIF... END SUBROUTINE vertical_diffusion_v_2 !======================================================================= !======================================================================= SUBROUTINE vertical_diffusion_w_2(tendency, config_flags, & defor33, tke, & nba_mij, n_nba_mij, & div, xkmh, & dn, rdz, fnm, fnp, rho, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) !----------------------------------------------------------------------- ! Begin declarations. 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( kms:kme ) , INTENT(IN ) :: dn, fnm, fnp REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) ::tendency REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , & INTENT(IN ) ::defor33, & tke, & div, & xkmh, & rdz, & rho INTEGER, INTENT( IN ) :: n_nba_mij REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij), INTENT(INOUT) & :: nba_mij ! LOCAL VARS 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 ! End declarations. !----------------------------------------------------------------------- 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) ! titau3 = titau33 is_ext=0 ie_ext=0 js_ext=0 je_ext=0 CALL cal_titau_11_22_33( config_flags, titau3, & tke, xkmh, defor33, & nba_mij(ims,kms,jms,P_m33), rho, & 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 ! titau3(i,k,j)=titau3(i,k,j)*zeta_z(i,j) ! ENDDO ! ENDDO ! ENDDO DO j = j_start, j_end DO k = kts+1, ktf DO i = i_start, i_end tendency(i,k,j)=tendency(i,k,j)+ g*(titau3(i,k,j)-titau3(i,k-1,j))/dn(k) ENDDO ENDDO ENDDO END SUBROUTINE vertical_diffusion_w_2 !======================================================================= !======================================================================= SUBROUTINE vertical_diffusion_s( tendency, config_flags, var, xkhv, & dn, dnw, rdz, rdzw, fnm, fnp, rho, & doing_tke, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) !----------------------------------------------------------------------- ! Begin declarations. 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 LOGICAL, INTENT(IN ) :: doing_tke REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnm REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnp REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: dn REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: dnw REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) ::tendency REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , INTENT(IN) :: xkhv REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , & INTENT(IN ) :: var, & rdz, & rdzw, & rho ! LOCAL VARS INTEGER :: i, j, k, ktf INTEGER :: i_start, i_end, j_start, j_end REAL , DIMENSION( its:ite, kts:kte, jts:jte) :: H3, & xkxavg, & rravg REAL , DIMENSION( its:ite, kts:kte, jts:jte) :: tmptendf ! End declarations. !----------------------------------------------------------------------- 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 tmptendf(i,k,j)=tendency(i,k,j) ENDDO ENDDO ENDDO ENDIF ! H3 xkxavg = 0. DO j = j_start, j_end DO k = kts+1,ktf DO i = i_start, i_end xkxavg(i,k,j)=fnm(k)*xkhv(i,k,j)+fnp(k)*xkhv(i,k-1,j) xkxavg(i,k,j)=xkxavg(i,k,j)*(fnm(k)*rho(i,k,j)+fnp(k)*rho(i,k-1,j)) H3(i,k,j)=-xkxavg(i,k,j)*(var(i,k,j)-var(i,k-1,j))*rdz(i,k,j) ENDDO ENDDO ENDDO DO j = j_start, j_end DO i = i_start, i_end H3(i,kts,j)=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 tendency(i,k,j)=tendency(i,k,j) & + g * (H3(i,k+1,j)-H3(i,k,j))/dnw(k) ENDDO ENDDO ENDDO IF (doing_tke) THEN DO j = j_start, j_end DO k = kts,ktf DO i = i_start, i_end tendency(i,k,j)=tmptendf(i,k,j)+2.* & (tendency(i,k,j)-tmptendf(i,k,j)) ENDDO ENDDO ENDDO ENDIF END SUBROUTINE vertical_diffusion_s !======================================================================= !======================================================================= SUBROUTINE nonlocal_flux (config_flags,nlflux,gamu,gamv,hpbl,kpbl, & dx,dy,dt,ust,hfx,qfx,br,ep1,ep2, & karman,u_phy,v_phy,th_phy,rho,moist,n_moist, & msftx,msfty,rdzw, & u10,v10,wspd, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) !----------------------------------------------------------------------- !This subroutine prescibes the nonlocal heat flux profile based on LES analysis !And compute the nonlocal momentum gamma term !References: ! Shin and Hong 2015, MWR ! Xu Zhang et al. 2018, MWR !----------------------------------------------------------------------- ! Begin declarations. 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 INTEGER , INTENT(IN ) :: n_moist REAL, INTENT(IN ) :: ep1,ep2,karman REAL, INTENT(IN ) :: dx,dy,dt REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) :: & th_phy,u_phy,v_phy REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) :: rdzw REAL, DIMENSION( ims:ime, kms:kme, jms:jme, n_moist ), INTENT( INOUT ) :: & moist REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) :: rho REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: hfx,qfx,br,ust,hpbl REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: u10,v10,wspd REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: msftx,msfty REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(OUT) :: nlflux REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: gamu,gamv INTEGER, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT ) :: kpbl ! Local variables. REAL, DIMENSION( its:ite, kts:kte, jts:jte ) :: zq REAL, DIMENSION( its:ite, kts:kte-1, jts:jte ) :: za,thv REAL, DIMENSION( its:ite, kts:kte, jts:jte ) :: zfacmf,entfacmf REAL, DIMENSION( its:ite, jts:jte ) :: govrth,sflux,wstar3,wstar,rigs LOGICAL, DIMENSION( its:ite,jts:jte ) :: pblflg, sfcflg, stable REAL, DIMENSION( its:ite, jts:jte ) :: deltaoh,we,enlfrac2 REAL, DIMENSION( its:ite, jts:jte ) :: hfxpbl,bfxpbl REAL, DIMENSION( its:ite, jts:jte ) :: dthv,wm2 REAL, DIMENSION( its:ite, jts:jte ) :: wscale,thermal REAL :: tvcon,delb,cpm,wm3,bfx0,ust3 REAL :: dtheta,du,dv,thsfc,brint INTEGER :: i,j,k,i_start,i_end,j_start,j_end,ktf REAL :: mlfrac,ezfrac,sfcfracn,sflux0,snlflux0 REAL :: amf1,amf2,amf3,bmf2,bmf3,pth1,delxy,pu1 REAL :: heat_flux REAL,PARAMETER :: phifac = 8.,sfcfrac = 0.1,d1 = 0.02, d2 = 0.05, zfmin = 1.e-8 REAL,PARAMETER :: h1 = 0.33333335, h2 = 0.6666667, tmin = 1.e-2 ! tunable parameters REAL,PARAMETER :: mltop = 1.0, sfcfracn1 = 0.075 REAL,PARAMETER :: nlfrac = 0.68 ! the ratio of nonlocal heat flux to total heat flux REAL,PARAMETER :: enlfrac = -0.15 REAL,PARAMETER :: a11 = 1.0, a12 = -1.15 REAL,PARAMETER :: ezfac = 1.5 REAL,PARAMETER :: cpent = -0.4, rigsmax = 100., rimin = -100. REAL,PARAMETER :: entfmin = 1.0, entfmax = 5.0, sm = 10.9 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 i = i_start, i_end zq(i,1,j) = 0.0 ENDDO ENDDO DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end zq(i,k+1,j) = 1.0/rdzw(i,k,j) + zq(i,k,j) ENDDO ENDDO ENDDO DO j = j_start,j_end DO k = kts,ktf DO i = i_start,i_end za(i,k,j) = 0.5*(zq(i,k,j) + zq(i,k+1,j)) ENDDO ENDDO ENDDO DO j = j_start, j_end DO i = i_start, i_end deltaoh(i,j) = 0.0 rigs (i,j) = 0.0 enlfrac2(i,j) = 0.0 ENDDO ENDDO DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end zfacmf(i,k,j) = 0.0 ENDDO ENDDO ENDDO DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end nlflux(i,k,j) = 0.0 ENDDO ENDDO ENDDO DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end tvcon = 1. + ep1*moist(i,k,j,P_QV) thv(i,k,j) = th_phy(i,k,j)*tvcon ENDDO ENDDO ENDDO DO j = j_start,j_end DO i = i_start,i_end govrth(i,j) = g/th_phy(i,1,j) ENDDO ENDDO hflux: SELECT CASE( config_flags%isfflx ) CASE (0,2) ! with fixed surface heat flux given in the namelist heat_flux = config_flags%tke_heat_flux ! constant heat flux value DO j = j_start, j_end DO i = i_start, i_end cpm = cp * (1. + 0.8 * moist(i,kts,j,P_QV)) hfx(i,j)= heat_flux*cpm*rho(i,1,j) ENDDO ENDDO CASE (1) ! use surface heat flux computed from surface routine DO j = j_start, j_end DO i = i_start, i_end cpm = cp * (1. + 0.8 * moist(i,kts,j,P_QV)) heat_flux = hfx(i,j)/cpm/rho(i,1,j) ENDDO ENDDO CASE DEFAULT CALL wrf_error_fatal( 'isfflx value invalid for diff_opt=2' ) END SELECT hflux DO j = j_start, j_end DO i = i_start, i_end kpbl(i,j) = 1 hpbl(i,j) = zq(i,1,j) pblflg(i,j) = .true. sfcflg(i,j) = .true. cpm = cp * (1. + 0.8*moist(i,1,j,P_QV)) sflux(i,j) = (hfx(i,j)/cpm)/rho(i,1,j) IF(br(i,j).GT.0.0) sfcflg(i,j) = .false. ENDDO ENDDO ! get pbl height begin based on theta method DO j = j_start, j_end DO i = i_start, i_end thsfc = thv(i,kts,j) + 0.5 DO k=kts+1,ktf IF(thv(i,k,j).GT.thsfc) THEN hpbl(i,j)=za(i,k-1,j)+(thsfc-thv(i,k-1,j))/(max(0.01,thv(i,k,j)-thv(i,k-1,j)))*(za(i,k,j)-za(i,k-1,j)) kpbl(i,j) = k GO TO 119 ENDIF ENDDO 119 CONTINUE ENDDO ENDDO DO j = j_start, j_end DO i = i_start, i_end IF(hpbl(i,j).LT.zq(i,2,j)) kpbl(i,j) = 1 IF(kpbl(i,j).LT.1) pblflg(i,j) = .false. ENDDO ENDDO DO j = j_start, j_end DO i = i_start, i_end IF(sfcflg(i,j))THEN bfx0 = max(sflux(i,j),0.) wstar3(i,j) = (govrth(i,j)*bfx0*hpbl(i,j)) wstar(i,j) = (wstar3(i,j))**h1 ELSE wstar(i,j) = 0. wstar3(i,j) = 0. ENDIF ust3 = ust(i,j)**3 wscale(i,j) = (ust3 + phifac*karman*wstar3(i,j)*0.5)**h1 wscale(i,j) = MIN(wscale(i,j), ust(i,j)*16.0) wscale(i,j) = MAX(wscale(i,j), ust(i,j)/5.0 ) ENDDO ENDDO DO j = j_start, j_end DO i = i_start, i_end delxy = sqrt(dx/msftx(i,j)*dy/msfty(i,j)) pu1=pu(delxy,hpbl(i,j)) IF(sfcflg(i,j).and.sflux(i,j).GT.0.0)THEN !nonlocal momentum flux based on Brown and Grant (1997) brint = -sm*ust(i,j)*ust(i,j)*wstar3(i,j)/(hpbl(i,j)*wscale(i,j)**4) gamu(i,j) = pu1 * brint*u_phy(i,1,j)/wspd(i,j) gamv(i,j) = pu1 * brint*v_phy(i,1,j)/wspd(i,j) ELSE pblflg(i,j) = .false. ENDIF ENDDO ENDDO DO j = j_start,j_end DO i = i_start,i_end IF(pblflg(i,j))THEN k = kpbl(i,j) - 1 wm3 = wstar3(i,j) + 5. * ust(i,j)**3 wm2(i,j) = wm3**h2 bfxpbl(i,j) = -0.15*thv(i,1,j)/g*wm3/hpbl(i,j) dthv(i,j) = max(thv(i,k+1,j) - thv(i,k,j),tmin) dtheta = max(th_phy(i,k+1,j) - th_phy(i,k,j),tmin) du = u_phy(i,k+1,j)-u_phy(i,k,j) dv = v_phy(i,k+1,j)-v_phy(i,k,j) we(i,j) = max(bfxpbl(i,j)/dthv(i,j),-sqrt(wm2(i,j))) hfxpbl(i,j) = we(i,j)*dtheta delb = govrth(i,j)*dthv(i,j) deltaoh(i,j) = d1*hpbl(i,j) + d2*wm2(i,j)/delb deltaoh(i,j) = max(ezfac*deltaoh(i,j),hpbl(i,j)-za(i,kpbl(i,j)-1,j)-1.) deltaoh(i,j) = min(deltaoh(i,j), hpbl(i,j)) rigs(i,j) = govrth(i,j)*dthv(i,j)*deltaoh(i,j)/(du**2.+dv**2.) rigs(i,j) = max(min(rigs(i,j), rigsmax),rimin) enlfrac2(i,j) = max(min(wm3/wstar3(i,j)/(1.+cpent/rigs(i,j)),entfmax),entfmin) enlfrac2(i,j) = enlfrac2(i,j)*enlfrac ENDIF ENDDO ENDDO DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end IF(pblflg(i,j))THEN entfacmf(i,k,j) = sqrt(((zq(i,k+1,j) - hpbl(i,j))/deltaoh(i,j))**2.) ENDIF ENDDO ENDDO ENDDO DO j = j_start, j_end DO i = i_start, i_end deltaoh(i,j) = deltaoh(i,j)/hpbl(i,j) ENDDO ENDDO DO j = j_start, j_end DO i = i_start, i_end delxy = sqrt(dx/msftx(i,j)*dy/msfty(i,j)) mlfrac = mltop-deltaoh(i,j) ezfrac = mltop+deltaoh(i,j) zfacmf(i,1,j) = min(max((zq(i,2,j)/hpbl(i,j)),zfmin),1.) sfcfracn = max(sfcfracn1,zfacmf(i,1,j)) ! sflux0 = (a11+a12*sfcfracn)*sflux(i,j) snlflux0 = nlfrac*sflux0 amf1 = snlflux0/sfcfracn amf2 = -snlflux0/(mlfrac-sfcfracn) bmf2 = -mlfrac*amf2 amf3 = snlflux0*enlfrac2(i,j)/deltaoh(i,j) bmf3 = -amf3*mlfrac hfxpbl(i,j) = amf3+bmf3 pth1 = pthnl(delxy,hpbl(i,j)) hfxpbl(i,j) = hfxpbl(i,j)*pth1 DO k = kts, ktf zfacmf(i,k,j) = max((zq(i,k+1,j)/hpbl(i,j)),zfmin) IF(pblflg(i,j).and.k.LT.kpbl(i,j)) THEN IF(zfacmf(i,k,j).LE.sfcfracn) THEN nlflux(i,k,j) = amf1*zfacmf(i,k,j) ELSE IF (zfacmf(i,k,j).LE.mlfrac) THEN nlflux(i,k,j) = amf2*zfacmf(i,k,j)+bmf2 ENDIF nlflux(i,k,j) = nlflux(i,k,j) + hfxpbl(i,j)*exp(-entfacmf(i,k,j)) nlflux(i,k,j) = nlflux(i,k,j)*pth1 ENDIF ENDDO ENDDO ENDDO END SUBROUTINE nonlocal_flux !============================================================================== !============================================================================== ! partial function for nonlocal heat flux FUNCTION pthnl(d,h) IMPLICIT NONE REAL :: pthnl REAL,PARAMETER :: pmin = 0.0,pmax = 1.0 REAL,PARAMETER :: a1 = 1.000, a2 = 0.936, a3 = -1.110, & a4 = 1.000, a5 = 0.312, a6 = 0.329, a7 = 0.243 REAL,PARAMETER :: b1 = 2.0, b2 = 0.875 real :: d,h,doh,num,den doh = d/h num = a1*(doh)**b1 + a2*(doh)**b2+a3 den = a4*(doh)**b1 + a5*(doh)**b2+a6 pthnl = a7*num/den + (1. - a7) pthnl = max(pthnl,pmin) pthnl = min(pthnl,pmax) IF(d.LE.100.) THEN ! assume dx<=100m as LES pthnl = 0.0 ENDIF RETURN END FUNCTION ! partial function for local heat flux FUNCTION pthl(d,h) IMPLICIT NONE REAL :: pthl REAL,PARAMETER :: pmin = 0.0,pmax = 1.0 REAL,PARAMETER :: a1 = 1.000, a2 = 0.870, a3 = -0.913, & a4 = 1.000, a5 = 0.153, a6 = 0.278, a7 = 0.280 REAL,PARAMETER :: b1 = 2.0, b2 = 0.5 REAL :: d,h,doh,num,den doh = d/h num = a1*(doh)**b1 + a2*(doh)**b2+a3 den = a4*(doh)**b1 + a5*(doh)**b2+a6 pthl = a7*num/den+(1. - a7) pthl = max(pthl,pmin) pthl = min(pthl,pmax) IF(d.LE.100.) THEN ! assume dx<=100m as LES pthl = 0.0 ENDIF RETURN END FUNCTION ! partial function for momentum flux FUNCTION pu(d,h) IMPLICIT NONE REAL :: pu REAL,PARAMETER :: pmin = 0.0,pmax = 1.0 REAL,PARAMETER :: a1 = 1.0, a2 = 0.070, a3 = 1.0, a4 = 0.142, a5 = 0.071 REAL,PARAMETER :: b1 = 2.0, b2 = 0.6666667 REAL :: d,h,doh,num,den doh = d/h num = a1*(doh)**b1 + a2*(doh)**b2 den = a3*(doh)**b1 + a4*(doh)**b2+a5 pu = num/den pu = max(pu,pmin) pu = min(pu,pmax) IF(d.LE.100.) THEN ! assume dx<=100 as LES pu = 0.0 ENDIF RETURN END FUNCTION !======================================================================= !======================================================================= SUBROUTINE cal_titau_11_22_33( config_flags, titau, & tke, xkx, defor, & mtau, rho, & 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 ) ! History: Sep 2003 Changes by George Bryan and Jason Knievel, NCAR ! Oct 2001 Converted to mass core by Bill Skamarock, NCAR ! Aug 2000 Original code by Shu-Hua Chen, UC-Davis ! Purpose: This routine calculates stress terms (taus) for use in ! the calculation of production of TKE by sheared wind ! References: Klemp and Wilhelmson (JAS 1978) ! Deardorff (B-L Meteor 1980) ! Chen and Dudhia (NCAR WRF physics report 2000) ! Key: !----------------------------------------------------------------------- ! Begin declarations. 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 INTEGER, INTENT( IN ) & :: is_ext, ie_ext, js_ext, je_ext REAL, DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1 ), INTENT( INOUT ) & :: titau REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN ) & :: defor, xkx, tke, rho REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) & :: mtau ! Local variables. INTEGER & :: i, j, k, ktf, i_start, i_end, j_start, j_end ! End declarations. !----------------------------------------------------------------------- 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 ! USE NBA MODEL SFS STRESSES DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end titau(i,k,j) = rho(i,k,j) * mtau(i,k,j) END DO END DO END DO ELSE !NOT NBA IF ( config_flags%m_opt .EQ. 1 ) THEN ! ASSIGN STRESS TO MTAU FOR OUTPUT DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end titau(i,k,j) = - rho(i,k,j) * xkx(i,k,j) * defor(i,k,j) mtau(i,k,j) = - xkx(i,k,j) * defor(i,k,j) END DO END DO END DO ELSE !NO STRESS OUTPUT DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end titau(i,k,j) = - rho(i,k,j) * xkx(i,k,j) * defor(i,k,j) END DO END DO END DO ENDIF ENDIF END SUBROUTINE cal_titau_11_22_33 !======================================================================= !======================================================================= SUBROUTINE cal_titau_12_21( config_flags, titau, & xkx, defor, & mtau, rho, & 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 ) ! History: Sep 2003 Modifications by George Bryan and Jason Knievel, NCAR ! Oct 2001 Converted to mass core by Bill Skamarock, NCAR ! Aug 2000 Original code by Shu-Hua Chen, UC-Davis ! Pusrpose This routine calculates the stress terms (taus) for use in ! the calculation of production of TKE by sheared wind ! References: Klemp and Wilhelmson (JAS 1978) ! Deardorff (B-L Meteor 1980) ! Chen and Dudhia (NCAR WRF physics report 2000) ! Key: !----------------------------------------------------------------------- ! Begin declarations. 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 INTEGER, INTENT( IN ) & :: is_ext, ie_ext, js_ext, je_ext REAL, DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1 ), INTENT( INOUT ) & :: titau REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN ) & :: defor, xkx, rho REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) & :: mtau ! Local variables. 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 ! End declarations. !----------------------------------------------------------------------- ktf = MIN( kte, kde-1 ) ! Needs one more point in the x and y directions. 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 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) ) xkxavg(i,k,j) = xkxavg(i,k,j) * .25 * ( rho(i-1,k,j ) + rho(i,k,j ) + & rho(i-1,k,j-1) + rho(i,k,j-1) ) END DO END DO END DO ! titau12 or titau21 IF ( config_flags%sfs_opt .GT. 0 ) THEN ! USE NBA MODEL SFS STRESSES DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end titau(i,k,j) = rho(i,k,j) * mtau(i,k,j) END DO END DO END DO ELSE ! NOT NBA IF ( config_flags%m_opt .EQ. 1 ) THEN ! ASSIGN STRESS TO MTAU FOR OUTPUT DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end titau(i,k,j) = - xkxavg(i,k,j) * defor(i,k,j) mtau(i,k,j) = - xkxavg(i,k,j) * defor(i,k,j) / rho(i,k,j) END DO END DO END DO ELSE ! NO STRESS OUTPUT DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end titau(i,k,j) = - xkxavg(i,k,j) * defor(i,k,j) END DO END DO END DO ENDIF ENDIF END SUBROUTINE cal_titau_12_21 !======================================================================= SUBROUTINE cal_titau_13_31( config_flags, titau, & defor, & mtau, & xkx, fnm, fnp, rho, & 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 ) ! History: Sep 2003 Modifications by George Bryan and Jason Knievel, NCAR ! Oct 2001 Converted to mass core by Bill Skamarock, NCAR ! Aug 2000 Original code by Shu-Hua Chen, UC-Davis ! Purpose: This routine calculates the stress terms (taus) for use in ! the calculation of production of TKE by sheared wind ! References: Klemp and Wilhelmson (JAS 1978) ! Deardorff (B-L Meteor 1980) ! Chen and Dudhia (NCAR WRF physics report 2000) ! Key: !----------------------------------------------------------------------- ! Begin declarations. 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 INTEGER, INTENT( IN ) & :: is_ext, ie_ext, js_ext, je_ext REAL, DIMENSION( kms:kme ), INTENT( IN ) & :: fnm, fnp REAL, DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1 ), INTENT( INOUT ) & :: titau REAL, DIMENSION( ims:ime, kms:kme, jms:jme), INTENT( IN ) & :: defor, xkx, rho REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) & :: mtau ! Local variables. 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 ! End declarations. !----------------------------------------------------------------------- ktf = MIN( kte, kde-1 ) ! Find ide-1 and jde-1 for averaging to p point. 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 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) ) ) xkxavg(i,k,j) = xkxavg(i,k,j) * 0.5 * ( fnm(k) * ( rho(i-1,k ,j) + rho(i,k ,j) ) + & fnp(k) * ( rho(i-1,k-1,j) + rho(i,k-1,j) ) ) END DO END DO END DO IF ( config_flags%sfs_opt .GT. 0 ) THEN ! USE NBA MODEL SFS STRESSES DO j = j_start, j_end DO k = kts+1, ktf DO i = i_start, i_end titau(i,k,j) = rho(i,k,j) * mtau(i,k,j) ENDDO ENDDO ENDDO ELSE ! NOT NBA IF ( config_flags%m_opt .EQ. 1 ) THEN ! ASSIGN STRESS TO MTAU FOR OUTPUT DO j = j_start, j_end DO k = kts+1, ktf DO i = i_start, i_end titau(i,k,j) = - xkxavg(i,k,j) * defor(i,k,j) mtau(i,k,j) = - xkxavg(i,k,j) * defor(i,k,j) / rho(i,k,j) ENDDO ENDDO ENDDO ELSE ! NO STRESS OUTPUT DO j = j_start, j_end DO k = kts+1, ktf DO i = i_start, i_end titau(i,k,j) = - xkxavg(i,k,j) * defor(i,k,j) ENDDO ENDDO ENDDO ENDIF ENDIF DO j = j_start, j_end DO i = i_start, i_end titau(i,kts ,j) = 0.0 titau(i,ktf+1,j) = 0.0 ENDDO ENDDO END SUBROUTINE cal_titau_13_31 !======================================================================= !======================================================================= SUBROUTINE cal_titau_23_32( config_flags, titau, defor, & mtau, & xkx, fnm, fnp, rho, & 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 ) ! History: Sep 2003 Changes by George Bryan and Jason Knievel, NCAR ! Oct 2001 Converted to mass core by Bill Skamarock, NCAR ! Aug 2000 Original code by Shu-Hua Chen, UC-Davis ! Purpose: This routine calculates stress terms (taus) for use in ! the calculation of production of TKE by sheared wind ! References: Klemp and Wilhelmson (JAS 1978) ! Deardorff (B-L Meteor 1980) ! Chen and Dudhia (NCAR WRF physics report 2000) ! Key: !----------------------------------------------------------------------- ! Begin declarations. 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 INTEGER, INTENT( IN ) & :: is_ext,ie_ext,js_ext,je_ext REAL, DIMENSION( kms:kme ), INTENT( IN ) & :: fnm, fnp REAL, DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1 ), INTENT( INOUT ) & :: titau REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN ) & :: defor, xkx, rho REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) & :: mtau ! Local variables. 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 ! End declarations. !----------------------------------------------------------------------- ktf = MIN( kte, kde-1 ) ! Find ide-1 and jde-1 for averaging to p point. 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 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) ) ) xkxavg(i,k,j) = xkxavg(i,k,j) * 0.5 * ( fnm(k) * ( rho(i,k ,j) + rho(i,k ,j-1) ) + & fnp(k) * ( rho(i,k-1,j) + rho(i,k-1,j-1) ) ) END DO END DO END DO IF ( config_flags%sfs_opt .GT. 0 ) THEN ! USE NBA MODEL SFS STRESSES DO j = j_start, j_end DO k = kts+1, ktf DO i = i_start, i_end titau(i,k,j) = rho(i,k,j) * mtau(i,k,j) END DO END DO END DO ELSE ! NOT NBA IF ( config_flags%m_opt .EQ. 1 ) THEN ! ASSIGN STRESS TO MTAU FOR OUTPUT DO j = j_start, j_end DO k = kts+1, ktf DO i = i_start, i_end titau(i,k,j) = - xkxavg(i,k,j) * defor(i,k,j) mtau(i,k,j) = - xkxavg(i,k,j) * defor(i,k,j) / rho(i,k,j) END DO END DO END DO ELSE ! NO STRESS OUTPUT DO j = j_start, j_end DO k = kts+1, ktf DO i = i_start, i_end titau(i,k,j) = - xkxavg(i,k,j) * defor(i,k,j) END DO END DO END DO ENDIF ENDIF DO j = j_start, j_end DO i = i_start, i_end titau(i,kts ,j) = 0.0 titau(i,ktf+1,j) = 0.0 END DO END DO END SUBROUTINE cal_titau_23_32 !======================================================================= !======================================================================= SUBROUTINE phy_bc ( config_flags,div,defor11,defor22,defor33, & defor12,defor13,defor23,xkmh,xkmv,xkhh,xkhv,tke,rho, & RUBLTEN, RVBLTEN, & RUCUTEN, RVCUTEN, & RUSHTEN, RVSHTEN, & gamu, gamv, xkmv_meso, & ! XZ ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, kpe, & its, ite, jts, jte, kts, kte ) !------------------------------------------------------------------------------ ! Begin declarations. 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, & ips, ipe, jps, jpe, kps, kpe, & its, ite, jts, jte, kts, kte REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) ::RUBLTEN, & RVBLTEN, & RUCUTEN, & RVCUTEN, & RUSHTEN, & RVSHTEN, & defor11, & defor22, & defor33, & defor12, & defor13, & defor23, & xkmh, & xkmv, & xkhh, & xkhv, & xkmv_meso, & ! XZ tke, & div, & rho !XZ REAL , DIMENSION( ims:ime, jms:jme), INTENT(INOUT) :: gamu, gamv ! End declarations. !----------------------------------------------------------------------- IF(config_flags%bl_pbl_physics .GT. 0) THEN CALL set_physical_bc3d( 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 set_physical_bc3d( 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 IF(config_flags%cu_physics .GT. 0) THEN CALL set_physical_bc3d( 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 set_physical_bc3d( 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 set_physical_bc3d( 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 set_physical_bc3d( 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 ! move out of the conditional, below; horiz coeffs needed for ! all diff_opt cases. JM CALL set_physical_bc3d( 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 set_physical_bc3d( 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 set_physical_bc3d( 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 set_physical_bc3d( 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 set_physical_bc3d( 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 set_physical_bc3d( 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 set_physical_bc3d( 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 set_physical_bc3d( 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 set_physical_bc3d( 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 set_physical_bc3d( 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 set_physical_bc3d( 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 ) CALL set_physical_bc3d( rho , '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 !XZ IF(config_flags%diff_opt .eq. 2 .and. config_flags%km_opt .eq. 5) THEN CALL set_physical_bc2d( gamu, 't', config_flags, & ids, ide, jds, jde, & ims, ime, jms, jme, & ips, ipe, jps, jpe, & its, ite, jts, jte ) CALL set_physical_bc2d( gamv, 't', config_flags, & ids, ide, jds, jde, & ims, ime, jms, jme, & ips, ipe, jps, jpe, & its, ite, jts, jte ) CALL set_physical_bc3d( xkmv_meso,'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 ! END SUBROUTINE phy_bc !======================================================================= !======================================================================= SUBROUTINE tke_rhs( tendency, BN2, config_flags, & defor11, defor22, defor33, & defor12, defor13, defor23, & u, v, w, div, tke, mu, c1, c2, & theta, p, p8w, t8w, z, fnm, fnp, & cf1, cf2, cf3, msftx, msfty, & xkmh, xkmv, xkhv, & rdx, rdy, dx, dy, dt, zx, zy, & rdz, rdzw, dn, dnw, isotropic, & hfx, qfx, qv, ust, rho, & l_diss, nlflux, hpbl, dlk, & !XZ ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) !----------------------------------------------------------------------- ! Begin declarations. 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 INTEGER, INTENT( IN ) :: isotropic REAL, INTENT( IN ) & :: cf1, cf2, cf3, dt, rdx, rdy, dx, dy REAL, DIMENSION( kms:kme ), INTENT( IN ) & :: fnm, fnp, dnw, dn REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN ) & :: msftx, msfty REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) & :: tendency REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN ) & :: defor11, defor22, defor33, defor12, defor13, defor23, & div, BN2, tke, xkmh, xkmv, xkhv, zx, zy, u, v, w, theta, & p, p8w, t8w, z, rdz, rdzw REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN ) & :: mu REAL, DIMENSION( kms:kme) , INTENT( IN ) & :: c1, c2 REAL, DIMENSION ( ims:ime, jms:jme ), INTENT( IN ) & :: hfx, ust, qfx REAL, DIMENSION ( ims:ime, kms:kme, jms:jme ), INTENT ( IN ) & :: qv, rho ! XZ REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( OUT ) & :: l_diss REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT ( IN ) & :: nlflux, dlk REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) & :: hpbl ! ! Local variables. INTEGER & :: i, j, k, ktf, i_start, i_end, j_start, j_end ! End declarations. !----------------------------------------------------------------------- CALL tke_shear( tendency, config_flags, & defor11, defor22, defor33, & defor12, defor13, defor23, & u, v, w, tke, ust, mu, & c1, c2, fnm, fnp, & cf1, cf2, cf3, msftx, msfty, & xkmh, xkmv, & rdx, rdy, zx, zy, rdz, rdzw, dnw, dn, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) CALL tke_buoyancy( tendency, config_flags, mu, & c1, c2, & tke, xkhv, BN2, theta, dt, & hfx, qfx, qv, rho, & nlflux, & ! XZ ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) CALL tke_dissip( tendency, config_flags, mu, c1, c2, & tke, bn2, theta, p8w, t8w, z, & dx, dy,rdz, rdzw, isotropic, & msftx, msfty, & hpbl, dlk, l_diss, & ! XZ ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) ! Set a lower limit on TKE. 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 tendency(i,k,j) = max( tendency(i,k,j), -(c1(k)*mu(i,j)+c2(k)) * max( 0.0 , tke(i,k,j) ) / dt ) END DO END DO END DO END SUBROUTINE tke_rhs !======================================================================= !======================================================================= SUBROUTINE tke_buoyancy( tendency, config_flags, mu, & c1, c2, & tke, xkhv, BN2, theta, dt, & hfx, qfx, qv, rho, & nlflux, & ! XZ ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) !----------------------------------------------------------------------- ! Begin declarations. 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 ) & :: dt REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) & :: tendency REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN ) & :: xkhv, tke, BN2, theta REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN ) & :: mu REAL, DIMENSION( kms:kme) , INTENT( IN ) & :: c1, c2 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT ( IN ) & :: qv, rho REAL, DIMENSION(ims:ime, jms:jme ), INTENT ( IN ) :: hfx, qfx !XZ REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT ( IN ) & :: nlflux ! ! Local variables. INTEGER & :: i, j, k, ktf INTEGER & :: i_start, i_end, j_start, j_end REAL :: heat_flux, heat_flux0 REAL :: cpm ! End declarations. !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! Add to the TKE tendency the term that accounts for production of TKE ! due to buoyant motions. 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 ) !XZ IF(config_flags%km_opt.eq.5) THEN DO j = j_start, j_end DO k = kts+1, ktf DO i = i_start, i_end tendency(i,k,j) = tendency(i,k,j) - (c1(k)*mu(i,j)+c2(k)) * (xkhv(i,k,j) * BN2(i,k,j) & - 0.5*(nlflux(i,k+1,j)+nlflux(i,k,j))*g/theta(i,k,j)) END DO END DO END DO ELSE DO j = j_start, j_end DO k = kts+1, ktf DO i = i_start, i_end tendency(i,k,j) = tendency(i,k,j) - (c1(k)*mu(i,j)+c2(k)) * xkhv(i,k,j) * BN2(i,k,j) END DO END DO END DO ENDIF ! MARTA: change in the computation of the tke's tendency at the surface. ! the buoyancy flux is the average of the surface heat flux (0.06) and the ! flux at the first w level ! ! WCS 040331 hflux: SELECT CASE( config_flags%isfflx ) CASE (0,2) ! with fixed surface heat flux given in the namelist heat_flux0 = config_flags%tke_heat_flux ! constant heat flux value ! set in namelist.input ! LES mods K=KTS DO j = j_start, j_end DO i = i_start, i_end heat_flux = heat_flux0 tendency(i,k,j)= tendency(i,k,j) - & (c1(k)*mu(i,j)+c2(k))*((xkhv(i,k,j)*BN2(i,k,j))- (g/theta(i,k,j))*heat_flux)/2. ENDDO ENDDO CASE (1) ! use surface heat flux computed from surface routine K=KTS DO j = j_start, j_end DO i = i_start, i_end cpm = cp * (1. + 0.8*qv(i,k,j)) heat_flux = (hfx(i,j)/cpm)/rho(i,k,j) tendency(i,k,j)= tendency(i,k,j) - & (c1(k)*mu(i,j)+c2(k))*((xkhv(i,k,j)*BN2(i,k,j))- (g/theta(i,k,j))*heat_flux)/2. ENDDO ENDDO CASE DEFAULT CALL wrf_error_fatal( 'isfflx value invalid for diff_opt=2' ) END SELECT hflux ! end of MARTA/WCS change ! The tendency array now includes production of TKE from buoyant ! motions. !----------------------------------------------------------------------- END SUBROUTINE tke_buoyancy !======================================================================= !======================================================================= SUBROUTINE tke_dissip( tendency, config_flags, & mu, c1, c2, & tke, bn2, theta, p8w, t8w, z, & dx, dy, rdz, rdzw, isotropic, & msftx, msfty, & hpbl, dlk, l_diss, & !XZ ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) ! History: Sep 2003 Changes by George Bryan and Jason Knievel, NCAR ! Oct 2001 Converted to mass core by Bill Skamarock, NCAR ! Aug 2000 Original code by Shu-Hua Chen, UC-Davis ! Purpose: This routine calculates dissipation of turbulent kinetic ! energy. ! References: Klemp and Wilhelmson (JAS 1978) ! Deardorff (B-L Meteor 1980) ! Chen and Dudhia (NCAR WRF physics report 2000) !----------------------------------------------------------------------- ! Begin declarations. 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 INTEGER, INTENT( IN ) :: isotropic REAL, INTENT( IN ) & :: dx, dy REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) & :: tendency REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN ) & :: tke, bn2, theta, p8w, t8w, z, rdz, rdzw REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN ) & :: mu REAL, DIMENSION( kms:kme) , INTENT( IN ) & :: c1, c2 REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN ) & :: msftx, msfty ! XZ REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) & :: hpbl REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) & :: dlk REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(OUT) & :: l_diss ! ! Local variables. REAL, DIMENSION( its:ite, kts:kte, jts:jte ) & :: dthrdn REAL, DIMENSION( its:ite, kts:kte, jts:jte ) & :: l_scale REAL, DIMENSION( its:ite ) & :: sumtke, sumtkez INTEGER & :: i, j, k, ktf, i_start, i_end, j_start, j_end REAL & :: disp_len, deltas, coefc, tmpdz, len_s, thetasfc, & thetatop, len_0, tketmp, tmp, ce1, ce2, c_k !XZ REAL & :: delxy,coefc_m,pu1 ! ! End declarations. !----------------------------------------------------------------------- c_k = config_flags%c_k ce1 = ( c_k / 0.10 ) * 0.19 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 calc_l_scale( config_flags, tke, BN2, l_scale, & i_start, i_end, ktf, j_start, j_end, & dx, dy, 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 deltas = ( dx/msftx(i,j) * dy/msfty(i,j) / rdzw(i,k,j) )**0.33333333 tketmp = MAX( tke(i,k,j), 1.0e-6 ) ! Apply Deardorff's (1980) "wall effect" at the bottom of the domain. ! For LES with fine grid, no need for this wall effect! IF ( k .eq. kts .or. k .eq. ktf ) then coefc = 3.9 ELSE coefc = ce1 + ce2 * l_scale(i,k,j) / deltas END IF ! XZ IF(config_flags%km_opt.eq.5) THEN delxy = SQRT(dx/msftx(i,j)*dy/msfty(i,j)) pu1 = pu(delxy,hpbl(i,j)) coefc_m = 0.3 ! l_diss(i,k,j) = (1.0-pu1)*l_scale(i,k,j)/coefc + pu1*dlk(i,k,j)/coefc_m ELSE tendency(i,k,j) = tendency(i,k,j) - & (c1(k)*mu(i,j)+c2(k)) * coefc * tketmp**1.5 / l_scale(i,k,j) ENDIF ! END DO END DO END DO END SUBROUTINE tke_dissip !======================================================================= !======================================================================= SUBROUTINE tke_shear( tendency, config_flags, & defor11, defor22, defor33, & defor12, defor13, defor23, & u, v, w, tke, ust, mu, c1, c2, & fnm, fnp, & cf1, cf2, cf3, msftx, msfty, & xkmh, xkmv, & rdx, rdy, zx, zy, rdz, rdzw, dn, dnw, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) ! History: Sep 2003 Rewritten by George Bryan and Jason Knievel, ! NCAR ! Oct 2001 Converted to mass core by Bill Skamarock, NCAR ! Aug 2000 Original code by Shu-Hua Chen, UC-Davis ! Purpose: This routine calculates the production of turbulent ! kinetic energy by stresses due to sheared wind. ! References: Klemp and Wilhelmson (JAS 1978) ! Deardorff (B-L Meteor 1980) ! Chen and Dudhia (NCAR WRF physics report 2000) ! Key: ! avg temporary working array ! cf1 ! cf2 ! cf3 ! defor11 deformation term ( du/dx + du/dx ) ! defor12 deformation term ( dv/dx + du/dy ); same as defor21 ! defor13 deformation term ( dw/dx + du/dz ); same as defor31 ! defor22 deformation term ( dv/dy + dv/dy ) ! defor23 deformation term ( dw/dy + dv/dz ); same as defor32 ! defor33 deformation term ( dw/dz + dw/dz ) ! div 3-d divergence ! dn ! dnw ! fnm ! fnp ! msftx ! msfty ! rdx ! rdy ! tendency ! titau tau (stress tensor) with a tilde, indicating division by ! a map-scale factor and the fraction of the total modeled ! atmosphere beneath a given altitude (titau = tau/m/zeta) ! tke turbulent kinetic energy !----------------------------------------------------------------------- ! Begin declarations. 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 ) & :: cf1, cf2, cf3, rdx, rdy REAL, DIMENSION( kms:kme ), INTENT( IN ) & :: fnm, fnp, dn, dnw REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN ) & :: msftx, msfty REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) & :: tendency REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN ) & :: defor11, defor22, defor33, defor12, defor13, defor23, & tke, xkmh, xkmv, zx, zy, u, v, w, rdz, rdzw REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN ) & :: mu REAL, DIMENSION( kms:kme) , INTENT( IN ) & :: c1, c2 REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN ) & :: ust ! Local variables. 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 REAL, DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1 ) & :: avg, titau, tmp2 REAL, DIMENSION( its:ite, kts:kte, jts:jte ) & :: titau12, tmp1, zxavg, zyavg REAL :: absU, cd0, Cd ! End declarations. !----------------------------------------------------------------------- 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 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) ) 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) ) END DO END DO END DO ! Begin calculating production of turbulence due to shear. The approach ! is to add together contributions from six terms, each of which is the ! square of a deformation that is then multiplied by an exchange ! coefficiant. The same exchange coefficient is assumed for horizontal ! and vertical coefficients for some of the terms (the vertical value is ! the one used). ! For defor11. DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end tendency(i,k,j) = tendency(i,k,j) + 0.5 * & (c1(k)*mu(i,j)+c2(k)) * xkmh(i,k,j) * ( ( defor11(i,k,j) )**2 ) END DO END DO END DO ! For defor22. DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end tendency(i,k,j) = tendency(i,k,j) + 0.5 * & (c1(k)*mu(i,j)+c2(k)) * xkmh(i,k,j) * ( ( defor22(i,k,j) )**2 ) END DO END DO END DO ! For defor33. DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end tendency(i,k,j) = tendency(i,k,j) + 0.5 * & (c1(k)*mu(i,j)+c2(k)) * xkmv(i,k,j) * ( ( defor33(i,k,j) )**2 ) END DO END DO END DO ! For defor12. DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end 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 ) ) END DO END DO END DO DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end tendency(i,k,j) = tendency(i,k,j) + (c1(k)*mu(i,j)+c2(k)) * xkmh(i,k,j) * avg(i,k,j) END DO END DO END DO ! For defor13. DO j = j_start, j_end DO k = kts+1, ktf DO i = i_start, i_end+1 tmp2(i,k,j) = defor13(i,k,j) END DO END DO END DO DO j = j_start, j_end DO i = i_start, i_end+1 tmp2(i,kts ,j) = 0.0 tmp2(i,ktf+1,j) = 0.0 END DO END DO DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end 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 ) ) END DO END DO END DO DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end tendency(i,k,j) = tendency(i,k,j) + (c1(k)*mu(i,j)+c2(k)) * xkmv(i,k,j) * avg(i,k,j) END DO END DO END DO !MARTA: add the drag at the surface; WCS 040331 K=KTS uflux: SELECT CASE( config_flags%isfflx ) CASE (0) ! Assume cd a constant, specified in namelist cd0 = config_flags%tke_drag_coefficient ! drag coefficient set ! in namelist.input DO j = j_start, j_end DO i = i_start, i_end absU=0.5*sqrt((u(i,k,j)+u(i+1,k,j))**2+(v(i,k,j)+v(i,k,j+1))**2) Cd = cd0 tendency(i,k,j) = tendency(i,k,j) + & (c1(k)*mu(i,j)+c2(k))*( (u(i,k,j)+u(i+1,k,j))*0.5* & Cd*absU*(defor13(i,kts+1,j)+defor13(i+1,kts+1,j))*0.5 ) END DO END DO CASE (1,2) ! ustar computed from surface routine DO j = j_start, j_end DO i = i_start, i_end 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 Cd = (ust(i,j)**2)/(absU**2) tendency(i,k,j) = tendency(i,k,j) + & (c1(k)*mu(i,j)+c2(k))*( (u(i,k,j)+u(i+1,k,j))*0.5* & Cd*absU*(defor13(i,kts+1,j)+defor13(i+1,kts+1,j))*0.5 ) END DO END DO CASE DEFAULT CALL wrf_error_fatal( 'isfflx value invalid for diff_opt=2' ) END SELECT uflux ! end of MARTA/WCS change ! For defor23. DO j = j_start, j_end+1 DO k = kts+1, ktf DO i = i_start, i_end tmp2(i,k,j) = defor23(i,k,j) END DO END DO END DO DO j = j_start, j_end+1 DO i = i_start, i_end tmp2(i,kts, j) = 0.0 tmp2(i,ktf+1,j) = 0.0 END DO END DO DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end 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) ) END DO END DO END DO DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end tendency(i,k,j) = tendency(i,k,j) + (c1(k)*mu(i,j)+c2(k)) * xkmv(i,k,j) * avg(i,k,j) END DO END DO END DO !MARTA: add the drag at the surface; WCS 040331 K=KTS vflux: SELECT CASE( config_flags%isfflx ) CASE (0) ! Assume cd a constant, specified in namelist cd0 = config_flags%tke_drag_coefficient ! constant drag coefficient ! set in namelist.input DO j = j_start, j_end DO i = i_start, i_end absU=0.5*sqrt((u(i,k,j)+u(i+1,k,j))**2+(v(i,k,j)+v(i,k,j+1))**2) Cd = cd0 tendency(i,k,j) = tendency(i,k,j) + & (c1(k)*mu(i,j)+c2(k))*( (v(i,k,j)+v(i,k,j+1))*0.5* & Cd*absU*(defor23(i,kts+1,j)+defor23(i,kts+1,j+1))*0.5 ) END DO END DO CASE (1,2) ! ustar computed from surface routine DO j = j_start, j_end DO i = i_start, i_end 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 Cd = (ust(i,j)**2)/(absU**2) tendency(i,k,j) = tendency(i,k,j) + & (c1(k)*mu(i,j)+c2(k))*( (v(i,k,j)+v(i,k,j+1))*0.5* & Cd*absU*(defor23(i,kts+1,j)+defor23(i,kts+1,j+1))*0.5 ) END DO END DO CASE DEFAULT CALL wrf_error_fatal( 'isfflx value invalid for diff_opt=2' ) END SELECT vflux ! end of MARTA/WCS change END SUBROUTINE tke_shear !======================================================================= !======================================================================= SUBROUTINE compute_diff_metrics( config_flags, ph, phb, z, rdz, rdzw, & zx, zy, rdx, rdy, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) !----------------------------------------------------------------------- ! Begin declarations. 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( OUT ) & :: rdz, rdzw, zx, zy, z REAL, INTENT( IN ) & :: rdx, rdy ! Local variables. REAL, DIMENSION( its-1:ite, kts:kte, jts-1:jte ) & :: z_at_w INTEGER & :: i, j, k, i_start, i_end, j_start, j_end, ktf ! End declarations. !----------------------------------------------------------------------- ktf = MIN( kte, kde-1 ) ! 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 ! Begin with dz computations. DO j = j_start, j_end IF ( ( j_start >= jts ) .AND. ( j_end <= MIN( jte, jde-1 ) ) ) THEN i_start = its-1 i_end = ite ELSE i_start = its i_end = MIN( ite, ide-1 ) 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_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 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 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 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 i_end = MIN( ite, ide-1 ) j_start = jts j_end = MIN( jte, jde-1 ) DO j = j_start, j_end DO k = 1, kte DO i = MAX( ids+1, its ), i_end 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 DO i = MAX( ids+1, its ), i_end 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 DO j = MAX( jds+1, jts ), j_end DO k = 1, kte DO i = i_start, i_end zy(i,k,j) = rdy * ( phb(i,k,j) - phb(i,k,j-1) ) / g END DO END DO END DO DO j = MAX( jds+1, jts ), j_end DO k = 1, kte DO i = i_start, i_end 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 == ide ) THEN DO j = j_start, j_end DO k = 1, ktf zx(ide,k,j) = 0.0 END DO END DO END IF IF ( its == ids ) THEN DO j = j_start, j_end DO k = 1, ktf zx(ids,k,j) = 0.0 END DO END DO END IF ELSE IF ( ite == ide ) THEN DO j=j_start,j_end DO k=1,ktf 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 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 == ids ) THEN DO j = j_start, j_end DO k = 1, ktf 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 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 == jde ) THEN DO k =1, ktf DO i =i_start, i_end zy(i,k,jde) = 0.0 END DO END DO END IF IF ( jts == jds ) THEN DO k =1, ktf DO i =i_start, i_end zy(i,k,jds) = 0.0 END DO END DO END IF ELSE IF ( jte == jde ) THEN DO k=1, ktf DO i =i_start, i_end 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 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 == jds ) THEN DO k = 1, ktf DO i =i_start, i_end 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 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 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 compute_diff_metrics SUBROUTINE cal_helicity ( config_flags, u, v, w, uh, up_heli_max,& ph, phb, & msfux, msfuy, & msfvx, msfvy, & ht, & rdx, rdy, dn, dnw, rdz, rdzw, & fnm, fnp, cf1, cf2, cf3, zx, zy, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) ! History: Apr 2007 Coded by Scott Dembek, USRA, basically using ! code segments stolen from the deformation ! and divergence subroutine. ! ... ... ! Purpose: This routine calculates updraft helicity. ! w ( dv/dx - du/dy ) ! References: !----------------------------------------------------------------------- ! Begin declarations. 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 ) & :: rdx, rdy, cf1, cf2, cf3 REAL, DIMENSION( kms:kme ), INTENT( IN ) & :: fnm, fnp, dn, dnw REAL, DIMENSION( ims:ime , jms:jme ), INTENT( IN ) & :: msfux, msfuy, msfvx, msfvy, ht REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN ) & :: u, v, w, ph, phb, zx, zy, rdz, rdzw REAL, DIMENSION( ims:ime, jms:jme ), INTENT( INOUT ) & :: uh, up_heli_max ! Local variables. INTEGER & :: i, j, k, ktf, ktes1, ktes2, i_start, i_end, j_start, j_end REAL & :: tmp, tmpzx, tmpzy, tmpzeta_z, cft1, cft2 REAL & :: zl, zu, uh_smth REAL, DIMENSION( its-3:ite+2, jts-3:jte+2 ) :: mm REAL, DIMENSION( its-3:ite+2, kts:kte, jts-3:jte+2 ) & :: tmp1, hat, hatavg REAL, DIMENSION( its-3:ite+2, kts:kte, jts-3:jte+2 ) & :: wavg, rvort LOGICAL, DIMENSION( its-3:ite+2, jts-3:jte+2 ) & :: use_column ! End declarations. !----------------------------------------------------------------------- !======================================================================= ! In the following section, calculate the vertical component of the ! relative vorticity as the first two terms of the updraft helicity ! w ( dv/dx - du/dy ). ktes1 = kte-1 ktes2 = kte-2 cft2 = - 0.5 * dnw(ktes1) / dn(ktes1) cft1 = 1.0 - cft2 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-2 ) IF ( config_flags%open_xe .OR. config_flags%specified .OR. & config_flags%nested) i_end = MIN( ide-1, ite+2 ) IF ( config_flags%open_ys .OR. config_flags%specified .OR. & config_flags%nested) j_start = MAX( jds+1, jts-2 ) IF ( config_flags%open_ye .OR. config_flags%specified .OR. & config_flags%nested) j_end = MIN( jde-1, jte+2 ) IF ( config_flags%periodic_x ) i_start = its IF ( config_flags%periodic_x ) i_end = ite !----------------------------------------------------------------------- ! Calculate dv/dx. ! First, calculate an average mapscale factor. ! Comments 10-MAR-05 ! du/dy => need u map scale factor in x (which is defined at u points) ! averaged over j and j-1 ! dv/dx => need v map scale factor in y (which is defined at v points) ! averaged over i and i-1 DO j = j_start, j_end DO i = i_start, i_end mm(i,j) = 0.25 * ( msfux(i,j-1) + msfux(i,j) ) * ( msfvy(i-1,j) + msfvy(i,j) ) END DO END DO ! Apply a coordinate transformation to meridional velocity, v. DO j = j_start, j_end DO k = kts, ktf DO i = i_start-1, i_end hat(i,k,j) = v(i,k,j) / msfvy(i,j) END DO END DO END DO ! Account for the slope in x of eta surfaces. DO j = j_start, j_end DO k = kts+1, ktf DO i = i_start, i_end 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) ) ) END DO END DO END DO ! Extrapolate to top and bottom of domain (to w levels). DO j = j_start, j_end DO i = i_start, i_end 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) ) hatavg(i,kte,j) = 0.5 * ( & cft1 * ( hat(i,ktes1,j) + hat(i-1,ktes1,j) ) + & cft2 * ( hat(i,ktes2,j) + hat(i-1,ktes2,j) ) ) END DO END DO ! Fixes to set_physical_bc2/3d have made any check for polar B.C.'s ! unnecessary in this place. zx, rdzw, and hatavg are all defined ! in places they need to be and the values at the poles are replications ! of the values one grid point in, so the averaging over j and j-1 works ! to act as just using the value at j or j-1 (with out extra code). ! ! tmpzx = averaged value of dpsi/dx (=zx) on vorticity grid ! tmp1 = partial dpsi/dx * partial dv^/dpsi DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end tmpzx = 0.25 * ( & zx(i,k ,j-1) + zx(i,k ,j) + & zx(i,k+1,j-1) + zx(i,k+1,j) ) tmp1(i,k,j) = ( hatavg(i,k+1,j) - hatavg(i,k,j) ) * & 0.25 * tmpzx * ( rdzw(i,k,j) + rdzw(i,k,j-1) + & rdzw(i-1,k,j-1) + rdzw(i-1,k,j) ) END DO END DO END DO ! End calculation of dv/dx. !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! Calculate the first parenthetical term of ! updraft helicity = w ( dv/dx - du/dy ) at vorticity points. DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end rvort(i,k,j) = mm(i,j) * ( & rdx * ( hat(i,k,j) - hat(i-1,k,j) ) - tmp1(i,k,j) ) END DO END DO END DO ! End calculation of the first parenthetical term of updraft helicity. !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! Calculate du/dy. ! Apply a coordinate transformation to zonal velocity, u. DO j =j_start-1, j_end DO k =kts, ktf DO i =i_start, i_end ! Fixes to set_physical_bc2/3d for polar boundary conditions ! remove issues with loop over j hat(i,k,j) = u(i,k,j) / msfux(i,j) END DO END DO END DO ! Average in y and z. DO j=j_start,j_end DO k=kts+1,ktf DO i=i_start,i_end 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) ) ) END DO END DO END DO ! Extrapolate to top and bottom of domain (to w levels). DO j = j_start, j_end DO i = i_start, i_end 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 ) ) hatavg(i,kte,j) = 0.5 * ( & cft1 * ( hat(i,ktes1,j-1) + hat(i,ktes1,j) ) + & cft2 * ( hat(i,ktes2,j-1) + hat(i,ktes2,j) ) ) END DO END DO ! tmpzy = averaged value of dpsi/dy (=zy) on vorticity grid ! tmp1 = partial dpsi/dy * partial du^/dpsi DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end tmpzy = 0.25 * ( & zy(i-1,k ,j) + zy(i,k ,j) + & zy(i-1,k+1,j) + zy(i,k+1,j) ) tmp1(i,k,j) = ( hatavg(i,k+1,j) - hatavg(i,k,j) ) * & 0.25 * tmpzy * ( rdzw(i,k,j) + rdzw(i-1,k,j) + & rdzw(i-1,k,j-1) + rdzw(i,k,j-1) ) END DO END DO END DO ! End calculation of du/dy. !---------------------------------------------------------------------- !----------------------------------------------------------------------- ! Add (subtract, actually) the second parenthetical term to ! updraft helicity = w ( dv/dx - du/dy ) at vorticity points. DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end rvort(i,k,j) = rvort(i,k,j) - & mm(i,j) * ( & rdy * ( hat(i,k,j) - hat(i,k,j-1) ) - tmp1(i,k,j) ) END DO END DO END DO ! End addition of the second parenthetical term to updraft helicity. !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! Update the boundary for the vorticity. IF ( .NOT. config_flags%periodic_x .AND. i_start .EQ. ids+1 ) THEN DO j = jts, jte DO k = kts, kte rvort(ids,k,j) = rvort(ids+1,k,j) END DO END DO END IF IF ( .NOT. config_flags%periodic_y .AND. j_start .EQ. jds+1) THEN DO k = kts, kte DO i = its, ite rvort(i,k,jds) = rvort(i,k,jds+1) END DO END DO END IF IF ( .NOT. config_flags%periodic_x .AND. i_end .EQ. ide-1) THEN DO j = jts, jte DO k = kts, kte rvort(ide,k,j) = rvort(ide-1,k,j) END DO END DO END IF IF ( .NOT. config_flags%periodic_y .AND. j_end .EQ. jde-1) THEN DO k = kts, kte DO i = its, ite rvort(i,k,jde) = rvort(i,k,jde-1) END DO END DO END IF ! End update of boundary for the vorticity. !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! Calculate an 8-point average of w used to complete the ! calculation of updraft helicity = w ( dv/dx - du/dy ). DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end wavg(i,k,j) = 0.125 * ( & w(i,k ,j ) + w(i-1,k ,j ) + & w(i,k ,j-1) + w(i-1,k ,j-1) + & w(i,k+1,j ) + w(i-1,k+1,j ) + & w(i,k+1,j-1) + w(i-1,k+1,j-1) ) END DO END DO END DO ! End addition of the average w calculation for updraft helicity. !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! Complete the updraft helicity calculation, only including columns with ! positive vertical velocity between the 2000 m and 5000 m levels. DO j = j_start, j_end DO i = i_start, i_end use_column(i,j) = .true. uh(i,j) = 0. END DO END DO ! We want zl and zu to be the height above ground, so we subtract ! the terrain elevation from the geopotential/g. DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end zl = ( 0.25 * ( & (( ph(i ,k ,j ) + phb(i ,k ,j ) ) / g - ht(i ,j ) ) + & (( ph(i-1,k ,j ) + phb(i-1,k ,j ) ) / g - ht(i-1,j ) ) + & (( ph(i ,k ,j-1) + phb(i ,k ,j-1) ) / g - ht(i ,j-1) ) + & (( ph(i-1,k ,j-1) + phb(i-1,k ,j-1) ) / g - ht(i-1,j-1) ) ) ) zu = ( 0.25 * ( & (( ph(i ,k+1,j ) + phb(i ,k+1,j ) ) / g - ht(i ,j ) ) + & (( ph(i-1,k+1,j ) + phb(i-1,k+1,j ) ) / g - ht(i-1,j ) ) + & (( ph(i ,k+1,j-1) + phb(i ,k+1,j-1) ) / g - ht(i ,j-1) ) + & (( ph(i-1,k+1,j-1) + phb(i-1,k+1,j-1) ) / g - ht(i-1,j-1) ) ) ) IF ( zl .GE. 2000. .AND. zu .LE. 5000. ) THEN IF ( wavg(i,k,j) .GT. 0. .AND. wavg(i,k+1,j) .GT. 0. ) THEN uh(i,j) = uh(i,j) + ( ( wavg(i,k,j) * rvort(i,k,j) + & wavg(i,k+1,j) * rvort(i,k+1,j) ) * 0.5 ) & * ( zu - zl ) ELSE use_column(i,j) = .false. uh(i,j) = 0. ENDIF ENDIF END DO END DO END DO ! Apply a smoother DO j = MAX(jds+1,jts),MIN(jde-2,jte) DO i = MAX(ids+1,its),MIN(ide-2,ite) uh_smth = 0.25 * uh(i ,j ) + & 0.125 * ( uh(i+1,j ) + uh(i-1,j ) + & uh(i ,j+1) + uh(i ,j-1) ) + & 0.0625 * ( uh(i+1,j+1) + uh(i+1,j-1) + & uh(i-1,j+1) + uh(i-1,j-1) ) IF ( use_column(i,j) ) THEN IF ( uh_smth .GT. up_heli_max(i,j) ) THEN up_heli_max(i,j) = uh_smth ENDIF ENDIF ! IF ( up_heli_max(i,j) .GT. 1.0e+3 ) THEN ! print *,' i,j,up_heli_max = ', i,j,up_heli_max(i,j) ! ENDIF END DO END DO ! End addition of the average w calculation for updraft helicity. !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! Update the boundary for updraft helicity (might need to change later). IF ( .NOT. config_flags%periodic_x .AND. i_start .EQ. ids+1 ) THEN DO j = jts, jte DO k = kts, kte ! rvort(ids,k,j) = rvort(ids+1,k,j) up_heli_max(ids,j) = up_heli_max(ids+1,j) END DO END DO END IF IF ( .NOT. config_flags%periodic_y .AND. j_start .EQ. jds+1) THEN DO k = kts, kte DO i = its, ite ! rvort(i,k,jds) = rvort(i,k,jds+1) up_heli_max(i,jds) = up_heli_max(i,jds+1) END DO END DO END IF IF ( .NOT. config_flags%periodic_x .AND. i_end .EQ. ide-1) THEN DO j = jts, jte DO k = kts, kte ! rvort(ide,k,j) = rvort(ide-1,k,j) up_heli_max(ide,j) = up_heli_max(ide-1,j) END DO END DO END IF IF ( .NOT. config_flags%periodic_y .AND. j_end .EQ. jde-1) THEN DO k = kts, kte DO i = its, ite ! rvort(i,k,jde) = rvort(i,k,jde-1) up_heli_max(i,jde) = up_heli_max(i,jde-1) END DO END DO END IF ! End update of boundary for updraft helicity. END SUBROUTINE cal_helicity !======================================================================= !======================================================================= SUBROUTINE tridiag(n,a,b,c,d) !! to solve system of linear eqs on tridiagonal matrix n times n !! after Peaceman and Rachford, 1955 !! a,b,c,d - are vectors of order n !! a,b,c - are coefficients on the LHS !! d - is initially RHS on the output becomes a solution vector !------------------------------------------------------------------- INTEGER, INTENT(IN) :: n REAL, DIMENSION(n), INTENT(IN) :: a,b REAL, DIMENSION(n), INTENT(INOUT) :: c,d INTEGER :: i REAL :: p REAL, DIMENSION(n) :: q c(n) = 0. q(1) = -c(1)/b(1) d(1) = d(1)/b(1) DO i = 2, n p = 1./(b(i) + a(i)*q(i-1)) q(i) = -c(i)*p d(i) = (d(i) - a(i)*d(i-1))*p ENDDO DO i = n-1, 1, -1 d(i) = d(i) + q(i)*d(i+1) ENDDO END SUBROUTINE tridiag !======================================================================= !======================================================================= SUBROUTINE vertical_diffusion_implicit(ru_tendf, rv_tendf, rw_tendf, rt_tendf,& tke_tendf, moist_tendf, n_moist, & chem_tendf, n_chem, & scalar_tendf, n_scalar, & tracer_tendf, n_tracer, & u_2, v_2, w_2, dt, & thp,u_base,v_base,t_base,qv_base,mu,tke, & theta, config_flags, & moist,chem,scalar,tracer, & xkmv,xkhv,xkmh,km_opt, & fnm, fnp, dn, dnw, rdz, rdzw, & hfx, qfx, ust, rho, & nlflux,gamu,gamv,xkmv_meso,l_diss, & c1h, c2h, c1f, c2f, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) !To solve the vertical diffusion equations for u,v,w,th,moist, !chem,scalar,tracer using implicit method. !The vertical TKE diffusion and dissipation are implicitly treated. !----------------------------------------------------------------------- ! Begin declarations. 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 INTEGER , INTENT(IN ) :: n_moist,n_chem,n_scalar,n_tracer,km_opt REAL, INTENT(IN ) :: dt REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnm REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnp REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: dnw REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: dn REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mu REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: qv_base REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: u_base REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: v_base REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: t_base REAL , DIMENSION( kms:kme) , INTENT(IN ) :: & c1h, c2h, c1f ,c2f REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) ::ru_tendf,& rv_tendf,& rw_tendf,& tke_tendf,& rt_tendf REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_moist), & INTENT(INOUT) :: moist_tendf REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_chem), & INTENT(INOUT) :: chem_tendf REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_scalar) , & INTENT(INOUT) :: scalar_tendf REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_tracer) , & INTENT(INOUT) :: tracer_tendf REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_moist), & INTENT(INOUT) :: moist REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_chem), & INTENT(INOUT) :: chem REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_scalar) , & INTENT(IN ) :: scalar REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_tracer) , & INTENT(IN ) :: tracer REAL , DIMENSION( ims:ime, kms:kme, jms:jme), & INTENT(IN ) :: xkmv, & xkhv, & xkmh, & tke, & theta, & rdz, & u_2, & v_2, & w_2, & rdzw REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN ) :: rho REAL , DIMENSION( ims:ime, jms:jme), INTENT(INOUT) :: hfx, & qfx REAL , DIMENSION( ims:ime, jms:jme), INTENT(IN ) :: ust REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: thp REAL , DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) :: nlflux REAL , DIMENSION( ims:ime, jms:jme), INTENT(INOUT) :: gamu,& gamv REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) :: xkmv_meso REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) :: l_diss ! LOCAL VAR REAL , DIMENSION( ims:ime, kms:kme, jms:jme) :: var_mix REAL, DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1 ):: xkxavg_m, & xkxavg_s REAL, DIMENSION( its:ite, kts:kte, jts:jte) :: xkxavg, & xkxavg_w, & rhoavg, & nlflux_rho REAL, DIMENSION( its-1:ite+1, jts-1:jte+1 ) :: gamvavg, gamuavg REAL, DIMENSION( its-1:ite+1, jts-1:jte+1 ) :: tao_xz, tao_yz REAL, DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1 ):: muavg_u,muavg_v REAL, DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1 ):: rdz_u, rdz_v REAL, DIMENSION(kts:kte) :: a, b, c, d REAL, DIMENSION(kts:kte-1) :: a1, b1, c1, d1 INTEGER :: im, i,j,k,ktf,nz INTEGER :: i_start, i_end, j_start, j_end REAL :: V0_u,V0_v,ustar,beta REAL :: heat_flux, moist_flux REAL :: cpm,rdz_w,rhoavg_u,rhoavg_v,rdz_z ! End declarations. !----------------------------------------------------------------------- !!============================================ !! u !!============================================ 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 DO j = j_start, j_end DO k = kts+1, ktf DO i = i_start, i_end rhoavg_u = 0.5 * ( fnm(k) * ( rho(i,k ,j) + rho(i-1,k,j) ) + & fnp(k) * ( rho(i,k-1,j) + rho(i-1,k-1,j) ) ) xkxavg_m(i,k,j) = 0.5 * rhoavg_u * & ( fnm(k) * ( xkmv_meso(i,k ,j) + xkmv_meso(i-1,k,j) ) + & fnp(k) * ( xkmv_meso(i,k-1,j) + xkmv_meso(i-1,k-1,j) ) ) xkxavg_s(i,k,j) = 0.5 * rhoavg_u * & ( fnm(k) * ( xkmv(i,k ,j) + xkmv(i-1,k,j) ) + & fnp(k) * ( xkmv(i,k-1,j) + xkmv(i-1,k-1,j) ) ) END DO END DO END DO DO j = j_start, j_end DO i = i_start, i_end xkxavg_m(i,kts, j) = 0.0 xkxavg_m(i,ktf+1,j) = 0.0 xkxavg_s(i,kts, j) = 0.0 xkxavg_s(i,ktf+1,j) = 0.0 END DO END DO DO j = j_start, j_end DO i = i_start, i_end gamuavg(i,j) = 0.5 * ( gamu(i,j) + gamu(i-1,j) ) END DO END DO DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end rdz_u(i,k,j) = 2./( 1./rdz(i,k,j) + 1./rdz(i-1,k,j)) muavg_u(i,k,j) = 0.5 * ( (c1h(k)*mu(i,j)+c2h(k)) + (c1h(k)*mu(i-1,j)+c2h(k)) ) ENDDO ENDDO ENDDO DO j = j_start, j_end DO i = i_start, ite V0_u = 0. 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 ustar = 0.5*(ust(i,j)+ust(i-1,j)) tao_xz(i,j) = ustar*ustar*(rho(i,kts,j)+rho(i-1,kts,j))/(2.*V0_u) ENDDO ENDDO nz = ktf DO j = j_start, j_end DO i = i_start, i_end k = kts rdz_w = -g/(dnw(k))/muavg_u(i,k,j) a(k) = 0. b(k) = 1.+rdz_w*(rdz_u(i,k+1,j)*xkxavg_s(i,k+1,j)+tao_xz(i,j))*dt c(k) = -rdz_w*rdz_u(i,k+1,j)*xkxavg_s(i,k+1,j)*dt d(k) = u_2(i,kts,j) DO k = kts+1,ktf-1 rdz_w = -g/(dnw(k))/muavg_u(i,k,j) a(k) = -rdz_w*rdz_u(i,k,j)*xkxavg_s(i,k,j)*dt b(k) = 1 + rdz_w*(rdz_u(i,k+1,j)*xkxavg_s(i,k+1,j)+rdz_u(i,k,j)*xkxavg_s(i,k,j))*dt c(k) = -rdz_w*rdz_u(i,k+1,j)*xkxavg_s(i,k+1,j)*dt d(k) = -rdz_w*(xkxavg_m(i,k+1,j)-xkxavg_m(i,k,j))*dt*gamuavg(i,j) + u_2(i,k,j) ENDDO a(ktf) = 0. b(ktf) = 1. c(ktf) = 0. d(ktf) = u_2(i,ktf,j) CALL tridiag(nz,a,b,c,d) DO k=kts,ktf ru_tendf(i,k,j) = ru_tendf(i,k,j) + muavg_u(i,k,j) * (d(k) - u_2(i,k,j))/dt ENDDO ENDDO ENDDO !!============================================ !! v !!============================================ 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) DO j = j_start, j_end DO k = kts+1, ktf DO i = i_start, i_end rhoavg_v = 0.5 * ( fnm(k) * ( rho(i,k ,j) + rho(i,k,j-1) ) + & fnp(k) * ( rho(i,k-1,j) + rho(i,k-1,j-1) ) ) xkxavg_m(i,k,j) = 0.5 * rhoavg_v * & ( fnm(k) * ( xkmv_meso(i,k ,j) + xkmv_meso(i,k,j-1) ) + & fnp(k) * ( xkmv_meso(i,k-1,j) + xkmv_meso(i,k-1,j-1) ) ) xkxavg_s(i,k,j) = 0.5 * rhoavg_v * & ( fnm(k) * ( xkmv(i,k ,j) + xkmv(i,k,j-1) ) + & fnp(k) * ( xkmv(i,k-1,j) + xkmv(i,k-1,j-1) ) ) END DO END DO END DO DO j = j_start, j_end DO i = i_start, i_end xkxavg_m(i,kts, j) = 0.0 xkxavg_m(i,ktf+1,j) = 0.0 xkxavg_s(i,kts, j) = 0.0 xkxavg_s(i,ktf+1,j) = 0.0 END DO END DO DO j = j_start, j_end DO i = i_start, i_end gamvavg(i,j) = 0.5 * ( gamv(i,j) + gamv(i,j-1) ) END DO END DO DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end muavg_v(i,k,j) = 0.5 * ( (c1h(k)*mu(i,j)+c2h(k)) + (c1h(k)*mu(i,j-1)+c2h(k)) ) END DO END DO END DO DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end rdz_v(i,k,j) = 2./( 1./rdz(i,k,j) + 1./rdz(i,k,j-1)) ENDDO ENDDO ENDDO DO j = j_start, jte DO i = i_start, i_end V0_v = 0. 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 ustar = 0.5*(ust(i,j)+ust(i,j-1)) tao_yz(i,j) = ustar*ustar*(rho(i,kts,j)+rho(i,kts,j-1))/(2.*V0_v) ENDDO ENDDO nz = ktf DO j = j_start, j_end DO i = i_start, i_end k = kts rdz_w = -g/(dnw(k))/muavg_v(i,k,j) a(k) = 0. b(k) = 1. + rdz_w*(rdz_v(i,k+1,j)*xkxavg_s(i,k+1,j)+tao_yz(i,j))*dt c(k) = -rdz_w* rdz_v(i,k+1,j)*xkxavg_s(i,k+1,j)*dt d(k) = v_2(i,kts,j) DO k = kts+1,ktf-1 rdz_w = -g/(dnw(k))/muavg_v(i,k,j) a(k) = -rdz_w*rdz_v(i,k,j)*xkxavg_s(i,k,j)*dt b(k) = 1. + rdz_w*(rdz_v(i,k+1,j)*xkxavg_s(i,k+1,j)+rdz_v(i,k,j)*xkxavg_s(i,k,j))*dt c(k) = -rdz_w*rdz_v(i,k+1,j)*xkxavg_s(i,k+1,j)*dt d(k) = -rdz_w*(xkxavg_m(i,k+1,j)-xkxavg_m(i,k,j))*dt*gamvavg(i,j) + v_2(i,k,j) ENDDO a(ktf) = 0. b(ktf) = 1. c(ktf) = 0. d(ktf) = v_2(i,ktf,j) CALL tridiag(nz,a,b,c,d) DO k=kts,ktf rv_tendf(i,k,j) = rv_tendf(i,k,j) + muavg_v(i,k,j) * (d(k) - v_2(i,k,j))/dt ENDDO ENDDO ENDDO !!============================================ !! w !!============================================ 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) nz = ktf-1 DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end xkxavg_w(i,k,j) = xkmh(i,k,j)*rho(i,k,j) ENDDO ENDDO ENDDO DO j = j_start, j_end DO i = i_start, i_end DO k = kts+1,ktf rdz_z = -g/dn(k)/(c1f(k)*mu(i,j) + c2f(k)) a1(k-1) = - rdz_z* rdzw(i,k-1,j)*xkxavg_w(i,k-1,j)*dt b1(k-1) = 1. + rdz_z*(rdzw(i,k ,j)*xkxavg_w(i,k,j)+rdzw(i,k-1,j)*xkxavg_w(i,k-1,j))*dt c1(k-1) = - rdz_z* rdzw(i,k ,j)*xkxavg_w(i,k,j)*dt d1(k-1) = w_2(i,k,j) ENDDO CALL tridiag(nz,a1,b1,c1,d1) DO k = kts+1,ktf rw_tendf(i,k,j) = rw_tendf(i,k,j) + (c1f(k)*mu(i,j) + c2f(k)) * (d1(k-1)-w_2(i,k,j))/dt ENDDO ENDDO ENDDO !!============================================ !! th !!============================================ 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 ( 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) 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) var_mix(i,k,j) = thp(i,k,j) - t_base(k) ENDDO ENDDO ENDDO END IF DO j = j_start, j_end DO k = kts+1,ktf DO i = i_start, i_end xkxavg(i,k,j) = (fnm(k)*xkhv(i,k,j)+fnp(k)*xkhv(i,k-1,j)) * & (fnm(k)*rho (i,k,j)+fnp(k)*rho (i,k-1,j)) ENDDO ENDDO ENDDO DO j = j_start, j_end DO k = kts+1,ktf DO i = i_start, i_end nlflux_rho(i,k,j) = nlflux(i,k,j) * & (fnm(k)*rho (i,k,j)+fnp(k)*rho (i,k-1,j)) ENDDO ENDDO ENDDO DO j = j_start, j_end DO i = i_start, i_end xkxavg(i,kts ,j) = 0.0 xkxavg(i,ktf+1,j) = 0.0 ENDDO ENDDO nz = ktf hflux: SELECT CASE( config_flags%isfflx ) CASE (0,2) ! with fixed surface heat flux given in the namelist heat_flux = config_flags%tke_heat_flux ! constant heat flux value ! set in namelist.input DO j = j_start, j_end DO i = i_start, i_end cpm = cp * (1. + 0.8 * moist(i,kts,j,P_QV)) hfx(i,j)=heat_flux*cpm*rho(i,1,j) ENDDO ENDDO CASE (1) ! use surface heat flux computed from surface routine DO j = j_start, j_end DO i = i_start, i_end cpm = cp * (1. + 0.8 * moist(i,kts,j,P_QV)) heat_flux = hfx(i,j)/cpm/rho(i,1,j) ENDDO ENDDO CASE DEFAULT CALL wrf_error_fatal( 'isfflx value invalid for diff_opt=2' ) END SELECT hflux DO j = j_start, j_end DO i = i_start, i_end cpm = cp * (1. + 0.8 * moist(i,kts,j,P_QV)) k = kts rdz_w = -g/dnw(k)/(c1h(k)*mu(i,j) + c2h(k)) a(k) = 0. b(k) = 1. + rdz_w*(rdz(i,k+1,j)*xkxavg(i,k+1,j))*dt c(k) = - rdz_w* rdz(i,k+1,j)*xkxavg(i,k+1,j) *dt IF(config_flags%use_theta_m == 0)THEN d(k) = var_mix(i,kts,j) & - dt*rdz_w*nlflux_rho(i,k+1,j) & + dt*rdz_w*hfx(i,j)/cpm ELSE d(k) = var_mix(i,kts,j) & - dt*rdz_w*nlflux_rho(i,k+1,j) & + dt*rdz_w*(hfx(i,j)/cpm+1.61*theta(i,kts,j)*qfx(i,j)) ENDIF DO k = kts+1, ktf-1 rdz_w = -g/dnw(k)/(c1h(k)*mu(i,j) + c2h(k)) a(k) = -rdz_w*rdz(i,k,j)*xkxavg(i,k,j)*dt b(k) = 1.+rdz_w*(rdz(i,k+1,j)*xkxavg(i,k+1,j)+rdz(i,k,j)*xkxavg(i,k,j))*dt c(k) = -rdz_w*rdz(i,k+1,j)*xkxavg(i,k+1,j)*dt d(k) = -rdz_w*(nlflux_rho(i,k+1,j)-nlflux_rho(i,k,j))*dt + var_mix(i,k,j) ENDDO a(ktf) = 0. b(ktf) = 1. c(ktf) = 0. d(ktf) = var_mix(i,ktf,j) CALL tridiag(nz,a,b,c,d) DO k = kts, ktf rt_tendf(i,k,j) = rt_tendf(i,k,j) + (c1h(k)*mu(i,j) + c2h(k)) * (d(k) - var_mix(i,k,j))/dt ENDDO ENDDO ENDDO !!============================================ !! tke(including implicit treatments of vertical diffusion and disspation) !!============================================ DO j = j_start, j_end DO k = kts+1, ktf DO i = i_start, i_end xkxavg(i,k,j) = ( fnm(k) * xkhv(i,k,j) + fnp(k) * xkhv(i,k-1,j) ) & *( fnm(k) * rho (i,k,j) + fnp(k) * rho (i,k-1,j) ) END DO END DO END DO DO j = j_start, j_end DO i = i_start, i_end xkxavg(i,kts, j) = 0.0 xkxavg(i,ktf+1,j) = 0.0 END DO END DO nz = ktf DO j = j_start, j_end DO i = i_start, i_end DO k = kts, ktf-1 rdz_w = - g/dnw(k)/(c1h(k)*mu(i,j)+c2h(k)) beta = 1.5*sqrt(tke(i,k,j))/l_diss(i,k,j) a(k) = - 2.0*xkxavg(i,k,j)*dt*rdz_w*rdz(i,k,j) b(k) = 1.0 + 2.0*dt*rdz_w*(rdz(i,k,j)*xkxavg(i,k,j) & + rdz(i,k+1,j)*xkxavg(i,k+1,j)) & + dt*beta c(k) = - 2.0*xkxavg(i,k+1,j)*dt*rdz(i,k+1,j)*rdz_w d(k) = tke(i,k,j) & + 0.5*dt*tke(i,k,j)**1.5/l_diss(i,k,j) ENDDO a(ktf) = 0. !-1 b(ktf) = 1. c(ktf) = 0. d(ktf) = 0. CALL tridiag(nz,a,b,c,d) DO k = kts,ktf tke_tendf(i,k,j) = tke_tendf(i,k,j) + (c1h(k)*mu(i,j)+c2h(k)) * (d(k)-tke(i,k,j))/dt ENDDO ENDDO ENDDO !!============================================ !! moisture !!============================================ DO j = j_start, j_end DO k = kts+1,ktf DO i = i_start, i_end xkxavg(i,k,j) = ( fnm(k) * xkhv(i,k,j) + fnp(k) * xkhv(i,k-1,j) ) & *( fnm(k) * rho (i,k,j) + fnp(k) * rho (i,k-1,j) ) ENDDO ENDDO ENDDO DO j = j_start, j_end DO i = i_start, i_end xkxavg(i,kts, j) = 0.0 xkxavg(i,ktf+1,j) = 0.0 END DO END DO IF (n_moist .ge. PARAM_FIRST_SCALAR) THEN moist_loop: 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) 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) var_mix(i,k,j) = moist(i,k,j,im) ENDDO ENDDO ENDDO END IF nz = ktf !! IF ( im == P_QV ) THEN DO j = j_start, j_end DO i = i_start, i_end k = kts rdz_w = -g/dnw(k)/(c1h(k)*mu(i,j)+c2h(k)) a(k) = 0. b(k) = 1.+rdz_w*(rdz(i,k+1,j)*xkxavg(i,k+1,j))*dt c(k) = -rdz_w* rdz(i,k+1,j)*xkxavg(i,k+1,j) *dt ! d(k) = var_mix(i,k,j) + dt*rdz_w*qfx(i,j)/(1.+moist(i,k,j,P_QV)) !?? d(k) = var_mix(i,k,j) + dt*rdz_w*qfx(i,j) DO k = kts+1,ktf-1 rdz_w = -g/dnw(k)/(c1h(k)*mu(i,j)+c2h(k)) a(k) = -rdz_w*rdz(i,k,j)*xkxavg(i,k,j)*dt b(k) = 1.+rdz_w*(rdz(i,k+1,j)*xkxavg(i,k+1,j)+rdz(i,k,j)*xkxavg(i,k,j))*dt c(k) = -rdz_w*rdz(i,k+1,j)*xkxavg(i,k+1,j)*dt d(k) = var_mix(i,k,j) ENDDO a(ktf) = 0. b(ktf) = 1. c(ktf) = 0. d(ktf) = var_mix(i,ktf,j) CALL tridiag(nz,a,b,c,d) DO k = kts, ktf moist_tendf(i,k,j,im) = moist_tendf(i,k,j,im) + (c1h(k)*mu(i,j)+c2h(k)) * (d(k)-var_mix(i,k,j))/dt ENDDO ENDDO ENDDO ENDIF !! IF ( im /= P_QV ) THEN DO j = j_start, j_end DO i = i_start, i_end k = kts rdz_w = -g/dnw(k)/(c1h(k)*mu(i,j)+c2h(k)) a(k) = 0. b(k) = 1.+rdz_w*(rdz(i,k+1,j)*xkxavg(i,k+1,j))*dt c(k) = -rdz_w* rdz(i,k+1,j)*xkxavg(i,k+1,j)*dt d(k) = var_mix(i,k,j) DO k = kts+1,ktf-1 rdz_w = -g/dnw(k)/(c1h(k)*mu(i,j)+c2h(k)) a(k) = -rdz_w*rdz(i,k,j)*xkxavg(i,k,j)*dt b(k) = 1.+rdz_w*(rdz(i,k+1,j)*xkxavg(i,k+1,j)+rdz(i,k,j)*xkxavg(i,k,j))*dt c(k) = -rdz_w*rdz(i,k+1,j)*xkxavg(i,k+1,j)*dt d(k) = var_mix(i,k,j) ENDDO a(ktf) = 0. b(ktf) = 1. c(ktf) = 0. d(ktf) = var_mix(i,ktf,j) CALL tridiag(nz,a,b,c,d) DO k = kts, ktf moist_tendf(i,k,j,im) = moist_tendf(i,k,j,im) + (c1h(k)*mu(i,j)+c2h(k)) * (d(k)-var_mix(i,k,j))/dt ENDDO ENDDO ENDDO ENDIF ENDDO moist_loop ENDIF !!============================================ !! scalar !!============================================ DO j = j_start, j_end DO k = kts+1, ktf DO i = i_start, i_end xkxavg(i,k,j) = ( fnm(k) * xkhv(i,k,j) + fnp(k) * xkhv(i,k-1,j) ) & *( fnm(k) * rho (i,k,j) + fnp(k) * rho (i,k-1,j) ) ENDDO ENDDO ENDDO DO j = j_start, j_end DO i = i_start, i_end xkxavg(i,kts ,j) = 0.0 xkxavg(i,ktf+1,j) = 0.0 END DO END DO IF (n_scalar .ge. PARAM_FIRST_SCALAR) THEN scalar_loop: do im = PARAM_FIRST_SCALAR, n_scalar ! need to avoid mixing scalars associated with precipitating species (e.g. Nr) IF(im.NE.P_QNS .AND. im.NE.P_QNR .AND. im.NE.P_QNG .AND. im.NE.P_QNH .AND. & im.NE.P_QT .AND. im.NE.P_QVOLG) THEN DO j = jts, min(jte,jde-1) DO k = kts, kte-1 DO i = its, min(ite,ide-1) var_mix(i,k,j) = scalar(i,k,j,im) ENDDO ENDDO ENDDO DO j = j_start, j_end DO i = i_start, i_end k = kts rdz_w = -g/dnw(k)/(c1h(k)*mu(i,j)+c2h(k)) a(k) = 0. b(k) = 1.+rdz_w*(rdz(i,k+1,j)*xkxavg(i,k+1,j))*dt c(k) = -rdz_w* rdz(i,k+1,j)*xkxavg(i,k+1,j)*dt d(k) = var_mix(i,k,j) DO k = kts+1, ktf-1 rdz_w = -g/dnw(k)/(c1h(k)*mu(i,j)+c2h(k)) a(k) = -rdz_w*rdz(i,k,j)*xkxavg(i,k,j)*dt b(k) = 1.+rdz_w*(rdz(i,k+1,j)*xkxavg(i,k+1,j)+rdz(i,k,j)*xkxavg(i,k,j))*dt c(k) = -rdz_w*rdz(i,k+1,j)*xkxavg(i,k+1,j)*dt d(k) = var_mix(i,k,j) ENDDO a(ktf) = 0. b(ktf) = 1. c(ktf) = 0. d(ktf) = var_mix(i,ktf,j) CALL tridiag(nz,a,b,c,d) DO k = kts, ktf scalar_tendf(i,k,j,im) = scalar_tendf(i,k,j,im) + (c1h(k)*mu(i,j)+c2h(k)) * (d(k)-var_mix(i,k,j))/dt ENDDO ENDDO ENDDO ENDIF ENDDO scalar_loop ENDIF !!============================================ !! tracer !!============================================ IF (n_tracer .ge. PARAM_FIRST_SCALAR) THEN tracer_loop: do im = PARAM_FIRST_SCALAR, n_tracer DO j = jts, min(jte,jde-1) DO k = kts, kte-1 DO i = its, min(ite,ide-1) var_mix(i,k,j) = tracer(i,k,j,im) ENDDO ENDDO ENDDO DO j = j_start, j_end DO i = i_start, i_end k = kts rdz_w = -g/dnw(k)/(c1h(k)*mu(i,j)+c2h(k)) a(k) = 0. b(k) = 1.+rdz_w*(rdz(i,k+1,j)*xkxavg(i,k+1,j))*dt c(k) = -rdz_w* rdz(i,k+1,j)*xkxavg(i,k+1,j)*dt d(k) = var_mix(i,kts,j) DO k = kts+1,ktf-1 rdz_w = -g/dnw(k)/(c1h(k)*mu(i,j)+c2h(k)) a(k) = -rdz_w*rdz(i,k,j)*xkxavg(i,k,j)*dt b(k) = 1.+rdz_w*(rdz(i,k+1,j)*xkxavg(i,k+1,j)+rdz(i,k,j)*xkxavg(i,k,j))*dt c(k) = -rdz_w*rdz(i,k+1,j)*xkxavg(i,k+1,j)*dt d(k) = var_mix(i,k,j) ENDDO a(ktf) = 0. b(ktf) = 1. c(ktf) = 0. d(ktf) = var_mix(i,ktf,j) CALL tridiag(nz,a,b,c,d) DO k = kts, ktf tracer_tendf(i,k,j,im) = tracer_tendf(i,k,j,im) + (c1h(k)*mu(i,j)+c2h(k)) * (d(k) - var_mix(i,k,j))/dt ENDDO ENDDO ENDDO ENDDO tracer_loop ENDIF !!============================================ !! chemistry !!============================================ IF (n_chem .ge. PARAM_FIRST_SCALAR) THEN chem_loop: do im = PARAM_FIRST_SCALAR, n_chem DO j = jts,min(jte,jde-1) DO k = kts,kte-1 DO i = its,min(ite,ide-1) var_mix(i,k,j) = chem(i,k,j,im) ENDDO ENDDO ENDDO DO j = j_start, j_end DO i = i_start, i_end k = kts rdz_w = -g/dnw(k)/(c1h(k)*mu(i,j)+c2h(k)) a(k) = 0. b(k) = 1.+rdz_w*(rdz(i,k+1,j)*xkxavg(i,k+1,j))*dt c(k) = -rdz_w* rdz(i,k+1,j)*xkxavg(i,k+1,j)*dt d(k) = var_mix(i,kts,j) DO k = kts+1,ktf-1 rdz_w = -g/dnw(k)/(c1h(k)*mu(i,j)+c2h(k)) a(k) = -rdz_w*rdz(i,k,j)*xkxavg(i,k,j)*dt b(k) = 1.+rdz_w*(rdz(i,k+1,j)*xkxavg(i,k+1,j)+rdz(i,k,j)*xkxavg(i,k,j))*dt c(k) = -rdz_w*rdz(i,k+1,j)*xkxavg(i,k+1,j)*dt d(k) = var_mix(i,k,j) ENDDO a(ktf) = 0. b(ktf) = 1. c(ktf) = 0. d(ktf) = var_mix(i,ktf,j) CALL tridiag(nz,a,b,c,d) DO k = kts, ktf chem_tendf(i,k,j,im) = chem_tendf(i,k,j,im) + (c1h(k)*mu(i,j)+c2h(k)) * (d(k) - var_mix(i,k,j))/dt ENDDO ENDDO ENDDO ENDDO chem_loop ENDIF END SUBROUTINE vertical_diffusion_implicit !======================================================================= !======================================================================= END MODULE module_diffusion_em !======================================================================= !=======================================================================