MODULE module_cu_camuwshcu_driver USE shr_kind_mod, only: r8 => shr_kind_r8 IMPLICIT NONE PRIVATE PUBLIC :: & camuwshcu_driver CONTAINS SUBROUTINE camuwshcu_driver( & ids,ide, jds,jde, kds,kde & ,ims,ime, jms,jme, kms,kme & ,its,ite, jts,jte, kts,kte & ,num_moist, dt & ,p, p8w, pi_phy, z, z_at_w, dz8w & ,t_phy, u_phy, v_phy & ,moist, qv, qc, qi & ,pblh_in, tke_pbl, cldfra, cldfra_old, cldfrash & ,cush_inout, rainsh, pratesh, snowsh, icwmrsh & ,cmfmc, cmfmc2_inout, rprdsh_inout, cbmf_inout & ,cmfsl, cmflq, dlf, evapcsh_inout & ,rliq, rliq2_inout, cubot, cutop & ,rushten, rvshten, rthshten & ,rqvshten, rqcshten, rqrshten & ,rqishten, rqsshten, rqgshten & ,ht & ) USE module_state_description, only: param_first_scalar, & p_qc, p_qr, p_qi, p_qs, p_qg USE module_cam_support, only: pcols, pver USE constituents, only: cnst_get_ind USE physconst, only: cpair, gravit, latvap USE uwshcu, only: compute_uwshcu_inv USE wv_saturation, only: fqsatd INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & num_moist REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), INTENT(IN) :: & moist REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) :: & cldfra, & cldfra_old, & dz8w, & p, & p8w, & pi_phy, & qv, & t_phy, & tke_pbl, & u_phy, & v_phy, & z, & z_at_w REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN), OPTIONAL :: & qc, & qi REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: & pblh_in, & ht REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) :: & cldfrash, & cmfmc, & cmfmc2_inout, & cmflq, & cmfsl, & dlf, & evapcsh_inout, & icwmrsh, & rprdsh_inout, & rushten, & rvshten, & rthshten, & rqvshten, & rqcshten, & rqrshten, & rqishten, & rqsshten, & rqgshten REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: & cbmf_inout, & cubot, & cutop, & cush_inout, & pratesh, & rainsh, & rliq, & rliq2_inout, & snowsh REAL, INTENT(IN) :: & dt REAL(r8), DIMENSION(pcols, kte, 5) :: & moist8, & tnd_tracer REAL(r8), DIMENSION(pcols, kte+1) :: & pint8, & zi8, & tke8, & slflx, & qtflx REAL(r8), DIMENSION(pcols, kte) :: & cld8, & cldold8, & cmfdqs, & cmfmc2, & evapcsh, & iccmr_uw, & icwmr_uw, & icimr_uw, & pdel8, & pdeldry8, & pmid8, & qc2, & qh8, & qc8, & qi8, & qhtnd, & qctnd, & qitnd, & rprdsh, & s8, & shfrc, & stnd, & t8, & u8, & utnd, & v8, & vtnd, & zm8 REAL(r8), DIMENSION(pcols) :: & cbmf, & cnb2, & cnt2, & cush, & pblh, & precc, & rliq2, & snow REAL(r8) :: ztodt INTEGER :: i, j, k, kflip, m, mp1 INTEGER :: cnb, cnt INTEGER :: lchnk INTEGER :: ncnst INTEGER :: ncol CHARACTER(LEN=250) :: msg ncol = 1 ncnst = 5 ztodt = 2.*dt ij_loops : do j = jts,jte do i = its,ite lchnk = (j-jts)*(ite-its+1) + (i-its+1) do k = kts,kte+1 kflip = kte-k+2 pint8(1,kflip) = p8w(i,k,j) zi8(1,kflip) = z_at_w(i,k,j) - ht(i,j) end do do k = kts,kte kflip = kte-k+1 cld8(1,kflip) = cldfra(i,k,j) cldold8(1,kflip) = cldfra_old(i,k,j) pdel8(1,kflip) = p8w(i,k,j) - p8w(i,k+1,j) pmid8(1,kflip) = p(i,k,j) qh8(1,kflip) = max( qv(i,k,j)/(1. + qv(i,k,j)), 1e-30 ) if( present(qc) ) then qc8(1,kflip) = qc(i,k,j)/(1. + qv(i,k,j)) else qc8(1,kflip) = 0. end if if( present(qi) ) then qi8(1,kflip) = qi(i,k,j)/(1. + qv(i,k,j)) else qi8(1,kflip) = 0. end if pdeldry8(1,kflip)= pdel8(1,kflip)*(1._r8 - qh8(1,kflip)) t8(1,kflip) = t_phy(i,k,j) s8(1,kflip) = cpair*t8(1,kflip) + gravit*(z(i,k,j)-ht(i,j)) u8(1,kflip) = u_phy(i,k,j) v8(1,kflip) = v_phy(i,k,j) zm8(1,kflip) = dz8w(i,k,j) end do tke8(1,kte+1) = tke_pbl(i,1,j) tke8(1,1) = tke_pbl(i,kte,j) do k = kts,kte-1 kflip = kte-k+1 tke8(1,kflip) = 0.5*(tke_pbl(i,k,j) + tke_pbl(i,k+1,j)) end do do k = kts,kte kflip = kte-k+1 moist8(1,kflip,1:ncnst) = 0. moist8(1,kflip,1) = qv(i,k,j)/(1. + qv(i,k,j)) call cnst_get_ind( 'CLDLIQ', m ) moist8(1,kflip,m) = qc(i,k,j)/(1. + qv(i,k,j)) call cnst_get_ind( 'CLDICE', m ) moist8(1,kflip,m) = qi(i,k,j)/(1. + qv(i,k,j)) call cnst_get_ind( 'NUMLIQ', m ) moist8(1,kflip,m) = 0. call cnst_get_ind( 'NUMICE', m ) moist8(1,kflip,m) = 0. end do pblh(1) = pblh_in(i,j) cush(1) = cush_inout(i,j) call compute_uwshcu_inv( & pcols, pver, ncol, ncnst, ztodt, & pint8, zi8, pmid8, zm8, pdel8, & u8, v8, qh8, qc8, qi8, & t8, s8, moist8, & tke8, cld8, cldold8, pblh, cush, & cmfmc2, slflx, qtflx, & qhtnd, qctnd, qitnd, & stnd, utnd, vtnd, tnd_tracer, & rprdsh, cmfdqs, precc, snow, & evapcsh, shfrc, iccmr_UW, icwmr_UW, & icimr_UW, cbmf, qc2, rliq2, & cnt2, cnb2, fqsatd, lchnk, pdeldry8 ) cush_inout(i,j) = cush(1) do k = kts,kte kflip = kte-k+1 dlf(i,k,j) = dlf(i,k,j) + qc2(1,kflip) evapcsh_inout(i,k,j)= evapcsh(1,kflip) icwmrsh(i,k,j) = icwmr_uw(1,kflip) rprdsh(1,kflip) = rprdsh(1,kflip) + cmfdqs(1,kflip) rprdsh_inout(i,k,j) = rprdsh(1,kflip) rushten(i,k,j) = utnd(1,kflip) rvshten(i,k,j) = vtnd(1,kflip) rthshten(i,k,j) = stnd(1,kflip)/cpair/pi_phy(i,k,j) rqvshten(i,k,j) = qhtnd(1,kflip)/(1. - qv(i,k,j)) if( p_qc >= param_first_scalar ) & rqcshten(i,k,j) = qctnd(1,kflip)/(1. - qv(i,k,j)) if( p_qi >= param_first_scalar ) & rqishten(i,k,j) = qitnd(1,kflip)/(1. - qv(i,k,j)) cmfmc2_inout(i,k,j) = cmfmc2(1,kflip) cmfmc(i,k,j) = cmfmc(i,k,j) + cmfmc2(1,kflip) end do do k = kts,kte+1 kflip = kte-k+2 cmfsl(i,k,j) = slflx(1,kflip) cmflq(i,k,j) = qtflx(1,kflip)*latvap end do pratesh(i,j) = precc(1)*1e3/dt kflip = kte - cutop(i,j) + 1 cnt = kflip if( cnt2(1) < kflip ) cnt = cnt2(1) cutop(i,j) = kte - cnt + 1 kflip = kte - cubot(i,j) + 1 cnb = kflip if( cnb2(1) > kflip ) cnb = cnb2(1) cubot(i,j) = kte - cnb + 1 rliq2_inout(i,j) = rliq2(1) rliq(i,j) = rliq(i,j) + rliq2(1) end do end do ij_loops END SUBROUTINE camuwshcu_driver END MODULE module_cu_camuwshcu_driver