GFS Operational Physics Documentation  Revision: 81451
gbphys.f
Go to the documentation of this file.
1 
5 !at tune step========================================================= !
6 ! description: !
7 ! !
11 ! !
12 ! usage: !
13 ! !
14 ! call gbphys !
15 ! inputs: !
16 ! ( im,ix,levs,lsoil,lsm,ntrac,ncld,ntoz,ntcw,ntke, !
17 ! ntiw,ntlnc,ntinc, !
18 ! nmtvr,nrcm,ko3,lonr,latr,jcap, !
19 ! num_p3d,num_p2d,npdf3d,ncnvcld3d, !
20 ! kdt,lat,me,pl_coeff,nlons,ncw,flgmin,crtrh,cdmbgwd, !
21 ! ccwf,dlqf,ctei_rm,clstp,cgwf,prslrd0,ral_ts,dtp,dtf,fhour, !
22 ! solhr,slag,sdec,cdec,sinlat,coslat,pgr,ugrs,vgrs, !
23 ! tgrs,qgrs,vvel,prsi,prsl,prslk,prsik,phii,phil, !
24 ! rann,prdoz,poz,dpshc,hprime,xlon,xlat, !
25 ! h2o_phys,levh2o,h2opl,h2o_pres,h2o_coeff, !
26 ! isot,ivegsrc, !
27 ! slope,shdmin,shdmax,snoalb,tg3,slmsk,vfrac, !
28 ! vtype,stype,uustar,oro,oro_uf,coszen,sfcdsw,sfcnsw, !
29 ! sfcnirbmd,sfcnirdfd,sfcvisbmd,sfcvisdfd, !
30 ! sfcnirbmu,sfcnirdfu,sfcvisbmu,sfcvisdfu, !
31 ! slimskin_cpl,ulwsfcin_cpl, !
32 ! dusfcin_cpl,dvsfcin_cpl,dtsfcin_cpl,dqsfcin_cpl, !
33 ! sfcdlw,tsflw,sfcemis,sfalb,swh,swhc,hlw,hlwc,hlwd,lsidea, !
34 ! ras,pre_rad,ldiag3d,lgocart,lssav,lssav_cpl !
35 ! xkzm_m,xkzm_h,xkzm_s,psautco,prautco,evpco,wminco, !
36 ! pdfcld,shcnvcw,sup,redrag,hybedmf,dspheat, !
37 ! flipv,old_monin,cnvgwd,shal_cnv, !
38 ! imfshalcnv,imfdeepcnv,cal_pre,aero_in, !
39 ! mom4ice,mstrat,trans_trac,nstf_name,moist_adj, !
40 ! thermodyn_id, sfcpress_id, gen_coord_hybrid,levr,adjtrc,nnp,!
41 ! cscnv,nctp,do_shoc,shocaftcnv,ntot3d,ntot2d, !
42 ! input/outputs: !
43 ! hice,fice,tisfc,tsea,tprcp,cv,cvb,cvt, !
44 ! srflag,snwdph,weasd,sncovr,zorl,canopy, !
45 ! ffmm,ffhh,f10m,srunoff,evbsa,evcwa,snohfa, !
46 ! transa,sbsnoa,snowca,soilm,tmpmin,tmpmax, !
47 ! dusfc,dvsfc,dtsfc,dqsfc,totprcp,gflux, !
48 ! dlwsfc,ulwsfc,suntim,runoff,ep,cldwrk, !
49 ! dugwd,dvgwd,psmean,cnvprcp,spfhmin,spfhmax,rain,rainc, !
50 ! dt3dt,dq3dt,du3dt,dv3dt,dqdt_v,cnvqc_v,acv,acvb,acvt, !
51 ! slc,smc,stc,upd_mf,dwn_mf,det_mf,phy_f3d,phy_f2d, !
52 ! dusfc_cpl, dvsfc_cpl, dtsfc_cpl, dqsfc_cpl, !
53 ! dlwsfc_cpl,dswsfc_cpl,dnirbm_cpl,dnirdf_cpl, !
54 ! dvisbm_cpl,dvisdf_cpl,rain_cpl, nlwsfc_cpl,nswsfc_cpl, !
55 ! nnirbm_cpl,nnirdf_cpl,nvisbm_cpl,nvisdf_cpl,snow_cpl, !
56 ! xt,xs,xu,xv,xz,zm,xtts,xzts,d_conv,ifd,dt_cool,Qrain, !
57 ! phy_fctd, !
58 ! outputs: !
59 ! gt0,gq0,gu0,gv0,t2m,q2m,u10m,v10m, !
60 ! zlvl,psurf,hpbl,pwat,t1,q1,u1,v1, !
61 ! chh,cmm,dlwsfci,ulwsfci,dswsfci,uswsfci,dusfci,dvsfci, !
62 ! dtsfci,dqsfci,gfluxi,epi,smcwlt2,smcref2,wet1, !
63 ! dusfci_cpl,dvsfci_cpl,dtsfci_cpl,dqsfci_cpl, !
64 ! dlwsfci_cpl,dswsfci_cpl, !
65 ! dnirbmi_cpl,dnirdfi_cpl,dvisbmi_cpl,dvisdfi_cpl, !
66 ! nlwsfci_cpl,nswsfci_cpl, !
67 ! nnirbmi_cpl,nnirdfi_cpl,nvisbmi_cpl,nvisdfi_cpl, !
68 ! t2mi_cpl,q2mi_cpl, !
69 ! u10mi_cpl,v10mi_cpl,tseai_cpl,psurfi_cpl, !
70 ! tref, z_c, c_0, c_d, w_0, w_d, rqtk, !
71 ! hlwd,lsidea ) !
72 ! !
73 ! subprograms called: !
74 ! !
75 ! get_prs, dcyc2t2_pre_rad (testing), dcyc2t3, sfc_diff, !
76 ! sfc_ocean,sfc_drv, sfc_land, sfc_sice, sfc_diag, moninp1, !
77 ! moninp, moninq1, moninq, gwdps, ozphys, get_phi, !
78 ! sascnv, sascnvn, rascnv, cs_convr, gwdc, shalcvt3,shalcv,!
79 ! shalcnv, cnvc90, lrgscl, gsmdrive, gscond, precpd, !
80 ! progt2. !
81 ! !
82 ! !
83 ! program history log: !
84 ! 19xx - ncep mrf/gfs !
85 ! 2002 - s. moorthi modify and restructure and add Ferrier !
86 ! microphysics as an option !
87 ! 200x - h. juang modify (what?) !
88 ! nov 2004 - x. wu modify sea-ice model !
89 ! may 2005 - s. moorthi modify and restructure !
90 ! 2005 - s. lu modify to include noah lsm !
91 ! oct 2006 - h. wei modify lsm options to include both !
92 ! noah and osu lsms. !
93 ! 2006 - s. moorthi added a. johansson's convective gravity !
94 ! wave parameterization code !
95 ! 2007 - s. moorthi added j. han's modified pbl/sas options !
96 ! dec 2007 - xu li modified the operational version for !
97 ! nst model !
98 ! 2008 - s. moorthi applied xu li's nst model to new gfs !
99 ! mar 2008 - y.-t. hou added sunshine duration var (suntim) as !
100 ! an input/output argument. !
101 ! 2008 - jun wang added spfhmax/spfhmin as input/output. !
102 ! apr 2008 - y.-t. hou added lw sfc emissivity var (sfcemis), !
103 ! define the lw sfc dn/up fluxes in two forms: atmos!
104 ! and ground. also changed sw sfc net flux direction!
105 ! (positive) from ground -> atmos to the direction !
106 ! of atmos -> ground. recode the program and add !
107 ! program documentation block.
108 ! 2008/ - s. moorthi and y.t. hou upgraded the code to more !
109 ! 2009 modern form and changed all the inputs to MKS units.!
110 ! feb 2009 - s. moorthi upgraded to add Hochun's gocart changes !
111 ! jul 2009 - s. moorthi added rqtk for sela's semi-lagrangian !
112 ! aug 2009 - s. moorthi added j. han and h. pan updated shallow !
113 ! convection package !
114 ! sep 2009 - s. moorthi updated for the mcica (rrtm3) radiation !
115 ! dec 2010 - sarah lu lgocart added to input arg; !
116 ! compute dqdt_v if inline gocart is on !
117 ! feb 2011 - sarah lu add the option to update surface diag !
118 ! fields (t2m,q2m,u10m,v10m) at the end !
119 ! Jun 2011 - s. moorthi and Xu Li - updated the nst model !
120 ! !
121 ! sep 2011 - sarah lu correct dqdt_v calculations !
122 ! apr 2012 - henry juang add idea !
123 ! sep 2012 - s. moorthi merge with operational version !
124 ! Mar 2013 - Jun Wang set idea heating rate to tmp tendency !
125 ! May 2013 - Jun Wang tmp updated after idea phys !
126 ! Jun 2013 - s. moorthi corrected a bug in 3d diagnostics for T !
127 ! Aug 2013 - s. moorthi updating J. Whitekar's changes related !
128 ! to stochastic physics perturnbation !
129 ! Oct 2013 - Xingren Wu add dusfci/dvsfci !
130 ! Mar 2014 - Xingren Wu add "_cpl" for coupling !
131 ! Mar 2014 - Xingren Wu add "nir/vis beam and nir/vis diff" !
132 ! Apr 2014 - Xingren Wu add "NET LW/SW including nir/vis" !
133 ! Jan 2014 - Jun Wang merge Moorthi's gwdc change and H.Juang !
134 ! and F. Yang's energy conversion from GWD!
135 ! jan 2014 - y-t hou revised sw sfc spectral component fluxes!
136 ! for coupled mdl, added estimation of ocean albedo !
137 ! without ice contamination. !
138 ! Jun 2014 - Xingren Wu update net SW fluxes over the ocean !
139 ! (no ice contamination) !
140 ! Jul 2014 - Xingren Wu add Sea/Land/Ice Mask - slmsk_cpl !
141 ! Jul 2014 - s. moorthi merge with standalone gfs and cleanup !
142 ! Aug 2014 - s. moorthi add tracer fixer !
143 ! Sep 2014 - Sarah Lu disable the option to compute tracer !
144 ! scavenging in GFS phys (set fscav=0.) !
145 ! Dec 2014 - Jun Wang add cnvqc_v for gocart !
146 
147 ! ==================== defination of variables ==================== !
148 ! --- 2014 - D. Dazlich Added Chikira-Sugiyama (CS) convection !
149 ! as an option in opr GFS. !
150 ! Apr 2015 S. Moorthi Added CS scheme to NEMS/GSM !
151 ! Jun 2015 S. Moorthi Added SHOC to NEMS/GSM !
152 ! Aug 2015 - Xu Li change nst_fcst to be nstf_name !
153 ! and introduce depth mean SST !
154 ! Sep 2015 - Xingren Wu remove oro_cpl & slmsk_cpl !
155 ! Sep 2015 - Xingren Wu add sfc_cice !
156 ! Sep 2015 - Xingren Wu connect CICE output to sfc_cice !
157 ! Jan 2016 - P. Tripp NUOPC/GSM merge !
158 ! Mar 2016 - J. Han - add ncnvcld3d integer !
159 ! for convective cloudiness enhancement !
160 ! Mar 2016 - J. Han - change newsas & sashal to imfdeepcnv !
161 ! & imfshalcnv, respectively !
162 ! Mar 2016 F. Yang add pgr to rayleigh damping call !
163 ! Mar 2016 S. Moorthi add ral_ts !
164 ! Mar 2016 Ann Cheng add morrison 2m microphysics (gsfc) !
165 ! May 2016 S. Moorthi cleanup 2m microphysics implementation !
166 ! Jun 2016 X. Li change all nst_fld as inout !
167 ! jul 2016 S. Moorthi fix some bugs in shoc/2m microphysics !
168 !
169 ! ==================== definition of variables ==================== !
170 ! !
171 ! inputs: size !
355 !
356 ! input/outputs:
420 ! ------- not used below -----------
423 ! ------- not used above -----------
444 !
458 !
459 ! outputs:
488 !
515 
525 !
526 ! ==================== end of description =====================
527 
528  subroutine gbphys &
529 ! --- inputs:
530  & ( im,ix,levs,lsoil,lsm,ntrac,ncld,ntoz,ntcw,ntke, &
531  & ntiw,ntlnc,ntinc, &
532  & nmtvr,nrcm,ko3,lonr,latr,jcap, &
533  & num_p3d,num_p2d,npdf3d,ncnvcld3d, &
534  & kdt,lat,me,pl_coeff,nlons,ncw,flgmin,crtrh,cdmbgwd, &
535  & ccwf,dlqf,ctei_rm,clstp,cgwf,prslrd0,ral_ts,dtp,dtf,fhour, &
536  & solhr,slag,sdec,cdec,sinlat,coslat,pgr,ugrs,vgrs, &
537  & tgrs,qgrs,vvel,prsi,prsl,prslk,prsik,phii,phil, &
538  & rann,prdoz,poz,dpshc,fscav,fswtr,hprime,xlon,xlat, &
539  & h2o_phys,levh2o,h2opl,h2o_pres,h2o_coeff, &
540  & isot, ivegsrc, &
541  & slope,shdmin,shdmax,snoalb,tg3,slmsk,vfrac, &
542  & vtype,stype,uustar,oro,oro_uf,coszen,sfcdsw,sfcnsw, &
543 
544  & sfcnirbmd,sfcnirdfd,sfcvisbmd,sfcvisdfd, &
545  & sfcnirbmu,sfcnirdfu,sfcvisbmu,sfcvisdfu, &
546  & slimskin_cpl,ulwsfcin_cpl, &
547  & dusfcin_cpl,dvsfcin_cpl,dtsfcin_cpl,dqsfcin_cpl, &
548  & sfcdlw,tsflw,sfcemis,sfalb,swh,swhc,hlw,hlwc,hlwd,lsidea, &
549  & ras,pre_rad,ldiag3d,lgocart,lssav,lssav_cpl, &
550 
551  & xkzm_m,xkzm_h,xkzm_s,psautco,prautco,evpco,wminco, &
552  & pdfcld,shcnvcw,sup,redrag,hybedmf,dspheat, &
553  & flipv,old_monin,cnvgwd,shal_cnv, &
554  & imfshalcnv,imfdeepcnv,cal_pre,aero_in, &
555  & mom4ice,mstrat,trans_trac,nstf_name,moist_adj, &
556  & thermodyn_id, sfcpress_id, gen_coord_hybrid,levr,adjtrc,nnp,&
557  & cscnv,nctp,do_shoc,shocaftcnv,ntot3d,ntot2d, &
558 ! --- input/outputs:
559  & hice,fice,tisfc,tsea,tprcp,cv,cvb,cvt, &
560  & srflag,snwdph,weasd,sncovr,zorl,canopy, &
561  & ffmm,ffhh,f10m,srunoff,evbsa,evcwa,snohfa, &
562  & transa,sbsnoa,snowca,soilm,tmpmin,tmpmax, &
563  & dusfc,dvsfc,dtsfc,dqsfc,totprcp,gflux, &
564  & dlwsfc,ulwsfc,suntim,runoff,ep,cldwrk, &
565  & dugwd,dvgwd,psmean,cnvprcp,spfhmin,spfhmax,rain,rainc, &
566 
567  & dt3dt,dq3dt,du3dt,dv3dt,dqdt_v,cnvqc_v,acv,acvb,acvt, &
568  & slc,smc,stc,upd_mf,dwn_mf,det_mf,phy_f3d,phy_f2d, &
569 ! & slc,smc,stc,upd_mf,dwn_mf,det_mf,dkh,rnp,phy_f3d,phy_f2d, &
570  & dusfc_cpl, dvsfc_cpl, dtsfc_cpl, dqsfc_cpl, &
571  & dlwsfc_cpl,dswsfc_cpl,dnirbm_cpl,dnirdf_cpl, &
572  & dvisbm_cpl,dvisdf_cpl,rain_cpl, nlwsfc_cpl,nswsfc_cpl, &
573  & nnirbm_cpl,nnirdf_cpl,nvisbm_cpl,nvisdf_cpl,snow_cpl, &
574 
575  & xt,xs,xu,xv,xz,zm,xtts,xzts,d_conv,ifd,dt_cool,qrain, &
576  & tref, z_c, c_0, c_d, w_0, w_d, &
577  & phy_fctd, &
578 ! --- outputs:
579  & gt0,gq0,gu0,gv0,t2m,q2m,u10m,v10m, &
580  & zlvl,psurf,hpbl,pwat,t1,q1,u1,v1, &
581  & chh,cmm,dlwsfci,ulwsfci,dswsfci,uswsfci,dusfci,dvsfci, &
582  & dtsfci,dqsfci,gfluxi,epi,smcwlt2,smcref2,wet1,sr, &
583 
584  & rqtk, &
585 ! Stochastic physics perturnbation
586  & dtdtr, &
587 
588  & dusfci_cpl, dvsfci_cpl, dtsfci_cpl, dqsfci_cpl, &
589  & dlwsfci_cpl, dswsfci_cpl, &
590  & dnirbmi_cpl, dnirdfi_cpl, dvisbmi_cpl, dvisdfi_cpl, &
591  & nlwsfci_cpl, nswsfci_cpl, &
592  & nnirbmi_cpl, nnirdfi_cpl, nvisbmi_cpl, nvisdfi_cpl, &
593  & t2mi_cpl, q2mi_cpl, u10mi_cpl, v10mi_cpl, &
594  & tseai_cpl, psurfi_cpl &
595  & )
596 !
597  use machine , only : kind_phys
598  use physcons, only : con_cp, con_fvirt, con_g, con_rd, con_rv, &
600  &, rhc_max, dxmin, dxinv, pa2mb, rlapse
601  use module_nst_water_prop, only: get_dtzm_2d
602  use cs_conv, only : cs_convr
603 
604  implicit none
605 !
606 ! --- some constant parameters:
607 
608  real(kind=kind_phys), parameter :: hocp = con_hvap/con_cp
609 ! &, fhourpr = 0.0
610  &, qmin = 1.0e-10
611  &, p850 = 85000.0
612  &, epsq = 1.e-20
613  &, hsub = con_hvap+con_hfus
614  &, czmin = 0.0001 ! cos(89.994)
615 
616 ! --- inputs:
617 
618 ! note: lgocart is the logical flag for in-line gocart;
619 
620  integer, intent(in) :: ix, im, levs, lsoil, lsm, ntrac, &
621  & ncld, ntiw, ntlnc, ntinc, &
622  & ntoz, ntcw, nmtvr, nrcm, ko3, &
623  & lonr, latr, jcap, num_p3d, num_p2d, kdt, &
624  & me, pl_coeff, lat, npdf3d, ncnvcld3d, &
625  & thermodyn_id, sfcpress_id, levr, nnp, nctp,&
626  & ntke, ntot3d, ntot2d, h2o_coeff, levh2o, &
627  & isot, ivegsrc
628 
629 
630  integer, intent(in) :: nlons(im), ncw(2)
631  integer, intent(in) :: nstf_name(5)
632  integer, intent(in) :: imfshalcnv, imfdeepcnv
633 
634  logical, intent(in) :: ras, pre_rad, ldiag3d, flipv, &
635  & old_monin, cnvgwd, aero_in, &
636  & redrag, hybedmf, dspheat, &
637  & lssav, mom4ice, mstrat, &
638  & trans_trac, moist_adj, cal_pre, cscnv, &
639  & shal_cnv, gen_coord_hybrid, lgocart, &
640  & lsidea, lssav_cpl, pdfcld, shcnvcw, &
641  & do_shoc, shocaftcnv, h2o_phys
642 
643  real(kind=kind_phys) :: adjtrc(ntrac)
644 
645  real(kind=kind_phys), dimension(im), intent(in) :: &
646  & sinlat, coslat, pgr, dpshc, xlon, xlat, &
647  & slope, shdmin, shdmax, snoalb, tg3, slmsk, vfrac, &
648  & vtype, stype, uustar, oro, coszen, sfcnsw, sfcdsw, &
649  & sfcnirbmu, sfcnirdfu, sfcvisbmu, sfcvisdfu, &
650  & sfcnirbmd, sfcnirdfd, sfcvisbmd, sfcvisdfd, &
651  & slimskin_cpl, dusfcin_cpl, dvsfcin_cpl, &
652  & dtsfcin_cpl, dqsfcin_cpl, ulwsfcin_cpl, &
653  & sfcdlw, tsflw, sfalb, sfcemis, oro_uf
654 
655  real(kind=kind_phys), dimension(ix,levs), intent(in) :: &
656  & ugrs, vgrs, tgrs, vvel, prsl, prslk, phil, swh, swhc, hlw, hlwc
657 
658 !idea add by hmhj
659  real(kind=kind_phys), intent(in) :: hlwd(ix,levs,6)
660 
661  real(kind=kind_phys), intent(inout) :: qgrs(ix,levs,ntrac)
662 
663  real(kind=kind_phys), dimension(ix,levs+1), intent(in) :: &
664  & prsi, prsik, phii
665 
666  real(kind=kind_phys), intent(in) :: hprime(ix,nmtvr), &
667  & prdoz(ix,ko3,pl_coeff), rann(ix,nrcm), poz(ko3), &
668  & h2opl(ix,levh2o,h2o_coeff), h2o_pres(levh2o)
669 
670  real(kind=kind_phys), intent(in) :: dtp, dtf, fhour, solhr, &
671  & slag, sdec, cdec, ctei_rm(2), clstp, &
672  & ccwf(2), crtrh(3), flgmin(2), dlqf(2), cdmbgwd(2), &
673  & xkzm_m, xkzm_h, xkzm_s, psautco(2), prautco(2), &
674  & evpco, wminco(2), cgwf(2), prslrd0, sup, ral_ts
675 
676 ! --- input/output:
677  real(kind=kind_phys), dimension(im), intent(inout) :: &
678  & hice, fice, tisfc, tsea, tprcp, cv, cvb, cvt, &
679  & srflag, snwdph, weasd, sncovr, zorl, canopy, ffmm, ffhh,&
680  & f10m, srunoff, evbsa, evcwa, snohfa, transa, sbsnoa, &
681  & snowca, soilm, tmpmin, tmpmax, dusfc, dvsfc, dtsfc, &
682  & dqsfc, totprcp, gflux, dlwsfc, ulwsfc, suntim, runoff, ep,&
683  & cldwrk, dugwd, dvgwd, psmean, cnvprcp,spfhmin,spfhmax, &
684  & rain, rainc, acv, acvb, acvt
685  real(kind=kind_phys), dimension(im), optional, intent(inout) :: &
686 ! for A/O/I coupling
687  & dusfc_cpl, dvsfc_cpl, dtsfc_cpl, dqsfc_cpl, &
688  & dlwsfc_cpl,dswsfc_cpl,rain_cpl, snow_cpl, &
689  & dnirbm_cpl,dnirdf_cpl,dvisbm_cpl,dvisdf_cpl, &
690  & nlwsfc_cpl,nswsfc_cpl, &
691  & nnirbm_cpl,nnirdf_cpl,nvisbm_cpl,nvisdf_cpl, &
692 ! for nst
693  & xt, xs, xu, xv, xz, zm, xtts, xzts, d_conv, ifd, dt_cool,
694  & qrain, tref, z_c, c_0, c_d, w_0, w_d
695 
696 !
697  real(kind=kind_phys), dimension(ix,lsoil), intent(inout) :: &
698  & smc, stc, slc
699 
700  real(kind=kind_phys), dimension(ix,levs), intent(inout) :: &
701  & upd_mf, dwn_mf, det_mf, dqdt_v, cnvqc_v
702 ! & upd_mf, dwn_mf, det_mf, dkh, rnp
703 
704  real(kind=kind_phys), intent(inout) :: &
705  & phy_f3d(ix,levs,ntot3d), phy_f2d(ix,ntot2d), &
706  & dt3dt(ix,levs,6), du3dt(ix,levs,4), dv3dt(ix,levs,4), &
707  & dq3dt(ix,levs,5+pl_coeff)
708 
709  real(kind=kind_phys), intent(inout) :: &
710  & phy_fctd(ix,nctp) &
711  real(kind=kind_phys), dimension(ntrac-ncld+2) :: fscav, fswtr
712 
713 ! --- output:
714  real(kind=kind_phys), dimension(im), intent(out) :: &
715  & t2m, q2m, u10m, v10m, zlvl, psurf, hpbl, &
716  & pwat, t1, q1, u1, v1, chh, cmm, &
717  & dlwsfci, ulwsfci, dswsfci, uswsfci, &
718  & dusfci, dvsfci, dtsfci, dqsfci, &
719  & gfluxi, epi, smcwlt2, smcref2, wet1, sr
720 
721  real(kind=kind_phys), dimension(im), optional, intent(out) :: &
722  & dusfci_cpl,dvsfci_cpl,dtsfci_cpl,dqsfci_cpl, &
723  & dlwsfci_cpl,dswsfci_cpl, &
724  & dnirbmi_cpl,dnirdfi_cpl,dvisbmi_cpl,dvisdfi_cpl, &
725  & nlwsfci_cpl,nswsfci_cpl, &
726  & nnirbmi_cpl,nnirdfi_cpl,nvisbmi_cpl,nvisdfi_cpl, &
727  & t2mi_cpl,q2mi_cpl, &
728  & u10mi_cpl,v10mi_cpl,tseai_cpl,psurfi_cpl, &
729  & rqtk
730 
731  real(kind=kind_phys), dimension(ix,levs), intent(out) :: &
732  & gt0, gu0, gv0
733 
734  real(kind=kind_phys), dimension(ix,levs,ntrac), intent(out) :: &
735  & gq0
736 
737 ! --- local:
738 ! real(kind=kind_phys) :: fscav(ntrac-ncld-1)
739 ! real(kind=kind_phys),allocatable :: fscav(:), fswtr(:)
740  real(kind=kind_phys), dimension(im) :: ccwfac, garea, &
741  & dlength, xncw, cumabs, qmax, cice, zice, tice, &
742 ! & gflx, rain, rainc, rainl, rain1, raincs, evapc, &
743  & gflx, rain1, raincs, &
744  & snowmt, cd, cdq, qss, dusfcg, dvsfcg, dusfc1, &
745  & dvsfc1, dtsfc1, dqsfc1, rb, rhscnpy, drain, cld1d, &
746  & evap, hflx, stress, t850, ep1d, gamt, gamq, &
747  & sigmaf, oc, theta, gamma, sigma, &
748  & elvmax, wind, work1, work2, runof, xmu, &
749 ! & elvmax, wind, work1, work2, runof, xmu, oro_land, &
750  & fm10, fh2, tsurf, tx1, tx2, ctei_r, flgmin_l, &
751  & evbs, evcw, trans, sbsno, snowc, frland, &
752  & adjsfcdsw, adjsfcnsw, adjsfcdlw, adjsfculw,gabsbdlw, &
753  & adjnirbmu, adjnirdfu, adjvisbmu, adjvisdfu, &
754  & adjnirbmd, adjnirdfd, adjvisbmd, adjvisdfd, &
755  & xcosz, tseal, snohf, dlqfac, work3, ctei_rml, cldf, &
756  & domr, domzr, domip, doms, psautco_l, prautco_l
757 
758  real(kind=kind_phys), dimension(im) :: ocalnirbm_cpl, &
759  & ocalnirdf_cpl,ocalvisbm_cpl,ocalvisdf_cpl
760 
761 ! & dswsfc, radsl, &
762 ! & dlwsf1, ulwsf1, xcosz, tseal, snohf, dlqfac, &
763 ! & domr, domzr, domip, doms
764 
765 ! real(kind=kind_phys), dimension(ix,levs) :: ud_mf, dd_mf, &
766 ! & dt_mf, del
767  real(kind=kind_phys), dimension(ix,levs) :: del, dtdtr
768  real(kind=kind_phys), dimension(im,levs-1) :: dkt
769 
770  real(kind=kind_phys), dimension(im,levs) :: rhc, dtdt, &
771  & dudt, dvdt, gwdcu, gwdcv, dtdtc, dmdt, &
772 ! & diagn1, diagn2, cuhr, cumchr, &
773  & qr_col, fc_ice, rainp, ud_mf, dd_mf, dt_mf, prnum
774 ! & qr_col, fc_ice, rainp, ud_mf, dd_mf, dt_mf, shoc_cld, prnum
775 
776  real(kind=kind_phys), dimension(im,lsoil) :: smsoil, stsoil, &
777  & ai, bi, cci, rhsmc, zsoil, slsoil
778 
779  real(kind=kind_phys) :: zsea1,zsea2
780  real(kind=kind_phys), dimension(im) :: dtzm
781 
782  real(kind=kind_phys) :: rhbbot, rhbtop, rhpbl, frain, f_rain, &
783  & f_ice, qi, qw, qr, wc, tem, tem1, tem2, sume, sumr, sumq, &
784  & dqdt(im,levs,ntrac), oa4(im,4), clx(im,4), albbm, xcosz_loc
785  real(kind=kind_phys), parameter :: albdf=0.06
786 
787 
788 ! in clw, the first two varaibles are cloud water and ice.
789 ! from third to ntrac are convective transportable tracers,
790 ! third being the ozone, when ntrac=3 (valid only with ras)
791 
792  real(kind=kind_phys), allocatable :: clw(:,:,:), qpl(:,:),qpi(:,:)
793  &, ncpl(:,:), ncpi(:,:)
794 
795  integer, dimension(im) :: kbot, ktop, kcnv, soiltyp, vegtype, &
796  & kpbl, slopetyp, kinver, lmh, levshc, islmsk
797 
798  integer :: i, nvdiff, kk, ic, k, n, ipr, lv, k1, iter, levshcm, &
799  & tracers, trc_shft, tottracer, num2, num3 &
800  &, nshocm, nshoc, ntk, ntln, ntin
801 
802  logical, dimension(im) :: flag_iter, flag_guess, invrsn &
803  &, skip_macro
804 
805  real(kind=kind_phys), dimension(im) :: dtsfc_cice, &
806  & dqsfc_cice, dusfc_cice, dvsfc_cice, ulwsfc_cice, tisfc_cice, &
807  & tsea_cice, hice_cice, fice_cice
808 
809  integer, dimension(im) :: islmsk_cice
810  logical, dimension(im) :: flag_cice
811 
812  logical :: lprnt, revap
813 
814  real(kind=kind_phys), allocatable :: cnvc(:,:),cnvw(:,:)
815  real(kind=kind_phys) eng0, eng1, dtshoc
816 !
817 ! for CS-convection
818 ! real(kind=kind_phys), parameter :: wcbmax1=2.8, wcbmax2=1.4
819  real(kind=kind_phys), parameter :: wcbmax1=2.5, wcbmax2=1.5
820 ! real(kind=kind_phys), parameter :: wcbmax1=1.4, wcbmax2=1.4
821  real(kind=kind_phys) wcbmax(im)
822 !
823  real(kind=kind_phys) tf, tcr, tcrf
824 ! parameter (tf=233.16, tcr=263.16, tcrf=1.0/(tcr-tf))
825  parameter(tf=258.16, tcr=273.16, tcrf=1.0/(tcr-tf))
826 !
827 ! for 2 M microphysics
828  real(kind=kind_phys), allocatable, dimension(:,:) :: qlcn, qicn
829  &, w_upi,cf_upi, cnv_mfd, cnv_prc3, cnv_dqldt,clcn, !Acheng
830  & cnv_fice,cnv_ndrop,cnv_nice
831  real(kind=kind_phys), allocatable, dimension(:) :: cn_prc,cn_snr
832 !
833 !
834 !===> ... begin here
835 !
836 ! The option to compute tracer scavenging in GSM is disabled
837 ! do i=1, ntrac-ncld-1
838 ! fscav(i) = 0.
839 ! enddo
840 
841 
842 ! --- ... set up check print point (for debugging)
843 !
844 !*************************************************************************
845  lprnt = .false.
846 ! lprnt = me == 0 .and. kdt < 10 .and. lat == 22
847  ipr = 1
848 
849 ! if (me == 0 .and. kdt < 5)
850 ! &write(0,*)' In gbphys:', im,ix,levs,lsoil,lsm,
851 ! & ntrac,ncld,ntoz,ntcw,
852 ! & nmtvr,nrcm,ko3,lonr,latr,jcap,num_p3d,num_p2d,npdf3d,
853 ! & kdt,lat,me,pl_coeff,ncw,flgmin,crtrh,cdmbgwd
854 ! &,' ccwf=',ccwf,' dlqf=',dlqf,' ras=',ras,
855 ! & ' evpco=',evpco,' wminco=',wminco,' levr=',levr
856 ! do i = 1, im
857 ! lprnt = kdt >= 256 .and. abs(xlon(i)*57.29578-136.07) < 0.08 &
858 ! & .and. abs(xlat(i)*57.29578+1.1) < 0.101
859 ! lprnt = kdt >= 0 .and. abs(xlon(i)*57.29578-13.125) < 0.501 &
860 ! & .and. abs(xlat(i)*57.29578-79.043) < 0.501
861 ! lprnt = kdt >= 0 .and. abs(xlon(i)*57.29578-8.4375) < 0.501 &
862 ! & .and. abs(xlat(i)*57.29578+1.4) < 0.501
863 ! lprnt = kdt >= 40 .and. abs(xlon(i)*57.29578-288.75) < 1.501 &
864 ! & .and. abs(xlat(i)*57.29578+12.38) < 1.501
865 ! lprnt = kdt >= 0 .and. abs(xlon(i)*57.29578-135.0) < 0.201 &
866 ! & .and. abs(xlat(i)*57.29578-10.476) < 0.201
867 ! lprnt = kdt >= 0 .and. abs(xlon(i)*57.29578-110.3) < 0.201 &
868 ! & .and. abs(xlat(i)*57.29578-2.0) < 0.201
869 ! if (kdt == 10)
870 ! & print *,' i=',i,' xlon=',xlon(i)*57.29578, &
871 ! & ' xlat=',xlat(i)*57.29578,' i=',i,' me=',me
872 ! if (lprnt) then
873 ! ipr = i
874 ! exit
875 ! endif
876 ! enddo
877 
878 ! lprnt = .false.
879 ! if(lprnt) then
880 ! write(0,*)' im=',im,' ix=',ix,' levs=',levs,' lsoil=',lsoil, &
881 ! & ' ntrac=',ntrac,' ntoz=',ntoz,' ntcw=',ntcw,' me=',me, &
882 ! & ' xlat=',xlat(ipr),' kdt=',kdt,' slmsk=',slmsk(ipr), &
883 ! & ' ntke=',ntke,' num_p3d=',num_p3d,' xlon=',xlon(ipr)
884 ! & ' tsea=',tsea(ipr),' tref=',tref(ipr),' dt_cool=',dt_cool(ipr),&
885 ! & ' dt_warm=',2.0*xt(ipr)/xz(ipr),' nrcm=',nrcm,' xlon=',
886 ! & xlon(ipr), &
887 ! & ' dt_warm=',dt_warm(ipr),' nrcm=',nrcm,' xlon=',xlon(ipr), &
888 ! & ' sfalb=',sfalb(ipr),' kdt=',kdt
889 ! write(0,*) ' pgr=',pgr(ipr),' kdt=',kdt,' ipr=',ipr
890 ! write(0,*)' ipr=',ipr,' phy_f2d=',phy_f2d(ipr,1:num_p2d)
891 ! write(0,*),' ugrs=',ugrs(ipr,:)
892 ! write(0,*)' vgrs=',vgrs(ipr,:)
893 ! write(0,*)' tgrs=',tgrs(ipr,:),' kdt=',kdt,' ipr=',ipr
894 ! &, ' xlon=',xlon(ipr),' xlat=',xlat(ipr)
895 ! write(0,*)' qgrs=',qgrs(ipr,:,1)
896 ! write(0,*)' ozg=',qgrs(ipr,:,2)
897 ! write(0,*)' tke=',qgrs(ipr,:,4)
898 ! print *,' clwb=',qgrs(ipr,:,ntiw)
899 ! &, ' xlon=',xlon(ipr),' xlat=',xlat(ipr)
900 ! endif
901 !
902 !*************************************************************************
903 !
904  do i = 1, im
905  if(nint(slmsk(i)) == 1) then
906  frland(i) = 1.0
907  else
908  frland(i) = 0.
909  endif
910  enddo
911 
912  nvdiff = ntrac ! vertical diffusion of all tracers!
913 !
914 ! --- ... figure out number of extra tracers
915 !
916  tottracer = 0 ! no convective transport of tracers
917  if (trans_trac) then
918  if (ntcw > 0) then
919  if (ntoz < ntcw) then
920  trc_shft = ntcw + ncld - 1
921  else
922  trc_shft = ntoz
923  endif
924  elseif (ntoz > 0) then
925  trc_shft = ntoz
926  else
927  trc_shft = 1
928  endif
929 
930  tracers = ntrac - trc_shft
931  tottracer = tracers
932  if (ntoz > 0) tottracer = tottracer + 1 ! ozone is added separately
933  endif
934  if (ntke > 0) ntk = ntke - trc_shft + 3
935 
936 ! if (lprnt) write(0,*)' trans_trac=',trans_trac,' tottracer=', &
937 ! write(0,*)' trans_trac=',trans_trac,' tottracer=', &
938 ! & tottracer,' trc_shft=',trc_shft,' kdt=',kdt
939 ! &, ntrac-ncld+2,' clstp=',clstp,' kdt=',kdt
940 ! &,' ntk=',ntk,' lat=',lat
941 
942  skip_macro = .false.
943  allocate ( clw(ix,levs,tottracer+2) )
944  if (do_shoc) then
945  allocate (qpl(im,levs), qpi(im,levs)
946  &, ncpl(im,levs), ncpi(im,levs))
947  do k=1,levs
948  do i=1,im
949  ncpl(i,k) = 0.0
950  ncpi(i,k) = 0.0
951  enddo
952  enddo
953  endif
954 
955  if (.not. ras .or. .not. cscnv) then
956  allocate ( cnvc(ix,levs), cnvw(ix,levs))
957  endif
958 ! allocate (fscav(tottracer+3), fswtr(tottracer+3))
959 
960  if (ncld == 2) then ! For MGB double moment microphysics
961  allocate (qlcn(im,levs), qicn(im,levs), w_upi(im,levs)
962  &, cf_upi(im,levs), cnv_mfd(im,levs),cnv_prc3(im,levs)
963  &, cnv_dqldt(im,levs), clcn(im,levs), cnv_fice(im,levs)
964  &, cnv_ndrop(im,levs), cnv_nice(im,levs))
965  allocate(cn_prc(im), cn_snr(im))
966  else
967  allocate (qlcn(1,1), qicn(1,1), w_upi(1,1)
968  &, cf_upi(1,1), cnv_mfd(1,1),cnv_prc3(1,1)
969  &, cnv_dqldt(1,1), clcn(1,1), cnv_fice(1,1)
970  &, cnv_ndrop(1,1), cnv_nice(1,1))
971  endif
972 
973 ! The option to compute tracer scavenging in GSM is disabled
974  do i=1, tottracer+3
975  fscav(i) = 0.
976  fswtr(i) = 0.
977  enddo
978 
979  if (nnp == 1) then
980  do n=1,ntrac
981  if (abs(1.0-adjtrc(n)) > 1.0e-7) then
982  do k=1,levs
983  do i=1,im
984  qgrs(i,k,n) = qgrs(i,k,n) * adjtrc(n)
985  enddo
986  enddo
987  endif
988  enddo
989  endif
990 !
991  call get_prs(im,ix,levs,ntrac,tgrs,qgrs, &
992  & thermodyn_id, sfcpress_id, &
993  & gen_coord_hybrid, &
994  & prsi,prsik,prsl,prslk,phii,phil,del)
995 ! & prsi,prsik,prsl,prslk,phii,phil,del,lprnt)
996 !
997 ! if (lprnt) then
998 ! write(0,*)' prsi=',prsi(ipr,:)
999 ! write(0,*)' prsik=',prsik(ipr,:),' me=',me,' kdt=',kdt
1000 ! write(0,*)' prslk=',prslk(ipr,:),' me=',me,' kdt=',kdt
1001 ! write(0,*)' phil=',phil(ipr,:),' me=',me,' kdt=',kdt,' ipr=',ipr
1002 ! &,' lat=',lat,' prsi=',prsi(ipr,1)
1003 ! write(0,*)' prsl=',prsl(ipr,:),' kdt=',kdt
1004 ! print *,' del=',del(ipr,:)
1005 ! endif
1006 !
1007  rhbbot = crtrh(1)
1008  rhpbl = crtrh(2)
1009  rhbtop = crtrh(3)
1010 !
1011 ! --- ... frain=factor for centered difference scheme correction of rain amount.
1012 
1013  frain = dtf / dtp
1014 
1015  do i = 1, im
1016  sigmaf(i) = max( vfrac(i),0.01 )
1017 ! sigmaf(i) = max( vfrac(i),0.3 )
1018  if (lsm == 0) sigmaf(i) = 0.5 + vfrac(i) * 0.5
1019 
1020  islmsk(i) = nint(slmsk(i))
1021 
1022  if (islmsk(i) == 2) then
1023  if (isot == 1) then
1024  soiltyp(i) = 16
1025  else
1026  soiltyp(i) = 9
1027  endif
1028  if (ivegsrc == 1) then
1029  vegtype(i) = 15
1030  elseif(ivegsrc == 2) then
1031  vegtype(i) = 13
1032  endif
1033  slopetyp(i) = 9 !! clu: qa(slopetyp)
1034  else
1035  soiltyp(i) = int( stype(i)+0.5 )
1036  vegtype(i) = int( vtype(i)+0.5 )
1037  slopetyp(i) = int( slope(i)+0.5 ) !! clu: slope -> slopetyp
1038  endif
1039 ! --- ... xw: transfer ice thickness & concentration from global to local variables
1040  zice(i) = hice(i)
1041  cice(i) = fice(i)
1042  tice(i) = tisfc(i)
1043 
1044  if (lssav_cpl) then
1045  islmsk_cice(i) = nint(slimskin_cpl(i))
1046  flag_cice(i) = (islmsk_cice(i) == 4)
1047 
1048  ulwsfc_cice(i) = ulwsfcin_cpl(i)
1049  dusfc_cice(i) = dusfcin_cpl(i)
1050  dvsfc_cice(i) = dvsfcin_cpl(i)
1051  dtsfc_cice(i) = dtsfcin_cpl(i)
1052  dqsfc_cice(i) = dqsfcin_cpl(i)
1053  tisfc_cice(i) = tisfc(i)
1054  tsea_cice(i) = tsea(i)
1055  fice_cice(i) = fice(i)
1056  hice_cice(i) = hice(i)
1057  endif
1058 
1059  work1(i) = (log(coslat(i) / (nlons(i)*latr)) - dxmin) * dxinv
1060  work1(i) = max(0.0, min(1.0,work1(i)))
1061  work2(i) = 1.0 - work1(i)
1062  psurf(i) = pgr(i)
1063  work3(i) = prsik(i,1) / prslk(i,1)
1064  tem1 = con_rerth * (con_pi+con_pi)*coslat(i)/nlons(i)
1065  tem2 = con_rerth * con_pi / latr
1066  garea(i) = tem1 * tem2
1067  dlength(i) = sqrt( tem1*tem1+tem2*tem2 )
1068  cldf(i) = cgwf(1)*work1(i) + cgwf(2)*work2(i)
1069  wcbmax(i) = wcbmax1*work1(i) + wcbmax2*work2(i)
1070  enddo
1071 
1072 ! if (lprnt) write(0,*)' in gbphys work1&2=',work1(ipr),work2(ipr)
1073 ! &,' dxmin=',dxmin,' dxinv=',dxinv,' dx=',
1074 ! & log(coslat(ipr) / (nlons(ipr)*latr))
1075 ! &,' coslat=',coslat(ipr),' nlons=',nlons(ipr),' latr=',latr
1076 
1077 ! --- ... transfer soil moisture and temperature from global to local variables
1078 
1079  do k = 1, lsoil
1080  do i = 1, im
1081  smsoil(i,k) = smc(i,k)
1082  stsoil(i,k) = stc(i,k)
1083  slsoil(i,k) = slc(i,k) !! clu: slc -> slsoil
1084  enddo
1085  enddo
1086 
1087  do k = 1, levs
1088  do i = 1, im
1089  dudt(i,k) = 0.
1090  dvdt(i,k) = 0.
1091  dtdt(i,k) = 0.
1092  dtdtc(i,k) = 0.
1093  enddo
1094  enddo
1095 
1096  do n = 1, ntrac
1097  do k = 1, levs
1098  do i = 1, im
1099  dqdt(i,k,n) = 0.
1100  enddo
1101  enddo
1102  enddo
1103 
1104 ! --- ... initialize dtdt with heating rate from dcyc2
1105 
1106 ! if (lprnt) then
1107 ! do ipr=1,im
1108 ! write(0,*)' before dcyc2: im=',im,' lsoil=',lsoil,' levs=', &
1109 ! & levs &
1110 ! &, ' sde=',sdec,' cdec=',cdec,' tsea=',tsea(ipr),' ipr=',ipr &
1111 ! &, ' lat=',lat,' me=',me,' kdt=',kdt &
1112 ! &, ' sfcdlw=',sfcdlw(ipr),' sfcnsw=',sfcnsw(ipr)
1113 ! print *,' hlw=',hlw(ipr,:),' me=',me,' lat=',lat,xlon(ipr)
1114 ! print *,' swh=',swh(ipr,:),' me=',me,' lat=',lat,xlon(ipr)
1115 ! enddo
1116 ! endif
1117 
1118 ! --- ... adjust mean radiation fluxes and heating rates to fit for
1119 ! faster model time steps.
1120 ! sw: using cos of zenith angle as scaling factor
1121 ! lw: using surface air skin temperature as scaling factor
1122 
1123  if (pre_rad) then
1124 
1125  call dcyc2t3_pre_rad &
1126 ! --- inputs:
1127  & ( solhr,slag,sdec,cdec,sinlat,coslat, &
1128  & xlon,coszen,tsea,tgrs(1,1),tgrs(1,1), &
1129  & sfcdsw,sfcnsw,sfcdlw,swh,hlw, &
1130  & sfcnirbmu,sfcnirdfu,sfcvisbmu,sfcvisdfu, &
1131  & sfcnirbmd,sfcnirdfd,sfcvisbmd,sfcvisdfd, &
1132  & ix, im, levs, &
1133 ! --- input/output:
1134  & dtdt, &
1135 ! --- outputs:
1136  & adjsfcdsw,adjsfcnsw,adjsfcdlw,adjsfculw,xmu,xcosz, &
1137  & adjnirbmu,adjnirdfu,adjvisbmu,adjvisdfu, &
1138  & adjnirbmd,adjnirdfd,adjvisbmd,adjvisdfd &
1139  & )
1140 
1141  else
1142 
1143  call dcyc2t3 &
1144 ! --- inputs:
1145  & ( solhr,slag,sdec,cdec,sinlat,coslat, &
1146  & xlon,coszen,tsea,tgrs(1,1),tsflw,sfcemis, &
1147  & sfcdsw,sfcnsw,sfcdlw,swh,swhc,hlw,hlwc, &
1148  & sfcnirbmu,sfcnirdfu,sfcvisbmu,sfcvisdfu, &
1149  & sfcnirbmd,sfcnirdfd,sfcvisbmd,sfcvisdfd, &
1150  & ix, im, levs, &
1151 ! --- input/output:
1152  & dtdt,dtdtc, &
1153 ! --- outputs:
1154  & adjsfcdsw,adjsfcnsw,adjsfcdlw,adjsfculw,xmu,xcosz, &
1155  & adjnirbmu,adjnirdfu,adjvisbmu,adjvisdfu, &
1156  & adjnirbmd,adjnirdfd,adjvisbmd,adjvisdfd &
1157  & )
1158 
1159 !
1160 ! save temp change due to radiation - need for sttp stochastic physics
1161 !---------------------------------------------------------------------
1162  do k=1,levs
1163  do i=1,im
1164  dtdtr(i,k) = dtdtr(i,k) + dtdtc(i,k)*dtf
1165  enddo
1166  enddo
1167 
1168  endif
1169 !
1170  if (lsidea) then !idea jw
1171  do k = 1, levs
1172  do i = 1, im
1173 ! dtdt(i,k) = hlwd(i,k,2)
1174  dtdt(i,k) = 0.
1175  enddo
1176  enddo
1177  endif
1178 
1179 ! --- convert lw fluxes for land/ocean/sea-ice models
1180 ! note: for sw: adjsfcdsw and adjsfcnsw are zenith angle adjusted downward/net fluxes.
1181 ! for lw: adjsfcdlw is (sfc temp adjusted) downward fluxe with no emiss effect.
1182 ! adjsfculw is (sfc temp adjusted) upward fluxe including emiss effect.
1183 ! one needs to be aware that that the absorbed downward lw flux (used by land/ocean
1184 ! models as downward flux) is not the same as adjsfcdlw but a value reduced by
1185 ! the factor of emissivity. however, the net effects are the same when seeing
1186 ! it either above the surface interface or below.
1187 !
1188 ! - flux above the interface used by atmosphere model:
1189 ! down: adjsfcdlw; up: adjsfculw = sfcemis*sigma*T**4 + (1-sfcemis)*adjsfcdlw
1190 ! net = up - down = sfcemis * (sigma*T**4 - adjsfcdlw)
1191 ! - flux below the interface used by lnd/oc/ice models:
1192 ! down: sfcemis*adjsfcdlw; up: sfcemis*sigma*T**4
1193 ! net = up - down = sfcemis * (sigma*T**4 - adjsfcdlw)
1194 
1195 ! --- ... define the downward lw flux absorbed by ground
1196 
1197  do i = 1, im
1198  gabsbdlw(i) = sfcemis(i) * adjsfcdlw(i)
1199  enddo
1200 
1201 ! if( lsidea ) then ! idea : moved temp adjust to idea_phys
1202 ! print *,' in gbphys: lsidea is true '
1203 ! DTDT = 0.
1204 ! endif
1205 
1206  if (lssav) then ! --- ... accumulate/save output variables
1207 
1208 ! --- ... sunshine duration time is defined as the length of time (in mdl output
1209 ! interval) that solar radiation falling on a plane perpendicular to the
1210 ! direction of the sun >= 120 w/m2
1211 
1212  do i = 1, im
1213  if ( xcosz(i) >= czmin ) then ! zenth angle > 89.994 deg
1214  tem1 = adjsfcdsw(i) / xcosz(i)
1215 
1216  if ( tem1 >= 120.0 ) then
1217  suntim(i) = suntim(i) + dtf
1218  endif
1219  endif
1220  enddo
1221 
1222 ! --- ... sfc lw fluxes used by atmospheric model are saved for output
1223 
1224  do i = 1, im
1225  dlwsfc(i) = dlwsfc(i) + adjsfcdlw(i)*dtf
1226  if (lssav_cpl) then
1227  if (flag_cice(i)) adjsfculw(i) = ulwsfc_cice(i)
1228  endif
1229  ulwsfc(i) = ulwsfc(i) + adjsfculw(i)*dtf
1230  psmean(i) = psmean(i) + pgr(i)*dtf ! mean surface pressure
1231  enddo
1232 
1233  if (ldiag3d) then
1234  if( lsidea ) then
1235  do k = 1, levs
1236  do i = 1, im
1237  dt3dt(i,k,1) = dt3dt(i,k,1) + hlwd(i,k,1)*dtf
1238  dt3dt(i,k,2) = dt3dt(i,k,2) + hlwd(i,k,2)*dtf
1239  dt3dt(i,k,3) = dt3dt(i,k,3) + hlwd(i,k,3)*dtf
1240  dt3dt(i,k,4) = dt3dt(i,k,4) + hlwd(i,k,4)*dtf
1241  dt3dt(i,k,5) = dt3dt(i,k,5) + hlwd(i,k,5)*dtf
1242  dt3dt(i,k,6) = dt3dt(i,k,6) + hlwd(i,k,6)*dtf
1243  enddo
1244  enddo
1245  else
1246  do k = 1, levs
1247  do i = 1, im
1248  dt3dt(i,k,1) = dt3dt(i,k,1) + hlw(i,k)*dtf
1249  dt3dt(i,k,2) = dt3dt(i,k,2) + swh(i,k)*dtf*xmu(i)
1250  enddo
1251  enddo
1252  endif
1253  endif
1254 
1255  endif ! end if_lssav_block
1256 
1257  do i = 1, im
1258  kcnv(i) = 0
1259  kinver(i) = levs
1260  invrsn(i) = .false.
1261  tx1(i) = 0.0
1262  tx2(i) = 10.0
1263  ctei_r(i) = 10.0
1264  enddo
1265 
1266 ! Only used for old shallow convection with mstrat=.true.
1267 
1268  if (((imfshalcnv == 0 .and. shal_cnv) .or. old_monin) &
1269  & .and. mstrat) then
1270  do i = 1, im
1271  ctei_rml(i) = ctei_rm(1)*work1(i) + ctei_rm(2)*work2(i)
1272  enddo
1273  do k = 1, levs/2
1274  do i = 1, im
1275  if (prsi(i,1)-prsi(i,k+1) < 0.35*prsi(i,1) &
1276  & .and. (.not. invrsn(i))) then
1277  tem = (tgrs(i,k+1)-tgrs(i,k)) / (prsl(i,k)-prsl(i,k+1))
1278 
1279  if ((tem > 0.00010 .and. tx1(i) < 0.0) .or.
1280  & (tem-abs(tx1(i)) > 0.0 .and. tx2(i) < 0.0)) then
1281  invrsn(i) = .true.
1282 
1283  if (qgrs(i,k,1) > qgrs(i,k+1,1)) then
1284  tem1 = tgrs(i,k+1) + hocp*max(qgrs(i,k+1,1),qmin)
1285  tem2 = tgrs(i,k) + hocp*max(qgrs(i,k,1),qmin)
1286 
1287  tem1 = tem1 / prslk(i,k+1) - tem2 / prslk(i,k)
1288 
1289 ! --- ... (cp/l)(deltathetae)/(deltatwater) > ctei_rm -> conditon for CTEI
1290  ctei_r(i) = (1.0/hocp)*tem1/(qgrs(i,k+1,1)-qgrs(i,k,1)&
1291  & + qgrs(i,k+1,ntcw)-qgrs(i,k,ntcw))
1292  else
1293  ctei_r(i) = 10
1294  endif
1295 
1296  if ( ctei_rml(i) > ctei_r(i) ) then
1297  kinver(i) = k
1298  else
1299  kinver(i) = levs
1300  endif
1301  endif
1302 
1303  tx2(i) = tx1(i)
1304  tx1(i) = tem
1305  endif
1306  enddo
1307  enddo
1308  endif
1309 
1310 ! --- ... check print
1311 
1312 ! ipr = 1
1313 ! if (lprnt) then
1314 ! write(0,*)' before progtm: im=',im,' lsoil=',lsoil &
1315 ! &, ' nvdiff=',nvdiff,' adjsfcnsw=',adjsfcnsw(ipr) &
1316 ! &, ' adjsfcdlw=',adjsfcdlw(ipr),'adjsfculw=',adjsfculw(ipr)&
1317 ! &, ' sfcemis=',sfcemis(ipr),' tsea2=',tsea(ipr) &
1318 ! &, ' ipr=',ipr,' me=',me,' lat=',lat,' xlon=',xlon(ipr) &
1319 ! &, ' kdt=',kdt
1320 ! write(0,*)' dtdth=',dtdt(ipr,:),' kdt=',kdt
1321 ! endif
1322 
1323 
1324 ! --- ... lu: initialize flag_guess, flag_iter, tsurf
1325 
1326  do i = 1, im
1327  tsurf(i) = tsea(i)
1328  flag_guess(i) = .false.
1329  flag_iter(i) = .true.
1330  drain(i) = 0.0
1331  ep1d(i) = 0.0
1332  runof(i) = 0.0
1333  hflx(i) = 0.0
1334  evap(i) = 0.0
1335 
1336  evbs(i) = 0.0
1337  evcw(i) = 0.0
1338  trans(i) = 0.0
1339  sbsno(i) = 0.0
1340  snowc(i) = 0.0
1341  snohf(i) = 0.0
1342  zlvl(i) = phil(i,1) / con_g
1343  smcwlt2(i) = 0.0
1344  smcref2(i) = 0.0
1345  enddo
1346 
1347 ! --- ... lu: iter-loop over (sfc_diff,sfc_drv,sfc_ocean,sfc_sice)
1348 
1349  do iter = 1, 2
1350 
1351 ! --- ... surface exchange coefficients
1352 !
1353 ! if (lprnt) write(0,*)' tsea=',tsea(ipr),' tsurf=',tsurf(ipr),iter
1354  call sfc_diff(im,pgr,ugrs,vgrs,tgrs,qgrs,zlvl, &
1355  & snwdph,tsea,zorl,cd,cdq,rb, &
1356  & prsl(1,1),work3,islmsk, &
1357  & stress,ffmm,ffhh, &
1358  & uustar,wind,phy_f2d(1,num_p2d),fm10,fh2, &
1359  & sigmaf,vegtype,shdmax,ivegsrc, &
1360  & tsurf, flag_iter, redrag)
1361 
1362 ! if (lprnt) write(0,*)' cdq=',cdq(ipr),' iter=',iter &
1363 ! &, ' wind=',wind(ipr),'phy_f2d=',phy_f2d(ipr,num_p2d),' ugrs=' &
1364 ! &, ugrs(ipr,1),' vgrs=',vgrs(ipr,1)
1365 
1366 ! --- ... lu: update flag_guess
1367 
1368  do i = 1, im
1369  if (iter == 1 .and. wind(i) < 2.0) then
1370  flag_guess(i) = .true.
1371  endif
1372  enddo
1373 
1374  if ( nstf_name(1) > 0 ) then
1375 
1376  do i = 1, im
1377  if ( islmsk(i) == 0 ) then
1378  tem = (oro(i)-oro_uf(i)) * rlapse
1379  tseal(i) = tsea(i) + tem
1380  tsurf(i) = tsurf(i) + tem
1381  endif
1382  enddo
1383 
1384 ! if (lprnt) write(0,*)' tseaz1=',tsea(ipr),' tref=',tref(ipr)
1385 ! &, ' dt_cool=',dt_cool(ipr),' dt_warm=',2.0*(xt(ipr)/xz(ipr)
1386 ! &, ' kdt=',kdt
1387 ! &, ' tgrs=',tgrs(ipr,1),' prsl=',prsl(ipr,1)
1388 ! &, ' work3=',work3(ipr),' kdt=',kdt
1389 
1390  call sfc_nst &
1391  & ( im,lsoil,pgr,ugrs,vgrs,tgrs,qgrs,tref,cd,cdq, &
1392  & prsl(1,1),work3,islmsk,xlon,sinlat,stress, &
1393  & sfcemis,gabsbdlw,adjsfcnsw,tprcp,dtf,kdt,solhr,xcosz, &
1394  & phy_f2d(1,num_p2d),flag_iter,flag_guess,nstf_name, &
1395  & lprnt,ipr, &
1396 ! --- Input/output
1397  & tseal,tsurf,xt,xs,xu,xv,xz,zm,xtts,xzts,dt_cool, &
1398  & z_c,c_0,c_d,w_0,w_d,d_conv,ifd,qrain, &
1399 ! --- outputs:
1400  & qss, gflx, cmm, chh, evap, hflx, ep1d)
1401 
1402 ! if (lprnt) print *,' tseaz2=',tseal(ipr),' tref=',tref(ipr),
1403 ! & ' dt_cool=',dt_cool(ipr),' dt_warm=',2.0*xt(ipr)/xz(ipr),
1404 ! & ' kdt=',kdt
1405 
1406  do i = 1, im
1407  if ( islmsk(i) == 0 ) then
1408  tsurf(i) = tsurf(i) - (oro(i)-oro_uf(i)) * rlapse
1409  endif
1410  enddo
1411 
1412 ! --- ... run nsst model ... ---
1413 
1414  if ( nstf_name(1) > 1 ) then
1415  zsea1 = 0.001*real(nstf_name(4))
1416  zsea2 = 0.001*real(nstf_name(5))
1417  call get_dtzm_2d(xt,xz,dt_cool,z_c,slmsk,
1418  & zsea1,zsea2,im,1,dtzm)
1419  do i = 1, im
1420  if ( islmsk(i) == 0 ) then
1421  tsea(i) = max(271.2,tref(i) + dtzm(i))
1422  & -(oro(i)-oro_uf(i))*rlapse
1423  endif
1424  enddo
1425  endif
1426 
1427 ! if (lprnt) print *,' tseaz2=',tsea(ipr),' tref=',tref(ipr), &
1428 ! & ' dt_cool=',dt_cool(ipr),' dt_warm=',dt_warm(ipr),' kdt=',kdt
1429 
1430  else
1431 
1432 ! --- ... surface energy balance over ocean
1433 
1434  call sfc_ocean &
1435 ! --- inputs:
1436  & ( im,pgr,ugrs,vgrs,tgrs,qgrs,tsea,cd,cdq, &
1437  & prsl(1,1),work3,islmsk,phy_f2d(1,num_p2d),flag_iter, &
1438 ! --- outputs:
1439  & qss,cmm,chh,gflx,evap,hflx,ep1d &
1440  & )
1441 
1442  endif ! if ( nstf_name(1) > 0 ) then
1443 
1444 ! if (lprnt) write(0,*)' sfalb=',sfalb(ipr),' ipr=',ipr &
1445 ! &, ' weasd=',weasd(ipr),' snwdph=',snwdph(ipr) &
1446 ! &, ' tprcp=',tprcp(ipr),' kdt=',kdt,' iter=',iter
1447 ! &,' tseabefland=',tsea(ipr)
1448 
1449 ! --- ... surface energy balance over land
1450 !
1451  if (lsm == 1) then ! noah lsm call
1452 
1453 ! if (lprnt) write(0,*)' tsead=',tsea(ipr),' tsurf=',tsurf(ipr),iter
1454 ! &,' pgr=',pgr(ipr),' sfcemis=',sfcemis(ipr)
1455 
1456  call sfc_drv &
1457 
1458 ! --- inputs:
1459  & ( im,lsoil,pgr,ugrs,vgrs,tgrs,qgrs,soiltyp,vegtype,sigmaf, &
1460  & sfcemis,gabsbdlw,adjsfcdsw,adjsfcnsw,dtf,tg3,cd,cdq, &
1461  & prsl(1,1),work3,zlvl,islmsk,phy_f2d(1,num_p2d),slopetyp, &
1462  & shdmin,shdmax,snoalb,sfalb,flag_iter,flag_guess, &
1463  & isot,ivegsrc, &
1464 ! --- in/outs:
1465  & weasd,snwdph,tsea,tprcp,srflag,smsoil,stsoil,slsoil, &
1466  & canopy,trans,tsurf,zorl, &
1467 ! --- outputs:
1468  & sncovr,qss,gflx,drain,evap,hflx,ep1d,runof, &
1469  & cmm,chh,evbs,evcw,sbsno,snowc,soilm,snohf, &
1470  & smcwlt2,smcref2,wet1 &
1471  & )
1472 
1473 ! if (lprnt) write(0,*)' tseae=',tsea(ipr),' tsurf=',tsurf(ipr),iter
1474 ! &,' phy_f2d=',phy_f2d(ipr,num_p2d)
1475 
1476  else ! osu lsm call
1477 
1478  call sfc_land &
1479 ! --- inputs:
1480  & ( im,lsoil,pgr,ugrs,vgrs,tgrs,qgrs,smsoil,soiltyp, &
1481  & sigmaf,vegtype,sfcemis,adjsfcdlw,adjsfcnsw,dtf, &
1482  & tg3,cd,cdq,prsl(1,1),work3,islmsk, &
1483 ! & zorl,tg3,cd,cdq,prsl(1,1),work3,islmsk, &
1484  & phy_f2d(1,num_p2d),flag_iter,flag_guess, &
1485 ! --- input/outputs:
1486  & weasd,tsea,tprcp,srflag,stsoil,canopy,tsurf, &
1487 ! --- outputs:
1488  & qss,snowmt,gflx,zsoil,rhscnpy,rhsmc, &
1489  & ai,bi,cci,drain,evap,hflx,ep1d,cmm,chh, &
1490  & evbs,evcw,trans,sbsno,snowc,soilm, &
1491  & snohf,smcwlt2,smcref2 &
1492  & )
1493 
1494  endif
1495 
1496 ! if (lprnt) write(0,*)' tseabeficemodel =',tsea(ipr),' me=',me &
1497 ! &, ' kdt=',kdt
1498 
1499 ! --- ... surface energy balance over seaice
1500 
1501  if (lssav_cpl) then
1502  do i = 1, im
1503  if (flag_cice(i)) then
1504  islmsk(i) = islmsk_cice(i)
1505  endif
1506  enddo
1507  endif
1508 
1509  call sfc_sice &
1510 ! --- inputs:
1511  & ( im,lsoil,pgr,ugrs,vgrs,tgrs,qgrs,dtf, &
1512  & sfcemis,gabsbdlw,adjsfcnsw,adjsfcdsw,srflag, &
1513  & cd,cdq,prsl(1,1),work3,islmsk,phy_f2d(1,num_p2d), &
1514  & flag_iter,mom4ice,lsm, lprnt,ipr, &
1515 ! & flag_iter,mom4ice,lsm, &
1516 ! --- input/outputs:
1517  & zice,cice,tice,weasd,tsea,tprcp,stsoil,ep1d, &
1518 ! --- outputs:
1519  & snwdph,qss,snowmt,gflx,cmm,chh,evap,hflx &
1520  & )
1521 
1522  if (lssav_cpl) then
1523  do i = 1, im
1524  if (flag_cice(i)) then
1525  islmsk(i) = nint(slmsk(i))
1526  endif
1527  enddo
1528 
1529  call sfc_cice &
1530 ! --- inputs:
1531  & ( im,ugrs,vgrs,tgrs,qgrs,cd,cdq,prsl(1,1),work3, &
1532  & islmsk_cice,phy_f2d(1,num_p2d),flag_iter, &
1533  & dqsfc_cice,dtsfc_cice, &
1534 ! --- outputs:
1535  & qss,cmm,chh,evap,hflx &
1536  & )
1537  endif
1538 
1539 ! --- ... lu: update flag_iter and flag_guess
1540 
1541  do i = 1, im
1542  flag_iter(i) = .false.
1543  flag_guess(i) = .false.
1544 
1545  if(islmsk(i) == 1 .and. iter == 1) then
1546  if (wind(i) < 2.0) flag_iter(i) = .true.
1547  elseif (islmsk(i) == 0 .and. iter == 1 &
1548  & .and. nstf_name(1) > 0) then
1549  if (wind(i) < 2.0) flag_iter(i) = .true.
1550  endif
1551  enddo
1552 
1553  enddo ! end iter_loop
1554 
1555  do i = 1, im
1556  epi(i) = ep1d(i)
1557  dlwsfci(i) = adjsfcdlw(i)
1558  ulwsfci(i) = adjsfculw(i)
1559  uswsfci(i) = adjsfcdsw(i) - adjsfcnsw(i)
1560  dswsfci(i) = adjsfcdsw(i)
1561  gfluxi(i) = gflx(i)
1562  t1(i) = tgrs(i,1)
1563  q1(i) = qgrs(i,1,1)
1564  u1(i) = ugrs(i,1)
1565  v1(i) = vgrs(i,1)
1566  enddo
1567 
1568  if (lsm == 0) then ! osu lsm call
1569  do i = 1, im
1570  sncovr(i) = 0.0
1571  if (weasd(i) > 0.0) sncovr(i) = 1.0
1572  enddo
1573  endif
1574 
1575 ! --- ... update near surface fields
1576 
1577  call sfc_diag(im,pgr,ugrs,vgrs,tgrs,qgrs, &
1578  & tsea,qss,f10m,u10m,v10m,t2m,q2m,work3, &
1579  & evap,ffmm,ffhh,fm10,fh2)
1580 
1581  do i = 1, im
1582  phy_f2d(i,num_p2d) = 0.0
1583  enddo
1584 
1585  if (lssav_cpl) then
1586  do i = 1, im
1587  dlwsfci_cpl(i) = adjsfcdlw(i)
1588  dswsfci_cpl(i) = adjsfcdsw(i)
1589  dlwsfc_cpl(i) = dlwsfc_cpl(i) + adjsfcdlw(i)*dtf
1590  dswsfc_cpl(i) = dswsfc_cpl(i) + adjsfcdsw(i)*dtf
1591  dnirbmi_cpl(i) = adjnirbmd(i)
1592  dnirdfi_cpl(i) = adjnirdfd(i)
1593  dvisbmi_cpl(i) = adjvisbmd(i)
1594  dvisdfi_cpl(i) = adjvisdfd(i)
1595  dnirbm_cpl(i) = dnirbm_cpl(i) + adjnirbmd(i)*dtf
1596  dnirdf_cpl(i) = dnirdf_cpl(i) + adjnirdfd(i)*dtf
1597  dvisbm_cpl(i) = dvisbm_cpl(i) + adjvisbmd(i)*dtf
1598  dvisdf_cpl(i) = dvisdf_cpl(i) + adjvisdfd(i)*dtf
1599  nlwsfci_cpl(i) = adjsfcdlw(i) - adjsfculw(i)
1600  nlwsfc_cpl(i) = nlwsfc_cpl(i) + nlwsfci_cpl(i)*dtf
1601  t2mi_cpl(i) = t2m(i)
1602  q2mi_cpl(i) = q2m(i)
1603  u10mi_cpl(i) = u10m(i)
1604  v10mi_cpl(i) = v10m(i)
1605  tseai_cpl(i) = tsea(i)
1606  psurfi_cpl(i) = pgr(i)
1607  enddo
1608 
1609 ! --- estimate mean albedo for ocean point without ice cover and apply
1610 ! them to net SW heat fluxes
1611 
1612  do i = 1, im
1613  if (islmsk(i) /= 1) then ! not a land point
1614 ! --- compute open water albedo
1615  xcosz_loc = max( 0.0, min( 1.0, xcosz(i) ))
1616  ocalnirdf_cpl(i) = 0.06
1617  ocalnirbm_cpl(i) = max(albdf, 0.026/(xcosz_loc**1.7+0.065) &
1618  & + 0.15 * (xcosz_loc-0.1) * (xcosz_loc-0.5) &
1619  & * (xcosz_loc-1.0))
1620  ocalvisdf_cpl(i) = 0.06
1621  ocalvisbm_cpl(i) = ocalnirbm_cpl(i)
1622 
1623  nnirbmi_cpl(i) = adjnirbmd(i)-adjnirbmd(i)*ocalnirbm_cpl(i)
1624  nnirdfi_cpl(i) = adjnirdfd(i)-adjnirdfd(i)*ocalnirdf_cpl(i)
1625  nvisbmi_cpl(i) = adjvisbmd(i)-adjvisbmd(i)*ocalvisbm_cpl(i)
1626  nvisdfi_cpl(i) = adjvisdfd(i)-adjvisdfd(i)*ocalvisdf_cpl(i)
1627  else
1628  nnirbmi_cpl(i) = adjnirbmd(i) - adjnirbmu(i)
1629  nnirdfi_cpl(i) = adjnirdfd(i) - adjnirdfu(i)
1630  nvisbmi_cpl(i) = adjvisbmd(i) - adjvisbmu(i)
1631  nvisdfi_cpl(i) = adjvisdfd(i) - adjvisdfu(i)
1632  endif
1633  nswsfci_cpl(i) = nnirbmi_cpl(i) + nnirdfi_cpl(i) &
1634  & + nvisbmi_cpl(i) + nvisdfi_cpl(i)
1635  nswsfc_cpl(i) = nswsfc_cpl(i) + nswsfci_cpl(i)*dtf
1636  nnirbm_cpl(i) = nnirbm_cpl(i) + nnirbmi_cpl(i)*dtf
1637  nnirdf_cpl(i) = nnirdf_cpl(i) + nnirdfi_cpl(i)*dtf
1638  nvisbm_cpl(i) = nvisbm_cpl(i) + nvisbmi_cpl(i)*dtf
1639  nvisdf_cpl(i) = nvisdf_cpl(i) + nvisdfi_cpl(i)*dtf
1640  enddo
1641  endif
1642 
1643  if (lssav) then
1644  do i = 1, im
1645  gflux(i) = gflux(i) + gflx(i) * dtf
1646  evbsa(i) = evbsa(i) + evbs(i) * dtf
1647  evcwa(i) = evcwa(i) + evcw(i) * dtf
1648  transa(i) = transa(i) + trans(i) * dtf
1649  sbsnoa(i) = sbsnoa(i) + sbsno(i) * dtf
1650  snowca(i) = snowca(i) + snowc(i) * dtf
1651  snohfa(i) = snohfa(i) + snohf(i) * dtf
1652  ep(i) = ep(i) + ep1d(i) * dtf
1653 
1654  tmpmax(i) = max(tmpmax(i),t2m(i))
1655  tmpmin(i) = min(tmpmin(i),t2m(i))
1656 
1657  spfhmax(i) = max(spfhmax(i),q2m(i))
1658  spfhmin(i) = min(spfhmin(i),q2m(i))
1659  enddo
1660  endif
1661 
1662 !!!!!!!!!!!!!!!!!Commented by Moorthi on July 18, 2012 !!!!!!!!!!!!!!!!!!!
1663 ! do i = 1, im
1664 ! --- ... compute coefficient of evaporation in evapc
1665 !
1666 ! if (evapc(i) > 1.0e0) evapc(i) = 1.0e0
1667 ! --- ... over snow cover or ice or sea, coef of evap =1.0e0
1668 ! if (weasd(i) > 0.0 .or. slmsk(i) /= 1.0) evapc(i) = 1.0e0
1669 ! enddo
1670 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1671 
1672 ! --- ... Boundary Layer and Free atmospheic turbulence parameterization
1673 
1674 ! if (lprnt) write(0,*)' tsea3=',tsea(ipr),' slmsk=',slmsk(ipr) &
1675 ! &, ' kdt=',kdt,' evap=',evap(ipr)
1676 ! if (lprnt) write(0,*)' dtdtb=',dtdt(ipr,1:10)
1677 
1678 ! do i = 1, im
1679 ! if (islmsk(i) == 0) then
1680 ! oro_land(i) = 0.0
1681 ! else
1682 ! oro_land(i) = oro(i)
1683 ! endif
1684 ! enddo
1685 
1686 ! write(0,*)' before monin clstp=',clstp,' kdt=',kdt,' lat=',lat
1687 
1688  if (do_shoc) then
1689  call moninshoc(ix,im,levs,ntrac,ntcw,dvdt,dudt,dtdt,dqdt, &
1690  & ugrs,vgrs,tgrs,qgrs,phy_f3d(1,1,ntot3d-1), & ! tkh
1691  & prnum,ntke, &
1692  & prsik(1,1),rb,zorl,u10m,v10m,ffmm,ffhh, &
1693  & tsea,hflx,evap,stress,wind,kpbl, &
1694  & prsi,del,prsl,prslk,phii,phil,dtp, &
1695  & dusfc1,dvsfc1,dtsfc1,dqsfc1,dkt,hpbl, &
1696  & kinver, xkzm_m, xkzm_h, xkzm_s, lprnt, ipr,me)
1697  else
1698 
1699  if (hybedmf) then
1700 
1701  call moninedmf(ix,im,levs,nvdiff,ntcw,dvdt,dudt,dtdt,dqdt, &
1702  & ugrs,vgrs,tgrs,qgrs,swh,hlw,xmu, &
1703  & prsik(1,1),rb,zorl,u10m,v10m,ffmm,ffhh, &
1704  & tsea,qss,hflx,evap,stress,wind,kpbl, &
1705  & prsi,del,prsl,prslk,phii,phil,dtp,dspheat, &
1706  & dusfc1,dvsfc1,dtsfc1,dqsfc1,hpbl,gamt,gamq,dkt, &
1707  & kinver, xkzm_m, xkzm_h, xkzm_s, lprnt, ipr)
1708 
1709  elseif (.not. old_monin) then
1710 
1711  call moninq(ix,im,levs,nvdiff,ntcw,dvdt,dudt,dtdt,dqdt, &
1712  & ugrs,vgrs,tgrs,qgrs,swh,hlw,xmu, &
1713  & prsik(1,1),rb,ffmm,ffhh, &
1714  & tsea,qss,hflx,evap,stress,wind,kpbl, &
1715  & prsi,del,prsl,prslk,phii,phil,dtp,dspheat, &
1716  & dusfc1,dvsfc1,dtsfc1,dqsfc1,hpbl,gamt,gamq,dkt, &
1717  & kinver, xkzm_m, xkzm_h, xkzm_s, lprnt, ipr)
1718 
1719  else
1720 
1721  if (mstrat) then
1722  call moninp1(ix,im,levs,nvdiff,dvdt,dudt,dtdt,dqdt, &
1723  & ugrs,vgrs,tgrs,qgrs, &
1724  & prsik(1,1),rb,ffmm,ffhh,tsea,qss,hflx,evap,stress,wind, &
1725  & kpbl,prsi,del,prsl,prslk,phii,phil,dtp, &
1726  & dusfc1,dvsfc1,dtsfc1,dqsfc1,hpbl,gamt,gamq,dkt, &
1727  & kinver, xkzm_m, xkzm_h)
1728 ! & kinver, oro_land, ctei_r, ctei_rm, xkzm_m, xkzm_h)
1729  else
1730  call moninp(ix,im,levs,nvdiff,dvdt,dudt,dtdt,dqdt, &
1731  & ugrs,vgrs,tgrs,qgrs, &
1732  & prsik(1,1),rb,ffmm,ffhh,tsea,qss,hflx,evap,stress,wind, &
1733  & kpbl,prsi,del,prsl,phii,phil,dtp, &
1734  & dusfc1,dvsfc1,dtsfc1,dqsfc1,hpbl,gamt,gamq,dkt, &
1735  & xkzm_m,xkzm_h)
1736  endif
1737 
1738  endif ! end if_hybedmf
1739  endif ! end if_do_shoc
1740 
1741  if (lssav_cpl) then
1742  do i = 1, im
1743  if (flag_cice(i)) then
1744  cice(i) = fice_cice(i)
1745  tsea(i) = tsea_cice(i)
1746  dusfc1(i) = dusfc_cice(i)
1747  dvsfc1(i) = dvsfc_cice(i)
1748  dqsfc1(i) = dqsfc_cice(i)
1749  dtsfc1(i) = dtsfc_cice(i)
1750  endif
1751  enddo
1752  endif
1753 
1754 ! if (lprnt) then
1755 ! write(0,*) ' dusfc1=',dusfc1(ipr),' kdt=',kdt,' lat=',lat
1756 ! write(0,*)' dtsfc1=',dtsfc1(ipr)
1757 ! write(0,*)' dqsfc1=',dqsfc1(ipr)
1758 ! write(0,*)' dtdt=',dtdt(ipr,1:10)
1759 ! print *,' dudtm=',dudt(ipr,:)
1760 ! endif
1761 
1762 ! --- ... coupling insertion
1763 
1764  if (lssav_cpl) then
1765  do i=1, im
1766  dusfc_cpl(i) = dusfc_cpl(i) + dusfc1(i)*dtf
1767  dvsfc_cpl(i) = dvsfc_cpl(i) + dvsfc1(i)*dtf
1768  dtsfc_cpl(i) = dtsfc_cpl(i) + dtsfc1(i)*dtf
1769  dqsfc_cpl(i) = dqsfc_cpl(i) + dqsfc1(i)*dtf
1770  dusfci_cpl(i) = dusfc1(i)
1771  dvsfci_cpl(i) = dvsfc1(i)
1772  dtsfci_cpl(i) = dtsfc1(i)
1773  dqsfci_cpl(i) = dqsfc1(i)
1774  enddo
1775  endif
1776 !-------------------------------------------------------lssav if loop ----------
1777  if (lssav) then
1778  do i = 1, im
1779  dusfc(i) = dusfc(i) + dusfc1(i)*dtf
1780  dvsfc(i) = dvsfc(i) + dvsfc1(i)*dtf
1781  dtsfc(i) = dtsfc(i) + dtsfc1(i)*dtf
1782  dqsfc(i) = dqsfc(i) + dqsfc1(i)*dtf
1783  dusfci(i) = dusfc1(i)
1784  dvsfci(i) = dvsfc1(i)
1785  dtsfci(i) = dtsfc1(i)
1786  dqsfci(i) = dqsfc1(i)
1787  enddo
1788 ! if (lprnt) then
1789 ! write(0,*)' dusfc=',dusfc(ipr),' dusfc1=',dusfc1(ipr),' dtf=',
1790 ! & dtf,' kdt=',kdt,' lat=',lat
1791 ! endif
1792 
1793  if (ldiag3d) then
1794 
1795  if (lsidea) then
1796  do k = 1, levs
1797  do i = 1, im
1798  dt3dt(i,k,3) = dt3dt(i,k,3) + dtdt(i,k)*dtf
1799  enddo
1800  enddo
1801  else
1802  do k = 1, levs
1803  do i = 1, im
1804  tem = dtdt(i,k) - (hlw(i,k)+swh(i,k)*xmu(i))
1805  dt3dt(i,k,3) = dt3dt(i,k,3) + tem*dtf
1806  enddo
1807  enddo
1808  endif
1809  do k = 1, levs
1810  do i = 1, im
1811  du3dt(i,k,1) = du3dt(i,k,1) + dudt(i,k) * dtf
1812  du3dt(i,k,2) = du3dt(i,k,2) - dudt(i,k) * dtf
1813  dv3dt(i,k,1) = dv3dt(i,k,1) + dvdt(i,k) * dtf
1814  dv3dt(i,k,2) = dv3dt(i,k,2) - dvdt(i,k) * dtf
1815  enddo
1816  enddo
1817 ! update dqdt_v to include moisture tendency due to vertical diffusion
1818 ! if (lgocart) then
1819 ! do k = 1, levs
1820 ! do i = 1, im
1821 ! dqdt_v(i,k) = dqdt(i,k,1) * dtf
1822 ! enddo
1823 ! enddo
1824 ! endif
1825  do k = 1, levs
1826  do i = 1, im
1827  tem = dqdt(i,k,1) * dtf
1828  dq3dt(i,k,1) = dq3dt(i,k,1) + tem
1829 ! dqdt_v(i,k) = tem
1830  enddo
1831  enddo
1832  if (ntoz > 0) then
1833  do k = 1, levs
1834  do i = 1, im
1835  dq3dt(i,k,5) = dq3dt(i,k,5) + dqdt(i,k,ntoz) * dtf
1836  enddo
1837  enddo
1838  endif
1839  endif
1840 
1841  endif ! end if_lssav
1842 !-------------------------------------------------------lssav if loop ----------
1843 !
1844 ! Orographic gravity wave drag parameterization
1845 ! ---------------------------------------------
1846 
1847  if (nmtvr == 14) then ! current operational - as of 2014
1848 
1849  do i = 1, im
1850  oc(i) = hprime(i,2)
1851  enddo
1852  do k = 1, 4
1853  do i = 1, im
1854  oa4(i,k) = hprime(i,k+2)
1855  clx(i,k) = hprime(i,k+6)
1856  enddo
1857  enddo
1858  do i = 1, im
1859  theta(i) = hprime(i,11)
1860  gamma(i) = hprime(i,12)
1861  sigma(i) = hprime(i,13)
1862  elvmax(i) = hprime(i,14)
1863  enddo
1864 
1865  elseif (nmtvr == 10) then
1866 
1867  do i = 1, im
1868  oc(i) = hprime(i,2)
1869  enddo
1870  do k = 1, 4
1871  do i = 1, im
1872  oa4(i,k) = hprime(i,k+2)
1873  clx(i,k) = hprime(i,k+6)
1874  enddo
1875  enddo
1876 
1877  elseif (nmtvr == 6) then
1878 
1879  do i = 1, im
1880  oc(i) = hprime(i,2)
1881  enddo
1882  do k = 1, 4
1883  do i = 1, im
1884  oa4(i,k) = hprime(i,k+2)
1885  clx(i,k) = 0.0
1886  enddo
1887  enddo
1888 
1889  else
1890 
1891  oc = 0 ; oa4 = 0 ; clx = 0 ; theta = 0 ; gamma = 0 ; sigma = 0
1892  elvmax = 0
1893 
1894  endif ! end if_nmtvr
1895 
1896 ! write(0,*)' before gwd clstp=',clstp,' kdt=',kdt,' lat=',lat
1897  call gwdps(im, ix, im, levs, dvdt, dudt, dtdt, &
1898  & ugrs, vgrs, tgrs, qgrs, &
1899  & kpbl, prsi, del, prsl, prslk, &
1900  & phii, phil, dtp, &
1901  & kdt, hprime(1,1), oc, oa4, clx, &
1902  & theta,sigma,gamma,elvmax,dusfcg, dvsfcg, &
1903  & con_g,con_cp,con_rd,con_rv, lonr, nmtvr, cdmbgwd, &
1904  & me, lprnt,ipr)
1905 
1906 ! if (lprnt) print *,' dudtg=',dudt(ipr,:)
1907 
1908  if (lssav) then
1909  do i = 1, im
1910  dugwd(i) = dugwd(i) + dusfcg(i)*dtf
1911  dvgwd(i) = dvgwd(i) + dvsfcg(i)*dtf
1912  enddo
1913 
1914 ! if (lprnt) print *,' dugwd=',dugwd(ipr),' dusfcg=',dusfcg(ipr)
1915 ! if (lprnt) print *,' dvgwd=',dvgwd(ipr),' dvsfcg=',dvsfcg(ipr)
1916 
1917  if (ldiag3d) then
1918  do k = 1, levs
1919  do i = 1, im
1920  du3dt(i,k,2) = du3dt(i,k,2) + dudt(i,k) * dtf
1921  dv3dt(i,k,2) = dv3dt(i,k,2) + dvdt(i,k) * dtf
1922  dt3dt(i,k,2) = dt3dt(i,k,2) + dtdt(i,k) * dtf
1923  enddo
1924  enddo
1925  endif
1926  endif
1927 
1928 ! Rayleigh damping near the model top
1929  if( .not. lsidea .and. ral_ts > 0.0) then
1930 ! call rayleigh_damp_mesopause(im, ix, im, levs, dvdt, dudt, dtdt,
1931 ! & ugrs, vgrs, dtp, con_cp, levr, prsl, prslrd0)
1932 ! else
1933  call rayleigh_damp(im, ix, im, levs, dvdt, dudt, dtdt, ugrs,
1934  & vgrs, dtp, con_cp, levr, pgr, prsl,
1935  & prslrd0, ral_ts)
1936  endif
1937 
1938 ! if (lprnt) then
1939 ! write(0,*)' tgrs1=',tgrs(ipr,1:10)
1940 ! write(0,*)' dtdt=',dtdt(ipr,1:10)
1941 ! endif
1942 
1943  do k = 1, levs
1944  do i = 1, im
1945  gt0(i,k) = tgrs(i,k) + dtdt(i,k) * dtp
1946  gu0(i,k) = ugrs(i,k) + dudt(i,k) * dtp
1947  gv0(i,k) = vgrs(i,k) + dvdt(i,k) * dtp
1948  enddo
1949  enddo
1950 
1951  do n = 1, ntrac
1952  do k = 1, levs
1953  do i = 1, im
1954  gq0(i,k,n) = qgrs(i,k,n) + dqdt(i,k,n) * dtp
1955  enddo
1956  enddo
1957  enddo
1958 ! if(lprnt) write(0,*)' gq0i=',gq0(ipr,:,ntiw)
1959 
1960  if( lsidea ) then ! idea convective adjustment
1961  call ideaca_up(prsi,gt0,ix,im,levs+1)
1962  endif
1963 
1964 ! --- ... check print
1965 
1966 ! if (me == 0) then
1967 ! sumq = 0.0
1968 ! do k = 1, levs
1969 ! do i = 1, im
1970 ! sumq = sumq + (dqdt(i,k,1)+dqdt(i,k,ntcw)) * del(i,k)
1971 ! enddo
1972 ! enddo
1973 
1974 ! sume = 0.0
1975 ! do i = 1, im
1976 ! sume = sume + dqsfc1(i)
1977 ! enddo
1978 
1979 ! sumq = sumq * 1000.0 / con_g
1980 ! sume = sume / con_hvap
1981 ! print *,' after mon: sumq=',sumq,' sume=',sume, ' kdt=',kdt
1982 ! endif
1983 
1984 ! --- ... ozone physics
1985 
1986  if (ntoz > 0 .and. ntrac >= ntoz) then
1987 
1988  if (pl_coeff > 4) then
1989 
1990  call ozphys_2015(ix,im,levs,ko3,dtp,gq0(1,1,ntoz),gq0(1,1,ntoz)&
1991  &, gt0, poz, prsl, prdoz, pl_coeff, del, ldiag3d &
1992  &, dq3dt(1,1,6), me)
1993  else
1994 
1995  call ozphys(ix,im,levs,ko3,dtp,gq0(1,1,ntoz),gq0(1,1,ntoz) &
1996  &, gt0, poz, prsl, prdoz, pl_coeff, del, ldiag3d &
1997  &, dq3dt(1,1,6), me)
1998 
1999  endif
2000  endif
2001 
2002 
2003  if (h2o_phys) then
2004 
2005  call h2ophys(ix,im,levs,levh2o,dtp,gq0(1,1,1),gq0(1,1,1)
2006  &, h2o_pres,prsl,h2opl,h2o_coeff,ldiag3d
2007  &, dq3dt(1,1,1), me)
2008  endif
2009 
2010 ! --- ... to side-step the ozone physics
2011 
2012 ! if (ntrac >= 2) then
2013 ! do k = 1, levs
2014 ! gq0(k,ntoz) = qgrs(k,ntoz)
2015 ! enddo
2016 ! endif
2017 
2018 ! if (lprnt) then
2019 ! write(0,*) ' levs=',levs,' jcap=',jcap,' dtp',dtp &
2020 ! &, ' slmsk=',slmsk(ilon,ilat),' kdt=',kdt
2021 ! print *,' rann=',rann,' ncld=',ncld,' iq=',iq,' lat=',lat
2022 ! print *,' pgr=',pgr
2023 ! print *,' del=',del(ipr,:)
2024 ! print *,' prsl=',prsl(ipr,:)
2025 ! print *,' prslk=',prslk(ipr,:)
2026 ! print *,' rann=',rann(ipr,1)
2027 ! write(0,*)' gt0=',gt0(ipr,:) &
2028 ! &, ' kdt=',kdt,' xlon=',xlon(ipr),' xlat=',xlat(ipr)
2029 ! print *,' dtdt=',dtdt(ipr,:)
2030 ! print *,' gu0=',gu0(ipr,:)
2031 ! print *,' gv0=',gv0(ipr,:)
2032 ! write(0,*)' gq0=',(gq0(ipr,k,1),k=1,levs),' lat=',lat
2033 ! write(0,*)' gq0i2=',(gq0(ipr,k,ntiw),k=1,levs),' lat=',lat
2034 ! print *,' gq1=',(gq0(ipr,k,ntcw),k=1,levs)
2035 ! print *,' vvel=',vvel
2036 ! endif
2037 
2038  if (ldiag3d) then
2039 
2040  do k = 1, levs
2041  do i = 1, im
2042  dtdt(i,k) = gt0(i,k)
2043 ! dqdt(i,k,1) = gq0(i,k,1)
2044  dudt(i,k) = gu0(i,k)
2045  dvdt(i,k) = gv0(i,k)
2046  enddo
2047  enddo
2048 
2049  elseif (cnvgwd) then
2050 
2051  do k = 1, levs
2052  do i = 1, im
2053  dtdt(i,k) = gt0(i,k)
2054  enddo
2055  enddo
2056 
2057  endif ! end if_ldiag3d/cnvgwd
2058 
2059  if (ldiag3d .or. lgocart) then
2060  do k = 1, levs
2061  do i = 1, im
2062  dqdt(i,k,1) = gq0(i,k,1)
2063  enddo
2064  enddo
2065  endif ! end if_ldiag3d/lgocart
2066 
2067  call get_phi(im,ix,levs,ntrac,gt0,gq0, &
2068  & thermodyn_id, sfcpress_id, &
2069  & gen_coord_hybrid, &
2070  & prsi,prsik,prsl,prslk,phii,phil)
2071 
2072 ! if (lprnt) then
2073 ! print *,' phii2=',phii(ipr,:)
2074 ! print *,' phil2=',phil(ipr,:)
2075 ! endif
2076 
2077  do k = 1, levs
2078  do i = 1, im
2079  clw(i,k,1) = 0.0
2080  clw(i,k,2) = -999.9
2081  enddo
2082  enddo
2083  if (.not. ras .or. .not. cscnv) then
2084  do k = 1, levs
2085  do i = 1, im
2086  cnvc(i,k) = 0.0
2087  cnvw(i,k) = 0.0
2088  enddo
2089  enddo
2090  endif
2091 
2092 ! write(0,*)' before cnv clstp=',clstp,' kdt=',kdt,' lat=',lat
2093 
2094 ! --- ... for convective tracer transport (while using ras)
2095 
2096  if (ras .or. cscnv) then
2097  if (tottracer > 0) then
2098 
2099  if (ntoz > 0) then
2100  do k=1,levs
2101  do i=1,im
2102  clw(i,k,3) = gq0(i,k,ntoz)
2103  enddo
2104  enddo
2105 
2106  if (tracers > 0) then
2107  do n = 1, tracers
2108  do k=1,levs
2109  do i=1,im
2110  clw(i,k,3+n) = gq0(i,k,n+trc_shft)
2111  enddo
2112  enddo
2113  enddo
2114  endif
2115  else
2116  do n = 1, tracers
2117  do k=1,levs
2118  do i=1,im
2119  clw(i,k,2+n) = gq0(i,k,n+trc_shft)
2120  enddo
2121  enddo
2122  enddo
2123  endif
2124 
2125  endif
2126  endif ! end if_ras or cfscnv
2127 
2128  do i = 1, im
2129  ktop(i) = 1
2130  kbot(i) = levs
2131  enddo
2132 
2133 ! --- ... calling condensation/precipitation processes
2134 ! --------------------------------------------
2135 
2136  if (ntcw > 0) then
2137 
2138  do k = 1, levs
2139  do i = 1, im
2140  tem = rhbbot - (rhbbot-rhbtop) * (1.0-prslk(i,k))
2141  tem = rhc_max * work1(i) + tem * work2(i)
2142  rhc(i,k) = max(0.0, min(1.0,tem))
2143  enddo
2144  enddo
2145 
2146  if (ncld == 2) then
2147  do k = 1, levs
2148  do i = 1, im
2149  clw(i,k,1) = gq0(i,k,ntiw) ! ice
2150  clw(i,k,2) = gq0(i,k,ntcw) ! water
2151  enddo
2152  enddo
2153  else
2154 
2155  if (num_p3d == 3) then ! brad ferrier's microphysics
2156 
2157 ! --- ... algorithm to separate different hydrometeor species
2158 
2159  do k = 1, levs
2160  do i = 1, im
2161  wc = gq0(i,k,ntcw)
2162  qi = 0.
2163  qr = 0.
2164  qw = 0.
2165  f_ice = max(0.0, min(1.0, phy_f3d(i,k,1)))
2166  f_rain = max(0.0, min(1.0, phy_f3d(i,k,2)))
2167 
2168  qi = f_ice*wc
2169  qw = wc-qi
2170  if (qw > 0.0) then
2171  qr = f_rain*qw
2172  qw = qw-qr
2173  endif
2174 
2175 ! if (f_ice >= 1.0) then
2176 ! qi = wc
2177 ! elseif (f_ice <= 0.0) then
2178 ! qw = wc
2179 ! else
2180 ! qi = f_ice*wc
2181 ! qw = wc-qi
2182 ! endif
2183 
2184 ! if (qw > 0.0 .and. f_rain > 0.0) then
2185 ! if (f_rain >= 1.0) then
2186 ! qr = qw
2187 ! qw = 0.0
2188 ! else
2189 ! qr = f_rain*qw
2190 ! qw = qw-qr
2191 ! endif
2192 ! endif
2193 
2194  qr_col(i,k) = qr
2195 ! clw(i,k) = qi + qw
2196  clw(i,k,1) = qi
2197  clw(i,k,2) = qw
2198 
2199 ! --- ... array to track fraction of "cloud" in the form of ice
2200 
2201 ! if (qi+qw > epsq) then
2202 ! fc_ice(i,k) = qi / (qi+qw)
2203 ! else
2204 ! fc_ice(i,k) = 0.0
2205 ! endif
2206  enddo
2207  enddo
2208 
2209  elseif (num_p3d == 4) then ! zhao-carr microphysics
2210 
2211  do i = 1, im
2212  psautco_l(i) = psautco(1)*work1(i) + psautco(2)*work2(i)
2213  prautco_l(i) = prautco(1)*work1(i) + prautco(2)*work2(i)
2214  enddo
2215  do k = 1, levs
2216  do i = 1, im
2217  clw(i,k,1) = gq0(i,k,ntcw)
2218  enddo
2219  enddo
2220 
2221  endif ! end if_num_p3d
2222  endif ! end if (ncld == 2)
2223 
2224  else ! if_ntcw
2225 
2226  do i = 1, im
2227  psautco_l(i) = psautco(1)*work1(i) + psautco(2)*work2(i)
2228  prautco_l(i) = prautco(1)*work1(i) + prautco(2)*work2(i)
2229  enddo
2230  do k = 1, levs
2231  do i = 1, im
2232  rhc(i,k) = 1.0
2233  enddo
2234  enddo
2235 
2236  endif ! end if_ntcw
2237 !
2238 ! Call SHOC if do_shoc is true and shocaftcnv is false
2239 !
2240  if (do_shoc .and. .not. shocaftcnv) then
2241 
2242  if (ncld == 2) then
2243  skip_macro = do_shoc
2244  do k = 1, levs
2245  do i = 1, im
2246  clw(i,k,1) = gq0(i,k,ntiw) ! ice
2247  clw(i,k,2) = gq0(i,k,ntcw) ! water
2248  ncpl(i,k) = gq0(i,k,ntlnc)
2249  ncpi(i,k) = gq0(i,k,ntinc)
2250  enddo
2251  enddo
2252  elseif (num_p3d == 4) then
2253  do k=1,levs
2254  do i=1,im
2255  qpl(i,k) = 0.0
2256  qpi(i,k) = 0.0
2257  tem = gq0(i,k,ntcw) &
2258  & * max(0.0, min(1.0, (tcr-gt0(i,k))*tcrf))
2259  clw(i,k,1) = tem ! ice
2260  clw(i,k,2) = gq0(i,k,ntcw) - tem ! water
2261  enddo
2262  enddo
2263  endif
2264 
2265 ! dtshoc = 60.0
2266 ! dtshoc = 120.0
2267 ! dtshoc = dtp
2268 ! nshocm = (dtp/dtshoc) + 0.001
2269 ! dtshoc = dtp / nshocm
2270 ! do nshoc=1,nshocm
2271 ! if (lprnt) write(1000+me,*)' before shoc tke=',clw(ipr,:,ntk),
2272 ! &' kdt=',kdt,' lat=',lat,'xlon=',xlon(ipr),' xlat=',xlat(ipr)
2273 
2274 ! phy_f3d(1,1,ntot3d-2) - shoc determined sgs clouds
2275 ! phy_f3d(1,1,ntot3d-1) - shoc determined diffusion coefficients
2276 ! phy_f3d(1,1,ntot3d ) - shoc determined w'theta'
2277 !
2278 ! call shoc(ix, im, 1, levs, levs+1, dtshoc, me, lat, &
2279  call shoc(ix, im, 1, levs, levs+1, dtp, me, lat, &
2280  & prsl(1,1), phii(1,1), phil(1,1), &
2281  & gu0(1,1),gv0(1,1), vvel(1,1), gt0(1,1), gq0(1,1,1), &
2282  & clw(1,1,1), clw(1,1,2), qpi, qpl,rhc, sup, &
2283  & phy_f3d(1,1,ntot3d-2), clw(1,1,ntk), hflx, evap, &
2284  & prnum, phy_f3d(1,1,ntot3d-1), phy_f3d(1,1,ntot3d), &
2285  & lprnt, ipr, ncpl, ncpi)
2286 
2287  if (ntlnc > 0 .and. ntinc > 0 .and. ncld >=2) then
2288  do k=1,levs
2289  do i=1,im
2290  gq0(i,k,ntlnc) = ncpl(i,k)
2291  gq0(i,k,ntinc) = ncpi(i,k)
2292  enddo
2293  enddo
2294  endif
2295 ! do k=1,levs
2296 ! do i=1,im
2297 ! sgs_cld(i,k) = sgs_cld(i,k) + shoc_cld(i,k)
2298 ! enddo
2299 ! enddo
2300 ! if (lprnt) write(0,*)' gt03=',gt0(ipr,1:10)
2301 ! if (lprnt) write(0,*)' tke=',clw(ipr,1:10,ntk)
2302 
2303 ! if (lprnt) write(1000+me,*)' after shoc tke=',clw(1,:,ntk),
2304 ! &' kdt=',kdt
2305 ! enddo
2306 !
2307 ! do k=1,levs
2308 ! write(1000+me,*)' maxcld=',maxval(sgs_cld(1:im,k)),
2309 ! write(1000+me,*)' maxtkh=',maxval(phy_f3d(1:im,k,ntot3d-1)),
2310 ! &' k=',k,' kdt=',kdt,' lat=',lat
2311 ! enddo
2312 
2313 ! write(0,*)' aft shoc gt0=',gt0(1,:),' lat=',lat
2314 ! write(0,*)' aft shoc gq0=',gq0(1,:,1),' lat=',lat
2315 ! write(0,*)' aft shoc gu0=',gu0(1,:),' lat=',lat
2316 !
2317  endif ! if(do_shoc)
2318 
2319 
2320 ! --- ... calling convective parameterization
2321 !
2322  if (.not. ras .and. .not. cscnv) then
2323 
2324  if (imfdeepcnv == 1) then ! no random cloud top
2325  call sascnvn(im,ix,levs,jcap,dtp,del,prsl,pgr,phil, &
2326  & clw,gq0,gt0,gu0,gv0,cld1d, &
2327  & rain1,kbot,ktop,kcnv,islmsk, &
2328  & vvel,ncld,ud_mf,dd_mf,dt_mf,cnvw,cnvc)
2329  elseif (imfdeepcnv == 2) then
2330  call mfdeepcnv(im,ix,levs,dtp,del,prsl,pgr,phil, &
2331  & clw,gq0,gt0,gu0,gv0,cld1d, &
2332  & rain1,kbot,ktop,kcnv,islmsk,garea, &
2333  & vvel,ncld,ud_mf,dd_mf,dt_mf,cnvw,cnvc)
2334 ! if (lprnt) print *,' rain1=',rain1(ipr)
2335  elseif (imfdeepcnv == 0) then ! random cloud top
2336  call sascnv(im,ix,levs,jcap,dtp,del,prsl,pgr,phil, &
2337  & clw,gq0,gt0,gu0,gv0,cld1d, &
2338  & rain1,kbot,ktop,kcnv,islmsk, &
2339  & vvel,rann,ncld,ud_mf,dd_mf,dt_mf,cnvw,cnvc)
2340 ! if (lprnt) print *,' rain1=',rain1(ipr),' rann=',rann(ipr,1)
2341  endif
2342 
2343  else ! ras or cscnv
2344 
2345  if(cscnv) then ! Chikira-Sugiyama convection scheme (via CSU)
2346 
2347 ! fscav(:) = 0.0
2348 ! fswtr(:) = 0.0
2349  call cs_convr( & !DD
2350  & ix ,im ,levs , tottracer+3 , & !DD
2351  & gt0 ,gq0 ,rain1 , clw , & !DD
2352  & phil ,phii , & !DD
2353  & prsl ,prsi , & !DD
2354  & dtp ,dtf , & !DD
2355  & ud_mf ,dd_mf ,dt_mf , & !DD
2356  & gu0 ,gv0 ,fscav, fswtr, & !DD
2357 ! & phy_fctd, me ) !DD & moorthi
2358  & phy_fctd, me, wcbmax ) !DD & moorthi
2359 ! & phy_fctd ) !DD
2360  do i = 1,im !DD
2361  rain1(i) = rain1(i) * (dtp*0.001) !DD
2362  enddo
2363 
2364  else ! ras version 2
2365 
2366  if (ccwf(1) >= 0.0 .or. ccwf(2) >= 0 ) then
2367  do i=1,im
2368  ccwfac(i) = ccwf(1)*work1(i) + ccwf(2)*work2(i)
2369  dlqfac(i) = dlqf(1)*work1(i) + dlqf(2)*work2(i)
2370  lmh(i) = levs
2371  enddo
2372  else
2373  do i=1,im
2374  ccwfac(i) = -999.0
2375  dlqfac(i) = 0.0
2376  lmh(i) = levs
2377  enddo
2378  endif
2379 ! if (lprnt) write(0,*) ' calling ras for kdt=',kdt,' me=',me &
2380 ! &, ' lprnt=',lprnt,' ccwfac=',ccwfac(ipr)
2381 
2382  revap = .true.
2383 ! if (ncld ==2) revap = .false.
2384  call rascnv(im, ix, levs, dtp, dtf, rann &
2385  &, gt0, gq0, gu0, gv0, clw, tottracer, fscav &
2386  &, prsi, prsl, prsik, prslk, phil, phii &
2387  &, kpbl, cd, rain1, kbot, ktop, kcnv &
2388  &, phy_f2d(1,num_p2d), flipv, pa2mb &
2389  &, me, garea, lmh, ccwfac, nrcm, rhc &
2390  &, ud_mf, dd_mf, dt_mf, dlqfac, lprnt, ipr, kdt,revap&
2391  &, qlcn, qicn, w_upi,cf_upi, cnv_mfd, cnv_prc3 &
2392  &, cnv_dqldt,clcn,cnv_fice,cnv_ndrop,cnv_nice,ncld )
2393  endif
2394 
2395 ! if(lprnt) write(0,*)' after ras rain1=',rain1(ipr)
2396 ! &,' cnv_prc3sum=',sum(cnv_prc3(ipr,1:levs))
2397 ! if (lprnt) write(0,*)' gt04=',gt0(ipr,1:10)
2398 
2399  cld1d = 0
2400 
2401  if (lgocart) then
2402  do k = 1, levs
2403  do i = 1, im
2404  upd_mf(i,k) = upd_mf(i,k) + ud_mf(i,k) * frain
2405  dwn_mf(i,k) = dwn_mf(i,k) + dd_mf(i,k) * frain
2406  det_mf(i,k) = det_mf(i,k) + dt_mf(i,k) * frain
2407  cnvqc_v(i,k) = cnvqc_v(i,k) + (clw(i,k,1)+clw(i,k,2)- &
2408  & gq0(i,k,ntcw)) * frain
2409  enddo
2410  enddo
2411  endif ! if (lgocart)
2412 
2413 ! --- ... update the tracers due to convective transport
2414 
2415  if (tottracer > 0) then
2416  if (ntoz > 0) then ! for ozone
2417  do k=1,levs
2418  do i=1,im
2419  gq0(i,k,ntoz) = clw(i,k,3)
2420  enddo
2421  enddo
2422 
2423  if (tracers > 0) then ! for other tracers
2424  do n = 1, tracers
2425  do k=1,levs
2426  do i=1,im
2427  gq0(i,k,n+trc_shft) = clw(i,k,3+n)
2428  enddo
2429  enddo
2430  enddo
2431  endif
2432  else
2433  do n = 1, tracers
2434  do k=1,levs
2435  do i=1,im
2436  gq0(i,k,n+trc_shft) = clw(i,k,2+n)
2437  enddo
2438  enddo
2439  enddo
2440  endif
2441  endif
2442  endif ! end if_not_ras
2443 !
2444  do i = 1, im
2445  rainc(i) = frain * rain1(i)
2446  enddo
2447 
2448 !
2449  if (lssav) then
2450  do i = 1, im
2451  cldwrk(i) = cldwrk(i) + cld1d(i) * dtf
2452  cnvprcp(i) = cnvprcp(i) + rainc(i)
2453  enddo
2454 
2455  if (ldiag3d) then
2456  do k = 1, levs
2457  do i = 1, im
2458  dt3dt(i,k,4) = dt3dt(i,k,4) + (gt0(i,k)-dtdt(i,k)) * frain
2459  dq3dt(i,k,2) = dq3dt(i,k,2) + (gq0(i,k,1)-dqdt(i,k,1)) &
2460  & * frain
2461  du3dt(i,k,3) = du3dt(i,k,3) + (gu0(i,k)-dudt(i,k)) * frain
2462  dv3dt(i,k,3) = dv3dt(i,k,3) + (gv0(i,k)-dvdt(i,k)) * frain
2463 
2464  upd_mf(i,k) = upd_mf(i,k) + ud_mf(i,k) * (con_g*frain)
2465  dwn_mf(i,k) = dwn_mf(i,k) + dd_mf(i,k) * (con_g*frain)
2466  det_mf(i,k) = det_mf(i,k) + dt_mf(i,k) * (con_g*frain)
2467 
2468  enddo
2469  enddo
2470  endif ! if (ldiag3d)
2471 
2472  endif ! end if_lssav
2473 !
2474 ! update dqdt_v to include moisture tendency due to deep convection
2475  if (lgocart) then
2476  do k = 1, levs
2477  do i = 1, im
2478  dqdt_v(i,k) = (gq0(i,k,1)-dqdt(i,k,1)) * frain
2479  upd_mf(i,k) = upd_mf(i,k) + ud_mf(i,k) * frain
2480  dwn_mf(i,k) = dwn_mf(i,k) + dd_mf(i,k) * frain
2481  det_mf(i,k) = det_mf(i,k) + dt_mf(i,k) * frain
2482  cnvqc_v(i,k) = cnvqc_v(i,k) + (clw(i,k,1)+clw(i,k,2))
2483  & *frain
2484  enddo
2485  enddo
2486  endif ! if (lgocart)
2487 !
2488  if(npdf3d == 3 .and. num_p3d == 4) then
2489  num2 = num_p3d + 2
2490  num3 = num2 + 1
2491  do k = 1, levs
2492  do i = 1, im
2493  phy_f3d(i,k,num2) = cnvw(i,k)
2494  phy_f3d(i,k,num3) = cnvc(i,k)
2495  enddo
2496  enddo
2497  else if(npdf3d == 0 .and. ncnvcld3d == 1) then
2498  num2 = num_p3d + 1
2499  do k = 1, levs
2500  do i = 1, im
2501  phy_f3d(i,k,num2) = cnvw(i,k)
2502  enddo
2503  enddo
2504  endif
2505 
2506 !
2507 !----------------Convective gravity wave drag parameterization starting --------
2508 
2509  if (cnvgwd) then ! call convective gravity wave drag
2510 
2511 ! --- ... calculate maximum convective heating rate qmax [k/s]
2512 ! cuhr = temperature change due to deep convection
2513 
2514  do i = 1, im
2515 ! qmax(i) = 0.
2516  cumabs(i) = 0.0
2517  work3(i) = 0.0
2518  enddo
2519 
2520  do k = 1, levs
2521  do i = 1, im
2522 ! cuhr(i,k) = (gt0(i,k)-dtdt(i,k)) / dtf
2523 ! cuhr(i,k) = (gt0(i,k)-dtdt(i,k)) / dtp ! moorthi
2524 
2525 ! cumchr(i,k) = 0.
2526 ! gwdcu(i,k) = 0.
2527 ! gwdcv(i,k) = 0.
2528 ! diagn1(i,k) = 0.
2529 ! diagn2(i,k) = 0.
2530 
2531  if (k >= kbot(i) .and. k <= ktop(i)) then
2532 ! qmax(i) = max(qmax(i),cuhr(i,k))
2533 ! cumabs(i) = cuhr(i,k) + cumabs(i)
2534  cumabs(i) = cumabs(i) + (gt0(i,k)-dtdt(i,k)) * del(i,k)
2535  work3(i) = work3(i) + del(i,k)
2536  endif
2537  enddo
2538  enddo
2539  do i=1,im
2540  if (work3(i) > 0.0) cumabs(i) = cumabs(i) / (dtp*work3(i))
2541  enddo
2542 
2543 ! do i = 1, im
2544 ! do k = kbot(i), ktop(i)
2545 ! do k1 = kbot(i), k
2546 ! cumchr(i,k) = cuhr(i,k1) + cumchr(i,k)
2547 ! enddo
2548 ! cumchr(i,k) = cumchr(i,k) / cumabs(i)
2549 ! enddo
2550 ! enddo
2551 
2552 ! --- ... begin check print ******************************************
2553 
2554 ! if (lprnt) then
2555 ! if (kbot(ipr) <= ktop(ipr)) then
2556 ! write(*,*) 'kbot <= ktop for (lat,lon) = ', &
2557 ! & xlon(ipr)*57.29578,xlat(ipr)*57.29578
2558 ! write(*,*) 'kcnv kbot ktop qmax dlength ',kcnv(ipr), &
2559 ! & kbot(ipr),ktop(ipr),(86400.*qmax(ipr)),dlength(ipr)
2560 ! write(*,9000) kdt
2561 !9000 format(/,3x,'k',5x,'cuhr(k)',4x,'cumchr(k)',5x, &
2562 ! & 'at kdt = ',i4,/)
2563 
2564 ! do k = ktop(ipr), kbot(ipr),-1
2565 ! write(*,9010) k,(86400.*cuhr(ipr,k)),(100.*cumchr(ipr,k))
2566 !9010 format(2x,i2,2x,f8.2,5x,f6.0)
2567 ! enddo
2568 ! endif
2569 
2570 ! if (fhour >= fhourpr) then
2571 ! print *,' before gwdc in gbphys start print'
2572 ! write(*,*) 'fhour ix im levs = ',fhour,ix,im,levs
2573 ! print *,'dtp dtf = ',dtp,dtf
2574 
2575 ! write(*,9100)
2576 !9100 format(//,14x,'pressure levels',// &
2577 ! & ' ilev',7x,'prsi',8x,'prsl',8x,'delp',/)
2578 
2579 ! k = levs + 1
2580 ! write(*,9110) k,(10.*prsi(ipr,k))
2581 !9110 format(i4,2x,f10.3)
2582 
2583 ! do k = levs, 1, -1
2584 ! write(*,9120) k,(10.*prsl(ipr,k)),(10.*del(ipr,k))
2585 ! write(*,9110) k,(10.*prsi(ipr,k))
2586 ! enddo
2587 !9120 format(i4,12x,2(2x,f10.3))
2588 
2589 ! write(*,9130)
2590 !9130 format(//,10x,'before gwdc in gbphys',//,' ilev',6x, &
2591 ! & 'ugrs',9x,'gu0',8x,'vgrs',9x,'gv0',8x, &
2592 ! & 'tgrs',9x,'gt0',8x,'gt0b',8x,'dudt',8x,'dvdt',/)
2593 
2594 ! do k = levs, 1, -1
2595 ! write(*,9140) k,ugrs(ipr,k),gu0(ipr,k), &
2596 ! & vgrs(ipr,k),gv0(ipr,k), &
2597 ! & tgrs(ipr,k),gt0(ipr,k),dtdt(ipr,k), &
2598 ! & dudt(ipr,k),dvdt(ipr,k)
2599 ! enddo
2600 !9140 format(i4,9(2x,f10.3))
2601 
2602 ! print *,' before gwdc in gbphys end print'
2603 ! endif
2604 ! endif ! end if_lprnt
2605 
2606 ! --- ... end check print ********************************************
2607 
2608  call gwdc(im, ix, im, levs, lat, ugrs, vgrs, tgrs, qgrs, &
2609  & prsl, prsi, del, cumabs, ktop, kbot, kcnv,cldf, &
2610  & con_g, con_cp, con_rd, con_fvirt, dlength, &
2611  & lprnt, ipr, fhour, gwdcu, gwdcv, dusfcg, dvsfcg)
2612 
2613 
2614 ! if (lprnt) then
2615 ! if (fhour >= fhourpr) then
2616 ! print *,' after gwdc in gbphys start print'
2617 
2618 ! write(*,9131)
2619 !9131 format(//,10x,'after gwdc in gbphys',//,' ilev',6x, &
2620 ! & 'ugrs',9x,'gu0',8x,'vgrs',9x,'gv0',8x, &
2621 ! & 'tgrs',9x,'gt0',8x,'gt0b',7x,'gwdcu',7x,'gwdcv',/)
2622 
2623 ! do k = levs, 1, -1
2624 ! write(*,9141) k,ugrs(ipr,k),gu0(ipr,k), &
2625 ! & vgrs(ipr,k),gv0(ipr,k), &
2626 ! & tgrs(ipr,k),gt0(ipr,k),dtdt(ipr,k), &
2627 ! & gwdcu(ipr,k),gwdcv(ipr,k)
2628 ! enddo
2629 !9141 format(i4,9(2x,f10.3))
2630 
2631 ! print *,' after gwdc in gbphys end print'
2632 ! endif
2633 ! endif
2634 
2635 ! --- ... write out cloud top stress and wind tendencies
2636 
2637  if (lssav) then
2638  do i = 1, im
2639  dugwd(i) = dugwd(i) + dusfcg(i)*dtf
2640  dvgwd(i) = dvgwd(i) + dvsfcg(i)*dtf
2641  enddo
2642 
2643  if (ldiag3d) then
2644  do k = 1, levs
2645  do i = 1, im
2646  du3dt(i,k,4) = du3dt(i,k,4) + gwdcu(i,k) * dtf
2647  dv3dt(i,k,4) = dv3dt(i,k,4) + gwdcv(i,k) * dtf
2648 ! du3dt(i,k,2) = du3dt(i,k,2) + diagn1(i,k) * dtf
2649 ! dv3dt(i,k,2) = dv3dt(i,k,2) + diagn2(i,k) * dtf
2650  enddo
2651  enddo
2652  endif
2653  endif ! end if_lssav
2654 
2655 ! --- ... update the wind components with gwdc tendencies
2656 
2657  do k = 1, levs
2658  do i = 1, im
2659  eng0 = 0.5*(gu0(i,k)*gu0(i,k)+gv0(i,k)*gv0(i,k))
2660  gu0(i,k) = gu0(i,k) + gwdcu(i,k) * dtp
2661  gv0(i,k) = gv0(i,k) + gwdcv(i,k) * dtp
2662  eng1 = 0.5*(gu0(i,k)*gu0(i,k)+gv0(i,k)*gv0(i,k))
2663  gt0(i,k) = gt0(i,k) + (eng0-eng1)/(dtp*con_cp)
2664  enddo
2665  enddo
2666 
2667 ! if (lprnt) then
2668 ! if (fhour >= fhourpr) then
2669 ! print *,' after tendency gwdc in gbphys start print'
2670 
2671 ! write(*,9132)
2672 !9132 format(//,10x,'after tendency gwdc in gbphys',//,' ilev',6x,&
2673 ! & 'ugrs',9x,'gu0',8x,'vgrs',9x,'gv0',8x, &
2674 ! & 'tgrs',9x,'gt0',8x,'gt0b',7x,'gwdcu',7x,'gwdcv',/)
2675 
2676 ! do k = levs, 1, -1
2677 ! write(*,9142) k,ugrs(ipr,k),gu0(ipr,k),vgrs(ipr,k), &
2678 ! & gv0(ipr,k),tgrs(ipr,k),gt0(ipr,k),dtdt(ipr,k), &
2679 ! & gwdcu(ipr,k),gwdcv(ipr,k)
2680 ! enddo
2681 !9142 format(i4,9(2x,f10.3))
2682 
2683 ! print *,' after tendency gwdc in gbphys end print'
2684 ! endif
2685 ! endif
2686 
2687  endif ! end if_cnvgwd (convective gravity wave drag)
2688 
2689 !----------------Convective gravity wave drag parameterization over --------
2690 
2691  if (ldiag3d) then
2692  do k = 1, levs
2693  do i = 1, im
2694  dtdt(i,k) = gt0(i,k)
2695 ! dqdt(i,k,1) = gq0(i,k,1)
2696  enddo
2697  enddo
2698  endif
2699  if (ldiag3d .or. lgocart) then
2700  do k = 1, levs
2701  do i = 1, im
2702  dqdt(i,k,1) = gq0(i,k,1)
2703  enddo
2704  enddo
2705  endif
2706 
2707 ! write(0,*)' before do_shoc shal clstp=',clstp,' kdt=',kdt,
2708 ! & ' lat=',lat
2709 
2710  if (.not. do_shoc) then
2711 
2712  if (shal_cnv) then ! Shallow convection parameterizations
2713 ! --------------------------------------
2714  if (imfshalcnv == 1) then ! opr option now at 2014
2715  !-----------------------
2716  call shalcnv(im,ix,levs,jcap,dtp,del,prsl,pgr,phil, &
2717  & clw,gq0,gt0,gu0,gv0, &
2718  & rain1,kbot,ktop,kcnv,islmsk, &
2719  & vvel,ncld,hpbl,hflx,evap,ud_mf,dt_mf, &
2720  & cnvw,cnvc)
2721 
2722  if (shcnvcw .and. num_p3d == 4 .and. npdf3d == 3 ) then
2723  do k = 1, levs
2724  do i = 1, im
2725  phy_f3d(i,k,num2) = cnvw(i,k)
2726  phy_f3d(i,k,num3) = cnvc(i,k)
2727 !??? phy_f3d(i,k,num2) = phy_f3d(i,k,num2) + cnvw(i,k)
2728 !??? phy_f3d(i,k,num3) = phy_f3d(i,k,num3) + cnvc(i,k)
2729  enddo
2730  enddo
2731  else if(npdf3d == 0 .and. ncnvcld3d == 1) then
2732  num2 = num_p3d + 1
2733  do k = 1, levs
2734  do i = 1, im
2735  phy_f3d(i,k,num2) = cnvw(i,k)
2736  enddo
2737  enddo
2738  endif
2739  do i = 1, im
2740  raincs(i) = frain * rain1(i)
2741  rainc(i) = rainc(i) + raincs(i)
2742  enddo
2743  if (lssav) then
2744  do i = 1, im
2745  cnvprcp(i) = cnvprcp(i) + raincs(i)
2746  enddo
2747  endif
2748 
2749  elseif (imfshalcnv == 2) then
2750  call mfshalcnv(im,ix,levs,dtp,del,prsl,pgr,phil, &
2751  & clw,gq0,gt0,gu0,gv0, &
2752  & rain1,kbot,ktop,kcnv,islmsk,garea, &
2753  & vvel,ncld,hpbl,ud_mf,dt_mf,cnvw,cnvc)
2754 
2755  if (shcnvcw .and. num_p3d == 4 .and. npdf3d == 3 ) then
2756  do k = 1, levs
2757  do i = 1, im
2758  phy_f3d(i,k,num2) = cnvw(i,k)
2759  phy_f3d(i,k,num3) = cnvc(i,k)
2760 !??? phy_f3d(i,k,num2) = phy_f3d(i,k,num2) + cnvw(i,k)
2761 !??? phy_f3d(i,k,num3) = phy_f3d(i,k,num3) + cnvc(i,k)
2762  enddo
2763  enddo
2764  else if(npdf3d == 0 .and. ncnvcld3d == 1) then
2765  num2 = num_p3d + 1
2766  do k = 1, levs
2767  do i = 1, im
2768  phy_f3d(i,k,num2) = cnvw(i,k)
2769  enddo
2770  enddo
2771  endif
2772  do i = 1, im
2773  raincs(i) = frain * rain1(i)
2774  rainc(i) = rainc(i) + raincs(i)
2775  enddo
2776  if (lssav) then
2777  do i = 1, im
2778  cnvprcp(i) = cnvprcp(i) + raincs(i)
2779  enddo
2780  endif
2781 
2782  elseif (imfshalcnv == 0) then ! modified Tiedtke Shallow convecton
2783  !-----------------------------------
2784  do i = 1, im
2785  levshc(i) = 0
2786  enddo
2787  do k = 2, levs
2788  do i = 1, im
2789  if (prsi(i,1)-prsi(i,k) <= dpshc(i)) levshc(i) = k
2790  enddo
2791  enddo
2792  levshcm = 1
2793  do i = 1, im
2794  levshcm = max(levshcm, levshc(i))
2795  enddo
2796 
2797 ! if (lprnt) print *,' levshcm=',levshcm,' gt0sh=',gt0(ipr,:)
2798 ! &, ' lat=',lat
2799 
2800  if (mstrat) then ! As in CFSv2
2801  call shalcv(im,ix,levshcm,dtp,del,prsi,prsl,prslk,kcnv, &
2802  & gq0,gt0,levshc,phil,kinver,ctei_r,ctei_rml &
2803  &, lprnt,ipr)
2804  else
2805  call shalcvt3(im,ix,levshcm,dtp,del,prsi,prsl,prslk, &
2806  & kcnv,gq0,gt0)
2807  endif
2808 ! if (lprnt) print *,' levshcm=',levshcm,' gt0sha=',gt0(ipr,:)
2809 
2810  endif ! end if_imfshalcnv
2811  endif ! end if_shal_cnv
2812 
2813  if (lssav) then
2814 ! update dqdt_v to include moisture tendency due to shallow convection
2815  if (lgocart) then
2816  do k = 1, levs
2817  do i = 1, im
2818  tem = (gq0(i,k,1)-dqdt(i,k,1)) * frain
2819  dqdt_v(i,k) = dqdt_v(i,k) + tem
2820  enddo
2821  enddo
2822  endif
2823  if (ldiag3d) then
2824  do k = 1, levs
2825  do i = 1, im
2826  dt3dt(i,k,5) = dt3dt(i,k,5) + (gt0(i,k)-dtdt(i,k))
2827  & * frain
2828  dq3dt(i,k,3) = dq3dt(i,k,3) + (gq0(i,k,1)-dqdt(i,k,1)) &
2829  & * frain
2830  dtdt(i,k) = gt0(i,k)
2831  dqdt(i,k,1) = gq0(i,k,1)
2832  enddo
2833  enddo
2834  endif
2835  endif ! end if_lssav
2836 !
2837  do k = 1, levs
2838  do i = 1, im
2839  if (clw(i,k,2) <= -999.0) clw(i,k,2) = 0.0
2840  enddo
2841  enddo
2842 
2843 ! if (lprnt) then
2844 ! write(0,*)' prsl=',prsl(ipr,:)
2845 ! write(0,*) ' del=',del(ipr,:)
2846 ! write(0,*) ' befshgt0=',gt0(ipr,:)
2847 ! write(0,*) ' befshgq0=',gq0(ipr,:,1)
2848 ! endif
2849 
2850  elseif (shocaftcnv) then ! if do_shoc is true and shocaftcnv is true call shoc
2851  if (ncld == 2) then
2852  skip_macro = do_shoc
2853  do k = 1, levs
2854  do i = 1, im
2855 ! clw(i,k,1) = gq0(i,k,ntiw) ! ice
2856 ! clw(i,k,2) = gq0(i,k,ntcw) ! water
2857  ncpl(i,k) = gq0(i,k,ntlnc)
2858  ncpi(i,k) = gq0(i,k,ntinc)
2859  enddo
2860  enddo
2861 
2862 ! else
2863 ! if (clw(1,1,2) < -999.0) then ! if clw is not partitioned to ice and water
2864 ! do k=1,levs
2865 ! do i=1,im
2866 ! tem = gq0(i,k,ntcw) &
2867 ! & * max(0.0, MIN(1.0, (TCR-gt0(i,k))*TCRF))
2868 ! clw(i,k,1) = tem ! ice
2869 ! clw(i,k,2) = gq0(i,k,ntcw) - tem ! water
2870 ! enddo
2871 ! enddo
2872 ! endif ! Anning ncld ==2
2873  endif
2874  do k=1,levs
2875  do i=1,im
2876  qpl(i,k) = 0.0
2877  qpi(i,k) = 0.0
2878  enddo
2879  enddo
2880 ! dtshoc = 60.0
2881 ! nshocm = (dtp/dtshoc) + 0.001
2882 ! dtshoc = dtp / nshocm
2883 ! do nshoc=1,nshocm
2884 ! call shoc(im, 1, levs, levs+1, dtp, me, lat, &
2885 !! call shoc(im, 1, levs, levs+1, dtshoc, me, lat, &
2886 ! & prsl(1:im,:), phii (1:im,:), phil(1:im,:),&
2887 ! & gu0(1:im,:),gv0(1:im,:), vvel(1:im,:), gt0(1:im,:), &
2888 ! & gq0(1:im,:,1), &
2889 ! & clw(1:im,:,1), clw(1:im,:,2), qpi, qpl, sgs_cld(1:im,:)&
2890 ! &, gq0(1:im,:,ntke), &
2891 ! & phy_f3d(1:im,:,ntot3d-1), phy_f3d(1:im,:,ntot3d), &
2892 ! & lprnt, ipr, &
2893 ! & con_cp, con_g, con_hvap, con_hfus, con_hvap+con_hfus, &
2894 ! & con_rv, con_rd, con_pi, con_fvirt)
2895 
2896 ! call shoc(ix, im, 1, levs, levs+1, dtshoc, me, lat, &
2897  call shoc(ix, im, 1, levs, levs+1, dtp, me, lat, &
2898  & prsl(1,1), phii(1,1), phil(1,1), &
2899  & gu0(1,1),gv0(1,1), vvel(1,1), gt0(1,1), gq0(1,1,1), &
2900  & clw(1,1,1), clw(1,1,2), qpi, qpl,rhc, sup, &
2901  & phy_f3d(1,1,ntot3d-2), gq0(1,1,ntke),hflx,evap, &
2902  & prnum, phy_f3d(1,1,ntot3d-1), phy_f3d(1,1,ntot3d), &
2903  & lprnt, ipr, ncpl, ncpi)
2904 
2905  if (ntlnc > 0 .and. ntinc > 0 .and. ncld >=2) then
2906  do k=1,levs
2907  do i=1,im
2908  gq0(i,k,ntlnc) = ncpl(i,k)
2909  gq0(i,k,ntinc) = ncpi(i,k)
2910  enddo
2911  enddo
2912  endif
2913 
2914 !
2915 ! do k=1,levs
2916 ! write(1000+me,*)' maxtkh=',maxval(phy_f3d(1:im,k,ntot3d-1)),
2917 ! &' k=',k,' kdt=',kdt,' lat=',lat
2918 ! enddo
2919 
2920 ! write(0,*)' aft shoc gt0=',gt0(1,:),' lat=',lat
2921 ! write(0,*)' aft shoc gq0=',gq0(1,:,1),' lat=',lat
2922 ! write(0,*)' aft shoc gu0=',gu0(1,:),' lat=',lat
2923 !
2924  endif ! if( .not. do_shoc)
2925 !
2926 ! if (lprnt) then
2927 ! write(0,*)' prsl=',prsl(ipr,:)
2928 ! write(0,*) ' del=',del(ipr,:)
2929 ! write(0,*) ' aftshgt0=',gt0(ipr,:)
2930 ! write(0,*) ' aftshgq0=',gq0(ipr,:,1)
2931 ! endif
2932 
2933  if (ntcw > 0) then
2934 
2935 ! for microphysics
2936 
2937  if (ncld == 2) then ! morrison microphysics
2938  do k = 1, levs
2939  do i = 1, im
2940  gq0(i,k,ntiw) = clw(i,k,1) ! ice
2941  gq0(i,k,ntcw) = clw(i,k,2) ! water
2942  enddo
2943  enddo
2944 
2945  elseif (num_p3d == 3) then ! call brad ferrier's microphysics
2946 
2947  do k = 1, levs
2948  do i = 1, im
2949 ! qi = clw(i,k)*fc_ice(i,k)
2950 ! qw = clw(i,k) - qi
2951  qi = clw(i,k,1)
2952  qw = clw(i,k,2)
2953 
2954 ! --- ... algorithm to combine different hydrometeor species
2955 
2956 ! gq0(i,k,ntcw) = max(epsq, qi+qw+qr_col(i,k))
2957  gq0(i,k,ntcw) = qi + qw + qr_col(i,k)
2958 
2959  if (qi <= epsq) then
2960  phy_f3d(i,k,1) = 0.
2961  else
2962  phy_f3d(i,k,1) = qi/gq0(i,k,ntcw)
2963  endif
2964 
2965  if (qr_col(i,k) <= epsq) then
2966  phy_f3d(i,k,2) = 0.
2967  else
2968  phy_f3d(i,k,2) = qr_col(i,k) / (qw+qr_col(i,k))
2969  endif
2970 
2971  enddo
2972  enddo
2973 
2974  elseif (num_p3d == 4) then ! if_num_p3d
2975 
2976  do k = 1, levs
2977  do i = 1, im
2978  gq0(i,k,ntcw) = clw(i,k,1) + clw(i,k,2)
2979  enddo
2980  enddo
2981 
2982  endif ! end if_num_p3d
2983 
2984  else ! if_ntcw
2985 
2986  do k = 1, levs
2987  do i = 1, im
2988  clw(i,k,1) = clw(i,k,1) + clw(i,k,2)
2989  enddo
2990  enddo
2991 
2992  endif ! end if_ntcw
2993 
2994 ! Legacy routine which determines convectve clouds - should be removed at some point
2995 
2996  call cnvc90(clstp, im, ix, rainc, kbot, ktop, levs, prsi, &
2997  & acv, acvb, acvt, cv, cvb, cvt)
2998 
2999 
3000  if (moist_adj) then ! moist convective adjustment
3001 ! ---------------------------
3002 !
3003 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3004 ! if (me == 0) then
3005 ! sumq = 0.0
3006 ! DO K=1,LEVS
3007 ! do i=1,im
3008 ! sumq = sumq - (gq0(i,k,1)+gq0(i,k,ntcw)) * del(i,k)
3009 ! enddo
3010 ! enddo
3011 ! endif
3012 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3013 !
3014 ! To call moist convective adjustment
3015 !
3016 ! if (lprnt) then
3017 ! print *,' prsl=',prsl(ipr,:)
3018 ! print *,' del=',del(ipr,:)
3019 ! print *,' gt0b=',gt0(ipr,:)
3020 ! print *,' gq0b=',gq0(ipr,:,1)
3021 ! endif
3022 
3023  call mstcnv(im,ix,levs,dtp,gt0,gq0,prsl,del,prslk,rain1
3024  &, gq0(1,1,ntcw), rhc, lprnt,ipr)
3025 
3026 ! if (lprnt) then
3027 ! print *,' rain1=',rain1(ipr),' rainc=',rainc(ipr)
3028 ! print *,' gt0a=',gt0(ipr,:)
3029 ! print *,' gq0a=',gq0(ipr,:,1)
3030 ! endif
3031  do i=1,im
3032  rainc(i) = rainc(i) + frain * rain1(i)
3033  enddo
3034  if(lssav) then
3035  do i=1,im
3036  cnvprcp(i) = cnvprcp(i) + rain1(i) * frain
3037  enddo
3038 
3039 ! update dqdt_v to include moisture tendency due to surface processes
3040 ! dqdt_v : instaneous moisture tendency (kg/kg/sec)
3041 ! if (lgocart) then
3042 ! do k=1,levs
3043 ! do i=1,im
3044 ! tem = (gq0(i,k,1)-dqdt(i,k,1)) * frain
3045 ! dqdt_v(i,k) = dqdt_v(i,k) + tem
3046 ! dqdt_v(i,k) = dqdt_v(i,k) / dtf
3047 ! enddo
3048 ! enddo
3049 ! endif
3050  if (ldiag3d) then
3051  do k=1,levs
3052  do i=1,im
3053  dt3dt(i,k,4) = dt3dt(i,k,4) + (gt0(i,k)-dtdt(i,k))
3054  & * frain
3055  dq3dt(i,k,2) = dq3dt(i,k,2) + (gq0(i,k,1)-dqdt(i,k,1))
3056  & * frain
3057  enddo
3058  enddo
3059  endif
3060  endif
3061 !
3062  if (ldiag3d) then
3063  do k=1,levs
3064  do i=1,im
3065  dtdt(i,k) = gt0(i,k)
3066  dqdt(i,k,1) = gq0(i,k,1)
3067  enddo
3068  enddo
3069  endif
3070 !
3071 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3072 ! if (me == 0) then
3073 ! DO K=1,LEVS
3074 ! do i=1,im
3075 ! sumq = sumq + (gq0(i,k,1)+gq0(i,k,ntcw)) * del(i,k)
3076 ! enddo
3077 ! enddo
3078 ! sumr = 0.0
3079 ! do i=1,im
3080 ! sumr = sumr + rain1(i)
3081 ! enddo
3082 ! sumq = sumq * 1000.0 / grav
3083 ! sumr = sumr *1000
3084 ! print *,' after MCN: sumq=',sumq,' sumr=',sumr, ' kdt=',kdt
3085 ! endif
3086 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3087 !
3088  endif ! moist convective adjustment over
3089 
3090 ! dqdt_v : instaneous moisture tendency (kg/kg/sec)
3091  if (lgocart) then
3092  do k=1,levs
3093  do i=1,im
3094  dqdt_v(i,k) = dqdt_v(i,k) / dtf
3095  enddo
3096  enddo
3097  endif
3098 !
3099 ! grid-scale condensation/precipitations and microphysics parameterization
3100 ! ------------------------------------------------------------------------
3101 
3102  if (ncld == 0) then ! no cloud microphysics
3103 
3104  call lrgscl(ix,im,levs,dtp,gt0,gq0,prsl,del,prslk,rain1,clw)
3105 
3106  elseif (ncld == 1) then ! microphysics with single cloud condensate
3107 
3108  if (num_p3d == 3) then ! brad ferrier's microphysics
3109  ! ---------------------------
3110  do i = 1, im
3111  xncw(i) = ncw(1) * work1(i) + ncw(2) * work2(i)
3112  flgmin_l(i) = flgmin(1)* work1(i) + flgmin(2) * work2(i)
3113  enddo
3114 
3115  if (kdt == 1 .and. abs(xlon(1)) < 0.0001) then
3116  write(0,*)' xncw=',xncw(1),' rhc=',rhc(1,1),' work1=' &
3117  &, work1(1),' work2=',work2(1),' flgmin=',flgmin_l(1) &
3118  &, ' lon=',xlon(1) * 57.29578,' lat=',lat,' me=',me
3119  endif
3120 
3121  call gsmdrive(im, ix, levs, dtp, con_g, con_hvap, hsub, con_cp&
3122  &, me, lprnt, ipr &
3123  &, prsl, del, rhc, xncw, flgmin_l &
3124  &, gt0, gq0(1,1,1), gq0(1,1,ntcw) &
3125  &, phy_f3d(1,1,1), phy_f3d(1,1,2) &
3126  &, phy_f3d(1,1,3), rain1, sr)
3127 
3128  elseif (num_p3d == 4) then ! call zhao/carr/sundqvist microphysics
3129 
3130  if (npdf3d /= 3) then ! without pdf clouds
3131 
3132 ! if (lprnt) then
3133 ! write(0,*)' prsl=',prsl(ipr,:)
3134 ! write(0,*) ' del=',del(ipr,:)
3135 ! write(0,*) ' beflsgt0=',gt0(ipr,:),' kdt=',kdt
3136 ! write(0,*) ' beflsgq0=',gq0(ipr,:,1),' kdt=',kdt
3137 ! endif
3138  ! ------------------
3139  if (do_shoc) then
3140  call precpd_shoc(im, ix, levs, dtp, del, prsl, &
3141  & gq0(1,1,1), gq0(1,1,ntcw), gt0, rain1, sr, &
3142  & rainp, rhc, psautco_l, prautco_l, evpco, &
3143  & wminco, phy_f3d(1,1,ntot3d-2), lprnt, ipr)
3144 ! & wminco, sgs_cld(1:im,1:levs), lprnt, ipr)
3145 ! & wminco, shoc_cld, lprnt, ipr)
3146  else
3147  call gscond(im, ix, levs, dtp, dtf, prsl, pgr, &
3148  & gq0(1,1,1), gq0(1,1,ntcw), gt0, &
3149  & phy_f3d(1,1,1), phy_f3d(1,1,2), phy_f2d(1,1), &
3150  & phy_f3d(1,1,3), phy_f3d(1,1,4), phy_f2d(1,2), &
3151  & rhc,lprnt, ipr)
3152 
3153  call precpd(im, ix, levs, dtp, del, prsl, &
3154  & gq0(1,1,1), gq0(1,1,ntcw), gt0, rain1, sr, &
3155  & rainp, rhc, psautco_l, prautco_l, evpco, &
3156  & wminco, lprnt, ipr)
3157  endif
3158 ! if (lprnt) then
3159 ! write(0,*)' prsl=',prsl(ipr,:)
3160 ! write(0,*) ' del=',del(ipr,:)
3161 ! write(0,*) ' aftlsgt0=',gt0(ipr,:),' kdt=',kdt
3162 ! write(0,*) ' aftlsgq0=',gq0(ipr,:,1),' kdt=',kdt
3163 ! write(0,*)' aft precpd rain1=',rain1(1:3),' lat=',lat
3164 ! endif
3165  else ! with pdf clouds
3166  ! ---------------
3167  call gscondp(im, ix, levs, dtp, dtf, prsl, pgr, &
3168  & gq0(1,1,1), gq0(1,1,ntcw), gt0, &
3169  & phy_f3d(1,1,1), phy_f3d(1,1,2), phy_f2d(1,1), &
3170  & phy_f3d(1,1,3), phy_f3d(1,1,4), phy_f2d(1,2), &
3171  & rhc,phy_f3d(1,1,num_p3d+1),sup,lprnt, &
3172  & ipr,kdt)
3173 
3174  call precpdp(im, ix, levs, dtp, del, prsl, pgr, &
3175  & gq0(1,1,1), gq0(1,1,ntcw), gt0, rain1,sr, &
3176  & rainp, rhc, phy_f3d(1,1,num_p3d+1), &
3177  & psautco_l, prautco_l, evpco, wminco, &
3178  & lprnt, ipr)
3179 
3180  endif ! end of grid-scale precip/microphysics options
3181  endif ! end if_num_p3d
3182 
3183 ! if (lprnt) write(0,*) ' rain1=',rain1(ipr),' rainc=',rainc(ipr)
3184 ! &,' lat=',lat
3185 
3186  elseif (ncld == 2) then ! MGB double-moment microphysics
3187 ! Acheng used clw here for other code to run smoothly and minimum change
3188 ! to make the code work. However, the nc and clw should be treated
3189 ! in other procceses too. August 28/2015; Hope that can be done next
3190 ! year. I believe this will make the physical interaction more reasonable
3191 ! Anning 12/5/2015 changed ntcw hold liquid only
3192  if (do_shoc) then
3193  do k=1,levs
3194  do i=1,im
3195  clw(i,k,1) = gq0(i,k,ntiw) ! ice
3196  clw(i,k,2) = gq0(i,k,ntcw) ! water
3197  phy_f3d(i,k,1) = phy_f3d(i,k,ntot3d-2) ! clouds from shoc
3198  enddo
3199  enddo
3200  else
3201  do k=1,levs
3202  do i=1,im
3203  clw(i,k,1) = gq0(i,k,ntiw) ! ice
3204  clw(i,k,2) = gq0(i,k,ntcw) ! water
3205  phy_f3d(i,k,1) = min(1.0, phy_f3d(i,k,1)+cnvc(i,k))
3206  ! clouds from t-dt and cnvc
3207  enddo
3208  enddo
3209  endif
3210 ! notice clw ix instead of im
3211 ! call m_micro_driver(im,ix,levs,flipv,del,dtp,prsl,prsi,
3212 ! & prslk,prsik,pgr,vvel,clw(1,1,2), QLCN, clw(1,1,1),QICN,
3213 ! if (lprnt) write(0,*)' cnv_mfdbef=',cnv_mfd(ipr,:),' flipv=',flipv
3214 ! if (lprnt) write(0,*)' clw1bef=',clw(ipr,:,1),' kdt=',kdt
3215  call m_micro_driver(im, ix, levs, flipv, dtp,
3216  & prsl, prsi, prslk, prsik,
3217  & vvel, clw(1,1,2), qlcn, clw(1,1,1),qicn,
3218  & hlw, swh, w_upi, cf_upi,
3219  & frland, hpbl, cnv_mfd, cnv_prc3,
3220  & cnv_dqldt, clcn, gu0, gv0,
3221  & dusfc, dvsfc, dusfc1, dvsfc1,
3222  & dusfc1, dvsfc1, cnv_fice,
3223  & cnv_ndrop, cnv_nice, gq0(1,1,1),
3224  & gq0(1,1,ntcw), gq0(1,1,ntiw), gt0,
3225  & rain1, sr, gq0(1,1,ntlnc),
3226  & gq0(1,1,ntinc), phy_f3d(1,1,1), kbot,
3227  & aero_in, skip_macro, cn_prc, cn_snr,
3228  & lprnt, ipr, kdt)
3229 
3230 ! if (lprnt) write(0,*) ' rain1=',rain1(ipr),' rainc=',rainc(ipr)
3231 ! &,' cn_prc=',cn_prc(ipr),' cn_snr=',cn_snr(ipr)
3232 ! if(lprnt) write(0,*) ' aftlsgq0=',gq0(ipr,:,1),' kdt=',kdt
3233 ! if (lprnt) write(0,*)' clw1aft=',gq0(ipr,:,ntiw),' kdt=',kdt
3234 
3235  endif ! end if_ncld
3236 
3237  do i = 1, im
3238  rain(i) = rainc(i) + frain * rain1(i)
3239  enddo
3240 
3241  if (cal_pre) then ! hchuang: add dominant precipitation type algorithm
3242 
3243  i = min(3,num_p3d)
3244  call calpreciptype(kdt,nrcm,im,ix,levs,levs+1,rann,
3245  & xlat,xlon,gt0,gq0,prsl,prsi,rain,
3246  & phii,num_p3d,tsea,sr,phy_f3d(1,1,i), ! input
3247  & domr,domzr,domip,doms) ! output
3248 
3249 !
3250 ! if (lprnt) print*,'debug calpreciptype: DOMR,DOMZR,DOMIP,DOMS '
3251 ! &,DOMR(ipr),DOMZR(ipr),DOMIP(ipr),DOMS(ipr)
3252 ! do i=1,im
3253 ! if (abs(xlon(i)*57.29578-114.0) .lt. 0.2 .and.
3254 ! & abs(xlat(i)*57.29578-40.0) .lt. 0.2)
3255 ! & print*,'debug calpreciptype: DOMR,DOMZR,DOMIP,DOMS ',
3256 ! & DOMR(i),DOMZR(i),DOMIP(i),DOMS(i)
3257 ! end do
3258 ! HCHUANG: use new precipitation type to decide snow flag for LSM snow accumulation
3259 
3260  do i=1,im
3261  if(doms(i) >0.0 .or. domip(i)>0.0)then
3262  srflag(i) = 1.
3263  else
3264  srflag(i) = 0.
3265  end if
3266  enddo
3267  endif
3268 
3269  if (lssav) then
3270  do i = 1, im
3271  totprcp(i) = totprcp(i) + rain(i)
3272 ! cnvprcp(i) = cnvprcp(i) + rainc(i)
3273  enddo
3274 
3275  if (ldiag3d) then
3276  do k = 1, levs
3277  do i = 1, im
3278  dt3dt(i,k,6) = dt3dt(i,k,6) + (gt0(i,k)-dtdt(i,k)) * frain
3279  dq3dt(i,k,4) = dq3dt(i,k,4) + (gq0(i,k,1)-dqdt(i,k,1)) &
3280  & * frain
3281  enddo
3282  enddo
3283  endif
3284  endif
3285 
3286 ! --- ... estimate t850 for rain-snow decision
3287 
3288  do i = 1, im
3289  t850(i) = gt0(i,1)
3290  enddo
3291 
3292  do k = 1, levs-1
3293  do i = 1, im
3294  if (prsl(i,k) > p850 .and. prsl(i,k+1) <= p850) then
3295  t850(i) = gt0(i,k) - (prsl(i,k)-p850) &
3296  & / (prsl(i,k)-prsl(i,k+1)) * (gt0(i,k)-gt0(i,k+1))
3297  endif
3298  enddo
3299  enddo
3300 
3301 ! --- ... lu: snow-rain detection is performed in land/sice module
3302 
3303  if (cal_pre) then ! hchuang: new precip type algorithm defines srflag
3304  do i = 1, im
3305  tprcp(i) = max(0.0, rain(i)) ! clu: rain -> tprcp
3306  enddo
3307  else
3308  do i = 1, im
3309  tprcp(i) = max(0.0, rain(i) )! clu: rain -> tprcp
3310  srflag(i) = 0. ! clu: default srflag as 'rain' (i.e. 0)
3311 
3312  if (t850(i) <= 273.16) then
3313  srflag(i) = 1. ! clu: set srflag to 'snow' (i.e. 1)
3314  endif
3315  enddo
3316  endif
3317 
3318 ! --- ... coupling insertion
3319 
3320  if (lssav_cpl) then
3321  do i = 1, im
3322  if (t850(i) > 273.16) then
3323  rain_cpl(i) = rain_cpl(i) + rain(i)
3324  else
3325  snow_cpl(i) = snow_cpl(i) + rain(i)
3326  endif
3327  enddo
3328  endif
3329 
3330 ! --- ... end coupling insertion
3331 
3332  if (lsm == 0) then ! for OSU land model
3333 
3334 ! --- ... wei: when calling osu lsm update soil moisture and canopy water
3335 ! after precipitation computaion
3336  do i = 1, im
3337  if (t850(i) <= 273.16 .and. islmsk(i) /= 0) then
3338  weasd(i) = weasd(i) + 1.e3*rain(i)
3339  tprcp(i) = 0.
3340  endif
3341  enddo
3342  call progt2(im,lsoil,rhscnpy,rhsmc,ai,bi,cci,smsoil, &
3343  & islmsk,canopy,tprcp,runof,snowmt, &
3344  & zsoil,soiltyp,sigmaf,dtf,me)
3345 
3346 ! --- ... wei: let soil liquid water equal to soil total water
3347 
3348  do k = 1, lsoil ! let soil liquid water equal to soil total water
3349  do i = 1, im
3350  if (islmsk(i) == 1) then
3351  slsoil(i,k) = smsoil(i,k)
3352  endif
3353  enddo
3354  enddo
3355 
3356  endif ! end if_lsm
3357 !!!
3358 !!! update surface diagnosis fields at the end of phys package
3359 !!! this change allows gocart to use filtered wind fields
3360 !!!
3361  if ( lgocart ) then
3362  call sfc_diag(im,pgr,gu0,gv0,gt0,gq0, &
3363  & tsea,qss,f10m,u10m,v10m,t2m,q2m,work3, &
3364  & evap,ffmm,ffhh,fm10,fh2)
3365 
3366  if (lssav) then
3367  do i = 1, im
3368  tmpmax(i) = max(tmpmax(i),t2m(i))
3369  tmpmin(i) = min(tmpmin(i),t2m(i))
3370 
3371  spfhmax(i) = max(spfhmax(i),q2m(i))
3372  spfhmin(i) = min(spfhmin(i),q2m(i))
3373  enddo
3374  endif
3375  endif
3376 
3377 ! --- ... total runoff is composed of drainage into water table and
3378 ! runoff at the surface and is accumulated in unit of meters
3379 
3380  if (lssav) then
3381  tem = dtf * 0.001
3382  do i = 1, im
3383  runoff(i) = runoff(i) + (drain(i)+runof(i)) * tem
3384  srunoff(i) = srunoff(i) + runof(i) * tem
3385  enddo
3386  endif
3387 
3388 ! --- ... xw: return updated ice thickness & concentration to global array
3389 
3390  do i = 1, im
3391  if (islmsk(i) == 2) then
3392  hice(i) = zice(i)
3393  fice(i) = cice(i)
3394  tisfc(i) = tice(i)
3395  else
3396  hice(i) = 0.0
3397  fice(i) = 0.0
3398  tisfc(i) = tsea(i)
3399  endif
3400  enddo
3401 
3402 ! --- ... return updated smsoil and stsoil to global arrays
3403 
3404  do k = 1, lsoil
3405  do i = 1, im
3406  smc(i,k) = smsoil(i,k)
3407  stc(i,k) = stsoil(i,k)
3408  slc(i,k) = slsoil(i,k)
3409  enddo
3410  enddo
3411 
3412 ! --- ... calculate column precipitable water "pwat"
3413 
3414  do i = 1, im
3415  pwat(i) = 0.
3416 ! rqtk(i) = 0.
3417 ! work2(i) = 1.0 / pgr(i)
3418  enddo
3419 
3420  do k = 1, levs
3421  do i = 1, im
3422  work1(i) = 0.0
3423  enddo
3424 
3425  if (ncld > 0) then
3426  do ic = ntcw, ntcw+ncld-1
3427  do i = 1, im
3428  work1(i) = work1(i) + gq0(i,k,ic)
3429  enddo
3430  enddo
3431  endif
3432 
3433  do i = 1, im
3434  pwat(i) = pwat(i) + del(i,k)*(gq0(i,k,1)+work1(i))
3435  rqtk(i) = rqtk(i) + del(i,k)*(gq0(i,k,1)-qgrs(i,k,1))
3436  enddo
3437  enddo
3438 
3439  do i = 1, im
3440  pwat(i) = pwat(i) * (1.0/con_g)
3441 ! rqtk(i) = rqtk(i) * work2(i)
3442  enddo
3443 !
3444 ! if (lat == 45) write(1000+me,*)' pwat=',pwat(1),' kdt=',kdt
3445 ! if (lprnt) then
3446 ! write(0,*) ' endgt0=',gt0(ipr,:),' kdt=',kdt
3447 ! write(0,*) ' endgq0=',gq0(ipr,:,1),' kdt=',kdt
3448 ! endif
3449  deallocate (clw)
3450  if (do_shoc) then
3451  deallocate (qpl, qpi, ncpl, ncpi)
3452  endif
3453  if (.not. ras .or. .not. cscnv) then
3454  deallocate (cnvc, cnvw)
3455  endif
3456 ! deallocate (fscav, fswtr)
3457 !
3458 ! if (lprnt) write(0,*)' end of gbphys at kdt=',kdt,
3459 ! &' rain=',rain(ipr),' rainc=',rainc(ipr)
3460 ! if (lprnt) call mpi_quit(7)
3461 ! if (kdt >2 ) call mpi_quit(7)
3462 ! if (ncld == 2) then ! For MGB double moment microphysics
3463  deallocate (qlcn, qicn, w_upi
3464  &, cf_upi, cnv_mfd, cnv_prc3
3465  &, cnv_dqldt, clcn, cnv_fice
3466  &, cnv_ndrop, cnv_nice)
3467 ! endif
3468 
3469  return
3470 !...................................
3471  end subroutine gbphys
3472 !-----------------------------------
real(kind=kind_phys), parameter con_pi
pi
Definition: physcons.f:48
real(kind=kind_phys), parameter con_g
gravity ( )
Definition: physcons.f:59
subroutine gwdc(im, ix, iy, km, lat, u1, v1, t1, q1, pmid1, pint1, dpmid1, qmax, ktop, kbot, kcnv, cldf, grav, cp, rd, fv, dlength, lprnt, ipr, fhour, utgwc, vtgwc, tauctx, taucty)
Definition: gwdc.f:76
subroutine precpd(im, ix, km, dt, del, prsl, q, cwm, t, rn, sr , rainp, u00k, psautco, prautco, evpco, wminco , lprnt, jpr)
Definition: precpd.f:81
subroutine gwdps(IM, IX, IY, KM, A, B, C, U1, V1, T1, Q1, KPBL, PRSI, DEL, PRSL, PRSLK, PHII, PHIL, DELTIM, KDT, HPRIME, OC, OA4, CLX4, THETA, SIGMA, GAMMA, ELVMAX, DUSFC, DVSFC, G, CP, RD, RV, IMX, nmtvr, cdmbgwd, me, lprnt, ipr)
Definition: gwdps.f:188
real(kind=kind_phys), parameter con_rv
gas constant H2O ( )
Definition: physcons.f:78
real(kind=kind_phys), parameter con_hfus
lat heat H2O fusion ( )
Definition: physcons.f:92
subroutine sascnvn(im, ix, km, jcap, delt, delp, prslp, psp, phil, ql, q1, t1, u1, v1, cldwrk, rn, kbot, ktop, kcnv, islimsk, dot, ncloud, ud_mf, dd_mf, dt_mf, cnvw, cnvc)
This subroutine contains the entirety of the SAS deep convection scheme.
Definition: sascnvn.f:59
real(kind=kind_phys), parameter con_cp
spec heat air at p ( )
Definition: physcons.f:80
real(kind=kind_phys), parameter con_hvap
lat heat H2O cond ( )
Definition: physcons.f:90
subroutine moninedmf(ix, im, km, ntrac, ntcw, dv, du, tau, rtg, u1, v1, t1, q1, swh, hlw, xmu, psk, rbsoil, zorl, u10m, v10m, fm, fh, tsea, qss, heat, evap, stress, spd1, kpbl, prsi, del, prsl, prslk, phii, phil, delt, dspheat, dusfc, dvsfc, dtsfc, dqsfc, hpbl, hgamt, hgamq, dkt, kinver, xkzm_m, xkzm_h, xkzm_s, lprnt, ipr)
This subroutine contains all of logic for the Hybrid EDMF PBL scheme except for the calculation of th...
Definition: moninedmf.f:96
subroutine gbphys
Parameter descriptions include intent, name, description, and size.
Definition: gbphys.f:529
subroutine shalcnv(im, ix, km, jcap, delt, delp, prslp, psp, phil, ql, q1, t1, u1, v1, rn, kbot, ktop, kcnv, islimsk, dot, ncloud, hpbl, heat, evap, ud_mf, dt_mf, cnvw, cnvc)
This subroutine contains the entirety of the SAS shallow convection scheme.
Definition: shalcnv.f:58
real(kind=kind_phys), parameter con_rd
gas constant air ( )
Definition: physcons.f:76
real(kind=kind_phys), parameter con_rerth
radius of earth (m)
Definition: physcons.f:57
subroutine gscond(im, ix, km, dt, dtf, prsl, ps, q, cwm, t , tp, qp, psp, tp1, qp1, psp1, u, lprnt, ipr)
Definition: gscond.f:87