tphysbc.f90

来自「CCSM Research Tools: Community Atmospher」· F90 代码 · 共 775 行 · 第 1/3 页

!
   call qneg3('TPHYSBCb',lchnk  ,ncol    ,pcols   ,pver    , &
              ppcnst,qmin  ,state%q )
!
! Setup q and t accumulation fields
!
   dqcond(:ncol,:,:) = state%q(:ncol,:,:)
   dtcond(:ncol,:)   = state%s(:ncol,:)
!
! Zero out precip and convective fields before accumulating terms
!
   precl (:ncol)   = 0.
   preclp(:ncol)   = 0.
   precc (:ncol)   = 0.
   precsl(:ncol)   = 0.
   precsc(:ncol)   = 0.
   qc    (:ncol,:) = 0.
   cmfdqr(:ncol,:) = 0.
   cmfmc (:ncol,:) = 0.
   cmfsl (:ncol,:) = 0.
   cmflq (:ncol,:) = 0.
   dqcond(ncol+1:pcols,:,:) = 0.
   dtcond(ncol+1:pcols,:)   = 0.

   fracis (:ncol,:,1:ppcnst) = 1.
!
!===================================================
! Dry adjustment
!===================================================

! Copy state info for input to dadadj
! This is a kludge, so that dadadj does not have to be correctly reformulated in dry static energy

   ptend%s(:ncol,:pver)   = state%t(:ncol,:pver)
   ptend%q(:ncol,:pver,1) = state%q(:ncol,:pver,1)

   call t_startf ('dadadj')
   call dadadj (lchnk, ncol, state%pmid,  state%pint,  state%pdel,  &
                ptend%s, ptend%q(1,1,1))
   ptend%name  = 'dadadj'
   ptend%ls    = .TRUE.
   ptend%lq(1) = .TRUE.
   ptend%s(:ncol,:)   = (ptend%s(:ncol,:)   - state%t(:ncol,:)  )/ztodt * cpair
   ptend%q(:ncol,:,1) = (ptend%q(:ncol,:,1) - state%q(:ncol,:,1))/ztodt
   call t_stopf ('dadadj')
   call physics_update (state, tend, ptend, ztodt)
!
!===================================================
! Moist convection
!===================================================
!
! Since the PBL doesn't pass constituent perturbations, they
! are zeroed here for input to the moist convection routine
!
   qpert(:ncol,2:ppcnst) = 0.0
!
! JR Set some arrays to zero @ nstep=0. Otherwise random junk off the heap
! or stack will be used in zm_convr
!
   if (is_first_step()) then
      pblht(:ncol)  = 0.
      tpert(:ncol)  = 0.
      cldo (:ncol,:)= 0.
   end if
!
! Begin with Zhang-McFarlane (1996) convection parameterization
!
   call t_startf ('zm_convr')
   call zm_convr( lchnk,    ncol, &
                  state%t,   state%q,    precc,   cnt,     cnb,      &
                  pblht,   state%zm, state%phis,    state%zi,   ptend%q(:,:,1),     &
                  ptend%s, state%pmid,   state%pint,  state%pdel,  ts,       &
                  .5*ztodt,cmfmc,    cmfcme,  nstep,             &
                  tpert,   dlf,      pflx,    zdu,     cmfdqr,   &
                  mu2,      md2,     du2,     eu2,     ed2,      &
                  dp,       dsubcld, jt,      maxg,    ideep,    &
                  lengath, icwmr1    )
   ptend%name  = 'zm_convr'
   ptend%ls    = .TRUE.
   ptend%lq(1) = .TRUE.

   ftem(:ncol,:pver) = ptend%s(:ncol,:pver)/cpair
   call outfld('ZMDT    ',ftem           ,pcols   ,lchnk   )
   call outfld('ZMDQ    ',ptend%q(1,1,1) ,pcols   ,lchnk   )
   call t_stopf('zm_convr')

   call physics_update(state, tend, ptend, ztodt)
!
! Evaporate some of the precip directly into the environment (Sundqvist)
!
   call zm_conv_evap(state, ptend, pflx, precc, cldo, ztodt, evappct)
   ptend%name  = 'zm_conv_evap'
   ptend%ls    = .TRUE.
   ptend%lq(1) = .TRUE.
   call outfld('EVAPPCT ',evappct,pcols,state%lchnk)
   call physics_update(state, tend, ptend, ztodt)
!
! Transport cloud water only
!
   ptend%name = 'convtran1'
   do m=2,ppcnst
      if (m == ixcldw) ptend%lq(m) = .true.
   end do
   call t_startf ('convtran1')
   call convtran (lchnk,                                        &
                  ptend%lq,state%q, ppcnst,  mu2,     md2,   &
                  du2,     eu2,     ed2,     dp,      dsubcld,  &
                  jt,      maxg,    ideep,   1,       lengath,  &
                  nstep,   fracis,  ptend%q   )
   call t_stopf ('convtran1')
   call physics_update (state, tend, ptend, ztodt)
!
! Convert mass flux from reported mb/s to kg/m^2/s
!
   cmfmc(:ncol,:pver) = cmfmc(:ncol,:pver) * 100./gravit
!
! Add production of rain by zm_convr to qc.  Added 1 to k-index of pflx
! at instruction of PJR
!
   do k=2,pver
      do i=1,ncol
         qc(i,k) = qc(i,k) + (pflx(i,k+1) - pflx(i,k))*gravit/state%pdel(i,k)
      end do
   end do
!
! Call Hack (1994) convection scheme to deal with shallow/mid-level convection
! Begin by zeroing local copies of mass flux, energy fluxes, etc.
!
   cmfmc2 (:ncol,:pver) = 0.
   cmfdqr2(:ncol,:pver) = 0.
   cmfsl2 (:ncol,:pver) = 0.
   cmflq2 (:ncol,:pver) = 0.
   qc2    (:ncol,:pver) = 0.
!
! At PJR's instruction, deleted kludge to get past a once in a lifetime
! problem in cmfmca's transport of liq water due to reliance on m=2 being
! hard-wired to cloud water--JR.  Put back in after run bombed.
!
   where (abs(state%q(:ncol,:pver,ixcldw)) < 1.e-36)
      state%q(:ncol,:pver,ixcldw) = 0.
   end where

   call t_startf('cmfmca')
   tpert2(:ncol  ) =0.
   qpert2(:ncol,:) = qpert(:ncol,:)  ! BAB Why is this not zero, if tpert2=0???
   call cmfmca (lchnk,   ncol, &
                nstep,   ztodt,   state%pmid,  state%pdel,   &
                state%rpdel,   state%zm,      tpert2,  qpert2,  state%phis,     &
                pblht,   state%t,   state%q,   ptend%s,   ptend%q,      &
                cmfmc2,  cmfdqr2, cmfsl2,  cmflq2,  precc2,   &
                qc2,     cnt2,    cnb2,    icwmr2   )
   ptend%name  = 'cmfmca'
   ptend%ls    = .TRUE.
   ptend%lq(:) = .TRUE.

   ftem(:ncol,:pver) = ptend%s(:ncol,:pver)/cpair
   call outfld('CMFDT   ',ftem          ,pcols   ,lchnk   )
   call outfld('CMFDQ   ',ptend%q(1,1,1),pcols   ,lchnk   )
   call t_stopf('cmfmca')
   call physics_update (state, tend, ptend, ztodt)
!
! Merge shallow/mid-level output with prior results from Zhang-McFarlane
!
   do i=1,ncol
      precc(i) = precc(i) + precc2(i)
      if (cnt2(i) < cnt(i)) cnt(i) = cnt2(i)
      if (cnb2(i) > cnb(i)) cnb(i) = cnb2(i)
   end do
!
   cmfmc(:ncol,:pver)  = cmfmc(:ncol,:pver)  + cmfmc2(:ncol,:pver)
   cmfdqr(:ncol,:pver) = cmfdqr(:ncol,:pver) + cmfdqr2(:ncol,:pver)
   cmfsl(:ncol,:pver)  = cmfsl(:ncol,:pver)  + cmfsl2(:ncol,:pver)
   cmflq(:ncol,:pver)  = cmflq(:ncol,:pver)  + cmflq2(:ncol,:pver)
   qc(:ncol,:pver)     = qc(:ncol,:pver)     + qc2(:ncol,:pver)

#ifndef PCWDETRAIN
!
! put the detraining cloud water into precip to conserve
! mass
!
   do k = 1,pver
      do i = 1,ncol
         precc(i) = precc(i) + dlf(i,k)*state%pdel(i,k)/(gravit*1000.)
      end do
   end do
#else
!
! put the detraining cloud water into the cloud and environment in
! proportion to the cloud fraction
!
   do k = 1,pver
      do i = 1,ncol
         ptend%q(i,k,1)      = dlf(i,k)*(1.-cldo(i,k))
         ptend%s(i,k)        =-dlf(i,k)*(1.-cldo(i,k))*latvap
         ptend%q(i,k,ixcldw) = dlf(i,k)*cldo(i,k)
      end do
   end do
   ptend%name  = 'pcwdetrain'
   ptend%ls    = .TRUE.
   ptend%lq(1) = .TRUE.
   ptend%lq(ixcldw) = .TRUE.
   call physics_update(state, tend, ptend, ztodt)
#endif
!
! cloud fraction after transport and convection,
! derive the relationship between rh and cld from 
! the employed cloud scheme
!
   call t_startf('cldnrh')
   call cldnrh(lchnk,   ncol,                                &
               state%pmid,    state%t,   state%q(1,1,1),   state%omega, &
               cnt,     cnb,     cldn,    clc,     state%pdel,   &
               cmfmc,   landfrac,snowh,   concld,  cldst,    &
               ts,      state%pint(1,pverp),       zdu,  ocnfrac, &
               rhdfda,   rhu00 )
   call t_stopf('cldnrh')
!
! calculate the tendencies for moisture, temperature and cloud fraction
!
   rtdt = 1./ztodt
   qtend(:ncol,:pver) = (state%q(:ncol,:pver,1)       - qcwato(:ncol,:pver))*rtdt
   ttend(:ncol,:pver) = (state%t(:ncol,:pver)         - tcwato(:ncol,:pver))*rtdt
   lctend(:ncol,:pver) = (state%q(:ncol,:pver,ixcldw) - lcwato(:ncol,:pver))*rtdt
!
! strat condensation via prognostic cloud water
! calculate tendencies
!
   call t_startf('pcond')
   zero(:ncol,:pverp) = 0.
   call pcond (lchnk,   ncol, &
               state%t,   ttend,   state%q(1,1,1), qtend,       state%omega,     &
               state%q(1,1,ixcldw),state%pmid,     state%pdel,  cldn,     &
               qme,     nevapr,    prain,          rmelt,    &
               ztodt,   zero,      fwaut,          fsaut,       fracw,    &
               fsacw,   fsaci,     lctend,         rhdfda,      rhu00, icefrac)
   call t_stopf('pcond')
!
   call outfld('FWAUT',fwaut, pcols,lchnk)
   call outfld('FSAUT',fsaut, pcols,lchnk)
   call outfld('FRACW',fracw, pcols,lchnk)
   call outfld('FSACW',fsacw, pcols,lchnk)
   call outfld('FSACI',fsaci, pcols,lchnk)
!
! make it interactive
!
   do k = 1,pver
      do i = 1,ncol
         ptend%s(i,k)        = (qme(i,k) - nevapr(i,k))*latvap + rmelt(i,k)
         ptend%q(i,k,1)      =-(qme(i,k) - nevapr(i,k))
         ptend%q(i,k,ixcldw) = (qme(i,k) - prain(i,k))
         preclp(i) = preclp(i) + (prain(i,k)-nevapr(i,k))*state%pdel(i,k)/gravit
      end do
   end do
   ptend%name  = 'pcond'
   ptend%ls    = .TRUE.
   ptend%lq(1) = .TRUE.
   ptend%lq(ixcldw) = .TRUE.
   call physics_update (state, tend, ptend, ztodt)
!