diff --git a/atmos_cubed_sphere/driver/fvGFS/atmosphere.F90 b/atmos_cubed_sphere/driver/fvGFS/atmosphere.F90 index 5139037d3..2e19ccb12 100644 --- a/atmos_cubed_sphere/driver/fvGFS/atmosphere.F90 +++ b/atmos_cubed_sphere/driver/fvGFS/atmosphere.F90 @@ -149,15 +149,15 @@ module atmosphere_mod close_file, error_mesg, FATAL, & check_nml_error, stdlog, & write_version_number, & - set_domain, & - read_data, & + set_domain, & + read_data, & mpp_clock_id, mpp_clock_begin, & mpp_clock_end, CLOCK_SUBCOMPONENT, & clock_flag_default, nullify_domain -use mpp_mod, only: mpp_error, stdout, FATAL, NOTE, & - input_nml_file, mpp_root_pe, & - mpp_npes, mpp_pe, mpp_chksum, & - mpp_get_current_pelist, & +use mpp_mod, only: mpp_error, stdout, FATAL, NOTE, & + input_nml_file, mpp_root_pe, & + mpp_npes, mpp_pe, mpp_chksum, & + mpp_get_current_pelist, & mpp_set_current_pelist use mpp_parameter_mod, only: EUPDATE, WUPDATE, SUPDATE, NUPDATE use mpp_domains_mod, only: domain2d, mpp_update_domains @@ -186,11 +186,10 @@ module atmosphere_mod use fv_sg_mod, only: fv_subgrid_z use fv_update_phys_mod, only: fv_update_phys use fv_nwp_nudge_mod, only: fv_nwp_nudge_init, fv_nwp_nudge_end, do_adiabatic_init -use fv_regional_mod, only: start_regional_restart, read_new_bc_data -use fv_regional_mod, only: a_step, p_step -use fv_regional_mod, only: current_time_in_seconds +use fv_regional_mod, only: start_regional_restart, read_new_bc_data, & + a_step, p_step, current_time_in_seconds -use mpp_domains_mod, only: mpp_get_data_domain, mpp_get_compute_domain +use mpp_domains_mod, only: mpp_get_data_domain, mpp_get_compute_domain implicit none private @@ -200,16 +199,16 @@ module atmosphere_mod atmosphere_dynamics, atmosphere_state_update !--- utility routines -public :: atmosphere_resolution, atmosphere_grid_bdry, & - atmosphere_grid_ctr, atmosphere_domain, & - atmosphere_control_data, atmosphere_pref, & - atmosphere_diag_axes, atmosphere_etalvls, & - atmosphere_hgt, atmosphere_scalar_field_halo, & +public :: atmosphere_resolution, atmosphere_grid_bdry, & + atmosphere_grid_ctr, atmosphere_domain, & + atmosphere_control_data, atmosphere_pref, & + atmosphere_diag_axes, atmosphere_etalvls, & + atmosphere_hgt, atmosphere_scalar_field_halo, & ! experimental APIs not ready for use ! atmosphere_tracer_postinit, & - atmosphere_diss_est, & ! dissipation estimate for SKEB + atmosphere_diss_est, & ! dissipation estimate for SKEB atmosphere_get_bottom_layer, & - atmosphere_nggps_diag, & + atmosphere_nggps_diag, & set_atmosphere_pelist !--- physics/radiation data exchange routines @@ -239,7 +238,7 @@ module atmosphere_mod integer, dimension(:), allocatable :: id_tracerdt_dyn integer :: sphum, liq_wat, rainwat, ice_wat, snowwat, graupel ! condensate species tracer indices - integer :: mytile = 1 + integer :: mytile = 1 integer :: p_split = 1 integer, allocatable :: pelist(:) logical, allocatable :: grids_on_this_pe(:) @@ -251,7 +250,7 @@ module atmosphere_mod !---dynamics tendencies for use in fv_subgrid_z and during fv_update_phys real, allocatable, dimension(:,:,:) :: u_dt, v_dt, t_dt - real, allocatable :: pref(:,:), dum1d(:) + real, allocatable :: pref(:,:), dum1d(:) logical :: first_diag = .true. @@ -267,10 +266,10 @@ subroutine atmosphere_init (Time_init, Time, Time_step, Grid_box, area) real(kind=kind_phys), pointer, dimension(:,:), intent(inout) :: area !--- local variables --- integer :: i, n - integer :: itrac +! integer :: itrac logical :: do_atmos_nudge character(len=32) :: tracer_name, tracer_units - real :: ps1, ps2 + real :: ps1, ps2 current_time_in_seconds = time_type_to_real( Time - Time_init ) if (mpp_pe() == 0) write(*,"('atmosphere_init: current_time_seconds = ',f9.1)")current_time_in_seconds @@ -299,9 +298,9 @@ subroutine atmosphere_init (Time_init, Time, Time_step, Grid_box, area) Atm(mytile)%Time_init = Time_init - a_step=0 - if(Atm(mytile)%flagstruct%warm_start)then - a_step=nint(current_time_in_seconds/dt_atmos) + a_step = 0 + if(Atm(mytile)%flagstruct%warm_start) then + a_step = nint(current_time_in_seconds/dt_atmos) endif !----- write version and namelist to log file ----- @@ -363,8 +362,8 @@ subroutine atmosphere_init (Time_init, Time, Time_step, Grid_box, area) Grid_box%en1 (:, isc:iec , jsc:jec+1) = Atm(mytile)%gridstruct%en1 (:, isc:iec , jsc:jec+1) Grid_box%en2 (:, isc:iec+1, jsc:jec ) = Atm(mytile)%gridstruct%en2 (:, isc:iec+1, jsc:jec ) do i = 1,3 - Grid_box%vlon (i, isc:iec , jsc:jec ) = Atm(mytile)%gridstruct%vlon (isc:iec , jsc:jec, i ) - Grid_box%vlat (i, isc:iec , jsc:jec ) = Atm(mytile)%gridstruct%vlat (isc:iec , jsc:jec, i ) + Grid_box%vlon(i, isc:iec , jsc:jec ) = Atm(mytile)%gridstruct%vlon (isc:iec , jsc:jec, i ) + Grid_box%vlat(i, isc:iec , jsc:jec ) = Atm(mytile)%gridstruct%vlat (isc:iec , jsc:jec, i ) enddo allocate (area(isc:iec , jsc:jec )) area(isc:iec,jsc:jec) = Atm(mytile)%gridstruct%area_64(isc:iec,jsc:jec) @@ -403,7 +402,7 @@ subroutine atmosphere_init (Time_init, Time, Time_step, Grid_box, area) ! --- initiate the start for a restarted regional forecast if ( Atm(mytile)%gridstruct%regional .and. Atm(mytile)%flagstruct%warm_start ) then - call start_regional_restart(Atm(1), & + call start_regional_restart(Atm(1), & isc, iec, jsc, jec, & isd, ied, jsd, jed ) endif @@ -413,7 +412,7 @@ subroutine atmosphere_init (Time_init, Time, Time_step, Grid_box, area) if ( .not. Atm(mytile)%flagstruct%hydrostatic ) then call prt_maxmin('Before adi: W', Atm(mytile)%w, isc, iec, jsc, jec, Atm(mytile)%ng, npz, 1.) endif - call adiabatic_init(zvir,Atm(mytile)%flagstruct%nudge_dz) + call adiabatic_init(zvir,Atm(mytile)%flagstruct%nudge_dz,time) if ( .not. Atm(mytile)%flagstruct%hydrostatic ) then call prt_maxmin('After adi: W', Atm(mytile)%w, isc, iec, jsc, jec, Atm(mytile)%ng, npz, 1.) ! Not nested? @@ -444,16 +443,16 @@ subroutine p_adi(km, ng, ifirst, ilast, jfirst, jlast, ptop, & integer, intent(in):: km, ng integer, intent(in):: ifirst, ilast !< Longitude strip integer, intent(in):: jfirst, jlast !< Latitude strip - logical, intent(in):: hydrostatic - real, intent(in):: ptop - real, intent(in):: pt(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng, km) - real, intent(in):: delp(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng, km) + logical, intent(in):: hydrostatic + real, intent(in):: ptop + real, intent(in):: pt(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng, km) + real, intent(in):: delp(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng, km) ! Output: - real, intent(out) :: ps(ifirst-ng:ilast+ng, jfirst-ng:jlast+ng) - real, intent(out) :: pk(ifirst:ilast, jfirst:jlast, km+1) - real, intent(out) :: pe(ifirst-1:ilast+1,km+1,jfirst-1:jlast+1) !< Ghosted Edge pressure - real, intent(out) :: peln(ifirst:ilast, km+1, jfirst:jlast) !< Edge pressure - real, intent(out) :: pkz(ifirst:ilast, jfirst:jlast, km) + real, intent(out) :: ps(ifirst-ng:ilast+ng, jfirst-ng:jlast+ng) + real, intent(out) :: pk(ifirst:ilast, jfirst:jlast, km+1) + real, intent(out) :: pe(ifirst-1:ilast+1,km+1,jfirst-1:jlast+1) !< Ghosted Edge pressure + real, intent(out) :: peln(ifirst:ilast, km+1, jfirst:jlast) !< Edge pressure + real, intent(out) :: pkz(ifirst:ilast, jfirst:jlast, km) ! Local real pek integer i, j, k @@ -471,9 +470,9 @@ subroutine p_adi(km, ng, ifirst, ilast, jfirst, jlast, ptop, & do k=2,km+1 do i=ifirst,ilast - pe(i,k,j) = pe(i,k-1,j) + delp(i,j,k-1) + pe(i,k,j) = pe(i,k-1,j) + delp(i,j,k-1) peln(i,k,j) = log(pe(i,k,j)) - pk(i,j,k) = exp( kappa*peln(i,k,j) ) + pk(i,j,k) = exp( kappa*peln(i,k,j) ) enddo enddo @@ -497,11 +496,10 @@ end subroutine p_adi !! of the FV3 dynamical core responsible for executing a "dynamics" step. subroutine atmosphere_dynamics ( Time ) type(time_type),intent(in) :: Time - integer :: itrac, n, psc - integer :: k, w_diff, nt_dyn + integer :: n, psc, atmos_time_step + integer :: k, w_diff, nt_dyn, n_split_loc, seconds, days type(time_type) :: atmos_time - integer :: atmos_time_step !---- Call FV dynamics ----- @@ -509,6 +507,18 @@ subroutine atmosphere_dynamics ( Time ) n = mytile + call get_time (time, seconds, days) +! if (seconds < 10800 .and. days == 0) then +! n_split_loc = (Atm(n)%flagstruct%n_split * 3) / 2 + if (seconds < nint(3600*Atm(n)%flagstruct%fhouri) .and. Atm(n)%flagstruct%fac_n_spl > 1.0) then + n_split_loc = nint(Atm(n)%flagstruct%n_split * Atm(n)%flagstruct%fac_n_spl) + else + n_split_loc = Atm(n)%flagstruct%n_split + endif + +! write(0,*)' before calling init n_split_loc=',n_split_loc,' seconds=',seconds,' days=',days,& +! ' n_split=',Atm(mytile)%flagstruct%n_split,' mytile=',mytile + a_step = a_step + 1 ! !*** If this is a regional run then read in the next boundary data when it is time. @@ -523,31 +533,32 @@ subroutine atmosphere_dynamics ( Time ) p_step = psc call timing_on('fv_dynamics') !uc/vc only need be same on coarse grid? However BCs do need to be the same - call fv_dynamics(npx, npy, npz, nq, Atm(n)%ng, dt_atmos/real(abs(p_split)),& - Atm(n)%flagstruct%consv_te, Atm(n)%flagstruct%fill, & - Atm(n)%flagstruct%reproduce_sum, kappa, cp_air, zvir,& - Atm(n)%ptop, Atm(n)%ks, nq, & - Atm(n)%flagstruct%n_split, Atm(n)%flagstruct%q_split,& - Atm(n)%u, Atm(n)%v, Atm(n)%w, Atm(n)%delz, & - Atm(n)%flagstruct%hydrostatic, & - Atm(n)%pt, Atm(n)%delp, Atm(n)%q, Atm(n)%ps, & - Atm(n)%pe, Atm(n)%pk, Atm(n)%peln, & - Atm(n)%pkz, Atm(n)%phis, Atm(n)%q_con, & - Atm(n)%omga, Atm(n)%ua, Atm(n)%va, Atm(n)%uc, & - Atm(n)%vc, Atm(n)%ak, Atm(n)%bk, Atm(n)%mfx, & - Atm(n)%mfy, Atm(n)%cx, Atm(n)%cy, Atm(n)%ze0, & - Atm(n)%flagstruct%hybrid_z, & - Atm(n)%gridstruct, Atm(n)%flagstruct, & - Atm(n)%neststruct, Atm(n)%idiag, Atm(n)%bd, & - Atm(n)%parent_grid, Atm(n)%domain,Atm(n)%diss_est) - - call timing_off('fv_dynamics') - - if (ngrids > 1 .and. (psc < p_split .or. p_split < 0)) then - call timing_on('TWOWAY_UPDATE') - call twoway_nesting(Atm, ngrids, grids_on_this_pe, zvir) - call timing_off('TWOWAY_UPDATE') - endif + call fv_dynamics(npx, npy, npz, nq, Atm(n)%ng, dt_atmos/real(abs(p_split)),& + Atm(n)%flagstruct%consv_te, Atm(n)%flagstruct%fill, & + Atm(n)%flagstruct%reproduce_sum, kappa, cp_air, zvir, & + Atm(n)%ptop, Atm(n)%ks, nq, & + n_split_loc, Atm(n)%flagstruct%q_split, & +! Atm(n)%flagstruct%n_split, Atm(n)%flagstruct%q_split, & + Atm(n)%u, Atm(n)%v, Atm(n)%w, Atm(n)%delz, & + Atm(n)%flagstruct%hydrostatic, & + Atm(n)%pt , Atm(n)%delp, Atm(n)%q, Atm(n)%ps, & + Atm(n)%pe, Atm(n)%pk, Atm(n)%peln, & + Atm(n)%pkz, Atm(n)%phis, Atm(n)%q_con, & + Atm(n)%omga, Atm(n)%ua, Atm(n)%va, Atm(n)%uc, & + Atm(n)%vc, Atm(n)%ak, Atm(n)%bk, Atm(n)%mfx, & + Atm(n)%mfy , Atm(n)%cx, Atm(n)%cy, Atm(n)%ze0, & + Atm(n)%flagstruct%hybrid_z, & + Atm(n)%gridstruct, Atm(n)%flagstruct, & + Atm(n)%neststruct, Atm(n)%idiag, Atm(n)%bd, & + Atm(n)%parent_grid, Atm(n)%domain,Atm(n)%diss_est) + + call timing_off('fv_dynamics') + + if (ngrids > 1 .and. (psc < p_split .or. p_split < 0)) then + call timing_on('TWOWAY_UPDATE') + call twoway_nesting(Atm, ngrids, grids_on_this_pe, zvir) + call timing_off('TWOWAY_UPDATE') + endif end do !p_split call mpp_clock_end (id_dynam) @@ -1160,8 +1171,8 @@ end subroutine atmosphere_get_bottom_layer subroutine get_stock_pe(index, value) - integer, intent(in) :: index - real, intent(out) :: value + integer, intent(in) :: index + real, intent(out) :: value #ifdef USE_STOCK include 'stock.inc' @@ -1432,9 +1443,10 @@ end subroutine atmosphere_state_update !>@brief The subroutine 'adiabatic_init' is an optional step during initialization !! to pre-condition a solution via backward-forward steps with capability for various !! nudgings. - subroutine adiabatic_init(zvir,nudge_dz) + subroutine adiabatic_init(zvir,nudge_dz,time) + type(time_type),intent(in) :: Time real, allocatable, dimension(:,:,:):: u0, v0, t0, dz0, dp0 - real, intent(in):: zvir + real, intent(in) :: zvir logical, intent(inout):: nudge_dz ! real, parameter:: wt = 1. ! was 2. real, parameter:: wt = 2. @@ -1449,7 +1461,7 @@ subroutine adiabatic_init(zvir,nudge_dz) real, parameter:: q3000_h2o = 3.0E-6 real:: xt, p00, q00 integer:: isc, iec, jsc, jec, npz - integer:: m, n, i,j,k, ngc + integer:: m, n, i,j,k, ngc, n_split_loc, days character(len=80) :: errstr @@ -1518,151 +1530,165 @@ subroutine adiabatic_init(zvir,nudge_dz) endif enddo + call get_time (time, seconds, days) + if (seconds < nint(3600*Atm(mytile)%flagstruct%fhouri) .and. Atm(mytile)%flagstruct%fac_n_spl > 1.0) then + n_split_loc = nint(Atm(mytile)%flagstruct%n_split * Atm(mytile)%flagstruct%fac_n_spl) + else + n_split_loc = Atm(mytile)%flagstruct%n_split + endif + +! write(0,*)' before calling init n_split_loc=',n_split_loc,' seconds=',seconds,' days=',days,& +! ' n_split=',Atm(mytile)%flagstruct%n_split,' mytile=',mytile + do m=1,Atm(mytile)%flagstruct%na_init ! Forward call - call fv_dynamics(Atm(mytile)%npx, Atm(mytile)%npy, npz, nq, Atm(mytile)%ng, dt_atmos, 0., & - Atm(mytile)%flagstruct%fill, Atm(mytile)%flagstruct%reproduce_sum, kappa, cp_air, zvir, & - Atm(mytile)%ptop, Atm(mytile)%ks, nq, Atm(mytile)%flagstruct%n_split, & - Atm(mytile)%flagstruct%q_split, Atm(mytile)%u, Atm(mytile)%v, Atm(mytile)%w, & - Atm(mytile)%delz, Atm(mytile)%flagstruct%hydrostatic, & - Atm(mytile)%pt, Atm(mytile)%delp, Atm(mytile)%q, Atm(mytile)%ps, & - Atm(mytile)%pe, Atm(mytile)%pk, Atm(mytile)%peln, Atm(mytile)%pkz, Atm(mytile)%phis, & - Atm(mytile)%q_con, Atm(mytile)%omga, Atm(mytile)%ua, Atm(mytile)%va, Atm(mytile)%uc, Atm(mytile)%vc, & - Atm(mytile)%ak, Atm(mytile)%bk, Atm(mytile)%mfx, Atm(mytile)%mfy, & - Atm(mytile)%cx, Atm(mytile)%cy, Atm(mytile)%ze0, Atm(mytile)%flagstruct%hybrid_z, & - Atm(mytile)%gridstruct, Atm(mytile)%flagstruct, & - Atm(mytile)%neststruct, Atm(mytile)%idiag, Atm(mytile)%bd, Atm(mytile)%parent_grid, & - Atm(mytile)%domain,Atm(mytile)%diss_est) + call fv_dynamics(Atm(mytile)%npx, Atm(mytile)%npy, npz, nq, Atm(mytile)%ng, dt_atmos, 0., & + Atm(mytile)%flagstruct%fill, Atm(mytile)%flagstruct%reproduce_sum, kappa, cp_air, zvir, & +! Atm(mytile)%ptop, Atm(mytile)%ks, nq, Atm(mytile)%flagstruct%n_split, & + Atm(mytile)%ptop, Atm(mytile)%ks, nq, n_split_loc, & + Atm(mytile)%flagstruct%q_split, Atm(mytile)%u, Atm(mytile)%v, Atm(mytile)%w, & + Atm(mytile)%delz, Atm(mytile)%flagstruct%hydrostatic, & + Atm(mytile)%pt, Atm(mytile)%delp, Atm(mytile)%q, Atm(mytile)%ps, & + Atm(mytile)%pe, Atm(mytile)%pk, Atm(mytile)%peln, Atm(mytile)%pkz, Atm(mytile)%phis, & + Atm(mytile)%q_con, Atm(mytile)%omga, Atm(mytile)%ua, Atm(mytile)%va, Atm(mytile)%uc, Atm(mytile)%vc, & + Atm(mytile)%ak, Atm(mytile)%bk, Atm(mytile)%mfx, Atm(mytile)%mfy, & + Atm(mytile)%cx, Atm(mytile)%cy, Atm(mytile)%ze0, Atm(mytile)%flagstruct%hybrid_z, & + Atm(mytile)%gridstruct, Atm(mytile)%flagstruct, & + Atm(mytile)%neststruct, Atm(mytile)%idiag, Atm(mytile)%bd, Atm(mytile)%parent_grid, & + Atm(mytile)%domain,Atm(mytile)%diss_est) ! Backward - call fv_dynamics(Atm(mytile)%npx, Atm(mytile)%npy, npz, nq, Atm(mytile)%ng, -dt_atmos, 0., & - Atm(mytile)%flagstruct%fill, Atm(mytile)%flagstruct%reproduce_sum, kappa, cp_air, zvir, & - Atm(mytile)%ptop, Atm(mytile)%ks, nq, Atm(mytile)%flagstruct%n_split, & - Atm(mytile)%flagstruct%q_split, Atm(mytile)%u, Atm(mytile)%v, Atm(mytile)%w, & - Atm(mytile)%delz, Atm(mytile)%flagstruct%hydrostatic, & - Atm(mytile)%pt, Atm(mytile)%delp, Atm(mytile)%q, Atm(mytile)%ps, & - Atm(mytile)%pe, Atm(mytile)%pk, Atm(mytile)%peln, Atm(mytile)%pkz, Atm(mytile)%phis, & - Atm(mytile)%q_con, Atm(mytile)%omga, Atm(mytile)%ua, Atm(mytile)%va, Atm(mytile)%uc, Atm(mytile)%vc, & - Atm(mytile)%ak, Atm(mytile)%bk, Atm(mytile)%mfx, Atm(mytile)%mfy, & - Atm(mytile)%cx, Atm(mytile)%cy, Atm(mytile)%ze0, Atm(mytile)%flagstruct%hybrid_z, & - Atm(mytile)%gridstruct, Atm(mytile)%flagstruct, & - Atm(mytile)%neststruct, Atm(mytile)%idiag, Atm(mytile)%bd, Atm(mytile)%parent_grid, & - Atm(mytile)%domain,Atm(mytile)%diss_est) + call fv_dynamics(Atm(mytile)%npx, Atm(mytile)%npy, npz, nq, Atm(mytile)%ng, -dt_atmos, 0., & + Atm(mytile)%flagstruct%fill, Atm(mytile)%flagstruct%reproduce_sum, kappa, cp_air, zvir, & +! Atm(mytile)%ptop, Atm(mytile)%ks, nq, Atm(mytile)%flagstruct%n_split, & + Atm(mytile)%ptop, Atm(mytile)%ks, nq, n_split_loc, & + Atm(mytile)%flagstruct%q_split, Atm(mytile)%u, Atm(mytile)%v, Atm(mytile)%w, & + Atm(mytile)%delz, Atm(mytile)%flagstruct%hydrostatic, & + Atm(mytile)%pt, Atm(mytile)%delp, Atm(mytile)%q, Atm(mytile)%ps, & + Atm(mytile)%pe, Atm(mytile)%pk, Atm(mytile)%peln, Atm(mytile)%pkz, Atm(mytile)%phis, & + Atm(mytile)%q_con, Atm(mytile)%omga, Atm(mytile)%ua, Atm(mytile)%va, Atm(mytile)%uc, Atm(mytile)%vc, & + Atm(mytile)%ak, Atm(mytile)%bk, Atm(mytile)%mfx, Atm(mytile)%mfy, & + Atm(mytile)%cx, Atm(mytile)%cy, Atm(mytile)%ze0, Atm(mytile)%flagstruct%hybrid_z, & + Atm(mytile)%gridstruct, Atm(mytile)%flagstruct, & + Atm(mytile)%neststruct, Atm(mytile)%idiag, Atm(mytile)%bd, Atm(mytile)%parent_grid, & + Atm(mytile)%domain,Atm(mytile)%diss_est) !Nudging back to IC !$omp parallel do default (none) & !$omp shared (pref, npz, jsc, jec, isc, iec, n, sphum, Atm, u0, v0, t0, dp0, xt, zvir, mytile, nudge_dz, dz0) & !$omp private (i, j, k, p00, q00) do k=1,npz - do j=jsc,jec+1 - do i=isc,iec - Atm(mytile)%u(i,j,k) = xt*(Atm(mytile)%u(i,j,k) + wt*u0(i,j,k)) - enddo - enddo - do j=jsc,jec - do i=isc,iec+1 - Atm(mytile)%v(i,j,k) = xt*(Atm(mytile)%v(i,j,k) + wt*v0(i,j,k)) - enddo - enddo - if( Atm(mytile)%flagstruct%nudge_qv ) then + do j=jsc,jec+1 + do i=isc,iec + Atm(mytile)%u(i,j,k) = xt*(Atm(mytile)%u(i,j,k) + wt*u0(i,j,k)) + enddo + enddo + do j=jsc,jec + do i=isc,iec+1 + Atm(mytile)%v(i,j,k) = xt*(Atm(mytile)%v(i,j,k) + wt*v0(i,j,k)) + enddo + enddo + if( Atm(mytile)%flagstruct%nudge_qv ) then ! SJL note: Nudging water vaport towards HALOE climatology: ! In case of better IC (IFS) this step may not be necessary - p00 = Atm(mytile)%pe(isc,k,jsc) - if ( p00 < 30.E2 ) then - if ( p00 < 1. ) then - q00 = q1_h2o - elseif ( p00 <= 7. .and. p00 >= 1. ) then - q00 = q1_h2o + (q7_h2o-q1_h2o)*log(pref(k,1)/1.)/log(7.) - elseif ( p00 < 100. .and. p00 >= 7. ) then - q00 = q7_h2o + (q100_h2o-q7_h2o)*log(pref(k,1)/7.)/log(100./7.) - elseif ( p00 < 1000. .and. p00 >= 100. ) then - q00 = q100_h2o + (q1000_h2o-q100_h2o)*log(pref(k,1)/1.E2)/log(10.) - elseif ( p00 < 2000. .and. p00 >= 1000. ) then - q00 = q1000_h2o + (q2000_h2o-q1000_h2o)*log(pref(k,1)/1.E3)/log(2.) - else - q00 = q2000_h2o + (q3000_h2o-q2000_h2o)*log(pref(k,1)/2.E3)/log(1.5) - endif - do j=jsc,jec - do i=isc,iec - Atm(mytile)%q(i,j,k,sphum) = xt*(Atm(mytile)%q(i,j,k,sphum) + wt*q00) - enddo - enddo - endif - endif - if ( nudge_dz ) then - do j=jsc,jec - do i=isc,iec - Atm(mytile)%delp(i,j,k) = xt*(Atm(mytile)%delp(i,j,k) + wt*dp0(i,j,k)) - Atm(mytile)%delz(i,j,k) = xt*(Atm(mytile)%delz(i,j,k) + wt*dz0(i,j,k)) - enddo - enddo - else - do j=jsc,jec + p00 = Atm(mytile)%pe(isc,k,jsc) + if ( p00 < 30.E2 ) then + if ( p00 < 1. ) then + q00 = q1_h2o + elseif ( p00 <= 7. .and. p00 >= 1. ) then + q00 = q1_h2o + (q7_h2o-q1_h2o)*log(pref(k,1)/1.)/log(7.) + elseif ( p00 < 100. .and. p00 >= 7. ) then + q00 = q7_h2o + (q100_h2o-q7_h2o)*log(pref(k,1)/7.)/log(100./7.) + elseif ( p00 < 1000. .and. p00 >= 100. ) then + q00 = q100_h2o + (q1000_h2o-q100_h2o)*log(pref(k,1)/1.E2)/log(10.) + elseif ( p00 < 2000. .and. p00 >= 1000. ) then + q00 = q1000_h2o + (q2000_h2o-q1000_h2o)*log(pref(k,1)/1.E3)/log(2.) + else + q00 = q2000_h2o + (q3000_h2o-q2000_h2o)*log(pref(k,1)/2.E3)/log(1.5) + endif + do j=jsc,jec do i=isc,iec - Atm(mytile)%pt(i,j,k) = xt*(Atm(mytile)%pt(i,j,k) + wt*t0(i,j,k)/(1.+zvir*Atm(mytile)%q(i,j,k,sphum))) - Atm(mytile)%delp(i,j,k) = xt*(Atm(mytile)%delp(i,j,k) + wt*dp0(i,j,k)) + Atm(mytile)%q(i,j,k,sphum) = xt*(Atm(mytile)%q(i,j,k,sphum) + wt*q00) enddo - enddo - endif + enddo + endif + endif + if ( nudge_dz ) then + do j=jsc,jec + do i=isc,iec + Atm(mytile)%delp(i,j,k) = xt*(Atm(mytile)%delp(i,j,k) + wt*dp0(i,j,k)) + Atm(mytile)%delz(i,j,k) = xt*(Atm(mytile)%delz(i,j,k) + wt*dz0(i,j,k)) + enddo + enddo + else + do j=jsc,jec + do i=isc,iec + Atm(mytile)%pt(i,j,k) = xt*(Atm(mytile)%pt(i,j,k) + wt*t0(i,j,k)/(1.+zvir*Atm(mytile)%q(i,j,k,sphum))) + Atm(mytile)%delp(i,j,k) = xt*(Atm(mytile)%delp(i,j,k) + wt*dp0(i,j,k)) + enddo + enddo + endif enddo ! Backward - call fv_dynamics(Atm(mytile)%npx, Atm(mytile)%npy, npz, nq, Atm(mytile)%ng, -dt_atmos, 0., & - Atm(mytile)%flagstruct%fill, Atm(mytile)%flagstruct%reproduce_sum, kappa, cp_air, zvir, & - Atm(mytile)%ptop, Atm(mytile)%ks, nq, Atm(mytile)%flagstruct%n_split, & - Atm(mytile)%flagstruct%q_split, Atm(mytile)%u, Atm(mytile)%v, Atm(mytile)%w, & - Atm(mytile)%delz, Atm(mytile)%flagstruct%hydrostatic, & - Atm(mytile)%pt, Atm(mytile)%delp, Atm(mytile)%q, Atm(mytile)%ps, & - Atm(mytile)%pe, Atm(mytile)%pk, Atm(mytile)%peln, Atm(mytile)%pkz, Atm(mytile)%phis, & - Atm(mytile)%q_con, Atm(mytile)%omga, Atm(mytile)%ua, Atm(mytile)%va, Atm(mytile)%uc, Atm(mytile)%vc, & - Atm(mytile)%ak, Atm(mytile)%bk, Atm(mytile)%mfx, Atm(mytile)%mfy, & - Atm(mytile)%cx, Atm(mytile)%cy, Atm(mytile)%ze0, Atm(mytile)%flagstruct%hybrid_z, & - Atm(mytile)%gridstruct, Atm(mytile)%flagstruct, & - Atm(mytile)%neststruct, Atm(mytile)%idiag, Atm(mytile)%bd, Atm(mytile)%parent_grid, & - Atm(mytile)%domain,Atm(mytile)%diss_est) + call fv_dynamics(Atm(mytile)%npx, Atm(mytile)%npy, npz, nq, Atm(mytile)%ng, -dt_atmos, 0., & + Atm(mytile)%flagstruct%fill, Atm(mytile)%flagstruct%reproduce_sum, kappa, cp_air, zvir, & +! Atm(mytile)%ptop, Atm(mytile)%ks, nq, Atm(mytile)%flagstruct%n_split, & + Atm(mytile)%ptop, Atm(mytile)%ks, nq, n_split_loc, & + Atm(mytile)%flagstruct%q_split, Atm(mytile)%u, Atm(mytile)%v, Atm(mytile)%w, & + Atm(mytile)%delz, Atm(mytile)%flagstruct%hydrostatic, & + Atm(mytile)%pt, Atm(mytile)%delp, Atm(mytile)%q, Atm(mytile)%ps, & + Atm(mytile)%pe, Atm(mytile)%pk, Atm(mytile)%peln, Atm(mytile)%pkz, Atm(mytile)%phis, & + Atm(mytile)%q_con, Atm(mytile)%omga, Atm(mytile)%ua, Atm(mytile)%va, Atm(mytile)%uc, Atm(mytile)%vc, & + Atm(mytile)%ak, Atm(mytile)%bk, Atm(mytile)%mfx, Atm(mytile)%mfy, & + Atm(mytile)%cx, Atm(mytile)%cy, Atm(mytile)%ze0, Atm(mytile)%flagstruct%hybrid_z, & + Atm(mytile)%gridstruct, Atm(mytile)%flagstruct, & + Atm(mytile)%neststruct, Atm(mytile)%idiag, Atm(mytile)%bd, Atm(mytile)%parent_grid, & + Atm(mytile)%domain,Atm(mytile)%diss_est) ! Forward call - call fv_dynamics(Atm(mytile)%npx, Atm(mytile)%npy, npz, nq, Atm(mytile)%ng, dt_atmos, 0., & - Atm(mytile)%flagstruct%fill, Atm(mytile)%flagstruct%reproduce_sum, kappa, cp_air, zvir, & - Atm(mytile)%ptop, Atm(mytile)%ks, nq, Atm(mytile)%flagstruct%n_split, & - Atm(mytile)%flagstruct%q_split, Atm(mytile)%u, Atm(mytile)%v, Atm(mytile)%w, & - Atm(mytile)%delz, Atm(mytile)%flagstruct%hydrostatic, & - Atm(mytile)%pt, Atm(mytile)%delp, Atm(mytile)%q, Atm(mytile)%ps, & - Atm(mytile)%pe, Atm(mytile)%pk, Atm(mytile)%peln, Atm(mytile)%pkz, Atm(mytile)%phis, & - Atm(mytile)%q_con, Atm(mytile)%omga, Atm(mytile)%ua, Atm(mytile)%va, Atm(mytile)%uc, Atm(mytile)%vc, & - Atm(mytile)%ak, Atm(mytile)%bk, Atm(mytile)%mfx, Atm(mytile)%mfy, & - Atm(mytile)%cx, Atm(mytile)%cy, Atm(mytile)%ze0, Atm(mytile)%flagstruct%hybrid_z, & - Atm(mytile)%gridstruct, Atm(mytile)%flagstruct, & - Atm(mytile)%neststruct, Atm(mytile)%idiag, Atm(mytile)%bd, Atm(mytile)%parent_grid, & - Atm(mytile)%domain,Atm(mytile)%diss_est) + call fv_dynamics(Atm(mytile)%npx, Atm(mytile)%npy, npz, nq, Atm(mytile)%ng, dt_atmos, 0., & + Atm(mytile)%flagstruct%fill, Atm(mytile)%flagstruct%reproduce_sum, kappa, cp_air, zvir, & +! Atm(mytile)%ptop, Atm(mytile)%ks, nq, Atm(mytile)%flagstruct%n_split, & + Atm(mytile)%ptop, Atm(mytile)%ks, nq, n_split_loc, & + Atm(mytile)%flagstruct%q_split, Atm(mytile)%u, Atm(mytile)%v, Atm(mytile)%w, & + Atm(mytile)%delz, Atm(mytile)%flagstruct%hydrostatic, & + Atm(mytile)%pt, Atm(mytile)%delp, Atm(mytile)%q, Atm(mytile)%ps, & + Atm(mytile)%pe, Atm(mytile)%pk, Atm(mytile)%peln, Atm(mytile)%pkz, Atm(mytile)%phis, & + Atm(mytile)%q_con, Atm(mytile)%omga, Atm(mytile)%ua, Atm(mytile)%va, Atm(mytile)%uc, Atm(mytile)%vc, & + Atm(mytile)%ak, Atm(mytile)%bk, Atm(mytile)%mfx, Atm(mytile)%mfy, & + Atm(mytile)%cx, Atm(mytile)%cy, Atm(mytile)%ze0, Atm(mytile)%flagstruct%hybrid_z, & + Atm(mytile)%gridstruct, Atm(mytile)%flagstruct, & + Atm(mytile)%neststruct, Atm(mytile)%idiag, Atm(mytile)%bd, Atm(mytile)%parent_grid, & + Atm(mytile)%domain,Atm(mytile)%diss_est) ! Nudging back to IC !$omp parallel do default (none) & !$omp shared (nudge_dz,npz, jsc, jec, isc, iec, n, sphum, Atm, u0, v0, t0, dz0, dp0, xt, zvir, mytile) & !$omp private (i, j, k) do k=1,npz - do j=jsc,jec+1 - do i=isc,iec - Atm(mytile)%u(i,j,k) = xt*(Atm(mytile)%u(i,j,k) + wt*u0(i,j,k)) - enddo - enddo - do j=jsc,jec - do i=isc,iec+1 - Atm(mytile)%v(i,j,k) = xt*(Atm(mytile)%v(i,j,k) + wt*v0(i,j,k)) - enddo - enddo - if ( nudge_dz ) then - do j=jsc,jec + do j=jsc,jec+1 + do i=isc,iec + Atm(mytile)%u(i,j,k) = xt*(Atm(mytile)%u(i,j,k) + wt*u0(i,j,k)) + enddo + enddo + do j=jsc,jec + do i=isc,iec+1 + Atm(mytile)%v(i,j,k) = xt*(Atm(mytile)%v(i,j,k) + wt*v0(i,j,k)) + enddo + enddo + if ( nudge_dz ) then + do j=jsc,jec do i=isc,iec Atm(mytile)%delp(i,j,k) = xt*(Atm(mytile)%delp(i,j,k) + wt*dp0(i,j,k)) Atm(mytile)%delz(i,j,k) = xt*(Atm(mytile)%delz(i,j,k) + wt*dz0(i,j,k)) enddo - enddo - else - do j=jsc,jec + enddo + else + do j=jsc,jec do i=isc,iec Atm(mytile)%pt(i,j,k) = xt*(Atm(mytile)%pt(i,j,k) + wt*t0(i,j,k)/(1.+zvir*Atm(mytile)%q(i,j,k,sphum))) Atm(mytile)%delp(i,j,k) = xt*(Atm(mytile)%delp(i,j,k) + wt*dp0(i,j,k)) enddo - enddo - endif + enddo + endif enddo enddo @@ -1710,12 +1736,12 @@ subroutine atmos_phys_driver_statein (IPD_Data, Atm_block,flip_vc) !!! - "Layer" means "layer mean", ie. the average value in a layer !!! - "Level" means "level interface", ie the point values at the top or bottom of a layer - ptop = _DBL_(_RL_(Atm(mytile)%ak(1))) + ptop = _DBL_(_RL_(Atm(mytile)%ak(1))) pktop = (ptop/p00)**kappa pk0inv = (1.0_kind_phys/p00)**kappa - npz = Atm_block%npz - dnats = Atm(mytile)%flagstruct%dnats + npz = Atm_block%npz + dnats = Atm(mytile)%flagstruct%dnats nq_adv = nq - dnats !--------------------------------------------------------------------- diff --git a/atmos_cubed_sphere/model/fv_arrays.F90 b/atmos_cubed_sphere/model/fv_arrays.F90 index dc3a491c7..ba323060d 100644 --- a/atmos_cubed_sphere/model/fv_arrays.F90 +++ b/atmos_cubed_sphere/model/fv_arrays.F90 @@ -602,7 +602,11 @@ module fv_arrays_mod !< produces a good first guess by examining the resolution, !< dt_atmos, and k_split. - integer :: m_split = 0 ! Number of time splits for Riemann solver + real :: fac_n_spl = 1.0 !< factor multiplying n_split up tp forecast hour fhouri + real :: fhouri = 0.0 !< forecast hour up to which the number of small dynamics (acoustic) time steps + !< are nint(n_split*fac_n_spl) + + integer :: m_split = 0 !< Number of time splits for Riemann solver integer :: k_split = 1 !< Number of vertical remappings per dt_atmos (physics timestep). !< 1 by default. @@ -1426,12 +1430,12 @@ subroutine allocate_fv_atmos_type(Atm, isd_in, ied_in, jsd_in, jed_in, is_in, ie Atm%bd%ng = ng !Convenience pointers - Atm%npx => Atm%flagstruct%npx - Atm%npy => Atm%flagstruct%npy - Atm%npz => Atm%flagstruct%npz + Atm%npx => Atm%flagstruct%npx + Atm%npy => Atm%flagstruct%npy + Atm%npz => Atm%flagstruct%npz Atm%ncnst => Atm%flagstruct%ncnst - Atm%ng => Atm%bd%ng + Atm%ng => Atm%bd%ng !!$ Atm%npx = npx_in !!$ Atm%npy = npy_in diff --git a/atmos_cubed_sphere/model/fv_control.F90 b/atmos_cubed_sphere/model/fv_control.F90 index a2ed96b8c..aeb525e06 100644 --- a/atmos_cubed_sphere/model/fv_control.F90 +++ b/atmos_cubed_sphere/model/fv_control.F90 @@ -221,6 +221,9 @@ module fv_control_mod real , pointer :: p_fac real , pointer :: a_imp integer , pointer :: n_split + + real , pointer :: fac_n_spl + real , pointer :: fhouri ! Default integer , pointer :: m_split integer , pointer :: k_split @@ -433,8 +436,8 @@ subroutine fv_init(Atm, dt_atmos, grids_on_this_pe, p_split) endif !!CLEANUP: Convenience pointers - Atm(n)%gridstruct%nested => Atm(n)%neststruct%nested - Atm(n)%gridstruct%grid_type => Atm(n)%flagstruct%grid_type + Atm(n)%gridstruct%nested => Atm(n)%neststruct%nested + Atm(n)%gridstruct%grid_type => Atm(n)%flagstruct%grid_type Atm(n)%flagstruct%grid_number => Atm(n)%grid_number Atm(n)%gridstruct%regional => Atm(n)%flagstruct%regional @@ -658,7 +661,7 @@ subroutine run_setup(Atm, dt_atmos, grids_on_this_pe, p_split) nested, twowaynest, parent_grid_num, parent_tile, nudge_qv, & refinement, nestbctype, nestupdate, nsponge, s_weight, & ioffset, joffset, check_negative, nudge_ic, halo_update_type, gfs_phil, agrid_vel_rst, & - do_uni_zfull, adj_mass_vmr, regional, bc_update_interval + do_uni_zfull, adj_mass_vmr, fac_n_spl, fhouri, regional, bc_update_interval namelist /test_case_nml/test_case, bubble_do, alpha, nsolitons, soliton_Umax, soliton_size @@ -749,14 +752,14 @@ subroutine run_setup(Atm, dt_atmos, grids_on_this_pe, p_split) if (.not. (nested .or. regional)) Atm(n)%neststruct%npx_global = npx ! Define n_split if not in namelist - if (ntiles==6) then + if (ntiles == 6) then dimx = 4.0*(npx-1) if ( hydrostatic ) then if ( npx >= 120 ) ns0 = 6 else if ( npx <= 45 ) then ns0 = 6 - elseif ( npx <=90 ) then + elseif ( npx <= 90 ) then ns0 = 7 else ns0 = 8 @@ -1189,6 +1192,8 @@ subroutine setup_pointers(Atm) p_fac => Atm%flagstruct%p_fac a_imp => Atm%flagstruct%a_imp n_split => Atm%flagstruct%n_split + fac_n_spl => Atm%flagstruct%fac_n_spl + fhouri => Atm%flagstruct%fhouri m_split => Atm%flagstruct%m_split k_split => Atm%flagstruct%k_split use_logp => Atm%flagstruct%use_logp diff --git a/atmos_cubed_sphere/model/fv_dynamics.F90 b/atmos_cubed_sphere/model/fv_dynamics.F90 index d86f6aa94..c92317567 100644 --- a/atmos_cubed_sphere/model/fv_dynamics.F90 +++ b/atmos_cubed_sphere/model/fv_dynamics.F90 @@ -91,6 +91,10 @@ module fv_dynamics_mod ! neg_adj3 ! ! +! fv_sg_mod +! neg_adj2 +! +! ! fv_timing_mod ! timing_on, timing_off ! @@ -132,7 +136,7 @@ module fv_dynamics_mod use mpp_mod, only: mpp_pe use field_manager_mod, only: MODEL_ATMOS use tracer_manager_mod, only: get_tracer_index - use fv_sg_mod, only: neg_adj3 + use fv_sg_mod, only: neg_adj3, neg_adj2 use fv_nesting_mod, only: setup_nested_grid_BCs use fv_regional_mod, only: regional_boundary_update, set_regional_BCs use fv_regional_mod, only: dump_field, H_STAGGER, U_STAGGER, V_STAGGER @@ -754,6 +758,38 @@ subroutine fv_dynamics(npx, npy, npz, nq_tot, ng, bdt, consv_te, fill, endif endif + if( nwat == 5 ) then + if (cld_amt > 0) then + call neg_adj2(is, ie, js, je, ng, npz, & + flagstruct%hydrostatic, & + peln, delz, & + pt, delp, q(isd,jsd,1,sphum), & + q(isd,jsd,1,liq_wat), & + q(isd,jsd,1,rainwat), & + q(isd,jsd,1,ice_wat), & + q(isd,jsd,1,snowwat), & + q(isd,jsd,1,cld_amt), flagstruct%check_negative) + else + call neg_adj2(is, ie, js, je, ng, npz, & + flagstruct%hydrostatic, & + peln, delz, & + pt, delp, q(isd,jsd,1,sphum), & + q(isd,jsd,1,liq_wat), & + q(isd,jsd,1,rainwat), & + q(isd,jsd,1,ice_wat), & + q(isd,jsd,1,snowwat), & + check_negative=flagstruct%check_negative) + endif + if ( flagstruct%fv_debug ) then + call prt_mxm('T_dyn_a3', pt, is, ie, js, je, ng, npz, 1., gridstruct%area_64, domain) + call prt_mxm('SPHUM_dyn', q(isd,jsd,1,sphum ), is, ie, js, je, ng, npz, 1.,gridstruct%area_64, domain) + call prt_mxm('liq_wat_dyn', q(isd,jsd,1,liq_wat), is, ie, js, je, ng, npz, 1.,gridstruct%area_64, domain) + call prt_mxm('rainwat_dyn', q(isd,jsd,1,rainwat), is, ie, js, je, ng, npz, 1.,gridstruct%area_64, domain) + call prt_mxm('ice_wat_dyn', q(isd,jsd,1,ice_wat), is, ie, js, je, ng, npz, 1.,gridstruct%area_64, domain) + call prt_mxm('snowwat_dyn', q(isd,jsd,1,snowwat), is, ie, js, je, ng, npz, 1.,gridstruct%area_64, domain) + endif + endif + if( (flagstruct%consv_am.or.idiag%id_amdt>0.or.idiag%id_aam>0) .and. (.not.do_adiabatic_init) ) then call compute_aam(npz, is, ie, js, je, isd, ied, jsd, jed, gridstruct, bd, & ptop, ua, va, u, v, delp, te_2d, ps, m_fac) diff --git a/atmos_cubed_sphere/model/fv_sg.F90 b/atmos_cubed_sphere/model/fv_sg.F90 index 00dd71223..7f177ee1e 100644 --- a/atmos_cubed_sphere/model/fv_sg.F90 +++ b/atmos_cubed_sphere/model/fv_sg.F90 @@ -64,7 +64,7 @@ module fv_sg_mod implicit none private -public fv_subgrid_z, qsmith, neg_adj3 +public fv_subgrid_z, qsmith, neg_adj3, neg_adj2 real, parameter:: esl = 0.621971831 real, parameter:: tice = 273.16 @@ -1550,6 +1550,326 @@ subroutine neg_adj3(is, ie, js, je, ng, kbot, hydrostatic, & end subroutine neg_adj3 + subroutine neg_adj2(is, ie, js, je, ng, kbot, hydrostatic, & + peln, delz, pt, dp, qv, ql, qr, qi, qs, qa, check_negative) + +! This is designed for 6-class micro-physics schemes + integer, intent(in):: is, ie, js, je, ng, kbot + logical, intent(in):: hydrostatic + real, intent(in):: dp(is-ng:ie+ng,js-ng:je+ng,kbot) !< total delp-p + real, intent(in):: delz(is-ng:,js-ng:,1:) + real, intent(in):: peln(is:ie,kbot+1,js:je) !< ln(pe) + logical, intent(in), OPTIONAL :: check_negative + real, intent(inout), dimension(is-ng:ie+ng,js-ng:je+ng,kbot):: & + pt, qv, ql, qr, qi, qs + real, intent(inout), OPTIONAL, dimension(is-ng:ie+ng,js-ng:je+ng,kbot):: qa +! Local: + logical:: sat_adj = .false. + real, parameter :: t48 = tice - 48. + real, dimension(is:ie,kbot):: dpk, q2 + real, dimension(is:ie,js:je):: pt2, qv2, ql2, qi2, qs2, qr2, dp2, p2, icpk, lcpk + real:: cv_air + real:: dq, qsum, dq1, q_liq, q_sol, oneocpm, sink, qsw, dwsdt, tx1 + integer i, j, k + + cv_air = cp_air - rdgas ! = rdgas * (7/2-1) = 2.5*rdgas=717.68 + + if ( present(check_negative) ) then + if ( check_negative ) then + call prt_negative('Temperature', pt, is, ie, js, je, ng, kbot, 165.) + call prt_negative('sphum', qv, is, ie, js, je, ng, kbot, -1.e-8) + call prt_negative('liq_wat', ql, is, ie, js, je, ng, kbot, -1.e-7) + call prt_negative('rainwat', qr, is, ie, js, je, ng, kbot, -1.e-7) + call prt_negative('ice_wat', qi, is, ie, js, je, ng, kbot, -1.e-7) + call prt_negative('snowwat', qs, is, ie, js, je, ng, kbot, -1.e-7) + endif + endif + + if ( hydrostatic ) then + d0_vap = cp_vapor - c_liq + else + d0_vap = cv_vap - c_liq + endif + lv00 = hlv0 - d0_vap*t_ice + +!$OMP parallel do default(none) shared(is,ie,js,je,kbot,qv,ql,qi,qs,qr,dp,pt, & +!$OMP lv00, d0_vap,hydrostatic,peln,delz,cv_air,sat_adj) & +!$OMP private(dq,dq1,qsum,dp2,p2,pt2,qv2,ql2,qi2,qs2,qr2, & +!$OMP lcpk,icpk,qsw,dwsdt,sink,q_liq,q_sol,oneocpm) + do k=1, kbot + do j=js, je + do i=is, ie + qv2(i,j) = qv(i,j,k) + ql2(i,j) = ql(i,j,k) + qi2(i,j) = qi(i,j,k) + qs2(i,j) = qs(i,j,k) + qr2(i,j) = qr(i,j,k) + dp2(i,j) = dp(i,j,k) + pt2(i,j) = pt(i,j,k) + enddo + enddo + + if ( hydrostatic ) then + do j=js, je + do i=is, ie + p2(i,j) = dp2(i,j)/(peln(i,k+1,j)-peln(i,k,j)) + q_liq = max(0., ql2(i,j) + qr2(i,j)) + q_sol = max(0., qi2(i,j) + qs2(i,j)) + oneocpm = 1.0 / ((1.-(qv2(i,j)+q_liq+q_sol))*cp_air + qv2(i,j)*cp_vapor + q_liq*c_liq + q_sol*c_ice) + lcpk(i,j) = hlv * oneocpm + icpk(i,j) = hlf * oneocpm + enddo + enddo + else + do j=js, je + do i=is, ie + p2(i,j) = -dp2(i,j)/(grav*delz(i,j,k))*rdgas*pt2(i,j)*(1.+zvir*qv2(i,j)) + q_liq = max(0., ql2(i,j) + qr2(i,j)) + q_sol = max(0., qi2(i,j) + qs2(i,j)) + oneocpm = 1.0 / ((1.-(qv2(i,j)+q_liq+q_sol))*cv_air + qv2(i,j)*cv_vap + q_liq*c_liq + q_sol*c_ice) + lcpk(i,j) = (lv00+d0_vap*pt2(i,j)) * oneocpm + icpk(i,j) = (Li0+dc_ice*pt2(i,j)) * oneocpm + enddo + enddo + endif + +! Fix the negatives: +!----------- +! Ice-phase: +!----------- + do j=js, je + do i=is, ie + qsum = qi2(i,j) + qs2(i,j) + if ( qsum > 0. ) then + if ( qi2(i,j) < 0. ) then + qi2(i,j) = 0. + qs2(i,j) = qsum + elseif ( qs2(i,j) < 0. ) then + qs2(i,j) = 0. + qi2(i,j) = qsum + endif + else + qi2(i,j) = 0. + qs2(i,j) = qsum + +! If qsum is negative then borrow from rain water: phase change + if ( qs2(i,j) < 0. .and. qr2(i,j) > 0. ) then + dq = min( qr2(i,j), -qs2(i,j) ) + qs2(i,j) = qs2(i,j) + dq + qr2(i,j) = qr2(i,j) - dq + pt2(i,j) = pt2(i,j) + dq*icpk(i,j) ! conserve total energy + endif +! If qs2 is still negative then borrow from cloud water: phase change + if ( qs2(i,j) < 0. .and. ql2(i,j) > 0. ) then + dq = min( ql2(i,j), -qs2(i,j) ) + qs2(i,j) = qs2(i,j) + dq + ql2(i,j) = ql2(i,j) - dq + pt2(i,j) = pt2(i,j) + dq*icpk(i,j) + endif +! Last resort; borrow from water vapor + if ( qs2(i,j) < 0. .and. qv2(i,j) > 0. ) then + dq = min( 0.999*qv2(i,j), -qs2(i,j) ) + qs2(i,j) = qs2(i,j) + dq + qv2(i,j) = qv2(i,j) - dq + pt2(i,j) = pt2(i,j) + dq*(icpk(i,j)+lcpk(i,j)) + endif + endif + +!-------------- +! Liquid phase: +!-------------- + qsum = ql2(i,j) + qr2(i,j) + if ( qsum > 0. ) then + if ( qr2(i,j) < 0. ) then + qr2(i,j) = 0. + ql2(i,j) = qsum + elseif ( ql2(i,j) < 0. ) then + ql2(i,j) = 0. + qr2(i,j) = qsum + endif + else + ql2(i,j) = 0. + qr2(i,j) = qsum ! rain water is still negative + if ( qr(i,j,k) < 0. ) then +! fill negative rain with available qi & qs (cooling) + dq = min( qi2(i,j)+qs2(i,j), -qr2(i,j) ) + qr2(i,j) = qr2(i,j) + dq + dq1 = min( dq, qs2(i,j) ) + qs2(i,j) = qs2(i,j) - dq1 + qi2(i,j) = qi2(i,j) + dq1 - dq + pt2(i,j) = pt2(i,j) - dq*icpk(i,j) + endif +! fix negative rain water with available vapor + if ( qr2(i,j) < 0. .and. qv2(i,j) > 0. ) then + dq = min( 0.999*qv2(i,j), -qr2(i,j) ) + qv2(i,j) = qv2(i,j) - dq + qr2(i,j) = qr2(i,j) + dq + pt2(i,j) = pt2(i,j) + dq*lcpk(i,j) + endif + endif + enddo + enddo + +!****************************************** +! Fast moist physics: Saturation adjustment +!****************************************** +#ifndef GFS_PHYS + if ( sat_adj ) then + + do j=js, je + do i=is, ie +! Melting of cloud ice into cloud water ******** + if ( qi2(i,j)>1.e-8 .and. pt2(i,j) > tice ) then + sink = min( qi2(i,j), (pt2(i,j)-tice)/icpk(i,j) ) + ql2(i,j) = ql2(i,j) + sink + qi2(i,j) = qi2(i,j) - sink + pt2(i,j) = pt2(i,j) - sink*icpk(i,j) + endif + +! vapor <---> liquid water -------------------------------- + qsw = wqsat2_moist(pt2(i,j), qv2(i,j), p2(i,j), dwsdt) + sink = min( ql2(i,j), (qsw-qv2(i,j))/(1.+lcpk(i,j)*dwsdt) ) + qv2(i,j) = qv2(i,j) + sink + ql2(i,j) = ql2(i,j) - sink + pt2(i,j) = pt2(i,j) - sink*lcpk(i,j) +!----------------------------------------------------------- + +! freezing of cloud water ******** + if( ql2(i,j)>1.e-8 .and. pt2(i,j) < t48 ) then +! Enforce complete freezing below t_00 (-48 C) + sink = min( ql2(i,j), (t48-pt2(i,j))/icpk(i,j) ) + ql2(i,j) = ql2(i,j) - sink + qi2(i,j) = qi2(i,j) + sink + pt2(i,j) = pt2(i,j) + sink*icpk(i,j) + endif ! significant ql existed + enddo + enddo + endif +#endif + +!---------------------------------------------------------------- +! Update fields: + do j=js, je + do i=is, ie + qv(i,j,k) = qv2(i,j) + ql(i,j,k) = ql2(i,j) + qi(i,j,k) = qi2(i,j) + qs(i,j,k) = qs2(i,j) + qr(i,j,k) = qr2(i,j) + pt(i,j,k) = pt2(i,j) + enddo + enddo + + enddo + +!$OMP parallel do default(none) shared(is,ie,js,je,kbot,dp,qr) & +!$OMP private(dpk, q2) + do j=js, je +! Rain water: + do k=1,kbot + do i=is,ie + dpk(i,k) = dp(i,j,k) + q2(i,k) = qr(i,j,k) + enddo + enddo + call fillq(ie-is+1, kbot, q2, dpk) + do k=1,kbot + do i=is,ie + qr(i,j,k) = q2(i,k) + enddo + enddo + enddo + +!----------------------------------- +! Fix water vapor +!----------------------------------- +! Top layer: borrow from below + k = 1 +!$OMP parallel do default(none) shared(is,ie,js,je,k,qv,dp) + do j=js, je + do i=is, ie + if( qv(i,j,k) < 0. ) then + qv(i,j,k+1) = qv(i,j,k+1) + qv(i,j,k)*dp(i,j,k)/dp(i,j,k+1) + qv(i,j,k ) = 0. + endif + enddo + enddo + +! this OpenMP do-loop cannot be parallelized with recursion on k/k-1 +!$OMP parallel do default(none) shared(is,ie,js,je,kbot,qv,dp) & +!$OMP private(dq) + do j=js, je + do k=2,kbot-1 + do i=is, ie + if( qv(i,j,k) < 0. .and. qv(i,j,k-1) > 0. ) then + dq = min(-qv(i,j,k)*dp(i,j,k), qv(i,j,k-1)*dp(i,j,k-1)) + qv(i,j,k-1) = qv(i,j,k-1) - dq/dp(i,j,k-1) + qv(i,j,k ) = qv(i,j,k ) + dq/dp(i,j,k ) + endif + if( qv(i,j,k) < 0. ) then + qv(i,j,k+1) = qv(i,j,k+1) + qv(i,j,k)*dp(i,j,k)/dp(i,j,k+1) + qv(i,j,k ) = 0. + endif + enddo + enddo + enddo + +! Bottom layer; Borrow from above +!$OMP parallel do default(none) shared(is,ie,js,je,kbot,qv,dp) private(dq,tx1) + do j=js, je + do i=is, ie + if( qv(i,j,kbot) < 0. ) then + tx1 = 1.0 / dp(i,j,kbot) + do k=kbot-1,1,-1 + if ( qv(i,j,kbot)>= 0. ) goto 123 + if ( qv(i,j,k) > 0. ) then + dq = min(-qv(i,j,kbot)*dp(i,j,kbot), qv(i,j,k)*dp(i,j,k)) + qv(i,j,k ) = qv(i,j,k ) - dq / dp(i,j,k) + qv(i,j,kbot) = qv(i,j,kbot) + dq * tx1 + endif + enddo ! k-loop +123 continue + endif + enddo ! i-loop + enddo ! j-loop + + + if (present(qa)) then +!----------------------------------- +! Fix negative cloud fraction +!----------------------------------- +! this OpenMP do-loop cannot be parallelized by the recursion on k/k+1 +!$OMP parallel do default(none) shared(is,ie,js,je,kbot,qa,dp) + do j=js, je + do k=1,kbot-1 + do i=is, ie + if( qa(i,j,k) < 0. ) then + qa(i,j,k+1) = qa(i,j,k+1) + qa(i,j,k)*dp(i,j,k)/dp(i,j,k+1) + qa(i,j,k ) = 0. + endif + enddo + enddo + enddo + +! Bottom layer; Borrow from above +!$OMP parallel do default(none) shared(is,ie,js,je,qa,kbot,dp) & +!$OMP private(dq) + do j=js, je + do i=is, ie + if( qa(i,j,kbot) < 0. .and. qa(i,j,kbot-1)>0.) then + dq = min(-qa(i,j,kbot)*dp(i,j,kbot), qa(i,j,kbot-1)*dp(i,j,kbot-1)) + qa(i,j,kbot-1) = qa(i,j,kbot-1) - dq/dp(i,j,kbot-1) + qa(i,j,kbot ) = qa(i,j,kbot ) + dq/dp(i,j,kbot ) + endif +! if qa is still < 0 + qa(i,j,kbot) = max(0., qa(i,j,kbot)) + enddo + enddo + + endif + + end subroutine neg_adj2 + subroutine fillq(im, km, q, dp) ! Aggresive 1D filling algorithm for qr and qg integer, intent(in):: im, km diff --git a/atmos_model.F90 b/atmos_model.F90 index 78a6df377..ede8ad11c 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -153,7 +153,7 @@ module atmos_model_mod logical :: sync = .false. integer, parameter :: maxhr = 4096 real, dimension(maxhr) :: fdiag = 0. -real :: fhmax=240.0, fhmaxhf=120.0, fhout=3.0, fhouthf=1.0 +real :: fhmax=384.0, fhmaxhf=120.0, fhout=3.0, fhouthf=1.0 namelist /atmos_model_nml/ blocksize, chksum_debug, dycore_only, debug, sync, fdiag, fhmax, fhmaxhf, fhout, fhouthf #ifdef CCPP character(len=256) :: ccpp_suite='undefined.xml' @@ -613,9 +613,7 @@ subroutine atmos_model_exchange_phase_1 (Atmos, rc) ! -- export fields to chemistry call update_atmos_chemistry('export', rc=localrc) if (ESMF_LogFoundError(rcToCheck=localrc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, & - rcToReturn=rc)) return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out endif end subroutine atmos_model_exchange_phase_1 @@ -652,9 +650,7 @@ subroutine atmos_model_exchange_phase_2 (Atmos, rc) ! -- import fields from chemistry call update_atmos_chemistry('import', rc=localrc) if (ESMF_LogFoundError(rcToCheck=localrc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, & - rcToReturn=rc)) return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out endif end subroutine atmos_model_exchange_phase_2 @@ -2202,9 +2198,7 @@ subroutine addLsmask2grid(fcstgrid, rc) call ESMF_GridAddItem(fcstgrid, itemflag=ESMF_GRIDITEM_MASK, & staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! call ESMF_GridGetItemBounds(fcstgrid, itemflag=ESMF_GRIDITEM_MASK, & ! staggerloc=ESMF_STAGGERLOC_CENTER, computationalLBound=ClBnd, & @@ -2214,18 +2208,14 @@ subroutine addLsmask2grid(fcstgrid, rc) ! 'ClBnd=',ClBnd,'CUbnd=',CUbnd,'Ccount=',Ccount, & ! 'TlBnd=',TlBnd,'TUbnd=',TUbnd,'Tcount=',Tcount ! if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & -! line=__LINE__, & -! file=__FILE__)) & -! return ! bail out +! line=__LINE__, file=__FILE__)) return ! bail out call ESMF_GridGetItem(fcstgrid, itemflag=ESMF_GRIDITEM_MASK, & staggerloc=ESMF_STAGGERLOC_CENTER,farrayPtr=maskPtr, rc=rc) ! print *,'in set up grid, aft get maskptr, rc=',rc, 'size=',size(maskPtr,1),size(maskPtr,2), & ! 'bound(maskPtr)=', LBOUND(maskPtr,1),LBOUND(maskPtr,2),UBOUND(maskPtr,1),UBOUND(maskPtr,2) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! do j=jsc,jec do i=isc,iec diff --git a/fv3_cap.F90 b/fv3_cap.F90 index 6a037211a..abfbdba74 100644 --- a/fv3_cap.F90 +++ b/fv3_cap.F90 @@ -106,95 +106,73 @@ subroutine SetServices(gcomp, rc) ! the NUOPC model component will register the generic methods call NUOPC_CompDerive(gcomp, model_routine_SS, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! initialization, switching to IPD versions call ESMF_GridCompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, & userRoutine=InitializeP0, phase=0, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! set entry point for methods that require specific implementation call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, & phaseLabelList=(/"IPDv01p1"/), userRoutine=InitializeAdvertise, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, & phaseLabelList=(/"IPDv01p3"/), userRoutine=InitializeRealize, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! model advance method(s) call NUOPC_CompSpecialize(gcomp, specLabel=model_label_Advance, & specRoutine=ModelAdvance, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! checking the import fields is a bit more complex because of coldstart option call ESMF_MethodRemove(gcomp, model_label_CheckImport, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_CheckImport, & specRoutine=fv3_checkimport, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! setup Run/Advance phase: phase1 call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_RUN, & phaseLabelList=(/"phase1"/), userRoutine=model_routine_Run, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_Advance, & specPhaseLabel="phase1", specRoutine=ModelAdvance_phase1, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! setup Run/Advance phase: phase2 call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_RUN, & phaseLabelList=(/"phase2"/), userRoutine=model_routine_Run, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_Advance, & specPhaseLabel="phase2", specRoutine=ModelAdvance_phase2, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_SetRunClock, & specPhaseLabel="phase2", specRoutine=SetRunClock_onestep, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! model finalize method(s) call NUOPC_CompSpecialize(gcomp, specLabel=model_label_Finalize, & specRoutine=atmos_model_finalize, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out end subroutine SetServices @@ -224,15 +202,14 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) call ESMF_AttributeGet(gcomp, name="ProfileMemory", value=value, defaultValue="true", & convention="NUOPC", purpose="Instance", rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out profile_memory = (trim(value)/="false") call ESMF_AttributeGet(gcomp, name="DumpFields", value=value, defaultValue="false", & convention="NUOPC", purpose="Instance", rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & line=__LINE__, file=__FILE__)) return ! bail out + cplprint_flag = (trim(value)=="true") write(msgString,'(A,l6)') trim(subname)//' cplprint_flag = ',cplprint_flag call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO, rc=rc) @@ -283,16 +260,13 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) call ESMF_GridCompGet(gcomp,name=name,vm=vm,rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out call ESMF_VMGet(vm, mpiCommunicator=mpi_comm_atm,petCount=petcount, & localpet = mype,rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + fcstmype = mype ! print *,'in fv3_cap,initAdvertize,name=',trim(name),'mpi_comm=',mpi_comm_atm, & ! 'petcount=',petcount,'mype=',mype @@ -300,9 +274,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) ! create an instance clock for fv3 clock_fv3=ESMF_ClockCreate(clock, rc=RC) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! !------------------------------------------------------------------------ ! get config variables @@ -310,37 +282,28 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) CF=ESMF_ConfigCreate(rc=RC) CALL ESMF_ConfigLoadFile(config=CF ,filename='model_configure' ,rc=RC) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! CALL ESMF_ConfigGetAttribute(config=CF,value=restart_interval, & label ='restart_interval:',rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! CALL ESMF_ConfigGetAttribute(config=CF,value=calendar, & label ='calendar:',rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! cpl = .false. CALL ESMF_ConfigGetAttribute(config=CF,value=cpl, label ='cpl:',rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! CALL ESMF_ConfigGetAttribute(config=CF,value=quilting, & label ='quilting:',rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + if(mype==0) print *,'af nems config,quilting=',quilting,'calendar=', & trim(calendar) ! @@ -349,16 +312,13 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) CALL ESMF_ConfigGetAttribute(config=CF,value=write_groups, & label ='write_groups:',rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! CALL ESMF_ConfigGetAttribute(config=CF,value=wrttasks_per_group, & label ='write_tasks_per_group:',rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + if(mype==0) print *,'af nems config,restart_interval=',restart_interval, & 'quilting=',quilting,'write_groups=',write_groups,wrttasks_per_group, & 'calendar=',trim(calendar),'calendar_type=',calendar_type @@ -366,18 +326,14 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) CALL ESMF_ConfigGetAttribute(config=CF,value=num_files, & label ='num_files:',rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! allocate(filename_base(num_files)) CALL ESMF_ConfigFindLabel(CF,'filename_base:',rc=RC) do i=1,num_files CALL ESMF_ConfigGetAttribute(config=CF,value=filename_base(i), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out enddo if(mype==0) print *,'af nems config,num_files=',num_files, & 'filename_base=',filename_base @@ -474,9 +430,8 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) call ESMF_ClockGet(clock_fv3, currTIME=CurrTime, StartTime=startTime, & RunDuration=RunDuration, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + StopTime = startTime + RunDuration ! *** read restart time from restart file @@ -505,9 +460,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) call ESMF_TimeSet(time=CurrTime,yy=date(1),mm=date(2),dd=date(3),h=date(4), & m=date(5),s=date(6),rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out 999 continue 998 continue ! if(mype==0) print *,'final date =',date,'date_init=',date_init @@ -516,9 +469,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) call ESMF_ClockSet(clock_fv3, currTIME=CurrTime, startTime=startTime, & stopTime=stopTime, timeStep=timeStep, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! ! !Under NUOPC, the EARTH driver clock is a separate instance from the @@ -527,24 +478,18 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) ! - Affected: currTime, timeStep call ESMF_ClockGet(clock, timeStep=earthStep, rc=RC) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out if (earthStep>(stopTime-currTime)) earthStep=stopTime-currTime call ESMF_ClockSet(clock, currTime=currTime, & timeStep=earthStep, rc=RC) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! Set fv3 component clock as copy of EARTH clock. call NUOPC_CompSetClock(gcomp, clock, rc=RC) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! Read in the FV3 coupling interval if ( cpl ) then @@ -558,24 +503,18 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) ! - Affected: currTime, timeStep call ESMF_ClockGet(clock, timeStep=earthStep, rc=RC) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - call ESMF_Finalize(endflag=ESMF_END_ABORT) + line=__LINE__, file=__FILE__)) call ESMF_Finalize(endflag=ESMF_END_ABORT) if (earthStep>(stopTime-currTime)) earthStep=stopTime-currTime call ESMF_ClockSet(clock, currTime=currTime, & timeStep=earthStep, rc=RC) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - call ESMF_Finalize(endflag=ESMF_END_ABORT) + line=__LINE__, file=__FILE__)) call ESMF_Finalize(endflag=ESMF_END_ABORT) ! Set fv3 component clock as copy of EARTH clock. call NUOPC_CompSetClock(gcomp, clock, rc=RC) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - call ESMF_Finalize(endflag=ESMF_END_ABORT) + line=__LINE__, file=__FILE__)) call ESMF_Finalize(endflag=ESMF_END_ABORT) ! Read in the FV3 coupling interval if ( cpl ) then @@ -600,53 +539,38 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) enddo fcstComp = ESMF_GridCompCreate(petList=fcstPetList, name='fv3_fcst', rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! call ESMF_GridCompSetServices(fcstComp, fcstSS, userRc=urc, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out if (ESMF_LogFoundError(rcToCheck=urc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, rcToReturn=rc)) & - return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out ! create fcst state fcstState = ESMF_StateCreate(rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! call fcst Initialize (including creating fcstgrid and fcst fieldbundle) call ESMF_GridCompInitialize(fcstComp, exportState=fcstState, & clock=clock_fv3, userRc=urc, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + if (ESMF_LogFoundError(rcToCheck=urc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, rcToReturn=rc)) & - return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out ! ! reconcile the fcstComp's import state call ESMF_StateReconcile(fcstState, attreconflag= ESMF_ATTRECONCILE_ON, & rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! ! determine number elements in fcstState call ESMF_StateGet(fcstState, itemCount=FBCount, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out if(mype==0) print *,'af fcstCom FBCount= ',FBcount ! ! allocate arrays @@ -656,9 +580,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) call ESMF_StateGet(fcstState, itemNameList=fcstItemNameList, & itemTypeList=fcstItemTypeList, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! ! loop over all items in the fcstState and collect all FieldBundles do i=1, FBcount @@ -667,18 +589,15 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) call ESMF_StateGet(fcstState, itemName=fcstItemNameList(i), & fieldbundle=fcstFB(i), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! if(mype==0.or.mype==144) print *,'af fcstFB,i=',i,'name=',trim(fcstItemNameList(i)) else !***### anything but a FieldBundle in the state is unexpected here call ESMF_LogSetError(ESMF_RC_ARG_BAD, & msg="Only FieldBundles supported in fcstState.", & - line=__LINE__, & - file=__FILE__, rcToReturn=rc) - return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc) + return ! bail out endif enddo ! @@ -718,76 +637,57 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) wrtComp(i) = ESMF_GridCompCreate(petList=petList, name=trim(cwrtcomp), rc=rc) ! print *,'af wrtComp(i)=',i,'name=',trim(cwrtcomp),'rc=',rc if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! call into wrtComp(i) SetServices call ESMF_GridCompSetServices(wrtComp(i), wrtSS, userRc=urc, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + if (ESMF_LogFoundError(rcToCheck=urc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, rcToReturn=rc)) & - return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out ! create wrtstate(i) wrtstate(i) = ESMF_StateCreate(rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! add the fcst FieldBundles to the wrtState(i) so write component can ! use this info to create mirror objects call ESMF_AttributeCopy(fcstState, wrtState(i), & attcopy=ESMF_ATTCOPY_REFERENCE, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out call ESMF_StateAdd(wrtState(i), fcstFB, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! call into wrtComp(i) Initialize call ESMF_GridCompInitialize(wrtComp(i), importState=wrtstate(i), & clock=clock_fv3, phase=1, userRc=urc, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + if (ESMF_LogFoundError(rcToCheck=urc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, rcToReturn=rc)) & - return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out ! remove fcst FieldBundles from the wrtState(i) because done with it call ESMF_StateRemove(wrtState(i), fcstItemNameList, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! reconcile the wrtComp(i)'s export state call ESMF_StateReconcile(wrtState(i), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + if(mype==0) print *,'af wrtState reconcile, FBcount=',FBcount call ESMF_AttributeCopy(fcstState, wrtState(i), & attcopy=ESMF_ATTCOPY_REFERENCE, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! loop over all FieldBundle in the states and precompute Regrid operation do j=1, FBcount @@ -798,9 +698,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) fieldbundle=wrtFB(j,i), rc=rc) if(mype==0) print *,'af get wrtfb=',"mirror_"//trim(fcstItemNameList(j)),'rc=',rc if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! determine regridmethod if (index(fcstItemNameList(j),"_bilinear") >0 ) then @@ -814,10 +712,9 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) else if (index(fcstItemNameList(j),"_conserve") >0) then regridmethod = ESMF_REGRIDMETHOD_CONSERVE else - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg="Unable to determine regrid method.", & - line=__LINE__, & - file=__FILE__, rcToReturn=rc) + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg="Unable to determine regrid method.", & + line=__LINE__, file=__FILE__, rcToReturn=rc) return ! bail out endif @@ -837,9 +734,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) if(mype==0) print *,'after regrid store, group i=',i,' fb=',j,' time=',mpi_wtime()-timewri call ESMF_LogWrite('af FieldBundleRegridStore', ESMF_LOGMSG_INFO, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out originPetList(1:num_pes_fcst) = fcstPetList(:) originPetList(num_pes_fcst+1:) = petList(:) @@ -850,9 +745,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) routehandle(j,i) = ESMF_RouteHandleCreate(routehandle(j,1), & originPetList=originPetList, targetPetList=targetPetList, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out endif write(msg,"(A,I2.2,',',I2.2,A)") "... returned from wrtFB(",j,i, ") FieldBundleRegridStore()." @@ -899,9 +792,8 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) sticky =.false., & !<-- Alarm does not ring until turned off rc =RC) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + alarm_output_ring = currtime + output_hfmax + output_interval else alarm_output_ring = currtime + output_interval @@ -919,9 +811,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) sticky =.false., & !<-- Alarm does not ring until turned off rc =RC) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! !----------------------------------------------------------------------- !*** SET THE FIRST WRITE GROUP AS THE FIRST ONE TO ACT. @@ -944,16 +834,12 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) StandardName=trim(ImportFieldsList(i)), & SharePolicyField="share", rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out else call NUOPC_Advertise(importState, & StandardName=trim(ImportFieldsList(i)), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out end if end do @@ -964,16 +850,12 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) StandardName=trim(exportFieldsList(i)), & SharePolicyField="share", rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out else call NUOPC_Advertise(exportState, & StandardName=trim(exportFieldsList(i)), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out end if end do @@ -1007,18 +889,14 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) numLevels, numSoilLayers, numTracers, & exportFieldsList, exportFieldTypes, exportFields, rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! -- realize connected fields in importState call realizeConnectedCplFields(importState, fcstGrid, & numLevels, numSoilLayers, numTracers, & importFieldsList, importFieldTypes, importFields, rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out end if endif @@ -1061,9 +939,7 @@ subroutine ModelAdvance(gcomp, rc) ! call ESMF_GridCompGet(gcomp, name=name, localpet=mype, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! Because of the way that the internal Clock was set in SetClock(), ! its timeStep is likely smaller than the parent timeStep. As a consequence @@ -1075,14 +951,11 @@ subroutine ModelAdvance(gcomp, rc) call ESMF_ClockPrint(clock_fv3, options="currTime", & preString="------>Advancing FV3 from: ", unit=msgString, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_LogWrite(msgString, ESMF_LOGMSG_INFO, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out !----------------------------------------------------------------------- !*** Use the internal Clock set by NUOPC layer for FV3 but update stopTime @@ -1091,23 +964,17 @@ subroutine ModelAdvance(gcomp, rc) ! Component internal Clock gets updated per NUOPC rules call ESMF_GridCompGet(gcomp, clock=clock, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! The stopTime will be updated to be the next coupling time call ESMF_ClockGet(clock, currTime=currTime, stopTime=stopTime, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! Set the coupling time to be stopTime in Clock that FV3 core uses call ESMF_ClockSet(clock_fv3, currTime=currTime, stopTime=stopTime, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out call ESMF_ClockPrint(clock_fv3, options="currTime", & preString="entering FV3_ADVANCE with clock_fv3 current: ", & @@ -1125,9 +992,8 @@ subroutine ModelAdvance(gcomp, rc) call ESMF_ClockGet(clock_fv3, startTime=startTime, currTime=currTime, & timeStep=timeStep, stopTime=stopTime, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + ! if(mype==0) print *,'total steps=', nint((stopTime-startTime)/timeStep) ! if(mype==lead_wrttask(1)) print *,'on wrt lead,total steps=', nint((stopTime-startTime)/timeStep) call ESMF_TimeGet(time=stopTime,yy=date(1),mm=date(2),dd=date(3),h=date(4), & @@ -1153,48 +1019,36 @@ subroutine ModelAdvance(gcomp, rc) timewri = mpi_wtime() call ESMF_LogWrite('Model Advance: before fcstcomp run ', ESMF_LOGMSG_INFO, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out call ESMF_GridCompRun(fcstComp, exportState=fcstState, clock=clock_fv3, & phase=1, userRc=urc, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + if (ESMF_LogFoundError(rcToCheck=urc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, rcToReturn=rc)) & - return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out call ESMF_GridCompRun(fcstComp, exportState=fcstState, clock=clock_fv3, & phase=2, userRc=urc, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + if (ESMF_LogFoundError(rcToCheck=urc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, rcToReturn=rc)) & - return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out call ESMF_LogWrite('Model Advance: after fcstcomp run ', ESMF_LOGMSG_INFO, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out call ESMF_ClockAdvance(clock = clock_fv3, rc = RC) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call esmf_clockget(clock_fv3, currtime=currtime, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + time_elapsed = currtime - starttime na = nint(time_elapsed/timeStep) ! @@ -1237,9 +1091,7 @@ subroutine ModelAdvance(gcomp, rc) termorderflag=(/ESMF_TERMORDER_SRCSEQ/), rc=rc) timerh = mpi_wtime() if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! !end FBcount enddo @@ -1249,29 +1101,22 @@ subroutine ModelAdvance(gcomp, rc) ! if(mype==0 .or. mype==lead_wrttask(1)) print *,'on wrt bf wrt run, na=',na call ESMF_LogWrite('Model Advance: before wrtcomp run ', ESMF_LOGMSG_INFO, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out timerhi = mpi_wtime() call ESMF_GridCompRun(wrtComp(n_group), importState=wrtState(n_group), clock=clock_fv3,userRc=urc,rc=rc) timerh = mpi_wtime() if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + if (ESMF_LogFoundError(rcToCheck=urc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, rcToReturn=rc)) & - return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out ! if (mype == 0 .or. mype == lead_wrttask(n_group)) print *,'aft wrtgridcomp run,na=',na, & ! ' time=', timerh- timerhi call ESMF_LogWrite('Model Advance: after wrtcomp run ', ESMF_LOGMSG_INFO, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! if (mype == 0 .or. mype == lead_wrttask(n_group)) print *,'fv3_cap,aft model advance,na=', & ! na,' time=', mpi_wtime()- timewri @@ -1342,9 +1187,7 @@ subroutine ModelAdvance_phase1(gcomp, rc) ! call ESMF_GridCompGet(gcomp, name=name, localpet=mype, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! Expecting to be called by NUOPC run method exactly once for every coupling ! step. @@ -1354,14 +1197,11 @@ subroutine ModelAdvance_phase1(gcomp, rc) call ESMF_ClockPrint(clock_fv3, options="currTime", & preString="------>Advancing FV3 from: ", unit=msgString, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_LogWrite(msgString, ESMF_LOGMSG_INFO, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out !----------------------------------------------------------------------- !*** Use the internal Clock set by NUOPC layer for FV3 but update stopTime @@ -1370,23 +1210,17 @@ subroutine ModelAdvance_phase1(gcomp, rc) ! Component internal Clock gets updated per NUOPC rules call ESMF_GridCompGet(gcomp, clock=clock, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! The stopTime will be updated to be the next external coupling time call ESMF_ClockGet(clock, currTime=currTime, stopTime=stopTime, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! Set the FV3-OCN coupling time to be stopTime in Clock that FV3 core uses call ESMF_ClockSet(clock_fv3, currTime=currTime, stopTime=stopTime, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out call ESMF_ClockPrint(clock_fv3, options="currTime", & preString="entering FV3_ADVANCE phase1 with clock_fv3 current: ", & @@ -1404,9 +1238,8 @@ subroutine ModelAdvance_phase1(gcomp, rc) call ESMF_ClockGet(clock_fv3, startTime=startTime, currTime=currTime, & timeStep=timeStep, stopTime=stopTime, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + ! if(mype==0) print *,'total steps=', nint((stopTime-startTime)/timeStep) ! if(mype==lead_wrttask(1)) print *,'on wrt lead,total steps=', nint((stopTime-startTime)/timeStep) call ESMF_TimeGet(time=stopTime,yy=date(1),mm=date(2),dd=date(3),h=date(4), & @@ -1428,26 +1261,19 @@ subroutine ModelAdvance_phase1(gcomp, rc) call ESMF_LogWrite('Model Advance phase1: before fcstcomp run ', ESMF_LOGMSG_INFO, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out call ESMF_GridCompRun(fcstComp, exportState=fcstState, clock=clock_fv3, & phase=1, userRc=urc, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + if (ESMF_LogFoundError(rcToCheck=urc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, rcToReturn=rc)) & - return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out call ESMF_LogWrite('Model Advance phase1: after fcstcomp run ', ESMF_LOGMSG_INFO, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out if(profile_memory) & call ESMF_VMLogMemInfo("Leaving FV3 Model_ADVANCE phase1: ") @@ -1489,9 +1315,7 @@ subroutine ModelAdvance_phase2(gcomp, rc) ! call ESMF_GridCompGet(gcomp, name=name, localpet=mype, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out !----------------------------------------------------------------------------- !*** no integration loop @@ -1503,39 +1327,31 @@ subroutine ModelAdvance_phase2(gcomp, rc) timewri = mpi_wtime() call ESMF_LogWrite('Model Advance phase2: before fcstcomp run ', ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out call ESMF_GridCompRun(fcstComp, exportState=fcstState, clock=clock_fv3, & - phase=2, userRc=urc, rc=rc) + phase=2, userRc=urc, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out if (ESMF_LogFoundError(rcToCheck=urc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, rcToReturn=rc)) & - return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out call ESMF_LogWrite('Model Advance phase2: after fcstcomp run ', ESMF_LOGMSG_INFO, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out call ESMF_ClockAdvance(clock = clock_fv3, rc = RC) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_ClockGet(clock_fv3, startTime=startTime, currTime=currTime, & timeStep=timeStep, stopTime=stopTime, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + time_elapsed = currtime - starttime na = nint(time_elapsed/timeStep) ! @@ -1574,76 +1390,68 @@ subroutine ModelAdvance_phase2(gcomp, rc) ! get fcst fieldbundle ! call ESMF_FieldBundleRegrid(fcstFB(i), wrtFB(i,n_group), & - routehandle=routehandle(i, n_group), rc=rc) + routehandle=routehandle(i, n_group), rc=rc) timerh = mpi_wtime() if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! !end FBcount - enddo - if (mype == 0 .or. mype == lead_wrttask(n_group)) print *,'aft fieldbundleregrid,na=',na, & - ' time=', timerh- timerhi + enddo + if (mype == 0 .or. mype == lead_wrttask(n_group)) print *,'aft fieldbundleregrid,na=',na, & + ' time=', timerh- timerhi -! if(mype==0 .or. mype==lead_wrttask(1)) print *,'on wrt bf wrt run, na=',na - call ESMF_LogWrite('Model Advance: before wrtcomp run ', ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out +! if(mype==0 .or. mype==lead_wrttask(1)) print *,'on wrt bf wrt run, na=',na + call ESMF_LogWrite('Model Advance: before wrtcomp run ', ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out - timerhi = mpi_wtime() - call ESMF_GridCompRun(wrtComp(n_group), importState=wrtState(n_group), clock=clock_fv3,userRc=urc,rc=rc) - timerh = mpi_wtime() - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - if (ESMF_LogFoundError(rcToCheck=urc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, rcToReturn=rc)) & - return ! bail out - if (mype == 0 .or. mype == lead_wrttask(n_group)) print *,'aft wrtgridcomp run,na=',na, & + timerhi = mpi_wtime() + call ESMF_GridCompRun(wrtComp(n_group), importState=wrtState(n_group), clock=clock_fv3,userRc=urc,rc=rc) + timerh = mpi_wtime() + + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out + if (ESMF_LogFoundError(rcToCheck=urc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out + + if (mype == 0 .or. mype == lead_wrttask(n_group)) print *,'aft wrtgridcomp run,na=',na, & ' time=', timerh- timerhi - call ESMF_LogWrite('Model Advance: after wrtcomp run ', ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + call ESMF_LogWrite('Model Advance: after wrtcomp run ', ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out - if (mype == 0 .or. mype == lead_wrttask(n_group)) print *,'fv3_cap,aft model advance phase2,na=', & - na,' time=', mpi_wtime()- timewri + if (mype == 0 .or. mype == lead_wrttask(n_group)) print *,'fv3_cap,aft model advance phase2,na=', & + na,' time=', mpi_wtime()- timewri - if(n_group == write_groups) then - n_group = 1 - else - n_group = n_group + 1 - endif + if(n_group == write_groups) then + n_group = 1 + else + n_group = n_group + 1 + endif - endif output + endif output ! end quilting - endif + endif ! !jw check clock - call ESMF_ClockPrint(clock_fv3, options="currTime", & - preString="leaving FV3_ADVANCE phase2 with clock_fv3 current: ", & - unit=nuopcMsg) - call ESMF_LogWrite(nuopcMsg, ESMF_LOGMSG_INFO) - call ESMF_ClockPrint(clock_fv3, options="startTime", & - preString="leaving FV3_ADVANCE phase2 with clock_fv3 start: ", & - unit=nuopcMsg) - call ESMF_LogWrite(nuopcMsg, ESMF_LOGMSG_INFO) - call ESMF_ClockPrint(clock_fv3, options="stopTime", & - preString="leaving FV3_ADVANCE phase2 with clock_fv3 stop: ", & - unit=nuopcMsg) - call ESMF_LogWrite(nuopcMsg, ESMF_LOGMSG_INFO) - - if(profile_memory) & - call ESMF_VMLogMemInfo("Leaving FV3 Model_ADVANCE phase2: ") + call ESMF_ClockPrint(clock_fv3, options="currTime", & + preString="leaving FV3_ADVANCE phase2 with clock_fv3 current: ", & + unit=nuopcMsg) + call ESMF_LogWrite(nuopcMsg, ESMF_LOGMSG_INFO) + call ESMF_ClockPrint(clock_fv3, options="startTime", & + preString="leaving FV3_ADVANCE phase2 with clock_fv3 start: ", & + unit=nuopcMsg) + call ESMF_LogWrite(nuopcMsg, ESMF_LOGMSG_INFO) + call ESMF_ClockPrint(clock_fv3, options="stopTime", & + preString="leaving FV3_ADVANCE phase2 with clock_fv3 stop: ", & + unit=nuopcMsg) + call ESMF_LogWrite(nuopcMsg, ESMF_LOGMSG_INFO) + + if(profile_memory) & + call ESMF_VMLogMemInfo("Leaving FV3 Model_ADVANCE phase2: ") end subroutine ModelAdvance_phase2 @@ -1664,45 +1472,34 @@ subroutine SetRunClock_onestep(model, rc) ! query component for clock and driver clock call NUOPC_ModelGet(model, modelClock=clock, driverClock=driverClock, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! query driver clock for incoming information call ESMF_ClockGet(driverClock, currTime=checkCurrTime, & timeStep=checkTimeStep, direction=direction, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! query component clock for its information call ESMF_ClockGet(clock, currTime=currTime, timeStep=timeStep, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! ensure the current times have the correct relationship if (currTime /= checkCurrTime + checkTimeStep) then call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg="NUOPC INCOMPATIBILITY DETECTED: "// & - "component clock and driver clock currentTime not as expected!", & - line=__LINE__, & - file=__FILE__, & - rcToReturn=rc) + msg="NUOPC INCOMPATIBILITY DETECTED: "// & + "component clock and driver clock currentTime not as expected!", & + line=__LINE__, file=__FILE__, rcToReturn=rc) return ! bail out endif ! ensure that the driver timestep is a multiple of the component timestep - if (ceiling(checkTimeStep/timeStep) /= floor(checkTimeStep/timeStep))& - then + if (ceiling(checkTimeStep/timeStep) /= floor(checkTimeStep/timeStep)) then call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg="NUOPC INCOMPATIBILITY DETECTED: "// & - "driver timestep is not multiple of model timestep!", & - line=__LINE__, & - file=__FILE__, & - rcToReturn=rc) + msg="NUOPC INCOMPATIBILITY DETECTED: "// & + "driver timestep is not multiple of model timestep!", & + line=__LINE__, file=__FILE__, rcToReturn=rc) return ! bail out endif @@ -1714,9 +1511,7 @@ subroutine SetRunClock_onestep(model, rc) endif call ESMF_ClockSet(clock, currTime=currTime, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out end subroutine SetRunClock_onestep @@ -1741,19 +1536,16 @@ subroutine fv3_checkimport(gcomp, rc) integer date(6) ! query the Component for its clock - call ESMF_GridCompGet(gcomp, clock=clock, & - importState=importState, rc=rc) + call ESMF_GridCompGet(gcomp, clock=clock, importState=importState, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! get the current time out of the clock call ESMF_ClockGet(clock, currTime=currTime, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out !jwtest: date(1:6) = 0 call ESMF_TimeGet(time=CurrTime,yy=date(1),mm=date(2),dd=date(3),h=date(4), & @@ -1762,19 +1554,15 @@ subroutine fv3_checkimport(gcomp, rc) ! set up invalid time (by convention) call ESMF_TimeSet(invalidTime, yy=99999999, mm=01, dd=01, & - h=00, m=00, s=00, rc=rc) + h=00, m=00, s=00, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out nullify(fieldList) - call NUOPC_GetStateMemberLists(importState, & - fieldList=fieldList, rc=rc) + call NUOPC_GetStateMemberLists(importState, fieldList=fieldList, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! set the importFieldsValid flag ! associated(fieldList) will be false if there are no fields @@ -1784,31 +1572,30 @@ subroutine fv3_checkimport(gcomp, rc) if(fcstmype==0) print *,'in fv3_checkimport, inside associated(fieldList)' do n = 1,size(fieldList) call ESMF_FieldGet(fieldList(n), name=fldname, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + nf = queryFieldList(ImportFieldsList,fldname) timeCheck1 = NUOPC_IsAtTime(fieldList(n), invalidTime, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + if (timeCheck1) then importFieldsValid(nf) = .false. if(fcstmype==0) print *,'in fv3_checkimport,',trim(fldname),' is set unvalid, nf=',nf,' at time',date(1:6) else timeCheck2 = NUOPC_IsAtTime(fieldList(n), currTime, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + if (.not.timeCheck2) then !TODO: introduce and use INCOMPATIBILITY return codes!!!! call ESMF_LogSetError(ESMF_RC_ARG_BAD, & msg="NUOPC INCOMPATIBILITY DETECTED: Import Field not at current time", & - line=__LINE__, file=__FILE__, & - rcToReturn=rc) + line=__LINE__, file=__FILE__, rcToReturn=rc) return ! bail out endif endif @@ -1846,52 +1633,36 @@ subroutine atmos_model_finalize(gcomp, rc) do i = 1, write_groups call ESMF_GridCompFinalize(wrtComp(i), importState=wrtstate(i),userRc=urc, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out if (ESMF_LogFoundError(rcToCheck=urc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, rcToReturn=rc)) & - return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out enddo endif call ESMF_GridCompFinalize(fcstComp, exportState=fcststate,userRc=urc, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out if (ESMF_LogFoundError(rcToCheck=urc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, rcToReturn=rc)) & - return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out ! !*** destroy grid comps if( quilting ) then do i = 1, write_groups call ESMF_StateDestroy(wrtState(i), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out call ESMF_GridCompDestroy(wrtComp(i), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out enddo endif call ESMF_StateDestroy(fcstState, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out call ESMF_GridCompDestroy(fcstComp, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! if(mype==0)print *,' wrt grid comp destroy time=',mpi_wtime()-timeffs diff --git a/gfsphysics/GFS_layer/GFS_driver.F90 b/gfsphysics/GFS_layer/GFS_driver.F90 index 1babd50c0..a890f2641 100644 --- a/gfsphysics/GFS_layer/GFS_driver.F90 +++ b/gfsphysics/GFS_layer/GFS_driver.F90 @@ -157,6 +157,13 @@ subroutine GFS_initialize (Model, Statein, Stateout, Sfcprop, & call read_o3data (Model%ntoz, Model%me, Model%master) call read_h2odata (Model%h2o_phys, Model%me, Model%master) + if (Model%aero_in) then + call read_aerdata (Model%me,Model%master,Model%iflip,Model%idate) + endif + if (Model%iccn) then + call read_cidata ( Model%me, Model%master) + endif + call init_stochastic_physics(Model,Init_parm,nblks,Grid) if(Model%me == Model%master) print*,'do_skeb=',Model%do_skeb @@ -191,6 +198,25 @@ subroutine GFS_initialize (Model, Statein, Stateout, Sfcprop, & enddo endif + !--- read in and initialize IN and CCN + if (Model%iccn) then + do nb = 1, nblks + call setindxci (Init_parm%blksz(nb), Grid(nb)%xlat_d, Grid(nb)%jindx1_ci, & + Grid(nb)%jindx2_ci, Grid(nb)%ddy_ci, Grid(nb)%xlon_d, & + Grid(nb)%iindx1_ci,Grid(nb)%iindx2_ci,Grid(nb)%ddx_ci) + enddo + endif + + !--- read in and initialize aerosols + if (Model%aero_in) then + do nb = 1, nblks + call setindxaer (Init_parm%blksz(nb),Grid(nb)%xlat_d,Grid(nb)%jindx1_aer, & + Grid(nb)%jindx2_aer, Grid(nb)%ddy_aer, Grid(nb)%xlon_d, & + Grid(nb)%iindx1_aer,Grid(nb)%iindx2_aer,Grid(nb)%ddx_aer, & + Init_parm%me, Init_parm%master ) + enddo + endif + if (Model%h2o_phys) then do nb = 1, nblks call setindxh2o (Init_parm%blksz(nb), Grid(nb)%xlat_d, Grid(nb)%jindx1_h, & @@ -224,19 +250,20 @@ subroutine GFS_initialize (Model, Statein, Stateout, Sfcprop, & if (Model%imp_physics == 10) then !--- initialize Morrison-Gettleman microphysics if (Model%fprcp <= 0) then - call ini_micro (Model%mg_dcs, Model%mg_qcvar, Model%mg_ts_auto_ice) + call ini_micro (Model%mg_dcs, Model%mg_qcvar, Model%mg_ts_auto_ice(1)) elseif (Model%fprcp == 1) then - call micro_mg_init2_0(kind_phys, gravit, rair, rh2o, cpair, & - tmelt, latvap, latice, 1.01_kind_phys, & - Model%mg_dcs, Model%mg_ts_auto_ice, & - Model%mg_qcvar, & - Model%microp_uniform, Model%do_cldice, & - Model%hetfrz_classnuc, & - Model%mg_precip_frac_method, & - Model%mg_berg_eff_factor, & - Model%sed_supersat, Model%do_sb_physics, & - Model%mg_nccons,Model%mg_nicons, & - Model%mg_ncnst, Model%mg_ninst) + call micro_mg_init2_0(kind_phys, gravit, rair, rh2o, cpair, & + tmelt, latvap, latice, 1.01_kind_phys, & + Model%mg_dcs, Model%mg_ts_auto_ice, & + Model%mg_qcvar, & + Model%microp_uniform, Model%do_cldice, & + Model%hetfrz_classnuc, & + Model%mg_precip_frac_method, & + Model%mg_berg_eff_factor, & + Model%sed_supersat, Model%do_sb_physics, & + Model%mg_do_ice_gmao, Model%mg_do_liq_liu, & + Model%mg_nccons, Model%mg_nicons, & + Model%mg_ncnst, Model%mg_ninst) elseif (Model%fprcp == 2) then call micro_mg_init3_0(kind_phys, gravit, rair, rh2o, cpair, & tmelt, latvap, latice, 1.01_kind_phys, & @@ -247,10 +274,11 @@ subroutine GFS_initialize (Model, Statein, Stateout, Sfcprop, & Model%hetfrz_classnuc, & Model%mg_precip_frac_method, & Model%mg_berg_eff_factor, & - Model%sed_supersat, Model%do_sb_physics, & - Model%mg_nccons, Model%mg_nicons, & - Model%mg_ncnst, Model%mg_ninst, & - Model%mg_ngcons, Model%mg_ngnst) + Model%sed_supersat, Model%do_sb_physics, & + Model%mg_do_ice_gmao, Model%mg_do_liq_liu, & + Model%mg_nccons, Model%mg_nicons, & + Model%mg_ncnst, Model%mg_ninst, & + Model%mg_ngcons, Model%mg_ngnst) else write(0,*)' Model%fprcp = ',Model%fprcp,' is not a valid option - aborting' stop @@ -380,7 +408,7 @@ subroutine GFS_time_vary_step (Model, Statein, Stateout, Sfcprop, Coupling, & endif !--- physics time varying routine - call GFS_phys_time_vary (Model, Grid, Tbd) + call GFS_phys_time_vary (Model, Grid, Tbd, Statein) !--- repopulate specific time-varying sfc properties for AMIP/forecast runs if (Model%nscyc > 0) then @@ -400,26 +428,26 @@ subroutine GFS_time_vary_step (Model, Statein, Stateout, Sfcprop, Coupling, & call run_stochastic_physics(nblks,Model,Grid(:),Coupling(:)) ! kludge for output if (Model%do_skeb) then - do nb = 1,nblks - do k=1,Model%levs - Diag(nb)%skebu_wts(:,k)=Coupling(nb)%skebu_wts(:,Model%levs-k+1) - Diag(nb)%skebv_wts(:,k)=Coupling(nb)%skebv_wts(:,Model%levs-k+1) - enddo - enddo + do nb = 1,nblks + do k=1,Model%levs + Diag(nb)%skebu_wts(:,k) = Coupling(nb)%skebu_wts(:,Model%levs-k+1) + Diag(nb)%skebv_wts(:,k) = Coupling(nb)%skebv_wts(:,Model%levs-k+1) + enddo + enddo endif !if (Model%do_sppt) then - ! do nb = 1,nblks - ! do k=1,Model%levs - ! Diag(nb)%sppt_wts(:,k)=Coupling(nb)%sppt_wts(:,Model%levs-k+1) - ! enddo - ! enddo + ! do nb = 1,nblks + ! do k=1,Model%levs + ! Diag(nb)%sppt_wts(:,k) = Coupling(nb)%sppt_wts(:,Model%levs-k+1) + ! enddo + ! enddo !endif if (Model%do_shum) then - do nb = 1,nblks - do k=1,Model%levs - Diag(nb)%shum_wts(:,k)=Coupling(nb)%shum_wts(:,Model%levs-k+1) - enddo - enddo + do nb = 1,nblks + do k=1,Model%levs + Diag(nb)%shum_wts(:,k)=Coupling(nb)%shum_wts(:,Model%levs-k+1) + enddo + enddo endif end subroutine GFS_time_vary_step @@ -629,13 +657,14 @@ end subroutine GFS_rad_time_vary ! Routine containing all of the setup logic originally in phys/gloopb.f ! !----------------------------------------------------------------------- - subroutine GFS_phys_time_vary (Model, Grid, Tbd) + subroutine GFS_phys_time_vary (Model, Grid, Tbd, Statein) use mersenne_twister, only: random_setseed, random_number implicit none type(GFS_control_type), intent(inout) :: Model type(GFS_grid_type), intent(inout) :: Grid(:) type(GFS_tbd_type), intent(inout) :: Tbd(:) + type(GFS_statein_type), intent(in) :: Statein(:) !--- local variables integer :: nb, ix, k, j, i, nblks, iseed, iskip real(kind=kind_phys) :: wrk(1) @@ -661,12 +690,13 @@ subroutine GFS_phys_time_vary (Model, Grid, Tbd) endif !--- random number needed for RAS and old SAS and when cal_pre=.true. - if ( ((Model%imfdeepcnv <= 0) .or. (Model%cal_pre)) .and. (Model%random_clds) ) then + ! Model%imfdeepcnv < 0 when Model%ras = .true. + if ( (Model%imfdeepcnv <= 0 .or. Model%cal_pre) .and. Model%random_clds ) then iseed = mod(con_100*sqrt(Model%fhour*con_hr),1.0d9) + Model%seed0 call random_setseed(iseed) call random_number(wrk) do i = 1,Model%cnx*Model%nrcm - iseed = iseed + nint(wrk(1)) * i + iseed = iseed + nint(wrk(1)*1000.0) * i call random_setseed(iseed) call random_number(rannie) rndval(1+(i-1)*Model%cny:i*Model%cny) = rannie(1:Model%cny) @@ -693,20 +723,45 @@ subroutine GFS_phys_time_vary (Model, Grid, Tbd) if (Model%ntoz > 0) then do nb = 1, nblks call ozinterpol (Model%me, blksz(nb), Model%idate, Model%fhour, & - Grid(nb)%jindx1_o3, Grid(nb)%jindx2_o3, & - Tbd(nb)%ozpl, Grid(nb)%ddy_o3) + Grid(nb)%jindx1_o3, Grid(nb)%jindx2_o3, & + Tbd(nb)%ozpl, Grid(nb)%ddy_o3) enddo endif !--- h2o interpolation if (Model%h2o_phys) then do nb = 1, nblks - call h2ointerpol (Model%me, blksz(nb), Model%idate, Model%fhour, & - Grid(nb)%jindx1_h, Grid(nb)%jindx2_h, & - Tbd(nb)%h2opl, Grid(nb)%ddy_h) + call h2ointerpol (Model%me, blksz(nb), Model%idate, Model%fhour, & + Grid(nb)%jindx1_h, Grid(nb)%jindx2_h, & + Tbd(nb)%h2opl, Grid(nb)%ddy_h) enddo endif + !--- ICCN interpolation + if (Model%ICCN ) then + do nb = 1, nblks + call ciinterpol (Model%me, blksz(nb), Model%idate, Model%fhour, & + Grid(nb)%jindx1_ci, Grid(nb)%jindx2_ci, & + Grid(nb)%ddy_ci,Grid(nb)%iindx1_ci, & + Grid(nb)%iindx2_ci,Grid(nb)%ddx_ci, & + Model%levs,Statein(nb)%prsl, & + Tbd(nb)%in_nm, Tbd(nb)%ccn_nm) + enddo + endif + + !--- aerosol interpolation + if (Model%aero_in ) then + do nb = 1, nblks + call aerinterpol (Model%me, Model%master, blksz(nb), & + Model%idate, Model%fhour, & + Grid(nb)%jindx1_aer, Grid(nb)%jindx2_aer, & + Grid(nb)%ddy_aer,Grid(nb)%iindx1_aer, & + Grid(nb)%iindx2_aer,Grid(nb)%ddx_aer, & + Model%levs,Statein(nb)%prsl, & + Tbd(nb)%aer_nm) + enddo + endif + end subroutine GFS_phys_time_vary @@ -722,6 +777,7 @@ subroutine GFS_grid_populate (Grid, xlon, xlat, area) real(kind=kind_phys), intent(in) :: xlon(:,:) real(kind=kind_phys), intent(in) :: xlat(:,:) real(kind=kind_phys), intent(in) :: area(:,:) + real(kind=kind_phys), parameter :: rad2deg = 180.0_kind_phys/pi !--- local variables integer :: nb, ix, blksz, i, j @@ -739,7 +795,8 @@ subroutine GFS_grid_populate (Grid, xlon, xlat, area) endif Grid(nb)%xlon(ix) = xlon(i,j) Grid(nb)%xlat(ix) = xlat(i,j) - Grid(nb)%xlat_d(ix) = xlat(i,j) * 180.0_kind_phys/pi + Grid(nb)%xlat_d(ix) = xlat(i,j) * rad2deg + Grid(nb)%xlon_d(ix) = xlon(i,j) * rad2deg Grid(nb)%sinlat(ix) = sin(Grid(nb)%xlat(ix)) Grid(nb)%coslat(ix) = sqrt(1.0_kind_phys - Grid(nb)%sinlat(ix)*Grid(nb)%sinlat(ix)) Grid(nb)%area(ix) = area(i,j) diff --git a/gfsphysics/GFS_layer/GFS_physics_driver.F90 b/gfsphysics/GFS_layer/GFS_physics_driver.F90 index f59163197..3a0d8f62c 100644 --- a/gfsphysics/GFS_layer/GFS_physics_driver.F90 +++ b/gfsphysics/GFS_layer/GFS_physics_driver.F90 @@ -304,7 +304,7 @@ module module_physics_driver !! - Call deep convective scheme according to the parameter 'imfdeepcnv', 'ras', and 'cscnv'. !! - if imfdeepcnv == 0, 1, or 2, no special processing is needed !! - if the Chikira-Sugiyama scheme (cscnv), convert rain rate to accumulated rain (rain1) -!! - if RAS, initialize 'ccwfac', 'dlqfac', 'lmh', and revap before the call to 'rascnv' +!! - if RAS, initialize 'ccwfac', 'dlqfac', and revap before the call to 'rascnv' !! - Zero out 'cld1d' (cloud work function calculated in non-RAS, non-Chikira-Sugiyama schemes) !! - If 'lgocart', accumulate convective mass fluxes and convective cloud water !! - Update tracers in the tracer array (gq0) due to convective transport (RAS, CS only) from the 'clw' array @@ -450,11 +450,11 @@ subroutine GFS_physics_driver & integer :: i, kk, ic, k, n, k1, iter, levshcm, tracers, & tottracer, nsamftrac, num2, num3, nshocm, nshoc, ntk, & - nn, nncl, seconds + nn, nncl, ntiwx, seconds integer, dimension(size(Grid%xlon,1)) :: & kbot, ktop, kcnv, soiltyp, vegtype, kpbl, slopetyp, kinver, & - lmh, levshc, islmsk, & + levshc, islmsk, & !--- coupling inputs for physics islmsk_cice @@ -468,6 +468,8 @@ subroutine GFS_physics_driver & logical, dimension(Model%ntrac+1,2) :: otspt + real(kind=kind_phys), dimension(Model%ntrac+2) :: trcmin + !--- REAL VARIABLES real(kind=kind_phys) :: & dtf, dtp, rhbbot, rhbtop, rhpbl, frain, tem, tem1, tem2, & @@ -493,6 +495,7 @@ subroutine GFS_physics_driver & snohf, dlqfac, work3, ctei_rml, cldf, domr, domzr, domip, & doms, psautco_l, prautco_l, ocalnirbm_cpl, ocalnirdf_cpl, & ocalvisbm_cpl, ocalvisdf_cpl, dtzm, temrain1, & + psaur_l, praur_l, & !--- coupling inputs for physics dtsfc_cice, dqsfc_cice, dusfc_cice, dvsfc_cice, ulwsfc_cice, & tisfc_cice, tsea_cice, hice_cice, fice_cice, & @@ -511,6 +514,7 @@ subroutine GFS_physics_driver & real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levs) :: & del, rhc, dtdt, dudt, dvdt, gwdcu, gwdcv, dtdtc, rainp, & ud_mf, dd_mf, dt_mf, prnum, dkt, sigmatot, sigmafrac +! ud_mf, dd_mf, dt_mf, prnum, dkt, sigmatot, sigmafrac, txa !--- GFDL modification for FV3 @@ -542,12 +546,14 @@ subroutine GFS_physics_driver & ncpr(:,:), ncps(:,:), cnvc(:,:), cnvw(:,:), & qgl(:,:), ncgl(:,:) !--- for 2 M microphysics - real(kind=kind_phys), allocatable, dimension(:) :: & - cn_prc, cn_snr +! real(kind=kind_phys), allocatable, dimension(:) :: & +! cn_prc, cn_snr real(kind=kind_phys), allocatable, dimension(:,:) :: & - qlcn, qicn, w_upi, cf_upi, CNV_MFD, CNV_PRC3, CNV_DQLDT, & +! qlcn, qicn, w_upi, cf_upi, CNV_MFD, CNV_PRC3, CNV_DQLDT, & + qlcn, qicn, w_upi, cf_upi, CNV_MFD, CNV_DQLDT, & CLCN, CNV_FICE, CNV_NDROP, CNV_NICE - real(kind=kind_phys),parameter :: slope_mg = 0.02, slope_upmg = 0.02, & +! real(kind=kind_phys),parameter :: slope_mg = 0.02, slope_upmg = 0.02, & + real(kind=kind_phys),parameter :: slope_mg = 0.02, slope_upmg = 0.04, & turnrhcrit = 0.900, turnrhcrit_upper = 0.150 ! !--- for 2 M Thmpson MP @@ -636,11 +642,17 @@ subroutine GFS_physics_driver & ntkev = nvdiff ! !------------------------------------------------------------------------------------------- -! lprnt = .false. + lprnt = .false. ! do i=1,im -! lprnt = kdt >= 0 .and. abs(grid%xlon(i)*57.29578-288.03) < 0.201 & -! .and. abs(grid%xlat(i)*57.29578+47.06) < 0.201 +! lprnt = kdt >= 1 .and. abs(grid%xlon(i)*57.29578-119.78) < 0.101 & +! .and. abs(grid%xlat(i)*57.29578-19.49) < 0.101 +! lprnt = kdt >= 250 .and. abs(grid%xlon(i)*57.29578-227.34) < 0.101 & +! .and. abs(grid%xlat(i)*57.29578-6.206) < 0.101 +! lprnt = kdt >= 0 .and. abs(grid%xlon(i)*57.29578-90.9375) < 0.501 & +! .and. abs(grid%xlat(i)*57.29578-36.0) < 0.501 +! lprnt = kdt >= 0 .and. abs(grid%xlon(i)*57.29578-285.938) < 0.501 & +! .and. abs(grid%xlat(i)*57.29578+46.286) < 0.501 ! lprnt = kdt >= 0 .and. abs(grid%xlon(i)*57.29578-108.41) < 0.501 & ! .and. abs(grid%xlat(i)*57.29578-32.97) < 0.501 ! if (kdt == 1) & @@ -653,7 +665,7 @@ subroutine GFS_physics_driver & ! endif ! enddo ! lprnt = .false. -! if (lprnt) write(0,*)' cloudsdriverdriver=',Tbd%phy_f3d(ipr,:,1)*100,' kdt=',kdt +! if (lprnt) write(0,*)' cloudsphysdriver=',Tbd%phy_f3d(ipr,:,1)*100,' kdt=',kdt !------------------------------------------------------------------------------------------- ! skip_macro = .false. @@ -671,13 +683,27 @@ subroutine GFS_physics_driver & endif allocate (clw(ix,levs,nn)) - if (Model%imfdeepcnv >= 0 .or. Model%imfshalcnv > 0) then + if (Model%imfdeepcnv >= 0 .or. Model%imfshalcnv > 0 .or. & + (Model%npdf3d == 3 .and. Model%num_p3d == 4) .or. & + (Model%npdf3d == 0 .and. Model%ncnvcld3d == 1) ) then allocate (cnvc(ix,levs), cnvw(ix,levs)) + do k=1,levs + do i=1,im + cnvc(i,k) = 0.0 + cnvw(i,k) = 0.0 + enddo + enddo + if (Model%npdf3d == 3 .and. Model%num_p3d == 4) then + num2 = Model%num_p3d + 2 + num3 = num2 + 1 + elseif (Model%npdf3d == 0 .and. Model%ncnvcld3d == 1) then + num2 = Model%num_p3d + 1 + endif endif ! ! --- set initial quantities for stochastic physics deltas if (Model%do_sppt) then - Tbd%dtdtr = 0.0 + Tbd%dtdtr = 0.0 do i=1,im Tbd%drain_cpl(i) = Coupling%rain_cpl (i) Tbd%dsnow_cpl(i) = Coupling%snow_cpl (i) @@ -688,12 +714,12 @@ subroutine GFS_physics_driver & ! --- scale random patterns for surface perturbations with perturbation size ! --- turn vegetation fraction pattern into percentile pattern do i=1,im - z01d(i) = 0. - zt1d(i) = 0. - bexp1d(i)= 0. - xlai1d(i)= 0. -! alb1d(i) = 0. - vegf1d(i)= 0. + z01d(i) = 0. + zt1d(i) = 0. + bexp1d(i) = 0. + xlai1d(i) = 0. +! alb1d(i) = 0. + vegf1d(i) = 0. enddo if (Model%do_sfcperts) then if (Model%pertz0(1) > 0.) then @@ -726,13 +752,15 @@ subroutine GFS_physics_driver & endif ! if (Model%do_shoc) then - allocate (qrn(im,levs), qsnw(im,levs), ncpl(im,levs), ncpi(im,levs)) + allocate (qrn(im,levs), qsnw(im,levs), qgl(im,levs), & + ncpl(im,levs), ncpi(im,levs)) do k=1,levs do i=1,im ncpl(i,k) = 0.0 ncpi(i,k) = 0.0 qrn(i,k) = 0.0 qsnw(i,k) = 0.0 + qgl(i,k) = 0.0 enddo enddo endif @@ -749,13 +777,15 @@ subroutine GFS_physics_driver & if (imp_physics == 10) then ! For MGB double moment microphysics allocate (qlcn(im,levs), qicn(im,levs), w_upi(im,levs), & - cf_upi(im,levs), CNV_MFD(im,levs), CNV_PRC3(im,levs), & + cf_upi(im,levs), CNV_MFD(im,levs), & +! cf_upi(im,levs), CNV_MFD(im,levs), CNV_PRC3(im,levs), & CNV_DQLDT(im,levs), clcn(im,levs), cnv_fice(im,levs), & cnv_ndrop(im,levs), cnv_nice(im,levs)) - allocate (cn_prc(im), cn_snr(im)) - allocate (ncpr(im,levs), ncps(im,levs), qgl(im,levs), ncgl(im,levs)) +! allocate (cn_prc(im), cn_snr(im)) + allocate (ncpr(im,levs), ncps(im,levs), ncgl(im,levs)) if (.not. allocated(qrn)) allocate (qrn(im,levs)) if (.not. allocated(qsnw)) allocate (qsnw(im,levs)) + if (.not. allocated(qgl)) allocate (qgl(im,levs)) do k=1,levs do i=1,im qrn(i,k) = 0.0 @@ -769,7 +799,8 @@ subroutine GFS_physics_driver & ! else allocate (qlcn(1,1), qicn(1,1), w_upi(1,1), cf_upi(1,1), & - CNV_MFD(1,1), CNV_PRC3(1,1), CNV_DQLDT(1,1), & + CNV_MFD(1,1), CNV_DQLDT(1,1), & +! CNV_MFD(1,1), CNV_PRC3(1,1), CNV_DQLDT(1,1), & clcn(1,1), cnv_fice(1,1), cnv_ndrop(1,1), cnv_nice(1,1)) if (imp_physics == 11) then ! GFDL MP allocate (delp(im,1,levs), dz(im,1,levs), uin(im,1,levs), & @@ -930,7 +961,7 @@ subroutine GFS_physics_driver & Radtend%htrsw, Radtend%swhc, Radtend%htrlw, Radtend%lwhc,& Coupling%nirbmui, Coupling%nirdfui, Coupling%visbmui, & Coupling%visdfui, Coupling%nirbmdi, Coupling%nirdfdi, & - Coupling%visbmdi, Coupling%visdfdi, ix, im, levs, & + Coupling%visbmdi, Coupling%visdfdi, ix, im, levs, dtf, & ! --- input/output: dtdt, dtdtc, & ! --- outputs: @@ -1106,10 +1137,10 @@ subroutine GFS_physics_driver & Sfcprop%snowd, Sfcprop%tsfc, Sfcprop%zorl, cd, & cdq, rb, Statein%prsl(1,1), work3, islmsk, stress, & Sfcprop%ffmm, Sfcprop%ffhh, Sfcprop%uustar, & - wind, Tbd%phy_f2d(1,Model%num_p2d), fm10, fh2, & + wind, Tbd%phy_f2d(1,Model%num_p2d), fm10, fh2, & sigmaf, vegtype, Sfcprop%shdmax, Model%ivegsrc, & - z01d, zt1d, & ! mg, sfc-perts - tsurf, flag_iter, Model%redrag) + z01d, zt1d, & ! mg, sfc-perts + tsurf, flag_iter, Model%redrag) ! --- ... lu: update flag_guess @@ -1129,7 +1160,7 @@ subroutine GFS_physics_driver & endif enddo - call sfc_nst (im, lsoil, Statein%pgr, Statein%ugrs, & + call sfc_nst (im, Statein%pgr, Statein%ugrs, & Statein%vgrs, Statein%tgrs, Statein%qgrs, & Sfcprop%tref, cd, cdq, Statein%prsl(1,1), work3, & islmsk, Grid%xlon, Grid%sinlat, stress, & @@ -1278,8 +1309,8 @@ subroutine GFS_physics_driver & flag_guess(i) = .false. if (iter == 1 .and. wind(i) < 2.0) then - if ((islmsk(i) == 1) .or. ((islmsk(i) == 0) .and. & - (Model%nstf_name(1) > 0))) then + if (islmsk(i) == 1 .or. (islmsk(i) == 0 .and. & + Model%nstf_name(1) > 0)) then flag_iter(i) = .true. endif endif @@ -1331,7 +1362,7 @@ subroutine GFS_physics_driver & Coupling%dnirdf_cpl (i) = Coupling%dnirdf_cpl(i) + adjnirdfd(i)*dtf Coupling%dvisbm_cpl (i) = Coupling%dvisbm_cpl(i) + adjvisbmd(i)*dtf Coupling%dvisdf_cpl (i) = Coupling%dvisdf_cpl(i) + adjvisdfd(i)*dtf - Coupling%nlwsfci_cpl (i) = adjsfcdlw(i) - adjsfculw(i) + Coupling%nlwsfci_cpl (i) = adjsfcdlw(i) - adjsfculw(i) Coupling%nlwsfc_cpl (i) = Coupling%nlwsfc_cpl(i) + Coupling%nlwsfci_cpl(i)*dtf Coupling%t2mi_cpl (i) = Sfcprop%t2m(i) Coupling%q2mi_cpl (i) = Sfcprop%q2m(i) @@ -1386,11 +1417,11 @@ subroutine GFS_physics_driver & Diag%snohfa(i) = Diag%snohfa(i) + snohf(i) * dtf Diag%ep(i) = Diag%ep(i) + ep1d(i) * dtf - Diag%tmpmax(i) = max(Diag%tmpmax(i),Sfcprop%t2m(i)) - Diag%tmpmin(i) = min(Diag%tmpmin(i),Sfcprop%t2m(i)) + Diag%tmpmax(i) = max(Diag%tmpmax(i), Sfcprop%t2m(i)) + Diag%tmpmin(i) = min(Diag%tmpmin(i), Sfcprop%t2m(i)) - Diag%spfhmax(i) = max(Diag%spfhmax(i),Sfcprop%q2m(i)) - Diag%spfhmin(i) = min(Diag%spfhmin(i),Sfcprop%q2m(i)) + Diag%spfhmax(i) = max(Diag%spfhmax(i), Sfcprop%q2m(i)) + Diag%spfhmin(i) = min(Diag%spfhmin(i), Sfcprop%q2m(i)) enddo do i=1, im @@ -1439,6 +1470,7 @@ subroutine GFS_physics_driver & ! if (lprnt) write(0,*)'befmonshoctkh=',Tbd%phy_f3d(ipr,1:10,ntot3d-1) ! if (lprnt) write(0,*)'befmonshochflx=',hflx(ipr),' tsea=',Sfcprop%tsfc(ipr),& ! ' evap=',evap(ipr) +! if (lprnt) write(0,*)'befmonshoctke=',Statein%qgrs(ipr,:,ntke) if (nvdiff == ntrac) then ! @@ -1453,10 +1485,11 @@ subroutine GFS_physics_driver & dvsfc1, dtsfc1, dqsfc1, dkt, Diag%hpbl, kinver, & Model%xkzm_m, Model%xkzm_h, Model%xkzm_s, lprnt, ipr, me) ! if (lprnt) write(0,*)'aftmonshoc=',Statein%tgrs(ipr,:) +! if (lprnt) write(0,*)'aftmonshoctke=',Statein%qgrs(ipr,:,ntke) ! if (lprnt) write(0,*)'aftmonshocdtdt=',dtdt(ipr,1:10) else if (Model%satmedmf) then - call satmedmfvdif(ix, im, levs, nvdiff, ntcw, ntiw, nncl, ntke, & + call satmedmfvdif(ix, im, levs, nvdiff, ntcw, ntiw, ntke, & dvdt, dudt, dtdt, dqdt, & Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs, & Radtend%htrsw, Radtend%htrlw, xmu, garea, & @@ -1516,6 +1549,7 @@ subroutine GFS_physics_driver & else allocate(vdftra(ix,levs,nvdiff), dvdftra(im,levs,nvdiff)) dvdftra(:,:,:) = 0.0 + ntiwx = 0 ! if (imp_physics == 6) then ! WSM6 @@ -1527,6 +1561,7 @@ subroutine GFS_physics_driver & vdftra(i,k,4) = Statein%qgrs(i,k,ntoz) enddo enddo + ntiwx = 3 elseif (imp_physics == 8) then ! Thompson if(Model%ltaerosol) then @@ -1542,6 +1577,7 @@ subroutine GFS_physics_driver & vdftra(i,k,8) = Statein%qgrs(i,k,ntia) enddo enddo + ntiwx = 3 else do k=1,levs do i=1,im @@ -1552,6 +1588,7 @@ subroutine GFS_physics_driver & vdftra(i,k,5) = Statein%qgrs(i,k,ntoz) enddo enddo + ntiwx = 3 endif ! elseif (imp_physics == 11) then @@ -1567,6 +1604,7 @@ subroutine GFS_physics_driver & vdftra(i,k,7) = Statein%qgrs(i,k,ntoz) enddo enddo + ntiwx = 3 endif ! if (Model%satmedmf) then @@ -1589,57 +1627,57 @@ subroutine GFS_physics_driver & Model%xkzm_m, Model%xkzm_h, Model%xkzm_s, lprnt, ipr, me) else if (Model%satmedmf) then - call satmedmfvdif(ix, im, levs, nvdiff, ntcw, ntiw, nncl, ntkev, & - dvdt, dudt, dtdt, dqdt, & - Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs, & - Radtend%htrsw, Radtend%htrlw, xmu, garea, & - Statein%prsik(1,1), rb, Sfcprop%zorl, Diag%u10m, Diag%v10m, & - Sfcprop%ffmm, Sfcprop%ffhh, Sfcprop%tsfc, hflx, evap, & - stress, wind, kpbl, Statein%prsi, del, Statein%prsl, & - Statein%prslk, Statein%phii, Statein%phil, dtp, & - Model%dspheat, dusfc1, dvsfc1, dtsfc1, dqsfc1, Diag%hpbl, & - kinver, Model%xkzm_m, Model%xkzm_h, Model%xkzm_s) + call satmedmfvdif(ix, im, levs, nvdiff, ntcw, ntiwx, ntkev, & + dvdt, dudt, dtdt, dvdftra, & + Statein%ugrs, Statein%vgrs, Statein%tgrs, vdftra, & + Radtend%htrsw, Radtend%htrlw, xmu, garea, & + Statein%prsik(1,1), rb, Sfcprop%zorl, Diag%u10m, Diag%v10m, & + Sfcprop%ffmm, Sfcprop%ffhh, Sfcprop%tsfc, hflx, evap, & + stress, wind, kpbl, Statein%prsi, del, Statein%prsl, & + Statein%prslk, Statein%phii, Statein%phil, dtp, & + Model%dspheat, dusfc1, dvsfc1, dtsfc1, dqsfc1, Diag%hpbl, & + kinver, Model%xkzm_m, Model%xkzm_h, Model%xkzm_s) elseif (Model%hybedmf) then - call moninedmf(ix, im, levs, nvdiff, ntcw, dvdt, dudt, dtdt, dvdftra, & - Statein%ugrs, Statein%vgrs, Statein%tgrs, vdftra, & - Radtend%htrsw, Radtend%htrlw, xmu, Statein%prsik(1,1), & - rb, Sfcprop%zorl, Diag%u10m, Diag%v10m, Sfcprop%ffmm, & - Sfcprop%ffhh, Sfcprop%tsfc, qss, hflx, evap, stress, & - wind, kpbl, Statein%prsi, del, Statein%prsl, & - Statein%prslk, Statein%phii, Statein%phil, dtp, & - Model%dspheat, dusfc1, dvsfc1, dtsfc1, dqsfc1, Diag%hpbl,& - gamt, gamq, dkt, kinver, Model%xkzm_m, Model%xkzm_h, & - Model%xkzm_s, lprnt, ipr, & - Model%xkzminv, Model%moninq_fac) + call moninedmf(ix, im, levs, nvdiff, ntcw, dvdt, dudt, dtdt, dvdftra, & + Statein%ugrs, Statein%vgrs, Statein%tgrs, vdftra, & + Radtend%htrsw, Radtend%htrlw, xmu, Statein%prsik(1,1), & + rb, Sfcprop%zorl, Diag%u10m, Diag%v10m, Sfcprop%ffmm, & + Sfcprop%ffhh, Sfcprop%tsfc, qss, hflx, evap, stress, & + wind, kpbl, Statein%prsi, del, Statein%prsl, & + Statein%prslk, Statein%phii, Statein%phil, dtp, & + Model%dspheat, dusfc1, dvsfc1, dtsfc1, dqsfc1, Diag%hpbl,& + gamt, gamq, dkt, kinver, Model%xkzm_m, Model%xkzm_h, & + Model%xkzm_s, lprnt, ipr, & + Model%xkzminv, Model%moninq_fac) elseif (.not. Model%old_monin) then - call moninq(ix, im, levs, nvdiff, ntcw, dvdt, dudt, dtdt, dvdftra, & - Statein%ugrs, Statein%vgrs, Statein%tgrs, vdftra, & - Radtend%htrsw, Radtend%htrlw, xmu, Statein%prsik(1,1), rb, & - Sfcprop%ffmm, Sfcprop%ffhh, Sfcprop%tsfc, qss, hflx, evap, & - stress, wind, kpbl, Statein%prsi, del, Statein%prsl, & - Statein%prslk, Statein%phii, Statein%phil, dtp, & - Model%dspheat, dusfc1, dvsfc1, dtsfc1, dqsfc1, Diag%hpbl, & - gamt, gamq, dkt, kinver, Model%xkzm_m, Model%xkzm_h, & - Model%xkzm_s, lprnt, ipr, & + call moninq(ix, im, levs, nvdiff, ntcw, dvdt, dudt, dtdt, dvdftra, & + Statein%ugrs, Statein%vgrs, Statein%tgrs, vdftra, & + Radtend%htrsw, Radtend%htrlw, xmu, Statein%prsik(1,1), rb, & + Sfcprop%ffmm, Sfcprop%ffhh, Sfcprop%tsfc, qss, hflx, evap, & + stress, wind, kpbl, Statein%prsi, del, Statein%prsl, & + Statein%prslk, Statein%phii, Statein%phil, dtp, & + Model%dspheat, dusfc1, dvsfc1, dtsfc1, dqsfc1, Diag%hpbl, & + gamt, gamq, dkt, kinver, Model%xkzm_m, Model%xkzm_h, & + Model%xkzm_s, lprnt, ipr, & Model%xkzminv, Model%moninq_fac, Model%rbcr) else if (Model%mstrat) then - call moninp1(ix, im, levs, nvdiff, dvdt, dudt, dtdt, dvdftra, & - Statein%ugrs, Statein%vgrs, Statein%tgrs, vdftra, & - Statein%prsik(1,1), rb, Sfcprop%ffmm, Sfcprop%ffhh, & - Sfcprop%tsfc, qss, hflx, evap, stress, wind, kpbl, & - Statein%prsi, del, Statein%prsl, Statein%prslk, & - Statein%phii, Statein%phil, dtp, dusfc1, dvsfc1, & - dtsfc1, dqsfc1, Diag%hpbl, gamt, gamq, dkt, kinver, & + call moninp1(ix, im, levs, nvdiff, dvdt, dudt, dtdt, dvdftra, & + Statein%ugrs, Statein%vgrs, Statein%tgrs, vdftra, & + Statein%prsik(1,1), rb, Sfcprop%ffmm, Sfcprop%ffhh, & + Sfcprop%tsfc, qss, hflx, evap, stress, wind, kpbl, & + Statein%prsi, del, Statein%prsl, Statein%prslk, & + Statein%phii, Statein%phil, dtp, dusfc1, dvsfc1, & + dtsfc1, dqsfc1, Diag%hpbl, gamt, gamq, dkt, kinver, & Model%xkzm_m, Model%xkzm_h) else - call moninp(ix, im, levs, nvdiff, dvdt, dudt, dtdt, dvdftra, & - Statein%ugrs, Statein%vgrs, Statein%tgrs, vdftra, & - Statein%prsik(1,1), rb, Sfcprop%ffmm, Sfcprop%ffhh, & - Sfcprop%tsfc, qss, hflx, evap, stress, wind, kpbl, & - Statein%prsi, del, Statein%prsl, Statein%phii, & - Statein%phil, dtp, dusfc1, dvsfc1, dtsfc1, dqsfc1, & - Diag%hpbl, gamt, gamq, dkt, Model%xkzm_m, Model%xkzm_h) + call moninp(ix, im, levs, nvdiff, dvdt, dudt, dtdt, dvdftra, & + Statein%ugrs, Statein%vgrs, Statein%tgrs, vdftra, & + Statein%prsik(1,1), rb, Sfcprop%ffmm, Sfcprop%ffhh, & + Sfcprop%tsfc, qss, hflx, evap, stress, wind, kpbl, & + Statein%prsi, del, Statein%prsl, Statein%phii, & + Statein%phil, dtp, dusfc1, dvsfc1, dtsfc1, dqsfc1, & + Diag%hpbl, gamt, gamq, dkt, Model%xkzm_m, Model%xkzm_h) endif endif ! end if_hybedmf @@ -2031,14 +2069,6 @@ subroutine GFS_physics_driver & clw(i,k,2) = -999.9 enddo enddo - if ((Model%imfdeepcnv >= 0) .or. (Model%imfshalcnv > 0)) then - do k=1,levs - do i=1,im - cnvc(i,k) = 0.0 - cnvw(i,k) = 0.0 - enddo - enddo - endif if(imp_physics == 8) then if(Model%ltaerosol) then @@ -2095,17 +2125,24 @@ subroutine GFS_physics_driver & ! -------------------------------------------- if (ntcw > 0) then - if (imp_physics == 10 .and. .not. Model%do_shoc) then ! compute rhc for GMAO macro physics cloud pdf +! if (imp_physics == 10 .and. .not. Model%do_shoc) then ! compute rhc for GMAO macro physics cloud pdf + if (imp_physics == 10) then ! compute rhc for GMAO macro physics cloud pdf do i=1,im tx1(i) = 1.0 / Statein%prsi(i,1) - tx2(i) = 1.0 - rhbbot +! tx2(i) = 1.0 - rhbbot + tx2(i) = 1.0 - rhc_max * work1(i)-rhbbot*work2(i) enddo do k = 1, levs do i = 1, im + kk = max(2,kpbl(i)) tem = Statein%prsl(i,k) * tx1(i) - tem1 = min(max((tem-turnrhcrit)/slope_mg, -20.0), 20.0) -! tem2 = min(max((0.3-0.2*abs(cos(Grid%xlat(i)))-tem)/slope_upmg, -20.0), 20.0) ! Anning - tem2 = min(max((turnrhcrit_upper-tem)/slope_upmg, -20.0), 20.0) + +! tem1 = min(max((tem-turnrhcrit)/slope_mg, -20.0), 20.0) +! tem2 = min(max((turnrhcrit_upper-tem)/slope_upmg, -20.0), 20.0) + + tem1 = min(max((tem-Statein%prsi(i,kk)*tx1(i))/slope_mg, -20.0), 20.0) + tem2 = min(max((0.3-0.2*abs(cos(Grid%xlat(i)))-tem)/slope_upmg, -20.0), 20.0) ! Anning + if (islmsk(i) > 0) then tem1 = 1.0 / (1.0+exp(tem1+tem1)) else @@ -2113,8 +2150,8 @@ subroutine GFS_physics_driver & endif tem2 = 1.0 / (1.0+exp(tem2)) -! rhc(i,k) = min(rhc_max, max(0.7, 1.0-tx2(i)*tem1*tem2)) - rhc(i,k) = min(rhc_max, rhc_max*work1(i) + (1.0-tx2(i)*tem1*tem2)*work2(i)) + rhc(i,k) = min(rhc_max, max(0.7, 1.0-tx2(i)*tem1*tem2)) +! rhc(i,k) = min(rhc_max, rhc_max*work1(i) + (1.0-tx2(i)*tem1*tem2)*work2(i)) enddo enddo else @@ -2167,13 +2204,13 @@ subroutine GFS_physics_driver & clw(i,k,2) = Stateout%gq0(i,k,ntcw) ! water enddo enddo - else ! if_ntcw + else do i=1,im psautco_l(i) = Model%psautco(1)*work1(i) + Model%psautco(2)*work2(i) prautco_l(i) = Model%prautco(1)*work1(i) + Model%prautco(2)*work2(i) enddo rhc(:,:) = 1.0 - endif ! end if_ntcw + endif ! ! Call SHOC if do_shoc is true and shocaftcnv is false ! @@ -2200,6 +2237,7 @@ subroutine GFS_physics_driver & do i=1,im qrn(i,k) = Stateout%gq0(i,k,ntrw) qsnw(i,k) = Stateout%gq0(i,k,ntsw) + Stateout%gq0(i,k,ntgl) + clw(i,k,1) = clw(i,k,1) + Stateout%gq0(i,k,ntgl) enddo enddo endif @@ -2227,7 +2265,7 @@ subroutine GFS_physics_driver & endif ! if (lprnt) write(0,*)'gt01=',Stateout%gt0(ipr,:) -! if (lprnt) write(0,*)'gq01=',Stateout%gq0(ipr,1:20,1) +! if (lprnt) write(0,*)'gq01=',Stateout%gq0(ipr,1:60,1) ! if (lprnt) write(0,*)'clwi=',clw(ipr,1:20,1) ! if (lprnt) write(0,*)'clwl=',clw(ipr,1:10,2) ! dtshoc = 60.0 @@ -2237,16 +2275,16 @@ subroutine GFS_physics_driver & ! nshocm = max(1, nint(dtp/dtshoc)) ! dtshoc = dtp / nshocm ! do nshoc=1,nshocm -! if (lprnt) write(0,*)' before shoc tke=',clw(ipr,1:25,ntk), & +! if (lprnt) write(0,*)' before shoc tke=',clw(ipr,1:45,ntk), & ! &' kdt=',kdt,'xlon=',grid%xlon(ipr),' xlat=',grid%xlat(ipr) ! phy_f3d(1,1,ntot3d-2) - shoc determined sgs clouds ! phy_f3d(1,1,ntot3d-1) - shoc determined diffusion coefficients ! phy_f3d(1,1,ntot3d ) - shoc determined w'theta' ! -! dqdt(1:im,:,1) = gq0(1:im,:,1) -! dqdt(1:im,:,2) = gq0(1:im,:,ntiw) -! dqdt(1:im,:,3) = gq0(1:im,:,ntcw) +! dqdt(1:im,:,1) = Stateout%gq0(1:im,:,1) +! dqdt(1:im,:,2) = Stateout%gq0(1:im,:,ntiw) +! dqdt(1:im,:,3) = Stateout%gq0(1:im,:,ntcw) !GFDL lat has no meaning inside of shoc - changed to "1" !GFDL call shoc(ix, im, 1, levs, levs+1, dtp, me, lat, ! call shoc (ix, im, 1, levs, levs+1, dtp, me, 1, Statein%prsl(1,1), & @@ -2254,7 +2292,8 @@ subroutine GFS_physics_driver & call shoc (ix, im, 1, levs, levs+1, dtp, me, 1, Statein%prsl(1,1), & Statein%phii(1,1), Statein%phil(1,1), Stateout%gu0(1,1), & Stateout%gv0(1,1), Statein%vvl(1,1), Stateout%gt0(1,1), & - Stateout%gq0(1,1,1), clw(1,1,1), clw(1,1,2), qsnw, qrn, & + Stateout%gq0(1,1,1), clw(1,1,1), clw(1,1,2), & + qsnw, qrn, qgl, & rhc, Model%sup, Model%shoc_parm(1), Model%shoc_parm(2), & Model%shoc_parm(3), Model%shoc_parm(4), & Model%shoc_parm(5), Tbd%phy_f3d(1,1,ntot3d-2), & @@ -2263,7 +2302,15 @@ subroutine GFS_physics_driver & Tbd%phy_f3d(1,1,ntot3d), lprnt, ipr, ncpl, ncpi) ! enddo + if (imp_physics == 10 .and. Model%fprcp > 1) then + do k=1,levs + do i=1,im + clw(i,k,1) = clw(i,k,1) - Stateout%gq0(i,k,ntgl) + enddo + enddo + endif ! if (lprnt) write(0,*)'aftshocgt0=',Stateout%gt0(ipr,:) +! if (lprnt) write(0,*)'aftshocgq0=',Stateout%gq0(ipr,1:60,1) ! if (lprnt) write(0,*)' aft shoc tke=',clw(ipr,1:25,ntk), & ! &' kdt=',kdt,'xlon=',grid%xlon(ipr),' xlat=',grid%xlat(ipr) ! if (lprnt) write(0,*)' aftshoccld=',tbd%phy_f3d(ipr,:,ntot3d-2)*100 @@ -2274,6 +2321,11 @@ subroutine GFS_physics_driver & ! call moist_bud(im,im,ix,levs,me,kdt,con_g,dtp,del,rain1 ! &, dqdt(1,1,1), dqdt(1,1,2), dqdt(1,1,3) ! &, gq0(1,1,1),clw(1,1,2),clw(1,1,1),'shoc ') +! tem = 1000.0 +! call moist_bud(im,im,ix,levs,me,kdt,con_g,tem,del,rain1 & +! &, dqdt(1,1,1), dqdt(1,1,2), dqdt(1,1,3) & +! &, Stateout%gq0(1:ix,1:levs,1),clw(1,1,2),clw(1,1,1) & +! &, ' shoc ', grid%xlon(1:im), grid%xlat(1:im)) if (ntlnc > 0 .and. ntinc > 0 .and. ncld >= 2) then do k=1,levs @@ -2320,6 +2372,9 @@ subroutine GFS_physics_driver & Stateout%gv0, cld1d, rain1, kbot, ktop, kcnv, & islmsk, Statein%vvl, ncld, ud_mf, dd_mf, & dt_mf, cnvw, cnvc, & + QLCN, QICN, w_upi,cf_upi, CNV_MFD, & +! QLCN, QICN, w_upi,cf_upi, CNV_MFD, CNV_PRC3, & + CNV_DQLDT,CLCN,CNV_FICE,CNV_NDROP,CNV_NICE,imp_physics,& Model%clam_deep, Model%c0s_deep, & Model%c1_deep, Model%betal_deep, Model%betas_deep, & Model%evfact_deep, Model%evfactl_deep, & @@ -2336,6 +2391,10 @@ subroutine GFS_physics_driver & Stateout%gu0, Stateout%gv0, & cld1d, rain1, kbot, ktop, kcnv, islmsk, garea, & Statein%vvl, ncld, ud_mf, dd_mf, dt_mf, cnvw, cnvc, & + QLCN, QICN, w_upi,cf_upi, CNV_MFD, & +! QLCN, QICN, w_upi,cf_upi, CNV_MFD, CNV_PRC3, & + CNV_DQLDT,CLCN,CNV_FICE,CNV_NDROP,CNV_NICE, & + imp_physics, & Model%clam_deep, Model%c0s_deep, & Model%c1_deep, Model%betal_deep, Model%betas_deep, & Model%evfact_deep, Model%evfactl_deep, & @@ -2347,10 +2406,31 @@ subroutine GFS_physics_driver & Stateout%gq0(:,:,1), Stateout%gt0, Stateout%gu0, & Stateout%gv0, cld1d, rain1, kbot, ktop, kcnv, & islmsk, Statein%vvl, Tbd%rann, ncld, & - ud_mf, dd_mf, dt_mf, cnvw, cnvc) + ud_mf, dd_mf, dt_mf, cnvw, cnvc, & + QLCN, QICN, w_upi,cf_upi, CNV_MFD, & +! QLCN, QICN, w_upi,cf_upi, CNV_MFD, CNV_PRC3, & + CNV_DQLDT,CLCN,CNV_FICE,CNV_NDROP,CNV_NICE,imp_physics ) ! if (lprnt) print *,' rain1=',rain1(ipr),' rann=',rann(ipr,1) endif +! + if (Model%npdf3d == 3 .and. Model%num_p3d == 4) then + do k=1,levs + do i=1,im + Tbd%phy_f3d(i,k,num2) = cnvw(i,k) + Tbd%phy_f3d(i,k,num3) = cnvc(i,k) + cnvw(i,k) = 0.0 + cnvc(i,k) = 0.0 + enddo + enddo + elseif (Model%npdf3d == 0 .and. Model%ncnvcld3d == 1) then + do k=1,levs + do i=1,im + Tbd%phy_f3d(i,k,num2) = cnvw(i,k) + cnvw(i,k) = 0.0 + enddo + enddo + endif else ! ras or cscnv fscav(:) = 0.0 @@ -2360,15 +2440,16 @@ subroutine GFS_physics_driver & ! write(0,*)' bef cs_cconv phii=',phii(ipr,:) ! &,' sizefsc=',size(fscav) ! write(0,*)' bef cs_cconv otspt=',otspt,' kdt=',kdt,' me=',me - do k=1,levs - do i=1,im - dqdt(i,k,1) = Stateout%gq0(i,k,1) - dqdt(i,k,2) = max(0.0,clw(i,k,2)) - dqdt(i,k,3) = max(0.0,clw(i,k,1)) - enddo - enddo +! do k=1,levs +! do i=1,im +! dqdt(i,k,1) = Stateout%gq0(i,k,1) +! dqdt(i,k,2) = clw(i,k,2) +! dqdt(i,k,3) = clw(i,k,1) +! enddo +! enddo ! if (lprnt) write(0,*)'befcsgt0=',Stateout%gt0(ipr,:) +! if (lprnt) write(0,*)'befcstke=',clw(ipr,1:25,ntk) call cs_convr (ix, im, levs, tottracer+3, Model%nctp, & otspt(1:tottracer+3,1:2), 1, & @@ -2377,19 +2458,27 @@ subroutine GFS_physics_driver & Statein%prsi, dtp, dtf, ud_mf, dd_mf, dt_mf, & Stateout%gu0, Stateout%gv0, fscav, fswtr, & Tbd%phy_fctd, me, wcbmax, Model%cs_parm(3), & - Model%cs_parm(4), sigmatot, & + Model%cs_parm(4), Model%cs_parm(9), sigmatot, & ! Model%cs_parm(4), sigmai, sigmatot, vverti, & Model%do_aw, Model%do_awdd, Model%flx_form, & lprnt, ipr, kcnv, QLCN, QICN, & - w_upi, cf_upi, CNV_MFD, CNV_PRC3, CNV_DQLDT, & + w_upi, cf_upi, CNV_MFD, CNV_DQLDT, & +! w_upi, cf_upi, CNV_MFD, CNV_PRC3, CNV_DQLDT, & CLCN, CNV_FICE, CNV_NDROP, CNV_NICE, imp_physics) ! if (lprnt) write(0,*)'aftcsgt0=',Stateout%gt0(ipr,:) +! if (lprnt) write(0,*)'aftcstke=',clw(ipr,1:25,ntk) ! write(1000+me,*)' at latitude = ',lat ! call moist_bud(im,im,ix,levs,me,kdt,con_g,dtp,del,rain1 ! &, dqdt(1,1,1), dqdt(1,1,2), dqdt(1,1,3) ! &, gq0(1,1,1),clw(1,1,2),clw(1,1,1),' cs_conv') +! tem = 1000.0 +! call moist_bud(im,im,ix,levs,me,kdt,con_g,tem,del,rain1 & +! &, dqdt(1,1,1), dqdt(1,1,2), dqdt(1,1,3) & +! &, Stateout%gq0(1:ix,1:levs,1),clw(1,1,2),clw(1,1,1) & +! &, ' cs_conv', grid%xlon(1:im), grid%xlat(1:im)) + rain1(:) = rain1(:) * (dtp*0.001) if (Model%do_aw) then @@ -2412,53 +2501,71 @@ subroutine GFS_physics_driver & else ! ras version 2 - if ((Model%ccwf(1) >= 0.0) .or. (Model%ccwf(2) >= 0)) then + if (Model%ccwf(1) >= 0.0 .or. Model%ccwf(2) >= 0) then do i=1,im - ccwfac(i) = Model%ccwf(1)*work1(i) + Model%ccwf(2)*work2(i) - dlqfac(i) = Model%dlqf(1)*work1(i) + Model%dlqf(2)*work2(i) - lmh (i) = levs + ccwfac(i) = Model%ccwf(1)*work1(i) + Model%ccwf(2)*work2(i) + dlqfac(i) = Model%dlqf(1)*work1(i) + Model%dlqf(2)*work2(i) + psaur_l(i) = Model%psauras(1)*work1(i) + Model%psauras(2)*work2(i) + praur_l(i) = Model%prauras(1)*work1(i) + Model%prauras(2)*work2(i) enddo else do i=1,im ccwfac(i) = -999.0 dlqfac(i) = 0.0 - lmh (i) = levs enddo endif -! if (lprnt) write(0,*) ' calling ras for kdt=',kdt,' me=',me & -! &, ' lprnt=',lprnt,' ccwfac=',ccwfac(ipr) - -! do k=1,levs -! do i=1,im -! dqdt(i,k,1) = gq0(i,k,1) -! dqdt(i,k,2) = max(0.0,clw(i,k,2)) -! dqdt(i,k,3) = max(0.0,clw(i,k,1)) +! if (lprnt) write(0,*) ' calling ras for kdt=',kdt,' me=',me & +! &, ' lprnt=',lprnt,' ccwfac=',ccwfac(ipr) + +! do k=1,levs +! do i=1,im +! dqdt(i,k,1) = Stateout%gq0(i,k,1) +! dqdt(i,k,2) = clw(i,k,2) +! dqdt(i,k,3) = clw(i,k,1) +! enddo ! enddo -! enddo revap = .true. -! if (ncld ==2) revap = .false. +! if (ncld ==2) revap = .false. + trcmin(:) = -999999.0 + if (ntk-2 > 0) trcmin(ntk-2) = 1.0e-4 + +! if (lprnt) write(0,*)' gt04bras=',Stateout%gt0(ipr,1:60) +! if (lprnt) write(0,*)' gq04bras=',Stateout%gq0(ipr,1:60,1) +! if (lprnt) write(0,*)'befrastke=',clw(ipr,1:25,ntk) +! if (lprnt) write(0,*)'trcmin=',trcmin(ntk-2),' ntk=',ntk + call rascnv (im, ix, levs, dtp, dtf, Tbd%rann, Stateout%gt0, & Stateout%gq0, Stateout%gu0, Stateout%gv0, clw, & tottracer, fscav, Statein%prsi, Statein%prsl, & Statein%prsik, Statein%prslk, Statein%phil, & Statein%phii, kpbl, cd, rain1, kbot, ktop, kcnv, & Tbd%phy_f2d(1,Model%num_p2d), Model%flipv, pa2mb, & - me, garea, lmh, ccwfac, Model%nrcm, rhc, ud_mf, & - dd_mf, dt_mf, dlqfac, lprnt, ipr, kdt, revap, QLCN, & - QICN, w_upi, cf_upi, CNV_MFD, CNV_PRC3, CNV_DQLDT, & - CLCN, CNV_FICE, CNV_NDROP, CNV_NICE, imp_physics) + me, garea, ccwfac, Model%nrcm, rhc, ud_mf, & + dd_mf, dt_mf, praur_l, Model%wminras(1), & + psaur_l, Model%wminras(2), dlqfac, & + lprnt, ipr, kdt, revap, QLCN, & + QICN, w_upi, cf_upi, CNV_MFD, CNV_DQLDT, & +! QICN, w_upi, cf_upi, CNV_MFD, CNV_PRC3, CNV_DQLDT, & + CLCN, CNV_FICE, CNV_NDROP, CNV_NICE, imp_physics, & +! trcmin) + trcmin, ntk) + +! if (lprnt) write(0,*)' gt04=',Stateout%gt0(ipr,1:60) +! if (lprnt) write(0,*)' gq04=',Stateout%gq0(ipr,1:60,1) +! if (lprnt) write(0,*)'aftrastke=',clw(ipr,1:25,ntk) + endif ! write(1000+me,*)' at latitude = ',lat -! tx1 = 1000.0 -! call moist_bud(im,im,ix,levs,me,kdt,con_g,tx1,del,rain1 -! &, dqdt(1,1,1), dqdt(1,1,2), dqdt(1,1,3) -! &, gq0(1,1,1),clw(1,1,2),clw(1,1,1),' ras_conv') -! if(lprnt) write(0,*)' after ras rain1=',rain1(ipr) +! tem = 1000.0 +! call moist_bud(im,im,ix,levs,me,kdt,con_g,tem,del,rain1 & +! &, dqdt(1,1,1), dqdt(1,1,2), dqdt(1,1,3) & +! &, Stateout%gq0(1:ix,1:levs,1),clw(1,1,2),clw(1,1,1) & +! &, ' ras_conv', grid%xlon(1:im), grid%xlat(1:im)) +! if(lprnt) write(0,*)' after ras rain1=',rain1(ipr),' me=',me,' kdt=',kdt ! &,' cnv_prc3sum=',sum(cnv_prc3(ipr,1:levs)) ! if (lprnt) write(0,*)' gt04=',gt0(ipr,1:10) -! if (lprnt) write(0,*)' gq04=',gq0(ipr,:,1) cld1d = 0 @@ -2499,8 +2606,6 @@ subroutine GFS_physics_driver & ud_mf = 0. dd_mf = 0. dt_mf = 0. - cnvw = 0. - cnvc = 0. endif ! if (lprnt) then @@ -2551,26 +2656,6 @@ subroutine GFS_physics_driver & enddo endif ! if (lgocart) ! - if ((Model%npdf3d == 3) .and. (Model%num_p3d == 4)) then - num2 = Model%num_p3d + 2 - num3 = num2 + 1 - do k=1,levs - do i=1,im - Tbd%phy_f3d(i,k,num2) = cnvw(i,k) - Tbd%phy_f3d(i,k,num3) = cnvc(i,k) - cnvw(i,k) = 0.0 - cnvc(i,k) = 0.0 - enddo - enddo - elseif ((Model%npdf3d == 0) .and. (Model%ncnvcld3d == 1)) then - num2 = Model%num_p3d + 1 - do k=1,levs - do i=1,im - Tbd%phy_f3d(i,k,num2) = cnvw(i,k) - cnvw(i,k) = 0.0 - enddo - enddo - endif ! if (lprnt) write(7000,*)' bef cnvgwd gu0=',gu0(ipr,:) ! &,' lat=',lat,' kdt=',kdt,' me=',me @@ -2785,13 +2870,13 @@ subroutine GFS_physics_driver & ! -------------------------------------- if (Model%imfshalcnv == 1) then ! opr option now at 2014 !----------------------- - call shalcnv (im, ix, levs, Model%jcap, dtp, del, Statein%prsl, & - Statein%pgr, Statein%phil, clw, Stateout%gq0, & - Stateout%gt0, Stateout%gu0, Stateout%gv0, rain1, & - kbot, ktop, kcnv, islmsk, Statein%vvl, ncld, & - Diag%hpbl, hflx, evap, ud_mf, dt_mf, cnvw, cnvc, & - Model%clam_shal, Model%c0s_shal, Model%c1_shal, & - Model%pgcon_shal) + call shalcnv (im, ix, levs, Model%jcap, dtp, del, Statein%prsl, & + Statein%pgr, Statein%phil, clw, Stateout%gq0, & + Stateout%gt0, Stateout%gu0, Stateout%gv0, rain1, & + kbot, ktop, kcnv, islmsk, Statein%vvl, ncld, & + Diag%hpbl, hflx, evap, ud_mf, dt_mf, cnvw, cnvc, & + Model%clam_shal, Model%c0s_shal, Model%c1_shal, & + Model%pgcon_shal) do i=1,im raincs(i) = frain * rain1(i) @@ -2803,15 +2888,15 @@ subroutine GFS_physics_driver & Diag%cnvprcpb(i) = Diag%cnvprcpb(i) + raincs(i) enddo endif -! in shalcnv, 'cnvw' and 'cnvc' are not set to zero: - if ((Model%shcnvcw) .and. (Model%num_p3d == 4) .and. (Model%npdf3d == 3)) then +! in shalcnv, 'cnvw' and 'cnvc' are not set to zero + if (Model%shcnvcw .and. Model%num_p3d == 4 .and. Model%npdf3d == 3) then do k=1,levs do i=1,im Tbd%phy_f3d(i,k,num2) = Tbd%phy_f3d(i,k,num2) + cnvw(i,k) Tbd%phy_f3d(i,k,num3) = Tbd%phy_f3d(i,k,num3) + cnvc(i,k) enddo enddo - elseif ((Model%npdf3d == 0) .and. (Model%ncnvcld3d == 1)) then + elseif (Model%npdf3d == 0 .and. Model%ncnvcld3d == 1) then do k=1,levs do i=1,im Tbd%phy_f3d(i,k,num2) = Tbd%phy_f3d(i,k,num2) + cnvw(i,k) @@ -2846,14 +2931,14 @@ subroutine GFS_physics_driver & enddo endif ! in mfshalcnv, 'cnvw' and 'cnvc' are set to zero before computation starts: - if ((Model%shcnvcw) .and. (Model%num_p3d == 4) .and. (Model%npdf3d == 3)) then + if (Model%shcnvcw .and. Model%num_p3d == 4 .and. Model%npdf3d == 3) then do k=1,levs do i=1,im Tbd%phy_f3d(i,k,num2) = Tbd%phy_f3d(i,k,num2) + cnvw(i,k) Tbd%phy_f3d(i,k,num3) = Tbd%phy_f3d(i,k,num3) + cnvc(i,k) enddo enddo - elseif ((Model%npdf3d == 0) .and. (Model%ncnvcld3d == 1)) then + elseif (Model%npdf3d == 0 .and. Model%ncnvcld3d == 1) then do k=1,levs do i=1,im Tbd%phy_f3d(i,k,num2) = Tbd%phy_f3d(i,k,num2) + cnvw(i,k) @@ -2986,13 +3071,13 @@ subroutine GFS_physics_driver & call shoc (ix, im, 1, levs, levs+1, dtp, me, 1, Statein%prsl(1,1), & Statein%phii(1,1), Statein%phil(1,1), Stateout%gu0(1,1), & Stateout%gv0(1,1), Statein%vvl(1,1), Stateout%gt0(1,1), & - Stateout%gq0(1,1,1), clw(1,1,1), clw(1,1,2), qsnw, qrn, & + Stateout%gq0(1,1,1), clw(1,1,1), clw(1,1,2), & + qsnw, qrn, qgl, & rhc, Model%sup, Model%shoc_parm(1), Model%shoc_parm(2), & Model%shoc_parm(3), Model%shoc_parm(4), & Model%shoc_parm(5), Tbd%phy_f3d(1,1,ntot3d-2), & - Model%sup, Tbd%phy_f3d(1,1,ntot3d-2), & Stateout%gq0(1,1,ntke), hflx, evap, prnum, & - Tbd%phy_f3d(1,1,ntot3d-1), Tbd%phy_f3d(1,1,ntot3d), & + Tbd%phy_f3d(1,1,ntot3d-1), Tbd%phy_f3d(1,1,ntot3d), & lprnt, ipr, ncpl, ncpi) ! enddo @@ -3223,7 +3308,7 @@ subroutine GFS_physics_driver & Statein%pgr, Stateout%gq0(1,1,1), & Stateout%gq0(1,1,ntcw), Stateout%gt0, & Tbd%phy_f3d(1,1,1), Tbd%phy_f3d(1,1,2), & - Tbd%phy_f2d(1,1), Tbd%phy_f3d(1,1,3), & + Tbd%phy_f2d(1,1), Tbd%phy_f3d(1,1,3), & Tbd%phy_f3d(1,1,4), Tbd%phy_f2d(1,2), rhc, & Tbd%phy_f3d(1,1,Model%num_p3d+1), Model%sup, & lprnt, ipr, kdt) @@ -3300,7 +3385,7 @@ subroutine GFS_physics_driver & ! elseif (imp_physics == 10) then ! MGB double-moment microphysics ! ------------------------------ - kk = 1 + kk = 5 if (Model%fprcp >= 2) kk = 6 ! Acheng used clw here for other code to run smoothly and minimum change @@ -3345,59 +3430,7 @@ subroutine GFS_physics_driver & enddo endif - elseif ((Model%imfdeepcnv >= 0) .or. (Model%imfshalcnv > 0)) then - if (Model%fprcp == 0) then - do k=1,levs - do i=1,im - clw(i,k,1) = Stateout%gq0(i,k,ntiw) ! ice - clw(i,k,2) = Stateout%gq0(i,k,ntcw) ! water - Tbd%phy_f3d(i,k,1) = max(0.0, min(1.0,Tbd%phy_f3d(i,k,1)+cnvc(i,k))) - ! clouds from t-dt and cnvc - tem = cnvw(i,k)* max(0.0, MIN(1.0, (TCR-Stateout%gt0(i,k))*TCRF)) - qlcn(i,k) = qlcn(i,k) + cnvw(i,k) - tem - qicn(i,k) = qicn(i,k) + tem - cf_upi(i,k) = cf_upi(i,k) + cnvc(i,k) - enddo - enddo - elseif (abs(Model%fprcp) == 1 .or. mg3_as_mg2) then - do k=1,levs - do i=1,im - clw(i,k,1) = Stateout%gq0(i,k,ntiw) ! ice - clw(i,k,2) = Stateout%gq0(i,k,ntcw) ! water - Tbd%phy_f3d(i,k,1) = max(0.0, min(1.0,Tbd%phy_f3d(i,k,1)+cnvc(i,k))) - ! clouds from t-dt and cnvc - tem = cnvw(i,k)* max(0.0, MIN(1.0, (TCR-Stateout%gt0(i,k))*TCRF)) - qlcn(i,k) = qlcn(i,k) + cnvw(i,k) - tem - qicn(i,k) = qicn(i,k) + tem - cf_upi(i,k) = cf_upi(i,k) + cnvc(i,k) - - qrn(i,k) = Stateout%gq0(i,k,ntrw) - qsnw(i,k) = Stateout%gq0(i,k,ntsw) - ncpr(i,k) = Stateout%gq0(i,k,ntrnc) - ncps(i,k) = Stateout%gq0(i,k,ntsnc) - enddo - enddo - else - do k=1,levs - do i=1,im - clw(i,k,1) = Stateout%gq0(i,k,ntiw) ! ice - clw(i,k,2) = Stateout%gq0(i,k,ntcw) ! water - Tbd%phy_f3d(i,k,1) = max(0.0, min(1.0,Tbd%phy_f3d(i,k,1)+cnvc(i,k))) - ! clouds from t-dt and cnvc - tem = cnvw(i,k)* max(0.0, MIN(1.0, (TCR-Stateout%gt0(i,k))*TCRF)) - qlcn(i,k) = qlcn(i,k) + cnvw(i,k) - tem - qicn(i,k) = qicn(i,k) + tem - cf_upi(i,k) = cf_upi(i,k) + cnvc(i,k) - qrn(i,k) = Stateout%gq0(i,k,ntrw) - qsnw(i,k) = Stateout%gq0(i,k,ntsw) - qgl(i,k) = Stateout%gq0(i,k,ntgl) - ncpr(i,k) = Stateout%gq0(i,k,ntrnc) - ncps(i,k) = Stateout%gq0(i,k,ntsnc) - ncgl(i,k) = Stateout%gq0(i,k,ntgnc) - enddo - enddo - endif else ! clouds from t-dt and cnvc if (Model%fprcp == 0 ) then @@ -3405,7 +3438,6 @@ subroutine GFS_physics_driver & do i=1,im clw(i,k,1) = Stateout%gq0(i,k,ntiw) ! ice clw(i,k,2) = Stateout%gq0(i,k,ntcw) ! water -! Tbd%phy_f3d(i,k,1) = min(1.0, Tbd%phy_f3d(i,k,1)) enddo enddo elseif (abs(Model%fprcp) == 1 .or. mg3_as_mg2) then @@ -3417,7 +3449,6 @@ subroutine GFS_physics_driver & qsnw(i,k) = Stateout%gq0(i,k,ntsw) ncpr(i,k) = Stateout%gq0(i,k,ntrnc) ncps(i,k) = Stateout%gq0(i,k,ntsnc) -! Tbd%phy_f3d(i,k,1) = min(1.0, Tbd%phy_f3d(i,k,1)) enddo enddo else @@ -3431,11 +3462,17 @@ subroutine GFS_physics_driver & ncpr(i,k) = Stateout%gq0(i,k,ntrnc) ncps(i,k) = Stateout%gq0(i,k,ntsnc) ncgl(i,k) = Stateout%gq0(i,k,ntgnc) -! Tbd%phy_f3d(i,k,1) = min(1.0, Tbd%phy_f3d(i,k,1)) enddo enddo endif endif +! add convective cloud fraction + do k = 1,levs + do i = 1,im + Tbd%phy_f3d(i,k,1) = min(1.0, Tbd%phy_f3d(i,k,1) + clcn(i,k)) + enddo + enddo + ! notice clw ix instead of im ! call m_micro_driver(im,ix,levs,flipv,del,dtp,prsl,prsi, ! & prslk,prsik,pgr,vvl,clw(1,1,2), QLCN, clw(1,1,1),QICN, @@ -3452,7 +3489,7 @@ subroutine GFS_physics_driver & ! if (lprnt) write(0,*)' cloudsb=',tbd%phy_f3d(ipr,:,1)*100,' kdt=',kdt ! if (lprnt) write(0,*)' cloudsb=',Tbd%phy_f3d(ipr,:,1)*100,' kdt=',kdt ! if (lprnt) write(0,*)' clcn=',clcn(ipr,:)*100,' kdt=',kdt -! txa(:,:) = gq0(:,:,1) +! txa(:,:) = Stateout%gq0(:,:,1) ! do k=1,levs ! write(1000+me,*)' maxwatncb=',maxval(Stateout%gq0(1:im,k,ntlnc)),' k=',k,' kdt',kdt ! enddo @@ -3461,7 +3498,8 @@ subroutine GFS_physics_driver & Statein%prsi, Statein%phil, Statein%phii, & Statein%vvl, clw(1,1,2), QLCN, clw(1,1,1), QICN, & Radtend%htrlw, Radtend%htrsw, w_upi, cf_upi, & - FRLAND, Diag%HPBL, CNV_MFD, CNV_PRC3, CNV_DQLDT, & + FRLAND, Diag%HPBL, CNV_MFD, CNV_DQLDT, & +! FRLAND, Diag%HPBL, CNV_MFD, CNV_PRC3, CNV_DQLDT, & CLCN, Stateout%gu0, Stateout%gv0, Diag%dusfc, & Diag%dvsfc, dusfc1, dvsfc1, dusfc1, dvsfc1, & CNV_FICE, CNV_NDROP, CNV_NICE, Stateout%gq0(1,1,1), & @@ -3470,25 +3508,33 @@ subroutine GFS_physics_driver & Diag%sr, Stateout%gq0(1,1,ntlnc), & Stateout%gq0(1,1,ntinc), Model%fprcp, qrn, & qsnw, qgl, ncpr, ncps, ncgl, & - Tbd%phy_f3d(1,1,1), kbot, & - Tbd%phy_f3d(1,1,2),Tbd%phy_f3d(1,1,3), & - Tbd%phy_f3d(1,1,4),Tbd%phy_f3d(1,1,5), & - Tbd%phy_f3d(1,1,kk), & - Model%aero_in, skip_macro, cn_prc, cn_snr, lprnt, & + Tbd%phy_f3d(1,1,1), kbot, & + Tbd%phy_f3d(1,1,2), Tbd%phy_f3d(1,1,3), & + Tbd%phy_f3d(1,1,4), Tbd%phy_f3d(1,1,5), & + Tbd%phy_f3d(1,1,kk), Tbd%aer_nm, & + Model%aero_in, Tbd%in_nm, Tbd%ccn_nm, Model%iccn, & + skip_macro, lprnt, & +! skip_macro, cn_prc, cn_snr, lprnt, & ! ipr, kdt, Grid%xlat, Grid%xlon) + Model%mg_alf, Model%mg_qcmin, Model%pdfflag, & ipr, kdt, Grid%xlat, Grid%xlon, rhc) ! do k=1,levs ! write(1000+me,*)' maxwatnca=',maxval(Stateout%gq0(1:im,k,ntlnc)),' k=',k,' kdt=',kdt ! enddo -! write(1000+me,*)' at latitude = ',lat -! tx1 = 1000.0 -! call moist_bud(im,ix,ix,levs,me,kdt,con_g,tx1,del,rain1 -! &, txa, clw(1,1,2), clw(1,1,1) -! &, gq0(1,1,1),gq0(1,1,ntcw),gq0(1,1,ntcw+1),' m_micro ') +! write(1000+me,*)' at kdt = ',kdt +! tem = 1000.0 + +! call moist_bud2(im,ix,ix,levs,me,kdt,con_g,tem,del,rain1 & +! &, txa, clw(1,1,2), clw(1,1,1) & +! &, Stateout%gq0(1:ix,1:levs,ntrw),Stateout%gq0(1:ix,1:levs,ntsw)& +! &, Stateout%gq0(1:ix,1:levs,ntgl) & +! &, Stateout%gq0(1:ix,1:levs,1),Stateout%gq0(1:ix,1:levs,ntcw) & +! &, Stateout%gq0(1:ix,1:levs,ntiw) & +! &, qrn, qsnw, qgl, ' m_micro ', grid%xlon(1:im), grid%xlat(1:im)) ! if (lprnt) write(0,*) ' rain1=',rain1(ipr)*86400.0, & ! &' rainc=',diag%rainc(ipr)*86400.0 & -! &,' cn_prc=',cn_prc(ipr),' cn_snr=',cn_snr(ipr) +! &,' cn_prc=',cn_prc(ipr),' cn_snr=',cn_snr(ipr),' kdt=',kdt ! if(lprnt) write(0,*) ' aftgt0=',Stateout%gt0(ipr,:),' kdt=',kdt ! if (lprnt) write(0,*) ' aftlsgq0=',stateout%gq0(ipr,:,1),' kdt=',kdt ! if (lprnt) write(0,*)' clw1aft=',stateout%gq0(ipr,:,ntiw),' kdt=',kdt @@ -3535,7 +3581,7 @@ subroutine GFS_physics_driver & ! if (lprnt) write(0,*)' qglba',qgl(ipr,:),' kdt=',kdt ! - elseif (imp_physics == 11) then ! GFDL MP + elseif (imp_physics == 11) then ! GFDL MP ! ------- do i = 1, im land (i,1) = frland(i) @@ -3660,24 +3706,7 @@ subroutine GFS_physics_driver & * tem2 * onebg enddo enddo -! add convective clouds - if (Model%do_shoc) then - do k = 1,levs - do i = 1,im - Tbd%phy_f3d(i,k,ntot3d-2) = min(1.0, Tbd%phy_f3d(i,k,ntot3d-2) & - + sigmafrac(i,k)) - enddo - enddo - if (ncld == 5) then - Stateout%gq0(:,:,ntclamt) = Tbd%phy_f3d(:,:,ntot3d-2) - endif - elseif (ncld == 2) then - do k = 1,levs - do i = 1,im - Tbd%phy_f3d(i,k,1) = min(1.0, Tbd%phy_f3d(i,k,1) + sigmafrac(i,k)) - enddo - enddo - endif + ! if (lprnt) write(0,*)' gt0aftpraw=',Stateout%gt0(ipr,:),' kdt=',kdt,'me=',me do n=ntcw,ntcw+nncl-1 do k = 1,levs @@ -3695,7 +3724,7 @@ subroutine GFS_physics_driver & enddo endif - Diag%rain(:) = Diag%rainc(:) + frain * rain1(:) + Diag%rain(:) = Diag%rainc(:) + frain * rain1(:) if (Model%cal_pre) then ! hchuang: add dominant precipitation type algorithm ! @@ -3780,15 +3809,15 @@ subroutine GFS_physics_driver & do i = 1, im Sfcprop%tprcp(i) = max(0.0, Diag%rain(i) )! clu: rain -> tprcp Sfcprop%srflag(i) = 0. ! clu: default srflag as 'rain' (i.e. 0) - if (Sfcprop%tsfc(i) .ge. 273.15) then + if (Sfcprop%tsfc(i) >= 273.15) then crain = Diag%rainc(i) csnow = 0.0 else crain = 0.0 csnow = Diag%rainc(i) endif -! if ((snow0(i,1)+ice0(i,1)+graupel0(i,1)+csnow) > (rain0(i,1)+crain)) then - if ((snow0(i,1)+ice0(i,1)+graupel0(i,1)+csnow) > 0.0) then +! if (snow0(i,1)+ice0(i,1)+graupel0(i,1)+csnow > rain0(i,1)+crain) then + if (snow0(i,1)+ice0(i,1)+graupel0(i,1)+csnow > 0.0) then Sfcprop%srflag(i) = 1. ! clu: set srflag to 'snow' (i.e. 1) endif enddo @@ -3807,17 +3836,17 @@ subroutine GFS_physics_driver & if (Model%cplflx) then do i = 1, im if (t850(i) > 273.16) then - Coupling%rain_cpl(i) = Coupling%rain_cpl(i) + Diag%rain(i) + Coupling%rain_cpl(i) = Coupling%rain_cpl(i) + Diag%rain(i) else - Coupling%snow_cpl(i) = Coupling%snow_cpl(i) + Diag%rain(i) + Coupling%snow_cpl(i) = Coupling%snow_cpl(i) + Diag%rain(i) endif enddo endif - if ((Model%cplchm).and.(.not.Model%cplflx)) then + if (Model%cplchm.and. .not. Model%cplflx) then do i = 1, im - Coupling%rain_cpl(i) = Coupling%rain_cpl(i) + Diag%rain(i) - Coupling%rainc_cpl(i) = Coupling%rainc_cpl(i) + Diag%rainc(i) + Coupling%rain_cpl(i) = Coupling%rain_cpl(i) + Diag%rain(i) + Coupling%rainc_cpl(i) = Coupling%rainc_cpl(i) + Diag%rainc(i) enddo endif ! --- ... end coupling insertion @@ -3829,7 +3858,7 @@ subroutine GFS_physics_driver & call sfc_diag (im, Statein%pgr, Stateout%gu0, Stateout%gv0, & Stateout%gt0, Stateout%gq0, Sfcprop%tsfc, qss, & Sfcprop%f10m, Diag%u10m, Diag%v10m, Sfcprop%t2m, & - Sfcprop%q2m, work3, evap, Sfcprop%ffmm, & + Sfcprop%q2m, work3, evap, Sfcprop%ffmm, & Sfcprop%ffhh, fm10, fh2) if (Model%lssav) then @@ -3942,7 +3971,7 @@ subroutine GFS_physics_driver & enddo endif - deallocate (clw) + deallocate (clw) if (allocated(cnvc)) deallocate(cnvc) if (allocated(cnvw)) deallocate(cnvw) if (allocated(qrn)) deallocate(qrn) @@ -3970,10 +3999,12 @@ subroutine GFS_physics_driver & ! if (lprnt) call mpi_quit(7) ! if (kdt > 2 ) call mpi_quit(70) ! if (lprnt) write(0,*)'qt0out=',Stateout%gt0(ipr,:) & +! if (lprnt) write(0,*)'gq0outtke=',Stateout%gq0(ipr,1:25,ntke) & ! ,'xlon=',grid%xlon(ipr)*57.29578,' xlat=',grid%xlat(ipr)*57.29578 ! if (lprnt) write(0,*)' clouddriverend=',Tbd%phy_f3d(ipr,:,1)*100,' kdt=',kdt - deallocate (qlcn, qicn, w_upi, cf_upi, CNV_MFD, CNV_PRC3, & +! deallocate (qlcn, qicn, w_upi, cf_upi, CNV_MFD, CNV_PRC3, & + deallocate (qlcn, qicn, w_upi, cf_upi, CNV_MFD, & CNV_DQLDT, clcn, cnv_fice, cnv_ndrop, cnv_nice) if (imp_physics == 11) then deallocate (delp, dz, uin, vin, pt, qv1, ql1, qr1, & @@ -3981,6 +4012,7 @@ subroutine GFS_physics_driver & w, qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt) endif +! if (kdt > 2 ) stop return !................................... end subroutine GFS_physics_driver @@ -3988,13 +4020,13 @@ end subroutine GFS_physics_driver subroutine moist_bud(im,ix,ix2,levs,me,kdt,grav,dtp,delp,rain, & - qv0,ql0,qi0,qv1,ql1,qi1,comp) + qv0,ql0,qi0,qv1,ql1,qi1,comp, xlon, xlat) ! nov 2016 - S. Moorthi - routine to compute local moisture budget use machine, only : kind_phys implicit none character*10 :: comp integer :: im,ix,ix2,levs,me,kdt - real (kind=kind_phys) :: grav, rain(im), dtp + real (kind=kind_phys) :: grav, rain(im), dtp, xlon(im), xlat(im) real (kind=kind_phys), dimension(ix,levs) :: qv0,ql0,qi0,delp real (kind=kind_phys), dimension(ix2,levs) :: qv1,ql1,qi1 REAL (kind=kind_phys), dimension(im) :: sumq, sumqv, sumql, sumqi @@ -4019,25 +4051,78 @@ subroutine moist_bud(im,ix,ix2,levs,me,kdt,grav,dtp,delp,rain, & sumqi(i) = - sumqi(i) * (1.0/grav) sumq (i) = sumqv(i) + sumql(i) + sumqi(i) enddo + do i=1,im + write(2000+me,*)' in moist_bud:',' i=',i,' sumq=',sumq(i), & + ' sumqv=',sumqv(i),' sumql=',sumql(i),' sumqi=',sumqi(i), & + ' rain=',rain(i)*dtp,' kdt=',kdt,' component=',trim(comp), & + ' qv:=',qv1(i,1),qv0(i,1),' ql=',ql1(i,1),ql0(i,1), & + ' qi=',qi1(i,1), qi0(i,1),' xlon=',xlon(i),' xlat=',xlat(i) + enddo + return + + end subroutine moist_bud + + + subroutine moist_bud2(im,ix,ix2,levs,me,kdt,grav,dtp,delp,rain, & + qv0,ql0,qi0,qr0,qs0,qg0, & + qv1,ql1,qi1,qr1,qs1,qg1,comp,xlon,xlat) +! aug 2018 - S. Moorthi - routine to compute local moisture budget + use machine, only : kind_phys + implicit none + character*10 :: comp + integer :: im,ix,ix2,levs,me,kdt + real (kind=kind_phys) :: grav, rain(im), dtp, oneog, xlon(im), xlat(im) + real (kind=kind_phys), dimension(ix,levs) :: qv0,ql0,qi0,delp, & + qr0,qs0,qg0 + real (kind=kind_phys), dimension(ix2,levs) :: qv1,ql1,qi1, & + qr1,qs1,qg1 + REAL (kind=kind_phys), dimension(im) :: sumq, sumqv, sumql, sumqi, & + sumqr, sumqs, sumqg + integer :: i, k +! + do i=1,im + sumqv(i) = 0.0 + sumql(i) = 0.0 + sumqi(i) = 0.0 + sumqr(i) = 0.0 + sumqs(i) = 0.0 + sumqg(i) = 0.0 + sumq (i) = 0.0 + enddo + do k=1,levs + do i=1,im + sumqv(i) = sumqv(i) + (qv1(i,k) - qv0(i,k)) * delp(i,k) + sumql(i) = sumql(i) + (ql1(i,k) - ql0(i,k)) * delp(i,k) + sumqi(i) = sumqi(i) + (qi1(i,k) - qi0(i,k)) * delp(i,k) + sumqr(i) = sumqr(i) + (qr1(i,k) - qr0(i,k)) * delp(i,k) + sumqs(i) = sumqs(i) + (qs1(i,k) - qs0(i,k)) * delp(i,k) + sumqg(i) = sumqg(i) + (qg1(i,k) - qg0(i,k)) * delp(i,k) + enddo + enddo + oneog = 1.0 / grav + do i=1,im + sumqv(i) = - sumqv(i) * oneog + sumql(i) = - sumql(i) * oneog + sumqi(i) = - sumqi(i) * oneog + sumqr(i) = - sumqr(i) * oneog + sumqs(i) = - sumqs(i) * oneog + sumqg(i) = - sumqg(i) * oneog + sumq (i) = sumqv(i) + sumql(i) + sumqi(i) + sumqr(i) & + + sumqs(i) + sumqg(i) + enddo do i=1,im write(1000+me,*)' in moist_bud:',' i=',i,' sumq=',sumq(i), & ' sumqv=',sumqv(i),' sumql=',sumql(i),' sumqi=',sumqi(i), & - ' rain=',rain(i)*dtp,' kdt=',kdt,' component=',comp, & + ' sumqr=',sumqr(i),' sumqs=',sumqs(i),' sumqg=',sumqg(i), & + ' rain=',rain(i)*dtp,' kdt=',kdt,' component=',trim(comp), & ' qv:=',qv1(i,1),qv0(i,1),' ql=',ql1(i,1),ql0(i,1), & - ' qi=',qi1(i,1), qi0(i,1) -! if(sumq(i) > 100) then -! write(1000+me,*)' i=',i,' sumq=',sumq(i) -! write(1000+me,*)' qv1=',(qv1(i,k),k=1,levs) -! write(1000+me,*)' qv0=',(qv0(i,k),k=1,levs) -! write(1000+me,*)' ql1=',(ql1(i,k),k=1,levs) -! write(1000+me,*)' ql0=',(ql0(i,k),k=1,levs) -! write(1000+me,*)' qi1=',(qi1(i,k),k=1,levs) -! write(1000+me,*)' qi0=',(qi0(i,k),k=1,levs) -! endif + ' qi=',qi1(i,1), qi0(i,1),' qr=',qr1(i,1),qr0(i,1), & + ' qs=',qs1(i,1), qs0(i,1),' qg=',qg1(i,1),qg0(i,1), & + ' xlon=',xlon(i),' xlat=',xlat(i) enddo return - end subroutine moist_bud + end subroutine moist_bud2 ! mg, sfc-perts *** ! the routines below are used in the percentile matching algorithm for the @@ -4202,3 +4287,4 @@ end subroutine dgamln !> @} end module module_physics_driver + diff --git a/gfsphysics/GFS_layer/GFS_radiation_driver.F90 b/gfsphysics/GFS_layer/GFS_radiation_driver.F90 index 92cbcd0ee..857125cad 100644 --- a/gfsphysics/GFS_layer/GFS_radiation_driver.F90 +++ b/gfsphysics/GFS_layer/GFS_radiation_driver.F90 @@ -296,6 +296,8 @@ ! down spectral components sw fluxes as output. ! ! Mar 2017 Ruiyu s.- add effect radii and other cloud properties! ! from the advanced MPs ! +! ----2018 S. Moorthi - update to use unified cloud from SHOC ! +! and/or MG2/3 microphysics and fix some bugs ! ! jun 2018 h-m lin/y-t hou - added option of de-correlation ! ! length cloud overlap method (Barker, 2008), removed ! the legacy rh based diagnostic cloud scheme ! @@ -1201,10 +1203,10 @@ subroutine GFS_radiation_driver & ! ! --- local variables: (horizontal dimensioned by IM) !--- INTEGER VARIABLES - integer :: me, im, lm, nfxr, ntrac + integer :: me, im, lm, levs, nfxr, ntrac integer :: i, j, k, k1, lv, itop, ibtc, nday, LP1, LMK, LMP, kd, & lla, llb, lya, lyb, kt, kb, n, ntcw, ntiw, ncld, ntrw, & - ntsw, ntgl + ntsw, ntgl, k2, lsk integer, dimension(size(Grid%xlon,1)) :: idxday integer, dimension(size(Grid%xlon,1),3) :: mbota, mtopa @@ -1219,8 +1221,8 @@ subroutine GFS_radiation_driver & real(kind=kind_phys), dimension(size(Grid%xlon,1),NF_ALBD) :: sfcalb real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+ltp) :: & - htswc, htlwc, gcice, grain, grime, htsw0, htlw0, plyr, tlyr, & - qlyr, olyr, rhly, tvly,qstl, vvel, prslk1, tem2da, & + htswc, htlwc, gcice, grain, grime, htsw0, htlw0, plyr, tlyr, & + qlyr, olyr, rhly, tvly, qstl, prslk1, tem2da, & dz,delp,cldcov, deltaq, cnvc, cnvw, effrl, effri, effrr, effrs real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+ltp+1) :: plvl, tlvl @@ -1258,6 +1260,7 @@ subroutine GFS_radiation_driver & !--- set commonly used integers me = Model%me LM = Model%levr + LEVS = Model%levs IM = size(Grid%xlon,1) NFXR = Model%nfxr NTRAC = Model%ntrac ! tracers in grrad strip off sphum - start tracer1(2:NTRAC) @@ -1324,20 +1327,23 @@ subroutine GFS_radiation_driver & !> -# Prepare atmospheric profiles for radiation input. ! + lsk = 0 + if (ivflip == 0 .and. lm < levs) lsk = levs - lm + ! convert pressure unit from pa to mb do k = 1, LM k1 = k + kd + k2 = k + lsk do i = 1, IM - plvl(i,k1) = 0.01 * Statein%prsi(i,k) ! pa to mb (hpa) - plyr(i,k1) = 0.01 * Statein%prsl(i,k) ! pa to mb (hpa) - tlyr(i,k1) = Statein%tgrs(i,k) - prslk1(i,k1) = Statein%prslk(i,k) + plvl(i,k1+kb) = Statein%prsi(i,k2+kb) * 0.01 ! pa to mb (hpa) + plyr(i,k1) = Statein%prsl(i,k2) * 0.01 ! pa to mb (hpa) + tlyr(i,k1) = Statein%tgrs(i,k2) + prslk1(i,k1) = Statein%prslk(i,k2) !> - Compute relative humidity. -! es = min( Statein%prsl(i,k), 0.001 * fpvs( Statein%tgrs(i,k) ) ) ! fpvs in pa - es = min( Statein%prsl(i,k), fpvs( Statein%tgrs(i,k) ) ) ! fpvs and prsl in pa - qs = max( QMIN, eps * es / (Statein%prsl(i,k) + epsm1*es) ) - rhly(i,k1) = max( 0.0, min( 1.0, max(QMIN, Statein%qgrs(i,k,1))/qs ) ) + es = min( Statein%prsl(i,k2), fpvs( Statein%tgrs(i,k2) ) ) ! fpvs and prsl in pa + qs = max( QMIN, eps * es / (Statein%prsl(i,k2) + epsm1*es) ) + rhly(i,k1) = max( 0.0, min( 1.0, max(QMIN, Statein%qgrs(i,k2,1))/qs ) ) qstl(i,k1) = qs enddo enddo @@ -1346,18 +1352,29 @@ subroutine GFS_radiation_driver & do j = 2, NTRAC do k = 1, LM k1 = k + kd - tracer1(:,k1,j) = max(0.0, Statein%qgrs(:,k,j)) + k2 = k + lsk + tracer1(:,k1,j) = max(0.0, Statein%qgrs(:,k2,j)) enddo enddo - - do i = 1, IM - plvl(i,LP1+kd) = 0.01 * Statein%prsi(i,LP1) ! pa to mb (hpa) - enddo - if (Model%levr < Model%levs) then +! + if (ivflip == 0) then ! input data from toa to sfc + do i = 1, IM + plvl(i,1+kd) = 0.01 * Statein%prsi(i,1) ! pa to mb (hpa) + enddo + if (lsk /= 0) then + do i = 1, IM + plvl(i,1+kd) = 0.5 * (plvl(i,2+kd) + plvl(i,1+kd)) + enddo + endif + else ! input data from sfc to top do i = 1, IM - plvl(i,LP1+kd) = 0.01 * Statein%prsi(i,Model%levs+1) ! pa to mb (hpa) - plvl(i,LM+kd) = 0.5 * (plvl(i,LP1+kd) + plvl(i,LM+kd)) + plvl(i,LP1+kd) = 0.01 * Statein%prsi(i,LP1+lsk) ! pa to mb (hpa) enddo + if (lsk /= 0) then + do i = 1, IM + plvl(i,LM+kd) = 0.5 * (plvl(i,LP1+kd) + plvl(i,LM+kd)) + enddo + endif endif if ( lextop ) then ! values for extra top layer @@ -1389,12 +1406,12 @@ subroutine GFS_radiation_driver & olyr) ! --- outputs endif ! end_if_ntoz -!> - Call coszmn(), to compute cosine of zenith angle. +!> - Call coszmn(), to compute cosine of zenith angle (only when SW is called) - if( Model%lsswr ) then - call coszmn (Grid%xlon,Grid%sinlat, & ! --- inputs + if (Model%lsswr) then + call coszmn (Grid%xlon,Grid%sinlat, & ! --- inputs Grid%coslat,Model%solhr, IM, me, & - Radtend%coszen, Radtend%coszdg) ! --- outputs + Radtend%coszen, Radtend%coszdg) ! --- outputs endif !> - Call getgases(), to set up non-prognostic gas volume mixing @@ -1614,10 +1631,10 @@ subroutine GFS_radiation_driver & ccnd(:,:,1) = ccnd(:,:,1) + tracer1(:,1:LMK,ntsw) ccnd(:,:,1) = ccnd(:,:,1) + tracer1(:,1:LMK,ntgl) - else - do j=1,Model%ncld - ccnd(:,:,1) = ccnd(:,:,1) + tracer1(:,1:LMK,ntcw+j-1) ! cloud condensate amount - enddo +! else +! do j=1,Model%ncld +! ccnd(:,:,1) = ccnd(:,:,1) + tracer1(:,1:LMK,ntcw+j-1) ! cloud condensate amount +! enddo endif do k=1,LMK do i=1,IM @@ -1626,29 +1643,23 @@ subroutine GFS_radiation_driver & enddo endif ! - if (Model%shoc_cld) then ! all but MG microphys - cldcov(1:IM,1+kd:LM+kd) = Tbd%phy_f3d(1:IM,1:LM,Model%ntot3d-2) - if (ncld == 2 .and. Model%effr_in) then + if (Model%uni_cld) then + if (Model%effr_in) then do k=1,lm k1 = k + kd do i=1,im - effrl(i,k1) = Tbd%phy_f3d(i,k,2) - effri(i,k1) = Tbd%phy_f3d(i,k,3) - effrr(i,k1) = Tbd%phy_f3d(i,k,4) - effrs(i,k1) = Tbd%phy_f3d(i,k,5) + cldcov(i,k1) = Tbd%phy_f3d(i,k,Model%indcld) + effrl(i,k1) = Tbd%phy_f3d(i,k,2) + effri(i,k1) = Tbd%phy_f3d(i,k,3) + effrr(i,k1) = Tbd%phy_f3d(i,k,4) + effrs(i,k1) = Tbd%phy_f3d(i,k,5) enddo enddo - endif - elseif (Model%imp_physics == 10) then ! MG microphys - cldcov(1:IM,1+kd:LM+kd) = Tbd%phy_f3d(1:IM,1:LM,1) - if (Model%effr_in) then + else do k=1,lm k1 = k + kd do i=1,im - effrl(i,k1) = Tbd%phy_f3d(i,k,2) - effri(i,k1) = Tbd%phy_f3d(i,k,3) - effrr(i,k1) = Tbd%phy_f3d(i,k,4) - effrs(i,k1) = Tbd%phy_f3d(i,k,5) + cldcov(i,k1) = Tbd%phy_f3d(i,k,Model%indcld) enddo enddo endif @@ -1856,12 +1867,13 @@ subroutine GFS_radiation_driver & do k = 1, LM k1 = k + kd - Radtend%htrsw(:,k) = htswc(:,k1) + Radtend%htrsw(1:im,k) = htswc(1:im,k1) enddo -! --- repopulate the points above levr - if (Model%levr < Model%levs) then - do k = LM,Model%levs - Radtend%htrsw (:,k) = Radtend%htrsw (:,LM) +! We are assuming that radiative tendencies are from bottom to top +! --- repopulate the points above levr i.e. LM + if (lm < levs) then + do k = lm,levs + Radtend%htrsw (1:im,k) = Radtend%htrsw (1:im,LM) enddo endif @@ -1870,9 +1882,9 @@ subroutine GFS_radiation_driver & k1 = k + kd Radtend%swhc(1:im,k) = htsw0(1:im,k1) enddo -! --- repopulate the points above levr - if (Model%levr < Model%levs) then - do k = LM,Model%levs +! --- repopulate the points above levr i.e. LM + if (lm < levs) then + do k = lm,levs Radtend%swhc(1:im,k) = Radtend%swhc(1:im,LM) enddo endif @@ -1967,8 +1979,8 @@ subroutine GFS_radiation_driver & Radtend%htrlw(1:im,k) = htlwc(1:im,k1) enddo ! --- repopulate the points above levr - if (Model%levr < Model%levs) then - do k = LM,Model%levs + if (lm < levs) then + do k = lm,levs Radtend%htrlw (1:im,k) = Radtend%htrlw (1:im,LM) enddo endif @@ -1979,8 +1991,8 @@ subroutine GFS_radiation_driver & Radtend%lwhc(1:im,k) = htlw0(1:im,k1) enddo ! --- repopulate the points above levr - if (Model%levr < Model%levs) then - do k = LM,Model%levs + if (lm < levs) then + do k = lm,levs Radtend%lwhc(1:im,k) = Radtend%lwhc(1:im,LM) enddo endif @@ -2032,7 +2044,7 @@ subroutine GFS_radiation_driver & if (Radtend%coszen(i) > 0.) then ! --- sw total-sky fluxes ! ------------------- - tem0d = Model%fhswr * Radtend%coszdg(i) / Radtend%coszen(i) + tem0d = Model%fhswr * Radtend%coszdg(i) / Radtend%coszen(i) Diag%fluxr(i,2 ) = Diag%fluxr(i,2) + Diag%topfsw(i)%upfxc * tem0d ! total sky top sw up Diag%fluxr(i,3 ) = Diag%fluxr(i,3) + Radtend%sfcfsw(i)%upfxc * tem0d ! total sky sfc sw up Diag%fluxr(i,4 ) = Diag%fluxr(i,4) + Radtend%sfcfsw(i)%dnfxc * tem0d ! total sky sfc sw dn @@ -2084,9 +2096,9 @@ subroutine GFS_radiation_driver & tem1 = 0. tem2 = 0. do k=ibtc,itop - tem1 = tem1 + cldtausw(i,k) ! approx .55 mu channel - tem2 = tem2 + cldtaulw(i,k) ! approx 10. mu channel - end do + tem1 = tem1 + cldtausw(i,k) ! approx .55 mu channel + tem2 = tem2 + cldtaulw(i,k) ! approx 10. mu channel + enddo Diag%fluxr(i,43-j) = Diag%fluxr(i,43-j) + tem0d * tem1 Diag%fluxr(i,46-j) = Diag%fluxr(i,46-j) + tem0d * (1.0-exp(-tem2)) enddo diff --git a/gfsphysics/GFS_layer/GFS_typedefs.F90 b/gfsphysics/GFS_layer/GFS_typedefs.F90 index 434fe6fc0..c96e55ae3 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.F90 +++ b/gfsphysics/GFS_layer/GFS_typedefs.F90 @@ -1,10 +1,11 @@ module GFS_typedefs - use machine, only: kind_phys, kind_evod + use machine, only: kind_phys use module_radsw_parameters, only: topfsw_type, sfcfsw_type use module_radlw_parameters, only: topflw_type, sfcflw_type - use ozne_def, only: levozp, oz_coeff - use h2o_def, only: levh2o, h2o_coeff + use ozne_def, only: levozp, oz_coeff + use h2o_def, only: levh2o, h2o_coeff + use aerclm_def, only: ntrcaer, ntrcaerm implicit none @@ -449,14 +450,17 @@ module GFS_typedefs !--- M-G microphysical parameters integer :: fprcp !< no prognostic rain and snow (MG) + integer :: pdfflag !< pdf flag for MG macrophysics real(kind=kind_phys) :: mg_dcs !< Morrison-Gettleman microphysics parameters real(kind=kind_phys) :: mg_qcvar - real(kind=kind_phys) :: mg_ts_auto_ice !< ice auto conversion time scale + real(kind=kind_phys) :: mg_ts_auto_ice(2) !< ice auto conversion time scale real(kind=kind_phys) :: mg_ncnst !< constant droplet num concentration (m-3) real(kind=kind_phys) :: mg_ninst !< constant ice num concentration (m-3) real(kind=kind_phys) :: mg_ngnst !< constant graupel/hail num concentration (m-3) real(kind=kind_phys) :: mg_berg_eff_factor !< berg efficiency factor + real(kind=kind_phys) :: mg_alf !< tuning factor for alphs in MG macrophysics + real(kind=kind_phys) :: mg_qcmin(2) !< min liquid and ice mixing ratio in Mg macro clouds character(len=16) :: mg_precip_frac_method ! type of precipitation fraction method ! @@ -473,6 +477,8 @@ module GFS_typedefs logical :: do_sb_physics logical :: mg_do_graupel logical :: mg_do_hail + logical :: mg_do_ice_gmao + logical :: mg_do_liq_liu real(kind=kind_phys) :: shoc_parm(5) !< critical pressure in Pa for tke dissipation in shoc integer :: ncnd !< number of cloud condensate types @@ -552,6 +558,10 @@ module GFS_typedefs !< PBL top and at the top of the atmosphere real(kind=kind_phys) :: dlqf(2) !< factor for cloud condensate detrainment !< from cloud edges for RAS + real(kind=kind_phys) :: psauras(2) !< [in] auto conversion coeff from ice to snow in ras + real(kind=kind_phys) :: prauras(2) !< [in] auto conversion coeff from cloud to rain in ras + real(kind=kind_phys) :: wminras(2) !< [in] water and ice minimum threshold for ras + integer :: seed0 !< random seed for radiation real(kind=kind_phys) :: rbcr !< Critical Richardson Number in the PBL scheme @@ -595,16 +605,18 @@ module GFS_typedefs !--- near surface temperature model logical :: nst_anl !< flag for NSSTM analysis in gcycle/sfcsub integer :: lsea - real(kind=kind_phys) :: xkzm_m !< [in] bkgd_vdif_m background vertical diffusion for momentum - real(kind=kind_phys) :: xkzm_h !< [in] bkgd_vdif_h background vertical diffusion for heat q - real(kind=kind_phys) :: xkzm_s !< [in] bkgd_vdif_s sigma threshold for background mom. diffusion integer :: nstf_name(5) !< flag 0 for no nst 1 for uncoupled nst and 2 for coupled NST !< nstf_name contains the NSST related parameters - !< nstf_name(1) : 0 = NSSTM off, 1 = NSSTM on but uncoupled, 2 = + !< nstf_name(1) : 0 = NSSTM off, 1 = NSSTM on but uncoupled + !< 2 = NSSTM on and coupled !< nstf_name(2) : 1 = NSSTM spin up on, 0 = NSSTM spin up off !< nstf_name(3) : 1 = NSST analysis on, 0 = NSSTM analysis off !< nstf_name(4) : zsea1 in mm !< nstf_name(5) : zsea2 in mm +!--- background vertical diffusion + real(kind=kind_phys) :: xkzm_m !< [in] bkgd_vdif_m background vertical diffusion for momentum + real(kind=kind_phys) :: xkzm_h !< [in] bkgd_vdif_h background vertical diffusion for heat q + real(kind=kind_phys) :: xkzm_s !< [in] bkgd_vdif_s sigma threshold for background mom. diffusion real(kind=kind_phys) :: xkzminv !< diffusivity in inversion layers real(kind=kind_phys) :: moninq_fac !< turbulence diffusion coefficient factor @@ -646,6 +658,7 @@ module GFS_typedefs !--- derived totals for phy_f*d integer :: ntot2d !< total number of variables for phyf2d integer :: ntot3d !< total number of variables for phyf3d + integer :: indcld !< location of cloud fraction in phyf3d (used ony for SHOC or MG) integer :: num_p2d !< number of 2D arrays needed for microphysics integer :: num_p3d !< number of 3D arrays needed for microphysics integer :: nshoc_2d !< number of 2d fields for SHOC @@ -677,6 +690,8 @@ module GFS_typedefs integer :: kdt !< current forecast iteration integer :: jdat(1:8) !< current forecast date and time !< (yr, mon, day, t-zone, hr, min, sec, mil-sec) + logical :: iccn !< using IN CCN forcing for MG2/3 + !--- IAU real(kind=kind_phys) :: iau_delthrs ! iau time interval (to scale increments) in hours character(len=240) :: iau_inc_files(7)! list of increment files @@ -693,16 +708,18 @@ module GFS_typedefs ! grid data needed for interpolations and length-scale calculations !-------------------------------------------------------------------- type GFS_grid_type - - real (kind=kind_phys), pointer :: xlon (:) => null() !< grid longitude in radians, ok for both 0->2pi - !! or -pi -> +pi ranges - real (kind=kind_phys), pointer :: xlat (:) => null() !< grid latitude in radians, default to pi/2 -> - !! -pi/2 range, otherwise adj in subr called - real (kind=kind_phys), pointer :: xlat_d (:) => null() !< grid latitude in degrees, default to 90 -> - !! -90 range, otherwise adj in subr called - real (kind=kind_phys), pointer :: sinlat (:) => null() !< sine of the grids corresponding latitudes - real (kind=kind_phys), pointer :: coslat (:) => null() !< cosine of the grids corresponding latitudes - real (kind=kind_phys), pointer :: area (:) => null() !< area of the grid cell + + real (kind=kind_phys), pointer :: xlon (:) => null() !< grid longitude in radians, ok for both 0->2pi + !! or -pi -> +pi ranges + real (kind=kind_phys), pointer :: xlat (:) => null() !< grid latitude in radians, default to pi/2 -> + !! -pi/2 range, otherwise adj in subr called + real (kind=kind_phys), pointer :: xlat_d (:) => null() !< grid latitude in degrees, default to 90 -> + !! -90 range, otherwise adj in subr called + real (kind=kind_phys), pointer :: xlon_d (:) => null() !< grid longitude in degrees, default to 0 -> + !! 360 range, otherwise adj in subr called + real (kind=kind_phys), pointer :: sinlat (:) => null() !< sine of the grids corresponding latitudes + real (kind=kind_phys), pointer :: coslat (:) => null() !< cosine of the grids corresponding latitudes + real (kind=kind_phys), pointer :: area (:) => null() !< area of the grid cell real (kind=kind_phys), pointer :: dx (:) => null() !< relative dx for the grid cell !--- grid-related interpolation data for prognostic ozone @@ -714,6 +731,22 @@ module GFS_typedefs real (kind=kind_phys), pointer :: ddy_h (:) => null() !< interpolation weight for h2o integer, pointer :: jindx1_h (:) => null() !< interpolation low index for h2o integer, pointer :: jindx2_h (:) => null() !< interpolation high index for h2o + +!--- grid-related interpolation data for prognostic iccn + real (kind=kind_phys), pointer :: ddy_ci (:) => null() !< interpolation weight for iccn + integer, pointer :: jindx1_ci (:) => null() !< interpolation low index for iccn + integer, pointer :: jindx2_ci (:) => null() !< interpolation high index for iccn + real (kind=kind_phys), pointer :: ddx_ci (:) => null() !< interpolation weight for iccn + integer, pointer :: iindx1_ci (:) => null() !< interpolation low index for iccn + integer, pointer :: iindx2_ci (:) => null() !< interpolation high index for iccn + +!--- grid-related interpolation data for prescribed aerosols + real (kind=kind_phys), pointer :: ddy_aer (:) => null() !< interpolation weight for iaerclm + integer, pointer :: jindx1_aer (:) => null() !< interpolation low index for iaerclm + integer, pointer :: jindx2_aer (:) => null() !< interpolation high index for iaerclm + real (kind=kind_phys), pointer :: ddx_aer (:) => null() !< interpolation weight for iaerclm + integer, pointer :: iindx1_aer (:) => null() !< interpolation low index for iaerclm + integer, pointer :: iindx2_aer (:) => null() !< interpolation high index for iaerclm contains procedure :: create => grid_create !< allocate array data end type GFS_grid_type @@ -727,13 +760,16 @@ module GFS_typedefs !--- radiation random seeds integer, pointer :: icsdsw (:) => null() !< (rad. only) auxiliary cloud control arrays passed to main - integer, pointer :: icsdlw (:) => null() !< (rad. only) radiations. if isubcsw/isubclw (input to init) - !< (rad. only) are set to 2, the arrays contains provided + integer, pointer :: icsdlw (:) => null() !< (rad. only) radiations. if isubcsw/isubclw (input to init) + !< (rad. only) are set to 2, the arrays contains provided !< (rad. only) random seeds for sub-column clouds generators !--- In real (kind=kind_phys), pointer :: ozpl (:,:,:) => null() !< ozone forcing data real (kind=kind_phys), pointer :: h2opl (:,:,:) => null() !< water forcing data + real (kind=kind_phys), pointer :: in_nm (:,:) => null() !< IN number concentration + real (kind=kind_phys), pointer :: ccn_nm (:,:) => null() !< CCN number concentration + real (kind=kind_phys), pointer :: aer_nm (:,:,:) => null() !< GOCART aerosol climo !--- active when ((.not. newsas .or. cal_pre) .and. random_clds) real (kind=kind_phys), pointer :: rann (:,:) => null() !< random number array (0-1) @@ -784,27 +820,27 @@ module GFS_typedefs type GFS_radtend_type type (sfcfsw_type), pointer :: sfcfsw(:) => null() !< sw radiation fluxes at sfc - !< [dim(im): created in grrad.f], components: - !! (check module_radsw_parameters for definition) - !!\n %upfxc - total sky upward sw flux at sfc (w/m**2) - !!\n %upfx0 - clear sky upward sw flux at sfc (w/m**2) - !!\n %dnfxc - total sky downward sw flux at sfc (w/m**2) - !!\n %dnfx0 - clear sky downward sw flux at sfc (w/m**2) + !< [dim(im): created in grrad.f], components: + !! (check module_radsw_parameters for definition) + !!\n %upfxc - total sky upward sw flux at sfc (w/m**2) + !!\n %upfx0 - clear sky upward sw flux at sfc (w/m**2) + !!\n %dnfxc - total sky downward sw flux at sfc (w/m**2) + !!\n %dnfx0 - clear sky downward sw flux at sfc (w/m**2) type (sfcflw_type), pointer :: sfcflw(:) => null() !< lw radiation fluxes at sfc - !< [dim(im): created in grrad.f], components: - !! (check module_radlw_paramters for definition) - !!\n %upfxc - total sky upward lw flux at sfc (w/m**2) - !!\n %upfx0 - clear sky upward lw flux at sfc (w/m**2) - !!\n %dnfxc - total sky downward lw flux at sfc (w/m**2) - !!\n %dnfx0 - clear sky downward lw flux at sfc (w/m**2) + !< [dim(im): created in grrad.f], components: + !! (check module_radlw_paramters for definition) + !!\n %upfxc - total sky upward lw flux at sfc (w/m**2) + !!\n %upfx0 - clear sky upward lw flux at sfc (w/m**2) + !!\n %dnfxc - total sky downward lw flux at sfc (w/m**2) + !!\n %dnfx0 - clear sky downward lw flux at sfc (w/m**2) !--- Out (radiation only) - real (kind=kind_phys), pointer :: htrsw (:,:) => null() !< swh total sky sw heating rate in k/sec + real (kind=kind_phys), pointer :: htrsw (:,:) => null() !< swh total sky sw heating rate in k/sec real (kind=kind_phys), pointer :: htrlw (:,:) => null() !< hlw total sky lw heating rate in k/sec real (kind=kind_phys), pointer :: sfalb (:) => null() !< mean surface diffused sw albedo - real (kind=kind_phys), pointer :: coszen(:) => null() !< mean cos of zenith angle over rad call period + real (kind=kind_phys), pointer :: coszen(:) => null() !< mean cos of zenith angle over rad call period real (kind=kind_phys), pointer :: tsflw (:) => null() !< surface air temp during lw calculation in k real (kind=kind_phys), pointer :: semis (:) => null() !< surface lw emissivity in fraction @@ -812,9 +848,9 @@ module GFS_typedefs real (kind=kind_phys), pointer :: coszdg(:) => null() !< daytime mean cosz over rad call period !--- In/Out (???) (physics only) - real (kind=kind_phys), pointer :: swhc (:,:) => null() !< clear sky sw heating rates ( k/s ) - real (kind=kind_phys), pointer :: lwhc (:,:) => null() !< clear sky lw heating rates ( k/s ) - real (kind=kind_phys), pointer :: lwhd (:,:,:) => null() !< idea sky lw heating rates ( k/s ) + real (kind=kind_phys), pointer :: swhc (:,:) => null() !< clear sky sw heating rates ( k/s ) + real (kind=kind_phys), pointer :: lwhc (:,:) => null() !< clear sky lw heating rates ( k/s ) + real (kind=kind_phys), pointer :: lwhd (:,:,:) => null() !< idea sky lw heating rates ( k/s ) contains procedure :: create => radtend_create !< allocate array data @@ -829,10 +865,10 @@ module GFS_typedefs !! Input/Output only in radiation real (kind=kind_phys), pointer :: fluxr(:,:) => null() !< to save time accumulated 2-d fields defined as:! !< hardcoded field indices, opt. includes aerosols! - type (topfsw_type), pointer :: topfsw(:) => null() !< sw radiation fluxes at toa, components: - ! %upfxc - total sky upward sw flux at toa (w/m**2) - ! %dnfxc - total sky downward sw flux at toa (w/m**2) - ! %upfx0 - clear sky upward sw flux at toa (w/m**2) + type (topfsw_type), pointer :: topfsw(:) => null() !< sw radiation fluxes at toa, components: + ! %upfxc - total sky upward sw flux at toa (w/m**2) + ! %dnfxc - total sky downward sw flux at toa (w/m**2) + ! %upfx0 - clear sky upward sw flux at toa (w/m**2) type (topflw_type), pointer :: topflw(:) => null() !< lw radiation fluxes at top, component: ! %upfxc - total sky upward lw flux at toa (w/m**2) ! %upfx0 - clear sky upward lw flux at toa (w/m**2) @@ -1493,7 +1529,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & logical :: exists real(kind=kind_phys) :: tem real(kind=kind_phys) :: rinc(5) - real(kind=kind_evod) :: wrk(1) + real(kind=kind_phys) :: wrk(1) real(kind=kind_phys), parameter :: con_hr = 3600. !--- BEGIN NAMELIST VARIABLES @@ -1520,6 +1556,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & integer :: levr = -99 !< number of vertical levels for radiation calculations integer :: nfxr = 39+6 !< second dimension of input/output array fluxr logical :: aero_in = .false. !< flag for initializing aero data + logical :: iccn = .true. !< logical to use IN CCN forcing for MG2/3 integer :: iflip = 1 !< iflip - is not the same as flipv integer :: isol = 0 !< use prescribed solar constant integer :: ico2 = 0 !< prescribed global mean value (old opernl) @@ -1542,38 +1579,41 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !< the fcst time; no extrapolation. !< ictm=-2 => same as ictm=0, but add seasonal cycle !< from climatology; no extrapolation. - integer :: isubc_sw = 0 !< sw clouds without sub-grid approximation - integer :: isubc_lw = 0 !< lw clouds without sub-grid approximation + integer :: isubc_sw = 0 !< sw clouds without sub-grid approximation + integer :: isubc_lw = 0 !< lw clouds without sub-grid approximation !< =1 => sub-grid cloud with prescribed seeds !< =2 => sub-grid cloud with randomly generated !< seeds - logical :: crick_proof = .false. !< CRICK-Proof cloud water - logical :: ccnorm = .false. !< Cloud condensate normalized by cloud cover - logical :: norad_precip = .false. !< radiation precip flag for Ferrier/Moorthi - logical :: lwhtr = .true. !< flag to output lw heating rate (Radtend%lwhc) - logical :: swhtr = .true. !< flag to output sw heating rate (Radtend%swhc) + logical :: crick_proof = .false. !< CRICK-Proof cloud water + logical :: ccnorm = .false. !< Cloud condensate normalized by cloud cover + logical :: norad_precip = .false. !< radiation precip flag for Ferrier/Moorthi + logical :: lwhtr = .true. !< flag to output lw heating rate (Radtend%lwhc) + logical :: swhtr = .true. !< flag to output sw heating rate (Radtend%swhc) !--- Z-C microphysical parameters - integer :: ncld = 1 !< cnoice of cloud scheme - integer :: imp_physics = 99 !< cnoice of cloud scheme - real(kind=kind_phys) :: psautco(2) = (/6.0d-4,3.0d-4/) !< [in] auto conversion coeff from ice to snow - real(kind=kind_phys) :: prautco(2) = (/1.0d-4,1.0d-4/) !< [in] auto conversion coeff from cloud to rain - real(kind=kind_phys) :: evpco = 2.0d-5 !< [in] coeff for evaporation of largescale rain - real(kind=kind_phys) :: wminco(2) = (/1.0d-5,1.0d-5/) !< [in] water and ice minimum threshold for Zhao + integer :: ncld = 1 !< cnoice of cloud scheme + integer :: imp_physics = 99 !< cnoice of cloud scheme + real(kind=kind_phys) :: psautco(2) = (/6.0d-4,3.0d-4/) !< [in] auto conversion coeff from ice to snow + real(kind=kind_phys) :: prautco(2) = (/1.0d-4,1.0d-4/) !< [in] auto conversion coeff from cloud to rain + real(kind=kind_phys) :: evpco = 2.0d-5 !< [in] coeff for evaporation of largescale rain + real(kind=kind_phys) :: wminco(2) = (/1.0d-5,1.0d-5/) !< [in] water and ice minimum threshold for Zhao !--- M-G microphysical parameters - integer :: fprcp = 0 !< no prognostic rain and snow (MG) - real(kind=kind_phys) :: mg_dcs = 350.0 !< Morrison-Gettleman microphysics parameters - real(kind=kind_phys) :: mg_qcvar = 2.0 - real(kind=kind_phys) :: mg_ts_auto_ice = 3600.0 !< ice auto conversion time scale - real(kind=kind_phys) :: mg_ncnst = 100.e6 !< constant droplet num concentration (m-3) - real(kind=kind_phys) :: mg_ninst = 0.15e6 !< constant ice num concentration (m-3) - real(kind=kind_phys) :: mg_ngnst = 0.10e6 !< constant graupel/hail num concentration (m-3) = 0.1e6_r8 - real(kind=kind_phys) :: mg_berg_eff_factor = 2.0 !< berg efficiency factor - character(len=16) :: mg_precip_frac_method = 'max_overlap' !< type of precipitation fraction method + integer :: fprcp = 0 !< no prognostic rain and snow (MG) + integer :: pdfflag = 4 !< pdf flag for MG macro physics + real(kind=kind_phys) :: mg_dcs = 200.0 !< Morrison-Gettleman microphysics parameters + real(kind=kind_phys) :: mg_qcvar = 1.0 + real(kind=kind_phys) :: mg_ts_auto_ice(2) = (/180.0,180.0/) !< ice auto conversion time scale + real(kind=kind_phys) :: mg_ncnst = 100.e6 !< constant droplet num concentration (m-3) + real(kind=kind_phys) :: mg_ninst = 0.15e6 !< constant ice num concentration (m-3) + real(kind=kind_phys) :: mg_ngnst = 0.10e6 !< constant graupel/hail num concentration (m-3) = 0.1e6_r8 + real(kind=kind_phys) :: mg_alf = 1.0 !< tuning factor for alphs in MG macrophysics + real(kind=kind_phys) :: mg_qcmin(2) = (/1.0d-9,1.0d-9/) !< min liquid and ice mixing ratio in Mg macro clouds + real(kind=kind_phys) :: mg_berg_eff_factor = 2.0 !< berg efficiency factor + character(len=16) :: mg_precip_frac_method = 'max_overlap' !< type of precipitation fraction method ! - logical :: effr_in = .false. !< flag to use effective radii of cloud species in radiation - logical :: microp_uniform = .false. + logical :: effr_in = .false. !< flag to use effective radii of cloud species in radiation + logical :: microp_uniform = .true. logical :: do_cldliq = .true. logical :: do_cldice = .true. logical :: hetfrz_classnuc = .false. @@ -1584,6 +1624,9 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & logical :: do_sb_physics = .true. logical :: mg_do_graupel = .true. !< set .true. to turn on prognostic grapuel (with fprcp=2) logical :: mg_do_hail = .false. !< set .true. to turn on prognostic hail (with fprcp=2) + logical :: mg_do_ice_gmao = .false. !< set .true. to turn on gmao ice formulation + logical :: mg_do_liq_liu = .true. !< set .true. to turn on liq liquid treatment + !--- Thompson microphysical parameters logical :: ltaerosol = .false. !< flag for aerosol version @@ -1646,7 +1689,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !< used in the GWD parameterization integer :: jcap = 1 !< number of spectral wave trancation used only by sascnv shalcnv ! real(kind=kind_phys) :: cs_parm(10) = (/5.0,2.5,1.0e3,3.0e3,20.0,-999.,-999.,0.,0.,0./) - real(kind=kind_phys) :: cs_parm(10) = (/10.0,4.0,1.0e3,2.0e3,20.0,1.0,-999.,0.,0.,0./) + real(kind=kind_phys) :: cs_parm(10) = (/8.0,4.0,1.0e3,3.5e3,20.0,1.0,-999.,1.,0.6,0./) real(kind=kind_phys) :: flgmin(2) = (/0.180,0.220/) !< [in] ice fraction bounds real(kind=kind_phys) :: cgwf(2) = (/0.5d0,0.05d0/) !< multiplication factor for convective GWD real(kind=kind_phys) :: ccwf(2) = (/1.0d0,1.0d0/) !< multiplication factor for critical cloud @@ -1660,6 +1703,10 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !< PBL top and at the top of the atmosphere real(kind=kind_phys) :: dlqf(2) = (/0.0d0,0.0d0/) !< factor for cloud condensate detrainment !< from cloud edges for RAS + real(kind=kind_phys) :: psauras(2) = (/1.0d-3,1.0d-3/) !< [in] auto conversion coeff from ice to snow in ras + real(kind=kind_phys) :: prauras(2) = (/2.0d-3,2.0d-3/) !< [in] auto conversion coeff from cloud to rain in ras + real(kind=kind_phys) :: wminras(2) = (/1.0d-5,1.0d-5/) !< [in] water and ice minimum threshold for ras + real(kind=kind_phys) :: rbcr = 0.25 !< Critical Richardson Number in PBL scheme real(kind=kind_phys) :: shoc_parm(5) = (/7000.0,1.0,4.2857143,0.7,-999.0/) !< some tunable parameters for shoc @@ -1699,22 +1746,23 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !< Until a realistic Nccn is provided, Nccns are assumed !< as Nccn=100 for sea and Nccn=1000 for land -!--- near surface temperature model +!--- near surface sea temperature model logical :: nst_anl = .false. !< flag for NSSTM analysis in gcycle/sfcsub integer :: lsea = 0 - real(kind=kind_phys) :: xkzm_m = 1.0d0 !< [in] bkgd_vdif_m background vertical diffusion for momentum - real(kind=kind_phys) :: xkzm_h = 1.0d0 !< [in] bkgd_vdif_h background vertical diffusion for heat q - real(kind=kind_phys) :: xkzm_s = 1.0d0 !< [in] bkgd_vdif_s sigma threshold for background mom. diffusion integer :: nstf_name(5) = (/0,0,1,0,5/) !< flag 0 for no nst 1 for uncoupled nst and 2 for coupled NST - !< nstf_name contains the NSSTM related parameters !< nstf_name(1) : 0 = NSSTM off, 1 = NSSTM on but uncoupled !< 2 = NSSTM on and coupled !< nstf_name(2) : 1 = NSSTM spin up on, 0 = NSSTM spin up off !< nstf_name(3) : 1 = NSSTM analysis on, 0 = NSSTM analysis off !< nstf_name(4) : zsea1 in mm !< nstf_name(5) : zsea2 in mm +!--- background vertical diffusion + real(kind=kind_phys) :: xkzm_m = 1.0d0 !< [in] bkgd_vdif_m background vertical diffusion for momentum + real(kind=kind_phys) :: xkzm_h = 1.0d0 !< [in] bkgd_vdif_h background vertical diffusion for heat q + real(kind=kind_phys) :: xkzm_s = 1.0d0 !< [in] bkgd_vdif_s sigma threshold for background mom. diffusion real(kind=kind_phys) :: xkzminv = 0.3 !< diffusivity in inversion layers real(kind=kind_phys) :: moninq_fac = 1.0 !< turbulence diffusion coefficient factor + !--- IAU options real(kind=kind_phys) :: iau_delthrs = 6 ! iau time interval (to scale increments) @@ -1724,6 +1772,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !--- debug flag logical :: debug = .false. logical :: pre_rad = .false. !< flag for testing purpose + ! max and min lon and lat for critical relative humidity integer :: max_lon=5000, max_lat=2000, min_lon=192, min_lat=94 real(kind=kind_phys) :: rhcmax = 0.9999999 !< max critical rel. hum. @@ -1736,11 +1785,11 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & integer :: skeb_npass = 11 logical :: do_sfcperts = .false. ! mg, sfc-perts integer :: nsfcpert = 6 ! mg, sfc-perts - real(kind=kind_phys) :: pertz0 = -999. - real(kind=kind_phys) :: pertzt = -999. - real(kind=kind_phys) :: pertshc = -999. - real(kind=kind_phys) :: pertlai = -999. - real(kind=kind_phys) :: pertalb = -999. + real(kind=kind_phys) :: pertz0 = -999. + real(kind=kind_phys) :: pertzt = -999. + real(kind=kind_phys) :: pertshc = -999. + real(kind=kind_phys) :: pertlai = -999. + real(kind=kind_phys) :: pertalb = -999. real(kind=kind_phys) :: pertvegf = -999. !--- END NAMELIST VARIABLES @@ -1754,12 +1803,15 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & fhswr, fhlwr, levr, nfxr, aero_in, iflip, isol, ico2, ialb, & isot, iems, iaer, icliq_sw, iovr_sw, iovr_lw, ictm, isubc_sw,& isubc_lw, crick_proof, ccnorm, lwhtr, swhtr, & + ! IN CCN forcing + iccn, & !--- microphysical parameterizations ncld, imp_physics, psautco, prautco, evpco, wminco, & - fprcp, mg_dcs, mg_qcvar, mg_ts_auto_ice, effr_in, & + fprcp, pdfflag, mg_dcs, mg_qcvar, mg_ts_auto_ice, effr_in, & microp_uniform, do_cldice, hetfrz_classnuc, & mg_do_graupel, mg_do_hail, mg_nccons, mg_nicons, mg_ngcons, & mg_ncnst, mg_ninst, mg_ngnst, sed_supersat, do_sb_physics, & + mg_alf, mg_qcmin, mg_do_ice_gmao, mg_do_liq_liu, & ltaerosol, lradar, lgfdlmprad, & !--- land/surface model control lsm, lsoil, nmtvr, ivegsrc, mom4ice, use_ufo, & @@ -1770,7 +1822,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & dspheat, cnvcld, & random_clds, shal_cnv, imfshalcnv, imfdeepcnv, do_deep, jcap,& cs_parm, flgmin, cgwf, ccwf, cdmbgwd, sup, ctei_rm, crtrh, & - dlqf, rbcr, shoc_parm, & + dlqf, rbcr, shoc_parm, psauras, prauras, wminras, & !--- Rayleigh friction prslrd0, ral_ts, & !--- mass flux deep convection @@ -1779,9 +1831,10 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & asolfac_deep, & !--- mass flux shallow convection clam_shal, c0s_shal, c1_shal, pgcon_shal, asolfac_shal, & - !--- near surface temperature model - nst_anl, lsea, xkzm_m, xkzm_h, xkzm_s, nstf_name, & - xkzminv, moninq_fac, & + !--- near surface sea temperature model + nst_anl, lsea, nstf_name, & + ! background vertical diffusion + xkzm_m, xkzm_h, xkzm_s, xkzminv, moninq_fac, & !--- IAU iau_delthrs,iaufhrs,iau_inc_files, & !--- debug options @@ -1884,6 +1937,13 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & endif Model%nfxr = nfxr Model%aero_in = aero_in + if (Model%aero_in) then + ntrcaer = ntrcaerm + else + ntrcaer = 1 + endif + Model%iccn = iccn + if (Model%aero_in) Model%iccn = .false. Model%iflip = iflip Model%isol = isol Model%ico2 = ico2 @@ -1911,15 +1971,20 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%wminco = wminco !--- Morroson-Gettleman MP parameters Model%fprcp = fprcp + Model%pdfflag = pdfflag Model%mg_dcs = mg_dcs Model%mg_qcvar = mg_qcvar Model%mg_ts_auto_ice = mg_ts_auto_ice + Model%mg_alf = mg_alf + Model%mg_qcmin = mg_qcmin Model%effr_in = effr_in Model%microp_uniform = microp_uniform Model%do_cldice = do_cldice Model%hetfrz_classnuc = hetfrz_classnuc Model%mg_do_graupel = mg_do_graupel Model%mg_do_hail = mg_do_hail + Model%mg_do_ice_gmao = mg_do_ice_gmao + Model%mg_do_liq_liu = mg_do_liq_liu Model%mg_nccons = mg_nccons Model%mg_nicons = mg_nicons Model%mg_ngcons = mg_ngcons @@ -1984,6 +2049,9 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%ctei_rm = ctei_rm Model%crtrh = crtrh Model%dlqf = dlqf + Model%psauras = psauras + Model%prauras = prauras + Model%wminras = wminras Model%rbcr = rbcr @@ -2002,24 +2070,26 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%pgcon_deep = pgcon_deep Model%asolfac_deep = asolfac_deep - !--- mass flux shallow convection +!--- mass flux shallow convection Model%clam_shal = clam_shal Model%c0s_shal = c0s_shal Model%c1_shal = c1_shal Model%pgcon_shal = pgcon_shal Model%asolfac_shal = asolfac_shal - !--- near surface temperature model +!--- near surface sea temperature model Model%nst_anl = nst_anl Model%lsea = lsea + Model%nstf_name = nstf_name + +!--- backgroud vertical diffusion Model%xkzm_m = xkzm_m Model%xkzm_h = xkzm_h Model%xkzm_s = xkzm_s - Model%nstf_name = nstf_name Model%xkzminv = xkzminv Model%moninq_fac = moninq_fac - !--- stochastic physics options +!--- stochastic physics options Model%do_sppt = do_sppt Model%use_zmtnblck = use_zmtnblck Model%do_shum = do_shum @@ -2142,7 +2212,8 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%nctp = max(Model%nctp,10) if (Model%cs_parm(7) < 0.0) Model%cs_parm(7) = Model%dtp Model%do_awdd = Model%do_aw .and. Model%cs_parm(6) > 0.0 - Model%flx_form = Model%do_aw .and. Model%cs_parm(8) > 0.0 +! Model%flx_form = Model%do_aw .and. Model%cs_parm(8) > 0.0 + Model%flx_form = Model%cs_parm(8) > 0.0 endif Model%nctp = max(Model%nctp,1) @@ -2297,17 +2368,20 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & endif Model%num_p3d = 6 endif - if (Model%me == Model%master) & - print *,' Using Morrison-Gettelman double moment microphysics', & - ' aero_in=', Model%aero_in, & - ' mg_dcs=', Model%mg_dcs,' mg_qcvar=',Model%mg_qcvar, & - ' mg_ts_auto_ice=',Model%mg_ts_auto_ice, & - ' mg_do_graupel=', Model%mg_do_graupel,' mg_do_hail=', Model%mg_do_hail, & - ' mg_nccons=', Model%mg_nccons, ' mg_nicon=', Model%mg_nicons, & - ' mg_ngcons=', Model%mg_ngcons , ' mg_ncnst=', Model%mg_ncnst, & - ' mg_ninst=', Model%mg_ninst , ' mg_ngnst=', Model%mg_ngnst, & - ' sed_supersat=', Model%sed_supersat ,' do_sb_physics=', Model%do_sb_physics,& - ' ncnd=',Model%ncnd + if (Model%me == Model%master) & + print *,' Using Morrison-Gettelman double moment microphysics', & + ' aero_in=', Model%aero_in, ' iccn=', Model%iccn, & + ' mg_dcs=', Model%mg_dcs, ' mg_qcvar=', Model%mg_qcvar, & + ' mg_ts_auto_ice=', Model%mg_ts_auto_ice, ' pdfflag=', Model%pdfflag, & + ' mg_do_graupel=', Model%mg_do_graupel, ' mg_do_hail=', Model%mg_do_hail, & + ' mg_nccons=', Model%mg_nccons, ' mg_nicon=', Model%mg_nicons, & + ' mg_ngcons=', Model%mg_ngcons , ' mg_ncnst=', Model%mg_ncnst, & + ' mg_ninst=', Model%mg_ninst , ' mg_ngnst=', Model%mg_ngnst, & + ' sed_supersat=', Model%sed_supersat , ' do_sb_physics=', Model%do_sb_physics,& + ' microp_uniform=', Model%microp_uniform, ' do_cldice=', Model%do_cldice, & + ' hetfrz_classnuc=', Model%hetfrz_classnuc, ' ncnd=', Model%ncnd, & + ' mg_alf=', Model%mg_alf, ' mg_qcmin=', Model%mg_qcmin, & + ' mg_do_ice_gmao=', Model%mg_do_ice_gmao, ' mg_do_liq_liu=', Model%mg_do_liq_liu elseif (Model%imp_physics == 11) then !GFDL microphysics Model%npdf3d = 0 @@ -2322,12 +2396,6 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & stop endif - Model%uni_cld = .false. -! if (Model%shoc_cld .or. Model%ncld == 2 .or. Model%ntclamt > 0) then - if ((Model%shoc_cld) .or. (Model%imp_physics == 10)) then - Model%uni_cld = .true. - endif - if(Model%ras .or. Model%cscnv) Model%cnvcld = .false. if(Model%do_shoc .or. Model%pdfcld) Model%cnvcld = .false. if(Model%cnvcld) Model%ncnvcld3d = 1 @@ -2343,15 +2411,30 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !--- derived totals for phy_f*d Model%ntot2d = Model%num_p2d + Model%nshoc_2d Model%ntot3d = Model%num_p3d + Model%nshoc_3d + Model%npdf3d + Model%ncnvcld3d - if (me == Model%master) print *,' num_p3d=',Model%num_p3d,' num_p2d=',Model%num_p2d, & - ' crtrh=',Model%crtrh,' npdf3d=',Model%npdf3d, & - ' pdfcld=',Model%pdfcld,' shcnvcw=',Model%shcnvcw, & - ' cnvcld=',Model%cnvcld,' ncnvcld3d=',Model%ncnvcld3d, & - ' do_shoc=',Model%do_shoc,' nshoc3d=',Model%nshoc_3d, & - ' nshoc_2d=',Model%nshoc_2d,' shoc_cld=',Model%shoc_cld,& - ' ntot3d=',Model%ntot3d,' ntot2d=',Model%ntot2d, & - ' shocaftcnv=',Model%shocaftcnv, & - ' shoc_parm=',Model%shoc_parm,' ncnvw=', Model%ncnvw +! +! Unified cloud for SHOC and/or MG3 + Model%uni_cld = .false. + Model%indcld = -1 +! if (Model%shoc_cld .or. Model%ncld == 2 .or. Model%ntclamt > 0) then + if (Model%imp_physics == 10) then + Model%uni_cld = .true. + Model%indcld = 1 + elseif (Model%shoc_cld) then + Model%uni_cld = .true. + Model%indcld = Model%ntot3d - 2 + endif + + if (me == Model%master) & + write(0,*) ' num_p3d=', Model%num_p3d, ' num_p2d=', Model%num_p2d, & + ' crtrh=', Model%crtrh, ' npdf3d=', Model%npdf3d, & + ' pdfcld=', Model%pdfcld, ' shcnvcw=', Model%shcnvcw, & + ' cnvcld=', Model%cnvcld, ' ncnvcld3d=',Model%ncnvcld3d, & + ' do_shoc=', Model%do_shoc, ' nshoc3d=', Model%nshoc_3d, & + ' nshoc_2d=', Model%nshoc_2d, ' shoc_cld=', Model%shoc_cld, & + ' uni_cld=', Model%uni_cld, & + ' ntot3d=', Model%ntot3d, ' ntot2d=', Model%ntot2d, & + ' shocaftcnv=',Model%shocaftcnv,' indcld=', Model%indcld, & + ' shoc_parm=', Model%shoc_parm, ' ncnvw=', Model%ncnvw !--- END CODE FROM COMPNS_PHYSICS @@ -2359,14 +2442,15 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !--- BEGIN CODE FROM GLOOPR !--- set up parameters for Xu & Randell's cloudiness computation (Radiation) - Model%lmfshal = (Model%shal_cnv .and. (Model%imfshalcnv > 0)) + Model%lmfshal = (Model%shal_cnv .and. Model%imfshalcnv > 0) Model%lmfdeep2 = (Model%imfdeepcnv == 2) !--- END CODE FROM GLOOPR !--- BEGIN CODE FROM GLOOPB !--- set up random number seed needed for RAS and old SAS and when cal_pre=.true. +! Model%imfdeepcnv < 0 when Model%ras = .true. - if ((Model%imfdeepcnv <= 0) .or. (Model%cal_pre)) then + if (Model%imfdeepcnv <= 0 .or. Model%cal_pre ) then if (Model%random_clds) then seed0 = Model%idate(1) + Model%idate(2) + Model%idate(3) + Model%idate(4) call random_setseed(seed0) @@ -2489,6 +2573,9 @@ subroutine control_print(Model) print *, ' mg_dcs : ', Model%mg_dcs print *, ' mg_qcvar : ', Model%mg_qcvar print *, ' mg_ts_auto_ice : ', Model%mg_ts_auto_ice + print *, ' mg_alf : ', Model%mg_alf + print *, ' mg_qcmin : ', Model%mg_qcmin + print *, ' pdfflag : ', Model%pdfflag print *, ' ' endif if (Model%imp_physics == 11) then @@ -2507,6 +2594,11 @@ subroutine control_print(Model) print *, ' ' print *, 'tuning parameters for physical parameterizations' print *, ' ras : ', Model%ras + if (Model%ras) then + print *, ' psauras : ', Model%psauras + print *, ' prauras : ', Model%prauras + print *, ' wminras : ', Model%wminras + endif print *, ' flipv : ', Model%flipv print *, ' trans_trac : ', Model%trans_trac print *, ' old_monin : ', Model%old_monin @@ -2516,6 +2608,7 @@ subroutine control_print(Model) print *, ' cscnv : ', Model%cscnv print *, ' cal_pre : ', Model%cal_pre print *, ' do_aw : ', Model%do_aw + print *, ' flx_form : ', Model%flx_form print *, ' do_shoc : ', Model%do_shoc print *, ' shoc_parm : ', Model%shoc_parm print *, ' shocaftcnv : ', Model%shocaftcnv @@ -2574,7 +2667,7 @@ subroutine control_print(Model) print *, ' asolfac_shal : ', Model%asolfac_shal endif print *, ' ' - print *, 'near surface temperature model' + print *, 'near surface sea temperature model' print *, ' nst_anl : ', Model%nst_anl print *, ' nstf_name : ', Model%nstf_name print *, ' lsea : ', Model%lsea @@ -2663,6 +2756,7 @@ subroutine grid_create (Grid, IM, Model) allocate (Grid%xlon (IM)) allocate (Grid%xlat (IM)) allocate (Grid%xlat_d (IM)) + allocate (Grid%xlon_d (IM)) allocate (Grid%sinlat (IM)) allocate (Grid%coslat (IM)) allocate (Grid%area (IM)) @@ -2671,6 +2765,7 @@ subroutine grid_create (Grid, IM, Model) Grid%xlon = clear_val Grid%xlat = clear_val Grid%xlat_d = clear_val + Grid%xlon_d = clear_val Grid%sinlat = clear_val Grid%coslat = clear_val Grid%area = clear_val @@ -2689,6 +2784,26 @@ subroutine grid_create (Grid, IM, Model) allocate (Grid%jindx1_h (IM)) allocate (Grid%jindx2_h (IM)) endif + +!--- iccn active + if ( Model%iccn ) then + allocate (Grid%ddy_ci (IM)) + allocate (Grid%jindx1_ci (IM)) + allocate (Grid%jindx2_ci (IM)) + allocate (Grid%ddx_ci (IM)) + allocate (Grid%iindx1_ci (IM)) + allocate (Grid%iindx2_ci (IM)) + endif + +!--- iaerclm active + if ( Model%aero_in ) then + allocate (Grid%ddy_aer (IM)) + allocate (Grid%jindx1_aer(IM)) + allocate (Grid%jindx2_aer(IM)) + allocate (Grid%ddx_aer (IM)) + allocate (Grid%iindx1_aer(IM)) + allocate (Grid%iindx2_aer(IM)) + endif end subroutine grid_create @@ -2716,6 +2831,16 @@ subroutine tbd_create (Tbd, IM, Model) Tbd%ozpl = clear_val Tbd%h2opl = clear_val +!--- ccn and in needs + allocate (Tbd%in_nm (IM,Model%levs)) + allocate (Tbd%ccn_nm (IM,Model%levs)) + Tbd%in_nm = clear_val + Tbd%ccn_nm = clear_val + +!--- aerosol fields + allocate (Tbd%aer_nm (IM,Model%levs,ntrcaer)) + Tbd%aer_nm = clear_val + allocate (Tbd%rann (IM,Model%nrcm)) Tbd%rann = rann_init diff --git a/gfsphysics/makefile b/gfsphysics/makefile index 557adff01..e8019473d 100644 --- a/gfsphysics/makefile +++ b/gfsphysics/makefile @@ -68,6 +68,8 @@ SRCS_f = \ ./physics/mstcnv.f \ ./physics/namelist_soilveg.f \ ./physics/ozne_def.f \ + ./physics/iccn_def.f \ + ./physics/aerclm_def.f \ ./physics/ozphys.f \ ./physics/ozphys_2015.f \ ./physics/physparam.f \ @@ -127,6 +129,8 @@ SRCS_f90 = \ ./physics/module_nst_parameters.f90 \ ./physics/module_nst_water_prop.f90 \ ./physics/ozinterp.f90 \ + ./physics/iccninterp.f90 \ + ./physics/aerinterp.f90 \ ./physics/physcons.f90 \ ./physics/wam_f107_kp_mod.f90 diff --git a/gfsphysics/physics/aer_cloud.F b/gfsphysics/physics/aer_cloud.F index 5a42dccad..680ce8438 100644 --- a/gfsphysics/physics/aer_cloud.F +++ b/gfsphysics/physics/aer_cloud.F @@ -4,8 +4,8 @@ MODULE aer_cloud use MAPL_ConstantsMod, r8 => MAPL_R8 #endif #ifdef NEMS_GSM - use physcons, only: MAPL_PI=>con_pi - use machine, only : r8 => kind_phys + use physcons, only : MAPL_PI => con_pi + use machine, only : r8 => kind_phys #endif ! according to the models of Nenes & Seinfeld (2003), Fountoukis and Nenes (2005) and Barahona and Nenes (2008, 2009). @@ -82,7 +82,8 @@ MODULE aer_cloud &, grav_par=9.81d0, rgas_par=8.31d0 &, accom_par=1.0d0, eps_par=1d-6 &, zero_par=1.0e-20, great_par=1d20 - &, pi_par=3.1415927d0, sq2pi_par=sqrt(pi_par) + &, pi_par=mapl_pi, sq2pi_par=sqrt(pi_par) +! &, pi_par=3.1415927d0, sq2pi_par=sqrt(pi_par) &, sq2_par=1.41421356237d0 ! &, wmw_ice=018d0, amw_ice=0.029d0 @@ -176,6 +177,7 @@ subroutine aerosol_activate(tparc_in, pparc_in, sigwparc_in, & dINimmr8, Ncdepr8, Ncdhfr8, sc_icer8, fdust_immr8, fdust_depr8, & fdust_dhfr8, nlimr8, use_average_v, CCN_param, IN_param, fd_dust, & fd_soot, pfrz_inc_r8, sigma_nuc, rhi_cell,nccn) +! & fd_soot, pfrz_inc_r8, sigma_nuc, rhi_cell,nccn, lprnt) @@ -183,6 +185,7 @@ subroutine aerosol_activate(tparc_in, pparc_in, sigwparc_in, type(AerProps), intent(in) :: Aer_Props logical :: use_average_v +! logical :: use_average_v, lprnt real(r8), intent(in) :: tparc_in, pparc_in, sigwparc_in, & wparc_ls, npre_in, dpre_in, Ndropr8, fd_soot, fd_dust, @@ -314,12 +317,25 @@ subroutine aerosol_activate(tparc_in, pparc_in, sigwparc_in, call init_Aer(Aeraux) +! if (lprnt) write(0,*)' in aero Aer_Props%num=' +! &,Aer_Props%num,' nmodes=',nmodes,' air_den=',air_den +! if (lprnt) write(0,*)' in aero Aer_Props%kap=' +! &,Aer_Props%kap + + antot = 0.0 + do n=1,nmodes - tp_par(n) = DBLE(Aer_Props%num(n))*air_den - dpg_par(n) = max(DBLE(Aer_Props%dpg(n)), 1.0e-10) - sig_par(n) = DBLE(Aer_Props%sig(n)) - kappa_par(n) = max(DBLE(Aer_Props%kap(n)), 0.001) - dens_par(n) = DBLE(Aer_Props%den(n)) +! tp_par(n) = DBLE(Aer_Props%num(n))*air_den +! dpg_par(n) = max(DBLE(Aer_Props%dpg(n)), 1.0e-10) +! sig_par(n) = DBLE(Aer_Props%sig(n)) +! kappa_par(n) = max(DBLE(Aer_Props%kap(n)), 0.001) +! dens_par(n) = DBLE(Aer_Props%den(n)) + + tp_par(n) = Aer_Props%num(n) * air_den + dpg_par(n) = max(Aer_Props%dpg(n), 1.0e-10) + sig_par(n) = Aer_Props%sig(n) + kappa_par(n) = max(Aer_Props%kap(n), 0.001) + dens_par(n) = Aer_Props%den(n) vhf_par(n) = 3.0 if (kappa_par(n) > 0.01) then ams_par(n) = 18.0e-3*1.7*3.0/kappa_par(n) @@ -328,15 +344,20 @@ subroutine aerosol_activate(tparc_in, pparc_in, sigwparc_in, tp_par(n) = 0.0 endif amfs_par(n) = 1.0 - deni_par(n) = dens_par(n) + deni_par(n) = dens_par(n) + antot = antot + tp_par(n) + +! if (lprnt) write(0,*)' n=',n,' tp_par=',tp_par(n),' antot=',antot +! &,' Aer_Props%num=',Aer_Props%num(n),' kappa_par=',kappa_par(n) +! &,' air_den=',air_den enddo - kappa_par = max(kappa_par, 0.001) - dpg_par = max(dpg_par, 1.0e-10) +! kappa_par = max(kappa_par, 0.001) +! dpg_par = max(dpg_par, 1.0e-10) temp_par = max(tparc, 245.0) pres_par = max(pparc, 34000.0) - antot = sum(tp_par) +! antot = sum(tp_par) ntot = antot wparc = max(max(0.8d0*sigwparc, 0.01)+ wparc_ls, 0.01) @@ -346,6 +367,9 @@ subroutine aerosol_activate(tparc_in, pparc_in, sigwparc_in, !============== Calculate cloud droplet number concentration=================== +! if (lprnt) write(0,*)' in aero tparc=',tparc,' antot=',antot +! if (lprnt) write(0,*)' in aero tp_par=',tp_par(1:nmodes) + if (tparc > 245.0) then if (antot > 1.0) then @@ -374,16 +398,18 @@ subroutine aerosol_activate(tparc_in, pparc_in, sigwparc_in, cdncr8 = max(nact/air_den, zero_par) smaxliqr8 = max(smax, zero_par) +! if (lprnt) write(0,*)' in aero cdncr8=',cdncr8,' nact=',nact, +! &' air_den=',air_den,' wparc=',wparc,' act_param=',act_param !============ Calculate diagnostic CCN number concentration================== - smax_diag = ccn_diagr8 +! smax_diag = ccn_diagr8 ! do k =1, size (smax_diag) - do k =1, nccn - call ccn_at_super (smax_diag(k), ccn_at_s,nmodes, - & sig_par,sg_par,tp_par) - ccn_diagr8 (k) = ccn_at_s - end do +! do k =1, nccn +! call ccn_at_super (smax_diag(k), ccn_at_s,nmodes, +! & sig_par,sg_par,tp_par) +! ccn_diagr8 (k) = ccn_at_s +! end do end if end if @@ -1321,7 +1347,7 @@ subroutine ccnspec (tparc,pparc,nmodes, integer act_param - ntot=zero_par + ntot = zero_par temp_par = max(tparc, 245.0) pres_par = max(pparc, 34000.0) ! @@ -1347,7 +1373,7 @@ subroutine ccnspec (tparc,pparc,nmodes, par1 = par1/vlfs par2 = sqrt(max(par1*akoh_par*akoh_par*akoh_par, zero_par)) sg_par(k)= max(exp(par2) - 1d0, zero_par) - ntot=ntot+tp_par(k) + ntot = ntot + tp_par(k) enddo ! diff --git a/gfsphysics/physics/aerclm_def.f b/gfsphysics/physics/aerclm_def.f new file mode 100644 index 000000000..6729237d8 --- /dev/null +++ b/gfsphysics/physics/aerclm_def.f @@ -0,0 +1,23 @@ + module aerclm_def + use machine , only : kind_phys + implicit none + +! only read monthly merra2 data for m-1, m, m+1 + integer, parameter :: levsaer=45, latsaer=91, lonsaer=144 + integer, parameter :: lmerra=72, ntrcaerm=15, timeaer=12 + + integer :: ntrcaer + character*10 :: specname(ntrcaerm) + real (kind=kind_phys):: aer_lat(latsaer), aer_lon(lonsaer) + & ,aer_time(13) + real (kind=4), allocatable, dimension(:,:,:,:,:) :: aerin + real (kind=kind_phys), allocatable, dimension(:,:,:,:) :: aer_pres + + data aer_time/15.5, 45., 74.5, 105., 135.5, 166., 196.5, + & 227.5, 258., 288.5, 319., 349.5, 380.5/ + + data specname /'DU001','DU002','DU003','DU004','DU005', + & 'SS001','SS002','SS003','SS004','SS005','SO4', + & 'BCPHOBIC','BCPHILIC','OCPHILIC','OCPHOBIC'/ + + end module aerclm_def diff --git a/gfsphysics/physics/aerinterp.f90 b/gfsphysics/physics/aerinterp.f90 new file mode 100644 index 000000000..8d5603b83 --- /dev/null +++ b/gfsphysics/physics/aerinterp.f90 @@ -0,0 +1,369 @@ + SUBROUTINE read_aerdata (me, master, iflip, idate ) + + use machine, only: kind_phys + use aerclm_def + use netcdf + +!--- in/out + integer, intent(in) :: me, master, iflip, idate(4) + +!--- locals + integer :: ncid, varid + integer :: i, j, k, n, ii, ijk, imon, klev + character :: fname*50, mn*2, fldname*10 + logical :: file_exist + real(kind=4), allocatable, dimension(:,:,:) :: ps_clm + real(kind=4), allocatable, dimension(:,:,:,:) :: delp_clm + real(kind=4), allocatable, dimension(:,:,:,:) :: aer_clm + real(kind=4), allocatable, dimension(:,:,:,:) :: airden_clm + real(kind=4), allocatable, dimension(:) :: pres_tmp + + allocate (delp_clm(lonsaer,latsaer,lmerra,1)) + allocate (aer_clm(lonsaer,latsaer,lmerra,1)) + allocate (airden_clm(lonsaer,latsaer,lmerra,1)) + allocate (ps_clm(lonsaer,latsaer,1)) + allocate (pres_tmp(lmerra)) + +! allocate aerclm_def arrays: aerin and aer_pres + allocate (aerin(lonsaer,latsaer,levsaer,ntrcaer,timeaer)) + allocate (aer_pres(lonsaer,latsaer,levsaer,timeaer)) + + if (me == master) then + if ( iflip == 0 ) then ! data from toa to sfc + print *, "EJ, GFS is top-down" + else + print *, "EJ, GFS is bottom-up" + endif + endif + + do imon = 1, timeaer + !ijk = imon + idate(2)+int(idate(3)/16)-2 + !if ( ijk .le. 0 ) ijk = 12 + !if ( ijk .eq. 13 ) ijk = 1 + !if ( ijk .eq. 14 ) ijk = 2 + write(mn,'(i2.2)') imon + fname=trim("merra2C.aerclim.2003-2014.m"//mn//".nc") + if (me == master) print *, "EJ,aerosol climo:", fname, & + "for imon:",imon,idate + + inquire (file = fname, exist = file_exist) + if ( file_exist ) then + if (me == master) print *, & + "EJ, aerosol climo found; proceed the run" + else + print *,"EJ, Error! aerosol climo not found; abort the run" + stop 555 + endif + + call nf_open(fname, nf_NOWRITE, ncid) + +! merra2 data is top down +! for GFS, iflip 0: toa to sfc; 1: sfc to toa + +! read aerosol mixing ratio arrays (kg/kg) +! construct 4-d aerosol mass concentration (kg/m3) + call nf_inq_varid(ncid, 'AIRDENS', varid) + call nf_get_var(ncid, varid, airden_clm) +! if(me==master) print *, "EJ, read airdens", airden_clm(1,1,:,1) + + do ii = 1, ntrcaer + fldname=specname(ii) + call nf_inq_varid(ncid, fldname, varid) + call nf_get_var(ncid, varid, aer_clm) +! if(me==master) print *, "EJ, read ", fldname, aer_clm(1,1,:,1) + do i = 1, lonsaer + do j = 1, latsaer + 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 = ( lmerra - k ) + 1 + endif + aerin(i,j,k,ii,imon) = aer_clm(i,j,klev,1)*airden_clm(i,j,klev,1) + enddo !k-loop (lev) + enddo !j-loop (lat) + enddo !i-loop (lon) + enddo !ii-loop (ntrac) + +! aer_clm is top-down (following MERRA2) +! aerin is bottom-up (following GFS) + +! if ( imon == 1 .and. me == master ) then +! print *, 'EJ, du1(1,1) :', aerin(1,1,:,1,imon) +! endif + +! construct 3-d pressure array (Pa) + call nf_inq_varid(ncid, "PS", varid) + call nf_get_var(ncid, varid, ps_clm) + call nf_inq_varid(ncid, "DELP", varid) + call nf_get_var(ncid, varid, delp_clm) + +! if ( imon == 1 .and. me == master ) then +! print *, 'EJ, ps_clm:', ps_clm(1,1,1) +! print *, 'EJ, delp_clm:', delp_clm(1,1,:,1) +! endif + + do i = 1, lonsaer + do j = 1, latsaer + +! constract pres_tmp (top-down) + pres_tmp(1) = 0. + do k=2, lmerra + pres_tmp(k) = pres_tmp(k-1) + delp_clm(i,j,k,1) + enddo +! if (imon==1 .and. me==master .and. i==1 .and. j==1 ) then +! print *, 'EJ, pres_tmp:', pres_tmp(:) +! endif + +! extract pres_tmp to fill aer_pres + do k = 1, levsaer + if ( iflip == 0 ) then ! data from toa to sfc + klev = k + else ! data from sfc to top + klev = ( lmerra - k ) + 1 + endif + aer_pres(i,j,k,imon)= pres_tmp(klev) + enddo !k-loop (lev) +! if (imon==1 .and. me==master .and. i==1 .and. j==1 ) then +! print *, 'EJ, aer_pres:', aer_pres(i,j,:,imon) +! endif + + enddo !j-loop (lat) + enddo !i-loop (lon) + +! if (imon==1 .and. me==master ) then +! print *, 'EJx, aer_pres_i1:',(aer_pres(1,1:180,levsaer,imon) ) +! endif + +! construct lat/lon array + if (imon == 1 ) then + call nf_inq_varid(ncid, "lat", varid) + call nf_get_var(ncid, varid, aer_lat) + call nf_inq_varid(ncid, "lon", varid) + call nf_get_var(ncid, varid, aer_lon) + do i = 1, lonsaer + if(aer_lon(i) < 0.) aer_lon(i) = aer_lon(i) + 360. + enddo +! if (imon==1 .and. me == master) then +! print *, "EJ, lat:", aer_lat(:) +! print *, "EJ, lon:", aer_lon(:) +! endif + endif + +! close the file + call nf_close(ncid) + enddo !imon-loop + +!--- + deallocate (ps_clm, delp_clm, pres_tmp, aer_clm, airden_clm ) + if (me == master) then + write(*,*) 'Reading in GOCART aerosols data' + endif + + END SUBROUTINE read_aerdata +! +!********************************************************************** +! + SUBROUTINE setindxaer(npts,dlat,jindx1,jindx2,ddy,dlon, & + iindx1,iindx2,ddx,me,master) +! + USE MACHINE, ONLY: kind_phys + use aerclm_def, only: aer_lat, jaero=>latsaer, & + aer_lon, iaero=>lonsaer +! + implicit none +! + integer me, master + integer npts, JINDX1(npts),JINDX2(npts),IINDX1(npts),IINDX2(npts) + real(kind=kind_phys) dlat(npts),DDY(npts),dlon(npts),DDX(npts) +! + integer i,j + + DO J=1,npts + jindx2(j) = jaero + 1 + do i=1,jaero + if (dlat(j) < aer_lat(i)) then + jindx2(j) = i + exit + endif + enddo + jindx1(j) = max(jindx2(j)-1,1) + jindx2(j) = min(jindx2(j),jaero) + if (jindx2(j) .ne. jindx1(j)) then + DDY(j) = (dlat(j) - aer_lat(jindx1(j))) & + / (aer_lat(jindx2(j)) - aer_lat(jindx1(j))) + else + ddy(j) = 1.0 + endif + +! if (me == master .and. j<= 3) then +! print *,'EJj,',j,' dlat=',dlat(j),' jindx12=',jindx1(j),& +! jindx2(j),' aer_lat=',aer_lat(jindx1(j)), & +! aer_lat(jindx2(j)),' ddy=',ddy(j) +! endif + ENDDO + + DO J=1,npts + iindx2(j) = iaero + 1 + do i=1,iaero + if (dlon(j) < aer_lon(i)) then + iindx2(j) = i + exit + endif + enddo + iindx1(j) = max(iindx2(j)-1,1) + iindx2(j) = min(iindx2(j),iaero) + if (iindx2(j) .ne. iindx1(j)) then + ddx(j) = (dlon(j) - aer_lon(iindx1(j))) & + / (aer_lon(iindx2(j)) - aer_lon(iindx1(j))) + else + ddx(j) = 1.0 + endif +! if (me == master .and. j<= 3) then +! print *,'EJi,',j,' dlon=',dlon(j),' iindx12=',iindx1(j),& +! iindx2(j),' aer_lon=',aer_lon(iindx1(j)), & +! aer_lon(iindx2(j)),' ddx=',ddx(j) +! endif + ENDDO + + RETURN + END +! +!********************************************************************** +!********************************************************************** +! + SUBROUTINE aerinterpol(me,master,npts,IDATE,FHOUR,jindx1,jindx2, & + 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 +! + + integer JINDX1(npts), JINDX2(npts),iINDX1(npts),iINDX2(npts) + integer me,idate(4), master + integer IDAT(8),JDAT(8) +! + real(kind=kind_phys) DDY(npts), ddx(npts),ttt + real(kind=kind_phys) aerout(npts,lev,ntrcaer),aerpm(npts,levsaer,ntrcaer) + real(kind=kind_phys) prsl(npts,lev), aerpres(npts,levsaer) + real(kind=kind_phys) RINC(5), rjday + integer jdow, jdoy, jday + 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 + call w3kind(w3kindreal,w3kindint) + if(w3kindreal==4) then + rinc4=rinc + CALL W3MOVDAT(RINC4,IDAT,JDAT) + else + CALL W3MOVDAT(RINC,IDAT,JDAT) + endif +! if(me==master) print *,'EJ, IDAT ',IDAT(1:3), IDAT(5) +! + jdow = 0 + jdoy = 0 + jday = 0 + call w3doxdat(jdat,jdow,jdoy,jday) + rjday = jdoy + jdat(5) / 24. + IF (RJDAY .LT. aer_time(1)) RJDAY = RJDAY+365. +! + n2 = 13 + do j=2, 12 + if (rjday .lt. aer_time(j)) then + n2 = j + exit + endif + enddo + n1 = n2 - 1 +! + tx1 = (aer_time(n2) - rjday) / (aer_time(n2) - aer_time(n1)) + tx2 = 1.0 - tx1 + if (n2 > 12) n2 = n2 -12 +! if(me==master)print *,'EJ,rjday=',rjday, ';aer_time,tx1,tx=' & +! , aer_time(n1),aer_time(n2),tx1,tx2,n1,n2 +! +! if(me==master) then +! DO L=1,levsaer +! print *,'EJ,aerin(n1,n2)=',L,aerin(1,1,L,1,n1),aerin(1,1,L,1,n2) +! ENDDO +! 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) + 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)) + 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)) + +! IF(me==master .and. j==1) THEN +! print *, 'EJ,aer/ps:',L,aerpm(j,L,1),aerpres(j,L) +! if(L==1) then +! print *, 'EJ, wgt:',TEMI*TEMJ,DDX(j)*DDY(J),TEMI*DDY(j),DDX(j)*TEMJ +! print *, 'EJ, aerx:',aerin(I1,J1,L,ii,n1), & +! aerin(I2,J2,L,ii,n1), aerin(I1,J2,L,ii,n1), aerin(I2,J1,L,ii,n1) +! print *, 'EJ, aery:',aerin(I1,J1,L,ii,n2), & +! aerin(I2,J2,L,ii,n2), aerin(I1,J2,L,ii,n2), aerin(I2,J1,L,ii,n2) +! endif +! ENDIF + ENDDO + ENDDO + +! note: input is set to be same as GFS + DO J=1,npts + DO L=1,lev + if(prsl(j,l).ge.aerpres(j,levsaer)) then + DO ii=1, ntrcaer + aerout(j,l,ii)=aerpm(j,levsaer,ii) + ENDDO + else if(prsl(j,l).le.aerpres(j,1)) then + DO ii=1, ntrcaer + aerout(j,l,ii)=aerpm(j,1,ii) + ENDDO + else + DO k=levsaer-1,1,-1 + IF(prsl(j,l)>aerpres(j,k)) then + i1=k + i2=min(k+1,levsaer) + exit + end if + end do + DO ii = 1, ntrcaer + aerout(j,l,ii)=aerpm(j,i1,ii)+(aerpm(j,i2,ii)-aerpm(j,i1,ii))& + /(aerpres(j,i2)-aerpres(j,i1))*(prsl(j,l)-aerpres(j,i1)) +! IF(me==master .and. j==1 .and. ii==1) then +! print *, 'EJ, aerout:',aerout(j,l,ii), aerpm(j,i1,ii), & +! aerpm(j,i2,ii), aerpres(j,i2), aerpres(j,i1), prsl(j,l) +! ENDIF + ENDDO + endif + ENDDO + ENDDO +! + RETURN + END diff --git a/gfsphysics/physics/cldmacro.F b/gfsphysics/physics/cldmacro.F index 084db5da5..bbc6fb5cf 100644 --- a/gfsphysics/physics/cldmacro.F +++ b/gfsphysics/physics/cldmacro.F @@ -2,8 +2,7 @@ module cldmacro !======================================================================= ! Anning Cheng 2/18/2016 replaced GEO condensation scheme ! with those from 2M microphysics - use wv_saturation, only: - & epsqs,ttrice,hlatv,hlatf,pcf,rgasv + use wv_saturation, only : epsqs, ttrice, hlatv, hlatf, pcf, rgasv ! & ,vqsatd2_water_single, ! & vqsatd2_ice_single,vqsatd2_single use funcphys, only : fpvs, fpvsl, fpvsi @@ -37,7 +36,8 @@ module cldmacro !! Some parameters set by PHYSPARAMS - integer :: NSMAX, DISABLE_RAD, ICEFRPWR, pdfflag +! integer :: NSMAX, DISABLE_RAD, ICEFRPWR + integer :: NSMAX, DISABLE_RAD, ICEFRPWR &, FR_LS_WAT, FR_LS_ICE, FR_AN_WAT, FR_AN_ICE real :: CNV_BETA @@ -94,45 +94,52 @@ module cldmacro &, alhsbcp = alhlbcp+alhfbcp - real, parameter :: PI_0 = 4.*atan(1.) - real omeps, trinv, t_ice_denom +! real, parameter :: PI_0 = 4.*atan(1.) + real :: omeps, trinv, t_ice_denom !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! contains - subroutine macro_cloud(IRUN, LM, DT, PP_dev, PPE_dev - &, FRLAND_dev, RMFDTR_dev - &, QLWDTR_dev, QRN_CU_dev, CNV_UPDFRC_dev - &, U_dev, V_dev, TH_dev, Q_dev + subroutine macro_cloud(IRUN, LM, DT, alf_fac, PP_dev, PPE_dev +! &, RMFDTR_dev +! &, FRLAND_dev, RMFDTR_dev + &, QLWDTR_dev +! &, QLWDTR_dev, QRN_CU_dev, CNV_UPDFRC_dev +! &, U_dev, V_dev, TH_dev, Q_dev + &, TH_dev, Q_dev &, QLW_LS_dev, QLW_AN_dev, QIW_LS_dev &, QIW_AN_dev, ANVFRC_dev, CLDFRC_dev - &, PRECU_dev, CUARF_dev, SNRCU_dev - &, PHYSPARAMS, SCLMFDFR, QST3_dev - &, DZET_dev, QDDF3_dev, RHX_dev - &, REV_CN_dev, RSU_CN_dev, ACLL_CN_dev - &, ACIL_CN_dev,PFL_CN_dev, PFI_CN_dev - &, PDFL_dev, PDFI_dev - &, ALPHT_dev, CFPDF_dev, DQRL_dev - &, VFALLSN_CN_dev - &, VFALLRN_CN_dev, CNV_FICE_dev +! &, PRECU_dev, CUARF_dev, SNRCU_dev + &, PHYSPARAMS, SCLMFDFR +! &, PHYSPARAMS, SCLMFDFR, QST3_dev +! &, DZET_dev, QDDF3_dev, RHX_dev +! &, REV_CN_dev, RSU_CN_dev, ACLL_CN_dev +! &, ACIL_CN_dev,PFL_CN_dev, PFI_CN_dev +! &, PDFL_dev, PDFI_dev + &, ALPHT_dev +! &, ALPHT_dev, CFPDF_dev, DQRL_dev +! &, VFALLSN_CN_dev +! &, VFALLRN_CN_dev, CNV_FICE_dev + &, CNV_FICE_dev &, CNV_NDROP_dev, CNV_NICE_dev, SCICE_dev &, NCPL_dev, NCPI_dev, PFRZ_dev - &, QRAIN_CN, QSNOW_CN - &, KCBL, lprnt, ipr, rhc ) +! &, QRAIN_CN, QSNOW_CN + &, lprnt, ipr, rhc, pdfflag, qc_min ) +! &, KCBL, lprnt, ipr, rhc ) - integer, intent(in ) :: IRUN, LM - real, intent(in ) :: DT + integer, intent(in ) :: IRUN, LM, pdfflag + real, intent(in ) :: DT, alf_fac, qc_min(2) real, intent(in ), dimension(IRUN, LM) :: PP_dev real, intent(in ), dimension(IRUN,0:LM) :: PPE_dev - real, intent(in ), dimension(IRUN ) :: FRLAND_dev - real, intent(in ), dimension(IRUN, LM) :: RMFDTR_dev +! real, intent(in ), dimension(IRUN ) :: FRLAND_dev +! real, intent(in ), dimension(IRUN, LM) :: RMFDTR_dev real, intent(in ), dimension(IRUN, LM) :: QLWDTR_dev - real, intent(inout), dimension(IRUN, LM) :: QRN_CU_dev - real, intent(inout), dimension(IRUN, LM) :: CNV_UPDFRC_dev - real, intent(in ), dimension(IRUN, LM) :: U_dev - real, intent(in ), dimension(IRUN, LM) :: V_dev +! real, intent(inout), dimension(IRUN, LM) :: QRN_CU_dev +! real, intent(inout), dimension(IRUN, LM) :: CNV_UPDFRC_dev +! real, intent(in ), dimension(IRUN, LM) :: U_dev +! real, intent(in ), dimension(IRUN, LM) :: V_dev real, intent(in ), dimension(IRUN, LM) :: rhc real, intent(inout), dimension(IRUN, LM) :: TH_dev real, intent(inout), dimension(IRUN, LM) :: Q_dev @@ -142,28 +149,28 @@ subroutine macro_cloud(IRUN, LM, DT, PP_dev, PPE_dev real, intent(inout), dimension(IRUN, LM) :: QIW_AN_dev real, intent(inout), dimension(IRUN, LM) :: ANVFRC_dev real, intent(inout), dimension(IRUN, LM) :: CLDFRC_dev - real, intent( out), dimension(IRUN ) :: PRECU_dev - real, intent( out), dimension(IRUN ) :: CUARF_dev - real, intent( out), dimension(IRUN ) :: SNRCU_dev +! real, intent( out), dimension(IRUN ) :: PRECU_dev +! real, intent( out), dimension(IRUN ) :: CUARF_dev +! real, intent( out), dimension(IRUN ) :: SNRCU_dev real, intent(in ), dimension(58 ) :: PHYSPARAMS real, intent(in ) :: SCLMFDFR - real, intent(in ), dimension(IRUN, LM) :: QST3_dev - real, intent(in ), dimension(IRUN, LM) :: DZET_dev - real, intent(in ), dimension(IRUN, LM) :: QDDF3_dev - real, intent( out), dimension(IRUN, LM) :: RHX_dev - real, intent( out), dimension(IRUN, LM) :: REV_CN_dev - real, intent( out), dimension(IRUN, LM) :: RSU_CN_dev - real, intent( out), dimension(IRUN, LM) :: ACLL_CN_dev - real, intent( out), dimension(IRUN, LM) :: ACIL_CN_dev - real, intent( out), dimension(IRUN,0:LM) :: PFL_CN_dev - real, intent( out), dimension(IRUN,0:LM) :: PFI_CN_dev - real, intent( out), dimension(IRUN, LM) :: PDFL_dev - real, intent( out), dimension(IRUN, LM) :: PDFI_dev +! real, intent(in ), dimension(IRUN, LM) :: QST3_dev +! real, intent(in ), dimension(IRUN, LM) :: DZET_dev +! real, intent(in ), dimension(IRUN, LM) :: QDDF3_dev +! real, intent( out), dimension(IRUN, LM) :: RHX_dev +! real, intent( out), dimension(IRUN, LM) :: REV_CN_dev +! real, intent( out), dimension(IRUN, LM) :: RSU_CN_dev +! real, intent( out), dimension(IRUN, LM) :: ACLL_CN_dev +! real, intent( out), dimension(IRUN, LM) :: ACIL_CN_dev +! real, intent( out), dimension(IRUN,0:LM) :: PFL_CN_dev +! real, intent( out), dimension(IRUN,0:LM) :: PFI_CN_dev +! real, intent( out), dimension(IRUN, LM) :: PDFL_dev +! real, intent( out), dimension(IRUN, LM) :: PDFI_dev real, intent( out), dimension(IRUN, LM) :: ALPHT_dev - real, intent( out), dimension(IRUN, LM) :: CFPDF_dev - real, intent( out), dimension(IRUN, LM) :: DQRL_dev - real, intent( out), dimension(IRUN, LM) :: VFALLSN_CN_dev - real, intent( out), dimension(IRUN, LM) :: VFALLRN_CN_dev +! real, intent( out), dimension(IRUN, LM) :: CFPDF_dev +! real, intent( out), dimension(IRUN, LM) :: DQRL_dev +! real, intent( out), dimension(IRUN, LM) :: VFALLSN_CN_dev +! real, intent( out), dimension(IRUN, LM) :: VFALLRN_CN_dev real, intent(inout), dimension(IRUN, LM) :: CNV_FICE_dev real, intent(inout), dimension(IRUN, LM) :: CNV_NDROP_dev real, intent(inout), dimension(IRUN, LM) :: CNV_NICE_dev @@ -171,11 +178,11 @@ subroutine macro_cloud(IRUN, LM, DT, PP_dev, PPE_dev real, intent(inout), dimension(IRUN, LM) :: NCPL_dev real, intent(inout), dimension(IRUN, LM) :: NCPI_dev real, intent(out), dimension(IRUN, LM) :: PFRZ_dev - real, intent(out), dimension(IRUN, LM) :: QRAIN_CN - real, intent(out), dimension(IRUN, LM) :: QSNOW_CN +! real, intent(out), dimension(IRUN, LM) :: QRAIN_CN +! real, intent(out), dimension(IRUN, LM) :: QSNOW_CN - real, dimension(IRUN, LM) :: FRZ_PP_dev - integer, intent(in), dimension(IRUN) :: KCBL +! real, dimension(IRUN, LM) :: FRZ_PP_dev +! integer, intent(in), dimension(IRUN) :: KCBL logical lprnt integer ipr @@ -187,17 +194,19 @@ subroutine macro_cloud(IRUN, LM, DT, PP_dev, PPE_dev integer :: I , J , K , L - integer :: FRACTION_REMOVAL +! integer :: FRACTION_REMOVAL - real :: MASS, iMASS, TOTFRC, QRN_CU_1D, QSN_CU, QRN_ALL, QSN_ALL - &, QTMP1, QTMP2, QTMP3, QTOT, TEMP, RHCRIT, AA3, BB3, ALPHA - &, VFALL, VFALLRN, VFALLSN, TOT_PREC_UPD, AREA_UPD_PRC - &, AREA_UPD_PRC_tolayer - &, PRN_CU_above, PSN_CU_above + real :: MASS, iMASS, TOTFRC, TEMP, ALPHA + &, dti, tx1, tend, fqi + +! real :: MASS, iMASS, TOTFRC, QRN_CU_1D, QSN_CU, QRN_ALL, QSN_ALL +! &, QTMP1, QTMP2, QTMP3, QTOT, TEMP, RHCRIT, AA3, BB3, ALPHA +! &, VFALL, VFALLRN, VFALLSN, TOT_PREC_UPD, AREA_UPD_PRC +! &, AREA_UPD_PRC_tolayer +! &, PRN_CU_above, PSN_CU_above ! &, AREA_UPD_PRC_tolayer, U_above,U_below, V_above,V_below ! &, DZET_above,DZET_below, PRN_CU_above, PSN_CU_above - &, EVAP_DD_CU_above, SUBL_DD_CU_above - &, NIX, TOTAL_WATER, dti, tx1, tend, fqi +! &, EVAP_DD_CU_above, SUBL_DD_CU_above ! &, NIX, TOTAL_WATER, dti, tx1, tend, fqi, psinv, pops logical :: use_autoconv_timescale @@ -205,9 +214,9 @@ subroutine macro_cloud(IRUN, LM, DT, PP_dev, PPE_dev real, parameter :: RL_cub = 1.0e-15, RI_cub = 6.4e-14 ! - omeps = 1. - epsqs - dti = 1.0 /dt - trinv = 1.0/ttrice + omeps = 1.0 - epsqs + trinv = 1.0 / ttrice + dti = 1.0 / dt CNV_BETA = PHYSPARAMS(1) ANV_BETA = PHYSPARAMS(2) @@ -261,7 +270,7 @@ subroutine macro_cloud(IRUN, LM, DT, PP_dev, PPE_dev MAX_RL = PHYSPARAMS(53) MAX_RI = PHYSPARAMS(54) RI_ANV = PHYSPARAMS(55) - pdfflag = INT(PHYSPARAMS(57)) +! pdfflag = INT(PHYSPARAMS(57)) turnrhcrit_upper = PHYSPARAMS(58) * 0.001 @@ -272,67 +281,72 @@ subroutine macro_cloud(IRUN, LM, DT, PP_dev, PPE_dev RUN_LOOP: DO I = 1, IRUN ! Anning initialization here - PRN_CU_above = 0. - PSN_CU_above = 0. - EVAP_DD_CU_above = 0. - SUBL_DD_CU_above = 0. +! PRN_CU_above = 0. +! PSN_CU_above = 0. +! EVAP_DD_CU_above = 0. +! SUBL_DD_CU_above = 0. ! psinv = 1.0 / ppe_dev(i,lm) K_LOOP: DO K = 1, LM - if (K == 1) then - TOT_PREC_UPD = 0. - AREA_UPD_PRC = 0. - end if +! if (K == 1) then +! TOT_PREC_UPD = 0. +! AREA_UPD_PRC = 0. +! end if - if (K == LM ) then - PRECU_dev(I) = 0. - SNRCU_dev(I) = 0. - CUARF_dev(I) = 0. - end if +! if (K == LM ) then +! PRECU_dev(I) = 0. +! SNRCU_dev(I) = 0. +! CUARF_dev(I) = 0. +! end if - QRN_CU_1D = 0. - QSN_CU = 0. - VFALL = 0. - - PFL_CN_dev(I,K) = 0. - PFI_CN_dev(I,K) = 0. - - IF (K == 1) THEN - PFL_CN_dev(I,0) = 0. - PFI_CN_dev(I,0) = 0. - END IF - - RHX_dev(I,K) = 0.0 - REV_CN_dev(I,K) = 0.0 - RSU_CN_dev(I,K) = 0.0 - ACLL_CN_dev(I,K) = 0.0 - ACIL_CN_dev(I,K) = 0.0 - PDFL_dev(I,K) = 0.0 - PDFI_dev(I,K) = 0.0 - ALPHT_dev(I,K) = 0.0 - CFPDF_dev(I,K) = 0.0 - DQRL_dev(I,K) = 0.0 - VFALLSN_CN_dev(I,K) = 0.0 - VFALLRN_CN_dev(I,K) = 0.0 - VFALLSN = 0.0 - VFALLRN = 0.0 +! QRN_CU_1D = 0. +! QSN_CU = 0. +! VFALL = 0. + +! PFL_CN_dev(I,K) = 0. +! PFI_CN_dev(I,K) = 0. + +! IF (K == 1) THEN +! PFL_CN_dev(I,0) = 0. +! PFI_CN_dev(I,0) = 0. +! END IF + +! RHX_dev(I,K) = 0.0 +! REV_CN_dev(I,K) = 0.0 +! RSU_CN_dev(I,K) = 0.0 +! ACLL_CN_dev(I,K) = 0.0 +! ACIL_CN_dev(I,K) = 0.0 +! PDFL_dev(I,K) = 0.0 +! PDFI_dev(I,K) = 0.0 +! ALPHT_dev(I,K) = 0.0 +! CFPDF_dev(I,K) = 0.0 +! DQRL_dev(I,K) = 0.0 +! VFALLSN_CN_dev(I,K) = 0.0 +! VFALLRN_CN_dev(I,K) = 0.0 +! VFALLSN = 0.0 +! VFALLRN = 0.0 ! DNDCNV_dev(I, K) = 0.0 ! DNCCNV_dev(I, K) = 0.0 ! RAS_DT_dev(I, K) = 0.0 - QRAIN_CN(I,K) = 0.0 - QSNOW_CN(I,K) = 0.0 - NIX = 0.0 +! QRAIN_CN(I,K) = 0.0 +! QSNOW_CN(I,K) = 0.0 +! NIX = 0.0 + +! QRN_CU_1D = QRN_CU_dev(I,K) - QRN_CU_1D = QRN_CU_dev(I,K) +! MASS = (PPE_dev(I,K) - PPE_dev(I,K-1)) +! & * (100./MAPL_GRAV) +! iMASS = 1.0 / MASS +! TEMP = TH_dev(I,K) +! FRZ_PP_dev(I,K) = 0.00 - MASS = (PPE_dev(I,K) - PPE_dev(I,K-1)) - & * (100./MAPL_GRAV) - iMASS = 1.0 / MASS - TEMP = TH_dev(I,K) - FRZ_PP_dev(I,K) = 0.00 + ALPHT_dev(I,K) = 0.0 + MASS = (PPE_dev(I,K) - PPE_dev(I,K-1)) * (100./MAPL_GRAV) + iMASS = 1.0 / MASS + TEMP = TH_dev(I,K) ! NOT USED??? - Moorthi @@ -365,8 +379,8 @@ subroutine macro_cloud(IRUN, LM, DT, PP_dev, PPE_dev NCPI_dev(I,K) = max(NCPI_dev(I,K)+CNV_NICE_dev(I,K)*tx1,0.0) - TEND = RMFDTR_dev(I,K)*iMASS * SCLMFDFR - ANVFRC_dev(I,K) = min(ANVFRC_dev(I,K) + TEND*DT, 1.0) +! TEND = RMFDTR_dev(I,K)*iMASS * SCLMFDFR +! ANVFRC_dev(I,K) = min(ANVFRC_dev(I,K) + TEND*DT, 1.0) ! ! DCNVi_dev(I,K) = (QIW_AN_dev(I,K) - DCNVi_dev(I,K) ) * DTi @@ -402,10 +416,13 @@ subroutine macro_cloud(IRUN, LM, DT, PP_dev, PPE_dev ! call pdf_spread (K, LM, pops, ALPHA, ALPHT_dev(I,K), ! & FRLAND_dev(I), rhc(i) ) - ALPHA = max(1.0e-4, 1.0-rhc(i,k)) +! ALPHA = max(1.0e-4, 1.0-rhc(i,k)) +! ALPHT_dev(I,K) = ALPHA * alf_fac +! + ALPHA = max(1.0e-4, 1.0-rhc(i,k)) * alf_fac ALPHT_dev(I,K) = ALPHA - RHCRIT = 1.0 - ALPHA +! RHCRIT = 1.0 - ALPHA !================================ @@ -414,144 +431,144 @@ subroutine macro_cloud(IRUN, LM, DT, PP_dev, PPE_dev & QLW_LS_dev(I,K), QLW_AN_dev(I,K), & QIW_LS_dev(I,K), QIW_AN_dev(I,K), & SCICE_dev(I,K) , CLDFRC_dev(I,K), - & ANVFRC_dev(I,K), PFRZ_dev(I,K) ) + & ANVFRC_dev(I,K), PFRZ_dev(I,K), pdfflag) !=============Collect convective precip============== !*********************** begin of if(false)******************************** - if(.false.) then - QTMP1 = 0. - QTMP2 = 0. - QTMP3 = 0. - QRN_ALL = 0. - QSN_ALL = 0. - - if ( TEMP < MAPL_TICE ) then -! QTMP2 = QRN_CU_1D - QSN_CU = QRN_CU_1D - QRN_CU_1D = 0. - TEMP = TEMP + QSN_CU * ALHFbCP - end if +! if(.false.) then +! QTMP1 = 0. +! QTMP2 = 0. +! QTMP3 = 0. +! QRN_ALL = 0. +! QSN_ALL = 0. + +! if ( TEMP < MAPL_TICE ) then +!! QTMP2 = QRN_CU_1D +! QSN_CU = QRN_CU_1D +! QRN_CU_1D = 0. +! TEMP = TEMP + QSN_CU * ALHFbCP +! end if - AREA_UPD_PRC_tolayer = 0.0 +! AREA_UPD_PRC_tolayer = 0.0 - TOT_PREC_UPD = TOT_PREC_UPD + ((QRN_CU_1D + QSN_CU) * MASS) - AREA_UPD_PRC = AREA_UPD_PRC + (CNV_UPDFRC_dev(I,K)* - & (QRN_CU_1D + QSN_CU )* MASS) +! TOT_PREC_UPD = TOT_PREC_UPD + ((QRN_CU_1D + QSN_CU) * MASS) +! AREA_UPD_PRC = AREA_UPD_PRC + (CNV_UPDFRC_dev(I,K)* +! & (QRN_CU_1D + QSN_CU )* MASS) - if ( TOT_PREC_UPD > 0.0 ) AREA_UPD_PRC_tolayer = - & MAX( AREA_UPD_PRC/TOT_PREC_UPD, 1.E-6 ) +! if ( TOT_PREC_UPD > 0.0 ) AREA_UPD_PRC_tolayer = +! & MAX( AREA_UPD_PRC/TOT_PREC_UPD, 1.E-6 ) - AREA_UPD_PRC_tolayer = CNV_BETA * AREA_UPD_PRC_tolayer +! AREA_UPD_PRC_tolayer = CNV_BETA * AREA_UPD_PRC_tolayer - IF (K == LM) THEN - if (TOT_PREC_UPD > 0.0) AREA_UPD_PRC = MAX( AREA_UPD_PRC/ - & TOT_PREC_UPD, 1.E-6 ) - AREA_UPD_PRC = CNV_BETA * AREA_UPD_PRC - CUARF_dev(I) = MIN( AREA_UPD_PRC, 1.0 ) - END IF +! IF (K == LM) THEN +! if (TOT_PREC_UPD > 0.0) AREA_UPD_PRC = MAX( AREA_UPD_PRC/ +! & TOT_PREC_UPD, 1.E-6 ) +! AREA_UPD_PRC = CNV_BETA * AREA_UPD_PRC +! CUARF_dev(I) = MIN( AREA_UPD_PRC, 1.0 ) +! END IF - CALL MICRO_AA_BB_3 (TEMP,PP_dev(I,K),QST3_dev(I,K),AA3,BB3) +! CALL MICRO_AA_BB_3 (TEMP,PP_dev(I,K),QST3_dev(I,K),AA3,BB3) - QTMP1 = QLW_LS_dev(I,K) + QLW_AN_dev(I,K) - QTMP2 = QIW_LS_dev(I,K) + QIW_AN_dev(I,K) - QTOT = QTMP1 + QTMP2 +! QTMP1 = QLW_LS_dev(I,K) + QLW_AN_dev(I,K) +! QTMP2 = QIW_LS_dev(I,K) + QIW_AN_dev(I,K) +! QTOT = QTMP1 + QTMP2 - call PRECIP3 (K, LM, DT, FRLAND_dev(I), RHCRIT, QRN_CU_1D, - & QSN_CU, QTMP1, QTMP2, TEMP, Q_dev(I,K), mass, - & imass, PP_dev(I,K), DZET_dev(I,K), - & QDDF3_dev(I,K), AA3,BB3,AREA_UPD_PRC_tolayer, - & PRECU_dev(I), SNRCU_dev(I), PRN_CU_above, - & PSN_CU_above, EVAP_DD_CU_above, - & SUBL_DD_CU_above, REV_CN_dev(I,K), - & RSU_CN_dev(I,K), ACLL_CN_dev(I,K), - & ACIL_CN_dev(I,K), PFL_CN_dev(I,K), - & PFI_CN_dev(I,K), VFALLRN, VFALLSN, - & FRZ_PP_dev(I,K), CNVENVFC, CNVDDRFC, - & ANVFRC_dev(I,k), CLDFRC_dev(I,k), - & PP_dev(I,KCBL(I)),i) - - VFALLSN_CN_dev(I,K) = VFALLSN - VFALLRN_CN_dev(I,K) = VFALLRN - - if (.not. use_autoconv_timescale) then - if (VFALLSN .NE. 0.) then - QSN_ALL = QSN_ALL + PFI_CN_dev(I,K)/VFALLSN - end if - if (VFALLRN .NE. 0.) then - QRN_ALL = QRN_ALL + PFL_CN_dev(I,K)/VFALLRN - end if - end if +! call PRECIP3 (K, LM, DT, FRLAND_dev(I), RHCRIT, QRN_CU_1D, +! & QSN_CU, QTMP1, QTMP2, TEMP, Q_dev(I,K), mass, +! & imass, PP_dev(I,K), DZET_dev(I,K), +! & QDDF3_dev(I,K), AA3,BB3,AREA_UPD_PRC_tolayer, +! & PRECU_dev(I), SNRCU_dev(I), PRN_CU_above, +! & PSN_CU_above, EVAP_DD_CU_above, +! & SUBL_DD_CU_above, REV_CN_dev(I,K), +! & RSU_CN_dev(I,K), ACLL_CN_dev(I,K), +! & ACIL_CN_dev(I,K), PFL_CN_dev(I,K), +! & PFI_CN_dev(I,K), VFALLRN, VFALLSN, +! & FRZ_PP_dev(I,K), CNVENVFC, CNVDDRFC, +! & ANVFRC_dev(I,k), CLDFRC_dev(I,k), +! & PP_dev(I,KCBL(I)),i) + +! VFALLSN_CN_dev(I,K) = VFALLSN +! VFALLRN_CN_dev(I,K) = VFALLRN + +! if (.not. use_autoconv_timescale) then +! if (VFALLSN .NE. 0.) then +! QSN_ALL = QSN_ALL + PFI_CN_dev(I,K)/VFALLSN +! end if +! if (VFALLRN .NE. 0.) then +! QRN_ALL = QRN_ALL + PFL_CN_dev(I,K)/VFALLRN +! end if +! end if -! if (.true.) then - - tx1 = QLW_LS_dev(I,K) + QLW_AN_dev(I,K) - IF (tx1 > 1.e-20 ) THEN - QTMP3 = 1.0 / tx1 - ELSE - QTMP3 = 0.0 - END IF - tx1 = QTMP1 * QTMP3 - QLW_LS_dev(I,K) = QLW_LS_dev(I,K) * tx1 - QLW_AN_dev(I,K) = QLW_AN_dev(I,K) * tx1 - NCPL_dev(I, K) = NCPL_dev(I,K) * tx1 - - tx1 = QIW_LS_dev(I,K) + QIW_AN_dev(I,K) - IF (tx1 > 1.0e-20 ) THEN - QTMP3 = 1.0 / tx1 - ELSE - QTMP3 = 0.0 - END IF - tx1 = QTMP2 * QTMP3 - QIW_LS_dev(I,K) = QIW_LS_dev(I,K) * tx1 - QIW_AN_dev(I,K) = QIW_AN_dev(I,K) * tx1 - NCPI_dev(I, K) = NCPI_dev(I,K) * tx1 - - - QTMP3 = QIW_LS_dev(I,K) + QIW_AN_dev(I,K) - & + QLW_LS_dev(I,K) + QLW_AN_dev(I,K) - - If (QTOT > 0.0) then - tx1 = QTMP3/QTOT - CLDFRC_dev(I,k) = CLDFRC_dev(I,k)*tx1 - ANVFRC_dev(I,k) = ANVFRC_dev(I,k)*tx1 - end if +!! if (.true.) then -! end if +! tx1 = QLW_LS_dev(I,K) + QLW_AN_dev(I,K) +! IF (tx1 > 1.e-20 ) THEN +! QTMP3 = 1.0 / tx1 +! ELSE +! QTMP3 = 0.0 +! END IF +! tx1 = QTMP1 * QTMP3 +! QLW_LS_dev(I,K) = QLW_LS_dev(I,K) * tx1 +! QLW_AN_dev(I,K) = QLW_AN_dev(I,K) * tx1 +! NCPL_dev(I, K) = NCPL_dev(I,K) * tx1 +! tx1 = QIW_LS_dev(I,K) + QIW_AN_dev(I,K) +! IF (tx1 > 1.0e-20 ) THEN +! QTMP3 = 1.0 / tx1 +! ELSE +! QTMP3 = 0.0 +! END IF +! tx1 = QTMP2 * QTMP3 +! QIW_LS_dev(I,K) = QIW_LS_dev(I,K) * tx1 +! QIW_AN_dev(I,K) = QIW_AN_dev(I,K) * tx1 +! NCPI_dev(I, K) = NCPI_dev(I,K) * tx1 - tx1 = (MAPL_RGAS*0.01) * temp / PP_dev(I,K) - QRAIN_CN(I,K) = QRN_ALL * tx1 - QSNOW_CN(I,K) = QSN_ALL * tx1 - QRN_CU_dev(I,K) = QRN_CU_1D +! QTMP3 = QIW_LS_dev(I,K) + QIW_AN_dev(I,K) +! & + QLW_LS_dev(I,K) + QLW_AN_dev(I,K) - TOTFRC = CLDFRC_dev(I,K) + ANVFRC_dev(I,K) +! If (QTOT > 0.0) then +! tx1 = QTMP3/QTOT +! CLDFRC_dev(I,k) = CLDFRC_dev(I,k)*tx1 +! ANVFRC_dev(I,k) = ANVFRC_dev(I,k)*tx1 +! end if - IF ( TOTFRC > 1.00 ) THEN - tx1 = 1.0 / TOTFRC - CLDFRC_dev(I,k) = CLDFRC_dev(I,k) * tx1 - ANVFRC_dev(I,k) = ANVFRC_dev(I,k) * tx1 - END IF +!! end if - TOTFRC = CLDFRC_dev(I,K) + ANVFRC_dev(I,K) - end if +! tx1 = (MAPL_RGAS*0.01) * temp / PP_dev(I,K) + +! QRAIN_CN(I,K) = QRN_ALL * tx1 +! QSNOW_CN(I,K) = QSN_ALL * tx1 +! QRN_CU_dev(I,K) = QRN_CU_1D + +! TOTFRC = CLDFRC_dev(I,K) + ANVFRC_dev(I,K) + +! IF ( TOTFRC > 1.00 ) THEN +! tx1 = 1.0 / TOTFRC +! CLDFRC_dev(I,k) = CLDFRC_dev(I,k) * tx1 +! ANVFRC_dev(I,k) = ANVFRC_dev(I,k) * tx1 +! END IF + +! TOTFRC = CLDFRC_dev(I,K) + ANVFRC_dev(I,K) + +! end if !*********************** end of if(false)******************************** - if (lprnt .and. i== ipr) write(0,*)'in macrocld1 clffrc=', - & CLDFRC_dev(I,K) ,' k=',k +! if (lprnt .and. i== ipr) write(0,*)'in macrocld1 clffrc=', +! & CLDFRC_dev(I,K) ,' k=',k CALL fix_up_clouds_2M( Q_dev(I,K) , TEMP , QLW_LS_dev(I,K), & QIW_LS_dev(I,K), CLDFRC_dev(I,K), QLW_AN_dev(I,K), & QIW_AN_dev(I,K), ANVFRC_dev(I,K), NCPL_dev(I, K), - & NCPI_dev(I, K)) + & NCPI_dev(I, K), qc_min) - if (lprnt .and. i== ipr) write(0,*)'in macrocld1 clffrc=', - & CLDFRC_dev(I,K) , ' k=',k +! if (lprnt .and. i== ipr) write(0,*)'in macrocld1 clffrc=', +! & CLDFRC_dev(I,K) , ' k=',k TH_dev(I,K) = TEMP @@ -648,119 +665,105 @@ end subroutine pdf_spread !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine fix_up_clouds_2M( QV, TE, QLC, QIC, CF, QLA, QIA, AF, - & NL, NI ) + subroutine fix_up_clouds_2M(QV, TE, QLC, QIC, CF, QLA, QIA, AF, + & NL, NI, qc_min) + real, intent(in) :: qc_min(2) real, intent(inout) :: TE,QV,QLC,CF,QLA,AF,QIC,QIA, NL, NI - real, parameter :: qmin = 1.0e-11, cfmin = 1.0e-4 - &, nmin = 1.0e-3, RL_cub = 1.0e-15 - &, RI_cub = 6.4e-14 - -! if(.false.) then -! if (AF < cfmin) then -! QV = QV + QLA + QIA -! TE = TE - ALHLbCP*QLA - ALHSbCP*QIA -! AF = 0. -! QLA = 0. -! QIA = 0. - - -! if ( CF < cfmin) then -! QV = QV + QLC + QIC -! TE = TE - ALHLbCP*QLC - ALHSbCP*QIC -! CF = 0. -! QLC = 0. -! QIC = 0. -! end if -! end if -! end if +! real, parameter :: qmin = 1.0e-8, qmini = 1.0e-7 + real, parameter :: nmin = 1.0e-3, cfmin = 1.0e-5 + &, RI_cub = 6.4e-14, RL_cub = 1.0e-15 -! Anning make some changes here -! if (AFqmin) AF=cfmin -! if(CFqmin) CF=cfmin + if (AF <= cfmin) then ! Fix if Anvil cloud fraction too small + QV = QV + QLA + QIA + TE = TE - ALHLbCP*QLA - ALHSbCP*QIA + AF = 0. + QLA = 0. + QIA = 0. + if ( CF <= cfmin) then ! Fix if LS cloud fraction too small + QV = QV + QLC + QIC + TE = TE - ALHLbCP*QLC - ALHSbCP*QIC + CF = 0. + QLC = 0. + QIC = 0. + endif + endif - if (QLC < qmin .and. QLC > 0.) then + if (QLC <= qc_min(1)) then ! LS LIQUID too small QV = QV + QLC TE = TE - ALHLbCP*QLC QLC = 0. - end if + endif - if (QIC < qmin .and. QIC > 0.) then + if (QIC <= qc_min(2)) then ! LS ICE too small QV = QV + QIC TE = TE - ALHSbCP*QIC QIC = 0. - end if - + endif - if (QLA < qmin .and. QLA > 0.) then + if (QLA <= qc_min(1)) then ! Anvil LIQUID too small QV = QV + QLA TE = TE - ALHLbCP*QLA QLA = 0. - end if + endif - if (QIA < qmin .and. QIA > 0.) then + if (QIA <= qc_min(2)) then ! Anvil ICE too small QV = QV + QIA TE = TE - ALHSbCP*QIA QIA = 0. - end if - + endif - if (QLA+QIA < qmin .and. QLA+QIA > 0.) then + if (QLA+QIA <= qc_min(1)) then ! Fix ALL cloud quants if Anvil cloud LIQUID+ICE too small QV = QV + QLA + QIA TE = TE - ALHLbCP*QLA - ALHSbCP*QIA AF = 0. QLA = 0. QIA = 0. - end if + endif - if (QLC+QIC < qmin .and. QLC+QIC > 0. ) then + if (QLC+QIC <= qc_min(1)) then ! Ditto if LS cloud LIQUID+ICE too small QV = QV + QLC + QIC TE = TE - ALHLbCP*QLC - ALHSbCP*QIC CF = 0. QLC = 0. QIC = 0. - end if + endif - if ((QLA+QLC) <= qmin) then + if (QLA+QLC <= qc_min(1)) then NL = 0.0 - end if - - if ((QIA+QIC) <= qmin) then - NI = 0.0 - end if - -! make sure N > 0 if Q >0 - if (QLA+QLC > qmin .and. NL <= nmin) then + elseif (NL <= nmin) then ! make sure NL > 0 if Q >0 NL = max((QLA+QLC)/( 1.333 * MAPL_PI *RL_cub*997.0), nmin) - end if + endif - if (QIA+QIC > qmin .and. NI <= nmin) then + if (QIA+QIC <= qc_min(2)) then + NI = 0.0 + elseif (NI <= nmin) then ! make sure NI > 0 if Q >0 NI = max((QIA+QIC)/( 1.333 * MAPL_PI *RI_cub*500.0), nmin) - end if - + endif end subroutine fix_up_clouds_2M !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine update_cld( irun, lm, DT, ALPHA, + subroutine update_cld( irun, lm, DT, ALPHA, qc_min, & PDFSHAPE, PL, QV, QCl, QAl, & QCi, QAi, TE, CF, AF, & SCICE, NI, NL) ! & SCICE, NI, NL, NCnuc) integer, intent(in) :: irun, lm, pdfshape - real, intent(in) :: DT + real, intent(in) :: DT, qc_min(2) real, intent(in), dimension(irun,lm) :: ALPHA, PL ! real, intent(in), dimension(irun,lm) :: ALPHA, PL, NCnuc real, intent(inout), dimension(irun,lm) :: te, qv, qcl, qci &, CF, QAl, QAi, AF, NI, NL, SCICE - real :: CFO, pl100, QT, DQ, QSx, DQsx, QCx, QC, QA - &, QX, QSLIQ, QSICE, CFALL, DQx, FQA +! real :: CFO, pl100, QT, DQ, QSx, DQsx, QCx, QC, QA + real :: CFO, pl100, QT, DQ, QSx, QCx, QC, QA + &, QX, QSLIQ, QSICE, CFALL, DQx, FQA, tem real :: esl, esi, esn !temp use only Anning @@ -768,87 +771,75 @@ subroutine update_cld( irun, lm, DT, ALPHA, do k=1,lm do i=1,irun - if(QV(i,k) > 1.e-6) then - pl100 = pl(i,k)*100 - QC = QCl(i,k) + QCi(i,k) - QA = QAl(i,k) + QAi(i,k) - !Anning do not let empty cloud exist - if(QC <= 0.) CF(i,k) = 0. - if(QA <= 0.) AF(i,k) = 0. - QT = QC + QA + QV(i,k) - CFALL = AF(i,k) + CF(i,k) - - if (QA+QC > 0.0) then - FQA = QA / (QA+QC) - else - FQA = 0.0 - end if + if (qv(i,k) > 1.0e-6) then + QC = QCl(i,k) + QCi(i,k) + QA = QAl(i,k) + QAi(i,k) + !Anning do not let empty cloud exist + if(QC <= 0.) CF(i,k) = 0. + if(QA <= 0.) AF(i,k) = 0. + QCx = QC + QA + QT = QCx + QV(i,k) + CFALL = AF(i,k) + CF(i,k) + !================================================ -! First find the cloud fraction that would correspond to the current -! condensate -! QSLIQ = QSATLQ( TE , PL*100.0 , DQ=DQx ) -! QSICE = QSATIC( TE , PL*100.0 , DQ=DQx ) -! call vqsatd2_water_single(TE(i,k),PL(i,k)*100.0, -! & esl,QSLIQ,DQx) -! call vqsatd2_ice_single(TE(i,k),PL(i,k)*100.0, -! & esi,QSICE,DQx) - esl = min(fpvsl(TE(i,k)),pl100) - QSLIQ = min(epsqs*esl/(pl100-omeps*esl),1.) - esi = min(fpvsi(TE(i,k)),pl100) - QSICE = min(epsqs*esi/(pl100-omeps*esi),1.) - - if ((QC+QA) > 0.0) then +! Find the cloud fraction that would correspond to the current condensate + + pl100 = pl(i,k)*100 + + if (QCx > 0.0) then + tem = 1.0 / QCx + FQA = QA *tem + esl = min(fpvsl(TE(i,k)), pl100) + QSLIQ = min(epsqs*esl/(pl100-omeps*esl), 1.) + esi = min(fpvsi(TE(i,k)), pl100) + QSICE = min(epsqs*esi/(pl100-omeps*esi), 1.) + QSx = ( (QCl(i,k)+QAl(i,k))*QSLIQ - & + (QCi(i,k)+QAi(i,k))*QSICE ) / (QC+QA) + & + (QCi(i,k)+QAi(i,k))*QSICE ) *tem else -! DQSx = DQSAT( TEo , PL , 35.0, QSAT=QSx ) -! call vqsatd2_single( TE(i,k), pl(i,k)*100., esl,QSx,DQSx) - esn = min(fpvs(TE(i,k)),pl100) - QSx = min(epsqs*esn/(pl100-omeps*esn),1.) + FQA = 0.0 + esn = min(fpvs(TE(i,k)), pl100) + QSx = min(epsqs*esn/(pl100-omeps*esn), 1.) + endif - end if +! if (TE(i,k) > T_ICE_ALL) SCICE(i,k) = 1.0 -! if (TE(i,k) > T_ICE_ALL) SCICE(i,k) = 1.0 - - QCx = QC + QA QX = QT - QSx*SCICE(i,k) - CFo = 0. + ! recalculate QX if too low and SCICE 0.0)) then - CFo = (1.0+SQRT(1.0-(QX/QCx))) - if (CFo > 1.e-6) then - CFo = min(1.0/CFo, 1.0) - DQ = 2.0*QCx/(CFo*CFo) + if (QCx > qc_min(1)) then + if (QX <= QCx) then + CFo = 1.0 / (1.0 + SQRT(1.0-QX/QCx) ) +! DQ = (Qcx+QCx) / (CFo*CFo) else - CFo = 0.0 - end if + CFo = 1.0 !Outside of distribution but still with condensate +! DQ = (QSx+QSx) * ALPHA(i,k) + endif else - if (QCx > 0.0) then - CFo = 1.0 - end if - DQ = 2.0*ALPHA(i,k)*QSx - end if + CFo = 0. + endif - CFALL = max(CFo, 0.0) - CFALL = min(CFo, 1.0) + CFALL = min(1.0, max(CFo, 0.0)) - CF(i,k) = CFALL*(1.0-FQA) - AF(i,k) = CFALL*FQA + AF(i,k) = CFALL * FQA + CF(i,k) = CFALL - AF(i,k) +! if (TE(i,k) > T_ICE_ALL) then ! don't do anything else for cirrus -! if ((TE(i,k) <= T_ICE_ALL)) cycle + call hystpdf( DT, ALPHA(i,k), PDFSHAPE, qc_min, PL(i,k) + &, QV(i,k), QCl(i,k), QAl(i,k), QCi(i,k) + &, QAi(i,k), TE(i,k), CF(i,k), AF(i,k) + &, SCICE(i,k), NI(i,k), NL(i,k)) - - call hystpdf( DT, ALPHA(i,k), PDFSHAPE, PL(i,k), QV(i,k) - &, QCl(i,k), QAl(i,k), QCi(i,k) - &, QAi(i,k), TE(i,k), CF(i,k), AF(i,k) - &, SCICE(i,k), NI(i,k), NL(i,k), i, k ) - - !Anning do not let empty cloud exist - if(QCl(i,k)+QCi(i,k) <= 0.0) CF(i,k) = 0. - if(QAl(i,k)+QAi(i,k) <= 0.0) AF(i,k) = 0. - end if +! endif + !Anning do not let empty cloud exist + if(QCl(i,k)+QCi(i,k) <= 0.0) CF(i,k) = 0.0 + if(QAl(i,k)+QAi(i,k) <= 0.0) AF(i,k) = 0.0 + else + CF(i,k) = 0.0 + AF(i,k) = 0.0 + endif enddo enddo @@ -857,66 +848,65 @@ end subroutine update_cld !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine hystpdf( DT, ALPHA, PDFSHAPE, PL, QV, QCl, QAl, - & QCi, QAi, TE, CF, AF, SCICE, NI, NL, i, k) + subroutine hystpdf( DT, ALPHA, PDFSHAPE, qc_min, PL, QV, QCl, QAl + &, QCi, QAi, TE, CF, AF, SCICE, NI, NL) +! &, QCi, QAi, TE, CF, AF, SCICE, NI, NL, i, k) - real, intent(in) :: DT,ALPHA,PL - integer, intent(in) :: pdfshape - real, intent(inout) :: TE,QV,QCl,QCi,CF,QAl,QAi,AF, NI, NL, - & SCICE + real, intent(in) :: DT, ALPHA, PL, qc_min(2) + integer, intent(in) :: pdfshape + real, intent(inout) :: TE, QV, QCl, QCi, CF, QAl, QAi, AF, + & NI, NL, SCICE - integer, parameter :: nmax=20 + integer, parameter :: nmax=10 real :: QCO, QVO, CFO, QAO, TAU real :: QT, QMX, QMN, DQ, QVtop, sigmaqt1, sigmaqt2, qsnx - real :: TEO, QSx, DQsx, QS, DQs +! real :: TEO, QSx, DQsx, QS, DQs + real :: QSx, DQSx, QS, DQs &, TEp, QSp, CFp, QVp, QCp &, TEn, QSn, CFn, QVn, QCn - real :: QCx, QVx, CFx, QAx, QC, QA, fQi, fQi_A +! real :: QCx, QVx, CFx, QAx, QC, QA, fQi, fQi_A + real :: QCx, QVx, CFx, QAx, QC, QA, fQi &, dQAi, dQAl, dQCi, dQCl - real :: QX, QSLIQ, QSICE, CFALL, DQx, FQA, pl100, tmpARR +! real :: QX, QSLIQ, QSICE, CFALL, DQx, FQA, pl100, tmpARR + real :: QX, QSLIQ, QSICE, DQx, pl100, tmpARR &, ALHX, DQCALL, esn, desdt, tc, hltalt, tterm - integer :: N, i, k - - pdfflag = PDFSHAPE - pl100 = pl*100 +! integer :: N, i, k + integer :: N QC = QCl + QCi QA = QAl + QAi - QT = QC + QA + QV - CFALL = AF + CF - FQA = 0.0 - fQi = 0.0 - tmpARR = 0.0 - QAx = 0.0 - if (QA+QC > 0.0) FQA = QA / (QA+QC) - if (QA > 0.0) fQi_A = QAi / QA - if (QT > 0.0) fQi = (QCI+QAI) / QT - if (TE < T_ICE_ALL) fQi = 1.0 - if ( AF < 1.0 ) tmpARR = 1.0 / (1.0-AF) +! QT = QC + QA + QV +! CFALL = AF + CF +! FQA = 0.0 +! fQi = 0.0 - TEo = TE +! if (QA+QC > 0.0) FQA = QA / (QA+QC) +! if (QA > 0.0) fQi_A = QAi / QA +! if (QT > 0.0) fQi = (QCI+QAI) / QT +! TEo = TE ! - fqi = 1.0 - max(0.0, min(1.0, (te-t_ice_all)*t_ice_denom)) - fqi = (max(0.0,min(1.0,fqi))) ** ICEFRPWR + if (TE <= t_ice_all) then + fqi = 1.0 + elseif (TE >= t_ice_max) then + fqi = 0.0 + else + fqi = (1.0 - (te-t_ice_all)*t_ice_denom) ** ICEFRPWR + endif -! fQi = ice_fraction( TE ) -! fQi = ice_fraction( TEn ) -! DQS = DQSAT( TE, PL, QSAT=QSx ) Anning changed to the foollowing -! DQSx = DQSAT( TE, PL, QSAT=QSx ) -! call vqsatd2_single( TE, pl*100., esn,QSx,DQSx) + pl100 = pl*100 - esn = min(fpvs(TE),pl100) - QSx = min(epsqs*esn/(pl100-omeps*esn),1.) + esn = min(fpvs(TE), pl100) + QSx = min(epsqs*esn/(pl100-omeps*esn), 1.) if (qsx < 1.0) then - tc = TE - MAPL_TICE + tc = TE - MAPL_TICE if (TE < MAPL_TICE) then hltalt = hlatv + hlatf * min(-tc*trinv,1.0) else @@ -927,25 +917,35 @@ subroutine hystpdf( DT, ALPHA, PDFSHAPE, PL, QV, QCl, QAl, & + tc*(pcf(4) + tc*pcf(5)))) else tterm = 0.0 - end if + endif desdt = hltalt*esn/(rgasv*TE*TE) + tterm*trinv dqsx = qsx*pl100*desdt/(esn*(pl100-omeps*esn)) else DQSx = 0.0 endif + if (AF < 1.0) then + tmpARR = 1.0 / (1.0-AF) + else + tmpARR = 0.0 + endif + CFx = CF*tmpARR QCx = QC*tmpARR - QVx = ( QV - QSx*AF )*tmpARR + QVx = (QV - QSx*AF) * tmpARR ! if ( AF >= 1.0 ) QVx = QSx*1.e-4 - if ( AF > 0.0 ) QAx = QA/AF + if (AF > 0.0) then + QAx = QA/AF + else + QAx = 0.0 + endif QT = QCx + QVx - TEp = TEo +! TEp = TEo QSn = QSx - TEn = TEo + TEn = TE CFn = CFx QVn = QVx QCn = QCx @@ -957,20 +957,23 @@ subroutine hystpdf( DT, ALPHA, PDFSHAPE, PL, QV, QCl, QAl, QCp = QCn CFp = CFn TEp = TEn -! fQip= fQi - if(pdfflag < 2) then + if(pdfshape < 2) then sigmaqt1 = ALPHA*QSn - sigmaqt2 = ALPHA*QSn - elseif(pdfflag == 2) then +! sigmaqt1 = ALPHA*QSn + sigmaqt2 = sigmaqt1 + elseif(pdfshape == 2) then sigmaqt1 = ALPHA*QSn - sigmaqt2 = ALPHA*QSn - elseif(pdfflag == 4) then + sigmaqt2 = sigmaqt1 + elseif(pdfshape == 4) then sigmaqt1 = max(ALPHA/sqrt(3.0), 0.001) + else + write(0,*)' Aborting : invalid pdfshape=',pdfshape + stop endif qsnx = qsn*SCICE - if (QCI >= 0.0 .and. qsn > qt) qsnx = qsn +! if (QCI >= 0.0 .and. qsn > qt) qsnx = qsn call pdffrac(PDFSHAPE,qt,sigmaqt1,sigmaqt2,qsnx,CFn) call pdfcondensate(PDFSHAPE,qt,sigmaqt1,sigmaqt2,qsnx,QCn,CFn) @@ -981,7 +984,7 @@ subroutine hystpdf( DT, ALPHA, PDFSHAPE, PL, QV, QCl, QAl, ! call Bergeron_iter (DT, PL, TEp, QT, QCi, QAi, QCl, QAl, ! & CF, AF, NL, NI, DQCALL, fQi) - if ( AF > 0. ) then + if (AF > 0.) then QAo = QAx else QAo = 0. @@ -990,43 +993,50 @@ subroutine hystpdf( DT, ALPHA, PDFSHAPE, PL, QV, QCl, QAl, ALHX = (1.0-fQi)*alhlbcp + fQi*alhsbcp - if(pdfflag == 1) then + if(pdfshape == 1) then QCn = QCp + (QCn- QCp) & / (1.0 - (CFn*(ALPHA-1.0) - QCn/QSn) *DQS*ALHX) - elseif(pdfflag == 2) then + elseif(pdfshape == 2) then if (n < nmax) QCn = QCp + ( QCn - QCp ) * 0.5 endif QVn = QVp - (QCn - QCp) TEn = TEp + ALHX * ((QCn-QCp)*(1.0-AF) + (QAo-QAx)*AF) -! fqi = 1.0 - max(0.0, min(1.0, (ten-t_ice_all)*t_ice_denom)) -! fqi = (max(0.0,min(1.0,fqi))) ** ICEFRPWR - if (abs(Ten-Tep) < 0.00001) exit -! DQS = DQSAT( TEn, PL, QSAT=QSn ) -! call vqsatd2_single( TEn, pl*100., esn,QSn,DQS) - esn = min(fpvs(TEn),pl100) - QSn = min(epsqs*esn/(pl100-omeps*esn),1.0) - - if (qsx < 1.0) then - tc = TEn - MAPL_TICE - if (TEn < MAPL_TICE) then - hltalt = hlatv + hlatf * min(-tc*trinv,1.0) - else - hltalt = hlatv - 2369.0*tc - end if - if (tc >= -ttrice .and. tc < 0.0) then - tterm = pcf(1) + tc*(pcf(2) + tc*(pcf(3) - & + tc*(pcf(4) + tc*pcf(5)))) - else - tterm = 0.0 - end if - desdt = hltalt*esn/(rgasv*TEn*TEn) + tterm*trinv - dqs = QSn*pl100*desdt/(esn*(pl100-omeps*esn)) + if (TEn <= t_ice_all) then + fqi = 1.0 + elseif (TEn >= t_ice_max) then + fqi = 0.0 else - DQS = 0.0 + fqi = (1.0 - (te-t_ice_all)*t_ice_denom) ** ICEFRPWR + endif + + DQS = 0.0 + + if (n < nmax) then + esn = min(fpvs(TEn), pl100) + QSn = min(epsqs*esn/(pl100-omeps*esn), 1.0) + + if (qsn < 1.0) then + tc = TEn - MAPL_TICE + if (TEn < MAPL_TICE) then + hltalt = hlatv + hlatf * min(-tc*trinv,1.0) + else + hltalt = hlatv - 2369.0*tc + end if + if (tc >= -ttrice .and. tc < 0.0) then + tterm = pcf(1) + tc*(pcf(2) + tc*(pcf(3) + & + tc*(pcf(4) + tc*pcf(5)))) + else + tterm = 0.0 + end if + desdt = hltalt*esn/(rgasv*TEn*TEn) + tterm*trinv + dqs = QSn*pl100*desdt / (esn*(pl100-omeps*esn)) +! else +! DQS = 0.0 + endif endif enddo @@ -1038,17 +1048,26 @@ subroutine hystpdf( DT, ALPHA, PDFSHAPE, PL, QV, QCl, QAl, ! TEo = TEn ! TE = TEn - if ( AF < 1.0 ) then - CF = CFo * ( 1.0-AF) - QCo = QCo * ( 1.0-AF) +! Update prognostic variables. Deal with special case of AF=1 +! Temporary variables QCo, QAo become updated grid means. + + if (AF < 1.0) then + CF = CFo * (1.0-AF) + QCo = QCo * (1.0-AF) QAo = QAo * AF else - CF = 0.0 - QAo = QA + QC - QCo = 0.0 - QT = QAo + QV - QAo = MAX(QT-QSx, 0.0) - end if +! Special case AF=1, i.e., box filled with anvil. +! - Note: no guarantee QV_box > QS_box + + CF = 0. ! Remove any other cloud + QAo = QA + QC ! Add any LS condensate to anvil type + QCo = 0. ! Remove same from LS + QT = QAo + QV ! Total water + +! Now set anvil condensate to any excess of total water +! over QSx (saturation value at top) + QAo = MAX(QT-QSx, 0.) + endif dQCl = 0.0 dQCi = 0.0 @@ -1059,7 +1078,7 @@ subroutine hystpdf( DT, ALPHA, PDFSHAPE, PL, QV, QCl, QAl, QCx = QCo - QC ! Anning Cheng prevented unstable here - if (QCx < -1.e-3) QCx = -1.e-3 +! if (QCx < -1.e-3) QCx = -1.e-3 if (QCx < 0.0) then dQCl = max(QCx, -QCl) dQCi = max(QCx-dQCl, -QCi) @@ -1071,7 +1090,7 @@ subroutine hystpdf( DT, ALPHA, PDFSHAPE, PL, QV, QCl, QAl, !Anvil QAx is not in anvil QAx = QAo - QA ! Anning Cheng prevented unstable here - if(QAx < -1.e-3) QAx = -1.e-3 +! if(QAx < -1.e-3) QAx = -1.e-3 if (QAx < 0.0) then dQAl = max(QAx, -QAl) @@ -1082,14 +1101,16 @@ subroutine hystpdf( DT, ALPHA, PDFSHAPE, PL, QV, QCl, QAl, end if ! if(.false.) then !Anning turn it off causing unstable -! if ( AF < 1.e-5 ) then -! dQAi = -QAi -! dQAl = -QAl -! end if -! if ( CF < 1.e-5 ) then -! dQCi = -QCi -! dQCl = -QCl -! end if + if ( AF < 1.e-5 ) then + dQAi = -QAi + dQAl = -QAl + af = 0.0 + end if + if ( CF < 1.e-5 ) then + dQCi = -QCi + dQCl = -QCl + cf = 0.0 + end if ! end if QAi = QAi + dQAi @@ -1112,7 +1133,8 @@ subroutine hystpdf( DT, ALPHA, PDFSHAPE, PL, QV, QCl, QAl, AF = 0. end if - CALL fix_up_clouds_2M(QV, TE, QCl, QCi, CF, QAl, QAi, AF, NL, NI) + CALL fix_up_clouds_2M(QV, TE, QCl, QCi, CF, QAl, QAi, AF, NL, NI + &, qc_min) end subroutine hystpdf @@ -2030,11 +2052,12 @@ end subroutine Bergeron_iter subroutine Pfreezing ( ALPHA , PL , TE , QV , QCl , QAl , QCi , - & QAi , SC_ICE , CF , AF , PF ) + & QAi , SC_ICE , CF , AF , PF, pdfflag) - real , intent(in) :: PL,ALPHA, QV, SC_ICE, AF, TE, QCl, QCi, QAl, - & QAi, CF - real , intent(out) :: PF + integer, intent(in) :: pdfflag + real , intent(in) :: PL, ALPHA, QV, SC_ICE, AF, TE, + & QCl, QCi, QAl, QAi, CF + real , intent(out) :: PF real :: qt, QCx, QSn, tmpARR, CFALL, QVx, CFio, QA, QAx, QC, QI, & QL, DQSx, sigmaqt1, sigmaqt2, qsnx, esl, esi,pl100 @@ -2083,6 +2106,9 @@ subroutine Pfreezing ( ALPHA , PL , TE , QV , QCl , QAl , QCi , sigmaqt2 = ALPHA * QSn elseif(pdfflag == 4) then sigmaqt1 = max(ALPHA/sqrt(3.0), 0.001) + else + write(0,*)' Aborting : invalid pdfflag=',pdfflag + stop endif call pdffrac(pdfflag,qt,sigmaqt1,sigmaqt2,qsn,CFio) diff --git a/gfsphysics/physics/cldwat2m_micro.F b/gfsphysics/physics/cldwat2m_micro.F index 4f5f2d92c..56aa06a18 100644 --- a/gfsphysics/physics/cldwat2m_micro.F +++ b/gfsphysics/physics/cldwat2m_micro.F @@ -18,7 +18,8 @@ module cldwat2m_micro use physcons, gravit => con_g, rair => con_rd, & & rh2o => con_rv, epsilon => con_eps, & & tmelt => con_tice, cpair => con_cp, & - & latvap => con_hvap, latice => con_hfus + & latvap => con_hvap, latice => con_hfus, & + & pi => con_pi use wv_saturation, only : estblf, hlatv, tmin, hlatf, rgasv, pcf,& & epsqs, ttrice, vqsatd2,cp, & & vqsatd2_single,polysvp,gestbl @@ -145,7 +146,7 @@ module cldwat2m_micro real(r8), private:: mi0 real(r8), private:: rin real(r8), private:: qcvar - real(r8), private:: pi +! real(r8), private:: pi ! Additional constants to help speed up code @@ -342,7 +343,7 @@ subroutine ini_micro(Dcs_, QCVAR_, ts_auto_ice_) ! pi= 3.1415927_r8 ! pi= 3.1415926535897931_r8 - pi = four*atan(one) +! pi = four*atan(one) pirhow = pi * rhow pirhosn = pi * rhosn diff --git a/gfsphysics/physics/cs_conv.f90 b/gfsphysics/physics/cs_conv.f90 index 6a0335ec2..bd7ef287a 100644 --- a/gfsphysics/physics/cs_conv.f90 +++ b/gfsphysics/physics/cs_conv.f90 @@ -32,6 +32,12 @@ module cs_conv ! operates - 0 - no convection 1 - with convection ! Jan 30 2018 : S, Moorthi - fixed sigmad dimension error in CUMDWN and an error when adjustp=.true. ! +! May -- 2018 : S. Moorthi - modified cumup to compute total workfunction (positive plus negative) +! and negative part only and to let a particular ensemble exist only if +! the ratio of negative to total is less than some prescribed percent. +! Also, added an extra iteration in this k loop. Reduced some memory. +! June 2018 : S. Moorthi - the output mass fluxes ud_mf, dd_mf and dt_mf are over time step delta +! ! Arakawa-Wu implemtation: for background, consult An Introduction to the ! General Circulation of the Atmosphere, Randall, chapter six. ! Traditional parameterizations compute tendencies like those in eq 103, 105 and 106. @@ -75,13 +81,16 @@ module cs_conv ! Tuning parameters set from namelist ! -! real(r8), save, public :: CLMD = 0.6, & ! entrainment efficiency - real(r8), parameter, public :: CLMD = 0.7, & ! entrainment efficiency +! real(r8), parameter, public :: CLMD = 0.60, & ! entrainment efficiency (now thru argument) + real(r8), parameter, public :: & PA=0.15, & ! factor for buoyancy to affect updraft velocity CPRES = 0.55, & ! pressure factor for momentum transport - ALP0 = 8.0e7, & ! alpha parameter in prognostic closure - CLMP = (one-CLMD)*(PA+PA), & - spblcrit=0.05, & ! minimum cloudbase height in p/ps + ALP0 = 5.0e7, & ! alpha parameter in prognostic closure +! ALP0 = 8.0e7, & ! alpha parameter in prognostic closure +! CLMP = (one-CLMD)*(PA+PA), & +! CLMDPA = CLMD*PA, & + spblmin=0.05, & ! minimum cloudbase height in p/ps + spblmax=0.30, & ! maximum cloudbase height in p/ps ! spblcrit=0.03, & ! minimum cloudbase height in p/ps ! spblcrit=0.035,& ! minimum cloudbase height in p/ps ! spblcrit=0.025,& ! minimum cloudbase height in p/ps @@ -92,7 +101,7 @@ module cs_conv !DD precz0 and preczh control partitioning of water between detrainment !DD and precipitation. Decrease for more precip - real(r8), public :: precz0, preczh + real(r8), public :: precz0, preczh, clmd, clmp, clmdpa ! ! Private data ! @@ -130,10 +139,11 @@ subroutine cs_convr(IM , IJSDIM , KMAX , NTR , nctp, & !DD dime delta , delti , ud_mf , dd_mf , dt_mf, & u , v , fscav , fswtr, & cbmfx , mype , wcbmaxm , precz0in, preczhin, & - sigma , do_aw , do_awdd, flx_form, & + clmdin , sigma , do_aw , do_awdd , flx_form, & lprnt , ipr, kcnv, & -! for coupling to Morrison microphysics - QLCN, QICN, w_upi, cf_upi, CNV_MFD, CNV_PRC3, & +! for coupling to MG microphysics + QLCN, QICN, w_upi, cf_upi, CNV_MFD, & +! QLCN, QICN, w_upi, cf_upi, CNV_MFD, CNV_PRC3, & CNV_DQLDT,CLCN,CNV_FICE,CNV_NDROP,CNV_NICE,mp_phys) !--------------------------------------------------------------------------------- @@ -163,7 +173,7 @@ subroutine cs_convr(IM , IJSDIM , KMAX , NTR , nctp, & !DD dime real(r8), intent(in) :: zm(IM,KMAX) ! geopotential at mid-layer (m) real(r8), intent(in) :: zi(IM,KMAX+1) ! geopotential at boundaries (m) real(r8), intent(in) :: fscav(ntr), fswtr(ntr), wcbmaxm(ijsdim) - real(r8), intent(in) :: precz0in, preczhin + real(r8), intent(in) :: precz0in, preczhin, clmdin ! added for cs_convr real(r8), intent(inout) :: u(IM,KMAX) ! zonal wind at mid-layer (m/s) real(r8), intent(inout) :: v(IM,KMAX) ! meridional wind at mid-layer (m/s) @@ -182,7 +192,8 @@ subroutine cs_convr(IM , IJSDIM , KMAX , NTR , nctp, & !DD dime real(r8), intent(inout), dimension(IJSDIM,KMAX) :: ud_mf, dd_mf, dt_mf real(r8), intent(out) :: prec(IJSDIM) ! precipitation at surface (including snowfall) (kg/m2/s) - real(r8), intent(out), dimension(ijsdim,kmax) :: qlcn, qicn, w_upi,cnv_mfd, cnv_prc3,& + real(r8), intent(out), dimension(ijsdim,kmax) :: qlcn, qicn, w_upi,cnv_mfd, & +! real(r8), intent(out), dimension(ijsdim,kmax) :: qlcn, qicn, w_upi,cnv_mfd, cnv_prc3,& cnv_dqldt, clcn, cnv_fice, & cnv_ndrop, cnv_nice, cf_upi integer, intent(inout) :: kcnv(im) ! zero if no deep convection and 1 otherwise @@ -245,6 +256,9 @@ subroutine cs_convr(IM , IJSDIM , KMAX , NTR , nctp, & !DD dime precz0 = precz0in preczh = preczhin + clmd = clmdin + CLMP = (one-CLMD)*(PA+PA) + CLMDPA = CLMD*PA ! if (first) then do i=1,ntr @@ -309,6 +323,7 @@ subroutine cs_convr(IM , IJSDIM , KMAX , NTR , nctp, & !DD dime enddo enddo enddo +! if (lprnt) write(0,*)' incs tke=',gdq(ipr,1:25,ntr) ! !*************************************************************************************** ! @@ -358,7 +373,7 @@ subroutine cs_convr(IM , IJSDIM , KMAX , NTR , nctp, & !DD dime DELTA , DELTI , ISTS , IENS, mype,& ! input fscav, fswtr, wcbmaxm, nctp, & sigma, vverti, & ! input/output !DDsigma - do_aw, do_awdd,flx_form) + do_aw, do_awdd, flx_form) ! ! !DD detrainment has to be added in for GFS @@ -366,6 +381,7 @@ subroutine cs_convr(IM , IJSDIM , KMAX , NTR , nctp, & !DD dime ! if (lprnt) write(0,*)' aft cs_cum gtqi=',gtq(ipr,:,2) ! if (lprnt) write(0,*)' aft cs_cum gtql=',gtq(ipr,:,3) + do n=2,NTR do k=1,KMAX do i=1,IJSDIM @@ -373,6 +389,8 @@ subroutine cs_convr(IM , IJSDIM , KMAX , NTR , nctp, & !DD dime enddo enddo enddo +! if (lprnt) write(0,*)' aftcs_cum tkein=',gdq(ipr,1:25,ntr),' delta=',delta +! if (lprnt) write(0,*)' aftcs_cum tke=',clw(ipr,1:25,ntr-1) ! if (lprnt) write(0,*)'in cs clw1a=',clw(ipr,:,1),' kdt=',kdt ! if (lprnt) write(0,*)'in cs clw2a=',clw(ipr,:,2),' kdt=',kdt ! @@ -402,9 +420,10 @@ subroutine cs_convr(IM , IJSDIM , KMAX , NTR , nctp, & !DD dime cnv_fice(i,k) = 0.0 endif ! - CNV_MFD(i,k) = dt_mf(i,k) * (1.0/delta) - CNV_DQLDT(i,k) = tem / delta - CNV_PRC3(i,k) = 0.0 +! CNV_MFD(i,k) = dt_mf(i,k) * (1.0/delta) + CNV_MFD(i,k) = dt_mf(i,k) + CNV_DQLDT(i,k) = wrk / delta +! CNV_PRC3(i,k) = 0.0 CNV_NDROP(i,k) = 0.0 CNV_NICE(i,k) = 0.0 cf_upi(i,k) = max(0.0, min(1.0, 0.5*(sigma(i,k)+sigma(i,kp1)))) @@ -435,17 +454,18 @@ subroutine cs_convr(IM , IJSDIM , KMAX , NTR , nctp, & !DD dime qlcn(i,k) = max(0.0, clw(i,k,2)-gdq(i,k,3)) cnv_fice(i,k) = qicn(i,k) / max(1.0e-10,qicn(i,k)+qlcn(i,k)) ! - CNV_MFD(i,k) = dt_mf(i,k) * (1/delta) +! CNV_MFD(i,k) = dt_mf(i,k) * (1/delta) + CNV_MFD(i,k) = dt_mf(i,k) CNV_DQLDT(i,k) = (qicn(i,k)+qlcn(i,k)) / delta - CNV_PRC3(i,k) = 0.0 +! CNV_PRC3(i,k) = 0.0 CNV_NDROP(i,k) = 0.0 CNV_NICE(i,k) = 0.0 - cf_upi(i,k) = max(0.0,min(0.01*log(1.0+500*ud_mf(i,k)/delta),0.25)) -! & 500*ud_mf(i,k)/delta),0.60)) + cf_upi(i,k) = max(0.0,min(0.01*log(1.0+500*ud_mf(i,k)),0.25)) +! & 500*ud_mf(i,k)),0.60)) CLCN(i,k) = cf_upi(i,k) !downdraft is below updraft w_upi(i,k) = ud_mf(i,k)*(t(i,k)+epsvt*gdq(i,k,1)) * rair & - / (delta*max(cf_upi(i,k),1.e-12)*gdp(i,k)) + / (max(cf_upi(i,k),1.e-12)*gdp(i,k)) enddo enddo endif @@ -469,6 +489,17 @@ subroutine cs_convr(IM , IJSDIM , KMAX , NTR , nctp, & !DD dime kcnv(i) = 0 endif enddo + +! multiplying mass fluxes by the time step + + do k=1,kmax + do i=1,ijsdim + ud_mf(i,k) = ud_mf(i,k) * delta + dd_mf(i,k) = dd_mf(i,k) * delta + dt_mf(i,k) = dt_mf(i,k) * delta + enddo + enddo + ! if (lprnt) then ! write(0,*)' aft cs_cum prec=',prec(ipr),'GTPRP=',GTPRP(ipr,1) ! endif @@ -585,15 +616,16 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions real(r8), intent(in) :: fscav(ntr), fswtr(ntr), wcbmaxm(ijsdim) ! ! [INTERNAL WORK] - REAL(r8) GPRCC (IJSDIM, NTR) ! rainfall - REAL(r8) GSNWC (IJSDIM) ! snowfall - REAL(r8) CUMCLW(IJSDIM, KMAX) ! cloud water in cumulus - REAL(r8) CUMFRC(IJSDIM) ! cumulus cloud fraction + REAL(r8), allocatable :: GPRCC (:, :) ! rainfall +! REAL(r8) GPRCC (IJSDIM, NTR) ! rainfall +! REAL(r8) GSNWC (IJSDIM) ! snowfall +! REAL(r8) CUMCLW(IJSDIM, KMAX) ! cloud water in cumulus +! REAL(r8) CUMFRC(IJSDIM) ! cumulus cloud fraction ! - REAL(r8) GTCFRC(IJSDIM, KMAX) ! change in cloud fraction - REAL(r8) FLIQC (IJSDIM, KMAX) ! liquid ratio in cumulus +! REAL(r8) GTCFRC(IJSDIM, KMAX) ! change in cloud fraction +! REAL(r8) FLIQC (IJSDIM, KMAX) ! liquid ratio in cumulus ! - REAL(r8) GDCFRC(IJSDIM, KMAX) ! cloud fraction +! REAL(r8) GDCFRC(IJSDIM, KMAX) ! cloud fraction ! REAL(r8) GDW (IJSDIM, KMAX) ! total water REAL(r8) DELP (IJSDIM, KMAX) @@ -661,8 +693,8 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions ! REAL(r8) TIMED REAL(r8) GDCLDX, GDMU2X, GDMU3X ! - REAL(r8) HBGT (IJSDIM) ! imbalance in column heat - REAL(r8) WBGT (IJSDIM) ! imbalance in column water +! REAL(r8) HBGT (IJSDIM) ! imbalance in column heat +! REAL(r8) WBGT (IJSDIM) ! imbalance in column water !DDsigma begin local work variables - all on model interfaces (sfc=1) REAL(r8) lamdai ! lamda for cloud type ctp @@ -765,13 +797,13 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions gsnwi(i,k) = zero qliq(i,k) = zero qice(i,k) = zero - gtcfrc(i,k) = zero - cumclw(i,k) = zero - fliqc(i,k) = zero +! gtcfrc(i,k) = zero +! cumclw(i,k) = zero +! fliqc(i,k) = zero sigma(i,k) = zero enddo enddo - if (do_aw .and. flx_form) then + if (flx_form) then allocate(sfluxterm(ijsdim,kmax), qvfluxterm(ijsdim,kmax), qlfluxterm(ijsdim,kmax), & qifluxterm(ijsdim,kmax), condtermt(ijsdim,kmax), condtermq(ijsdim,kmax), & frzterm(ijsdim,kmax), prectermq(ijsdim,kmax), prectermfrz(ijsdim,kmax), & @@ -806,10 +838,10 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions enddo endif do i=1,ijsdim - gprcc(i,:) = zero +! gprcc(i,:) = zero gtprc0(i) = zero - hbgt(i) = zero - wbgt(i) = zero +! hbgt(i) = zero +! wbgt(i) = zero gdztr(i) = zero kstrt(i) = kmax enddo @@ -823,7 +855,7 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions DO K=1,KMAX DO I=ISTS,IENS esat = min(gdp(i,k), fpvs(gdt(i,k))) - GDQS(I,K) = min(EPSV*esat/max(gdp(i,k)+epsvm1*esat, 1.0e-10), 1.0) + GDQS(I,K) = min(EPSV*esat/max(gdp(i,k)+epsvm1*esat, 1.0e-10), 0.1) tem = one / GDT(I,K) FDQS(I,K) = GDQS(I,K) * tem * (fact1 + fact2*tem) ! calculate d(qs)/dT GAM (I,K) = ELOCP*FDQS(I,K) @@ -899,11 +931,6 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions do k=1,kmax ! Moorthi do i=1,ijsdim lamdaprod(i,k) = one - dqcondtem(i,k) = zero - dqprectem(i,k) = zero - dfrzprectem(i,k) = zero - dtfrztem(i,k) = zero - dtcondtem(i,k) = zero enddo enddo @@ -923,6 +950,15 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions WCBX(I) = DELWC * DELWC enddo + do k=1,kmax ! Moorthi + do i=1,ijsdim + dqcondtem(i,k) = zero + dqprectem(i,k) = zero + dfrzprectem(i,k) = zero + dtfrztem(i,k) = zero + dtcondtem(i,k) = zero + enddo + enddo ! getting more incloud profiles of variables to compute eddy flux tendencies ! and condensation rates @@ -945,8 +981,8 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions GDPM , FDQS , GAM , GDZTR , & ! input CPRES , WCBX , & ! input KB , CTP , ISTS , IENS , & ! input - gctm, gcqm, gcwm, gchm, gcwt, gclm, gcim,gctrm, & ! additional incloud profiles and cloud top total water - lprnt, ipr ) + gctm , gcqm, gcwm, gchm, gcwt, gclm, gcim, gctrm, & ! additional incloud profiles and cloud top total water + lprnt , ipr ) ! !! CUMBMX computes Cloud Base Mass Flux @@ -960,41 +996,42 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions !DDsigma - begin sigma computation ! At this point cbmfx is updated and we have everything we need to compute sigma - if (do_aw) then - do i=ISTS,IENS - if (flx_form) then + do i=ISTS,IENS + if (flx_form) then ! initialize eddy fluxes for cloud type ctp + do k=1,kmax+1 + sfluxtem(k) = zero + qvfluxtem(k) = zero + qlfluxtem(k) = zero + qifluxtem(k) = zero + enddo + do n=ntrq,ntr ! tracers do k=1,kmax+1 - sfluxtem(k) = zero - qvfluxtem(k) = zero - qlfluxtem(k) = zero - qifluxtem(k) = zero + trfluxtem(k,n) = zero enddo - do n=ntrq,ntr ! tracers - do k=1,kmax+1 - trfluxtem(k,n) = zero - enddo - enddo - endif + enddo + endif - cbmfl = cbmfx(i,ctp) - kk = kt(i,ctp) ! cloud top index + cbmfl = cbmfx(i,ctp) + kk = kt(i,ctp) ! cloud top index - if(cbmfl > zero) then ! this should avoid zero wcv in the denominator - kbi = kb(i) ! cloud base index - do k=kbi,kk ! loop from cloud base to cloud top - km1 = k - 1 - rhs_h = zero - rhs_q = zero + if(cbmfl > zero) then ! this should avoid zero wcv in the denominator + kbi = kb(i) ! cloud base index + do k=kbi,kk ! loop from cloud base to cloud top + km1 = k - 1 + rhs_h = zero + rhs_q = zero ! get environment variables interpolated to layer interface - GDQM = half * (GDQ(I,K,1) + GDQ(I,KM1,1)) ! as computed in cumup -! GDwM = half * (GDw(I,K) + GDw(I,KM1 )) - GDlM = half * (GDQ(I,K,3) + GDQ(I,KM1,3)) - GDiM = half * (GDQ(I,K,2) + GDQ(I,KM1,2)) - do n = ntrq,NTR - GDtrM(n) = half * (GDQ(I,K,n) + GDQ(I,KM1,n)) ! as computed in cumup - enddo - mflx_e = gcym(i,k,ctp) * cbmfl ! mass flux at level k for cloud ctp + GDQM = half * (GDQ(I,K,1) + GDQ(I,KM1,1)) ! as computed in cumup +! GDwM = half * (GDw(I,K) + GDw(I,KM1 )) + GDlM = half * (GDQ(I,K,3) + GDQ(I,KM1,3)) + GDiM = half * (GDQ(I,K,2) + GDQ(I,KM1,2)) + do n = ntrq,NTR + GDtrM(n) = half * (GDQ(I,K,n) + GDQ(I,KM1,n)) ! as computed in cumup + enddo + mflx_e = gcym(i,k,ctp) * cbmfl ! mass flux at level k for cloud ctp + + if (do_aw) then ! this is the computation of lamda for a cloud type, and then updraft area fraction ! (sigmai for a single cloud type) @@ -1010,105 +1047,119 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions sigmai = lamdai / lamdaprod(i,k) sigma(i,k) = max(zero, min(one, sigma(i,k) + sigmai)) vverti(i,k,ctp) = sigmai * wcv(i,k) + else + sigma(i,k) = 0.0 + endif - if (flx_form) then + if (flx_form) then -! fsigma = 1.0 ! no aw effect, comment following lines to undo AW - fsigma = one - sigma(i,k) +! fsigma = 1.0 ! no aw effect, comment following lines to undo AW + fsigma = one - sigma(i,k) ! compute tendencies based on mass flux, and tendencies based on condensation ! fsigma is the AW reduction of flux tendencies - if(k == kbi) then - do l=2,kbi ! compute eddy fluxes below cloud base - tem = - fsigma * gcym(i,l,ctp) * cbmfl + if(k == kbi) then + do l=2,kbi ! compute eddy fluxes below cloud base + tem = - fsigma * gcym(i,l,ctp) * cbmfl ! first get environment variables at layer interface - l1 = l - 1 - GDQM = half * (GDQ(I,l,1) + GDQ(I,l1,1)) - GDlM = half * (GDQ(I,l,3) + GDQ(I,l1,3)) - GDiM = half * (GDQ(I,l,2) + GDQ(I,l1,2)) -!! GDwM = half * (GDw(I,l) + GDw(I,l1)) - do n = ntrq,NTR - GDtrM(n) = half * (GDQ(I,l,n) + GDQ(I,l1,n)) ! as computed in cumup - enddo + l1 = l - 1 + GDQM = half * (GDQ(I,l,1) + GDQ(I,l1,1)) + GDlM = half * (GDQ(I,l,3) + GDQ(I,l1,3)) + GDiM = half * (GDQ(I,l,2) + GDQ(I,l1,2)) +!! GDwM = half * (GDw(I,l) + GDw(I,l1)) + do n = ntrq,NTR + GDtrM(n) = half * (GDQ(I,l,n) + GDQ(I,l1,n)) ! as computed in cumup + enddo ! flux = mass flux * (updraft variable minus environment variable) !centered differences - sfluxtem(l) = tem * (gdtm(i,l)-gctbl(i,l)) - qvfluxtem(l) = tem * (gdqm-gcqbl(i,l)) - qlfluxtem(l) = tem * (gdlm-gcqlbl(i,l)) - qifluxtem(l) = tem * (gdim-gcqibl(i,l)) - do n = ntrq,NTR - trfluxtem(l,n) = tem * (gdtrm(n)-gctrbl(i,l,n)) - enddo + sfluxtem(l) = tem * (gdtm(i,l)-gctbl(i,l)) + qvfluxtem(l) = tem * (gdqm-gcqbl(i,l)) + qlfluxtem(l) = tem * (gdlm-gcqlbl(i,l)) + qifluxtem(l) = tem * (gdim-gcqibl(i,l)) + do n = ntrq,NTR + trfluxtem(l,n) = tem * (gdtrm(n)-gctrbl(i,l,n)) + enddo +! if(lprnt .and. i == ipr) write(0,*)' l=',l,' kbi=',kbi,' tem =', tem,' trfluxtem=',trfluxtem(l,ntr),& +! ' gdtrm=',gdtrm(ntr),' gctrbl=',gctrbl(i,l,ntr),' gq=',GDQ(I,l,ntr),GDQ(I,l1,ntr),' l1=',l1,' ctp=',ctp,& +! ' fsigma=',fsigma,' gcym=',gcym(i,l,ctp),' cbmfl=',cbmfl,' sigma=',sigma(i,k) ! The following commented out by Moorthi on April 13, 2018 because tke below ! cloud base becomes too large otherwise when shoc is used !upstream - This better matches what the original CS tendencies do -! sfluxtem(l) = tem * (gdt(i,l)+gocp*(gdz(i,l)-gdzm(i,l))-gctbl(i,l)) -! qvfluxtem(l) = tem * (gdq(i,l,1)-gcqbl(i,l)) -! qlfluxtem(l) = tem * (gdq(i,l,3)-gcqlbl(i,l)) -! qifluxtem(l) = tem * (gdq(i,l,2)-gcqibl(i,l)) -! do n = ntrq,NTR -! trfluxtem(l,n) = tem * (gdq(i,l,n)-gctrbl(i,l,n)) -! enddo - - enddo - else +! sfluxtem(l) = tem * (gdt(i,l)+gocp*(gdz(i,l)-gdzm(i,l))-gctbl(i,l)) +! qvfluxtem(l) = tem * (gdq(i,l,1)-gcqbl(i,l)) +! qlfluxtem(l) = tem * (gdq(i,l,3)-gcqlbl(i,l)) +! qifluxtem(l) = tem * (gdq(i,l,2)-gcqibl(i,l)) +! do n = ntrq,NTR +! trfluxtem(l,n) = tem * (gdq(i,l,n)-gctrbl(i,l,n)) +! enddo + + enddo + else ! flux = mass flux * (updraft variable minus environment variable) - tem = - fsigma * mflx_e + tem = - fsigma * mflx_e !centered + sfluxtem(k) = tem * (gdtm(i,k)+gocp*gdzm(i,k)-gctm(i,k)) + qvfluxtem(k) = tem * (gdqm-gcqm(i,k)) + qlfluxtem(k) = tem * (gdlm-gclm(i,k)) + qifluxtem(k) = tem * (gdim-gcim(i,k)) + do n = ntrq,NTR + trfluxtem(k,n) = tem * (gdtrm(n)-gctrm(i,k,n)) + enddo + +!upstream - This better matches what the original CS tendencies do +! if(k < kk) then +! sfluxtem(k) = tem * (gdt(i,k)+gocp*gdz(i,k)-gctm(i,k)) +! qvfluxtem(k) = tem * (gdq(i,k,1)-gcqm(i,k)) +! qlfluxtem(k) = tem * (gdq(i,k,3)-gclm(i,k)) +! qifluxtem(k) = tem * (gdq(i,k,2)-gcim(i,k)) +! do n = ntrq,NTR +! trfluxtem(k,n) = tem * (gdq(i,k,n)-gctrm(i,k,n)) +! enddo +! if(lprnt .and. i == ipr) write(0,*)' k=',k,' kbi=',kbi,' tem =', tem,' kk=',kk,& +! ' gctrm=',gctrm(i,k,ntr),' gdq=',gdq(I,k,ntr),' gctrm=',gctrm(I,k,ntr),' ctp=',ctp,& +! ' fsigma=',fsigma,' mflx_e=',mflx_e,' trfluxtemk=',trfluxtem(k,ntr),' sigma=',sigma(i,k) + +! else +! centered at top of cloud ! sfluxtem(k) = tem * (gdtm(i,k)+gocp*gdzm(i,k)-gctm(i,k)) ! qvfluxtem(k) = tem * (gdqm-gcqm(i,k)) ! qlfluxtem(k) = tem * (gdlm-gclm(i,k)) ! qifluxtem(k) = tem * (gdim-gcim(i,k)) -! do n = ntrq,NTR -! trfluxtem(k,n) = tem * (gdtrm(n)-gctrm(i,k,n)) -! enddo +! do n = ntrq,NTR +! trfluxtem(k,n) = tem * (gdtrm(n)-gctrm(i,k,n)) +! enddo +! endif -!upstream - This better matches what the original CS tendencies do - if(k < kk) then - sfluxtem(k) = tem * (gdt(i,k)+gocp*gdz(i,k)-gctm(i,k)) - qvfluxtem(k) = tem * (gdq(i,k,1)-gcqm(i,k)) - qlfluxtem(k) = tem * (gdq(i,k,3)-gclm(i,k)) - qifluxtem(k) = tem * (gdq(i,k,2)-gcim(i,k)) - do n = ntrq,NTR - trfluxtem(k,n) = tem * (gdq(i,k,n)-gctrm(i,k,n)) - enddo - else -! centered at top of cloud - sfluxtem(k) = tem * (gdtm(i,k)+gocp*gdzm(i,k)-gctm(i,k)) - qvfluxtem(k) = tem * (gdqm-gcqm(i,k)) - qlfluxtem(k) = tem * (gdlm-gclm(i,k)) - qifluxtem(k) = tem * (gdim-gcim(i,k)) - do n = ntrq,NTR - trfluxtem(k,n) = tem * (gdtrm(n)-gctrm(i,k,n)) - enddo - endif +! if(lprnt .and. i == ipr) write(0,*)' k=',k,' kbi=',kbi,' tem =', tem,' kk=',kk,& +! ' gctrm=',gctrm(i,k,ntr),' gdtrm=',gdtrm(ntr),' gctrm=',gctrm(I,k,ntr),' ctp=',ctp,& +! ' fsigma=',fsigma,' mflx_e=',mflx_e,' trfluxtemk=',trfluxtem(k,ntr),' sigma=',sigma(i,k) ! the condensation terms - these come from the MSE and condensed water budgets for ! an entraining updraft -! if(k > kb(i)) then ! comment for test -! if(k <= kk) then ! Moorthi -! if(k < kt(i,ctp)) then +! if(k > kb(i)) then ! comment for test +! if(k <= kk) then ! Moorthi +! if(k < kt(i,ctp)) then ! rhs_h = cbmfl*(gcym(i,k)*gchm(i,k) - (gcym(i,km1)*gchm(i,km1) & -! + GDH(I,Km1 )*(gcym(i,k)-gcym(i,km1))) ) -! rhs_q = cbmfl*(gcym(i,k)*(gcwm(i,k)-gcqm(i,k)) & -! - (gcym(i,km1)*(gcwm(i,km1)-gcqm(i,km1)) & -! + (GDw( I,Km1 )-gdq(i,km1,1))*(gcym(i,k)-gcym(i,km1))) ) -! tem = cbmfl * (one - sigma(i,k)) - tem = cbmfl * (one - 0.5*(sigma(i,k)+sigma(i,km1))) - tem1 = gcym(i,k,ctp) * (one - sigma(i,k)) - tem2 = gcym(i,km1,ctp) * (one - sigma(i,km1)) - rhs_h = cbmfl * (tem1*gchm(i,k) - (tem2*gchm(i,km1) & - + GDH(I,Km1)*(tem1-tem2)) ) - rhs_q = cbmfl * (tem1*(gcwm(i,k)-gcqm(i,k)) & - - (tem2*(gcwm(i,km1)-gcqm(i,km1)) & - + (GDw(I,Km1)-gdq(i,km1,1))*(tem1-tem2)) ) +! + GDH(I,Km1 )*(gcym(i,k)-gcym(i,km1))) ) +! rhs_q = cbmfl*(gcym(i,k)*(gcwm(i,k)-gcqm(i,k)) & +! - (gcym(i,km1)*(gcwm(i,km1)-gcqm(i,km1)) & +! + (GDw( I,Km1 )-gdq(i,km1,1))*(gcym(i,k)-gcym(i,km1))) ) +! tem = cbmfl * (one - sigma(i,k)) + tem = cbmfl * (one - 0.5*(sigma(i,k)+sigma(i,km1))) + tem1 = gcym(i,k,ctp) * (one - sigma(i,k)) + tem2 = gcym(i,km1,ctp) * (one - sigma(i,km1)) + rhs_h = cbmfl * (tem1*gchm(i,k) - (tem2*gchm(i,km1) & + + GDH(I,Km1)*(tem1-tem2)) ) + rhs_q = cbmfl * (tem1*(gcwm(i,k)-gcqm(i,k)) & + - (tem2*(gcwm(i,km1)-gcqm(i,km1)) & + + (GDw(I,Km1)-gdq(i,km1,1))*(tem1-tem2)) ) ! ELSE ! rhs_h = cbmfl*(gcht(i,ctp) - (gcym(i,k-1)*gchm(i,k-1) + GDH( I,K-1 )*(gcyt(i,ctp)-gcym(i,k-1))) ) @@ -1125,72 +1176,71 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions ! total temperature tendency due to in cloud microphysics dtcondtem(i,km1) = - elocp * dqcondtem(i,km1) + dtfrztem(i,km1) - endif ! if(k > kbi) then - endif ! if (flx_form) - enddo ! end of k=kbi,kk loop + endif ! if(k > kbi) then + endif ! if (flx_form) + enddo ! end of k=kbi,kk loop - endif ! end of if(cbmfl > zero) + endif ! end of if(cbmfl > zero) ! get tendencies by difference of fluxes, sum over cloud type - if (flx_form) then - do k = 1,kk - delpinv = delpi(i,k) + if (flx_form) then + do k = 1,kk + delpinv = delpi(i,k) ! sum single cloud microphysical tendencies over all cloud types - condtermt(i,k) = condtermt(i,k) + dtcondtem(i,k) * delpinv - condtermq(i,k) = condtermq(i,k) + dqcondtem(i,k) * delpinv - prectermq(i,k) = prectermq(i,k) + dqprectem(i,k) * delpinv - prectermfrz(i,k) = prectermfrz(i,k) + dfrzprectem(i,k) * delpinv - frzterm(i,k) = frzterm(i,k) + dtfrztem(i,k) * delpinv + condtermt(i,k) = condtermt(i,k) + dtcondtem(i,k) * delpinv + condtermq(i,k) = condtermq(i,k) + dqcondtem(i,k) * delpinv + prectermq(i,k) = prectermq(i,k) + dqprectem(i,k) * delpinv + prectermfrz(i,k) = prectermfrz(i,k) + dfrzprectem(i,k) * delpinv + frzterm(i,k) = frzterm(i,k) + dtfrztem(i,k) * delpinv ! flux tendencies - compute the vertical flux divergence - sfluxterm(i,k) = sfluxterm(i,k) - (sfluxtem(k+1) - sfluxtem(k)) * delpinv - qvfluxterm(i,k) = qvfluxterm(i,k) - (qvfluxtem(k+1) - qvfluxtem(k)) * delpinv - qlfluxterm(i,k) = qlfluxterm(i,k) - (qlfluxtem(k+1) - qlfluxtem(k)) * delpinv - qifluxterm(i,k) = qifluxterm(i,k) - (qifluxtem(k+1) - qifluxtem(k)) * delpinv - do n = ntrq,ntr - trfluxterm(i,k,n) = trfluxterm(i,k,n) - (trfluxtem(k+1,n) - trfluxtem(k,n)) * delpinv - enddo - enddo - endif ! if (flx_form) - - enddo ! end of i loop -! - do i=ists,iens - if (cbmfx(i,ctp) > zero) then - tem = one - sigma(i,kt(i,ctp)) - gcyt(i,ctp) = tem * gcyt(i,ctp) - gtprt(i,ctp) = tem * gtprt(i,ctp) - gclt(i,ctp) = tem * gclt(i,ctp) - gcht(i,ctp) = tem * gcht(i,ctp) - gcqt(i,ctp) = tem * gcqt(i,ctp) - gcit(i,ctp) = tem * gcit(i,ctp) + sfluxterm(i,k) = sfluxterm(i,k) - (sfluxtem(k+1) - sfluxtem(k)) * delpinv + qvfluxterm(i,k) = qvfluxterm(i,k) - (qvfluxtem(k+1) - qvfluxtem(k)) * delpinv + qlfluxterm(i,k) = qlfluxterm(i,k) - (qlfluxtem(k+1) - qlfluxtem(k)) * delpinv + qifluxterm(i,k) = qifluxterm(i,k) - (qifluxtem(k+1) - qifluxtem(k)) * delpinv do n = ntrq,ntr - gctrt(i,n,ctp) = tem * gctrt(i,n,ctp) + trfluxterm(i,k,n) = trfluxterm(i,k,n) - (trfluxtem(k+1,n) - trfluxtem(k,n)) * delpinv enddo - gcut(i,ctp) = tem * gcut(i,ctp) - gcvt(i,ctp) = tem * gcvt(i,ctp) - do k=1,kmax - kk = kb(i) - if (k < kk) then - tem = one - sigma(i,kk) - tem1 = tem - else - tem = one - sigma(i,k) - tem1 = one - 0.5*(sigma(i,k)+sigma(i,k-1)) - endif - gcym(i,k,ctp) = tem * gcym(i,k,ctp) - gprciz(i,k) = tem1 * gprciz(i,k) - gsnwiz(i,k) = tem1 * gsnwiz(i,k) - gclz(i,k) = tem1 * gclz(i,k) - gciz(i,k) = tem1 * gciz(i,k) - enddo - endif - enddo - +! if (lprnt .and. i == ipr) write(0,*)' k=',k,' trfluxtem=',trfluxtem(k+1,ntr),trfluxtem(k,ntr),& +! ' ctp=',ctp,' trfluxterm=',trfluxterm(i,k,ntr) + enddo + endif ! if (flx_form) + + enddo ! end of i loop ! - endif ! end of do_aw if !DDsigma - end sigma computation for AW + do i=ists,iens + if (cbmfx(i,ctp) > zero) then + tem = one - sigma(i,kt(i,ctp)) + gcyt(i,ctp) = tem * gcyt(i,ctp) + gtprt(i,ctp) = tem * gtprt(i,ctp) + gclt(i,ctp) = tem * gclt(i,ctp) + gcht(i,ctp) = tem * gcht(i,ctp) + gcqt(i,ctp) = tem * gcqt(i,ctp) + gcit(i,ctp) = tem * gcit(i,ctp) + do n = ntrq,ntr + gctrt(i,n,ctp) = tem * gctrt(i,n,ctp) + enddo + gcut(i,ctp) = tem * gcut(i,ctp) + gcvt(i,ctp) = tem * gcvt(i,ctp) + do k=1,kmax + kk = kb(i) + if (k < kk) then + tem = one - sigma(i,kk) + tem1 = tem + else + tem = one - sigma(i,k) + tem1 = one - 0.5*(sigma(i,k)+sigma(i,k-1)) + endif + gcym(i,k,ctp) = tem * gcym(i,k,ctp) + gprciz(i,k) = tem1 * gprciz(i,k) + gsnwiz(i,k) = tem1 * gsnwiz(i,k) + gclz(i,k) = tem1 * gclz(i,k) + gciz(i,k) = tem1 * gciz(i,k) + enddo + endif + enddo ! ! Cloud Mass Flux & Precip. @@ -1214,26 +1264,29 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions DO CTP=1,NCTP IF (KTMX(CTP) > KTMXT) KTMXT = KTMX(CTP) ENDDO - DO K=1,KTMXT - DO I=ISTS,IENS - CUMCLW(I,K) = QLIQ(I,K) + QICE(I,K) - IF (CUMCLW(I,K) > zero) THEN - FLIQC(I,K) = QLIQ(I,K) / CUMCLW(I,K) - ENDIF - ENDDO - ENDDO + +! DO K=1,KTMXT +! DO I=ISTS,IENS +! CUMCLW(I,K) = QLIQ(I,K) + QICE(I,K) +! IF (CUMCLW(I,K) > zero) THEN +! FLIQC(I,K) = QLIQ(I,K) / CUMCLW(I,K) +! ENDIF +! ENDDO +! ENDDO ! ! Cumulus Cloudiness - CALL CUMCLD(IJSDIM, KMAX , & !DD dimensions - CUMCLW, QLIQ , QICE , FLIQC , & ! modified - CUMFRC, & ! output - GMFLX , KTMXT , ISTS , IENS ) ! input +! CALL CUMCLD(IJSDIM, KMAX , & !DD dimensions +! CUMCLW, QLIQ , QICE , FLIQC , & ! modified +! CUMFRC, & ! output +! GMFLX , KTMXT , ISTS , IENS ) ! input ! ! Cloud Detrainment Heating - if (.not. do_aw .or. .not. flx_form) then + if (.not. flx_form) then CALL CUMDET(im , IJSDIM, KMAX , NTR , ntrq , & !DD dimensions - GTT , GTQ , GTCFRC, GTU , GTV , & ! modified - GDH , GDQ , GDCFRC, GDU , GDV , & ! input + GTT , GTQ , GTU , GTV , & ! modified + GDH , GDQ , GDU , GDV , & ! input +! GTT , GTQ , GTCFRC, GTU , GTV , & ! modified +! GDH , GDQ , GDCFRC, GDU , GDV , & ! input CBMFX , GCYT , DELPI , GCHT , GCQT , & ! input GCLT , GCIT , GCUT , GCVT , GDQ(1,1,iti),& ! input gctrt , & @@ -1274,7 +1327,7 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions ! enddo ! enddo - if (.not. do_aw .or. .not. flx_form) then + if (.not. flx_form) then ! Cloud Subsidence Heating ! -----------------------= CALL CUMSBH(IM , IJSDIM, KMAX , NTR , ntrq , & !DD dimensions @@ -1295,9 +1348,15 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions ! ! for now the following routines appear to be of no consequence to AW - DD ! - if (.not. do_aw .or. .not. flx_form) then + if (.not. flx_form) then ! Tracer Updraft properties ! ------------- + allocate (gprcc(ijsdim,ntr)) + do n=1,ntr + do i=1,ijsdim + gprcc(i,n) = zero + enddo + enddo CALL CUMUPR(im , IJSDIM, KMAX , NTR , & !DD dimensions GTQ , GPRCC , & ! modified GDQ , CBMFX , & ! input @@ -1336,7 +1395,8 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions endif ENDDO - if(do_aw .and. flx_form) then ! compute AW tendencies +! if(do_aw .and. flx_form) then ! compute AW tendencies + if(flx_form) then ! compute AW tendencies ! AW lump all heating together, compute qv term do k=1,kmax do i=ists,iens @@ -1400,8 +1460,10 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions ENDDO endif ENDDO +! if (lprnt) write(0,*)' endcs_cum gtq=',gtq(ipr,1:25,ntr) +! if (lprnt) write(0,*)' endcs_cum trfluxterm=',trfluxterm(ipr,1:25,ntr) - endif ! if (do_aw) + endif ! if (flx_form) !!!! this section may need adjustment for cloud ice and water with flux_form ! @@ -1432,8 +1494,8 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions ! !!!!! end fixer section - DO K=1,KMAX - DO I=ISTS, IENS +! DO K=1,KMAX +! DO I=ISTS, IENS ! GTLDET(I,k) = GTQL(I,k) - GTQ(I,k,ITL) - GTIDET(I,k) ! tendencies of subgrid PDF (turned off) @@ -1448,22 +1510,22 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions ! GTQ( I,K,IMU2 ) = ( GDMU2X - GDQ( I,K,IMU2 ))/DELTA ! GTQ( I,K,IMU3 ) = ( GDMU3X - GDQ( I,K,IMU3 ))/DELTA ! - tem = DELP(I,K)*GRAVI - HBGT(I) = HBGT(I) + (CP*GTT(I,K) + EL*GTQ(I,K,1) & - - EMELT*GTQ(I,K,ITI)) * tem +! tem = DELP(I,K)*GRAVI +! HBGT(I) = HBGT(I) + (CP*GTT(I,K) + EL*GTQ(I,K,1) & +! - EMELT*GTQ(I,K,ITI)) * tem ! - EMELT*(GTQ(I,K,ITI)+GTIDET(I,K))) * tem - WBGT(I) = WBGT(I) + (GTQ(I,K,1) + GTQ(I,K,ITL) + GTQ(I,K,ITI)) * tem +! WBGT(I) = WBGT(I) + (GTQ(I,K,1) + GTQ(I,K,ITL) + GTQ(I,K,ITI)) * tem ! + GTLDET(I,K) + GTIDET(I,K)) * tem - ENDDO - ENDDO +! ENDDO +! ENDDO ! - DO I=ISTS,IENS - HBGT(I) = HBGT(I) - EMELT*GSNWC(I) - WBGT(I) = WBGT(I) + GPRCC(I,1) + GSNWC(I) +! DO I=ISTS,IENS +! HBGT(I) = HBGT(I) - EMELT*GSNWC(I) +! WBGT(I) = WBGT(I) + GPRCC(I,1) + GSNWC(I) ! CTOPP(I) = 1.D6 - ENDDO +! ENDDO ! ! The following commented out because they are unused ! DO CTP=1,NCTP @@ -1485,7 +1547,7 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions ! ! This code ensures conservation of water. In fact, no adjustment of the precip ! is occuring now which is a good sign! DD - if(do_aw .and. flx_form .and. adjustp) then + if(flx_form .and. adjustp) then DO I = ISTS, IENS if(gprcp(i,1)+gsnwp(i,1) > 1.e-12_r8) then moistening_aw(i) = - moistening_aw(i) / (gprcp(i,1)+gsnwp(i,1)) @@ -1502,10 +1564,10 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions endif ! - do i=ISTS,IENS - GPRCC(I,1) = GPRCP(I,1) - GSNWC(I ) = GSNWP(I,1) - enddo +! do i=ISTS,IENS +! GPRCC(I,1) = GPRCP(I,1) +! GSNWC(I ) = GSNWP(I,1) +! enddo do k=1,kmax do i=ISTS,IENS GTPRP(I,k) = GPRCP(I,k) + GSNWP(I,k) @@ -1519,12 +1581,13 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions ENDDO ENDDO ! - if (do_aw .and. flx_form) then + if (flx_form) then deallocate(sfluxterm, qvfluxterm, qlfluxterm, qifluxterm,& condtermt, condtermq, frzterm, prectermq, & prectermfrz, dtdwn, dqvdwn, dqldwn, & dqidwn, trfluxterm, dtrdwn) endif + if (allocated(gprcc)) deallocate(gprcc) ! END SUBROUTINE CS_CUMLUS @@ -1544,6 +1607,7 @@ SUBROUTINE CUMBAS & !! cloud base ! ! IMPLICIT NONE +! integer, parameter :: crtrh=0.80 integer, parameter :: crtrh=0.70 INTEGER, INTENT(IN) :: IJSDIM, KMAX , ntr, ntrq ! DD, for GFS, pass in integer ipr @@ -1625,7 +1689,7 @@ SUBROUTINE CUMBAS & !! cloud base QSL(i) = GDQS(I,K) + GAMX * (GDH(I,KLCLB)-GDHS(I,K)) spbl(i) = one - gdpm(i,k) * tx1(i) IF (GDW(I,KLCLB) >= QSL(i) .and. kb(i) < 0 & - .and. spbl(i) >= spblcrit) THEN + .and. spbl(i) >= spblmin) THEN ! .and. spbl(i) >= spblcrit .and. spbl(i) < spblcrit*10.0) THEN KB(I) = K + KBOFS ENDIF @@ -1634,7 +1698,7 @@ SUBROUTINE CUMBAS & !! cloud base DO K=KLCLB+1,KBMAX-1 DO I=ISTS,IENS spbl(i) = one - gdpm(i,k) * tx1(i) - IF (kb(i) > k .and. spbl(i) > spblcrit*5.0) THEN + IF (kb(i) > k .and. spbl(i) > spblmax) THEN KB(I) = K ENDIF ENDDO @@ -1682,10 +1746,11 @@ SUBROUTINE CUMBAS & !! cloud base endif ENDDO ! - DO K=1,KBMX + DO K=2,KBMX DO I=ISTS,IENS IF (K <= KB(I)) THEN - GCYM(I,K) = sqrt((GDZM(I,K)-GDZM(I,1)) * CBASE(i)) +! GCYM(I,K) = sqrt((GDZM(I,K)-GDZM(I,1))*CBASE(i)) + GCYM(I,K) = (GDZM(I,K)-GDZM(I,1))*CBASE(i) ENDIF ENDDO ENDDO @@ -1839,22 +1904,26 @@ SUBROUTINE CUMUP & !! in-cloud properties INTEGER CTP, ISTS, IENS ! ! [INTERNAL WORK] + REAL(r8) ACWFK (IJSDIM,KMAX) ! cloud work function + REAL(r8) ACWFN (IJSDIM,KMAX) ! negative part of cloud work function REAL(r8) myGCHt ! cloud top h *eta (half lev) REAL(r8) GCHMZ (IJSDIM, KMAX) ! cloud h *eta (half lev) REAL(r8) GCWMZ (IJSDIM, KMAX) ! cloud Qt*eta (half lev) - REAL(r8) GCqMZ (IJSDIM, KMAX) ! cloud qv*eta (half lev) REAL(r8) GCUMZ (IJSDIM, KMAX) ! cloud U *eta (half lev) REAL(r8) GCVMZ (IJSDIM, KMAX) ! cloud V *eta (half lev) + REAL(r8) GCqMZ (IJSDIM ) ! cloud qv*eta (half lev) REAL(r8) GCIMZ (IJSDIM, KMAX) ! cloud Qi*eta (half lev) REAL(r8) GCtrMZ(IJSDIM, KMAX,ntrq:ntr)! cloud tracer*eta (half lev) REAL(r8) GTPRMZ(IJSDIM, KMAX) ! rain+snow *eta (half lev) ! REAL(r8) BUOY (IJSDIM, KMAX) ! buoyancy REAL(r8) BUOYM (IJSDIM, KMAX) ! buoyancy (half lev) - REAL(r8) WCM (IJSDIM, KMAX) ! updraft velocity**2 (half lev) + REAL(r8) WCM (IJSDIM ) ! updraft velocity**2 (half lev) +! REAL(r8) WCM (IJSDIM, KMAX) ! updraft velocity**2 (half lev) !DD sigma make output REAL(r8) WCV ( IJSDIM, KMAX+1 ) !! updraft velocity (half lev) REAL(r8) GCY (IJSDIM, KMAX) ! norm. mass flux - REAL(r8) ELAR (IJSDIM, KMAX) ! entrainment rate +! REAL(r8) ELAR (IJSDIM, KMAX) ! entrainment rate + REAL(r8) ELAR ! entrainment rate at mid layer ! REAL(r8) GCHM (IJSDIM, KMAX) ! cloud MSE (half lev) REAL(r8) GCWM (IJSDIM, KMAX) ! cloud Qt (half lev) !DDsigmadiag @@ -1871,7 +1940,8 @@ SUBROUTINE CUMUP & !! in-cloud properties DELZ, ELADZ, DCTM , CPGMI, DELC, FICE, ELARM2,GCCMZ, & PRECR, GTPRIZ, DELZL, GCCT, DCT, WCVX, PRCZH, wrk INTEGER K, I, kk, km1, kp1, n - CHARACTER CTNUM*2 + +! CHARACTER CTNUM*2 ! !DD#ifdef OPT_CUMBGT !DD REAL(r8) HBGT (IJSDIM) ! heat budget @@ -1886,18 +1956,24 @@ SUBROUTINE CUMUP & !! in-cloud properties ! ! [INTERNAL PARAM] - REAL(r8), parameter :: ZTREF = 1._r8, ztrefi = one/ztref, & - ELAMIN = zero, ELAMAX = 4.e-3 ! min and max entrainment rate - REAL(r8) :: PB = 1._r8 -!m REAL(r8) :: TAUZ = 5.e3_r8 - REAL(r8) :: TAUZ = 1.e4_r8 - REAL(r8) :: ELMD = 2.4e-3 ! for Neggers and Siebesma (2002) -!m REAL(r8) :: ELAMAX = 5.e-3 ! max. of entrainment rate - REAL(r8) :: WCCRT = zero -!m REAL(r8) :: WCCRT = 0.01 - REAL(r8) :: TSICE = 268.15_r8 ! compatible with macrop_driver - REAL(r8) :: TWICE = 238.15_r8 ! compatible with macrop_driver -! REAL(r8) :: EPSln = 1.e-10 + REAL(r8), parameter :: ZTREF = 1._r8, ztrefi = one/ztref, & + ELAMIN = zero, ELAMAX = 4.e-3 ! min and max entrainment rate + REAL(r8) :: PB = 1.0_r8 +!m REAL(r8) :: TAUZ = 5.0e3_r8 + REAL(r8) :: TAUZ = 1.0e4_r8 +!m REAL(r8) :: ELMD = 2.4e-3 ! for Neggers and Siebesma (2002) +!m REAL(r8) :: ELAMAX = 5.e-3 ! max. of entrainment rate +! REAL(r8) :: WCCRT = zero +!m REAL(r8) :: WCCRT = 0.01 + REAL(r8) :: WCCRT = 1.0e-6_r8, wvcrt=1.0e-3_r8 + REAL(r8) :: TSICE = 268.15_r8 ! compatible with macrop_driver + REAL(r8) :: TWICE = 238.15_r8 ! compatible with macrop_driver + +! REAL(r8) :: wfn_neg = 0.1 + REAL(r8) :: wfn_neg = 0.15 +! REAL(r8) :: wfn_neg = 0.25 +! REAL(r8) :: wfn_neg = 0.30 +! REAL(r8) :: wfn_neg = 0.35 REAL(r8) :: esat, tem ! REAL(r8) :: esat, tem, rhs_h, rhs_q @@ -1928,6 +2004,8 @@ SUBROUTINE CUMUP & !! in-cloud properties enddo do k=1,kmax do i=ists,iens + ACWFK (I,k) = unset_r8 + ACWFN (I,k) = unset_r8 GCLZ (I,k) = zero GCIZ (I,k) = zero GPRCIZ(I,k) = zero @@ -1935,7 +2013,6 @@ SUBROUTINE CUMUP & !! in-cloud properties ! GCHMZ (I,k) = zero GCWMZ (I,k) = zero - GCqMZ (I,k) = zero GCIMZ (I,k) = zero GCUMZ (I,k) = zero GCVMZ (I,k) = zero @@ -1943,10 +2020,8 @@ SUBROUTINE CUMUP & !! in-cloud properties ! BUOY (I,k) = unset_r8 BUOYM (I,k) = unset_r8 - WCM (I,k) = unset_r8 WCV (I,k) = unset_r8 GCY (I,k) = unset_r8 - ELAR (I,k) = unset_r8 ! GCHM (I,k) = unset_r8 GCWM (I,k) = unset_r8 @@ -1958,32 +2033,38 @@ SUBROUTINE CUMUP & !! in-cloud properties GCVM (I,k) = unset_r8 enddo enddo + do i=ists,iens + GCqMZ(I) = zero + WCM(I) = unset_r8 + WCM_(I) = zero + enddo ! tracers do n=ntrq,ntr do i=ists,iens - GCtrT (I,n) = zero + GCtrT(I,n) = zero enddo do k=1,kmax do i=ists,iens - GCTRM (I,k,n) = unset_r8 + GCTRM(I,k,n) = unset_r8 enddo enddo enddo - DO I=ISTS,IENS - if (kb(i) > 0) then - GDZMKB(I) = GDZM(I,KB(I)) ! cloud base height - endif - ENDDO +! DO I=ISTS,IENS +! if (kb(i) > 0) then +! GDZMKB(I) = GDZM(I,KB(I)) ! cloud base height +! endif +! ENDDO ! ! < cloud base properties > ! DO I=ISTS,IENS K = KB(I) if (k > 0) then + GDZMKB(I) = GDZM(I,K) ! cloud base height GCHM(I,K) = GCHB(I) GCWM(I,K) = GCWB(I) - WCM (I,K) = WCB(i) + WCM_(I) = WCB(i) GCUM(I,K) = GCUB(I) GCVM(I,K) = GCVB(I) do n = ntrq,ntr @@ -1991,7 +2072,7 @@ SUBROUTINE CUMUP & !! in-cloud properties enddo ! esat = min(gdpm(i,k), fpvs(gdtm(i,k))) - GDQSM = min(EPSV*esat/max(gdpm(i,k)+epsvm1*esat, 1.0e-10), 1.0) + GDQSM = min(EPSV*esat/max(gdpm(i,k)+epsvm1*esat, 1.0e-10), 0.1) gdsm = CP*GDTM(I,K) + GRAV*GDZMKB(I) ! dse GDHSM = gdsm + EL*GDQSM ! saturated mse ! FDQSM = FDQSAT(GDTM(I,K), GDQSM) @@ -2003,7 +2084,8 @@ SUBROUTINE CUMUP & !! in-cloud properties GCQM(I,K) = min(GDQSM + FDQSM*DCTM, GCWM(I,K)) GCCM = MAX(GCWM(I,K)-GCQM(I,K), zero) ! GCTM(I,K) = GDT(I,K) + DCTM ! old - GCTM(I,K) = (GCHB(I) - gdsm - el*gcqm(i,k)) * oneocp + dctm ! new +! GCTM(I,K) = (GCHB(I) - gdsm - el*gcqm(i,k)) * oneocp + dctm ! new + GCTM(I,K) = (GCHB(I) - grav*gdzm(i,k) - el*gcqm(i,k)) * oneocp + dctm ! new ! GCIM(I,K) = FRICE(GCTM(I,K)) * GCCM ! cloud base ice GCLM(I,K) = MAX(GCCM-GCIM(I,K), zero) ! cloud base liquid @@ -2017,26 +2099,29 @@ SUBROUTINE CUMUP & !! in-cloud properties + GDQ(I,K-1,ITL) + GDQI(I,K-1)) ! - BUOYM(I,K) = (DCTM/GDTM(I,K) + EPSVT*(GCQM(I,K)-GDQM) - GCCM + GDCM )*GRAV + BUOYM(I,K) = (DCTM*tem + EPSVT*(GCQM(I,K)-GDQM) - GCCM + GDCM )*GRAV +! + ACWFK(I,K) = zero + ACWFN(I,K) = zero ! !DD#ifdef OPT_ASMODE !DD ELARM1(I) = ERMR !DD#elif defined OPT_NS02 !DD ELARM1(I) = ELMD / SQRT(WCM(I,K)) !DD#else - ELARM1(I) = CLMD*PA*BUOYM(I,K)/WCM(I,K) +! ELARM1(I) = CLMD*PA*BUOYM(I,K)/WCM(I,K) +! ELARM1(I) = min(max(CLMD*PA*BUOYM(I,K)/WCM_(I), ELAMIN), ELAMAX) !DD#endif - ELARM1(I) = MIN(MAX(ELARM1(I), ELAMIN), ELAMAX) -! - GCHMZ (I,K) = GCHM(I,K) - GCWMZ (I,K) = GCWM(I,K) - GCqMZ (I,K) = GCqM(I,K) - GCUMZ (I,K) = GCUM(I,K) - GCVMZ (I,K) = GCVM(I,K) - GCIMZ (I,K) = GCIM(I,K) - WCM_(I) = WCM(I,K) +! ELARM1(I) = MIN(MAX(ELARM1(I), ELAMIN), ELAMAX) +! + GCHMZ(I,K) = GCHM(I,K) + GCWMZ(I,K) = GCWM(I,K) + GCUMZ(I,K) = GCUM(I,K) + GCVMZ(I,K) = GCVM(I,K) + GCqMZ(I) = GCqM(I,K) + GCIMZ(I,K) = GCIM(I,K) do n = ntrq,ntr - GCtrMZ (I,K,n) = GCtrM(I,K,n) + GCtrMZ(I,K,n) = GCtrM(I,K,n) enddo endif ENDDO @@ -2049,6 +2134,7 @@ SUBROUTINE CUMUP & !! in-cloud properties IF (kb(i) > 0 .and. K > KB(I) .AND. WCM_(I) > WCCRT) THEN WCV(I,KM1) = SQRT(MAX(WCM_(I), zero)) DELZ = GDZM(I,K) - GDZM(I,KM1) + ELARM1(I) = min(max(CLMDPA*BUOYM(I,KM1)/WCM_(I), ELAMIN), ELAMAX) GCYM(I,K) = GCYM(I,KM1) * EXP(ELARM1(I)*DELZ) ELADZ = GCYM(I,K) - GCYM(I,KM1) ! @@ -2056,7 +2142,7 @@ SUBROUTINE CUMUP & !! in-cloud properties GCWMZ(I,K) = GCWMZ(I,KM1) + GDW(I,KM1)*ELADZ ! esat = min(gdpm(i,k), fpvs(gdtm(i,k))) - GDQSM = min(EPSV*esat/max(gdpm(i,k)+epsvm1*esat, 1.0e-10), 1.0) + GDQSM = min(EPSV*esat/max(gdpm(i,k)+epsvm1*esat, 1.0e-10), 0.1) GDHSM = CP*GDTM(I,K ) + GRAV*GDZM(I,K) + EL*GDQSM ! FDQSM = FDQSAT(GDTM(I,K), GDQSM) tem = one / GDTM(I,K) @@ -2067,15 +2153,14 @@ SUBROUTINE CUMUP & !! in-cloud properties PRECR = FPREC(GDZM(I,K)-GDZMKB(I), PRCZH ) ! wrk = one / GCYM(I,K) - DCTM = (GCHMZ(I,K)*wrk - GDHSM) * CPGMI - GCQMZ(i,k) = (GDQSM+FDQSM*DCTM) * GCYM(I,K) - GCQMZ(i,k) = MIN(GCQMZ(i,k), GCWMZ(I,K)) - GTPRMZ(I,K) = PRECR * (GCWMZ(I,K)-GCQMZ(i,k)) - GTPRMZ(I,K) = MAX(GTPRMZ(I,K), GTPRMZ(I,KM1)) - GCCMZ = GCWMZ(I,K) - GCQMZ(i,k) - GTPRMZ(I,K ) - DELC = MIN(GCCMZ, zero) - GCCMZ = GCCMZ - DELC - GCQMZ(i,k) = GCQMZ(i,k) + DELC + DCTM = (GCHMZ(I,K)*wrk - GDHSM) * CPGMI + GCQMZ(i) = min((GDQSM+FDQSM*DCTM)*GCYM(I,K), GCWMZ(I,K)) + GTPRMZ(I,K) = PRECR * (GCWMZ(I,K)-GCQMZ(i)) + GTPRMZ(I,K) = MAX(GTPRMZ(I,K), GTPRMZ(I,KM1)) + GCCMZ = GCWMZ(I,K) - GCQMZ(i) - GTPRMZ(I,K ) + DELC = MIN(GCCMZ, zero) + GCCMZ = GCCMZ - DELC + GCQMZ(i) = GCQMZ(i) + DELC ! FICE = FRICE(GDTM(I,K)+DCTM ) GCIMZ(I,K) = FICE * GCCMZ @@ -2087,11 +2172,10 @@ SUBROUTINE CUMUP & !! in-cloud properties GDQM = half * (GDQ(I,K,1) + GDQ(I,KM1,1)) GDCM = half * (GDQ(I,K,ITL) + GDQI(I,K) & + GDQ(I,KM1,ITL) + GDQI(I,KM1)) - GCQM(I,K) = GCQMZ(i,k)*wrk - GCCM = GCCMZ*wrk + GCQM(I,K) = wrk * GCQMZ(i) + GCCM = wrk * GCCMZ ! - BUOYM(I,K) = (DCTM/GDTM(I,K) & - + EPSVT*(GCQM(I,K)-GDQM )-GCCM+GDCM) * GRAV + BUOYM(I,K) = (DCTM*tem + EPSVT*(GCQM(I,K)-GDQM)-GCCM+GDCM) * GRAV BUOY(I,KM1) = half * (BUOYM(I,K)+BUOYM(I,KM1)) ! !DD#ifdef OPT_ASMODE @@ -2106,11 +2190,10 @@ SUBROUTINE CUMUP & !! in-cloud properties !DD WCM(I,K) = WCM_(I) + 2.D0*DELZ*(PA*BUOY(I,KM1)-ELMD*WCVX) !DD#else IF (BUOY(I,KM1) > zero) THEN - WCM(I,K) = (WCM_(I) + CLMP*DELZ*BUOY(I,KM1)) & - / (one + DELZ/TAUZ) + WCM(I) = (WCM_(I) + CLMP*DELZ*BUOY(I,KM1)) / (one + DELZ/TAUZ) ELSE - WCM(I,K) = (WCM_(I) + PA*(DELZ+DELZ)*BUOY(I,KM1) ) & - / (one + DELZ/TAUZ + (DELZ+DELZ)*ELAMIN ) + WCM(I) = (WCM_(I) + PA*(DELZ+DELZ)*BUOY(I,KM1) ) & + / (one + DELZ/TAUZ + (DELZ+DELZ)*ELAMIN ) ENDIF !DD#endif ! @@ -2119,33 +2202,36 @@ SUBROUTINE CUMUP & !! in-cloud properties !DD#elif OPT_NS02 !DD ELARM2 = ELMD/SQRT(MAX(WCM(I,K), EPSln)) !DD#else - ELARM2 = CLMD*PA*BUOYM(I,K) / MAX(WCM(I,K), EPSln) +! ELARM2 = CLMD*PA*BUOYM(I,K) / MAX(WCM(I), EPSln) !DD#endif - ELARM2 = MIN(MAX(ELARM2, ELAMIN), ELAMAX) - ELAR(I,KM1) = half * (ELARM1(I) + ELARM2) - GCYM(I,K) = GCYM(I,KM1) * EXP(ELAR(I,KM1)*DELZ) - ELADZ = GCYM(I,K) - GCYM(I,KM1) -! - GCHMZ(I,K) = GCHMZ(I,KM1) + GDH(I,KM1)*ELADZ - GCWMZ(I,K) = GCWMZ(I,KM1) + GDW(I,KM1)*ELADZ - GCUMZ(I,K) = GCUMZ(I,KM1) + GDU(I,KM1)*ELADZ - GCVMZ(I,K) = GCVMZ(I,KM1) + GDV(I,KM1)*ELADZ + if (WCM(I) > zero) then + ELARM2 = min(max(CLMDPA*BUOYM(I,K)/WCM(I),ELAMIN), ELAMAX) + else + ELARM2 = zero + endif + ELAR = half * (ELARM1(I) + ELARM2) + GCYM(I,K) = GCYM(I,KM1) * EXP(ELAR*DELZ) + ELADZ = GCYM(I,K) - GCYM(I,KM1) +! + GCHMZ(I,K) = GCHMZ(I,KM1) + GDH(I,KM1)*ELADZ + GCWMZ(I,K) = GCWMZ(I,KM1) + GDW(I,KM1)*ELADZ + GCUMZ(I,K) = GCUMZ(I,KM1) + GDU(I,KM1)*ELADZ + GCVMZ(I,K) = GCVMZ(I,KM1) + GDV(I,KM1)*ELADZ do n = ntrq,ntr - GCtrMZ(I,K,n) = GCtrMZ(I,KM1,n) + GDq(I,KM1,n)*ELADZ + GCtrMZ(I,K,n) = GCtrMZ(I,KM1,n) + GDq(I,KM1,n)*ELADZ enddo ! wrk = one / GCYM(I,K) DCTM = (GCHMZ(I,K)*wrk - GDHSM) * CPGMI - GCQMZ(i,k) = (GDQSM+FDQSM*DCTM) * GCYM(I,K) - GCQMZ(i,k) = MIN(GCQMZ(i,k), GCWMZ(I,K)) - GTPRMZ(I,K) = PRECR * (GCWMZ(I,K)-GCQMZ(i,k)) + GCQMZ(i) = min((GDQSM+FDQSM*DCTM)*GCYM(I,K), GCWMZ(I,K)) + GTPRMZ(I,K) = PRECR * (GCWMZ(I,K)-GCQMZ(i)) GTPRMZ(I,K) = MAX(GTPRMZ(I,K), GTPRMZ(I,KM1)) - GCCMZ = GCWMZ(I,K) - GCQMZ(i,k) - GTPRMZ(I,K) + GCCMZ = GCWMZ(I,K) - GCQMZ(i) - GTPRMZ(I,K) DELC = MIN(GCCMZ, zero) - GCCMZ = GCCMZ - DELC - GCQMZ(i,k) = GCQMZ(i,k) + DELC - GCCM = GCCMZ*wrk - GCQM(I,K) = GCQMZ(i,k)*wrk + GCCMZ = GCCMZ - DELC + GCQMZ(i) = GCQMZ(i) + DELC + GCCM = wrk * GCCMZ + GCQM(I,K) = wrk * GCQMZ(i) ! FICE = FRICE(GDTM(I,K)+DCTM ) GCIMZ(I,K) = FICE*GCCMZ @@ -2156,28 +2242,52 @@ SUBROUTINE CUMUP & !! in-cloud properties GPRCIZ(I,KM1) = (one-FICE )*GTPRIZ GCHMZ(I,K) = GCHMZ(I,K) + EMELT*(GCIMZ(I,K) + GSNWIZ(I,KM1) & - - GCIMZ(I,KM1) - GDQI(I,KM1)*ELADZ ) + - GCIMZ(I,KM1) - GDQI(I,KM1)*ELADZ ) GCHM(I,K) = GCHMZ(I,K)*wrk DCTM = (GCHM(I,K)-GDHSM) * CPGMI ! GCTM(I,K) = dctm + GDTM(I,K) + gocp*gdzm(i,k) ! old, make dse GCTM(I,K) = dctm + (GCHM(I,K) - el*gcqm(i,k)) * oneocp ! new, make dse ! - GCWM(I,K) = GCWMZ(I,K)*wrk - GCUM(I,K) = GCUMZ(I,K)*wrk - GCVM(I,K) = GCVMZ(I,K)*wrk + GCWM(I,K) = GCWMZ(I,K) * wrk + GCUM(I,K) = GCUMZ(I,K) * wrk + GCVM(I,K) = GCVMZ(I,K) * wrk do n = ntrq,ntr - GCtrM(I,K,n) = GCtrMZ(I,K,n)*wrk + GCtrM(I,K,n) = GCtrMZ(I,K,n) * wrk enddo DELZL = GDZ(I,KM1)-GDZM(I,KM1) - GCY (I,KM1) = GCYM(I,KM1) * EXP(ELAR(I,KM1)*DELZL) + GCY (I,KM1) = GCYM(I,KM1) * EXP(ELAR*DELZL) GCLZ(I,KM1) = half * (GCLM(I,K) + GCLM(I,KM1)) * GCY(I,KM1) GCIZ(I,KM1) = half * (GCIM(I,K) + GCIM(I,KM1)) * GCY(I,KM1) + +! + BUOYM(I,K) = (DCTM*tem + EPSVT*(GCQM(I,K)-GDQM)-GCCM+GDCM) * GRAV + BUOY(I,KM1) = half * (BUOYM(I,K)+BUOYM(I,KM1)) +! IF (BUOY(I,KM1) > zero) THEN - ACWF(I) = ACWF(I) + BUOY(I,KM1)*GCY(I,KM1)*DELZ + WCM(I) = (WCM_(I) + CLMP*DELZ*BUOY(I,KM1)) / (one + DELZ/TAUZ) + ELSE + WCM(I) = (WCM_(I) + PA*(DELZ+DELZ)*BUOY(I,KM1) ) & + / (one + DELZ/TAUZ + (DELZ+DELZ)*ELAMIN ) ENDIF + ! - ELARM1(I) = ELARM2 - WCM_(I) = WCM(I,K) +! IF (BUOY(I,KM1) > zero) THEN +! ACWF(I) = ACWF(I) + BUOY(I,KM1)*GCY(I,KM1)*DELZ +! ENDIF +! ACWF(I) = ACWF(I) + BUOY(I,KM1)*GCY(I,KM1)*DELZ +!!! wrk = BUOY(I,KM1)*GCY(I,KM1)*DELZ +!!! ACWFK(I,K) = ACWFK(I,KM1) + wrk +!!! ACWFN(I,K) = ACWFN(I,KM1) - min(wrk,0.0) +! ACWFN(I,K) = ACWFN(I,KM1) + abs(min(wrk,0.0)) +! + + wrk = BUOY(I,KM1)*GCY(I,KM1)*DELZ + ACWFK(I,K) = ACWFK(I,KM1) + wrk + ACWFN(I,K) = ACWFN(I,KM1) - min(wrk,0.0) + + WCM_(I) = WCM(I) + +! if (lprnt .and. i == ipr) write(0,*) ' in cumup k=',k,' km1=',km1,' WCM_=',WCM_(I),' gcy=',gcy(i,km1),' buoym=',buoym(i,km1) ENDIF ! IF (K > KB(I) .AND. WCM_(I) > WCCRT) THEN ENDDO @@ -2190,73 +2300,61 @@ SUBROUTINE CUMUP & !! in-cloud properties enddo DO K=KMAX,2,-1 DO I=ISTS,IENS - if (kb(i) > 0) then - IF (K > KB(I) .AND. KT(I) == -1 & - .AND. BUOYM(I,K) > zero .AND. WCM(I,K) > WCCRT) THEN - KT(I) = K + if (kb(i) > 0 .and. k > kb(i) .and. ACWFK(I,K) > 1.0e-10) then + wrk = ACWFN(I,K) / ACWFK(I,K) + IF (KT(I) == -1 .and. wrk < wfn_neg .AND. WCV(I,K) > WVCRT) THEN + KT(I) = K + ACWF(I) = ACWFK(I,K) ENDIF endif ENDDO ENDDO +! if (lprnt .and. kt(ipr) > 0) write(0,*) ' in cumup kt=',kt(ipr),' gcy=',gcy(ipr,kt(ipr)) ! KTMX = 2 DO I=ISTS,IENS kt(i) = min(kt(i), kmax-1) - KTMX = max(ktmx, KT(I)) + KTMX = max(ktmx, KT(I)) ENDDO ! DO I=ISTS,IENS - kk = kt(i) - IF (KK > 0 ) then - do k=kk+1,kmax - GCYM(I,K) = zero - enddo - do k=kk,kmax - GCLZ (I,K) = zero - GCIZ (I,K) = zero - GPRCIZ(I,K) = zero - GSNWIZ(I,K) = zero - enddo - ELSE - do k=1,kmax - GCYM(I,K) = zero - enddo - do k=1,kmax - GCLZ (I,k) = zero - GCIZ (I,k) = zero - GPRCIZ(I,k) = zero - GSNWIZ(I,k) = zero - enddo - ENDIF + kk = max(1, kt(i)+1) + do k=kk,kmax + GCYM (I,K) = zero + GCLZ (I,K) = zero + GCIZ (I,K) = zero + GPRCIZ(I,K) = zero + GSNWIZ(I,K) = zero + enddo ENDDO +! if (lprnt .and. kt(ipr) > 0) write(0,*) ' in cumup2 kt=',kt(ipr),' gcy=',gcy(ipr,kt(ipr)) ! ! < cloud top properties > ! DO I=ISTS,IENS - IF (kb(i) > 0 .and. KT(I) > 0) THEN + IF (kb(i) > 0 .and. KT(I) > kb(i)) THEN K = KT(I) kp1 = k + 1 - GCYT(I) = GCY(I,K) - ELADZ = GCYT(I) - GCYM(I,K) + GCYT(I) = GCY(I,K) + ELADZ = GCYT(I) - GCYM(I,K) ! - GCHT(I) = GCHMZ(I,K) + GDH(I,K)*ELADZ - GCWT(i) = GCWMZ(I,K) + GDW(I,K)*ELADZ - GCUT(I) = GCUMZ(I,K) + GDU(I,K)*ELADZ - GCVT(I) = GCVMZ(I,K) + GDV(I,K)*ELADZ + GCHT(I) = GCHMZ(I,K) + GDH(I,K)*ELADZ + GCWT(i) = GCWMZ(I,K) + GDW(I,K)*ELADZ + GCUT(I) = GCUMZ(I,K) + GDU(I,K)*ELADZ + GCVT(I) = GCVMZ(I,K) + GDV(I,K)*ELADZ do n = ntrq,NTR GCtrT(I,n) = GCtrMZ(I,K,n) + GDq(I,K,n)*ELADZ enddo ! - DCT = (GCHT(I)/GCYT(I) - GDHS(I,K)) & - / (CP*(one + GAM(I,K))) - GCQT(I) = (GDQS(I,K) + FDQS(I,K)*DCT) * GCYT(I) - GCQT(I) = MIN(GCQT(I), GCWT(i)) + wrk = one / gcyt(i) + DCT = (GCHT(I)*wrk - GDHS(I,K)) / (CP*(one + GAM(I,K))) + GCQT(I) = min((GDQS(I,K) + FDQS(I,K)*DCT) * GCYT(I), GCWT(i)) PRCZH = PRECZH * MIN(GDZTR(I)*ZTREFI, one) GTPRT(I) = FPREC(GDZ(I,K)-GDZMKB(I), PRCZH) * (GCWT(i)-GCQT(I)) GTPRT(I) = MAX(GTPRT(I), GTPRMZ(I,K)) GCCT = GCWT(i) - GCQT(I) - GTPRT(I) DELC = MIN(GCCT, zero) - GCCT = GCCT - DELC + GCCT = GCCT - DELC GCQT(I) = GCQT(I) + DELC ! FICE = FRICE(GDT(I,K)+DCT) @@ -2271,7 +2369,8 @@ SUBROUTINE CUMUP & !! in-cloud properties GCUT(I) = GCUT(I)*(one-CPRES) + GCY(I,K)*GDU(I,K)*CPRES GCVT(I) = GCVT(I)*(one-CPRES) + GCY(I,K)*GDV(I,K)*CPRES do n = ntrq,NTR - GCtrT(I,n) = GCtrT(I,n)*(one-CPRES) + GCY(I,K)*GDq(I,K,n)*CPRES +! GCtrT(I,n) = GCtrT(I,n)*(one-CPRES) + GCY(I,K)*GDq(I,K,n)*CPRES + GCtrT(I,n) = GCtrT(I,n) + GCY(I,K)*GDq(I,K,n) enddo GCLZ(I,K) = GCLT(I) GCIZ(I,K) = GCIT(I) @@ -2279,7 +2378,6 @@ SUBROUTINE CUMUP & !! in-cloud properties !DD AW get the cloud top values denormalized and put into profile mygcht = gcht(I) - el*(gcwt(i) - gcqt(i)) - wrk = one / gcyt(i) gctm(i,kp1) = wrk * (mygcht - el*gcqt(i)) * oneocp !Moorthi gcqm(i,kp1) = gcqt(i) gcqm(i,kp1) = gcqt(i)*wrk ! check this - oct17 2016 @@ -2393,15 +2491,15 @@ SUBROUTINE CUMBMX & !! cloud base mass flux ! ! [INTERNAL PARAM] REAL(r8) :: FMAX = 1.5e-2_r8 ! maximum flux - REAL(r8) :: RHMCRT = zero ! critical val. of RH@ all could -! REAL(r8) :: RHMCRT = 0.5_r8 ! critical val. of RH@ all could +! REAL(r8) :: RHMCRT = zero ! critical val. of cloud mean RH +! REAL(r8) :: RHMCRT = 0.25_r8 ! critical val. of cloud mean RH + REAL(r8) :: RHMCRT = 0.50_r8 ! critical val. of cloud mean RH REAL(r8) :: ALP1 = zero -! REAL(r8) :: TAUD = 1.e3_r8 - REAL(r8) :: TAUD = 6.e2_r8 + REAL(r8) :: TAUD = 1.e3_r8 +! REAL(r8) :: TAUD = 6.e2_r8 REAL(r8) :: ZFMAX = 3.5e3_r8 REAL(r8) :: ZDFMAX = 5.e2_r8 ! REAL(r8) :: FMAXP = 2._r8 -! REAL(r8) :: EPSln = 1.e-10_r8 ! do i=ists,iens qx(i) = zero @@ -2422,15 +2520,16 @@ SUBROUTINE CUMBMX & !! cloud base mass flux ! wrk = one + delt/(taud+taud) DO I=ISTS,IENS - cbmfx(i) = max(cbmfx(i), zero) - IF (kb(i) > 0 .and. KT(I) > KB(I) .AND. RHM(I) >= RHMCRT) THEN - ALP = ALP0 + ALP1 * (GDZM(I,KT(I))-GDZM(I,KB(I))) + k = kb(i) + IF (k > 0 .and. KT(I) > K .AND. RHM(I) >= RHMCRT) THEN + cbmfx(i) = max(cbmfx(i), zero) + ALP = ALP0 + ALP1 * (GDZM(I,KT(I))-GDZM(I,K)) FMAX1 = (one - TANH((GDZM(I,1)-ZFMAX)/ZDFMAX)) * half ! FMAX1 = FMAX * FMAX1**FMAXP FMAX1 = FMAX * FMAX1 * FMAX1 ! CBMFX(I) = CBMFX(I) + MAX(ACWF(I), zero)/(ALP+ALP)*DELT ! CBMFX(I) = CBMFX(I) / (one + DELT/(TAUD+TAUD)) - CBMFX(I) = (CBMFX(I) + MAX(ACWF(I), zero)/(ALP+ALP)*DELT) * wrk + CBMFX(I) = (CBMFX(I) + ACWF(I)*(delt/(ALP+ALP))) * wrk CBMFX(I) = MIN(max(CBMFX(I), zero), FMAX1/GCYT(I)) ELSE CBMFX(I) = zero @@ -2488,9 +2587,10 @@ SUBROUTINE CUMFLX & !! cloud mass flux ENDDO ! DO I= ISTS,IENS - if (kb(i) > 0 .and. kt(i) > 0) then - GTPRC0(I) = GTPRC0(I) + CBMFX(I) * GTPRT(I) - CMDET(I,KT(I)) = CMDET(I,KT(I)) + CBMFX(I) * GCYT(I) + k = kt(i) + if (kb(i) > 0 .and. k > kb(i)) then + GTPRC0(I) = GTPRC0(I) + CBMFX(I) * GTPRT(I) + CMDET(I,K) = CMDET(I,K) + CBMFX(I) * GCYT(I) endif ENDDO ! @@ -2498,8 +2598,10 @@ END SUBROUTINE CUMFLX !*********************************************************************** SUBROUTINE CUMDET & !! detrainment ( im , IJSDIM, KMAX , NTR , ntrq , & !DD dimensions - GTT , GTQ , GTCFRC, GTU , GTV , & ! modified - GDH , GDQ , GDCFRC, GDU , GDV , & ! input + GTT , GTQ , GTU , GTV , & ! modified + GDH , GDQ , GDU , GDV , & ! input +! GTT , GTQ , GTCFRC, GTU , GTV , & ! modified +! GDH , GDQ , GDCFRC, GDU , GDV , & ! input CBMFX , GCYT , DELPI , GCHT , GCQT , & ! input GCLT , GCIT , GCUT , GCVT , GDQI , & ! input gctrt, & @@ -2512,14 +2614,14 @@ SUBROUTINE CUMDET & !! detrainment ! [MODIFY] REAL(r8) GTT (IJSDIM, KMAX) !! temperature tendency REAL(r8) GTQ (IJSDIM, KMAX, NTR) !! moisture tendency - REAL(r8) GTCFRC(IJSDIM, KMAX) !! cloud fraction tendency +! REAL(r8) GTCFRC(IJSDIM, KMAX) !! cloud fraction tendency REAL(r8) GTU (IJSDIM, KMAX) !! u tendency REAL(r8) GTV (IJSDIM, KMAX) !! v tendency ! ! [INPUT] REAL(r8) GDH (IJSDIM, KMAX) !! moist static energy REAL(r8) GDQ (IJSDIM, KMAX, NTR) !! humidity qv - REAL(r8) GDCFRC(IJSDIM, KMAX) !! cloud fraction +! REAL(r8) GDCFRC(IJSDIM, KMAX) !! cloud fraction REAL(r8) GDU (IJSDIM, KMAX) REAL(r8) GDV (IJSDIM, KMAX) REAL(r8) DELPI (IJSDIM, KMAX) @@ -2560,7 +2662,7 @@ SUBROUTINE CUMDET & !! detrainment GTQ(I,K,n) = GTQ(I,K,n) + GTXCI * (GCtrT(I,n,CTP) - GCYT(I,CTP)*GDQ(I,K,n)) enddo - GTCFRC(I,K) = GTCFRC(I,K) + GTXCI * (GCYT(I,CTP) - GCYT(I,CTP)*GDCFRC(I,K)) +! GTCFRC(I,K) = GTCFRC(I,K) + GTXCI * (GCYT(I,CTP) - GCYT(I,CTP)*GDCFRC(I,K)) GTU(I,K) = GTU(I,K) + GTXCI * (GCUT(I,CTP) - GCYT(I,CTP)*GDU(I,K)) GTV(I,K) = GTV(I,K) + GTXCI * (GCVT(I,CTP) - GCYT(I,CTP)*GDV(I,K)) ENDIF @@ -2869,7 +2971,7 @@ SUBROUTINE CUMDWN & ! Freeze & Melt & Evaporation !M REAL(r8) GTHCI, GTQVCI, GTQLCI, GTQICI, GTUCI, GTVCI !DD#ifdef OPT_CUMBGT ! Water, energy, downdraft water and downdraft energy budgets - REAL(r8), dimension(ISTS:IENS) :: WBGT, HBGT, DDWBGT, DDHBGT +! REAL(r8), dimension(ISTS:IENS) :: WBGT, HBGT, DDWBGT, DDHBGT integer ij, i, k, kp1, n !DD#endif ! @@ -2929,7 +3031,7 @@ SUBROUTINE CUMDWN & ! Freeze & Melt & Evaporation enddo enddo ! testing on oct 17 2016 - if (do_aw .and. flx_form) then + if (flx_form) then if (.not. do_awdd) then do k=1,kmax do i=ists,iens @@ -2994,15 +3096,15 @@ SUBROUTINE CUMDWN & ! Freeze & Melt & Evaporation ELSE FSNOW(I) = zero ENDIF - LVIC = ELocp + EMELTocp*FSNOW(I) - GDTW = GDT(I,K) - LVIC*(GDQS(I,K) - GDQ(I,K,1)) & - / (one + LVIC*FDQS(I,K)) + LVIC = ELocp + EMELTocp*FSNOW(I) + GDTW = GDT(I,K) - LVIC*(GDQS(I,K) - GDQ(I,K,1)) & + / (one + LVIC*FDQS(I,K)) IF (GDTW < TWSNOW) THEN GSNWP(I,K) = GSNWP(I,KP1) + GPRCI(I,K) + GSNWI(I,K) GTTEV(I,K) = EMELToCP * GPRCI(I,K) * DELPI(I,K) SNMLT(I,K) = -GPRCI(I,K) ELSE - DZ = GDZM(I,KP1) - GDZM(I,K) + DZ = GDZM(I,KP1) - GDZM(I,K) FMELT = (one + FTMLT*(GDTW - TWSNOW)) & * (one - TANH(GMFLX(I,KP1)/GMFLXC)) & * (one - TANH(VTERMS*MELTAU/DZ)) @@ -3091,12 +3193,12 @@ SUBROUTINE CUMDWN & ! Freeze & Melt & Evaporation GCWDX = GCWD(I) + GDQW*GMDDE(I,K) GCSD = (GCHDX - EL*GCWDX) / GMDDX IF (GCSD < GDS(I,K)) THEN - GCHD(I) = GCHDX - GCWD(I) = GCWDX - GCUD(I) = GCUD(I) + GDU(I,K)*GMDDE(I,K) - GCVD(I) = GCVD(I) + GDV(I,K)*GMDDE(I,K) + GCHD(I) = GCHDX + GCWD(I) = GCWDX + GCUD(I) = GCUD(I) + GDU(I,K)*GMDDE(I,K) + GCVD(I) = GCVD(I) + GDV(I,K)*GMDDE(I,K) do n = ntrq,ntr - GCtrD(I,n) = GCtrD(I,n) + GDq(I,K,n)*GMDDE(I,K) + GCtrD(I,n) = GCtrD(I,n) + GDq(I,K,n)*GMDDE(I,K) enddo GMDD(I,K) = GMDDX EVAPE(I,K) = EVAPE(I,K) - EVAPX(I,K) @@ -3171,7 +3273,7 @@ SUBROUTINE CUMDWN & ! Freeze & Melt & Evaporation GMFLX(I,K) = GMFLX(I,K) - GMDD(I,K) ! AW tendencies due to vertical divergence of eddy fluxes - if (do_awdd .and. k > 1 .and. flx_form) then + if (k > 1 .and. flx_form) then fsigma = one - sigmad(i,kp1) dp_below = wrk * (one - sigmad(i,k)) dp_above = tx1 * (one - sigmad(i,kp1)) @@ -3216,7 +3318,7 @@ SUBROUTINE CUMDWN & ! Freeze & Melt & Evaporation do k=1,kmax do i=ists,iens if (kb(i) > 0) then - dtrdwn(i,k,n) = gtq(i,k,n) - dtrdwn(i,k,n) + dtrdwn(i,k,n) = gtq(i,k,n) - dtrdwn(i,k,n) endif enddo enddo diff --git a/gfsphysics/physics/dcyc2.f b/gfsphysics/physics/dcyc2.f index 04a803ff9..5401b84fb 100644 --- a/gfsphysics/physics/dcyc2.f +++ b/gfsphysics/physics/dcyc2.f @@ -124,7 +124,7 @@ subroutine dcyc2t3 & & sfcdsw,sfcnsw,sfcdlw,swh,swhc,hlw,hlwc, & & sfcnirbmu,sfcnirdfu,sfcvisbmu,sfcvisdfu, & & sfcnirbmd,sfcnirdfd,sfcvisbmd,sfcvisdfd, & - & ix, im, levs, & + & ix, im, levs, deltim, & ! --- input/output: & dtdt,dtdtc, & ! --- outputs: @@ -139,12 +139,15 @@ subroutine dcyc2t3 & implicit none ! ! --- constant parameters: - real(kind=kind_phys), parameter :: f_eps = 0.0001, hour12 = 12.0 + real(kind=kind_phys), parameter :: f_eps = 0.0001, hour12 = 12.0,& + & f7200 = 1.0/7200.0, & + & pid12 = con_pi / hour12 ! --- inputs: integer, intent(in) :: ix, im, levs - real(kind=kind_phys), intent(in) :: solhr, slag, cdec, sdec + real(kind=kind_phys), intent(in) :: solhr, slag, cdec, sdec, & + & deltim real(kind=kind_phys), dimension(im), intent(in) :: & & sinlat, coslat, xlon, coszen, tsea, tf, tsflw, sfcdlw, & @@ -172,7 +175,7 @@ subroutine dcyc2t3 & ! !===> ... begin here ! - cns = con_pi * (solhr - hour12) / hour12 + slag + cns = pid12 * (solhr + deltim*f7200 - hour12) + slag ! do i = 1, im @@ -182,7 +185,7 @@ subroutine dcyc2t3 & ! compute 4th power of the ratio of layer 1 tf over the mean value tsflw tem1 = tf(i) / tsflw(i) - tem2 = tem1 * tem1 + tem2 = tem1 * tem1 adjsfcdlw(i) = sfcdlw(i) * tem2 * tem2 ! --- ... compute sfc upward lw flux from current sfc temp, @@ -211,18 +214,18 @@ subroutine dcyc2t3 & ! --- ... adjust sfc net and downward sw fluxes for zenith angle changes ! note: sfc emiss effect will not be appied here - adjsfcnsw(i) = sfcnsw(i) * xmu(i) - adjsfcdsw(i) = sfcdsw(i) * xmu(i) + adjsfcnsw(i) = sfcnsw(i) * xmu(i) + adjsfcdsw(i) = sfcdsw(i) * xmu(i) - adjnirbmu(i) = sfcnirbmu(i) * xmu(i) - adjnirdfu(i) = sfcnirdfu(i) * xmu(i) - adjvisbmu(i) = sfcvisbmu(i) * xmu(i) - adjvisdfu(i) = sfcvisdfu(i) * xmu(i) + adjnirbmu(i) = sfcnirbmu(i) * xmu(i) + adjnirdfu(i) = sfcnirdfu(i) * xmu(i) + adjvisbmu(i) = sfcvisbmu(i) * xmu(i) + adjvisdfu(i) = sfcvisdfu(i) * xmu(i) - adjnirbmd(i) = sfcnirbmd(i) * xmu(i) - adjnirdfd(i) = sfcnirdfd(i) * xmu(i) - adjvisbmd(i) = sfcvisbmd(i) * xmu(i) - adjvisdfd(i) = sfcvisdfd(i) * xmu(i) + adjnirbmd(i) = sfcnirbmd(i) * xmu(i) + adjnirdfd(i) = sfcnirdfd(i) * xmu(i) + adjvisbmd(i) = sfcvisbmd(i) * xmu(i) + adjvisdfd(i) = sfcvisdfd(i) * xmu(i) enddo ! --- ... adjust sw heating rates with zenith angle change and diff --git a/gfsphysics/physics/gcm_shoc.f90 b/gfsphysics/physics/gcm_shoc.f90 index c9cec3038..3e4b0247e 100644 --- a/gfsphysics/physics/gcm_shoc.f90 +++ b/gfsphysics/physics/gcm_shoc.f90 @@ -12,12 +12,15 @@ ! pressures below a critical value pcrit ! S Moorthi - 04-12-17 - fixed a bug in the definition of hl on input ! replacing fac_fus by fac_sub +! S.Moorthi - 00-00-17 - added an alternate option for near boundary cek following +! Scipion et. al., from U. Oklahoma. subroutine shoc(ix, nx, ny, nzm, nz, dtn, me, lat, & prsl, phii, phil, u, v, omega, tabs, & - qwv, qi, qc, qpi, qpl, rhc, supice, & +! qwv, qi, qc, rhc, supice, & + qwv, qi, qc, qpi_i, qpl, qgl, rhc, supice, & pcrit, cefac, cesfac, tkef1, dis_opt, & cld_sgs, tke, hflx, evap, prnum, tkh, & wthv_sec, lprnt, ipr, ncpl, ncpi) @@ -46,26 +49,9 @@ subroutine shoc(ix, nx, ny, nzm, nz, dtn, me, lat, & sqrtpii = one/sqrt(pi+pi), epsterm = rgas/rv, & onebeps = one/epsterm, twoby15 = two / 15.0, & onebrvcp= one/(rv*cp), skew_facw=1.2, skew_fact=0.0, & - tkhmax=300.0, scrit=2.0e-6 + tkhmax=300.0 ! onebrvcp= 1.0/(rv*cp), skew_facw=1.2, skew_fact=1.0, & -! tkef1=0.5, tkef2=1.0-tkef1, tkhmax=1000.0, cefac=3.0, & -! tkef1=0.5, tkef2=1.0-tkef1, tkhmax=1000.0, cefac=1.5, & -! tkef1=0.5, tkef2=1.0-tkef1, tkhmax=200.0, cefac=1.5, & -! tkef1=0.7, tkef2=1.0-tkef1, tkhmax=1000.0, cefac=1.5, & -! tkef1=0.7, tkef2=1.0-tkef1, tkhmax=300.0, cefac=1.0, & -! tkef1=0.7, tkef2=1.0-tkef1, tkhmax=300.0, cefac=1.5, & -! tkef1=1.1, tkef2=1.0-tkef1, tkhmax=200.0, cefac=1.5, & -! tkef1=0.7, tkef2=1.0-tkef1, tkhmax=1000.0, cefac=1.5, & - -! scrit=5.0e-8 -! scrit=3.0e-6 -! scrit=1.0e-5 -! scrit=5.0e-6 -! scrit=1.0e-5 -! scrit=1.0e-6 - -! real, parameter :: supice=1.05 logical lprnt integer ipr @@ -103,8 +89,9 @@ subroutine shoc(ix, nx, ny, nzm, nz, dtn, me, lat, & ! Anning Cheng 03/11/2016 SHOC feedback to number concentration real, intent(inout) :: ncpl (nx,ny,nzm) ! cloud water number concentration,/m^3 real, intent(inout) :: ncpi (nx,ny,nzm) ! cloud ice number concentration,/m^3 - real, intent(inout) :: qpl (nx,ny,nzm) ! rain mixing ratio, kg/kg - real, intent(inout) :: qpi (nx,ny,nzm) ! snow mixing ratio, kg/kg + real, intent(inout) :: qpl (nx,ny,nzm) ! rain mixing ratio, kg/kg - not used at this time + real, intent(inout) :: qpi_i (nx,ny,nzm) ! snow mixing ratio, kg/kg - not used at this time + real, intent(inout) :: qgl (nx,ny,nzm) ! graupel mixing ratio, kg/kg - not used at this time real, intent(inout) :: rhc (nx,ny,nzm) ! critical relative humidity real, intent(in) :: supice ! ice supersaturation parameter real, intent(inout) :: cld_sgs(ix,ny,nzm) ! sgs cloud fraction @@ -130,7 +117,7 @@ subroutine shoc(ix, nx, ny, nzm, nz, dtn, me, lat, & real, parameter :: Pr = 1.0 ! Prandtl number ! Constants for the TKE dissipation term based on Deardorff (1980) - real, parameter :: pt19=0.19, pt51=0.51, pt01=0.01, atmin=0.10, atmax=one-atmin + real, parameter :: pt19=0.19, pt51=0.51, pt01=0.01, atmin=0.01, atmax=one-atmin real, parameter :: Cs = 0.15, epsln=1.0e-6 real, parameter :: Ck = 0.1 ! Coeff in the eddy diffusivity - TKE relationship, see Eq. 7 in BK13 @@ -151,11 +138,13 @@ subroutine shoc(ix, nx, ny, nzm, nz, dtn, me, lat, & real, parameter :: w_tol_sqd = 4.0e-04 ! Min vlaue of second moment of w ! real, parameter :: w_tol_sqd = 1.0e-04 ! Min vlaue of second moment of w real, parameter :: w_thresh = 0.0, thresh = 0.0 + real, parameter :: w3_tol = 1.0e-20 ! Min vlaue of third moment of w ! These parameters are a tie-in with a microphysical scheme ! Double check their values for the Zhao-Carr scheme. - real, parameter :: tbgmin = 258.16 ! Minimum temperature for cloud water., K (ZC) + real, parameter :: tbgmin = 233.16 ! Minimum temperature for cloud water., K (ZC) +! real, parameter :: tbgmin = 258.16 ! Minimum temperature for cloud water., K (ZC) ! real, parameter :: tbgmin = 253.16 ! Minimum temperature for cloud water., K real, parameter :: tbgmax = 273.16 ! Maximum temperature for cloud ice, K real, parameter :: a_bg = one/(tbgmax-tbgmin) @@ -182,6 +171,8 @@ subroutine shoc(ix, nx, ny, nzm, nz, dtn, me, lat, & real w (nx,ny,nzm) ! z-wind, m/s real bet (nx,ny,nzm) ! ggr/tv0 real gamaz (nx,ny,nzm) ! ggr/cp*z + real qpi (nx,ny,nzm) ! snow + graupel mixing ratio, kg/kg +! real qpl (nx,ny,nzm) ! rain mixing ratio, kg/kg ! Moments of the trivariate double Gaussian PDF for the SGS total water mixing ratio ! SGS liquid/ice static energy, and vertical velocity @@ -244,7 +235,7 @@ subroutine shoc(ix, nx, ny, nzm, nz, dtn, me, lat, & lstarn1, lstarn2, sqrtw2, sqrtthl, sqrtqt, & sqrtstd1, sqrtstd2, tsign, tvar, sqrtw2t, wqls, wqis, & sqrtqw2_1, sqrtqw2_2, sqrtthl2_1, sqrtthl2_2, sm, prespot, & - corrtest1, corrtest2, wrk, wrk1, wrk2, wrk3, onema, pfac, sfac, sfaci + corrtest1, corrtest2, wrk, wrk1, wrk2, wrk3, onema, pfac integer i,j,k,km1,ku,kd,ka,kb @@ -259,6 +250,13 @@ subroutine shoc(ix, nx, ny, nzm, nz, dtn, me, lat, & enddo enddo enddo + +! if (lprnt) write(0,*)' tabsin=',tabs(ipr,1,1:40) +! if (lprnt) write(0,*)' qcin=',qc(ipr,1,1:40) +! if (lprnt) write(0,*)' qwvin=',qwv(ipr,1,1:40) +! if (lprnt) write(0,*)' qiin=',qi(ipr,1,1:40) +! if (lprnt) write(0,*)' qplin=',qpl(ipr,1,1:40) +! if (lprnt) write(0,*)' qpiin=',qpi(ipr,1,1:40) ! ! move water from vapor to condensate if the condensate is negative ! @@ -293,6 +291,7 @@ subroutine shoc(ix, nx, ny, nzm, nz, dtn, me, lat, & enddo enddo +! if (lprnt) write(0,*)' tabsin2=',tabs(ipr,1,1:40) do k=1,nzm do j=1,ny @@ -304,9 +303,11 @@ subroutine shoc(ix, nx, ny, nzm, nz, dtn, me, lat, & w(i,j,k) = - rog * omega(i,j,k) * thv(i,j,k) * wrk qcl(i,j,k) = max(qc(i,j,k), zero) qci(i,j,k) = max(qi(i,j,k), zero) + qpi(i,j,k) = qpi_i(i,j,k) + qgl(i,j,k) ! add snow and graupel together ! ! qpl(i,j,k) = zero ! comment or remove when using with prognostic rain/snow ! qpi(i,j,k) = zero ! comment or remove when using with prognostic rain/snow + wqp_sec(i,j,k) = zero ! Turbulent flux of precipiation ! total_water(i,j,k) = qcl(i,j,k) + qci(i,j,k) + qv(i,j,k) @@ -326,6 +327,7 @@ subroutine shoc(ix, nx, ny, nzm, nz, dtn, me, lat, & enddo enddo +! if (lprnt) write(0,*)' hlin=',hl(ipr,1,1:40) ! Define vertical grid increments for later use in the vertical differentiation @@ -378,10 +380,13 @@ subroutine shoc(ix, nx, ny, nzm, nz, dtn, me, lat, & do j=1,ny do i=1,nx if (tke(i,j,k) > zero) then - wrk = half*(tkh(i,j,ka)+tkh(i,j,kb))*(w(i,j,ku) - w(i,j,kd)) & +! wrk = half*(tkh(i,j,ka)+tkh(i,j,kb))*(w(i,j,ku) - w(i,j,kd)) & + wrk = half*(tkh(i,j,ka)*prnum(i,j,ka)+tkh(i,j,kb)*prnum(i,j,kb))*(w(i,j,ku) - w(i,j,kd)) & * sqrt(tke(i,j,k)) / (zl(i,j,ku) - zl(i,j,kd)) -! / (sqrt(tke(i,j,k)) * (zl(i,j,ku) - zl(i,j,kd))) w_sec(i,j,k) = max(twoby3 * tke(i,j,k) - twoby15 * wrk, zero) +! w_sec(i,j,k) = max(twoby3 * tke(i,j,k), zero) +! if(lprnt .and. i == ipr .and. k <40) write(0,*)' w_sec=',w_sec(i,j,k),' tke=r',tke(i,j,k),& +! ' tkh=',tkh(i,j,ka),tkh(i,j,kb),' w=',w(i,j,ku),w(i,j,kd),' prnum=',prnum(i,j,ka),prnum(i,j,kb) else w_sec(i,j,k) = zero endif @@ -405,8 +410,11 @@ subroutine shoc(ix, nx, ny, nzm, nz, dtn, me, lat, & sm = half*(isotropy(i,j,k)+isotropy(i,j,km1))*wrk1*wrk3 ! Tau*Kh/dz^2 ! SGS vertical flux liquid/ice water static energy. Eq 1 in BK13 +! No rain, snow or graupel in pdf (Annig, 08/29/2018) - wrk1 = hl(i,j,k) - hl(i,j,km1) + wrk1 = hl(i,j,k) - hl(i,j,km1) & + + (qpl(i,j,k) - qpl(i,j,km1)) * fac_cond & + + (qpi(i,j,k) - qpi(i,j,km1)) * fac_sub wthl_sec(i,j,k) = - wrk3 * wrk1 ! SGS vertical flux of total water. Eq 2 in BK13 @@ -563,7 +571,7 @@ subroutine tke_shoc() wrk = (dtn*Cee) / smixt(i,j,k) wrk1 = wtke + dtn*(a_prod_sh+a_prod_bu) -! if (lprnt .and. i == ipr .and. k<20) write(0,*)' wtke=',wtke,' wrk1=',wrk1,& +! if (lprnt .and. i == ipr .and. k<40) write(0,*)' wtke=',wtke,' wrk1=',wrk1,& ! ' a_prod_sh=',a_prod_sh,' a_prod_bu=',a_prod_bu,' dtn=',dtn,' smixt=',& ! smixt(i,j,k),' tkh=',tkh(i,j,ku),tkh(i,j,kd),' def2=',def2(i,j,ku),def2(i,j,kd)& ! ,' prnum=',prnum(i,j,ku),prnum(i,j,kd),' wthv_sec=',wthv_sec(i,j,k),' thv=',thv(i,j,k) @@ -574,7 +582,7 @@ subroutine tke_shoc() wtke = wrk1 / (one+a_diss) wtke = tkef1*wtke + tkef2*wtk2 ! tkef1+tkef2 = 1.0 -! if (lprnt .and. i == ipr .and. k<20) write(0,*)' wtke=',wtke,' wtk2=',wtk2,& +! if (lprnt .and. i == ipr .and. k<40) write(0,*)' wtke=',wtke,' wtk2=',wtk2,& ! ' a_diss=',a_diss,' a_prod_sh=',a_prod_sh,' a_prod_bu=',a_prod_bu,& ! ' wrk1=',wrk1,' itr=',itr,' k=',k @@ -583,8 +591,9 @@ subroutine tke_shoc() enddo tke(i,j,k) = min(max(min_tke, wtke), max_tke) + a_diss = wrk*sqrt(tke(i,j,k)) - tscale1 = (dtn+dtn) / a_diss ! See Eq 8 in BK13 + tscale1 = (dtn+dtn) / a_diss ! corrected Eq 8 in BK13 -- tau = 2*tke/eps tkesbdiss(i,j,k) = rdtn*a_diss*tke(i,j,k) ! TKE dissipation term, epsilon @@ -844,20 +853,20 @@ subroutine eddy_length() ! call conv_scale() ! inlining the relevant code - do j=1,ny - do i=1,nx - conv_vel2(i,j,1) = zero ! Convective velocity scale cubed - enddo - enddo +! do j=1,ny +! do i=1,nx +! conv_vel2(i,j,1) = zero ! Convective velocity scale cubed +! enddo +! enddo ! Integrate velocity scale in the vertical - do k=2,nzm - do j=1,ny - do i=1,nx - conv_vel2(i,j,k) = conv_vel2(i,j,k-1) & - + 2.5*adzi(i,j,k)*bet(i,j,k)*wthv_sec(i,j,k) - enddo - enddo - enddo +! do k=2,nzm +! do j=1,ny +! do i=1,nx +! conv_vel2(i,j,k) = conv_vel2(i,j,k-1) & +! + 2.5*adzi(i,j,k)*bet(i,j,k)*wthv_sec(i,j,k) +! enddo +! enddo +! enddo do j=1,ny do i=1,nx @@ -880,11 +889,19 @@ subroutine eddy_length() ku = k ! conv_vel2 (Cubed convective velocity scale) is calculated in conv_scale() ! Use the value of conv_vel2 at the top of the cloud. - conv_var = conv_vel2(i,j,k)**(oneb3) +! conv_var = conv_vel2(i,j,k)**(oneb3) endif ! Compute the mixing length scale for the cloud layer that we just found - if (kl > 0 .and. ku > 0 .and. ku-kl > 1) then +! if (kl > 0 .and. ku > 0 .and. ku-kl > 1) then + if (kl > 0 .and. ku > 0 .and. ku-kl > 0) then + +! The calculation below finds the integral in the Eq. 10 in BK13 for the current cloud + conv_var = zero + do kk=kl,ku + conv_var = conv_var+ 2.5*adzi(i,j,kk)*bet(i,j,kk)*wthv_sec(i,j,kk) + enddo + conv_var = conv_var ** oneb3 if (conv_var > 0) then ! If convective vertical velocity scale > 0 @@ -894,8 +911,11 @@ subroutine eddy_length() do kk=kl,ku ! in-cloud turbulence length scale, Eq. 13 in BK13 (Eq. 4.18) - wrk = conv_var/(depth*sqrt(tke(i,j,kk))) - wrk = wrk * wrk + pt01*brunt2(i,j,kk)/tke(i,j,kk) +! wrk = conv_var/(depth*sqrt(tke(i,j,kk))) +! wrk = wrk * wrk + pt01*brunt2(i,j,kk)/tke(i,j,kk) + + wrk = conv_var/(depth*depth*sqrt(tke(i,j,kk))) & + + pt01*brunt2(i,j,kk)/tke(i,j,kk) smixt(i,j,kk) = min(max_eddy_length_scale, (one/0.3)*sqrt(one/wrk)) @@ -1012,7 +1032,8 @@ subroutine canuto() real bet2, f0, f1, f2, f3, f4, f5, iso, isosqr, & omega0, omega1, omega2, X0, Y0, X1, Y1, AA0, AA1, buoy_sgs2, & - cond, wrk, wrk1, wrk2, wrk3, avew + wrk, wrk1, wrk2, wrk3, avew +! cond, wrk, wrk1, wrk2, wrk3, avew ! ! See Eq. 7 in C01 (B.7 in Pete's dissertation) real, parameter :: c=7.0, a0=0.52/(c*c*(c-2.)), a1=0.87/(c*c), & @@ -1026,28 +1047,29 @@ subroutine canuto() kb = k-1 kc = k+1 - if(k == 1) then - kb = 1 - kc = 2 - do j=1,ny - do i=1,nx - thedz(i,j) = one / adzl(i,j,kc) - thedz2(i,j) = thedz(i,j) - enddo - enddo - elseif(k == nzm) then +! if(k == 1) then +! kb = 1 +! kc = 2 +! do j=1,ny +! do i=1,nx +! thedz(i,j) = one / adzl(i,j,kc) +! thedz2(i,j) = thedz(i,j) +! enddo +! enddo +! elseif(k == nzm) then + if (k == nzm) then kb = nzm-1 kc = nzm do j=1,ny do i=1,nx - thedz(i,j) = one / adzl(i,j,k) - thedz2(i,j) = thedz(i,j) + thedz(i,j) = one / adzi(i,j,k) + thedz2(i,j) = one / adzl(i,j,kb) enddo enddo else do j=1,ny do i=1,nx - thedz(i,j) = one / adzl(i,j,k) + thedz(i,j) = one / adzi(i,j,k) thedz2(i,j) = one / (adzl(i,j,k)+adzl(i,j,kb)) enddo enddo @@ -1067,7 +1089,27 @@ subroutine canuto() avew = half*(w_sec(i,j,k)+w_sec(i,j,kb)) - cond = 1.2*sqrt(max(1.0e-20,2.*avew*avew*avew)) +!aab +! wrk1 = bet2*iso wrk2 = thedz2(i,j)*wrk1*wrk1*iso wrk3 = thl_sec(i,j,kc) - thl_sec(i,j,kb) @@ -1114,7 +1156,11 @@ subroutine canuto() ! cond is an estimate of third moment from second oment - If the third moment is larger ! than the estimate - limit w3. - w3(i,j,k) = max(-cond, min(cond, (AA1-1.2*X1-1.5*f5)/(c-1.2*X0+AA0))) +!aab ! Implemetation of the C01 approach in this subroutine is nearly complete ! (the missing part are Eqs. 5c and 5e which are very simple) @@ -1144,7 +1190,7 @@ subroutine assumed_pdf() ! Local variables integer i,j,k,ku,kd - real wrk, wrk1, wrk2, wrk3, wrk4, bastoeps, eps_ss1, eps_ss2 + real wrk, wrk1, wrk2, wrk3, wrk4, bastoeps, eps_ss1, eps_ss2, cond_w ! bastoeps = basetemp / epsterm @@ -1154,9 +1200,6 @@ subroutine assumed_pdf() wqlsb(k) = zero wqisb(k) = zero enddo - -! sfac = scrit -! sfaci = one / sfac DO k=1,nzm @@ -1177,14 +1220,12 @@ subroutine assumed_pdf() pfac = pval * 1.0e-5 pkap = pfac ** kapa -! sfac = scrit * sqrt(pfac) -! sfac = scrit - sfac = scrit * pfac * pfac - sfaci = one / sfac - ! Read in liquid/ice static energy, total water mixing ratio, ! and vertical velocity to variables PDF needs - thl_first = hl(i,j,k) + + thl_first = hl(i,j,k) + fac_cond*qpl(i,j,k) & + + fac_sub*qpi(i,j,k) + qw_first = total_water(i,j,k) ! w_first = half*(w(i,j,kd)+w(i,j,ku)) w_first = w(i,j,k) @@ -1218,6 +1259,7 @@ subroutine assumed_pdf() ! wthlsec = wthl_sec(i,j,k) ! Compute square roots of some variables so we don't have to do it again +! if (lprnt .and. i == ipr .and. k<40) write(0,*)' w_sec=',w_sec(i,j,k),' k=',k if (w_sec(i,j,k) > zero) then sqrtw2 = sqrt(w_sec(i,j,k)) else @@ -1251,6 +1293,12 @@ subroutine assumed_pdf() aterm = half onema = half ELSE + +!aab Skew_w = w3var / (sqrtw2*sqrtw2*sqrtw2) ! Moorthi ! Proportionality coefficients between widths of each vertical velocity @@ -1279,6 +1327,8 @@ subroutine assumed_pdf() ! Find parameters of the PDF of liquid/ice static energy +! if (lprnt .and. i == ipr .and. k<40) write(0,*)' thlsec=',thlsec,' w1_2=',w1_2,' w1_1=',w1_1,& +! ' thl_first=',thl_first,' k=',k,' wthlsec=',wthlsec,sqrtw2,sqrtthl IF (thlsec <= thl_tol*thl_tol .or. abs(w1_2-w1_1) <= w_thresh) THEN thl1_1 = thl_first thl1_2 = thl_first @@ -1296,7 +1346,8 @@ subroutine assumed_pdf() wrk1 = thl1_1 * thl1_1 wrk2 = thl1_2 * thl1_2 wrk3 = three * (one - aterm*wrk1 - onema*wrk2) - wrk4 = -skew_fact*Skew_w - aterm*wrk1*thl1_1 - onema*wrk2*thl1_2 ! testing - Moorthi + wrk4 = -skew_facw*Skew_w - aterm*wrk1*thl1_1 - onema*wrk2*thl1_2 ! testing - Moorthi +! wrk4 = -skew_fact*Skew_w - aterm*wrk1*thl1_1 - onema*wrk2*thl1_2 ! testing - Moorthi ! wrk4 = - aterm*wrk1*thl1_1 - onema*wrk2*thl1_2 wrk = three * (thl1_2-thl1_1) if (wrk /= zero) then @@ -1307,9 +1358,14 @@ subroutine assumed_pdf() thl2_2 = zero endif ! +! if (lprnt .and. i == ipr .and. k<40) write(0,*)' thl1_1=',thl1_1,' sqrtthl=',sqrtthl,' thl_first=',thl_first,& +! ' thl1_2=',thl1_2,' corrtest1=',corrtest1,' w1_2=',w1_2,' w1_1=',w1_1 + thl1_1 = thl1_1*sqrtthl + thl_first thl1_2 = thl1_2*sqrtthl + thl_first +! if (lprnt .and. i == ipr .and. k<40) write(0,*)' thl1_1=',thl1_1,' thl1_2=',thl1_2 + sqrtthl2_1 = sqrt(thl2_1) sqrtthl2_2 = sqrt(thl2_2) @@ -1383,41 +1439,47 @@ subroutine assumed_pdf() ! BEGIN TO COMPUTE CLOUD PROPERTY STATISTICS - wrk1 = gamaz(i,j,k) - fac_cond*qpl(i,j,k) - fac_sub*qpi(i,j,k) - Tl1_1 = thl1_1 - wrk1 - Tl1_2 = thl1_2 - wrk1 +! wrk1 = gamaz(i,j,k) - fac_cond * qpl(i,j,k) - fac_sub * qpi(i,j,k) +! Tl1_1 = thl1_1 - wrk1 +! Tl1_2 = thl1_2 - wrk1 + + Tl1_1 = thl1_1 - gamaz(i,j,k) + Tl1_2 = thl1_2 - gamaz(i,j,k) + +! if (lprnt .and. i == ipr .and. k<40) write(0,*)' Tl1_1=',Tl1_1,' Tl1_2=',Tl1_2,& +! ' wrk1=',wrk1,' thl1_1=',thl1_1,' thl1_2=',thl1_2,' qpl=',qpl(i,j,k),' qpi=',qpi(i,j,k) ! Now compute qs esval1_1 = zero esval2_1 = zero - om1 = one eps_ss1 = eps eps_ss2 = eps + om1 = one ! Partition based on temperature for the first plume IF (Tl1_1 >= tbgmax) THEN - esval1_1 = fpvsl(Tl1_1) + esval1_1 = min(fpvsl(Tl1_1), pval) ! esval1_1 = esatw(Tl1_1) lstarn1 = lcond - ELSE IF (Tl1_1 < tbgmin) THEN - esval1_1 = fpvsi(Tl1_1) + ELSE IF (Tl1_1 <= tbgmin) THEN + esval1_1 = min(fpvsi(Tl1_1), pval) ! esval1_1 = esati(Tl1_1) lstarn1 = lsub - eps_ss1 = eps * supice + eps_ss1 = eps * supice ELSE - esval1_1 = fpvsl(Tl1_1) - esval2_1 = fpvsi(Tl1_1) + esval1_1 = min(fpvsl(Tl1_1), pval) + esval2_1 = min(fpvsi(Tl1_1), pval) ! esval1_1 = esatw(Tl1_1) ! esval2_1 = esati(Tl1_1) om1 = max(zero, min(one, a_bg*(Tl1_1-tbgmin))) lstarn1 = lcond + (one-om1)*lfus - eps_ss2 = eps * supice - ENDIF + eps_ss2 = eps * supice - qs1 = om1 * (eps_ss1*esval1_1/max(esval1_1,pval-0.378*esval1_1)) & - + (one-om1) * (eps_ss2*esval2_1/max(esval2_1,pval-0.378*esval2_1)) + ENDIF + qs1 = om1 * eps_ss1*esval1_1/(pval-0.378*esval1_1) & + + (one-om1) * eps_ss2*esval2_1/(pval-0.378*esval2_1) ! beta1 = (rgas/rv)*(lstarn1/(rgas*Tl1_1))*(lstarn1/(cp*Tl1_1)) beta1 = (lstarn1*lstarn1*onebrvcp) / (Tl1_1*Tl1_1) ! A.18 @@ -1432,22 +1494,22 @@ subroutine assumed_pdf() esval1_2 = zero esval2_2 = zero - om2 = one eps_ss1 = eps eps_ss2 = eps + om2 = one - IF (Tl1_2 < tbgmin) THEN - esval1_2 = fpvsi(Tl1_2) -! esval1_2 = esati(Tl1_2) - lstarn2 = lsub - eps_ss1 = eps * supice - ELSE IF (Tl1_2 >= tbgmax) THEN - esval1_2 = fpvsl(Tl1_2) + IF (Tl1_2 >= tbgmax) THEN + esval1_2 = min(fpvsl(Tl1_2), pval) ! esval1_2 = esatw(Tl1_2) lstarn2 = lcond + ELSE IF (Tl1_2 <= tbgmin) THEN + esval1_2 = min(fpvsi(Tl1_2), pval) +! esval1_2 = esati(Tl1_2) + lstarn2 = lsub + eps_ss1 = eps * supice ELSE - esval1_2 = fpvsl(Tl1_2) - esval2_2 = fpvsi(Tl1_2) + esval1_2 = min(fpvsl(Tl1_2), pval) + esval2_2 = min(fpvsi(Tl1_2), pval) ! esval1_2 = esatw(Tl1_2) ! esval2_2 = esati(Tl1_2) om2 = max(zero, min(one, a_bg*(Tl1_2-tbgmin))) @@ -1455,8 +1517,8 @@ subroutine assumed_pdf() eps_ss2 = eps * supice ENDIF - qs2 = om2 * (eps_ss1*esval1_2/max(esval1_2,pval-0.378*esval1_2)) & - + (one-om2) * (eps_ss2*esval2_2/max(esval2_2,pval-0.378*esval2_2)) + qs2 = om2 * eps_ss1*esval1_2/(pval-0.378*esval1_2) & + + (one-om2) * eps_ss2*esval2_2/(pval-0.378*esval2_2) ! beta2 = (rgas/rv)*(lstarn2/(rgas*Tl1_2))*(lstarn2/(cp*Tl1_2)) ! A.18 beta2 = (lstarn2*lstarn2*onebrvcp) / (Tl1_2*Tl1_2) ! A.18 @@ -1485,15 +1547,14 @@ subroutine assumed_pdf() IF (std_s1 > zero) THEN wrk = s1 / (std_s1*sqrt2) C1 = max(zero, min(one, half*(one+erf(wrk)))) ! A.15 -! if (lprnt .and. i == ipr) write(0,*)' in shoc wrk=',wrk,' s1=','std=',std_s1,& -! ' c1=',c1*100,' qs1=',qs1,' qw1_1=',qw1_1 - IF (C1 > zero) qn1 = s1*C1 + (std_s1*sqrtpii)*exp(-wrk*wrk) ! A.16 - if (qn1 < sfac) then - c1 = min(c1, qn1*sfaci) - endif +! if (lprnt .and. i == ipr .and. k<40) write(0,*)' in shoc wrk=',wrk,' s1=','std=',std_s1,& +! ' c1=',c1*100,' qs1=',qs1,' qw1_1=',qw1_1,' k=',k + +! IF (C1 > zero) qn1 = s1*C1 + (std_s1*sqrtpii)*exp(-wrk*wrk) ! A.16 + qn1 = max(zero, s1*C1 + (std_s1*sqrtpii)*exp(-wrk*wrk)) ! A.16 ELSEIF (s1 > zero) THEN - C1 = min(one, max(zero,s1*sfaci)) + C1 = one qn1 = s1 ENDIF @@ -1526,12 +1587,10 @@ subroutine assumed_pdf() IF (std_s2 > zero) THEN wrk = s2 / (std_s2*sqrt2) C2 = max(zero, min(one, half*(one+erf(wrk)))) - IF (C2 > zero) qn2 = s2*C2 + (std_s2*sqrtpii)*exp(-wrk*wrk) - if (qn2 < sfac) then - c2 = min(c2, qn2*sfaci) - endif +! IF (C2 > zero) qn2 = s2*C2 + (std_s2*sqrtpii)*exp(-wrk*wrk) + qn2 = max(zero, s2*C2 + (std_s2*sqrtpii)*exp(-wrk*wrk)) ELSEIF (s2 > zero) THEN - C2 = min(one, max(zero,s2*sfaci)) + C2 = one qn2 = s2 ENDIF @@ -1552,8 +1611,10 @@ subroutine assumed_pdf() qi1 = qn1 - ql1 qi2 = qn2 - ql2 -! if (lprnt .and. i == ipr) write(0,*)' in shoc qi=',qi1,qi2,' ql=',ql1,ql2,& -! ' c1=',c1,' c2=',c2,' s1=',s1,' s2=',s2,' k=',k +! if (lprnt .and. i == ipr .and. k<40) write(0,*)' in shoc qi=',qi1,qi2,' ql=',ql1,ql2,& +! ' c1=',c1,' c2=',c2,' s1=',s1,' s2=',s2,' k=',k,' tl1=',tl1_1,tl1_2,' om1=',om1,'om2=',om2& +! ,' tbgmin=',tbgmin,'a_bg=',a_bg + diag_qn = min(max(zero, aterm*qn1 + onema*qn2), total_water(i,j,k)) diag_ql = min(max(zero, aterm*ql1 + onema*ql2), diag_qn) @@ -1567,6 +1628,10 @@ subroutine assumed_pdf() + fac_sub *(diag_qi+qpi(i,j,k)) & + tkesbdiss(i,j,k) * (dtn/cp) ! tke dissipative heating +! if (lprnt .and. i == ipr .and. k < 40) write(0,*)' tabsout=',tabs(ipr,1,k),' k=',k& +! ,' hl=',hl(i,j,k),' gamaz=',gamaz(i,j,k),' diag_ql=',diag_ql,' qpl=',qpl(i,j,k)& +! ,' diag_qi=',diag_qi,' qpi=',qpi(i,j,k),' diag_qn =',diag_qn ,' aterm=',aterm,' onema=',onema& +! ,' qn1=',qn1 ,' qn2=',qn2,' ql1=',ql1,' ql2=',ql2 ! Update moisture fields ! Update ncpl and ncpi Anning Cheng 03/11/2016 diff --git a/gfsphysics/physics/gcycle.F90 b/gfsphysics/physics/gcycle.F90 index 0595cdc52..8a3549aeb 100644 --- a/gfsphysics/physics/gcycle.F90 +++ b/gfsphysics/physics/gcycle.F90 @@ -51,7 +51,8 @@ SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) STCFC1 (Model%nx*Model%ny*Model%lsoil), & SLCFC1 (Model%nx*Model%ny*Model%lsoil) - real(kind=kind_phys) :: sig1t, pifac + real(kind=kind_phys), parameter :: pifac=180.0/pi + real(kind=kind_phys) :: sig1t integer :: npts, len, nb, ix, ls, ios logical :: exists ! @@ -63,7 +64,6 @@ SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) sig1t = 0.0 npts = Model%nx*Model%ny ! - pifac = 180.0 / pi len = 0 do nb = 1,nblks do ix = 1,size(Grid(nb)%xlat,1) @@ -74,9 +74,9 @@ SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) OROG_UF (len) = Sfcprop(nb)%oro_uf (ix) SLIFCS (len) = Sfcprop(nb)%slmsk (ix) if ( Model%nstf_name(1) > 0 ) then - TSFFCS(len) = Sfcprop(nb)%tref (ix) + TSFFCS(len) = Sfcprop(nb)%tref (ix) else - TSFFCS(len) = Sfcprop(nb)%tsfc (ix) + TSFFCS(len) = Sfcprop(nb)%tsfc (ix) endif SNOFCS (len) = Sfcprop(nb)%weasd (ix) ZORFCS (len) = Sfcprop(nb)%zorl (ix) @@ -146,7 +146,8 @@ SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) CALL SFCCYCLE (9998, npts, Model%lsoil, SIG1T, Model%fhcyc, & Model%idate(4), Model%idate(2), & Model%idate(3), Model%idate(1), & - Model%fhour, RLA, RLO, SLMASK, & + Model%phour, RLA, RLO, SLMASK, & +! Model%fhour, RLA, RLO, SLMASK, & OROG, OROG_UF, Model%USE_UFO, Model%nst_anl, & SIHFCS, SICFCS, SITFCS, SWDFCS, SLCFC1, & VMNFCS, VMXFCS, SLPFCS, ABSFCS, TSFFCS, & diff --git a/gfsphysics/physics/gwdps.f b/gfsphysics/physics/gwdps.f index b2aa0abec..b9ea117f5 100644 --- a/gfsphysics/physics/gwdps.f +++ b/gfsphysics/physics/gwdps.f @@ -448,8 +448,8 @@ SUBROUTINE GWDPS(IM,IX,IY,KM,A,B,C,U1,V1,T1,Q1,KPBL, & real(kind=kind_phys) wk(IM) real(kind=kind_phys) bnv2lm(IM,KM),PE(IM),EK(IM),ZBK(IM),UP(IM) real(kind=kind_phys) DB(IM,KM),ANG(IM,KM),UDS(IM,KM) - real(kind=kind_phys) ZLEN, DBTMP, R, PHIANG, CDmb, DBIM, ZR - real(kind=kind_phys) ENG0, ENG1, COSANG2, SINANG2 + real(kind=kind_phys) ZLEN, DBTMP, Rtrm, PHIANG, CDmb, DBIM, ZR + real(kind=kind_phys) ENG0, ENG1 ! ! Some constants ! @@ -498,14 +498,14 @@ SUBROUTINE GWDPS(IM,IX,IY,KM,A,B,C,U1,V1,T1,Q1,KPBL, & ! !---- MOUNTAIN INDUCED GRAVITY WAVE DRAG ! - real(kind=kind_phys) TAUB(IM), XN(IM), YN(IM), UBAR(IM) & - &, VBAR(IM), ULOW(IM), OA(IM), CLX(IM) & - &, ROLL(IM), ULOI(IM), DUSFC(IM), DVSFC(IM) & + real(kind=kind_phys) TAUB(IM), XN(IM), YN(IM), UBAR(IM) & + &, VBAR(IM), ULOW(IM), OA(IM), CLX(IM) & + &, ROLL(IM), ULOI(IM), DUSFC(IM), DVSFC(IM) & &, DTFAC(IM), XLINV(IM), DELKS(IM), DELKS1(IM) ! - real(kind=kind_phys) BNV2(IM,KM), TAUP(IM,KM+1), ri_n(IM,KM) & - &, TAUD(IM,KM), RO(IM,KM), VTK(IM,KM) & - &, VTJ(IM,KM), SCOR(IM), VELCO(IM,KM-1) & + real(kind=kind_phys) BNV2(IM,KM), TAUP(IM,KM+1), ri_n(IM,KM) & + &, TAUD(IM,KM), RO(IM,KM), VTK(IM,KM) & + &, VTJ(IM,KM), SCOR(IM), VELCO(IM,KM-1) & &, bnv2bar(im) ! ! real(kind=kind_phys) VELKO(KM-1) @@ -514,15 +514,16 @@ SUBROUTINE GWDPS(IM,IX,IY,KM,A,B,C,U1,V1,T1,Q1,KPBL, & Integer kreflm(IM), iwklm(im) Integer idxzb(im), ktrial, klevm1, nmtvr ! - real(kind=kind_phys) gor, gocp, fv, gr2, bnv, fr & - &, brvf, cleff, tem, tem1, tem2, temc, temv & - &, wdir, ti, rdz, dw2, shr2, bvf2 & - &, rdelks, efact, coefm, gfobnv & - &, scork, rscor, hd, fro, rim, sira & - &, dtaux, dtauy, pkp1log, pklog - integer kmm1, kmm2, lcap, lcapp1, kbps, kbpsp1,kbpsm1 & - &, kmps, idir, nwd, i, j, k, klcap, kp1, kmpbl, npt, npr & - &, kmll + real(kind=kind_phys) gor, gocp, fv, gr2, bnv, fr & + &, brvf, cleff, tem, tem1, tem2, temc, temv& + &, wdir, ti, rdz, dw2, shr2, bvf2 & + &, rdelks, efact, coefm, gfobnv, onebg & + &, scork, rscor, hd, fro, rim, sira & + &, dtaux, dtauy, pkp1log, pklog & + &, cosang, sinang, cos2a, sin2a +! + integer kmm1, kmm2, lcap, lcapp1, kbps, kbpsp1,kbpsm1 & + &, kmps, idir, nwd, i, j, k, klcap, kp1, kmpbl, npt, npr, kmll ! &, kmll,kmds,ihit,jhit logical lprnt ! @@ -547,11 +548,12 @@ SUBROUTINE GWDPS(IM,IX,IY,KM,A,B,C,U1,V1,T1,Q1,KPBL, & ENDDO ENDDO ! - RDI = 1.0 / RD - GOR = G/RD - GR2 = G*GOR - GOCP = G/CP - FV = RV/RD - 1 + RDI = 1.0 / RD + onebg = 1.0 / g + GOR = G/RD + GR2 = G*GOR + GOCP = G/CP + FV = RV/RD - 1 ! ! NCNT = 0 KMM1 = KM - 1 @@ -560,20 +562,19 @@ SUBROUTINE GWDPS(IM,IX,IY,KM,A,B,C,U1,V1,T1,Q1,KPBL, & LCAPP1 = LCAP + 1 ! ! - IF ( NMTVR .eq. 14) then + IF ( NMTVR == 14) then ! ---- for lm and gwd calculation points RDXZB(:) = 0 ipt = 0 npt = 0 DO I = 1,IM - IF ( (elvmax(i) .GT. HMINMT) - & .and. (hprime(i) .GT. hpmin) ) then + IF (elvmax(i) > HMINMT .and. hprime(i) > hpmin) then npt = npt + 1 ipt(npt) = i - if (ipr .eq. i) npr = npt + if (ipr == i) npr = npt ENDIF ENDDO - IF (npt .eq. 0) RETURN ! No gwd/mb calculation done! + IF (npt == 0) RETURN ! No gwd/mb calculation done! ! ! if (lprnt) print *,' npt=',npt,' npr=',npr,' ipr=',ipr,' im=',im ! &,' ipt(npt)=',ipt(npt) @@ -599,7 +600,9 @@ SUBROUTINE GWDPS(IM,IX,IY,KM,A,B,C,U1,V1,T1,Q1,KPBL, & ! (*j*) 11/03: test upper limit on KMLL=km - 1 ! then do not need hncrit -- test with large hncrit first. ! KMLL = km / 2 ! maximum mtnlm height : # of vertical levels / 2 + KMLL = kmm1 + ! --- No mtn should be as high as KMLL (so we do not have to start at ! --- the top of the model but could do calc for all levels). ! @@ -613,21 +616,22 @@ SUBROUTINE GWDPS(IM,IX,IY,KM,A,B,C,U1,V1,T1,Q1,KPBL, & j = ipt(i) ! --- interpolate to max mtn height for index, iwklm(I) wk[gz] ! --- ELVMAX is limited to hncrit because to hi res topo30 orog. - pkp1log = phil(j,k+1) / G - pklog = phil(j,k) / G + pkp1log = phil(j,k+1) * onebg + pklog = phil(j,k) * onebg !!!------- ELVMAX(J) = min (ELVMAX(J) + sigfac * hprime(j), hncrit) - if ( ( ELVMAX(j) .le. pkp1log ) .and. - & ( ELVMAX(j) .ge. pklog ) ) THEN + + if (ELVMAX(j) <= pkp1log .and. ELVMAX(j) >= pklog) THEN + ! print *,' in gwdps_lm.f 1 =',k,ELVMAX(j),pklog,pkp1log,me ! --- wk for diags but can be saved and reused. - wk(i) = G * ELVMAX(j) / ( phil(j,k+1) - phil(j,k) ) - iwklm(I) = MAX(iwklm(I), k+1 ) + wk(i) = G * ELVMAX(j) / (phil(j,k+1) - phil(j,k)) + iwklm(I) = MAX(iwklm(I), k+1) ! print *,' in gwdps_lm.f 2 npt=',npt,i,j,wk(i),iwklm(i),me endif ! ! --- find at prsl levels large scale environment variables ! --- these cover all possible mtn max heights - VTJ(I,K) = T1(J,K) * (1.+FV*Q1(J,K)) + VTJ(I,K) = T1(J,K) * (1.0+FV*Q1(J,K)) VTK(I,K) = VTJ(I,K) / PRSLK(J,K) RO(I,K) = RDI * PRSL(J,K) / VTJ(I,K) ! DENSITY Kg/M**3 ENDDO @@ -649,13 +653,14 @@ SUBROUTINE GWDPS(IM,IX,IY,KM,A,B,C,U1,V1,T1,Q1,KPBL, & klevm1 = KMLL - 1 DO K = 1, klevm1 + kp1 = k + 1 DO I = 1, npt j = ipt(i) - RDZ = g / ( phil(j,k+1) - phil(j,k) ) + RDZ = g / (phil(j,kp1) - phil(j,k)) ! --- Brunt-Vaisala Frequency !> - Compute Brunt-Vaisala Frequency \f$N\f$. - BNV2LM(I,K) = (G+G) * RDZ * ( VTK(I,K+1)-VTK(I,K) ) - & / ( VTK(I,K+1)+VTK(I,K) ) + BNV2LM(I,K) = (G+G) * RDZ * (VTK(I,Kp1) - VTK(I,K)) + & / (VTK(I,Kp1) + VTK(I,K)) bnv2lm(i,k) = max( bnv2lm(i,k), bnv2min ) ENDDO ENDDO @@ -680,7 +685,7 @@ SUBROUTINE GWDPS(IM,IX,IY,KM,A,B,C,U1,V1,T1,Q1,KPBL, & !! the maximum mountain height and processing downward. DO Ktrial = KMLL, 1, -1 DO I = 1, npt - IF ( Ktrial .LT. iwklm(I) .and. kreflm(I) .eq. 0 ) then + IF ( Ktrial < iwklm(I) .and. kreflm(I) == 0 ) then kreflm(I) = Ktrial ENDIF ENDDO @@ -694,7 +699,7 @@ SUBROUTINE GWDPS(IM,IX,IY,KM,A,B,C,U1,V1,T1,Q1,KPBL, & ! DO I = 1, npt DO K = 1, Kreflm(I) - J = ipt(i) + J = ipt(i) RDELKS = DEL(J,K) * DELKS(I) UBAR(I) = UBAR(I) + RDELKS * U1(J,K) ! trial Mean U below VBAR(I) = VBAR(I) + RDELKS * V1(J,K) ! trial Mean V below @@ -715,8 +720,8 @@ SUBROUTINE GWDPS(IM,IX,IY,KM,A,B,C,U1,V1,T1,Q1,KPBL, & DO K = iwklm(I), 1, -1 PHIANG = atan2(V1(J,K),U1(J,K))*RAD_TO_DEG ANG(I,K) = ( THETA(J) - PHIANG ) - if ( ANG(I,K) .gt. 90. ) ANG(I,K) = ANG(I,K) - 180. - if ( ANG(I,K) .lt. -90. ) ANG(I,K) = ANG(I,K) + 180. + if ( ANG(I,K) > 90. ) ANG(I,K) = ANG(I,K) - 180. + if ( ANG(I,K) < -90. ) ANG(I,K) = ANG(I,K) + 180. ANG(I,K) = ANG(I,K) * DEG_TO_RAD ! !> - Compute wind speed UDS @@ -725,13 +730,14 @@ SUBROUTINE GWDPS(IM,IX,IY,KM,A,B,C,U1,V1,T1,Q1,KPBL, & !!\f] !! where \f$ minwnd=0.1 \f$, \f$U1\f$ and \f$V1\f$ are zonal and !! meridional wind components of model layer wind. + UDS(I,K) = & MAX(SQRT(U1(J,K)*U1(J,K) + V1(J,K)*V1(J,K)), minwnd) ! --- Test to see if we found Zb previously - IF (IDXZB(I) .eq. 0 ) then - PE(I) = PE(I) + BNV2lm(I,K) * - & ( G * ELVMAX(J) - phil(J,K) ) * - & ( PHII(J,K+1) - PHII(J,K) ) / (G*G) + IF (IDXZB(I) == 0 ) then + PE(I) = PE(I) + BNV2lm(I,K) * (G*ELVMAX(J) - phil(J,K)) + & * (PHII(J,K+1) - PHII(J,K)) + & * (onebg*onebg) ! --- KE ! --- Wind projected on the line perpendicular to mtn range, U(Zb(K)). ! --- kenetic energy is at the layer Zb @@ -740,7 +746,7 @@ SUBROUTINE GWDPS(IM,IX,IY,KM,A,B,C,U1,V1,T1,Q1,KPBL, & EK(I) = 0.5 * UP(I) * UP(I) ! --- Dividing Stream lime is found when PE =exceeds EK. - IF ( PE(I) .ge. EK(I) ) THEN + IF (PE(I) >= EK(I)) THEN IDXZB(I) = K RDXZB(J) = real(K,kind=kind_phys) ENDIF @@ -791,9 +797,9 @@ SUBROUTINE GWDPS(IM,IX,IY,KM,A,B,C,U1,V1,T1,Q1,KPBL, & J = ipt(i) ZLEN = 0. ! print *,' in gwdps_lm.f 9 =',i,j,IDXZB(i),me - IF ( IDXZB(I) .gt. 0 ) then + IF (IDXZB(I) > 0) then DO K = IDXZB(I), 1, -1 - IF ( PHIL(J,IDXZB(I)) .gt. PHIL(J,K) ) then + IF (PHIL(J,IDXZB(I)) > PHIL(J,K)) then !> - Calculate \f$ZLEN\f$, which sums up a number of contributions of !! elliptic obstables. @@ -802,8 +808,8 @@ SUBROUTINE GWDPS(IM,IX,IY,KM,A,B,C,U1,V1,T1,Q1,KPBL, & !!\f] !! where \f$z\f$ is the height, \f$h'\f$ is the orographic standard !! deviation (HPRIME). - ZLEN = SQRT( ( PHIL(J,IDXZB(I)) - PHIL(J,K) ) / - & ( PHIL(J,K ) + G * hprime(J) ) ) + ZLEN = SQRT( (PHIL(J,IDXZB(I)) - PHIL(J,K)) + & / (PHIL(J,K ) + G*hprime(J)) ) ! --- lm eq 14: !> - Calculate the drag coefficient to vary with the aspect ratio of !! the obstable as seen by the incident flow (see eq.14 in Lott and @@ -814,16 +820,23 @@ SUBROUTINE GWDPS(IM,IX,IY,KM,A,B,C,U1,V1,T1,Q1,KPBL, & !! where \f$\psi\f$, which is derived from THETA, is the angle between !! the incident flow direction and the normal ridge direcion. !! \f$\gamma\f$ is the orographic anisotropy (GAMMA). - COSANG2 = cos(ANG(I,K))*cos(ANG(I,K)) - SINANG2 = sin(ANG(I,K))*sin(ANG(I,K)) - if ( abs(GAMMA(J) * COSANG2 + SINANG2) - & .lt. 1.e-06 ) then - ZR = 2.0 - else - R = (COSANG2 + GAMMA(J) * SINANG2) / - & (GAMMA(J) * COSANG2 + SINANG2) - ZR = MAX( 2. - 1. / R, 0. ) - endif + + cosang = cos(ang(i,k)) + sinang = sin(ang(i,k)) + cos2a = cosang * cosang + sin2a = sinang * sinang + tem = cos2a + GAMMA(J)*sin2a + ! Here Rtrm is 1.0/R + ! -------------------- + if (abs(tem) > 1.e-06) then + Rtrm = (gamma(J)*cos2a + sin2a) / tem + elseif (tem > 0.0) then + Rtrm = (gamma(J)*cos2a + sin2a) * 1.0e6 + else + Rtrm = - (gamma(J)*cos2a + sin2a) * 1.0e6 + endif + ZR = MAX( 2.0 - Rtrm, 0. ) + ! --- (negitive of DB -- see sign at tendency) !> - In each model layer below the dividing streamlines, a drag from !! the blocked flow is exerted by the obstacle on the large scale flow. @@ -836,8 +849,7 @@ SUBROUTINE GWDPS(IM,IX,IY,KM,A,B,C,U1,V1,T1,Q1,KPBL, & !! orographic slope. DBTMP = 0.25 * CDmb * ZR * sigma(J) * - & MAX(cos(ANG(I,K)), gamma(J)*sin(ANG(I,K))) * - & ZLEN / hprime(J) + & MAX(cosANG, gamma(J)*sinANG) * ZLEN / hprime(J) DB(I,K) = DBTMP * UDS(I,K) ! ! if(lprnt .and. i .eq. npr) then @@ -856,18 +868,18 @@ SUBROUTINE GWDPS(IM,IX,IY,KM,A,B,C,U1,V1,T1,Q1,KPBL, & !............................. ! end mtn blocking section ! - ELSEIF ( NMTVR .ne. 14) then + ELSEIF ( NMTVR /= 14) then ! ---- for mb not present and gwd (nmtvr .ne .14) - ipt = 0 - npt = 0 + ipt = 0 + npt = 0 DO I = 1,IM - IF ( hprime(i) .GT. hpmin ) then + IF ( hprime(i) > hpmin ) then npt = npt + 1 ipt(npt) = i - if (ipr .eq. i) npr = npt + if (ipr == i) npr = npt ENDIF ENDDO - IF (npt .eq. 0) RETURN ! No gwd/mb calculation done! + IF (npt == 0) RETURN ! No gwd/mb calculation done! ! ! if (lprnt) print *,' NPR=',npr,' npt=',npt,' IPR=',IPR ! &,' ipt(npt)=',ipt(npt) @@ -886,7 +898,7 @@ SUBROUTINE GWDPS(IM,IX,IY,KM,A,B,C,U1,V1,T1,Q1,KPBL, & ! ! Scale cleff between IM=384*2 and 192*2 for T126/T170 and T62 ! - if (imx .gt. 0) then + if (imx > 0) then ! cleff = 1.0E-5 * SQRT(FLOAT(IMX)/384.0) ! this is inverse of CLEFF! ! cleff = 1.0E-5 * SQRT(FLOAT(IMX)/192.0) ! this is inverse of CLEFF! ! cleff = 0.5E-5 * SQRT(FLOAT(IMX)/192.0) ! this is inverse of CLEFF! @@ -903,29 +915,30 @@ SUBROUTINE GWDPS(IM,IX,IY,KM,A,B,C,U1,V1,T1,Q1,KPBL, & DO K = 1,KM DO I =1,npt J = ipt(i) - VTJ(I,K) = T1(J,K) * (1.+FV*Q1(J,K)) + VTJ(I,K) = T1(J,K) * (1.0+FV*Q1(J,K)) VTK(I,K) = VTJ(I,K) / PRSLK(J,K) RO(I,K) = RDI * PRSL(J,K) / VTJ(I,K) ! DENSITY TONS/M**3 TAUP(I,K) = 0.0 ENDDO ENDDO DO K = 1,KMM1 + kp1 = k + 1 DO I =1,npt J = ipt(i) - TI = 2.0 / (T1(J,K)+T1(J,K+1)) - TEM = TI / (PRSL(J,K)-PRSL(J,K+1)) - RDZ = g / (phil(j,k+1) - phil(j,k)) - TEM1 = U1(J,K) - U1(J,K+1) - TEM2 = V1(J,K) - V1(J,K+1) + TI = 2.0 / (T1(J,K)+T1(J,Kp1)) + TEM = TI / (PRSL(J,K)-PRSL(J,Kp1)) + RDZ = g / (phil(j,kp1) - phil(j,k)) + TEM1 = U1(J,K) - U1(J,Kp1) + TEM2 = V1(J,K) - V1(J,Kp1) DW2 = TEM1*TEM1 + TEM2*TEM2 SHR2 = MAX(DW2,DW2MIN) * RDZ * RDZ - BVF2 = G*(GOCP+RDZ*(VTJ(I,K+1)-VTJ(I,K))) * TI + BVF2 = G*(GOCP+RDZ*(VTJ(I,Kp1)-VTJ(I,K))) * TI ri_n(I,K) = MAX(BVF2/SHR2,RIMIN) ! Richardson number ! Brunt-Vaisala Frequency ! TEM = GR2 * (PRSL(J,K)+PRSL(J,K+1)) * TEM ! BNV2(I,K) = TEM * (VTK(I,K+1)-VTK(I,K))/(VTK(I,K+1)+VTK(I,K)) - BNV2(I,K) = (G+G) * RDZ * (VTK(I,K+1)-VTK(I,K)) - & / (VTK(I,K+1)+VTK(I,K)) + BNV2(I,K) = (G+G) * RDZ * (VTK(I,Kp1)-VTK(I,K)) + & / (VTK(I,Kp1)+VTK(I,K)) bnv2(i,k) = max( bnv2(i,k), bnv2min ) ENDDO ENDDO @@ -953,7 +966,7 @@ SUBROUTINE GWDPS(IM,IX,IY,KM,A,B,C,U1,V1,T1,Q1,KPBL, & DO I=1,npt j = ipt(i) tem = (prsi(j,1) - prsi(j,k)) - if (tem .lt. dpmin) iwk(i) = k + if (tem < dpmin) iwk(i) = k enddo enddo ! @@ -969,8 +982,8 @@ SUBROUTINE GWDPS(IM,IX,IY,KM,A,B,C,U1,V1,T1,Q1,KPBL, & UBAR (I) = 0.0 VBAR (I) = 0.0 ROLL (I) = 0.0 - KBPS = MAX(KBPS, kref(I)) - KMPS = MIN(KMPS, kref(I)) + KBPS = MAX(KBPS, kref(I)) + KMPS = MIN(KMPS, kref(I)) ! BNV2bar(I) = (PRSL(J,1)-PRSL(J,2)) * DELKS1(I) * BNV2(I,1) ENDDO @@ -979,7 +992,7 @@ SUBROUTINE GWDPS(IM,IX,IY,KM,A,B,C,U1,V1,T1,Q1,KPBL, & KBPSM1 = KBPS - 1 DO K = 1,KBPS DO I = 1,npt - IF (K .LT. kref(I)) THEN + IF (K < kref(I)) THEN J = ipt(i) RDELKS = DEL(J,K) * DELKS(I) UBAR(I) = UBAR(I) + RDELKS * U1(J,K) ! Mean U below kref @@ -1037,10 +1050,11 @@ SUBROUTINE GWDPS(IM,IX,IY,KM,A,B,C,U1,V1,T1,Q1,KPBL, & ENDDO ! DO K = 1,KMM1 + kp1 = k + 1 DO I = 1,npt J = ipt(i) - VELCO(I,K) = 0.5 * ((U1(J,K)+U1(J,K+1))*UBAR(I) - & + (V1(J,K)+V1(J,K+1))*VBAR(I)) + VELCO(I,K) = 0.5 * ((U1(J,K)+U1(J,Kp1))*UBAR(I) + & + (V1(J,K)+V1(J,Kp1))*VBAR(I)) VELCO(I,K) = VELCO(I,K) * ULOI(I) ! IF ((VELCO(I,K).LT.VELEPS) .AND. (VELCO(I,K).GT.0.)) THEN ! VELCO(I,K) = VELEPS @@ -1149,7 +1163,7 @@ SUBROUTINE GWDPS(IM,IX,IY,KM,A,B,C,U1,V1,T1,Q1,KPBL, & ! DO K = 1, KBPS DO I = 1,npt - IF (K .LE. kref(I)) TAUP(I,K) = TAUB(I) + IF (K <= kref(I)) TAUP(I,K) = TAUB(I) ENDDO ENDDO ! @@ -1163,9 +1177,9 @@ SUBROUTINE GWDPS(IM,IX,IY,KM,A,B,C,U1,V1,T1,Q1,KPBL, & !-----UNSTABLE LAYER IF UPPER AIR VEL COMP ALONG SURF VEL <=0 (CRIT LAY) !---- AT (U-C)=0. CRIT LAYER EXISTS AND BIT VECTOR SHOULD BE SET (.LE.) ! - IF (K .GE. kref(I)) THEN - ICRILV(I) = ICRILV(I) .OR. ( ri_n(I,K) .LT. RIC) - & .OR. (VELCO(I,K) .LE. 0.0) + IF (K >= kref(I)) THEN + ICRILV(I) = ICRILV(I) .OR. ( ri_n(I,K) < RIC) + & .OR. (VELCO(I,K) <= 0.0) ENDIF ENDDO ! @@ -1182,11 +1196,11 @@ SUBROUTINE GWDPS(IM,IX,IY,KM,A,B,C,U1,V1,T1,Q1,KPBL, & !! R_{scor}=\min \left[\frac{\tau_i}{\tau_{i+1}},1\right] !!\f] DO I = 1,npt - IF (K .GE. kref(I)) THEN - IF (.NOT.ICRILV(I) .AND. TAUP(I,K) .GT. 0.0 ) THEN + IF (K >= kref(I)) THEN + IF (.NOT.ICRILV(I) .AND. TAUP(I,K) > 0.0 ) THEN TEMV = 1.0 / max(VELCO(I,K), 0.01) ! IF (OA(I) .GT. 0. .AND. PRSI(ipt(i),KP1).GT.RLOLEV) THEN - IF (OA(I).GT.0. .AND. kp1 .lt. kint(i)) THEN + IF (OA(I) > 0. .AND. kp1 < kint(i)) THEN SCORK = BNV2(I,K) * TEMV * TEMV RSCOR = MIN(1.0, SCORK / SCOR(I)) SCOR(I) = SCORK @@ -1247,9 +1261,9 @@ SUBROUTINE GWDPS(IM,IX,IY,KM,A,B,C,U1,V1,T1,Q1,KPBL, & !! \f$\tau\f$ is unchanged (note: scaled by the ratio of the Scorer !! paramter). ! ---------------------- - IF (RIM .LE. RIC .AND. + IF (RIM <= RIC .AND. ! & (OA(I) .LE. 0. .OR. PRSI(ipt(I),KP1).LE.RLOLEV )) THEN - & (OA(I) .LE. 0. .OR. kp1 .ge. kint(i) )) THEN + & (OA(I) <= 0. .OR. kp1 >= kint(i) )) THEN TEMC = 2.0 + 1.0 / TEM2 HD = VELCO(I,K) * (2.*SQRT(TEMC)-TEMC) / BRVF TAUP(I,KP1) = TEM1 * HD * HD @@ -1298,8 +1312,8 @@ SUBROUTINE GWDPS(IM,IX,IY,KM,A,B,C,U1,V1,T1,Q1,KPBL, & ! DO K = 1,KMM1 DO I = 1,npt - IF (K .GT. kref(I) .and. PRSI(ipt(i),K) .GE. RLOLEV) THEN - IF(TAUD(I,K).NE.0.) THEN + IF (K > kref(I) .and. PRSI(ipt(i),K) >= RLOLEV) THEN + IF(TAUD(I,K) /= 0.) THEN TEM = DELTIM * TAUD(I,K) DTFAC(I) = MIN(DTFAC(I),ABS(VELCO(I,K)/TEM)) ENDIF @@ -1318,31 +1332,31 @@ SUBROUTINE GWDPS(IM,IX,IY,KM,A,B,C,U1,V1,T1,Q1,KPBL, & !! - Otherwise (k>= idxzb), orographic GWD (\f$\tau\f$) is applied. DO K = 1,KM DO I = 1,npt - J = ipt(i) - TAUD(I,K) = TAUD(I,K) * DTFAC(I) - DTAUX = TAUD(I,K) * XN(I) - DTAUY = TAUD(I,K) * YN(I) - ENG0 = 0.5*(U1(j,K)*U1(j,K)+V1(J,K)*V1(J,K)) + J = ipt(i) + TAUD(I,K) = TAUD(I,K) * DTFAC(I) + DTAUX = TAUD(I,K) * XN(I) + DTAUY = TAUD(I,K) * YN(I) + ENG0 = 0.5*(U1(j,K)*U1(j,K)+V1(J,K)*V1(J,K)) ! --- lm mb (*j*) changes overwrite GWD - if ( K .lt. IDXZB(I) .AND. IDXZB(I) .ne. 0 ) then - DBIM = DB(I,K) / (1.+DB(I,K)*DELTIM) + if ( K < IDXZB(I) .AND. IDXZB(I) /= 0 ) then + DBIM = DB(I,K) / (1.+DB(I,K)*DELTIM) A(J,K) = - DBIM * V1(J,K) + A(J,K) B(J,K) = - DBIM * U1(J,K) + B(J,K) ENG1 = ENG0*(1.0-DBIM*DELTIM)*(1.0-DBIM*DELTIM) ! if ( ABS(DBIM * U1(J,K)) .gt. .01 ) ! & print *,' in gwdps_lmi.f KDT=',KDT,I,K,DB(I,K), ! & dbim,idxzb(I),U1(J,K),V1(J,K),me - DUSFC(J) = DUSFC(J) - DBIM * U1(J,K) * DEL(J,K) - DVSFC(J) = DVSFC(J) - DBIM * V1(J,K) * DEL(J,K) + DUSFC(J) = DUSFC(J) - DBIM * U1(J,K) * DEL(J,K) + DVSFC(J) = DVSFC(J) - DBIM * V1(J,K) * DEL(J,K) else ! - A(J,K) = DTAUY + A(J,K) - B(J,K) = DTAUX + B(J,K) - ENG1 = 0.5*( - & (U1(J,K)+DTAUX*DELTIM)*(U1(J,K)+DTAUX*DELTIM) - & + (V1(J,K)+DTAUY*DELTIM)*(V1(J,K)+DTAUY*DELTIM)) - DUSFC(J) = DUSFC(J) + DTAUX * DEL(J,K) - DVSFC(J) = DVSFC(J) + DTAUY * DEL(J,K) + A(J,K) = DTAUY + A(J,K) + B(J,K) = DTAUX + B(J,K) + ENG1 = 0.5*( + & (U1(J,K)+DTAUX*DELTIM)*(U1(J,K)+DTAUX*DELTIM) + & + (V1(J,K)+DTAUY*DELTIM)*(V1(J,K)+DTAUY*DELTIM)) + DUSFC(J) = DUSFC(J) + DTAUX * DEL(J,K) + DVSFC(J) = DVSFC(J) + DTAUY * DEL(J,K) endif C(J,K) = C(J,K) + max(ENG0-ENG1,0.)/CP/DELTIM ENDDO @@ -1352,12 +1366,12 @@ SUBROUTINE GWDPS(IM,IX,IY,KM,A,B,C,U1,V1,T1,Q1,KPBL, & ! print *,' in gwdps_lm.f after B=',B(ipr,:) ! print *,' DB=',DB(ipr,:) ! endif - TEM = -1.0/G + DO I = 1,npt J = ipt(i) ! TEM = (-1.E3/G) - DUSFC(J) = TEM * DUSFC(J) - DVSFC(J) = TEM * DVSFC(J) + DUSFC(J) = - onebg * DUSFC(J) + DVSFC(J) = - onebg * DVSFC(J) ENDDO ! ! MONITOR FOR EXCESSIVE GRAVITY WAVE DRAG TENDENCIES IF NCNT>0 diff --git a/gfsphysics/physics/iccn_def.f b/gfsphysics/physics/iccn_def.f new file mode 100644 index 000000000..5e0bbe50d --- /dev/null +++ b/gfsphysics/physics/iccn_def.f @@ -0,0 +1,15 @@ + module iccn_def + use machine , only : kind_phys + implicit none + + integer, parameter :: kcipl=32, latscip=192, lonscip=288 + & , timeci=12 + + real (kind=kind_phys):: ci_lat(latscip), ci_lon(lonscip) + & , ci_time(timeci+1) + real (kind=4), allocatable, dimension(:,:,:,:):: ciplin, ccnin + real (kind=kind_phys), allocatable, dimension(:,:,:,:):: ci_pres + data ci_time/15.5,45.,74.5,105.,135.5,166.,196.5, + & 227.5,258.,288.5,319.,349.5,380.5/ + + end module iccn_def diff --git a/gfsphysics/physics/iccninterp.f90 b/gfsphysics/physics/iccninterp.f90 new file mode 100644 index 000000000..d0183d8c9 --- /dev/null +++ b/gfsphysics/physics/iccninterp.f90 @@ -0,0 +1,227 @@ + SUBROUTINE read_cidata (me, master) + use machine, only: kind_phys + use iccn_def + use netcdf +!--- in/out + integer, intent(in) :: me + integer, intent(in) :: master +!--- locals + integer :: i, n, k, ncid, varid,j,it + real(kind=kind_phys), allocatable, dimension(:) :: hyam,hybm + real(kind=4), allocatable, dimension(:,:,:) :: ci_ps + + allocate (hyam(kcipl), hybm(kcipl), ci_ps(lonscip,latscip,timeci)) + allocate (ciplin(lonscip,latscip,kcipl,timeci)) + allocate (ccnin(lonscip,latscip,kcipl,timeci)) + allocate (ci_pres(lonscip,latscip,kcipl,timeci)) + call nf_open("cam5_4_143_NAAI_monclimo2.nc", nf_NOWRITE, ncid) + call nf_inq_varid(ncid, "lat", varid) + call nf_get_var(ncid, varid, ci_lat) + call nf_inq_varid(ncid, "lon", varid) + call nf_get_var(ncid, varid, ci_lon) + call nf_inq_varid(ncid, "PS", varid) + call nf_get_var(ncid, varid, ci_ps) + call nf_inq_varid(ncid, "hyam", varid) + call nf_get_var(ncid, varid, hyam) + call nf_inq_varid(ncid, "hybm", varid) + call nf_get_var(ncid, varid, hybm) + call nf_inq_varid(ncid, "NAAI", varid) + call nf_get_var(ncid, varid, ciplin) + do it = 1,timeci + do k=1, kcipl + ci_pres(:,:,k,it)=hyam(k)*1.e5+hybm(k)*ci_ps(:,:,it) + end do + end do + call nf_close(ncid) + call nf_open("INPUT/cam5_4_143_NPCCN_monclimo2.nc", nf_NOWRITE, ncid) + call nf_inq_varid(ncid, "NPCCN", varid) + call nf_get_var(ncid, varid, ccnin) + call nf_close(ncid) +!--- + deallocate (hyam, hybm, ci_ps) + if (me == master) then + write(*,*) 'Reading in ICCN data',ci_time + endif + + END SUBROUTINE read_cidata +! +!********************************************************************** +! + SUBROUTINE setindxci(npts,dlat,jindx1,jindx2,ddy,dlon, & + iindx1,iindx2,ddx) +! + USE MACHINE, ONLY: kind_phys + USE iccn_def, ONLY: jci => latscip, ci_lat,ici=>lonscip, ci_lon +! + implicit none +! + integer npts, JINDX1(npts),JINDX2(npts),iINDX1(npts),iINDX2(npts) + real(kind=kind_phys) dlat(npts),DDY(npts),dlon(npts),DDX(npts) +! + integer i,j +! + DO J=1,npts + jindx2(j) = jci + 1 + do i=1,jci + if (dlat(j) < ci_lat(i)) then + jindx2(j) = i + exit + endif + enddo + jindx1(j) = max(jindx2(j)-1,1) + jindx2(j) = min(jindx2(j),jci) + if (jindx2(j) .ne. jindx1(j)) then + DDY(j) = (dlat(j) - ci_lat(jindx1(j))) & + / (ci_lat(jindx2(j)) - ci_lat(jindx1(j))) + else + ddy(j) = 1.0 + endif + !print *,' j=',j,' dlat=',dlat(j),' jindx12=',jindx1(j), & + ! jindx2(j),' ci_lat=',ci_lat(jindx1(j)), & + ! ci_lat(jindx2(j)),' ddy=',ddy(j) + ENDDO + + DO J=1,npts + iindx2(j) = ici + 1 + do i=1,ici + if (dlon(j) < ci_lon(i)) then + iindx2(j) = i + exit + endif + enddo + iindx1(j) = max(iindx2(j)-1,1) + iindx2(j) = min(iindx2(j),ici) + if (iindx2(j) .ne. iindx1(j)) then + ddx(j) = (dlon(j) - ci_lon(iindx1(j))) & + / (ci_lon(iindx2(j)) - ci_lon(iindx1(j))) + else + ddx(j) = 1.0 + endif + !print *,' j=',j,' dlon=',dlon(j),' iindx12=',iindx1(j), & + ! iindx2(j),' ci_lon=',ci_lon(iindx1(j)), & + ! ci_lon(iindx2(j)),' ddx=',ddx(j) + ENDDO + + RETURN + END +! +!********************************************************************** +!********************************************************************** +! + SUBROUTINE ciinterpol(me,npts,IDATE,FHOUR,jindx1,jindx2,ddy, & + iindx1,iindx2,ddx,lev, prsl, ciplout,ccnout) +! + USE MACHINE, ONLY : kind_phys + use iccn_def + implicit none + integer i1,i2, iday,j,j1,j2,l,npts,nc,n1,n2,lev,k,i + real(kind=kind_phys) fhour,temj, tx1, tx2,temi +! + + integer JINDX1(npts), JINDX2(npts),iINDX1(npts),iINDX2(npts) + integer me,idate(4) + integer IDAT(8),JDAT(8) +! + real(kind=kind_phys) DDY(npts), ddx(npts),ttt + real(kind=kind_phys) ciplout(npts,lev),cipm(npts,kcipl) + real(kind=kind_phys) ccnout(npts,lev),ccnpm(npts,kcipl) + real(kind=kind_phys) cipres(npts,kcipl), prsl(npts,lev) + real(kind=kind_phys) RINC(5), rjday + integer jdow, jdoy, jday + 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 + call w3kind(w3kindreal,w3kindint) + if(w3kindreal==4) then + rinc4=rinc + CALL W3MOVDAT(RINC4,IDAT,JDAT) + else + CALL W3MOVDAT(RINC,IDAT,JDAT) + endif +! + jdow = 0 + jdoy = 0 + jday = 0 + call w3doxdat(jdat,jdow,jdoy,jday) + rjday = jdoy + jdat(5) / 24. + IF (RJDAY .LT. ci_time(1)) RJDAY = RJDAY+365. +! + n2 = timeci + 1 + do j=2,timeci + if (rjday .lt. ci_time(j)) then + n2 = j + exit + endif + enddo + n1 = n2 - 1 + +! +! + tx1 = (ci_time(n2) - rjday) / (ci_time(n2) - ci_time(n1)) + if (n2 > timeci) n2 = n2 - timeci +! if (me .eq. 0) print *,' n1=',n1,' n2=',n2,' rjday=',rjday & +! ,'ci_time=',ci_time(n1),ci_time(n2), ci_time(timeci+1),tx1 + tx2 = 1.0 - tx1 +! + DO L=1,kcipl + 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) + cipm(j,L) = & + tx1*(TEMI*TEMJ*ciplin(I1,J1,L,n1)+DDX(j)*DDY(J)*ciplin(I2,J2,L,n1) & + +TEMI*DDY(j)*ciplin(I1,J2,L,n1)+DDX(j)*TEMJ*ciplin(I2,J1,L,n1)) & + + tx2*(TEMI*TEMJ*ciplin(I1,J1,L,n2)+DDX(j)*DDY(J)*ciplin(I2,J2,L,n2) & + +TEMI*DDY(j)*ciplin(I1,J2,L,n2)+DDX(j)*TEMJ*ciplin(I2,J1,L,n2)) + + ccnpm(j,L) = & + tx1*(TEMI*TEMJ*ccnin(I1,J1,L,n1)+DDX(j)*DDY(J)*ccnin(I2,J2,L,n1) & + +TEMI*DDY(j)*ccnin(I1,J2,L,n1)+DDX(j)*TEMJ*ccnin(I2,J1,L,n1)) & + + tx2*(TEMI*TEMJ*ccnin(I1,J1,L,n2)+DDX(j)*DDY(J)*ccnin(I2,J2,L,n2) & + +TEMI*DDY(j)*ccnin(I1,J2,L,n2)+DDX(j)*TEMJ*ccnin(I2,J1,L,n2)) + + cipres(j,L) = & + tx1*(TEMI*TEMJ*ci_pres(I1,J1,L,n1)+DDX(j)*DDY(J)*ci_pres(I2,J2,L,n1) & + +TEMI*DDY(j)*ci_pres(I1,J2,L,n1)+DDX(j)*TEMJ*ci_pres(I2,J1,L,n1)) & + + tx2*(TEMI*TEMJ*ci_pres(I1,J1,L,n2)+DDX(j)*DDY(J)*ci_pres(I2,J2,L,n2) & + +TEMI*DDY(j)*ci_pres(I1,J2,L,n2)+DDX(j)*TEMJ*ci_pres(I2,J1,L,n2)) + ENDDO + ENDDO + + DO J=1,npts + DO L=1,lev + ! noticed input is from top to bottom + if(prsl(j,l).ge.cipres(j,kcipl)) then + ciplout(j,l)=cipm(j,kcipl) + ccnout(j,l)=ccnpm(j,kcipl) + else if(prsl(j,l).le.cipres(j,1)) then + ciplout(j,l)=cipm(j,1) + ccnout(j,l)=ccnpm(j,1) + else + DO k=kcipl-1,1,-1 + IF(prsl(j,l)>cipres(j,k)) then + i1=k + i2=min(k+1,kcipl) + exit + end if + end do + ciplout(j,l)=cipm(j,i1)+(cipm(j,i2)-cipm(j,i1)) & + /(cipres(j,i2)-cipres(j,i1))*(prsl(j,l)-cipres(j,i1)) + ccnout(j,l)=ccnpm(j,i1)+(ccnpm(j,i2)-ccnpm(j,i1)) & + /(cipres(j,i2)-cipres(j,i1))*(prsl(j,l)-cipres(j,i1)) + end if + ENDDO + ENDDO +! + RETURN + END diff --git a/gfsphysics/physics/m_micro_driver.f90 b/gfsphysics/physics/m_micro_driver.f90 index a2ae816da..5b642fe0d 100644 --- a/gfsphysics/physics/m_micro_driver.f90 +++ b/gfsphysics/physics/m_micro_driver.f90 @@ -2,7 +2,8 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & &, prsl_i, prsi_i, phil, phii & &, omega_i, QLLS_i, QLCN_i, QILS_i, QICN_i& &, lwheat_i, swheat_i, w_upi, cf_upi & - &, FRLAND, ZPBL, CNV_MFD_i, CNV_PRC3_i & + &, FRLAND, ZPBL, CNV_MFD_i & +! &, FRLAND, ZPBL, CNV_MFD_i, CNV_PRC3_i & &, CNV_DQLDT_i, CLCN_i, u_i, v_i & &, TAUGWX, TAUGWY, TAUX, TAUY & &, TAUOROX, TAUOROY, CNV_FICE_i & @@ -12,9 +13,12 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & &, qgl_io, ncpr_io, ncps_io, ncgl_io & &, CLLS_io, KCBL & &, CLDREFFL, CLDREFFI, CLDREFFR, CLDREFFS & - &, CLDREFFG & - &, aero_in, skip_macro, cn_prc2, cn_snr & - &, lprnt, ipr, kdt, xlat, xlon, rhc_i) + &, CLDREFFG, aerfld_i & + &, aero_in, naai_i, npccn_i, iccn & + &, skip_macro & +! &, skip_macro, cn_prc2, cn_snr & + &, lprnt, alf_fac, qc_min, pdfflag & + &, ipr, kdt, xlat, xlon, rhc_i) use machine , only: kind_phys use physcons, grav => con_g, pi => con_pi, & @@ -25,7 +29,7 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & & VIREPS => con_fvirt, & & latvap => con_hvap, latice => con_hfus - use funcphys, only: fpvs ! saturation vapor pressure for water-ice mixed +! use funcphys, only: fpvs ! saturation vapor pressure for water-ice mixed ! use funcphys, only: fpvsl, fpvsi, fpvs ! saturation vapor pressure for water,ice & mixed use aer_cloud, only: AerProps, getINsubset,init_aer, & & aerosol_activate,AerConversion1 @@ -34,6 +38,7 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & use cldwat2m_micro,only: mmicro_pcond use micro_mg2_0, only: micro_mg_tend2_0 => micro_mg_tend, qcvar2 => qcvar use micro_mg3_0, only: micro_mg_tend3_0 => micro_mg_tend, qcvar3 => qcvar + use aerclm_def, only: ntrcaer ! use wv_saturation, only: aqsat @@ -52,12 +57,12 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & real, parameter :: one=1.0, oneb3=one/3.0, onebcp=one/cp, & & kapa=rgas*onebcp, cpbg=cp/grav, & & lvbcp=hvap*onebcp, lsbcp=(hvap+hfus)*onebcp,& - qsmall=1.e-14 + qsmall=1.e-14, rainmin = 1.0e-13 integer, parameter :: ncolmicro = 1 - integer,intent(in) :: im, ix,lm, ipr, kdt, fprcp - logical,intent(in) :: flipv, aero_in, skip_macro, lprnt - real (kind=kind_phys), intent(in):: dt_i + integer,intent(in) :: im, ix,lm, ipr, kdt, fprcp, pdfflag + logical,intent(in) :: flipv, aero_in, skip_macro, lprnt, iccn + real (kind=kind_phys), intent(in):: dt_i, alf_fac, qc_min(2) real (kind=kind_phys), dimension(ix,lm),intent(in) :: & & prsl_i,u_i,v_i,phil, omega_i, QLLS_i,QILS_i, & @@ -66,8 +71,11 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & & phii real (kind=kind_phys), dimension(im,lm),intent(in) :: & & CNV_DQLDT_i, CLCN_i, QLCN_i, QICN_i, & - & CNV_MFD_i, CNV_PRC3_i, cf_upi, CNV_FICE_i, CNV_NDROP_i, & - & CNV_NICE_i, w_upi, rhc_i + & CNV_MFD_i, cf_upi, CNV_FICE_i, CNV_NDROP_i, & +! & CNV_MFD_i, CNV_PRC3_i, cf_upi, CNV_FICE_i, CNV_NDROP_i, & + & CNV_NICE_i, w_upi, rhc_i, naai_i, npccn_i + real (kind=kind_phys), dimension(im,lm,ntrcaer),intent(in) :: & + & aerfld_i real (kind=kind_phys),dimension(im),intent(in):: TAUGWX, & & TAUGWY, TAUX, TAUY, TAUOROX, TAUOROY, FRLAND,ZPBL,xlat,xlon ! & TAUGWY, TAUX, TAUY, TAUOROX, TAUOROY,ps_i,FRLAND,ZPBL @@ -95,10 +103,11 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & & TMAXLL, USURF,LTS_UP, LTS_LOW, MIN_EXP, fracover, c2_gw, est3 real(kind=kind_phys), allocatable, dimension(:,:) :: & - & CNV_MFD,CNV_PRC3,CNV_FICE,CNV_NDROP,CNV_NICE + & CNV_MFD, CNV_FICE,CNV_NDROP,CNV_NICE +! & CNV_MFD,CNV_PRC3,CNV_FICE,CNV_NDROP,CNV_NICE real(kind=kind_phys), dimension(IM,LM)::ncpl,ncpi,omega,SC_ICE, & - & RAD_CF, radheat,Q1,U1,V1, PLO, ZLO, temp, & + & RAD_CF, radheat,Q1,U1,V1, PLO, ZLO, temp, & & QLLS, QLCN, QILS,QICN, CNV_CVW,CNV_UPDF, & ! & QLLS, QLCN, QILS,QICN, CNV_CVW,CNV_UPDF,SMAXL,SMAXI, & ! & NHET_NUC, NLIM_NUC, CDNC_NUC,INC_NUC,CNN01,CNN04,CNN1,DNHET_IMM, & @@ -113,16 +122,27 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & real(kind=kind_phys) :: QCNTOT, QTOT + real(kind=kind_phys), dimension(IM,LM):: CNV_DQLDT, CLCN, CLLS + ! real(kind=kind_phys), dimension(IM,LM):: DQRL_X, & - real(kind=kind_phys), dimension(IM,LM):: CNV_DQLDT, CLCN,CLLS, & - & CCN01,CCN04,CCN1 +! real(kind=kind_phys), dimension(IM,LM):: CNV_DQLDT, CLCN,CLLS, & +! & CCN01,CCN04,CCN1 + +! real(kind=kind_phys), allocatable, dimension(:,:) :: RHX_X & +! &, CFPDF_X, VFALLSN_CN_X, QSNOW_CN, VFALLRN_CN_X, QRAIN_CN & - real(kind=kind_phys), allocatable, dimension(:,:) :: RHX_X & - &, CFPDF_X, VFALLSN_CN_X, QSNOW_CN, VFALLRN_CN_X, QRAIN_CN & - &, REV_CN_X, RSU_CN_X, DLPDF_X, DIPDF_X, ALPHT_X, PFRZ & - &, ACLL_CN_X, ACIL_CN_X, DQRL_X & - &, PFI_CN_X, PFL_CN_X, QST3, DZET, QDDF3 - real(kind=kind_phys), allocatable, dimension(:) :: vmip + real(kind=kind_phys), allocatable, dimension(:,:) :: & + & ALPHT_X, PFRZ +! & QSNOW_CN, QRAIN_CN, ALPHT_X, PFRZ + +! real(kind=kind_phys), allocatable, dimension(:,:) :: & +! & QSNOW_CN, QRAIN_CN & +!! &, CFPDF_X, QSNOW_CN, QRAIN_CN & +! &, ALPHT_X, PFRZ +!! &, REV_CN_X, RSU_CN_X, DLPDF_X, DIPDF_X, ALPHT_X, PFRZ & +!! &, ACLL_CN_X, ACIL_CN_X, DQRL_X & +!! &, PFI_CN_X, PFL_CN_X, QST3, DZET, QDDF3 +!! real(kind=kind_phys), allocatable, dimension(:) :: vmip ! real(kind=kind_phys), dimension(IM,LM) :: QDDF3 ! real(kind=kind_phys), dimension(IM,LM):: QST3, DZET, QDDF3 @@ -132,7 +152,8 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & ! & VFALLRN_CN_X, QRAIN_CN, dum real(kind=kind_phys), dimension(IM,LM+1) :: ZET - real(kind=kind_phys), dimension(IM,0:LM) :: PLE, kh + real(kind=kind_phys), dimension(IM,0:LM) :: PLE, kh + ! real(kind=kind_phys), dimension(IM,0:LM) :: PLE, PKE, kh ! &, PFI_CN_X, PFL_CN_X @@ -144,8 +165,9 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & real(kind=kind_phys), dimension(1:LM,10) :: rndstr8,naconr8 - real(kind=kind_phys), dimension(IM) :: CN_PRC2,CN_SNR,CN_ARFX,& - & LS_SNR,LS_PRC2, TPREC +! real(kind=kind_phys), dimension(IM) :: CN_PRC2,CN_SNR,CN_ARFX,& +! & LS_SNR, LS_PRC2, TPREC + real(kind=kind_phys), dimension(IM) :: LS_SNR, LS_PRC2 ! & VMIP, twat ! Anning Cheng 10/24/2016 twat for total water, diagnostic purpose integer, dimension(IM) :: KCBL @@ -206,6 +228,10 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & &, ncnstr8 = 100.0e6 real(kind=kind_phys):: k_gw, maxkh, tausurf_gw, overscale, tx1, rh1_r8 + real(kind=kind_phys):: t_ice_denom + + integer, dimension(1) :: lev_sed_strt ! sedimentation start level + real(kind=kind_phys), parameter :: sig_sed_strt=0.05 ! normalized pressure at sedimentation start real(kind=kind_phys),dimension(3) :: ccn_diag real(kind=kind_phys),dimension(58) :: cloudparams @@ -240,8 +266,9 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & ! &, 0.0 , 0.0 , 1.0e-3, 8.0e-4, 1.0 , 0.95 , 1.0 , 0.0 , 880.0& ! &, 0.0 , 0.0 , 1.0e-3, 8.0e-4, 1.0 , 0.95 , 1.0 , 0.0 , 980.0& &, 1.0 , 1.0 , 1.0 , 0.0 , 0.0 , 1.e-5, 2.e-5, 2.1e-5, 4.e-5& -! &, 3e-5, 0.1 , 4.0 , 250./ - &, 3e-5, 0.1 , 1.0 , 150./ +! &, 3e-5, 0.1 , 4.0 , 250./ ! Annings version + &, 3e-5, 0.1 , 4.0 , 150./ ! Annings version +! &, 3e-5, 0.1 , 1.0 , 150./ ! rhr8 = 1.0 @@ -276,6 +303,10 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & temp(i,k) = t_io(i,ll) radheat(i,k) = lwheat_i(i,ll) + swheat_i(i,ll) rhc(i,k) = rhc_i(i,ll) + if (iccn) then + CDNC_NUC(i,k) = npccn_i(i,ll) + INC_NUC(i,k) = naai_i (i,ll) + endif END DO END DO @@ -287,13 +318,14 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & END DO END DO if (.not. skip_macro) then - allocate(CNV_MFD(im,lm), CNV_PRC3(im,lm), CNV_FICE(im,lm) & +! allocate(CNV_MFD(im,lm), CNV_PRC3(im,lm), CNV_FICE(im,lm) & + allocate(CNV_MFD(im,lm), CNV_FICE(im,lm) & &, CNV_NDROP(im,lm), CNV_NICE(im,lm)) DO K=1, LM ll = lm-k+1 DO I = 1,IM CNV_MFD(i,k) = CNV_MFD_i(i,ll) - CNV_PRC3(i,k) = CNV_PRC3_i(i,ll) +! CNV_PRC3(i,k) = CNV_PRC3_i(i,ll) CNV_FICE(i,k) = CNV_FICE_i(i,ll) CNV_NDROP(i,k) = CNV_NDROP_i(i,ll) CNV_NICE(i,k) = CNV_NICE_i(i,ll) @@ -332,6 +364,10 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & temp(i,k) = t_io(i,k) radheat(i,k) = lwheat_i(i,k) + swheat_i(i,k) rhc(i,k) = rhc_i(i,k) + if (iccn) then + CDNC_NUC(i,k) = npccn_i(i,k) + INC_NUC(i,k) = naai_i (i,k) + endif END DO END DO @@ -342,12 +378,13 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & END DO END DO if (.not. skip_macro) then - allocate(CNV_MFD(im,lm), CNV_PRC3(im,lm), CNV_FICE(im,lm) & +! allocate(CNV_MFD(im,lm), CNV_PRC3(im,lm), CNV_FICE(im,lm) & + allocate(CNV_MFD(im,lm), CNV_FICE(im,lm) & &, CNV_NDROP(im,lm), CNV_NICE(im,lm)) DO K=1, LM DO I = 1,IM CNV_MFD(i,k) = CNV_MFD_i(i,k) - CNV_PRC3(i,k) = CNV_PRC3_i(i,k) +! CNV_PRC3(i,k) = CNV_PRC3_i(i,k) CNV_FICE(i,k) = CNV_FICE_i(i,k) CNV_NDROP(i,k) = CNV_NDROP_i(i,k) CNV_NICE(i,k) = CNV_NICE_i(i,k) @@ -415,39 +452,39 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & ! enddo !------------------------------------------------------------------------------ - if (.not. skip_macro) then - allocate(qddf3(im,lm)) - allocate(vmip(im)) - do i=1,im - vmip(i) = 0.0 - enddo - DO K = LM, 1, -1 - do i=1,im - if (zet(i,k) < 3000.0) then -! qddf3(i,k) = - (zet(i,k) - 3000.0) * zet(i,k) * mass(i,k) - qddf3(i,k) = - (zet(i,k) - 3000.0) * zet(i,k) & - & * (ple(i,k) - ple(i,k-1)) * (100.0/grav) - else - qddf3(i,k) = 0.0 - endif - vmip(i) = vmip(i) + qddf3(i,k) - enddo - END DO - do i=1,im - if (vmip(i) /= 0.0) vmip(i) = 1.0 / vmip(i) - enddo - DO K = 1,LM - do i=1,im - QDDF3(i,K) = QDDF3(i,K) * VMIP(i) - enddo - END DO - deallocate (vmip) - endif +! if (.not. skip_macro) then +! allocate(qddf3(im,lm)) +! allocate(vmip(im)) +! do i=1,im +! vmip(i) = 0.0 +! enddo +! DO K = LM, 1, -1 +! do i=1,im +! if (zet(i,k) < 3000.0) then +!! qddf3(i,k) = - (zet(i,k) - 3000.0) * zet(i,k) * mass(i,k) +! qddf3(i,k) = - (zet(i,k) - 3000.0) * zet(i,k) & +! & * (ple(i,k) - ple(i,k-1)) * (100.0/grav) +! else +! qddf3(i,k) = 0.0 +! endif +! vmip(i) = vmip(i) + qddf3(i,k) +! enddo +! END DO +! do i=1,im +! if (vmip(i) /= 0.0) vmip(i) = 1.0 / vmip(i) +! enddo +! DO K = 1,LM +! do i=1,im +! QDDF3(i,K) = QDDF3(i,K) * VMIP(i) +! enddo +! END DO +! deallocate (vmip) +! endif do l=lm-1,1,-1 do i=1,im - tx1 = 0.5 * (temp(i,l+1) + temp(i,l)) + tx1 = 0.5 * (temp(i,l+1) + temp(i,l)) kh(i,l) = 3.55e-7*tx1**2.5*(rgas*0.01) / ple(i,l) !kh molecule diff only needing refinement enddo end do @@ -457,21 +494,23 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & enddo do L=LM,1,-1 do i=1,im - blk_l(i,l) = 1.0 / ( 1.0/max(0.15*ZPBL(i),0.4*zlo(i,lm-1))& - & + 1.0/(zlo(i,l)*.4) ) - - SC_ICE(i,l) = 1.0 - NCPL(i,l) = MAX( NCPL(i,l), 0.) - NCPI(i,l) = MAX( NCPI(i,l), 0.) - RAD_CF(i,l) = max(0.0, min(CLLS(i,l)+CLCN(i,l), 1.0)) - CDNC_NUC(i,l) = 0.0 - INC_NUC(i,l) = 0.0 + blk_l(i,l) = 1.0 / ( 1.0/max(0.15*ZPBL(i),0.4*zlo(i,lm-1))& + & + 1.0/(zlo(i,l)*.4) ) + + SC_ICE(i,l) = 1.0 + NCPL(i,l) = MAX( NCPL(i,l), 0.) + NCPI(i,l) = MAX( NCPI(i,l), 0.) + RAD_CF(i,l) = max(0.0, min(CLLS(i,l)+CLCN(i,l), 1.0)) + if (.not. iccn) then + CDNC_NUC(i,l) = 0.0 + INC_NUC(i,l) = 0.0 + endif enddo end do ! T_ICE_ALL = TICE - 40.0 T_ICE_ALL = CLOUDPARAMS(33) + TICE - + t_ice_denom = 1.0 / (tice - t_ice_all) do l=1,lm @@ -501,12 +540,31 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & !======================================================================================================================= !======================================================================================================================= !======================================================================================================================= - if(aero_in) then - allocate(AERMASSMIX (IM,LM, 15)) - AERMASSMIX = 1.e-15 - call AerConversion1 (AERMASSMIX, AeroProps) - deallocate(AERMASSMIX) +! if(aero_in) then +! allocate(AERMASSMIX (IM,LM, 15)) +! AERMASSMIX = 1.e-15 +! call AerConversion1 (AERMASSMIX, AeroProps) +! deallocate(AERMASSMIX) +! end if + +! + do k=1,lm + do i=1,im + call init_Aer(AeroProps(I, K)) + enddo + enddo +! + + allocate(AERMASSMIX(IM,LM,15)) + if ( aero_in ) then + AERMASSMIX(:,:,1:ntrcaer) = aerfld_i(:,:,1:ntrcaer) + else + AERMASSMIX(:,:,1:5) = 1.e-6 + AERMASSMIX(:,:,6:15) = 2.e-14 end if + call AerConversion1 (AERMASSMIX, AeroProps) + deallocate(AERMASSMIX) + use_average_v = .false. if (USE_AV_V > 0.0) then use_average_v = .true. @@ -580,7 +638,7 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & call gw_prof (1, LM, 1, tm_gw, pm_gw, pi_gw, rhoi_gw, ni_gw, & - & ti_gw, nm_gw) + & ti_gw, nm_gw, q1(i,:)) do k=1,lm nm_gw(k) = max(nm_gw(k), 0.005) @@ -630,7 +688,7 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & kbmin = KCBL(I) - kbmin = min(int(kbmin), LM-1)-4 + kbmin = min(kbmin, LM-1) - 4 do K = 1, LM wparc_turb(k) = KH(I,k) / lc_turb(k) dummyW(k) = 10.0 @@ -669,7 +727,7 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & do K = 1, LM - if (plevr8(K) > 100.0) then + if (plevr8(K) > 70.0) then ccn_diag(1) = 0.001 ccn_diag(2) = 0.004 @@ -681,16 +739,19 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & tauxr8 = ter8(K) endif - if(aero_in) then +! if(aero_in) then AeroAux = AeroProps(I, K) - else - call init_Aer(AeroAux) - call init_Aer(AeroAux_b) - endif +! else +! call init_Aer(AeroAux) +! call init_Aer(AeroAux_b) +! endif pfrz_inc_r8(k) = 0.0 rh1_r8 = 0.0 !related to cnv_dql_dt, needed to changed soon +! if (lprnt) write(0,*)' bef aero npccninr8=',npccninr8(k),' k=',k & +! &,' ccn_param=',ccn_param,' in_param=',in_param & +! &,' AeroAux%kap=',AeroAux%kap call aerosol_activate(tauxr8, plevr8(K), swparc(K), & & wparc_ls(K), AeroAux, npre8(k), dpre8(k), ccn_diag, & @@ -703,12 +764,14 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & & CCN_PARAM, IN_PARAM, fdust_drop, & & fsoot_drop,pfrz_inc_r8(K),sigma_nuc_r8, rh1_r8, & & size(ccn_diag)) +! & size(ccn_diag), lprnt) +! if (lprnt) write(0,*)' aft aero npccninr8=',npccninr8(k),' k=',k if (npccninr8(k) < 1.0e-12) npccninr8(k) = 0.0 - CCN01(I,K) = max(ccn_diag(1)*1e-6, 0.0) - CCN04(I,K) = max(ccn_diag(2)*1e-6, 0.0) - CCN1 (I,K) = max(ccn_diag(3)*1e-6, 0.0) +! CCN01(I,K) = max(ccn_diag(1)*1e-6, 0.0) +! CCN04(I,K) = max(ccn_diag(2)*1e-6, 0.0) +! CCN1 (I,K) = max(ccn_diag(3)*1e-6, 0.0) @@ -739,10 +802,27 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & NLIM_NUC(I,k) = nlimicer8(k) * 1e-6 SC_ICE(I,k) = min(max(sc_icer8(k),1.0),2.0) ! SC_ICE(I,k) = min(max(sc_icer8(k),1.0),1.2) - if(temp(i,k) > T_ICE_ALL) SC_ICE(i,k) = 1.0 - if(temp(i,k) > TICE) SC_ICE(i,k) = rhc(i,k) - CDNC_NUC(I,k) = npccninr8(k) - INC_NUC (I,k) = naair8(k) +! if(temp(i,k) < T_ICE_ALL) SC_ICE(i,k) = max(SC_ICE(I,k), 1.2) +! if(temp(i,k) < T_ICE_ALL) SC_ICE(i,k) = max(SC_ICE(I,k), 1.5) +! if(temp(i,k) > T_ICE_ALL) SC_ICE(i,k) = 1.0 +! if(temp(i,k) > TICE) SC_ICE(i,k) = rhc(i,k) +! + if(temp(i,k) < T_ICE_ALL) then +! SC_ICE(i,k) = max(SC_ICE(I,k), 1.2) + SC_ICE(i,k) = max(SC_ICE(I,k), 1.5) + elseif(temp(i,k) > TICE) then + SC_ICE(i,k) = rhc(i,k) + else +! SC_ICE(i,k) = 1.0 +! tx1 = max(SC_ICE(I,k), 1.2) + tx1 = max(SC_ICE(I,k), 1.5) + SC_ICE(i,k) = ((tice-temp(i,k))*tx1 + (temp(i,k)-t_ice_all)*rhc(i,k)) & + * t_ice_denom + endif + if (.not. iccn) then + CDNC_NUC(I,k) = npccninr8(k) + INC_NUC (I,k) = naair8(k) + endif NHET_IMM(I,k) = max(nhet_immr8(k), 0.0) DNHET_IMM(I,k) = max(dnhet_immr8(k), 0.0) NHET_DEP(I,k) = nhet_depr8(k) * 1e-6 @@ -795,50 +875,64 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & ! if(lprnt) write(0,*)' bef macro_cloud clcn=',clcn(ipr,:) ! if(lprnt) write(0,*)' bef macro_cloud clls=',clls(ipr,:) - allocate(RHX_X(im,lm), CFPDF_X(im,lm), VFALLSN_CN_X(im,lm), & - & QSNOW_CN(im,lm), VFALLRN_CN_X(im,lm), QRAIN_CN(im,lm),& - & REV_CN_X(im,lm), RSU_CN_X(im,lm), DLPDF_X(im,lm), & - & DIPDF_X(im,lm), ALPHT_X(im,lm), PFRZ(im,lm), & - & ACLL_CN_X(im,lm), ACIL_CN_X(im,lm), DQRL_X(im,lm), & - & DZET(im,lm), qst3(im,lm)) - allocate (PFI_CN_X(im,0:lm), PFL_CN_X(im,0:lm)) - - do L=LM,1,-1 - do i=1,im - DZET(i,L) = ZET(i,L) - ZET(i,L+1) - tx1 = plo(i,l)*100.0 - est3 = min(tx1, fpvs(temp(i,l))) - qst3(i,l) = min(eps*est3/max(tx1+epsm1*est3,1.0e-10),1.0) -! MASS(i,l) = (ple(i,l) - ple(i,l-1)) * (100.0/grav) - enddo - enddo - do k=1,lm - do i=1,im - REV_CN_X(i,k) = 0.0 - RSU_CN_X(i,k) = 0.0 - enddo - enddo - do k=0,lm - do i=1,im - PFI_CN_X(i,k) = 0.0 - PFL_CN_X(i,k) = 0.0 - enddo - enddo +! allocate(RHX_X(im,lm), CFPDF_X(im,lm), VFALLSN_CN_X(im,lm), & + allocate( & +! & QSNOW_CN(im,lm), VFALLRN_CN_X(im,lm), QRAIN_CN(im,lm),& +! & QSNOW_CN(im,lm), QRAIN_CN(im,lm),& +! & REV_CN_X(im,lm), RSU_CN_X(im,lm), DLPDF_X(im,lm), & +! & DIPDF_X(im,lm), ALPHT_X(im,lm), PFRZ(im,lm), & + & ALPHT_X(im,lm), PFRZ(im,lm)) +! & ACLL_CN_X(im,lm), ACIL_CN_X(im,lm), DQRL_X(im,lm) +! & ACLL_CN_X(im,lm), ACIL_CN_X(im,lm), DQRL_X(im,lm), & +! & DZET(im,lm)) +! & DZET(im,lm), qst3(im,lm)) +! allocate (PFI_CN_X(im,0:lm), PFL_CN_X(im,0:lm)) + +! do L=LM,1,-1 +! do i=1,im +! DZET(i,L) = ZET(i,L) - ZET(i,L+1) +! tx1 = plo(i,l)*100.0 +! est3 = min(tx1, fpvs(temp(i,l))) +! qst3(i,l) = min(eps*est3/max(tx1+epsm1*est3,1.0e-10),1.0) +!! MASS(i,l) = (ple(i,l) - ple(i,l-1)) * (100.0/grav) +! enddo +! enddo +! do k=1,lm +! do i=1,im +! REV_CN_X(i,k) = 0.0 +! RSU_CN_X(i,k) = 0.0 +! enddo +! enddo +! do k=0,lm +! do i=1,im +! PFI_CN_X(i,k) = 0.0 +! PFL_CN_X(i,k) = 0.0 +! enddo +! enddo ! call macro_cloud (IM, LM, DT_MOIST, PLO, PLE, PK, FRLAND, & - call macro_cloud (IM, LM, DT_MOIST, PLO, PLE, FRLAND, & - & CNV_MFD, CNV_DQLDT, CNV_PRC3, CNV_UPDF, & - & U1, V1, temp, Q1, QLLS, QLCN, QILS, QICN, & +! call macro_cloud (IM, LM, DT_MOIST, PLO, PLE, FRLAND, & + call macro_cloud (IM, LM, DT_MOIST, alf_fac, PLO, PLE, & + & CNV_DQLDT, & +! & CNV_MFD, CNV_DQLDT, & +! & CNV_MFD, CNV_DQLDT, CNV_PRC3, CNV_UPDF, & +! & U1, V1, temp, Q1, QLLS, QLCN, QILS, QICN, & + & temp, Q1, QLLS, QLCN, QILS, QICN, & ! & U1, V1, TH1, Q1, QLLS, QLCN, QILS, QICN, & - & CLCN, CLLS, CN_PRC2, CN_ARFX, CN_SNR, & - & CLOUDPARAMS, SCLMFDFR, QST3, DZET, QDDF3, & - & RHX_X, REV_CN_X, RSU_CN_X, & - & ACLL_CN_X, ACIL_CN_X, PFL_CN_X, & - & PFI_CN_X, DLPDF_X, DIPDF_X, & - & ALPHT_X, CFPDF_X, DQRL_X, VFALLSN_CN_X, & - & VFALLRN_CN_X, CNV_FICE, CNV_NDROP, CNV_NICE, & + & CLCN, CLLS, & +! & CLCN, CLLS, CN_PRC2, CN_ARFX, CN_SNR, & + & CLOUDPARAMS, SCLMFDFR, & +! & CLOUDPARAMS, SCLMFDFR, QST3, DZET, QDDF3, & +! & RHX_X, REV_CN_X, RSU_CN_X, & +! & ACLL_CN_X, ACIL_CN_X, PFL_CN_X, & +! & PFI_CN_X, DLPDF_X, DIPDF_X, & +! & ALPHT_X, CFPDF_X, DQRL_X, VFALLSN_CN_X, & +! & VFALLRN_CN_X, CNV_FICE, CNV_NDROP, CNV_NICE, & + & ALPHT_X, & + & CNV_FICE, CNV_NDROP, CNV_NICE, & & SC_ICE, NCPL, NCPI, PFRZ, & - & QRAIN_CN, QSNOW_CN, KCBL, lprnt, ipr, rhc) + & lprnt, ipr, rhc, pdfflag, qc_min) +! & QRAIN_CN, QSNOW_CN, KCBL, lprnt, ipr, rhc) ! if (lprnt) write(0,*) ' in micro qicn3=',qicn(ipr,25) @@ -859,13 +953,15 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & endif ! temp(i,k) = th1(i,k) * PK(i,k) RAD_CF(i,k) = min(CLLS(i,k)+CLCN(i,k), 1.0) - - if (PFRZ(i,k) > 0.0) then - INC_NUC(i,k) = INC_NUC(i,k) * PFRZ(i,k) - NHET_NUC(i,k) = NHET_NUC(i,k) * PFRZ(i,k) - else - INC_NUC(i,k) = 0.0 - NHET_NUC(i,k) = 0.0 +! + if (.not. iccn) then + if (PFRZ(i,k) > 0.0) then + INC_NUC(i,k) = INC_NUC(i,k) * PFRZ(i,k) + NHET_NUC(i,k) = NHET_NUC(i,k) * PFRZ(i,k) + else + INC_NUC(i,k) = 0.0 + NHET_NUC(i,k) = 0.0 + endif endif enddo @@ -873,26 +969,35 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & !make sure QI , NI stay within T limits - call meltfrz_inst(IM, LM, TEMP, QLLS, QLCN, QILS, QICN, NCPL, NCPI) +! call meltfrz_inst(IM, LM, TEMP, QLLS, QLCN, QILS, QICN, NCPL, NCPI) !============ a little treatment of cloud before micorphysics -! call update_cld(im,lm,DT_MOIST, ALPHT_X & -! &, INT(CLOUDPARAMS(57)), PLO , Q1, QLLS & +! call update_cld(im,lm,DT_MOIST, ALPHT_X, qc_min & +! &, pdfflag, PLO , Q1, QLLS & ! &, QLCN, QILS, QICN, TEMP & ! &, CLLS, CLCN, SC_ICE, NCPI & -! &, NCPL, INC_NUC, RHCmicro ) +! &, NCPL) +!! &, NCPL, INC_NUC) !============ Put cloud fraction back in contact with the PDF (Barahona et al., GMD, 2014)============ - deallocate(RHX_X, CFPDF_X, VFALLSN_CN_X, & - & QSNOW_CN, VFALLRN_CN_X, QRAIN_CN, REV_CN_X, RSU_CN_X,& - & DLPDF_X, DIPDF_X, PFRZ, ACLL_CN_X, ACIL_CN_X, DQRL_X,& - & PFI_CN_X, PFL_CN_X, DZET, qst3, qddf3) +!make sure QI , NI stay within T limits + call meltfrz_inst(IM, LM, TEMP, QLLS, QLCN, QILS, QICN, NCPL, NCPI) + + +! deallocate(RHX_X, CFPDF_X, VFALLSN_CN_X, & + deallocate( & +! & QSNOW_CN, VFALLRN_CN_X, QRAIN_CN, REV_CN_X, RSU_CN_X,& +! & QSNOW_CN, QRAIN_CN, & + & PFRZ) +! & DLPDF_X, DIPDF_X, PFRZ, ACLL_CN_X, ACIL_CN_X, DQRL_X,& +! & PFI_CN_X, PFL_CN_X) +! & PFI_CN_X, PFL_CN_X, DZET, qst3, qddf3) else - do i=1,im - CN_PRC2(i) = 0.0 - CN_SNR(i) = 0.0 - enddo +! do i=1,im +! CN_PRC2(i) = 0.0 +! CN_SNR(i) = 0.0 +! enddo endif ! .not. skip_macro @@ -908,14 +1013,8 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & do k=1,lm do i=1,im QCNTOT = QLCN(i,k) + QICN(i,k) - QTOT = QCNTOT + QLLS(i,k) + QILS(i,k) QL_TOT(i,k) = QLCN(i,k) + QLLS(i,k) QI_TOT(i,k) = QICN(i,k) + QILS(i,k) - if (QTOT > 0.0) then - FQA(i,k) = min(max(QCNTOT / QTOT, 0.0), 1.0) - else - FQA(i,k) = 0.0 - endif ! Anning if negative, borrow water and ice from vapor 11/23/2016 if (QL_TOT(i,k) < 0.0) then Q1(i,k) = Q1(i,k) + QL_TOT(i,k) @@ -927,6 +1026,12 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & TEMP(i,k) = TEMP(i,k) - lsbcp*QI_TOT(i,k) QI_TOT(i,k) = 0.0 endif + QTOT = QL_TOT(i,k) + QI_TOT(i,k) + if (QTOT > 0.0) then + FQA(i,k) = min(max(QCNTOT / QTOT, 0.0), 1.0) + else + FQA(i,k) = 0.0 + endif enddo enddo @@ -952,7 +1057,8 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & naair8(k) = 0.0 omegr8(k) = 0.0 - tx1 = MIN(CLLS(I,k) + CLCN(I,k), 0.99) +! tx1 = MIN(CLLS(I,k) + CLCN(I,k), 0.99) + tx1 = MIN(CLLS(I,k) + CLCN(I,k), 1.00) if (tx1 > 0.0) then cldfr8(k) = min(max(tx1, 0.00001), 1.0) else @@ -997,30 +1103,31 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & endif - if(aero_in) then +! if(aero_in) then AeroAux = AeroProps(I, K) - else - call init_Aer(AeroAux) - end if +! else +! call init_Aer(AeroAux) +! end if call getINsubset(1, AeroAux, AeroAux_b) naux = AeroAux_b%nmods if (nbincontactdust < naux) then nbincontactdust = naux - end if + endif naconr8(K, 1:naux) = AeroAux_b%num(1:naux) rndstr8(K, 1:naux) = AeroAux_b%dpg(1:naux) * 0.5 +! The following moved inside of if(fprcp <= 0) then loop ! Get black carbon properties for contact ice nucleation - call getINsubset(2, AeroAux, AeroAux_b) - nsootr8 (K) = sum(AeroAux_b%num) - naux = AeroAux_b%nmods - rnsootr8 (K) = sum(AeroAux_b%dpg(1:naux))/naux +! call getINsubset(2, AeroAux, AeroAux_b) +! nsootr8 (K) = sum(AeroAux_b%num) +! naux = AeroAux_b%nmods +! rnsootr8 (K) = sum(AeroAux_b%dpg(1:naux))/naux pdelr8(k) = (PLE(I,k) - PLE(I,k-1)) * 100.0 - rpdelr8(k) = 1./pdelr8(k) - plevr8(k) = 100.*PLO(I,k) + rpdelr8(k) = 1. / pdelr8(k) + plevr8(k) = 100. * PLO(I,k) zmr8(k) = ZLO(I,k) - ficer8(k) = qir8(k) /( qcr8(k)+qir8(k) + 1.e-10 ) + ficer8(k) = qir8(k) / (qcr8(k)+qir8(k) + 1.e-10) omegr8(k) = WSUB(I,k) ! alphar8(k) = max(alpht_x(i,k)/maxval(alpht_x(i,:))*8.,0.5) ! alphar8(k) = qcvar2 @@ -1031,6 +1138,18 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & pintr8(k) = PLE(I,k-1) * 100.0 kkvhr8(k) = KH(I,k-1) END DO + + lev_sed_strt = 0 + tx1 = 1.0 / pintr8(lm+1) + do k=1,lm + if (plevr8(k)*tx1 < sig_sed_strt) then + lev_sed_strt(1) = k + endif + enddo + lev_sed_strt(1) = max(lm/6, min(lm/3,lev_sed_strt(1))) +! if (kdt == 1) & +! write(0,*)' lev_sed_strt=',lev_sed_strt,' plevr8=',plevr8(lev_sed_strt), & +! ' pintr8=',pintr8(lm+1),' sig_sed_strt=',sig_sed_strt ! ! do k=1,lm ! if (cldfr8(k) <= 0.2 ) then @@ -1051,7 +1170,17 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & !!!Call to MG microphysics. Lives in cldwat2m_micro.f ! ttendr8, qtendr8,cwtendr8, not used so far Anning noted August 2015 - if (fprcp <= 0) then ! if fprcp=-1, then Anning's code for MG2 will be used + if (fprcp <= 0) then ! if fprcp = -1, then Anning's code for MG2 will be used + ! if fprcp = 0, then MG1 is used + +! Get black carbon properties for contact ice nucleation + do k=1,lm + call getINsubset(2, AeroAux, AeroAux_b) + nsootr8 (K) = sum(AeroAux_b%num) + naux = AeroAux_b%nmods + rnsootr8 (K) = sum(AeroAux_b%dpg(1:naux))/naux + enddo + call mmicro_pcond ( ncolmicro, ncolmicro, & & dt_r8, ter8, ttendr8, & & ncolmicro, LM , qvr8, & @@ -1090,6 +1219,7 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & ! if (lprint) write(0,*)' prectr8=',prectr8(1), & ! & ' precir8=',precir8(1) + LS_PRC2(I) = max(1000.*(prectr8(1)-precir8(1)), 0.0) LS_SNR(I) = max(1000.*precir8(1), 0.0) @@ -1109,14 +1239,15 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & NCPR(I,k) = nrr8(k) NCPS(I,k) = nsr8(k) - CLDREFFL(I,k) = min(max(effcr8(k), 10.),150.) - CLDREFFI(I,k) = min(max(effir8(k), 20.),150.) - CLDREFFR(I,k) = max(droutr8(k)*0.5*1.e6,150.) - CLDREFFS(I,k) = max(0.192*dsoutr8(k)*0.5*1.e6,250.) + CLDREFFL(I,k) = min(max(effcr8(k), 10.), 150.) + CLDREFFI(I,k) = min(max(effir8(k), 20.), 150.) + CLDREFFR(I,k) = max(droutr8(k)*0.5*1.e6, 150.) + CLDREFFS(I,k) = max(0.192*dsoutr8(k)*0.5*1.e6, 250.) enddo ! K loop - elseif (fprcp == 1) then ! callo mg2 + elseif (fprcp == 1) then ! Call MG2 +! -------- ! if (lprnt .and. i == ipr) then ! write(0,*)' bef micro_mg_tend ter8= ', ter8(:) ! write(0,*)' bef micro_mg_tend qvr8= ', qvr8(:),'dt_r8=',dt_r8 @@ -1190,7 +1321,8 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & & drout2, dsout2, & & freqs, freqr, & & nfice, qcrat, & - & prer_evap,xlat(i),xlon(i), lprint) + & prer_evap, xlat(i), xlon(i), lprint, iccn, aero_in, & + & lev_sed_strt) ! LS_PRC2(I) = max(1000.*(prectr8(1)-precir8(1)), 0.0) LS_SNR(I) = max(1000.*precir8(1), 0.0) @@ -1227,13 +1359,16 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & CLDREFFS(I,k) = 250. enddo ! K loop endif - else +! + else ! Call MG3 +! -------- ltrue = any(qcr8 >= qsmall) .or. any(qir8 >= qsmall) & .or. any(qsr8 >= qsmall) .or. any(qrr8 >= qsmall) & .or. any(qgr8 >= qsmall) lprint = lprnt .and. i == ipr if (ltrue) then alphar8(:) = qcvar3 + ! if(lprint) then ! write(0,*)' calling micro_mg_tend3_0 qcvar3=',qcvar3,' i=',i ! write(0,*)' qcr8=',qcr8(:) @@ -1242,6 +1377,7 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & ! write(0,*)' plevr8=',plevr8(:) ! write(0,*)' ter8=',ter8(:) ! endif + call micro_mg_tend3_0 ( & & ncolmicro, lm, dt_r8, & & ter8, qvr8, & @@ -1319,7 +1455,8 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & & qgout2, ngout2, dgout2, freqg, & & freqs, freqr, & & nfice, qcrat, & - & prer_evap, xlat(i), xlon(i), lprint) + & prer_evap, xlat(i), xlon(i), lprint, iccn, aero_in, & + & lev_sed_strt) LS_PRC2(I) = max(1000.*(prectr8(1)-precir8(1)), 0.0) LS_SNR(I) = max(1000.*precir8(1), 0.0) @@ -1378,11 +1515,12 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & end do end do - call update_cld(im,lm, DT_MOIST, ALPHT_X & - &, INT(CLOUDPARAMS(57)), PLO, Q1, QLLS, QLCN & - &, QILS, QICN, TEMP, CLLS, CLCN & - &, SC_ICE, NCPI, NCPL) + call update_cld(im, lm, DT_MOIST, ALPHT_X, qc_min & + &, pdfflag, PLO, Q1, QLLS, QLCN & + &, QILS, QICN, TEMP, CLLS, CLCN & + &, SC_ICE, NCPI, NCPL) +! if(lprnt) write(0,*)' aft update_cloud clls=',clls(ipr,:) do k=1,lm do i=1,im @@ -1390,7 +1528,8 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & QI_TOT(I,K) = QILS(I,K) + QICN(I,K) end do end do - deallocate(CNV_MFD,CNV_PRC3,CNV_FICE,CNV_NDROP,CNV_NICE) + deallocate(CNV_MFD,CNV_FICE,CNV_NDROP,CNV_NICE) +! deallocate(CNV_MFD,CNV_PRC3,CNV_FICE,CNV_NDROP,CNV_NICE) endif ! do I=1,IM @@ -1426,10 +1565,17 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & ncgl_io(i,k) = NCGL(i,ll) lwm_o(i,k) = QL_TOT(i,ll) qi_o(i,k) = QI_TOT(i,ll) -! CLLS_io(i,k) = CLLS(i,ll) - CLLS_io(i,k) = min(CLLS(i,ll)+CLCN(i,ll),1.0) END DO END DO + if (.not. skip_macro) then + DO K=1, LM + ll = lm-k+1 + DO I = 1,IM +! CLLS_io(i,k) = max(0.0, min(CLLS(i,ll)+CLCN(i,ll),1.0)) + CLLS_io(i,k) = CLLS(i,ll) + enddo + enddo + endif else DO K=1, LM DO I = 1,IM @@ -1445,29 +1591,34 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & ncgl_io(i,k) = NCGL(i,k) lwm_o(i,k) = QL_TOT(i,k) qi_o(i,k) = QI_TOT(i,k) -! CLLS_io(i,k) = CLLS(i,k) - CLLS_io(i,k) = min(CLLS(i,k)+CLCN(i,k),1.) END DO END DO - end if + if (.not. skip_macro) then + DO K=1, LM + DO I = 1,IM +! CLLS_io(i,k) = max(0.0, min(CLLS(i,k)+CLCN(i,k),1.0)) + CLLS_io(i,k) = CLLS(i,k) + enddo + enddo + endif + endif DO I = 1,IM - TPREC(i) = CN_PRC2(i) + CN_SNR(i) + LS_PRC2(i) + LS_SNR(i) -! rn_o(i) = TPREC(i) * dt_i * 0.001 - rn_o(i) = (LS_PRC2(i) + LS_SNR(i)) * dt_i * 0.001 + tx1 = LS_PRC2(i) + LS_SNR(i) + rn_o(i) = tx1 * dt_i * 0.001 - if (rn_o(i) < 1.e-13) then + if (rn_o(i) < rainmin) then sr_o(i) = 0. else - sr_o(i) = (CN_SNR(i)+LS_SNR(i)) / rn_o(i) + sr_o(i) = LS_SNR(i) / tx1 endif - cn_prc2(i) = cn_prc2(i) * dt_i * 0.001 - cn_snr(i) = cn_snr(i) * dt_i * 0.001 - END DO + ENDDO if (allocated(ALPHT_X)) deallocate (ALPHT_X) ! if (lprnt) then +! write(0,*)' rn_o=',rn_o(ipr),' ls_prc2=',ls_prc2(ipr),' ls_snr=',ls_snr(ipr) ! write(0,*)' end micro_mg_tend t_io= ', t_io(ipr,:) +! write(0,*)' end micro_mg_tend clls_io= ', clls_io(ipr,:) ! endif ! do k=1,lm ! do i=1,im @@ -1493,9 +1644,11 @@ end subroutine m_micro_driver !DONIF Calculate the Brunt_Vaisala frequency !=============================================================================== - subroutine gw_prof (pcols, pver, ncol, t, pm, pi, rhoi, ni, ti, nm) + subroutine gw_prof (pcols, pver, ncol, t, pm, pi, rhoi, ni, ti, & + nm, sph) use machine , only : kind_phys - use physcons, grav => con_g, cp => con_cp, rgas => con_rd + use physcons, grav => con_g, cp => con_cp, rgas => con_rd, & + fv => con_fvirt implicit none !----------------------------------------------------------------------- ! Compute profiles of background state quantities for the multiple @@ -1505,30 +1658,27 @@ subroutine gw_prof (pcols, pver, ncol, t, pm, pi, rhoi, ni, ti, nm) ! concentrations are negligible in determining the density. !----------------------------------------------------------------------- !------------------------------Arguments-------------------------------- - integer, intent(in) :: ncol - integer, intent(in) :: pcols - integer, intent(in) :: pver + integer, intent(in) :: ncol, pcols, pver real(kind=kind_phys), intent(in) :: t(pcols,pver) real(kind=kind_phys), intent(in) :: pm(pcols,pver) real(kind=kind_phys), intent(in) :: pi(pcols,0:pver) + real(kind=kind_phys), intent(in) :: sph(pcols,pver) real(kind=kind_phys), intent(out) :: rhoi(pcols,0:pver) real(kind=kind_phys), intent(out) :: ni(pcols,0:pver) real(kind=kind_phys), intent(out) :: ti(pcols,0:pver) real(kind=kind_phys), intent(out) :: nm(pcols,pver) + real(kind=kind_phys), parameter :: r=rgas, cpair=cp, g=grav, & + oneocp=1.0/cp, n2min=1.e-8 + !---------------------------Local storage------------------------------- integer :: ix,kx - real :: dtdp - real :: n2, cpair, r,g - real :: n2min = 1.e-8 - r = RGAS - cpair = CP - g = GRAV + real :: dtdp, n2 !----------------------------------------------------------------------------- ! Determine the interface densities and Brunt-Vaisala frequencies. @@ -1539,7 +1689,7 @@ subroutine gw_prof (pcols, pver, ncol, t, pm, pi, rhoi, ni, ti, nm) kx = 0 do ix = 1, ncol ti(ix,kx) = t(ix,kx+1) - rhoi(ix,kx) = pi(ix,kx) / (r*ti(ix,kx)) + rhoi(ix,kx) = pi(ix,kx) / (r*(ti(ix,kx)*(1.0+fv*sph(ix,kx+1)))) ni(ix,kx) = sqrt (g*g / (cpair*ti(ix,kx))) end do @@ -1547,9 +1697,9 @@ subroutine gw_prof (pcols, pver, ncol, t, pm, pi, rhoi, ni, ti, nm) do kx = 1, pver-1 do ix = 1, ncol ti(ix,kx) = 0.5 * (t(ix,kx) + t(ix,kx+1)) - rhoi(ix,kx) = pi(ix,kx) / (r*ti(ix,kx)) + rhoi(ix,kx) = pi(ix,kx) / (r*ti(ix,kx)*(1.0+0.5*fv*(sph(ix,kx)+sph(ix,kx+1)))) dtdp = (t(ix,kx+1)-t(ix,kx)) / (pm(ix,kx+1)-pm(ix,kx)) - n2 = g*g/ti(ix,kx) * (1./cpair - rhoi(ix,kx)*dtdp) + n2 = g*g/ti(ix,kx) * (oneocp - rhoi(ix,kx)*dtdp) ni(ix,kx) = sqrt (max (n2min, n2)) end do end do @@ -1559,7 +1709,7 @@ subroutine gw_prof (pcols, pver, ncol, t, pm, pi, rhoi, ni, ti, nm) kx = pver do ix = 1, ncol ti(ix,kx) = t(ix,kx) - rhoi(ix,kx) = pi(ix,kx) / (r*ti(ix,kx)) + rhoi(ix,kx) = pi(ix,kx) / (r*ti(ix,kx)*(1.0+fv*sph(ix,kx))) ni(ix,kx) = ni(ix,kx-1) end do diff --git a/gfsphysics/physics/micro_mg2_0.F90 b/gfsphysics/physics/micro_mg2_0.F90 index 96169f9a9..325a2dbbe 100755 --- a/gfsphysics/physics/micro_mg2_0.F90 +++ b/gfsphysics/physics/micro_mg2_0.F90 @@ -159,7 +159,7 @@ module micro_mg2_0 real(r8), parameter :: minrefl = 1.26e-10_r8 ! minrefl = 10._r8**(mindbz/10._r8) ! autoconversion size threshold for cloud ice to snow (m) -real(r8) :: dcs, ts_au, qcvar +real(r8) :: dcs, ts_au, ts_au_min, qcvar ! minimum mass of new crystal due to freezing of cloud droplets done ! externally (kg) @@ -207,6 +207,8 @@ module micro_mg2_0 logical :: allow_sed_supersat ! Allow supersaturated conditions after sedimentation loop logical :: do_sb_physics ! do SB 2001 autoconversion or accretion physics +logical :: do_ice_gmao +logical :: do_liq_liu !=============================================================================== contains @@ -219,6 +221,7 @@ subroutine micro_mg_init( & microp_uniform_in, do_cldice_in, use_hetfrz_classnuc_in, & micro_mg_precip_frac_method_in, micro_mg_berg_eff_factor_in, & allow_sed_supersat_in, do_sb_physics_in, & + do_ice_gmao_in, do_liq_liu_in, & nccons_in, nicons_in, ncnst_in, ninst_in) use micro_mg_utils, only : micro_mg_utils_init @@ -243,7 +246,7 @@ subroutine micro_mg_init( & real(r8), intent(in) :: latice real(r8), intent(in) :: rhmini_in ! Minimum rh for ice cloud fraction > 0. real(r8), intent(in) :: micro_mg_dcs - real(r8), intent(in) :: ts_auto + real(r8), intent(in) :: ts_auto(2) real(r8), intent(in) :: mg_qcvar logical, intent(in) :: microp_uniform_in ! .true. = configure uniform for sub-columns @@ -256,6 +259,8 @@ subroutine micro_mg_init( & real(r8), intent(in) :: micro_mg_berg_eff_factor_in ! berg efficiency factor logical, intent(in) :: allow_sed_supersat_in ! allow supersaturated conditions after sedimentation loop logical, intent(in) :: do_sb_physics_in ! do SB autoconversion and accretion physics + logical, intent(in) :: do_ice_gmao_in + logical, intent(in) :: do_liq_liu_in logical, intent(in) :: nccons_in, nicons_in real(r8), intent(in) :: ncnst_in, ninst_in @@ -266,9 +271,10 @@ subroutine micro_mg_init( & !----------------------------------------------------------------------- - dcs = micro_mg_dcs * 1.0e-6 - ts_au = ts_auto - qcvar = mg_qcvar + dcs = micro_mg_dcs * 1.0e-6 + ts_au_min = ts_auto(1) + ts_au = ts_auto(2) + qcvar = mg_qcvar ! Initialize subordinate utilities module. call micro_mg_utils_init(kind, rair, rh2o, cpair, tmelt_in, latvap, latice, & @@ -287,6 +293,8 @@ subroutine micro_mg_init( & micro_mg_berg_eff_factor = micro_mg_berg_eff_factor_in allow_sed_supersat = allow_sed_supersat_in do_sb_physics = do_sb_physics_in + do_ice_gmao = do_ice_gmao_in + do_liq_liu = do_liq_liu_in nccons = nccons_in nicons = nicons_in @@ -343,7 +351,7 @@ end subroutine micro_mg_init !=============================================================================== !microphysics routine for each timestep goes here... -subroutine micro_mg_tend ( & +subroutine micro_mg_tend ( & mgncol, nlev, deltatin, & t, q, & qcn, qin, & @@ -395,7 +403,7 @@ subroutine micro_mg_tend ( & drout2, dsout2, & freqs, freqr, & nfice, qcrat, & - prer_evap,xlat,xlon,lprnt) + prer_evap, xlat, xlon, lprnt, iccn, aero_in, nlball) ! Constituent properties. use micro_mg_utils, only: mg_liq_props, & @@ -427,7 +435,8 @@ subroutine micro_mg_tend ( & evaporate_sublimate_precip, & bergeron_process_snow, & liu_liq_autoconversion, & - gmao_ice_autoconversion + gmao_ice_autoconversion, & + size_dist_param_ice !Authors: Hugh Morrison, Andrew Gettelman, NCAR, Peter Caldwell, LLNL ! e-mail: morrison@ucar.edu, andrew@ucar.edu @@ -435,6 +444,7 @@ subroutine micro_mg_tend ( & ! input arguments integer, intent(in) :: mgncol ! number of microphysics columns integer, intent(in) :: nlev ! number of layers + integer, intent(in) :: nlball(mgncol) ! sedimentation start level real(r8), intent(in) :: xlat,xlon ! number of layers real(r8), intent(in) :: deltatin ! time step (s) real(r8), intent(in) :: t(mgncol,nlev) ! input temperature (K) @@ -464,7 +474,7 @@ subroutine micro_mg_tend ( & real(r8), intent(in) :: liqcldf(mgncol,nlev) ! liquid cloud fraction (no units) real(r8), intent(in) :: icecldf(mgncol,nlev) ! ice cloud fraction (no units) real(r8), intent(in) :: qsatfac(mgncol,nlev) ! subgrid cloud water saturation scaling factor (no units) - logical, intent(in) :: lprnt + logical, intent(in) :: lprnt, iccn, aero_in ! used for scavenging @@ -824,10 +834,11 @@ subroutine micro_mg_tend ( & ! Varaibles to scale fall velocity between small and regular ice regimes. real(r8) :: irad, ifrac, tsfac - logical, parameter :: do_ice_gmao=.false., do_liq_liu=.false. +! logical, parameter :: do_ice_gmao=.false., do_liq_liu=.false. ! logical, parameter :: do_ice_gmao=.true., do_liq_liu=.true. - real(r8), parameter :: qimax=0.010, qimin=0.001, qiinv=one/(qimax-qimin), & - ts_au_min=180.0 +! logical, parameter :: do_ice_gmao=.true., do_liq_liu=.false. + real(r8), parameter :: qimax=0.010, qimin=0.005, qiinv=one/(qimax-qimin) +! ts_au_min=180.0 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc @@ -837,9 +848,9 @@ subroutine micro_mg_tend ( & ! assign variable deltat to deltatin deltat = deltatin oneodt = one / deltat - nlb = nlev/3 - nstep_def = max(1, nint(deltat/20)) - tsfac = log(ts_au/ts_au_min) * qiinv +! nstep_def = max(1, nint(deltat/20)) + nstep_def = max(1, nint(deltat/5)) +! tsfac = log(ts_au/ts_au_min) * qiinv ! Copies of input concentrations that may be changed internally. do k=1,nlev @@ -1111,6 +1122,20 @@ subroutine micro_mg_tend ( & npccn(i,k) = zero enddo enddo + + if(iccn) then + do k=1,nlev + do i=1,mgncol + npccn(i,k) = npccnin(i,k) + enddo + enddo + else + do k=1,nlev + do i=1,mgncol + npccn(i,k) = max((npccnin(i,k)*lcldm(i,k)-nc(i,k))*oneodt, zero) + enddo + enddo + endif ! initialize precip at surface do i=1,mgncol @@ -1133,20 +1158,56 @@ subroutine micro_mg_tend ( & npccn = max((npccnin*lcldm-nc)*oneodt, zero) nc = max(nc + npccn*deltat, zero) ncal = nc*rho/lcldm ! sghan minimum in #/cm3 + elsewhere + ncal = zero end where - do k=1,nlev - do i=1,mgncol - if( (t(i,k) < icenuct)) then - ncai(i,k) = 0.005_r8*exp(0.304_r8*(273.15_r8-t(i,k))) * 1000._r8 - ncai(i,k) = min(ncai(i,k), 208.9e3_r8) - naai(i,k) = ncai(i,k) * rhoinv(i,k) - else - naai(i,k) = zero - ncai(i,k) = zero - endif + if (iccn) then + do k=1,nlev + do i=1,mgncol + if (t(i,k) < icenuct) then + ncai(i,k) = 0.005_r8*exp(0.304_r8*(273.15_r8-t(i,k))) * 1000._r8 +! ncai(i,k) = min(ncai(i,k), 208.9e3_r8) + ncai(i,k) = min(ncai(i,k), 355.0e3_r8) + naai(i,k) = (ncai(i,k)*rhoinv(i,k) + naai(i,k)) * half + ncai(i,k) = naai(i,k)*rho(i,k) + else + naai(i,k) = zero + ncai(i,k) = zero + endif + enddo enddo - enddo + elseif (aero_in) then + do k=1,nlev + do i=1,mgncol + if (t(i,k) < icenuct) then + ncai(i,k) = naai(i,k)*rho(i,k) + else + naai(i,k) = zero + ncai(i,k) = zero + endif + enddo + enddo + else + do k=1,nlev + do i=1,mgncol + if (t(i,k) < icenuct) then + ncai(i,k) = 0.005_r8*exp(0.304_r8*(273.15_r8-t(i,k))) * 1000._r8 + ncai(i,k) = min(ncai(i,k), 355.0e3_r8) + naai(i,k) = ncai(i,k)*rhoinv(i,k) + else + naai(i,k) = zero + ncai(i,k) = zero + endif + enddo + enddo + do k=1,nlev + do i=1,mgncol + naai(i,k) = zero + ncai(i,k) = zero + enddo + enddo + endif !=============================================== @@ -1265,9 +1326,9 @@ subroutine micro_mg_tend ( & ! units are kg/kg for mixing ratio, 1/kg for number conc if (qc(i,k) >= qsmall) then - ! limit in-cloud values to 0.005 kg/kg dum = one / lcldm(i,k) - qcic(i,k) = min(qc(i,k)*dum, 5.e-3_r8) +! qcic(i,k) = min(qc(i,k)*dum, 5.e-3_r8) ! limit in-cloud values to 0.005 kg/kg + qcic(i,k) = min(qc(i,k)*dum, 0.05_r8) ! limit in-cloud values to 0.05 kg/kg ncic(i,k) = max(nc(i,k)*dum, zero) ! specify droplet concentration @@ -1280,9 +1341,9 @@ subroutine micro_mg_tend ( & end if if (qi(i,k) >= qsmall) then - ! limit in-cloud values to 0.005 kg/kg dum = one / icldm(i,k) - qiic(i,k) = min(qi(i,k)*dum, 5.e-3_r8) +! qiic(i,k) = min(qi(i,k)*dum, 5.e-3_r8) ! limit in-cloud values to 0.005 kg/kg + qiic(i,k) = min(qi(i,k)*dum, 0.05_r8) ! limit in-cloud values to 0.05 kg/kg niic(i,k) = max(ni(i,k)*dum, zero) ! switch for specification of cloud ice number @@ -1360,7 +1421,8 @@ subroutine micro_mg_tend ( & else dum = zero endif - qric(i,k) = min(qr(i,k)*dum, 0.01_r8) ! limit in-precip mixing ratios to 10 g/kg +! qric(i,k) = min(qr(i,k)*dum, 0.01_r8) ! limit in-precip mixing ratios to 10 g/kg + qric(i,k) = min(qr(i,k)*dum, 0.05_r8) ! limit in-precip mixing ratios to 50 g/kg nric(i,k) = nr(i,k) * dum @@ -1379,8 +1441,11 @@ subroutine micro_mg_tend ( & enddo ! Get size distribution parameters for cloud ice - call size_dist_param_basic(mg_ice_props, qiic(:,k), niic(:,k), & - lami(:,k), mgncol, n0=n0i(:,k)) + call size_dist_param_ice(mg_ice_props, qiic(:,k), niic(:,k), & + lami(:,k), mgncol, n0=n0i(:,k)) + +! call size_dist_param_basic(mg_ice_props, qiic(:,k), niic(:,k), & +! lami(:,k), mgncol, n0=n0i(:,k)) ! Alternative autoconversion if (do_sb_physics) then @@ -1398,16 +1463,20 @@ subroutine micro_mg_tend ( & ! similar to Ferrier (1994) if (do_cldice) then - do i=1,mgncol + do i=1,mgncol if (qiic(i,k) >= qimax) then +! if (qi(i,k) >= qimax) then ts_au_loc(i) = ts_au_min elseif (qiic(i,k) <= qimin) then +! elseif (qi(i,k) <= qimin) then ts_au_loc(i) = ts_au else -! ts_au_loc(i) = (ts_au*(qimax-qiic(i,k)) + ts_au_min*(qiic(i,k)-qimin)) * qiinv - ts_au_loc(i) = ts_au_min *exp(-tsfac*(qiic(i,k)-qimin)) +! ts_au_loc(i) = (ts_au*(qimax-qi(i,k)) + ts_au_min*(qi(i,k)-qimin)) * qiinv + ts_au_loc(i) = (ts_au*(qimax-qiic(i,k)) + ts_au_min*(qiic(i,k)-qimin)) * qiinv +! ts_au_loc(i) = ts_au * exp(-tsfac*(qiic(i,k)-qimin)) endif enddo + if(do_ice_gmao) then call gmao_ice_autoconversion(t(:,k), qiic(:,k), niic(:,k), lami(:,k), & n0i(:,k), dcs, ts_au_loc(:), prci(:,k), nprci(:,k), mgncol) @@ -1431,7 +1500,9 @@ subroutine micro_mg_tend ( & else dum = zero endif - qsic(i,k) = min(qs(i,k)*dum, 0.01_r8) ! limit in-precip mixing ratios to 10 g/kg +! qsic(i,k) = min(qs(i,k)*dum, 0.01_r8) ! limit in-precip mixing ratios to 10 g/kg +! qsic(i,k) = min(qs(i,k)*dum, 0.05_r8) ! limit in-precip mixing ratios to 50 g/kg + qsic(i,k) = min(qs(i,k)*dum, 0.10_r8) ! limit in-precip mixing ratios to 50 g/kg nsic(i,k) = ns(i,k) * dum ! if precip mix ratio is zero so should number concentration @@ -2221,11 +2292,14 @@ subroutine micro_mg_tend ( & ! obtain new slope parameter to avoid possible singularity + call size_dist_param_ice(mg_ice_props, dumi(:,k), dumni(:,k), & + lami(:,k), mgncol) + call size_dist_param_liq(mg_liq_props, dumc(:,k), dumnc(:,k), rho(:,k), & pgam(:,k), lamc(:,k), mgncol) - call size_dist_param_basic(mg_ice_props, dumi(:,k), dumni(:,k), & - lami(:,k), mgncol) +! call size_dist_param_basic(mg_ice_props, dumi(:,k), dumni(:,k), & +! lami(:,k), mgncol) ! fallspeed for rain call size_dist_param_basic(mg_rain_props, dumr(:,k), dumnr(:,k), & @@ -2363,6 +2437,7 @@ subroutine micro_mg_tend ( & ! for sedimentation calculations !------------------------------------------------------------------- do i=1,mgncol + nlb = nlball(i) nstep = 1 + nint(max( maxval( fi(i,nlb:nlev)*pdel_inv(i,nlb:nlev)), & maxval(fni(i,nlb:nlev)*pdel_inv(i,nlb:nlev))) * deltat) @@ -2944,8 +3019,10 @@ subroutine micro_mg_tend ( & end if ! limit in-cloud mixing ratio to reasonable value of 5 g kg-1 - dumc(i,k) = min(dumc(i,k), 5.e-3_r8) - dumi(i,k) = min(dumi(i,k), 5.e-3_r8) +! dumc(i,k) = min(dumc(i,k), 5.e-3_r8) +! dumi(i,k) = min(dumi(i,k), 5.e-3_r8) + dumc(i,k) = min(dumc(i,k), 10.e-3_r8) + dumi(i,k) = min(dumi(i,k), 10.e-3_r8) ! limit in-precip mixing ratios dumr(i,k) = min(dumr(i,k), 10.e-3_r8) dums(i,k) = min(dums(i,k), 10.e-3_r8) @@ -2969,11 +3046,13 @@ subroutine micro_mg_tend ( & end if tx1 = one / lami(i,k) - effi(i,k) = (1.5_r8*1.e6_r8) * tx1 +! effi(i,k) = (1.5_r8*1.e6_r8) * tx1 + effi(i,k) = (three*1.e6_r8) * tx1 sadice(i,k) = two*pi*(tx1*tx1*tx1)*dumni0*rho(i,k)*1.e-2_r8 ! m2/m3 -> cm2/cm3 else - effi(i,k) = 25._r8 +! effi(i,k) = 25._r8 + effi(i,k) = 50._r8 sadice(i,k) = zero end if @@ -3134,7 +3213,7 @@ subroutine micro_mg_tend ( & drout2(i,k) = avg_diameter(qrout(i,k), nrout(i,k), rho(i,k), rhow) freqr(i,k) = precip_frac(i,k) - reff_rain(i,k) = (1.e6_r8*1.5_r8) * drout2(i,k) + reff_rain(i,k) = (1.e6_r8*three) * drout2(i,k) else qrout2(i,k) = zero nrout2(i,k) = zero @@ -3153,7 +3232,7 @@ subroutine micro_mg_tend ( & dsout(i,k) = three*rhosn/rhows*dsout2(i,k) - reff_snow(i,k) = (1.e6_r8*1.5_r8) * dsout2(i,k) + reff_snow(i,k) = (1.e6_r8*three) * dsout2(i,k) else dsout(i,k) = zero qsout2(i,k) = zero diff --git a/gfsphysics/physics/micro_mg3_0.F90 b/gfsphysics/physics/micro_mg3_0.F90 index 9dbb1dd12..2c6ecec3c 100755 --- a/gfsphysics/physics/micro_mg3_0.F90 +++ b/gfsphysics/physics/micro_mg3_0.F90 @@ -24,6 +24,7 @@ module micro_mg3_0 ! S. Moorthi - Feb 2018 - updated to MG3 - modified graupel sedimentation ! other modifications to eliminate blowup. ! S. Moorthi - Mar 2018 - fixed a few bugs and added option to run as MG2 +! S. Moorthi - Oct,29,2018 - change nlb from nlev/3 to levels with p/ps < 0.05 (nlball) ! ! invoked in CAM by specifying -microphys=mg3 ! @@ -179,7 +180,7 @@ module micro_mg3_0 real(r8), parameter :: minrefl = 1.26e-10_r8 ! minrefl = 10._r8**(mindbz/10._r8) ! autoconversion size threshold for cloud ice to snow (m) -real(r8) :: dcs, ts_au, qcvar +real(r8) :: dcs, ts_au, ts_au_min, qcvar ! minimum mass of new crystal due to freezing of cloud droplets done ! externally (kg) @@ -238,6 +239,8 @@ module micro_mg3_0 logical :: allow_sed_supersat ! Allow supersaturated conditions after sedimentation loop logical :: do_sb_physics ! do SB 2001 autoconversion or accretion physics +logical :: do_ice_gmao +logical :: do_liq_liu !=============================================================================== contains @@ -253,6 +256,7 @@ subroutine micro_mg_init( & microp_uniform_in, do_cldice_in, use_hetfrz_classnuc_in, & micro_mg_precip_frac_method_in, micro_mg_berg_eff_factor_in, & allow_sed_supersat_in, do_sb_physics_in, & + do_ice_gmao_in, do_liq_liu_in, & nccons_in, nicons_in, ncnst_in, ninst_in, ngcons_in, ngnst_in) ! nccons_in, nicons_in, ncnst_in, ninst_in, ngcons_in, ngnst_in, errstring) @@ -278,7 +282,7 @@ subroutine micro_mg_init( & real(r8), intent(in) :: latice real(r8), intent(in) :: rhmini_in ! Minimum rh for ice cloud fraction > 0. real(r8), intent(in) :: micro_mg_dcs - real(r8), intent(in) :: ts_auto + real(r8), intent(in) :: ts_auto(2) real(r8), intent(in) :: mg_qcvar !++ag @@ -299,6 +303,8 @@ subroutine micro_mg_init( & real(r8), intent(in) :: micro_mg_berg_eff_factor_in ! berg efficiency factor logical, intent(in) :: allow_sed_supersat_in ! allow supersaturated conditions after sedimentation loop logical, intent(in) :: do_sb_physics_in ! do SB autoconversion and accretion physics + logical, intent(in) :: do_ice_gmao_in + logical, intent(in) :: do_liq_liu_in logical, intent(in) :: nccons_in, nicons_in, ngcons_in real(r8), intent(in) :: ncnst_in, ninst_in, ngnst_in @@ -310,9 +316,10 @@ subroutine micro_mg_init( & !----------------------------------------------------------------------- - dcs = micro_mg_dcs * 1.0e-6 - ts_au = ts_auto - qcvar = mg_qcvar + dcs = micro_mg_dcs * 1.0e-6 + ts_au_min = ts_auto(1) + ts_au = ts_auto(2) + qcvar = mg_qcvar ! Initialize subordinate utilities module. call micro_mg_utils_init(kind, rair, rh2o, cpair, tmelt_in, latvap, latice, & @@ -334,6 +341,8 @@ subroutine micro_mg_init( & micro_mg_berg_eff_factor = micro_mg_berg_eff_factor_in allow_sed_supersat = allow_sed_supersat_in do_sb_physics = do_sb_physics_in + do_ice_gmao = do_ice_gmao_in + do_liq_liu = do_liq_liu_in nccons = nccons_in nicons = nicons_in @@ -496,7 +505,7 @@ subroutine micro_mg_tend ( & !--ag freqs, freqr, & nfice, qcrat, & - prer_evap, xlat, xlon, lprnt) + prer_evap, xlat, xlon, lprnt, iccn, aero_in, nlball) ! Constituent properties. use micro_mg_utils, only: mg_liq_props, & @@ -530,6 +539,7 @@ subroutine micro_mg_tend ( & accrete_cloud_ice_snow, & evaporate_sublimate_precip, & bergeron_process_snow, & + size_dist_param_ice, & !++ag graupel_collecting_snow, & graupel_collecting_rain, & @@ -549,6 +559,7 @@ subroutine micro_mg_tend ( & ! input arguments integer, intent(in) :: mgncol ! number of microphysics columns integer, intent(in) :: nlev ! number of layers + integer, intent(in) :: nlball(mgncol) ! sedimentation start level real(r8), intent(in) :: xlat,xlon ! number of layers real(r8), intent(in) :: deltatin ! time step (s) real(r8), intent(in) :: t(mgncol,nlev) ! input temperature (K) @@ -582,7 +593,7 @@ subroutine micro_mg_tend ( & real(r8), intent(in) :: liqcldf(mgncol,nlev) ! liquid cloud fraction (no units) real(r8), intent(in) :: icecldf(mgncol,nlev) ! ice cloud fraction (no units) real(r8), intent(in) :: qsatfac(mgncol,nlev) ! subgrid cloud water saturation scaling factor (no units) - logical, intent(in) :: lprnt + logical, intent(in) :: lprnt, iccn, aero_in ! used for scavenging @@ -1042,7 +1053,7 @@ subroutine micro_mg_tend ( & real(r8) :: dumng(mgncol,nlev) ! graupel number concentration !--ag ! Array dummy variable - !real(r8) :: dum_2D(mgncol,nlev) +! real(r8) :: dum_2D(mgncol,nlev) real(r8) :: pdel_inv(mgncol,nlev) real(r8) :: ts_au_loc(mgncol) @@ -1055,11 +1066,15 @@ subroutine micro_mg_tend ( & integer nstep, mdust, nlb, nstep_def ! Varaibles to scale fall velocity between small and regular ice regimes. - real(r8) :: irad, ifrac, tsfac - logical, parameter :: do_ice_gmao=.false., do_liq_liu=.false. -! logical, parameter :: do_ice_gmao=.true., do_liq_liu=.true. - real(r8), parameter :: qimax=0.010, qimin=0.001, qiinv=one/(qimax-qimin), & - ts_au_min=180.0 +! real(r8) :: irad, ifrac, tsfac + real(r8) :: irad, ifrac +! logical, parameter :: do_ice_gmao=.false., do_liq_liu=.false. +! logical, parameter :: do_ice_gmao=.false., do_liq_liu=.true. +! logical, parameter :: do_ice_gmao=.true., do_liq_liu=.false. +! real(r8), parameter :: qimax=0.010, qimin=0.001, qiinv=one/(qimax-qimin), & +! real(r8), parameter :: qimax=0.010, qimin=0.001, qiinv=one/(qimax-qimin), & + real(r8), parameter :: qimax=0.010, qimin=0.005, qiinv=one/(qimax-qimin) +! ts_au_min=180.0 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc @@ -1069,10 +1084,9 @@ subroutine micro_mg_tend ( & ! assign variable deltat to deltatin deltat = deltatin oneodt = one / deltat - nlb = nlev/3 ! nstep_def = max(1, nint(deltat/20)) nstep_def = max(1, nint(deltat/5)) - tsfac = log(ts_au/ts_au_min) * qiinv +! tsfac = log(ts_au/ts_au_min) * qiinv ! Copies of input concentrations that may be changed internally. do k=1,nlev @@ -1426,6 +1440,20 @@ subroutine micro_mg_tend ( & npccn(i,k) = zero enddo enddo +! + if (iccn) then + do k=1,nlev + do i=1,mgncol + npccn(i,k) = npccnin(i,k) + enddo + enddo + else + do k=1,nlev + do i=1,mgncol + npccn(i,k) = max((npccnin(i,k)*lcldm(i,k)-nc(i,k))*oneodt, zero) + enddo + enddo + endif ! initialize precip at surface @@ -1446,25 +1474,69 @@ subroutine micro_mg_tend ( & ! output activated liquid and ice (convert from #/kg -> #/m3) !-------------------------------------------------- ! where (qc >= qsmall .and. lcldm > mincld) - where (qc >= qsmall) - npccn = max((npccnin*lcldm-nc)*oneodt, zero) - nc = max(nc + npccn*deltat, zero) - ncal = nc*rho/lcldm ! sghan minimum in #/cm3 - end where - +! where (qc >= qsmall) +! npccn = max((npccnin*lcldm-nc)*oneodt, zero) +! nc = max(nc + npccn*deltat, zero) +! ncal = nc*rho/lcldm ! sghan minimum in #/cm3 +! elsewhere +! ncal = zero +! end where + +! if (lprnt) write(0,*)' nc1=',nc(1,:) do k=1,nlev do i=1,mgncol - if( (t(i,k) < icenuct)) then - ncai(i,k) = 0.005_r8*exp(0.304_r8*(273.15_r8-t(i,k))) * 1000._r8 - ncai(i,k) = min(ncai(i,k), 208.9e3_r8) - naai(i,k) = ncai(i,k) * rhoinv(i,k) + if (qc(i,k) > qsmall .and. lcldm(i,k) >= mincld) then + npccn(i,k) = max((npccnin(i,k)*lcldm(i,k)-nc(i,k))*oneodt, zero) + nc(i,k) = max(nc(i,k) + npccn(i,k)*deltat, zero) + ncal(i,k) = nc(i,k) * rho(i,k) / lcldm(i,k) else - naai(i,k) = zero - ncai(i,k) = zero + ncal(i,k) = 0.0 endif enddo enddo + if (iccn) then + do k=1,nlev + do i=1,mgncol + if (t(i,k) < icenuct) then + ncai(i,k) = 0.005_r8*exp(0.304_r8*(273.15_r8-t(i,k))) * 1000._r8 +! ncai(i,k) = min(ncai(i,k), 208.9e3_r8) + ncai(i,k) = min(ncai(i,k), 355.0e3_r8) + naai(i,k) = (ncai(i,k)*rhoinv(i,k) + naai(i,k)) * half + ncai(i,k) = naai(i,k)*rho(i,k) + else + naai(i,k) = zero + ncai(i,k) = zero + endif + enddo + enddo + elseif (aero_in) then + do k=1,nlev + do i=1,mgncol + if (t(i,k) < icenuct) then + ncai(i,k) = naai(i,k)*rho(i,k) + else + naai(i,k) = zero + ncai(i,k) = zero + endif + enddo + enddo + else + do k=1,nlev + do i=1,mgncol + if (t(i,k) < icenuct) then + ncai(i,k) = 0.005_r8*exp(0.304_r8*(273.15_r8-t(i,k))) * 1000._r8 + ncai(i,k) = min(ncai(i,k), 355.0e3_r8) + naai(i,k) = ncai(i,k)*rhoinv(i,k) + else + naai(i,k) = zero + ncai(i,k) = zero + endif + enddo + enddo + + endif + !=============================================== @@ -1635,9 +1707,9 @@ subroutine micro_mg_tend ( & ! if (lprnt) then ! write(0,*)' tlat2=',tlat(1,:)*deltat -! write(0,*)' lcldm=',lcldm(1,100:127) -! write(0,*)' qc=',qc(1,100:127) -! write(0,*)' nc=',nc(1,100:127) +! write(0,*)' lcldm=',lcldm(1,:) +! write(0,*)' qc=',qc(1,:) +! write(0,*)' nc=',nc(1,:) ! write(0,*)' qg2=',qg(1,:) ! endif @@ -1652,7 +1724,8 @@ subroutine micro_mg_tend ( & if (qc(i,k) >= qsmall) then ! limit in-cloud values to 0.005 kg/kg dum = one / lcldm(i,k) - qcic(i,k) = min(qc(i,k)*dum, 5.e-3_r8) +! qcic(i,k) = min(qc(i,k)*dum, 5.e-3_r8) ! limit in-cloud values to 0.005 kg/kg + qcic(i,k) = min(qc(i,k)*dum, 0.05_r8) ! limit in-cloud values to 0.05 kg/kg ncic(i,k) = max(nc(i,k)*dum, zero) ! specify droplet concentration @@ -1666,9 +1739,9 @@ subroutine micro_mg_tend ( & ! if (qi(i,k) >= qsmall .and. icldm(i,k) > mincld) then if (qi(i,k) >= qsmall) then - ! limit in-cloud values to 0.005 kg/kg dum = one / icldm(i,k) - qiic(i,k) = min(qi(i,k)*dum, 5.e-3_r8) +! qiic(i,k) = min(qi(i,k)*dum, 5.e-3_r8) ! limit in-cloud values to 0.005 kg/kg + qiic(i,k) = min(qi(i,k)*dum, 0.05_r8) ! limit in-cloud values to 0.05 kg/kg niic(i,k) = max(ni(i,k)*dum, zero) ! switch for specification of cloud ice number @@ -1680,7 +1753,7 @@ subroutine micro_mg_tend ( & niic(i,k) = zero end if - end do + end do end do !======================================================================== @@ -1760,7 +1833,8 @@ subroutine micro_mg_tend ( & else dum = zero endif - qric(i,k) = min(qr(i,k)*dum, 0.01_r8) ! limit in-precip mixing ratios to 10 g/kg +! qric(i,k) = min(qr(i,k)*dum, 0.01_r8) ! limit in-precip mixing ratios to 10 g/kg + qric(i,k) = min(qr(i,k)*dum, 0.05_r8) ! limit in-precip mixing ratios to 50 g/kg nric(i,k) = nr(i,k) * dum @@ -1779,7 +1853,7 @@ subroutine micro_mg_tend ( & enddo ! Get size distribution parameters for cloud ice - call size_dist_param_basic(mg_ice_props, qiic(:,k), niic(:,k), & + call size_dist_param_ice(mg_ice_props, qiic(:,k), niic(:,k), & lami(:,k), mgncol, n0=n0i(:,k)) ! Alternative autoconversion @@ -1800,14 +1874,23 @@ subroutine micro_mg_tend ( & if (do_cldice) then do i=1,mgncol if (qiic(i,k) >= qimax) then +! if (qi(i,k) >= qimax) then ts_au_loc(i) = ts_au_min elseif (qiic(i,k) <= qimin) then +! elseif (qi(i,k) <= qimin) then ts_au_loc(i) = ts_au else -! ts_au_loc(i) = (ts_au*(qimax-qiic(i,k)) + ts_au_min*(qiic(i,k)-qimin)) * qiinv - ts_au_loc(i) = ts_au_min *exp(-tsfac*(qiic(i,k)-qimin)) +! ts_au_loc(i) = (ts_au*(qimax-qi(i,k)) + ts_au_min*(qi(i,k)-qimin)) * qiinv + ts_au_loc(i) = (ts_au*(qimax-qiic(i,k)) + ts_au_min*(qiic(i,k)-qimin)) * qiinv +! ts_au_loc(i) = ts_au * exp(-tsfac*(qiic(i,k)-qimin)) endif +! if (ts_au_loc(i) > ts_au_min) ts_au_loc(i) = ts_au_loc(i)*min(five,sqrt(p(i,nlev)/p(i,k))) enddo +! if (lprnt) write(0,*)' ts_au_loc=',ts_au_loc(1),' k=',k, ' qiic=',qiic(1,k),& +! if (lprnt) write(0,*)' ts_au_loc=',ts_au_loc(1),' k=',k, ' qi=',qi(1,k),& +! ' ts_au=',ts_au,' ts_au_min=',ts_au_min,' qimin=',qimin,' qimax=',qimax +! ' ts_au=',ts_au,' ts_au_min=',ts_au_min,' tsfac=',tsfac,' qimin=',qimin,' qimax=',qimax + if(do_ice_gmao) then call gmao_ice_autoconversion(t(:,k), qiic(:,k), niic(:,k), lami(:,k), & n0i(:,k), dcs, ts_au_loc(:), prci(:,k), nprci(:,k), mgncol) @@ -1831,7 +1914,8 @@ subroutine micro_mg_tend ( & else dum = zero endif - qsic(i,k) = min(qs(i,k)*dum, 0.01_r8) ! limit in-precip mixing ratios to 10 g/kg +! qsic(i,k) = min(qs(i,k)*dum, 0.01_r8) ! limit in-precip mixing ratios to 10 g/kg + qsic(i,k) = min(qs(i,k)*dum, 0.05_r8) ! limit in-precip mixing ratios to 50 g/kg nsic(i,k) = ns(i,k) * dum ! if precip mix ratio is zero so should number concentration @@ -3111,12 +3195,14 @@ subroutine micro_mg_tend ( & ! obtain new slope parameter to avoid possible singularity + call size_dist_param_ice(mg_ice_props, dumi(:,k), dumni(:,k), & + lami(:,k), mgncol) call size_dist_param_liq(mg_liq_props, dumc(:,k), dumnc(:,k), rho(:,k), & pgam(:,k), lamc(:,k), mgncol) - call size_dist_param_basic(mg_ice_props, dumi(:,k), dumni(:,k), & - lami(:,k), mgncol) +! call size_dist_param_basic(mg_ice_props, dumi(:,k), dumni(:,k), & +! lami(:,k), mgncol) ! fallspeed for rain call size_dist_param_basic(mg_rain_props, dumr(:,k), dumnr(:,k), & @@ -3283,6 +3369,7 @@ subroutine micro_mg_tend ( & ! for sedimentation calculations !------------------------------------------------------------------- do i=1,mgncol + nlb = nlball(i) nstep = 1 + nint(max( maxval( fi(i,nlb:nlev)*pdel_inv(i,nlb:nlev)), & maxval(fni(i,nlb:nlev)*pdel_inv(i,nlb:nlev))) * deltat) nstep = min(nstep, nstep_def) @@ -3879,8 +3966,8 @@ subroutine micro_mg_tend ( & enddo ! if (lprnt) write(0,*)' tlat6=',tlat(1,:)*deltat -! if (lprnt) write(0,*)' qitend=',qitend(1,nlev-10:nlev)*deltat -! if (lprnt) write(0,*)' qctend=',qctend(1,nlev-10:nlev)*deltat +! if (lprnt) write(0,*)' qitend=',qitend(1,nlev-45:nlev)*deltat +! if (lprnt) write(0,*)' qctend=',qctend(1,nlev-45:nlev)*deltat ! homogeneously freeze droplets at -40 C !----------------------------------------------------------------- @@ -4022,8 +4109,10 @@ subroutine micro_mg_tend ( & !--ag ! limit in-cloud mixing ratio to reasonable value of 5 g kg-1 - dumc(i,k) = min(dumc(i,k), 5.e-3_r8) - dumi(i,k) = min(dumi(i,k), 5.e-3_r8) +! dumc(i,k) = min(dumc(i,k), 5.e-3_r8) +! dumi(i,k) = min(dumi(i,k), 5.e-3_r8) + dumc(i,k) = min(dumc(i,k), 10.e-3_r8) + dumi(i,k) = min(dumi(i,k), 10.e-3_r8) ! limit in-precip mixing ratios dumr(i,k) = min(dumr(i,k), 10.e-3_r8) dums(i,k) = min(dums(i,k), 10.e-3_r8) @@ -4050,11 +4139,12 @@ subroutine micro_mg_tend ( & end if tx1 = one / lami(i,k) - effi(i,k) = (1.5_r8*1.e6_r8) * tx1 +! effi(i,k) = (1.5_r8*1.e6_r8) * tx1 + effi(i,k) = (three*1.e6_r8) * tx1 sadice(i,k) = two*pi*(tx1*tx1*tx1)*dumni0*rho(i,k)*1.e-2_r8 ! m2/m3 -> cm2/cm3 else - effi(i,k) = 25._r8 + effi(i,k) = 50._r8 sadice(i,k) = zero end if @@ -4237,7 +4327,7 @@ subroutine micro_mg_tend ( & dsout(i,k) = three*rhosn/rhows*dsout2(i,k) - reff_snow(i,k) = (1.e6_r8*1.5_r8) * dsout2(i,k) + reff_snow(i,k) = (1.e6_r8*three) * dsout2(i,k) else dsout(i,k) = zero qsout2(i,k) = zero diff --git a/gfsphysics/physics/micro_mg_utils.F90 b/gfsphysics/physics/micro_mg_utils.F90 index 78556a5f8..ac9569bf1 100755 --- a/gfsphysics/physics/micro_mg_utils.F90 +++ b/gfsphysics/physics/micro_mg_utils.F90 @@ -72,6 +72,7 @@ module micro_mg_utils bergeron_process_snow, & liu_liq_autoconversion, & gmao_ice_autoconversion, & + size_dist_param_ice, & !++ag graupel_collecting_snow, & graupel_collecting_rain, & @@ -122,6 +123,11 @@ module micro_mg_utils module procedure size_dist_param_basic_line end interface +interface size_dist_param_ice + module procedure size_dist_param_ice_vect + module procedure size_dist_param_ice_line +end interface + !================================================= ! Public module parameters (mostly for MG itself) !================================================= @@ -225,7 +231,9 @@ module micro_mg_utils ! collection efficiencies ! aggregation of cloud ice and snow -real(r8), parameter :: eii = 0.5_r8 +!real(r8), parameter :: eii = 0.5_r8 +!real(r8), parameter :: eii = 0.1_r8 + real(r8), parameter :: eii = 0.2_r8 !++ag ! collection efficiency, ice-droplet collisions real(r8), parameter, public :: ecid = 0.7_r8 @@ -437,14 +445,16 @@ end function calc_ab ! get cloud droplet size distribution parameters elemental subroutine size_dist_param_liq_line(props, qcic, ncic, rho, pgam, lamc) type(MGHydrometeorProps), intent(in) :: props - real(r8), intent(in) :: qcic - real(r8), intent(inout) :: ncic - real(r8), intent(in) :: rho + real(r8), intent(in) :: qcic + real(r8), intent(inout) :: ncic + real(r8), intent(in) :: rho - real(r8), intent(out) :: pgam - real(r8), intent(out) :: lamc + real(r8), intent(out) :: pgam + real(r8), intent(out) :: lamc + real(r8) :: xs type(MGHydrometeorProps) :: props_loc + logical, parameter :: liq_gmao=.true. if (qcic > qsmall) then @@ -454,8 +464,25 @@ elemental subroutine size_dist_param_liq_line(props, qcic, ncic, rho, pgam, lamc props_loc = props ! Get pgam from fit to observations of martin et al. 1994 - pgam = one - 0.7_r8 * exp(-0.008_r8*1.e-6_r8*ncic*rho) -! pgam = 0.0005714_r8*1.e-6_r8*ncic*rho + 0.2714_r8 + + if (liq_gmao) then + pgam = 0.0005714_r8*1.e-6_r8*ncic*rho + 0.2714_r8 + ! Anning modified lamc + if ((ncic > 1.0e-3) .and. (qcic > 1.0e-11)) then + xs = 0.07_r8*(1000._r8*qcic/ncic) ** (-0.14_r8) + else + xs = 1.2 + end if + + xs = max(min(xs, 1.7_r8), 1.1_r8) + xs = xs*xs*xs + xs = (xs + sqrt(xs+8.0_r8)*sqrt(xs) - 4.)/8.0_r8 + pgam = sqrt(xs) + else + + pgam = one - 0.7_r8 * exp(-0.008_r8*1.e-6_r8*ncic*rho) +! pgam = 0.0005714_r8*1.e-6_r8*ncic*rho + 0.2714_r8 + endif pgam = one / (pgam*pgam) - one pgam = max(pgam, two) @@ -495,7 +522,9 @@ subroutine size_dist_param_liq_vect(props, qcic, ncic, rho, pgam, lamc, mgncol) real(r8), dimension(mgncol), intent(in) :: rho real(r8), dimension(mgncol), intent(out) :: pgam real(r8), dimension(mgncol), intent(out) :: lamc + real(r8) :: xs type(mghydrometeorprops) :: props_loc + logical, parameter :: liq_gmao=.true. integer :: i do i=1,mgncol @@ -505,8 +534,24 @@ subroutine size_dist_param_liq_vect(props, qcic, ncic, rho, pgam, lamc, mgncol) ! arguments.) props_loc = props ! Get pgam from fit to observations of martin et al. 1994 - pgam(i) = one - 0.7_r8 * exp(-0.008_r8*1.e-6_r8*ncic(i)*rho(i)) -! pgam(i) = 0.0005714_r8*1.e-6_r8*ncic(i)*rho(i) + 0.2714_r8 + + if (liq_gmao) then + pgam(i) = 0.0005714_r8*1.e-6_r8*ncic(i)*rho(i) + 0.2714_r8 + if ((ncic(i) > 1.0e-3) .and. (qcic(i) > 1.0e-11)) then + xs = 0.07_r8*(1000._r8*qcic(i)/ncic(i)) **(-0.14_r8) + else + xs = 1.2 + end if + + xs = max(min(xs, 1.7_r8), 1.1_r8) + xs = xs*xs*xs + xs = (xs + sqrt(xs+8.0_r8)*sqrt(xs) - 4.)/8.0_r8 + pgam(i) = sqrt(xs) + else + pgam(i) = one - 0.7_r8 * exp(-0.008_r8*1.e-6_r8*ncic(i)*rho(i)) +! pgam(i) = 0.0005714_r8*1.e-6_r8*ncic(i)*rho(i) + 0.2714_r8 + endif + pgam(i) = one/(pgam(i)*pgam(i)) - one pgam(i) = max(pgam(i), two) endif @@ -544,10 +589,10 @@ end subroutine size_dist_param_liq_vect ! Basic routine for getting size distribution parameters. elemental subroutine size_dist_param_basic_line(props, qic, nic, lam, n0) type(MGHydrometeorProps), intent(in) :: props - real(r8), intent(in) :: qic + real(r8), intent(in) :: qic real(r8), intent(inout) :: nic - real(r8), intent(out) :: lam + real(r8), intent(out) :: lam real(r8), intent(out), optional :: n0 if (qic > qsmall) then @@ -621,6 +666,115 @@ subroutine size_dist_param_basic_vect(props, qic, nic, lam, mgncol, n0) end subroutine size_dist_param_basic_vect +! ice routine for getting size distribution parameters. +elemental subroutine size_dist_param_ice_line(props, qic, nic, lam, n0) + type(MGHydrometeorProps), intent(in) :: props + real(r8), intent(in) :: qic + real(r8), intent(inout) :: nic + + real(r8), intent(out) :: lam + real(r8):: miu_ice,tx1,tx2, aux + real(r8), intent(out), optional :: n0 + logical, parameter :: ice_sep=.true. + + if (qic > qsmall) then + + ! add upper limit to in-cloud number concentration to prevent + ! numerical error + if (limiter_is_on(props%min_mean_mass)) then + nic = min(nic, qic / props%min_mean_mass) + end if + + ! lambda = (c n/q)^(1/d) + lam = (props%shape_coef * nic/qic)**(1._r8/props%eff_dim) + if (ice_sep) then + miu_ice = max(min(0.008_r8*(lam*0.01)**0.87_r8, 10.0_r8), 0.1_r8) + tx1 = 1. + miu_ice + tx2 = 1. / gamma(tx1) + aux = (gamma(tx1+3.)*tx2) ** (1./3.) + lam = lam*aux + else + aux = 1. + tx1 = 1.0 + tx2 = 1.0 + end if + if (present(n0)) n0 = nic * lam**tx1*tx2 + + ! check for slope + ! adjust vars + if (lam < props%lambda_bounds(1)*aux) then + lam = props%lambda_bounds(1) + nic = lam**(props%eff_dim) * qic/props%shape_coef + if (present(n0)) n0 = nic * lam + else if (lam > props%lambda_bounds(2)*aux) then + lam = props%lambda_bounds(2) + nic = lam**(props%eff_dim) * qic/props%shape_coef + if (present(n0)) n0 = nic * lam + end if + + else + lam = 0._r8 + end if + + +end subroutine size_dist_param_ice_line + +subroutine size_dist_param_ice_vect(props, qic, nic, lam, mgncol, n0) + + type (mghydrometeorprops), intent(in) :: props + integer, intent(in) :: mgncol + real(r8), dimension(mgncol), intent(in) :: qic + real(r8), dimension(mgncol), intent(inout) :: nic + real(r8), dimension(mgncol), intent(out) :: lam + real(r8), dimension(mgncol), intent(out), optional :: n0 + real(r8) :: miu_ice,tx1,tx2, aux + integer :: i + logical, parameter :: ice_sep=.true. + do i=1,mgncol + + if (qic(i) > qsmall) then + + ! add upper limit to in-cloud number concentration to prevent + ! numerical error + if (limiter_is_on(props%min_mean_mass)) then + nic(i) = min(nic(i), qic(i) / props%min_mean_mass) + end if + + ! lambda = (c n/q)^(1/d) + lam(i) = (props%shape_coef * nic(i)/qic(i))**(1._r8/props%eff_dim) + if (ice_sep) then + miu_ice = max(min(0.008_r8*(lam(i)*0.01)**0.87_r8, 10.0_r8), 0.1_r8) + tx1 = 1. + miu_ice + tx2 = 1. / gamma(tx1) + aux = (gamma(tx1+3.)*tx2) ** (1./3.) + lam(i) = lam(i)*aux + else + aux = 1. + tx1 = 1.0 + tx2 = 1.0 + end if + if (present(n0)) n0(i) = nic(i) * lam(i)**tx1*tx2 + + ! check for slope + ! adjust vars + if (lam(i) < props%lambda_bounds(1)*aux) then + lam(i) = props%lambda_bounds(1) + nic(i) = lam(i)**(props%eff_dim) * qic(i)/props%shape_coef + if (present(n0)) n0(i) = nic(i) * lam(i) + else if (lam(i) > props%lambda_bounds(2)*aux) then + lam(i) = props%lambda_bounds(2) + nic(i) = lam(i)**(props%eff_dim) * qic(i)/props%shape_coef + if (present(n0)) n0(i) = nic(i) * lam(i) + end if + + else + lam(i) = 0._r8 + end if + + enddo + +end subroutine size_dist_param_ice_vect + real(r8) elemental function avg_diameter(q, n, rho_air, rho_sub) ! Finds the average diameter of particles given their density, and @@ -711,7 +865,8 @@ subroutine ice_deposition_sublimation(t, qv, qi, ni, & !Compute linearized condensational heating correction ab = calc_ab(t(i), qvi(i), xxls) !Get slope and intercept of gamma distn for ice. - call size_dist_param_basic(mg_ice_props, qiic, niic, lami, n0i) +! call size_dist_param_basic(mg_ice_props, qiic, niic, lami, n0i) + call size_dist_param_ice(mg_ice_props, qiic, niic, lami, n0i) !Get depletion timescale=1/eps epsi = twopi*n0i*rho(i)*Dv(i)/(lami*lami) @@ -901,26 +1056,28 @@ subroutine liu_liq_autoconversion(pgam,qc,nc,qr,rho,relvar, & real(r8), dimension(mgncol), intent (out) :: nprc1 real(r8), dimension(mgncol), intent (out) :: nprc real(r8) :: xs,lw, nw, beta6 - real(r8), parameter :: dcrit=1.0e-6, miu_disp=1. +! real(r8), parameter :: dcrit=1.0e-6, miu_disp=1. +! real(r8), parameter :: dcrit=1.0e-3, miu_disp=1. + real(r8), parameter :: dcrit=2.0e-3, miu_disp=0.8 integer :: i do i=1,mgncol if (qc(i) > qsmall) then - xs = 1. / (1.+pgam(i)) - beta6 = (1.+3.0*xs)*(1.+4.0*xs)*(1.+5.0*xs) & - / ((1.+xs)*(1.+xs+xs)) + xs = one / (one+pgam(i)) + beta6 = (one+three*xs)*(one+four*xs)*(one+five*xs) & + / ((one+xs)*(one+xs+xs)) LW = 1.0e-3_r8 * qc(i) * rho(i) NW = nc(i) * rho(i) * 1.e-6_r8 xs = min(20.0, 1.03e16*(LW*LW)/(NW*SQRT(NW))) au(i) = 1.1e10*beta6*LW*LW*LW & - * (1.-exp(-(xs**miu_disp))) / NW + * (one-exp(-(xs**miu_disp))) / NW au(i) = au(i)*1.0e3/rho(i) - au(i) = au(i) * gamma(2.+relvar(i)) & + au(i) = au(i) * gamma(two+relvar(i)) & / (gamma(relvar(i))*(relvar(i)*relvar(i))) - au(i) = au(i)*dcrit - nprc1(i)= au(i) * two/2.6e-7_r8*1000._r8 + au(i) = au(i) * dcrit + nprc1(i)= au(i) * (two/2.6e-7_r8*1000._r8) nprc(i) = au(i) / droplet_mass_40um else au(i) = zero @@ -1052,7 +1209,7 @@ subroutine gmao_ice_autoconversion(t, qiic, niic, lami, n0i, & real(r8) :: m_ip, tx1, tx2 - integer :: i + integer :: i do i=1,mgncol if (t(i) <= tmelt .and. qiic(i) >= qsmall) then m_ip = max(min(0.008_r8*(lami(i)*0.01)**0.87_r8, & @@ -2014,19 +2171,19 @@ subroutine graupel_collecting_cld_water(qgic,qcic,ncic,rho,n0g,lamg,bg,agn, & real(r8) :: cons, tx1 integer :: i - cons = gamma(bg + 3._r8)*pi/4._r8 * ecid + cons = gamma(bg+three) * pi/four * ecid do i=1,mgncol if (qgic(i) >= 1.e-8 .and. qcic(i) >= qsmall) then - tx1 = cons*agn(i)*rho(i)*n0g(i) / lamg(i)**(bg+3.) + tx1 = cons*agn(i)*rho(i)*n0g(i) / lamg(i)**(bg+three) psacwg(i) = tx1 * qcic(i) npsacwg(i) = tx1 * ncic(i) else - psacwg(i) = 0._r8 - npsacwg(i) = 0._r8 + psacwg(i) = zero + npsacwg(i) = zero end if enddo end subroutine graupel_collecting_cld_water @@ -2529,8 +2686,7 @@ FUNCTION gamma_incomp(muice, x) xog = log(alfa -0.3068_r8) kg = 1.44818*(alfa**0.5357_r8) auxx = max(min(kg*(log(x)-xog), 30._r8), -30._r8) - gamma_incomp = one / (one +exp(-auxx)) - gamma_incomp = max(gamma_incomp, 1.0e-20) + gamma_incomp = max(one/(one+exp(-auxx)), 1.0e-20) END FUNCTION gamma_incomp diff --git a/gfsphysics/physics/physcons.f90 b/gfsphysics/physics/physcons.f90 index bc975ce3b..f88788c12 100644 --- a/gfsphysics/physics/physcons.f90 +++ b/gfsphysics/physics/physcons.f90 @@ -45,7 +45,8 @@ module physcons ! !> \name Math constants !> pi - real(kind=kind_phys),parameter:: con_pi =3.1415926535897931 +! real(kind=kind_phys),parameter:: con_pi =3.1415926535897931 + real(kind=kind_phys),parameter:: con_pi =4.0d0*atan(1.0d0) !> square root of 2 real(kind=kind_phys),parameter:: con_sqrt2 =1.414214e+0 !> square root of 3 diff --git a/gfsphysics/physics/physparam.f b/gfsphysics/physics/physparam.f index 3e6d58925..f3742c9cc 100755 --- a/gfsphysics/physics/physparam.f +++ b/gfsphysics/physics/physparam.f @@ -23,14 +23,14 @@ !> \defgroup physparam physparam !! @{ !> This module defines commonly used control variables and parameters -!! in physics related programs. +!! in physics related programs. !! !! Those variables are grouped together in accordance with functionaity -!! and are given brief descriptions and value specifications. There are +!! and are given brief descriptions and value specifications. There are !! two types of attributes (parameters vs. save) designated for the -!! control variables. Those with a "parameter" attribute are prescribed +!! control variables. Those with a "parameter" attribute are prescribed !! with a preferred option value, while the ones with a "save" attribute -!! are given a default value but could be changed at the model's +!! are given a default value but could be changed at the model's !! execution-time (usually through an input of name-list file or through !! run scripts). !========================================! @@ -61,77 +61,77 @@ module physparam ! !================================================================================== ! ............................................. ! -!> \name -1.1- Control flags for SW radiation +!> \name -1.1- Control flags for SW radiation ! ............................................. ! !> SW heating rate unit control flag: =1:k/day; =2:k/second. - integer,parameter :: iswrate = 2 + integer,parameter :: iswrate = 2 !> SW minor gases effect control flag (CH4 and O2): =0:no; =1:yes. !!\n =0: minor gases' effects are not included in calculations !!\n =1: minor gases' effects are included in calculations integer,parameter :: iswrgas = 1 - + !> SW optical property for liquid clouds !!\n =0:input cld opt depth, ignoring iswcice setting -!!\n =1:cloud optical property scheme based on Hu and Stamnes(1993) \cite +!!\n =1:cloud optical property scheme based on Hu and Stamnes(1993) \cite !! hu_and_stamnes_1993 method !!\n =2:cloud optical property scheme based on Hu and Stamnes(1993) -updated - integer,save :: iswcliq = 1 - + integer,save :: iswcliq = 1 + !> SW optical property for ice clouds (only iswcliq>0) -!!\n =1:optical property scheme based on Ebert and Curry (1992) +!!\n =1:optical property scheme based on Ebert and Curry (1992) !! \cite ebert_and_curry_1992 method -!!\n =2:optical property scheme based on Streamer v3.0 +!!\n =2:optical property scheme based on Streamer v3.0 !! \cite key_2002 method -!!\n =3:optical property scheme based on Fu's method (1996) +!!\n =3:optical property scheme based on Fu's method (1996) !! \cite fu_1996 method - integer,save :: iswcice = 3 - + integer,save :: iswcice = 3 + !> SW control flag for scattering process approximation !!\n =1:two-stream delta-eddington (Joseph et al. 1976 !! \cite joseph_et_al_1976) -!!\n =2:two-stream PIFM (Zdunkowski et al. 1980 +!!\n =2:two-stream PIFM (Zdunkowski et al. 1980 !! \cite zdunkowski_et_al_1980) -!!\n =3:discrete ordinates (Liou, 1973 +!!\n =3:discrete ordinates (Liou, 1973 !! \cite liou_1973) - integer,parameter :: iswmode = 2 + integer,parameter :: iswmode = 2 ! ............................................. ! -!> \name -1.2- Control flags for LW radiation +!> \name -1.2- Control flags for LW radiation ! ............................................. ! !> LW heating rate unit: =1:k/day; =2:k/second. - integer,parameter :: ilwrate = 2 + integer,parameter :: ilwrate = 2 !> LW minor gases effect control flag (CH4,N2O,O2,and some CFCs): !!\n =0: minor gases' effects are not included in calculations !!\n =1: minor gases' effects are included in calculations - integer,parameter :: ilwrgas = 1 + integer,parameter :: ilwrgas = 1 !> LW optical property scheme for liquid clouds !!\n =0:input cloud optical properties directly, not computed within -!!\n =1:input cwp,rew, use Hu and Stamnes(1993) +!!\n =1:input cwp,rew, use Hu and Stamnes(1993) !! \cite hu_and_stamnes_1993 method - integer,save :: ilwcliq = 1 + integer,save :: ilwcliq = 1 !> LW optical property scheme for ice clouds (only ilwcliq>0) -!!\n =1:optical property scheme based on Ebert and Curry (1992) +!!\n =1:optical property scheme based on Ebert and Curry (1992) !! \cite ebert_and_curry_1992 method -!!\n =2:optical property scheme based on Streamer v3 +!!\n =2:optical property scheme based on Streamer v3 !! \cite key_2002 method -!!\n =3:optical property scheme use Fu's method (1998) +!!\n =3:optical property scheme use Fu's method (1998) !! \cite fu_et_al_1998 method - integer,save :: ilwcice = 3 + integer,save :: ilwcice = 3 ! ............................................. ! -!>\name -1.3- Control flag for LW aerosol property +!>\name -1.3- Control flag for LW aerosol property !> selects 1 band or multi bands for LW aerosol properties !!\n =.true.:aerosol properties calculated in 1 broad LW band !!\n =.false.:aerosol properties calculated in all LW bands !!\n variable names diff in Opr CFS - logical,parameter :: lalw1bd =.false. + logical,parameter :: lalw1bd =.false. !================================================================================== ! Section - 2 - @@ -140,7 +140,7 @@ module physparam ! !================================================================================== ! ............................................. ! -!>\name -2.1- For module radiation_astronomy +!>\name -2.1- For module radiation_astronomy ! ............................................. ! !> solar constant scheme control flag @@ -151,15 +151,15 @@ module physparam ! !!\n =3:CMIP5 TIM-scale TSI table (yearly) w 11-yr cycle approx !!\n =4:CMIP5 TIM-scale TSI table (monthly) w 11-yr cycle approx !!\n see ISOL in run scripts: Opr GFS=2; Opr CFS=1 - integer, save :: isolar = 0 + integer, save :: isolar = 0 !> external solar constant data table,solarconstant_noaa_a0.txt - character, save :: solar_file*26 + character, save :: solar_file*26 ! data solar_file / 'solarconstantdata.txt ' / data solar_file / 'solarconstant_noaa_a0.txt ' / ! ............................................. ! -!> \name -2.2- For module radiation_aerosols +!> \name -2.2- For module radiation_aerosols ! ............................................. ! !> aerosol model scheme control flag @@ -168,7 +168,7 @@ module physparam ! !!\n =2: GOCART prognostic aerosol model !!\n =5: OPAC climatoloy with new band mapping !!\n Opr GFS=0; Opr CFS=n/a - integer, save :: iaermdl = 0 + integer, save :: iaermdl = 0 !> aerosol effect control flag !!\n 3-digit flag 'abc': @@ -177,10 +177,10 @@ module physparam ! !!\n c-tropospheric aerosols for SW !!\n =0:aerosol effect is not included; =1:aerosol effect is included !!\n Opr GFS/CFS =111; see IAER in run scripts - integer, save :: iaerflg = 0 + integer, save :: iaerflg = 0 !> external aerosols data file: aerosol.dat - character, save :: aeros_file*26 + character, save :: aeros_file*26 ! data aeros_file / 'climaeropac_global.txt ' / data aeros_file / 'aerosol.dat ' / @@ -193,7 +193,7 @@ module physparam ! !!\n =1:yearly global averaged annual mean from observations !!\n =2:monthly 15 degree horizontal resolution from observations !!\n Opr GFS/CFS=2; see ICO2 in run scripts - integer, save :: ico2flg = 0 + integer, save :: ico2flg = 0 !> controls external data at initial time and data usage during !! forecast time @@ -204,20 +204,20 @@ module physparam ! !!\n =yyyy0:use yyyy year of data, no extrapolation !!\n =yyyy1:use yyyy year of data, extrapolate when necessary !!\n Opr GFS/CFS=1; see ICTM in run scripts - integer, save :: ictmflg = 0 + integer, save :: ictmflg = 0 !> ozone data source control flag !!\n =0:use seasonal climatology ozone data -!!\n >0:use prognostic ozone scheme (also depend on other model control -!! variable at initial time) - integer, save :: ioznflg = 1 +!!\n >0:use prognostic ozone scheme (also depend on other model control +!! variable at initial time + integer, save :: ioznflg = 1 !> external co2 2d monthly obsv data table: co2historicaldata_2004.txt - character, save :: co2dat_file*26 + character, save :: co2dat_file*26 !> external co2 global annual mean data tb: co2historicaldata_glob.txt - character, save :: co2gbl_file*26 -!> external co2 user defined data table: co2userdata.txt - character, save :: co2usr_file*26 + character, save :: co2gbl_file*26 +!> external co2 user defined data table: co2userdata.txt + character, save :: co2usr_file*26 !> external co2 clim monthly cycle data tb: co2monthlycyc.txt character, save :: co2cyc_file*26 data co2dat_file / 'co2historicaldata_2004.txt' / !year is run-time selected @@ -226,13 +226,13 @@ module physparam ! data co2cyc_file / 'co2monthlycyc.txt ' / ! ............................................. ! -!>\name -2.4- For module radiation_clouds +!>\name -2.4- For module radiation_clouds ! ............................................. ! !> cloud optical property scheme control flag !!\n =0:use diagnostic cloud scheme for cloud cover and mean optical properties !!\n =1:use prognostic cloud scheme for cloud cover and cloud properties - integer, save :: icldflg = 1 + integer, save :: icldflg = 1 !> cloud overlapping control flag for SW !!\n =0:use random cloud overlapping method @@ -240,14 +240,14 @@ module physparam ! !!\n =2:use maximum cloud overlapping method !!\n =3:use decorrelation length overlapping method !!\n Opr GFS/CFS=1; see IOVR_SW in run scripts - integer, save :: iovrsw = 1 + integer, save :: iovrsw = 1 !> cloud overlapping control flag for LW !!\n =0:use random cloud overlapping method !!\n =1:use maximum-random cloud overlapping method !!\n =2:use maximum cloud overlapping method !!\n =3:use decorrelation length overlapping method !!\n Opr GFS/CFS=1; see IOVR_LW in run scripts - integer, save :: iovrlw = 1 + integer, save :: iovrlw = 1 !> sub-column cloud approx flag in SW radiation !!\n =0:no McICA approximation in SW radiation @@ -263,42 +263,42 @@ module physparam ! integer, save :: isubclw = 0 !> eliminating CRICK control flag - logical, save :: lcrick =.false. + logical, save :: lcrick =.false. !> in-cld condensate control flag logical, save :: lcnorm =.false. !> precip effect on radiation flag (Ferrier microphysics) - logical, save :: lnoprec =.false. + logical, save :: lnoprec =.false. !> shallow convetion flag - logical, save :: lsashal =.false. + logical, save :: lsashal =.false. ! ............................................. ! -!>\name -2.5- For module radiation_surface +!>\name -2.5- For module radiation_surface ! ............................................. ! !> surface albedo scheme control flag !!\n =0:vegetation type based climatological albedo scheme !!\n =1:seasonal albedo derived from MODIS measurements - integer, save :: ialbflg = 0 + integer, save :: ialbflg = 0 !> surface emissivity scheme control flag !!\n =0:black-body surface emissivity(=1.0) !!\n =1:vegetation type based climatology emissivity(<1.0) !!\n Opr GFS/CFS=1; see IEMS in run scripts - integer, save :: iemsflg = 0 + integer, save :: iemsflg = 0 !> external sfc emissivity data table: sfc_emissivity_idx.txt - character, save :: semis_file*26 + character, save :: semis_file*26 data semis_file / 'sfc_emissivity_idx.txt ' / ! ............................................. ! -!> \name -2.6- general purpose +!> \name -2.6- general purpose ! ............................................. ! !> vertical profile indexing flag - integer, save :: ivflip = 1 + integer, save :: ivflip = 1 !> initial permutaion seed for mcica radiation - integer, save :: ipsd0 = 0 + integer, save :: ipsd0 = 0 integer, save :: ipsdlim = 1e8 ! !...................................! diff --git a/gfsphysics/physics/radiation_aerosols.f b/gfsphysics/physics/radiation_aerosols.f index 722a9d5c4..732556c6d 100644 --- a/gfsphysics/physics/radiation_aerosols.f +++ b/gfsphysics/physics/radiation_aerosols.f @@ -4388,7 +4388,7 @@ subroutine rd_gocart_luts !! 0.1399 0.2399 0.4499 0.8000 1.3994 2.3964 4.4964 7.9887 <-- reff data indx_dust/4, 8, 12, 18, 21, 24, 30, 36/ - PI = acos(-1.d0) +! PI = acos(-1.d0) ! -- allocate aerosol optical data if ( .not. allocated( iendwv_grt ) ) then diff --git a/gfsphysics/physics/radiation_astronomy.f b/gfsphysics/physics/radiation_astronomy.f index 888de73fd..4145054e3 100644 --- a/gfsphysics/physics/radiation_astronomy.f +++ b/gfsphysics/physics/radiation_astronomy.f @@ -105,8 +105,8 @@ module module_radiation_astronomy ! real (kind=kind_phys), parameter :: f12 = 12.0 real (kind=kind_phys), parameter :: f3600 = 3600.0 real (kind=kind_phys), parameter :: czlimt = 0.0001 ! ~ cos(89.99427) -! real (kind=kind_phys), parameter :: pid12 = con_pi/f12 ! angle per hour - real (kind=kind_phys), parameter :: pid12 = (2.0*asin(1.0))/f12 + real (kind=kind_phys), parameter :: pid12 = con_pi/f12 ! angle per hour +! real (kind=kind_phys), parameter :: pid12 = (2.0*asin(1.0))/f12 !> \name Module variable (to be set in module_radiation_astronomy::sol_init): real (kind=kind_phys), public :: solc0 = con_solr @@ -602,15 +602,18 @@ subroutine sol_update & nswr = nint(deltsw / deltim) ! number of mdl t-step per sw call dtswh = deltsw / f3600 ! time length in hours - if ( deltsw >= f3600 ) then ! for longer sw call interval - nn = max(6, min(12, nint(f3600/deltim) )) ! num of calc per hour - nstp = nint(dtswh) * nn + 1 ! num of calc per sw call - else ! for shorter sw sw call interval - nstp = max(2, min(20, nswr)) + 1 -! nn = nint( float(nstp-1)/dtswh ) - endif +! if ( deltsw >= f3600 ) then ! for longer sw call interval +! nn = max(6, min(12, nint(f3600/deltim) )) ! num of calc per hour +! nstp = nint(dtswh) * nn + 1 ! num of calc per sw call +! else ! for shorter sw sw call interval +! nstp = max(2, min(20, nswr)) + 1 +!! nn = nint( float(nstp-1)/dtswh ) +! endif + +! anginc = pid12 * dtswh / float(nstp-1) ! solar angle inc during each calc step - anginc = pid12 * dtswh / float(nstp-1) ! solar angle inc during each calc step + nstp = nswr + anginc = pid12 * dtswh / float(nstp) if ( me == 0 ) then print *,' for cosz calculations: nswr,deltim,deltsw,dtswh =', & @@ -860,7 +863,7 @@ subroutine coszmn & enddo do it = 1, nstp - cns = solang + float(it-1)*anginc + sollag + cns = solang + (float(it)-0.5)*anginc + sollag do i = 1, IM ss = sinlat(i) * sindec diff --git a/gfsphysics/physics/radiation_clouds.f b/gfsphysics/physics/radiation_clouds.f index b06e1d33b..3ce9c35c8 100644 --- a/gfsphysics/physics/radiation_clouds.f +++ b/gfsphysics/physics/radiation_clouds.f @@ -148,6 +148,7 @@ ! ! ! jul 2014 s. moorthi - merging with gfs version ! ! feb 2017 a. cheng - add odepth output, effective radius input ! +! Jan 2018 S Moorthi - update to include physics from ipdv4 ! ! jun 2018 h-m lin/y-t hou - removed the legacy subroutine ! ! 'diagcld1' for diagnostic cloud scheme, added new cloud ! ! overlapping method of de-correlation length, and optimized ! @@ -2807,7 +2808,7 @@ subroutine progclduni & crp (i,k) = 0.0 csp (i,k) = 0.0 rew (i,k) = effrl (i,k) - rei (i,k) = effri (i,k) + rei (i,k) = max(10.0, min(150.0,effri (i,k))) rer (i,k) = effrr (i,k) res (i,k) = effrs (i,k) tem2d (i,k) = min( 1.0, max( 0.0,(con_ttp-tlyr(i,k))*0.05)) diff --git a/gfsphysics/physics/rascnvv2.f b/gfsphysics/physics/rascnvv2.f index ce4dec6f1..3e3039510 100644 --- a/gfsphysics/physics/rascnvv2.f +++ b/gfsphysics/physics/rascnvv2.f @@ -6,7 +6,7 @@ module module_ras implicit none SAVE ! - integer, parameter :: nrcmax=32 ! Maximum # of random clouds per 1200s + integer, parameter :: nrcmax=32 ! Maximum # of random clouds per 1200s real (kind=kind_phys), parameter :: delt_c=1800.0/3600.0 & ! Adjustment time scales in hrs for deep and shallow clouds @@ -17,19 +17,31 @@ module module_ras logical, parameter :: fix_ncld_hr=.true. ! real (kind=kind_phys), parameter :: ZERO=0.0, HALF=0.5 & + &, pt25=0.25 & &, ONE=1.0, TWO=2.0, FOUR=4.& + &, twoo3=two/3.0 & &, FOUR_P2=4.E2, ONE_M10=1.E-10 & &, ONE_M6=1.E-6, ONE_M5=1.E-5 & &, ONE_M2=1.E-2, ONE_M1=1.E-1 & + &, oneolog10=one/log(10.0) & + &, cfmax=0.1 & &, cmb2pa = 100.0 ! Conversion from Mb to Pa ! real(kind=kind_phys), parameter :: & - & ONEBG = ONE / GRAV, GRAVCON = cmb2pa * ONEBG & - &, GRAVFAC = GRAV / CMB2PA, ELOCP = ALHL / CP & - &, ELFOCP = (ALHL+ALHF) / CP & -! &, RKAPI = ONE / RKAP, RKPP1I = ONE / (ONE+RKAP) & - &, CMPOR = CMB2PA / RGAS & - &, zfac = 0.28888889E-4 * ONEBG + & ONEBG = ONE / GRAV, GRAVCON = cmb2pa * ONEBG & + &, onebcp = one / cp & + &, GRAVFAC = GRAV / CMB2PA, ELOCP = ALHL * onebcp & + &, ELFOCP = (ALHL+ALHF) * onebcp & + &, oneoalhl = one/alhl & + &, CMPOR = CMB2PA / RGAS & + &, picon = half*pi*onebg, VTPEXP = -0.3636 & + &, dpnegcr = 150.0 & +! &, dpnegcr = 100.0 & +! &, dpnegcr = 200.0 & +! &, ddunc1 = 0.4, ddunc2=one-ddunc1 & uncentering for vvel in dd + &, ddunc1 = 0.25, ddunc2=one-ddunc1 & uncentering for vvel in dd +! &, ddunc1 = 0.3, ddunc2=one-ddunc1 & uncentering for vvel in dd + &, zfac = 0.28888889E-4 * ONEBG ! ! logical, parameter :: advcld=.true., advups=.true., advtvd=.false. logical, parameter :: advcld=.true., advups=.false., advtvd=.true. @@ -37,18 +49,21 @@ module module_ras ! real(kind=kind_phys) RHMAX, qudfac, QUAD_LAM, RHRAM, TESTMB, & & TSTMBI, HCRITD, DD_DP, RKNOB, AFC, EKNOB& - &, shalfac,HCRITS, HPERT_FAC + &, shalfac,HCRITS, HPERT_FAC, pcrit_lcl & + &, testmboalhl, testmbi -! PARAMETER (DD_DP=1000.0, RKNOB=1.0, EKNOB=1.0) ! No downdraft! - PARAMETER (DD_DP=500.0, RKNOB=1.0, EKNOB=1.0) -! PARAMETER (DD_DP=500.0, RKNOB=2.0, EKNOB=1.0) +! PARAMETER (DD_DP=0.0, RKNOB=1.0, EKNOB=1.0) ! No downdraft! + PARAMETER (DD_DP=0.5, RKNOB=1.0, EKNOB=1.0) +! PARAMETER (DD_DP=0.5, RKNOB=2.0, EKNOB=1.0) ! PARAMETER (RHMAX=1.0 ) ! MAX RELATIVE HUMIDITY PARAMETER (QUAD_LAM=1.0) ! MASK FOR QUADRATIC LAMBDA ! PARAMETER (RHRAM=0.15) ! PBL RELATIVE HUMIDITY RAMP PARAMETER (RHRAM=0.05) ! PBL RELATIVE HUMIDITY RAMP - PARAMETER (HCRITD=4000.0) ! Critical Moist Static Energy - PARAMETER (HCRITS=2000.0) ! Critical Moist Static Energy + PARAMETER (HCRITD=4000.0) ! Critical Moist Static Energy for Deep clouds + PARAMETER (HCRITS=2000.0) ! Critical Moist Static Energy for Shallow Clouds + PARAMETER (pcrit_lcl=250.0)! Critical pressure difference between boundary layer top +! and lifting condensation level (hPa) ! parameter (hpert_fac=1.01) ! Perturbation on hbl when ctei=.true. ! parameter (hpert_fac=1.005)! Perturbation on hbl when ctei=.true. @@ -56,38 +71,33 @@ module module_ras ! parameter (qudfac=quad_lam*half, shalfac=1.0) ! parameter (qudfac=quad_lam*half, shalfac=2.0) parameter (qudfac=quad_lam*half, shalfac=3.0) -! parameter (qudfac=quad_lam*0.25) ! Yogesh's - parameter (testmb=0.1, tstmbi=one/testmb) +! parameter (qudfac=quad_lam*pt25) ! Yogesh's + parameter (testmb=0.1, testmbi=one/testmb) + parameter (testmboalhl=testmb/alhl) ! - real(kind=kind_phys) ALMIN1, ALMIN2, ALMAX real(kind=kind_phys) facdt + + real(kind=kind_phys), parameter :: almax=1.0e-2 + &, almin1=0.0, almin2=0.0 + +! real(kind=kind_phys) ALMIN1, ALMIN2, ALMAX ! ! PARAMETER (ALMIN1=0.00E-6, ALMIN2=2.50E-5, ALMAX=1.0E-2) - PARAMETER (ALMIN1=0.00E-6, ALMIN2=0.00E-5, ALMAX=1.0E-2) +!!! PARAMETER (ALMIN1=0.00E-6, ALMIN2=0.00E-5, ALMAX=1.0E-2) ! PARAMETER (ALMIN1=1.00E-5, ALMIN2=2.00E-5, ALMAX=1.0E-2) !cnt PARAMETER (ALMIN1=0.00E-6, ALMIN2=2.50E-5, ALMAX=5.0E-3) ! ! real(kind=kind_phys), parameter :: BLDMAX = 200.0 - real(kind=kind_phys), parameter :: BLDMAX = 300.0 + real(kind=kind_phys), parameter :: BLDMAX = 300.0, bldmin=25.0 !! real(kind=kind_phys), parameter :: BLDMAX = 350.0 ! - real(kind=kind_phys) C0, C0I, QI0, QW0, c00, c00i, dlq_fac - PARAMETER (QI0=1.0E-5, QW0=1.0E-5) -! PARAMETER (QI0=1.0E-4, QW0=1.0E-5) ! 20050509 -! PARAMETER (QI0=1.0E-5, QW0=1.0E-6) -!!! PARAMETER (C0I=1.0E-3) - PARAMETER (C00I=1.0E-3) -! PARAMETER (C00I=2.0E-3) -! parameter (c0=1.0e-3) -! parameter (c0=1.5e-3) -!!! parameter (c0=2.0e-3) - parameter (c00=2.0e-3) ! real(kind=kind_phys) TF, TCR, TCRF, TCL ! parameter (TF=130.16, TCR=160.16, TCRF=1.0/(TCR-TF),TCL=2.0) ! parameter (TF=230.16, TCR=260.16, TCRF=1.0/(TCR-TF)) ! parameter (TF=233.16, TCR=263.16, TCRF=1.0/(TCR-TF),TCL=2.0) - parameter (TF=258.16, TCR=273.16, TCRF=1.0/(TCR-TF),TCL=2.0) +! parameter (TF=258.16, TCR=273.16, TCRF=1.0/(TCR-TF),TCL=2.0) + parameter (TF=233.16, TCR=273.16, TCRF=1.0/(TCR-TF),TCL=2.0) ! ! For Tilting Angle Specification ! @@ -97,7 +107,7 @@ module module_ras DATA PLAC/100.0, 200.0, 300.0, 400.0, 500.0, 600.0, 700.0, 800.0/ DATA TLAC/ 35.0, 25.0, 20.0, 17.5, 15.0, 12.5, 10.0, 7.5/ DATA REFP/500.0, 300.0, 250.0, 200.0, 150.0, 100.0/ - DATA REFR/ 1.0, 2.0, 3.0, 4.0, 6.0, 8.0/ + DATA REFR/ 1.0, 2.0, 3.0, 4.0, 6.0, 8.0/ ! real(kind=kind_phys) AC(16), AD(16) ! @@ -123,37 +133,37 @@ subroutine ras_init(levs, me) ! integer levs, me ! - real(kind=kind_phys) actp, facm, tem, actop, tem1, tem2 - integer i, l - PARAMETER (ACTP=1.7, FACM=1.00) + real(kind=kind_phys), parameter :: actp=1.7, facm=1.00 ! - real(kind=kind_phys) PH(15), A(15) + real(kind=kind_phys) PH(15), A(15) ! DATA PH/150.0, 200.0, 250.0, 300.0, 350.0, 400.0, 450.0, 500.0 & &, 550.0, 600.0, 650.0, 700.0, 750.0, 800.0, 850.0/ ! DATA A/ 1.6851, 1.1686, 0.7663, 0.5255, 0.4100, 0.3677 & - &, 0.3151, 0.2216, 0.1521, 0.1082, 0.0750, 0.0664 & - &, 0.0553, 0.0445, 0.0633/ + &, 0.3151, 0.2216, 0.1521, 0.1082, 0.0750, 0.0664 & + &, 0.0553, 0.0445, 0.0633/ ! + real(kind=kind_phys) tem, actop, tem1, tem2 + integer i, l logical first data first/.true./ ! if (first) then -! set critical workfunction arrays +! set critical workfunction arrays ACTOP = ACTP*FACM DO L=1,15 A(L) = A(L)*FACM ENDDO DO L=2,15 - TEM = 1.0 / (PH(L) - PH(L-1)) + TEM = one / (PH(L) - PH(L-1)) AC(L) = (PH(L)*A(L-1) - PH(L-1)*A(L)) * TEM AD(L) = (A(L) - A(L-1)) * TEM ENDDO AC(1) = ACTOP AC(16) = A(15) - AD(1) = 0.0 - AD(16) = 0.0 + AD(1) = zero + AD(16) = zero ! CALL SETQRP CALL SETVTP @@ -167,8 +177,8 @@ subroutine ras_init(levs, me) ! VTP = 36.34*SQRT(1.2)* (0.001)**0.1364 ! - if (me == 0) print *,' NO DOWNDRAFT FOR CLOUD TYPES' & - &, ' DETRAINING WITHIN THE BOTTOM ',DD_DP,' hPa LAYERS' + if (me == 0) write(0,*) ' NO DOWNDRAFT FOR CLOUD TYPES' & + &, ' DETRAINING AT NORMALIZED PRESSURE ABOVE ',DD_DP ! first = .false. endif @@ -182,44 +192,24 @@ module module_rascnv implicit none SAVE ! -! logical REVAP, CUMFRC - logical CUMFRC - LOGICAL WRKFUN, CALKBL, CRTFUN, UPDRET, BOTOP, vsmooth + LOGICAL WRKFUN, CALKBL, CRTFUN, UPDRET, BOTOP, vsmooth, do_aw & + &, CUMFRC real(kind=kind_phys), parameter :: frac=0.5, crtmsf=0.0 & &, rhfacs=0.70, rhfacl=0.70 & &, face=5.0, delx=10000.0 & &, ddfac=face*delx*0.001 & &, max_neg_bouy=0.15 -! &, max_neg_bouy=0.25 +! &, max_neg_bouy=pt25 -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!! real(kind=kind_phys) FRAC, CRTMSF, MAX_NEG_BOUY, rhfacs, rhfacl & -!! &, FACE, DELX, DDFAC -! parameter (frac=0.1, crtmsf=0.0) -! parameter (frac=0.25, crtmsf=0.0) -!! parameter (frac=0.5, crtmsf=0.0) -! PARAMETER (MAX_NEG_BOUY=0.15, REVAP=.true., CUMFRC=.false.) -! PARAMETER (MAX_NEG_BOUY=0.15, REVAP=.true., CUMFRC=.true.) -! PARAMETER (MAX_NEG_BOUY=0.10, REVAP=.true., CUMFRC=.true.) -! PARAMETER (MAX_NEG_BOUY=0.20, REVAP=.true., CUMFRC=.true.) -!! PARAMETER (MAX_NEG_BOUY=0.25, REVAP=.true., CUMFRC=.true.) -! PARAMETER (MAX_NEG_BOUY=0.30, REVAP=.true., CUMFRC=.true.) -!! PARAMETER (MAX_NEG_BOUY=0.05, REVAP=.true., CUMFRC=.true.) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! PARAMETER ( REVAP = .true., CUMFRC=.true.) - PARAMETER ( CUMFRC=.true.) + PARAMETER (do_aw = .true., CUMFRC=.true.) +! PARAMETER (do_aw = .false., CUMFRC=.true.) PARAMETER (WRKFUN = .FALSE., UPDRET = .FALSE., vsmooth=.false.) ! PARAMETER (CRTFUN = .TRUE., CALKBL = .false., BOTOP=.true.) PARAMETER (CRTFUN = .TRUE., CALKBL = .true., BOTOP=.true.) ! -!! parameter (rhfacs=0.70, rhfacl=0.70) -! parameter (rhfacs=0.75, rhfacl=0.75) -! parameter (rhfacs=0.85, rhfacl=0.85) -! parameter (rhfacs=0.80, rhfacl=0.80) ! August 26, 2008 -! parameter (rhfacs=0.80, rhfacl=0.85) -!! PARAMETER (FACE=5.0, DELX=10000.0, DDFAC=FACE*DELX*0.001) -! ! real (kind=kind_phys), parameter :: pgftop=0.7, pgfbot=0.3 & ! real (kind=kind_phys), parameter :: pgftop=0.75, pgfbot=0.35 & ! For pressure gradient force in momentum mixing @@ -236,12 +226,15 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & &, tin, qin, uin, vin, ccin, trac, fscav& &, prsi, prsl, prsik, prslk, phil, phii & &, KPBL, CDRAG, RAINC, kbot, ktop, kcnv & - &, DDVEL, FLIPV, facmb, me, garea, lmh, ccwfac& - &, nrcm, rhc, ud_mf, dd_mf, det_mf, dlqfac & + &, DDVEL, FLIPV, facmb, me, garea, ccwfac & + &, nrcm, rhc, ud_mf, dd_mf, det_mf & + &, c00, qw0, c00i, qi0, dlqfac & &, lprnt, ipr, kdt, revap & - &, QLCN, QICN, w_upi, cf_upi, CNV_MFD, CNV_PRC3 & - &, CNV_DQLDT,CLCN,CNV_FICE,CNV_NDROP,CNV_NICE, & - & mp_phys) + &, QLCN, QICN, w_upi, cf_upi, CNV_MFD & +! &, QLCN, QICN, w_upi, cf_upi, CNV_MFD, CNV_PRC3 & + &, CNV_DQLDT,CLCN,CNV_FICE,CNV_NDROP,CNV_NICE & + &, mp_phys, trcmin, ntk) +! &, mp_phys, trcmin) ! &, lprnt, ipr, kdt, fscav, ctei_r, ctei_rm) ! !********************************************************************* @@ -269,23 +262,28 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & ! ! input ! - Integer IM, IX, k, ncrnd, me, trac, ipr, nrcm, mp_phys, kdt - integer, dimension(im) :: kbot, ktop, kcnv, kpbl, lmh +! Integer IM, IX, k, ncrnd, me, trac, ipr, nrcm, mp_phys, kdt + Integer IM, IX, k, ncrnd, me, trac, ipr, nrcm, mp_phys, kdt,ntk + integer, dimension(im) :: kbot, ktop, kcnv, kpbl ! real(kind=kind_phys), dimension(ix,k) :: tin, qin, uin, vin & &, prsl, prslk, phil real(kind=kind_phys), dimension(ix,k+1) :: prsi, prsik, phii real(kind=kind_phys), dimension(im,k) :: ud_mf, dd_mf, det_mf & &, rhc, qlcn, qicn, w_upi & - &, cnv_mfd, cnv_prc3 & + &, cnv_mfd & +! &, cnv_mfd, cnv_prc3 & &, cnv_dqldt, clcn & &, cnv_fice, cnv_ndrop & &, cnv_nice, cf_upi real(kind=kind_phys), dimension(im) :: ccwfac, rainc, cdrag & - &, ddvel, garea + &, ddvel, garea & + &, c00, c00i, dlqfac real(kind=kind_phys), dimension(ix,nrcm):: rannum real(kind=kind_phys) ccin(ix,k,trac+2) - real(kind=kind_phys) dlqfac, DT, facmb, dtf + real(kind=kind_phys) trcmin(trac+2) + + real(kind=kind_phys) DT, facmb, dtf, qw0, qi0 ! ! Added for aerosol scavenging for GOCART ! @@ -295,56 +293,57 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & ! ! locals ! - real(kind=kind_phys), dimension(k) :: toi, qoi, tcu, qcu & - &, pcu, clw, cli, qii, qli & - &, phi_l,prsm,psjm & + real(kind=kind_phys), dimension(k) :: toi, qoi, tcu, qcu & + &, pcu, clw, cli, qii, qli& + &, phi_l, prsm,psjm & &, alfinq, alfind, rhc_l + &, qoi_l, qli_l, qii_l real(kind=kind_phys), dimension(k+1) :: prs, psj, phi_h, flx, flxd - integer, parameter :: icm = 100 - real, parameter :: DAYLEN=86400.0, PFAC=1.0/450.0 & - &, clwmin=1.0e-10 - Integer IC(ICM) + integer, dimension(100) :: ic + real(kind=kind_phys), parameter :: clwmin=1.0e-10 ! real(kind=kind_phys), allocatable :: ALFINT(:,:), uvi(:,:) &, trcfac(:,:), rcu(:,:) real(kind=kind_phys) dtvd(2,4) -! &, DPI(K), psjp(k+1) - real(kind=kind_phys) CFAC, TEM, sgc, ccwf, tem1, tem2 & - &, rain,wfnc,tla,pl,qiid,qlid +! &, DPI(K) + real(kind=kind_phys) CFAC, TEM, sgc, ccwf, tem1, tem2, rain & + &, wfnc,tla,pl,qiid,qlid, c0, c0i, dlq_fac, sumq& + &, rainp ! Integer KCR, KFX, NCMX, NC, KTEM, I, L, lm1 & &, ntrc, ia, ll, km1, kp1, ipt, lv, KBL, n & - &, lmhij, KRMIN, KRMAX, KFMAX, kblmx, irnd,ib + &, KRMIN, KRMAX, KFMAX, kblmx, irnd,ib & + &, kblmn, ksfc real(kind=kind_phys) sgcs(k,im) ! - LOGICAL DNDRFT, lprint -! LOGICAL DNDRFT, lprint, ctei + LOGICAL lprint +! LOGICAL lprint, ctei ! ! Scavenging related parameters ! real fscav_(trac+2) ! Fraction scavenged per km ! -! write(0,*)' fscav=',fscav,' trac=',trac - - fscav_ = 0.0 ! By default no scavenging + fscav_ = zero ! By default no scavenging if (trac > 0) then do i=1,trac fscav_(i) = fscav(i) enddo endif - if (lprnt) write(0,*)' in RAS fscav=',fscav_,' ccwfac=', - & ccwfac(ipr),' mp_phys=',mp_phys +! if (me == 0) write(0,*)' rann=',rannum(1,:),' kdt=',kdt +! if (lprnt) write(0,*)' in RAS fscav=',fscav_,' ccwfac=', +! & ccwfac(ipr),' mp_phys=',mp_phys +! &, ' fscav=',fscav,' trac=',trac ! - km1 = k - 1 - kp1 = k + 1 -! - dlq_fac = dlqfac - tem = 1.0 + dlq_fac - c0 = c00 * tem - c0i = c00i * tem + km1 = k - 1 + kp1 = k + 1 + if (flipv) then + ksfc = 1 + else + ksfc = kp1 + endif ! ntrc = trac IF (CUMFRC) THEN @@ -356,8 +355,8 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & if (.not. allocated(rcu)) allocate (rcu(k,ntrc)) do n=1, ntrc do l=1,k - trcfac(l,n) = 1.0 ! For other tracers - rcu(l,n) = 0.0 + trcfac(l,n) = one ! For other tracers + rcu(l,n) = zero enddo enddo endif @@ -366,17 +365,17 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & if(mp_phys == 10) then do l=1,K do i=1,im - QLCN(i,l) = 0.0 - QICN(i,l) = 0.0 - w_upi(i,l) = 0.0 - cf_upi(i,l) = 0.0 - CNV_MFD(i,l) = 0.0 - CNV_PRC3(i,l) = 0.0 - CNV_DQLDT(i,l) = 0.0 - CLCN(i,l) = 0.0 - CNV_FICE(i,l) = 0.0 - CNV_NDROP(i,l) = 0.0 - CNV_NICE(i,l) = 0.0 + QLCN(i,l) = zero + QICN(i,l) = zero + w_upi(i,l) = zero + cf_upi(i,l) = zero + CNV_MFD(i,l) = zero +! CNV_PRC3(i,l) = zero + CNV_DQLDT(i,l) = zero + CLCN(i,l) = zero + CNV_FICE(i,l) = zero + CNV_NDROP(i,l) = zero + CNV_NICE(i,l) = zero enddo enddo endif @@ -385,40 +384,38 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & ! call set_ras_afc(dt) ! + do l=1,k + do i=1,im + ud_mf(i,l) = zero + dd_mf(i,l) = zero + det_mf(i,l) = zero + enddo + enddo DO IPT=1,IM - ccwf = 0.5 - if (ccwfac(ipt) >= 0.0) ccwf = ccwfac(ipt) + ccwf = half + if (ccwfac(ipt) >= zero) ccwf = ccwfac(ipt) + dlq_fac = dlqfac(ipt) + tem = one + dlq_fac + c0 = c00(IPT) * tem + c0i = c00i(IPT) * tem ! ! ctei = .false. ! if (ctei_r(ipt) > ctei_rm) ctei = .true. ! - - do l=1,k - ud_mf(ipt,l) = 0.0 - dd_mf(ipt,l) = 0.0 - det_mf(ipt,l) = 0.0 - enddo -! -! Compute NCRND : here LMH is the number of layers above the -! bottom surface. For sigma coordinate LMH=K. +! Compute NCRND : ! if flipv is true, then input variables are from bottom ! to top while RAS goes top to bottom ! - LMHIJ = LMH(ipt) - if (flipv) then - ll = kp1 - LMHIJ - tem = 1.0 / prsi(ipt,ll) - else - ll = LMHIJ - tem = 1.0 / prsi(ipt,ll+1) - endif + tem = one / prsi(ipt,ksfc) + KRMIN = 1 KRMAX = km1 KFMAX = KRMAX kblmx = 1 - DO L=1,LMHIJ-1 + kblmn = 1 + DO L=1,KM1 ll = l if (flipv) ll = kp1 -l ! Input variables are bottom to top! SGC = prsl(ipt,ll) * tem @@ -432,11 +429,13 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & ! IF (SGC <= 0.700) kblmx = L ! Commented on 20101015 IF (SGC <= 0.600) kblmx = L ! ! IF (SGC <= 0.650) kblmx = L ! Commented on 20060202 + IF (SGC <= 0.980) kblmn = L ! ENDDO krmin = max(krmin,2) -! if (lprnt .and. ipt == ipr) print *,' krmin=',krmin,' krmax=', -! &krmax,' kfmax=',kfmax,' lmhij=',lmhij,' tem=',tem +! if (kdt == 1 .and. ipt == 1) write(0,*)' kblmn=',kblmn,kblmx +! if (lprnt .and. ipt == ipr) write(0,*)' krmin=',krmin,' krmax=', +! &krmax,' kfmax=',kfmax,' tem=',tem ! if (fix_ncld_hr) then !!! NCRND = min(nrcmax, (KRMAX-KRMIN+1)) * (DTF/1200) + 0.50001 @@ -448,16 +447,15 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & facdt = delt_c / dt else NCRND = min(nrcmax, (KRMAX-KRMIN+1)) - facdt = 1.0 / 3600.0 + facdt = one / 3600.0 endif NCRND = min(nrcm,max(NCRND, 1)) ! - KCR = MIN(LMHIJ,KRMAX) - KTEM = MIN(LMHIJ,KFMAX) + KCR = MIN(K,KRMAX) + KTEM = MIN(K,KFMAX) KFX = KTEM - KCR -! if(lprnt)print*,' enter RASCNV k=',k,' ktem=',ktem,' LMHIJ=' -! &, LMHIJ +! if(lprnt)write(0,*)' enter RASCNV k=',k,' ktem=',ktem ! &, ' krmax=',krmax,' kfmax=',kfmax ! &, ' kcr=',kcr, ' cdrag=',cdrag(ipr) @@ -483,101 +481,142 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & ! ! ia = 1 ! -! print *,' in rascnv: k=',k,'lat=',lat,' lprnt=',lprnt +! write(0,*)' in rascnv: k=',k,'lat=',lat,' lprnt=',lprnt ! if (lprnt) then ! if (me == 0) then -! print *,' tin',(tin(ia,l),l=k,1,-1) -! print *,' qin',(qin(ia,l),l=k,1,-1) +! write(0,*)' tin',(tin(ia,l),l=k,1,-1) +! write(0,*)' qin',(qin(ia,l),l=k,1,-1) ! endif ! ! lprint = lprnt .and. ipt == ipr -! lprint = lprnt + do l=1,k - ll = l - if (flipv) ll = kp1 -l ! Input variables are bottom to top! - CLW(l) = 0.0 ! Assumes initial value of Cloud water - CLI(l) = 0.0 ! Assumes initial value of Cloud ice + CLW(l) = zero + CLI(l) = zero ! to be zero i.e. no environmental condensate!!! - QII(l) = 0.0 - QLI(l) = 0.0 + QII(l) = zero + QLI(l) = zero ! Initialize heating, drying, cloudiness etc. - tcu(l) = 0.0 - qcu(l) = 0.0 - pcu(l) = 0.0 - flx(l) = 0.0 - flxd(l) = 0.0 + tcu(l) = zero + qcu(l) = zero + pcu(l) = zero + flx(l) = zero + flxd(l) = zero do n=1,ntrc - rcu(l,n) = 0.0 + rcu(l,n) = zero enddo -! Transfer input prognostic data into local variable - toi(l) = tin(ipt,ll) - qoi(l) = qin(ipt,ll) -! - if (ntrc > trac) then ! CUMFRC is true - uvi(l,trac+1) = uin(ipt,ll) - uvi(l,trac+2) = vin(ipt,ll) - endif -! - if (trac > 0) then ! tracers such as O3, dust etc - do n=1,trac - uvi(l,n) = ccin(ipt,ll,n+2) - if (abs(uvi(l,n)) < 1.0e-20) uvi(l,n) = 0.0 - enddo - endif -! enddo - flx(k+1) = 0.0 - flxd(k+1) = 0.0 + flx(kp1) = zero + flxd(kp1) = zero + rain = zero ! - if (ccin(ipt,1,2) <= -999.0) then ! input ice/water are together + if (flipv) then ! Input variables are bottom to top! do l=1,k - ll = l - if (flipv) ll = kp1 -l ! Input variables are bottom to top! + ll = kp1 - l + ! Transfer input prognostic data into local variable + toi(l) = tin(ipt,ll) + qoi(l) = qin(ipt,ll) + + PRSM(L) = prsl(ipt,ll) * facmb ! facmb is for conversion to MB + PSJM(L) = prslk(ipt,ll) + phi_l(L) = phil(ipt,ll) + rhc_l(L) = rhc(ipt,ll) +! + if (ntrc > trac) then ! CUMFRC is true + uvi(l,trac+1) = uin(ipt,ll) + uvi(l,trac+2) = vin(ipt,ll) + endif +! + if (trac > 0) then ! tracers such as O3, dust etc + do n=1,trac + uvi(l,n) = ccin(ipt,ll,n+2) + if (abs(uvi(l,n)) < 1.0e-20) uvi(l,n) = zero + enddo + endif + enddo + do l=1,kp1 + ll = kp1 + 1 - l ! Input variables are bottom to top! + PRS(LL) = prsi(ipt,L) * facmb ! facmb is for conversion to MB + PSJ(LL) = prsik(ipt,L) + phi_h(LL) = phii(ipt,L) + enddo +! + if (ccin(ipt,1,2) <= -999.0) then ! input ice/water are together + do l=1,k + ll = kp1 -l tem = ccin(ipt,ll,1) & & * MAX(ZERO, MIN(ONE, (TCR-toi(L))*TCRF)) ccin(ipt,ll,2) = ccin(ipt,ll,1) - tem ccin(ipt,ll,1) = tem - enddo - endif - if (advcld) then + enddo + endif + if (advcld) then + do l=1,k + ll = kp1 -l ! Input variables are bottom to top! + QII(L) = ccin(ipt,ll,1) + QLI(L) = ccin(ipt,ll,2) + enddo + endif + KBL = MAX(MIN(k, kp1-KPBL(ipt)), k/2) +! + else ! Input variables are top to bottom! + do l=1,k - ll = l - if (flipv) ll = kp1 -l ! Input variables are bottom to top! - QII(L) = ccin(ipt,ll,1) - QLI(L) = ccin(ipt,ll,2) + ! Transfer input prognostic data into local variable + toi(l) = tin(ipt,l) + qoi(l) = qin(ipt,l) + + PRSM(L) = prsl(ipt, L) * facmb ! facmb is for conversion to MB + PSJM(L) = prslk(ipt,L) + phi_l(L) = phil(ipt,L) + rhc_l(L) = rhc(ipt,L) +! + if (ntrc > trac) then ! CUMFRC is true + uvi(l,trac+1) = uin(ipt,l) + uvi(l,trac+2) = vin(ipt,l) + endif +! + if (trac > 0) then ! tracers such as O3, dust etc + do n=1,trac + uvi(l,n) = ccin(ipt,l,n+2) + if (abs(uvi(l,n)) < 1.0e-20) uvi(l,n) = zero + enddo + endif enddo - endif + DO L=1,kp1 + PRS(L) = prsi(ipt,L) * facmb ! facmb is for conversion to MB + PSJ(L) = prsik(ipt,L) + phi_h(L) = phii(ipt,L) + ENDDO ! - KBL = KPBL(ipt) - if (flipv) KBL = MAX(MIN(k, kp1-KPBL(ipt)), k/2) - rain = 0.0 + if (ccin(ipt,1,2) <= -999.0) then ! input ice/water are together + do l=1,k + tem = ccin(ipt,l,1) & + & * MAX(ZERO, MIN(ONE, (TCR-toi(L))*TCRF)) + ccin(ipt,l,2) = ccin(ipt,l,1) - tem + ccin(ipt,l,1) = tem + enddo + endif + if (advcld) then + do l=1,k + QII(L) = ccin(ipt,l,1) + QLI(L) = ccin(ipt,l,2) + enddo + endif ! - DO L=1,kp1 - ll = l - if (flipv) ll = kp1 + 1 - l ! Input variables are bottom to top! - PRS(LL) = prsi(ipt, L) * facmb ! facmb is for conversion to MB - PSJ(LL) = prsik(ipt,L) - phi_h(LL) = phii(ipt,L) - ENDDO + KBL = KPBL(ipt) ! - DO L=1,k - ll = l - if (flipv) ll = kp1 - l ! Input variables are bottom to top! - PRSM(LL) = prsl(ipt, L) * facmb ! facmb is for conversion to MB - PSJM(LL) = prslk(ipt,L) - phi_l(LL) = phil(ipt,L) - rhc_l(LL) = rhc(ipt,L) - ENDDO + endif ! end of if (flipv) then ! -! if (lprnt .and. ipt == ipr) print *,' phi_h=',phi_h(:) -! if(lprint) print *,' PRS=',PRS -! if(lprint) print *,' PRSM=',PRSM +! if (lprnt .and. ipt == ipr) write(0,*)' phi_h=',phi_h(:) +! if(lprint) write(0,*)' PRS=',PRS +! if(lprint) write(0,*)' PRSM=',PRSM ! if (lprint) then -! print *,' qns=',qns(ia),' qoi=',qn0(ia,k),'qin=',qin(ia,1) +! write(0,*)' qns=',qns(ia),' qoi=',qn0(ia,k),'qin=',qin(ia,1) ! if (me == 0) then -! print *,' toi',(tn0(ia,l),l=1,k) -! print *,' qoi',(qn0(ia,l),l=1,k),' kbl=',kbl +! write(0,*)' toi',(tn0(ia,l),l=1,k) +! write(0,*)' qoi',(qn0(ia,l),l=1,k),' kbl=',kbl ! endif ! ! @@ -588,9 +627,9 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & ! print *,' ipt=',ipt if (advups) then ! For first order upstream for updraft - alfint(:,:) = 1.0 + alfint(:,:) = one elseif (advtvd) then ! TVD flux limiter scheme for updraft - alfint(:,:) = 1.0 + alfint(:,:) = one l = krmin lm1 = l - 1 dtvd(1,1) = cp*(toi(l)-toi(lm1)) + phi_l(l)-phi_l(lm1) & @@ -601,88 +640,88 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & do l=krmin+1,k lm1 = l - 1 -! print *,' toi=',toi(l),toi(lm1),' phi_l=',phi_l(l),phi_l(lm1) +! write(0,*)' toi=',toi(l),toi(lm1),' phi_l=',phi_l(l),phi_l(lm1) ! &,' qoi=',qoi(l),qoi(lm1),' cp=',cp,' alhl=',alhl dtvd(2,1) = cp*(toi(l)-toi(lm1)) + phi_l(l)-phi_l(lm1) & & + alhl*(qoi(l)-qoi(lm1)) -! print *,' l=',l,' dtvd=',dtvd(:,1) +! write(0,*)' l=',l,' dtvd=',dtvd(:,1) if (abs(dtvd(2,1)) > 1.0e-10) then tem1 = dtvd(1,1) / dtvd(2,1) tem2 = abs(tem1) - alfint(l,1) = 1.0 - 0.5*(tem1 + tem2)/(1.0 + tem2) ! for h + alfint(l,1) = one - half*(tem1 + tem2)/(one + tem2) ! for h endif -! print *,' alfint=',alfint(l,1),' l=',l,' ipt=',ipt +! write(0,*)' alfint=',alfint(l,1),' l=',l,' ipt=',ipt - dtvd(1,1) = dtvd(2,1) + dtvd(1,1) = dtvd(2,1) ! - dtvd(2,2) = qoi(l) - qoi(lm1) + dtvd(2,2) = qoi(l) - qoi(lm1) -! print *,' l=',l,' dtvd2=',dtvd(:,2) +! write(0,*)' l=',l,' dtvd2=',dtvd(:,2) if (abs(dtvd(2,2)) > 1.0e-10) then tem1 = dtvd(1,2) / dtvd(2,2) tem2 = abs(tem1) - alfint(l,2) = 1.0 - 0.5*(tem1 + tem2)/(1.0 + tem2) ! for q + alfint(l,2) = one - half*(tem1 + tem2)/(one + tem2) ! for q endif - dtvd(1,2) = dtvd(2,2) + dtvd(1,2) = dtvd(2,2) ! - dtvd(2,3) = qli(l) - qli(lm1) + dtvd(2,3) = qli(l) - qli(lm1) -! print *,' l=',l,' dtvd3=',dtvd(:,3) +! write(0,*)' l=',l,' dtvd3=',dtvd(:,3) if (abs(dtvd(2,3)) > 1.0e-10) then tem1 = dtvd(1,3) / dtvd(2,3) tem2 = abs(tem1) - alfint(l,3) = 1.0 - 0.5*(tem1 + tem2)/(1.0 + tem2) ! for ql + alfint(l,3) = one - half*(tem1 + tem2)/(one + tem2) ! for ql endif - dtvd(1,3) = dtvd(2,3) + dtvd(1,3) = dtvd(2,3) ! - dtvd(2,4) = qii(l) - qii(lm1) + dtvd(2,4) = qii(l) - qii(lm1) -! print *,' l=',l,' dtvd4=',dtvd(:,4) +! write(0,*)' l=',l,' dtvd4=',dtvd(:,4) if (abs(dtvd(2,4)) > 1.0e-10) then tem1 = dtvd(1,4) / dtvd(2,4) tem2 = abs(tem1) - alfint(l,4) = 1.0 - 0.5*(tem1 + tem2)/(1.0 + tem2) ! for qi + alfint(l,4) = one - half*(tem1 + tem2)/(one + tem2) ! for qi endif - dtvd(1,4) = dtvd(2,4) + dtvd(1,4) = dtvd(2,4) enddo ! if (ntrc > 0) then do n=1,ntrc l = krmin - dtvd(1,1) = uvi(l,n) - uvi(l-1,n) + dtvd(1,1) = uvi(l,n) - uvi(l-1,n) do l=krmin+1,k - dtvd(2,1) = uvi(l,n) - uvi(l-1,n) + dtvd(2,1) = uvi(l,n) - uvi(l-1,n) -! print *,' l=',l,' dtvdn=',dtvd(:,1),' n=',n,' l=',l +! write(0,*)' l=',l,' dtvdn=',dtvd(:,1),' n=',n,' l=',l if (abs(dtvd(2,1)) > 1.0e-10) then tem1 = dtvd(1,1) / dtvd(2,1) tem2 = abs(tem1) - alfint(l,n+4) = 1.0 - 0.5*(tem1 + tem2)/(1.0 + tem2) ! for tracers + alfint(l,n+4) = one - half*(tem1 + tem2)/(one + tem2) ! for tracers endif - dtvd(1,1) = dtvd(2,1) + dtvd(1,1) = dtvd(2,1) enddo enddo endif else - alfint(:,:) = 0.5 ! For second order scheme + alfint(:,:) = half ! For second order scheme endif - alfind(:) = 0.5 + alfind(:) = half ! -! print *,' after alfint for ipt=',ipt +! write(0,*)' after alfint for ipt=',ipt ! Resolution dependent press grad correction momentum mixing if (CUMFRC) then do l=krmin,k - tem = 1.0 - max(pgfbot, min(pgftop, pgftop+pgfgrad*prsm(l))) + tem = one - max(pgfbot, min(pgftop, pgftop+pgfgrad*prsm(l))) trcfac(l,trac+1) = tem trcfac(l,trac+2) = tem enddo @@ -691,25 +730,29 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & ! lprint = lprnt .and. ipt == ipr ! if (lprint) then -! print *,' trcfac=',trcfac(krmin:k,1+trac) -! print *,' alfint=',alfint(krmin:k,1) -! print *,' alfinq=',alfint(krmin:k,2) -! print *,' alfini=',alfint(krmin:k,4) -! print *,' alfinu=',alfint(krmin:k,5) +! write(0,*)' trcfac=',trcfac(krmin:k,1+trac) +! write(0,*)' alfint=',alfint(krmin:k,1) +! write(0,*)' alfinq=',alfint(krmin:k,2) +! write(0,*)' alfini=',alfint(krmin:k,4) +! write(0,*)' alfinu=',alfint(krmin:k,5) ! endif ! - if (calkbl) kbl = k - DO NC=1,NCMX -! - IB = IC(NC) - if (ib > kbl) cycle +! if (calkbl) kbl = k -! lprint = lprnt .and. ipt == ipr -! lprint = lprnt .and. ipt == ipr .and. ib == 41 + if (calkbl) then + kbl = kblmn + else + kbl = min(kbl, kblmn) + endif ! - DNDRFT = DPD > 0.0 + DO NC=1,NCMX ! multi cloud loop ! -! if (lprint) print *,' calling cloud type ib=',ib,' kbl=',kbl + IB = IC(NC) ! cloud top level index + if (ib > kbl-1) cycle + +! lprint = lprnt .and. ipt == ipr .and. ib == 57 +! +! if (lprint) write(0,*)' calling cloud type ib=',ib,' kbl=',kbl ! *, ' kpbl=',kpbl,' alfint=',alfint,' frac=',frac ! *, ' ntrc=',ntrc,' ipt=',ipt ! @@ -778,81 +821,126 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & ! ! if (lprint) then ! ia = ipt -! print *,' toi=',(toi(ia,l),l=1,K) -! print *,' qoi=',(qoi(ia,l),l=1,K),' kbl=',kbl -! print *,' toi=',(toi(l),l=1,K) -! print *,' qoi=',(qoi(l),l=1,K),' kbl=',kbl -! print *,' prs=',(prs(l),l=1,K) +! write(0,*)' toi=',(toi(ia,l),l=1,K) +! write(0,*)' qoi=',(qoi(ia,l),l=1,K),' kbl=',kbl +! write(0,*)' toi=',(toi(l),l=1,K) +! write(0,*)' qoi=',(qoi(l),l=1,K),' kbl=',kbl +! write(0,*)' prs=',(prs(l),l=1,K) ! endif ! - WFNC = 0.0 - do L=IB,K+1 - FLX(L) = 0.0 - FLXD(L)= 0.0 + WFNC = zero + do L=IB,KP1 + FLX(L) = zero + FLXD(L) = zero enddo ! ! if(lprint)then -! print *,' CALLING CLOUD TYPE IB= ', IB,' DT=',DT,' K=',K +! write(0,*) ' CALLING CLOUD TYPE IB= ', IB,' DT=',DT,' K=',K ! &, 'ipt=',ipt -! print *,' TOI=',(TOI(L),L=IB,K) -! print *,' QOI=',(QOI(L),L=IB,K) -! print *,' qliin=',qli -! print *,' qiiin=',qii +! write(0,*) ' TOI=',(TOI(L),L=IB,K) +! write(0,*) ' QOI=',(QOI(L),L=IB,K) +! write(0,*) ' qliin=',qli +! write(0,*) ' qiiin=',qii ! endif ! - TLA = -10.0 + TLA = -10.0 ! qiid = qii(ib) ! cloud top level ice before convection qlid = qli(ib) ! cloud top level water before convection ! - CALL CLOUD(lmhij, IB, ntrc, kblmx & - &, FRAC, MAX_NEG_BOUY, vsmooth & - &, REVAP, WRKFUN, CALKBL, CRTFUN, DNDRFT, lprint & +! if(lprint) write(0,*)' uvitke=',uvi(ib:k,ntk-2), ' ib=',ib +! &,' trcmin=',trcmin(ntk-2) +! if (lprnt) then +! qoi_l(ib:k) = qoi(ib:k) +! qli_l(ib:k) = qli(ib:k) +! qii_l(ib:k) = qii(ib:k) +! endif +! rainp = rain + + CALL CLOUD(K, KP1, IB, ntrc, kblmx, kblmn & + &, FRAC, MAX_NEG_BOUY, vsmooth, do_aw & + &, REVAP, WRKFUN, CALKBL, CRTFUN, lprint & &, DT, KDT, TLA, DPD & &, ALFINT, rhfacl, rhfacs, garea(ipt) & &, ccwf, CDRAG(ipt), trcfac & &, alfind, rhc_l, phi_l, phi_h, PRS, PRSM,sgcs(1,ipt) & &, TOI, QOI, UVI, QLI, QII, KBL, DDVEL(ipt) & &, TCU, QCU, RCU, PCU, FLX, FLXD, RAIN, WFNC, fscav_ & - & ) +! &, trcmin) + &, trcmin, ntk-2, c0, qw0, c0i, qi0, dlq_fac) ! &, ctei) +! if(lprint) write(0,*)' uvitkea=',uvi(ib:k,ntk-2),' ib=',ib ! if (lprint) then -! print *,' rain=',rain,' ipt=',ipt -! print *,' after calling CLOUD TYPE IB= ', IB & +! write(0,*) ' rain=',rain,' ipt=',ipt +! write(0,*) ' after calling CLOUD TYPE IB= ', IB & ! &,' rain=',rain,' prskd=',prs(ib),' qli=',qli(ib),' qii=',qii(ib) -! print *,' phi_h=',phi_h(K-5:K+1) -! print *,' TOI=',(TOI(L),L=1,K),' me=',me,' ib=',ib -! print *,' QOI=',(QOI(L),L=1,K) -! print *,' qliou=',qli -! print *,' qiiou=',qii +! &,' rainp=',rainp +! write(0,*) ' phi_h=',phi_h(K-5:KP1) +! write(0,*) ' TOI=',(TOI(L),L=1,K),' me=',me,' ib=',ib +! write(0,*) ' QOI=',(QOI(L),L=1,K) +! write(0,*) ' qliou=',qli +! write(0,*) ' qiiou=',qii +! sumq = 0.0 +! do l=ib,k +! sumq = sumq+(qoi(l)+qli(l)+qii(l)-qoi_l(l)-qli_l(l)-qii_l(l)) +! & * (prs(l+1)-prs(l)) * (100.0/grav) +! enddo +! write(0,*)' sumq=',sumq,' rainib=',rain-rainp,' ib=',ib + ! endif ! - do L=IB,K - ll = l - if (flipv) ll = kp1 -l ! Input variables are bottom to top! - ud_mf(ipt,ll) = ud_mf(ipt,ll) + flx(l+1) - dd_mf(ipt,ll) = dd_mf(ipt,ll) + flxd(l+1) - enddo - ll = ib - if (flipv) ll = kp1 - ib - det_mf(ipt,ll) = det_mf(ipt,ll) + flx(ib) + if (flipv) then + do L=IB,K + ll = kp1 -l ! Input variables are bottom to top! + ud_mf(ipt,ll) = ud_mf(ipt,ll) + flx(l+1) + dd_mf(ipt,ll) = dd_mf(ipt,ll) + flxd(l+1) + enddo + ll = kp1 - ib + det_mf(ipt,ll) = det_mf(ipt,ll) + flx(ib) + + if (mp_phys == 10) then ! Anning Cheng for microphysics 11/14/2015 -! Anning Cheng for microphysics 11/14/2015 - if (mp_phys == 10) then ! if (lprint) write(0,*)' ib=',ib,' flx=',flx(ib),' ll=',ll ! &,' ud_mf=',ud_mf(ipt,:) - CNV_MFD(ipt,ll) = CNV_MFD(ipt,ll) + flx(ib)/dt + + CNV_MFD(ipt,ll) = CNV_MFD(ipt,ll) + flx(ib)/dt + ! if (lprint) write(0,*)' ib=',ib,' CNV_MFD=',CNV_MFD(ipt,ll) ! &,' ll=',ll,' kp1=',kp1 -! CNV_DQLDT(ipt,ll) = CNV_DQLDT(ipt,ll) -! & + max(0.,(QLI(ib)+QII(ib)-qiid-qlid))/dt - CNV_DQLDT(ipt,ll) = CNV_DQLDT(ipt,ll) + flx(ib)* - & max(0.,(QLI(ib)+QII(ib)-qiid-qlid))/dt + +! CNV_DQLDT(ipt,ll) = CNV_DQLDT(ipt,ll) +! & + max(0.,(QLI(ib)+QII(ib)-qiid-qlid))/dt + CNV_DQLDT(ipt,ll) = CNV_DQLDT(ipt,ll) + flx(ib)* + & max(0.,(QLI(ib)+QII(ib)-qiid-qlid))/dt ! & max(0.,(QLI(ib)+QII(ib)))/dt/3. - if(flx(ib)<0) write(*,*)"AAA666", flx(ib),QLI(ib),QII(ib) + if(flx(ib)<0) write(*,*)"AAA666", flx(ib),QLI(ib),QII(ib) & ,ipt,ll - end if + endif + + else + + do L=IB,K + ud_mf(ipt,l) = ud_mf(ipt,l) + flx(l+1) + dd_mf(ipt,l) = dd_mf(ipt,l) + flxd(l+1) + enddo + det_mf(ipt,ib) = det_mf(ipt,ib) + flx(ib) + + if (mp_phys == 10) then ! Anning Cheng for microphysics 11/14/2015 +! if (lprint) write(0,*)' ib=',ib,' flx=',flx(ib),' ib=',ib +! &,' ud_mf=',ud_mf(ipt,:) + CNV_MFD(ipt,ib) = CNV_MFD(ipt,ib) + flx(ib)/dt +! if (lprint) write(0,*)' ib=',ib,' CNV_MFD=',CNV_MFD(ipt,ib) +! &,' ib=',ib,' kp1=',kp1 +! CNV_DQLDT(ipt,ib) = CNV_DQLDT(ipt,ib) +! & + max(0.,(QLI(ib)+QII(ib)-qiid-qlid))/dt + CNV_DQLDT(ipt,ib) = CNV_DQLDT(ipt,ib) + flx(ib)* + & max(0.,(QLI(ib)+QII(ib)-qiid-qlid))/dt +! & max(0.,(QLI(ib)+QII(ib)))/dt/3. + if(flx(ib)<0) write(*,*)"AAA666", flx(ib),QLI(ib),QII(ib) + & ,ipt,ib + endif + endif ! ! ! Warining!!!! @@ -862,10 +950,10 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & ! if (.not. advcld) then do l=1,K - clw(l ) = clw(l) + QLI(L) - cli(l ) = cli(l) + QII(L) - QLI(L) = 0.0 - QII(L) = 0.0 + clw(l) = clw(l) + QLI(L) + cli(l) = cli(l) + QII(L) + QLI(L) = zero + QII(L) = zero enddo endif ! @@ -874,111 +962,169 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & RAINC(ipt) = rain * 0.001 ! Output rain is in meters ! if (lprint) then -! print*,' convective precip=',rain*86400/dt,' mm/day' +! write(0,*) ' convective precip=',rain*86400/dt,' mm/day' ! 1, ' ipt=',ipt -! print *,' toi',(tn0(imax,l),l=1,k) -! print *,' qoi',(qn0(imax,l),l=1,k) +! write(0,*) ' toi',(tn0(imax,l),l=1,k) +! write(0,*) ' qoi',(qn0(imax,l),l=1,k) ! endif ! - do l=1,k - ll = l - if (flipv) ll = kp1 - l - tin(ipt,ll) = toi(l) ! Temperature - qin(ipt,ll) = qoi(l) ! Specific humidity - uin(ipt,ll) = uvi(l,trac+1) ! U momentum - vin(ipt,ll) = uvi(l,trac+2) ! V momentum -!! for 2M microphysics, always output these variables - if (mp_phys == 10) then - qli(l) = max(qli(l),0.) - qii(l) = max(qii(l),0.) - if (advcld) then - QLCN(ipt,ll) = max(qli(l)-ccin(ipt,ll,2), 0.0) - QICN(ipt,ll) = max(qii(l)-ccin(ipt,ll,1), 0.0) - CNV_FICE(ipt,ll) = QICN(ipt,ll) - & / max(1.e-10,QLCN(ipt,ll)+QICN(ipt,ll)) - else - QLCN(ipt,ll) = qli(l) - QICN(ipt,ll) = qii(l) - CNV_FICE(ipt,ll) = qii(l)/max(1.e-10,qii(l)+qli(l)) - endif -! CNV_PRC3(ipt,ll) = PCU(l)/dt - CNV_PRC3(ipt,ll) = 0.0 - if(PCU(l)<0.) write(*,*)"AAA777",PCU(l),ipt,ll - cf_upi(ipt,ll) = max(0.0,min(0.02*log(1.0+ - & 500*ud_mf(ipt,ll)/dt),0.25)) -! & 500*ud_mf(ipt,ll)/dt),0.60)) - CLCN(ipt,ll) = cf_upi(ipt,ll) !downdraft is below updraft - w_upi(ipt,ll) = ud_mf(ipt,ll)*toi(l)*rgas / - & (dt*max(cf_upi(ipt,ll),1.e-12)*prsl(ipt,ll)) - endif - - if (trac > 0) then - do n=1,trac - ccin(ipt,ll,n+2) = uvi(l,n) ! Tracers - enddo - endif - enddo - if (advcld) then - do l=1,k - ll = l - if (flipv) ll = kp1 - l - ccin(ipt,ll,1) = qii(l) ! Cloud ice - ccin(ipt,ll,2) = qli(l) ! Cloud water - enddo - else - do l=1,k - ll = l - if (flipv) ll = kp1 - l - ccin(ipt,ll,1) = ccin(ipt,ll,1) + cli(l) - ccin(ipt,ll,2) = ccin(ipt,ll,2) + clw(l) - enddo - endif ! ktop(ipt) = kp1 kbot(ipt) = 0 kcnv(ipt) = 0 - do l=lmhij-1,1,-1 - if (sgcs(l,ipt) < 0.93 .and. tcu(l) .ne. 0.0) then + + do l=k,1,-1 +! qli(l) = max(qli(l), zero) +! qii(l) = max(qii(l), zero) +! clw(i) = max(clw(i), zero) +! cli(i) = max(cli(i), zero) + + if (sgcs(l,ipt) < 0.93 .and. abs(tcu(l)) > one_m10) then ! if (sgcs(l,ipt) < 0.90 .and. tcu(l) .ne. 0.0) then ! if (sgcs(l,ipt) < 0.85 .and. tcu(l) .ne. 0.0) then -! if (sgcs(l,ipt) < 0.70 .and. tcu(l) .ne. 0.0) then -! if (sgcs(l,ipt) < 0.60 .and. tcu(l) .ne. 0.0) then -! if (tcu(l) .ne. 0.0) then kcnv(ipt) = 1 endif ! New test for convective clouds ! added in 08/21/96 - if (clw(l)+cli(l) > 0.0 .OR. & + if (clw(l)+cli(l) > zero .OR. & & qli(l)+qii(l) > clwmin) ktop(ipt) = l enddo do l=1,km1 - if (clw(l)+cli(l) > 0.0 .OR. & + if (clw(l)+cli(l) > zero .OR. & & qli(l)+qii(l) > clwmin) kbot(ipt) = l enddo +! if (flipv) then + do l=1,k + ll = kp1 - l + tin(ipt,ll) = toi(l) ! Temperature + qin(ipt,ll) = qoi(l) ! Specific humidity + uin(ipt,ll) = uvi(l,trac+1) ! U momentum + vin(ipt,ll) = uvi(l,trac+2) ! V momentum + +!! for 2M microphysics, always output these variables + if (mp_phys == 10) then + if (advcld) then + QLCN(ipt,ll) = max(qli(l)-ccin(ipt,ll,2), zero) + QICN(ipt,ll) = max(qii(l)-ccin(ipt,ll,1), zero) + CNV_FICE(ipt,ll) = QICN(ipt,ll) + & / max(1.e-10,QLCN(ipt,ll)+QICN(ipt,ll)) + else + QLCN(ipt,ll) = qli(l) + QICN(ipt,ll) = qii(l) + CNV_FICE(ipt,ll) = qii(l)/max(1.e-10,qii(l)+qli(l)) + endif +!! CNV_PRC3(ipt,ll) = PCU(l)/dt +! CNV_PRC3(ipt,ll) = zero +! if(PCU(l) < zero) write(*,*)"AAA777",PCU(l),ipt,ll + cf_upi(ipt,ll) = max(zero,min(0.02*log(one+ + & 500*ud_mf(ipt,ll)/dt), cfmax)) +! & 500*ud_mf(ipt,ll)/dt), 0.60)) +! if (lprint) write(0,*)' ll=',ll,' cf_upi=',cf_upi(ipt,ll) +! &,' ud_mf=',ud_mf(ipt,ll),' dt=',dt,' cfmax=',cfmax + CLCN(ipt,ll) = cf_upi(ipt,ll) !downdraft is below updraft + w_upi(ipt,ll) = ud_mf(ipt,ll)*toi(l)*rgas / + & (dt*max(cf_upi(ipt,ll),1.e-12)*prsl(ipt,ll)) + endif + + if (trac > 0) then + do n=1,trac + ccin(ipt,ll,n+2) = uvi(l,n) ! Tracers + enddo + endif + enddo + if (advcld) then + do l=1,k + ll = kp1 - l + ccin(ipt,ll,1) = qii(l) ! Cloud ice + ccin(ipt,ll,2) = qli(l) ! Cloud water + enddo + else + do l=1,k + ll = kp1 - l + ccin(ipt,ll,1) = ccin(ipt,ll,1) + cli(l) + ccin(ipt,ll,2) = ccin(ipt,ll,2) + clw(l) + enddo + endif +! ktop(ipt) = kp1 - ktop(ipt) kbot(ipt) = kp1 - kbot(ipt) - endif ! -! if (lprint) then -! print *,' tin',(tin(ia,l),l=k,1,-1) -! print *,' qin',(qin(ia,l),l=k,1,-1) -! endif +! if (lprint) then +! write(0,*) ' tin',(tin(ia,l),l=k,1,-1) +! write(0,*) ' qin',(qin(ia,l),l=k,1,-1) +! endif +! + else + + do l=1,k + tin(ipt,l) = toi(l) ! Temperature + qin(ipt,l) = qoi(l) ! Specific humidity + uin(ipt,l) = uvi(l,trac+1) ! U momentum + vin(ipt,l) = uvi(l,trac+2) ! V momentum + +!! for 2M microphysics, always output these variables + if (mp_phys == 10) then + if (advcld) then + QLCN(ipt,l) = max(qli(l)-ccin(ipt,l,2), zero) + QICN(ipt,l) = max(qii(l)-ccin(ipt,l,1), zero) + CNV_FICE(ipt,l) = QICN(ipt,l) + & / max(1.e-10,QLCN(ipt,l)+QICN(ipt,l)) + else + QLCN(ipt,l) = qli(l) + QICN(ipt,l) = qii(l) + CNV_FICE(ipt,l) = qii(l)/max(1.e-10,qii(l)+qli(l)) + endif +!! CNV_PRC3(ipt,l) = PCU(l)/dt +! CNV_PRC3(ipt,l) = zero +! if(PCU(l) < zero) write(*,*)"AAA777",PCU(l),ipt,l + cf_upi(ipt,l) = max(zero,min(0.02*log(one+ + & 500*ud_mf(ipt,l)/dt), cfmax)) +! & 500*ud_mf(ipt,l)/dt), 0.60)) + CLCN(ipt,l) = cf_upi(ipt,l) !downdraft is below updraft + w_upi(ipt,l) = ud_mf(ipt,l)*toi(l)*rgas / + & (dt*max(cf_upi(ipt,l),1.e-12)*prsl(ipt,l)) + endif + + if (trac > 0) then + do n=1,trac + ccin(ipt,l,n+2) = uvi(l,n) ! Tracers + enddo + endif + enddo + if (advcld) then + do l=1,k + ccin(ipt,l,1) = qii(l) ! Cloud ice + ccin(ipt,l,2) = qli(l) ! Cloud water + enddo + else + do l=1,k + ccin(ipt,l,1) = ccin(ipt,l,1) + cli(l) + ccin(ipt,l,2) = ccin(ipt,l,2) + clw(l) + enddo + endif +! +! if (lprint) then +! write(0,*) ' tin',(tin(ia,l),l=k,1,-1) +! write(0,*) ' qin',(qin(ia,l),l=k,1,-1) +! endif +! + endif ! ! Velocity scale from the downdraft! ! - DDVEL(ipt) = DDVEL(ipt) * DDFAC * GRAV / (prs(K+1)-prs(k)) + DDVEL(ipt) = DDVEL(ipt) * DDFAC * GRAV / (prs(KP1)-prs(K)) ! ENDDO ! End of the IPT Loop! - deallocate (alfint,uvi,trcfac,rcu) + deallocate (alfint, uvi, trcfac, rcu) ! RETURN END SUBROUTINE CRTWRK(PL, CCWF, ACR) - USE MACHINE , ONLY : kind_phys + USE MACHINE , ONLY : kind_phys use module_ras , only : ac, ad Implicit none ! @@ -992,15 +1138,15 @@ SUBROUTINE CRTWRK(PL, CCWF, ACR) RETURN END SUBROUTINE CLOUD( & - & K, KD, NTRC, KBLMX & - &, FRACBL, MAX_NEG_BOUY, vsmooth & - &, REVAP, WRKFUN, CALKBL, CRTFUN, DNDRFT, lprnt & + & K, KP1, KD, NTRC, KBLMX, kblmn & + &, FRACBL, MAX_NEG_BOUY, vsmooth, do_aw & + &, REVAP, WRKFUN, CALKBL, CRTFUN, lprnt & &, DT, KDT, TLA, DPD & &, ALFINT, RHFACL, RHFACS, garea, ccwf, cd, trcfac & &, alfind, rhc_ls, phil, phih, prs, prsm, sgcs & &, TOI, QOI, ROI, QLI, QII, KPBL, DSFC & &, TCU, QCU, RCU, PCU, FLX, FLXD, CUP, WFNC,fscav_ & - & ) + &, trcmin, ntk, c0, qw0, c0i, qi0, dlq_fac) ! &, ctei) ! @@ -1012,13 +1158,17 @@ SUBROUTINE CLOUD( & !******************** VERSION 2.0 (modified) ************************* !************* Shrinivas.Moorthi@noaa.gov (301) 683-3718 ***** ******** !*********************************************************************** -!*Reference: +!*References: !----------- ! NOAA Technical Report NWS/NCEP 99-01: ! Documentation of Version 2 of Relaxed-Arakawa-Schubert ! Cumulus Parameterization with Convective Downdrafts, June 1999. ! by S. Moorthi and M. J. Suarez. ! +! Relaxed Arakawa-Schubert Cumulus Parameterization (Version 2) +! with Convective Downdrafts - Unpublished Manuscript (2002) +! by Shrinivas Moorthi and Max J. Suarez. +! !*********************************************************************** ! !===> UPDATES CLOUD TENDENCIES DUE TO A SINGLE CLOUD @@ -1032,25 +1182,27 @@ SUBROUTINE CLOUD( & !===> QLI(K) INOUT LIQUID WATER NON-DIMENSIONAL !===> QII(K) INOUT ICE NON-DIMENSIONAL -!===> PRS(K+1) INPUT PRESSURE @ EDGES MB +!===> PRS(KP1) INPUT PRESSURE @ EDGES MB !===> PRSM(K) INPUT PRESSURE @ LAYERS MB !===> SGCS(K) INPUT Local sigma -!===> PHIH(K+1) INPUT GEOPOTENTIAL @ EDGES IN MKS units +!===> PHIH(KP1) INPUT GEOPOTENTIAL @ EDGES IN MKS units !===> PHIL(K) INPUT GEOPOTENTIAL @ LAYERS IN MKS units -!===> PRJ(K+1) INPUT (P/P0)^KAPPA @ EDGES NON-DIMENSIONAL +!===> PRJ(KP1) INPUT (P/P0)^KAPPA @ EDGES NON-DIMENSIONAL !===> PRJM(K) INPUT (P/P0)^KAPPA @ LAYERS NON-DIMENSIONAL !===> K INPUT THE RISE & THE INDEX OF THE SUBCLOUD LAYER !===> KD INPUT DETRAINMENT LEVEL ( 1<= KD < K ) !===> NTRC INPUT NUMBER OF TRACERS. MAY BE ZERO. !===> kblmx INPUT highest level the pbl can take -!===> DNDRFT INPUT LOGICAL .TRUE. OR .FALSE. -!===> DPD INPUT Minumum Cloud Depth for DOWNDRFAT Computation hPa +!===> kblmn INPUT lowest level the pbl can take +!===> DPD INPUT Critical normalized pressure (i.e. sigma) at the cloud top +! No downdraft calculation if the cloud top pressure is higher +! than DPD*PRS(KP1) ! !===> TCU(K ) UPDATE TEMPERATURE TENDENCY DEG !===> QCU(K ) UPDATE WATER VAPOR TENDENCY (G/G) !===> RCU(K,NTRC)UPDATE TRACER TENDENCIES ND -!===> PCU(K-1) UPDATE PRECIP @ BASE OF LAYER KG/M^2 +!===> PCU(K) UPDATE PRECIP @ BASE OF LAYER KG/M^2 !===> FLX(K ) UPDATE MASS FLUX @ TOP OF LAYER KG/M^2 !===> CUP UPDATE PRECIPITATION AT THE SURFACE KG/M^2 ! @@ -1060,30 +1212,39 @@ SUBROUTINE CLOUD( & ! ! INPUT ARGUMENTS -! LOGICAL REVAP, DNDRFT, WRKFUN, CALKBL, CRTFUN, CALCUP, ctei - LOGICAL REVAP, DNDRFT, WRKFUN, CALKBL, CRTFUN, CALCUP - logical vsmooth, lprnt - INTEGER K, KD, NTRC, kblmx +! LOGICAL REVAP, WRKFUN, CALKBL, CRTFUN, CALCUP, ctei + LOGICAL REVAP, WRKFUN, CALKBL, CRTFUN, CALCUP + logical vsmooth, do_aw, lprnt + INTEGER K, KP1, KD, NTRC, kblmx, kblmn, ntk real(kind=kind_phys), dimension(K) :: TOI, QOI, PRSM, QLI, QII& &, PHIL, SGCS, rhc_ls & &, alfind - real(kind=kind_phys), dimension(K+1) :: PRS, PHIH + real(kind=kind_phys), dimension(KP1) :: PRS, PHIH real(kind=kind_phys), dimension(K,NTRC) :: ROI, trcfac - real(kind=kind_phys) :: CD, UFN, DSFC + real(kind=kind_phys), dimension(ntrc) :: trcmin + real(kind=kind_phys) :: CD, DSFC INTEGER :: KPBL, KBL, KB1, kdt real(kind=kind_phys) ALFINT(K,NTRC+4) - real(kind=kind_phys) FRACBL, MAX_NEG_BOUY, DPD, & - & RHFACL, RHFACS, garea, ccwf + real(kind=kind_phys) FRACBL, MAX_NEG_BOUY, DPD & + &, RHFACL, RHFACS, garea, ccwf & + &, c0, qw0, c0i, qi0, dlq_fac ! UPDATE ARGUMENTS real(kind=kind_phys), dimension(K) :: TCU, QCU, TCD, QCD, PCU - real(kind=kind_phys), dimension(K+1) :: FLX, FLXD + real(kind=kind_phys), dimension(KP1) :: FLX, FLXD real(kind=kind_phys), dimension(K,NTRC) :: RCU real(kind=kind_phys) :: CUP +! + real(kind=kind_phys), parameter :: ERRMIN=0.0001 & + &, ERRMI2=0.1*ERRMIN & +! &, rainmin=1.0e-9 & + &, rainmin=1.0e-8 & + &, oneopt9=1.0/0.09 & + &, oneopt4=1.0/0.04 ! TEMPORARY WORK SPACE @@ -1092,22 +1253,22 @@ SUBROUTINE CLOUD( & &, FCO, PRI, QIL, QLL, ZET, XI, RNS & &, Q0U, Q0D, vtf, CIL, CLL, ETAI, dlq & &, wrk1, wrk2, dhdp, qrb, qrt, evp & - &, ghd, gsd, etz, cldfr + &, ghd, gsd, etz, cldfr, sigf, rho - real(kind=kind_phys), dimension(KD:K+1) :: GAF, GMS, GAM, DLB & - &, DLT, ETA, PRL, BUY, ETD, HOD, QOD + real(kind=kind_phys), dimension(KD:KP1) :: GAF, GMS, GAM, DLB & + &, DLT, ETA, PRL, BUY, ETD, HOD, QOD, wvl real(kind=kind_phys), dimension(KD:K-1) :: etzi real(kind=kind_phys) fscav_(ntrc) - LOGICAL ep_wfn, cnvflg, LOWEST, SKPDD, DDFT, UPDRET + LOGICAL ep_wfn, cnvflg, LOWEST, DDFT, UPDRET real(kind=kind_phys) ALM, DET, HCC, CLP & &, HSU, HSD, QTL, QTV & &, AKM, WFN, HOS, QOS & &, AMB, TX1, TX2, TX3 & &, TX4, TX5, QIS, QLS & - &, HBL, QBL, RBL(NTRC) & + &, HBL, QBL, RBL(NTRC), wcbase & &, QLB, QIB, PRIS & &, WFNC, TX6, ACR & &, TX7, TX8, TX9, RHC & @@ -1127,57 +1288,55 @@ SUBROUTINE CLOUD( & &, FAC, RSUM1, RSUM2, RSUM3, dpneg, hcrit & &, ACTEVAP,AREARAT,DELTAQ,MASS,MASSINV,POTEVAP & &, TEQ,QSTEQ,DQDT,QEQ & - &, CLFRAC, DT, clf, clvfr, delzkm, fnoscav + &, CLFRAC, DT, clf, clvfr, delzkm, fnoscav, delp +! &, almin1, almin2 - real(kind=kind_phys), parameter :: ERRMIN=0.0001 & - &, ERRMI2=0.1*ERRMIN INTEGER I, L, N, KD1, II, idh, lcon & - &, KP1, IT, KM1, KTEM, KK, KK1, LM1, LL, LP1, kbls, kmxh + &, IT, KM1, KTEM, KK, KK1, LM1, LL, LP1, kbls, kmxh &, kblh, kblm, kblpmn, kmax, kmaxm1, kmaxp1, klcl, kmin, kmxb ! - -! real(kind=kind_phys), parameter :: rainmin=1.0e-9 - real(kind=kind_phys), parameter :: rainmin=1.0e-8 - real(kind=kind_phys), parameter :: oneopt9=1.0/0.09 - real(kind=kind_phys), parameter :: oneopt4=1.0/0.04 -! !*********************************************************************** ! +! almin2 = 0.2 * sqrt(pi/garea) +! almin1 = almin2 + + KM1 = K - 1 + KD1 = KD + 1 + do l=1,K - tcd(L) = 0.0 - qcd(L) = 0.0 + tcd(L) = zero + qcd(L) = zero enddo -! - KP1 = K + 1 - KM1 = K - 1 - KD1 = KD + 1 ! ! if (lprnt) then -! print *,' IN CLOUD for KD=',kd -! print *,' prs=',prs(Kd:K+1) -! print *,' phil=',phil(KD:K) -! print *,' phih=',phih(1:K+1),' kdt=',kdt -! print *,' phih=',phih(KD:K+1) -! print *,' toi=',toi -! print *,' qoi=',qoi +! write(0,*) ' IN CLOUD for KD=',kd +! write(0,*) ' prs=',prs(Kd:KP1) +! write(0,*) ' phil=',phil(KD:K) +!! write(0,*) ' phih=',phih(kd:KP1),' kdt=',kdt +! write(0,*) ' phih=',phih(KD:KP1) +! write(0,*) ' toi=',toi +! write(0,*) ' qoi=',qoi ! endif ! - CLDFRD = 0.0 - DOF = 0.0 + CLDFRD = zero + DOF = zero PRL(KP1) = PRS(KP1) ! DO L=KD,K - RNN(L) = 0.0 - ZET(L) = 0.0 - XI(L) = 0.0 + RNN(L) = zero + ZET(L) = zero + XI(L) = zero ! TOL(L) = TOI(L) QOL(L) = QOI(L) PRL(L) = PRS(L) - BUY(L) = 0.0 CLL(L) = QLI(L) CIL(L) = QII(L) + BUY(L) = zero + + wvl(l) = zero ENDDO + wvl(kp1) = zero ! if (vsmooth) then do l=kd,k @@ -1185,8 +1344,8 @@ SUBROUTINE CLOUD( & wrk2(l) = qol(l) enddo do l=kd1,km1 - tol(l) = 0.25*wrk1(l-1) + 0.5*wrk1(l) + 0.25*wrk1(l+1) - qol(l) = 0.25*wrk2(l-1) + 0.5*wrk2(l) + 0.25*wrk2(l+1) + tol(l) = pt25*wrk1(l-1) + half*wrk1(l) + pt25*wrk1(l+1) + qol(l) = pt25*wrk2(l-1) + half*wrk2(l) + pt25*wrk2(l+1) enddo endif ! @@ -1197,6 +1356,8 @@ SUBROUTINE CLOUD( & PL = PRSM(L) TL = TOL(L) + rho(l) = cmb2pa * pl / (rgas*tl*(one+nu*qol(l))) + AKT(L) = (PRL(L+1) - PL) * DPI ! CALL QSATCN(TL, PL, QS, DQS) @@ -1205,14 +1366,14 @@ SUBROUTINE CLOUD( & QST(L) = QS GAM(L) = DQS * ELOCP ST1 = ONE + GAM(L) - GAF(L) = (ONE/ALHL) * GAM(L)/ST1 + GAF(L) = ONEOALHL * GAM(L) / ST1 QL = MAX(MIN(QS*RHMAX,QOL(L)), ONE_M10) QOL(L) = QL TEM = CP * TL LTL(L) = TEM * ST1 / (ONE+NU*(QST(L)+TL*DQS)) - vtf(L) = 1.0 + NU * QL + vtf(L) = one + NU * QL ETA(L) = ONE / (LTL(L) * VTF(L)) HOL(L) = TEM + QL * ALHL @@ -1220,7 +1381,7 @@ SUBROUTINE CLOUD( & ! ENDDO ! - ETA(K+1) = ZERO + ETA(KP1) = ZERO GMS(K) = ZERO ! AKT(KD) = HALF @@ -1228,14 +1389,14 @@ SUBROUTINE CLOUD( & ! CLP = ZERO ! - GAM(K+1) = GAM(K) - GAF(K+1) = GAF(K) + GAM(KP1) = GAM(K) + GAF(KP1) = GAF(K) ! DO L=K,KD1,-1 DPHIB = PHIL(L) - PHIH(L+1) DPHIT = PHIH(L) - PHIL(L) ! - DLB(L) = DPHIB * ETA(L) + DLB(L) = DPHIB * ETA(L) ! here eta contains 1/(L*(1+nu*q)) DLT(L) = DPHIT * ETA(L) ! QRB(L) = DPHIB @@ -1268,19 +1429,19 @@ SUBROUTINE CLOUD( & ! ! if (kd == 12) then ! if (lprnt) then -! print *,' IN CLOUD for KD=',KD,' K=',K -! print *,' l=',l,' hol=',hol(l),' hst=',hst(l) -! print *,' TOL=',tol -! print *,' qol=',qol -! print *,' hol=',hol -! print *,' hst=',hst +! write(0,*) ' IN CLOUD for KD=',KD,' K=',K +! write(0,*) ' l=',l,' hol=',hol(l),' hst=',hst(l) +! write(0,*) ' TOL=',tol +! write(0,*) ' qol=',qol +! write(0,*) ' hol=',hol +! write(0,*) ' hst=',hst ! endif ! endif ! ! To determine KBL internally -- If KBL is defined externally ! the following two loop should be skipped ! -! if (lprnt) print *,' calkbl=',calkbl +! if (lprnt) write(0,*) ' calkbl=',calkbl hcrit = hcritd if (sgcs(kd) > 0.65) hcrit = hcrits @@ -1310,7 +1471,7 @@ SUBROUTINE CLOUD( & hmax = hol(kmax) elseif (kmax < k) then do l=kmax+1,k - if (abs(hol(kmax)-hol(l)) > 0.5 * hcrit) then + if (abs(hol(kmax)-hol(l)) > half * hcrit) then kmxb = l - 1 exit endif @@ -1320,28 +1481,28 @@ SUBROUTINE CLOUD( & kmaxp1 = kmax + 1 kblpmn = kmax ! - dhdp(kmax:k) = 0.0 + dhdp(kmax:k) = zero dhdpmn = dhdp(kmax) do l=kmaxm1,ktem,-1 dhdp(l) = (HOL(L)-HOL(L+1)) / (PRL(L+2)-PRL(L)) if (dhdp(l) < dhdpmn) then dhdpmn = dhdp(l) kblpmn = l + 1 - elseif (dhdp(l) > 0.0 .and. l <= kmin) then + elseif (dhdp(l) > zero .and. l <= kmin) then exit endif enddo kbl = kmax if (kblpmn < kmax) then do l=kblpmn,kmaxm1 - if (hmax-hol(l) < 0.5*hcrit) then + if (hmax-hol(l) < half*hcrit) then kbl = l exit endif enddo endif -! if(lprnt) print *,' kbl=',kbl,' kbls=',kbls,' kmax=',kmax +! if(lprnt) write(0,*)' kbl=',kbl,' kbls=',kbls,' kmax=',kmax ! klcl = kd1 if (kmax > kd1) then @@ -1352,7 +1513,7 @@ SUBROUTINE CLOUD( & endif enddo endif -! if(lprnt) print *,' klcl=',klcl,' ii=',ii +! if(lprnt) write(0,*)' klcl=',klcl,' ii=',ii ! if (klcl == kd .or. klcl < ktem) return ! This is to handle mid-level convection from quasi-uniform h @@ -1371,73 +1532,74 @@ SUBROUTINE CLOUD( & tem = min(50.0,max(10.0,(prl(kmaxp1)-prl(kd))*0.10)) if (prl(kmaxp1) - prl(ii) > tem .and. ii > kbl) kbl = ii -! if(lprnt) print *,' kbl2=',kbl,' ii=',ii +! if(lprnt) write(0,*)' kbl2=',kbl,' ii=',ii if (kbl .ne. ii) then if (PRL(kmaxp1)-PRL(KBL) > bldmax) kbl = max(kbl,ii) endif if (kbl < ii) then - if (hol(ii)-hol(ii-1) > 0.5*hcrit) kbl = ii + if (hol(ii)-hol(ii-1) > half*hcrit) kbl = ii endif -! if (prl(kbl) - prl(klcl) > 300.0 ) return - if (prl(kbl) - prl(klcl) > 250.0 ) return + if (prl(kbl) - prl(klcl) > pcrit_lcl) return ! - KBL = min(kmax, MAX(KBL,KBLMX)) +! KBL = min(kmax, MAX(KBL,KBLMX)) + KBL = min(kblmn, MAX(KBL,KBLMX)) ! kbl = min(kblh,kbl) !!! -! tem1 = max(prl(k+1)-prl(k), & +! tem1 = max(prl(kP1)-prl(k), & ! & min((prl(kbl) - prl(kd))*0.05, 10.0)) !! & min((prl(kbl) - prl(kd))*0.05, 20.0)) !! & min((prl(kbl) - prl(kd))*0.05, 30.0)) -! if (prl(k+1)-prl(kbl) < tem1) then +! if (prl(kp1)-prl(kbl) < tem1) then ! KTEM = MAX(KD+1, KBLMX) ! do l=k,KTEM,-1 -! tem = prl(k+1) - prl(l) +! tem = prl(kp1) - prl(l) ! if (tem > tem1) then ! kbl = min(kbl,l) ! exit ! endif ! enddo ! endif -! if (kbl == kblmx .and. kmax >= k-1) kbl = k - 1 +! if (kbl == kblmx .and. kmax >= km1) kbl = k - 1 !!! KPBL = KBL -! if(lprnt)print*,' 1st kbl=',kbl,' kblmx=',kblmx,' kd=',kd -! if(lprnt)print*,' tx3=',tx3,' tx1=',tx1,' tem=',tem +! if(lprnt)write(0,*)' 1st kbl=',kbl,' kblmx=',kblmx,' kd=',kd +! if(lprnt)write(0,*)' tx3=',tx3,' tx1=',tx1,' tem=',tem ! 1, ' hcrit=',hcrit ELSE KBL = KPBL -! if(lprnt)print*,' 2nd kbl=',kbl +! if(lprnt)write(0,*)' 2nd kbl=',kbl ENDIF -! if(lprnt)print*,' after CALKBL l=',l,' hol=',hol(l) +! if(lprnt)write(0,*)' after CALKBL l=',l,' hol=',hol(l) ! 1, ' hst=',hst(l) ! KBL = min(kmax,MAX(KBL,KD+2)) KB1 = KBL - 1 !! -! if (lprnt) print *,' kbl=',kbl,' prlkbl=',prl(kbl),prl(k+1) +! if (lprnt) write(0,*)' kbl=',kbl,' prlkbl=',prl(kbl),prl(kp1) - if(PRL(Kmaxp1)-PRL(KBL) > bldmax .or. kb1 <= kd) then + if (PRL(Kmaxp1)-PRL(KBL) > bldmax .or. kb1 <= kd ) then +! & .or. PRL(Kmaxp1)-PRL(KBL) < bldmin) then return endif ! -! if (lprnt) print *,' kbl=',kbl +! if (lprnt) write(0,*)' kbl=',kbl ! write(0,*)' kbl=',kbl,' kmax=',kmax,' kmaxp1=',kmaxp1,' k=',k ! - PRIS = ONE / (PRL(K+1)-PRL(KBL)) + PRIS = ONE / (PRL(KP1)-PRL(KBL)) PRISM = ONE / (PRL(Kmaxp1)-PRL(KBL)) - TX1 = ETA(KBL) + TX1 = ETA(KBL) ! geopotential height at KBL ! - GMS(KBL) = 0.0 - XI(KBL) = 0.0 - ZET(KBL) = 0.0 + GMS(KBL) = zero + XI(KBL) = zero + ZET(KBL) = zero ! - shal_fac = 1.0 + shal_fac = one ! if (prl(kbl)-prl(kd) < 300.0 .and. kmax == k) shal_fac = shalfac if (prl(kbl)-prl(kd) < 350.0 .and. kmax == k) shal_fac = shalfac DO L=Kmax,KD,-1 @@ -1449,11 +1611,11 @@ SUBROUTINE CLOUD( & ETA(L) = ZET(L) - ZET(L+1) GMS(L) = XI(L) - XI(L+1) ENDIF -! if (lprnt) print *,' l=',l,' eta=',eta(l),' kbl=',kbl +! if (lprnt) write(0,*)' l=',l,' eta=',eta(l),' kbl=',kbl ENDDO if (kmax < k) then do l=kmaxp1,kp1 - eta(l) = 0.0 + eta(l) = zero enddo endif ! @@ -1477,7 +1639,7 @@ SUBROUTINE CLOUD( & ! qbl = qbl * hpert_fac ! endif -! if (lprnt) print *,' hbl=',hbl,' qbl=',qbl +! if (lprnt) write(0,*)' hbl=',hbl,' qbl=',qbl ! Find Min value of HOL in TX2 TX2 = HOL(KD) IDH = KD1 @@ -1508,19 +1670,20 @@ SUBROUTINE CLOUD( & TX1 = RHFACS - QBL / TX1 ! Average RH cnvflg = (TEM > ZERO .OR. (LOWEST .AND. TEM1 >= ZERO)) & - & .AND. (TX1 < RHRAM) + & .AND. TX1 < RHRAM -! if(lprnt) print *,' cnvflg=',cnvflg,' tem=',tem,' tem1=',tem1 +! if(lprnt) write(0,*)' cnvflg=',cnvflg,' tem=',tem,' tem1=',tem1 ! &,' tx1=',tx1,' rhram=',rhram,' kbl=',kbl,' kd=',kd,' lowest=' ! &,lowest,' rhfacs=',rhfacs,' ltl=',ltl(kd1),' qol=',qol(kd1) ! &,' qst=',qst(kd1),' hst=',hst(kd1),' nu=',nu -! if(lprnt .and. (.not. cnvflg)) print *,' tx1=',tx1,' rhfacs=' +! if(lprnt .and. (.not. cnvflg)) write(0,*)' tx1=',tx1,' rhfacs=' ! &,rhfacs, ' tem=',tem,' hst=',hst(kd1) IF (.NOT. cnvflg) RETURN ! - RHC = MAX(ZERO, MIN(ONE, EXP(-20.0*TX1) )) + RHC = MAX(ZERO, MIN(ONE, EXP(-20.0*TX1) )) ! + wcbase = 0.1 if (ntrc > 0) then DO N=1,NTRC RBL(N) = ROI(Kmax,N) * ETA(Kmax) @@ -1530,48 +1693,60 @@ SUBROUTINE CLOUD( & RBL(N) = RBL(N) + ROI(L,N)*(ETA(L)-ETA(L+1)) ENDDO ENDDO +! +! if (ntk > 0 .and. do_aw) then + if (ntk > 0) then + wcbase = min(2.0, max(wcbase, sqrt(twoo3*rbl(ntk)))) +! wcbase = min(1.0, max(wcbase, sqrt(twoo3*rbl(ntk)))) + endif + +! if (lprnt) write(0,*)' wcbase=',wcbase,' rbl=', +! & rbl(ntk),' ntk=',ntk + endif ! - TX4 = 0.0 - TX5 = 0.0 + TX4 = zero + TX5 = zero ! - TX3 = QST(KBL) - GAF(KBL) * HST(KBL) + TX3 = QST(KBL) - GAF(KBL) * HST(KBL) DO L=KBL,K QIL(L) = MAX(ZERO, MIN(ONE, (TCR-TCL-TOL(L))*TCRF)) ENDDO ! DO L=KB1,KD1,-1 + lp1 = l + 1 TEM = QST(L) - GAF(L) * HST(L) - TEM1 = (TX3 + TEM) * 0.5 - ST2 = (GAF(L)+GAF(L+1)) * 0.5 + TEM1 = (TX3 + TEM) * half + ST2 = (GAF(L)+GAF(LP1)) * half ! - FCO(L+1) = TEM1 + ST2 * HBL + FCO(LP1) = TEM1 + ST2 * HBL -! if(lprnt) print *,' fco=',fco(l+1),' tem1=',tem1,' st2=',st2 +! if(lprnt) write(0,*)' fco=',fco(l+1),' tem1=',tem1,' st2=',st2 ! &,' hbl=',hbl,' tx3=',tx3,' tem=',tem,' gaf=',gaf(l),' l=',l - RNN(L+1) = ZET(L+1) * TEM1 + ST2 * TX4 - GMH(L+1) = XI(L+1) * TEM1 + ST2 * TX5 + RNN(LP1) = ZET(LP1) * TEM1 + ST2 * TX4 + GMH(LP1) = XI(LP1) * TEM1 + ST2 * TX5 ! TX3 = TEM TX4 = TX4 + ETA(L) * HOL(L) TX5 = TX5 + GMS(L) * HOL(L) ! QIL(L) = MAX(ZERO, MIN(ONE, (TCR-TCL-TOL(L))*TCRF)) - QLL(L+1) = (0.5*ALHF) * ST2 * (QIL(L)+QIL(L+1)) + ONE + QLL(LP1) = (half*ALHF) * ST2 * (QIL(L)+QIL(LP1)) + ONE ENDDO ! ! FOR THE CLOUD TOP -- L=KD ! L = KD ! + lp1 = l + 1 TEM = QST(L) - GAF(L) * HST(L) - TEM1 = (TX3 + TEM) * 0.5 - ST2 = (GAF(L)+GAF(L+1)) * 0.5 + TEM1 = (TX3 + TEM) * half + ST2 = (GAF(L)+GAF(LP1)) * half ! - FCO(L+1) = TEM1 + ST2 * HBL - RNN(L+1) = ZET(L+1) * TEM1 + ST2 * TX4 - GMH(L+1) = XI(L+1) * TEM1 + ST2 * TX5 + FCO(LP1) = TEM1 + ST2 * HBL + RNN(LP1) = ZET(LP1) * TEM1 + ST2 * TX4 + GMH(LP1) = XI(LP1) * TEM1 + ST2 * TX5 ! FCO(L) = TEM + GAF(L) * HBL RNN(L) = TEM * ZET(L) + (TX4 + ETA(L)*HOL(L)) * GAF(L) @@ -1580,77 +1755,78 @@ SUBROUTINE CLOUD( & ! Replace FCO for the Bottom ! FCO(KBL) = QBL - RNN(KBL) = 0.0 - GMH(KBL) = 0.0 + RNN(KBL) = zero + GMH(KBL) = zero ! QIL(KD) = MAX(ZERO, MIN(ONE, (TCR-TCL-TOL(KD))*TCRF)) - QLL(KD1) = (0.5*ALHF) * ST2 * (QIL(KD) + QIL(KD1)) + ONE + QLL(KD1) = (half*ALHF) * ST2 * (QIL(KD) + QIL(KD1)) + ONE QLL(KD ) = ALHF * GAF(KD) * QIL(KD) + ONE ! ! if (lprnt) then -! print *,' fco=',fco(kd:kbl) -! print *,' qil=',qil(kd:kbl) -! print *,' qll=',qll(kd:kbl) +! write(0,*)' fco=',fco(kd:kbl) +! write(0,*)' qil=',qil(kd:kbl) +! write(0,*)' qll=',qll(kd:kbl) ! endif ! st1 = qil(kd) st2 = c0i * st1 - tem = c0 * (1.0-st1) + tem = c0 * (one-st1) tem2 = st2*qi0 + tem*qw0 ! DO L=KD,KB1 + lp1 = l + 1 tx2 = akt(l) * eta(l) tx1 = tx2 * tem2 q0u(l) = tx1 - FCO(L) = FCO(L+1) - FCO(L) + tx1 - RNN(L) = RNN(L+1) - RNN(L) & + FCO(L) = FCO(LP1) - FCO(L) + tx1 + RNN(L) = RNN(LP1) - RNN(L) & & + ETA(L)*(QOL(L)+CLL(L)+CIL(L)) + tx1*zet(l) - GMH(L) = GMH(L+1) - GMH(L) & + GMH(L) = GMH(LP1) - GMH(L) & & + GMS(L)*(QOL(L)+CLL(L)+CIL(L)) + tx1*xi(l) ! - tem1 = (1.0-akt(l)) * eta(l) + tem1 = (one-akt(l)) * eta(l) -! if(lprnt) print *,' qll=',qll(l),' st2=',st2,' tem=',tem +! if(lprnt) write(0,*)' qll=',qll(l),' st2=',st2,' tem=',tem ! &,' tx2=',tx2,' akt=',akt(l),' eta=',eta(l) AKT(L) = QLL(L) + (st2 + tem) * tx2 -! if(lprnt) print *,' akt==',akt(l),' l==',l +! if(lprnt) write(0,*)' akt==',akt(l),' l==',l - AKC(L) = 1.0 / AKT(L) + AKC(L) = one / AKT(L) ! - st1 = 0.5 * (qil(l)+qil(l+1)) + st1 = half * (qil(l)+qil(lp1)) st2 = c0i * st1 - tem = c0 * (1.0-st1) + tem = c0 * (one-st1) tem2 = st2*qi0 + tem*qw0 ! - BKC(L) = QLL(L+1) - (st2 + tem) * tem1 + BKC(L) = QLL(LP1) - (st2 + tem) * tem1 ! tx1 = tem1*tem2 q0d(l) = tx1 FCO(L) = FCO(L) + tx1 - RNN(L) = RNN(L) + tx1*zet(l+1) - GMH(L) = GMH(L) + tx1*xi(l+1) + RNN(L) = RNN(L) + tx1*zet(lp1) + GMH(L) = GMH(L) + tx1*xi(lp1) ENDDO -! if(lprnt) print *,' akt=',akt(kd:kb1) -! if(lprnt) print *,' akc=',akc(kd:kb1) +! if(lprnt) write(0,*)' akt=',akt(kd:kb1) +! if(lprnt) write(0,*)' akc=',akc(kd:kb1) qw00 = qw0 qi00 = qi0 ii = 0 777 continue ! -! if (lprnt) print *,' after 777 ii=',ii,' ep_wfn=',ep_wfn +! if (lprnt) write(0,*)' after 777 ii=',ii,' ep_wfn=',ep_wfn ! ep_wfn = .false. - RNN(KBL) = 0.0 + RNN(KBL) = zero TX3 = bkc(kb1) * (QIB + QLB) - TX4 = 0.0 - TX5 = 0.0 + TX4 = zero + TX5 = zero DO L=KB1,KD1,-1 TEM = BKC(L-1) * AKC(L) -! if (lprnt) print *,' tx3=',tx3,' fco=',fco(l),' akc=',akc(l) +! if (lprnt) write(0,*)' tx3=',tx3,' fco=',fco(l),' akc=',akc(l) ! &,' bkc=',bkc(l-1), ' l=',l TX3 = (TX3 + FCO(L)) * TEM TX4 = (TX4 + RNN(L)) * TEM @@ -1662,7 +1838,7 @@ SUBROUTINE CLOUD( & HSD = HBL ENDIF ! -! if (lprnt) print *,' tx3=',tx3,' fco=',fco(kd),' akc=',akc(kd) +! if (lprnt) write(0,*)' tx3=',tx3,' fco=',fco(kd),' akc=',akc(kd) TX3 = (TX3 + FCO(KD)) * AKC(KD) TX4 = (TX4 + RNN(KD)) * AKC(KD) @@ -1671,7 +1847,7 @@ SUBROUTINE CLOUD( & ! HSU = HST(KD) + LTL(KD) * NU * (QOL(KD)-QST(KD)) -! if (lprnt) print *,' hsu=',hsu,' hst=',hst(kd), +! if (lprnt) write(0,*)' hsu=',hsu,' hst=',hst(kd), ! &' ltl=',ltl(kd),' qol=',qol(kd),' qst=',qst(kd) ! !===> VERTICAL INTEGRALS NEEDED TO COMPUTE THE ENTRAINMENT PARAMETER @@ -1687,7 +1863,7 @@ SUBROUTINE CLOUD( & ! ! MODIFY HSU TO INCLUDE CLOUD LIQUID WATER AND ICE TERMS ! -! if (lprnt) print *,' hsu=',hsu,' alm=',alm,' tx3=',tx3 +! if (lprnt) write(0,*)' hsu=',hsu,' alm=',alm,' tx3=',tx3 HSU = HSU - ALM * TX3 ! @@ -1700,7 +1876,7 @@ SUBROUTINE CLOUD( & cnvflg = HBL > HSU .and. abs(tx1) > 1.0e-4 -! if (lprnt) print *,' ii=',ii,' cnvflg=',cnvflg,' hsu=',hsu +! if (lprnt) write(0,*)' ii=',ii,' cnvflg=',cnvflg,' hsu=',hsu ! &,' hbl=',hbl,' tx1=',tx1,' hsd=',hsd !*********************************************************************** @@ -1713,19 +1889,19 @@ SUBROUTINE CLOUD( & ! CLOUD CAN BE NEUTRALLY BOUYANT AT MIDDLE OF LEVEL KD W/ +VE LAMBDA. ! EPP < .25 IS REQUIRED TO HAVE REAL ROOTS. ! - clp = 1.0 + clp = one st2 = hbl - hsu -! if(lprnt) print *,' tx2=',tx2,' tx1=',tx1,' st2=',st2 +! if(lprnt) write(0,*)' tx2=',tx2,' tx1=',tx1,' st2=',st2 ! - if (tx2 == 0.0) then + if (tx2 == zero) then alm = - st2 / tx1 if (alm > almax) alm = -100.0 else x00 = tx2 + tx2 epp = tx1 * tx1 - (x00+x00)*st2 - if (epp > 0.0) then - x00 = 1.0 / x00 + if (epp > zero) then + x00 = one / x00 tem = sqrt(epp) tem1 = (-tx1-tem)*x00 tem2 = (-tx1+tem)*x00 @@ -1733,44 +1909,43 @@ SUBROUTINE CLOUD( & if (tem2 > almax) tem2 = -100.0 alm = max(tem1,tem2) -! if (lprnt) print *,' tem1=',tem1,' tem2=',tem2,' alm=',alm +! if (lprnt) write(0,*) ' tem1=',tem1,' tem2=',tem2,' alm=',alm ! &,' tx1=',tx1,' tem=',tem,' epp=',epp,' x00=',x00,' st2=',st2 endif endif -! if (lprnt) print *,' almF=',alm,' ii=',ii,' qw00=',qw00 +! if (lprnt) write(0,*)' almF=',alm,' ii=',ii,' qw00=',qw00 ! &,' qi00=',qi00 ! ! CLIP CASE: ! NON-ENTRAINIG CLOUD DETRAINS IN LOWER HALF OF TOP LAYER. ! NO CLOUDS ARE ALLOWED TO DETRAIN BELOW THE TOP LAYER. ! - ELSEIF ( (HBL <= HSU) .AND. & - & (HBL > ST1 ) ) THEN + ELSEIF (HBL <= HSU .AND. HBL > ST1) THEN ALM = ZERO ! CLP = (HBL-ST1) / (HSU-ST1) ! commented on Jan 16, 2010 ENDIF ! cnvflg = .TRUE. - IF (ALMIN1 > 0.0) THEN + IF (ALMIN1 > zero) THEN IF (ALM >= ALMIN1) cnvflg = .FALSE. ELSE - LOWEST = KD == KB1 + LOWEST = KD == KB1 IF ( (ALM > ZERO) .OR. & - & (.NOT. LOWEST .AND. ALM == ZERO) ) cnvflg = .FALSE. + & (.NOT. LOWEST .AND. ALM == ZERO) ) cnvflg = .FALSE. ENDIF ! !===> IF NO SOUNDING MEETS SECOND CONDITION, RETURN ! IF (cnvflg) THEN - IF (ii > 0 .or. (qw00 == 0.0 .and. qi00 == 0.0)) RETURN - CLP = 1.0 + IF (ii > 0 .or. (qw00 == zero .and. qi00 == zero)) RETURN + CLP = one ep_wfn = .true. GO TO 888 ENDIF ! -! if (lprnt) print *,' hstkd=',hst(kd),' qstkd=',qst(kd) +! if (lprnt) write(0,*)' hstkd=',hst(kd),' qstkd=',qst(kd) ! &,' ii=',ii,' clp=',clp st1s = ONE @@ -1807,15 +1982,17 @@ SUBROUTINE CLOUD( & ! ! Critical workfunction is included in this version ! - ACR = 0.0 - TEM = PRL(KD1) - (PRL(KD1)-PRL(KD)) * CLP * HALF - tx1 = PRL(KBL) - TEM - tx2 = min(900.0,max(tx1,100.0)) - tem1 = log(tx2*0.01) / log(10.0) + ACR = zero + TEM = PRL(KD1) - (PRL(KD1)-PRL(KD)) * CLP * HALF + tx1 = PRL(KBL) - TEM + tx2 = min(900.0, max(tx1,100.0)) + tem1 = log(tx2*0.01) * oneolog10 + tem2 = one - tem1 if ( kdt == 1 ) then - rel_fac = (dt * facdt) / (tem1*12.0 + (1-tem1)*3.0) +! rel_fac = (dt * facdt) / (tem1*12.0 + tem2*3.0) + rel_fac = (dt * facdt) / (tem1*6.0 + tem2*adjts_s) else - rel_fac = (dt * facdt) / (tem1*adjts_d + (1-tem1)*adjts_s) + rel_fac = (dt * facdt) / (tem1*adjts_d + tem2*adjts_s) endif ! ! rel_fac = max(zero, min(one,rel_fac)) @@ -1828,19 +2005,18 @@ SUBROUTINE CLOUD( & ! !===> NORMALIZED MASSFLUX ! -! ETA IS THE THICKNESS COMING IN AND THE MASS FLUX GOING OUT. -! GMS IS THE THICKNESS OF THE SQUARE; IT IS LATER REUSED FOR GAMMA_S +! ETA IS THE THICKNESS COMING IN AND normalized MASS FLUX GOING OUT. +! GMS IS THE THICKNESS SQUARE ; IT IS LATER REUSED FOR GAMMA_S ! ! ETA(K) = ONE DO L=KB1,KD,-1 ETA(L) = ETA(L+1) + ALM * (ETA(L) + ALM * GMS(L)) + ETAI(L) = one / ETA(L) ENDDO - DO L=KD,KBL - ETAI(L) = 1.0 / ETA(L) - ENDDO + ETAI(KBL) = one -! if (lprnt) print *,' eta=',eta,' ii=',ii,' alm=',alm +! if (lprnt) write(0,*)' eta=',eta,' ii=',ii,' alm=',alm ! !===> CLOUD WORKFUNCTION ! @@ -1855,33 +2031,35 @@ SUBROUTINE CLOUD( & qtv = qbl det = qlb + qib ! - tx2 = 0.0 - dpneg = 0.0 + tx2 = zero + dpneg = zero ! DO L=KB1,KD1,-1 - DEL_ETA = ETA(L) - ETA(L+1) + lm1 = l - 1 + lp1 = l + 1 + DEL_ETA = ETA(L) - ETA(LP1) HCCP = HCC + DEL_ETA*HOL(L) ! - QTLP = QST(L-1) - GAF(L-1)*HST(L-1) - QTVP = 0.5 * ((QTLP+QTL)*ETA(L) & - & + (GAF(L)+GAF(L-1))*HCCP) - ST1 = ETA(L)*Q0U(L) + ETA(L+1)*Q0D(L) + QTLP = QST(LM1) - GAF(LM1)*HST(LM1) + QTVP = half * ((QTLP+QTL)*ETA(L) & + & + (GAF(L)+GAF(LM1))*HCCP) + ST1 = ETA(L)*Q0U(L) + ETA(LP1)*Q0D(L) DETP = (BKC(L)*DET - (QTVP-QTV) & & + DEL_ETA*(QOL(L)+CLL(L)+CIL(L)) + ST1) * AKC(L) -! if(lprnt) print *,' detp=',detp,' bkc=',bkc(l),' det=',det +! if(lprnt) write(0,*)' detp=',detp,' bkc=',bkc(l),' det=',det ! if (lprnt .and. kd == 15) -! & print *,' detp=',detp,' bkc=',bkc(l),' det=',det +! & write(0,*)' detp=',detp,' bkc=',bkc(l),' det=',det ! &,' qtvp=',qtvp,' qtv=',qtv,' del_eta=',del_eta,' qol=' ! &,qol(l),' st1=',st1,' akc=',akc(l) ! TEM1 = AKT(L) - QLL(L) - TEM2 = QLL(L+1) - BKC(L) + TEM2 = QLL(LP1) - BKC(L) RNS(L) = TEM1*DETP + TEM2*DET - ST1 - qtp = 0.5 * (qil(L)+qil(L-1)) + qtp = half * (qil(L)+qil(LM1)) tem2 = min(qtp*(detp-eta(l)*qw00), & - & (1.0-qtp)*(detp-eta(l)*qi00)) + & (one-qtp)*(detp-eta(l)*qi00)) st1 = min(tx2,tem2) tx2 = tem2 ! @@ -1893,42 +2071,42 @@ SUBROUTINE CLOUD( & TEM2 = HCCP + DETP * QTP * ALHF ! -! if(lprnt) print *,' hst=',hst(l),' ltl=',ltl(l),' nu=',nu +! if(lprnt) write(0,*)' hst=',hst(l),' ltl=',ltl(l),' nu=',nu ! if (lprnt .and. kd == 15) -! & print *,' hst=',hst(l),' ltl=',ltl(l),' nu=',nu +! & write(0,*)' hst=',hst(l),' ltl=',ltl(l),' nu=',nu ! &,' qst=',qst(l),' qol=',qol(l),' hccp=',hccp,' detp=',detp ! *,' qtp=',qtp,' alhf=',alhf,' vtf=',vtf(l) ST2 = LTL(L) * VTF(L) TEM5 = CLL(L) + CIL(L) - TEM3 = (TX1 - ETA(L+1)*ST1 - ST2*(DET-TEM5*eta(l+1))) * DLB(L) + TEM3 = (TX1 - ETA(LP1)*ST1 - ST2*(DET-TEM5*eta(lp1))) * DLB(L) TEM4 = (TEM2 - ETA(L )*ST1 - ST2*(DETP-TEM5*eta(l))) * DLT(L) ! ! if (lprnt) then ! if (lprnt .and. kd == 12) then -! print *,' tem3=',tem3,' tx1=',tx1,' st1=',st1,' eta1=',eta(l+1) +! write(0,*)' tem3=',tem3,' tx1=',tx1,' st1=',st1,' eta1=',eta(l+1) ! &, ' st2=',st2,' det=',det,' tem5=',tem5,' dlb=',dlb(l) -! print *,' tem4=',tem4,' tem2=',tem2,' detp=',detp +! write(0,*)' tem4=',tem4,' tem2=',tem2,' detp=',detp ! &, ' eta=',eta(l),' dlt=',dlt(l),' rns=',rns(l),' l=',l -! print *,' bt1=',tem3/(eta(l+1)*qrb(l)) +! write(0,*)' bt1=',tem3/(eta(l+1)*qrb(l)) ! &, ' bt2=',tem4/(eta(l)*qrt(l)) ! endif ST1 = TEM3 + TEM4 -! if (lprnt) print *,' wfn=',wfn,' st1=',st1,' l=',l,' ep_wfn=', +! if (lprnt) write(0,*)' wfn=',wfn,' st1=',st1,' l=',l,' ep_wfn=', ! &ep_wfn,' akm=',akm WFN = WFN + ST1 AKM = AKM - min(ST1,ZERO) -! if (lprnt) print *,' wfn=',wfn,' akm=',akm +! if (lprnt) write(0,*)' wfn=',wfn,' akm=',akm if (st1 < zero .and. wfn < zero) then - dpneg = dpneg + prl(l+1) - prl(l) + dpneg = dpneg + prl(lp1) - prl(l) endif - BUY(L) = 0.5 * (tem3/(eta(l+1)*qrb(l)) + tem4/(eta(l)*qrt(l))) + BUY(L) = half * (tem3/(eta(lp1)*qrb(l)) + tem4/(eta(l)*qrt(l))) ! HCC = HCCP DET = DETP @@ -1952,18 +2130,18 @@ SUBROUTINE CLOUD( & RNS(KD) = TEM1*DETP + TEM2*DET - ST1 ! IF (rns(kd) < zero) ep_wfn = .TRUE. - IF (DETP <= ZERO) cnvflg = .TRUE. + IF (DETP <= ZERO) cnvflg = .TRUE. ! 888 continue -! if (lprnt) print *,' ep_wfn=',ep_wfn,' ii=',ii,' rns=',rns(kd) +! if (lprnt) write(0,*)' ep_wfn=',ep_wfn,' ii=',ii,' rns=',rns(kd) ! &,' clp=',clp,' hst(kd)=',hst(kd) if (ep_wfn) then - IF ((qw00 == 0.0 .and. qi00 == 0.0)) RETURN + IF ((qw00 == zero .and. qi00 == zero)) RETURN if (ii == 0) then ii = 1 - if (clp > 0.0 .and. clp < 1.0) then + if (clp > zero .and. clp < one) then hst(kd) = hstkd qst(kd) = qstkd ltl(kd) = ltlkd @@ -1973,18 +2151,19 @@ SUBROUTINE CLOUD( & qrb(kd) = qrbkd endif do l=kd,kb1 + lp1 = l + 1 FCO(L) = FCO(L) - q0u(l) - q0d(l) - RNN(L) = RNN(L) - q0u(l)*zet(l) - q0d(l)*zet(l+1) - GMH(L) = GMH(L) - q0u(l)*xi(l) - q0d(l)*zet(l+1) - ETA(L) = ZET(L) - ZET(L+1) - GMS(L) = XI(L) - XI(L+1) - Q0U(L) = 0.0 - Q0D(L) = 0.0 + RNN(L) = RNN(L) - q0u(l)*zet(l) - q0d(l)*zet(lp1) + GMH(L) = GMH(L) - q0u(l)*xi(l) - q0d(l)*zet(lp1) + ETA(L) = ZET(L) - ZET(LP1) + GMS(L) = XI(L) - XI(LP1) + Q0U(L) = zero + Q0D(L) = zero ENDDO - qw00 = 0.0 - qi00 = 0.0 + qw00 = zero + qi00 = zero -! if (lprnt) print *,' returning to 777 : ii=',ii,' qw00=',qw00,qi00 +! if (lprnt) write(0,*)' returning to 777 : ii=',ii,' qw00=',qw00,qi00 ! &,' clp=',clp,' hst(kd)=',hst(kd) go to 777 @@ -2002,7 +2181,7 @@ SUBROUTINE CLOUD( & TEM5 = (QLS + QIS) * eta(kd1) ST1 = HALF * (TX1-ETA(KD1)*ST1-ST2*(DET-TEM5))*DLB(KD) ! -! if (lprnt) print *,' st1=',st1,' st2=',st2,' ltl=',ltl(kd) +! if (lprnt) write(0,*)' st1=',st1,' st2=',st2,' ltl=',ltl(kd) ! *,ltl(kd1),' qos=',qos,qol(kd1) WFN = WFN + ST1 @@ -2011,7 +2190,7 @@ SUBROUTINE CLOUD( & BUY(KD) = ST1 / (ETA(KD1)*qrb(kd)) ! -! if (lprnt) print *,' wfn=',wfn,' akm=',akm,' st1=',st1 +! if (lprnt) write(0,*)' wfn=',wfn,' akm=',akm,' st1=',st1 ! &,' dpneg=',dpneg DET = DETP @@ -2021,10 +2200,8 @@ SUBROUTINE CLOUD( & !*********************************************************************** ! -! If only to calculate workfunction save it and return -! - IF (WRKFUN) THEN - IF (WFN >= 0.0) WFNC = WFN + IF (WRKFUN) THEN ! If only to calculate workfunction save it and return + IF (WFN >= zero) WFNC = WFN RETURN ELSEIF (.NOT. CRTFUN) THEN ACR = WFNC @@ -2034,16 +2211,11 @@ SUBROUTINE CLOUD( & ! CALCUP = .FALSE. - TEM = max(0.05, MIN(CD*200.0, MAX_NEG_BOUY)) - IF (WFN > ACR .AND. (.NOT. cnvflg) & -! & .and. dpneg < 100.0 .AND. AKM <= TEM) THEN - & .and. dpneg < 150.0 .AND. AKM <= TEM) THEN -! & .and. dpneg < 200.0 .AND. AKM <= TEM) THEN -! - CALCUP = .TRUE. - ENDIF + TEM = max(0.05, MIN(CD*200.0, MAX_NEG_BOUY)) + IF (.not. cnvflg .and. WFN > ACR .and. & + & dpneg < dpnegcr .and. AKM <= TEM) CALCUP = .TRUE. -! if (lprnt) print *,' calcup=',calcup,' akm=',akm,' tem=',tem +! if (lprnt) write(0,*)' calcup=',calcup,' akm=',akm,' tem=',tem ! *,' cnvflg=',cnvflg,' clp=',clp,' rhc=',rhc,' cd=',cd,' acr=',acr ! !===> IF NO SOUNDING MEETS THIRD CONDITION, RETURN @@ -2051,64 +2223,61 @@ SUBROUTINE CLOUD( & IF (.NOT. CALCUP) RETURN ! ! This is for not LL - 20050601 - IF (ALMIN2 .NE. 0.0) THEN - IF (ALMIN1 .NE. ALMIN2) ST1 = 1.0 / max(ONE_M10,(ALMIN2-ALMIN1)) - IF (ALM < ALMIN2) THEN - CLP = CLP * max(0.0, min(1.0,(0.3 + 0.7*(ALM-ALMIN1)*ST1))) -! CLP = CLP * max(0.0, min(1.0,(0.2 + 0.8*(ALM-ALMIN1)*ST1))) -! CLP = CLP * max(0.0, min(1.0,(0.1 + 0.9*(ALM-ALMIN1)*ST1))) - ENDIF - ENDIF +! IF (ALMIN2 .NE. zero) THEN +! IF (ALMIN1 .NE. ALMIN2) ST1 = one / max(ONE_M10,(ALMIN2-ALMIN1)) +! IF (ALM < ALMIN2) THEN +! CLP = CLP * max(zero, min(one,(0.3 + 0.7*(ALM-ALMIN1)*ST1))) +!! CLP = CLP * max(0.0, min(1.0,(0.2 + 0.8*(ALM-ALMIN1)*ST1))) +!! CLP = CLP * max(0.0, min(1.0,(0.1 + 0.9*(ALM-ALMIN1)*ST1))) +! ENDIF +! ENDIF ! -! if (lprnt) print *,' clp=',clp +! if (lprnt) write(0,*)' clp=',clp ! CLP = CLP * RHC - dlq = 0.0 - tem = 1.0 / (1.0 + dlq_fac) + dlq = zero + tem = one / (one + dlq_fac) do l=kd,kb1 rnn(l) = rns(l) * tem dlq(l) = rns(l) * tem * dlq_fac enddo DO L=KBL,K - RNN(L) = 0.0 + RNN(L) = zero ENDDO -! if (lprnt) print *,' rnn=',rnn +! if (lprnt) write(0,*)' rnn=',rnn ! ! If downdraft is to be invoked, do preliminary check to see ! if enough rain is available and then call DDRFT. ! DDFT = .FALSE. - IF (DNDRFT) THEN -! - TRAIN = 0.0 - IF (CLP > 0.0) THEN + IF (dpd > zero) THEN + TRAIN = zero + IF (CLP > zero) THEN DO L=KD,KB1 TRAIN = TRAIN + RNN(L) ENDDO ENDIF PL = (PRL(KD1) + PRL(KD))*HALF - TEM = PRL(K+1)*(1.0-DPD*0.001) - IF (TRAIN > 1.0E-4 .AND. PL <= TEM) DDFT = .TRUE. -! + IF (TRAIN > 1.0E-4 .AND. PL <= dpd*prl(kp1)) DDFT = .TRUE. ENDIF ! ! if (lprnt) then -! print *,' BEFORE CALLING DDRFT KD=',kd,' DDFT=',DDFT +! write(0,*)' BEFORE CALLING DDRFT KD=',kd,' DDFT=',DDFT ! &, ' PL=',PL,' TRAIN=',TRAIN -! print *,' buy=',(buy(l),l=kd,kb1) +! write(0,*)' buy=',(buy(l),l=kd,kb1) ! endif IF (DDFT) THEN ! Downdraft scheme based on (Cheng and Arakawa, 1997) CALL DDRFT( & - & K, KD & - &, TLA, ALFIND & + & K, KP1, KD & + &, TLA, ALFIND, wcbase & &, TOL, QOL, HOL, PRL, QST, HST, GAM, GAF & ! &, TOL, QOL, HOL, PRL, QST, HST, GAM, GAF, HBL, QBL & &, QRB, QRT, BUY, KBL, IDH, ETA, RNN, ETAI & &, ALM, WFN, TRAIN, DDFT & &, ETD, HOD, QOD, EVP, DOF, CLDFR, ETZ & - &, GMS, GSD, GHD, lprnt) + &, GMS, GSD, GHD, wvl, lprnt) ENDIF ! @@ -2116,41 +2285,43 @@ SUBROUTINE CLOUD( & ! --------------------------------------------------------- ! IF (.NOT. DDFT) THEN - DO L=KD,K+1 - ETD(L) = 0.0 - HOD(L) = 0.0 - QOD(L) = 0.0 + DO L=KD,KP1 + ETD(L) = zero + HOD(L) = zero + QOD(L) = zero + wvl(l) = zero ENDDO DO L=KD,K - EVP(L) = 0.0 - ETZ(L) = 0.0 + EVP(L) = zero + ETZ(L) = zero ENDDO ENDIF -! if (lprnt) print *,' hod=',hod -! if (lprnt) print *,' etd=',etd +! if (lprnt) write(0,*) ' hod=',hod +! if (lprnt) write(0,*) ' etd=',etd +! if (lprnt) write(0,*) ' aft dd wvl=',wvl ! ! !===> CALCULATE GAMMAS i.e. TENDENCIES PER UNIT CLOUD BASE MASSFLUX ! Includes downdraft terms! - avh = 0.0 + avh = zero ! ! Fraction of detrained condensate evaporated ! ! tem1 = max(ZERO, min(HALF, (prl(kd)-FOUR_P2)*ONE_M2)) ! tem1 = max(ZERO, min(HALF, (prl(kd)-300.0)*0.005)) - tem1 = 0.0 + tem1 = zero ! tem1 = 1.0 ! if (kd1 == kbl) tem1 = 0.0 ! - tem2 = 1.0 - tem1 - TEM = DET * QIL(KD) + tem2 = one - tem1 + TEM = DET * QIL(KD) - st1 = (HCC+ALHF*TEM-ETA(KD)*HST(KD)) / (1.0+gam(KD)) + st1 = (HCC+ALHF*TEM-ETA(KD)*HST(KD)) / (one+gam(KD)) DS = ETA(KD1) * (HOS- HOL(KD)) - ALHL*(QOS - QOL(KD)) DH = ETA(KD1) * (HOS- HOL(KD)) @@ -2159,37 +2330,38 @@ SUBROUTINE CLOUD( & GMH(KD) = PRI(KD) * (HCC-ETA(KD)*HOS + DH) -! if (lprnt) print *,' gmhkd=',gmh(kd),' gmskd=',gms(kd) +! if (lprnt) write(0,*)' gmhkd=',gmh(kd),' gmskd=',gms(kd) ! &,' det=',det,' tem=',tem,' tem1=',tem1,' tem2=',tem2 ! ! TENDENCY FOR SUSPENDED ENVIRONMENTAL ICE AND/OR LIQUID WATER ! QLL(KD) = (tem2*(DET-TEM) + ETA(KD1)*(QLS-CLL(KD)) & - & + (1.0-QIL(KD))*dlq(kd) - ETA(KD)*QLS ) * PRI(KD) + & + (one-QIL(KD))*dlq(kd) - ETA(KD)*QLS ) * PRI(KD) QIL(KD) = (tem2*TEM + ETA(KD1)*(QIS-CIL(KD)) & & + QIL(KD)*dlq(kd) - ETA(KD)*QIS ) * PRI(KD) ! - GHD(KD) = 0.0 - GSD(KD) = 0.0 + GHD(KD) = zero + GSD(KD) = zero ! DO L=KD1,K + lm1 = l - 1 ST1 = ONE - ALFINT(L,1) ST2 = ONE - ALFINT(L,2) ST3 = ONE - ALFINT(L,3) ST4 = ONE - ALFINT(L,4) ST5 = ONE - ALFIND(L) - HB = ALFINT(L,1)*HOL(L-1) + ST1*HOL(L) - QB = ALFINT(L,2)*QOL(L-1) + ST2*QOL(L) + HB = ALFINT(L,1)*HOL(LM1) + ST1*HOL(L) + QB = ALFINT(L,2)*QOL(LM1) + ST2*QOL(L) - TEM = ALFINT(L,4)*CIL(L-1) + ST4*CIL(L) - TEM2 = ALFINT(L,3)*CLL(L-1) + ST3*CLL(L) + TEM = ALFINT(L,4)*CIL(LM1) + ST4*CIL(L) + TEM2 = ALFINT(L,3)*CLL(LM1) + ST3*CLL(L) TEM1 = ETA(L) * (TEM - CIL(L)) TEM3 = ETA(L) * (TEM2 - CLL(L)) - HBD = ALFIND(L)*HOL(L-1) + ST5*HOL(L) - QBD = ALFIND(L)*QOL(L-1) + ST5*QOL(L) + HBD = ALFIND(L)*HOL(LM1) + ST5*HOL(L) + QBD = ALFIND(L)*QOL(LM1) + ST5*QOL(L) TEM5 = ETD(L) * (HOD(L) - HBD) TEM6 = ETD(L) * (QOD(L) - QBD) @@ -2200,7 +2372,7 @@ SUBROUTINE CLOUD( & GMH(L) = DH * PRI(L) GMS(L) = DS * PRI(L) -! if (lprnt) print *,' gmh=',gmh(l),' gms=',gms(l) +! if (lprnt) write(0,*)' gmh=',gmh(l),' gms=',gms(l) ! &,' dh=',dh,' ds=',ds,' qb=',qb,' qol=',qol(l),' eta=',eta(l) ! &,' hb=',hb,' hol=',hol(l),' l=',l,' hod=',hod(l) ! &,' etd=',etd(l),' qod=',qod(l),' tem5=',tem5,' tem6=',tem6 @@ -2208,44 +2380,44 @@ SUBROUTINE CLOUD( & GHD(L) = TEM5 * PRI(L) GSD(L) = (TEM5 - ALHL * TEM6) * PRI(L) ! - QLL(L) = (TEM3 + (1.0-QIL(L))*dlq(l)) * PRI(L) + QLL(L) = (TEM3 + (one-QIL(L))*dlq(l)) * PRI(L) QIL(L) = (TEM1 + QIL(L)*dlq(l)) * PRI(L) - TEM1 = ETA(L) * (CIL(L-1) - TEM) - TEM3 = ETA(L) * (CLL(L-1) - TEM2) + TEM1 = ETA(L) * (CIL(LM1) - TEM) + TEM3 = ETA(L) * (CLL(LM1) - TEM2) - DH = ETA(L) * (HOL(L-1) - HB) - TEM5 - DS = DH - ALHL * ETA(L) * (QOL(L-1) - QB) & - & + ALHL * (TEM6 - EVP(L-1)) + DH = ETA(L) * (HOL(LM1) - HB) - TEM5 + DS = DH - ALHL * ETA(L) * (QOL(LM1) - QB) & + & + ALHL * (TEM6 - EVP(LM1)) - GMH(L-1) = GMH(L-1) + DH * PRI(L-1) - GMS(L-1) = GMS(L-1) + DS * PRI(L-1) + GMH(LM1) = GMH(LM1) + DH * PRI(LM1) + GMS(LM1) = GMS(LM1) + DS * PRI(LM1) ! -! if (lprnt) print *,' gmh1=',gmh(l-1),' gms1=',gms(l-1) +! if (lprnt) write(0,*)' gmh1=',gmh(l-1),' gms1=',gms(l-1) ! &,' dh=',dh,' ds=',ds,' qb=',qb,' qol=',qol(l-1) ! &,' hb=',hb,' hol=',hol(l-1),' evp=',evp(l-1) ! - GHD(L-1) = GHD(L-1) - TEM5 * PRI(L-1) - GSD(L-1) = GSD(L-1) - (TEM5-ALHL*(TEM6-EVP(L-1))) * PRI(L-1) + GHD(LM1) = GHD(LM1) - TEM5 * PRI(LM1) + GSD(LM1) = GSD(LM1) - (TEM5-ALHL*(TEM6-EVP(LM1))) * PRI(LM1) - QIL(L-1) = QIL(L-1) + TEM1 * PRI(L-1) - QLL(L-1) = QLL(L-1) + TEM3 * PRI(L-1) + QIL(LM1) = QIL(LM1) + TEM1 * PRI(LM1) + QLL(LM1) = QLL(LM1) + TEM3 * PRI(LM1) -! if (lprnt) print *,' gmh=',gmh(l),' gms=',gms(l) +! if (lprnt) write(0,*)' gmh=',gmh(l),' gms=',gms(l) ! &,' dh=',dh,' ds=',ds,' qb=',qb,' qol=',qol(l),' eta=',eta(l) ! &,' hb=',hb,' hol=',hol(l),' l=',l ! - avh = avh + gmh(l-1)*(prs(l)-prs(l-1)) + avh = avh + gmh(lm1)*(prs(l)-prs(lm1)) ENDDO ! HBD = HOL(K) QBD = QOL(K) - TEM5 = ETD(K+1) * (HOD(K+1) - HBD) - TEM6 = ETD(K+1) * (QOD(K+1) - QBD) + TEM5 = ETD(KP1) * (HOD(KP1) - HBD) + TEM6 = ETD(KP1) * (QOD(KP1) - QBD) DH = - TEM5 - DS = DH + ALHL * TEM6 + DS = DH + ALHL * TEM6 TEM1 = DH * PRI(K) TEM2 = (DS - ALHL * EVP(K)) * PRI(K) GMH(K) = GMH(K) + TEM1 @@ -2253,7 +2425,7 @@ SUBROUTINE CLOUD( & GHD(K) = GHD(K) + TEM1 GSD(K) = GSD(K) + TEM2 -! if (lprnt) print *,' gmhk=',gmh(k),' gmsk=',gms(k) +! if (lprnt) write(0,*)' gmhk=',gmh(k),' gmsk=',gms(k) ! &,' tem1=',tem1,' tem2=',tem2,' dh=',dh,' ds=',ds ! avh = avh + gmh(K)*(prs(KP1)-prs(K)) @@ -2273,8 +2445,8 @@ SUBROUTINE CLOUD( & ! ! if (lprnt) then -! print *,' gmh=',gmh -! print *,' gms=',gms(KD:K) +! write(0,*)' gmh=',gmh +! write(0,*)' gms=',gms(KD:K) ! endif ! !*********************************************************************** @@ -2289,27 +2461,27 @@ SUBROUTINE CLOUD( & TEM1 = GMH(L) TEM2 = GMS(L) HOL(L) = HOL(L) + TEM1*TESTMB - QOL(L) = QOL(L) + (TEM1-TEM2) * (TESTMB/ALHL) + QOL(L) = QOL(L) + (TEM1-TEM2) * TESTMBOALHL HST(L) = HST(L) + TEM2*(ONE+GAM(L))*TESTMB - QST(L) = QST(L) + TEM2*GAM(L)*(TESTMB/ALHL) + QST(L) = QST(L) + TEM2*GAM(L) * TESTMBOALHL CLL(L) = CLL(L) + QLL(L) * TESTMB CIL(L) = CIL(L) + QIL(L) * TESTMB ENDDO ! - if (alm > 0.0) then + if (alm > zero) then HOS = HOS + GMH(KD) * TESTMB - QOS = QOS + (GMH(KD)-GMS(KD)) * (TESTMB/ALHL) + QOS = QOS + (GMH(KD)-GMS(KD)) * TESTMBOALHL QLS = QLS + QLL(KD) * TESTMB QIS = QIS + QIL(KD) * TESTMB else - st2 = 1.0 - st1s + st2 = one - st1s HOS = HOS + (st1s*GMH(KD)+st2*GMH(KD1)) * TESTMB QOS = QOS + (st1s * (GMH(KD)-GMS(KD)) & - & + st2 * (GMH(KD1)-GMS(KD1))) * (TESTMB/ALHL) + & + st2 * (GMH(KD1)-GMS(KD1))) * TESTMBOALHL HST(kd) = HST(kd) + (st1s*GMS(kd)*(ONE+GAM(kd)) & & + st2*gms(kd1)*(ONE+GAM(kd1))) * TESTMB QST(kd) = QST(kd) + (st1s*GMS(kd)*GAM(kd) & - & + st2*gms(kd1)*gam(kd1)) * (TESTMB/ALHL) + & + st2*gms(kd1)*gam(kd1)) * TESTMBOALHL QLS = QLS + (st1s*QLL(KD)+st2*QLL(KD1)) * TESTMB QIS = QIS + (st1s*QIL(KD)+st2*QIL(KD1)) * TESTMB @@ -2338,7 +2510,7 @@ SUBROUTINE CLOUD( & ! qbl = qbl * hpert_fac ! endif -! if (lprnt) print *,' hbla=',hbl,' qbla=',qbl +! if (lprnt) write(0,*)' hbla=',hbl,' qbla=',qbl !*********************************************************************** @@ -2350,33 +2522,35 @@ SUBROUTINE CLOUD( & QTV = QBL HCC = HBL TX2 = HCC - TX4 = (ALHF*0.5)*MAX(ZERO,MIN(ONE,(TCR-TCL-TOL(KB1))*TCRF)) + TX4 = (ALHF*half)*MAX(ZERO,MIN(ONE,(TCR-TCL-TOL(KB1))*TCRF)) ! qtv = qbl tx1 = qib + qlb ! DO L=KB1,KD1,-1 - DEL_ETA = ETA(L) - ETA(L+1) + lm1 = l - 1 + lp1 = l + 1 + DEL_ETA = ETA(L) - ETA(LP1) HCCP = HCC + DEL_ETA*HOL(L) ! - QTLP = QST(L-1) - GAF(L-1)*HST(L-1) - QTVP = 0.5 * ((QTLP+QTL)*ETA(L) + (GAF(L)+GAF(L-1))*HCCP) + QTLP = QST(LM1) - GAF(LM1)*HST(LM1) + QTVP = half * ((QTLP+QTL)*ETA(L) + (GAF(L)+GAF(LM1))*HCCP) DETP = (BKC(L)*TX1 - (QTVP-QTV) & & + DEL_ETA*(QOL(L)+CLL(L)+CIL(L)) & - & + ETA(L)*Q0U(L) + ETA(L+1)*Q0D(L)) * AKC(L) - IF (DETP .LE. ZERO) cnvflg = .TRUE. + & + ETA(L)*Q0U(L) + ETA(LP1)*Q0D(L)) * AKC(L) + IF (DETP <= ZERO) cnvflg = .TRUE. ST1 = HST(L) - LTL(L)*NU*(QST(L)-QOL(L)) - TEM2 = (ALHF*0.5)*MAX(ZERO,MIN(ONE,(TCR-TCL-TOL(L-1))*TCRF)) + TEM2 = (ALHF*half)*MAX(ZERO,MIN(ONE,(TCR-TCL-TOL(LM1))*TCRF)) TEM1 = HCCP + DETP * (TEM2+TX4) ST2 = LTL(L) * VTF(L) TEM5 = CLL(L) + CIL(L) AKM = AKM + & - & ( (TX2 -ETA(L+1)*ST1-ST2*(TX1-TEM5*eta(l+1))) * DLB(L) & + & ( (TX2 -ETA(LP1)*ST1-ST2*(TX1-TEM5*eta(lp1))) * DLB(L) & & + (TEM1 -ETA(L )*ST1-ST2*(DETP-TEM5*eta(l))) * DLT(L) ) ! HCC = HCCP @@ -2394,29 +2568,27 @@ SUBROUTINE CLOUD( & ! had non-bouyancy there. ! ! - ST1 = HST(KD) - LTL(KD)*NU*(QST(KD)-QOS) - ST2 = LTL(KD) * VTF(KD) + ST1 = HST(KD) - LTL(KD)*NU*(QST(KD)-QOS) + ST2 = LTL(KD) * VTF(KD) TEM5 = (QLS + QIS) * eta(kd1) AKM = AKM + HALF * (TX2-ETA(KD1)*ST1-ST2*(TX1-TEM5)) * DLB(KD) ! - AKM = (AKM - WFN) * (ONE/TESTMB) + AKM = (AKM - WFN) * TESTMBI !*********************************************************************** !===> MASS FLUX - - tem2 = rel_fac ! - AMB = - (WFN-ACR) / AKM + AMB = - (WFN-ACR) / AKM ! -! if(lprnt) print *,' wfn=',wfn,' acr=',acr,' akm=',akm & -! &,' amb=',amb,' KD=',kd,' cldfrd=',cldfrd,' tem2=',tem2 & +! if(lprnt) write(0,*)' wfn=',wfn,' acr=',acr,' akm=',akm & +! &,' amb=',amb,' KD=',kd,' cldfrd=',cldfrd & ! &,' rel_fac=',rel_fac,' prskd=',prs(kd) !===> RELAXATION AND CLIPPING FACTORS ! - AMB = AMB * CLP * tem2 + AMB = AMB * CLP * rel_fac !!! if (DDFT) AMB = MIN(AMB, ONE/CLDFRD) @@ -2426,81 +2598,136 @@ SUBROUTINE CLOUD( & AMB = MAX(MIN(AMB, AMBMAX),ZERO) -! if(lprnt) print *,' AMB=',amb,' clp=',clp,' ambmax=',ambmax +! if(lprnt) write(0,*)' AMB=',amb,' clp=',clp,' ambmax=',ambmax !*********************************************************************** !*************************RESULTS*************************************** !*********************************************************************** !===> PRECIPITATION AND CLW DETRAINMENT ! - if (amb > 0.0) then - avt = 0.0 - avq = 0.0 - avr = dof + if (amb > zero) then ! - DSFC = DSFC + AMB * ETD(K) * (1.0/DT) +! if (wvl(kd) > zero) then +! tx1 = one - amb * eta(kd) / (rho(kd)*wvl(kd)) +! sigf(kd) = max(zero, min(one, tx1 * tx1)) +! endif + if (do_aw) then + tx1 = (0.2 / max(alm, 1.0e-5)) + tx2 = one - min(one, pi * tx1 * tx1 / garea) +! if(lprnt) write(0,*)' kd=',kd,' alm=',alm,' tx1=',tx1 +! &,' garea=',garea,' pi=',pi,' tx2=',tx2 + tx2 = tx2 * tx2 +! if(lprnt) write(0,*)' kd=',kd,' wvl=',wvl(kd:k+1) +! if(lprnt) write(0,*)' kd=',kd,' eta=',eta(kd:k+1) +! if(lprnt) write(0,*)' kd=',kd,' rho=',rho(kd:k) +! comnet out the following for now - 07/23/18 +! do l=kd1,kbl +! lp1 = min(K, l+1) +! if (wvl(l) > zero .and. wvl(lp1) > zero) then +! tx1 = one - amb * (eta(l)+eta(lp1)) +! & / ((wvl(l)+wvl(lp1))*rho(l)*grav) +! sigf(l) = max(zero, min(one, tx1 * tx1)) +! else +! sigf(l) = min(one,tx2) +! endif +! sigf(l) = max(sigf(l), tx2) +! enddo +! sigf(kd) = sigf(kd1) +! if (kbl < k) then +! sigf(kbl+1:k) = sigf(kbl) +! endif + sigf(kd:k) = tx2 + else + sigf(kd:k) = one + endif +! if(lprnt) write(0,*)' for kd=',kd,'sigf=',sigf(kd:k) +! + avt = zero + avq = zero + avr = dof * sigf(kbl) +! + DSFC = DSFC + AMB * ETD(K) * (one/DT) * sigf(kbl) ! ! DO L=KBL,KD,-1 DO L=K,KD,-1 - PCU(L) = PCU(L) + AMB*RNN(L) ! (A40) - avr = avr + rnn(l) -! if(lprnt) print *,' avr=',avr,' rnn=',rnn(l),' l=',l + PCU(L) = PCU(L) + AMB*RNN(L)*sigf(l) ! (A40) + avr = avr + rnn(l) * sigf(l) +! if(lprnt) write(0,*)' avr=',avr,' rnn=',rnn(l),' l=',l ENDDO - pcu(k) = pcu(k) + dof + pcu(k) = pcu(k) + amb * dof * sigf(kbl) ! !===> TEMPARATURE AND Q CHANGE AND CLOUD MASS FLUX DUE TO CLOUD TYPE KD ! - TX1 = AMB * (ONE/CP) - TX2 = AMB * (ONE/ALHL) + TX1 = AMB * ONEBCP + TX2 = AMB * ONEOALHL DO L=KD,K - ST1 = GMS(L)*TX1 + delp = prs(l+1) - prs(l) + tx3 = amb * sigf(l) + ST1 = GMS(L) * TX1 * sigf(l) TOI(L) = TOI(L) + ST1 TCU(L) = TCU(L) + ST1 - TCD(L) = TCD(L) + GSD(L) * TX1 + TCD(L) = TCD(L) + GSD(L) * TX1 * sigf(l) ! - st1 = st1 - (alhl/cp) * (QIL(L) + QLL(L)) * AMB + st1 = st1 - ELOCP * (QIL(L) + QLL(L)) * tx3 - avt = avt + st1 * (prs(l+1)-prs(l)) + avt = avt + st1 * delp - FLX(L) = FLX(L) + ETA(L)*AMB - FLXD(L) = FLXD(L) + ETD(L)*AMB + FLX(L) = FLX(L) + ETA(L) * tx3 + FLXD(L) = FLXD(L) + ETD(L) * tx3 ! - QII(L) = QII(L) + QIL(L) * AMB - TEM = 0.0 + QII(L) = QII(L) + QIL(L) * tx3 + TEM = zero - QLI(L) = QLI(L) + QLL(L) * AMB + TEM + QLI(L) = QLI(L) + QLL(L) * tx3 + TEM - ST1 = (GMH(L)-GMS(L)) * TX2 + ST1 = (GMH(L)-GMS(L)) * TX2 * sigf(l) QOI(L) = QOI(L) + ST1 QCU(L) = QCU(L) + ST1 - QCD(L) = QCD(L) + (GHD(L)-GSD(L)) * TX2 + QCD(L) = QCD(L) + (GHD(L)-GSD(L)) * TX2 * sigf(l) ! - avq = avq + (st1+(QLL(L)+QIL(L))*amb) * (prs(l+1)-prs(l)) + avq = avq + (st1 + (QLL(L)+QIL(L))*tx3) * delp ! avq = avq + st1 * (prs(l+1)-prs(l)) ! avr = avr + (QLL(L) + QIL(L)*(1+alhf/alhl)) -! avr = avr + (QLL(L) + QIL(L)) -! * * (prs(l+1)-prs(l)) * gravcon + avr = avr + (QLL(L) + QIL(L)) * delp * sigf(l) * gravcon -! if(lprnt) print *,' avr=',avr,' qll=',qll(l),' l=',l +! if(lprnt) write(0,*)' avr=',avr,' qll=',qll(l),' l=',l ! &, ' qil=',qil(l) +! Correction for negative condensate! + if (qii(l) < zero) then + tem = qii(l) * elfocp + QOI(L) = QOI(L) + qii(l) + qcu(l) = qcu(l) + qii(l) + toi(l) = toi(l) - tem + tcu(l) = tcu(l) - tem + qii(l) = zero + endif + if (qli(l) < zero) then + tem = qli(l) * elocp + QOI(L) = QOI(L) + qli(l) + qcu(l) = qcu(l) + qli(l) + toi(l) = toi(l) - tem + tcu(l) = tcu(l) - tem + qli(l) = zero + endif + ENDDO avr = avr * amb ! ! Correction for negative condensate! ! if (advcld) then ! do l=kd,k -! if (qli(l) < 0.0) then +! if (qli(l) < zero) then ! qoi(l) = qoi(l) + qli(l) ! toi(l) = toi(l) - (alhl/cp) * qli(l) -! qli(l) = 0.0 +! qli(l) = zero ! endif -! if (qii(l) < 0.0) then +! if (qii(l) < zero) then ! qoi(l) = qoi(l) + qii(l) ! toi(l) = toi(l) - ((alhl+alhf)/cp) * qii(l) -! qii(l) = 0.0 +! qii(l) = zero ! endif ! enddo ! endif @@ -2508,11 +2735,11 @@ SUBROUTINE CLOUD( & ! ! ! if (lprnt) then -! print *,' For KD=',KD +! write(0,*)' For KD=',KD ! avt = avt * cp * 100.0*86400.0 / (alhl*DT*grav) ! avq = avq * 100.0*86400.0 / (DT*grav) ! avr = avr * 86400.0 / DT -! print *,' avt=',avt,' avq=',avq,' avr=',avr,' avh=' +! write(0,*) ' avt=',avt,' avq=',avq,' avr=',avr,' avh=' ! * ,avh,' alm=',alm,' DDFT=',DDFT,' KD=',KD ! &,' TOIK-',toi(k),' TOIK-1=',toi(k-1),' TOIK-2=',toi(k-2) ! if (kd == 12 .and. .not. ddft) stop @@ -2520,78 +2747,79 @@ SUBROUTINE CLOUD( & ! & abs(avt-avr) > 1.0e-5 .or. abs(avr+avq) > 1.0e-5) stop ! ! if (lprnt) then -! print *,' For KD=',KD -! print *,' TCU=',(tcu(l),l=kd,k) -! print *,' QCU=',(Qcu(l),l=kd,k) +! write(0,*) ' in CLOUD For KD=',KD +! write(0,*) ' TCU=',(tcu(l),l=kd,k) +! write(0,*) ' QCU=',(Qcu(l),l=kd,k) ! endif ! - TX1 = 0.0 - TX2 = 0.0 + TX1 = zero + TX2 = zero ! IF (REVAP) THEN ! REEVAPORATION OF FALLING CONVECTIVE RAIN ! - tem = 0.0 + tem = zero do l=kd,kbl IF (L < IDH .or. (.not. DDFT)) THEN - tem = tem + amb * rnn(l) + tem = tem + amb * rnn(l) * sigf(l) endif enddo - tem = tem + amb * dof + tem = tem + amb * dof * sigf(kbl) tem = tem * (3600.0/dt) !!!! tem1 = max(1.0, min(100.0,sqrt((5.0E10/max(garea,one))))) ! tem1 = max(1.0, min(100.0,(7.5E10/max(garea,one)))) ! tem1 = max(1.0, min(100.0,(5.0E10/max(garea,one)))) ! tem1 = max(1.0, min(100.0,(4.0E10/max(garea,one)))) !! tem1 = sqrt(max(1.0, min(100.0,(4.0E10/max(garea,one))))) ! 20100902 - tem1 = sqrt(max(1.0, min(100.0,(6.25E10/max(garea,one))))) ! 20110530 + tem1 = sqrt(max(one, min(100.0,(6.25E10/max(garea,one))))) ! 20110530 -! if (lprnt) print *,' clfr0=',clf(tem),' tem=',tem,' tem1=',tem1 +! if (lprnt) write(0,*)' clfr0=',clf(tem),' tem=',tem,' tem1=',tem1 ! clfrac = max(ZERO, min(ONE, rknob*clf(tem)*tem1)) ! clfrac = max(ZERO, min(0.25, rknob*clf(tem)*tem1)) clfrac = max(ZERO, min(half, rknob*clf(tem)*tem1)) ! if (lprnt) then -! print *,' cldfrd=',cldfrd,' amb=',amb,' clfrac=',clfrac -! print *,' tx3=',tx3,' etakd=',eta(kd),' pri=',pri(kd) -! print *,' RNN=',RNN(kd:k) +! write(0,*) ' cldfrd=',cldfrd,' amb=',amb,' clfrac=',clfrac +! write(0,*) ' tx3=',tx3,' etakd=',eta(kd),' pri=',pri(kd) +! write(0,*) ' RNN=',RNN(kd:k) ! endif ! !cnt DO L=KD,K DO L=KD,KBL ! Testing on 20070926 ! for L=KD,K IF (L >= IDH .AND. DDFT) THEN - TX2 = TX2 + AMB * RNN(L) - CLDFRD = MIN(AMB*CLDFR(L), clfrac) + tem = amb * sigf(l) + TX2 = TX2 + tem * RNN(L) + CLDFRD = MIN(tem*CLDFR(L), clfrac) ELSE - TX1 = TX1 + AMB * RNN(L) + TX1 = TX1 + AMB * RNN(L) * sigf(l) ENDIF tx4 = zfac * phil(l) tx4 = (one - tx4 * (one - half*tx4)) * afc ! - IF (TX1 > 0. .OR. TX2 > 0.0) THEN + IF (TX1 > zero .OR. TX2 > zero) THEN TEQ = TOI(L) QEQ = QOI(L) - PL = 0.5 * (PRL(L+1)+PRL(L)) + PL = half * (PRL(L+1)+PRL(L)) ST1 = MAX(ZERO, MIN(ONE, (TCR-TEQ)*TCRF)) - ST2 = ST1*ELFOCP + (1.0-ST1)*ELOCP + ST2 = ST1*ELFOCP + (one-ST1)*ELOCP CALL QSATCN ( TEQ,PL,QSTEQ,DQDT) ! CALL QSATCN ( TEQ,PL,QSTEQ,DQDT,.false.) ! - DELTAQ = 0.5 * (QSTEQ*rhc_ls(l)-QEQ) / (1.+ST2*DQDT) + DELTAQ = half * (QSTEQ*rhc_ls(l)-QEQ) / (one+ST2*DQDT) ! QEQ = QEQ + DELTAQ TEQ = TEQ - DELTAQ*ST2 ! TEM1 = MAX(ZERO, MIN(ONE, (TCR-TEQ)*TCRF)) - TEM2 = TEM1*ELFOCP + (1.0-TEM1)*ELOCP + TEM2 = TEM1*ELFOCP + (one-TEM1)*ELOCP CALL QSATCN ( TEQ,PL,QSTEQ,DQDT) ! CALL QSATCN ( TEQ,PL,QSTEQ,DQDT,.false.) ! - DELTAQ = (QSTEQ*rhc_ls(l)-QEQ) / (1.+TEM2*DQDT) + DELTAQ = (QSTEQ*rhc_ls(l)-QEQ) / (one+TEM2*DQDT) ! QEQ = QEQ + DELTAQ TEQ = TEQ - DELTAQ*TEM2 @@ -2599,22 +2827,22 @@ SUBROUTINE CLOUD( & IF (QEQ > QOI(L)) THEN POTEVAP = (QEQ-QOI(L))*(PRL(L+1)-PRL(L))*GRAVCON - tem4 = 0.0 - if (tx1 > 0.0) & - & TEM4 = POTEVAP * (1. - EXP( tx4*TX1**0.57777778 ) ) + tem4 = zero + if (tx1 > zero) & + & TEM4 = POTEVAP * (one - EXP( tx4*TX1**0.57777778 ) ) ! & TEM4 = POTEVAP * (1. - EXP( AFC*tx4*SQRT(TX1) ) ) ACTEVAP = MIN(TX1, TEM4*CLFRAC) -! if(lprnt) print *,' L=',L,' actevap=',actevap,' tem4=',tem4, +! if(lprnt) write(0,*)' L=',L,' actevap=',actevap,' tem4=',tem4, ! &' clfrac=' ! &,clfrac,' potevap=',potevap,'efac=',AFC*SQRT(TX1*TEM3) ! &,' tx1=',tx1 if (tx1 < rainmin*dt) actevap = min(tx1, potevap) ! - tem4 = 0.0 - if (tx2 > 0.0) & - & TEM4 = POTEVAP * (1. - EXP( tx4*TX2**0.57777778 ) ) + tem4 = zero + if (tx2 > zero) & + & TEM4 = POTEVAP * (one - EXP( tx4*TX2**0.57777778 ) ) ! & TEM4 = POTEVAP * (1. - EXP( AFC*tx4*SQRT(TX2) ) ) TEM4 = min(MIN(TX2, TEM4*CLDFRD), potevap-actevap) if (tx2 < rainmin*dt) tem4 = min(tx2, potevap-actevap) @@ -2633,15 +2861,15 @@ SUBROUTINE CLOUD( & ENDIF ENDDO ! - CUP = CUP + TX1 + TX2 + DOF * AMB + CUP = CUP + TX1 + TX2 + DOF * AMB * sigf(kbl) ELSE DO L=KD,K - TX1 = TX1 + AMB * RNN(L) + TX1 = TX1 + AMB * RNN(L) * sigf(l) ENDDO - CUP = CUP + TX1 + DOF * AMB + CUP = CUP + TX1 + DOF * AMB * sigf(kbl) ENDIF -! if (lprnt) print *,' tx1=',tx1,' tx2=',tx2,' dof=',dof +! if (lprnt) write(0,*)' tx1=',tx1,' tx2=',tx2,' dof=',dof ! &,' cup=',cup*86400/dt,' amb=',amb ! &,' amb=',amb,' cup=',cup,' clfrac=',clfrac,' cldfrd=',cldfrd ! &,' ddft=',ddft,' kd=',kd,' kbl=',kbl,' k=',k @@ -2649,7 +2877,7 @@ SUBROUTINE CLOUD( & ! Convective transport (mixing) of passive tracers ! if (NTRC > 0) then - do l=kd,k-1 + do l=kd,km1 if (etz(l) /= zero) etzi(l) = one / etz(l) enddo DO N=1,NTRC ! Tracer loop ; first two are u and v @@ -2662,15 +2890,16 @@ SUBROUTINE CLOUD( & HOD(KD) = HOL(KD) ! Compute downdraft properties for the tracer DO L=KD1,K + lm1 = l - 1 ST1 = ONE - ALFIND(L) - HB = ALFIND(L) * HOL(L-1) + ST1 * HOL(L) - IF (ETZ(L-1) /= ZERO) THEN - TEM = ETZI(L-1) - IF (ETD(L) > ETD(L-1)) THEN - HOD(L) = (ETD(L-1)*(HOD(L-1)-HOL(L-1)) & - & + ETD(L) *(HOL(L-1)-HB) + ETZ(L-1)*HB) * TEM + HB = ALFIND(L) * HOL(LM1) + ST1 * HOL(L) + IF (ETZ(LM1) /= ZERO) THEN + TEM = ETZI(LM1) + IF (ETD(L) > ETD(LM1)) THEN + HOD(L) = (ETD(LM1)*(HOD(LM1)-HOL(LM1)) & + & + ETD(L) *(HOL(LM1)-HB) + ETZ(LM1)*HB) * TEM ELSE - HOD(L) = (ETD(L-1)*(HOD(L-1)-HB) + ETZ(L-1)*HB) * TEM + HOD(L) = (ETD(LM1)*(HOD(LM1)-HB) + ETZ(LM1)*HB) * TEM ENDIF ELSE HOD(L) = HB @@ -2686,55 +2915,84 @@ SUBROUTINE CLOUD( & ! fnoscav - the fraction not scavenged ! following Liu et al. [JGR,2001] Eq 1 - if (FSCAV_(N) > 0.0) then + if (FSCAV_(N) > zero) then DELZKM = ( PHIL(KD) - PHIH(KD1) ) *(onebg*0.001) FNOSCAV = exp(- FSCAV_(N) * DELZKM) else - FNOSCAV = 1.0 + FNOSCAV = one endif GMH(KD) = PRI(KD) * (HCC-ETA(KD)*HOL(KD)) * trcfac(kd,n) & & * FNOSCAV DO L=KD1,K - if (FSCAV_(N) > 0.0) then + if (FSCAV_(N) > zero) then DELZKM = ( PHIL(KD) - PHIH(L+1) ) *(onebg*0.001) FNOSCAV = exp(- FSCAV_(N) * DELZKM) endif + lm1 = l - 1 ST1 = ONE - ALFINT(L,N+4) ST2 = ONE - ALFIND(L) - HB = ALFINT(L,N+4) * HOL(L-1) + ST1 * HOL(L) - HBD = ALFIND(L) * HOL(L-1) + ST2 * HOL(L) + HB = ALFINT(L,N+4) * HOL(LM1) + ST1 * HOL(L) + HBD = ALFIND(L) * HOL(LM1) + ST2 * HOL(L) TEM5 = ETD(L) * (HOD(L) - HBD) DH = ETA(L) * (HB - HOL(L)) * FNOSCAV + TEM5 GMH(L ) = DH * PRI(L) * trcfac(l,n) - DH = ETA(L) * (HOL(L-1) - HB) * FNOSCAV - TEM5 - GMH(L-1) = GMH(L-1) + DH * PRI(L-1) * trcfac(l,n) + DH = ETA(L) * (HOL(LM1) - HB) * FNOSCAV - TEM5 + GMH(LM1) = GMH(LM1) + DH * PRI(LM1) * trcfac(l,n) ENDDO ! + st2 = zero DO L=KD,K - ST1 = GMH(L)*AMB - ROI(L,N) = HOL(L) + ST1 - RCU(L,N) = RCU(L,N) + ST1 + ST1 = GMH(L)*AMB*sigf(l) + st2 + st3 = HOL(L) + st1 + st2 = st3 - trcmin(n) ! if trcmin is defined limit change + if (st2 < zero) then + ROI(L,N) = trcmin(n) + RCU(L,N) = RCU(L,N) + ST1 + if (l < k) + & st2 = st2 * (prl(l+1)-prl(l))*pri(l+1) * (cmb2pa/grav) + else + ROI(L,N) = ST3 + RCU(L,N) = RCU(L,N) + ST1 + st2 = zero + endif + +! ROI(L,N) = HOL(L) + ST1 +! RCU(L,N) = RCU(L,N) + ST1 + +! if (l < k) then +! if (lprnt .and. n == ntk) write(0,*)' in ras roifin=',roi(l,n), +! &' hol=',hol(l),' gmh=',GMH(L),' amb=',amb,' l=',l +! &,' st2=',st2,' st3=',st3,' trcmin=',trcmin(n) +! &,' roi=',roi(l,n),' n=',n,' prl=',prl(l+1),prl(l),' pri=', +! & pri(l+1) +! else +! if (lprnt .and. n == ntk) write(0,*)' in ras roifin=',roi(l,n), +! &' hol=',hol(l),' gmh=',GMH(L),' amb=',amb,' l=',l +! &,' st2=',st2,' st3=',st3,' trcmin=',trcmin(n) +! &,' roi=',roi(l,n),' n=',n +! endif + ENDDO ENDDO ! Tracer loop NTRC endif - endif ! amb > 0.0 + endif ! amb > zero -! if (lprnt) print *,' toio=',toi -! if (lprnt) print *,' qoio=',qoi +! if (lprnt) write(0,*)' toio=',toi +! if (lprnt) write(0,*)' qoio=',qoi RETURN END SUBROUTINE DDRFT( & - & K, KD & - &, TLA, ALFIND & + & K, KP1, KD & + &, TLA, ALFIND, wcbase & &, TOL, QOL, HOL, PRL, QST, HST, GAM, GAF & ! &, TOL, QOL, HOL, PRL, QST, HST, GAM, GAF, HBL, QBL& &, QRB, QRT, BUY, KBL, IDH, ETA, RNN, ETAI & &, ALM, WFN, TRAIN, DDFT & &, ETD, HOD, QOD, EVP, DOF, CLDFRD, WCB & - &, GMS, GSD, GHD,lprnt) + &, GMS, GSD, GHD, wvlu, lprnt) ! !*********************************************************************** @@ -2752,7 +3010,7 @@ SUBROUTINE DDRFT( & !===> TOL(K) INPUT TEMPERATURE KELVIN !===> QOL(K) INPUT SPECIFIC HUMIDITY NON-DIMENSIONAL -!===> PRL(K+1) INPUT PRESSURE @ EDGES MB +!===> PRL(KP1) INPUT PRESSURE @ EDGES MB !===> K INPUT THE RISE & THE INDEX OF THE SUBCLOUD LAYER !===> KD INPUT DETRAINMENT LEVEL ( 1<= KD < K ) @@ -2763,13 +3021,13 @@ SUBROUTINE DDRFT( & ! ! INPUT ARGUMENTS ! - INTEGER K, KD, KBL - real(kind=kind_phys) ALFIND(K) + INTEGER K, KP1, KD, KBL + real(kind=kind_phys) ALFIND(K), wcbase real(kind=kind_phys), dimension(kd:k) :: HOL, QOL, HST, QST & &, TOL, QRB, QRT, RNN & &, RNS, ETAI - real(kind=kind_phys), dimension(kd:k+1) :: GAF, BUY, GAM, ETA & + real(kind=kind_phys), dimension(kd:kp1) :: GAF, BUY, GAM, ETA & &, PRL ! ! real(kind=kind_phys) HBL, QBL, PRIS & @@ -2781,19 +3039,20 @@ SUBROUTINE DDRFT( & &, GHD, GSD, CLDFRD & &, GQW, QRPI, QRPS, BUD - real(kind=kind_phys), dimension(KD:K+1) :: QRP, WVL, WVLO, ETD & - &, HOD, QOD, ROR, GMS + real(kind=kind_phys), dimension(KD:KP1) :: QRP, WVL, WVLU, ETD & + &, HOD, QOD, ROR, GMS real(kind=kind_phys) TL, PL, QL, QS, DQS, ST1 & - &, QQQ, PICON, DEL_ETA, HB, QB, TB & + &, QQQ, DEL_ETA, HB, QB, TB & &, TEM, TEM1, TEM2, TEM3, TEM4, ST2 & &, ERRMIN, ERRMI2, ERRH, ERRW, ERRE, TEM5 & &, TEM6, HBD, QBD, TX1, TX2, TX3 & &, TX4, TX5, TX6, TX7, TX8, TX9 & - &, WFN, ALM, VTPEXP , AL2 & + &, WFN, ALM, AL2 & &, TRAIN, GMF, ONPG, CTLA, VTRM & &, RPART, QRMIN, AA1, BB1, CC1, DD1 & - &, WC2MIN, WCMIN, WCBASE, F2, F3, F5 & +! &, WC2MIN, WCMIN, WCBASE, F2, F3, F5 & + &, WC2MIN, WCMIN, F2, F3, F5 & &, GMF1, GMF5, QRAF, QRBF, del_tla & &, TLA, STLA, CTL2, CTL3, ASIN & &, RNT, RNB, ERRQ, RNTP, QRPF, VTPF & @@ -2802,7 +3061,7 @@ SUBROUTINE DDRFT( & ! &, sialf INTEGER I, L, N, IX, KD1, II, kb1, IP1, JJ, ntla & - &, KP1, IT, KM1, KTEM, KK, KK1, LM1, LL, LP1 & + &, IT, KM1, KTEM, KK, KK1, LM1, LL, LP1 & &, IDW, IDH, IDN(K), idnm ! integer, parameter :: NUMTLA=2 @@ -2810,9 +3069,10 @@ SUBROUTINE DDRFT( & parameter (ERRMIN=0.0001, ERRMI2=0.1*ERRMIN) ! parameter (ERRMIN=0.00001, ERRMI2=0.1*ERRMIN) ! - real (kind=kind_phys), parameter :: PIINV=1.0/PI + real (kind=kind_phys), parameter :: PIINV=one/PI +! real (kind=kind_phys), parameter :: PIINV=one/PI, pio2=half*pi ! - parameter (ONPG=1.0+0.5, GMF=1.0/ONPG, RPART=0.0) + parameter (ONPG=one+half, GMF=one/ONPG, RPART=zero) ! parameter (ONPG=1.0+0.5, GMF=1.0/ONPG, RPART=1.0) ! parameter (ONPG=1.0+0.5, GMF=1.0/ONPG, RPART=0.5) ! PARAMETER (AA1=1.0, BB1=1.5, CC1=1.1, DD1=0.85, F3=CC1, F5=2.5) @@ -2820,66 +3080,67 @@ SUBROUTINE DDRFT( & PARAMETER (AA1=1.0, BB1=1.0, CC1=1.0, DD1=1.0, F3=CC1, F5=1.0) parameter (QRMIN=1.0E-6, WC2MIN=0.01, GMF1=GMF/AA1, GMF5=GMF/F5) ! parameter (QRMIN=1.0E-6, WC2MIN=1.00, GMF1=GMF/AA1, GMF5=GMF/F5) + parameter (WCMIN=sqrt(wc2min)) ! parameter (sialf=0.5) ! INTEGER ITR, ITRMU, ITRMD, KTPD, ITRMIN, ITRMND ! PARAMETER (ITRMU=25, ITRMD=25, ITRMIN=7) - PARAMETER (ITRMU=25, ITRMD=25, ITRMIN=12, ITRMND=12) + PARAMETER (ITRMU=25, ITRMD=25, ITRMIN=15, ITRMND=12) +! PARAMETER (ITRMU=25, ITRMD=25, ITRMIN=12, ITRMND=12) ! PARAMETER (ITRMU=25, ITRMD=25, ITRMIN=12) ! PARAMETER (ITRMU=14, ITRMD=18, ITRMIN=7) ! PARAMETER (ITRMU=10, ITRMD=10, ITRMIN=5) ! ! real(kind=kind_phys) EM(K*K), ELM(K) - real(kind=kind_phys) ELM(K), AA(KD:K,KD:K+1), QW(KD:K,KD:K) & + real(kind=kind_phys) ELM(K), AA(KD:K,KD:KP1), QW(KD:K,KD:K) & &, VT(2), VRW(2), TRW(2), QA(3), WA(3) - LOGICAL SKPDD, SKPUP, cnvflg, DDFT, UPDRET, DDLGK, lprnt + LOGICAL SKPUP, cnvflg, DDFT, UPDRET, DDLGK, lprnt !*********************************************************************** -! if(lprnt) print *,' K=',K,' KD=',KD,' In Downdrft' +! if(lprnt) write(0,*)' K=',K,' KD=',KD,' In Downdrft' KD1 = KD + 1 - KP1 = K + 1 KM1 = K - 1 KB1 = KBL - 1 ! ! VTP = 36.34*SQRT(1.2)* (0.001)**0.1364 - VTPEXP = -0.3636 +! VTPEXP = -0.3636 ! PIINV = 1.0 / PI - PICON = PI * ONEBG * 0.5 +! PICON = PIO2 * ONEBG ! ! Compute Rain Water Budget of the Updraft (Cheng and Arakawa, 1997) ! - CLDFRD = 0.0 - RNTP = 0.0 - DOF = 0.0 + CLDFRD = zero + RNTP = zero + DOF = zero ERRQ = 10.0 - RNB = 0.0 - RNT = 0.0 + RNB = zero + RNT = zero TX2 = PRL(KBL) ! - TX1 = (PRL(KD) + PRL(KD1)) * 0.5 - ROR(KD) = CMPOR*TX1 / (TOL(KD)*(1.0+NU*QOL(KD))) + TX1 = (PRL(KD) + PRL(KD1)) * half + ROR(KD) = CMPOR*TX1 / (TOL(KD)*(one+NU*QOL(KD))) ! GMS(KD) = VTP * ROR(KD) ** VTPEXP GMS(KD) = VTP * VTPF(ROR(KD)) ! QRP(KD) = QRMIN ! - TEM = TOL(K) * (1.0 + NU * QOL(K)) - ROR(K+1) = 0.5 * CMPOR * (PRL(K+1)+PRL(K)) / TEM - GMS(K+1) = VTP * VTPF(ROR(K+1)) - QRP(K+1) = QRMIN + TEM = TOL(K) * (one + NU * QOL(K)) + ROR(KP1) = half * CMPOR * (PRL(KP1)+PRL(K)) / TEM + GMS(KP1) = VTP * VTPF(ROR(KP1)) + QRP(KP1) = QRMIN ! kk = kbl DO L=KD1,K - TEM = 0.5 * (TOL(L)+TOL(L-1)) & - & * (1.0 + (0.5*NU) * (QOL(L)+QOL(L-1))) + TEM = half * (TOL(L)+TOL(L-1)) & + & * (one + (half*NU) * (QOL(L)+QOL(L-1))) ROR(L) = CMPOR * PRL(L) / TEM ! GMS(L) = VTP * ROR(L) ** VTPEXP GMS(L) = VTP * VTPF(ROR(L)) QRP(L) = QRMIN - if (buy(l) <= 0.0 .and. kk == KBL) then + if (buy(l) <= zero .and. kk == KBL) then kk = l endif ENDDO @@ -2898,14 +3159,15 @@ SUBROUTINE DDRFT( & ! ! CALL ANGRAD(TX1, ALM, STLA, CTL2, AL2, PI, TLA, TX2, WFN, TX3) - tx1 = 1000.0 + tx1 - prl(k+1) - CALL ANGRAD(TX1, ALM, AL2, TLA, TX2, WFN, TX3) + tx1 = 1000.0 + tx1 - prl(kp1) +! CALL ANGRAD(TX1, ALM, AL2, TLA, TX2, WFN, TX3) + CALL ANGRAD(TX1, ALM, AL2, TLA) ! ! Following Ucla approach for rain profile ! - F2 = 2.0*BB1*ONEBG/(PI*0.2) - WCMIN = SQRT(WC2MIN) - WCBASE = WCMIN + F2 = (BB1+BB1)*ONEBG/(PI*0.2) +! WCMIN = SQRT(WC2MIN) +! WCBASE = WCMIN ! ! del_tla = TLA * 0.2 ! del_tla = TLA * 0.25 @@ -2913,87 +3175,91 @@ SUBROUTINE DDRFT( & TLA = TLA - DEL_TLA ! DO L=KD,K - RNF(L) = 0.0 - RNS(L) = 0.0 - WVL(L) = 0.0 - STLT(L) = 0.0 - GQW(L) = 0.0 + RNF(L) = zero + RNS(L) = zero + STLT(L) = zero + GQW(L) = zero QRP(L) = QRMIN DO N=KD,K - QW(N,L) = 0.0 + QW(N,L) = zero ENDDO ENDDO +! DO L=KD,KP1 +! WVL(L) = zero +! ENDDO ! !-----QW(N,L) = D(W(N)*W(N))/DQR(L) ! KK = KBL - QW(KD,KD) = -QRB(KD) * GMF1 - GHD(KD) = ETA(KD) * ETA(KD) - GQW(KD) = QW(KD,KD) * GHD(KD) - GSD(KD) = ETAI(KD) * ETAI(KD) + QW(KD,KD) = -QRB(KD) * GMF1 + GHD(KD) = ETA(KD) * ETA(KD) + GQW(KD) = QW(KD,KD) * GHD(KD) + GSD(KD) = ETAI(KD) * ETAI(KD) ! - GQW(KK) = - QRB(KK-1) * (GMF1+GMF1) + GQW(KK) = - QRB(KK-1) * (GMF1+GMF1) ! - WCB(KK) = WCBASE * WCBASE + WCB(KK) = WCBASE * WCBASE - TX1 = WCB(KK) - GSD(KK) = 1.0 - GHD(KK) = 1.0 + TX1 = WCB(KK) + GSD(KK) = one + GHD(KK) = one ! - TEM = GMF1 + GMF1 + TEM = GMF1 + GMF1 DO L=KB1,KD1,-1 - GHD(L) = ETA(L) * ETA(L) - GSD(L) = ETAI(L) * ETAI(L) - GQW(L) = - GHD(L) * (QRB(L-1)+QRT(L)) * TEM - QW(L,L) = - QRT(L) * TEM -! - st1 = 0.5 * (eta(l) + eta(l+1)) - TX1 = TX1 + BUY(L) * TEM * (qrb(l)+qrt(l)) * st1 * st1 - WCB(L) = TX1 * GSD(L) + GHD(L) = ETA(L) * ETA(L) + GSD(L) = ETAI(L) * ETAI(L) + GQW(L) = - GHD(L) * (QRB(L-1)+QRT(L)) * TEM + QW(L,L) = - QRT(L) * TEM +! + st1 = half * (eta(l) + eta(l+1)) + TX1 = TX1 + BUY(L) * TEM * (qrb(l)+qrt(l)) * st1 * st1 + WCB(L) = TX1 * GSD(L) ENDDO ! TEM1 = (QRB(KD) + QRT(KD1) + QRT(KD1)) * GMF1 GQW(KD1) = - GHD(KD1) * TEM1 QW(KD1,KD1) = - QRT(KD1) * TEM - st1 = 0.5 * (eta(kd) + eta(kd1)) + st1 = half * (eta(kd) + eta(kd1)) WCB(KD) = (TX1 + BUY(KD)*TEM*qrb(kd)*st1*st1) * GSD(KD) ! DO L=KD1,KBL DO N=KD,L-1 - QW(N,L) = GQW(L) * GSD(N) + QW(N,L) = GQW(L) * GSD(N) ENDDO ENDDO - QW(KBL,KBL) = 0.0 + QW(KBL,KBL) = zero ! do ntla=1,numtla ! ! if (errq < 1.0 .or. tla > 45.0) cycle if (errq < 0.1 .or. tla > 45.0) cycle ! - tla = tla + del_tla + tla = tla + del_tla STLA = SIN(TLA*PI/180.0) - CTL2 = 1.0 - STLA * STLA + CTL2 = one - STLA * STLA ! -! if (lprnt) print *,' tla=',tla,' al2=',al2,' ptop=' +! if (lprnt) write(0,*)' tla=',tla,' al2=',al2,' ptop=' ! &,0.5*(prl(kd)+prl(kd1)),' ntla=',ntla,' f2=',f2,' stla=',stla -! if (lprnt) print *,' buy=',(buy(l),l=kd,kbl) +! if (lprnt) write(0,*)' buy=',(buy(l),l=kd,kbl) ! STLA = F2 * STLA * AL2 CTL2 = DD1 * CTL2 CTL3 = 0.1364 * CTL2 ! DO L=KD,K - RNF(L) = 0.0 - WVL(L) = 0.0 - STLT(L) = 0.0 - QRP(L) = QRMIN + RNF(L) = zero + STLT(L) = zero + QRP(L) = QRMIN + ENDDO + DO L=KD,KP1 + WVL(L) = zero ENDDO - WVL(KBL) = WCBASE - STLT(KBL) = 1.0 / WCBASE + WVL(KBL) = WCBASE + STLT(KBL) = one / WCBASE ! - DO L=KD,K+1 + DO L=KD,KP1 DO N=KD,K - AA(N,L) = 0.0 + AA(N,L) = zero ENDDO ENDDO ! @@ -3001,44 +3267,48 @@ SUBROUTINE DDRFT( & ! DO ITR=1,ITRMU ! Rain Profile Iteration starts! IF (.NOT. SKPUP) THEN - wvlo = wvl +! wvlu = wvl ! !-----CALCULATING THE VERTICAL VELOCITY ! - TX1 = 0.0 - QRPI(KBL) = 1.0 / QRP(KBL) + TX1 = zero + QRPI(KBL) = one / QRP(KBL) DO L=KB1,KD,-1 - TX1 = TX1 + QRP(L+1) * GQW(L+1) - ST1 = WCB(L) + QW(L,L) * QRP(L) & - & + TX1 * GSD(L) - if (st1 > wc2min) then -! WVL(L) = SQRT(ST1) - WVL(L) = 0.5 * (SQRT(ST1) + WVL(L)) -! if (itr == 1) wvl(l) = wvl(l) * 0.25 + TX1 = TX1 + QRP(L+1)*GQW(L+1) + ST1 = WCB(L) + QW(L,L)*QRP(L) + TX1*GSD(L) +! if (st1 > wc2min) then + if (st1 > zero) then +! if (lprnt) write(0,*)' l=',l,' st1=',st1,' wvl=',wvl(l) + WVL(L) = max(ddunc1*SQRT(ST1) + ddunc2*WVL(L), wcmin) +! WVL(L) = SQRT(ST1) +! WVL(L) = max(half * (SQRT(ST1) + WVL(L)), wcmin) +! qrp(l) = half*((wvl(l)*wvl(l)-wcb(l)-tx1*gsd(l))/qw(l,l)& +! & + qrp(l)) else -! if (lprnt) print *,' l=',l,' st1=',st1,' wcb=',wcb(l),' qw=' -! &,qw(l,l),' qrp=',qrp(l),' tx1=',tx1,' gsd=',gsd(l),' ite=',itr +! if (lprnt) write(0,*)' l=',l,' st1=',st1,' wcb=',wcb(l),' qw=' +! &,qw(l,l),' qrp=',qrp(l),' tx1=',tx1,' gsd=',gsd(l),' itr=',itr +! &,' wvl=',wvl(l) ! wvl(l) = 0.5*(wcmin+wvl(l)) - wvl(l) = 0.5*(wvl(l) + wvl(l+1)) - qrp(l) = 0.5*((wvl(l)*wvl(l)-wcb(l)-tx1*gsd(l))/qw(l,l) & - & + qrp(l)) -!! wvl(l) = 0.5 * (wvl(l) + wvl(l+1)) +! wvl(l) = max(half*(wvl(l) + wvl(l+1)), wcmin) + wvl(l) = max(wvl(l),wcmin) + qrp(l) = (wvl(l)*wvl(l) - wcb(l) - tx1*gsd(l))/qw(l,l) +! qrp(l) = half*((wvl(l)*wvl(l)-wcb(l)-tx1*gsd(l))/qw(l,l)& +! & + qrp(l)) endif -! wvl(l) = 0.5 * (wvl(l) + wvlo(l)) -! WVL(L) = SQRT(MAX(ST1,WC2MIN)) - wvl(l) = max(wvl(l), wcbase) - STLT(L) = 1.0 / WVL(L) - QRPI(L) = 1.0 / QRP(L) + qrp(l) = max(qrp(l), qrmin) + + STLT(L) = one / WVL(L) + QRPI(L) = one / QRP(L) ENDDO ! ! if (lprnt) then -! print *,' ITR=',ITR,' ITRMU=',ITRMU -! print *,' WVL=',(WVL(L),L=KD,KBL) -! print *,' qrp=',(qrp(L),L=KD,KBL) -! print *,' qrpi=',(qrpi(L),L=KD,KBL) -! print *,' rnf=',(rnf(L),L=KD,KBL) +! write(0,*) ' ITR=',ITR,' ITRMU=',ITRMU,' kd=',kd,' kbl=',kbl +! write(0,*) ' WVL=',(WVL(L),L=KD,KBL) +! write(0,*) ' qrp=',(qrp(L),L=KD,KBL) +! write(0,*) ' qrpi=',(qrpi(L),L=KD,KBL) +! write(0,*) ' rnf=',(rnf(L),L=KD,KBL) ! endif ! !-----CALCULATING TRW, VRW AND OF @@ -3048,26 +3318,26 @@ SUBROUTINE DDRFT( & TRW(1) = ETA(KD) * QRP(KD) * STLT(KD) TX6 = TRW(1) * VT(1) VRW(1) = F3*WVL(KD) - CTL2*VT(1) - BUD(KD) = STLA * TX6 * QRB(KD) * 0.5 + BUD(KD) = STLA * TX6 * QRB(KD) * half RNF(KD) = BUD(KD) DOF = 1.1364 * BUD(KD) * QRPI(KD) DOFW = -BUD(KD) * STLT(KD) ! RNT = TRW(1) * VRW(1) - TX2 = 0.0 - TX4 = 0.0 + TX2 = zero + TX4 = zero RNB = RNT - TX1 = 0.5 - TX8 = 0.0 + TX1 = half + TX8 = zero ! - IF (RNT >= 0.0) THEN + IF (RNT >= zero) THEN TX3 = (RNT-CTL3*TX6) * QRPI(KD) TX5 = CTL2 * TX6 * STLT(KD) ELSE - TX3 = 0.0 - TX5 = 0.0 - RNT = 0.0 - RNB = 0.0 + TX3 = zero + TX5 = zero + RNT = zero + RNB = zero ENDIF ! DO L=KD1,KB1 @@ -3093,19 +3363,19 @@ SUBROUTINE DDRFT( & TEM3 = VRW(1) + VRW(2) TEM4 = TRW(1) + TRW(2) ! - TX6 = .25 * TEM3 * TEM4 + TX6 = pt25 * TEM3 * TEM4 TEM4 = TEM4 * CTL3 ! !-----BY QR ABOVE ! -! TEM1 = .25*(TRW(1)*TEM3 - TEM4*VT(1))*TX7 - TEM1 = .25*(TRW(1)*TEM3 - TEM4*VT(1))*QRPI(LL) - ST1 = .25*(TRW(1)*(CTL2*VT(1)-VRW(2)) & - & * STLT(LL) + F3*TRW(2)) +! TEM1 = pt25*(TRW(1)*TEM3 - TEM4*VT(1))*TX7 + TEM1 = pt25*(TRW(1)*TEM3 - TEM4*VT(1))*QRPI(LL) + ST1 = pt25*(TRW(1)*(CTL2*VT(1)-VRW(2)) & + & * STLT(LL) + F3*TRW(2)) !-----BY QR BELOW - TEM2 = .25*(TRW(2)*TEM3 - TEM4*VT(2))*QRPI(L) - ST2 = .25*(TRW(2)*(CTL2*VT(2)-VRW(1)) & - & * STLT(L) + F3*TRW(1)) + TEM2 = pt25*(TRW(2)*TEM3 - TEM4*VT(2))*QRPI(L) + ST2 = pt25*(TRW(2)*(CTL2*VT(2)-VRW(1)) & + & * STLT(L) + F3*TRW(1)) ! ! From top to the KBL-2 layer ! @@ -3126,22 +3396,22 @@ SUBROUTINE DDRFT( & TRW(1) = TRW(2) VRW(1) = VRW(2) ! - IF (WVL(KTEM) == WCMIN) WA(1) = 0.0 - IF (WVL(LL) == WCMIN) WA(2) = 0.0 - IF (WVL(L) == WCMIN) WA(3) = 0.0 + IF (WVL(KTEM) == WCMIN) WA(1) = zero + IF (WVL(LL) == WCMIN) WA(2) = zero + IF (WVL(L) == WCMIN) WA(3) = zero DO N=KTEM,KBL AA(LL,N) = (WA(1)*QW(KTEM,N) * STLT(KTEM) & & + WA(2)*QW(LL,N) * STLT(LL) & - & + WA(3)*QW(L,N) * STLT(L) ) * 0.5 + & + WA(3)*QW(L,N) * STLT(L) ) * half ENDDO AA(LL,KTEM) = AA(LL,KTEM) + QA(1) AA(LL,LL) = AA(LL,LL) + QA(2) AA(LL,L) = AA(LL,L) + QA(3) - BUD(LL) = (TX8 + RNN(LL)) * 0.5 & + BUD(LL) = (TX8 + RNN(LL)) * half & & - RNB + TX6 - BUD(LL) AA(LL,KBL+1) = BUD(LL) RNB = TX6 - TX1 = 1.0 + TX1 = one TX8 = RNN(LL) ENDDO L = KBL @@ -3163,18 +3433,18 @@ SUBROUTINE DDRFT( & TEM3 = VRW(1) + VRW(2) TEM4 = TRW(1) + TRW(2) ! - TX6 = .25 * TEM3 * TEM4 + TX6 = pt25 * TEM3 * TEM4 TEM4 = TEM4 * CTL3 ! !-----BY QR ABOVE ! - TEM1 = .25*(TRW(1)*TEM3 - TEM4*VT(1))*QRPI(LL) - ST1 = .25*(TRW(1)*(CTL2*VT(1)-VRW(2)) & - & * STLT(LL) + F3*TRW(2)) + TEM1 = pt25*(TRW(1)*TEM3 - TEM4*VT(1))*QRPI(LL) + ST1 = pt25*(TRW(1)*(CTL2*VT(1)-VRW(2)) & + & * STLT(LL) + F3*TRW(2)) !-----BY QR BELOW - TEM2 = .25*(TRW(2)*TEM3 - TEM4*VT(2))*QRPI(L) - ST2 = .25*(TRW(2)*(CTL2*VT(2)-VRW(1)) & - & * STLT(L) + F3*TRW(1)) + TEM2 = pt25*(TRW(2)*TEM3 - TEM4*VT(2))*QRPI(L) + ST2 = pt25*(TRW(2)*(CTL2*VT(2)-VRW(1)) & + & * STLT(L) + F3*TRW(1)) ! ! For the layer next to the top of the boundary layer ! @@ -3193,22 +3463,22 @@ SUBROUTINE DDRFT( & ! IDW = MAX(L-2, KD) ! - IF (WVL(IDW) == WCMIN) WA(1) = 0.0 - IF (WVL(LL) == WCMIN) WA(2) = 0.0 - IF (WVL(L) == WCMIN) WA(3) = 0.0 + IF (WVL(IDW) == WCMIN) WA(1) = zero + IF (WVL(LL) == WCMIN) WA(2) = zero + IF (WVL(L) == WCMIN) WA(3) = zero ! KK = IDW DO N=KK,L AA(LL,N) = (WA(1)*QW(KK,N) * STLT(KK) & & + WA(2)*QW(LL,N) * STLT(LL) & - & + WA(3)*QW(L,N) * STLT(L) ) * 0.5 + & + WA(3)*QW(L,N) * STLT(L) ) * half ENDDO ! AA(LL,IDW) = AA(LL,IDW) + QA(1) AA(LL,LL) = AA(LL,LL) + QA(2) AA(LL,L) = AA(LL,L) + QA(3) - BUD(LL) = (TX8+RNN(LL)) * 0.5 - RNB + TX6 - BUD(LL) + BUD(LL) = (TX8+RNN(LL)) * half - RNB + TX6 - BUD(LL) ! AA(LL,L+1) = BUD(LL) ! @@ -3216,41 +3486,41 @@ SUBROUTINE DDRFT( & ! ! For the top of the boundary layer ! - IF (RNB < 0.0) THEN + IF (RNB < zero) THEN KK = KBL TEM = VT(2) * TRW(2) QA(2) = (RNB - CTL3*TEM) * QRPI(KK) WA(2) = CTL2 * TEM * STLT(KK) ELSE - RNB = 0.0 - QA(2) = 0.0 - WA(2) = 0.0 + RNB = zero + QA(2) = zero + WA(2) = zero ENDIF ! QA(1) = TX2 QA(2) = DOF + TX3 - QA(2) - QA(3) = 0.0 + QA(3) = zero ! WA(1) = TX4 WA(2) = DOFW + TX5 - WA(2) - WA(3) = 0.0 + WA(3) = zero ! KK = KBL - IF (WVL(KK-1) == WCMIN) WA(1) = 0.0 - IF (WVL(KK) == WCMIN) WA(2) = 0.0 + IF (WVL(KK-1) == WCMIN) WA(1) = zero + IF (WVL(KK) == WCMIN) WA(2) = zero ! DO II=1,2 N = KK + II - 2 AA(KK,N) = (WA(1)*QW(KK-1,N) * STLT(KK-1) & - & + WA(2)*QW(KK,N) * STLT(KK)) * 0.5 + & + WA(2)*QW(KK,N) * STLT(KK)) * half ENDDO - FAC = 0.5 + FAC = half LL = KBL L = LL + 1 LM1 = LL - 1 AA(LL,LM1) = AA(LL,LM1) + QA(1) AA(LL,LL) = AA(LL,LL) + QA(2) - BUD(LL) = 0.5*RNN(LM1) - TX6 + RNB - BUD(LL) + BUD(LL) = half*RNN(LM1) - TX6 + RNB - BUD(LL) AA(LL,LL+1) = BUD(LL) ! !-----SOLVING THE BUDGET EQUATIONS FOR DQR @@ -3277,31 +3547,31 @@ SUBROUTINE DDRFT( & KK1 = KK + 1 AA(KK,KK1) = AA(KK,KK1) / AA(KK,KK) ! Qr correction ! TX2 = ABS(AA(KK,KK1)) * QRPI(KK) ! Error Measure ! -! if (lprnt) print *,' tx2a=',tx2,' aa1=',aa(kk,kk1) +! if (lprnt) write(0,*) ' tx2a=',tx2,' aa1=',aa(kk,kk1) ! &,' qrpi=',qrpi(kk) ! KK = KBL + 1 DO L=KB1,KD,-1 LP1 = L + 1 - TX1 = 0.0 + TX1 = zero DO N=LP1,KBL TX1 = TX1 + AA(L,N) * AA(N,KK) ENDDO AA(L,KK) = (AA(L,KK) - TX1) / AA(L,L) ! Qr correction ! TX2 = MAX(TX2, ABS(AA(L,KK))*QRPI(L)) ! Error Measure ! -! if (lprnt) print *,' tx2b=',tx2,' aa1=',aa(l,kk) +! if (lprnt) write(0,*)' tx2b=',tx2,' aa1=',aa(l,kk) ! &,' qrpi=',qrpi(l),' L=',L ENDDO ! ! tem = 0.5 - if (tx2 > 1.0 .and. abs(errq-tx2) > 0.1) then - tem = 0.5 + if (tx2 > one .and. abs(errq-tx2) > 0.1) then + tem = half !! elseif (tx2 < 0.1) then !! tem = 1.2 else - tem = 1.0 + tem = one endif ! DO L=KD,KBL @@ -3309,7 +3579,7 @@ SUBROUTINE DDRFT( & QRP(L) = MAX(QRP(L)+AA(L,KBL+1)*tem, QRMIN) ENDDO ! -! if (lprnt) print *,' itr=',itr,' tx2=',tx2 +! if (lprnt) write(0,*)' itr=',itr,' tx2=',tx2 IF (ITR < ITRMIN) THEN TEM = ABS(ERRQ-TX2) @@ -3317,9 +3587,9 @@ SUBROUTINE DDRFT( & ERRQ = TX2 ! Further iteration ! ELSE SKPUP = .TRUE. ! Converges ! - ERRQ = 0.0 ! Rain profile exists! -! if (lprnt) print *,' here1',' tem=',tem,' tx2=',tx2,' errmi2=', -! *errmi2,' errmin=',errmin + ERRQ = zero ! Rain profile exists! +! if (lprnt) write(0,*)' here1',' tem=',tem,' tx2=',tx2,' errmi2=', +! &errmi2,' errmin=',errmin ENDIF ELSE TEM = ERRQ - TX2 @@ -3327,38 +3597,38 @@ SUBROUTINE DDRFT( & IF (TEM < ZERO .AND. ERRQ > 0.5) THEN ! IF (TEM < ZERO .and. & ! & (ntla < numtla .or. ERRQ > 0.5)) THEN -! if (lprnt) print *,' tx2=',tx2,' errq=',errq,' tem=',tem +! if (lprnt) write(0,*)' tx2=',tx2,' errq=',errq,' tem=',tem SKPUP = .TRUE. ! No convergence ! ERRQ = 10.0 ! No rain profile! !!!! ELSEIF (ABS(TEM) < ERRMI2 .OR. TX2 < ERRMIN) THEN ELSEIF (TX2 < ERRMIN) THEN SKPUP = .TRUE. ! Converges ! - ERRQ = 0.0 ! Rain profile exists! -! if (lprnt) print *,' here2' + ERRQ = zero ! Rain profile exists! +! if (lprnt) write(0,*)' here2' elseif (tem < zero .and. errq < 0.1) then skpup = .true. ! if (ntla == numtla .or. tem > -0.003) then - errq = 0.0 + errq = zero ! else ! errq = 10.0 ! endif ELSE ERRQ = TX2 ! Further iteration ! -! if (lprnt) print *,' itr=',itr,' errq=',errq +! if (lprnt) write(0,*)' itr=',itr,' errq=',errq ! if (itr == itrmu .and. ERRQ > ERRMIN*10 & ! & .and. ntla == 1) ERRQ = 10.0 ENDIF ENDIF ! -! if (lprnt) print *,' ERRQ=',ERRQ +! if (lprnt) write(0,*)' ERRQ=',ERRQ ENDIF ! SKPUP ENDIF! ! - ENDDO ! End of the ITR Loop!! + ENDDO ! End of the ITR Loop!! ! ! if(lprnt) then -! print *,' QRP=',(QRP(L),L=KD,KBL) -! print *,'RNF=',(RNF(L),L=KD,KBL),' RNT=',RNT,' RNB=',RNB +! write(0,*)' QRP=',(QRP(L),L=KD,KBL) +! write(0,*)'RNF=',(RNF(L),L=KD,KBL),' RNT=',RNT,' RNB=',RNB ! &,' errq=',errq ! endif ! @@ -3371,124 +3641,128 @@ SUBROUTINE DDRFT( & ELSE DDFT = .FALSE. ENDIF + + enddo ! End of ntla loop ! ! Caution !! Below is an adjustment to rain flux to maintain ! conservation of precip! ! - IF (DDFT) THEN - TX1 = 0.0 + IF (DDFT) THEN + TX1 = zero + DO L=KD,KB1 + TX1 = TX1 + RNF(L) + ENDDO +! if (lprnt) write(0,*)' tx1+rnt+rnb=',tx1+rnt+rnb, ' train=',train + TX1 = TRAIN / (TX1+RNT+RNB) +! if (lprnt) write(0,*)' tx1= ', tx1 + IF (ABS(TX1-one) < 0.2) THEN + RNT = MAX(RNT*TX1,ZERO) + RNB = RNB * TX1 DO L=KD,KB1 - TX1 = TX1 + RNF(L) + RNF(L) = RNF(L) * TX1 ENDDO -! if (lprnt) print *,' tx1+rnt+rnb=',tx1+rnt+rnb, ' train=',train - TX1 = TRAIN / (TX1+RNT+RNB) - IF (ABS(TX1-1.0) < 0.2) THEN - RNT = MAX(RNT*TX1,ZERO) - RNB = RNB * TX1 - ELSE - DDFT = .FALSE. - ERRQ = 10.0 - ENDIF +! rain flux adjustment is over + +! if (lprnt) write(0,*)' TRAIN=',TRAIN +! if (lprnt) write(0,*)' RNF=',RNF + + ELSE + DDFT = .FALSE. + ERRQ = 10.0 ENDIF - enddo ! End of ntla loop + ENDIF ! - DOF = 0.0 - IF (.NOT. DDFT) RETURN ! Rain profile did not converge! + DOF = zero + IF (.NOT. DDFT) then + wvlu(kd:kp1) = zero + RETURN ! Rain profile did not converge! + ! No down draft for this case - rerurn + ! ------------------------------------ ! + else ! rain profile converged - do downdraft calculation + ! ------------------------------------------------ - DO L=KD,KB1 - RNF(L) = RNF(L) * TX1 + wvlu(kd:kp1) = wvl(kd:kp1) - ENDDO -! if (lprnt) print *,' TRAIN=',TRAIN -! if (lprnt) print *,' RNF=',RNF -! -! Adjustment is over +! if (lprnt) write(0,*)' in ddrft kd=',kd,'wvlu=',wvlu(kd:kp1) ! -! Downdraft +! Downdraft calculation begins +! ---------------------------- ! - DO L=KD,K - WCB(L) = 0.0 - ENDDO -! - SKPDD = .NOT. DDFT -! - ERRQ = 10.0 - IF (.NOT. SKPDD) THEN + DO L=KD,K + WCB(L) = zero + ENDDO ! -! Calculate Downdraft Properties + ERRQ = 10.0 ! - KK = MAX(KB1,KD1) DO L=KK,K STLT(L) = STLT(L-1) ENDDO - TEM1 = 1.0 / BB1 + TEM = stla / BB1 ! DO L=KD,K - IF (L .LE. KBL) THEN - TEM = STLA * TEM1 + IF (L <= KBL) THEN STLT(L) = ETA(L) * STLT(L) * TEM / ROR(L) ELSE - STLT(L) = 0.0 + STLT(L) = zero ENDIF ENDDO -! if (lprnt) print *,' STLT=',stlt - - rsum1 = 0.0 - rsum2 = 0.0 +! if (lprnt) write(0,*)' STLT=',stlt + rsum1 = zero + rsum2 = zero ! IDN = 99 - DO L=KD,K+1 - ETD(L) = 0.0 - WVL(L) = 0.0 -! QRP(L) = 0.0 + DO L=KD,KP1 + ETD(L) = zero + WVL(L) = zero +! QRP(L) = zero ENDDO DO L=KD,K - EVP(L) = 0.0 - BUY(L) = 0.0 - QRP(L+1) = 0.0 + EVP(L) = zero + BUY(L) = zero + QRP(L+1) = zero ENDDO HOD(KD) = HOL(KD) QOD(KD) = QOL(KD) - TX1 = 0.0 ! sigma at the top + TX1 = zero !!! TX1 = STLT(KD)*QRB(KD)*ONE ! sigma at the top ! TX1 = MIN(STLT(KD)*QRB(KD)*ONE, ONE) ! sigma at the top ! TX1 = MIN(STLT(KD)*QRB(KD)*0.5, ONE) ! sigma at the top - RNTP = 0.0 + RNTP = zero TX5 = TX1 - QA(1) = 0.0 -! if(lprnt) print *,' stlt=',stlt(kd),' qrb=',qrb(kd) + QA(1) = zero +! if(lprnt) write(0,*)' stlt=',stlt(kd),' qrb=',qrb(kd) ! *,' tx1=',tx1,' ror=',ror(kd),' gms=',gms(kd),' rpart=',rpart ! *,' rnt=',rnt ! ! Here we assume RPART of detrained rain RNT goes to Pd ! - IF (RNT > 0.0) THEN - if (TX1 > 0.0) THEN + IF (RNT > zero) THEN + if (TX1 > zero) THEN QRP(KD) = (RPART*RNT / (ROR(KD)*TX1*GMS(KD))) & - & ** (1.0/1.1364) - else - tx1 = RPART*RNT / (ROR(KD)*GMS(KD)*QRP(KD)**1.1364) - endif - RNTP = (1.0 - RPART) * RNT - BUY(KD) = - ROR(KD) * TX1 * QRP(KD) + & ** (one/1.1364) + else + tx1 = RPART*RNT / (ROR(KD)*GMS(KD)*QRP(KD)**1.1364) + endif + RNTP = (one - RPART) * RNT + BUY(KD) = - ROR(KD) * TX1 * QRP(KD) ELSE - QRP(KD) = 0.0 + QRP(KD) = zero ENDIF ! -! L-loop for the downdraft iteration from KD1 to K+1 (bottom surface) +! L-loop for the downdraft iteration from KD1 to KP1 (bottom surface) ! -! BUD(KD) = ROR(KD) - idnm = 1 - DO L=KD1,K+1 +! BUD(KD) = ROR(KD) + idnm = 1 + DO L=KD1,KP1 - QA(1) = 0.0 + QA(1) = zero ddlgk = idn(idnm) == 99 if (.not. ddlgk) cycle IF (L <= K) THEN - ST1 = 1.0 - ALFIND(L) + ST1 = one - ALFIND(L) WA(1) = ALFIND(L)*HOL(L-1) + ST1*HOL(L) WA(2) = ALFIND(L)*QOL(L-1) + ST1*QOL(L) WA(3) = ALFIND(L)*TOL(L-1) + ST1*TOL(L) @@ -3502,10 +3776,10 @@ SUBROUTINE DDRFT( & QA(3) = QST(K) ENDIF ! - FAC = 2.0 - IF (L == KD1) FAC = 1.0 + FAC = two + IF (L == KD1) FAC = one - FACG = FAC * 0.5 * GMF5 ! 12/17/97 + FACG = FAC * half * GMF5 ! 12/17/97 ! ! DDLGK = IDN(idnm) == 99 BUD(KD) = ROR(L) @@ -3519,7 +3793,7 @@ SUBROUTINE DDRFT( & ! VT(1) = GMS(L-1) * QRP(L-1) ** 0.1364 VT(1) = GMS(L-1) * QRPF(QRP(L-1)) RNT = ROR(L-1) * (WVL(L-1)+VT(1))*QRP(L-1) -! if(lprnt) print *,' l=',l,' qa=',qa(1), ' tx1RNT=',RNT*tx1, +! if(lprnt) write(0,*)' l=',l,' qa=',qa(1), ' tx1RNT=',RNT*tx1, ! *' wvl=',wvl(l-1) ! *,' qrp=',qrp(l-1),' tx5=',tx5,' tx1=',tx1,' rnt=',rnt @@ -3529,14 +3803,14 @@ SUBROUTINE DDRFT( & TEM = MAX(ALM,ONE_M6) * MAX(ETA(L), ONE) ! TEM = MAX(ALM, 1.0E-5) * MAX(ETA(L), 1.0) TRW(1) = PICON*TEM*(QRB(L-1)+QRT(L-1)) - TRW(2) = 1.0 / TRW(1) + TRW(2) = one / TRW(1) ! - VRW(1) = 0.5 * (GAM(L-1) + GAM(L)) - VRW(2) = 1.0 / (VRW(1) + VRW(1)) + VRW(1) = half * (GAM(L-1) + GAM(L)) + VRW(2) = one / (VRW(1) + VRW(1)) ! TX4 = (QRT(L-1)+QRB(L-1))*(ONEBG*FAC*500.00*EKNOB) ! - DOFW = 1.0 / (WA(3) * (1.0 + NU*WA(2))) ! 1.0 / TVbar! + DOFW = one / (WA(3) * (one + NU*WA(2))) ! 1.0 / TVbar! ! ETD(L) = ETD(L-1) HOD(L) = HOD(L-1) @@ -3546,32 +3820,32 @@ SUBROUTINE DDRFT( & ! IF (L <= KBL) THEN - TX3 = STLT(L-1) * QRT(L-1) * (0.5*FAC) - TX8 = STLT(L) * QRB(L-1) * (0.5*FAC) + TX3 = STLT(L-1) * QRT(L-1) * (half*FAC) + TX8 = STLT(L) * QRB(L-1) * (half*FAC) TX9 = TX8 + TX3 ELSE - TX3 = 0.0 - TX8 = 0.0 - TX9 = 0.0 + TX3 = zero + TX8 = zero + TX9 = zero ENDIF ! TEM = WVL(L-1) + VT(1) - IF (TEM > 0.0) THEN - TEM1 = 1.0 / (TEM*ROR(L-1)) + IF (TEM > zero) THEN + TEM1 = one / (TEM*ROR(L-1)) TX3 = VT(1) * TEM1 * ROR(L-1) * TX3 TX6 = TX1 * TEM1 ELSE - TX6 = 1.0 + TX6 = one ENDIF ! ENDIF ! IF (L == KD1) THEN - IF (RNT > 0.0) THEN + IF (RNT > zero) THEN TEM = MAX(QRP(L-1),QRP(L)) WVL(L) = TX1 * TEM * QRB(L-1)*(FACG*5.0) ENDIF WVL(L) = MAX(ONE_M2, WVL(L)) - TRW(1) = TRW(1) * 0.5 + TRW(1) = TRW(1) * half TRW(2) = TRW(2) + TRW(2) ELSE IF (DDLGK) EVP(L-1) = EVP(L-2) @@ -3582,58 +3856,58 @@ SUBROUTINE DDRFT( & IF (L < IDH) THEN - ETD(L) = 0.0 + ETD(L) = zero HOD(L) = WA(1) QOD(L) = WA(2) - EVP(L-1) = 0.0 - WVL(L) = 0.0 - QRP(L) = 0.0 - BUY(L) = 0.0 + EVP(L-1) = zero + WVL(L) = zero + QRP(L) = zero + BUY(L) = zero TX5 = TX9 - ERRQ = 0.0 + ERRQ = zero RNTP = RNTP + RNT * TX1 - RNT = 0.0 - WCB(L-1) = 0.0 + RNT = zero + WCB(L-1) = zero ENDIF ! BUD(KD) = ROR(L) ! ! Iteration loop for a given level L begins ! -! if (lprnt) print *,' tx8=',tx8,' tx9=',tx9,' tx5=',tx5 -! &, ' tx1=',tx1 +! if (lprnt) write(0,*)' tx8=',tx8,' tx9=',tx9,' tx5=',tx5 +! &, ' tx1=',tx1 DO ITR=1,ITRMD ! ! cnvflg = DDLGK .AND. (ERRQ > ERRMIN) cnvflg = ERRQ > ERRMIN IF (cnvflg) THEN ! -! VT(1) = GMS(L) * QRP(L) ** 0.1364 - VT(1) = GMS(L) * QRPF(QRP(L)) - TEM = WVL(L) + VT(1) +! VT(1) = GMS(L) * QRP(L) ** 0.1364 + VT(1) = GMS(L) * QRPF(QRP(L)) + TEM = WVL(L) + VT(1) ! - IF (TEM > 0.0) THEN - ST1 = ROR(L) * TEM * QRP(L) + RNT - IF (ST1 /= 0.0) ST1 = 2.0 * EVP(L-1) / ST1 - TEM1 = 1.0 / (TEM*ROR(L)) - TEM2 = VT(1) * TEM1 * ROR(L) * TX8 + IF (TEM > zero) THEN + ST1 = ROR(L) * TEM * QRP(L) + RNT + IF (ST1 /= zero) ST1 = two * EVP(L-1) / ST1 + TEM1 = one / (TEM*ROR(L)) + TEM2 = VT(1) * TEM1 * ROR(L) * TX8 ELSE - TEM1 = 0.0 - TEM2 = TX8 - ST1 = 0.0 + TEM1 = zero + TEM2 = TX8 + ST1 = zero ENDIF -! if (lprnt) print *,' st1=',st1,' tem=',tem,' ror=',ror(l) +! if (lprnt) write(0,*)' st1=',st1,' tem=',tem,' ror=',ror(l) ! &,' qrp=',qrp(l),' rnt=',rnt,' ror1=',ror(l-1),' wvl=',wvl(l) ! &,' wvl1=',wvl(l-1),' tem2=',tem2,' vt=',vt(1),' tx3=',tx3 ! st2 = tx5 TEM = ROR(L)*WVL(L) - ROR(L-1)*WVL(L-1) - if (tem > 0.0) then - TX5 = (TX1 - ST1 + TEM2 + TX3)/(1.0+tem*tem1) + if (tem > zero) then + TX5 = (TX1 - ST1 + TEM2 + TX3)/(one+tem*tem1) else TX5 = TX1 - tem*tx6 - ST1 + TEM2 + TX3 endif TX5 = MAX(TX5,ZERO) - tx5 = 0.5 * (tx5 + st2) + tx5 = half * (tx5 + st2) ! ! qqq = 1.0 + tem * tem1 * (1.0 - sialf) ! @@ -3643,13 +3917,13 @@ SUBROUTINE DDRFT( & ! TX5 = (TX1 - tem*tx6 - ST1 + TEM2 + TX3) ! endif ! -! if(lprnt) print *,' tx51=',tx5,' tx1=',tx1,' st1=',st1,' tem2=' +! if(lprnt) write(0,*)' tx51=',tx5,' tx1=',tx1,' st1=',st1,' tem2=' ! if(tx5 <= 0.0 .and. l > kd+2) -! * print *,' tx51=',tx5,' tx1=',tx1,' st1=',st1,' tem2=' +! & write(0,*)' tx51=',tx5,' tx1=',tx1,' st1=',st1,' tem2=' ! *,tem2,' tx3=',tx3,' tem=',tem,' tem1=',tem1,' wvl=',wvl(l-1), ! &wvl(l),' l=',l,' itr=',itr,' evp=',evp(l-1),' vt=',vt(1) ! *,' qrp=',qrp(l),' rnt=',rnt,' kd=',kd -! if (lprnt) print *,' etd=',etd(l),' wvl=',wvl(l) +! if (lprnt) write(0,*)' etd=',etd(l),' wvl=',wvl(l) ! &,' trw=',trw(1),trw(2),' ror=',ror(l),' wa=',wa @@ -3657,7 +3931,7 @@ SUBROUTINE DDRFT( & TEM1 = ETD(L) ETD(L) = ROR(L) * TX5 * MAX(WVL(L),ZERO) ! - if (etd(l) > 0.0) etd(l) = 0.5 * (etd(l) + tem1) + if (etd(l) > zero) etd(l) = half * (etd(l) + tem1) ! DEL_ETA = ETD(L) - ETD(L-1) @@ -3677,37 +3951,35 @@ SUBROUTINE DDRFT( & TEM1 = SQRT(MAX((tem+DEL_ETA)*(tem-DEL_ETA),ZERO)) ! TEM1 = SQRT(MAX((TRW(1)+DEL_ETA)*(TRW(1)-DEL_ETA),0.0)) - EDZ = (0.5 + ASIN(TEM2)*PIINV)*DEL_ETA + TEM1*PIINV + EDZ = (half + ASIN(TEM2)*PIINV)*DEL_ETA + TEM1*PIINV DDZ = EDZ - DEL_ETA WCB(L-1) = ETD(L) + DDZ ! TEM1 = HOD(L) - IF (DEL_ETA > 0.0) THEN - QQQ = 1.0 / (ETD(L) + DDZ) + IF (DEL_ETA > zero) THEN + QQQ = one / (ETD(L) + DDZ) HOD(L) = (ETD(L-1)*HOD(L-1) + DEL_ETA*HOL(L-1) & & + DDZ*WA(1)) * QQQ QOD(L) = (ETD(L-1)*QOD(L-1) + DEL_ETA*QOL(L-1) & & + DDZ*WA(2)) * QQQ - ELSEif((ETD(L-1) + EDZ) > 0.0) then - QQQ = 1.0 / (ETD(L-1) + EDZ) + ELSEif((ETD(L-1) + EDZ) > zero) then + QQQ = one / (ETD(L-1) + EDZ) HOD(L) = (ETD(L-1)*HOD(L-1) + EDZ*WA(1)) * QQQ QOD(L) = (ETD(L-1)*QOD(L-1) + EDZ*WA(2)) * QQQ ENDIF ERRH = HOD(L) - TEM1 ERRQ = ABS(ERRH/HOD(L)) + ABS(ERRE/MAX(ETD(L),ONE_M5)) -! if (lprnt) print *,' ERRQP=',errq,' errh=',errh,' hod=',hod(l) +! if (lprnt) write(0,*)' ERRQP=',errq,' errh=',errh,' hod=',hod(l) ! &,' erre=',erre,' etd=',etd(l),' del_eta=',del_eta DOF = DDZ VT(2) = QQQ - ! DDZ = DOF TEM4 = QOD(L) TEM1 = VRW(1) ! - QHS = QA(3) + 0.5 * (GAF(L-1)+GAF(L)) & - & * (HOD(L)-QA(2)) + QHS = QA(3) + half * (GAF(L-1)+GAF(L)) * (HOD(L)-QA(2)) ! ! First iteration ! ! @@ -3718,12 +3990,11 @@ SUBROUTINE DDRFT( & ! CE = TEM6 * ST2 / ((5.4E5*ST2 + 2.55E6)*(ETD(L)+DDZ)) ! - TEM2 = - ((1.0+TEM1)*(QHS+CE) + TEM1*QOD(L)) - TEM3 = (1.0 + TEM1) * QHS * (QOD(L)+CE) - TEM = MAX(TEM2*TEM2 - 4.0*TEM1*TEM3,ZERO) + TEM2 = - ((one+TEM1)*(QHS+CE) + TEM1*QOD(L)) + TEM3 = (one + TEM1) * QHS * (QOD(L)+CE) + TEM = MAX(TEM2*TEM2 - four*TEM1*TEM3,ZERO) QOD(L) = MAX(TEM4, (- TEM2 - SQRT(TEM)) * VRW(2)) ! - ! ! second iteration ! ! @@ -3733,46 +4004,43 @@ SUBROUTINE DDRFT( & ! - TEM2 = - ((1.0+TEM1)*(QHS+CE) + TEM1*tem4) - TEM3 = (1.0 + TEM1) * QHS * (tem4+CE) - TEM = MAX(TEM2*TEM2 - 4.0*TEM1*TEM3,ZERO) + TEM2 = - ((one+TEM1)*(QHS+CE) + TEM1*tem4) + TEM3 = (one + TEM1) * QHS * (tem4+CE) + TEM = MAX(TEM2*TEM2 - four*TEM1*TEM3,ZERO) QOD(L) = MAX(TEM4, (- TEM2 - SQRT(TEM)) * VRW(2)) ! Evaporation in Layer L-1 ! - EVP(L-1) = (QOD(L)-TEM4) * (ETD(L)+DDZ) ! Calculate Pd (L+1/2) QA(1) = TX1*RNT + RNF(L-1) - EVP(L-1) ! -! if(lprnt) print *,' etd=',etd(l),' tx5=',tx5,' rnt=',rnt +! if(lprnt) write(0,*)' etd=',etd(l),' tx5=',tx5,' rnt=',rnt ! *,' rnf=',rnf(l-1),' evp=',evp(l-1),' itr=',itr,' L=',L - ! - if (qa(1) > 0.0) then - IF (ETD(L) > 0.0) THEN + if (qa(1) > zero) then + IF (ETD(L) > zero) THEN TEM = QA(1) / (ETD(L)+ROR(L)*TX5*VT(1)) QRP(L) = MAX(TEM,ZERO) - ELSEIF (TX5 > 0.0) THEN + ELSEIF (TX5 > zero) THEN QRP(L) = (MAX(ZERO,QA(1)/(ROR(L)*TX5*GMS(L)))) & - & ** (1.0/1.1364) + & ** (one/1.1364) ELSE - QRP(L) = 0.0 + QRP(L) = zero ENDIF else - qrp(l) = 0.5 * qrp(l) + qrp(l) = half * qrp(l) endif ! Compute Buoyancy - TEM1 = WA(3)+(HOD(L)-WA(1)-ALHL*(QOD(L)-WA(2))) & - & * (1.0/CP) -! if (lprnt) print *,' tem1=',tem1,' wa3=',wa(3),' hod=' + TEM1 = WA(3)+(HOD(L)-WA(1)-ALHL*(QOD(L)-WA(2))) * onebcp +! if (lprnt) write(0,*)' tem1=',tem1,' wa3=',wa(3),' hod=' ! &,hod(l),' wa1=',wa(1),' qod=',qod(l),' wa2=',wa(2),' alhl=',alhl ! &,' cmpor=',cmpor,' dofw=',dofw,' prl=',prl(l),' qrp=',qrp(l) - TEM1 = TEM1 * (1.0 + NU*QOD(L)) + TEM1 = TEM1 * (one + NU*QOD(L)) ROR(L) = CMPOR * PRL(L) / TEM1 TEM1 = TEM1 * DOFW !!! TEM1 = TEM1 * (1.0 + NU*QOD(L)) * DOFW - BUY(L) = (TEM1 - 1.0 - QRP(L)) * ROR(L) * TX5 + BUY(L) = (TEM1 - one - QRP(L)) * ROR(L) * TX5 ! Compute W (L+1/2) TEM1 = WVL(L) @@ -3780,19 +4048,19 @@ SUBROUTINE DDRFT( & WVL(L) = VT(2) * (ETD(L-1)*WVL(L-1) - FACG & & * (BUY(L-1)*QRT(L-1)+BUY(L)*QRB(L-1))) ! -! if (lprnt) print *,' wvl=',wvl(l),'vt2=',vt(2),' buy1=' +! if (lprnt) write(0,*)' wvl=',wvl(l),'vt2=',vt(2),' buy1=' ! &,buy(l-1),' buy=',buy(l),' qrt1=',qrt(l-1),' qrb1=',qrb(l-1) ! &,' etd1=',etd(l-1),' wvl1=',wvl(l-1) ! ENDIF ! - if (wvl(l) < 0.0) then + if (wvl(l) < zero) then ! WVL(L) = max(wvl(l), 0.1*tem1) ! WVL(L) = 0.5*tem1 ! WVL(L) = 0.1*tem1 ! WVL(L) = 0.0 WVL(L) = 1.0e-10 else - WVL(L) = 0.5*(WVL(L)+TEM1) + WVL(L) = half*(WVL(L)+TEM1) endif ! @@ -3802,69 +4070,69 @@ SUBROUTINE DDRFT( & ! ERRQ = ERRQ + ABS(ERRW/MAX(WVL(L),ONE_M5)) -! if (lprnt) print *,' errw=',errw,' wvl=',wvl(l) +! if (lprnt) write(0,*)' errw=',errw,' wvl=',wvl(l) ! if(lprnt .or. tx5 == 0.0) then ! if(tx5 == 0.0 .and. l > kbl) then -! print *,' errq=',errq,' itr=',itr,' l=',l,' wvl=',wvl(l) +! write(0,*)' errq=',errq,' itr=',itr,' l=',l,' wvl=',wvl(l) ! &,' tx5=',tx5,' idnm=',idnm,' etd1=',etd(l-1),' etd=',etd(l) ! &,' kbl=',kbl ! endif ! -! if(lprnt) print *,' itr=',itr,' itrmnd=',itrmnd,' itrmd=',itrmd +! if(lprnt) write(0,*)' itr=',itr,' itrmnd=',itrmnd,' itrmd=',itrmd ! IF (ITR >= MIN(ITRMIN,ITRMD/2)) THEN IF (ITR >= MIN(ITRMND,ITRMD/2)) THEN -! if(lprnt) print *,' itr=',itr,' etd1=',etd(l-1),' errq=',errq - IF (ETD(L-1) == 0.0 .AND. ERRQ > 0.2) THEN -! if(lprnt) print *,' bud=',bud(kd),' wa=',wa(1),wa(2) - ROR(L) = BUD(KD) - ETD(L) = 0.0 - WVL(L) = 0.0 - ERRQ = 0.0 - HOD(L) = WA(1) - QOD(L) = WA(2) +! if(lprnt) write(0,*)' itr=',itr,' etd1=',etd(l-1),' errq=',errq + IF (ETD(L-1) == zero .AND. ERRQ > 0.2) THEN +! if(lprnt) write(0,*)' bud=',bud(kd),' wa=',wa(1),wa(2) + ROR(L) = BUD(KD) + ETD(L) = zero + WVL(L) = zero + ERRQ = zero + HOD(L) = WA(1) + QOD(L) = WA(2) ! TX5 = TX1 + TX9 - if (L .le. KBL) then - TX5 = TX9 + if (L <= KBL) then + TX5 = TX9 else TX5 = (STLT(KB1) * QRT(KB1) & & + STLT(KBL) * QRB(KB1)) * (0.5*FAC) endif -! if(lprnt) print *,' tx1=',tx1,' rnt=',rnt,' rnf=',rnf(l-1) +! if(lprnt) write(0,*)' tx1=',tx1,' rnt=',rnt,' rnf=',rnf(l-1) ! *,' evp=',evp(l-1),' l=',l - EVP(L-1) = 0.0 + EVP(L-1) = zero TEM = MAX(TX1*RNT+RNF(L-1),ZERO) QA(1) = TEM - EVP(L-1) ! IF (QA(1) > 0.0) THEN -! if(lprnt) print *,' ror=',ror(l),' tx5=',tx5,' tx1=',tx1 +! if(lprnt) write(0,*)' ror=',ror(l),' tx5=',tx5,' tx1=',tx1 ! *,' tx9=',tx9,' gms=',gms(l),' qa=',qa(1) ! if(lprnt) call mpi_quit(13) ! if (tx5 == 0.0 .or. gms(l) == 0.0) ! if (lprnt) -! * print *,' Atx5=',tx5,' gms=',gms(l),' ror=',ror(l) +! * write(0,*)' Atx5=',tx5,' gms=',gms(l),' ror=',ror(l) ! *,' L=',L,' QA=',QA(1),' tx1=',tx1,' tx9=',tx9 ! *,' kbl=',kbl,' etd1=',etd(l-1),' idnm=',idnm,' idn=',idn(idnm) ! *,' errq=',errq QRP(L) = (QA(1) / (ROR(L)*TX5*GMS(L))) & - & ** (1.0/1.1364) + & ** (one/1.1364) ! endif BUY(L) = - ROR(L) * TX5 * QRP(L) - WCB(L-1) = 0.0 + WCB(L-1) = zero ENDIF ! DEL_ETA = ETD(L) - ETD(L-1) - IF(DEL_ETA < 0.0 .AND. ERRQ > 0.1) THEN + IF(DEL_ETA < zero .AND. ERRQ > 0.1) THEN ROR(L) = BUD(KD) - ETD(L) = 0.0 - WVL(L) = 0.0 + ETD(L) = zero + WVL(L) = zero !!!!! TX5 = TX1 + TX9 CLDFRD(L-1) = TX5 ! DEL_ETA = - ETD(L-1) - EDZ = 0.0 + EDZ = zero DDZ = -DEL_ETA WCB(L-1) = DDZ ! @@ -3874,8 +4142,8 @@ SUBROUTINE DDRFT( & TEM4 = QOD(L) TEM1 = VRW(1) ! - QHS = QA(3) + 0.5 * (GAF(L-1)+GAF(L)) & - & * (HOD(L)-QA(2)) + QHS = QA(3) + half * (GAF(L-1)+GAF(L)) & + & * (HOD(L)-QA(2)) ! ! First iteration ! @@ -3888,8 +4156,8 @@ SUBROUTINE DDRFT( & CE = TEM6*ST2/((5.4E5*ST2 + 2.55E6)*(ETD(L)+DDZ)) ! - TEM2 = - ((1.0+TEM1)*(QHS+CE) + TEM1*QOD(L)) - TEM3 = (1.0 + TEM1) * QHS * (QOD(L)+CE) + TEM2 = - ((one+TEM1)*(QHS+CE) + TEM1*QOD(L)) + TEM3 = (one + TEM1) * QHS * (QOD(L)+CE) TEM = MAX(TEM2*TEM2 -FOUR*TEM1*TEM3,ZERO) QOD(L) = MAX(TEM4, (- TEM2 - SQRT(TEM)) * VRW(2)) ! @@ -3901,8 +4169,8 @@ SUBROUTINE DDRFT( & ! - TEM2 = - ((1.0+TEM1)*(QHS+CE) + TEM1*tem4) - TEM3 = (1.0 + TEM1) * QHS * (tem4+CE) + TEM2 = - ((one+TEM1)*(QHS+CE) + TEM1*tem4) + TEM3 = (one + TEM1) * QHS * (tem4+CE) TEM = MAX(TEM2*TEM2 -FOUR*TEM1*TEM3,ZERO) QOD(L) = MAX(TEM4, (- TEM2 - SQRT(TEM)) * VRW(2)) @@ -3916,12 +4184,12 @@ SUBROUTINE DDRFT( & QA(1) = TX1*RNT + RNF(L-1) EVP(L-1) = min(EVP(L-1), QA(1)) QA(1) = QA(1) - EVP(L-1) - qrp(l) = 0.0 + qrp(l) = zero ! ! if (tx5 == 0.0 .or. gms(l) == 0.0) ! if (lprnt) -! * print *,' Btx5=',tx5,' gms=',gms(l),' ror=',ror(l) +! * write(0,*)' Btx5=',tx5,' gms=',gms(l),' ror=',ror(l) ! *,' L=',L,' QA=',QA(1),' tx1=',tx1,' tx9=',tx9 ! *,' kbl=',kbl,' etd1=',etd(l-1),' DEL_ETA=',DEL_ETA ! &,' evp=',evp(l-1) @@ -3943,12 +4211,12 @@ SUBROUTINE DDRFT( & IF (L .LE. K) THEN RNS(L) = QA(1) - QA(1) = 0.0 + QA(1) = zero ENDIF - tx5 = tx9 - ERRQ = 0.0 - QRP(L) = 0.0 - BUY(L) = 0.0 + tx5 = tx9 + ERRQ = zero + QRP(L) = zero + BUY(L) = zero ! ENDIF ENDIF @@ -3956,7 +4224,7 @@ SUBROUTINE DDRFT( & ! ENDDO ! End of the iteration loop for a given L! IF (L <= K) THEN - IF (ETD(L-1) == 0.0 .AND. ERRQ > 0.1 .and. l <= kbl) THEN + IF (ETD(L-1) == zero .AND. ERRQ > 0.1 .and. l <= kbl) THEN !!! & .AND. ERRQ > ERRMIN*10.0 .and. l <= kbl) THEN ! & .AND. ERRQ > ERRMIN*10.0) THEN ROR(L) = BUD(KD) @@ -3964,7 +4232,7 @@ SUBROUTINE DDRFT( & QOD(L) = WA(2) TX5 = TX9 ! Does not make too much difference! ! TX5 = TX1 + TX9 - EVP(L-1) = 0.0 + EVP(L-1) = zero ! EVP(L-1) = CEE * (1.0 - qod(l)/qa(3)) QA(1) = TX1*RNT + RNF(L-1) EVP(L-1) = min(EVP(L-1), QA(1)) @@ -3972,42 +4240,42 @@ SUBROUTINE DDRFT( & ! QRP(L) = 0.0 ! if (tx5 == 0.0 .or. gms(l) == 0.0) then -! print *,' Ctx5=',tx5,' gms=',gms(l),' ror=',ror(l) & +! write(0,*)' Ctx5=',tx5,' gms=',gms(l),' ror=',ror(l) & ! &, ' L=',L,' QA=',QA(1),' tx1=',tx1,' tx9=',tx9 & ! &, ' kbl=',kbl,' etd1=',etd(l-1),' DEL_ETA=',DEL_ETA ! endif ! IF (QA(1) > 0.0) THEN QRP(L) = (QA(1) / (ROR(L)*TX5*GMS(L))) & - & ** (1.0/1.1364) + & ** (one/1.1364) ! ENDIF - ETD(L) = 0.0 - WVL(L) = 0.0 - ST1 = 1.0 - ALFIND(L) + ETD(L) = zero + WVL(L) = zero + ST1 = one - ALFIND(L) - ERRQ = 0.0 + ERRQ = zero BUY(L) = - ROR(L) * TX5 * QRP(L) - WCB(L-1) = 0.0 + WCB(L-1) = zero ENDIF ENDIF ! - LL = MIN(IDN(idnm), K+1) - IF (ERRQ < 1.0 .AND. L <= LL) THEN - IF (ETD(L-1) > 0.0 .AND. ETD(L) == 0.0) THEN + LL = MIN(IDN(idnm), KP1) + IF (ERRQ < one .AND. L <= LL) THEN + IF (ETD(L-1) > zero .AND. ETD(L) == zero) THEN IDN(idnm) = L - wvl(l) = 0.0 - if (L < KBL .or. tx5 > 0.0) idnm = idnm + 1 - errq = 0.0 + wvl(l) = zero + if (L < KBL .or. tx5 > zero) idnm = idnm + 1 + errq = zero ENDIF - if (etd(l) == 0.0 .and. l > kbl) then + if (etd(l) == zero .and. l > kbl) then idn(idnm) = l - if (tx5 > 0.0) idnm = idnm + 1 + if (tx5 > zero) idnm = idnm + 1 endif ENDIF ! if (lprnt) then -! print *,' ERRQ=',ERRQ,' IDN=',IDN(idnm),' idnm=',idnm -! print *,' L=',L,' QRP=',QRP(L),' ETD=',ETD(L),' QA=',QA(1) +! write(0,*)' ERRQ=',ERRQ,' IDN=',IDN(idnm),' idnm=',idnm +! write(0,*)' L=',L,' QRP=',QRP(L),' ETD=',ETD(L),' QA=',QA(1) ! *,' evp=',evp(l-1),' rnf=',rnf(l-1) ! endif @@ -4016,93 +4284,90 @@ SUBROUTINE DDRFT( & ! not converge) , no downdraft is assumed ! ! IF (ERRQ > ERRMIN*100.0 .AND. IDN(idnm) == 99) & - IF (ERRQ > 0.1 .AND. IDN(idnm) == 99) & - & DDFT = .FALSE. + IF (ERRQ > 0.1 .AND. IDN(idnm) == 99) DDFT = .FALSE. ! -! - DOF = 0.0 + DOF = zero IF (.NOT. DDFT) RETURN ! ! if (ddlgk .or. l .le. idn(idnm)) then ! rsum2 = rsum2 + evp(l-1) -! print *,' rsum1=',rsum1,' rsum2=',rsum2,' L=',L,' qa=',qa(1)& +! write(0,*)' rsum1=',rsum1,' rsum2=',rsum2,' L=',L,' qa=',qa(1)& ! &, ' evp=',evp(l-1) ! else ! rsum1 = rsum1 + rnf(l-1) -! print *,' rsum1=',rsum1,' rsum2=',rsum2,' L=',L,' rnf=', & +! write(0,*)' rsum1=',rsum1,' rsum2=',rsum2,' L=',L,' rnf=', & ! & rnf(l-1) ! endif ENDDO ! End of the L Loop of downdraft ! - TX1 = 0.0 + TX1 = zero DOF = QA(1) ! -! print *,' dof=',dof,' rntp=',rntp,' rnb=',rnb -! print *,' total=',(rsum1+dof+rntp+rnb) - - ENDIF ! SKPDD endif +! write(0,*)' dof=',dof,' rntp=',rntp,' rnb=',rnb +! write(0,*)' total=',(rsum1+dof+rntp+rnb) ! + dof = max(dof, zero) + RNN(KD) = RNTP + TX1 = EVP(KD) + TX2 = RNTP + RNB + DOF - dof = max(dof, 0.0) - RNN(KD) = RNTP - TX1 = EVP(KD) - TX2 = RNTP + RNB + DOF - -! if (lprnt) print *,' tx2=',tx2 - II = IDH - IF (II >= KD1+1) THEN - RNN(KD) = RNN(KD) + RNF(KD) - TX2 = TX2 + RNF(KD) - RNN(II-1) = 0.0 - TX1 = EVP(II-1) - ENDIF -! if (lprnt) print *,' tx2=',tx2,' idnm=',idnm,' idn=',idn(idnm) - DO L=KD,K +! if (lprnt) write(0,*)' tx2=',tx2 II = IDH - - IF (L > KD1 .AND. L < II) THEN - RNN(L-1) = RNF(L-1) - TX2 = TX2 + RNN(L-1) - ELSEIF (L >= II .AND. L < IDN(idnm)) THEN - rnn(l) = rns(l) - tx2 = tx2 + rnn(l) - TX1 = TX1 + EVP(L) - ELSEIF (L >= IDN(idnm)) THEN - ETD(L+1) = 0.0 - HOD(L+1) = 0.0 - QOD(L+1) = 0.0 - EVP(L) = 0.0 - RNN(L) = RNF(L) + RNS(L) - TX2 = TX2 + RNN(L) + IF (II >= KD1+1) THEN + RNN(KD) = RNN(KD) + RNF(KD) + TX2 = TX2 + RNF(KD) + RNN(II-1) = zero + TX1 = EVP(II-1) ENDIF -! if (lprnt) print *,' tx2=',tx2,' L=',L,' rnn=',rnn(l) - ENDDO +! if (lprnt) write(0,*)' tx2=',tx2,' idnm=',idnm,' idn=',idn(idnm) + DO L=KD,K + II = IDH + + IF (L > KD1 .AND. L < II) THEN + RNN(L-1) = RNF(L-1) + TX2 = TX2 + RNN(L-1) + ELSEIF (L >= II .AND. L < IDN(idnm)) THEN + rnn(l) = rns(l) + tx2 = tx2 + rnn(l) + TX1 = TX1 + EVP(L) + ELSEIF (L >= IDN(idnm)) THEN + ETD(L+1) = zero + HOD(L+1) = zero + QOD(L+1) = zero + EVP(L) = zero + RNN(L) = RNF(L) + RNS(L) + TX2 = TX2 + RNN(L) + ENDIF +! if (lprnt) write(0,*)' tx2=',tx2,' L=',L,' rnn=',rnn(l) + ENDDO ! ! For Downdraft case the rain is that falls thru the bottom - L = KBL + L = KBL - RNN(L) = RNN(L) + RNB - CLDFRD(L) = TX5 + RNN(L) = RNN(L) + RNB + CLDFRD(L) = TX5 ! ! Caution !! Below is an adjustment to rain flux to maintain ! conservation of precip! ! -! if (lprnt) print *,' train=',train,' tx2=',tx2,' tx1=',tx1 +! if (lprnt) write(0,*)' train=',train,' tx2=',tx2,' tx1=',tx1 - IF (TX1 > 0.0) THEN - TX1 = (TRAIN - TX2) / TX1 - ELSE - TX1 = 0.0 - ENDIF + IF (TX1 > zero) THEN + TX1 = (TRAIN - TX2) / TX1 + ELSE + TX1 = zero + ENDIF - DO L=KD,K - EVP(L) = EVP(L) * TX1 - ENDDO + DO L=KD,K + EVP(L) = EVP(L) * TX1 + ENDDO + + ENDIF ! if (.not. DDFT) loop endif ! !*********************************************************************** !*********************************************************************** @@ -4123,37 +4388,36 @@ SUBROUTINE QSATCN(TT,P,Q,DQDT) ! real(kind=kind_phys) TT, P, Q, DQDT ! - real(kind=kind_phys) rvi, facw, faci, hsub, tmix, DEN - real(kind=kind_phys) ZERO,ONE,ONE_M10 - PARAMETER (RVI=1.0/RV) - PARAMETER (FACW=CVAP-CLIQ, FACI=CVAP-CSOL) - PARAMETER (HSUB=HVAP+HFUS, tmix=TTP-20.0, DEN=1.0/(TTP-TMIX)) - PARAMETER (ZERO=0.,ONE=1.,ONE_M10=1.E-10) + real(kind=kind_phys), parameter :: ZERO=0.0, ONE=1.0 & + &, ONE_M10=1.E-10 & + &, rvi=one/rv, facw=CVAP-CLIQ & + &, faci=CVAP-CSOL, hsub=HVAP+HFUS & + &, tmix=TTP-20.0 & + &, DEN=one/(TTP-TMIX) ! logical lprnt ! real(kind=kind_phys) es, d, hlorv, W ! ! es = 10.0 * fpvs(tt) ! fpvs is in centibars! es = 0.01 * fpvs(tt) ! fpvs is in Pascals! - D = 1.0 / max(p+epsm1*es,ONE_M10) + D = one / max(p+epsm1*es,ONE_M10) ! q = MIN(eps*es*D, ONE) ! W = max(ZERO, min(ONE, (TT - TMIX)*DEN)) hlorv = ( W * (HVAP + FACW * (tt-ttp)) & - & + (1.0-W) * (HSUB + FACI * (tt-ttp)) ) * RVI + & + (one-W) * (HSUB + FACI * (tt-ttp)) ) * RVI dqdt = p * q * hlorv * D / (tt*tt) ! return end - SUBROUTINE ANGRAD( PRES, ALM, AL2, TLA, PRB, WFN, UFN) + SUBROUTINE ANGRAD(PRES, ALM, AL2, TLA) USE MACHINE , ONLY : kind_phys use module_ras , only : refp, refr, tlac, plac, tlbpl, drdp, almax implicit none - real(kind=kind_phys) PRES, ALM, AL2, TLA, TEM, TEM1 & - &, PRB, ACR, WFN, UFN + real(kind=kind_phys) PRES, ALM, AL2, TLA, TEM ! integer i ! @@ -4201,7 +4465,7 @@ SUBROUTINE ANGRAD( PRES, ALM, AL2, TLA, PRB, WFN, UFN) END SUBROUTINE SETQRP USE MACHINE , ONLY : kind_phys - use module_ras , only : NQRP,C1XQRP,C2XQRP,TBQRP,TBQRA,TBQRB + use module_ras , only : NQRP,C1XQRP,C2XQRP,TBQRP,TBQRA,TBQRB,one implicit none real(kind=kind_phys) tem2,tem1,x,xinc,xmax,xmin @@ -4211,8 +4475,8 @@ SUBROUTINE SETQRP XMIN = 0.0 XMAX = 5.0 XINC = (XMAX-XMIN)/(NQRP-1) - C2XQRP = 1.0/XINC - C1XQRP = 1.0 - XMIN*C2XQRP + C2XQRP = one / XINC + C1XQRP = one - XMIN*C2XQRP TEM1 = 0.001 ** 0.2046 TEM2 = 0.001 ** 0.525 DO JX=1,NQRP @@ -4227,11 +4491,10 @@ SUBROUTINE SETQRP FUNCTION QRPF(QRP) ! USE MACHINE , ONLY : kind_phys - use module_ras , only : NQRP,C1XQRP,C2XQRP,TBQRP,TBQRA,TBQRB + use module_ras , only : NQRP,C1XQRP,C2XQRP,TBQRP,TBQRA,TBQRB, one implicit none - real(kind=kind_phys) QRP, QRPF, XJ, REAL_NQRP, ONE - PARAMETER (ONE=1.0) + real(kind=kind_phys) QRP, QRPF, XJ, REAL_NQRP INTEGER JX ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - REAL_NQRP = REAL(NQRP) @@ -4244,11 +4507,10 @@ FUNCTION QRPF(QRP) END SUBROUTINE QRABF(QRP,QRAF,QRBF) USE MACHINE , ONLY : kind_phys - use module_ras , only : NQRP,C1XQRP,C2XQRP,TBQRP,TBQRA,TBQRB + use module_ras , only : NQRP,C1XQRP,C2XQRP,TBQRP,TBQRA,TBQRB, one implicit none ! - real(kind=kind_phys) QRP, QRAF, QRBF, XJ, REAL_NQRP, ONE - PARAMETER (ONE=1.0) + real(kind=kind_phys) QRP, QRAF, QRBF, XJ, REAL_NQRP INTEGER JX ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - REAL_NQRP = REAL(NQRP) @@ -4262,18 +4524,17 @@ SUBROUTINE QRABF(QRP,QRAF,QRBF) END SUBROUTINE SETVTP USE MACHINE , ONLY : kind_phys - use module_ras , only : NVTP,C1XVTP,C2XVTP,TBVTP + use module_ras , only : NVTP,C1XVTP,C2XVTP,TBVTP, VTPEXP,one implicit none - real(kind=kind_phys) vtpexp,xinc,x,xmax,xmin + real(kind=kind_phys) xinc,x,xmax,xmin integer jx - PARAMETER(VTPEXP=-0.3636) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - XMIN = 0.05 XMAX = 1.5 XINC = (XMAX-XMIN)/(NVTP-1) - C2XVTP = 1.0/XINC - C1XVTP = 1.0 - XMIN*C2XVTP + C2XVTP = one / XINC + C1XVTP = one - XMIN*C2XVTP DO JX=1,NVTP X = XMIN + (JX-1)*XINC TBVTP(JX) = X ** VTPEXP @@ -4284,10 +4545,9 @@ SUBROUTINE SETVTP FUNCTION VTPF(ROR) ! USE MACHINE , ONLY : kind_phys - use module_ras , only : NVTP,C1XVTP,C2XVTP,TBVTP + use module_ras , only : NVTP,C1XVTP,C2XVTP,TBVTP, one implicit none - real(kind=kind_phys) ROR, VTPF, XJ, REAL_NVTP, ONE - PARAMETER (ONE=1.0) + real(kind=kind_phys) ROR, VTPF, XJ, REAL_NVTP INTEGER JX ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - REAL_NVTP = REAL(NVTP) diff --git a/gfsphysics/physics/samfdeepcnv.f b/gfsphysics/physics/samfdeepcnv.f index 399933656..d0152a460 100755 --- a/gfsphysics/physics/samfdeepcnv.f +++ b/gfsphysics/physics/samfdeepcnv.f @@ -83,14 +83,17 @@ subroutine samfdeepcnv(im,ix,km,delt,ntk,ntr,delp, & prslp,psp,phil,qtr,q1,t1,u1,v1, & cldwrk,rn,kbot,ktop,kcnv,islimsk,garea, & dot,ncloud,ud_mf,dd_mf,dt_mf,cnvw,cnvc, + & QLCN, QICN, w_upi, cf_upi, CNV_MFD, +! & QLCN, QICN, w_upi, cf_upi, CNV_MFD, CNV_PRC3, + & CNV_DQLDT,CLCN,CNV_FICE,CNV_NDROP,CNV_NICE,mp_phys, & clam,c0s,c1,betal,betas,evfact,evfactl,pgcon,asolfac) ! use machine , only : kind_phys use funcphys , only : fpvs - use physcons, grav => con_g, cp => con_cp, hvap => con_hvap - &, rv => con_rv, fv => con_fvirt, t0c => con_t0c - &, rd => con_rd, cvap => con_cvap, cliq => con_cliq - &, eps => con_eps, epsm1 => con_epsm1 + use physcons, grav => con_g, cp => con_cp, hvap => con_hvap + &, rv => con_rv, fv => con_fvirt, t0c => con_t0c + &, rd => con_rd, cvap => con_cvap, cliq => con_cliq + &, eps => con_eps,epsm1 => con_epsm1, rgas => con_rd implicit none ! integer, intent(in) :: im, ix, km, ntk, ntr, ncloud @@ -240,6 +243,13 @@ subroutine samfdeepcnv(im,ix,km,delt,ntk,ntr,delp, & tx1(im), sumx(im), cnvwt(im,km) ! &, rhbar(im) ! + real(kind=kind_phys), dimension(im,km) :: qlcn, qicn, w_upi + &, cnv_mfd +! &, cnv_mfd, cnv_prc3 + &, cnv_dqldt, clcn + &, cnv_fice, cnv_ndrop + &, cnv_nice, cf_upi + integer mp_phys logical totflg, cnvflg(im), asqecflg(im), flg(im) ! ! asqecflg: flag for the quasi-equilibrium assumption of Arakawa-Schubert @@ -340,6 +350,23 @@ subroutine samfdeepcnv(im,ix,km,delt,ntk,ntr,delp, dt_mf(i,k) = 0. enddo enddo + if(mp_phys == 10) then + do k = 1, km + do i = 1, im + QLCN(i,k) = qtr(i,k,2) + QICN(i,k) = qtr(i,k,1) + w_upi(i,k) = 0.0 + cf_upi(i,k) = 0.0 + CNV_MFD(i,k) = 0.0 + + CNV_DQLDT(i,k) = 0.0 + CLCN(i,k) = 0.0 + CNV_FICE(i,k) = 0.0 + CNV_NDROP(i,k) = 0.0 + CNV_NICE(i,k) = 0.0 + enddo + enddo + endif c ! do k = 1, 15 ! acrit(k) = acritt(k) * (975. - pcrit(k)) @@ -352,7 +379,7 @@ subroutine samfdeepcnv(im,ix,km,delt,ntk,ntr,delp, ! val = 5400. val = 10800. dtmax = max(dt2, val ) -c model tunable parameters are all here +! model tunable parameters are all here edtmaxl = .3 edtmaxs = .3 ! clam = .1 @@ -2709,5 +2736,20 @@ subroutine samfdeepcnv(im,ix,km,delt,ntk,ntr,delp, ! endif !! + if(mp_phys == 10) then + do k=1,km + do i=1,im + QLCN(i,k) = qtr(i,k,2) - qlcn(i,k) + QICN(i,k) = qtr(i,k,1) - qicn(i,k) + cf_upi(i,k) = cnvc(i,k) + w_upi(i,k) = ud_mf(i,k)*t1(i,k)*rgas / + & (dt2*max(sigmagfm(i),1.e-12)*prslp(i,k)) + CNV_MFD(i,k) = ud_mf(i,k)/dt2 + CLCN(i,k) = cnvc(i,k) + CNV_FICE(i,k) = QICN(i,k) + & / max(1.e-10,QLCN(i,k)+QICN(i,k)) + enddo + enddo + endif return end diff --git a/gfsphysics/physics/sascnv.f b/gfsphysics/physics/sascnv.f index a35d12e3b..93ac11a9a 100644 --- a/gfsphysics/physics/sascnv.f +++ b/gfsphysics/physics/sascnv.f @@ -1,7 +1,10 @@ subroutine sascnv(im,ix,km,jcap,delt,delp,prslp,psp,phil,ql, ! subroutine sascnv(im,ix,km,jcap,delt,del,prsl,phil,ql, & q1,t1,u1,v1,cldwrk,rn,kbot,ktop,kuo,islimsk, - & dot,xkt2,ncloud,ud_mf,dd_mf,dt_mf,cnvw,cnvc) + & dot,xkt2,ncloud,ud_mf,dd_mf,dt_mf,cnvw,cnvc, + & QLCN, QICN, w_upi, cf_upi, CNV_MFD, +! & QLCN, QICN, w_upi, cf_upi, CNV_MFD, CNV_PRC3, + & CNV_DQLDT,CLCN,CNV_FICE,CNV_NDROP,CNV_NICE,mp_phys) ! hchuang code change [r1l] ! & dot,xkt2,ncloud) ! @@ -18,7 +21,7 @@ subroutine sascnv(im,ix,km,jcap,delt,delp,prslp,psp,phil,ql, use physcons, grav => con_g, cp => con_cp, hvap => con_hvap &, rv => con_rv, fv => con_fvirt, t0c => con_t0c &, cvap => con_cvap, cliq => con_cliq - &, eps => con_eps, epsm1 => con_epsm1 + &, eps => con_eps, epsm1 => con_epsm1,rgas => con_rd implicit none ! ! @@ -111,6 +114,13 @@ subroutine sascnv(im,ix,km,jcap,delt,delp,prslp,psp,phil,ql, & qrcdo(im,km), pwo(im,km), pwdo(im,km), & rhbar(im), tx1(im), cnvwt(im,km) ! + real(kind=kind_phys), dimension(im,km) :: qlcn, qicn, w_upi + &, cnv_mfd +! &, cnv_mfd, cnv_prc3 + &, cnv_dqldt, clcn + &, cnv_fice, cnv_ndrop + &, cnv_nice, cf_upi + integer mp_phys logical totflg, cnvflg(im), dwnflg(im), dwnflg2(im), flg(im) ! real(kind=kind_phys) pcrit(15), acritt(15), acrit(15) @@ -167,6 +177,19 @@ subroutine sascnv(im,ix,km,jcap,delt,delp,prslp,psp,phil,ql, ud_mf(i,k) = 0. dd_mf(i,k) = 0. dt_mf(i,k) = 0. + if(mp_phys == 10) then + QLCN(i,k) = 0.0 + QICN(i,k) = 0.0 + w_upi(i,k) = 0.0 + cf_upi(i,k) = 0.0 + CNV_MFD(i,k) = 0.0 +! CNV_PRC3(i,k) = 0.0 + CNV_DQLDT(i,k) = 0.0 + CLCN(i,k) = 0.0 + CNV_FICE(i,k) = 0.0 + CNV_NDROP(i,k) = 0.0 + CNV_NICE(i,k) = 0.0 + end if enddo enddo !! @@ -1766,6 +1789,23 @@ subroutine sascnv(im,ix,km,jcap,delt,delp,prslp,psp,phil,ql, endif enddo enddo + + if(mp_phys == 10) then + do k=1,km + do i=1,im + QLCN(i,k) = ql(i,k,2) + QICN(i,k) = ql(i,k,1) + cf_upi(i,k) = cnvc(i,k) + w_upi(i,k) = ud_mf(i,k)*t1(i,k)*rgas / + & (dt2*max(cf_upi(i,k),1.e-12)*prslp(i,k)) + CNV_MFD(i,k) = ud_mf(i,k)/dt2 + CLCN(i,k) = cnvc(i,k) + CNV_FICE(i,k) = QICN(i,k) + & / max(1.e-10,QLCN(i,k)+QICN(i,k)) + enddo + enddo + endif !! + return end diff --git a/gfsphysics/physics/sascnvn.f b/gfsphysics/physics/sascnvn.f index 81e3d5078..208c423aa 100644 --- a/gfsphysics/physics/sascnvn.f +++ b/gfsphysics/physics/sascnvn.f @@ -56,8 +56,9 @@ subroutine sascnvn(im,ix,km,jcap,delt,delp,prslp,psp,phil,ql, & & q1,t1,u1,v1,cldwrk,rn,kbot,ktop,kcnv,islimsk, & & dot,ncloud,ud_mf,dd_mf,dt_mf,cnvw,cnvc, & -! & q1,t1,u1,v1,rcs,cldwrk,rn,kbot,ktop,kcnv,islimsk, -! & dot,ncloud,ud_mf,dd_mf,dt_mf,me) + & QLCN, QICN, w_upi, cf_upi, CNV_MFD, & +! & QLCN, QICN, w_upi, cf_upi, CNV_MFD, CNV_PRC3, & + & CNV_DQLDT,CLCN,CNV_FICE,CNV_NDROP,CNV_NICE,mp_phys, & & clam,c0,c1,betal,betas,evfact,evfactl,pgcon) ! use machine , only : kind_phys @@ -65,7 +66,7 @@ subroutine sascnvn(im,ix,km,jcap,delt,delp,prslp,psp,phil,ql, & use physcons, grav => con_g, cp => con_cp, hvap => con_hvap & &, rv => con_rv, fv => con_fvirt, t0c => con_t0c & &, cvap => con_cvap, cliq => con_cliq & - &, eps => con_eps, epsm1 => con_epsm1 + &, eps => con_eps, epsm1 => con_epsm1,rgas => con_rd implicit none ! integer im, ix, km, jcap, ncloud, & @@ -80,8 +81,15 @@ subroutine sascnvn(im,ix,km,jcap,delt,delp,prslp,psp,phil,ql, & & dot(ix,km), phil(ix,km), & & cnvw(ix,km), cnvc(ix,km), & & ud_mf(im,km),dd_mf(im,km),dt_mf(im,km) ! hchuang code change mass flux output + real(kind=kind_phys), dimension(im,km) :: qlcn, qicn, w_upi & + &, cnv_mfd & +! &, cnv_mfd, cnv_prc3 & + &, cnv_dqldt, clcn & + &, cnv_fice, cnv_ndrop & + &, cnv_nice, cf_upi + ! - integer i, indx, jmn, k, kk, km1 + integer i, indx, jmn, k, kk, km1, mp_phys integer, dimension(im), intent(in) :: islimsk ! integer latd,lond ! @@ -234,6 +242,19 @@ subroutine sascnvn(im,ix,km,jcap,delt,delp,prslp,psp,phil,ql, & ud_mf(i,k) = 0. dd_mf(i,k) = 0. dt_mf(i,k) = 0. + if(mp_phys == 10) then + QLCN(i,k) = 0.0 + QICN(i,k) = 0.0 + w_upi(i,k) = 0.0 + cf_upi(i,k) = 0.0 + CNV_MFD(i,k) = 0.0 +! CNV_PRC3(i,k) = 0.0 + CNV_DQLDT(i,k) = 0.0 + CLCN(i,k) = 0.0 + CNV_FICE(i,k) = 0.0 + CNV_NDROP(i,k) = 0.0 + CNV_NICE(i,k) = 0.0 + end if enddo enddo !> - Initialize the reference cloud work function, define min/max convective adjustment timescales, and tunable parameters. @@ -2017,6 +2038,23 @@ subroutine sascnvn(im,ix,km,jcap,delt,delp,prslp,psp,phil,ql, & endif enddo enddo + + if(mp_phys == 10) then + do k=1,km + do i=1,im + QLCN(i,k) = ql(i,k,2) + QICN(i,k) = ql(i,k,1) + cf_upi(i,k) = cnvc(i,k) + w_upi(i,k) = ud_mf(i,k)*t1(i,k)*rgas / + & (dt2*max(cf_upi(i,k),1.e-12)*prslp(i,k)) + CNV_MFD(i,k) = ud_mf(i,k)/dt2 + CLCN(i,k) = cnvc(i,k) + CNV_FICE(i,k) = QICN(i,k) + & / max(1.e-10,QLCN(i,k)+QICN(i,k)) + enddo + enddo + endif + !! return !> @} diff --git a/gfsphysics/physics/satmedmfvdif.f b/gfsphysics/physics/satmedmfvdif.f index f85723a37..fa85d2c5d 100644 --- a/gfsphysics/physics/satmedmfvdif.f +++ b/gfsphysics/physics/satmedmfvdif.f @@ -14,7 +14,7 @@ ! For local turbulence mixing, a TKE closure model is used. ! !---------------------------------------------------------------------- - subroutine satmedmfvdif(ix,im,km,ntrac,ntcw,ntiw,nthm,ntke, + subroutine satmedmfvdif(ix,im,km,ntrac,ntcw,ntiw,ntke, & dv,du,tdt,rtg,u1,v1,t1,q1,swh,hlw,xmu,garea, & psk,rbsoil,zorl,u10m,v10m,fm,fh, & tsea,heat,evap,stress,spd1,kpbl, @@ -26,13 +26,13 @@ subroutine satmedmfvdif(ix,im,km,ntrac,ntcw,ntiw,nthm,ntke, use funcphys , only : fpvs use physcons, grav => con_g, rd => con_rd, cp => con_cp &, rv => con_rv, hvap => con_hvap - &, fv => con_fvirt + &, hfus => con_hfus, fv => con_fvirt &, eps => con_eps, epsm1 => con_epsm1 ! implicit none ! !---------------------------------------------------------------------- - integer ix, im, km, ntrac, ntcw, ntiw, nthm, ntke + integer ix, im, km, ntrac, ntcw, ntiw, ntke integer kpbl(im), kinver(im) ! real(kind=kind_phys) delt, xkzm_m, xkzm_h, xkzm_s @@ -70,17 +70,16 @@ subroutine satmedmfvdif(ix,im,km,ntrac,ntcw,ntiw,nthm,ntke, ! real(kind=kind_phys) theta(im,km),thvx(im,km), thlvx(im,km), & qlx(im,km), thetae(im,km),thlx(im,km), -! & slx(im,km), svx(im,km), qtx(im,km), + & slx(im,km), svx(im,km), qtx(im,km), & tvx(im,km), pix(im,km), radx(im,km-1), & dku(im,km-1),dkt(im,km-1), dkq(im,km-1), & cku(im,km-1),ckt(im,km-1) ! -! real(kind=kind_phys) plyr(im,km), rhly(im,km), cfly(im,km), -! & qstl(im,km) - real(kind=kind_phys) plyr(im,km) + real(kind=kind_phys) plyr(im,km), rhly(im,km), cfly(im,km), + & qstl(im,km) ! real(kind=kind_phys) dtdz1(im), gdx(im), - & phih(im), phim(im), prn(im), + & phih(im), phim(im), prn(im,km-1), & rbdn(im), rbup(im), thermal(im), & ustar(im), wstar(im), hpblx(im), & ust3(im), wst3(im), @@ -100,6 +99,7 @@ subroutine satmedmfvdif(ix,im,km,ntrac,ntcw,ntiw,nthm,ntke, & f1(im,km), f2(im,km*(ntrac-1)) ! real(kind=kind_phys) elm(im,km), ele(im,km), rle(im,km-1), + & ckz(im,km), chz(im,km), & diss(im,km-1),prod(im,km-1), & bf(im,km-1), shr2(im,km-1), & xlamue(im,km-1), xlamde(im,km-1), @@ -151,7 +151,7 @@ subroutine satmedmfvdif(ix,im,km,ntrac,ntcw,ntiw,nthm,ntke, & tem, tem1, tem2, & ptem, ptem0, ptem1, ptem2 ! - real(kind=kind_phys) ck0, ch0, ch1, ce0, rchck + real(kind=kind_phys) ck0, ck1, ch0, ch1, ce0, rchck ! real(kind=kind_phys) qlcr, zstblmax ! @@ -163,14 +163,13 @@ subroutine satmedmfvdif(ix,im,km,ntrac,ntcw,ntiw,nthm,ntke, parameter(cont=cp/g,conq=hvap/g,conw=1.0/g) ! for del in pa ! parameter(cont=1000.*cp/g,conq=1000.*hvap/g,conw=1000./g) !kpa parameter(elocp=hvap/cp,el2orc=hvap*hvap/(rv*cp)) - parameter(wfac=7.0,cfac=4.0) + parameter(wfac=7.0,cfac=4.5) parameter(gamcrt=3.,gamcrq=0.,sfcfrac=0.1) parameter(vk=0.4,rimin=-100.) parameter(rbcr=0.25,zolcru=-0.02,tdzmin=1.e-3) - parameter(rlmn=30.,rlmx=300.,elmx=300.) + parameter(rlmn=30.,rlmx=500.,elmx=500.) parameter(prmin=0.25,prmax=4.0,prtke=1.0,prscu=0.67) parameter(f0=1.e-4,crbmin=0.15,crbmax=0.35) -! parameter(tkmin=5.e-5,dspfac=0.5,dspmax=10.0) parameter(tkmin=1.e-9,dspfac=0.5,dspmax=10.0) parameter(qmin=1.e-8,qlmin=1.e-12,zfmin=1.e-8) parameter(aphi5=5.,aphi16=16.) @@ -178,7 +177,7 @@ subroutine satmedmfvdif(ix,im,km,ntrac,ntcw,ntiw,nthm,ntke, parameter(dw2min=1.e-4,dkmax=1000.,xkgdx=25000.) parameter(qlcr=3.5e-5,zstblmax=2500.,xkzinv=0.15) parameter(h1=0.33333333) - parameter(ck0=0.4,ch0=0.4,ch1=0.2,ce0=0.7) + parameter(ck0=0.4,ck1=0.15,ch0=0.4,ch1=0.15,ce0=0.4) parameter(rchck=1.5,cdtn=25.) ! !************************************************************************ @@ -201,6 +200,8 @@ subroutine satmedmfvdif(ix,im,km,ntrac,ntcw,ntiw,nthm,ntke, xmfd(i,k) = 0. buou(i,k) = 0. buod(i,k) = 0. + ckz(i,k) = ck1 + chz(i,k) = ch1 enddo enddo do i=1,im @@ -230,6 +231,7 @@ subroutine satmedmfvdif(ix,im,km,ntrac,ntcw,ntiw,nthm,ntke, do k = 1,km1 do i=1,im rdzt(i,k) = 1.0 / (zl(i,k+1) - zl(i,k)) + prn(i,k) = 1.0 enddo enddo ! @@ -303,37 +305,27 @@ subroutine satmedmfvdif(ix,im,km,ntrac,ntcw,ntiw,nthm,ntke, endif enddo ! - do k = 1,km + do k=1,km do i=1,im - tx1(i) = 0.0 - enddo - do kk=1,nthm - do i=1,im - tx1(i) = tx1(i) + max(q1(i,k,ntcw+kk-1), qlmin) - enddo - enddo - do i = 1,im pix(i,k) = psk(i) / prslk(i,k) theta(i,k) = t1(i,k) * pix(i,k) - tem = 1.+fv*max(q1(i,k,1),qmin)-tx1(i) - thvx(i,k) = theta(i,k) * tem - tvx(i,k) = t1(i,k) * tem - enddo - enddo -! - do k=1,km - do i=1,im if(ntiw > 0) then - qlx(i,k) = max((q1(i,k,ntcw)+q1(i,k,ntiw)),qlmin) + tem = max(q1(i,k,ntcw),qlmin) + tem1 = max(q1(i,k,ntiw),qlmin) + qlx(i,k) = tem + tem1 + ptem = hvap*tem + (hvap+hfus)*tem1 + slx(i,k) = cp * t1(i,k) + phil(i,k) - ptem else qlx(i,k) = max(q1(i,k,ntcw),qlmin) + slx(i,k) = cp * t1(i,k) + phil(i,k) - hvap*qlx(i,k) endif -! qtx(i,k) = max(q1(i,k,1),qmin)+qlx(i,k) - ptem = max(q1(i,k,1),qmin) + qlx(i,k) -! slx(i,k) = cp * t1(i,k) + phil(i,k) - hvap*qlx(i,k) + tem2 = 1.+fv*max(q1(i,k,1),qmin)-qlx(i,k) + thvx(i,k) = theta(i,k) * tem2 + tvx(i,k) = t1(i,k) * tem2 + qtx(i,k) = max(q1(i,k,1),qmin)+qlx(i,k) thlx(i,k) = theta(i,k) - pix(i,k)*elocp*qlx(i,k) - thlvx(i,k) = thlx(i,k) * (1. + fv * ptem) -! svx(i,k) = cp * tvx(i,k) + phil(i,k) + thlvx(i,k) = thlx(i,k) * (1. + fv * qtx(i,k)) + svx(i,k) = cp * tvx(i,k) ptem1 = elocp * pix(i,k) * max(q1(i,k,1),qmin) thetae(i,k)= theta(i,k) + ptem1 gotvx(i,k) = g / tvx(i,k) @@ -360,48 +352,48 @@ subroutine satmedmfvdif(ix,im,km,ntrac,ntcw,ntiw,nthm,ntke, do i = 1, im plyr(i,k) = 0.01 * prsl(i,k) ! pa to mb (hpa) ! --- ... compute relative humidity -! es = 0.01 * fpvs(t1(i,k)) ! fpvs in pa -! qs = max(qmin, eps * es / (plyr(i,k) + epsm1*es)) -! rhly(i,k) = max(0.0, min(1.0, max(qmin, q1(i,k,1))/qs)) -! qstl(i,k) = qs + es = 0.01 * fpvs(t1(i,k)) ! fpvs in pa + qs = max(qmin, eps * es / (plyr(i,k) + epsm1*es)) + rhly(i,k) = max(0.0, min(1.0, max(qmin, q1(i,k,1))/qs)) + qstl(i,k) = qs enddo enddo ! -! do k = 1, km -! do i = 1, im -! cfly(i,k) = 0. -! clwt = 1.0e-6 * (plyr(i,k)*0.001) -! if (qlx(i,k) > clwt) then -! onemrh= max(1.e-10, 1.0-rhly(i,k)) -! tem1 = min(max((onemrh*qstl(i,k))**0.49,0.0001),1.0) -! tem1 = cql / tem1 -! value = max(min( tem1*qlx(i,k), 50.0), 0.0) -! tem2 = sqrt(sqrt(rhly(i,k))) -! cfly(i,k) = max(tem2*(1.0-exp(-value)), 0.0) -! endif -! enddo -! enddo + do k = 1, km + do i = 1, im + cfly(i,k) = 0. + clwt = 1.0e-6 * (plyr(i,k)*0.001) + if (qlx(i,k) > clwt) then + onemrh= max(1.e-10, 1.0-rhly(i,k)) + tem1 = min(max((onemrh*qstl(i,k))**0.49,0.0001),1.0) + tem1 = cql / tem1 + value = max(min( tem1*qlx(i,k), 50.0), 0.0) + tem2 = sqrt(sqrt(rhly(i,k))) + cfly(i,k) = min(max(tem2*(1.0-exp(-value)), 0.0), 1.0) + endif + enddo + enddo ! ! compute buoyancy modified by clouds ! -! do k = 1, km1 -! do i = 1, im -! tem = 0.5 * (svx(i,k) + svx(i,k+1)) -! tem1 = 0.5 * (t1(i,k) + t1(i,k+1)) -! tem2 = 0.5 * (qstl(i,k) + qstl(i,k+1)) -! cfh = min(cfly(i,k+1),0.5*(cfly(i,k)+cfly(i,k+1))) -! alp = g / tem -! gamma = el2orc * tem2 / (tem1**2) -! epsi = tem1 / elocp -! beta = (1. + gamma*epsi*(1.+fv)) / (1. + gamma) -! chx = cfh * alp * beta + (1. - cfh) * alp -! cqx = cfh * alp * hvap * (beta - epsi) -! cqx = cqx + (1. - cfh) * fv * g -! ptem1 = (slx(i,k+1)-slx(i,k))*rdzt(i,k) -! ptem2 = (qtx(i,k+1)-qtx(i,k))*rdzt(i,k) -! bf(i,k) = chx * ptem1 + cqx * ptem2 -! enddo -! enddo + do k = 1, km1 + do i = 1, im + tem = 0.5 * (svx(i,k) + svx(i,k+1)) + tem1 = 0.5 * (t1(i,k) + t1(i,k+1)) + tem2 = 0.5 * (qstl(i,k) + qstl(i,k+1)) + cfh = min(cfly(i,k+1),0.5*(cfly(i,k)+cfly(i,k+1))) + alp = g / tem + gamma = el2orc * tem2 / (tem1**2) + epsi = tem1 / elocp + beta = (1. + gamma*epsi*(1.+fv)) / (1. + gamma) + chx = cfh * alp * beta + (1. - cfh) * alp + cqx = cfh * alp * hvap * (beta - epsi) + cqx = cqx + (1. - cfh) * fv * g + ptem1 = (slx(i,k+1)-slx(i,k))*rdzt(i,k) + ptem2 = (qtx(i,k+1)-qtx(i,k))*rdzt(i,k) + bf(i,k) = chx * ptem1 + cqx * ptem2 + enddo + enddo ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! @@ -453,7 +445,7 @@ subroutine satmedmfvdif(ix,im,km,ntrac,ntcw,ntiw,nthm,ntke, do k = 1, km1 do i = 1, im rdz = rdzt(i,k) - bf(i,k) = gotvx(i,k)*(thvx(i,k+1)-thvx(i,k))*rdz +! bf(i,k) = gotvx(i,k)*(thvx(i,k+1)-thvx(i,k))*rdz dw2 = (u1(i,k)-u1(i,k+1))**2 & + (v1(i,k)-v1(i,k+1))**2 shr2(i,k) = max(dw2,dw2min)*rdz*rdz @@ -690,13 +682,32 @@ subroutine satmedmfvdif(ix,im,km,ntrac,ntcw,ntiw,nthm,ntke, & tcdo,qcdo,ucdo,vcdo,xlamde) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! compute prandtl number +! compute prandtl number and exchange coefficient varying with height ! - do i = 1, im - prn(i) = phih(i)/phim(i) - prn(i) = min(prn(i),prmax) - prn(i) = max(prn(i),prmin) + do k = 1, kmpbl + do i = 1, im + if(k < kpbl(i)) then + tem = phih(i)/phim(i) + ptem = -3.*(max(zi(i,k+1)-sfcfrac*hpbl(i),0.))**2. + & /hpbl(i)**2. + if(pcnvflg(i)) then + prn(i,k) = 1. + (tem-1.)*exp(ptem) + else + prn(i,k) = tem + endif + prn(i,k) = min(prn(i,k),prmax) + prn(i,k) = max(prn(i,k),prmin) +! + ckz(i,k) = ck1 + (ck0-ck1)*exp(ptem) + ckz(i,k) = min(ckz(i,k),ck0) + ckz(i,k) = max(ckz(i,k),ck1) + chz(i,k) = ch1 + (ch0-ch1)*exp(ptem) + chz(i,k) = min(chz(i,k),ch0) + chz(i,k) = max(chz(i,k),ch1) + endif + enddo enddo + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! compute an asymtotic mixing length @@ -810,16 +821,16 @@ subroutine satmedmfvdif(ix,im,km,ntrac,ntcw,ntiw,nthm,ntke, tem = tem * sqrt(tkeh(i,k)) if(k < kpbl(i)) then if(pblflg(i)) then - dku(i,k) = ck0 * tem - dkt(i,k) = dku(i,k) / prn(i) + dku(i,k) = ckz(i,k) * tem + dkt(i,k) = dku(i,k) / prn(i,k) else - dkt(i,k) = ch0 * tem - dku(i,k) = dkt(i,k) * prn(i) + dkt(i,k) = chz(i,k) * tem + dku(i,k) = dkt(i,k) * prn(i,k) endif else ri = max(bf(i,k)/shr2(i,k),rimin) if(ri < 0.) then ! unstable regime - dku(i,k) = ck0 * tem + dku(i,k) = ck1 * tem dkt(i,k) = rchck * dku(i,k) else ! stable regime dkt(i,k) = ch1 * tem @@ -829,14 +840,14 @@ subroutine satmedmfvdif(ix,im,km,ntrac,ntcw,ntiw,nthm,ntke, endif endif ! -! if(scuflg(i)) then -! if(k >= mrad(i) .and. k < krad(i)) then -! tem1 = ck0 * tem -! ptem1 = tem1 / prscu -! dku(i,k) = max(dku(i,k), tem1) -! dkt(i,k) = max(dkt(i,k), ptem1) -! endif -! endif + if(scuflg(i)) then + if(k >= mrad(i) .and. k < krad(i)) then + tem1 = ckz(i,k) * tem + ptem1 = tem1 / prscu + dku(i,k) = max(dku(i,k), tem1) + dkt(i,k) = max(dkt(i,k), ptem1) + endif + endif ! dkq(i,k) = prtke * dkt(i,k) ! diff --git a/gfsphysics/physics/sfc_nst.f b/gfsphysics/physics/sfc_nst.f index 99f21bf6d..12fccb160 100644 --- a/gfsphysics/physics/sfc_nst.f +++ b/gfsphysics/physics/sfc_nst.f @@ -20,7 +20,7 @@ subroutine sfc_nst & !................................... ! --- inputs: - & ( im, km, ps, u1, v1, t1, q1, tref, cm, ch, & + & ( im, ps, u1, v1, t1, q1, tref, cm, ch, & & prsl1, prslki, islimsk, xlon, sinlat, stress, & & sfcemis, dlwflx, sfcnsw, rain, timestep, kdt, solhr,xcosz, & & ddvel, flag_iter, flag_guess, nstf_name, & @@ -40,7 +40,7 @@ subroutine sfc_nst & ! ! ! call sfc_nst ! ! inputs: ! -! ( im, km, ps, u1, v1, t1, q1, tref, cm, ch, ! +! ( im, ps, u1, v1, t1, q1, tref, cm, ch, ! ! prsl1, prslki, islimsk, xlon, sinlat, stress, ! ! sfcemis, dlwflx, sfcnsw, rain, timestep, kdt,solhr,xcosz, ! ! ddvel, flag_iter, flag_guess, nstf_name, ! @@ -76,7 +76,6 @@ subroutine sfc_nst & ! ! ! inputs: size ! ! im - integer, horiz dimension 1 ! -! km - integer, vertical dimension 1 ! ! ps - real, surface pressure (pa) im ! ! u1, v1 - real, u/v component of surface layer wind (m/s) im ! ! t1 - real, surface layer mean temperature ( k ) im ! @@ -182,7 +181,7 @@ subroutine sfc_nst & ! --- inputs: - integer, intent(in) :: im, km, kdt, ipr,nstf_name(5) + integer, intent(in) :: im, kdt, ipr,nstf_name(5) real (kind=kind_phys), dimension(im), intent(in) :: ps, u1, v1, & & t1, q1, tref, cm, ch, prsl1, prslki, xlon,xcosz, & & sinlat, stress, sfcemis, dlwflx, sfcnsw, rain, ddvel diff --git a/gfsphysics/physics/sfcsub.F b/gfsphysics/physics/sfcsub.F index 6bbae0276..753a43701 100644 --- a/gfsphysics/physics/sfcsub.F +++ b/gfsphysics/physics/sfcsub.F @@ -1997,7 +1997,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc ! if(lprnt) print *,'tsfclm=',tsfclm(iprnt),' tsfcl2=',tsfcl2(iprnt) ! *,' tsffcs=',tsffcs(iprnt),' slianl=',slianl(iprnt) - if (fh -deltsfc > 0.001) then + if (fh-deltsfc > -0.001 ) then do i=1,len if(slianl(i) == 0.0) then tsffcs(i) = tsffcs(i) + (tsfclm(i) - tsfcl2(i)) diff --git a/gfsphysics/physics/sflx.f b/gfsphysics/physics/sflx.f index 805ea3fc6..4c6f50197 100644 --- a/gfsphysics/physics/sflx.f +++ b/gfsphysics/physics/sflx.f @@ -325,7 +325,7 @@ subroutine sflx & endif ! --- ... lai sfc-perts, mgehne xlai = xlai * (1.+xlaip) - xlai = amax1(xlai, .75) + xlai = max(xlai, .75) ! --- ... initialize precipitation logicals. diff --git a/gfsphysics/physics/wv_saturation.F b/gfsphysics/physics/wv_saturation.F index fd52af551..55d9c55a3 100644 --- a/gfsphysics/physics/wv_saturation.F +++ b/gfsphysics/physics/wv_saturation.F @@ -9,9 +9,9 @@ module wv_saturation use MAPL_ConstantsMod, r8 => MAPL_R8 #endif #ifdef NEMS_GSM - use funcphys, only: fpvsl, fpvsi, fpvs ! saturation vapor pressure for water & ice + use funcphys, only : fpvsl, fpvsi, fpvs ! saturation vapor pressure for water & ice #endif - use machine, only: r8 => kind_phys + use machine, only : r8 => kind_phys !++jtb (comm out) diff --git a/io/FV3GFS_io.F90 b/io/FV3GFS_io.F90 index a3a438a91..5897d1cf1 100644 --- a/io/FV3GFS_io.F90 +++ b/io/FV3GFS_io.F90 @@ -554,6 +554,7 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) call mpp_error(NOTE,'reading surface properties data from INPUT/sfc_data.tile*.nc') call restore_state(Sfc_restart) +! write(0,*)' sfc_var2=',sfc_var2(:,:,12) !--- place the data into the block GFS containers do nb = 1, Atm_block%nblks do ix = 1, Atm_block%blksz(nb) @@ -1762,46 +1763,36 @@ subroutine fv_phys_bundle_setup(Diag, axes, phys_bundle, fcst_grid, quilting, nb ! 'bdl_intplmethod=',trim(bdl_intplmethod(ibdl)) call ESMF_AttributeAdd(phys_bundle(ibdl), convention="NetCDF", purpose="FV3", & - attrList=(/ "fhzero ", & - & "ncld ", & - & "nsoil ", & - & "imp_physics", & - & "dtp " /), rc=rc) + attrList=(/"fhzero", "ncld", "nsoil", "imp_physics", "dtp"/), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_AttributeSet(phys_bundle(ibdl), convention="NetCDF", purpose="FV3", & name="fhzero", value=fhzero, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_AttributeSet(phys_bundle(ibdl), convention="NetCDF", purpose="FV3", & name="ncld", value=ncld, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_AttributeSet(phys_bundle(ibdl), convention="NetCDF", purpose="FV3", & name="nsoil", value=nsoil, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_AttributeSet(phys_bundle(ibdl), convention="NetCDF", purpose="FV3", & name="imp_physics", value=imp_physics, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_AttributeSet(phys_bundle(ibdl), convention="NetCDF", purpose="FV3", & name="dtp", value=dtp, rc=rc) ! print *,'in fcst gfdl diag, dtp=',dtp,' ibdl=',ibdl if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out !end ibdl enddo @@ -1820,15 +1811,11 @@ subroutine fv_phys_bundle_setup(Diag, axes, phys_bundle, fcst_grid, quilting, nb call ESMF_AttributeAdd(fcst_grid, convention="NetCDF", purpose="FV3", & attrList=(/"vertical_dim_labels"/), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out call ESMF_AttributeSet(fcst_grid, convention="NetCDF", purpose="FV3", & name="vertical_dim_labels", valueList=axis_name_vert, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out endif !*** add attributes @@ -1863,33 +1850,28 @@ subroutine fv_phys_bundle_setup(Diag, axes, phys_bundle, fcst_grid, quilting, nb trim(axis_name(id))//":positive"/), rc=rc) endif if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_AttributeSet(fcst_grid, convention="NetCDF", purpose="FV3", & name=trim(axis_name(id)), valueList=axis_data, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_AttributeSet(fcst_grid, convention="NetCDF", purpose="FV3", & name=trim(axis_name(id))//":long_name", value=trim(long_name), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_AttributeSet(fcst_grid, convention="NetCDF", purpose="FV3", & name=trim(axis_name(id))//":units", value=trim(units), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_AttributeSet(fcst_grid, convention="NetCDF", purpose="FV3", & name=trim(axis_name(id))//":cartesian_axis", value=trim(cart_name), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + if(direction>0) then axis_direct="up" else @@ -1898,16 +1880,13 @@ subroutine fv_phys_bundle_setup(Diag, axes, phys_bundle, fcst_grid, quilting, nb call ESMF_AttributeSet(fcst_grid, convention="NetCDF", purpose="FV3", & name=trim(axis_name(id))//":positive", value=trim(axis_direct), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + if(trim(edgesS)/='') then call ESMF_AttributeSet(fcst_grid, convention="NetCDF", purpose="FV3", & name=trim(axis_name(id))//":edges", value=trim(edgesS), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out endif endif @@ -2000,39 +1979,34 @@ subroutine add_field_to_phybundle(var_name,long_name,units,cell_methods, axes,ph ! if( mpp_root_pe() == 0) print *,'phys, create wind vector esmf field' call ESMF_LogWrite('bf create winde vector esmf field '//trim(var_name), ESMF_LOGMSG_INFO, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + !datacopyflag=ESMF_DATACOPY_VALUE, & field = ESMF_FieldCreate(phys_grid, temp_r3d, datacopyflag=ESMF_DATACOPY_REFERENCE, & gridToFieldMap=(/2,3/), ungriddedLBound=(/1/), ungriddedUBound=(/3/), & name=var_name, indexFlag=ESMF_INDEX_DELOCAL, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out call ESMF_LogWrite('af winde vector esmf field create '//trim(var_name), ESMF_LOGMSG_INFO, rc=rc) call ESMF_AttributeAdd(field, convention="NetCDF", purpose="FV3", & attrList=(/"output_file"/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - call ESMF_Finalize(endflag=ESMF_END_ABORT) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) call ESMF_Finalize(endflag=ESMF_END_ABORT) + call ESMF_AttributeSet(field, convention="NetCDF", purpose="FV3", & name='output_file',value=trim(output_file),rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - call ESMF_Finalize(endflag=ESMF_END_ABORT) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) call ESMF_Finalize(endflag=ESMF_END_ABORT) + call ESMF_LogWrite('before winde vector esmf field add output_file', ESMF_LOGMSG_INFO, rc=rc) ! if( mpp_root_pe() == 0)print *,'phys, aftercreate wind vector esmf field' call ESMF_FieldBundleAdd(phys_bundle,(/field/), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - call ESMF_Finalize(endflag=ESMF_END_ABORT) + line=__LINE__, file=__FILE__)) call ESMF_Finalize(endflag=ESMF_END_ABORT) + if( present(rcd)) rcd=rc call ESMF_LogWrite('aft winde vector esmf field add to fieldbundle'//trim(var_name), ESMF_LOGMSG_INFO, rc=rc) return @@ -2041,18 +2015,15 @@ subroutine add_field_to_phybundle(var_name,long_name,units,cell_methods, axes,ph temp_r2d => buffer_phys_nb(isco:ieco,jsco:jeco,kstt) field = ESMF_FieldCreate(phys_grid, temp_r2d, datacopyflag=copyflag, & name=var_name, indexFlag=ESMF_INDEX_DELOCAL, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - call ESMF_Finalize(endflag=ESMF_END_ABORT) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) call ESMF_Finalize(endflag=ESMF_END_ABORT) + else if(size(axes) == 3) then temp_r3d => buffer_phys_nb(isco:ieco,jsco:jeco,kstt:kstt+levo-1) field = ESMF_FieldCreate(phys_grid, temp_r3d, datacopyflag=copyflag, & name=var_name, indexFlag=ESMF_INDEX_DELOCAL, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - call ESMF_Finalize(endflag=ESMF_END_ABORT) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) call ESMF_Finalize(endflag=ESMF_END_ABORT) if( mpp_root_pe() == 0) print *,'add 3D field to after nearest_stod, fld=', trim(var_name) endif @@ -2061,18 +2032,14 @@ subroutine add_field_to_phybundle(var_name,long_name,units,cell_methods, axes,ph temp_r2d => buffer_phys_bl(isco:ieco,jsco:jeco,kstt) field = ESMF_FieldCreate(phys_grid, temp_r2d, datacopyflag=copyflag, & name=var_name, indexFlag=ESMF_INDEX_DELOCAL, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - call ESMF_Finalize(endflag=ESMF_END_ABORT) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) call ESMF_Finalize(endflag=ESMF_END_ABORT) else if(size(axes) == 3) then temp_r3d => buffer_phys_bl(isco:ieco,jsco:jeco,kstt:kstt+levo-1) field = ESMF_FieldCreate(phys_grid, temp_r3d, datacopyflag=copyflag, & name=var_name, indexFlag=ESMF_INDEX_DELOCAL, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - call ESMF_Finalize(endflag=ESMF_END_ABORT) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) call ESMF_Finalize(endflag=ESMF_END_ABORT) if( mpp_root_pe() == 0) print *,'add field to after bilinear, fld=', trim(var_name) endif endif @@ -2080,81 +2047,63 @@ subroutine add_field_to_phybundle(var_name,long_name,units,cell_methods, axes,ph !*** add field attributes call ESMF_AttributeAdd(field, convention="NetCDF", purpose="FV3", & attrList=(/"long_name"/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - call ESMF_Finalize(endflag=ESMF_END_ABORT) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) call ESMF_Finalize(endflag=ESMF_END_ABORT) + call ESMF_AttributeSet(field, convention="NetCDF", purpose="FV3", & name='long_name',value=trim(long_name),rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - call ESMF_Finalize(endflag=ESMF_END_ABORT) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_AttributeAdd(field, convention="NetCDF", purpose="FV3", & attrList=(/"units"/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - call ESMF_Finalize(endflag=ESMF_END_ABORT) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) call ESMF_Finalize(endflag=ESMF_END_ABORT) + call ESMF_AttributeSet(field, convention="NetCDF", purpose="FV3", & name='units',value=trim(units),rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - call ESMF_Finalize(endflag=ESMF_END_ABORT) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_AttributeAdd(field, convention="NetCDF", purpose="FV3", & attrList=(/"missing_value"/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - call ESMF_Finalize(endflag=ESMF_END_ABORT) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) call ESMF_Finalize(endflag=ESMF_END_ABORT) + call ESMF_AttributeSet(field, convention="NetCDF", purpose="FV3", & name='missing_value',value=missing_value,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - call ESMF_Finalize(endflag=ESMF_END_ABORT) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_AttributeAdd(field, convention="NetCDF", purpose="FV3", & attrList=(/"_FillValue"/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - call ESMF_Finalize(endflag=ESMF_END_ABORT) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) call ESMF_Finalize(endflag=ESMF_END_ABORT) + call ESMF_AttributeSet(field, convention="NetCDF", purpose="FV3", & name='_FillValue',value=missing_value,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - call ESMF_Finalize(endflag=ESMF_END_ABORT) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_AttributeAdd(field, convention="NetCDF", purpose="FV3", & attrList=(/"cell_methods"/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - call ESMF_Finalize(endflag=ESMF_END_ABORT) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) call ESMF_Finalize(endflag=ESMF_END_ABORT) + call ESMF_AttributeSet(field, convention="NetCDF", purpose="FV3", & name='cell_methods',value=trim(cell_methods),rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - call ESMF_Finalize(endflag=ESMF_END_ABORT) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) call ESMF_Finalize(endflag=ESMF_END_ABORT) ! call ESMF_AttributeAdd(field, convention="NetCDF", purpose="FV3", & attrList=(/"output_file"/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - call ESMF_Finalize(endflag=ESMF_END_ABORT) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) call ESMF_Finalize(endflag=ESMF_END_ABORT) + call ESMF_AttributeSet(field, convention="NetCDF", purpose="FV3", & name='output_file',value=trim(output_file),rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - call ESMF_Finalize(endflag=ESMF_END_ABORT) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) call ESMF_Finalize(endflag=ESMF_END_ABORT) ! !*** add vertical coord attribute: @@ -2170,16 +2119,12 @@ subroutine add_field_to_phybundle(var_name,long_name,units,cell_methods, axes,ph if (idx>0) then call ESMF_AttributeAdd(field, convention="NetCDF", purpose="FV3", & attrList=(/"ESMF:ungridded_dim_labels"/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out call ESMF_AttributeSet(field, convention="NetCDF", purpose="FV3", & name="ESMF:ungridded_dim_labels", valueList=(/trim(axis_name(idx))/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out endif enddo endif diff --git a/io/module_write_nemsio.F90 b/io/module_write_nemsio.F90 index bf773c73d..3afd66789 100644 --- a/io/module_write_nemsio.F90 +++ b/io/module_write_nemsio.F90 @@ -18,19 +18,19 @@ module module_write_nemsio character(16),dimension(3000,5) :: recname,reclevtyp integer,dimension(3000,5) :: reclev - integer,dimension(:), allocatable :: nrec - integer,dimension(:), allocatable :: idsl, idvc,idvm - integer,dimension(:), allocatable :: fieldcount + integer, dimension(:), allocatable :: nrec + integer, dimension(:), allocatable :: idsl, idvc,idvm + integer, dimension(:), allocatable :: fieldcount integer, dimension(:), allocatable :: idisp, irecv ! integer,dimension(:), allocatable :: nmetavari,nmetavarc, nmetavarr4,nmetavarr8 integer,dimension(:), allocatable :: nmetaaryi,nmetaaryc, nmetaaryr4,nmetaaryr8 character(16),dimension(:,:),allocatable :: variname, varcname, varr4name, varr8name character(16),dimension(:,:),allocatable :: aryiname - integer, dimension(:,:), allocatable :: varival, aryilen - integer, dimension(:,:,:), allocatable :: aryival - real(4), dimension(:,:), allocatable :: varr4val - real(8), dimension(:,:), allocatable :: varr8val + integer, dimension(:,:), allocatable :: varival, aryilen + integer, dimension(:,:,:), allocatable :: aryival + real(4), dimension(:,:), allocatable :: varr4val + real(8), dimension(:,:), allocatable :: varr8val character(16), dimension(:,:), allocatable :: varcval logical, dimension(:), allocatable :: extrameta ! @@ -381,6 +381,7 @@ subroutine write_nemsio(fieldbundle, filename, nf_hours, & jend = ubound(arrayr82d,2) nlen = (iend-istart+1) * (jend-jstart+1) allocate( arrayr42d(istart:iend,jstart:jend)) +!$omp parallel do default(none) shared(arrayr42d,arrayr82d,jstart,jend,istart,iend) private(m,n) do n=jstart,jend do m=istart,iend arrayr42d(m,n) = arrayr82d(m,n) @@ -454,28 +455,30 @@ subroutine write_nemsio(fieldbundle, filename, nf_hours, & allocate(arrayr42d(istart:iend,jstart:jend)) ! do k=kstart,kend if ( write_nemsioflip ) then - k1=kend; k2=kstart; k3=-1 + k1=kend ; k2=kstart ; k3=-1 else - k1=kstart; k2=kend; k3=1 + k1=kstart ; k2=kend ; k3=1 endif do k=k1,k2,k3 if (typekind == ESMF_TYPEKIND_R4) then +!$omp parallel do default(none) shared(arrayr42d,arrayr43d,jstart,jend,istart,iend,k) private(m,n) do n=jstart,jend do m=istart,iend - arrayr42d(m,n)=arrayr43d(m,n,k) + arrayr42d(m,n) = arrayr43d(m,n,k) enddo enddo elseif (typekind == ESMF_TYPEKIND_R8) then +!$omp parallel do default(none) shared(arrayr42d,arrayr83d,jstart,jend,istart,iend,k) private(m,n) do n=jstart,jend do m=istart,iend - arrayr42d(m,n)=arrayr83d(m,n,k) + arrayr42d(m,n) = arrayr83d(m,n,k) enddo enddo endif ! call mpi_gatherv(arrayr42d, nlen, MPI_REAL, arrayr4, irecv,idisp, MPI_REAL, & - 0, mpi_comm, rc) - if(mype==0) then + 0, mpi_comm, rc) + if(mype == 0) then tmp = reshape(arrayr4, (/im*jm/)) call nemsio_writerec(nemsiofile, jrec, tmp, iret=rc) jrec = jrec + 1 @@ -549,7 +552,7 @@ subroutine get_global_attr(fldbundle, mybdl, rc) ! ! look at the field bundle attributes call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & - attnestflag=ESMF_ATTNEST_OFF, Count=attcount, rc=rc) + attnestflag=ESMF_ATTNEST_OFF, Count=attcount, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & line=__LINE__, & file=__FILE__)) & @@ -755,19 +758,19 @@ subroutine get_global_attr(fldbundle, mybdl, rc) enddo ! if(write_nemsioflip) then - nc=nc+1 + nc = nc + 1 varcname(nc,mybdl) = 'y-direction' - varcval(nc,mybdl) = 'north2south' - nc=nc+1 + varcval(nc,mybdl) = 'north2south' + nc = nc + 1 varcname(nc,mybdl) = 'z-direction' - varcval(nc,mybdl) = 'bottom2top' + varcval(nc,mybdl) = 'bottom2top' else - nc=nc+1 + nc = nc + 1 varcname(nc,mybdl) = 'y-direction' - varcval(nc,mybdl) = 'south2north' - nc=nc+1 + varcval(nc,mybdl) = 'south2north' + nc = nc + 1 varcname(nc,mybdl) = 'z-direction' - varcval(nc,mybdl) = 'top2bottom' + varcval(nc,mybdl) = 'top2bottom' endif ! !output lpl diff --git a/io/module_wrt_grid_comp.F90 b/io/module_wrt_grid_comp.F90 index 9671a5388..c18afab19 100644 --- a/io/module_wrt_grid_comp.F90 +++ b/io/module_wrt_grid_comp.F90 @@ -40,6 +40,7 @@ module module_wrt_grid_comp stdlat1, stdlat2, dx, dy use module_write_nemsio, only : nemsio_first_call, write_nemsio use module_write_netcdf, only : write_netcdf + use physcons, only : pi => con_pi ! !----------------------------------------------------------------------- ! @@ -54,7 +55,7 @@ module module_wrt_grid_comp !----------------------------------------------------------------------- ! integer,parameter :: filename_maxstr=255 - real(8),parameter :: pi=3.14159265358979d0 +! real(8),parameter :: pi=3.14159265358979d0 real, parameter :: rdgas=287.04, grav=9.80 real, parameter :: stndrd_atmos_ps = 101325. real, parameter :: stndrd_atmos_lapse = 0.0065 @@ -80,6 +81,7 @@ module module_wrt_grid_comp !----------------------------------------------------------------------- REAL(KIND=8) :: btim,btim0 REAL(KIND=8),PUBLIC,SAVE :: write_init_tim, write_run_tim + REAL(KIND=8), parameter :: radi=180.0d0/pi !----------------------------------------------------------------------- ! public SetServices @@ -170,18 +172,17 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) real(ESMF_KIND_R8) :: valueR8 integer :: attCount, axeslen, jidx, noutfile - real(8) :: radi character(128) :: FBlist_outfilename(100), outfile_name character(128),dimension(:,:), allocatable :: outfilename - real(8), dimension(:), allocatable :: slat - real, dimension(:), allocatable :: lat, lon, axesdata + real(8), dimension(:), allocatable :: slat + real, dimension(:), allocatable :: lat, lon, axesdata real(ESMF_KIND_R8), dimension(:,:), pointer :: lonPtr, latPtr real(ESMF_KIND_R8) :: rot_lon, rot_lat real(ESMF_KIND_R8) :: geo_lon, geo_lat real(ESMF_KIND_R8) :: lon1_r8, lat1_r8 real(ESMF_KIND_R8) :: x1, y1, x, y type(ESMF_DataCopy_Flag) :: copyflag=ESMF_DATACOPY_REFERENCE - real(8),parameter :: PI=3.14159265358979d0 +! real(8),parameter :: PI=3.14159265358979d0 character(256) :: gridfile @@ -212,18 +213,14 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) wrap%write_int_state => wrt_int_state call ESMF_GridCompSetInternalState(wrt_comp, wrap, rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out allocate(wrt_int_state%wrtFB(num_files)) ! call ESMF_VMGetCurrent(vm=VM,rc=RC) call ESMF_VMGet(vm=VM, localPet=wrt_int_state%mype, & petCount=wrt_int_state%petcount,mpiCommunicator=vm_mpi_comm,rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out call mpi_comm_dup(vm_mpi_comm,wrt_mpi_comm,rc) ntasks = wrt_int_state%petcount jidx = wrt_int_state%petcount/6 @@ -248,10 +245,9 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) call ESMF_AttributeGet(imp_state_write, convention="NetCDF", purpose="FV3", & name="gridfile", value=gridfile, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out CALL ESMF_LogWrite("wrtComp: gridfile:"//trim(gridfile),ESMF_LOGMSG_INFO,rc=rc) @@ -259,10 +255,9 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) regDecompPTile=decomptile,tileFilePath="INPUT/", & staggerlocList=(/ESMF_STAGGERLOC_CENTER, ESMF_STAGGERLOC_CORNER/), & name='wrt_grid', rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out else if ( trim(output_grid) == 'gaussian_grid') then wrtgrid = ESMF_GridCreate1PeriDim(minIndex=(/1,1/), & @@ -272,29 +267,22 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) ! indexflag=ESMF_INDEX_GLOBAL, coordSys=ESMF_COORDSYS_SPH_DEG if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_GridAddCoord(wrtgrid, staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out call ESMF_GridGetCoord(wrtgrid, coordDim=1, farrayPtr=lonPtr, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_GridGetCoord(wrtgrid, coordDim=2, farrayPtr=latPtr, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! - allocate(slat(jmo),lat(jmo), lon(imo)) - call splat(4,jmo, slat) - radi = 180.0d0/(4.d0*atan(1.0d0)) + allocate(slat(jmo), lat(jmo), lon(imo)) + call splat(4, jmo, slat) if(write_nemsioflip) then do j=1,jmo lat(j) = asin(slat(j)) * radi @@ -324,10 +312,9 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) minCornerCoord=(/0._ESMF_KIND_R8, -80._ESMF_KIND_R8/), & maxCornerCoord=(/360._ESMF_KIND_R8, 80._ESMF_KIND_R8/), & staggerLocList=(/ESMF_STAGGERLOC_CENTER, ESMF_STAGGERLOC_CORNER/), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! if(wrt_int_state%mype == lead_write_task) print *,'af wrtgrd, latlon,rc=',rc, & ! 'imo=',imo,' jmo=',jmo @@ -339,27 +326,21 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) maxIndex=(/imo,jmo/), regDecomp=(/1,ntasks/), & indexflag=ESMF_INDEX_GLOBAL, & name='wrt_grid',rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out call ESMF_GridAddCoord(wrtgrid, staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out call ESMF_GridGetCoord(wrtgrid, coordDim=1, farrayPtr=lonPtr, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_GridGetCoord(wrtgrid, coordDim=2, farrayPtr=latPtr, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out if ( trim(output_grid) == 'regional_latlon' ) then do j=lbound(lonPtr,2),ubound(lonPtr,2) @@ -411,18 +392,17 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) ! !--- check grid dim count first call ESMF_GridGet(wrtgrid, dimCount=gridDimCount, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! !--- Look at the incoming FieldBundles in the imp_state_write, and mirror them ! call ESMF_StateGet(imp_state_write, itemCount=FBCount, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + wrt_int_state%FBCount = FBCount ! if(wrt_int_state%mype == lead_write_task) print *,'in wrt,fcst FBCount=',FBCount @@ -434,11 +414,10 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) outfilename='' call ESMF_StateGet(imp_state_write, itemNameList=fcstItemNameList, & - itemTypeList=fcstItemTypeList, rc=rc) + itemTypeList=fcstItemTypeList, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out !loop over all items in the imp_state_write and collect all FieldBundles do i=1, FBcount @@ -446,55 +425,50 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) if (fcstItemTypeList(i)==ESMF_STATEITEM_FIELDBUNDLE) then call ESMF_StateGet(imp_state_write, itemName=fcstItemNameList(i), & - fieldbundle=fcstFB, rc=rc) + fieldbundle=fcstFB, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! create a mirror FieldBundle and add it to importState fieldbundle = ESMF_FieldBundleCreate(name="mirror_"//trim(fcstItemNameList(i)), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_StateAdd(imp_state_write, (/fieldbundle/), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! copy the fcstFB Attributes to the mirror FieldBundle call ESMF_AttributeCopy(fcstFB, fieldbundle, & attcopy=ESMF_ATTCOPY_REFERENCE, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! call ESMF_FieldBundleGet(fcstFB, fieldCount=fieldCount, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + wrt_int_state%ncount_fields(i) = fieldCount allocate(fcstField(fieldCount)) call ESMF_FieldBundleGet(fcstFB, fieldList=fcstField, & - itemorderflag=ESMF_ITEMORDER_ADDORDER, rc=rc) + itemorderflag=ESMF_ITEMORDER_ADDORDER, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out do j=1, fieldCount call ESMF_FieldGet(fcstField(j), typekind=typekind, & dimCount=fieldDimCount, name=fieldName, grid=fcstGrid, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out allocate(gridToFieldMap(gridDimCount)) allocate(ungriddedLBound(fieldDimCount-gridDimCount)) @@ -507,10 +481,9 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) ! trim(fieldname),'fieldDimCount=',fieldDimCount,'gridDimCount=',gridDimCount, & ! 'gridToFieldMap=',gridToFieldMap,'ungriddedLBound=',ungriddedLBound, & ! 'ungriddedUBound=',ungriddedUBound,'rc=',rc + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! create the mirror field @@ -519,26 +492,25 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) gridToFieldMap=gridToFieldMap, ungriddedLBound=ungriddedLBound, & ungriddedUBound=ungriddedUBound, rc=rc) CALL ESMF_LogWrite("aft call field create on wrt comp",ESMF_LOGMSG_INFO,rc=RC) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + wrt_int_state%field_names(j,i) = trim(fieldName) call ESMF_AttributeCopy(fcstField(j), field_work, & attcopy=ESMF_ATTCOPY_REFERENCE, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! ! get output file name call ESMF_AttributeGet(fcstField(i), convention="NetCDF", purpose="FV3", & name="output_file", value=outfile_name, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + CALL ESMF_LogWrite("bf fcstfield, get output_file"//trim(outfile_name)//trim(fieldName),ESMF_LOGMSG_INFO,rc=RC) if( trim(outfile_name) /= '') then outfilename(j,i) = trim(outfile_name) @@ -548,10 +520,9 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) ! add the mirror field to the mirror FieldBundle call ESMF_FieldBundleAdd(fieldbundle, (/field_work/), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! local garbage collection deallocate(gridToFieldMap, ungriddedLBound, ungriddedUBound) @@ -560,10 +531,9 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) if (fieldCount>0) then call ESMF_AttributeCopy(fcstGrid, wrtGrid, & attcopy=ESMF_ATTCOPY_REFERENCE, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out endif deallocate(fcstField) @@ -588,15 +558,14 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) wrt_int_state%wrtFB_names(i) = trim(FBlist_outfilename(i)) wrt_int_state%wrtFB(i) = ESMF_FieldBundleCreate(name=trim(wrt_int_state%wrtFB_names(i)), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out do n=1, FBcount call ESMF_StateGet(imp_state_write, itemName="mirror_"//trim(fcstItemNameList(n)), & - fieldbundle=fcstFB, rc=rc) + fieldbundle=fcstFB, rc=rc) ! if(wrt_int_state%mype == lead_write_task) print *,'in wrt,fcstItemNameList(n)=', & ! trim(fcstItemNameList(n)),' FBlist_outfilename=',trim(FBlist_outfilename(i)) @@ -605,34 +574,30 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) ! ! copy the mirror fcstfield bundle Attributes to the output field bundle call ESMF_AttributeCopy(fcstFB, wrt_int_state%wrtFB(i), & - attcopy=ESMF_ATTCOPY_REFERENCE, rc=rc) + attcopy=ESMF_ATTCOPY_REFERENCE, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! call ESMF_FieldBundleGet(fcstFB, fieldCount=fieldCount, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out allocate(fcstField(fieldCount),fieldnamelist(fieldCount)) call ESMF_FieldBundleGet(fcstFB, fieldList=fcstField, fieldNameList=fieldnamelist, & - itemorderflag=ESMF_ITEMORDER_ADDORDER, rc=rc) + itemorderflag=ESMF_ITEMORDER_ADDORDER, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out do j=1, fieldCount call ESMF_AttributeGet(fcstField(j),convention="NetCDF", purpose="FV3", & - name='output_file',value=outfile_name, rc=rc) + name='output_file',value=outfile_name, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! if(wrt_int_state%mype == lead_write_task) print *,'in wrt,add field,i=',i,'n=',n,' j=',j, & ! 'fieldname=',trim(fieldnamelist(j)), ' outfile_name=',trim(outfile_name), & @@ -640,10 +605,9 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) if( trim(outfile_name) == trim(FBlist_outfilename(i))) then call ESMF_FieldBundleAdd(wrt_int_state%wrtFB(i), (/fcstField(j)/), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out endif enddo @@ -657,94 +621,94 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) if ( .not. (trim(output_grid) == 'cubed_sphere_grid' .or. trim(output_grid) == 'gaussian_grid') ) then !!!!!!! call ESMF_AttributeAdd(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - attrList=(/"source","grid"/), rc=rc) + attrList=(/"source","grid"/), rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="source", value="FV3GFS", rc=rc) + name="source", value="FV3GFS", rc=rc) if (trim(output_grid) == 'cubed_sphere_grid') then call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="grid", value="cubed_sphere", rc=rc) + name="grid", value="cubed_sphere", rc=rc) else if (trim(output_grid) == 'gaussian_grid') then call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="grid", value="gaussian", rc=rc) + name="grid", value="gaussian", rc=rc) call ESMF_AttributeAdd(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - attrList=(/"im","jm"/), rc=rc) + attrList=(/"im","jm"/), rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="im", value=imo, rc=rc) + name="im", value=imo, rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="jm", value=jmo, rc=rc) + name="jm", value=jmo, rc=rc) else if (trim(output_grid) == 'regional_latlon') then call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="grid", value="latlon", rc=rc) + name="grid", value="latlon", rc=rc) call ESMF_AttributeAdd(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - attrList=(/"lon1","lat1","lon2","lat2","dlon","dlat"/), rc=rc) + attrList=(/"lon1","lat1","lon2","lat2","dlon","dlat"/), rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="lon1", value=lon1, rc=rc) + name="lon1", value=lon1, rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="lat1", value=lat1, rc=rc) + name="lat1", value=lat1, rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="lon2", value=lon2, rc=rc) + name="lon2", value=lon2, rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="lat2", value=lat2, rc=rc) + name="lat2", value=lat2, rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="dlon", value=dlon, rc=rc) + name="dlon", value=dlon, rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="dlat", value=dlat, rc=rc) + name="dlat", value=dlat, rc=rc) else if (trim(output_grid) == 'rotated_latlon') then call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="grid", value="rotated_latlon", rc=rc) + name="grid", value="rotated_latlon", rc=rc) call ESMF_AttributeAdd(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - attrList=(/"cen_lon","cen_lat","lon1","lat1","lon2","lat2","dlon","dlat"/), rc=rc) + attrList=(/"cen_lon","cen_lat","lon1","lat1","lon2","lat2","dlon","dlat"/), rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="cen_lon", value=cen_lon, rc=rc) + name="cen_lon", value=cen_lon, rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="cen_lat", value=cen_lat, rc=rc) + name="cen_lat", value=cen_lat, rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="lon1", value=lon1, rc=rc) + name="lon1", value=lon1, rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="lat1", value=lat1, rc=rc) + name="lat1", value=lat1, rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="lon2", value=lon2, rc=rc) + name="lon2", value=lon2, rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="lat2", value=lat2, rc=rc) + name="lat2", value=lat2, rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="dlon", value=dlon, rc=rc) + name="dlon", value=dlon, rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="dlat", value=dlat, rc=rc) + name="dlat", value=dlat, rc=rc) else if (trim(output_grid) == 'lambert_conformal') then call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="grid", value="lambert_conformal", rc=rc) + name="grid", value="lambert_conformal", rc=rc) call ESMF_AttributeAdd(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - attrList=(/"cen_lon","cen_lat","stdlat1","stdlat2","nx","ny","lon1","lat1","dx","dy"/), rc=rc) + attrList=(/"cen_lon","cen_lat","stdlat1","stdlat2","nx","ny","lon1","lat1","dx","dy"/), rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="cen_lon", value=cen_lon, rc=rc) + name="cen_lon", value=cen_lon, rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="cen_lat", value=cen_lat, rc=rc) + name="cen_lat", value=cen_lat, rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="stdlat1", value=stdlat1, rc=rc) + name="stdlat1", value=stdlat1, rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="stdlat2", value=stdlat2, rc=rc) + name="stdlat2", value=stdlat2, rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="nx", value=imo, rc=rc) + name="nx", value=imo, rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="ny", value=jmo, rc=rc) + name="ny", value=jmo, rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="lat1", value=lat1, rc=rc) + name="lat1", value=lat1, rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="lon1", value=lon1, rc=rc) + name="lon1", value=lon1, rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="dx", value=dx, rc=rc) + name="dx", value=dx, rc=rc) call ESMF_AttributeSet(wrt_int_state%wrtFB(i), convention="NetCDF", purpose="FV3", & - name="dy", value=dy, rc=rc) + name="dy", value=dy, rc=rc) end if @@ -759,11 +723,11 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) ! look at the importState attributes and copy those starting with "time" call ESMF_AttributeGet(imp_state_write, convention="NetCDF", purpose="FV3", & - attnestflag=ESMF_ATTNEST_OFF, count=attCount, rc=rc) + attnestflag=ESMF_ATTNEST_OFF, count=attCount, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_LogWrite("Write component AttributeGet, attCount ", ESMF_LOGMSG_INFO, rc=rc) ! prepare the lists needed to transfer attributes @@ -775,254 +739,239 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) k=1 do i=1, attCount call ESMF_AttributeGet(imp_state_write, convention="NetCDF", purpose="FV3", & - attnestflag=ESMF_ATTNEST_OFF, attributeIndex=i, name=attName, & - typekind=typekind, rc=rc) + attnestflag=ESMF_ATTNEST_OFF, attributeIndex=i, name=attName, & + typekind=typekind, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! test for name starting with "time" if (index(trim(attName), "time")==1) then ! add this attribute to the list of transfers - attNameList(j)=attName - typekindList(j)=typekind + attNameList(j) = attName + typekindList(j) = typekind j=j+1 if (index(trim(attName), "time:")==1) then ! store names of attributes starting with "time:" for later use - attNameList2(k)=attName - k=k+1 + attNameList2(k) = attName + k = k+1 endif endif enddo ! add the transfer attributes from importState to grid call ESMF_AttributeAdd(wrtgrid, convention="NetCDF", purpose="FV3", & - attrList=attNameList(1:j-1), rc=rc) + attrList=attNameList(1:j-1), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! loop over the added attributes, access the value (only scalar allowed), ! and set them on the grid do i=1, j-1 if (typekindList(i)==ESMF_TYPEKIND_CHARACTER) then - call ESMF_AttributeGet(imp_state_write, & - convention="NetCDF", purpose="FV3", & - name=trim(attNameList(i)), value=valueS, rc=rc) + call ESMF_AttributeGet(imp_state_write, & + convention="NetCDF", purpose="FV3", & + name=trim(attNameList(i)), value=valueS, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_AttributeSet(wrtgrid, convention="NetCDF", purpose="FV3", & - name=trim(attNameList(i)), value=valueS, rc=rc) + name=trim(attNameList(i)), value=valueS, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + else if (typekindList(i)==ESMF_TYPEKIND_I4) then - call ESMF_AttributeGet(imp_state_write, & - convention="NetCDF", purpose="FV3", & - name=trim(attNameList(i)), value=valueI4, rc=rc) + call ESMF_AttributeGet(imp_state_write, & + convention="NetCDF", purpose="FV3", & + name=trim(attNameList(i)), value=valueI4, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_AttributeSet(wrtgrid, convention="NetCDF", purpose="FV3", & name=trim(attNameList(i)), value=valueI4, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + else if (typekindList(i)==ESMF_TYPEKIND_R4) then - call ESMF_AttributeGet(imp_state_write, & - convention="NetCDF", purpose="FV3", & - name=trim(attNameList(i)), value=valueR4, rc=rc) + call ESMF_AttributeGet(imp_state_write, & + convention="NetCDF", purpose="FV3", & + name=trim(attNameList(i)), value=valueR4, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_AttributeSet(wrtgrid, convention="NetCDF", purpose="FV3", & - name=trim(attNameList(i)), value=valueR4, rc=rc) + name=trim(attNameList(i)), value=valueR4, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + else if (typekindList(i)==ESMF_TYPEKIND_R8) then - call ESMF_AttributeGet(imp_state_write, & - convention="NetCDF", purpose="FV3", & - name=trim(attNameList(i)), value=valueR8, rc=rc) + call ESMF_AttributeGet(imp_state_write, & + convention="NetCDF", purpose="FV3", & + name=trim(attNameList(i)), value=valueR8, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_AttributeSet(wrtgrid, convention="NetCDF", purpose="FV3", & - name=trim(attNameList(i)), value=valueR8, rc=rc) + name=trim(attNameList(i)), value=valueR8, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out endif enddo ! Add special attribute that holds names of "time" related attributes ! for faster access during Run(). call ESMF_AttributeAdd(wrtgrid, convention="NetCDF", purpose="FV3", & - attrList=(/"TimeAttributes"/), rc=rc) + attrList=(/"TimeAttributes"/), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_AttributeSet(wrtgrid, convention="NetCDF", purpose="FV3", & - name="TimeAttributes", valueList=attNameList2(1:k-1), rc=rc) + name="TimeAttributes", valueList=attNameList2(1:k-1), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out deallocate(attNameList, attNameList2, typekindList) ! !*** create temporary field bundle for axes information ! write the Grid coordinate arrays into the output files via temporary FB gridFB = ESMF_FieldBundleCreate(rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out call ESMF_AttributeGet(wrtGrid, convention="NetCDF", purpose="FV3", & - name="ESMF:gridded_dim_labels", valueList=attrValueSList, rc=rc) + name="ESMF:gridded_dim_labels", valueList=attrValueSList, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out call ESMF_GridGetCoord(wrtGrid, coordDim=1, & - staggerloc=ESMF_STAGGERLOC_CENTER, array=array, rc=rc) + staggerloc=ESMF_STAGGERLOC_CENTER, array=array, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + ! print *,'create gridFB,fieldname=',trim(attrValueSList(1)),trim(attrValueSList(2)), & ! 'lon value=',array(1:5) field = ESMF_FieldCreate(wrtGrid, array, name=trim(attrValueSList(1)), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out !add attribute info ! long name call ESMF_AttributeAdd(field,convention="NetCDF",purpose="FV3", & - attrList=(/'long_name'/), rc=rc) + attrList=(/'long_name'/), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_AttributeSet(field,convention="NetCDF",purpose="FV3",name='long_name', & - value="T-cell longitude", rc=rc) + value="T-cell longitude", rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! units call ESMF_AttributeAdd(field,convention="NetCDF",purpose="FV3", & - attrList=(/'units'/), rc=rc) + attrList=(/'units'/), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_AttributeSet(field,convention="NetCDF",purpose="FV3",name='units', & value="degrees_E", rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! cartesian_axis call ESMF_AttributeAdd(field,convention="NetCDF",purpose="FV3", & attrList=(/'cartesian_axis'/), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_AttributeSet(field,convention="NetCDF",purpose="FV3",name='cartesian_axis', & - value="X", rc=rc) + value="X", rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! add field to bundle call ESMF_FieldBundleAdd(gridFB, (/field/), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! ! get 2nd dimension call ESMF_GridGetCoord(wrtGrid, coordDim=2, & - staggerloc=ESMF_STAGGERLOC_CENTER, array=array, rc=rc) + staggerloc=ESMF_STAGGERLOC_CENTER, array=array, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + ! print *,'create gridFB,fieldname=',trim(attrValueSList(1)),trim(attrValueSList(2)), & ! 'lat value=',array(1:5,1),array(1,1:5) field = ESMF_FieldCreate(wrtGrid, array, name=trim(attrValueSList(2)), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out !add attribute info ! long name call ESMF_AttributeAdd(field,convention="NetCDF",purpose="FV3", & - attrList=(/'long_name'/), rc=rc) + attrList=(/'long_name'/), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_AttributeSet(field,convention="NetCDF",purpose="FV3",name='long_name', & value="T-cell latitude", rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! units call ESMF_AttributeAdd(field,convention="NetCDF",purpose="FV3", & - attrList=(/'units'/), rc=rc) + attrList=(/'units'/), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_AttributeSet(field,convention="NetCDF",purpose="FV3",name='units', & value="degrees_N", rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + ! cartesian_axis call ESMF_AttributeAdd(field,convention="NetCDF",purpose="FV3", & - attrList=(/'cartesian_axis'/), rc=rc) + attrList=(/'cartesian_axis'/), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_AttributeSet(field,convention="NetCDF",purpose="FV3",name='cartesian_axis', & - value="Y", rc=rc) + value="Y", rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out call ESMF_FieldBundleAdd(gridFB, (/field/), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! !----------------------------------------------------------------------- !*** SET THE IO_BaseTime TO THE INITIAL CLOCK TIME. @@ -1143,7 +1092,7 @@ subroutine wrt_run(wrt_comp, imp_state_write, exp_state_write,clock,rc) integer fieldcount, dimCount real(kind=ESMF_KIND_R8), dimension(:,:,:), pointer :: datar8 - real(kind=ESMF_KIND_R8), dimension(:,:), pointer :: datar82d + real(kind=ESMF_KIND_R8), dimension(:,:), pointer :: datar82d ! integer myattCount ! @@ -1158,10 +1107,9 @@ subroutine wrt_run(wrt_comp, imp_state_write, exp_state_write,clock,rc) !*** get the current write grid comp name, id, and internal state ! call ESMF_GridCompGet(wrt_comp, name=compname, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! print *,'in wrt run. compname=',trim(compname),' rc=',rc ! instance id from name @@ -1170,17 +1118,15 @@ subroutine wrt_run(wrt_comp, imp_state_write, exp_state_write,clock,rc) ! Provide log message indicating which wrtComp is active call ESMF_LogWrite("Write component activated: "//trim(compname), & ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! access the internal state call ESMF_GridCompGetInternalState(wrt_Comp, wrap, rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out wrt_int_state => wrap%write_int_state call ESMF_VMGetCurrent(VM,rc=RC) @@ -1191,24 +1137,22 @@ subroutine wrt_run(wrt_comp, imp_state_write, exp_state_write,clock,rc) !*** get current time and elapsed forecast time call ESMF_ClockGet(clock=CLOCK, currTime=CURRTIME, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_TimeGet(time=currTime,yy=date(1),mm=date(2),dd=date(3),h=date(4), & - m=date(5),s=date(6),rc=rc) + m=date(5),s=date(6),rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! if(mype == lead_write_task) print *,'in wrt run, curr time=',date ! call ESMF_TimeGet(time=wrt_int_state%IO_BASETIME,yy=date(1),mm=date(2),dd=date(3),h=date(4), & - m=date(5),s=date(6),rc=rc) + m=date(5),s=date(6),rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! print *,'in wrt run, io_baseline time=',date ! wrt_int_state%IO_CURRTIMEDIFF = CURRTIME-wrt_int_state%IO_BASETIME @@ -1221,9 +1165,7 @@ subroutine wrt_run(wrt_comp, imp_state_write, exp_state_write,clock,rc) ,sD =nseconds_den & !<-- denominator of fractional elapsed seconds ,rc =RC) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! if(mype == lead_write_task) print *,'in wrt run, nf_hours=',nf_hours,nf_minutes,nseconds, & ! 'nseconds_num=',nseconds_num,nseconds_den ! @@ -1253,10 +1195,10 @@ subroutine wrt_run(wrt_comp, imp_state_write, exp_state_write,clock,rc) call ESMF_LogWrite("before Write component get time", ESMF_LOGMSG_INFO, rc=rc) call ESMF_AttributeGet(imp_state_write, convention="NetCDF", purpose="FV3", & name="time", value=time, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_LogWrite("before Write component af get time", ESMF_LOGMSG_INFO, rc=rc) ! !----------------------------------------------------------------------- @@ -1266,10 +1208,10 @@ subroutine wrt_run(wrt_comp, imp_state_write, exp_state_write,clock,rc) do i=1, FBCount call ESMF_LogWrite("before Write component get mirror file bundle", ESMF_LOGMSG_INFO, rc=rc) call ESMF_StateGet(imp_state_write, itemName="mirror_"//trim(fcstItemNameList(i)), & - fieldbundle=file_bundle, rc=rc) + fieldbundle=file_bundle, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out call ESMF_LogWrite("before Write component af get mirror file bundle", ESMF_LOGMSG_INFO, rc=rc) !recover fields from cartesian vector and sfc pressure call recover_fields(file_bundle,rc) @@ -1293,42 +1235,41 @@ subroutine wrt_run(wrt_comp, imp_state_write, exp_state_write,clock,rc) ! ! set the time Attribute on the grid to carry it into the lower levels call ESMF_FieldBundleGet(file_bundle, grid=fbgrid, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_AttributeSet(fbgrid, convention="NetCDF", purpose="FV3", & - name="time", value=real(wrt_int_state%nfhour,ESMF_KIND_R8), rc=rc) + name="time", value=real(wrt_int_state%nfhour,ESMF_KIND_R8), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out !*** write out grid bundle: ! Provide log message indicating which wrtComp is active call ESMF_LogWrite("before Write component before gridFB ", ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out if (trim(output_grid) == 'cubed_sphere_grid') then wbeg = MPI_Wtime() - call ESMFproto_FieldBundleWrite(gridFB, filename=trim(filename), & - convention="NetCDF", purpose="FV3", & + call ESMFproto_FieldBundleWrite(gridFB, filename=trim(filename), & + convention="NetCDF", purpose="FV3", & status=ESMF_FILESTATUS_REPLACE, state=stateGridFB, comps=compsGridFB,rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out - call ESMFproto_FieldBundleWrite(wrt_int_state%wrtFB(nbdl), & - filename=trim(filename), convention="NetCDF", purpose="FV3", & + call ESMFproto_FieldBundleWrite(wrt_int_state%wrtFB(nbdl), & + filename=trim(filename), convention="NetCDF", purpose="FV3", & status=ESMF_FILESTATUS_OLD, timeslice=step, state=optimize(nbdl)%state, & comps=optimize(nbdl)%comps, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + wend = MPI_Wtime() if (mype == lead_write_task) then write(*,'(A,F10.5,A,I4.2,A,I2.2)')' actual netcdf Write Time is ',wend-wbeg & @@ -1365,18 +1306,18 @@ subroutine wrt_run(wrt_comp, imp_state_write, exp_state_write,clock,rc) call ESMFproto_FieldBundleWrite(gridFB, filename=trim(filename), & convention="NetCDF", purpose="FV3", & status=ESMF_FILESTATUS_REPLACE, state=stateGridFB, comps=compsGridFB,rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out call ESMFproto_FieldBundleWrite(wrt_int_state%wrtFB(nbdl), & filename=trim(filename), convention="NetCDF", purpose="FV3", & status=ESMF_FILESTATUS_OLD, timeslice=step, state=optimize(nbdl)%state, & comps=optimize(nbdl)%comps, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + wend = MPI_Wtime() if (mype == lead_write_task) then write(*,'(A,F10.5,A,I4.2,A,I2.2)')' netcdf_esmf Write Time is ',wend-wbeg & @@ -1502,9 +1443,7 @@ subroutine wrt_finalize(wrt_comp, imp_state_write, exp_state_write, clock, rc) ! if (ESMF_LogFoundDeallocError(statusToCheck=stat, & msg="Deallocation of internal state memory failed.", & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! !----------------------------------------------------------------------- ! @@ -1541,6 +1480,7 @@ subroutine recover_fields(file_bundle,rc) real(ESMF_KIND_R4), dimension(:,:,:,:), pointer :: cart3dPtr3dr4 real(ESMF_KIND_R8), dimension(:,:,:,:), pointer :: cart3dPtr3dr8 save lon, lat + real(ESMF_KIND_R8) :: coslon, sinlon, sinlat ! ! get filed count call ESMF_FieldBundleGet(file_bundle, fieldCount=fieldCount, & @@ -1548,31 +1488,33 @@ subroutine recover_fields(file_bundle,rc) ! CALL ESMF_LogWrite("call recover field on wrt comp",ESMF_LOGMSG_INFO,rc=RC) call ESMF_GridGet(fieldgrid, dimCount=gridDimCount, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out if( first_getlatlon ) then - CALL ESMF_LogWrite("call recover field get coord 1",ESMF_LOGMSG_INFO,rc=RC) - call ESMF_GridGetCoord(fieldgrid, coordDim=1, farrayPtr=lon, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - lon = lon * pi/180. + CALL ESMF_LogWrite("call recover field get coord 1",ESMF_LOGMSG_INFO,rc=RC) + + call ESMF_GridGetCoord(fieldgrid, coordDim=1, farrayPtr=lon, rc=rc) + + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out + + lon = lon * pi/180. ! print *,'in 3DCartesian2wind, lon dim=',lbound(lon,1),ubound(lon,1),lbound(lon,2),ubound(lon,2), & ! 'lon=',lon(lbound(lon,1),lbound(lon,2)), lon(ubound(lon,1),ubound(lon,2)) - CALL ESMF_LogWrite("call recover field get coord 2",ESMF_LOGMSG_INFO,rc=RC) - call ESMF_GridGetCoord(fieldgrid, coordDim=2, farrayPtr=lat, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - lat = lat * pi/180. + + CALL ESMF_LogWrite("call recover field get coord 2",ESMF_LOGMSG_INFO,rc=RC) + + call ESMF_GridGetCoord(fieldgrid, coordDim=2, farrayPtr=lat, rc=rc) + + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out + + lat = lat * pi/180. ! print *,'in 3DCartesian2wind, lat dim=',lbound(lat,1),ubound(lat,1),lbound(lat,2),ubound(lat,2), & ! 'lat=',lat(lbound(lon,1),lbound(lon,2)), lat(ubound(lon,1),ubound(lon,2)) - first_getlatlon = .false. + first_getlatlon = .false. endif ! allocate(fcstField(fieldCount)) @@ -1628,14 +1570,20 @@ subroutine recover_fields(file_bundle,rc) call ESMF_FieldGet(ufield, localDe=0, farrayPtr=uwind3dr4,rc=rc) call ESMF_FieldGet(vfield, localDe=0, farrayPtr=vwind3dr4,rc=rc) ! update u , v wind +!$omp parallel do default(shared) private(i,j,k,coslon,sinlon,sinlat) do k=kstart,kend +!!$omp parallel do default(none) shared(uwind3dr4,vwind3dr4,lon,lat,cart3dPtr3dr4,jstart,jend,istart,iend,k) & +!!$omp private(i,j,coslon,sinlon,sinlat) do j=jstart, jend do i=istart, iend - uwind3dr4(i,j,k) = cart3dPtr3dr4(1,i,j,k) * cos(lon(i,j))+ & - cart3dPtr3dr4(2,i,j,k) * sin(lon(i,j)) - vwind3dr4(i,j,k) =-cart3dPtr3dr4(1,i,j,k) * sin(lat(i,j))*sin(lon(i,j))+ & - cart3dPtr3dr4(2,i,j,k) * sin(lat(i,j))*cos(lon(i,j))+ & - cart3dPtr3dr4(3,i,j,k) * cos(lat(i,j)) + coslon = cos(lon(i,j)) + sinlon = sin(lon(i,j)) + sinlat = sin(lat(i,j)) + uwind3dr4(i,j,k) = cart3dPtr3dr4(1,i,j,k) * coslon & + + cart3dPtr3dr4(2,i,j,k) * sinlon + vwind3dr4(i,j,k) =-cart3dPtr3dr4(1,i,j,k) * sinlat*sinlon & + + cart3dPtr3dr4(2,i,j,k) * sinlat*coslon & + + cart3dPtr3dr4(3,i,j,k) * cos(lat(i,j)) enddo enddo enddo @@ -1656,13 +1604,18 @@ subroutine recover_fields(file_bundle,rc) call ESMF_FieldGet(ufield, localDe=0, farrayPtr=uwind2dr4,rc=rc) call ESMF_FieldGet(vfield, localDe=0, farrayPtr=vwind2dr4,rc=rc) ! update u , v wind +!$omp parallel do default(none) shared(uwind2dr4,vwind2dr4,lon,lat,cart3dPtr2dr4,jstart,jend,istart,iend) & +!$omp private(i,j,k,coslon,sinlon,sinlat) do j=jstart, jend do i=istart, iend - uwind2dr4(i,j) = cart3dPtr2dr4(1,i,j) * cos(lon(i,j))+ & - cart3dPtr2dr4(2,i,j) * sin(lon(i,j)) - vwind2dr4(i,j) =-cart3dPtr2dr4(1,i,j) * sin(lat(i,j))*sin(lon(i,j))+ & - cart3dPtr2dr4(2,i,j) * sin(lat(i,j))*cos(lon(i,j))+ & - cart3dPtr2dr4(3,i,j) * cos(lat(i,j)) + coslon = cos(lon(i,j)) + sinlon = sin(lon(i,j)) + sinlat = sin(lat(i,j)) + uwind2dr4(i,j) = cart3dPtr2dr4(1,i,j) * coslon & + + cart3dPtr2dr4(2,i,j) * sinlon + vwind2dr4(i,j) =-cart3dPtr2dr4(1,i,j) * sinlat*sinlon & + + cart3dPtr2dr4(2,i,j) * sinlat*coslon & + + cart3dPtr2dr4(3,i,j) * cos(lat(i,j)) enddo enddo endif @@ -1677,6 +1630,7 @@ subroutine recover_fields(file_bundle,rc) iend = ubound(pressfc,1) jstart = lbound(pressfc,2) jend = ubound(pressfc,2) +!$omp parallel do default(none) shared(pressfc,jstart,jend,istart,iend) private(i,j) do j=jstart, jend do i=istart, iend pressfc(i,j) = pressfc(i,j)**(grav/(rdgas*stndrd_atmos_lapse))*stndrd_atmos_ps @@ -1737,78 +1691,71 @@ subroutine ESMFproto_FieldBundleWrite(fieldbundle, fileName, & if (present(rc)) rc = ESMF_SUCCESS call ESMF_VMLogMemInfo("Entering ESMFproto_FieldBundleWrite",rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! query number of fields in fieldbundle call ESMF_FieldBundleGet(fieldbundle, fieldCount=fieldCount, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + ! early successful exit if there are no fields present if (fieldCount==0) return ! obtain list of fields in the fieldbundle + allocate(fieldList(fieldCount), tileFieldList(fieldCount)) call ESMF_FieldBundleGet(fieldbundle, fieldList=fieldList, & itemorderflag=ESMF_ITEMORDER_ADDORDER, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! determine tileCount by looking at first field + call ESMF_FieldGet(fieldList(1), array=array, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_ArrayGet(array, tileCount=tileCount, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! deal with optional state argument stateIsEmpty = .true. if (present(state)) then if (.not.ESMF_StateIsCreated(state, rc=rc)) then state = ESMF_StateCreate(rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out endif call ESMF_StateGet(state, itemCount=itemCount, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + if (itemCount /= 0) then stateIsEmpty = .false. if (itemCount /= tileCount) then call ESMF_LogSetError(ESMF_RC_ARG_BAD, & msg="Number of items in state must match number of tiles.", & - line=__LINE__, & - file=__FILE__, & - rcToReturn=rc) + line=__LINE__, file=__FILE__, rcToReturn=rc) return ! bail out endif allocate(itemNameList(itemCount),wrtTileFBList(itemCount)) call ESMF_StateGet(state, itemNameList=itemNameList, & - itemorderflag=ESMF_ITEMORDER_ADDORDER, rc=rc) + itemorderflag=ESMF_ITEMORDER_ADDORDER, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out do i=1, itemCount call ESMF_StateGet(state, itemName=itemNameList(i), & - fieldbundle=wrtTileFBList(i), rc=rc) + fieldbundle=wrtTileFBList(i), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out enddo endif endif @@ -1825,16 +1772,15 @@ subroutine ESMFproto_FieldBundleWrite(fieldbundle, fileName, & allocate(comps(tileCount)) do i=1, tileCount call ESMF_LogWrite("In ESMFproto_FieldBundleWrite() before "// & - "ESMFproto_FieldMakeSingleTile() w/ petList", & - ESMF_LOGMSG_INFO, rc=rc) + "ESMFproto_FieldMakeSingleTile() w/ petList", & + ESMF_LOGMSG_INFO, rc=rc) do j=1, fieldCount ! access only tile specific part of field call ESMFproto_FieldMakeSingleTile(fieldList(j), tile=i, & tileField=tileFieldList(j), petList=petList, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out enddo ! write(msgString, *) petList ! call ESMF_LogWrite("In ESMFproto_FieldBundleWrite() after "// & @@ -1842,37 +1788,31 @@ subroutine ESMFproto_FieldBundleWrite(fieldbundle, fileName, & ! ESMF_LOGMSG_INFO, rc=rc) ! create component to handle this tile I/O call ESMF_LogWrite("In ESMFproto_FieldBundleWrite() before "// & - "tile-component creation", ESMF_LOGMSG_INFO, rc=rc) + "tile-component creation", ESMF_LOGMSG_INFO, rc=rc) comps(i) = ESMF_GridCompCreate(petList=petList, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! convention call ESMF_AttributeSet(comps(i), name="convention", & - value=convention, rc=rc) + value=convention, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! purpose call ESMF_AttributeSet(comps(i), name="purpose", & - value=purpose, rc=rc) + value=purpose, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! timeslice timesliceOpt = -1 ! init if (present(timeslice)) timesliceOpt = timeslice call ESMF_AttributeSet(comps(i), name="timeslice", & - value=timesliceOpt, rc=rc) + value=timesliceOpt, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! status - statusStr="ESMF_FILESTATUS_UNKNOWN" ! default + statusStr = "ESMF_FILESTATUS_UNKNOWN" ! default if (present(status)) then if (status==ESMF_FILESTATUS_UNKNOWN) then statusStr="ESMF_FILESTATUS_UNKNOWN" ! default @@ -1885,22 +1825,20 @@ subroutine ESMFproto_FieldBundleWrite(fieldbundle, fileName, & endif endif call ESMF_AttributeSet(comps(i), name="status", & - value=statusStr, rc=rc) + value=statusStr, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_GridCompSetServices(comps(i), ioCompSS, userRc=urc, rc=rc) + if (ESMF_LogFoundError(rcToCheck=urc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, rcToReturn=rc)) & - return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_LogWrite("In ESMFproto_FieldBundleWrite() after "// & - "tile-component creation", ESMF_LOGMSG_INFO, rc=rc) + "tile-component creation", ESMF_LOGMSG_INFO, rc=rc) enddo endif endif @@ -1909,38 +1847,34 @@ subroutine ESMFproto_FieldBundleWrite(fieldbundle, fileName, & if (stateIsEmpty) then ! loop over all the fields and add tile specific part to fieldbundle call ESMF_LogWrite("In ESMFproto_FieldBundleWrite() before "// & - "ESMFproto_FieldMakeSingleTile()", ESMF_LOGMSG_INFO, rc=rc) + "ESMFproto_FieldMakeSingleTile()", ESMF_LOGMSG_INFO, rc=rc) do j=1, fieldCount ! access only tile specific part of field call ESMFproto_FieldMakeSingleTile(fieldList(j), tile=i, & - tileField=tileFieldList(j), rc=rc) + tileField=tileFieldList(j), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out enddo call ESMF_LogWrite("In ESMFproto_FieldBundleWrite() after "// & - "ESMFproto_FieldMakeSingleTile()", ESMF_LOGMSG_INFO, rc=rc) + "ESMFproto_FieldMakeSingleTile()", ESMF_LOGMSG_INFO, rc=rc) ! create tile specific fieldbundle wrtTileFB = ESMF_FieldBundleCreate(fieldList=tileFieldList, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! ensure global attributes on the fieldbundle are passed on by reference call ESMF_AttributeCopy(fieldbundle, wrtTileFB, & - attcopy=ESMF_ATTCOPY_REFERENCE, rc=rc) + attcopy=ESMF_ATTCOPY_REFERENCE, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + ! store this fieldbundle in state if present if (present(state)) then call ESMF_StateAdd(state, fieldbundleList=(/wrtTileFB/), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out endif else ! state brought in existing fieldbundles @@ -1955,36 +1889,34 @@ subroutine ESMFproto_FieldBundleWrite(fieldbundle, fileName, & endif if (present(comps)) then ioState(i) = ESMF_StateCreate(rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_StateAdd(ioState(i), (/wrtTileFB/), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_AttributeSet(comps(i), name="tileFileName", & - value=tileFileName, rc=rc) + value=tileFileName, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_GridCompRun(comps(i), importState=ioState(i), & - userRc=urc, rc=rc) + userRc=urc, rc=rc) + if (ESMF_LogFoundError(rcToCheck=urc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, rcToReturn=rc)) & - return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_StateDestroy(ioState(i), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out else call ESMF_LogWrite("In ESMFproto_FieldBundleWrite() before "// & "ESMF_FieldBundleWrite(): "//trim(tileFileName), & @@ -1992,58 +1924,56 @@ subroutine ESMFproto_FieldBundleWrite(fieldbundle, fileName, & call ESMF_FieldBundleWrite(fieldbundle=wrtTileFB, fileName=tileFileName, & convention=convention, purpose=purpose, status=status, & timeslice=timeslice, overwrite=.true., rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_LogWrite("In ESMFproto_FieldBundleWrite() after "// & - "ESMF_FieldBundleWrite()", ESMF_LOGMSG_INFO, rc=rc) + "ESMF_FieldBundleWrite()", ESMF_LOGMSG_INFO, rc=rc) endif if (.not.present(state)) then ! local garbage collection of fields do j=1, fieldCount call ESMF_FieldGet(tileFieldList(j), array=array, grid=grid, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_FieldDestroy(tileFieldList(j), noGarbage=.true., rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_GridDestroy(grid, noGarbage=.true., rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_ArrayGet(array, distgrid=distgrid, delayout=delayout, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_ArrayDestroy(array, noGarbage=.true., rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_DistGridDestroy(distgrid, noGarbage=.true., rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_DELayoutDestroy(delayout, noGarbage=.true., rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out enddo ! destroy tile specific fieldbundle call ESMF_FieldBundleDestroy(wrtTileFB, noGarbage=.true., rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out endif enddo if (present(comps)) then @@ -2056,10 +1986,9 @@ subroutine ESMFproto_FieldBundleWrite(fieldbundle, fileName, & deallocate(fieldList, tileFieldList) call ESMF_VMLogMemInfo("Exiting ESMFproto_FieldBundleWrite",rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out end subroutine ESMFproto_FieldBundleWrite @@ -2072,11 +2001,10 @@ subroutine ioCompSS(comp, rc) rc = ESMF_SUCCESS call ESMF_GridCompSetEntryPoint(comp, ESMF_METHOD_RUN, & - userRoutine=ioCompRun, rc=rc) + userRoutine=ioCompRun, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out end subroutine @@ -2123,57 +2051,56 @@ subroutine ioCompRun(comp, importState, exportState, clock, rc) ! Access the FieldBundle call ESMF_StateGet(importState, itemNameList=itemNameList, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_StateGet(importState, itemName=itemNameList(1), & - fieldBundle=wrtTileFB, rc=rc) + fieldBundle=wrtTileFB, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + ! Access attributes on the component and use as parameters for Write() call ESMF_AttributeGet(comp, name="tileFileName", value=tileFileName, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_AttributeGet(comp, name="convention", value=convention, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_AttributeGet(comp, name="purpose", value=purpose, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_AttributeGet(comp, name="timeslice", value=timeslice, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out call ESMF_AttributeGet(comp, name="status", value=statusStr, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - if (trim(statusStr)=="ESMF_FILESTATUS_UNKNOWN") then - status=ESMF_FILESTATUS_UNKNOWN - else if (trim(statusStr)=="ESMF_FILESTATUS_NEW") then - status=ESMF_FILESTATUS_NEW - else if (trim(statusStr)=="ESMF_FILESTATUS_OLD") then + line=__LINE__, file=__FILE__)) return ! bail out + + if (trim(statusStr) == "ESMF_FILESTATUS_UNKNOWN") then + status = ESMF_FILESTATUS_UNKNOWN + else if (trim(statusStr) == "ESMF_FILESTATUS_NEW") then + status = ESMF_FILESTATUS_NEW + else if (trim(statusStr) == "ESMF_FILESTATUS_OLD") then status=ESMF_FILESTATUS_OLD - else if (trim(statusStr)=="ESMF_FILESTATUS_REPLACE") then - status=ESMF_FILESTATUS_REPLACE + else if (trim(statusStr) == "ESMF_FILESTATUS_REPLACE") then + status = ESMF_FILESTATUS_REPLACE endif call ESMF_LogWrite("In ioCompRun() before writing to: "// & - trim(tileFileName), ESMF_LOGMSG_INFO, rc=rc) + trim(tileFileName), ESMF_LOGMSG_INFO, rc=rc) - if (status==ESMF_FILESTATUS_OLD) then + if (status == ESMF_FILESTATUS_OLD) then ! This writes the vectical coordinates and the time dimension into the ! file. Doing this before the large data sets are written, assuming that ! the first time coming into ioCompRun() with this tileFileName, only @@ -2181,65 +2108,63 @@ subroutine ioCompRun(comp, importState, exportState, clock, rc) ! the large data sets are written. That is when vertical and time info ! is also written. ! Hoping for better performance because file exists, but is still small. + call ESMF_GridCompGet(comp, localPet=localPet, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out if (localPet==0) then ! do this work only on the root pet call ESMF_FieldBundleGet(wrtTileFB, grid=grid, fieldCount=fieldCount, & - rc=rc) + rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + allocate(fieldList(fieldCount)) call ESMF_FieldBundleGet(wrtTileFB, fieldList=fieldList, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + ! open this tile's NetCDF file ncerr = nf90_open(tileFileName, NF90_WRITE, ncid=ncid) + if (ESMF_LogFoundNetCDFError(ncerr, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, rcToReturn=rc)) & - return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out ! loop over all the fields in the bundle and handle their vectical dims - thereAreVerticals=.false. + + thereAreVerticals = .false. do i=1, fieldCount field = fieldList(i) call ESMF_AttributeGetAttPack(field, & convention="NetCDF", purpose="FV3", isPresent=isPresent, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + if (.not.isPresent) cycle ! field does not have the AttPack call ESMF_AttributeGet(field, convention="NetCDF", purpose="FV3", & name="ESMF:ungridded_dim_labels", isPresent=isPresent, & itemCount=udimCount, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + if (udimCount==0 .or. .not.isPresent) cycle ! nothing there to do - thereAreVerticals=.true. + + thereAreVerticals = .true. allocate(udimList(udimCount)) call ESMF_AttributeGet(field, convention="NetCDF", purpose="FV3", & name="ESMF:ungridded_dim_labels", valueList=udimList, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + ! loop over all ungridded dimension labels do k=1, udimCount call write_out_ungridded_dim_atts(dimLabel=trim(udimList(k)), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out enddo deallocate(udimList) enddo ! fieldCount @@ -2250,25 +2175,24 @@ subroutine ioCompRun(comp, importState, exportState, clock, rc) call ESMF_AttributeGet(grid, convention="NetCDF", purpose="FV3", & name="vertical_dim_labels", isPresent=isPresent, & itemCount=udimCount, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + if (isPresent .and. (udimCount>0) ) then allocate(udimList(udimCount)) call ESMF_AttributeGet(grid, convention="NetCDF", purpose="FV3", & name="vertical_dim_labels", valueList=udimList, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + ! loop over all ungridded dimension labels do k=1, udimCount call write_out_ungridded_dim_atts(dimLabel=trim(udimList(k)), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out enddo deallocate(udimList) endif @@ -2281,148 +2205,139 @@ subroutine ioCompRun(comp, importState, exportState, clock, rc) call ESMF_AttributeGet(grid, convention="NetCDF", purpose="FV3", & name="time", value=time, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + ncerr = nf90_redef(ncid=ncid) if (ESMF_LogFoundNetCDFError(ncerr, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, rcToReturn=rc)) & - return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out + ncerr = nf90_inq_dimid(ncid, "time", dimid=dimid) if (ncerr /= NF90_NOERR) then ! "time" dimension does not yet exist, define as unlimited dim ncerr = nf90_def_dim(ncid, "time", NF90_UNLIMITED, dimid=dimid) + if (ESMF_LogFoundNetCDFError(ncerr, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, rcToReturn=rc)) & - return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out endif ncerr = nf90_def_var(ncid, "time", NF90_DOUBLE, & - dimids=(/dimid/), varid=varid) + dimids=(/dimid/), varid=varid) if (ESMF_LogFoundNetCDFError(ncerr, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, rcToReturn=rc)) & - return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out + ncerr = nf90_enddef(ncid=ncid) + if (ESMF_LogFoundNetCDFError(ncerr, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, rcToReturn=rc)) & - return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out + ncerr = nf90_put_var(ncid, varid, values=time) + if (ESMF_LogFoundNetCDFError(ncerr, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, rcToReturn=rc)) & - return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out + ! loop over all the grid attributes that start with "time:", and ! put them on the "time" variable in the NetCDF file + call ESMF_AttributeGet(grid, convention="NetCDF", purpose="FV3", & - name="TimeAttributes", itemCount=itemCount, rc=rc) + name="TimeAttributes", itemCount=itemCount, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + if (itemCount>0) then ncerr = nf90_redef(ncid=ncid) + if (ESMF_LogFoundNetCDFError(ncerr, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, rcToReturn=rc)) & - return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out + allocate(attNameList(itemCount)) call ESMF_AttributeGet(grid, convention="NetCDF", purpose="FV3", & - name="TimeAttributes", valueList=attNameList, rc=rc) + name="TimeAttributes", valueList=attNameList, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + do i=1, itemCount - attName=attNameList(i) + attName = attNameList(i) call ESMF_AttributeGet(grid, convention="NetCDF", purpose="FV3", & - name=trim(attNameList(i)), typekind=typekind, rc=rc) + name=trim(attNameList(i)), typekind=typekind, rc=rc) ! print *,'in esmf call, att name=',trim(attNameList(i)) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + if (typekind==ESMF_TYPEKIND_CHARACTER) then - call ESMF_AttributeGet(grid, & - convention="NetCDF", purpose="FV3", & - name=trim(attNameList(i)), value=valueS, rc=rc) + call ESMF_AttributeGet(grid, & + convention="NetCDF", purpose="FV3", & + name=trim(attNameList(i)), value=valueS, rc=rc) ! print *,'in esmf call, att string value=',trim(valueS) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + ncerr = nf90_put_att(ncid, varid, & - trim(attName(6:len(attName))), values=valueS) + trim(attName(6:len(attName))), values=valueS) + if (ESMF_LogFoundNetCDFError(ncerr, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, rcToReturn=rc)) & - return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out + else if (typekind==ESMF_TYPEKIND_I4) then - call ESMF_AttributeGet(grid, & - convention="NetCDF", purpose="FV3", & - name=trim(attNameList(i)), value=valueI4, rc=rc) + + call ESMF_AttributeGet(grid, & + convention="NetCDF", purpose="FV3", & + name=trim(attNameList(i)), value=valueI4, rc=rc) ! print *,'in esmf call, att I4 value=',valueR8 if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ncerr = nf90_put_att(ncid, varid, & - trim(attName(6:len(attName))), values=valueI4) + trim(attName(6:len(attName))), values=valueI4) + if (ESMF_LogFoundNetCDFError(ncerr, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, rcToReturn=rc)) & - return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out + else if (typekind==ESMF_TYPEKIND_R4) then - call ESMF_AttributeGet(grid, & - convention="NetCDF", purpose="FV3", & - name=trim(attNameList(i)), value=valueR4, rc=rc) + call ESMF_AttributeGet(grid, & + convention="NetCDF", purpose="FV3", & + name=trim(attNameList(i)), value=valueR4, rc=rc) ! print *,'in esmf call, att r4 value=',valueR8 + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + ncerr = nf90_put_att(ncid, varid, & - trim(attName(6:len(attName))), values=valueR4) + trim(attName(6:len(attName))), values=valueR4) + if (ESMF_LogFoundNetCDFError(ncerr, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, rcToReturn=rc)) & - return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out + else if (typekind==ESMF_TYPEKIND_R8) then - call ESMF_AttributeGet(grid, & - convention="NetCDF", purpose="FV3", & - name=trim(attNameList(i)), value=valueR8, rc=rc) + call ESMF_AttributeGet(grid, & + convention="NetCDF", purpose="FV3", & + name=trim(attNameList(i)), value=valueR8, rc=rc) ! print *,'in esmf call, att r8 value=',valueR8 + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ncerr = nf90_put_att(ncid, varid, & - trim(attName(6:len(attName))), values=valueR8) + trim(attName(6:len(attName))), values=valueR8) + if (ESMF_LogFoundNetCDFError(ncerr, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, rcToReturn=rc)) & - return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out endif enddo deallocate(attNameList) ncerr = nf90_enddef(ncid=ncid) + if (ESMF_LogFoundNetCDFError(ncerr, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, rcToReturn=rc)) & - return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out endif endif ! close the NetCDF file ncerr = nf90_close(ncid=ncid) + if (ESMF_LogFoundNetCDFError(ncerr, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, rcToReturn=rc)) & - return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out endif call ESMF_LogWrite("In ioCompRun() after "// & - "writing vectical and time dimensions.", ESMF_LOGMSG_INFO, rc=rc) + "writing vectical and time dimensions.", ESMF_LOGMSG_INFO, rc=rc) endif !TODO: remove this block once the ESMF_FieldBundleWrite() below allows to @@ -2432,48 +2347,44 @@ subroutine ioCompRun(comp, importState, exportState, clock, rc) ! file with 64bit-offset format in order to accommodate larger data ! volume. call ESMF_GridCompGet(comp, localPet=localPet, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out if (localPet==0) then ! only single PET to deal with NetCDF ncerr = nf90_create(tileFileName, & - cmode=or(nf90_clobber,nf90_64bit_offset), ncid=ncid) + cmode=or(nf90_clobber,nf90_64bit_offset), ncid=ncid) + if (ESMF_LogFoundNetCDFError(ncerr, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, rcToReturn=rc)) & - return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out + ncerr = nf90_close(ncid=ncid) + if (ESMF_LogFoundNetCDFError(ncerr, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, rcToReturn=rc)) & - return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out endif - status=ESMF_FILESTATUS_OLD ! switch status to 'OLD' to not overwrite + status = ESMF_FILESTATUS_OLD ! switch status to 'OLD' to not overwrite call ESMF_LogWrite("In ioCompRun() after creating the NetCDF file", & - ESMF_LOGMSG_INFO, rc=rc) + ESMF_LOGMSG_INFO, rc=rc) endif if (timeslice==-1) then call ESMF_FieldBundleWrite(fieldbundle=wrtTileFB, fileName=tileFileName, & - convention=convention, purpose=purpose, status=status, & - overwrite=.true., rc=rc) + convention=convention, purpose=purpose, status=status, & + overwrite=.true., rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out else call ESMF_FieldBundleWrite(fieldbundle=wrtTileFB, fileName=tileFileName, & - convention=convention, purpose=purpose, status=status, & - timeslice=timeslice, overwrite=.true., rc=rc) + convention=convention, purpose=purpose, status=status, & + timeslice=timeslice, overwrite=.true., rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out endif call ESMF_LogWrite("In ioCompRun() after "// & - "ESMF_FieldBundleWrite()", ESMF_LOGMSG_INFO, rc=rc) + "ESMF_FieldBundleWrite()", ESMF_LOGMSG_INFO, rc=rc) contains @@ -2487,173 +2398,154 @@ subroutine write_out_ungridded_dim_atts(dimLabel, rc) ! the variable does not exist in the NetCDF file yet -> add it ! access the undistributed dimension attribute on the grid call ESMF_AttributeGet(grid, convention="NetCDF", purpose="FV3", & - name=trim(dimLabel), itemCount=valueCount, typekind=typekind, rc=rc) + name=trim(dimLabel), itemCount=valueCount, typekind=typekind, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + if( typekind == ESMF_TYPEKIND_R4 ) then allocate(valueListr4(valueCount)) call ESMF_AttributeGet(grid, convention="NetCDF", purpose="FV3", & - name=trim(dimLabel), valueList=valueListr4, rc=rc) + name=trim(dimLabel), valueList=valueListr4, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + else if ( typekind == ESMF_TYPEKIND_R8) then allocate(valueListr8(valueCount)) call ESMF_AttributeGet(grid, convention="NetCDF", purpose="FV3", & - name=trim(dimLabel), valueList=valueListr8, rc=rc) + name=trim(dimLabel), valueList=valueListr8, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out endif ! now add it to the NetCDF file ncerr = nf90_redef(ncid=ncid) if (ESMF_LogFoundNetCDFError(ncerr, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, rcToReturn=rc)) & - return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out + ncerr = nf90_inq_dimid(ncid, trim(dimLabel), dimid=dimid) if (ncerr /= NF90_NOERR) then ! dimension does not yet exist, and must be defined ncerr = nf90_def_dim(ncid, trim(dimLabel), valueCount, & - dimid=dimid) + dimid=dimid) if (ESMF_LogFoundNetCDFError(ncerr, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, rcToReturn=rc)) & - return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out endif if( typekind == ESMF_TYPEKIND_R4 ) then ncerr = nf90_def_var(ncid, trim(dimLabel), NF90_FLOAT, & - dimids=(/dimid/), varid=varid) + dimids=(/dimid/), varid=varid) if (ESMF_LogFoundNetCDFError(ncerr, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, rcToReturn=rc)) & - return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out + ncerr = nf90_enddef(ncid=ncid) if (ESMF_LogFoundNetCDFError(ncerr, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, rcToReturn=rc)) & - return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out + ncerr = nf90_put_var(ncid, varid, values=valueListr4) if (ESMF_LogFoundNetCDFError(ncerr, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, rcToReturn=rc)) & - return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out + deallocate(valueListr4) else if(typekind == ESMF_TYPEKIND_R8) then ncerr = nf90_def_var(ncid, trim(dimLabel), NF90_DOUBLE, & - dimids=(/dimid/), varid=varid) + dimids=(/dimid/), varid=varid) if (ESMF_LogFoundNetCDFError(ncerr, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, rcToReturn=rc)) & - return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out + ncerr = nf90_enddef(ncid=ncid) if (ESMF_LogFoundNetCDFError(ncerr, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, rcToReturn=rc)) & - return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out + ncerr = nf90_put_var(ncid, varid, values=valueListr8) if (ESMF_LogFoundNetCDFError(ncerr, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, rcToReturn=rc)) & - return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out deallocate(valueListr8) endif ! add attributes to this vertical variable call ESMF_AttributeGet(grid, convention="NetCDF", purpose="FV3", & - attnestflag=ESMF_ATTNEST_OFF, count=attCount, rc=rc) + attnestflag=ESMF_ATTNEST_OFF, count=attCount, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + if (attCount>0) then ncerr = nf90_redef(ncid=ncid) if (ESMF_LogFoundNetCDFError(ncerr, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, rcToReturn=rc)) & - return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out endif ! loop over all the attributes do j=1, attCount - call ESMF_AttributeGet(grid, convention="NetCDF", purpose="FV3", & - attnestflag=ESMF_ATTNEST_OFF, attributeIndex=j, name=attName, & - typekind=typekind, rc=rc) + call ESMF_AttributeGet(grid, convention="NetCDF", purpose="FV3", & + attnestflag=ESMF_ATTNEST_OFF, attributeIndex=j, & + name=attName, typekind=typekind, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + ! test for name starting with trim(dimLabel)":" if (index(trim(attName), trim(dimLabel)//":")==1) then ind = len(trim(dimLabel)//":") ! found a matching attributes - if (typekind==ESMF_TYPEKIND_CHARACTER) then + if (typekind == ESMF_TYPEKIND_CHARACTER) then call ESMF_AttributeGet(grid, & - convention="NetCDF", purpose="FV3", & - name=trim(attName), value=valueS, rc=rc) + convention="NetCDF", purpose="FV3", & + name=trim(attName), value=valueS, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + ncerr = nf90_put_att(ncid, varid, & - trim(attName(ind+1:len(attName))), values=valueS) + trim(attName(ind+1:len(attName))), values=valueS) + if (ESMF_LogFoundNetCDFError(ncerr, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, rcToReturn=rc)) & - return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out + else if (typekind==ESMF_TYPEKIND_I4) then call ESMF_AttributeGet(grid, & - convention="NetCDF", purpose="FV3", & - name=trim(attName), value=valueI4, rc=rc) + convention="NetCDF", purpose="FV3", & + name=trim(attName), value=valueI4, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + ncerr = nf90_put_att(ncid, varid, & - trim(attName(ind+1:len(attName))), values=valueI4) + trim(attName(ind+1:len(attName))), values=valueI4) + if (ESMF_LogFoundNetCDFError(ncerr, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, rcToReturn=rc)) & - return ! bail out - else if (typekind==ESMF_TYPEKIND_R4) then + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out + + else if (typekind == ESMF_TYPEKIND_R4) then call ESMF_AttributeGet(grid, & - convention="NetCDF", purpose="FV3", & - name=trim(attName), value=valueR4, rc=rc) + convention="NetCDF", purpose="FV3", & + name=trim(attName), value=valueR4, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + ncerr = nf90_put_att(ncid, varid, & - trim(attName(ind+1:len(attName))), values=valueR4) + trim(attName(ind+1:len(attName))), values=valueR4) + if (ESMF_LogFoundNetCDFError(ncerr, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, rcToReturn=rc)) & - return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out + else if (typekind==ESMF_TYPEKIND_R8) then call ESMF_AttributeGet(grid, & - convention="NetCDF", purpose="FV3", & - name=trim(attName), value=valueR8, rc=rc) + convention="NetCDF", purpose="FV3", & + name=trim(attName), value=valueR8, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + ncerr = nf90_put_att(ncid, varid, & - trim(attName(ind+1:len(attName))), values=valueR8) + trim(attName(ind+1:len(attName))), values=valueR8) + if (ESMF_LogFoundNetCDFError(ncerr, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, rcToReturn=rc)) & - return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out endif endif enddo if (attCount>0) then ncerr = nf90_enddef(ncid=ncid) if (ESMF_LogFoundNetCDFError(ncerr, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, rcToReturn=rc)) & - return ! bail out + line=__LINE__, file=__FILE__, rcToReturn=rc)) return ! bail out endif end subroutine @@ -2709,20 +2601,19 @@ subroutine ESMFproto_FieldMakeSingleTile(field, tile, tileField, petList, rc) ! access information from the incoming field call ESMF_FieldGet(field, array=array, typekind=typekind, & - dimCount=fieldDimCount, name=fieldName, grid=grid, rc=rc) + dimCount=fieldDimCount, name=fieldName, grid=grid, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + ! access information from the associated grid call ESMF_GridGet(grid, dimCount=gridDimCount, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out #if 0 -write(msg,*) "fieldDimCount=",fieldDimCount,"gridDimCount=",gridDimCount -call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + write(msg,*) "fieldDimCount=",fieldDimCount,"gridDimCount=",gridDimCount + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) #endif ! access list type information from the incoming field allocate(gridToFieldMap(gridDimCount)) @@ -2731,74 +2622,71 @@ subroutine ESMFproto_FieldMakeSingleTile(field, tile, tileField, petList, rc) allocate(ungriddedLBound(undistDims)) allocate(ungriddedUBound(undistDims)) call ESMF_FieldGet(field, gridToFieldMap=gridToFieldMap, & - ungriddedLBound=ungriddedLBound, ungriddedUBound=ungriddedUBound, & - rc=rc) + ungriddedLBound=ungriddedLBound, ungriddedUBound=ungriddedUBound, & + rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + ! access information from associated array call ESMF_ArrayGet(array, distgrid=distgrid, delayout=delayout, & - indexflag=indexflag, localDeCount=localDeCount, deCount=deCount, rc=rc) + indexflag=indexflag, localDeCount=localDeCount, deCount=deCount, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + ! access list type information from associated array allocate(localDeToDeMap(localDeCount), deToTileMap(deCount)) allocate(distgridToArrayMap(gridDimCount)) allocate(undistLBound(undistDims)) allocate(undistUBound(undistDims)) - call ESMF_ArrayGet(array, tileCount=tileCount, & - localDeToDeMap=localDeToDeMap, deToTileMap=deToTileMap, & - distgridToArrayMap=distgridToArrayMap, & - undistLBound=undistLBound, undistUBound=undistUBound, rc=rc) + call ESMF_ArrayGet(array, tileCount=tileCount, & + localDeToDeMap=localDeToDeMap, deToTileMap=deToTileMap, & + distgridToArrayMap=distgridToArrayMap, & + undistLBound=undistLBound, undistUBound=undistUBound, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + ! access list type information from associated distgrid allocate(minIndexPDe(gridDimCount,deCount)) allocate(maxIndexPDe(gridDimCount,deCount)) allocate(minIndexPTile(gridDimCount,tileCount)) allocate(maxIndexPTile(gridDimCount,tileCount)) - call ESMF_DistGridGet(distgrid, & - minIndexPDe=minIndexPDe, maxIndexPDe=maxIndexPDe, & - minIndexPTile=minIndexPTile, maxIndexPTile=maxIndexPTile, & - rc=rc) + call ESMF_DistGridGet(distgrid, & + minIndexPDe=minIndexPDe, maxIndexPDe=maxIndexPDe, & + minIndexPTile=minIndexPTile, maxIndexPTile=maxIndexPTile, & + rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + ! access list type information from associated delayout allocate(petMap(deCount)) call ESMF_DELayoutGet(delayout, petMap=petMap, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + ! construct data structures selecting specific tile allocate(lArrayList(localDeCount)) - tileLocalDeCount=0 + tileLocalDeCount = 0 do i=1, localDeCount - if (deToTileMap(localDeToDeMap(i)+1)==tile) then + if (deToTileMap(localDeToDeMap(i)+1) == tile) then ! localDe is on tile - tileLocalDeCount=tileLocalDeCount+1 + tileLocalDeCount = tileLocalDeCount + 1 call ESMF_ArrayGet(array, localDe=i-1, & - localarray=lArrayList(tileLocalDeCount), rc=rc) + localarray=lArrayList(tileLocalDeCount), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out endif enddo allocate(tilePetMap(deCount)) allocate(deBlockList(gridDimCount,2,deCount)) tileDeCount=0 do i=1, deCount - if (deToTileMap(i)==tile) then + if (deToTileMap(i) == tile) then ! DE is on tile - tileDeCount = tileDeCount+1 + tileDeCount = tileDeCount + 1 tilePetMap(tileDeCount) = petMap(i) deBlockList(:,1,tileDeCount) = minIndexPDe(:,i) deBlockList(:,2,tileDeCount) = maxIndexPDe(:,i) @@ -2816,68 +2704,64 @@ subroutine ESMFproto_FieldMakeSingleTile(field, tile, tileField, petList, rc) ! create DELayout and DistGrid that only contain the single tile delayout = ESMF_DELayoutCreate(tilePetMap(1:tileDeCount), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - distgrid = ESMF_DistGridCreate(minIndex=minIndexPTile(:,tile), & - maxIndex=maxIndexPTile(:,tile), delayout=delayout, & - deBlockList=deBlockList(:,:,1:tileDeCount), rc=rc) + line=__LINE__, file=__FILE__)) return ! bail out + + distgrid = ESMF_DistGridCreate(minIndex=minIndexPTile(:,tile), & + maxIndex=maxIndexPTile(:,tile), delayout=delayout, & + deBlockList=deBlockList(:,:,1:tileDeCount), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + ! create an Array that only holds tile specific allocations if (tileLocalDeCount>0) then - array = ESMF_ArrayCreate(distgrid, lArrayList(1:tileLocalDeCount), & - indexflag=indexflag, & - distgridToArrayMap=distgridToArrayMap, undistLBound=undistLBound, & - undistUBound=undistUBound, rc=rc) + array = ESMF_ArrayCreate(distgrid, lArrayList(1:tileLocalDeCount), & + indexflag=indexflag, & + distgridToArrayMap=distgridToArrayMap, undistLBound=undistLBound, & + undistUBound=undistUBound, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out else - array = ESMF_ArrayCreate(distgrid, typekind, indexflag=indexflag, & - distgridToArrayMap=distgridToArrayMap, undistLBound=undistLBound, & - undistUBound=undistUBound, rc=rc) + array = ESMF_ArrayCreate(distgrid, typekind, indexflag=indexflag, & + distgridToArrayMap=distgridToArrayMap, undistLBound=undistLBound, & + undistUBound=undistUBound, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out endif + ! create a grid on the new distgrid tileGrid = ESMF_GridCreate(distgrid, indexflag=indexflag, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + ! alias the Attributes on grid level call ESMF_AttributeCopy(grid, tileGrid, attcopy=ESMF_ATTCOPY_REFERENCE, & - rc=rc) + rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + ! create the tile specific field from the array tileField = ESMF_FieldCreate(tileGrid, array=array, name=fieldName, & - gridToFieldMap=gridToFieldMap, ungriddedLBound=ungriddedLBound, & - ungriddedUBound=ungriddedUBound, rc=rc) + gridToFieldMap=gridToFieldMap, ungriddedLBound=ungriddedLBound, & + ungriddedUBound=ungriddedUBound, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + ! alias the Attributes on field level call ESMF_AttributeCopy(field, tileField, attcopy=ESMF_ATTCOPY_REFERENCE, & - rc=rc) + rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + ! local garbage collection deallocate(localDeToDeMap, deToTileMap) - deallocate(petMap, tilePetMap) - deallocate(minIndexPDe, maxIndexPDe) - deallocate(minIndexPTile, maxIndexPTile) + deallocate(petMap, tilePetMap) + deallocate(minIndexPDe, maxIndexPDe) + deallocate(minIndexPTile, maxIndexPTile) deallocate(gridToFieldMap, ungriddedLBound, ungriddedUBound) deallocate(deBlockList) @@ -2911,7 +2795,8 @@ subroutine splat4(idrt,jmax,aslat) 146.870307625d0, 150.011882457d0, 153.153458019d0, 156.295034268d0 / real(8) :: dlt,d1=1.d0 integer :: jhe,jho,j0=0 - real(8),parameter :: PI=3.14159265358979d0,C=(1.d0-(2.d0/PI)**2)*0.25d0 +! real(8),parameter :: PI=3.14159265358979d0,C=(1.d0-(2.d0/PI)**2)*0.25d0 + real(8),parameter :: C=(1.d0-(2.d0/PI)**2)*0.25d0 real(8) r integer jh,js,n,j ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -3020,7 +2905,8 @@ subroutine splat8(idrt,jmax,aslat) 146.870307625d0, 150.011882457d0, 153.153458019d0, 156.295034268d0 / real(8) :: dlt,d1=1.d0 integer(4) :: jhe,jho,j0=0 - real(8),parameter :: PI=3.14159265358979d0,C=(1.d0-(2.d0/PI)**2)*0.25d0 +! real(8),parameter :: PI=3.14159265358979d0,C=(1.d0-(2.d0/PI)**2)*0.25d0 + real(8),parameter :: C=(1.d0-(2.d0/PI)**2)*0.25d0 real(8) r integer jh,js,n,j ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -3109,7 +2995,7 @@ subroutine rtll(tlmd,tphd,almd,aphd,tlm0d,tph0d) real(ESMF_KIND_R8), intent(out) :: almd, aphd real(ESMF_KIND_R8), intent(in) :: tph0d, tlm0d !------------------------------------------------------------------------------- - real(ESMF_KIND_R8), parameter :: pi=3.14159265358979323846 +! real(ESMF_KIND_R8), parameter :: pi=3.14159265358979323846 real(ESMF_KIND_R8), parameter :: dtr=pi/180.0 ! real(ESMF_KIND_R8) :: tph0, ctph0, stph0, tlm, tph, stph, ctph, ctlm, stlm, aph, cph @@ -3164,7 +3050,7 @@ subroutine lambert(stlat1,stlat2,c_lat,c_lon,glon,glat,x,y,inv) real(ESMF_KIND_R8), intent(inout) :: x, y integer, intent(in) :: inv !------------------------------------------------------------------------------- - real(ESMF_KIND_R8), parameter :: pi=3.14159265358979323846 +! real(ESMF_KIND_R8), parameter :: pi=3.14159265358979323846 real(ESMF_KIND_R8), parameter :: dtor=pi/180.0 real(ESMF_KIND_R8), parameter :: rtod=180.0/pi real(ESMF_KIND_R8), parameter :: a = 6371200.0 diff --git a/module_fcst_grid_comp.F90 b/module_fcst_grid_comp.F90 index 44663d459..482a03c9c 100644 --- a/module_fcst_grid_comp.F90 +++ b/module_fcst_grid_comp.F90 @@ -122,29 +122,22 @@ subroutine SetServices(fcst_comp, rc) call ESMF_GridCompSetEntryPoint(fcst_comp, ESMF_METHOD_INITIALIZE, & userRoutine=fcst_initialize, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! call ESMF_GridCompSetEntryPoint(fcst_comp, ESMF_METHOD_RUN, & userRoutine=fcst_run_phase_1, phase=1, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_GridCompSetEntryPoint(fcst_comp, ESMF_METHOD_RUN, & userRoutine=fcst_run_phase_2, phase=2, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! call ESMF_GridCompSetEntryPoint(fcst_comp, ESMF_METHOD_FINALIZE, & userRoutine=fcst_finalize, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out end subroutine SetServices ! @@ -224,14 +217,12 @@ subroutine fcst_initialize(fcst_comp, importState, exportState, clock, rc) wrap%ptr => atm_int_state call ESMF_GridCompSetInternalState(fcst_comp, wrap, rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! call ESMF_VMGetCurrent(vm=VM,rc=RC) call ESMF_VMGet(vm=VM, localPet=mype, mpiCommunicator=mpi_comm_comp, & petCount=ntasks, rc=rc) - if(mype==0) print *,'in fcst comp init, ntasks=',ntasks + if (mype == 0) write(0,*)'in fcst comp init, ntasks=',ntasks ! call fms_init(mpi_comm_comp) call mpp_init() @@ -269,18 +260,15 @@ subroutine fcst_initialize(fcst_comp, importState, exportState, clock, rc) call ESMF_ClockGet(clock, CurrTime=CurrTime, StartTime=StartTime, & StopTime=StopTime, RunDuration=RunDuration, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out - date_init=0 + date_init = 0 call ESMF_TimeGet (StartTime, & YY=date_init(1), MM=date_init(2), DD=date_init(3), & H=date_init(4), M =date_init(5), S =date_init(6), RC=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + if ( date_init(1) == 0 ) date_init = date atm_int_state%Time_init = set_date (date_init(1), date_init(2), date_init(3), & date_init(4), date_init(5), date_init(6)) @@ -291,9 +279,8 @@ subroutine fcst_initialize(fcst_comp, importState, exportState, clock, rc) YY=date(1), MM=date(2), DD=date(3), & H=date(4), M =date(5), S =date(6), RC=rc ) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + if(mype==0) write(*,'(A,6I5)') 'CurrTime =',date atm_int_state%Time_atmos = set_date (date(1), date(2), date(3), & @@ -304,9 +291,8 @@ subroutine fcst_initialize(fcst_comp, importState, exportState, clock, rc) YY=date_end(1), MM=date_end(2), DD=date_end(3), & H=date_end(4), M =date_end(5), S =date_end(6), RC=rc ) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + if ( date_end(1) == 0 ) date_end = date atm_int_state%Time_end = set_date (date_end(1), date_end(2), date_end(3), & date_end(4), date_end(5), date_end(6)) @@ -316,16 +302,14 @@ subroutine fcst_initialize(fcst_comp, importState, exportState, clock, rc) ! CALL ESMF_TimeIntervalGet(RunDuration, S=Run_length, RC=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! call diag_manager_init (TIME_INIT=date) call diag_manager_set_time_end(atm_int_state%Time_end) ! atm_int_state%Time_step_atmos = set_time (dt_atmos,0) atm_int_state%num_atmos_calls = Run_length / dt_atmos - if(mype==0) print *,'num_atmos_calls=',atm_int_state%num_atmos_calls,'time_init=', & + if (mype == 0) write(0,*)'num_atmos_calls=',atm_int_state%num_atmos_calls,'time_init=', & date_init,'time_atmos=',date,'time_end=',date_end,'dt_atmos=',dt_atmos, & 'Run_length=',Run_length res_intvl = restart_interval*3600 @@ -368,7 +352,7 @@ subroutine fcst_initialize(fcst_comp, importState, exportState, clock, rc) !*** first try: Create cubed sphere grid from file !----------------------------------------------------------------------- ! - if(mype==0) print *,'be create fcst grid' + if (mype == 0) write(0,*)'be create fcst grid' if( quilting ) then do tl=1,6 @@ -442,9 +426,7 @@ subroutine fcst_initialize(fcst_comp, importState, exportState, clock, rc) staggerlocList=(/ESMF_STAGGERLOC_CENTER, ESMF_STAGGERLOC_CORNER/), & name='fcst_grid', rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out end if ! @@ -452,17 +434,13 @@ subroutine fcst_initialize(fcst_comp, importState, exportState, clock, rc) if( cpl ) then call addLsmask2grid(fcstGrid, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! print *,'call addLsmask2grid after fcstgrid, rc=',rc if( cplprint_flag ) then call ESMF_GridWriteVTK(fcstgrid, staggerloc=ESMF_STAGGERLOC_CENTER, & filename='fv3cap_fv3Grid', rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out endif endif ! @@ -470,29 +448,23 @@ subroutine fcst_initialize(fcst_comp, importState, exportState, clock, rc) call ESMF_AttributeAdd(exportState, convention="NetCDF", purpose="FV3", & attrList=(/"gridfile"/), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_AttributeSet(exportState, convention="NetCDF", purpose="FV3", & name="gridfile", value=trim(gridfile), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! Add dimension Attributes to Grid call ESMF_AttributeAdd(fcstgrid, convention="NetCDF", purpose="FV3", & attrList=(/"ESMF:gridded_dim_labels"/), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_AttributeSet(fcstGrid, convention="NetCDF", purpose="FV3", & name="ESMF:gridded_dim_labels", valueList=(/"grid_xt", "grid_yt"/), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! ! Add time Attribute to the exportState call ESMF_AttributeAdd(exportState, convention="NetCDF", purpose="FV3", & @@ -503,55 +475,49 @@ subroutine fcst_initialize(fcst_comp, importState, exportState, clock, rc) "time:calendar_type ", & "time:calendar " /), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_AttributeSet(exportState, convention="NetCDF", purpose="FV3", & name="time", value=real(0,ESMF_KIND_R8), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + write(dateSY,'(I4.4)')date_init(1) write(dateSM,'(I2.2)')date_init(2) write(dateSD,'(I2.2)')date_init(3) write(dateSH,'(I2.2)')date_init(4) write(dateSN,'(I2.2)')date_init(5) write(dateSS,'(I2.2)')date_init(6) + dateS="hours since "//dateSY//'-'//dateSM//'-'//dateSD//' '//dateSH//':'// & dateSN//":"//dateSS - if(mype==0) print *,'dateS=',trim(dateS),'date_init=',date_init + if (mype == 0) write(0,*)'dateS=',trim(dateS),'date_init=',date_init + call ESMF_AttributeSet(exportState, convention="NetCDF", purpose="FV3", & name="time:units", value=trim(dateS), rc=rc) ! name="time:units", value="hours since 2016-10-03 00:00:00", rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_AttributeSet(exportState, convention="NetCDF", purpose="FV3", & name="time:long_name", value="time", rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_AttributeSet(exportState, convention="NetCDF", purpose="FV3", & name="time:cartesian_axis", value="T", rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_AttributeSet(exportState, convention="NetCDF", purpose="FV3", & name="time:calendar_type", value="JULIAN", rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_AttributeSet(exportState, convention="NetCDF", purpose="FV3", & name="time:calendar", value="JULIAN", rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! ! Create FieldBundle for Fields that need to be regridded bilinear @@ -563,20 +529,17 @@ subroutine fcst_initialize(fcst_comp, importState, exportState, clock, rc) ! for dyn name_FB1 = trim(name_FB)//'_bilinear' fieldbundle = ESMF_FieldBundleCreate(name=trim(name_FB1),rc=rc) - if(mype==0) print *,'af create fcst fieldbundle, name=',trim(name_FB),'rc=',rc + if (mype == 0) write(0,*)'af create fcst fieldbundle, name=',trim(name_FB),'rc=',rc if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out + call fv_dyn_bundle_setup(atm_int_state%Atm%axes, & fieldbundle, fcstgrid, quilting) ! Add the field to the importState so parent can connect to it call ESMF_StateAdd(exportState, (/fieldbundle/), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out else if( i==2 ) then ! for phys @@ -589,11 +552,9 @@ subroutine fcst_initialize(fcst_comp, importState, exportState, clock, rc) name_FB1 = trim(name_FB)//'_bilinear' endif fieldbundlephys(j) = ESMF_FieldBundleCreate(name=trim(name_FB1),rc=rc) - if(mype==0) print *,'af create fcst fieldbundle, name=',trim(name_FB1),'rc=',rc + if (mype == 0) write(0,*)'af create fcst fieldbundle, name=',trim(name_FB1),'rc=',rc if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out enddo ! call fv_phys_bundle_setup(atm_int_state%Atm%diag, atm_int_state%Atm%axes, & @@ -603,9 +564,7 @@ subroutine fcst_initialize(fcst_comp, importState, exportState, clock, rc) do j=1,nbdlphys call ESMF_StateAdd(exportState, (/fieldbundlephys(j)/), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out enddo endif @@ -626,7 +585,7 @@ subroutine fcst_initialize(fcst_comp, importState, exportState, clock, rc) ! WRITE(0,*)"PASS: Fcst_Initialize." ENDIF ! - if(mype==0) print *,'in fcst,init total time: ', mpi_wtime() - timeis + if (mype == 0) write(0,*)'in fcst,init total time: ', mpi_wtime() - timeis ! !----------------------------------------------------------------------- ! @@ -674,15 +633,11 @@ subroutine fcst_run_phase_1(fcst_comp, importState, exportState,clock,rc) ! call ESMF_GridCompGet(fcst_comp, name=compname, localpet=mype, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! call ESMF_ClockGet(clock, advanceCount=NTIMESTEP_ESMF, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out na = NTIMESTEP_ESMF ! @@ -699,19 +654,17 @@ subroutine fcst_run_phase_1(fcst_comp, importState, exportState,clock,rc) call atmos_model_exchange_phase_1 (atm_int_state%Atm, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out !----------------------------------------------------------------------- ! ! IF(RC /= ESMF_SUCCESS) THEN ! if(mype==0) WRITE(0,*)"FAIL: fcst_RUN" -! ELSE - if(mype==0) WRITE(0,*)"PASS: fcstRUN, na=",na +! ELSE + if (mype == 0) WRITE(0,*)"PASS: fcstRUN, na=",na ! ENDIF ! - if(mype==0) print *,'fcst_run_phase_1 time is ', mpi_wtime()-tbeg1 + if (mype == 0) write(0,*)'fcst_run_phase_1 time is ', mpi_wtime()-tbeg1 ! !----------------------------------------------------------------------- ! @@ -759,27 +712,21 @@ subroutine fcst_run_phase_2(fcst_comp, importState, exportState,clock,rc) ! call ESMF_GridCompGet(fcst_comp, name=compname, localpet=mype, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out ! call ESMF_ClockGet(clock, advanceCount=NTIMESTEP_ESMF, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out na = NTIMESTEP_ESMF - if(mype==0) print *,'in fcst run phase 2, na=',na + if (mype == 0) write(0,*)'in fcst run phase 2, na=',na ! !----------------------------------------------------------------------- ! *** call fcst integration subroutines call atmos_model_exchange_phase_2 (atm_int_state%Atm, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return ! bail out call update_atmos_model_state (atm_int_state%Atm) @@ -800,12 +747,12 @@ subroutine fcst_run_phase_2(fcst_comp, importState, exportState,clock,rc) !----------------------------------------------------------------------- ! ! IF(RC /= ESMF_SUCCESS) THEN -! if(mype==0) WRITE(0,*)"FAIL: fcst_RUN" -! ELSE - if(mype==0) WRITE(0,*)"PASS: fcstRUN, na=",na +! if(mype==0) WRITE(0,*)"FAIL: fcst_RUN" +! ELSE + if (mype == 0) WRITE(0,*)"PASS: fcstRUN, na=",na ! ENDIF ! - if(mype==0) print *,'fcst_run_phase_2 time is ', mpi_wtime()-tbeg1 + if (mype == 0) write(0,*)'fcst_run_phase_2 time is ', mpi_wtime()-tbeg1 ! !----------------------------------------------------------------------- !