<p><b>dwj07@fsu.edu</b> 2013-03-29 08:40:23 -0600 (Fri, 29 Mar 2013)</p><p><br>
-- BRANCH COMMIT --<br>
<br>
Merging trunk into openmp elements branch.<br>
Validates on a single processor (no OpenMP).<br>
</p><hr noshade><pre><font color="gray">Index: branches/ocean_projects/openmp_elements
===================================================================
--- branches/ocean_projects/openmp_elements 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements 2013-03-29 14:40:23 UTC (rev 2678)
Property changes on: branches/ocean_projects/openmp_elements
___________________________________________________________________
Modified: svn:mergeinfo
## -4,16 +4,22 ##
/branches/ocean_projects/ale_vert_coord:1225-1383
/branches/ocean_projects/ale_vert_coord_new:1387-1428
/branches/ocean_projects/cesm_coupling:2147-2344
+/branches/ocean_projects/comment_cleanup:2626-2630
+/branches/ocean_projects/diagnostics_revision:2439-2462
+/branches/ocean_projects/explicit_vmix_removal:2486-2490
/branches/ocean_projects/gmvar:1214-1514,1517-1738
/branches/ocean_projects/imp_vert_mix_error:1847-1887
/branches/ocean_projects/imp_vert_mix_mrp:754-986
/branches/ocean_projects/leith_mrp:2182-2241
+/branches/ocean_projects/linear_eos:2435-2437
/branches/ocean_projects/monotonic_advection:1499-1640
/branches/ocean_projects/monthly_forcing:1810-1867
/branches/ocean_projects/namelist_cleanup:2319-2414
/branches/ocean_projects/option3_b4b_test:2201-2231
/branches/ocean_projects/partial_bottom_cells:2172-2226
+/branches/ocean_projects/remove_sw_test_cases:2539-2540
/branches/ocean_projects/restart_reproducibility:2239-2272
+/branches/ocean_projects/sea_level_pressure:2488-2528
/branches/ocean_projects/split_explicit_mrp:1134-1138
/branches/ocean_projects/split_explicit_timestepping:1044-1097
/branches/ocean_projects/vert_adv_mrp:704-745
## -24,6 +30,8 ##
/branches/omp_blocks/halo:1570-1638
/branches/omp_blocks/io:1639-1787
/branches/omp_blocks/multiple_blocks:1803-2084
+/branches/scratch_indication:2555-2656
/branches/source_renaming:1082-1113
/branches/time_manager:924-962
-/trunk/mpas:2346-2428
+/branches/xml_registry:2610-2662
+/trunk/mpas:2346-2677
\ No newline at end of property
Modified: branches/ocean_projects/openmp_elements/Makefile
===================================================================
--- branches/ocean_projects/openmp_elements/Makefile 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/Makefile 2013-03-29 14:40:23 UTC (rev 2678)
@@ -363,12 +363,12 @@
@cd src; ls -d core_* | grep ".*" | sed "s/core_/ /g"
@echo ""
@echo "Available Options:"
- @echo " SERIAL=true - builds serial version. Default is parallel version."
+#@echo " SERIAL=true - builds serial version. Default is parallel version."
@echo " DEBUG=true - builds debug version. Default is optimized version."
@echo " USE_PAPI=true - builds version using PAPI for timers. Default is off."
@echo " TAU=true - builds version using TAU hooks for profiling. Default is off."
@echo ""
- @echo "Ensure that NETCDF (and PAPI if USE_PAPI=true) are environment variables"
+ @echo "Ensure that NETCDF, PNETCDF, PIO, and PAPI (if USE_PAPI=true) are environment variables"
@echo "that point to the absolute paths for the libraries."
@echo ""
Modified: branches/ocean_projects/openmp_elements/namelist.input.nhyd_atmos
===================================================================
--- branches/ocean_projects/openmp_elements/namelist.input.nhyd_atmos 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/namelist.input.nhyd_atmos 2013-03-29 14:40:23 UTC (rev 2678)
@@ -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: branches/ocean_projects/openmp_elements/namelist.input.ocean
===================================================================
--- branches/ocean_projects/openmp_elements/namelist.input.ocean 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/namelist.input.ocean 2013-03-29 14:40:23 UTC (rev 2678)
@@ -4,19 +4,18 @@
config_stop_time = 'none'
config_run_duration = '0_06:00:00'
config_calendar_type = '360day'
- config_ncouple_per_day = 1
/
&io
config_input_name = 'grid.nc'
config_output_name = 'output.nc'
config_restart_name = 'restart.nc'
- config_restart_interval = '0_03:00:00'
+ config_restart_interval = '0_06:00:00'
config_output_interval = '0_06:00:00'
- config_stats_interval = '00_00:00:01'
- config_write_stats_on_startup = .false.
- config_write_output_on_startup = .false.
- config_frames_per_outfile = 0
- config_pio_num_iotasks = 0
+ config_stats_interval = '0_01:00:00'
+ config_write_stats_on_startup = .true.
+ config_write_output_on_startup = .true.
+ config_frames_per_outfile = 1000
+ config_pio_num_iotasks = 0
config_pio_stride = 1
/
&time_integration
@@ -25,7 +24,6 @@
/
&grid
config_num_halos = 3
- config_enforce_grid_on_restart = .false.
config_vert_coord_movement = 'uniform_stretching'
config_alter_ICs_for_pbcs = 'zlevel_pbcs_off'
config_min_pbc_fraction = 0.10
@@ -38,23 +36,23 @@
config_proc_decomp_file_prefix = 'graph.info.part.'
/
&hmix
- config_h_ScaleWithMesh = .true.
+ config_hmix_ScaleWithMesh = .false.
config_visc_vorticity_term = .true.
config_apvm_scale_factor = 0.0
/
&hmix_del2
config_use_mom_del2 = .false.
config_use_tracer_del2 = .false.
- config_h_mom_eddy_visc2 = 0.0
- config_h_tracer_eddy_diff2 = 0.0
- config_visc_vorticity_visc2_scale = 1.0
+ config_mom_del2 = 0.0
+ config_tracer_del2 = 0.0
+ config_vorticity_del2_scale = 1.0
/
&hmix_del4
config_use_mom_del4 = .true.
config_use_tracer_del4 = .false.
- config_h_mom_eddy_visc4 = 5.0e13
- config_h_tracer_eddy_diff4 = 0.0
- config_visc_vorticity_visc4_scale = 1.0
+ config_mom_del4 = 5.0e13
+ config_tracer_del4 = 0.0
+ config_vorticity_del4_scale = 1.0
/
&hmix_Leith
config_use_Leith_del2 = .false.
@@ -71,7 +69,6 @@
config_Rayleigh_damping_coeff = 0.0
/
&vmix
- config_implicit_vertical_mix = .true.
config_convective_visc = 1.0
config_convective_diff = 1.0
/
@@ -121,6 +118,13 @@
&eos
config_eos_type = 'jm'
/
+&eos_linear
+ config_eos_linear_alpha = 2.55e-1
+ config_eos_linear_beta = 7.64e-1
+ config_eos_linear_Tref = 19.0
+ config_eos_linear_Sref = 35.0
+ config_eos_linear_rhoref = 1025.022
+/
&split_explicit_ts
config_n_ts_iter = 2
config_n_bcl_iter_beg = 1
@@ -135,13 +139,10 @@
config_btr_gam3_uWt2 = 1.0
config_btr_solve_SSH2 = .false.
/
-&sw_model
- config_test_case = 0
-/
&debug
config_check_zlevel_consistency = .false.
config_filter_btr_mode = .false.
- config_prescribe_velocity = .false.
+ config_prescribe_velocity = .false.
config_prescribe_thickness = .false.
config_include_KE_vertex = .false.
config_check_tracer_monotonicity = .false.
Modified: branches/ocean_projects/openmp_elements/src/Makefile
===================================================================
--- branches/ocean_projects/openmp_elements/src/Makefile 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/Makefile 2013-03-29 14:40:23 UTC (rev 2678)
@@ -10,7 +10,6 @@
all: mpas
-
mpas: reg_includes externals frame ops dycore drver
$(LINKER) $(LDFLAGS) -o $(CORE)_model.exe driver/*.o -L. -ldycore -lops -lframework $(LIBS) -I./external/esmf_time_f90 -L./external/esmf_time_f90 -lesmf_time
@@ -23,7 +22,7 @@
reg_includes:
( cd registry; $(MAKE) CC="$(SCC)" )
- ( cd inc; $(CPP) ../core_$(CORE)/Registry | ../registry/parse > Registry.processed)
+ ( cd inc; $(CPP) ../core_$(CORE)/Registry.xml | ../registry/parse > Registry.processed)
frame: reg_includes externals
( cd framework; $(MAKE) CPPFLAGS="$(CPPFLAGS)" CPPINCLUDES="$(CPPINCLUDES)" all )
Modified: branches/ocean_projects/openmp_elements/src/core_atmos_physics/Makefile
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_atmos_physics/Makefile 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_atmos_physics/Makefile 2013-03-29 14:40:23 UTC (rev 2678)
@@ -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: branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_control.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_control.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_control.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -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: branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_date_time.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_date_time.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_date_time.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -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: branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_driver.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_driver.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_driver.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -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: branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_driver_convection_deep.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_driver_convection_deep.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_driver_convection_deep.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -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
Copied: branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_driver_gwdo.F (from rev 2677, trunk/mpas/src/core_atmos_physics/mpas_atmphys_driver_gwdo.F)
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_driver_gwdo.F (rev 0)
+++ branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_driver_gwdo.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -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: branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_driver_lsm.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_driver_lsm.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_driver_lsm.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -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: branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_driver_microphysics.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_driver_microphysics.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_driver_microphysics.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -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: branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_driver_pbl.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_driver_pbl.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_driver_pbl.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -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: branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_driver_radiation_lw.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_driver_radiation_lw.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_driver_radiation_lw.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -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: branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_driver_radiation_sw.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_driver_radiation_sw.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_driver_radiation_sw.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -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: branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_driver_sfclayer.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_driver_sfclayer.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_driver_sfclayer.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -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: branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_initialize_real.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_initialize_real.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_initialize_real.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -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: branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_interface_nhyd.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_interface_nhyd.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_interface_nhyd.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -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: branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_manager.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_manager.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_manager.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -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: branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_todynamics.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_todynamics.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_todynamics.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -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: branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_update_surface.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_update_surface.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_update_surface.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -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: branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_vars.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_vars.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_atmos_physics/mpas_atmphys_vars.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -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: branches/ocean_projects/openmp_elements/src/core_atmos_physics/physics_wrf/Makefile
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_atmos_physics/physics_wrf/Makefile 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_atmos_physics/physics_wrf/Makefile 2013-03-29 14:40:23 UTC (rev 2678)
@@ -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 \
Copied: branches/ocean_projects/openmp_elements/src/core_atmos_physics/physics_wrf/module_bl_gwdo.F (from rev 2677, trunk/mpas/src/core_atmos_physics/physics_wrf/module_bl_gwdo.F)
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_atmos_physics/physics_wrf/module_bl_gwdo.F (rev 0)
+++ branches/ocean_projects/openmp_elements/src/core_atmos_physics/physics_wrf/module_bl_gwdo.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -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: branches/ocean_projects/openmp_elements/src/core_atmos_physics/physics_wrf/module_bl_ysu.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_atmos_physics/physics_wrf/module_bl_ysu.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_atmos_physics/physics_wrf/module_bl_ysu.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -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: branches/ocean_projects/openmp_elements/src/core_atmos_physics/physics_wrf/module_cu_tiedtke.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_atmos_physics/physics_wrf/module_cu_tiedtke.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_atmos_physics/physics_wrf/module_cu_tiedtke.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -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) )
Copied: branches/ocean_projects/openmp_elements/src/core_atmos_physics/physics_wrf/module_mp_radar.F (from rev 2677, trunk/mpas/src/core_atmos_physics/physics_wrf/module_mp_radar.F)
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_atmos_physics/physics_wrf/module_mp_radar.F (rev 0)
+++ branches/ocean_projects/openmp_elements/src/core_atmos_physics/physics_wrf/module_mp_radar.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -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: branches/ocean_projects/openmp_elements/src/core_atmos_physics/physics_wrf/module_mp_wsm6.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_atmos_physics/physics_wrf/module_mp_wsm6.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_atmos_physics/physics_wrf/module_mp_wsm6.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -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: branches/ocean_projects/openmp_elements/src/core_atmos_physics/physics_wrf/module_ra_rrtmg_sw.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_atmos_physics/physics_wrf/module_ra_rrtmg_sw.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_atmos_physics/physics_wrf/module_ra_rrtmg_sw.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -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: branches/ocean_projects/openmp_elements/src/core_atmos_physics/physics_wrf/module_sf_sfclay.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_atmos_physics/physics_wrf/module_sf_sfclay.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_atmos_physics/physics_wrf/module_sf_sfclay.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -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: branches/ocean_projects/openmp_elements/src/core_hyd_atmos/Registry
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_hyd_atmos/Registry 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_hyd_atmos/Registry 2013-03-29 14:40:23 UTC (rev 2678)
@@ -96,7 +96,7 @@
var persistent real edgeNormalVectors ( R3 nEdges ) 0 o edgeNormalVectors mesh - -
var persistent real localVerticalUnitVectors ( R3 nCells ) 0 o localVerticalUnitVectors mesh - -
-var persistent real cellTangentPlane ( R3 TWO nEdges ) 0 o cellTangentPlane mesh - -
+var persistent real cellTangentPlane ( R3 TWO nCells ) 0 o cellTangentPlane mesh - -
var persistent integer cellsOnCell ( maxEdges nCells ) 0 iro cellsOnCell mesh - -
var persistent integer verticesOnCell ( maxEdges nCells ) 0 iro verticesOnCell mesh - -
Copied: branches/ocean_projects/openmp_elements/src/core_hyd_atmos/Registry.xml (from rev 2677, trunk/mpas/src/core_hyd_atmos/Registry.xml)
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_hyd_atmos/Registry.xml (rev 0)
+++ branches/ocean_projects/openmp_elements/src/core_hyd_atmos/Registry.xml 2013-03-29 14:40:23 UTC (rev 2678)
@@ -0,0 +1,179 @@
+<?xml version="1.0"?>
+<registry>
+ <dims>
+ <dim name="nCells"/>
+ <dim name="nEdges"/>
+ <dim name="maxEdges"/>
+ <dim name="maxEdges2"/>
+ <dim name="nVertices"/>
+ <dim name="TWO" definition="2"/>
+ <dim name="vertexDegree"/>
+ <dim name="FIFTEEN" definition="15"/>
+ <dim name="TWENTYONE" definition="21"/>
+ <dim name="R3" definition="3"/>
+ <dim name="nVertLevels" definition="namelist:config_nvertlevels"/>
+ <dim name="nVertLevelsP1" definition="nVertLevels+1"/>
+ </dims>
+ <nml_record name="sw_model">
+ <nml_option name="config_test_case" type="integer" default_value="5"/>
+ <nml_option name="config_time_integration" type="character" default_value="SRK3"/>
+ <nml_option name="config_dt" type="real" default_value="172.8"/>
+ <nml_option name="config_calendar_type" type="character" default_value="360day"/>
+ <nml_option name="config_start_time" type="character" default_value="0000-01-01_00:00:00"/>
+ <nml_option name="config_stop_time" type="character" default_value="none"/>
+ <nml_option name="config_run_duration" type="character" default_value="none"/>
+ <nml_option name="config_h_mom_eddy_visc2" type="real" default_value="0.0"/>
+ <nml_option name="config_h_mom_eddy_visc4" type="real" default_value="0.0"/>
+ <nml_option name="config_v_mom_eddy_visc2" type="real" default_value="0.0"/>
+ <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_number_of_sub_steps" type="integer" default_value="4"/>
+ <nml_option name="config_theta_adv_order" type="integer" default_value="2"/>
+ <nml_option name="config_scalar_adv_order" type="integer" default_value="2"/>
+ <nml_option name="config_positive_definite" type="logical" default_value="false"/>
+ <nml_option name="config_monotonic" type="logical" default_value="true"/>
+ <nml_option name="config_mp_physics" type="integer" default_value="0"/>
+ <nml_option name="config_apvm_upwinding" type="real" default_value="0.5"/>
+ <nml_option name="config_num_halos" type="integer" default_value="2"/>
+ </nml_record>
+ <nml_record name="dimensions">
+ <nml_option name="config_nvertlevels" type="integer" default_value="26"/>
+ </nml_record>
+ <nml_record name="io">
+ <nml_option name="config_input_name" type="character" default_value="grid.nc"/>
+ <nml_option name="config_output_name" type="character" default_value="output.nc"/>
+ <nml_option name="config_restart_name" type="character" default_value="restart.nc"/>
+ <nml_option name="config_output_interval" type="character" default_value="06:00:00"/>
+ <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_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_proc_decomp_file_prefix" type="character" default_value="graph.info.part."/>
+ </nml_record>
+ <nml_record name="restart">
+ <nml_option name="config_do_restart" type="logical" default_value="false"/>
+ <nml_option name="config_restart_interval" type="character" default_value="none"/>
+ </nml_record>
+ <var_struct name="state" time_levs="2">
+ <var_array name="scalars" type="real" dimensions="nVertLevels nCells Time">
+ <var name="qv" array_group="moist" streams="iro"/>
+ <var name="qc" array_group="moist" streams="iro"/>
+ <var name="qr" array_group="moist" streams="iro"/>
+ </var_array>
+ <var name="xtime" type="text" dimensions="Time" streams="ro"/>
+ <var name="u" type="real" dimensions="nVertLevels nEdges Time" streams="iro"/>
+ <var name="theta" type="real" dimensions="nVertLevels nCells Time" streams="iro"/>
+ <var name="surface_pressure" type="real" dimensions="nCells Time" streams="iro"/>
+ <var name="h" type="real" dimensions="nVertLevels nCells Time" streams="ro"/>
+ <var name="ww" type="real" dimensions="nVertLevelsP1 nCells Time" streams="ro"/>
+ <var name="w" type="real" dimensions="nVertLevelsP1 nCells Time" streams="ro"/>
+ <var name="pressure" type="real" dimensions="nVertLevelsP1 nCells Time" streams="ro"/>
+ <var name="geopotential" type="real" dimensions="nVertLevelsP1 nCells Time" streams="ro"/>
+ <var name="alpha" type="real" dimensions="nVertLevels nCells Time" streams="iro"/>
+ <var name="v" type="real" dimensions="nVertLevels nEdges Time" streams="o"/>
+ <var name="divergence" type="real" dimensions="nVertLevels nCells Time" streams="o"/>
+ <var name="vorticity" type="real" dimensions="nVertLevels nVertices Time" streams="o"/>
+ <var name="pv_edge" type="real" dimensions="nVertLevels nEdges Time" streams="o"/>
+ <var name="h_edge" type="real" dimensions="nVertLevels nEdges Time" streams="o"/>
+ <var name="ke" type="real" dimensions="nVertLevels nCells Time" streams="o"/>
+ <var name="pv_vertex" type="real" dimensions="nVertLevels nVertices Time" streams="o"/>
+ <var name="pv_cell" type="real" dimensions="nVertLevels nCells Time" streams="o"/>
+ <var name="vh" type="real" dimensions="nVertLevels nEdges Time"/>
+ <var name="circulation" type="real" dimensions="nVertLevels nVertices Time"/>
+ <var name="gradPVt" type="real" dimensions="nVertLevels nEdges Time"/>
+ <var name="gradPVn" type="real" dimensions="nVertLevels nEdges Time"/>
+ </var_struct>
+ <var_struct name="mesh" time_levs="0">
+ <var_array name="scalars_old" type="real" dimensions="nVertLevels nCells">
+ <var name="qv_old" array_group="moist_old"/>
+ <var name="qc_old" array_group="moist_old"/>
+ <var name="qr_old" array_group="moist_old"/>
+ </var_array>
+ <var name="latCell" type="real" dimensions="nCells" streams="iro"/>
+ <var name="lonCell" type="real" dimensions="nCells" streams="iro"/>
+ <var name="xCell" type="real" dimensions="nCells" streams="iro"/>
+ <var name="yCell" type="real" dimensions="nCells" streams="iro"/>
+ <var name="zCell" type="real" dimensions="nCells" streams="iro"/>
+ <var name="indexToCellID" type="integer" dimensions="nCells" streams="iro"/>
+ <var name="latEdge" type="real" dimensions="nEdges" streams="iro"/>
+ <var name="lonEdge" type="real" dimensions="nEdges" streams="iro"/>
+ <var name="xEdge" type="real" dimensions="nEdges" streams="iro"/>
+ <var name="yEdge" type="real" dimensions="nEdges" streams="iro"/>
+ <var name="zEdge" type="real" dimensions="nEdges" streams="iro"/>
+ <var name="indexToEdgeID" type="integer" dimensions="nEdges" streams="iro"/>
+ <var name="latVertex" type="real" dimensions="nVertices" streams="iro"/>
+ <var name="lonVertex" type="real" dimensions="nVertices" streams="iro"/>
+ <var name="xVertex" type="real" dimensions="nVertices" streams="iro"/>
+ <var name="yVertex" type="real" dimensions="nVertices" streams="iro"/>
+ <var name="zVertex" type="real" dimensions="nVertices" streams="iro"/>
+ <var name="indexToVertexID" type="integer" dimensions="nVertices" streams="iro"/>
+ <var name="cellsOnEdge" type="integer" dimensions="TWO nEdges" streams="iro"/>
+ <var name="nEdgesOnCell" type="integer" dimensions="nCells" streams="iro"/>
+ <var name="nEdgesOnEdge" type="integer" dimensions="nEdges" streams="iro"/>
+ <var name="edgesOnCell" type="integer" dimensions="maxEdges nCells" streams="iro"/>
+ <var name="edgesOnEdge" type="integer" dimensions="maxEdges2 nEdges" streams="iro"/>
+ <var name="weightsOnEdge" type="real" dimensions="maxEdges2 nEdges" streams="iro"/>
+ <var name="dvEdge" type="real" dimensions="nEdges" streams="iro"/>
+ <var name="dcEdge" type="real" dimensions="nEdges" streams="iro"/>
+ <var name="angleEdge" type="real" dimensions="nEdges" streams="iro"/>
+ <var name="areaCell" type="real" dimensions="nCells" streams="iro"/>
+ <var name="areaTriangle" type="real" dimensions="nVertices" streams="iro"/>
+ <var name="edgeNormalVectors" type="real" dimensions="R3 nEdges" streams="o"/>
+ <var name="localVerticalUnitVectors" type="real" dimensions="R3 nCells" streams="o"/>
+ <var name="cellTangentPlane" type="real" dimensions="R3 TWO nCells" streams="o"/>
+ <var name="cellsOnCell" type="integer" dimensions="maxEdges nCells" streams="iro"/>
+ <var name="verticesOnCell" type="integer" dimensions="maxEdges nCells" streams="iro"/>
+ <var name="verticesOnEdge" type="integer" dimensions="TWO nEdges" streams="iro"/>
+ <var name="edgesOnVertex" type="integer" dimensions="vertexDegree nVertices" streams="iro"/>
+ <var name="cellsOnVertex" type="integer" dimensions="vertexDegree nVertices" streams="iro"/>
+ <var name="kiteAreasOnVertex" type="real" dimensions="vertexDegree nVertices" streams="iro"/>
+ <var name="fEdge" type="real" dimensions="nEdges" streams="iro"/>
+ <var name="fVertex" type="real" dimensions="nVertices" streams="iro"/>
+ <var name="h_s" type="real" dimensions="nCells" streams="iro"/>
+ <var name="rdnu" type="real" dimensions="nVertLevels" streams="iro"/>
+ <var name="rdnw" type="real" dimensions="nVertLevels" streams="iro"/>
+ <var name="fnm" type="real" dimensions="nVertLevels" streams="iro"/>
+ <var name="fnp" type="real" dimensions="nVertLevels" streams="iro"/>
+ <var name="dbn" type="real" dimensions="nVertLevels" streams="iro"/>
+ <var name="dnu" type="real" dimensions="nVertLevels" streams="iro"/>
+ <var name="dnw" type="real" dimensions="nVertLevels" streams="iro"/>
+ <var name="uhAvg" type="real" dimensions="nVertLevels nEdges"/>
+ <var name="wwAvg" type="real" dimensions="nVertLevelsP1 nCells"/>
+ <var name="qtot" type="real" dimensions="nVertLevels nCells"/>
+ <var name="cqu" type="real" dimensions="nVertLevels nEdges"/>
+ <var name="h_diabatic" type="real" dimensions="nVertLevels nCells"/>
+ <var name="dpsdt" type="real" dimensions="nCells"/>
+ <var name="u_old" type="real" dimensions="nVertLevels nEdges"/>
+ <var name="ww_old" type="real" dimensions="nVertLevelsP1 nCells"/>
+ <var name="theta_old" type="real" dimensions="nVertLevels nCells"/>
+ <var name="h_edge_old" type="real" dimensions="nVertLevels nEdges"/>
+ <var name="h_old" type="real" dimensions="nVertLevels nCells"/>
+ <var name="pressure_old" type="real" dimensions="nVertLevelsP1 nCells"/>
+ <var name="deriv_two" type="real" dimensions="FIFTEEN TWO nEdges" streams="o"/>
+ <var name="advCells" type="integer" dimensions="TWENTYONE nCells"/>
+ <var name="coeffs_reconstruct" type="real" dimensions="R3 maxEdges nCells"/>
+ </var_struct>
+ <var_struct name="diag" time_levs="1">
+ <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"/>
+ <var name="uReconstructZonal" type="real" dimensions="nVertLevels nCells Time" streams="o"/>
+ <var name="uReconstructMeridional" type="real" dimensions="nVertLevels nCells Time" streams="o"/>
+ </var_struct>
+ <var_struct name="tend" time_levs="1">
+ <var_array name="scalars" type="real" dimensions="nVertLevels nCells Time">
+ <var name="tend_qv" array_group="moist" name_in_code="qv"/>
+ <var name="tend_qc" array_group="moist" name_in_code="qc"/>
+ <var name="tend_qr" array_group="moist" name_in_code="qr"/>
+ </var_array>
+ <var name="tend_h" type="real" dimensions="nVertLevels nCells Time" name_in_code="h"/>
+ <var name="tend_u" type="real" dimensions="nVertLevels nEdges Time" name_in_code="u"/>
+ <var name="tend_vh" type="real" dimensions="nVertLevels nEdges Time" name_in_code="vh"/>
+ <var name="tend_theta" type="real" dimensions="nVertLevels nCells Time" name_in_code="theta"/>
+ </var_struct>
+</registry>
Modified: branches/ocean_projects/openmp_elements/src/core_init_nhyd_atmos/Makefile
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_init_nhyd_atmos/Makefile 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_init_nhyd_atmos/Makefile 2013-03-29 14:40:23 UTC (rev 2678)
@@ -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: branches/ocean_projects/openmp_elements/src/core_init_nhyd_atmos/Registry
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_init_nhyd_atmos/Registry 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_init_nhyd_atmos/Registry 2013-03-29 14:40:23 UTC (rev 2678)
@@ -108,7 +108,7 @@
var persistent real edgeNormalVectors ( R3 nEdges ) 0 io edgeNormalVectors mesh - -
var persistent real localVerticalUnitVectors ( R3 nCells ) 0 io localVerticalUnitVectors mesh - -
-var persistent real cellTangentPlane ( R3 TWO nEdges ) 0 io cellTangentPlane mesh - -
+var persistent real cellTangentPlane ( R3 TWO nCells ) 0 io cellTangentPlane mesh - -
var persistent integer cellsOnCell ( maxEdges nCells ) 0 io cellsOnCell mesh - -
var persistent integer verticesOnCell ( maxEdges nCells ) 0 io verticesOnCell mesh - -
@@ -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 - -
Copied: branches/ocean_projects/openmp_elements/src/core_init_nhyd_atmos/Registry.xml (from rev 2677, trunk/mpas/src/core_init_nhyd_atmos/Registry.xml)
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_init_nhyd_atmos/Registry.xml (rev 0)
+++ branches/ocean_projects/openmp_elements/src/core_init_nhyd_atmos/Registry.xml 2013-03-29 14:40:23 UTC (rev 2678)
@@ -0,0 +1,297 @@
+<?xml version="1.0"?>
+<registry>
+
+<!-- **************************************************************************************** -->
+<!-- ************************************** Dimensions ************************************** -->
+<!-- **************************************************************************************** -->
+
+ <dims>
+ <dim name="nCells"/>
+ <dim name="nEdges"/>
+ <dim name="maxEdges"/>
+ <dim name="maxEdges2"/>
+ <dim name="nVertices"/>
+ <dim name="TWO" definition="2"/>
+ <dim name="THREE" definition="3"/>
+ <dim name="vertexDegree"/>
+ <dim name="FIFTEEN" definition="15"/>
+ <dim name="TWENTYONE" definition="21"/>
+ <dim name="R3" definition="3"/>
+ <dim name="nVertLevels" definition="namelist:config_nvertlevels"/>
+ <dim name="nSoilLevels" definition="namelist:config_nsoillevels"/>
+ <dim name="nFGLevels" definition="namelist:config_nfglevels"/>
+ <dim name="nFGSoilLevels" definition="namelist:config_nfgsoillevels"/>
+ <dim name="nVertLevelsP1" definition="nVertLevels+1"/>
+ <dim name="nMonths" definition="namelist:config_months"/>
+ </dims>
+
+
+<!-- **************************************************************************************** -->
+<!-- ************************************** Namelists *************************************** -->
+<!-- **************************************************************************************** -->
+
+ <nml_record name="nhyd_model">
+ <nml_option name="config_test_case" type="integer" default_value="7"/>
+ <nml_option name="config_calendar_type" type="character" default_value="gregorian"/>
+ <nml_option name="config_start_time" type="character" default_value="none"/>
+ <nml_option name="config_stop_time" type="character" default_value="none"/>
+ <nml_option name="config_theta_adv_order" type="integer" default_value="3"/>
+ <nml_option name="config_coef_3rd_order" type="real" default_value="0.25"/>
+ <nml_option name="config_num_halos" type="integer" default_value="2"/>
+ </nml_record>
+
+ <nml_record name="dcmip">
+ <nml_option name="config_dcmip_case" type="character" default_value="2-0-0"/>
+ <nml_option name="config_planet_scale" type="real" default_value="1.0"/>
+ <nml_option name="config_rotation_rate_scale" type="real" default_value="1.0"/>
+ </nml_record>
+
+ <nml_record name="dimensions">
+ <nml_option name="config_nvertlevels" type="integer" default_value="26"/>
+ <nml_option name="config_nsoillevels" type="integer" default_value="4"/>
+ <nml_option name="config_nfglevels" type="integer" default_value="27"/>
+ <nml_option name="config_nfgsoillevels" type="integer" default_value="4"/>
+ <nml_option name="config_months" type="integer" default_value="12"/>
+ </nml_record>
+
+ <nml_record name="data_sources">
+ <nml_option name="config_geog_data_path" type="character" default_value="/mmm/users/wrfhelp/WPS_GEOG/"/>
+ <nml_option name="config_met_prefix" type="character" default_value="FILE"/>
+ <nml_option name="config_sfc_prefix" type="character" default_value="FILE"/>
+ <nml_option name="config_fg_interval" type="integer" default_value="21600"/>
+ </nml_record>
+
+ <nml_record name="vertical_grid">
+ <nml_option name="config_ztop" type="real" default_value="28000.0"/>
+ <nml_option name="config_nsmterrain" type="integer" default_value="2"/>
+ <nml_option name="config_smooth_surfaces" type="logical" default_value="false"/>
+ </nml_record>
+
+ <nml_record name="preproc_stages">
+ <nml_option name="config_static_interp" type="logical" default_value="true"/>
+ <nml_option name="config_vertical_grid" type="logical" default_value="true"/>
+ <nml_option name="config_met_interp" type="logical" default_value="true"/>
+ <nml_option name="config_input_sst" type="logical" default_value="false"/>
+ <nml_option name="config_frac_seaice" type="logical" default_value="false"/>
+ </nml_record>
+
+ <nml_record name="io">
+ <nml_option name="config_input_name" type="character" default_value="grid.nc"/>
+ <nml_option name="config_sfc_update_name" type="character" default_value="sfc_update.nc"/>
+ <nml_option name="config_output_name" type="character" default_value="init.nc"/>
+ <nml_option name="config_restart_name" type="character" default_value="restart.nc"/>
+ <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_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_proc_decomp_file_prefix" type="character" default_value="graph.info.part."/>
+ </nml_record>
+
+ <nml_record name="restart">
+ <nml_option name="config_restart_interval" type="integer" default_value="0"/>
+ <nml_option name="config_do_restart" type="logical" default_value="false"/>
+ <nml_option name="config_restart_time" type="real" default_value="172800.0"/>
+ </nml_record>
+
+
+<!-- **************************************************************************************** -->
+<!-- ************************************** Variables *************************************** -->
+<!-- **************************************************************************************** -->
+
+ <var_struct name="mesh" time_levs="0">
+ <var name="latCell" type="real" dimensions="nCells" streams="io"/>
+ <var name="lonCell" type="real" dimensions="nCells" streams="io"/>
+ <var name="xCell" type="real" dimensions="nCells" streams="io"/>
+ <var name="yCell" type="real" dimensions="nCells" streams="io"/>
+ <var name="zCell" type="real" dimensions="nCells" streams="io"/>
+ <var name="indexToCellID" type="integer" dimensions="nCells" streams="io"/>
+ <var name="latEdge" type="real" dimensions="nEdges" streams="io"/>
+ <var name="lonEdge" type="real" dimensions="nEdges" streams="io"/>
+ <var name="xEdge" type="real" dimensions="nEdges" streams="io"/>
+ <var name="yEdge" type="real" dimensions="nEdges" streams="io"/>
+ <var name="zEdge" type="real" dimensions="nEdges" streams="io"/>
+ <var name="indexToEdgeID" type="integer" dimensions="nEdges" streams="io"/>
+ <var name="latVertex" type="real" dimensions="nVertices" streams="io"/>
+ <var name="lonVertex" type="real" dimensions="nVertices" streams="io"/>
+ <var name="xVertex" type="real" dimensions="nVertices" streams="io"/>
+ <var name="yVertex" type="real" dimensions="nVertices" streams="io"/>
+ <var name="zVertex" type="real" dimensions="nVertices" streams="io"/>
+ <var name="indexToVertexID" type="integer" dimensions="nVertices" streams="io"/>
+ <var name="cellsOnEdge" type="integer" dimensions="TWO nEdges" streams="io"/>
+ <var name="nEdgesOnCell" type="integer" dimensions="nCells" streams="io"/>
+ <var name="nEdgesOnEdge" type="integer" dimensions="nEdges" streams="io"/>
+ <var name="edgesOnCell" type="integer" dimensions="maxEdges nCells" streams="io"/>
+ <var name="edgesOnEdge" type="integer" dimensions="maxEdges2 nEdges" streams="io"/>
+ <var name="weightsOnEdge" type="real" dimensions="maxEdges2 nEdges" streams="io"/>
+ <var name="dvEdge" type="real" dimensions="nEdges" streams="io"/>
+ <var name="dcEdge" type="real" dimensions="nEdges" streams="io"/>
+ <var name="angleEdge" type="real" dimensions="nEdges" streams="io"/>
+ <var name="areaCell" type="real" dimensions="nCells" streams="io"/>
+ <var name="areaTriangle" type="real" dimensions="nVertices" streams="io"/>
+ <var name="edgeNormalVectors" type="real" dimensions="R3 nEdges" streams="io"/>
+ <var name="localVerticalUnitVectors" type="real" dimensions="R3 nCells" streams="io"/>
+ <var name="cellTangentPlane" type="real" dimensions="R3 TWO nCells" streams="io"/>
+ <var name="cellsOnCell" type="integer" dimensions="maxEdges nCells" streams="io"/>
+ <var name="verticesOnCell" type="integer" dimensions="maxEdges nCells" streams="io"/>
+ <var name="verticesOnEdge" type="integer" dimensions="TWO nEdges" streams="io"/>
+ <var name="edgesOnVertex" type="integer" dimensions="vertexDegree nVertices" streams="io"/>
+ <var name="cellsOnVertex" type="integer" dimensions="vertexDegree nVertices" streams="io"/>
+ <var name="kiteAreasOnVertex" type="real" dimensions="vertexDegree nVertices" streams="io"/>
+ <var name="fEdge" type="real" dimensions="nEdges" streams="io"/>
+ <var name="fVertex" type="real" dimensions="nVertices" streams="io"/>
+ <var name="meshDensity" type="real" dimensions="nCells" streams="iro"/>
+
+ <!-- coefficients for vertical extrapolation to the surface -->
+ <var name="cf1" type="real" dimensions="" streams="io"/>
+ <var name="cf2" type="real" dimensions="" streams="io"/>
+ <var name="cf3" type="real" dimensions="" streams="io"/>
+
+ <!-- static terrestrial fields -->
+ <var name="ter" type="real" dimensions="nCells" streams="io"/>
+ <var name="landmask" type="integer" dimensions="nCells" streams="io"/>
+ <var name="ivgtyp" name_in_code="lu_index" type="integer" dimensions="nCells" streams="io"/>
+ <var name="isltyp" name_in_code="soilcat_top" type="integer" dimensions="nCells" streams="io"/>
+ <var name="soilcat_bot" type="integer" dimensions="nCells" streams="io"/>
+ <var name="snoalb" type="real" dimensions="nCells" streams="io"/>
+ <var name="soiltemp" type="real" dimensions="nCells" streams="io"/>
+ <var name="greenfrac" type="real" dimensions="nMonths nCells" streams="io"/>
+ <var name="shdmin" type="real" dimensions="nCells" streams="io"/>
+ <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"/>
+ <var name="rdzw" type="real" dimensions="nVertLevels" streams="io"/>
+ <var name="dzu" type="real" dimensions="nVertLevels" streams="io"/>
+ <var name="rdzu" type="real" dimensions="nVertLevels" streams="io"/>
+ <var name="fzm" type="real" dimensions="nVertLevels" streams="io"/>
+ <var name="fzp" type="real" dimensions="nVertLevels" streams="io"/>
+ <var name="zx" type="real" dimensions="nVertLevelsP1 nEdges" streams="io"/>
+ <var name="zz" type="real" dimensions="nVertLevelsP1 nCells" streams="io"/>
+ <var name="zb" type="real" dimensions="nVertLevelsP1 TWO nEdges" streams="io"/>
+ <var name="zb3" type="real" dimensions="nVertLevelsP1 TWO nEdges" streams="io"/>
+
+ <!-- W-Rayleigh damping coefficient -->
+ <var name="dss" type="real" dimensions="nVertLevels nCells" streams="io"/>
+
+ <var name="u_init" type="real" dimensions="nVertLevels" streams="io"/>
+ <var name="t_init" type="real" dimensions="nVertLevels nCells" streams="io"/>
+ <var name="qv_init" type="real" dimensions="nVertLevels" streams="io"/>
+
+ <!-- variables needed for advection -->
+ <var name="deriv_two" type="real" dimensions="FIFTEEN TWO nEdges" streams="io"/>
+ <var name="advCells" type="integer" dimensions="TWENTYONE nCells" streams="io"/>
+
+ <!-- deformation calculation weights -->
+ <var name="defc_a" type="real" dimensions="maxEdges nCells" streams="io"/>
+ <var name="defc_b" type="real" dimensions="maxEdges nCells" streams="io"/>
+
+ <!-- arrays required for reconstruction of velocity field -->
+ <var name="coeffs_reconstruct" type="real" dimensions="R3 maxEdges nCells" streams="io"/>
+ </var_struct>
+
+ <var_struct name="state" time_levs="2">
+ <var name="xtime" type="text" dimensions="Time" streams="so"/>
+ <var name="u" type="real" dimensions="nVertLevels nEdges Time" streams="o"/>
+ <var name="w" type="real" dimensions="nVertLevelsP1 nCells Time" streams="o"/>
+ <var name="rho_zz" type="real" dimensions="nVertLevels nCells Time" streams="o"/>
+ <var name="theta_m" type="real" dimensions="nVertLevels nCells Time" streams="o"/>
+
+ <var_array name="scalars" type="real" dimensions="nVertLevels nCells Time">
+ <var name="qv" array_group="moist" streams="o"/>
+ <var name="qc" array_group="moist" streams="o"/>
+ <var name="qr" array_group="moist" streams="o"/>
+ </var_array>
+ </var_struct>
+
+ <var_struct name="fg" time_levs="1">
+
+ <!-- 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" 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"/>
+ <var name="dz_fg" type="real" dimensions="nFGSoilLevels nCells Time" streams="io"/>
+ <var name="dzs_fg" type="real" dimensions="nFGSoilLevels nCells Time" streams="io"/>
+ <var name="zs_fg" type="real" dimensions="nFGSoilLevels nCells Time" streams="io"/>
+ <var name="st_fg" type="real" dimensions="nFGSoilLevels nCells Time" streams="io"/>
+ <var name="sm_fg" type="real" dimensions="nFGSoilLevels nCells Time" streams="io"/>
+
+ <!-- horizontally interpolated from first-guess data, and should be read in by model -->
+ <var name="dz" type="real" dimensions="nSoilLevels nCells Time" streams="io"/>
+ <var name="dzs" type="real" dimensions="nSoilLevels nCells Time" streams="io"/>
+ <var name="zs" type="real" dimensions="nSoilLevels nCells Time" streams="io"/>
+ <var name="sh2o" type="real" dimensions="nSoilLevels nCells Time" streams="io"/>
+ <var name="smois" type="real" dimensions="nSoilLevels nCells Time" streams="io"/>
+ <var name="tslb" type="real" dimensions="nSoilLevels nCells Time" streams="io"/>
+ <var name="smcrel" type="real" dimensions="nSoilLevels nCells Time" streams="io"/>
+ <var name="tmn" type="real" dimensions="nCells Time" streams="io"/>
+ <var name="skintemp" type="real" dimensions="nCells Time" streams="io"/>
+ <var name="sst" type="real" dimensions="nCells Time" streams="iso"/>
+ <var name="snow" type="real" dimensions="nCells Time" streams="io"/>
+ <var name="snowc" type="real" dimensions="nCells Time" streams="io"/>
+ <var name="snowh" type="real" dimensions="nCells Time" streams="io"/>
+ <var name="xice" type="real" dimensions="nCells Time" streams="iso"/>
+ <var name="seaice" type="real" dimensions="nCells Time" streams="io"/>
+ <var name="gfs_z" type="real" dimensions="nVertLevels nCells Time"/>
+ <var name="vegfra" type="real" dimensions="nCells Time" streams="io"/>
+ <var name="sfc_albbck" type="real" dimensions="nCells Time" streams="io"/>
+ <var name="xland" type="real" dimensions="nCells Time" streams="io"/>
+ </var_struct>
+
+ <var_struct name="diag" time_levs="1">
+ <var name="pressure_p" type="real" dimensions="nVertLevels nCells Time"/>
+ <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"/>
+ <var name="uReconstructZonal" type="real" dimensions="nVertLevels nCells Time" streams="o"/>
+ <var name="uReconstructMeridional" type="real" dimensions="nVertLevels nCells Time" streams="o"/>
+ <var name="exner" type="real" dimensions="nVertLevels nCells Time"/>
+ <var name="exner_base" type="real" dimensions="nVertLevels nCells Time" streams="io"/>
+ <var name="rtheta_base" type="real" dimensions="nVertLevels nCells Time"/>
+ <var name="pressure" type="real" dimensions="nVertLevels nCells Time"/>
+ <var name="pressure_base" type="real" dimensions="nVertLevels nCells Time" streams="io"/>
+ <var name="rho_base" type="real" dimensions="nVertLevels nCells Time" streams="io"/>
+ <var name="theta_base" type="real" dimensions="nVertLevels nCells Time" streams="io"/>
+ <var name="cqw" type="real" dimensions="nVertLevels nCells Time"/>
+ <var name="surface_pressure" type="real" dimensions="nCells Time" streams="io"/>
+
+ <!-- coupled variables needed by the solver, but not output -->
+ <var name="ru" type="real" dimensions="nVertLevels nEdges Time"/>
+ <var name="rw" type="real" dimensions="nVertLevelsP1 nCells Time"/>
+ <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: branches/ocean_projects/openmp_elements/src/core_init_nhyd_atmos/mpas_init_atm_llxy.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_init_nhyd_atmos/mpas_init_atm_llxy.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_init_nhyd_atmos/mpas_init_atm_llxy.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -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, &
Copied: branches/ocean_projects/openmp_elements/src/core_init_nhyd_atmos/mpas_init_atm_static.F (from rev 2677, trunk/mpas/src/core_init_nhyd_atmos/mpas_init_atm_static.F)
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_init_nhyd_atmos/mpas_init_atm_static.F (rev 0)
+++ branches/ocean_projects/openmp_elements/src/core_init_nhyd_atmos/mpas_init_atm_static.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -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
+!==================================================================================================
Copied: branches/ocean_projects/openmp_elements/src/core_init_nhyd_atmos/mpas_init_atm_surface.F (from rev 2677, trunk/mpas/src/core_init_nhyd_atmos/mpas_init_atm_surface.F)
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_init_nhyd_atmos/mpas_init_atm_surface.F (rev 0)
+++ branches/ocean_projects/openmp_elements/src/core_init_nhyd_atmos/mpas_init_atm_surface.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -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: branches/ocean_projects/openmp_elements/src/core_init_nhyd_atmos/mpas_init_atm_test_cases.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_init_nhyd_atmos/mpas_init_atm_test_cases.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_init_nhyd_atmos/mpas_init_atm_test_cases.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -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: branches/ocean_projects/openmp_elements/src/core_nhyd_atmos/Makefile
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_nhyd_atmos/Makefile 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_nhyd_atmos/Makefile 2013-03-29 14:40:23 UTC (rev 2678)
@@ -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: branches/ocean_projects/openmp_elements/src/core_nhyd_atmos/Registry
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_nhyd_atmos/Registry 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_nhyd_atmos/Registry 2013-03-29 14:40:23 UTC (rev 2678)
@@ -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.
@@ -113,7 +115,7 @@
var persistent real edgeNormalVectors ( R3 nEdges ) 0 iro edgeNormalVectors mesh - -
var persistent real localVerticalUnitVectors ( R3 nCells ) 0 iro localVerticalUnitVectors mesh - -
-var persistent real cellTangentPlane ( R3 TWO nEdges ) 0 iro cellTangentPlane mesh - -
+var persistent real cellTangentPlane ( R3 TWO nCells ) 0 iro cellTangentPlane mesh - -
var persistent integer cellsOnCell ( maxEdges nCells ) 0 iro cellsOnCell mesh - -
var persistent integer verticesOnCell ( maxEdges nCells ) 0 iro verticesOnCell mesh - -
@@ -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 - -
Copied: branches/ocean_projects/openmp_elements/src/core_nhyd_atmos/Registry.xml (from rev 2677, trunk/mpas/src/core_nhyd_atmos/Registry.xml)
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_nhyd_atmos/Registry.xml (rev 0)
+++ branches/ocean_projects/openmp_elements/src/core_nhyd_atmos/Registry.xml 2013-03-29 14:40:23 UTC (rev 2678)
@@ -0,0 +1,994 @@
+<?xml version="1.0"?>
+<registry>
+
+<!-- **************************************************************************************** -->
+<!-- ************************************** Dimensions ************************************** -->
+<!-- **************************************************************************************** -->
+
+ <dims>
+ <dim name="nCells"/>
+ <dim name="nEdges"/>
+ <dim name="maxEdges"/>
+ <dim name="maxEdges2"/>
+ <dim name="nVertices"/>
+ <dim name="TWO" definition="2"/>
+ <dim name="THREE" definition="3"/>
+ <dim name="vertexDegree"/>
+ <dim name="FIFTEEN" definition="15"/>
+ <dim name="TWENTYONE" definition="21"/>
+ <dim name="R3" definition="3"/>
+ <dim name="nVertLevels"/>
+ <dim name="nVertLevelsP1" definition="nVertLevels+1"/>
+ <dim name="nMonths" definition="namelist:months"/>
+ <dim name="nSoilLevels" definition="namelist:num_soil_layers"/>
+ <dim name="nLags" definition="namelist:input_soil_temperature_lag"/>
+ <dim name="nOznLevels" definition="namelist:noznlev"/>
+ <dim name="nAerLevels" definition="namelist:naerlev"/>
+ <dim name="cam_dim1" definition="namelist:camdim1"/>
+ <dim name="nVertLevelsP2" definition="nVertLevels+2"/>
+ </dims>
+
+
+<!-- **************************************************************************************** -->
+<!-- ************************************** Namelists *************************************** -->
+<!-- **************************************************************************************** -->
+
+ <nml_record name="nhyd_model">
+ <nml_option name="config_time_integration" type="character" default_value="SRK3"/>
+ <nml_option name="config_dt" type="real" default_value="600.0"/>
+ <nml_option name="config_calendar_type" type="character" default_value="gregorian"/>
+ <nml_option name="config_start_time" type="character" default_value="0000-01-01_00:00:00"/>
+ <nml_option name="config_stop_time" type="character" default_value="none"/>
+ <nml_option name="config_run_duration" type="character" default_value="none"/>
+ <nml_option name="config_sfc_update_interval" type="character" default_value="none"/>
+ <nml_option name="config_horiz_mixing" type="character" default_value="2d_smagorinsky"/>
+ <nml_option name="config_h_mom_eddy_visc2" type="real" default_value="0.0"/>
+ <nml_option name="config_h_mom_eddy_visc4" type="real" default_value="0.0"/>
+ <nml_option name="config_v_mom_eddy_visc2" type="real" default_value="0.0"/>
+ <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"/>
+ <nml_option name="config_scalar_adv_order" type="integer" default_value="3"/>
+ <nml_option name="config_u_vadv_order" type="integer" default_value="3"/>
+ <nml_option name="config_w_vadv_order" type="integer" default_value="3"/>
+ <nml_option name="config_theta_vadv_order" type="integer" default_value="3"/>
+ <nml_option name="config_scalar_vadv_order" type="integer" default_value="3"/>
+ <nml_option name="config_coef_3rd_order" type="real" default_value="0.25"/>
+ <nml_option name="config_scalar_advection" type="logical" default_value="true"/>
+ <nml_option name="config_positive_definite" type="logical" default_value="false"/>
+ <nml_option name="config_monotonic" type="logical" default_value="true"/>
+ <nml_option name="config_mix_full" type="logical" default_value="true"/>
+ <nml_option name="config_len_disp" type="real" default_value="120000.0"/>
+ <nml_option name="config_epssm" type="real" default_value="0.1"/>
+ <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="true"/>
+ <nml_option name="config_num_halos" type="integer" default_value="2"/>
+ </nml_record>
+
+ <nml_record name="damping">
+ <nml_option name="config_zd" type="real" default_value="22000.0"/>
+ <nml_option name="config_xnutr" type="real" default_value="0.0"/>
+ </nml_record>
+
+ <nml_record name="io">
+ <nml_option name="config_input_name" type="character" default_value="init.nc"/>
+ <nml_option name="config_sfc_update_name" type="character" default_value="sfc_update.nc"/>
+ <nml_option name="config_output_name" type="character" default_value="output.nc"/>
+ <nml_option name="config_restart_name" type="character" default_value="restart.nc"/>
+ <nml_option name="config_output_interval" type="character" default_value="06:00:00"/>
+ <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_proc_decomp_file_prefix" type="character" default_value="graph.info.part."/>
+ </nml_record>
+
+ <nml_record name="restart">
+ <nml_option name="config_do_restart" type="logical" default_value="false"/>
+ <nml_option name="config_do_DAcycling" type="logical" default_value="false"/>
+ <nml_option name="config_restart_interval" type="character" default_value="none"/>
+ </nml_record>
+
+
+<!-- **************************************************************************************** -->
+<!-- ************************************** Variables *************************************** -->
+<!-- **************************************************************************************** -->
+
+ <var_struct name="mesh" time_levs="0">
+
+ <!-- horizontal grid structure -->
+ <var name="latCell" type="real" dimensions="nCells" streams="iro"/>
+ <var name="lonCell" type="real" dimensions="nCells" streams="iro"/>
+ <var name="xCell" type="real" dimensions="nCells" streams="iro"/>
+ <var name="yCell" type="real" dimensions="nCells" streams="iro"/>
+ <var name="zCell" type="real" dimensions="nCells" streams="iro"/>
+ <var name="indexToCellID" type="integer" dimensions="nCells" streams="iro"/>
+ <var name="latEdge" type="real" dimensions="nEdges" streams="iro"/>
+ <var name="lonEdge" type="real" dimensions="nEdges" streams="iro"/>
+ <var name="xEdge" type="real" dimensions="nEdges" streams="iro"/>
+ <var name="yEdge" type="real" dimensions="nEdges" streams="iro"/>
+ <var name="zEdge" type="real" dimensions="nEdges" streams="iro"/>
+ <var name="indexToEdgeID" type="integer" dimensions="nEdges" streams="iro"/>
+ <var name="latVertex" type="real" dimensions="nVertices" streams="iro"/>
+ <var name="lonVertex" type="real" dimensions="nVertices" streams="iro"/>
+ <var name="xVertex" type="real" dimensions="nVertices" streams="iro"/>
+ <var name="yVertex" type="real" dimensions="nVertices" streams="iro"/>
+ <var name="zVertex" type="real" dimensions="nVertices" streams="iro"/>
+ <var name="indexToVertexID" type="integer" dimensions="nVertices" streams="iro"/>
+ <var name="cellsOnEdge" type="integer" dimensions="TWO nEdges" streams="iro"/>
+ <var name="nEdgesOnCell" type="integer" dimensions="nCells" streams="iro"/>
+ <var name="nEdgesOnEdge" type="integer" dimensions="nEdges" streams="iro"/>
+ <var name="edgesOnCell" type="integer" dimensions="maxEdges nCells" streams="iro"/>
+ <var name="edgesOnEdge" type="integer" dimensions="maxEdges2 nEdges" streams="iro"/>
+ <var name="weightsOnEdge" type="real" dimensions="maxEdges2 nEdges" streams="iro"/>
+ <var name="dvEdge" type="real" dimensions="nEdges" streams="iro"/>
+ <var name="dcEdge" type="real" dimensions="nEdges" streams="iro"/>
+ <var name="angleEdge" type="real" dimensions="nEdges" streams="iro"/>
+ <var name="areaCell" type="real" dimensions="nCells" streams="iro"/>
+ <var name="areaTriangle" type="real" dimensions="nVertices" streams="iro"/>
+ <var name="edgeNormalVectors" type="real" dimensions="R3 nEdges" streams="iro"/>
+ <var name="localVerticalUnitVectors" type="real" dimensions="R3 nCells" streams="iro"/>
+ <var name="cellTangentPlane" type="real" dimensions="R3 TWO nCells" streams="iro"/>
+ <var name="cellsOnCell" type="integer" dimensions="maxEdges nCells" streams="iro"/>
+ <var name="verticesOnCell" type="integer" dimensions="maxEdges nCells" streams="iro"/>
+ <var name="verticesOnEdge" type="integer" dimensions="TWO nEdges" streams="iro"/>
+ <var name="edgesOnVertex" type="integer" dimensions="vertexDegree nVertices" streams="iro"/>
+ <var name="cellsOnVertex" type="integer" dimensions="vertexDegree nVertices" streams="iro"/>
+ <var name="kiteAreasOnVertex" type="real" dimensions="vertexDegree nVertices" streams="iro"/>
+ <var name="fEdge" type="real" dimensions="nEdges" streams="iro"/>
+ <var name="fVertex" type="real" dimensions="nVertices" streams="iro"/>
+ <var name="meshDensity" type="real" dimensions="nCells" streams="iro"/>
+ <var name="meshScalingDel2" type="real" dimensions="nEdges" streams="ro"/>
+ <var name="meshScalingDel4" type="real" dimensions="nEdges" streams="ro"/>
+
+ <!-- coefficients for vertical extrapolation to the surface -->
+ <var name="cf1" type="real" dimensions="" streams="iro"/>
+ <var name="cf2" type="real" dimensions="" streams="iro"/>
+ <var name="cf3" type="real" dimensions="" streams="iro"/>
+
+ <!-- coefficients used by "newpx" horizontal pressure gradient option -->
+ <var name="cpr" type="real" dimensions="THREE nEdges" streams="ro"/>
+ <var name="cpl" type="real" dimensions="THREE nEdges" streams="ro"/>
+
+ <!-- description of the vertical grid structure -->
+ <var name="hx" type="real" dimensions="nVertLevelsP1 nCells" streams="iro"/>
+ <var name="zgrid" type="real" dimensions="nVertLevelsP1 nCells" streams="iro"/>
+ <var name="rdzw" type="real" dimensions="nVertLevels" streams="iro"/>
+ <var name="dzu" type="real" dimensions="nVertLevels" streams="iro"/>
+ <var name="rdzu" type="real" dimensions="nVertLevels" streams="iro"/>
+ <var name="fzm" type="real" dimensions="nVertLevels" streams="iro"/>
+ <var name="fzp" type="real" dimensions="nVertLevels" streams="iro"/>
+ <var name="zx" type="real" dimensions="nVertLevelsP1 nEdges" streams="iro"/>
+ <var name="zz" type="real" dimensions="nVertLevelsP1 nCells" streams="iro"/>
+ <var name="zb" type="real" dimensions="nVertLevelsP1 TWO nEdges" streams="iro"/>
+ <var name="zb3" type="real" dimensions="nVertLevelsP1 TWO nEdges" streams="iro"/>
+ <var name="pzm" type="real" dimensions="nVertLevels nCells" streams="r"/>
+ <var name="pzp" type="real" dimensions="nVertLevels nCells" streams="r"/>
+
+ <!-- W-Rayleigh damping coefficients -->
+ <var name="dss" type="real" dimensions="nVertLevels nCells" streams="iro"/>
+
+ <var name="u_init" type="real" dimensions="nVertLevels" streams="iro"/>
+ <var name="t_init" type="real" dimensions="nVertLevels nCells" streams="iro"/>
+ <var name="qv_init" type="real" dimensions="nVertLevels" streams="iro"/>
+
+ <!-- Space needed for advection -->
+ <var name="deriv_two" type="real" dimensions="FIFTEEN TWO nEdges" streams="ir"/>
+ <var name="advCells" type="integer" dimensions="TWENTYONE nCells" streams="ir"/>
+ <var name="adv_coefs" type="real" dimensions="FIFTEEN nEdges"/>
+ <var name="adv_coefs_3rd" type="real" dimensions="FIFTEEN nEdges"/>
+ <var name="advCellsForEdge" type="integer" dimensions="FIFTEEN nEdges"/>
+ <var name="nAdvCellsForEdge" type="integer" dimensions="nEdges"/>
+
+ <!-- Space needed for deformation calculation weights -->
+ <var name="defc_a" type="real" dimensions="maxEdges nCells" streams="iro"/>
+ <var name="defc_b" type="real" dimensions="maxEdges nCells" streams="iro"/>
+
+ <!-- Arrays required for reconstruction of velocity field -->
+ <var name="coeffs_reconstruct" type="real" dimensions="R3 maxEdges nCells" streams="iro"/>
+ <var name="east" type="real" dimensions="R3 nCells" streams="r"/>
+ <var name="north" type="real" dimensions="R3 nCells" streams="r"/>
+
+ <!-- Arrays needed only in the CAM LW and SW radiation codes: Ozone -->
+ <var name="pin" type="real" dimensions="nOznLevels nCells"/>
+ <var name="ozmixm" type="real" dimensions="nMonths nOznLevels nCells"/>
+
+ <!-- Arrays needed only in the CAM LW and SW radiation codes: Aerosols -->
+ <var name="m_hybi" type="real" dimensions="nAerLevels nCells"/>
+ </var_struct>
+
+ <var_struct name="state" time_levs="2">
+
+ <var name="xtime" type="text" dimensions="Time" streams="iro"/>
+
+ <!-- Prognostic variables: read from input, saved in restart, and written to output -->
+ <var name="u" type="real" dimensions="nVertLevels nEdges Time" streams="iro"/>
+ <var name="w" type="real" dimensions="nVertLevelsP1 nCells Time" streams="iro"/>
+ <var name="rho_zz" type="real" dimensions="nVertLevels nCells Time" streams="r"/>
+ <var name="theta_m" type="real" dimensions="nVertLevels nCells Time" streams="r"/>
+ <var name="m_ps" type="real" dimensions="nCells Time"/>
+ <var_array name="scalars" type="real" dimensions="nVertLevels nCells Time">
+ <var name="qv" array_group="moist" streams="iro"/>
+ <var name="qc" array_group="moist" streams="iro"/>
+ <var name="qr" array_group="moist" streams="iro"/>
+ <var name="qi" array_group="moist" streams="iro"/>
+ <var name="qs" array_group="moist" streams="iro"/>
+ <var name="qg" array_group="moist" streams="iro"/>
+ <var name="qnr" array_group="number" streams="iro"/>
+ <var name="qni" array_group="number" streams="iro"/>
+ </var_array>
+
+ <var_array name="aerosols" type="real" dimensions="nAerLevels nCells Time">
+ <var name="sul" array_group="aer_cam"/>
+ <var name="sslt" array_group="aer_cam"/>
+ <var name="dust1" array_group="aer_cam"/>
+ <var name="dust2" array_group="aer_cam"/>
+ <var name="dust3" array_group="aer_cam"/>
+ <var name="dust4" array_group="aer_cam"/>
+ <var name="ocpho" array_group="aer_cam"/>
+ <var name="bcpho" array_group="aer_cam"/>
+ <var name="ocphi" array_group="aer_cam"/>
+ <var name="bcphi" array_group="aer_cam"/>
+ <var name="bg" array_group="aer_cam"/>
+ <var name="volc" array_group="aer_cam"/>
+ </var_array>
+ </var_struct>
+
+ <var_struct name="diag" time_levs="1">
+
+ <!-- coefficients for the vertical tridiagonal solve -->
+ <!-- Note: these could be local but... -->
+ <var name="cofrz" type="real" dimensions="nVertLevels Time"/>
+ <var name="cofwr" type="real" dimensions="nVertLevels nCells Time"/>
+ <var name="cofwz" type="real" dimensions="nVertLevels nCells Time"/>
+ <var name="coftz" type="real" dimensions="nVertLevelsP1 nCells Time"/>
+ <var name="cofwt" type="real" dimensions="nVertLevels nCells Time"/>
+ <var name="a_tri" type="real" dimensions="nVertLevels nCells Time"/>
+ <var name="alpha_tri" type="real" dimensions="nVertLevels nCells Time"/>
+ <var name="gamma_tri" type="real" dimensions="nVertLevels nCells Time"/>
+
+ <!-- state variables diagnosed from prognostic state -->
+ <var name="pressure_p" type="real" dimensions="nVertLevels nCells Time" streams="ro"/>
+
+ <!-- Diagnostic fields: only written to output -->
+ <!-- NOTE: added the "r" option to rho,theta,uReconstructZonal,and uReconstructMeridional for use of the -->
+ <!-- non-hydrostatic dynamical core in a data assimilation framework. NOTE that the "r" option is not -->
+ <!-- needed for those 4 variables to get bit for bit restart capabilities, otherwise. -->
+ <var name="rho" type="real" dimensions="nVertLevels nCells Time" streams="iro"/>
+ <var name="theta" type="real" dimensions="nVertLevels nCells Time" streams="iro"/>
+ <var name="rh" type="real" dimensions="nVertLevels nCells Time" streams="iro"/>
+ <var name="v" type="real" dimensions="nVertLevels nEdges Time" streams="o"/>
+ <var name="divergence" type="real" dimensions="nVertLevels nCells Time" streams="o"/>
+ <var name="vorticity" type="real" dimensions="nVertLevels nVertices Time" streams="o"/>
+ <var name="pv_edge" type="real" dimensions="nVertLevels nEdges Time" streams="o"/>
+ <var name="rho_edge" type="real" dimensions="nVertLevels nEdges Time" streams="o"/>
+ <var name="ke" type="real" dimensions="nVertLevels nCells Time" streams="o"/>
+ <var name="pv_vertex" type="real" dimensions="nVertLevels nVertices Time" streams="o"/>
+ <var name="pv_cell" type="real" dimensions="nVertLevels nCells Time" streams="o"/>
+
+ <!-- reconstructed horizontal velocity vectors at cell centers -->
+ <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"/>
+ <var name="uReconstructZonal" type="real" dimensions="nVertLevels nCells Time" streams="ro"/>
+ <var name="uReconstructMeridional" type="real" dimensions="nVertLevels nCells Time" streams="ro"/>
+
+ <!-- Other diagnostic variables -->
+ <var name="rv" type="real" dimensions="nVertLevels nEdges Time" streams="r"/>
+ <var name="circulation" type="real" dimensions="nVertLevels nVertices Time" streams="r"/>
+ <var name="gradPVt" type="real" dimensions="nVertLevels nEdges Time"/>
+ <var name="gradPVn" type="real" dimensions="nVertLevels nEdges Time"/>
+ <var name="h_divergence" type="real" dimensions="nVertLevels nCells Time" streams="o"/>
+
+ <var name="exner" type="real" dimensions="nVertLevels nCells Time" streams="ro"/>
+ <var name="exner_base" type="real" dimensions="nVertLevels nCells Time" streams="iro"/>
+ <var name="rtheta_base" type="real" dimensions="nVertLevels nCells Time" streams="r"/>
+ <var name="pressure_base" type="real" dimensions="nVertLevels nCells Time" streams="iro"/>
+ <var name="rho_base" type="real" dimensions="nVertLevels nCells Time" streams="iro"/>
+ <var name="theta_base" type="real" dimensions="nVertLevels nCells Time" streams="iro"/>
+
+ <var name="ruAvg" type="real" dimensions="nVertLevels nEdges Time"/>
+ <var name="wwAvg" type="real" dimensions="nVertLevelsP1 nCells Time"/>
+ <var name="cqu" type="real" dimensions="nVertLevels nEdges Time"/>
+ <var name="cqw" type="real" dimensions="nVertLevels nCells Time"/>
+
+ <!-- coupled variables needed by solver, but not output -->
+ <var name="ru" type="real" dimensions="nVertLevels nEdges Time" streams="r"/>
+ <var name="ru_p" type="real" dimensions="nVertLevels nEdges Time" streams="r"/>
+ <var name="ru_save" type="real" dimensions="nVertLevels nEdges Time"/>
+
+ <var name="rw" type="real" dimensions="nVertLevelsP1 nCells Time" streams="r"/>
+ <var name="rw_p" type="real" dimensions="nVertLevelsP1 nCells Time" streams="r"/>
+ <var name="rw_save" type="real" dimensions="nVertLevelsP1 nCells Time"/>
+
+ <var name="rtheta_p" type="real" dimensions="nVertLevels nCells Time" streams="r"/>
+ <var name="rtheta_pp" type="real" dimensions="nVertLevels nCells Time"/>
+ <var name="rtheta_p_save" type="real" dimensions="nVertLevels nCells Time"/>
+ <var name="rtheta_pp_old" type="real" dimensions="nVertLevels nCells Time"/>
+
+ <var name="rho_p" type="real" dimensions="nVertLevels nCells Time" streams="r"/>
+ <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" streams="o"/>
+
+ <var name="surface_pressure" type="real" dimensions="nCells Time" streams="iro"/>
+
+ <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">
+
+
+ <!-- tendencies for prognostic variables -->
+ <var name="tend_u" name_in_code="u" type="real" dimensions="nVertLevels nEdges Time" streams="o"/>
+ <var name="tend_w" name_in_code="w" type="real" dimensions="nVertLevelsP1 nCells Time" streams="o"/>
+ <var name="tend_rho" name_in_code="rho_zz" type="real" dimensions="nVertLevels nCells Time" streams="o"/>
+ <var name="tend_theta" name_in_code="theta_m" type="real" dimensions="nVertLevels nCells Time" streams="o"/>
+ <var name="rt_diabatic_tend" type="real" dimensions="nVertLevels nCells Time" streams="r"/>
+ <var name="euler_tend_u" name_in_code="u_euler" type="real" dimensions="nVertLevels nEdges Time"/>
+ <var name="euler_tend_w" name_in_code="w_euler" type="real" dimensions="nVertLevelsP1 nCells Time"/>
+ <var name="euler_tend_theta" name_in_code="theta_euler" type="real" dimensions="nVertLevels nCells Time"/>
+
+ <!-- scalar tendencies -->
+ <var_array name="scalars" type="real" dimensions="nVertLevels nCells Time">
+ <var name="tend_qv" name_in_code="qv" array_group="moist" streams="o"/>
+ <var name="tend_qc" name_in_code="qc" array_group="moist" streams="o"/>
+ <var name="tend_qr" name_in_code="qr" array_group="moist" streams="o"/>
+ <var name="tend_qi" name_in_code="qi" array_group="moist" streams="o"/>
+ <var name="tend_qs" name_in_code="qs" array_group="moist" streams="o"/>
+ <var name="tend_qg" name_in_code="qg" array_group="moist" streams="o"/>
+ <var name="tend_qnr" name_in_code="qnr" array_group="number" streams="o"/>
+ <var name="tend_qni" name_in_code="qni" array_group="number" streams="o"/>
+ </var_array>
+ </var_struct>
+
+
+
+<!-- ================================================================================================== -->
+<!-- DECLARATIONS OF ALL PHYSICS VARIABLES (will need to be moved to a Physics Registry shared by the -->
+<!-- hydrostatic and non-hydrostatic dynamical cores): -->
+<!-- ================================================================================================== -->
+
+
+ <nml_record name="physics">
+ <!-- NAMELIST VARIABLES ADDED FOR INITIALIZATION OF SURFACE CHARACTERISTICS: -->
+ <nml_option name="input_landuse_data" type="character" default_value="USGS"/>
+ <nml_option name="input_soil_data" type="character" default_value="STAS"/>
+ <nml_option name="input_soil_temperature_lag" type="integer" default_value="140"/>
+ <nml_option name="num_soil_layers" type="integer" default_value="4"/>
+ <nml_option name="months" type="integer" default_value="12"/>
+
+ <!-- ... DIMENSION NEEDED FOR OZONE AND AEROSOLS CONCENTRATIONS IN THE CAM LONGWAVE AND SHORTWAVE -->
+ <!-- ... RADIATION PARAMETERIZATIONS. -->
+ <nml_option name="noznlev" type="integer" default_value="59"/>
+ <nml_option name="naerlev" type="integer" default_value="29"/>
+ <nml_option name="camdim1" type="integer" default_value="4"/>
+
+ <!-- NAMELIST VARIABLES ADDED FOR PHYSICS CONFIGURATION: -->
+ <nml_option name="config_frac_seaice" type="logical" default_value="false"/>
+ <nml_option name="config_sfc_albedo" type="logical" default_value="false"/>
+ <nml_option name="config_sfc_snowalbedo" type="logical" default_value="false"/>
+ <nml_option name="config_sst_update" type="logical" default_value="false"/>
+ <nml_option name="config_sstdiurn_update" type="logical" default_value="false"/>
+ <nml_option name="config_deepsoiltemp_update" type="logical" default_value="false"/>
+
+ <nml_option name="config_n_physics" type="integer" default_value="1"/>
+ <nml_option name="config_n_microp" type="integer" default_value="1"/>
+ <nml_option name="config_n_conv" type="integer" default_value="1"/>
+ <nml_option name="config_n_pbl" type="integer" default_value="1"/>
+ <nml_option name="config_n_lsm" type="integer" default_value="1"/>
+ <nml_option name="config_n_eddy" type="integer" default_value="1"/>
+ <nml_option name="config_n_radt_lw" type="integer" default_value="1"/>
+ <nml_option name="config_n_radt_sw" type="integer" default_value="1"/>
+
+ <nml_option name="config_radtlw_interval" type="character" default_value="none"/>
+ <nml_option name="config_radtsw_interval" type="character" default_value="none"/>
+ <nml_option name="config_conv_interval" type="character" default_value="none"/>
+ <nml_option name="config_pbl_interval" type="character" default_value="none"/>
+ <nml_option name="config_camrad_abs_update" type="character" default_value="06:00:00"/>
+ <nml_option name="config_greeness_update" type="character" default_value="24:00:00"/>
+ <nml_option name="config_bucket_update" type="character" default_value="none"/>
+
+ <nml_option name="config_microp_scheme" type="character" default_value="off"/>
+ <nml_option name="config_conv_shallow_scheme" type="character" default_value="off"/>
+ <nml_option name="config_conv_deep_scheme" type="character" default_value="off"/>
+ <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"/>
+ <nml_option name="config_sfclayer_scheme" type="character" default_value="off"/>
+
+ <nml_option name="config_bucket_radt" type="real" default_value="0.0_RKIND"/>
+ <nml_option name="config_bucket_rainc" type="real" default_value="0.0_RKIND"/>
+ <nml_option name="config_bucket_rainnc" type="real" default_value="0.0_RKIND"/>
+ </nml_record>
+
+ <var_struct name="diag_physics" time_levs="1">
+
+ <!-- ================================================================================================= -->
+ <!-- ... ARRAYS AND VARIABLES FOR UPDATING THE DEEP SOIL TEMPERATURE: -->
+ <!-- ================================================================================================= -->
+ <!-- nsteps_accum: number of accumulated time-step in a day. -->
+ <!-- ndays_accum : number of accumulated days in a year. -->
+ <!-- tlag : daily mean surface temperature of prior days [K] -->
+ <!-- tday_accum : accumulated daily surface temperature for current day [K] -->
+ <!-- tyear_mean : annual mean surface temperature [K] -->
+ <!-- tyear_accum : accumulated yearly surface temperature for current year [K] -->
+
+ <var name="nsteps_accum" type="real" dimensions="nCells Time" streams="r"/>
+ <var name="ndays_accum" type="real" dimensions="nCells Time" streams="r"/>
+
+ <var name="tlag" type="real" dimensions="nLags nCells Time" streams="r"/>
+ <var name="tday_accum" type="real" dimensions="nCells Time" streams="r"/>
+ <var name="tyear_mean" type="real" dimensions="nCells Time" streams="r"/>
+ <var name="tyear_accum" type="real" dimensions="nCells Time" streams="r"/>
+
+
+ <!-- ================================================================================================== -->
+ <!-- ... PARAMETERIZATION OF CLOUD MICROPHYSICS: -->
+ <!-- ================================================================================================== -->
+ <!-- i_rainnc : counter related to how often rainnc is being reset relative to its bucket value (-) -->
+ <!-- rainnc : accumulated total time-step grid-scale precipitation (mm) -->
+ <!-- rainncv : time-step total grid-scale precipitation (mm) -->
+ <!-- snownc : accumulated grid-scale precipitation of snow (mm) -->
+ <!-- snowncv : time-step grid-scale precipitation of snow (mm) -->
+ <!-- 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"/>
+ <var name="snowncv" type="real" dimensions="nCells Time" streams="o"/>
+ <var name="graupelncv" type="real" dimensions="nCells Time" streams="o"/>
+
+ <var name="rainnc" type="real" dimensions="nCells Time" streams="ro"/>
+ <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"/>
+
+ <!-- ================================================================================================== -->
+ <!-- ... PARAMETERIZATION OF CONVECTION: -->
+ <!-- ================================================================================================== -->
+ <!-- i_rainc : counter related to how often rainc is begin reset relative to its bucket value (-) -->
+ <!-- cuprec : convective precipitation rate (mm/s) -->
+ <!-- rainc : accumulated time-step convective precipitation (mm) -->
+ <!-- raincv : time-step convective precipitation (mm) -->
+
+ <var name="i_rainc" type="integer" dimensions="nCells Time" streams="ro"/>
+ <var name="cuprec" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="rainc" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="raincv" type="real" dimensions="nCells Time" streams="ro"/>
+
+ <!-- ... KAIN_FRITSCH: -->
+ <!-- cubot : lowest level of convection (-) -->
+ <!-- cutop : highest level of convection (-) -->
+ <!-- nca : relaxation time for KF parameterization of convection (s) -->
+ <!-- wavg0 : average vertical velocity (KF scheme only) (m s-1) -->
+
+ <var name="nca" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="cubot" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="cutop" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="w0avg" type="real" dimensions="nVertLevels nCells Time" streams="ro"/>
+
+
+ <!-- ================================================================================================== -->
+ <!-- ... PARAMETERIZATION OF PLANETARY BOUNDARY LAYER PROCESSES: -->
+ <!-- ================================================================================================== -->
+ <!-- kpbl : index of PBL top (-) -->
+ <!-- hpbl : PBL height (m) -->
+ <!-- exch_h : exchange coefficient (-) -->
+
+ <var name="kpbl" type="integer" dimensions="nCells Time" streams="ro"/>
+ <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: -->
+ <!-- ================================================================================================== -->
+ <!-- br :bulk richardson number [-] -->
+ <!-- cd :drag coefficient at 10m [-] -->
+ <!-- cda :drag coefficient at lowest model level [-] -->
+ <!-- chs :??? -->
+ <!-- chs2 :??? -->
+ <!-- cqs2 :??? -->
+ <!-- ck :enthalpy exchange coefficient at 10 m [-] -->
+ <!-- cka :enthalpy exchange coefficient at lowest model level [-] -->
+ <!-- cpm :??? -->
+ <!-- flhc :exchange coefficient for heat [-] -->
+ <!-- flqc :exchange coefficient for moisture [-] -->
+ <!-- gz1oz0 :log of z1 over z0 [-] -->
+ <!-- hfx :upward heat flux at the surface [W/m2/s] -->
+ <!-- lh :latent heat flux at the surface [W/m2] -->
+ <!-- mavail :surface moisture availability [-] -->
+ <!-- mol :T* in similarity theory [K] -->
+ <!-- psih :similarity theory for heat [-] -->
+ <!-- psim :similarity theory for momentum [-] -->
+ <!-- qfx :upward moisture flux at the surface [kg/m2/s] -->
+ <!-- qgh :??? -->
+ <!-- qsfc :specific humidity at lower boundary [kg/kg] -->
+ <!-- regime :flag indicating PBL regime (stable_p,unstable_p,etc...) [-] -->
+ <!-- rmol :1 / Monin Ob length [-] -->
+ <!-- ust :u* in similarity theory [m/s] -->
+ <!-- ustm :u* in similarity theory without vconv [m/s] -->
+ <!-- zol :z/L height over Monin-Obukhov length [-] -->
+ <!-- znt :time-varying roughness length [m] -->
+ <!-- wspd :wind speed [m/s] -->
+ <!-- DIAGNOSTICS: -->
+ <!-- q2 :specific humidity at 2m [kg/kg] -->
+ <!-- u10 :u at 10 m [m/s] -->
+ <!-- v10 :v at 10 m [m/s] -->
+ <!-- t2m :temperature at 2m [K] -->
+ <!-- th2m :potential temperature at 2m [K] -->
+ <var name="hfx" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="mavail" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="mol" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="qfx" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="qsfc" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="ust" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="ustm" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="zol" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="znt" type="real" dimensions="nCells Time" streams="ro"/>
+
+ <var name="br" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="cd" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="cda" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="chs" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="chs2" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="cqs2" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="ck" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="cka" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="cpm" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="flhc" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="flqc" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="gz1oz0" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="lh" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="psim" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="psih" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="qgh" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="regime" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="rmol" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="wspd" type="real" dimensions="nCells Time" streams="ro"/>
+
+ <!-- DIAGNOSTICS: -->
+ <var name="u10" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="v10" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="q2" type="real" dimensions="nCells Time" streams="ro"/>
+ <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 [-] -->
+ <!-- gsw :net shortwave flux at surface [W m-2] -->
+ <!-- swcf :shortwave cloud forcing at top-of-atmosphere [W m-2] -->
+ <!-- swdnb :all-sky downwelling shortwave flux at bottom-of-atmosphere [W m-2] -->
+ <!-- swdnbc :clear-sky downwelling shortwave flux at bottom-of-atmosphere [W m-2] -->
+ <!-- swdnt :all-sky downwelling shortwave flux at top-of-atmosphere [W m-2] -->
+ <!-- swdntc :clear-sky downwelling shortwave flux at top-of-atmosphere [W m-2] -->
+ <!-- swupb :all-sky upwelling shortwave flux at bottom-of-atmosphere [W m-2] -->
+ <!-- swupbc :clear-sky upwelling shortwave flux at bottom-of-atmosphere [W m-2] -->
+ <!-- swupt :all-sky upwelling shortwave flux at top-of-atmosphere [W m-2] -->
+ <!-- swuptc :clear-sky upwelling shortwave flux at top-of-atmosphere [W m-2] -->
+ <!-- acswdnb :accumulated all-sky downwelling shortwave flux at bottom-of-atmosphere [J m-2] -->
+ <!-- acswdnbc :accumulated clear-sky downwelling shortwave flux at bottom-of-atmosphere [J m-2] -->
+ <!-- acswdnt :accumulated all-sky downwelling shortwave flux at top-of-atmosphere [J m-2] -->
+ <!-- acswdntc :accumulated clear-sky downwelling shortwave flux at top-of-atmosphere [J m-2] -->
+ <!-- acswupb :accumulated all-sky upwelling shortwave flux at bottom-of-atmosphere [J m-2] -->
+ <!-- acswupbc :accumulated clear-sky upwelling shortwave flux at bottom-of-atmosphere [J m-2] -->
+ <!-- acswupt :accumulated all-sky upwelling shortwave flux at top-of-atmosphere [J m-2] -->
+ <!-- acswuptc :accumulated clear-sky upwelling shortwave flux at top-of-atmosphere [J m-2] -->
+ <!-- swdnflx : -->
+ <!-- swdnflxc : -->
+ <!-- swupflx : -->
+ <!-- swupflxc : -->
+
+ <!-- i_acswdnb : counter related to how often swdnb is begin reset relative to its bucket value (-) -->
+ <!-- i_acswdnbc: counter related to how often swdnbc is begin reset relative to its bucket value (-) -->
+ <!-- i_acswdnt : counter related to how often swdnt is begin reset relative to its bucket value (-) -->
+ <!-- i_acswdntc: counter related to how often swdntc is begin reset relative to its bucket value (-) -->
+ <!-- i_acswupb : counter related to how often swupb is begin reset relative to its bucket value (-) -->
+ <!-- i_acswupbc: counter related to how often swupbc is begin reset relative to its bucket value (-) -->
+ <!-- i_acswupt : counter related to how often swupt is begin reset relative to its bucket value (-) -->
+ <!-- i_acswuptc: counter related to how often swuptc is begin reset relative to its bucket value (-) -->
+
+ <var name="i_acswdnb" type="integer" dimensions="nCells Time" streams="ro"/>
+ <var name="i_acswdnbc" type="integer" dimensions="nCells Time" streams="ro"/>
+ <var name="i_acswdnt" type="integer" dimensions="nCells Time" streams="ro"/>
+ <var name="i_acswdntc" type="integer" dimensions="nCells Time" streams="ro"/>
+ <var name="i_acswupb" type="integer" dimensions="nCells Time" streams="ro"/>
+ <var name="i_acswupbc" type="integer" dimensions="nCells Time" streams="ro"/>
+ <var name="i_acswupt" type="integer" dimensions="nCells Time" streams="ro"/>
+ <var name="i_acswuptc" type="integer" dimensions="nCells Time" streams="ro"/>
+
+ <var name="coszr" type="real" dimensions="nCells Time" streams="o"/>
+ <var name="swcf" type="real" dimensions="nCells Time" streams="o"/>
+ <var name="swdnb" type="real" dimensions="nCells Time" streams="o"/>
+ <var name="swdnbc" type="real" dimensions="nCells Time" streams="o"/>
+ <var name="swdnt" type="real" dimensions="nCells Time" streams="o"/>
+ <var name="swdntc" type="real" dimensions="nCells Time" streams="o"/>
+ <var name="swupb" type="real" dimensions="nCells Time" streams="o"/>
+ <var name="swupbc" type="real" dimensions="nCells Time" streams="o"/>
+ <var name="swupt" type="real" dimensions="nCells Time" streams="o"/>
+ <var name="swuptc" type="real" dimensions="nCells Time" streams="o"/>
+ <var name="acswdnb" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="acswdnbc" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="acswdnt" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="acswdntc" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="acswupb" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="acswupbc" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="acswupt" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="acswuptc" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="gsw" type="real" dimensions="nCells Time" streams="ro"/>
+
+ <!-- RRTMG SW ONLY: -->
+ <var name="swdnflx" type="real" dimensions="nVertLevelsP2 nCells Time" streams="o"/>
+ <var name="swdnflxc" type="real" dimensions="nVertLevelsP2 nCells Time" streams="o"/>
+ <var name="swupflx" type="real" dimensions="nVertLevelsP2 nCells Time" streams="o"/>
+ <var name="swupflxc" type="real" dimensions="nVertLevelsP2 nCells Time" streams="o"/>
+
+
+ <!-- ================================================================================================== -->
+ <!-- ... PARAMETERIZATION OF LONGWAVE RADIATION: -->
+ <!-- ================================================================================================== -->
+
+ <!-- note: glw is the same diagnostic as lwdnb and is used in the land-surface scheme for the calcula- -->
+ <!-- tion of the surface budget. glw is always an output argument to the subroutine rrtmg_lwrad. -->
+ <!-- in contrast,lwdnb is an optional ouput argument to the subroutine rrtmg_lwrad depending on -->
+ <!-- the presence of lwupt (or not). -->
+
+ <!-- glw :all-sky downwelling longwave flux at bottom-of-atmosphere [W m-2] -->
+ <!-- lwcf :longwave cloud forcing at top-of-atmosphere [W m-2] -->
+ <!-- lwdnb :all-sky downwelling longwave flux at bottom-of-atmosphere [W m-2] -->
+ <!-- lwdnbc :clear-sky downwelling longwave flux at bottom-of-atmosphere [W m-2] -->
+ <!-- lwdnt :all-sky downwelling longwave flux at top-of-atmosphere [W m-2] -->
+ <!-- lwdntc :clear-sky downwelling longwave flux at top-of-atmosphere [W m-2] -->
+ <!-- lwupb :all-sky upwelling longwave flux at bottom-of-atmosphere [W m-2] -->
+ <!-- lwupbc :clear-sky upwelling longwave flux at bottom-of-atmosphere [W m-2] -->
+ <!-- lwupt :all-sky upwelling longwave flux at top-of-atmosphere [W m-2] -->
+ <!-- lwuptc :clear-sky upwelling longwave flux at top-of-atmosphere [W m-2] -->
+ <!-- aclwdnb :accumulated all-sky downwelling longwave flux at bottom-of-atmosphere [J m-2] -->
+ <!-- aclwdnbc :accumulated clear-sky downwelling longwave flux at bottom-of-atmosphere [J m-2] -->
+ <!-- aclwdnt :accumulated all-sky downwelling longwave flux at top-of-atmosphere [J m-2] -->
+ <!-- aclwdntc :accumulated clear-sky downwelling longwave flux at top-of-atmosphere [J m-2] -->
+ <!-- aclwupb :accumulated all-sky upwelling longwave flux at bottom-of-atmosphere [J m-2] -->
+ <!-- aclwupbc :accumulated clear-sky upwelling longwave flux at bottom-of-atmosphere [J m-2] -->
+ <!-- aclwupt :accumulated all-sky upwelling longwave flux at top-of-atmosphere [J m-2] -->
+ <!-- aclwuptc :accumulated clear-sky upwelling longwave flux at top-of-atmosphere [J m-2] -->
+ <!-- lwdnflx : -->
+ <!-- lwdnflxc : -->
+ <!-- lwupflx : -->
+ <!-- lwupflxc : -->
+ <!-- olrtoa :outgoing longwave radiation at top-of-the-atmosphere [W m-2] -->
+
+ <!-- i_aclwdnb : counter related to how often lwdnb is begin reset relative to its bucket value (-) -->
+ <!-- i_aclwdnbc: counter related to how often lwdnbc is begin reset relative to its bucket value (-) -->
+ <!-- i_aclwdnt : counter related to how often lwdnt is begin reset relative to its bucket value (-) -->
+ <!-- i_aclwdntc: counter related to how often lwdntc is begin reset relative to its bucket value (-) -->
+ <!-- i_aclwupb : counter related to how often lwupb is begin reset relative to its bucket value (-) -->
+ <!-- i_aclwupbc: counter related to how often lwupbc is begin reset relative to its bucket value (-) -->
+ <!-- i_aclwupt : counter related to how often lwupt is begin reset relative to its bucket value (-) -->
+ <!-- i_aclwuptc: counter related to how often lwuptc is begin reset relative to its bucket value (-) -->
+
+ <var name="i_aclwdnb" type="integer" dimensions="nCells Time" streams="ro"/>
+ <var name="i_aclwdnbc" type="integer" dimensions="nCells Time" streams="ro"/>
+ <var name="i_aclwdnt" type="integer" dimensions="nCells Time" streams="ro"/>
+ <var name="i_aclwdntc" type="integer" dimensions="nCells Time" streams="ro"/>
+ <var name="i_aclwupb" type="integer" dimensions="nCells Time" streams="ro"/>
+ <var name="i_aclwupbc" type="integer" dimensions="nCells Time" streams="ro"/>
+ <var name="i_aclwupt" type="integer" dimensions="nCells Time" streams="ro"/>
+ <var name="i_aclwuptc" type="integer" dimensions="nCells Time" streams="ro"/>
+
+ <var name="lwcf" type="real" dimensions="nCells Time" streams="o"/>
+ <var name="lwdnb" type="real" dimensions="nCells Time" streams="o"/>
+ <var name="lwdnbc" type="real" dimensions="nCells Time" streams="o"/>
+ <var name="lwdnt" type="real" dimensions="nCells Time" streams="o"/>
+ <var name="lwdntc" type="real" dimensions="nCells Time" streams="o"/>
+ <var name="lwupb" type="real" dimensions="nCells Time" streams="o"/>
+ <var name="lwupbc" type="real" dimensions="nCells Time" streams="o"/>
+ <var name="lwupt" type="real" dimensions="nCells Time" streams="o"/>
+ <var name="lwuptc" type="real" dimensions="nCells Time" streams="o"/>
+ <var name="aclwdnb" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="aclwdnbc" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="aclwdnt" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="aclwdntc" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="aclwupb" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="aclwupbc" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="aclwupt" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="aclwuptc" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="olrtoa" type="real" dimensions="nCells Time" streams="o"/>
+ <var name="glw" type="real" dimensions="nCells Time" streams="ro"/>
+
+ <!-- ... RRTMG LW ONLY: -->
+ <!-- var name="lwdnflx" type="real" dimensions="nVertLevelsP2 nCells Time" streams="o" -->
+ <!-- var name="lwdnflxc" type="real" dimensions="nVertLevelsP2 nCells Time" streams="o" -->
+ <!-- var name="lwupflx" type="real" dimensions="nVertLevelsP2 nCells Time" streams="o" -->
+ <!-- var name="lwupflxc" type="real" dimensions="nVertLevelsP2 nCells Time" streams="o" -->
+
+
+ <!-- ================================================================================================== -->
+ <!-- ... ADDITIONAL "RADIATION" ARRAYS NEEDED ONLY IN THE "CAM" LW AND SW RADIATION CODES: -->
+ <!-- ================================================================================================== -->
+
+ <!-- INFRARED ABSORPTION: -->
+ <var name="absnxt" type="real" dimensions="nVertLevels cam_dim1 nCells Time"/>
+ <var name="abstot" type="real" dimensions="nVertLevelsP1 nVertLevelsP1 nCells Time"/>
+ <var name="emstot" type="real" dimensions="nVertLevelsP1 nCells Time"/>
+
+
+ <!-- ================================================================================================== -->
+ <!-- ... PARAMERIZATION OF CLOUDINESS: -->
+ <!-- ================================================================================================== -->
+ <var name="cldfrac" type="real" dimensions="nVertLevels nCells Time" streams="o"/>
+
+
+ <!-- ================================================================================================== -->
+ <!-- ... PARAMETERIZATION OF LAND-SURFACE SCHEME: -->
+ <!-- ================================================================================================== -->
+
+ <!-- acsnom :accumulated melted snow [kg m-2] -->
+ <!-- acsnow :accumulated snow [kg m-2] -->
+ <!-- canwat :canopy water [kg m-2] -->
+ <!-- chklowq :surface saturation flag [-] -->
+ <!-- grdflx :ground heat flux [W m-2] -->
+ <!-- lai :leaf area index [-] -->
+ <!-- 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] -->
+ <!-- sfc_albedo :surface albedo [-] -->
+ <!-- sfc_embck :background emissivity [-] -->
+ <!-- sfc_emiss :surface emissivity [-] -->
+ <!-- sfcrunoff :surface runoff [m s-1] -->
+ <!-- smstav :moisture availability [-] -->
+ <!-- smstot :total moisture [m3 m-3] -->
+ <!-- snopcx :snow phase change heat flux [W m-2] -->
+ <!-- snotime :?? -->
+ <!-- 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 [-] -->
+ <!-- z0 :background roughness length [m] -->
+ <!-- zs :depth of centers of soil layers [m] -->
+
+ <var name="acsnom" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="acsnow" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="canwat" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="chklowq" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="grdflx" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="lai" type="real" dimensions="nCells Time" streams="ro"/>
+ <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="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"/>
+ <var name="sfcrunoff" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="smstav" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="smstot" type="real" dimensions="nCells Time" streams="ro"/>
+ <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_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"/>
+ <var name="z0" type="real" dimensions="nCells Time" streams="ro"/>
+ <var name="zs" type="real" dimensions="nCells Time" streams="ro"/>
+ </var_struct>
+
+ <var_struct name="tend_physics" time_levs="1">
+
+ <!-- ================================================================================================== -->
+ <!-- TENDENCIES FROM PARAMETERIZATION OF CONVECTION: -->
+ <!-- ================================================================================================== -->
+ <!-- rthcuten : tendency of potential temperature due to cumulus convection (K s-1) -->
+ <!-- rqvcuten : tendency of water vapor mixing ratio due to cumulus convection (kg/kg s-1) -->
+ <!-- rqccuten : tendency of cloud water mixing ratio due to cumulus convection (kg/kg s-1) -->
+ <!-- rqicuten : tendency of cloud ice mixing ratio due to cumulus convection (kg/kg s-1) -->
+
+ <var name="rthcuten" type="real" dimensions="nVertLevels nCells Time" streams="ro"/>
+ <var name="rqvcuten" type="real" dimensions="nVertLevels nCells Time" streams="ro"/>
+ <var name="rqccuten" type="real" dimensions="nVertLevels nCells Time" streams="ro"/>
+ <var name="rqicuten" type="real" dimensions="nVertLevels nCells Time" streams="ro"/>
+
+ <!-- KAIN_FRITSCH -->
+ <!-- rqrcuten : tendency of rain mixing ratio due to cumulus convection (kg/kg s-1) -->
+ <!-- rqscuten : tendency of snow mixing ratio due to cumulus convection (kg/kg s-1) -->
+
+ <var name="rqrcuten" type="real" dimensions="nVertLevels nCells Time" streams="ro"/>
+ <var name="rqscuten" type="real" dimensions="nVertLevels nCells Time" streams="ro"/>
+
+ <!-- TIEDTKE -->
+ <!-- rucuten : tendency of zonal wind due to cumulus convection (m/s-1) -->
+ <!-- rvcuten : tendency of meridional wind due to cumulus convection (m/s-1) -->
+ <!-- rqvdynten : tendency of water vapor due to horizontal and vertical advections (kg/kg/s-1) -->
+ <var name="rqvdynten" type="real" dimensions="nVertLevels nCells Time" streams="ro"/>
+ <var name="rucuten" type="real" dimensions="nVertLevels nCells Time" streams="ro"/>
+ <var name="rvcuten" type="real" dimensions="nVertLevels nCells Time" streams="ro"/>
+
+
+ <!-- ================================================================================================== -->
+ <!-- ... TENDENCIES FROM PARAMETERIZATION OF PLANETARY BOUNDARY LAYER PROCESSES: -->
+ <!-- ================================================================================================== -->
+ <!-- rublten : tendency of zonal wind due to pbl processes (m s-1) -->
+ <!-- rvblten : tendency of meridional wind due to pbl processes (m s-1) -->
+ <!-- rthblten : tendency of potential temperature due to pbl processes (K s-1) -->
+ <!-- rqvblten : tendency of water vapor mixing ratio due to pbl processes (kg/kg s-1) -->
+ <!-- rqcblten : tendency of cloud water mixing ratio due to pbl processes (kg/kg s-1) -->
+ <!-- rqiblten : tendency of cloud ice mixing ratio due to pbl processes (kg/kg s-1) -->
+
+ <var name="rublten" type="real" dimensions="nVertLevels nCells Time" streams="ro"/>
+ <var name="rvblten" type="real" dimensions="nVertLevels nCells Time" streams="ro"/>
+ <var name="rthblten" type="real" dimensions="nVertLevels nCells Time" streams="ro"/>
+ <var name="rqvblten" type="real" dimensions="nVertLevels nCells Time" streams="ro"/>
+ <var name="rqcblten" type="real" dimensions="nVertLevels nCells Time" streams="ro"/>
+ <var name="rqiblten" type="real" dimensions="nVertLevels nCells Time" streams="ro"/>
+
+
+ <!-- ================================================================================================== -->
+ <!-- ... TENDENCIES FROM PARAMETERIZATION OF LONGWAVE RADIATION: -->
+ <!-- ================================================================================================== -->
+ <!-- rthratensw:uncoupled theta tendency due to shortwave radiation [K s-1] -->
+ <!-- rthratenlw:uncoupled theta tendency due to longwave radiation [K s-1] -->
+
+ <var name="rthratensw" type="real" dimensions="nVertLevels nCells Time" streams="ro"/>
+ <var name="rthratenlw" type="real" dimensions="nVertLevels nCells Time" streams="ro"/>
+ </var_struct>
+
+ <var_struct name="sfc_input" time_levs="0">
+
+ <!-- ================================================================================================== -->
+ <!-- ... SURFACE CHARACTERISTICS THAT NEED TO BE READ FROM GRID.NC: -->
+ <!-- ================================================================================================== -->
+
+ <!-- albedo12m :monthly climatological albedo [-] -->
+ <!-- greenfrac :monthly climatological greeness fraction [-] -->
+ <!-- isltyp :dominant soil category [-] -->
+ <!-- ivgtyp :dominant vegetation category [-] -->
+ <!-- landmask :=0 for ocean;=1 for land [-] -->
+ <!-- sfc_albbck :background albedo [-] -->
+ <!-- shdmin :minimum areal fractional coverage of annual green vegetation [-] -->
+ <!-- shdmax :maximum areal fractional coverage of annual green vegetation [-] -->
+ <!-- skintemp :skin temperature [K] -->
+ <!-- snoalb :annual max snow albedo [-] -->
+ <!-- snow :snow water equivalent [kg m-2] -->
+ <!-- sst :sea-surface temperature [K] -->
+ <!-- snowc :flag indicating snow coverage (1 for snow cover) [-] -->
+ <!-- snowh :physical snow depth [m] -->
+ <!-- ter :terrain height [-] -->
+ <!-- tmn :soil temperature at lower boundary [K] -->
+ <!-- vegfra :vegetation fraction [-] -->
+ <!-- seaice :sea-ice mask (=1 when xice is greater than 0; =0 otherwise) [-] -->
+ <!-- xice :fractional sea-ice coverage [-] -->
+ <!-- xland :land mask (1 for land; 2 for water) [-] -->
+
+ <!-- dzs :thickness of soil layers [m] -->
+ <!-- smcrel :soil moisture threshold below which transpiration begins to stress [-] -->
+ <!-- sh2o :soil liquid water [m3 m-3] -->
+ <!-- smois :soil moisture [m3 m-3] -->
+ <!-- tslb :soil temperature [K] -->
+
+ <var name="isltyp" type="integer" dimensions="nCells" streams="iro"/>
+ <var name="ivgtyp" type="integer" dimensions="nCells" streams="iro"/>
+ <var name="landmask" type="integer" dimensions="nCells" streams="iro"/>
+ <var name="shdmin" type="real" dimensions="nCells" streams="iro"/>
+ <var name="shdmax" type="real" dimensions="nCells" streams="iro"/>
+ <var name="snoalb" type="real" dimensions="nCells" streams="iro"/>
+ <var name="ter" type="real" dimensions="nCells" streams="io"/>
+ <var name="albedo12m" type="real" dimensions="nMonths nCells" streams="iro"/>
+ <var name="greenfrac" type="real" dimensions="nMonths nCells" streams="iro"/>
+
+ <var name="sfc_albbck" type="real" dimensions="nCells Time" streams="iro"/>
+ <var name="skintemp" type="real" dimensions="nCells Time" streams="iro"/>
+ <var name="snow" type="real" dimensions="nCells Time" streams="iro"/>
+ <var name="snowc" type="real" dimensions="nCells Time" streams="iro"/>
+ <var name="snowh" type="real" dimensions="nCells Time" streams="iro"/>
+ <var name="sst" type="real" dimensions="nCells Time" streams="isro"/>
+ <var name="tmn" type="real" dimensions="nCells Time" streams="iro"/>
+ <var name="vegfra" type="real" dimensions="nCells Time" streams="iro"/>
+ <var name="seaice" type="real" dimensions="nCells Time" streams="iro"/>
+ <var name="xice" type="real" dimensions="nCells Time" streams="isro"/>
+ <var name="xland" type="real" dimensions="nCells Time" streams="iro"/>
+
+ <var name="dzs" type="real" dimensions="nSoilLevels nCells Time" streams="iro"/>
+ <var name="smcrel" type="real" dimensions="nSoilLevels nCells Time" streams="ro"/>
+ <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: branches/ocean_projects/openmp_elements/src/core_nhyd_atmos/mpas_atm_advection.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_nhyd_atmos/mpas_atm_advection.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_nhyd_atmos/mpas_atm_advection.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -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.
Copied: branches/ocean_projects/openmp_elements/src/core_nhyd_atmos/mpas_atm_interp_diagnostics.F (from rev 2677, trunk/mpas/src/core_nhyd_atmos/mpas_atm_interp_diagnostics.F)
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_nhyd_atmos/mpas_atm_interp_diagnostics.F (rev 0)
+++ branches/ocean_projects/openmp_elements/src/core_nhyd_atmos/mpas_atm_interp_diagnostics.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -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: branches/ocean_projects/openmp_elements/src/core_nhyd_atmos/mpas_atm_mpas_core.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_nhyd_atmos/mpas_atm_mpas_core.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_nhyd_atmos/mpas_atm_mpas_core.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -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: branches/ocean_projects/openmp_elements/src/core_nhyd_atmos/mpas_atm_time_integration.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_nhyd_atmos/mpas_atm_time_integration.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_nhyd_atmos/mpas_atm_time_integration.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -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
Index: branches/ocean_projects/openmp_elements/src/core_ocean
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_ocean 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_ocean 2013-03-29 14:40:23 UTC (rev 2678)
Property changes on: branches/ocean_projects/openmp_elements/src/core_ocean
___________________________________________________________________
Modified: svn:mergeinfo
## -4,16 +4,22 ##
/branches/ocean_projects/ale_vert_coord/src/core_ocean:1225-1383
/branches/ocean_projects/ale_vert_coord_new/src/core_ocean:1387-1428
/branches/ocean_projects/cesm_coupling/src/core_ocean:2147-2344
+/branches/ocean_projects/comment_cleanup/src/core_ocean:2626-2630
+/branches/ocean_projects/diagnostics_revision/src/core_ocean:2439-2462
+/branches/ocean_projects/explicit_vmix_removal/src/core_ocean:2486-2490
/branches/ocean_projects/gmvar/src/core_ocean:1214-1514,1517-1738
/branches/ocean_projects/imp_vert_mix_error/src/core_ocean:1847-1887
/branches/ocean_projects/imp_vert_mix_mrp/src/core_ocean:754-986
/branches/ocean_projects/leith_mrp/src/core_ocean:2182-2241
+/branches/ocean_projects/linear_eos/src/core_ocean:2435-2437
/branches/ocean_projects/monotonic_advection/src/core_ocean:1499-1640
/branches/ocean_projects/monthly_forcing/src/core_ocean:1810-1867
/branches/ocean_projects/namelist_cleanup/src/core_ocean:2319-2414
/branches/ocean_projects/option3_b4b_test/src/core_ocean:2201-2231
/branches/ocean_projects/partial_bottom_cells/src/core_ocean:2172-2226
+/branches/ocean_projects/remove_sw_test_cases/src/core_ocean:2539-2540
/branches/ocean_projects/restart_reproducibility/src/core_ocean:2239-2272
+/branches/ocean_projects/sea_level_pressure/src/core_ocean:2488-2528
/branches/ocean_projects/split_explicit_mrp/src/core_ocean:1134-1138
/branches/ocean_projects/split_explicit_timestepping/src/core_ocean:1044-1097
/branches/ocean_projects/vert_adv_mrp/src/core_ocean:704-745
## -26,6 +32,8 ##
/branches/omp_blocks/multiple_blocks/src/core_ocean:1803-2084
/branches/omp_blocks/openmp_test/src/core_ocean:2107-2144
/branches/omp_blocks/openmp_test/src/core_ocean_elements:2161-2201
+/branches/scratch_indication/src/core_ocean:2555-2656
/branches/source_renaming/src/core_ocean:1082-1113
/branches/time_manager/src/core_ocean:924-962
-/trunk/mpas/src/core_ocean:2346-2428
+/branches/xml_registry/src/core_ocean:2610-2662
+/trunk/mpas/src/core_ocean:2346-2677
\ No newline at end of property
Modified: branches/ocean_projects/openmp_elements/src/core_ocean/Makefile
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_ocean/Makefile 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_ocean/Makefile 2013-03-29 14:40:23 UTC (rev 2678)
@@ -1,79 +1,79 @@
.SUFFIXES: .F .o
OBJS = mpas_ocn_mpas_core.o \
- mpas_ocn_test_cases.o \
mpas_ocn_advection.o \
- mpas_ocn_thick_hadv.o \
- mpas_ocn_thick_vadv.o \
- mpas_ocn_gm.o \
- mpas_ocn_vel_coriolis.o \
- mpas_ocn_vel_vadv.o \
- mpas_ocn_vel_hmix.o \
- mpas_ocn_vel_hmix_del2.o \
- mpas_ocn_vel_hmix_leith.o \
- mpas_ocn_vel_hmix_del4.o \
- mpas_ocn_vel_forcing.o \
- mpas_ocn_vel_forcing_windstress.o \
- mpas_ocn_vel_forcing_bottomdrag.o \
- mpas_ocn_vel_forcing_rayleigh.o \
- mpas_ocn_vel_pressure_grad.o \
- mpas_ocn_tracer_vadv.o \
- mpas_ocn_tracer_vadv_spline.o \
- mpas_ocn_tracer_vadv_spline2.o \
- mpas_ocn_tracer_vadv_spline3.o \
- mpas_ocn_tracer_vadv_stencil.o \
- mpas_ocn_tracer_vadv_stencil2.o \
- mpas_ocn_tracer_vadv_stencil3.o \
- mpas_ocn_tracer_vadv_stencil4.o \
- mpas_ocn_tracer_hadv.o \
- mpas_ocn_tracer_hadv2.o \
- mpas_ocn_tracer_hadv3.o \
- mpas_ocn_tracer_hadv4.o \
- mpas_ocn_tracer_hmix.o \
- mpas_ocn_tracer_hmix_del2.o \
- mpas_ocn_tracer_hmix_del4.o \
- mpas_ocn_vmix.o \
- mpas_ocn_vmix_coefs_const.o \
- mpas_ocn_vmix_coefs_rich.o \
- mpas_ocn_vmix_coefs_tanh.o \
- mpas_ocn_restoring.o \
- mpas_ocn_tendency.o \
- mpas_ocn_tracer_advection.o \
- mpas_ocn_tracer_advection_std.o \
- mpas_ocn_tracer_advection_std_hadv.o \
- mpas_ocn_tracer_advection_std_vadv.o \
- mpas_ocn_tracer_advection_std_vadv2.o \
- mpas_ocn_tracer_advection_std_vadv3.o \
- mpas_ocn_tracer_advection_std_vadv4.o \
- mpas_ocn_tracer_advection_mono.o \
- mpas_ocn_tracer_advection_helpers.o \
+ mpas_ocn_thick_hadv.o \
+ mpas_ocn_thick_vadv.o \
+ mpas_ocn_gm.o \
+ mpas_ocn_vel_coriolis.o \
+ mpas_ocn_vel_vadv.o \
+ mpas_ocn_vel_hmix.o \
+ mpas_ocn_vel_hmix_del2.o \
+ mpas_ocn_vel_hmix_leith.o \
+ mpas_ocn_vel_hmix_del4.o \
+ mpas_ocn_vel_forcing.o \
+ mpas_ocn_vel_forcing_windstress.o \
+ mpas_ocn_vel_forcing_rayleigh.o \
+ mpas_ocn_vel_pressure_grad.o \
+ mpas_ocn_tracer_vadv.o \
+ mpas_ocn_tracer_vadv_spline.o \
+ mpas_ocn_tracer_vadv_spline2.o \
+ mpas_ocn_tracer_vadv_spline3.o \
+ mpas_ocn_tracer_vadv_stencil.o \
+ mpas_ocn_tracer_vadv_stencil2.o \
+ mpas_ocn_tracer_vadv_stencil3.o \
+ mpas_ocn_tracer_vadv_stencil4.o \
+ mpas_ocn_tracer_hadv.o \
+ mpas_ocn_tracer_hadv2.o \
+ mpas_ocn_tracer_hadv3.o \
+ mpas_ocn_tracer_hadv4.o \
+ mpas_ocn_tracer_hmix.o \
+ mpas_ocn_tracer_hmix_del2.o \
+ mpas_ocn_tracer_hmix_del4.o \
+ mpas_ocn_vmix.o \
+ mpas_ocn_vmix_coefs_const.o \
+ mpas_ocn_vmix_coefs_rich.o \
+ mpas_ocn_vmix_coefs_tanh.o \
+ mpas_ocn_restoring.o \
+ mpas_ocn_tendency.o \
+ mpas_ocn_diagnostics.o \
+ mpas_ocn_tracer_advection.o \
+ mpas_ocn_tracer_advection_std.o \
+ mpas_ocn_tracer_advection_std_hadv.o \
+ mpas_ocn_tracer_advection_std_vadv.o \
+ mpas_ocn_tracer_advection_std_vadv2.o \
+ mpas_ocn_tracer_advection_std_vadv3.o \
+ mpas_ocn_tracer_advection_std_vadv4.o \
+ mpas_ocn_tracer_advection_mono.o \
+ mpas_ocn_tracer_advection_helpers.o \
mpas_ocn_time_integration.o \
mpas_ocn_time_integration_rk4.o \
mpas_ocn_time_integration_split.o \
- mpas_ocn_equation_of_state.o \
- mpas_ocn_equation_of_state_jm.o \
- mpas_ocn_equation_of_state_linear.o \
+ mpas_ocn_equation_of_state.o \
+ mpas_ocn_equation_of_state_jm.o \
+ mpas_ocn_equation_of_state_linear.o \
+ mpas_ocn_diagnostics.o \
mpas_ocn_global_diagnostics.o \
- mpas_ocn_time_average.o \
- mpas_ocn_monthly_forcing.o
+ mpas_ocn_time_average.o \
+ mpas_ocn_monthly_forcing.o
all: core_hyd
core_hyd: $(OBJS)
ar -ru libdycore.a $(OBJS)
-mpas_ocn_test_cases.o:
-
mpas_ocn_advection.o:
mpas_ocn_time_integration.o: mpas_ocn_time_integration_rk4.o mpas_ocn_time_integration_split.o
-mpas_ocn_time_integration_rk4.o:
+mpas_ocn_time_integration_rk4.o: mpas_ocn_tendency.o mpas_ocn_diagnostics.o
-mpas_ocn_time_integration_split.o:
+mpas_ocn_time_integration_split.o: mpas_ocn_tendency.o mpas_ocn_diagnostics.o
mpas_ocn_tendency.o: mpas_ocn_time_average.o
+mpas_ocn_diagnostics.o: mpas_ocn_time_average.o
+
mpas_ocn_global_diagnostics.o:
mpas_ocn_time_average.o:
@@ -96,12 +96,10 @@
mpas_ocn_vel_hmix_del4.o:
-mpas_ocn_vel_forcing.o: mpas_ocn_vel_forcing_windstress.o mpas_ocn_vel_forcing_bottomdrag.o mpas_ocn_vel_forcing_rayleigh.o
+mpas_ocn_vel_forcing.o: mpas_ocn_vel_forcing_windstress.o mpas_ocn_vel_forcing_rayleigh.o
mpas_ocn_vel_forcing_windstress.o:
-mpas_ocn_vel_forcing_bottomdrag.o:
-
mpas_ocn_vel_forcing_rayleigh.o:
mpas_ocn_vel_coriolis.o:
@@ -172,61 +170,59 @@
mpas_ocn_monthly_forcing.o:
-mpas_ocn_mpas_core.o: mpas_ocn_mpas_core.o \
- mpas_ocn_test_cases.o \
- mpas_ocn_advection.o \
- mpas_ocn_thick_hadv.o \
+mpas_ocn_mpas_core.o: mpas_ocn_advection.o \
+ mpas_ocn_thick_hadv.o \
mpas_ocn_gm.o \
- mpas_ocn_thick_vadv.o \
- mpas_ocn_vel_coriolis.o \
- mpas_ocn_vel_vadv.o \
- mpas_ocn_vel_hmix.o \
- mpas_ocn_vel_hmix_del2.o \
- mpas_ocn_vel_hmix_leith.o \
- mpas_ocn_vel_hmix_del4.o \
- mpas_ocn_vel_forcing.o \
- mpas_ocn_vel_forcing_windstress.o \
- mpas_ocn_vel_forcing_bottomdrag.o \
- mpas_ocn_vel_pressure_grad.o \
- mpas_ocn_tracer_vadv.o \
- mpas_ocn_tracer_vadv_spline.o \
- mpas_ocn_tracer_vadv_spline2.o \
- mpas_ocn_tracer_vadv_spline3.o \
- mpas_ocn_tracer_vadv_stencil.o \
- mpas_ocn_tracer_vadv_stencil2.o \
- mpas_ocn_tracer_vadv_stencil3.o \
- mpas_ocn_tracer_vadv_stencil4.o \
- mpas_ocn_tracer_hadv.o \
- mpas_ocn_tracer_hadv2.o \
- mpas_ocn_tracer_hadv3.o \
- mpas_ocn_tracer_hadv4.o \
- mpas_ocn_tracer_hmix.o \
- mpas_ocn_tracer_hmix_del2.o \
- mpas_ocn_tracer_hmix_del4.o \
- mpas_ocn_vmix.o \
- mpas_ocn_vmix_coefs_const.o \
- mpas_ocn_vmix_coefs_rich.o \
- mpas_ocn_vmix_coefs_tanh.o \
- mpas_ocn_restoring.o \
- mpas_ocn_tracer_advection.o \
- mpas_ocn_tracer_advection_std.o \
- mpas_ocn_tracer_advection_std_hadv.o \
- mpas_ocn_tracer_advection_std_vadv.o \
- mpas_ocn_tracer_advection_std_vadv2.o \
- mpas_ocn_tracer_advection_std_vadv3.o \
- mpas_ocn_tracer_advection_std_vadv4.o \
- mpas_ocn_tracer_advection_mono.o \
- mpas_ocn_tracer_advection_helpers.o \
- mpas_ocn_tendency.o \
- mpas_ocn_time_integration.o \
- mpas_ocn_time_integration_rk4.o \
- mpas_ocn_time_integration_split.o \
- mpas_ocn_equation_of_state.o \
- mpas_ocn_equation_of_state_jm.o \
- mpas_ocn_equation_of_state_linear.o \
- mpas_ocn_global_diagnostics.o \
- mpas_ocn_time_average.o \
- mpas_ocn_monthly_forcing.o
+ mpas_ocn_thick_vadv.o \
+ mpas_ocn_vel_coriolis.o \
+ mpas_ocn_vel_vadv.o \
+ mpas_ocn_vel_hmix.o \
+ mpas_ocn_vel_hmix_del2.o \
+ mpas_ocn_vel_hmix_leith.o \
+ mpas_ocn_vel_hmix_del4.o \
+ mpas_ocn_vel_forcing.o \
+ mpas_ocn_vel_forcing_windstress.o \
+ mpas_ocn_vel_pressure_grad.o \
+ mpas_ocn_tracer_vadv.o \
+ mpas_ocn_tracer_vadv_spline.o \
+ mpas_ocn_tracer_vadv_spline2.o \
+ mpas_ocn_tracer_vadv_spline3.o \
+ mpas_ocn_tracer_vadv_stencil.o \
+ mpas_ocn_tracer_vadv_stencil2.o \
+ mpas_ocn_tracer_vadv_stencil3.o \
+ mpas_ocn_tracer_vadv_stencil4.o \
+ mpas_ocn_tracer_hadv.o \
+ mpas_ocn_tracer_hadv2.o \
+ mpas_ocn_tracer_hadv3.o \
+ mpas_ocn_tracer_hadv4.o \
+ mpas_ocn_tracer_hmix.o \
+ mpas_ocn_tracer_hmix_del2.o \
+ mpas_ocn_tracer_hmix_del4.o \
+ mpas_ocn_vmix.o \
+ mpas_ocn_vmix_coefs_const.o \
+ mpas_ocn_vmix_coefs_rich.o \
+ mpas_ocn_vmix_coefs_tanh.o \
+ mpas_ocn_restoring.o \
+ mpas_ocn_tracer_advection.o \
+ mpas_ocn_tracer_advection_std.o \
+ mpas_ocn_tracer_advection_std_hadv.o \
+ mpas_ocn_tracer_advection_std_vadv.o \
+ mpas_ocn_tracer_advection_std_vadv2.o \
+ mpas_ocn_tracer_advection_std_vadv3.o \
+ mpas_ocn_tracer_advection_std_vadv4.o \
+ mpas_ocn_tracer_advection_mono.o \
+ mpas_ocn_tracer_advection_helpers.o \
+ mpas_ocn_tendency.o \
+ mpas_ocn_diagnostics.o \
+ mpas_ocn_time_integration.o \
+ mpas_ocn_time_integration_rk4.o \
+ mpas_ocn_time_integration_split.o \
+ mpas_ocn_equation_of_state.o \
+ mpas_ocn_equation_of_state_jm.o \
+ mpas_ocn_equation_of_state_linear.o \
+ mpas_ocn_global_diagnostics.o \
+ mpas_ocn_time_average.o \
+ mpas_ocn_monthly_forcing.o
clean:
$(RM) *.o *.mod *.f90 libdycore.a
Modified: branches/ocean_projects/openmp_elements/src/core_ocean/Registry
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_ocean/Registry 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_ocean/Registry 2013-03-29 14:40:23 UTC (rev 2678)
@@ -4,57 +4,55 @@
namelist logical time_management config_do_restart .false.
namelist character time_management config_start_time '0000-01-01_00:00:00'
namelist character time_management config_stop_time 'none'
-namelist character time_management config_run_duration 'none'
+namelist character time_management config_run_duration '0_06:00:00'
namelist character time_management config_calendar_type '360day'
-namelist integer time_management config_ncouple_per_day 1
namelist character io config_input_name 'grid.nc'
namelist character io config_output_name 'output.nc'
namelist character io config_restart_name 'restart.nc'
-namelist character io config_restart_interval 'none'
-namelist character io config_output_interval '24:00:00'
-namelist character io config_stats_interval '24:00:00'
-namelist logical io config_write_stats_on_startup .false.
+namelist character io config_restart_interval '0_06:00:00'
+namelist character io config_output_interval '0_06:00:00'
+namelist character io config_stats_interval '0_01:00:00'
+namelist logical io config_write_stats_on_startup .true.
namelist logical io config_write_output_on_startup .true.
-namelist integer io config_frames_per_outfile 0
+namelist integer io config_frames_per_outfile 1000
namelist integer io config_pio_num_iotasks 0
namelist integer io config_pio_stride 1
-namelist real time_integration config_dt 172.8
-namelist character time_integration config_time_integrator 'RK4'
+namelist real time_integration config_dt 3000.0
+namelist character time_integration config_time_integrator 'split_explicit'
-namelist integer grid config_num_halos 3
-namelist logical grid config_enforce_grid_on_restart .false.
-namelist character grid config_vert_coord_movement 'isopycnal'
-namelist character grid config_alter_ICs_for_pbcs 'zlevel_pbcs_off'
-namelist real grid config_min_pbc_fraction 0.10
-namelist logical grid config_check_ssh_consistency .true.
+namelist integer grid config_num_halos 3
+namelist character grid config_vert_coord_movement 'uniform_stretching'
+namelist character grid config_alter_ICs_for_pbcs 'zlevel_pbcs_off'
+namelist real grid config_min_pbc_fraction 0.10
+namelist logical grid config_check_ssh_consistency .true.
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.
namelist character decomposition config_proc_decomp_file_prefix 'graph.info.part.'
-namelist logical hmix config_h_ScaleWithMesh .false.
+namelist logical hmix config_hmix_ScaleWithMesh .false.
namelist logical hmix config_visc_vorticity_term .true.
namelist real hmix config_apvm_scale_factor 0.0
-namelist logical hmix_del2 config_use_mom_del2 .true.
-namelist logical hmix_del2 config_use_tracer_del2 .true.
-namelist real hmix_del2 config_h_mom_eddy_visc2 0.0
-namelist real hmix_del2 config_h_tracer_eddy_diff2 0.0
-namelist real hmix_del2 config_visc_vorticity_visc2_scale 1.0
+namelist logical hmix_del2 config_use_mom_del2 .false.
+namelist logical hmix_del2 config_use_tracer_del2 .false.
+namelist real hmix_del2 config_mom_del2 0.0
+namelist real hmix_del2 config_tracer_del2 0.0
+namelist real hmix_del2 config_vorticity_del2_scale 1.0
-namelist logical hmix_del4 config_use_mom_del4 .true.
-namelist logical hmix_del4 config_use_tracer_del4 .true.
-namelist real hmix_del4 config_h_mom_eddy_visc4 0.0
-namelist real hmix_del4 config_h_tracer_eddy_diff4 0.0
-namelist real hmix_del4 config_visc_vorticity_visc4_scale 1.0
+namelist logical hmix_del4 config_use_mom_del4 .true.
+namelist logical hmix_del4 config_use_tracer_del4 .false.
+namelist real hmix_del4 config_mom_del4 5.0e13
+namelist real hmix_del4 config_tracer_del4 0.0
+namelist real hmix_del4 config_vorticity_del4_scale 1.0
-namelist logical hmix_Leith config_use_Leith_del2 .false.
-namelist real hmix_Leith config_Leith_parameter 0.0
-namelist real hmix_Leith config_Leith_dx 0.0
-namelist real hmix_Leith config_Leith_visc2_max 1000000.0
+namelist logical hmix_Leith config_use_Leith_del2 .false.
+namelist real hmix_Leith config_Leith_parameter 1.0
+namelist real hmix_Leith config_Leith_dx 15000.0
+namelist real hmix_Leith config_Leith_visc2_max 2.5e3
namelist real standard_GM config_h_kappa 0.0
namelist real standard_GM config_h_kappa_q 0.0
@@ -62,12 +60,11 @@
namelist logical Rayleigh_damping config_Rayleigh_friction .false.
namelist real Rayleigh_damping config_Rayleigh_damping_coeff 0.0
-namelist logical vmix config_implicit_vertical_mix .true.
namelist real vmix config_convective_visc 1.0
namelist real vmix config_convective_diff 1.0
-namelist logical vmix_const config_use_const_visc .true.
-namelist logical vmix_const config_use_const_diff .true.
+namelist logical vmix_const config_use_const_visc .false.
+namelist logical vmix_const config_use_const_diff .false.
namelist real vmix_const config_vert_visc 2.5e-4
namelist real vmix_const config_vert_diff 2.5e-5
@@ -77,8 +74,8 @@
namelist real vmix_rich config_bkrd_vert_diff 1.0e-5
namelist real vmix_rich config_rich_mix 0.005
-namelist logical vmix_tanh config_use_tanh_visc .true.
-namelist logical vmix_tanh config_use_tanh_diff .true.
+namelist logical vmix_tanh config_use_tanh_visc .false.
+namelist logical vmix_tanh config_use_tanh_diff .false.
namelist real vmix_tanh config_max_visc_tanh 2.5e-1
namelist real vmix_tanh config_min_visc_tanh 1.0e-4
namelist real vmix_tanh config_max_diff_tanh 2.5e-2
@@ -92,20 +89,26 @@
namelist real forcing config_restoreS_timescale 90.0
namelist character advection config_vert_tracer_adv 'stencil'
-namelist integer advection config_vert_tracer_adv_order 4
-namelist integer advection config_horiz_tracer_adv_order 2
+namelist integer advection config_vert_tracer_adv_order 3
+namelist integer advection config_horiz_tracer_adv_order 3
namelist real advection config_coef_3rd_order 0.25
-namelist logical advection config_monotonic .false.
+namelist logical advection config_monotonic .true.
namelist real bottom_drag config_bottom_drag_coeff 1.0e-3
namelist character pressure_gradient config_pressure_gradient_type 'pressure_and_zmid'
namelist real pressure_gradient config_rho0 1014.65
-namelist character eos config_eos_type 'linear'
+namelist character eos config_eos_type 'jm'
+namelist real eos_linear config_eos_linear_alpha 2.55e-1
+namelist real eos_linear config_eos_linear_beta 7.64e-1
+namelist real eos_linear config_eos_linear_Tref 19.0
+namelist real eos_linear config_eos_linear_Sref 35.0
+namelist real eos_linear config_eos_linear_rhoref 1025.022
+
namelist integer split_explicit_ts config_n_ts_iter 2
-namelist integer split_explicit_ts config_n_bcl_iter_beg 2
+namelist integer split_explicit_ts config_n_bcl_iter_beg 1
namelist integer split_explicit_ts config_n_bcl_iter_mid 2
namelist integer split_explicit_ts config_n_bcl_iter_end 2
namelist integer split_explicit_ts config_n_btr_subcycles 20
@@ -117,8 +120,6 @@
namelist real split_explicit_ts config_btr_gam3_uWt2 1.0
namelist logical split_explicit_ts config_btr_solve_SSH2 .false.
-namelist integer sw_model config_test_case 0
-
namelist logical debug config_check_zlevel_consistency .false.
namelist logical debug config_filter_btr_mode .false.
namelist logical debug config_prescribe_velocity .false.
@@ -204,7 +205,7 @@
var persistent real edgeNormalVectors ( R3 nEdges ) 0 o edgeNormalVectors mesh - -
var persistent real localVerticalUnitVectors ( R3 nCells ) 0 o localVerticalUnitVectors mesh - -
-var persistent real cellTangentPlane ( R3 TWO nEdges ) 0 o cellTangentPlane mesh - -
+var persistent real cellTangentPlane ( R3 TWO nCells ) 0 o cellTangentPlane mesh - -
var persistent integer cellsOnCell ( maxEdges nCells ) 0 iro cellsOnCell mesh - -
var persistent integer verticesOnCell ( maxEdges nCells ) 0 iro verticesOnCell mesh - -
@@ -327,7 +328,9 @@
var persistent real MontPot ( nVertLevels nCells Time ) 2 - MontPot state - -
var persistent real pressure ( nVertLevels nCells Time ) 2 - pressure state - -
var persistent real wTop ( nVertLevelsP1 nCells Time ) 2 - wTop state - -
+var persistent real vertVelocityTop ( nVertLevelsP1 nCells Time ) 2 - vertVelocityTop state - -
var persistent real rhoDisplaced ( nVertLevels nCells Time ) 2 - rhoDisplaced state - -
+var persistent real BruntVaisalaFreqTop ( nVertLevels nCells Time ) 2 o BruntVaisalaFreqTop state - -
var persistent real viscosity ( nVertLevels nEdges Time ) 2 o viscosity state - -
% Other diagnostic variables: neither read nor written to any files
@@ -360,6 +363,7 @@
var persistent real acc_uReconstructMeridionalVar ( nVertLevels nCells Time ) 2 o acc_uReconstructMeridionalVar state - -
var persistent real acc_u ( nVertLevels nEdges Time ) 2 o acc_u state - -
var persistent real acc_uVar ( nVertLevels nEdges Time ) 2 o acc_uVar state - -
+var persistent real acc_vertVelocityTop ( nVertLevelsP1 nCells Time ) 2 o acc_vertVelocityTop state - -
% Sign fields, for openmp and bit reproducibility without branching statements.
var persistent integer edgeSignOnCell ( maxEdges nCells ) 0 - edgeSignOnCell mesh - -
@@ -389,3 +393,6 @@
var scratch real drhoTopOfEdge ( nVertLevelsP1 nEdges ) 0 - drhoTopOfEdge scratch - -
var scratch real du2TopOfCell ( nVertLevelsP1 nCells ) 0 - du2TopOfCell scratch - -
var scratch real du2TopOfEdge ( nVertLevelsP1 nEdges ) 0 - du2TopOfEdge scratch - -
+
+% Sea surface pressure, for coupling
+var persistent real seaSurfacePressure ( nCells Time ) 0 ir seaSurfacePressure mesh - -
Copied: branches/ocean_projects/openmp_elements/src/core_ocean/Registry.xml (from rev 2677, trunk/mpas/src/core_ocean/Registry.xml)
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_ocean/Registry.xml (rev 0)
+++ branches/ocean_projects/openmp_elements/src/core_ocean/Registry.xml 2013-03-29 14:40:23 UTC (rev 2678)
@@ -0,0 +1,1141 @@
+<?xml version="1.0"?>
+<registry>
+ <dims>
+ <dim name="nCells" units="unitless"
+ description="The number of polygons in the primary grid."
+ />
+ <dim name="nEdges" units="unitless"
+ description="The number of edge midpoints in either the primary or dual grid."
+ />
+ <dim name="maxEdges" units="unitless"
+ description="The largest number of edges any polygon within the grid has."
+ />
+ <dim name="maxEdges2" units="unitless"
+ description="Two times the largest number of edges any polygon within the grid has."
+ />
+ <dim name="nAdvectionCells" definition="maxEdges2+0" units="unitless"
+ description="The largest number of advection cells for any edge."
+ />
+ <dim name="nVertices" units="unitless"
+ description="The total number of cells in the dual grid. Also the number of corners in the primary grid."
+ />
+ <dim name="TWO" definition="2" units="unitless"
+ description="The number two as a dimension."
+ />
+ <dim name="R3" definition="3" units="unitless"
+ description="The number three as a dimension."
+ />
+ <dim name="FIFTEEN" definition="15" units="unitless"
+ description="The number 15 as a dimension."
+ />
+ <dim name="TWENTYONE" definition="21" units="unitless"
+ description="The number 21 as a dimension."
+ />
+ <dim name="vertexDegree" units="unitless"
+ description="The number of cells or edges touching each vertex."
+ />
+ <dim name="nVertLevels" units="unitless"
+ description="The number of levels in the vertical direction. All vertical levels share the same horizontal locations."
+ />
+ <dim name="nVertLevelsP1" definition="nVertLevels+1" units="unitless"
+ description="The number of interfaces in the vertical direction."
+ />
+ <dim name="nMonths" units="unitless"
+ description="The number of forcing slices in the monthly forcing fields. {\bf \color{red} Deprecated. Should be removed.}"
+ />
+ </dims>
+ <nml_record name="time_management">
+ <nml_option name="config_do_restart" type="logical" default_value=".false." units="unitless"
+ description="Determines if the initial conditions should be read from a restart file, or an input file."
+ possible_values=".true. or .false."
+ />
+ <nml_option name="config_start_time" type="character" default_value="'0000-01-01_00:00:00'" units="unitless"
+ description="Timestamp describing the initial time of the simulation. If it is set to 'file', the initial time is read from restart_timestamp."
+ possible_values="'YYYY-MM-DD_HH:MM:SS' or 'file'"
+ />
+ <nml_option name="config_stop_time" type="character" default_value="'none'" units="unitless"
+ description="Timestamp descriping the final time of the simulation. If it is set to 'none' the final time is determined from config_start_time and config_run_duration."
+ possible_values="'YYYY-MM-DD_HH:MM:SS' or 'none'"
+ />
+ <nml_option name="config_run_duration" type="character" default_value="'0_06:00:00'" units="unitless"
+ description="Timestamp describing the length of the simulation. If it is set to 'none' the duraction is determined from config_start_time and config_stop_time. config_run_duration overrides inconsistent values of config_stop_time."
+ possible_values="'DDDD_HH:MM:SS' or 'none'"
+ />
+ <nml_option name="config_calendar_type" type="character" default_value="'360day'" units="unitless"
+ description="Selection of the type of calendar that should be used in the simulation."
+ possible_values="'gregorian', 'gregorian_noleap', or '360day'"
+ />
+ </nml_record>
+ <nml_record name="io">
+ <nml_option name="config_input_name" type="character" default_value="'grid.nc'" units=""
+ description=""
+ possible_values=""
+ />
+ <nml_option name="config_output_name" type="character" default_value="'output.nc'" units=""
+ description=""
+ possible_values=""
+ />
+ <nml_option name="config_restart_name" type="character" default_value="'restart.nc'" units=""
+ description=""
+ possible_values=""
+ />
+ <nml_option name="config_restart_interval" type="character" default_value="'0_06:00:00'" units=""
+ description=""
+ possible_values=""
+ />
+ <nml_option name="config_output_interval" type="character" default_value="'0_06:00:00'" units=""
+ description=""
+ possible_values=""
+ />
+ <nml_option name="config_stats_interval" type="character" default_value="'0_01:00:00'" units=""
+ description=""
+ possible_values=""
+ />
+ <nml_option name="config_write_stats_on_startup" type="logical" default_value=".true." units=""
+ description=""
+ possible_values=""
+ />
+ <nml_option name="config_write_output_on_startup" type="logical" default_value=".true." units=""
+ description=""
+ possible_values=""
+ />
+ <nml_option name="config_frames_per_outfile" type="integer" default_value="1000" units=""
+ description=""
+ possible_values=""
+ />
+ <nml_option name="config_pio_num_iotasks" type="integer" default_value="0" units=""
+ description=""
+ possible_values=""
+ />
+ <nml_option name="config_pio_stride" type="integer" default_value="1" units=""
+ description=""
+ possible_values=""
+ />
+ </nml_record>
+ <nml_record name="time_integration">
+ <nml_option name="config_dt" type="real" default_value="3000.0" units="s"
+ description="Length of model time-step."
+ possible_values="Any positive real value, but limited by CFL condition."
+ />
+ <nml_option name="config_time_integrator" type="character" default_value="'split_explicit'" units="unitless"
+ description="Time integration method."
+ possible_values="'split_explicit', 'RK4', 'unsplit_explicit'"
+ />
+ </nml_record>
+ <nml_record name="grid">
+ <nml_option name="config_num_halos" type="integer" default_value="3" units="unitless"
+ description="Determines the number of halo cells extending from a blocks owned cells (Called the 0-Halo). The default of 3 is the minimum that can be used with monotonic advection."
+ possible_values="Any positive interger value."
+ />
+ <nml_option name="config_vert_coord_movement" type="character" default_value="'uniform_stretching'" units="unitless"
+ description="Determines the vertical coordinate movement type. 'uniform_stretching' distrubtes SSH perturbations through all vertical levels, 'fixed' places them all in the top level, 'user_specified' allows the input file to determine the distribution, and 'isopycnal' causes levels to be pure isopycnal."
+ possible_values="'uniform_stretching', 'fixed', 'user_specified', 'isopycnal'"
+ />
+ <nml_option name="config_alter_ICs_for_pbcs" type="character" default_value="'zlevel_pbcs_off'" units="unitless"
+ description="Determines the method of alteration for partial bottom cells. 'zlevel_pbcs_on' alters the initial conditions for partial bottom cells, 'zlevel_pbcs_off' alters the initial conditions to have full cells everwhere, and 'off' does nothing to the initial conditions."
+ possible_values="'zlevel_pbcs_on', 'zlevel_pbcs_off', 'off'"
+ />
+ <nml_option name="config_min_pbc_fraction" type="real" default_value="0.10" units="unitless"
+ description="Determines the minimum fraction of a cell altering the initial conditions can create."
+ possible_values="Any real between 0 and 1."
+ />
+ <nml_option name="config_check_ssh_consistency" type="logical" default_value=".true." units=""
+ description="Enables a check to determine if the SSH is consistent across relevant variables."
+ possible_values=""
+ />
+ </nml_record>
+ <nml_record name="decomposition">
+ <nml_option name="config_block_decomp_file_prefix" type="character" default_value="'graph.info.part.'" units="unitless"
+ description="Defines the prefix for the block decomposition file. Can include a path. The number of blocks is appended to the end of the prefix at run-time."
+ possible_values="Any path/prefix to a block decomposition file."
+ />
+ <nml_option name="config_number_of_blocks" type="integer" default_value="0" units="unitless"
+ description="Determines the number of blocks a simulation should be run with. If it is set to 0, the number of blocks is the same as the number of MPI tasks at run-time."
+ possible_values="Any integer $>=$ 0."
+ />
+ <nml_option name="config_explicit_proc_decomp" type="logical" default_value=".false." units="unitless"
+ description="Determines if an explicit processor decomposition should be used. This is only useful if multiple blocks per processor are used."
+ possible_values=".true. or .false."
+ />
+ <nml_option name="config_proc_decomp_file_prefix" type="character" default_value="'graph.info.part.'" units="unitless"
+ description="Defines the prefix for the processor decomposition file. This file is only read if config_explicit_proc_decomp is .true. The number of processors is appended to the end of the prefix at run-time."
+ possible_values="Any path/prefix to a processor decomposition file."
+ />
+ </nml_record>
+ <nml_record name="hmix">
+ <nml_option name="config_hmix_ScaleWithMesh" type="logical" default_value=".false." units="unitless"
+ description="If false, del2 and del4 coefficients are constant throughout the mesh (equivalent to setting $\rho_m=1$ throughout the mesh). If true, these coefficients scale as mesh density to the -3/4 power."
+ possible_values=".true. or .false."
+ />
+ <nml_option name="config_visc_vorticity_term" type="logical" default_value=".true." units="unitless"
+ description="{\color{red} TO BE DELETED}"
+ possible_values=".true. or .false."
+ />
+ <nml_option name="config_apvm_scale_factor" type="real" default_value="0.0" units="unitless"
+ description="Anticipated potential vorticity (APV) method scale factor, $c_{apv}$. When zero, APV is off."
+ possible_values="Any non-negative number, typically between zero and one."
+ />
+ </nml_record>
+ <nml_record name="hmix_del2">
+ <nml_option name="config_use_mom_del2" type="logical" default_value=".false." units="unitless"
+ description="If true, Laplacian horizontal mixing is used on the momentum equation."
+ possible_values=".true. or .false."
+ />
+ <nml_option name="config_use_tracer_del2" type="logical" default_value=".false." units="unitless"
+ description="If true, Laplacian horizontal mixing is used on the tracer equation."
+ possible_values=".true. or .false."
+ />
+ <nml_option name="config_mom_del2" type="real" default_value="0.0" units="m^2 s^{-1}"
+ description="Horizonal viscosity, $</font>
<font color="gray">u_h$."
+ possible_values="any positive real"
+ />
+ <nml_option name="config_tracer_del2" type="real" default_value="0.0" units="m^2 s^{-1}"
+ description="Horizonal diffusion, $\kappa_h$."
+ possible_values="any positive real"
+ />
+ <nml_option name="config_vorticity_del2_scale" type="real" default_value="1.0" units="unitless"
+ description="{\color{red} TO BE DELETED}"
+ possible_values=""
+ />
+ </nml_record>
+ <nml_record name="hmix_del4">
+ <nml_option name="config_use_mom_del4" type="logical" default_value=".true." units="unitless"
+ description="If true, biharmonic horizontal mixing is used on the momentum equation."
+ possible_values=".true. or .false."
+ />
+ <nml_option name="config_use_tracer_del4" type="logical" default_value=".false." units="unitless"
+ description="If true, biharmonic horizontal mixing is used on the tracer equation."
+ possible_values=".true. or .false."
+ />
+ <nml_option name="config_mom_del4" type="real" default_value="5.0e13" units="m^4 s^{-1}"
+ description="Coefficient for horizontal biharmonic operator on momentum."
+ possible_values="any positive real"
+ />
+ <nml_option name="config_tracer_del4" type="real" default_value="0.0" units="m^4 s^{-1}"
+ description="Coefficient for horizontal biharmonic operator on tracers."
+ possible_values="any positive real"
+ />
+ <nml_option name="config_vorticity_del4_scale" type="real" default_value="1.0" units=""
+ description="{\color{red} TO BE DELETED}"
+ possible_values=""
+ />
+ </nml_record>
+ <nml_record name="hmix_Leith">
+ <nml_option name="config_use_Leith_del2" type="logical" default_value=".false." units=""
+ description=""
+ possible_values=""
+ />
+ <nml_option name="config_Leith_parameter" type="real" default_value="1.0" units=""
+ description=""
+ possible_values=""
+ />
+ <nml_option name="config_Leith_dx" type="real" default_value="15000.0" units=""
+ description=""
+ possible_values=""
+ />
+ <nml_option name="config_Leith_visc2_max" type="real" default_value="2.5e3" units=""
+ description=""
+ possible_values=""
+ />
+ </nml_record>
+ <nml_record name="standard_GM">
+ <nml_option name="config_h_kappa" type="real" default_value="0.0" units=""
+ description=""
+ possible_values=""
+ />
+ <nml_option name="config_h_kappa_q" type="real" default_value="0.0" units=""
+ description=""
+ possible_values=""
+ />
+ </nml_record>
+ <nml_record name="Rayleigh_damping">
+ <nml_option name="config_Rayleigh_friction" type="logical" default_value=".false." units="unitless"
+ description="If true, Rayleigh friction is included in the momentum equation."
+ possible_values=".true. or .false."
+ />
+ <nml_option name="config_Rayleigh_damping_coeff" type="real" default_value="0.0" units="s^{-1}"
+ description="Inverse-time coefficient for the Rayleigh damping term, $c_R$."
+ possible_values="Any positive real value."
+ />
+ </nml_record>
+ <nml_record name="vmix">
+ <nml_option name="config_convective_visc" type="real" default_value="1.0" units=""
+ description=""
+ possible_values=""
+ />
+ <nml_option name="config_convective_diff" type="real" default_value="1.0" units=""
+ description=""
+ possible_values=""
+ />
+ </nml_record>
+ <nml_record name="vmix_const">
+ <nml_option name="config_use_const_visc" type="logical" default_value=".false." units=""
+ description=""
+ possible_values=""
+ />
+ <nml_option name="config_use_const_diff" type="logical" default_value=".false." units=""
+ description=""
+ possible_values=""
+ />
+ <nml_option name="config_vert_visc" type="real" default_value="2.5e-4" units=""
+ description=""
+ possible_values=""
+ />
+ <nml_option name="config_vert_diff" type="real" default_value="2.5e-5" units=""
+ description=""
+ possible_values=""
+ />
+ </nml_record>
+ <nml_record name="vmix_rich">
+ <nml_option name="config_use_rich_visc" type="logical" default_value=".true." units=""
+ description=""
+ possible_values=""
+ />
+ <nml_option name="config_use_rich_diff" type="logical" default_value=".true." units=""
+ description=""
+ possible_values=""
+ />
+ <nml_option name="config_bkrd_vert_visc" type="real" default_value="1.0e-4" units=""
+ description=""
+ possible_values=""
+ />
+ <nml_option name="config_bkrd_vert_diff" type="real" default_value="1.0e-5" units=""
+ description=""
+ possible_values=""
+ />
+ <nml_option name="config_rich_mix" type="real" default_value="0.005" units=""
+ description=""
+ possible_values=""
+ />
+ </nml_record>
+ <nml_record name="vmix_tanh">
+ <nml_option name="config_use_tanh_visc" type="logical" default_value=".false." units=""
+ description=""
+ possible_values=""
+ />
+ <nml_option name="config_use_tanh_diff" type="logical" default_value=".false." units=""
+ description=""
+ possible_values=""
+ />
+ <nml_option name="config_max_visc_tanh" type="real" default_value="2.5e-1" units=""
+ description=""
+ possible_values=""
+ />
+ <nml_option name="config_min_visc_tanh" type="real" default_value="1.0e-4" units=""
+ description=""
+ possible_values=""
+ />
+ <nml_option name="config_max_diff_tanh" type="real" default_value="2.5e-2" units=""
+ description=""
+ possible_values=""
+ />
+ <nml_option name="config_min_diff_tanh" type="real" default_value="1.0e-5" units=""
+ description=""
+ possible_values=""
+ />
+ <nml_option name="config_zMid_tanh" type="real" default_value="-100" units=""
+ description=""
+ possible_values=""
+ />
+ <nml_option name="config_zWidth_tanh" type="real" default_value="100" units=""
+ description=""
+ possible_values=""
+ />
+ </nml_record>
+ <nml_record name="forcing">
+ <nml_option name="config_use_monthly_forcing" type="logical" default_value=".false." units="unitless"
+ description="Controls time frequency of forcing. If false, a constant forcing is used, provided by the input fields u_src, temperatureRestore, and salinityRestore. If true, forcing is interpolated between monthly fields given by windStressMonthly, temperatureRestoreMonthly, and salinityRestoreMonthly."
+ possible_values=".true. or .false."
+ />
+ <nml_option name="config_restoreTS" type="logical" default_value=".false." units="unitless"
+ description="If true, the restoring term is activated in the tracer equation for temperature and salinity."
+ possible_values=".true. or .false."
+ />
+ <nml_option name="config_restoreT_timescale" type="real" default_value="90.0" units="days"
+ description="Restoring timescale for temperature, $\tau_r.$"
+ possible_values="any positive real value, but typically between 30 and 90 days."
+ />
+ <nml_option name="config_restoreS_timescale" type="real" default_value="90.0" units="days"
+ description="Restoring timescale for salinity, $\tau_r$."
+ possible_values="any positive real value, but typically between 30 and 90 days."
+ />
+ </nml_record>
+ <nml_record name="advection">
+ <nml_option name="config_vert_tracer_adv" type="character" default_value="'stencil'" units=""
+ description=""
+ possible_values=""
+ />
+ <nml_option name="config_vert_tracer_adv_order" type="integer" default_value="3" units=""
+ description=""
+ possible_values=""
+ />
+ <nml_option name="config_horiz_tracer_adv_order" type="integer" default_value="3" units=""
+ description=""
+ possible_values=""
+ />
+ <nml_option name="config_coef_3rd_order" type="real" default_value="0.25" units=""
+ description=""
+ possible_values=""
+ />
+ <nml_option name="config_monotonic" type="logical" default_value=".true." units=""
+ description=""
+ possible_values=""
+ />
+ </nml_record>
+ <nml_record name="bottom_drag">
+ <nml_option name="config_bottom_drag_coeff" type="real" default_value="1.0e-3" units="unitless"
+ description="Dimensionless bottom drag coefficient, $c_{drag}$."
+ possible_values="any positive real, typically 1.0e-3"
+ />
+ </nml_record>
+ <nml_record name="pressure_gradient">
+ <nml_option name="config_pressure_gradient_type" type="character" default_value="'pressure_and_zmid'" units="unitless"
+ description="Form of pressure gradient terms in momentum equation. For most applications, the gradient of pressure and layer mid-depth are appropriate. For isopycnal coordinates, one may use the gradient of the Montgomery potential."
+ possible_values="'pressure_and_zmid' or 'MontgomeryPotential'"
+ />
+ <nml_option name="config_rho0" type="real" default_value="1014.65" units="kg m^{-3}"
+ description="Density used as a coefficient of the pressure gradient terms, $\rho_0$. This is a constant due to the Boussinesq approximation."
+ possible_values="any positive real, but typically 1000-1035"
+ />
+ </nml_record>
+ <nml_record name="eos">
+ <nml_option name="config_eos_type" type="character" default_value="'jm'" units=""
+ description=""
+ possible_values=""
+ />
+ </nml_record>
+ <nml_record name="eos_linear">
+ <nml_option name="config_eos_linear_alpha" type="real" default_value="2.55e-1" units=""
+ description=""
+ possible_values=""
+ />
+ <nml_option name="config_eos_linear_beta" type="real" default_value="7.64e-1" units=""
+ description=""
+ possible_values=""
+ />
+ <nml_option name="config_eos_linear_Tref" type="real" default_value="19.0" units=""
+ description=""
+ possible_values=""
+ />
+ <nml_option name="config_eos_linear_Sref" type="real" default_value="35.0" units=""
+ description=""
+ possible_values=""
+ />
+ <nml_option name="config_eos_linear_rhoref" type="real" default_value="1025.022" units=""
+ description=""
+ possible_values=""
+ />
+ </nml_record>
+ <nml_record name="split_explicit_ts">
+ <nml_option name="config_n_ts_iter" type="integer" default_value="2" units="unitless"
+ description="number of large iterations over stages 1-3"
+ possible_values="any positive integer, but typically 1, 2, or 3"
+ />
+ <nml_option name="config_n_bcl_iter_beg" type="integer" default_value="1" units="unitless"
+ description="number of iterations of stage 1 (baroclinic solve) on the first split-explicit iteration"
+ possible_values="any positive integer, but typically 1, 2, or 3"
+ />
+ <nml_option name="config_n_bcl_iter_mid" type="integer" default_value="2" units="unitless"
+ description="number of iterations of stage 1 (baroclinic solve) on any split-explicit iterations between first and last"
+ possible_values="any positive integer, but typically 1, 2, or 3"
+ />
+ <nml_option name="config_n_bcl_iter_end" type="integer" default_value="2" units="unitless"
+ description="number of iterations of stage 1 (baroclinic solve) on the last split-explicit iteration"
+ possible_values="any positive integer, but typically 1, 2, or 3"
+ />
+ <nml_option name="config_n_btr_subcycles" type="integer" default_value="20" units="unitless"
+ description="number of barotropic subcycles in stage 2"
+ possible_values="any positive integer, typically between 10 and 100"
+ />
+ <nml_option name="config_n_btr_cor_iter" type="integer" default_value="2" units="unitless"
+ description="number of iterations of the velocity corrector step in stage 2"
+ possible_values="any positive integer, but typically 1, 2, or 3"
+ />
+ <nml_option name="config_u_correction" type="logical" default_value=".true." units="unitless"
+ description="If true, the velocity correction term is included in the horizontal advection of thickness and tracers"
+ possible_values=".true. or .false."
+ />
+ <nml_option name="config_btr_subcycle_loop_factor" type="integer" default_value="2" units="unitless"
+ description="Barotropic subcycles proceed from $t$ to $t+n\Delta t$, where $n$ is this configuration option."
+ possible_values="Any positive integer, but typically 1 or 2"
+ />
+ <nml_option name="config_btr_gam1_uWt1" type="real" default_value="0.5" units="unitless"
+ description="Weighting of velocity in the SSH predictor step in stage 2. When zero, previous subcycle time is used; when one, new subcycle time is used."
+ possible_values="between 0 and 1"
+ />
+ <nml_option name="config_btr_gam2_SSHWt1" type="real" default_value="1.0" units="unitless"
+ description="Weighting of SSH in the velocity corrector step in stage 2. When zero, previous subcycle time is used; when one, new subcycle time is used."
+ possible_values="between 0 and 1"
+ />
+ <nml_option name="config_btr_gam3_uWt2" type="real" default_value="1.0" units="unitless"
+ description="Weighting of velocity in the SSH corrector step in stage 2. When zero, previous subcycle time is used; when one, new subcycle time is used."
+ possible_values="between 0 and 1"
+ />
+ <nml_option name="config_btr_solve_SSH2" type="logical" default_value=".false." units="unitless"
+ description="If true, execute the SSH corrector step in stage 2"
+ possible_values=".true. or .false."
+ />
+ </nml_record>
+ <nml_record name="debug">
+ <nml_option name="config_check_zlevel_consistency" type="logical" default_value=".false." units="unitless"
+ description="Enables a run-time check for consistency for a zlevel grid. Ensures relevant variables correctly define the bottom of the ocean."
+ possible_values=".true. or .false."
+ />
+ <nml_option name="config_filter_btr_mode" type="logical" default_value=".false." units="unitless"
+ description="Enables filtering of the barotropic mode."
+ possible_values=".true. or .false."
+ />
+ <nml_option name="config_prescribe_velocity" type="logical" default_value=".false." units="unitless"
+ description="Enables a prescribed velocity field. This velocity field is read on input, and remains constant through a simulation."
+ possible_values=".true. or .false."
+ />
+ <nml_option name="config_prescribe_thickness" type="logical" default_value=".false." units="unitless"
+ description="Enables a prescribed thickness field. This thickness field is read on input, and remains constant through a simulation."
+ possible_values=".true. or .false."
+ />
+ <nml_option name="config_include_KE_vertex" type="logical" default_value=".false." units="unitless"
+ description=""
+ possible_values=".true. or .false."
+ />
+ <nml_option name="config_check_tracer_monotonicity" type="logical" default_value=".false." units="unitless"
+ description="Enables a change on tracer monotonicity at the end of the monotonic advection routine. Only used if config_monotonic is set to .true."
+ possible_values=".true. or .false."
+ />
+ <nml_option name="config_disable_h_all_tend" type="logical" default_value=".false." units="unitless"
+ description="Disables all tendencies on the thickness field."
+ possible_values=".true. or .false."
+ />
+ <nml_option name="config_disable_h_hadv" type="logical" default_value=".false." units="unitless"
+ description="Disable tendencies on the thickness field from horizontal advection."
+ possible_values=".true. or .false."
+ />
+ <nml_option name="config_disable_h_vadv" type="logical" default_value=".false." units="unitless"
+ description="Disables tendencies on the thickness field from vertical advection."
+ possible_values=".true. or .false."
+ />
+ <nml_option name="config_disable_u_all_tend" type="logical" default_value=".false." units="unitless"
+ description="Disables all tendencies on the velocity field."
+ possible_values=".true. or .false."
+ />
+ <nml_option name="config_disable_u_coriolis" type="logical" default_value=".false." units="unitless"
+ description="Diables tendencies on the velocity field from the Coriolis force."
+ possible_values=".true. or .false."
+ />
+ <nml_option name="config_disable_u_pgrad" type="logical" default_value=".false." units="unitless"
+ description="Disables tendencies on the velocity field from the horizontal pressure gradient."
+ possible_values=".true. or .false."
+ />
+ <nml_option name="config_disable_u_hmix" type="logical" default_value=".false." units="unitless"
+ description="Disables tendencies on the velocity field from horizontal mixing."
+ possible_values=".true. or .false."
+ />
+ <nml_option name="config_disable_u_windstress" type="logical" default_value=".false." units="unitless"
+ description="Disables tendencies on the velocity field from horizontal wind stress."
+ possible_values=".true. or .false."
+ />
+ <nml_option name="config_disable_u_vmix" type="logical" default_value=".false." units="unitless"
+ description="Disables tendencies on the velocity field from vertical mixing."
+ possible_values=".true. or .false."
+ />
+ <nml_option name="config_disable_u_vadv" type="logical" default_value=".false." units="unitless"
+ description="Disables tendencies on the velocity field from vertical advection."
+ possible_values=".true. or .false."
+ />
+ <nml_option name="config_disable_tr_all_tend" type="logical" default_value=".false." units="unitless"
+ description="Disables all tendencies on tracer fields."
+ possible_values=".true. or .false."
+ />
+ <nml_option name="config_disable_tr_adv" type="logical" default_value=".false." units="unitless"
+ description="Disables tendencies on tracer fields from advection, both horizontal and vertical."
+ possible_values=".true. or .false."
+ />
+ <nml_option name="config_disable_tr_hmix" type="logical" default_value=".false." units="unitless"
+ description="Disables tendencies on tracer fields from horizontal mixing."
+ possible_values=".true. or .false."
+ />
+ <nml_option name="config_disable_tr_vmix" type="logical" default_value=".false." units="unitless"
+ description="Disables tendencies on tracer fields from vertical mixing."
+ possible_values=".true. or .false."
+ />
+ </nml_record>
+ <var_struct name="state" time_levs="2">
+ <var_array name="tracers" type="real" dimensions="nVertLevels nCells Time">
+ <var name="temperature" array_group="dynamics" streams="iro" units="degrees Celsius"
+ description="potential temperature"
+ />
+ <var name="salinity" array_group="dynamics" streams="iro" units="grams salt per kilogram seawater"
+ description="salinity"
+ />
+ <var name="tracer1" array_group="testing" streams="iro" units="unitless"
+ description="A tracer with value 1.0 to test conservation. {\color{red} REMOVE THIS VARIABLE}"
+ />
+ </var_array>
+ <var name="xtime" type="text" dimensions="Time" streams="ro" units="unitless"
+ description="model time, with format 'YYYY-MM-DD_HH:MM:SS'"
+ />
+ <var name="u" type="real" dimensions="nVertLevels nEdges Time" streams="ir" units="m s^{-1}"
+ description="horizonal velocity, normal component to an edge"
+ />
+ <var name="h" type="real" dimensions="nVertLevels nCells Time" streams="iro" units="m"
+ description="layer thickness"
+ />
+ <var name="rho" type="real" dimensions="nVertLevels nCells Time" streams="iro" units="kg m^{-3}"
+ description="density"
+ />
+ <var name="uBtr" type="real" dimensions="nEdges Time" streams="r" units="m s^{-1}"
+ description="barotropic velocity, used in split-explicit time-stepping"
+ />
+ <var name="ssh" type="real" dimensions="nCells Time" streams="o" units="m"
+ description="sea surface height"
+ />
+ <var name="uBtrSubcycle" type="real" dimensions="nEdges Time" units="m s^{-1}"
+ description="barotropic velocity, used in subcycling in stage 2 of split-explicit time-stepping"
+ />
+ <var name="sshSubcycle" type="real" dimensions="nCells Time" units="m"
+ description="sea surface height, used in subcycling in stage 2 of split-explicit time-stepping"
+ />
+ <var name="FBtr" type="real" dimensions="nEdges Time" units="m^2 s^{-1}"
+ description="Barotropic thickness flux at each edge, used to advance sea surface height in each subcycle of stage 2 of the split-explicit algorithm."
+ />
+ <var name="GBtrForcing" type="real" dimensions="nEdges Time" units="m s^{-2}"
+ description="Barotropic tendency computed from the baroclinic equations in stage 1 of the split-explicit algorithm."
+ />
+ <var name="uBcl" type="real" dimensions="nVertLevels nEdges Time" units="m s^{-1}"
+ description="baroclinic velocity, used in split-explicit time-stepping"
+ />
+ <var name="zMid" type="real" dimensions="nVertLevels nCells Time" units="m"
+ description="z-coordinate of the mid-depth of the layer"
+ />
+ <var name="v" type="real" dimensions="nVertLevels nEdges Time" units="m s^{-1}"
+ description="horizontal velocity, tangential to an edge"
+ />
+ <var name="uTransport" type="real" dimensions="nVertLevels nEdges Time" units="m s^{-1}"
+ description="horizontal velocity used to transport mass and tracers"
+ />
+ <var name="uBolusGM" type="real" dimensions="nVertLevels nEdges Time" units=""
+ description=""
+ />
+ <var name="uBolusGMX" type="real" dimensions="nVertLevels nEdges Time" units=""
+ description=""
+ />
+ <var name="uBolusGMY" type="real" dimensions="nVertLevels nEdges Time" units=""
+ description=""
+ />
+ <var name="uBolusGMZ" type="real" dimensions="nVertLevels nEdges Time" units=""
+ description=""
+ />
+ <var name="uBolusGMZonal" type="real" dimensions="nVertLevels nEdges Time" streams="o" units=""
+ description=""
+ />
+ <var name="uBolusGMMeridional" type="real" dimensions="nVertLevels nEdges Time" streams="o" units=""
+ description=""
+ />
+ <var name="hEddyFlux" type="real" dimensions="nVertLevels nEdges Time" units=""
+ description=""
+ />
+ <var name="h_kappa" type="real" dimensions="nVertLevels nEdges Time" units=""
+ description=""
+ />
+ <var name="h_kappa_q" type="real" dimensions="nVertLevels nEdges Time" units=""
+ description=""
+ />
+ <var name="divergence" type="real" dimensions="nVertLevels nCells Time" streams="o" units="s^{-1}"
+ description="divergence of horizonal velocity"
+ />
+ <var name="vorticity" type="real" dimensions="nVertLevels nVertices Time" streams="o" units="s^{-1}"
+ description="curl of horizontal velocity"
+ />
+ <var name="Vor_edge" type="real" dimensions="nVertLevels nEdges Time" units="s^{-1}"
+ description="vorticity averaged from vertices to edges"
+ />
+ <var name="h_edge" type="real" dimensions="nVertLevels nEdges Time" units="m"
+ description="layer thickness averaged from cell center to edges"
+ />
+ <var name="h_vertex" type="real" dimensions="nVertLevels nVertices Time" units="m"
+ description="layer thickness averaged from cell center to vertices"
+ />
+ <var name="ke" type="real" dimensions="nVertLevels nCells Time" streams="o" units="m^2 s^{-2}"
+ description="kinetic energy of horizonal velocity"
+ />
+ <var name="kev" type="real" dimensions="nVertLevels nVertices Time" streams="o" units="m^2 s^{-2}"
+ description="kinetic energy of horizonal velocity defined at vertices"
+ />
+ <var name="kevc" type="real" dimensions="nVertLevels nCells Time" streams="o" units="m^2 s^{-2}"
+ description="kinetic energy of horizonal velocity defined at vertices"
+ />
+ <var name="ke_edge" type="real" dimensions="nVertLevels nEdges Time" units="m^2 s^{-2}"
+ description="kinetic energy of horizonal velocity defined at edges"
+ />
+ <var name="Vor_vertex" type="real" dimensions="nVertLevels nVertices Time" units="s^{-1}"
+ description="curl of horizontal velocity defined at vertices"
+ />
+ <var name="Vor_cell" type="real" dimensions="nVertLevels nCells Time" streams="o" units="s^{-1}"
+ description="curl of horizontal velocity defined at cell centers"
+ />
+ <var name="uReconstructX" type="real" dimensions="nVertLevels nCells Time" units="m s^{-1}"
+ description="component of horizontal velocity in the x-direction (cartesian)"
+ />
+ <var name="uReconstructY" type="real" dimensions="nVertLevels nCells Time" units="m s^{-1}"
+ description="component of horizontal velocity in the y-direction (cartesian)"
+ />
+ <var name="uReconstructZ" type="real" dimensions="nVertLevels nCells Time" units="m s^{-1}"
+ description="component of horizontal velocity in the z-direction (cartesian)"
+ />
+ <var name="uReconstructZonal" type="real" dimensions="nVertLevels nCells Time" streams="o" units="m s^{-1}"
+ description="component of horizontal velocity in the eastward direction"
+ />
+ <var name="uReconstructMeridional" type="real" dimensions="nVertLevels nCells Time" streams="o" units="m s^{-1}"
+ description="component of horizontal velocity in the northward"
+ />
+ <var name="uSrcReconstructX" type="real" dimensions="nVertLevels nCells Time" units="N m^{-2}"
+ description="wind stress in the x-direction (cartesian)"
+ />
+ <var name="uSrcReconstructY" type="real" dimensions="nVertLevels nCells Time" units="N m^{-2}"
+ description="wind stress in the y-direction (cartesian)"
+ />
+ <var name="uSrcReconstructZ" type="real" dimensions="nVertLevels nCells Time" units="N m^{-2}"
+ description="wind stress in the z-direction (cartesian)"
+ />
+ <var name="uSrcReconstructZonal" type="real" dimensions="nVertLevels nCells Time" streams="o" units="N m^{-2}"
+ description="wind stress in the eastward direction"
+ />
+ <var name="uSrcReconstructMeridional" type="real" dimensions="nVertLevels nCells Time" streams="o" units="N m^{-2}"
+ description="wind stress in the northward direction"
+ />
+ <var name="MontPot" type="real" dimensions="nVertLevels nCells Time" units="m^2 s^{-2}"
+ description="Montgomery potential, may be used as the pressure for isopycnal coordinates."
+ />
+ <var name="pressure" type="real" dimensions="nVertLevels nCells Time" units="N m^{-2}"
+ description="pressure used in the momentum equation"
+ />
+ <var name="wTop" type="real" dimensions="nVertLevelsP1 nCells Time" units="m s^{-1}"
+ description="vertical transport through the layer interface at the top of the cell"
+ />
+ <var name="vertVelocityTop" type="real" dimensions="nVertLevelsP1 nCells Time" units="m s^{-1}"
+ description="vertical velocity defined at center (horizonally) and top (vertically) of cell"
+ />
+ <var name="rhoDisplaced" type="real" dimensions="nVertLevels nCells Time" units="kg m^{-3}"
+ description="potential density displaced to the mid-depth of top layer"
+ />
+ <var name="BruntVaisalaFreqTop" type="real" dimensions="nVertLevels nCells Time" streams="o" units="s^{-2}"
+ description="Brunt Vaisala frequency defined at the center (horizontally) and top (vertically) of cell"
+ />
+ <var name="viscosity" type="real" dimensions="nVertLevels nEdges Time" streams="o" units="m^2 s^{-1}"
+ description="horizontal viscosity"
+ />
+ <var name="vh" type="real" dimensions="nVertLevels nEdges Time" units="m^2 s^{-1}"
+ description="thickness flux in the tangent direction (from vertex1 to vertex2)"
+ />
+ <var name="circulation" type="real" dimensions="nVertLevels nVertices Time" units="m^2 s^{-1}"
+ description="area-integrated vorticity"
+ />
+ <var name="gradVor_t" type="real" dimensions="nVertLevels nEdges Time" units="s^{-1} m^{-1}"
+ description="gradient of vorticity in the tangent direction (from vertex1 to vertex2)"
+ />
+ <var name="gradVor_n" type="real" dimensions="nVertLevels nEdges Time" units="s^{-1} m^{-1}"
+ description="gradient of vorticity in the normal direction (from cell1 to cell2)"
+ />
+ <var name="areaCellGlobal" type="real" dimensions="Time" streams="o" units="m^2"
+ description="sum of the areaCell variable over the full domain, used to normalize global statistics"
+ />
+ <var name="areaEdgeGlobal" type="real" dimensions="Time" streams="o" units="m^2"
+ description="sum of the areaEdge variable over the full domain, used to normalize global statistics"
+ />
+ <var name="areaTriangleGlobal" type="real" dimensions="Time" streams="o" units="m^2"
+ description="sum of the areaTriangle variable over the full domain, used to normalize global statistics"
+ />
+ <var name="volumeCellGlobal" type="real" dimensions="Time" streams="o" units="m^3"
+ description="sum of the volumeCell variable over the full domain, used to normalize global statistics"
+ />
+ <var name="volumeEdgeGlobal" type="real" dimensions="Time" streams="o" units="m^3"
+ description="sum of the volumeEdge variable over the full domain, used to normalize global statistics"
+ />
+ <var name="CFLNumberGlobal" type="real" dimensions="Time" streams="o" units="unitless"
+ description="maximum CFL number over the full domain"
+ />
+ <var name="nAccumulate" type="real" dimensions="Time" streams="o" units="unitless"
+ description="number of timesteps in time-averaged variables"
+ />
+ <var name="acc_ssh" type="real" dimensions="nCells Time" streams="o" units="m"
+ description="time-averaged sea surface height"
+ />
+ <var name="acc_sshVar" type="real" dimensions="nCells Time" streams="o" units="m"
+ description="variance of sea surface height"
+ />
+ <var name="acc_uReconstructZonal" type="real" dimensions="nVertLevels nCells Time" streams="o" units="m s^{-1}"
+ description="time-averaged velocity in the eastward direction"
+ />
+ <var name="acc_uReconstructMeridional" type="real" dimensions="nVertLevels nCells Time" streams="o" units="m s^{-1}"
+ description="time-averaged velocity in the northward direction"
+ />
+ <var name="acc_uReconstructZonalVar" type="real" dimensions="nVertLevels nCells Time" streams="o" units="m s^{-1}"
+ description="variance of velocity in the eastward direction"
+ />
+ <var name="acc_uReconstructMeridionalVar" type="real" dimensions="nVertLevels nCells Time" streams="o" units="m s^{-1}"
+ description="variance of velocity in the northward direction"
+ />
+ <var name="acc_u" type="real" dimensions="nVertLevels nEdges Time" streams="o" units="m s^{-1}"
+ description="time-averaged velocity, normal to cell edge"
+ />
+ <var name="acc_uVar" type="real" dimensions="nVertLevels nEdges Time" streams="o" units="m s^{-1}"
+ description="variance of velocity, normal to cell edge"
+ />
+ <var name="acc_vertVelocityTop" type="real" dimensions="nVertLevelsP1 nCells Time" streams="o" units="m s^{-1}"
+ description="time-averaged vertical velocity at top of cell"
+ />
+ </var_struct>
+ <var_struct name="mesh" time_levs="0">
+ <var name="latCell" type="real" dimensions="nCells" streams="iro" units="radians"
+ description="Latitude location of cell centers in radians."
+ />
+ <var name="lonCell" type="real" dimensions="nCells" streams="iro" units="radians"
+ description="Longitude location of cell centers in radians."
+ />
+ <var name="xCell" type="real" dimensions="nCells" streams="iro" units="unitless"
+ description="X Coordinate in cartesian space of cell centers."
+ />
+ <var name="yCell" type="real" dimensions="nCells" streams="iro" units="unitless"
+ description="Y Coordinate in cartesian space of cell centers."
+ />
+ <var name="zCell" type="real" dimensions="nCells" streams="iro" units="unitless"
+ description="Z Coordinate in cartesian space of cell centers."
+ />
+ <var name="indexToCellID" type="integer" dimensions="nCells" streams="iro" units="unitless"
+ description="List of global cell IDs."
+ />
+ <var name="latEdge" type="real" dimensions="nEdges" streams="iro" units="radians"
+ description="Latitude location of edge midpoints in radians."
+ />
+ <var name="lonEdge" type="real" dimensions="nEdges" streams="iro" units="radians"
+ description="Longitude location of edge midpoints in radians."
+ />
+ <var name="xEdge" type="real" dimensions="nEdges" streams="iro" units="unitless"
+ description="X Coordinate in cartesian space of edge midpoints."
+ />
+ <var name="yEdge" type="real" dimensions="nEdges" streams="iro" units="unitless"
+ description="Y Coordinate in cartesian space of edge midpoints."
+ />
+ <var name="zEdge" type="real" dimensions="nEdges" streams="iro" units="unitless"
+ description="Z Coordinate in cartesian space of edge midpoints."
+ />
+ <var name="indexToEdgeID" type="integer" dimensions="nEdges" streams="iro" units="unitless"
+ description="List of global edge IDs."
+ />
+ <var name="latVertex" type="real" dimensions="nVertices" streams="iro" units="radians"
+ description="Latitude location of vertices in radians."
+ />
+ <var name="lonVertex" type="real" dimensions="nVertices" streams="iro" units="radians"
+ description="Longitude location of vertices in radians."
+ />
+ <var name="xVertex" type="real" dimensions="nVertices" streams="iro" units="unitless"
+ description="X Coordinate in cartesian space of vertices."
+ />
+ <var name="yVertex" type="real" dimensions="nVertices" streams="iro" units="unitless"
+ description="Y Coordinate in cartesian space of vertices."
+ />
+ <var name="zVertex" type="real" dimensions="nVertices" streams="iro" units="unitless"
+ description="Z Coordinate in cartesian space of vertices."
+ />
+ <var name="indexToVertexID" type="integer" dimensions="nVertices" streams="iro" units="unitless"
+ description="List of global vertex IDs."
+ />
+ <var name="meshDensity" type="real" dimensions="nCells" streams="iro" units="unitless"
+ description="Value of density function used to generate a particular mesh at cell centers."
+ />
+ <var name="meshScalingDel2" type="real" dimensions="nEdges" streams="ro" units="unitless"
+ description="Coefficient to Laplacian mixing terms in momentum and tracer equations, so that viscosity and diffusion scale with mesh."
+ />
+ <var name="meshScalingDel4" type="real" dimensions="nEdges" streams="ro" units="unitless"
+ description="Coefficient to biharmonic mixing terms in momentum and tracer equations, so that biharmonic viscosity and diffusion coefficients scale with mesh."
+ />
+ <var name="meshScaling" type="real" dimensions="nEdges" streams="ro" units="unitless"
+ description="Coefficient used for mesh scaling, such as the Leith parameter."
+ />
+ <var name="cellsOnEdge" type="integer" dimensions="TWO nEdges" streams="iro" units="unitless"
+ description="List of cells that straddle each edge."
+ />
+ <var name="nEdgesOnCell" type="integer" dimensions="nCells" streams="iro" units="unitless"
+ description="Number of edges that border each cell."
+ />
+ <var name="nEdgesOnEdge" type="integer" dimensions="nEdges" streams="iro" units="unitless"
+ description="Number of edges that surround each of the cells that straddle each edge. These edges are used to reconstruct the tangential velocities."
+ />
+ <var name="edgesOnCell" type="integer" dimensions="maxEdges nCells" streams="iro" units="unitless"
+ description="List of edges that border each cell."
+ />
+ <var name="edgesOnEdge" type="integer" dimensions="maxEdges2 nEdges" streams="iro" units="unitless"
+ description="List of edges that border each of the cells that straddle each edge."
+ />
+ <var name="weightsOnEdge" type="real" dimensions="maxEdges2 nEdges" streams="iro" units="unitless"
+ description="Reconstruction weights associated with each of the edgesOnEdge."
+ />
+ <var name="dvEdge" type="real" dimensions="nEdges" streams="iro" units="m"
+ description="Length of each edge, computed as the distance between verticesOnEdge."
+ />
+ <var name="dcEdge" type="real" dimensions="nEdges" streams="iro" units="m"
+ description="Length of each edge, computed as the distance between cellsOnEdge."
+ />
+ <var name="angleEdge" type="real" dimensions="nEdges" streams="iro" units="radians"
+ description="Angle the edge normal makes with local eastward direction."
+ />
+ <var name="areaCell" type="real" dimensions="nCells" streams="iro" units="m^2"
+ description="Area of each cell in the primary grid."
+ />
+ <var name="areaTriangle" type="real" dimensions="nVertices" streams="iro" units="m^2"
+ description="Area of each cell (triangle) in the dual grid."
+ />
+ <var name="edgeNormalVectors" type="real" dimensions="R3 nEdges" streams="o" units="unitless"
+ description="Normal vector defined at an edge."
+ />
+ <var name="localVerticalUnitVectors" type="real" dimensions="R3 nCells" streams="o" units="unitless"
+ description="Unit surface normal vectors defined at cell centers."
+ />
+ <var name="cellTangentPlane" type="real" dimensions="R3 TWO nCells" streams="o" units="unitless"
+ description="The two vectors that define a tangent plane at a cell center."
+ />
+ <var name="cellsOnCell" type="integer" dimensions="maxEdges nCells" streams="iro" units="unitless"
+ description="List of cells that neighbor each cell."
+ />
+ <var name="verticesOnCell" type="integer" dimensions="maxEdges nCells" streams="iro" units="unitless"
+ description="List of vertices that border each cell."
+ />
+ <var name="verticesOnEdge" type="integer" dimensions="TWO nEdges" streams="iro" units="unitless"
+ description="List of vertices that straddle each edge."
+ />
+ <var name="edgesOnVertex" type="integer" dimensions="vertexDegree nVertices" streams="iro" units="unitless"
+ description="List of edges that share a vertex as an endpoint."
+ />
+ <var name="cellsOnVertex" type="integer" dimensions="vertexDegree nVertices" streams="iro" units="unitless"
+ description="List of cells that share a vertex."
+ />
+ <var name="kiteAreasOnVertex" type="real" dimensions="vertexDegree nVertices" streams="iro" units="m^2"
+ description="Area of the portions of each dual cell that are part of each cellsOnVertex."
+ />
+ <var name="fEdge" type="real" dimensions="nEdges" streams="iro" units="s^{-1}"
+ description="Coriolis parameter at edges."
+ />
+ <var name="fVertex" type="real" dimensions="nVertices" streams="iro" units="s^{-1}"
+ description="Coriolis parameter at vertices."
+ />
+ <var name="bottomDepth" type="real" dimensions="nCells" streams="iro" units="m"
+ description="Depth of the bottom of the ocean. Given as a positive distance from sea level."
+ />
+ <var name="deriv_two" type="real" dimensions="maxEdges2 TWO nEdges" units="m^{-2}"
+ description="Value of the second derivative of the polynomial used for reconstruction of cell center quantities at edges."
+ />
+ <var name="adv_coefs" type="real" dimensions="nAdvectionCells nEdges" units="m"
+ description="Weighting coefficients used for reconstruction of cell center quantities at edges. Used in advection routines."
+ />
+ <var name="adv_coefs_2nd" type="real" dimensions="nAdvectionCells nEdges" units="m"
+ description="Weighting coefficients used for reconstruction of cell center quantities at edges. Used in advection routines."
+ />
+ <var name="adv_coefs_3rd" type="real" dimensions="nAdvectionCells nEdges" units="m"
+ description="Wegihting coefficients used for reconstruction of cell center quantities at edges. Used in advection routines."
+ />
+ <var name="advCellsForEdge" type="integer" dimensions="nAdvectionCells nEdges" units="unitless"
+ description="List of cells used to reconstruct a cell quantity at an edge. Used in advection routines."
+ />
+ <var name="nAdvCellsForEdge" type="integer" dimensions="nEdges" units="unitless"
+ description="Number of cells used in reconstruction of cell center quantities at an edge. Used in advection routines."
+ />
+ <var name="highOrderAdvectionMask" type="integer" dimensions="nVertLevels nEdges" units="unitless"
+ description="Mask for high order advection. Values are 1 if high order is used, and 0 if not."
+ />
+ <var name="lowOrderAdvectionMask" type="integer" dimensions="nVertLevels nEdges" units="unitless"
+ description="Mask for low order advection. Values are 1 if low order is used, and 0 if not."
+ />
+ <var name="defc_a" type="real" dimensions="maxEdges nCells" units="m^{-1}"
+ description="Variable used with advection setup to compute advection coefficients. Deformation weight coefficients."
+ />
+ <var name="defc_b" type="real" dimensions="maxEdges nCells" units="m^{-1}"
+ description="Variable used with advection setup to compute advection coefficients. Deformation weight coefficients."
+ />
+ <var name="kdiff" type="real" dimensions="nVertLevels nCells Time" units=""
+ description="{\color{red} TO BE REMOVED}"
+ />
+ <var name="coeffs_reconstruct" type="real" dimensions="R3 maxEdges nCells" units="unitless"
+ description="Coefficients to reconstruct velocity vectors at cells centers."
+ />
+ <var name="maxLevelCell" type="integer" dimensions="nCells" streams="iro" units="unitless"
+ description="Index to the last active ocean cell in each column."
+ />
+ <var name="maxLevelEdgeTop" type="integer" dimensions="nEdges" units="unitless"
+ description="Index to the last edge in a column with active ocean cells on both sides of it."
+ />
+ <var name="maxLevelEdgeBot" type="integer" dimensions="nEdges" units="unitless"
+ description="Index to the last edge in a column with at least one active ocean cell on either side of it."
+ />
+ <var name="maxLevelVertexTop" type="integer" dimensions="nVertices" units="unitless"
+ description="Index to the last vertex in a column with all active cells around it."
+ />
+ <var name="maxLevelVertexBot" type="integer" dimensions="nVertices" units="unitless"
+ description="Index to the last vertex in a column with at least one active ocean cell around it."
+ />
+ <var name="refBottomDepth" type="real" dimensions="nVertLevels" streams="iro" units="m"
+ description="Reference depth of ocean for each vertical level. Used in 'z-level' type runs."
+ />
+ <var name="refBottomDepthTopOfCell" type="real" dimensions="nVertLevelsP1" units="m"
+ description="Reference depth of ocean for each vertical interface. Used in 'z-level' type runs."
+ />
+ <var name="hZLevel" type="real" dimensions="nVertLevels" streams="iro" units="m"
+ description="{\color{red} TO BE REMOVED}"
+ />
+ <var name="vertCoordMovementWeights" type="real" dimensions="nVertLevels" streams="iro" units="unitless"
+ description="Weights used for distribution of sea surface heigh purturbations through multiple vertical levels."
+ />
+ <var name="boundaryEdge" type="integer" dimensions="nVertLevels nEdges" units="unitless"
+ description="Mask for determining boundary edges. A boundary edge has only one active ocean cell neighboring it."
+ />
+ <var name="boundaryVertex" type="integer" dimensions="nVertLevels nVertices" units="unitless"
+ description="Mask for determining boundary vertices. A boundary vertex has at least one inactive cell neighboring it."
+ />
+ <var name="boundaryCell" type="integer" dimensions="nVertLevels nCells" units="unitless"
+ description="Mask for determining boundary cells. A boundary cell has at least one inactive cell neighboring it."
+ />
+ <var name="edgeMask" type="integer" dimensions="nVertLevels nEdges" streams="o" units="unitless"
+ description="Mask on edges that determines if computations should be done on edge."
+ />
+ <var name="vertexMask" type="integer" dimensions="nVertLevels nVertices" streams="o" units="unitless"
+ description="Mask on vertices that determines if computations should be done on vertice."
+ />
+ <var name="cellMask" type="integer" dimensions="nVertLevels nCells" streams="o" units="unitless"
+ description="Mask on cells that determines if computations should be done on cell."
+ />
+ <var name="u_src" type="real" dimensions="nVertLevels nEdges" streams="ir" units="N m^{-2}"
+ description="Velocity forcing field. Defines a forcing at an edge."
+ />
+ <var name="temperatureRestore" type="real" dimensions="nCells" streams="ir" units="^\circ C"
+ description="Temperature restoring field, for restoring temperature at the surface."
+ />
+ <var name="salinityRestore" type="real" dimensions="nCells" streams="ir" units="PSU"
+ description="Salinity restoring field, for restoring salinity at the surface."
+ />
+ <var name="windStressMonthly" type="real" dimensions="nMonths nEdges" streams="ir" units="N m^{-2}"
+ description="Monthly wind stress field, defined at the surface for use in monthly forcing."
+ />
+ <var name="temperatureRestoreMonthly" type="real" dimensions="nMonths nCells" streams="ir" units="^\circ C"
+ description="Monthly temperature restorying field, defined at the surface for use in monthly forcing."
+ />
+ <var name="salinityRestoreMonthly" type="real" dimensions="nMonths nCells" streams="ir" units="PSU"
+ description="Monthly salinity resotring field, defined at the surface, for use in monthly forcing."
+ />
+ <var name="edgeSignOnCell" type="integer" dimensions="maxEdges nCells" units="unitless"
+ description="Sign of edge contributions to a cell for each edge on cell. Used for bit-reproducible loops. Represents directionality of vector connecting cells."
+ />
+ <var name="edgeSignOnVertex" type="integer" dimensions="maxEdges nVertices" units="unitless"
+ description="Sign of edge contributions to a vertex for each edge on vertex. Used for bit-reproducible loops. Represents directionality of vector connecting vertices."
+ />
+ <var name="kiteIndexOnCell" type="integer" dimensions="maxEdges nCells" units="unitless"
+ description="Index of kite in dual grid, based on verticesOnCell."
+ />
+ <var name="seaSurfacePressure" type="real" dimensions="nCells Time" streams="ir" units="Pa"
+ description="Pressure defined at the sea surface."
+ />
+ </var_struct>
+ <var_struct name="tend" time_levs="1">
+ <var_array name="tracers" type="real" dimensions="nVertLevels nCells Time">
+ <var name="tend_temperature" array_group="dynamics" units="K s^{-1}" name_in_code="temperature"
+ description="time tendency of potential temperature"
+ />
+ <var name="tend_salinity" array_group="dynamics" units="PSU s^{-1}" name_in_code="salinity"
+ description="time tendency of salinity measured as change in practical salinity units per second"
+ />
+ <var name="tend_tracer1" array_group="testing" units="tracer s^{-1}" name_in_code="tracer1"
+ description="time tendency of an arbitary tracer"
+ />
+ </var_array>
+ <var name="tend_u" type="real" dimensions="nVertLevels nEdges Time" units="m s^{-2}" name_in_code="u"
+ description="time tendency of normal component of velocity"
+ />
+ <var name="tend_h" type="real" dimensions="nVertLevels nCells Time" units="m s^{-1}" name_in_code="h"
+ description="time tendency of layer thickness"
+ />
+ <var name="tend_ssh" type="real" dimensions="nCells Time" units="m s^{-1}" name_in_code="ssh"
+ description="time tendency of sea-surface height"
+ />
+ </var_struct>
+ <var_struct name="diagnostics" time_levs="1">
+ <var name="RiTopOfCell" type="real" dimensions="nVertLevelsP1 nCells Time" units="nondimensional"
+ description="gradient Richardson number defined at the center (horizontally) and top (vertically)"
+ />
+ <var name="RiTopOfEdge" type="real" dimensions="nVertLevelsP1 nEdges Time" units="nondimensional"
+ description="gradient Richardson number defined at the edge (horizontally) and top (vertically)"
+ />
+ <var name="vertViscTopOfEdge" type="real" dimensions="nVertLevelsP1 nEdges Time" units="m^2 s^{-1}"
+ description="vertical viscosity defined at the edge (horizontally) and top (vertically)"
+ />
+ <var name="vertDiffTopOfCell" type="real" dimensions="nVertLevelsP1 nCells Time" units="m^2 s^{-1}"
+ description="vertical diffusion defined at the edge (horizontally) and top (vertically)"
+ />
+ </var_struct>
+ <var_struct name="scratch" time_levs="0">
+ <var name="uTempEdges" type="real" dimensions="nEdges" persistence="scratch" units="m s^{-1}"
+ description="Scratch variable for single layer edge field"
+ />
+ <var name="delsq_u" type="real" dimensions="nVertLevels nEdges" persistence="scratch" units=""
+ description=""
+ />
+ <var name="delsq_vorticity" type="real" dimensions="nVertLevels nVertices" persistence="scratch" units=""
+ description=""
+ />
+ <var name="delsq_divergence" type="real" dimensions="nVertLevels nCells" persistence="scratch" units=""
+ description=""
+ />
+ <var name="uh" type="real" dimensions="nVertLevels nEdges" persistence="scratch" units=""
+ description=""
+ />
+ <var name="high_order_horiz_flux" type="real" dimensions="nVertLevels nEdges" persistence="scratch" units=""
+ description=""
+ />
+ <var name="tracer_new" type="real" dimensions="nVertLevels nCells" persistence="scratch" units=""
+ description=""
+ />
+ <var name="tracer_cur" type="real" dimensions="nVertLevels nCells" persistence="scratch" units=""
+ description=""
+ />
+ <var name="upwind_tendency" type="real" dimensions="nVertLevels nCells" persistence="scratch" units=""
+ description=""
+ />
+ <var name="inv_h_new" type="real" dimensions="nVertLevels nCells" persistence="scratch" units=""
+ description=""
+ />
+ <var name="tracer_max" type="real" dimensions="nVertLevels nCells" persistence="scratch" units=""
+ description=""
+ />
+ <var name="tracer_min" type="real" dimensions="nVertLevels nCells" persistence="scratch" units=""
+ description=""
+ />
+ <var name="flux_incoming" type="real" dimensions="nVertLevels nCells" persistence="scratch" units=""
+ description=""
+ />
+ <var name="flux_outgoing" type="real" dimensions="nVertLevels nCells" persistence="scratch" units=""
+ description=""
+ />
+ <var name="high_order_vert_flux" type="real" dimensions="nVertLevelsP1 nCells" persistence="scratch" units=""
+ description=""
+ />
+ <var name="drhoTopOfCell" type="real" dimensions="nVertLevelsP1 nCells" persistence="scratch" units=""
+ description=""
+ />
+ <var name="drhoTopOfEdge" type="real" dimensions="nVertLevelsP1 nEdges" persistence="scratch" units=""
+ description=""
+ />
+ <var name="du2TopOfCell" type="real" dimensions="nVertLevelsP1 nCells" persistence="scratch" units=""
+ description=""
+ />
+ <var name="du2TopOfEdge" type="real" dimensions="nVertLevelsP1 nEdges" persistence="scratch" units=""
+ description=""
+ />
+ <var_array name="delsq_tracers" type="real" dimensions="nVertLevels nCells" persistence="scratch">
+ <var name="delsq_temperature" dimensions="nVertLevels nCells" array_group="dynamics" units=""
+ description=""
+ />
+ <var name="delsq_salinity" dimensions="nVertLevels nCells" array_group="dynamics" units=""
+ description=""
+ />
+ <var name="delsq_tracer1" dimensions="nVertLevels nCells" array_group="testing" units=""
+ description=""
+ />
+ </var_array>
+ </var_struct>
+</registry>
Copied: branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_diagnostics.F (from rev 2677, trunk/mpas/src/core_ocean/mpas_ocn_diagnostics.F)
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_diagnostics.F (rev 0)
+++ branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_diagnostics.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -0,0 +1,903 @@
+!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
+!
+! ocn_diagnostics
+!
+!> \brief MPAS ocean diagnostics driver
+!> \author Mark Petersen
+!> \date 23 September 2011
+!> \version SVN:$Id:$
+!> \details
+!> This module contains the routines for computing
+!> diagnostic variables, and other quantities such as wTop.
+!
+!-----------------------------------------------------------------------
+
+module ocn_diagnostics
+
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_constants
+ use mpas_timer
+
+ use ocn_gm
+ use ocn_equation_of_state
+
+ implicit none
+ private
+ save
+
+ type (timer_node), pointer :: diagEOSTimer
+
+ !--------------------------------------------------------------------
+ !
+ ! Public parameters
+ !
+ !--------------------------------------------------------------------
+
+ !--------------------------------------------------------------------
+ !
+ ! Public member functions
+ !
+ !--------------------------------------------------------------------
+
+ public :: ocn_diagnostic_solve, &
+ ocn_wtop, &
+ ocn_fuperp, &
+ ocn_filter_btr_mode_u, &
+ ocn_filter_btr_mode_tend_u, &
+ ocn_diagnostics_init
+
+ !--------------------------------------------------------------------
+ !
+ ! Private module variables
+ !
+ !--------------------------------------------------------------------
+
+ integer :: ke_cell_flag, ke_vertex_flag
+ real (kind=RKIND) :: coef_3rd_order, fCoef
+
+!***********************************************************************
+
+contains
+
+!***********************************************************************
+!
+! routine ocn_diagnostic_solve
+!
+!> \brief Computes diagnostic variables
+!> \author Mark Petersen
+!> \date 23 September 2011
+!> \version SVN:$Id$
+!> \details
+!> This routine computes the diagnostic variables for the ocean
+!
+!-----------------------------------------------------------------------
+
+ subroutine ocn_diagnostic_solve(dt, s, grid)!{{{
+ implicit none
+
+ real (kind=RKIND), intent(in) :: dt !< Input: Time step
+ type (state_type), intent(inout) :: s !< Input/Output: State information
+ type (mesh_type), intent(in) :: grid !< Input: Grid information
+
+
+ integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j
+ integer :: boundaryMask, velMask, nCells, nEdges, nVertices, nVertLevels, vertexDegree, err
+
+ integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge, &
+ maxLevelCell, maxLevelEdgeTop, maxLevelEdgeBot, &
+ maxLevelVertexBot
+ integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnVertex, &
+ verticesOnEdge, edgesOnEdge, edgesOnVertex,boundaryCell, kiteIndexOnCell, &
+ verticesOnCell, edgeSignOnVertex, edgeSignOnCell, edgesOnCell
+
+ real (kind=RKIND) :: d2fdx2_cell1, d2fdx2_cell2, coef_3rd_order, r_tmp, &
+ invAreaCell1, invAreaCell2, invAreaTri1, invAreaTri2, invLength, h_vertex, coef
+
+ real (kind=RKIND), dimension(:), allocatable:: pTop, div_hu
+
+ real (kind=RKIND), dimension(:), pointer :: &
+ bottomDepth, fVertex, dvEdge, dcEdge, areaCell, areaTriangle, ssh, seaSurfacePressure
+ real (kind=RKIND), dimension(:,:), pointer :: &
+ weightsOnEdge, kiteAreasOnVertex, h_edge, h, u, v, pressure,&
+ circulation, vorticity, ke, ke_edge, MontPot, wTop, zMid, &
+ Vor_edge, Vor_vertex, Vor_cell, gradVor_n, gradVor_t, divergence, &
+ rho, rhoDisplaced, temperature, salinity, kev, kevc, uBolusGM, uTransport, &
+ vertVelocityTop, BruntVaisalaFreqTop
+ real (kind=RKIND), dimension(:,:,:), pointer :: tracers, deriv_two
+ character :: c1*6
+
+ h => s % h % array
+ u => s % u % array
+ uTransport => s % uTransport % array
+ uBolusGM => s % uBolusGM % array
+ v => s % v % array
+ h_edge => s % h_edge % array
+ circulation => s % circulation % array
+ vorticity => s % vorticity % array
+ divergence => s % divergence % array
+ ke => s % ke % array
+ kev => s % kev % array
+ kevc => s % kevc % array
+ ke_edge => s % ke_edge % array
+ Vor_edge => s % Vor_edge % array
+ Vor_vertex => s % Vor_vertex % array
+ Vor_cell => s % Vor_cell % array
+ gradVor_n => s % gradVor_n % array
+ gradVor_t => s % gradVor_t % array
+ rho => s % rho % array
+ rhoDisplaced=> s % rhoDisplaced % array
+ MontPot => s % MontPot % array
+ pressure => s % pressure % array
+ zMid => s % zMid % array
+ ssh => s % ssh % array
+ tracers => s % tracers % array
+ vertVelocityTop => s % vertVelocityTop % array
+ BruntVaisalaFreqTop => s % BruntVaisalaFreqTop % array
+
+ weightsOnEdge => grid % weightsOnEdge % array
+ kiteAreasOnVertex => grid % kiteAreasOnVertex % array
+ cellsOnEdge => grid % cellsOnEdge % array
+ cellsOnVertex => grid % cellsOnVertex % array
+ verticesOnEdge => grid % verticesOnEdge % array
+ nEdgesOnCell => grid % nEdgesOnCell % array
+ nEdgesOnEdge => grid % nEdgesOnEdge % array
+ edgesOnCell => grid % edgesOnCell % array
+ edgesOnEdge => grid % edgesOnEdge % array
+ edgesOnVertex => grid % edgesOnVertex % array
+ dcEdge => grid % dcEdge % array
+ dvEdge => grid % dvEdge % array
+ areaCell => grid % areaCell % array
+ areaTriangle => grid % areaTriangle % array
+ bottomDepth => grid % bottomDepth % array
+ fVertex => grid % fVertex % array
+ deriv_two => grid % deriv_two % array
+ maxLevelCell => grid % maxLevelCell % array
+ maxLevelEdgeTop => grid % maxLevelEdgeTop % array
+ maxLevelEdgeBot => grid % maxLevelEdgeBot % array
+ maxLevelVertexBot => grid % maxLevelVertexBot % array
+ kiteIndexOnCell => grid % kiteIndexOnCell % array
+ verticesOnCell => grid % verticesOnCell % array
+
+ seaSurfacePressure => grid % seaSurfacePressure % array
+
+ nCells = grid % nCells
+ nEdges = grid % nEdges
+ nVertices = grid % nVertices
+ nVertLevels = grid % nVertLevels
+ vertexDegree = grid % vertexDegree
+
+ boundaryCell => grid % boundaryCell % array
+
+ edgeSignOnVertex => grid % edgeSignOnVertex % array
+ edgeSignOnCell => grid % edgeSignOnCell % array
+
+ !
+ ! Compute height on cell edges at velocity locations
+ ! Namelist options control the order of accuracy of the reconstructed h_edge value
+ !
+
+ ! initialize h_edge to avoid divide by zero and NaN problems.
+ !$OMP WORKSHARE
+ h_edge = -1.0e34
+ !$OMP END WORKSHARE
+ coef_3rd_order = config_coef_3rd_order
+
+ !$OMP DO PRIVATE(cell1, cell2, k)
+ do iEdge=1,nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ do k=1,maxLevelEdgeTop(iEdge)
+ h_edge(k,iEdge) = 0.5 * (h(k,cell1) + h(k,cell2))
+ end do
+ end do
+ !$OMP END DO
+
+ !
+ ! set the velocity and height at dummy address
+ ! used -1e34 so error clearly occurs if these values are used.
+ !
+ !$OMP WORKSHARE
+ u(:,nEdges+1) = -1e34
+ h(:,nCells+1) = -1e34
+ tracers(s % index_temperature,:,nCells+1) = -1e34
+ tracers(s % index_salinity,:,nCells+1) = -1e34
+
+ circulation(:,:) = 0.0
+ vorticity(:,:) = 0.0
+ divergence(:,:) = 0.0
+ vertVelocityTop(:,:)=0.0
+ ke(:,:) = 0.0
+ v(:,:) = 0.0
+ !$OMP END WORKSHARE
+
+ !$OMP DO PRIVATE(invAreaTri1, i, iEdge, k, r_tmp)
+ do iVertex = 1, nVertices
+ invAreaTri1 = 1.0 / areaTriangle(iVertex)
+ do i = 1, vertexDegree
+ iEdge = edgesOnVertex(i, iVertex)
+ do k = 1, maxLevelVertexBot(iVertex)
+ r_tmp = dcEdge(iEdge) * u(k, iEdge)
+
+ circulation(k, iVertex) = circulation(k, iVertex) + edgeSignOnVertex(i, iVertex) * r_tmp
+ vorticity(k, iVertex) = vorticity(k, iVertex) + edgeSignOnVertex(i, iVertex) * r_tmp * invAreaTri1
+ end do
+ end do
+ end do
+ !$OMP END DO
+
+ allocate(div_hu(nVertLevels))
+ !$OMP DO PRIVATE(invAreaCEll1, i, iEdge, k, r_tmp)
+ do iCell = 1, nCells
+ div_hu(:) = 0.0
+ invAreaCell1 = 1.0 / areaCell(iCell)
+ do i = 1, nEdgesOnCell(iCell)
+ iEdge = edgesOnCell(i, iCell)
+ do k = 1, maxLevelCell(iCell)
+ r_tmp = dvEdge(iEdge) * u(k, iEdge) * invAreaCell1
+
+ divergence(k, iCell) = divergence(k, iCell) - edgeSignOnCell(i, iCell) * r_tmp
+ div_hu(k) = div_hu(k) - h_edge(k, iEdge) * edgeSignOnCell(i, iCell) * r_tmp
+ ke(k, iCell) = ke(k, iCell) + 0.25 * r_tmp * dcEdge(iEdge) * u(k,iEdge)
+ end do
+ end do
+ ! Vertical velocity at bottom (maxLevelCell(iCell)+1) is zero, initialized above.
+ do k=maxLevelCell(iCell),1,-1
+ vertVelocityTop(k,iCell) = vertVelocityTop(k+1,iCell) - div_hu(k)
+ end do
+ end do
+ !$OMP END DO
+ deallocate(div_hu)
+
+ !$OMP DO PRIVATE(i, eoe, k)
+ do iEdge=1,nEdges
+ ! Compute v (tangential) velocities
+ do i=1,nEdgesOnEdge(iEdge)
+ eoe = edgesOnEdge(i,iEdge)
+ do k = 1,maxLevelEdgeTop(iEdge)
+ v(k,iEdge) = v(k,iEdge) + weightsOnEdge(i,iEdge) * u(k, eoe)
+ end do
+ end do
+ end do
+ !$OMP END DO
+
+ !
+ ! Compute kinetic energy in each vertex
+ !
+ !$OMP WORKSHARE
+ kev(:,:) = 0.0; kevc(:,:) = 0.0
+ !$OMP END WORKSHARE
+
+ !$OMP DO PRIVATE(i, iEdge, r_tmp, k)
+ do iVertex = 1, nVertices*ke_vertex_flag
+ do i = 1, vertexDegree
+ iEdge = edgesOnVertex(i, iVertex)
+ r_tmp = dcEdge(iEdge) * dvEdge(iEdge) * 0.25 / areaTriangle(iVertex)
+ do k = 1, nVertLevels
+ kev(k, iVertex) = kev(k, iVertex) + r_tmp * u(k, iEdge)**2
+ end do
+ end do
+ end do
+ !$OMP END DO
+
+ !$OMP DO PRIVATE(invAreaCell1, i, j, iVertex, k)
+ do iCell = 1, nCells*ke_vertex_flag
+ invAreaCell1 = 1.0 / areaCell(iCell)
+ do i = 1, nEdgesOnCell(iCell)
+ j = kiteIndexOnCell(i, iCell)
+ iVertex = verticesOnCell(i, iCell)
+ do k = 1, nVertLevels
+ kevc(k, iCell) = kevc(k, iCell) + kiteAreasOnVertex(j, iVertex) * kev(k, iVertex) * invAreaCell1
+ end do
+ end do
+ end do
+ !$OMP END DO
+
+ !
+ ! Compute kinetic energy in each cell by blending ke and kevc
+ !
+ !$OMP DO PRIVATE(k)
+ do iCell=1,nCells*ke_vertex_flag
+ do k=1,nVertLevels
+ ke(k,iCell) = 5.0/8.0*ke(k,iCell) + 3.0/8.0*kevc(k,iCell)
+ end do
+ end do
+ !$OMP END DO
+
+ !
+ ! Compute ke on cell edges at velocity locations for quadratic bottom drag.
+ !
+ !$OMP DO PRIVATE(cell1, cell2, k)
+ do iEdge=1,nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ do k=1,maxLevelEdgeTop(iEdge)
+ ke_edge(k,iEdge) = 0.5 * (ke(k,cell1) + ke(k,cell2))
+ end do
+ end do
+ !$OMP END DO
+
+ !
+ ! Compute height at vertices, pv at vertices, and average pv to edge locations
+ ! ( this computes Vor_vertex at all vertices bounding real cells and distance-1 ghost cells )
+ !
+ !$OMP DO PRIVATE(invAreaTri1, k, h_vertex, i)
+ do iVertex = 1,nVertices
+ invAreaTri1 = 1.0 / areaTriangle(iVertex)
+ do k=1,maxLevelVertexBot(iVertex)
+ h_vertex = 0.0
+ do i=1,vertexDegree
+ h_vertex = h_vertex + h(k,cellsOnVertex(i,iVertex)) * kiteAreasOnVertex(i,iVertex)
+ end do
+ h_vertex = h_vertex * invAreaTri1
+
+ Vor_vertex(k,iVertex) = (fCoef*fVertex(iVertex) + vorticity(k,iVertex)) / h_vertex
+ end do
+ end do
+ !$OMP END DO
+
+ !$OMP WORKSHARE
+ Vor_cell(:,:) = 0.0
+ Vor_edge(:,:) = 0.0
+ !$OMP END WORKSHARE
+
+ !$OMP DO PRIVATE(vertex1, vertex2, k)
+ do iEdge = 1, nEdges
+ vertex1 = verticesOnEdge(1, iEdge)
+ vertex2 = verticesOnEdge(2, iEdge)
+ do k = 1, maxLevelEdgeBot(iEdge)
+ Vor_edge(k, iEdge) = 0.5 * (Vor_vertex(k, vertex1) + Vor_vertex(k, vertex2))
+ end do
+ end do
+ !$OMP END DO
+
+ !$OMP DO PRIVATE(invAreaCell1, i, j, iVertex, k)
+ do iCell = 1, nCells
+ invAreaCell1 = 1.0 / areaCell(iCell)
+
+ do i = 1, nEdgesOnCell(iCell)
+ j = kiteIndexOnCell(i, iCell)
+ iVertex = verticesOnCell(i, iCell)
+ do k = 1, maxLevelCell(iCell)
+ Vor_cell(k, iCell) = Vor_cell(k, iCell) + kiteAreasOnVertex(j, iVertex) * Vor_vertex(k, iVertex) * invAreaCell1
+ end do
+ end do
+ end do
+ !$OMP END DO
+
+ !$OMP DO PRIVATE(cell1, cell2, vertex1, vertex2, invLength, k)
+ do iEdge = 1,nEdges
+ cell1 = cellsOnEdge(1, iEdge)
+ cell2 = cellsOnEdge(2, iEdge)
+ vertex1 = verticesOnedge(1, iEdge)
+ vertex2 = verticesOnedge(2, iEdge)
+
+ invLength = 1.0 / dcEdge(iEdge)
+ ! Compute gradient of PV in normal direction
+ ! ( this computes gradVor_n for all edges bounding real cells )
+ do k=1,maxLevelEdgeTop(iEdge)
+ gradVor_n(k,iEdge) = (Vor_cell(k,cell2) - Vor_cell(k,cell1)) * invLength
+ enddo
+
+ invLength = 1.0 / dvEdge(iEdge)
+ ! Compute gradient of PV in the tangent direction
+ ! ( this computes gradVor_t at all edges bounding real cells and distance-1 ghost cells )
+ do k = 1,maxLevelEdgeBot(iEdge)
+ gradVor_t(k,iEdge) = (Vor_vertex(k,vertex2) - Vor_vertex(k,vertex1)) * invLength
+ enddo
+ enddo
+ !$OMP END DO
+
+ !
+ ! Modify PV edge with upstream bias.
+ !
+ !$OMP DO PRIVATE(k)
+ do iEdge = 1,nEdges
+ do k = 1,maxLevelEdgeBot(iEdge)
+ Vor_edge(k,iEdge) = Vor_edge(k,iEdge) &
+ - config_apvm_scale_factor * dt* ( u(k,iEdge) * gradVor_n(k,iEdge) &
+ + v(k,iEdge) * gradVor_t(k,iEdge) )
+ enddo
+ enddo
+ !$OMP END DO
+
+ !
+ ! equation of state
+ !
+ ! For an isopycnal model, density should remain constant.
+ ! For zlevel, calculate in-situ density
+ if (config_vert_coord_movement.ne.'isopycnal') then
+ !$OMP SINGLE
+ call mpas_timer_start("equation of state", .false., diagEOSTimer)
+ !$OMP END SINGLE
+
+ ! compute in-place density
+ call ocn_equation_of_state_rho(s, grid, 0, 'relative', err)
+
+ ! compute rhoDisplaced, the potential density referenced to the top layer
+ call ocn_equation_of_state_rho(s, grid, 1, 'relative', err)
+
+ !$OMP SINGLE
+ call mpas_timer_stop("equation of state", diagEOSTimer)
+ !$OMP END SINGLE
+ endif
+
+ !
+ ! Pressure
+ ! This section must be after computing rho
+ !
+ if (config_pressure_gradient_type.eq.'MontgomeryPotential') then
+
+ ! For Isopycnal model.
+ ! Compute pressure at top of each layer, and then
+ ! Montgomery Potential.
+ allocate(pTop(nVertLevels))
+ !$OMP DO PRIVATE(k)
+ do iCell=1,nCells
+
+ ! assume atmospheric pressure at the surface is zero for now.
+ pTop(1) = 0.0
+ ! For isopycnal mode, p is the Montgomery Potential.
+ ! At top layer it is g*SSH, where SSH may be off by a
+ ! constant (ie, bottomDepth can be relative to top or bottom)
+ MontPot(1,iCell) = gravity &
+ * (bottomDepth(iCell) + sum(h(1:nVertLevels,iCell)))
+
+ do k=2,nVertLevels
+ pTop(k) = pTop(k-1) + rho(k-1,iCell)*gravity* h(k-1,iCell)
+
+ ! from delta M = p delta / rho
+ MontPot(k,iCell) = MontPot(k-1,iCell) &
+ + pTop(k)*(1.0/rho(k,iCell) - 1.0/rho(k-1,iCell))
+ end do
+
+ end do
+ !$OMP END DO
+ deallocate(pTop)
+
+ else
+
+ !$OMP DO PRIVATE(k)
+ do iCell=1,nCells
+ ! Pressure for generalized coordinates.
+ ! Pressure at top surface may be due to atmospheric pressure
+ ! or an ice-shelf depression.
+ pressure(1,iCell) = seaSurfacePressure(iCell) + rho(1,iCell)*gravity &
+ * 0.5*h(1,iCell)
+
+ do k=2,maxLevelCell(iCell)
+ pressure(k,iCell) = pressure(k-1,iCell) &
+ + 0.5*gravity*( rho(k-1,iCell)*h(k-1,iCell) &
+ + rho(k ,iCell)*h(k ,iCell))
+ end do
+
+ ! Compute zMid, the z-coordinate of the middle of the layer.
+ ! This is used for the rho g grad z momentum term.
+ ! Note the negative sign, since bottomDepth is positive
+ ! and z-coordinates are negative below the surface.
+ k = maxLevelCell(iCell)
+ zMid(k:nVertLevels,iCell) = -bottomDepth(iCell) + 0.5*h(k,iCell)
+
+ do k=maxLevelCell(iCell)-1, 1, -1
+ zMid(k,iCell) = zMid(k+1,iCell) &
+ + 0.5*( h(k+1,iCell) &
+ + h(k ,iCell))
+ end do
+
+ end do
+ !$OMP END DO
+ endif
+
+ !
+ ! Brunt-Vaisala frequency
+ !
+ coef = -gravity/config_rho0
+ !$OMP DO PRIVATE(k)
+ do iCell=1,nCells
+ BruntVaisalaFreqTop(1,iCell) = 0.0
+ do k=2,maxLevelCell(iCell)
+ BruntVaisalaFreqTop(k,iCell) = coef * (rhoDisplaced(k-1,iCell) - rhoDisplaced(k,iCell)) &
+ / (zMid(k-1,iCell) - zMid(k,iCell))
+ end do
+ end do
+ !$OMP END DO
+
+ !
+ ! Sea Surface Height
+ !
+ !$OMP DO
+ do iCell=1,nCells
+ ! Start at the bottom where we know the depth, and go up.
+ ! The bottom depth for this cell is bottomDepth(iCell).
+ ! Note the negative sign, since bottomDepth is positive
+ ! and z-coordinates are negative below the surface.
+
+ ssh(iCell) = - bottomDepth(iCell) + sum(h(1:maxLevelCell(iCell),iCell))
+ end do
+ !$OMP END DO
+
+ !
+ ! Apply the GM closure as a bolus velocity
+ !
+ if (config_h_kappa .GE. epsilon(0D0)) then
+ call ocn_gm_compute_uBolus(s,grid)
+ else
+ !$OMP WORKSHARE
+ uBolusGM = 0.0
+ !$OMP END WORKSHARE
+ end if
+
+ end subroutine ocn_diagnostic_solve!}}}
+
+!***********************************************************************
+!
+! routine ocn_wtop
+!
+!> \brief Computes vertical transport
+!> \author Mark Petersen
+!> \date 23 September 2011
+!> \version SVN:$Id$
+!> \details
+!> This routine computes the vertical transport through the top of each
+!> cell.
+!
+!-----------------------------------------------------------------------
+ subroutine ocn_wtop(grid,h,h_edge,u,wTop, err)!{{{
+
+ !-----------------------------------------------------------------
+ !
+ ! input variables
+ !
+ !-----------------------------------------------------------------
+
+ type (mesh_type), intent(in) :: &
+ grid !< Input: grid information
+
+ real (kind=RKIND), dimension(:,:), intent(in) :: &
+ h !< Input: thickness
+
+ real (kind=RKIND), dimension(:,:), intent(in) :: &
+ h_edge !< Input: h interpolated to an edge
+
+ real (kind=RKIND), dimension(:,:), intent(in) :: &
+ u !< Input: transport
+
+ !-----------------------------------------------------------------
+ !
+ ! output variables
+ !
+ !-----------------------------------------------------------------
+
+ real (kind=RKIND), dimension(:,:), intent(out) :: &
+ wTop !< Output: vertical transport at top of cell
+
+ integer, intent(out) :: err !< Output: error flag
+
+ !-----------------------------------------------------------------
+ !
+ ! local variables
+ !
+ !-----------------------------------------------------------------
+
+ integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j, cov
+ real (kind=RKIND) :: flux, vorticity_abs, h_vertex, workpv, rho0Inv, hSum, invAreaCell
+
+ integer :: nCells, nEdges, nVertices, nVertLevels, vertexDegree
+
+
+ real (kind=RKIND), dimension(:), pointer :: &
+ dvEdge, areaCell, vertCoordMovementWeights
+ real (kind=RKIND), dimension(:), allocatable:: div_hu, h_tend_col
+ real (kind=RKIND) :: div_hu_btr
+
+ integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnVertex, &
+ verticesOnEdge, edgesOnCell, edgesOnEdge, edgesOnVertex, &
+ boundaryEdge, boundaryCell, edgeSignOnCell
+ integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge, &
+ maxLevelCell, maxLevelEdgeTop, maxLevelEdgeBot, &
+ maxLevelVertexBot, maxLevelVertexTop
+
+ err = 0
+
+ nEdgesOnCell => grid % nEdgesOnCell % array
+ areaCell => grid % areaCell % array
+ cellsOnEdge => grid % cellsOnEdge % array
+ edgesOnCell => grid % edgesOnCell % array
+ edgeSignOnCell => grid % edgeSignOnCell % array
+ maxLevelCell => grid % maxLevelCell % array
+ maxLevelEdgeBot => grid % maxLevelEdgeBot % array
+ dvEdge => grid % dvEdge % array
+ vertCoordMovementWeights => grid % vertCoordMovementWeights % array
+
+ nCells = grid % nCells
+ nEdges = grid % nEdges
+ nVertLevels = grid % nVertLevels
+
+
+ if (config_vert_coord_movement.eq.'isopycnal') then
+ ! set vertical transport to zero in isopycnal case
+ !$OMP WORKSHARE
+ wTop=0.0
+ !$OMP END WORKSHARE
+ return
+ end if
+
+ allocate(div_hu(nVertLevels), h_tend_col(nVertLevels))
+
+ !
+ ! Compute div(h^{edge} u) for each cell
+ ! See Ringler et al. (2010) jcp paper, eqn 19, 21, and fig. 3.
+ !
+ !$OMP DO PRIVATE(div_hu_btr, hSum, invAreaCell, i, k, flux)
+ do iCell=1,nCells
+ div_hu(:) = 0.0
+ div_hu_btr = 0.0
+ hSum = 0.0
+ invAreaCell = 1.0 / areaCell(iCell)
+
+ do i = 1, nEdgesOnCell(iCell)
+ iEdge = edgesOnCell(i, iCell)
+
+ do k = 1, maxLevelEdgeBot(iEdge)
+ flux = h_edge(k, iEdge) * u(k, iEdge) * dvEdge(iEdge) * edgeSignOnCell(i, iCell) * invAreaCell
+ div_hu(k) = div_hu(k) - flux
+ div_hu_btr = div_hu_btr - flux
+ end do
+ end do
+
+ do k = 1, maxLevelCell(iCell)
+ h_tend_col(k) = - vertCoordMovementWeights(k) * h(k, iCell) * div_hu_btr
+ hSum = hSum + vertCoordMovementWeights(k) * h(k, iCell)
+ end do
+
+ if(hSum > 0.0) then
+ h_tend_col = h_tend_col / hSum
+ end if
+
+ ! Vertical transport through layer interface at top and bottom is zero.
+ wTop(1,iCell) = 0.0
+ wTop(maxLevelCell(iCell)+1,iCell) = 0.0
+ do k=maxLevelCell(iCell),2,-1
+ wTop(k,iCell) = wTop(k+1,iCell) - div_hu(k) - h_tend_col(k)
+ end do
+ end do
+ !$OMP END DO
+
+ deallocate(div_hu, h_tend_col)
+
+ end subroutine ocn_wtop!}}}
+
+!***********************************************************************
+!
+! routine ocn_fuperp
+!
+!> \brief Computes f u_perp
+!> \author Mark Petersen
+!> \date 23 September 2011
+!> \version SVN:$Id$
+!> \details
+!> This routine computes f u_perp for the ocean
+!
+!-----------------------------------------------------------------------
+
+ subroutine ocn_fuperp(s, grid)!{{{
+ implicit none
+
+ type (state_type), intent(inout) :: s !< Input/Output: State information
+ type (mesh_type), intent(in) :: grid !< Input: Grid information
+
+ integer :: iEdge, cell1, cell2, eoe, i, j, k
+ integer :: nEdgesSolve
+ real (kind=RKIND), dimension(:), pointer :: fEdge
+ real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge, u, uBcl
+ type (dm_info) :: dminfo
+
+ integer, dimension(:), pointer :: maxLevelEdgeTop, nEdgesOnEdge
+ integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnEdge
+
+ !$OMP SINGLE
+ call mpas_timer_start("ocn_fuperp")
+ !$OMP END SINGLE
+
+ u => s % u % array
+ uBcl => s % uBcl % array
+ weightsOnEdge => grid % weightsOnEdge % array
+ fEdge => grid % fEdge % array
+ maxLevelEdgeTop => grid % maxLevelEdgeTop % array
+ cellsOnEdge => grid % cellsOnEdge % array
+ nEdgesOnEdge => grid % nEdgesOnEdge % array
+ edgesOnEdge => grid % edgesOnEdge % array
+
+ fEdge => grid % fEdge % array
+
+ nEdgesSolve = grid % nEdgesSolve
+
+ !
+ ! Put f*uBcl^{perp} in u as a work variable
+ !
+ !$OMP DO PRIVATE(cell1, cell2, k, j, eoe)
+ do iEdge=1,nEdgesSolve
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+
+ do k=1,maxLevelEdgeTop(iEdge)
+
+ u(k,iEdge) = 0.0
+ do j = 1,nEdgesOnEdge(iEdge)
+ eoe = edgesOnEdge(j,iEdge)
+ u(k,iEdge) = u(k,iEdge) + weightsOnEdge(j,iEdge) * uBcl(k,eoe) * fEdge(eoe)
+ end do
+ end do
+ end do
+ !$OMP END DO
+
+ !$OMP SINGLE
+ call mpas_timer_stop("ocn_fuperp")
+ !$OMP END SINGLE
+
+ end subroutine ocn_fuperp!}}}
+
+!***********************************************************************
+!
+! routine ocn_filter_btr_mode_u
+!
+!> \brief filters barotropic mode out of the velocity variable.
+!> \author Mark Petersen
+!> \date 23 September 2011
+!> \version SVN:$Id$
+!> \details
+!> This routine filters barotropic mode out of the velocity variable.
+!
+!-----------------------------------------------------------------------
+ subroutine ocn_filter_btr_mode_u(s, grid)!{{{
+ implicit none
+
+ type (state_type), intent(inout) :: s
+ type (mesh_type), intent(in) :: grid
+
+ integer :: iEdge, k, nEdges
+ real (kind=RKIND) :: vertSum, uhSum, hSum
+ real (kind=RKIND), dimension(:,:), pointer :: h_edge, u
+ integer, dimension(:), pointer :: maxLevelEdgeTop
+
+ !$OMP SINGLE
+ call mpas_timer_start("ocn_filter_btr_mode_u")
+ !$OMP END SINGLE
+
+ u => s % u % array
+ h_edge => s % h_edge % array
+ maxLevelEdgeTop => grid % maxLevelEdgeTop % array
+ nEdges = grid % nEdges
+
+ !$OMP DO PRIVATE(uhSum, hSum, k, vertSum)
+ do iEdge=1,nEdges
+
+ ! hSum is initialized outside the loop because on land boundaries
+ ! maxLevelEdgeTop=0, but I want to initialize hSum with a
+ ! nonzero value to avoid a NaN.
+ uhSum = h_edge(1,iEdge) * u(1,iEdge)
+ hSum = h_edge(1,iEdge)
+
+ do k=2,maxLevelEdgeTop(iEdge)
+ uhSum = uhSum + h_edge(k,iEdge) * u(k,iEdge)
+ hSum = hSum + h_edge(k,iEdge)
+ enddo
+
+ vertSum = uhSum/hSum
+ do k=1,maxLevelEdgeTop(iEdge)
+ u(k,iEdge) = u(k,iEdge) - vertSum
+ enddo
+ enddo ! iEdge
+ !$OMP END DO
+
+ !$OMP SINGLE
+ call mpas_timer_stop("ocn_filter_btr_mode_u")
+ !$OMP END SINGLE
+
+ end subroutine ocn_filter_btr_mode_u!}}}
+
+!***********************************************************************
+!
+! routine ocn_filter_btr_mode_tend_u
+!
+!> \brief ocn_filters barotropic mode out of the u tendency
+!> \author Mark Petersen
+!> \date 23 September 2011
+!> \version SVN:$Id$
+!> \details
+!> This routine filters barotropic mode out of the u tendency.
+!
+!-----------------------------------------------------------------------
+ subroutine ocn_filter_btr_mode_tend_u(tend, s, grid)!{{{
+ implicit none
+
+ type (tend_type), intent(inout) :: tend
+ type (state_type), intent(in) :: s
+ type (mesh_type), intent(in) :: grid
+
+ integer :: iEdge, k, nEdges
+ real (kind=RKIND) :: vertSum, uhSum, hSum
+ real (kind=RKIND), dimension(:,:), pointer :: h_edge, tend_u
+
+ integer, dimension(:), pointer :: maxLevelEdgeTop
+
+ !$OMP SINGLE
+ call mpas_timer_start("ocn_filter_btr_mode_tend_u")
+ !$OMP END SINGLE
+
+ tend_u => tend % u % array
+ h_edge => s % h_edge % array
+ maxLevelEdgeTop => grid % maxLevelEdgeTop % array
+ nEdges = grid % nEdges
+
+ !$OMP DO PRIVATE(uhSum, hSum, k, vertSum)
+ do iEdge=1,nEdges
+
+ ! hSum is initialized outside the loop because on land boundaries
+ ! maxLevelEdgeTop=0, but I want to initialize hSum with a
+ ! nonzero value to avoid a NaN.
+ uhSum = h_edge(1,iEdge) * tend_u(1,iEdge)
+ hSum = h_edge(1,iEdge)
+
+ do k=2,maxLevelEdgeTop(iEdge)
+ uhSum = uhSum + h_edge(k,iEdge) * tend_u(k,iEdge)
+ hSum = hSum + h_edge(k,iEdge)
+ enddo
+
+ vertSum = uhSum/hSum
+ do k=1,maxLevelEdgeTop(iEdge)
+ tend_u(k,iEdge) = tend_u(k,iEdge) - vertSum
+ enddo
+ enddo ! iEdge
+ !$OMP END DO
+
+ !$OMP SINGLE
+ call mpas_timer_stop("ocn_filter_btr_mode_tend_u")
+ !$OMP END SINGLE
+
+ end subroutine ocn_filter_btr_mode_tend_u!}}}
+
+!***********************************************************************
+!
+! routine ocn_diagnostics_init
+!
+!> \brief Initializes flags used within diagnostics routines.
+!> \author Mark Petersen
+!> \date 4 November 2011
+!> \version SVN:$Id$
+!> \details
+!> This routine initializes flags related to quantities computed within
+!> other diagnostics routines.
+!
+!-----------------------------------------------------------------------
+ subroutine ocn_diagnostics_init(err)!{{{
+ integer, intent(out) :: err !< Output: Error flag
+
+ err = 0
+
+ if(config_include_KE_vertex) then
+ ke_vertex_flag = 1
+ ke_cell_flag = 0
+ else
+ ke_vertex_flag = 0
+ ke_cell_flag = 1
+ endif
+
+ if (trim(config_time_integrator) == 'RK4') then
+ ! For RK4, PV includes f: PV = (eta+f)/h.
+ fCoef = 1
+ elseif (trim(config_time_integrator) == 'split_explicit' &
+ .or.trim(config_time_integrator) == 'unsplit_explicit') then
+ ! For split explicit, PV is eta/h because the Coriolis term
+ ! is added separately to the momentum tendencies.
+ fCoef = 0
+ end if
+
+ end subroutine ocn_diagnostics_init!}}}
+
+!***********************************************************************
+
+end module ocn_diagnostics
+
+!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
+! vim: foldmethod=marker
Modified: branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_equation_of_state_linear.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_equation_of_state_linear.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_equation_of_state_linear.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -82,27 +82,21 @@
integer, intent(in) :: indexT, indexS
integer, intent(out) :: err
- real (kind=RKIND), parameter :: rho_ref = 1025.022 ! kg / m^3
- real (kind=RKIND), parameter :: alpha = 2.55e-1 ! kg / m^3 / K (dT/dRho)
- real (kind=RKIND), parameter :: beta = 7.64e-1 ! kg / m^3 / psu (dS/dRho)
- real (kind=RKIND), parameter :: T_ref = 19.0 ! K
- real (kind=RKIND), parameter :: S_ref = 35.0 ! psu
- real (kind=RKIND), parameter :: rho_prime_ref = rho_ref + alpha * T_ref - beta * S_ref
-
integer, dimension(:), pointer :: maxLevelCell
integer :: nCells, iCell, k
type (dm_info) :: dminfo
- maxLevelCell => grid % maxLevelCell % array
- nCells = grid % nCells
+ maxLevelCell => grid % maxLevelCell % array
+ nCells = grid % nCells
err = 0
do iCell=1,nCells
do k=1,maxLevelCell(iCell)
! Linear equation of state
- ! rho = rho_ref - alpha * (T - T_ref) + beta * (S - S_ref)
- rho(k,iCell) = rho_prime_ref - alpha*tracers(indexT,k,iCell) + beta*tracers(indexS,k,iCell)
+ rho(k,iCell) = config_eos_linear_rhoref &
+ - config_eos_linear_alpha * (tracers(indexT,k,iCell)-config_eos_linear_Tref) &
+ + config_eos_linear_beta * (tracers(indexS,k,iCell)-config_eos_linear_Sref)
end do
end do
Modified: branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_mpas_core.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_mpas_core.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_mpas_core.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -7,9 +7,9 @@
use mpas_timer
use ocn_global_diagnostics
- use ocn_test_cases
use ocn_time_integration
use ocn_tendency
+ use ocn_diagnostics
use ocn_monthly_forcing
@@ -102,6 +102,8 @@
call ocn_tendency_init(err_tmp)
err = ior(err,err_tmp)
+ call ocn_diagnostics_init(err_tmp)
+ err = ior(err,err_tmp)
call mpas_ocn_tracer_advection_init(err_tmp)
err = ior(err,err_tmp)
@@ -115,15 +117,13 @@
call mpas_dmpar_abort(dminfo)
endif
- if (.not. config_do_restart) call setup_sw_test_case(domain)
-
if (config_vert_coord_movement.ne.'isopycnal') call ocn_init_vert_coord(domain)
call ocn_compute_max_level(domain)
if (.not.config_do_restart) call ocn_init_split_timestep(domain)
- write (0,'(a,a10)') ' Vertical coordinate movement is: ',config_vert_coord_movement
+ write (0,'(a,a)') ' Vertical coordinate movement is: ',trim(config_vert_coord_movement)
if (config_vert_coord_movement.ne.'isopycnal'.and. &
config_vert_coord_movement.ne.'fixed'.and. &
@@ -169,16 +169,10 @@
block => block % next
end do
- ! mrp 100316 In order for this to work, we need to pass domain % dminfo as an
- ! input arguement into mpas_init. Ask about that later. For now, there will be
- ! no initial statistics write.
-
if (config_write_stats_on_startup) then
call mpas_timer_start("global diagnostics", .false., globalDiagTimer)
call ocn_compute_global_diagnostics(domain, 1 , 0, dt)
call mpas_timer_stop("global diagnostics", globalDiagTimer)
-! call mpas_output_state_init(output_obj, domain, "OUTPUT")
-! call ocn_write_output_frame(output_obj, output_frame, domain)
endif
current_outfile_frames = 0
@@ -296,7 +290,6 @@
block % state % time_levs(1) % state % uReconstructMeridional % array &
)
-!TDR
call mpas_reconstruct(mesh, mesh % u_src % array, &
block % state % time_levs(1) % state % uSrcReconstructX % array, &
block % state % time_levs(1) % state % uSrcReconstructY % array, &
@@ -304,18 +297,12 @@
block % state % time_levs(1) % state % uSrcReconstructZonal % array, &
block % state % time_levs(1) % state % uSrcReconstructMeridional % array &
)
-!TDR
- ! initialize velocities and tracers on land to be -1e34
- ! The reconstructed velocity on land will have values not exactly
- ! -1e34 due to the interpolation of reconstruction.
+ ! initialize velocities and tracers on land to be zero.
block % mesh % areaCell % array(block % mesh % nCells+1) = -1.0e34
do iEdge=1,block % mesh % nEdges
- ! mrp 101115 note: in order to include flux boundary conditions, the following
- ! line will need to change. Right now, set boundary edges between land and
- ! water to have zero velocity.
block % state % time_levs(1) % state % u % array( &
block % mesh % maxLevelEdgeTop % array(iEdge)+1 &
:block % mesh % maxLevelEdgeBot % array(iEdge), iEdge) = 0.0
@@ -323,15 +310,11 @@
block % state % time_levs(1) % state % u % array( &
block % mesh % maxLevelEdgeBot % array(iEdge)+1: &
block % mesh % nVertLevels,iEdge) = 0.0
-! mrp changed to 0
-! block % mesh % nVertLevels,iEdge) = -1e34
end do
do iCell=1,block % mesh % nCells
block % state % time_levs(1) % state % tracers % array( &
:, block % mesh % maxLevelCell % array(iCell)+1 &
:block % mesh % nVertLevels,iCell) = 0.0
-! mrp changed to 0
-! :block % mesh % nVertLevels,iCell) = -1e34
end do
do i=2,nTimeLevs
@@ -613,11 +596,6 @@
nVertLevels = block % mesh % nVertLevels
num_tracers = size(tracers, dim=1)
- ! mrp 120208 right now hZLevel is in the grid.nc file.
- ! We would like to transition to using refBottomDepth
- ! as the defining variable instead, and will transition soon.
- ! When the transition is done, hZLevel can be removed from
- ! registry and the following four lines deleted.
refBottomDepth(1) = hZLevel(1)
do k = 2,nVertLevels
refBottomDepth(k) = refBottomDepth(k-1) + hZLevel(k)
@@ -1038,7 +1016,7 @@
meshScalingDel2(:) = 1.0
meshScalingDel4(:) = 1.0
meshScaling(:) = 1.0
- if (config_h_ScaleWithMesh) then
+ if (config_hmix_ScaleWithMesh) then
do iEdge=1,mesh%nEdges
cell1 = mesh % cellsOnEdge % array(1,iEdge)
cell2 = mesh % cellsOnEdge % array(2,iEdge)
Modified: branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_tendency.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_tendency.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_tendency.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -8,9 +8,7 @@
!> \version SVN:$Id:$
!> \details
!> This module contains the routines for computing
-!> various tendencies for the ocean. As well as routines
-!> for computing diagnostic variables, and other quantities
-!> such as wTop.
+!> tendency terms for the ocean primitive equations.
!
!-----------------------------------------------------------------------
@@ -25,32 +23,26 @@
use ocn_thick_hadv
use ocn_thick_vadv
- use ocn_gm
use ocn_vel_coriolis
use ocn_vel_pressure_grad
use ocn_vel_vadv
use ocn_vel_hmix
use ocn_vel_forcing
+ use ocn_vmix
use ocn_tracer_hadv
use ocn_tracer_vadv
use ocn_tracer_hmix
use ocn_restoring
- use ocn_equation_of_state
- use ocn_vmix
-
- use ocn_time_average
-
implicit none
private
save
- type (timer_node), pointer :: diagEOSTimer
type (timer_node), pointer :: thickHadvTimer, thickVadvTimer
- type (timer_node), pointer :: velCorTimer, velVadvTimer, velPgradTimer, velHmixTimer, velForceTimer, velExpVmixTimer
- type (timer_node), pointer :: tracerHadvTimer, tracerVadvTimer, tracerHmixTimer, tracerExpVmixTimer, tracerRestoringTimer
+ type (timer_node), pointer :: velCorTimer, velVadvTimer, velPgradTimer, velHmixTimer, velForceTimer
+ type (timer_node), pointer :: tracerHadvTimer, tracerVadvTimer, tracerHmixTimer, tracerRestoringTimer
!--------------------------------------------------------------------
!
@@ -66,13 +58,8 @@
public :: ocn_tend_h, &
ocn_tend_u, &
- ocn_tend_scalar, &
- ocn_diagnostic_solve, &
- ocn_wtop, &
- ocn_fuperp, &
- ocn_tendency_init, &
- ocn_filter_btr_mode_u, &
- ocn_filter_btr_mode_tend_u
+ ocn_tend_tracer, &
+ ocn_tendency_init
!--------------------------------------------------------------------
!
@@ -80,10 +67,6 @@
!
!--------------------------------------------------------------------
- integer :: ke_cell_flag, ke_vertex_flag
- real (kind=RKIND) :: coef_3rd_order, fCoef
-
-
!***********************************************************************
contains
@@ -219,7 +202,6 @@
!
! velocity tendency: start accumulating tendency terms
!
- ! mrp 110516 efficiency: could remove next line and have first tend_u operation not be additive
!$OMP WORKSHARE
tend_u(:,:) = 0.0
!$OMP END WORKSHARE
@@ -263,7 +245,7 @@
!
! velocity tendency: del2 dissipation, </font>
<font color="black">u_2 </font>
<font color="black">abla^2 u
! computed as </font>
<font color="black">u( </font>
<font color="black">abla divergence + k \times </font>
<font color="gray">abla vorticity )
- ! strictly only valid for config_h_mom_eddy_visc2 == constant
+ ! strictly only valid for config_mom_del2 == constant
!
call mpas_timer_start("hmix", .false., velHmixTimer)
!$OMP END SINGLE
@@ -274,8 +256,6 @@
!
! velocity tendency: forcing and bottom drag
!
- ! mrp 101115 note: in order to include flux boundary conditions, we will need to
- ! know the bottom edge with nonzero velocity and place the drag there.
call mpas_timer_start("forcings", .false., velForceTimer)
!$OMP END SINGLE
@@ -287,12 +267,6 @@
!
! velocity tendency: vertical mixing d/dz( nu_v du/dz))
!
- !$OMP SINGLE
- if (.not.config_implicit_vertical_mix) then
- call mpas_timer_start("explicit vmix", .false., velExpVmixTimer)
- call ocn_vel_vmix_tend_explicit(grid, u, h_edge, vertvisctopofedge, tend_u, err)
- call mpas_timer_stop("explicit vmix", velExpVmixTimer)
- endif
!$OMP END SINGLE
!$OMP SINGLE
call mpas_timer_stop("ocn_tend_u")
@@ -302,17 +276,17 @@
!***********************************************************************
!
-! routine ocn_tendSalar
+! routine ocn_tend_tracer
!
-!> \brief Computes scalar tendency
+!> \brief Computes tracer tendency
!> \author Doug Jacobsen
!> \date 23 September 2011
!> \version SVN:$Id$
!> \details
-!> This routine computes the scalar (tracer) tendency for the ocean
+!> This routine computes tracer tendencies for the ocean
!
!-----------------------------------------------------------------------
- subroutine ocn_tend_scalar(tend, s, d, grid, scratch, dt)!{{{
+ subroutine ocn_tend_tracer(tend, s, d, grid, scratch, dt)!{{{
implicit none
type (tend_type), intent(inout) :: tend !< Input/Output: Tendency structure
@@ -330,7 +304,7 @@
integer :: err, iEdge, k
!$OMP SINGLE
- call mpas_timer_start("ocn_tend_scalar")
+ call mpas_timer_start("ocn_tend_tracer")
!$OMP END SINGLE
uTransport => s % uTransport % array
@@ -372,10 +346,6 @@
! tracer tendency: horizontal advection term -div( h \phi u)
!
- ! mrp 101115 note: in order to include flux boundary conditions, we will need to
- ! assign h_edge for maxLevelEdgeTop:maxLevelEdgeBot in the compute_solve_diagnostics
- ! and then change maxLevelEdgeTop to maxLevelEdgeBot in the following section.
- ! tracer_edge at the boundary will also need to be defined for flux boundaries.
! Monotonoic Advection, or standard advection
!$OMP SINGLE
@@ -397,32 +367,6 @@
call mpas_timer_stop("hmix", tracerHmixTimer)
!$OMP END SINGLE
-! mrp 110516 printing
-!print *, 'tend_tr 1',minval(tend_tr(3,1,1:nCells)),&
-! maxval(tend_tr(3,1,1:nCells))
-!print *, 'tracer 1',minval(tracers(3,1,1:nCells)),&
-! maxval(tracers(3,1,1:nCells))
-! mrp 110516 printing end
-
- !
- ! tracer tendency: vertical diffusion h d/dz( \kappa_v d\phi/dz)
- !
- !$OMP SINGLE
- if (.not.config_implicit_vertical_mix) then
- call mpas_timer_start("explicit vmix", .false., tracerExpVmixTimer)
-
- call ocn_tracer_vmix_tend_explicit(grid, h, vertdifftopofcell, tracers, tend_tr, err)
-
- call mpas_timer_stop("explicit vmix", tracerExpVmixTimer)
- endif
- !$OMP END SINGLE
-
-! mrp 110516 printing
-!print *, 'tend_tr 2',minval(tend_tr(3,1,1:nCells)),&
-! maxval(tend_tr(3,1,1:nCells))
-! mrp 110516 printing end
-
- !
! add restoring to T and S in top model layer
!
!$OMP SINGLE
@@ -434,795 +378,17 @@
!$OMP SINGLE
call mpas_timer_stop("restoring", tracerRestoringTimer)
- call mpas_timer_stop("ocn_tend_scalar")
+ call mpas_timer_stop("ocn_tend_tracer")
!$OMP END SINGLE
!$OMP SINGLE
call mpas_deallocate_scratch_field(scratch % uh)
!$OMP END SINGLE
- 10 format(2i8,10e20.10)
+ end subroutine ocn_tend_tracer!}}}
- end subroutine ocn_tend_scalar!}}}
-
!***********************************************************************
!
-! routine ocn_diagnostic_solve
-!
-!> \brief Computes diagnostic variables
-!> \author Doug Jacobsen
-!> \date 23 September 2011
-!> \version SVN:$Id$
-!> \details
-!> This routine computes the diagnostic variables for the ocean
-!
-!-----------------------------------------------------------------------
-
- subroutine ocn_diagnostic_solve(dt, s, grid)!{{{
- implicit none
-
- real (kind=RKIND), intent(in) :: dt !< Input: Time step
- type (state_type), intent(inout) :: s !< Input/Output: State information
- type (mesh_type), intent(in) :: grid !< Input: Grid information
-
-
- integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j
- integer :: boundaryMask, velMask, nCells, nEdges, nVertices, nVertLevels, vertexDegree, err
-
- integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge, &
- maxLevelCell, maxLevelEdgeTop, maxLevelEdgeBot, &
- maxLevelVertexBot
- integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnVertex, &
- verticesOnEdge, edgesOnEdge, edgesOnVertex,boundaryCell, kiteIndexOnCell, verticesOnCell, edgeSignOnVertex, edgeSignOnCell, edgesOnCell
-
- real (kind=RKIND) :: d2fdx2_cell1, d2fdx2_cell2, coef_3rd_order, r_tmp, invAreaCell1, invAreaCell2, invAreaTri1, invAreaTri2, invLength, h_vertex
-
- real (kind=RKIND), dimension(:), allocatable:: pTop
-
- real (kind=RKIND), dimension(:), pointer :: &
- bottomDepth, fVertex, dvEdge, dcEdge, areaCell, areaTriangle, ssh
- real (kind=RKIND), dimension(:,:), pointer :: &
- weightsOnEdge, kiteAreasOnVertex, h_edge, h, u, v, pressure,&
- circulation, vorticity, ke, ke_edge, MontPot, wTop, zMid, &
- Vor_edge, Vor_vertex, Vor_cell, gradVor_n, gradVor_t, divergence, &
- rho, temperature, salinity, kev, kevc, uBolusGM, uTransport
- real (kind=RKIND), dimension(:,:,:), pointer :: tracers, deriv_two
- real (kind=RKIND), dimension(:,:), allocatable:: div_u
- character :: c1*6
-
- h => s % h % array
- u => s % u % array
- uTransport => s % uTransport % array
- uBolusGM => s % uBolusGM % array
- v => s % v % array
- h_edge => s % h_edge % array
- circulation => s % circulation % array
- vorticity => s % vorticity % array
- divergence => s % divergence % array
- ke => s % ke % array
- kev => s % kev % array
- kevc => s % kevc % array
- ke_edge => s % ke_edge % array
- Vor_edge => s % Vor_edge % array
- Vor_vertex => s % Vor_vertex % array
- Vor_cell => s % Vor_cell % array
- gradVor_n => s % gradVor_n % array
- gradVor_t => s % gradVor_t % array
- rho => s % rho % array
- MontPot => s % MontPot % array
- pressure => s % pressure % array
- zMid => s % zMid % array
- ssh => s % ssh % array
- tracers => s % tracers % array
-
- weightsOnEdge => grid % weightsOnEdge % array
- kiteAreasOnVertex => grid % kiteAreasOnVertex % array
- cellsOnEdge => grid % cellsOnEdge % array
- cellsOnVertex => grid % cellsOnVertex % array
- verticesOnEdge => grid % verticesOnEdge % array
- nEdgesOnCell => grid % nEdgesOnCell % array
- nEdgesOnEdge => grid % nEdgesOnEdge % array
- edgesOnCell => grid % edgesOnCell % array
- edgesOnEdge => grid % edgesOnEdge % array
- edgesOnVertex => grid % edgesOnVertex % array
- dcEdge => grid % dcEdge % array
- dvEdge => grid % dvEdge % array
- areaCell => grid % areaCell % array
- areaTriangle => grid % areaTriangle % array
- bottomDepth => grid % bottomDepth % array
- fVertex => grid % fVertex % array
- deriv_two => grid % deriv_two % array
- maxLevelCell => grid % maxLevelCell % array
- maxLevelEdgeTop => grid % maxLevelEdgeTop % array
- maxLevelEdgeBot => grid % maxLevelEdgeBot % array
- maxLevelVertexBot => grid % maxLevelVertexBot % array
- kiteIndexOnCell => grid % kiteIndexOnCell % array
- verticesOnCell => grid % verticesOnCell % array
-
- nCells = grid % nCells
- nEdges = grid % nEdges
- nVertices = grid % nVertices
- nVertLevels = grid % nVertLevels
- vertexDegree = grid % vertexDegree
-
- boundaryCell => grid % boundaryCell % array
-
- edgeSignOnVertex => grid % edgeSignOnVertex % array
- edgeSignOnCell => grid % edgeSignOnCell % array
-
-
- !
- ! Compute height on cell edges at velocity locations
- ! Namelist options control the order of accuracy of the reconstructed h_edge value
- !
- ! mrp 101115 note: in order to include flux boundary conditions, we will need to
- ! assign h_edge for maxLevelEdgeTop:maxLevelEdgeBot in the following section
-
- ! initialize h_edge to avoid divide by zero and NaN problems.
- !$OMP WORKSHARE
- h_edge = -1.0e34
- !$OMP END WORKSHARE
- coef_3rd_order = config_coef_3rd_order
-
- !$OMP DO PRIVATE(cell1, cell2, k)
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- do k=1,maxLevelEdgeTop(iEdge)
- h_edge(k,iEdge) = 0.5 * (h(k,cell1) + h(k,cell2))
- end do
- end do
- !$OMP END DO
-
- !
- ! set the velocity and height at dummy address
- ! used -1e34 so error clearly occurs if these values are used.
- !
- !$OMP WORKSHARE
- u(:,nEdges+1) = -1e34
- h(:,nCells+1) = -1e34
- tracers(s % index_temperature,:,nCells+1) = -1e34
- tracers(s % index_salinity,:,nCells+1) = -1e34
-
- circulation(:,:) = 0.0
- vorticity(:,:) = 0.0
- divergence(:,:) = 0.0
- ke(:,:) = 0.0
- v(:,:) = 0.0
- !$OMP END WORKSHARE
-
- !$OMP DO PRIVATE(invAreaTri1, i, iEdge, k, r_tmp)
- do iVertex = 1, nVertices
- invAreaTri1 = 1.0 / areaTriangle(iVertex)
- do i = 1, vertexDegree
- iEdge = edgesOnVertex(i, iVertex)
- do k = 1, maxLevelVertexBot(iVertex)
- r_tmp = dcEdge(iEdge) * u(k, iEdge)
-
- circulation(k, iVertex) = circulation(k, iVertex) + edgeSignOnVertex(i, iVertex) * r_tmp
- vorticity(k, iVertex) = vorticity(k, iVertex) + edgeSignOnVertex(i, iVertex) * r_tmp * invAreaTri1
- end do
- end do
- end do
- !$OMP END DO
-
- !$OMP DO PRIVATE(invAreaCell1, i, iEdge, k, r_tmp)
- do iCell = 1, nCells
- invAreaCell1 = 1.0 / areaCell(iCell)
- do i = 1, nEdgesOnCell(iCell)
- iEdge = edgesOnCell(i, iCell)
- do k = 1, maxLevelCell(iCell)
- r_tmp = dvEdge(iEdge) * u(k, iEdge) * invAreaCell1
-
- divergence(k, iCell) = divergence(k, iCell) - edgeSignOnCell(i, iCell) * r_tmp
- ke(k, iCell) = ke(k, iCell) + 0.25 * r_tmp * dcEdge(iEdge) * u(k,iEdge)
- end do
- end do
- end do
- !$OMP END DO
-
- !$OMP DO PRIVATE(i, eoe, k)
- do iEdge=1,nEdges
- ! Compute v (tangential) velocities
- do i=1,nEdgesOnEdge(iEdge)
- eoe = edgesOnEdge(i,iEdge)
- ! mrp 101115 note: in order to include flux boundary conditions,
- ! the following loop may need to change to maxLevelEdgeBot
- do k = 1,maxLevelEdgeTop(iEdge)
- v(k,iEdge) = v(k,iEdge) + weightsOnEdge(i,iEdge) * u(k, eoe)
- end do
- end do
- end do
- !$OMP END DO
-
- !
- ! Compute kinetic energy in each vertex
- !
- !$OMP WORKSHARE
- kev(:,:) = 0.0; kevc(:,:) = 0.0
- !$OMP END WORKSHARE
-
- !$OMP DO PRIVATE(i, iEdge, r_tmp, k)
- do iVertex = 1, nVertices*ke_vertex_flag
- do i = 1, vertexDegree
- iEdge = edgesOnVertex(i, iVertex)
- r_tmp = dcEdge(iEdge) * dvEdge(iEdge) * 0.25 / areaTriangle(iVertex)
- do k = 1, nVertLevels
- kev(k, iVertex) = kev(k, iVertex) + r_tmp * u(k, iEdge)**2
- end do
- end do
- end do
- !$OMP END DO
-
- !$OMP DO PRIVATE(invAreaCell1, i, j, iVertex, k)
- do iCell = 1, nCells*ke_vertex_flag
- invAreaCell1 = 1.0 / areaCell(iCell)
- do i = 1, nEdgesOnCell(iCell)
- j = kiteIndexOnCell(i, iCell)
- iVertex = verticesOnCell(i, iCell)
- do k = 1, nVertLevels
- kevc(k, iCell) = kevc(k, iCell) + kiteAreasOnVertex(j, iVertex) * kev(k, iVertex) * invAreaCell1
- end do
- end do
- end do
- !$OMP END DO
-
- !
- ! Compute kinetic energy in each cell by blending ke and kevc
- !
- !$OMP DO PRIVATE(k)
- do iCell=1,nCells*ke_vertex_flag
- do k=1,nVertLevels
- ke(k,iCell) = 5.0/8.0*ke(k,iCell) + 3.0/8.0*kevc(k,iCell)
- end do
- end do
- !$OMP END DO
-
- !
- ! Compute ke on cell edges at velocity locations for quadratic bottom drag.
- !
- ! mrp 101025 efficiency note: we could get rid of ke_edge completely by
- ! using sqrt(u(k,iEdge)**2 + v(k,iEdge)**2) in its place elsewhere.
- !$OMP DO PRIVATE(cell1, cell2, k)
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- do k=1,maxLevelEdgeTop(iEdge)
- ke_edge(k,iEdge) = 0.5 * (ke(k,cell1) + ke(k,cell2))
- end do
- end do
- !$OMP END DO
-
- !
- ! Compute height at vertices, pv at vertices, and average pv to edge locations
- ! ( this computes Vor_vertex at all vertices bounding real cells and distance-1 ghost cells )
- !
- !$OMP DO PRIVATE(invAreaTri1, k, h_vertex, i)
- do iVertex = 1,nVertices
- invAreaTri1 = 1.0 / areaTriangle(iVertex)
- do k=1,maxLevelVertexBot(iVertex)
- h_vertex = 0.0
- do i=1,vertexDegree
- h_vertex = h_vertex + h(k,cellsOnVertex(i,iVertex)) * kiteAreasOnVertex(i,iVertex)
- end do
- h_vertex = h_vertex * invAreaTri1
-
- Vor_vertex(k,iVertex) = (fCoef*fVertex(iVertex) + vorticity(k,iVertex)) / h_vertex
- end do
- end do
- !$OMP END DO
-
- !$OMP WORKSHARE
- Vor_cell(:,:) = 0.0
- Vor_edge(:,:) = 0.0
- !$OMP END WORKSHARE
-
- !$OMP DO PRIVATE(vertex1, vertex2, k)
- do iEdge = 1, nEdges
- vertex1 = verticesOnEdge(1, iEdge)
- vertex2 = verticesOnEdge(2, iEdge)
- do k = 1, maxLevelEdgeBot(iEdge)
- Vor_edge(k, iEdge) = 0.5 * (Vor_vertex(k, vertex1) + Vor_vertex(k, vertex2))
- end do
- end do
- !$OMP END DO
-
- !$OMP DO PRIVATE(invAreaCell1, i, j, iVertex, k)
- do iCell = 1, nCells
- invAreaCell1 = 1.0 / areaCell(iCell)
-
- do i = 1, nEdgesOnCell(iCell)
- j = kiteIndexOnCell(i, iCell)
- iVertex = verticesOnCell(i, iCell)
- do k = 1, maxLevelCell(iCell)
- Vor_cell(k, iCell) = Vor_cell(k, iCell) + kiteAreasOnVertex(j, iVertex) * Vor_vertex(k, iVertex) * invAreaCell1
- end do
- end do
- end do
- !$OMP END DO
-
- !$OMP DO PRIVATE(cell1, cell2, vertex1, vertex2, invLength, k)
- do iEdge = 1,nEdges
- cell1 = cellsOnEdge(1, iEdge)
- cell2 = cellsOnEdge(2, iEdge)
- vertex1 = verticesOnedge(1, iEdge)
- vertex2 = verticesOnedge(2, iEdge)
-
- invLength = 1.0 / dcEdge(iEdge)
- ! Compute gradient of PV in normal direction
- ! ( this computes gradVor_n for all edges bounding real cells )
- do k=1,maxLevelEdgeTop(iEdge)
- gradVor_n(k,iEdge) = (Vor_cell(k,cell2) - Vor_cell(k,cell1)) * invLength
- enddo
-
- invLength = 1.0 / dvEdge(iEdge)
- ! Compute gradient of PV in the tangent direction
- ! ( this computes gradVor_t at all edges bounding real cells and distance-1 ghost cells )
- do k = 1,maxLevelEdgeBot(iEdge)
- gradVor_t(k,iEdge) = (Vor_vertex(k,vertex2) - Vor_vertex(k,vertex1)) * invLength
- enddo
- enddo
- !$OMP END DO
-
- !
- ! Modify PV edge with upstream bias.
- !
- !$OMP DO PRIVATE(k)
- do iEdge = 1,nEdges
- do k = 1,maxLevelEdgeBot(iEdge)
- Vor_edge(k,iEdge) = Vor_edge(k,iEdge) &
- - config_apvm_scale_factor * dt* ( u(k,iEdge) * gradVor_n(k,iEdge) &
- + v(k,iEdge) * gradVor_t(k,iEdge) )
- enddo
- enddo
- !$OMP END DO
-
- !
- ! equation of state
- !
- ! For an isopycnal model, density should remain constant.
- ! For zlevel, calculate in-situ density
- if (config_vert_coord_movement.ne.'isopycnal') then
- !DWJ 01/29/13 OMP Equation Of State Call....
- !$OMP SINGLE
- call mpas_timer_start("equation of state", .false., diagEOSTimer)
- call ocn_equation_of_state_rho(s, grid, 0, 'relative', err)
- ! mrp 110324 In order to visualize rhoDisplaced, include the following
- call ocn_equation_of_state_rho(s, grid, 1, 'relative', err)
- call mpas_timer_stop("equation of state", diagEOSTimer)
- !$OMP END SINGLE
- endif
-
- !
- ! Pressure
- ! This section must be after computing rho
- !
- ! dwj: 10/25/2011 - Need to explore isopycnal vs zlevel flags
- if (config_pressure_gradient_type.eq.'MontgomeryPotential') then
-
- ! For Isopycnal model.
- ! Compute pressure at top of each layer, and then
- ! Montgomery Potential.
- allocate(pTop(nVertLevels))
- !$OMP DO PRIVATE(k)
- do iCell=1,nCells
-
- ! assume atmospheric pressure at the surface is zero for now.
- pTop(1) = 0.0
- ! For isopycnal mode, p is the Montgomery Potential.
- ! At top layer it is g*SSH, where SSH may be off by a
- ! constant (ie, bottomDepth can be relative to top or bottom)
- MontPot(1,iCell) = gravity &
- * (bottomDepth(iCell) + sum(h(1:nVertLevels,iCell)))
-
- do k=2,nVertLevels
- pTop(k) = pTop(k-1) + rho(k-1,iCell)*gravity* h(k-1,iCell)
-
- ! from delta M = p delta / rho
- MontPot(k,iCell) = MontPot(k-1,iCell) &
- + pTop(k)*(1.0/rho(k,iCell) - 1.0/rho(k-1,iCell))
- end do
-
- end do
- !$OMP END DO
- deallocate(pTop)
-
- else
-
- !$OMP DO PRIVATE(k)
- do iCell=1,nCells
- ! pressure for generalized coordinates
- ! assume atmospheric pressure at the surface is zero for now.
- pressure(1,iCell) = rho(1,iCell)*gravity &
- * 0.5*h(1,iCell)
-
- do k=2,maxLevelCell(iCell)
- pressure(k,iCell) = pressure(k-1,iCell) &
- + 0.5*gravity*( rho(k-1,iCell)*h(k-1,iCell) &
- + rho(k ,iCell)*h(k ,iCell))
- end do
-
- ! Compute zMid, the z-coordinate of the middle of the layer.
- ! This is used for the rho g grad z momentum term.
- ! Note the negative sign, since bottomDepth is positive
- ! and z-coordinates are negative below the surface.
- k = maxLevelCell(iCell)
- zMid(k:nVertLevels,iCell) = -bottomDepth(iCell) + 0.5*h(k,iCell)
-
- do k=maxLevelCell(iCell)-1, 1, -1
- zMid(k,iCell) = zMid(k+1,iCell) &
- + 0.5*( h(k+1,iCell) &
- + h(k ,iCell))
- end do
-
- end do
- !$OMP END DO
-
- endif
-
- !
- ! Sea Surface Height
- !
- !$OMP DO
- do iCell=1,nCells
- ! Start at the bottom where we know the depth, and go up.
- ! The bottom depth for this cell is bottomDepth(iCell).
- ! Note the negative sign, since bottomDepth is positive
- ! and z-coordinates are negative below the surface.
-
- ssh(iCell) = - bottomDepth(iCell) + sum(h(1:maxLevelCell(iCell),iCell))
- end do
- !$OMP END DO
-
- !
- ! Apply the GM closure as a bolus velocity
- !
- if (config_h_kappa .GE. epsilon(0D0)) then
- call ocn_gm_compute_uBolus(s,grid)
- else
- ! mrp efficiency note: if uBolusGM is guaranteed to be zero, this can be removed.
- !$OMP WORKSHARE
- uBolusGM = 0.0
- !$OMP END WORKSHARE
- end if
-
- end subroutine ocn_diagnostic_solve!}}}
-
-!***********************************************************************
-!
-! routine ocn_wtop
-!
-!> \brief Computes vertical velocity
-!> \author Doug Jacobsen
-!> \date 23 September 2011
-!> \version SVN:$Id$
-!> \details
-!> This routine computes the vertical velocity in the top layer for the ocean
-!
-!-----------------------------------------------------------------------
- subroutine ocn_wtop(grid,h,h_edge,u,wTop, err)!{{{
-
- !-----------------------------------------------------------------
- !
- ! input variables
- !
- !-----------------------------------------------------------------
-
- type (mesh_type), intent(in) :: &
- grid !< Input: grid information
-
- real (kind=RKIND), dimension(:,:), intent(in) :: &
- h !< Input: thickness
-
- real (kind=RKIND), dimension(:,:), intent(in) :: &
- h_edge !< Input: h interpolated to an edge
-
- real (kind=RKIND), dimension(:,:), intent(in) :: &
- u !< Input: velocity
-
- !-----------------------------------------------------------------
- !
- ! output variables
- !
- !-----------------------------------------------------------------
-
- real (kind=RKIND), dimension(:,:), intent(out) :: &
- wTop !< Output: vertical transport at top edge
-
- integer, intent(out) :: err !< Output: error flag
-
- !-----------------------------------------------------------------
- !
- ! local variables
- !
- !-----------------------------------------------------------------
-
- integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j, cov
- real (kind=RKIND) :: flux, vorticity_abs, h_vertex, workpv, rho0Inv, hSum, invAreaCell
-
- integer :: nCells, nEdges, nVertices, nVertLevels, vertexDegree
-
-
- real (kind=RKIND), dimension(:), pointer :: &
- dvEdge, areaCell, vertCoordMovementWeights
- real (kind=RKIND), dimension(:), allocatable:: div_hu, h_tend_col
- real (kind=RKIND) :: div_hu_btr
-
- integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnVertex, &
- verticesOnEdge, edgesOnCell, edgesOnEdge, edgesOnVertex, &
- boundaryEdge, boundaryCell, edgeSignOnCell
- integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge, &
- maxLevelCell, maxLevelEdgeTop, maxLevelEdgeBot, &
- maxLevelVertexBot, maxLevelVertexTop
-
- err = 0
-
- nEdgesOnCell => grid % nEdgesOnCell % array
- areaCell => grid % areaCell % array
- cellsOnEdge => grid % cellsOnEdge % array
- edgesOnCell => grid % edgesOnCell % array
- edgeSignOnCell => grid % edgeSignOnCell % array
- maxLevelCell => grid % maxLevelCell % array
- maxLevelEdgeBot => grid % maxLevelEdgeBot % array
- dvEdge => grid % dvEdge % array
- vertCoordMovementWeights => grid % vertCoordMovementWeights % array
-
- nCells = grid % nCells
- nEdges = grid % nEdges
- nVertLevels = grid % nVertLevels
-
-
- if (config_vert_coord_movement.eq.'isopycnal') then
- ! set vertical velocity to zero in isopycnal case
- !$OMP WORKSHARE
- wTop=0.0_RKIND
- !$OMP END WORKSHARE
- return
- end if
-
- allocate(div_hu(nVertLevels), h_tend_col(nVertLevels))
-
- !
- ! Compute div(h^{edge} u) for each cell
- ! See Ringler et al. (2010) jcp paper, eqn 19, 21, and fig. 3.
- !
-
- !$OMP DO PRIVATE(hSum, invAreaCell, i, iEdge, k, flux)
- do iCell=1,nCells
- div_hu(:) = 0.0_RKIND
- div_hu_btr = 0.0_RKIND
- hSum = 0.0_RKIND
- invAreaCell = 1.0_RKIND / areaCell(iCell)
-
- do i = 1, nEdgesOnCell(iCell)
- iEdge = edgesOnCell(i, iCell)
-
- do k = 1, maxLevelEdgeBot(iEdge)
- flux = u(k, iEdge) * dvEdge(iEdge) * h_edge(k, iEdge)
- flux = edgeSignOnCell(i, iCell) * flux * invAreaCell
- div_hu(k) = div_hu(k) - flux
- div_hu_btr = div_hu_btr - flux
- end do
- end do
-
- do k = 1, maxLevelCell(iCell)
- h_tend_col(k) = - vertCoordMovementWeights(k) * h(k, iCell) * div_hu_btr
- hSum = hSum + vertCoordMovementWeights(k) * h(k, iCell)
- end do
-
- if(hSum > 0.0) then
- h_tend_col = h_tend_col / hSum
- end if
-
- ! Vertical velocity through layer interface at top and
- ! bottom is zero.
- wTop(1,iCell) = 0.0_RKIND
- wTop(maxLevelCell(iCell)+1,iCell) = 0.0_RKIND
- do k=maxLevelCell(iCell),2,-1
- wTop(k,iCell) = wTop(k+1,iCell) - div_hu(k) - h_tend_col(k)
- end do
- end do
- !$OMP END DO
-
- deallocate(div_hu, h_tend_col)
-
- end subroutine ocn_wtop!}}}
-
-!***********************************************************************
-!
-! routine ocn_fuperp
-!
-!> \brief Computes f u_perp
-!> \author Doug Jacobsen
-!> \date 23 September 2011
-!> \version SVN:$Id$
-!> \details
-!> This routine computes f u_perp for the ocean
-!
-!-----------------------------------------------------------------------
-
- subroutine ocn_fuperp(s, grid)!{{{
- implicit none
-
- type (state_type), intent(inout) :: s !< Input/Output: State information
- type (mesh_type), intent(in) :: grid !< Input: Grid information
-
-! mrp 110512 I just split compute_tend into compute_tend_u and compute_tend_h.
-! Some of these variables can be removed, but at a later time.
- integer :: iEdge, cell1, cell2, eoe, i, j, k
-
- integer :: nEdgesSolve
- real (kind=RKIND), dimension(:), pointer :: fEdge
- real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge, u, uBcl
- type (dm_info) :: dminfo
-
- integer, dimension(:), pointer :: maxLevelEdgeTop, nEdgesOnEdge
- integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnEdge
-
- !$OMP SINGLE
- call mpas_timer_start("ocn_fuperp")
- !$OMP END SINGLE
-
- u => s % u % array
- uBcl => s % uBcl % array
- weightsOnEdge => grid % weightsOnEdge % array
- fEdge => grid % fEdge % array
- maxLevelEdgeTop => grid % maxLevelEdgeTop % array
- cellsOnEdge => grid % cellsOnEdge % array
- nEdgesOnEdge => grid % nEdgesOnEdge % array
- edgesOnEdge => grid % edgesOnEdge % array
-
- fEdge => grid % fEdge % array
-
- nEdgesSolve = grid % nEdgesSolve
-
- !
- ! Put f*uBcl^{perp} in u as a work variable
- !
- !$OMP DO PRIVATE(cell1, cell2, k, j, eoe)
- do iEdge=1,nEdgesSolve
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
-
- do k=1,maxLevelEdgeTop(iEdge)
-
- u(k,iEdge) = 0.0
- do j = 1,nEdgesOnEdge(iEdge)
- eoe = edgesOnEdge(j,iEdge)
- u(k,iEdge) = u(k,iEdge) + weightsOnEdge(j,iEdge) * uBcl(k,eoe) * fEdge(eoe)
- end do
- end do
- end do
- !$OMP END DO
-
- !$OMP SINGLE
- call mpas_timer_stop("ocn_fuperp")
- !$OMP END SINGLE
-
- end subroutine ocn_fuperp!}}}
-
-!***********************************************************************
-!
-! routine ocn_filter_btr_mode_u
-!
-!> \brief filters barotropic mode out of the velocity variable.
-!> \author Mark Petersen
-!> \date 23 September 2011
-!> \version SVN:$Id$
-!> \details
-!> This routine filters barotropic mode out of the velocity variable.
-!
-!-----------------------------------------------------------------------
- subroutine ocn_filter_btr_mode_u(s, grid)!{{{
- implicit none
-
- type (state_type), intent(inout) :: s
- type (mesh_type), intent(in) :: grid
-
- integer :: iEdge, k, nEdges
- real (kind=RKIND) :: vertSum, uhSum, hSum
- real (kind=RKIND), dimension(:,:), pointer :: h_edge, u
- integer, dimension(:), pointer :: maxLevelEdgeTop
-
- !$OMP SINGLE
- call mpas_timer_start("ocn_filter_btr_mode_u")
- !$OMP END SINGLE
-
- u => s % u % array
- h_edge => s % h_edge % array
- maxLevelEdgeTop => grid % maxLevelEdgeTop % array
- nEdges = grid % nEdges
-
- !$OMP DO PRIVATE(uhSum, hSum, k, vertSum)
- do iEdge=1,nEdges
-
- ! hSum is initialized outside the loop because on land boundaries
- ! maxLevelEdgeTop=0, but I want to initialize hSum with a
- ! nonzero value to avoid a NaN.
- uhSum = h_edge(1,iEdge) * u(1,iEdge)
- hSum = h_edge(1,iEdge)
-
- do k=2,maxLevelEdgeTop(iEdge)
- uhSum = uhSum + h_edge(k,iEdge) * u(k,iEdge)
- hSum = hSum + h_edge(k,iEdge)
- enddo
-
- vertSum = uhSum/hSum
- do k=1,maxLevelEdgeTop(iEdge)
- u(k,iEdge) = u(k,iEdge) - vertSum
- enddo
- enddo ! iEdge
- !$OMP END DO
-
- !$OMP SINGLE
- call mpas_timer_stop("ocn_filter_btr_mode_u")
- !$OMP END SINGLE
-
- end subroutine ocn_filter_btr_mode_u!}}}
-
-!***********************************************************************
-!
-! routine ocn_filter_btr_mode_tend_u
-!
-!> \brief ocn_filters barotropic mode out of the u tendency
-!> \author Mark Petersen
-!> \date 23 September 2011
-!> \version SVN:$Id$
-!> \details
-!> This routine filters barotropic mode out of the u tendency.
-!
-!-----------------------------------------------------------------------
- subroutine ocn_filter_btr_mode_tend_u(tend, s, grid)!{{{
- implicit none
-
- type (tend_type), intent(inout) :: tend
- type (state_type), intent(in) :: s
- type (mesh_type), intent(in) :: grid
-
- integer :: iEdge, k, nEdges
- real (kind=RKIND) :: vertSum, uhSum, hSum
- real (kind=RKIND), dimension(:,:), pointer :: h_edge, tend_u
-
- integer, dimension(:), pointer :: maxLevelEdgeTop
-
- !$OMP SINGLE
- call mpas_timer_start("ocn_filter_btr_mode_tend_u")
- !$OMP END SINGLE
-
- tend_u => tend % u % array
- h_edge => s % h_edge % array
- maxLevelEdgeTop => grid % maxLevelEdgeTop % array
- nEdges = grid % nEdges
-
- !$OMP DO PRIVATE(uhSum, hSum, k, vertSum)
- do iEdge=1,nEdges
-
- ! hSum is initialized outside the loop because on land boundaries
- ! maxLevelEdgeTop=0, but I want to initialize hSum with a
- ! nonzero value to avoid a NaN.
- uhSum = h_edge(1,iEdge) * tend_u(1,iEdge)
- hSum = h_edge(1,iEdge)
-
- do k=2,maxLevelEdgeTop(iEdge)
- uhSum = uhSum + h_edge(k,iEdge) * tend_u(k,iEdge)
- hSum = hSum + h_edge(k,iEdge)
- enddo
-
- vertSum = uhSum/hSum
- do k=1,maxLevelEdgeTop(iEdge)
- tend_u(k,iEdge) = tend_u(k,iEdge) - vertSum
- enddo
- enddo ! iEdge
- !$OMP END DO
-
- !$OMP SINGLE
- call mpas_timer_stop("ocn_filter_btr_mode_tend_u")
- !$OMP END SINGLE
-
- end subroutine ocn_filter_btr_mode_tend_u!}}}
-
-!***********************************************************************
-!
! routine ocn_tendency_init
!
!> \brief Initializes flags used within tendency routines.
@@ -1239,28 +405,6 @@
err = 0
- coef_3rd_order = 0.
-
- if(config_include_KE_vertex) then
- ke_vertex_flag = 1
- ke_cell_flag = 0
- else
- ke_vertex_flag = 0
- ke_cell_flag = 1
- endif
-
- if (trim(config_time_integrator) == 'RK4') then
- ! for RK4, PV is really PV = (eta+f)/h
- fCoef = 1
- elseif (trim(config_time_integrator) == 'split_explicit' &
- .or.trim(config_time_integrator) == 'unsplit_explicit') then
- ! for split explicit, PV is eta/h because f is added separately to the momentum forcing.
- ! mrp temp, new should be:
- fCoef = 0
- ! old, for testing:
- ! fCoef = 1
- end if
-
end subroutine ocn_tendency_init!}}}
!***********************************************************************
Deleted: branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_test_cases.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_test_cases.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_test_cases.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -1,526 +0,0 @@
- module ocn_test_cases
-
- use mpas_grid_types
- use mpas_configure
- use mpas_constants
-
-
- contains
-
-
- subroutine setup_sw_test_case(domain)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Configure grid metadata and model state for the shallow water test case
- ! specified in the namelist
- !
- ! Output: block - a subset (not necessarily proper) of the model domain to be
- ! initialized
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (domain_type), intent(inout) :: domain
-
- integer :: i, iCell, iEdge, iVtx, iLevel
- type (block_type), pointer :: block_ptr
- type (dm_info) :: dminfo
-
- if (config_test_case == 0) then
- write(0,*) 'Using initial conditions supplied in input file'
-
- else if (config_test_case == 1) then
- write(0,*) ' Setting up shallow water test case 1:'
- write(0,*) ' Advection of Cosine Bell over the Pole'
-
- block_ptr => domain % blocklist
- do while (associated(block_ptr))
- call sw_test_case_1(block_ptr % mesh, block_ptr % state % time_levs(1) % state)
- block_ptr => block_ptr % next
- end do
-
- else if (config_test_case == 2) then
- write(0,*) ' Setup shallow water test case 2: '// &
- 'Global Steady State Nonlinear Zonal Geostrophic Flow'
-
- block_ptr => domain % blocklist
- do while (associated(block_ptr))
- call sw_test_case_2(block_ptr % mesh, block_ptr % state % time_levs(1) % state)
- block_ptr => block_ptr % next
- end do
-
- else if (config_test_case == 5) then
- write(0,*) ' Setup shallow water test case 5:'// &
- ' Zonal Flow over an Isolated Mountain'
-
- block_ptr => domain % blocklist
- do while (associated(block_ptr))
- call sw_test_case_5(block_ptr % mesh, block_ptr % state % time_levs(1) % state)
- block_ptr => block_ptr % next
- end do
-
- else if (config_test_case == 6) then
- write(0,*) ' Set up shallow water test case 6:'
- write(0,*) ' Rossby-Haurwitz Wave'
-
- block_ptr => domain % blocklist
- do while (associated(block_ptr))
- call sw_test_case_6(block_ptr % mesh, block_ptr % state % time_levs(1) % state)
- block_ptr => block_ptr % next
- end do
-
- else
- write(0,*) 'Abort: config_test_case=',config_test_case
- write(0,*) 'Only test case 1, 2, 5, and 6 ', &
- 'are currently supported. '
- call mpas_dmpar_abort(dminfo)
- end if
-
- block_ptr => domain % blocklist
- do while (associated(block_ptr))
-
- do i=2,nTimeLevs
- call mpas_copy_state(block_ptr % state % time_levs(i) % state, &
- block_ptr % state % time_levs(1) % state)
- end do
-
- block_ptr => block_ptr % next
- end do
-
- end subroutine setup_sw_test_case
-
-
- subroutine sw_test_case_1(grid, state)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Setup shallow water test case 1: Advection of Cosine Bell over the Pole
- !
- ! Reference: Williamson, D.L., et al., "A Standard Test Set for Numerical
- ! Approximations to the Shallow Water Equations in Spherical
- ! Geometry" J. of Comp. Phys., 102, pp. 211--224
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (mesh_type), intent(inout) :: grid
- type (state_type), intent(inout) :: state
-
- real (kind=RKIND), parameter :: u0 = 2.0 * pii * a / (12.0 * 86400.0)
- real (kind=RKIND), parameter :: h0 = 1000.0
- real (kind=RKIND), parameter :: theta_c = 0.0
- real (kind=RKIND), parameter :: lambda_c = 3.0*pii/2.0
- real (kind=RKIND), parameter :: alpha = pii/4.0
-
- integer :: iCell, iEdge, iVtx
- real (kind=RKIND) :: r, u, v
- real (kind=RKIND), allocatable, dimension(:) :: psiVertex
-
- !
- ! Scale all distances and areas from a unit sphere to one with radius a
- !
- grid % xCell % array = grid % xCell % array * a
- grid % yCell % array = grid % yCell % array * a
- grid % zCell % array = grid % zCell % array * a
- grid % xVertex % array = grid % xVertex % array * a
- grid % yVertex % array = grid % yVertex % array * a
- grid % zVertex % array = grid % zVertex % array * a
- grid % xEdge % array = grid % xEdge % array * a
- grid % yEdge % array = grid % yEdge % array * a
- grid % zEdge % array = grid % zEdge % array * a
- grid % dvEdge % array = grid % dvEdge % array * a
- grid % dcEdge % array = grid % dcEdge % array * a
- grid % areaCell % array = grid % areaCell % array * a**2.0
- grid % areaTriangle % array = grid % areaTriangle % array * a**2.0
- grid % kiteAreasOnVertex % array = grid % kiteAreasOnVertex % array * a**2.0
-
- !
- ! Initialize wind field
- !
- allocate(psiVertex(grid % nVertices))
- do iVtx=1,grid % nVertices
- psiVertex(iVtx) = -a * u0 * ( &
- sin(grid%latVertex%array(iVtx)) * cos(alpha) - &
- cos(grid%lonVertex%array(iVtx)) * cos(grid%latVertex%array(iVtx)) * sin(alpha) &
- )
- end do
- do iEdge=1,grid % nEdges
- state % u % array(1,iEdge) = -1.0 * ( &
- psiVertex(grid%verticesOnEdge%array(2,iEdge)) - &
- psiVertex(grid%verticesOnEdge%array(1,iEdge)) &
- ) / grid%dvEdge%array(iEdge)
- end do
- deallocate(psiVertex)
-
- !
- ! Initialize cosine bell at (theta_c, lambda_c)
- !
- do iCell=1,grid % nCells
- r = sphere_distance(theta_c, lambda_c, grid % latCell % array(iCell), grid % lonCell % array(iCell), a)
- if (r < a/3.0) then
- state % h % array(1,iCell) = (h0 / 2.0) * (1.0 + cos(pii*r*3.0/a))
- else
- state % h % array(1,iCell) = 0.0
- end if
- end do
-
- end subroutine sw_test_case_1
-
-
- subroutine sw_test_case_2(grid, state)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Setup shallow water test case 2: Global Steady State Nonlinear Zonal
- ! Geostrophic Flow
- !
- ! Reference: Williamson, D.L., et al., "A Standard Test Set for Numerical
- ! Approximations to the Shallow Water Equations in Spherical
- ! Geometry" J. of Comp. Phys., 102, pp. 211--224
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (mesh_type), intent(inout) :: grid
- type (state_type), intent(inout) :: state
-
- real (kind=RKIND), parameter :: u0 = 2.0 * pii * a / (12.0 * 86400.0)
- real (kind=RKIND), parameter :: gh0 = 29400.0
- real (kind=RKIND), parameter :: alpha = 0.0
-
- integer :: iCell, iEdge, iVtx
- real (kind=RKIND) :: u, v
- real (kind=RKIND), allocatable, dimension(:) :: psiVertex
-
-
- !
- ! Scale all distances and areas from a unit sphere to one with radius a
- !
- grid % xCell % array = grid % xCell % array * a
- grid % yCell % array = grid % yCell % array * a
- grid % zCell % array = grid % zCell % array * a
- grid % xVertex % array = grid % xVertex % array * a
- grid % yVertex % array = grid % yVertex % array * a
- grid % zVertex % array = grid % zVertex % array * a
- grid % xEdge % array = grid % xEdge % array * a
- grid % yEdge % array = grid % yEdge % array * a
- grid % zEdge % array = grid % zEdge % array * a
- grid % dvEdge % array = grid % dvEdge % array * a
- grid % dcEdge % array = grid % dcEdge % array * a
- grid % areaCell % array = grid % areaCell % array * a**2.0
- grid % areaTriangle % array = grid % areaTriangle % array * a**2.0
- grid % kiteAreasOnVertex % array = grid % kiteAreasOnVertex % array * a**2.0
-
-
- !
- ! Initialize wind field
- !
- allocate(psiVertex(grid % nVertices))
- do iVtx=1,grid % nVertices
- psiVertex(iVtx) = -a * u0 * ( &
- sin(grid%latVertex%array(iVtx)) * cos(alpha) - &
- cos(grid%lonVertex%array(iVtx)) * cos(grid%latVertex%array(iVtx)) * sin(alpha) &
- )
- end do
- do iEdge=1,grid % nEdges
- state % u % array(1,iEdge) = -1.0 * ( &
- psiVertex(grid%verticesOnEdge%array(2,iEdge)) - &
- psiVertex(grid%verticesOnEdge%array(1,iEdge)) &
- ) / grid%dvEdge%array(iEdge)
- end do
- deallocate(psiVertex)
-
- !
- ! Generate rotated Coriolis field
- !
- do iEdge=1,grid % nEdges
- grid % fEdge % array(iEdge) = 2.0 * omega * &
- ( -cos(grid%lonEdge%array(iEdge)) * cos(grid%latEdge%array(iEdge)) * sin(alpha) + &
- sin(grid%latEdge%array(iEdge)) * cos(alpha) &
- )
- end do
- do iVtx=1,grid % nVertices
- grid % fVertex % array(iVtx) = 2.0 * omega * &
- (-cos(grid%lonVertex%array(iVtx)) * cos(grid%latVertex%array(iVtx)) * sin(alpha) + &
- sin(grid%latVertex%array(iVtx)) * cos(alpha) &
- )
- end do
-
- !
- ! Initialize height field (actually, fluid thickness field)
- !
- do iCell=1,grid % nCells
- state % h % array(1,iCell) = (gh0 - (a * omega * u0 + 0.5 * u0**2.0) * &
- (-cos(grid%lonCell%array(iCell)) * cos(grid%latCell%array(iCell)) * sin(alpha) + &
- sin(grid%latCell%array(iCell)) * cos(alpha) &
- )**2.0 &
- ) / &
- gravity
- end do
-
- end subroutine sw_test_case_2
-
-
- subroutine sw_test_case_5(grid, state)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Setup shallow water test case 5: Zonal Flow over an Isolated Mountain
- !
- ! Reference: Williamson, D.L., et al., "A Standard Test Set for Numerical
- ! Approximations to the Shallow Water Equations in Spherical
- ! Geometry" J. of Comp. Phys., 102, pp. 211--224
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (mesh_type), intent(inout) :: grid
- type (state_type), intent(inout) :: state
-
- real (kind=RKIND), parameter :: u0 = 20.
- real (kind=RKIND), parameter :: gh0 = 5960.0*gravity
-! real (kind=RKIND), parameter :: hs0 = 2000. original
- real (kind=RKIND), parameter :: hs0 = 250. !mrp 100204
- real (kind=RKIND), parameter :: theta_c = pii/6.0
- real (kind=RKIND), parameter :: lambda_c = 3.0*pii/2.0
- real (kind=RKIND), parameter :: rr = pii/9.0
- real (kind=RKIND), parameter :: alpha = 0.0
-
- integer :: iCell, iEdge, iVtx
- real (kind=RKIND) :: r, u, v
- real (kind=RKIND), allocatable, dimension(:) :: psiVertex
-
-
- !
- ! Scale all distances and areas from a unit sphere to one with radius a
- !
- grid % xCell % array = grid % xCell % array * a
- grid % yCell % array = grid % yCell % array * a
- grid % zCell % array = grid % zCell % array * a
- grid % xVertex % array = grid % xVertex % array * a
- grid % yVertex % array = grid % yVertex % array * a
- grid % zVertex % array = grid % zVertex % array * a
- grid % xEdge % array = grid % xEdge % array * a
- grid % yEdge % array = grid % yEdge % array * a
- grid % zEdge % array = grid % zEdge % array * a
- grid % dvEdge % array = grid % dvEdge % array * a
- grid % dcEdge % array = grid % dcEdge % array * a
- grid % areaCell % array = grid % areaCell % array * a**2.0
- grid % areaTriangle % array = grid % areaTriangle % array * a**2.0
- grid % kiteAreasOnVertex % array = grid % kiteAreasOnVertex % array * a**2.0
-
- !
- ! Initialize wind field
- !
- allocate(psiVertex(grid % nVertices))
- do iVtx=1,grid % nVertices
- psiVertex(iVtx) = -a * u0 * ( &
- sin(grid%latVertex%array(iVtx)) * cos(alpha) - &
- cos(grid%lonVertex%array(iVtx)) * cos(grid%latVertex%array(iVtx)) * sin(alpha) &
- )
- end do
- do iEdge=1,grid % nEdges
- state % u % array(1,iEdge) = -1.0 * ( &
- psiVertex(grid%verticesOnEdge%array(2,iEdge)) - &
- psiVertex(grid%verticesOnEdge%array(1,iEdge)) &
- ) / grid%dvEdge%array(iEdge)
- end do
- deallocate(psiVertex)
-
- !
- ! Generate rotated Coriolis field
- !
- do iEdge=1,grid % nEdges
- grid % fEdge % array(iEdge) = 2.0 * omega * &
- (-cos(grid%lonEdge%array(iEdge)) * cos(grid%latEdge%array(iEdge)) * sin(alpha) + &
- sin(grid%latEdge%array(iEdge)) * cos(alpha) &
- )
- end do
- do iVtx=1,grid % nVertices
- grid % fVertex % array(iVtx) = 2.0 * omega * &
- (-cos(grid%lonVertex%array(iVtx)) * cos(grid%latVertex%array(iVtx)) * sin(alpha) + &
- sin(grid%latVertex%array(iVtx)) * cos(alpha) &
- )
- end do
-
- !
- ! Initialize mountain
- !
- do iCell=1,grid % nCells
- if (grid % lonCell % array(iCell) < 0.0) grid % lonCell % array(iCell) = grid % lonCell % array(iCell) + 2.0 * pii
- r = sqrt(min(rr**2.0, (grid % lonCell % array(iCell) - lambda_c)**2.0 + (grid % latCell % array(iCell) - theta_c)**2.0))
- grid % bottomDepth % array(iCell) = hs0 * (1.0 - r/rr)
- end do
-! output about mountain
-print *, 'bottomDepth',minval(grid % bottomDepth % array),sum(grid % bottomDepth % array)/grid % nCells, maxval(grid % bottomDepth % array)
-
- !
- ! Initialize tracer fields
- !
- do iCell=1,grid % nCells
- r = sqrt(min(rr**2.0, (grid % lonCell % array(iCell) - lambda_c)**2.0 + (grid % latCell % array(iCell) - theta_c)**2.0))
- state % tracers % array(1,1,iCell) = 1.0 - r/rr
- end do
- do iCell=1,grid % nCells
- r = sqrt(min(rr**2.0, (grid % lonCell % array(iCell) - lambda_c)**2.0 + &
- (grid % latCell % array(iCell) - theta_c - pii/6.0)**2.0 &
- ) &
- )
- state % tracers % array(2,1,iCell) = 1.0 - r/rr
- end do
-
- !
- ! Initialize height field (actually, fluid thickness field)
- !
- do iCell=1,grid % nCells
- state % h % array(1,iCell) = (gh0 - (a * omega * u0 + 0.5 * u0**2.0) * &
- (-cos(grid%lonCell%array(iCell)) * cos(grid%latCell%array(iCell)) * sin(alpha) + &
- sin(grid%latCell%array(iCell)) * cos(alpha) &
- )**2.0 &
- ) / &
- gravity
- state % h % array(1,iCell) = state % h % array(1,iCell) - grid % bottomDepth % array(iCell)
- end do
-
- end subroutine sw_test_case_5
-
-
- subroutine sw_test_case_6(grid, state)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Setup shallow water test case 6: Rossby-Haurwitz Wave
- !
- ! Reference: Williamson, D.L., et al., "A Standard Test Set for Numerical
- ! Approximations to the Shallow Water Equations in Spherical
- ! Geometry" J. of Comp. Phys., 102, pp. 211--224
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (mesh_type), intent(inout) :: grid
- type (state_type), intent(inout) :: state
-
- real (kind=RKIND), parameter :: h0 = 8000.0
- real (kind=RKIND), parameter :: w = 7.848e-6
- real (kind=RKIND), parameter :: K = 7.848e-6
- real (kind=RKIND), parameter :: R = 4.0
-
- integer :: iCell, iEdge, iVtx
- real (kind=RKIND) :: u, v
- real (kind=RKIND), allocatable, dimension(:) :: psiVertex
-
-
- !
- ! Scale all distances and areas from a unit sphere to one with radius a
- !
- grid % xCell % array = grid % xCell % array * a
- grid % yCell % array = grid % yCell % array * a
- grid % zCell % array = grid % zCell % array * a
- grid % xVertex % array = grid % xVertex % array * a
- grid % yVertex % array = grid % yVertex % array * a
- grid % zVertex % array = grid % zVertex % array * a
- grid % xEdge % array = grid % xEdge % array * a
- grid % yEdge % array = grid % yEdge % array * a
- grid % zEdge % array = grid % zEdge % array * a
- grid % dvEdge % array = grid % dvEdge % array * a
- grid % dcEdge % array = grid % dcEdge % array * a
- grid % areaCell % array = grid % areaCell % array * a**2.0
- grid % areaTriangle % array = grid % areaTriangle % array * a**2.0
- grid % kiteAreasOnVertex % array = grid % kiteAreasOnVertex % array * a**2.0
-
- !
- ! Initialize wind field
- !
- allocate(psiVertex(grid % nVertices))
- do iVtx=1,grid % nVertices
- psiVertex(iVtx) = -a * a * w * sin(grid%latVertex%array(iVtx)) + &
- a *a * K * (cos(grid%latVertex%array(iVtx))**R) * &
- sin(grid%latVertex%array(iVtx)) * cos(R * grid%lonVertex%array(iVtx))
- end do
- do iEdge=1,grid % nEdges
- state % u % array(1,iEdge) = -1.0 * ( &
- psiVertex(grid%verticesOnEdge%array(2,iEdge)) - &
- psiVertex(grid%verticesOnEdge%array(1,iEdge)) &
- ) / grid%dvEdge%array(iEdge)
- end do
- deallocate(psiVertex)
-
- !
- ! Initialize height field (actually, fluid thickness field)
- !
- do iCell=1,grid % nCells
- state % h % array(1,iCell) = (gravity * h0 + a*a*aa(grid%latCell%array(iCell)) + &
- a*a*bb(grid%latCell%array(iCell)) * cos(R*grid%lonCell%array(iCell)) + &
- a*a*cc(grid%latCell%array(iCell)) * cos(2.0*R*grid%lonCell%array(iCell)) &
- ) / gravity
- end do
-
- end subroutine sw_test_case_6
-
-
- real 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 function aa(theta)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! A, used in height field computation for Rossby-Haurwitz wave
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- real (kind=RKIND), parameter :: w = 7.848e-6
- real (kind=RKIND), parameter :: K = 7.848e-6
- real (kind=RKIND), parameter :: R = 4.0
-
- real (kind=RKIND), intent(in) :: theta
-
- aa = 0.5 * w * (2.0 * omega + w) * cos(theta)**2.0 + &
- 0.25 * K**2.0 * cos(theta)**(2.0*R) * ((R+1.0)*cos(theta)**2.0 + 2.0*R**2.0 - R - 2.0 - 2.0*R**2*cos(theta)**(-2.0))
-
- end function aa
-
-
- real function bb(theta)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! B, used in height field computation for Rossby-Haurwitz wave
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- real (kind=RKIND), parameter :: w = 7.848e-6
- real (kind=RKIND), parameter :: K = 7.848e-6
- real (kind=RKIND), parameter :: R = 4.0
-
- real (kind=RKIND), intent(in) :: theta
-
- bb = (2.0*(omega + w)*K / ((R+1.0)*(R+2.0))) * cos(theta)**R * ((R**2.0 + 2.0*R + 2.0) - ((R+1.0)*cos(theta))**2.0)
-
- end function bb
-
-
- real function cc(theta)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! C, used in height field computation for Rossby-Haurwitz wave
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- real (kind=RKIND), parameter :: w = 7.848e-6
- real (kind=RKIND), parameter :: K = 7.848e-6
- real (kind=RKIND), parameter :: R = 4.0
-
- real (kind=RKIND), intent(in) :: theta
-
- cc = 0.25 * K**2.0 * cos(theta)**(2.0*R) * ((R+1.0)*cos(theta)**2.0 - R - 2.0)
-
- end function cc
-
-end module ocn_test_cases
Modified: branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_time_average.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_time_average.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_time_average.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -15,7 +15,7 @@
real (kind=RKIND), dimension(:), pointer :: acc_ssh, acc_sshVar
real (kind=RKIND), dimension(:,:), pointer :: acc_uReconstructZonal, acc_uReconstructMeridional, acc_uReconstructZonalVar, acc_uReconstructMeridionalVar
- real (kind=RKIND), dimension(:,:), pointer :: acc_u, acc_uVar
+ real (kind=RKIND), dimension(:,:), pointer :: acc_u, acc_uVar, acc_vertVelocityTop
nAccumulate => state % nAccumulate % scalar
@@ -27,6 +27,7 @@
acc_uReconstructMeridionalVar => state % acc_uReconstructMeridionalVar % array
acc_u => state % acc_u % array
acc_uVar => state % acc_uVar % array
+ acc_vertVelocityTop => state % acc_vertVelocityTop % array
nAccumulate = 0
@@ -38,6 +39,7 @@
acc_uReconstructMeridionalVar = 0.0
acc_u = 0.0
acc_uVar = 0.0
+ acc_vertVelocityTop = 0.0
end subroutine ocn_time_average_init!}}}
@@ -48,13 +50,13 @@
real (kind=RKIND), pointer :: nAccumulate, old_nAccumulate
real (kind=RKIND), dimension(:), pointer :: ssh
- real (kind=RKIND), dimension(:,:), pointer :: uReconstructZonal, uReconstructMeridional, u
+ real (kind=RKIND), dimension(:,:), pointer :: uReconstructZonal, uReconstructMeridional, u, vertVelocityTop
- real (kind=RKIND), dimension(:,:), pointer :: acc_u, acc_uVar
+ real (kind=RKIND), dimension(:,:), pointer :: acc_u, acc_uVar, acc_vertVelocityTop
real (kind=RKIND), dimension(:,:), pointer :: acc_uReconstructZonal, acc_uReconstructMeridional, acc_uReconstructZonalVar, acc_uReconstructMeridionalVar
real (kind=RKIND), dimension(:), pointer :: acc_ssh, acc_sshVar
- real (kind=RKIND), dimension(:,:), pointer :: old_acc_u, old_acc_uVar
+ real (kind=RKIND), dimension(:,:), pointer :: old_acc_u, old_acc_uVar, old_acc_vertVelocityTop
real (kind=RKIND), dimension(:,:), pointer :: old_acc_uReconstructZonal, old_acc_uReconstructMeridional, old_acc_uReconstructZonalVar, old_acc_uReconstructMeridionalVar
real (kind=RKIND), dimension(:), pointer :: old_acc_ssh, old_acc_sshVar
@@ -65,6 +67,7 @@
uReconstructZonal => state % uReconstructZonal % array
uReconstructMeridional => state % uReconstructMeridional % array
u => state % u % array
+ vertVelocityTop => state % vertVelocityTop % array
acc_ssh => state % acc_ssh % array
acc_sshVar => state % acc_sshVar % array
@@ -74,6 +77,7 @@
acc_uReconstructMeridionalVar => state % acc_uReconstructMeridionalVar % array
acc_u => state % acc_u % array
acc_uVar => state % acc_uVar % array
+ acc_vertVelocityTop => state % acc_vertVelocityTop % array
old_acc_ssh => old_state % acc_ssh % array
old_acc_sshVar => old_state % acc_sshVar % array
@@ -83,6 +87,7 @@
old_acc_uReconstructMeridionalVar => old_state % acc_uReconstructMeridionalVar % array
old_acc_u => old_state % acc_u % array
old_acc_uVar => old_state % acc_uVar % array
+ old_acc_vertVelocityTop => old_state % acc_vertVelocityTop % array
acc_ssh = old_acc_ssh + ssh
acc_sshVar = old_acc_sshVar + ssh**2
@@ -92,6 +97,7 @@
acc_uReconstructMeridionalVar = old_acc_uReconstructMeridionalVar + uReconstructMeridional**2
acc_u = old_acc_u + u
acc_uVar = old_acc_uVar + u**2
+ acc_vertVelocityTop = old_acc_vertVelocityTop + vertVelocityTop
nAccumulate = old_nAccumulate + 1
end subroutine ocn_time_average_accumulate!}}}
@@ -103,7 +109,7 @@
real (kind=RKIND), dimension(:), pointer :: acc_ssh, acc_sshVar
real (kind=RKIND), dimension(:,:), pointer :: acc_uReconstructZonal, acc_uReconstructMeridional, acc_uReconstructZonalVar, acc_uReconstructMeridionalVar
- real (kind=RKIND), dimension(:,:), pointer :: acc_u, acc_uVar
+ real (kind=RKIND), dimension(:,:), pointer :: acc_u, acc_uVar, acc_vertVelocityTop
nAccumulate => state % nAccumulate % scalar
@@ -115,6 +121,7 @@
acc_uReconstructMeridionalVar => state % acc_uReconstructMeridionalVar % array
acc_u => state % acc_u % array
acc_uVar => state % acc_uVar % array
+ acc_vertVelocityTop => state % acc_vertVelocityTop % array
if(nAccumulate > 0) then
acc_ssh = acc_ssh / nAccumulate
@@ -125,6 +132,7 @@
acc_uReconstructMeridionalVar = acc_uReconstructMeridionalVar / nAccumulate
acc_u = acc_u / nAccumulate
acc_uVar = acc_uVar / nAccumulate
+ acc_vertVelocityTop = acc_vertVelocityTop / nAccumulate
end if
end subroutine ocn_time_average_normalize!}}}
Modified: branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_time_integration_rk4.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_time_integration_rk4.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_time_integration_rk4.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -22,6 +22,7 @@
use mpas_timer
use ocn_tendency
+ use ocn_diagnostics
use ocn_equation_of_state
use ocn_vmix
@@ -148,7 +149,7 @@
!$OMP SINGLE
call mpas_timer_start("RK4-diagnostic halo update")
call mpas_dmpar_exch_halo_field(domain % blocklist % provis % Vor_edge)
- if (config_h_mom_eddy_visc4 > 0.0) then
+ if (config_mom_del4 > 0.0) then
call mpas_dmpar_exch_halo_field(domain % blocklist % provis % divergence)
call mpas_dmpar_exch_halo_field(domain % blocklist % provis % vorticity)
end if
@@ -162,11 +163,6 @@
!$OMP END SINGLE
block => domain % blocklist
do while (associated(block))
-
- if (.not.config_implicit_vertical_mix) then
- call ocn_vmix_coefs(block % mesh, block % provis, block % diagnostics, block % scratch, err)
- end if
-
! advection of u uses u, while advection of h and tracers use uTransport.
call ocn_wtop(block % mesh, block % provis % h % array, block % provis % h_edge % array, &
block % provis % u % array, block % provis % wTop % array, err)
@@ -180,7 +176,7 @@
call ocn_filter_btr_mode_tend_u(block % tend, block % provis, block % mesh)
endif
- call ocn_tend_scalar(block % tend, block % provis, block % diagnostics, block % mesh, block % scratch, dt)
+ call ocn_tend_tracer(block % tend, block % provis, block % diagnostics, block % mesh, block % scratch, dt)
block => block % next
end do
!$OMP SINGLE
@@ -222,12 +218,6 @@
end do
!$OMP END DO
- if (config_test_case == 1) then ! For case 1, wind field should be fixed
- !$OMP WORKSHARE
- block % provis % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:)
- !$OMP END WORKSHARE
- end if
-
if (config_prescribe_velocity) then
!$OMP WORKSHARE
block % provis % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:)
@@ -296,7 +286,7 @@
!$OMP END SINGLE
!
- ! A little clean up at the end: decouple new scalar fields and compute diagnostics for new state
+ ! A little clean up at the end: rescale tracer fields and compute diagnostics for new state
!
!$OMP SINGLE
call mpas_timer_start("RK4-cleaup phase")
@@ -316,48 +306,38 @@
block => block % next
end do
+ !$OMP SINGLE
+ call mpas_timer_start("RK4-implicit vert mix")
+ !$OMP END SINGLE
+ block => domain % blocklist
+ do while(associated(block))
+ ! Call ocean diagnostic solve in preparation for vertical mixing. Note
+ ! it is called again after vertical mixing, because u and tracers change.
+ ! For Richardson vertical mixing, only rho, h_edge, and ke_edge need to
+ ! be computed. For kpp, more variables may be needed. Either way, this
+ ! could be made more efficient by only computing what is needed for the
+ ! implicit vmix routine that follows.
+ call ocn_diagnostic_solve(dt, block % state % time_levs(2) % state, block % mesh)
- if (config_implicit_vertical_mix) then
- !$OMP SINGLE
- call mpas_timer_start("RK4-implicit vert mix")
- !$OMP END SINGLE
- block => domain % blocklist
- do while(associated(block))
+ call ocn_vmix_implicit(dt, block % mesh, block % diagnostics, block % state % time_levs(2) % state, block % scratch, err)
+ block => block % next
+ end do
- ! Call ocean diagnostic solve in preparation for vertical mixing. Note
- ! it is called again after vertical mixing, because u and tracers change.
- ! For Richardson vertical mixing, only rho, h_edge, and ke_edge need to
- ! be computed. For kpp, more variables may be needed. Either way, this
- ! could be made more efficient by only computing what is needed for the
- ! implicit vmix routine that follows. mrp 121023.
- call ocn_diagnostic_solve(dt, block % state % time_levs(2) % state, block % mesh)
+ ! Update halo on u and tracers, which were just updated for implicit vertical mixing. If not done,
+ ! this leads to lack of volume conservation. It is required because halo updates in RK4 are only
+ ! conducted on tendencies, not on the velocity and tracer fields. So this update is required to
+ ! communicate the change due to implicit vertical mixing across the boundary.
+ !$OMP SINGLE
+ call mpas_timer_start("RK4-implicit vert mix halos")
+ call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % u)
+ call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % tracers)
+ call mpas_timer_stop("RK4-implicit vert mix halos")
+ call mpas_timer_stop("RK4-implicit vert mix")
+ call mpas_timer_stop("RK4-implicit vert mix")
+ !$OMP END SINGLE
- call ocn_vmix_implicit(dt, block % mesh, block % diagnostics, block % state % time_levs(2) % state, block % scratch, err)
- block => block % next
- end do
-
- ! Update halo on u and tracers, which were just updated for implicit vertical mixing. If not done,
- ! this leads to lack of volume conservation. It is required because halo updates in RK4 are only
- ! conducted on tendencies, not on the velocity and tracer fields. So this update is required to
- ! communicate the change due to implicit vertical mixing across the boundary.
- !$OMP SINGLE
- call mpas_timer_start("RK4-implicit vert mix halos")
- call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % u)
- call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % tracers)
- call mpas_timer_stop("RK4-implicit vert mix halos")
-
- call mpas_timer_stop("RK4-implicit vert mix")
- !$OMP END SINGLE
- end if
-
block => domain % blocklist
do while (associated(block))
- if (config_test_case == 1) then ! For case 1, wind field should be fixed
- !$OMP WORKSHARE
- block % state % time_levs(2) % state % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:)
- !$OMP END WORKSHARE
- end if
-
if (config_prescribe_velocity) then
!$OMP WORKSHARE
block % state % time_levs(2) % state % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:)
@@ -389,7 +369,6 @@
block % state % time_levs(2) % state % uReconstructMeridional % array &
)
-!TDR
!$OMP SECTION
call mpas_reconstruct(block % mesh, block % mesh % u_src % array, &
block % state % time_levs(2) % state % uSrcReconstructX % array, &
Modified: branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_time_integration_split.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_time_integration_split.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_time_integration_split.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -24,6 +24,7 @@
use mpas_timer
use ocn_tendency
+ use ocn_diagnostics
use ocn_equation_of_state
use ocn_vmix
@@ -178,7 +179,7 @@
!$OMP SINGLE
call mpas_timer_start("se halo diag", .false., timer_halo_diagnostic)
call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % Vor_edge)
- if (config_h_mom_eddy_visc4 > 0.0) then
+ if (config_mom_del4 > 0.0) then
call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % divergence)
call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % vorticity)
end if
@@ -201,12 +202,6 @@
stage1_tend_time = min(split_explicit_step,2)
- !$OMP SINGLE
- if (.not.config_implicit_vertical_mix) then
- call ocn_vmix_coefs(block % mesh, block % state % time_levs(stage1_tend_time) % state, block % diagnostics, block % scratch, err)
- end if
- !$OMP END SINGLE
-
! compute wTop. Use u (rather than uTransport) for momentum advection.
! Use the most recent time level available.
call ocn_wtop(block % mesh, block % state % time_levs(stage1_tend_time) % state % h % array, &
@@ -462,7 +457,6 @@
! config_btr_gam1_uWt1= 1 flux = uBtrNew*H
! config_btr_gam1_uWt1=0.5 flux = 1/2*(uBtrNew+uBtrOld)*H
! config_btr_gam1_uWt1= 0 flux = uBtrOld*H
- ! mrp 120201 efficiency: could we combine the following edge and cell loops?
!$OMP DO PRIVATE(i, iEdge, cell1, cell2, sshEdge, hSum, flux)
do iCell = 1, block % mesh % nCells
@@ -626,7 +620,6 @@
! config_btr_gam3_uWt2= 1 flux = uBtrNew*H
! config_btr_gam3_uWt2=0.5 flux = 1/2*(uBtrNew+uBtrOld)*H
! config_btr_gam3_uWt2= 0 flux = uBtrOld*H
- ! mrp 120201 efficiency: could we combine the following edge and cell loops?
!$OMP DO PRIVATE(i, iEdge, cell1, cell2, sshCell1, sshCell2, sshEdge, hSum, flux)
do iCell = 1, block % mesh % nCells
@@ -856,13 +849,8 @@
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !TDR: it seems almost trivial to hold off on doing T, S and rho updates until the
- !TDR: dycore time step is complete. we might want to take this opportunity to clean-up
- !TDR: Stage3 in order to faciliate the testing of not doing tracer updates after this code is committed to trunk.
- !TDR: at this point, I am suggesting just pushing some of this code into subroutines.
- !TDR: see comments farther down
-
- ! dwj: 02/22/12 splitting thickness and tracer tendency computations and halo updates to allow monotonic advection.
+ ! Thickness tendency computations and thickness halo updates are completed before tracer
+ ! tendency computations to allow monotonic advection.
block => domain % blocklist
do while (associated(block))
@@ -886,7 +874,7 @@
block => domain % blocklist
do while (associated(block))
- call ocn_tend_scalar(block % tend, block % state % time_levs(2) % state, block % diagnostics, block % mesh, block % scratch, dt)
+ call ocn_tend_tracer(block % tend, block % state % time_levs(2) % state, block % diagnostics, block % mesh, block % scratch, dt)
block => block % next
end do
@@ -908,9 +896,6 @@
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
if (split_explicit_step < config_n_ts_iter) then
- !TDR: should we move this code into a subroutine called "compute_intermediate_value_at_midtime"
- !TDR: this could be within a contains statement in this routine
-
! Only need T & S for earlier iterations,
! then all the tracers needed the last time through.
!$OMP DO PRIVATE(k, temp_h, i)
@@ -963,8 +948,8 @@
end do ! iEdge
!$OMP END DO
- ! mrp 110512 I really only need this to compute h_edge, density, pressure, and SSH
- ! I can par this down later.
+ ! Efficiency note: We really only need this to compute h_edge, density, pressure, and SSH
+ ! in this diagnostics solve.
call ocn_diagnostic_solve(dt, block % state % time_levs(2) % state, block % mesh)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -974,9 +959,6 @@
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
elseif (split_explicit_step == config_n_ts_iter) then
- !TDR: should we move this code into a subroutine called "compute_final_values_at_nplus1"?
- !TDR: this could be within a contains statement in this routine
-
!$OMP DO PRIVATE(k, i)
do iCell=1,block % mesh % nCells
do k=1,block % mesh % maxLevelCell % array(iCell)
@@ -1028,95 +1010,84 @@
! END large iteration loop
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- if (config_implicit_vertical_mix) then
- !$OMP SINGLE
- call mpas_timer_start("se implicit vert mix")
- !$OMP END SINGLE
- block => domain % blocklist
- do while(associated(block))
+ !$OMP SINGLE
+ call mpas_timer_start("se implicit vert mix")
+ !$OMP END SINGLE
+ block => domain % blocklist
+ do while(associated(block))
- ! Call ocean diagnostic solve in preparation for vertical mixing. Note
- ! it is called again after vertical mixing, because u and tracers change.
- ! For Richardson vertical mixing, only rho, h_edge, and ke_edge need to
- ! be computed. For kpp, more variables may be needed. Either way, this
- ! could be made more efficient by only computing what is needed for the
- ! implicit vmix routine that follows. mrp 121023.
- call ocn_diagnostic_solve(dt, block % state % time_levs(2) % state, block % mesh)
+ ! Call ocean diagnostic solve in preparation for vertical mixing. Note
+ ! it is called again after vertical mixing, because u and tracers change.
+ ! For Richardson vertical mixing, only rho, h_edge, and ke_edge need to
+ ! be computed. For kpp, more variables may be needed. Either way, this
+ ! could be made more efficient by only computing what is needed for the
+ ! implicit vmix routine that follows.
+ call ocn_diagnostic_solve(dt, block % state % time_levs(2) % state, block % mesh)
- call ocn_vmix_implicit(dt, block % mesh, block % diagnostics, block % state % time_levs(2) % state, block % scratch, err)
+ call ocn_vmix_implicit(dt, block % mesh, block % diagnostics, block % state % time_levs(2) % state, block % scratch, err)
- block => block % next
- end do
+ block => block % next
+ end do
- ! Update halo on u and tracers, which were just updated for implicit vertical mixing. If not done,
- ! this leads to lack of volume conservation. It is required because halo updates in stage 3 are only
- ! conducted on tendencies, not on the velocity and tracer fields. So this update is required to
- ! communicate the change due to implicit vertical mixing across the boundary.
- !$OMP SINGLE
- call mpas_timer_start("se implicit vert mix halos")
- call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % u)
- call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % tracers)
- call mpas_timer_stop("se implicit vert mix halos")
+ ! Update halo on u and tracers, which were just updated for implicit vertical mixing. If not done,
+ ! this leads to lack of volume conservation. It is required because halo updates in stage 3 are only
+ ! conducted on tendencies, not on the velocity and tracer fields. So this update is required to
+ ! communicate the change due to implicit vertical mixing across the boundary.
+ !$OMP SINGLE
+ call mpas_timer_start("se implicit vert mix halos")
+ call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % u)
+ call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % tracers)
+ call mpas_timer_stop("se implicit vert mix halos")
+ call mpas_timer_stop("se implicit vert mix")
+ !$OMP END SINGLE
+ call mpas_timer_stop("se implicit vert mix")
- call mpas_timer_stop("se implicit vert mix")
- !$OMP END SINGLE
- end if
-
block => domain % blocklist
do while (associated(block))
+ if (config_prescribe_velocity) then
+ !$OMP WORKSHARE
+ block % state % time_levs(2) % state % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:)
+ !$OMP END WORKSHARE
+ end if
- if (config_test_case == 1) then ! For case 1, wind field should be fixed
- !$OMP WORKSHARE
- block % state % time_levs(2) % state % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:)
- !$OMP END WORKSHARE
- end if
+ if (config_prescribe_thickness) then
+ !$OMP WORKSHARE
+ block % state % time_levs(2) % state % h % array(:,:) = block % state % time_levs(1) % state % h % array(:,:)
+ !$OMP END WORKSHARE
+ end if
- if (config_prescribe_velocity) then
- !$OMP WORKSHARE
- block % state % time_levs(2) % state % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:)
- !$OMP END WORKSHARE
- end if
+ call ocn_diagnostic_solve(dt, block % state % time_levs(2) % state, block % mesh)
- if (config_prescribe_thickness) then
- !$OMP WORKSHARE
- block % state % time_levs(2) % state % h % array(:,:) = block % state % time_levs(1) % state % h % array(:,:)
- !$OMP END WORKSHARE
- end if
+ ! Compute velocity transport, used in advection terms of h and tracer tendency
+ !$OMP WORKSHARE
+ block % state % time_levs(2) % state % uTransport % array(:,:) &
+ = block % state % time_levs(2) % state % u % array(:,:) &
+ + block % state % time_levs(2) % state % uBolusGM % array(:,:)
+ !$OMP END WORKSHARE
- call ocn_diagnostic_solve(dt, block % state % time_levs(2) % state, block % mesh)
+ !$OMP SINGLE
+ call mpas_reconstruct(block % mesh, block % state % time_levs(2) % state % u % array, &
+ block % state % time_levs(2) % state % uReconstructX % array, &
+ block % state % time_levs(2) % state % uReconstructY % array, &
+ block % state % time_levs(2) % state % uReconstructZ % array, &
+ block % state % time_levs(2) % state % uReconstructZonal % array, &
+ block % state % time_levs(2) % state % uReconstructMeridional % array &
+ )
+ !$OMP END SINGLE NOWAIT
- ! Compute velocity transport, used in advection terms of h and tracer tendency
- !$OMP WORKSHARE
- block % state % time_levs(2) % state % uTransport % array(:,:) &
- = block % state % time_levs(2) % state % u % array(:,:) &
- + block % state % time_levs(2) % state % uBolusGM % array(:,:)
- !$OMP END WORKSHARE
-
- !$OMP SINGLE
- call mpas_reconstruct(block % mesh, block % state % time_levs(2) % state % u % array, &
- block % state % time_levs(2) % state % uReconstructX % array, &
- block % state % time_levs(2) % state % uReconstructY % array, &
- block % state % time_levs(2) % state % uReconstructZ % array, &
- block % state % time_levs(2) % state % uReconstructZonal % array, &
- block % state % time_levs(2) % state % uReconstructMeridional % array &
- )
- !$OMP END SINGLE NOWAIT
-
+ !$OMP SINGLE
+ call mpas_reconstruct(block % mesh, block % mesh % u_src % array, &
+ block % state % time_levs(2) % state % uSrcReconstructX % array, &
+ block % state % time_levs(2) % state % uSrcReconstructY % array, &
+ block % state % time_levs(2) % state % uSrcReconstructZ % array, &
+ block % state % time_levs(2) % state % uSrcReconstructZonal % array, &
+ block % state % time_levs(2) % state % uSrcReconstructMeridional % array &
+ )
+ !$OMP END SINGLE
!TDR
- !$OMP SINGLE
- call mpas_reconstruct(block % mesh, block % mesh % u_src % array, &
- block % state % time_levs(2) % state % uSrcReconstructX % array, &
- block % state % time_levs(2) % state % uSrcReconstructY % array, &
- block % state % time_levs(2) % state % uSrcReconstructZ % array, &
- block % state % time_levs(2) % state % uSrcReconstructZonal % array, &
- block % state % time_levs(2) % state % uSrcReconstructMeridional % array &
- )
- !$OMP END SINGLE
-!TDR
+ call ocn_time_average_accumulate(block % state % time_levs(2) % state, block % state % time_levs(1) % state)
- call ocn_time_average_accumulate(block % state % time_levs(2) % state, block % state % time_levs(1) % state)
-
- block => block % next
+ block => block % next
end do
!$OMP SINGLE
Modified: branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_tracer_advection_std.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_tracer_advection_std.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_tracer_advection_std.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -51,7 +51,7 @@
! Input: s - current model state
! grid - grid metadata
!
- ! Output: tend - computed scalar tendencies
+ ! Output: tend - computed tracer tendencies
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
real (kind=RKIND), dimension(:,:,:), intent(inout) :: tend !< Input/Output: Tracer tendency
Modified: branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_tracer_hmix_del2.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_tracer_hmix_del2.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_tracer_hmix_del2.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -213,9 +213,9 @@
del2on = .false.
- if ( config_h_tracer_eddy_diff2 > 0.0 ) then
+ if ( config_tracer_del2 > 0.0 ) then
del2On = .true.
- eddyDiff2 = config_h_tracer_eddy_diff2
+ eddyDiff2 = config_tracer_del2
endif
if(.not.config_use_tracer_del2) del2on = .false.
Modified: branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_tracer_hmix_del4.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_tracer_hmix_del4.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_tracer_hmix_del4.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -249,9 +249,9 @@
err = 0
del4on = .false.
- if ( config_h_tracer_eddy_diff4 > 0.0 ) then
+ if ( config_tracer_del4 > 0.0 ) then
del4On = .true.
- eddyDiff4 = config_h_tracer_eddy_diff4
+ eddyDiff4 = config_tracer_del4
endif
if(.not.config_use_tracer_del4) del4on = .false.
Modified: branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_tracer_vadv.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_tracer_vadv.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_tracer_vadv.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -123,11 +123,6 @@
err = 0
- ! mrp 120202 efficiency note:
- ! The following if statement is not needed, since wTop is set to
- ! zero for isopycnal coordinates. This if statment saves flops
- ! for isopycnal coordinates. However, if the loops are pushed
- ! out, we could get rid of this if statement.
if(.not.vadvOn) return
call ocn_tracer_vadv_stencil_tend(grid, h, wTop, tracers, tend, err1)
Modified: branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_tracer_vadv_spline3.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_tracer_vadv_spline3.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_tracer_vadv_spline3.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -150,8 +150,6 @@
depthTop(k+1) = depthTop(k) + h(k,iCell)
enddo
- ! mrp 110201 efficiency note: push tracer loop down
- ! into spline subroutines to improve efficiency
do iTracer=1,num_tracers
! Place data in arrays to avoid creating new temporary arrays for every
Modified: branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_vel_forcing.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_vel_forcing.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_vel_forcing.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -18,7 +18,6 @@
use mpas_configure
use ocn_vel_forcing_windstress
- use ocn_vel_forcing_bottomdrag
use ocn_vel_forcing_rayleigh
implicit none
@@ -115,7 +114,7 @@
!
!-----------------------------------------------------------------
- integer :: err1, err2, err3
+ integer :: err1, err2
!-----------------------------------------------------------------
!
@@ -126,11 +125,9 @@
!-----------------------------------------------------------------
call ocn_vel_forcing_windstress_tend(grid, u_src, h_edge, tend, err1)
- call ocn_vel_forcing_bottomdrag_tend(grid, u, ke_edge, h_edge, tend, err2)
- call ocn_vel_forcing_rayleigh_tend(grid, u, tend, err3)
+ call ocn_vel_forcing_rayleigh_tend(grid, u, tend, err2)
err = ior(err1, err2)
- err = ior(err, err3)
!--------------------------------------------------------------------
@@ -164,14 +161,12 @@
integer, intent(out) :: err !< Output: error flag
- integer :: err1, err2, err3
+ integer :: err1, err2
call ocn_vel_forcing_windstress_init(err1)
- call ocn_vel_forcing_bottomdrag_init(err2)
- call ocn_vel_forcing_rayleigh_init(err3)
+ call ocn_vel_forcing_rayleigh_init(err2)
err = ior(err1, err2)
- err = ior(err, err3)
!--------------------------------------------------------------------
Modified: branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_vel_hmix_del2.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_vel_hmix_del2.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_vel_hmix_del2.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -203,13 +203,12 @@
hmixDel2On = .false.
- if ( config_h_mom_eddy_visc2 > 0.0 ) then
+ if ( config_mom_del2 > 0.0 ) then
hmixDel2On = .true.
- eddyVisc2 = config_h_mom_eddy_visc2
+ eddyVisc2 = config_mom_del2
-
if (config_visc_vorticity_term) then
- viscVortCoef = config_visc_vorticity_visc2_scale
+ viscVortCoef = config_vorticity_del2_scale
else
viscVortCoef = 0.0
endif
Modified: branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_vel_hmix_del4.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_vel_hmix_del4.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_vel_hmix_del4.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -193,7 +193,7 @@
do k=1,maxLevelEdgeTop(iEdge)
! Compute </font>
<font color="black">abla^2 u = </font>
<font color="black">abla divergence + k \times </font>
<font color="gray">abla vorticity
delsq_u(k, iEdge) = ( divergence(k,cell2) - divergence(k,cell1) ) * invDcEdge &
- -viscVortCoef *( vorticity(k,vertex2) - vorticity(k,vertex1)) * invDcEdge * sqrt(3.0) ! TDR
+ -viscVortCoef *( vorticity(k,vertex2) - vorticity(k,vertex1)) * invDcEdge * sqrt(3.0)
end do
end do
!$OMP END DO
@@ -239,7 +239,7 @@
do k=1,maxLevelEdgeTop(iEdge)
u_diffusion = (delsq_divergence(k,cell2) - delsq_divergence(k,cell1)) * invDcEdge &
- -viscVortCoef * (delsq_vorticity(k,vertex2) - delsq_vorticity(k,vertex1) ) * invDcEdge * sqrt(3.0) ! TDR
+ -viscVortCoef * (delsq_vorticity(k,vertex2) - delsq_vorticity(k,vertex1) ) * invDcEdge * sqrt(3.0)
tend(k,iEdge) = tend(k,iEdge) - edgeMask(k, iEdge) * u_diffusion * r_tmp
end do
@@ -285,11 +285,11 @@
hmixDel4On = .false.
- if ( config_h_mom_eddy_visc4 > 0.0 ) then
+ if ( config_mom_del4 > 0.0 ) then
hmixDel4On = .true.
- eddyVisc4 = config_h_mom_eddy_visc4
+ eddyVisc4 = config_mom_del4
if (config_visc_vorticity_term) then
- viscVortCoef = config_visc_vorticity_visc4_scale
+ viscVortCoef = config_vorticity_del4_scale
else
viscVortCoef = 0.0
endif
Modified: branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_vel_hmix_leith.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_vel_hmix_leith.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_vel_hmix_leith.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -216,7 +216,7 @@
hmixLeithOn = .true.
if (config_visc_vorticity_term) then
- viscVortCoef = config_visc_vorticity_visc2_scale
+ viscVortCoef = config_vorticity_del2_scale
else
viscVortCoef = 0.0
endif
Modified: branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_vel_vadv.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_vel_vadv.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_vel_vadv.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -112,11 +112,6 @@
real (kind=RKIND) :: wTopEdge
real (kind=RKIND), dimension(:), allocatable :: w_dudzTopEdge
- ! mrp 120202 efficiency note:
- ! The following if statement is not needed, since wTop is set to
- ! zero for isopycnal coordinates. This if statment saves flops
- ! for isopycnal coordinates. However, if the loops are pushed
- ! out, we could get rid of this if statement.
if(.not.velVadvOn) return
err = 0
Modified: branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_vmix.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_vmix.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_vmix.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -44,8 +44,6 @@
tridiagonal_solve_mult
public :: ocn_vmix_coefs, &
- ocn_vel_vmix_tend_explicit, &
- ocn_tracer_vmix_tend_explicit, &
ocn_vel_vmix_tend_implicit, &
ocn_tracer_vmix_tend_implicit, &
ocn_vmix_init, &
@@ -58,7 +56,6 @@
!--------------------------------------------------------------------
logical :: velVmixOn, tracerVmixOn
- logical :: explicitOn, implicitOn
!***********************************************************************
@@ -142,100 +139,6 @@
!***********************************************************************
!
-! routine ocn_vel_vmix_tendExplict
-!
-!> \brief Computes tendencies for explict momentum vertical mixing
-!> \author Doug Jacobsen
-!> \date 19 September 2011
-!> \version SVN:$Id$
-!> \details
-!> This routine computes the tendencies for explicit vertical mixing for momentum
-!> using computed coefficients.
-!
-!-----------------------------------------------------------------------
-
- subroutine ocn_vel_vmix_tend_explicit(grid, u, h_edge, vertViscTopOfEdge, tend, err)!{{{
-
- !-----------------------------------------------------------------
- !
- ! input variables
- !
- !-----------------------------------------------------------------
-
- type (mesh_type), intent(in) :: &
- grid !< Input: grid information
-
- real (kind=RKIND), dimension(:,:), intent(in) :: &
- u !< Input: velocity
-
- real (kind=RKIND), dimension(:,:), intent(in) :: &
- h_edge !< Input: thickness at edge
-
- real (kind=RKIND), dimension(:,:), intent(in) :: &
- vertViscTopOfEdge !< Input: vertical mixing coefficients
-
- !-----------------------------------------------------------------
- !
- ! input/output variables
- !
- !-----------------------------------------------------------------
-
- real (kind=RKIND), dimension(:,:), intent(inout) :: &
- tend !< Input/Output: tendency information
-
- !-----------------------------------------------------------------
- !
- ! output variables
- !
- !-----------------------------------------------------------------
-
- integer, intent(out) :: err !< Output: error flag
-
- !-----------------------------------------------------------------
- !
- ! local variables
- !
- !-----------------------------------------------------------------
-
- integer :: iEdge, nEdgesSolve, k, nVertLevels
-
- integer, dimension(:), pointer :: maxLevelEdgeTop
-
- real (kind=RKIND), dimension(:), allocatable :: fluxVertTop
-
- err = 0
-
- if(.not.velVmixOn) return
- if(implicitOn) return
-
- nEdgessolve = grid % nEdgesSolve
- nVertLevels = grid % nVertLevels
- maxLevelEdgeTop => grid % maxLevelEdgeTop % array
-
- allocate(fluxVertTop(nVertLevels+1))
- fluxVertTop(1) = 0.0
- do iEdge=1,nEdgesSolve
- do k=2,maxLevelEdgeTop(iEdge)
- fluxVertTop(k) = vertViscTopOfEdge(k,iEdge) &
- * ( u(k-1,iEdge) - u(k,iEdge) ) &
- * 2 / (h_edge(k-1,iEdge) + h_edge(k,iEdge))
- enddo
- fluxVertTop(maxLevelEdgeTop(iEdge)+1) = 0.0
-
- do k=1,maxLevelEdgeTop(iEdge)
- tend(k,iEdge) = tend(k,iEdge) &
- + (fluxVertTop(k) - fluxVertTop(k+1)) &
- / h_edge(k,iEdge)
- enddo
-
- end do
- deallocate(fluxVertTop)
- !--------------------------------------------------------------------
-
- end subroutine ocn_vel_vmix_tend_explicit!}}}
-
-!***********************************************************************
-!
! routine ocn_vel_vmix_tend_implicit
!
!> \brief Computes tendencies for implicit momentum vertical mixing
@@ -308,7 +211,6 @@
err = 0
if(.not.velVmixOn) return
- if(explicitOn) return
nEdges = grid % nEdges
nVertLevels = grid % nVertLevels
@@ -373,111 +275,6 @@
!***********************************************************************
!
-! routine ocn_tracer_vmix_tendExplict
-!
-!> \brief Computes tendencies for explict tracer vertical mixing
-!> \author Doug Jacobsen
-!> \date 19 September 2011
-!> \version SVN:$Id$
-!> \details
-!> This routine computes the tendencies for explicit vertical mixing for
-!> tracers using computed coefficients.
-!
-!-----------------------------------------------------------------------
-
- subroutine ocn_tracer_vmix_tend_explicit(grid, h, vertDiffTopOfCell, tracers, tend, err)!{{{
-
- !-----------------------------------------------------------------
- !
- ! input variables
- !
- !-----------------------------------------------------------------
-
- type (mesh_type), intent(in) :: &
- grid !< Input: grid information
-
- real (kind=RKIND), dimension(:,:), intent(in) :: &
- h !< Input: thickness at cell center
-
- real (kind=RKIND), dimension(:,:), intent(in) :: &
- vertDiffTopOfCell !< Input: vertical mixing coefficients
-
- real (kind=RKIND), dimension(:,:,:), intent(in) :: &
- tracers !< Input: tracers
-
- !-----------------------------------------------------------------
- !
- ! input/output variables
- !
- !-----------------------------------------------------------------
-
- real (kind=RKIND), dimension(:,:,:), intent(inout) :: &
- tend !< Input/Output: tendency information
-
- !-----------------------------------------------------------------
- !
- ! output variables
- !
- !-----------------------------------------------------------------
-
- integer, intent(out) :: err !< Output: error flag
-
- !-----------------------------------------------------------------
- !
- ! local variables
- !
- !-----------------------------------------------------------------
-
- integer :: iCell, nCellsSolve, k, iTracer, num_tracers, nVertLevels
-
- integer, dimension(:), pointer :: maxLevelCell
-
- real (kind=RKIND), dimension(:,:), allocatable :: fluxVertTop
-
- err = 0
-
- if(.not.tracerVmixOn) return
- if(implicitOn) return
-
- nCellsSolve = grid % nCellsSolve
- nVertLevels = grid % nVertLevels
- num_tracers = size(tracers, dim=1)
-
- maxLevelCell => grid % maxLevelCell % array
-
- allocate(fluxVertTop(num_tracers,nVertLevels+1))
- fluxVertTop(:,1) = 0.0
- do iCell=1,nCellsSolve
-
- do k=2,maxLevelCell(iCell)
- do iTracer=1,num_tracers
- ! compute \kappa_v d\phi/dz
- fluxVertTop(iTracer,k) = vertDiffTopOfCell(k,iCell) &
- * ( tracers(iTracer,k-1,iCell) &
- - tracers(iTracer,k ,iCell) ) &
- * 2 / (h(k-1,iCell) + h(k,iCell))
-
- enddo
- enddo
- fluxVertTop(:,maxLevelCell(iCell)+1) = 0.0
-
- do k=1,maxLevelCell(iCell)
- do iTracer=1,num_tracers
- ! This is h d/dz( fluxVertTop) but h and dz cancel, so
- ! reduces to delta( fluxVertTop)
- tend(iTracer,k,iCell) = tend(iTracer,k,iCell) &
- + fluxVertTop(iTracer,k) - fluxVertTop(iTracer,k+1)
- enddo
- enddo
-
- enddo ! iCell loop
- deallocate(fluxVertTop)
- !--------------------------------------------------------------------
-
- end subroutine ocn_tracer_vmix_tend_explicit!}}}
-
-!***********************************************************************
-!
! routine ocn_tracer_vmix_tend_implicit
!
!> \brief Computes tendencies for implicit tracer vertical mixing
@@ -543,7 +340,6 @@
err = 0
if(.not.tracerVmixOn) return
- if(explicitOn) return
nCells = grid % nCells
nVertLevels = grid % nVertLevels
@@ -656,8 +452,7 @@
!> \version SVN:$Id$
!> \details
!> This routine initializes a variety of quantities related to
-!> vertical mixing in the ocean. This primarily determines if
-!> explicit or implicit vertical mixing is to be used.
+!> vertical mixing in the ocean.
!
!-----------------------------------------------------------------------
@@ -681,14 +476,6 @@
velVmixOn = .true.
tracerVmixOn = .true.
- explicitOn = .true.
- implicitOn = .false.
-
- if(config_implicit_vertical_mix) then
- explicitOn = .false.
- implicitOn = .true.
- end if
-
if(config_disable_u_vmix) velVmixOn = .false.
if(config_disable_tr_vmix) tracerVmixOn = .false.
Modified: branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_vmix_coefs_rich.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_vmix_coefs_rich.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_ocean/mpas_ocn_vmix_coefs_rich.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -228,31 +228,17 @@
!$OMP DO PRIVATE(k)
do iEdge = 1,nEdges
do k = 2,maxLevelEdgeTop(iEdge)
- ! mrp 110324 efficiency note: this if is inside iEdge and k loops.
+ ! efficiency note: these if statements are inside iEdge and k loops.
! Perhaps there is a more efficient way to do this.
if (RiTopOfEdge(k,iEdge)>0.0) then
vertViscTopOfEdge(k,iEdge) = vertViscTopOfEdge(k, iEdge) + config_bkrd_vert_visc &
+ config_rich_mix / (1.0 + 5.0*RiTopOfEdge(k,iEdge))**2
- ! maltrud do limiting of coefficient--should not be necessary
- ! also probably better logic could be found
if (vertViscTopOfEdge(k,iEdge) > config_convective_visc) then
- if( config_implicit_vertical_mix) then
- vertViscTopOfEdge(k,iEdge) = config_convective_visc
- else
- vertViscTopOfEdge(k,iEdge) = &
- ((h_edge(k-1,iEdge)+h_edge(k,iEdge))/2.0)**2/config_dt/4.0
- end if
+ vertViscTopOfEdge(k,iEdge) = config_convective_visc
end if
else
- ! mrp 110324 efficiency note: this if is inside iCell and k loops.
- if (config_implicit_vertical_mix) then
- ! for Ri<0 and implicit mix, use convective diffusion
- vertViscTopOfEdge(k,iEdge) = config_convective_visc
- else
- ! for Ri<0 and explicit vertical mix,
- ! use maximum diffusion allowed by CFL criterion
- vertViscTopOfEdge(k,iEdge) = vertViscTopOfEdge(k,iEdge) + ((h_edge(k-1,iEdge)+h_edge(k,iEdge))/2.0)**2/config_dt/4.0
- end if
+ ! for Ri<0 use the convective value for the viscosity
+ vertViscTopOfEdge(k,iEdge) = config_convective_visc
end if
end do
end do
@@ -333,33 +319,19 @@
!$OMP DO PRIVATE(k)
do iCell = 1,nCells
do k = 2,maxLevelCell(iCell)
- ! mrp 110324 efficiency note: this if is inside iCell and k loops.
+ ! efficiency note: these if statements are inside iEdge and k loops.
! Perhaps there is a more efficient way to do this.
if (RiTopOfCell(k,iCell)>0.0) then
vertDiffTopOfCell(k,iCell) = vertDiffTopOfCell(k, iCell) + config_bkrd_vert_diff &
+ (config_bkrd_vert_visc &
+ config_rich_mix / (1.0 + 5.0*RiTopOfCell(k,iCell))**2) &
/ (1.0 + 5.0*RiTopOfCell(k,iCell))
- ! maltrud do limiting of coefficient--should not be necessary
- ! also probably better logic could be found
if (vertDiffTopOfCell(k,iCell) > config_convective_diff) then
- if (config_implicit_vertical_mix) then
- vertDiffTopOfCell(k,iCell) = config_convective_diff
- else
- vertDiffTopOfCell(k,iCell) = &
- ((h(k-1,iCell)+h(k,iCell))/2.0)**2/config_dt/4.0
- end if
+ vertDiffTopOfCell(k,iCell) = config_convective_diff
end if
else
- ! mrp 110324 efficiency note: this if is inside iCell and k loops.
- if (config_implicit_vertical_mix) then
- ! for Ri<0 and implicit mix, use convective diffusion
- vertDiffTopOfCell(k,iCell) = config_convective_diff
- else
- ! for Ri<0 and explicit vertical mix,
- ! use maximum diffusion allowed by CFL criterion
- vertDiffTopOfCell(k,iCell) = vertDiffTopOfCell(k, iCell) + ((h(k-1,iCell)+h(k,iCell))/2.0)**2/config_dt/4.0
- end if
+ ! for Ri<0 use the convective value for the diffusion
+ vertDiffTopOfCell(k,iCell) = config_convective_diff
end if
end do
end do
@@ -475,16 +447,6 @@
du2TopOfCell => scratch % du2TopOfCell % array
du2TopOfEdge => scratch % du2TopOfEdge % array
- ! compute density of parcel displaced to next deeper z-level,
- ! in state % rhoDisplaced
-!maltrud make sure rho is current--check this for redundancy
-! call OcnEquationOfStateRho(grid, 'relative', 0, indexT, indexS, &
-! tracers, rho, err)
- ! mrp 110324 In order to visualize rhoDisplaced, include the following
-! call OcnEquationOfStateRho(grid, 'relative', 1, indexT, indexS, &
-! tracers, rhoDisplaced, err)
-
-
! drhoTopOfCell(k) = $\rho^*_{k-1}-\rho^*_k$
!$OMP WORKSHARE
drhoTopOfCell = 0.0
Modified: branches/ocean_projects/openmp_elements/src/core_sw/Registry
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_sw/Registry 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/core_sw/Registry 2013-03-29 14:40:23 UTC (rev 2678)
@@ -97,7 +97,7 @@
var persistent real edgeNormalVectors ( R3 nEdges ) 0 o edgeNormalVectors mesh - -
var persistent real localVerticalUnitVectors ( R3 nCells ) 0 o localVerticalUnitVectors mesh - -
-var persistent real cellTangentPlane ( R3 TWO nEdges ) 0 o cellTangentPlane mesh - -
+var persistent real cellTangentPlane ( R3 TWO nCells ) 0 o cellTangentPlane mesh - -
var persistent integer cellsOnCell ( maxEdges nCells ) 0 iro cellsOnCell mesh - -
var persistent integer verticesOnCell ( maxEdges nCells ) 0 iro verticesOnCell mesh - -
Copied: branches/ocean_projects/openmp_elements/src/core_sw/Registry.xml (from rev 2677, trunk/mpas/src/core_sw/Registry.xml)
===================================================================
--- branches/ocean_projects/openmp_elements/src/core_sw/Registry.xml (rev 0)
+++ branches/ocean_projects/openmp_elements/src/core_sw/Registry.xml 2013-03-29 14:40:23 UTC (rev 2678)
@@ -0,0 +1,146 @@
+<?xml version="1.0"?>
+<registry>
+ <dims>
+ <dim name="nCells"/>
+ <dim name="nEdges"/>
+ <dim name="maxEdges"/>
+ <dim name="maxEdges2"/>
+ <dim name="nVertices"/>
+ <dim name="TWO" definition="2"/>
+ <dim name="R3" definition="3"/>
+ <dim name="FIFTEEN" definition="15"/>
+ <dim name="TWENTYONE" definition="21"/>
+ <dim name="vertexDegree"/>
+ <dim name="nVertLevels"/>
+ <dim name="nTracers"/>
+ </dims>
+ <nml_record name="sw_model">
+ <nml_option name="config_test_case" type="integer" default_value="5"/>
+ <nml_option name="config_time_integration" type="character" default_value="RK4"/>
+ <nml_option name="config_dt" type="real" default_value="172.8"/>
+ <nml_option name="config_calendar_type" type="character" default_value="360day"/>
+ <nml_option name="config_start_time" type="character" default_value="0000-01-01_00:00:00"/>
+ <nml_option name="config_stop_time" type="character" default_value="none"/>
+ <nml_option name="config_run_duration" type="character" default_value="none"/>
+ <nml_option name="config_stats_interval" type="integer" default_value="100"/>
+ <nml_option name="config_h_ScaleWithMesh" type="logical" default_value="false"/>
+ <nml_option name="config_h_mom_eddy_visc2" type="real" default_value="0.0"/>
+ <nml_option name="config_h_mom_eddy_visc4" type="real" default_value="0.0"/>
+ <nml_option name="config_h_tracer_eddy_diff2" type="real" default_value="0.0"/>
+ <nml_option name="config_h_tracer_eddy_diff4" type="real" default_value="0.0"/>
+ <nml_option name="config_thickness_adv_order" type="integer" default_value="2"/>
+ <nml_option name="config_tracer_adv_order" type="integer" default_value="2"/>
+ <nml_option name="config_positive_definite" type="logical" default_value="false"/>
+ <nml_option name="config_monotonic" type="logical" default_value="false"/>
+ <nml_option name="config_wind_stress" type="logical" default_value="false"/>
+ <nml_option name="config_bottom_drag" type="logical" default_value="false"/>
+ <nml_option name="config_apvm_upwinding" type="real" default_value="0.5"/>
+ <nml_option name="config_num_halos" type="integer" default_value="2"/>
+ </nml_record>
+ <nml_record name="io">
+ <nml_option name="config_input_name" type="character" default_value="grid.nc"/>
+ <nml_option name="config_output_name" type="character" default_value="output.nc"/>
+ <nml_option name="config_restart_name" type="character" default_value="restart.nc"/>
+ <nml_option name="config_output_interval" type="character" default_value="06:00:00"/>
+ <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_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_proc_decomp_file_prefix" type="character" default_value="graph.info.part."/>
+ </nml_record>
+ <nml_record name="restart">
+ <nml_option name="config_do_restart" type="logical" default_value="false"/>
+ <nml_option name="config_restart_interval" type="character" default_value="none"/>
+ </nml_record>
+ <var_struct name="state" time_levs="2">
+ <var name="xtime" type="text" dimensions="Time" streams="ro"/>
+ <var name="u" type="real" dimensions="nVertLevels nEdges Time" streams="iro"/>
+ <var name="h" type="real" dimensions="nVertLevels nCells Time" streams="iro"/>
+ <var name="tracers" type="real" dimensions="nTracers nVertLevels nCells Time" streams="iro"/>
+ <var name="v" type="real" dimensions="nVertLevels nEdges Time" streams="o"/>
+ <var name="divergence" type="real" dimensions="nVertLevels nCells Time" streams="o"/>
+ <var name="vorticity" type="real" dimensions="nVertLevels nVertices Time" streams="o"/>
+ <var name="vorticity_cell" type="real" dimensions="nVertLevels nCells Time" streams="o"/>
+ <var name="pv_edge" type="real" dimensions="nVertLevels nEdges Time" streams="o"/>
+ <var name="h_edge" type="real" dimensions="nVertLevels nEdges Time" streams="o"/>
+ <var name="ke" type="real" dimensions="nVertLevels nCells Time" streams="o"/>
+ <var name="pv_vertex" type="real" dimensions="nVertLevels nVertices Time" streams="o"/>
+ <var name="pv_cell" 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"/>
+ <var name="uReconstructZonal" type="real" dimensions="nVertLevels nCells Time" streams="o"/>
+ <var name="uReconstructMeridional" type="real" dimensions="nVertLevels nCells Time" streams="o"/>
+ <var name="vh" type="real" dimensions="nVertLevels nEdges Time"/>
+ <var name="circulation" type="real" dimensions="nVertLevels nVertices Time"/>
+ <var name="gradPVt" type="real" dimensions="nVertLevels nEdges Time"/>
+ <var name="gradPVn" type="real" dimensions="nVertLevels nEdges Time"/>
+ <var name="h_vertex" type="real" dimensions="nVertLevels nVertices Time"/>
+ </var_struct>
+ <var_struct name="mesh" time_levs="0">
+ <var name="latCell" type="real" dimensions="nCells" streams="iro"/>
+ <var name="lonCell" type="real" dimensions="nCells" streams="iro"/>
+ <var name="xCell" type="real" dimensions="nCells" streams="iro"/>
+ <var name="yCell" type="real" dimensions="nCells" streams="iro"/>
+ <var name="zCell" type="real" dimensions="nCells" streams="iro"/>
+ <var name="indexToCellID" type="integer" dimensions="nCells" streams="iro"/>
+ <var name="latEdge" type="real" dimensions="nEdges" streams="iro"/>
+ <var name="lonEdge" type="real" dimensions="nEdges" streams="iro"/>
+ <var name="xEdge" type="real" dimensions="nEdges" streams="iro"/>
+ <var name="yEdge" type="real" dimensions="nEdges" streams="iro"/>
+ <var name="zEdge" type="real" dimensions="nEdges" streams="iro"/>
+ <var name="indexToEdgeID" type="integer" dimensions="nEdges" streams="iro"/>
+ <var name="latVertex" type="real" dimensions="nVertices" streams="iro"/>
+ <var name="lonVertex" type="real" dimensions="nVertices" streams="iro"/>
+ <var name="xVertex" type="real" dimensions="nVertices" streams="iro"/>
+ <var name="yVertex" type="real" dimensions="nVertices" streams="iro"/>
+ <var name="zVertex" type="real" dimensions="nVertices" streams="iro"/>
+ <var name="indexToVertexID" type="integer" dimensions="nVertices" streams="iro"/>
+ <var name="meshDensity" type="real" dimensions="nCells" streams="iro"/>
+ <var name="meshScalingDel2" type="real" dimensions="nEdges" streams="ro"/>
+ <var name="meshScalingDel4" type="real" dimensions="nEdges" streams="ro"/>
+ <var name="cellsOnEdge" type="integer" dimensions="TWO nEdges" streams="iro"/>
+ <var name="nEdgesOnCell" type="integer" dimensions="nCells" streams="iro"/>
+ <var name="nEdgesOnEdge" type="integer" dimensions="nEdges" streams="iro"/>
+ <var name="edgesOnCell" type="integer" dimensions="maxEdges nCells" streams="iro"/>
+ <var name="edgesOnEdge" type="integer" dimensions="maxEdges2 nEdges" streams="iro"/>
+ <var name="weightsOnEdge" type="real" dimensions="maxEdges2 nEdges" streams="iro"/>
+ <var name="dvEdge" type="real" dimensions="nEdges" streams="iro"/>
+ <var name="dcEdge" type="real" dimensions="nEdges" streams="iro"/>
+ <var name="angleEdge" type="real" dimensions="nEdges" streams="iro"/>
+ <var name="areaCell" type="real" dimensions="nCells" streams="iro"/>
+ <var name="areaTriangle" type="real" dimensions="nVertices" streams="iro"/>
+ <var name="edgeNormalVectors" type="real" dimensions="R3 nEdges" streams="o"/>
+ <var name="localVerticalUnitVectors" type="real" dimensions="R3 nCells" streams="o"/>
+ <var name="cellTangentPlane" type="real" dimensions="R3 TWO nCells" streams="o"/>
+ <var name="cellsOnCell" type="integer" dimensions="maxEdges nCells" streams="iro"/>
+ <var name="verticesOnCell" type="integer" dimensions="maxEdges nCells" streams="iro"/>
+ <var name="verticesOnEdge" type="integer" dimensions="TWO nEdges" streams="iro"/>
+ <var name="edgesOnVertex" type="integer" dimensions="vertexDegree nVertices" streams="iro"/>
+ <var name="cellsOnVertex" type="integer" dimensions="vertexDegree nVertices" streams="iro"/>
+ <var name="kiteAreasOnVertex" type="real" dimensions="vertexDegree nVertices" streams="iro"/>
+ <var name="fEdge" type="real" dimensions="nEdges" streams="iro"/>
+ <var name="fVertex" type="real" dimensions="nVertices" streams="iro"/>
+ <var name="fCell" type="real" dimensions="nCells" streams="iro"/>
+ <var name="h_s" type="real" dimensions="nCells" streams="iro"/>
+ <var name="deriv_two" type="real" dimensions="FIFTEEN TWO nEdges" streams="o"/>
+ <var name="advCells" type="integer" dimensions="TWENTYONE nCells"/>
+ <var name="defc_a" type="real" dimensions="maxEdges nCells"/>
+ <var name="defc_b" type="real" dimensions="maxEdges nCells"/>
+ <var name="kdiff" type="real" dimensions="nVertLevels nCells Time"/>
+ <var name="coeffs_reconstruct" type="real" dimensions="R3 maxEdges nCells"/>
+ <var name="boundaryEdge" type="integer" dimensions="nVertLevels nEdges" streams="iro"/>
+ <var name="boundaryVertex" type="integer" dimensions="nVertLevels nVertices" streams="iro"/>
+ <var name="boundaryCell" type="integer" dimensions="nVertLevels nCells" streams="iro"/>
+ <var name="u_src" type="real" dimensions="nVertLevels nEdges" streams="iro"/>
+ </var_struct>
+ <var_struct name="tend" time_levs="1">
+ <var name="tend_u" type="real" dimensions="nVertLevels nEdges Time" name_in_code="u"/>
+ <var name="tend_h" type="real" dimensions="nVertLevels nCells Time" name_in_code="h"/>
+ <var name="tend_tracers" type="real" dimensions="nTracers nVertLevels nCells Time" name_in_code="tracers"/>
+ </var_struct>
+</registry>
Modified: branches/ocean_projects/openmp_elements/src/framework/mpas_attlist.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/framework/mpas_attlist.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/framework/mpas_attlist.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -1,3 +1,16 @@
+!***********************************************************************
+!
+! mpas_attlist
+!
+!> \brief MPAS Attribute list module
+!> \author Michael Duda
+!> \date 03/27/13
+!> \version SVN:$Id$
+!> \details
+!> This module provides type definitions and subroutines for working with attribute lists.
+!
+!-----------------------------------------------------------------------
+
module mpas_attlist
use mpas_kind_types
@@ -42,15 +55,26 @@
contains
+!***********************************************************************
+!
+! routine mpas_add_att_int0d
+!
+!> \brief MPAS Add 0D integer attribute routine
+!> \author Michael Duda
+!> \date 03/27/13
+!> \version SVN:$Id$
+!> \details
+!> This routine adds a 0D integer attribute the attribute list.
+!
+!-----------------------------------------------------------------------
+ subroutine mpas_add_att_int0d(attList, attName, attValue, ierr)!{{{
- subroutine mpas_add_att_int0d(attList, attName, attValue, ierr)
-
implicit none
- type (att_list_type), pointer :: attList
- character (len=*), intent(in) :: attName
- integer, intent(in) :: attValue
- integer, intent(out), optional :: ierr
+ type (att_list_type), pointer :: attList !< Input/Output: Attribute list
+ character (len=*), intent(in) :: attName !< Input: Attribute name
+ integer, intent(in) :: attValue !< Input: Attribute value
+ integer, intent(out), optional :: ierr !< Output: Error flag
type (att_list_type), pointer :: cursor
@@ -72,17 +96,28 @@
write(cursor % attName,'(a)') trim(attName)
cursor % attValueInt = attValue
- end subroutine mpas_add_att_int0d
+ end subroutine mpas_add_att_int0d!}}}
+!***********************************************************************
+!
+! routine mpas_add_att_int1d
+!
+!> \brief MPAS Add 1D integer attribute routine
+!> \author Michael Duda
+!> \date 03/27/13
+!> \version SVN:$Id$
+!> \details
+!> This routine adds a 1D integer attribute the attribute list.
+!
+!-----------------------------------------------------------------------
+ subroutine mpas_add_att_int1d(attList, attName, attValue, ierr)!{{{
- subroutine mpas_add_att_int1d(attList, attName, attValue, ierr)
-
implicit none
- type (att_list_type), pointer :: attList
- character (len=*), intent(in) :: attName
- integer, dimension(:), intent(in) :: attValue
- integer, intent(out), optional :: ierr
+ type (att_list_type), pointer :: attList !< Input/Output: Attribute list
+ character (len=*), intent(in) :: attName !< Input: Attribute name
+ integer, dimension(:), intent(in) :: attValue !< Input: Attribute value
+ integer, intent(out), optional :: ierr !< Output: Error flag
type (att_list_type), pointer :: cursor
@@ -105,17 +140,28 @@
write(cursor % attName,'(a)') trim(attName)
cursor % attValueIntA(:) = attValue(:)
- end subroutine mpas_add_att_int1d
+ end subroutine mpas_add_att_int1d!}}}
+!***********************************************************************
+!
+! routine mpas_add_att_real0d
+!
+!> \brief MPAS Add 0D real attribute routine
+!> \author Michael Duda
+!> \date 03/27/13
+!> \version SVN:$Id$
+!> \details
+!> This routine adds a 0D real attribute the attribute list.
+!
+!-----------------------------------------------------------------------
+ subroutine mpas_add_att_real0d(attList, attName, attValue, ierr)!{{{
- subroutine mpas_add_att_real0d(attList, attName, attValue, ierr)
-
implicit none
- type (att_list_type), pointer :: attList
- character (len=*), intent(in) :: attName
- real (kind=RKIND), intent(in) :: attValue
- integer, intent(out), optional :: ierr
+ type (att_list_type), pointer :: attList !< Input/Output: Attribute list
+ character (len=*), intent(in) :: attName !< Input: Attribute name
+ real (kind=RKIND), intent(in) :: attValue !< Input: Attribute value
+ integer, intent(out), optional :: ierr !< Output: Error flag
type (att_list_type), pointer :: cursor
@@ -137,17 +183,28 @@
write(cursor % attName,'(a)') trim(attName)
cursor % attValueReal = attValue
- end subroutine mpas_add_att_real0d
+ end subroutine mpas_add_att_real0d!}}}
+!***********************************************************************
+!
+! routine mpas_add_att_real1d
+!
+!> \brief MPAS Add 1D real attribute routine
+!> \author Michael Duda
+!> \date 03/27/13
+!> \version SVN:$Id$
+!> \details
+!> This routine adds a 1D real attribute the attribute list.
+!
+!-----------------------------------------------------------------------
+ subroutine mpas_add_att_real1d(attList, attName, attValue, ierr)!{{{
- subroutine mpas_add_att_real1d(attList, attName, attValue, ierr)
-
implicit none
- type (att_list_type), pointer :: attList
- character (len=*), intent(in) :: attName
- real (kind=RKIND), dimension(:), intent(in) :: attValue
- integer, intent(out), optional :: ierr
+ type (att_list_type), pointer :: attList !< Input/Output: Attribute list
+ character (len=*), intent(in) :: attName !< Input: Attribute name
+ real (kind=RKIND), dimension(:), intent(in) :: attValue !< Input: Attribute value
+ integer, intent(out), optional :: ierr !< Output: Error flag
type (att_list_type), pointer :: cursor
@@ -170,17 +227,28 @@
write(cursor % attName,'(a)') trim(attName)
cursor % attValueRealA(:) = attValue(:)
- end subroutine mpas_add_att_real1d
+ end subroutine mpas_add_att_real1d!}}}
+!***********************************************************************
+!
+! routine mpas_add_att_text
+!
+!> \brief MPAS Add text attribute routine
+!> \author Michael Duda
+!> \date 03/27/13
+!> \version SVN:$Id$
+!> \details
+!> This routine adds a text attribute the attribute list.
+!
+!-----------------------------------------------------------------------
+ subroutine mpas_add_att_text(attList, attName, attValue, ierr)!{{{
- subroutine mpas_add_att_text(attList, attName, attValue, ierr)
-
implicit none
- type (att_list_type), pointer :: attList
- character (len=*), intent(in) :: attName
- character (len=*), intent(in) :: attValue
- integer, intent(out), optional :: ierr
+ type (att_list_type), pointer :: attList !< Input/Output: Attribute list
+ character (len=*), intent(in) :: attName !< Input: Attribute name
+ character (len=*), intent(in) :: attValue !< Input: Attribute value
+ integer, intent(out), optional :: ierr !< Output: Error flag
type (att_list_type), pointer :: cursor
@@ -202,17 +270,28 @@
write(cursor % attName,'(a)') trim(attName)
write(cursor % attValueText,'(a)') trim(attValue)
- end subroutine mpas_add_att_text
+ end subroutine mpas_add_att_text!}}}
+!***********************************************************************
+!
+! routine mpas_get_att_int0d
+!
+!> \brief MPAS get 0D integer attribute routine
+!> \author Michael Duda
+!> \date 03/27/13
+!> \version SVN:$Id$
+!> \details
+!> This routine returns the attribute value of a 0D integer attribute.
+!
+!-----------------------------------------------------------------------
+ subroutine mpas_get_att_int0d(attList, attName, attValue, ierr)!{{{
- subroutine mpas_get_att_int0d(attList, attName, attValue, ierr)
-
implicit none
- type (att_list_type), pointer :: attList
- character (len=*), intent(in) :: attName
- integer, intent(out) :: attValue
- integer, intent(out), optional :: ierr
+ type (att_list_type), pointer :: attList !< Input: Attribute list
+ character (len=*), intent(in) :: attName !< Input: Attribute name
+ integer, intent(out) :: attValue !< Output: Attribute value
+ integer, intent(out), optional :: ierr !< Output: Error flag
type (att_list_type), pointer :: cursor
@@ -233,17 +312,28 @@
if (present(ierr)) ierr = 1 ! Not found
- end subroutine mpas_get_att_int0d
+ end subroutine mpas_get_att_int0d!}}}
+!***********************************************************************
+!
+! routine mpas_get_att_int1d
+!
+!> \brief MPAS get 1D integer attribute routine
+!> \author Michael Duda
+!> \date 03/27/13
+!> \version SVN:$Id$
+!> \details
+!> This routine returns the attribute value of a 1D integer attribute.
+!
+!-----------------------------------------------------------------------
+ subroutine mpas_get_att_int1d(attList, attName, attValue, ierr)!{{{
- subroutine mpas_get_att_int1d(attList, attName, attValue, ierr)
-
implicit none
- type (att_list_type), pointer :: attList
- character (len=*), intent(in) :: attName
- integer, dimension(:), pointer :: attValue
- integer, intent(out), optional :: ierr
+ type (att_list_type), pointer :: attList !< Input: Attribute list
+ character (len=*), intent(in) :: attName !< Input: Attribute name
+ integer, dimension(:), pointer :: attValue !< Output: Attribute value
+ integer, intent(out), optional :: ierr !< Output: Error flag
type (att_list_type), pointer :: cursor
@@ -265,17 +355,28 @@
if (present(ierr)) ierr = 1 ! Not found
- end subroutine mpas_get_att_int1d
+ end subroutine mpas_get_att_int1d!}}}
+!***********************************************************************
+!
+! routine mpas_get_att_real0d
+!
+!> \brief MPAS get 0D real attribute routine
+!> \author Michael Duda
+!> \date 03/27/13
+!> \version SVN:$Id$
+!> \details
+!> This routine returns the attribute value of a 0D real attribute.
+!
+!-----------------------------------------------------------------------
+ subroutine mpas_get_att_real0d(attList, attName, attValue, ierr)!{{{
- subroutine mpas_get_att_real0d(attList, attName, attValue, ierr)
-
implicit none
- type (att_list_type), pointer :: attList
- character (len=*), intent(in) :: attName
- real (kind=RKIND), intent(out) :: attValue
- integer, intent(out), optional :: ierr
+ type (att_list_type), pointer :: attList !< Input: Attribute list
+ character (len=*), intent(in) :: attName !< Input: Attribute name
+ real (kind=RKIND), intent(out) :: attValue !< Output: Attribute value
+ integer, intent(out), optional :: ierr !< Output: Error flag
type (att_list_type), pointer :: cursor
@@ -296,17 +397,28 @@
if (present(ierr)) ierr = 1 ! Not found
- end subroutine mpas_get_att_real0d
+ end subroutine mpas_get_att_real0d!}}}
+!***********************************************************************
+!
+! routine mpas_get_att_real1d
+!
+!> \brief MPAS get 1D real attribute routine
+!> \author Michael Duda
+!> \date 03/27/13
+!> \version SVN:$Id$
+!> \details
+!> This routine returns the attribute value of a 1D real attribute.
+!
+!-----------------------------------------------------------------------
+ subroutine mpas_get_att_real1d(attList, attName, attValue, ierr)!{{{
- subroutine mpas_get_att_real1d(attList, attName, attValue, ierr)
-
implicit none
- type (att_list_type), pointer :: attList
- character (len=*), intent(in) :: attName
- real (kind=RKIND), dimension(:), pointer :: attValue
- integer, intent(out), optional :: ierr
+ type (att_list_type), pointer :: attList !< Input: Attribute list
+ character (len=*), intent(in) :: attName !< Input: Attribute name
+ real (kind=RKIND), dimension(:), pointer :: attValue !< Output: Attribute value
+ integer, intent(out), optional :: ierr !< Output: Error flag
type (att_list_type), pointer :: cursor
@@ -328,17 +440,28 @@
if (present(ierr)) ierr = 1 ! Not found
- end subroutine mpas_get_att_real1d
+ end subroutine mpas_get_att_real1d!}}}
+!***********************************************************************
+!
+! routine mpas_get_att_text
+!
+!> \brief MPAS get text attribute routine
+!> \author Michael Duda
+!> \date 03/27/13
+!> \version SVN:$Id$
+!> \details
+!> This routine returns the attribute value of a text attribute.
+!
+!-----------------------------------------------------------------------
+ subroutine mpas_get_att_text(attList, attName, attValue, ierr)!{{{
- subroutine mpas_get_att_text(attList, attName, attValue, ierr)
-
implicit none
- type (att_list_type), pointer :: attList
- character (len=*), intent(in) :: attName
- character (len=*), intent(out) :: attValue
- integer, intent(out), optional :: ierr
+ type (att_list_type), pointer :: attList !< Input: Attribute list
+ character (len=*), intent(in) :: attName !< Input: Attribute name
+ character (len=*), intent(out) :: attValue !< Output: Attribute value
+ integer, intent(out), optional :: ierr !< Output: Error flag
type (att_list_type), pointer :: cursor
@@ -359,16 +482,27 @@
if (present(ierr)) ierr = 1 ! Not found
- end subroutine mpas_get_att_text
+ end subroutine mpas_get_att_text!}}}
+!***********************************************************************
+!
+! routine mpas_remove_att
+!
+!> \brief MPAS remove attribute routine
+!> \author Michael Duda
+!> \date 03/27/13
+!> \version SVN:$Id$
+!> \details
+!> This routine removes an attribute from an attribute list.
+!
+!-----------------------------------------------------------------------
+ subroutine mpas_remove_att(attList, attName, ierr)!{{{
- subroutine mpas_remove_att(attList, attName, ierr)
-
implicit none
- type (att_list_type), pointer :: attList
- character (len=*), intent(in) :: attName
- integer, intent(out), optional :: ierr
+ type (att_list_type), pointer :: attList !< Input/Output: Attribute list
+ character (len=*), intent(in) :: attName !< Input: Attribute name
+ integer, intent(out), optional :: ierr !< Output: Error flag
type (att_list_type), pointer :: cursor, cursor_prev
@@ -410,15 +544,26 @@
if (present(ierr)) ierr = 1 ! Not found
- end subroutine mpas_remove_att
+ end subroutine mpas_remove_att!}}}
+!***********************************************************************
+!
+! routine mpas_deallocate_attlist
+!
+!> \brief MPAS attribute list deallocation routine
+!> \author Michael Duda
+!> \date 03/27/13
+!> \version SVN:$Id$
+!> \details
+!> This routine deallocates an attribute list.
+!
+!-----------------------------------------------------------------------
+ subroutine mpas_deallocate_attlist(attList, ierr)!{{{
- subroutine mpas_deallocate_attlist(attList, ierr)
-
implicit none
- type (att_list_type), pointer :: attList
- integer, intent(out), optional :: ierr
+ type (att_list_type), pointer :: attList !< Input/Output: Attribute list
+ integer, intent(out), optional :: ierr !< Output: Error flag
type (att_list_type), pointer :: cursor
@@ -436,6 +581,6 @@
cursor => attList
end do
- end subroutine mpas_deallocate_attlist
+ end subroutine mpas_deallocate_attlist!}}}
end module mpas_attlist
Modified: branches/ocean_projects/openmp_elements/src/framework/mpas_block_decomp.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/framework/mpas_block_decomp.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/framework/mpas_block_decomp.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -1,3 +1,16 @@
+!***********************************************************************
+!
+! mpas_block_decomp
+!
+!> \brief This module contains routines related to the block decomposition.
+!> \author Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id$
+!> \details
+!> This module is repsonsible for reading the decomposition files, and determining which elements should live within which blocks.
+!> It also provides interfaces to find out how blocks map to processors.
+!
+!-----------------------------------------------------------------------
module mpas_block_decomp
use mpas_dmpar
@@ -23,6 +36,18 @@
contains
+!***********************************************************************
+!
+! routine mpas_block_decomp_cells_for_proc
+!
+!> \brief Determines list of cells for a specific processor
+!> \author Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id$
+!> \details
+!> This routine determines a list of cells for each processor, and what blocks the live in.
+!
+!-----------------------------------------------------------------------
subroutine mpas_block_decomp_cells_for_proc(dminfo, partial_global_graph_info, local_cell_list, block_id, block_start, block_count)!{{{
use mpas_configure
@@ -165,7 +190,7 @@
allocate(block_id(blocks_per_proc))
allocate(block_start(blocks_per_proc))
allocate(block_count(blocks_per_proc))
-
+
do i = 1, blocks_per_proc
block_start = 0
block_count = 0
@@ -226,15 +251,30 @@
end subroutine mpas_block_decomp_cells_for_proc!}}}
+!***********************************************************************
+!
+! routine mpas_block_decomp_partitioned_edge_list
+!
+!> \brief Partitions list of edges for a processor
+!> \author Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id$
+!> \details
+!> This routine partitions a list of edges for each processor, based on a list of owned cells.
+!> Output edge list has 0-Halo edges first, followed by halo edges.
+!
+!-----------------------------------------------------------------------
subroutine mpas_block_decomp_partitioned_edge_list(nCells, cellIDList, maxCells, nEdges, cellsOnEdge, edgeIDList, ghostEdgeStart)!{{{
implicit none
- integer, intent(in) :: nCells, maxCells, nEdges
- integer, dimension(nCells), intent(in) :: cellIDList
- integer, dimension(maxCells, nEdges), intent(in) :: cellsOnEdge
- integer, dimension(nEdges), intent(inout) :: edgeIDList
- integer, intent(inout) :: ghostEdgeStart
+ integer, intent(in) :: nCells !< Input: Number of owned cells
+ integer, intent(in) :: maxCells !< Input: Maximum number of cells on an edge
+ integer, intent(in) :: nEdges !< Input: Number of edges
+ integer, dimension(nCells), intent(in) :: cellIDList !< Input: List of owned cell IDs
+ integer, dimension(maxCells, nEdges), intent(in) :: cellsOnEdge !< Input: Connectivity of cells on edges.
+ integer, dimension(nEdges), intent(inout) :: edgeIDList !< Input/Output: List of edge IDs
+ integer, intent(inout) :: ghostEdgeStart !< Input/Output: Index to beginning of edge halo
integer :: i, j, lastEdge
integer, dimension(nEdges) :: edgeIDListLocal
@@ -281,15 +321,28 @@
end subroutine mpas_block_decomp_partitioned_edge_list!}}}
+!***********************************************************************
+!
+! routine mpas_block_decomp_all_edges_in_block
+!
+!> \brief Determines all edges in a block.
+!> \author Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id$
+!> \details
+!> This routine creates a list of all edges that are in a block, based on a list of owned cells.
+!
+!-----------------------------------------------------------------------
subroutine mpas_block_decomp_all_edges_in_block(maxEdges, nCells, nEdgesOnCell, edgesOnCell, nEdges, edgeList)!{{{
implicit none
- integer, intent(in) :: maxEdges, nCells
- integer, dimension(nCells), intent(in) :: nEdgesOnCell
- integer, dimension(maxEdges, nCells), intent(in) :: edgesOnCell
- integer, intent(out) :: nEdges
- integer, dimension(:), pointer :: edgeList
+ integer, intent(in) :: maxEdges !< Input: Maximum number of edges on cell
+ integer, intent(in) :: nCells !< Input: Number of owned cells
+ integer, dimension(nCells), intent(in) :: nEdgesOnCell !< Input: Number of edges on each cell
+ integer, dimension(maxEdges, nCells), intent(in) :: edgesOnCell !< Input: ID of edges that border each cell
+ integer, intent(out) :: nEdges !< Output: Number of edges in block
+ integer, dimension(:), pointer :: edgeList !< Output: List of edges in block
integer :: i, j, k
type (hashtable) :: h
@@ -334,13 +387,25 @@
end subroutine mpas_block_decomp_all_edges_in_block!}}}
+!***********************************************************************
+!
+! routine mpas_block_decomp_add_halo
+!
+!> \brief Add halo to block
+!> \author Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id$
+!> \details
+!> This routine adds a halo layer to the block.
+!
+!-----------------------------------------------------------------------
subroutine mpas_block_decomp_add_halo(dminfo, local_graph_info, local_graph_with_halo)!{{{
implicit none
- type (dm_info), intent(in) :: dminfo
- type (graph), intent(in) :: local_graph_info
- type (graph), intent(out) :: local_graph_with_halo
+ type (dm_info), intent(in) :: dminfo !< Input: Domain information
+ type (graph), intent(in) :: local_graph_info !< Input: Local graph structure for a block
+ type (graph), intent(out) :: local_graph_with_halo !< Output: Local graph structure for a block, with an extra halo
integer :: i, j, k
type (hashtable) :: h
@@ -408,6 +473,18 @@
end subroutine mpas_block_decomp_add_halo!}}}
+!***********************************************************************
+!
+! routine mpas_get_blocks_per_proc
+!
+!> \brief Determine number of blocks per processor
+!> \author Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id$
+!> \details
+!> This routine returns the number of blocks a specific processor owns.
+!
+!-----------------------------------------------------------------------
subroutine mpas_get_blocks_per_proc(dminfo, proc_number, blocks_per_proc)!{{{
type(dm_info), intent(in) :: dminfo !< Input: Domain Information
integer, intent(in) :: proc_number !< Input: Processor number
@@ -436,17 +513,29 @@
end if
else
blocks_per_proc = 0
- do i = 1, total_blocks
+ do i = 0, total_blocks-1
call mpas_get_owning_proc(dminfo, i, owning_proc)
if(owning_proc == proc_number) then
call mpas_get_local_block_id(dminfo, i, local_block_id)
- blocks_per_proc = max(blocks_per_proc, local_block_id)
+ blocks_per_proc = max(blocks_per_proc, local_block_id+1)
end if
end do
end if
end subroutine mpas_get_blocks_per_proc!}}}
+!***********************************************************************
+!
+! routine mpas_get_local_block_id
+!
+!> \brief Determine the local ID of a block
+!> \author Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id$
+!> \details
+!> This routine returns the local block ID on the owning processor.
+!
+!-----------------------------------------------------------------------
subroutine mpas_get_local_block_id(dminfo, global_block_number, local_block_number)!{{{
type(dm_info), intent(in) :: dminfo !< Input: Domain Information
integer, intent(in) :: global_block_number !< Input: Global block id from 0 to config_number_of_blocks-1
@@ -473,6 +562,18 @@
end if
end subroutine mpas_get_local_block_id!}}}
+!***********************************************************************
+!
+! routine mpas_get_owning_proc
+!
+!> \brief Determine the owning processor ID for a specific block.
+!> \author Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id$
+!> \details
+!> This routine returns the ID of the processor that owns a specific block.
+!
+!-----------------------------------------------------------------------
subroutine mpas_get_owning_proc(dminfo, global_block_number, owning_proc)!{{{
type(dm_info), intent(in) :: dminfo !< Input: Domain Information
integer, intent(in) :: global_block_number !< Input: Global block id from 0 to config_number_of_blocks-1
@@ -499,13 +600,25 @@
end if
end subroutine mpas_get_owning_proc!}}}
+!***********************************************************************
+!
+! routine mpas_build_block_proc_list
+!
+!> \brief Build list of blocks per processor
+!> \author Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id$
+!> \details
+!> This routine builds the mapping of blocks to processors. Most useful when using an explicit decomposition.
+!
+!-----------------------------------------------------------------------
subroutine mpas_build_block_proc_list(dminfo)!{{{
use mpas_configure
implicit none
- type(dm_info), intent(in) :: dminfo
+ type(dm_info), intent(in) :: dminfo !< Input: Domain information
integer :: iounit, istatus, i, owning_proc
character (len=StrKIND) :: filename
@@ -556,6 +669,18 @@
end subroutine mpas_build_block_proc_list!}}}
+!***********************************************************************
+!
+! routine mpas_finish_block_proc_list
+!
+!> \brief Destroy list of blocks per processor
+!> \author Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id$
+!> \details
+!> This routine destroys the mapping of blocks to processors.
+!
+!-----------------------------------------------------------------------
subroutine mpas_finish_block_proc_list()!{{{
if(.not.explicitDecomp) return
deallocate(block_proc_list)
Modified: branches/ocean_projects/openmp_elements/src/framework/mpas_configure.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/framework/mpas_configure.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/framework/mpas_configure.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -1,3 +1,14 @@
+!-----------------------------------------------------------------------
+! mpas_configure
+!
+!> \brief MPAS Configuration routines.
+!> \author Michael Duda, Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This module will contain all namelist parameter definitions, as well as the routine which reads them from the namelist file.
+!
+!-----------------------------------------------------------------------
module mpas_configure
use mpas_dmpar
@@ -6,13 +17,23 @@
contains
-
+!-----------------------------------------------------------------------
+! routine mpas_read_namelist
+!
+!> \brief MPAS read namelist routine
+!> \author Michael Duda, Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine reads and broadcasts the namelist file.
+!
+!-----------------------------------------------------------------------
subroutine mpas_read_namelist(dminfo, nml_filename)
implicit none
- type (dm_info), intent(in) :: dminfo
- character (len=*), optional :: nml_filename
+ type (dm_info), intent(in) :: dminfo !< Input: Domain information
+ character (len=*), optional :: nml_filename !< Input - Optional: Namelist filename. Defaults to namelist.input
integer :: funit, ierr
Modified: branches/ocean_projects/openmp_elements/src/framework/mpas_constants.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/framework/mpas_constants.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/framework/mpas_constants.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -1,3 +1,17 @@
+!***********************************************************************
+!
+! mpas_constants
+!
+!> \brief MPAS Constant Module
+!> \author Michael Duda
+!> \date 03/27/13
+!> \version SVN:$Id$
+!> \details
+!> This module provides various constants that can be used in different parts of MPAS.
+!> They may or may not be a physical quantity.
+!
+!-----------------------------------------------------------------------
+
module mpas_constants
use mpas_kind_types
@@ -2,15 +16,30 @@
- real (kind=RKIND), parameter :: pii = 3.141592653589793
- real (kind=RKIND), parameter :: a = 6371229.0
- real (kind=RKIND), parameter :: omega = 7.29212e-5
- real (kind=RKIND), parameter :: gravity = 9.80616
- real (kind=RKIND), parameter :: rgas = 287.
- real (kind=RKIND), parameter :: cp = 1003.
- real (kind=RKIND), parameter :: cv = 716. ! cp - rgas
- real (kind=RKIND), parameter :: cvpm = -.71385842 ! -cv/cp
- real (kind=RKIND), parameter :: prandtl = 1.0
+ real (kind=RKIND), parameter :: pii = 3.141592653589793 !< Constant: Pi
+ real (kind=RKIND), parameter :: a = 6371229.0 !< Constant: Spherical Earth radius [m]
+ real (kind=RKIND), parameter :: omega = 7.29212e-5 !< Constant: Angular rotation rate of the Earth [s-1]
+ real (kind=RKIND), parameter :: gravity = 9.80616 !< Constant: Acceleration due to gravity [m s-2]
+ real (kind=RKIND), parameter :: rgas = 287.0 !< Constant: Gas constant for dry air [J kg-1 K-1]
+ real (kind=RKIND), parameter :: rv = 461.6 !< Constant: Gas constant for water vapor [J kg-1 K-1]
+ real (kind=RKIND), parameter :: rvord = rv/rgas !
+ real (kind=RKIND), parameter :: cp = 1003.0 !< Constant: Specific heat of dry air at constant pressure [J kg-1 K-1]
+ real (kind=RKIND), parameter :: cv = cp - rgas !< Constant: Specific heat of dry air at constant volume [J kg-1 K-1]
+ real (kind=RKIND), parameter :: cvpm = -cv/cp !
+ real (kind=RKIND), parameter :: prandtl = 1.0 !< Constant: Prandtl number
contains
+
+!***********************************************************************
+!
+! routine dummy
+!
+!> \brief MPAS Dummy Routine
+!> \author Michael Duda
+!> \date 03/27/13
+!> \version SVN:$Id$
+!> \details
+!> This is a dummy routine that doesn't do anything.
+!
+!-----------------------------------------------------------------------
subroutine dummy()
Modified: branches/ocean_projects/openmp_elements/src/framework/mpas_dmpar.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/framework/mpas_dmpar.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/framework/mpas_dmpar.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -1,3 +1,14 @@
+!-----------------------------------------------------------------------
+! mpas_dmpar
+!
+!> \brief MPAS Communication Routines
+!> \author Michael Duda, Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This module contains all communication routines. All MPI calls should be made in this module.
+!
+!-----------------------------------------------------------------------
module mpas_dmpar
use mpas_dmpar_types
@@ -25,6 +36,8 @@
module procedure mpas_dmpar_alltoall_field1d_real
module procedure mpas_dmpar_alltoall_field2d_real
module procedure mpas_dmpar_alltoall_field3d_real
+ module procedure mpas_dmpar_alltoall_field4d_real
+ module procedure mpas_dmpar_alltoall_field5d_real
end interface
private :: mpas_dmpar_alltoall_field1d_integer
@@ -32,6 +45,8 @@
private :: mpas_dmpar_alltoall_field1d_real
private :: mpas_dmpar_alltoall_field2d_real
private :: mpas_dmpar_alltoall_field3d_real
+ private :: mpas_dmpar_alltoall_field4d_real
+ private :: mpas_dmpar_alltoall_field5d_real
interface mpas_dmpar_exch_halo_field
@@ -41,6 +56,8 @@
module procedure mpas_dmpar_exch_halo_field1d_real
module procedure mpas_dmpar_exch_halo_field2d_real
module procedure mpas_dmpar_exch_halo_field3d_real
+ module procedure mpas_dmpar_exch_halo_field4d_real
+ module procedure mpas_dmpar_exch_halo_field5d_real
end interface
private :: mpas_dmpar_exch_halo_field1d_integer
@@ -49,6 +66,8 @@
private :: mpas_dmpar_exch_halo_field1d_real
private :: mpas_dmpar_exch_halo_field2d_real
private :: mpas_dmpar_exch_halo_field3d_real
+ private :: mpas_dmpar_exch_halo_field4d_real
+ private :: mpas_dmpar_exch_halo_field5d_real
interface mpas_dmpar_copy_field
module procedure mpas_dmpar_copy_field1d_integer
@@ -57,6 +76,8 @@
module procedure mpas_dmpar_copy_field1d_real
module procedure mpas_dmpar_copy_field2d_real
module procedure mpas_dmpar_copy_field3d_real
+ module procedure mpas_dmpar_copy_field4d_real
+ module procedure mpas_dmpar_copy_field5d_real
end interface
private :: mpas_dmpar_copy_field1d_integer
@@ -65,15 +86,29 @@
private :: mpas_dmpar_copy_field1d_real
private :: mpas_dmpar_copy_field2d_real
private :: mpas_dmpar_copy_field3d_real
+ private :: mpas_dmpar_copy_field4d_real
+ private :: mpas_dmpar_copy_field5d_real
contains
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_init
+!
+!> \brief MPAS dmpar initialization routine.
+!> \author Michael Duda, Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine initializes dmpar. It calls MPI_Init (if required), and setups up the communicators.
+!> It also setups of the domain information structure.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_init(dminfo, mpi_comm)!{{{
implicit none
- type (dm_info), intent(inout) :: dminfo
- integer, intent(in), optional :: mpi_comm ! Optional: externally-supplied MPI communicator
+ type (dm_info), intent(inout) :: dminfo !< Input/Output: Domain information
+ integer, intent(in), optional :: mpi_comm !< Input - Optional: externally-supplied MPI communicator
#ifdef _MPI
integer :: mpi_rank, mpi_size
@@ -112,11 +147,22 @@
end subroutine mpas_dmpar_init!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_finalize
+!
+!> \brief MPAS dmpar finalization routine.
+!> \author Michael Duda, Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine finalizes dmpar. It calls MPI_Finalize (if required).
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_finalize(dminfo)!{{{
implicit none
- type (dm_info), intent(inout) :: dminfo
+ type (dm_info), intent(inout) :: dminfo !< Input/Output: Domain information.
#ifdef _MPI
integer :: mpi_ierr
@@ -128,11 +174,22 @@
end subroutine mpas_dmpar_finalize!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_abort
+!
+!> \brief MPAS dmpar abort routine.
+!> \author Michael Duda, Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine aborts MPI. A call to it kills the model through the use of MPI_Abort.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_abort(dminfo)!{{{
implicit none
- type (dm_info), intent(in) :: dminfo
+ type (dm_info), intent(in) :: dminfo !< Input: Domain information
#ifdef _MPI
integer :: mpi_ierr, mpi_errcode
@@ -144,11 +201,22 @@
end subroutine mpas_dmpar_abort!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_global_abort
+!
+!> \brief MPAS dmpar global abort routine.
+!> \author Michael Duda
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine aborts MPI. A call to it kills the model through the use of MPI_Abort on the world communicator, and outputs a message.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_global_abort(mesg)!{{{
implicit none
- character (len=*), intent(in) :: mesg
+ character (len=*), intent(in) :: mesg !< Input: Abort message
#ifdef _MPI
integer :: mpi_ierr, mpi_errcode
@@ -162,12 +230,23 @@
end subroutine mpas_dmpar_global_abort!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_bcast_int
+!
+!> \brief MPAS dmpar broadcast integer routine.
+!> \author Michael Duda
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine broadcasts an integer to all processors in the communicator.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_bcast_int(dminfo, i)!{{{
implicit none
- type (dm_info), intent(in) :: dminfo
- integer, intent(inout) :: i
+ type (dm_info), intent(in) :: dminfo !< Input: Domain information
+ integer, intent(inout) :: i !< Input/Output: Integer to broadcast
#ifdef _MPI
integer :: mpi_ierr
@@ -177,13 +256,24 @@
end subroutine mpas_dmpar_bcast_int!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_bcast_ints
+!
+!> \brief MPAS dmpar broadcast integers routine.
+!> \author Michael Duda
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine broadcasts an array of integers to all processors in the communicator.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_bcast_ints(dminfo, n, iarray)!{{{
implicit none
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: n
- integer, dimension(n), intent(inout) :: iarray
+ type (dm_info), intent(in) :: dminfo !< Input: Domain information
+ integer, intent(in) :: n !< Input: Length of array
+ integer, dimension(n), intent(inout) :: iarray !< Input/Output: Array of integers
#ifdef _MPI
integer :: mpi_ierr
@@ -193,12 +283,23 @@
end subroutine mpas_dmpar_bcast_ints!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_bcast_real
+!
+!> \brief MPAS dmpar broadcast real routine.
+!> \author Michael Duda
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine broadcasts a real to all processors in the communicator.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_bcast_real(dminfo, r)!{{{
implicit none
- type (dm_info), intent(in) :: dminfo
- real (kind=RKIND), intent(inout) :: r
+ type (dm_info), intent(in) :: dminfo !< Input: Domain information
+ real (kind=RKIND), intent(inout) :: r !< Input/Output: Real to be broadcast
#ifdef _MPI
integer :: mpi_ierr
@@ -208,13 +309,24 @@
end subroutine mpas_dmpar_bcast_real!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_bcast_reals
+!
+!> \brief MPAS dmpar broadcast reals routine.
+!> \author Michael Duda
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine broadcasts an array of reals to all processors in the communicator.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_bcast_reals(dminfo, n, rarray)!{{{
implicit none
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: n
- real (kind=RKIND), dimension(n), intent(inout) :: rarray
+ type (dm_info), intent(in) :: dminfo !< Input: Domain information
+ integer, intent(in) :: n !< Input: Length of array
+ real (kind=RKIND), dimension(n), intent(inout) :: rarray !< Input/Output: Array of reals to be broadcast
#ifdef _MPI
integer :: mpi_ierr
@@ -224,12 +336,23 @@
end subroutine mpas_dmpar_bcast_reals!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_bcast_logical
+!
+!> \brief MPAS dmpar broadcast logical routine.
+!> \author Michael Duda
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine broadcasts a logical to all processors in the communicator.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_bcast_logical(dminfo, l)!{{{
implicit none
- type (dm_info), intent(in) :: dminfo
- logical, intent(inout) :: l
+ type (dm_info), intent(in) :: dminfo !< Input: Domain information
+ logical, intent(inout) :: l !< Input/Output: Logical to be broadcast
#ifdef _MPI
integer :: mpi_ierr
@@ -254,12 +377,23 @@
end subroutine mpas_dmpar_bcast_logical!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_bcast_char
+!
+!> \brief MPAS dmpar broadcast character routine.
+!> \author Michael Duda
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine broadcasts a character to all processors in the communicator.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_bcast_char(dminfo, c)!{{{
implicit none
- type (dm_info), intent(in) :: dminfo
- character (len=*), intent(inout) :: c
+ type (dm_info), intent(in) :: dminfo !< Input: Domain information
+ character (len=*), intent(inout) :: c !< Input/Output: Character to be broadcast
#ifdef _MPI
integer :: mpi_ierr
@@ -269,13 +403,24 @@
end subroutine mpas_dmpar_bcast_char!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_sum_int
+!
+!> \brief MPAS dmpar sum integers routine.
+!> \author Michael Duda
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine sums (Allreduce) integer values across all processors in a communicator.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_sum_int(dminfo, i, isum)!{{{
implicit none
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: i
- integer, intent(out) :: isum
+ type (dm_info), intent(in) :: dminfo !< Input: Domain information
+ integer, intent(in) :: i !< Input: Integer value input
+ integer, intent(out) :: isum !< Output: Integer sum for output
integer :: mpi_ierr
@@ -287,13 +432,24 @@
end subroutine mpas_dmpar_sum_int!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_sum_real
+!
+!> \brief MPAS dmpar sum real routine.
+!> \author Michael Duda
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine sums (Allreduce) real values across all processors in a communicator.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_sum_real(dminfo, r, rsum)!{{{
implicit none
- type (dm_info), intent(in) :: dminfo
- real(kind=RKIND), intent(in) :: r
- real(kind=RKIND), intent(out) :: rsum
+ type (dm_info), intent(in) :: dminfo !< Input: Domain information
+ real(kind=RKIND), intent(in) :: r !< Input: Real values to be summed
+ real(kind=RKIND), intent(out) :: rsum !< Output: Sum of reals for output
integer :: mpi_ierr
@@ -305,13 +461,24 @@
end subroutine mpas_dmpar_sum_real!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_min_int
+!
+!> \brief MPAS dmpar minimum integer routine.
+!> \author Michael Duda
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine returns the minimum integer value across all processors in a communicator.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_min_int(dminfo, i, imin)!{{{
implicit none
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: i
- integer, intent(out) :: imin
+ type (dm_info), intent(in) :: dminfo !< Input: Domain information
+ integer, intent(in) :: i !< Input: Integer value
+ integer, intent(out) :: imin !< Output: Minimum integer value
integer :: mpi_ierr
@@ -323,13 +490,24 @@
end subroutine mpas_dmpar_min_int!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_min_real
+!
+!> \brief MPAS dmpar minimum real routine.
+!> \author Michael Duda
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine returns the minimum real value across all processors in a communicator.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_min_real(dminfo, r, rmin)!{{{
implicit none
- type (dm_info), intent(in) :: dminfo
- real(kind=RKIND), intent(in) :: r
- real(kind=RKIND), intent(out) :: rmin
+ type (dm_info), intent(in) :: dminfo !< Input: Domain information
+ real(kind=RKIND), intent(in) :: r !< Input: Real value
+ real(kind=RKIND), intent(out) :: rmin !< Output: Minimum of real value
integer :: mpi_ierr
@@ -341,13 +519,24 @@
end subroutine mpas_dmpar_min_real!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_max_int
+!
+!> \brief MPAS dmpar maximum integer routine.
+!> \author Michael Duda
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine returns the maximum integer value across all processors in a communicator.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_max_int(dminfo, i, imax)!{{{
implicit none
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: i
- integer, intent(out) :: imax
+ type (dm_info), intent(in) :: dminfo !< Input: Domain information
+ integer, intent(in) :: i !< Input: Integer value
+ integer, intent(out) :: imax !< Output: Maximum of integer values
integer :: mpi_ierr
@@ -359,13 +548,24 @@
end subroutine mpas_dmpar_max_int!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_max_real
+!
+!> \brief MPAS dmpar maximum real routine.
+!> \author Michael Duda
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine returns the maximum real value across all processors in a communicator.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_max_real(dminfo, r, rmax)!{{{
implicit none
- type (dm_info), intent(in) :: dminfo
- real(kind=RKIND), intent(in) :: r
- real(kind=RKIND), intent(out) :: rmax
+ type (dm_info), intent(in) :: dminfo !< Input: Domain information
+ real(kind=RKIND), intent(in) :: r !< Input: Real value
+ real(kind=RKIND), intent(out) :: rmax !< Output: Maximum of real values
integer :: mpi_ierr
@@ -377,14 +577,25 @@
end subroutine mpas_dmpar_max_real!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_sum_int_array
+!
+!> \brief MPAS dmpar integer array sum routine.
+!> \author Michael Duda
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine computes the sum of a set of integer arrays across all processors in a communicator.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_sum_int_array(dminfo, nElements, inArray, outArray)!{{{
implicit none
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: nElements
- integer, dimension(nElements), intent(in) :: inArray
- integer, dimension(nElements), intent(out) :: outArray
+ type (dm_info), intent(in) :: dminfo !< Input: Domain information
+ integer, intent(in) :: nElements !< Input: Length of arrays
+ integer, dimension(nElements), intent(in) :: inArray !< Input: Processor specific array to sum
+ integer, dimension(nElements), intent(out) :: outArray !< Output: Sum of arrays
integer :: mpi_ierr
@@ -396,14 +607,25 @@
end subroutine mpas_dmpar_sum_int_array!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_min_int_array
+!
+!> \brief MPAS dmpar integer array minimum routine.
+!> \author Michael Duda
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine computes an array of minimum values for each index across all processors in a communicator, from some input arrays.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_min_int_array(dminfo, nElements, inArray, outArray)!{{{
implicit none
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: nElements
- integer, dimension(nElements), intent(in) :: inArray
- integer, dimension(nElements), intent(out) :: outArray
+ type (dm_info), intent(in) :: dminfo !< Input: Domain information
+ integer, intent(in) :: nElements !< Input: Array size
+ integer, dimension(nElements), intent(in) :: inArray !< Input: Input array of integers
+ integer, dimension(nElements), intent(out) :: outArray !< Output: Array of minimum integers
integer :: mpi_ierr
@@ -415,14 +637,25 @@
end subroutine mpas_dmpar_min_int_array!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_min_int_array
+!
+!> \brief MPAS dmpar integer array maximum routine.
+!> \author Michael Duda
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine computes an array of maximum values for each index across all processors in a communicator, from some input arrays.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_max_int_array(dminfo, nElements, inArray, outArray)!{{{
implicit none
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: nElements
- integer, dimension(nElements), intent(in) :: inArray
- integer, dimension(nElements), intent(out) :: outArray
+ type (dm_info), intent(in) :: dminfo !< Input: Domain information
+ integer, intent(in) :: nElements !< Input: Length of arrays
+ integer, dimension(nElements), intent(in) :: inArray !< Input: Array of integers
+ integer, dimension(nElements), intent(out) :: outArray !< Output: Array of maximum integers
integer :: mpi_ierr
@@ -434,14 +667,25 @@
end subroutine mpas_dmpar_max_int_array!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_sum_real_array
+!
+!> \brief MPAS dmpar real array sum routine.
+!> \author Michael Duda
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine computes the sum array of real values across all processors in a communicator, from some input arrays.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_sum_real_array(dminfo, nElements, inArray, outArray)!{{{
implicit none
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: nElements
- real(kind=RKIND), dimension(nElements), intent(in) :: inArray
- real(kind=RKIND), dimension(nElements), intent(out) :: outArray
+ type (dm_info), intent(in) :: dminfo !< Input: Domain information
+ integer, intent(in) :: nElements !< Input: Length of arrays
+ real(kind=RKIND), dimension(nElements), intent(in) :: inArray !< Input: Array of reals
+ real(kind=RKIND), dimension(nElements), intent(out) :: outArray !< Output: Array of real sums
integer :: mpi_ierr
@@ -453,14 +697,25 @@
end subroutine mpas_dmpar_sum_real_array!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_min_real_array
+!
+!> \brief MPAS dmpar real array minimum routine.
+!> \author Michael Duda
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine computes the minimum array of real values across all processors in a communicator, from some input arrays.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_min_real_array(dminfo, nElements, inArray, outArray)!{{{
implicit none
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: nElements
- real(kind=RKIND), dimension(nElements), intent(in) :: inArray
- real(kind=RKIND), dimension(nElements), intent(out) :: outArray
+ type (dm_info), intent(in) :: dminfo !< Input: Domain information
+ integer, intent(in) :: nElements !< Input: Length of arrays
+ real(kind=RKIND), dimension(nElements), intent(in) :: inArray !< Input: Array of reals
+ real(kind=RKIND), dimension(nElements), intent(out) :: outArray !< Input: Array of minimum reals
integer :: mpi_ierr
@@ -472,14 +727,25 @@
end subroutine mpas_dmpar_min_real_array!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_max_real_array
+!
+!> \brief MPAS dmpar real array maximum routine.
+!> \author Michael Duda
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine computes the maximum array of real values across all processors in a communicator, from some input arrays.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_max_real_array(dminfo, nElements, inArray, outArray)!{{{
implicit none
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: nElements
- real(kind=RKIND), dimension(nElements), intent(in) :: inArray
- real(kind=RKIND), dimension(nElements), intent(out) :: outArray
+ type (dm_info), intent(in) :: dminfo !< Input: Domain information
+ integer, intent(in) :: nElements !< Input: Length of arrays
+ real(kind=RKIND), dimension(nElements), intent(in) :: inArray !< Input: Array of reals
+ real(kind=RKIND), dimension(nElements), intent(out) :: outArray !< Output: Array of maximum reals
integer :: mpi_ierr
@@ -491,15 +757,28 @@
end subroutine mpas_dmpar_max_real_array!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_scatter_ints
+!
+!> \brief MPAS dmpar scatter integers routine
+!> \author Michael Duda
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine computes the maximum array of real values across all processors in a communicator, from some input arrays.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_scatter_ints(dminfo, nprocs, noutlist, displs, counts, inlist, outlist)!{{{
implicit none
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: nprocs, noutlist
- integer, dimension(nprocs), intent(in) :: displs, counts
- integer, dimension(:), pointer :: inlist
- integer, dimension(noutlist), intent(inout) :: outlist
+ type (dm_info), intent(in) :: dminfo !< Input: Domain information
+ integer, intent(in) :: nprocs !< Input: Number of processors
+ integer, intent(in) :: noutlist !< Input: Number integers to receive
+ integer, dimension(nprocs), intent(in) :: displs !< Input: Displacement in sending array
+ integer, dimension(nprocs), intent(in) :: counts !< Input: Number of integers to distribute
+ integer, dimension(:), pointer :: inlist !< Input: List of integers to send
+ integer, dimension(noutlist), intent(inout) :: outlist !< Output: List of received integers
#ifdef _MPI
integer :: mpi_ierr
@@ -509,15 +788,28 @@
end subroutine mpas_dmpar_scatter_ints!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_get_index_range
+!
+!> \brief MPAS dmpar processor specific range of indices
+!> \author Michael Duda
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine divides a global range of indices among all processors, and returns the range of indices a specific processors is responsible for.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_get_index_range(dminfo, &!{{{
global_start, global_end, &
local_start, local_end)
implicit none
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: global_start, global_end
- integer, intent(out) :: local_start, local_end
+ type (dm_info), intent(in) :: dminfo !< Input: Domain information
+ integer, intent(in) :: global_start !< Input: Starting index in global range
+ integer, intent(in) :: global_end !< Input: Ending index in global range
+ integer, intent(out) :: local_start !< Output: Starting index in local range
+ integer, intent(out) :: local_end !< Output: Ending index in local range
local_start = nint(real(dminfo % my_proc_id) * real(global_end - global_start + 1) / real(dminfo % nprocs)) + 1
local_end = nint(real(dminfo % my_proc_id + 1) * real(global_end - global_start + 1) / real(dminfo % nprocs))
@@ -560,16 +852,27 @@
end subroutine mpas_dmpar_compute_index_range!}}}
- ! ----- NEW ROUTINES BELOW ----- !
-
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_get_exch_list
+!
+!> \brief MPAS dmpar exchange list builder
+!> \author Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine builds exchange lists to communicated between the lists of owned and needed fields, over a given number of halos.
+!> Exchange lists are built into the input fields.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_get_exch_list(haloLayer, ownedListField, neededListField, offsetListField, ownedLimitField)!{{{
implicit none
- integer, intent(in) :: haloLayer
- type (field1dInteger), pointer :: ownedListField, neededListField
- type (field0dInteger), pointer, optional :: offsetListField
- type (field0dInteger), pointer, optional :: ownedLimitField
+ integer, intent(in) :: haloLayer !< Input: Halo layer to build exchange list for
+ type (field1dInteger), pointer :: ownedListField !< Input/Output: List of owned fields
+ type (field1dInteger), pointer :: neededListField !< Input/Output: List of needed fields
+ type (field0dInteger), pointer, optional :: offsetListField !< Input: Offsets for placement of received data into destination arrays
+ type (field0dInteger), pointer, optional :: ownedLimitField !< Input: List of limits in owned array
type (dm_info), pointer :: dminfo
@@ -612,7 +915,7 @@
!
! For the neededListField:
- ! similar to the owneListField...
+ ! similar to the ownedListField...
dminfo => ownedListField % block % domain % dminfo
@@ -1110,14 +1413,25 @@
end subroutine mpas_dmpar_get_exch_list!}}}
-
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_alltoall_field1d_integer
+!
+!> \brief MPAS dmpar all-to-all 1D integer routine
+!> \author Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine handles the all-to-all communication of an input field into an output field across all processors.
+!> It requries exchange lists to be created prior to calling this routine.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_alltoall_field1d_integer(fieldIn, fieldout, haloLayersIn)!{{{
implicit none
- type (field1dInteger), pointer :: fieldIn
- type (field1dInteger), pointer :: fieldOut
- integer, dimension(:), pointer, optional :: haloLayersIn
+ type (field1dInteger), pointer :: fieldIn !< Input: Field to send
+ type (field1dInteger), pointer :: fieldOut !< Output: Field to receive
+ integer, dimension(:), pointer, optional :: haloLayersIn !< Input: Halo layers to communicated. Defaults to all.
type (field1dInteger), pointer :: fieldInPtr, fieldOutPtr
type (mpas_exchange_list), pointer :: exchListPtr, exchListPtr2
@@ -1391,13 +1705,25 @@
end subroutine mpas_dmpar_alltoall_field1d_integer!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_alltoall_field2d_integer
+!
+!> \brief MPAS dmpar all-to-all 2D integer routine
+!> \author Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine handles the all-to-all communication of an input field into an output field across all processors.
+!> It requries exchange lists to be created prior to calling this routine.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_alltoall_field2d_integer(fieldIn, fieldout, haloLayersIn)!{{{
implicit none
- type (field2dInteger), pointer :: fieldIn
- type (field2dInteger), pointer :: fieldOut
- integer, dimension(:), pointer, optional :: haloLayersIn
+ type (field2dInteger), pointer :: fieldIn !< Input: Field to communicate from
+ type (field2dInteger), pointer :: fieldOut !< Output: Field to receive into
+ integer, dimension(:), pointer, optional :: haloLayersIn !< Input: List of halo layers to communicate. Defaults to all
type (field2dInteger), pointer :: fieldInPtr, fieldOutPtr
type (mpas_exchange_list), pointer :: exchListPtr, exchListPtr2
@@ -1672,13 +1998,25 @@
end subroutine mpas_dmpar_alltoall_field2d_integer!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_alltoall_field3d_integer
+!
+!> \brief MPAS dmpar all-to-all 3D integer routine
+!> \author Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine handles the all-to-all communication of an input field into an output field across all processors.
+!> It requries exchange lists to be created prior to calling this routine.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_alltoall_field3d_integer(fieldIn, fieldout, haloLayersIn)!{{{
implicit none
- type (field3dInteger), pointer :: fieldIn
- type (field3dInteger), pointer :: fieldOut
- integer, dimension(:), pointer, optional :: haloLayersIn
+ type (field3dInteger), pointer :: fieldIn !< Input: Field to send from
+ type (field3dInteger), pointer :: fieldOut !< Output: Field to receive into
+ integer, dimension(:), pointer, optional :: haloLayersIn !< Input: List of halo layers to communicate. Defaults to all
type (field3dInteger), pointer :: fieldInPtr, fieldOutPtr
type (mpas_exchange_list), pointer :: exchListPtr, exchListPtr2
@@ -1960,13 +2298,25 @@
end subroutine mpas_dmpar_alltoall_field3d_integer!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_alltoall_field1d_real
+!
+!> \brief MPAS dmpar all-to-all 1D real routine
+!> \author Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine handles the all-to-all communication of an input field into an output field across all processors.
+!> It requries exchange lists to be created prior to calling this routine.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_alltoall_field1d_real(fieldIn, fieldout, haloLayersIn)!{{{
implicit none
- type (field1dReal), pointer :: fieldIn
- type (field1dReal), pointer :: fieldOut
- integer, dimension(:), pointer, optional :: haloLayersIn
+ type (field1dReal), pointer :: fieldIn !< Input: Field to send from
+ type (field1dReal), pointer :: fieldOut !< Output: Field to receive into
+ integer, dimension(:), pointer, optional :: haloLayersIn !< Input: List of halo layers to communicate. Defaults to all
type (field1dReal), pointer :: fieldInPtr, fieldOutPtr
type (mpas_exchange_list), pointer :: exchListPtr, exchListPtr2
@@ -2238,13 +2588,25 @@
end subroutine mpas_dmpar_alltoall_field1d_real!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_alltoall_field2d_real
+!
+!> \brief MPAS dmpar all-to-all 2D real routine
+!> \author Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine handles the all-to-all communication of an input field into an output field across all processors.
+!> It requries exchange lists to be created prior to calling this routine.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_alltoall_field2d_real(fieldIn, fieldout, haloLayersIn)!{{{
implicit none
- type (field2dReal), pointer :: fieldIn
- type (field2dReal), pointer :: fieldOut
- integer, dimension(:), pointer, optional :: haloLayersIn
+ type (field2dReal), pointer :: fieldIn !< Input: Field to send from
+ type (field2dReal), pointer :: fieldOut !< Output: Field to receive into
+ integer, dimension(:), pointer, optional :: haloLayersIn !< Input: List of halo layers to communicate. Defaults to all
type (field2dReal), pointer :: fieldInPtr, fieldOutPtr
type (mpas_exchange_list), pointer :: exchListPtr, exchListPtr2
@@ -2520,13 +2882,25 @@
end subroutine mpas_dmpar_alltoall_field2d_real!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_alltoall_field3d_real
+!
+!> \brief MPAS dmpar all-to-all 3D real routine
+!> \author Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine handles the all-to-all communication of an input field into an output field across all processors.
+!> It requries exchange lists to be created prior to calling this routine.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_alltoall_field3d_real(fieldIn, fieldout, haloLayersIn)!{{{
implicit none
- type (field3dReal), pointer :: fieldIn
- type (field3dReal), pointer :: fieldOut
- integer, dimension(:), pointer, optional :: haloLayersIn
+ type (field3dReal), pointer :: fieldIn !< Input: Field to send from
+ type (field3dReal), pointer :: fieldOut !< Output: Field to receive into
+ integer, dimension(:), pointer, optional :: haloLayersIn !< Input: List of halo layers to communicate. Defaults to all
type (field3dReal), pointer :: fieldInPtr, fieldOutPtr
type (mpas_exchange_list), pointer :: exchListPtr, exchListPtr2
@@ -2810,13 +3184,650 @@
end subroutine mpas_dmpar_alltoall_field3d_real!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_alltoall_field4d_real
+!
+!> \brief MPAS dmpar all-to-all 4D real routine
+!> \author Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine handles the all-to-all communication of an input field into an output field across all processors.
+!> It requries exchange lists to be created prior to calling this routine.
+!
+!-----------------------------------------------------------------------
+ subroutine mpas_dmpar_alltoall_field4d_real(fieldIn, fieldout, haloLayersIn)!{{{
+ implicit none
+
+ type (field4dReal), pointer :: fieldIn !< Input: Field to send from
+ type (field4dReal), pointer :: fieldOut !< Output: Field to receive into
+ integer, dimension(:), pointer, optional :: haloLayersIn !< Input: List of halo layers to communicate. Defaults to all
+
+ type (field4dReal), pointer :: fieldInPtr, fieldOutPtr
+ type (mpas_exchange_list), pointer :: exchListPtr, exchListPtr2
+ type (mpas_communication_list), pointer :: sendList, recvList, commListPtr, commListPtr2
+ type (dm_info), pointer :: dminfo
+
+ logical :: comm_list_found
+
+ integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
+ integer :: nAdded, bufferOffset
+ integer :: mpi_ierr
+ integer :: iHalo, iBuffer, i, j, k, l
+ integer :: nHaloLayers
+ integer, dimension(:), pointer :: haloLayers
+
+ dminfo => fieldIn % block % domain % dminfo
+
+ if(present(haloLayersIn)) then
+ nHaloLayers = size(haloLayersIn)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = haloLayersIn(iHalo)
+ end do
+ else
+ nHaloLayers = size(fieldIn % sendList % halos)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = iHalo
+ end do
+ end if
+
+#ifdef _MPI
+ nullify(sendList)
+ nullify(recvList)
+
+ ! Setup recieve lists.
+ do iHalo = 1, nHaloLayers
+ fieldOutPtr => fieldOut
+ do while(associated(fieldOutPtr))
+ exchListPtr => fieldOutPtr % recvList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ comm_list_found = .false.
+
+ ! Search for an already created commList to this processor.
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ if(commListPtr % procID == exchListPtr % endPointID) then
+ commListPtr % nList = commListPtr % nList + exchListPtr % nList * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2) * fieldOutPtr % dimSizes(3)
+ comm_list_found = .true.
+ exit
+ end if
+
+ commListPtr => commListPtr % next
+ end do
+
+ ! If no comm list exists, create a new one.
+ if(.not. comm_list_found) then
+ if(.not.associated(recvList)) then
+ allocate(recvList)
+ nullify(recvList % next)
+ commListPtr => recvList
+ else
+ commListPtr => recvList
+ commListPtr2 => commListPtr % next
+ do while(associated(commListPtr2))
+ commListPtr => commListPtr % next
+ commListPtr2 => commListPtr % next
+ end do
+
+ allocate(commListPtr % next)
+ commListPtr => commListPtr % next
+ nullify(commListPtr % next)
+ end if
+
+ commListPtr % procID = exchListPtr % endPointID
+ commListPtr % nList = exchListPtr % nList * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2) * fieldOutPtr % dimSizes(3)
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldOutPtr => fieldOutPtr % next
+ end do
+ end do
+
+ ! Determine size of receive list buffers.
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldOutPtr => fieldOut
+ do while(associated(fieldOutPtr))
+ exchListPtr => fieldOutPtr % recvList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ nAdded = max(nAdded, maxval(exchListPtr % srcList) * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2) * fieldOutPtr % dimSizes(3))
+ end if
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldOutPtr => fieldOutPtr % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
+ commListPtr % nList = nAdded
+
+ commListPtr => commListPtr % next
+ end do
+
+ ! Allocate buffers for recieves, and initiate mpi_irecv calls.
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ allocate(commListPtr % rbuffer(commListPtr % nList))
+ nullify(commListPtr % ibuffer)
+ call MPI_Irecv(commListPtr % rbuffer, commListPtr % nList, MPI_realKIND, commListPtr % procID, commListPtr % procID, dminfo % comm, commListPtr % reqID, mpi_ierr)
+ commListPtr => commListPtr % next
+ end do
+
+ ! Setup send lists, and determine the size of their buffers.
+ do iHalo = 1, nHaloLayers
+ fieldInPtr => fieldIn
+ do while(associated(fieldInPtr))
+ exchListPtr => fieldInPtr % sendList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ comm_list_found = .false.
+
+ ! Search for an already created commList to this processor.
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ if(commListPtr % procID == exchListPtr % endPointID) then
+ commListPtr % nList = commListPtr % nList + exchListPtr % nList * fieldInPtr % dimSizes(1) * fieldInPtr % dimSizes(2) * fieldOutPtr % dimSizes(3)
+ comm_list_found = .true.
+ exit
+ end if
+
+ commListPtr => commListPtr % next
+ end do
+
+ ! If no comm list exists, create a new one.
+ if(.not. comm_list_found) then
+ if(.not.associated(sendList)) then
+ allocate(sendList)
+ nullify(sendList % next)
+ commListPtr => sendList
+ else
+ commListPtr => sendList
+ commListPtr2 => commListPtr % next
+ do while(associated(commListPtr2))
+ commListPtr => commListPtr % next
+ commListPtr2 => commListPtr % next
+ end do
+
+ allocate(commListPtr % next)
+ commListPtr => commListPtr % next
+ nullify(commListPtr % next)
+ end if
+ commListPtr % procID = exchListPtr % endPointID
+ commListPtr % nList = exchListPtr % nList * fieldInPtr % dimSizes(1) * fieldInPtr % dimSizes(2) * fieldOutPtr % dimSizes(3)
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldInPtr => fieldInPtr % next
+ end do
+ end do
+
+ ! Allocate sendLists, copy data into buffer, and initiate mpi_isends
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ allocate(commListPtr % rbuffer(commListPtr % nList))
+ nullify(commListPtr % ibuffer)
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldInPtr => fieldIn
+ do while(associated(fieldInPtr))
+ exchListPtr => fieldInPtr % sendList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ do j = 1, fieldInPtr % dimSizes(3)
+ do k = 1, fieldInPtr % dimSizes(2)
+ do l = 1, fieldInPtr % dimSizes(1)
+ iBuffer = (exchListPtr % destList(i)-1) * fieldInPtr % dimSizes(1) * fieldInPtr % dimSizes(2) * fieldInPtr % dimSizes(3) &
+ + (j-1) * fieldInPtr % dimSizes(1) * fieldInPtr % dimSizes(2) &
+ + (k-1) * fieldInPtr % dimSizes(1) + l + bufferOffset
+ commListPtr % rbuffer(iBuffer) = fieldInPtr % array(l, k, j, exchListPtr % srcList(i))
+ nAdded = nAdded + 1
+ end do
+ end do
+ end do
+ end do
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldInPtr => fieldInPtr % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
+
+ call MPI_Isend(commListPtr % rbuffer, commListPtr % nlist, MPI_realKIND, &
+ commListPtr % procID, dminfo % my_proc_id, dminfo % comm, commListPtr % reqID, mpi_ierr)
+
+ commListPtr => commListPtr % next
+ end do
+
+#endif
+
+ ! Handle Local Copies. Only local copies if no MPI
+ do iHalo = 1, nHaloLayers
+ fieldInPtr => fieldIn
+ do while(associated(fieldInPtr))
+ exchListPtr => fieldInPtr % copyList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ fieldOutPtr => fieldOut
+ do while(associated(fieldOutPtr))
+ if(exchListPtr % endPointID == fieldOutPtr % block % localBlockID) then
+ do i = 1, exchListPtr % nList
+ fieldOutPtr % array(:, :, :, exchListPtr % destList(i)) = fieldInPtr % array(:, :, :, exchListPtr % srcList(i))
+ end do
+ end if
+ fieldOutPtr => fieldOutPtr % next
+ end do
+
+ exchListPtr => exchListPtr % next
+ end do
+ fieldInPtr => fieldInPtr % next
+ end do
+ end do
+
+#ifdef _MPI
+ ! Wait for MPI_Irecv's to finish, and unpack data.
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldOutPtr => fieldOut
+ do while(associated(fieldOutPtr))
+ exchListPtr => fieldOutPtr % recvList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ do j = 1, fieldOutPtr % dimSizes(3)
+ do k = 1, fieldOutPtr % dimSizes(2)
+ do l = 1, fieldOutPtr % dimSizes(1)
+ iBuffer = (exchListPtr % srcList(i)-1) * fieldOutPtr % dimSizes(3) * fieldOutPtr % dimSizes(2) * fieldOutPtr % dimSizes(1) &
+ + (j-1) * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2) &
+ + (k-1) * fieldOutPtr % dimSizes(1) + l + bufferOffset
+ fieldOutPtr % array(l, k, j, exchListPtr % destList(i)) = commListPtr % rbuffer(iBuffer)
+ end do
+ end do
+ end do
+ end do
+ nAdded = max(nAdded, maxval(exchListPtr % srcList) * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2) * fieldOutPtr % dimSizes(3))
+ end if
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldOutPtr => fieldOutPtr % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
+
+ commListPtr => commListPtr % next
+ end do
+
+ ! Wait for MPI_Isend's to finish.
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ commListPtr => commListPtr % next
+ end do
+
+ ! Destroy commLists.
+ call mpas_dmpar_destroy_communication_list(sendList)
+ call mpas_dmpar_destroy_communication_list(recvList)
+#endif
+
+ deallocate(haloLayers)
+
+ end subroutine mpas_dmpar_alltoall_field4d_real!}}}
+
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_alltoall_field5d_real
+!
+!> \brief MPAS dmpar all-to-all 5D real routine
+!> \author Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine handles the all-to-all communication of an input field into an output field across all processors.
+!> It requries exchange lists to be created prior to calling this routine.
+!
+!-----------------------------------------------------------------------
+ subroutine mpas_dmpar_alltoall_field5d_real(fieldIn, fieldout, haloLayersIn)!{{{
+
+ implicit none
+
+ type (field5dReal), pointer :: fieldIn !< Input: Field to send from
+ type (field5dReal), pointer :: fieldOut !< Output: Field to receive into
+ integer, dimension(:), pointer, optional :: haloLayersIn !< Input: List of halo layers to communicate. Defaults to all.
+
+ type (field5dReal), pointer :: fieldInPtr, fieldOutPtr
+ type (mpas_exchange_list), pointer :: exchListPtr, exchListPtr2
+ type (mpas_communication_list), pointer :: sendList, recvList, commListPtr, commListPtr2
+ type (dm_info), pointer :: dminfo
+
+ logical :: comm_list_found
+
+ integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
+ integer :: nAdded, bufferOffset
+ integer :: mpi_ierr
+ integer :: iHalo, iBuffer, i, j, k, l, m
+ integer :: nHaloLayers
+ integer, dimension(:), pointer :: haloLayers
+
+ dminfo => fieldIn % block % domain % dminfo
+
+ if(present(haloLayersIn)) then
+ nHaloLayers = size(haloLayersIn)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = haloLayersIn(iHalo)
+ end do
+ else
+ nHaloLayers = size(fieldIn % sendList % halos)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = iHalo
+ end do
+ end if
+
+#ifdef _MPI
+ nullify(sendList)
+ nullify(recvList)
+
+ ! Setup recieve lists.
+ do iHalo = 1, nHaloLayers
+ fieldOutPtr => fieldOut
+ do while(associated(fieldOutPtr))
+ exchListPtr => fieldOutPtr % recvList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ comm_list_found = .false.
+
+ ! Search for an already created commList to this processor.
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ if(commListPtr % procID == exchListPtr % endPointID) then
+ commListPtr % nList = commListPtr % nList + exchListPtr % nList * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2) * fieldOutPtr % dimSizes(3) * fieldOutPtr % dimSizes(4)
+ comm_list_found = .true.
+ exit
+ end if
+
+ commListPtr => commListPtr % next
+ end do
+
+ ! If no comm list exists, create a new one.
+ if(.not. comm_list_found) then
+ if(.not.associated(recvList)) then
+ allocate(recvList)
+ nullify(recvList % next)
+ commListPtr => recvList
+ else
+ commListPtr => recvList
+ commListPtr2 => commListPtr % next
+ do while(associated(commListPtr2))
+ commListPtr => commListPtr % next
+ commListPtr2 => commListPtr % next
+ end do
+
+ allocate(commListPtr % next)
+ commListPtr => commListPtr % next
+ nullify(commListPtr % next)
+ end if
+
+ commListPtr % procID = exchListPtr % endPointID
+ commListPtr % nList = exchListPtr % nList * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2) * fieldOutPtr % dimSizes(3) * fieldOutPtr % dimSizes(4)
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldOutPtr => fieldOutPtr % next
+ end do
+ end do
+
+ ! Determine size of receive list buffers.
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldOutPtr => fieldOut
+ do while(associated(fieldOutPtr))
+ exchListPtr => fieldOutPtr % recvList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ nAdded = max(nAdded, maxval(exchListPtr % srcList) * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2) * fieldOutPtr % dimSizes(3) * fieldOutPtr % dimSizes(4))
+ end if
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldOutPtr => fieldOutPtr % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
+ commListPtr % nList = nAdded
+
+ commListPtr => commListPtr % next
+ end do
+
+ ! Allocate buffers for recieves, and initiate mpi_irecv calls.
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ allocate(commListPtr % rbuffer(commListPtr % nList))
+ nullify(commListPtr % ibuffer)
+ call MPI_Irecv(commListPtr % rbuffer, commListPtr % nList, MPI_realKIND, commListPtr % procID, commListPtr % procID, dminfo % comm, commListPtr % reqID, mpi_ierr)
+ commListPtr => commListPtr % next
+ end do
+
+ ! Setup send lists, and determine the size of their buffers.
+ do iHalo = 1, nHaloLayers
+ fieldInPtr => fieldIn
+ do while(associated(fieldInPtr))
+ exchListPtr => fieldInPtr % sendList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ comm_list_found = .false.
+
+ ! Search for an already created commList to this processor.
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ if(commListPtr % procID == exchListPtr % endPointID) then
+ commListPtr % nList = commListPtr % nList + exchListPtr % nList * fieldInPtr % dimSizes(1) * fieldInPtr % dimSizes(2) * fieldOutPtr % dimSizes(3) * fieldInPtr % dimSizes(4)
+ comm_list_found = .true.
+ exit
+ end if
+
+ commListPtr => commListPtr % next
+ end do
+
+ ! If no comm list exists, create a new one.
+ if(.not. comm_list_found) then
+ if(.not.associated(sendList)) then
+ allocate(sendList)
+ nullify(sendList % next)
+ commListPtr => sendList
+ else
+ commListPtr => sendList
+ commListPtr2 => commListPtr % next
+ do while(associated(commListPtr2))
+ commListPtr => commListPtr % next
+ commListPtr2 => commListPtr % next
+ end do
+
+ allocate(commListPtr % next)
+ commListPtr => commListPtr % next
+ nullify(commListPtr % next)
+ end if
+ commListPtr % procID = exchListPtr % endPointID
+ commListPtr % nList = exchListPtr % nList * fieldInPtr % dimSizes(1) * fieldInPtr % dimSizes(2) * fieldOutPtr % dimSizes(3) * fieldInPtr % dimSizes(4)
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldInPtr => fieldInPtr % next
+ end do
+ end do
+
+ ! Allocate sendLists, copy data into buffer, and initiate mpi_isends
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ allocate(commListPtr % rbuffer(commListPtr % nList))
+ nullify(commListPtr % ibuffer)
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldInPtr => fieldIn
+ do while(associated(fieldInPtr))
+ exchListPtr => fieldInPtr % sendList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ do j = 1, fieldInPtr % dimSizes(4)
+ do k = 1, fieldInPtr % dimSizes(3)
+ do l = 1, fieldInPtr % dimSizes(2)
+ do m = 1, fieldInPtr % dimSizes(1)
+ iBuffer = (exchListPtr % destList(i)-1) * fieldInPtr % dimSizes(1) * fieldInPtr % dimSizes(2) * fieldInPtr % dimSizes(3) * fieldInPtr % dimSizes(4) &
+ + (j-1) * fieldInPtr % dimSizes(1) * fieldInPtr % dimSizes(2) * fieldInPtr % dimSizes(3) &
+ + (k-1) * fieldInPtr % dimSizes(1) * fieldInPtr % dimSizes(2) &
+ + (l-1) * fieldInPtr % dimSizes(1) + m + bufferOffset
+ commListPtr % rbuffer(iBuffer) = fieldInPtr % array(m, l, k, j, exchListPtr % srcList(i))
+ nAdded = nAdded + 1
+ end do
+ end do
+ end do
+ end do
+ end do
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldInPtr => fieldInPtr % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
+
+ call MPI_Isend(commListPtr % rbuffer, commListPtr % nlist, MPI_realKIND, &
+ commListPtr % procID, dminfo % my_proc_id, dminfo % comm, commListPtr % reqID, mpi_ierr)
+
+ commListPtr => commListPtr % next
+ end do
+
+#endif
+
+ ! Handle Local Copies. Only local copies if no MPI
+ do iHalo = 1, nHaloLayers
+ fieldInPtr => fieldIn
+ do while(associated(fieldInPtr))
+ exchListPtr => fieldInPtr % copyList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ fieldOutPtr => fieldOut
+ do while(associated(fieldOutPtr))
+ if(exchListPtr % endPointID == fieldOutPtr % block % localBlockID) then
+ do i = 1, exchListPtr % nList
+ fieldOutPtr % array(:, :, :, :, exchListPtr % destList(i)) = fieldInPtr % array(:, :, :, :, exchListPtr % srcList(i))
+ end do
+ end if
+ fieldOutPtr => fieldOutPtr % next
+ end do
+
+ exchListPtr => exchListPtr % next
+ end do
+ fieldInPtr => fieldInPtr % next
+ end do
+ end do
+
+#ifdef _MPI
+ ! Wait for MPI_Irecv's to finish, and unpack data.
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldOutPtr => fieldOut
+ do while(associated(fieldOutPtr))
+ exchListPtr => fieldOutPtr % recvList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ do j = 1, fieldOutPtr % dimSizes(4)
+ do k = 1, fieldOutPtr % dimSizes(3)
+ do l = 1, fieldOutPtr % dimSizes(2)
+ do m = 1, fieldOutPtr % dimSizes(1)
+ iBuffer = (exchListPtr % srcList(i)-1) * fieldOutPtr % dimSizes(4) * fieldOutPtr % dimSizes(3) * fieldOutPtr % dimSizes(2) * fieldOutPtr % dimSizes(1) &
+ + (j-1) * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2) * fieldOutPtr % dimSizes(3) &
+ + (k-1) * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2) &
+ + (l-1) * fieldOutPtr % dimSizes(1) + m + bufferOffset
+ fieldOutPtr % array(m, l, k, j, exchListPtr % destList(i)) = commListPtr % rbuffer(iBuffer)
+ end do
+ end do
+ end do
+ end do
+ end do
+ nAdded = max(nAdded, maxval(exchListPtr % srcList) * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2) * fieldOutPtr % dimSizes(3) * fieldOutPtr % dimSizes(4))
+ end if
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldOutPtr => fieldOutPtr % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
+
+ commListPtr => commListPtr % next
+ end do
+
+ ! Wait for MPI_Isend's to finish.
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ commListPtr => commListPtr % next
+ end do
+
+ ! Destroy commLists.
+ call mpas_dmpar_destroy_communication_list(sendList)
+ call mpas_dmpar_destroy_communication_list(recvList)
+#endif
+
+ deallocate(haloLayers)
+
+ end subroutine mpas_dmpar_alltoall_field5d_real!}}}
+
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_exch_halo_field1d_integer
+!
+!> \brief MPAS dmpar halo exchange 1D integer field
+!> \author Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine handles the halo exchange communication of an input field across all processors.
+!> It requries exchange lists to be created prior to calling this routine.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_exch_halo_field1d_integer(field, haloLayersIn)!{{{
implicit none
- type (field1DInteger), pointer :: field
- integer, dimension(:), intent(in), optional :: haloLayersIn
+ type (field1DInteger), pointer :: field !< Input: Field to communicate
+ integer, dimension(:), intent(in), optional :: haloLayersIn !< Input: List of halo layers to communicate. Defaults to all
type (dm_info), pointer :: dminfo
type (field1DInteger), pointer :: fieldCursor, fieldCursor2
@@ -3091,12 +4102,24 @@
end subroutine mpas_dmpar_exch_halo_field1d_integer!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_exch_halo_field2d_integer
+!
+!> \brief MPAS dmpar halo exchange 2D integer field
+!> \author Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine handles the halo exchange communication of an input field across all processors.
+!> It requries exchange lists to be created prior to calling this routine.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_exch_halo_field2d_integer(field, haloLayersIn)!{{{
implicit none
- type (field2DInteger), pointer :: field
- integer, dimension(:), intent(in), optional :: haloLayersIn
+ type (field2DInteger), pointer :: field !< Input: Field to communicate
+ integer, dimension(:), intent(in), optional :: haloLayersIn !< Input: List of halo layers to communicate. Defaults to all
type (dm_info), pointer :: dminfo
type (field2DInteger), pointer :: fieldCursor, fieldCursor2
@@ -3372,12 +4395,24 @@
end subroutine mpas_dmpar_exch_halo_field2d_integer!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_exch_halo_field3d_integer
+!
+!> \brief MPAS dmpar halo exchange 3D integer field
+!> \author Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine handles the halo exchange communication of an input field across all processors.
+!> It requries exchange lists to be created prior to calling this routine.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_exch_halo_field3d_integer(field, haloLayersIn)!{{{
implicit none
- type (field3DInteger), pointer :: field
- integer, dimension(:), intent(in), optional :: haloLayersIn
+ type (field3DInteger), pointer :: field !< Input: Field to communicate
+ integer, dimension(:), intent(in), optional :: haloLayersIn !< Input: List of halo layers to communicate. Defaults to all
type (dm_info), pointer :: dminfo
type (field3DInteger), pointer :: fieldCursor, fieldCursor2
@@ -3659,12 +4694,24 @@
end subroutine mpas_dmpar_exch_halo_field3d_integer!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_exch_halo_field1d_real
+!
+!> \brief MPAS dmpar halo exchange 1D real field
+!> \author Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine handles the halo exchange communication of an input field across all processors.
+!> It requries exchange lists to be created prior to calling this routine.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_exch_halo_field1d_real(field, haloLayersIn)!{{{
implicit none
- type (field1dReal), pointer :: field
- integer, dimension(:), intent(in), optional :: haloLayersIn
+ type (field1dReal), pointer :: field !< Input: Field to communicate
+ integer, dimension(:), intent(in), optional :: haloLayersIn !< Input: List of halo layers to communicate. Defaults to all
type (dm_info), pointer :: dminfo
type (field1dReal), pointer :: fieldCursor, fieldCursor2
@@ -3937,12 +4984,24 @@
end subroutine mpas_dmpar_exch_halo_field1d_real!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_exch_halo_field2d_real
+!
+!> \brief MPAS dmpar halo exchange 2D real field
+!> \author Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine handles the halo exchange communication of an input field across all processors.
+!> It requries exchange lists to be created prior to calling this routine.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_exch_halo_field2d_real(field, haloLayersIn)!{{{
implicit none
- type (field2dReal), pointer :: field
- integer, dimension(:), intent(in), optional :: haloLayersIn
+ type (field2dReal), pointer :: field !< Input: Field to communicate
+ integer, dimension(:), intent(in), optional :: haloLayersIn !< Input: List of halo layers to communicate. Defaults to all
type (dm_info), pointer :: dminfo
type (field2dReal), pointer :: fieldCursor, fieldCursor2
@@ -4220,12 +5279,24 @@
end subroutine mpas_dmpar_exch_halo_field2d_real!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_exch_halo_field3d_real
+!
+!> \brief MPAS dmpar halo exchange 3D real field
+!> \author Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine handles the halo exchange communication of an input field across all processors.
+!> It requries exchange lists to be created prior to calling this routine.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_exch_halo_field3d_real(field, haloLayersIn)!{{{
implicit none
- type (field3dReal), pointer :: field
- integer, dimension(:), intent(in), optional :: haloLayersIn
+ type (field3dReal), pointer :: field !< Input: Field to communicate
+ integer, dimension(:), intent(in), optional :: haloLayersIn !< Input: List of halo layers to communicate. Defaults to all
type (dm_info), pointer :: dminfo
type (field3dReal), pointer :: fieldCursor, fieldCursor2
@@ -4507,9 +5578,640 @@
end subroutine mpas_dmpar_exch_halo_field3d_real!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_exch_halo_field4d_real
+!
+!> \brief MPAS dmpar halo exchange 4D real field
+!> \author Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine handles the halo exchange communication of an input field across all processors.
+!> It requries exchange lists to be created prior to calling this routine.
+!
+!-----------------------------------------------------------------------
+ subroutine mpas_dmpar_exch_halo_field4d_real(field, haloLayersIn)!{{{
+
+ implicit none
+
+ type (field4dReal), pointer :: field !< Input: Field to communicate
+ integer, dimension(:), intent(in), optional :: haloLayersIn !< Input: List of halo layers to communicate. Defaults to all
+
+ type (dm_info), pointer :: dminfo
+ type (field4dReal), pointer :: fieldCursor, fieldCursor2
+ type (mpas_exchange_list), pointer :: exchListPtr
+ type (mpas_communication_list), pointer :: sendList, recvList, commListPtr, commListPtr2
+ integer :: mpi_ierr
+ integer :: nHaloLayers, iHalo, i, j, k, l
+ integer :: bufferOffset, nAdded
+ integer, dimension(:), pointer :: haloLayers
+
+ logical :: comm_list_found
+
+ do i = 1, 4
+ if(field % dimSizes(i) <= 0) then
+ return
+ end if
+ end do
+
+ dminfo => field % block % domain % dminfo
+
+ if(present(haloLayersIn)) then
+ nHaloLayers = size(haloLayersIn)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = haloLayersIn(iHalo)
+ end do
+ else
+ nHaloLayers = size(field % sendList % halos)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = iHalo
+ end do
+ end if
+
+#ifdef _MPI
+ ! Allocate communication lists, and setup dead header nodes
+ allocate(sendList)
+ nullify(sendList % next)
+ sendList % procID = -1
+ sendList % nList = 0
+
+ allocate(recvList)
+ nullify(recvList % next)
+ recvList % procID = -1
+ recvList % nList = 0
+
+ dminfo = field % block % domain % dminfo
+
+ ! Determine size of buffers for communication lists
+ fieldCursor => field
+ do while(associated(fieldCursor))
+
+ ! Need to aggregate across halo layers
+ do iHalo = 1, nHaloLayers
+
+ ! Determine size from send lists
+ exchListPtr => fieldCursor % sendList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ comm_list_found = .false.
+
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ if(commListPtr % procID == exchListPtr % endPointId) then
+ comm_list_found = .true.
+ commListPtr % nList = commListPtr % nList + exchListPtr % nList * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) * fieldCursor % dimSizes(3)
+ exit
+ end if
+
+ commListPtr => commListPtr % next
+ end do
+
+ if(.not. comm_list_found) then
+ commListPtr => sendList
+ commListPtr2 => commListPtr % next
+ do while(associated(commListPtr2))
+ commListPtr => commListPtr % next
+ commListPtr2 => commListPtr % next
+ end do
+
+ allocate(commListPtr % next)
+ commListPtr => commListPtr % next
+ nullify(commListPtr % next)
+ commListPtr % procID = exchListPtr % endPointID
+ commListPtr % nList = exchListPtr % nList * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) * fieldCursor % dimSizes(3)
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ ! Setup recv lists
+ exchListPtr => fieldCursor % recvList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ comm_list_found = .false.
+
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ if(commListPtr % procID == exchListPtr % endPointId) then
+ comm_list_found = .true.
+ exit
+ end if
+
+ commListPtr => commListPtr % next
+ end do
+
+ if(.not. comm_list_found) then
+ commListPtr => recvList
+ commListPtr2 => commListPtr % next
+ do while(associated(commListPtr2))
+ commListPtr => commListPtr % next
+ commListPtr2 => commListPtr % next
+ end do
+
+ allocate(commListPtr % next)
+ commListPtr => commListPtr % next
+ nullify(commListPtr % next)
+ commListPtr % procID = exchListPtr % endPointID
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+ end do
+
+ fieldCursor => fieldCursor % next
+ end do
+
+ ! Remove the dead head pointer on send and recv list
+ commListPtr => sendList
+ sendList => sendList % next
+ deallocate(commListPtr)
+
+ commListPtr => recvList
+ recvList => recvList % next
+ deallocate(commListPtr)
+
+ ! Determine size of recv lists
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldCursor => field
+ do while(associated(fieldCursor))
+ exchListPtr => fieldCursor % recvList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ nAdded = max(nAdded, maxval(exchListPtr % srcList) * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) * fieldCursor % dimSizes(3))
+ end if
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldCursor => fieldCursor % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
+ commListPtr % nList = bufferOffset
+
+ commListPtr => commListPtr % next
+ end do
+
+ ! Allocate space in recv lists, and initiate mpi_irecv calls
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ allocate(commListPtr % rbuffer(commListPtr % nList))
+ nullify(commListPtr % ibuffer)
+ call MPI_Irecv(commListPtr % rbuffer, commListPtr % nList, MPI_REALKIND, commListPtr % procID, commListPtr % procID, dminfo % comm, commListPtr % reqID, mpi_ierr)
+
+ commListPtr => commListPtr % next
+ end do
+
+ ! Allocate space in send lists, copy data into buffer, and initiate mpi_isend calls
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ allocate(commListPtr % rbuffer(commListPtr % nList))
+ nullify(commListPtr % ibuffer)
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldCursor => field
+ do while(associated(fieldCursor))
+ exchListPtr => fieldCursor % sendList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ do j = 1, fieldCursor % dimSizes(3)
+ do k = 1, fieldCursor % dimSizes(2)
+ do l = 1, fieldCursor % dimSizes(1)
+ commListPtr % rbuffer((exchListPtr % destList(i)-1) * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) * fieldCursor % dimSizes(3) &
+ + (j-1) * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) &
+ + (k-1) * fieldCursor % dimSizes(1) + l + bufferOffset) &
+ = fieldCursor % array(l, k, j, exchListPtr % srcList(i))
+ nAdded = nAdded + 1
+ end do
+ end do
+ end do
+ end do
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldCursor => fieldCursor % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
+
+ call MPI_Isend(commListPtr % rbuffer, commListPtr % nList, MPI_REALKIND, commListPtr % procID, dminfo % my_proc_id, dminfo % comm, commListPtr % reqID, mpi_ierr)
+ commListPtr => commListPtr % next
+ end do
+#endif
+
+ ! Handle local copy. If MPI is off, then only local copies are performed.
+ fieldCursor => field
+ do while(associated(fieldCursor))
+ do iHalo = 1, nHaloLayers
+ exchListPtr => fieldCursor % copyList % halos(haloLayers(iHalo)) % exchList
+
+ do while(associated(exchListPtr))
+ fieldCursor2 => field
+ do while(associated(fieldCursor2))
+ if(exchListPtr % endPointID == fieldCursor2 % block % localBlockID) then
+ do i = 1, exchListPtr % nList
+ fieldCursor2 % array(:, :, :, exchListPtr % destList(i)) = fieldCursor % array(:, :, :, exchListPtr % srcList(i))
+ end do
+ end if
+
+ fieldCursor2 => fieldCursor2 % next
+ end do
+
+ exchListPtr => exchListPtr % next
+ end do
+ end do
+
+ fieldCursor => fieldCursor % next
+ end do
+
+#ifdef _MPI
+
+ ! Wait for mpi_irecv to finish, and unpack data from buffer
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldCursor => field
+ do while(associated(fieldCursor))
+ exchListPtr => fieldCursor % recvList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ do j = 1, fieldCursor % dimSizes(3)
+ do k = 1, fieldCursor % dimSizes(2)
+ do l = 1, fieldCursor % dimSizes(1)
+ fieldCursor % array(l, k, j, exchListPtr % destList(i)) = commListPtr % rbuffer((exchListPtr % srcList(i)-1)&
+ *fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) *fieldCursor % dimSizes(3)&
+ + (j-1)*fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) &
+ + (k-1)*fieldCursor % dimSizes(1) + l + bufferOffset)
+ end do
+ end do
+ end do
+ end do
+ nAdded = max(nAdded, maxval(exchListPtr % srcList) * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) * fieldCursor % dimSizes(3))
+ end if
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldCursor => fieldCursor % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
+ commListPtr => commListPtr % next
+ end do
+
+ ! wait for mpi_isend to finish.
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ commListPtr => commListPtr % next
+ end do
+
+ ! Destroy commLists.
+ call mpas_dmpar_destroy_communication_list(sendList)
+ call mpas_dmpar_destroy_communication_list(recvList)
+#endif
+
+ deallocate(haloLayers)
+
+ end subroutine mpas_dmpar_exch_halo_field4d_real!}}}
+
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_exch_halo_field5d_real
+!
+!> \brief MPAS dmpar halo exchange 5D real field
+!> \author Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine handles the halo exchange communication of an input field across all processors.
+!> It requries exchange lists to be created prior to calling this routine.
+!
+!-----------------------------------------------------------------------
+ subroutine mpas_dmpar_exch_halo_field5d_real(field, haloLayersIn)!{{{
+
+ implicit none
+
+ type (field5dReal), pointer :: field !< Input: Field to communicate
+ integer, dimension(:), intent(in), optional :: haloLayersIn !< Input: List of halo layers to communicate. Defaults to all
+
+ type (dm_info), pointer :: dminfo
+ type (field5dReal), pointer :: fieldCursor, fieldCursor2
+ type (mpas_exchange_list), pointer :: exchListPtr
+ type (mpas_communication_list), pointer :: sendList, recvList, commListPtr, commListPtr2
+ integer :: mpi_ierr
+ integer :: nHaloLayers, iHalo, i, j, k, l, m
+ integer :: bufferOffset, nAdded
+ integer, dimension(:), pointer :: haloLayers
+
+ logical :: comm_list_found
+
+ do i = 1, 5
+ if(field % dimSizes(i) <= 0) then
+ return
+ end if
+ end do
+
+ dminfo => field % block % domain % dminfo
+
+ if(present(haloLayersIn)) then
+ nHaloLayers = size(haloLayersIn)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = haloLayersIn(iHalo)
+ end do
+ else
+ nHaloLayers = size(field % sendList % halos)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = iHalo
+ end do
+ end if
+
+#ifdef _MPI
+ ! Allocate communication lists, and setup dead header nodes
+ allocate(sendList)
+ nullify(sendList % next)
+ sendList % procID = -1
+ sendList % nList = 0
+
+ allocate(recvList)
+ nullify(recvList % next)
+ recvList % procID = -1
+ recvList % nList = 0
+
+ dminfo = field % block % domain % dminfo
+
+ ! Determine size of buffers for communication lists
+ fieldCursor => field
+ do while(associated(fieldCursor))
+
+ ! Need to aggregate across halo layers
+ do iHalo = 1, nHaloLayers
+
+ ! Determine size from send lists
+ exchListPtr => fieldCursor % sendList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ comm_list_found = .false.
+
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ if(commListPtr % procID == exchListPtr % endPointId) then
+ comm_list_found = .true.
+ commListPtr % nList = commListPtr % nList + exchListPtr % nList * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) * fieldCursor % dimSizes(3) * fieldCursor % dimSizes(4)
+ exit
+ end if
+
+ commListPtr => commListPtr % next
+ end do
+
+ if(.not. comm_list_found) then
+ commListPtr => sendList
+ commListPtr2 => commListPtr % next
+ do while(associated(commListPtr2))
+ commListPtr => commListPtr % next
+ commListPtr2 => commListPtr % next
+ end do
+
+ allocate(commListPtr % next)
+ commListPtr => commListPtr % next
+ nullify(commListPtr % next)
+ commListPtr % procID = exchListPtr % endPointID
+ commListPtr % nList = exchListPtr % nList * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) * fieldCursor % dimSizes(3) * fieldCursor % dimSizes(4)
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ ! Setup recv lists
+ exchListPtr => fieldCursor % recvList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ comm_list_found = .false.
+
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ if(commListPtr % procID == exchListPtr % endPointId) then
+ comm_list_found = .true.
+ exit
+ end if
+
+ commListPtr => commListPtr % next
+ end do
+
+ if(.not. comm_list_found) then
+ commListPtr => recvList
+ commListPtr2 => commListPtr % next
+ do while(associated(commListPtr2))
+ commListPtr => commListPtr % next
+ commListPtr2 => commListPtr % next
+ end do
+
+ allocate(commListPtr % next)
+ commListPtr => commListPtr % next
+ nullify(commListPtr % next)
+ commListPtr % procID = exchListPtr % endPointID
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+ end do
+
+ fieldCursor => fieldCursor % next
+ end do
+
+ ! Remove the dead head pointer on send and recv list
+ commListPtr => sendList
+ sendList => sendList % next
+ deallocate(commListPtr)
+
+ commListPtr => recvList
+ recvList => recvList % next
+ deallocate(commListPtr)
+
+ ! Determine size of recv lists
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldCursor => field
+ do while(associated(fieldCursor))
+ exchListPtr => fieldCursor % recvList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ nAdded = max(nAdded, maxval(exchListPtr % srcList) * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) * fieldCursor % dimSizes(3) * fieldCursor % dimSizes(4))
+ end if
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldCursor => fieldCursor % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
+ commListPtr % nList = bufferOffset
+
+ commListPtr => commListPtr % next
+ end do
+
+ ! Allocate space in recv lists, and initiate mpi_irecv calls
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ allocate(commListPtr % rbuffer(commListPtr % nList))
+ nullify(commListPtr % ibuffer)
+ call MPI_Irecv(commListPtr % rbuffer, commListPtr % nList, MPI_REALKIND, commListPtr % procID, commListPtr % procID, dminfo % comm, commListPtr % reqID, mpi_ierr)
+
+ commListPtr => commListPtr % next
+ end do
+
+ ! Allocate space in send lists, copy data into buffer, and initiate mpi_isend calls
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ allocate(commListPtr % rbuffer(commListPtr % nList))
+ nullify(commListPtr % ibuffer)
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldCursor => field
+ do while(associated(fieldCursor))
+ exchListPtr => fieldCursor % sendList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ do j = 1, fieldCursor % dimSizes(4)
+ do k = 1, fieldCursor % dimSizes(3)
+ do l = 1, fieldCursor % dimSizes(2)
+ do m = 1, fieldCursor % dimSizes(1)
+ commListPtr % rbuffer((exchListPtr % destList(i)-1) * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) * fieldCursor % dimSizes(3) * fieldCursor % dimSizes(4) &
+ + (j-1) * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) * fieldCursor % dimSizes(3) &
+ + (k-1) * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) &
+ + (l-1) * fieldCursor % dimSizes(1) + m + bufferOffset) &
+ = fieldCursor % array(m, l, k, j, exchListPtr % srcList(i))
+ nAdded = nAdded + 1
+ end do
+ end do
+ end do
+ end do
+ end do
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldCursor => fieldCursor % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
+
+ call MPI_Isend(commListPtr % rbuffer, commListPtr % nList, MPI_REALKIND, commListPtr % procID, dminfo % my_proc_id, dminfo % comm, commListPtr % reqID, mpi_ierr)
+ commListPtr => commListPtr % next
+ end do
+#endif
+
+ ! Handle local copy. If MPI is off, then only local copies are performed.
+ fieldCursor => field
+ do while(associated(fieldCursor))
+ do iHalo = 1, nHaloLayers
+ exchListPtr => fieldCursor % copyList % halos(haloLayers(iHalo)) % exchList
+
+ do while(associated(exchListPtr))
+ fieldCursor2 => field
+ do while(associated(fieldCursor2))
+ if(exchListPtr % endPointID == fieldCursor2 % block % localBlockID) then
+ do i = 1, exchListPtr % nList
+ fieldCursor2 % array(:, :, :, :, exchListPtr % destList(i)) = fieldCursor % array(:, :, :, :, exchListPtr % srcList(i))
+ end do
+ end if
+
+ fieldCursor2 => fieldCursor2 % next
+ end do
+
+ exchListPtr => exchListPtr % next
+ end do
+ end do
+
+ fieldCursor => fieldCursor % next
+ end do
+
+#ifdef _MPI
+
+ ! Wait for mpi_irecv to finish, and unpack data from buffer
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldCursor => field
+ do while(associated(fieldCursor))
+ exchListPtr => fieldCursor % recvList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ do j = 1, fieldCursor % dimSizes(4)
+ do k = 1, fieldCursor % dimSizes(3)
+ do l = 1, fieldCursor % dimSizes(2)
+ do m = 1, fieldCursor % dimSizes(1)
+ fieldCursor % array(m, l, k, j, exchListPtr % destList(i)) = commListPtr % rbuffer((exchListPtr % srcList(i)-1)&
+ *fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) *fieldCursor % dimSizes(3) * fieldCursor % dimSizes(4)&
+ + (j-1)*fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) * fieldCursor % dimSizes(3) &
+ + (k-1)*fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) &
+ + (l-1)*fieldCursor % dimSizes(1) + m + bufferOffset)
+ end do
+ end do
+ end do
+ end do
+ end do
+ nAdded = max(nAdded, maxval(exchListPtr % srcList) * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) * fieldCursor % dimSizes(3) * fieldCursor % dimSizes(4))
+ end if
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldCursor => fieldCursor % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
+ commListPtr => commListPtr % next
+ end do
+
+ ! wait for mpi_isend to finish.
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ commListPtr => commListPtr % next
+ end do
+
+ ! Destroy commLists.
+ call mpas_dmpar_destroy_communication_list(sendList)
+ call mpas_dmpar_destroy_communication_list(recvList)
+#endif
+
+ deallocate(haloLayers)
+
+ end subroutine mpas_dmpar_exch_halo_field5d_real!}}}
+
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_init_mulithalo_exchange_list
+!
+!> \brief MPAS dmpar initialize muiltihalo exchange list routine.
+!> \author Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine initializes the multihalo exchange lists, based on a number of halo layers.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_init_mulithalo_exchange_list(exchList, nHalos)!{{{
- type (mpas_multihalo_exchange_list), pointer :: exchList
- integer, intent(in) :: nHalos
+ type (mpas_multihalo_exchange_list), pointer :: exchList !< Input: Exchange list to initialize
+ integer, intent(in) :: nHalos !< Input: Number of halo layers for exchange list
integer :: i
@@ -4520,8 +6222,19 @@
end do
end subroutine mpas_dmpar_init_mulithalo_exchange_list!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_destroy_mulithalo_exchange_list
+!
+!> \brief MPAS dmpar destroy muiltihalo exchange list routine.
+!> \author Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine destroys the multihalo exchange lists.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_destroy_mulithalo_exchange_list(exchList)!{{{
- type (mpas_multihalo_exchange_list), pointer :: exchList
+ type (mpas_multihalo_exchange_list), pointer :: exchList !< Input: Exchange list to destroy.
integer :: nHalos
integer :: i
@@ -4537,8 +6250,19 @@
nullify(exchList)
end subroutine mpas_dmpar_destroy_mulithalo_exchange_list!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_destroy_communication_list
+!
+!> \brief MPAS dmpar destroy communication list routine.
+!> \author Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine destroys a communication lists.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_destroy_communication_list(commList)!{{{
- type (mpas_communication_list), pointer :: commList
+ type (mpas_communication_list), pointer :: commList !< Input: Communication list to destroy.
type (mpas_communication_list), pointer :: commListPtr
commListPtr => commList
@@ -4563,8 +6287,19 @@
end subroutine mpas_dmpar_destroy_communication_list!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_destroy_exchange_list
+!
+!> \brief MPAS dmpar destroy exchange list routine.
+!> \author Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine destroys a exchange lists.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_destroy_exchange_list(exchList)!{{{
- type (mpas_exchange_list), pointer :: exchList
+ type (mpas_exchange_list), pointer :: exchList !< Input: Exchange list to destroy
type (mpas_exchange_list), pointer :: exchListPtr
exchListPtr => exchList
@@ -4589,8 +6324,19 @@
end subroutine mpas_dmpar_destroy_exchange_list!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_copy_field1d_integer
+!
+!> \brief MPAS dmpar copy 1D integer field routine
+!> \author Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine copies a 1D integer field throughout a block list.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_copy_field1d_integer(field)!{{{
- type (field1dInteger), pointer :: field
+ type (field1dInteger), pointer :: field !< Input: Field to copy
type (field1dInteger), pointer :: fieldCursor
if(associated(field % next)) then
@@ -4602,8 +6348,19 @@
end if
end subroutine mpas_dmpar_copy_field1d_integer!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_copy_field2d_integer
+!
+!> \brief MPAS dmpar copy 2D integer field routine
+!> \author Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine copies a 2D integer field throughout a block list.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_copy_field2d_integer(field)!{{{
- type (field2dInteger), pointer :: field
+ type (field2dInteger), pointer :: field !< Input: Field to copy
type (field2dInteger), pointer :: fieldCursor
if(associated(field % next)) then
@@ -4615,8 +6372,19 @@
end if
end subroutine mpas_dmpar_copy_field2d_integer!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_copy_field3d_integer
+!
+!> \brief MPAS dmpar copy 3D integer field routine
+!> \author Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine copies a 3D integer field throughout a block list.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_copy_field3d_integer(field)!{{{
- type (field3dInteger), pointer :: field
+ type (field3dInteger), pointer :: field !< Input: Field to copy
type (field3dInteger), pointer :: fieldCursor
if(associated(field % next)) then
@@ -4628,8 +6396,19 @@
end if
end subroutine mpas_dmpar_copy_field3d_integer!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_copy_field1d_real
+!
+!> \brief MPAS dmpar copy 1D real field routine
+!> \author Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine copies a 1D real field throughout a block list.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_copy_field1d_real(field)!{{{
- type (field1dReal), pointer :: field
+ type (field1dReal), pointer :: field !< Input: Field to copy
type (field1dReal), pointer :: fieldCursor
@@ -4642,8 +6421,19 @@
end if
end subroutine mpas_dmpar_copy_field1d_real!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_copy_field2d_real
+!
+!> \brief MPAS dmpar copy 2D real field routine
+!> \author Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine copies a 2D real field throughout a block list.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_copy_field2d_real(field)!{{{
- type (field2dReal), pointer :: field
+ type (field2dReal), pointer :: field !< Input: Field to copy
type (field2dReal), pointer :: fieldCursor
if(associated(field % next)) then
@@ -4655,8 +6445,19 @@
end if
end subroutine mpas_dmpar_copy_field2d_real!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_copy_field3d_real
+!
+!> \brief MPAS dmpar copy 3D real field routine
+!> \author Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine copies a 3D real field throughout a block list.
+!
+!-----------------------------------------------------------------------
subroutine mpas_dmpar_copy_field3d_real(field)!{{{
- type (field3dReal), pointer :: field
+ type (field3dReal), pointer :: field !< Input: Field to copy
type (field3dReal), pointer :: fieldCursor
if(associated(field % next)) then
@@ -4668,4 +6469,52 @@
end if
end subroutine mpas_dmpar_copy_field3d_real!}}}
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_copy_field4d_real
+!
+!> \brief MPAS dmpar copy 4D real field routine
+!> \author Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine copies a 4D real field throughout a block list.
+!
+!-----------------------------------------------------------------------
+ subroutine mpas_dmpar_copy_field4d_real(field)!{{{
+ type (field4dReal), pointer :: field !< Input: Field to copy
+ type (field4dReal), pointer :: fieldCursor
+
+ if(associated(field % next)) then
+ fieldCursor => field % next
+ do while(associated(fieldCursor))
+ fieldCursor % array = field % array
+ fieldCursor => fieldCursor % next
+ end do
+ end if
+ end subroutine mpas_dmpar_copy_field4d_real!}}}
+
+!-----------------------------------------------------------------------
+! routine mpas_dmpar_copy_field5d_real
+!
+!> \brief MPAS dmpar copy 5D real field routine
+!> \author Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine copies a 5D real field throughout a block list.
+!
+!-----------------------------------------------------------------------
+ subroutine mpas_dmpar_copy_field5d_real(field)!{{{
+ type (field5dReal), pointer :: field !< Input: Field to copy
+ type (field5dReal), pointer :: fieldCursor
+
+ if(associated(field % next)) then
+ fieldCursor => field % next
+ do while(associated(fieldCursor))
+ fieldCursor % array = field % array
+ fieldCursor => fieldCursor % next
+ end do
+ end if
+ end subroutine mpas_dmpar_copy_field5d_real!}}}
+
end module mpas_dmpar
Modified: branches/ocean_projects/openmp_elements/src/framework/mpas_dmpar_types.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/framework/mpas_dmpar_types.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/framework/mpas_dmpar_types.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -1,3 +1,14 @@
+!-----------------------------------------------------------------------
+! mpas_dmpar_types
+!
+!> \brief MPAS Communication Type Definitions
+!> \author Michael Duda, Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This module defines all communication related derived data types
+!
+!-----------------------------------------------------------------------
module mpas_dmpar_types
use mpas_kind_types
Modified: branches/ocean_projects/openmp_elements/src/framework/mpas_framework.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/framework/mpas_framework.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/framework/mpas_framework.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -1,3 +1,14 @@
+!-----------------------------------------------------------------------
+! mpas_framework
+!
+!> \brief MPAS Framework routines
+!> \author Michael Duda, Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This module contains all routines related to the general MPAS framework interface.
+!
+!-----------------------------------------------------------------------
module mpas_framework
use mpas_dmpar
@@ -12,8 +23,18 @@
contains
-
- subroutine mpas_framework_init(dminfo, domain, mpi_comm, nml_filename, io_system)
+!-----------------------------------------------------------------------
+! routine mpas_framework_init
+!
+!> \brief MPAS framework initialization routine.
+!> \author Michael Duda, Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine initializes the MPAS framework. It calls routines related to initializing different parts of MPAS, that are housed within the framework.
+!
+!-----------------------------------------------------------------------
+ subroutine mpas_framework_init(dminfo, domain, mpi_comm, nml_filename, io_system)!{{{
implicit none
@@ -43,10 +64,20 @@
end if
call MPAS_io_init(dminfo, pio_num_iotasks, pio_stride, io_system)
- end subroutine mpas_framework_init
+ end subroutine mpas_framework_init!}}}
-
- subroutine mpas_framework_finalize(dminfo, domain, io_system)
+!-----------------------------------------------------------------------
+! routine mpas_framework_finalize
+!
+!> \brief MPAS framework finalization routine.
+!> \author Michael Duda, Doug Jacobsen
+!> \date 03/26/13
+!> \version SVN:$Id:$
+!> \details
+!> This routine finalizes the MPAS framework. It calls routines related to finalizing different parts of MPAS, that are housed within the framework.
+!
+!-----------------------------------------------------------------------
+ subroutine mpas_framework_finalize(dminfo, domain, io_system)!{{{
implicit none
@@ -62,6 +93,6 @@
call mpas_timekeeping_finalize()
- end subroutine mpas_framework_finalize
+ end subroutine mpas_framework_finalize!}}}
end module mpas_framework
Modified: branches/ocean_projects/openmp_elements/src/framework/mpas_grid_types.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/framework/mpas_grid_types.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/framework/mpas_grid_types.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -20,8 +20,68 @@
logical :: output
end type io_info
+ ! Derived type for storing fields
+ type field5DReal
+
+ ! Back-pointer to the containing block
+ type (block_type), pointer :: block
+ ! Raw array holding field data on this block
+ real (kind=RKIND), dimension(:,:,:,:,:), pointer :: array
+
+ ! Information used by the I/O layer
+ type (io_info), pointer :: ioinfo ! to be removed later
+ character (len=StrKIND) :: fieldName
+ character (len=StrKIND), dimension(:), pointer :: constituentNames => null()
+ character (len=StrKIND), dimension(5) :: dimNames
+ integer, dimension(5) :: dimSizes
+ logical :: hasTimeDimension
+ logical :: isSuperArray
+ logical :: isPersistent
+ type (att_list_type), pointer :: attList => null()
+
+ ! Pointers to the prev and next blocks for this field on this task
+ type (field5DReal), pointer :: prev, next
+
+ ! Halo communication lists
+ type (mpas_multihalo_exchange_list), pointer :: sendList
+ type (mpas_multihalo_exchange_list), pointer :: recvList
+ type (mpas_multihalo_exchange_list), pointer :: copyList
+ end type field5DReal
+
+
! Derived type for storing fields
+ type field4DReal
+
+ ! Back-pointer to the containing block
+ type (block_type), pointer :: block
+
+ ! Raw array holding field data on this block
+ real (kind=RKIND), dimension(:,:,:,:), pointer :: array
+
+ ! Information used by the I/O layer
+ type (io_info), pointer :: ioinfo ! to be removed later
+ character (len=StrKIND) :: fieldName
+ character (len=StrKIND), dimension(:), pointer :: constituentNames => null()
+ character (len=StrKIND), dimension(4) :: dimNames
+ integer, dimension(4) :: dimSizes
+ logical :: hasTimeDimension
+ logical :: isSuperArray
+ logical :: isPersistent
+ type (att_list_type), pointer :: attList => null()
+
+ ! Pointers to the prev and next blocks for this field on this task
+ type (field4DReal), pointer :: prev, next
+
+ ! Halo communication lists
+ type (mpas_multihalo_exchange_list), pointer :: sendList
+ type (mpas_multihalo_exchange_list), pointer :: recvList
+ type (mpas_multihalo_exchange_list), pointer :: copyList
+ end type field4DReal
+
+
+
+ ! Derived type for storing fields
type field3DReal
! Back-pointer to the containing block
@@ -38,6 +98,7 @@
integer, dimension(3) :: dimSizes
logical :: hasTimeDimension
logical :: isSuperArray
+ logical :: isPersistent
type (att_list_type), pointer :: attList => null()
! Pointers to the prev and next blocks for this field on this task
@@ -67,6 +128,7 @@
integer, dimension(2) :: dimSizes
logical :: hasTimeDimension
logical :: isSuperArray
+ logical :: isPersistent
type (att_list_type), pointer :: attList => null()
! Pointers to the prev and next blocks for this field on this task
@@ -96,6 +158,7 @@
integer, dimension(1) :: dimSizes
logical :: hasTimeDimension
logical :: isSuperArray
+ logical :: isPersistent
type (att_list_type), pointer :: attList => null()
! Pointers to the prev and next blocks for this field on this task
@@ -152,6 +215,7 @@
integer, dimension(3) :: dimSizes
logical :: hasTimeDimension
logical :: isSuperArray
+ logical :: isPersistent
type (att_list_type), pointer :: attList => null()
! Pointers to the prev and next blocks for this field on this task
@@ -181,6 +245,7 @@
integer, dimension(2) :: dimSizes
logical :: hasTimeDimension
logical :: isSuperArray
+ logical :: isPersistent
type (att_list_type), pointer :: attList => null()
! Pointers to the prev and next blocks for this field on this task
@@ -210,6 +275,7 @@
integer, dimension(1) :: dimSizes
logical :: hasTimeDimension
logical :: isSuperArray
+ logical :: isPersistent
type (att_list_type), pointer :: attList => null()
! Pointers to the prev and next blocks for this field on this task
@@ -266,6 +332,7 @@
integer, dimension(1) :: dimSizes
logical :: hasTimeDimension
logical :: isSuperArray
+ logical :: isPersistent
type (att_list_type), pointer :: attList => null()
! Pointers to the prev and next blocks for this field on this task
@@ -370,6 +437,8 @@
module procedure mpas_allocate_scratch_field1d_real
module procedure mpas_allocate_scratch_field2d_real
module procedure mpas_allocate_scratch_field3d_real
+ module procedure mpas_allocate_scratch_field4d_real
+ module procedure mpas_allocate_scratch_field5d_real
module procedure mpas_allocate_scratch_field1d_char
end interface
@@ -380,6 +449,8 @@
module procedure mpas_deallocate_scratch_field1d_real
module procedure mpas_deallocate_scratch_field2d_real
module procedure mpas_deallocate_scratch_field3d_real
+ module procedure mpas_deallocate_scratch_field4d_real
+ module procedure mpas_deallocate_scratch_field5d_real
module procedure mpas_deallocate_scratch_field1d_char
end interface
@@ -392,6 +463,8 @@
module procedure mpas_deallocate_field1d_real
module procedure mpas_deallocate_field2d_real
module procedure mpas_deallocate_field3d_real
+ module procedure mpas_deallocate_field4d_real
+ module procedure mpas_deallocate_field5d_real
module procedure mpas_deallocate_field0d_char
module procedure mpas_deallocate_field1d_char
end interface
@@ -470,6 +543,10 @@
logical :: single_block
type (field1dInteger), pointer :: f_cursor
+ if(f % isPersistent) then
+ return
+ end if
+
if(present(single_block_in)) then
single_block = single_block_in
else
@@ -498,6 +575,10 @@
logical :: single_block
type (field2dInteger), pointer :: f_cursor
+ if(f % isPersistent) then
+ return
+ end if
+
if(present(single_block_in)) then
single_block = single_block_in
else
@@ -526,6 +607,10 @@
logical :: single_block
type (field3dInteger), pointer :: f_cursor
+ if(f % isPersistent) then
+ return
+ end if
+
if(present(single_block_in)) then
single_block = single_block_in
else
@@ -554,6 +639,10 @@
logical :: single_block
type (field1dReal), pointer :: f_cursor
+ if(f % isPersistent) then
+ return
+ end if
+
if(present(single_block_in)) then
single_block = single_block_in
else
@@ -582,6 +671,10 @@
logical :: single_block
type (field2dReal), pointer :: f_cursor
+ if(f % isPersistent) then
+ return
+ end if
+
if(present(single_block_in)) then
single_block = single_block_in
else
@@ -610,6 +703,10 @@
logical :: single_block
type (field3dReal), pointer :: f_cursor
+ if(f % isPersistent) then
+ return
+ end if
+
if(present(single_block_in)) then
single_block = single_block_in
else
@@ -632,12 +729,80 @@
end subroutine mpas_allocate_scratch_field3d_real!}}}
+ subroutine mpas_allocate_scratch_field4d_real(f, single_block_in)!{{{
+ type (field4dReal), pointer :: f
+ logical, intent(in), optional :: single_block_in
+ logical :: single_block
+ type (field4dReal), pointer :: f_cursor
+
+ if(f % isPersistent) then
+ return
+ end if
+
+ if(present(single_block_in)) then
+ single_block = single_block_in
+ else
+ single_block = .false.
+ end if
+
+ if(.not. single_block) then
+ f_cursor => f
+ do while(associated(f_cursor))
+ if(.not.associated(f_cursor % array)) then
+ allocate(f_cursor % array(f_cursor % dimSizes(1), f_cursor % dimSizes(2), f_cursor % dimSizes(3), f_cursor % dimSizes(4)))
+ end if
+ f_cursor => f_cursor % next
+ end do
+ else
+ if(.not.associated(f % array)) then
+ allocate(f % array(f % dimSizes(1), f % dimSizes(2), f % dimSizes(3), f % dimSizes(4)))
+ end if
+ end if
+
+ end subroutine mpas_allocate_scratch_field4d_real!}}}
+
+ subroutine mpas_allocate_scratch_field5d_real(f, single_block_in)!{{{
+ type (field5dReal), pointer :: f
+ logical, intent(in), optional :: single_block_in
+ logical :: single_block
+ type (field5dReal), pointer :: f_cursor
+
+ if(f % isPersistent) then
+ return
+ end if
+
+ if(present(single_block_in)) then
+ single_block = single_block_in
+ else
+ single_block = .false.
+ end if
+
+ if(.not. single_block) then
+ f_cursor => f
+ do while(associated(f_cursor))
+ if(.not.associated(f_cursor % array)) then
+ allocate(f_cursor % array(f_cursor % dimSizes(1), f_cursor % dimSizes(2), f_cursor % dimSizes(3), f_cursor % dimSizes(4), f_cursor % dimSizes(5)))
+ end if
+ f_cursor => f_cursor % next
+ end do
+ else
+ if(.not.associated(f % array)) then
+ allocate(f % array(f % dimSizes(1), f % dimSizes(2), f % dimSizes(3), f % dimSizes(4), f % dimSizes(5)))
+ end if
+ end if
+
+ end subroutine mpas_allocate_scratch_field5d_real!}}}
+
subroutine mpas_allocate_scratch_field1d_char(f, single_block_in)!{{{
type (field1dChar), pointer :: f
logical, intent(in), optional :: single_block_in
logical :: single_block
type (field1dChar), pointer :: f_cursor
+ if(f % isPersistent) then
+ return
+ end if
+
if(present(single_block_in)) then
single_block = single_block_in
else
@@ -666,6 +831,10 @@
logical :: single_block
type (field1dInteger), pointer :: f_cursor
+ if(f % isPersistent) then
+ return
+ end if
+
if(present(single_block_in)) then
single_block = single_block_in
else
@@ -695,6 +864,10 @@
logical :: single_block
type (field2dInteger), pointer :: f_cursor
+ if(f % isPersistent) then
+ return
+ end if
+
if(present(single_block_in)) then
single_block = single_block_in
else
@@ -724,6 +897,10 @@
logical :: single_block
type (field3dInteger), pointer :: f_cursor
+ if(f % isPersistent) then
+ return
+ end if
+
if(present(single_block_in)) then
single_block = single_block_in
else
@@ -753,6 +930,10 @@
logical :: single_block
type (field1dReal), pointer :: f_cursor
+ if(f % isPersistent) then
+ return
+ end if
+
if(present(single_block_in)) then
single_block = single_block_in
else
@@ -782,6 +963,10 @@
logical :: single_block
type (field2dReal), pointer :: f_cursor
+ if(f % isPersistent) then
+ return
+ end if
+
if(present(single_block_in)) then
single_block = single_block_in
else
@@ -811,6 +996,10 @@
logical :: single_block
type (field3dReal), pointer :: f_cursor
+ if(f % isPersistent) then
+ return
+ end if
+
if(present(single_block_in)) then
single_block = single_block_in
else
@@ -834,12 +1023,82 @@
end subroutine mpas_deallocate_scratch_field3d_real!}}}
+ subroutine mpas_deallocate_scratch_field4d_real(f, single_block_in)!{{{
+ type (field4dReal), pointer :: f
+ logical, intent(in), optional :: single_block_in
+ logical :: single_block
+ type (field4dReal), pointer :: f_cursor
+
+ if(f % isPersistent) then
+ return
+ end if
+
+ if(present(single_block_in)) then
+ single_block = single_block_in
+ else
+ single_block = .false.
+ end if
+
+ if(.not.single_block) then
+ f_cursor => f
+ do while(associated(f_cursor))
+ if(associated(f_cursor % array)) then
+ deallocate(f_cursor % array)
+ end if
+
+ f_cursor => f_cursor % next
+ end do
+ else
+ if(associated(f % array)) then
+ deallocate(f % array)
+ end if
+ end if
+
+ end subroutine mpas_deallocate_scratch_field4d_real!}}}
+
+ subroutine mpas_deallocate_scratch_field5d_real(f, single_block_in)!{{{
+ type (field5dReal), pointer :: f
+ logical, intent(in), optional :: single_block_in
+ logical :: single_block
+ type (field5dReal), pointer :: f_cursor
+
+ if(f % isPersistent) then
+ return
+ end if
+
+ if(present(single_block_in)) then
+ single_block = single_block_in
+ else
+ single_block = .false.
+ end if
+
+ if(.not.single_block) then
+ f_cursor => f
+ do while(associated(f_cursor))
+ if(associated(f_cursor % array)) then
+ deallocate(f_cursor % array)
+ end if
+
+ f_cursor => f_cursor % next
+ end do
+ else
+ if(associated(f % array)) then
+ deallocate(f % array)
+ end if
+ end if
+
+ end subroutine mpas_deallocate_scratch_field5d_real!}}}
+
subroutine mpas_deallocate_scratch_field1d_char(f, single_block_in)!{{{
type (field1dChar), pointer :: f
logical, intent(in), optional :: single_block_in
logical :: single_block
type (field1dChar), pointer :: f_cursor
+ if(f % isPersistent) then
+ return
+ end if
+
if(present(single_block_in)) then
single_block = single_block_in
else
@@ -1073,6 +1332,60 @@
end subroutine mpas_deallocate_field3d_real!}}}
+ subroutine mpas_deallocate_field4d_real(f)!{{{
+ type (field4dReal), pointer :: f
+ type (field4dReal), pointer :: f_cursor
+
+ f_cursor => f
+ do while(associated(f_cursor))
+ if(associated(f % next)) then
+ f => f % next
+ else
+ nullify(f)
+ end if
+
+ if(associated(f_cursor % ioinfo)) then
+ deallocate(f_cursor % ioinfo)
+ end if
+
+ if(associated(f_cursor % array)) then
+ deallocate(f_cursor % array)
+ end if
+
+ deallocate(f_cursor)
+
+ f_cursor => f
+ end do
+
+ end subroutine mpas_deallocate_field4d_real!}}}
+
+ subroutine mpas_deallocate_field5d_real(f)!{{{
+ type (field5dReal), pointer :: f
+ type (field5dReal), pointer :: f_cursor
+
+ f_cursor => f
+ do while(associated(f_cursor))
+ if(associated(f % next)) then
+ f => f % next
+ else
+ nullify(f)
+ end if
+
+ if(associated(f_cursor % ioinfo)) then
+ deallocate(f_cursor % ioinfo)
+ end if
+
+ if(associated(f_cursor % array)) then
+ deallocate(f_cursor % array)
+ end if
+
+ deallocate(f_cursor)
+
+ f_cursor => f
+ end do
+
+ end subroutine mpas_deallocate_field5d_real!}}}
+
subroutine mpas_deallocate_field0d_char(f)!{{{
type (field0dChar), pointer :: f
type (field0dChar), pointer :: f_cursor
Modified: branches/ocean_projects/openmp_elements/src/framework/mpas_hash.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/framework/mpas_hash.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/framework/mpas_hash.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -1,14 +1,19 @@
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! MODULE HASH
+!***********************************************************************
!
-! Purpose: This module provides a dictionary/hashtable with insert, search, and
-! remove routines.
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! mpas_hash
+!
+!> \brief MPAS Hash table module
+!> \author Michael Duda
+!> \date 03/27/13
+!> \version SVN:$Id$
+!> \details
+!> This module provides A dictionary/hashtable with insert, search, and remove routines.
+!
+!-----------------------------------------------------------------------
module mpas_hash
! Parameters
- integer, parameter :: TABLESIZE=27183 ! Number of spaces in the table (the
- ! number of linked lists)
+ integer, parameter :: TABLESIZE=27183 !< Number of spaces in the table (the number of linked lists)
type hashnode
integer :: key
@@ -16,29 +21,35 @@
end type hashnode
type hashnode_ptr
- type (hashnode), pointer :: p ! Pointer to a list of entries
+ type (hashnode), pointer :: p !< Pointer to a list of entries
end type hashnode_ptr
type hashtable
integer :: size
- type (hashnode_ptr), dimension(TABLESIZE) :: table ! The hashtable array
+ type (hashnode_ptr), dimension(TABLESIZE) :: table !< The hashtable array
end type hashtable
contains
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Name: hash_init
- !
- ! Purpose: To initialize a hashtable
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine mpas_hash_init(h)
+!***********************************************************************
+!
+! routine mpas_hash_init
+!
+!> \brief MPAS Hash table init routine
+!> \author Michael Duda
+!> \date 03/27/13
+!> \version SVN:$Id$
+!> \details
+!> This routine initializes a hashtable.
+!
+!-----------------------------------------------------------------------
+ subroutine mpas_hash_init(h)!{{{
implicit none
! Arguments
- type (hashtable), intent(inout) :: h
+ type (hashtable), intent(inout) :: h !< Input/Output: Hash table
! Local variables
integer :: i
@@ -49,25 +60,29 @@
nullify(h%table(i)%p)
end do
- end subroutine mpas_hash_init
+ end subroutine mpas_hash_init!}}}
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Name: hash_insert
- !
- ! Purpose: Given a hashtable h and a key to be inserted into the hashtable,
- ! this routine adds key to the table.
- !
- ! NOTE: If the key already exists in the table, a second copy of the
- ! key is added to the table
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine mpas_hash_insert(h, key)
+!***********************************************************************
+!
+! routine mpas_hash_insert
+!
+!> \brief MPAS Hash table insert routine
+!> \author Michael Duda
+!> \date 03/27/13
+!> \version SVN:$Id$
+!> \details
+!> This routine inserts a key into a hashtable. If the key already exists in the hash table,
+!> a second copy of the key is added to the table.
+!
+!-----------------------------------------------------------------------
+ subroutine mpas_hash_insert(h, key)!{{{
implicit none
! Arguments
- integer, intent(in) :: key
- type (hashtable), intent(inout) :: h
+ integer, intent(in) :: key !< Input: Key
+ type (hashtable), intent(inout) :: h !< Input/Output: Hashtable
! Local variables
integer :: hashval, i
@@ -82,22 +97,27 @@
h%size = h%size + 1
- end subroutine mpas_hash_insert
+ end subroutine mpas_hash_insert!}}}
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Name: hash_search
- !
- ! Purpose: This function returns TRUE if the specified key was found in the
- ! hashtable h, and FALSE otherwise.
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- logical function mpas_hash_search(h, key)
+!***********************************************************************
+!
+! logical function mpas_hash_search
+!
+!> \brief MPAS Hash table search routine
+!> \author Michael Duda
+!> \date 03/27/13
+!> \version SVN:$Id$
+!> \details
+!> This function searches for a key within a hashtable. If the key is found TRUE is returned, and FALSE is return otherwise.
+!
+!-----------------------------------------------------------------------
+ logical function mpas_hash_search(h, key)!{{{
implicit none
! Arguments
- integer, intent(in) :: key
- type (hashtable), intent(inout) :: h
+ integer, intent(in) :: key !< Input: Key
+ type (hashtable), intent(inout) :: h !< Input/Output: Hashtable
! Local variables
integer :: hashval, i
@@ -170,6 +190,6 @@
h%size = 0
- end subroutine mpas_hash_destroy
+ end subroutine mpas_hash_destroy!}}}
end module mpas_hash
Modified: branches/ocean_projects/openmp_elements/src/framework/mpas_io.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/framework/mpas_io.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/framework/mpas_io.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -77,6 +77,7 @@
module procedure MPAS_io_get_var_real2d
module procedure MPAS_io_get_var_real3d
module procedure MPAS_io_get_var_real4d
+ module procedure MPAS_io_get_var_real5d
module procedure MPAS_io_get_var_char0d
end interface MPAS_io_get_var
@@ -91,6 +92,7 @@
module procedure MPAS_io_put_var_real2d
module procedure MPAS_io_put_var_real3d
module procedure MPAS_io_put_var_real4d
+ module procedure MPAS_io_put_var_real5d
module procedure MPAS_io_put_var_char0d
end interface MPAS_io_put_var
@@ -1146,7 +1148,7 @@
subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArray2d, intArray3d, intArray4d, &
- realVal, realArray1d, realArray2d, realArray3d, realArray4d, &
+ realVal, realArray1d, realArray2d, realArray3d, realArray4d, realArray5d, &
charVal, ierr)
implicit none
@@ -1163,6 +1165,7 @@
real (kind=RKIND), dimension(:,:), intent(out), optional :: realArray2d
real (kind=RKIND), dimension(:,:,:), intent(out), optional :: realArray3d
real (kind=RKIND), dimension(:,:,:,:), intent(out), optional :: realArray4d
+ real (kind=RKIND), dimension(:,:,:,:,:), intent(out), optional :: realArray5d
character (len=*), intent(out), optional :: charVal
integer, intent(out), optional :: ierr
@@ -1245,7 +1248,10 @@
pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start2, count2, tempchar)
charVal(1:count2(1)) = tempchar(1)(1:count2(1))
else
- pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % field_desc, charVal)
+ start1(1) = 1
+ count1(1) = field_cursor % fieldhandle % dims(1) % dimsize
+ pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start1, count1, tempchar)
+ charVal(1:count1(1)) = tempchar(1)(1:count1(1))
end if
else if (present(realArray1d)) then
! write (0,*) ' value is real1'
@@ -1263,6 +1269,10 @@
! write (0,*) ' value is real4'
call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, &
realArray4d, pio_ierr)
+ else if (present(realArray5d)) then
+! write (0,*) ' value is real5'
+ call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, &
+ realArray5d, pio_ierr)
else if (present(intArray1d)) then
! write (0,*) ' value is int1'
call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, &
@@ -1492,6 +1502,26 @@
end subroutine MPAS_io_get_var_real4d
+ subroutine MPAS_io_get_var_real5d(handle, fieldname, array, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: fieldname
+ real (kind=RKIND), dimension(:,:,:,:,:), intent(out) :: array
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_ierr
+ type (fieldlist_type), pointer :: field_cursor
+
+! write(0,*) 'Called MPAS_io_get_var_real5d()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ call MPAS_io_get_var_generic(handle, fieldname, realArray5d=array, ierr=ierr)
+
+ end subroutine MPAS_io_get_var_real5d
+
+
subroutine MPAS_io_get_var_char0d(handle, fieldname, val, ierr)
implicit none
@@ -1513,7 +1543,7 @@
subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArray2d, intArray3d, intArray4d, &
- realVal, realArray1d, realArray2d, realArray3d, realArray4d, &
+ realVal, realArray1d, realArray2d, realArray3d, realArray4d, realArray5d, &
charVal, ierr)
implicit none
@@ -1530,6 +1560,7 @@
real (kind=RKIND), dimension(:,:), intent(in), optional :: realArray2d
real (kind=RKIND), dimension(:,:,:), intent(in), optional :: realArray3d
real (kind=RKIND), dimension(:,:,:,:), intent(in), optional :: realArray4d
+ real (kind=RKIND), dimension(:,:,:,:,:), intent(in), optional :: realArray5d
character (len=*), intent(in), optional :: charVal
integer, intent(out), optional :: ierr
@@ -1615,7 +1646,9 @@
count2(1) = field_cursor % fieldhandle % dims(1) % dimsize
pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start2, count2, (/charVal/))
else
- pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, charVal)
+ start1(1) = 1
+ count1(1) = field_cursor % fieldhandle % dims(1) % dimsize
+ pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start1, count1, (/charVal/))
end if
else if (present(realArray1d)) then
call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, &
@@ -1629,6 +1662,9 @@
else if (present(realArray4d)) then
call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, &
realArray4d, pio_ierr)
+ else if (present(realArray5d)) then
+ call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, &
+ realArray5d, pio_ierr)
else if (present(intArray1d)) then
call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, &
intArray1d, pio_ierr)
@@ -1852,6 +1888,26 @@
end subroutine MPAS_io_put_var_real4d
+ subroutine MPAS_io_put_var_real5d(handle, fieldname, array, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: fieldname
+ real (kind=RKIND), dimension(:,:,:,:,:), intent(in) :: array
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_ierr
+ type (fieldlist_type), pointer :: field_cursor
+
+! write(0,*) 'Called MPAS_io_put_var_real5d()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ call MPAS_io_put_var_generic(handle, fieldname, realArray5d=array, ierr=ierr)
+
+ end subroutine MPAS_io_put_var_real5d
+
+
subroutine MPAS_io_put_var_char0d(handle, fieldname, val, ierr)
implicit none
Modified: branches/ocean_projects/openmp_elements/src/framework/mpas_io_streams.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/framework/mpas_io_streams.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/framework/mpas_io_streams.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -19,6 +19,8 @@
type (field1dReal), pointer :: real1dField => null()
type (field2dReal), pointer :: real2dField => null()
type (field3dReal), pointer :: real3dField => null()
+ type (field4dReal), pointer :: real4dField => null()
+ type (field5dReal), pointer :: real5dField => null()
type (field0dChar), pointer :: char0dField => null()
type (field1dChar), pointer :: char1dField => null()
type (field_list_type), pointer :: next => null()
@@ -44,6 +46,8 @@
module procedure MPAS_streamAddField_1dReal
module procedure MPAS_streamAddField_2dReal
module procedure MPAS_streamAddField_3dReal
+ module procedure MPAS_streamAddField_4dReal
+ module procedure MPAS_streamAddField_5dReal
module procedure MPAS_streamAddField_0dChar
end interface MPAS_streamAddField
@@ -82,8 +86,10 @@
FIELD_1D_REAL = 6, &
FIELD_2D_REAL = 7, &
FIELD_3D_REAL = 8, &
- FIELD_0D_CHAR = 9, &
- FIELD_1D_CHAR = 10
+ FIELD_4D_REAL = 9, &
+ FIELD_5D_REAL = 10, &
+ FIELD_0D_CHAR = 11, &
+ FIELD_1D_CHAR = 12
private mergeArrays
@@ -996,6 +1002,208 @@
end subroutine MPAS_streamAddField_3dReal
+ subroutine MPAS_streamAddField_4dReal(stream, field, ierr)
+
+ implicit none
+
+ type (MPAS_Stream_type), intent(inout) :: stream
+ type (field4DReal), intent(in), target :: field
+ integer, intent(out), optional :: ierr
+
+ integer :: io_err
+ integer :: i
+ integer :: idim
+ integer :: totalDimSize, globalDimSize
+ logical :: isDecomposed
+ integer :: ndims
+ type (field4dReal), pointer :: field_ptr
+ character (len=StrKIND), dimension(5) :: dimNames
+ character (len=StrKIND), dimension(:), pointer :: dimNamesInq
+ integer, dimension(:), pointer :: indices
+ type (field_list_type), pointer :: field_list_cursor
+ type (field_list_type), pointer :: new_field_list_node
+ logical :: any_success
+ logical, dimension(:), pointer :: isAvailable
+
+ if (present(ierr)) ierr = MPAS_STREAM_NOERR
+
+ !
+ ! Sanity checks
+ !
+ if (.not. stream % isInitialized) then
+ if (present(ierr)) ierr = MPAS_STREAM_NOT_INITIALIZED
+ return
+ end if
+
+!write(0,*) '... Adding field '//trim(field % fieldName)//' to stream'
+
+ ndims = size(field % dimSizes)
+
+!write(0,*) '... field has ', ndims, ' dimensions'
+
+ !
+ ! Determine whether the field is decomposed, the indices that are owned by this task's blocks,
+ ! and the total number of outer-indices owned by this task
+ !
+#include "add_field_indices.inc"
+
+
+ any_success = .false.
+ if (field % isSuperArray) then
+!write(0,*) '^^^^^^^^^^^^^^^^^^^^^^^^^^^ we are adding a super-array'
+ allocate(isAvailable(size(field % constituentNames)))
+ isAvailable(:) = .false.
+ do i=1,size(field % constituentNames)
+ call MPAS_streamAddField_generic(stream, trim(field % constituentNames(i)), MPAS_IO_DOUBLE, field % dimNames(2:ndims), &
+ field % dimSizes(2:ndims), field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, &
+ indices, io_err)
+ if (io_err == MPAS_STREAM_NOERR) then
+ isAvailable(i) = .true.
+ any_success = .true.
+ end if
+ end do
+ else
+ nullify(isAvailable)
+ call MPAS_streamAddField_generic(stream, trim(field % fieldName), MPAS_IO_DOUBLE, field % dimNames, field % dimSizes, &
+ field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, indices, io_err)
+ if (io_err == MPAS_STREAM_NOERR) then
+ any_success = .true.
+ end if
+ end if
+
+ deallocate(indices)
+ if (.not. any_success) then
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ return
+ end if
+
+ if (field % isSuperArray) then
+ do i=1,size(field % constituentNames)
+ call put_get_field_atts(stream % fileHandle, stream % ioDirection, trim(field % constituentNames(i)), field % attList)
+ end do
+ else
+ call put_get_field_atts(stream % fileHandle, stream % ioDirection, trim(field % fieldname), field % attList)
+ end if
+
+
+ !
+ ! Set field pointer and type in fieldList
+ !
+ new_field_list_node => stream % fieldList
+ do while (associated(new_field_list_node % next))
+ new_field_list_node => new_field_list_node % next
+ end do
+ new_field_list_node % field_type = FIELD_4D_REAL
+ new_field_list_node % real4dField => field
+ new_field_list_node % isAvailable => isAvailable
+
+!write(0,*) '... done adding field'
+!write(0,*) 'DEBUGGING : Finished adding 4d real field '//trim(field % fieldName)
+
+ end subroutine MPAS_streamAddField_4dReal
+
+
+ subroutine MPAS_streamAddField_5dReal(stream, field, ierr)
+
+ implicit none
+
+ type (MPAS_Stream_type), intent(inout) :: stream
+ type (field5DReal), intent(in), target :: field
+ integer, intent(out), optional :: ierr
+
+ integer :: io_err
+ integer :: i
+ integer :: idim
+ integer :: totalDimSize, globalDimSize
+ logical :: isDecomposed
+ integer :: ndims
+ type (field5dReal), pointer :: field_ptr
+ character (len=StrKIND), dimension(5) :: dimNames
+ character (len=StrKIND), dimension(:), pointer :: dimNamesInq
+ integer, dimension(:), pointer :: indices
+ type (field_list_type), pointer :: field_list_cursor
+ type (field_list_type), pointer :: new_field_list_node
+ logical :: any_success
+ logical, dimension(:), pointer :: isAvailable
+
+ if (present(ierr)) ierr = MPAS_STREAM_NOERR
+
+ !
+ ! Sanity checks
+ !
+ if (.not. stream % isInitialized) then
+ if (present(ierr)) ierr = MPAS_STREAM_NOT_INITIALIZED
+ return
+ end if
+
+!write(0,*) '... Adding field '//trim(field % fieldName)//' to stream'
+
+ ndims = size(field % dimSizes)
+
+!write(0,*) '... field has ', ndims, ' dimensions'
+
+ !
+ ! Determine whether the field is decomposed, the indices that are owned by this task's blocks,
+ ! and the total number of outer-indices owned by this task
+ !
+#include "add_field_indices.inc"
+
+
+ any_success = .false.
+ if (field % isSuperArray) then
+!write(0,*) '^^^^^^^^^^^^^^^^^^^^^^^^^^^ we are adding a super-array'
+ allocate(isAvailable(size(field % constituentNames)))
+ isAvailable(:) = .false.
+ do i=1,size(field % constituentNames)
+ call MPAS_streamAddField_generic(stream, trim(field % constituentNames(i)), MPAS_IO_DOUBLE, field % dimNames(2:ndims), &
+ field % dimSizes(2:ndims), field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, &
+ indices, io_err)
+ if (io_err == MPAS_STREAM_NOERR) then
+ isAvailable(i) = .true.
+ any_success = .true.
+ end if
+ end do
+ else
+ nullify(isAvailable)
+ call MPAS_streamAddField_generic(stream, trim(field % fieldName), MPAS_IO_DOUBLE, field % dimNames, field % dimSizes, &
+ field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, indices, io_err)
+ if (io_err == MPAS_STREAM_NOERR) then
+ any_success = .true.
+ end if
+ end if
+
+ deallocate(indices)
+ if (.not. any_success) then
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ return
+ end if
+
+ if (field % isSuperArray) then
+ do i=1,size(field % constituentNames)
+ call put_get_field_atts(stream % fileHandle, stream % ioDirection, trim(field % constituentNames(i)), field % attList)
+ end do
+ else
+ call put_get_field_atts(stream % fileHandle, stream % ioDirection, trim(field % fieldname), field % attList)
+ end if
+
+
+ !
+ ! Set field pointer and type in fieldList
+ !
+ new_field_list_node => stream % fieldList
+ do while (associated(new_field_list_node % next))
+ new_field_list_node => new_field_list_node % next
+ end do
+ new_field_list_node % field_type = FIELD_5D_REAL
+ new_field_list_node % real5dField => field
+ new_field_list_node % isAvailable => isAvailable
+
+!write(0,*) '... done adding field'
+!write(0,*) 'DEBUGGING : Finished adding 3d real field '//trim(field % fieldName)
+
+ end subroutine MPAS_streamAddField_5dReal
+
+
subroutine MPAS_streamAddField_0dChar(stream, field, ierr)
implicit none
@@ -1313,6 +1521,8 @@
type (field1dReal), pointer :: field_1dreal_ptr
type (field2dReal), pointer :: field_2dreal_ptr
type (field3dReal), pointer :: field_3dreal_ptr
+ type (field4dReal), pointer :: field_4dreal_ptr
+ type (field5dReal), pointer :: field_5dreal_ptr
type (field0dChar), pointer :: field_0dchar_ptr
type (field1dChar), pointer :: field_1dchar_ptr
type (field_list_type), pointer :: field_cursor
@@ -1324,6 +1534,8 @@
real (kind=RKIND), dimension(:), pointer :: real1d_temp
real (kind=RKIND), dimension(:,:), pointer :: real2d_temp
real (kind=RKIND), dimension(:,:,:), pointer :: real3d_temp
+ real (kind=RKIND), dimension(:,:,:,:), pointer :: real4d_temp
+ real (kind=RKIND), dimension(:,:,:,:,:), pointer :: real5d_temp
if (present(ierr)) ierr = MPAS_STREAM_NOERR
@@ -1876,7 +2088,185 @@
else
deallocate(real3d_temp)
end if
+ else if (field_cursor % field_type == FIELD_4D_REAL) then
+!write(0,*) 'DEBUGGING : *************** '//trim(field_cursor % real3dField % fieldName)
+!write(0,*) 'DEBUGGING : reading a 4d real array'
+ if (field_cursor % real4dField % isSuperArray) then
+!write(0,*) 'DEBUGGING : reading a 4d real super-array'
+ ncons = size(field_cursor % real4dField % constituentNames)
+ allocate(real3d_temp(field_cursor % real4dField % dimSizes(2), &
+ field_cursor % real4dField % dimSizes(3), &
+ field_cursor % totalDimSize))
+ else
+ ncons = 1
+ allocate(real4d_temp(field_cursor % real4dField % dimSizes(1), &
+ field_cursor % real4dField % dimSizes(2), &
+ field_cursor % real4dField % dimSizes(3), &
+ field_cursor % totalDimSize))
+ end if
+
+ do j=1,ncons
+ if (field_cursor % real4dField % isSuperArray) then
+ if (.not. field_cursor % isAvailable(j)) cycle
+!write(0,*) 'DEBUGGING : calling get_var for a constitutent'
+ call MPAS_io_get_var(stream % fileHandle, field_cursor % real4dField % constituentNames(j), real3d_temp, io_err)
+ else
+ call MPAS_io_get_var(stream % fileHandle, field_cursor % real4dField % fieldName, real4d_temp, io_err)
+ end if
+ call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR) then
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ if (field_cursor % real4dField % isSuperArray) then
+ deallocate(real3d_temp)
+ else
+ deallocate(real4d_temp)
+ end if
+ return
+ end if
+
+ if (field_cursor % isDecomposed) then
+ ! Distribute field to multiple blocks
+ field_4dreal_ptr => field_cursor % real4dField
+ i = 1
+ do while (associated(field_4dreal_ptr))
+ if (trim(field_4dreal_ptr % dimNames(4)) == 'nCells') then
+ ownedSize = field_4dreal_ptr % block % mesh % nCellsSolve
+ else if (trim(field_4dreal_ptr % dimNames(4)) == 'nEdges') then
+ ownedSize = field_4dreal_ptr % block % mesh % nEdgesSolve
+ else if (trim(field_4dreal_ptr % dimNames(4)) == 'nVertices') then
+ ownedSize = field_4dreal_ptr % block % mesh % nVerticesSolve
+ else
+ ownedSize = field_4dreal_ptr % dimSizes(4)
+ end if
+
+ if (field_cursor % real4dField % isSuperArray) then
+!write(0,*) 'DEBUGGING : copying the temporary array'
+ field_4dreal_ptr % array(j, :,:,1:ownedSize) = real3d_temp(:,:,i:i+ownedSize-1)
+ else
+ field_4dreal_ptr % array(:,:,:,1:ownedSize) = real4d_temp(:,:,:,i:i+ownedSize-1)
+ end if
+ i = i + ownedSize
+ field_4dreal_ptr => field_4dreal_ptr % next
+ end do
+
+ else
+
+ if (field_cursor % real3dField % isSuperArray) then
+ call mpas_dmpar_bcast_reals(field_cursor % real4dField % block % domain % dminfo, size(real3d_temp), real3d_temp(:,1,1))
+ field_4dreal_ptr => field_cursor % real4dField
+ do while (associated(field_4dreal_ptr))
+ field_4dreal_ptr % array(j,:,:,:) = real3d_temp(:,:,:)
+ field_4dreal_ptr => field_4dreal_ptr % next
+ end do
+ else
+ call mpas_dmpar_bcast_reals(field_cursor % real4dField % block % domain % dminfo, size(real4d_temp), real4d_temp(:,1,1,1))
+ field_4dreal_ptr => field_cursor % real4dField
+ do while (associated(field_4dreal_ptr))
+ field_4dreal_ptr % array(:,:,:,:) = real4d_temp(:,:,:,:)
+ field_4dreal_ptr => field_4dreal_ptr % next
+ end do
+ end if
+ end if
+ end do
+
+ if (field_cursor % real4dField % isSuperArray) then
+ deallocate(real3d_temp)
+ else
+ deallocate(real4d_temp)
+ end if
+
+ else if (field_cursor % field_type == FIELD_5D_REAL) then
+
+!write(0,*) 'DEBUGGING : *************** '//trim(field_cursor % real3dField % fieldName)
+!write(0,*) 'DEBUGGING : reading a 4d real array'
+ if (field_cursor % real5dField % isSuperArray) then
+!write(0,*) 'DEBUGGING : reading a 4d real super-array'
+ ncons = size(field_cursor % real5dField % constituentNames)
+ allocate(real4d_temp(field_cursor % real5dField % dimSizes(2), &
+ field_cursor % real5dField % dimSizes(3), &
+ field_cursor % real5dField % dimSizes(4), &
+ field_cursor % totalDimSize))
+ else
+ ncons = 1
+ allocate(real5d_temp(field_cursor % real5dField % dimSizes(1), &
+ field_cursor % real5dField % dimSizes(2), &
+ field_cursor % real5dField % dimSizes(3), &
+ field_cursor % real5dField % dimSizes(4), &
+ field_cursor % totalDimSize))
+ end if
+
+ do j=1,ncons
+ if (field_cursor % real5dField % isSuperArray) then
+ if (.not. field_cursor % isAvailable(j)) cycle
+!write(0,*) 'DEBUGGING : calling get_var for a constitutent'
+ call MPAS_io_get_var(stream % fileHandle, field_cursor % real5dField % constituentNames(j), real4d_temp, io_err)
+ else
+ call MPAS_io_get_var(stream % fileHandle, field_cursor % real5dField % fieldName, real5d_temp, io_err)
+ end if
+ call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR) then
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ if (field_cursor % real5dField % isSuperArray) then
+ deallocate(real4d_temp)
+ else
+ deallocate(real5d_temp)
+ end if
+ return
+ end if
+
+ if (field_cursor % isDecomposed) then
+ ! Distribute field to multiple blocks
+ field_5dreal_ptr => field_cursor % real5dField
+ i = 1
+ do while (associated(field_5dreal_ptr))
+ if (trim(field_5dreal_ptr % dimNames(5)) == 'nCells') then
+ ownedSize = field_5dreal_ptr % block % mesh % nCellsSolve
+ else if (trim(field_5dreal_ptr % dimNames(5)) == 'nEdges') then
+ ownedSize = field_5dreal_ptr % block % mesh % nEdgesSolve
+ else if (trim(field_5dreal_ptr % dimNames(5)) == 'nVertices') then
+ ownedSize = field_5dreal_ptr % block % mesh % nVerticesSolve
+ else
+ ownedSize = field_5dreal_ptr % dimSizes(5)
+ end if
+
+ if (field_cursor % real5dField % isSuperArray) then
+!write(0,*) 'DEBUGGING : copying the temporary array'
+ field_5dreal_ptr % array(j,:,:,:,1:ownedSize) = real4d_temp(:,:,:,i:i+ownedSize-1)
+ else
+ field_5dreal_ptr % array(:,:,:,:,1:ownedSize) = real5d_temp(:,:,:,:,i:i+ownedSize-1)
+ end if
+ i = i + ownedSize
+ field_5dreal_ptr => field_5dreal_ptr % next
+ end do
+
+ else
+
+ if (field_cursor % real5dField % isSuperArray) then
+ call mpas_dmpar_bcast_reals(field_cursor % real5dField % block % domain % dminfo, size(real4d_temp), real4d_temp(:,1,1,1))
+ field_5dreal_ptr => field_cursor % real5dField
+ do while (associated(field_5dreal_ptr))
+ field_5dreal_ptr % array(j,:,:,:,:) = real4d_temp(:,:,:,:)
+ field_5dreal_ptr => field_5dreal_ptr % next
+ end do
+ else
+ call mpas_dmpar_bcast_reals(field_cursor % real5dField % block % domain % dminfo, size(real5d_temp), real5d_temp(:,1,1,1,1))
+ field_5dreal_ptr => field_cursor % real5dField
+ do while (associated(field_5dreal_ptr))
+ field_5dreal_ptr % array(:,:,:,:,:) = real5d_temp(:,:,:,:,:)
+ field_5dreal_ptr => field_5dreal_ptr % next
+ end do
+ end if
+ end if
+ end do
+
+ if (field_cursor % real5dField % isSuperArray) then
+ deallocate(real4d_temp)
+ else
+ deallocate(real5d_temp)
+ end if
+
+
else if (field_cursor % field_type == FIELD_0D_CHAR) then
!write(0,*) 'Reading in field '//trim(field_cursor % char0dField % fieldName)
Modified: branches/ocean_projects/openmp_elements/src/framework/mpas_kind_types.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/framework/mpas_kind_types.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/framework/mpas_kind_types.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -1,3 +1,16 @@
+!***********************************************************************
+!
+! mpas_kind_types
+!
+!> \brief MPAS Kind definition module
+!> \author Michael Duda, Doug Jacobsen
+!> \date 03/27/13
+!> \version SVN:$Id$
+!> \details
+!> This module defines the kind types for basic fortran data types within MPAS.
+!
+!-----------------------------------------------------------------------
+
module mpas_kind_types
#ifdef SINGLE_PRECISION
@@ -10,6 +23,18 @@
contains
+!***********************************************************************
+!
+! routine dummy_kinds
+!
+!> \brief MPAS Dummy kind routine
+!> \author Michael Duda
+!> \date 03/27/13
+!> \version SVN:$Id$
+!> \details
+!> This is a dummy routine that doesn't do anything.
+!
+!-----------------------------------------------------------------------
subroutine dummy_kinds()
end subroutine dummy_kinds
Modified: branches/ocean_projects/openmp_elements/src/framework/mpas_sort.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/framework/mpas_sort.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/framework/mpas_sort.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -1,3 +1,16 @@
+!***********************************************************************
+!
+! mpas_sort
+!
+!> \brief MPAS Sort and search module
+!> \author Michael Duda
+!> \date 03/27/13
+!> \version SVN:$Id$
+!> \details
+!> This module provides routines for various sorting methods, in addition to a binary search.
+!
+!-----------------------------------------------------------------------
+
module mpas_sort
use mpas_kind_types
@@ -11,13 +24,27 @@
contains
+!***********************************************************************
+!
+! recursive routine mpas_mergesort
+!
+!> \brief MPAS Merge sort
+!> \author Michael Duda
+!> \date 03/27/13
+!> \version SVN:$Id$
+!> \details
+!> This routine recursively calls itself to perform a merge sort on array.
+!
+!-----------------------------------------------------------------------
recursive subroutine mpas_mergesort(array, d1, n1, n2)!{{{
implicit none
! Arguments
- integer, intent(in) :: n1, n2, d1
- integer, dimension(1:d1,n1:n2), intent(inout) :: array
+ integer, intent(in) :: d1 !< Input: Size of first dimension of array
+ integer, intent(in) :: n1 !< Input: Beginning of second dimension of array
+ integer, intent(in) :: n2 !< Input: Ending of second dimension of array
+ integer, dimension(1:d1,n1:n2), intent(inout) :: array !< Input/Output: Array to be sorted (in-place)
! Local variables
integer :: i, j, k
@@ -73,12 +100,24 @@
end subroutine mpas_mergesort!}}}
+!***********************************************************************
+!
+! routine mpas_quicksort_1dint
+!
+!> \brief MPAS 1D integer quicksort
+!> \author Michael Duda
+!> \date 03/27/13
+!> \version SVN:$Id$
+!> \details
+!> This routine performs a quicksort on a 1D integer array
+!
+!-----------------------------------------------------------------------
subroutine mpas_quicksort_1dint(nArray, array)!{{{
implicit none
- integer, intent(in) :: nArray
- integer, dimension(nArray), intent(inout) :: array
+ integer, intent(in) :: nArray !< Input: Array size
+ integer, dimension(nArray), intent(inout) :: array !< Input/Output: Array to be sorted
integer :: i, j, top, l, r, pivot, s
integer :: pivot_value
@@ -135,12 +174,24 @@
end subroutine mpas_quicksort_1dint!}}}
+!***********************************************************************
+!
+! routine mpas_quicksort_1dreal
+!
+!> \brief MPAS 1D real quicksort
+!> \author Michael Duda
+!> \date 03/27/13
+!> \version SVN:$Id$
+!> \details
+!> This routine performs a quicksort on a 1D real array
+!
+!-----------------------------------------------------------------------
subroutine mpas_quicksort_1dreal(nArray, array)!{{{
implicit none
- integer, intent(in) :: nArray
- real (kind=RKIND), dimension(nArray), intent(inout) :: array
+ integer, intent(in) :: nArray !< Input: Array size
+ real (kind=RKIND), dimension(nArray), intent(inout) :: array !< Input/Output: Array to be sorted
integer :: i, j, top, l, r, pivot, s
real (kind=RKIND) :: pivot_value
@@ -197,12 +248,24 @@
end subroutine mpas_quicksort_1dreal!}}}
+!***********************************************************************
+!
+! routine mpas_quicksort_2dint
+!
+!> \brief MPAS 2D integer quicksort
+!> \author Michael Duda
+!> \date 03/27/13
+!> \version SVN:$Id$
+!> \details
+!> This routine performs a quicksort on a 2D integer array
+!
+!-----------------------------------------------------------------------
subroutine mpas_quicksort_2dint(nArray, array)!{{{
implicit none
- integer, intent(in) :: nArray
- integer, dimension(2,nArray), intent(inout) :: array
+ integer, intent(in) :: nArray !< Input: Array size
+ integer, dimension(2,nArray), intent(inout) :: array !< Input/Output: Array to be sorted
integer :: i, j, top, l, r, pivot, s
integer :: pivot_value
@@ -259,12 +322,24 @@
end subroutine mpas_quicksort_2dint!}}}
+!***********************************************************************
+!
+! routine mpas_quicksort_2dreal
+!
+!> \brief MPAS 2D real quicksort
+!> \author Michael Duda
+!> \date 03/27/13
+!> \version SVN:$Id$
+!> \details
+!> This routine performs a quicksort on a 2D real array
+!
+!-----------------------------------------------------------------------
subroutine mpas_quicksort_2dreal(nArray, array)!{{{
implicit none
- integer, intent(in) :: nArray
- real (kind=RKIND), dimension(2,nArray), intent(inout) :: array
+ integer, intent(in) :: nArray !< Input: Array size
+ real (kind=RKIND), dimension(2,nArray), intent(inout) :: array !< Input/Output: Array to be sorted
integer :: i, j, top, l, r, pivot, s
real (kind=RKIND) :: pivot_value
@@ -321,6 +396,18 @@
end subroutine mpas_quicksort_2dreal!}}}
+!***********************************************************************
+!
+! integer function mpas_binary_search
+!
+!> \brief MPAS Binary search routine
+!> \author Michael Duda
+!> \date 03/27/13
+!> \version SVN:$Id$
+!> \details
+!> This routine performs a binary search in array for the key. It either returns the index of the key within array, or n2+1 if the key is not found.
+!
+!-----------------------------------------------------------------------
integer function mpas_binary_search(array, d1, n1, n2, key)!{{{
implicit none
Modified: branches/ocean_projects/openmp_elements/src/framework/mpas_timer.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/framework/mpas_timer.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/framework/mpas_timer.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -1,3 +1,17 @@
+!***********************************************************************
+!
+! mpas_timer
+!
+!> \brief MPAS Timer module
+!> \author Michael Duda, Doug Jacobsen
+!> \date 03/27/13
+!> \version SVN:$Id$
+!> \details
+!> This module provides developers with internal timer routines. These can be
+!> use to profile various parts of code within MPAS. Calls to TAU happen in this module as well
+!> to provide more detailed profiling.
+!
+!-----------------------------------------------------------------------
module mpas_timer
use mpas_kind_types
@@ -32,6 +46,19 @@
contains
+!***********************************************************************
+!
+! routine mpas_timer_start
+!
+!> \brief MPAS Timer start routine
+!> \author Doug Jacobsen
+!> \date 03/27/13
+!> \version SVN:$Id$
+!> \details
+!> This routine starts a timer. By default, timer_name is searched for in the linked list of timers.
+!> If timer_ptr is provided, the search doesn't happen and the pointer to the timer is used (or allocated if not created yet).
+!
+!-----------------------------------------------------------------------
subroutine mpas_timer_start(timer_name, clear_timer, timer_ptr)!{{{
# ifdef _MPI
use mpi
@@ -161,6 +188,19 @@
end subroutine mpas_timer_start!}}}
+!***********************************************************************
+!
+! routine mpas_timer_stop
+!
+!> \brief MPAS Timer stop routine
+!> \author Doug Jacobsen
+!> \date 03/27/13
+!> \version SVN:$Id$
+!> \details
+!> This routine stops a timer. By default, timer_name is searched for in the linked list of timers.
+!> If timer_ptr is provided, the search doesn't happen and the pointer to the timer is used.
+!
+!-----------------------------------------------------------------------
subroutine mpas_timer_stop(timer_name, timer_ptr)!{{{
# ifdef _MPI
use mpi
@@ -238,9 +278,23 @@
end subroutine mpas_timer_stop!}}}
+!***********************************************************************
+!
+! recursive routine mpas_timer_write
+!
+!> \brief MPAS Timer write routine
+!> \author Doug Jacobsen
+!> \date 03/27/13
+!> \version SVN:$Id$
+!> \details
+!> This routine writes all timer output to stdout. It recursively calls
+!> itself until all timers have been written out. Prior to writing timers,
+!> this routine calls mpas_timer_sync.
+!
+!-----------------------------------------------------------------------
recursive subroutine mpas_timer_write(timer_ptr, total_ptr)!{{{
- type (timer_node), pointer, optional :: timer_ptr
- type (timer_node), pointer, optional :: total_ptr
+ type (timer_node), pointer, optional :: timer_ptr !< Input - Optional: Pointer to a specific timer to write out.
+ type (timer_node), pointer, optional :: total_ptr !< Input - Optional: Pointer to the total_time timer.
character (len=StrKIND) :: tname
logical :: total_found, string_equals
@@ -269,7 +323,7 @@
timer_ptr%avg_time = 0.0d0
percent = 0.0d0
else
- timer_ptr%avg_time = timer_ptr%avg_time/timer_ptr%calls
+ timer_ptr%avg_time = timer_ptr%total_time/timer_ptr%calls
percent = timer_ptr%total_time/total_ptr%total_time
endif
@@ -312,8 +366,20 @@
end subroutine mpas_timer_write!}}}
+!***********************************************************************
+!
+! routine mpas_timer_init
+!
+!> \brief MPAS Timer init routine
+!> \author Doug Jacobsen
+!> \date 03/27/13
+!> \version SVN:$Id$
+!> \details
+!> This routine initializes the mpas_timer setup. It needs to have access to the dminfo object in order to sync timers.
+!
+!-----------------------------------------------------------------------
subroutine mpas_timer_init(domain)!{{{
- type (domain_type), intent(in), optional :: domain
+ type (domain_type), intent(in), optional :: domain !< Input - Optional: Domain structure
if( present(domain) ) then
domain_info => domain % dminfo
@@ -323,6 +389,19 @@
end subroutine mpas_timer_init!}}}
+!***********************************************************************
+!
+! routine mpas_timer_sync
+!
+!> \brief MPAS Timer sync routine
+!> \author Doug Jacobsen
+!> \date 03/27/13
+!> \version SVN:$Id$
+!> \details
+!> This routine synchronizes timers across all processors in order to better represent
+!> the entire run domain with the timer output.
+!
+!-----------------------------------------------------------------------
subroutine mpas_timer_sync()!{{{
use mpas_dmpar
Modified: branches/ocean_projects/openmp_elements/src/operators/mpas_rbf_interpolation.F
===================================================================
--- branches/ocean_projects/openmp_elements/src/operators/mpas_rbf_interpolation.F 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/operators/mpas_rbf_interpolation.F 2013-03-29 14:40:23 UTC (rev 2678)
@@ -1,3 +1,16 @@
+!***********************************************************************
+!
+! mpas_rbf_interpolation
+!
+!> \brief MPAS Radial basis function interpolation module
+!> \author Xylar Asay-Davis
+!> \date 03/28/13
+!> \version SVN:$Id$
+!> \details
+!> This module provides routines for performing interpolation with radial basis functions.
+!> It performs interpolation of scalar and vector functions in 2 and 3 dimensions.
+!
+!-----------------------------------------------------------------------
module mpas_rbf_interpolation
use mpas_dmpar
use mpas_grid_types
@@ -6,11 +19,6 @@
private
save
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Purpose: perform interpolation of scalar and vector functions in 2D
-! and 3D using Radial Basis Functions (RBFs).
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
! Initialize the geometry that will be useful from interpolation
public :: mpas_rbf_interp_initialize
@@ -93,26 +101,32 @@
contains
- subroutine mpas_rbf_interp_initialize(grid)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Purpose: compute geometric fields that will be potentially useful for calling
- ! the interpolation routines
- !
- ! Input: the grid
- !
- ! Output:
- ! edgeNormalVectors - the unit vector at the center of each edge tangent to the sphere
- ! cellTangentPlane - 2 orthogonal unit vectors in the tangent plane of each cell
- ! The first unit vector is chosen to point toward the center of the first
- ! edge on the cell.
- ! localVerticalUnitVectors - the unit normal vector of the tangent plane at the center
- ! of each cell
- !
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!***********************************************************************
+!
+! routine mpas_rbf_interp_initialize
+!
+!> \brief MPAS RBF interpolation initialization routine
+!> \author Xylar Asay-Davis
+!> \date 03/28/13
+!> \version SVN:$Id$
+!> \details
+!> This routine computes geometric fields that will be potentially useful for calling
+!> the interpolation routines.
+!> Input: the grid
+!> Output:
+!> edgeNormalVectors - the unit vector at the center of each edge tangent to the sphere
+!> cellTangentPlane - 2 orthogonal unit vectors in the tangent plane of each cell
+!> The first unit vector is chosen to point toward the center of the first
+!> edge on the cell.
+!> localVerticalUnitVectors - the unit normal vector of the tangent plane at the center
+!> of each cell
+!-----------------------------------------------------------------------
+ subroutine mpas_rbf_interp_initialize(grid)!{{{
+
implicit none
- type (mesh_type), intent(inout) :: grid
+ type (mesh_type), intent(inout) :: grid !< Input/Output: Grid information
integer :: nCells, nEdges
integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnCell
@@ -185,34 +199,41 @@
cellTangentPlane(:,2,iCell) = yHatPlane
end do
- end subroutine mpas_rbf_interp_initialize
+ end subroutine mpas_rbf_interp_initialize!}}}
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Purpose: Compute interpolation coefficients in 2D that can be used to
- ! reconstruct a given scalar function at varying locations. This is useful
- ! for finding the location on the the RBF reconstruction of a function
- ! (e.g., a height field) that minimizes the distance to a point in 3D space.
- ! The reconstruction is performed with basis functions that are RBFs and constant
- ! Input:
- ! pointCount - the number of "source" points and functionValues supplied
- ! coeffCount - the size of coefficients, must be at least pointCount + 1
- ! points - the location of the "source" points in the 2D space where the values of
- ! the function are known
- ! fieldValues - the values of the function of interest at the points
- ! alpha - a constant that give the characteristic length scale of the RBFs,
- ! should be on the order of the distance between points
- ! Output:
- ! coefficients - the coefficients needed to perform interpolation of the funciton
- ! at destination points yet to be specified
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine mpas_rbf_interp_loc_2D_sca_const_comp_coeffs(pointCount, coeffCount, &
+!***********************************************************************
+!
+! routine mpas_rbf_interp_loc_2D_sca_const_comp_coeffs
+!
+!> \brief MPAS 2D scalar constant interpolation coefficient routine
+!> \author Xylar Asay-Davis
+!> \date 03/28/13
+!> \version SVN:$Id$
+!> \details
+!> This routine computes interpolation coefficients in 2D that can be used to reconstruct a given scalar function at varying locations.
+!> This is useful for finding the location on the RBF reconstruction of a function (e.g. a heigh field) that minimizes the distantce
+!> to a point in 3D space. The reconstruction is performed with basis functions that are RBFs and constant.
+!> Input:
+!> pointCount - the number of "source" points and functionValues supplied
+!> coeffCount - the size of coefficients, must be at least pointCount + 1
+!> points - the location of the "source" points in the 2D space where the values of
+!> the function are known
+!> fieldValues - the values of the function of interest at the points
+!> alpha - a constant that give the characteristic length scale of the RBFs,
+!> should be on the order of the distance between points
+!> Output:
+!> coefficients - the coefficients needed to perform interpolation of the funciton
+!> at destination points yet to be specified
+!-----------------------------------------------------------------------
+ subroutine mpas_rbf_interp_loc_2D_sca_const_comp_coeffs(pointCount, coeffCount, &!{{{
points, fieldValues, alpha, coefficients)
- integer, intent(in) :: pointCount, coeffCount
- real(kind=RKIND), dimension(pointCount,2), intent(in) :: points
- real(kind=RKIND), dimension(pointCount), intent(in) :: fieldValues
- real(kind=RKIND), intent(in) :: alpha
- real(kind=RKIND), dimension(coeffCount), intent(out) :: coefficients
+ integer, intent(in) :: pointCount !< Input: Number of points
+ integer, intent(in) :: coeffCount !< Input: Number of coefficients
+ real(kind=RKIND), dimension(pointCount,2), intent(in) :: points !< Input: List of points
+ real(kind=RKIND), dimension(pointCount), intent(in) :: fieldValues !< Input: Value at points
+ real(kind=RKIND), intent(in) :: alpha !< Input: Charachteristic length scale of RBFs
+ real(kind=RKIND), dimension(coeffCount), intent(out) :: coefficients !< Output: List of coefficients
integer :: i, j, matrixSize
real(kind=RKIND), dimension(pointCount+1,pointCount+1) :: matrix
@@ -242,35 +263,44 @@
call mpas_legs(matrix(1:matrixSize,1:matrixSize), matrixSize, rhs(1:matrixSize), &
coefficients(1:matrixSize), pivotIndices(1:matrixSize))
- end subroutine mpas_rbf_interp_loc_2D_sca_const_comp_coeffs
+ end subroutine mpas_rbf_interp_loc_2D_sca_const_comp_coeffs!}}}
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Purpose: Compute interpolation coefficients in 2D that can be used to
- ! reconstruct a given scalar function at varying locations. This is useful
- ! for finding the location on the the RBF reconstruction of a function
- ! (e.g., a height field) that minimizes the distance to a point in 3D space.
- ! The reconstruction is performed with basis functions that are RBFs plus constant
- ! and linear
- ! Input:
- ! pointCount - the number of "source" points and functionValues supplied
- ! coeffCount - the size of coefficients, must be at least pointCount + 3
- ! points - the location of the "source" points in the 2D space where the values of
- ! the function are known
- ! fieldValues - the values of the function of interest at the points
- ! alpha - a constant that give the characteristic length scale of the RBFs,
- ! should be on the order of the distance between points
- ! Output:
- ! coefficients - the coefficients needed to perform interpolation of the funciton
- ! at destination points yet to be specified
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine mpas_rbf_interp_loc_2D_sca_lin_comp_coeffs(pointCount, coeffCount, &
+!***********************************************************************
+!
+! routine mpas_rbf_interp_loc_2D_sca_lin_comp_coeffs
+!
+!> \brief MPAS 2D scalar linear interpolation coefficient routine
+!> \author Xylar Asay-Davis
+!> \date 03/28/13
+!> \version SVN:$Id$
+!> \details
+!> This routine computes interpolation coefficients in 2D that can be used to
+!> reconstruct a given scalar function at varying locations. This is useful
+!> for finding the location on the the RBF reconstruction of a function
+!> (e.g., a height field) that minimizes the distance to a point in 3D space.
+!> The reconstruction is performed with basis functions that are RBFs plus constant
+!> and linear
+!> Input:
+!> pointCount - the number of "source" points and functionValues supplied
+!> coeffCount - the size of coefficients, must be at least pointCount + 3
+!> points - the location of the "source" points in the 2D space where the values of
+!> the function are known
+!> fieldValues - the values of the function of interest at the points
+!> alpha - a constant that give the characteristic length scale of the RBFs,
+!> should be on the order of the distance between points
+!> Output:
+!> coefficients - the coefficients needed to perform interpolation of the funciton
+!> at destination points yet to be specified
+!-----------------------------------------------------------------------
+ subroutine mpas_rbf_interp_loc_2D_sca_lin_comp_coeffs(pointCount, coeffCount, &!{{{
points, fieldValues, alpha, coefficients)
- integer, intent(in) :: pointCount, coeffCount
- real(kind=RKIND), dimension(pointCount,2), intent(in) :: points
- real(kind=RKIND), dimension(pointCount), intent(in) :: fieldValues
- real(kind=RKIND), intent(in) :: alpha
- real(kind=RKIND), dimension(coeffCount), intent(out) :: coefficients
+ integer, intent(in) :: pointCount !< Input: Number of points
+ integer, intent(in) :: coeffCount !< Input: Number of coefficients
+ real(kind=RKIND), dimension(pointCount,2), intent(in) :: points !< Input: List of points
+ real(kind=RKIND), dimension(pointCount), intent(in) :: fieldValues !< Input: List of values at points
+ real(kind=RKIND), intent(in) :: alpha !< Input: Characteristic length scale for RBFs
+ real(kind=RKIND), dimension(coeffCount), intent(out) :: coefficients !< Output: List of coefficients
integer :: i, j, matrixSize
real(kind=RKIND), dimension(pointCount+3,pointCount+3) :: matrix
@@ -301,43 +331,53 @@
call mpas_legs(matrix(1:matrixSize,1:matrixSize), matrixSize, rhs(1:matrixSize), &
coefficients(1:matrixSize), pivotIndices(1:matrixSize))
- end subroutine mpas_rbf_interp_loc_2D_sca_lin_comp_coeffs
+ end subroutine mpas_rbf_interp_loc_2D_sca_lin_comp_coeffs!}}}
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Purpose: Evalute a scalar function in 2D using coefficients computed in
- ! rbfInterp_loc_2D_sca_const_compCoeffs. This
- ! function can be called repeatedly with different destination points
- ! to quickly evaluate the interpolating function using the same
- ! coefficients. This is useful for finding the location on the the
- ! RBF reconstruction of a function (e.g., a height field) that minimizes
- ! the distance to a point in 3D space. The reconstruction is performed
- ! with basis functions that are RBFs and constant
- ! Input:
- ! fieldCount - the number fields to be evaluated. This is useful for reconstructing,
- ! for example, the x-, y- and z-components of a vector field at the same
- ! point in 2D
- ! coeffCount - the size of coefficients, must be at least pointCount + 1
- ! pointCount - the number of "source" points and functionValues supplied
- ! coefficients - the coefficients needed to perform interpolation of the funciton
- ! at the evaluationPoint
- ! evaluationPoint - the point in 2D where the function is to be reconstructed
- ! points - the location of the "source" points in the 2D space where the values of
- ! the function are known
- ! alpha - a constant that give the characteristic length scale of the RBFs,
- ! should be on the order of the distance between points
- ! Output:
- ! derivs - the value of the function, the 2 components of its Jacobian and
- ! the 3 unique components of its Hessian at the evaluationPoint
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine mpas_rbf_interp_loc_2D_sca_const_eval_with_derivs(fieldCount, coeffCount, &
+!***********************************************************************
+!
+! routine mpas_rbf_interp_loc_2D_sca_const_eval_with_derivs
+!
+!> \brief MPAS 2D scalar constant evaulation routine
+!> \author Xylar Asay-Davis
+!> \date 03/28/13
+!> \version SVN:$Id$
+!> \details
+!> This routine evalutes a scalar function in 2D using coefficients computed in
+!> rbfInterp_loc_2D_sca_const_compCoeffs. This
+!> function can be called repeatedly with different destination points
+!> to quickly evaluate the interpolating function using the same
+!> coefficients. This is useful for finding the location on the the
+!> RBF reconstruction of a function (e.g., a height field) that minimizes
+!> the distance to a point in 3D space. The reconstruction is performed
+!> with basis functions that are RBFs and constant
+!> Input:
+!> fieldCount - the number fields to be evaluated. This is useful for reconstructing,
+!> for example, the x-, y- and z-components of a vector field at the same
+!> point in 2D
+!> coeffCount - the size of coefficients, must be at least pointCount + 1
+!> pointCount - the number of "source" points and functionValues supplied
+!> coefficients - the coefficients needed to perform interpolation of the funciton
+!> at the evaluationPoint
+!> evaluationPoint - the point in 2D where the function is to be reconstructed
+!> points - the location of the "source" points in the 2D space where the values of
+!> the function are known
+!> alpha - a constant that give the characteristic length scale of the RBFs,
+!> should be on the order of the distance between points
+!> Output:
+!> derivs - the value of the function, the 2 components of its Jacobian and
+!> the 3 unique components of its Hessian at the evaluationPoint
+!-----------------------------------------------------------------------
+ subroutine mpas_rbf_interp_loc_2D_sca_const_eval_with_derivs(fieldCount, coeffCount, &!{{{
pointCount, coefficients, evaluationPoint, points, alpha, derivs)
- integer, intent(in) :: fieldCount, coeffCount, pointCount
- real(kind=RKIND), dimension(coeffCount, fieldCount), intent(in) :: coefficients
- real(kind=RKIND), dimension(2), intent(in) :: evaluationPoint
- real(kind=RKIND), dimension(pointCount,2), intent(in) :: points
- real(kind=RKIND), intent(in) :: alpha
+ integer, intent(in) :: fieldCount !< Input: Number of fields
+ integer, intent(in) :: coeffCount !< Input: Number of coefficients
+ integer, intent(in) :: pointCount !< Input: Number of points
+ real(kind=RKIND), dimension(coeffCount, fieldCount), intent(in) :: coefficients !< Input: List of coefficients
+ real(kind=RKIND), dimension(2), intent(in) :: evaluationPoint !< Input: Location for evaluation
+ real(kind=RKIND), dimension(pointCount,2), intent(in) :: points !< Input: List of points
+ real(kind=RKIND), intent(in) :: alpha !< Input: Characteristic length scale for RBFs
- real(kind=RKIND), dimension(6,fieldCount), intent(out) :: derivs
+ real(kind=RKIND), dimension(6,fieldCount), intent(out) :: derivs !< Output: List of derivatives
integer :: pointIndex
real(kind=RKIND) :: x, y, rSquared, rbfValue, rbfDerivOverR, rbfSecondDeriv
@@ -369,43 +409,53 @@
end if
end do
derivs(1,:) = derivs(1,:) + coefficients(pointCount+1,:)
- end subroutine mpas_rbf_interp_loc_2D_sca_const_eval_with_derivs
+ end subroutine mpas_rbf_interp_loc_2D_sca_const_eval_with_derivs!}}}
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Purpose: Evalute a scalar function in 2D using coefficients computed in
- ! rbfInterp_loc_2D_sca_const_compCoeffs. This
- ! function can be called repeatedly with different destination points
- ! to quickly evaluate the interpolating function using the same
- ! coefficients. This is useful for finding the location on the the
- ! RBF reconstruction of a function (e.g., a height field) that minimizes
- ! the distance to a point in 3D space. The reconstruction is performed
- ! with basis functions that are RBFs, constant and linear
- ! Input:
- ! fieldCount - the number fields to be evaluated. This is useful for reconstructing,
- ! for example, the x-, y- and z-components of a vector field at the same
- ! point in 2D
- ! coeffCount - the size of coefficients, must be at least pointCount + 1
- ! pointCount - the number of "source" points and functionValues supplied
- ! coefficients - the coefficients needed to perform interpolation of the funciton
- ! at the evaluationPoint
- ! evaluationPoint - the point in 2D where the function is to be reconstructed
- ! points - the location of the "source" points in the 2D space where the values of
- ! the function are known
- ! alpha - a constant that give the characteristic length scale of the RBFs,
- ! should be on the order of the distance between points
- ! Output:
- ! derivs - the value of the function, the 2 components of its Jacobian and
- ! the 3 unique components of its Hessian at the evaluationPoint
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine mpas_rbf_interp_loc_2D_sca_lin_eval_with_derivs(fieldCount, coeffCount, &
+!***********************************************************************
+!
+! routine mpas_rbf_interp_loc_2D_sca_lin_eval_with_derivs
+!
+!> \brief MPAS 2D scalar linear evaluation routine
+!> \author Xylar Asay-Davis
+!> \date 03/28/13
+!> \version SVN:$Id$
+!> \details
+!> This routine evalutes a scalar function in 2D using coefficients computed in
+!> rbfInterp_loc_2D_sca_const_compCoeffs. This
+!> function can be called repeatedly with different destination points
+!> to quickly evaluate the interpolating function using the same
+!> coefficients. This is useful for finding the location on the the
+!> RBF reconstruction of a function (e.g., a height field) that minimizes
+!> the distance to a point in 3D space. The reconstruction is performed
+!> with basis functions that are RBFs, constant and linear
+!> Input:
+!> fieldCount - the number fields to be evaluated. This is useful for reconstructing,
+!> for example, the x-, y- and z-components of a vector field at the same
+!> point in 2D
+!> coeffCount - the size of coefficients, must be at least pointCount + 1
+!> pointCount - the number of "source" points and functionValues supplied
+!> coefficients - the coefficients needed to perform interpolation of the funciton
+!> at the evaluationPoint
+!> evaluationPoint - the point in 2D where the function is to be reconstructed
+!> points - the location of the "source" points in the 2D space where the values of
+!> the function are known
+!> alpha - a constant that give the characteristic length scale of the RBFs,
+!> should be on the order of the distance between points
+!> Output:
+!> derivs - the value of the function, the 2 components of its Jacobian and
+!> the 3 unique components of its Hessian at the evaluationPoint
+!-----------------------------------------------------------------------
+ subroutine mpas_rbf_interp_loc_2D_sca_lin_eval_with_derivs(fieldCount, coeffCount, &!{{{
pointCount, coefficients, evaluationPoint, points, alpha, derivs)
- integer, intent(in) :: fieldCount, coeffCount, pointCount
- real(kind=RKIND), dimension(coeffCount, fieldCount), intent(in) :: coefficients
- real(kind=RKIND), dimension(2), intent(in) :: evaluationPoint
- real(kind=RKIND), dimension(pointCount,2), intent(in) :: points
- real(kind=RKIND), intent(in) :: alpha
+ integer, intent(in) :: fieldCount !< Input: Number of fields
+ integer, intent(in) :: coeffCount !< Input: Number of coefficients
+ integer, intent(in) :: pointCount !< Input: Number of points
+ real(kind=RKIND), dimension(coeffCount, fieldCount), intent(in) :: coefficients !< Input: List of coefficients
+ real(kind=RKIND), dimension(2), intent(in) :: evaluationPoint !< Input: Point for evaluation
+ real(kind=RKIND), dimension(pointCount,2), intent(in) :: points !< Input: List of points
+ real(kind=RKIND), intent(in) :: alpha !< Input: Characteristic length scale of RBFs
- real(kind=RKIND), dimension(6,fieldCount), intent(out) :: derivs
+ real(kind=RKIND), dimension(6,fieldCount), intent(out) :: derivs !< Output: Derivatives
integer :: pointIndex
real(kind=RKIND) :: x, y, rSquared, rbfValue, rbfDerivOverR, rbfSecondDeriv
@@ -442,39 +492,47 @@
derivs(2,:) = derivs(2,:) + coefficients(pointCount+2,:)
derivs(3,:) = derivs(3,:) + coefficients(pointCount+3,:)
- end subroutine mpas_rbf_interp_loc_2D_sca_lin_eval_with_derivs
+ end subroutine mpas_rbf_interp_loc_2D_sca_lin_eval_with_derivs!}}}
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Purpose: Compute interpolation coefficients in 3D that can be used to
- ! interpolate a number of scalar functions at a given locations. This is useful
- ! if the interpolation location does not change with time, or if several
- ! fields are to be interpolated at a given time step. (If both the fields
- ! and the interpolation locations vary with time, there is no clear advantage in
- ! using either this method or the method for 2D interpoaltion above; for simplicity
- ! and because we foresee more uses for the method of this subroutine, we have not
- ! implemented a 3D version of the fixed field, variable interpolation location method
- ! as we have in 2D.) Coefficients are produced for handling Dirichlet boundary
- ! conditions (or no boundaries). The interpolation is performed with basis functions
- ! that are RBFs plus a constant.
- ! Input:
- ! pointCount - the number of "source" points and functionValues supplied
- ! sourcePoints - the location of the "source" points in the 3D space where the values of
- ! the function are known
- ! destinationPoint - the point where the interpolation will be performed
- ! alpha - a constant that give the characteristic length scale of the RBFs,
- ! should be on the order of the distance between points
- ! Output:
- ! coefficients - the coefficients used to interpolate a function with Dirichlet
- ! boundary conditions to the specified destinationPoint
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine mpas_rbf_interp_func_3D_sca_const_dir_comp_coeffs( &
+!***********************************************************************
+!
+! routine mpas_rbf_interp_func_3D_sca_const_dir_comp_coeffs
+!
+!> \brief MPAS 3D scalar constant coefficients routine
+!> \author Xylar Asay-Davis
+!> \date 03/28/13
+!> \version SVN:$Id$
+!> \details
+!> This routine computes interpolation coefficients in 3D that can be used to
+!> interpolate a number of scalar functions at a given locations. This is useful
+!> if the interpolation location does not change with time, or if several
+!> fields are to be interpolated at a given time step. (If both the fields
+!> and the interpolation locations vary with time, there is no clear advantage in
+!> using either this method or the method for 2D interpoaltion above; for simplicity
+!> and because we foresee more uses for the method of this subroutine, we have not
+!> implemented a 3D version of the fixed field, variable interpolation location method
+!> as we have in 2D.) Coefficients are produced for handling Dirichlet boundary
+!> conditions (or no boundaries). The interpolation is performed with basis functions
+!> that are RBFs plus a constant.
+!> Input:
+!> pointCount - the number of "source" points and functionValues supplied
+!> sourcePoints - the location of the "source" points in the 3D space where the values of
+!> the function are known
+!> destinationPoint - the point where the interpolation will be performed
+!> alpha - a constant that give the characteristic length scale of the RBFs,
+!> should be on the order of the distance between points
+!> Output:
+!> coefficients - the coefficients used to interpolate a function with Dirichlet
+!> boundary conditions to the specified destinationPoint
+!-----------------------------------------------------------------------
+ subroutine mpas_rbf_interp_func_3D_sca_const_dir_comp_coeffs( &!{{{
pointCount, sourcePoints, destinationPoint, alpha, coefficients)
- integer, intent(in) :: pointCount
- real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints
- real(kind=RKIND), dimension(3), intent(in) :: destinationPoint
- real(kind=RKIND), intent(in) :: alpha
- real(kind=RKIND), dimension(pointCount), intent(out) :: coefficients
+ integer, intent(in) :: pointCount !< Input: Number of points
+ real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints !< Input: List of source points
+ real(kind=RKIND), dimension(3), intent(in) :: destinationPoint !< Input: List of destination points
+ real(kind=RKIND), intent(in) :: alpha !< Input: Characteristic length scale of RBFs
+ real(kind=RKIND), dimension(pointCount), intent(out) :: coefficients !< Output: List of coefficients
integer :: i, j
integer :: matrixSize
@@ -513,46 +571,54 @@
deallocate(coeffs)
deallocate(pivotIndices)
- end subroutine mpas_rbf_interp_func_3D_sca_const_dir_comp_coeffs
+ end subroutine mpas_rbf_interp_func_3D_sca_const_dir_comp_coeffs!}}}
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Purpose: Compute interpolation coefficients in a plane in 3D that can be used to
- ! interpolate a number of scalar functions at a given locations. This is useful
- ! if the interpolation location does not change with time, or if several
- ! fields are to be interpolated at a given time step. (If both the fields
- ! and the interpolation locations vary with time, there is no clear advantage in
- ! using either this method or the method for 2D interpoaltion above; for simplicity
- ! and because we foresee more uses for the method of this subroutine, we have not
- ! implemented a 3D version of the fixed field, variable interpolation location method
- ! as we have in 2D.) Coefficients are produced for handling both Dirichlet (or no)
- ! boundary conditions. The interpolation is performed with basis functions that are
- ! RBFs plus constant and linear. All points are projected into the plane given by the
- ! planeBasisVectors.
- ! Input:
- ! pointCount - the number of "source" points and functionValues supplied
- ! sourcePoints - the location of the "source" points in the 3D space where the values of
- ! the function are known. The points will be projected into the plane given by
- ! planeBasisVectors
- ! destinationPoint - the point in 3D where the interpolation will be performed. The
- ! destinationPoint will be projected into the plane given by planeBasisVectors.
- ! alpha - a constant that give the characteristic length scale of the RBFs,
- ! should be on the order of the distance between points
- ! planeBasisVectors - the basis fectors for the plane where interpolation is performed.
- ! All points are projected into this plane.
- ! Output:
- ! coefficients - the coefficients used to interpolate a function with Dirichlet
- ! boundary conditions to the specified destinationPoint
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine mpas_rbf_interp_func_3D_plane_sca_lin_dir_comp_coeffs( &
+!***********************************************************************
+!
+! routine mpas_rbf_interp_func_3D_plane_sca_lin_dir_comp_coeffs
+!
+!> \brief MPAS 3D planar scalar linear coefficients routine
+!> \author Xylar Asay-Davis
+!> \date 03/28/13
+!> \version SVN:$Id$
+!> \details
+!> This routine computes interpolation coefficients in a plane in 3D that can be used to
+!> interpolate a number of scalar functions at a given locations. This is useful
+!> if the interpolation location does not change with time, or if several
+!> fields are to be interpolated at a given time step. (If both the fields
+!> and the interpolation locations vary with time, there is no clear advantage in
+!> using either this method or the method for 2D interpoaltion above; for simplicity
+!> and because we foresee more uses for the method of this subroutine, we have not
+!> implemented a 3D version of the fixed field, variable interpolation location method
+!> as we have in 2D.) Coefficients are produced for handling both Dirichlet (or no)
+!> boundary conditions. The interpolation is performed with basis functions that are
+!> RBFs plus constant and linear. All points are projected into the plane given by the
+!> planeBasisVectors.
+!> Input:
+!> pointCount - the number of "source" points and functionValues supplied
+!> sourcePoints - the location of the "source" points in the 3D space where the values of
+!> the function are known. The points will be projected into the plane given by
+!> planeBasisVectors
+!> destinationPoint - the point in 3D where the interpolation will be performed. The
+!> destinationPoint will be projected into the plane given by planeBasisVectors.
+!> alpha - a constant that give the characteristic length scale of the RBFs,
+!> should be on the order of the distance between points
+!> planeBasisVectors - the basis fectors for the plane where interpolation is performed.
+!> All points are projected into this plane.
+!> Output:
+!> coefficients - the coefficients used to interpolate a function with Dirichlet
+!> boundary conditions to the specified destinationPoint
+!-----------------------------------------------------------------------
+ subroutine mpas_rbf_interp_func_3D_plane_sca_lin_dir_comp_coeffs( &!{{{
pointCount, sourcePoints, destinationPoint, &
alpha, planeBasisVectors, coefficients)
- integer, intent(in) :: pointCount
- real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints
- real(kind=RKIND), dimension(3), intent(in) :: destinationPoint
- real(kind=RKIND), intent(in) :: alpha
- real(kind=RKIND), dimension(2,3) :: planeBasisVectors
- real(kind=RKIND), dimension(pointCount), intent(out) :: coefficients
+ integer, intent(in) :: pointCount !< Input: Number of points
+ real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints !< Input: List of source points
+ real(kind=RKIND), dimension(3), intent(in) :: destinationPoint !< Input: Destination point
+ real(kind=RKIND), intent(in) :: alpha !< Input: Characteristic length scale of RBFs
+ real(kind=RKIND), dimension(2,3) :: planeBasisVectors !< Input: Basis vectors for the interpolation plane
+ real(kind=RKIND), dimension(pointCount), intent(out) :: coefficients !< Output: List of coefficients
integer :: i, j
integer :: matrixSize
@@ -596,39 +662,47 @@
deallocate(coeffs)
deallocate(pivotIndices)
- end subroutine mpas_rbf_interp_func_3D_plane_sca_lin_dir_comp_coeffs
+ end subroutine mpas_rbf_interp_func_3D_plane_sca_lin_dir_comp_coeffs!}}}
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Purpose: Compute interpolation coefficients in 3D that can be used to
- ! interpolate a number of scalar functions at a given locations. This is useful
- ! if the interpolation location does not change with time, or if several
- ! fields are to be interpolated at a given time step. (If both the fields
- ! and the interpolation locations vary with time, there is no clear advantage in
- ! using either this method or the method for 2D interpoaltion above; for simplicity
- ! and because we foresee more uses for the method of this subroutine, we have not
- ! implemented a 3D version of the fixed field, variable interpolation location method
- ! as we have in 2D.) Coefficients are produced for handling both Dirichlet (or no)
- ! boundary conditions. The interpolation is performed with basis functions that are
- ! RBFs plus constant and linear.
- ! Input:
- ! pointCount - the number of "source" points and functionValues supplied
- ! sourcePoints - the location of the "source" points in the 3D space where the values of
- ! the function are known
- ! destinationPoint - the point where the interpolation will be performed
- ! alpha - a constant that give the characteristic length scale of the RBFs,
- ! should be on the order of the distance between points
- ! Output:
- ! coefficients - the coefficients used to interpolate a function with Dirichlet
- ! boundary conditions to the specified destinationPoint
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine mpas_rbf_interp_func_3D_sca_lin_dir_comp_coeffs(pointCount, &
+!***********************************************************************
+!
+! routine mpas_rbf_interp_func_3D_sca_lin_dir_comp_coeffs
+!
+!> \brief MPAS 3D scalar linear coefficients routine
+!> \author Xylar Asay-Davis
+!> \date 03/28/13
+!> \version SVN:$Id$
+!> \details
+!> This routine computes interpolation coefficients in 3D that can be used to
+!> interpolate a number of scalar functions at a given locations. This is useful
+!> if the interpolation location does not change with time, or if several
+!> fields are to be interpolated at a given time step. (If both the fields
+!> and the interpolation locations vary with time, there is no clear advantage in
+!> using either this method or the method for 2D interpoaltion above; for simplicity
+!> and because we foresee more uses for the method of this subroutine, we have not
+!> implemented a 3D version of the fixed field, variable interpolation location method
+!> as we have in 2D.) Coefficients are produced for handling both Dirichlet (or no)
+!> boundary conditions. The interpolation is performed with basis functions that are
+!> RBFs plus constant and linear.
+!> Input:
+!> pointCount - the number of "source" points and functionValues supplied
+!> sourcePoints - the location of the "source" points in the 3D space where the values of
+!> the function are known
+!> destinationPoint - the point where the interpolation will be performed
+!> alpha - a constant that give the characteristic length scale of the RBFs,
+!> should be on the order of the distance between points
+!> Output:
+!> coefficients - the coefficients used to interpolate a function with Dirichlet
+!> boundary conditions to the specified destinationPoint
+!-----------------------------------------------------------------------
+ subroutine mpas_rbf_interp_func_3D_sca_lin_dir_comp_coeffs(pointCount, &!{{{
sourcePoints, destinationPoint, alpha, coefficients)
- integer, intent(in) :: pointCount
- real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints
- real(kind=RKIND), dimension(3), intent(in) :: destinationPoint
- real(kind=RKIND), intent(in) :: alpha
- real(kind=RKIND), dimension(pointCount), intent(out) :: coefficients
+ integer, intent(in) :: pointCount !< Input: Number of points
+ real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints !< Input: List of source points
+ real(kind=RKIND), dimension(3), intent(in) :: destinationPoint !< Input: Destination point
+ real(kind=RKIND), intent(in) :: alpha !< Input: Characteristic length scale for RBFs
+ real(kind=RKIND), dimension(pointCount), intent(out) :: coefficients !< Output: List of coefficients
integer :: i, j
integer :: matrixSize
@@ -670,52 +744,60 @@
deallocate(coeffs)
deallocate(pivotIndices)
- end subroutine mpas_rbf_interp_func_3D_sca_lin_dir_comp_coeffs
+ end subroutine mpas_rbf_interp_func_3D_sca_lin_dir_comp_coeffs!}}}
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Purpose: Compute interpolation coefficients in 3D that can be used to
- ! interpolate a number of scalar functions at a given locations. This is useful
- ! if the interpolation location does not change with time, or if several
- ! fields are to be interpolated at a given time step. (If both the fields
- ! and the interpolation locations vary with time, there is no clear advantage in
- ! using either this method or the method for 2D interpoaltion above; for simplicity
- ! and because we foresee more uses for the method of this subroutine, we have not
- ! implemented a 3D version of the fixed field, variable interpolation location method
- ! as we have in 2D.) Coefficients are produced for handling both Dirichlet and Neumann
- ! boundary conditions. The interpolation is performed with basis functions that are
- ! RBFs plus a constant.
- ! Input:
- ! pointCount - the number of "source" points and functionValues supplied
- ! sourcePoints - the location of the "source" points in the 3D space where the values of
- ! the function are known
- ! isInterface - a logical array indicating which of the source points (if any) are at
- ! at the domain interface. These points and their normals will be used to compute the
- ! neumannCoefficients below
- ! interfaceNormals - a 3D normal vector for each sourcePoint. These vectors are only used
- ! at points where isInterface == .true., and can take arbitrary values elsewehere. The
- ! normal vector is used to compute coefficients for the normal derivative of the
- ! interpolating function in order to impose the Neumann Boundary condition
- ! destinationPoint - the point where the interpolation will be performed
- ! alpha - a constant that give the characteristic length scale of the RBFs,
- ! should be on the order of the distance between points
- ! Output:
- ! dirichletCoefficients - the coefficients used to interpolate a function with Dirichlet
- ! boundary conditions to the specified destinationPoint
- ! neumannCoefficients - the coefficients used to interpolate a function with Neumann
- ! boundary conditions to the specified destinationPoint
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine mpas_rbf_interp_func_3D_sca_const_dir_neu_comp_coeffs( &
+!***********************************************************************
+!
+! routine mpas_rbf_interp_func_3D_sca_const_dir_neu_comp_coeffs
+!
+!> \brief MPAS 3D scalar constant Dirichlet and Neumann coefficients routine
+!> \author Xylar Asay-Davis
+!> \date 03/28/13
+!> \version SVN:$Id$
+!> \details
+!> This routine computes interpolation coefficients in 3D that can be used to
+!> interpolate a number of scalar functions at a given locations. This is useful
+!> if the interpolation location does not change with time, or if several
+!> fields are to be interpolated at a given time step. (If both the fields
+!> and the interpolation locations vary with time, there is no clear advantage in
+!> using either this method or the method for 2D interpoaltion above; for simplicity
+!> and because we foresee more uses for the method of this subroutine, we have not
+!> implemented a 3D version of the fixed field, variable interpolation location method
+!> as we have in 2D.) Coefficients are produced for handling both Dirichlet and Neumann
+!> boundary conditions. The interpolation is performed with basis functions that are
+!> RBFs plus a constant.
+!> Input:
+!> pointCount - the number of "source" points and functionValues supplied
+!> sourcePoints - the location of the "source" points in the 3D space where the values of
+!> the function are known
+!> isInterface - a logical array indicating which of the source points (if any) are at
+!> at the domain interface. These points and their normals will be used to compute the
+!> neumannCoefficients below
+!> interfaceNormals - a 3D normal vector for each sourcePoint. These vectors are only used
+!> at points where isInterface == .true., and can take arbitrary values elsewehere. The
+!> normal vector is used to compute coefficients for the normal derivative of the
+!> interpolating function in order to impose the Neumann Boundary condition
+!> destinationPoint - the point where the interpolation will be performed
+!> alpha - a constant that give the characteristic length scale of the RBFs,
+!> should be on the order of the distance between points
+!> Output:
+!> dirichletCoefficients - the coefficients used to interpolate a function with Dirichlet
+!> boundary conditions to the specified destinationPoint
+!> neumannCoefficients - the coefficients used to interpolate a function with Neumann
+!> boundary conditions to the specified destinationPoint
+!-----------------------------------------------------------------------
+ subroutine mpas_rbf_interp_func_3D_sca_const_dir_neu_comp_coeffs( &!{{{
pointCount, sourcePoints, isInterface, interfaceNormals, destinationPoint, &
alpha, dirichletCoefficients, neumannCoefficients)
- integer, intent(in) :: pointCount
- real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints
- logical, dimension(pointCount), intent(in) :: isInterface
- real(kind=RKIND), dimension(pointCount,3), intent(in) :: interfaceNormals
- real(kind=RKIND), dimension(3), intent(in) :: destinationPoint
- real(kind=RKIND), intent(in) :: alpha
- real(kind=RKIND), dimension(pointCount), intent(out) :: &
- dirichletCoefficients, neumannCoefficients
+ integer, intent(in) :: pointCount !< Input: Number of points
+ real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints !< Input: List of source points
+ logical, dimension(pointCount), intent(in) :: isInterface !< Input: Logicals determining if a source point is at an interface
+ real(kind=RKIND), dimension(pointCount,3), intent(in) :: interfaceNormals !< Input: Normal vector at interface for each source point
+ real(kind=RKIND), dimension(3), intent(in) :: destinationPoint !< Input: Destination point
+ real(kind=RKIND), intent(in) :: alpha !< Input: Characteristic length scale of RBFs
+ real(kind=RKIND), dimension(pointCount), intent(out) :: dirichletCoefficients !< Output: Coefficients with Dirichlet BCs
+ real(kind=RKIND), dimension(pointCount), intent(out) :: neumannCoefficients !< Output: Coefficients with Neumann BCs
integer :: i, j
integer :: matrixSize
@@ -772,58 +854,66 @@
deallocate(coeffs)
deallocate(pivotIndices)
- end subroutine mpas_rbf_interp_func_3D_sca_const_dir_neu_comp_coeffs
+ end subroutine mpas_rbf_interp_func_3D_sca_const_dir_neu_comp_coeffs!}}}
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Purpose: Compute interpolation coefficients in a plane in 3D that can be used to
- ! interpolate a number of scalar functions at a given locations. This is useful
- ! if the interpolation location does not change with time, or if several
- ! fields are to be interpolated at a given time step. (If both the fields
- ! and the interpolation locations vary with time, there is no clear advantage in
- ! using either this method or the method for 2D interpoaltion above; for simplicity
- ! and because we foresee more uses for the method of this subroutine, we have not
- ! implemented a 3D version of the fixed field, variable interpolation location method
- ! as we have in 2D.) Coefficients are produced for handling both Dirichlet and Neumann
- ! boundary conditions. The interpolation is performed with basis functions that are
- ! RBFs plus constant and linear. All points are projected into the plane given by the
- ! planeBasisVectors.
- ! Input:
- ! pointCount - the number of "source" points and functionValues supplied
- ! sourcePoints - the location of the "source" points in the 3D space where the values of
- ! the function are known. The sourcePoints will be projected into the plane given by
- ! planeBasisVectors
- ! isInterface - a logical array indicating which of the source points (if any) are at
- ! at the domain interface. These points and their normals will be used to compute the
- ! neumannCoefficients below
- ! interfaceNormals - a 3D normal vector for each sourcePoint. These vectors are only used
- ! at points where isInterface == .true., and can take arbitrary values elsewehere. The
- ! normal vector is used to compute coefficients for the normal derivative of the
- ! interpolating function in order to impose the Neumann Boundary condition
- ! destinationPoint - the point in 3D where the interpolation will be performed. The
- ! destinationPoint will be projected into the plane given by planeBasisVectors.
- ! alpha - a constant that give the characteristic length scale of the RBFs,
- ! should be on the order of the distance between points
- ! planeBasisVectors - the basis fectors for the plane where interpolation is performed.
- ! All points are projected into this plane.
- ! Output:
- ! dirichletCoefficients - the coefficients used to interpolate a function with Dirichlet
- ! boundary conditions to the specified destinationPoint
- ! neumannCoefficients - the coefficients used to interpolate a function with Neumann
- ! boundary conditions to the specified destinationPoint
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine mpas_rbf_interp_func_3D_plane_sca_lin_dir_neu_comp_coeffs( &
+!***********************************************************************
+!
+! routine mpas_rbf_interp_func_3D_plane_sca_lin_dir_neu_comp_coeffs
+!
+!> \brief MPAS 3D scalar planar linear Dirichlet and Neumann coefficients routine
+!> \author Xylar Asay-Davis
+!> \date 03/28/13
+!> \version SVN:$Id$
+!> \details
+!> This routine computes interpolation coefficients in a plane in 3D that can be used to
+!> interpolate a number of scalar functions at a given locations. This is useful
+!> if the interpolation location does not change with time, or if several
+!> fields are to be interpolated at a given time step. (If both the fields
+!> and the interpolation locations vary with time, there is no clear advantage in
+!> using either this method or the method for 2D interpoaltion above; for simplicity
+!> and because we foresee more uses for the method of this subroutine, we have not
+!> implemented a 3D version of the fixed field, variable interpolation location method
+!> as we have in 2D.) Coefficients are produced for handling both Dirichlet and Neumann
+!> boundary conditions. The interpolation is performed with basis functions that are
+!> RBFs plus constant and linear. All points are projected into the plane given by the
+!> planeBasisVectors.
+!> Input:
+!> pointCount - the number of "source" points and functionValues supplied
+!> sourcePoints - the location of the "source" points in the 3D space where the values of
+!> the function are known. The sourcePoints will be projected into the plane given by
+!> planeBasisVectors
+!> isInterface - a logical array indicating which of the source points (if any) are at
+!> at the domain interface. These points and their normals will be used to compute the
+!> neumannCoefficients below
+!> interfaceNormals - a 3D normal vector for each sourcePoint. These vectors are only used
+!> at points where isInterface == .true., and can take arbitrary values elsewehere. The
+!> normal vector is used to compute coefficients for the normal derivative of the
+!> interpolating function in order to impose the Neumann Boundary condition
+!> destinationPoint - the point in 3D where the interpolation will be performed. The
+!> destinationPoint will be projected into the plane given by planeBasisVectors.
+!> alpha - a constant that give the characteristic length scale of the RBFs,
+!> should be on the order of the distance between points
+!> planeBasisVectors - the basis fectors for the plane where interpolation is performed.
+!> All points are projected into this plane.
+!> Output:
+!> dirichletCoefficients - the coefficients used to interpolate a function with Dirichlet
+!> boundary conditions to the specified destinationPoint
+!> neumannCoefficients - the coefficients used to interpolate a function with Neumann
+!> boundary conditions to the specified destinationPoint
+!-----------------------------------------------------------------------
+ subroutine mpas_rbf_interp_func_3D_plane_sca_lin_dir_neu_comp_coeffs( &!{{{
pointCount, sourcePoints, isInterface, interfaceNormals, destinationPoint, &
alpha, planeBasisVectors, dirichletCoefficients, neumannCoefficients)
- integer, intent(in) :: pointCount
- real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints
- logical, dimension(pointCount), intent(in) :: isInterface
- real(kind=RKIND), dimension(pointCount,3), intent(in) :: interfaceNormals
- real(kind=RKIND), dimension(3), intent(in) :: destinationPoint
- real(kind=RKIND), intent(in) :: alpha
- real(kind=RKIND), dimension(2,3) :: planeBasisVectors
- real(kind=RKIND), dimension(pointCount), intent(out) :: &
- dirichletCoefficients, neumannCoefficients
+ integer, intent(in) :: pointCount !< Input: Number of points
+ real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints !< Input: List of points
+ logical, dimension(pointCount), intent(in) :: isInterface !< Input: List of logicals determining if point is at an interface
+ real(kind=RKIND), dimension(pointCount,3), intent(in) :: interfaceNormals !< Input: List of interface normals
+ real(kind=RKIND), dimension(3), intent(in) :: destinationPoint !< Input: Destination point
+ real(kind=RKIND), intent(in) :: alpha !< Input: Characteristic length scale of RBFs
+ real(kind=RKIND), dimension(2,3) :: planeBasisVectors !< Input: Basis vectors for interpolation plane
+ real(kind=RKIND), dimension(pointCount), intent(out) :: dirichletCoefficients !< Output: List of Dirichlet coefficients
+ real(kind=RKIND), dimension(pointCount), intent(out) :: neumannCoefficients !< Output: List of Neumann coefficients
integer :: i, j
integer :: matrixSize
@@ -889,52 +979,60 @@
deallocate(coeffs)
deallocate(pivotIndices)
- end subroutine mpas_rbf_interp_func_3D_plane_sca_lin_dir_neu_comp_coeffs
+ end subroutine mpas_rbf_interp_func_3D_plane_sca_lin_dir_neu_comp_coeffs!}}}
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Purpose: Compute interpolation coefficients in 3D that can be used to
- ! interpolate a number of scalar functions at a given locations. This is useful
- ! if the interpolation location does not change with time, or if several
- ! fields are to be interpolated at a given time step. (If both the fields
- ! and the interpolation locations vary with time, there is no clear advantage in
- ! using either this method or the method for 2D interpoaltion above; for simplicity
- ! and because we foresee more uses for the method of this subroutine, we have not
- ! implemented a 3D version of the fixed field, variable interpolation location method
- ! as we have in 2D.) Coefficients are produced for handling both Dirichlet and Neumann
- ! boundary conditions. The interpolation is performed with basis functions that are
- ! RBFs plus constant and linear.
- ! Input:
- ! pointCount - the number of "source" points and functionValues supplied
- ! sourcePoints - the location of the "source" points in the 3D space where the values of
- ! the function are known
- ! isInterface - a logical array indicating which of the source points (if any) are at
- ! at the domain interface. These points and their normals will be used to compute the
- ! neumannCoefficients below
- ! interfaceNormals - a 3D normal vector for each sourcePoint. These vectors are only used
- ! at points where isInterface == .true., and can take arbitrary values elsewehere. The
- ! normal vector is used to compute coefficients for the normal derivative of the
- ! interpolating function in order to impose the Neumann Boundary condition
- ! destinationPoint - the point where the interpolation will be performed
- ! alpha - a constant that give the characteristic length scale of the RBFs,
- ! should be on the order of the distance between points
- ! Output:
- ! dirichletCoefficients - the coefficients used to interpolate a function with Dirichlet
- ! boundary conditions to the specified destinationPoint
- ! neumannCoefficients - the coefficients used to interpolate a function with Neumann
- ! boundary conditions to the specified destinationPoint
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine mpas_rbf_interp_func_3D_sca_lin_dir_neu_comp_coeffs(pointCount, &
+!***********************************************************************
+!
+! routine mpas_rbf_interp_func_3D_sca_lin_dir_neu_comp_coeffs
+!
+!> \brief MPAS 3D scalar linear Dirichlet and Neumann coefficients routine
+!> \author Xylar Asay-Davis
+!> \date 03/28/13
+!> \version SVN:$Id$
+!> \details
+!> This routine computes interpolation coefficients in 3D that can be used to
+!> interpolate a number of scalar functions at a given locations. This is useful
+!> if the interpolation location does not change with time, or if several
+!> fields are to be interpolated at a given time step. (If both the fields
+!> and the interpolation locations vary with time, there is no clear advantage in
+!> using either this method or the method for 2D interpoaltion above; for simplicity
+!> and because we foresee more uses for the method of this subroutine, we have not
+!> implemented a 3D version of the fixed field, variable interpolation location method
+!> as we have in 2D.) Coefficients are produced for handling both Dirichlet and Neumann
+!> boundary conditions. The interpolation is performed with basis functions that are
+!> RBFs plus constant and linear.
+!> Input:
+!> pointCount - the number of "source" points and functionValues supplied
+!> sourcePoints - the location of the "source" points in the 3D space where the values of
+!> the function are known
+!> isInterface - a logical array indicating which of the source points (if any) are at
+!> at the domain interface. These points and their normals will be used to compute the
+!> neumannCoefficients below
+!> interfaceNormals - a 3D normal vector for each sourcePoint. These vectors are only used
+!> at points where isInterface == .true., and can take arbitrary values elsewehere. The
+!> normal vector is used to compute coefficients for the normal derivative of the
+!> interpolating function in order to impose the Neumann Boundary condition
+!> destinationPoint - the point where the interpolation will be performed
+!> alpha - a constant that give the characteristic length scale of the RBFs,
+!> should be on the order of the distance between points
+!> Output:
+!> dirichletCoefficients - the coefficients used to interpolate a function with Dirichlet
+!> boundary conditions to the specified destinationPoint
+!> neumannCoefficients - the coefficients used to interpolate a function with Neumann
+!> boundary conditions to the specified destinationPoint
+!-----------------------------------------------------------------------
+ subroutine mpas_rbf_interp_func_3D_sca_lin_dir_neu_comp_coeffs(pointCount, &!{{{
sourcePoints, isInterface, interfaceNormals, destinationPoint, &
alpha, dirichletCoefficients, neumannCoefficients)
- integer, intent(in) :: pointCount
- real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints
- logical, dimension(pointCount), intent(in) :: isInterface
- real(kind=RKIND), dimension(pointCount,3), intent(in) :: interfaceNormals
- real(kind=RKIND), dimension(3), intent(in) :: destinationPoint
- real(kind=RKIND), intent(in) :: alpha
- real(kind=RKIND), dimension(pointCount), intent(out) :: &
- dirichletCoefficients, neumannCoefficients
+ integer, intent(in) :: pointCount !< Input: Number of points
+ real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints !< Input: List of points
+ logical, dimension(pointCount), intent(in) :: isInterface !< Input: List of logicals determining if point as at an interface
+ real(kind=RKIND), dimension(pointCount,3), intent(in) :: interfaceNormals !< Input: List of interface normals
+ real(kind=RKIND), dimension(3), intent(in) :: destinationPoint !< Input: Destination point
+ real(kind=RKIND), intent(in) :: alpha !< Input: Characteristic length scale of RBFs
+ real(kind=RKIND), dimension(pointCount), intent(out) :: dirichletCoefficients !< Output: List of Dirichlet coefficients
+ real(kind=RKIND), dimension(pointCount), intent(out) :: neumannCoefficients !< Outut: List of Neumann coefficients
integer :: i, j
integer :: matrixSize
@@ -997,45 +1095,53 @@
deallocate(coeffs)
deallocate(pivotIndices)
- end subroutine mpas_rbf_interp_func_3D_sca_lin_dir_neu_comp_coeffs
+ end subroutine mpas_rbf_interp_func_3D_sca_lin_dir_neu_comp_coeffs!}}}
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Purpose: Compute interpolation coefficients in 3D that can be used to
- ! interpolate a number of vector functions at a given locations. This is useful
- ! if the interpolation location does not change with time, or if several
- ! fields are to be interpolated at a given time step. (If both the vector fields
- ! and the interpolation locations vary with time, there is no clear advantage in
- ! using either this method or the method for 2D interpoaltion above; for simplicity
- ! and because we foresee more uses for the method of this subroutine, we have not
- ! implemented a 3D version of the fixed field, variable interpolation location method
- ! as we have in 2D.) Coefficients are produced for handling Dirichlet boundary
- ! conditions (or no boundaries). The interpolation is performed with basis functions
- ! that are RBFs plus a constant.
- ! Input:
- ! pointCount - the number of "source" points and functionValues supplied
- ! sourcePoints - the location of the "source" points in the 3D space where the values of
- ! the function are known
- ! unitVectors - the unit vectors associated with each of the sourcePoints. Interpolation
- ! is performed by supplying the value of the vector function dotted into each of these unit
- ! vectors. If multiple unit vectors are supplied at the same sourcePoint, they *must* be
- ! orthogonal for the interpolation to succeed.
- ! destinationPoint - the point where the interpolation will be performed
- ! alpha - a constant that give the characteristic length scale of the RBFs,
- ! should be on the order of the distance between points
- ! Output:
- ! coefficients - the coefficients used to interpolate a function with Dirichlet
- ! boundary conditions to the specified destinationPoint
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine mpas_rbf_interp_func_3D_vec_const_dir_comp_coeffs(pointCount, &
+!***********************************************************************
+!
+! routine mpas_rbf_interp_func_3D_vec_const_dir_comp_coeffs
+!
+!> \brief MPAS 3D vector constant Dirichlet coefficients routine
+!> \author Xylar Asay-Davis
+!> \date 03/28/13
+!> \version SVN:$Id$
+!> \details
+!> This routine computes interpolation coefficients in 3D that can be used to
+!> interpolate a number of vector functions at a given locations. This is useful
+!> if the interpolation location does not change with time, or if several
+!> fields are to be interpolated at a given time step. (If both the vector fields
+!> and the interpolation locations vary with time, there is no clear advantage in
+!> using either this method or the method for 2D interpoaltion above; for simplicity
+!> and because we foresee more uses for the method of this subroutine, we have not
+!> implemented a 3D version of the fixed field, variable interpolation location method
+!> as we have in 2D.) Coefficients are produced for handling Dirichlet boundary
+!> conditions (or no boundaries). The interpolation is performed with basis functions
+!> that are RBFs plus a constant.
+!> Input:
+!> pointCount - the number of "source" points and functionValues supplied
+!> sourcePoints - the location of the "source" points in the 3D space where the values of
+!> the function are known
+!> unitVectors - the unit vectors associated with each of the sourcePoints. Interpolation
+!> is performed by supplying the value of the vector function dotted into each of these unit
+!> vectors. If multiple unit vectors are supplied at the same sourcePoint, they *must* be
+!> orthogonal for the interpolation to succeed.
+!> destinationPoint - the point where the interpolation will be performed
+!> alpha - a constant that give the characteristic length scale of the RBFs,
+!> should be on the order of the distance between points
+!> Output:
+!> coefficients - the coefficients used to interpolate a function with Dirichlet
+!> boundary conditions to the specified destinationPoint
+!-----------------------------------------------------------------------
+ subroutine mpas_rbf_interp_func_3D_vec_const_dir_comp_coeffs(pointCount, &!{{{
sourcePoints, unitVectors, destinationPoint, &
alpha, coefficients)
- integer, intent(in) :: pointCount
- real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints
- real(kind=RKIND), dimension(pointCount,3), intent(in) :: unitVectors
- real(kind=RKIND), dimension(3), intent(in) :: destinationPoint
- real(kind=RKIND), intent(in) :: alpha
- real(kind=RKIND), dimension(pointCount, 3), intent(out) :: coefficients
+ integer, intent(in) :: pointCount !< Input: Number of points
+ real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints !< Input: List of points
+ real(kind=RKIND), dimension(pointCount,3), intent(in) :: unitVectors !< Input: List of unit vectors
+ real(kind=RKIND), dimension(3), intent(in) :: destinationPoint !< Input: Destination point
+ real(kind=RKIND), intent(in) :: alpha !< Input: Characteristic length scale of RBFs
+ real(kind=RKIND), dimension(pointCount, 3), intent(out) :: coefficients !< Output: List of coefficients
integer :: i, j
integer :: matrixSize
@@ -1082,51 +1188,59 @@
deallocate(coeffs)
deallocate(pivotIndices)
- end subroutine mpas_rbf_interp_func_3D_vec_const_dir_comp_coeffs
+ end subroutine mpas_rbf_interp_func_3D_vec_const_dir_comp_coeffs !}}}
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Purpose: Compute interpolation coefficients in 3D that can be used to
- ! interpolate a number of vector functions at a given locations. This is useful
- ! if the interpolation location does not change with time, or if several
- ! fields are to be interpolated at a given time step. (If both the vector fields
- ! and the interpolation locations vary with time, there is no clear advantage in
- ! using either this method or the method for 2D interpoaltion above; for simplicity
- ! and because we foresee more uses for the method of this subroutine, we have not
- ! implemented a 3D version of the fixed field, variable interpolation location method
- ! as we have in 2D.) Coefficients are produced for handling Dirichlet boundary
- ! conditions (or no boundaries). The interpolation is performed with basis functions
- ! that are RBFs plus a constant.
- ! Input:
- ! pointCount - the number of "source" points and functionValues supplied
- ! sourcePoints - the location of the "source" points in the 3D space where the values of
- ! the function are known. The sourcePoints are projected into the plane given by
- ! planeBasisVectors
- ! unitVectors - the unit vectors associated with each of the sourcePoints. Interpolation
- ! is performed by supplying the value of the vector function dotted into each of these unit
- ! vectors. If multiple unit vectors are supplied at the same sourcePoint, they *must* be
- ! orthogonal for the interpolation to succeed. The unitVectors are projected into the
- ! plane given by planeBasisVectors
- ! destinationPoint - the point where the interpolation will be performed. The destinationPoint
- ! is projected into the plane given by planeBasisVectors
- ! alpha - a constant that give the characteristic length scale of the RBFs,
- ! should be on the order of the distance between points
- ! planeBasisVectors - the basis fectors for the plane where interpolation is performed.
- ! All points are projected into this plane.
- ! Output:
- ! coefficients - the coefficients used to interpolate a function with Dirichlet
- ! boundary conditions to the specified destinationPoint
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine mpas_rbf_interp_func_3D_plane_vec_const_dir_comp_coeffs(pointCount, &
+!***********************************************************************
+!
+! routine mpas_rbf_interp_func_3D_plane_vec_const_dir_comp_coeffs
+!
+!> \brief MPAS 3D vector planar constant Dirichlet coefficients routine
+!> \author Xylar Asay-Davis
+!> \date 03/28/13
+!> \version SVN:$Id$
+!> \details
+!> This routine computes interpolation coefficients in 3D that can be used to
+!> interpolate a number of vector functions at a given locations. This is useful
+!> if the interpolation location does not change with time, or if several
+!> fields are to be interpolated at a given time step. (If both the vector fields
+!> and the interpolation locations vary with time, there is no clear advantage in
+!> using either this method or the method for 2D interpoaltion above; for simplicity
+!> and because we foresee more uses for the method of this subroutine, we have not
+!> implemented a 3D version of the fixed field, variable interpolation location method
+!> as we have in 2D.) Coefficients are produced for handling Dirichlet boundary
+!> conditions (or no boundaries). The interpolation is performed with basis functions
+!> that are RBFs plus a constant.
+!> Input:
+!> pointCount - the number of "source" points and functionValues supplied
+!> sourcePoints - the location of the "source" points in the 3D space where the values of
+!> the function are known. The sourcePoints are projected into the plane given by
+!> planeBasisVectors
+!> unitVectors - the unit vectors associated with each of the sourcePoints. Interpolation
+!> is performed by supplying the value of the vector function dotted into each of these unit
+!> vectors. If multiple unit vectors are supplied at the same sourcePoint, they *must* be
+!> orthogonal for the interpolation to succeed. The unitVectors are projected into the
+!> plane given by planeBasisVectors
+!> destinationPoint - the point where the interpolation will be performed. The destinationPoint
+!> is projected into the plane given by planeBasisVectors
+!> alpha - a constant that give the characteristic length scale of the RBFs,
+!> should be on the order of the distance between points
+!> planeBasisVectors - the basis fectors for the plane where interpolation is performed.
+!> All points are projected into this plane.
+!> Output:
+!> coefficients - the coefficients used to interpolate a function with Dirichlet
+!> boundary conditions to the specified destinationPoint
+!-----------------------------------------------------------------------
+ subroutine mpas_rbf_interp_func_3D_plane_vec_const_dir_comp_coeffs(pointCount, &!{{{
sourcePoints, unitVectors, destinationPoint, &
alpha, planeBasisVectors, coefficients)
- integer, intent(in) :: pointCount
- real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints
- real(kind=RKIND), dimension(pointCount,3), intent(in) :: unitVectors
- real(kind=RKIND), dimension(3), intent(in) :: destinationPoint
- real(kind=RKIND), intent(in) :: alpha
- real(kind=RKIND), dimension(2,3) :: planeBasisVectors
- real(kind=RKIND), dimension(pointCount, 3), intent(out) :: coefficients
+ integer, intent(in) :: pointCount !< Input: Number of points
+ real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints !< Input: List of points
+ real(kind=RKIND), dimension(pointCount,3), intent(in) :: unitVectors !< Input: List of unit vectors
+ real(kind=RKIND), dimension(3), intent(in) :: destinationPoint !< Input: Destination point
+ real(kind=RKIND), intent(in) :: alpha !< Input: Characteristic length scale of RBFs
+ real(kind=RKIND), dimension(2,3) :: planeBasisVectors !< Input: Basis vectors for interpolation plane
+ real(kind=RKIND), dimension(pointCount, 3), intent(out) :: coefficients !< Output: List of coefficients
integer :: i, j
integer :: matrixSize
@@ -1191,55 +1305,63 @@
deallocate(coeffs)
deallocate(pivotIndices)
- end subroutine mpas_rbf_interp_func_3D_plane_vec_const_dir_comp_coeffs
+ end subroutine mpas_rbf_interp_func_3D_plane_vec_const_dir_comp_coeffs !}}}
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Purpose: Compute interpolation coefficients in 3D that can be used to
- ! interpolate a number of vector functions at a given locations. This is useful
- ! if the interpolation location does not change with time, or if several
- ! fields are to be interpolated at a given time step. (If both the vector fields
- ! and the interpolation locations vary with time, there is no clear advantage in
- ! using either this method or the method for 2D interpoaltion above; for simplicity
- ! and because we foresee more uses for the method of this subroutine, we have not
- ! implemented a 3D version of the fixed field, variable interpolation location method
- ! as we have in 2D.) Coefficients are produced for handling Dirichlet normal /
- ! Neumann tangential boundary conditions (such as free slip). The interpolation is
- ! performed with basis functions that are RBFs plus a constant.
- ! Input:
- ! pointCount - the number of "source" points and functionValues supplied
- ! sourcePoints - the location of the "source" points in the 3D space where the values of
- ! the function are known
- ! isTangentToInterface - a logical array indicating which sourcePoints/unitVectors are
- ! tangent to the interface where the boundary condition will be applied. A Neumann
- ! boundary condition will be applied at these points in these directions.
- ! normalVectorIndex - where isTangentToInterface == .true., the index into unitVectors that
- ! gives the normal vector at the same sourcePoint. This information is needed to compute
- ! the Neumann boundary condition at this point.
- ! unitVectors - the unit vectors associated with each of the sourcePoints. Interpolation
- ! is performed by supplying the value of the vector function dotted into each of these unit
- ! vectors. If multiple unit vectors are supplied at the same sourcePoint, they *must* be
- ! orthogonal for the interpolation to succeed. A normal vector and two tangential vectors
- ! are needed at each interface point in order to satisfy the Dirichlet normal boundary
- ! condition and the Neumann tangential boundary conditions at these points.
- ! destinationPoint - the point where the interpolation will be performed
- ! alpha - a constant that give the characteristic length scale of the RBFs,
- ! should be on the order of the distance between points
- ! Output:
- ! coefficients - the coefficients used to interpolate a function with Dirichlet
- ! boundary conditions to the specified destinationPoint
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine mpas_rbf_interp_func_3D_vec_const_tan_neu_comp_coeffs(pointCount, &
+!***********************************************************************
+!
+! routine mpas_rbf_interp_func_3D_vec_const_tan_neu_comp_coeffs
+!
+!> \brief MPAS 3D vector constant tangent Neumann coefficients routine
+!> \author Xylar Asay-Davis
+!> \date 03/28/13
+!> \version SVN:$Id$
+!> \details
+!> This routine computes interpolation coefficients in 3D that can be used to
+!> interpolate a number of vector functions at a given locations. This is useful
+!> if the interpolation location does not change with time, or if several
+!> fields are to be interpolated at a given time step. (If both the vector fields
+!> and the interpolation locations vary with time, there is no clear advantage in
+!> using either this method or the method for 2D interpoaltion above; for simplicity
+!> and because we foresee more uses for the method of this subroutine, we have not
+!> implemented a 3D version of the fixed field, variable interpolation location method
+!> as we have in 2D.) Coefficients are produced for handling Dirichlet normal /
+!> Neumann tangential boundary conditions (such as free slip). The interpolation is
+!> performed with basis functions that are RBFs plus a constant.
+!> Input:
+!> pointCount - the number of "source" points and functionValues supplied
+!> sourcePoints - the location of the "source" points in the 3D space where the values of
+!> the function are known
+!> isTangentToInterface - a logical array indicating which sourcePoints/unitVectors are
+!> tangent to the interface where the boundary condition will be applied. A Neumann
+!> boundary condition will be applied at these points in these directions.
+!> normalVectorIndex - where isTangentToInterface == .true., the index into unitVectors that
+!> gives the normal vector at the same sourcePoint. This information is needed to compute
+!> the Neumann boundary condition at this point.
+!> unitVectors - the unit vectors associated with each of the sourcePoints. Interpolation
+!> is performed by supplying the value of the vector function dotted into each of these unit
+!> vectors. If multiple unit vectors are supplied at the same sourcePoint, they *must* be
+!> orthogonal for the interpolation to succeed. A normal vector and two tangential vectors
+!> are needed at each interface point in order to satisfy the Dirichlet normal boundary
+!> condition and the Neumann tangential boundary conditions at these points.
+!> destinationPoint - the point where the interpolation will be performed
+!> alpha - a constant that give the characteristic length scale of the RBFs,
+!> should be on the order of the distance between points
+!> Output:
+!> coefficients - the coefficients used to interpolate a function with Dirichlet
+!> boundary conditions to the specified destinationPoint
+!-----------------------------------------------------------------------
+ subroutine mpas_rbf_interp_func_3D_vec_const_tan_neu_comp_coeffs(pointCount, &!{{{
sourcePoints, isTangentToInterface, normalVectorIndex, unitVectors, destinationPoint, &
alpha, coefficients)
- integer, intent(in) :: pointCount
- real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints
- logical, dimension(pointCount), intent(in) :: isTangentToInterface
- integer, dimension(pointCount), intent(in) :: normalVectorIndex
- real(kind=RKIND), dimension(pointCount,3), intent(in) :: unitVectors
- real(kind=RKIND), dimension(3), intent(in) :: destinationPoint
- real(kind=RKIND), intent(in) :: alpha
- real(kind=RKIND), dimension(pointCount, 3), intent(out) :: coefficients
+ integer, intent(in) :: pointCount !< Input: Number of points
+ real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints !< Input: List of points
+ logical, dimension(pointCount), intent(in) :: isTangentToInterface !< Input: List of logicals determining if point is tangent to interface
+ integer, dimension(pointCount), intent(in) :: normalVectorIndex !< Input: Index of for normal vectors
+ real(kind=RKIND), dimension(pointCount,3), intent(in) :: unitVectors !< Input: List of unit vectors
+ real(kind=RKIND), dimension(3), intent(in) :: destinationPoint !< Input: Destination point
+ real(kind=RKIND), intent(in) :: alpha !< Input: Characteristic length scale of RBFs
+ real(kind=RKIND), dimension(pointCount, 3), intent(out) :: coefficients !< Output: List of coefficients
integer :: i, j
integer :: matrixSize
@@ -1287,61 +1409,70 @@
deallocate(coeffs)
deallocate(pivotIndices)
- end subroutine mpas_rbf_interp_func_3D_vec_const_tan_neu_comp_coeffs
+ end subroutine mpas_rbf_interp_func_3D_vec_const_tan_neu_comp_coeffs !}}}
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Purpose: Compute interpolation coefficients in 3D that can be used to
- ! interpolate a number of vector functions at a given locations. This is useful
- ! if the interpolation location does not change with time, or if several
- ! fields are to be interpolated at a given time step. (If both the vector fields
- ! and the interpolation locations vary with time, there is no clear advantage in
- ! using either this method or the method for 2D interpoaltion above; for simplicity
- ! and because we foresee more uses for the method of this subroutine, we have not
- ! implemented a 3D version of the fixed field, variable interpolation location method
- ! as we have in 2D.) Coefficients are produced for handling Dirichlet normal /
- ! Neumann tangential boundary conditions (such as free slip). The interpolation is
- ! performed with basis functions that are RBFs plus a constant.
- ! Input:
- ! pointCount - the number of "source" points and functionValues supplied
- ! sourcePoints - the location of the "source" points in the 3D space where the values of
- ! the function are known. The sourcePoints are projected into the plane given by
- ! planeBasisVectors
- ! isTangentToInterface - a logical array indicating which sourcePoints/unitVectors are
- ! tangent to the interface where the boundary condition will be applied. A Neumann
- ! boundary condition will be applied at these points in these directions.
- ! normalVectorIndex - where isTangentToInterface == .true., the index into unitVectors that
- ! gives the normal vector at the same sourcePoint. This information is needed to compute
- ! the Neumann boundary condition at this point.
- ! unitVectors - the unit vectors associated with each of the sourcePoints. Interpolation
- ! is performed by supplying the value of the vector function dotted into each of these unit
- ! vectors. If multiple unit vectors are supplied at the same sourcePoint, they *must* be
- ! orthogonal for the interpolation to succeed. A normal vector and two tangential vectors
- ! are needed at each interface point in order to satisfy the Dirichlet normal boundary
- ! condition and the Neumann tangential boundary conditions at these points. The unitVectors
- ! are projected into the plane given by planeBasisVectors
- ! destinationPoint - the point where the interpolation will be performed. The destinationPoint
- ! is projected into the plane given by planeBasisVectors
- ! alpha - a constant that give the characteristic length scale of the RBFs,
- ! should be on the order of the distance between points
- ! planeBasisVectors - the basis fectors for the plane where interpolation is performed.
- ! All points are projected into this plane.
- ! Output:
- ! coefficients - the coefficients used to interpolate a function with Dirichlet
- ! boundary conditions to the specified destinationPoint
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine mpas_rbf_interp_func_3D_plane_vec_const_tan_neu_comp_coeffs(&
+!***********************************************************************
+!
+! routine mpas_rbf_interp_func_3D_plane_vec_const_tan_neu_comp_coeffs
+!
+!> \brief MPAS 3D vector planar constant tangent Neumann coefficients routine
+!> \author Xylar Asay-Davis
+!> \date 03/28/13
+!> \version SVN:$Id$
+!> \details
+!> This routine computes interpolation coefficients in 3D that can be used to
+!> interpolate a number of vector functions at a given locations. This is useful
+!> if the interpolation location does not change with time, or if several
+!> fields are to be interpolated at a given time step. (If both the vector fields
+!> and the interpolation locations vary with time, there is no clear advantage in
+!> using either this method or the method for 2D interpoaltion above; for simplicity
+!> and because we foresee more uses for the method of this subroutine, we have not
+!> implemented a 3D version of the fixed field, variable interpolation location method
+!> as we have in 2D.) Coefficients are produced for handling Dirichlet normal /
+!> Neumann tangential boundary conditions (such as free slip). The interpolation is
+!> performed with basis functions that are RBFs plus a constant.
+!> Input:
+!> pointCount - the number of "source" points and functionValues supplied
+!> sourcePoints - the location of the "source" points in the 3D space where the values of
+!> the function are known. The sourcePoints are projected into the plane given by
+!> planeBasisVectors
+!> isTangentToInterface - a logical array indicating which sourcePoints/unitVectors are
+!> tangent to the interface where the boundary condition will be applied. A Neumann
+!> boundary condition will be applied at these points in these directions.
+!> normalVectorIndex - where isTangentToInterface == .true., the index into unitVectors that
+!> gives the normal vector at the same sourcePoint. This information is needed to compute
+!> the Neumann boundary condition at this point.
+!> unitVectors - the unit vectors associated with each of the sourcePoints. Interpolation
+!> is performed by supplying the value of the vector function dotted into each of these unit
+!> vectors. If multiple unit vectors are supplied at the same sourcePoint, they *must* be
+!> orthogonal for the interpolation to succeed. A normal vector and two tangential vectors
+!> are needed at each interface point in order to satisfy the Dirichlet normal boundary
+!> condition and the Neumann tangential boundary conditions at these points. The unitVectors
+!> are projected into the plane given by planeBasisVectors
+!> destinationPoint - the point where the interpolation will be performed. The destinationPoint
+!> is projected into the plane given by planeBasisVectors
+!> alpha - a constant that give the characteristic length scale of the RBFs,
+!> should be on the order of the distance between points
+!> planeBasisVectors - the basis fectors for the plane where interpolation is performed.
+!> All points are projected into this plane.
+!> Output:
+!> coefficients - the coefficients used to interpolate a function with Dirichlet
+!> boundary conditions to the specified destinationPoint
+!-----------------------------------------------------------------------
+
+ subroutine mpas_rbf_interp_func_3D_plane_vec_const_tan_neu_comp_coeffs(&!{{{
pointCount, sourcePoints, isTangentToInterface, normalVectorIndex, unitVectors, &
destinationPoint, alpha, planeBasisVectors, coefficients)
- integer, intent(in) :: pointCount
- real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints
- logical, dimension(pointCount), intent(in) :: isTangentToInterface
- integer, dimension(pointCount), intent(in) :: normalVectorIndex
- real(kind=RKIND), dimension(pointCount,3), intent(in) :: unitVectors
- real(kind=RKIND), dimension(3), intent(in) :: destinationPoint
- real(kind=RKIND), intent(in) :: alpha
- real(kind=RKIND), dimension(2,3), intent(in) :: planeBasisVectors
- real(kind=RKIND), dimension(pointCount, 3), intent(out) :: coefficients
+ integer, intent(in) :: pointCount !< input: Number of points
+ real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints !< Input: List of points
+ logical, dimension(pointCount), intent(in) :: isTangentToInterface !< Input: List of logicals determining if point is tangent to interface
+ integer, dimension(pointCount), intent(in) :: normalVectorIndex !< Input: Index for normal vectors
+ real(kind=RKIND), dimension(pointCount,3), intent(in) :: unitVectors !< Input: List of unit vectors
+ real(kind=RKIND), dimension(3), intent(in) :: destinationPoint !< Input: Destination point
+ real(kind=RKIND), intent(in) :: alpha !< Input: Characteristic length scale of RBFs
+ real(kind=RKIND), dimension(2,3), intent(in) :: planeBasisVectors !< Input: Basis vectors for interpolation plane
+ real(kind=RKIND), dimension(pointCount, 3), intent(out) :: coefficients !< Output: List of coefficients
integer :: i, j
integer :: matrixSize
@@ -1407,52 +1538,99 @@
deallocate(coeffs)
deallocate(pivotIndices)
- end subroutine mpas_rbf_interp_func_3D_plane_vec_const_tan_neu_comp_coeffs
+ end subroutine mpas_rbf_interp_func_3D_plane_vec_const_tan_neu_comp_coeffs !}}}
!!!!!!!!!!!!!!!!!!!!!
! private subroutines
!!!!!!!!!!!!!!!!!!!!!
- function evaluate_rbf(rSquared) result(rbfValue)
- real(kind=RKIND), intent(in) :: rSquared
+!***********************************************************************
+!
+! function evaluate_rbf
+!
+!> \brief MPAS RBF Evaluation function
+!> \author Xylar Asay-Davis
+!> \date 03/28/13
+!> \version SVN:$Id$
+!> \details
+!> This function evaluates an RBF and returns the value.
+!-----------------------------------------------------------------------
+ function evaluate_rbf(rSquared) result(rbfValue)!{{{
+ real(kind=RKIND), intent(in) :: rSquared !< Input: Squared value of r
real(kind=RKIND) :: rbfValue
! inverse multiquadratic
rbfValue = 1/sqrt(1 + rSquared)
- end function evaluate_rbf
+ end function evaluate_rbf!}}}
- subroutine mpas_evaluate_rbf_and_deriv(rSquared, rbfValue, rbfDerivOverR)
- real(kind=RKIND), intent(in) :: rSquared
- real(kind=RKIND), intent(out) :: rbfValue, rbfDerivOverR
+!***********************************************************************
+!
+! routine mpas_evaluate_rbf_and_deriv
+!
+!> \brief MPAS RBF Evaluation and derivative routine
+!> \author Xylar Asay-Davis
+!> \date 03/28/13
+!> \version SVN:$Id$
+!> \details
+!> This routine computes the value and derivative of a RBF.
+!-----------------------------------------------------------------------
+ subroutine mpas_evaluate_rbf_and_deriv(rSquared, rbfValue, rbfDerivOverR)!{{{
+ real(kind=RKIND), intent(in) :: rSquared !< Input: Squared value of R
+ real(kind=RKIND), intent(out) :: rbfValue !< Output: Value of RBF
+ real(kind=RKIND), intent(out) :: rbfDerivOverR !< Outut: Derivative of RBF over R
! inverse multiquadratic
rbfValue = 1/sqrt(1 + rSquared)
rbfDerivOverR = -rbfValue**3
- end subroutine mpas_evaluate_rbf_and_deriv
+ end subroutine mpas_evaluate_rbf_and_deriv!}}}
- subroutine mpas_evaluate_rbf_and_derivs(rSquared, rbfValue, rbfDerivOverR, rbfSecondDeriv)
- real(kind=RKIND), intent(in) :: rSquared
- real(kind=RKIND), intent(out) :: rbfValue, rbfDerivOverR, rbfSecondDeriv
+!***********************************************************************
+!
+! routine mpas_evaluate_rbf_and_derivs
+!
+!> \brief MPAS RBF Evaluation and first and second derivative routine
+!> \author Xylar Asay-Davis
+!> \date 03/28/13
+!> \version SVN:$Id$
+!> \details
+!> This routine computes the value and the first two derivatives of a RBF.
+!-----------------------------------------------------------------------
+ subroutine mpas_evaluate_rbf_and_derivs(rSquared, rbfValue, rbfDerivOverR, rbfSecondDeriv)!{{{
+ real(kind=RKIND), intent(in) :: rSquared !< Input: Squared value of R
+ real(kind=RKIND), intent(out) :: rbfValue !< Output: Value of RBF
+ real(kind=RKIND), intent(out) :: rbfDerivOverR !< Output: Value of first derivative of RBF
+ real(kind=RKIND), intent(out) :: rbfSecondDeriv !< Output: Value of second derivative of RBF
! inverse multiquadratic
rbfValue = 1/sqrt(1 + rSquared)
rbfDerivOverR = -rbfValue**3
rbfSecondDeriv = (2*rSquared-1)*rbfValue**5
- end subroutine mpas_evaluate_rbf_and_derivs
+ end subroutine mpas_evaluate_rbf_and_derivs!}}}
- subroutine mpas_set_up_scalar_rbf_dirichlet_matrix_and_rhs(pointCount, sourcePoints, destinationPoint, &
+!***********************************************************************
+!
+! routine mpas_set_up_scalar_rbf_dirichlet_matrix_and_rhs
+!
+!> \brief MPAS RBF Scalar Matrix and RHS setup routine
+!> \author Xylar Asay-Davis
+!> \date 03/28/13
+!> \version SVN:$Id$
+!> \details
+!> This routine sets up the matrix and RHS for scalar Dirichlet RBF interpolation.
+!-----------------------------------------------------------------------
+ subroutine mpas_set_up_scalar_rbf_dirichlet_matrix_and_rhs(pointCount, sourcePoints, destinationPoint, &!{{{
alpha, dirichletMatrix, rhs)
- integer, intent(in) :: pointCount
- real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints
- real(kind=RKIND), dimension(3), intent(in) :: destinationPoint
- real(kind=RKIND), intent(in) :: alpha
- real(kind=RKIND), dimension(pointCount,pointCount), intent(out) :: dirichletMatrix
- real(kind=RKIND), dimension(pointCount), intent(out) :: rhs
+ integer, intent(in) :: pointCount !< Input: Number of points
+ real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints !< Input: List of points
+ real(kind=RKIND), dimension(3), intent(in) :: destinationPoint !< Input: Destination point
+ real(kind=RKIND), intent(in) :: alpha !< Input: Characteristic length scale of RBF
+ real(kind=RKIND), dimension(pointCount,pointCount), intent(out) :: dirichletMatrix !< Output: Matrix
+ real(kind=RKIND), dimension(pointCount), intent(out) :: rhs !< Output: Right hand side
integer :: i, j
@@ -1471,21 +1649,32 @@
rhs(j) = evaluate_rbf(rSquared)
end do
- end subroutine mpas_set_up_scalar_rbf_dirichlet_matrix_and_rhs
+ end subroutine mpas_set_up_scalar_rbf_dirichlet_matrix_and_rhs!}}}
- subroutine mpas_set_up_scalar_rbf_matrix_and_rhs(pointCount, &
+!***********************************************************************
+!
+! routine mpas_set_up_scalar_rbf_matrix_and_rhs
+!
+!> \brief MPAS RBF Scalar Matrix and RHS setup routine
+!> \author Xylar Asay-Davis
+!> \date 03/28/13
+!> \version SVN:$Id$
+!> \details
+!> This routine sets up the matrix and RHS for scalar Dirichlet and Neumann RBF interpolation.
+!-----------------------------------------------------------------------
+ subroutine mpas_set_up_scalar_rbf_matrix_and_rhs(pointCount, &!{{{
sourcePoints, isInterface, interfaceNormals, destinationPoint, &
alpha, dirichletMatrix, neumannMatrix, rhs)
- integer, intent(in) :: pointCount
- real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints
- logical, dimension(pointCount), intent(in) :: isInterface
- real(kind=RKIND), dimension(pointCount,3), intent(in) :: interfaceNormals
- real(kind=RKIND), dimension(3), intent(in) :: destinationPoint
- real(kind=RKIND), intent(in) :: alpha
- real(kind=RKIND), dimension(pointCount,pointCount), intent(out) :: &
- dirichletMatrix, neumannMatrix
- real(kind=RKIND), dimension(pointCount), intent(out) :: rhs
+ integer, intent(in) :: pointCount !< Input: Number of points
+ real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints !< Input: List of points
+ logical, dimension(pointCount), intent(in) :: isInterface !< Input: Logicals determining if point is an interface
+ real(kind=RKIND), dimension(pointCount,3), intent(in) :: interfaceNormals !< Input: Normals at interfaces
+ real(kind=RKIND), dimension(3), intent(in) :: destinationPoint !< Input: Destination point
+ real(kind=RKIND), intent(in) :: alpha !< Input: Characteristic length scale of RBF
+ real(kind=RKIND), dimension(pointCount,pointCount), intent(out) :: dirichletMatrix !< Output: Dirichlet Matrix
+ real(kind=RKIND), dimension(pointCount,pointCount), intent(out) :: neumannMatrix !< Output: Neumann Matrix
+ real(kind=RKIND), dimension(pointCount), intent(out) :: rhs !< Output: Right hand side
integer :: i, j
@@ -1517,19 +1706,31 @@
rhs(j) = evaluate_rbf(rSquared)
end do
- end subroutine mpas_set_up_scalar_rbf_matrix_and_rhs
+ end subroutine mpas_set_up_scalar_rbf_matrix_and_rhs!}}}
- subroutine mpas_set_up_vector_dirichlet_rbf_matrix_and_rhs(pointCount, dimensions, &
+!***********************************************************************
+!
+! routine mpas_set_up_vector_dirichlet_rbf_matrix_and_rhs
+!
+!> \brief MPAS RBF Vector Matrix and RHS setup routine
+!> \author Xylar Asay-Davis
+!> \date 03/28/13
+!> \version SVN:$Id$
+!> \details
+!> This routine sets up the matrix and RHS for vector Dirichlet RBF interpolation.
+!-----------------------------------------------------------------------
+ subroutine mpas_set_up_vector_dirichlet_rbf_matrix_and_rhs(pointCount, dimensions, &!{{{
sourcePoints, unitVectors, destinationPoint, &
alpha, matrix, rhs)
- integer, intent(in) :: pointCount, dimensions
- real(kind=RKIND), dimension(pointCount,dimensions), intent(in) :: sourcePoints
- real(kind=RKIND), dimension(pointCount,dimensions), intent(in) :: unitVectors
- real(kind=RKIND), dimension(dimensions), intent(in) :: destinationPoint
- real(kind=RKIND), intent(in) :: alpha
- real(kind=RKIND), dimension(pointCount,pointCount), intent(out) :: matrix
- real(kind=RKIND), dimension(pointCount,dimensions), intent(out) :: rhs
+ integer, intent(in) :: pointCount !< Input: Number of points
+ integer, intent(in) :: dimensions !< Input: Number of dimensions
+ real(kind=RKIND), dimension(pointCount,dimensions), intent(in) :: sourcePoints !< Input: List of points
+ real(kind=RKIND), dimension(pointCount,dimensions), intent(in) :: unitVectors !< Input: List of unit vectors
+ real(kind=RKIND), dimension(dimensions), intent(in) :: destinationPoint !< Input: Destination point
+ real(kind=RKIND), intent(in) :: alpha !< Input: Characteristic length scale of RBFs
+ real(kind=RKIND), dimension(pointCount,pointCount), intent(out) :: matrix !< Output: Matrix
+ real(kind=RKIND), dimension(pointCount,dimensions), intent(out) :: rhs !< Output: Right hand side
integer :: i, j
@@ -1550,21 +1751,33 @@
rhs(j,:) = evaluate_rbf(rSquared)*unitVectors(j,:)
end do
- end subroutine mpas_set_up_vector_dirichlet_rbf_matrix_and_rhs
+ end subroutine mpas_set_up_vector_dirichlet_rbf_matrix_and_rhs!}}}
- subroutine mpas_set_up_vector_free_slip_rbf_matrix_and_rhs(pointCount, dimensions, &
+!***********************************************************************
+!
+! routine mpas_set_up_vector_free_slip_rbf_matrix_and_rhs
+!
+!> \brief MPAS RBF Vector Matrix and RHS setup routine
+!> \author Xylar Asay-Davis
+!> \date 03/28/13
+!> \version SVN:$Id$
+!> \details
+!> This routine sets up the matrix and RHS for vector Free Slip RBF interpolation.
+!-----------------------------------------------------------------------
+ subroutine mpas_set_up_vector_free_slip_rbf_matrix_and_rhs(pointCount, dimensions, &!{{{
sourcePoints, isTangentToInterface, normalVectorIndex, unitVectors, destinationPoint, &
alpha, matrix, rhs)
- integer, intent(in) :: pointCount, dimensions
- real(kind=RKIND), dimension(pointCount,dimensions), intent(in) :: sourcePoints
- logical, dimension(pointCount), intent(in) :: isTangentToInterface
- integer, dimension(pointCount), intent(in) :: normalVectorIndex
- real(kind=RKIND), dimension(pointCount,dimensions), intent(in) :: unitVectors
- real(kind=RKIND), dimension(dimensions), intent(in) :: destinationPoint
- real(kind=RKIND), intent(in) :: alpha
- real(kind=RKIND), dimension(pointCount,pointCount), intent(out) :: matrix
- real(kind=RKIND), dimension(pointCount,dimensions), intent(out) :: rhs
+ integer, intent(in) :: pointCount !< Input: Number of points
+ integer, intent(in) :: dimensions !< Input: Number of dimensions
+ real(kind=RKIND), dimension(pointCount,dimensions), intent(in) :: sourcePoints !< Input: List of points
+ logical, dimension(pointCount), intent(in) :: isTangentToInterface !< Input: Logical to determine if point is tangent to interface
+ integer, dimension(pointCount), intent(in) :: normalVectorIndex !< Input: Index to normal vector
+ real(kind=RKIND), dimension(pointCount,dimensions), intent(in) :: unitVectors !< Input: List of unit vectors
+ real(kind=RKIND), dimension(dimensions), intent(in) :: destinationPoint !< Input: Destination point
+ real(kind=RKIND), intent(in) :: alpha !< Input: Characteristic length scale of RBF
+ real(kind=RKIND), dimension(pointCount,pointCount), intent(out) :: matrix !< Output: Matrix
+ real(kind=RKIND), dimension(pointCount,dimensions), intent(out) :: rhs !< Output: Right hand side
integer :: i, j
@@ -1597,24 +1810,47 @@
rhs(j,:) = evaluate_rbf(rSquared)*unitVectors(j,:)
end do
- end subroutine mpas_set_up_vector_free_slip_rbf_matrix_and_rhs
+ end subroutine mpas_set_up_vector_free_slip_rbf_matrix_and_rhs!}}}
- subroutine mpas_unit_vec_in_r3(xin)
+!***********************************************************************
+!
+! routine mpas_unit_vec_in_r3
+!
+!> \brief MPAS 3D unit vector routine
+!> \author Xylar Asay-Davis
+!> \date 03/28/13
+!> \version SVN:$Id$
+!> \details
+!> This routine creates a unit vector out of an input point.
+!-----------------------------------------------------------------------
+ subroutine mpas_unit_vec_in_r3(xin)!{{{
implicit none
- real (kind=RKIND), intent(inout) :: xin(3)
+ real (kind=RKIND), intent(inout) :: xin(3) !< Input/Output: Vector and unit vector
real (kind=RKIND) :: mag
mag = sqrt(xin(1)**2+xin(2)**2+xin(3)**2)
xin(:) = xin(:) / mag
- end subroutine mpas_unit_vec_in_r3
+ end subroutine mpas_unit_vec_in_r3!}}}
- subroutine mpas_cross_product_in_r3(p_1,p_2,p_out)
- real (kind=RKIND), intent(in) :: p_1 (3), p_2 (3)
- real (kind=RKIND), intent(out) :: p_out (3)
+!***********************************************************************
+!
+! routine mpas_cross_product_in_r3
+!
+!> \brief MPAS 3D cross product routine
+!> \author Xylar Asay-Davis
+!> \date 03/28/13
+!> \version SVN:$Id$
+!> \details
+!> This routine computes the cross product of two input vectors.
+!-----------------------------------------------------------------------
+ subroutine mpas_cross_product_in_r3(p_1,p_2,p_out)!{{{
+ real (kind=RKIND), intent(in) :: p_1 (3) !< Input: Vector 1
+ real (kind=RKIND), intent(in) :: p_2 (3) !< Input: Vector 2
+ real (kind=RKIND), intent(out) :: p_out (3) !< Output: Cross product of vector 1 and vector 2
p_out(1) = p_1(2)*p_2(3)-p_1(3)*p_2(2)
p_out(2) = p_1(3)*p_2(1)-p_1(1)*p_2(3)
p_out(3) = p_1(1)*p_2(2)-p_1(2)*p_2(1)
- end subroutine mpas_cross_product_in_r3
+ end subroutine mpas_cross_product_in_r3!}}}
! Updated 10/24/2001.
!
@@ -1656,20 +1892,28 @@
! WRITE (6, "(F16.8)") (X(I), I=1,N)
!END PROGRAM EX43
-
-subroutine mpas_legs (A,N,B,X,INDX)
+!***********************************************************************
!
-! subroutine to solve the equation A(N,N)*X(N) = B(N) with the
-! partial-pivoting Gaussian elimination scheme.
-! Copyright (c) Tao Pang 2001.
+! routine mpas_legs
!
+!> \brief MPAS Gaussian elimination solver routine
+!> \author Xylar Asay-Davis
+!> \date 03/28/13
+!> \version SVN:$Id$
+!> \details
+!> This routine solves the equation A(N,N)*X(N) = B(N) with the partial-pivoting
+!> Gaussian Elimination scheme. Copyright (c) Tao Pang 2001.
+!-----------------------------------------------------------------------
+subroutine mpas_legs (A,N,B,X,INDX)!{{{
+
IMPLICIT NONE
- integer, INTENT (IN) :: N
- integer :: I,J
- integer, INTENT (OUT), DIMENSION (N) :: INDX
- real(kind=RKIND), INTENT (INOUT), DIMENSION (N,N) :: A
- real(kind=RKIND), INTENT (INOUT), DIMENSION (N) :: B
- real(kind=RKIND), INTENT (OUT), DIMENSION (N) :: X
+ integer, INTENT (IN) :: N !< Input: Size of matrix and vectors
+ integer, INTENT (OUT), DIMENSION (N) :: INDX !< Output: Pivot vector
+ real(kind=RKIND), INTENT (INOUT), DIMENSION (N,N) :: A !< Input/Output: Matrix
+ real(kind=RKIND), INTENT (INOUT), DIMENSION (N) :: B !< Input/Output: Right hand side vector
+ real(kind=RKIND), INTENT (OUT), DIMENSION (N) :: X !< Output: Solution
+
+ integer :: I,J
!
CALL elgs (A,N,INDX)
!
@@ -1688,7 +1932,7 @@
X(I) = X(I)/A(INDX(I),I)
END DO
!
-END subroutine mpas_legs
+END subroutine mpas_legs!}}}
!
@@ -1709,18 +1953,26 @@
! !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
-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.
+! routine migs
!
+!> \brief Matrix inversion routine
+!> \author Xylar Asay-Davis
+!> \date 03/28/13
+!> \version SVN:$Id$
+!> \details
+!> This routine inverts the matrix A(N,N) and stores it in X(N,B)
+!> Copyright (c) Tao Pang 2001.
+!-----------------------------------------------------------------------
+subroutine migs (A,N,X,INDX)!{{{
IMPLICIT NONE
- integer, INTENT (IN) :: N
+ integer, INTENT (IN) :: N !< Input: Size of matrix and inverse
+ integer, INTENT (OUT), DIMENSION (N) :: INDX !< Output: Pivot vector
+ real(kind=RKIND), INTENT (INOUT), DIMENSION (N,N):: A !< Input/Output: Matrix to invert
+ real(kind=RKIND), INTENT (OUT), DIMENSION (N,N):: X !< Output: Inverse of Matrix
+ real(kind=RKIND), DIMENSION (N,N) :: B
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
@@ -1751,10 +2003,22 @@
X(J,I) = X(J,I)/A(INDX(J),J)
END DO
END DO
-END subroutine migs
+END subroutine migs!}}}
+!***********************************************************************
+!
+! routine elgs
+!
+!> \brief Partial-pivoting Gaussian elimination routine
+!> \author Xylar Asay-Davis
+!> \date 03/28/13
+!> \version SVN:$Id$
+!> \details
+!> This routine performs the partial-pivoting Gaussian elimination.
+!> Copyright (c) Tao Pang 2001.
+!-----------------------------------------------------------------------
-subroutine elgs (A,N,INDX)
+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
@@ -1762,11 +2026,11 @@
! INDX(N) records the pivoting order. Copyright (c) Tao Pang 2001.
!
IMPLICIT NONE
- integer, INTENT (IN) :: N
+ integer, INTENT (IN) :: N !< Input: Size of matrix
+ integer, INTENT (OUT), DIMENSION (N) :: INDX !< Output: Pivot vector
+ real(kind=RKIND), INTENT (INOUT), DIMENSION (N,N) :: A !< Input/Output: Matrix and solution
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
@@ -1818,7 +2082,7 @@
END DO
END DO
!
-END subroutine elgs
+END subroutine elgs!}}}
end module mpas_rbf_interpolation
Modified: branches/ocean_projects/openmp_elements/src/registry/Makefile
===================================================================
--- branches/ocean_projects/openmp_elements/src/registry/Makefile 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/registry/Makefile 2013-03-29 14:40:23 UTC (rev 2678)
@@ -1,9 +1,12 @@
.SUFFIXES: .c .o
-OBJS = parse.o dictionary.o gen_inc.o fortprintf.o
+OBJS = parse.o dictionary.o gen_inc.o fortprintf.o ezxml/ezxml.o
all: parse
+ezxml/ezxml.o:
+ (cd ezxml; $(CC) -c ezxml.c)
+
parse: $(OBJS)
$(CC) -o $@ $(OBJS)
Copied: branches/ocean_projects/openmp_elements/src/registry/Registry.xsd (from rev 2677, trunk/mpas/src/registry/Registry.xsd)
===================================================================
--- branches/ocean_projects/openmp_elements/src/registry/Registry.xsd (rev 0)
+++ branches/ocean_projects/openmp_elements/src/registry/Registry.xsd 2013-03-29 14:40:23 UTC (rev 2678)
@@ -0,0 +1,121 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<xs:schema xmlns:xs="http://www.w3.org/2001/XMLSchema" elementFormDefault="qualified" attributeFormDefault="unqualified" >
+ <xs:element name="registry" >
+ <xs:complexType>
+ <xs:sequence>
+ <!-- The dims element contains all dimensions -->
+ <xs:element name="dims" >
+ <xs:complexType>
+ <xs:sequence>
+ <!-- Each dimension is an independent child of the <dims></dims> element. -->
+ <xs:element name="dim" maxOccurs="unbounded" >
+ <xs:complexType>
+ <!-- The name attribute should specify the name of the dimension. -->
+ <xs:attribute name="name" type="xs:string" use="required"/>
+ <!-- The definition attribute is used to define a dimension based on other pre-defined dimensions -->
+ <xs:attribute name="definition" type="xs:string" use="optional"/>
+ <!-- The units attribute defines the units of the dimension. -->
+ <xs:attribute name="units" type="xs:string" use="optional"/>
+ <!-- The description attribute describes the dimensions. -->
+ <xs:attribute name="description" type="xs:string" use="optional"/>
+ </xs:complexType>
+ </xs:element>
+ </xs:sequence>
+ </xs:complexType>
+ </xs:element>
+ <!-- The nml_record element contains all namelist options for a particular namelist record -->
+ <xs:element name="nml_record" maxOccurs="unbounded" >
+ <xs:complexType>
+ <xs:sequence>
+ <!-- The nml_option element defines a particular namelist option that lives within the defined nml_record -->
+ <xs:element name="nml_option" maxOccurs="unbounded" >
+ <xs:complexType>
+ <!-- The name attribute defines the name of the namelist option. This is how it would look in a namelist file. -->
+ <xs:attribute name="name" type="xs:string" use="required"/>
+ <!-- The type attribute defines the type of the particular namelist option. Options are real, integer, character, and logical. -->
+ <xs:attribute name="type" type="xs:string" use="required"/>
+ <!-- The default_value attribute defines the default value of the namelist option. This is used if the option is omitted from a namelist file. -->
+ <xs:attribute name="default_value" type="xs:string" use="required"/>
+ <!-- The units attribute defines the units for the particular namelist option. -->
+ <xs:attribute name="units" type="xs:string" use="optional"/>
+ <!-- The description attribute describes the namelist option. -->
+ <xs:attribute name="description" type="xs:string" use="optional"/>
+ <!-- The possible_values attribute defines what values are allowable for the namelist option. -->
+ <xs:attribute name="possible_values" type="xs:string" use="optional"/>
+ </xs:complexType>
+ </xs:element>
+ </xs:sequence>
+ <!-- The name attribute defines the name of the namelist record. This would be seen as &name in the actual namelist. -->
+ <xs:attribute name="name" type="xs:string" use="required"/>
+ </xs:complexType>
+ </xs:element>
+ <!-- The var_struct element defines a grouping of variables. This is similar to mesh, or state and lives at the domain % blocklist level. -->
+ <xs:element name="var_struct" maxOccurs="unbounded" >
+ <xs:complexType>
+ <xs:sequence>
+ <!-- The var_array element defines an array of variables.
+ Within the code all constituent variables are merged into a one higher dimension array, for ease of use.
+ When written to the output file, they will be named their individual names. -->
+ <xs:element name="var_array" maxOccurs="unbounded" minOccurs="0" >
+ <xs:complexType>
+ <xs:sequence>
+ <!-- This specific var element defines a variable that is a constituent to a particular var_array group. -->
+ <xs:element name="var" maxOccurs="unbounded" minOccurs="0" >
+ <xs:complexType>
+ <!-- The name attribute is the name of the variable. This how it will be displayed in the output file. -->
+ <xs:attribute name="name" type="xs:string" use="required"/>
+ <!-- The array_group attribute is used to group variables within the var_array for ease of use. -->
+ <xs:attribute name="array_group" type="xs:string" use="required"/>
+ <!-- The streams attribute defines the streams this variable is included in. Allowable values are omitted, i, r, o and any combination of i, r, and o. -->
+ <xs:attribute name="streams" type="xs:string" use="optional"/>
+ <!-- The name_in_code attribute defines the name of the variable in the code, if it should be different then in the input/output/restart streams. -->
+ <xs:attribute name="name_in_code" type="xs:string" use="optional"/>
+ <!-- The units attribute defines the units of the particular variable -->
+ <xs:attribute name="units" type="xs:string" use="optional"/>
+ <!-- The description attribute describes the particular variable -->
+ <xs:attribute name="description" type="xs:string" use="optional"/>
+ </xs:complexType>
+ </xs:element>
+ </xs:sequence>
+ <!-- The name attribute is the name of the var_array that will be seen in the code. -->
+ <xs:attribute name="name" type="xs:string" use="required"/>
+ <!-- The type attribute defines the type of all constituents for the var_array. Valid options are real, integer, logical, and character -->
+ <xs:attribute name="type" type="xs:string" use="required"/>
+ <!-- The dimensions attribute defines the dimensions of each individual constituent. This does not include the collapsed dimension. -->
+ <xs:attribute name="dimensions" type="xs:string" use="required"/>
+ <!-- The persistence attribute determines if the var_array is persistence or scratch. Valid options are persistent, and scratch. -->
+ <xs:attribute name="persistence" type="xs:string" use="optional"/>
+ </xs:complexType>
+ </xs:element>
+ <!-- This var element defines a variable that does not live within a var_array group. -->
+ <xs:element name="var" maxOccurs="unbounded" minOccurs="0" >
+ <xs:complexType>
+ <!-- The name attribute defines the name in the NetCDF files of this variable. -->
+ <xs:attribute name="name" type="xs:string" use="required"/>
+ <!-- The type attribute defines the type within MPAS of the variable. -->
+ <xs:attribute name="type" type="xs:string" use="required"/>
+ <!-- The dimensions attribute defines the dimensions of the variable. -->
+ <xs:attribute name="dimensions" type="xs:string" use="required"/>
+ <!-- The streams attribute defines the streams this variable is included in. -->
+ <xs:attribute name="streams" type="xs:string" use="optional"/>
+ <!-- The name_in_code attribute defines the name of the variable within MPAS (if different from name). -->
+ <xs:attribute name="name_in_code" type="xs:string" use="optional"/>
+ <!-- The units attribute defines the units of the variable. -->
+ <xs:attribute name="units" type="xs:string" use="optional"/>
+ <!-- The description attribute provides a brief description of the variable. -->
+ <xs:attribute name="description" type="xs:string" use="optional"/>
+ <!-- The persistence attribute determines if the var is persistent or scratch. Valid options are persistent, and scratch. Default is persistent. -->
+ <xs:attribute name="persistence" type="xs:string" use="optional"/>
+ </xs:complexType>
+ </xs:element>
+ </xs:sequence>
+ <!-- The name attribute defines the name of the var_struct. This would be similar to mesh, or state. -->
+ <xs:attribute name="name" type="xs:string" use="required"/>
+ <!-- The time_levs attribute defines the number of time levels this var_struct contains. -->
+ <xs:attribute name="time_levs" type="xs:int" use="required"/>
+ </xs:complexType>
+ </xs:element>
+ </xs:sequence>
+ </xs:complexType>
+ </xs:element>
+</xs:schema>
Modified: branches/ocean_projects/openmp_elements/src/registry/gen_inc.c
===================================================================
--- branches/ocean_projects/openmp_elements/src/registry/gen_inc.c 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/registry/gen_inc.c 2013-03-29 14:40:23 UTC (rev 2678)
@@ -822,8 +822,10 @@
fortprintf(fd, " %s %% %s %% isSuperArray = .false.</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code);
if (var_ptr->ndims > 0) {
if(var_ptr->persistence == SCRATCH){
+ fortprintf(fd, " %s %% %s %% isPersistent = .false.</font>
<font color="black">", group_ptr->name, var_ptr->name_in_code);
fortprintf(fd, " nullify(%s %% %s %% array)</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code);
} else if(var_ptr->persistence == PERSISTENT){
+ fortprintf(fd, " %s %% %s %% isPersistent = .true.</font>
<font color="gray">", group_ptr->name, var_ptr->name_in_code);
fortprintf(fd, " allocate(%s %% %s %% array(", group_ptr->name, var_ptr->name_in_code);
dimlist_ptr = var_ptr->dimlist;
if (!strncmp(dimlist_ptr->dim->name_in_file, "nCells", 1024) ||
@@ -1159,7 +1161,10 @@
for(i=1; i<=ntime_levs; i++)
{
fortprintf(fd, " if(associated(next) .and. associated(prev)) then</font>
<font color="red">");
- fortprintf(fd, " call mpas_create_%s_links(b %% %s %% time_levs(%i) %% %s, prev = prev %% %s %% time_levs(%i) %% %s, next = next %% %s %% time_levs(%i) %% %s)</font>
<font color="blue">", group_ptr->name, group_ptr->name, i, group_ptr->name, i, group_ptr->name, group_ptr->name, i, group_ptr->name);
+// fortprintf(fd, " call mpas_create_%s_links(b %% %s %% time_levs(%i) %% %s, prev = prev %% %s %% time_levs(%i) %% %s, next = next %% %s %% time_levs(%i) %% %s)</font>
<font color="blue">", group_ptr->name, group_ptr->name, i, group_ptr->name, i, group_ptr->name, group_ptr->name, i, group_ptr->name);
+ fortprintf(fd, " call mpas_create_%s_links(b %% %s %% time_levs(%i) %% %s, ", group_ptr->name, group_ptr->name, i, group_ptr->name, i);
+ fortprintf(fd, " prev = prev %% %s %% time_levs(%i) %% %s,", group_ptr->name, i, group_ptr->name);
+ fortprintf(fd, " next = next %% %s %% time_levs(%i) %% %s)</font>
<font color="black">", group_ptr->name, i, group_ptr->name);
fortprintf(fd, " else if(associated(next)) then</font>
<font color="black">");
fortprintf(fd, " call mpas_create_%s_links(b %% %s %% time_levs(%i) %% %s, next = next %% %s %% time_levs(%i) %% %s)</font>
<font color="black">", group_ptr->name, group_ptr->name, i, group_ptr->name, group_ptr->name, i, group_ptr->name);
fortprintf(fd, " else if(associated(prev)) then</font>
<font color="gray">");
@@ -1387,7 +1392,7 @@
void gen_reads(struct group_list * groups, struct variable * vars, struct dimension * dims)
{
struct variable * var_ptr;
- struct variable_list * var_list_ptr;
+ struct variable_list * var_list_ptr, *var_list_ptr2;
struct dimension * dim_ptr;
struct dimension_list * dimlist_ptr, * lastdim;
struct group_list * group_ptr;
@@ -2117,8 +2122,10 @@
/* fortprintf(fd, " write(0,*) \'adding input field %s\'</font>
<font color="black">", var_ptr->super_array); */
fortprintf(fd, " call MPAS_streamAddField(input_obj %% io_stream, %s %% %s, nferr)</font>
<font color="blue">", struct_deref, var_ptr->super_array);
while (var_list_ptr && strncmp(super_array, var_list_ptr->var->super_array, 1024) == 0) {
+ var_list_ptr2 = var_list_ptr;
var_list_ptr = var_list_ptr->next;
}
+ var_list_ptr = var_list_ptr2;
}
else {
fortprintf(fd, " if ((%s %% %s %% ioinfo %% input .and. input_obj %% stream == STREAM_INPUT) .or. &</font>
<font color="gray">", struct_deref, var_ptr->name_in_code);
@@ -2174,8 +2181,10 @@
/* fortprintf(fd, " write(0,*) \'exchange halo for %s\'</font>
<font color="black">", var_ptr->super_array); */
fortprintf(fd, " call mpas_dmpar_exch_halo_field(%s %% %s)</font>
<font color="blue">", struct_deref, var_ptr->super_array);
while (var_list_ptr && strncmp(super_array, var_list_ptr->var->super_array, 1024) == 0) {
+ var_list_ptr2 = var_list_ptr;
var_list_ptr = var_list_ptr->next;
}
+ var_list_ptr = var_list_ptr2;
}
else {
fortprintf(fd, " if ((%s %% %s %% ioinfo %% input .and. input_obj %% stream == STREAM_INPUT) .or. &</font>
<font color="gray">", struct_deref, var_ptr->name_in_code);
@@ -2381,7 +2390,7 @@
void gen_writes(struct group_list * groups, struct variable * vars, struct dimension * dims, struct namelist * namelists)
{
struct variable * var_ptr;
- struct variable_list * var_list_ptr;
+ struct variable_list * var_list_ptr, *var_list_ptr2;
struct dimension * dim_ptr;
struct dimension_list * dimlist_ptr, * lastdim;
struct group_list * group_ptr;
@@ -2563,8 +2572,10 @@
memcpy(super_array, var_ptr->super_array, 1024);
fortprintf(fd, " call MPAS_streamAddField(output_obj %% io_stream, %s %% %s, ierr)</font>
<font color="blue">", struct_deref, super_array);
while (var_list_ptr && strncmp(super_array, var_list_ptr->var->super_array, 1024) == 0) {
+ var_list_ptr2 = var_list_ptr;
var_list_ptr = var_list_ptr->next;
}
+ var_list_ptr = var_list_ptr2;
}
else {
fortprintf(fd, " if ((%s %% %s %% ioinfo %% output .and. output_obj %% stream == OUTPUT) .or. &</font>
<font color="gray">", struct_deref, var_ptr->name_in_code);
Modified: branches/ocean_projects/openmp_elements/src/registry/parse.c
===================================================================
--- branches/ocean_projects/openmp_elements/src/registry/parse.c 2013-03-28 19:10:52 UTC (rev 2677)
+++ branches/ocean_projects/openmp_elements/src/registry/parse.c 2013-03-29 14:40:23 UTC (rev 2678)
@@ -3,6 +3,7 @@
#include <string.h>
#include "registry_types.h"
#include "gen_inc.h"
+#include "ezxml/ezxml.h"
int parse_reg(FILE *, struct namelist **, struct dimension **, struct variable **, struct group_list **);
int getword(FILE *, char *);
@@ -30,9 +31,16 @@
nls = NULL;
dims = NULL;
vars = NULL;
+
+ if (parse_reg_xml(regfile, &nls, &dims, &vars, &groups)) {
+ return 1;
+ }
+
+/* Old Parser
if (parse_reg(regfile, &nls, &dims, &vars, &groups)) {
return 1;
}
+*/
sort_vars(vars);
sort_group_vars(groups);
@@ -45,7 +53,391 @@
return 0;
}
+int parse_reg_xml(FILE * regfile, struct namelist **nls, struct dimension ** dims, struct variable ** vars, struct group_list ** groups)
+{
+ struct namelist * nls_ptr, *nls_ptr2;
+ struct namelist * nls_chk_ptr;
+ struct dimension * dim_ptr, *dim_ptr2;
+ struct variable * var_ptr, *var_ptr2;
+ struct dimension_list * dimlist_ptr;
+ struct dimension * dimlist_cursor;
+ struct group_list * grouplist_ptr;
+ struct variable_list * vlist_cursor;
+ ezxml_t registry = ezxml_parse_fp(regfile);
+ ezxml_t dims_xml, dim_xml;
+ ezxml_t structs_xml, var_arr_xml, var_xml;
+ ezxml_t nmlrecs_xml, nmlopt_xml;
+
+ const char *dimname, *dimunits, *dimdesc, *dimdef;
+ const char *nmlrecname, *nmloptname, *nmlopttype, *nmloptval, *nmloptunits, *nmloptdesc, *nmloptposvals;
+ const char *structname, *structlevs;
+ const char *vararrname, *vararrtype, *vararrdims, *vararrpersistence;
+ const char *varname, *varpersistence, *vartype, *vardims, *varunits, *vardesc, *vararrgroup, *varstreams;
+ const char *varname_in_code;
+
+ char dimensions[2048];
+ char *dimension_list;
+ char dimension_buffer[128];
+ char streams_buffer[128];
+
+ NEW_NAMELIST(nls_ptr)
+ NEW_DIMENSION(dim_ptr)
+ NEW_VARIABLE(var_ptr)
+ NEW_GROUP_LIST(grouplist_ptr);
+ *nls = nls_ptr;
+ *dims = dim_ptr;
+ *vars = var_ptr;
+ *groups = grouplist_ptr;
+
+ // Parse Namelist Records
+ for (nmlrecs_xml = ezxml_child(registry, "nml_record"); nmlrecs_xml; nmlrecs_xml = nmlrecs_xml->next){
+ nmlrecname = ezxml_attr(nmlrecs_xml, "name");
+ for (nmlopt_xml = ezxml_child(nmlrecs_xml, "nml_option"); nmlopt_xml; nmlopt_xml = nmlopt_xml->next){
+ nmloptname = ezxml_attr(nmlopt_xml, "name");
+ nmlopttype = ezxml_attr(nmlopt_xml, "type");
+ nmloptval = ezxml_attr(nmlopt_xml, "default_value");
+ nmloptunits = ezxml_attr(nmlopt_xml, "units");
+ nmloptdesc = ezxml_attr(nmlopt_xml, "description");
+ nmloptposvals = ezxml_attr(nmlopt_xml, "possible_values");
+
+ snprintf(nls_ptr->record, 1024, "%s", nmlrecname);
+ snprintf(nls_ptr->name, 1024, "%s", nmloptname);
+
+ if(strncmp(nmlopttype, "real", 1024) == 0){
+ nls_ptr->vtype = REAL;
+ } else if(strncmp(nmlopttype, "integer", 1024) == 0){
+ nls_ptr->vtype = INTEGER;
+ } else if(strncmp(nmlopttype, "logical", 1024) == 0){
+ nls_ptr->vtype = LOGICAL;
+ } else if(strncmp(nmlopttype, "character", 1024) == 0){
+ nls_ptr->vtype = CHARACTER;
+ }
+
+ switch(nls_ptr->vtype){
+ case REAL:
+ nls_ptr->defval.rval = (float)atof(nmloptval);
+ break;
+ case INTEGER:
+ nls_ptr->defval.ival = atoi(nmloptval);
+ break;
+ case LOGICAL:
+ if(strncmp(nmloptval, "true", 1024) ==0){
+ nls_ptr->defval.lval = 1;
+ } else if (strncmp(nmloptval, "false", 1024) == 0){
+ nls_ptr->defval.lval = 0;
+ }
+ break;
+ case CHARACTER:
+ snprintf(nls_ptr->defval.cval, 32, "%s", nmloptval);
+ break;
+ }
+
+ NEW_NAMELIST(nls_ptr->next)
+ nls_ptr2 = nls_ptr;
+ nls_ptr = nls_ptr->next;
+ }
+ }
+
+ if(nls_ptr2->next) free(nls_ptr2->next);
+ nls_ptr2->next = NULL;
+
+ // Parse Dimensions
+ for (dims_xml = ezxml_child(registry, "dims"); dims_xml; dims_xml = dims_xml->next){
+ for (dim_xml = ezxml_child(dims_xml, "dim"); dim_xml; dim_xml = dim_xml->next){
+ dimname = ezxml_attr(dim_xml, "name");
+ dimdef = ezxml_attr(dim_xml, "definition");
+ dimunits = ezxml_attr(dim_xml, "units");
+ dimdesc = ezxml_attr(dim_xml, "description");
+
+ dim_ptr->namelist_defined = 0;
+
+ snprintf(dim_ptr->name_in_file, 1024, "%s", dimname);
+ if(dimdef == NULL){
+ snprintf(dim_ptr->name_in_code, 1024, "%s", dimname);
+ dim_ptr->constant_value = -1;
+ } else {
+ snprintf(dim_ptr->name_in_code, 1024, "%s", dimdef);
+ // Check namelist defined ??
+ dim_ptr->constant_value = is_integer_constant(dim_ptr->name_in_code);
+ if(strncmp(dim_ptr->name_in_code, "namelist:", 9) == 0) {
+ dim_ptr->namelist_defined = 1;
+ snprintf(dim_ptr->name_in_code, 1024, "%s", (dim_ptr->name_in_code)+9);
+
+ /* Check that the referenced namelist variable is defined as an integer variable */
+ nls_chk_ptr = (*nls)->next;
+ while (nls_chk_ptr) {
+ if (strncmp(nls_chk_ptr->name, dim_ptr->name_in_code, 1024) == 0) {
+ if (nls_chk_ptr->vtype != INTEGER) {
+ printf("</font>
<font color="black">Registry error: Namelist variable %s must be an integer for namelist-derived dimension %s</font>
<font color="black"></font>
<font color="blue">", nls_chk_ptr->name, dim_ptr->name_in_file);
+ return 1;
+ }
+ break;
+ }
+ nls_chk_ptr = nls_chk_ptr->next;
+ }
+ if (!nls_chk_ptr) {
+ printf("</font>
<font color="black">Registry error: Namelist variable %s not defined for namelist-derived dimension %s</font>
<font color="black"></font>
<font color="blue">", dim_ptr->name_in_code, dim_ptr->name_in_file);
+ return 1;
+ }
+
+ }
+ }
+
+ NEW_DIMENSION(dim_ptr->next)
+ dim_ptr2 = dim_ptr;
+ dim_ptr = dim_ptr->next;
+ }
+ }
+
+ if(dim_ptr2->next) free(dim_ptr2->next);
+ dim_ptr2->next = NULL;
+
+ // Parse Variable Structures
+ for(structs_xml = ezxml_child(registry, "var_struct"); structs_xml; structs_xml = structs_xml->next){
+ structname = ezxml_attr(structs_xml, "name");
+ structlevs = ezxml_attr(structs_xml, "time_levs");
+
+ grouplist_ptr = *groups;
+ while(grouplist_ptr->next) grouplist_ptr = grouplist_ptr->next;
+ NEW_GROUP_LIST(grouplist_ptr->next);
+ grouplist_ptr = grouplist_ptr->next;
+ snprintf(grouplist_ptr->name, 1024, "%s", structname);
+ vlist_cursor = NULL;
+
+ // Parse variable arrays
+ for(var_arr_xml = ezxml_child(structs_xml, "var_array"); var_arr_xml; var_arr_xml = var_arr_xml->next){
+ vararrname = ezxml_attr(var_arr_xml, "name");
+ vararrtype = ezxml_attr(var_arr_xml, "type");
+ vararrdims = ezxml_attr(var_arr_xml, "dimensions");
+ vararrpersistence = ezxml_attr(var_arr_xml, "persistence");
+
+ //Parse variables in variable arrays
+ for(var_xml = ezxml_child(var_arr_xml, "var"); var_xml; var_xml = var_xml->next){
+ varname = ezxml_attr(var_xml, "name");
+ varunits = ezxml_attr(var_xml, "units");
+ vardesc = ezxml_attr(var_xml, "description");
+ varstreams = ezxml_attr(var_xml, "streams");
+ vararrgroup = ezxml_attr(var_xml, "array_group");
+ varname_in_code = ezxml_attr(var_xml, "name_in_code");
+
+ if(vlist_cursor == NULL){
+ NEW_VARIABLE_LIST(grouplist_ptr->vlist);
+ vlist_cursor = grouplist_ptr->vlist;
+ } else {
+ NEW_VARIABLE_LIST(vlist_cursor->next);
+ vlist_cursor->next->prev = vlist_cursor;
+ vlist_cursor = vlist_cursor->next;
+ }
+ vlist_cursor->var = var_ptr;
+ vlist_cursor->next = NULL;
+
+ var_ptr->ndims = 0;
+ var_ptr->timedim = 0;
+ var_ptr->iostreams = 0;
+
+ snprintf(var_ptr->name_in_file, 1024, "%s", varname);
+
+ if(vararrpersistence == NULL){
+ var_ptr->persistence = PERSISTENT;
+ } else {
+ if(strncmp(vararrpersistence, "persistent", 1024) == 0){
+ var_ptr->persistence = PERSISTENT;
+ } else if(strncmp(vararrpersistence, "scratch", 1024) == 0){
+ var_ptr->persistence = SCRATCH;
+ }
+ }
+
+ if(strncmp(vararrtype, "real", 1024) == 0){
+ var_ptr->vtype = REAL;
+ } else if(strncmp(vararrtype, "integer", 1024) == 0){
+ var_ptr->vtype = INTEGER;
+ } else if(strncmp(vararrtype, "logical", 1024) == 0){
+ var_ptr->vtype = LOGICAL;
+ } else if(strncmp(vararrtype, "text", 1024) == 0){
+ var_ptr->vtype = CHARACTER;
+ }
+
+ NEW_DIMENSION_LIST(dimlist_ptr)
+ var_ptr->dimlist = dimlist_ptr;
+
+ snprintf(dimensions,2048, "%s", vararrdims);
+ dimension_list = strtok(dimensions, " ");
+ while(dimension_list != NULL){
+ snprintf(dimension_buffer, 128, "%s", dimension_list);
+ if(strncmp(dimension_buffer, "Time", 1024) == 0){
+ var_ptr->timedim = 1;
+ } else {
+ NEW_DIMENSION_LIST(dimlist_ptr->next)
+ dimlist_ptr->next->prev = dimlist_ptr;
+ dimlist_ptr = dimlist_ptr->next;
+
+ dimlist_cursor = (*dims);
+ while(dimlist_cursor && (strncmp(dimension_buffer, dimlist_cursor->name_in_file, 1024) != 0)){
+ dimlist_cursor = dimlist_cursor->next;
+ }
+ if (dimlist_cursor) {
+ dimlist_ptr->dim = dimlist_cursor;
+ } else {
+ fprintf(stderr, "Error: Unknown dimension %s for variable %s</font>
<font color="blue">", dimension_buffer, var_ptr->name_in_file);
+ return 1;
+ }
+ var_ptr->ndims++;
+ }
+ dimension_list = strtok(NULL, " ");
+ }
+ dimlist_ptr = var_ptr->dimlist;
+ if(var_ptr->dimlist) var_ptr->dimlist = var_ptr->dimlist->next;
+ free(dimlist_ptr);
+
+ var_ptr->ntime_levs = atoi(structlevs);
+
+ if(varstreams != NULL){
+ snprintf(streams_buffer, 128, "%s", varstreams);
+ if(strchr(streams_buffer, (int)'i')) var_ptr->iostreams |= INPUT0;
+ if(strchr(streams_buffer, (int)'s')) var_ptr->iostreams |= SFC0;
+ if(strchr(streams_buffer, (int)'r')) var_ptr->iostreams |= RESTART0;
+ if(strchr(streams_buffer, (int)'o')) var_ptr->iostreams |= OUTPUT0;
+ }
+
+ if(varname_in_code == NULL){
+ snprintf(var_ptr->name_in_code, 1024, "%s", varname);
+ } else {
+ snprintf(var_ptr->name_in_code, 1024, "%s", varname_in_code);
+ }
+
+ snprintf(var_ptr->super_array, 1024, "%s", vararrname);
+ snprintf(var_ptr->array_class, 1024, "%s", vararrgroup);
+
+ NEW_VARIABLE(var_ptr->next);
+ var_ptr2 = var_ptr;
+ var_ptr = var_ptr->next;
+ }
+ }
+
+ for(var_xml = ezxml_child(structs_xml, "var"); var_xml; var_xml = var_xml->next){
+ varname = ezxml_attr(var_xml, "name");
+ varpersistence = ezxml_attr(var_xml, "persistence");
+ vartype = ezxml_attr(var_xml, "type");
+ vardims = ezxml_attr(var_xml, "dimensions");
+ varunits = ezxml_attr(var_xml, "units");
+ vardesc = ezxml_attr(var_xml, "description");
+ varstreams = ezxml_attr(var_xml, "streams");
+ varname_in_code = ezxml_attr(var_xml, "name_in_code");
+
+ if(vlist_cursor == NULL){
+ NEW_VARIABLE_LIST(grouplist_ptr->vlist);
+ vlist_cursor = grouplist_ptr->vlist;
+ } else {
+ NEW_VARIABLE_LIST(vlist_cursor->next);
+ vlist_cursor->next->prev = vlist_cursor;
+ vlist_cursor = vlist_cursor->next;
+ }
+ vlist_cursor->var = var_ptr;
+ vlist_cursor->next = NULL;
+
+ var_ptr->ndims = 0;
+ var_ptr->timedim = 0;
+ var_ptr->iostreams = 0;
+
+ snprintf(var_ptr->name_in_file, 1024, "%s", varname);
+
+ if(varpersistence == NULL){
+ var_ptr->persistence = PERSISTENT;
+ } else {
+ if(strncmp(varpersistence, "persistent", 1024) == 0){
+ var_ptr->persistence = PERSISTENT;
+ } else if(strncmp(varpersistence, "scratch", 1024) == 0){
+ var_ptr->persistence = SCRATCH;
+ }
+ }
+
+ if(strncmp(vartype, "real", 1024) == 0){
+ var_ptr->vtype = REAL;
+ } else if(strncmp(vartype, "integer", 1024) == 0){
+ var_ptr->vtype = INTEGER;
+ } else if(strncmp(vartype, "logical", 1024) == 0){
+ var_ptr->vtype = LOGICAL;
+ } else if(strncmp(vartype, "text", 1024) == 0){
+ var_ptr->vtype = CHARACTER;
+ }
+
+ NEW_DIMENSION_LIST(dimlist_ptr)
+ var_ptr->dimlist = dimlist_ptr;
+
+ snprintf(dimensions, 2048, "%s", vardims);
+ dimension_list = strtok(dimensions, " ");
+ while(dimension_list != NULL){
+ snprintf(dimension_buffer, 128, "%s", dimension_list);
+ if(strncmp(dimension_buffer, "Time", 1024) == 0){
+ var_ptr->timedim = 1;
+ } else {
+ NEW_DIMENSION_LIST(dimlist_ptr->next)
+ dimlist_ptr->next->prev = dimlist_ptr;
+ dimlist_ptr = dimlist_ptr->next;
+
+ dimlist_cursor = (*dims);
+ while(dimlist_cursor && (strncmp(dimension_buffer, dimlist_cursor->name_in_file, 1024) != 0) )
+ dimlist_cursor = dimlist_cursor->next;
+ if (dimlist_cursor) {
+ dimlist_ptr->dim = dimlist_cursor;
+ } else {
+ fprintf(stderr, "Error: Unknown dimension %s for variable %s</font>
<font color="gray">", dimension_buffer, var_ptr->name_in_file);
+ return 1;
+ }
+ var_ptr->ndims++;
+ }
+ dimension_list = strtok(NULL, " ");
+ }
+
+ dimlist_ptr = var_ptr->dimlist;
+ if(var_ptr->dimlist) var_ptr->dimlist = var_ptr->dimlist->next;
+ free(dimlist_ptr);
+
+ var_ptr->ntime_levs = atoi(structlevs);
+
+ if(varstreams != NULL){
+ snprintf(streams_buffer, 128, "%s", varstreams);
+ if(strchr(streams_buffer, (int)'i')) {
+ var_ptr->iostreams |= INPUT0;
+ }
+ if(strchr(streams_buffer, (int)'s')) {
+ var_ptr->iostreams |= SFC0;
+ }
+ if(strchr(streams_buffer, (int)'r')) {
+ var_ptr->iostreams |= RESTART0;
+ }
+ if(strchr(streams_buffer, (int)'o')) {
+ var_ptr->iostreams |= OUTPUT0;
+ }
+ }
+
+ if(varname_in_code == NULL){
+ snprintf(var_ptr->name_in_code, 1024, "%s", varname);
+ } else {
+ snprintf(var_ptr->name_in_code, 1024, "%s", varname_in_code);
+ }
+
+ snprintf(var_ptr->super_array, 1024, "-");
+ snprintf(var_ptr->array_class, 1024, "-");
+
+ NEW_VARIABLE(var_ptr->next);
+ var_ptr2 = var_ptr;
+ var_ptr = var_ptr->next;
+ }
+ }
+
+ if(var_ptr2->next) free(var_ptr2->next);
+ var_ptr2->next = NULL;
+
+ grouplist_ptr = *groups;
+ if ((*groups)->next) *groups = (*groups)->next;
+ if (grouplist_ptr) free(grouplist_ptr);
+
+ return 0;
+}
+
+
int parse_reg(FILE * regfile, struct namelist ** nls, struct dimension ** dims, struct variable ** vars, struct group_list ** groups)
{
char word[1024];
@@ -228,7 +620,6 @@
vlist_cursor->var = var_ptr;
}
-
getword(regfile, var_ptr->super_array);
getword(regfile, var_ptr->array_class);
@@ -402,7 +793,7 @@
memcpy(super_array, var_ptr->var->super_array, 1024);
var_ptr2_prev = var_ptr;
var_ptr2 = var_ptr->next;
- if (var_ptr2 && strncmp(super_array, var_ptr2->var->super_array, 1024) != 0) {
+ if (var_ptr2 != NULL && strncmp(super_array, var_ptr2->var->super_array, 1024) != 0) {
while (var_ptr2) {
if (strncmp(super_array, var_ptr2->var->super_array, 1024) == 0) {
var_ptr2_prev->next = var_ptr2->next;
</font>
</pre>