diff --git a/physics/GFS_MP_generic.F90 b/physics/GFS_MP_generic.F90 index 04450b612..680302cad 100644 --- a/physics/GFS_MP_generic.F90 +++ b/physics/GFS_MP_generic.F90 @@ -85,7 +85,7 @@ end subroutine GFS_MP_generic_post_init !! !> \section gfs_mp_gen GFS MP Generic Post General Algorithm !> @{ - subroutine GFS_MP_generic_post_run(im, levs, kdt, nrcm, ncld, nncl, ntcw, ntrac, imp_physics, imp_physics_gfdl, & + subroutine GFS_MP_generic_post_run(im, levs, kdt, nrcm, nncl, ntcw, ntrac, imp_physics, imp_physics_gfdl, & imp_physics_thompson, imp_physics_mg, imp_physics_fer_hires, cal_pre, lssav, ldiag3d, qdiag3d, cplflx, cplchm, con_g, dtf, frain, rainc, rain1, & rann, xlat, xlon, gt0, gq0, prsl, prsi, phii, tsfc, ice, snow, graupel, save_t, save_qv, rain0, ice0, snow0, & graupel0, del, rain, domr_diag, domzr_diag, domip_diag, doms_diag, tprcp, srflag, sr, cnvprcp, totprcp, totice, & @@ -97,7 +97,7 @@ subroutine GFS_MP_generic_post_run(im, levs, kdt, nrcm, ncld, nncl, ntcw, ntrac, implicit none - integer, intent(in) :: im, levs, kdt, nrcm, ncld, nncl, ntcw, ntrac + integer, intent(in) :: im, levs, kdt, nrcm, nncl, ntcw, ntrac integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_mg, imp_physics_fer_hires logical, intent(in) :: cal_pre, lssav, ldiag3d, qdiag3d, cplflx, cplchm @@ -373,7 +373,7 @@ subroutine GFS_MP_generic_post_run(im, levs, kdt, nrcm, ncld, nncl, ntcw, ntrac, do i=1, im work1(i) = zero enddo - if (ncld > 0) then + if (nncl > 0) then do ic = ntcw, ntcw+nncl-1 do i=1,im work1(i) = work1(i) + gq0(i,k,ic) diff --git a/physics/GFS_MP_generic.meta b/physics/GFS_MP_generic.meta index fa4be3ea7..468bd1397 100644 --- a/physics/GFS_MP_generic.meta +++ b/physics/GFS_MP_generic.meta @@ -56,8 +56,8 @@ intent = in optional = F [nncl] - standard_name = number_of_tracers_for_cloud_condensate - long_name = number of tracers for cloud condensate + standard_name = number_of_cloud_condensate_types + long_name = number of cloud condensate types units = count dimensions = () type = integer @@ -176,17 +176,9 @@ type = integer intent = in optional = F -[ncld] - standard_name = number_of_hydrometeors - long_name = choice of cloud scheme / number of hydrometeors - units = count - dimensions = () - type = integer - intent = in - optional = F [nncl] - standard_name = number_of_tracers_for_cloud_condensate - long_name = number of tracers for cloud condensate + standard_name = number_of_cloud_condensate_types + long_name = number of cloud condensate types units = count dimensions = () type = integer diff --git a/physics/GFS_PBL_generic.F90 b/physics/GFS_PBL_generic.F90 index 09576443c..e116f04da 100644 --- a/physics/GFS_PBL_generic.F90 +++ b/physics/GFS_PBL_generic.F90 @@ -326,14 +326,13 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, implicit none integer, parameter :: kp = kind_phys - integer, intent(in) :: im, levs, nvdiff, ntrac, ntchs, ntchm + integer, intent(in) :: im, levs, nvdiff, ntrac, ntchs, ntchm, kdt integer, intent(in) :: ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc, ntwa, ntia, ntgl, ntoz, ntke, ntkev, nqrimef logical, intent(in) :: trans_aero integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6 integer, intent(in) :: imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires logical, intent(in) :: ltaerosol, cplflx, cplchm, lssav, ldiag3d, qdiag3d, lsidea logical, intent(in) :: hybedmf, do_shoc, satmedmf, shinhong, do_ysu - integer, intent(in) :: kdt logical, intent(in) :: flag_for_pbl_generic_tend real(kind=kind_phys), dimension(:,:), intent(in) :: save_u, save_v, save_t @@ -534,14 +533,14 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, if (cplflx) then do i=1,im - if (oceanfrac(i) > zero) then ! Ocean only, NO LAKES + if (oceanfrac(i) > zero) then ! Ocean only, NO LAKES if ( .not. wet(i)) then ! no open water - if ( kdt > 1 ) then !use results from CICE + if (kdt > 1) then !use results from CICE dusfci_cpl(i) = dusfc_cice(i) dvsfci_cpl(i) = dvsfc_cice(i) dtsfci_cpl(i) = dtsfc_cice(i) dqsfci_cpl(i) = dqsfc_cice(i) - else !use PBL fluxes when CICE fluxes is unavailable + else !use PBL fluxes when CICE fluxes is unavailable dusfci_cpl(i) = dusfc1(i) dvsfci_cpl(i) = dvsfc1(i) dtsfci_cpl(i) = dtsfc1(i) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index bc96075be..39cee585f 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -1307,8 +1307,8 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%slopetype ', Interstitial%slopetype ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowc ', Interstitial%snowc ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowd_ice ', Interstitial%snowd_ice ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowd_land ', Interstitial%snowd_land ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowd_water ', Interstitial%snowd_water ) +! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowd_land ', Interstitial%snowd_land ) +! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowd_water ', Interstitial%snowd_water ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snohf ', Interstitial%snohf ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowmt ', Interstitial%snowmt ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%soiltype ', Interstitial%soiltype ) @@ -1342,8 +1342,8 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%vegtype ', Interstitial%vegtype ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%wcbmax ', Interstitial%wcbmax ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%weasd_ice ', Interstitial%weasd_ice ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%weasd_land ', Interstitial%weasd_land ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%weasd_water ', Interstitial%weasd_water ) +! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%weasd_land ', Interstitial%weasd_land ) +! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%weasd_water ', Interstitial%weasd_water ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%wind ', Interstitial%wind ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%work1 ', Interstitial%work1 ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%work2 ', Interstitial%work2 ) diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index b68900d09..20c6c68c3 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -75,7 +75,7 @@ subroutine GFS_phys_time_vary_init ( isot, ivegsrc, nlunit, sncovr, sncovr_ice, lsm, lsm_noahmp, lsm_ruc, min_seaice, & fice, landfrac, vtype, weasd, lsoil, zs, dzs, lsnow_lsm_lbound, lsnow_lsm_ubound, & tvxy, tgxy, tahxy, canicexy, canliqxy, eahxy, cmxy, chxy, fwetxy, sneqvoxy, alboldxy,& - qsnowxy, wslakexy, albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, albdvis_ice, & + qsnowxy, wslakexy, albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, albdvis_ice, & albdnir_ice, albivis_ice, albinir_ice, emiss_lnd, emiss_ice, taussxy, waxy, wtxy, & zwtxy, xlaixy, xsaixy, lfmassxy, stmassxy, rtmassxy, woodxy, stblcpxy, fastcpxy, & smcwtdxy, deeprechxy, rechxy, snowxy, snicexy, snliqxy, tsnoxy , smoiseq, zsnsoxy, & @@ -319,10 +319,10 @@ subroutine GFS_phys_time_vary_init ( jindx2_aer, ddy_aer, xlon_d, & iindx1_aer, iindx2_aer, ddx_aer, & me, master) - iamin=min(minval(iindx1_aer), iamin) - iamax=max(maxval(iindx2_aer), iamax) - jamin=min(minval(jindx1_aer), jamin) - jamax=max(maxval(jindx2_aer), jamax) + iamin = min(minval(iindx1_aer), iamin) + iamax = max(maxval(iindx2_aer), iamax) + jamin = min(minval(jindx1_aer), jamin) + jamax = max(maxval(jindx2_aer), jamax) endif !$OMP section @@ -723,7 +723,7 @@ subroutine GFS_phys_time_vary_timestep_init ( lakefrac, min_seaice, min_lakeice, smc, slc, stc, smois, sh2o, tslb, tiice, tg3, tref, & tsfc, tsfco, tisfc, hice, fice, facsf, facwf, alvsf, alvwf, alnsf, alnwf, zorli, zorll, & zorlo, weasd, slope, snoalb, canopy, vfrac, vtype, stype, shdmin, shdmax, snowd, & - cv, cvb, cvt, oro, oro_uf, xlat_d, xlon_d, slmsk, & + cv, cvb, cvt, oro, oro_uf, xlat_d, xlon_d, slmsk, landfrac, & do_ugwp_v1, jindx1_tau, jindx2_tau, ddy_j1tau, ddy_j2tau, tau_amf, errmsg, errflg) implicit none @@ -760,7 +760,7 @@ subroutine GFS_phys_time_vary_timestep_init ( character(len=*), intent(in) :: input_nml_file(:) logical, intent(in) :: use_ufo, nst_anl, frac_grid real(kind_phys), intent(in) :: fhcyc, phour, lakefrac(:), min_seaice, min_lakeice, & - xlat_d(:), xlon_d(:) + xlat_d(:), xlon_d(:), landfrac(:) real(kind_phys), intent(inout) :: smc(:,:), slc(:,:), stc(:,:), smois(:,:), sh2o(:,:), & tslb(:,:), tiice(:,:), tg3(:), tref(:), & tsfc(:), tsfco(:), tisfc(:), hice(:), fice(:), & @@ -888,7 +888,7 @@ subroutine GFS_phys_time_vary_timestep_init ( ! aerinterpol is using threading inside, don't ! move into OpenMP parallel section above call aerinterpol (me, master, nthrds, im, idate, & - fhour, jindx1_aer, jindx2_aer,& + fhour, jindx1_aer, jindx2_aer, & ddy_aer, iindx1_aer, & iindx2_aer, ddx_aer, & levs, prsl, aer_nm) @@ -897,13 +897,13 @@ subroutine GFS_phys_time_vary_timestep_init ( !> - Call gcycle() to repopulate specific time-varying surface properties for AMIP/forecast runs if (nscyc > 0) then if (mod(kdt,nscyc) == 1) THEN - call gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & - input_nml_file, lsoil, lsoil_lsm, kice, idate, ialb, isot, ivegsrc, & - use_ufo, nst_anl, fhcyc, phour, lakefrac, min_seaice, min_lakeice, & - frac_grid, smc, slc, stc, smois, sh2o, tslb, tiice, tg3, tref, tsfc, & - tsfco, tisfc, hice, fice, facsf, facwf, alvsf, alvwf, alnsf, alnwf, & - zorli, zorll, zorlo, weasd, slope, snoalb, canopy, vfrac, vtype, & - stype, shdmin, shdmax, snowd, cv, cvb, cvt, oro, oro_uf, & + call gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & + input_nml_file, lsoil, lsoil_lsm, kice, idate, ialb, isot, ivegsrc, & + use_ufo, nst_anl, fhcyc, phour, landfrac, lakefrac, min_seaice, min_lakeice,& + frac_grid, smc, slc, stc, smois, sh2o, tslb, tiice, tg3, tref, tsfc, & + tsfco, tisfc, hice, fice, facsf, facwf, alvsf, alvwf, alnsf, alnwf, & + zorli, zorll, zorlo, weasd, slope, snoalb, canopy, vfrac, vtype, & + stype, shdmin, shdmax, snowd, cv, cvb, cvt, oro, oro_uf, & xlat_d, xlon_d, slmsk, imap, jmap) endif endif diff --git a/physics/GFS_phys_time_vary.fv3.meta b/physics/GFS_phys_time_vary.fv3.meta index 6289fb6a7..217dd5be7 100644 --- a/physics/GFS_phys_time_vary.fv3.meta +++ b/physics/GFS_phys_time_vary.fv3.meta @@ -2006,6 +2006,15 @@ kind = kind_phys intent = inout optional = F +[landfrac] + standard_name = land_area_fraction + long_name = fraction of horizontal grid area occupied by land + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F [slmsk] standard_name = sea_land_ice_mask_real long_name = landmask: sea/land/ice=0/1/2 diff --git a/physics/GFS_phys_time_vary.scm.F90 b/physics/GFS_phys_time_vary.scm.F90 index e1b5c3d9b..e0f380276 100644 --- a/physics/GFS_phys_time_vary.scm.F90 +++ b/physics/GFS_phys_time_vary.scm.F90 @@ -69,7 +69,7 @@ subroutine GFS_phys_time_vary_init ( isot, ivegsrc, nlunit, sncovr, sncovr_ice, lsm, lsm_noahmp, lsm_ruc, min_seaice, & fice, landfrac, vtype, weasd, lsoil, zs, dzs, lsnow_lsm_lbound, lsnow_lsm_ubound, & tvxy, tgxy, tahxy, canicexy, canliqxy, eahxy, cmxy, chxy, fwetxy, sneqvoxy, alboldxy,& - qsnowxy, wslakexy, albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, albdvis_ice, & + qsnowxy, wslakexy, albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, albdvis_ice, & albdnir_ice, albivis_ice, albinir_ice, emiss_lnd, emiss_ice, taussxy, waxy, wtxy, & zwtxy, xlaixy, xsaixy, lfmassxy, stmassxy, rtmassxy, woodxy, stblcpxy, fastcpxy, & smcwtdxy, deeprechxy, rechxy, snowxy, snicexy, snliqxy, tsnoxy , smoiseq, zsnsoxy, & @@ -281,10 +281,10 @@ subroutine GFS_phys_time_vary_init ( jindx2_aer, ddy_aer, xlon_d, & iindx1_aer, iindx2_aer, ddx_aer, & me, master) - iamin=min(minval(iindx1_aer), iamin) - iamax=max(maxval(iindx2_aer), iamax) - jamin=min(minval(jindx1_aer), jamin) - jamax=max(maxval(jindx2_aer), jamax) + iamin = min(minval(iindx1_aer), iamin) + iamax = max(maxval(iindx2_aer), iamax) + jamin = min(minval(jindx1_aer), jamin) + jamax = max(maxval(jindx2_aer), jamax) endif !> - Call setindxci() to initialize IN and CCN data @@ -691,8 +691,7 @@ subroutine GFS_phys_time_vary_timestep_init ( integer, intent(out) :: errflg ! Local variables - integer :: i, j, k, iseed, iskip, ix, kdt_rad - real(kind=kind_phys) :: sec_zero, rsnow + integer :: i, j, k, iseed, iskip, ix real(kind=kind_phys) :: wrk(1) real(kind=kind_phys) :: rannie(cny) real(kind=kind_phys) :: rndval(cnx*cny*nrcm) @@ -792,18 +791,18 @@ subroutine GFS_phys_time_vary_timestep_init ( ! Not needed for SCM: !> - Call gcycle() to repopulate specific time-varying surface properties for AMIP/forecast runs - !if (nscyc > 0) then - ! if (mod(kdt,nscyc) == 1) THEN - ! call gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & - ! input_nml_file, lsoil, lsoil_lsm, kice, idate, ialb, isot, ivegsrc, & - ! use_ufo, nst_anl, fhcyc, phour, lakefrac, min_seaice, min_lakeice, & - ! frac_grid, smc, slc, stc, smois, sh2o, tslb, tiice, tg3, tref, tsfc, & - ! tsfco, tisfc, hice, fice, facsf, facwf, alvsf, alvwf, alnsf, alnwf, & - ! zorli, zorll, zorlo, weasd, slope, snoalb, canopy, vfrac, vtype, & - ! stype, shdmin, shdmax, snowd, cv, cvb, cvt, oro, oro_uf, & - ! xlat_d, xlon_d, slmsk, imap, jmap) - ! endif - !endif + ! if (nscyc > 0) then + ! if (mod(kdt,nscyc) == 1) THEN + ! call gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & + ! input_nml_file, lsoil, lsoil_lsm, kice, idate, ialb, isot, ivegsrc, & + ! use_ufo, nst_anl, fhcyc, phour, landfrac, lakefrac, min_seaice, min_lakeice,& + ! frac_grid, smc, slc, stc, smois, sh2o, tslb, tiice, tg3, tref, tsfc, & + ! tsfco, tisfc, hice, fice, facsf, facwf, alvsf, alvwf, alnsf, alnwf, & + ! zorli, zorll, zorlo, weasd, slope, snoalb, canopy, vfrac, vtype, & + ! stype, shdmin, shdmax, snowd, cv, cvb, cvt, oro, oro_uf, & + ! xlat_d, xlon_d, slmsk, imap, jmap) + ! endif + ! endif end subroutine GFS_phys_time_vary_timestep_init !! @} diff --git a/physics/GFS_radiation_surface.F90 b/physics/GFS_radiation_surface.F90 index dd0c56d43..2481af163 100644 --- a/physics/GFS_radiation_surface.F90 +++ b/physics/GFS_radiation_surface.F90 @@ -159,7 +159,7 @@ subroutine GFS_radiation_surface_run ( & if (lslwr) then !> - Call module_radiation_surface::setemis(),to set up surface !! emissivity for LW radiation. - call setemis (lsm, lsm_noahmp, lsm_ruc, vtype, landfrac, & + call setemis (lsm, lsm_noahmp, lsm_ruc, vtype, & frac_grid, min_seaice, xlon, xlat, slmsk, & snowd, sncovr, sncovr_ice, zorl, tsfg, tsfa, & hprime, semis_lnd, semis_ice, im, & @@ -182,7 +182,7 @@ subroutine GFS_radiation_surface_run ( & !! albedor for SW radiation. call setalb (slmsk, lsm, lsm_noahmp, lsm_ruc, snowd, sncovr, sncovr_ice, snoalb, & - zorl, coszen, tsfg, tsfa, hprime, landfrac, frac_grid, min_seaice, & + zorl, coszen, tsfg, tsfa, hprime, frac_grid, min_seaice, & alvsf, alnsf, alvwf, alnwf, facsf, facwf, fice, tisfc, & albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, & albdvis_ice, albdnir_ice, albivis_ice, albinir_ice, & diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 158067c05..dbea66985 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -18,7 +18,7 @@ end subroutine GFS_rrtmg_pre_init ! in the CCPP version - they are defined in the interstitial_create routine subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & imfdeepcnv, imfdeepcnv_gf, me, ncnd, ntrac, num_p3d, npdf3d, ncnvcld3d,& - ntqv, ntcw,ntiw, ntlnc, ntinc, ncld, ntrw, ntsw, ntgl, ntwa, ntoz, & + ntqv, ntcw,ntiw, ntlnc, ntinc, ntrw, ntsw, ntgl, ntwa, ntoz, & ntclamt, nleffr, nieffr, nseffr, lndp_type, kdt, imp_physics, & imp_physics_thompson, imp_physics_gfdl, imp_physics_zhao_carr, & imp_physics_zhao_carr_pdf, imp_physics_mg, imp_physics_wsm6, & @@ -83,7 +83,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & imfdeepcnv, & imfdeepcnv_gf, me, ncnd, ntrac, & num_p3d, npdf3d, ncnvcld3d, ntqv, & - ntcw, ntiw, ntlnc, ntinc, ncld, & + ntcw, ntiw, ntlnc, ntinc, & ntrw, ntsw, ntgl, ntwa, ntoz, & ntclamt, nleffr, nieffr, nseffr, & lndp_type, & @@ -594,7 +594,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & !! call module_radiation_clouds::progcld1() !! - For Zhao/Moorthi's prognostic cloud+pdfcld, !! call module_radiation_clouds::progcld3() -!! call module_radiation_clouds::progclduni() for unified cloud and ncld=2 +!! call module_radiation_clouds::progclduni() for unified cloud and ncnd>=2 ! --- ... obtain cloud information for radiation calculations @@ -690,11 +690,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & ccnd(:,:,1) = ccnd(:,:,1) + tracer1(:,1:LMK,ntiw) ccnd(:,:,1) = ccnd(:,:,1) + tracer1(:,1:LMK,ntsw) ccnd(:,:,1) = ccnd(:,:,1) + tracer1(:,1:LMK,ntgl) - -! else -! do j=1,ncld -! ccnd(:,:,1) = ccnd(:,:,1) + tracer1(:,1:LMK,ntcw+j-1) ! cloud condensate amount -! enddo endif do k=1,LMK do i=1,IM @@ -949,7 +944,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & if (imp_physics == imp_physics_zhao_carr .or. imp_physics == imp_physics_mg) then ! zhao/moorthi's prognostic cloud scheme ! or unified cloud and/or with MG microphysics - if (uni_cld .and. ncld >= 2) then + if (uni_cld .and. ncndl >= 2) then call progclduni (plyr, plvl, tlyr, tvly, ccnd, ncndl, & ! --- inputs xlat, xlon, slmsk, dz, delp, & IM, LMK, LMP, cldcov, & diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 344befa97..d6da64ffb 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -161,14 +161,6 @@ type = integer intent = in optional = F -[ncld] - standard_name = number_of_hydrometeors - long_name = choice of cloud scheme / number of hydrometeors - units = count - dimensions = () - type = integer - intent = in - optional = F [ntrw] standard_name = index_for_rain_water long_name = tracer index for rain water diff --git a/physics/GFS_rrtmg_setup.F90 b/physics/GFS_rrtmg_setup.F90 index 1af386370..fc660994d 100644 --- a/physics/GFS_rrtmg_setup.F90 +++ b/physics/GFS_rrtmg_setup.F90 @@ -282,7 +282,7 @@ subroutine GFS_rrtmg_setup_init ( & print *,' In rad_initialize (GFS_rrtmg_setup_init), before calling radinit' print *,' si =',si print *,' levr=',levr,' ictm=',ictm,' isol=',isol,' ico2=',ico2,& - & ' iaer=',iaer,' ntcw=',ntcw + & ' iaermdl=',iaermdl,' iaerflg=',iaerflg print *,' np3d=',num_p3d,' ntoz=',ntoz, & & ' iovr=',iovr,' isubc_sw=',isubc_sw, & & ' isubc_lw=',isubc_lw,' icliq_sw=',icliq_sw, & diff --git a/physics/GFS_suite_interstitial.F90 b/physics/GFS_suite_interstitial.F90 index 72ebeede1..4835ea006 100644 --- a/physics/GFS_suite_interstitial.F90 +++ b/physics/GFS_suite_interstitial.F90 @@ -230,8 +230,8 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, flag_ ! --- ... sfc lw fluxes used by atmospheric model are saved for output if (.not. use_LW_jacobian) then - if (frac_grid) then - do i=1,im + if (frac_grid) then + do i=1,im tem = (one - frland(i)) * cice(i) ! tem = ice fraction wrt whole cell if (flag_cice(i)) then adjsfculw(i) = adjsfculw_lnd(i) * frland(i) & @@ -242,9 +242,9 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, flag_ + adjsfculw_ice(i) * tem & + adjsfculw_wat(i) * (one - frland(i) - tem) endif - enddo - else - do i=1,im + enddo + else + do i=1,im if (dry(i)) then ! all land adjsfculw(i) = adjsfculw_lnd(i) elseif (icy(i)) then ! ice (and water) @@ -265,15 +265,15 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, flag_ else ! all water adjsfculw(i) = adjsfculw_wat(i) endif - enddo - endif + enddo + endif endif do i=1,im dlwsfc(i) = dlwsfc(i) + adjsfcdlw(i)*dtf ulwsfc(i) = ulwsfc(i) + adjsfculw(i)*dtf psmean(i) = psmean(i) + pgr(i)*dtf ! mean surface pressure - end do + enddo if (ldiag3d) then if (lsidea) then diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index ee99e0f85..f3b87d1f5 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -29,32 +29,32 @@ end subroutine GFS_surface_composites_pre_finalize !! subroutine GFS_surface_composites_pre_run (im, flag_init, lkm, lsm, lsm_noahmp, lsm_ruc, frac_grid, & flag_cice, cplflx, cplwav2atm, landfrac, lakefrac, lakedepth, oceanfrac, frland, & - dry, icy, use_flake, ocean, wet, hice, cice, zorlo, zorll, zorli, & - snowd, snowd_wat, snowd_lnd, snowd_ice, tprcp, tprcp_wat, & + dry, icy, lake, use_flake, ocean, wet, hice, cice, zorlo, zorll, zorli, & + snowd, snowd_lnd, snowd_ice, tprcp, tprcp_wat, & tprcp_lnd, tprcp_ice, uustar, uustar_wat, uustar_lnd, uustar_ice, & - weasd, weasd_wat, weasd_lnd, weasd_ice, ep1d_ice, tsfc, tsfco, tsfcl, tsfc_wat, & + weasd, weasd_lnd, weasd_ice, ep1d_ice, tsfc, tsfco, tsfcl, tsfc_wat, & tsfc_lnd, tsfc_ice, tisfc, tice, tsurf_wat, tsurf_lnd, tsurf_ice, & gflx_ice, tgice, islmsk, islmsk_cice, slmsk, semis_rad, semis_wat, semis_lnd, semis_ice, & emis_lnd, emis_ice, qss, qss_wat, qss_lnd, qss_ice, hflx, hflx_wat, hflx_lnd, hflx_ice, & - min_lakeice, min_seaice, errmsg, errflg) + min_lakeice, min_seaice, kdt, errmsg, errflg) implicit none ! Interface variables - integer, intent(in ) :: im, lkm + integer, intent(in ) :: im, lkm, kdt integer, intent(in ) :: lsm, lsm_noahmp, lsm_ruc logical, intent(in ) :: flag_init, frac_grid, cplflx, cplwav2atm logical, dimension(:), intent(inout) :: flag_cice - logical, dimension(:), intent(inout) :: dry, icy, use_flake, ocean, wet + logical, dimension(:), intent(inout) :: dry, icy, lake, use_flake, ocean, wet real(kind=kind_phys), dimension(:), intent(in ) :: landfrac, lakefrac, lakedepth, oceanfrac real(kind=kind_phys), dimension(:), intent(inout) :: cice, hice real(kind=kind_phys), dimension(:), intent( out) :: frland real(kind=kind_phys), dimension(:), intent(in ) :: snowd, tprcp, uustar, weasd, qss, hflx real(kind=kind_phys), dimension(:), intent(inout) :: tsfc, tsfco, tsfcl, tisfc - real(kind=kind_phys), dimension(:), intent(inout) :: snowd_wat, snowd_lnd, snowd_ice, tprcp_wat, & + real(kind=kind_phys), dimension(:), intent(inout) :: snowd_lnd, snowd_ice, tprcp_wat, & tprcp_lnd, tprcp_ice, tsfc_wat, tsfc_lnd, tsfc_ice, tsurf_wat,tsurf_lnd, tsurf_ice, & - uustar_wat, uustar_lnd, uustar_ice, weasd_wat, weasd_lnd, weasd_ice, & + uustar_wat, uustar_lnd, uustar_ice, weasd_lnd, weasd_ice, & qss_wat, qss_lnd, qss_ice, hflx_wat, hflx_lnd, hflx_ice, ep1d_ice, gflx_ice real(kind=kind_phys), dimension(:), intent( out) :: tice real(kind=kind_phys), intent(in ) :: tgice @@ -68,6 +68,8 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, lkm, lsm, lsm_noahmp, ! real(kind=kind_phys), parameter :: timin = 173.0_kind_phys ! minimum temperature allowed for snow/ice + real(kind=kind_phys) :: tem + ! CCPP error handling character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -93,6 +95,7 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, lkm, lsm, lsm_noahmp, flag_cice(i) = .true. else islmsk_cice(i) = 2 + flag_cice(i) = .false. endif islmsk(i) = 2 else @@ -101,6 +104,7 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, lkm, lsm, lsm_noahmp, flag_cice(i) = .false. islmsk_cice(i) = 0 islmsk(i) = 0 + icy(i) = .false. endif if (cice(i) < one) then wet(i) = .true. ! some open ocean @@ -108,15 +112,17 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, lkm, lsm, lsm_noahmp, endif else if (cice(i) >= min_lakeice) then - icy(i) = .true. + icy(i) = .true. islmsk(i) = 2 - tisfc(i) = max(timin, min(tisfc(i), tgice)) + tisfc(i) = max(timin, min(tisfc(i), tgice)) else cice(i) = zero hice(i) = zero islmsk(i) = 0 + icy(i) = .false. endif islmsk_cice(i) = islmsk(i) + flag_cice(i) = .false. if (cice(i) < one) then wet(i) = .true. ! some open lake if (icy(i)) tsfco(i) = max(tisfc(i), tgice) @@ -127,6 +133,9 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, lkm, lsm, lsm_noahmp, hice(i) = zero islmsk_cice(i) = 1 islmsk(i) = 1 + wet(i) = .false. + icy(i) = .false. + flag_cice(i) = .false. endif enddo @@ -139,18 +148,28 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, lkm, lsm, lsm_noahmp, frland(i) = one cice(i) = zero hice(i) = zero + icy(i) = .false. else frland(i) = zero if (oceanfrac(i) > zero) then if (cice(i) >= min_seaice) then icy(i) = .true. tisfc(i) = max(timin, min(tisfc(i), tgice)) + if (cplflx) then + islmsk_cice(i) = 4 + flag_cice(i) = .true. + else + islmsk_cice(i) = 2 + flag_cice(i) = .false. + endif + islmsk(i) = 2 else cice(i) = zero hice(i) = zero flag_cice(i) = .false. islmsk(i) = 0 islmsk_cice(i) = 0 + icy(i) = .false. endif if (cice(i) < one) then wet(i) = .true. ! some open ocean @@ -160,13 +179,15 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, lkm, lsm, lsm_noahmp, if (cice(i) >= min_lakeice) then icy(i) = .true. tisfc(i) = max(timin, min(tisfc(i), tgice)) + islmsk(i) = 2 else cice(i) = zero hice(i) = zero - flag_cice(i) = .false. islmsk(i) = 0 + icy(i) = .false. endif islmsk_cice(i) = islmsk(i) + flag_cice(i) = .false. if (cice(i) < one) then wet(i) = .true. ! some open lake if (icy(i)) tsfco(i) = max(tisfc(i), tgice) @@ -184,21 +205,11 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, lkm, lsm, lsm_noahmp, uustar_wat(i) = uustar(i) tsfc_wat(i) = tsfco(i) tsurf_wat(i) = tsfco(i) -! weasd_wat(i) = weasd(i) -! snowd_wat(i) = snowd(i) - weasd_wat(i) = zero - snowd_wat(i) = zero !-- reference emiss value for surface emissivity in setemis ! 1-open water, 2-grass/shrub land, 3-bare soil, tundra, ! 4-sandy desert, 5-rocky desert, 6-forest, 7-ice, 8-snow !data emsref / 0.97, 0.95, 0.94, 0.90, 0.93, 0.96, 0.96, 0.99 / - if(iemsflg == 2) then semis_wat(i) = 0.97_kind_phys ! consistent with setemis - else - semis_wat(i) = 0.984_kind_phys - endif - qss_wat(i) = qss(i) - hflx_wat(i) = hflx(i) ! DH* else zorlo(i) = huge @@ -209,26 +220,22 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, lkm, lsm, lsm_noahmp, weasd_lnd(i) = weasd(i) tsfc_lnd(i) = tsfcl(i) tsurf_lnd(i) = tsfcl(i) - snowd_lnd(i) = snowd(i) if (iemsflg == 2 .and. .not. flag_init) then !-- use land emissivity from the LSM semis_lnd(i) = emis_lnd(i) else semis_lnd(i) = semis_rad(i) endif - qss_lnd(i) = qss(i) - hflx_lnd(i) = hflx(i) ! DH* else zorll(i) = huge ! *DH - end if + endif if (icy(i)) then ! Ice uustar_ice(i) = uustar(i) weasd_ice(i) = weasd(i) tsfc_ice(i) = tisfc(i) tsurf_ice(i) = tisfc(i) - snowd_ice(i) = snowd(i) ep1d_ice(i) = zero gflx_ice(i) = zero if (iemsflg == 2 .and. .not. flag_init .and. lsm == lsm_ruc) then @@ -237,28 +244,65 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, lkm, lsm, lsm_noahmp, else semis_ice(i) = 0.95_kind_phys endif - qss_ice(i) = qss(i) - hflx_ice(i) = hflx(i) ! DH* else zorli(i) = huge ! *DH - end if + endif if (nint(slmsk(i)) /= 1) slmsk(i) = islmsk(i) enddo ! to prepare to separate lake from ocean under water category do i = 1, im - if(wet(i) .and. lkm == 1) then - if(lakefrac(i) >= 0.15 .and. lakedepth(i) > one) then - use_flake(i) = .true. - else - use_flake(i) = .false. - endif + if(wet(i) .and. lakefrac(i) > zero) then + lake(i) = .true. + if (lkm == 1 .and. lakefrac(i) >= 0.15 .and. lakedepth(i) > one) then + use_flake(i) = .true. + else + use_flake(i) = .false. + endif else - use_flake(i) = .false. + lake(i) = .false. + use_flake(i) = .false. endif enddo +! + if (.not. cplflx .or. kdt == 1) then + if (frac_grid) then + do i=1,im + if (dry(i)) then + if (icy(i)) then + tem = one / (cice(i)*(one-frland(i))) + snowd_ice(i) = max(zero, (snowd(i) - snowd_lnd(i)*frland(i)) * tem) + weasd_ice(i) = max(zero, (weasd(i) - weasd_lnd(i)*frland(i)) * tem) + endif + elseif (icy(i)) then + tem = one / cice(i) + snowd_lnd(i) = zero + snowd_ice(i) = snowd(i) * tem + weasd_lnd(i) = zero + weasd_ice(i) = weasd(i) * tem + endif + enddo + else + do i=1,im + if (dry(i)) then + snowd_lnd(i) = snowd(i) + weasd_lnd(i) = weasd(i) + snowd_ice(i) = zero + weasd_ice(i) = zero + elseif (icy(i)) then + snowd_lnd(i) = zero + weasd_lnd(i) = zero + tem = one / cice(i) + snowd_ice(i) = snowd(i) * tem + weasd_ice(i) = weasd(i) * tem + endif + enddo + endif + endif + +! write(0,*)' minmax of ice snow=',minval(snowd_ice),maxval(snowd_ice) ! Assign sea ice temperature to interstitial variable do i = 1, im @@ -380,7 +424,7 @@ subroutine GFS_surface_composites_post_run ( stress_ice, ffmm, ffmm_wat, ffmm_lnd, ffmm_ice, ffhh, ffhh_wat, ffhh_lnd, ffhh_ice, uustar, uustar_wat, uustar_lnd, & uustar_ice, fm10, fm10_wat, fm10_lnd, fm10_ice, fh2, fh2_wat, fh2_lnd, fh2_ice, tsurf_wat, tsurf_lnd, tsurf_ice, & cmm, cmm_wat, cmm_lnd, cmm_ice, chh, chh_wat, chh_lnd, chh_ice, gflx, gflx_wat, gflx_lnd, gflx_ice, ep1d, ep1d_wat, & - ep1d_lnd, ep1d_ice, weasd, weasd_wat, weasd_lnd, weasd_ice, snowd, snowd_wat, snowd_lnd, snowd_ice, tprcp, tprcp_wat, & + ep1d_lnd, ep1d_ice, weasd, weasd_lnd, weasd_ice, snowd, snowd_lnd, snowd_ice, tprcp, tprcp_wat, & tprcp_lnd, tprcp_ice, evap, evap_wat, evap_lnd, evap_ice, hflx, hflx_wat, hflx_lnd, hflx_ice, qss, qss_wat, qss_lnd, & qss_ice, tsfc, tsfco, tsfcl, tsfc_wat, tsfc_lnd, tsfc_ice, tisfc, tice, hice, cice, min_seaice, tiice, stc, & grav, prsik1, prslk1, prslki, z1, ztmax_wat, ztmax_lnd, ztmax_ice, errmsg, errflg) @@ -395,8 +439,8 @@ subroutine GFS_surface_composites_post_run ( cd_wat, cd_lnd, cd_ice, cdq_wat, cdq_lnd, cdq_ice, rb_wat, rb_lnd, rb_ice, stress_wat, & stress_lnd, stress_ice, ffmm_wat, ffmm_lnd, ffmm_ice, ffhh_wat, ffhh_lnd, ffhh_ice, uustar_wat, uustar_lnd, uustar_ice, & fm10_wat, fm10_lnd, fm10_ice, fh2_wat, fh2_lnd, fh2_ice, tsurf_wat, tsurf_lnd, tsurf_ice, cmm_wat, cmm_lnd, cmm_ice, & - chh_wat, chh_lnd, chh_ice, gflx_wat, gflx_lnd, gflx_ice, ep1d_wat, ep1d_lnd, ep1d_ice, weasd_wat, weasd_lnd, weasd_ice, & - snowd_wat, snowd_lnd, snowd_ice,tprcp_wat, tprcp_lnd, tprcp_ice, evap_wat, evap_lnd, evap_ice, hflx_wat, hflx_lnd, & + chh_wat, chh_lnd, chh_ice, gflx_wat, gflx_lnd, gflx_ice, ep1d_wat, ep1d_lnd, ep1d_ice, weasd_lnd, weasd_ice, & + snowd_lnd, snowd_ice, tprcp_wat, tprcp_lnd, tprcp_ice, evap_wat, evap_lnd, evap_ice, hflx_wat, hflx_lnd, & hflx_ice, qss_wat, qss_lnd, qss_ice, tsfc_wat, tsfc_lnd, tsfc_ice, zorlo, zorll, zorli real(kind=kind_phys), dimension(:), intent(inout) :: zorl, cd, cdq, rb, stress, ffmm, ffhh, uustar, fm10, & @@ -443,17 +487,22 @@ subroutine GFS_surface_composites_post_run ( !gflx(i) = txl*gflx_lnd(i) + txi*gflx_ice(i) + txo*gflx_wat(i) ep1d(i) = txl*ep1d_lnd(i) + txi*ep1d_ice(i) + txo*ep1d_wat(i) - !weasd(i) = txl*weasd_lnd(i) + txi*weasd_ice(i) + txo*weasd_wat(i) - !snowd(i) = txl*snowd_lnd(i) + txi*snowd_ice(i) + txo*snowd_wat(i) weasd(i) = txl*weasd_lnd(i) + txi*weasd_ice(i) snowd(i) = txl*snowd_lnd(i) + txi*snowd_ice(i) !tprcp(i) = txl*tprcp_lnd(i) + txi*tprcp_ice(i) + txo*tprcp_wat(i) - if (.not. flag_cice(i) .and. islmsk(i) == 2) then - evap(i) = txl*evap_lnd(i) + wfrac*evap_ice(i) - hflx(i) = txl*hflx_lnd(i) + wfrac*hflx_ice(i) - qss(i) = txl*qss_lnd(i) + wfrac*qss_ice(i) - gflx(i) = txl*gflx_lnd(i) + wfrac*gflx_ice(i) + if (.not. flag_cice(i)) then + if (islmsk(i) == 2) then + evap(i) = txl*evap_lnd(i) + wfrac*evap_ice(i) + hflx(i) = txl*hflx_lnd(i) + wfrac*hflx_ice(i) + qss(i) = txl*qss_lnd(i) + wfrac*qss_ice(i) + gflx(i) = txl*gflx_lnd(i) + wfrac*gflx_ice(i) + else + evap(i) = txl*evap_lnd(i) + wfrac*evap_wat(i) + hflx(i) = txl*hflx_lnd(i) + wfrac*hflx_wat(i) + qss(i) = txl*qss_lnd(i) + wfrac*qss_wat(i) + gflx(i) = txl*gflx_lnd(i) + wfrac*gflx_wat(i) + endif else evap(i) = txl*evap_lnd(i) + txi*evap_ice(i) + txo*evap_wat(i) hflx(i) = txl*hflx_lnd(i) + txi*hflx_ice(i) + txo*hflx_wat(i) @@ -606,7 +655,6 @@ subroutine GFS_surface_composites_post_run ( ep1d(i) = ep1d_lnd(i) weasd(i) = weasd_lnd(i) snowd(i) = snowd_lnd(i) - !tprcp(i) = tprcp_lnd(i) evap(i) = evap_lnd(i) hflx(i) = hflx_lnd(i) qss(i) = qss_lnd(i) @@ -631,9 +679,8 @@ subroutine GFS_surface_composites_post_run ( chh(i) = chh_wat(i) gflx(i) = gflx_wat(i) ep1d(i) = ep1d_wat(i) - weasd(i) = weasd_wat(i) - snowd(i) = snowd_wat(i) - !tprcp(i) = tprcp_wat(i) + weasd(i) = zero + snowd(i) = zero evap(i) = evap_wat(i) hflx(i) = hflx_wat(i) qss(i) = qss_wat(i) @@ -654,21 +701,17 @@ subroutine GFS_surface_composites_post_run ( chh(i) = chh_ice(i) gflx(i) = gflx_ice(i) ep1d(i) = ep1d_ice(i) - weasd(i) = weasd_ice(i) - snowd(i) = snowd_ice(i) - !tprcp(i) = cice(i)*tprcp_ice(i) + (one-cice(i))*tprcp_wat(i) + weasd(i) = weasd_ice(i) * cice(i) + snowd(i) = snowd_ice(i) * cice(i) qss(i) = qss_ice(i) tsfc(i) = tsfc_ice(i) evap(i) = evap_ice(i) hflx(i) = hflx_ice(i) - qss(i) = qss_ice(i) - tisfc(i) = tice(i) - if (.not. flag_cice(i)) then -! tisfc(i) = tice(i) ! over lake ice (and sea ice when uncoupled) - zorl(i) = cice(i) * zorli(i) + (one - cice(i)) * zorlo(i) - tsfc(i) = tsfc_ice(i) ! over lake (and ocean when uncoupled) - elseif (wet(i)) then - if (cice(i) >= min_seaice) then ! this was already done for lake ice in sfc_sice + tisfc(i) = tice(i) ! over lake ice (and sea ice when uncoupled) + tsfc(i) = tsfc_ice(i) ! over lake (and ocean when uncoupled) +! + if (flag_cice(i)) then + if (wet(i) .and. cice(i) >= min_seaice) then ! this was already done for lake ice in sfc_sice txi = cice(i) txo = one - txi evap(i) = txi * evap_ice(i) + txo * evap_wat(i) @@ -677,17 +720,12 @@ subroutine GFS_surface_composites_post_run ( stress(i) = txi * stress_ice(i) + txo * stress_wat(i) qss(i) = txi * qss_ice(i) + txo * qss_wat(i) ep1d(i) = txi * ep1d_ice(i) + txo * ep1d_wat(i) - zorl(i) = txi * zorli(i) + txo * zorlo(i) - else - evap(i) = evap_wat(i) - hflx(i) = hflx_wat(i) - tsfc(i) = tsfc_wat(i) - stress(i) = stress_wat(i) - qss(i) = qss_wat(i) - ep1d(i) = ep1d_wat(i) - zorl(i) = zorlo(i) + zorl(i) = exp(txi*log(zorli(i)) + txo*log(zorlo(i))) endif + elseif (wet(i)) then ! return updated lake ice thickness & concentration to global array + zorl(i) = exp(cice(i)*log(zorli(i)) + (one-cice(i))*log(zorlo(i))) endif +! if (wet(i)) then tsfco(i) = tsfc_wat(i) else @@ -696,7 +734,7 @@ subroutine GFS_surface_composites_post_run ( tsfcl(i) = tsfc(i) do k=1,min(kice,km) ! store tiice in stc to reduce output in the nonfrac grid case stc(i,k) = tiice(i,k) - end do + enddo endif enddo diff --git a/physics/GFS_surface_composites.meta b/physics/GFS_surface_composites.meta index 95f2c6e4e..08f66fe2f 100644 --- a/physics/GFS_surface_composites.meta +++ b/physics/GFS_surface_composites.meta @@ -148,7 +148,7 @@ type = logical intent = inout optional = F -[use_flake] +[lake] standard_name = flag_nonzero_lake_surface_fraction long_name = flag indicating presence of some lake surface area fraction units = flag @@ -156,6 +156,14 @@ type = logical intent = inout optional = F +[use_flake] + standard_name = flag_for_using_flake + long_name = flag indicating lake points using flake model + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = inout + optional = F [ocean] standard_name = flag_nonzero_ocean_surface_fraction long_name = flag indicating presence of some ocean surface area fraction @@ -226,15 +234,6 @@ kind = kind_phys intent = in optional = F -[snowd_wat] - standard_name = surface_snow_thickness_water_equivalent_over_water - long_name = water equivalent snow depth over water - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F [snowd_lnd] standard_name = surface_snow_thickness_water_equivalent_over_land long_name = water equivalent snow depth over land @@ -334,15 +333,6 @@ kind = kind_phys intent = in optional = F -[weasd_wat] - standard_name = water_equivalent_accumulated_snow_depth_over_water - long_name = water equiv of acc snow depth over water - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F [weasd_lnd] standard_name = water_equivalent_accumulated_snow_depth_over_land long_name = water equiv of acc snow depth over land @@ -656,6 +646,14 @@ kind = kind_phys intent = in optional = F +[kdt] + standard_name = index_of_time_step + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -1551,15 +1549,6 @@ kind = kind_phys intent = inout optional = F -[weasd_wat] - standard_name = water_equivalent_accumulated_snow_depth_over_water - long_name = water equiv of acc snow depth over water - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F [weasd_lnd] standard_name = water_equivalent_accumulated_snow_depth_over_land long_name = water equiv of acc snow depth over land @@ -1587,15 +1576,6 @@ kind = kind_phys intent = inout optional = F -[snowd_wat] - standard_name = surface_snow_thickness_water_equivalent_over_water - long_name = water equivalent snow depth over water - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F [snowd_lnd] standard_name = surface_snow_thickness_water_equivalent_over_land long_name = water equivalent snow depth over land diff --git a/physics/GFS_surface_generic.F90 b/physics/GFS_surface_generic.F90 index 9fa75dea1..a4bf92543 100644 --- a/physics/GFS_surface_generic.F90 +++ b/physics/GFS_surface_generic.F90 @@ -31,7 +31,7 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, drain_cpl, dsnow_cpl, rain_cpl, snow_cpl, lndp_type, n_var_lndp, sfc_wts, & lndp_var_list, lndp_prt_list, & z01d, zt1d, bexp1d, xlai1d, vegf1d, lndp_vgf, sfc_wts_inv, & - cplflx, flag_cice, islmsk_cice, slimskin_cpl, tisfc, tsfco, fice, hice, & + cplflx, flag_cice, islmsk_cice, slimskin_cpl, & wind, u1, v1, cnvwind, smcwlt2, smcref2, errmsg, errflg) use surface_perturbation, only: cdfnor @@ -56,8 +56,7 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, real(kind=kind_phys), dimension(:), intent(out) :: dsnow_cpl real(kind=kind_phys), dimension(:), intent(in) :: rain_cpl real(kind=kind_phys), dimension(:), intent(in) :: snow_cpl - integer, intent(in) :: lndp_type - integer, intent(in) :: n_var_lndp + integer, intent(in) :: lndp_type, n_var_lndp character(len=3), dimension(:), intent(in) :: lndp_var_list real(kind=kind_phys), dimension(:), intent(in) :: lndp_prt_list real(kind=kind_phys), dimension(:,:), intent(in) :: sfc_wts @@ -67,21 +66,19 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, real(kind=kind_phys), dimension(:), intent(out) :: xlai1d real(kind=kind_phys), dimension(:), intent(out) :: vegf1d real(kind=kind_phys), intent(out) :: lndp_vgf - real(kind=kind_phys), dimension(:,:), intent(inout) :: sfc_wts_inv + real(kind=kind_phys), dimension(:,:), intent(inout) :: sfc_wts_inv - logical, intent(in) :: cplflx - real(kind=kind_phys), dimension(:), intent(in) :: slimskin_cpl - logical, dimension(:), intent(inout) :: flag_cice - integer, dimension(:), intent(out) :: islmsk_cice - real(kind=kind_phys), dimension(:), intent(in) :: & - tisfc, tsfco, fice, hice + logical, intent(in) :: cplflx + real(kind=kind_phys), dimension(:), intent(in) :: slimskin_cpl + logical, dimension(:), intent(inout) :: flag_cice + integer, dimension(:), intent(out) :: islmsk_cice - real(kind=kind_phys), dimension(:), intent(out) :: wind - real(kind=kind_phys), dimension(:), intent(in ) :: u1, v1 + real(kind=kind_phys), dimension(:), intent(out) :: wind + real(kind=kind_phys), dimension(:), intent(in ) :: u1, v1 ! surface wind enhancement due to convection - real(kind=kind_phys), dimension(:), intent(inout ) :: cnvwind + real(kind=kind_phys), dimension(:), intent(inout ) :: cnvwind ! - real(kind=kind_phys), dimension(:), intent(out) :: smcwlt2, smcref2 + real(kind=kind_phys), dimension(:), intent(out) :: smcwlt2, smcref2 ! CCPP error handling character(len=*), intent(out) :: errmsg @@ -89,8 +86,7 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, ! Local variables integer :: i, k - real(kind=kind_phys) :: onebg - real(kind=kind_phys) :: cdfz + real(kind=kind_phys) :: onebg, cdfz ! Set constants onebg = 1.0/con_g @@ -99,7 +95,6 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, errmsg = '' errflg = 0 - ! Scale random patterns for surface perturbations with perturbation size ! Turn vegetation fraction pattern into percentile pattern lndp_vgf=-999. @@ -108,25 +103,25 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, sfc_wts_inv(:,:)=sfc_wts(:,:) endif if (lndp_type==1) then - do k =1,n_var_lndp - select case(lndp_var_list(k)) - case ('rz0') + do k =1,n_var_lndp + select case(lndp_var_list(k)) + case ('rz0') z01d(:) = lndp_prt_list(k)* sfc_wts(:,k) - case ('rzt') - zt1d(:) = lndp_prt_list(k)* sfc_wts(:,k) - case ('shc') - bexp1d(:) = lndp_prt_list(k) * sfc_wts(:,k) - case ('lai') + case ('rzt') + zt1d(:) = lndp_prt_list(k)* sfc_wts(:,k) + case ('shc') + bexp1d(:) = lndp_prt_list(k) * sfc_wts(:,k) + case ('lai') xlai1d(:) = lndp_prt_list(k)* sfc_wts(:,k) - case ('vgf') + case ('vgf') ! note that the pertrubed vegfrac is being used in sfc_drv, but not sfc_diff do i=1,im call cdfnor(sfc_wts(i,k),cdfz) vegf1d(i) = cdfz enddo lndp_vgf = lndp_prt_list(k) - end select - enddo + end select + enddo endif ! End of stochastic physics / surface perturbation @@ -136,20 +131,20 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, islmsk_cice(i) = islmsk(i) if (islmsk(i) == 2) then if (isot == 1) then - soiltyp(i) = 16 + soiltyp(i) = 16 else - soiltyp(i) = 9 + soiltyp(i) = 9 endif if (ivegsrc == 0 .or. ivegsrc == 4) then - vegtype(i) = 24 + vegtype(i) = 24 elseif (ivegsrc == 1) then - vegtype(i) = 15 + vegtype(i) = 15 elseif (ivegsrc == 2) then - vegtype(i) = 13 + vegtype(i) = 13 elseif (ivegsrc == 3 .or. ivegsrc == 5) then - vegtype(i) = 15 + vegtype(i) = 15 endif - slopetyp(i) = 9 + slopetyp(i) = 9 else soiltyp(i) = int( stype(i)+0.5_kind_phys ) vegtype(i) = int( vtype(i)+0.5_kind_phys ) @@ -167,9 +162,9 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, wind(i) = max(sqrt(u1(i)*u1(i) + v1(i)*v1(i)) & + max(zero, min(cnvwind(i), 30.0_kind_phys)), one) - !wind(i) = max(sqrt(Statein%ugrs(i,1)*Statein%ugrs(i,1) + & - ! Statein%vgrs(i,1)*Statein%vgrs(i,1)) & - ! + max(zero, min(Tbd%phy_f2d(i,Model%num_p2d), 30.0)), one) + !wind(i) = max(sqrt(Statein%ugrs(i,1)*Statein%ugrs(i,1) + & + ! Statein%vgrs(i,1)*Statein%vgrs(i,1)) & + ! + max(zero, min(Tbd%phy_f2d(i,Model%num_p2d), 30.0)), one) cnvwind(i) = zero enddo @@ -316,7 +311,7 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplchm, cplwav, lssav, icy, do i=1,im ! if (Sfcprop%landfrac(i) < one) then ! Not 100% land - if (wet(i)) then ! some open water + if (wet(i)) then ! some open water ! --- compute open water albedo xcosz_loc = max( zero, min( one, xcosz(i) )) ocalnirdf_cpl = 0.06_kind_phys @@ -374,20 +369,20 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplchm, cplwav, lssav, icy, do i=1,im hflxq(i) = hflx(i) evapq(i) = evap(i) - hffac(i) = 1.0 - hefac(i) = 1.0 + hffac(i) = one + hefac(i) = one enddo if (lheatstrg) then do i=1,im - tem = 0.01 * zorl(i) ! change unit from cm to m + tem = 0.01_kind_phys * zorl(i) ! change unit from cm to m tem1 = (tem - z0min) / (z0max - z0min) - hffac(i) = z0fac * min(max(tem1, 0.0), 1.0) - tem = sqrt(u10m(i)**2+v10m(i)**2) + hffac(i) = z0fac * min(max(tem1, zero), one) + tem = sqrt(u10m(i)*u10m(i)+v10m(i)*v10m(i)) tem1 = (tem - u10min) / (u10max - u10min) - tem2 = 1.0 - min(max(tem1, 0.0), 1.0) + tem2 = one - min(max(tem1, zero), one) hffac(i) = tem2 * hffac(i) - hefac(i) = 1. + e0fac * hffac(i) - hffac(i) = 1. + hffac(i) + hefac(i) = one + e0fac * hffac(i) + hffac(i) = one + hffac(i) hflxq(i) = hflx(i) / hffac(i) evapq(i) = evap(i) / hefac(i) enddo diff --git a/physics/GFS_surface_generic.meta b/physics/GFS_surface_generic.meta index a28890079..893d07dd4 100644 --- a/physics/GFS_surface_generic.meta +++ b/physics/GFS_surface_generic.meta @@ -190,7 +190,7 @@ optional = F [dsnow_cpl] standard_name = tendency_of_lwe_thickness_of_snow_amount_for_coupling - long_name = change in show_cpl (coupling_type) + long_name = change in snow_cpl (coupling_type) units = m dimensions = (horizontal_loop_extent) type = real @@ -354,42 +354,6 @@ kind = kind_phys intent = in optional = F -[tisfc] - standard_name = sea_ice_temperature - long_name = sea-ice surface temperature - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[tsfco] - standard_name = sea_surface_temperature - long_name = sea surface temperature - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[fice] - standard_name = sea_ice_concentration - long_name = sea-ice concentration [0,1] - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[hice] - standard_name = sea_ice_thickness - long_name = sea-ice thickness - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F [wind] standard_name = wind_speed_at_lowest_model_layer long_name = wind speed at lowest model level diff --git a/physics/GFS_time_vary_pre.fv3.F90 b/physics/GFS_time_vary_pre.fv3.F90 index 98ac6a07f..4b7648c38 100644 --- a/physics/GFS_time_vary_pre.fv3.F90 +++ b/physics/GFS_time_vary_pre.fv3.F90 @@ -66,7 +66,7 @@ end subroutine GFS_time_vary_pre_finalize !> \section arg_table_GFS_time_vary_pre_timestep_init Argument Table !! \htmlinclude GFS_time_vary_pre_timestep_init.html !! - subroutine GFS_time_vary_pre_timestep_init (jdat, idat, dtp, lkm, lsm, lsm_noahmp, nsswr, & + subroutine GFS_time_vary_pre_timestep_init (jdat, idat, dtp, nsswr, & nslwr, nhfrad, idate, debug, me, master, nscyc, sec, phour, zhour, fhour, & kdt, julian, yearlen, ipt, lprnt, lssav, lsswr, lslwr, solhr, errmsg, errflg) @@ -76,8 +76,7 @@ subroutine GFS_time_vary_pre_timestep_init (jdat, idat, dtp, lkm, lsm, lsm_noahm integer, intent(in) :: idate(:) integer, intent(in) :: jdat(:), idat(:) - integer, intent(in) :: lkm, lsm, lsm_noahmp, & - nsswr, nslwr, me, & + integer, intent(in) :: nsswr, nslwr, me, & master, nscyc, nhfrad logical, intent(in) :: debug real(kind=kind_phys), intent(in) :: dtp diff --git a/physics/GFS_time_vary_pre.fv3.meta b/physics/GFS_time_vary_pre.fv3.meta index 6266889aa..16a124c12 100644 --- a/physics/GFS_time_vary_pre.fv3.meta +++ b/physics/GFS_time_vary_pre.fv3.meta @@ -76,30 +76,6 @@ kind = kind_phys intent = in optional = F -[lkm] - standard_name = flag_for_lake_surface_scheme - long_name = flag for lake surface model - units = flag - dimensions = () - type = integer - intent = in - optional = F -[lsm] - standard_name = flag_for_land_surface_scheme - long_name = flag for land surface model - units = flag - dimensions = () - type = integer - intent = in - optional = F -[lsm_noahmp] - standard_name = flag_for_noahmp_land_surface_scheme - long_name = flag for NOAH MP land surface model - units = flag - dimensions = () - type = integer - intent = in - optional = F [nsswr] standard_name = number_of_timesteps_between_shortwave_radiation_calls long_name = number of timesteps between shortwave radiation calls diff --git a/physics/GFS_time_vary_pre.scm.F90 b/physics/GFS_time_vary_pre.scm.F90 index c9ee9f946..0c34ca735 100644 --- a/physics/GFS_time_vary_pre.scm.F90 +++ b/physics/GFS_time_vary_pre.scm.F90 @@ -65,7 +65,7 @@ end subroutine GFS_time_vary_pre_finalize !> \section arg_table_GFS_time_vary_pre_timestep_init Argument Table !! \htmlinclude GFS_time_vary_pre_timestep_init.html !! - subroutine GFS_time_vary_pre_timestep_init (jdat, idat, dtp, lsm, lsm_noahmp, nsswr, & + subroutine GFS_time_vary_pre_timestep_init (jdat, idat, dtp, nsswr, & nslwr, idate, debug, me, master, nscyc, sec, phour, zhour, fhour, kdt, & julian, yearlen, ipt, lprnt, lssav, lsswr, lslwr, solhr, errmsg, errflg) @@ -75,8 +75,7 @@ subroutine GFS_time_vary_pre_timestep_init (jdat, idat, dtp, lsm, lsm_noahmp, ns integer, intent(in) :: idate(:) integer, intent(in) :: jdat(:), idat(:) - integer, intent(in) :: lsm, lsm_noahmp, & - nsswr, nslwr, me, & + integer, intent(in) :: nsswr, nslwr, me, & master, nscyc logical, intent(in) :: debug real(kind=kind_phys), intent(in) :: dtp diff --git a/physics/GFS_time_vary_pre.scm.meta b/physics/GFS_time_vary_pre.scm.meta index 5033f7988..5b6648a96 100644 --- a/physics/GFS_time_vary_pre.scm.meta +++ b/physics/GFS_time_vary_pre.scm.meta @@ -76,22 +76,6 @@ kind = kind_phys intent = in optional = F -[lsm] - standard_name = flag_for_land_surface_scheme - long_name = flag for land surface model - units = flag - dimensions = () - type = integer - intent = in - optional = F -[lsm_noahmp] - standard_name = flag_for_noahmp_land_surface_scheme - long_name = flag for NOAH MP land surface model - units = flag - dimensions = () - type = integer - intent = in - optional = F [nsswr] standard_name = number_of_timesteps_between_shortwave_radiation_calls long_name = number of timesteps between shortwave radiation calls diff --git a/physics/aerinterp.F90 b/physics/aerinterp.F90 index 25472632f..dbcf73603 100644 --- a/physics/aerinterp.F90 +++ b/physics/aerinterp.F90 @@ -98,7 +98,7 @@ END SUBROUTINE read_aerdata ! !********************************************************************** SUBROUTINE read_aerdataf (iamin, iamax, jamin, jamax, & - me, master, iflip, idate, errmsg, errflg) + me, master, iflip, idate, errmsg, errflg) use machine, only: kind_phys, kind_io4, kind_io8 use aerclm_def use netcdf @@ -172,23 +172,23 @@ SUBROUTINE read_aerdataf (iamin, iamax, jamin, jamax, & call nf_get_var(ncid, varid, buffx) do j = jamin, jamax - do k = 1, levsaer + do k = 1, levsaer ! input is from toa to sfc - if ( iflip == 0 ) then ! data from toa to sfc - klev = k - else ! data from sfc to top - klev = ( levsw - k ) + 1 - endif - do i = iamin, iamax - aerin(i,j,k,ii,imon) = 1.d0*buffx(i,j,klev,1) - if(aerin(i,j,k,ii,imon)<0.or.aerin(i,j,k,ii,imon)>1.) then - aerin(i,j,k,ii,imon) = 1.e-15 - end if - enddo !i-loop (lon) - enddo !k-loop (lev) - enddo !j-loop (lat) - - ENDDO ! ii-loop (ntracaerm) + if ( iflip == 0 ) then ! data from toa to sfc + klev = k + else ! data from sfc to top + klev = ( levsw - k ) + 1 + endif + do i = iamin, iamax + aerin(i,j,k,ii,imon) = 1.d0*buffx(i,j,klev,1) + if(aerin(i,j,k,ii,imon) < 0 .or. aerin(i,j,k,ii,imon) > 1.) then + aerin(i,j,k,ii,imon) = 1.e-15 + endif + enddo !i-loop (lon) + enddo !k-loop (lev) + enddo !j-loop (lat) + + ENDDO ! ii-loop (ntracaerm) ! close the file call nf_close(ncid) @@ -199,7 +199,7 @@ SUBROUTINE read_aerdataf (iamin, iamax, jamin, jamax, & END SUBROUTINE read_aerdataf ! SUBROUTINE setindxaer(npts,dlat,jindx1,jindx2,ddy,dlon, & - iindx1,iindx2,ddx,me,master) + iindx1,iindx2,ddx,me,master) ! USE MACHINE, ONLY: kind_phys use aerclm_def, only: aer_lat, jaero=>latsaer, & @@ -257,16 +257,17 @@ END SUBROUTINE setindxaer !********************************************************************** ! SUBROUTINE aerinterpol(me,master,nthrds,npts,IDATE,FHOUR,jindx1,jindx2, & - ddy,iindx1,iindx2,ddx,lev,prsl,aerout) + ddy,iindx1,iindx2,ddx,lev,prsl,aerout) ! USE MACHINE, ONLY : kind_phys use aerclm_def implicit none integer i1,i2, iday,j,j1,j2,l,npts,nc,n1,n2,lev,k,i,ii - real(kind=kind_phys) fhour,temj, tx1, tx2,temi + real(kind=kind_phys) fhour,temj, tx1, tx2,temi, tem + real(kind=kind_phys), dimension(npts) :: temij,temiy,temjx,ddxy ! - integer JINDX1(npts), JINDX2(npts),iINDX1(npts),iINDX2(npts) + integer JINDX1(npts), JINDX2(npts), iINDX1(npts), iINDX2(npts) integer me,idate(4), master, nthrds integer IDAT(8),JDAT(8) ! @@ -279,16 +280,16 @@ SUBROUTINE aerinterpol(me,master,nthrds,npts,IDATE,FHOUR,jindx1,jindx2, & real(4) rinc4(5) integer w3kindreal,w3kindint ! - IDAT=0 - IDAT(1)=IDATE(4) - IDAT(2)=IDATE(2) - IDAT(3)=IDATE(3) - IDAT(5)=IDATE(1) - RINC=0. - RINC(2)=FHOUR + IDAT = 0 + IDAT(1) = IDATE(4) + IDAT(2) = IDATE(2) + IDAT(3) = IDATE(3) + IDAT(5) = IDATE(1) + RINC = 0. + RINC(2) = FHOUR call w3kind(w3kindreal,w3kindint) - if(w3kindreal==4) then - rinc4=rinc + if(w3kindreal == 4) then + rinc4 = rinc CALL W3MOVDAT(RINC4,IDAT,JDAT) else CALL W3MOVDAT(RINC,IDAT,JDAT) @@ -299,11 +300,11 @@ SUBROUTINE aerinterpol(me,master,nthrds,npts,IDATE,FHOUR,jindx1,jindx2, & jday = 0 call w3doxdat(jdat,jdow,jdoy,jday) rjday = jdoy + jdat(5) / 24. - IF (RJDAY .LT. aer_time(1)) RJDAY = RJDAY+365. + IF (RJDAY < aer_time(1)) RJDAY = RJDAY+365. ! n2 = 13 do j=2, 12 - if (rjday .lt. aer_time(j)) then + if (rjday < aer_time(j)) then n2 = j exit endif @@ -314,37 +315,45 @@ SUBROUTINE aerinterpol(me,master,nthrds,npts,IDATE,FHOUR,jindx1,jindx2, & tx2 = 1.0 - tx1 if (n2 > 12) n2 = n2 -12 + do j=1,npts + TEMJ = 1.0 - DDY(J) + TEMI = 1.0 - DDX(J) + temij(j) = TEMI*TEMJ + temiy(j) = TEMI*DDY(j) + temjx(j) = TEMJ*DDX(j) + ddxy(j) = DDX(j)*DDY(J) + enddo + #ifndef __GFORTRAN__ !$OMP parallel num_threads(nthrds) default(none) & !$OMP shared(npts,ntrcaer,aerin,aer_pres,prsl) & !$OMP shared(ddx,ddy,jindx1,jindx2,iindx1,iindx2) & !$OMP shared(aerpm,aerpres,aerout,n1,n2,lev,nthrds) & -!$OMP private(l,j,k,ii,i1,i2,j1,j2,temj,temi) & +!$OMP shared(temij,temiy,temjx,ddxy) & +!$OMP private(l,j,k,ii,i1,i2,j1,j2,tem) & !$OMP copyin(tx1,tx2) firstprivate(tx1,tx2) !$OMP do #endif DO L=1,levsaer DO J=1,npts - J1 = JINDX1(J) - J2 = JINDX2(J) - TEMJ = 1.0 - DDY(J) - I1 = IINDX1(J) - I2 = IINDX2(J) - TEMI = 1.0 - DDX(J) + J1 = JINDX1(J) + J2 = JINDX2(J) + I1 = IINDX1(J) + I2 = IINDX2(J) DO ii=1,ntrcaer - aerpm(j,L,ii) = & - tx1*(TEMI*TEMJ*aerin(I1,J1,L,ii,n1)+DDX(j)*DDY(J)*aerin(I2,J2,L,ii,n1)& - +TEMI*DDY(j)*aerin(I1,J2,L,ii,n1)+DDX(j)*TEMJ*aerin(I2,J1,L,ii,n1))& - +tx2*(TEMI*TEMJ*aerin(I1,J1,L,ii,n2)+DDX(j)*DDY(J)*aerin(I2,J2,L,ii,n2) & - +TEMI*DDY(j)*aerin(I1,J2,L,ii,n2)+DDX(j)*TEMJ*aerin(I2,J1,L,ii,n2)) + aerpm(j,L,ii) = & + tx1*(TEMIJ(j)*aerin(I1,J1,L,ii,n1)+DDXY(j)*aerin(I2,J2,L,ii,n1) & + +TEMIY(j)*aerin(I1,J2,L,ii,n1)+temjx(j)*aerin(I2,J1,L,ii,n1))& + +tx2*(TEMIJ(j)*aerin(I1,J1,L,ii,n2)+DDXY(j)*aerin(I2,J2,L,ii,n2) & + +TEMIY(j)*aerin(I1,J2,L,ii,n2)+temjx(j)*aerin(I2,J1,L,ii,n2)) ENDDO - aerpres(j,L) = & - tx1*(TEMI*TEMJ*aer_pres(I1,J1,L,n1)+DDX(j)*DDY(J)*aer_pres(I2,J2,L,n1)& - +TEMI*DDY(j)*aer_pres(I1,J2,L,n1)+DDX(j)*TEMJ*aer_pres(I2,J1,L,n1))& - +tx2*(TEMI*TEMJ*aer_pres(I1,J1,L,n2)+DDX(j)*DDY(J)*aer_pres(I2,J2,L,n2) & - +TEMI*DDY(j)*aer_pres(I1,J2,L,n2)+DDX(j)*TEMJ*aer_pres(I2,J1,L,n2)) + aerpres(j,L) = & + tx1*(TEMIJ(j)*aer_pres(I1,J1,L,n1)+DDXY(j)*aer_pres(I2,J2,L,n1) & + +TEMIY(j)*aer_pres(I1,J2,L,n1)+temjx(j)*aer_pres(I2,J1,L,n1))& + +tx2*(TEMIJ(j)*aer_pres(I1,J1,L,n2)+DDXY(j)*aer_pres(I2,J2,L,n2) & + +TEMIY(j)*aer_pres(I1,J2,L,n2)+temjx(j)*aer_pres(I2,J1,L,n2)) ENDDO ENDDO #ifndef __GFORTRAN__ @@ -355,28 +364,27 @@ SUBROUTINE aerinterpol(me,master,nthrds,npts,IDATE,FHOUR,jindx1,jindx2, & #endif DO J=1,npts DO L=1,lev - if(prsl(j,L).ge.aerpres(j,1)) then + if(prsl(j,L) >= aerpres(j,1)) then DO ii=1, ntrcaer - aerout(j,L,ii)=aerpm(j,1,ii) !! sfc level + aerout(j,L,ii) = aerpm(j,1,ii) !! sfc level ENDDO - else if(prsl(j,L).le.aerpres(j,levsaer)) then + else if(prsl(j,L) <= aerpres(j,levsaer)) then DO ii=1, ntrcaer - aerout(j,L,ii)=aerpm(j,levsaer,ii) !! toa top + aerout(j,L,ii) = aerpm(j,levsaer,ii) !! toa top ENDDO else DO k=1, levsaer-1 !! from sfc to toa - IF(prsl(j,L)aerpres(j,k+1)) then - i1=k - i2=min(k+1,levsaer) + IF(prsl(j,L) < aerpres(j,k) .and. prsl(j,L)>aerpres(j,k+1)) then + i1 = k + i2 = min(k+1,levsaer) exit ENDIF ENDDO - temi = prsl(j,L)-aerpres(j,i2) - temj = aerpres(j,i1) - prsl(j,L) - tx1 = temi/(aerpres(j,i1) - aerpres(j,i2)) - tx2 = temj/(aerpres(j,i1) - aerpres(j,i2)) + tem = 1.0 / (aerpres(j,i1) - aerpres(j,i2)) + tx1 = (prsl(j,L) - aerpres(j,i2)) * tem + tx2 = (aerpres(j,i1) - prsl(j,L)) * tem DO ii = 1, ntrcaer - aerout(j,L,ii)= aerpm(j,i1,ii)*tx1 + aerpm(j,i2,ii)*tx2 + aerout(j,L,ii) = aerpm(j,i1,ii)*tx1 + aerpm(j,i2,ii)*tx2 ENDDO endif ENDDO !L-loop diff --git a/physics/cs_conv.F90 b/physics/cs_conv.F90 index d47dcd457..8ed33f0d3 100644 --- a/physics/cs_conv.F90 +++ b/physics/cs_conv.F90 @@ -13,7 +13,7 @@ end subroutine cs_conv_pre_finalize !! \section arg_table_cs_conv_pre_run Argument Table !! \htmlinclude cs_conv_pre_run.html !! - subroutine cs_conv_pre_run(im, levs, ntrac, ncld, q, clw1, clw2, & + subroutine cs_conv_pre_run(im, levs, ntrac, q, clw1, clw2, & & work1, work2, cs_parm1, cs_parm2, wcbmax, & & fswtr, fscav, save_q1, save_q2, save_q3, & & errmsg, errflg) @@ -24,7 +24,7 @@ subroutine cs_conv_pre_run(im, levs, ntrac, ncld, q, clw1, clw2, & implicit none ! --- inputs - integer, intent(in) :: im, levs, ntrac, ncld + integer, intent(in) :: im, levs, ntrac real(kind_phys), dimension(:,:), intent(in) :: q real(kind_phys), dimension(:,:), intent(in) :: clw1,clw2 real(kind_phys), dimension(:), intent(in) :: work1, work2 diff --git a/physics/cs_conv.meta b/physics/cs_conv.meta index 14a0d5bf2..5766cc3c2 100644 --- a/physics/cs_conv.meta +++ b/physics/cs_conv.meta @@ -31,14 +31,6 @@ type = integer intent = in optional = F -[ncld] - standard_name = number_of_hydrometeors - long_name = number of hydrometeors - units = count - dimensions = () - type = integer - intent = in - optional = F [q] standard_name = water_vapor_specific_humidity_updated_by_physics long_name = water vapor specific humidity updated by physics diff --git a/physics/cs_conv_aw_adj.F90 b/physics/cs_conv_aw_adj.F90 index 74cac9184..4b54290bd 100644 --- a/physics/cs_conv_aw_adj.F90 +++ b/physics/cs_conv_aw_adj.F90 @@ -27,7 +27,7 @@ end subroutine cs_conv_aw_adj_finalize !! !\section gen_cs_conv_aw_adj_run CPT cs_conv_aw_adj_run General Algorithm subroutine cs_conv_aw_adj_run(im, levs, do_cscnv, do_aw, do_shoc, & - ntrac, ncld, ntcw, ntclamt, nncl, con_g, sigmafrac, & + ntrac, ntcw, ntclamt, nncl, con_g, sigmafrac, & gt0, gq0, save_t, save_q, prsi, cldfrac, subcldfrac, & prcp, imp_physics, imp_physics_mg, errmsg, errflg) @@ -38,7 +38,7 @@ subroutine cs_conv_aw_adj_run(im, levs, do_cscnv, do_aw, do_shoc, & ! --- interface variables integer, intent(in) :: im, levs logical, intent(in) :: do_cscnv, do_aw, do_shoc - integer, intent(in) :: ntrac, ncld, ntcw, ntclamt, nncl + integer, intent(in) :: ntrac, ntcw, ntclamt, nncl real(kind_phys), intent(in) :: con_g real(kind_phys), dimension(:,:), intent(inout) :: sigmafrac real(kind_phys), dimension(:,:), intent(inout) :: gt0 diff --git a/physics/cs_conv_aw_adj.meta b/physics/cs_conv_aw_adj.meta index 720330c50..b0b8e6244 100644 --- a/physics/cs_conv_aw_adj.meta +++ b/physics/cs_conv_aw_adj.meta @@ -55,14 +55,6 @@ type = integer intent = in optional = F -[ncld] - standard_name = number_of_hydrometeors - long_name = number of hydrometeors - units = count - dimensions = () - type = integer - intent = in - optional = F [ntcw] standard_name = index_for_liquid_cloud_condensate long_name = tracer index for cloud condensate (or liquid water) @@ -80,8 +72,8 @@ intent = in optional = F [nncl] - standard_name = number_of_tracers_for_cloud_condensate - long_name = number of tracers for cloud condensate + standard_name = number_of_cloud_condensate_types + long_name = number of cloud condensate types units = count dimensions = () type = integer diff --git a/physics/dcyc2.f b/physics/dcyc2.f index dfa9f02ed..154c4c798 100644 --- a/physics/dcyc2.f +++ b/physics/dcyc2.f @@ -178,7 +178,7 @@ subroutine dcyc2t3_run & & sfcnirbmu,sfcnirdfu,sfcvisbmu,sfcvisdfu, & & sfcnirbmd,sfcnirdfd,sfcvisbmd,sfcvisdfd, & & im, levs, deltim, fhswr, & - & dry, icy, wet, damp_LW_fluxadj, lfnc_k, lfnc_p0, & + & dry, icy, wet, & & minGPpres, use_LW_jacobian, sfculw, fluxlwUP_jac, & & t_lay, t_lev, p_lay, p_lev, flux2D_lwUP, flux2D_lwDOWN, & & pert_radtend, do_sppt,ca_global, & @@ -213,11 +213,10 @@ subroutine dcyc2t3_run & ! integer, intent(in) :: ipr ! logical lprnt logical, dimension(:), intent(in) :: dry, icy, wet - logical, intent(in) :: use_LW_jacobian, damp_LW_fluxadj, & - & pert_radtend + logical, intent(in) :: use_LW_jacobian, pert_radtend logical, intent(in) :: do_sppt,ca_global real(kind=kind_phys), intent(in) :: solhr, slag, cdec, sdec, & - & deltim, fhswr, minGPpres, lfnc_k, lfnc_p0 + & deltim, fhswr, minGPpres real(kind=kind_phys), dimension(:), intent(in) :: & & sinlat, coslat, xlon, coszen, tf, tsflw, sfcdlw, & @@ -254,19 +253,11 @@ subroutine dcyc2t3_run & integer, intent(out) :: errflg ! --- locals: - integer :: i, k, nstp, nstl, it, istsun(im),iSFC,iTOA + integer :: i, k, nstp, nstl, it, istsun(im),iSFC real(kind=kind_phys) :: cns, coszn, tem1, tem2, anginc, & & rstl, solang, dT real(kind=kind_phys), dimension(im,levs+1) :: flxlwup_adj, & & flxlwdn_adj, t_lev2 - real(kind=kind_phys) :: fluxlwnet_adj,fluxlwnet,dT_sfc, & - &fluxlwDOWN_jac,lfnc,c1 - ! Length scale for flux-adjustment scaling - real(kind=kind_phys), parameter :: & - & L = 1. - ! Scaling factor for downwelling LW Jacobian profile. - real(kind=kind_phys), parameter :: & - & gamma = 0.2 ! !===> ... begin here ! @@ -276,11 +267,9 @@ subroutine dcyc2t3_run & ! Vertical ordering? if (p_lev(1,1) .lt. p_lev(1, levs)) then - iSFC = levs + 1 - iTOA = 1 + iSFC = levs else iSFC = 1 - iTOA = levs + 1 endif tem1 = fhswr / deltim @@ -321,15 +310,15 @@ subroutine dcyc2t3_run & ! do i = 1, im - tem1 = tf(i) / tsflw(i) - tem2 = tem1 * tem1 - adjsfcdlw(i) = sfcdlw(i) * tem2 * tem2 !> - LW time-step adjustment: if (use_LW_Jacobian) then ! F_adj = F_o + (dF/dT) * dT dT = tf(i) - tsflw(i) adjsfculw(i) = sfculw(i) + fluxlwUP_jac(i,iSFC) * dT else + tem1 = tf(i) / tsflw(i) + tem2 = tem1 * tem1 + adjsfcdlw(i) = sfcdlw(i) * tem2 * tem2 !! - adjust \a sfc downward LW flux to account for t changes in the lowest model layer. !! compute 4th power of the ratio of \c tf in the lowest model layer over the mean value \c tsflw. if (dry(i)) then @@ -386,47 +375,32 @@ subroutine dcyc2t3_run & call cmp_tlev(im, levs, minGPpres, p_lay, t_lay, p_lev, tsfc, & & t_lev2) - ! Compute adjusted net LW flux foillowing Hogan and Bozzo 2015 (10.1002/2015MS000455) - ! Here we assume that the profile of the downwelling LW Jaconiam has the same shape - ! as the upwelling, but scaled and offset. - ! The scaling factor is 0.2 - ! The profile of the downwelling Jacobian (J) is offset so that - ! J_dn_sfc / J_up_sfc = scaling_factor - ! J_dn_toa / J_up_sfc = 0 ! - ! Optionally, the flux adjustment can be damped with height using a logistic function - ! fx ~ L / (1 + exp(-k*dp)), where dp = p - p0 - ! L = 1, fix scale between 0-1. - Fixed - ! k = 1 / pressure decay length (Pa) - Controlled by namelist - ! p0 = Transition pressure (Pa) - Controlled by namelsit - do i = 1, im - c1 = fluxlwUP_jac(i,iTOA) / fluxlwUP_jac(i,iSFC) - dT_sfc = t_lev2(i,iSFC) - t_lev(i,iSFC) - do k = 1, levs - ! LW net flux - fluxlwnet = (flux2D_lwUP(i, k+1) - flux2D_lwUP(i, k) - & - & flux2D_lwDOWN(i,k+1) + flux2D_lwDOWN(i,k)) - ! Downward LW Jacobian (Eq. 9) - fluxlwDOWN_jac = gamma * & - & (fluxlwUP_jac(i,k)/fluxlwUP_jac(i,iSFC) - c1) / & - & (1 - c1) - ! Adjusted LW net flux(Eq. 10) - fluxlwnet_adj = fluxlwnet + dT_sfc* & - & (fluxlwUP_jac(i,k)/fluxlwUP_jac(i,iSFC) - & - & fluxlwDOWN_jac) - ! Adjusted LW heating rate - htrlw(i,k) = fluxlwnet_adj * con_g / & - & (con_cp * (p_lev(i,k+1) - p_lev(i,k))) - - ! Add radiative heating rates to physics heating rate. Optionally, scaled w/ height - ! using a logistic function - if (damp_LW_fluxadj) then - lfnc = L / (1+exp(-(p_lev(i,k) - lfnc_p0)/lfnc_k)) - else - lfnc = 1. - endif - dtdt(i,k) = dtdt(i,k) + swh(i,k)*xmu(i) + & - & htrlw(i,k)*lfnc + (1.-lfnc)*hlw(i,k) + ! Adjust up/downward fluxes (at layer interfaces). + ! + do k = 1, levs+1 + do i = 1, im + dT = t_lev2(i,k) - t_lev(i,k) + flxlwup_adj(i,k) = flux2D_lwUP(i,k) + & + & fluxlwUP_jac(i,k)*dT + enddo + enddo + ! + ! Compute new heating rate (within each layer). + ! + do k = 1, levs + htrlw(1:im,k) = & + & (flxlwup_adj(1:im,k+1) - flxlwup_adj(1:im,k) - & + & flux2D_lwDOWN(1:im,k+1) + flux2D_lwDOWN(1:im,k)) * & + & con_g / (con_cp * (p_lev(1:im,k+1) - p_lev(1:im,k))) + enddo + + ! + ! Add radiative heating rates to physics heating rate + ! + do k = 1, levs + do i = 1, im + dtdt(i,k) = dtdt(i,k) + swh(i,k)*xmu(i) + htrlw(i,k) enddo enddo else diff --git a/physics/dcyc2.meta b/physics/dcyc2.meta index 91e01a2d2..a460db7ab 100644 --- a/physics/dcyc2.meta +++ b/physics/dcyc2.meta @@ -370,32 +370,6 @@ type = logical intent = in optional = F -[damp_LW_fluxadj] - standard_name = flag_to_damp_RRTMGP_LW_jacobian_flux_adjustment - long_name = logical flag to control RRTMGP LW calculation - units = flag - dimensions = () - type = logical - intent = in - optional = F -[lfnc_k] - standard_name = transition_pressure_length_scale_for_flux_damping - long_name = depth of transition layer in logistic function for LW flux adjustment damping - units = Pa - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[lfnc_p0] - standard_name = transition_pressure_for_flux_damping - long_name = transition pressure for LW flux adjustment damping - units = Pa - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F [sfculw] standard_name = surface_upwelling_longwave_flux_on_radiation_time_step long_name = total sky sfc upward lw flux diff --git a/physics/flake_driver.F90 b/physics/flake_driver.F90 index 1e8714461..94fe8286b 100644 --- a/physics/flake_driver.F90 +++ b/physics/flake_driver.F90 @@ -62,13 +62,13 @@ SUBROUTINE flake_driver_run ( & ! ! Declarations ! use module_flake_ini, only:flake_init - use module_FLake + use module_FLake ! use flake_albedo_ref ! use data_parameters ! use flake_derivedtypes -! use flake_paramoptic_ref +! use flake_paramoptic_ref ! use flake_parameters - use machine , only : kind_phys + use machine , only : kind_phys ! use funcphys, only : fpvs ! use physcons, only : grav => con_g, cp => con_cp, & ! & hvap => con_hvap, rd => con_rd, & @@ -76,10 +76,10 @@ SUBROUTINE flake_driver_run ( & ! & rvrdm1 => con_fvirt !============================================================================== -IMPLICIT NONE + implicit none integer, intent(in) :: im, imon,yearlen -! integer, dimension(im), intent(in) :: islmsk +! integer, dimension(im), intent(in) :: islmsk real (kind=kind_phys), dimension(:), intent(in) :: ps, wind, & & t1, q1, dlwflx, dswsfc, zlvl, elev @@ -91,7 +91,7 @@ SUBROUTINE flake_driver_run ( & real (kind=kind_phys),dimension(:),intent(inout) :: & & snwdph, hice, tsurf, t_sfc, hflx, evap, fice, ustar, qsfc, & - & ch, cm, chh, cmm + & ch, cm, chh, cmm real (kind=kind_phys), intent(in) :: julian @@ -116,184 +116,190 @@ SUBROUTINE flake_driver_run ( & h_ML , & ! Thickness of the mixed-layer [m] H_B1 , & ! Thickness of the upper layer of bottom sediments [m] w_albedo , & ! - w_extinc + w_extinc ! Input (procedure arguments) -REAL (KIND = kind_phys) :: & - - dMsnowdt_in , & ! The rate of snow accumulation [kg m^{-2} s^{-1}] - I_atm_in , & ! Solar radiation flux at the surface [W m^{-2}] - Q_atm_lw_in , & ! Long-wave radiation flux from the atmosphere [W m^{-2}] - height_u_in , & ! Height above the lake surface where the wind speed is measured [m] - height_tq_in , & ! Height where temperature and humidity are measured [m] - U_a_in , & ! Wind speed at z=height_u_in [m s^{-1}] - T_a_in , & ! Air temperature at z=height_tq_in [K] - q_a_in , & ! Air specific humidity at z=height_tq_in - P_a_in ! Surface air pressure [N m^{-2} = kg m^{-1} s^{-2}] - -REAL (KIND = kind_phys) :: & - depth_w , & ! The lake depth [m] - fetch_in , & ! Typical wind fetch [m] - depth_bs_in , & ! Depth of the thermally active layer of the bottom sediments [m] - T_bs_in , & ! Temperature at the outer edge of + REAL (KIND = kind_phys) :: & + + dMsnowdt_in , & ! The rate of snow accumulation [kg m^{-2} s^{-1}] + I_atm_in , & ! Solar radiation flux at the surface [W m^{-2}] + Q_atm_lw_in , & ! Long-wave radiation flux from the atmosphere [W m^{-2}] + height_u_in , & ! Height above the lake surface where the wind speed is measured [m] + height_tq_in , & ! Height where temperature and humidity are measured [m] + U_a_in , & ! Wind speed at z=height_u_in [m s^{-1}] + T_a_in , & ! Air temperature at z=height_tq_in [K] + q_a_in , & ! Air specific humidity at z=height_tq_in + P_a_in ! Surface air pressure [N m^{-2} = kg m^{-1} s^{-2}] + + REAL (KIND = kind_phys) :: & + depth_w , & ! The lake depth [m] + fetch_in , & ! Typical wind fetch [m] + depth_bs_in , & ! Depth of the thermally active layer of the bottom sediments [m] + T_bs_in , & ! Temperature at the outer edge of ! the thermally active layer of the bottom sediments [K] - par_Coriolis , & ! The Coriolis parameter [s^{-1}] - del_time ! The model time step [s] - -REAL (KIND = kind_phys) :: & - T_snow_in , & ! Temperature at the air-snow interface [K] - T_ice_in , & ! Temperature at the snow-ice or air-ice interface [K] - T_mnw_in , & ! Mean temperature of the water column [K] - T_wML_in , & ! Mixed-layer temperature [K] - T_bot_in , & ! Temperature at the water-bottom sediment interface [K] - T_B1_in , & ! Temperature at the bottom of the upper layer of the sediments [K] - C_T_in , & ! Shape factor (thermocline) - h_snow_in , & ! Snow thickness [m] - h_ice_in , & ! Ice thickness [m] - h_ML_in , & ! Thickness of the mixed-layer [m] - H_B1_in , & ! Thickness of the upper layer of bottom sediments [m] - T_sfc_in , & ! Surface temperature at the previous time step [K] - ch_in , & - cm_in , & - albedo_water , & - water_extinc - -REAL (KIND = kind_phys) :: & - T_snow_out , & ! Temperature at the air-snow interface [K] - T_ice_out , & ! Temperature at the snow-ice or air-ice interface [K] - T_mnw_out , & ! Mean temperature of the water column [K] - T_wML_out , & ! Mixed-layer temperature [K] - T_bot_out , & ! Temperature at the water-bottom sediment interface [K] - T_B1_out , & ! Temperature at the bottom of the upper layer of the sediments [K] - C_T_out , & ! Shape factor (thermocline) - h_snow_out , & ! Snow thickness [m] - h_ice_out , & ! Ice thickness [m] - h_ML_out , & ! Thickness of the mixed-layer [m] - H_B1_out , & ! Thickness of the upper layer of bottom sediments [m] - T_sfc_out , & ! surface temperature [K] - T_sfc_n , & ! Updated surface temperature [K] - u_star , & - q_sfc , & - chh_out , & - cmm_out - -REAL (KIND = kind_phys) :: & - Q_momentum , & ! Momentum flux [N m^{-2}] - Q_SHT_flx , & ! Sensible heat flux [W m^{-2}] - Q_LHT_flx , & ! Latent heat flux [W m^{-2}] - Q_watvap ! Flux of water vapour [kg m^{-2} s^{-1}] - -REAL (KIND = kind_phys) :: & - lake_depth_max, T_bot_2_in, T_bot_2_out, dxlat,tb,tr,tt,temp,Kbar, DelK - - -REAL (KIND = kind_phys) :: x, y !temperarory variables used for Tbot and Tsfc - !initilizations - -INTEGER :: i,ipr,iter - -LOGICAL :: lflk_botsed_use -logical :: flag(im) -CHARACTER(LEN=*), PARAMETER :: FMT2 = "(1x,8(F12.4,1x))" + par_Coriolis , & ! The Coriolis parameter [s^{-1}] + del_time ! The model time step [s] + + REAL (KIND = kind_phys) :: & + T_snow_in , & ! Temperature at the air-snow interface [K] + T_ice_in , & ! Temperature at the snow-ice or air-ice interface [K] + T_mnw_in , & ! Mean temperature of the water column [K] + T_wML_in , & ! Mixed-layer temperature [K] + T_bot_in , & ! Temperature at the water-bottom sediment interface [K] + T_B1_in , & ! Temperature at the bottom of the upper layer of the sediments [K] + C_T_in , & ! Shape factor (thermocline) + h_snow_in , & ! Snow thickness [m] + h_ice_in , & ! Ice thickness [m] + h_ML_in , & ! Thickness of the mixed-layer [m] + H_B1_in , & ! Thickness of the upper layer of bottom sediments [m] + T_sfc_in , & ! Surface temperature at the previous time step [K] + ch_in , & + cm_in , & + albedo_water , & + water_extinc + + REAL (KIND = kind_phys) :: & + T_snow_out , & ! Temperature at the air-snow interface [K] + T_ice_out , & ! Temperature at the snow-ice or air-ice interface [K] + T_mnw_out , & ! Mean temperature of the water column [K] + T_wML_out , & ! Mixed-layer temperature [K] + T_bot_out , & ! Temperature at the water-bottom sediment interface [K] + T_B1_out , & ! Temperature at the bottom of the upper layer of the sediments [K] + C_T_out , & ! Shape factor (thermocline) + h_snow_out , & ! Snow thickness [m] + h_ice_out , & ! Ice thickness [m] + h_ML_out , & ! Thickness of the mixed-layer [m] + H_B1_out , & ! Thickness of the upper layer of bottom sediments [m] + T_sfc_out , & ! surface temperature [K] + T_sfc_n , & ! Updated surface temperature [K] + u_star , & + q_sfc , & + chh_out , & + cmm_out + + REAL (KIND = kind_phys) :: & + Q_momentum , & ! Momentum flux [N m^{-2}] + Q_SHT_flx , & ! Sensible heat flux [W m^{-2}] + Q_LHT_flx , & ! Latent heat flux [W m^{-2}] + Q_watvap ! Flux of water vapour [kg m^{-2} s^{-1}] + + REAL (KIND = kind_phys) :: & + lake_depth_max, T_bot_2_in, T_bot_2_out, dxlat,tb,tr,tt,temp,temp2 + + real (kind=kind_phys), parameter :: pi=4.0_kind_phys*atan(1.0_kind_phys) + real (kind=kind_phys), parameter :: degrad=180.0_kind_phys/pi + real (kind=kind_phys), parameter :: Kbar = 3.5_kind_phys, DelK = 3.0_kind_phys, & + KbaroDelK = Kbar / DelK + + REAL (KIND = kind_phys) :: x, y !temperarory variables used for Tbot and Tsfc + !initilizations + + INTEGER :: i,ipr,iter + + LOGICAL :: lflk_botsed_use, do_flake + logical :: flag(im) +! CHARACTER(LEN=*), PARAMETER :: FMT2 = "(1x,8(F12.4,1x))" !============================================================================== ! Start calculations !------------------------------------------------------------------------------ -! FLake_write need to assign original value to make the model somooth - - lake_depth_max = 60.0 - ipr = min(im,10) +! FLake_write need to assign original value to make the model somooth ! --- ... set flag for lake points + do_flake = .false. do i = 1, im - flag(i) = (wet(i) .and. flag_iter(i)) + flag(i) = wet(i) .and. flag_iter(i) .and. use_flake(i) + do_flake = flag(i) .or. do_flake enddo - Kbar=3.5 - DelK=3.0 + if (.not. do_flake) return + + lake_depth_max = 60.0 + ipr = min(im,10) + + x = 0.03279*julian + y = ((((0.0034*x-0.1241)*x+1.6231)*x-8.8666)*x+17.206)*x-4.2929 + + temp = (pi+pi)*(julian-1)/float(yearlen) + temp = 0.006918-0.399912*cos(temp)+0.070257*sin(temp) & + - 0.006758*cos(2.0*temp)+0.000907*sin(2.0*temp) & + - 0.002697*cos(3.0*temp)+0.00148*sin(3.0*temp) + + temp2 = sin((pi+pi)*(julian-151)/244) do i = 1, im if (flag(i)) then - if( use_flake(i) ) then - T_ice(i) = 273.15 - T_snow(i) = 273.15 - fetch(i) = 2.0E+03 - C_T(i) = 0.50 - - dxlat = 57.29578*abs(xlat(i)) - tt = 29.275+0.0813*dxlat-0.0052*dxlat*dxlat-0.0038*elev(i)+273.15 - tb = 29.075-0.7566*dxlat+0.0051*dxlat*dxlat-0.0038*elev(i)+273.15 -! if(fice(i).le.0.0) then -! h_ice(i) = 0.0 -! h_snow(i)= 0.0 + T_ice(i) = 273.15 + T_snow(i) = 273.15 + fetch(i) = 2.0E+03 + C_T(i) = 0.50 + + dxlat = degrad*abs(xlat(i)) + tt = 29.275+(0.0813-0.0052*dxlat)*dxlat-0.0038*elev(i)+273.15 + tb = 29.075-(0.7566-0.0051*dxlat)*dxlat-0.0038*elev(i)+273.15 +! if (fice(i).le.0.0) then +! h_ice(i) = 0.0 +! h_snow(i)= 0.0 +! endif + if (snwdph(i) > 0.0 .or. hice(i) > 0.0) then + if (tsurf(i) < T_ice(i)) then + T_sfc(i) = T_ice(i) + else + T_sfc(i) = tsurf(i) + endif + else +! if (tsurf(i) < tt) then +! T_sfc(i) = tt +! else +! T_sfc(i) = tsurf(i) ! endif - if(snwdph(i).gt.0.0 .or. hice(i).gt.0.0) then - if(tsurf(i).lt.T_ice(i)) then - T_sfc(i) = T_ice(i) - else - T_sfc(i) = tsurf(i) - endif - else -! if(tsurf(i).lt.tt) then -! T_sfc(i) = tt -! else -! T_sfc(i) = tsurf(i) -! endif - T_sfc(i) = 0.1*tt + 0.9* tsurf(i) - endif + T_sfc(i) = 0.1*tt + 0.9* tsurf(i) + endif ! ! Add empirical climatology of lake Tsfc and Tbot to the current Tsfc and Tbot ! to make sure Tsfc and Tbot are warmer than Tair in Winter or colder than Tair ! in Summer - x = 0.03279*julian - if(xlat(i) .ge. 0.0) then - y = ((((0.0034*x-0.1241)*x+1.6231)*x-8.8666)*x+17.206)*x-4.2929 - T_sfc(i) = T_sfc(i) + 0.3*y - tb = tb + 0.05*y - else - y = ((((0.0034*x-0.1241)*x+1.6231)*x-8.8666)*x+17.206)*x-4.2929 - T_sfc(i) = T_sfc(i) - 0.3*y - tb = tb - 0.05*y - endif - T_bot(i) = tb - T_B1(i) = tb - -! if(lakedepth(i).lt.10.0) then -! T_bot(i) = T_sfc(i) -! T_B1(i) = T_bot(i) -! endif - - T_mnw(i) = C_T(i)*T_sfc(i)+(1-C_T(i))*T_bot(i) - T_wML(i) = C_T(i)*T_sfc(i)+(1-C_T(i))*T_bot(i) - h_ML(i) = C_T(i)* min ( lakedepth(i), lake_depth_max ) - H_B1(i) = min ( lakedepth(i),4.0) - hflx(i) = 0.0 - evap(i) = 0.0 - -! compute albedo as a function of julian day and latitute - temp = 2*3.14159265*(julian-1)/float(yearlen) - temp = 0.006918-0.399912*cos(temp)+0.070257*sin(temp)- & - 0.006758*cos(2.0*temp)+0.000907*sin(2.0*temp) - & - 0.002697*cos(3.0*temp)+0.00148*sin(3.0*temp) - w_albedo(I) = 0.06/cos((xlat(i)-temp)/1.2) -! w_albedo(I) = 0.06 + if (xlat(i) >= 0.0) then + T_sfc(i) = T_sfc(i) + 0.3*y + tb = tb + 0.05*y + else + T_sfc(i) = T_sfc(i) - 0.3*y + tb = tb - 0.05*y + endif + T_bot(i) = tb + T_B1(i) = tb + +! if (lakedepth(i) < 10.0) then +! T_bot(i) = T_sfc(i) +! T_B1(i) = T_bot(i) +! endif + + T_mnw(i) = C_T(i)*T_sfc(i) + (1-C_T(i))*T_bot(i) + T_wML(i) = C_T(i)*T_sfc(i) + (1-C_T(i))*T_bot(i) + h_ML(i) = C_T(i)* min ( lakedepth(i), lake_depth_max ) + H_B1(i) = min ( lakedepth(i),4.0) + hflx(i) = 0.0 + evap(i) = 0.0 + +! compute albedo as a function of julian day and latitude + w_albedo(I) = 0.06/cos((xlat(i)-temp)/1.2) +! w_albedo(I) = 0.06 ! compute water extinction coefficient as a function of julian day - if(julian.lt.90 .or. julian .gt. 333) then - w_extinc(i) = Kbar-Kbar/DelK - else - w_extinc(i) = Kbar+Kbar/DelK*sin(2*3.14159265*(julian-151)/244) - endif -! w_extinc(i) = 3.0 + if (julian < 90 .or. julian > 333) then + w_extinc(i) = Kbar - KbaroDelK + else + w_extinc(i) = Kbar + KbaroDelK*temp2 + endif +! w_extinc(i) = 3.0 ! write(65,1002) julian,xlat(i),w_albedo(I),w_extinc(i),lakedepth(i),elev(i),tb,tt,tsurf(i),T_sfc(i) ! print 1002 julian,xlat(i),w_albedo(I),w_extinc(i),lakedepth(i),elev(i),tb,tt,tsurf(i),T_sfc(i) ! print*,'inside flake driver' ! print*, julian,xlat(i),w_albedo(I),w_extinc(i),lakedepth(i),elev(i),tb,tt,tsurf(i),T_sfc(i) - endif !lake endif !flag enddo 1001 format ( 'At icount=', i5, ' x = ', f5.2,5x, 'y = ', & @@ -302,55 +308,54 @@ SUBROUTINE flake_driver_run ( & 1002 format (I4,1x,3(f8.4,1x),6(f11.4,1x)) -! +! ! call lake interface do i=1,im - if (flag(i)) then - if( use_flake(i) ) then - dMsnowdt_in = weasd(i)/delt - I_atm_in = dswsfc(i) - Q_atm_lw_in = dlwflx(i) - height_u_in = zlvl(i) - height_tq_in = zlvl(i) - U_a_in = wind(i) - T_a_in = t1(i) - q_a_in = q1(i) - P_a_in = ps(i) - ch_in = ch(i) - cm_in = cm(i) - albedo_water= w_albedo(i) - water_extinc= w_extinc(i) - - depth_w = min ( lakedepth(i), lake_depth_max ) - depth_bs_in = max ( 4.0, min ( depth_w * 0.2, 10.0 ) ) - fetch_in = fetch(i) - T_bs_in = T_bot(i) - par_Coriolis = 2 * 7.2921 / 100000. * sin ( xlat(i) ) - del_time = delt - - do iter=1,10 !interation loop - T_snow_in = T_snow(i) - T_ice_in = T_ice(i) - T_mnw_in = T_mnw(i) - T_wML_in = T_wML(i) - T_bot_in = T_bot(i) - T_B1_in = T_B1(i) - C_T_in = C_T(i) - h_snow_in = snwdph(i) - h_ice_in = hice(i) - h_ML_in = h_ML(i) - H_B1_in = H_B1(i) - T_sfc_in = T_sfc(i) - - T_bot_2_in = T_bot(i) - Q_SHT_flx = hflx(i) - Q_watvap = evap(i) + if (flag(i)) then + dMsnowdt_in = weasd(i)/delt + I_atm_in = dswsfc(i) + Q_atm_lw_in = dlwflx(i) + height_u_in = zlvl(i) + height_tq_in = zlvl(i) + U_a_in = wind(i) + T_a_in = t1(i) + q_a_in = q1(i) + P_a_in = ps(i) + ch_in = ch(i) + cm_in = cm(i) + albedo_water = w_albedo(i) + water_extinc = w_extinc(i) + + depth_w = min ( lakedepth(i), lake_depth_max ) + depth_bs_in = max ( 4.0, min ( depth_w * 0.2, 10.0 ) ) + fetch_in = fetch(i) + T_bs_in = T_bot(i) + par_Coriolis = 2 * 7.2921 / 100000. * sin ( xlat(i) ) + del_time = delt + + do iter=1,10 !interation loop + T_snow_in = T_snow(i) + T_ice_in = T_ice(i) + T_mnw_in = T_mnw(i) + T_wML_in = T_wML(i) + T_bot_in = T_bot(i) + T_B1_in = T_B1(i) + C_T_in = C_T(i) + h_snow_in = snwdph(i) + h_ice_in = hice(i) + h_ML_in = h_ML(i) + H_B1_in = H_B1(i) + T_sfc_in = T_sfc(i) + + T_bot_2_in = T_bot(i) + Q_SHT_flx = hflx(i) + Q_watvap = evap(i) !------------------------------------------------------------------------------ ! Set the rate of snow accumulation !------------------------------------------------------------------------------ - CALL flake_interface(dMsnowdt_in, I_atm_in, Q_atm_lw_in, height_u_in, & + CALL flake_interface(dMsnowdt_in, I_atm_in, Q_atm_lw_in, height_u_in, & height_tq_in, U_a_in, T_a_in, q_a_in, P_a_in, & depth_w, fetch_in, depth_bs_in, T_bs_in, par_Coriolis, del_time, & @@ -362,45 +367,45 @@ SUBROUTINE flake_driver_run ( & T_B1_out, C_T_out, h_snow_out, h_ice_out, h_ML_out, & H_B1_out, T_sfc_out, Q_SHT_flx, Q_watvap, & ! - T_bot_2_in, T_bot_2_out,u_star, q_sfc,chh_out,cmm_out ) + T_bot_2_in, T_bot_2_out,u_star, q_sfc,chh_out,cmm_out ) !------------------------------------------------------------------------------ ! Update output and values for previous time step ! - T_snow(i) = T_snow_out - T_ice(i) = T_ice_out - T_mnw(i) = T_mnw_out - T_wML(i) = T_wML_out - T_sfc(i) = T_sfc_out - Tsurf(i) = T_sfc_out - T_bot(i) = T_bot_out - T_B1(i) = T_B1_out - C_T(i) = C_T_out - h_ML(i) = h_ML_out - H_B1(i) = H_B1_out - ustar(i) = u_star - qsfc(i) = q_sfc - chh(i) = chh_out - cmm(i) = cmm_out - snwdph(i) = h_snow_out - hice(i) = h_ice_out - evap(i) = Q_watvap - hflx(i) = Q_SHT_flx - - if(hice(i) .gt. 0.0 .or. snwdph(i) .gt. 0.0) then - fice(i) = 1.0 - else - fice(i) = 0.0 - endif - enddo !iter loop - endif !endif of lake - endif !endif of flag - - ENDDO - - 125 format(1x,i2,1x,i2,1x,i2,1x,6(1x,f14.8)) - 126 format(1x,i2,1x,i2,1x,6(1x,f14.8)) - 127 format(1x,i2,2(1x,f16.9)) + T_snow(i) = T_snow_out + T_ice(i) = T_ice_out + T_mnw(i) = T_mnw_out + T_wML(i) = T_wML_out + T_sfc(i) = T_sfc_out + Tsurf(i) = T_sfc_out + T_bot(i) = T_bot_out + T_B1(i) = T_B1_out + C_T(i) = C_T_out + h_ML(i) = h_ML_out + H_B1(i) = H_B1_out + ustar(i) = u_star + qsfc(i) = q_sfc + chh(i) = chh_out + cmm(i) = cmm_out + snwdph(i) = h_snow_out + hice(i) = h_ice_out + evap(i) = Q_watvap + hflx(i) = Q_SHT_flx + + if (hice(i) > 0.0 .or. snwdph(i) > 0.0) then + fice(i) = 1.0 + else + fice(i) = 0.0 + endif + enddo !iter loop + + endif !endif of flag + + enddo + +!125 format(1x,i2,1x,i2,1x,i2,1x,6(1x,f14.8)) +!126 format(1x,i2,1x,i2,1x,6(1x,f14.8)) +!127 format(1x,i2,2(1x,f16.9)) !------------------------------------------------------------------------------ ! End calculations !============================================================================== diff --git a/physics/flake_driver.meta b/physics/flake_driver.meta index 74fb6b7e6..959b5b43f 100644 --- a/physics/flake_driver.meta +++ b/physics/flake_driver.meta @@ -114,8 +114,8 @@ intent = in optional = F [weasd] - standard_name = water_equivalent_accumulated_snow_depth_over_water - long_name = water equiv of acc snow depth over water + standard_name = water_equivalent_accumulated_snow_depth_over_ice + long_name = water equiv of acc snow depth over ice units = mm dimensions = (horizontal_loop_extent) type = real @@ -132,8 +132,8 @@ intent = in optional = F [use_flake] - standard_name = flag_nonzero_lake_surface_fraction - long_name = flag indicating presence of some lake surface area fraction + standard_name = flag_for_using_flake + long_name = flag indicating lake points using flake model units = flag dimensions = (horizontal_loop_extent) type = logical @@ -217,8 +217,8 @@ intent = in optional = F [snwdph] - standard_name = surface_snow_thickness_water_equivalent_over_water - long_name = water equivalent snow depth over water + standard_name = surface_snow_thickness_water_equivalent_over_ice + long_name = water equivalent snow depth over ice units = mm dimensions = (horizontal_loop_extent) type = real diff --git a/physics/gcycle.F90 b/physics/gcycle.F90 index 558a65860..718b375af 100644 --- a/physics/gcycle.F90 +++ b/physics/gcycle.F90 @@ -15,17 +15,17 @@ module gcycle_mod !>\ingroup mod_GFS_phys_time_vary !! This subroutine repopulates specific time-varying surface properties for !! atmospheric forecast runs. - subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & - input_nml_file, lsoil, lsoil_lsm, kice, idate, ialb, isot, ivegsrc, & - use_ufo, nst_anl, fhcyc, phour, lakefrac, min_seaice, min_lakeice, & - frac_grid, smc, slc, stc, smois, sh2o, tslb, tiice, tg3, tref, tsfc, & - tsfco, tisfc, hice, fice, facsf, facwf, alvsf, alvwf, alnsf, alnwf, & - zorli, zorll, zorlo, weasd, slope, snoalb, canopy, vfrac, vtype, & - stype, shdmin, shdmax, snowd, cv, cvb, cvt, oro, oro_uf, & + subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & + input_nml_file, lsoil, lsoil_lsm, kice, idate, ialb, isot, ivegsrc, & + use_ufo, nst_anl, fhcyc, phour, landfrac, lakefrac, min_seaice, min_lakeice, & + frac_grid, smc, slc, stc, smois, sh2o, tslb, tiice, tg3, tref, tsfc, & + tsfco, tisfc, hice, fice, facsf, facwf, alvsf, alvwf, alnsf, alnwf, & + zorli, zorll, zorlo, weasd, slope, snoalb, canopy, vfrac, vtype, & + stype, shdmin, shdmax, snowd, cv, cvb, cvt, oro, oro_uf, & xlat_d, xlon_d, slmsk, imap, jmap) ! ! - use machine, only: kind_phys + use machine, only: kind_phys, kind_io8 implicit none integer, intent(in) :: me, nthrds, nx, ny, isc, jsc, nsst, & @@ -33,8 +33,8 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & integer, intent(in) :: idate(:), ialb, isot, ivegsrc character(len=*), intent(in) :: input_nml_file(:) logical, intent(in) :: use_ufo, nst_anl, frac_grid - real(kind=kind_phys), intent(in) :: fhcyc, phour, lakefrac(:), & - min_seaice, min_lakeice, & + real(kind=kind_phys), intent(in) :: fhcyc, phour, landfrac(:), lakefrac(:), & + min_seaice, min_lakeice, & xlat_d(:), xlon_d(:) real(kind=kind_phys), intent(inout) :: smc(:,:), & slc(:,:), & @@ -80,8 +80,10 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & ! ! Local variables ! --------------- - real(kind=kind_phys) :: & - SLMASK (nx*ny), & +! real(kind=kind_phys) :: & + real(kind=kind_io8) :: & + slmskl (nx*ny), & + slmskw (nx*ny), & TSFFCS (nx*ny), & ZORFCS (nx*ny), & AISFCS (nx*ny), & @@ -92,9 +94,10 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & SLCFC1 (nx*ny*max(lsoil,lsoil_lsm)) - logical :: lake(nx*ny) + real (kind=kind_io8) :: min_ice(nx*ny) + integer :: i_indx(nx*ny), j_indx(nx*ny) character(len=6) :: tile_num_ch - real(kind=kind_phys) :: sig1t, dt_warm + real(kind=kind_phys) :: sig1t integer :: npts, nb, ix, jx, ls, ios, ll logical :: exists ! @@ -116,17 +119,59 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & if ( nsst > 0 ) then TSFFCS = tref else - TSFFCS = tsfc + TSFFCS = tsfco end if ! + if (frac_grid) then + do ix=1,npts + if (landfrac(ix) > -1.0e-8_kind_phys) then + slmskl(ix) = ceiling(landfrac(ix)-1.0e-8_kind_phys) + slmskw(ix) = floor(landfrac(ix)+1.0e-8_kind_phys) + else + if (nint(slmsk(ix)) == 1) then + slmskl(ix) = 1.0_kind_phys + slmskw(ix) = 1.0_kind_phys + else + slmskl(ix) = 0.0_kind_phys + slmskw(ix) = 0.0_kind_phys + endif + endif + ZORFCS(ix) = zorll(ix) + if (nint(slmskl(ix)) == 0) then + if (slmsk(ix) > 1.99_kind_phys) then + ZORFCS(ix) = zorli(ix) + else + ZORFCS(ix) = zorlo(ix) + endif + endif + enddo + else + do ix=1,npts + if (nint(slmsk(ix)) == 1) then + slmskl(ix) = 1.0_kind_phys + slmskw(ix) = 1.0_kind_phys + else + slmskl(ix) = 0.0_kind_phys + slmskw(ix) = 0.0_kind_phys + endif + ZORFCS(ix) = zorll(ix) + if (slmsk(ix) > 1.99_kind_phys) then + ZORFCS(ix) = zorli(ix) + elseif (slmsk(ix) < 0.1_kind_phys) then + ZORFCS(ix) = zorlo(ix) + endif + enddo + endif do ix=1,npts - ZORFCS(ix) = zorll (ix) - if (slmsk(ix) > 1.9_kind_phys .and. .not. frac_grid) then - ZORFCS(ix) = zorli (ix) - elseif (slmsk(ix) < 0.1_kind_phys .and. .not. frac_grid) then - ZORFCS(ix) = zorlo (ix) + i_indx(ix) = imap(ix) + isc - 1 + j_indx(ix) = jmap(ix) + jsc - 1 + + if (lakefrac(ix) > 0.0_kind_phys) then + min_ice(ix) = min_lakeice + else + min_ice(ix) = min_seaice endif - ! DH* Why not 1.9 as for ZORFCS? + IF (slmsk(ix) > 1.99_kind_phys) THEN AISFCS(ix) = 1.0_kind_phys ELSE @@ -153,19 +198,8 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & SLCFC1(ll) = sh2o(ix,ls) endif enddo - ! - IF (slmsk(ix) < 0.1_kind_phys .OR. slmsk(ix) > 1.5_kind_phys) THEN - SLMASK(ix) = 0.0_kind_phys - ELSE - SLMASK(ix) = 1.0_kind_phys - ENDIF - ! - if (lakefrac(ix) > 0.0_kind_phys) then - lake(ix) = .true. - else - lake(ix) = .false. - endif - end do +! + enddo ! #ifndef INTERNAL_FILE_NML inquire (file=trim(Model%fn_nml),exist=exists) @@ -179,7 +213,7 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & #endif CALL SFCCYCLE (9998, npts, max(lsoil,lsoil_lsm), sig1t, fhcyc, & idate(4), idate(2), idate(3), idate(1), & - phour, xlat_d, xlon_d, slmask, & + phour, xlat_d, xlon_d, slmskl, slmskw, & oro, oro_uf, use_ufo, nst_anl, & hice, fice, tisfc, snowd, slcfc1, & shdmin, shdmax, slope, snoalb, tsffcs, & @@ -188,9 +222,8 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & vfrac, vtype, stype, alffc1, cv, & cvb, cvt, me, nthrds, & nlunit, size(input_nml_file), input_nml_file, & - lake, min_lakeice, min_seaice, & - ialb, isot, ivegsrc, & - trim(tile_num_ch), imap, jmap) + min_ice, ialb, isot, ivegsrc, & + trim(tile_num_ch), i_indx, j_indx) #ifndef INTERNAL_FILE_NML close (Model%nlunit) #endif @@ -200,14 +233,16 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & else tsfc = TSFFCS tsfco = TSFFCS - end if + endif ! do ix=1,npts zorll(ix) = ZORFCS(ix) - if (slmsk(ix) > 1.9_kind_phys .and. .not. frac_grid) then - zorli(ix) = ZORFCS(ix) - elseif (slmsk(ix) < 0.1_kind_phys .and. .not. frac_grid) then - zorlo(ix) = ZORFCS(ix) + if (nint(slmskl(ix)) == 0) then + if (slmsk(ix) > 1.99_kind_phys) then + zorli(ix) = ZORFCS(ix) + elseif (slmsk(ix) < 0.1_kind_phys) then + zorlo(ix) = ZORFCS(ix) + endif endif ! facsf(ix) = ALFFC1(ix ) @@ -229,7 +264,7 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & tslb(ix,ls) = STCFC1(ll) sh2o(ix,ls) = SLCFC1(ll) endif - if (ls<=kice) tiice(ix,ls) = STCFC1(ll) +! if (ls<=kice) tiice(ix,ls) = STCFC1(ll) enddo enddo ! diff --git a/physics/gfs_phy_tracer_config.F b/physics/gfs_phy_tracer_config.F index 8ed7443d3..0e1185a50 100644 --- a/physics/gfs_phy_tracer_config.F +++ b/physics/gfs_phy_tracer_config.F @@ -66,7 +66,7 @@ subroutine tracer_config_init (ntrac,ntoz,ntcw,ncld, c implicit none ! input - integer, intent(in) :: me, ntoz,ntcw,ncld,ntke, + integer, intent(in) :: me, ntoz,ntcw,ntke, & ntiw,ntlnc,ntinc,nto,nto2, & fprcp,ntrw,ntsw,ntrnc,ntsnc ! output @@ -83,19 +83,7 @@ subroutine tracer_config_init (ntrac,ntoz,ntcw,ncld, ! initialize chem tracers call gocart_tracer_config(me) -! call gocart_tracer_config(gfs_phy_tracer,me) - -! ntrac_met = number of met tracers -!hmhj if ( ntoz < ntcw ) then -!hmhj gfs_phy_tracer%ntrac_met = ntcw + ncld - 1 -!hmhj else -!hmhj gfs_phy_tracer%ntrac_met = ntoz -!hmhj endif -!hmhj if ( gfs_phy_tracer%ntrac_met /= ntrac ) then -!hmhj print *,'LU_TRC: ERROR ! inconsistency in ntrac:', -!hmhj& ntrac, gfs_phy_tracer%ntrac_met -!hmhj stop 222 -!hmhj endif + ! input ntrac is meteorological tracers gfs_phy_tracer%ntrac_met = ntrac @@ -230,7 +218,7 @@ subroutine fixchar(name_in, name_out, option) endif enddo - name_out=trim(name_out) + name_out = trim(name_out) return end subroutine fixchar diff --git a/physics/m_micro.F90 b/physics/m_micro.F90 index f9b793239..7624d7e3e 100644 --- a/physics/m_micro.F90 +++ b/physics/m_micro.F90 @@ -180,7 +180,10 @@ subroutine m_micro_run( im, lm, flipv, dt_i & real (kind=kind_phys), dimension(:,:),intent(in) :: & & prsl_i,u_i,v_i,phil, omega_i, QLLS_i,QILS_i, & & lwheat_i,swheat_i - real (kind=kind_phys), dimension(:,0:),intent(in):: prsi_i, phii + real (kind=kind_phys), dimension(:,:),intent(in):: prsi_i, phii +! GJF* These variables are conditionally allocated depending on whether the +! Morrison-Gettelman microphysics is used, so they must be declared +! using assumed shape. real (kind=kind_phys), dimension(:,:), intent(in) :: & & CNV_DQLDT_i, CLCN_i, QLCN_i, QICN_i, & & CNV_MFD_i, cf_upi, CNV_FICE_i, CNV_NDROP_i, & @@ -207,6 +210,9 @@ subroutine m_micro_run( im, lm, flipv, dt_i & integer, dimension(:), intent(inout):: KCBL real (kind=kind_phys),dimension(:,:),intent(inout):: q_io, t_io, & & ncpl_io,ncpi_io,CLLS_io +! GJF* These variables are conditionally allocated depending on whether the +! Morrison-Gettelman microphysics is used, so they must be declared +! using assumed shape. real (kind=kind_phys),dimension(:,:),intent(inout):: rnw_io,snw_io,& & ncpr_io, ncps_io, & & qgl_io, ncgl_io @@ -436,7 +442,7 @@ subroutine m_micro_run( im, lm, flipv, dt_i & END DO END DO DO K=0, LM - ll = lm-k + ll = lm-k+1 DO I = 1,IM PLE(i,k) = prsi_i(i,ll) * 0.01_kp ! interface pressure in hPa zet(i,k+1) = phii(i,ll) * onebg diff --git a/physics/module_MYNNSFC_wrapper.F90 b/physics/module_MYNNSFC_wrapper.F90 index a27b02e0d..271ca5a24 100644 --- a/physics/module_MYNNSFC_wrapper.F90 +++ b/physics/module_MYNNSFC_wrapper.F90 @@ -69,7 +69,7 @@ SUBROUTINE mynnsfc_wrapper_run( & & tskin_wat, tskin_lnd, tskin_ice, & !intent(in) & tsurf_wat, tsurf_lnd, tsurf_ice, & !intent(in) & qsfc_wat, qsfc_lnd, qsfc_ice, & !intent(in) - & snowh_wat, snowh_lnd, snowh_ice, & !intent(in) + & snowh_lnd, snowh_ice, & !intent(in) & znt_wat, znt_lnd, znt_ice, & !intent(inout) & ust_wat, ust_lnd, ust_ice, & !intent(inout) & cm_wat, cm_lnd, cm_ice, & !intent(inout) @@ -163,7 +163,7 @@ SUBROUTINE mynnsfc_wrapper_run( & real(kind=kind_phys), dimension(:), intent(in) :: & & tskin_wat, tskin_lnd, tskin_ice, & & tsurf_wat, tsurf_lnd, tsurf_ice, & - & snowh_wat, snowh_lnd, snowh_ice + & snowh_lnd, snowh_ice real(kind=kind_phys), dimension(:), intent(inout) :: & & znt_wat, znt_lnd, znt_ice, & @@ -194,7 +194,7 @@ SUBROUTINE mynnsfc_wrapper_run( & real, dimension(im) :: & & hfx, znt, psim, psih, & & chs, ck, cd, mavail, xland, GZ1OZ0, & - & cpm, qgh, qfx, qsfc_ruc + & cpm, qgh, qfx, qsfc_ruc, snowh_wat real(kind=kind_phys), dimension(im,levs) :: & & pattern_spp_pbl, dz, th, qv @@ -233,13 +233,14 @@ SUBROUTINE mynnsfc_wrapper_run( & else xland(i)=2.0 endif - qgh(i)=0.0 - mavail(i)=1.0 - !snowh(i)=snowd(i)*800. !mm -> m - !znt_lnd(i)=znt_lnd(i)*0.01 !cm -> m - !znt_wat(i)=znt_wat(i)*0.01 !cm -> m - !znt_ice(i)=znt_ice(i)*0.01 !cm -> m - cpm(i)=cp + qgh(i) = 0.0 + mavail(i) = 1.0 + !snowh(i) = snowd(i)*800. !mm -> m + !znt_lnd(i) = znt_lnd(i)*0.01 !cm -> m + !znt_wat(i) = znt_wat(i)*0.01 !cm -> m + !znt_ice(i) = znt_ice(i)*0.01 !cm -> m + cpm(i) = cp + snowh_wat(i) = 0.0 enddo ! cm -> m diff --git a/physics/module_MYNNSFC_wrapper.meta b/physics/module_MYNNSFC_wrapper.meta index d082752c4..94393057b 100644 --- a/physics/module_MYNNSFC_wrapper.meta +++ b/physics/module_MYNNSFC_wrapper.meta @@ -391,15 +391,6 @@ kind = kind_phys intent = inout optional = F -[snowh_wat] - standard_name = surface_snow_thickness_water_equivalent_over_water - long_name = water equivalent snow depth over water - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F [snowh_lnd] standard_name = surface_snow_thickness_water_equivalent_over_land long_name = water equivalent snow depth over land diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index b1301d744..1a038ca72 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -988,24 +988,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & ims,ime, jms,jme, kms,kme, & ! memory dims its,ite, jts,jte, kts,kte, & ! tile dims reset_dBZ, istep, nsteps, & - errmsg, errflg, & - ! Extended diagnostics, array pointers - ! only associated if ext_diag flag is .true. - ext_diag, & - !vts1, txri, txrc, & - prw_vcdc, & - prw_vcde, tpri_inu, tpri_ide_d, & - tpri_ide_s, tprs_ide, tprs_sde_d, & - tprs_sde_s, tprg_gde_d, & - tprg_gde_s, tpri_iha, tpri_wfz, & - tpri_rfz, tprg_rfz, tprs_scw, tprg_scw, & - tprg_rcs, tprs_rcs, & - tprr_rci, tprg_rcg, & - tprw_vcd_c, tprw_vcd_e, tprr_sml, & - tprr_gml, tprr_rcg, & - tprr_rcs, tprv_rev, tten3, qvten3, & - qrten3, qsten3, qgten3, qiten3, niten3, & - nrten3, ncten3, qcten3) + errmsg, errflg) implicit none @@ -1050,46 +1033,12 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & ! To support subcycling: current step and maximum number of steps INTEGER, INTENT (IN) :: istep, nsteps LOGICAL, INTENT (IN) :: reset_dBZ - ! Extended diagnostics, array pointers only associated if ext_diag flag is .true. - LOGICAL, INTENT (IN) :: ext_diag - REAL, DIMENSION(:,:,:), INTENT(INOUT):: & - !vts1, txri, txrc, & - prw_vcdc, & - prw_vcde, tpri_inu, tpri_ide_d, & - tpri_ide_s, tprs_ide, & - tprs_sde_d, tprs_sde_s, tprg_gde_d, & - tprg_gde_s, tpri_iha, tpri_wfz, & - tpri_rfz, tprg_rfz, tprs_scw, tprg_scw, & - tprg_rcs, tprs_rcs, & - tprr_rci, tprg_rcg, & - tprw_vcd_c, tprw_vcd_e, tprr_sml, & - tprr_gml, tprr_rcg, & - tprr_rcs, tprv_rev, tten3, qvten3, & - qrten3, qsten3, qgten3, qiten3, niten3, & - nrten3, ncten3, qcten3 !..Local variables REAL, DIMENSION(kts:kte):: & qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & nr1d, nc1d, nwfa1d, nifa1d, & t1d, p1d, w1d, dz1d, rho, dBZ -!..Extended diagnostics, single column arrays - REAL, DIMENSION(:), ALLOCATABLE:: & - !vtsk1, txri1, txrc1, & - prw_vcdc1, & - prw_vcde1, tpri_inu1, tpri_ide1_d, & - tpri_ide1_s, tprs_ide1, & - tprs_sde1_d, tprs_sde1_s, tprg_gde1_d, & - tprg_gde1_s, tpri_iha1, tpri_wfz1, & - tpri_rfz1, tprg_rfz1, tprs_scw1, tprg_scw1,& - tprg_rcs1, tprs_rcs1, & - tprr_rci1, tprg_rcg1, & - tprw_vcd1_c, tprw_vcd1_e, tprr_sml1, & - tprr_gml1, tprr_rcg1, & - tprr_rcs1, tprv_rev1, tten1, qvten1, & - qrten1, qsten1, qgten1, qiten1, niten1, & - nrten1, ncten1, qcten1 - REAL, DIMENSION(kts:kte):: re_qc1d, re_qi1d, re_qs1d #if ( WRF_CHEM == 1 ) REAL, DIMENSION(kts:kte):: & @@ -1177,50 +1126,6 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & end if end if test_only_once - ! These must be alwyas allocated - !allocate (vtsk1(kts:kte)) - !allocate (txri1(kts:kte)) - !allocate (txrc1(kts:kte)) - allocate_extended_diagnostics: if (ext_diag) then - allocate (prw_vcdc1(kts:kte)) - allocate (prw_vcde1(kts:kte)) - allocate (tpri_inu1(kts:kte)) - allocate (tpri_ide1_d(kts:kte)) - allocate (tpri_ide1_s(kts:kte)) - allocate (tprs_ide1(kts:kte)) - allocate (tprs_sde1_d(kts:kte)) - allocate (tprs_sde1_s(kts:kte)) - allocate (tprg_gde1_d(kts:kte)) - allocate (tprg_gde1_s(kts:kte)) - allocate (tpri_iha1(kts:kte)) - allocate (tpri_wfz1(kts:kte)) - allocate (tpri_rfz1(kts:kte)) - allocate (tprg_rfz1(kts:kte)) - allocate (tprs_scw1(kts:kte)) - allocate (tprg_scw1(kts:kte)) - allocate (tprg_rcs1(kts:kte)) - allocate (tprs_rcs1(kts:kte)) - allocate (tprr_rci1(kts:kte)) - allocate (tprg_rcg1(kts:kte)) - allocate (tprw_vcd1_c(kts:kte)) - allocate (tprw_vcd1_e(kts:kte)) - allocate (tprr_sml1(kts:kte)) - allocate (tprr_gml1(kts:kte)) - allocate (tprr_rcg1(kts:kte)) - allocate (tprr_rcs1(kts:kte)) - allocate (tprv_rev1(kts:kte)) - allocate (tten1(kts:kte)) - allocate (qvten1(kts:kte)) - allocate (qrten1(kts:kte)) - allocate (qsten1(kts:kte)) - allocate (qgten1(kts:kte)) - allocate (qiten1(kts:kte)) - allocate (niten1(kts:kte)) - allocate (nrten1(kts:kte)) - allocate (ncten1(kts:kte)) - allocate (qcten1(kts:kte)) - end if allocate_extended_diagnostics - !+---+ i_start = its j_start = jts @@ -1330,50 +1235,6 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & ni1d(k) = ni(i,k,j) nr1d(k) = nr(i,k,j) rho(k) = 0.622*p1d(k)/(R*t1d(k)*(qv1d(k)+0.622)) - - ! These arrays are always allocated and must be initialized - !vtsk1(k) = 0. - !txrc1(k) = 0. - !txri1(k) = 0. - initialize_extended_diagnostics: if (ext_diag) then - prw_vcdc1(k) = 0. - prw_vcde1(k) = 0. - tpri_inu1(k) = 0. - tpri_ide1_d(k) = 0. - tpri_ide1_s(k) = 0. - tprs_ide1(k) = 0. - tprs_sde1_d(k) = 0. - tprs_sde1_s(k) = 0. - tprg_gde1_d(k) = 0. - tprg_gde1_s(k) = 0. - tpri_iha1(k) = 0. - tpri_wfz1(k) = 0. - tpri_rfz1(k) = 0. - tprg_rfz1(k) = 0. - tprs_scw1(k) = 0. - tprg_scw1(k) = 0. - tprg_rcs1(k) = 0. - tprs_rcs1(k) = 0. - tprr_rci1(k) = 0. - tprg_rcg1(k) = 0. - tprw_vcd1_c(k) = 0. - tprw_vcd1_e(k) = 0. - tprr_sml1(k) = 0. - tprr_gml1(k) = 0. - tprr_rcg1(k) = 0. - tprr_rcs1(k) = 0. - tprv_rev1(k) = 0. - tten1(k) = 0. - qvten1(k) = 0. - qrten1(k) = 0. - qsten1(k) = 0. - qgten1(k) = 0. - qiten1(k) = 0. - niten1(k) = 0. - nrten1(k) = 0. - ncten1(k) = 0. - qcten1(k) = 0. - endif initialize_extended_diagnostics enddo if (is_aerosol_aware) then do k = kts, kte @@ -1397,20 +1258,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & rainprod1d, evapprod1d, & #endif rand1, rand2, rand3, & - kts, kte, dt, i, j, & - ext_diag, & - !vtsk1, txri1, txrc1, & - prw_vcdc1, prw_vcde1, & - tpri_inu1, tpri_ide1_d, tpri_ide1_s, tprs_ide1, & - tprs_sde1_d, tprs_sde1_s, & - tprg_gde1_d, tprg_gde1_s, tpri_iha1, tpri_wfz1, & - tpri_rfz1, tprg_rfz1, tprs_scw1, tprg_scw1, & - tprg_rcs1, tprs_rcs1, tprr_rci1, & - tprg_rcg1, tprw_vcd1_c, & - tprw_vcd1_e, tprr_sml1, tprr_gml1, tprr_rcg1, & - tprr_rcs1, tprv_rev1, & - tten1, qvten1, qrten1, qsten1, & - qgten1, qiten1, niten1, nrten1, ncten1, qcten1) + kts, kte, dt, i, j) pcp_ra(i,j) = pptrain pcp_sn(i,j) = pptsnow @@ -1548,52 +1396,6 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & endif enddo - assign_extended_diagnostics: if (ext_diag) then - do k=kts,kte - !vts1(i,k,j) = vtsk1(k) - !txri(i,k,j) = txri(i,k,j) + txri1(k) - !txrc(i,k,j) = txrc(i,k,j) + txrc1(k) - prw_vcdc(i,k,j) = prw_vcdc(i,k,j) + prw_vcdc1(k) - prw_vcde(i,k,j) = prw_vcde(i,k,j) + prw_vcde1(k) - tpri_inu(i,k,j) = tpri_inu(i,k,j) + tpri_inu1(k) - tpri_ide_d(i,k,j) = tpri_ide_d(i,k,j) + tpri_ide1_d(k) - tpri_ide_s(i,k,j) = tpri_ide_s(i,k,j) + tpri_ide1_s(k) - tprs_ide(i,k,j) = tprs_ide(i,k,j) + tprs_ide1(k) - tprs_sde_s(i,k,j) = tprs_sde_s(i,k,j) + tprs_sde1_s(k) - tprs_sde_d(i,k,j) = tprs_sde_d(i,k,j) + tprs_sde1_d(k) - tprg_gde_d(i,k,j) = tprg_gde_d(i,k,j) + tprg_gde1_d(k) - tprg_gde_s(i,k,j) = tprg_gde_s(i,k,j) + tprg_gde1_s(k) - tpri_iha(i,k,j) = tpri_iha(i,k,j) + tpri_iha1(k) - tpri_wfz(i,k,j) = tpri_wfz(i,k,j) + tpri_wfz1(k) - tpri_rfz(i,k,j) = tpri_rfz(i,k,j) + tpri_rfz1(k) - tprg_rfz(i,k,j) = tprg_rfz(i,k,j) + tprg_rfz1(k) - tprs_scw(i,k,j) = tprs_scw(i,k,j) + tprs_scw1(k) - tprg_scw(i,k,j) = tprg_scw(i,k,j) + tprg_scw1(k) - tprg_rcs(i,k,j) = tprg_rcs(i,k,j) + tprg_rcs1(k) - tprs_rcs(i,k,j) = tprs_rcs(i,k,j) + tprs_rcs1(k) - tprr_rci(i,k,j) = tprr_rci(i,k,j) + tprr_rci1(k) - tprg_rcg(i,k,j) = tprg_rcg(i,k,j) + tprg_rcg1(k) - tprw_vcd_c(i,k,j) = tprw_vcd_c(i,k,j) + tprw_vcd1_c(k) - tprw_vcd_e(i,k,j) = tprw_vcd_e(i,k,j) + tprw_vcd1_e(k) - tprr_sml(i,k,j) = tprr_sml(i,k,j) + tprr_sml1(k) - tprr_gml(i,k,j) = tprr_gml(i,k,j) + tprr_gml1(k) - tprr_rcg(i,k,j) = tprr_rcg(i,k,j) + tprr_rcg1(k) - tprr_rcs(i,k,j) = tprr_rcs(i,k,j) + tprr_rcs1(k) - tprv_rev(i,k,j) = tprv_rev(i,k,j) + tprv_rev1(k) - tten3(i,k,j) = tten3(i,k,j) + tten1(k) - qvten3(i,k,j) = qvten3(i,k,j) + qvten1(k) - qrten3(i,k,j) = qrten3(i,k,j) + qrten1(k) - qsten3(i,k,j) = qsten3(i,k,j) + qsten1(k) - qgten3(i,k,j) = qgten3(i,k,j) + qgten1(k) - qiten3(i,k,j) = qiten3(i,k,j) + qiten1(k) - niten3(i,k,j) = niten3(i,k,j) + niten1(k) - nrten3(i,k,j) = nrten3(i,k,j) + nrten1(k) - ncten3(i,k,j) = ncten3(i,k,j) + ncten1(k) - qcten3(i,k,j) = qcten3(i,k,j) + qcten1(k) - - enddo - endif assign_extended_diagnostics - ! Diagnostic calculations only for last step ! if Thompson MP is called multiple times last_step_only: IF (istep == nsteps) THEN @@ -1657,50 +1459,6 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & ! 'nr: ', nr_max, '(', imax_nr, ',', jmax_nr, ',', kmax_nr, ')' ! END DEBUG - GT - ! These are always allocated - !deallocate (vtsk1) - !deallocate (txri1) - !deallocate (txrc1) - deallocate_extended_diagnostics: if (ext_diag) then - deallocate (prw_vcdc1) - deallocate (prw_vcde1) - deallocate (tpri_inu1) - deallocate (tpri_ide1_d) - deallocate (tpri_ide1_s) - deallocate (tprs_ide1) - deallocate (tprs_sde1_d) - deallocate (tprs_sde1_s) - deallocate (tprg_gde1_d) - deallocate (tprg_gde1_s) - deallocate (tpri_iha1) - deallocate (tpri_wfz1) - deallocate (tpri_rfz1) - deallocate (tprg_rfz1) - deallocate (tprs_scw1) - deallocate (tprg_scw1) - deallocate (tprg_rcs1) - deallocate (tprs_rcs1) - deallocate (tprr_rci1) - deallocate (tprg_rcg1) - deallocate (tprw_vcd1_c) - deallocate (tprw_vcd1_e) - deallocate (tprr_sml1) - deallocate (tprr_gml1) - deallocate (tprr_rcg1) - deallocate (tprr_rcs1) - deallocate (tprv_rev1) - deallocate (tten1) - deallocate (qvten1) - deallocate (qrten1) - deallocate (qsten1) - deallocate (qgten1) - deallocate (qiten1) - deallocate (niten1) - deallocate (nrten1) - deallocate (ncten1) - deallocate (qcten1) - end if deallocate_extended_diagnostics - END SUBROUTINE mp_gt_driver !> @} @@ -1765,30 +1523,14 @@ END SUBROUTINE thompson_finalize !! Thompson et al. (2004, 2008)\cite Thompson_2004 \cite Thompson_2008. !>\section gen_mp_thompson mp_thompson General Algorithm !> @{ - subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & - nr1d, nc1d, nwfa1d, nifa1d, t1d, p1d, w1d, dzq, & - pptrain, pptsnow, pptgraul, pptice, & + subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & + nr1d, nc1d, nwfa1d, nifa1d, t1d, p1d, w1d, dzq, & + pptrain, pptsnow, pptgraul, pptice, & #if ( WRF_CHEM == 1 ) - rainprod, evapprod, & + rainprod, evapprod, & #endif - rand1, rand2, rand3, & - kts, kte, dt, ii, jj, & - ! Extended diagnostics, most arrays only - ! allocated if ext_diag flag is .true. - ext_diag, & - !vtsk1, txri1, txrc1, & - prw_vcdc1, prw_vcde1, & - tpri_inu1, tpri_ide1_d, tpri_ide1_s, tprs_ide1, & - tprs_sde1_d, tprs_sde1_s, & - tprg_gde1_d, tprg_gde1_s, tpri_iha1, tpri_wfz1, & - tpri_rfz1, tprg_rfz1, tprs_scw1, tprg_scw1, & - tprg_rcs1, tprs_rcs1, tprr_rci1, & - tprg_rcg1, tprw_vcd1_c, & - tprw_vcd1_e, tprr_sml1, tprr_gml1, tprr_rcg1, & - tprr_rcs1, tprv_rev1, & - tten1, qvten1, qrten1, qsten1, & - qgten1, qiten1, niten1, nrten1, ncten1, qcten1) - + rand1, rand2, rand3, & + kts, kte, dt, ii, jj) #ifdef MPI use mpi #endif @@ -1803,23 +1545,6 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & REAL, INTENT(INOUT):: pptrain, pptsnow, pptgraul, pptice REAL, INTENT(IN):: dt REAL, INTENT(IN):: rand1, rand2, rand3 - ! Extended diagnostics, most arrays only allocated if ext_diag is true - LOGICAL, INTENT(IN) :: ext_diag - REAL, DIMENSION(:), INTENT(OUT):: & - !vtsk1, txri1, txrc1, & - prw_vcdc1, & - prw_vcde1, tpri_inu1, tpri_ide1_d, & - tpri_ide1_s, tprs_ide1, & - tprs_sde1_d, tprs_sde1_s, tprg_gde1_d, & - tprg_gde1_s, tpri_iha1, tpri_wfz1, & - tpri_rfz1, tprg_rfz1, tprs_scw1, tprg_scw1,& - tprg_rcs1, tprs_rcs1, & - tprr_rci1, tprg_rcg1, & - tprw_vcd1_c, tprw_vcd1_e, tprr_sml1, & - tprr_gml1, tprr_rcg1, & - tprr_rcs1, tprv_rev1, tten1, qvten1, & - qrten1, qsten1, qgten1, qiten1, niten1, & - nrten1, ncten1, qcten1 #if ( WRF_CHEM == 1 ) REAL, DIMENSION(kts:kte), INTENT(INOUT):: & @@ -2029,52 +1754,6 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & enddo #endif -!Diagnostics - if (ext_diag) then - do k = kts, kte - !vtsk1(k) = 0. - !txrc1(k) = 0. - !txri1(k) = 0. - prw_vcdc1(k) = 0. - prw_vcde1(k) = 0. - tpri_inu1(k) = 0. - tpri_ide1_d(k) = 0. - tpri_ide1_s(k) = 0. - tprs_ide1(k) = 0. - tprs_sde1_d(k) = 0. - tprs_sde1_s(k) = 0. - tprg_gde1_d(k) = 0. - tprg_gde1_s(k) = 0. - tpri_iha1(k) = 0. - tpri_wfz1(k) = 0. - tpri_rfz1(k) = 0. - tprg_rfz1(k) = 0. - tprg_scw1(k) = 0. - tprs_scw1(k) = 0. - tprg_rcs1(k) = 0. - tprs_rcs1(k) = 0. - tprr_rci1(k) = 0. - tprg_rcg1(k) = 0. - tprw_vcd1_c(k) = 0. - tprw_vcd1_e(k) = 0. - tprr_sml1(k) = 0. - tprr_gml1(k) = 0. - tprr_rcg1(k) = 0. - tprr_rcs1(k) = 0. - tprv_rev1(k) = 0. - tten1(k) = 0. - qvten1(k) = 0. - qrten1(k) = 0. - qsten1(k) = 0. - qgten1(k) = 0. - qiten1(k) = 0. - niten1(k) = 0. - nrten1(k) = 0. - ncten1(k) = 0. - qcten1(k) = 0. - enddo - endif - !..Bug fix (2016Jun15), prevent use of uninitialized value(s) of snow moments. do k = kts, kte smo0(k) = 0. @@ -3770,7 +3449,6 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & nstep = 0 do k = kte, kts, -1 vts = 0. - !vtsk1(k)=0. if (rs(k).gt. R1) then xDs = smoc(k) / smob(k) @@ -3789,14 +3467,11 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & ! & vts*((vtrk(k)-vts*vts_boost(k))/(temp(k)-T_0))) SR = rs(k)/(rs(k)+rr(k)) vtsk(k) = vts*SR + (1.-SR)*vtrk(k) - !vtsk1(k)=vtsk(k) else vtsk(k) = vts*vts_boost(k) - !vtsk1(k)=vtsk(k) endif else vtsk(k) = vtsk(k+1) - !vtsk1(k)=0 endif if (vtsk(k) .gt. 1.E-3) then @@ -3994,8 +3669,6 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & qiten(k) = qiten(k) - xri*odt niten(k) = -ni1d(k)*odt tten(k) = tten(k) - lfus*ocp(k)*xri*odt*(1-IFDRY) -!diag - !txri1(k) = lfus*ocp(k)*xri*odt*(1-IFDRY) endif xrc = MAX(0.0, qc1d(k) + qcten(k)*DT) @@ -4007,8 +3680,6 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & qcten(k) = qcten(k) - xrc*odt ncten(k) = ncten(k) - xnc*odt tten(k) = tten(k) + lfus2*ocp(k)*xrc*odt*(1-IFDRY) -!diag - !txrc1(k) = lfus2*ocp(k)*xrc*odt*(1-IFDRY)*DT endif enddo endif @@ -4087,89 +3758,6 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & if (qg1d(k) .le. R1) qg1d(k) = 0.0 enddo -! Diagnostics - calculate_extended_diagnostics: if (ext_diag) then - do k = kts, kte - if(prw_vcd(k).gt.0)then - prw_vcdc1(k) = prw_vcd(k)*dt - elseif(prw_vcd(k).lt.0)then - prw_vcde1(k) = -1*prw_vcd(k)*dt - endif -!heating/cooling diagnostics - tpri_inu1(k) = pri_inu(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT - - if(pri_ide(k).gt.0)then - tpri_ide1_d(k) = pri_ide(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT - else - tpri_ide1_s(k) = -pri_ide(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT - endif - - if(temp(k).lt.T_0)then - tprs_ide1(k) = prs_ide(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT - endif - - if(prs_sde(k).gt.0)then - tprs_sde1_d(k) = prs_sde(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT - else - tprs_sde1_s(k) = -prs_sde(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT - endif - - if(prg_gde(k).gt.0)then - tprg_gde1_d(k) = prg_gde(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT - else - tprg_gde1_s(k) = -prg_gde(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT - endif - - tpri_iha1(k) = pri_iha(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT - tpri_wfz1(k) = pri_wfz(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT - tpri_rfz1(k) = pri_rfz(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT - tprg_rfz1(k) = prg_rfz(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT - tprs_scw1(k) = prs_scw(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT - tprg_scw1(k) = prg_scw(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT - tprg_rcs1(k) = prg_rcs(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT - - if(temp(k).lt.T_0)then - tprs_rcs1(k) = prs_rcs(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT - endif - - tprr_rci1(k) = prr_rci(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT - - if(temp(k).lt.T_0)then - tprg_rcg1(k) = prg_rcg(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT - endif - - if(prw_vcd(k).gt.0)then - tprw_vcd1_c(k) = lvap(k)*ocp(k)*prw_vcd(k)*(1-IFDRY)*DT - else - tprw_vcd1_e(k) = -lvap(k)*ocp(k)*prw_vcd(k)*(1-IFDRY)*DT - endif - -! cooling terms - tprr_sml1(k) = prr_sml(k)*lfus*ocp(k)*orho * (1-IFDRY)*DT - tprr_gml1(k) = prr_gml(k)*lfus*ocp(k)*orho * (1-IFDRY)*DT - - if(temp(k).ge.T_0)then - tprr_rcg1(k) = -prr_rcg(k)*lfus*ocp(k)*orho * (1-IFDRY)*DT - endif - - if(temp(k).ge.T_0)then - tprr_rcs1(k) = -prr_rcs(k)*lfus*ocp(k)*orho * (1-IFDRY)*DT - endif - - tprv_rev1(k) = lvap(k)*ocp(k)*prv_rev(k)*(1-IFDRY)*DT - tten1(k) = tten(k)*DT - qvten1(k) = qvten(k)*DT - qiten1(k) = qiten(k)*DT - qrten1(k) = qrten(k)*DT - qsten1(k) = qsten(k)*DT - qgten1(k) = qgten(k)*DT - niten1(k) = niten(k)*DT - nrten1(k) = nrten(k)*DT - ncten1(k) = ncten(k)*DT - qcten1(k) = qcten(k)*DT - enddo - endif calculate_extended_diagnostics - end subroutine mp_thompson !>@} diff --git a/physics/moninshoc.meta b/physics/moninshoc.meta index 51f2c4536..5d6bebcee 100644 --- a/physics/moninshoc.meta +++ b/physics/moninshoc.meta @@ -70,8 +70,8 @@ intent = in optional = F [ncnd] - standard_name = number_of_tracers_for_cloud_condensate - long_name = number of tracers for cloud condensate + standard_name = number_of_cloud_condensate_types + long_name = number of cloud condensate types units = count dimensions = () type = integer diff --git a/physics/mp_thompson.F90 b/physics/mp_thompson.F90 index 6fb039b9d..1d235c3e6 100644 --- a/physics/mp_thompson.F90 +++ b/physics/mp_thompson.F90 @@ -22,8 +22,6 @@ module mp_thompson logical :: is_initialized = .False. - integer, parameter :: ext_ndiag3d = 37 - contains !> This subroutine is a wrapper around the actual thompson_init(). @@ -38,8 +36,7 @@ subroutine mp_thompson_init(ncol, nlev, con_g, con_rd, con_eps, & nwfa, nifa, tgrs, prsl, phil, area, & re_cloud, re_ice, re_snow, & mpicomm, mpirank, mpiroot, & - threads, ext_diag, diag3d, & - errmsg, errflg) + threads, errmsg, errflg) implicit none @@ -82,9 +79,6 @@ subroutine mp_thompson_init(ncol, nlev, con_g, con_rd, con_eps, & integer, intent(in ) :: mpiroot ! Threading/blocking information integer, intent(in ) :: threads - ! Extended diagnostics - logical, intent(in ) :: ext_diag - real(kind_phys), intent(in ) :: diag3d(:,:,:) ! CCPP error handling character(len=*), intent( out) :: errmsg integer, intent( out) :: errflg @@ -112,14 +106,6 @@ subroutine mp_thompson_init(ncol, nlev, con_g, con_rd, con_eps, & return end if - if (ext_diag) then - if (size(diag3d,dim=3) /= ext_ndiag3d) then - write(errmsg,'(*(a))') "Logic error: number of diagnostic 3d arrays from model does not match requirements" - errflg = 1 - return - end if - end if - ! Call Thompson init call thompson_init(is_aerosol_aware_in=is_aerosol_aware, mpicomm=mpicomm, & mpirank=mpirank, mpiroot=mpiroot, threads=threads, & @@ -339,9 +325,8 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & prcp, rain, graupel, ice, snow, sr, & refl_10cm, reset_dBZ, do_radar_ref, & re_cloud, re_ice, re_snow, & - mpicomm, mpirank, mpiroot, blkno, & - ext_diag, diag3d, reset_diag3d, & - errmsg, errflg) + mpicomm, mpirank, mpiroot, & + blkno, errmsg, errflg) implicit none @@ -398,11 +383,6 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & integer, intent(in) :: mpicomm integer, intent(in) :: mpirank integer, intent(in) :: mpiroot - ! Extended diagnostic output - logical, intent(in) :: ext_diag - real(kind_phys), target, intent(inout) :: diag3d(:,:,:) - logical, intent(in) :: reset_diag3d - ! CCPP error handling character(len=*), intent( out) :: errmsg integer, intent( out) :: errflg @@ -445,47 +425,6 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & integer :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte - ! Pointer arrays for extended diagnostics - !real(kind_phys), dimension(:,:,:), pointer :: vts1 => null() - !real(kind_phys), dimension(:,:,:), pointer :: txri => null() - !real(kind_phys), dimension(:,:,:), pointer :: txrc => null() - real(kind_phys), dimension(:,:,:), pointer :: prw_vcdc => null() - real(kind_phys), dimension(:,:,:), pointer :: prw_vcde => null() - real(kind_phys), dimension(:,:,:), pointer :: tpri_inu => null() - real(kind_phys), dimension(:,:,:), pointer :: tpri_ide_d => null() - real(kind_phys), dimension(:,:,:), pointer :: tpri_ide_s => null() - real(kind_phys), dimension(:,:,:), pointer :: tprs_ide => null() - real(kind_phys), dimension(:,:,:), pointer :: tprs_sde_d => null() - real(kind_phys), dimension(:,:,:), pointer :: tprs_sde_s => null() - real(kind_phys), dimension(:,:,:), pointer :: tprg_gde_d => null() - real(kind_phys), dimension(:,:,:), pointer :: tprg_gde_s => null() - real(kind_phys), dimension(:,:,:), pointer :: tpri_iha => null() - real(kind_phys), dimension(:,:,:), pointer :: tpri_wfz => null() - real(kind_phys), dimension(:,:,:), pointer :: tpri_rfz => null() - real(kind_phys), dimension(:,:,:), pointer :: tprg_rfz => null() - real(kind_phys), dimension(:,:,:), pointer :: tprs_scw => null() - real(kind_phys), dimension(:,:,:), pointer :: tprg_scw => null() - real(kind_phys), dimension(:,:,:), pointer :: tprg_rcs => null() - real(kind_phys), dimension(:,:,:), pointer :: tprs_rcs => null() - real(kind_phys), dimension(:,:,:), pointer :: tprr_rci => null() - real(kind_phys), dimension(:,:,:), pointer :: tprg_rcg => null() - real(kind_phys), dimension(:,:,:), pointer :: tprw_vcd_c => null() - real(kind_phys), dimension(:,:,:), pointer :: tprw_vcd_e => null() - real(kind_phys), dimension(:,:,:), pointer :: tprr_sml => null() - real(kind_phys), dimension(:,:,:), pointer :: tprr_gml => null() - real(kind_phys), dimension(:,:,:), pointer :: tprr_rcg => null() - real(kind_phys), dimension(:,:,:), pointer :: tprr_rcs => null() - real(kind_phys), dimension(:,:,:), pointer :: tprv_rev => null() - real(kind_phys), dimension(:,:,:), pointer :: tten3 => null() - real(kind_phys), dimension(:,:,:), pointer :: qvten3 => null() - real(kind_phys), dimension(:,:,:), pointer :: qrten3 => null() - real(kind_phys), dimension(:,:,:), pointer :: qsten3 => null() - real(kind_phys), dimension(:,:,:), pointer :: qgten3 => null() - real(kind_phys), dimension(:,:,:), pointer :: qiten3 => null() - real(kind_phys), dimension(:,:,:), pointer :: niten3 => null() - real(kind_phys), dimension(:,:,:), pointer :: nrten3 => null() - real(kind_phys), dimension(:,:,:), pointer :: ncten3 => null() - real(kind_phys), dimension(:,:,:), pointer :: qcten3 => null() ! Initialize the CCPP error handling variables errmsg = '' @@ -621,53 +560,6 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & kme = nlev kte = nlev - ! Set pointers for extended diagnostics - set_extended_diagnostic_pointers: if (ext_diag) then - if (reset_diag3d) then - diag3d = 0.0 - end if - !vts1 => diag3d(:,:,X:X) - !txri => diag3d(:,:,X:X) - !txrc => diag3d(:,:,X:X) - prw_vcdc => diag3d(:,:,1:1) - prw_vcde => diag3d(:,:,2:2) - tpri_inu => diag3d(:,:,3:3) - tpri_ide_d => diag3d(:,:,4:4) - tpri_ide_s => diag3d(:,:,5:5) - tprs_ide => diag3d(:,:,6:6) - tprs_sde_d => diag3d(:,:,7:7) - tprs_sde_s => diag3d(:,:,8:8) - tprg_gde_d => diag3d(:,:,9:9) - tprg_gde_s => diag3d(:,:,10:10) - tpri_iha => diag3d(:,:,11:11) - tpri_wfz => diag3d(:,:,12:12) - tpri_rfz => diag3d(:,:,13:13) - tprg_rfz => diag3d(:,:,14:14) - tprs_scw => diag3d(:,:,15:15) - tprg_scw => diag3d(:,:,16:16) - tprg_rcs => diag3d(:,:,17:17) - tprs_rcs => diag3d(:,:,18:18) - tprr_rci => diag3d(:,:,19:19) - tprg_rcg => diag3d(:,:,20:20) - tprw_vcd_c => diag3d(:,:,21:21) - tprw_vcd_e => diag3d(:,:,22:22) - tprr_sml => diag3d(:,:,23:23) - tprr_gml => diag3d(:,:,24:24) - tprr_rcg => diag3d(:,:,25:25) - tprr_rcs => diag3d(:,:,26:26) - tprv_rev => diag3d(:,:,27:27) - tten3 => diag3d(:,:,28:28) - qvten3 => diag3d(:,:,29:29) - qrten3 => diag3d(:,:,30:30) - qsten3 => diag3d(:,:,31:31) - qgten3 => diag3d(:,:,32:32) - qiten3 => diag3d(:,:,33:33) - niten3 => diag3d(:,:,34:34) - nrten3 => diag3d(:,:,35:35) - ncten3 => diag3d(:,:,36:36) - qcten3 => diag3d(:,:,37:37) - end if set_extended_diagnostic_pointers - !> - Call mp_gt_driver() with or without aerosols if (is_aerosol_aware) then if (do_effective_radii) then @@ -690,26 +582,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & reset_dBZ=reset_dBZ, istep=istep, nsteps=nsteps, & - first_time_step=first_time_step, errmsg=errmsg, errflg=errflg, & - ! Extended diagnostics - ext_diag=ext_diag, & - ! vts1=vts1, txri=txri, txrc=txrc, & - prw_vcdc=prw_vcdc, & - prw_vcde=prw_vcde, tpri_inu=tpri_inu, tpri_ide_d=tpri_ide_d, & - tpri_ide_s=tpri_ide_s, tprs_ide=tprs_ide, & - tprs_sde_d=tprs_sde_d, & - tprs_sde_s=tprs_sde_s, tprg_gde_d=tprg_gde_d, & - tprg_gde_s=tprg_gde_s, tpri_iha=tpri_iha, & - tpri_wfz=tpri_wfz, tpri_rfz=tpri_rfz, tprg_rfz=tprg_rfz, & - tprs_scw=tprs_scw, tprg_scw=tprg_scw, tprg_rcs=tprg_rcs, & - tprs_rcs=tprs_rcs, & - tprr_rci=tprr_rci, tprg_rcg=tprg_rcg, tprw_vcd_c=tprw_vcd_c, & - tprw_vcd_e=tprw_vcd_e, tprr_sml=tprr_sml, tprr_gml=tprr_gml, & - tprr_rcg=tprr_rcg, tprr_rcs=tprr_rcs, & - tprv_rev=tprv_rev, tten3=tten3, & - qvten3=qvten3, qrten3=qrten3, qsten3=qsten3, qgten3=qgten3, & - qiten3=qiten3, niten3=niten3, nrten3=nrten3, ncten3=ncten3, & - qcten3=qcten3) + first_time_step=first_time_step, errmsg=errmsg, errflg=errflg) else call mp_gt_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, ni=ni, nr=nr, & nc=nc, nwfa=nwfa, nifa=nifa, nwfa2d=nwfa2d, nifa2d=nifa2d, & @@ -729,26 +602,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & reset_dBZ=reset_dBZ, istep=istep, nsteps=nsteps, & - first_time_step=first_time_step, errmsg=errmsg, errflg=errflg, & - ! Extended diagnostics - ext_diag=ext_diag, & - ! vts1=vts1, txri=txri, txrc=txrc, & - prw_vcdc=prw_vcdc, & - prw_vcde=prw_vcde, tpri_inu=tpri_inu, tpri_ide_d=tpri_ide_d, & - tpri_ide_s=tpri_ide_s, tprs_ide=tprs_ide, & - tprs_sde_d=tprs_sde_d, & - tprs_sde_s=tprs_sde_s, tprg_gde_d=tprg_gde_d, & - tprg_gde_s=tprg_gde_s, tpri_iha=tpri_iha, & - tpri_wfz=tpri_wfz, tpri_rfz=tpri_rfz, tprg_rfz=tprg_rfz, & - tprs_scw=tprs_scw, tprg_scw=tprg_scw, tprg_rcs=tprg_rcs, & - tprs_rcs=tprs_rcs, & - tprr_rci=tprr_rci, tprg_rcg=tprg_rcg, tprw_vcd_c=tprw_vcd_c, & - tprw_vcd_e=tprw_vcd_e, tprr_sml=tprr_sml, tprr_gml=tprr_gml, & - tprr_rcg=tprr_rcg, tprr_rcs=tprr_rcs, & - tprv_rev=tprv_rev, tten3=tten3, & - qvten3=qvten3, qrten3=qrten3, qsten3=qsten3, qgten3=qgten3, & - qiten3=qiten3, niten3=niten3, nrten3=nrten3, ncten3=ncten3, & - qcten3=qcten3) + first_time_step=first_time_step, errmsg=errmsg, errflg=errflg) end if else if (do_effective_radii) then @@ -770,26 +624,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & reset_dBZ=reset_dBZ, istep=istep, nsteps=nsteps, & - first_time_step=first_time_step, errmsg=errmsg, errflg=errflg, & - ! Extended diagnostics - ext_diag=ext_diag, & - ! vts1=vts1, txri=txri, txrc=txrc, & - prw_vcdc=prw_vcdc, & - prw_vcde=prw_vcde, tpri_inu=tpri_inu, tpri_ide_d=tpri_ide_d, & - tpri_ide_s=tpri_ide_s, tprs_ide=tprs_ide, & - tprs_sde_d=tprs_sde_d, & - tprs_sde_s=tprs_sde_s, tprg_gde_d=tprg_gde_d, & - tprg_gde_s=tprg_gde_s, tpri_iha=tpri_iha, & - tpri_wfz=tpri_wfz, tpri_rfz=tpri_rfz, tprg_rfz=tprg_rfz, & - tprs_scw=tprs_scw, tprg_scw=tprg_scw, tprg_rcs=tprg_rcs, & - tprs_rcs=tprs_rcs, & - tprr_rci=tprr_rci, tprg_rcg=tprg_rcg, tprw_vcd_c=tprw_vcd_c, & - tprw_vcd_e=tprw_vcd_e, tprr_sml=tprr_sml, tprr_gml=tprr_gml, & - tprr_rcg=tprr_rcg, tprr_rcs=tprr_rcs, & - tprv_rev=tprv_rev, tten3=tten3, & - qvten3=qvten3, qrten3=qrten3, qsten3=qsten3, qgten3=qgten3, & - qiten3=qiten3, niten3=niten3, nrten3=nrten3, ncten3=ncten3, & - qcten3=qcten3) + first_time_step=first_time_step, errmsg=errmsg, errflg=errflg) else call mp_gt_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, ni=ni, nr=nr, & tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtp, & @@ -808,26 +643,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & reset_dBZ=reset_dBZ, istep=istep, nsteps=nsteps, & - first_time_step=first_time_step, errmsg=errmsg, errflg=errflg, & - ! Extended diagnostics - ext_diag=ext_diag, & - ! vts1=vts1, txri=txri, txrc=txrc, & - prw_vcdc=prw_vcdc, & - prw_vcde=prw_vcde, tpri_inu=tpri_inu, tpri_ide_d=tpri_ide_d, & - tpri_ide_s=tpri_ide_s, tprs_ide=tprs_ide, & - tprs_sde_d=tprs_sde_d, & - tprs_sde_s=tprs_sde_s, tprg_gde_d=tprg_gde_d, & - tprg_gde_s=tprg_gde_s, tpri_iha=tpri_iha, & - tpri_wfz=tpri_wfz, tpri_rfz=tpri_rfz, tprg_rfz=tprg_rfz, & - tprs_scw=tprs_scw, tprg_scw=tprg_scw, tprg_rcs=tprg_rcs, & - tprs_rcs=tprs_rcs, & - tprr_rci=tprr_rci, tprg_rcg=tprg_rcg, tprw_vcd_c=tprw_vcd_c, & - tprw_vcd_e=tprw_vcd_e, tprr_sml=tprr_sml, tprr_gml=tprr_gml, & - tprr_rcg=tprr_rcg, tprr_rcs=tprr_rcs, & - tprv_rev=tprv_rev, tten3=tten3, & - qvten3=qvten3, qrten3=qrten3, qsten3=qsten3, qgten3=qgten3, & - qiten3=qiten3, niten3=niten3, nrten3=nrten3, ncten3=ncten3, & - qcten3=qcten3) + first_time_step=first_time_step, errmsg=errmsg, errflg=errflg) end if end if if (errflg/=0) return @@ -870,49 +686,6 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & sr = (snow + graupel + ice)/(rain + snow + graupel + ice +1.e-12) end if - unset_extended_diagnostic_pointers: if (ext_diag) then - !vts1 => null() - !txri => null() - !txrc => null() - prw_vcdc => null() - prw_vcde => null() - tpri_inu => null() - tpri_ide_d => null() - tpri_ide_s => null() - tprs_ide => null() - tprs_sde_d => null() - tprs_sde_s => null() - tprg_gde_d => null() - tprg_gde_s => null() - tpri_iha => null() - tpri_wfz => null() - tpri_rfz => null() - tprg_rfz => null() - tprs_scw => null() - tprg_scw => null() - tprg_rcs => null() - tprs_rcs => null() - tprr_rci => null() - tprg_rcg => null() - tprw_vcd_c => null() - tprw_vcd_e => null() - tprr_sml => null() - tprr_gml => null() - tprr_rcg => null() - tprr_rcs => null() - tprv_rev => null() - tten3 => null() - qvten3 => null() - qrten3 => null() - qsten3 => null() - qgten3 => null() - qiten3 => null() - niten3 => null() - nrten3 => null() - ncten3 => null() - qcten3 => null() - end if unset_extended_diagnostic_pointers - end subroutine mp_thompson_run !>@} diff --git a/physics/mp_thompson.meta b/physics/mp_thompson.meta index 1ab496c25..573bab6c8 100644 --- a/physics/mp_thompson.meta +++ b/physics/mp_thompson.meta @@ -302,23 +302,6 @@ type = integer intent = in optional = F -[ext_diag] - standard_name = flag_for_extended_diagnostic_output_from_thompson_microphysics - long_name = flag for extended diagnostic output from thompson microphysics - units = flag - dimensions = () - type = logical - intent = in - optional = F -[diag3d] - standard_name = extended_diagnostics_output_from_thompson_microphysics - long_name = set of 3d arrays for extended diagnostics output from thompson microphysics - units = none - dimensions = (horizontal_dimension,vertical_dimension,number_of_3d_diagnostic_output_arrays_from_thompson_microphysics) - type = real - kind = kind_phys - intent = in - optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -724,31 +707,6 @@ type = integer intent = in optional = F -[ext_diag] - standard_name = flag_for_extended_diagnostic_output_from_thompson_microphysics - long_name = flag for extended diagnostic output from thompson microphysics - units = flag - dimensions = () - type = logical - intent = in - optional = F -[diag3d] - standard_name = extended_diagnostics_output_from_thompson_microphysics - long_name = set of 3d arrays for extended diagnostics output from thompson microphysics - units = none - dimensions = (horizontal_loop_extent,vertical_dimension,number_of_3d_diagnostic_output_arrays_from_thompson_microphysics) - type = real - kind = kind_phys - intent = inout - optional = F -[reset_diag3d] - standard_name = flag_reset_extended_diagnostics_output_arrays_from_thompson_microphysics - long_name = flag for resetting extended diagnostics output arrays from thompson microphysics - units = flag - dimensions = () - type = logical - intent = in - optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/radiation_surface.f b/physics/radiation_surface.f index ab7d33e44..3ec34513c 100644 --- a/physics/radiation_surface.f +++ b/physics/radiation_surface.f @@ -334,7 +334,7 @@ end subroutine sfc_init subroutine setalb & & ( slmsk,lsm,lsm_noahmp,lsm_ruc,snowf, & ! --- inputs: & sncovr,sncovr_ice,snoalb,zorlf,coszf, & - & tsknf,tairf,hprif,landfrac,frac_grid,min_seaice, & + & tsknf,tairf,hprif,frac_grid,min_seaice, & & alvsf,alnsf,alvwf,alnwf,facsf,facwf,fice,tisfc, & & lsmalbdvis, lsmalbdnir, lsmalbivis, lsmalbinir, & & icealbdvis, icealbdnir, icealbivis, icealbinir, & @@ -409,7 +409,7 @@ subroutine setalb & logical, intent(in) :: frac_grid real (kind=kind_phys), dimension(:), intent(in) :: & - & slmsk, snowf, zorlf, coszf, tsknf, tairf, hprif, landfrac, & + & slmsk, snowf, zorlf, coszf, tsknf, tairf, hprif, & & alvsf, alnsf, alvwf, alnwf, facsf, facwf, fice, tisfc, & & lsmalbdvis, lsmalbdnir, lsmalbivis, lsmalbinir, & & icealbdvis, icealbdnir, icealbivis, icealbinir, & @@ -687,7 +687,6 @@ end subroutine setalb !! or -pi -> +pi ranges !!\param xlat (IMAX), latitude in radiance, default to pi/2 -> !! -pi/2 range, otherwise see in-line comment -!!\param landfrac (IMAX), fraction of grid that is land !!\param snowf (IMAX), snow depth water equivalent in mm !!\param sncovr (IMAX), snow cover over land !!\param zorlf (IMAX), surface roughness in cm @@ -700,7 +699,7 @@ end subroutine setalb !! @{ !----------------------------------- subroutine setemis & - & ( lsm,lsm_noahmp,lsm_ruc,vtype,landfrac,frac_grid, & ! --- inputs: + & ( lsm,lsm_noahmp,lsm_ruc,vtype,frac_grid, & ! --- inputs: & min_seaice,xlon,xlat,slmsk,snowf,sncovr,sncovr_ice, & & zorlf,tsknf,tairf,hprif, & & semis_lnd,semis_ice,IMAX,fracl,fraco,fraci,icy, & @@ -723,7 +722,6 @@ subroutine setemis & ! xlat (IMAX) - latitude in radiance, default to pi/2 -> -pi/2 ! ! range, otherwise see in-line comment ! ! slmsk (IMAX) - sea(0),land(1),ice(2) mask on fcst model grid ! -! landfrac (IMAX) - fraction of land on on fcst model grid ! ! snowf (IMAX) - snow depth water equivalent in mm ! ! sncovr(IMAX) - ialbflg=1: snow cover over land in fraction ! ! sncovr_ice(IMAX) - snow cover over ice in fraction ! @@ -759,7 +757,6 @@ subroutine setemis & integer, intent(in) :: lsm, lsm_noahmp, lsm_ruc logical, intent(in) :: frac_grid real (kind=kind_phys), dimension(:), intent(in) :: vtype - real (kind=kind_phys), dimension(:), intent(in) :: landfrac real (kind=kind_phys), intent(in) :: min_seaice real (kind=kind_phys), dimension(:), intent(in) :: & @@ -892,7 +889,7 @@ subroutine setemis & asnow = 0.02*snowf(i) argh = min(0.50, max(.025,0.01*zorlf(i))) hrgh = min(f_one,max(0.20,1.0577-1.1538e-3*hprif(i))) - fsno = asnow / (argh + asnow) * hrgh + fsno = asnow / (argh + asnow) * hrgh sfcemis_ice = sfcemis_ice*(f_one-fsno)+emsref(8)*fsno endif elseif (lsm == lsm_ruc) then @@ -906,7 +903,7 @@ subroutine setemis & !-- Composite emissivity from land, water and ice fractions. sfcemis(i) = fracl(i)*sfcemis_land + fraco(i)*emsref(1) & - & + fraci(i)*sfcemis_ice + & + fraci(i)*sfcemis_ice enddo ! i diff --git a/physics/rascnv.F90 b/physics/rascnv.F90 index 31386b180..79a5dce40 100644 --- a/physics/rascnv.F90 +++ b/physics/rascnv.F90 @@ -685,7 +685,8 @@ subroutine rascnv_run(IM, k, itc, ntc, ntr, dt, dtf & if (advups) then ! For first order upstream for updraft alfint(:,:) = one elseif (advtvd) then ! TVD flux limiter scheme for updraft - alfint(:,:) = one +! alfint(:,:) = one + alfint(:,:) = half l = krmin lm1 = l - 1 dtvd(1,1) = cp*(toi(l)-toi(lm1)) + phi_l(l)-phi_l(lm1) & diff --git a/physics/samfdeepcnv.meta b/physics/samfdeepcnv.meta index ff3c0d115..ada8a5cf3 100644 --- a/physics/samfdeepcnv.meta +++ b/physics/samfdeepcnv.meta @@ -368,8 +368,8 @@ intent = in optional = F [ncloud] - standard_name = number_of_hydrometeors - long_name = number of hydrometeors + standard_name = number_of_cloud_condensate_types + long_name = number of cloud condensate types units = count dimensions = () type = integer diff --git a/physics/samfshalcnv.meta b/physics/samfshalcnv.meta index a454da3e7..f37ec354d 100644 --- a/physics/samfshalcnv.meta +++ b/physics/samfshalcnv.meta @@ -351,8 +351,8 @@ intent = in optional = F [ncloud] - standard_name = number_of_hydrometeors - long_name = number of hydrometeors + standard_name = number_of_cloud_condensate_types + long_name = number of cloud condensate types units = count dimensions = () type = integer diff --git a/physics/sascnvn.meta b/physics/sascnvn.meta index af25b8477..89f2c6984 100644 --- a/physics/sascnvn.meta +++ b/physics/sascnvn.meta @@ -327,8 +327,8 @@ intent = in optional = F [ncloud] - standard_name = number_of_hydrometeors - long_name = number of hydrometeors + standard_name = number_of_cloud_condensate_types + long_name = number of cloud condensate types units = count dimensions = () type = integer diff --git a/physics/sfc_diff.f b/physics/sfc_diff.f index bff171f4b..445eb0dc4 100644 --- a/physics/sfc_diff.f +++ b/physics/sfc_diff.f @@ -72,7 +72,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) & thsfc_loc, & !intent(in) & tskin_wat, tskin_lnd, tskin_ice, & !intent(in) & tsurf_wat, tsurf_lnd, tsurf_ice, & !intent(in) - & snwdph_wat,snwdph_lnd,snwdph_ice, & !intent(in) + & snwdph_lnd,snwdph_ice, & !intent(in) & z0rl_wat, z0rl_lnd, z0rl_ice, & !intent(inout) & z0rl_wav, & !intent(inout) & ustar_wat, ustar_lnd, ustar_ice, & !intent(inout) @@ -109,7 +109,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) real(kind=kind_phys), dimension(:), intent(in) :: & & tskin_wat, tskin_lnd, tskin_ice, & & tsurf_wat, tsurf_lnd, tsurf_ice, & - & snwdph_wat,snwdph_lnd,snwdph_ice + & snwdph_lnd,snwdph_ice real(kind=kind_phys), dimension(:), intent(in) :: z0rl_wav real(kind=kind_phys), dimension(:), intent(inout) :: & @@ -138,7 +138,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) real(kind=kind_phys) :: tv1 - real(kind=kind_phys) :: tvs, z0, z0max + real(kind=kind_phys) :: tvs, z0, z0max, snwdph_wat ! real(kind=kind_phys), parameter :: & one=1.0_kp, zero=0.0_kp, half=0.5_kp, qmin=1.0e-8_kp @@ -174,6 +174,8 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! write(0,*)'in sfc_diff, sfc_z0_type=',sfc_z0_type + snwdph_wat = zero + do i=1,im if(flag_iter(i)) then @@ -358,7 +360,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! call stability ! --- inputs: - & (z1(i), snwdph_wat(i), thv1, wind(i), + & (z1(i), snwdph_wat, thv1, wind(i), & z0max, ztmax_wat(i), tvs, grav, tv1, thsfc_loc, ! --- outputs: & rb_wat(i), fm_wat(i), fh_wat(i), fm10_wat(i), fh2_wat(i), diff --git a/physics/sfc_diff.meta b/physics/sfc_diff.meta index 7b639b6b0..e7551cf99 100644 --- a/physics/sfc_diff.meta +++ b/physics/sfc_diff.meta @@ -312,15 +312,6 @@ kind = kind_phys intent = in optional = F -[snwdph_wat] - standard_name = surface_snow_thickness_water_equivalent_over_water - long_name = water equivalent snow depth over water - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F [snwdph_lnd] standard_name = surface_snow_thickness_water_equivalent_over_land long_name = water equivalent snow depth over land diff --git a/physics/sfc_drv.f b/physics/sfc_drv.f index d50a8505e..2ecb26469 100644 --- a/physics/sfc_drv.f +++ b/physics/sfc_drv.f @@ -569,8 +569,7 @@ subroutine lsm_noah_run & snwdph(i) = snowh * 1000.0_kind_phys weasd(i) = sneqv * 1000.0_kind_phys sncovr1(i) = sncovr -! ---- ... outside sflx, roughness uses cm as unit (update after snow's -! effect) +! ---- ... outside sflx, roughness uses cm as unit (update after snow's effect) zorl(i) = z0*100.0_kind_phys !> - Do not return the following output fields to parent model: diff --git a/physics/sfc_drv_ruc.meta b/physics/sfc_drv_ruc.meta index 7a7fc5075..1e6d38fc5 100644 --- a/physics/sfc_drv_ruc.meta +++ b/physics/sfc_drv_ruc.meta @@ -845,8 +845,8 @@ intent = in optional = F [lake] - standard_name = flag_nonzero_lake_surface_fraction - long_name = flag indicating presence of some lake surface area fraction + standard_name = flag_for_using_flake + long_name = flag indicating lake points using flake model units = flag dimensions = (horizontal_loop_extent) type = logical diff --git a/physics/sfc_nst.f b/physics/sfc_nst.f index 967fd1c0a..529fa7828 100644 --- a/physics/sfc_nst.f +++ b/physics/sfc_nst.f @@ -94,7 +94,7 @@ subroutine sfc_nst_run & ! prsik1 - real, im ! ! prslk1 - real, im ! ! wet - logical, =T if any ocn/lake water (F otherwise) im ! -! use_flake - logical, =T if any lake otherwise ocn +! use_flake- logical, =T if flake model is used for lake im ! ! icy - logical, =T if any ice im ! ! xlon - real, longitude (radians) im ! ! sinlat - real, sin of latitude im ! @@ -244,6 +244,7 @@ subroutine sfc_nst_run & real(kind=kind_phys) fw,q_warm real(kind=kind_phys) t12,alon,tsea,sstc,dta,dtz real(kind=kind_phys) zsea1,zsea2,soltim + logical do_nst ! external functions called: iw3jdn integer :: iw3jdn @@ -253,6 +254,8 @@ subroutine sfc_nst_run & errmsg = '' errflg = 0 + if (nstf_name1 == 0) return ! No NSST model used + cpinv = one/cp hvapi = one/hvap elocp = hvap/cp @@ -261,10 +264,13 @@ subroutine sfc_nst_run & ! ! flag for open water and where the iteration is on ! + do_nst = .false. do i = 1, im ! flag(i) = wet(i) .and. .not.icy(i) .and. flag_iter(i) flag(i) = wet(i) .and. flag_iter(i) .and. .not. use_flake(i) + do_nst = do_nst .or. flag(i) enddo + if (.not. do_nst) return ! ! save nst-related prognostic fields for guess run ! @@ -677,7 +683,7 @@ end subroutine sfc_nst_pre_finalize !> \section NSST_general_pre_algorithm General Algorithm !! @{ subroutine sfc_nst_pre_run - & (im, wet, use_flake, tgice, tsfco, tsfc_wat, tsurf_wat, + & (im, wet, tgice, tsfco, tsurf_wat, & tseal, xt, xz, dt_cool, z_c, tref, cplflx, & oceanfrac, nthreads, errmsg, errflg) @@ -690,11 +696,10 @@ subroutine sfc_nst_pre_run ! --- inputs: integer, intent(in) :: im, nthreads - logical, dimension(:), intent(in) :: wet, use_flake + logical, dimension(:), intent(in) :: wet real (kind=kind_phys), intent(in) :: tgice real (kind=kind_phys), dimension(:), intent(in) :: - & tsfc_wat, xt, xz, dt_cool, z_c, oceanfrac, - & tsfco + & tsfco, xt, xz, dt_cool, z_c, oceanfrac logical, intent(in) :: cplflx ! --- input/outputs: @@ -712,33 +717,32 @@ subroutine sfc_nst_pre_run & half = 0.5_kp, & omz1 = 2.0_kp real(kind=kind_phys) :: tem1, tem2, dnsst - real(kind=kind_phys), dimension(im) :: dtzm,z_c_0 + real(kind=kind_phys), dimension(im) :: dtzm, z_c_0 ! Initialize CCPP error handling variables errmsg = '' errflg = 0 do i=1,im - if (wet(i) .and. .not. use_flake(i)) then + if (wet(i) .and. oceanfrac(i) > 0.0) then ! tem = (oro(i)-oro_uf(i)) * rlapse ! DH* 20190927 simplyfing this code because tem is zero !tem = zero - !tseal(i) = tsfc_wat(i) + tem - tseal(i) = tsfc_wat(i) + !tseal(i) = tsfco(i) + tem + tseal(i) = tsfco(i) !tsurf_wat(i) = tsurf_wat(i) + tem ! *DH endif enddo - ! ! update tsfc & tref with T1 from OGCM & NSST Profile if coupled ! if (cplflx) then - z_c_0 = 0.0 + z_c_0 = zero call get_dtzm_2d (xt, xz, dt_cool, & & z_c_0, wet, zero, omz1, im, 1, nthreads, dtzm) do i=1,im - if (wet(i) .and. oceanfrac(i)>zero .and..not.use_flake(i)) then + if (wet(i) .and. oceanfrac(i) > zero ) then ! dnsst = tsfc_wat(i) - tref(i) ! retrive/get difference of Ts and Tf tref(i) = max(tgice, tsfco(i) - dtzm(i)) ! update Tf with T1 and NSST T-Profile ! tsfc_wat(i) = max(271.2,tref(i) + dnsst) ! get Ts updated due to Tf update diff --git a/physics/sfc_nst.meta b/physics/sfc_nst.meta index dc0056aeb..685f6f59b 100644 --- a/physics/sfc_nst.meta +++ b/physics/sfc_nst.meta @@ -240,8 +240,8 @@ intent = in optional = F [use_flake] - standard_name = flag_nonzero_lake_surface_fraction - long_name = flag indicating presence of some lake surface area fraction + standard_name = flag_for_using_flake + long_name = flag indicating lake points using flake model units = flag dimensions = (horizontal_loop_extent) type = logical @@ -696,14 +696,6 @@ type = logical intent = in optional = F -[use_flake] - standard_name = flag_nonzero_lake_surface_fraction - long_name = flag indicating presence of some lake surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in - optional = F [tgice] standard_name = freezing_point_temperature_of_seawater long_name = freezing point temperature of seawater @@ -722,15 +714,6 @@ kind = kind_phys intent = in optional = F -[tsfc_wat] - standard_name = surface_skin_temperature_over_water_interstitial - long_name = surface skin temperature over water (temporary use as interstitial) - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F [tsurf_wat] standard_name = surface_skin_temperature_after_iteration_over_water long_name = surface skin temperature after iteration over water @@ -890,8 +873,8 @@ intent = in optional = F [use_flake] - standard_name = flag_nonzero_lake_surface_fraction - long_name = flag indicating presence of some lake surface area fraction + standard_name = flag_for_using_flake + long_name = flag indicating lake points using flake model units = flag dimensions = (horizontal_loop_extent) type = logical diff --git a/physics/sfc_ocean.meta b/physics/sfc_ocean.meta index f27c2207d..844eaed88 100644 --- a/physics/sfc_ocean.meta +++ b/physics/sfc_ocean.meta @@ -132,8 +132,8 @@ intent = in optional = F [use_flake] - standard_name = flag_nonzero_lake_surface_fraction - long_name = flag indicating presence of some lake surface area fraction + standard_name = flag_for_using_flake + long_name = flag indicating lake points using flake model units = flag dimensions = (horizontal_loop_extent) type = logical diff --git a/physics/sfc_sice.f b/physics/sfc_sice.f index 93f7ca16d..176a3e8de 100644 --- a/physics/sfc_sice.f +++ b/physics/sfc_sice.f @@ -45,11 +45,10 @@ subroutine sfc_sice_run & & t0c, rd, ps, t1, q1, delt, & & sfcemis, dlwflx, sfcnsw, sfcdsw, srflag, & & cm, ch, prsl1, prslki, prsik1, prslk1, wind, & - & flag_iter, lprnt, ipr, thsfc_loc, & + & flag_iter, use_flake, lprnt, ipr, thsfc_loc, & & hice, fice, tice, weasd, tskin, tprcp, tiice, ep, & ! --- input/outputs: - & snwdph, qsurf, snowmt, gflux, cmm, chh, evap, hflx, & ! - & frac_grid, icy, islmsk_cice, & - & min_lakeice, min_seaice, oceanfrac, & + & snwdph, qsurf, snowmt, gflux, cmm, chh, evap, hflx, & + & islmsk, & & errmsg, errflg & ) @@ -71,22 +70,22 @@ subroutine sfc_sice_run & ! ! ! subprogram called: ice3lay. ! ! ! -!> program history log: -!!- 2005 -- xingren wu created from original progtm and added -!! two-layer ice model -!!- 200x -- sarah lu added flag_iter -!!- oct 2006 -- h. wei added cmm and chh to output +!> program history log: +!!- 2005 -- xingren wu created from original progtm and added +!! two-layer ice model +!!- 200x -- sarah lu added flag_iter +!!- oct 2006 -- h. wei added cmm and chh to output !!- 2007 -- x. wu modified for mom4 coupling (i.e. cpldice) !! (not used anymore) -!!- 2007 -- s. moorthi micellaneous changes -!!- may 2009 -- y.-t. hou modified to include surface emissivity -!! effect on lw radiation. replaced the confusing +!!- 2007 -- s. moorthi micellaneous changes +!!- may 2009 -- y.-t. hou modified to include surface emissivity +!! effect on lw radiation. replaced the confusing !! slrad with sfc net sw sfcnsw (dn-up). reformatted -!! the code and add program documentation block. -!!- sep 2009 -- s. moorthi removed rcl, changed pressure units and -!! further optimized -!!- jan 2015 -- x. wu change "cimin = 0.15" for both -!! uncoupled and coupled case +!! the code and add program documentation block. +!!- sep 2009 -- s. moorthi removed rcl, changed pressure units and +!! further optimized +!!- jan 2015 -- x. wu change "cimin = 0.15" for both +!! uncoupled and coupled case ! ! ! ! ! ==================== defination of variables ==================== ! @@ -111,6 +110,7 @@ subroutine sfc_sice_run & ! islimsk - integer, sea/land/ice mask (=0/1/2) im ! ! wind - real, im ! ! flag_iter- logical, im ! +! use_flake- logical, true for lakes when when lkm > 0 im ! ! thsfc_loc- logical, reference pressure for potential temp im ! ! ! ! input/outputs: ! @@ -135,7 +135,7 @@ subroutine sfc_sice_run & ! ! ! ===================================================================== ! ! - use machine, only : kind_phys + use machine, only : kind_phys use funcphys, only : fpvs ! implicit none @@ -155,21 +155,18 @@ subroutine sfc_sice_run & integer, intent(in) :: im, kice, ipr logical, intent(in) :: lprnt logical, intent(in) :: thsfc_loc - logical, intent(in) :: frac_grid real (kind=kind_phys), intent(in) :: sbc, hvap, tgice, cp, eps, & & epsm1, grav, rvrdm1, t0c, rd real (kind=kind_phys), dimension(:), intent(in) :: ps, & & t1, q1, sfcemis, dlwflx, sfcnsw, sfcdsw, srflag, cm, ch, & - & prsl1, prslki, prsik1, prslk1, wind, oceanfrac + & prsl1, prslki, prsik1, prslk1, wind -! integer, dimension(im), intent(in) :: islimsk - integer, dimension(:), intent(in) :: islmsk_cice - real (kind=kind_phys), intent(in) :: delt, min_seaice, & - & min_lakeice + integer, dimension(:), intent(in) :: islmsk + real (kind=kind_phys), intent(in) :: delt - logical, dimension(:), intent(in) :: flag_iter, icy + logical, dimension(im), intent(in) :: flag_iter, use_flake ! --- input/outputs: real (kind=kind_phys), dimension(:), intent(inout) :: hice, & @@ -193,10 +190,11 @@ subroutine sfc_sice_run & real (kind=kind_phys) :: t12, t14, tem, stsice(im,kice) &, hflxi, hflxw, q0, qs1, qssi, qssw - real (kind=kind_phys) :: cpinv, hvapi, elocp, snetw, cimin + real (kind=kind_phys) :: cpinv, hvapi, elocp, snetw +! real (kind=kind_phys) :: cpinv, hvapi, elocp, snetw, cimin + logical do_sice integer :: i, k - integer, dimension(im) :: islmsk_local logical :: flag(im) ! @@ -209,35 +207,20 @@ subroutine sfc_sice_run & ! Initialize CCPP error handling variables errmsg = '' errflg = 0 - - - islmsk_local = islmsk_cice - if (frac_grid) then - do i=1,im - if (icy(i) .and. islmsk_local(i) < 2) then - if (oceanfrac(i) > zero) then - tem = min_seaice - else - tem = min_lakeice - endif - if (fice(i) > tem) then - islmsk_local(i) = 2 - tice(i) =min( tice(i), tgice) - endif - endif - enddo - endif - ! !> - Set flag for sea-ice. + do_sice = .false. do i = 1, im - flag(i) = (islmsk_local(i) == 2) .and. flag_iter(i) - if (flag_iter(i) .and. islmsk_local(i) < 2) then - hice(i) = zero - fice(i) = zero - endif + flag(i) = islmsk(i) == 2 .and. flag_iter(i) & + & .and. .not. use_flake(i) + do_sice = do_sice .or. flag(i) +! if (flag_iter(i) .and. islmsk(i) < 2) then +! hice(i) = zero +! fice(i) = zero +! endif enddo + if (.not. do_sice) return do i = 1, im if (flag(i)) then @@ -266,38 +249,30 @@ subroutine sfc_sice_run & do i = 1, im if (flag(i)) then - if (oceanfrac(i) > zero) then - cimin = min_seaice - else - cimin = min_lakeice - endif -! psurf(i) = 1000.0 * ps(i) -! ps1(i) = 1000.0 * prsl1(i) ! dlwflx has been given a negative sign for downward longwave ! sfcnsw is the net shortwave flux (direction: dn-up) q0 = max(q1(i), qmin) -! tsurf(i) = tskin(i) - if(thsfc_loc) then ! Use local potential temperature + if (thsfc_loc) then ! Use local potential temperature theta1(i) = t1(i) * prslki(i) - else ! Use potential temperature referenced to 1000 hPa + else ! Use potential temperature referenced to 1000 hPa theta1(i) = t1(i) / prslk1(i) ! potential temperature in middle of lowest atm. layer endif - rho(i) = prsl1(i) / (rd*t1(i)*(one+rvrdm1*q0)) - qs1 = fpvs(t1(i)) - qs1 = max(eps*qs1 / (prsl1(i) + epsm1*qs1), qmin) - q0 = min(qs1, q0) + rho(i) = prsl1(i) / (rd*t1(i)*(one+rvrdm1*q0)) + qs1 = fpvs(t1(i)) + qs1 = max(eps*qs1 / (prsl1(i) + epsm1*qs1), qmin) + q0 = min(qs1, q0) - if (fice(i) < cimin) then +! if (fice(i) < cimin) then ! print *,'warning: ice fraction is low:', fice(i) - fice(i) = cimin - tice(i) = tgice - tskin(i)= tgice +! fice(i) = cimin +! tice(i) = tgice +! tskin(i)= tgice ! print *,'fix ice fraction: reset it to:', fice(i) - endif +! endif ffw(i) = one - fice(i) qssi = fpvs(tice(i)) @@ -378,7 +353,7 @@ subroutine sfc_sice_run & !> - Call the three-layer thermodynamics sea ice model ice3lay(). call ice3lay ! --- inputs: ! - & ( im, kice, fice, flag, hfi, hfd, sneti, focn, delt, ! + & ( im, kice, fice, flag, hfi, hfd, sneti, focn, delt, ! & lprnt, ipr, ! --- outputs: ! & snowd, hice, stsice, tice, snof, snowmt, gflux ) ! @@ -387,14 +362,12 @@ subroutine sfc_sice_run & if (flag(i)) then if (tice(i) < timin) then print *,'warning: snow/ice temperature is too low:',tice(i) - &,' i=',i tice(i) = timin print *,'fix snow/ice temperature: reset it to:',tice(i) endif if (stsice(i,1) < timin) then print *,'warning: layer 1 ice temp is too low:',stsice(i,1) - &,' i=',i stsice(i,1) = timin print *,'fix layer 1 ice temp: reset it to:',stsice(i,1) endif @@ -405,7 +378,6 @@ subroutine sfc_sice_run & print *,'fix layer 2 ice temp: reset it to:',stsice(i,2) endif - tskin(i) = tice(i)*fice(i) + tgice*ffw(i) endif enddo @@ -431,6 +403,7 @@ subroutine sfc_sice_run & hflx(i) = fice(i)*hflxi + ffw(i)*hflxw evap(i) = fice(i)*evapi(i) + ffw(i)*evapw(i) + tskin(i) = fice(i)*tice(i) + ffw(i)*tgice ! ! --- ... the rest of the output @@ -696,8 +669,8 @@ subroutine ice3lay snowd (i) = snowd(i) - snowmt(i) else snowmt(i) = snowd(i) - h1 = h1 - (tmelt - snowd(i)*dsli) & - & / (di * (ci - li/stsice(i,1)) * (tfi - stsice(i,1))) + h1 = max(zero, h1 - (tmelt - snowd(i)*dsli) & + & / (di * (ci - li/stsice(i,1)) * (tfi - stsice(i,1)))) snowd(i) = zero endif @@ -712,6 +685,7 @@ subroutine ice3lay else h2 = h2 - bmelt / (dili + dici*(tfi - stsice(i,2))) endif + h2 = max(h2, zero) !> - If ice remains, even up 2 layers, else, pass negative energy back in snow. !! Calculate the new upper layer temperature (see \a eq.(38)). diff --git a/physics/sfc_sice.meta b/physics/sfc_sice.meta index b256d54ff..aa520115b 100644 --- a/physics/sfc_sice.meta +++ b/physics/sfc_sice.meta @@ -265,6 +265,14 @@ type = logical intent = in optional = F +[use_flake] + standard_name = flag_for_using_flake + long_name = flag indicating lake points using flake model + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in + optional = F [lprnt] standard_name = flag_print long_name = switch for printing sample column to stdout @@ -433,23 +441,7 @@ kind = kind_phys intent = inout optional = F -[frac_grid] - standard_name = flag_for_fractional_grid - long_name = flag for fractional grid - units = flag - dimensions = () - type = logical - intent = in - optional = F -[icy] - standard_name = flag_nonzero_sea_ice_surface_fraction - long_name = flag indicating presence of some sea ice surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in - optional = F -[islmsk_cice] +[islmsk] standard_name = sea_land_ice_mask_cice long_name = sea/land/ice mask cice (=0/1/2) units = flag @@ -457,33 +449,6 @@ type = integer intent = in optional = F -[min_lakeice] - standard_name = lake_ice_minimum - long_name = minimum lake ice value - units = frac - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[min_seaice] - standard_name = sea_ice_minimum - long_name = minimum sea ice value - units = frac - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[oceanfrac] - standard_name = sea_area_fraction - long_name = fraction of horizontal grid area occupied by ocean - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/sfcsub.F b/physics/sfcsub.F index 067e5ad4e..002103e10 100644 --- a/physics/sfcsub.F +++ b/physics/sfcsub.F @@ -8,6 +8,7 @@ !! This module contains grib code for each parameter-used in subroutines sfccycle() !! and setrmsk(). module sfccyc_module + use machine , only : kind_io8,kind_io4 implicit none save ! @@ -19,12 +20,12 @@ module sfccyc_module &, kpdvmn,kpdvmx,kpdslp,kpdabs &, kpdsnd, kpdabs_0, kpdabs_1, kpdalb(4) parameter(kpdtsf=11, kpdwet=86, kpdsno=65, kpdzor=83, -! 1 kpdalb=84, kpdais=91, kpdtg3=11, kpdplr=224, - 1 kpdais=91, kpdtg3=11, kpdplr=224, - 2 kpdgla=238, kpdmxi=91, kpdscv=238, kpdsmc=144, - 3 kpdoro=8, kpdmsk=81, kpdstc=11, kpdacn=91, kpdveg=87, +! & kpdalb=84, kpdais=91, kpdtg3=11, kpdplr=224, + & kpdais=91, kpdtg3=11, kpdplr=224, + & kpdgla=238, kpdmxi=91, kpdscv=238, kpdsmc=144, + & kpdoro=8, kpdmsk=81, kpdstc=11, kpdacn=91, kpdveg=87, !cbosu max snow albedo uses a grib id number of 159, not 255. - & kpdvmn=255, kpdvmx=255,kpdslp=236, kpdabs_0=255, + & kpdvmn=255, kpdvmx=255,kpdslp=236, kpdabs_0=255, & kpdvet=225, kpdsot=224,kpdabs_1=159, & kpdsnd=66 ) ! @@ -32,6 +33,7 @@ module sfccyc_module integer, parameter :: kpdalb_1(4)=(/189,190,191,192/) integer, parameter :: kpdalf(2)=(/214,217/) ! + real (kind=kind_io8), parameter :: ten=10.0, one=1.0, zero=0.0 integer, parameter :: xdata=5000, ydata=2500, mdata=xdata*ydata integer :: veg_type_landice integer :: soil_type_landice @@ -52,11 +54,11 @@ end function message end module sfccyc_module !>\ingroup mod_GFS_phys_time_vary -!! This subroutine reads or interpolates surface climatology data in analysis +!! This subroutine reads or interpolates surface climatology data in analysis !! and forecast mode. !!\param lugb the unit number used in this subprogram !!\param len number of points on which sfccyc operates -!!\param lsoil number of soil layers +!!\param lsoil number of soil layers !!\param sig1t sigma level 1 temperature for dead start. it should be on gaussian !! grid. If not dead start, no need for dimension but set to zero as !! in the example below. @@ -71,18 +73,18 @@ end module sfccyc_module !!\param nst_anl !! - subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & - &, iy,im,id,ih,fh & - &, rla, rlo, slmask,orog,orog_uf,use_ufo,nst_anl & - &, sihfcs,sicfcs,sitfcs & - &, swdfcs,slcfcs & - &, vmnfcs,vmxfcs,slpfcs,absfcs & - &, tsffcs,snofcs,zorfcs,albfcs,tg3fcs & - &, cnpfcs,smcfcs,stcfcs,slifcs,aisfcs & - &, vegfcs,vetfcs,sotfcs,alffcs & - &, cvfcs,cvbfcs,cvtfcs,me,nthrds,nlunit & - &, sz_nml,input_nml_file & - &, lake, min_lakeice, min_seaice & + subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & + &, iy,im,id,ih,fh,rla,rlo & + &, slmskl,slmskw,orog,orog_uf,use_ufo,nst_anl & + &, sihfcs,sicfcs,sitfcs & + &, swdfcs,slcfcs & + &, vmnfcs,vmxfcs,slpfcs,absfcs & + &, tsffcs,snofcs,zorfcs,albfcs,tg3fcs & + &, cnpfcs,smcfcs,stcfcs,slifcs,aisfcs & + &, vegfcs,vetfcs,sotfcs,alffcs & + &, cvfcs,cvbfcs,cvtfcs,me,nthrds,nlunit & + &, sz_nml,input_nml_file & + &, min_ice & &, ialb,isot,ivegsrc,tile_num_ch,i_index,j_index) ! use machine , only : kind_io8,kind_io4 @@ -92,8 +94,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & integer, intent(in) :: i_index(len), j_index(len), & & me, nthrds logical, intent(in) :: use_ufo, nst_anl - logical, intent(in) :: lake(len) - real (kind=kind_io8), intent(in) :: min_lakeice, min_seaice + real (kind=kind_io8), intent(in) :: min_ice(len) real (kind=kind_io8) sllnd,slsea,aicice,aicsea,tgice,rlapse, & & orolmx,orolmn,oroomx,oroomn,orosmx, & @@ -316,7 +317,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & parameter(plrlmx=1000.,plrlmn=0.0,plromx=1000.0,plromn=0.0, & plrsmx=1000.,plrsmn=0.0,plrimx=1000.,plrimn=0.0, & plrjmx=1000.,plrjmn=0.0) -!clu [-1l/+1l] relax tsfsmx +!clu [-1l/+1l] relax tsfsmx parameter(tsflmx=353.,tsflmn=173.0,tsfomx=313.0,tsfomn=271.2, & tsfsmx=305.0,tsfsmn=173.0,tsfimx=271.2,tsfimn=173.0, & tsfjmx=273.16,tsfjmn=173.0) @@ -342,19 +343,19 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & vegjmx=0.0,vegjmn=0.0) parameter(vmnlmx=1.0,vmnlmn=0.0,vmnomx=0.0,vmnomn=0.0, & vmnsmx=1.0,vmnsmn=0.0,vmnimx=0.0,vmnimn=0.0, - & vmnjmx=0.0,vmnjmn=0.0) + & vmnjmx=0.0,vmnjmn=0.0) parameter(vmxlmx=1.0,vmxlmn=0.0,vmxomx=0.0,vmxomn=0.0, & vmxsmx=1.0,vmxsmn=0.0,vmximx=0.0,vmximn=0.0, - & vmxjmx=0.0,vmxjmn=0.0) + & vmxjmx=0.0,vmxjmn=0.0) parameter(slplmx=9.0,slplmn=1.0,slpomx=0.0,slpomn=0.0, & slpsmx=9.0,slpsmn=1.0,slpimx=0.,slpimn=0., - & slpjmx=0.,slpjmn=0.) + & slpjmx=0.,slpjmn=0.) ! note: the range values for bare land and snow covered land ! (alblmx, alblmn, albsmx, albsmn) are set below ! based on whether the old or new radiation is selected parameter(absomx=0.0,absomn=0.0, & absimx=0.0,absimn=0.0, - & absjmx=0.0,absjmn=0.0) + & absjmx=0.0,absjmn=0.0) ! vegetation type parameter(vetlmx=20.,vetlmn=1.0,vetomx=0.0,vetomn=0.0, & vetsmx=20.,vetsmn=1.0,vetimx=0.,vetimn=0., @@ -399,7 +400,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! parameter(snwmin=25.,snwmax=100.) parameter(snwmin=5.0,snwmax=100.) - real (kind=kind_io8), parameter :: ten=10.0, one=1.0 +! real (kind=kind_io8), parameter :: ten=10.0, one=1.0, zero=0.0 ! ! coefficients of blending forecast and interpolated clim ! (or analyzed) fields over sea or land(l) (not for clouds) @@ -451,9 +452,9 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! mask orography and variance on gaussian grid ! - real (kind=kind_io8) slmask(len),orog(len), orog_uf(len) & - &, orogd(len) - real (kind=kind_io8) rla(len), rlo(len) + real (kind=kind_io8) slmskl(len), slmskw(len) + real (kind=kind_io8) orog(len), orog_uf(len), orogd(len) + real (kind=kind_io8) rla(len), rlo(len) ! ! permanent/extremes ! @@ -467,7 +468,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & character*500 fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc & &, fnplrc,fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc & &, fnvegc,fnvetc,fnsotc & - &, fnvmnc,fnvmxc,fnslpc,fnabsc, fnalbc2 + &, fnvmnc,fnvmxc,fnslpc,fnabsc, fnalbc2 real (kind=kind_io8) tsfclm(len), wetclm(len), snoclm(len) & &, zorclm(len), albclm(len,4), aisclm(len) & &, tg3clm(len), acnclm(len), cnpclm(len) & @@ -483,7 +484,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & character*500 fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa & &, fnplra,fntg3a,fnscva,fnsmca,fnstca,fnacna & &, fnvega,fnveta,fnsota & - &, fnvmna,fnvmxa,fnslpa,fnabsa + &, fnvmna,fnvmxa,fnslpa,fnabsa ! real (kind=kind_io8) tsfanl(len), wetanl(len), snoanl(len) & &, zoranl(len), albanl(len,4), aisanl(len) & @@ -514,7 +515,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! in this program). ! real (kind=kind_io8) f10m (len) - real (kind=kind_io8) fsmcl(25),fsmcs(25),fstcl(25),fstcs(25) + real (kind=kind_io8) fsmcl(25), fsmcs(25), fstcl(25), fstcs(25) real (kind=kind_io8) fcsmcl(25),fcsmcs(25),fcstcl(25),fcstcs(25) !clu [+1l] add swratio (soil moisture liquid-to-total ratio) @@ -532,6 +533,13 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & integer kpd7, kpd9 ! logical icefl1(len), icefl2(len) +! + real (kind=kind_io8), allocatable, dimension(:) :: & + & tsffcsd, snofcsd, tg3fcsd, zorfcsd, slifcsd, aisfcsd, & + & cnpfcsd, vegfcsd, vetfcsd, sotfcsd, sihfcsd, sicfcsd, & + & vmnfcsd, vmxfcsd, slpfcsd, absfcsd + real (kind=kind_io8), allocatable, dimension(:,:) :: & + & smcfcsd, stcfcsd, albfcsd ! ! input and output surface fields (bges) file names ! @@ -777,19 +785,19 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & num_threads = nthrds ! lprnt = .false. - iprnt = 1 ! do i=1,len ! if (ifp .eq. 0 .and. rla(i) .gt. 80.0) print *,' rla=',rla(i) ! *,' rlo=',rlo(i) -! tem1 = abs(rla(i) - 48.75) -! tem2 = abs(rlo(i) - (-68.50)) -! if(tem1 .lt. 0.25 .and. tem2 .lt. 0.50) then +! tem1 = abs(rla(i) - 60.11) +! tem2 = abs(rlo(i) - 5.38) +! if(tem1 < 0.10 .and. tem2 < 0.10) then ! lprnt = .true. ! iprnt = i ! print *,' lprnt=',lprnt,' iprnt=',iprnt ! print *,' rla(i)=',rla(i),' rlo(i)=',rlo(i) ! endif ! enddo + if (ialb == 1) then kpdabs = kpdabs_1 kpdalb = kpdalb_1 @@ -855,14 +863,14 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & endif if (ivegsrc == 2) then ! sib - veg_type_landice=13 + veg_type_landice = 13 else - veg_type_landice=15 + veg_type_landice = 15 endif if (isot == 0) then - soil_type_landice=9 + soil_type_landice = 9 else - soil_type_landice=16 + soil_type_landice = 16 endif ! deltf = deltsfc / 24.0 @@ -1052,8 +1060,8 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! kpd9 = -1 kpd7 = -1 - call fixrdc(lugb,fnglac,kpdgla,kpd7,kpd9,slmask, - & glacir,len,iret + call fixrdc(lugb,fnglac,kpdgla,kpd7,kpd9,slmskl + &, glacir,len,iret &, imsk, jmsk, slmskh, gausm, blnmsk, bltmsk &, rla, rlo, me) ! znnt=1. @@ -1062,8 +1070,8 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! read maximum ice extent ! kpd7 = -1 - call fixrdc(lugb,fnmxic,kpdmxi,kpd7,kpd9,slmask, - & amxice,len,iret + call fixrdc(lugb,fnmxic,kpdmxi,kpd7,kpd9,slmskl + &, amxice,len,iret &, imsk, jmsk, slmskh, gausm, blnmsk, bltmsk &, rla, rlo, me) ! znnt=1. @@ -1085,6 +1093,8 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & icefl1(i) = .true. enddo ! if(lprnt) print *,' tsffcsin=',tsffcs(iprnt) +! if(lprnt) print *,' slifcsin=',slifcs(iprnt) +! if(lprnt) print *,'slmskl=',slmskl(iprnt),' slmskw=',slmskw(iprnt) ! ! read climatology fields ! @@ -1096,7 +1106,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! percrit=critp1 ! - call clima(lugb,iy,im,id,ih,fh,len,lsoil,slmask, + call clima(lugb,iy,im,id,ih,fh,len,lsoil,slmskl,slmskw, & fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, & fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc, & fnvetc,fnsotc, @@ -1113,6 +1123,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & deltsfc, lanom &, imsk, jmsk, slmskh, rla, rlo, gausm, blnmsk, bltmsk,me &, lprnt,iprnt,fnalbc2,ialb,tile_num_ch,i_index,j_index) + ! if(lprnt) print *,'tsfclm=',tsfclm(iprnt),' tsfcl2=',tsfcl2(iprnt) ! ! scale surface roughness and albedo to model required units @@ -1135,11 +1146,11 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! set albedo over ocean to albomx ! - call albocn(albclm,slmask,albomx,len) + call albocn(albclm,slmskl,albomx,len) ! ! make sure vegetation type and soil type are non zero over land ! - call landtyp(vetclm,sotclm,slpclm,slmask,len) + call landtyp(vetclm,sotclm,slpclm,slmskl,len) ! !cwu [-1l/+1l] !* ice concentration or ice mask (only ice mask used in the model now) @@ -1150,7 +1161,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & do i=1,len sihclm(i) = 3.0*aisclm(i) sicclm(i) = aisclm(i) - if(nint(slmask(i)) == 0 .and. nint(glacir(i)) == 1 & + if(nint(slmskl(i)) == 0 .and. nint(glacir(i)) == 1 & & .and. sicclm(i) /= 1.0) then sicclm(i) = sicimx sihfcs(i) = glacir_hice @@ -1159,21 +1170,21 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & crit=aislim !* crit=0.5 ! call rof01(aisclm,len,'ge',crit) - call rof01_len(aisclm, len, 'ge', lake, min_lakeice, min_seaice) + call rof01_len(aisclm, len, 'ge', min_ice) elseif(fnacnc(1:8) /= ' ') then !cwu [+4l] update sihclm, sicclm do i=1,len sihclm(i) = 3.0*acnclm(i) sicclm(i) = acnclm(i) - if(nint(slmask(i)) == 0 .and. nint(glacir(i)) == 1 & + if(nint(slmskw(i)) == 0 .and. nint(glacir(i)) == 1 & & .and. sicclm(i).ne.1.) then sicclm(i) = sicimx sihfcs(i) = glacir_hice endif enddo ! call rof01(acnclm,len,'ge',aislim) - call rof01_len(acnclm, len, 'ge', lake, min_lakeice, min_seaice) + call rof01_len(acnclm, len, 'ge', min_ice) do i=1,len aisclm(i) = acnclm(i) enddo @@ -1181,15 +1192,15 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! quality control of sea ice mask ! - call qcsice(aisclm,glacir,amxice,aicice,aicsea,sllnd,slmask, + call qcsice(aisclm,glacir,amxice,aicice,aicsea,sllnd,slmskw, & rla,rlo,len,me) ! ! set ocean/land/sea-ice mask ! - call setlsi(slmask,aisclm,len,aicice,sliclm) + call setlsi(slmskw,aisclm,len,aicice,sliclm) ! if(lprnt) print *,' aisclm=',aisclm(iprnt),' sliclm=' -! *,sliclm(iprnt),' slmask=',slmask(iprnt) +! &,sliclm(iprnt),' slmskw=',slmskw(iprnt) ! ! write(6,*) 'sliclm' ! znnt=1. @@ -1197,7 +1208,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! quality control of snow ! - call qcsnow(snoclm,slmask,aisclm,glacir,len,snosmx,landice,me) + call qcsnow(snoclm,slmskl,aisclm,glacir,len,snosmx,landice,me) ! call setzro(snoclm,epssno,len) ! @@ -1388,13 +1399,13 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & cnpanl,smcanl,stcanl,slianl,scvanl,veganl, & vetanl,sotanl,alfanl, & sihanl,sicanl, - & vmnanl,vmxanl,slpanl,absanl, + & vmnanl,vmxanl,slpanl,absanl, & tsfclm,tsfcl2,wetclm,snoclm,zorclm,albclm,aisclm, & tg3clm,cvclm ,cvbclm,cvtclm, & cnpclm,smcclm,stcclm,sliclm,scvclm,vegclm, & vetclm,sotclm,alfclm, & sihclm,sicclm, - & vmnclm,vmxclm,slpclm,absclm, + & vmnclm,vmxclm,slpclm,absclm, & len,lsoil) ! ! reverse scaling to match with grib analysis input @@ -1418,7 +1429,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! read analysis fields ! - call analy(lugb,iy,im,id,ih,fh,len,lsoil,slmask, + call analy(lugb,iy,im,id,ih,fh,len,lsoil,slmskl,slmskw, & fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, & fntg3a,fnscva,fnsmca,fnstca,fnacna,fnvega, & fnveta,fnsota, @@ -1427,17 +1438,18 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & tg3anl,cvanl ,cvbanl,cvtanl, & smcanl,stcanl,slianl,scvanl,acnanl,veganl, & vetanl,sotanl,alfanl,tsfan0, - & vmnanl,vmxanl,slpanl,absanl, + & vmnanl,vmxanl,slpanl,absanl, & kpdtsf,kpdwet,kpdsno,kpdsnd,kpdzor,kpdalb,kpdais, & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, & kpdvet,kpdsot,kpdalf, - & kpdvmn,kpdvmx,kpdslp,kpdabs, + & kpdvmn,kpdvmx,kpdslp,kpdabs, & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, & irtvet,irtsot,irtalf - &, irtvmn,irtvmx,irtslp,irtabs, + &, irtvmn,irtvmx,irtslp,irtabs, & imsk, jmsk, slmskh, rla, rlo, gausm, blnmsk, bltmsk &, me, lanom) + ! if(lprnt) print *,' tsfanl=',tsfanl(iprnt) ! ! scale zor and alb to match forecast model units @@ -1469,7 +1481,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! if (use_ufo .and. .not. nst_anl) then ztsfc = 0.0 - call tsfcor(tsfanl,orog_uf,slmask,ztsfc,len,rlapse) + call tsfcor(tsfanl,orog_uf,slmskw,ztsfc,len,rlapse) endif ! ! ice concentration or ice mask (only ice mask used in the model now) @@ -1479,7 +1491,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & do i=1,len sihanl(i) = 3.0*aisanl(i) sicanl(i) = aisanl(i) - if(nint(slmask(i)) == 0 .and. nint(glacir(i)) == 1 & + if(nint(slmskw(i)) == 0 .and. nint(glacir(i)) == 1 & & .and. sicanl(i) /= 1.) then sicanl(i) = sicimx sihfcs(i) = glacir_hice @@ -1488,13 +1500,13 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! crit=aislim !* crit=0.5 ! call rof01(aisanl,len,'ge',crit) - call rof01_len(aisanl, len, 'ge', lake, min_lakeice, min_seaice) + call rof01_len(aisanl, len, 'ge', min_ice) elseif(fnacna(1:8) /= ' ') then !cwu [+17l] update sihanl, sicanl do i=1,len sihanl(i) = 3.0*acnanl(i) sicanl(i) = acnanl(i) - if(nint(slmask(i)) == 0 .and. nint(glacir(i)) == 1 & + if(nint(slmskw(i)) == 0 .and. nint(glacir(i)) == 1 & & .and. sicanl(i) /= 1.) then sicanl(i) = sicimx sihfcs(i) = glacir_hice @@ -1502,20 +1514,20 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & enddo ! crit=aislim do i=1,len - if (lake(i)) then - crit = min_lakeice - else - crit = min_seaice - endif + crit = min_ice(i) if (nint(slianl(i)) == 0 .and. sicanl(i) >= crit) then - slianl(i) = 2. + slianl(i) = 2.0_kind_io8 ! print *,'cycle - new ice form: fice=',sicanl(i) elseif (nint(slianl(i)) >= 2 .and. sicanl(i) < crit) then slianl(i) = 0. ! print *,'cycle - ice free: fice=',sicanl(i) - elseif (nint(slianl(i)) == 1 .and. sicanl(i) > crit) then -! print *,'cycle - land covered by sea-ice: fice=',sicanl(i) - sicanl(i) = 0. + elseif (nint(slianl(i)) == 1 .and. sicanl(i) >= crit) then + if (nint(slmskw(i)) == 0) then ! can happen only for fractional grid + slianl(i) = 2.0_kind_io8 + else +! print *,'cycle - land covered by sea-ice: fice=',sicanl(i) + sicanl(i) = 0.0_kind_io8 + endif endif enddo ! znnt=10. @@ -1527,22 +1539,23 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! enddo ! if(lprnt) print *,' acnanl=',acnanl(iprnt) ! call rof01(acnanl,len,'ge',aislim) - call rof01_len(acnanl, len, 'ge', lake, min_lakeice, min_seaice) + call rof01_len(acnanl, len, 'ge', min_ice) do i=1,len aisanl(i) = acnanl(i) enddo endif -! if(lprnt) print *,' aisanl1=',aisanl(iprnt),' glacir=' -! &,glacir(iprnt),' slmask=',slmask(iprnt) +! if(lprnt) print *,' aisanl1=',aisanl(iprnt),' glacir=' & +! &,glacir(iprnt),' slmskwl=',slmskw(iprnt),slmskl(iprnt) ! - call qcsice(aisanl,glacir,amxice,aicice,aicsea,sllnd,slmask, + call qcsice(aisanl,glacir,amxice,aicice,aicsea,sllnd,slmskw, & rla,rlo,len,me) ! ! set ocean/land/sea-ice mask ! - call setlsi(slmask,aisanl,len,aicice,slianl) -! if(lprnt) print *,' aisanl=',aisanl(iprnt),' slianl=' -! *,slianl(iprnt),' slmask=',slmask(iprnt) + call setlsi(slmskw,aisanl,len,aicice,slianl) + +! if(lprnt) print *,' aisanl=',aisanl(iprnt),' slianl=' & +! &,slianl(iprnt),' slmskwl=',slmskw(iprnt),slmskl(iprnt) ! ! do k=1,lsoil @@ -1569,14 +1582,14 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! set albedo over ocean to albomx ! - call albocn(albanl,slmask,albomx,len) + call albocn(albanl,slmskl,albomx,len) ! ! quality control of snow and sea-ice ! process snow depth or snow cover ! if (fnsnoa(1:8) /= ' ') then call setzro(snoanl,epssno,len) - call qcsnow(snoanl,slmask,aisanl,glacir,len,ten,landice,me) + call qcsnow(snoanl,slmskl,aisanl,glacir,len,ten,landice,me) if (.not.landice) then call snodpth2(glacir,snosmx,snoanl, len, me) endif @@ -1594,14 +1607,14 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & else crit = 0.5 call rof01(scvanl,len,'ge',crit) - call qcsnow(scvanl,slmask,aisanl,glacir,len,one,landice,me) + call qcsnow(scvanl,slmskl,aisanl,glacir,len,one,landice,me) call qcmxmn('sncva ',scvanl,slianl,scvanl,icefl1, & scvlmx,scvlmn,scvomx,scvomn,scvimx,scvimn, & scvjmx,scvjmn,scvsmx,scvsmn,epsscv, & rla,rlo,len,kqcm,percrit,lgchek,me) call snodpth(scvanl,slianl,tsfanl,snoclm, & glacir,snwmax,snwmin,landice,len,snoanl,me) - call qcsnow(scvanl,slmask,aisanl,glacir,len,snosmx,landice,me) + call qcsnow(scvanl,slmskl,aisanl,glacir,len,snosmx,landice,me) call snosfc(snoanl,tsfanl,tsfsmx,len,me) call qcmxmn('snowa ',snoanl,slianl,snoanl,icefl1, & snolmx,snolmn,snoomx,snoomn,snoimx,snoimn, @@ -1770,7 +1783,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & !cwu [+1l] add ()anl for sih, sic & sihanl,sicanl, !clu [+1l] add ()anl for vmn, vmx, slp, abs - & vmnanl,vmxanl,slpanl,absanl, + & vmnanl,vmxanl,slpanl,absanl, & len,lsoil) if (sig1t(1) /= 0.) then call usesgt(sig1t,slianl,tg3anl,len,lsoil,tsffcs,stcfcs, @@ -1807,13 +1820,13 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! if ( index(fntg3c, "tileX.nc") == 0) then ! global file ztsfc = 1.0 - call tsfcor(tg3fcs,orogd,slmask,ztsfc,len,-rlapse) + call tsfcor(tg3fcs,orogd,slmskl,ztsfc,len,-rlapse) endif ztsfc = 0. - call tsfcor(tsffcs,orogd,slmask,ztsfc,len,-rlapse) + call tsfcor(tsffcs,orogd,slmskw,ztsfc,len,-rlapse) else ztsfc = 0. - call tsfcor(tsffcs,orog,slmask,ztsfc,len,-rlapse) + call tsfcor(tsffcs,orog,slmskw,ztsfc,len,-rlapse) endif !clu [+12l] -------------------------------------------------------------- @@ -1833,7 +1846,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! if (lqcbgs .and. irtacn == 0) then call qcsli(slianl,slifcs,len,me) - call albocn(albfcs,slmask,albomx,len) + call albocn(albfcs,slmskl,albomx,len) do i=1,len icefl2(i) = sicfcs(i) .gt. 0.99999 enddo @@ -1976,6 +1989,15 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! if(lprnt) print *,'tsfclm=',tsfclm(iprnt),' tsfcl2=',tsfcl2(iprnt) ! *,' tsffcs=',tsffcs(iprnt),' slianl=',slianl(iprnt) + do i=1,len + if (sicanl(i) >= min_ice(i)) then + slianl(i) = 2.0_kind_io8 + else + slianl(i) = zero + sicanl(i) = zero + endif + enddo + if (fh-deltsfc > -0.001 ) then do i=1,len if(slianl(i) == 0.0) then @@ -2004,15 +2026,18 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! merge analysis and forecast. note tg3, ais are not merged ! +! if(lprnt) print *,' stcfcsbefmer=',stcfcs(iprnt,:) +! if(lprnt) print *,' stcanlbefmer=',stcanl(iprnt,:) + call merge(len,lsoil,iy,im,id,ih,fh,deltsfc, - & sihfcs,sicfcs, - & vmnfcs,vmxfcs,slpfcs,absfcs, + & slmskl,slmskw,sihfcs,sicfcs, + & vmnfcs,vmxfcs,slpfcs,absfcs, & tsffcs,wetfcs,snofcs,zorfcs,albfcs,aisfcs, & cvfcs ,cvbfcs,cvtfcs, & cnpfcs,smcfcs,stcfcs,slifcs,vegfcs, & vetfcs,sotfcs,alffcs, - & sihanl,sicanl, - & vmnanl,vmxanl,slpanl,absanl, + & sihanl,sicanl, + & vmnanl,vmxanl,slpanl,absanl, & tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl,aisanl, & cvanl ,cvbanl,cvtanl, & cnpanl,smcanl,stcanl,slianl,veganl, @@ -2025,20 +2050,22 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & cvmnl,cvmns,cvmxl,cvmxs,cslpl,cslps,cabsl,cabss, & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, - & irtvmn,irtvmx,irtslp,irtabs, + & irtvmn,irtvmx,irtslp,irtabs, & irtvet,irtsot,irtalf,landice,me) call setzro(snoanl,epssno,len) ! if(lprnt) print *,' tanlm=',tsfanl(iprnt),' tfcsm=',tsffcs(iprnt) ! if(lprnt) print *,' sliam=',slianl(iprnt),' slifm=',slifcs(iprnt) +! if(lprnt) print *,' stcfcsmer=',stcfcs(iprnt,:) +! if(lprnt) print *,' stcanlmer=',stcanl(iprnt,:) ! ! new ice/melted ice ! call newice(slianl,slifcs,tsfanl,tsffcs,len,lsoil, !cwu [+1l] add sihnew, aislim, sihanl & sicanl - & sihnew,aislim,sihanl,sicanl, + & sihnew,aislim,sihanl,sicanl, & albanl,snoanl,zoranl,smcanl,stcanl, & albomx,snoomx,zoromx,smcomx,smcimx, !cwu [-1l/+1l] change albimx to albimn - note albimx & albimn have been modified @@ -2048,7 +2075,8 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! if(lprnt) print *,'tsfanl=',tsfanl(iprnt),' tsffcs=',tsffcs(iprnt) ! if(lprnt) print *,' slian=',slianl(iprnt),' slifn=',slifcs(iprnt) -! +! if(lprnt) print *,' stcan=',stcanl(iprnt,:) + ! set tsfc to tsnow over snow ! call snosfc(snoanl,tsfanl,tsfsmx,len,me) @@ -2158,13 +2186,13 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! if ( index(fntg3c, "tileX.nc") == 0) then ! global file ztsfc = 1. - call tsfcor(tg3anl,orogd,slmask,ztsfc,len,rlapse) + call tsfcor(tg3anl,orogd,slmskl,ztsfc,len,rlapse) endif ztsfc = 0. - call tsfcor(tsfanl,orogd,slmask,ztsfc,len,rlapse) + call tsfcor(tsfanl,orogd,slmskw,ztsfc,len,rlapse) else ztsfc = 0. - call tsfcor(tsfanl,orog,slmask,ztsfc,len,rlapse) + call tsfcor(tsfanl,orog,slmskw,ztsfc,len,rlapse) endif ! if(lprnt) print *,' tsfaf=',tsfanl(iprnt) ! @@ -2214,37 +2242,45 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & endif ! if (mondif) then + allocate (tsffcsd(len), snofcsd(len), tg3fcsd(len), & + & zorfcsd(len), slifcsd(len), aisfcsd(len), & + & cnpfcsd(len), vegfcsd(len), vetfcsd(len), & + & sotfcsd(len), sihfcsd(len), sicfcsd(len), & + & vmnfcsd(len), vmxfcsd(len), slpfcsd(len), & + & absfcsd(len)) + allocate (smcfcsd(len,lsoil), stcfcsd(len,lsoil), & + & albfcsd(len,4)) do i=1,len - tsffcs(i) = tsfanl(i) - tsffcs(i) - snofcs(i) = snoanl(i) - snofcs(i) - tg3fcs(i) = tg3anl(i) - tg3fcs(i) - zorfcs(i) = zoranl(i) - zorfcs(i) + tsffcsd(i) = tsfanl(i) - tsffcs(i) + snofcsd(i) = snoanl(i) - snofcs(i) + tg3fcsd(i) = tg3anl(i) - tg3fcs(i) + zorfcsd(i) = zoranl(i) - zorfcs(i) ! plrfcs(i) = plranl(i) - plrfcs(i) ! albfcs(i) = albanl(i) - albfcs(i) - slifcs(i) = slianl(i) - slifcs(i) - aisfcs(i) = aisanl(i) - aisfcs(i) - cnpfcs(i) = cnpanl(i) - cnpfcs(i) - vegfcs(i) = veganl(i) - vegfcs(i) - vetfcs(i) = vetanl(i) - vetfcs(i) - sotfcs(i) = sotanl(i) - sotfcs(i) + slifcsd(i) = slianl(i) - slifcs(i) + aisfcsd(i) = aisanl(i) - aisfcs(i) + cnpfcsd(i) = cnpanl(i) - cnpfcs(i) + vegfcsd(i) = veganl(i) - vegfcs(i) + vetfcsd(i) = vetanl(i) - vetfcs(i) + sotfcsd(i) = sotanl(i) - sotfcs(i) !clu [+2l] add sih, sic - sihfcs(i) = sihanl(i) - sihfcs(i) - sicfcs(i) = sicanl(i) - sicfcs(i) + sihfcsd(i) = sihanl(i) - sihfcs(i) + sicfcsd(i) = sicanl(i) - sicfcs(i) !clu [+4l] add vmn, vmx, slp, abs - vmnfcs(i) = vmnanl(i) - vmnfcs(i) - vmxfcs(i) = vmxanl(i) - vmxfcs(i) - slpfcs(i) = slpanl(i) - slpfcs(i) - absfcs(i) = absanl(i) - absfcs(i) + vmnfcsd(i) = vmnanl(i) - vmnfcs(i) + vmxfcsd(i) = vmxanl(i) - vmxfcs(i) + slpfcsd(i) = slpanl(i) - slpfcs(i) + absfcsd(i) = absanl(i) - absfcs(i) enddo do j = 1,lsoil do i = 1,len - smcfcs(i,j) = smcanl(i,j) - smcfcs(i,j) - stcfcs(i,j) = stcanl(i,j) - stcfcs(i,j) + smcfcsd(i,j) = smcanl(i,j) - smcfcs(i,j) + stcfcsd(i,j) = stcanl(i,j) - stcfcs(i,j) enddo enddo do j = 1,4 do i = 1,len - albfcs(i,j) = albanl(i,j) - albfcs(i,j) + albfcsd(i,j) = albanl(i,j) - albfcs(i,j) enddo enddo ! @@ -2255,40 +2291,45 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & print *,'monitor of difference' print *,' (includes angulation correction)' print *,' ' - call monitr('tsfdif',tsffcs,slianl,snoanl,len) - call monitr('albdif',albfcs,slianl,snoanl,len) - call monitr('albdif1',albfcs,slianl,snoanl,len) - call monitr('albdif2',albfcs(1,2),slianl,snoanl,len) - call monitr('albdif3',albfcs(1,3),slianl,snoanl,len) - call monitr('albdif4',albfcs(1,4),slianl,snoanl,len) - call monitr('aisdif',aisfcs,slianl,snoanl,len) - call monitr('snodif',snofcs,slianl,snoanl,len) + call monitr('tsfdif', tsffcsd,slianl,snoanl,len) + call monitr('albdif', albfcsd,slianl,snoanl,len) + call monitr('albdif1',albfcsd,slianl,snoanl,len) + call monitr('albdif2',albfcsd(1,2),slianl,snoanl,len) + call monitr('albdif3',albfcsd(1,3),slianl,snoanl,len) + call monitr('albdif4',albfcsd(1,4),slianl,snoanl,len) + call monitr('aisdif', aisfcsd,slianl,snoanl,len) + call monitr('snodif', snofcsd,slianl,snoanl,len) do k=1,lsoil - call monitr(message('smcanl',k),smcfcs(1,k),slianl,snoanl,len) - call monitr(message('stcanl',k),stcfcs(1,k),slianl,snoanl,len) + call monitr(message('smcanl',k),smcfcsd(1,k),slianl,snoanl,len) + call monitr(message('stcanl',k),stcfcsd(1,k),slianl,snoanl,len) enddo - call monitr('tg3dif',tg3fcs,slianl,snoanl,len) - call monitr('zordif',zorfcs,slianl,snoanl,len) + call monitr('tg3dif',tg3fcsd,slianl,snoanl,len) + call monitr('zordif',zorfcsd,slianl,snoanl,len) ! if (gaus) then call monitr('cvadif',cvfcs ,slianl,snoanl,len) call monitr('cvbdif',cvbfcs,slianl,snoanl,len) call monitr('cvtdif',cvtfcs,slianl,snoanl,len) ! endif - call monitr('slidif',slifcs,slianl,snoanl,len) + call monitr('slidif',slifcsd,slianl,snoanl,len) ! call monitr('plrdif',plrfcs,slianl,snoanl,len) - call monitr('cnpdif',cnpfcs,slianl,snoanl,len) - call monitr('vegdif',vegfcs,slianl,snoanl,len) - call monitr('vetdif',vetfcs,slianl,snoanl,len) - call monitr('sotdif',sotfcs,slianl,snoanl,len) + call monitr('cnpdif',cnpfcsd,slianl,snoanl,len) + call monitr('vegdif',vegfcsd,slianl,snoanl,len) + call monitr('vetdif',vetfcsd,slianl,snoanl,len) + call monitr('sotdif',sotfcsd,slianl,snoanl,len) !cwu [+2l] add sih, sic - call monitr('sihdif',sihfcs,slianl,snoanl,len) - call monitr('sicdif',sicfcs,slianl,snoanl,len) + call monitr('sihdif',sihfcsd,slianl,snoanl,len) + call monitr('sicdif',sicfcsd,slianl,snoanl,len) !clu [+4l] add vmn, vmx, slp, abs - call monitr('vmndif',vmnfcs,slianl,snoanl,len) - call monitr('vmxdif',vmxfcs,slianl,snoanl,len) - call monitr('slpdif',slpfcs,slianl,snoanl,len) - call monitr('absdif',absfcs,slianl,snoanl,len) + call monitr('vmndif',vmnfcsd,slianl,snoanl,len) + call monitr('vmxdif',vmxfcsd,slianl,snoanl,len) + call monitr('slpdif',slpfcsd,slianl,snoanl,len) + call monitr('absdif',absfcsd,slianl,snoanl,len) endif + deallocate (tsffcsd, snofcsd, tg3fcsd, zorfcsd, slifcsd, & + & aisfcsd, cnpfcsd, vegfcsd, vetfcsd, sotfcsd, & + & sihfcsd, sicfcsd, vmnfcsd, vmxfcsd, slpfcsd, & + & absfcsd) + deallocate (smcfcsd, stcfcsd, albfcsd) endif ! ! @@ -2324,6 +2365,8 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & endif enddo enddo +! if(lprnt) print *,' stcfcs=',stcfcs(iprnt,:),'slifcs=', & +! & slifcs(iprnt) do j = 1,4 do i = 1,len albfcs(i,j) = albanl(i,j) @@ -2338,27 +2381,29 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & !cwu [+20l] update sihfcs, sicfcs. remove sea ice over non-ice points ! crit = aislim do i=1,len - sihfcs(i) = sihanl(i) - sitfcs(i) = tsffcs(i) - if (lake(i)) then - crit = min_lakeice - else - crit = min_seaice - endif - if (slifcs(i) >= 1.99_kind_io8) then - if (sicfcs(i) > crit) then - tem1 = 1.0_kind_io8 / sicfcs(i) - tsffcs(i) = (sicanl(i)*tsffcs(i) - & + (sicfcs(i)-sicanl(i))*tgice) * tem1 - sitfcs(i) = (tsffcs(i)-tgice*(1.0-sicfcs(i))) * tem1 - sicfcs(i) = sicanl(i) + if (slmskw(i) == zero) then + crit = min_ice(i) + if (sicanl(i) >= crit) then + sihfcs(i) = sihanl(i) + sitfcs(i) = tsffcs(i) + if (sicfcs(i) >= crit) then + tem1 = 1.0_kind_io8 / sicfcs(i) + tsffcs(i) = (sicanl(i)*tsffcs(i) + & + (sicfcs(i)-sicanl(i))*tgice) * tem1 + sitfcs(i) = (tsffcs(i)-tgice*(1.0-sicfcs(i))) * tem1 + sicfcs(i) = sicanl(i) + else + tsffcs(i) = tgice + sitfcs(i) = tgice + sicfcs(i) = sicanl(i) + sihfcs(i) = sihnew + endif else tsffcs(i) = tsfanl(i) -! tsffcs(i) = tgice -! sihfcs(i) = sihnew - sihfcs(i) = 0.0_kind_io8 - sicfcs(i) = 0.0_kind_io8 - slifcs(i) = 0.0_kind_io8 + sihfcs(i) = zero + sicfcs(i) = zero + slifcs(i) = zero + sitfcs(i) = tsffcs(i) endif endif if (slifcs(i) > 1.5_kind_io8 .and. sicfcs(i) < crit) then @@ -2373,11 +2418,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! sicfcs(i) = 0.0_kind_io8 ! sitfcs(i) = tsffcs(i) ! else -! if (lake(i)) then -! crit = min_lakeice -! else -! crit = min_seaice -! endif +! crit = min_ice(i) ! if (sicfcs(i) < crit) then ! print *,'warning: check, slifcs and sicfcs', & ! & slifcs(i),sicfcs(i) @@ -2464,9 +2505,16 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & tsffcs(i) = min(tsffcs(i),273.15) endif enddo - end if + endif + do i=1,len + if (nint(slmskl(i)) == 1 .and. nint(slmskw(i)) == 0) then + slifcs(i) = slmskl(i) ! resetting slmsk to land value where land/wate/ice coexist + endif + enddo ! ! if(lprnt) print *,' tsffcsf=',tsffcs(iprnt) +! if(lprnt) print *,' stcfcsend=',stcfcs(iprnt,:) +! if(lprnt) print *,' slifcsend=',slifcs(iprnt) return end subroutine sfccycle @@ -3315,8 +3363,10 @@ subroutine la2ga(regin,imxin,jmxin,rinlon,rinlat,rlon,rlat,inttyp,& !cggg routine assign a default. if (num_threads == 1) then - print*,'no matching mask found ',i,i1,j1,ix,jx - print*,'set to default value.' + print*,'no matching mask found ',i,i1,j1,ix,jx & + &, ' slmask=',slmask(i),' me=',me & + &, ' outlon=',outlon(i),' outlat=',outlat(i) + &, 'set to default value.' endif gauout(i) = 0.0 @@ -3581,7 +3631,7 @@ subroutine filanl(tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl, & & slianl(len),scvanl(len),veganl(len), & & vetanl(len),sotanl(len),alfanl(len,2) & &, sihanl(len),sicanl(len) & - &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) + &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) real (kind=kind_io8) tsfclm(len),tsfcl2(len),wetclm(len), & & snoclm(len), & & zorclm(len),albclm(len,4),aisclm(len), & @@ -3617,7 +3667,7 @@ subroutine filanl(tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl, & sicanl(i) = sicclm(i) ! sea ice concentration !clu [+4l] add vmn, vmx, slp, abs vmnanl(i) = vmnclm(i) ! min vegetation cover - vmxanl(i) = vmxclm(i) ! max vegetation cover + vmxanl(i) = vmxclm(i) ! max vegetation cover slpanl(i) = slpclm(i) ! slope type absanl(i) = absclm(i) ! max snow albedo enddo @@ -3643,8 +3693,8 @@ subroutine filanl(tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl, & end !>\ingroup mod_sfcsub - subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & - & slmask,fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa,& + subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil,slmskl,slmskw, & + & fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, & & fntg3a,fnscva,fnsmca,fnstca,fnacna,fnvega, & & fnveta,fnsota, & & fnvmna,fnvmxa,fnslpa,fnabsa, & !clu [+1l] add fn()a for vmn, vmx, slp, abs @@ -3674,7 +3724,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & &, kpdvmn,kpdvmx,kpdslp,kpdabs,irtvmn,irtvmx,irtslp,irtabs real (kind=kind_io8) blto,blno,fh ! - real (kind=kind_io8) slmask(len) + real (kind=kind_io8) slmskl(len), slmskw(len) real (kind=kind_io8) slmskh(imsk,jmsk) real (kind=kind_io8) outlat(len), outlon(len) integer kpdalb(4), kpdalf(2) @@ -3704,7 +3754,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & ! irttsf = 1 if(fntsfa(1:8).ne.' ') then - call fixrda(lugb,fntsfa,kpdtsf,slmask, + call fixrda(lugb,fntsfa,kpdtsf,slmskw, & iy,im,id,ih,fh,tsfanl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -3731,7 +3781,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & ! tsf0 ! if(fntsfa(1:8).ne.' ' .and. lanom) then - call fixrda(lugb,fntsfa,kpdtsf,slmask, + call fixrda(lugb,fntsfa,kpdtsf,slmskw, & iy,im,id,ih,0.,tsfan0,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -3759,7 +3809,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & irtalb = 0 if(fnalba(1:8).ne.' ') then do kk = 1, 4 - call fixrda(lugb,fnalba,kpdalb(kk),slmask, + call fixrda(lugb,fnalba,kpdalb(kk),slmskl, & iy,im,id,ih,fh,albanl(1,kk),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -3790,7 +3840,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & irtalf = 0 if(fnalba(1:8).ne.' ') then do kk = 1, 2 - call fixrda(lugb,fnalba,kpdalf(kk),slmask, + call fixrda(lugb,fnalba,kpdalf(kk),slmskl, & iy,im,id,ih,fh,alfanl(1,kk),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -3821,7 +3871,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & irtwet=0 irtsmc=0 if(fnweta(1:8).ne.' ') then - call fixrda(lugb,fnweta,kpdwet,slmask, + call fixrda(lugb,fnweta,kpdwet,slmskl, & iy,im,id,ih,fh,wetanl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -3839,11 +3889,11 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & if (me .eq. 0) print *,'bucket wetness analysis provided.' endif elseif(fnsmca(1:8).ne.' ') then - call fixrda(lugb,fnsmca,kpdsmc,slmask, + call fixrda(lugb,fnsmca,kpdsmc,slmskl, & iy,im,id,ih,fh,smcanl(1,1),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) - call fixrda(lugb,fnsmca,kpdsmc,slmask, + call fixrda(lugb,fnsmca,kpdsmc,slmskl, & iy,im,id,ih,fh,smcanl(1,2),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -3904,14 +3954,14 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & call abort endif if (kgds(1) == 4) then ! gaussian data is depth - call fixrda(lugb,fnsnoa,kpdsnd,slmask, + call fixrda(lugb,fnsnoa,kpdsnd,slmskl, & iy,im,id,ih,fh,snoanl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) - snoanl=snoanl*100. ! convert from meters to liq. eq. - ! depth in mm using 10:1 ratio + snoanl = snoanl*100. ! convert from meters to liq. eq. + ! depth in mm using 10:1 ratio else ! lat/lon data is liq equv. depth - call fixrda(lugb,fnsnoa,kpdsno,slmask, + call fixrda(lugb,fnsnoa,kpdsno,slmskl, & iy,im,id,ih,fh,snoanl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -3933,9 +3983,9 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & irtsno=0 elseif(fnscva(1:8).ne.' ') then do i=1,len - snoanl(i)=0. + snoanl(i) = 0. enddo - call fixrda(lugb,fnscva,kpdscv,slmask, + call fixrda(lugb,fnscva,kpdscv,slmskl, & iy,im,id,ih,fh,scvanl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -3964,7 +4014,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & irtacn=0 irtais=0 if(fnacna(1:8).ne.' ') then - call fixrda(lugb,fnacna,kpdacn,slmask, + call fixrda(lugb,fnacna,kpdacn,slmskw, & iy,im,id,ih,fh,acnanl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -3984,7 +4034,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & if (me .eq. 0) print *,'ice concentration analysis provided.' endif elseif(fnaisa(1:8).ne.' ') then - call fixrda(lugb,fnaisa,kpdais,slmask, + call fixrda(lugb,fnaisa,kpdais,slmskw, & iy,im,id,ih,fh,aisanl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -4012,7 +4062,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & ! irtzor=0 if(fnzora(1:8).ne.' ') then - call fixrda(lugb,fnzora,kpdzor,slmask, + call fixrda(lugb,fnzora,kpdzor,slmskl, & iy,im,id,ih,fh,zoranl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -4041,7 +4091,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & irttg3=0 irtstc=0 if(fntg3a(1:8).ne.' ') then - call fixrda(lugb,fntg3a,kpdtg3,slmask, + call fixrda(lugb,fntg3a,kpdtg3,slmskl, & iy,im,id,ih,fh,tg3anl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -4060,11 +4110,11 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & if (me .eq. 0) print *,'deep soil tmp analysis provided.' endif elseif(fnstca(1:8).ne.' ') then - call fixrda(lugb,fnstca,kpdstc,slmask, + call fixrda(lugb,fnstca,kpdstc,slmskl, & iy,im,id,ih,fh,stcanl(1,1),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) - call fixrda(lugb,fnstca,kpdstc,slmask, + call fixrda(lugb,fnstca,kpdstc,slmskl, & iy,im,id,ih,fh,stcanl(1,2),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -4093,7 +4143,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & ! irtveg=0 if(fnvega(1:8).ne.' ') then - call fixrda(lugb,fnvega,kpdveg,slmask, + call fixrda(lugb,fnvega,kpdveg,slmskl, & iy,im,id,ih,fh,veganl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -4123,7 +4173,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & ! irtvet=0 if(fnveta(1:8).ne.' ') then - call fixrda(lugb,fnveta,kpdvet,slmask, + call fixrda(lugb,fnveta,kpdvet,slmskl, & iy,im,id,ih,fh,vetanl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -4153,7 +4203,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & ! irtsot=0 if(fnsota(1:8).ne.' ') then - call fixrda(lugb,fnsota,kpdsot,slmask, + call fixrda(lugb,fnsota,kpdsot,slmskl, & iy,im,id,ih,fh,sotanl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -4184,7 +4234,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & ! irtvmn=0 if(fnvmna(1:8).ne.' ') then - call fixrda(lugb,fnvmna,kpdvmn,slmask, + call fixrda(lugb,fnvmna,kpdvmn,slmskl, & iy,im,id,ih,fh,vmnanl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -4214,7 +4264,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & ! irtvmx=0 if(fnvmxa(1:8).ne.' ') then - call fixrda(lugb,fnvmxa,kpdvmx,slmask, + call fixrda(lugb,fnvmxa,kpdvmx,slmskl, & iy,im,id,ih,fh,vmxanl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -4244,7 +4294,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & ! irtslp=0 if(fnslpa(1:8).ne.' ') then - call fixrda(lugb,fnslpa,kpdslp,slmask, + call fixrda(lugb,fnslpa,kpdslp,slmskl, & iy,im,id,ih,fh,slpanl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -4274,7 +4324,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & ! irtabs=0 if(fnabsa(1:8).ne.' ') then - call fixrda(lugb,fnabsa,kpdabs,slmask, + call fixrda(lugb,fnabsa,kpdabs,slmskl, & iy,im,id,ih,fh,absanl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -4331,7 +4381,7 @@ subroutine filfcs(tsffcs,wetfcs,snofcs,zorfcs,albfcs, & & slifcs(len),vegfcs(len), & & vetfcs(len),sotfcs(len),alffcs(len,2) & &, sihfcs(len),sicfcs(len) & - &, vmnfcs(len),vmxfcs(len),slpfcs(len),absfcs(len) + &, vmnfcs(len),vmxfcs(len),slpfcs(len),absfcs(len) real (kind=kind_io8) tsfanl(len),wetanl(len),snoanl(len), & & zoranl(len),albanl(len,4),aisanl(len), & & tg3anl(len), & @@ -4470,21 +4520,14 @@ subroutine rof01(aisfld, len, op, crit) end !>\ingroup mod_sfcsub - subroutine rof01_len(aisfld, len, op, lake, critl, crits) + subroutine rof01_len(aisfld, len, op, crit) use machine , only : kind_io8,kind_io4 implicit none integer i,len - logical :: lake(len) - real (kind=kind_io8) aisfld(len), critl, crits, crit(len) + real (kind=kind_io8), intent(in) :: crit(len) + real (kind=kind_io8) aisfld(len) character*2 op ! - do i=1,len - if (lake(i)) then - crit(i) = critl - else - crit(i) = crits - endif - enddo if(op == 'ge') then do i=1,len if(aisfld(i) >= crit(i)) then @@ -4602,7 +4645,7 @@ end subroutine snodpth !>\ingroup mod_sfcsub !! This subroutine merges analysis and forecast. subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & - & sihfcs,sicfcs, & + & slmskl,slmskw,sihfcs,sicfcs, & & vmnfcs,vmxfcs,slpfcs,absfcs, & & tsffcs,wetfcs,snofcs,zorfcs,albfcs,aisfcs, & & cvfcs ,cvbfcs,cvtfcs, & @@ -4626,7 +4669,7 @@ subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & & irtvet,irtsot,irtalf, landice, me) use machine , only : kind_io8,kind_io4 use sfccyc_module, only : veg_type_landice, soil_type_landice, & - & num_threads + & num_threads, zero, one implicit none integer k,i,im,id,iy,len,lsoil,ih,irtacn,irtsmc,irtscv,irtais, & & irttg3,irtstc,irtalf,me,irtsot,irtveg,irtvet, irtzor, & @@ -4651,6 +4694,7 @@ subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & &, rslpl,rslps,rabsl,rabss,qvmnl,qvmns & &, qvmxl,qvmxs,qslpl,qslps,qabsl,qabss ! + real (kind=kind_io8) slmskl(len), slmskw(len) real (kind=kind_io8) tsffcs(len), wetfcs(len), snofcs(len), & & zorfcs(len), albfcs(len,4), aisfcs(len), & & cvfcs (len), cvbfcs(len), cvtfcs(len), & @@ -4835,8 +4879,8 @@ subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & if (me == 0) then write(6,100) rtsfl,ralbl,raisl,rsnol,rsmcl,rzorl,rvegl 100 format('rtsfl,ralbl,raisl,rsnol,rsmcl,rzorl,rvegl=',10f7.3) - write(6,101) rtsfs,ralbs,raiss,rsnos,rsmcs,rzors,rvegs - 101 format('rtsfs,ralbs,raiss,rsnos,rsmcs,rzors,rvegs=',10f7.3) + write(6,101) rtsfs,ralbs,raiss,rsnos,rsmcs,rzors,rvegs,rsics + 101 format('rtsfs,ralbs,raiss,rsnos,rsmcs,rzors,rvegs,rsics=',11f7.3) ! print *,' ralfl=',ralfl,' ralfs=',ralfs,' rsotl=',rsotl ! *,' rsots=',rsots,' rvetl=',rvetl,' rvets=',rvets endif @@ -4914,7 +4958,7 @@ subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & i1_t = (it-1)*len_thread_m+1 i2_t = min(i1_t+len_thread_m-1,len) do i=i1_t,i2_t - if(slianl(i).eq.0.) then + if(slianl(i) == zero) then vetanl(i) = vetfcs(i)*rvets + vetanl(i)*qvets sotanl(i) = sotfcs(i)*rsots + sotanl(i)*qsots else @@ -4932,7 +4976,8 @@ subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & i2_t = min(i1_t+len_thread_m-1,len) ! do i=i1_t,i2_t - if(slianl(i).eq.0.) then + if(slianl(i) == zero) then +! if(slmskw(i) == zero) then !.... tsffc2 is the previous anomaly + today's climatology ! tsffc2 = (tsffcs(i)-tsfan2(i))+tsfanl(i) ! tsfanl(i) = tsffc2 *rtsfs+tsfanl(i)*qtsfs @@ -4950,7 +4995,8 @@ subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & vmxanl(i) = vmxfcs(i)*rvmxs + vmxanl(i)*qvmxs slpanl(i) = slpfcs(i)*rslps + slpanl(i)*qslps absanl(i) = absfcs(i)*rabss + absanl(i)*qabss - else + endif + if(slmskl(i) == one .or. slianl(i) > zero) then tsfanl(i) = tsffcs(i)*rtsfl + tsfanl(i)*qtsfl ! albanl(i) = albfcs(i)*ralbl + albanl(i)*qalbl aisanl(i) = aisfcs(i)*raisl + aisanl(i)*qaisl @@ -5053,11 +5099,11 @@ end subroutine merge !>\ingroup mod_sfcsub subroutine newice(slianl,slifcs,tsfanl,tsffcs,len,lsoil, & - & sihnew,sicnew,sihanl,sicanl, & !cwu [+1l] add sihnew,sicnew,sihanl,sicanl - & albanl,snoanl,zoranl,smcanl,stcanl, & - & albsea,snosea,zorsea,smcsea,smcice, & - & tsfmin,tsfice,albice,zorice,tgice, & - & rla,rlo,me) + & sihnew,sicnew,sihanl,sicanl, & !cwu [+1l] add sihnew,sicnew,sihanl,sicanl + & albanl,snoanl,zoranl,smcanl,stcanl, & + & albsea,snosea,zorsea,smcsea,smcice, & + & tsfmin,tsfice,albice,zorice,tgice, & + & rla,rlo,me) ! use machine , only : kind_io8,kind_io4 implicit none @@ -5081,8 +5127,8 @@ subroutine newice(slianl,slifcs,tsfanl,tsffcs,len,lsoil, & kount1 = 0 kount2 = 0 do i=1,len - if(slifcs(i).ne.slianl(i)) then - if(slifcs(i).eq.1..or.slianl(i).eq.1.) then + if (nint(slifcs(i)) /= nint(slianl(i))) then + if (nint(slifcs(i)) == 1 .or. nint(slianl(i)) == 1) then print *,'FATAL ERROR: inconsistency in slifcs or slianl.' print 910,rla(i),rlo(i),slifcs(i),slianl(i), & tsffcs(i),tsfanl(i) @@ -5093,7 +5139,7 @@ subroutine newice(slianl,slifcs,tsfanl,tsffcs,len,lsoil, & ! ! interpolated climatology indicates melted sea ice ! - if(slianl(i).eq.0..and.slifcs(i).eq.2.) then + if (nint(slianl(i)) == 0 .and. nint(slifcs(i)) == 2) then tsfanl(i) = tsfmin albanl(i,1) = albsea albanl(i,2) = albsea @@ -5114,7 +5160,7 @@ subroutine newice(slianl,slifcs,tsfanl,tsffcs,len,lsoil, & ! ! interplated climatoloyg/analysis indicates new sea ice ! - if(slianl(i).eq.2..and.slifcs(i).eq.0.) then + if (nint(slianl(i)) == 2 .and. nint(slifcs(i)) == 0) then tsfanl(i) = tsfice albanl(i,1) = albice albanl(i,2) = albice @@ -5134,15 +5180,15 @@ subroutine newice(slianl,slifcs,tsfanl,tsffcs,len,lsoil, & endif enddo ! - if (me .eq. 0) then - if(kount1.gt.0) then - write(6,*) 'sea ice melted. tsf,alb,zor are filled', - & ' at ',kount1,' points' - endif - if(kount2.gt.0) then - write(6,*) 'sea ice formed. tsf,alb,zor are filled', - & ' at ',kount2,' points' - endif + if (me == 0) then + if (kount1 > 0) then + write(6,*) 'sea ice melted. tsf,alb,zor are filled', + & ' at ',kount1,' points' + endif + if(kount2 > 0) then + write(6,*) 'sea ice formed. tsf,alb,zor are filled', + & ' at ',kount2,' points' + endif endif ! return @@ -5884,7 +5930,7 @@ subroutine albocn(albclm,slmask,albomx,len) real (kind=kind_io8) albomx real (kind=kind_io8) albclm(len,4), slmask(len) do i=1,len - if(slmask(i).eq.0) then + if(slmask(i) == 0) then albclm(i,1) = albomx albclm(i,2) = albomx albclm(i,3) = albomx @@ -6256,7 +6302,7 @@ subroutine setrmsk(kpds5,slmask,igaul,jgaul,wlon,rnlat, & do j = 1, jmax do i = 1, imax if (lbms(i,j)) then - rslmsk(i,j) = 1. + rslmsk(i,j) = 1. end if enddo enddo @@ -6271,7 +6317,7 @@ subroutine setrmsk(kpds5,slmask,igaul,jgaul,wlon,rnlat, & do j = 1, jmax do i = 1, imax if (lbms(i,j)) then - rslmsk(i,j) = 1. + rslmsk(i,j) = 1. end if enddo enddo @@ -6286,7 +6332,7 @@ subroutine setrmsk(kpds5,slmask,igaul,jgaul,wlon,rnlat, & do j = 1, jmax do i = 1, imax if (lbms(i,j)) then - rslmsk(i,j) = 1. + rslmsk(i,j) = 1. end if enddo enddo @@ -6301,7 +6347,7 @@ subroutine setrmsk(kpds5,slmask,igaul,jgaul,wlon,rnlat, & do j = 1, jmax do i = 1, imax if (lbms(i,j)) then - rslmsk(i,j) = 1. + rslmsk(i,j) = 1. end if enddo enddo @@ -6479,9 +6525,9 @@ subroutine setrmsk(kpds5,slmask,igaul,jgaul,wlon,rnlat, & ! veg type is zero over water, use this to get a bitmap. else do j = 1, jmax - do i = 1, imax - rslmsk(i,j) = data(i,j) - enddo + do i = 1, imax + rslmsk(i,j) = data(i,j) + enddo enddo crit=0.1 call rof01(rslmsk,ijmax,'gt',crit) @@ -6542,7 +6588,7 @@ subroutine setrmsk(kpds5,slmask,igaul,jgaul,wlon,rnlat, & do j = 1, jmax do i = 1, imax if (lbms(i,j)) then - rslmsk(i,j) = 1. + rslmsk(i,j) = 1. end if enddo enddo @@ -6877,8 +6923,8 @@ subroutine anomint(tsfan0,tsfclm,tsfcl0,tsfanl,len) end !>\ingroup mod_sfcsub - subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & - & slmask,fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc,& + subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil,slmskl,slmskw, & + & fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, & & fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc, & & fnvetc,fnsotc, & & fnvmnc,fnvmxc,fnslpc,fnabsc, & @@ -6928,7 +6974,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & real (kind=kind_io8) slmskh(imsk,jmsk) real (kind=kind_io8) outlat(len), outlon(len) ! - real (kind=kind_io8) slmask(len), tsfcl0(len) + real (kind=kind_io8) slmskl(len), slmskw(len), tsfcl0(len) real (kind=kind_io8), allocatable :: slmask_noice(:) ! logical lanom, gaus, first @@ -7100,7 +7146,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & do nn=1,2 mon = mon1 if (nn == 2) mon = mon2 - call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmask, + call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmskw, & tsf(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7242,7 +7288,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & if (ialb == 1 .or. ialb == 2) then !cbosu still need facsf and facwf. read them from the production file if ( index(fnalbc2, "tileX.nc") == 0) then ! grib file - call fixrdc(lugb,fnalbc2,kpdalf(1),kpd7,kpd9,slmask + call fixrdc(lugb,fnalbc2,kpdalf(1),kpd7,kpd9,slmskl &, alf,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7251,13 +7297,13 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & & kpdalf(1), alf(:,1), 1, len, me) endif else - call fixrdc(lugb,fnalbc,kpdalf(1),kpd7,kpd9,slmask + call fixrdc(lugb,fnalbc,kpdalf(1),kpd7,kpd9,slmskl &, alf,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) endif do i = 1, len - if(slmask(i).eq.1.) then + if(slmskl(i) == 1.) then alf(i,2) = 100. - alf(i,1) endif enddo @@ -7267,7 +7313,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & if(fntg3c(1:8).ne.' ') then if ( index(fntg3c, "tileX.nc") == 0) then ! grib file kpd7=-1 - call fixrdc(lugb,fntg3c,kpdtg3,kpd7,kpd9,slmask, + call fixrdc(lugb,fntg3c,kpdtg3,kpd7,kpd9,slmskl, & tg3,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7285,7 +7331,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & if(fnvetc(1:8).ne.' ') then if ( index(fnvetc, "tileX.nc") == 0) then ! grib file kpd7=-1 - call fixrdc(lugb,fnvetc,kpdvet,kpd7,kpd9,slmask, + call fixrdc(lugb,fnvetc,kpdvet,kpd7,kpd9,slmskl, & vet,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7312,7 +7358,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & if(fnsotc(1:8).ne.' ') then if ( index(fnsotc, "tileX.nc") == 0) then ! grib file kpd7=-1 - call fixrdc(lugb,fnsotc,kpdsot,kpd7,kpd9,slmask, + call fixrdc(lugb,fnsotc,kpdsot,kpd7,kpd9,slmskl, & sot,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7329,7 +7375,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & if(fnvmnc(1:8).ne.' ') then if ( index(fnvmnc, "tileX.nc") == 0) then ! grib file kpd7=-1 - call fixrdc(lugb,fnvmnc,kpdvmn,kpd7,kpd9,slmask, + call fixrdc(lugb,fnvmnc,kpdvmn,kpd7,kpd9,slmskl, & vmn,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7346,7 +7392,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & if(fnvmxc(1:8).ne.' ') then if ( index(fnvmxc, "tileX.nc") == 0) then ! grib file kpd7=-1 - call fixrdc(lugb,fnvmxc,kpdvmx,kpd7,kpd9,slmask, + call fixrdc(lugb,fnvmxc,kpdvmx,kpd7,kpd9,slmskl, & vmx,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7362,7 +7408,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & if(fnslpc(1:8).ne.' ') then if ( index(fnslpc, "tileX.nc") == 0) then ! grib file kpd7=-1 - call fixrdc(lugb,fnslpc,kpdslp,kpd7,kpd9,slmask, + call fixrdc(lugb,fnslpc,kpdslp,kpd7,kpd9,slmskl, & slp,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7373,12 +7419,12 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & if (me .eq. 0) write(6,*) 'climatological slope read in.' endif ! -! max snow albeod +! max snow albedo ! if(fnabsc(1:8).ne.' ') then if ( index(fnabsc, "tileX.nc") == 0) then ! grib file kpd7=-1 - call fixrdc(lugb,fnabsc,kpdabs,kpd7,kpd9,slmask, + call fixrdc(lugb,fnabsc,kpdabs,kpd7,kpd9,slmskl, & absm,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7392,20 +7438,20 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! is1 = sea1/3 + 1 is2 = sea2/3 + 1 - if (is1 .eq. 5) is1 = 1 - if (is2 .eq. 5) is2 = 1 + if (is1 == 5) is1 = 1 + if (is2 == 5) is2 = 1 do nn=1,2 ! ! seasonal mean climatology - if(nn.eq.1) then - isx=is1 + if(nn == 1) then + isx = is1 else - isx=is2 + isx = is2 endif - if(isx.eq.1) kpd9 = 12 - if(isx.eq.2) kpd9 = 3 - if(isx.eq.3) kpd9 = 6 - if(isx.eq.4) kpd9 = 9 + if(isx == 1) kpd9 = 12 + if(isx == 2) kpd9 = 3 + if(isx == 3) kpd9 = 6 + if(isx == 4) kpd9 = 9 ! ! seasonal mean climatology ! @@ -7417,7 +7463,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & if (ialb == 0) then kpd7=-1 do k = 1, 4 - call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,kpd9,slmask, + call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,kpd9,slmskl, & alb(1,k,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7434,7 +7480,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & if ( index(fnalbc, "tileX.nc") == 0) then ! grib file kpd7=-1 do k = 1, 4 - call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,mon,slmask, + call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,mon,slmskl, & alb(1,k,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7452,7 +7498,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! tsf at the current time t ! kpd7=-1 - call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmask, + call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmskw, & tsf(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7462,7 +7508,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! ! fh2 = fh - deltsfc ! if (fh2 .gt. 0.0) then -! call fixrd(lugb,fntsfc,kpdtsf,lclim,slmask, +! call fixrd(lugb,fntsfc,kpdtsf,lclim,slmskw, ! & iy,im,id,ih,fh2,tsfcl2,len,iret ! &, imsk, jmsk, slmskh, gaus,blno, blto ! &, outlat, outlon, me) @@ -7476,14 +7522,14 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! if(fnwetc(1:8).ne.' ') then kpd7=-1 - call fixrdc(lugb,fnwetc,kpdwet,kpd7,mon,slmask, + call fixrdc(lugb,fnwetc,kpdwet,kpd7,mon,slmskl, & wet(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) elseif(fnsmcc(1:8).ne.' ') then if (index(fnsmcc,'global_soilmcpc.1x1.grb') /= 0) then ! the old climo data kpd7=-1 - call fixrdc(lugb,fnsmcc,kpdsmc,kpd7,mon,slmask, + call fixrdc(lugb,fnsmcc,kpdsmc,kpd7,mon,slmskl, & smc(1,lsoil,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7496,7 +7542,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! points. so for efficiency, don't have fixrdc try to ! find a value at landice points as defined by the vet type (vet). allocate(slmask_noice(len)) - slmask_noice=1.0 + slmask_noice = 1.0 do i = 1, len if (nint(vet(i)) < 1 .or. & nint(vet(i)) == landice_cat) then @@ -7525,7 +7571,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! if(fnstcc(1:8).ne.' ') then kpd7=-1 - call fixrdc(lugb,fnstcc,kpdstc,kpd7,mon,slmask, + call fixrdc(lugb,fnstcc,kpdstc,kpd7,mon,slmskl, & stc(1,lsoil,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7540,12 +7586,12 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! kpd7=-1 if(fnacnc(1:8).ne.' ') then - call fixrdc(lugb,fnacnc,kpdacn,kpd7,mon,slmask, + call fixrdc(lugb,fnacnc,kpdacn,kpd7,mon,slmskw, & acn(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) elseif(fnaisc(1:8).ne.' ') then - call fixrdc(lugb,fnaisc,kpdais,kpd7,mon,slmask, + call fixrdc(lugb,fnaisc,kpdais,kpd7,mon,slmskw, & ais(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7558,7 +7604,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! snow depth ! kpd7=-1 - call fixrdc(lugb,fnsnoc,kpdsno,kpd7,mon,slmask, + call fixrdc(lugb,fnsnoc,kpdsno,kpd7,mon,slmskl, & sno(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7567,7 +7613,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! if(fnscvc(1:8).ne.' ') then kpd7=-1 - call fixrdc(lugb,fnscvc,kpdscv,kpd7,mon,slmask, + call fixrdc(lugb,fnscvc,kpdscv,kpd7,mon,slmskl, & scv(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7586,7 +7632,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & endif else kpd7=-1 - call fixrdc(lugb,fnzorc,kpdzor,kpd7,mon,slmask, + call fixrdc(lugb,fnzorc,kpdzor,kpd7,mon,slmskl, & zor(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7606,7 +7652,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & if(fnvegc(1:8).ne.' ') then if ( index(fnvegc, "tileX.nc") == 0) then ! grib file kpd7=-1 - call fixrdc(lugb,fnvegc,kpdveg,kpd7,mon,slmask, + call fixrdc(lugb,fnvegc,kpdveg,kpd7,mon,slmskl, & veg(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7655,7 +7701,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & k1 = mod(k2,2) + 1 mon = mon1s kpd7=-1 - call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmask, + call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmskw, & tsf(1,k1),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7695,7 +7741,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & if (ialb == 0) then kpd7=-1 do k = 1, 4 - call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,kpd9,slmask + call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,kpd9,slmskl &, alb(1,k,m2),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7722,7 +7768,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & if ( index(fnalbc, "tileX.nc") == 0) then ! grib file kpd7 = -1 do k = 1, 4 - call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,mon,slmask, + call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,mon,slmskl, & alb(1,k,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7738,7 +7784,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! tsf at the current time t ! kpd7 = -1 - call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmask, + call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmskw, & tsf(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7747,14 +7793,14 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! if (fnwetc(1:8).ne.' ') then kpd7=-1 - call fixrdc(lugb,fnwetc,kpdwet,kpd7,mon,slmask, + call fixrdc(lugb,fnwetc,kpdwet,kpd7,mon,slmskl, & wet(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) elseif (fnsmcc(1:8).ne.' ') then if (index(fnsmcc,'global_soilmcpc.1x1.grb') /= 0) then ! the old climo data kpd7=-1 - call fixrdc(lugb,fnsmcc,kpdsmc,kpd7,mon,slmask, + call fixrdc(lugb,fnsmcc,kpdsmc,kpd7,mon,slmskl, & smc(1,lsoil,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7796,12 +7842,12 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! kpd7 = -1 if (fnacnc(1:8).ne.' ') then - call fixrdc(lugb,fnacnc,kpdacn,kpd7,mon,slmask, + call fixrdc(lugb,fnacnc,kpdacn,kpd7,mon,slmskw, & acn(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) elseif (fnaisc(1:8).ne.' ') then - call fixrdc(lugb,fnaisc,kpdais,kpd7,mon,slmask, + call fixrdc(lugb,fnaisc,kpdais,kpd7,mon,slmskw, & ais(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7814,7 +7860,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! snow depth ! kpd7=-1 - call fixrdc(lugb,fnsnoc,kpdsno,kpd7,mon,slmask, + call fixrdc(lugb,fnsnoc,kpdsno,kpd7,mon,slmskl, & sno(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7823,7 +7869,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! if (fnscvc(1:8).ne.' ') then kpd7=-1 - call fixrdc(lugb,fnscvc,kpdscv,kpd7,mon,slmask, + call fixrdc(lugb,fnscvc,kpdscv,kpd7,mon,slmskl, & scv(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7842,7 +7888,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & endif else kpd7=-1 - call fixrdc(lugb,fnzorc,kpdzor,kpd7,mon,slmask, + call fixrdc(lugb,fnzorc,kpdzor,kpd7,mon,slmskl, & zor(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7853,7 +7899,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & if (fnvegc(1:8) .ne. ' ') then if ( index(fnvegc, "tileX.nc") == 0) then ! grib file kpd7=-1 - call fixrdc(lugb,fnvegc,kpdveg,kpd7,mon,slmask, + call fixrdc(lugb,fnvegc,kpdveg,kpd7,mon,slmskl, & veg(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -8368,8 +8414,8 @@ subroutine fixrdc(lugb,fngrib,kpds5,kpds7,mon,slmask, & inttyp = 0 if(kpds5.eq.225) inttyp = 1 if(kpds5.eq.230) inttyp = 1 - if(kpds5.eq.236) inttyp = 1 - if(kpds5.eq.224) inttyp = 1 + if(kpds5.eq.236) inttyp = 1 + if(kpds5.eq.224) inttyp = 1 if (me .eq. 0) then if(inttyp.eq.1) print *, ' nearest grid point used' &, ' kpds5=',kpds5, ' lmask = ',lmask @@ -8401,7 +8447,7 @@ subroutine fixrda(lugb,fngrib,kpds5,slmask, & integer nrepmx,nvalid,imo,iyr,idy,jret,ihr,nrept,lskip,lugi, & & lgrib,j,ndata,i,inttyp,jmax,imax,ijmax,ij,jday,len,iret, & & jmsk,imsk,ih,kpds5,lugb,iy,id,im,jh,jd,jdoy,jdow,jm,me, & - & monend,jy,iy4,kmami,iret2,jj,w3kindreal,w3kindint + & monend,jy,iy4,kmami,iret2,jj,w3kindreal,w3kindint real (kind=kind_io8) rnlat,rslat,wlon,elon,dlon,dlat,fh,blno, & & rjday,blto ! diff --git a/physics/shalcnv.meta b/physics/shalcnv.meta index 7986d28f8..38436c8bd 100644 --- a/physics/shalcnv.meta +++ b/physics/shalcnv.meta @@ -334,8 +334,8 @@ intent = in optional = F [ncloud] - standard_name = number_of_hydrometeors - long_name = number of hydrometeors + standard_name = number_of_cloud_condensate_types + long_name = number of cloud condensate types units = count dimensions = () type = integer