<p><b>duda</b> 2013-03-27 13:26:14 -0600 (Wed, 27 Mar 2013)</p><p>Merge changes to atmospheric cores from atmos_physics branch.<br>
No changes to shared code or non-atmosphere cores.<br>
</p><hr noshade><pre><font color="gray">Modified: trunk/mpas/namelist.input.nhyd_atmos
===================================================================
--- trunk/mpas/namelist.input.nhyd_atmos 2013-03-27 19:24:59 UTC (rev 2673)
+++ trunk/mpas/namelist.input.nhyd_atmos 2013-03-27 19:26:14 UTC (rev 2674)
@@ -1,56 +1,56 @@
&nhyd_model
config_time_integration = 'SRK3'
config_dt = 450.0
- config_start_time = '2010-10-23_00:00:00'
+ config_start_time = '2010-10-23_00:00:00'
config_run_duration = '5_00:00:00'
config_number_of_sub_steps = 6
- config_h_mom_eddy_visc2 = 0.0
- config_h_mom_eddy_visc4 = 0.0
- config_v_mom_eddy_visc2 = 0.0
- config_h_theta_eddy_visc2 = 0.0
- config_h_theta_eddy_visc4 = 0.0
- config_v_theta_eddy_visc2 = 0.0
- config_horiz_mixing = '2d_smagorinsky'
- config_len_disp = 120000.0
- config_theta_adv_order = 3
- config_scalar_adv_order = 3
- config_w_adv_order = 3
- config_u_vadv_order = 3
- config_w_vadv_order = 3
- config_theta_vadv_order = 3
- config_scalar_vadv_order = 3
- config_coef_3rd_order = 0.25
- config_positive_definite = .true.
- config_monotonic = .false.
- config_epssm = 0.1
- config_smdiv = 0.1
- config_h_ScaleWithMesh = .false.
- config_sfc_update_interval = "none"
- config_newpx = .false.
+ config_h_mom_eddy_visc2 = 0.0
+ config_h_mom_eddy_visc4 = 0.0
+ config_v_mom_eddy_visc2 = 0.0
+ config_h_theta_eddy_visc2 = 0.0
+ config_h_theta_eddy_visc4 = 0.0
+ config_v_theta_eddy_visc2 = 0.0
+ config_horiz_mixing = '2d_smagorinsky'
+ config_len_disp = 120000.0
+ config_visc4_2dsmag = 0.05
+ config_u_vadv_order = 3
+ config_w_vadv_order = 3
+ config_theta_vadv_order = 3
+ config_scalar_vadv_order = 3
+ config_w_adv_order = 3
+ config_theta_adv_order = 3
+ config_scalar_adv_order = 3
+ config_scalar_advection = .true.
+ config_positive_definite = .false.
+ config_monotonic = .true.
+ config_coef_3rd_order = 0.25
+ config_epssm = 0.1
+ config_smdiv = 0.1
+ config_h_ScaleWithMesh = .false.
+ config_newpx = .false.
+ config_sfc_update_interval = 'none'
/
config_stop_time = '0000-01-16_00:00:00'
&damping
config_zd = 22000.0
- config_xnutr = 0.0
+ config_xnutr = 0.2
/
&io
- config_input_name = 'x1.40962.init.nc'
- config_output_name = 'x1.40962.output.nc'
- config_restart_name = 'restart.nc'
- config_output_interval = '1_00:00:00'
+ config_input_name = 'x1.40962.init.nc'
+ config_output_name = 'x1.40962.output.nc'
+ config_restart_name = 'x1.40962.restart.nc'
+ config_output_interval = '1_00:00:00'
config_frames_per_outfile = 1
- config_pio_num_iotasks = 0
- config_pio_stride = 1
+ config_pio_num_iotasks = 0
+ config_pio_stride = 1
/
- config_sfc_update_name = 'sfc_update.nc'
+ config_sfc_update_name = 'x1.40962.sfc_update.nc'
&decomposition
- config_number_of_blocks = 0
+ config_number_of_blocks = 0
config_block_decomp_file_prefix = 'x1.40962.graph.info.part.'
- config_explicit_proc_decomp = .false.
- config_proc_decomp_file_prefix = 'graph.info.part.'
/
&restart
@@ -59,27 +59,30 @@
/
&physics
- config_frac_seaice = .false.
- config_sfc_albedo = .true.
- config_sst_update = .false.
- config_sstdiurn_update = .false.
- config_deepsoiltemp_update = .false.
-
- config_n_microp = 5
-
- config_radtlw_interval = '00:30:00'
- config_radtsw_interval = '00:30:00'
- config_conv_interval = 'none'
- config_pbl_interval = 'none'
-
- config_microp_scheme = 'wsm6'
- config_conv_shallow_scheme = 'off'
- config_conv_deep_scheme = 'kain_fritsch'
- config_eddy_scheme = 'off'
- config_lsm_scheme = 'noah'
- config_pbl_scheme = 'ysu'
- config_radt_cld_scheme = 'off'
- config_radt_lw_scheme = 'rrtmg_lw'
- config_radt_sw_scheme = 'rrtmg_sw'
- config_sfclayer_scheme = 'monin_obukhov'
+ config_frac_seaice = .false.
+ config_sfc_albedo = .true.
+ config_sfc_snowalbedo = .true.
+ config_sst_update = .false.
+ config_sstdiurn_update = .false.
+ config_deepsoiltemp_update = .false.
+ config_bucket_update = 'none'
+ config_bucket_rainc = 100.0
+ config_bucket_rainnc = 100.0
+ config_bucket_radt = 1.0e9
+ config_radtlw_interval = '00:30:00'
+ config_radtsw_interval = '00:30:00'
+ config_conv_interval = 'none'
+ config_pbl_interval = 'none'
+ config_n_microp = 5
+ config_microp_scheme = 'wsm6'
+ config_conv_shallow_scheme = 'off'
+ config_conv_deep_scheme = 'kain_fritsch'
+ config_eddy_scheme = 'off'
+ config_lsm_scheme = 'noah'
+ config_pbl_scheme = 'ysu'
+ config_gwdo_scheme = 'off'
+ config_radt_cld_scheme = 'off'
+ config_radt_lw_scheme = 'rrtmg_lw'
+ config_radt_sw_scheme = 'rrtmg_sw'
+ config_sfclayer_scheme = 'monin_obukhov'
/
Modified: trunk/mpas/src/core_atmos_physics/Makefile
===================================================================
--- trunk/mpas/src/core_atmos_physics/Makefile 2013-03-27 19:24:59 UTC (rev 2673)
+++ trunk/mpas/src/core_atmos_physics/Makefile 2013-03-27 19:26:14 UTC (rev 2674)
@@ -6,6 +6,8 @@
ifeq ($(CORE),nhyd_atmos)
COREDEF = -Dnon_hydrostatic_core
endif
+HYDROSTATIC = -Ddo_hydrostatic_pressure
+#HYDROSTATIC =
dummy:
echo "****** make non-hydrostatic core ******"
@@ -17,16 +19,17 @@
OBJS = \
mpas_atmphys_driver_cloudiness.o \
mpas_atmphys_driver_convection_deep.o \
+ mpas_atmphys_driver_gwdo.o \
mpas_atmphys_driver_lsm.o \
mpas_atmphys_driver_microphysics.o \
mpas_atmphys_driver_radiation_lw.o \
mpas_atmphys_driver_radiation_sw.o \
mpas_atmphys_driver_sfclayer.o \
mpas_atmphys_driver_pbl.o \
+ mpas_atmphys_driver.o \
mpas_atmphys_camrad_init.o \
mpas_atmphys_control.o \
mpas_atmphys_date_time.o \
- mpas_atmphys_driver.o \
mpas_atmphys_init.o \
mpas_atmphys_landuse.o \
mpas_atmphys_lsm_noahinit.o \
@@ -73,6 +76,10 @@
./physics_wrf/module_cu_kfeta.o \
./physics_wrf/module_cu_tiedtke.o
+mpas_atmphys_driver_gwdo.o: \
+ mpas_atmphys_vars.o \
+ ./physics_wrf/module_bl_gwdo.o
+
mpas_atmphys_driver_lsm.o: \
mpas_atmphys_constants.o \
mpas_atmphys_landuse.o \
@@ -203,6 +210,7 @@
mpas_atmphys_driver.o: \
mpas_atmphys_driver_convection_deep.o \
+ mpas_atmphys_driver_gwdo.o \
mpas_atmphys_driver_pbl.o \
mpas_atmphys_driver_radiation_lw.o \
mpas_atmphys_driver_radiation_sw.o \
@@ -225,5 +233,5 @@
.F.o:
$(RM) $@ $*.mod
- $(CPP) $(CPPFLAGS) $(COREDEF) $(CPPINCLUDES) -DIWORDSIZE=4 -DRWORDSIZE=8 $< > $*.f90
+ $(CPP) $(CPPFLAGS) $(COREDEF) $(HYDROSTATIC) $(CPPINCLUDES) -DIWORDSIZE=4 -DRWORDSIZE=8 $< > $*.f90
$(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../framework -I../operators -I./physics_wrf -I./physics_eaung -I../external/esmf_time_f90
Modified: trunk/mpas/src/core_atmos_physics/mpas_atmphys_control.F
===================================================================
--- trunk/mpas/src/core_atmos_physics/mpas_atmphys_control.F 2013-03-27 19:24:59 UTC (rev 2673)
+++ trunk/mpas/src/core_atmos_physics/mpas_atmphys_control.F 2013-03-27 19:26:14 UTC (rev 2674)
@@ -35,16 +35,17 @@
write(0,*)
write(0,*) '--- enter subroutine physics_namelist_check:'
- write(0,*) ' config_microp_scheme = ', config_microp_scheme
- write(0,*) ' config_conv_shallow_scheme = ', config_conv_shallow_scheme
- write(0,*) ' config_conv_deep_scheme = ', config_conv_deep_scheme
- write(0,*) ' config_eddy_scheme = ', config_eddy_scheme
- write(0,*) ' config_lsm_scheme = ', config_lsm_scheme
- write(0,*) ' config_pbl_scheme = ', config_pbl_scheme
- write(0,*) ' config_radt_cld_scheme = ', config_radt_cld_scheme
- write(0,*) ' config_radt_lw_scheme = ', config_radt_lw_scheme
- write(0,*) ' config_radt_sw_scheme = ', config_radt_sw_scheme
- write(0,*) ' config_sfclayer_scheme = ', config_sfclayer_scheme
+ write(0,*) ' config_microp_scheme = ', trim(config_microp_scheme)
+ write(0,*) ' config_conv_shallow_scheme = ', trim(config_conv_shallow_scheme)
+ write(0,*) ' config_conv_deep_scheme = ', trim(config_conv_deep_scheme)
+ write(0,*) ' config_eddy_scheme = ', trim(config_eddy_scheme)
+ write(0,*) ' config_lsm_scheme = ', trim(config_lsm_scheme)
+ write(0,*) ' config_pbl_scheme = ', trim(config_pbl_scheme)
+ write(0,*) ' config_gwdo_scheme = ', trim(config_gwdo_scheme)
+ write(0,*) ' config_radt_cld_scheme = ', trim(config_radt_cld_scheme)
+ write(0,*) ' config_radt_lw_scheme = ', trim(config_radt_lw_scheme)
+ write(0,*) ' config_radt_sw_scheme = ', trim(config_radt_sw_scheme)
+ write(0,*) ' config_sfclayer_scheme = ', trim(config_sfclayer_scheme)
!cloud microphysics scheme:
if(.not. (config_microp_scheme .eq. 'off' .or. &
@@ -93,6 +94,22 @@
endif
+!gravity wave drag over orography scheme:
+ if(.not. (config_gwdo_scheme .eq. 'off' .or. &
+ config_gwdo_scheme .eq. 'ysu_gwdo')) then
+
+ write(mpas_err_message,'(A,A10)') 'illegal value for gwdo_scheme: ', &
+ trim(config_gwdo_scheme)
+ call physics_error_fatal(mpas_err_message)
+
+ elseif(config_gwdo_scheme .eq. 'ysu_gwdo' .and. config_pbl_scheme .ne. 'ysu') then
+
+ write(mpas_err_message,'(A,A10)') 'turn YSU PBL scheme on with config_gwdo = ysu_gwdo:', &
+ trim(config_gwdo_scheme)
+ call physics_error_fatal(mpas_err_message)
+
+ endif
+
!diffusion scheme:
if(.not. (config_eddy_scheme .eq. 'off')) then
Modified: trunk/mpas/src/core_atmos_physics/mpas_atmphys_date_time.F
===================================================================
--- trunk/mpas/src/core_atmos_physics/mpas_atmphys_date_time.F 2013-03-27 19:24:59 UTC (rev 2673)
+++ trunk/mpas/src/core_atmos_physics/mpas_atmphys_date_time.F 2013-03-27 19:26:14 UTC (rev 2674)
@@ -85,7 +85,6 @@
!local variables:
character(len=StrKIND):: day15,mon
- character(len=StrKIND):: yr
integer:: l,n
integer:: julyr,julday,int_month,month1,month2
@@ -144,7 +143,7 @@
endif
enddo find_month
- 201 format(i6,3(1x,e15.8))
+! 201 format(i6,3(1x,e15.8))
end subroutine monthly_interp_to_date
Modified: trunk/mpas/src/core_atmos_physics/mpas_atmphys_driver.F
===================================================================
--- trunk/mpas/src/core_atmos_physics/mpas_atmphys_driver.F 2013-03-27 19:24:59 UTC (rev 2673)
+++ trunk/mpas/src/core_atmos_physics/mpas_atmphys_driver.F 2013-03-27 19:26:14 UTC (rev 2674)
@@ -5,6 +5,7 @@
use mpas_atmphys_driver_cloudiness
use mpas_atmphys_driver_convection_deep
+ use mpas_atmphys_driver_gwdo
use mpas_atmphys_driver_pbl
use mpas_atmphys_driver_lsm
use mpas_atmphys_driver_radiation_sw
@@ -118,6 +119,14 @@
call deallocate_pbl
endif
+ !call to gravity wave drag over orography scheme:
+ if(config_gwdo_scheme .ne. 'off') then
+ call allocate_gwdo
+ call driver_gwdo(itimestep,block%mesh,block%sfc_input,block%diag_physics, &
+ block%tend_physics)
+ call deallocate_gwdo
+ endif
+
!call to convection scheme:
call update_convection_step1(block%mesh,block%diag_physics,block%tend_physics)
if(l_conv) then
Modified: trunk/mpas/src/core_atmos_physics/mpas_atmphys_driver_convection_deep.F
===================================================================
--- trunk/mpas/src/core_atmos_physics/mpas_atmphys_driver_convection_deep.F 2013-03-27 19:24:59 UTC (rev 2673)
+++ trunk/mpas/src/core_atmos_physics/mpas_atmphys_driver_convection_deep.F 2013-03-27 19:26:14 UTC (rev 2674)
@@ -290,7 +290,10 @@
else
ktau = itimestep + 1
endif
+#if defined(do_hydrostatic_pressure)
+!... REARRANGED CALL USING HYDROSTATIC PRESSURE:
call kf_eta_cps ( &
+ pcps = pres_hyd_p , t = t_p , &
! dt = dt_dyn , ktau = itimestep , &
dt = dt_dyn , ktau = ktau , &
areaCell = area_p , cudt = cudt , &
@@ -298,9 +301,8 @@
rho = rho_p , raincv = raincv_p , &
pratec = pratec_p , nca = nca_p , &
u = u_p , v = v_p , &
- th = th_p , t = t_p , &
+ th = th_p , pi = pi_p , &
w = w_p , dz8w = dz_p , &
- pcps = pres_p , pi = pi_p , &
w0avg = w0avg_p , xlv0 = xlv0 , &
xlv1 = xlv1 , xls0 = xls0 , &
xls1 = xls1 , cp = cp , &
@@ -320,22 +322,90 @@
ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , &
ims = ims , ime = ime , jms = jms , jme = jme , kms = kds , kme = kme , &
its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte &
- )
+ )
+#else
+!... REARRANGED CALL:
+ call kf_eta_cps ( &
+ pcps = pres_p , t = t_p , &
+! dt = dt_dyn , ktau = itimestep , &
+ dt = dt_dyn , ktau = ktau , &
+ areaCell = area_p , cudt = cudt , &
+ curr_secs = curr_secs , adapt_step_flag = adapt_step_flag , &
+ rho = rho_p , raincv = raincv_p , &
+ pratec = pratec_p , nca = nca_p , &
+ u = u_p , v = v_p , &
+ th = th_p , pi = pi_p , &
+ w = w_p , dz8w = dz_p , &
+ w0avg = w0avg_p , xlv0 = xlv0 , &
+ xlv1 = xlv1 , xls0 = xls0 , &
+ xls1 = xls1 , cp = cp , &
+ r = r_d , g = g , &
+ ep1 = ep_1 , ep2 = ep_2 , &
+ svp1 = svp1 , svp2 = svp2 , &
+ svp3 = svp3 , svpt0 = svpt0 , &
+ stepcu = n_cu , cu_act_flag = cu_act_flag , &
+ warm_rain = warm_rain , cutop = cutop_p , &
+ cubot = cubot_p , qv = qv_p , &
+ f_qv = f_qv , f_qc = f_qc , &
+ f_qr = f_qr , f_qi = f_qi , &
+ f_qs = f_qs , rthcuten = rthcuten_p , &
+ rqvcuten = rqvcuten_p , rqccuten = rqccuten_p , &
+ rqrcuten = rqrcuten_p , rqicuten = rqicuten_p , &
+ rqscuten = rqscuten_p , &
+ ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , &
+ ims = ims , ime = ime , jms = jms , jme = jme , kms = kds , kme = kme , &
+ its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte &
+ )
+#endif
+!... CALL FROM REVISION 1721:
+! call kf_eta_cps ( &
+! dt = dt_dyn , ktau = itimestep , &
+! dt = dt_dyn , ktau = ktau , &
+! areaCell = area_p , cudt = cudt , &
+! curr_secs = curr_secs , adapt_step_flag = adapt_step_flag , &
+! rho = rho_p , raincv = raincv_p , &
+! pratec = pratec_p , nca = nca_p , &
+! u = u_p , v = v_p , &
+! th = th_p , t = t_p , &
+! w = w_p , dz8w = dz_p , &
+! pcps = pres_p , pi = pi_p , &
+! w0avg = w0avg_p , xlv0 = xlv0 , &
+! xlv1 = xlv1 , xls0 = xls0 , &
+! xls1 = xls1 , cp = cp , &
+! r = r_d , g = g , &
+! ep1 = ep_1 , ep2 = ep_2 , &
+! svp1 = svp1 , svp2 = svp2 , &
+! svp3 = svp3 , svpt0 = svpt0 , &
+! stepcu = n_cu , cu_act_flag = cu_act_flag , &
+! warm_rain = warm_rain , cutop = cutop_p , &
+! cubot = cubot_p , qv = qv_p , &
+! f_qv = f_qv , f_qc = f_qc , &
+! f_qr = f_qr , f_qi = f_qi , &
+! f_qs = f_qs , rthcuten = rthcuten_p , &
+! rqvcuten = rqvcuten_p , rqccuten = rqccuten_p , &
+! rqrcuten = rqrcuten_p , rqicuten = rqicuten_p , &
+! rqscuten = rqscuten_p , &
+! ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , &
+! ims = ims , ime = ime , jms = jms , jme = jme , kms = kds , kme = kme , &
+! its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte &
+! )
case("tiedtke")
write(0,*) '--- enter subroutine cu_tiedtke:'
+#if defined(do_hydrostatic_pressure)
+!... REARRANGED CALL USING HYDROSTATIC PRESSURE:
call cu_tiedtke ( &
+ pcps = pres_hyd_p , p8w = pres2_hyd_p , &
+ znu = znu_hyd_p , t3d = t_p , &
dt = dt_dyn , itimestep = itimestep , &
stepcu = n_cu , raincv = raincv_p , &
pratec = pratec_p , qfx = qfx_p , &
- znu = znu_p , u3d = u_p , &
- v3d = v_p , w = w_p , &
- t3d = t_p , qv3d = qv_p , &
+ u3d = u_p , v3d = v_p , &
+ w = w_p , qv3d = qv_p , &
qc3d = qc_p , qi3d = qi_p , &
pi3d = pi_p , rho3d = rho_p , &
qvften = rqvdynten_p , qvpblten = rqvdynblten_p , &
- dz8w = dz_p , pcps = pres_p , &
- p8w = pres2_p , xland = xland_p , &
+ dz8w = dz_p , xland = xland_p , &
cu_act_flag = cu_act_flag , cudt = dt_cu , &
! curr_secs = curr_secs , adapt_step_flag = adapt_step_flag , &
! cudtacttime = cudtacttime , f_qv = f_qv , &
@@ -349,6 +419,60 @@
ims = ims , ime = ime , jms = jms , jme = jme , kms = kds , kme = kme , &
its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte &
)
+#else
+!... REARRANGED CALL:
+ call cu_tiedtke ( &
+ pcps = pres_p , p8w = pres2_p , &
+ znu = znu_p , t3d = t_p , &
+ dt = dt_dyn , itimestep = itimestep , &
+ stepcu = n_cu , raincv = raincv_p , &
+ pratec = pratec_p , qfx = qfx_p , &
+ u3d = u_p , v3d = v_p , &
+ w = w_p , qv3d = qv_p , &
+ qc3d = qc_p , qi3d = qi_p , &
+ pi3d = pi_p , rho3d = rho_p , &
+ qvften = rqvdynten_p , qvpblten = rqvdynblten_p , &
+ dz8w = dz_p , xland = xland_p , &
+ cu_act_flag = cu_act_flag , cudt = dt_cu , &
+! curr_secs = curr_secs , adapt_step_flag = adapt_step_flag , &
+! cudtacttime = cudtacttime , f_qv = f_qv , &
+ f_qv = f_qv , &
+ f_qc = f_qc , f_qr = f_qr , &
+ f_qi = f_qi , f_qs = f_qs , &
+ rthcuten = rthcuten_p , rqvcuten = rqvcuten_p , &
+ rqccuten = rqccuten_p , rqicuten = rqicuten_p , &
+ rucuten = rucuten_p , rvcuten = rvcuten_p , &
+ ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , &
+ ims = ims , ime = ime , jms = jms , jme = jme , kms = kds , kme = kme , &
+ its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte &
+ )
+#endif
+!... CALL FROM REVISION 1721:
+! call cu_tiedtke ( &
+! dt = dt_dyn , itimestep = itimestep , &
+! stepcu = n_cu , raincv = raincv_p , &
+! pratec = pratec_p , qfx = qfx_p , &
+! znu = znu_p , u3d = u_p , &
+! v3d = v_p , w = w_p , &
+! t3d = t_p , qv3d = qv_p , &
+! qc3d = qc_p , qi3d = qi_p , &
+! pi3d = pi_p , rho3d = rho_p , &
+! qvften = rqvdynten_p , qvpblten = rqvdynblten_p , &
+! dz8w = dz_p , pcps = pres_p , &
+! p8w = pres2_p , xland = xland_p , &
+! cu_act_flag = cu_act_flag , cudt = dt_cu , &
+! curr_secs = curr_secs , adapt_step_flag = adapt_step_flag , &
+! cudtacttime = cudtacttime , f_qv = f_qv , &
+! f_qv = f_qv , &
+! f_qc = f_qc , f_qr = f_qr , &
+! f_qi = f_qi , f_qs = f_qs , &
+! rthcuten = rthcuten_p , rqvcuten = rqvcuten_p , &
+! rqccuten = rqccuten_p , rqicuten = rqicuten_p , &
+! rucuten = rucuten_p , rvcuten = rvcuten_p , &
+! ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , &
+! ims = ims , ime = ime , jms = jms , jme = jme , kms = kds , kme = kme , &
+! its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte &
+! )
case default
Added: trunk/mpas/src/core_atmos_physics/mpas_atmphys_driver_gwdo.F
===================================================================
--- trunk/mpas/src/core_atmos_physics/mpas_atmphys_driver_gwdo.F (rev 0)
+++ trunk/mpas/src/core_atmos_physics/mpas_atmphys_driver_gwdo.F 2013-03-27 19:26:14 UTC (rev 2674)
@@ -0,0 +1,236 @@
+!=============================================================================================
+ module mpas_atmphys_driver_gwdo
+ use mpas_configure, only: len_disp => config_len_disp
+ use mpas_grid_types
+
+ use mpas_atmphys_constants
+ use mpas_atmphys_vars
+
+!from wrf physics:
+ use module_bl_gwdo
+
+ implicit none
+ private
+ public:: allocate_gwdo, &
+ deallocate_gwdo, &
+ driver_gwdo
+
+ integer,private:: i,j,k
+
+ contains
+
+!=============================================================================================
+ subroutine allocate_gwdo
+!=============================================================================================
+
+ if(.not.allocated(dx_p) ) allocate(dx_p(ims:ime,jms:jme) )
+ if(.not.allocated(var2d_p) ) allocate(var2d_p(ims:ime,jms:jme) )
+ if(.not.allocated(con_p) ) allocate(con_p(ims:ime,jms:jme) )
+ if(.not.allocated(oa1_p) ) allocate(oa1_p(ims:ime,jms:jme) )
+ if(.not.allocated(oa2_p) ) allocate(oa2_p(ims:ime,jms:jme) )
+ if(.not.allocated(oa3_p) ) allocate(oa3_p(ims:ime,jms:jme) )
+ if(.not.allocated(oa4_p) ) allocate(oa4_p(ims:ime,jms:jme) )
+ if(.not.allocated(ol1_p) ) allocate(ol1_p(ims:ime,jms:jme) )
+ if(.not.allocated(ol2_p) ) allocate(ol2_p(ims:ime,jms:jme) )
+ if(.not.allocated(ol3_p) ) allocate(ol3_p(ims:ime,jms:jme) )
+ if(.not.allocated(ol4_p) ) allocate(ol4_p(ims:ime,jms:jme) )
+ if(.not.allocated(kpbl_p )) allocate(kpbl_p(ims:ime,jms:jme) )
+ if(.not.allocated(dusfcg_p)) allocate(dusfcg_p(ims:ime,jms:jme))
+ if(.not.allocated(dvsfcg_p)) allocate(dvsfcg_p(ims:ime,jms:jme))
+
+ if(.not.allocated(dtaux3d_p)) allocate(dtaux3d_p(ims:ime,kms:kme,jms:jme))
+ if(.not.allocated(dtauy3d_p)) allocate(dtauy3d_p(ims:ime,kms:kme,jms:jme))
+ if(.not.allocated(rublten_p)) allocate(rublten_p(ims:ime,kms:kme,jms:jme))
+ if(.not.allocated(rvblten_p)) allocate(rvblten_p(ims:ime,kms:kme,jms:jme))
+
+ end subroutine allocate_gwdo
+
+!=============================================================================================
+ subroutine deallocate_gwdo
+!=============================================================================================
+
+ if(allocated(dx_p) ) deallocate(dx_p )
+ if(allocated(var2d_p) ) deallocate(var2d_p )
+ if(allocated(con_p) ) deallocate(con_p )
+ if(allocated(oa1_p) ) deallocate(oa1_p )
+ if(allocated(oa2_p) ) deallocate(oa2_p )
+ if(allocated(oa3_p) ) deallocate(oa3_p )
+ if(allocated(oa4_p) ) deallocate(oa4_p )
+ if(allocated(ol1_p) ) deallocate(ol1_p )
+ if(allocated(ol2_p) ) deallocate(ol2_p )
+ if(allocated(ol3_p) ) deallocate(ol3_p )
+ if(allocated(ol4_p) ) deallocate(ol4_p )
+ if(allocated(kpbl_p )) deallocate(kpbl_p )
+ if(allocated(dusfcg_p)) deallocate(dusfcg_p)
+ if(allocated(dvsfcg_p)) deallocate(dvsfcg_p)
+
+ if(allocated(dtaux3d_p)) deallocate(dtaux3d_p)
+ if(allocated(dtauy3d_p)) deallocate(dtauy3d_p)
+ if(allocated(rublten_p)) deallocate(rublten_p)
+ if(allocated(rvblten_p)) deallocate(rvblten_p)
+
+ end subroutine deallocate_gwdo
+
+!=============================================================================================
+ subroutine gwdo_from_MPAS(mesh,sfc_input,diag_physics,tend_physics)
+!=============================================================================================
+
+!input arguments:
+ type(mesh_type),intent(in):: mesh
+ type(sfc_input_type),intent(in) :: sfc_input
+ type(diag_physics_type),intent(in):: diag_physics
+ type(tend_physics_type),intent(in):: tend_physics
+
+!local variables:
+ integer:: iEdge
+
+!---------------------------------------------------------------------------------------------
+
+ do j = jts,jte
+ do i = its,ite
+ iEdge = mesh%nEdgesOnCell%array(i)
+ dx_p(i,j) = maxval(mesh%dcEdge%array(mesh%edgesOnCell%array(1:iEdge,i)))
+ enddo
+ enddo
+
+ do j = jts,jte
+ do i = its,ite
+ var2d_p(i,j) = sfc_input % var2d % array(i)
+ con_p(i,j) = sfc_input % con % array(i)
+ oa1_p(i,j) = sfc_input % oa1 % array(i)
+ oa2_p(i,j) = sfc_input % oa2 % array(i)
+ oa3_p(i,j) = sfc_input % oa3 % array(i)
+ oa4_p(i,j) = sfc_input % oa4 % array(i)
+ ol1_p(i,j) = sfc_input % ol1 % array(i)
+ ol2_p(i,j) = sfc_input % ol2 % array(i)
+ ol3_p(i,j) = sfc_input % ol3 % array(i)
+ ol4_p(i,j) = sfc_input % ol4 % array(i)
+ enddo
+ enddo
+
+ do j = jts,jte
+ do i = its,ite
+ kpbl_p(i,j) = diag_physics % kpbl % array(i)
+ dusfcg_p(i,j) = diag_physics % dusfcg % array(i)
+ dvsfcg_p(i,j) = diag_physics % dvsfcg % array(i)
+ enddo
+ enddo
+
+ do j = jts,jte
+ do k = kts,kte
+ do i = its,ite
+ dtaux3d_p(i,k,j) = diag_physics % dtaux3d % array(k,i)
+ dtauy3d_p(i,k,j) = diag_physics % dtauy3d % array(k,i)
+ rublten_p(i,k,j) = tend_physics % rublten % array(k,i)
+ rvblten_p(i,k,j) = tend_physics % rvblten % array(k,i)
+ enddo
+ enddo
+ enddo
+
+ end subroutine gwdo_from_MPAS
+
+!=============================================================================================
+ subroutine gwdo_to_MPAS(diag_physics,tend_physics)
+!=============================================================================================
+
+!inout arguments:
+ type(diag_physics_type),intent(inout):: diag_physics
+ type(tend_physics_type),intent(inout):: tend_physics
+
+!---------------------------------------------------------------------------------------------
+
+ do j = jts,jte
+ do i = its,ite
+ diag_physics % dusfcg % array(i) = dusfcg_p(i,j)
+ diag_physics % dvsfcg % array(i) = dvsfcg_p(i,j)
+ enddo
+ enddo
+
+ do j = jts,jte
+ do k = kts,kte
+ do i = its,ite
+ diag_physics % dtaux3d % array(k,i) = dtaux3d_p(i,k,j)
+ diag_physics % dtauy3d % array(k,i) = dtauy3d_p(i,k,j)
+ diag_physics % rubldiff % array(k,i) = rublten_p(i,k,j)-tend_physics%rublten%array(k,i)
+ diag_physics % rvbldiff % array(k,i) = rvblten_p(i,k,j)-tend_physics%rvblten%array(k,i)
+
+ tend_physics % rublten % array(k,i) = rublten_p(i,k,j)
+ tend_physics % rvblten % array(k,i) = rvblten_p(i,k,j)
+ enddo
+ enddo
+ enddo
+
+!write(0,*)
+!write(0,*) '--- end subroutine gwdo_to_MPAS:'
+!do i = its,ite
+! write(0,101) i,diag_physics%dusfcg%array(i),diag_physics%dvsfcg%array(i)
+!enddo
+!101 format(i8,2(1x,e15.8))
+
+ end subroutine gwdo_to_MPAS
+
+!=============================================================================================
+ subroutine driver_gwdo(itimestep,mesh,sfc_input,diag_physics,tend_physics)
+!=============================================================================================
+
+!input arguments:
+ type(mesh_type),intent(in):: mesh
+ type(sfc_input_type),intent(in):: sfc_input
+ integer,intent(in):: itimestep
+
+!inout arguments:
+ type(diag_physics_type),intent(inout):: diag_physics
+ type(tend_physics_type),intent(inout):: tend_physics
+
+!local variables:
+ integer:: i,iCell,iEdge
+ real(kind=RKIND),dimension(:),allocatable:: dx_max
+
+!---------------------------------------------------------------------------------------------
+ write(0,*)
+ write(0,*) '--- enter subroutine driver_gwdo: dt_pbl=',dt_pbl
+
+!copy all MPAS arrays to rectanguler grid arrays:
+ call gwdo_from_MPAS(mesh,sfc_input,diag_physics,tend_physics)
+
+ gwdo_select: select case (trim(gwdo_scheme))
+
+ case("ysu_gwdo")
+#if defined(do_hydrostatic_pressure)
+!... REARRANGED CALL USING HYDROSTATIC PRESSURE:
+ call gwdo ( &
+ p3d = pres_hydd_p , p3di = pres2_hydd_p , pi3d = pi_p , &
+ u3d = u_p , v3d = v_p , t3d = t_p , &
+ qv3d = qv_p , z = z_p , rublten = rublten_p , &
+ rvblten = rvblten_p , dtaux3d = dtaux3d_p , dtauy3d = dtauy3d_p , &
+ dusfcg = dusfcg_p , dvsfcg = dvsfcg_p , kpbl2d = kpbl_p , &
+ itimestep = itimestep , dt = dt_pbl , dx = dx_p , &
+ cp = cp , g = g , rd = R_d , &
+ rv = R_v , ep1 = ep_1 , pi = pii , &
+ var2d = var2d_p , oc12d = con_p , oa2d1 = oa1_p , &
+ oa2d2 = oa2_p , oa2d3 = oa3_p , oa2d4 = oa4_p , &
+ ol2d1 = ol1_p , ol2d2 = ol2_p , ol2d3 = ol3_p , &
+ ol2d4 = ol4_p , &
+ ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , &
+ ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , &
+ its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte &
+ )
+#else
+!... REARRANGED CALL:
+ call gwdo ( &
+ )
+#endif
+
+ case default
+
+ end select gwdo_select
+
+!copy all arrays back to the MPAS grid:
+ call gwdo_to_MPAS(diag_physics,tend_physics)
+ write(0,*) '--- end subroutine driver_gwdo'
+
+ end subroutine driver_gwdo
+
+!=============================================================================================
+ end module mpas_atmphys_driver_gwdo
+!=============================================================================================
Modified: trunk/mpas/src/core_atmos_physics/mpas_atmphys_driver_lsm.F
===================================================================
--- trunk/mpas/src/core_atmos_physics/mpas_atmphys_driver_lsm.F 2013-03-27 19:24:59 UTC (rev 2673)
+++ trunk/mpas/src/core_atmos_physics/mpas_atmphys_driver_lsm.F 2013-03-27 19:26:14 UTC (rev 2674)
@@ -75,7 +75,7 @@
if(.not.allocated(qsfc_p) ) allocate(qsfc_p(ims:ime,jms:jme) )
if(.not.allocated(qz0_p) ) allocate(qz0_p(ims:ime,jms:jme) )
if(.not.allocated(rainbl_p) ) allocate(rainbl_p(ims:ime,jms:jme) )
- if(.not.allocated(rib_p) ) allocate(rib_p(ims:ime,jms:jme) )
+ if(.not.allocated(br_p) ) allocate(br_p(ims:ime,jms:jme) )
if(.not.allocated(sfc_albbck_p) ) allocate(sfc_albbck_p(ims:ime,jms:jme) )
if(.not.allocated(sfc_albedo_p) ) allocate(sfc_albedo_p(ims:ime,jms:jme) )
if(.not.allocated(sfc_emibck_p) ) allocate(sfc_emibck_p(ims:ime,jms:jme) )
@@ -139,7 +139,7 @@
if(allocated(qsfc_p) ) deallocate(qsfc_p )
if(allocated(qz0_p) ) deallocate(qz0_p )
if(allocated(rainbl_p) ) deallocate(rainbl_p )
- if(allocated(rib_p) ) deallocate(rib_p )
+ if(allocated(br_p) ) deallocate(br_p )
if(allocated(sfc_albbck_p) ) deallocate(sfc_albbck_p )
if(allocated(sfc_albedo_p) ) deallocate(sfc_albedo_p )
if(allocated(sfc_emibck_p) ) deallocate(sfc_emibck_p )
@@ -221,7 +221,7 @@
qgh_p(i,j) = diag_physics % qgh % array(i)
qsfc_p(i,j) = diag_physics % qsfc % array(i)
qz0_p(i,j) = diag_physics % qz0 % array(i)
- rib_p(i,j) = diag_physics % rib % array(i)
+ br_p(i,j) = diag_physics % br % array(i)
sfc_albedo_p(i,j) = diag_physics % sfc_albedo % array(i)
sfc_emibck_p(i,j) = diag_physics % sfc_emibck % array(i)
sfc_emiss_p(i,j) = diag_physics % sfc_emiss % array(i)
@@ -309,7 +309,7 @@
diag_physics % qgh % array(i) = qgh_p(i,j)
diag_physics % qsfc % array(i) = qsfc_p(i,j)
diag_physics % qz0 % array(i) = qz0_p(i,j)
- diag_physics % rib % array(i) = rib_p(i,j)
+ diag_physics % br % array(i) = br_p(i,j)
diag_physics % sfc_albedo % array(i) = sfc_albedo_p(i,j)
diag_physics % sfc_emibck % array(i) = sfc_emibck_p(i,j)
diag_physics % sfc_emiss % array(i) = sfc_emiss_p(i,j)
@@ -405,7 +405,46 @@
lsm_select: select case (trim(lsm_scheme))
case("noah")
+#if defined(do_hydrostatic_pressure)
+!... REARRANGED CALL USING HYDROSTATIC PRESSURE:
call lsm( &
+ dz8w = dz_p , p8w3d = pres2_hyd_p , t3d = t_p , &
+ qv3d = qv_p , xland = xland_p , xice = xice_p , &
+ ivgtyp = ivgtyp_p , isltyp = isltyp_p , tmn = tmn_p , &
+ vegfra = vegfra_p , shdmin = shdmin_p , shdmax = shdmax_p , &
+ snoalb = snoalb_p , glw = glw_p , gsw = gsw_p , &
+ swdown = swdown_p , rainbl = rainbl_p , embck = sfc_emibck_p , &
+ sr = sr_p , qgh = qgh_p , cpm = cpm_p , &
+ qz0 = qz0_p , tsk = tsk_p , hfx = hfx_p , &
+ qfx = qfx_p , lh = lh_p , grdflx = grdflx_p , &
+ qsfc = qsfc_p , cqs2 = cqs2_p , chs = chs_p , &
+ chs2 = chs2_p , snow = snow_p , snowc = snowc_p , &
+ snowh = snowh_p , canwat = canwat_p , smstav = smstav_p , &
+ smstot = smstot_p , sfcrunoff = sfcrunoff_p , udrunoff = udrunoff_p , &
+ acsnom = acsnom_p , acsnow = acsnow_p , snotime = snotime_p , &
+ snopcx = snopcx_p , emiss = sfc_emiss_p , rib = br_p , &
+ potevp = potevp_p , albedo = sfc_albedo_p , albbck = sfc_albbck_p , &
+ z0 = z0_p , znt = znt_p , lai = lai_p , &
+ noahres = noahres_p , chklowq = chklowq_p , sh2o = sh2o_p , &
+ smois = smois_p , tslb = tslb_p , smcrel = smcrel_p , &
+ dzs = dzs_p , isurban = isurban , isice = isice , &
+ rovcp = rcp , dt = dt_pbl , myj = myj , &
+ itimestep = itimestep , frpcpn = frpcpn , rdlai2d = rdlai2d , &
+ xice_threshold = xice_threshold , &
+ usemonalb = config_sfc_albedo , &
+ mminlu = input_landuse_data , &
+ num_soil_layers = num_soil_layers , &
+ num_roof_layers = num_soil_layers , &
+ num_wall_layers = num_soil_layers , &
+ num_road_layers = num_soil_layers , &
+ num_urban_layers = num_soil_layers , &
+ sf_urban_physics = sf_urban_physics , &
+ ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , &
+ ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , &
+ its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte &
+ )
+#else
+ call lsm( &
dz8w = dz_p , p8w3d = pres2_p , t3d = t_p , &
qv3d = qv_p , xland = xland_p , xice = xice_p , &
ivgtyp = ivgtyp_p , isltyp = isltyp_p , tmn = tmn_p , &
@@ -420,7 +459,7 @@
snowh = snowh_p , canwat = canwat_p , smstav = smstav_p , &
smstot = smstot_p , sfcrunoff = sfcrunoff_p , udrunoff = udrunoff_p , &
acsnom = acsnom_p , acsnow = acsnow_p , snotime = snotime_p , &
- snopcx = snopcx_p , emiss = sfc_emiss_p , rib = rib_p , &
+ snopcx = snopcx_p , emiss = sfc_emiss_p , rib = br_p , &
potevp = potevp_p , albedo = sfc_albedo_p , albbck = sfc_albbck_p , &
z0 = z0_p , znt = znt_p , lai = lai_p , &
noahres = noahres_p , chklowq = chklowq_p , sh2o = sh2o_p , &
@@ -441,6 +480,7 @@
ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , &
its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte &
)
+#endif
case default
Modified: trunk/mpas/src/core_atmos_physics/mpas_atmphys_driver_microphysics.F
===================================================================
--- trunk/mpas/src/core_atmos_physics/mpas_atmphys_driver_microphysics.F 2013-03-27 19:24:59 UTC (rev 2673)
+++ trunk/mpas/src/core_atmos_physics/mpas_atmphys_driver_microphysics.F 2013-03-27 19:26:14 UTC (rev 2674)
@@ -294,6 +294,9 @@
end do
+!... calculate the 10cm radar reflectivity, if needed:
+ if(l_diags) call compute_radar_reflectivity(diag_physics)
+
!... copy updated precipitation from the wrf-physics grid back to the geodesic-dynamics grid:
call precip_to_MPAS(config_bucket_rainnc,diag_physics)
@@ -382,7 +385,8 @@
type(diag_physics_type),intent(inout):: diag_physics
!local variables:
- integer:: i,j
+ integer:: i,j,k
+ real(kind=RKIND):: rho_a
!---------------------------------------------------------------------------------------------
@@ -391,6 +395,14 @@
do j = jts,jte
do i = its,ite
+ !precipitable water:
+ diag_physics % precipw % array(i) = 0._RKIND
+ do k = kts,kte
+ rho_a = rho_p(i,k,j) / (1._RKIND + qv_p(i,k,j))
+ diag_physics % precipw % array(i) = &
+ diag_physics % precipw % array(i) + qv_p(i,k,j) * rho_a * dz_p(i,k,j)
+ enddo
+
!time-step precipitation:
diag_physics % rainncv % array(i) = rainnc_p(i,j)
@@ -438,5 +450,81 @@
end subroutine precip_to_MPAS
!=============================================================================================
+ subroutine compute_radar_reflectivity(diag_physics)
+!=============================================================================================
+
+!inout arguments:
+ type(diag_physics_type),intent(inout):: diag_physics
+
+!local variables:
+ integer:: i,j,k
+ real(kind=RKIND),dimension(:),allocatable:: qv1d,qr1d,qs1d,qg1d,t1d,p1d,dBZ1d
+
+!---------------------------------------------------------------------------------------------
+!write(0,*)
+!write(0,*) '--- enter subroutine COMPUTE_RADAR_REFLECTIVITY:'
+
+ microp_select: select case(microp_scheme)
+
+ case ("kessler")
+ call physics_error_fatal('--- calculation of radar reflectivity is not available' // &
+ 'with kessler cloud microphysics')
+
+ case ("thompson")
+ call physics_error_fatal('--- calculation of radar reflectivity is not available' // &
+ 'with thompson cloud microphysics')
+
+ case ("wsm6")
+
+ if(.not.allocated(p1d) ) allocate(p1d(kts:kte) )
+ if(.not.allocated(t1d) ) allocate(t1d(kts:kte) )
+ if(.not.allocated(qv1d) ) allocate(qv1d(kts:kte) )
+ if(.not.allocated(qr1d) ) allocate(qr1d(kts:kte) )
+ if(.not.allocated(qs1d) ) allocate(qs1d(kts:kte) )
+ if(.not.allocated(qg1d) ) allocate(qg1d(kts:kte) )
+ if(.not.allocated(dBz1d)) allocate(dBZ1d(kts:kte))
+
+ do j = jts,jte
+ do i = its,ite
+ do k = kts,kte
+ p1d(k) = pres_p(i,k,j)
+ t1d(k) = th_p(i,k,j) * pi_p(i,k,j)
+ qv1d(k) = qv_p(i,k,j)
+ qr1d(k) = qr_p(i,k,j)
+ qs1d(k) = qs_p(i,k,j)
+ qg1d(k) = qg_p(i,k,j)
+ dBZ1d(k) = -35._RKIND
+ enddo
+
+ call refl10cm_wsm6(qv1d,qr1d,qs1d,qg1d,t1d,p1d,dBZ1d,kts,kte,i,j)
+
+ do k = kts,kte
+ dBZ1d(k) = max(-35._RKIND,dBZ1d(k))
+! write(0,201) i,k,dBZ1d(k)
+ enddo
+ diag_physics % refl10cm_max % array(i) = maxval(dBZ1d(:))
+! if(diag_physics % refl10cm_max % array(i) .gt. 0.) &
+! write(0,201) j,i,diag_physics % refl10cm_max % array(i)
+ enddo
+ enddo
+
+ if(allocated(p1d) ) deallocate(p1d )
+ if(allocated(t1d) ) deallocate(t1d )
+ if(allocated(qv1d) ) deallocate(qv1d )
+ if(allocated(qr1d) ) deallocate(qr1d )
+ if(allocated(qs1d) ) deallocate(qs1d )
+ if(allocated(qg1d) ) deallocate(qg1d )
+ if(allocated(dBz1d)) deallocate(dBZ1d)
+
+ case default
+
+ end select microp_select
+!write(0,*) '--- end subroutine COMPUTE_RADAR_REFLECTIVITY'
+
+ 201 format(2i6,e15.8)
+
+ end subroutine compute_radar_reflectivity
+
+!=============================================================================================
end module mpas_atmphys_driver_microphysics
!=============================================================================================
Modified: trunk/mpas/src/core_atmos_physics/mpas_atmphys_driver_pbl.F
===================================================================
--- trunk/mpas/src/core_atmos_physics/mpas_atmphys_driver_pbl.F 2013-03-27 19:24:59 UTC (rev 2673)
+++ trunk/mpas/src/core_atmos_physics/mpas_atmphys_driver_pbl.F 2013-03-27 19:26:14 UTC (rev 2674)
@@ -24,11 +24,14 @@
!from surface-layer model:
if(.not.allocated(br_p) ) allocate(br_p(ims:ime,jms:jme) )
+ if(.not.allocated(ctopo_p) ) allocate(ctopo_p(ims:ime,jms:jme) )
+ if(.not.allocated(ctopo2_p) ) allocate(ctopo2_p(ims:ime,jms:jme) )
if(.not.allocated(gz1oz0_p) ) allocate(gz1oz0_p(ims:ime,jms:jme) )
if(.not.allocated(hfx_p) ) allocate(hfx_p(ims:ime,jms:jme) )
if(.not.allocated(psih_p) ) allocate(psih_p(ims:ime,jms:jme) )
if(.not.allocated(psim_p) ) allocate(psim_p(ims:ime,jms:jme) )
if(.not.allocated(qfx_p) ) allocate(qfx_p(ims:ime,jms:jme) )
+ if(.not.allocated(regime_p) ) allocate(regime_p(ims:ime,jms:jme) )
if(.not.allocated(u10_p) ) allocate(u10_p(ims:ime,jms:jme) )
if(.not.allocated(ust_p) ) allocate(ust_p(ims:ime,jms:jme) )
if(.not.allocated(v10_p) ) allocate(v10_p(ims:ime,jms:jme) )
@@ -46,6 +49,10 @@
if(.not.allocated(rqvblten_p)) allocate(rqvblten_p(ims:ime,kms:kme,jms:jme) )
if(.not.allocated(rqcblten_p)) allocate(rqcblten_p(ims:ime,kms:kme,jms:jme) )
if(.not.allocated(rqiblten_p)) allocate(rqiblten_p(ims:ime,kms:kme,jms:jme) )
+!temporary for debugging the YSU PBL scheme:
+ if(.not.allocated(kzh_p) ) allocate(kzh_p(ims:ime,kms:kme,jms:jme) )
+ if(.not.allocated(kzm_p) ) allocate(kzm_p(ims:ime,kms:kme,jms:jme) )
+ if(.not.allocated(kzq_p) ) allocate(kzq_p(ims:ime,kms:kme,jms:jme) )
end subroutine allocate_pbl
@@ -55,11 +62,14 @@
!from surface-layer model:
if(allocated(br_p) ) deallocate(br_p )
+ if(allocated(ctopo_p) ) deallocate(ctopo_p )
+ if(allocated(ctopo2_p) ) deallocate(ctopo2_p )
if(allocated(gz1oz0_p) ) deallocate(gz1oz0_p )
if(allocated(hfx_p) ) deallocate(hfx_p )
if(allocated(psih_p) ) deallocate(psih_p )
if(allocated(psim_p) ) deallocate(psim_p )
if(allocated(qfx_p) ) deallocate(qfx_p )
+ if(allocated(regime_p) ) deallocate(regime_p )
if(allocated(u10_p) ) deallocate(u10_p )
if(allocated(ust_p) ) deallocate(ust_p )
if(allocated(v10_p) ) deallocate(v10_p )
@@ -77,6 +87,10 @@
if(allocated(rqvblten_p)) deallocate(rqvblten_p )
if(allocated(rqcblten_p)) deallocate(rqcblten_p )
if(allocated(rqiblten_p)) deallocate(rqiblten_p )
+!temporary for debugging the YSU PBL scheme:
+ if(allocated(kzh_p) ) deallocate(kzh_p )
+ if(allocated(kzm_p) ) deallocate(kzm_p )
+ if(allocated(kzq_p) ) deallocate(kzq_p )
end subroutine deallocate_pbl
@@ -100,6 +114,7 @@
psim_p(i,j) = diag_physics % psim % array(i)
psih_p(i,j) = diag_physics % psih % array(i)
qfx_p(i,j) = diag_physics % qfx % array(i)
+ regime_p(i,j) = diag_physics % regime % array(i)
u10_p(i,j) = diag_physics % u10 % array(i)
ust_p(i,j) = diag_physics % ust % array(i)
v10_p(i,j) = diag_physics % v10 % array(i)
@@ -108,6 +123,8 @@
xland_p(i,j) = sfc_input % xland % array(i)
!initialization for YSU PBL scheme:
+ ctopo_p(i,j) = 1._RKIND
+ ctopo2_p(i,j) = 1._RKIND
kpbl_p(i,j) = 1
enddo
enddo
@@ -122,9 +139,12 @@
rqvblten_p(i,k,j) = 0.
rqcblten_p(i,k,j) = 0.
rqiblten_p(i,k,j) = 0.
+!temporary for debugging the YSU PBL scheme:
+ kzh_p(i,k,j) = 0._RKIND
+ kzm_p(i,k,j) = 0._RKIND
+ kzq_p(i,k,j) = 0._RKIND
enddo
enddo
-
enddo
end subroutine pbl_from_MPAS
@@ -156,6 +176,10 @@
tend_physics % rqvblten % array(k,i) = rqvblten_p(i,k,j)
tend_physics % rqcblten % array(k,i) = rqcblten_p(i,k,j)
tend_physics % rqiblten % array(k,i) = rqiblten_p(i,k,j)
+!temporary for debugging the YSU PBL scheme:
+ diag_physics % kzh % array(k,i) = kzh_p(i,k,j)
+ diag_physics % kzm % array(k,i) = kzm_p(i,k,j)
+ diag_physics % kzq % array(k,i) = kzq_p(i,k,j)
enddo
enddo
enddo
@@ -182,26 +206,55 @@
pbl_select: select case (trim(pbl_scheme))
case("ysu")
+#if defined(do_hydrostatic_pressure)
+!... REARRANGED CALL USING HYDROSTATIC PRESSURE:
call ysu ( &
- u3d = u_p , v3d = v_p , th3d = th_p , &
- t3d = t_p , qv3d = qv_p , qc3d = qc_p , &
- qi3d = qi_p , p3d = pres_p , p3di = pres2_p , &
- pi3d = pi_p , rublten = rublten_p , rvblten = rvblten_p , &
- rthblten = rthblten_p , rqvblten = rqvblten_p , rqcblten = rqcblten_p , &
- rqiblten = rqiblten_p , flag_qi = f_qi , cp = cp , &
- g = g , rovcp = rcp , rd = R_d , &
- rovg = rdg , ep1 = ep_1 , ep2 = ep_2 , &
- karman = karman , xlv = xlv , rv = R_v , &
- dz8w = dz_p , psfc = psfc_p , znt = znt_p , &
+ p3d = pres_hyd_p , p3di = pres2_hyd_p , psfc = psfc_p , &
+ th3d = th_p , t3d = t_p , dz8w = dz_p , &
+ pi3d = pi_p , u3d = u_p , v3d = v_p , &
+ qv3d = qv_p , qc3d = qc_p , qi3d = qi_p , &
+ rublten = rublten_p , rvblten = rvblten_p , rthblten = rthblten_p , &
+ rqvblten = rqvblten_p , rqcblten = rqcblten_p , rqiblten = rqiblten_p , &
+ flag_qi = f_qi , cp = cp , g = g , &
+ rovcp = rcp , rd = R_d , rovg = rdg , &
+ ep1 = ep_1 , ep2 = ep_2 , karman = karman , &
+ xlv = xlv , rv = R_v , znt = znt_p , &
ust = ust_p , hpbl = hpbl_p , psim = psim_p , &
psih = psih_p , xland = xland_p , hfx = hfx_p , &
- qfx = qfx_p , gz1oz0 = gz1oz0_p , wspd = wspd_p , &
- br = br_p , dt = dt_pbl , kpbl2d = kpbl_p , &
- exch_h = exch_p , u10 = u10_p , v10 = v10_p , &
+ qfx = qfx_p , wspd = wspd_p , br = br_p , &
+ dt = dt_pbl , kpbl2d = kpbl_p , exch_h = exch_p , &
+ u10 = u10_p , v10 = v10_p , ctopo = ctopo_p , &
+ ctopo2 = ctopo2_p , regime = regime_p , rho = rho_p , &
+ kzhout = kzh_p , kzmout = kzm_p , kzqout = kzq_p , &
ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , &
ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , &
its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte &
)
+#else
+!... REARRANGED CALL:
+ call ysu ( &
+ p3d = pres_p , p3di = pres2_p , psfc = psfc_p , &
+ th3d = th_p , t3d = t_p , dz8w = dz_p , &
+ pi3d = pi_p , u3d = u_p , v3d = v_p , &
+ qv3d = qv_p , qc3d = qc_p , qi3d = qi_p , &
+ rublten = rublten_p , rvblten = rvblten_p , rthblten = rthblten_p , &
+ rqvblten = rqvblten_p , rqcblten = rqcblten_p , rqiblten = rqiblten_p , &
+ flag_qi = f_qi , cp = cp , g = g , &
+ rovcp = rcp , rd = R_d , rovg = rdg , &
+ ep1 = ep_1 , ep2 = ep_2 , karman = karman , &
+ xlv = xlv , rv = R_v , znt = znt_p , &
+ ust = ust_p , hpbl = hpbl_p , psim = psim_p , &
+ psih = psih_p , xland = xland_p , hfx = hfx_p , &
+ qfx = qfx_p , wspd = wspd_p , br = br_p , &
+ dt = dt_pbl , kpbl2d = kpbl_p , exch_h = exch_p , &
+ u10 = u10_p , v10 = v10_p , ctopo = ctopo_p , &
+ ctopo2 = ctopo2_p , regime = regime_p , rho = rho_p , &
+ kzhout = kzh_p , kzmout = kzm_p , kzqout = kzq_p , &
+ ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , &
+ ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , &
+ its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte &
+ )
+#endif
case default
@@ -209,7 +262,7 @@
!copy all arrays back to the MPAS grid:
call pbl_to_MPAS(diag_physics,tend_physics)
- write(0,*) '--- enter subroutine driver_pbl'
+ write(0,*) '--- end subroutine driver_pbl'
end subroutine driver_pbl
Modified: trunk/mpas/src/core_atmos_physics/mpas_atmphys_driver_radiation_lw.F
===================================================================
--- trunk/mpas/src/core_atmos_physics/mpas_atmphys_driver_radiation_lw.F 2013-03-27 19:24:59 UTC (rev 2673)
+++ trunk/mpas/src/core_atmos_physics/mpas_atmphys_driver_radiation_lw.F 2013-03-27 19:26:14 UTC (rev 2674)
@@ -524,14 +524,42 @@
case ("rrtmg_lw")
write(0,*) '--- enter subroutine rrtmg_lwrad:'
+#if defined(do_hydrostatic_pressure)
+!... REARRANGED CALL USING HYDROSTATIC PRESSURE:
call rrtmg_lwrad( &
+ p3d = pres_hyd_p , p8w = pres2_hyd_p , pi3d = pi_p , &
+ t3d = t_p , t8w = t2_p , rho3d = rho_p , &
+ rthratenlw = rthratenlw_p , lwupt = lwupt_p , lwuptc = lwuptc_p , &
+ lwdnt = lwdnt_p , lwdntc = lwdntc_p , lwupb = lwupb_p , &
+ lwupbc = lwupbc_p , lwdnb = lwdnb_p , lwdnbc = lwdnbc_p , &
+ lwcf = lwcf_p , glw = glw_p , olr = olrtoa_p , &
+ emiss = sfc_emiss_p , tsk = tsk_p , dz8w = dz_p , &
+ cldfra3d = cldfrac_p , r = R_d , g = g , &
+ icloud = icloud , warm_rain = warm_rain , f_ice_phy = f_ice , &
+ f_rain_phy = f_rain , xland = xland_p , xice = xice_p , &
+ snow = snow_p , qv3d = qv_p , qc3d = qc_p , &
+ qr3d = qr_p , qi3d = qi_p , qs3d = qs_p , &
+ qg3d = qg_p , f_qv = f_qv , f_qc = f_qc , &
+ f_qr = f_qr , f_qi = f_qi , f_qs = f_qs , &
+ f_qg = f_qg , &
+ !begin optional arguments:
+ !lwupflx = lwupflx_p , lwupflxc = lwupflxc_p , lwdnflx = lwdnflx_p , &
+ !lwdnflxc = lwdnflxc_p , &
+ !end optional arguments.
+ ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , &
+ ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , &
+ its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte &
+ )
+#else
+!... REARRANGED CALL:
+ call rrtmg_lwrad( &
+ p3d = pres_p , p8w = pres2_p , pi3d = pi_p , &
+ t3d = t_p , t8w = t2_p , rho3d = rho_p , &
rthratenlw = rthratenlw_p , lwupt = lwupt_p , lwuptc = lwuptc_p , &
lwdnt = lwdnt_p , lwdntc = lwdntc_p , lwupb = lwupb_p , &
lwupbc = lwupbc_p , lwdnb = lwdnb_p , lwdnbc = lwdnbc_p , &
lwcf = lwcf_p , glw = glw_p , olr = olrtoa_p , &
- emiss = sfc_emiss_p , t3d = t_p , t8w = t2_p , &
- tsk = tsk_p , p3d = pres_p , p8w = pres2_p , &
- pi3d = pi_p , rho3d = rho_p , dz8w = dz_p , &
+ emiss = sfc_emiss_p , tsk = tsk_p , dz8w = dz_p , &
cldfra3d = cldfrac_p , r = R_d , g = g , &
icloud = icloud , warm_rain = warm_rain , f_ice_phy = f_ice , &
f_rain_phy = f_rain , xland = xland_p , xice = xice_p , &
@@ -541,13 +569,39 @@
f_qr = f_qr , f_qi = f_qi , f_qs = f_qs , &
f_qg = f_qg , &
!begin optional arguments:
- !lwupflx = lwupflx_p , lwupflxc = lwupflxc_p , lwdnflx = lwdnflx_p, &
- !lwdnflxc = lwdnflxc_p , &
+ !lwupflx = lwupflx_p , lwupflxc = lwupflxc_p , lwdnflx = lwdnflx_p, &
+ !lwdnflxc = lwdnflxc_p , &
!end optional arguments.
ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , &
ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , &
its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte &
)
+#endif
+!... CALL FROM REVISION 1721:
+! call rrtmg_lwrad( &
+! rthratenlw = rthratenlw_p , lwupt = lwupt_p , lwuptc = lwuptc_p , &
+! lwdnt = lwdnt_p , lwdntc = lwdntc_p , lwupb = lwupb_p , &
+! lwupbc = lwupbc_p , lwdnb = lwdnb_p , lwdnbc = lwdnbc_p , &
+! lwcf = lwcf_p , glw = glw_p , olr = olrtoa_p , &
+! emiss = sfc_emiss_p , t3d = t_p , t8w = t2_p , &
+! tsk = tsk_p , p3d = pres_p , p8w = pres2_p , &
+! pi3d = pi_p , rho3d = rho_p , dz8w = dz_p , &
+! cldfra3d = cldfrac_p , r = R_d , g = g , &
+! icloud = icloud , warm_rain = warm_rain , f_ice_phy = f_ice , &
+! f_rain_phy = f_rain , xland = xland_p , xice = xice_p , &
+! snow = snow_p , qv3d = qv_p , qc3d = qc_p , &
+! qr3d = qr_p , qi3d = qi_p , qs3d = qs_p , &
+! qg3d = qg_p , f_qv = f_qv , f_qc = f_qc , &
+! f_qr = f_qr , f_qi = f_qi , f_qs = f_qs , &
+! f_qg = f_qg , &
+! !begin optional arguments:
+! !lwupflx = lwupflx_p , lwupflxc = lwupflxc_p , lwdnflx = lwdnflx_p, &
+! !lwdnflxc = lwdnflxc_p , &
+! !end optional arguments.
+! ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , &
+! ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , &
+! its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte &
+! )
write(0,*) '--- exit subroutine rrtmg_lwrad'
case ("cam_lw")
@@ -562,7 +616,12 @@
call mpas_timer_start("camrad")
write(0,*) '--- enter subroutine camrad_lw: doabsems=',doabsems
call mpas_timer_start("camrad")
+#if defined(do_hydrostatic_pressure)
+!... REARRANGED CALL USING HYDROSTATIC PRESSURE:
call camrad( dolw = .true. , dosw = .false. , &
+ p_phy = pres_hyd_p , p8w = pres2_hyd_p , &
+ pi_phy = pi_p , t_phy = t_p , &
+ z = zmid_p , dz8w = dz_p , &
rthratenlw = rthratenlw_p , rthratensw = rthratensw_p , &
swupt = swupt_p , swuptc = swuptc_p , &
swdnt = swdnt_p , swdntc = swdntc_p , &
@@ -579,9 +638,56 @@
coszr = coszr_p , albedo = sfc_albedo_p , &
emiss = sfc_emiss_p , tsk = tsk_p , &
xlat = xlat_p , xlong = xlon_p , &
- t_phy = t_p , pi_phy = pi_p , &
+ rho_phy = rho_p , qv3d = qv_p , &
+ qc3d = qc_p , qr3d = qr_p , &
+ qi3d = qi_p , qs3d = qs_p , &
+ qg3d = qg_p , f_qv = f_qv , &
+ f_qc = f_qc , f_qr = f_qr , &
+ f_qi = f_qi , f_qs = f_qs , &
+ f_qg = f_qg , f_ice_phy = f_ice , &
+ f_rain_phy = f_rain , cldfra = cldfrac_p , &
+ xland = xland_p , xice = xice_p , &
+ num_months = num_months , levsiz = num_oznlevels , &
+ pin0 = pin_p , ozmixm = ozmixm_p , &
+ paerlev = num_aerlevels , naer_c = num_aerosols , &
+ m_psp = m_psp_p , m_psn = m_psn_p , &
+ aerosolcp = aerosolcp_p , aerosolcn = aerosolcn_p , &
+ m_hybi0 = m_hybi_p , snow = snow_p , &
+ cam_abs_dim1 = cam_abs_dim1 , cam_abs_dim2 = cam_abs_dim2 , &
+ gmt = gmt , yr = year , &
+ julday = julday , julian = curr_julday , &
+ dt = dt_dyn , xtime = xtime_m , &
+ declin = declin , solcon = solcon , &
+ radt = radt , degrad = degrad , &
+ n_cldadv = 3 , abstot_3d = abstot_p , &
+ absnxt_3d = absnxt_p , emstot_3d = emstot_p , &
+ doabsems = doabsems , &
+ ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , &
+ ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , &
+ its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte &
+ )
+#else
+!... REARRANGED CALL:
+ call camrad( dolw = .true. , dosw = .false. , &
p_phy = pres_p , p8w = pres2_p , &
+ pi_phy = pi_p , t_phy = t_p , &
z = zmid_p , dz8w = dz_p , &
+ rthratenlw = rthratenlw_p , rthratensw = rthratensw_p , &
+ swupt = swupt_p , swuptc = swuptc_p , &
+ swdnt = swdnt_p , swdntc = swdntc_p , &
+ lwupt = lwupt_p , lwuptc = lwuptc_p , &
+ lwdnt = lwdnt_p , lwdntc = lwdntc_p , &
+ swupb = swupb_p , swupbc = swupbc_p , &
+ swdnb = swdnb_p , swdnbc = swdnbc_p , &
+ lwupb = lwupb_p , lwupbc = lwupbc_p , &
+ lwdnb = lwdnb_p , lwdnbc = lwdnbc_p , &
+ swcf = swcf_p , lwcf = lwcf_p , &
+ gsw = gsw_p , glw = glw_p , &
+ olr = olrtoa_p , cemiss = cemiss_p , &
+ taucldc = taucldc_p , taucldi = taucldi_p , &
+ coszr = coszr_p , albedo = sfc_albedo_p , &
+ emiss = sfc_emiss_p , tsk = tsk_p , &
+ xlat = xlat_p , xlong = xlon_p , &
rho_phy = rho_p , qv3d = qv_p , &
qc3d = qc_p , qr3d = qr_p , &
qi3d = qi_p , qs3d = qs_p , &
@@ -610,6 +716,56 @@
ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , &
its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte &
)
+#endif
+!... CALL FROM REVISION 1721:
+! call camrad( dolw = .true. , dosw = .false. , &
+! rthratenlw = rthratenlw_p , rthratensw = rthratensw_p , &
+! swupt = swupt_p , swuptc = swuptc_p , &
+! swdnt = swdnt_p , swdntc = swdntc_p , &
+! lwupt = lwupt_p , lwuptc = lwuptc_p , &
+! lwdnt = lwdnt_p , lwdntc = lwdntc_p , &
+! swupb = swupb_p , swupbc = swupbc_p , &
+! swdnb = swdnb_p , swdnbc = swdnbc_p , &
+! lwupb = lwupb_p , lwupbc = lwupbc_p , &
+! lwdnb = lwdnb_p , lwdnbc = lwdnbc_p , &
+! swcf = swcf_p , lwcf = lwcf_p , &
+! gsw = gsw_p , glw = glw_p , &
+! olr = olrtoa_p , cemiss = cemiss_p , &
+! taucldc = taucldc_p , taucldi = taucldi_p , &
+! coszr = coszr_p , albedo = sfc_albedo_p , &
+! emiss = sfc_emiss_p , tsk = tsk_p , &
+! xlat = xlat_p , xlong = xlon_p , &
+! t_phy = t_p , pi_phy = pi_p , &
+! p_phy = pres_p , p8w = pres2_p , &
+! z = zmid_p , dz8w = dz_p , &
+! rho_phy = rho_p , qv3d = qv_p , &
+! qc3d = qc_p , qr3d = qr_p , &
+! qi3d = qi_p , qs3d = qs_p , &
+! qg3d = qg_p , f_qv = f_qv , &
+! f_qc = f_qc , f_qr = f_qr , &
+! f_qi = f_qi , f_qs = f_qs , &
+! f_qg = f_qg , f_ice_phy = f_ice , &
+! f_rain_phy = f_rain , cldfra = cldfrac_p , &
+! xland = xland_p , xice = xice_p , &
+! num_months = num_months , levsiz = num_oznlevels , &
+! pin0 = pin_p , ozmixm = ozmixm_p , &
+! paerlev = num_aerlevels , naer_c = num_aerosols , &
+! m_psp = m_psp_p , m_psn = m_psn_p , &
+! aerosolcp = aerosolcp_p , aerosolcn = aerosolcn_p , &
+! m_hybi0 = m_hybi_p , snow = snow_p , &
+! cam_abs_dim1 = cam_abs_dim1 , cam_abs_dim2 = cam_abs_dim2 , &
+! gmt = gmt , yr = year , &
+! julday = julday , julian = curr_julday , &
+! dt = dt_dyn , xtime = xtime_m , &
+! declin = declin , solcon = solcon , &
+! radt = radt , degrad = degrad , &
+! n_cldadv = 3 , abstot_3d = abstot_p , &
+! absnxt_3d = absnxt_p , emstot_3d = emstot_p , &
+! doabsems = doabsems , &
+! ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , &
+! ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , &
+! its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte &
+! )
call mpas_timer_stop("camrad")
! write(0,*) 'max lwupb =',maxval(lwupb_p(its:ite,jms:jme))
! write(0,*) 'max lwupbc =',maxval(lwupbc_p(its:ite,jms:jme))
Modified: trunk/mpas/src/core_atmos_physics/mpas_atmphys_driver_radiation_sw.F
===================================================================
--- trunk/mpas/src/core_atmos_physics/mpas_atmphys_driver_radiation_sw.F 2013-03-27 19:24:59 UTC (rev 2673)
+++ trunk/mpas/src/core_atmos_physics/mpas_atmphys_driver_radiation_sw.F 2013-03-27 19:26:14 UTC (rev 2674)
@@ -21,6 +21,14 @@
init_radiation_sw, &
radconst
+!add-ons and modifications to sourcecode:
+! * removed commented out sourcecode left from revision 1721. removed commented out calls to
+! subroutines rrtmg_swrad and camrad.
+! * updated call to subroutine rrtmg_swrad in order to use module_ra_rrtmg_sw.F from WRF 3.4.1
+! instead of WRF 3.2.1. Results are unchanged.
+! Laura D. Fowler (birch.ucar.edu) / 2013-03-13.
+
+
integer,private:: i,j,k,n
contains
@@ -63,6 +71,15 @@
radiation_sw_select: select case (trim(radt_sw_scheme))
case("rrtmg_sw")
+ if(.not.allocated(alswvisdir_p) ) allocate(alswvisdir_p(ims:ime,jms:jme) )
+ if(.not.allocated(alswvisdif_p) ) allocate(alswvisdif_p(ims:ime,jms:jme) )
+ if(.not.allocated(alswnirdir_p) ) allocate(alswnirdir_p(ims:ime,jms:jme) )
+ if(.not.allocated(alswnirdif_p) ) allocate(alswnirdif_p(ims:ime,jms:jme) )
+ if(.not.allocated(swvisdir_p) ) allocate(swvisdir_p(ims:ime,jms:jme) )
+ if(.not.allocated(swvisdif_p) ) allocate(swvisdif_p(ims:ime,jms:jme) )
+ if(.not.allocated(swnirdir_p) ) allocate(swnirdir_p(ims:ime,jms:jme) )
+ if(.not.allocated(swnirdif_p) ) allocate(swnirdif_p(ims:ime,jms:jme) )
+
if(.not.allocated(swdnflx_p) ) allocate(swdnflx_p(ims:ime,kms:kme+1,jms:jme) )
if(.not.allocated(swdnflxc_p) ) allocate(swdnflxc_p(ims:ime,kms:kme+1,jms:jme) )
if(.not.allocated(swupflx_p) ) allocate(swupflx_p(ims:ime,kms:kme+1,jms:jme) )
@@ -146,6 +163,11 @@
radiation_sw_select: select case (trim(radt_sw_scheme))
case("rrtmg_sw")
+ if(allocated(alswvisdir_p) ) deallocate(alswvisdir_p )
+ if(allocated(alswvisdif_p) ) deallocate(alswvisdif_p )
+ if(allocated(alswnirdir_p) ) deallocate(alswnirdir_p )
+ if(allocated(alswnirdif_p) ) deallocate(alswnirdif_p )
+
if(allocated(swdnflx_p) ) deallocate(swdnflx_p )
if(allocated(swdnflxc_p) ) deallocate(swdnflxc_p )
if(allocated(swupflx_p) ) deallocate(swupflx_p )
@@ -497,39 +519,78 @@
case ("rrtmg_sw")
write(0,*) '--- enter subroutine rrtmg_swrad:'
+#if defined(do_hydrostatic_pressure)
+!... REARRANGED CALL USING HYDROSTATIC PRESSURE:
call rrtmg_swrad( &
- rthratensw = rthratensw_p , swupt = swupt_p , swuptc = swuptc_p , &
- swdnt = swdnt_p , swdntc = swdntc_p , swupb = swupb_p , &
- swupbc = swupbc_p , swdnb = swdnb_p , swdnbc = swdnbc_p , &
- swcf = swcf_p , gsw = gsw_p , xtime = xtime_m , &
- gmt = gmt , xlat = xlat_p , xlong = xlon_p , &
- radt = radt , degrad = degrad , declin = declin , &
- coszr = coszr_p , julday = julday , solcon = solcon , &
- albedo = sfc_albedo_p , t3d = t_p , t8w = t2_p , &
- tsk = tsk_p , p3d = pres_p , p8w = pres2_p , &
- pi3d = pi_p , rho3d = rho_p , dz8w = dz_p , &
- cldfra3d = cldfrac_p , r = R_d , g = g , &
- icloud = icloud , warm_rain = warm_rain , f_ice_phy = f_ice , &
- f_rain_phy = f_rain , xland = xland_p , xice = xice_p , &
- snow = snow_p , qv3d = qv_p , qc3d = qc_p , &
- qr3d = qr_p , qi3d = qi_p , qs3d = qs_p , &
- qg3d = qg_p , f_qv = f_qv , f_qc = f_qc , &
- f_qr = f_qr , f_qi = f_qi , f_qs = f_qs , &
- f_qg = f_qg , &
+ p3d = pres_hyd_p , p8w = pres2_hyd_p , pi3d = pi_p ,&
+ t3d = t_p , t8w = t2_p , rho3d = rho_p ,&
+ rthratensw = rthratensw_p , swupt = swupt_p , swuptc = swuptc_p ,&
+ swdnt = swdnt_p , swdntc = swdntc_p , swupb = swupb_p ,&
+ swupbc = swupbc_p , swdnb = swdnb_p , swdnbc = swdnbc_p ,&
+ swcf = swcf_p , gsw = gsw_p , xtime = xtime_m ,&
+ gmt = gmt , xlat = xlat_p , xlong = xlon_p ,&
+ radt = radt , degrad = degrad , declin = declin ,&
+ coszr = coszr_p , julday = julday , solcon = solcon ,&
+ albedo = sfc_albedo_p , tsk = tsk_p , dz8w = dz_p ,&
+ cldfra3d = cldfrac_p , r = R_d , g = g ,&
+ icloud = icloud , warm_rain = warm_rain , f_ice_phy = f_ice ,&
+ f_rain_phy = f_rain , xland = xland_p , xice = xice_p ,&
+ snow = snow_p , qv3d = qv_p , qc3d = qc_p ,&
+ qr3d = qr_p , qi3d = qi_p , qs3d = qs_p ,&
+ qg3d = qg_p , sf_surface_physics = sf_surface_physics , &
!begin optional arguments:
- swupflx = swupflx_p , swupflxc = swupflxc_p , swdnflx = swdnflx_p , &
- swdnflxc = swdnflxc_p , &
+ f_qv = f_qv , f_qc = f_qc , f_qr = f_qr ,&
+ f_qi = f_qi , f_qs = f_qs , f_qg = f_qg ,&
+ alswvisdir = alswvisdir_p , alswvisdif = alswvisdif_p , alswnirdir = alswnirdir_p,&
+ alswnirdif = alswnirdif_p , swvisdir = swvisdir_p , swvisdif = swvisdif_p ,&
+ swnirdir = swnirdir_p , swnirdif = swnirdif_p , &
!end optional arguments.
- ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , &
- ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , &
- its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte &
+ ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde ,&
+ ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme ,&
+ its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte &
)
+#else
+!... REARRANGED CALL:
+ call rrtmg_swrad( &
+ p3d = pres_p , p8w = pres2_p , pi3d = pi_p ,&
+ t3d = t_p , t8w = t2_p , rho3d = rho_p ,&
+ rthratensw = rthratensw_p , swupt = swupt_p , swuptc = swuptc_p ,&
+ swdnt = swdnt_p , swdntc = swdntc_p , swupb = swupb_p ,&
+ swupbc = swupbc_p , swdnb = swdnb_p , swdnbc = swdnbc_p ,&
+ swcf = swcf_p , gsw = gsw_p , xtime = xtime_m ,&
+ gmt = gmt , xlat = xlat_p , xlong = xlon_p ,&
+ radt = radt , degrad = degrad , declin = declin ,&
+ coszr = coszr_p , julday = julday , solcon = solcon ,&
+ albedo = sfc_albedo_p , tsk = tsk_p , dz8w = dz_p ,&
+ cldfra3d = cldfrac_p , r = R_d , g = g ,&
+ icloud = icloud , warm_rain = warm_rain , f_ice_phy = f_ice ,&
+ f_rain_phy = f_rain , xland = xland_p , xice = xice_p ,&
+ snow = snow_p , qv3d = qv_p , qc3d = qc_p ,&
+ qr3d = qr_p , qi3d = qi_p , qs3d = qs_p ,&
+ qg3d = qg_p , sf_surface_physics = sf_surface_physics , &
+ !begin optional arguments:
+ f_qv = f_qv , f_qc = f_qc , f_qr = f_qr ,&
+ f_qi = f_qi , f_qs = f_qs , f_qg = f_qg ,&
+ alswvisdir = alswvisdir_p , alswvisdif = alswvisdif_p , alswnirdir = alswnirdir_p,&
+ alswnirdif = alswnirdif_p , swvisdir = swvisdir_p , swvisdif = swvisdif_p ,&
+ swnirdir = swnirdir_p , swnirdif = swnirdif_p , &
+ !end optional arguments.
+ ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde ,&
+ ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme ,&
+ its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte &
+ )
+#endif
write(0,*) '--- exit subroutine rrtmg_swrad'
case ("cam_sw")
write(0,*) '--- enter subroutine camrad_sw:'
+#if defined(do_hydrostatic_pressure)
+!... REARRANGED CALL USING HYDROSTATIC PRESSURE:
call camrad( dolw = .false. , dosw = .true. , &
+ p_phy = pres_hyd_p , p8w = pres2_hyd_p , &
+ pi_phy = pi_p , t_phy = t_p , &
+ z = zmid_p , dz8w = dz_p , &
rthratenlw = rthratenlw_p , rthratensw = rthratensw_p , &
swupt = swupt_p , swuptc = swuptc_p , &
swdnt = swdnt_p , swdntc = swdntc_p , &
@@ -546,9 +607,61 @@
coszr = coszr_p , albedo = sfc_albedo_p , &
emiss = sfc_emiss_p , tsk = tsk_p , &
xlat = xlat_p , xlong = xlon_p , &
- t_phy = t_p , pi_phy = pi_p , &
+ rho_phy = rho_p , qv3d = qv_p , &
+ qc3d = qc_p , qr3d = qr_p , &
+ qi3d = qi_p , qs3d = qs_p , &
+ qg3d = qg_p , f_qv = f_qv , &
+ f_qc = f_qc , f_qr = f_qr , &
+ f_qi = f_qi , f_qs = f_qs , &
+ f_qg = f_qg , f_ice_phy = f_ice , &
+ f_rain_phy = f_rain , cldfra = cldfrac_p , &
+ xland = xland_p , xice = xice_p , &
+ num_months = num_months , levsiz = num_oznlevels , &
+ pin0 = pin_p , ozmixm = ozmixm_p , &
+ paerlev = num_aerlevels , naer_c = num_aerosols , &
+ m_psp = m_psp_p , m_psn = m_psn_p , &
+ aerosolcp = aerosolcp_p , aerosolcn = aerosolcn_p , &
+ m_hybi0 = m_hybi_p , snow = snow_p , &
+ cam_abs_dim1 = cam_abs_dim1 , cam_abs_dim2 = cam_abs_dim2 , &
+ gmt = gmt , yr = year , &
+ julday = julday , julian = curr_julday , &
+ dt = dt_dyn , xtime = xtime_m , &
+ declin = declin , solcon = solcon , &
+ radt = radt , degrad = degrad , &
+ n_cldadv = 3 , abstot_3d = abstot_p , &
+ absnxt_3d = absnxt_p , emstot_3d = emstot_p , &
+ doabsems = doabsems , &
+ ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , &
+ ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , &
+ its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte &
+ )
+! do j = jts,jte
+! do i = its,ite
+! write(0,200) j,i,swdnt_p(i,j),swdnb_p(i,j),swupt_p(i,j),swupb_p(i,j)
+! enddo
+! enddo
+#else
+!... REARRANGED CALL:
+ call camrad( dolw = .false. , dosw = .true. , &
p_phy = pres_p , p8w = pres2_p , &
+ pi_phy = pi_p , t_phy = t_p , &
z = zmid_p , dz8w = dz_p , &
+ rthratenlw = rthratenlw_p , rthratensw = rthratensw_p , &
+ swupt = swupt_p , swuptc = swuptc_p , &
+ swdnt = swdnt_p , swdntc = swdntc_p , &
+ lwupt = lwupt_p , lwuptc = lwuptc_p , &
+ lwdnt = lwdnt_p , lwdntc = lwdntc_p , &
+ swupb = swupb_p , swupbc = swupbc_p , &
+ swdnb = swdnb_p , swdnbc = swdnbc_p , &
+ lwupb = lwupb_p , lwupbc = lwupbc_p , &
+ lwdnb = lwdnb_p , lwdnbc = lwdnbc_p , &
+ swcf = swcf_p , lwcf = lwcf_p , &
+ gsw = gsw_p , glw = glw_p , &
+ olr = olrtoa_p , cemiss = cemiss_p , &
+ taucldc = taucldc_p , taucldi = taucldi_p , &
+ coszr = coszr_p , albedo = sfc_albedo_p , &
+ emiss = sfc_emiss_p , tsk = tsk_p , &
+ xlat = xlat_p , xlong = xlon_p , &
rho_phy = rho_p , qv3d = qv_p , &
qc3d = qc_p , qr3d = qr_p , &
qi3d = qi_p , qs3d = qs_p , &
@@ -577,6 +690,7 @@
ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , &
its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte &
)
+#endif
! write(0,*) 'doabsems =',doabsems
! write(0,*) 'max swupb =',maxval(swupb_p(its:ite,jms:jme))
! write(0,*) 'max swupbc =',maxval(swupbc_p(its:ite,jms:jme))
Modified: trunk/mpas/src/core_atmos_physics/mpas_atmphys_driver_sfclayer.F
===================================================================
--- trunk/mpas/src/core_atmos_physics/mpas_atmphys_driver_sfclayer.F 2013-03-27 19:24:59 UTC (rev 2673)
+++ trunk/mpas/src/core_atmos_physics/mpas_atmphys_driver_sfclayer.F 2013-03-27 19:26:14 UTC (rev 2674)
@@ -1,4 +1,4 @@
-!=============================================================================================
+!==================================================================================================
module mpas_atmphys_driver_sfclayer
use mpas_grid_types
@@ -17,15 +17,17 @@
integer,parameter,private:: isfflx = 1 !=1 for surface heat and moisture fluxes.
integer,parameter,private:: isftcflx = 0 !=0,(Charnock and Carlson-Boland).
- integer,parameter,private:: iz0tlnd = 0 !=0,(Carlson-Boland)
+ integer,parameter,private:: iz0tlnd = 0 !=0,(Carlson-Boland).
+ integer,parameter,private:: scm_force_flux = 0 !SCM surface forcing by surface fluxes.
+ !0=no 1=yes (WRF single column model option only).
integer,private:: i,j
contains
-!=============================================================================================
+!==================================================================================================
subroutine allocate_sfclayer
-!=============================================================================================
+!==================================================================================================
if(.not.allocated(area_p) ) allocate(area_p(ims:ime,jms:jme) )
if(.not.allocated(br_p) ) allocate(br_p(ims:ime,jms:jme) )
@@ -33,13 +35,15 @@
if(.not.allocated(cda_p) ) allocate(cda_p(ims:ime,jms:jme) )
if(.not.allocated(chs_p) ) allocate(chs_p(ims:ime,jms:jme) )
if(.not.allocated(chs2_p) ) allocate(chs2_p(ims:ime,jms:jme) )
+ if(.not.allocated(ck_p) ) allocate(ck_p(ims:ime,jms:jme) )
+ if(.not.allocated(cka_p) ) allocate(cka_p(ims:ime,jms:jme) )
if(.not.allocated(cpm_p) ) allocate(cpm_p(ims:ime,jms:jme) )
if(.not.allocated(cqs2_p) ) allocate(cqs2_p(ims:ime,jms:jme) )
- if(.not.allocated(ck_p) ) allocate(ck_p(ims:ime,jms:jme) )
- if(.not.allocated(cka_p) ) allocate(cka_p(ims:ime,jms:jme) )
if(.not.allocated(gz1oz0_p) ) allocate(gz1oz0_p(ims:ime,jms:jme) )
if(.not.allocated(flhc_p) ) allocate(flhc_p(ims:ime,jms:jme) )
if(.not.allocated(flqc_p) ) allocate(flqc_p(ims:ime,jms:jme) )
+ if(.not.allocated(fh_p) ) allocate(fh_p(ims:ime,jms:jme) )
+ if(.not.allocated(fm_p) ) allocate(fm_p(ims:ime,jms:jme) )
if(.not.allocated(hfx_p) ) allocate(hfx_p(ims:ime,jms:jme) )
if(.not.allocated(hpbl_p) ) allocate(hpbl_p(ims:ime,jms:jme) )
if(.not.allocated(lh_p) ) allocate(lh_p(ims:ime,jms:jme) )
@@ -67,9 +71,9 @@
end subroutine allocate_sfclayer
-!=============================================================================================
+!==================================================================================================
subroutine deallocate_sfclayer
-!=============================================================================================
+!==================================================================================================
if(allocated(area_p) ) deallocate(area_p )
if(allocated(br_p) ) deallocate(br_p )
@@ -77,13 +81,15 @@
if(allocated(cda_p) ) deallocate(cda_p )
if(allocated(chs_p) ) deallocate(chs_p )
if(allocated(chs2_p) ) deallocate(chs2_p )
+ if(allocated(ck_p) ) deallocate(ck_p )
+ if(allocated(cka_p) ) deallocate(cka_p )
if(allocated(cpm_p) ) deallocate(cpm_p )
if(allocated(cqs2_p) ) deallocate(cqs2_p )
- if(allocated(ck_p) ) deallocate(ck_p )
- if(allocated(cka_p) ) deallocate(cka_p )
if(allocated(gz1oz0_p) ) deallocate(gz1oz0_p )
if(allocated(flhc_p) ) deallocate(flhc_p )
if(allocated(flqc_p) ) deallocate(flqc_p )
+ if(allocated(fh_p) ) deallocate(fh_p )
+ if(allocated(fm_p) ) deallocate(fm_p )
if(allocated(hfx_p) ) deallocate(hfx_p )
if(allocated(hpbl_p) ) deallocate(hpbl_p )
if(allocated(lh_p) ) deallocate(lh_p )
@@ -111,16 +117,16 @@
end subroutine deallocate_sfclayer
-!=============================================================================================
+!==================================================================================================
subroutine sfclayer_from_MPAS(mesh,diag_physics,sfc_input)
-!=============================================================================================
+!==================================================================================================
!input arguments:
type(mesh_type),intent(in):: mesh
type(sfc_input_type),intent(in):: sfc_input
type(diag_physics_type),intent(inout):: diag_physics
-!---------------------------------------------------------------------------------------------
+!--------------------------------------------------------------------------------------------------
do j = jts,jte
do i = its,ite
@@ -135,59 +141,52 @@
qfx_p(i,j) = diag_physics % qfx % array(i)
qsfc_p(i,j) = diag_physics % qsfc % array(i)
mol_p(i,j) = diag_physics % mol % array(i)
+ regime_p(i,j) = diag_physics % regime % array(i)
ust_p(i,j) = diag_physics % ust % array(i)
- ustm_p(i,j) = diag_physics % ustm % array(i)
znt_p(i,j) = diag_physics % znt % array(i)
zol_p(i,j) = diag_physics % zol % array(i)
!output variables:
- br_p(i,j) = 0.
+ br_p(i,j) = 0._RKIND
cpm_p(i,j) = cp
- cd_p(i,j) = 0.
- cda_p(i,j) = 0.
- chs_p(i,j) = 0.
- chs2_p(i,j) = 0.
- ck_p(i,j) = 0.
- cka_p(i,j) = 0.
- cqs2_p(i,j) = 0.
- flhc_p(i,j) = 0.
- flqc_p(i,j) = 0.
- gz1oz0_p(i,j) = 0.
- lh_p(i,j) = 0.
- psim_p(i,j) = 0.
- psih_p(i,j) = 0.
- qgh_p(i,j) = 0.
- regime_p(i,j) = 0.
- rmol_p(i,j) = 0.
- wspd_p(i,j) = 0.
- q2_p(i,j) = 0.
- t2m_p(i,j) = 0.
- th2m_p(i,j) = 0.
- u10_p(i,j) = 0.
- v10_p(i,j) = 0.
+ chs_p(i,j) = 0._RKIND
+ chs2_p(i,j) = 0._RKIND
+ cqs2_p(i,j) = 0._RKIND
+ flhc_p(i,j) = 0._RKIND
+ flqc_p(i,j) = 0._RKIND
+ fh_p(i,j) = 0._RKIND
+ fm_p(i,j) = 0._RKIND
+ gz1oz0_p(i,j) = 0._RKIND
+ lh_p(i,j) = 0._RKIND
+ psim_p(i,j) = 0._RKIND
+ psih_p(i,j) = 0._RKIND
+ qgh_p(i,j) = 0._RKIND
+ rmol_p(i,j) = 0._RKIND
+ wspd_p(i,j) = 0._RKIND
+ q2_p(i,j) = 0._RKIND
+ t2m_p(i,j) = 0._RKIND
+ th2m_p(i,j) = 0._RKIND
+ u10_p(i,j) = 0._RKIND
+ v10_p(i,j) = 0._RKIND
enddo
enddo
end subroutine sfclayer_from_MPAS
-!=============================================================================================
+!==================================================================================================
subroutine sfclayer_to_MPAS(diag_physics)
-!=============================================================================================
+!==================================================================================================
!inout arguments:
type(diag_physics_type),intent(inout):: diag_physics
-!---------------------------------------------------------------------------------------------
+!--------------------------------------------------------------------------------------------------
do j = jts,jte
do i = its,ite
diag_physics % br % array(i) = br_p(i,j)
diag_physics % cpm % array(i) = cpm_p(i,j)
- diag_physics % cd % array(i) = cd_p(i,j)
- diag_physics % cda % array(i) = cda_p(i,j)
diag_physics % chs % array(i) = chs_p(i,j)
diag_physics % chs2 % array(i) = chs2_p(i,j)
- diag_physics % ck % array(i) = ck_p(i,j)
- diag_physics % cka % array(i) = cka_p(i,j)
diag_physics % cqs2 % array(i) = cqs2_p(i,j)
diag_physics % flhc % array(i) = flhc_p(i,j)
diag_physics % flqc % array(i) = flqc_p(i,j)
@@ -203,7 +202,6 @@
diag_physics % regime % array(i) = regime_p(i,j)
diag_physics % rmol % array(i) = rmol_p(i,j)
diag_physics % ust % array(i) = ust_p(i,j)
- diag_physics % ustm % array(i) = ustm_p(i,j)
diag_physics % wspd % array(i) = wspd_p(i,j)
diag_physics % zol % array(i) = zol_p(i,j)
diag_physics % znt % array(i) = znt_p(i,j)
@@ -218,14 +216,14 @@
end subroutine sfclayer_to_MPAS
-!=============================================================================================
+!==================================================================================================
subroutine init_sfclayer
-!=============================================================================================
+!==================================================================================================
!local variables:
logical:: allowed_to_read
-!---------------------------------------------------------------------------------------------
+!--------------------------------------------------------------------------------------------------
write(0,*)
write(0,*) '--- enter sfclayer_initialization:'
sfclayer_select: select case (trim(sfclayer_scheme))
@@ -242,9 +240,9 @@
end subroutine init_sfclayer
-!=============================================================================================
+!==================================================================================================
subroutine driver_sfclayer(mesh,diag_physics,sfc_input)
-!=============================================================================================
+!==================================================================================================
!input and inout arguments:
!--------------------------
@@ -256,7 +254,7 @@
!----------------
real(kind=RKIND):: dx
-!---------------------------------------------------------------------------------------------
+!--------------------------------------------------------------------------------------------------
write(0,*)
write(0,*) '--- enter subroutine driver_sfclayer:'
@@ -267,32 +265,67 @@
case("monin_obukhov")
dx = sqrt(maxval(mesh % areaCell % array))
+#if defined(do_hydrostatic_pressure)
+!... REARRANGED CALL USING HYDROSTATIC PRESSURE:
call sfclay( &
- u3d = u_p , v3d = v_p , t3d = t_p , &
- qv3d = qv_p , p3d = pres_p , dz8w = dz_p , &
- cp = cp , g = g , rovcp = rcp , &
- R = R_d , xlv = xlv , psfc = psfc_p , &
- chs = chs_p , chs2 = chs2_p , cqs2 = cqs2_p , &
- cpm = cpm_p , znt = znt_p , ust = ust_p , &
- pblh = hpbl_p , mavail = mavail_p , zol = zol_p , &
- mol = mol_p , regime = regime_p , psim = psim_p , &
- psih = psih_p , xland = xland_p , hfx = hfx_p , &
- qfx = qfx_p , lh = lh_p , tsk = tsk_p , &
- flhc = flhc_p , flqc = flqc_p , qgh = qgh_p , &
- qsfc = qsfc_p , rmol = rmol_p , u10 = u10_p , &
- v10 = v10_p , th2 = th2m_p , t2 = t2m_p , &
- q2 = q2_p , gz1oz0 = gz1oz0_p , wspd = wspd_p , &
- br = br_p , isfflx = isfflx , dx = dx , &
- svp1 = svp1 , svp2 = svp2 , svp3 = svp3 , &
- svpt0 = svpt0 , ep1 = ep_1 , ep2 = ep_2 , &
- karman = karman , eomeg = eomeg , stbolt = stbolt , &
- P1000mb = P0 , ustm = ustm_p , ck = ck_p , &
- cka = cka_p , cd = cd_p , cda = cda_p , &
- isftcflx = isftcflx , iz0tlnd = iz0tlnd , areaCell = area_p , &
+ p3d = pres_hyd_p , psfc = psfc_p , t3d = t_p , &
+ u3d = u_p , v3d = v_p , qv3d = qv_p , &
+ dz8w = dz_p , cp = cp , g = g , &
+ rovcp = rcp , R = R_d , xlv = xlv , &
+ chs = chs_p , chs2 = chs2_p , cqs2 = cqs2_p , &
+ cpm = cpm_p , znt = znt_p , ust = ust_p , &
+ pblh = hpbl_p , mavail = mavail_p , zol = zol_p , &
+ mol = mol_p , regime = regime_p , psim = psim_p , &
+ psih = psih_p , fm = fm_p , fh = fh_p , &
+ xland = xland_p , hfx = hfx_p , qfx = qfx_p , &
+ lh = lh_p , tsk = tsk_p , flhc = flhc_p , &
+ flqc = flqc_p , qgh = qgh_p , qsfc = qsfc_p , &
+ rmol = rmol_p , u10 = u10_p , v10 = v10_p , &
+ th2 = th2m_p , t2 = t2m_p , q2 = q2_p , &
+ gz1oz0 = gz1oz0_p , wspd = wspd_p , br = br_p , &
+ isfflx = isfflx , dx = dx , svp1 = svp1 , &
+ svp2 = svp2 , svp3 = svp3 , svpt0 = svpt0 , &
+ ep1 = ep_1 , ep2 = ep_2 , karman = karman , &
+ eomeg = eomeg , stbolt = stbolt , P1000mb = P0 , &
+ areaCell = area_p , ustm = ustm_p , ck = ck_p , &
+ cka = cka_p , cd = cd_p , cda = cda_p , &
+ isftcflx = isftcflx , iz0tlnd = iz0tlnd , &
+ scm_force_flux = scm_force_flux , &
ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , &
ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , &
its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte &
)
+#else
+!... REARRANGED CALL:
+ call sfclay( &
+ p3d = pres_p , psfc = psfc_p , t3d = t_p , &
+ u3d = u_p , v3d = v_p , qv3d = qv_p , &
+ dz8w = dz_p , cp = cp , g = g , &
+ rovcp = rcp , R = R_d , xlv = xlv , &
+ chs = chs_p , chs2 = chs2_p , cqs2 = cqs2_p , &
+ cpm = cpm_p , znt = znt_p , ust = ust_p , &
+ pblh = hpbl_p , mavail = mavail_p , zol = zol_p , &
+ mol = mol_p , regime = regime_p , psim = psim_p , &
+ psih = psih_p , fm = fm_p , fh = fh_p , &
+ xland = xland_p , hfx = hfx_p , qfx = qfx_p , &
+ lh = lh_p , tsk = tsk_p , flhc = flhc_p , &
+ flqc = flqc_p , qgh = qgh_p , qsfc = qsfc_p , &
+ rmol = rmol_p , u10 = u10_p , v10 = v10_p , &
+ th2 = th2m_p , t2 = t2m_p , q2 = q2_p , &
+ gz1oz0 = gz1oz0_p , wspd = wspd_p , br = br_p , &
+ isfflx = isfflx , dx = dx , svp1 = svp1 , &
+ svp2 = svp2 , svp3 = svp3 , svpt0 = svpt0 , &
+ ep1 = ep_1 , ep2 = ep_2 , karman = karman , &
+ eomeg = eomeg , stbolt = stbolt , P1000mb = P0 , &
+ areaCell = area_p , ustm = ustm_p , ck = ck_p , &
+ cka = cka_p , cd = cd_p , cda = cda_p , &
+ isftcflx = isftcflx , iz0tlnd = iz0tlnd , &
+ scm_force_flux = scm_force_flux , &
+ ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , &
+ ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , &
+ its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte &
+ )
+#endif
case default
@@ -305,6 +338,6 @@
end subroutine driver_sfclayer
-!=============================================================================================
+!==================================================================================================
end module mpas_atmphys_driver_sfclayer
-!=============================================================================================
+!==================================================================================================
Modified: trunk/mpas/src/core_atmos_physics/mpas_atmphys_initialize_real.F
===================================================================
--- trunk/mpas/src/core_atmos_physics/mpas_atmphys_initialize_real.F 2013-03-27 19:24:59 UTC (rev 2673)
+++ trunk/mpas/src/core_atmos_physics/mpas_atmphys_initialize_real.F 2013-03-27 19:26:14 UTC (rev 2674)
@@ -1,4 +1,4 @@
-!=============================================================================================
+!==================================================================================================
module mpas_atmphys_initialize_real
use mpas_kind_types
use mpas_configure, only: config_met_prefix, &
@@ -7,11 +7,9 @@
config_nsoillevels, &
config_start_time, &
config_sfc_prefix
+ use mpas_dmpar
use mpas_grid_types
- use init_atm_hinterp
- use init_atm_llxy
- use init_atm_read_met
-
+ use mpas_init_atm_surface
use mpas_atmphys_date_time
use mpas_atmphys_utilities
@@ -21,140 +19,17 @@
contains
-!=============================================================================================
- subroutine physics_initialize_sst(mesh,fg)
-!=============================================================================================
-
+!==================================================================================================
+ subroutine physics_initialize_real(mesh,fg,dminfo)
+!==================================================================================================
!input arguments:
- type(mesh_type),intent(in) :: mesh
+ type(mesh_type),intent(in):: mesh
+ type(dm_info),intent(in) :: dminfo
!inout arguments:
type(fg_type),intent(inout):: fg
!local variables:
- character(len=StrKIND):: timeString
- integer:: i,j,iCell,istatus
- integer,dimension(5) :: interp_list
-
- type(met_data) :: field
- type(proj_info):: proj
-
- real(kind=RKIND):: lat, lon, x, y
- real(kind=RKIND),allocatable,dimension(:,:):: slab_r8
-
-!---------------------------------------------------------------------------------------------
-
- write(0,*) '--- enter subroutine physics_initialize_sst:'
-
-!set interpolation sequence to be used for SST/SEAICE field:
- interp_list(1) = FOUR_POINT
- interp_list(2) = SEARCH
- interp_list(3) = 0
-
-!open intermediate file:
- call read_met_init(trim(config_sfc_prefix),.false.,config_start_time(1:13),istatus)
- if(istatus /= 0) &
- write(0,*) 'Error reading ',trim(config_sfc_prefix)//':'//config_start_time(1:13)
- write(0,*) 'Processing ',trim(config_sfc_prefix)//':'//config_start_time(1:13)
-
-!scan through all the fields in the file:
- call read_next_met_field(field,istatus)
- do while (istatus == 0)
-
- !initialization of the sea-surface temperature (SST) and sea-ice fraction (XICE) arrays,
- !prior to reading the input data:
- fg % sst % array (1:mesh%nCells) = 0.0_RKIND
- fg % xice % array (1:mesh%nCells) = 0.0_RKIND
-
- if(index(field % field,'SKINTEMP') /= 0 .or. &
- index(field % field,'SST' ) /= 0 .or. &
- index(field % field,'SEAICE' ) /= 0 ) then
-
- !Interpolation routines use real(kind=RKIND), so copy from default real array
- allocate(slab_r8(field % nx, field % ny))
- do j=1,field % ny
- do i=1,field % nx
- slab_r8(i,j) = field % slab(i,j)
- end do
- end do
-
- !
- !Set up map projection
- !
- call map_init(proj)
-
- if(field % iproj == PROJ_LATLON) then
- call map_set(PROJ_LATLON, proj, &
- latinc = real(field % deltalat,RKIND), &
- loninc = real(field % deltalon,RKIND), &
- knowni = 1.0_RKIND, &
- knownj = 1.0_RKIND, &
- lat1 = real(field % startlat,RKIND), &
- lon1 = real(field % startlon,RKIND))
- else if (field % iproj == PROJ_GAUSS) then
- call map_set(PROJ_GAUSS, proj, &
- nlat = nint(field % deltalat), &
- loninc = real(field % deltalon,RKIND), &
- lat1 = real(field % startlat,RKIND), &
- lon1 = real(field % startlon,RKIND))
-! nxmax = nint(360.0 / field % deltalon), &
- else if (field % iproj == PROJ_PS) then
- call map_set(PROJ_PS, proj, &
- dx = real(field % dx,RKIND), &
- truelat1 = real(field % truelat1,RKIND), &
- stdlon = real(field % xlonc,RKIND), &
- knowni = real(field % nx / 2.0,RKIND), &
- knownj = real(field % ny / 2.0,RKIND), &
- lat1 = real(field % startlat,RKIND), &
- lon1 = real(field % startlon,RKIND))
- end if
-
- !Interpolate field to each MPAS grid cell:
- do iCell=1,mesh % nCells
- lat = mesh % latCell % array(iCell) * DEG_PER_RAD
- lon = mesh % lonCell % array(iCell) * DEG_PER_RAD
- call latlon_to_ij(proj, lat, lon, x, y)
- if (y < 0.5) then
- y = 1.0
- else if (y >= real(field%ny)+0.5) then
- y = real(field % ny)
- endif
- if (x < 0.5) then
- lon = lon + 360.0
- call latlon_to_ij(proj, lat, lon, x, y)
- else if (x >= real(field%nx)+0.5) then
- lon = lon - 360.0
- call latlon_to_ij(proj, lat, lon, x, y)
- end if
-
- if(index(field % field,'SST') /= 0) then
- fg % sst % array(iCell) = interp_sequence(x,y,1,slab_r8,1,field%nx, &
- 1,field%ny,1,1,-1.e30_RKIND,interp_list,1)
- elseif(index(field % field,'SEAICE') /= 0) then
- fg % xice % array(iCell) = interp_sequence(x,y,1,slab_r8,1,field%nx, &
- 1,field%ny,1,1,-1.e30_RKIND,interp_list,1)
- endif
- end do
-
- deallocate(slab_r8)
- deallocate(field % slab)
-! exit
- end if
- call read_next_met_field(field,istatus)
- enddo
-
- end subroutine physics_initialize_sst
-
-!=============================================================================================
- subroutine physics_initialize_real(mesh,fg)
-!=============================================================================================
-!input arguments:
- type(mesh_type),intent(in) :: mesh
-
-!inout arguments:
- type(fg_type),intent(inout):: fg
-
-!local variables:
character(len=StrKIND):: initial_date
integer:: iCell,nCellsSolve
@@ -171,19 +46,19 @@
real(kind=RKIND),dimension(:),pointer:: skintemp,sst
-!---------------------------------------------------------------------------------------------
+!--------------------------------------------------------------------------------------------------
write(0,*)
write(0,*) '--- enter physics_initialize_real:'
nCellsSolve = mesh % nCellsSolve
- landmask => mesh % landmask % array
- albedo12m => mesh % albedo12m % array
- greenfrac => mesh % greenfrac % array
- shdmin => mesh % shdmin % array
- shdmax => mesh % shdmax % array
- snoalb => mesh % snoalb % array
+ landmask => mesh % landmask % array
+ albedo12m => mesh % albedo12m % array
+ greenfrac => mesh % greenfrac % array
+ shdmin => mesh % shdmin % array
+ shdmax => mesh % shdmax % array
+ snoalb => mesh % snoalb % array
sfc_albbck => fg % sfc_albbck % array
vegfra => fg % vegfra % array
@@ -200,32 +75,9 @@
!input file. calling this subroutine will overwrite the arrays sst and seaice already read
!in the file defined by config_input_name:
if(config_input_sst) then
- call physics_initialize_sst(mesh,fg)
-
- if(maxval(xice(1:nCellsSolve)) == 0._RKIND .and. minval(xice(1:nCellsSolve)) == 0._RKIND) then
- write(0,*)
- write(0,*) "The input file does not contain sea-ice data. We freeze the really cold ocean instead"
- do iCell = 1, nCellsSolve
- if(landmask(iCell).eq.0 .and. sst(iCell).lt.271._RKIND) xice(iCell) = 1._RKIND
- enddo
- endif
- write(0,*) 'max sst =',maxval(fg % sst % array(1:mesh%nCells))
- write(0,*) 'min sst =',minval(fg % sst % array(1:mesh%nCells))
- write(0,*) 'max xice =',maxval(fg % xice % array(1:mesh%nCells))
- write(0,*) 'min xice =',minval(fg % xice % array(1:mesh%nCells))
-
- do iCell = 1, nCellsSolve
- !recalculate the sea-ice flag:
- if(xice(iCell) .gt. 0._RKIND) then
- seaice(iCell) = 1._RKIND
- else
- seaice(iCell) = 0._RKIND
- endif
-
- !set the skin temperature to the sea-surface temperature over the oceans:
- if(landmask(iCell).eq.0 .and. sst(iCell).gt.170._RKIND .and. sst(iCell).lt.400._RKIND) &
- skintemp(iCell) = sst(iCell)
- enddo
+ write(0,*) '--- read sea-surface temperature from auxillary file:'
+ call interp_sfc_to_MPAS(config_start_time(1:13),mesh,fg,dminfo)
+ call physics_init_sst(mesh,fg)
endif
!initialization of the surface background albedo: interpolation of the monthly values to the
@@ -269,10 +121,10 @@
enddo
!initialization of soil layers properties:
- call init_soil_layers(mesh,fg)
+ call init_soil_layers(mesh,fg,dminfo)
-!adjustment of all surface fields for seaice points:
- call init_seaice_points(mesh,fg)
+!initialize seaice points:
+ call physics_init_seaice(mesh,fg)
!define xland over land and ocean:
do iCell = 1, nCellsSolve
@@ -287,17 +139,18 @@
end subroutine physics_initialize_real
-!=============================================================================================
- subroutine init_soil_layers(mesh,fg)
-!=============================================================================================
+!==================================================================================================
+ subroutine init_soil_layers(mesh,fg,dminfo)
+!==================================================================================================
!input arguments:
type(mesh_type),intent(in):: mesh
+ type(dm_info),intent(in) :: dminfo
!inout arguments:
type(fg_type),intent(inout):: fg
-!---------------------------------------------------------------------------------------------
+!--------------------------------------------------------------------------------------------------
!adjust the annual mean deep soil temperature:
call adjust_input_soiltemps(mesh,fg)
@@ -306,13 +159,13 @@
call init_soil_layers_depth(mesh,fg)
!initialize the temperature, moisture, and liquid water of the individual soil layers:
- call init_soil_layers_properties(mesh,fg)
+ call init_soil_layers_properties(mesh,fg,dminfo)
end subroutine init_soil_layers
-!=============================================================================================
+!==================================================================================================
subroutine adjust_input_soiltemps(mesh,fg)
-!=============================================================================================
+!==================================================================================================
!input arguments:
type(mesh_type),intent(in) :: mesh
@@ -329,7 +182,7 @@
real(kind=RKIND),dimension(:),pointer :: skintemp,soiltemp,tmn
real(kind=RKIND),dimension(:,:),pointer:: st_fg
-!---------------------------------------------------------------------------------------------
+!--------------------------------------------------------------------------------------------------
nCellsSolve = mesh % nCellsSolve
nFGSoilLevels = mesh % nFGSoilLevels
@@ -347,12 +200,12 @@
if(landmask(iCell) .eq. 1) then
!adjust the annual deep mean soil temperature and skin temperatures over land:
- tmn(iCell) = soiltemp(iCell) - 0.0065 * ter(iCell)
- skintemp(iCell) = skintemp(iCell) - 0.0065 * (ter(iCell)-soilz(iCell))
+ tmn(iCell) = soiltemp(iCell) - 0.0065_RKIND * ter(iCell)
+ skintemp(iCell) = skintemp(iCell) - 0.0065_RKIND * (ter(iCell)-soilz(iCell))
!adjust the soil layer temperatures:
do ifgSoil = 1, nFGSoilLevels
- st_fg(ifgSoil,iCell) = st_fg(ifgSoil,iCell) - 0.0065 * (ter(iCell)-soilz(iCell))
+ st_fg(ifgSoil,iCell) = st_fg(ifgSoil,iCell) - 0.0065_RKIND * (ter(iCell)-soilz(iCell))
enddo
elseif(landmask(iCell) .eq. 0) then
@@ -364,12 +217,12 @@
end subroutine adjust_input_soiltemps
-!=============================================================================================
+!==================================================================================================
subroutine init_soil_layers_depth(mesh,fg)
-!=============================================================================================
+!==================================================================================================
!input arguments:
- type(mesh_type),intent(in) :: mesh
+ type(mesh_type),intent(in):: mesh
!inout arguments:
type(fg_type),intent(inout):: fg
@@ -377,7 +230,7 @@
!local variables:
integer:: iCell,iSoil
-!---------------------------------------------------------------------------------------------
+!--------------------------------------------------------------------------------------------------
write(0,*)
write(0,*) '--- enter subroutine init_soil_layers_depth:'
@@ -388,65 +241,57 @@
do iCell = 1, mesh % nCells
iSoil = 1
- fg % zs_fg % array(iSoil,iCell) = 0.5 * fg % dzs_fg % array(iSoil,iCell)
-! if(iCell .eq. 1) write(0,101) iSoil,fg % dzs_fg % array(iSoil,iCell), &
-! fg % zs_fg % array(iSoil,iCell)
+ fg % zs_fg % array(iSoil,iCell) = 0.5_RKIND * fg % dzs_fg % array(iSoil,iCell)
do iSoil = 2, mesh % nFGSoilLevels
fg % zs_fg % array(iSoil,iCell) = fg % zs_fg % array(iSoil-1,iCell) &
- + 0.5 * fg % dzs_fg % array(iSoil-1,iCell) &
- + 0.5 * fg % dzs_fg % array(iSoil,iCell)
-! if(iCell .eq. 1) write(0,101) iSoil,fg % dzs_fg % array(iSoil,iCell), &
-! fg % zs_fg % array(iSoil,iCell)
+ + 0.5_RKIND * fg % dzs_fg % array(iSoil-1,iCell) &
+ + 0.5_RKIND * fg % dzs_fg % array(iSoil,iCell)
enddo
enddo
- 101 format(i4,2(1x,e15.8))
do iCell = 1, mesh % nCells
- fg % dzs % array(1,iCell) = 0.10
- fg % dzs % array(2,iCell) = 0.30
- fg % dzs % array(3,iCell) = 0.60
- fg % dzs % array(4,iCell) = 1.00
+ fg % dzs % array(1,iCell) = 0.10_RKIND
+ fg % dzs % array(2,iCell) = 0.30_RKIND
+ fg % dzs % array(3,iCell) = 0.60_RKIND
+ fg % dzs % array(4,iCell) = 1.00_RKIND
iSoil = 1
- fg % zs % array(iSoil,iCell) = 0.5 * fg % dzs % array(iSoil,iCell)
-! if(iCell .eq. 1) write(0,101) iSoil,fg % dzs % array(iSoil,iCell), &
-! fg % zs % array(iSoil,iCell)
-
+ fg % zs % array(iSoil,iCell) = 0.5_RKIND * fg % dzs % array(iSoil,iCell)
do iSoil = 2, mesh % nSoilLevels
- fg % zs % array(iSoil,iCell) = fg % zs % array(iSoil-1,iCell) &
- + 0.5 * fg % dzs % array(iSoil-1,iCell) &
- + 0.5 * fg % dzs % array(iSoil,iCell)
-! if(iCell .eq. 1) write(0,101) iSoil,fg % dzs % array(iSoil,iCell), &
-! fg % zs % array(iSoil,iCell)
+ fg % zs % array(iSoil,iCell) = fg % zs % array(iSoil-1,iCell) &
+ + 0.5_RKIND * fg % dzs % array(iSoil-1,iCell) &
+ + 0.5_RKIND * fg % dzs % array(iSoil,iCell)
enddo
enddo
end subroutine init_soil_layers_depth
-!=============================================================================================
- subroutine init_soil_layers_properties(mesh,fg)
-!=============================================================================================
+!==================================================================================================
+ subroutine init_soil_layers_properties(mesh,fg,dminfo)
+!==================================================================================================
!input arguments:
- type(mesh_type),intent(in) :: mesh
+ type(mesh_type),intent(in):: mesh
+ type(dm_info),intent(in) :: dminfo
!inout arguments:
type(fg_type),intent(inout):: fg
!local variables:
- integer:: iCell,ifgSoil,iSoil,is
+ integer:: iCell,ifgSoil,iSoil
integer:: nCells,nFGSoilLevels,nSoilLevels
+ integer:: num_sm,num_st
integer,dimension(:),pointer:: landmask
real(kind=RKIND),dimension(:,:),allocatable:: zhave,sm_input,st_input
real(kind=RKIND),dimension(:),pointer :: skintemp,tmn
- real(kind=RKIND),dimension(:,:),pointer:: dzs,zs,tslb,smois,sh2o
+ real(kind=RKIND),dimension(:,:),pointer:: dzs,zs,tslb,smois,sh2o,smcrel
real(kind=RKIND),dimension(:,:),pointer:: sm_fg,st_fg,zs_fg
-!---------------------------------------------------------------------------------------------
+!--------------------------------------------------------------------------------------------------
!write(0,*)
write(0,*) '--- enter subroutine init_soil_layers_properties:'
@@ -463,14 +308,33 @@
st_fg => fg % st_fg % array
sm_fg => fg % sm_fg % array
- zs => fg % zs % array
- dzs => fg % dzs % array
- sh2o => fg % sh2o % array
- smois => fg % smois % array
- tslb => fg % tslb % array
+ zs => fg % zs % array
+ dzs => fg % dzs % array
+ sh2o => fg % sh2o % array
+ smcrel => fg % smcrel % array
+ smois => fg % smois % array
+ tslb => fg % tslb % array
skintemp => fg % skintemp % array
tmn => fg % tmn % array
+!check that interpolation of the meteorological data to the MPAS grid did not create negative
+!values for the first-guess soil temperatures and soil moistures.
+ num_sm = 0
+ num_st = 0
+ do iCell = 1, nCells
+ do ifgSoil = 1, nFGSoilLevels
+ if(st_fg(ifgSoil,iCell) .le. 0._RKIND) num_st = num_st + 1
+ if(sm_fg(ifgSoil,iCell) .lt. 0._RKIND) num_sm = num_sm + 1
+ enddo
+ enddo
+ if(num_st .gt. 0) then
+ write(0,*) 'Error in interpolation of st_fg to MPAS grid: num_st =', num_st
+ call mpas_dmpar_abort(dminfo)
+ elseif(num_sm .gt. 0) then
+ write(0,*) 'Error in interpolation of sm_fg to MPAS grid: num_sm =', num_sm
+ call mpas_dmpar_abort(dminfo)
+ endif
+
if(config_nsoillevels .ne. 4) &
call physics_error_fatal('NOAH lsm uses 4 soil layers. Correct config_nsoillevels.')
@@ -481,17 +345,17 @@
do iCell = 1, nCells
ifgSoil = 1
- zhave(ifgSoil,iCell) = 0.
+ zhave(ifgSoil,iCell) = 0._RKIND
st_input(ifgSoil,iCell) = skintemp(iCell)
sm_input(ifgSoil,iCell) = sm_fg(ifgSoil+1,iCell)
do ifgSoil = 1, nFGSoilLevels
- zhave(ifgSoil+1,iCell) = zs_fg(ifgSoil,iCell) / 100.
+ zhave(ifgSoil+1,iCell) = zs_fg(ifgSoil,iCell) / 100._RKIND
st_input(ifgSoil+1,iCell) = st_fg(ifgSoil,iCell)
sm_input(ifgSoil+1,iCell) = sm_fg(ifgSoil,iCell)
enddo
- zhave(nFGSoilLevels+2,iCell) = 300./100.
+ zhave(nFGSoilLevels+2,iCell) = 300._RKIND/100._RKIND
st_input(nFGSoilLevels+2,iCell) = tmn(iCell)
sm_input(nFGSoilLevels+2,iCell) = sm_input(nFGSoilLevels,iCell)
@@ -530,7 +394,8 @@
+ sm_input(ifgSoil+1,iCell) * (zs(iSoil,iCell)-zhave(ifgSoil,iCell))) &
/ (zhave(ifgSoil+1,iCell)-zhave(ifgSoil,iCell))
- sh2o(iSoil,iCell) = 0.
+ sh2o(iSoil,iCell) = 0._RKIND
+ smcrel(iSoil,iCell) = 0._RKIND
exit input
endif
@@ -542,9 +407,10 @@
!fill the soil temperatures with the skin temperatures over oceans:
do iSoil = 1, nSoilLevels
- tslb(iSoil,iCell) = skintemp(iCell)
- smois(iSoil,iCell) = 1.0
- sh2o(iSoil,iCell) = 1.0
+ tslb(iSoil,iCell) = skintemp(iCell)
+ smois(iSoil,iCell) = 1._RKIND
+ sh2o(iSoil,iCell) = 1._RKIND
+ smcrel(iSoil,iCell) = 0._RKIND
enddo
endif
@@ -555,10 +421,10 @@
do iCell = 1, nCells
- if(landmask(iCell).eq. 1 .and. tslb(1,iCell).gt.170. .and. tslb(1,iCell).lt.400. .and. &
- smois(1,iCell).lt.0.005) then
+ if(landmask(iCell).eq. 1 .and. tslb(1,iCell).gt.170._RKIND .and. tslb(1,iCell).lt.400._RKIND &
+ .and. smois(1,iCell).lt.0.005_RKIND) then
do iSoil = 1, nSoilLevels
- smois(iSoil,iCell) = 0.005
+ smois(iSoil,iCell) = 0.005_RKIND
enddo
endif
@@ -574,19 +440,78 @@
end subroutine init_soil_layers_properties
-!=============================================================================================
- subroutine init_seaice_points(mesh,fg)
-!=============================================================================================
+!==================================================================================================
+ subroutine physics_init_sst(mesh,input)
+!==================================================================================================
+!input arguments:
+ type(mesh_type),intent(in):: mesh
+
+#if !defined(non_hydrostatic_core)
+!inout arguments: this subroutine is called from the MPAS initialization side.
+ type(fg_type),intent(inout):: input
+#else
+!inout arguments: this subroutine is called from the MPAS model side.
+ type(sfc_input_type),intent(inout):: input
+#endif
+
+!local variables:
+ integer:: iCell,nCells
+ integer,dimension(:),pointer:: landmask
+
+ real(kind=RKIND),dimension(:),pointer :: sst,tsk,xice
+ real(kind=RKIND),dimension(:,:),pointer:: tslb
+
+!--------------------------------------------------------------------------------------------------
+ write(0,*)
+ write(0,*) '--- enter subroutine physics_update_sst:'
+
+!initialization:
+ nCells = mesh % nCells
+
+ landmask => mesh % landmask % array
+ sst => input % sst % array
+ tsk => input % skintemp % array
+ tslb => input % tslb % array
+ xice => input % xice % array
+
+!update the skin temperature and the soil temperature of the first soil layer with the updated
+!sea-surface temperatures:
+!change made so that the SSTs read for the surface update file are the same as the skin temperature
+!over the oceans.
+!do iCell = 1, nCells
+! if(landmask(iCell) == 0 .and. xice(iCell) == 0) then
+! tsk(iCell) = sst(iCell)
+! endif
+!enddo
+ do iCell = 1, nCells
+ if(landmask(iCell) == 0) then
+ tsk(iCell) = sst(iCell)
+ endif
+ enddo
+
+ write(0,*) '--- end subroutine physics_update_sst:'
+
+ end subroutine physics_init_sst
+
+!==================================================================================================
+ subroutine physics_init_seaice(mesh,input)
+!==================================================================================================
+
!input arguments:
type(mesh_type),intent(in) :: mesh
-!inout arguments:
- type(fg_type),intent(inout):: fg
+#if !defined(non_hydrostatic_core)
+!inout arguments: this subroutine is called from the MPAS initialization side.
+ type(fg_type),intent(inout):: input
+#else
+!inout arguments: this subroutine is called from the MPAS model side.
+ type(sfc_input_type),intent(inout):: input
+#endif
!local variables:
character(len=StrKIND):: mess
- integer:: iCell,iSoil,nCellsSolve,nSoilLevels
+ integer:: iCell,iSoil,nCells,nSoilLevels
integer:: num_seaice_changes
integer,dimension(:),pointer:: landmask,isltyp,ivgtyp
@@ -594,8 +519,8 @@
real(kind=RKIND):: mid_point_depth
real(kind=RKIND),dimension(:),pointer :: vegfra
real(kind=RKIND),dimension(:),pointer :: seaice,xice
- real(kind=RKIND),dimension(:),pointer :: skintemp,sst,tmn
- real(kind=RKIND),dimension(:,:),pointer:: tslb,smois,sh2o
+ real(kind=RKIND),dimension(:),pointer :: skintemp,tmn
+ real(kind=RKIND),dimension(:,:),pointer:: tslb,smois,sh2o,smcrel
!note that this threshold is also defined in module_physics_vars.F.It is defined here to avoid
!adding "use module_physics_vars" since this subroutine is only used for the initialization of
@@ -603,85 +528,108 @@
real(kind=RKIND),parameter:: xice_tsk_threshold = 271.
real(kind=RKIND),parameter:: total_depth = 3. ! 3-meter soil depth.
-!---------------------------------------------------------------------------------------------
-
+!--------------------------------------------------------------------------------------------------
write(0,*)
- write(0,*) '--- enter init_seaice_points:'
- write(0,*) '--- config_frac_seaice :', config_frac_seaice
+ write(0,*) '--- enter physics_init_seaice:'
- nCellsSolve = mesh % nCellsSolve
+ nCells = mesh % nCells
nSoilLevels = mesh % nSoilLevels
landmask => mesh % landmask % array
isltyp => mesh % soilcat_top % array
ivgtyp => mesh % lu_index % array
- seaice => fg % seaice % array
- xice => fg % xice % array
- vegfra => fg % vegfra % array
+ seaice => input % seaice % array
+ xice => input % xice % array
+ vegfra => input % vegfra % array
- skintemp => fg % skintemp % array
- sst => fg % sst % array
- tmn => fg % tmn % array
+ skintemp => input % skintemp % array
+ tmn => input % tmn % array
- tslb => fg % tslb % array
- smois => fg % smois % array
- sh2o => fg % sh2o % array
+ tslb => input % tslb % array
+ smois => input % smois % array
+ sh2o => input % sh2o % array
+ smcrel => input % smcrel % array
- if(.not. config_frac_seaice) then
- xice_threshold = 0.5
- elseif(config_frac_seaice) then
- xice_threshold = 0.02
- endif
+ do iCell = 1, nCells
+ seaice(iCell) = 0._RKIND
+ enddo
!make sure that all the cells flagged as sea-ice cells are defined as ocean cells:
num_seaice_changes = 0
- do iCell = 1, nCellsSolve
- if((landmask(iCell).eq.1 .and. xice(iCell).gt.0.) .or. xice(iCell).gt.200.) then
+ do iCell = 1, nCells
+ if((landmask(iCell).eq.1 .and. xice(iCell).gt.0._RKIND) .or. xice(iCell).gt.200._RKIND) then
num_seaice_changes = num_seaice_changes + 1
- seaice(iCell) = 0.
- xice(iCell) = 0.
+ seaice(iCell) = 0._RKIND
+ xice(iCell) = 0._RKIND
endif
enddo
- write(mess,fmt='(A,i12)') 'number of seaice cells converted to land cells=', &
+ write(mess,fmt='(A,i12)') 'number of seaice cells converted to land cells 1 =', &
num_seaice_changes
call physics_message(mess)
+!assign the threshold value for xice as a function of config_frac_seaice:
+ if(.not. config_frac_seaice) then
+ xice_threshold = 0.5_RKIND
+ do iCell = 1,nCells
+ if(xice(iCell) >= xice_threshold) then
+ xice(iCell) = 1._RKIND
+ else
+ xice(iCell) = 0._RKIND
+ endif
+ enddo
+ elseif(config_frac_seaice) then
+ xice_threshold = 0.02
+ endif
+ write(0,*) '--- config_frac_seaice :', config_frac_seaice
+ write(0,*) '--- xice_threshold :', xice_threshold
+
+!convert seaice points to land points:
num_seaice_changes = 0
- do iCell =1 , nCellsSolve
+ do iCell = 1, nCells
if(xice(iCell) .ge. xice_threshold .or. &
- (landmask(iCell).eq.0 .and. skintemp(iCell).lt.xice_tsk_threshold)) then
+ (landmask(iCell).eq.0 .and. skintemp(iCell).lt.xice_tsk_threshold)) then
num_seaice_changes = num_seaice_changes + 1
!sea-ice points are converted to land points:
- if(.not. config_frac_seaice) xice(iCell) = 1.0
- if(landmask(iCell) .eq. 0) tmn(iCell) = 271.4
+ if(.not. config_frac_seaice) xice(iCell) = 1._RKIND
+ if(landmask(iCell) .eq. 0) tmn(iCell) = 271.4_RKIND
ivgtyp(iCell) = 24 ! (isice = 24)
isltyp(iCell) = 16
- vegfra(iCell) = 0.
- landmask(iCell) = 1.
+ vegfra(iCell) = 0._RKIND
+ landmask(iCell) = 1._RKIND
do iSoil = 1, nSoilLevels
mid_point_depth = total_depth/nSoilLevels/2. &
+ (iSoil-1)*(total_depth/nSoilLevels)
tslb(iSoil,iCell) = ((total_depth-mid_point_depth) * skintemp(iCell) &
+ mid_point_depth * tmn(iCell)) / total_depth
- smois(iSoil,iCell) = 1.0
- sh2o(iSoil,iCell) = 0.0
+ smois(iSoil,iCell) = 1._RKIND
+ sh2o(iSoil,iCell) = 0._RKIND
+ smcrel(iSoil,iCell) = 0._RKIND
enddo
elseif(xice(iCell) .lt. xice_threshold) then
- xice(iCell) = 0.
+ xice(iCell) = 0._RKIND
endif
enddo
+ write(mess,fmt='(A,i12)') 'number of seaice cells converted to land cells 2 =', &
+ num_seaice_changes
+ call physics_message(mess)
- end subroutine init_seaice_points
+!finally, update the sea-ice flag:
+ do iCell = 1, nCells
+ if(xice(iCell) > 0._RKIND) seaice(iCell) = 1._RKIND
+ enddo
+ write(0,*) '--- end physics_init_seaice:'
-!=============================================================================================
+ end subroutine physics_init_seaice
+
+!==================================================================================================
end module mpas_atmphys_initialize_real
-!=============================================================================================
+!==================================================================================================
Modified: trunk/mpas/src/core_atmos_physics/mpas_atmphys_interface_nhyd.F
===================================================================
--- trunk/mpas/src/core_atmos_physics/mpas_atmphys_interface_nhyd.F 2013-03-27 19:24:59 UTC (rev 2673)
+++ trunk/mpas/src/core_atmos_physics/mpas_atmphys_interface_nhyd.F 2013-03-27 19:26:14 UTC (rev 2674)
@@ -54,6 +54,15 @@
if(.not.allocated(qs_p) ) allocate(qs_p(ims:ime,kms:kme,jms:jme) )
if(.not.allocated(qg_p) ) allocate(qg_p(ims:ime,kms:kme,jms:jme) )
+!... arrays used for calculating the hydrostatic pressure and exner function:
+ if(.not.allocated(psfc_hyd_p) ) allocate(psfc_hyd_p(ims:ime,jms:jme) )
+ if(.not.allocated(psfc_hydd_p) ) allocate(psfc_hydd_p(ims:ime,jms:jme) )
+ if(.not.allocated(pres_hyd_p) ) allocate(pres_hyd_p(ims:ime,kms:kme,jms:jme) )
+ if(.not.allocated(pres_hydd_p) ) allocate(pres_hydd_p(ims:ime,kms:kme,jms:jme) )
+ if(.not.allocated(pres2_hyd_p) ) allocate(pres2_hyd_p(ims:ime,kms:kme,jms:jme) )
+ if(.not.allocated(pres2_hydd_p)) allocate(pres2_hydd_p(ims:ime,kms:kme,jms:jme))
+ if(.not.allocated(znu_hyd_p) ) allocate(znu_hyd_p(ims:ime,kms:kme,jms:jme) )
+
end subroutine allocate_forall_physics
!=============================================================================================
@@ -91,6 +100,14 @@
if(allocated(qs_p) ) deallocate(qs_p )
if(allocated(qg_p) ) deallocate(qg_p )
+ if(allocated(psfc_hyd_p) ) deallocate(psfc_hyd_p )
+ if(allocated(psfc_hydd_p) ) deallocate(psfc_hydd_p )
+ if(allocated(pres_hyd_p) ) deallocate(pres_hyd_p )
+ if(allocated(pres_hydd_p) ) deallocate(pres_hydd_p )
+ if(allocated(pres2_hyd_p) ) deallocate(pres2_hyd_p )
+ if(allocated(pres2_hydd_p)) deallocate(pres2_hydd_p)
+ if(allocated(znu_hyd_p) ) deallocate(znu_hyd_p )
+
end subroutine deallocate_forall_physics
!=============================================================================================
@@ -114,7 +131,7 @@
real(kind=RKIND),dimension(:,:),pointer:: rho_zz,theta_m,qv,pressure_p,u,v,w
real(kind=RKIND),dimension(:,:),pointer:: qvs,rh
- real(kind=RKIND):: rho1,rho2,tem1,tem2
+ real(kind=RKIND):: rho_a,rho1,rho2,tem1,tem2
!---------------------------------------------------------------------------------------------
@@ -152,18 +169,7 @@
u => diag % uReconstructZonal % array
v => diag % uReconstructMeridional % array
-!ldf (2012-01-06): updates the surface pressure as is done in subroutine microphysics_to_MPAS.
-!do j = jts,jte
-!do i = its,ite
-! sfc_pressure(i) = 0.5*g*(zgrid(2,i)-zgrid(1,i)) &
-! * (1.25 * rho_zz(1,i) * zz(1,i) * (1. + qv(1,i)) &
-! - 0.25 * rho_zz(2,i) * zz(2,i) * (1. + qv(1,i)))
-! sfc_pressure(i) = sfc_pressure(i) + pressure_p(1,i) + pressure_b(1,i)
-!enddo
-!enddo
-!ldf end.
-!ldf (2012-01-09): updates the surface pressure using zgrid.
-!do j = jts,jte
+!calculation of the surface pressure using hydrostatic assumption down to the surface::
do i = its,ite
tem1 = zgrid(2,i)-zgrid(1,i)
tem2 = zgrid(3,i)-zgrid(2,i)
@@ -173,17 +179,15 @@
* (rho1 + 0.5*(rho2-rho1)*tem1/(tem1+tem2))
sfc_pressure(i) = sfc_pressure(i) + pressure_p(1,i) + pressure_b(1,i)
enddo
+
+!arrays located at theta points:
+!do j = jts, jte
+!do i = its, ite
+! psfc_p(i,j) = diag % surface_pressure % array(i)
!enddo
-!ldf end.
+!enddo
-!copy sounding variables from the geodesic grid to the rectangular grid:
do j = jts, jte
- do i = its, ite
- psfc_p(i,j) = diag % surface_pressure % array(i)
- enddo
- enddo
-
- do j = jts, jte
do k = kts, kte
do i = its, ite
@@ -216,6 +220,7 @@
enddo
enddo
+!arrays located at w points:
do j = jts, jte
do k = kts,kte+1
do i = its,ite
@@ -225,38 +230,26 @@
enddo
enddo
+!check that the pressure in the layer above the surface is greater than that in the layer
+!above it:
do j = jts,jte
do i = its,ite
- if(pres_p(i,1,j) .lt. pres_p(i,2,j)) then
+ if(pres_p(i,1,j) .le. pres_p(i,2,j)) then
write(0,*)
- write(0,*) '--- subroutine MPAS_to_phys: pres:',j,i
- write(0,*) 'latCell=', latCell(i)
- write(0,*) 'lonCell=', lonCell(i)
+ write(0,*) '--- subroutine MPAS_to_phys - pressure(1) < pressure(2):'
+ write(0,*) 'i =', i
+ write(0,*) 'latCell=', latCell(i)/degrad
+ write(0,*) 'lonCell=', lonCell(i)/degrad
do k = kts,kte
- write(0,201) j,i,k,pressure_b(k,i),pressure_p(k,i),pres_p(i,k,j),zz(k,i), &
+ write(0,201) j,i,k,dz_p(i,k,j),pressure_b(k,i),pressure_p(k,i),pres_p(i,k,j), &
rho_p(i,k,j),th_p(i,k,j),t_p(i,k,j),qv_p(i,k,j)
enddo
- write(0,*)
- do k = kts,kte
- write(0,201) j,i,k,qv_p(i,k,j),qc_p(i,k,j),qr_p(i,k,j),qi_p(i,k,j),qs_p(i,k,j), &
- qg_p(i,k,j)
- enddo
- write(0,*)
- stop
+! stop
endif
enddo
enddo
!interpolation of pressure and temperature from theta points to w points:
-!do j = jts,jte
-!do k = kts+1,kte
-!do i = its,ite
-! t2_p(i,k,j) = fzm(k)*t_p(i,k,j) + fzp(k)*t_p(i,k-1,j)
-! pres2_p(i,k,j) = fzm(k)*pres_p(i,k,j) + fzp(k)*pres_p(i,k-1,j)
-!enddo
-!enddo
-!enddo
-!ldf(2011-01-10):
do j = jts,jte
do k = kts+1,kte
do i = its,ite
@@ -286,7 +279,8 @@
enddo
enddo
-!interpolation of pressure and temperature from theta points to the surface:
+!ldf (2012-06-22): recalculates the pressure at the surface as an extrapolation of the
+!pressures in the 2 layers above the surface, as was originally done:
k = kts
do j = jts,jte
do i = its,ite
@@ -296,31 +290,35 @@
w1 = (z0-z2)/(z1-z2)
w2 = 1.-w1
t2_p(i,k,j) = w1*t_p(i,k,j)+w2*t_p(i,k+1,j)
- !use surface pressure calculated in subroutine recover_large_step_variables.
- !pres2_p(i,k,j) = w1*pres_p(i,k,j)+w2*pres_p(i,k+1,j)
- pres2_p(i,k,j) = psfc_p(i,j)
+ pres2_p(i,k,j) = w1*pres_p(i,k,j)+w2*pres_p(i,k+1,j)
+ psfc_p(i,j) = pres2_p(i,k,j)
enddo
- enddo
+ enddo
+
+!calculation of the hydrostatic pressure:
do j = jts,jte
do i = its,ite
- if(pres2_p(i,1,j) .lt. pres2_p(i,2,j)) then
- write(0,*)
- write(0,*) '--- subroutine MPAS_to_phys: pres2:',j,i
- do k = kts,kte+1
- write(0,201) j,i,k,pres2_p(i,k,j)
- enddo
-! write(0,*)
-! do k = kts,kte
-! write(0,201) j,i,k,pressure_b(k,i),pressure_p(k,i),pres_p(i,k,j),zz(k,i), &
-! rho_p(i,k,j),th_p(i,k,j),t_p(i,k,j),qv_p(i,k,j)
-! enddo
-! write(0,*)
-! do k = kts,kte
-! write(0,201) j,i,k,qv_p(i,k,j),qc_p(i,k,j),qr_p(i,k,j),qi_p(i,k,j),qs_p(i,k,j), &
-! qg_p(i,k,j)
-! enddo
- stop
- endif
+ !pressure at w-points:
+ k = kte+1
+ pres2_hyd_p(i,k,j) = pres2_p(i,k,j)
+ pres2_hydd_p(i,k,j) = pres2_p(i,k,j)
+ do k = kte,1,-1
+ rho_a = rho_p(i,k,j) / (1.+qv_p(i,k,j))
+ pres2_hyd_p(i,k,j) = pres2_hyd_p(i,k+1,j) + g*rho_p(i,k,j)*dz_p(i,k,j)
+ pres2_hydd_p(i,k,j) = pres2_hydd_p(i,k+1,j) + g*rho_a*dz_p(i,k,j)
+ enddo
+ !pressure at theta-points:
+ do k = kte,1,-1
+ pres_hyd_p(i,k,j) = 0.5*(pres2_hyd_p(i,k+1,j)+pres2_hyd_p(i,k,j))
+ pres_hydd_p(i,k,j) = 0.5*(pres2_hydd_p(i,k+1,j)+pres2_hydd_p(i,k,j))
+ enddo
+ !surface pressure:
+ psfc_hyd_p(i,j) = pres2_hyd_p(i,1,j)
+ psfc_hydd_p(i,j) = pres2_hydd_p(i,1,j)
+ !znu:
+ do k = kte,1,-1
+ znu_hyd_p(i,k,j) = pres_hyd_p(i,k,j) / psfc_hyd_p(i,j)
+ enddo
enddo
enddo
@@ -546,15 +544,6 @@
enddo
!updates the surface pressure.
-!do j = jts,jte
-!do i = its,ite
-! sfc_pressure(i) = 0.5*g*(zgrid(2,i)-zgrid(1,i)) &
-! * (1.25 * rho_zz(1,i) * zz(1,i) * (1. + qv_p(i,1,j)) &
-! - 0.25 * rho_zz(2,i) * zz(2,i) * (1. + qv_p(i,2,j)))
-! sfc_pressure(i) = sfc_pressure(i) + pressure_p(1,i) + pressure_b(1,i)
-!enddo
-!enddo
-!ldf (2012-01-09):
do j = jts,jte
do i = its,ite
tem1 = zgrid(2,i)-zgrid(1,i)
Modified: trunk/mpas/src/core_atmos_physics/mpas_atmphys_manager.F
===================================================================
--- trunk/mpas/src/core_atmos_physics/mpas_atmphys_manager.F 2013-03-27 19:24:59 UTC (rev 2673)
+++ trunk/mpas/src/core_atmos_physics/mpas_atmphys_manager.F 2013-03-27 19:26:14 UTC (rev 2674)
@@ -14,6 +14,12 @@
private
public:: physics_timetracker,physics_run_init
+!add-ons and modifications to sourcecode:
+!* added initialization of variable sf_surface_physics in subroutine physics_run_init. see
+! definition of sf_surface_physics in mpas_atmphys_vars.F
+! Laura D. Fowler (birch.ucar.edu) / 2013-03-11.
+
+
integer, public:: year !Current year.
integer, public:: julday !Initial Julian day.
real(kind=RKIND), public:: curr_julday !Current Julian day (= 0.0 at 0Z on January 1st).
@@ -55,6 +61,9 @@
integer, parameter:: acradtAlarmID = 20
type(MPAS_TimeInterval_Type):: acradtTimeStep
+!defines alarm to compute some physics diagnostics, such as radar reflectivity:
+ integer, parameter:: diagAlarmID = 21
+
integer :: h, m, s, s_n, s_d, DoY, yr
real(kind=RKIND) :: utc_h
@@ -229,6 +238,14 @@
write(0,*) '--- time to apply limit to accumulated radiation diags. L_ACRADT =',l_acradt
endif
+!check to see if it is time to calculate additional physics diagnostics:
+ l_diags = .false.
+ if(mpas_is_alarm_ringing(clock,diagAlarmID,ierr=ierr)) then
+ call mpas_reset_clock_alarm(clock,diagAlarmID,ierr=ierr)
+ l_diags = .true.
+ endif
+ write(0,*) '--- time to calculate additional physics_diagnostics =',l_diags
+
end subroutine physics_timetracker
!=============================================================================================
@@ -419,6 +436,11 @@
call physics_error_fatal('subroutine physics_init: error creating alarm radiation limit')
endif
+!set alarm to calculate physics diagnostics on IO outpt only:
+ call mpas_set_timeInterval(alarmTimeStep,timeString=config_output_interval,ierr=ierr)
+ alarmStartTime = startTime
+ call mpas_add_clock_alarm(clock,diagAlarmID,alarmStartTime,alarmTimeStep,ierr=ierr)
+
write(0,102) dt_radtlw,dt_radtsw,dt_cu,dt_pbl
!initialization of physics dimensions to mimic a rectangular grid:
@@ -447,11 +469,14 @@
lsm_scheme = trim(config_lsm_scheme)
microp_scheme = trim(config_microp_scheme)
pbl_scheme = trim(config_pbl_scheme)
+ gwdo_scheme = trim(config_gwdo_scheme)
radt_cld_scheme = trim(config_radt_cld_scheme)
radt_lw_scheme = trim(config_radt_lw_scheme)
radt_sw_scheme = trim(config_radt_sw_scheme)
sfclayer_scheme = trim(config_sfclayer_scheme)
+ if(trim(config_lsm_scheme) .eq. "noah") sf_surface_physics = 2
+
!initialization of local physics time-steps:
!... dynamics:
dt_dyn = config_dt
@@ -466,6 +491,7 @@
l_radtlw = .false.
l_radtsw = .false.
!... others:
+ l_diags = .false.
l_camlw = .false.
l_acrain = .false.
l_acradt = .false.
Modified: trunk/mpas/src/core_atmos_physics/mpas_atmphys_todynamics.F
===================================================================
--- trunk/mpas/src/core_atmos_physics/mpas_atmphys_todynamics.F 2013-03-27 19:24:59 UTC (rev 2673)
+++ trunk/mpas/src/core_atmos_physics/mpas_atmphys_todynamics.F 2013-03-27 19:26:14 UTC (rev 2674)
@@ -12,15 +12,16 @@
contains
!=============================================================================================
-subroutine physics_addtend(mesh, state, diag, tend, tend_physics, mass, mass_edge)
+subroutine physics_addtend(mesh, state, diag, tend, tend_physics, mass, mass_edge, rk_step)
!=============================================================================================
!input variables:
!----------------
-type(mesh_type),intent(in):: mesh
+ type(mesh_type),intent(in):: mesh
type(state_type),intent(in):: state
type(diag_type),intent(in):: diag
type(tend_physics_type),intent(inout):: tend_physics
+ integer, intent(in):: rk_step
real(kind=RKIND),dimension(:,:),intent(in):: mass
real(kind=RKIND),dimension(:,:),intent(in):: mass_edge
@@ -54,9 +55,6 @@
!ldf end.
!=============================================================================================
-!write(0,*)
-!write(0,*) '--- enter subroutine physics_add_tend:'
-
block => mesh % block
nCells = mesh % nCells
@@ -120,13 +118,6 @@
enddo
enddo
endif
-write(0,*) 'max rthblten = ',maxval(rthblten(:,1:nCellsSolve))
-write(0,*) 'min rthblten = ',minval(rthblten(:,1:nCellsSolve))
-!write(0,*) 'max rqvblten = ',maxval(rqvblten(:,1:nCellsSolve))
-!write(0,*) 'min rqvblten = ',minval(rqvblten(:,1:nCellsSolve))
-!write(0,*) 'max tend = ',maxval(tend_scalars(tend%index_qv,:,1:nCellsSolve))
-!write(0,*) 'min tend = ',minval(tend_scalars(tend%index_qv,:,1:nCellsSolve))
-!write(0,*)
!add coupled tendencies due to convection:
if(config_conv_deep_scheme .ne. 'off') then
@@ -154,13 +145,6 @@
enddo
enddo
endif
-write(0,*) 'max rthcuten = ',maxval(rthcuten(:,1:nCellsSolve))
-write(0,*) 'min rthcuten = ',minval(rthcuten(:,1:nCellsSolve))
-!write(0,*) 'max rqvcuten = ',maxval(rqvcuten(:,1:nCellsSolve))
-!write(0,*) 'min rqvcuten = ',minval(rqvcuten(:,1:nCellsSolve))
-!write(0,*) 'max tend = ',maxval(tend_scalars(tend%index_qv,:,1:nCellsSolve))
-!write(0,*) 'min tend = ',minval(tend_scalars(tend%index_qv,:,1:nCellsSolve))
-!write(0,*)
!add coupled tendencies due to longwave radiation:
if(config_radt_lw_scheme .ne. 'off') then
@@ -170,8 +154,6 @@
enddo
enddo
endif
-write(0,*) 'max rthratenlw = ',maxval(rthratenlw(:,1:nCellsSolve))
-write(0,*) 'min rthratenlw = ',minval(rthratenlw(:,1:nCellsSolve))
!add coupled tendencies due to shortwave radiation:
if(config_radt_sw_scheme .ne. 'off') then
@@ -181,8 +163,6 @@
enddo
enddo
endif
-write(0,*) 'max rthratensw = ',maxval(rthratensw(:,1:nCellsSolve))
-write(0,*) 'min rthratensw = ',minval(rthratensw(:,1:nCellsSolve))
!if non-hydrostatic core, convert the tendency for the potential temperature to a
!tendency for the modified potential temperature:
@@ -205,6 +185,21 @@
deallocate(theta)
deallocate(tend_th)
+ if(rk_step .eq. 3) then
+ write(0,*)
+ write(0,*) '--- enter subroutine physics_addtend:'
+ write(0,*) 'max rthblten = ',maxval(rthblten(:,1:nCellsSolve))
+ write(0,*) 'min rthblten = ',minval(rthblten(:,1:nCellsSolve))
+ write(0,*) 'max rthcuten = ',maxval(rthcuten(:,1:nCellsSolve))
+ write(0,*) 'min rthcuten = ',minval(rthcuten(:,1:nCellsSolve))
+ write(0,*) 'max rthratenlw = ',maxval(rthratenlw(:,1:nCellsSolve))
+ write(0,*) 'min rthratenlw = ',minval(rthratenlw(:,1:nCellsSolve))
+ write(0,*) 'max rthratensw = ',maxval(rthratensw(:,1:nCellsSolve))
+ write(0,*) 'min rthratensw = ',minval(rthratensw(:,1:nCellsSolve))
+ write(0,*) '--- end subroutine physics_addtend'
+ write(0,*)
+ endif
+
!formats:
201 format(2i6,10(1x,e15.8))
202 format(3i6,10(1x,e15.8))
Modified: trunk/mpas/src/core_atmos_physics/mpas_atmphys_update_surface.F
===================================================================
--- trunk/mpas/src/core_atmos_physics/mpas_atmphys_update_surface.F 2013-03-27 19:24:59 UTC (rev 2673)
+++ trunk/mpas/src/core_atmos_physics/mpas_atmphys_update_surface.F 2013-03-27 19:26:14 UTC (rev 2674)
@@ -54,7 +54,7 @@
shdmax => sfc_input % shdmax % array
!updates the surface background albedo for the current date as a function of the monthly-mean
-!surface background albedo valid on the 15th day of the month, if input_sfc_albedo is true:
+!surface background albedo valid on the 15th day of the month, if config_sfc_albedo is true:
if(config_sfc_albedo) then
call monthly_interp_to_date(nCellsSolve,current_date,albedo12m,sfc_albbck)
@@ -146,6 +146,9 @@
if(config_frac_seaice) then
if(xice(iCell).ne.xicem(iCell) .and. xicem(iCell).gt.xice_threshold) then
+ !Fractional values of sfc_albedo and sfc_emiss are valid according to the earlier
+ !fractional sea-ice fraction, xicem. We recompute them for the new sea-ice fraction,
+ !xice.
sfc_albedo(iCell) = 0.08 + (sfc_albedo(iCell) -0.08) * xice(iCell)/xicem(iCell)
sfc_emiss(iCell) = 0.98 + (sfc_emiss(iCell)-0.98) * xice(iCell)/xicem(iCell)
endif
@@ -178,12 +181,12 @@
sfc_emibck(iCell) = 0.98
elseif(xland(iCell).lt.1.5 .and. xice(iCell).lt.xice_threshold .and. &
- xicem(iCell).lt.xice_threshold) then
+ xicem(iCell).ge.xice_threshold) then
!sea-ice points turn to water points:
xicem(iCell) = xice(iCell)
xland(iCell) = 2.
- isltyp(iCell) = 16
+ isltyp(iCell) = 14
ivgtyp(iCell) = iswater
vegfra(iCell) = 0.
tmn(iCell) = sst(iCell)
@@ -236,22 +239,25 @@
real(kind=RKIND):: fs, con1, con2, con3, con4, con5, zlan, q2, ts, phi, qn1
real(kind=RKIND):: usw, qo, swo, us, tb, dtc, dtw, alw, dtwo, delt, f1
- real(kind=RKIND),dimension(:),pointer:: tsk,xland
+ real(kind=RKIND),dimension(:),pointer:: sst,tsk,xland
real(kind=RKIND),dimension(:),pointer:: glw,gsw
- real(kind=RKIND),dimension(:),pointer:: hfx,qfx,sstsk
- real(kind=RKIND),dimension(:),pointer:: dtw1,emiss,ust
+ real(kind=RKIND),dimension(:),pointer:: hfx,qfx
+ real(kind=RKIND),dimension(:),pointer:: emiss,ust
+ real(kind=RKIND),dimension(:),pointer:: sstsk,dtc1,dtw1
!---------------------------------------------------------------------------------------------
-!write(0,*)
-!write(0,*) '--- enter subroutine physics_update_sstskin:'
+ write(0,*)
+ write(0,*) '--- enter subroutine physics_update_sstskin:'
nCellsSolve = mesh % nCellsSolve
tsk => sfc_input % skintemp % array
+ sst => sfc_input % sst % array
xland => sfc_input % xland % array
- dtw1 => diag_physics % sstsk_diur % array
sstsk => diag_physics % sstsk % array
+ dtc1 => diag_physics % sstsk_dtc % array
+ dtw1 => diag_physics % sstsk_dtw % array
emiss => diag_physics % sfc_emiss % array
glw => diag_physics % glw % array
gsw => diag_physics % gsw % array
@@ -262,8 +268,14 @@
skinmax = -9999.
skinmin = 9999.
+!first, restore the surface temperature to the sea-surface temperature:
do iCell = 1, nCellsSolve
+ if(xland(iCell) .ge. 1.5) tsk(iCell) = sst(iCell)
+ enddo
+!calculate the skin sea-surface temperature:
+ do iCell = 1, nCellsSolve
+
if(xland(iCell) .ge. 1.5) then
qo = glw(iCell)-emiss(iCell)*stbolt*(sstsk(iCell)**4)-2.5e6*qfx(iCell)-hfx(iCell)
@@ -324,19 +336,20 @@
skinmax = amax1(skinmax,ts-tb)
skinmin = amin1(skinmin,ts-tb)
sstsk(iCell) = ts+273.15 ! convert ts (in C) to sstsk (in K)
+ dtc1(iCell) = dtc ! dtc always in C
dtw1(iCell) = dtw ! dtw always in C
endif
enddo
-!update the skin temperature:
+!update the surface temperature over the oceans:
do iCell = 1, nCellsSolve
if(xland(iCell) .gt. 1.5) tsk(iCell) = sstsk(iCell)
enddo
- write(0,*) 'check skin sst skinmax = ', skinmax, ' skinmin = ', skinmin
-
+ write(0,*) 'check skin sst skinmax = ', skinmax
+ write(0,*) 'check skin sst skinmin = ', skinmin
end subroutine physics_update_sstskin
Modified: trunk/mpas/src/core_atmos_physics/mpas_atmphys_vars.F
===================================================================
--- trunk/mpas/src/core_atmos_physics/mpas_atmphys_vars.F 2013-03-27 19:24:59 UTC (rev 2673)
+++ trunk/mpas/src/core_atmos_physics/mpas_atmphys_vars.F 2013-03-27 19:26:14 UTC (rev 2674)
@@ -7,6 +7,12 @@
public
save
+!add-ons and modifications to sourcecode:
+!* added the variables sf_surface_physics,alswvisdir_p,alswvisdif_p,alswnirdir_p,alswnirdif_p,
+! swvisdir_p,swvisdif_p,swnirdir_p,and swnirdif_p to upgrade the RRTMG short wave radiation
+! code to WRF version 3.4.1. see definition of each individual variables below.
+! Laura D. Fowler (birch.ucar.edu) / 2013-03-11.
+
!=============================================================================================
!list of physics parameterizations:
!=============================================================================================
@@ -14,6 +20,7 @@
character(len=StrKIND),public:: microp_scheme
character(len=StrKIND),public:: conv_deep_scheme
character(len=StrKIND),public:: conv_shallow_scheme
+ character(len=StrKIND),public:: gwdo_scheme
character(len=StrKIND),public:: lsm_scheme
character(len=StrKIND),public:: pbl_scheme
character(len=StrKIND),public:: radt_cld_scheme
@@ -30,12 +37,14 @@
logical:: l_radtsw !controls call to shortwave radiation parameterization.
logical:: l_conv !controls call to convective parameterization.
logical:: l_camlw !controls when to save local CAM LW abs and ems arrays.
+ logical:: l_diags !controls when to calculate physics diagnostics.
logical:: l_acrain !when .true., limit to accumulated rain is applied.
logical:: l_acradt !when .true., limit to lw and sw radiation is applied.
integer,public:: ids,ide,jds,jde,kds,kde
integer,public:: ims,ime,jms,jme,kms,kme
integer,public:: its,ite,jts,jte,kts,kte
+ integer,public:: iall
integer,public:: n_microp
integer,public:: num_months !number of months [-]
@@ -96,6 +105,17 @@
pres2_p, &!pressure [hPa]
t2_p !temperature [K]
+!... arrays used for calculating the hydrostatic pressure and exner function:
+ real(kind=RKIND),dimension(:,:),allocatable:: &
+ psfc_hyd_p, &!surface pressure [hPa]
+ psfc_hydd_p !"dry" surface pressure [hPa]
+ real(kind=RKIND),dimension(:,:,:),allocatable:: &
+ pres_hyd_p, &!pressure located at theta levels [hPa]
+ pres_hydd_p, &!"dry" pressure located at theta levels [hPa]
+ pres2_hyd_p, &!pressure located at w-velocity levels [hPa]
+ pres2_hydd_p, &!"dry" pressure located at w-velocity levels [hPa]
+ znu_hyd_p !(pres_hyd_p / P0) needed in the Tiedtke convection scheme [hPa]
+
!=============================================================================================
!... variables and arrays related to parameterization of cloud microphysics:
! warm_phase: logical that determines if we want to run warm-phase cloud microphysics only.
@@ -164,6 +184,18 @@
rqrcuten_p, &!
rqscuten_p !
+!... kain fritsch (trigger option) specific arrays:
+ real(kind=RKIND),dimension(:,:),allocatable:: &
+ area_kf_p !as area_p but using nCells instead of nCellsSolve [m2]
+ real(kind=RKIND),dimension(:,:,:),allocatable:: &
+ rqvdynten_havg_p, &!
+ rqvdynten_vavg_p, &!
+ t_kf_p, &!as t_p but using nCells instead of nCellsSolve to compute t_havg_p [K]
+ t_havg_p, &!
+ t_vavg_p, &!
+ t_htrigger_p, &!
+ t_vtrigger_p !
+
!... tiedtke specific arrays:
real(kind=RKIND),dimension(:,:,:),allocatable:: &
znu_p, &!
@@ -184,6 +216,8 @@
real(kind=RKIND),public:: dt_pbl
real(kind=RKIND),dimension(:,:),allocatable:: &
+ ctopo_p, &!correction to topography [-]
+ ctopo2_p, &!correction to topography 2 [-]
hpbl_p !PBL height [m]
real(kind=RKIND),dimension(:,:,:),allocatable:: &
@@ -197,23 +231,57 @@
rqcblten_p, &!
rqiblten_p !
+ real(kind=RKIND),dimension(:,:,:),allocatable:: &
+ kzh_p, &!
+ kzm_p, &!
+ kzq_p !
+
!=============================================================================================
+!... variables and arrays related to parameterization of gravity wave drag over orography:
+!=============================================================================================
+
+ real(kind=RKIND),dimension(:,:),allocatable:: &
+ var2d_p, &!orographic variance (m2)
+ con_p, &!orographic convexity (m2)
+ oa1_p, &!orographic direction asymmetry function (-)
+ oa2_p, &!orographic direction asymmetry function (-)
+ oa3_p, &!orographic direction asymmetry function (-)
+ oa4_p, &!orographic direction asymmetry function (-)
+ ol1_p, &!orographic direction asymmetry function (-)
+ ol2_p, &!orographic direction asymmetry function (-)
+ ol3_p, &!orographic direction asymmetry function (-)
+ ol4_p !orographic direction asymmetry function (-)
+
+ real(kind=RKIND),dimension(:,:),allocatable:: &
+ dx_p !maximum distance between cell centers (m)
+
+ real(kind=RKIND),dimension(:,:),allocatable:: &
+ dusfcg_p, &!vertically-integrated gwdo u-stress (Pa m s-1)
+ dvsfcg_p !vertically-integrated gwdo v -stress (Pa m s-1)
+
+ real(kind=RKIND),dimension(:,:,:),allocatable:: &
+ dtaux3d_p, &!gravity wave drag over orography u-stress (m s-1)
+ dtauy3d_p !gravity wave drag over orography u-stress (m s-1)
+
+!=============================================================================================
!... variables and arrays related to parameterization of surface layer:
!=============================================================================================
real(kind=RKIND),dimension(:,:),allocatable:: &
br_p, &!bulk richardson number [-]
- cd_p, &!
- cda_p, &!
- ck_p, &!
- cka_p, &!
+ cd_p, &!momentum exchange coeff at 10 meters [?]
+ cda_p, &!momentum exchange coeff at the lowest model level [?]
cpm_p, &!
chs_p, &!
chs2_p, &!
+ ck_p, &!enthalpy exchange coeff at 10 meters [?]
+ cka_p, &!enthalpy exchange coeff at the lowest model level [?]
cqs2_p, &!
gz1oz0_p, &!log of z1 over z0 [-]
flhc_p, &!exchange coefficient for heat [-]
flqc_p, &!exchange coefficient for moisture [-]
hfx_p, &!upward heat flux at the surface [W/m2]
+ fh_p, &!integrated stability function for heat [-]
+ fm_p, &!integrated stability function for momentum [-]
lh_p, &!latent heat flux at the surface [W/m2]
mavail_p, &!surface moisture availability [-]
mol_p, &!T* in similarity theory [K]
@@ -230,12 +298,13 @@
th2m_p, &!potential temperature at 2m [K]
u10_p, &!u at 10 m [m/s]
ust_p, &!u* in similarity theory [m/s]
- ustm_p, &!u* in similarity theory without vconv [m/s]
+ ustm_p, &!u* in similarity theory without vconv correction [m/s]
v10_p, &!v at 10 m [m/s]
wspd_p, &!wind speed [m/s]
znt_p, &!time-varying roughness length [m]
zol_p !
+
!=============================================================================================
!... variables and arrays related to parameterization of short-wave radiation:
!=============================================================================================
@@ -257,6 +326,12 @@
swupt_p, &!all-sky upwelling shortwave flux at top-of-atmosphere [J m-2]
swuptc_p !clear-sky upwelling shortwave flux at top-of-atmosphere [J m-2]
+ real(kind=RKIND),dimension(:,:),allocatable:: &
+ swvisdir_p, &!visible direct downward flux [W m-2]
+ swvisdif_p, &!visible diffuse downward flux [W m-2]
+ swnirdir_p, &!near-IR direct downward flux [W m-2]
+ swnirdif_p !near-IR diffuse downward flux [W m-2]
+
real(kind=RKIND),dimension(:,:,:),allocatable:: &
swdnflx_p, &!
swdnflxc_p, &!
@@ -344,6 +419,11 @@
!=============================================================================================
integer,public:: &
+ sf_surface_physics !used to define the land surface scheme by a number instead of name. It
+ !is only needed in module_ra_rrtmg_sw.F to define the spectral surface
+ !albedos as functions of the land surface scheme.
+
+ integer,public:: &
num_soils !number of soil layers [-]
integer,dimension(:,:),allocatable:: &
@@ -369,7 +449,6 @@
potevp_p, &!potential evaporation [W m-2]
qz0_p, &!specific humidity at znt [kg kg-1]
rainbl_p, &!
- rib_p, &!?
sfcrunoff_p, &!surface runoff [m s-1]
shdmin_p, &!minimum areal fractional coverage of annual green vegetation [-]
shdmax_p, &!maximum areal fractional coverage of annual green vegetation [-]
@@ -385,6 +464,12 @@
vegfra_p, &!vegetation fraction [-]
z0_p !background roughness length [m]
+ real(kind=RKIND),dimension(:,:),allocatable:: &
+ alswvisdir_p, &!direct-beam surface albedo in visible spectrum [-]
+ alswvisdif_p, &!diffuse-beam surface albedo in visible spectrum [-]
+ alswnirdir_p, &!direct-beam surface albedo in near-IR spectrum [-]
+ alswnirdif_p !diffuse-beam surface albedo in near-IR spectrum [-]
+
!=============================================================================================
!.. variables and arrays related to surface characteristics:
!=============================================================================================
Modified: trunk/mpas/src/core_atmos_physics/physics_wrf/Makefile
===================================================================
--- trunk/mpas/src/core_atmos_physics/physics_wrf/Makefile 2013-03-27 19:24:59 UTC (rev 2673)
+++ trunk/mpas/src/core_atmos_physics/physics_wrf/Makefile 2013-03-27 19:26:14 UTC (rev 2674)
@@ -7,6 +7,7 @@
OBJS = \
libmassv.o \
+ module_bl_gwdo.o \
module_bl_ysu.o \
module_cam_shr_kind_mod.o \
module_cam_support.o \
@@ -14,6 +15,7 @@
module_cu_kfeta_wrf3.3.1.o \
module_cu_tiedtke.o \
module_mp_kessler.o \
+ module_mp_radar.o \
module_mp_thompson.o \
module_mp_wsm6.o \
module_ra_cam.o \
@@ -36,11 +38,15 @@
module_cam_shr_kind_mod.o \
../mpas_atmphys_utilities.o
+module_mp_radar.o: \
+ ../mpas_atmphys_utilities.o
+
module_mp_thompson.o: \
../mpas_atmphys_utilities.o
module_mp_wsm6.o: \
- libmassv.o
+ libmassv.o \
+ module_mp_radar.o
module_ra_cam.o: \
module_cam_support.o \
Added: trunk/mpas/src/core_atmos_physics/physics_wrf/module_bl_gwdo.F
===================================================================
--- trunk/mpas/src/core_atmos_physics/physics_wrf/module_bl_gwdo.F (rev 0)
+++ trunk/mpas/src/core_atmos_physics/physics_wrf/module_bl_gwdo.F 2013-03-27 19:26:14 UTC (rev 2674)
@@ -0,0 +1,743 @@
+! WRf:model_layer:physics
+!
+!
+!
+!
+!
+module module_bl_gwdo
+contains
+!
+!-------------------------------------------------------------------
+!
+ subroutine gwdo(u3d,v3d,t3d,qv3d,p3d,p3di,pi3d,z, &
+ rublten,rvblten, &
+ dtaux3d,dtauy3d,dusfcg,dvsfcg, &
+ var2d,oc12d,oa2d1,oa2d2,oa2d3,oa2d4,ol2d1,ol2d2,ol2d3,ol2d4, &
+ znu,znw,mut,p_top, &
+ cp,g,rd,rv,ep1,pi, &
+ dt,dx,kpbl2d,itimestep, &
+ ids,ide, jds,jde, kds,kde, &
+ ims,ime, jms,jme, kms,kme, &
+ its,ite, jts,jte, kts,kte)
+!-------------------------------------------------------------------
+ implicit none
+!------------------------------------------------------------------------------
+!
+!-- u3d 3d u-velocity interpolated to theta points (m/s)
+!-- v3d 3d v-velocity interpolated to theta points (m/s)
+!-- t3d temperature (k)
+!-- qv3d 3d water vapor mixing ratio (kg/kg)
+!-- p3d 3d pressure (pa)
+!-- p3di 3d pressure (pa) at interface level
+!-- pi3d 3d exner function (dimensionless)
+!-- rublten u tendency due to
+! pbl parameterization (m/s/s)
+!-- rvblten v tendency due to
+!-- cp heat capacity at constant pressure for dry air (j/kg/k)
+!-- g acceleration due to gravity (m/s^2)
+!-- rd gas constant for dry air (j/kg/k)
+!-- z height above sea level (m)
+!-- rv gas constant for water vapor (j/kg/k)
+!-- dt time step (s)
+!-- dx model grid interval (m)
+!-- ep1 constant for virtual temperature (r_v/r_d - 1) (dimensionless)
+!-- ids start index for i in domain
+!-- ide end index for i in domain
+!-- jds start index for j in domain
+!-- jde end index for j in domain
+!-- kds start index for k in domain
+!-- kde end index for k in domain
+!-- ims start index for i in memory
+!-- ime end index for i in memory
+!-- jms start index for j in memory
+!-- jme end index for j in memory
+!-- kms start index for k in memory
+!-- kme end index for k in memory
+!-- its start index for i in tile
+!-- ite end index for i in tile
+!-- jts start index for j in tile
+!-- jte end index for j in tile
+!-- kts start index for k in tile
+!-- kte end index for k in tile
+!-------------------------------------------------------------------
+!
+ integer, intent(in ) :: ids,ide, jds,jde, kds,kde, &
+ ims,ime, jms,jme, kms,kme, &
+ its,ite, jts,jte, kts,kte
+ integer, intent(in ) :: itimestep
+!
+!MPAS specific (Laura D. Fowler 2013-02-12):
+#if defined(non_hydrostatic_core)
+ real, intent(in ) :: dt,cp,g,rd,rv,ep1,pi
+ real, intent(in), dimension(ims:ime,jms:jme):: dx
+#else
+ real, intent(in ) :: dt,dx,cp,g,rd,rv,ep1,pi
+#endif
+!MPAS specific end.
+!
+ real, dimension( ims:ime, kms:kme, jms:jme ) , &
+ intent(in ) :: qv3d, &
+ p3d, &
+ pi3d, &
+ t3d, &
+ z
+ real, dimension( ims:ime, kms:kme, jms:jme ) , &
+ intent(in ) :: p3di
+!
+ real, dimension( ims:ime, kms:kme, jms:jme ) , &
+ intent(inout) :: rublten, &
+ rvblten
+ real, dimension( ims:ime, kms:kme, jms:jme ) , &
+ intent(inout) :: dtaux3d, &
+ dtauy3d
+!
+ real, dimension( ims:ime, kms:kme, jms:jme ) , &
+ intent(in ) :: u3d, &
+ v3d
+!
+ integer, dimension( ims:ime, jms:jme ) , &
+ intent(in ) :: kpbl2d
+ real, dimension( ims:ime, jms:jme ) , &
+ intent(inout ) :: dusfcg, &
+ dvsfcg
+!
+ real, dimension( ims:ime, jms:jme ) , &
+ intent(in ) :: var2d, &
+ oc12d, &
+ oa2d1,oa2d2,oa2d3,oa2d4, &
+ ol2d1,ol2d2,ol2d3,ol2d4
+!
+ real, dimension( ims:ime, jms:jme ) , &
+ optional , &
+ intent(in ) :: mut
+!
+ real, dimension( kms:kme ) , &
+ optional , &
+ intent(in ) :: znu, &
+ znw
+!
+ real, optional, intent(in ) :: p_top
+!
+!local
+!
+ real, dimension( its:ite, kts:kte ) :: delprsi, &
+ pdh
+ real, dimension( its:ite, kts:kte+1 ) :: pdhi
+ real, dimension( its:ite, 4 ) :: oa4, &
+ ol4
+ integer :: i,j,k,kdt
+!
+ do j = jts,jte
+ if(present(mut))then
+! For ARW we will replace p and p8w with dry hydrostatic pressure
+ do k = kts,kte+1
+ do i = its,ite
+ if(k.le.kte)pdh(i,k) = mut(i,j)*znu(k) + p_top
+ pdhi(i,k) = mut(i,j)*znw(k) + p_top
+ enddo
+ enddo
+ else
+ do k = kts,kte+1
+ do i = its,ite
+ if(k.le.kte)pdh(i,k) = p3d(i,k,j)
+ pdhi(i,k) = p3di(i,k,j)
+ enddo
+ enddo
+ endif
+!
+ do k = kts,kte
+ do i = its,ite
+ delprsi(i,k) = pdhi(i,k)-pdhi(i,k+1)
+ enddo
+ enddo
+ do i = its,ite
+ oa4(i,1) = oa2d1(i,j)
+ oa4(i,2) = oa2d2(i,j)
+ oa4(i,3) = oa2d3(i,j)
+ oa4(i,4) = oa2d4(i,j)
+ ol4(i,1) = ol2d1(i,j)
+ ol4(i,2) = ol2d2(i,j)
+ ol4(i,3) = ol2d3(i,j)
+ ol4(i,4) = ol2d4(i,j)
+ enddo
+ call gwdo2d(dudt=rublten(ims,kms,j),dvdt=rvblten(ims,kms,j) &
+ ,dtaux2d=dtaux3d(ims,kms,j),dtauy2d=dtauy3d(ims,kms,j) &
+ ,u1=u3d(ims,kms,j),v1=v3d(ims,kms,j) &
+ ,t1=t3d(ims,kms,j),q1=qv3d(ims,kms,j) &
+ ,prsi=pdhi(its,kts),del=delprsi(its,kts) &
+ ,prsl=pdh(its,kts),prslk=pi3d(ims,kms,j) &
+ ,zl=z(ims,kms,j),rcl=1.0 &
+ ,dusfc=dusfcg(ims,j),dvsfc=dvsfcg(ims,j) &
+ ,var=var2d(ims,j),oc1=oc12d(ims,j) &
+ ,oa4=oa4,ol4=ol4 &
+ ,g=g,cp=cp,rd=rd,rv=rv,fv=ep1,pi=pi &
+!MPAS specific (Laura D. Fowler 2013-02-12):
+#if defined(non_hydrostatic_core)
+ ,dxmeter=dx(ims,j),deltim=dt &
+#else
+ ,dxmeter=dx,deltim=dt &
+#endif
+!MPAS specific end.
+ ,kpbl=kpbl2d(ims,j),kdt=itimestep,lat=j &
+ ,ids=ids,ide=ide, jds=jds,jde=jde, kds=kds,kde=kde &
+ ,ims=ims,ime=ime, jms=jms,jme=jme, kms=kms,kme=kme &
+ ,its=its,ite=ite, jts=jts,jte=jte, kts=kts,kte=kte )
+ enddo
+!
+!
+ end subroutine gwdo
+!
+!-------------------------------------------------------------------
+!
+!
+!
+!
+ subroutine gwdo2d(dudt,dvdt,dtaux2d,dtauy2d, &
+ u1,v1,t1,q1, &
+ prsi,del,prsl,prslk,zl,rcl, &
+ var,oc1,oa4,ol4,dusfc,dvsfc, &
+ g,cp,rd,rv,fv,pi,dxmeter,deltim,kpbl,kdt,lat, &
+ ids,ide, jds,jde, kds,kde, &
+ ims,ime, jms,jme, kms,kme, &
+ its,ite, jts,jte, kts,kte)
+!-------------------------------------------------------------------
+!
+! this code handles the time tendencies of u v due to the effect of mountain
+! induced gravity wave drag from sub-grid scale orography. this routine
+! not only treats the traditional upper-level wave breaking due to mountain
+! variance (alpert 1988), but also the enhanced lower-tropospheric wave
+! breaking due to mountain convexity and asymmetry (kim and arakawa 1995).
+! thus, in addition to the terrain height data in a model grid gox,
+! additional 10-2d topographic statistics files are needed, including
+! orographic standard deviation (var), convexity (oc1), asymmetry (oa4)
+! and ol (ol4). these data sets are prepared based on the 30 sec usgs orography
+! hong (1999). the current scheme was implmented as in hong et al.(2008)
+!
+! coded by song-you hong and young-joon kim and implemented by song-you hong
+!
+! references:
+! hong et al. (2008), wea. and forecasting
+! kim and arakawa (1995), j. atmos. sci.
+! alpet et al. (1988), NWP conference.
+! hong (1999), NCEP office note 424.
+!
+! notice : comparible or lower resolution orography files than model resolution
+! are desirable in preprocess (wps) to prevent weakening of the drag
+!-------------------------------------------------------------------
+!
+! input
+! dudt (ims:ime,kms:kme) non-lin tendency for u wind component
+! dvdt (ims:ime,kms:kme) non-lin tendency for v wind component
+! u1(ims:ime,kms:kme) zonal wind / sqrt(rcl) m/sec at t0-dt
+! v1(ims:ime,kms:kme) meridional wind / sqrt(rcl) m/sec at t0-dt
+! t1(ims:ime,kms:kme) temperature deg k at t0-dt
+! q1(ims:ime,kms:kme) specific humidity at t0-dt
+!
+! rcl a scaling factor = reciprocal of square of cos(lat)
+! for mrf gsm. rcl=1 if u1 and v1 are wind components.
+! deltim time step secs
+! del(kts:kte) positive increment of pressure across layer (pa)
+!
+! output
+! dudt, dvdt wind tendency due to gwdo
+!
+!-------------------------------------------------------------------
+ implicit none
+!-------------------------------------------------------------------
+ integer :: kdt,lat,latd,lond, &
+ ids,ide, jds,jde, kds,kde, &
+ ims,ime, jms,jme, kms,kme, &
+ its,ite, jts,jte, kts,kte
+!
+!MPAS specific (Laura D. Fowler 2013-02-12):
+#if defined(non_hydrostatic_core)
+ real :: g,rd,rv,fv,cp,pi,deltim,rcl
+ real, dimension(ims:ime):: dxmeter
+#else
+ real :: g,rd,rv,fv,cp,pi,dxmeter,deltim,rcl
+#endif
+!MPAS specific end.
+
+ real :: dudt(ims:ime,kms:kme),dvdt(ims:ime,kms:kme), &
+ dtaux2d(ims:ime,kms:kme),dtauy2d(ims:ime,kms:kme), &
+ u1(ims:ime,kms:kme),v1(ims:ime,kms:kme), &
+ t1(ims:ime,kms:kme),q1(ims:ime,kms:kme), &
+ zl(ims:ime,kms:kme),prslk(ims:ime,kms:kme)
+ real :: prsl(its:ite,kts:kte),prsi(its:ite,kts:kte+1), &
+ del(its:ite,kts:kte)
+ real :: oa4(its:ite,4),ol4(its:ite,4)
+!
+ integer :: kpbl(ims:ime)
+ real :: var(ims:ime),oc1(ims:ime), &
+ dusfc(ims:ime),dvsfc(ims:ime)
+! critical richardson number for wave breaking : ! larger drag with larger value
+!
+ real,parameter :: ric = 0.25
+!
+ real,parameter :: dw2min = 1.
+ real,parameter :: rimin = -100.
+ real,parameter :: bnv2min = 1.0e-5
+ real,parameter :: efmin = 0.0
+ real,parameter :: efmax = 10.0
+ real,parameter :: xl = 4.0e4
+ real,parameter :: critac = 1.0e-5
+ real,parameter :: gmax = 1.
+ real,parameter :: veleps = 1.0
+ real,parameter :: factop = 0.5
+ real,parameter :: frc = 1.0
+ real,parameter :: ce = 0.8
+ real,parameter :: cg = 0.5
+!
+! local variables
+!
+ integer :: i,k,lcap,lcapp1,nwd,idir,kpblmin,kpblmax, &
+ klcap,kp1,ikount,kk
+!
+!MPAS specific (Laura D. Fowler 2013-02-12):
+#if defined(non_hydrostatic_core)
+ real :: rcs,rclcs,csg,fdir,cs,rcsks, &
+ wdir,ti,rdz,temp,tem2,dw2,shr2,bvf2,rdelks, &
+ wtkbj,coefm,tem,gfobnv,hd,fro,rim,temc,tem1,efact, &
+ temv,dtaux,dtauy
+ real, dimension(its:ite):: cleff
+#else
+ real :: rcs,rclcs,csg,fdir,cleff,cs,rcsks, &
+ wdir,ti,rdz,temp,tem2,dw2,shr2,bvf2,rdelks, &
+ wtkbj,coefm,tem,gfobnv,hd,fro,rim,temc,tem1,efact, &
+ temv,dtaux,dtauy
+#endif
+!
+ logical :: ldrag(its:ite),icrilv(its:ite), &
+ flag(its:ite),kloop1(its:ite)
+!
+ real :: taub(its:ite),taup(its:ite,kts:kte+1), &
+ xn(its:ite),yn(its:ite), &
+ ubar(its:ite),vbar(its:ite), &
+ fr(its:ite),ulow(its:ite), &
+ rulow(its:ite),bnv(its:ite), &
+ oa(its:ite),ol(its:ite), &
+ roll(its:ite),dtfac(its:ite), &
+ brvf(its:ite),xlinv(its:ite), &
+ delks(its:ite),delks1(its:ite), &
+ bnv2(its:ite,kts:kte),usqj(its:ite,kts:kte), &
+ taud(its:ite,kts:kte),ro(its:ite,kts:kte), &
+ vtk(its:ite,kts:kte),vtj(its:ite,kts:kte), &
+ zlowtop(its:ite),velco(its:ite,kts:kte-1)
+!
+ integer :: kbl(its:ite),klowtop(its:ite), &
+ lowlv(its:ite)
+!
+ logical :: iope
+ integer,parameter :: mdir=8
+ integer :: nwdir(mdir)
+ data nwdir/6,7,5,8,2,3,1,4/
+!
+! initialize local variables
+!
+ kbl=0 ; klowtop=0 ; lowlv=0
+!
+!---- constants
+!
+ rcs = sqrt(rcl)
+ cs = 1. / sqrt(rcl)
+ csg = cs * g
+ lcap = kte
+ lcapp1 = lcap + 1
+ fdir = mdir / (2.0*pi)
+!
+!
+!!!!!!! cleff (subgrid mountain scale ) is highly tunable parameter
+!!!!!!! the bigger (smaller) value produce weaker (stronger) wave drag
+!
+!MPAS specific (Laura D. Fowler 2013-02-13):
+#if defined(non_hydrostatic_core)
+ do i = its, ite
+ cleff(i) = max(dxmeter(i),50.e3)
+ enddo
+#else
+ cleff = max(dxmeter,50.e3)
+#endif
+!MPAS specific end.
+!
+! initialize!!
+!
+ dtaux = 0.0
+ dtauy = 0.0
+ do k = kts,kte
+ do i = its,ite
+ usqj(i,k) = 0.0
+ bnv2(i,k) = 0.0
+ vtj(i,k) = 0.0
+ vtk(i,k) = 0.0
+ taup(i,k) = 0.0
+ taud(i,k) = 0.0
+ dtaux2d(i,k)= 0.0
+ dtauy2d(i,k)= 0.0
+ enddo
+ enddo
+ do i = its,ite
+ taup(i,kte+1) = 0.0
+ xlinv(i) = 1.0/xl
+ enddo
+!
+ do k = kts,kte
+ do i = its,ite
+ vtj(i,k) = t1(i,k) * (1.+fv*q1(i,k))
+ vtk(i,k) = vtj(i,k) / prslk(i,k)
+ ro(i,k) = 1./rd * prsl(i,k) / vtj(i,k) ! density kg/m**3
+ enddo
+ enddo
+!
+ do i = its,ite
+ zlowtop(i) = 2. * var(i)
+ enddo
+!
+!--- determine new reference level > 2*var
+!
+ do i = its,ite
+ kloop1(i) = .true.
+ enddo
+ do k = kts+1,kte
+ do i = its,ite
+ if(kloop1(i).and.zl(i,k)-zl(i,1).ge.zlowtop(i)) then
+ klowtop(i) = k+1
+ kloop1(i) = .false.
+ endif
+ enddo
+ enddo
+!
+ kpblmax = 2
+ do i = its,ite
+ kbl(i) = max(2, kpbl(i))
+ kbl(i) = max(kbl(i), klowtop(i))
+ delks(i) = 1.0 / (prsi(i,1) - prsi(i,kbl(i)))
+ ubar (i) = 0.0
+ vbar (i) = 0.0
+ taup(i,1) = 0.0
+ oa(i) = 0.0
+ kpblmax = max(kpblmax,kbl(i))
+ flag(i) = .true.
+ lowlv(i) = 2
+ enddo
+ kpblmax = min(kpblmax+1,kte-1)
+!
+! compute low level averages within pbl
+!
+ do k = kts,kpblmax
+ do i = its,ite
+ if (k.lt.kbl(i)) then
+ rcsks = rcs * del(i,k) * delks(i)
+ ubar(i) = ubar(i) + rcsks * u1(i,k) ! pbl u mean
+ vbar(i) = vbar(i) + rcsks * v1(i,k) ! pbl v mean
+ endif
+ enddo
+ enddo
+!
+! figure out low-level horizontal wind direction
+!
+! nwd 1 2 3 4 5 6 7 8
+! wd w s sw nw e n ne se
+!
+ do i = its,ite
+ wdir = atan2(ubar(i),vbar(i)) + pi
+ idir = mod(nint(fdir*wdir),mdir) + 1
+ nwd = nwdir(idir)
+ oa(i) = (1-2*int( (nwd-1)/4 )) * oa4(i,mod(nwd-1,4)+1)
+ ol(i) = ol4(i,mod(nwd-1,4)+1)
+ enddo
+!
+ kpblmin = kte
+ do i = its,ite
+ kpblmin = min(kpblmin, kbl(i))
+ enddo
+!
+ do i = its,ite
+ if (oa(i).le.0.0) kbl(i) = kpbl(i) + 1
+ enddo
+!
+ do i = its,ite
+ delks(i) = 1.0 / (prsi(i,1) - prsi(i,kbl(i)))
+ delks1(i) = 1.0 / (prsl(i,1) - prsl(i,kbl(i)))
+ enddo
+!
+!--- saving richardson number in usqj for migwdi
+!
+ do k = kts,kte-1
+ do i = its,ite
+ ti = 2.0 / (t1(i,k)+t1(i,k+1))
+ rdz = 1./(zl(i,k+1) - zl(i,k))
+ tem1 = u1(i,k) - u1(i,k+1)
+ tem2 = v1(i,k) - v1(i,k+1)
+ dw2 = rcl*(tem1*tem1 + tem2*tem2)
+ shr2 = max(dw2,dw2min) * rdz * rdz
+ bvf2 = g*(g/cp+rdz*(vtj(i,k+1)-vtj(i,k))) * ti
+ usqj(i,k) = max(bvf2/shr2,rimin)
+ bnv2(i,k) = 2*g*rdz*(vtk(i,k+1)-vtk(i,k))/(vtk(i,k+1)+vtk(i,k))
+ bnv2(i,k) = max( bnv2(i,k), bnv2min )
+ enddo
+ enddo
+!
+!-----initialize arrays
+!
+ do i = its,ite
+ xn(i) = 0.0
+ yn(i) = 0.0
+ ubar (i) = 0.0
+ vbar (i) = 0.0
+ roll (i) = 0.0
+ taub (i) = 0.0
+ ulow (i) = 0.0
+ dtfac(i) = 1.0
+ ldrag(i) = .false.
+ icrilv(i) = .false. ! initialize critical level control vector
+ enddo
+!
+!---- compute low level averages
+!---- (u,v)*cos(lat) use uv=(u1,v1) which is wind at t0-1
+!---- use rcs=1/cos(lat) to get wind field
+!
+ do k = 1,kpblmax
+ do i = its,ite
+ if (k .lt. kbl(i)) then
+ rdelks = del(i,k) * delks(i)
+ rcsks = rcs * rdelks
+ ubar(i) = ubar(i) + rcsks * u1(i,k) ! u mean
+ vbar(i) = vbar(i) + rcsks * v1(i,k) ! v mean
+ roll(i) = roll(i) + rdelks * ro(i,k) ! ro mean
+ endif
+ enddo
+ enddo
+!
+!----compute the "low level" or 1/3 wind magnitude (m/s)
+!
+ do i = its,ite
+ ulow(i) = max(sqrt(ubar(i)*ubar(i) + vbar(i)*vbar(i)), 1.0)
+ rulow(i) = 1./ulow(i)
+ enddo
+!
+ do k = kts,kte-1
+ do i = its,ite
+ velco(i,k) = (0.5*rcs) * ((u1(i,k)+u1(i,k+1)) * ubar(i) &
+ + (v1(i,k)+v1(i,k+1)) * vbar(i))
+ velco(i,k) = velco(i,k) * rulow(i)
+ if ((velco(i,k).lt.veleps) .and. (velco(i,k).gt.0.)) then
+ velco(i,k) = veleps
+ endif
+ enddo
+ enddo
+!
+! no drag when critical level in the base layer
+!
+ do i = its,ite
+ ldrag(i) = velco(i,1).le.0.
+ enddo
+!
+ do k = kts+1,kpblmax-1
+ do i = its,ite
+ if (k .lt. kbl(i)) ldrag(i) = ldrag(i).or. velco(i,k).le.0.
+ enddo
+ enddo
+!
+! no drag when bnv2.lt.0
+!
+ do k = kts,kpblmax-1
+ do i = its,ite
+ if (k .lt. kbl(i)) ldrag(i) = ldrag(i).or. bnv2(i,k).lt.0.
+ enddo
+ enddo
+!
+!-----the low level weighted average ri is stored in usqj(1,1; im)
+!-----the low level weighted average n**2 is stored in bnv2(1,1; im)
+!---- this is called bnvl2 in phys_gwd_alpert_sub not bnv2
+!---- rdelks (del(k)/delks) vert ave factor so we can * instead of /
+!
+ do i = its,ite
+ wtkbj = (prsl(i,1)-prsl(i,2)) * delks1(i)
+ bnv2(i,1) = wtkbj * bnv2(i,1)
+ usqj(i,1) = wtkbj * usqj(i,1)
+ enddo
+!
+ do k = kts+1,kpblmax-1
+ do i = its,ite
+ if (k .lt. kbl(i)) then
+ rdelks = (prsl(i,k)-prsl(i,k+1)) * delks1(i)
+ bnv2(i,1) = bnv2(i,1) + bnv2(i,k) * rdelks
+ usqj(i,1) = usqj(i,1) + usqj(i,k) * rdelks
+ endif
+ enddo
+ enddo
+!
+ do i = its,ite
+ ldrag(i) = ldrag(i) .or. bnv2(i,1).le.0.0
+ ldrag(i) = ldrag(i) .or. ulow(i).eq.1.0
+ ldrag(i) = ldrag(i) .or. var(i) .le. 0.0
+ enddo
+!
+! ----- set all ri low level values to the low level value
+!
+ do k = kts+1,kpblmax-1
+ do i = its,ite
+ if (k .lt. kbl(i)) usqj(i,k) = usqj(i,1)
+ enddo
+ enddo
+!
+ do i = its,ite
+ if (.not.ldrag(i)) then
+ bnv(i) = sqrt( bnv2(i,1) )
+ fr(i) = bnv(i) * rulow(i) * var(i)
+ xn(i) = ubar(i) * rulow(i)
+ yn(i) = vbar(i) * rulow(i)
+ endif
+ enddo
+!
+! compute the base level stress and store it in taub
+! calculate enhancement factor, number of mountains & aspect
+! ratio const. use simplified relationship between standard
+! deviation & critical hgt
+!
+ do i = its,ite
+ if (.not. ldrag(i)) then
+ efact = (oa(i) + 2.) ** (ce*fr(i)/frc)
+ efact = min( max(efact,efmin), efmax )
+ coefm = (1. + ol(i)) ** (oa(i)+1.)
+!MPAS specific (Laura D. Fowler 2013-02-12):
+#if defined (non_hydrostatic_core)
+ xlinv(i) = coefm / cleff(i)
+#else
+ xlinv(i) = coefm / cleff
+#endif
+ tem = fr(i) * fr(i) * oc1(i)
+ gfobnv = gmax * tem / ((tem + cg)*bnv(i))
+ taub(i) = xlinv(i) * roll(i) * ulow(i) * ulow(i) &
+ * ulow(i) * gfobnv * efact
+ else
+ taub(i) = 0.0
+ xn(i) = 0.0
+ yn(i) = 0.0
+ endif
+ enddo
+!
+! now compute vertical structure of the stress.
+!
+!----set up bottom values of stress
+!
+ do k = kts,kpblmax
+ do i = its,ite
+ if (k .le. kbl(i)) taup(i,k) = taub(i)
+ enddo
+ enddo
+!
+ do k = kpblmin, kte-1 ! vertical level k loop!
+ kp1 = k + 1
+ do i = its,ite
+!
+!-----unstablelayer if ri < ric
+!-----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. kbl(i)) then
+ icrilv(i) = icrilv(i) .or. ( usqj(i,k) .lt. ric) &
+ .or. (velco(i,k) .le. 0.0)
+ brvf(i) = max(bnv2(i,k),bnv2min) ! brunt-vaisala frequency squared
+ brvf(i) = sqrt(brvf(i)) ! brunt-vaisala frequency
+ endif
+ enddo
+!
+ do i = its,ite
+ if (k .ge. kbl(i) .and. (.not. ldrag(i))) then
+ if (.not.icrilv(i) .and. taup(i,k) .gt. 0.0 ) then
+ temv = 1.0 / velco(i,k)
+ tem1 = xlinv(i)*(ro(i,kp1)+ro(i,k))*brvf(i)*velco(i,k)*0.5
+ hd = sqrt(taup(i,k) / tem1)
+ fro = brvf(i) * hd * temv
+!
+! rim is the minimum-richardson number by shutts (1985)
+!
+ tem2 = sqrt(usqj(i,k))
+ tem = 1. + tem2 * fro
+ rim = usqj(i,k) * (1.-fro) / (tem * tem)
+!
+! check stability to employ the 'saturation hypothesis'
+! of lindzen (1981) except at tropospheric downstream regions
+!
+ if (rim .le. ric) then ! saturation hypothesis!
+ if ((oa(i) .le. 0. .or. kp1 .ge. lowlv(i) )) then
+ temc = 2.0 + 1.0 / tem2
+ hd = velco(i,k) * (2.*sqrt(temc)-temc) / brvf(i)
+ taup(i,kp1) = tem1 * hd * hd
+ endif
+ else ! no wavebreaking!
+ taup(i,kp1) = taup(i,k)
+ endif
+ endif
+ endif
+ enddo
+ enddo
+!
+ if(lcap.lt.kte) then
+ do klcap = lcapp1,kte
+ do i = its,ite
+ taup(i,klcap) = prsi(i,klcap) / prsi(i,lcap) * taup(i,lcap)
+ enddo
+ enddo
+ endif
+!
+! calculate - (g)*d(tau)/d(pressure) and deceleration terms dtaux, dtauy
+!
+ do k = kts,kte
+ do i = its,ite
+ taud(i,k) = 1. * (taup(i,k+1) - taup(i,k)) * csg / del(i,k)
+ enddo
+ enddo
+!
+!------limit de-acceleration (momentum deposition ) at top to 1/2 value
+!------the idea is some stuff must go out the 'top'
+!
+ do klcap = lcap,kte
+ do i = its,ite
+ taud(i,klcap) = taud(i,klcap) * factop
+ enddo
+ enddo
+!
+!------if the gravity wave drag would force a critical line
+!------in the lower ksmm1 layers during the next deltim timestep,
+!------then only apply drag until that critical line is reached.
+!
+ do k = kts,kpblmax-1
+ do i = its,ite
+ if (k .le. kbl(i)) then
+ if(taud(i,k).ne.0.) &
+ dtfac(i) = min(dtfac(i),abs(velco(i,k) &
+ /(deltim*rcs*taud(i,k))))
+ endif
+ enddo
+ enddo
+!
+ do i = its,ite
+ dusfc(i) = 0.
+ dvsfc(i) = 0.
+ enddo
+!
+ do k = kts,kte
+ do i = its,ite
+ taud(i,k) = taud(i,k) * dtfac(i)
+ dtaux = taud(i,k) * xn(i)
+ dtauy = taud(i,k) * yn(i)
+ dtaux2d(i,k) = dtaux
+ dtauy2d(i,k) = dtauy
+ dudt(i,k) = dtaux + dudt(i,k)
+ dvdt(i,k) = dtauy + dvdt(i,k)
+ dusfc(i) = dusfc(i) + dtaux * del(i,k)
+ dvsfc(i) = dvsfc(i) + dtauy * del(i,k)
+ enddo
+ enddo
+!
+ do i = its,ite
+ dusfc(i) = (-1./g*rcs) * dusfc(i)
+ dvsfc(i) = (-1./g*rcs) * dvsfc(i)
+ enddo
+!
+ return
+ end subroutine gwdo2d
+!-------------------------------------------------------------------
+end module module_bl_gwdo
Modified: trunk/mpas/src/core_atmos_physics/physics_wrf/module_bl_ysu.F
===================================================================
--- trunk/mpas/src/core_atmos_physics/physics_wrf/module_bl_ysu.F 2013-03-27 19:24:59 UTC (rev 2673)
+++ trunk/mpas/src/core_atmos_physics/physics_wrf/module_bl_ysu.F 2013-03-27 19:26:14 UTC (rev 2674)
@@ -1,4 +1,4 @@
-!WRf:model_layer:physics
+!WRF:model_layer:physics
!
!
!
@@ -19,15 +19,21 @@
dz8w,psfc, &
znu,znw,mut,p_top, &
znt,ust,hpbl,psim,psih, &
- xland,hfx,qfx,gz1oz0,wspd,br, &
+ xland,hfx,qfx,wspd,br, &
dt,kpbl2d, &
exch_h, &
u10,v10, &
+ ctopo,ctopo2, &
ids,ide, jds,jde, kds,kde, &
ims,ime, jms,jme, kms,kme, &
its,ite, jts,jte, kts,kte, &
!optional
- regime )
+ regime &
+#if defined(non_hydrostatic_core) || defined(hydrostatic_core)
+ !MPAS specific optional arguments for additional diagnostics:
+ ,rho,kzhout,kzmout,kzqout &
+#endif
+ )
!-------------------------------------------------------------------
implicit none
!-------------------------------------------------------------------
@@ -72,7 +78,6 @@
!-- xland land mask (1 for land, 2 for water)
!-- hfx upward heat flux at the surface (w/m^2)
!-- qfx upward moisture flux at the surface (kg/m^2/s)
-!-- gz1oz0 log(z/z0) where z0 is roughness length
!-- wspd wind speed at lowest model level (m/s)
!-- u10 u-wind speed at 10 m (m/s)
!-- v10 v-wind speed at 10 m (m/s)
@@ -115,40 +120,39 @@
!
real, dimension( ims:ime, kms:kme, jms:jme ) , &
intent(in ) :: qv3d, &
- qc3d, &
- qi3d, &
- p3d, &
- pi3d, &
- th3d, &
- t3d, &
- dz8w
+ qc3d, &
+ qi3d, &
+ p3d, &
+ pi3d, &
+ th3d, &
+ t3d, &
+ dz8w
real, dimension( ims:ime, kms:kme, jms:jme ) , &
intent(in ) :: p3di
!
real, dimension( ims:ime, kms:kme, jms:jme ) , &
intent(inout) :: rublten, &
- rvblten, &
- rthblten, &
- rqvblten, &
+ rvblten, &
+ rthblten, &
+ rqvblten, &
rqcblten
!
real, dimension( ims:ime, kms:kme, jms:jme ) , &
intent(inout) :: exch_h
real, dimension( ims:ime, jms:jme ) , &
- intent(in ) :: u10, &
+ intent(inout) :: u10, &
v10
!
real, dimension( ims:ime, jms:jme ) , &
intent(in ) :: xland, &
- hfx, &
+ hfx, &
qfx, &
br, &
psfc
real, dimension( ims:ime, jms:jme ) , &
intent(in ) :: &
psim, &
- psih, &
- gz1oz0
+ psih
real, dimension( ims:ime, jms:jme ) , &
intent(inout) :: znt, &
ust, &
@@ -182,6 +186,10 @@
!
real, optional, intent(in ) :: p_top
!
+ real, dimension( ims:ime, jms:jme ) , &
+ optional , &
+ intent(in ) :: ctopo, &
+ ctopo2
!local
integer :: i,j,k
real, dimension( its:ite, kts:kte*ndiff ) :: rqvbl2dt, &
@@ -193,6 +201,23 @@
dvsfc, &
dtsfc, &
dqsfc
+#if defined(non_hydrostatic_core) || defined(hydrostatic_core)
+!MPAS specific optional arguments for additional diagnostics (Laura Fowler = 2013-03-06):
+ real,intent(in),dimension(ims:ime,kms:kme,jms:jme),optional:: rho
+ real:: rho_d
+ real,intent(out),dimension(ims:ime,kms:kme,jms:jme),optional:: kzhout,kzmout,kzqout
+ do j = jts,jte
+ do k = kts,kte
+ do i = its,ite
+ kzhout(i,k,j) = 0.
+ kzmout(i,k,j) = 0.
+ kzqout(i,k,j) = 0.
+ enddo
+ enddo
+ enddo
+!MPAS specific end.
+#endif
+
!
qv2d(:,:) = 0.0
do j = jts,jte
@@ -204,6 +229,26 @@
pdhi(i,k) = mut(i,j)*znw(k) + p_top
enddo
enddo
+ elseif(present(rho)) then
+ 203 format(1x,i4,1x,i2,10(1x,e15.8))
+!For MPAS, we replace the hydrostatic pressures defined at theta and w points by
+!the dry hydrostatic pressures (Laura D. Fowler):
+ k = kte+1
+ do i = its,ite
+ pdhi(i,k) = p3di(i,k,j)
+ enddo
+ do k = kte,kts,-1
+ do i = its,ite
+ rho_d = rho(i,k,j) / (1. + qv3d(i,k,j))
+ if(k.le.kte) pdhi(i,k) = pdhi(i,k+1) + g*rho_d*dz8w(i,k,j)
+ enddo
+ enddo
+ do k = kts,kte
+ do i = its,ite
+ pdh(i,k) = 0.5*(pdhi(i,k) + pdhi(i,k+1))
+ enddo
+ enddo
+!MPAS specific end.
else
do k = kts,kte+1
do i = its,ite
@@ -241,7 +286,15 @@
,dt=dt,rcl=1.0,kpbl1d=kpbl2d(ims,j) &
,exch_hx=exch_h(ims,kms,j) &
,u10=u10(ims,j),v10=v10(ims,j) &
- ,gz1oz0=gz1oz0(ims,j) &
+#if defined(non_hydrostatic_core) || defined(hydrostatic_core)
+!MPAS specific optional arguments for additional diagnostics:
+ ,kzh=kzhout(ims,kms,j) &
+ ,kzm=kzmout(ims,kms,j) &
+ ,kzq=kzqout(ims,kms,j) &
+#endif
+#if ( ! NMM_CORE == 1 )
+ ,ctopo=ctopo(ims,j),ctopo2=ctopo2(ims,j) &
+#endif
,ids=ids,ide=ide, jds=jds,jde=jde, kds=kds,kde=kde &
,ims=ims,ime=ime, jms=jms,jme=jme, kms=kms,kme=kme &
,its=its,ite=ite, jts=jts,jte=jte, kts=kts,kte=kte )
@@ -270,12 +323,17 @@
dt,rcl,kpbl1d, &
exch_hx, &
u10,v10, &
- gz1oz0, &
+ ctopo,ctopo2, &
ids,ide, jds,jde, kds,kde, &
ims,ime, jms,jme, kms,kme, &
its,ite, jts,jte, kts,kte, &
!optional
- regime )
+ regime &
+#if defined(non_hydrostatic_core) || defined(hydrostatic_core)
+ !MPAS specific optional arguments for additional diagnostics:
+ ,kzh,kzm,kzq &
+#endif
+ )
!-------------------------------------------------------------------
implicit none
!-------------------------------------------------------------------
@@ -307,11 +365,21 @@
! pressure-level diffusion, april 2009
! ==> negligible differences
! implicit forcing for momentum with clean up, july 2009
-! ==> prevents model blownup when sfc layer is too low
-! increase of lamda, 30 < 0.1 x del z < 300, feb 2010
+! ==> prevents model blowup when sfc layer is too low
+! incresea of lamda, maximum (30, 0.1 x del z) feb 2010
! ==> prevents model blowup when delz is extremely large
! revised prandtl number at surface, peggy lemone, feb 2010
! ==> increase kh, decrease mixing due to counter-gradient term
+! revised thermal, shin et al. mon. wea. rev. , songyou hong, aug 2011
+! ==> reduce the thermal strength when z1 < 0.1 h
+! revised prandtl number for free convection, dudhia, mar 2012
+! ==> pr0 = 1 + bke (=0.272) when newtral, kh is reduced
+! minimum kzo = 0.01, lo = min (30m,delz), hong, mar 2012
+! ==> weaker mixing when stable, and les resolution in vertical
+! gz1oz0 is removed, and phim phih are ln(z1/z0)-phim,h, hong, mar 2012
+! ==> consider thermal z0 when differs from mechanical z0
+! a bug fix in wscale computation in stable bl, sukanta basu, jun 2012
+! ==> wscale becomes small with height, and less mixing in stable bl
!
! references:
!
@@ -324,7 +392,8 @@
!-------------------------------------------------------------------
!
real,parameter :: xkzmin = 0.01,xkzmax = 1000.,rimin = -100.
- real,parameter :: rlam = 30.,prmin = 0.25,prmax = 4.
+ real,parameter :: rlam = 150.,prmin = 0.25,prmax = 4.
+! real,parameter :: rlam = 30.,prmin = 0.25,prmax = 4.
real,parameter :: brcr_ub = 0.0,brcr_sb = 0.25,cori = 1.e-4
real,parameter :: afac = 6.8,bfac = 6.8,pfac = 2.0,pfac_q = 2.0
real,parameter :: phifac = 8.,sfcfrac = 0.1
@@ -382,7 +451,7 @@
!
real, dimension( ims:ime ), intent(in ) :: psim, &
psih
- real, dimension( ims:ime ), intent(in ) :: gz1oz0
+
!
real, dimension( ims:ime ), intent(in ) :: psfcpa
integer, dimension( ims:ime ), intent(out ) :: kpbl1d
@@ -390,9 +459,12 @@
real, dimension( ims:ime, kms:kme ) , &
intent(in ) :: ux, &
vx
-!optional
real, dimension( ims:ime ) , &
optional , &
+ intent(in ) :: ctopo, &
+ ctopo2
+ real, dimension( ims:ime ) , &
+ optional , &
intent(inout) :: regime
!
! local vars
@@ -400,29 +472,30 @@
real, dimension( its:ite ) :: hol
real, dimension( its:ite, kts:kte+1 ) :: zq
!
- real, dimension( its:ite, kts:kte ) :: &
+ real, dimension( its:ite, kts:kte ) :: &
thx,thvx, &
del, &
dza, &
dzq, &
+ xkzo, &
za
!
real, dimension( its:ite ) :: &
rhox, &
govrth, &
zl1,thermal, &
- wscale,hgamt, &
- hgamq,brdn, &
- brup,phim, &
- phih, &
+ wscale, &
+ hgamt,hgamq, &
+ brdn,brup, &
+ phim,phih, &
dusfc,dvsfc, &
dtsfc,dqsfc, &
prpbl, &
wspd1
!
real, dimension( its:ite, kts:kte ) :: xkzm,xkzh, &
- f1,f2, &
- r1,r2, &
+ f1,f2, &
+ r1,r2, &
ad,au, &
cu, &
al, &
@@ -433,8 +506,8 @@
real, dimension( ims:ime, kms:kme ) , &
intent(inout) :: exch_hx
!
- real, dimension( ims:ime ) , &
- intent(in ) :: u10, &
+ real, dimension( ims:ime ) , &
+ intent(inout) :: u10, &
v10
real, dimension( its:ite ) :: &
brcr, &
@@ -453,14 +526,15 @@
!
!
real :: dt2,rdt,spdk2,fm,fh,hol1,gamfac,vpert,prnum,prnum0
- real :: xkzo,ss,ri,qmean,tmean,alph,chi,zk,rl2,dk,sri
+ real :: ss,ri,qmean,tmean,alph,chi,zk,rl2,dk,sri
real :: brint,dtodsd,dtodsu,rdz,dsdzt,dsdzq,dsdz2,rlamdz
real :: utend,vtend,ttend,qtend
real :: dtstep,govrthv
real :: cont, conq, conw, conwrc
!
- real, dimension( its:ite, kts:kte ) :: wscalek, &
- xkzml,xkzhl, &
+ real, dimension( its:ite, kts:kte ) :: wscalek
+ real, dimension( its:ite ) :: delta
+ real, dimension( its:ite, kts:kte ) :: xkzml,xkzhl, &
zfacent,entfac
real, dimension( its:ite ) :: ust3, &
wstar3,wstar, &
@@ -469,10 +543,18 @@
bfxpbl, &
hfxpbl,qfxpbl, &
ufxpbl,vfxpbl, &
- delta,dthvx
+ dthvx, &
+ zol1
real :: prnumfac,bfx0,hfx0,qfx0,delb,dux,dvx, &
- dsdzu,dsdzv,wm3,dthx,dqx,wspd10,ross,tem1,dsig,tvcon,conpr,prfac
+ dsdzu,dsdzv,wm3,dthx,dqx,wspd10,ross,tem1,dsig,tvcon,conpr, &
+ prfac,prfac2,phim8z
!
+#if defined (non_hydrostatic_core) || defined(hydrostatic_core)
+!MPAS specific begin (Laura Fowler - 2013-03-01):
+ real,intent(out),dimension(ims:ime,kms:kme),optional::kzh,kzm,kzq
+!MPAS specific end.
+#endif
+
!----------------------------------------------------------------------
!
klpbl = kte
@@ -571,6 +653,20 @@
delta(i) = 0.0
enddo
!
+!MPAS specific begin (Laura Fowler - 2013-03-01): Added initialization of local
+!vertical diffusion coefficients:
+ if(present(kzh) .and. present(kzm) .and. present(kzq)) then
+ do k = kts,kte
+ do i = its,ite
+ xkzh(i,k) = 0.0
+ xkzm(i,k) = 0.0
+ xkzhl(i,k) = 0.0
+ xkzml(i,k) = 0.0
+ enddo
+ enddo
+ endif
+!MPAS specific end.
+!
do k = kts,klpbl
do i = its,ite
wscalek(i,k) = 0.0
@@ -582,6 +678,11 @@
zfac(i,k) = 0.0
enddo
enddo
+ do k = kts,klpbl-1
+ do i = its,ite
+ xkzo(i,k) = ckz*dza(i,k+1)
+ enddo
+ enddo
!
do i = its,ite
dusfc(i) = 0.
@@ -639,16 +740,15 @@
enddo
!
do i = its,ite
- fm = gz1oz0(i)-psim(i)
- fh = gz1oz0(i)-psih(i)
- hol(i) = max(br(i)*fm*fm/fh,rimin)
+ fm = psim(i)
+ fh = psih(i)
+ zol1(i) = max(br(i)*fm*fm/fh,rimin)
if(sfcflg(i))then
- hol(i) = min(hol(i),-zfmin)
+ zol1(i) = min(zol1(i),-zfmin)
else
- hol(i) = max(hol(i),zfmin)
+ zol1(i) = max(zol1(i),zfmin)
endif
- hol1 = hol(i)*hpbl(i)/zl1(i)*sfcfrac
- hol(i) = -hol(i)*hpbl(i)/zl1(i)
+ hol1 = zol1(i)*hpbl(i)/zl1(i)*sfcfrac
if(sfcflg(i))then
phim(i) = (1.-aphi16*hol1)**(-1./4.)
phih(i) = (1.-aphi16*hol1)**(-1./2.)
@@ -678,7 +778,7 @@
hgamt(i) = min(gamfac*hfx(i)/cp,gamcrt)
hgamq(i) = min(gamfac*qfx(i),gamcrq)
vpert = (hgamt(i)+ep1*thx(i,1)*hgamq(i))/bfac*afac
- thermal(i) = thermal(i)+max(vpert,0.)
+ thermal(i) = thermal(i)+max(vpert,0.)*min(za(i,1)/(sfcfrac*hpbl(i)),1.0)
hgamt(i) = max(hgamt(i),0.0)
hgamq(i) = max(hgamq(i),0.0)
brint = -15.9*ust(i)*ust(i)/wspd(i)*wstar3(i)/(wscale(i)**4.)
@@ -844,31 +944,34 @@
do i = its,ite
if(k.lt.kpbl(i)) then
zfac(i,k) = min(max((1.-(zq(i,k+1)-zl1(i))/(hpbl(i)-zl1(i))),zfmin),1.)
- xkzo = ckz*dza(i,k+1)
zfacent(i,k) = (1.-zfac(i,k))**3.
+ wscalek(i,k) = (ust3(i)+phifac*karman*wstar3(i)*(1.-zfac(i,k)))**h1
if(sfcflg(i)) then
- prfac = conpr/phim(i)/(1.+4.*karman*wstar3(i)/ust3(i))
+ prfac = conpr
+ prfac2 = 15.9*wstar3(i)/ust3(i)/(1.+4.*karman*wstar3(i)/ust3(i))
prnumfac = -3.*(max(zq(i,k+1)-sfcfrac*hpbl(i),0.))**2./hpbl(i)**2.
else
prfac = 0.
+ prfac2 = 0.
prnumfac = 0.
+ phim8z = 1.+aphi5*zol1(i)*zq(i,k+1)/zl1(i)
+ wscalek(i,k) = ust(i)/phim8z
+ wscalek(i,k) = max(wscalek(i,k),0.001)
endif
prnum0 = (phih(i)/phim(i)+prfac)
- prnum0 = min(prnum0,prmax)
- prnum0 = max(prnum0,prmin)
- wscalek(i,k) = (ust3(i)+phifac*karman*wstar3(i)*(1.-zfac(i,k)))**h1
- xkzm(i,k) = xkzo+wscalek(i,k)*karman*zq(i,k+1)*zfac(i,k)**pfac
+ prnum0 = max(min(prnum0,prmax),prmin)
+ xkzm(i,k) = wscalek(i,k)*karman*zq(i,k+1)*zfac(i,k)**pfac
prnum = 1. + (prnum0-1.)*exp(prnumfac)
xkzq(i,k) = xkzm(i,k)/prnum*zfac(i,k)**(pfac_q-pfac)
- prnum0 = prnum0/(1.+prfac)
+ prnum0 = prnum0/(1.+prfac2*karman*sfcfrac)
prnum = 1. + (prnum0-1.)*exp(prnumfac)
xkzh(i,k) = xkzm(i,k)/prnum
xkzm(i,k) = min(xkzm(i,k),xkzmax)
- xkzm(i,k) = max(xkzm(i,k),xkzmin)
+ xkzm(i,k) = max(xkzm(i,k),xkzo(i,k))
xkzh(i,k) = min(xkzh(i,k),xkzmax)
- xkzh(i,k) = max(xkzh(i,k),xkzmin)
+ xkzh(i,k) = max(xkzh(i,k),xkzo(i,k))
xkzq(i,k) = min(xkzq(i,k),xkzmax)
- xkzq(i,k) = max(xkzq(i,k),xkzmin)
+ xkzq(i,k) = max(xkzq(i,k),xkzo(i,k))
endif
enddo
enddo
@@ -877,7 +980,6 @@
!
do k = kts,kte-1
do i = its,ite
- xkzo = ckz*dza(i,k+1)
if(k.ge.kpbl(i)) then
ss = ((ux(i,k+1)-ux(i,k))*(ux(i,k+1)-ux(i,k)) &
+(vx(i,k+1)-vx(i,k))*(vx(i,k+1)-vx(i,k))) &
@@ -897,25 +999,26 @@
endif
zk = karman*zq(i,k+1)
rlamdz = min(max(0.1*dza(i,k+1),rlam),300.)
+ rlamdz = min(dza(i,k+1),rlamdz)
rl2 = (zk*rlamdz/(rlamdz+zk))**2
dk = rl2*sqrt(ss)
if(ri.lt.0.)then
! unstable regime
sri = sqrt(-ri)
- xkzm(i,k) = xkzo+dk*(1+8.*(-ri)/(1+1.746*sri))
- xkzh(i,k) = xkzo+dk*(1+8.*(-ri)/(1+1.286*sri))
+ xkzm(i,k) = dk*(1+8.*(-ri)/(1+1.746*sri))
+ xkzh(i,k) = dk*(1+8.*(-ri)/(1+1.286*sri))
else
! stable regime
- xkzh(i,k) = xkzo+dk/(1+5.*ri)**2
+ xkzh(i,k) = dk/(1+5.*ri)**2
prnum = 1.0+2.1*ri
prnum = min(prnum,prmax)
- xkzm(i,k) = (xkzh(i,k)-xkzo)*prnum+xkzo
+ xkzm(i,k) = xkzh(i,k)*prnum
endif
!
xkzm(i,k) = min(xkzm(i,k),xkzmax)
- xkzm(i,k) = max(xkzm(i,k),xkzmin)
+ xkzm(i,k) = max(xkzm(i,k),xkzo(i,k))
xkzh(i,k) = min(xkzh(i,k),xkzmax)
- xkzh(i,k) = max(xkzh(i,k),xkzmin)
+ xkzh(i,k) = max(xkzh(i,k),xkzo(i,k))
xkzml(i,k) = xkzm(i,k)
xkzhl(i,k) = xkzh(i,k)
endif
@@ -953,7 +1056,7 @@
xkzh(i,k) = -we(i)*dza(i,kpbl(i))*exp(-entfac(i,k))
xkzh(i,k) = sqrt(xkzh(i,k)*xkzhl(i,k))
xkzh(i,k) = min(xkzh(i,k),xkzmax)
- xkzh(i,k) = max(xkzh(i,k),xkzmin)
+ xkzh(i,k) = max(xkzh(i,k),xkzo(i,k))
f1(i,k+1) = thx(i,k+1)-300.
else
f1(i,k+1) = thx(i,k+1)-300.
@@ -989,7 +1092,7 @@
enddo
enddo
!
-! compute tridiagonal matrix elements for moisture, clouds, and tracers
+! compute tridiagonal matrix elements for moisture, clouds, and gases
!
do k = kts,kte
do i = its,ite
@@ -1044,7 +1147,7 @@
xkzq(i,k) = -we(i)*dza(i,kpbl(i))*exp(-entfac(i,k))
xkzq(i,k) = sqrt(xkzq(i,k)*xkzhl(i,k))
xkzq(i,k) = min(xkzq(i,k),xkzmax)
- xkzq(i,k) = max(xkzq(i,k),xkzmin)
+ xkzq(i,k) = max(xkzq(i,k),xkzo(i,k))
f3(i,k+1,1) = qx(i,k+1)
else
f3(i,k+1,1) = qx(i,k+1)
@@ -1086,7 +1189,7 @@
enddo
enddo
!
-! solve tridiagonal problem for moisture, clouds, and tracers
+! solve tridiagonal problem for moisture, clouds, and gases
!
call tridin_ysu(al,ad,cu,r3,au,f3,its,ite,kts,kte,ndiff)
!
@@ -1125,8 +1228,15 @@
enddo
!
do i = its,ite
- ad(i,1) = 1.+ust(i)**2/wspd1(i)*rhox(i)*g/del(i,1)*dt2 &
- *(wspd1(i)/wspd(i))**2
+! paj: ctopo=1 if topo_wind=0 (default)
+! mchen add this line to make sure NMM can still work with YSU PBL
+ if(present(ctopo)) then
+ ad(i,1) = 1.+ctopo(i)*ust(i)**2/wspd1(i)*rhox(i)*g/del(i,1)*dt2 &
+ *(wspd1(i)/wspd(i))**2
+ else
+ ad(i,1) = 1.+ust(i)**2/wspd1(i)*rhox(i)*g/del(i,1)*dt2 &
+ *(wspd1(i)/wspd(i))**2
+ endif
f1(i,1) = ux(i,1)
f2(i,1) = vx(i,1)
enddo
@@ -1149,7 +1259,7 @@
xkzm(i,k) = prpbl(i)*xkzh(i,k)
xkzm(i,k) = sqrt(xkzm(i,k)*xkzml(i,k))
xkzm(i,k) = min(xkzm(i,k),xkzmax)
- xkzm(i,k) = max(xkzm(i,k),xkzmin)
+ xkzm(i,k) = max(xkzm(i,k),xkzo(i,k))
f1(i,k+1) = ux(i,k+1)
f2(i,k+1) = vx(i,k+1)
else
@@ -1192,12 +1302,33 @@
enddo
enddo
!
+! paj: ctopo2=1 if topo_wind=0 (default)
+!
+ do i = its,ite
+ if(present(ctopo).and.present(ctopo2)) then ! mchen for NMM
+ u10(i) = ctopo2(i)*u10(i)+(1-ctopo2(i))*ux(i,1)
+ v10(i) = ctopo2(i)*v10(i)+(1-ctopo2(i))*vx(i,1)
+ endif !mchen
+ enddo
+!
!---- end of vertical diffusion
!
do i = its,ite
kpbl1d(i) = kpbl(i)
enddo
!
+!MPAS specific begin (Laura D. Fowler - 2013-03-01)::
+ if(present(kzh) .and. present(kzm) .and. present(kzq)) then
+ do i = its,ite
+ do k = kts,kte
+ kzh(i,k) = xkzh(i,k)
+ kzm(i,k) = xkzm(i,k)
+ kzq(i,k) = xkzq(i,k)
+ enddo
+ enddo
+ endif
+!MPAS specific end.
+
end subroutine ysu2d
!
subroutine tridi1n(cl,cm,cu,r1,r2,au,f1,f2,its,ite,kts,kte,nt)
Modified: trunk/mpas/src/core_atmos_physics/physics_wrf/module_cu_tiedtke.F
===================================================================
--- trunk/mpas/src/core_atmos_physics/physics_wrf/module_cu_tiedtke.F 2013-03-27 19:24:59 UTC (rev 2673)
+++ trunk/mpas/src/core_atmos_physics/physics_wrf/module_cu_tiedtke.F 2013-03-27 19:26:14 UTC (rev 2674)
@@ -63,7 +63,7 @@
VTMPC1=RV/RD-1.0, &
VTMPC2=CPV/CPD-1.0, &
CVDIFTS=1.0, &
- CEVAPCU1=1.93E-6*261., &
+ CEVAPCU1=1.93E-6*261.0*0.5/G, & ! Correction from WRFV3.4.1 sourcecode.
CEVAPCU2=1.E3/(38.3*0.293) )
Added: trunk/mpas/src/core_atmos_physics/physics_wrf/module_mp_radar.F
===================================================================
--- trunk/mpas/src/core_atmos_physics/physics_wrf/module_mp_radar.F (rev 0)
+++ trunk/mpas/src/core_atmos_physics/physics_wrf/module_mp_radar.F 2013-03-27 19:26:14 UTC (rev 2674)
@@ -0,0 +1,685 @@
+!+---+-----------------------------------------------------------------+
+!..This set of routines facilitates computing radar reflectivity.
+!.. This module is more library code whereas the individual microphysics
+!.. schemes contains specific details needed for the final computation,
+!.. so refer to location within each schemes calling the routine named
+!.. rayleigh_soak_wetgraupel.
+!.. The bulk of this code originated from Ulrich Blahak (Germany) and
+!.. was adapted to WRF by G. Thompson. This version of code is only
+!.. intended for use when Rayleigh scattering principles dominate and
+!.. is not intended for wavelengths in which Mie scattering is a
+!.. significant portion. Therefore, it is well-suited to use with
+!.. 5 or 10 cm wavelength like USA NEXRAD radars.
+!.. This code makes some rather simple assumptions about water
+!.. coating on outside of frozen species (snow/graupel). Fraction of
+!.. meltwater is simply the ratio of mixing ratio below melting level
+!.. divided by mixing ratio at level just above highest T>0C. Also,
+!.. immediately 90% of the melted water exists on the ice's surface
+!.. and 10% is embedded within ice. No water is "shed" at all in these
+!.. assumptions. The code is quite slow because it does the reflectivity
+!.. calculations based on 50 individual size bins of the distributions.
+!+---+-----------------------------------------------------------------+
+
+MODULE module_mp_radar
+
+#if defined(non_hydrostatic_core) || defined(hydrostatic_core)
+ USE mpas_atmphys_utilities
+#else
+ USE module_wrf_error
+#endif
+
+ PUBLIC :: rayleigh_soak_wetgraupel
+ PUBLIC :: radar_init
+ PRIVATE :: m_complex_water_ray
+ PRIVATE :: m_complex_ice_maetzler
+ PRIVATE :: m_complex_maxwellgarnett
+ PRIVATE :: get_m_mix_nested
+ PRIVATE :: get_m_mix
+ PRIVATE :: WGAMMA
+ PRIVATE :: GAMMLN
+
+
+ INTEGER, PARAMETER, PUBLIC:: nrbins = 50
+ DOUBLE PRECISION, DIMENSION(nrbins+1), PUBLIC:: xxDx
+ DOUBLE PRECISION, DIMENSION(nrbins), PUBLIC:: xxDs,xdts,xxDg,xdtg
+ DOUBLE PRECISION, PARAMETER, PUBLIC:: lamda_radar = 0.10 ! in meters
+ DOUBLE PRECISION, PUBLIC:: K_w, PI5, lamda4
+ COMPLEX*16, PUBLIC:: m_w_0, m_i_0
+ DOUBLE PRECISION, DIMENSION(nrbins+1), PUBLIC:: simpson
+ DOUBLE PRECISION, DIMENSION(3), PARAMETER, PUBLIC:: basis = &
+ (/1.d0/3.d0, 4.d0/3.d0, 1.d0/3.d0/)
+ REAL, DIMENSION(4), PUBLIC:: xcre, xcse, xcge, xcrg, xcsg, xcgg
+ REAL, PUBLIC:: xam_r, xbm_r, xmu_r, xobmr
+ REAL, PUBLIC:: xam_s, xbm_s, xmu_s, xoams, xobms, xocms
+ REAL, PUBLIC:: xam_g, xbm_g, xmu_g, xoamg, xobmg, xocmg
+ REAL, PUBLIC:: xorg2, xosg2, xogg2
+
+ INTEGER, PARAMETER, PUBLIC:: slen = 20
+ CHARACTER(len=slen), PUBLIC:: &
+ mixingrulestring_s, matrixstring_s, inclusionstring_s, &
+ hoststring_s, hostmatrixstring_s, hostinclusionstring_s, &
+ mixingrulestring_g, matrixstring_g, inclusionstring_g, &
+ hoststring_g, hostmatrixstring_g, hostinclusionstring_g
+
+!..Single melting snow/graupel particle 90% meltwater on external sfc
+ DOUBLE PRECISION, PARAMETER:: melt_outside_s = 0.9d0
+ DOUBLE PRECISION, PARAMETER:: melt_outside_g = 0.9d0
+
+ CHARACTER*256:: radar_debug
+
+CONTAINS
+
+!+---+-----------------------------------------------------------------+
+!+---+-----------------------------------------------------------------+
+!+---+-----------------------------------------------------------------+
+
+ subroutine radar_init
+
+ IMPLICIT NONE
+ INTEGER:: n
+ PI5 = 3.14159*3.14159*3.14159*3.14159*3.14159
+ lamda4 = lamda_radar*lamda_radar*lamda_radar*lamda_radar
+ m_w_0 = m_complex_water_ray (lamda_radar, 0.0d0)
+ m_i_0 = m_complex_ice_maetzler (lamda_radar, 0.0d0)
+ K_w = (ABS( (m_w_0*m_w_0 - 1.0) /(m_w_0*m_w_0 + 2.0) ))**2
+
+ do n = 1, nrbins+1
+ simpson(n) = 0.0d0
+ enddo
+ do n = 1, nrbins-1, 2
+ simpson(n) = simpson(n) + basis(1)
+ simpson(n+1) = simpson(n+1) + basis(2)
+ simpson(n+2) = simpson(n+2) + basis(3)
+ enddo
+
+ do n = 1, slen
+ mixingrulestring_s(n:n) = char(0)
+ matrixstring_s(n:n) = char(0)
+ inclusionstring_s(n:n) = char(0)
+ hoststring_s(n:n) = char(0)
+ hostmatrixstring_s(n:n) = char(0)
+ hostinclusionstring_s(n:n) = char(0)
+ mixingrulestring_g(n:n) = char(0)
+ matrixstring_g(n:n) = char(0)
+ inclusionstring_g(n:n) = char(0)
+ hoststring_g(n:n) = char(0)
+ hostmatrixstring_g(n:n) = char(0)
+ hostinclusionstring_g(n:n) = char(0)
+ enddo
+
+ mixingrulestring_s = 'maxwellgarnett'
+ hoststring_s = 'air'
+ matrixstring_s = 'water'
+ inclusionstring_s = 'spheroidal'
+ hostmatrixstring_s = 'icewater'
+ hostinclusionstring_s = 'spheroidal'
+
+ mixingrulestring_g = 'maxwellgarnett'
+ hoststring_g = 'air'
+ matrixstring_g = 'water'
+ inclusionstring_g = 'spheroidal'
+ hostmatrixstring_g = 'icewater'
+ hostinclusionstring_g = 'spheroidal'
+
+!..Create bins of snow (from 100 microns up to 2 cm).
+ xxDx(1) = 100.D-6
+ xxDx(nrbins+1) = 0.02d0
+ do n = 2, nrbins
+ xxDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nrbins) &
+ *DLOG(xxDx(nrbins+1)/xxDx(1)) +DLOG(xxDx(1)))
+ enddo
+ do n = 1, nrbins
+ xxDs(n) = DSQRT(xxDx(n)*xxDx(n+1))
+ xdts(n) = xxDx(n+1) - xxDx(n)
+ enddo
+
+!..Create bins of graupel (from 100 microns up to 5 cm).
+ xxDx(1) = 100.D-6
+ xxDx(nrbins+1) = 0.05d0
+ do n = 2, nrbins
+ xxDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nrbins) &
+ *DLOG(xxDx(nrbins+1)/xxDx(1)) +DLOG(xxDx(1)))
+ enddo
+ do n = 1, nrbins
+ xxDg(n) = DSQRT(xxDx(n)*xxDx(n+1))
+ xdtg(n) = xxDx(n+1) - xxDx(n)
+ enddo
+
+
+!..The calling program must set the m(D) relations and gamma shape
+!.. parameter mu for rain, snow, and graupel. Easily add other types
+!.. based on the template here. For majority of schemes with simpler
+!.. exponential number distribution, mu=0.
+
+ xcre(1) = 1. + xbm_r
+ xcre(2) = 1. + xmu_r
+ xcre(3) = 4. + xmu_r
+ xcre(4) = 7. + xmu_r
+ do n = 1, 4
+ xcrg(n) = WGAMMA(xcre(n))
+ enddo
+ xorg2 = 1./xcrg(2)
+
+ xcse(1) = 1. + xbm_s
+ xcse(2) = 1. + xmu_s
+ xcse(3) = 4. + xmu_s
+ xcse(4) = 7. + xmu_s
+ do n = 1, 4
+ xcsg(n) = WGAMMA(xcse(n))
+ enddo
+ xosg2 = 1./xcsg(2)
+
+ xcge(1) = 1. + xbm_g
+ xcge(2) = 1. + xmu_g
+ xcge(3) = 4. + xmu_g
+ xcge(4) = 7. + xmu_g
+ do n = 1, 4
+ xcgg(n) = WGAMMA(xcge(n))
+ enddo
+ xogg2 = 1./xcgg(2)
+
+ xobmr = 1./xbm_r
+ xoams = 1./xam_s
+ xobms = 1./xbm_s
+ xocms = xoams**xobms
+ xoamg = 1./xam_g
+ xobmg = 1./xbm_g
+ xocmg = xoamg**xobmg
+
+
+ end subroutine radar_init
+
+!+---+-----------------------------------------------------------------+
+!+---+-----------------------------------------------------------------+
+
+ COMPLEX*16 FUNCTION m_complex_water_ray(lambda,T)
+
+! Complex refractive Index of Water as function of Temperature T
+! [deg C] and radar wavelength lambda [m]; valid for
+! lambda in [0.001,1.0] m; T in [-10.0,30.0] deg C
+! after Ray (1972)
+
+ IMPLICIT NONE
+ DOUBLE PRECISION, INTENT(IN):: T,lambda
+ DOUBLE PRECISION:: epsinf,epss,epsr,epsi
+ DOUBLE PRECISION:: alpha,lambdas,sigma,nenner
+ COMPLEX*16, PARAMETER:: i = (0d0,1d0)
+ DOUBLE PRECISION, PARAMETER:: PIx=3.1415926535897932384626434d0
+
+ epsinf = 5.27137d0 + 0.02164740d0 * T - 0.00131198d0 * T*T
+ epss = 78.54d+0 * (1.0 - 4.579d-3 * (T - 25.0) &
+ + 1.190d-5 * (T - 25.0)*(T - 25.0) &
+ - 2.800d-8 * (T - 25.0)*(T - 25.0)*(T - 25.0))
+ alpha = -16.8129d0/(T+273.16) + 0.0609265d0
+ lambdas = 0.00033836d0 * exp(2513.98d0/(T+273.16)) * 1e-2
+
+ nenner = 1.d0+2.d0*(lambdas/lambda)**(1d0-alpha)*sin(alpha*PIx*0.5) &
+ + (lambdas/lambda)**(2d0-2d0*alpha)
+ epsr = epsinf + ((epss-epsinf) * ((lambdas/lambda)**(1d0-alpha) &
+ * sin(alpha*PIx*0.5)+1d0)) / nenner
+ epsi = ((epss-epsinf) * ((lambdas/lambda)**(1d0-alpha) &
+ * cos(alpha*PIx*0.5)+0d0)) / nenner &
+ + lambda*1.25664/1.88496
+
+ m_complex_water_ray = SQRT(CMPLX(epsr,-epsi))
+
+ END FUNCTION m_complex_water_ray
+
+!+---+-----------------------------------------------------------------+
+
+ COMPLEX*16 FUNCTION m_complex_ice_maetzler(lambda,T)
+
+! complex refractive index of ice as function of Temperature T
+! [deg C] and radar wavelength lambda [m]; valid for
+! lambda in [0.0001,30] m; T in [-250.0,0.0] C
+! Original comment from the Matlab-routine of Prof. Maetzler:
+! Function for calculating the relative permittivity of pure ice in
+! the microwave region, according to C. Maetzler, "Microwave
+! properties of ice and snow", in B. Schmitt et al. (eds.) Solar
+! System Ices, Astrophys. and Space Sci. Library, Vol. 227, Kluwer
+! Academic Publishers, Dordrecht, pp. 241-257 (1998). Input:
+! TK = temperature (K), range 20 to 273.15
+! f = frequency in GHz, range 0.01 to 3000
+
+ IMPLICIT NONE
+ DOUBLE PRECISION, INTENT(IN):: T,lambda
+ DOUBLE PRECISION:: f,c,TK,B1,B2,b,deltabeta,betam,beta,theta,alfa
+
+ c = 2.99d8
+ TK = T + 273.16
+ f = c / lambda * 1d-9
+
+ B1 = 0.0207
+ B2 = 1.16d-11
+ b = 335.0d0
+ deltabeta = EXP(-10.02 + 0.0364*(TK-273.16))
+ betam = (B1/TK) * ( EXP(b/TK) / ((EXP(b/TK)-1)**2) ) + B2*f*f
+ beta = betam + deltabeta
+ theta = 300. / TK - 1.
+ alfa = (0.00504d0 + 0.0062d0*theta) * EXP(-22.1d0*theta)
+ m_complex_ice_maetzler = 3.1884 + 9.1e-4*(TK-273.16)
+ m_complex_ice_maetzler = m_complex_ice_maetzler &
+ + CMPLX(0.0d0, (alfa/f + beta*f))
+ m_complex_ice_maetzler = SQRT(CONJG(m_complex_ice_maetzler))
+
+ END FUNCTION m_complex_ice_maetzler
+
+!+---+-----------------------------------------------------------------+
+
+ subroutine rayleigh_soak_wetgraupel (x_g, a_geo, b_geo, fmelt, &
+ meltratio_outside, m_w, m_i, lambda, C_back, &
+ mixingrule,matrix,inclusion, &
+ host,hostmatrix,hostinclusion)
+
+ IMPLICIT NONE
+
+ DOUBLE PRECISION, INTENT(in):: x_g, a_geo, b_geo, fmelt, lambda, &
+ meltratio_outside
+ DOUBLE PRECISION, INTENT(out):: C_back
+ COMPLEX*16, INTENT(in):: m_w, m_i
+ CHARACTER(len=*), INTENT(in):: mixingrule, matrix, inclusion, &
+ host, hostmatrix, hostinclusion
+
+ COMPLEX*16:: m_core, m_air
+ DOUBLE PRECISION:: D_large, D_g, rhog, x_w, xw_a, fm, fmgrenz, &
+ volg, vg, volair, volice, volwater, &
+ meltratio_outside_grenz, mra
+ INTEGER:: error
+ DOUBLE PRECISION, PARAMETER:: PIx=3.1415926535897932384626434d0
+
+! refractive index of air:
+ m_air = (1.0d0,0.0d0)
+
+! Limiting the degree of melting --- for safety:
+ fm = DMAX1(DMIN1(fmelt, 1.0d0), 0.0d0)
+! Limiting the ratio of (melting on outside)/(melting on inside):
+ mra = DMAX1(DMIN1(meltratio_outside, 1.0d0), 0.0d0)
+
+! ! The relative portion of meltwater melting at outside should increase
+! ! from the given input value (between 0 and 1)
+! ! to 1 as the degree of melting approaches 1,
+! ! so that the melting particle "converges" to a water drop.
+! ! Simplest assumption is linear:
+ mra = mra + (1.0d0-mra)*fm
+
+ x_w = x_g * fm
+
+ D_g = a_geo * x_g**b_geo
+
+ if (D_g .ge. 1d-12) then
+
+ vg = PIx/6. * D_g**3
+ rhog = DMAX1(DMIN1(x_g / vg, 900.0d0), 10.0d0)
+ vg = x_g / rhog
+
+ meltratio_outside_grenz = 1.0d0 - rhog / 1000.
+
+ if (mra .le. meltratio_outside_grenz) then
+ !..In this case, it cannot happen that, during melting, all the
+ !.. air inclusions within the ice particle get filled with
+ !.. meltwater. This only happens at the end of all melting.
+ volg = vg * (1.0d0 - mra * fm)
+
+ else
+ !..In this case, at some melting degree fm, all the air
+ !.. inclusions get filled with meltwater.
+ fmgrenz=(900.0-rhog)/(mra*900.0-rhog+900.0*rhog/1000.)
+
+ if (fm .le. fmgrenz) then
+ !.. not all air pockets are filled:
+ volg = (1.0 - mra * fm) * vg
+ else
+ !..all air pockets are filled with meltwater, now the
+ !.. entire ice sceleton melts homogeneously:
+ volg = (x_g - x_w) / 900.0 + x_w / 1000.
+ endif
+
+ endif
+
+ D_large = (6.0 / PIx * volg) ** (1./3.)
+ volice = (x_g - x_w) / (volg * 900.0)
+ volwater = x_w / (1000. * volg)
+ volair = 1.0 - volice - volwater
+
+ !..complex index of refraction for the ice-air-water mixture
+ !.. of the particle:
+ m_core = get_m_mix_nested (m_air, m_i, m_w, volair, volice, &
+ volwater, mixingrule, host, matrix, inclusion, &
+ hostmatrix, hostinclusion, error)
+ if (error .ne. 0) then
+ C_back = 0.0d0
+ return
+ endif
+
+ !..Rayleigh-backscattering coefficient of melting particle:
+ C_back = (ABS((m_core**2-1.0d0)/(m_core**2+2.0d0)))**2 &
+ * PI5 * D_large**6 / lamda4
+
+ else
+ C_back = 0.0d0
+ endif
+
+ end subroutine rayleigh_soak_wetgraupel
+
+!+---+-----------------------------------------------------------------+
+
+ complex*16 function get_m_mix_nested (m_a, m_i, m_w, volair, &
+ volice, volwater, mixingrule, host, matrix, &
+ inclusion, hostmatrix, hostinclusion, cumulerror)
+
+ IMPLICIT NONE
+
+ DOUBLE PRECISION, INTENT(in):: volice, volair, volwater
+ COMPLEX*16, INTENT(in):: m_a, m_i, m_w
+ CHARACTER(len=*), INTENT(in):: mixingrule, host, matrix, &
+ inclusion, hostmatrix, hostinclusion
+ INTEGER, INTENT(out):: cumulerror
+
+ DOUBLE PRECISION:: vol1, vol2
+ COMPLEX*16:: mtmp
+ INTEGER:: error
+
+ !..Folded: ( (m1 + m2) + m3), where m1,m2,m3 could each be
+ !.. air, ice, or water
+
+ cumulerror = 0
+ get_m_mix_nested = CMPLX(1.0d0,0.0d0)
+
+ if (host .eq. 'air') then
+
+ if (matrix .eq. 'air') then
+ write(radar_debug,*) 'GET_M_MIX_NESTED: bad matrix: ', matrix
+#if defined(non_hydrostatic_core) | defined(hydrostatic_core)
+ call physics_message(radar_debug)
+#else
+ CALL wrf_debug(150, radar_debug)
+#endif
+ cumulerror = cumulerror + 1
+ else
+ vol1 = volice / MAX(volice+volwater,1d-10)
+ vol2 = 1.0d0 - vol1
+ mtmp = get_m_mix (m_a, m_i, m_w, 0.0d0, vol1, vol2, &
+ mixingrule, matrix, inclusion, error)
+ cumulerror = cumulerror + error
+
+ if (hostmatrix .eq. 'air') then
+ get_m_mix_nested = get_m_mix (m_a, mtmp, 2.0*m_a, &
+ volair, (1.0d0-volair), 0.0d0, mixingrule, &
+ hostmatrix, hostinclusion, error)
+ cumulerror = cumulerror + error
+ elseif (hostmatrix .eq. 'icewater') then
+ get_m_mix_nested = get_m_mix (m_a, mtmp, 2.0*m_a, &
+ volair, (1.0d0-volair), 0.0d0, mixingrule, &
+ 'ice', hostinclusion, error)
+ cumulerror = cumulerror + error
+ else
+ write(radar_debug,*) 'GET_M_MIX_NESTED: bad hostmatrix: ', &
+ hostmatrix
+#if defined(non_hydrostatic_core) | defined(hydrostatic_core)
+ call physics_message(radar_debug)
+#else
+ CALL wrf_debug(150, radar_debug)
+#endif
+ cumulerror = cumulerror + 1
+ endif
+ endif
+
+ elseif (host .eq. 'ice') then
+
+ if (matrix .eq. 'ice') then
+ write(radar_debug,*) 'GET_M_MIX_NESTED: bad matrix: ', matrix
+#if defined(non_hydrostatic_core) | defined(hydrostatic_core)
+ call physics_message(radar_debug)
+#else
+ CALL wrf_debug(150, radar_debug)
+#endif
+ cumulerror = cumulerror + 1
+ else
+ vol1 = volair / MAX(volair+volwater,1d-10)
+ vol2 = 1.0d0 - vol1
+ mtmp = get_m_mix (m_a, m_i, m_w, vol1, 0.0d0, vol2, &
+ mixingrule, matrix, inclusion, error)
+ cumulerror = cumulerror + error
+
+ if (hostmatrix .eq. 'ice') then
+ get_m_mix_nested = get_m_mix (mtmp, m_i, 2.0*m_a, &
+ (1.0d0-volice), volice, 0.0d0, mixingrule, &
+ hostmatrix, hostinclusion, error)
+ cumulerror = cumulerror + error
+ elseif (hostmatrix .eq. 'airwater') then
+ get_m_mix_nested = get_m_mix (mtmp, m_i, 2.0*m_a, &
+ (1.0d0-volice), volice, 0.0d0, mixingrule, &
+ 'air', hostinclusion, error)
+ cumulerror = cumulerror + error
+ else
+ write(radar_debug,*) 'GET_M_MIX_NESTED: bad hostmatrix: ', &
+ hostmatrix
+#if defined(non_hydrostatic_core) | defined(hydrostatic_core)
+ call physics_message(radar_debug)
+#else
+ CALL wrf_debug(150, radar_debug)
+#endif
+ cumulerror = cumulerror + 1
+ endif
+ endif
+
+ elseif (host .eq. 'water') then
+
+ if (matrix .eq. 'water') then
+ write(radar_debug,*) 'GET_M_MIX_NESTED: bad matrix: ', matrix
+#if defined(non_hydrostatic_core) | defined(hydrostatic_core)
+ call physics_message(radar_debug)
+#else
+ CALL wrf_debug(150, radar_debug)
+#endif
+ cumulerror = cumulerror + 1
+ else
+ vol1 = volair / MAX(volice+volair,1d-10)
+ vol2 = 1.0d0 - vol1
+ mtmp = get_m_mix (m_a, m_i, m_w, vol1, vol2, 0.0d0, &
+ mixingrule, matrix, inclusion, error)
+ cumulerror = cumulerror + error
+
+ if (hostmatrix .eq. 'water') then
+ get_m_mix_nested = get_m_mix (2*m_a, mtmp, m_w, &
+ 0.0d0, (1.0d0-volwater), volwater, mixingrule, &
+ hostmatrix, hostinclusion, error)
+ cumulerror = cumulerror + error
+ elseif (hostmatrix .eq. 'airice') then
+ get_m_mix_nested = get_m_mix (2*m_a, mtmp, m_w, &
+ 0.0d0, (1.0d0-volwater), volwater, mixingrule, &
+ 'ice', hostinclusion, error)
+ cumulerror = cumulerror + error
+ else
+ write(radar_debug,*) 'GET_M_MIX_NESTED: bad hostmatrix: ', &
+ hostmatrix
+#if defined(non_hydrostatic_core) | defined(hydrostatic_core)
+ call physics_message(radar_debug)
+#else
+ CALL wrf_debug(150, radar_debug)
+#endif
+ cumulerror = cumulerror + 1
+ endif
+ endif
+
+ elseif (host .eq. 'none') then
+
+ get_m_mix_nested = get_m_mix (m_a, m_i, m_w, &
+ volair, volice, volwater, mixingrule, &
+ matrix, inclusion, error)
+ cumulerror = cumulerror + error
+
+ else
+ write(radar_debug,*) 'GET_M_MIX_NESTED: unknown matrix: ', host
+#if defined(non_hydrostatic_core) | defined(hydrostatic_core)
+ call physics_message(radar_debug)
+#else
+ CALL wrf_debug(150, radar_debug)
+#endif
+ cumulerror = cumulerror + 1
+ endif
+
+ IF (cumulerror .ne. 0) THEN
+ write(radar_debug,*) 'GET_M_MIX_NESTED: error encountered'
+#if defined(non_hydrostatic_core) | defined(hydrostatic_core)
+ call physics_message(radar_debug)
+#else
+ CALL wrf_debug(150, radar_debug)
+#endif
+ get_m_mix_nested = CMPLX(1.0d0,0.0d0)
+ endif
+
+ end function get_m_mix_nested
+
+!+---+-----------------------------------------------------------------+
+
+ COMPLEX*16 FUNCTION get_m_mix (m_a, m_i, m_w, volair, volice, &
+ volwater, mixingrule, matrix, inclusion, error)
+
+ IMPLICIT NONE
+
+ DOUBLE PRECISION, INTENT(in):: volice, volair, volwater
+ COMPLEX*16, INTENT(in):: m_a, m_i, m_w
+ CHARACTER(len=*), INTENT(in):: mixingrule, matrix, inclusion
+ INTEGER, INTENT(out):: error
+
+ error = 0
+ get_m_mix = CMPLX(1.0d0,0.0d0)
+
+ if (mixingrule .eq. 'maxwellgarnett') then
+ if (matrix .eq. 'ice') then
+ get_m_mix = m_complex_maxwellgarnett(volice, volair, volwater, &
+ m_i, m_a, m_w, inclusion, error)
+ elseif (matrix .eq. 'water') then
+ get_m_mix = m_complex_maxwellgarnett(volwater, volair, volice, &
+ m_w, m_a, m_i, inclusion, error)
+ elseif (matrix .eq. 'air') then
+ get_m_mix = m_complex_maxwellgarnett(volair, volwater, volice, &
+ m_a, m_w, m_i, inclusion, error)
+ else
+ write(radar_debug,*) 'GET_M_MIX: unknown matrix: ', matrix
+#if defined(non_hydrostatic_core) | defined(hydrostatic_core)
+ call physics_message(radar_debug)
+#else
+ CALL wrf_debug(150, radar_debug)
+#endif
+ error = 1
+ endif
+
+ else
+ write(radar_debug,*) 'GET_M_MIX: unknown mixingrule: ', mixingrule
+#if defined(non_hydrostatic_core) | defined(hydrostatic_core)
+ call physics_message(radar_debug)
+#else
+ CALL wrf_debug(150, radar_debug)
+#endif
+ error = 2
+ endif
+
+ if (error .ne. 0) then
+ write(radar_debug,*) 'GET_M_MIX: error encountered'
+#if defined(non_hydrostatic_core) | defined(hydrostatic_core)
+ call physics_message(radar_debug)
+#else
+ CALL wrf_debug(150, radar_debug)
+#endif
+ endif
+
+ END FUNCTION get_m_mix
+
+!+---+-----------------------------------------------------------------+
+
+ COMPLEX*16 FUNCTION m_complex_maxwellgarnett(vol1, vol2, vol3, &
+ m1, m2, m3, inclusion, error)
+
+ IMPLICIT NONE
+
+ COMPLEX*16 :: m1, m2, m3
+ DOUBLE PRECISION :: vol1, vol2, vol3
+ CHARACTER(len=*) :: inclusion
+
+ COMPLEX*16 :: beta2, beta3, m1t, m2t, m3t
+ INTEGER, INTENT(out) :: error
+
+ error = 0
+
+ if (DABS(vol1+vol2+vol3-1.0d0) .gt. 1d-6) then
+ write(radar_debug,*) 'M_COMPLEX_MAXWELLGARNETT: sum of the ', &
+ 'partial volume fractions is not 1...ERROR'
+#if defined(non_hydrostatic_core) | defined(hydrostatic_core)
+ call physics_message(radar_debug)
+#else
+ CALL wrf_debug(150, radar_debug)
+#endif
+ m_complex_maxwellgarnett=CMPLX(-999.99d0,-999.99d0)
+ error = 1
+ return
+ endif
+
+ m1t = m1**2
+ m2t = m2**2
+ m3t = m3**2
+
+ if (inclusion .eq. 'spherical') then
+ beta2 = 3.0d0*m1t/(m2t+2.0d0*m1t)
+ beta3 = 3.0d0*m1t/(m3t+2.0d0*m1t)
+ elseif (inclusion .eq. 'spheroidal') then
+ beta2 = 2.0d0*m1t/(m2t-m1t) * (m2t/(m2t-m1t)*LOG(m2t/m1t)-1.0d0)
+ beta3 = 2.0d0*m1t/(m3t-m1t) * (m3t/(m3t-m1t)*LOG(m3t/m1t)-1.0d0)
+ else
+ write(radar_debug,*) 'M_COMPLEX_MAXWELLGARNETT: ', &
+ 'unknown inclusion: ', inclusion
+#if defined(non_hydrostatic_core) | defined(hydrostatic_core)
+ call physics_message(radar_debug)
+#else
+ CALL wrf_debug(150, radar_debug)
+#endif
+ m_complex_maxwellgarnett=DCMPLX(-999.99d0,-999.99d0)
+ error = 1
+ return
+ endif
+
+ m_complex_maxwellgarnett = &
+ SQRT(((1.0d0-vol2-vol3)*m1t + vol2*beta2*m2t + vol3*beta3*m3t) / &
+ (1.0d0-vol2-vol3+vol2*beta2+vol3*beta3))
+
+ END FUNCTION m_complex_maxwellgarnett
+
+!+---+-----------------------------------------------------------------+
+ REAL FUNCTION GAMMLN(XX)
+! --- RETURNS THE VALUE LN(GAMMA(XX)) FOR XX > 0.
+ IMPLICIT NONE
+ REAL, INTENT(IN):: XX
+ DOUBLE PRECISION, PARAMETER:: STP = 2.5066282746310005D0
+ DOUBLE PRECISION, DIMENSION(6), PARAMETER:: &
+ COF = (/76.18009172947146D0, -86.50532032941677D0, &
+ 24.01409824083091D0, -1.231739572450155D0, &
+ .1208650973866179D-2, -.5395239384953D-5/)
+ DOUBLE PRECISION:: SER,TMP,X,Y
+ INTEGER:: J
+
+ X=XX
+ Y=X
+ TMP=X+5.5D0
+ TMP=(X+0.5D0)*LOG(TMP)-TMP
+ SER=1.000000000190015D0
+ DO 11 J=1,6
+ Y=Y+1.D0
+ SER=SER+COF(J)/Y
+11 CONTINUE
+ GAMMLN=TMP+LOG(STP*SER/X)
+ END FUNCTION GAMMLN
+! (C) Copr. 1986-92 Numerical Recipes Software 2.02
+!+---+-----------------------------------------------------------------+
+ REAL FUNCTION WGAMMA(y)
+
+ IMPLICIT NONE
+ REAL, INTENT(IN):: y
+
+ WGAMMA = EXP(GAMMLN(y))
+
+ END FUNCTION WGAMMA
+
+!+---+-----------------------------------------------------------------+
+END MODULE module_mp_radar
+!+---+-----------------------------------------------------------------+
Modified: trunk/mpas/src/core_atmos_physics/physics_wrf/module_mp_wsm6.F
===================================================================
--- trunk/mpas/src/core_atmos_physics/physics_wrf/module_mp_wsm6.F 2013-03-27 19:24:59 UTC (rev 2673)
+++ trunk/mpas/src/core_atmos_physics/physics_wrf/module_mp_wsm6.F 2013-03-27 19:26:14 UTC (rev 2674)
@@ -8,6 +8,13 @@
MODULE module_mp_wsm6
!
+!#if defined(non_hydrostatic_core) || defined(hydrostatic_code)
+! USE mpas_atmphys_utilities
+!#else
+! USE module_utility, ONLY: WRFU_Clock, WRFU_Alarm
+! USE module_domain, ONLY : HISTORY_ALARM, Is_alarm_tstep
+!#endif
+ USE module_mp_radar
!
REAL, PARAMETER, PRIVATE :: dtcldcr = 120. ! maximum time step for minor loops
REAL, PARAMETER, PRIVATE :: n0r = 8.e6 ! intercept parameter rain
@@ -64,6 +71,7 @@
,rain, rainncv &
,snow, snowncv &
,sr &
+ ,refl_10cm, diagflag, do_radar_ref &
,graupel, graupelncv &
,ids,ide, jds,jde, kds,kde &
,ims,ime, jms,jme, kms,kme &
@@ -112,6 +120,16 @@
INTENT(INOUT) :: rain, &
rainncv, &
sr
+
+!+---+-----------------------------------------------------------------+
+#if defined(non_hydrostatic_core) | defined(hydrostatic_core)
+ REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT),optional:: & ! GT
+ refl_10cm
+#else
+ REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & ! GT
+#endif
+!+---+-----------------------------------------------------------------+
+
REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, &
INTENT(INOUT) :: snow, &
snowncv
@@ -123,7 +141,13 @@
REAL, DIMENSION( its:ite , kts:kte, 2 ) :: qci
REAL, DIMENSION( its:ite , kts:kte, 3 ) :: qrs
INTEGER :: i,j,k
-!-------------------------------------------------------------------
+
+!+---+-----------------------------------------------------------------+
+ REAL, DIMENSION(kts:kte):: qv1d, t1d, p1d, qr1d, qs1d, qg1d, dBZ
+ LOGICAL, OPTIONAL, INTENT(IN) :: diagflag
+ INTEGER, OPTIONAL, INTENT(IN) :: do_radar_ref
+!+---+-----------------------------------------------------------------+
+
DO j=jts,jte
DO k=kts,kte
DO i=its,ite
@@ -163,6 +187,29 @@
qg(i,k,j) = qrs(i,k,3)
ENDDO
ENDDO
+
+!+---+-----------------------------------------------------------------+
+ IF ( PRESENT (diagflag) ) THEN
+ if (diagflag .and. do_radar_ref == 1) then
+ DO I=its,ite
+ DO K=kts,kte
+ t1d(k)=th(i,k,j)*pii(i,k,j)
+ p1d(k)=p(i,k,j)
+ qv1d(k)=q(i,k,j)
+ qr1d(k)=qr(i,k,j)
+ qs1d(k)=qs(i,k,j)
+ qg1d(k)=qg(i,k,j)
+ ENDDO
+ call refl10cm_wsm6 (qv1d, qr1d, qs1d, qg1d, &
+ t1d, p1d, dBZ, kts, kte, i, j)
+ do k = kts, kte
+ refl_10cm(i,k,j) = MAX(-35., dBZ(k))
+ enddo
+ ENDDO
+ endif
+ ENDIF
+!+---+-----------------------------------------------------------------+
+
ENDDO
END SUBROUTINE wsm6
!===================================================================
@@ -1489,6 +1536,24 @@
rsloper3max = rsloper2max * rslopermax
rslopes3max = rslopes2max * rslopesmax
rslopeg3max = rslopeg2max * rslopegmax
+
+!+---+-----------------------------------------------------------------+
+!..Set these variables needed for computing radar reflectivity. These
+!.. get used within radar_init to create other variables used in the
+!.. radar module.
+ xam_r = PI*denr/6.
+ xbm_r = 3.
+ xmu_r = 0.
+ xam_s = PI*dens/6.
+ xbm_s = 3.
+ xmu_s = 0.
+ xam_g = PI*deng/6.
+ xbm_g = 3.
+ xmu_g = 0.
+
+ call radar_init
+!+---+-----------------------------------------------------------------+
+
!
END SUBROUTINE wsm6init
!------------------------------------------------------------------------------
@@ -2215,4 +2280,182 @@
enddo i_loop
!
END SUBROUTINE nislfv_rain_plm6
+
+!+---+-----------------------------------------------------------------+
+
+ subroutine refl10cm_wsm6 (qv1d, qr1d, qs1d, qg1d, &
+ t1d, p1d, dBZ, kts, kte, ii, jj)
+
+ IMPLICIT NONE
+
+!..Sub arguments
+ INTEGER, INTENT(IN):: kts, kte, ii, jj
+ REAL, DIMENSION(kts:kte), INTENT(IN):: &
+ qv1d, qr1d, qs1d, qg1d, t1d, p1d
+ REAL, DIMENSION(kts:kte), INTENT(INOUT):: dBZ
+
+!..Local variables
+ REAL, DIMENSION(kts:kte):: temp, pres, qv, rho
+ REAL, DIMENSION(kts:kte):: rr, rs, rg
+ REAL:: temp_C
+
+ DOUBLE PRECISION, DIMENSION(kts:kte):: ilamr, ilams, ilamg
+ DOUBLE PRECISION, DIMENSION(kts:kte):: N0_r, N0_s, N0_g
+ DOUBLE PRECISION:: lamr, lams, lamg
+ LOGICAL, DIMENSION(kts:kte):: L_qr, L_qs, L_qg
+
+ REAL, DIMENSION(kts:kte):: ze_rain, ze_snow, ze_graupel
+ DOUBLE PRECISION:: fmelt_s, fmelt_g
+
+ INTEGER:: i, k, k_0, kbot, n
+ LOGICAL:: melti
+
+ DOUBLE PRECISION:: cback, x, eta, f_d
+ REAL, PARAMETER:: R=287.
+
+!+---+
+
+ do k = kts, kte
+ dBZ(k) = -35.0
+ enddo
+
+!+---+-----------------------------------------------------------------+
+!..Put column of data into local arrays.
+!+---+-----------------------------------------------------------------+
+ do k = kts, kte
+ temp(k) = t1d(k)
+ temp_C = min(-0.001, temp(K)-273.15)
+ qv(k) = MAX(1.E-10, qv1d(k))
+ pres(k) = p1d(k)
+ rho(k) = 0.622*pres(k)/(R*temp(k)*(qv(k)+0.622))
+
+ if (qr1d(k) .gt. 1.E-9) then
+ rr(k) = qr1d(k)*rho(k)
+ N0_r(k) = n0r
+ lamr = (xam_r*xcrg(3)*N0_r(k)/rr(k))**(1./xcre(1))
+ ilamr(k) = 1./lamr
+ L_qr(k) = .true.
+ else
+ rr(k) = 1.E-12
+ L_qr(k) = .false.
+ endif
+
+ if (qs1d(k) .gt. 1.E-9) then
+ rs(k) = qs1d(k)*rho(k)
+ N0_s(k) = min(n0smax, n0s*exp(-alpha*temp_C))
+ lams = (xam_s*xcsg(3)*N0_s(k)/rs(k))**(1./xcse(1))
+ ilams(k) = 1./lams
+ L_qs(k) = .true.
+ else
+ rs(k) = 1.E-12
+ L_qs(k) = .false.
+ endif
+
+ if (qg1d(k) .gt. 1.E-9) then
+ rg(k) = qg1d(k)*rho(k)
+ N0_g(k) = n0g
+ lamg = (xam_g*xcgg(3)*N0_g(k)/rg(k))**(1./xcge(1))
+ ilamg(k) = 1./lamg
+ L_qg(k) = .true.
+ else
+ rg(k) = 1.E-12
+ L_qg(k) = .false.
+ endif
+ enddo
+
+!+---+-----------------------------------------------------------------+
+!..Locate K-level of start of melting (k_0 is level above).
+!+---+-----------------------------------------------------------------+
+ melti = .false.
+ k_0 = kts
+ do k = kte-1, kts, -1
+ if ( (temp(k).gt.273.15) .and. L_qr(k) &
+ .and. (L_qs(k+1).or.L_qg(k+1)) ) then
+ k_0 = MAX(k+1, k_0)
+ melti=.true.
+ goto 195
+ endif
+ enddo
+ 195 continue
+
+!+---+-----------------------------------------------------------------+
+!..Assume Rayleigh approximation at 10 cm wavelength. Rain (all temps)
+!.. and non-water-coated snow and graupel when below freezing are
+!.. simple. Integrations of m(D)*m(D)*N(D)*dD.
+!+---+-----------------------------------------------------------------+
+
+ do k = kts, kte
+ ze_rain(k) = 1.e-22
+ ze_snow(k) = 1.e-22
+ ze_graupel(k) = 1.e-22
+ if (L_qr(k)) ze_rain(k) = N0_r(k)*xcrg(4)*ilamr(k)**xcre(4)
+ if (L_qs(k)) ze_snow(k) = (0.176/0.93) * (6.0/PI)*(6.0/PI) &
+ * (xam_s/900.0)*(xam_s/900.0) &
+ * N0_s(k)*xcsg(4)*ilams(k)**xcse(4)
+ if (L_qg(k)) ze_graupel(k) = (0.176/0.93) * (6.0/PI)*(6.0/PI) &
+ * (xam_g/900.0)*(xam_g/900.0) &
+ * N0_g(k)*xcgg(4)*ilamg(k)**xcge(4)
+ enddo
+
+
+!+---+-----------------------------------------------------------------+
+!..Special case of melting ice (snow/graupel) particles. Assume the
+!.. ice is surrounded by the liquid water. Fraction of meltwater is
+!.. extremely simple based on amount found above the melting level.
+!.. Uses code from Uli Blahak (rayleigh_soak_wetgraupel and supporting
+!.. routines).
+!+---+-----------------------------------------------------------------+
+
+ if (melti .and. k_0.ge.kts+1) then
+ do k = k_0-1, kts, -1
+
+!..Reflectivity contributed by melting snow
+ if (L_qs(k) .and. L_qs(k_0) ) then
+ fmelt_s = MAX(0.005d0, MIN(1.0d0-rs(k)/rs(k_0), 0.99d0))
+ eta = 0.d0
+ lams = 1./ilams(k)
+ do n = 1, nrbins
+ x = xam_s * xxDs(n)**xbm_s
+ call rayleigh_soak_wetgraupel (x,DBLE(xocms),DBLE(xobms), &
+ fmelt_s, melt_outside_s, m_w_0, m_i_0, lamda_radar, &
+ CBACK, mixingrulestring_s, matrixstring_s, &
+ inclusionstring_s, hoststring_s, &
+ hostmatrixstring_s, hostinclusionstring_s)
+ f_d = N0_s(k)*xxDs(n)**xmu_s * DEXP(-lams*xxDs(n))
+ eta = eta + f_d * CBACK * simpson(n) * xdts(n)
+ enddo
+ ze_snow(k) = SNGL(lamda4 / (pi5 * K_w) * eta)
+ endif
+
+
+!..Reflectivity contributed by melting graupel
+
+ if (L_qg(k) .and. L_qg(k_0) ) then
+ fmelt_g = MAX(0.005d0, MIN(1.0d0-rg(k)/rg(k_0), 0.99d0))
+ eta = 0.d0
+ lamg = 1./ilamg(k)
+ do n = 1, nrbins
+ x = xam_g * xxDg(n)**xbm_g
+ call rayleigh_soak_wetgraupel (x,DBLE(xocmg),DBLE(xobmg), &
+ fmelt_g, melt_outside_g, m_w_0, m_i_0, lamda_radar, &
+ CBACK, mixingrulestring_g, matrixstring_g, &
+ inclusionstring_g, hoststring_g, &
+ hostmatrixstring_g, hostinclusionstring_g)
+ f_d = N0_g(k)*xxDg(n)**xmu_g * DEXP(-lamg*xxDg(n))
+ eta = eta + f_d * CBACK * simpson(n) * xdtg(n)
+ enddo
+ ze_graupel(k) = SNGL(lamda4 / (pi5 * K_w) * eta)
+ endif
+
+ enddo
+ endif
+
+ do k = kte, kts, -1
+ dBZ(k) = 10.*log10((ze_rain(k)+ze_snow(k)+ze_graupel(k))*1.d18)
+ enddo
+
+
+ end subroutine refl10cm_wsm6
+!+---+-----------------------------------------------------------------+
+
END MODULE module_mp_wsm6
Modified: trunk/mpas/src/core_atmos_physics/physics_wrf/module_ra_rrtmg_sw.F
===================================================================
--- trunk/mpas/src/core_atmos_physics/physics_wrf/module_ra_rrtmg_sw.F 2013-03-27 19:24:59 UTC (rev 2673)
+++ trunk/mpas/src/core_atmos_physics/physics_wrf/module_ra_rrtmg_sw.F 2013-03-27 19:26:14 UTC (rev 2674)
@@ -8544,8 +8544,14 @@
taucmcl ,ssacmcl ,asmcmcl ,fsfcmcl , &
ciwpmcl ,clwpmcl ,reicmcl ,relqmcl , &
tauaer ,ssaaer ,asmaer ,ecaer , &
- swuflx ,swdflx ,swhr ,swuflxc ,swdflxc ,swhrc)
+ swuflx ,swdflx ,swhr ,swuflxc ,swdflxc ,swhrc, &
+! --------- Add the following four compenants for ssib shortwave down radiation ---!
+! ------------------- by Zhenxin 2011-06-20 --------------------------------!
+ sibvisdir, sibvisdif, sibnirdir, sibnirdif &
+ )
+! ---------------------- End, Zhenxin 2011-06-20 --------------------------------!
+
! ------- Description -------
! This program is the driver for RRTMG_SW, the AER SW radiation model for
@@ -8743,6 +8749,14 @@
! Dimensions: (ncol,nlay+1)
real(kind=rb), intent(out) :: swdflx(:,:) ! Total sky shortwave downward flux (W/m2)
! Dimensions: (ncol,nlay+1)
+ real(kind=rb), intent(out) :: sibvisdir(:,:) ! visible direct downward flux (W/m2)
+ ! Dimensions: (ncol,nlay+1) Zhenxin (2011/06/20)
+ real(kind=rb), intent(out) :: sibvisdif(:,:) ! visible diffusion downward flux (W/m2)
+ ! Dimensions: (ncol,nlay+1) Zhenxin (2011/06/20)
+ real(kind=rb), intent(out) :: sibnirdir(:,:) ! Near IR direct downward flux (W/m2)
+ ! Dimensions: (ncol,nlay+1) Zhenxin (2011/06/20)
+ real(kind=rb), intent(out) :: sibnirdif(:,:) ! Near IR diffusion downward flux (W/m2)
+ ! Dimensions: (ncol,nlay+1) Zhenxin (2011/06/20)
real(kind=rb), intent(out) :: swhr(:,:) ! Total sky shortwave radiative heating rate (K/d)
! Dimensions: (ncol,nlay)
real(kind=rb), intent(out) :: swuflxc(:,:) ! Clear sky shortwave upward flux (W/m2)
@@ -9070,7 +9084,7 @@
do ib = 1, nbndsw
ztaua(i,ib) = 0._rb
zasya(i,ib) = 0._rb
- zomga(i,ib) = 1._rb
+ zomga(i,ib) = 0._rb
do ia = 1, naerec
ztaua(i,ib) = ztaua(i,ib) + rsrtaua(ib,ia) * ecaer(iplon,i,ia)
zomga(i,ib) = zomga(i,ib) + rsrtaua(ib,ia) * ecaer(iplon,i,ia) * &
@@ -9142,15 +9156,24 @@
swdflx(iplon,i) = zbbfd(i)
uvdflx(i) = zuvfd(i)
nidflx(i) = znifd(i)
+
! Direct/diffuse fluxes
dirdflux(i) = zbbfddir(i)
difdflux(i) = swdflx(iplon,i) - dirdflux(i)
! UV/visible direct/diffuse fluxes
dirdnuv(i) = zuvfddir(i)
difdnuv(i) = zuvfd(i) - dirdnuv(i)
+! ------- Zhenxin add vis/uv downwards dir or dif here --!
+ sibvisdir(iplon,i) = dirdnuv(i)
+ sibvisdif(iplon,i) = difdnuv(i)
+! ----- End of Zhenxin addition ------------!
! Near-IR direct/diffuse fluxes
dirdnir(i) = znifddir(i)
difdnir(i) = znifd(i) - dirdnir(i)
+! ---------Zhenxin add nir downwards dir and dif here --!
+ sibnirdir(iplon,i) = dirdnir(i)
+ sibnirdif(iplon,i) = difdnir(i)
+! -------- End of Zhenxin addition 2011-05 ---------!
enddo
! Total and clear sky net fluxes
@@ -9546,12 +9569,12 @@
MODULE module_ra_rrtmg_sw
#if defined(non_hydrostatic_core) || defined(hydrostatic_core)
-!MPAS specific (Laura D. Fowler):
+!MPAS specific (Laura D. Fowler - 2013-03-11):
use mpas_atmphys_constants,only: cp
#else
use module_model_constants, only : cp
-use module_wrf_error
-!use module_dm
+USE module_wrf_error
+!USE module_dm
#endif
!MPAS specific end.
@@ -9584,7 +9607,19 @@
xland, xice, snow, &
qv3d, qc3d, qr3d, &
qi3d, qs3d, qg3d, &
+ alswvisdir, alswvisdif, & !Zhenxin ssib alb comp (06/20/2011)
+ alswnirdir, alswnirdif, & !Zhenxin ssib alb comp (06/20/2011)
+ swvisdir, swvisdif, & !Zhenxin ssib swr comp (06/20/2011)
+ swnirdir, swnirdif, & !Zhenxin ssib swi comp (06/20/2011)
+ sf_surface_physics, & !Zhenxin
f_qv, f_qc, f_qr, f_qi, f_qs, f_qg, &
+ tauaer300,tauaer400,tauaer600,tauaer999, & ! czhao
+ gaer300,gaer400,gaer600,gaer999, & ! czhao
+ waer300,waer400,waer600,waer999, & ! czhao
+ aer_ra_feedback, &
+!jdfcz progn,prescribe, &
+ progn, &
+ qndrop3d,f_qndrop, & !czhao
ids,ide, jds,jde, kds,kde, &
ims,ime, jms,jme, kms,kme, &
its,ite, jts,jte, kts,kte, &
@@ -9631,6 +9666,24 @@
TSK, &
ALBEDO
!
+!!! ------------------- Zhenxin (2011-06/20) ------------------
+ REAL, DIMENSION( ims:ime, jms:jme ) , &
+ OPTIONAL , &
+ INTENT(IN) :: ALSWVISDIR, & ! ssib albedo of sw and lw
+ ALSWVISDIF, &
+ ALSWNIRDIR, &
+ ALSWNIRDIF
+
+ REAL, DIMENSION( ims:ime, jms:jme ) , &
+ OPTIONAL , &
+ INTENT(OUT) :: SWVISDIR, &
+ SWVISDIF, &
+ SWNIRDIR, &
+ SWNIRDIF ! ssib sw dir and diff rad
+ INTEGER, INTENT(IN) :: sf_surface_physics ! ssib para
+
+! ----------------------- end Zhenxin --------------------------
+!
REAL, INTENT(IN ) :: R,G
!
! Optional
@@ -9644,8 +9697,11 @@
QR3D, &
QI3D, &
QS3D, &
- QG3D
+ QG3D, &
+ QNDROP3D
+ real pi,third,relconst,lwpmin,rhoh2o
+
REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
OPTIONAL , &
INTENT(IN ) :: &
@@ -9653,8 +9709,30 @@
F_RAIN_PHY
LOGICAL, OPTIONAL, INTENT(IN) :: &
- F_QV,F_QC,F_QR,F_QI,F_QS,F_QG
+ F_QV,F_QC,F_QR,F_QI,F_QS,F_QG,F_QNDROP
+! Optional
+ REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL , &
+ INTENT(IN ) :: tauaer300,tauaer400,tauaer600,tauaer999, & ! czhao
+ gaer300,gaer400,gaer600,gaer999, & ! czhao
+ waer300,waer400,waer600,waer999 ! czhao
+
+ INTEGER, INTENT(IN ), OPTIONAL :: aer_ra_feedback
+!jdfcz INTEGER, INTENT(IN ), OPTIONAL :: progn,prescribe
+ INTEGER, INTENT(IN ), OPTIONAL :: progn
+
+ !wavelength corresponding to wavenum1 and wavenum2 (cm-1)
+ real, save :: wavemin(nbndsw) ! Min wavelength (um) of 14 intervals
+ data wavemin /3.077,2.500,2.150,1.942,1.626,1.299, &
+ 1.242,0.778,0.625,0.442,0.345,0.263,0.200,3.846/
+ real, save :: wavemax(nbndsw) ! Max wavelength (um) of interval
+ data wavemax/3.846,3.077,2.500,2.150,1.942,1.626, &
+ 1.299,1.242,0.778,0.625,0.442,0.345,0.263,12.195/
+ real wavemid(nbndsw) ! Mid wavelength (um) of interval
+ real, parameter :: thresh=1.e-9
+ real ang,slope
+ character(len=200) :: msg
+
! Top of atmosphere and surface shortwave fluxes (W m-2)
REAL, DIMENSION( ims:ime, jms:jme ), &
OPTIONAL, INTENT(INOUT) :: &
@@ -9663,8 +9741,7 @@
! Layer shortwave fluxes (including extra layer above model top)
! Vertical ordering is from bottom to top (W m-2)
-! REAL, DIMENSION( ims:ime, kms:kme+2, jms:jme ), &
- REAL, DIMENSION( ims:ime, kms:kme+1, jms:jme ), &
+ REAL, DIMENSION( ims:ime, kms:kme+2, jms:jme ), &
OPTIONAL, INTENT(OUT) :: &
SWUPFLX,SWUPFLXC,SWDNFLX,SWDNFLXC
@@ -9683,7 +9760,8 @@
QR1D, &
QI1D, &
QS1D, &
- QG1D
+ QG1D, &
+ qndrop1d
! Added local arrays for RRTMG
integer :: ncol, &
@@ -9739,7 +9817,11 @@
real, dimension( 1, kts:kte+2 ) :: swuflx, &
swdflx, &
swuflxc, &
- swdflxc
+ swdflxc, &
+ sibvisdir, & ! Zhenxin 2011-06-20
+ sibvisdif, &
+ sibnirdir, &
+ sibnirdif ! Zhenxin 2011-06-20
real, dimension( 1, kts:kte+1 ) :: swhr, &
swhrc
@@ -9822,6 +9904,26 @@
LOGICAL :: predicate
!------------------------------------------------------------------
+#ifdef WRF_CHEM
+ IF ( aer_ra_feedback == 1) then
+ IF ( .NOT. &
+ ( PRESENT(tauaer300) .AND. &
+ PRESENT(tauaer400) .AND. &
+ PRESENT(tauaer600) .AND. &
+ PRESENT(tauaer999) .AND. &
+ PRESENT(gaer300) .AND. &
+ PRESENT(gaer400) .AND. &
+ PRESENT(gaer600) .AND. &
+ PRESENT(gaer999) .AND. &
+ PRESENT(waer300) .AND. &
+ PRESENT(waer400) .AND. &
+ PRESENT(waer600) .AND. &
+ PRESENT(waer999) ) ) THEN
+ CALL wrf_error_fatal &
+ ('Warning: missing fields required for aerosol radiation' )
+ ENDIF
+ ENDIF
+#endif
!-----CALCULATE SHORT WAVE RADIATION
!
@@ -9850,6 +9952,7 @@
! clat(i) = xxlat
coszrs = sin(xxlat) * sin(declin) + cos(xxlat) * cos(declin) * cos(hrang)
coszr(i,j) = coszrs
+
! Set flag to prevent shortwave calculation when sun below horizon
if (coszrs.le.0.0) dorrsw = .false.
! Perform shortwave calculation if sun above horizon
@@ -9867,6 +9970,7 @@
QI1D(K)=0.
QS1D(K)=0.
CLDFRA1D(k)=0.
+ QNDROP1D(k)=0.
ENDDO
DO K=kts,kte
@@ -9908,6 +10012,14 @@
ENDIF
ENDIF
+ IF ( PRESENT(F_QNDROP).AND.PRESENT(QNDROP3D)) THEN
+ IF (F_QNDROP) THEN
+ DO K=kts,kte
+ qndrop1d(K)=qndrop3d(I,K,J)
+ ENDDO
+ ENDIF
+ ENDIF
+
! This logic is tortured because cannot test F_QI unless
! it is present, and order of evaluation of expressions
! is not specified in Fortran
@@ -10053,11 +10165,31 @@
! Set surface albedo for direct and diffuse radiation in UV/visible and
! near-IR spectral regions
+! -------------- Zhenxin 2011-06-20 ----------- !
+
+! ------- 1. Commented by Zhenxin 2011-06-20 for SSiB coupling modified ---- !
+! asdir(ncol) = albedo(i,j)
+! asdif(ncol) = albedo(i,j)
+! aldir(ncol) = albedo(i,j)
+! aldif(ncol) = albedo(i,j)
+! ------- End of Comments ------ !
+
+! ------- 2. New Addiation ------ !
+ IF ( sf_surface_physics .eq. 8 .AND. XLAND(i,j) .LT. 1.5) THEN
+ asdir(ncol) = ALSWVISDIR(I,J)
+ asdif(ncol) = ALSWVISDIF(I,J)
+ aldir(ncol) = ALSWNIRDIR(I,J)
+ aldif(ncol) = ALSWNIRDIF(I,J)
+ ELSE
asdir(ncol) = albedo(i,j)
asdif(ncol) = albedo(i,j)
aldir(ncol) = albedo(i,j)
aldif(ncol) = albedo(i,j)
+ ENDIF
+! ---------- End of Addiation ------!
+! ---------- End of fds_Zhenxin 2011-06-20 --------------!
+
! Define cloud optical properties for radiation (inflgsw = 0)
! This option is not currently active
! Cloud and precipitation paths in g/m2
@@ -10114,12 +10246,59 @@
cliqwp(ncol,k) = gliqwp / max(0.01,cldfrac(ncol,k)) ! In-cloud liquid water path.
end do
+!link the aerosol feedback to cloud -czhao
+ if( PRESENT( progn ) ) then
+ if (progn == 1) then
+!jdfcz if(prescribe==0) then
+
+ pi = 4.*atan(1.0)
+ third=1./3.
+ rhoh2o=1.e3
+ relconst=3/(4.*pi*rhoh2o)
+! minimun liquid water path to calculate rel
+! corresponds to optical depth of 1.e-3 for radius 4 microns.
+ lwpmin=3.e-5
+ do k = kts, kte
+ reliq(ncol,k) = 10.
+ if( PRESENT( F_QNDROP ) ) then
+ if( F_QNDROP ) then
+ if ( qc1d(k)*pdel(ncol,k).gt.lwpmin.and. &
+ qndrop1d(k).gt.1000. ) then
+ reliq(ncol,k)=(relconst*qc1d(k)/qndrop1d(k))**third ! effective radius in m
+! apply scaling from Martin et al., JAS 51, 1830.
+ reliq(ncol,k)=1.1*reliq(ncol,k)
+ reliq(ncol,k)=reliq(ncol,k)*1.e6 ! convert from m to microns
+ reliq(ncol,k)=max(reliq(ncol,k),4.)
+ reliq(ncol,k)=min(reliq(ncol,k),20.)
+ end if
+ end if
+ end if
+ end do
+!jdfcz else ! prescribe
! following Kiehl
- call relcalc(ncol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
+ call relcalc(ncol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
+! write(0,*) 'sw prescribe aerosol',maxval(qndrop3d)
+!jdfcz endif
+ else ! progn
+ call relcalc(ncol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
+ endif
+ else !progn
+ call relcalc(ncol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
+ endif
! following Kristjansson and Mitchell
- call reicalc(ncol, pcols, pver, tlay, reice)
+ call reicalc(ncol, pcols, pver, tlay, reice)
+#if 0
+ if (i==80.and.j==30) then
+#if defined( DM_PARALLEL ) && ! defined( STUBMPI)
+ if( PRESENT( progn ) ) write(0,*) 'aerosol indirect',progn
+ write(0,*)'sw water eff radius',reliq(ncol,10),reliq(ncol,20),reliq(ncol,25)
+ write(0,*)'sw ice eff radius',reice(ncol,10),reice(ncol,20),reice(ncol,25)
+#endif
+ endif
+#endif
+
! Limit upper bound of reice for Fu ice parameterization and convert
! from effective radius to generalized effective size (*1.0315; Fu, 1996)
if (iceflgsw .eq. 3) then
@@ -10172,17 +10351,111 @@
cldfmcl, ciwpmcl, clwpmcl, reicmcl, relqmcl, &
taucmcl, ssacmcl, asmcmcl, fsfcmcl)
-! Aerosol optical depth, single scattering albedo and asymmetry parameter
+!--------------------------------------------------------------------------
+! Aerosol optical depth, single scattering albedo and asymmetry parameter -czhao 03/2010
+!--------------------------------------------------------------------------
! by layer for each RRTMG shortwave band
! No aerosols in top layer above model top (kte+1).
- do nb = 1, nbndsw
- do k = kts, kte+1
- tauaer(ncol,k,nb) = 0.
- ssaaer(ncol,k,nb) = 1.
- asmaer(ncol,k,nb) = 0.
- enddo
- enddo
+!cz do nb = 1, nbndsw
+!cz do k = kts, kte+1
+!cz tauaer(ncol,k,nb) = 0.
+!cz ssaaer(ncol,k,nb) = 1.
+!cz asmaer(ncol,k,nb) = 0.
+!cz enddo
+!cz enddo
+! ... Aerosol effects. Added aerosol feedbacks from Chem , 03/2010 -czhao
+!
+ do nb = 1, nbndsw
+ do k = kts,kte+1
+ tauaer(ncol,k,nb) = 0.
+ ssaaer(ncol,k,nb) = 1.
+ asmaer(ncol,k,nb) = 0.
+ end do
+ end do
+
+#ifdef WRF_CHEM
+ IF ( AER_RA_FEEDBACK == 1) then
+ do nb = 1, nbndsw
+ wavemid(nb)=0.5*(wavemin(nb)+wavemax(nb)) ! um
+ do k = kts,kte !wig
+
+! convert optical properties at 300,400,600, and 999 to conform to the band wavelengths
+! tauaer - use angstrom exponent
+ if(tauaer300(i,k,j).gt.thresh .and. tauaer999(i,k,j).gt.thresh) then
+ ang=alog(tauaer300(i,k,j)/tauaer999(i,k,j))/alog(999./300.)
+ tauaer(ncol,k,nb)=tauaer400(i,k,j)*(0.4/wavemid(nb))**ang
+ !tauaer(ncol,k,nb)=tauaer600(i,k,j)*(0.6/wavemid(nb))**ang
+ if (i==30.and.j==49.and.k==2.and.nb==12) then
+ write(0,*) 'TAU from 600 vs 400 in RRTMG',tauaer600(i,k,j),tauaer400(i,k,j)
+ print*, 'TAU from 600 vs 400 in RRTMG',tauaer600(i,k,j),tauaer400(i,k,j)
+ write(0,*) tauaer600(i,k,j)*(0.6/wavemid(nb))**ang,tauaer400(i,k,j)*(0.4/wavemid(nb))**ang
+ print*, tauaer600(i,k,j)*(0.6/wavemid(nb))**ang,tauaer400(i,k,j)*(0.4/wavemid(nb))**ang
+ endif
+! ssa - linear interpolation; extrapolation
+ slope=(waer600(i,k,j)-waer400(i,k,j))/.2
+ ssaaer(ncol,k,nb) = slope*(wavemid(nb)-.6)+waer600(i,k,j)
+ if(ssaaer(ncol,k,nb).lt.0.4) ssaaer(ncol,k,nb)=0.4
+ if(ssaaer(ncol,k,nb).ge.1.0) ssaaer(ncol,k,nb)=1.0
+! g - linear interpolation;extrapolation
+ slope=(gaer600(i,k,j)-gaer400(i,k,j))/.2
+ asmaer(ncol,k,nb) = slope*(wavemid(nb)-.6)+gaer600(i,k,j) ! notice reversed varaibles
+ if(asmaer(ncol,k,nb).lt.0.5) asmaer(ncol,k,nb)=0.5
+ if(asmaer(ncol,k,nb).ge.1.0) asmaer(ncol,k,nb)=1.0
+ endif
+ end do ! k
+ end do ! nb
+
+!wig beg
+ do nb = 1, nbndsw
+ slope = 0. !use slope as a sum holder
+ do k = kts,kte
+ slope = slope + tauaer(ncol,k,nb)
+ end do
+ if( slope < 0. ) then
+ write(msg,'("ERROR: Negative total optical depth of ",f8.2," at point i,j,nb=",3i5)') slope,i,j,nb
+ call wrf_error_fatal(msg)
+ else if( slope > 6. ) then
+ call wrf_message("-------------------------")
+ write(msg,'("WARNING: Large total sw optical depth of ",f8.2," at point i,j,nb=",3i5)') slope,i,j,nb
+ call wrf_message(msg)
+
+ call wrf_message("Diagnostics 1: k, tauaer300, tauaer400, tauaer600, tauaer999, tauaer")
+ do k=kts,kte
+ write(msg,'(i4,5f8.2)') k, tauaer300(i,k,j), tauaer400(i,k,j), &
+ tauaer600(i,k,j), tauaer999(i,k,j),tauaer(ncol,k,nb)
+ call wrf_message(msg)
+ !czhao set an up-limit here to avoid segmentation fault
+ !from extreme AOD
+ tauaer(ncol,k,nb)=tauaer(ncol,k,nb)*6.0/slope
+ end do
+
+ call wrf_message("Diagnostics 2: k, gaer300, gaer400, gaer600, gaer999")
+ do k=kts,kte
+ write(msg,'(i4,4f8.2)') k, gaer300(i,k,j), gaer400(i,k,j), &
+ gaer600(i,k,j), gaer999(i,k,j)
+ call wrf_message(msg)
+ end do
+
+ call wrf_message("Diagnostics 3: k, waer300, waer400, waer600, waer999")
+ do k=kts,kte
+ write(msg,'(i4,4f8.2)') k, waer300(i,k,j), waer400(i,k,j), &
+ waer600(i,k,j), waer999(i,k,j)
+ call wrf_message(msg)
+ end do
+
+ call wrf_message("Diagnostics 4: k, ssaal, asyal, taual")
+ do k=kts-1,kte
+ write(msg,'(i4,3f8.2)') k, ssaaer(i,k,nb), asmaer(i,k,nb), tauaer(i,k,nb)
+ call wrf_message(msg)
+ end do
+ call wrf_message("-------------------------")
+ endif
+ enddo ! nb
+ endif ! aer_ra_feedback
+#endif
+
+
! Zero array for input of aerosol optical thickness for use with
! ECMWF aerosol types (not used)
do na = 1, naerec
@@ -10203,7 +10476,11 @@
taucmcl ,ssacmcl ,asmcmcl ,fsfcmcl , &
ciwpmcl ,clwpmcl ,reicmcl ,relqmcl , &
tauaer ,ssaaer ,asmaer ,ecaer , &
- swuflx ,swdflx ,swhr ,swuflxc ,swdflxc ,swhrc)
+ swuflx ,swdflx ,swhr ,swuflxc ,swdflxc ,swhrc, &
+! ----- Zhenxin added for ssib coupiling 2011-06-20 --------!
+ sibvisdir, sibvisdif, sibnirdir, sibnirdif &
+ )
+! -------------------- End of addiation by Zhenxin 2011-06-20 ------!
! Output net absorbed shortwave surface flux and shortwave cloud forcing
! at the top of atmosphere (W/m2)
@@ -10220,6 +10497,12 @@
swupb(i,j) = swuflx(1,1)
swupbc(i,j) = swuflxc(1,1)
swdnb(i,j) = swdflx(1,1)
+! Added by Zhenxin for 4 compenants of swdown radiation
+ swvisdir(i,j) = sibvisdir(1,1)
+ swvisdif(i,j) = sibvisdif(1,1)
+ swnirdir(i,j) = sibnirdir(1,1)
+ swnirdif(i,j) = sibnirdif(1,1)
+! Ended, Zhenxin (2011/06/20)
swdnbc(i,j) = swdflxc(1,1)
endif
@@ -10252,6 +10535,10 @@
swupbc(i,j) = 0.
swdnb(i,j) = 0.
swdnbc(i,j) = 0.
+ swvisdir(i,j) = 0. ! Add by Zhenxin (2011/06/20)
+ swvisdif(i,j) = 0.
+ swnirdir(i,j) = 0.
+ swnirdif(i,j) = 0. ! Add by Zhenxin (2011/06/20)
endif
endif
@@ -10264,15 +10551,14 @@
END SUBROUTINE RRTMG_SWRAD
-
-!ldf (12-20-2010): This section of the module is moved to module_physics_rrtmg_swinit.F in
+!ldf (2013-03-11): This section of the module is moved to module_physics_rrtmg_swinit.F in
!./../core_physics to accomodate differences in the mpi calls between WRF and MPAS.I thought
!that it would be cleaner to do this instead of adding a lot of #ifdef statements throughout
!the initialization of the shortwave radiation code. Initialization is handled the same way
!for the longwave radiation code.
#if !(defined(non_hydrostatic_core) || defined(hydrostatic_core))
-
+
!====================================================================
SUBROUTINE rrtmg_swinit( &
allowed_to_read , &
@@ -10325,11 +10611,7 @@
rrtmg_unit = -1
2010 CONTINUE
ENDIF
-!ldf (11-08-2010): changed wrf_dm_bcast_bytes to wrf_dm_bcast_integer to avoid warning at
-!compilation time:
-! CALL wrf_dm_bcast_bytes ( rrtmg_unit , IWORDSIZE )
- CALL wrf_dm_bcast_integer ( rrtmg_unit , IWORDSIZE )
-!ldf end.
+ CALL wrf_dm_bcast_bytes ( rrtmg_unit , IWORDSIZE )
IF ( rrtmg_unit < 0 ) THEN
CALL wrf_error_fatal ( 'module_ra_rrtmg_sw: rrtm_swlookuptable: Can not '// &
'find unused fortran unit to read in lookup table.' )
@@ -11454,6 +11736,6 @@
!------------------------------------------------------------------
#endif
-!ldf end (12-20-2010).
+!ldf end (2013-03-11).
END MODULE module_ra_rrtmg_sw
Modified: trunk/mpas/src/core_atmos_physics/physics_wrf/module_sf_sfclay.F
===================================================================
--- trunk/mpas/src/core_atmos_physics/physics_wrf/module_sf_sfclay.F 2013-03-27 19:24:59 UTC (rev 2673)
+++ trunk/mpas/src/core_atmos_physics/physics_wrf/module_sf_sfclay.F 2013-03-27 19:26:14 UTC (rev 2674)
@@ -14,6 +14,7 @@
SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, &
CP,G,ROVCP,R,XLV,PSFC,CHS,CHS2,CQS2,CPM, &
ZNT,UST,PBLH,MAVAIL,ZOL,MOL,REGIME,PSIM,PSIH, &
+ FM,FH, &
XLAND,HFX,QFX,LH,TSK,FLHC,FLQC,QGH,QSFC,RMOL, &
U10,V10,TH2,T2,Q2, &
GZ1OZ0,WSPD,BR,ISFFLX,DX, &
@@ -23,7 +24,11 @@
ids,ide, jds,jde, kds,kde, &
ims,ime, jms,jme, kms,kme, &
its,ite, jts,jte, kts,kte, &
- ustm,ck,cka,cd,cda,isftcflx,iz0tlnd,areaCell )
+ ustm,ck,cka,cd,cda,isftcflx,iz0tlnd,scm_force_flux &
+#if defined(non_hydrostatic_core) || defined(hydrostatic_core)
+ ,areaCell &
+#endif
+ )
!-------------------------------------------------------------------
IMPLICIT NONE
!-------------------------------------------------------------------
@@ -50,6 +55,8 @@
!-- REGIME flag indicating PBL regime (stable, unstable, etc.)
!-- PSIM similarity stability function for momentum
!-- PSIH similarity stability function for heat
+!-- FM integrated stability function for momentum
+!-- FH integrated stability function for heat
!-- XLAND land mask (1 for land, 2 for water)
!-- HFX upward heat flux at the surface (W/m^2)
!-- QFX upward moisture flux at the surface (kg/m^2/s)
@@ -146,7 +153,7 @@
!
REAL, DIMENSION( ims:ime, jms:jme ) , &
INTENT(INOUT) :: GZ1OZ0,WSPD,BR, &
- PSIM,PSIH
+ PSIM,PSIH,FM,FH
REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
INTENT(IN ) :: U3D, &
@@ -175,16 +182,18 @@
REAL, INTENT(IN ) :: CP,G,ROVCP,R,XLV,DX
-!MPAS specific (Laura D. Fowler):
-! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ) , &
-! INTENT(OUT) :: ck,cka,cd,cda,ustm
- real, optional, dimension( ims:ime, jms:jme ) , &
- intent(inout) :: ck,cka,cd,cda,ustm
+ REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ) , &
+ INTENT(OUT) :: ck,cka,cd,cda,ustm
+
+ INTEGER, OPTIONAL, INTENT(IN ) :: ISFTCFLX, IZ0TLND
+ INTEGER, OPTIONAL, INTENT(IN ) :: SCM_FORCE_FLUX
+
+#if defined(non_hydrostatic_core) || defined(hydrostatic_core)
+!MPAS specific (Laura D. Fowler - 2013-03-06):
real,intent(in),dimension(ims:ime,jms:jme),optional:: areaCell
!MPAS specific end.
+#endif
- INTEGER, OPTIONAL, INTENT(IN ) :: ISFTCFLX, IZ0TLND
-
! LOCAL VARS
REAL, DIMENSION( its:ite ) :: U1D, &
@@ -218,6 +227,7 @@
CQS2(ims,j),CPM(ims,j),PBLH(ims,j), RMOL(ims,j), &
ZNT(ims,j),UST(ims,j),MAVAIL(ims,j),ZOL(ims,j), &
MOL(ims,j),REGIME(ims,j),PSIM(ims,j),PSIH(ims,j), &
+ FM(ims,j),FH(ims,j), &
XLAND(ims,j),HFX(ims,j),QFX(ims,j),TSK(ims,j), &
U10(ims,j),V10(ims,j),TH2(ims,j),T2(ims,j), &
Q2(ims,j),FLHC(ims,j),FLQC(ims,j),QGH(ims,j), &
@@ -229,26 +239,26 @@
ims,ime, jms,jme, kms,kme, &
its,ite, jts,jte, kts,kte &
#if defined(non_hydrostatic_core) || defined(hydrostatic_core)
-!MPAS specific (Laura D. Fowler):
- ,isftcflx,iz0tlnd, &
+!MPAS specific (Laura D. Fowler - 2013-03-06):
+ ,isftcflx,iz0tlnd,scm_force_flux, &
USTM(ims,j),CK(ims,j),CKA(ims,j), &
CD(ims,j),CDA(ims,j),areaCell(ims,j) &
-!#elseif ( EM_CORE == 1 )
-! ,isftcflx,iz0tlnd, &
-! USTM(ims,j),CK(ims,j),CKA(ims,j), &
-! CD(ims,j),CDA(ims,j) &
+#elif ( EM_CORE == 1 )
+ ,isftcflx,iz0tlnd,scm_force_flux, &
+ USTM(ims,j),CK(ims,j),CKA(ims,j), &
+ CD(ims,j),CDA(ims,j) &
#endif
)
ENDDO
-
+
END SUBROUTINE SFCLAY
!-------------------------------------------------------------------
SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, &
CP,G,ROVCP,R,XLV,PSFCPA,CHS,CHS2,CQS2,CPM,PBLH,RMOL, &
- ZNT,UST,MAVAIL,ZOL,MOL,REGIME,PSIM,PSIH, &
+ ZNT,UST,MAVAIL,ZOL,MOL,REGIME,PSIM,PSIH,FM,FH,&
XLAND,HFX,QFX,TSK, &
U10,V10,TH2,T2,Q2,FLHC,FLQC,QGH, &
QSFC,LH,GZ1OZ0,WSPD,BR,ISFFLX,DX, &
@@ -258,9 +268,14 @@
ids,ide, jds,jde, kds,kde, &
ims,ime, jms,jme, kms,kme, &
its,ite, jts,jte, kts,kte, &
- isftcflx, iz0tlnd, &
- ustm,ck,cka,cd,cda, &
- areaCell)
+ isftcflx, iz0tlnd, scm_force_flux, &
+#if defined(non_hydrostatic_core) || defined(hydrostatic_core)
+!MPAS specific (Laura D. Fowler - 2013-03-06):
+ ustm,ck,cka,cd,cda,areaCell )
+#else
+ ustm,ck,cka,cd,cda )
+#endif
+
!-------------------------------------------------------------------
IMPLICIT NONE
!-------------------------------------------------------------------
@@ -296,7 +311,7 @@
!
REAL, DIMENSION( ims:ime ) , &
INTENT(INOUT) :: GZ1OZ0,WSPD,BR, &
- PSIM,PSIH
+ PSIM,PSIH,FM,FH
REAL, DIMENSION( ims:ime ) , &
INTENT(INOUT) :: ZNT, &
@@ -334,11 +349,14 @@
INTENT(OUT) :: ck,cka,cd,cda,ustm
INTEGER, OPTIONAL, INTENT(IN ) :: ISFTCFLX, IZ0TLND
+ INTEGER, OPTIONAL, INTENT(IN ) :: SCM_FORCE_FLUX
-!MPAS specific (Laura D. Fowler): We take into accound the actual size of individual
-!grid-boxes:
+#if defined(non_hydrostatic_core) || defined(hydrostatic_core)
+!MPAS specific (Laura D. Fowler - 2013-03-06):
real,intent(in),dimension(ims:ime),optional:: areaCell
!MPAS specific end.
+#endif
+
! LOCAL VARS
@@ -372,6 +390,7 @@
REAL :: ZL,TSKV,DTHVDZ,DTHVM,VCONV,RZOL,RZOL2,RZOL10,ZOL2,ZOL10
REAL :: DTG,PSIX,DTTHX,PSIX10,PSIT,PSIT2,PSIQ,PSIQ2,PSIQ10
REAL :: FLUXC,VSGD,Z0Q,VISC,RESTAR,CZIL,RESTAR2
+ REAL :: ZW, ZN1, ZN2
!-------------------------------------------------------------------
KL=kte
@@ -511,8 +530,6 @@
else
VSGD = 0.32 * (max(dx/5000.-1.,0.))**.33
endif
-! write(0,201) i,areaCell(i),vsgd
-! 201 format(i8,2(1x,e15.8))
!MPAS specific end.
WSPD(I)=SQRT(WSPD(I)*WSPD(I)+VCONV*VCONV+vsgd*vsgd)
WSPD(I)=AMAX1(WSPD(I),0.1)
@@ -523,7 +540,7 @@
RMOL(I)=-GOVRTH(I)*DTHVDZ*ZA(I)*KARMAN
!jdf
- 260 CONTINUE
+ 260 CONTINUE
!
!-----DIAGNOSE BASIC PARAMETERS FOR THE APPROPRIATED STABILITY CLASS:
@@ -782,20 +799,25 @@
DENOMQ(I)=PSIQ
DENOMQ2(I)=PSIQ2
DENOMT2(I)=PSIT2
+ FM(I)=PSIX
+ FH(I)=PSIT
330 CONTINUE
!
335 CONTINUE
!-----COMPUTE THE SURFACE SENSIBLE AND LATENT HEAT FLUXES:
-
+ IF ( PRESENT(SCM_FORCE_FLUX) ) THEN
+ IF (SCM_FORCE_FLUX.EQ.1) GOTO 350
+ ENDIF
DO i=its,ite
QFX(i)=0.
HFX(i)=0.
ENDDO
+ 350 CONTINUE
IF (ISFFLX.EQ.0) GOTO 410
-!-----OVER WATER, ALTER ROUGHNESS LENGTH (ZNT) ACCORDING TO WIND (UST).
+!-----OVER WATER, ALTER ROUGHNESS LENGTH (ZNT) ACCORDING TO WIND (UST).
DO 360 I=its,ite
IF((XLAND(I)-1.5).GE.0)THEN
@@ -804,8 +826,16 @@
IF ( PRESENT(ISFTCFLX) ) THEN
IF ( ISFTCFLX.NE.0 ) THEN
! ZNT(I)=10.*exp(-9.*UST(I)**(-.3333))
- ZNT(I)=10.*exp(-9.5*UST(I)**(-.3333))
- ZNT(I)=ZNT(I) + 0.11*1.5E-5/AMAX1(UST(I),0.01)
+! ZNT(I)=10.*exp(-9.5*UST(I)**(-.3333))
+! ZNT(I)=ZNT(I) + 0.11*1.5E-5/AMAX1(UST(I),0.01)
+! ZNT(I)=0.011*UST(I)*UST(I)/G+OZO
+! ZNT(I)=MAX(ZNT(I),3.50e-5)
+! AHW 2012:
+ ZW = MIN((UST(I)/1.06)**(0.3),1.0)
+ ZN1 = 0.011*UST(I)*UST(I)/G + OZO
+ ZN2 = 10.*exp(-9.5*UST(I)**(-.3333)) + &
+ 0.11*1.5E-5/AMAX1(UST(I),0.01)
+ ZNT(I)=(1.0-ZW) * ZN1 + ZW * ZN2
ZNT(I)=MIN(ZNT(I),2.85e-3)
ZNT(I)=MAX(ZNT(I),1.27e-7)
ENDIF
@@ -825,13 +855,16 @@
ELSE
FLHC(I)=0.
ENDIF
- 360 CONTINUE
+ 360 CONTINUE
!
-!-----COMPUTE SURFACE MOIST FLUX:
-!
-! IF(IDRY.EQ.1)GOTO 390
-!
+!-----COMPUTE SURFACE MOIST FLUX:
+!
+! IF(IDRY.EQ.1)GOTO 390
+ IF ( PRESENT(SCM_FORCE_FLUX) ) THEN
+ IF (SCM_FORCE_FLUX.EQ.1) GOTO 405
+ ENDIF
+!
DO 370 I=its,ite
QFX(I)=FLQC(I)*(QSFC(I)-QX(I))
QFX(I)=AMAX1(QFX(I),0.)
@@ -855,6 +888,8 @@
HFX(I)=AMAX1(HFX(I),-250.)
ENDIF
400 CONTINUE
+
+ 405 CONTINUE
DO I=its,ite
IF((XLAND(I)-1.5).GE.0)THEN
Modified: trunk/mpas/src/core_init_nhyd_atmos/Makefile
===================================================================
--- trunk/mpas/src/core_init_nhyd_atmos/Makefile 2013-03-27 19:24:59 UTC (rev 2673)
+++ trunk/mpas/src/core_init_nhyd_atmos/Makefile 2013-03-27 19:26:14 UTC (rev 2674)
@@ -8,6 +8,8 @@
mpas_init_atm_bitarray.o \
mpas_init_atm_queue.o \
mpas_init_atm_hinterp.o \
+ mpas_init_atm_static.o \
+ mpas_init_atm_surface.o \
read_geogrid.o \
mpas_atmphys_date_time.o \
mpas_atmphys_initialize_real.o \
@@ -18,8 +20,15 @@
core_hyd: $(OBJS)
ar -ru libdycore.a $(OBJS)
-mpas_init_atm_test_cases.o: mpas_atm_advection.o mpas_init_atm_read_met.o read_geogrid.o mpas_init_atm_llxy.o mpas_init_atm_hinterp.o \
- mpas_atmphys_initialize_real.o
+mpas_init_atm_test_cases.o: \
+ read_geogrid.o \
+ mpas_atm_advection.o \
+ mpas_init_atm_read_met.o \
+ mpas_init_atm_llxy.o \
+ mpas_init_atm_hinterp.o \
+ mpas_init_atm_static.o \
+ mpas_init_atm_surface.o \
+ mpas_atmphys_initialize_real.o
mpas_init_atm_hinterp.o: mpas_init_atm_queue.o mpas_init_atm_bitarray.o
@@ -33,10 +42,19 @@
mpas_init_atm_mpas_core.o: mpas_advection.o mpas_init_atm_test_cases.o
+mpas_init_atm_static.o: \
+ mpas_atm_advection.o \
+ mpas_init_atm_hinterp.o \
+ mpas_init_atm_llxy.o \
+ mpas_atmphys_utilities.o
+
+mpas_init_atm_surface.o: \
+ mpas_init_atm_hinterp.o \
+ mpas_init_atm_llxy.o \
+ mpas_init_atm_read_met.o
+
mpas_atmphys_initialize_real.o: \
- mpas_init_atm_hinterp.o \
- mpas_init_atm_llxy.o \
- mpas_init_atm_read_met.o \
+ mpas_init_atm_surface.o \
mpas_atmphys_date_time.o \
mpas_atmphys_utilities.o
Modified: trunk/mpas/src/core_init_nhyd_atmos/Registry
===================================================================
--- trunk/mpas/src/core_init_nhyd_atmos/Registry 2013-03-27 19:24:59 UTC (rev 2673)
+++ trunk/mpas/src/core_init_nhyd_atmos/Registry 2013-03-27 19:26:14 UTC (rev 2674)
@@ -140,6 +140,17 @@
var persistent real shdmin ( nCells ) 0 io shdmin mesh - -
var persistent real shdmax ( nCells ) 0 io shdmax mesh - -
var persistent real albedo12m ( nMonths nCells ) 0 io albedo12m mesh - -
+var persistent real varsso ( nCells ) 0 io varsso mesh - -
+var persistent real var2d ( nCells ) 0 io var2d mesh - -
+var persistent real con ( nCells ) 0 io con mesh - -
+var persistent real oa1 ( nCells ) 0 io oa1 mesh - -
+var persistent real oa2 ( nCells ) 0 io oa2 mesh - -
+var persistent real oa3 ( nCells ) 0 io oa3 mesh - -
+var persistent real oa4 ( nCells ) 0 io oa4 mesh - -
+var persistent real ol1 ( nCells ) 0 io ol1 mesh - -
+var persistent real ol2 ( nCells ) 0 io ol2 mesh - -
+var persistent real ol3 ( nCells ) 0 io ol3 mesh - -
+var persistent real ol4 ( nCells ) 0 io ol4 mesh - -
% description of the vertical grid structure
@@ -162,10 +173,10 @@
% Horizontally interpolated from first-guess data
var persistent real u_fg ( nFGLevels nEdges Time ) 1 - u fg - -
var persistent real v_fg ( nFGLevels nEdges Time ) 1 - v fg - -
-var persistent real t_fg ( nFGLevels nCells Time ) 1 - t fg - -
-var persistent real p_fg ( nFGLevels nCells Time ) 1 - p fg - -
-var persistent real z_fg ( nFGLevels nCells Time ) 1 - z fg - -
-var persistent real rh_fg ( nFGLevels nCells Time ) 1 - rh fg - -
+var persistent real t_fg ( nFGLevels nCells Time ) 1 o t fg - -
+var persistent real p_fg ( nFGLevels nCells Time ) 1 o p fg - -
+var persistent real z_fg ( nFGLevels nCells Time ) 1 o z fg - -
+var persistent real rh_fg ( nFGLevels nCells Time ) 1 o rh fg - -
var persistent real soilz_fg ( nCells Time ) 1 io soilz fg - -
var persistent real psfc_fg ( nCells Time ) 1 - psfc fg - -
var persistent real pmsl_fg ( nCells Time ) 1 - pmsl fg - -
@@ -216,6 +227,8 @@
var persistent real qv_init ( nVertLevels ) 0 io qv_init mesh - -
% Diagnostic fields: only written to output
+var persistent real precipw ( nCells Time ) 1 o precipw diag_physics - -
+var persistent real rh ( nVertLevels nCells Time ) 1 o rh diag - -
var persistent real rho ( nVertLevels nCells Time ) 1 o rho diag - -
var persistent real theta ( nVertLevels nCells Time ) 1 o theta diag - -
var persistent real v ( nVertLevels nEdges Time ) 1 o v diag - -
Modified: trunk/mpas/src/core_init_nhyd_atmos/Registry.xml
===================================================================
--- trunk/mpas/src/core_init_nhyd_atmos/Registry.xml 2013-03-27 19:24:59 UTC (rev 2673)
+++ trunk/mpas/src/core_init_nhyd_atmos/Registry.xml 2013-03-27 19:26:14 UTC (rev 2674)
@@ -164,6 +164,19 @@
<var name="shdmax" type="real" dimensions="nCells" streams="io"/>
<var name="albedo12m" type="real" dimensions="nMonths nCells" streams="io"/>
+ <!-- GWDO fields -->
+ <var name="varsso" type="real" dimensions="nCells" streams="io"/>
+ <var name="var2d" type="real" dimensions="nCells" streams="io"/>
+ <var name="con" type="real" dimensions="nCells" streams="io"/>
+ <var name="oa1" type="real" dimensions="nCells" streams="io"/>
+ <var name="oa2" type="real" dimensions="nCells" streams="io"/>
+ <var name="oa3" type="real" dimensions="nCells" streams="io"/>
+ <var name="oa4" type="real" dimensions="nCells" streams="io"/>
+ <var name="ol1" type="real" dimensions="nCells" streams="io"/>
+ <var name="ol2" type="real" dimensions="nCells" streams="io"/>
+ <var name="ol3" type="real" dimensions="nCells" streams="io"/>
+ <var name="ol4" type="real" dimensions="nCells" streams="io"/>
+
<!-- description of the vertical grid structure -->
<var name="hx" type="real" dimensions="nVertLevelsP1 nCells" streams="io"/>
<var name="zgrid" type="real" dimensions="nVertLevelsP1 nCells" streams="io"/>
@@ -215,10 +228,10 @@
<!-- horizontally interpolated from first-guess data -->
<var name="u_fg" name_in_code="u" type="real" dimensions="nFGLevels nEdges Time"/>
<var name="v_fg" name_in_code="v" type="real" dimensions="nFGLevels nEdges Time"/>
- <var name="t_fg" name_in_code="t" type="real" dimensions="nFGLevels nCells Time"/>
- <var name="p_fg" name_in_code="p" type="real" dimensions="nFGLevels nCells Time"/>
- <var name="z_fg" name_in_code="z" type="real" dimensions="nFGLevels nCells Time"/>
- <var name="rh_fg" name_in_code="rh" type="real" dimensions="nFGLevels nCells Time"/>
+ <var name="t_fg" name_in_code="t" type="real" dimensions="nFGLevels nCells Time" streams="o"/>
+ <var name="p_fg" name_in_code="p" type="real" dimensions="nFGLevels nCells Time" streams="o"/>
+ <var name="z_fg" name_in_code="z" type="real" dimensions="nFGLevels nCells Time" streams="o"/>
+ <var name="rh_fg" name_in_code="rh" type="real" dimensions="nFGLevels nCells Time" streams="o"/>
<var name="soilz_fg" name_in_code="soilz" type="real" dimensions="nCells Time" streams="io"/>
<var name="psfc_fg" name_in_code="psfc" type="real" dimensions="nCells Time"/>
<var name="pmsl_fg" name_in_code="pmsl" type="real" dimensions="nCells Time"/>
@@ -255,6 +268,7 @@
<var name="rho" type="real" dimensions="nVertLevels nCells Time" streams="o"/>
<var name="theta" type="real" dimensions="nVertLevels nCells Time" streams="o"/>
<var name="v" type="real" dimensions="nVertLevels nEdges Time" streams="o"/>
+ <var name="rh" type="real" dimensions="nVertLevels nCells Time" streams="o"/>
<var name="uReconstructX" type="real" dimensions="nVertLevels nCells Time" streams="o"/>
<var name="uReconstructY" type="real" dimensions="nVertLevels nCells Time" streams="o"/>
<var name="uReconstructZ" type="real" dimensions="nVertLevels nCells Time" streams="o"/>
@@ -276,4 +290,8 @@
<var name="rtheta_p" type="real" dimensions="nVertLevels nCells Time"/>
<var name="rho_p" type="real" dimensions="nVertLevels nCells Time"/>
</var_struct>
+
+ <var_struct name="diag_physics" time_levs="1">
+ <var name="precipw" type="real" dimensions="nCells Time" streams="o"/>
+ </var_struct>
</registry>
Modified: trunk/mpas/src/core_init_nhyd_atmos/mpas_init_atm_llxy.F
===================================================================
--- trunk/mpas/src/core_init_nhyd_atmos/mpas_init_atm_llxy.F 2013-03-27 19:24:59 UTC (rev 2673)
+++ trunk/mpas/src/core_init_nhyd_atmos/mpas_init_atm_llxy.F 2013-03-27 19:26:14 UTC (rev 2674)
@@ -1669,7 +1669,7 @@
TYPE (proj_info), INTENT(IN) :: proj
! Local variables
- INTEGER :: ii,imt,jj,jmt,k,krows,ncol,nrow,iri
+ INTEGER :: ii,imt,jj,jmt,ncol,nrow
REAL(KIND=HIGH) :: dphd,dlmd !Grid increments, degrees
REAL(KIND=HIGH) :: glatd !Geographic latitude, positive north
REAL(KIND=HIGH) :: glond !Geographic longitude, positive west
@@ -1839,8 +1839,8 @@
TYPE (proj_info), INTENT(IN) :: proj
! Local variables
- INTEGER :: ih,jh
- INTEGER :: midcol,midrow,ncol,iadd1,iadd2,imt,jh2,knrow,krem,kv,nrow
+ INTEGER :: jh
+ INTEGER :: midcol,midrow
REAL (KIND=RKIND) :: i_work, j_work
REAL (KIND=RKIND) :: dphd,dlmd !Grid increments, degrees
REAL(KIND=HIGH) :: arg1,arg2,d2r,fctr,glatr,glatd,glond,pi, &
Added: trunk/mpas/src/core_init_nhyd_atmos/mpas_init_atm_static.F
===================================================================
--- trunk/mpas/src/core_init_nhyd_atmos/mpas_init_atm_static.F (rev 0)
+++ trunk/mpas/src/core_init_nhyd_atmos/mpas_init_atm_static.F 2013-03-27 19:26:14 UTC (rev 2674)
@@ -0,0 +1,1891 @@
+!==================================================================================================
+ module mpas_init_atm_static
+!==================================================================================================
+ use atm_advection
+ use mpas_configure
+ use mpas_dmpar
+ use init_atm_hinterp
+ use init_atm_llxy
+
+ use mpas_atmphys_utilities
+
+ implicit none
+ private
+ public:: init_atm_static, &
+ init_atm_static_orogwd, &
+ init_atm_check_read_error, &
+ nearest_cell, &
+ sphere_distance
+
+ contains
+
+!==================================================================================================
+ subroutine init_atm_static(mesh)
+!==================================================================================================
+
+!inout arguments:
+ type(mesh_type),intent(inout):: mesh
+
+!local variables:
+ type(proj_info):: proj
+ type(dm_info),pointer :: dminfo
+
+ character(len=StrKIND):: fname
+
+ integer:: nx,ny,nz
+ integer:: endian,isigned,istatus,wordsize
+ integer:: i,j,k
+ integer:: iCell,iPoint,iTileStart,iTileEnd,jTileStart,jTileEnd
+ integer,dimension(5) :: interp_list
+ integer,dimension(:),allocatable :: nhs
+ integer,dimension(:,:),allocatable:: ncat
+
+ real(kind=4):: scalefactor
+ real(kind=4),dimension(:,:,:),allocatable:: rarray
+
+ real(kind=RKIND):: r_earth
+ real(kind=RKIND):: lat,lon,x,y
+ real(kind=RKIND):: lat_pt,lon_pt
+ real(kind=RKIND),dimension(:,:),allocatable :: soiltemp_1deg
+ real(kind=RKIND),dimension(:,:),allocatable :: maxsnowalb
+ real(kind=RKIND),dimension(:,:,:),allocatable:: vegfra
+
+!--------------------------------------------------------------------------------------------------
+ write(0,*)
+ write(0,*) '--- enter subroutine init_atm_static:'
+
+!
+! Scale all distances and areas from a unit sphere to one with radius sphere_radius
+!
+
+ r_earth = mesh % sphere_radius
+
+ mesh % xCell % array = mesh % xCell % array * r_earth
+ mesh % yCell % array = mesh % yCell % array * r_earth
+ mesh % zCell % array = mesh % zCell % array * r_earth
+ mesh % xVertex % array = mesh % xVertex % array * r_earth
+ mesh % yVertex % array = mesh % yVertex % array * r_earth
+ mesh % zVertex % array = mesh % zVertex % array * r_earth
+ mesh % xEdge % array = mesh % xEdge % array * r_earth
+ mesh % yEdge % array = mesh % yEdge % array * r_earth
+ mesh % zEdge % array = mesh % zEdge % array * r_earth
+ mesh % dvEdge % array = mesh % dvEdge % array * r_earth
+ mesh % dcEdge % array = mesh % dcEdge % array * r_earth
+ mesh % areaCell % array = mesh % areaCell % array * r_earth**2.0
+ mesh % areaTriangle % array = mesh % areaTriangle % array * r_earth**2.0
+ mesh % kiteAreasOnVertex % array = mesh % kiteAreasOnVertex % array * r_earth**2.0
+
+ call atm_initialize_advection_rk(mesh)
+ call atm_initialize_deformation_weights(mesh)
+
+!
+! Interpolate HGT
+!
+!nx = 126
+!ny = 126
+ nx = 1206
+ ny = 1206
+ nz = 1
+ isigned = 1
+ endian = 0
+ wordsize = 2
+ scalefactor = 1.0
+ allocate(rarray(nx,ny,nz))
+ allocate(nhs(mesh%nCells))
+ nhs(:) = 0
+ mesh%ter%array(:) = 0.0
+
+ do jTileStart = 1,20401,ny-6
+ jTileEnd = jTileStart + ny - 1 - 6
+
+ do iTileStart=1,42001,nx-6
+ iTileEnd = iTileStart + nx - 1 - 6
+ write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(config_geog_data_path)// &
+ 'topo_30s/',iTileStart,'-',iTileEnd,'.',jTileStart,'-',jTileEnd
+ write(0,*) trim(fname)
+
+ call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, &
+ scalefactor,wordsize,istatus)
+ call init_atm_check_read_error(istatus, fname, dminfo)
+
+ iPoint = 1
+ do j=4,ny-3
+ do i=4,nx-3
+ lat_pt = -89.99583 + (jTileStart + j - 5) * 0.0083333333
+ lon_pt = -179.99583 + (iTileStart + i - 5) * 0.0083333333
+ lat_pt = lat_pt * PI / 180.0
+ lon_pt = lon_pt * PI / 180.0
+
+ iPoint = nearest_cell(lat_pt,lon_pt,iPoint,mesh%nCells,mesh%maxEdges, &
+ mesh%nEdgesOnCell%array,mesh%cellsOnCell%array, &
+ mesh%latCell%array,mesh%lonCell%array)
+ mesh%ter%array(iPoint) = mesh%ter%array(iPoint) + rarray(i,j,1)
+ nhs(iPoint) = nhs(iPoint) + 1
+ end do
+ end do
+
+ end do
+ end do
+
+ do iCell = 1,mesh%nCells
+ mesh%ter%array(iCell) = mesh%ter%array(iCell) / real(nhs(iCell))
+ end do
+ deallocate(rarray)
+ deallocate(nhs)
+ write(0,*) '--- end interpolate TER'
+
+
+!
+! Interpolate LU_INDEX
+!
+ nx = 1200
+ ny = 1200
+ nz = 1
+ isigned = 1
+ endian = 0
+ wordsize = 1
+ scalefactor = 1.0
+ allocate(rarray(nx,ny,nz))
+ allocate(ncat(24,mesh%nCells))
+ ncat(:,:) = 0
+ mesh%lu_index%array(:) = 0.0
+
+ do jTileStart = 1,20401,ny
+ jTileEnd = jTileStart + ny - 1
+
+ do iTileStart = 1,42001,nx
+ iTileEnd = iTileStart + nx - 1
+ write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(config_geog_data_path)// &
+ '/landuse_30s/',iTileStart,'-',iTileEnd,'.',jTileStart,'-',jTileEnd
+ write(0,*) trim(fname)
+
+ call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, &
+ scalefactor,wordsize,istatus)
+ call init_atm_check_read_error(istatus, fname, dminfo)
+
+ iPoint = 1
+ do j=1,ny
+ do i=1,nx
+ lat_pt = -89.99583 + (jTileStart + j - 2) * 0.0083333333
+ lon_pt = -179.99583 + (iTileStart + i - 2) * 0.0083333333
+ lat_pt = lat_pt * PI / 180.0
+ lon_pt = lon_pt * PI / 180.0
+
+ iPoint = nearest_cell(lat_pt,lon_pt,iPoint,mesh%nCells,mesh%maxEdges, &
+ mesh%nEdgesOnCell%array,mesh%cellsOnCell%array, &
+ mesh%latCell%array,mesh%lonCell%array)
+ ncat(int(rarray(i,j,1)),iPoint) = ncat(int(rarray(i,j,1)),iPoint) + 1
+ end do
+ end do
+
+ end do
+ end do
+
+ do iCell = 1,mesh%nCells
+ mesh%lu_index%array(iCell) = 1
+ do i = 2,24
+ if(ncat(i,iCell) > ncat(mesh%lu_index%array(iCell),iCell)) then
+ mesh%lu_index%array(iCell) = i
+ end if
+ end do
+ end do
+ deallocate(rarray)
+ deallocate(ncat)
+ write(0,*) '--- end interpolate LU_INDEX'
+
+
+!
+! Interpolate SOILCAT_TOP
+!
+ nx = 1200
+ ny = 1200
+ nz = 1
+ isigned = 1
+ endian = 0
+ wordsize = 1
+ scalefactor = 1.0
+ allocate(rarray(nx,ny,nz))
+ allocate(ncat(16,mesh%nCells))
+ ncat(:,:) = 0
+ mesh%soilcat_top%array(:) = 0.0
+
+ do jTileStart = 1,20401,ny
+ jTileEnd = jTileStart + ny - 1
+
+ do iTileStart = 1,42001,nx
+ iTileEnd = iTileStart + nx - 1
+ write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(config_geog_data_path)// &
+ '/soiltype_top_30s/',iTileStart,'-',iTileEnd,'.',jTileStart,'-',jTileEnd
+ write(0,*) trim(fname)
+
+ call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, &
+ scalefactor,wordsize,istatus)
+ call init_atm_check_read_error(istatus, fname, dminfo)
+
+ iPoint = 1
+ do j=1,ny
+ do i=1,nx
+ lat_pt = -89.99583 + (jTileStart + j - 2) * 0.0083333333
+ lon_pt = -179.99583 + (iTileStart + i - 2) * 0.0083333333
+ lat_pt = lat_pt * PI / 180.0
+ lon_pt = lon_pt * PI / 180.0
+
+ iPoint = nearest_cell(lat_pt,lon_pt,iPoint,mesh%nCells,mesh%maxEdges, &
+ mesh%nEdgesOnCell%array,mesh%cellsOnCell%array, &
+ mesh%latCell%array,mesh%lonCell%array)
+ ncat(int(rarray(i,j,1)),iPoint) = ncat(int(rarray(i,j,1)),iPoint) + 1
+ end do
+ end do
+
+ end do
+ end do
+
+ do iCell = 1,mesh%nCells
+ mesh%soilcat_top%array(iCell) = 1
+ do i = 2,16
+ if(ncat(i,iCell) > ncat(mesh%soilcat_top%array(iCell),iCell)) then
+ mesh%soilcat_top%array(iCell) = i
+ end if
+ end do
+ end do
+ deallocate(rarray)
+ deallocate(ncat)
+ write(0,*) '--- end interpolate SOILCAT_TOP'
+
+
+!
+! Interpolate SOILCAT_BOT
+!
+ nx = 1200
+ ny = 1200
+ nz = 1
+ isigned = 1
+ endian = 0
+ wordsize = 1
+ scalefactor = 1.0
+ allocate(rarray(nx,ny,nz))
+ allocate(ncat(16,mesh%nCells))
+ ncat(:,:) = 0
+ mesh%soilcat_bot%array(:) = 0.0
+
+ do jTileStart = 1,20401,ny
+ jTileEnd = jTileStart + ny - 1
+
+ do iTileStart = 1,42001,nx
+ iTileEnd = iTileStart + nx - 1
+ write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(config_geog_data_path)// &
+ '/soiltype_bot_30s/',iTileStart,'-',iTileEnd,'.',jTileStart,'-',jTileEnd
+ write(0,*) trim(fname)
+
+ call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, &
+ scalefactor,wordsize,istatus)
+ call init_atm_check_read_error(istatus, fname, dminfo)
+
+ iPoint = 1
+ do j=1,ny
+ do i=1,nx
+ lat_pt = -89.99583 + (jTileStart + j - 2) * 0.0083333333
+ lon_pt = -179.99583 + (iTileStart + i - 2) * 0.0083333333
+ lat_pt = lat_pt * PI / 180.0
+ lon_pt = lon_pt * PI / 180.0
+
+ iPoint = nearest_cell(lat_pt,lon_pt,iPoint,mesh%nCells,mesh%maxEdges, &
+ mesh%nEdgesOnCell%array,mesh%cellsOnCell%array, &
+ mesh%latCell%array,mesh%lonCell%array)
+ ncat(int(rarray(i,j,1)),iPoint) = ncat(int(rarray(i,j,1)),iPoint) + 1
+ end do
+ end do
+
+ end do
+ end do
+
+ do iCell =1, mesh%nCells
+ mesh%soilcat_bot%array(iCell) = 1
+ do i = 2,16
+ if(ncat(i,iCell) > ncat(mesh%soilcat_bot%array(iCell),iCell)) then
+ mesh%soilcat_bot%array(iCell) = i
+ end if
+ end do
+ end do
+ deallocate(rarray)
+ deallocate(ncat)
+ write(0,*) '--- end interpolate SOILCAT_BOT'
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! KLUDGE TO FIX SOIL TYPE OVER ANTARCTICA
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ where (mesh%lu_index%array == 24) mesh%soilcat_top%array = 16
+ where (mesh%lu_index%array == 24) mesh%soilcat_bot%array = 16
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! CORRECT INCONSISTENT SOIL AND LAND USE DATA
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ do iCell = 1,mesh%nCells
+ if (mesh%lu_index%array(iCell) == 16 .or. &
+ mesh%soilcat_top%array(iCell) == 14 .or. &
+ mesh%soilcat_bot%array(iCell) == 14) then
+ if (mesh%lu_index%array(iCell) /= 16) then
+ write(0,*) 'Turning lu_index into water at ', iCell
+ mesh%lu_index%array(iCell) = 16
+ end if
+ if (mesh%soilcat_top%array(iCell) /= 14) then
+ write(0,*) 'Turning soilcat_top into water at ', iCell
+ mesh%soilcat_top%array(iCell) = 14
+ end if
+ if (mesh%soilcat_bot%array(iCell) /= 14) then
+ write(0,*) 'Turning soilcat_bot into water at ', iCell
+ mesh%soilcat_bot%array(iCell) = 14
+ end if
+ end if
+ end do
+
+
+!
+! Derive LANDMASK
+!
+ mesh%landmask%array(:) = 0
+ do iCell=1, mesh%nCells
+ if (mesh%lu_index%array(iCell) /= 16) mesh%landmask%array(iCell) = 1
+ end do
+ write(0,*) '--- end interpolate LANDMASK'
+
+
+!
+! Interpolate SOILTEMP:
+!
+ nx = 186
+ ny = 186
+ nz = 1
+ isigned = 0
+ endian = 0
+ wordsize = 2
+ scalefactor = 0.01
+ allocate(rarray(nx,ny,nz))
+ allocate(soiltemp_1deg(-2:363,-2:183))
+ mesh%soiltemp%array(:) = 0.0
+
+ call map_set(PROJ_LATLON, proj, &
+ latinc = 1.0_RKIND, &
+ loninc = 1.0_RKIND, &
+ knowni = 1.0_RKIND, &
+ knownj = 1.0_RKIND, &
+ lat1 = -89.5_RKIND, &
+ lon1 = -179.5_RKIND)
+
+ write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(config_geog_data_path)// &
+ 'soiltemp_1deg/',1,'-',180,'.',1,'-',180
+ write(0,*) trim(fname)
+
+ call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned, endian, &
+ scalefactor,wordsize,istatus)
+ call init_atm_check_read_error(istatus, fname, dminfo)
+ soiltemp_1deg(-2:180,-2:183) = rarray(1:183,1:186,1)
+
+ write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(config_geog_data_path)// &
+ 'soiltemp_1deg/',181,'-',360,'.',1,'-',180
+ write(0,*) trim(fname)
+
+ call read_geogrid(fname, len_trim(fname),rarray,nx,ny,nz,isigned,endian, &
+ scalefactor,wordsize,istatus)
+ call init_atm_check_read_error(istatus,fname,dminfo)
+ soiltemp_1deg(181:363,-2:183) = rarray(4:186,1:186,1)
+
+ interp_list(1) = FOUR_POINT
+ interp_list(2) = W_AVERAGE4
+ interp_list(3) = W_AVERAGE16
+ interp_list(4) = SEARCH
+ interp_list(5) = 0
+
+ do iCell = 1,mesh%nCells
+
+ if(mesh%landmask%array(iCell) == 1) then
+ lat = mesh % latCell % array(iCell) * DEG_PER_RAD
+ lon = mesh % lonCell % array(iCell) * DEG_PER_RAD
+ call latlon_to_ij(proj, lat, lon, x, y)
+ if(x < 0.5) then
+ lon = lon + 360.0
+ call latlon_to_ij(proj, lat, lon, x, y)
+ else if (x >= 360.5) then
+ lon = lon - 360.0
+ call latlon_to_ij(proj, lat, lon, x, y)
+ end if
+ if (y < 1.0) y = 1.0
+ if (y > 179.0) y = 179.0
+ mesh%soiltemp%array(iCell) = interp_sequence(x,y,1,soiltemp_1deg,-2,363,-2,183, &
+ 1,1,0.0_RKIND,interp_list,1)
+ else
+ mesh%soiltemp%array(iCell) = 0.0
+ end if
+
+ end do
+ deallocate(rarray)
+ deallocate(soiltemp_1deg)
+ write(0,*) '--- end interpolate SOILTEMP'
+
+
+!
+! Interpolate SNOALB
+!
+ nx = 186
+ ny = 186
+ nz = 1
+ isigned = 0
+ endian = 0
+ wordsize = 1
+ scalefactor = 1.0
+ allocate(rarray(nx,ny,nz))
+ allocate(maxsnowalb(-2:363,-2:183))
+ mesh%snoalb%array(:) = 0.0
+
+ call map_set(PROJ_LATLON, proj, &
+ latinc = 1.0_RKIND, &
+ loninc = 1.0_RKIND, &
+ knowni = 1.0_RKIND, &
+ knownj = 1.0_RKIND, &
+ lat1 = -89.5_RKIND, &
+ lon1 = -179.5_RKIND)
+
+ write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(config_geog_data_path)// &
+ 'maxsnowalb/',1,'-',180,'.',1,'-',180
+ write(0,*) trim(fname)
+
+ call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, &
+ scalefactor,wordsize,istatus)
+ call init_atm_check_read_error(istatus,fname,dminfo)
+ maxsnowalb(-2:180,-2:183) = rarray(1:183,1:186,1)
+
+ write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(config_geog_data_path)// &
+ 'maxsnowalb/',181,'-',360,'.',1,'-',180
+ write(0,*) trim(fname)
+
+ call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, &
+ scalefactor,wordsize,istatus)
+ call init_atm_check_read_error(istatus, fname, dminfo)
+ maxsnowalb(181:363,-2:183) = rarray(4:186,1:186,1)
+
+ interp_list(1) = FOUR_POINT
+ interp_list(2) = W_AVERAGE4
+ interp_list(3) = W_AVERAGE16
+ interp_list(4) = SEARCH
+ interp_list(5) = 0
+
+ do iCell = 1,mesh%nCells
+
+ if(mesh%landmask%array(iCell) == 1) then
+ lat = mesh % latCell % array(iCell) * DEG_PER_RAD
+ lon = mesh % lonCell % array(iCell) * DEG_PER_RAD
+ call latlon_to_ij(proj, lat, lon, x, y)
+ if(x < 0.5) then
+ lon = lon + 360.0
+ call latlon_to_ij(proj, lat, lon, x, y)
+ else if (x >= 360.5) then
+ lon = lon - 360.0
+ call latlon_to_ij(proj, lat, lon, x, y)
+ end if
+ if (y < 1.0) y = 1.0
+ if (y > 179.0) y = 179.0
+ mesh%snoalb%array(iCell) = interp_sequence(x,y,1,maxsnowalb,-2,363,-2,183, &
+ 1,1,0.0_RKIND,interp_list,1)
+ else
+ mesh%snoalb%array(iCell) = 0.0
+ end if
+
+ end do
+ mesh%snoalb%array(:) = mesh%snoalb%array(:) / 100.0
+ deallocate(rarray)
+ deallocate(maxsnowalb)
+ write(0,*) '--- end interpolate SNOALB'
+
+
+!
+! Interpolate GREENFRAC
+!
+ nx = 1256
+ ny = 1256
+ nz = 12
+ isigned = 0
+ endian = 0
+ wordsize = 1
+ scalefactor = 1.0
+ allocate(rarray(nx,ny,nz))
+ allocate(vegfra(-2:2503,-2:1253,12))
+ mesh%greenfrac%array(:,:) = 0.0
+
+ call map_set(PROJ_LATLON, proj, &
+ latinc = 0.144_RKIND, &
+ loninc = 0.144_RKIND, &
+ knowni = 1.0_RKIND, &
+ knownj = 1.0_RKIND, &
+ lat1 = -89.928_RKIND, &
+ lon1 = -179.928_RKIND)
+
+ write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(config_geog_data_path)// &
+ 'greenfrac/',1,'-',1250,'.',1,'-',1250
+ write(0,*) trim(fname)
+
+ call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, &
+ scalefactor,wordsize,istatus)
+ call init_atm_check_read_error(istatus,fname,dminfo)
+ vegfra(-2:1250,-2:1253,1:12) = rarray(1:1253,1:1256,1:12)
+
+ write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(config_geog_data_path)// &
+ 'greenfrac/',1251,'-',2500,'.',1,'-',1250
+ write(0,*) trim(fname)
+
+ call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, &
+ scalefactor,wordsize,istatus)
+ call init_atm_check_read_error(istatus,fname,dminfo)
+ vegfra(1251:2503,-2:1253,1:12) = rarray(4:1256,1:1256,1:12)
+
+ do iCell = 1,mesh%nCells
+
+ if (mesh%landmask%array(iCell) == 1) then
+ lat = mesh % latCell % array(iCell) * DEG_PER_RAD
+ lon = mesh % lonCell % array(iCell) * DEG_PER_RAD
+ call latlon_to_ij(proj, lat, lon, x, y)
+ if(x < 0.5) then
+ lon = lon + 360.0
+ call latlon_to_ij(proj, lat, lon, x, y)
+ else if(x >= 2500.5) then
+ lon = lon - 360.0
+ call latlon_to_ij(proj, lat, lon, x, y)
+ end if
+ if (y < 1.0) y = 1.0
+ if (y > 1249.0) y = 1249.0
+ do k = 1,12
+ mesh%greenfrac%array(k,iCell) = interp_sequence(x,y,k,vegfra,-2,2503,-2,1253, &
+ 1,12,-1.e30_RKIND,interp_list,1)
+ end do
+ else
+ mesh%greenfrac%array(:,iCell) = 0.0
+ end if
+ mesh%shdmin%array(iCell) = minval(mesh%greenfrac%array(:,iCell))
+ mesh%shdmax%array(iCell) = maxval(mesh%greenfrac%array(:,iCell))
+
+ end do
+ deallocate(rarray)
+ deallocate(vegfra)
+ write(0,*) '--- end interpolate GREENFRAC'
+
+
+!
+! Interpolate ALBEDO12M
+!
+ nx = 1256
+ ny = 1256
+ nz = 12
+ isigned = 0
+ endian = 0
+ wordsize = 1
+ scalefactor = 1.0
+ allocate(rarray(nx,ny,nz))
+ allocate(vegfra(-2:2503,-2:1253,12))
+ mesh%albedo12m%array(:,:) = 0.0
+
+ call map_set(PROJ_LATLON, proj, &
+ latinc = 0.144_RKIND, &
+ loninc = 0.144_RKIND, &
+ knowni = 1.0_RKIND, &
+ knownj = 1.0_RKIND, &
+ lat1 = -89.928_RKIND, &
+ lon1 = -179.928_RKIND)
+
+ write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(config_geog_data_path)// &
+ 'albedo_ncep/',1,'-',1250,'.',1,'-',1250
+ write(0,*) trim(fname)
+
+ call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, &
+ scalefactor, wordsize, istatus)
+ call init_atm_check_read_error(istatus,fname, dminfo)
+ vegfra(-2:1250,-2:1253,1:12) = rarray(1:1253,1:1256,1:12)
+
+ write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(config_geog_data_path)// &
+ 'albedo_ncep/',1251,'-',2500,'.',1,'-',1250
+ write(0,*) trim(fname)
+
+ call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, &
+ scalefactor,wordsize,istatus)
+ call init_atm_check_read_error(istatus,fname,dminfo)
+ vegfra(1251:2503,-2:1253,1:12) = rarray(4:1256,1:1256,1:12)
+
+ do iCell = 1,mesh%nCells
+
+ if (mesh%landmask%array(iCell) == 1) then
+ lat = mesh % latCell % array(iCell) * DEG_PER_RAD
+ lon = mesh % lonCell % array(iCell) * DEG_PER_RAD
+ call latlon_to_ij(proj, lat, lon, x, y)
+ if(x < 0.5) then
+ lon = lon + 360.0
+ call latlon_to_ij(proj, lat, lon, x, y)
+ else if(x >= 2500.5) then
+ lon = lon - 360.0
+ call latlon_to_ij(proj, lat, lon, x, y)
+ end if
+ if (y < 1.0) y = 1.0
+ if (y > 1249.0) y = 1249.0
+ do k = 1,12
+ mesh%albedo12m%array(k,iCell) = interp_sequence(x,y,k,vegfra,-2,2503,-2,1253, &
+ 1,12,0.0_RKIND,interp_list,1)
+ end do
+ else
+ mesh%albedo12m%array(:,iCell) = 8.0
+ end if
+ end do
+ deallocate(rarray)
+ deallocate(vegfra)
+ write(0,*) '--- end interpolate ALBEDO12M'
+
+
+ end subroutine init_atm_static
+
+!==================================================================================================
+ subroutine init_atm_static_orogwd(mesh)
+!==================================================================================================
+
+!inout arguments:
+ type(mesh_type),intent(inout):: mesh
+
+!local variables:
+ type(proj_info):: proj
+ type(dm_info),pointer :: dminfo
+
+ character(len=StrKIND):: mess
+ character(len=StrKIND):: fname
+ character(len=StrKIND):: dir_gwdo
+
+ integer:: nx,ny,nz
+ integer:: endian,isigned,istatus,wordsize
+ integer:: i,j
+ integer:: iCell,iPoint,iTileStart,iTileEnd,jTileStart,jTileEnd
+ integer,dimension(5) :: interp_list
+ integer,dimension(:),allocatable:: nhs
+
+ real(kind=4):: scalefactor
+ real(kind=4),dimension(:,:,:),allocatable:: rarray
+
+ real(kind=RKIND):: lat,lon,x,y
+ real(kind=RKIND):: lat_pt,lon_pt
+ real(kind=RKIND):: dx,dy,known_lat,known_lon,known_x,known_y
+ real(kind=RKIND):: minMeshD,maxMeshD
+ real(kind=RKIND):: mindcEdge,maxdcEdge
+ real(kind=RKIND),dimension(:,:),allocatable:: xarray
+
+!--------------------------------------------------------------------------------------------------
+ write(0,*)
+ write(0,*) '--- enter subroutine init_atm_static_orogwd:'
+
+!goto 100
+!
+! Interpolate VARSSO:
+ mesh%varsso%array(:) = 0.0_RKIND
+ nx = 600
+ ny = 600
+ nz = 1
+ isigned = 0
+ endian = 0
+ wordsize = 4
+ scalefactor = 1.0
+
+ dx = 0.00833333
+ dy = 0.00833333
+ known_x = 1.0
+ known_y = 1.0
+ known_lat = -59.99583
+ known_lon = -179.99583
+
+ allocate(rarray(nx,ny,nz))
+ allocate(nhs(mesh%nCells))
+ nhs(:) = 0
+ rarray(:,:,:) = 0._RKIND
+ do jTileStart = 1,13801,ny
+ jTileEnd = jTileStart + ny - 1
+
+ do iTileStart = 1,42601,nx
+ iTileEnd = iTileStart + nx -1
+ write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(config_geog_data_path)//'varsso/', &
+ iTileStart,'-',iTileEnd,'.',jTileStart,'-',jTileEnd
+ write(0,*) trim(fname)
+
+ call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, &
+ scalefactor,wordsize,istatus)
+ call init_atm_check_read_error(istatus,fname,dminfo)
+
+ iPoint = 1
+ do j = 1,ny
+ do i = 1,nx
+ lat_pt = known_lat + (jTileStart + j - 2) * dy
+ lon_pt = known_lon + (iTileStart + i - 2) * dx
+ lat_pt = lat_pt * PI / 180.0
+ lon_pt = lon_pt * PI / 180.0
+
+ iPoint = nearest_cell(lat_pt,lon_pt,iPoint,mesh%nCells,mesh%maxEdges, &
+ mesh%nEdgesOnCell%array,mesh%cellsOnCell%array, &
+ mesh%latCell%array,mesh%lonCell%array)
+ mesh%varsso%array(iPoint) = mesh%varsso%array(iPoint) + rarray(i,j,1)
+ nhs(iPoint) = nhs(iPoint) + 1
+ enddo
+ enddo
+
+ enddo
+ enddo
+
+ do iCell = 1,mesh%nCells
+ if(nhs(iCell) .gt. 0) &
+ mesh%varsso%array(iCell) = mesh%varsso%array(iCell) / real(nhs(iCell))
+ enddo
+ deallocate(rarray)
+ deallocate(nhs)
+ write(0,*) '--- end interpolate VARSSO'
+
+! 100 continue
+!... statistic fields needed for the parameterization of gravity wavwe drag over orography. The
+!input directory depends on the mesh resolution, and the mesh must be a uniform mesh.
+ minMeshD = minval(mesh%meshDensity%array(1:mesh%nCells))
+ maxMeshD = maxval(mesh%meshDensity%array(1:mesh%nCells))
+ mindcEdge = minval(mesh%dcEdge%array(1:mesh%nEdges))
+ maxdcEdge = maxval(mesh%dcEdge%array(1:mesh%nEdges))
+
+ write(0,*)
+ write(0,*) 'BEGIN INTERPOLATION OF STATISTICAL FIELDS FOR GRAVITY WAVE DRAG OVER OROGRAPHY'
+ write(0,*) 'min MeshD =', minMeshD
+ write(0,*) 'max MeshD =', maxMeshD
+ write(0,*) 'min dcEdge =', mindcEdge
+ write(0,*) 'max dcEdge =', maxdcEdge
+
+ dir_gwdo = ' '
+ if(minMeshD == 1.0_RKIND .and. maxMeshD == 1.0_RKIND) then
+ !... uniform 10242 mesh:
+ if(mindcEdge .ge. 200000._RKIND .and. maxdcEdge .lt. 260000._RKIND) then
+ dir_gwdo = 'orogwd_2deg'
+ elseif(mindcEdge .ge. 90000._RKIND .and. maxdcEdge .lt. 150000_RKIND) then
+ dir_gwdo = 'orogwd_1deg'
+ elseif(mindcEdge .ge. 40000._RKIND .and. maxdcEdge .lt. 70000._RKIND) then
+ dir_gwdo = 'orogwd_30m'
+ else
+ write(0,*)
+! write(mess,*) 'GWDO: Interpolation not available. The initialization will abort'
+! call physics_error_fatal(mess)
+ write(mess,*) 'GWDO: Interpolation not available. Set config_gwdo_scheme = .false.'
+ return
+ endif
+ else
+ write(0,*)
+! write(mess,*) 'GWDO: The input mesh must be a uniform mesh. The initialization will abort'
+! call physics_error_fatal(mess)
+ write(mess,*) 'GWDO: The input mesh must be a uniform mesh. Set config_gwdo_scheme = .false.'
+ return
+ endif
+ write(0,*) 'dir_gwdo = ', trim(dir_gwdo)
+ write(0,*)
+
+!
+! Interpolate CON:
+!
+ mesh%con%array(:) = 0.0_RKIND
+
+ con_select: select case(dir_gwdo)
+ case("orogwd_2deg")
+ nx = 180
+ ny = 90
+ nz = 1
+ isigned = 0
+ endian = 0
+ wordsize = 2
+ scalefactor = 0.025
+ dx = 2.0
+ dy = 2.0
+ known_x = 1.0
+ known_y = 1.0
+ known_lat = -89.0
+ known_lon = 1.0
+ case("orogwd_1deg")
+ nx = 360
+ ny = 180
+ nz = 1
+ isigned = 0
+ endian = 0
+ wordsize = 2
+ scalefactor = 0.025
+ dx = 1.0
+ dy = 1.0
+ known_x = 1.0
+ known_y = 1.0
+ known_lat = -89.5
+ known_lon = 0.5
+ case("orogwd_30m")
+ nx = 720
+ ny = 360
+ nz = 1
+ isigned = 0
+ endian = 0
+ wordsize = 2
+ scalefactor = 0.025
+ dx = 0.5
+ dy = 0.5
+ known_x = 1.0
+ known_y = 1.0
+ known_lat = -89.75
+ known_lon = 0.25
+ case("orogwd_10m")
+ nx = 2160
+ ny = 1080
+ nz = 1
+ isigned = 0
+ endian = 0
+ wordsize = 2
+ scalefactor = 0.025
+ dx = 0.16666667
+ dy = 0.16666667
+ known_x = 1.0
+ known_y = 1.0
+ known_lat = -89.916667
+ known_lon = 0.0833333
+ case default
+ end select con_select
+
+ write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') &
+ trim(config_geog_data_path)//trim(dir_gwdo)//'/con/',1,'-',nx,'.',1,'-',ny
+ write(0,*) trim(fname)
+
+ allocate(xarray(nx,ny))
+ allocate(rarray(nx,ny,nz))
+ call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, &
+ scalefactor,wordsize,istatus)
+ call init_atm_check_read_error(istatus,fname,dminfo)
+ xarray(1:nx,1:ny) = rarray(1:nx,1:ny,1)
+
+ call map_set(PROJ_LATLON, proj, &
+ latinc = dy, &
+ loninc = dx, &
+ knowni = known_x, &
+ knownj = known_y, &
+ lat1 = known_lat, &
+ lon1 = known_lon)
+
+ interp_list(1) = AVERAGE4
+ interp_list(2) = AVERAGE4
+ interp_list(3) = AVERAGE4
+ interp_list(4) = AVERAGE4
+ interp_list(5) = 0
+
+ do iCell = 1,mesh%nCells
+ if(mesh % landmask % array(iCell) == 1) then
+ lat = mesh % latCell % array(iCell) * DEG_PER_RAD
+ lon = mesh % lonCell % array(iCell) * DEG_PER_RAD
+ call latlon_to_ij(proj, lat, lon, x, y)
+ mesh % con % array(iCell) = interp_sequence(x,y,1,xarray,1,nx,1,ny,1,1, &
+ 0.0_RKIND,interp_list,1)
+ endif
+ enddo
+ deallocate(rarray)
+ deallocate(xarray)
+ write(0,*) '--- end interpolate CON'
+
+!
+! Interpolate OA1:
+!
+ mesh%oa1%array(:) = 0.0_RKIND
+
+ oa1_select: select case(dir_gwdo)
+ case("orogwd_2deg")
+ nx = 180
+ ny = 90
+ nz = 1
+ isigned = 1
+ endian = 0
+ wordsize = 2
+ scalefactor = 0.0001
+ dx = 2.0
+ dy = 2.0
+ known_x = 1.0
+ known_y = 1.0
+ known_lat = -89.0
+ known_lon = 1.0
+ case("orogwd_1deg")
+ nx = 360
+ ny = 180
+ nz = 1
+ isigned = 1
+ endian = 0
+ wordsize = 2
+ scalefactor = 0.0001
+ dx = 1.0
+ dy = 1.0
+ known_x = 1.0
+ known_y = 1.0
+ known_lat = -89.5
+ known_lon = 0.5
+ case("orogwd_30m")
+ nx = 720
+ ny = 360
+ nz = 1
+ isigned = 1
+ endian = 0
+ wordsize = 2
+ scalefactor = 0.0001
+ dx = 0.5
+ dy = 0.5
+ known_x = 1.0
+ known_y = 1.0
+ known_lat = -89.75
+ known_lon = 0.25
+ case("orogwd_10m")
+ nx = 2160
+ ny = 1080
+ nz = 1
+ isigned = 1
+ endian = 0
+ wordsize = 2
+ scalefactor = 0.0001
+ dx = 0.16666667
+ dy = 0.16666667
+ known_x = 1.0
+ known_y = 1.0
+ known_lat = -89.916667
+ known_lon = 0.0833333
+ case default
+ end select oa1_select
+
+ write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') &
+ trim(config_geog_data_path)//trim(dir_gwdo)//'/oa1/',1,'-',nx,'.',1,'-',ny
+ write(0,*) trim(fname)
+
+ allocate(xarray(nx,ny))
+ allocate(rarray(nx,ny,nz))
+ call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, &
+ scalefactor,wordsize,istatus)
+ call init_atm_check_read_error(istatus,fname,dminfo)
+ xarray(1:nx,1:ny) = rarray(1:nx,1:ny,1)
+
+ call map_set(PROJ_LATLON, proj, &
+ latinc = dy, &
+ loninc = dx, &
+ knowni = known_x, &
+ knownj = known_y, &
+ lat1 = known_lat, &
+ lon1 = known_lon)
+
+ interp_list(1) = AVERAGE4
+ interp_list(2) = AVERAGE4
+ interp_list(3) = AVERAGE4
+ interp_list(4) = AVERAGE4
+ interp_list(5) = 0
+
+ do iCell = 1,mesh%nCells
+ if(mesh % landmask % array(iCell) == 1) then
+ lat = mesh % latCell % array(iCell) * DEG_PER_RAD
+ lon = mesh % lonCell % array(iCell) * DEG_PER_RAD
+ call latlon_to_ij(proj, lat, lon, x, y)
+ mesh % oa1 % array(iCell) = interp_sequence(x,y,1,xarray,1,nx,1,ny,1,1, &
+ 0.0_RKIND,interp_list,1)
+ endif
+ enddo
+ deallocate(rarray)
+ deallocate(xarray)
+ write(0,*) '--- end interpolate OA1'
+
+!
+! Interpolate OA2:
+ mesh%oa2%array(:) = 0.0_RKIND
+
+ oa2_select: select case(dir_gwdo)
+ case("orogwd_2deg")
+ nx = 180
+ ny = 90
+ nz = 1
+ isigned = 1
+ endian = 0
+ wordsize = 2
+ scalefactor = 0.0001
+ dx = 2.0
+ dy = 2.0
+ known_x = 1.0
+ known_y = 1.0
+ known_lat = -89.0
+ known_lon = 1.0
+ case("orogwd_1deg")
+ nx = 360
+ ny = 180
+ nz = 1
+ isigned = 1
+ endian = 0
+ wordsize = 2
+ scalefactor = 0.0001
+ dx = 1.0
+ dy = 1.0
+ known_x = 1.0
+ known_y = 1.0
+ known_lat = -89.5
+ known_lon = 0.5
+ case("orogwd_30m")
+ nx = 720
+ ny = 360
+ nz = 1
+ isigned = 1
+ endian = 0
+ wordsize = 2
+ scalefactor = 0.0001
+ dx = 0.5
+ dy = 0.5
+ known_x = 1.0
+ known_y = 1.0
+ known_lat = -89.75
+ known_lon = 0.25
+ case("orogwd_10m")
+ nx = 2160
+ ny = 1080
+ nz = 1
+ isigned = 1
+ endian = 0
+ wordsize = 2
+ scalefactor = 0.0001
+ dx = 0.16666667
+ dy = 0.16666667
+ known_x = 1.0
+ known_y = 1.0
+ known_lat = -89.916667
+ known_lon = 0.0833333
+ case default
+ end select oa2_select
+
+ write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') &
+ trim(config_geog_data_path)//trim(dir_gwdo)//'/oa2/',1,'-',nx,'.',1,'-',ny
+ write(0,*) trim(fname)
+
+ allocate(xarray(nx,ny))
+ allocate(rarray(nx,ny,nz))
+ call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, &
+ scalefactor,wordsize,istatus)
+ call init_atm_check_read_error(istatus,fname,dminfo)
+ xarray(1:nx,1:ny) = rarray(1:nx,1:ny,1)
+
+ call map_set(PROJ_LATLON, proj, &
+ latinc = dy, &
+ loninc = dx, &
+ knowni = known_x, &
+ knownj = known_y, &
+ lat1 = known_lat, &
+ lon1 = known_lon)
+
+ interp_list(1) = AVERAGE4
+ interp_list(2) = AVERAGE4
+ interp_list(3) = AVERAGE4
+ interp_list(4) = AVERAGE4
+ interp_list(5) = 0
+
+ do iCell = 1,mesh%nCells
+ if(mesh % landmask % array(iCell) == 1) then
+ lat = mesh % latCell % array(iCell) * DEG_PER_RAD
+ lon = mesh % lonCell % array(iCell) * DEG_PER_RAD
+ call latlon_to_ij(proj, lat, lon, x, y)
+ mesh % oa2 % array(iCell) = interp_sequence(x,y,1,xarray,1,nx,1,ny,1,1, &
+ 0.0_RKIND,interp_list,1)
+ endif
+ enddo
+ deallocate(rarray)
+ deallocate(xarray)
+ write(0,*) '--- end interpolate OA2'
+
+!
+! Interpolate OA3:
+!
+ mesh%oa3%array(:) = 0.0_RKIND
+
+ oa3_select: select case(dir_gwdo)
+ case("orogwd_2deg")
+ nx = 180
+ ny = 90
+ nz = 1
+ isigned = 1
+ endian = 0
+ wordsize = 2
+ scalefactor = 0.0001
+ dx = 2.0
+ dy = 2.0
+ known_x = 1.0
+ known_y = 1.0
+ known_lat = -89.0
+ known_lon = 1.0
+ case("orogwd_1deg")
+ nx = 360
+ ny = 180
+ nz = 1
+ isigned = 1
+ endian = 0
+ wordsize = 2
+ scalefactor = 0.0001
+ dx = 1.0
+ dy = 1.0
+ known_x = 1.0
+ known_y = 1.0
+ known_lat = -89.5
+ known_lon = 0.5
+ case("orogwd_30m")
+ nx = 720
+ ny = 360
+ nz = 1
+ isigned = 1
+ endian = 0
+ wordsize = 2
+ scalefactor = 0.0001
+ dx = 0.5
+ dy = 0.5
+ known_x = 1.0
+ known_y = 1.0
+ known_lat = -89.75
+ known_lon = 0.25
+ case("orogwd_10m")
+ nx = 2160
+ ny = 1080
+ nz = 1
+ isigned = 1
+ endian = 0
+ wordsize = 2
+ scalefactor = 0.0001
+ dx = 0.16666667
+ dy = 0.16666667
+ known_x = 1.0
+ known_y = 1.0
+ known_lat = -89.916667
+ known_lon = 0.0833333
+ case default
+ end select oa3_select
+
+ write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') &
+ trim(config_geog_data_path)//trim(dir_gwdo)//'/oa3/',1,'-',nx,'.',1,'-',ny
+ write(0,*) trim(fname)
+
+ allocate(xarray(nx,ny))
+ allocate(rarray(nx,ny,nz))
+ call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, &
+ scalefactor,wordsize,istatus)
+ call init_atm_check_read_error(istatus,fname,dminfo)
+ xarray(1:nx,1:ny) = rarray(1:nx,1:ny,1)
+
+ call map_set(PROJ_LATLON, proj, &
+ latinc = dy, &
+ loninc = dx, &
+ knowni = known_x, &
+ knownj = known_y, &
+ lat1 = known_lat, &
+ lon1 = known_lon)
+
+ interp_list(1) = AVERAGE4
+ interp_list(2) = AVERAGE4
+ interp_list(3) = AVERAGE4
+ interp_list(4) = AVERAGE4
+ interp_list(5) = 0
+
+ do iCell = 1,mesh%nCells
+ if(mesh % landmask % array(iCell) == 1) then
+ lat = mesh % latCell % array(iCell) * DEG_PER_RAD
+ lon = mesh % lonCell % array(iCell) * DEG_PER_RAD
+ call latlon_to_ij(proj, lat, lon, x, y)
+ mesh % oa3 % array(iCell) = interp_sequence(x,y,1,xarray,1,nx,1,ny,1,1, &
+ 0.0_RKIND,interp_list,1)
+ endif
+ enddo
+ deallocate(rarray)
+ deallocate(xarray)
+ write(0,*) '--- end interpolate OA3'
+
+!
+! Interpolate OA4:
+!
+ mesh%oa4%array(:) = 0.0_RKIND
+
+ oa4_select: select case(dir_gwdo)
+ case("orogwd_2deg")
+ nx = 180
+ ny = 90
+ nz = 1
+ isigned = 1
+ endian = 0
+ wordsize = 2
+ scalefactor = 0.0001
+ dx = 2.0
+ dy = 2.0
+ known_x = 1.0
+ known_y = 1.0
+ known_lat = -89.0
+ known_lon = 1.0
+ case("orogwd_1deg")
+ nx = 360
+ ny = 180
+ nz = 1
+ isigned = 1
+ endian = 0
+ wordsize = 2
+ scalefactor = 0.0001
+ dx = 1.0
+ dy = 1.0
+ known_x = 1.0
+ known_y = 1.0
+ known_lat = -89.5
+ known_lon = 0.5
+ case("orogwd_30m")
+ nx = 720
+ ny = 360
+ nz = 1
+ isigned = 1
+ endian = 0
+ wordsize = 2
+ scalefactor = 0.0001
+ dx = 0.5
+ dy = 0.5
+ known_x = 1.0
+ known_y = 1.0
+ known_lat = -89.75
+ known_lon = 0.25
+ case("orogwd_10m")
+ nx = 2160
+ ny = 1080
+ nz = 1
+ isigned = 1
+ endian = 0
+ wordsize = 2
+ scalefactor = 0.0001
+ dx = 0.16666667
+ dy = 0.16666667
+ known_x = 1.0
+ known_y = 1.0
+ known_lat = -89.916667
+ known_lon = 0.0833333
+ case default
+ end select oa4_select
+
+ write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') &
+ trim(config_geog_data_path)//trim(dir_gwdo)//'/oa4/',1,'-',nx,'.',1,'-',ny
+ write(0,*) trim(fname)
+
+ allocate(xarray(nx,ny))
+ allocate(rarray(nx,ny,nz))
+ call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, &
+ scalefactor,wordsize,istatus)
+ call init_atm_check_read_error(istatus,fname,dminfo)
+ xarray(1:nx,1:ny) = rarray(1:nx,1:ny,1)
+
+ call map_set(PROJ_LATLON, proj, &
+ latinc = dy, &
+ loninc = dx, &
+ knowni = known_x, &
+ knownj = known_y, &
+ lat1 = known_lat, &
+ lon1 = known_lon)
+
+ interp_list(1) = AVERAGE4
+ interp_list(2) = AVERAGE4
+ interp_list(3) = AVERAGE4
+ interp_list(4) = AVERAGE4
+ interp_list(5) = 0
+
+ do iCell = 1,mesh%nCells
+ if(mesh % landmask % array(iCell) == 1) then
+ lat = mesh % latCell % array(iCell) * DEG_PER_RAD
+ lon = mesh % lonCell % array(iCell) * DEG_PER_RAD
+ call latlon_to_ij(proj, lat, lon, x, y)
+ mesh % oa4 % array(iCell) = interp_sequence(x,y,1,xarray,1,nx,1,ny,1,1, &
+ 0.0_RKIND,interp_list,1)
+ endif
+ enddo
+ deallocate(rarray)
+ deallocate(xarray)
+ write(0,*) '--- end interpolate OA4'
+
+!
+! Interpolate OL1:
+!
+ mesh%ol1%array(:) = 0.0_RKIND
+
+ ol1_select: select case(dir_gwdo)
+ case("orogwd_2deg")
+ nx = 180
+ ny = 90
+ nz = 1
+ isigned = 0
+ endian = 0
+ wordsize = 2
+ scalefactor = 0.0001
+ dx = 2.0
+ dy = 2.0
+ known_x = 1.0
+ known_y = 1.0
+ known_lat = -89.0
+ known_lon = 1.0
+ case("orogwd_1deg")
+ nx = 360
+ ny = 180
+ nz = 1
+ isigned = 0
+ endian = 0
+ wordsize = 2
+ scalefactor = 0.0001
+ dx = 1.0
+ dy = 1.0
+ known_x = 1.0
+ known_y = 1.0
+ known_lat = -89.5
+ known_lon = 0.5
+ case("orogwd_30m")
+ nx = 720
+ ny = 360
+ nz = 1
+ isigned = 0
+ endian = 0
+ wordsize = 2
+ scalefactor = 0.0001
+ dx = 0.5
+ dy = 0.5
+ known_x = 1.0
+ known_y = 1.0
+ known_lat = -89.75
+ known_lon = 0.25
+ case("orogwd_10m")
+ nx = 2160
+ ny = 1080
+ nz = 1
+ isigned = 0
+ endian = 0
+ wordsize = 2
+ scalefactor = 0.0001
+ dx = 0.16666667
+ dy = 0.16666667
+ known_x = 1.0
+ known_y = 1.0
+ known_lat = -89.916667
+ known_lon = 0.0833333
+ case default
+ end select ol1_select
+
+ write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') &
+ trim(config_geog_data_path)//trim(dir_gwdo)//'/ol1/',1,'-',nx,'.',1,'-',ny
+ write(0,*) trim(fname)
+
+ allocate(xarray(nx,ny))
+ allocate(rarray(nx,ny,nz))
+ call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, &
+ scalefactor,wordsize,istatus)
+ call init_atm_check_read_error(istatus,fname,dminfo)
+ xarray(1:nx,1:ny) = rarray(1:nx,1:ny,1)
+
+ call map_set(PROJ_LATLON, proj, &
+ latinc = dy, &
+ loninc = dx, &
+ knowni = known_x, &
+ knownj = known_y, &
+ lat1 = known_lat, &
+ lon1 = known_lon)
+
+ interp_list(1) = AVERAGE4
+ interp_list(2) = AVERAGE4
+ interp_list(3) = AVERAGE4
+ interp_list(4) = AVERAGE4
+ interp_list(5) = 0
+
+ do iCell = 1,mesh%nCells
+ if(mesh % landmask % array(iCell) == 1) then
+ lat = mesh % latCell % array(iCell) * DEG_PER_RAD
+ lon = mesh % lonCell % array(iCell) * DEG_PER_RAD
+ call latlon_to_ij(proj, lat, lon, x, y)
+ mesh % ol1 % array(iCell) = interp_sequence(x,y,1,xarray,1,nx,1,ny,1,1, &
+ 0.0_RKIND,interp_list,1)
+ endif
+ enddo
+ deallocate(rarray)
+ deallocate(xarray)
+ write(0,*) '--- end interpolate OL1'
+
+!
+! Interpolate OL2:
+!
+ mesh%ol2%array(:) = 0.0_RKIND
+
+ ol2_select: select case(dir_gwdo)
+ case("orogwd_2deg")
+ nx = 180
+ ny = 90
+ nz = 1
+ isigned = 0
+ endian = 0
+ wordsize = 2
+ scalefactor = 0.0001
+ dx = 2.0
+ dy = 2.0
+ known_x = 1.0
+ known_y = 1.0
+ known_lat = -89.0
+ known_lon = 1.0
+ case("orogwd_1deg")
+ nx = 360
+ ny = 180
+ nz = 1
+ isigned = 0
+ endian = 0
+ wordsize = 2
+ scalefactor = 0.0001
+ dx = 1.0
+ dy = 1.0
+ known_x = 1.0
+ known_y = 1.0
+ known_lat = -89.5
+ known_lon = 0.5
+ case("orogwd_30m")
+ nx = 720
+ ny = 360
+ nz = 1
+ isigned = 0
+ endian = 0
+ wordsize = 2
+ scalefactor = 0.0001
+ dx = 0.5
+ dy = 0.5
+ known_x = 1.0
+ known_y = 1.0
+ known_lat = -89.75
+ known_lon = 0.25
+ case("orogwd_10m")
+ nx = 2160
+ ny = 1080
+ nz = 1
+ isigned = 0
+ endian = 0
+ wordsize = 2
+ scalefactor = 0.0001
+ dx = 0.16666667
+ dy = 0.16666667
+ known_x = 1.0
+ known_y = 1.0
+ known_lat = -89.916667
+ known_lon = 0.0833333
+ case default
+ end select ol2_select
+
+ write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') &
+ trim(config_geog_data_path)//trim(dir_gwdo)//'/ol2/',1,'-',nx,'.',1,'-',ny
+ write(0,*) trim(fname)
+
+ allocate(xarray(nx,ny))
+ allocate(rarray(nx,ny,nz))
+ call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, &
+ scalefactor,wordsize,istatus)
+ call init_atm_check_read_error(istatus,fname,dminfo)
+ xarray(1:nx,1:ny) = rarray(1:nx,1:ny,1)
+
+ call map_set(PROJ_LATLON, proj, &
+ latinc = dy, &
+ loninc = dx, &
+ knowni = known_x, &
+ knownj = known_y, &
+ lat1 = known_lat, &
+ lon1 = known_lon)
+
+ interp_list(1) = AVERAGE4
+ interp_list(2) = AVERAGE4
+ interp_list(3) = AVERAGE4
+ interp_list(4) = AVERAGE4
+ interp_list(5) = 0
+
+ do iCell = 1,mesh%nCells
+ if(mesh % landmask % array(iCell) == 1) then
+ lat = mesh % latCell % array(iCell) * DEG_PER_RAD
+ lon = mesh % lonCell % array(iCell) * DEG_PER_RAD
+ call latlon_to_ij(proj, lat, lon, x, y)
+ mesh % ol2 % array(iCell) = interp_sequence(x,y,1,xarray,1,nx,1,ny,1,1, &
+ 0.0_RKIND,interp_list,1)
+ endif
+ enddo
+ deallocate(rarray)
+ deallocate(xarray)
+ write(0,*) '--- end interpolate OL2'
+
+!
+! Interpolate OL3:
+!
+ mesh%ol3%array(:) = 0.0_RKIND
+
+ ol3_select: select case(dir_gwdo)
+ case("orogwd_2deg")
+ nx = 180
+ ny = 90
+ nz = 1
+ isigned = 0
+ endian = 0
+ wordsize = 2
+ scalefactor = 0.0001
+ dx = 2.0
+ dy = 2.0
+ known_x = 1.0
+ known_y = 1.0
+ known_lat = -89.0
+ known_lon = 1.0
+ case("orogwd_1deg")
+ nx = 360
+ ny = 180
+ nz = 1
+ isigned = 0
+ endian = 0
+ wordsize = 2
+ scalefactor = 0.0001
+ dx = 1.0
+ dy = 1.0
+ known_x = 1.0
+ known_y = 1.0
+ known_lat = -89.5
+ known_lon = 0.5
+ case("orogwd_30m")
+ nx = 720
+ ny = 360
+ nz = 1
+ isigned = 0
+ endian = 0
+ wordsize = 2
+ scalefactor = 0.0001
+ dx = 0.5
+ dy = 0.5
+ known_x = 1.0
+ known_y = 1.0
+ known_lat = -89.75
+ known_lon = 0.25
+ case("orogwd_10m")
+ nx = 2160
+ ny = 1080
+ nz = 1
+ isigned = 0
+ endian = 0
+ wordsize = 2
+ scalefactor = 0.0001
+ dx = 0.16666667
+ dy = 0.16666667
+ known_x = 1.0
+ known_y = 1.0
+ known_lat = -89.916667
+ known_lon = 0.0833333
+ case default
+ end select ol3_select
+
+ write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') &
+ trim(config_geog_data_path)//trim(dir_gwdo)//'/ol3/',1,'-',nx,'.',1,'-',ny
+ write(0,*) trim(fname)
+
+ allocate(xarray(nx,ny))
+ allocate(rarray(nx,ny,nz))
+ call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, &
+ scalefactor,wordsize,istatus)
+ call init_atm_check_read_error(istatus,fname,dminfo)
+ xarray(1:nx,1:ny) = rarray(1:nx,1:ny,1)
+
+ call map_set(PROJ_LATLON, proj, &
+ latinc = dy, &
+ loninc = dx, &
+ knowni = known_x, &
+ knownj = known_y, &
+ lat1 = known_lat, &
+ lon1 = known_lon)
+
+ interp_list(1) = AVERAGE4
+ interp_list(2) = AVERAGE4
+ interp_list(3) = AVERAGE4
+ interp_list(4) = AVERAGE4
+ interp_list(5) = 0
+
+ do iCell = 1,mesh%nCells
+ if(mesh % landmask % array(iCell) == 1) then
+ lat = mesh % latCell % array(iCell) * DEG_PER_RAD
+ lon = mesh % lonCell % array(iCell) * DEG_PER_RAD
+ call latlon_to_ij(proj, lat, lon, x, y)
+ mesh % ol3 % array(iCell) = interp_sequence(x,y,1,xarray,1,nx,1,ny,1,1, &
+ 0.0_RKIND,interp_list,1)
+ endif
+ enddo
+ deallocate(rarray)
+ deallocate(xarray)
+ write(0,*) '--- end interpolate OL3'
+
+!
+! Interpolate OL4:
+!
+ mesh%ol4%array(:) = 0.0_RKIND
+
+ ol4_select: select case(dir_gwdo)
+ case("orogwd_2deg")
+ nx = 180
+ ny = 90
+ nz = 1
+ isigned = 0
+ endian = 0
+ wordsize = 2
+ scalefactor = 0.0001
+ dx = 2.0
+ dy = 2.0
+ known_x = 1.0
+ known_y = 1.0
+ known_lat = -89.0
+ known_lon = 1.0
+ case("orogwd_1deg")
+ nx = 360
+ ny = 180
+ nz = 1
+ isigned = 0
+ endian = 0
+ wordsize = 2
+ scalefactor = 0.0001
+ dx = 1.0
+ dy = 1.0
+ known_x = 1.0
+ known_y = 1.0
+ known_lat = -89.5
+ known_lon = 0.5
+ case("orogwd_30m")
+ nx = 720
+ ny = 360
+ nz = 1
+ isigned = 0
+ endian = 0
+ wordsize = 2
+ scalefactor = 0.0001
+ dx = 0.5
+ dy = 0.5
+ known_x = 1.0
+ known_y = 1.0
+ known_lat = -89.75
+ known_lon = 0.25
+ case("orogwd_10m")
+ nx = 2160
+ ny = 1080
+ nz = 1
+ isigned = 0
+ endian = 0
+ wordsize = 2
+ scalefactor = 0.0001
+ dx = 0.16666667
+ dy = 0.16666667
+ known_x = 1.0
+ known_y = 1.0
+ known_lat = -89.916667
+ known_lon = 0.0833333
+ case default
+ end select ol4_select
+
+ write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') &
+ trim(config_geog_data_path)//trim(dir_gwdo)//'/ol4/',1,'-',nx,'.',1,'-',ny
+ write(0,*) trim(fname)
+
+ allocate(xarray(nx,ny))
+ allocate(rarray(nx,ny,nz))
+ call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, &
+ scalefactor,wordsize,istatus)
+ call init_atm_check_read_error(istatus,fname,dminfo)
+ xarray(1:nx,1:ny) = rarray(1:nx,1:ny,1)
+
+ call map_set(PROJ_LATLON, proj, &
+ latinc = dy, &
+ loninc = dx, &
+ knowni = known_x, &
+ knownj = known_y, &
+ lat1 = known_lat, &
+ lon1 = known_lon)
+
+ interp_list(1) = AVERAGE4
+ interp_list(2) = AVERAGE4
+ interp_list(3) = AVERAGE4
+ interp_list(4) = AVERAGE4
+ interp_list(5) = 0
+
+ do iCell = 1,mesh%nCells
+ if(mesh % landmask % array(iCell) == 1) then
+ lat = mesh % latCell % array(iCell) * DEG_PER_RAD
+ lon = mesh % lonCell % array(iCell) * DEG_PER_RAD
+ call latlon_to_ij(proj, lat, lon, x, y)
+ mesh % ol4 % array(iCell) = interp_sequence(x,y,1,xarray,1,nx,1,ny,1,1, &
+ 0.0_RKIND,interp_list,1)
+ endif
+ enddo
+ deallocate(rarray)
+ deallocate(xarray)
+ write(0,*) '--- end interpolate OL4'
+
+!
+! Interpolate VAR2D:
+!
+ mesh%var2d%array(:) = 0.0_RKIND
+
+ var2d_select: select case(dir_gwdo)
+ case("orogwd_2deg")
+ nx = 180
+ ny = 90
+ nz = 1
+ isigned = 0
+ endian = 0
+ wordsize = 4
+ scalefactor = 0.02
+ dx = 2.0
+ dy = 2.0
+ known_x = 1.0
+ known_y = 1.0
+ known_lat = -89.0
+ known_lon = 1.0
+ case("orogwd_1deg")
+ nx = 360
+ ny = 180
+ nz = 1
+ isigned = 0
+ endian = 0
+ wordsize = 4
+ scalefactor = 0.02
+ dx = 1.0
+ dy = 1.0
+ known_x = 1.0
+ known_y = 1.0
+ known_lat = -89.5
+ known_lon = 0.5
+ case("orogwd_30m")
+ nx = 720
+ ny = 360
+ nz = 1
+ isigned = 0
+ endian = 0
+ wordsize = 4
+ scalefactor = 0.02
+ dx = 0.5
+ dy = 0.5
+ known_x = 1.0
+ known_y = 1.0
+ known_lat = -89.75
+ known_lon = 0.25
+ case("orogwd_10m")
+ nx = 2160
+ ny = 1080
+ nz = 1
+ isigned = 0
+ endian = 0
+ wordsize = 2
+ scalefactor = 0.02
+ dx = 0.16666667
+ dy = 0.16666667
+ known_x = 1.0
+ known_y = 1.0
+ known_lat = -89.916667
+ known_lon = 0.0833333
+ case default
+ end select var2d_select
+
+ write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') &
+ trim(config_geog_data_path)//trim(dir_gwdo)//'/var/',1,'-',nx,'.',1,'-',ny
+ write(0,*) trim(fname)
+
+
+ allocate(xarray(nx,ny))
+ allocate(rarray(nx,ny,nz))
+ call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, &
+ scalefactor,wordsize,istatus)
+ call init_atm_check_read_error(istatus,fname,dminfo)
+ xarray(1:nx,1:ny) = rarray(1:nx,1:ny,1)
+
+ call map_set(PROJ_LATLON, proj, &
+ latinc = dy, &
+ loninc = dx, &
+ knowni = known_x, &
+ knownj = known_y, &
+ lat1 = known_lat, &
+ lon1 = known_lon)
+
+ interp_list(1) = AVERAGE4
+ interp_list(2) = AVERAGE4
+ interp_list(3) = AVERAGE4
+ interp_list(4) = AVERAGE4
+ interp_list(5) = 0
+
+ do iCell = 1,mesh%nCells
+ if(mesh % landmask % array(iCell) == 1) then
+ lat = mesh % latCell % array(iCell) * DEG_PER_RAD
+ lon = mesh % lonCell % array(iCell) * DEG_PER_RAD
+ call latlon_to_ij(proj, lat, lon, x, y)
+ mesh % var2d % array(iCell) = interp_sequence(x,y,1,xarray,1,nx,1,ny,1,1, &
+ 0.0_RKIND,interp_list,1)
+ endif
+ enddo
+ deallocate(rarray)
+ deallocate(xarray)
+ write(0,*) '--- end interpolate VAR2D'
+
+ end subroutine init_atm_static_orogwd
+
+!==================================================================================================
+ subroutine init_atm_check_read_error(istatus, fname, dminfo)
+!==================================================================================================
+ implicit none
+
+ integer, intent(in) :: istatus
+ character (len=*), intent(in) :: fname
+ type (dm_info), intent(in) :: dminfo
+
+ if (istatus /= 0) then
+ write(0,*) 'ERROR: Could not read file '//trim(fname)
+ call mpas_dmpar_abort(dminfo)
+ end if
+
+ end subroutine init_atm_check_read_error
+
+!==================================================================================================
+ integer function nearest_cell(target_lat, target_lon, start_cell, nCells, maxEdges, &
+ nEdgesOnCell, cellsOnCell, latCell, lonCell)
+!==================================================================================================
+ implicit none
+
+ real (kind=RKIND), intent(in) :: target_lat, target_lon
+ integer, intent(in) :: start_cell
+ integer, intent(in) :: nCells, maxEdges
+ integer, dimension(nCells), intent(in) :: nEdgesOnCell
+ integer, dimension(maxEdges,nCells), intent(in) :: cellsOnCell
+ real (kind=RKIND), dimension(nCells), intent(in) :: latCell, lonCell
+
+ integer :: i
+ integer :: iCell
+ integer :: current_cell
+ real (kind=RKIND) :: current_distance, d
+ real (kind=RKIND) :: nearest_distance
+
+ nearest_cell = start_cell
+ current_cell = -1
+
+ do while (nearest_cell /= current_cell)
+ current_cell = nearest_cell
+ current_distance = sphere_distance(latCell(current_cell), lonCell(current_cell), target_lat, &
+ target_lon, 1.0_RKIND)
+ nearest_cell = current_cell
+ nearest_distance = current_distance
+ do i = 1, nEdgesOnCell(current_cell)
+ iCell = cellsOnCell(i,current_cell)
+ if (iCell <= nCells) then
+ d = sphere_distance(latCell(iCell), lonCell(iCell), target_lat, target_lon, 1.0_RKIND)
+ if (d < nearest_distance) then
+ nearest_cell = iCell
+ nearest_distance = d
+ end if
+ end if
+ end do
+ end do
+
+ end function nearest_cell
+
+!==================================================================================================
+ real (kind=RKIND) function sphere_distance(lat1, lon1, lat2, lon2, radius)
+
+!Compute the great-circle distance between (lat1, lon1) and (lat2, lon2) on a
+!sphere with given radius.
+!==================================================================================================
+ implicit none
+
+ real (kind=RKIND), intent(in) :: lat1, lon1, lat2, lon2, radius
+ real (kind=RKIND) :: arg1
+
+ arg1 = sqrt( sin(0.5*(lat2-lat1))**2 + &
+ cos(lat1)*cos(lat2)*sin(0.5*(lon2-lon1))**2 )
+ sphere_distance = 2.*radius*asin(arg1)
+
+ end function sphere_distance
+
+!==================================================================================================
+ end module mpas_init_atm_static
+!==================================================================================================
Added: trunk/mpas/src/core_init_nhyd_atmos/mpas_init_atm_surface.F
===================================================================
--- trunk/mpas/src/core_init_nhyd_atmos/mpas_init_atm_surface.F (rev 0)
+++ trunk/mpas/src/core_init_nhyd_atmos/mpas_init_atm_surface.F 2013-03-27 19:26:14 UTC (rev 2674)
@@ -0,0 +1,315 @@
+!==================================================================================================
+ module mpas_init_atm_surface
+ use mpas_configure
+ use mpas_grid_types
+ use mpas_io_output
+ use mpas_timekeeping
+ use mpas_timer
+
+ use init_atm_hinterp
+ use init_atm_llxy
+ use init_atm_read_met
+
+ implicit none
+ private
+ public:: init_atm_test_case_sfc,interp_sfc_to_MPAS
+
+ contains
+
+!==================================================================================================
+ subroutine init_atm_test_case_sfc(domain,dminfo,mesh,fg,state)
+!==================================================================================================
+
+!input arguments:
+ type(domain_type), intent(inout):: domain
+ type(dm_info), intent(in) :: dminfo
+ type(mesh_type), intent(inout) :: mesh
+ type(fg_type), intent(inout) :: fg
+ type (state_type), intent(inout):: state
+
+!local variables:
+ type(MPAS_Clock_type) :: fg_clock
+ type(MPAS_Time_type) :: start_time,stop_time,curr_time
+ type(MPAS_TimeInterval_type):: fg_interval
+
+ type(io_output_object):: sfc_update_obj
+
+ character(len=StrKIND) :: timeString
+
+!==================================================================================================
+
+!set up clock to step through all intermediate file dates to be processed:
+ call mpas_set_time(start_time, dateTimeString=trim(config_start_time))
+ call mpas_set_time(stop_time, dateTimeString=trim(config_stop_time))
+ call mpas_set_timeInterval(fg_interval, S=config_fg_interval)
+ call mpas_create_clock(fg_clock, start_time, fg_interval, stopTime=stop_time)
+
+!initialize the output file
+ sfc_update_obj % time = 1
+ sfc_update_obj % filename = trim(config_sfc_update_name)
+
+ call mpas_output_state_init(sfc_update_obj, domain, "SFC")
+
+!loop over all times:
+ curr_time = mpas_get_clock_time(fg_clock, MPAS_NOW)
+
+ do while (curr_time <= stop_time)
+ call mpas_get_time(curr_time, dateTimeString=timeString)
+! write(0,*) 'Processing ',trim(config_sfc_prefix)//':'//timeString(1:13)
+
+ !read the sea-surface temperature and sea-ice data from the surface file, and interpolate the
+ !data to the MPAS grid:
+ call interp_sfc_to_MPAS(timeString(1:13),mesh,fg,dminfo)
+
+ !write the interpolated SST/SKINTEMP field as a new time slice in the MPAS output file:
+ call mpas_output_state_for_domain(sfc_update_obj, domain, sfc_update_obj % time)
+ sfc_update_obj % time = sfc_update_obj % time + 1
+
+ call mpas_advance_clock(fg_clock)
+ curr_time = mpas_get_clock_time(fg_clock, MPAS_NOW)
+
+ call mpas_get_time(curr_time, dateTimeString=timeString)
+ state % xtime % scalar = timeString
+
+ enddo
+
+ call mpas_output_state_finalize(sfc_update_obj, dminfo)
+
+ end subroutine init_atm_test_case_sfc
+
+!==================================================================================================
+ subroutine interp_sfc_to_MPAS(timeString,mesh,fg,dminfo)
+!==================================================================================================
+
+!input arguments:
+ character(len=*),intent(in):: timeString
+ type(mesh_type), intent(in):: mesh
+ type(dm_info),intent(in) :: dminfo
+
+!inout arguments:
+ type(fg_type), intent(inout):: fg
+
+!local variables:
+ type(met_data) :: field !real*4 meteorological data.
+
+ integer:: istatus
+ integer:: masked
+ integer,dimension(5):: interp_list
+ integer,dimension(:),pointer:: mask_array
+
+ real(kind=RKIND):: fillval,maskval,msgval
+ real(kind=RKIND),dimension(:,:),allocatable:: maskslab
+
+ real(kind=RKIND), dimension(:), pointer:: destField1d
+
+!==================================================================================================
+ mask_array => mesh % landmask % array
+
+!open intermediate file:
+ call read_met_init(trim(config_sfc_prefix),.false.,timeString,istatus)
+ if(istatus /= 0) then
+ write(0,*) 'Error reading ',trim(config_sfc_prefix)//':'//timeString(1:13)
+ call mpas_dmpar_abort(dminfo)
+ else
+ write(0,*) 'Processing file ',trim(config_sfc_prefix)//':'//timeString(1:13)
+ endif
+
+!scan through all fields in the file, looking for the LANDSEA field:
+ call read_next_met_field(field,istatus)
+ do while (istatus == 0)
+ if(index(field % field, 'LANDSEA') /= 0) then
+ if(.not.allocated(maskslab)) allocate(maskslab(-2:field % nx+3, field % ny))
+ maskslab(1:field % nx, 1:field % ny) = field % slab(1:field % nx, 1:field % ny)
+ maskslab(0, 1:field % ny) = field % slab(field % nx, 1:field % ny)
+ maskslab(-1, 1:field % ny) = field % slab(field % nx-1, 1:field % ny)
+ maskslab(-2, 1:field % ny) = field % slab(field % nx-2, 1:field % ny)
+ maskslab(field % nx+1, 1:field % ny) = field % slab(1, 1:field % ny)
+ maskslab(field % nx+2, 1:field % ny) = field % slab(2, 1:field % ny)
+ maskslab(field % nx+3, 1:field % ny) = field % slab(3, 1:field % ny)
+! write(0,*) 'minval, maxval of LANDSEA = ', minval(maskslab), maxval(maskslab)
+ endif
+ deallocate(field % slab)
+ call read_next_met_field(field,istatus)
+ enddo
+ call read_met_close()
+
+!read sea-surface temperatures and seaice data. open intermediate file:
+ call read_met_init(trim(config_sfc_prefix),.false.,timeString(1:13),istatus)
+ if(istatus /= 0) then
+ write(0,*) 'Error reading ',trim(config_sfc_prefix)//':'//timeString(1:13)
+ call mpas_dmpar_abort(dminfo)
+ endif
+
+!scan through all fields in the file, looking for the SST,SKINTEMP, or SEAICE field:
+ call read_next_met_field(field,istatus)
+ do while (istatus == 0)
+
+ !sea-surface data:
+ if(index(field % field, 'SKINTEMP') /= 0 .or. index(field % field, 'SST') /= 0) then
+! write(0,*) '... Processing SST:'
+ fg % sst % array(1:mesh%nCells) = 0.0_RKIND
+ destField1d => fg % sst % array
+
+ !interpolation to the MPAS grid:
+ interp_list(1) = FOUR_POINT
+ interp_list(2) = SEARCH
+ interp_list(3) = 0
+ interp_list(4) = SEARCH
+ interp_list(5) = 0
+ msgval = -1.0e30_RKIND !missing value
+ masked = -1
+ maskval = -1.0_RKIND
+ fillval = 0.0_RKIND
+ call interp_to_MPAS(mesh,field,destField1d,interp_list,msgval,masked,maskval,fillval, &
+ maskslab,mask_array)
+
+ !field%slab was allocated in the subroutine read_next_met_field
+ deallocate(field%slab)
+
+ !sea-ice data:
+ elseif(index(field % field, 'SEAICE') /= 0) then
+! write(0,*) '... Processing SEAICE:'
+ fg % xice % array(1:mesh%nCells) = 0.0_RKIND
+ destField1d => fg % xice % array
+
+ !interpolation to the MPAS grid:
+ !interp_list(1) = SIXTEEN_POINT
+ interp_list(1) = FOUR_POINT
+ interp_list(2) = FOUR_POINT
+ interp_list(3) = W_AVERAGE4
+ interp_list(4) = SEARCH
+ interp_list(5) = 0
+ msgval = -1.0e30_RKIND !missing value
+ masked = 1
+ maskval = 1.0_RKIND
+ fillval = 0.0_RKIND
+ call interp_to_MPAS(mesh,field,destField1d,interp_list,msgval,masked,maskval,fillval, &
+ maskslab,mask_array)
+
+ !field%slab was allocated in the subroutine read_next_met_field
+ deallocate(field%slab)
+
+ else
+ deallocate(field%slab)
+
+ endif
+
+ call read_next_met_field(field,istatus)
+ enddo
+
+!close intermediate file:
+ call read_met_close()
+ if(allocated(maskslab)) deallocate(maskslab)
+
+!freeze really cold oceans:
+ where(fg%sst%array.lt.271.0_RKIND .and. mesh%landmask%array.eq.0) fg%xice%array = 1.0_RKIND
+
+!limit XICE to values between 0 and 1. Although the input meteorological field is between 0. and 1.
+!interpolation to the MPAS grid can yield values of XiCE less than 0. and greater than 1.:
+ where (fg%xice%array < 0._RKIND) fg%xice%array = 0._RKIND
+ where (fg%xice%array > 1._RKIND) fg%xice%array = 1._RKIND
+
+ end subroutine interp_sfc_to_MPAS
+
+!==================================================================================================
+ subroutine interp_to_MPAS(mesh,field,destField1d,interp_list,msgval,masked,maskval,fillval, &
+ maskslab,mask_array)
+!==================================================================================================
+
+!input arguments:
+ type(mesh_type),intent(in):: mesh
+ type(met_data),intent(in) :: field !real*4 meteorological data.
+
+ integer,intent(in):: masked
+ integer,dimension(5),intent(in):: interp_list
+ integer,dimension(:),intent(in),pointer:: mask_array
+
+ real(kind=RKIND),intent(in):: fillval,maskval,msgval
+ real(kind=RKIND),intent(in),dimension(*):: maskslab
+
+!inout arguments:
+ real(kind=RKIND),intent(inout),dimension(:),pointer:: destField1d
+
+!local variables:
+ type(proj_info):: proj
+ integer:: i,nInterpPoints
+ real(kind=RKIND):: lat,lon,x,y
+ real(kind=RKIND),dimension(:,:),allocatable:: rslab
+
+ real(kind=RKIND),dimension(:),pointer:: latPoints,lonPoints
+
+!--------------------------------------------------------------------------------------------------
+
+ call map_init(proj)
+ if(field % iproj == PROJ_LATLON) then
+ call map_set(PROJ_LATLON, proj, &
+ latinc = real(field % deltalat,RKIND), &
+ loninc = real(field % deltalon,RKIND), &
+ knowni = 1.0_RKIND, &
+ knownj = 1.0_RKIND, &
+ lat1 = real(field % startlat,RKIND), &
+ lon1 = real(field % startlon,RKIND))
+! write(0,*) '--- The projection is PROJ_LATLON.'
+ elseif(field % iproj == PROJ_GAUSS) then
+ call map_set(PROJ_GAUSS, proj, &
+ nlat = nint(field % deltalat), &
+ loninc = real(field % deltalon,RKIND), &
+ lat1 = real(field % startlat,RKIND), &
+ lon1 = real(field % startlon,RKIND))
+! write(0,*) '--- The projection is PROJ_GAUSS.'
+ elseif(field % iproj == PROJ_PS) then
+ call map_set(PROJ_PS, proj, &
+ dx = real(field % dx,RKIND), &
+ truelat1 = real(field % truelat1,RKIND), &
+ stdlon = real(field % xlonc,RKIND), &
+ knowni = real(field % nx / 2.0,RKIND), &
+ knownj = real(field % ny / 2.0,RKIND), &
+ lat1 = real(field % startlat,RKIND), &
+ lon1 = real(field % startlon,RKIND))
+! write(0,*) '--- The projection is PROJ_PS.'
+ endif
+
+ nInterpPoints = mesh % nCells
+ latPoints => mesh % latCell % array
+ lonPoints => mesh % lonCell % array
+
+ allocate(rslab(-2:field % nx+3, field % ny))
+ rslab(1:field % nx, 1:field % ny) = field % slab(1:field % nx, 1:field % ny)
+ rslab( 0, 1:field % ny) = field % slab(field % nx , 1:field % ny)
+ rslab(-1, 1:field % ny) = field % slab(field % nx-1, 1:field % ny)
+ rslab(-2, 1:field % ny) = field % slab(field % nx-2, 1:field % ny)
+ rslab(field % nx+1, 1:field % ny) = field % slab(1, 1:field % ny)
+ rslab(field % nx+2, 1:field % ny) = field % slab(2, 1:field % ny)
+ rslab(field % nx+3, 1:field % ny) = field % slab(3, 1:field % ny)
+
+ do i = 1,nInterpPoints
+ if(mask_array(i) /= masked) then
+ lat = latPoints(i) * DEG_PER_RAD
+ lon = lonPoints(i) * DEG_PER_RAD
+ call latlon_to_ij(proj, lat, lon, x, y)
+ if(y < 0.5) then
+ y = 1.0
+ elseif(y >= real(field%ny)+0.5) then
+ y = real(field % ny)
+ endif
+ if(x < 0.5) then
+ lon = lon + 360.0
+ call latlon_to_ij(proj, lat, lon, x, y)
+ elseif (x >= real(field%nx)+0.5) then
+ lon = lon - 360.0
+ call latlon_to_ij(proj, lat, lon, x, y)
+ endif
+ destField1d(i) = interp_sequence(x,y,1,rslab,-2,field%nx+3,1,field%ny,1,1, &
+ msgval,interp_list,1,maskval=maskval,mask_array=maskslab)
+ else
+ destField1d(i) = fillval
+ endif
+ enddo
+ deallocate(rslab)
+
+ end subroutine interp_to_MPAS
+
+!==================================================================================================
+ end module mpas_init_atm_surface
+!==================================================================================================
+
Modified: trunk/mpas/src/core_init_nhyd_atmos/mpas_init_atm_test_cases.F
===================================================================
--- trunk/mpas/src/core_init_nhyd_atmos/mpas_init_atm_test_cases.F 2013-03-27 19:24:59 UTC (rev 2673)
+++ trunk/mpas/src/core_init_nhyd_atmos/mpas_init_atm_test_cases.F 2013-03-27 19:26:14 UTC (rev 2674)
@@ -10,6 +10,8 @@
use mpas_RBF_interpolation
use mpas_vector_reconstruction
use mpas_timer
+ use mpas_init_atm_static
+ use mpas_init_atm_surface
! Added only clause to keep xlf90 from getting confused from the overloaded abs intrinsic in mpas_timekeeping
use mpas_timekeeping !, only: MPAS_Time_type, MPAS_TimeInterval_type, MPAS_Clock_type, &
@@ -104,20 +106,25 @@
write(0,*) ' real-data GFS test case '
block_ptr => domain % blocklist
do while (associated(block_ptr))
+ if (config_static_interp) then
+ call init_atm_static(block_ptr % mesh)
+ call init_atm_static_orogwd(block_ptr % mesh)
+ endif
call init_atm_test_case_gfs(block_ptr % mesh, block_ptr % fg, &
block_ptr % state % time_levs(1) % state, block_ptr % diag, &
- config_test_case)
- if (config_met_interp) call physics_initialize_real(block_ptr % mesh, block_ptr % fg)
+ block_ptr % diag_physics, config_test_case)
+ if (config_met_interp) call physics_initialize_real(block_ptr % mesh, block_ptr % fg, domain % dminfo)
+
block_ptr => block_ptr % next
end do
else if (config_test_case == 8 ) then
- write(0,*) ' real-data surface (SST) update test case '
+ write(0,*) 'real-data surface (SST) update test case '
block_ptr => domain % blocklist
do while (associated(block_ptr))
- call init_atm_test_case_sfc(domain, domain % dminfo, block_ptr % mesh, block_ptr % fg, block_ptr % state % time_levs(1) % state, &
- block_ptr % diag, config_test_case, block_ptr % parinfo)
+ ! Defined in mpas_init_atm_surface.F
+ call init_atm_test_case_sfc(domain, domain % dminfo, block_ptr % mesh,block_ptr % fg, block_ptr % state % time_levs(1) % state)
block_ptr => block_ptr % next
end do
@@ -2231,7 +2238,7 @@
end subroutine init_atm_test_case_mtn_wave
- subroutine init_atm_test_case_gfs(grid, fg, state, diag, test_case)
+ subroutine init_atm_test_case_gfs(grid, fg, state, diag, diag_physics, test_case)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Real-data test case using GFS data
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -2247,6 +2254,7 @@
type (fg_type), intent(inout) :: fg
type (state_type), intent(inout) :: state
type (diag_type), intent(inout) :: diag
+ type (diag_physics_type), intent(inout):: diag_physics
integer, intent(in) :: test_case
type (block_type), pointer :: block
@@ -2291,10 +2299,9 @@
!This is temporary variable here. It just need when calculate tangential velocity v.
integer :: eoe, j
- integer, dimension(:), pointer :: nEdgesOnEdge, nEdgesOnCell
+ integer, dimension(:), pointer :: nEdgesOnCell
integer, dimension(:,:), pointer :: edgesOnEdge, cellsOnEdge, edgesOnCell, cellsOnCell
real (kind=RKIND), dimension(:), pointer :: dvEdge, dcEdge, AreaCell
- real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge
real (kind=RKIND), dimension(:,:), pointer :: v
real (kind=RKIND), dimension(:,:), pointer :: sorted_arr
@@ -2302,7 +2309,7 @@
type (field1DReal), target :: tempFieldTarget
real(kind=RKIND), dimension(:), pointer :: hs, hs1
- real(kind=RKIND) :: hm, zh, dzmin, dzmina, dzmina_global, dzminf, sm
+ real(kind=RKIND) :: hm, hm_global, zh, dzmin, dzmina, dzmina_global, dzminf, sm
integer :: nsmterrain, kz, sfc_k
logical :: hybrid, smooth
@@ -2310,19 +2317,10 @@
real (kind=RKIND) :: p_check
! For interpolating terrain and land use
- integer :: nx, ny, nzz, iPoint, subx, suby
- integer :: isigned, endian, wordsize, istatus
- integer :: iTileStart, iTileEnd
- integer :: jTileStart, jTileEnd
- integer, allocatable, dimension(:) :: nhs
- integer, allocatable, dimension(:,:) :: ncat
- real (kind=4) :: scalefactor ! NB: this should be a single-precision real
- real (kind=RKIND) :: lat_pt, lon_pt, lon_pt_o
- real (kind=4), allocatable, dimension(:,:,:) :: rarray ! NB: this should be a single-precision real array
+ integer :: nx, ny
+ integer :: istatus
+
real (kind=RKIND), allocatable, dimension(:,:) :: rslab, maskslab
- real (kind=RKIND), allocatable, dimension(:,:) :: maxsnowalb
- real (kind=RKIND), allocatable, dimension(:,:) :: soiltemp_1deg
- real (kind=RKIND), allocatable, dimension(:,:,:) :: vegfra
integer, dimension(:), pointer :: mask_array
integer, dimension(grid % nEdges), target :: edge_mask
character (len=StrKIND) :: fname
@@ -2364,8 +2362,6 @@
parinfo => block % parinfo
dminfo => block % domain % dminfo
- weightsOnEdge => grid % weightsOnEdge % array
- nEdgesOnEdge => grid % nEdgesOnEdge % array
nEdgesOnCell => grid % nEdgesOnCell % array
edgesOnEdge => grid % edgesOnEdge % array
edgesOnCell => grid % edgesOnCell % array
@@ -2421,622 +2417,9 @@
omega_e = omega
p0 = 1.e+05
- interp_list(1) = FOUR_POINT
- interp_list(2) = SEARCH
- interp_list(3) = 0
-
-
- !
- ! Scale all distances and areas from a unit sphere to one with radius sphere_radius
- !
-
- if (config_static_interp) then
-
- grid % xCell % array = grid % xCell % array * r_earth
- grid % yCell % array = grid % yCell % array * r_earth
- grid % zCell % array = grid % zCell % array * r_earth
- grid % xVertex % array = grid % xVertex % array * r_earth
- grid % yVertex % array = grid % yVertex % array * r_earth
- grid % zVertex % array = grid % zVertex % array * r_earth
- grid % xEdge % array = grid % xEdge % array * r_earth
- grid % yEdge % array = grid % yEdge % array * r_earth
- grid % zEdge % array = grid % zEdge % array * r_earth
- grid % dvEdge % array = grid % dvEdge % array * r_earth
- grid % dcEdge % array = grid % dcEdge % array * r_earth
- grid % areaCell % array = grid % areaCell % array * r_earth**2.0
- grid % areaTriangle % array = grid % areaTriangle % array * r_earth**2.0
- grid % kiteAreasOnVertex % array = grid % kiteAreasOnVertex % array * r_earth**2.0
-
scalars(:,:,:) = 0.
- call atm_initialize_advection_rk(grid)
- call atm_initialize_deformation_weights(grid)
-
-
- !
- ! Interpolate HGT
- !
-! nx = 126
-! ny = 126
- nx = 1206
- ny = 1206
- nzz = 1
- isigned = 1
- endian = 0
- wordsize = 2
- scalefactor = 1.0
- allocate(rarray(nx,ny,nzz))
- allocate(nhs(grid % nCells))
- nhs(:) = 0
- ter(:) = 0.0
-
- do jTileStart=1,20401,ny-6
-! do jTileStart=1,961,ny-6
- jTileEnd = jTileStart + ny - 1 - 6
- do iTileStart=1,42001,nx-6
-! do iTileStart=1,2041,nx-6
- iTileEnd = iTileStart + nx - 1 - 6
- write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(config_geog_data_path)//'topo_30s/',iTileStart,'-',iTileEnd,'.',jTileStart,'-',jTileEnd
-! write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(config_geog_data_path)//'topo_10m/',iTileStart,'-',iTileEnd,'.',jTileStart,'-',jTileEnd
-write(0,*) trim(fname)
-
- call read_geogrid(fname, len_trim(fname), &
- rarray, &
- nx, ny, nzz, &
- isigned, endian, scalefactor, wordsize, istatus)
- call init_atm_check_read_error(istatus, fname, dminfo)
-
- iPoint = 1
- do j=4,ny-3
- do i=4,nx-3
- lat_pt = -89.99583 + (jTileStart + j - 5) * 0.0083333333
- lon_pt = -179.99583 + (iTileStart + i - 5) * 0.0083333333
-! lat_pt = -89.91667 + (jTileStart + j - 5) * 0.166667
-! lon_pt = -179.91667 + (iTileStart + i - 5) * 0.166667
- lat_pt = lat_pt * pii / 180.0
- lon_pt = lon_pt * pii / 180.0
-
- iPoint = nearest_cell(lat_pt, lon_pt, &
- iPoint, &
- grid % nCells, grid % maxEdges, grid % nEdgesOnCell % array, grid % cellsOnCell % array, &
- grid % latCell % array, grid % lonCell % array)
-
- ter(iPoint) = ter(iPoint) + rarray(i,j,1)
- nhs(iPoint) = nhs(iPoint) + 1
-
- end do
- end do
-
- end do
- end do
-
- do iCell=1, grid % nCells
- ter(iCell) = ter(iCell) / real(nhs(iCell))
- end do
-
- deallocate(rarray)
- deallocate(nhs)
-
-
- !
- ! Interpolate LU_INDEX
- !
- nx = 1200
- ny = 1200
- nzz = 1
- isigned = 1
- endian = 0
- wordsize = 1
- scalefactor = 1.0
- allocate(rarray(nx,ny,nzz))
- allocate(ncat(24,grid % nCells))
- ncat(:,:) = 0
- grid % lu_index % array(:) = 0.0
-
- do jTileStart=1,20401,ny
- jTileEnd = jTileStart + ny - 1
- do iTileStart=1,42001,nx
- iTileEnd = iTileStart + nx - 1
- write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(config_geog_data_path)//'/landuse_30s/',iTileStart,'-',iTileEnd,'.',jTileStart,'-',jTileEnd
-write(0,*) trim(fname)
-
- call read_geogrid(fname, len_trim(fname), &
- rarray, &
- nx, ny, nzz, &
- isigned, endian, scalefactor, wordsize, istatus)
- call init_atm_check_read_error(istatus, fname, dminfo)
-
- iPoint = 1
- do j=1,ny
- do i=1,nx
- lat_pt = -89.99583 + (jTileStart + j - 2) * 0.0083333333
- lon_pt = -179.99583 + (iTileStart + i - 2) * 0.0083333333
- lat_pt = lat_pt * pii / 180.0
- lon_pt = lon_pt * pii / 180.0
-
- iPoint = nearest_cell(lat_pt, lon_pt, &
- iPoint, &
- grid % nCells, grid % maxEdges, grid % nEdgesOnCell % array, grid % cellsOnCell % array, &
- grid % latCell % array, grid % lonCell % array)
-
- ncat(int(rarray(i,j,1)),iPoint) = ncat(int(rarray(i,j,1)),iPoint) + 1
-
- end do
- end do
-
- end do
- end do
-
- do iCell=1, grid % nCells
- grid % lu_index % array(iCell) = 1
- do i=2,24
- if (ncat(i,iCell) > ncat(grid % lu_index % array(iCell),iCell)) then
- grid % lu_index % array(iCell) = i
- end if
- end do
- end do
-
- deallocate(rarray)
- deallocate(ncat)
-
-
- !
- ! Interpolate SOILCAT_TOP
- !
- nx = 1200
- ny = 1200
- nzz = 1
- isigned = 1
- endian = 0
- wordsize = 1
- scalefactor = 1.0
- allocate(rarray(nx,ny,nzz))
- allocate(ncat(16,grid % nCells))
- ncat(:,:) = 0
- grid % soilcat_top % array(:) = 0.0
-
- do jTileStart=1,20401,ny
- jTileEnd = jTileStart + ny - 1
- do iTileStart=1,42001,nx
- iTileEnd = iTileStart + nx - 1
- write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(config_geog_data_path)//'/soiltype_top_30s/',iTileStart,'-',iTileEnd,'.',jTileStart,'-',jTileEnd
-write(0,*) trim(fname)
-
- call read_geogrid(fname, len_trim(fname), &
- rarray, &
- nx, ny, nzz, &
- isigned, endian, scalefactor, wordsize, istatus)
- call init_atm_check_read_error(istatus, fname, dminfo)
-
- iPoint = 1
- do j=1,ny
- do i=1,nx
- lat_pt = -89.99583 + (jTileStart + j - 2) * 0.0083333333
- lon_pt = -179.99583 + (iTileStart + i - 2) * 0.0083333333
- lat_pt = lat_pt * pii / 180.0
- lon_pt = lon_pt * pii / 180.0
-
- iPoint = nearest_cell(lat_pt, lon_pt, &
- iPoint, &
- grid % nCells, grid % maxEdges, grid % nEdgesOnCell % array, grid % cellsOnCell % array, &
- grid % latCell % array, grid % lonCell % array)
-
- ncat(int(rarray(i,j,1)),iPoint) = ncat(int(rarray(i,j,1)),iPoint) + 1
-
- end do
- end do
-
- end do
- end do
-
- do iCell=1, grid % nCells
- grid % soilcat_top % array(iCell) = 1
- do i=2,16
- if (ncat(i,iCell) > ncat(grid % soilcat_top % array(iCell),iCell)) then
- grid % soilcat_top % array(iCell) = i
- end if
- end do
- end do
-
- deallocate(rarray)
- deallocate(ncat)
-
-
- !
- ! Interpolate SOILCAT_BOT
- !
- nx = 1200
- ny = 1200
- nzz = 1
- isigned = 1
- endian = 0
- wordsize = 1
- scalefactor = 1.0
- allocate(rarray(nx,ny,nzz))
- allocate(ncat(16,grid % nCells))
- ncat(:,:) = 0
- grid % soilcat_bot % array(:) = 0.0
-
- do jTileStart=1,20401,ny
- jTileEnd = jTileStart + ny - 1
- do iTileStart=1,42001,nx
- iTileEnd = iTileStart + nx - 1
- write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(config_geog_data_path)//'/soiltype_bot_30s/',iTileStart,'-',iTileEnd,'.',jTileStart,'-',jTileEnd
-write(0,*) trim(fname)
-
- call read_geogrid(fname, len_trim(fname), &
- rarray, &
- nx, ny, nzz, &
- isigned, endian, scalefactor, wordsize, istatus)
- call init_atm_check_read_error(istatus, fname, dminfo)
-
- iPoint = 1
- do j=1,ny
- do i=1,nx
- lat_pt = -89.99583 + (jTileStart + j - 2) * 0.0083333333
- lon_pt = -179.99583 + (iTileStart + i - 2) * 0.0083333333
- lat_pt = lat_pt * pii / 180.0
- lon_pt = lon_pt * pii / 180.0
-
- iPoint = nearest_cell(lat_pt, lon_pt, &
- iPoint, &
- grid % nCells, grid % maxEdges, grid % nEdgesOnCell % array, grid % cellsOnCell % array, &
- grid % latCell % array, grid % lonCell % array)
-
- ncat(int(rarray(i,j,1)),iPoint) = ncat(int(rarray(i,j,1)),iPoint) + 1
-
- end do
- end do
-
- end do
- end do
-
- do iCell=1, grid % nCells
- grid % soilcat_bot % array(iCell) = 1
- do i=2,16
- if (ncat(i,iCell) > ncat(grid % soilcat_bot % array(iCell),iCell)) then
- grid % soilcat_bot % array(iCell) = i
- end if
- end do
- end do
-
- deallocate(rarray)
- deallocate(ncat)
-
-
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! KLUDGE TO FIX SOIL TYPE OVER ANTARCTICA
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- where (grid % lu_index % array == 24) grid % soilcat_top % array = 16
- where (grid % lu_index % array == 24) grid % soilcat_bot % array = 16
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! CORRECT INCONSISTENT SOIL AND LAND USE DATA
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- do iCell = 1,grid % nCells
- if (grid % lu_index % array(iCell) == 16 .or. &
- grid % soilcat_top % array(iCell) == 14 .or. &
- grid % soilcat_bot % array(iCell) == 14) then
- if (grid % lu_index % array(iCell) /= 16) then
- write(0,*) 'Turning lu_index into water at ', iCell
- grid % lu_index % array(iCell) = 16
- end if
- if (grid % soilcat_top % array(iCell) /= 14) then
- write(0,*) 'Turning soilcat_top into water at ', iCell
- grid % soilcat_top % array(iCell) = 14
- end if
- if (grid % soilcat_bot % array(iCell) /= 14) then
- write(0,*) 'Turning soilcat_bot into water at ', iCell
- grid % soilcat_bot % array(iCell) = 14
- end if
- end if
- end do
-
-
- !
- ! Derive LANDMASK
- !
- grid % landmask % array(:) = 0
- do iCell=1, grid % nCells
- if (grid % lu_index % array(iCell) /= 16) grid % landmask % array(iCell) = 1
- end do
-
-
- !
- ! Interpolate SOILTEMP:
- !
- nx = 186
- ny = 186
- nzz = 1
- isigned = 0
- endian = 0
- wordsize = 2
- scalefactor = 0.01
- allocate(rarray(nx,ny,nzz))
- allocate(soiltemp_1deg(360,180))
- grid % soiltemp % array(:) = 0.0
-
- call map_set(PROJ_LATLON, proj, &
- latinc = 1.0_RKIND, &
- loninc = 1.0_RKIND, &
- knowni = 1.0_RKIND, &
- knownj = 1.0_RKIND, &
- lat1 = -89.5_RKIND, &
- lon1 = -179.5_RKIND)
-
- write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(config_geog_data_path)//'soiltemp_1deg/',1,'-',180,'.',1,'-',180
-write(0,*) trim(fname)
- call read_geogrid(fname, len_trim(fname), &
- rarray, &
- nx, ny, nzz, &
- isigned, endian, scalefactor, wordsize, istatus)
- call init_atm_check_read_error(istatus, fname, dminfo)
-
- soiltemp_1deg(1:180,1:180) = rarray(4:183,4:183,1)
-
- write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(config_geog_data_path)//'soiltemp_1deg/',181,'-',360,'.',1,'-',180
-write(0,*) trim(fname)
- call read_geogrid(fname, len_trim(fname), &
- rarray, &
- nx, ny, nzz, &
- isigned, endian, scalefactor, wordsize, istatus)
- call init_atm_check_read_error(istatus, fname, dminfo)
-
- soiltemp_1deg(181:360,1:180) = rarray(4:183,4:183,1)
-
- interp_list(1) = FOUR_POINT
- interp_list(2) = W_AVERAGE4
- interp_list(3) = W_AVERAGE16
- interp_list(4) = SEARCH
- interp_list(5) = 0
-
- do iCell=1,grid%nCells
-
- if (grid % landmask % array(iCell) == 1) then
- lat = grid % latCell % array(iCell)*DEG_PER_RAD
- lon = grid % lonCell % array(iCell)*DEG_PER_RAD
- call latlon_to_ij(proj, lat, lon, x, y)
- if (x < 0.5) then
- lon = lon + 360.0
- call latlon_to_ij(proj, lat, lon, x, y)
- else if (x >= 360.5) then
- lon = lon - 360.0
- call latlon_to_ij(proj, lat, lon, x, y)
- end if
-if (y < 1.0) y = 1.0
-if (y > 179.0) y = 179.0
-! grid % soiltemp % array(iCell) = interp_sequence(x, y, 1, soiltemp_1deg, 1, 360, 1, 180, 1, 1, -1.e30_RKIND, interp_list, 1)
- grid % soiltemp % array(iCell) = interp_sequence(x, y, 1, soiltemp_1deg, 1, 360, 1, 180, 1, 1, 0.0_RKIND, interp_list, 1)
- else
- grid % soiltemp % array(iCell) = 0.0
- end if
-
- end do
-
- deallocate(rarray)
- deallocate(soiltemp_1deg)
-
-
- !
- ! Interpolate SNOALB
- !
- nx = 186
- ny = 186
- nzz = 1
- isigned = 0
- endian = 0
- wordsize = 1
- scalefactor = 1.0
- allocate(rarray(nx,ny,nzz))
- allocate(maxsnowalb(360,180))
- grid % snoalb % array(:) = 0.0
-
- call map_set(PROJ_LATLON, proj, &
- latinc = 1.0_RKIND, &
- loninc = 1.0_RKIND, &
- knowni = 1.0_RKIND, &
- knownj = 1.0_RKIND, &
- lat1 = -89.5_RKIND, &
- lon1 = -179.5_RKIND)
-
- write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(config_geog_data_path)//'maxsnowalb/',1,'-',180,'.',1,'-',180
-write(0,*) trim(fname)
- call read_geogrid(fname, len_trim(fname), &
- rarray, &
- nx, ny, nzz, &
- isigned, endian, scalefactor, wordsize, istatus)
- call init_atm_check_read_error(istatus, fname, dminfo)
-
- maxsnowalb(1:180,1:180) = rarray(4:183,4:183,1)
-
- write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(config_geog_data_path)//'maxsnowalb/',181,'-',360,'.',1,'-',180
-write(0,*) trim(fname)
- call read_geogrid(fname, len_trim(fname), &
- rarray, &
- nx, ny, nzz, &
- isigned, endian, scalefactor, wordsize, istatus)
- call init_atm_check_read_error(istatus, fname, dminfo)
-
- maxsnowalb(181:360,1:180) = rarray(4:183,4:183,1)
-
- interp_list(1) = FOUR_POINT
- interp_list(2) = W_AVERAGE4
- interp_list(3) = W_AVERAGE16
- interp_list(4) = SEARCH
- interp_list(5) = 0
-
- do iCell=1,grid%nCells
-
- if (grid % landmask % array(iCell) == 1) then
- lat = grid % latCell % array(iCell)*DEG_PER_RAD
- lon = grid % lonCell % array(iCell)*DEG_PER_RAD
- call latlon_to_ij(proj, lat, lon, x, y)
- if (x < 0.5) then
- lon = lon + 360.0
- call latlon_to_ij(proj, lat, lon, x, y)
- else if (x >= 360.5) then
- lon = lon - 360.0
- call latlon_to_ij(proj, lat, lon, x, y)
- end if
-if (y < 1.0) y = 1.0
-if (y > 179.0) y = 179.0
-! grid % snoalb % array(iCell) = interp_sequence(x, y, 1, maxsnowalb, 1, 360, 1, 180, 1, 1, -1.e30_RKIND, interp_list, 1)
- grid % snoalb % array(iCell) = interp_sequence(x, y, 1, maxsnowalb, 1, 360, 1, 180, 1, 1, 0.0_RKIND, interp_list, 1)
- else
- grid % snoalb % array(iCell) = 0.0
- end if
-
- end do
-
- grid % snoalb % array(:) = grid % snoalb % array(:) / 100.0
-
- deallocate(rarray)
- deallocate(maxsnowalb)
-
-
- !
- ! Interpolate GREENFRAC
- !
- nx = 1256
- ny = 1256
- nzz = 12
- isigned = 0
- endian = 0
- wordsize = 1
- scalefactor = 1.0
- allocate(rarray(nx,ny,nzz))
- allocate(vegfra(2500,1250,12))
-! grid % vegfra % array(:) = 0.0
- grid % greenfrac % array(:,:) = 0.0
-
- call map_set(PROJ_LATLON, proj, &
- latinc = 0.144_RKIND, &
- loninc = 0.144_RKIND, &
- knowni = 1.0_RKIND, &
- knownj = 1.0_RKIND, &
- lat1 = -89.928_RKIND, &
- lon1 = -179.928_RKIND)
-
- write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(config_geog_data_path)//'greenfrac/',1,'-',1250,'.',1,'-',1250
-write(0,*) trim(fname)
- call read_geogrid(fname, len_trim(fname), &
- rarray, &
- nx, ny, nzz, &
- isigned, endian, scalefactor, wordsize, istatus)
- call init_atm_check_read_error(istatus, fname, dminfo)
-
- vegfra(1:1250,1:1250,1:12) = rarray(4:1253,4:1253,1:12)
-
- write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(config_geog_data_path)//'greenfrac/',1251,'-',2500,'.',1,'-',1250
-write(0,*) trim(fname)
- call read_geogrid(fname, len_trim(fname), &
- rarray, &
- nx, ny, nzz, &
- isigned, endian, scalefactor, wordsize, istatus)
- call init_atm_check_read_error(istatus, fname, dminfo)
-
- vegfra(1251:2500,1:1250,1:12) = rarray(4:1253,4:1253,1:12)
-
- do iCell=1,grid%nCells
- if (grid % landmask % array(iCell) == 1) then
- lat = grid % latCell % array(iCell)*DEG_PER_RAD
- lon = grid % lonCell % array(iCell)*DEG_PER_RAD
- call latlon_to_ij(proj, lat, lon, x, y)
- if (x < 0.5) then
- lon = lon + 360.0
- call latlon_to_ij(proj, lat, lon, x, y)
- else if (x >= 2500.5) then
- lon = lon - 360.0
- call latlon_to_ij(proj, lat, lon, x, y)
- end if
-if (y < 1.0) y = 1.0
-if (y > 1249.0) y = 1249.0
- do k=1,12
- grid % greenfrac % array(k,iCell) = interp_sequence(x, y, k, vegfra, 1, 2500, 1, 1250, 1, 12, -1.e30_RKIND, interp_list, 1)
- end do
- else
- grid % greenfrac % array(:,iCell) = 0.0
- end if
- grid % shdmin % array(iCell) = minval(grid % greenfrac % array(:,iCell))
- grid % shdmax % array(iCell) = maxval(grid % greenfrac % array(:,iCell))
-
- end do
-
- deallocate(rarray)
- deallocate(vegfra)
-
-
- !
- ! Interpolate ALBEDO12M
- !
- nx = 1256
- ny = 1256
- nzz = 12
- isigned = 0
- endian = 0
- wordsize = 1
- scalefactor = 1.0
- allocate(rarray(nx,ny,nzz))
- allocate(vegfra(2500,1250,12))
- grid % albedo12m % array(:,:) = 0.0
-
- call map_set(PROJ_LATLON, proj, &
- latinc = 0.144_RKIND, &
- loninc = 0.144_RKIND, &
- knowni = 1.0_RKIND, &
- knownj = 1.0_RKIND, &
- lat1 = -89.928_RKIND, &
- lon1 = -179.928_RKIND)
-
- write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(config_geog_data_path)//'albedo_ncep/',1,'-',1250,'.',1,'-',1250
-write(0,*) trim(fname)
- call read_geogrid(fname, len_trim(fname), &
- rarray, &
- nx, ny, nzz, &
- isigned, endian, scalefactor, wordsize, istatus)
- call init_atm_check_read_error(istatus, fname, dminfo)
-
- vegfra(1:1250,1:1250,1:12) = rarray(4:1253,4:1253,1:12)
-
- write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(config_geog_data_path)//'albedo_ncep/',1251,'-',2500,'.',1,'-',1250
-write(0,*) trim(fname)
- call read_geogrid(fname, len_trim(fname), &
- rarray, &
- nx, ny, nzz, &
- isigned, endian, scalefactor, wordsize, istatus)
- call init_atm_check_read_error(istatus, fname, dminfo)
-
- vegfra(1251:2500,1:1250,1:12) = rarray(4:1253,4:1253,1:12)
-
- do iCell=1,grid%nCells
- if (grid % landmask % array(iCell) == 1) then
- lat = grid % latCell % array(iCell)*DEG_PER_RAD
- lon = grid % lonCell % array(iCell)*DEG_PER_RAD
- call latlon_to_ij(proj, lat, lon, x, y)
- if (x < 0.5) then
- lon = lon + 360.0
- call latlon_to_ij(proj, lat, lon, x, y)
- else if (x >= 2500.5) then
- lon = lon - 360.0
- call latlon_to_ij(proj, lat, lon, x, y)
- end if
-if (y < 1.0) y = 1.0
-if (y > 1249.0) y = 1249.0
- do k=1,12
- grid % albedo12m % array(k,iCell) = interp_sequence(x, y, k, vegfra, 1, 2500, 1, 1250, 1, 12, 0.0_RKIND, interp_list, 1)
- end do
- else
- grid % albedo12m % array(:,iCell) = 8.0
- end if
- end do
-
- deallocate(rarray)
- deallocate(vegfra)
-
-
- end if ! config_static_interp
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! BEGIN ADOPT GFS TERRAIN HEIGHT
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -3120,22 +2503,27 @@
do iCell=1,grid%nCells
hs(iCell) = 0.
- do j = 1,nEdgesOnCell(iCell)
- hs(iCell) = hs(iCell) + dvEdge(edgesOnCell(j,iCell)) &
- / dcEdge(edgesOnCell(j,iCell)) &
- * (ter(cellsOnCell(j,iCell))-ter(iCell))
- end do
- hs(iCell) = ter(iCell) + 0.25*hs(iCell)
+ if(ter(iCell) .ne. 0.) then
+ do j = 1,nEdgesOnCell(iCell)
+ hs(iCell) = hs(iCell) + dvEdge(edgesOnCell(j,iCell)) &
+ / dcEdge(edgesOnCell(j,iCell)) &
+ * (ter(cellsOnCell(j,iCell))-ter(iCell))
+ end do
+ endif
+ hs(iCell) = ter(iCell) + 0.125*hs(iCell)
end do
do iCell=1,grid %nCells
ter(iCell) = 0.
- do j = 1,nEdgesOnCell(iCell)
- ter(iCell) = ter(iCell) + dvEdge(edgesOnCell(j,iCell)) &
- / dcEdge(edgesOnCell(j,iCell)) &
- * (hs(cellsOnCell(j,iCell))-hs(iCell))
- end do
- ter(iCell) = hs(iCell) - 0.25*ter(iCell)
+ if(hs(iCell) .ne. 0.) then
+ do j = 1,nEdgesOnCell(iCell)
+ ter(iCell) = ter(iCell) + dvEdge(edgesOnCell(j,iCell)) &
+ / dcEdge(edgesOnCell(j,iCell)) &
+ * (hs(cellsOnCell(j,iCell))-hs(iCell))
+ end do
+ endif
+! ter(iCell) = hs(iCell) - 0.25*ter(iCell)
+ ter(iCell) = hs(iCell) - 0.125*ter(iCell)
end do
! note that ther variable ter used throughout this section is a pointer to grid % ter % array, here we are passing ter's parent field
@@ -3147,7 +2535,9 @@
hx(:,iCell) = ter(iCell)
end do
- hm = maxval(ter(:))
+ hm = maxval(ter(1:nCellsSolve))
+ call mpas_dmpar_max_real(dminfo, hm, hm_global)
+ hm = hm_global
write(0,*) "max ter = ", hm
! Metrics for hybrid coordinate and vertical stretching
@@ -3243,7 +2633,7 @@
if (smooth) then
- dzmin = 0.3
+ dzmin = 0.5
do k=2,kz-1
hx(k,:) = hx(k-1,:)
@@ -3251,9 +2641,9 @@
! dzmin = max(0.5_RKIND,1.-.5*zw(k)/hm)
- sm = .05*min(0.5_RKIND*zw(k)/hm,1.0_RKIND)
+ sm = .02*min(0.5_RKIND*zw(k)/hm,1.0_RKIND)
- do i=1,50
+ do i=1,30
do iCell=1,grid % nCells
hs1(iCell) = 0.
do j = 1,nEdgesOnCell(iCell)
@@ -3287,7 +2677,7 @@
call mpas_dmpar_exch_halo_field(tempField)
! dzmina = minval(hs(:)-hx(k-1,:))
- dzmina = minval(zw(k)+ah(k)*hs(1:grid%nCellsSolve)-zw(k-1)-ah(k-1)*hx(k-1,1:grid%nCellsSolve))
+ dzmina = minval(zw(k)+ah(k)*hs(1:nCellsSolve)-zw(k-1)-ah(k-1)*hx(k-1,1:nCellsSolve))
call mpas_dmpar_min_real(dminfo, dzmina, dzmina_global)
! write(0,*) ' k,i, dzmina, dzmin, zw(k)-zw(k-1) ', k,i, dzmina, dzmin, zw(k)-zw(k-1)
if (dzmina_global >= dzmin*(zw(k)-zw(k-1))) then
@@ -3428,7 +2818,7 @@
do while (istatus == 0)
if (index(field % field, 'LANDSEA') /= 0) then
- allocate(maskslab(-3:field % nx+3, field % ny))
+ allocate(maskslab(-2:field % nx+3, field % ny))
maskslab(1:field % nx, 1:field % ny) = field % slab(1:field % nx, 1:field % ny)
maskslab(0, 1:field % ny) = field % slab(field % nx, 1:field % ny)
maskslab(-1, 1:field % ny) = field % slab(field % nx-1, 1:field % ny)
@@ -3849,7 +3239,8 @@
else if (index(field % field, 'SEAICE') /= 0) then
write(0,*) 'Interpolating SEAICE'
- interp_list(1) = SIXTEEN_POINT
+ !interp_list(1) = SIXTEEN_POINT
+ interp_list(1) = FOUR_POINT
interp_list(2) = FOUR_POINT
interp_list(3) = W_AVERAGE4
interp_list(4) = SEARCH
@@ -3873,7 +3264,7 @@
ndims = 1
end if
- allocate(rslab(-3:field % nx+3, field % ny))
+ allocate(rslab(-2:field % nx+3, field % ny))
rslab(1:field % nx, 1:field % ny) = field % slab(1:field % nx, 1:field % ny)
rslab(0, 1:field % ny) = field % slab(field % nx, 1:field % ny)
rslab(-1, 1:field % ny) = field % slab(field % nx-1, 1:field % ny)
@@ -3892,9 +3283,9 @@
call latlon_to_ij(proj, lat, lon, x, y)
end if
if (ndims == 1) then
- destField1d(i) = interp_sequence(x, y, 1, rslab, -3, field % nx + 3, 1, field % ny, 1, 1, msgval, interp_list, 1, maskval=maskval, mask_array=maskslab)
+ destField1d(i) = interp_sequence(x, y, 1, rslab, -2, field % nx + 3, 1, field % ny, 1, 1, msgval, interp_list, 1, maskval=maskval, mask_array=maskslab)
else if (ndims == 2) then
- destField2d(k,i) = interp_sequence(x, y, 1, rslab, -3, field % nx + 3, 1, field % ny, 1, 1, msgval, interp_list, 1, maskval=maskval, mask_array=maskslab)
+ destField2d(k,i) = interp_sequence(x, y, 1, rslab, -2, field % nx + 3, 1, field % ny, 1, 1, msgval, interp_list, 1, maskval=maskval, mask_array=maskslab)
end if
else
if (ndims == 1) then
@@ -4050,28 +3441,17 @@
! Freeze really cold ocean
where (fg % sst % array < 271.0 .and. grid % landmask % array == 0) fg % xice % array = 1.0
+ ! Limit XICE to values between 0 and 1. Although the input meteorological field is between 0.
+ ! and 1., interpolation to the MPAS grid can yield values of XiCE less than 0. and greater
+ ! than 1.:
+ where (fg % xice % array < 0._RKIND) fg % xice % array = 0._RKIND
+ where (fg % xice % array > 1._RKIND) fg % xice % array = 1._RKIND
+
! Set SEAICE (0/1 flag) based on XICE (fractional ice coverage)
fg % seaice % array(:) = 0.0
where (fg % xice % array >= 0.5) fg % seaice % array = 1.0
- !
- ! For now, hard-wire soil layer depths and thicknesses
- !
-
- !LDF begin:
- !fg % dzs % array(1,:) = 0.10
- !fg % dzs % array(2,:) = 0.30
- !fg % dzs % array(3,:) = 0.60
- !fg % dzs % array(4,:) = 1.00
-
- !fg % dz % array(1,:) = 0.05
- !fg % dz % array(2,:) = 0.25
- !fg % dz % array(3,:) = 0.70
- !fg % dz % array(4,:) = 1.50
- !LDF end.
-
-
!
! Compute normal wind component and store in fg%u
!
@@ -4101,7 +3481,9 @@
call mpas_quicksort(config_nfglevels, sorted_arr)
do k=1,grid%nVertLevels
target_z = 0.5 * (grid % zgrid % array(k,iCell) + grid % zgrid % array(k+1,iCell))
- state % theta_m % array(k,iCell) = vertical_interp(target_z, config_nfglevels, sorted_arr, order=1, extrap=1)
+! state % theta_m % array(k,iCell) = vertical_interp(target_z, config_nfglevels, sorted_arr, order=1, extrap=1)
+ state % theta_m % array(k,iCell) = vertical_interp(target_z, config_nfglevels-1, &
+ sorted_arr(:,1:config_nfglevels-1), order=1, extrap=1)
end do
@@ -4116,7 +3498,10 @@
call mpas_quicksort(config_nfglevels, sorted_arr)
do k=1,grid%nVertLevels
target_z = 0.5 * (grid % zgrid % array(k,iCell) + grid % zgrid % array(k+1,iCell))
- state % scalars % array(state % index_qv,k,iCell) = vertical_interp(target_z, config_nfglevels, sorted_arr, order=1, extrap=0)
+! state % scalars % array(state % index_qv,k,iCell) = vertical_interp(target_z, config_nfglevels, sorted_arr, order=1, extrap=0)
+ state % scalars % array(state % index_qv,k,iCell) = vertical_interp(target_z, config_nfglevels-1, &
+ sorted_arr(:,1:config_nfglevels-1), order=1, extrap=1)
+ diag % rh % array(k,iCell) = state % scalars % array(state % index_qv,k,iCell)
end do
@@ -4131,7 +3516,9 @@
call mpas_quicksort(config_nfglevels, sorted_arr)
do k=1,grid%nVertLevels
target_z = 0.5 * (grid % zgrid % array(k,iCell) + grid % zgrid % array(k+1,iCell))
- fg % gfs_z % array(k,iCell) = vertical_interp(target_z, config_nfglevels, sorted_arr, order=1, extrap=1)
+! fg % gfs_z % array(k,iCell) = vertical_interp(target_z, config_nfglevels, sorted_arr, order=1, extrap=1)
+ fg % gfs_z % array(k,iCell) = vertical_interp(target_z, config_nfglevels-1, &
+ sorted_arr(:,1:config_nfglevels-1), order=1, extrap=1)
end do
@@ -4149,7 +3536,9 @@
call mpas_quicksort(config_nfglevels, sorted_arr)
do k=1,grid%nVertLevels
target_z = 0.5 * (grid % zgrid % array(k,iCell) + grid % zgrid % array(k+1,iCell))
- diag % pressure % array(k,iCell) = exp(vertical_interp(target_z, config_nfglevels, sorted_arr, order=1, extrap=1))
+! diag % pressure % array(k,iCell) = exp(vertical_interp(target_z, config_nfglevels, sorted_arr, order=1, extrap=1))
+ diag % pressure % array(k,iCell) = exp(vertical_interp(target_z, config_nfglevels-1, &
+ sorted_arr(:,1:config_nfglevels-1), order=1, extrap=1))
end do
@@ -4186,7 +3575,9 @@
call mpas_quicksort(config_nfglevels, sorted_arr)
do k=1,grid%nVertLevels
target_z = 0.25 * (grid % zgrid % array(k,cellsOnEdge(1,iEdge)) + grid % zgrid % array(k+1,cellsOnEdge(1,iEdge)) + grid % zgrid % array(k,cellsOnEdge(2,iEdge)) + grid % zgrid % array(k+1,cellsOnEdge(2,iEdge)))
- state % u % array(k,iEdge) = vertical_interp(target_z, config_nfglevels, sorted_arr, order=1, extrap=0)
+! state % u % array(k,iEdge) = vertical_interp(target_z, config_nfglevels, sorted_arr, order=1, extrap=0)
+ state % u % array(k,iEdge) = vertical_interp(target_z, config_nfglevels-1, &
+ sorted_arr(:,1:config_nfglevels-1), order=1, extrap=1)
end do
end do
@@ -4243,8 +3634,8 @@
! QV
es = 6.112 * exp((17.27*(state % theta_m % array(k,iCell) - 273.16))/(state % theta_m % array(k,iCell) - 35.86))
- rs = 0.622 * es / (diag % pressure % array(k,iCell) - es)
- scalars(state % index_qv,k,iCell) = rs * scalars(state % index_qv,k,iCell)
+ rs = 0.622 * es * 100. / (diag % pressure % array(k,iCell) - es * 100.)
+ scalars(state % index_qv,k,iCell) = 0.01 * rs * scalars(state % index_qv,k,iCell)
! PI
p(k,iCell) = (diag % pressure % array(k,iCell) / p0) ** (rgas / cp)
@@ -4261,6 +3652,17 @@
!
+ ! Calculation of the initial precipitable water:
+ !
+ do iCell = 1,grid%nCells
+ diag_physics%precipw%array(iCell) = 0.0
+ do k = 1,grid%nVertLevels
+ diag_physics%precipw%array(iCell) = diag_physics%precipw%array(iCell) &
+ + rho_zz(k,iCell)*scalars(state%index_qv,k,iCell)*(zgrid(k+1,iCell)-zgrid(k,iCell))
+ enddo
+ enddo
+
+ !
! Reference state based on a dry isothermal atmosphere
!
do iCell=1,grid % nCells
@@ -4387,242 +3789,6 @@
end subroutine init_atm_test_case_gfs
- subroutine init_atm_test_case_sfc(domain, dminfo, grid, fg, state, diag, test_case, parinfo)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Real-data test case using SST data
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- use mpas_dmpar
- use mpas_io_output
- use init_atm_read_met
- use init_atm_llxy
- use init_atm_hinterp
-
- implicit none
-
- type (domain_type), intent(inout) :: domain
- type (dm_info), intent(in) :: dminfo
- type (mesh_type), intent(inout) :: grid
- type (fg_type), intent(inout) :: fg
- type (state_type), intent(inout) :: state
- type (diag_type), intent(inout) :: diag
- integer, intent(in) :: test_case
- type (parallel_info), pointer :: parinfo
-
- integer :: istatus
- integer :: iCell, i, j
- type (met_data) :: field
- type (proj_info) :: proj
- real (kind=RKIND) :: lat, lon, x, y
- integer, dimension(5) :: interp_list
- real (kind=RKIND), allocatable, dimension(:,:) :: slab_r8
- type (io_output_object) :: sfc_update_obj
- type (MPAS_Clock_type) :: fg_clock
- type (MPAS_Time_type) :: start_time, stop_time, curr_time
- type (MPAS_TimeInterval_type) :: fg_interval
- character (len=StrKIND) :: timeString
-
-
- ! Set interpolation sequence to be used for SST/SKINTEMP field
- interp_list(1) = FOUR_POINT
- interp_list(2) = SEARCH
- interp_list(3) = 0
-
-
- ! Set up clock to step through all intermediate file dates to be processed
- call mpas_set_time(start_time, dateTimeString=trim(config_start_time))
- call mpas_set_time(stop_time, dateTimeString=trim(config_stop_time))
- call mpas_set_timeInterval(fg_interval, S=config_fg_interval)
-
- call mpas_create_clock(fg_clock, start_time, fg_interval, stopTime=stop_time)
-
-
- ! Initialize the output file
- sfc_update_obj % time = 1
- sfc_update_obj % filename = trim(config_sfc_update_name)
-
- call mpas_output_state_init(sfc_update_obj, domain, "SFC")
-
- ! Loop over all times, interpolating the SST/SKINTEMP field from each intermediate file
- curr_time = mpas_get_clock_time(fg_clock, MPAS_NOW)
- do while (curr_time <= stop_time)
- call mpas_get_time(curr_time, dateTimeString=timeString)
- write(0,*) 'Processing ',trim(config_sfc_prefix)//':'//timeString(1:13)
-
- ! Open intermediate file
- call read_met_init(trim(config_sfc_prefix), .false., timeString(1:13), istatus)
- if (istatus /= 0) then
- write(0,*) 'Error reading ',trim(config_sfc_prefix)//':'//timeString(1:13)
- exit
- end if
-
- ! Scan through all fields in the file, looking for the SST or SKINTEMP field
- call read_next_met_field(field, istatus)
- do while (istatus == 0)
-
- !initialization of sea-surface temperature (SST) and sea-ice fraction (XICE) arrays,
- !prior to reading the input data:
- fg % sst % array (1:grid%nCells) = 0.0
- fg % xice % array (1:grid%nCells) = 0.0
-
- if (index(field % field, 'SKINTEMP') /= 0 .or. index(field % field, 'SST') /= 0) then
-
- ! Interpolation routines use real(kind=RKIND), so copy from default real array
- allocate(slab_r8(field % nx, field % ny))
- do j=1,field % ny
- do i=1,field % nx
- slab_r8(i,j) = field % slab(i,j)
- end do
- end do
-
- !
- ! Set up map projection
- !
- call map_init(proj)
-
- if (field % iproj == PROJ_LATLON) then
- call map_set(PROJ_LATLON, proj, &
- latinc = real(field % deltalat,RKIND), &
- loninc = real(field % deltalon,RKIND), &
- knowni = 1.0_RKIND, &
- knownj = 1.0_RKIND, &
- lat1 = real(field % startlat,RKIND), &
- lon1 = real(field % startlon,RKIND))
- else if (field % iproj == PROJ_GAUSS) then
- call map_set(PROJ_GAUSS, proj, &
- nlat = nint(field % deltalat), &
- loninc = real(field % deltalon,RKIND), &
- lat1 = real(field % startlat,RKIND), &
- lon1 = real(field % startlon,RKIND))
-! nxmax = nint(360.0 / field % deltalon), &
- else if (field % iproj == PROJ_PS) then
- call map_set(PROJ_PS, proj, &
- dx = real(field % dx,RKIND), &
- truelat1 = real(field % truelat1,RKIND), &
- stdlon = real(field % xlonc,RKIND), &
- knowni = real(field % nx / 2.0,RKIND), &
- knownj = real(field % ny / 2.0,RKIND), &
- lat1 = real(field % startlat,RKIND), &
- lon1 = real(field % startlon,RKIND))
- end if
-
- ! Interpolate SST/SKINTEMP field to each MPAS grid cell
- do iCell=1,grid % nCells
- lat = grid % latCell % array(iCell) * DEG_PER_RAD
- lon = grid % lonCell % array(iCell) * DEG_PER_RAD
- call latlon_to_ij(proj, lat, lon, x, y)
- if (y < 0.5) then
- y = 1.0
- else if (y >= real(field%ny)+0.5) then
- y = real(field % ny)
- end if
- if (x < 0.5) then
- lon = lon + 360.0
- call latlon_to_ij(proj, lat, lon, x, y)
- else if (x >= real(field%nx)+0.5) then
- lon = lon - 360.0
- call latlon_to_ij(proj, lat, lon, x, y)
- end if
- fg % sst % array(iCell) = interp_sequence(x, y, 1, slab_r8, 1, field % nx, 1, field % ny, 1, 1, -1.e30_RKIND, interp_list, 1)
- end do
-
- deallocate(slab_r8)
- deallocate(field % slab)
-
- else if (index(field % field, 'SEAICE') /= 0) then
-
- ! Interpolation routines use real(kind=RKIND), so copy from default real array
- allocate(slab_r8(field % nx, field % ny))
- do j=1,field % ny
- do i=1,field % nx
- slab_r8(i,j) = field % slab(i,j)
- end do
- end do
-
- !
- ! Set up map projection
- !
- call map_init(proj)
-
- if (field % iproj == PROJ_LATLON) then
- call map_set(PROJ_LATLON, proj, &
- latinc = real(field % deltalat,RKIND), &
- loninc = real(field % deltalon,RKIND), &
- knowni = 1.0_RKIND, &
- knownj = 1.0_RKIND, &
- lat1 = real(field % startlat,RKIND), &
- lon1 = real(field % startlon,RKIND))
- else if (field % iproj == PROJ_GAUSS) then
- call map_set(PROJ_GAUSS, proj, &
- nlat = nint(field % deltalat), &
- loninc = real(field % deltalon,RKIND), &
- lat1 = real(field % startlat,RKIND), &
- lon1 = real(field % startlon,RKIND))
-! nxmax = nint(360.0 / field % deltalon), &
- else if (field % iproj == PROJ_PS) then
- call map_set(PROJ_PS, proj, &
- dx = real(field % dx,RKIND), &
- truelat1 = real(field % truelat1,RKIND), &
- stdlon = real(field % xlonc,RKIND), &
- knowni = real(field % nx / 2.0,RKIND), &
- knownj = real(field % ny / 2.0,RKIND), &
- lat1 = real(field % startlat,RKIND), &
- lon1 = real(field % startlon,RKIND))
- end if
-
- ! Interpolate SEAICE/SKINTEMP field to each MPAS grid cell
- do iCell=1,grid % nCells
- lat = grid % latCell % array(iCell) * DEG_PER_RAD
- lon = grid % lonCell % array(iCell) * DEG_PER_RAD
- call latlon_to_ij(proj, lat, lon, x, y)
- if (y < 0.5) then
- y = 1.0
- else if (y >= real(field%ny)+0.5) then
- y = real(field % ny)
- end if
- if (x < 0.5) then
- lon = lon + 360.0
- call latlon_to_ij(proj, lat, lon, x, y)
- else if (x >= real(field%nx)+0.5) then
- lon = lon - 360.0
- call latlon_to_ij(proj, lat, lon, x, y)
- end if
- fg % xice % array(iCell) = interp_sequence(x, y, 1, slab_r8, 1, field % nx, 1, field % ny, 1, 1, -1.e30_RKIND, interp_list, 1)
- if (fg % xice % array(iCell) == -1.e30_RKIND) fg % xice % array(iCell) = 0.0_RKIND
-
- end do
-
- deallocate(slab_r8)
- deallocate(field % slab)
-
- else
-
- deallocate(field % slab)
- end if
-
- call read_next_met_field(field, istatus)
- end do
-
- ! Close intermediate file
- call read_met_close()
-
- ! Write the interpolated SST/SKINTEMP field as a new time slice in the MPAS output file
- call mpas_output_state_for_domain(sfc_update_obj, domain, sfc_update_obj % time)
- sfc_update_obj % time = sfc_update_obj % time + 1
-
- call mpas_advance_clock(fg_clock)
- curr_time = mpas_get_clock_time(fg_clock, MPAS_NOW)
-
- call mpas_get_time(curr_time, dateTimeString=timeString)
- state % xtime % scalar = timeString
-
- end do
-
- call mpas_output_state_finalize(sfc_update_obj, dminfo)
-
- end subroutine init_atm_test_case_sfc
-
-
!--------------------- TEST CASE 9 -----------------------------------------------
@@ -6200,48 +5366,6 @@
end subroutine init_atm_test_case_resting_atmosphere
- integer function nearest_cell(target_lat, target_lon, &
- start_cell, &
- nCells, maxEdges, nEdgesOnCell, cellsOnCell, latCell, lonCell)
-
- implicit none
-
- real (kind=RKIND), intent(in) :: target_lat, target_lon
- integer, intent(in) :: start_cell
- integer, intent(in) :: nCells, maxEdges
- integer, dimension(nCells), intent(in) :: nEdgesOnCell
- integer, dimension(maxEdges,nCells), intent(in) :: cellsOnCell
- real (kind=RKIND), dimension(nCells), intent(in) :: latCell, lonCell
-
- integer :: i
- integer :: iCell
- integer :: current_cell
- real (kind=RKIND) :: current_distance, d
- real (kind=RKIND) :: nearest_distance
-
- nearest_cell = start_cell
- current_cell = -1
-
- do while (nearest_cell /= current_cell)
- current_cell = nearest_cell
- current_distance = sphere_distance(latCell(current_cell), lonCell(current_cell), target_lat, target_lon, 1.0_RKIND)
- nearest_cell = current_cell
- nearest_distance = current_distance
- do i = 1, nEdgesOnCell(current_cell)
- iCell = cellsOnCell(i,current_cell)
- if (iCell <= nCells) then
- d = sphere_distance(latCell(iCell), lonCell(iCell), target_lat, target_lon, 1.0_RKIND)
- if (d < nearest_distance) then
- nearest_cell = iCell
- nearest_distance = d
- end if
- end if
- end do
- end do
-
- end function nearest_cell
-
-
integer function nearest_edge(target_lat, target_lon, &
start_edge, &
nCells, nEdges, maxEdges, nEdgesOnCell, edgesOnCell, cellsOnEdge, latCell, lonCell, latEdge, lonEdge)
@@ -6325,7 +5449,7 @@
if (present(extrap)) then
extrap_type = extrap
else
- interp_order = 1
+ extrap_type = 1
end if
if (present(surface_val)) then
@@ -6383,44 +5507,8 @@
end function vertical_interp
- subroutine init_atm_check_read_error(istatus, fname, dminfo)
-
- implicit none
-
- integer, intent(in) :: istatus
- character (len=*), intent(in) :: fname
- type (dm_info), intent(in) :: dminfo
-
- if (istatus /= 0) then
- write(0,*) 'ERROR: Could not read file '//trim(fname)
- call mpas_dmpar_abort(dminfo)
- end if
-
- end subroutine init_atm_check_read_error
-
-
!----------------------------------------------------------------------------------------------------------
- real (kind=RKIND) function sphere_distance(lat1, lon1, lat2, lon2, radius)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Compute the great-circle distance between (lat1, lon1) and (lat2, lon2) on a
- ! sphere with given radius.
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- real (kind=RKIND), intent(in) :: lat1, lon1, lat2, lon2, radius
-
- real (kind=RKIND) :: arg1
-
- arg1 = sqrt( sin(0.5*(lat2-lat1))**2 + &
- cos(lat1)*cos(lat2)*sin(0.5*(lon2-lon1))**2 )
- sphere_distance = 2.*radius*asin(arg1)
-
- end function sphere_distance
-
-!--------------------------------------------------------------------
-
real (kind=RKIND) function env_qv( z, temperature, pressure, rh_max )
implicit none
Modified: trunk/mpas/src/core_nhyd_atmos/Makefile
===================================================================
--- trunk/mpas/src/core_nhyd_atmos/Makefile 2013-03-27 19:24:59 UTC (rev 2673)
+++ trunk/mpas/src/core_nhyd_atmos/Makefile 2013-03-27 19:26:14 UTC (rev 2674)
@@ -5,7 +5,8 @@
OBJS = mpas_atm_mpas_core.o \
mpas_atm_time_integration.o \
- mpas_atm_advection.o
+ mpas_atm_advection.o \
+ mpas_atm_interp_diagnostics.o
all: physcore core_hyd
@@ -22,7 +23,7 @@
mpas_atm_advection.o:
-mpas_atm_mpas_core.o: mpas_atm_advection.o mpas_atm_time_integration.o
+mpas_atm_mpas_core.o: mpas_atm_advection.o mpas_atm_time_integration.o mpas_atm_interp_diagnostics.o
clean:
( cd ../core_atmos_physics; make clean )
Modified: trunk/mpas/src/core_nhyd_atmos/Registry
===================================================================
--- trunk/mpas/src/core_nhyd_atmos/Registry 2013-03-27 19:24:59 UTC (rev 2673)
+++ trunk/mpas/src/core_nhyd_atmos/Registry 2013-03-27 19:26:14 UTC (rev 2674)
@@ -15,6 +15,7 @@
namelist real nhyd_model config_h_theta_eddy_visc2 0.0
namelist real nhyd_model config_h_theta_eddy_visc4 0.0
namelist real nhyd_model config_v_theta_eddy_visc2 0.0
+namelist real nhyd_model config_visc4_2dsmag 0.0
namelist integer nhyd_model config_number_of_sub_steps 4
namelist integer nhyd_model config_w_adv_order 3
namelist integer nhyd_model config_theta_adv_order 3
@@ -33,7 +34,7 @@
namelist real nhyd_model config_smdiv 0.1
namelist logical nhyd_model config_newpx false
namelist real nhyd_model config_apvm_upwinding 0.5
-namelist logical nhyd_model config_h_ScaleWithMesh false
+namelist logical nhyd_model config_h_ScaleWithMesh true
namelist integer nhyd_model config_num_halos 2
namelist real damping config_zd 22000.0
namelist real damping config_xnutr 0.0
@@ -45,6 +46,7 @@
namelist integer io config_frames_per_outfile 0
namelist integer io config_pio_num_iotasks 0
namelist integer io config_pio_stride 1
+namelist character io config_pio_format pnetcdf
namelist character decomposition config_block_decomp_file_prefix graph.info.part.
namelist integer decomposition config_number_of_blocks 0
namelist logical decomposition config_explicit_proc_decomp .false.
@@ -283,15 +285,34 @@
% Space needed for deformation calculation weights
var persistent real defc_a ( maxEdges nCells ) 0 iro defc_a mesh - -
var persistent real defc_b ( maxEdges nCells ) 0 iro defc_b mesh - -
-var persistent real kdiff ( nVertLevels nCells Time ) 1 - kdiff diag - -
+var persistent real kdiff ( nVertLevels nCells Time ) 1 o kdiff diag - -
% Arrays required for reconstruction of velocity field
var persistent real coeffs_reconstruct ( R3 maxEdges nCells ) 0 iro coeffs_reconstruct mesh - -
% ADDED DECLARATIONS MADE BY LDF:
-var persistent real surface_pressure ( nCells Time ) 1 iro surface_pressure diag - -
-var persistent real surface_temperature ( nCells Time ) 1 o surface_temperature diag - -
+var persistent real surface_pressure ( nCells Time ) 1 iro surface_pressure diag - -
+var persistent real temperature_200hPa ( nCells Time ) 1 o temperature_200hPa diag - -
+var persistent real temperature_500hPa ( nCells Time ) 1 o temperature_500hPa diag - -
+var persistent real temperature_850hPa ( nCells Time ) 1 o temperature_850hPa diag - -
+var persistent real height_200hPa ( nCells Time ) 1 o height_200hPa diag - -
+var persistent real height_500hPa ( nCells Time ) 1 o height_500hPa diag - -
+var persistent real height_850hPa ( nCells Time ) 1 o height_850hPa diag - -
+var persistent real uzonal_200hPa ( nCells Time ) 1 o uzonal_200hPa diag - -
+var persistent real uzonal_500hPa ( nCells Time ) 1 o uzonal_500hPa diag - -
+var persistent real uzonal_850hPa ( nCells Time ) 1 o uzonal_850hPa diag - -
+var persistent real umeridional_200hPa ( nCells Time ) 1 o umeridional_200hPa diag - -
+var persistent real umeridional_500hPa ( nCells Time ) 1 o umeridional_500hPa diag - -
+var persistent real umeridional_850hPa ( nCells Time ) 1 o umeridional_850hPa diag - -
+var persistent real w_200hPa ( nCells Time ) 1 o w_200hPa diag - -
+var persistent real w_500hPa ( nCells Time ) 1 o w_500hPa diag - -
+var persistent real w_850hPa ( nCells Time ) 1 o w_850hPa diag - -
+
+var persistent real vorticity_200hPa ( nVertices Time ) 1 o vorticity_200hPa diag - -
+var persistent real vorticity_500hPa ( nVertices Time ) 1 o vorticity_500hPa diag - -
+var persistent real vorticity_850hPa ( nVertices Time ) 1 o vorticity_850hPa diag - -
+
%==================================================================================================
% DECLARATIONS OF ALL PHYSICS VARIABLES (will need to be moved to a Physics Registry shared by the
% hydrostatic and non-hydrostatic dynamical cores):
@@ -360,6 +381,7 @@
namelist character physics config_eddy_scheme off
namelist character physics config_lsm_scheme off
namelist character physics config_pbl_scheme off
+namelist character physics config_gwdo_scheme off
namelist character physics config_radt_cld_scheme off
namelist character physics config_radt_lw_scheme off
namelist character physics config_radt_sw_scheme off
@@ -402,7 +424,11 @@
% graupelnc : accumulated grid-scale precipitation of graupel (mm)
% graupelncv: time-step grid-scale precipitation of graupel (mm)
% sr : time-step ratio of frozen versus total grid-scale precipitation (-)
+% precipw : precipitable water (kg/m2)
+% refl10cm_max: maximum column reflectivity (dBz)
+var persistent real refl10cm_max ( nCells Time ) 1 o refl10cm_max diag_physics - -
+
var persistent integer i_rainnc ( nCells Time ) 1 ro i_rainnc diag_physics - -
var persistent real sr ( nCells Time ) 1 ro sr diag_physics - -
var persistent real rainncv ( nCells Time ) 1 ro rainncv diag_physics - -
@@ -413,8 +439,9 @@
var persistent real snownc ( nCells Time ) 1 ro snownc diag_physics - -
var persistent real graupelnc ( nCells Time ) 1 ro graupelnc diag_physics - -
-var persistent real qsat ( nVertLevels nCells Time ) 1 o qsat diag_physics - -
-var persistent real relhum ( nVertLevels nCells Time ) 1 o relhum diag_physics - -
+var persistent real precipw ( nCells Time ) 1 o precipw diag_physics - -
+var persistent real qsat ( nVertLevels nCells Time ) 1 o qsat diag_physics - -
+var persistent real relhum ( nVertLevels nCells Time ) 1 o relhum diag_physics - -
%--------------------------------------------------------------------------------------------------
%... PARAMETERIZATION OF CONVECTION:
@@ -488,7 +515,50 @@
var persistent real rqcblten ( nVertLevels nCells Time ) 1 ro rqcblten tend_physics - -
var persistent real rqiblten ( nVertLevels nCells Time ) 1 ro rqiblten tend_physics - -
+% TEMPORARY:
+var persistent real kzh ( nVertLevels nCells Time ) 1 o kzh diag_physics - -
+var persistent real kzm ( nVertLevels nCells Time ) 1 o kzm diag_physics - -
+var persistent real kzq ( nVertLevels nCells Time ) 1 o kzq diag_physics - -
+
%--------------------------------------------------------------------------------------------------
+%... PARAMETERIZATION OF GRAVITY WAVE DRAG OVER OROGRAPHY:
+%--------------------------------------------------------------------------------------------------
+
+% var2d : orographic variance (m2)
+% con : orographic convexity (m2)
+% oa1 : orographic direction asymmetry function (-)
+% oa2 : orographic direction asymmetry function (-)
+% oa3 : orographic direction asymmetry function (-)
+% oa4 : orographic direction asymmetry function (-)
+% ol1 : orographic direction asymmetry function (-)
+% ol2 : orographic direction asymmetry function (-)
+% ol3 : orographic direction asymmetry function (-)
+% ol4 : orographic direction asymmetry function (-)
+% dusfcg : vertically-integrated gravity wave drag over orography u-stress (Pa m s-1)
+% dvsfcg : vertically-integrated gravity wave drag over orography v-stress (Pa m s-1)
+% dtaux3d : gravity wave drag over orography u-stress (m s-1)
+% dtauy3d : gravity wave drag over orography v-stress (m s-1)
+
+var persistent real var2d ( nCells ) 0 iro var2d sfc_input - -
+var persistent real con ( nCells ) 0 iro con sfc_input - -
+var persistent real oa1 ( nCells ) 0 iro oa1 sfc_input - -
+var persistent real oa2 ( nCells ) 0 iro oa2 sfc_input - -
+var persistent real oa3 ( nCells ) 0 iro oa3 sfc_input - -
+var persistent real oa4 ( nCells ) 0 iro oa4 sfc_input - -
+var persistent real ol1 ( nCells ) 0 iro ol1 sfc_input - -
+var persistent real ol2 ( nCells ) 0 iro ol2 sfc_input - -
+var persistent real ol3 ( nCells ) 0 iro ol3 sfc_input - -
+var persistent real ol4 ( nCells ) 0 iro ol4 sfc_input - -
+
+var persistent real dusfcg ( nCells Time ) 1 ro dusfcg diag_physics - -
+var persistent real dvsfcg ( nCells Time ) 1 ro dvsfcg diag_physics - -
+var persistent real dtaux3d ( nVertLevels nCells Time ) 1 ro dtaux3d diag_physics - -
+var persistent real dtauy3d ( nVertLevels nCells Time ) 1 ro dtauy3d diag_physics - -
+
+var persistent real rubldiff ( nVertLevels nCells Time ) 1 ro rubldiff diag_physics - -
+var persistent real rvbldiff ( nVertLevels nCells Time ) 1 ro rvbldiff diag_physics - -
+
+%--------------------------------------------------------------------------------------------------
%... PARAMETERIZATION OF SURFACE LAYER PROCESSES:
%--------------------------------------------------------------------------------------------------
@@ -772,7 +842,6 @@
% noahres :residual of the noah land-surface scheme energy budget [W m-2]
% potevp :potential evaporation [W m-2]
% qz0 :specific humidity at znt [kg kg-1]
-% rib :??
% sfc_albedo :surface albedo [-]
% sfc_embck :background emissivity [-]
% sfc_emiss :surface emissivity [-]
@@ -781,8 +850,9 @@
% smstot :total moisture [m3 m-3]
% snopcx :snow phase change heat flux [W m-2]
% snotime :??
-% sstsk : skin sea-surface temperature [K]
-% sstsk_diur : skin sea-surface temperature difference [K]
+% sstsk : skin sea-surface temperature [K]
+% sstsk_dtc : skin sea-surface temperature cooling [K]
+% sstsk_dtw : skin sea-surface temperature warming [K]
% thc :thermal inertia [Cal cm-1 K-1 s-0.5]
% udrunoff :sub-surface runoff [m s-1]
% xicem :ice mask from previous time-step [-]
@@ -798,7 +868,6 @@
var persistent real noahres ( nCells Time ) 1 ro noahres diag_physics - -
var persistent real potevp ( nCells Time ) 1 ro potevp diag_physics - -
var persistent real qz0 ( nCells Time ) 1 ro qz0 diag_physics - -
-var persistent real rib ( nCells Time ) 1 ro rib diag_physics - -
var persistent real sfc_albedo ( nCells Time ) 1 ro sfc_albedo diag_physics - -
var persistent real sfc_emiss ( nCells Time ) 1 ro sfc_emiss diag_physics - -
var persistent real sfc_emibck ( nCells Time ) 1 ro sfc_emibck diag_physics - -
@@ -808,7 +877,8 @@
var persistent real snopcx ( nCells Time ) 1 ro snopcx diag_physics - -
var persistent real snotime ( nCells Time ) 1 ro snotime diag_physics - -
var persistent real sstsk ( nCells Time ) 1 ro sstsk diag_physics - -
-var persistent real sstsk_diur ( nCells Time ) 1 ro sstsk_diur diag_physics - -
+var persistent real sstsk_dtc ( nCells Time ) 1 ro sstsk_dtc diag_physics - -
+var persistent real sstsk_dtw ( nCells Time ) 1 ro sstsk_dtw diag_physics - -
var persistent real thc ( nCells Time ) 1 ro thc diag_physics - -
var persistent real udrunoff ( nCells Time ) 1 ro udrunoff diag_physics - -
var persistent real xicem ( nCells Time ) 1 ro xicem diag_physics - -
Modified: trunk/mpas/src/core_nhyd_atmos/Registry.xml
===================================================================
--- trunk/mpas/src/core_nhyd_atmos/Registry.xml 2013-03-27 19:24:59 UTC (rev 2673)
+++ trunk/mpas/src/core_nhyd_atmos/Registry.xml 2013-03-27 19:26:14 UTC (rev 2674)
@@ -48,6 +48,7 @@
<nml_option name="config_h_theta_eddy_visc2" type="real" default_value="0.0"/>
<nml_option name="config_h_theta_eddy_visc4" type="real" default_value="0.0"/>
<nml_option name="config_v_theta_eddy_visc2" type="real" default_value="0.0"/>
+ <nml_option name="config_visc4_2dsmag" type="real" default_value="0.0"/>
<nml_option name="config_number_of_sub_steps" type="integer" default_value="4"/>
<nml_option name="config_w_adv_order" type="integer" default_value="3"/>
<nml_option name="config_theta_adv_order" type="integer" default_value="3"/>
@@ -66,7 +67,7 @@
<nml_option name="config_smdiv" type="real" default_value="0.1"/>
<nml_option name="config_newpx" type="logical" default_value="false"/>
<nml_option name="config_apvm_upwinding" type="real" default_value="0.5"/>
- <nml_option name="config_h_ScaleWithMesh" type="logical" default_value="false"/>
+ <nml_option name="config_h_ScaleWithMesh" type="logical" default_value="true"/>
<nml_option name="config_num_halos" type="integer" default_value="2"/>
</nml_record>
@@ -84,12 +85,13 @@
<nml_option name="config_frames_per_outfile" type="integer" default_value="0"/>
<nml_option name="config_pio_num_iotasks" type="integer" default_value="0"/>
<nml_option name="config_pio_stride" type="integer" default_value="1"/>
+ <nml_option name="config_pio_format" type="character" default_value="pnetcdf"/>
</nml_record>
<nml_record name="decomposition">
<nml_option name="config_block_decomp_file_prefix" type="character" default_value="graph.info.part."/>
<nml_option name="config_number_of_blocks" type="integer" default_value="0"/>
- <nml_option name="config_explicit_proc_decomp" type="logical" default_value=".false."/>
+ <nml_option name="config_explicit_proc_decomp" type="logical" default_value="false"/>
<nml_option name="config_proc_decomp_file_prefix" type="character" default_value="graph.info.part."/>
</nml_record>
@@ -320,10 +322,28 @@
<var name="rho_pp" type="real" dimensions="nVertLevels nCells Time"/>
<var name="rho_p_save" type="real" dimensions="nVertLevels nCells Time"/>
- <var name="kdiff" type="real" dimensions="nVertLevels nCells Time"/>
+ <var name="kdiff" type="real" dimensions="nVertLevels nCells Time" streams="o"/>
<var name="surface_pressure" type="real" dimensions="nCells Time" streams="iro"/>
- <var name="surface_temperature" type="real" dimensions="nCells Time" streams="o"/>
+
+ <var name="temperature_200hPa" type="real" dimensions="nCells Time" streams="o"/>
+ <var name="temperature_500hPa" type="real" dimensions="nCells Time" streams="o"/>
+ <var name="temperature_850hPa" type="real" dimensions="nCells Time" streams="o"/>
+ <var name="height_200hPa" type="real" dimensions="nCells Time" streams="o"/>
+ <var name="height_500hPa" type="real" dimensions="nCells Time" streams="o"/>
+ <var name="height_850hPa" type="real" dimensions="nCells Time" streams="o"/>
+ <var name="uzonal_200hPa" type="real" dimensions="nCells Time" streams="o"/>
+ <var name="uzonal_500hPa" type="real" dimensions="nCells Time" streams="o"/>
+ <var name="uzonal_850hPa" type="real" dimensions="nCells Time" streams="o"/>
+ <var name="umeridional_200hPa" type="real" dimensions="nCells Time" streams="o"/>
+ <var name="umeridional_500hPa" type="real" dimensions="nCells Time" streams="o"/>
+ <var name="umeridional_850hPa" type="real" dimensions="nCells Time" streams="o"/>
+ <var name="w_200hPa" type="real" dimensions="nCells Time" streams="o"/>
+ <var name="w_500hPa" type="real" dimensions="nCells Time" streams="o"/>
+ <var name="w_850hPa" type="real" dimensions="nCells Time" streams="o"/>
+ <var name="vorticity_200hPa" type="real" dimensions="nVertices Time" streams="o"/>
+ <var name="vorticity_500hPa" type="real" dimensions="nVertices Time" streams="o"/>
+ <var name="vorticity_850hPa" type="real" dimensions="nVertices Time" streams="o"/>
</var_struct>
<var_struct name="tend" time_levs="1">
@@ -405,6 +425,7 @@
<nml_option name="config_eddy_scheme" type="character" default_value="off"/>
<nml_option name="config_lsm_scheme" type="character" default_value="off"/>
<nml_option name="config_pbl_scheme" type="character" default_value="off"/>
+ <nml_option name="config_gwdo_scheme" type="character" default_value="off"/>
<nml_option name="config_radt_cld_scheme" type="character" default_value="off"/>
<nml_option name="config_radt_lw_scheme" type="character" default_value="off"/>
<nml_option name="config_radt_sw_scheme" type="character" default_value="off"/>
@@ -447,7 +468,11 @@
<!-- graupelnc : accumulated grid-scale precipitation of graupel (mm) -->
<!-- graupelncv: time-step grid-scale precipitation of graupel (mm) -->
<!-- sr : time-step ratio of frozen versus total grid-scale precipitation (-) -->
+ <!-- precipw : precipitable water (kg/m2) -->
+ <!-- refl10cm_max: maximum column reflectivity (dBz) -->
+ <var name="refl10cm_max" type="real" dimensions="nCells Time" streams="ro"/>
+
<var name="i_rainnc" type="integer" dimensions="nCells Time" streams="ro"/>
<var name="sr" type="real" dimensions="nCells Time" streams="ro"/>
<var name="rainncv" type="real" dimensions="nCells Time" streams="ro"/>
@@ -458,6 +483,7 @@
<var name="snownc" type="real" dimensions="nCells Time" streams="ro"/>
<var name="graupelnc" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="precipw" type="real" dimensions="nCells Time" streams="o"/>
<var name="qsat" type="real" dimensions="nVertLevels nCells Time" streams="o"/>
<var name="relhum" type="real" dimensions="nVertLevels nCells Time" streams="o"/>
@@ -497,6 +523,12 @@
<var name="hpbl" type="real" dimensions="nCells Time" streams="ro"/>
<var name="exch_h" type="real" dimensions="nVertLevels nCells Time" streams="o"/>
+ <!-- TEMPORARY: -->
+ <var name="kzh" type="real" dimensions="nVertLevels nCells Time" streams="o"/>
+ <var name="kzm" type="real" dimensions="nVertLevels nCells Time" streams="o"/>
+ <var name="kzq" type="real" dimensions="nVertLevels nCells Time" streams="o"/>
+
+
<!-- ================================================================================================== -->
<!-- ... PARAMETERIZATION OF SURFACE LAYER PROCESSES: -->
<!-- ================================================================================================== -->
@@ -571,7 +603,26 @@
<var name="t2m" type="real" dimensions="nCells Time" streams="ro"/>
<var name="th2m" type="real" dimensions="nCells Time" streams="ro"/>
+
<!-- ================================================================================================== -->
+ <!-- ... PARAMETERIZATION OF GRAVITY WAVE DRAG OVER OROGRAPHY: -->
+ <!-- ================================================================================================== -->
+
+ <!-- dusfcg : vertically-integrated gravity wave drag over orography u-stress (Pa m s-1) -->
+ <!-- dvsfcg : vertically-integrated gravity wave drag over orography v-stress (Pa m s-1) -->
+ <!-- dtaux3d : gravity wave drag over orography u-stress (m s-1) -->
+ <!-- dtauy3d : gravity wave drag over orography v-stress (m s-1) -->
+
+ <var name="dusfcg" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="dvsfcg" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="dtaux3d" type="real" dimensions="nVertLevels nCells Time" streams="ro"/>
+ <var name="dtauy3d" type="real" dimensions="nVertLevels nCells Time" streams="ro"/>
+
+ <var name="rubldiff" type="real" dimensions="nVertLevels nCells Time" streams="ro"/>
+ <var name="rvbldiff" type="real" dimensions="nVertLevels nCells Time" streams="ro"/>
+
+
+ <!-- ================================================================================================== -->
<!-- ... PARAMETERIZATION OF SHORTWAVE RADIATION: -->
<!-- ================================================================================================== -->
<!-- coszr :cosine of the solar zenith angle [-] -->
@@ -750,7 +801,6 @@
<!-- noahres :residual of the noah land-surface scheme energy budget [W m-2] -->
<!-- potevp :potential evaporation [W m-2] -->
<!-- qz0 :specific humidity at znt [kg kg-1] -->
- <!-- rib :?? -->
<!-- sfc_albedo :surface albedo [-] -->
<!-- sfc_embck :background emissivity [-] -->
<!-- sfc_emiss :surface emissivity [-] -->
@@ -760,7 +810,8 @@
<!-- snopcx :snow phase change heat flux [W m-2] -->
<!-- snotime :?? -->
<!-- sstsk : skin sea-surface temperature [K] -->
- <!-- sstsk_diur : skin sea-surface temperature difference [K] -->
+ <!-- sstsk_dtc : skin sea-surface temperature cooling [K] -->
+ <!-- sstsk_dtw : skin sea-surface temperature warming [K] -->
<!-- thc :thermal inertia [Cal cm-1 K-1 s-0.5] -->
<!-- udrunoff :sub-surface runoff [m s-1] -->
<!-- xicem :ice mask from previous time-step [-] -->
@@ -776,7 +827,6 @@
<var name="noahres" type="real" dimensions="nCells Time" streams="ro"/>
<var name="potevp" type="real" dimensions="nCells Time" streams="ro"/>
<var name="qz0" type="real" dimensions="nCells Time" streams="ro"/>
- <var name="rib" type="real" dimensions="nCells Time" streams="ro"/>
<var name="sfc_albedo" type="real" dimensions="nCells Time" streams="ro"/>
<var name="sfc_emiss" type="real" dimensions="nCells Time" streams="ro"/>
<var name="sfc_emibck" type="real" dimensions="nCells Time" streams="ro"/>
@@ -786,7 +836,8 @@
<var name="snopcx" type="real" dimensions="nCells Time" streams="ro"/>
<var name="snotime" type="real" dimensions="nCells Time" streams="ro"/>
<var name="sstsk" type="real" dimensions="nCells Time" streams="ro"/>
- <var name="sstsk_diur" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="sstsk_dtc" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="sstsk_dtw" type="real" dimensions="nCells Time" streams="ro"/>
<var name="thc" type="real" dimensions="nCells Time" streams="ro"/>
<var name="udrunoff" type="real" dimensions="nCells Time" streams="ro"/>
<var name="xicem" type="real" dimensions="nCells Time" streams="ro"/>
@@ -913,5 +964,31 @@
<var name="sh2o" type="real" dimensions="nSoilLevels nCells Time" streams="iro"/>
<var name="smois" type="real" dimensions="nSoilLevels nCells Time" streams="iro"/>
<var name="tslb" type="real" dimensions="nSoilLevels nCells Time" streams="iro"/>
+
+ <!-- ================================================================================================== -->
+ <!-- ... PARAMETERIZATION OF GRAVITY WAVE DRAG OVER OROGRAPHY: -->
+ <!-- ================================================================================================== -->
+
+ <!-- var2d : orographic variance (m2) -->
+ <!-- con : orographic convexity (m2) -->
+ <!-- oa1 : orographic direction asymmetry function (-) -->
+ <!-- oa2 : orographic direction asymmetry function (-) -->
+ <!-- oa3 : orographic direction asymmetry function (-) -->
+ <!-- oa4 : orographic direction asymmetry function (-) -->
+ <!-- ol1 : orographic direction asymmetry function (-) -->
+ <!-- ol2 : orographic direction asymmetry function (-) -->
+ <!-- ol3 : orographic direction asymmetry function (-) -->
+ <!-- ol4 : orographic direction asymmetry function (-) -->
+
+ <var name="var2d" type="real" dimensions="nCells" streams="iro"/>
+ <var name="con" type="real" dimensions="nCells" streams="iro"/>
+ <var name="oa1" type="real" dimensions="nCells" streams="iro"/>
+ <var name="oa2" type="real" dimensions="nCells" streams="iro"/>
+ <var name="oa3" type="real" dimensions="nCells" streams="iro"/>
+ <var name="oa4" type="real" dimensions="nCells" streams="iro"/>
+ <var name="ol1" type="real" dimensions="nCells" streams="iro"/>
+ <var name="ol2" type="real" dimensions="nCells" streams="iro"/>
+ <var name="ol3" type="real" dimensions="nCells" streams="iro"/>
+ <var name="ol4" type="real" dimensions="nCells" streams="iro"/>
</var_struct>
</registry>
Modified: trunk/mpas/src/core_nhyd_atmos/mpas_atm_advection.F
===================================================================
--- trunk/mpas/src/core_nhyd_atmos/mpas_atm_advection.F 2013-03-27 19:24:59 UTC (rev 2673)
+++ trunk/mpas/src/core_nhyd_atmos/mpas_atm_advection.F 2013-03-27 19:26:14 UTC (rev 2674)
@@ -26,43 +26,33 @@
! local variables
real (kind=RKIND), dimension(2, grid % nEdges) :: thetae
- real (kind=RKIND), dimension(grid % nEdges) :: xe, ye
real (kind=RKIND), dimension(grid % nCells) :: theta_abs
real (kind=RKIND), dimension(25) :: xc, yc, zc ! cell center coordinates
real (kind=RKIND), dimension(25) :: thetav, thetat, dl_sphere
- real (kind=RKIND) :: xm, ym, zm, dl, xec, yec, zec
- real (kind=RKIND) :: thetae_tmp, xe_tmp, ye_tmp
+ real (kind=RKIND) :: xec, yec, zec
+ real (kind=RKIND) :: thetae_tmp
real (kind=RKIND) :: xv1, xv2, yv1, yv2, zv1, zv2
- integer :: i, j, k, ip1, ip2, m, n, ip1a, ii
+ integer :: i, j, k, ip1, ip2, n
integer :: iCell, iEdge
real (kind=RKIND) :: pii
- real (kind=RKIND) :: x0, y0, x1, y1, x2, y2, x3, y3, x4, y4, x5, y5
- real (kind=RKIND) :: pdx1, pdx2, pdx3, pdy1, pdy2, pdy3, dx1, dx2, dy1, dy2
- real (kind=RKIND) :: angv1, angv2, dl1, dl2
- real (kind=RKIND), dimension(25) :: dxe, dye, x2v, y2v, xp, yp
+ real (kind=RKIND), dimension(25) :: xp, yp
real (kind=RKIND) :: amatrix(25,25), bmatrix(25,25), wmatrix(25,25)
real (kind=RKIND) :: length_scale
- integer :: ma,na, cell_add, mw, nn
+ integer :: ma,na, cell_add, mw
integer, dimension(25) :: cell_list
+ logical :: add_the_cell, do_the_cell
+ real (kind=RKIND) :: cos2t, costsint, sin2t
+ real (kind=RKIND), dimension(grid%maxEdges) :: angle_2d
- integer :: cell1, cell2
integer, parameter :: polynomial_order = 2
-! logical, parameter :: debug = .true.
logical, parameter :: debug = .false.
-! logical, parameter :: least_squares = .false.
logical, parameter :: least_squares = .true.
- logical :: add_the_cell, do_the_cell
-
logical, parameter :: reset_poly = .true.
- real (kind=RKIND) :: rcell, cos2t, costsint, sin2t
- real (kind=RKIND), dimension(grid%maxEdges) :: angle_2d
-!---
-
pii = 2.*asin(1.0)
advCells => grid % advCells % array
@@ -119,7 +109,7 @@
theta_abs(iCell) = pii/2. - sphere_angle( xc(1), yc(1), zc(1), &
xc(2), yc(2), zc(2), &
0.0_RKIND, 0.0_RKIND, 1.0_RKIND )
-
+
! angles from cell center to neighbor centers (thetav)
do i=1,n-1
@@ -130,7 +120,7 @@
thetav(i) = sphere_angle( xc(1), yc(1), zc(1), &
xc(i+1), yc(i+1), zc(i+1), &
xc(ip2), yc(ip2), zc(ip2) )
-
+
dl_sphere(i) = grid%sphere_radius*arc_length( xc(1), yc(1), zc(1), &
xc(i+1), yc(i+1), zc(i+1) )
end do
@@ -159,10 +149,10 @@
iEdge = grid % EdgesOnCell % array(i,iCell)
if ( iCell .ne. grid % CellsOnEdge % array(1,iEdge)) &
angle_2d(i) = angle_2d(i) - pii
+
+! xp(i) = grid % xCell % array(cell_list(i)) - grid % xCell % array(iCell)
+! yp(i) = grid % yCell % array(cell_list(i)) - grid % yCell % array(iCell)
-! xp(i) = grid % xCell % array(cell_list(i)) - grid % xCell % array(iCell)
-! yp(i) = grid % yCell % array(cell_list(i)) - grid % yCell % array(iCell)
-
xp(i) = grid % dcEdge % array(grid % EdgesOnCell % array(i,iCell)) * cos(angle_2d(i))
yp(i) = grid % dcEdge % array(grid % EdgesOnCell % array(i,iCell)) * sin(angle_2d(i))
@@ -205,20 +195,20 @@
amatrix(i,1) = 1.
amatrix(i,2) = xp(i-1)
amatrix(i,3) = yp(i-1)
-
+
amatrix(i,4) = xp(i-1)**2
amatrix(i,5) = xp(i-1) * yp(i-1)
amatrix(i,6) = yp(i-1)**2
-
+
amatrix(i,7) = xp(i-1)**3
amatrix(i,8) = yp(i-1) * (xp(i-1)**2)
amatrix(i,9) = xp(i-1) * (yp(i-1)**2)
amatrix(i,10) = yp(i-1)**3
+
+ wmatrix(i,i) = 1.
- wmatrix(i,i) = 1.
-
end do
-
+
else
na = 15
ma = ma+1
@@ -229,16 +219,16 @@
amatrix(i,1) = 1.
amatrix(i,2) = xp(i-1)
amatrix(i,3) = yp(i-1)
-
+
amatrix(i,4) = xp(i-1)**2
amatrix(i,5) = xp(i-1) * yp(i-1)
amatrix(i,6) = yp(i-1)**2
-
+
amatrix(i,7) = xp(i-1)**3
amatrix(i,8) = yp(i-1) * (xp(i-1)**2)
amatrix(i,9) = xp(i-1) * (yp(i-1)**2)
amatrix(i,10) = yp(i-1)**3
-
+
amatrix(i,11) = xp(i-1)**4
amatrix(i,12) = yp(i-1) * (xp(i-1)**3)
amatrix(i,13) = (xp(i-1)**2)*(yp(i-1)**2)
@@ -248,11 +238,11 @@
wmatrix(i,i) = 1.
end do
-
+
do i=1,mw
wmatrix(i,i) = 1.
end do
-
+
end if
call poly_fit_2( amatrix, bmatrix, wmatrix, ma, na, 25 )
@@ -363,7 +353,6 @@
if (debug) stop
-
! write(0,*) ' check for deriv2 coefficients, iEdge 4 '
!
! iEdge = 4
@@ -400,9 +389,7 @@
real (kind=RKIND) :: a, b, c ! Side lengths of spherical triangle ABC
real (kind=RKIND) :: ABx, ABy, ABz ! The components of the vector AB
- real (kind=RKIND) :: mAB ! The magnitude of AB
real (kind=RKIND) :: ACx, ACy, ACz ! The components of the vector AC
- real (kind=RKIND) :: mAC ! The magnitude of AC
real (kind=RKIND) :: Dx ! The i-components of the cross product AB x AC
real (kind=RKIND) :: Dy ! The j-components of the cross product AB x AC
@@ -571,16 +558,15 @@
real (kind=RKIND), dimension(n,m) :: b
real (kind=RKIND), dimension(m,m) :: w,wt,h
real (kind=RKIND), dimension(n,m) :: at, ath
- real (kind=RKIND), dimension(n,n) :: ata, ata_inv, atha, atha_inv
+ real (kind=RKIND), dimension(n,n) :: ata, atha, atha_inv
+! real (kind=RKIND), dimension(n,n) :: ata_inv
integer, dimension(n) :: indx
- integer :: i,j
if ( (ne<n) .or. (ne<m) ) then
write(6,*) ' error in poly_fit_2 inversion ',m,n,ne
stop
end if
-! a(1:m,1:n) = a_in(1:n,1:m)
a(1:m,1:n) = a_in(1:m,1:n)
w(1:m,1:m) = weights_in(1:m,1:m)
b_out(:,:) = 0.
@@ -615,134 +601,133 @@
end subroutine poly_fit_2
-! Updated 10/24/2001.
-!
-!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 4.4 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! !
-! Please Note: !
-! !
-! (1) This computer program is written by Tao Pang in conjunction with !
-! his book, "An Introduction to Computational Physics," published !
-! by Cambridge University Press in 1997. !
-! !
-! (2) No warranties, express or implied, are made for this program. !
-! !
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!
-SUBROUTINE MIGS (A,N,X,INDX)
-!
-! Subroutine to invert matrix A(N,N) with the inverse stored
-! in X(N,N) in the output. Copyright (c) Tao Pang 2001.
-!
- IMPLICIT NONE
- INTEGER, INTENT (IN) :: N
- INTEGER :: I,J,K
- INTEGER, INTENT (OUT), DIMENSION (N) :: INDX
- REAL (kind=RKIND), INTENT (INOUT), DIMENSION (N,N):: A
- REAL (kind=RKIND), INTENT (OUT), DIMENSION (N,N):: X
- REAL (kind=RKIND), DIMENSION (N,N) :: B
-!
- DO I = 1, N
- DO J = 1, N
- B(I,J) = 0.0
- END DO
- END DO
- DO I = 1, N
- B(I,I) = 1.0
- END DO
-!
- CALL ELGS (A,N,INDX)
-!
- DO I = 1, N-1
- DO J = I+1, N
- DO K = 1, N
- B(INDX(J),K) = B(INDX(J),K)-A(INDX(J),I)*B(INDX(I),K)
- END DO
- END DO
- END DO
-!
- DO I = 1, N
- X(N,I) = B(INDX(N),I)/A(INDX(N),N)
- DO J = N-1, 1, -1
- X(J,I) = B(INDX(J),I)
- DO K = J+1, N
- X(J,I) = X(J,I)-A(INDX(J),K)*X(K,I)
- END DO
- X(J,I) = X(J,I)/A(INDX(J),J)
- END DO
- END DO
-END SUBROUTINE MIGS
+ ! Updated 10/24/2001.
+ !
+ !!!!!!!!!!!!!!!!!!!!!!!!!!! Program 4.4 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! !
+ ! Please Note: !
+ ! !
+ ! (1) This computer program is written by Tao Pang in conjunction with !
+ ! his book, "An Introduction to Computational Physics," published !
+ ! by Cambridge University Press in 1997. !
+ ! !
+ ! (2) No warranties, express or implied, are made for this program. !
+ ! !
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !
+ SUBROUTINE MIGS (A,N,X,INDX)
+ !
+ ! Subroutine to invert matrix A(N,N) with the inverse stored
+ ! in X(N,N) in the output. Copyright (c) Tao Pang 2001.
+ !
+ IMPLICIT NONE
+ INTEGER, INTENT (IN) :: N
+ INTEGER :: I,J,K
+ INTEGER, INTENT (OUT), DIMENSION (N) :: INDX
+ REAL (kind=RKIND), INTENT (INOUT), DIMENSION (N,N):: A
+ REAL (kind=RKIND), INTENT (OUT), DIMENSION (N,N):: X
+ REAL (kind=RKIND), DIMENSION (N,N) :: B
+ !
+ DO I = 1, N
+ DO J = 1, N
+ B(I,J) = 0.0
+ END DO
+ END DO
+ DO I = 1, N
+ B(I,I) = 1.0
+ END DO
+ !
+ CALL ELGS (A,N,INDX)
+ !
+ DO I = 1, N-1
+ DO J = I+1, N
+ DO K = 1, N
+ B(INDX(J),K) = B(INDX(J),K)-A(INDX(J),I)*B(INDX(I),K)
+ END DO
+ END DO
+ END DO
+ !
+ DO I = 1, N
+ X(N,I) = B(INDX(N),I)/A(INDX(N),N)
+ DO J = N-1, 1, -1
+ X(J,I) = B(INDX(J),I)
+ DO K = J+1, N
+ X(J,I) = X(J,I)-A(INDX(J),K)*X(K,I)
+ END DO
+ X(J,I) = X(J,I)/A(INDX(J),J)
+ END DO
+ END DO
+ END SUBROUTINE MIGS
-SUBROUTINE ELGS (A,N,INDX)
-!
-! Subroutine to perform the partial-pivoting Gaussian elimination.
-! A(N,N) is the original matrix in the input and transformed matrix
-! plus the pivoting element ratios below the diagonal in the output.
-! INDX(N) records the pivoting order. Copyright (c) Tao Pang 2001.
-!
- IMPLICIT NONE
- INTEGER, INTENT (IN) :: N
- INTEGER :: I,J,K,ITMP
- INTEGER, INTENT (OUT), DIMENSION (N) :: INDX
- REAL (kind=RKIND) :: C1,PI,PI1,PJ
- REAL (kind=RKIND), INTENT (INOUT), DIMENSION (N,N) :: A
- REAL (kind=RKIND), DIMENSION (N) :: C
-!
-! Initialize the index
-!
- DO I = 1, N
- INDX(I) = I
- END DO
-!
-! Find the rescaling factors, one from each row
-!
- DO I = 1, N
- C1= 0.0
- DO J = 1, N
- C1 = MAX(C1,ABS(A(I,J)))
- END DO
- C(I) = C1
- END DO
-!
-! Search the pivoting (largest) element from each column
-!
- DO J = 1, N-1
- PI1 = 0.0
- DO I = J, N
- PI = ABS(A(INDX(I),J))/C(INDX(I))
- IF (PI.GT.PI1) THEN
- PI1 = PI
- K = I
- ENDIF
- END DO
-!
-! Interchange the rows via INDX(N) to record pivoting order
-!
- ITMP = INDX(J)
- INDX(J) = INDX(K)
- INDX(K) = ITMP
- DO I = J+1, N
- PJ = A(INDX(I),J)/A(INDX(J),J)
-!
-! Record pivoting ratios below the diagonal
-!
- A(INDX(I),J) = PJ
-!
-! Modify other elements accordingly
-!
- DO K = J+1, N
- A(INDX(I),K) = A(INDX(I),K)-PJ*A(INDX(J),K)
- END DO
- END DO
- END DO
-!
-END SUBROUTINE ELGS
+ SUBROUTINE ELGS (A,N,INDX)
+ !
+ ! Subroutine to perform the partial-pivoting Gaussian elimination.
+ ! A(N,N) is the original matrix in the input and transformed matrix
+ ! plus the pivoting element ratios below the diagonal in the output.
+ ! INDX(N) records the pivoting order. Copyright (c) Tao Pang 2001.
+ !
+ IMPLICIT NONE
+ INTEGER, INTENT (IN) :: N
+ INTEGER :: I,J,K,ITMP
+ INTEGER, INTENT (OUT), DIMENSION (N) :: INDX
+ REAL (kind=RKIND) :: C1,PI,PI1,PJ
+ REAL (kind=RKIND), INTENT (INOUT), DIMENSION (N,N) :: A
+ REAL (kind=RKIND), DIMENSION (N) :: C
+ !
+ ! Initialize the index
+ !
+ DO I = 1, N
+ INDX(I) = I
+ END DO
+ !
+ ! Find the rescaling factors, one from each row
+ !
+ DO I = 1, N
+ C1= 0.0
+ DO J = 1, N
+ C1 = MAX(C1,ABS(A(I,J)))
+ END DO
+ C(I) = C1
+ END DO
+ !
+ ! Search the pivoting (largest) element from each column
+ !
+ DO J = 1, N-1
+ PI1 = 0.0
+ DO I = J, N
+ PI = ABS(A(INDX(I),J))/C(INDX(I))
+ IF (PI.GT.PI1) THEN
+ PI1 = PI
+ K = I
+ ENDIF
+ END DO
+ !
+ ! Interchange the rows via INDX(N) to record pivoting order
+ !
+ ITMP = INDX(J)
+ INDX(J) = INDX(K)
+ INDX(K) = ITMP
+ DO I = J+1, N
+ PJ = A(INDX(I),J)/A(INDX(J),J)
+ !
+ ! Record pivoting ratios below the diagonal
+ !
+ A(INDX(I),J) = PJ
+ !
+ ! Modify other elements accordingly
+ !
+ DO K = J+1, N
+ A(INDX(I),K) = A(INDX(I),K)-PJ*A(INDX(J),K)
+ END DO
+ END DO
+ END DO
+ !
+ END SUBROUTINE ELGS
+
-!-------------------------------------------------------------
-
subroutine atm_initialize_deformation_weights( grid )
!
@@ -758,30 +743,22 @@
! local variables
- real (kind=RKIND), dimension(2, grid % nEdges) :: thetae
- real (kind=RKIND), dimension(grid % nEdges) :: xe, ye
real (kind=RKIND), dimension(grid % nCells) :: theta_abs
real (kind=RKIND), dimension(25) :: xc, yc, zc ! cell center coordinates
real (kind=RKIND), dimension(25) :: thetav, thetat, dl_sphere
- real (kind=RKIND) :: xm, ym, zm, dl, xec, yec, zec
- real (kind=RKIND) :: thetae_tmp, xe_tmp, ye_tmp
- real (kind=RKIND) :: xv1, xv2, yv1, yv2, zv1, zv2
- integer :: i, j, k, ip1, ip2, m, n, ip1a, ii
- integer :: iCell, iEdge
+ real (kind=RKIND) :: dl
+ integer :: i, ip1, ip2, n
+ integer :: iCell
real (kind=RKIND) :: pii
- real (kind=RKIND) :: x0, y0, x1, y1, x2, y2, x3, y3, x4, y4, x5, y5
- real (kind=RKIND) :: pdx1, pdx2, pdx3, pdy1, pdy2, pdy3, dx1, dx2, dy1, dy2
- real (kind=RKIND) :: angv1, angv2, dl1, dl2
- real (kind=RKIND), dimension(25) :: dxe, dye, x2v, y2v, xp, yp, xpt, ypt
+ real (kind=RKIND), dimension(25) :: xp, yp
real (kind=RKIND) :: length_scale
- integer :: ma,na, cell_add, mw, nn
integer, dimension(25) :: cell_list
- integer :: cell1, cell2, iv
+ integer :: iv
logical :: do_the_cell
- real (kind=RKIND) :: area_cell, sint2, cost2, sint_cost, sumw1, sumw2, xptt, area_cellt
+ real (kind=RKIND) :: area_cell, sint2, cost2, sint_cost, area_cellt
logical, parameter :: debug = .false.
Added: trunk/mpas/src/core_nhyd_atmos/mpas_atm_interp_diagnostics.F
===================================================================
--- trunk/mpas/src/core_nhyd_atmos/mpas_atm_interp_diagnostics.F (rev 0)
+++ trunk/mpas/src/core_nhyd_atmos/mpas_atm_interp_diagnostics.F 2013-03-27 19:26:14 UTC (rev 2674)
@@ -0,0 +1,383 @@
+!==================================================================================================
+ module mpas_atm_interp_diagnostics
+ use mpas_kind_types
+ use mpas_grid_types
+ use mpas_constants
+
+ implicit none
+ private
+ public:: interp_diagnostics
+
+ contains
+
+!==================================================================================================
+ subroutine interp_diagnostics(mesh,state,diag)
+!==================================================================================================
+
+!input arguments:
+ type(mesh_type),intent(in) :: mesh
+ type(state_type),intent(in):: state
+
+!inout arguments:
+ type(diag_type),intent(inout):: diag
+
+!local variables:
+ integer:: iCell,iVert,iVertD,k,kk
+ integer:: nCells,nVertLevels,nVertLevelsP1,nVertices,VertexDegree
+ integer,dimension(:,:),pointer:: cellsOnVertex
+
+ real(kind=RKIND),dimension(:),pointer:: areaTriangle
+ real(kind=RKIND),dimension(:,:),pointer:: kiteAreasOnVertex
+
+ real(kind=RKIND),dimension(:,:),pointer:: exner,height
+ real(kind=RKIND),dimension(:,:),pointer:: pressure_b,pressure_p
+ real(kind=RKIND),dimension(:,:),pointer:: qvapor,theta_m,vorticity
+ real(kind=RKIND),dimension(:,:),pointer:: umeridional,uzonal,vvel
+
+ real(kind=RKIND),dimension(:,:),allocatable:: pressure,pressureCp1,pressure2,pressure_v,temperature
+
+!local interpolated fields:
+ integer:: nIntP
+ real(kind=RKIND):: w1,w2,z0,z1,z2
+ real(kind=RKIND),dimension(:,:),allocatable:: field_in,press_in
+ real(kind=RKIND),dimension(:,:),allocatable:: field_interp,press_interp
+
+!--------------------------------------------------------------------------------------------------
+
+ write(0,*)
+ write(0,*) '--- enter subroutine interp_diagnostics:'
+
+ nCells = mesh % nCells
+ nVertLevels = mesh % nVertLevels
+!nVertLevelsP1 = mesh % nVertLevelsP1
+ nVertices = mesh % nVertices
+ VertexDegree = mesh % vertexDegree
+ nVertLevelsP1 = nVertLevels + 1
+
+ cellsOnVertex => mesh % cellsOnVertex % array
+ areaTriangle => mesh % areaTriangle % array
+ kiteAreasOnVertex => mesh % kiteAreasOnVertex % array
+
+ height => mesh % zgrid % array
+ vvel => state % w % array
+ theta_m => state % theta_m % array
+ qvapor => state % scalars % array(state%index_qv,:,:)
+
+ exner => diag % exner % array
+ pressure_b => diag % pressure_base % array
+ pressure_p => diag % pressure_p % array
+ vorticity => diag % vorticity % array
+ umeridional => diag % uReconstructMeridional % array
+ uzonal => diag % uReconstructZonal % array
+
+ if(.not.allocated(pressure) ) allocate(pressure(nVertLevels,nCells) )
+ if(.not.allocated(pressureCp1) ) allocate(pressureCp1(nVertLevels,nCells+1) )
+ if(.not.allocated(pressure2) ) allocate(pressure2(nVertLevelsP1,nCells) )
+ if(.not.allocated(pressure_v) ) allocate(pressure_v(nVertLevels,nVertices) )
+ if(.not.allocated(temperature) ) allocate(temperature(nVertLevels,nCells) )
+
+!calculation of total pressure at cell centers (at mass points):
+ do iCell = 1, nCells
+ do k = 1, nVertLevels
+ pressure(k,iCell) = (pressure_p(k,iCell) + pressure_b(k,iCell)) / 100._RKIND
+ pressureCp1(k,iCell) = pressure(k,iCell)
+ enddo
+ enddo
+ do iCell = nCells+1, nCells+1
+ do k = 1, nVertLevels
+ pressureCp1(k,iCell) = (pressure_p(k,iCell) + pressure_b(k,iCell)) / 100._RKIND
+ enddo
+ enddo
+
+!calculation of total pressure at cell centers (at vertical velocity points):
+ k = nVertLevelsP1
+ do iCell = 1, nCells
+ z0 = height(k,iCell)
+ z1 = 0.5*(height(k,iCell)+height(k-1,iCell))
+ z2 = 0.5*(height(k-1,iCell)+height(k-2,iCell))
+ w1 = (z0-z2)/(z1-z2)
+ w2 = 1.-w1
+ !use log of pressure to avoid occurrences of negative top-of-the-model pressure.
+ pressure2(k,iCell) = exp(w1*log(pressure(k-1,iCell))+w2*log(pressure(k-2,iCell)))
+ enddo
+ do k = 2, nVertLevels
+ do iCell = 1, nCells
+ w1 = (height(k,iCell)-height(k-1,iCell)) / (height(k+1,iCell)-height(k-1,iCell))
+ w2 = (height(k+1,iCell)-height(k,iCell)) / (height(k+1,iCell)-height(k-1,iCell))
+ pressure2(k,iCell) = w1*pressure(k,iCell) + w2*pressure(k-1,iCell)
+ enddo
+ enddo
+ k = 1
+ do iCell = 1, nCells
+ z0 = height(k,iCell)
+ z1 = 0.5*(height(k,iCell)+height(k+1,iCell))
+ z2 = 0.5*(height(k+1,iCell)+height(k+2,iCell))
+ w1 = (z0-z2)/(z1-z2)
+ w2 = 1.-w1
+ pressure2(k,iCell) = w1*pressure(k,iCell)+w2*pressure(k+1,iCell)
+ enddo
+
+!calculation of total pressure at cell vertices (at mass points):
+ do iVert = 1, nVertices
+ pressure_v(:,iVert) = 0._RKIND
+
+ do k = 1, nVertLevels
+ do iVertD = 1, vertexDegree
+ pressure_v(k,iVert) = pressure_v(k,iVert) &
+ + kiteAreasOnVertex(iVertD,iVert)*pressureCp1(k,cellsOnVertex(iVertD,iVert))
+ enddo
+ pressure_v(k,iVert) = pressure_v(k,iVert) / areaTriangle(iVert)
+ enddo
+ enddo
+
+!calculation of temperature at cell centers:
+ do iCell = 1,nCells
+ do k = 1,nVertLevels
+ temperature(k,iCell) = (theta_m(k,iCell)/(1._RKIND+rvord*qvapor(k,iCell)))*exner(k,iCell)
+ enddo
+ enddo
+
+!interpolation to fixed pressure levels for fields located at cells centers and at mass points:
+ nIntP = 3
+ if(.not.allocated(field_interp)) allocate(field_interp(nCells,nIntP) )
+ if(.not.allocated(press_interp)) allocate(press_interp(nCells,nIntP) )
+ do iCell = 1, nCells
+ press_interp(iCell,1) = 200.0_RKIND
+ press_interp(iCell,2) = 500.0_RKIND
+ press_interp(iCell,3) = 850.0_RKIND
+ enddo
+
+ if(.not.allocated(press_in)) allocate(press_in(nCells,nVertLevels))
+ do iCell = 1, nCells
+ do k = 1, nVertLevels
+ kk = nVertLevels+1-k
+ press_in(iCell,kk) = pressure(k,iCell)
+ enddo
+ enddo
+
+ if(.not.allocated(field_in)) allocate(field_in(nCells,nVertLevels))
+!... temperature:
+ do iCell = 1, nCells
+ do k = 1, nVertLevels
+ kk = nVertLevels+1-k
+ field_in(iCell,kk) = temperature(k,iCell)
+ enddo
+ enddo
+ call interp_tofixed_pressure(nCells,nVertLevels,nIntP,press_in,field_in,press_interp,field_interp)
+ diag % temperature_200hPa % array(1:nCells) = field_interp(1:nCells,1)
+ diag % temperature_500hPa % array(1:nCells) = field_interp(1:nCells,2)
+ diag % temperature_850hPa % array(1:nCells) = field_interp(1:nCells,3)
+ write(0,*) '--- end interpolate temperature:'
+
+!... u zonal wind:
+ do iCell = 1, nCells
+ do k = 1, nVertLevels
+ kk = nVertLevels+1-k
+ field_in(iCell,kk) = uzonal(k,iCell)
+ enddo
+ enddo
+ call interp_tofixed_pressure(nCells,nVertLevels,nIntP,press_in,field_in,press_interp,field_interp)
+ diag % uzonal_200hPa % array(1:nCells) = field_interp(1:nCells,1)
+ diag % uzonal_500hPa % array(1:nCells) = field_interp(1:nCells,2)
+ diag % uzonal_850hPa % array(1:nCells) = field_interp(1:nCells,3)
+ write(0,*) '--- end interpolate zonal wind:'
+
+!... u meridional wind:
+ do iCell = 1, nCells
+ do k = 1, nVertLevels
+ kk = nVertLevels+1-k
+ field_in(iCell,kk) = umeridional(k,iCell)
+ enddo
+ enddo
+ call interp_tofixed_pressure(nCells,nVertLevels,nIntP,press_in,field_in,press_interp,field_interp)
+ diag % umeridional_200hPa % array(1:nCells) = field_interp(1:nCells,1)
+ diag % umeridional_500hPa % array(1:nCells) = field_interp(1:nCells,2)
+ diag % umeridional_850hPa % array(1:nCells) = field_interp(1:nCells,3)
+ write(0,*) '--- end interpolate meridional wind:'
+
+ if(allocated(field_in)) deallocate(field_in)
+ if(allocated(press_in)) deallocate(press_in)
+
+!interpolation to fixed pressure levels for fields located at cells centers and at vertical
+!velocity points:
+ if(.not.allocated(press_in)) allocate(press_in(nCells,nVertLevelsP1))
+ do iCell = 1, nCells
+ do k = 1, nVertLevelsP1
+ kk = nVertLevelsP1+1-k
+ press_in(iCell,kk) = pressure2(k,iCell)
+ enddo
+ enddo
+
+ if(.not.allocated(field_in)) allocate(field_in(nCells,nVertLevelsP1))
+ !... height:
+ do iCell = 1, nCells
+ do k = 1, nVertLevelsP1
+ kk = nVertLevelsP1+1-k
+ field_in(iCell,kk) = height(k,iCell)
+ enddo
+ enddo
+ call interp_tofixed_pressure(nCells,nVertLevelsP1,nIntP,press_in,field_in,press_interp,field_interp)
+ diag % height_200hPa % array(1:nCells) = field_interp(1:nCells,1)
+ diag % height_500hPa % array(1:nCells) = field_interp(1:nCells,2)
+ diag % height_850hPa % array(1:nCells) = field_interp(1:nCells,3)
+ write(0,*) '--- end interpolate height:'
+
+!... vertical velocity
+ do iCell = 1, nCells
+ do k = 1, nVertLevelsP1
+ kk = nVertLevelsP1+1-k
+ field_in(iCell,kk) = vvel(k,iCell)
+ enddo
+ enddo
+ call interp_tofixed_pressure(nCells,nVertLevelsP1,nIntP,press_in,field_in,press_interp,field_interp)
+ diag % w_200hPa % array(1:nCells) = field_interp(1:nCells,1)
+ diag % w_500hPa % array(1:nCells) = field_interp(1:nCells,2)
+ diag % w_850hPa % array(1:nCells) = field_interp(1:nCells,3)
+ write(0,*) '--- end interpolate vertical velocity:'
+
+ if(allocated(field_interp)) deallocate(field_interp)
+ if(allocated(press_interp)) deallocate(press_interp)
+
+!interpolation to fixed pressure levels for fields located at cell vertices and at mass points:
+ nIntP = 3
+ if(.not.allocated(field_interp)) allocate(field_interp(nVertices,nIntP) )
+ if(.not.allocated(press_interp)) allocate(press_interp(nVertices,nIntP) )
+ do iVert = 1, nVertices
+ press_interp(iVert,1) = 200.0_RKIND
+ press_interp(iVert,2) = 500.0_RKIND
+ press_interp(iVert,3) = 850.0_RKIND
+ enddo
+
+ if(allocated(field_in)) deallocate(field_in)
+ if(allocated(press_in)) deallocate(press_in)
+
+ if(.not.allocated(press_in)) allocate(press_in(nVertices,nVertLevels))
+ do iVert = 1, nVertices
+ do k = 1, nVertLevels
+ kk = nVertLevels+1-k
+ press_in(iVert,kk) = pressure_v(k,iVert)
+ enddo
+ enddo
+
+ if(.not.allocated(field_in)) allocate(field_in(nVertices,nVertLevels))
+!... relative vorticity:
+ do iVert = 1, nVertices
+ do k = 1, nVertLevels
+ kk = nVertLevels+1-k
+ field_in(iVert,kk) = vorticity(k,iVert)
+ enddo
+ enddo
+ call interp_tofixed_pressure(nVertices,nVertLevels,nIntP,press_in,field_in,press_interp,field_interp)
+ diag % vorticity_200hPa % array(1:nVertices) = field_interp(1:nVertices,1)
+ diag % vorticity_500hPa % array(1:nVertices) = field_interp(1:nVertices,2)
+ diag % vorticity_850hPa % array(1:nVertices) = field_interp(1:nVertices,3)
+ write(0,*) '--- end interpolate relative vorticity:'
+
+ if(allocated(field_interp)) deallocate(field_interp)
+ if(allocated(press_interp)) deallocate(press_interp)
+ if(allocated(pressure) ) deallocate(pressure )
+ if(allocated(pressureCp1) ) deallocate(pressureCp1 )
+ if(allocated(pressure2) ) deallocate(pressure2 )
+ if(allocated(pressure_v) ) deallocate(pressure_v )
+ if(allocated(temperature) ) deallocate(temperature )
+
+!formats:
+! 201 format(i5,4(1x,e15.8))
+
+ end subroutine interp_diagnostics
+
+!==================================================================================================
+ subroutine interp_tofixed_pressure(ncol,nlev_in,nlev_out,pres_in,field_in,pres_out,field_out)
+!==================================================================================================
+
+!input arguments:
+ integer,intent(in):: ncol,nlev_in,nlev_out
+
+ real(kind=RKIND),intent(in),dimension(ncol,nlev_in) :: pres_in,field_in
+ real(kind=RKIND),intent(in),dimension(ncol,nlev_out):: pres_out
+
+!output arguments:
+ real(kind=RKIND),intent(out),dimension(ncol,nlev_out):: field_out
+
+!local variables:
+! integer:: i1,i2,icol,k,kk
+ integer:: icol,k,kk
+ integer:: kkstart,kount
+ integer,dimension(ncol):: kupper
+
+ real(kind=RKIND):: dpl,dpu
+
+!--------------------------------------------------------------------------------------------------
+
+!formats:
+! 201 format(i5,8(1x,e15.8))
+
+!write(0,*)
+!write(0,*) '--- enter subroutine interp_tofixed_pressure:'
+!write(0,*) '... ncol = ',ncol
+!write(0,*) '... nlev_in = ',nlev_in
+!write(0,*) '... nlev_out = ',nlev_out
+!i1=1 ; i2=ncol
+!do k = 1, nlev_in
+! write(0,201) k,pres_in(i1,k),field_in(i1,k),pres_in(i2,k),field_in(i2,k)
+!enddo
+!write(0,*)
+
+ do icol = 1, ncol
+ kupper(icol) = 1
+ enddo
+
+ do k = 1, nlev_out
+
+ kkstart = nlev_in
+ do icol = 1, ncol
+ kkstart = min0(kkstart,kupper(icol))
+ enddo
+ kount = 0
+
+ do kk = kkstart, nlev_in-1
+ do icol = 1, ncol
+ if(pres_out(icol,k).gt.pres_in(icol,kk).and.pres_out(icol,k).le.pres_in(icol,kk+1)) then
+ kupper(icol) = kk
+ kount = kount + 1
+! write(0,201) kupper(icol),pres_out(icol,k),pres_in(icol,kk),pres_in(icol,kk+1)
+ endif
+ enddo
+
+ if(kount.eq.ncol) then
+ do icol = 1, ncol
+ dpu = pres_out(icol,k) - pres_in(icol,kupper(icol))
+ dpl = pres_in(icol,kupper(icol)+1) - pres_out(icol,k)
+ field_out(icol,k) = (field_in(icol,kupper(icol))*dpl &
+ + field_in(icol,kupper(icol)+1)*dpu)/(dpl + dpu)
+ end do
+ goto 35
+ end if
+ enddo
+
+ do icol = 1, ncol
+ if(pres_out(icol,k) .lt. pres_in(icol,1)) then
+ field_out(icol,k) = field_in(icol,1)*pres_out(icol,k)/pres_in(icol,1)
+ elseif(pres_out(icol,k) .gt. pres_in(icol,nlev_in)) then
+ field_out(icol,k) = field_in(icol,nlev_in)
+ else
+ dpu = pres_out(icol,k) - pres_in(icol,kupper(icol))
+ dpl = pres_in(icol,kupper(icol)+1) - pres_out(icol,k)
+ field_out(icol,k) = (field_in(icol,kupper(icol))*dpl &
+ + field_in(icol,kupper(icol)+1)*dpu)/(dpl + dpu)
+ endif
+ enddo
+
+ 35 continue
+! write(0,201) kupper(i1),pres_out(i1,k),pres_in(i1,kupper(i1)),pres_in(i1,kupper(i1)+1), &
+! field_out(i1,k),field_in(i1,kupper(i1)),field_in(i1,kupper(i1)+1)
+! write(0,201) kupper(i2),pres_out(i2,k),pres_in(i2,kupper(i2)),pres_in(i2,kupper(i2)+1), &
+! field_out(i2,k),field_in(i2,kupper(i2)),field_in(i2,kupper(i2)+1)
+
+ enddo
+
+ end subroutine interp_tofixed_pressure
+
+!==================================================================================================
+ end module mpas_atm_interp_diagnostics
+!==================================================================================================
Modified: trunk/mpas/src/core_nhyd_atmos/mpas_atm_mpas_core.F
===================================================================
--- trunk/mpas/src/core_nhyd_atmos/mpas_atm_mpas_core.F 2013-03-27 19:24:59 UTC (rev 2673)
+++ trunk/mpas/src/core_nhyd_atmos/mpas_atm_mpas_core.F 2013-03-27 19:26:14 UTC (rev 2674)
@@ -29,16 +29,13 @@
real (kind=RKIND) :: dt
type (block_type), pointer :: block
- type (field1DChar) :: xtime
- type (MPAS_Time_type) :: startTime, sliceTime
- type (MPAS_TimeInterval_type) :: timeDiff, minTimeDiff
character(len=StrKIND) :: timeStamp
integer :: i
integer :: ierr
if (.not. config_do_restart) then
- ! Code that was previously handled by atm_setup_test_case()
+ ! Code that was previously in atm_setup_test_case()
block => domain % blocklist
do while (associated(block))
@@ -340,8 +337,6 @@
type (domain_type), intent(inout) :: domain
type (io_output_object), intent(inout) :: output_obj
- integer :: i, j, k
- integer :: eoe
type (block_type), pointer :: block_ptr
block_ptr => domain % blocklist
@@ -376,6 +371,8 @@
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
use mpas_grid_types
+ use mpas_constants
+ use mpas_atm_interp_diagnostics
implicit none
@@ -383,15 +380,16 @@
type (diag_type), intent(inout) :: diag
type (mesh_type), intent(in) :: grid
- integer :: i, eoe
integer :: iCell, k
do iCell=1,grid%nCells
do k=1,grid%nVertLevels
- diag % theta % array(k,iCell) = state % theta_m % array(k,iCell) / (1.0 + 1.61 * state % scalars % array(state % index_qv,k,iCell))
+ diag % theta % array(k,iCell) = state % theta_m % array(k,iCell) / (1._RKIND + rvord * state % scalars % array(state % index_qv,k,iCell))
diag % rho % array(k,iCell) = state % rho_zz % array(k,iCell) * grid % zz % array(k,iCell)
end do
end do
+
+ call interp_diagnostics(grid,state,diag)
end subroutine atm_compute_output_diagnostics
@@ -407,6 +405,7 @@
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
use mpas_grid_types
+ use mpas_constants
implicit none
@@ -414,12 +413,11 @@
type (diag_type), intent(inout) :: diag
type (mesh_type), intent(in) :: grid
- integer :: i, eoe
integer :: iCell, k
do iCell=1,grid%nCells
do k=1,grid%nVertLevels
- diag % theta % array(k,iCell) = state % theta_m % array(k,iCell) / (1.0 + 1.61 * state % scalars % array(state % index_qv,k,iCell))
+ diag % theta % array(k,iCell) = state % theta_m % array(k,iCell) / (1._RKIND + rvord * state % scalars % array(state % index_qv,k,iCell))
diag % rho % array(k,iCell) = state % rho_zz % array(k,iCell) * grid % zz % array(k,iCell)
end do
end do
Modified: trunk/mpas/src/core_nhyd_atmos/mpas_atm_time_integration.F
===================================================================
--- trunk/mpas/src/core_nhyd_atmos/mpas_atm_time_integration.F 2013-03-27 19:24:59 UTC (rev 2673)
+++ trunk/mpas/src/core_nhyd_atmos/mpas_atm_time_integration.F 2013-03-27 19:26:14 UTC (rev 2674)
@@ -95,9 +95,8 @@
! logical, parameter :: debug = .true.
logical, parameter :: debug_mass_conservation = .true.
- integer :: index_qc
- real (kind=RKIND) :: domain_mass, scalar_mass, scalar_min, scalar_max
- real (kind=RKIND) :: global_domain_mass, global_scalar_mass, global_scalar_min, global_scalar_max
+ real (kind=RKIND) :: scalar_min, scalar_max
+ real (kind=RKIND) :: global_scalar_min, global_scalar_max
!
@@ -169,7 +168,7 @@
if (debug) write(0,*) ' compute_dyn_tend '
block => domain % blocklist
do while (associated(block))
- call atm_compute_dyn_tend( block % tend, block % state % time_levs(2) % state, block % diag, block % mesh, rk_step )
+ call atm_compute_dyn_tend( block % tend, block % state % time_levs(2) % state, block % diag, block % mesh, rk_step, dt )
block => block % next
end do
if (debug) write(0,*) ' finished compute_dyn_tend '
@@ -185,7 +184,8 @@
block % tend, &
block % tend_physics, &
block % state % time_levs(2) % state % rho_zz % array(:,:), &
- block % diag % rho_edge % array(:,:) )
+ block % diag % rho_edge % array(:,:), &
+ rk_step )
block => block % next
end do
if (debug) write(0,*) ' finished add physics tendencies '
@@ -201,8 +201,8 @@
block => domain % blocklist
do while (associated(block))
- call atm_set_smlstep_pert_variables( block % state % time_levs(1) % state, block % state % time_levs(2) % state, &
- block % tend, block % diag, block % mesh )
+! call atm_set_smlstep_pert_variables( block % state % time_levs(1) % state, block % state % time_levs(2) % state, &
+ call atm_set_smlstep_pert_variables( block % tend, block % diag, block % mesh )
call atm_compute_vert_imp_coefs( block % state % time_levs(2) % state, block % mesh, block % diag, rk_sub_timestep(rk_step) )
block => block % next
end do
@@ -290,7 +290,7 @@
call atm_advance_scalars_mono( block % tend, &
block % state % time_levs(1) % state, block % state % time_levs(2) % state, &
block % diag, block % mesh, &
- rk_timestep(rk_step), rk_step, 3 )
+ rk_timestep(rk_step))
end if
block => block % next
end do
@@ -396,7 +396,7 @@
! if(debug) then
- 101 format(' local min, max scalar',i4,2(1x,e17.10))
+! 101 format(' local min, max scalar',i4,2(1x,e17.10))
102 format(' global min, max scalar',i4,2(1x,e17.10))
write(0,*)
block => domain % blocklist
@@ -456,7 +456,6 @@
implicit none
type (state_type) :: s_new, s_old
type (diag_type) :: diag
- integer :: iCell, k
diag % ru_save % array = diag % ru % array
diag % rw_save % array = diag % rw % array
@@ -639,10 +638,9 @@
!------------------------
- subroutine atm_set_smlstep_pert_variables( s_old, s_new, tend, diag, grid )
+ subroutine atm_set_smlstep_pert_variables( tend, diag, grid )
implicit none
- type (state_type) :: s_new, s_old
type (tend_type) :: tend
type (diag_type) :: diag
type (mesh_type) :: grid
@@ -728,7 +726,7 @@
real (kind=RKIND), dimension( grid % nVertLevels, grid % nCells+1 ) :: ts, rs
integer :: cell1, cell2, iEdge, iCell, k
- real (kind=RKIND) :: pgrad, flux1, flux2, flux, resm, epssm
+ real (kind=RKIND) :: pgrad, flux, resm, epssm
real (kind=RKIND) :: cf1, cf2, cf3, pr, pl
integer :: kr, kl
@@ -738,8 +736,6 @@
logical, parameter :: debug = .false.
! logical, parameter :: debug = .true.
logical, parameter :: debug1 = .false.
- real (kind=RKIND) :: wmax
- integer :: iwmax, kwmax
logical :: newpx
!--
@@ -971,7 +967,7 @@
end do
do k=nVertLevels,1,-1
- rw_p(k,iCell) = rw_p(k,iCell) - gamma_tri(k,iCell)*rw_p(k+1,iCell)
+ rw_p(k,iCell) = rw_p(k,iCell) - gamma_tri(k,iCell)*rw_p(k+1,iCell)
end do
do k=2,nVertLevels
@@ -1199,8 +1195,7 @@
real (kind=RKIND) :: dt
integer :: i, iCell, iEdge, k, iScalar, cell1, cell2
- real (kind=RKIND) :: flux, scalar_edge, d2fdx2_cell1, d2fdx2_cell2, scalar_weight
- real (kind=RKIND) :: scalar_weight_cell1, scalar_weight_cell2
+ real (kind=RKIND) :: scalar_weight
real (kind=RKIND), dimension(:,:,:), pointer :: scalar_old, scalar_new, scalar_tend
real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
@@ -1213,15 +1208,13 @@
real (kind=RKIND), dimension(:,:), pointer :: adv_coefs, adv_coefs_3rd
real (kind=RKIND), dimension( s_old % num_scalars, grid % nVertLevels ) :: flux_arr
- real (kind=RKIND), dimension( s_old % num_scalars, grid % nVertLevels ) :: d2fdx2_cell1_arr, d2fdx2_cell2_arr
-
real (kind=RKIND), dimension( s_old % num_scalars, grid % nVertLevels + 1 ) :: wdtn
integer :: nVertLevels
real (kind=RKIND), dimension(:), pointer :: fnm, fnp, rdnw, meshScalingDel2, meshScalingDel4
real (kind=RKIND) :: coef_3rd_order
- real (kind=RKIND) :: h_theta_eddy_visc2, v_theta_eddy_visc2, scalar_turb_flux, z1,z2,z3,z4,zm,z0,zp
+ real (kind=RKIND) :: h_theta_eddy_visc2, v_theta_eddy_visc2
real (kind=RKIND) :: flux3, flux4
real (kind=RKIND) :: q_im2, q_im1, q_i, q_ip1, ua, coef3
@@ -1402,7 +1395,7 @@
!---------------------------
- subroutine atm_advance_scalars_mono(tend, s_old, s_new, diag, grid, dt, rk_step, rk_order)
+ subroutine atm_advance_scalars_mono(tend, s_old, s_new, diag, grid, dt)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! Input: s - current model state
@@ -1416,12 +1409,10 @@
type (diag_type),intent(in) :: diag
type (mesh_type),intent(in) :: grid
real (kind=RKIND),intent(in) :: dt
- integer, intent(in) :: rk_step, rk_order
type (block_type), pointer :: block
integer :: i, iCell, iEdge, k, iScalar, cell1, cell2
- real (kind=RKIND) :: flux, scalar_edge, d2fdx2_cell1, d2fdx2_cell2, scalar_weight
- real (kind=RKIND) :: scalar_weight_cell1, scalar_weight_cell2
+ real (kind=RKIND) :: flux, scalar_weight
real (kind=RKIND), dimension(:,:,:), pointer :: scalar_tend
real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
@@ -1433,22 +1424,24 @@
integer, dimension(:), pointer :: nAdvCellsForEdge
real (kind=RKIND), dimension(:,:), pointer :: adv_coefs, adv_coefs_3rd
- type (field2DReal), pointer :: tempField
- type (field2DReal), target :: tempFieldTarget
+ type (field3DReal), pointer :: tempField
+ type (field3DReal), target :: tempFieldTarget
real (kind=RKIND), dimension( grid % nVertLevels, grid % nCells ) :: scalar_old, scalar_new
- real (kind=RKIND), dimension( grid % nVertLevels, grid % nCells ) :: s_max, s_min, s_update
- real (kind=RKIND), dimension( grid % nVertLevels, grid % nCells ), target :: scale_in, scale_out
+ real (kind=RKIND), dimension( grid % nVertLevels, grid % nCells ) :: s_max, s_min
+ real (kind=RKIND), dimension( 2, grid % nVertLevels, grid % nCells ), target :: scale_arr
+ integer, parameter :: SCALE_IN = 1, SCALE_OUT = 2
+
real (kind=RKIND), dimension( grid % nVertLevels, grid % nEdges ) :: flux_arr
real (kind=RKIND), dimension( grid % nVertLevels + 1, grid % nCells ) :: wdtn
- integer :: nVertLevels, isc, num_scalars, icellmax, kmax
+ integer :: nVertLevels, num_scalars, icellmax, kmax
real (kind=RKIND), dimension(:), pointer :: fnm, fnp, rdnw, meshScalingDel2, meshScalingDel4
real (kind=RKIND) :: coef_3rd_order
- real (kind=RKIND) :: h_theta_eddy_visc2, v_theta_eddy_visc2, scalar_turb_flux, z1,z2,z3,z4,zm,z0,zp
+ real (kind=RKIND) :: h_theta_eddy_visc2, v_theta_eddy_visc2
real (kind=RKIND) :: flux3, flux4, flux_upwind
real (kind=RKIND) :: q_im2, q_im1, q_i, q_ip1, ua, coef3, scmin,scmax
@@ -1541,25 +1534,27 @@
end do
end do
- scmin = scalar_old(1,1)
- scmax = scalar_old(1,1)
- do iCell = 1, grid%nCells
- do k=1, grid%nVertLevels
- scmin = min(scmin,scalar_old(k,iCell))
- scmax = max(scmax,scalar_old(k,iCell))
- enddo
- enddo
- write(0,*) ' scmin, scmin old in ',scmin,scmax
+ if(debug_print) then
+ scmin = scalar_old(1,1)
+ scmax = scalar_old(1,1)
+ do iCell = 1, grid%nCells
+ do k=1, grid%nVertLevels
+ scmin = min(scmin,scalar_old(k,iCell))
+ scmax = max(scmax,scalar_old(k,iCell))
+ enddo
+ enddo
+ write(0,*) ' scmin, scmin old in ',scmin,scmax
- scmin = scalar_new(1,1)
- scmax = scalar_new(1,1)
- do iCell = 1, grid%nCells
- do k=1, grid%nVertLevels
- scmin = min(scmin,scalar_new(k,iCell))
- scmax = max(scmax,scalar_new(k,iCell))
- enddo
- enddo
- write(0,*) ' scmin, scmin new in ',scmin,scmax
+ scmin = scalar_new(1,1)
+ scmax = scalar_new(1,1)
+ do iCell = 1, grid%nCells
+ do k=1, grid%nVertLevels
+ scmin = min(scmin,scalar_new(k,iCell))
+ scmax = max(scmax,scalar_new(k,iCell))
+ enddo
+ enddo
+ write(0,*) ' scmin, scmin new in ',scmin,scmax
+ end if
!
@@ -1644,12 +1639,12 @@
wdtn(k,iCell) = dt*wdtn(k,iCell) - flux_upwind
end do
-! scale_in(:,:) and scale_out(:,:) are used here to store the incoming and outgoing perturbation flux
+! scale_arr(SCALE_IN,:,:) and scale_arr(SCALE_OUT:,:) are used here to store the incoming and outgoing perturbation flux
! contributions to the update: first the vertical flux component, then the horizontal
do k=1,nVertLevels
- scale_in (k,iCell) = - rdnw(k)*(min(0.0_RKIND,wdtn(k+1,iCell))-max(0.0_RKIND,wdtn(k,iCell)))
- scale_out(k,iCell) = - rdnw(k)*(max(0.0_RKIND,wdtn(k+1,iCell))-min(0.0_RKIND,wdtn(k,iCell)))
+ scale_arr(SCALE_IN, k,iCell) = - rdnw(k)*(min(0.0_RKIND,wdtn(k+1,iCell))-max(0.0_RKIND,wdtn(k,iCell)))
+ scale_arr(SCALE_OUT,k,iCell) = - rdnw(k)*(max(0.0_RKIND,wdtn(k+1,iCell))-min(0.0_RKIND,wdtn(k,iCell)))
end do
end do
@@ -1669,10 +1664,10 @@
scalar_new(k,cell1) = scalar_new(k,cell1) - flux_upwind / areaCell(cell1)
scalar_new(k,cell2) = scalar_new(k,cell2) + flux_upwind / areaCell(cell2)
- scale_out(k,cell1) = scale_out(k,cell1) - max(0.0_RKIND,flux_arr(k,iEdge)) / areaCell(cell1)
- scale_in (k,cell1) = scale_in (k,cell1) - min(0.0_RKIND,flux_arr(k,iEdge)) / areaCell(cell1)
- scale_out(k,cell2) = scale_out(k,cell2) + min(0.0_RKIND,flux_arr(k,iEdge)) / areaCell(cell2)
- scale_in (k,cell2) = scale_in (k,cell2) + max(0.0_RKIND,flux_arr(k,iEdge)) / areaCell(cell2)
+ scale_arr(SCALE_OUT,k,cell1) = scale_arr(SCALE_OUT,k,cell1) - max(0.0_RKIND,flux_arr(k,iEdge)) / areaCell(cell1)
+ scale_arr(SCALE_IN, k,cell1) = scale_arr(SCALE_IN, k,cell1) - min(0.0_RKIND,flux_arr(k,iEdge)) / areaCell(cell1)
+ scale_arr(SCALE_OUT,k,cell2) = scale_arr(SCALE_OUT,k,cell2) + min(0.0_RKIND,flux_arr(k,iEdge)) / areaCell(cell2)
+ scale_arr(SCALE_IN, k,cell2) = scale_arr(SCALE_IN, k,cell2) + max(0.0_RKIND,flux_arr(k,iEdge)) / areaCell(cell2)
end do
end if
@@ -1682,15 +1677,15 @@
do iCell = 1, grid % nCellsSolve
do k = 1, nVertLevels
- s_min_update = (scalar_new(k,iCell)+scale_out(k,iCell))/h_new(k,iCell)
- s_max_update = (scalar_new(k,iCell)+scale_in (k,iCell))/h_new(k,iCell)
+ s_min_update = (scalar_new(k,iCell)+scale_arr(SCALE_OUT,k,iCell))/h_new(k,iCell)
+ s_max_update = (scalar_new(k,iCell)+scale_arr(SCALE_IN,k,iCell))/h_new(k,iCell)
s_upwind = scalar_new(k,iCell)/h_new(k,iCell)
scale_factor = (s_max(k,iCell)-s_upwind)/(s_max_update-s_upwind+eps)
- scale_in(k,iCell) = min( 1.0_RKIND, max( 0.0_RKIND, scale_factor) )
+ scale_arr(SCALE_IN,k,iCell) = min( 1.0_RKIND, max( 0.0_RKIND, scale_factor) )
scale_factor = (s_upwind-s_min(k,iCell))/(s_upwind-s_min_update+eps)
- scale_out(k,iCell) = min( 1.0_RKIND, max( 0.0_RKIND, scale_factor) )
+ scale_arr(SCALE_OUT,k,iCell) = min( 1.0_RKIND, max( 0.0_RKIND, scale_factor) )
end do
end do
@@ -1703,20 +1698,18 @@
tempField => tempFieldTarget
tempField % block => block
- tempField % dimSizes(1) = grid % nVertLevels
- tempField % dimSizes(2) = grid % nCells
+ tempField % dimSizes(1) = 2
+ tempField % dimSizes(2) = grid % nVertLevels
+ tempField % dimSizes(3) = grid % nCells
tempField % sendList => block % parinfo % cellsToSend
tempField % recvList => block % parinfo % cellsToRecv
tempField % copyList => block % parinfo % cellsToCopy
tempField % prev => null()
tempField % next => null()
- tempField % array => scale_in
+ tempField % array => scale_arr
call mpas_dmpar_exch_halo_field(tempField, (/ 1 /))
- tempField % array => scale_out
- call mpas_dmpar_exch_halo_field(tempField, (/ 1 /))
-
!
! rescale the fluxes
!
@@ -1726,8 +1719,8 @@
if (cell1 <= grid%nCellsSolve .or. cell2 <= grid%nCellsSolve) then
do k = 1, nVertLevels
flux = flux_arr(k,iEdge)
- flux = max(0.0_RKIND,flux) * min(scale_out(k,cell1), scale_in(k,cell2)) &
- + min(0.0_RKIND,flux) * min(scale_in(k,cell1), scale_out(k,cell2))
+ flux = max(0.0_RKIND,flux) * min(scale_arr(SCALE_OUT,k,cell1), scale_arr(SCALE_IN, k,cell2)) &
+ + min(0.0_RKIND,flux) * min(scale_arr(SCALE_IN, k,cell1), scale_arr(SCALE_OUT,k,cell2))
flux_arr(k,iEdge) = flux
end do
end if
@@ -1738,8 +1731,8 @@
do iCell=1,grid % nCells
do k = 2, nVertLevels
flux = wdtn(k,iCell)
- flux = max(0.0_RKIND,flux) * min(scale_out(k-1,iCell), scale_in(k ,iCell)) &
- + min(0.0_RKIND,flux) * min(scale_out(k ,iCell), scale_in(k-1,iCell))
+ flux = max(0.0_RKIND,flux) * min(scale_arr(SCALE_OUT,k-1,iCell), scale_arr(SCALE_IN,k ,iCell)) &
+ + min(0.0_RKIND,flux) * min(scale_arr(SCALE_OUT,k ,iCell), scale_arr(SCALE_IN,k-1,iCell))
wdtn(k,iCell) = flux
end do
end do
@@ -1757,39 +1750,39 @@
end if
end do
- do iCell=1,grid % nCellsSolve
- do k=1,grid % nVertLevels
- scalar_new(k,iCell) = ( scalar_new(k,iCell) &
- + (-rdnw(k)*(wdtn(k+1,iCell)-wdtn(k,iCell)) ) )/h_new(k,iCell)
- end do
- end do
+ do iCell=1,grid % nCellsSolve
+ do k=1,grid % nVertLevels
+ scalar_new(k,iCell) = ( scalar_new(k,iCell) &
+ + (-rdnw(k)*(wdtn(k+1,iCell)-wdtn(k,iCell)) ) )/h_new(k,iCell)
+ end do
+ end do
- if(debug_print) then
+ if(debug_print) then
- scmin = scalar_new(1,1)
- scmax = scalar_new(1,1)
- do iCell = 1, grid%nCellsSolve
- do k=1, grid%nVertLevels
- scmax = max(scmax,scalar_new(k,iCell))
- scmin = min(scmin,scalar_new(k,iCell))
- if(s_max(k,iCell) < scalar_new(k,iCell)) then
- write(32,*) ' over - k,iCell,s_min,s_max,scalar_new ',k,iCell,s_min(k,iCell),s_max(k,iCell),scalar_new(k,iCell)
- end if
- if(s_min(k,iCell) > scalar_new(k,iCell)) then
- write(32,*) ' under - k,iCell,s_min,s_max,scalar_new ',k,iCell,s_min(k,iCell),s_max(k,iCell),scalar_new(k,iCell)
- end if
- enddo
- enddo
- write(0,*) ' scmin, scmax new out ',scmin,scmax
- write(0,*) ' icell_min, k_min ',icellmax, kmax
+ scmin = scalar_new(1,1)
+ scmax = scalar_new(1,1)
+ do iCell = 1, grid%nCellsSolve
+ do k=1, grid%nVertLevels
+ scmax = max(scmax,scalar_new(k,iCell))
+ scmin = min(scmin,scalar_new(k,iCell))
+ if(s_max(k,iCell) < scalar_new(k,iCell)) then
+ write(32,*) ' over - k,iCell,s_min,s_max,scalar_new ',k,iCell,s_min(k,iCell),s_max(k,iCell),scalar_new(k,iCell)
+ end if
+ if(s_min(k,iCell) > scalar_new(k,iCell)) then
+ write(32,*) ' under - k,iCell,s_min,s_max,scalar_new ',k,iCell,s_min(k,iCell),s_max(k,iCell),scalar_new(k,iCell)
+ end if
+ enddo
+ enddo
+ write(0,*) ' scmin, scmax new out ',scmin,scmax
+ write(0,*) ' icell_min, k_min ',icellmax, kmax
- end if
+ end if
- do iCell = 1, grid%nCells
- do k=1, grid%nVertLevels
- s_new % scalars % array(iScalar,k,iCell) = max(0.0_RKIND,scalar_new(k,iCell))
- end do
- end do
+ do iCell = 1, grid%nCells
+ do k=1, grid%nVertLevels
+ s_new % scalars % array(iScalar,k,iCell) = max(0.0_RKIND,scalar_new(k,iCell))
+ end do
+ end do
end do ! loop over scalars
@@ -1797,7 +1790,7 @@
!----
- subroutine atm_compute_dyn_tend(tend, s, diag, grid, rk_step)
+ subroutine atm_compute_dyn_tend(tend, s, diag, grid, rk_step, dt)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Compute height and normal wind tendencies, as well as diagnostic variables
!
@@ -1816,18 +1809,19 @@
type (diag_type), intent(in) :: diag
type (mesh_type), intent(in) :: grid
integer, intent(in) :: rk_step
+ real (kind=RKIND), intent(in) :: dt
logical, parameter :: rk_diffusion = .false.
integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j, iq
- real (kind=RKIND) :: flux, vorticity_abs, rho_vertex, workpv, upstream_bias
+ real (kind=RKIND) :: flux, workpv
integer :: nCells, nEdges, nVertices, nVertLevels, nCellsSolve
real (kind=RKIND) :: h_mom_eddy_visc2, v_mom_eddy_visc2, h_mom_eddy_visc4
real (kind=RKIND) :: h_theta_eddy_visc2, v_theta_eddy_visc2, h_theta_eddy_visc4
real (kind=RKIND) :: u_diffusion
- real (kind=RKIND), dimension(:), pointer :: fVertex, fEdge, dvEdge, dcEdge, areaCell, areaTriangle, meshScalingDel2, meshScalingDel4
- real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge, kiteAreasOnVertex, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, &
+ real (kind=RKIND), dimension(:), pointer :: fEdge, dvEdge, dcEdge, areaCell, areaTriangle, meshScalingDel2, meshScalingDel4
+ real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, &
circulation, divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, &
rt_diabatic_tend, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zx, cqu, &
h_divergence, kdiff
@@ -1835,13 +1829,13 @@
real (kind=RKIND), dimension(:,:), pointer :: tend_u_euler, tend_w_euler, tend_theta_euler
real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
- integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnVertex, verticesOnEdge, edgesOnCell, edgesOnEdge, edgesOnVertex
+ integer, dimension(:,:), pointer :: cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnEdge
integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge
real (kind=RKIND), dimension( grid % nVertLevels + 1 ) :: wduz, wdwz, wdtz, dpzx
real (kind=RKIND), dimension( grid % nVertLevels ) :: u_mix, ru_edge_w, q
- real (kind=RKIND) :: theta_edge, theta_turb_flux, z1, z2, z3, z4, zm, z0, zp, r
- real (kind=RKIND) :: d2fdx2_cell1, d2fdx2_cell2, pgrad
+ real (kind=RKIND) :: theta_turb_flux, z1, z2, z3, z4, zm, z0, zp, r
+ real (kind=RKIND) :: d2fdx2_cell1, d2fdx2_cell2
integer, dimension(:,:), pointer :: advCellsForEdge
integer, dimension(:), pointer :: nAdvCellsForEdge
@@ -1854,11 +1848,12 @@
real (kind=RKIND), dimension(:,:), pointer :: cpr, cpl, pzp, pzm
integer :: kr, kl
- real (kind=RKIND), allocatable, dimension(:,:) :: rv, divergence_ru, qtot
+ real (kind=RKIND), allocatable, dimension(:,:) :: divergence_ru, qtot
real (kind=RKIND), allocatable, dimension(:,:) :: delsq_theta, delsq_divergence
real (kind=RKIND), allocatable, dimension(:,:) :: delsq_u
real (kind=RKIND), allocatable, dimension(:,:) :: delsq_circulation, delsq_vorticity
real (kind=RKIND) :: cf1, cf2, cf3, pr, pl
+ real (kind=RKIND) :: prandtl_inv
! logical, parameter :: debug = .true.
logical, parameter :: debug = .false.
@@ -1974,10 +1969,10 @@
nCellsSolve = grid % nCellsSolve
h_mom_eddy_visc2 = config_h_mom_eddy_visc2
- h_mom_eddy_visc4 = config_h_mom_eddy_visc4
+! h_mom_eddy_visc4 = config_h_mom_eddy_visc4
v_mom_eddy_visc2 = config_v_mom_eddy_visc2
h_theta_eddy_visc2 = config_h_theta_eddy_visc2
- h_theta_eddy_visc4 = config_h_theta_eddy_visc4
+! h_theta_eddy_visc4 = config_h_theta_eddy_visc4
v_theta_eddy_visc2 = config_v_theta_eddy_visc2
nAdvCellsForEdge => grid % nAdvCellsForEdge % array
@@ -1985,6 +1980,8 @@
adv_coefs => grid % adv_coefs % array
adv_coefs_3rd => grid % adv_coefs_3rd % array
+ prandtl_inv = 1.0_RKIND/prandtl
+
!
! Compute u (normal) velocity tendency for each edge (cell face)
!
@@ -2007,11 +2004,21 @@
end do
do k=1, nVertLevels
kdiff(k,iCell) = (c_s * config_len_disp)**2 * sqrt(d_diag(k)**2 + d_off_diag(k)**2)
+ kdiff(k,iCell) = min(kdiff(k,iCell),(0.01*config_len_disp**2)/dt)
end do
end do
+!ldf (2012-10-10):
+ h_mom_eddy_visc4 = config_visc4_2dsmag * config_len_disp**3
+ h_theta_eddy_visc4 = h_mom_eddy_visc4
delsq_horiz_mixing = .true.
+ write(0,*) '... config_visc4_2dsmag = ', config_visc4_2dsmag
+ write(0,*) '... h_mom_eddy_visc4 = ', h_mom_eddy_visc4
+ write(0,*) '... h_theta_eddy_visc4 = ', h_theta_eddy_visc4
else if ( config_horiz_mixing == "2d_fixed") then
+ h_mom_eddy_visc4 = config_h_mom_eddy_visc4
+ h_theta_eddy_visc4 = config_h_theta_eddy_visc4
delsq_horiz_mixing = .true.
+!ldf (2012-10-10):
end if
tend_u(:,:) = 0.0
@@ -2179,7 +2186,7 @@
if (delsq_horiz_mixing) then
- if (h_mom_eddy_visc2 > 0.0) then
+ if ((h_mom_eddy_visc2 > 0.0) .and. (config_horiz_mixing == "2d_fixed")) then
do iEdge=1,grid % nEdgesSolve
cell1 = cellsOnEdge(1,iEdge)
cell2 = cellsOnEdge(2,iEdge)
@@ -2193,7 +2200,7 @@
! only valid for h_mom_eddy_visc2 == constant
!
u_diffusion = ( divergence(k,cell2) - divergence(k,cell1) ) / dcEdge(iEdge) &
- -( vorticity(k,vertex2) - vorticity(k,vertex1) ) / dvEdge(iEdge)
+ -( vorticity(k,vertex2) - vorticity(k,vertex1) ) / max(dvEdge(iEdge),0.25*dcEdge(iEdge))
u_diffusion = rho_edge(k,iEdge)*h_mom_eddy_visc2 * u_diffusion
u_diffusion = u_diffusion * meshScalingDel2(iEdge)
@@ -2216,7 +2223,7 @@
! only valid for h_mom_eddy_visc2 == constant
!
u_diffusion = ( divergence(k,cell2) - divergence(k,cell1) ) / dcEdge(iEdge) &
- -( vorticity(k,vertex2) - vorticity(k,vertex1) ) / dvEdge(iEdge)
+ -( vorticity(k,vertex2) - vorticity(k,vertex1) ) / max(dvEdge(iEdge),0.25*dcEdge(iEdge))
u_diffusion = rho_edge(k,iEdge)* 0.5*(kdiff(k,cell1)+kdiff(k,cell2)) * u_diffusion
u_diffusion = u_diffusion * meshScalingDel2(iEdge)
@@ -2228,7 +2235,10 @@
end if ! delsq_horiz_mixing for u
- if ( h_mom_eddy_visc4 > 0.0 ) then
+!ldf (2012-10-10): Modified loop below to allow hyper-diffusion when 2d_smagorinsky is set to true.
+! if ((h_mom_eddy_visc4 > 0.0) .and. (config_horiz_mixing == "2d_fixed")) then
+ if ((h_mom_eddy_visc4 > 0.0 .and. config_horiz_mixing == "2d_fixed") .or. &
+ (h_mom_eddy_visc4 > 0.0 .and. config_horiz_mixing == "2d_smagorinsky")) then
allocate(delsq_divergence(nVertLevels, nCells+1))
allocate(delsq_u(nVertLevels, nEdges+1))
@@ -2545,7 +2555,7 @@
if (delsq_horiz_mixing) then
- if (h_mom_eddy_visc2 > 0.0) then
+ if ((h_mom_eddy_visc2 > 0.0) .and. (config_horiz_mixing == "2d_fixed")) then
do iEdge=1,grid % nEdges
cell1 = grid % cellsOnEdge % array(1,iEdge)
@@ -2589,7 +2599,10 @@
end if
- if ( h_mom_eddy_visc4 > 0.0 ) then
+!ldf (2010-10-10):
+! if ( (h_mom_eddy_visc4 > 0.0) .and. (config_horiz_mixing == "2d_fixed")) then
+ if ((h_mom_eddy_visc4 > 0.0 .and. config_horiz_mixing == "2d_fixed") .or. &
+ (h_mom_eddy_visc4 > 0.0 .and. config_horiz_mixing == "2d_smagorinsky")) then
allocate(delsq_theta(nVertLevels, nCells+1))
@@ -2840,7 +2853,7 @@
tend_theta_euler = 0.
if (delsq_horiz_mixing) then
- if ( h_theta_eddy_visc2 > 0.0 ) then
+ if ( (h_theta_eddy_visc2 > 0.0) .and. (config_horiz_mixing == "2d_fixed") ) then
do iEdge=1,grid % nEdges
cell1 = grid % cellsOnEdge % array(1,iEdge)
@@ -2848,7 +2861,7 @@
if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
do k=1,grid % nVertLevels
- theta_turb_flux = h_theta_eddy_visc2*prandtl*(theta_m(k,cell2) - theta_m(k,cell1))/dcEdge(iEdge)
+ theta_turb_flux = h_theta_eddy_visc2*prandtl_inv*(theta_m(k,cell2) - theta_m(k,cell1))/dcEdge(iEdge)
theta_turb_flux = theta_turb_flux * meshScalingDel2(iEdge)
flux = dvEdge (iEdge) * rho_edge(k,iEdge) * theta_turb_flux
! tend_theta(k,cell1) = tend_theta(k,cell1) + flux
@@ -2868,7 +2881,7 @@
if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
do k=1,grid % nVertLevels
- theta_turb_flux = 0.5*(kdiff(k,cell1)+kdiff(k,cell2))*prandtl &
+ theta_turb_flux = 0.5*(kdiff(k,cell1)+kdiff(k,cell2))*prandtl_inv &
*(theta_m(k,cell2) - theta_m(k,cell1))/dcEdge(iEdge)
theta_turb_flux = theta_turb_flux * meshScalingDel2(iEdge)
flux = dvEdge (iEdge) * rho_edge(k,iEdge) * theta_turb_flux
@@ -2884,7 +2897,10 @@
end if
- if ( h_theta_eddy_visc4 > 0.0 ) then
+!ldf (2010-10-10):
+! if ( (h_theta_eddy_visc4 > 0.0) .and. (config_horiz_mixing == "2d_fixed") ) then
+ if ((h_theta_eddy_visc4 > 0.0 .and. config_horiz_mixing == "2d_fixed") .or. &
+ (h_theta_eddy_visc4 > 0.0 .and. config_horiz_mixing == "2d_smagorinsky")) then
allocate(delsq_theta(nVertLevels, nCells+1))
@@ -2912,7 +2928,7 @@
if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
do k=1,grid % nVertLevels
- theta_turb_flux = h_theta_eddy_visc4*prandtl*(delsq_theta(k,cell2) - delsq_theta(k,cell1))/dcEdge(iEdge)
+ theta_turb_flux = h_theta_eddy_visc4*prandtl_inv*(delsq_theta(k,cell2) - delsq_theta(k,cell1))/dcEdge(iEdge)
theta_turb_flux = theta_turb_flux * meshScalingDel4(iEdge)
flux = dvEdge (iEdge) * theta_turb_flux
@@ -2996,10 +3012,10 @@
z0 = 0.5*(z2+z3)
zp = 0.5*(z3+z4)
-! tend_theta(k,iCell) = tend_theta(k,iCell) + v_theta_eddy_visc2*prandtl*rho_zz(k,iCell)*(&
+! tend_theta(k,iCell) = tend_theta(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(&
! (theta_m(k+1,iCell)-theta_m(k ,iCell))/(zp-z0) &
! -(theta_m(k ,iCell)-theta_m(k-1,iCell))/(z0-zm) )/(0.5*(zp-zm))
- tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl*rho_zz(k,iCell)*(&
+ tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(&
(theta_m(k+1,iCell)-theta_m(k ,iCell))/(zp-z0) &
-(theta_m(k ,iCell)-theta_m(k-1,iCell))/(z0-zm) )/(0.5*(zp-zm))
end do
@@ -3018,10 +3034,10 @@
z0 = 0.5*(z2+z3)
zp = 0.5*(z3+z4)
-! tend_theta(k,iCell) = tend_theta(k,iCell) + v_theta_eddy_visc2*prandtl*rho_zz(k,iCell)*(&
+! tend_theta(k,iCell) = tend_theta(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(&
! ((theta_m(k+1,iCell)-t_init(k+1,iCell))-(theta_m(k ,iCell)-t_init(k,iCell)))/(zp-z0) &
! -((theta_m(k ,iCell)-t_init(k,iCell))-(theta_m(k-1,iCell)-t_init(k-1,iCell)))/(z0-zm) )/(0.5*(zp-zm))
- tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl*rho_zz(k,iCell)*(&
+ tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(&
((theta_m(k+1,iCell)-t_init(k+1,iCell))-(theta_m(k ,iCell)-t_init(k,iCell)))/(zp-z0) &
-((theta_m(k ,iCell)-t_init(k,iCell))-(theta_m(k-1,iCell)-t_init(k-1,iCell)))/(z0-zm) )/(0.5*(zp-zm))
end do
@@ -3060,12 +3076,12 @@
type (mesh_type), intent(in) :: grid
- integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j, cov
- real (kind=RKIND) :: flux, vorticity_abs, h_vertex, workpv, r
+ integer :: iEdge, iCell, iVertex, k, cell1, cell2, eoe, i
+ real (kind=RKIND) :: h_vertex, r
integer :: nCells, nEdges, nVertices, nVertLevels
real (kind=RKIND), dimension(:), pointer :: fVertex, fEdge, dvEdge, dcEdge, areaCell, areaTriangle
- real (kind=RKIND), dimension(:,:), pointer :: vh, weightsOnEdge, kiteAreasOnVertex, h_edge, h, u, v, tend_h, tend_u, &
+ real (kind=RKIND), dimension(:,:), pointer :: vh, weightsOnEdge, kiteAreasOnVertex, h_edge, h, u, v, &
circulation, vorticity, ke, pv_edge, pv_vertex, pv_cell, gradPVn, gradPVt, &
divergence
integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnVertex, verticesOnEdge, edgesOnCell, edgesOnEdge, edgesOnVertex
@@ -3340,7 +3356,7 @@
type (mesh_type), intent(inout) :: grid
!SHP-w
- integer :: k,iCell,iEdge,i,iCell1,iCell2, cell1, cell2, coef_3rd_order
+ integer :: k,iCell,iEdge,iCell1,iCell2, cell1, cell2, coef_3rd_order
real (kind=RKIND) :: p0, rcv, flux
!SHP-w
@@ -3352,7 +3368,7 @@
do iCell=1,grid%nCells
do k=1,grid%nVertLevels
- state % theta_m % array(k,iCell) = diag % theta % array(k,iCell) * (1.0 + 1.61 * state % scalars % array(state % index_qv,k,iCell))
+ state % theta_m % array(k,iCell) = diag % theta % array(k,iCell) * (1._RKIND + rvord * state % scalars % array(state % index_qv,k,iCell))
state % rho_zz % array(k,iCell) = diag % rho % array(k,iCell) / grid % zz % array(k,iCell)
end do
end do
</font>
</pre>