<p><b>duda</b> 2011-01-04 17:56:27 -0700 (Tue, 04 Jan 2011)</p><p>BRANCH COMMIT<br>
<br>
Merge changes from atmos_nonhydrostatic branch.<br>
<br>
<br>
D src/core_hyd_atmos/module_core.F<br>
A src/core_hyd_atmos/module_mpas_core.F<br>
M src/core_hyd_atmos/Registry<br>
M src/core_hyd_atmos/Makefile<br>
A src/core_init_nhyd_atmos<br>
A src/core_init_nhyd_atmos/module_llxy.F<br>
A src/core_init_nhyd_atmos/module_mpas_core.F<br>
A src/core_init_nhyd_atmos/module_advection.F<br>
A src/core_init_nhyd_atmos/module_test_cases.F<br>
A src/core_init_nhyd_atmos/Registry<br>
A src/core_init_nhyd_atmos/module_read_met.F<br>
A src/core_init_nhyd_atmos/read_geogrid.c<br>
A src/core_init_nhyd_atmos/Makefile<br>
D src/core_sw/module_core.F<br>
A src/core_sw/module_mpas_core.F<br>
M src/core_sw/Registry<br>
M src/core_sw/module_time_integration.F<br>
M src/core_sw/Makefile<br>
M src/driver/mpas.F<br>
M src/driver/Makefile<br>
D src/driver/module_subdriver.F<br>
A src/driver/module_mpas_subdriver.F<br>
D src/core_nhyd_atmos/module_core.F<br>
A src/core_nhyd_atmos/module_mpas_core.F<br>
M src/core_nhyd_atmos/Registry<br>
M src/core_nhyd_atmos/Makefile<br>
D src/core_ocean/module_core.F<br>
A src/core_ocean/module_mpas_core.F<br>
M src/core_ocean/Registry<br>
M src/core_ocean/Makefile<br>
D src/framework/module_framework.F<br>
A src/framework/module_mpas_framework.F<br>
M src/framework/module_block_decomp.F<br>
M src/framework/Makefile<br>
A namelist.input.nhyd_realdata<br>
M Makefile<br>
</p><hr noshade><pre><font color="gray">Modified: branches/atmos_physics/Makefile
===================================================================
--- branches/atmos_physics/Makefile 2011-01-04 17:14:40 UTC (rev 672)
+++ branches/atmos_physics/Makefile 2011-01-05 00:56:27 UTC (rev 673)
@@ -41,7 +41,7 @@
"CC = cc" \
"SFC = ftn" \
"SCC = cc" \
- "FFLAGS = -i4 -r8 -gopt -O2 -Mvect=nosse -Kieee" \
+ "FFLAGS = -i4 -r8 -gopt -O2 -Mvect=nosse -Kieee -convert big_endian" \
"CFLAGS = -fast" \
"LDFLAGS = " \
"CORE = $(CORE)" \
@@ -53,7 +53,7 @@
"CC = mpicc" \
"SFC = pgf90" \
"SCC = pgcc" \
- "FFLAGS = -r8 -O3" \
+ "FFLAGS = -r8 -O3 -byteswapio" \
"CFLAGS = -O3" \
"LDFLAGS = -O3" \
"CORE = $(CORE)" \
@@ -65,7 +65,7 @@
"CC = pgcc" \
"SFC = pgf90" \
"SCC = pgcc" \
- "FFLAGS = -i4 -r8 -g -O2" \
+ "FFLAGS = -i4 -r8 -g -O2 -byteswapio" \
"CFLAGS = -fast" \
"LDFLAGS = " \
"CORE = $(CORE)" \
@@ -77,7 +77,7 @@
"CC = pgcc" \
"SFC = pgf90" \
"SCC = pgcc" \
- "FFLAGS = -r8 -O0 -g -Mbounds -Mchkptr" \
+ "FFLAGS = -r8 -O0 -g -Mbounds -Mchkptr -byteswapio" \
"CFLAGS = -O0 -g" \
"LDFLAGS = -O0 -g -Mbounds -Mchkptr" \
"CORE = $(CORE)" \
@@ -89,7 +89,7 @@
"CC = gcc" \
"SFC = ifort" \
"SCC = gcc" \
- "FFLAGS = -real-size 64 -O3" \
+ "FFLAGS = -real-size 64 -O3 -convert big_endian" \
"CFLAGS = -O3 -m64" \
"LDFLAGS = -O3" \
"CORE = $(CORE)" \
@@ -101,19 +101,31 @@
"CC = mpicc" \
"SFC = gfortran" \
"SCC = gcc" \
- "FFLAGS = -O3 -m64 -ffree-line-length-none -fdefault-real-8" \
+ "FFLAGS = -O3 -m64 -ffree-line-length-none -fdefault-real-8 -fconvert=big-endian" \
"CFLAGS = -O3 -m64" \
"LDFLAGS = -O3 -m64" \
"CORE = $(CORE)" \
- "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE $(PHYSICS) -m64 $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
+ "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE -m64 $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
+gfortran-serial:
+ ( make all \
+ "FC = gfortran" \
+ "CC = gcc" \
+ "SFC = gfortran" \
+ "SCC = gcc" \
+ "FFLAGS = -O3 -m64 -ffree-line-length-none -fdefault-real-8 -fconvert=big-endian" \
+ "CFLAGS = -O3 -m64" \
+ "LDFLAGS = -O3 -m64" \
+ "CORE = $(CORE)" \
+ "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) -DUNDERSCORE -m64 $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
+
g95:
( make all \
"FC = mpif90" \
"CC = mpicc" \
"SFC = g95" \
"SCC = gcc" \
- "FFLAGS = -O3 -ffree-line-length-huge -r8" \
+ "FFLAGS = -O3 -ffree-line-length-huge -r8 -fendian=big" \
"CFLAGS = -O3" \
"LDFLAGS = -O3" \
"CORE = $(CORE)" \
@@ -125,7 +137,7 @@
"CC = gcc" \
"SFC = g95" \
"SCC = gcc" \
- "FFLAGS = -O3 -ffree-line-length-huge -r8" \
+ "FFLAGS = -O3 -ffree-line-length-huge -r8 -fendian=big" \
"CFLAGS = -O3" \
"LDFLAGS = -O3" \
"CORE = $(CORE)" \
Added: branches/atmos_physics/namelist.input.nhyd_realdata
===================================================================
--- branches/atmos_physics/namelist.input.nhyd_realdata (rev 0)
+++ branches/atmos_physics/namelist.input.nhyd_realdata 2011-01-05 00:56:27 UTC (rev 673)
@@ -0,0 +1,52 @@
+&nhyd_model
+ config_test_case = 7
+ config_time_integration = 'SRK3'
+ config_dt = 450
+ config_ntimesteps = 1920
+ config_output_interval = 192
+ config_number_of_sub_steps = 6
+ config_h_mom_eddy_visc2 = 0.0e+04
+ config_h_mom_eddy_visc4 = 0.
+ config_v_mom_eddy_visc2 = 00.0
+ config_h_theta_eddy_visc2 = 0.0e+04
+ config_h_theta_eddy_visc4 = 00.
+ config_v_theta_eddy_visc2 = 00.0
+ config_horiz_mixing = '2d_smagorinsky'
+ config_len_disp = 60000.
+ config_u_vadv_order = 3
+ config_w_vadv_order = 3
+ config_theta_vadv_order = 3
+ config_scalar_vadv_order = 3
+ config_theta_adv_order = 3
+ config_scalar_adv_order = 3
+ config_scalar_advection = .false.
+ config_positive_definite = .false.
+ config_coef_3rd_order = 1.0
+ config_monotonic = .false.
+ config_epssm = 0.1
+ config_smdiv = 0.1
+/
+
+&dimensions
+ config_nvertlevels = 26
+ config_nfglevels = 27
+/
+
+&data_sources
+ config_geog_data_path = '/data3/mp/wrfhelp/WPS_GEOG/'
+ config_met_prefix = 'GFS'
+ config_init_date = '2010-05-26_12'
+/
+
+
+&io
+ config_input_name = 'grid.nc'
+ config_output_name = 'output.nc'
+ config_restart_name = 'restart.nc'
+/
+
+&restart
+ config_restart_interval = 3000
+ config_do_restart = .false.
+ config_restart_time = 1036800.0
+/
Modified: branches/atmos_physics/src/core_hyd_atmos/Makefile
===================================================================
--- branches/atmos_physics/src/core_hyd_atmos/Makefile 2011-01-04 17:14:40 UTC (rev 672)
+++ branches/atmos_physics/src/core_hyd_atmos/Makefile 2011-01-05 00:56:27 UTC (rev 673)
@@ -1,6 +1,6 @@
.SUFFIXES: .F .o
-OBJS = module_core.o \
+OBJS = module_mpas_core.o \
module_test_cases.o \
module_time_integration.o \
module_advection.o
@@ -16,7 +16,7 @@
module_advection.o:
-module_core.o: module_advection.o module_test_cases.o module_time_integration.o
+module_mpas_core.o: module_advection.o module_test_cases.o module_time_integration.o
clean:
$(RM) *.o *.mod *.f90 libdycore.a
Modified: branches/atmos_physics/src/core_hyd_atmos/Registry
===================================================================
--- branches/atmos_physics/src/core_hyd_atmos/Registry 2011-01-04 17:14:40 UTC (rev 672)
+++ branches/atmos_physics/src/core_hyd_atmos/Registry 2011-01-05 00:56:27 UTC (rev 673)
@@ -23,6 +23,7 @@
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_decomp_file_prefix graph.info.part.
namelist integer restart config_restart_interval 0
namelist logical restart config_do_restart false
namelist real restart config_restart_time 172800.0
Deleted: branches/atmos_physics/src/core_hyd_atmos/module_core.F
===================================================================
--- branches/atmos_physics/src/core_hyd_atmos/module_core.F 2011-01-04 17:14:40 UTC (rev 672)
+++ branches/atmos_physics/src/core_hyd_atmos/module_core.F 2011-01-05 00:56:27 UTC (rev 673)
@@ -1,231 +0,0 @@
-module core
-
- use framework
-
- type (io_output_object) :: restart_obj
- integer :: restart_frame
-
-
- contains
-
-
- subroutine mpas_init(domain)
-
- use configure
- use grid_types
- use test_cases
-
- implicit none
-
- type (domain_type), intent(inout) :: domain
-
- real (kind=RKIND) :: dt
- type (block_type), pointer :: block
-
-
- if (.not. config_do_restart) call setup_hyd_test_case(domain)
-
- !
- ! Initialize core
- !
- dt = config_dt
- block => domain % blocklist
- do while (associated(block))
- call mpas_init_block(block, block % mesh, dt)
- block => block % next
- end do
-
- restart_frame = 1
-
- end subroutine mpas_init
-
-
- subroutine mpas_init_block(block, mesh, dt)
-
- use grid_types
- use advection
- use time_integration
- use RBF_interpolation
- use vector_reconstruction
-#ifdef DO_PHYSICS
- use module_physics_control
- use module_physics_init
- use module_physics_manager
-#endif
-
- implicit none
-
- type (block_type), intent(inout) :: block
- type (mesh_type), intent(inout) :: mesh
- real (kind=RKIND), intent(in) :: dt
-
-
- call compute_solver_constants(block % state % time_levs(1) % state, mesh)
- call compute_state_diagnostics(block % state % time_levs(1) % state, mesh)
- call compute_solve_diagnostics(dt, block % state % time_levs(1) % state, mesh)
- call initialize_advection_rk(mesh)
- call rbfInterp_initialize(mesh)
- call init_reconstruct(mesh)
- call reconstruct(block % state % time_levs(1) % state, block % diag, mesh)
-
-#ifdef DO_PHYSICS
- !check that all the physics options are correctly defined and that at least one physics
- !parameterization is called (using the logical moist_physics):
- call physics_namelist_check
-
- !proceed with initialization of physics parameterization if moist_physics is set to true:
- if(moist_physics) then
- call physics_registry_init(config_do_restart, mesh, block % diag_physics, block % tend_physics)
- call physics_wrf_interface(mesh)
- call physics_init(mesh, block % state % time_levs(1) % state, block % diag_physics)
- endif
-#endif
-
- if (.not. config_do_restart) block % state % time_levs(1) % state % xtime % scalar = 0.0
-
- end subroutine mpas_init_block
-
-
- subroutine mpas_run(domain, output_obj, output_frame)
-
- use grid_types
- use io_output
- use timer
-
- implicit none
-
- type (domain_type), intent(inout) :: domain
- type (io_output_object), intent(inout) :: output_obj
- integer, intent(inout) :: output_frame
-
- integer :: ntimesteps, itimestep
- real (kind=RKIND) :: dt
- type (block_type), pointer :: block_ptr
-
- ! Eventually, dt should be domain specific
- dt = config_dt
- ntimesteps = config_ntimesteps
-
- call write_output_frame(output_obj, output_frame, domain)
-
- ! During integration, time level 1 stores the model state at the beginning of the
- ! time step, and time level 2 stores the state advanced dt in time by timestep(...)
- do itimestep = 1,ntimesteps
- write(0,*) 'Doing timestep ', itimestep
- call timer_start("time integration")
- call mpas_timestep(domain, itimestep, dt)
- call timer_stop("time integration")
-
- ! Move time level 2 fields back into time level 1 for next time step
- call shift_time_levels_state(domain % blocklist % state)
-
- if (mod(itimestep, config_output_interval) == 0) then
- call write_output_frame(output_obj, output_frame, domain)
- end if
- if (mod(itimestep, config_restart_interval) == 0 .and. config_restart_interval > 0) then
- if (restart_frame == 1) call output_state_init(restart_obj, domain, "RESTART")
- call output_state_for_domain(restart_obj, domain, restart_frame)
- restart_frame = restart_frame + 1
- end if
- end do
-
- end subroutine mpas_run
-
-
- subroutine write_output_frame(output_obj, output_frame, domain)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Compute diagnostic fields for a domain and write model state to output file
- !
- ! Input/Output: domain - contains model state; diagnostic field are computed
- ! before returning
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- use grid_types
- use io_output
-
- implicit none
-
- integer, intent(inout) :: output_frame
- 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
- do while (associated(block_ptr))
- call compute_output_diagnostics(block_ptr % state % time_levs(1) % state, block_ptr % mesh)
- block_ptr => block_ptr % next
- end do
-
- call output_state_for_domain(output_obj, domain, output_frame)
- output_frame = output_frame + 1
-
- end subroutine write_output_frame
-
-
- subroutine compute_output_diagnostics(state, grid)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Compute diagnostic fields for a domain
- !
- ! Input: state - contains model prognostic fields
- ! grid - contains grid metadata
- !
- ! Output: state - upon returning, diagnostic fields will have be computed
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- use grid_types
-
- implicit none
-
- type (state_type), intent(inout) :: state
- type (mesh_type), intent(in) :: grid
-
- integer :: i, eoe
- integer :: iEdge, k
-
- end subroutine compute_output_diagnostics
-
-
- subroutine mpas_timestep(domain, itimestep, dt)
-
- use grid_types
- use time_integration
-#ifdef DO_PHYSICS
- use module_physics_control
- use module_physics_driver
- use module_physics_manager
-#endif
-
- implicit none
-
- type (domain_type), intent(inout) :: domain
- integer, intent(in) :: itimestep
- real (kind=RKIND), intent(in) :: dt
-
-#ifdef DO_PHYSICS
- !proceed with physics if moist_physics is set to true:
- if(moist_physics) then
- call physics_timetracker(itimestep)
- if(l_physics) call physics_driver(domain,itimestep)
- endif
-#endif
- call timestep(domain, dt, itimestep)
-
- end subroutine mpas_timestep
-
-
- subroutine mpas_finalize(domain)
-
- use grid_types
-
- implicit none
-
- type (domain_type), intent(inout) :: domain
-
- if (restart_frame > 1) call output_state_finalize(restart_obj, domain % dminfo)
-
- end subroutine mpas_finalize
-
-end module core
Copied: branches/atmos_physics/src/core_hyd_atmos/module_mpas_core.F (from rev 667, branches/atmos_physics/src/core_hyd_atmos/module_core.F)
===================================================================
--- branches/atmos_physics/src/core_hyd_atmos/module_mpas_core.F (rev 0)
+++ branches/atmos_physics/src/core_hyd_atmos/module_mpas_core.F 2011-01-05 00:56:27 UTC (rev 673)
@@ -0,0 +1,231 @@
+module mpas_core
+
+ use mpas_framework
+
+ type (io_output_object) :: restart_obj
+ integer :: restart_frame
+
+
+ contains
+
+
+ subroutine mpas_core_init(domain)
+
+ use configure
+ use grid_types
+ use test_cases
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+
+ real (kind=RKIND) :: dt
+ type (block_type), pointer :: block
+
+
+ if (.not. config_do_restart) call setup_hyd_test_case(domain)
+
+ !
+ ! Initialize core
+ !
+ dt = config_dt
+ block => domain % blocklist
+ do while (associated(block))
+ call mpas_init_block(block, block % mesh, dt)
+ block => block % next
+ end do
+
+ restart_frame = 1
+
+ end subroutine mpas_core_init
+
+
+ subroutine mpas_init_block(block, mesh, dt)
+
+ use grid_types
+ use advection
+ use time_integration
+ use RBF_interpolation
+ use vector_reconstruction
+#ifdef DO_PHYSICS
+ use module_physics_control
+ use module_physics_init
+ use module_physics_manager
+#endif
+
+ implicit none
+
+ type (block_type), intent(inout) :: block
+ type (mesh_type), intent(inout) :: mesh
+ real (kind=RKIND), intent(in) :: dt
+
+
+ call compute_solver_constants(block % state % time_levs(1) % state, mesh)
+ call compute_state_diagnostics(block % state % time_levs(1) % state, mesh)
+ call compute_solve_diagnostics(dt, block % state % time_levs(1) % state, mesh)
+ call initialize_advection_rk(mesh)
+ call rbfInterp_initialize(mesh)
+ call init_reconstruct(mesh)
+ call reconstruct(block % state % time_levs(1) % state, block % diag, mesh)
+
+#ifdef DO_PHYSICS
+ !check that all the physics options are correctly defined and that at least one physics
+ !parameterization is called (using the logical moist_physics):
+ call physics_namelist_check
+
+ !proceed with initialization of physics parameterization if moist_physics is set to true:
+ if(moist_physics) then
+ call physics_registry_init(config_do_restart, mesh, block % diag_physics, block % tend_physics)
+ call physics_wrf_interface(mesh)
+ call physics_init(mesh, block % state % time_levs(1) % state, block % diag_physics)
+ endif
+#endif
+
+ if (.not. config_do_restart) block % state % time_levs(1) % state % xtime % scalar = 0.0
+
+ end subroutine mpas_init_block
+
+
+ subroutine mpas_core_run(domain, output_obj, output_frame)
+
+ use grid_types
+ use io_output
+ use timer
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+ type (io_output_object), intent(inout) :: output_obj
+ integer, intent(inout) :: output_frame
+
+ integer :: ntimesteps, itimestep
+ real (kind=RKIND) :: dt
+ type (block_type), pointer :: block_ptr
+
+ ! Eventually, dt should be domain specific
+ dt = config_dt
+ ntimesteps = config_ntimesteps
+
+ call write_output_frame(output_obj, output_frame, domain)
+
+ ! During integration, time level 1 stores the model state at the beginning of the
+ ! time step, and time level 2 stores the state advanced dt in time by timestep(...)
+ do itimestep = 1,ntimesteps
+ write(0,*) 'Doing timestep ', itimestep
+ call timer_start("time integration")
+ call mpas_timestep(domain, itimestep, dt)
+ call timer_stop("time integration")
+
+ ! Move time level 2 fields back into time level 1 for next time step
+ call shift_time_levels_state(domain % blocklist % state)
+
+ if (mod(itimestep, config_output_interval) == 0) then
+ call write_output_frame(output_obj, output_frame, domain)
+ end if
+ if (mod(itimestep, config_restart_interval) == 0 .and. config_restart_interval > 0) then
+ if (restart_frame == 1) call output_state_init(restart_obj, domain, "RESTART")
+ call output_state_for_domain(restart_obj, domain, restart_frame)
+ restart_frame = restart_frame + 1
+ end if
+ end do
+
+ end subroutine mpas_core_run
+
+
+ subroutine write_output_frame(output_obj, output_frame, domain)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Compute diagnostic fields for a domain and write model state to output file
+ !
+ ! Input/Output: domain - contains model state; diagnostic field are computed
+ ! before returning
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ use grid_types
+ use io_output
+
+ implicit none
+
+ integer, intent(inout) :: output_frame
+ 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
+ do while (associated(block_ptr))
+ call compute_output_diagnostics(block_ptr % state % time_levs(1) % state, block_ptr % mesh)
+ block_ptr => block_ptr % next
+ end do
+
+ call output_state_for_domain(output_obj, domain, output_frame)
+ output_frame = output_frame + 1
+
+ end subroutine write_output_frame
+
+
+ subroutine compute_output_diagnostics(state, grid)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Compute diagnostic fields for a domain
+ !
+ ! Input: state - contains model prognostic fields
+ ! grid - contains grid metadata
+ !
+ ! Output: state - upon returning, diagnostic fields will have be computed
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ use grid_types
+
+ implicit none
+
+ type (state_type), intent(inout) :: state
+ type (mesh_type), intent(in) :: grid
+
+ integer :: i, eoe
+ integer :: iEdge, k
+
+ end subroutine compute_output_diagnostics
+
+
+ subroutine mpas_timestep(domain, itimestep, dt)
+
+ use grid_types
+ use time_integration
+#ifdef DO_PHYSICS
+ use module_physics_control
+ use module_physics_driver
+ use module_physics_manager
+#endif
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+ integer, intent(in) :: itimestep
+ real (kind=RKIND), intent(in) :: dt
+
+#ifdef DO_PHYSICS
+ !proceed with physics if moist_physics is set to true:
+ if(moist_physics) then
+ call physics_timetracker(itimestep)
+ if(l_physics) call physics_driver(domain,itimestep)
+ endif
+#endif
+ call timestep(domain, dt, itimestep)
+
+ end subroutine mpas_timestep
+
+
+ subroutine mpas_core_finalize(domain)
+
+ use grid_types
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+
+ if (restart_frame > 1) call output_state_finalize(restart_obj, domain % dminfo)
+
+ end subroutine mpas_core_finalize
+
+end module mpas_core
Added: branches/atmos_physics/src/core_init_nhyd_atmos/Makefile
===================================================================
--- branches/atmos_physics/src/core_init_nhyd_atmos/Makefile (rev 0)
+++ branches/atmos_physics/src/core_init_nhyd_atmos/Makefile 2011-01-05 00:56:27 UTC (rev 673)
@@ -0,0 +1,36 @@
+.SUFFIXES: .F .o
+
+OBJS = module_mpas_core.o \
+ module_test_cases.o \
+ module_advection.o \
+ module_read_met.o \
+ module_llxy.o \
+ read_geogrid.o
+
+all: core_hyd
+
+core_hyd: $(OBJS)
+ ar -ru libdycore.a $(OBJS)
+
+module_test_cases.o: module_advection.o module_read_met.o read_geogrid.o module_llxy.o
+
+module_advection.o:
+
+module_read_met.o:
+
+read_geogrid.o:
+
+module_llxy.o:
+
+module_mpas_core.o: module_advection.o module_test_cases.o
+
+clean:
+ $(RM) *.o *.mod *.f90 libdycore.a
+
+.F.o:
+ $(RM) $@ $*.mod
+ $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90
+ $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../framework -I../operators
+
+.c.o:
+ $(CC) $(CFLAGS) $(CPPFLAGS) $(CPPINCLUDES) -c $<
Added: branches/atmos_physics/src/core_init_nhyd_atmos/Registry
===================================================================
--- branches/atmos_physics/src/core_init_nhyd_atmos/Registry (rev 0)
+++ branches/atmos_physics/src/core_init_nhyd_atmos/Registry 2011-01-05 00:56:27 UTC (rev 673)
@@ -0,0 +1,208 @@
+#
+# namelist type namelist_record name default_value
+#
+namelist integer nhyd_model config_test_case 5
+namelist character nhyd_model config_time_integration SRK3
+namelist real nhyd_model config_dt 172.8
+namelist integer nhyd_model config_ntimesteps 7500
+namelist integer nhyd_model config_output_interval 500
+namelist character nhyd_model config_horiz_mixing 2d_smagorinsky
+namelist real nhyd_model config_h_mom_eddy_visc2 0.0
+namelist real nhyd_model config_h_mom_eddy_visc4 0.0
+namelist real nhyd_model config_v_mom_eddy_visc2 0.0
+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 integer nhyd_model config_number_of_sub_steps 4
+namelist integer nhyd_model config_w_adv_order 2
+namelist integer nhyd_model config_theta_adv_order 2
+namelist integer nhyd_model config_scalar_adv_order 2
+namelist integer nhyd_model config_u_vadv_order 2
+namelist integer nhyd_model config_w_vadv_order 2
+namelist integer nhyd_model config_theta_vadv_order 2
+namelist integer nhyd_model config_scalar_vadv_order 2
+namelist real nhyd_model config_coef_3rd_order 1.0
+namelist logical nhyd_model config_scalar_advection true
+namelist logical nhyd_model config_positive_definite false
+namelist logical nhyd_model config_monotonic true
+namelist logical nhyd_model config_mix_full true
+namelist real nhyd_model config_len_disp 0.
+namelist integer nhyd_model config_mp_physics 0.
+namelist real nhyd_model config_epssm 0.1
+namelist real nhyd_model config_smdiv 0.1
+namelist integer dimensions config_nvertlevels 26
+namelist integer dimensions config_nfglevels 27
+namelist character data_sources config_geog_data_path /data3/mp/wrfhelp/WPS_GEOG/
+namelist character data_sources config_met_prefix GFS
+namelist character data_sources config_init_date 2010-05-26_12
+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_decomp_file_prefix graph.info.part.
+namelist integer restart config_restart_interval 0
+namelist logical restart config_do_restart false
+namelist real restart config_restart_time 172800.0
+
+#
+# dim type name_in_file name_in_code
+#
+dim nCells nCells
+dim nEdges nEdges
+dim maxEdges maxEdges
+dim maxEdges2 maxEdges2
+dim nVertices nVertices
+dim TWO 2
+dim THREE 3
+dim vertexDegree vertexDegree
+dim FIFTEEN 15
+dim TWENTYONE 21
+dim R3 3
+dim nVertLevels namelist:config_nvertlevels
+dim nFGLevels namelist:config_nfglevels
+dim nVertLevelsP1 nVertLevels+1
+
+#
+# var type name_in_file ( dims ) iro- name_in_code super-array array_class
+#
+var persistent real xtime ( Time ) 2 o xtime state - -
+
+# horizontal grid structure
+
+var persistent real latCell ( nCells ) 0 io latCell mesh - -
+var persistent real lonCell ( nCells ) 0 io lonCell mesh - -
+var persistent real xCell ( nCells ) 0 io xCell mesh - -
+var persistent real yCell ( nCells ) 0 io yCell mesh - -
+var persistent real zCell ( nCells ) 0 io zCell mesh - -
+var persistent integer indexToCellID ( nCells ) 0 io indexToCellID mesh - -
+
+var persistent real latEdge ( nEdges ) 0 io latEdge mesh - -
+var persistent real lonEdge ( nEdges ) 0 io lonEdge mesh - -
+var persistent real xEdge ( nEdges ) 0 io xEdge mesh - -
+var persistent real yEdge ( nEdges ) 0 io yEdge mesh - -
+var persistent real zEdge ( nEdges ) 0 io zEdge mesh - -
+var persistent integer indexToEdgeID ( nEdges ) 0 io indexToEdgeID mesh - -
+
+var persistent real latVertex ( nVertices ) 0 io latVertex mesh - -
+var persistent real lonVertex ( nVertices ) 0 io lonVertex mesh - -
+var persistent real xVertex ( nVertices ) 0 io xVertex mesh - -
+var persistent real yVertex ( nVertices ) 0 io yVertex mesh - -
+var persistent real zVertex ( nVertices ) 0 io zVertex mesh - -
+var persistent integer indexToVertexID ( nVertices ) 0 io indexToVertexID mesh - -
+
+var persistent integer cellsOnEdge ( TWO nEdges ) 0 io cellsOnEdge mesh - -
+var persistent integer nEdgesOnCell ( nCells ) 0 io nEdgesOnCell mesh - -
+var persistent integer nEdgesOnEdge ( nEdges ) 0 io nEdgesOnEdge mesh - -
+var persistent integer edgesOnCell ( maxEdges nCells ) 0 io edgesOnCell mesh - -
+var persistent integer edgesOnEdge ( maxEdges2 nEdges ) 0 io edgesOnEdge mesh - -
+
+var persistent real weightsOnEdge ( maxEdges2 nEdges ) 0 io weightsOnEdge mesh - -
+var persistent real dvEdge ( nEdges ) 0 io dvEdge mesh - -
+var persistent real dcEdge ( nEdges ) 0 io dcEdge mesh - -
+var persistent real angleEdge ( nEdges ) 0 io angleEdge mesh - -
+var persistent real areaCell ( nCells ) 0 io areaCell mesh - -
+var persistent real areaTriangle ( nVertices ) 0 io areaTriangle mesh - -
+
+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 integer cellsOnCell ( maxEdges nCells ) 0 io cellsOnCell mesh - -
+var persistent integer verticesOnCell ( maxEdges nCells ) 0 io verticesOnCell mesh - -
+var persistent integer verticesOnEdge ( TWO nEdges ) 0 io verticesOnEdge mesh - -
+var persistent integer edgesOnVertex ( vertexDegree nVertices ) 0 io edgesOnVertex mesh - -
+var persistent integer cellsOnVertex ( vertexDegree nVertices ) 0 io cellsOnVertex mesh - -
+var persistent real kiteAreasOnVertex ( vertexDegree nVertices ) 0 io kiteAreasOnVertex mesh - -
+var persistent real fEdge ( nEdges ) 0 io fEdge mesh - -
+var persistent real fVertex ( nVertices ) 0 io fVertex mesh - -
+
+# some solver scalar coefficients
+
+# coefficients for vertical extrapolation to the surface
+var persistent real cf1 ( ) 0 io cf1 mesh - -
+var persistent real cf2 ( ) 0 io cf2 mesh - -
+var persistent real cf3 ( ) 0 io cf3 mesh - -
+
+# land use
+var persistent integer lu_index ( nCells ) 0 io lu_index mesh - -
+
+# description of the vertical grid structure
+
+var persistent real hx ( nVertLevelsP1 nCells ) 0 io hx mesh - -
+var persistent real zgrid ( nVertLevelsP1 nCells ) 0 io zgrid mesh - -
+var persistent real rdzw ( nVertLevels ) 0 io rdzw mesh - -
+var persistent real dzu ( nVertLevels ) 0 io dzu mesh - -
+var persistent real rdzu ( nVertLevels ) 0 io rdzu mesh - -
+var persistent real fzm ( nVertLevels ) 0 io fzm mesh - -
+var persistent real fzp ( nVertLevels ) 0 io fzp mesh - -
+var persistent real zx ( nVertLevelsP1 nEdges ) 0 io zx mesh - -
+var persistent real zz ( nVertLevelsP1 nCells ) 0 io zz mesh - -
+var persistent real zf ( nVertLevelsP1 TWO nEdges ) 0 io zf mesh - -
+var persistent real zf3 ( nVertLevelsP1 TWO nEdges ) 0 io zf3 mesh - -
+var persistent real zb ( nVertLevelsP1 TWO nEdges ) 0 io zb mesh - -
+var persistent real zb3 ( nVertLevelsP1 TWO nEdges ) 0 io zb3 mesh - -
+
+# W-Rayleigh-damping coefficient
+
+var persistent real dss ( nVertLevels nCells ) 0 io dss mesh - -
+
+# Horizontally interpolated from first-guess data
+var persistent real u_fg ( nFGLevels nEdges ) 0 o u fg - -
+var persistent real v_fg ( nFGLevels nEdges ) 0 o v fg - -
+var persistent real t_fg ( nFGLevels nCells ) 0 o t fg - -
+var persistent real p_fg ( nFGLevels nCells ) 0 o p fg - -
+var persistent real z_fg ( nFGLevels nCells ) 0 o z fg - -
+var persistent real rh_fg ( nFGLevels nCells ) 0 o rh fg - -
+var persistent real soilz_fg ( nCells ) 0 o soilz fg - -
+var persistent real psfc_fg ( nCells ) 0 o psfc fg - -
+var persistent real pmsl_fg ( nCells ) 0 o pmsl fg - -
+
+# Prognostic variables: read from input, saved in restart, and written to output
+var persistent real u ( nVertLevels nEdges Time ) 2 io u state - -
+var persistent real w ( nVertLevelsP1 nCells Time ) 2 io w state - -
+var persistent real rho ( nVertLevels nCells Time ) 2 io rho state - -
+var persistent real theta ( nVertLevels nCells Time ) 2 io theta state - -
+var persistent real qv ( nVertLevels nCells Time ) 2 io qv state scalars moist
+var persistent real qc ( nVertLevels nCells Time ) 2 io qc state scalars moist
+var persistent real qr ( nVertLevels nCells Time ) 2 io qr state scalars moist
+
+# state variables diagnosed from prognostic state
+var persistent real pressure_p ( nVertLevels nCells Time ) 1 - pressure_p diag - -
+
+var persistent real u_init ( nVertLevels ) 0 io u_init mesh - -
+var persistent real t_init ( nVertLevels nCells ) 0 io t_init mesh - -
+var persistent real qv_init ( nVertLevels ) 0 io qv_init mesh - -
+
+# Diagnostic fields: only written to output
+var persistent real v ( nVertLevels nEdges Time ) 1 o v diag - -
+var persistent real uReconstructX ( nVertLevels nCells Time ) 1 o uReconstructX diag - -
+var persistent real uReconstructY ( nVertLevels nCells Time ) 1 o uReconstructY diag - -
+var persistent real uReconstructZ ( nVertLevels nCells Time ) 1 o uReconstructZ diag - -
+var persistent real uReconstructZonal ( nVertLevels nCells Time ) 1 o uReconstructZonal diag - -
+var persistent real uReconstructMeridional ( nVertLevels nCells Time ) 1 o uReconstructMeridional diag - -
+
+var persistent real exner ( nVertLevels nCells Time ) 1 - exner diag - -
+var persistent real exner_base ( nVertLevels nCells Time ) 1 io exner_base diag - -
+var persistent real rtheta_base ( nVertLevels nCells Time ) 1 - rtheta_base diag - -
+var persistent real pressure_base ( nVertLevels nCells Time ) 1 io pressure_base diag - -
+var persistent real rho_base ( nVertLevels nCells Time ) 1 io rho_base diag - -
+var persistent real theta_base ( nVertLevels nCells Time ) 1 io theta_base diag - -
+
+var persistent real cqw ( nVertLevels nCells Time ) 1 - cqw diag - -
+
+# coupled variables needed by the solver, but not output...
+var persistent real ru ( nVertLevels nEdges Time ) 1 - ru diag - -
+var persistent real rw ( nVertLevelsP1 nCells Time ) 1 - rw diag - -
+var persistent real rtheta_p ( nVertLevels nCells Time ) 1 - rtheta_p diag - -
+var persistent real rho_p ( nVertLevels nCells Time ) 1 - rho_p diag - -
+
+# Space needed for advection
+var persistent real deriv_two ( FIFTEEN TWO nEdges ) 0 io deriv_two mesh - -
+var persistent integer advCells ( TWENTYONE nCells ) 0 io advCells mesh - -
+
+# Space needed for deformation calculation weights
+var persistent real defc_a ( maxEdges nCells ) 0 io defc_a mesh - -
+var persistent real defc_b ( maxEdges nCells ) 0 io defc_b mesh - -
+
+# Arrays required for reconstruction of velocity field
+var persistent real coeffs_reconstruct ( R3 maxEdges nCells ) 0 io coeffs_reconstruct mesh - -
+
Added: branches/atmos_physics/src/core_init_nhyd_atmos/module_advection.F
===================================================================
--- branches/atmos_physics/src/core_init_nhyd_atmos/module_advection.F (rev 0)
+++ branches/atmos_physics/src/core_init_nhyd_atmos/module_advection.F 2011-01-05 00:56:27 UTC (rev 673)
@@ -0,0 +1,933 @@
+module advection
+
+ use grid_types
+ use configure
+ use constants
+
+
+ contains
+
+
+ subroutine initialize_advection_rk( grid )
+
+!
+! compute the cell coefficients for the polynomial fit.
+! this is performed during setup for model integration.
+! WCS, 31 August 2009
+!
+ implicit none
+
+ type (mesh_type), intent(in) :: grid
+
+ real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
+ integer, dimension(:,:), pointer :: advCells
+
+! 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) :: 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) :: amatrix(25,25), bmatrix(25,25), wmatrix(25,25)
+ real (kind=RKIND) :: length_scale
+ integer :: ma,na, cell_add, mw, nn
+ integer, dimension(25) :: cell_list
+
+
+ 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
+ deriv_two => grid % deriv_two % array
+ deriv_two(:,:,:) = 0.
+
+ do iCell = 1, grid % nCells ! is this correct? - we need first halo cell also...
+
+ cell_list(1) = iCell
+ do i=2, grid % nEdgesOnCell % array(iCell)+1
+ cell_list(i) = grid % CellsOnCell % array(i-1,iCell)
+ end do
+ n = grid % nEdgesOnCell % array(iCell) + 1
+
+ if ( polynomial_order > 2 ) then
+ do i=2,grid % nEdgesOnCell % array(iCell) + 1
+ do j=1,grid % nEdgesOnCell % array ( cell_list(i) )
+ cell_add = grid % CellsOnCell % array (j,cell_list(i))
+ add_the_cell = .true.
+ do k=1,n
+ if ( cell_add == cell_list(k) ) add_the_cell = .false.
+ end do
+ if (add_the_cell) then
+ n = n+1
+ cell_list(n) = cell_add
+ end if
+ end do
+ end do
+ end if
+
+ advCells(1,iCell) = n
+
+! check to see if we are reaching outside the halo
+
+ do_the_cell = .true.
+ do i=1,n
+ if (cell_list(i) > grid % nCells) do_the_cell = .false.
+ end do
+
+
+ if ( .not. do_the_cell ) cycle
+
+
+! compute poynomial fit for this cell if all needed neighbors exist
+ if ( grid % on_a_sphere ) then
+
+ do i=1,n
+ advCells(i+1,iCell) = cell_list(i)
+ xc(i) = grid % xCell % array(advCells(i+1,iCell))/a
+ yc(i) = grid % yCell % array(advCells(i+1,iCell))/a
+ zc(i) = grid % zCell % array(advCells(i+1,iCell))/a
+ end do
+
+ theta_abs(iCell) = pii/2. - sphere_angle( xc(1), yc(1), zc(1), &
+ xc(2), yc(2), zc(2), &
+ 0., 0., 1. )
+
+! angles from cell center to neighbor centers (thetav)
+
+ do i=1,n-1
+
+ ip2 = i+2
+ if (ip2 > n) ip2 = 2
+
+ 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) = a*arc_length( xc(1), yc(1), zc(1), &
+ xc(i+1), yc(i+1), zc(i+1) )
+ end do
+
+ length_scale = 1.
+ do i=1,n-1
+ dl_sphere(i) = dl_sphere(i)/length_scale
+ end do
+
+! thetat(1) = 0. ! this defines the x direction, cell center 1 ->
+ thetat(1) = theta_abs(iCell) ! this defines the x direction, longitude line
+ do i=2,n-1
+ thetat(i) = thetat(i-1) + thetav(i-1)
+ end do
+
+ do i=1,n-1
+ xp(i) = cos(thetat(i)) * dl_sphere(i)
+ yp(i) = sin(thetat(i)) * dl_sphere(i)
+ end do
+
+ else ! On an x-y plane
+
+ do i=1,n-1
+
+ angle_2d(i) = grid%angleEdge%array(grid % EdgesOnCell % array(i,iCell))
+ 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 % 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))
+
+ end do
+
+ end if
+
+
+ ma = n-1
+ mw = grid % nEdgesOnCell % array (iCell)
+
+ bmatrix = 0.
+ amatrix = 0.
+ wmatrix = 0.
+
+ if (polynomial_order == 2) then
+ na = 6
+ ma = ma+1
+
+ amatrix(1,1) = 1.
+ wmatrix(1,1) = 1.
+ do i=2,ma
+ 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
+
+ wmatrix(i,i) = 1.
+ end do
+
+ else if (polynomial_order == 3) then
+ na = 10
+ ma = ma+1
+
+ amatrix(1,1) = 1.
+ wmatrix(1,1) = 1.
+ do i=2,ma
+ 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.
+
+ end do
+
+ else
+ na = 15
+ ma = ma+1
+
+ amatrix(1,1) = 1.
+ wmatrix(1,1) = 1.
+ do i=2,ma
+ 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)
+ amatrix(i,14) = xp(i-1) * (yp(i-1)**3)
+ amatrix(i,15) = yp(i-1)**4
+
+ 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 )
+
+ do i=1,grid % nEdgesOnCell % array (iCell)
+ ip1 = i+1
+ if (ip1 > n-1) ip1 = 1
+
+ iEdge = grid % EdgesOnCell % array (i,iCell)
+ xv1 = grid % xVertex % array(grid % verticesOnEdge % array (1,iedge))/a
+ yv1 = grid % yVertex % array(grid % verticesOnEdge % array (1,iedge))/a
+ zv1 = grid % zVertex % array(grid % verticesOnEdge % array (1,iedge))/a
+ xv2 = grid % xVertex % array(grid % verticesOnEdge % array (2,iedge))/a
+ yv2 = grid % yVertex % array(grid % verticesOnEdge % array (2,iedge))/a
+ zv2 = grid % zVertex % array(grid % verticesOnEdge % array (2,iedge))/a
+
+ if ( grid % on_a_sphere ) then
+ call arc_bisect( xv1, yv1, zv1, &
+ xv2, yv2, zv2, &
+ xec, yec, zec )
+
+ thetae_tmp = sphere_angle( xc(1), yc(1), zc(1), &
+ xc(i+1), yc(i+1), zc(i+1), &
+ xec, yec, zec )
+ thetae_tmp = thetae_tmp + thetat(i)
+ if (iCell == grid % cellsOnEdge % array(1,iEdge)) then
+ thetae(1,grid % EdgesOnCell % array (i,iCell)) = thetae_tmp
+ else
+ thetae(2,grid % EdgesOnCell % array (i,iCell)) = thetae_tmp
+ end if
+! else
+!
+! xe(grid % EdgesOnCell % array (i,iCell)) = 0.5 * (xv1 + xv2)
+! ye(grid % EdgesOnCell % array (i,iCell)) = 0.5 * (yv1 + yv2)
+
+ end if
+
+ end do
+
+! fill second derivative stencil for rk advection
+
+ do i=1, grid % nEdgesOnCell % array (iCell)
+ iEdge = grid % EdgesOnCell % array (i,iCell)
+
+
+ if ( grid % on_a_sphere ) then
+ if (iCell == grid % cellsOnEdge % array(1,iEdge)) then
+
+ cos2t = cos(thetae(1,grid % EdgesOnCell % array (i,iCell)))
+ sin2t = sin(thetae(1,grid % EdgesOnCell % array (i,iCell)))
+ costsint = cos2t*sin2t
+ cos2t = cos2t**2
+ sin2t = sin2t**2
+
+ do j=1,n
+ deriv_two(j,1,iEdge) = 2.*cos2t*bmatrix(4,j) &
+ + 2.*costsint*bmatrix(5,j) &
+ + 2.*sin2t*bmatrix(6,j)
+ end do
+ else
+
+ cos2t = cos(thetae(2,grid % EdgesOnCell % array (i,iCell)))
+ sin2t = sin(thetae(2,grid % EdgesOnCell % array (i,iCell)))
+ costsint = cos2t*sin2t
+ cos2t = cos2t**2
+ sin2t = sin2t**2
+
+ do j=1,n
+ deriv_two(j,2,iEdge) = 2.*cos2t*bmatrix(4,j) &
+ + 2.*costsint*bmatrix(5,j) &
+ + 2.*sin2t*bmatrix(6,j)
+ end do
+ end if
+
+ else
+
+ cos2t = cos(angle_2d(i))
+ sin2t = sin(angle_2d(i))
+ costsint = cos2t*sin2t
+ cos2t = cos2t**2
+ sin2t = sin2t**2
+
+! do j=1,n
+!
+! deriv_two(j,1,iEdge) = 2.*xe(iEdge)*xe(iEdge)*bmatrix(4,j) &
+! + 2.*xe(iEdge)*ye(iEdge)*bmatrix(5,j) &
+! + 2.*ye(iEdge)*ye(iEdge)*bmatrix(6,j)
+! end do
+
+ if (iCell == grid % cellsOnEdge % array(1,iEdge)) then
+ do j=1,n
+ deriv_two(j,1,iEdge) = 2.*cos2t*bmatrix(4,j) &
+ + 2.*costsint*bmatrix(5,j) &
+ + 2.*sin2t*bmatrix(6,j)
+ end do
+ else
+ do j=1,n
+ deriv_two(j,2,iEdge) = 2.*cos2t*bmatrix(4,j) &
+ + 2.*costsint*bmatrix(5,j) &
+ + 2.*sin2t*bmatrix(6,j)
+ end do
+ end if
+
+ end if
+ end do
+
+ end do ! end of loop over cells
+
+ if (debug) stop
+
+
+! write(0,*) ' check for deriv2 coefficients, iEdge 4 '
+!
+! iEdge = 4
+! j = 1
+! iCell = grid % cellsOnEdge % array(1,iEdge)
+! write(0,*) ' j, icell, coef ',j,iCell,deriv_two(j,1,iEdge)
+! do j=2,7
+! write(0,*) ' j, icell, coef ',j,grid % CellsOnCell % array(j-1,iCell),deriv_two(j,1,iEdge)
+! end do
+!
+! j = 1
+! iCell = grid % cellsOnEdge % array(2,iEdge)
+! write(0,*) ' j, icell, coef ',j,iCell,deriv_two(j,2,iEdge)
+! do j=2,7
+! write(0,*) ' j, icell, coef ',j,grid % CellsOnCell % array(j-1,iCell),deriv_two(j,2,iEdge)
+! end do
+! stop
+
+ end subroutine initialize_advection_rk
+
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! FUNCTION SPHERE_ANGLE
+ !
+ ! Computes the angle between arcs AB and AC, given points A, B, and C
+ ! Equation numbers w.r.t. http://mathworld.wolfram.com/SphericalTrigonometry.html
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ real function sphere_angle(ax, ay, az, bx, by, bz, cx, cy, cz)
+
+ implicit none
+
+ real (kind=RKIND), intent(in) :: ax, ay, az, bx, by, bz, cx, cy, cz
+
+ 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
+ real (kind=RKIND) :: Dz ! The k-components of the cross product AB x AC
+
+ real (kind=RKIND) :: s ! Semiperimeter of the triangle
+ real (kind=RKIND) :: sin_angle
+
+ a = acos(max(min(bx*cx + by*cy + bz*cz,1.0),-1.0)) ! Eqn. (3)
+ b = acos(max(min(ax*cx + ay*cy + az*cz,1.0),-1.0)) ! Eqn. (2)
+ c = acos(max(min(ax*bx + ay*by + az*bz,1.0),-1.0)) ! Eqn. (1)
+
+ ABx = bx - ax
+ ABy = by - ay
+ ABz = bz - az
+
+ ACx = cx - ax
+ ACy = cy - ay
+ ACz = cz - az
+
+ Dx = (ABy * ACz) - (ABz * ACy)
+ Dy = -((ABx * ACz) - (ABz * ACx))
+ Dz = (ABx * ACy) - (ABy * ACx)
+
+ s = 0.5*(a + b + c)
+! sin_angle = sqrt((sin(s-b)*sin(s-c))/(sin(b)*sin(c))) ! Eqn. (28)
+ sin_angle = sqrt(min(1.,max(0.,(sin(s-b)*sin(s-c))/(sin(b)*sin(c))))) ! Eqn. (28)
+
+ if ((Dx*ax + Dy*ay + Dz*az) >= 0.0) then
+ sphere_angle = 2.0 * asin(max(min(sin_angle,1.0),-1.0))
+ else
+ sphere_angle = -2.0 * asin(max(min(sin_angle,1.0),-1.0))
+ end if
+
+ end function sphere_angle
+
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! FUNCTION PLANE_ANGLE
+ !
+ ! Computes the angle between vectors AB and AC, given points A, B, and C, and
+ ! a vector (u,v,w) normal to the plane.
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ real function plane_angle(ax, ay, az, bx, by, bz, cx, cy, cz, u, v, w)
+
+ implicit none
+
+ real (kind=RKIND), intent(in) :: ax, ay, az, bx, by, bz, cx, cy, cz, u, v, w
+
+ 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
+ real (kind=RKIND) :: Dz ! The k-components of the cross product AB x AC
+
+ real (kind=RKIND) :: cos_angle
+
+ ABx = bx - ax
+ ABy = by - ay
+ ABz = bz - az
+ mAB = sqrt(ABx**2.0 + ABy**2.0 + ABz**2.0)
+
+ ACx = cx - ax
+ ACy = cy - ay
+ ACz = cz - az
+ mAC = sqrt(ACx**2.0 + ACy**2.0 + ACz**2.0)
+
+
+ Dx = (ABy * ACz) - (ABz * ACy)
+ Dy = -((ABx * ACz) - (ABz * ACx))
+ Dz = (ABx * ACy) - (ABy * ACx)
+
+ cos_angle = (ABx*ACx + ABy*ACy + ABz*ACz) / (mAB * mAC)
+
+ if ((Dx*u + Dy*v + Dz*w) >= 0.0) then
+ plane_angle = acos(max(min(cos_angle,1.0),-1.0))
+ else
+ plane_angle = -acos(max(min(cos_angle,1.0),-1.0))
+ end if
+
+ end function plane_angle
+
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! FUNCTION ARC_LENGTH
+ !
+ ! Returns the length of the great circle arc from A=(ax, ay, az) to
+ ! B=(bx, by, bz). It is assumed that both A and B lie on the surface of the
+ ! same sphere centered at the origin.
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ real function arc_length(ax, ay, az, bx, by, bz)
+
+ implicit none
+
+ real (kind=RKIND), intent(in) :: ax, ay, az, bx, by, bz
+
+ real (kind=RKIND) :: r, c
+ real (kind=RKIND) :: cx, cy, cz
+
+ cx = bx - ax
+ cy = by - ay
+ cz = bz - az
+
+! r = ax*ax + ay*ay + az*az
+! c = cx*cx + cy*cy + cz*cz
+!
+! arc_length = sqrt(r) * acos(1.0 - c/(2.0*r))
+
+ r = sqrt(ax*ax + ay*ay + az*az)
+ c = sqrt(cx*cx + cy*cy + cz*cz)
+! arc_length = sqrt(r) * 2.0 * asin(c/(2.0*r))
+ arc_length = r * 2.0 * asin(c/(2.0*r))
+
+ end function arc_length
+
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! SUBROUTINE ARC_BISECT
+ !
+ ! Returns the point C=(cx, cy, cz) that bisects the great circle arc from
+ ! A=(ax, ay, az) to B=(bx, by, bz). It is assumed that A and B lie on the
+ ! surface of a sphere centered at the origin.
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine arc_bisect(ax, ay, az, bx, by, bz, cx, cy, cz)
+
+ implicit none
+
+ real (kind=RKIND), intent(in) :: ax, ay, az, bx, by, bz
+ real (kind=RKIND), intent(out) :: cx, cy, cz
+
+ real (kind=RKIND) :: r ! Radius of the sphere
+ real (kind=RKIND) :: d
+
+ r = sqrt(ax*ax + ay*ay + az*az)
+
+ cx = 0.5*(ax + bx)
+ cy = 0.5*(ay + by)
+ cz = 0.5*(az + bz)
+
+ if (cx == 0. .and. cy == 0. .and. cz == 0.) then
+ write(0,*) 'Error: arc_bisect: A and B are diametrically opposite'
+ else
+ d = sqrt(cx*cx + cy*cy + cz*cz)
+ cx = r * cx / d
+ cy = r * cy / d
+ cz = r * cz / d
+ end if
+
+ end subroutine arc_bisect
+
+
+ subroutine poly_fit_2(a_in,b_out,weights_in,m,n,ne)
+
+ implicit none
+
+ integer, intent(in) :: m,n,ne
+ real (kind=RKIND), dimension(ne,ne), intent(in) :: a_in, weights_in
+ real (kind=RKIND), dimension(ne,ne), intent(out) :: b_out
+
+ ! local storage
+
+ real (kind=RKIND), dimension(m,n) :: a
+ 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
+ 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.
+
+ wt = transpose(w)
+ h = matmul(wt,w)
+ at = transpose(a)
+ ath = matmul(at,h)
+ atha = matmul(ath,a)
+
+ ata = matmul(at,a)
+
+! if (m == n) then
+! call migs(a,n,b,indx)
+! else
+
+ call migs(atha,n,atha_inv,indx)
+
+ b = matmul(atha_inv,ath)
+
+! call migs(ata,n,ata_inv,indx)
+! b = matmul(ata_inv,at)
+! end if
+ b_out(1:n,1:m) = b(1:n,1:m)
+
+! do i=1,n
+! write(6,*) ' i, indx ',i,indx(i)
+! end do
+!
+! write(6,*) ' '
+
+ 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
+
+
+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 = AMAX1(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 initialize_deformation_weights( grid )
+
+!
+! compute the cell coefficients for the deformation calculations
+! WCS, 13 July 2010
+!
+ implicit none
+
+ type (mesh_type), intent(in) :: grid
+
+ real (kind=RKIND), dimension(:,:), pointer :: defc_a, defc_b
+ integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnCell
+
+! 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) :: 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) :: length_scale
+ integer :: ma,na, cell_add, mw, nn
+ integer, dimension(25) :: cell_list
+
+ integer :: cell1, cell2, iv
+ logical :: do_the_cell
+ real (kind=RKIND) :: area_cell, sint2, cost2, sint_cost, sumw1, sumw2, xptt, area_cellt
+
+ logical, parameter :: debug = .false.
+
+ if (debug) write(0,*) ' in def weight calc '
+
+ defc_a => grid % defc_a % array
+ defc_b => grid % defc_b % array
+ cellsOnEdge => grid % cellsOnEdge % array
+ edgesOnCell => grid % edgesOnCell % array
+
+ defc_a(:,:) = 0.
+ defc_b(:,:) = 0.
+
+ pii = 2.*asin(1.0)
+
+ if (debug) write(0,*) ' beginning cell loop '
+
+ do iCell = 1, grid % nCells
+
+ if (debug) write(0,*) ' cell loop ', iCell
+
+ cell_list(1) = iCell
+ do i=2, grid % nEdgesOnCell % array(iCell)+1
+ cell_list(i) = grid % CellsOnCell % array(i-1,iCell)
+ end do
+ n = grid % nEdgesOnCell % array(iCell) + 1
+
+! check to see if we are reaching outside the halo
+
+ if (debug) write(0,*) ' points ', n
+
+ do_the_cell = .true.
+ do i=1,n
+ if (cell_list(i) > grid % nCells) do_the_cell = .false.
+ end do
+
+
+ if (.not. do_the_cell) cycle
+
+
+! compute poynomial fit for this cell if all needed neighbors exist
+ if (grid % on_a_sphere) then
+
+ xc(1) = grid % xCell % array(iCell)/a
+ yc(1) = grid % yCell % array(iCell)/a
+ zc(1) = grid % zCell % array(iCell)/a
+
+
+ do i=2,n
+ iv = grid % verticesOnCell % array(i-1,iCell)
+ xc(i) = grid % xVertex % array(iv)/a
+ yc(i) = grid % yVertex % array(iv)/a
+ zc(i) = grid % zVertex % array(iv)/a
+ end do
+
+ theta_abs(iCell) = pii/2. - sphere_angle( xc(1), yc(1), zc(1), &
+ xc(2), yc(2), zc(2), &
+ 0., 0., 1. )
+
+! angles from cell center to neighbor centers (thetav)
+
+ do i=1,n-1
+
+ ip2 = i+2
+ if (ip2 > n) ip2 = 2
+
+ 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) = a*arc_length( xc(1), yc(1), zc(1), &
+ xc(i+1), yc(i+1), zc(i+1) )
+ end do
+
+ length_scale = 1.
+ do i=1,n-1
+ dl_sphere(i) = dl_sphere(i)/length_scale
+ end do
+
+ thetat(1) = 0. ! this defines the x direction, cell center 1 ->
+! thetat(1) = theta_abs(iCell) ! this defines the x direction, longitude line
+ do i=2,n-1
+ thetat(i) = thetat(i-1) + thetav(i-1)
+ end do
+
+ do i=1,n-1
+ xp(i) = cos(thetat(i)) * dl_sphere(i)
+ yp(i) = sin(thetat(i)) * dl_sphere(i)
+ end do
+
+ else ! On an x-y plane
+
+ xp(1) = grid % xCell % array(iCell)
+ yp(1) = grid % yCell % array(iCell)
+
+
+ do i=2,n
+ iv = grid % verticesOnCell % array(i-1,iCell)
+ xp(i) = grid % xVertex % array(iv)
+ yp(i) = grid % yVertex % array(iv)
+ end do
+
+ end if
+
+! thetat(1) = 0.
+ thetat(1) = theta_abs(iCell)
+ do i=2,n-1
+ ip1 = i+1
+ if (ip1 == n) ip1 = 1
+ thetat(i) = plane_angle( 0.,0.,0., &
+ xp(i)-xp(i-1), yp(i)-yp(i-1), 0., &
+ xp(ip1)-xp(i), yp(ip1)-yp(i), 0., &
+ 0., 0., 1.)
+ thetat(i) = thetat(i) + thetat(i-1)
+ end do
+
+ area_cell = 0.
+ area_cellt = 0.
+ do i=1,n-1
+ ip1 = i+1
+ if (ip1 == n) ip1 = 1
+ dl = sqrt((xp(ip1)-xp(i))**2 + (yp(ip1)-yp(i))**2)
+ area_cell = area_cell + 0.25*(xp(i)+xp(ip1))*(yp(ip1)-yp(i)) - 0.25*(yp(i)+yp(ip1))*(xp(ip1)-xp(i))
+ area_cellt = area_cellt + (0.25*(xp(i)+xp(ip1))*cos(thetat(i)) + 0.25*(yp(i)+yp(ip1))*sin(thetat(i)))*dl
+ end do
+ if (debug) write(0,*) ' area_cell, area_cellt ',area_cell, area_cellt,area_cell-area_cellt
+
+ do i=1,n-1
+ ip1 = i+1
+ if (ip1 == n) ip1 = 1
+ dl = sqrt((xp(ip1)-xp(i))**2 + (yp(ip1)-yp(i))**2)
+ sint2 = (sin(thetat(i)))**2
+ cost2 = (cos(thetat(i)))**2
+ sint_cost = sin(thetat(i))*cos(thetat(i))
+ defc_a(i,iCell) = dl*(cost2 - sint2)/area_cell
+ defc_b(i,iCell) = dl*2.*sint_cost/area_cell
+ if (cellsOnEdge(1,EdgesOnCell(i,iCell)) /= iCell) then
+ defc_a(i,iCell) = - defc_a(i,iCell)
+ defc_b(i,iCell) = - defc_b(i,iCell)
+ end if
+
+ end do
+
+ end do
+
+ if (debug) write(0,*) ' exiting def weight calc '
+
+ end subroutine initialize_deformation_weights
+
+end module advection
Added: branches/atmos_physics/src/core_init_nhyd_atmos/module_llxy.F
===================================================================
--- branches/atmos_physics/src/core_init_nhyd_atmos/module_llxy.F (rev 0)
+++ branches/atmos_physics/src/core_init_nhyd_atmos/module_llxy.F 2011-01-05 00:56:27 UTC (rev 673)
@@ -0,0 +1,2226 @@
+MODULE llxy
+
+! Module that defines constants, data structures, and
+! subroutines used to convert grid indices to lat/lon
+! and vice versa.
+!
+! SUPPORTED PROJECTIONS
+! ---------------------
+! Cylindrical Lat/Lon (code = PROJ_LATLON)
+! Mercator (code = PROJ_MERC)
+! Lambert Conformal (code = PROJ_LC)
+! Gaussian (code = PROJ_GAUSS)
+! Polar Stereographic (code = PROJ_PS)
+! Rotated Lat/Lon (code = PROJ_ROTLL)
+!
+! REMARKS
+! -------
+! The routines contained within were adapted from routines
+! obtained from NCEP's w3 library. The original NCEP routines were less
+! flexible (e.g., polar-stereo routines only supported truelat of 60N/60S)
+! than what we needed, so modifications based on equations in Hoke, Hayes, and
+! Renninger (AFGWC/TN/79-003) were added to improve the flexibility.
+! Additionally, coding was improved to F90 standards and the routines were
+! combined into this module.
+!
+! ASSUMPTIONS
+! -----------
+! Grid Definition:
+! For mercator, lambert conformal, and polar-stereographic projections,
+! the routines within assume the following:
+!
+! 1. Grid is dimensioned (i,j) where i is the East-West direction,
+! positive toward the east, and j is the north-south direction,
+! positive toward the north.
+! 2. Origin is at (1,1) and is located at the southwest corner,
+! regardless of hemispere.
+! 3. Grid spacing (dx) is always positive.
+! 4. Values of true latitudes must be positive for NH domains
+! and negative for SH domains.
+!
+! For the latlon and Gaussian projection, the grid origin may be at any
+! of the corners, and the deltalat and deltalon values can be signed to
+! account for this using the following convention:
+! Origin Location Deltalat Sign Deltalon Sign
+! --------------- ------------- -------------
+! SW Corner + +
+! NE Corner - -
+! NW Corner - +
+! SE Corner + -
+!
+! Data Definitions:
+! 1. Any arguments that are a latitude value are expressed in
+! degrees north with a valid range of -90 -> 90
+! 2. Any arguments that are a longitude value are expressed in
+! degrees east with a valid range of -180 -> 180.
+! 3. Distances are in meters and are always positive.
+! 4. The standard longitude (stdlon) is defined as the longitude
+! line which is parallel to the grid's y-axis (j-direction), along
+! which latitude increases (NOT the absolute value of latitude, but
+! the actual latitude, such that latitude increases continuously
+! from the south pole to the north pole) as j increases.
+! 5. One true latitude value is required for polar-stereographic and
+! mercator projections, and defines at which latitude the
+! grid spacing is true. For lambert conformal, two true latitude
+! values must be specified, but may be set equal to each other to
+! specify a tangent projection instead of a secant projection.
+!
+! USAGE
+! -----
+! To use the routines in this module, the calling routines must have the
+! following statement at the beginning of its declaration block:
+! USE map_utils
+!
+! The use of the module not only provides access to the necessary routines,
+! but also defines a structure of TYPE (proj_info) that can be used
+! to declare a variable of the same type to hold your map projection
+! information. It also defines some integer parameters that contain
+! the projection codes so one only has to use those variable names rather
+! than remembering the acutal code when using them. The basic steps are
+! as follows:
+!
+! 1. Ensure the "USE map_utils" is in your declarations.
+! 2. Declare the projection information structure as type(proj_info):
+! TYPE(proj_info) :: proj
+! 3. Populate your structure by calling the map_set routine:
+! CALL map_set(code,lat1,lon1,knowni,knownj,dx,stdlon,truelat1,truelat2,proj)
+! where:
+! code (input) = one of PROJ_LATLON, PROJ_MERC, PROJ_LC, PROJ_PS,
+! PROJ_GAUSS, or PROJ_ROTLL
+! lat1 (input) = Latitude of grid origin point (i,j)=(1,1)
+! (see assumptions!)
+! lon1 (input) = Longitude of grid origin
+! knowni (input) = origin point, x-location
+! knownj (input) = origin point, y-location
+! dx (input) = grid spacing in meters (ignored for LATLON projections)
+! stdlon (input) = Standard longitude for PROJ_PS and PROJ_LC,
+! deltalon (see assumptions) for PROJ_LATLON,
+! ignored for PROJ_MERC
+! truelat1 (input) = 1st true latitude for PROJ_PS, PROJ_LC, and
+! PROJ_MERC, deltalat (see assumptions) for PROJ_LATLON
+! truelat2 (input) = 2nd true latitude for PROJ_LC,
+! ignored for all others.
+! proj (output) = The structure of type (proj_info) that will be fully
+! populated after this call
+!
+! 4. Now that the proj structure is populated, you may call either
+! of the following routines:
+!
+! latlon_to_ij(proj, lat, lon, i, j)
+! ij_to_latlon(proj, i, j, lat, lon)
+!
+! It is incumbent upon the calling routine to determine whether or
+! not the values returned are within your domain's bounds. All values
+! of i, j, lat, and lon are REAL values.
+!
+!
+! REFERENCES
+! ----------
+! Hoke, Hayes, and Renninger, "Map Preojections and Grid Systems for
+! Meteorological Applications." AFGWC/TN-79/003(Rev), Air Weather
+! Service, 1985.
+!
+! NCAR MM5v3 Modeling System, REGRIDDER program, module_first_guess_map.F
+! NCEP routines w3fb06, w3fb07, w3fb08, w3fb09, w3fb11, w3fb12
+!
+! HISTORY
+! -------
+! 27 Mar 2001 - Original Version
+! Brent L. Shaw, NOAA/FSL (CSU/CIRA)
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ INTEGER, PARAMETER :: HH=4, VV=5
+
+ REAL (KIND=4), PARAMETER :: PI = 3.141592653589793
+
+ REAL (KIND=4), PARAMETER :: DEG_PER_RAD = 180./PI
+ REAL (KIND=4), PARAMETER :: RAD_PER_DEG = PI/180.
+
+ REAL (KIND=4), PARAMETER :: A_WGS84 = 6378137.
+ REAL (KIND=4), PARAMETER :: B_WGS84 = 6356752.314
+ REAL (KIND=4), PARAMETER :: RE_WGS84 = A_WGS84
+ REAL (KIND=4), PARAMETER :: E_WGS84 = 0.081819192
+
+ REAL (KIND=4), PARAMETER :: A_NAD83 = 6378137.
+ REAL (KIND=4), PARAMETER :: RE_NAD83 = A_NAD83
+ REAL (KIND=4), PARAMETER :: E_NAD83 = 0.0818187034
+
+ REAL (KIND=4), PARAMETER :: EARTH_RADIUS_M = 6370000.
+ REAL (KIND=4), PARAMETER :: EARTH_CIRC_M = 2.*PI*EARTH_RADIUS_M
+
+ INTEGER, PUBLIC, PARAMETER :: PROJ_LATLON = 0
+ INTEGER, PUBLIC, PARAMETER :: PROJ_LC = 1
+ INTEGER, PUBLIC, PARAMETER :: PROJ_PS = 2
+ INTEGER, PUBLIC, PARAMETER :: PROJ_PS_WGS84 = 102
+ INTEGER, PUBLIC, PARAMETER :: PROJ_MERC = 3
+ INTEGER, PUBLIC, PARAMETER :: PROJ_GAUSS = 4
+ INTEGER, PUBLIC, PARAMETER :: PROJ_CYL = 5
+ INTEGER, PUBLIC, PARAMETER :: PROJ_CASSINI = 6
+ INTEGER, PUBLIC, PARAMETER :: PROJ_ALBERS_NAD83 = 105
+ INTEGER, PUBLIC, PARAMETER :: PROJ_ROTLL = 203
+
+ ! Define some private constants
+ INTEGER, PRIVATE, PARAMETER :: HIGH = 8
+
+ TYPE proj_info
+
+ INTEGER :: code ! Integer code for projection TYPE
+ INTEGER :: nlat ! For Gaussian -- number of latitude points
+ ! north of the equator
+ INTEGER :: nlon !
+ !
+ INTEGER :: ixdim ! For Rotated Lat/Lon -- number of mass points
+ ! in an odd row
+ INTEGER :: jydim ! For Rotated Lat/Lon -- number of rows
+ INTEGER :: stagger ! For Rotated Lat/Lon -- mass or velocity grid
+ REAL (KIND=4) :: phi ! For Rotated Lat/Lon -- domain half-extent in
+ ! degrees latitude
+ REAL (KIND=4) :: lambda ! For Rotated Lat/Lon -- domain half-extend in
+ ! degrees longitude
+ REAL (KIND=4) :: lat1 ! SW latitude (1,1) in degrees (-90->90N)
+ REAL (KIND=4) :: lon1 ! SW longitude (1,1) in degrees (-180->180E)
+ REAL (KIND=4) :: lat0 ! For Cassini, latitude of projection pole
+ REAL (KIND=4) :: lon0 ! For Cassini, longitude of projection pole
+ REAL (KIND=4) :: dx ! Grid spacing in meters at truelats, used
+ ! only for ps, lc, and merc projections
+ REAL (KIND=4) :: dy ! Grid spacing in meters at truelats, used
+ ! only for ps, lc, and merc projections
+ REAL (KIND=4) :: latinc ! Latitude increment for cylindrical lat/lon
+ REAL (KIND=4) :: loninc ! Longitude increment for cylindrical lat/lon
+ ! also the lon increment for Gaussian grid
+ REAL (KIND=4) :: dlat ! Lat increment for lat/lon grids
+ REAL (KIND=4) :: dlon ! Lon increment for lat/lon grids
+ REAL (KIND=4) :: stdlon ! Longitude parallel to y-axis (-180->180E)
+ REAL (KIND=4) :: truelat1 ! First true latitude (all projections)
+ REAL (KIND=4) :: truelat2 ! Second true lat (LC only)
+ REAL (KIND=4) :: hemi ! 1 for NH, -1 for SH
+ REAL (KIND=4) :: cone ! Cone factor for LC projections
+ REAL (KIND=4) :: polei ! Computed i-location of pole point
+ REAL (KIND=4) :: polej ! Computed j-location of pole point
+ REAL (KIND=4) :: rsw ! Computed radius to SW corner
+ REAL (KIND=4) :: rebydx ! Earth radius divided by dx
+ REAL (KIND=4) :: knowni ! X-location of known lat/lon
+ REAL (KIND=4) :: knownj ! Y-location of known lat/lon
+ REAL (KIND=4) :: re_m ! Radius of spherical earth, meters
+ REAL (KIND=4) :: rho0 ! For Albers equal area
+ REAL (KIND=4) :: nc ! For Albers equal area
+ REAL (KIND=4) :: bigc ! For Albers equal area
+ LOGICAL :: init ! Flag to indicate if this struct is
+ ! ready for use
+ LOGICAL :: wrap ! For Gaussian -- flag to indicate wrapping
+ ! around globe?
+ REAL (KIND=4), POINTER, DIMENSION(:) :: gauss_lat ! Latitude array for Gaussian grid
+
+ END TYPE proj_info
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ CONTAINS
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ SUBROUTINE map_init(proj)
+ ! Initializes the map projection structure to missing values
+
+ IMPLICIT NONE
+ TYPE(proj_info), INTENT(INOUT) :: proj
+
+ proj%lat1 = -999.9
+ proj%lon1 = -999.9
+ proj%lat0 = -999.9
+ proj%lon0 = -999.9
+ proj%dx = -999.9
+ proj%dy = -999.9
+ proj%latinc = -999.9
+ proj%loninc = -999.9
+ proj%stdlon = -999.9
+ proj%truelat1 = -999.9
+ proj%truelat2 = -999.9
+ proj%phi = -999.9
+ proj%lambda = -999.9
+ proj%ixdim = -999
+ proj%jydim = -999
+ proj%stagger = HH
+ proj%nlat = 0
+ proj%nlon = 0
+ proj%hemi = 0.0
+ proj%cone = -999.9
+ proj%polei = -999.9
+ proj%polej = -999.9
+ proj%rsw = -999.9
+ proj%knowni = -999.9
+ proj%knownj = -999.9
+ proj%re_m = EARTH_RADIUS_M
+ proj%init = .FALSE.
+ proj%wrap = .FALSE.
+ proj%rho0 = 0.
+ proj%nc = 0.
+ proj%bigc = 0.
+ nullify(proj%gauss_lat)
+
+ END SUBROUTINE map_init
+
+
+ SUBROUTINE map_set(proj_code, proj, lat1, lon1, lat0, lon0, knowni, knownj, dx, latinc, &
+ loninc, stdlon, truelat1, truelat2, nlat, nlon, ixdim, jydim, &
+ stagger, phi, lambda, r_earth)
+ ! Given a partially filled proj_info structure, this routine computes
+ ! polei, polej, rsw, and cone (if LC projection) to complete the
+ ! structure. This allows us to eliminate redundant calculations when
+ ! calling the coordinate conversion routines multiple times for the
+ ! same map.
+ ! This will generally be the first routine called when a user wants
+ ! to be able to use the coordinate conversion routines, and it
+ ! will call the appropriate subroutines based on the
+ ! proj%code which indicates which projection type this is.
+
+ IMPLICIT NONE
+
+ ! Declare arguments
+ INTEGER, INTENT(IN) :: proj_code
+ INTEGER, INTENT(IN), OPTIONAL :: nlat
+ INTEGER, INTENT(IN), OPTIONAL :: nlon
+ INTEGER, INTENT(IN), OPTIONAL :: ixdim
+ INTEGER, INTENT(IN), OPTIONAL :: jydim
+ INTEGER, INTENT(IN), OPTIONAL :: stagger
+ REAL (KIND=4), INTENT(IN), OPTIONAL :: latinc
+ REAL (KIND=4), INTENT(IN), OPTIONAL :: loninc
+ REAL (KIND=4), INTENT(IN), OPTIONAL :: lat1
+ REAL (KIND=4), INTENT(IN), OPTIONAL :: lon1
+ REAL (KIND=4), INTENT(IN), OPTIONAL :: lat0
+ REAL (KIND=4), INTENT(IN), OPTIONAL :: lon0
+ REAL (KIND=4), INTENT(IN), OPTIONAL :: dx
+ REAL (KIND=4), INTENT(IN), OPTIONAL :: stdlon
+ REAL (KIND=4), INTENT(IN), OPTIONAL :: truelat1
+ REAL (KIND=4), INTENT(IN), OPTIONAL :: truelat2
+ REAL (KIND=4), INTENT(IN), OPTIONAL :: knowni
+ REAL (KIND=4), INTENT(IN), OPTIONAL :: knownj
+ REAL (KIND=4), INTENT(IN), OPTIONAL :: phi
+ REAL (KIND=4), INTENT(IN), OPTIONAL :: lambda
+ REAL (KIND=4), INTENT(IN), OPTIONAL :: r_earth
+ TYPE(proj_info), INTENT(OUT) :: proj
+
+ INTEGER :: iter
+ REAL (KIND=4) :: dummy_lon1
+ REAL (KIND=4) :: dummy_lon0
+ REAL (KIND=4) :: dummy_stdlon
+
+ ! First, verify that mandatory parameters are present for the specified proj_code
+ IF ( proj_code == PROJ_LC ) THEN
+ IF ( .NOT.PRESENT(truelat1) .OR. &
+ .NOT.PRESENT(truelat2) .OR. &
+ .NOT.PRESENT(lat1) .OR. &
+ .NOT.PRESENT(lon1) .OR. &
+ .NOT.PRESENT(knowni) .OR. &
+ .NOT.PRESENT(knownj) .OR. &
+ .NOT.PRESENT(stdlon) .OR. &
+ .NOT.PRESENT(dx) ) THEN
+ PRINT '(A,I2)', 'The following are mandatory parameters for projection code : ', proj_code
+ PRINT '(A)', ' truelat1, truelat2, lat1, lon1, knowni, knownj, stdlon, dx'
+ CALL llxy_error_fatal ( 'MAP_INIT' )
+ END IF
+ ELSE IF ( proj_code == PROJ_PS ) THEN
+ IF ( .NOT.PRESENT(truelat1) .OR. &
+ .NOT.PRESENT(lat1) .OR. &
+ .NOT.PRESENT(lon1) .OR. &
+ .NOT.PRESENT(knowni) .OR. &
+ .NOT.PRESENT(knownj) .OR. &
+ .NOT.PRESENT(stdlon) .OR. &
+ .NOT.PRESENT(dx) ) THEN
+ PRINT '(A,I2)', 'The following are mandatory parameters for projection code : ', proj_code
+ PRINT '(A)', ' truelat1, lat1, lon1, knonwi, knownj, stdlon, dx'
+ CALL llxy_error_fatal ( 'MAP_INIT' )
+ END IF
+ ELSE IF ( proj_code == PROJ_PS_WGS84 ) THEN
+ IF ( .NOT.PRESENT(truelat1) .OR. &
+ .NOT.PRESENT(lat1) .OR. &
+ .NOT.PRESENT(lon1) .OR. &
+ .NOT.PRESENT(knowni) .OR. &
+ .NOT.PRESENT(knownj) .OR. &
+ .NOT.PRESENT(stdlon) .OR. &
+ .NOT.PRESENT(dx) ) THEN
+ PRINT '(A,I2)', 'The following are mandatory parameters for projection code : ', proj_code
+ PRINT '(A)', ' truelat1, lat1, lon1, knonwi, knownj, stdlon, dx'
+ CALL llxy_error_fatal ( 'MAP_INIT' )
+ END IF
+ ELSE IF ( proj_code == PROJ_ALBERS_NAD83 ) THEN
+ IF ( .NOT.PRESENT(truelat1) .OR. &
+ .NOT.PRESENT(truelat2) .OR. &
+ .NOT.PRESENT(lat1) .OR. &
+ .NOT.PRESENT(lon1) .OR. &
+ .NOT.PRESENT(knowni) .OR. &
+ .NOT.PRESENT(knownj) .OR. &
+ .NOT.PRESENT(stdlon) .OR. &
+ .NOT.PRESENT(dx) ) THEN
+ PRINT '(A,I2)', 'The following are mandatory parameters for projection code : ', proj_code
+ PRINT '(A)', ' truelat1, truelat2, lat1, lon1, knonwi, knownj, stdlon, dx'
+ CALL llxy_error_fatal ( 'MAP_INIT' )
+ END IF
+ ELSE IF ( proj_code == PROJ_MERC ) THEN
+ IF ( .NOT.PRESENT(truelat1) .OR. &
+ .NOT.PRESENT(lat1) .OR. &
+ .NOT.PRESENT(lon1) .OR. &
+ .NOT.PRESENT(knowni) .OR. &
+ .NOT.PRESENT(knownj) .OR. &
+ .NOT.PRESENT(dx) ) THEN
+ PRINT '(A,I2)', 'The following are mandatory parameters for projection code : ', proj_code
+ PRINT '(A)', ' truelat1, lat1, lon1, knowni, knownj, dx'
+ CALL llxy_error_fatal ( 'MAP_INIT' )
+ END IF
+ ELSE IF ( proj_code == PROJ_LATLON ) THEN
+ IF ( .NOT.PRESENT(latinc) .OR. &
+ .NOT.PRESENT(loninc) .OR. &
+ .NOT.PRESENT(knowni) .OR. &
+ .NOT.PRESENT(knownj) .OR. &
+ .NOT.PRESENT(lat1) .OR. &
+ .NOT.PRESENT(lon1) ) THEN
+ PRINT '(A,I2)', 'The following are mandatory parameters for projection code : ', proj_code
+ PRINT '(A)', ' latinc, loninc, knowni, knownj, lat1, lon1'
+ CALL llxy_error_fatal ( 'MAP_INIT' )
+ END IF
+ ELSE IF ( proj_code == PROJ_CYL ) THEN
+ IF ( .NOT.PRESENT(latinc) .OR. &
+ .NOT.PRESENT(loninc) .OR. &
+ .NOT.PRESENT(stdlon) ) THEN
+ PRINT '(A,I2)', 'The following are mandatory parameters for projection code : ', proj_code
+ PRINT '(A)', ' latinc, loninc, stdlon'
+ CALL llxy_error_fatal ( 'MAP_INIT' )
+ END IF
+ ELSE IF ( proj_code == PROJ_CASSINI ) THEN
+ IF ( .NOT.PRESENT(latinc) .OR. &
+ .NOT.PRESENT(loninc) .OR. &
+ .NOT.PRESENT(lat1) .OR. &
+ .NOT.PRESENT(lon1) .OR. &
+ .NOT.PRESENT(lat0) .OR. &
+ .NOT.PRESENT(lon0) .OR. &
+ .NOT.PRESENT(knowni) .OR. &
+ .NOT.PRESENT(knownj) .OR. &
+ .NOT.PRESENT(stdlon) ) THEN
+ PRINT '(A,I2)', 'The following are mandatory parameters for projection code : ', proj_code
+ PRINT '(A)', ' latinc, loninc, lat1, lon1, knowni, knownj, lat0, lon0, stdlon'
+ CALL llxy_error_fatal ( 'MAP_INIT' )
+ END IF
+ ELSE IF ( proj_code == PROJ_GAUSS ) THEN
+ IF ( .NOT.PRESENT(nlat) .OR. &
+ .NOT.PRESENT(lat1) .OR. &
+ .NOT.PRESENT(lon1) .OR. &
+ .NOT.PRESENT(loninc) ) THEN
+ PRINT '(A,I2)', 'The following are mandatory parameters for projection code : ', proj_code
+ PRINT '(A)', ' nlat, lat1, lon1, loninc'
+ CALL llxy_error_fatal ( 'MAP_INIT' )
+ END IF
+ ELSE IF ( proj_code == PROJ_ROTLL ) THEN
+ IF ( .NOT.PRESENT(ixdim) .OR. &
+ .NOT.PRESENT(jydim) .OR. &
+ .NOT.PRESENT(phi) .OR. &
+ .NOT.PRESENT(lambda) .OR. &
+ .NOT.PRESENT(lat1) .OR. &
+ .NOT.PRESENT(lon1) .OR. &
+ .NOT.PRESENT(stagger) ) THEN
+ PRINT '(A,I2)', 'The following are mandatory parameters for projection code : ', proj_code
+ PRINT '(A)', ' ixdim, jydim, phi, lambda, lat1, lon1, stagger'
+ CALL llxy_error_fatal ( 'MAP_INIT' )
+ END IF
+ ELSE
+ PRINT '(A,I2)', 'Unknown projection code: ', proj_code
+ CALL llxy_error_fatal ( 'MAP_INIT' )
+ END IF
+
+ ! Check for validity of mandatory variables in proj
+ IF ( PRESENT(lat1) ) THEN
+ IF ( ABS(lat1) .GT. 90. ) THEN
+ PRINT '(A)', 'Latitude of origin corner required as follows:'
+ PRINT '(A)', ' -90N <= lat1 < = 90.N'
+ CALL llxy_error_fatal ( 'MAP_INIT' )
+ ENDIF
+ ENDIF
+
+ IF ( PRESENT(lon1) ) THEN
+ dummy_lon1 = lon1
+ IF ( ABS(dummy_lon1) .GT. 180.) THEN
+ iter = 0
+ DO WHILE (ABS(dummy_lon1) > 180. .AND. iter < 10)
+ IF (dummy_lon1 < -180.) dummy_lon1 = dummy_lon1 + 360.
+ IF (dummy_lon1 > 180.) dummy_lon1 = dummy_lon1 - 360.
+ iter = iter + 1
+ END DO
+ IF (abs(dummy_lon1) > 180.) THEN
+ PRINT '(A)', 'Longitude of origin required as follows:'
+ PRINT '(A)', ' -180E <= lon1 <= 180W'
+ CALL llxy_error_fatal ( 'MAP_INIT' )
+ ENDIF
+ ENDIF
+ ENDIF
+
+ IF ( PRESENT(lon0) ) THEN
+ dummy_lon0 = lon0
+ IF ( ABS(dummy_lon0) .GT. 180.) THEN
+ iter = 0
+ DO WHILE (ABS(dummy_lon0) > 180. .AND. iter < 10)
+ IF (dummy_lon0 < -180.) dummy_lon0 = dummy_lon0 + 360.
+ IF (dummy_lon0 > 180.) dummy_lon0 = dummy_lon0 - 360.
+ iter = iter + 1
+ END DO
+ IF (abs(dummy_lon0) > 180.) THEN
+ PRINT '(A)', 'Longitude of pole required as follows:'
+ PRINT '(A)', ' -180E <= lon0 <= 180W'
+ CALL llxy_error_fatal ( 'MAP_INIT' )
+ ENDIF
+ ENDIF
+ ENDIF
+
+ IF ( PRESENT(dx) ) THEN
+ IF ((dx .LE. 0.).AND.(proj_code .NE. PROJ_LATLON)) THEN
+ PRINT '(A)', 'Require grid spacing (dx) in meters be positive'
+ CALL llxy_error_fatal ( 'MAP_INIT' )
+ ENDIF
+ ENDIF
+
+ IF ( PRESENT(stdlon) ) THEN
+ dummy_stdlon = stdlon
+ IF ((ABS(dummy_stdlon) > 180.).AND.(proj_code /= PROJ_MERC)) THEN
+ iter = 0
+ DO WHILE (ABS(dummy_stdlon) > 180. .AND. iter < 10)
+ IF (dummy_stdlon < -180.) dummy_stdlon = dummy_stdlon + 360.
+ IF (dummy_stdlon > 180.) dummy_stdlon = dummy_stdlon - 360.
+ iter = iter + 1
+ END DO
+ IF (abs(dummy_stdlon) > 180.) THEN
+ PRINT '(A)', 'Need orientation longitude (stdlon) as: '
+ PRINT '(A)', ' -180E <= stdlon <= 180W'
+ CALL llxy_error_fatal ( 'MAP_INIT' )
+ ENDIF
+ ENDIF
+ ENDIF
+
+ IF ( PRESENT(truelat1) ) THEN
+ IF (ABS(truelat1).GT.90.) THEN
+ PRINT '(A)', 'Set true latitude 1 for all projections'
+ CALL llxy_error_fatal ( 'MAP_INIT' )
+ ENDIF
+ ENDIF
+
+ CALL map_init(proj)
+ proj%code = proj_code
+ IF ( PRESENT(lat1) ) proj%lat1 = lat1
+ IF ( PRESENT(lon1) ) proj%lon1 = dummy_lon1
+ IF ( PRESENT(lat0) ) proj%lat0 = lat0
+ IF ( PRESENT(lon0) ) proj%lon0 = dummy_lon0
+ IF ( PRESENT(latinc) ) proj%latinc = latinc
+ IF ( PRESENT(loninc) ) proj%loninc = loninc
+ IF ( PRESENT(knowni) ) proj%knowni = knowni
+ IF ( PRESENT(knownj) ) proj%knownj = knownj
+ IF ( PRESENT(dx) ) proj%dx = dx
+ IF ( PRESENT(stdlon) ) proj%stdlon = dummy_stdlon
+ IF ( PRESENT(truelat1) ) proj%truelat1 = truelat1
+ IF ( PRESENT(truelat2) ) proj%truelat2 = truelat2
+ IF ( PRESENT(nlat) ) proj%nlat = nlat
+ IF ( PRESENT(nlon) ) proj%nlon = nlon
+ IF ( PRESENT(ixdim) ) proj%ixdim = ixdim
+ IF ( PRESENT(jydim) ) proj%jydim = jydim
+ IF ( PRESENT(stagger) ) proj%stagger = stagger
+ IF ( PRESENT(phi) ) proj%phi = phi
+ IF ( PRESENT(lambda) ) proj%lambda = lambda
+ IF ( PRESENT(r_earth) ) proj%re_m = r_earth
+
+ IF ( PRESENT(dx) ) THEN
+ IF ( (proj_code == PROJ_LC) .OR. (proj_code == PROJ_PS) .OR. &
+ (proj_code == PROJ_PS_WGS84) .OR. (proj_code == PROJ_ALBERS_NAD83) .OR. &
+ (proj_code == PROJ_MERC) ) THEN
+ proj%dx = dx
+ IF (truelat1 .LT. 0.) THEN
+ proj%hemi = -1.0
+ ELSE
+ proj%hemi = 1.0
+ ENDIF
+ proj%rebydx = proj%re_m / dx
+ ENDIF
+ ENDIF
+
+ pick_proj: SELECT CASE(proj%code)
+
+ CASE(PROJ_PS)
+ CALL set_ps(proj)
+
+ CASE(PROJ_PS_WGS84)
+ CALL set_ps_wgs84(proj)
+
+ CASE(PROJ_ALBERS_NAD83)
+ CALL set_albers_nad83(proj)
+
+ CASE(PROJ_LC)
+ IF (ABS(proj%truelat2) .GT. 90.) THEN
+ proj%truelat2=proj%truelat1
+ ENDIF
+ CALL set_lc(proj)
+
+ CASE (PROJ_MERC)
+ CALL set_merc(proj)
+
+ CASE (PROJ_LATLON)
+
+ CASE (PROJ_GAUSS)
+ CALL set_gauss(proj)
+
+ CASE (PROJ_CYL)
+ CALL set_cyl(proj)
+
+ CASE (PROJ_CASSINI)
+ CALL set_cassini(proj)
+
+ CASE (PROJ_ROTLL)
+
+ END SELECT pick_proj
+ proj%init = .TRUE.
+
+ RETURN
+
+ END SUBROUTINE map_set
+
+
+ SUBROUTINE latlon_to_ij(proj, lat, lon, i, j)
+ ! Converts input lat/lon values to the cartesian (i,j) value
+ ! for the given projection.
+
+ IMPLICIT NONE
+ TYPE(proj_info), INTENT(IN) :: proj
+ REAL (KIND=4), INTENT(IN) :: lat
+ REAL (KIND=4), INTENT(IN) :: lon
+ REAL (KIND=4), INTENT(OUT) :: i
+ REAL (KIND=4), INTENT(OUT) :: j
+
+ IF (.NOT.proj%init) THEN
+ PRINT '(A)', 'You have not called map_set for this projection'
+ CALL llxy_error_fatal ( 'LATLON_TO_IJ' )
+ ENDIF
+
+ SELECT CASE(proj%code)
+
+ CASE(PROJ_LATLON)
+ CALL llij_latlon(lat,lon,proj,i,j)
+
+ CASE(PROJ_MERC)
+ CALL llij_merc(lat,lon,proj,i,j)
+
+ CASE(PROJ_PS)
+ CALL llij_ps(lat,lon,proj,i,j)
+
+ CASE(PROJ_PS_WGS84)
+ CALL llij_ps_wgs84(lat,lon,proj,i,j)
+
+ CASE(PROJ_ALBERS_NAD83)
+ CALL llij_albers_nad83(lat,lon,proj,i,j)
+
+ CASE(PROJ_LC)
+ CALL llij_lc(lat,lon,proj,i,j)
+
+ CASE(PROJ_GAUSS)
+ CALL llij_gauss(lat,lon,proj,i,j)
+
+ CASE(PROJ_CYL)
+ CALL llij_cyl(lat,lon,proj,i,j)
+
+ CASE(PROJ_CASSINI)
+ CALL llij_cassini(lat,lon,proj,i,j)
+
+ CASE(PROJ_ROTLL)
+ CALL llij_rotlatlon(lat,lon,proj,i,j)
+
+ CASE DEFAULT
+ PRINT '(A,I2)', 'Unrecognized map projection code: ', proj%code
+ CALL llxy_error_fatal ( 'LATLON_TO_IJ' )
+
+ END SELECT
+
+ RETURN
+
+ END SUBROUTINE latlon_to_ij
+
+
+ SUBROUTINE ij_to_latlon(proj, i, j, lat, lon)
+ ! Computes geographical latitude and longitude for a given (i,j) point
+ ! in a grid with a projection of proj
+
+ IMPLICIT NONE
+ TYPE(proj_info),INTENT(IN) :: proj
+ REAL (KIND=4), INTENT(IN) :: i
+ REAL (KIND=4), INTENT(IN) :: j
+ REAL (KIND=4), INTENT(OUT) :: lat
+ REAL (KIND=4), INTENT(OUT) :: lon
+
+ IF (.NOT.proj%init) THEN
+ PRINT '(A)', 'You have not called map_set for this projection'
+ CALL llxy_error_fatal ( 'IJ_TO_LATLON' )
+ ENDIF
+ SELECT CASE (proj%code)
+
+ CASE (PROJ_LATLON)
+ CALL ijll_latlon(i, j, proj, lat, lon)
+
+ CASE (PROJ_MERC)
+ CALL ijll_merc(i, j, proj, lat, lon)
+
+ CASE (PROJ_PS)
+ CALL ijll_ps(i, j, proj, lat, lon)
+
+ CASE (PROJ_PS_WGS84)
+ CALL ijll_ps_wgs84(i, j, proj, lat, lon)
+
+ CASE (PROJ_ALBERS_NAD83)
+ CALL ijll_albers_nad83(i, j, proj, lat, lon)
+
+ CASE (PROJ_LC)
+ CALL ijll_lc(i, j, proj, lat, lon)
+
+ CASE (PROJ_CYL)
+ CALL ijll_cyl(i, j, proj, lat, lon)
+
+ CASE (PROJ_CASSINI)
+ CALL ijll_cassini(i, j, proj, lat, lon)
+
+ CASE (PROJ_ROTLL)
+ CALL ijll_rotlatlon(i, j, proj, lat, lon)
+
+ CASE DEFAULT
+ PRINT '(A,I2)', 'Unrecognized map projection code: ', proj%code
+ CALL llxy_error_fatal ( 'IJ_TO_LATLON' )
+
+ END SELECT
+ RETURN
+ END SUBROUTINE ij_to_latlon
+
+
+ SUBROUTINE set_ps(proj)
+ ! Initializes a polar-stereographic map projection from the partially
+ ! filled proj structure. This routine computes the radius to the
+ ! southwest corner and computes the i/j location of the pole for use
+ ! in llij_ps and ijll_ps.
+ IMPLICIT NONE
+
+ ! Declare args
+ TYPE(proj_info), INTENT(INOUT) :: proj
+
+ ! Local vars
+ REAL (KIND=4) :: ala1
+ REAL (KIND=4) :: alo1
+ REAL (KIND=4) :: reflon
+ REAL (KIND=4) :: scale_top
+
+ ! Executable code
+ reflon = proj%stdlon + 90.
+
+ ! Compute numerator term of map scale factor
+ scale_top = 1. + proj%hemi * SIN(proj%truelat1 * rad_per_deg)
+
+ ! Compute radius to lower-left (SW) corner
+ ala1 = proj%lat1 * rad_per_deg
+ proj%rsw = proj%rebydx*COS(ala1)*scale_top/(1.+proj%hemi*SIN(ala1))
+
+ ! Find the pole point
+ alo1 = (proj%lon1 - reflon) * rad_per_deg
+ proj%polei = proj%knowni - proj%rsw * COS(alo1)
+ proj%polej = proj%knownj - proj%hemi * proj%rsw * SIN(alo1)
+
+ RETURN
+
+ END SUBROUTINE set_ps
+
+
+ SUBROUTINE llij_ps(lat,lon,proj,i,j)
+ ! Given latitude (-90 to 90), longitude (-180 to 180), and the
+ ! standard polar-stereographic projection information via the
+ ! public proj structure, this routine returns the i/j indices which
+ ! if within the domain range from 1->nx and 1->ny, respectively.
+
+ IMPLICIT NONE
+
+ ! Delcare input arguments
+ REAL (KIND=4), INTENT(IN) :: lat
+ REAL (KIND=4), INTENT(IN) :: lon
+ TYPE(proj_info),INTENT(IN) :: proj
+
+ ! Declare output arguments
+ REAL (KIND=4), INTENT(OUT) :: i !(x-index)
+ REAL (KIND=4), INTENT(OUT) :: j !(y-index)
+
+ ! Declare local variables
+
+ REAL (KIND=4) :: reflon
+ REAL (KIND=4) :: scale_top
+ REAL (KIND=4) :: ala
+ REAL (KIND=4) :: alo
+ REAL (KIND=4) :: rm
+
+ ! BEGIN CODE
+
+ reflon = proj%stdlon + 90.
+
+ ! Compute numerator term of map scale factor
+
+ scale_top = 1. + proj%hemi * SIN(proj%truelat1 * rad_per_deg)
+
+ ! Find radius to desired point
+ ala = lat * rad_per_deg
+ rm = proj%rebydx * COS(ala) * scale_top/(1. + proj%hemi *SIN(ala))
+ alo = (lon - reflon) * rad_per_deg
+ i = proj%polei + rm * COS(alo)
+ j = proj%polej + proj%hemi * rm * SIN(alo)
+
+ RETURN
+
+ END SUBROUTINE llij_ps
+
+
+ SUBROUTINE ijll_ps(i, j, proj, lat, lon)
+
+ ! This is the inverse subroutine of llij_ps. It returns the
+ ! latitude and longitude of an i/j point given the projection info
+ ! structure.
+
+ IMPLICIT NONE
+
+ ! Declare input arguments
+ REAL (KIND=4), INTENT(IN) :: i ! Column
+ REAL (KIND=4), INTENT(IN) :: j ! Row
+ TYPE (proj_info), INTENT(IN) :: proj
+
+ ! Declare output arguments
+ REAL (KIND=4), INTENT(OUT) :: lat ! -90 -> 90 north
+ REAL (KIND=4), INTENT(OUT) :: lon ! -180 -> 180 East
+
+ ! Local variables
+ REAL (KIND=4) :: reflon
+ REAL (KIND=4) :: scale_top
+ REAL (KIND=4) :: xx,yy
+ REAL (KIND=4) :: gi2, r2
+ REAL (KIND=4) :: arccos
+
+ ! Begin Code
+
+ ! Compute the reference longitude by rotating 90 degrees to the east
+ ! to find the longitude line parallel to the positive x-axis.
+ reflon = proj%stdlon + 90.
+
+ ! Compute numerator term of map scale factor
+ scale_top = 1. + proj%hemi * SIN(proj%truelat1 * rad_per_deg)
+
+ ! Compute radius to point of interest
+ xx = i - proj%polei
+ yy = (j - proj%polej) * proj%hemi
+ r2 = xx**2 + yy**2
+
+ ! Now the magic code
+ IF (r2 .EQ. 0.) THEN
+ lat = proj%hemi * 90.
+ lon = reflon
+ ELSE
+ gi2 = (proj%rebydx * scale_top)**2.
+ lat = deg_per_rad * proj%hemi * ASIN((gi2-r2)/(gi2+r2))
+ arccos = ACOS(xx/SQRT(r2))
+ IF (yy .GT. 0) THEN
+ lon = reflon + deg_per_rad * arccos
+ ELSE
+ lon = reflon - deg_per_rad * arccos
+ ENDIF
+ ENDIF
+
+ ! Convert to a -180 -> 180 East convention
+ IF (lon .GT. 180.) lon = lon - 360.
+ IF (lon .LT. -180.) lon = lon + 360.
+
+ RETURN
+
+ END SUBROUTINE ijll_ps
+
+
+ SUBROUTINE set_ps_wgs84(proj)
+ ! Initializes a polar-stereographic map projection (WGS84 ellipsoid)
+ ! from the partially filled proj structure. This routine computes the
+ ! radius to the southwest corner and computes the i/j location of the
+ ! pole for use in llij_ps and ijll_ps.
+
+ IMPLICIT NONE
+
+ ! Arguments
+ TYPE(proj_info), INTENT(INOUT) :: proj
+
+ ! Local variables
+ REAL (KIND=4) :: h, mc, tc, t, rho
+
+ h = proj%hemi
+
+ mc = cos(h*proj%truelat1*rad_per_deg)/sqrt(1.0-(E_WGS84*sin(h*proj%truelat1*rad_per_deg))**2.0)
+ tc = sqrt(((1.0-sin(h*proj%truelat1*rad_per_deg))/(1.0+sin(h*proj%truelat1*rad_per_deg)))* &
+ (((1.0+E_WGS84*sin(h*proj%truelat1*rad_per_deg))/(1.0-E_WGS84*sin(h*proj%truelat1*rad_per_deg)))**E_WGS84 ))
+
+ ! Find the i/j location of reference lat/lon with respect to the pole of the projection
+ t = sqrt(((1.0-sin(h*proj%lat1*rad_per_deg))/(1.0+sin(h*proj%lat1*rad_per_deg)))* &
+ (((1.0+E_WGS84*sin(h*proj%lat1*rad_per_deg))/(1.0-E_WGS84*sin(h*proj%lat1*rad_per_deg)) )**E_WGS84 ) )
+ rho = h * (A_WGS84 / proj%dx) * mc * t / tc
+ proj%polei = rho * sin((h*proj%lon1 - h*proj%stdlon)*rad_per_deg)
+ proj%polej = -rho * cos((h*proj%lon1 - h*proj%stdlon)*rad_per_deg)
+
+ RETURN
+
+ END SUBROUTINE set_ps_wgs84
+
+
+ SUBROUTINE llij_ps_wgs84(lat,lon,proj,i,j)
+ ! Given latitude (-90 to 90), longitude (-180 to 180), and the
+ ! standard polar-stereographic projection information via the
+ ! public proj structure, this routine returns the i/j indices which
+ ! if within the domain range from 1->nx and 1->ny, respectively.
+
+ IMPLICIT NONE
+
+ ! Arguments
+ REAL (KIND=4), INTENT(IN) :: lat
+ REAL (KIND=4), INTENT(IN) :: lon
+ REAL (KIND=4), INTENT(OUT) :: i !(x-index)
+ REAL (KIND=4), INTENT(OUT) :: j !(y-index)
+ TYPE(proj_info),INTENT(IN) :: proj
+
+ ! Local variables
+ REAL (KIND=4) :: h, mc, tc, t, rho
+
+ h = proj%hemi
+
+ mc = cos(h*proj%truelat1*rad_per_deg)/sqrt(1.0-(E_WGS84*sin(h*proj%truelat1*rad_per_deg))**2.0)
+ tc = sqrt(((1.0-sin(h*proj%truelat1*rad_per_deg))/(1.0+sin(h*proj%truelat1*rad_per_deg)))* &
+ (((1.0+E_WGS84*sin(h*proj%truelat1*rad_per_deg))/(1.0-E_WGS84*sin(h*proj%truelat1*rad_per_deg)))**E_WGS84 ))
+
+ t = sqrt(((1.0-sin(h*lat*rad_per_deg))/(1.0+sin(h*lat*rad_per_deg))) * &
+ (((1.0+E_WGS84*sin(h*lat*rad_per_deg))/(1.0-E_WGS84*sin(h*lat*rad_per_deg)))**E_WGS84))
+
+ ! Find the x/y location of the requested lat/lon with respect to the pole of the projection
+ rho = (A_WGS84 / proj%dx) * mc * t / tc
+ i = h * rho * sin((h*lon - h*proj%stdlon)*rad_per_deg)
+ j = h *(-rho)* cos((h*lon - h*proj%stdlon)*rad_per_deg)
+
+ ! Get i/j relative to reference i/j
+ i = proj%knowni + (i - proj%polei)
+ j = proj%knownj + (j - proj%polej)
+
+ RETURN
+
+ END SUBROUTINE llij_ps_wgs84
+
+
+ SUBROUTINE ijll_ps_wgs84(i, j, proj, lat, lon)
+
+ ! This is the inverse subroutine of llij_ps. It returns the
+ ! latitude and longitude of an i/j point given the projection info
+ ! structure.
+
+ implicit none
+
+ ! Arguments
+ REAL (KIND=4), INTENT(IN) :: i ! Column
+ REAL (KIND=4), INTENT(IN) :: j ! Row
+ REAL (KIND=4), INTENT(OUT) :: lat ! -90 -> 90 north
+ REAL (KIND=4), INTENT(OUT) :: lon ! -180 -> 180 East
+ TYPE (proj_info), INTENT(IN) :: proj
+
+ ! Local variables
+ REAL (KIND=4) :: h, mc, tc, t, rho, x, y
+ REAL (KIND=4) :: chi, a, b, c, d
+
+ h = proj%hemi
+ x = (i - proj%knowni + proj%polei)
+ y = (j - proj%knownj + proj%polej)
+
+ mc = cos(h*proj%truelat1*rad_per_deg)/sqrt(1.0-(E_WGS84*sin(h*proj%truelat1*rad_per_deg))**2.0)
+ tc = sqrt(((1.0-sin(h*proj%truelat1*rad_per_deg))/(1.0+sin(h*proj%truelat1*rad_per_deg))) * &
+ (((1.0+E_WGS84*sin(h*proj%truelat1*rad_per_deg))/(1.0-E_WGS84*sin(h*proj%truelat1*rad_per_deg)))**E_WGS84 ))
+
+ rho = sqrt((x*proj%dx)**2.0 + (y*proj%dx)**2.0)
+ t = rho * tc / (A_WGS84 * mc)
+
+ lon = h*proj%stdlon + h*atan2(h*x,h*(-y))
+
+ chi = PI/2.0-2.0*atan(t)
+ a = 1./2.*E_WGS84**2. + 5./24.*E_WGS84**4. + 1./40.*E_WGS84**6. + 73./2016.*E_WGS84**8.
+ b = 7./24.*E_WGS84**4. + 29./120.*E_WGS84**6. + 54113./40320.*E_WGS84**8.
+ c = 7./30.*E_WGS84**6. + 81./280.*E_WGS84**8.
+ d = 4279./20160.*E_WGS84**8.
+
+ lat = chi + sin(2.*chi)*(a + cos(2.*chi)*(b + cos(2.*chi)*(c + d*cos(2.*chi))))
+ lat = h * lat
+
+ lat = lat*deg_per_rad
+ lon = lon*deg_per_rad
+
+ RETURN
+
+ END SUBROUTINE ijll_ps_wgs84
+
+
+ SUBROUTINE set_albers_nad83(proj)
+ ! Initializes an Albers equal area map projection (NAD83 ellipsoid)
+ ! from the partially filled proj structure. This routine computes the
+ ! radius to the southwest corner and computes the i/j location of the
+ ! pole for use in llij_albers_nad83 and ijll_albers_nad83.
+
+ IMPLICIT NONE
+
+ ! Arguments
+ TYPE(proj_info), INTENT(INOUT) :: proj
+
+ ! Local variables
+ REAL (KIND=4) :: h, m1, m2, q1, q2, theta, q, sinphi
+
+ h = proj%hemi
+
+ m1 = cos(h*proj%truelat1*rad_per_deg)/sqrt(1.0-(E_NAD83*sin(h*proj%truelat1*rad_per_deg))**2.0)
+ m2 = cos(h*proj%truelat2*rad_per_deg)/sqrt(1.0-(E_NAD83*sin(h*proj%truelat2*rad_per_deg))**2.0)
+
+ sinphi = sin(proj%truelat1*rad_per_deg)
+ q1 = (1.0-E_NAD83**2.0) * &
+ ((sinphi/(1.0-(E_NAD83*sinphi)**2.0)) - 1.0/(2.0*E_NAD83) * log((1.0-E_NAD83*sinphi)/(1.0+E_NAD83*sinphi)))
+
+ sinphi = sin(proj%truelat2*rad_per_deg)
+ q2 = (1.0-E_NAD83**2.0) * &
+ ((sinphi/(1.0-(E_NAD83*sinphi)**2.0)) - 1.0/(2.0*E_NAD83) * log((1.0-E_NAD83*sinphi)/(1.0+E_NAD83*sinphi)))
+
+ if (proj%truelat1 == proj%truelat2) then
+ proj%nc = sin(proj%truelat1*rad_per_deg)
+ else
+ proj%nc = (m1**2.0 - m2**2.0) / (q2 - q1)
+ end if
+
+ proj%bigc = m1**2.0 + proj%nc*q1
+
+ ! Find the i/j location of reference lat/lon with respect to the pole of the projection
+ sinphi = sin(proj%lat1*rad_per_deg)
+ q = (1.0-E_NAD83**2.0) * &
+ ((sinphi/(1.0-(E_NAD83*sinphi)**2.0)) - 1.0/(2.0*E_NAD83) * log((1.0-E_NAD83*sinphi)/(1.0+E_NAD83*sinphi)))
+
+ proj%rho0 = h * (A_NAD83 / proj%dx) * sqrt(proj%bigc - proj%nc * q) / proj%nc
+ theta = proj%nc*(proj%lon1 - proj%stdlon)*rad_per_deg
+
+ proj%polei = proj%rho0 * sin(h*theta)
+ proj%polej = proj%rho0 - proj%rho0 * cos(h*theta)
+
+ RETURN
+
+ END SUBROUTINE set_albers_nad83
+
+
+ SUBROUTINE llij_albers_nad83(lat,lon,proj,i,j)
+ ! Given latitude (-90 to 90), longitude (-180 to 180), and the
+ ! standard projection information via the
+ ! public proj structure, this routine returns the i/j indices which
+ ! if within the domain range from 1->nx and 1->ny, respectively.
+
+ IMPLICIT NONE
+
+ ! Arguments
+ REAL (KIND=4), INTENT(IN) :: lat
+ REAL (KIND=4), INTENT(IN) :: lon
+ REAL (KIND=4), INTENT(OUT) :: i !(x-index)
+ REAL (KIND=4), INTENT(OUT) :: j !(y-index)
+ TYPE(proj_info),INTENT(IN) :: proj
+
+ ! Local variables
+ REAL (KIND=4) :: h, q, rho, theta, sinphi
+
+ h = proj%hemi
+
+ sinphi = sin(h*lat*rad_per_deg)
+
+ ! Find the x/y location of the requested lat/lon with respect to the pole of the projection
+ q = (1.0-E_NAD83**2.0) * &
+ ((sinphi/(1.0-(E_NAD83*sinphi)**2.0)) - 1.0/(2.0*E_NAD83) * log((1.0-E_NAD83*sinphi)/(1.0+E_NAD83*sinphi)))
+
+ rho = h * (A_NAD83 / proj%dx) * sqrt(proj%bigc - proj%nc * q) / proj%nc
+ theta = proj%nc * (h*lon - h*proj%stdlon)*rad_per_deg
+
+ i = h*rho*sin(theta)
+ j = h*proj%rho0 - h*rho*cos(theta)
+
+ ! Get i/j relative to reference i/j
+ i = proj%knowni + (i - proj%polei)
+ j = proj%knownj + (j - proj%polej)
+
+ RETURN
+
+ END SUBROUTINE llij_albers_nad83
+
+
+ SUBROUTINE ijll_albers_nad83(i, j, proj, lat, lon)
+
+ ! This is the inverse subroutine of llij_albers_nad83. It returns the
+ ! latitude and longitude of an i/j point given the projection info
+ ! structure.
+
+ implicit none
+
+ ! Arguments
+ REAL (KIND=4), INTENT(IN) :: i ! Column
+ REAL (KIND=4), INTENT(IN) :: j ! Row
+ REAL (KIND=4), INTENT(OUT) :: lat ! -90 -> 90 north
+ REAL (KIND=4), INTENT(OUT) :: lon ! -180 -> 180 East
+ TYPE (proj_info), INTENT(IN) :: proj
+
+ ! Local variables
+ REAL (KIND=4) :: h, q, rho, theta, beta, x, y
+ REAL (KIND=4) :: a, b, c
+
+ h = proj%hemi
+
+ x = (i - proj%knowni + proj%polei)
+ y = (j - proj%knownj + proj%polej)
+
+ rho = sqrt(x**2.0 + (proj%rho0 - y)**2.0)
+ theta = atan2(x, proj%rho0-y)
+
+ q = (proj%bigc - (rho*proj%nc*proj%dx/A_NAD83)**2.0) / proj%nc
+
+ beta = asin(q/(1.0 - log((1.0-E_NAD83)/(1.0+E_NAD83))*(1.0-E_NAD83**2.0)/(2.0*E_NAD83)))
+ a = 1./3.*E_NAD83**2. + 31./180.*E_NAD83**4. + 517./5040.*E_NAD83**6.
+ b = 23./360.*E_NAD83**4. + 251./3780.*E_NAD83**6.
+ c = 761./45360.*E_NAD83**6.
+
+ lat = beta + a*sin(2.*beta) + b*sin(4.*beta) + c*sin(6.*beta)
+
+ lat = h*lat*deg_per_rad
+ lon = proj%stdlon + theta*deg_per_rad/proj%nc
+
+ RETURN
+
+ END SUBROUTINE ijll_albers_nad83
+
+
+ SUBROUTINE set_lc(proj)
+ ! Initialize the remaining items in the proj structure for a
+ ! lambert conformal grid.
+
+ IMPLICIT NONE
+
+ TYPE(proj_info), INTENT(INOUT) :: proj
+
+ REAL (KIND=4) :: arg
+ REAL (KIND=4) :: deltalon1
+ REAL (KIND=4) :: tl1r
+ REAL (KIND=4) :: ctl1r
+
+ ! Compute cone factor
+ CALL lc_cone(proj%truelat1, proj%truelat2, proj%cone)
+
+ ! Compute longitude differences and ensure we stay out of the
+ ! forbidden "cut zone"
+ deltalon1 = proj%lon1 - proj%stdlon
+ IF (deltalon1 .GT. +180.) deltalon1 = deltalon1 - 360.
+ IF (deltalon1 .LT. -180.) deltalon1 = deltalon1 + 360.
+
+ ! Convert truelat1 to radian and compute COS for later use
+ tl1r = proj%truelat1 * rad_per_deg
+ ctl1r = COS(tl1r)
+
+ ! Compute the radius to our known lower-left (SW) corner
+ proj%rsw = proj%rebydx * ctl1r/proj%cone * &
+ (TAN((90.*proj%hemi-proj%lat1)*rad_per_deg/2.) / &
+ TAN((90.*proj%hemi-proj%truelat1)*rad_per_deg/2.))**proj%cone
+
+ ! Find pole point
+ arg = proj%cone*(deltalon1*rad_per_deg)
+ proj%polei = proj%hemi*proj%knowni - proj%hemi * proj%rsw * SIN(arg)
+ proj%polej = proj%hemi*proj%knownj + proj%rsw * COS(arg)
+
+ RETURN
+
+ END SUBROUTINE set_lc
+
+
+ SUBROUTINE lc_cone(truelat1, truelat2, cone)
+
+ ! Subroutine to compute the cone factor of a Lambert Conformal projection
+
+ IMPLICIT NONE
+
+ ! Input Args
+ REAL (KIND=4), INTENT(IN) :: truelat1 ! (-90 -> 90 degrees N)
+ REAL (KIND=4), INTENT(IN) :: truelat2 ! " " " " "
+
+ ! Output Args
+ REAL (KIND=4), INTENT(OUT) :: cone
+
+ ! Locals
+
+ ! BEGIN CODE
+
+ ! First, see if this is a secant or tangent projection. For tangent
+ ! projections, truelat1 = truelat2 and the cone is tangent to the
+ ! Earth's surface at this latitude. For secant projections, the cone
+ ! intersects the Earth's surface at each of the distinctly different
+ ! latitudes
+ IF (ABS(truelat1-truelat2) .GT. 0.1) THEN
+ cone = ALOG10(COS(truelat1*rad_per_deg)) - &
+ ALOG10(COS(truelat2*rad_per_deg))
+ cone = cone /(ALOG10(TAN((45.0 - ABS(truelat1)/2.0) * rad_per_deg)) - &
+ ALOG10(TAN((45.0 - ABS(truelat2)/2.0) * rad_per_deg)))
+ ELSE
+ cone = SIN(ABS(truelat1)*rad_per_deg )
+ ENDIF
+
+ RETURN
+
+ END SUBROUTINE lc_cone
+
+
+ SUBROUTINE ijll_lc( i, j, proj, lat, lon)
+
+ ! Subroutine to convert from the (i,j) cartesian coordinate to the
+ ! geographical latitude and longitude for a Lambert Conformal projection.
+
+ ! History:
+ ! 25 Jul 01: Corrected by B. Shaw, NOAA/FSL
+ !
+ IMPLICIT NONE
+
+ ! Input Args
+ REAL (KIND=4), INTENT(IN) :: i ! Cartesian X coordinate
+ REAL (KIND=4), INTENT(IN) :: j ! Cartesian Y coordinate
+ TYPE(proj_info),INTENT(IN) :: proj ! Projection info structure
+
+ ! Output Args
+ REAL (KIND=4), INTENT(OUT) :: lat ! Latitude (-90->90 deg N)
+ REAL (KIND=4), INTENT(OUT) :: lon ! Longitude (-180->180 E)
+
+ ! Locals
+ REAL (KIND=4) :: inew
+ REAL (KIND=4) :: jnew
+ REAL (KIND=4) :: r
+ REAL (KIND=4) :: chi,chi1,chi2
+ REAL (KIND=4) :: r2
+ REAL (KIND=4) :: xx
+ REAL (KIND=4) :: yy
+
+ ! BEGIN CODE
+
+ chi1 = (90. - proj%hemi*proj%truelat1)*rad_per_deg
+ chi2 = (90. - proj%hemi*proj%truelat2)*rad_per_deg
+
+ ! See if we are in the southern hemispere and flip the indices
+ ! if we are.
+ inew = proj%hemi * i
+ jnew = proj%hemi * j
+
+ ! Compute radius**2 to i/j location
+ xx = inew - proj%polei
+ yy = proj%polej - jnew
+ r2 = (xx*xx + yy*yy)
+ r = SQRT(r2)/proj%rebydx
+
+ ! Convert to lat/lon
+ IF (r2 .EQ. 0.) THEN
+ lat = proj%hemi * 90.
+ lon = proj%stdlon
+ ELSE
+
+ ! Longitude
+ lon = proj%stdlon + deg_per_rad * ATAN2(proj%hemi*xx,yy)/proj%cone
+# if ( defined (G95) && ( DA_CORE == 1 ) )
+ lon = DMOD(lon+360., 360.)
+# else
+ lon = AMOD(lon+360., 360.)
+# endif
+
+ ! Latitude. Latitude determined by solving an equation adapted
+ ! from:
+ ! Maling, D.H., 1973: Coordinate Systems and Map Projections
+ ! Equations #20 in Appendix I.
+
+ IF (chi1 .EQ. chi2) THEN
+ chi = 2.0*ATAN( ( r/TAN(chi1) )**(1./proj%cone) * TAN(chi1*0.5) )
+ ELSE
+ chi = 2.0*ATAN( (r*proj%cone/SIN(chi1))**(1./proj%cone) * TAN(chi1*0.5))
+ ENDIF
+ lat = (90.0-chi*deg_per_rad)*proj%hemi
+
+ ENDIF
+
+ IF (lon .GT. +180.) lon = lon - 360.
+ IF (lon .LT. -180.) lon = lon + 360.
+
+ RETURN
+
+ END SUBROUTINE ijll_lc
+
+
+ SUBROUTINE llij_lc( lat, lon, proj, i, j)
+
+ ! Subroutine to compute the geographical latitude and longitude values
+ ! to the cartesian x/y on a Lambert Conformal projection.
+
+ IMPLICIT NONE
+
+ ! Input Args
+ REAL (KIND=4), INTENT(IN) :: lat ! Latitude (-90->90 deg N)
+ REAL (KIND=4), INTENT(IN) :: lon ! Longitude (-180->180 E)
+ TYPE(proj_info),INTENT(IN) :: proj ! Projection info structure
+
+ ! Output Args
+ REAL (KIND=4), INTENT(OUT) :: i ! Cartesian X coordinate
+ REAL (KIND=4), INTENT(OUT) :: j ! Cartesian Y coordinate
+
+ ! Locals
+ REAL (KIND=4) :: arg
+ REAL (KIND=4) :: deltalon
+ REAL (KIND=4) :: tl1r
+ REAL (KIND=4) :: rm
+ REAL (KIND=4) :: ctl1r
+
+
+ ! BEGIN CODE
+
+ ! Compute deltalon between known longitude and standard lon and ensure
+ ! it is not in the cut zone
+ deltalon = lon - proj%stdlon
+ IF (deltalon .GT. +180.) deltalon = deltalon - 360.
+ IF (deltalon .LT. -180.) deltalon = deltalon + 360.
+
+ ! Convert truelat1 to radian and compute COS for later use
+ tl1r = proj%truelat1 * rad_per_deg
+ ctl1r = COS(tl1r)
+
+ ! Radius to desired point
+ rm = proj%rebydx * ctl1r/proj%cone * &
+ (TAN((90.*proj%hemi-lat)*rad_per_deg/2.) / &
+ TAN((90.*proj%hemi-proj%truelat1)*rad_per_deg/2.))**proj%cone
+
+ arg = proj%cone*(deltalon*rad_per_deg)
+ i = proj%polei + proj%hemi * rm * SIN(arg)
+ j = proj%polej - rm * COS(arg)
+
+ ! Finally, if we are in the southern hemisphere, flip the i/j
+ ! values to a coordinate system where (1,1) is the SW corner
+ ! (what we assume) which is different than the original NCEP
+ ! algorithms which used the NE corner as the origin in the
+ ! southern hemisphere (left-hand vs. right-hand coordinate?)
+ i = proj%hemi * i
+ j = proj%hemi * j
+
+ RETURN
+ END SUBROUTINE llij_lc
+
+
+ SUBROUTINE set_merc(proj)
+
+ ! Sets up the remaining basic elements for the mercator projection
+
+ IMPLICIT NONE
+ TYPE(proj_info), INTENT(INOUT) :: proj
+ REAL (KIND=4) :: clain
+
+
+ ! Preliminary variables
+
+ clain = COS(rad_per_deg*proj%truelat1)
+ proj%dlon = proj%dx / (proj%re_m * clain)
+
+ ! Compute distance from equator to origin, and store in the
+ ! proj%rsw tag.
+
+ proj%rsw = 0.
+ IF (proj%lat1 .NE. 0.) THEN
+ proj%rsw = (ALOG(TAN(0.5*((proj%lat1+90.)*rad_per_deg))))/proj%dlon
+ ENDIF
+
+ RETURN
+
+ END SUBROUTINE set_merc
+
+
+ SUBROUTINE llij_merc(lat, lon, proj, i, j)
+
+ ! Compute i/j coordinate from lat lon for mercator projection
+
+ IMPLICIT NONE
+ REAL (KIND=4), INTENT(IN) :: lat
+ REAL (KIND=4), INTENT(IN) :: lon
+ TYPE(proj_info),INTENT(IN) :: proj
+ REAL (KIND=4),INTENT(OUT) :: i
+ REAL (KIND=4),INTENT(OUT) :: j
+ REAL (KIND=4) :: deltalon
+
+ deltalon = lon - proj%lon1
+ IF (deltalon .LT. -180.) deltalon = deltalon + 360.
+ IF (deltalon .GT. 180.) deltalon = deltalon - 360.
+ i = proj%knowni + (deltalon/(proj%dlon*deg_per_rad))
+ j = proj%knownj + (ALOG(TAN(0.5*((lat + 90.) * rad_per_deg)))) / &
+ proj%dlon - proj%rsw
+
+ RETURN
+
+ END SUBROUTINE llij_merc
+
+
+ SUBROUTINE ijll_merc(i, j, proj, lat, lon)
+
+ ! Compute the lat/lon from i/j for mercator projection
+
+ IMPLICIT NONE
+ REAL (KIND=4),INTENT(IN) :: i
+ REAL (KIND=4),INTENT(IN) :: j
+ TYPE(proj_info),INTENT(IN) :: proj
+ REAL (KIND=4), INTENT(OUT) :: lat
+ REAL (KIND=4), INTENT(OUT) :: lon
+
+
+ lat = 2.0*ATAN(EXP(proj%dlon*(proj%rsw + j-proj%knownj)))*deg_per_rad - 90.
+ lon = (i-proj%knowni)*proj%dlon*deg_per_rad + proj%lon1
+ IF (lon.GT.180.) lon = lon - 360.
+ IF (lon.LT.-180.) lon = lon + 360.
+ RETURN
+
+ END SUBROUTINE ijll_merc
+
+
+ SUBROUTINE llij_latlon(lat, lon, proj, i, j)
+
+ ! Compute the i/j location of a lat/lon on a LATLON grid.
+ IMPLICIT NONE
+ REAL (KIND=4), INTENT(IN) :: lat
+ REAL (KIND=4), INTENT(IN) :: lon
+ TYPE(proj_info), INTENT(IN) :: proj
+ REAL (KIND=4), INTENT(OUT) :: i
+ REAL (KIND=4), INTENT(OUT) :: j
+
+ REAL (KIND=4) :: deltalat
+ REAL (KIND=4) :: deltalon
+
+ ! Compute deltalat and deltalon as the difference between the input
+ ! lat/lon and the origin lat/lon
+ deltalat = lat - proj%lat1
+ deltalon = lon - proj%lon1
+
+ ! Compute i/j
+ i = deltalon/proj%loninc
+ j = deltalat/proj%latinc
+
+ i = i + proj%knowni
+ j = j + proj%knownj
+
+ RETURN
+
+ END SUBROUTINE llij_latlon
+
+
+ SUBROUTINE ijll_latlon(i, j, proj, lat, lon)
+
+ ! Compute the lat/lon location of an i/j on a LATLON grid.
+ IMPLICIT NONE
+ REAL (KIND=4), INTENT(IN) :: i
+ REAL (KIND=4), INTENT(IN) :: j
+ TYPE(proj_info), INTENT(IN) :: proj
+ REAL (KIND=4), INTENT(OUT) :: lat
+ REAL (KIND=4), INTENT(OUT) :: lon
+
+ REAL (KIND=4) :: i_work, j_work
+ REAL (KIND=4) :: deltalat
+ REAL (KIND=4) :: deltalon
+
+ i_work = i - proj%knowni
+ j_work = j - proj%knownj
+
+ ! Compute deltalat and deltalon
+ deltalat = j_work*proj%latinc
+ deltalon = i_work*proj%loninc
+
+ lat = proj%lat1 + deltalat
+ lon = proj%lon1 + deltalon
+
+ RETURN
+
+ END SUBROUTINE ijll_latlon
+
+
+ SUBROUTINE set_cyl(proj)
+
+ implicit none
+
+ ! Arguments
+ type(proj_info), intent(inout) :: proj
+
+ proj%hemi = 1.0
+
+ END SUBROUTINE set_cyl
+
+
+ SUBROUTINE llij_cyl(lat, lon, proj, i, j)
+
+ implicit none
+
+ ! Arguments
+ REAL (KIND=4), intent(in) :: lat, lon
+ REAL (KIND=4), intent(out) :: i, j
+ type(proj_info), intent(in) :: proj
+
+ ! Local variables
+ REAL (KIND=4) :: deltalat
+ REAL (KIND=4) :: deltalon
+
+ ! Compute deltalat and deltalon as the difference between the input
+ ! lat/lon and the origin lat/lon
+ deltalat = lat - proj%lat1
+! deltalon = lon - proj%stdlon
+ deltalon = lon - proj%lon1
+
+ if (deltalon < 0.) deltalon = deltalon + 360.
+ if (deltalon > 360.) deltalon = deltalon - 360.
+
+ ! Compute i/j
+ i = deltalon/proj%loninc
+ j = deltalat/proj%latinc
+
+ if (i <= 0.) i = i + 360./proj%loninc
+ if (i > 360./proj%loninc) i = i - 360./proj%loninc
+
+ i = i + proj%knowni
+ j = j + proj%knownj
+
+ END SUBROUTINE llij_cyl
+
+
+ SUBROUTINE ijll_cyl(i, j, proj, lat, lon)
+
+ implicit none
+
+ ! Arguments
+ REAL (KIND=4), intent(in) :: i, j
+ REAL (KIND=4), intent(out) :: lat, lon
+ type(proj_info), intent(in) :: proj
+
+ ! Local variables
+ REAL (KIND=4) :: deltalat
+ REAL (KIND=4) :: deltalon
+ REAL (KIND=4) :: i_work, j_work
+
+ i_work = i - proj%knowni
+ j_work = j - proj%knownj
+
+ if (i_work < 0.) i_work = i_work + 360./proj%loninc
+ if (i_work >= 360./proj%loninc) i_work = i_work - 360./proj%loninc
+
+ ! Compute deltalat and deltalon
+ deltalat = j_work*proj%latinc
+ deltalon = i_work*proj%loninc
+
+ lat = deltalat + proj%lat1
+! lon = deltalon + proj%stdlon
+ lon = deltalon + proj%lon1
+
+ if (lon < -180.) lon = lon + 360.
+ if (lon > 180.) lon = lon - 360.
+
+ END SUBROUTINE ijll_cyl
+
+
+ SUBROUTINE set_cassini(proj)
+
+ implicit none
+
+ ! Arguments
+ type(proj_info), intent(inout) :: proj
+
+ ! Local variables
+ REAL (KIND=4) :: comp_lat, comp_lon
+ logical :: global_domain
+
+ proj%hemi = 1.0
+
+ ! Try to determine whether this domain has global coverage
+ if (abs(proj%lat1 - proj%latinc/2. + 90.) < 0.001 .and. &
+ abs(mod(proj%lon1 - proj%loninc/2. - proj%stdlon,360.)) < 0.001) then
+ global_domain = .true.
+ else
+ global_domain = .false.
+ end if
+
+ if (abs(proj%lat0) /= 90. .and. .not.global_domain) then
+ call rotate_coords(proj%lat1,proj%lon1,comp_lat,comp_lon,proj%lat0,proj%lon0,proj%stdlon,-1)
+ proj%lat1 = comp_lat
+ proj%lon1 = comp_lon
+ end if
+
+ END SUBROUTINE set_cassini
+
+
+ SUBROUTINE llij_cassini(lat, lon, proj, i, j)
+
+ implicit none
+
+ ! Arguments
+ REAL (KIND=4), intent(in) :: lat, lon
+ REAL (KIND=4), intent(out) :: i, j
+ type(proj_info), intent(in) :: proj
+
+ ! Local variables
+ REAL (KIND=4) :: comp_lat, comp_lon
+
+ ! Convert geographic to computational lat/lon
+ if (abs(proj%lat0) /= 90.) then
+ call rotate_coords(lat,lon,comp_lat,comp_lon,proj%lat0,proj%lon0,proj%stdlon,-1)
+ else
+ comp_lat = lat
+ comp_lon = lon
+ end if
+
+ ! Convert computational lat/lon to i/j
+ call llij_cyl(comp_lat, comp_lon, proj, i, j)
+
+ END SUBROUTINE llij_cassini
+
+
+ SUBROUTINE ijll_cassini(i, j, proj, lat, lon)
+
+ implicit none
+
+ ! Arguments
+ REAL (KIND=4), intent(in) :: i, j
+ REAL (KIND=4), intent(out) :: lat, lon
+ type(proj_info), intent(in) :: proj
+
+ ! Local variables
+ REAL (KIND=4) :: comp_lat, comp_lon
+
+ ! Convert i/j to computational lat/lon
+ call ijll_cyl(i, j, proj, comp_lat, comp_lon)
+
+ ! Convert computational to geographic lat/lon
+ if (abs(proj%lat0) /= 90.) then
+ call rotate_coords(comp_lat,comp_lon,lat,lon,proj%lat0,proj%lon0,proj%stdlon,1)
+ else
+ lat = comp_lat
+ lon = comp_lon
+ end if
+
+ END SUBROUTINE ijll_cassini
+
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Purpose: Converts between computational and geographic lat/lon for Cassini
+ !
+ ! Notes: This routine was provided by Bill Skamarock, 2007-03-27
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ SUBROUTINE rotate_coords(ilat,ilon,olat,olon,lat_np,lon_np,lon_0,direction)
+
+ IMPLICIT NONE
+
+ REAL (KIND=4), INTENT(IN ) :: ilat, ilon
+ REAL (KIND=4), INTENT( OUT) :: olat, olon
+ REAL (KIND=4), INTENT(IN ) :: lat_np, lon_np, lon_0
+ INTEGER, INTENT(IN ), OPTIONAL :: direction
+ ! >=0, default : computational -> geographical
+ ! < 0 : geographical -> computational
+
+ REAL (KIND=4) :: rlat, rlon
+ REAL (KIND=4) :: phi_np, lam_np, lam_0, dlam
+ REAL (KIND=4) :: sinphi, cosphi, coslam, sinlam
+
+ ! Convert all angles to radians
+ phi_np = lat_np * rad_per_deg
+ lam_np = lon_np * rad_per_deg
+ lam_0 = lon_0 * rad_per_deg
+ rlat = ilat * rad_per_deg
+ rlon = ilon * rad_per_deg
+
+ IF (PRESENT(direction) .AND. (direction < 0)) THEN
+ ! The equations are exactly the same except for one small difference
+ ! with respect to longitude ...
+ dlam = PI - lam_0
+ ELSE
+ dlam = lam_np
+ END IF
+ sinphi = COS(phi_np)*COS(rlat)*COS(rlon-dlam) + SIN(phi_np)*SIN(rlat)
+ cosphi = SQRT(1.-sinphi*sinphi)
+ coslam = SIN(phi_np)*COS(rlat)*COS(rlon-dlam) - COS(phi_np)*SIN(rlat)
+ sinlam = COS(rlat)*SIN(rlon-dlam)
+ IF ( cosphi /= 0. ) THEN
+ coslam = coslam/cosphi
+ sinlam = sinlam/cosphi
+ END IF
+ olat = deg_per_rad*ASIN(sinphi)
+ olon = deg_per_rad*(ATAN2(sinlam,coslam)-dlam-lam_0+lam_np)
+ ! Both of my F90 text books prefer the DO-EXIT form, and claim it is faster
+ ! when optimization is turned on (as we will always do...)
+ DO
+ IF (olon >= -180.) EXIT
+ olon = olon + 360.
+ END DO
+ DO
+ IF (olon <= 180.) EXIT
+ olon = olon - 360.
+ END DO
+
+ END SUBROUTINE rotate_coords
+
+
+ SUBROUTINE llij_rotlatlon(lat, lon, proj, i_real, j_real)
+
+ IMPLICIT NONE
+
+ ! Arguments
+ REAL (KIND=4), INTENT(IN) :: lat, lon
+ REAL (KIND=4) :: i, j
+ REAL (KIND=4), INTENT(OUT) :: i_real, j_real
+ TYPE (proj_info), INTENT(IN) :: proj
+
+ ! Local variables
+ INTEGER :: ii,imt,jj,jmt,k,krows,ncol,nrow,iri
+ REAL(KIND=HIGH) :: dphd,dlmd !Grid increments, degrees
+ REAL(KIND=HIGH) :: glatd !Geographic latitude, positive north
+ REAL(KIND=HIGH) :: glond !Geographic longitude, positive west
+ REAL(KIND=HIGH) :: col,d1,d2,d2r,dlm,dlm1,dlm2,dph,glat,glon, &
+ pi,r2d,row,tlat,tlat1,tlat2, &
+ tlon,tlon1,tlon2,tph0,tlm0,x,y,z
+
+ glatd = lat
+ glond = -lon
+
+ dphd = proj%phi/REAL((proj%jydim-1)/2)
+ dlmd = proj%lambda/REAL(proj%ixdim-1)
+
+ pi = ACOS(-1.0)
+ d2r = pi/180.
+ r2d = 1./d2r
+
+ imt = 2*proj%ixdim-1
+ jmt = proj%jydim/2+1
+
+ glat = glatd*d2r
+ glon = glond*d2r
+ dph = dphd*d2r
+ dlm = dlmd*d2r
+ tph0 = proj%lat1*d2r
+ tlm0 = -proj%lon1*d2r
+
+ x = COS(tph0)*COS(glat)*COS(glon-tlm0)+SIN(tph0)*SIN(glat)
+ y = -COS(glat)*SIN(glon-tlm0)
+ z = COS(tph0)*SIN(glat)-SIN(tph0)*COS(glat)*COS(glon-tlm0)
+ tlat = r2d*ATAN(z/SQRT(x*x+y*y))
+ tlon = r2d*ATAN(y/x)
+
+ row = tlat/dphd+jmt
+ col = tlon/dlmd+proj%ixdim
+
+ if ( (row - INT(row)) .gt. 0.999) then
+ row = row + 0.0002
+ else if ( (col - INT(col)) .gt. 0.999) then
+ col = col + 0.0002
+ end if
+
+ nrow = INT(row)
+ ncol = INT(col)
+
+! nrow = NINT(row)
+! ncol = NINT(col)
+
+ tlat = tlat*d2r
+ tlon = tlon*d2r
+
+
+ IF (proj%stagger == HH) THEN
+
+ IF (mod(nrow,2) .eq. 0) then
+ i_real = col / 2.0
+ ELSE
+ i_real = col / 2.0 + 0.5
+ ENDIF
+ j_real=row
+
+
+ IF ((abs(MOD(nrow,2)) == 1 .AND. abs(MOD(ncol,2)) == 1) .OR. &
+ (MOD(nrow,2) == 0 .AND. MOD(ncol,2) == 0)) THEN
+
+ tlat1 = (nrow-jmt)*dph
+ tlat2 = tlat1+dph
+ tlon1 = (ncol-proj%ixdim)*dlm
+ tlon2 = tlon1+dlm
+
+ dlm1 = tlon-tlon1
+ dlm2 = tlon-tlon2
+ d1 = ACOS(COS(tlat)*COS(tlat1)*COS(dlm1)+SIN(tlat)*SIN(tlat1))
+ d2 = ACOS(COS(tlat)*COS(tlat2)*COS(dlm2)+SIN(tlat)*SIN(tlat2))
+
+ IF (d1 > d2) THEN
+ nrow = nrow+1
+ ncol = ncol+1
+ END IF
+
+ ELSE
+ tlat1 = (nrow+1-jmt)*dph
+ tlat2 = tlat1-dph
+ tlon1 = (ncol-proj%ixdim)*dlm
+ tlon2 = tlon1+dlm
+ dlm1 = tlon-tlon1
+ dlm2 = tlon-tlon2
+ d1 = ACOS(COS(tlat)*COS(tlat1)*COS(dlm1)+SIN(tlat)*SIN(tlat1))
+ d2 = ACOS(COS(tlat)*COS(tlat2)*COS(dlm2)+SIN(tlat)*SIN(tlat2))
+
+ IF (d1 < d2) THEN
+ nrow = nrow+1
+ ELSE
+ ncol = ncol+1
+ END IF
+ END IF
+
+ ELSE IF (proj%stagger == VV) THEN
+
+ IF (mod(nrow,2) .eq. 0) then
+ i_real = col / 2.0 + 0.5
+ ELSE
+ i_real = col / 2.0
+ ENDIF
+ j_real=row
+
+ IF ((MOD(nrow,2) == 0 .AND. abs(MOD(ncol,2)) == 1) .OR. &
+ (abs(MOD(nrow,2)) == 1 .AND. MOD(ncol,2) == 0)) THEN
+ tlat1 = (nrow-jmt)*dph
+ tlat2 = tlat1+dph
+ tlon1 = (ncol-proj%ixdim)*dlm
+ tlon2 = tlon1+dlm
+ dlm1 = tlon-tlon1
+ dlm2 = tlon-tlon2
+ d1 = ACOS(COS(tlat)*COS(tlat1)*COS(dlm1)+SIN(tlat)*SIN(tlat1))
+ d2 = ACOS(COS(tlat)*COS(tlat2)*COS(dlm2)+SIN(tlat)*SIN(tlat2))
+
+ IF (d1 > d2) THEN
+ nrow = nrow+1
+ ncol = ncol+1
+ END IF
+
+ ELSE
+ tlat1 = (nrow+1-jmt)*dph
+ tlat2 = tlat1-dph
+ tlon1 = (ncol-proj%ixdim)*dlm
+ tlon2 = tlon1+dlm
+ dlm1 = tlon-tlon1
+ dlm2 = tlon-tlon2
+ d1 = ACOS(COS(tlat)*COS(tlat1)*COS(dlm1)+SIN(tlat)*SIN(tlat1))
+ d2 = ACOS(COS(tlat)*COS(tlat2)*COS(dlm2)+SIN(tlat)*SIN(tlat2))
+
+ IF (d1 < d2) THEN
+ nrow = nrow+1
+ ELSE
+ ncol = ncol+1
+ END IF
+ END IF
+ END IF
+
+
+!!! Added next line as a Kludge - not yet understood why needed
+ if (ncol .le. 0) ncol=ncol-1
+
+ jj = nrow
+ ii = ncol/2
+
+ IF (proj%stagger == HH) THEN
+ IF (abs(MOD(jj,2)) == 1) ii = ii+1
+ ELSE IF (proj%stagger == VV) THEN
+ IF (MOD(jj,2) == 0) ii=ii+1
+ END IF
+
+ i = REAL(ii)
+ j = REAL(jj)
+
+ END SUBROUTINE llij_rotlatlon
+
+
+ SUBROUTINE ijll_rotlatlon(i, j, proj, lat,lon)
+
+ IMPLICIT NONE
+
+ ! Arguments
+ REAL (KIND=4), INTENT(IN) :: i, j
+ REAL (KIND=4), INTENT(OUT) :: lat, lon
+ TYPE (proj_info), INTENT(IN) :: proj
+
+ ! Local variables
+ INTEGER :: ih,jh
+ INTEGER :: midcol,midrow,ncol,iadd1,iadd2,imt,jh2,knrow,krem,kv,nrow
+ REAL (KIND=4) :: i_work, j_work
+ REAL (KIND=4) :: dphd,dlmd !Grid increments, degrees
+ REAL(KIND=HIGH) :: arg1,arg2,d2r,fctr,glatr,glatd,glond,pi, &
+ r2d,tlatd,tlond,tlatr,tlonr,tlm0,tph0
+ REAL (KIND=4) :: col
+
+ i_work = i
+ j_work = j
+
+ if ( (j - INT(j)) .gt. 0.999) then
+ j_work = j + 0.0002
+ endif
+
+ jh = INT(j_work)
+
+ dphd = proj%phi/REAL((proj%jydim-1)/2)
+ dlmd = proj%lambda/REAL(proj%ixdim-1)
+
+ pi = ACOS(-1.0)
+ d2r = pi/180.
+ r2d = 1./d2r
+ tph0 = proj%lat1*d2r
+ tlm0 = -proj%lon1*d2r
+
+ midrow = (proj%jydim+1)/2
+ midcol = proj%ixdim
+
+ col = 2*i_work-1+abs(MOD(jh+1,2))
+ tlatd = (j_work-midrow)*dphd
+ tlond = (col-midcol)*dlmd
+
+ IF (proj%stagger == VV) THEN
+ if (mod(jh,2) .eq. 0) then
+ tlond = tlond - DLMD
+ else
+ tlond = tlond + DLMD
+ end if
+ END IF
+
+ tlatr = tlatd*d2r
+ tlonr = tlond*d2r
+ arg1 = SIN(tlatr)*COS(tph0)+COS(tlatr)*SIN(tph0)*COS(tlonr)
+ glatr = ASIN(arg1)
+
+ glatd = glatr*r2d
+
+ arg2 = COS(tlatr)*COS(tlonr)/(COS(glatr)*COS(tph0))-TAN(glatr)*TAN(tph0)
+ IF (ABS(arg2) > 1.) arg2 = ABS(arg2)/arg2
+ fctr = 1.
+ IF (tlond > 0.) fctr = -1.
+
+ glond = tlm0*r2d+fctr*ACOS(arg2)*r2d
+
+ lat = glatd
+ lon = -glond
+
+ IF (lon .GT. +180.) lon = lon - 360.
+ IF (lon .LT. -180.) lon = lon + 360.
+
+ END SUBROUTINE ijll_rotlatlon
+
+
+ SUBROUTINE set_gauss(proj)
+
+ IMPLICIT NONE
+
+ ! Argument
+ type (proj_info), intent(inout) :: proj
+
+ ! Initialize the array that will hold the Gaussian latitudes.
+
+ IF ( ASSOCIATED( proj%gauss_lat ) ) THEN
+ DEALLOCATE ( proj%gauss_lat )
+ END IF
+
+ ! Get the needed space for our array.
+
+ ALLOCATE ( proj%gauss_lat(proj%nlat*2) )
+
+ ! Compute the Gaussian latitudes.
+
+ CALL gausll( proj%nlat*2 , proj%gauss_lat )
+
+ ! Now, these could be upside down from what we want, so let's check.
+ ! We take advantage of the equatorial symmetry to remove any sort of
+ ! array re-ordering.
+
+ IF ( ABS(proj%gauss_lat(1) - proj%lat1) .GT. 0.01 ) THEN
+ proj%gauss_lat = -1. * proj%gauss_lat
+ END IF
+
+ ! Just a sanity check.
+
+ IF ( ABS(proj%gauss_lat(1) - proj%lat1) .GT. 0.01 ) THEN
+ PRINT '(A)','Oops, something is not right with the Gaussian latitude computation.'
+ PRINT '(A,F8.3,A)','The input data gave the starting latitude as ',proj%lat1,'.'
+ PRINT '(A,F8.3,A)','This routine computed the starting latitude as +-',ABS(proj%gauss_lat(1)),'.'
+ PRINT '(A,F8.3,A)','The difference is larger than 0.01 degrees, which is not expected.'
+ CALL llxy_error_fatal ( 'Gaussian_latitude_computation' )
+ END IF
+
+ END SUBROUTINE set_gauss
+
+
+ SUBROUTINE gausll ( nlat , lat_sp )
+
+ IMPLICIT NONE
+
+ INTEGER :: nlat , i
+ REAL (KIND=HIGH) , PARAMETER :: pi = 3.141592653589793
+ REAL (KIND=HIGH) , DIMENSION(nlat) :: cosc , gwt , sinc , colat , wos2 , lat
+ REAL (KIND=4) , DIMENSION(nlat) :: lat_sp
+
+ CALL lggaus(nlat, cosc, gwt, sinc, colat, wos2)
+
+ DO i = 1, nlat
+ lat(i) = ACOS(sinc(i)) * 180._HIGH / pi
+ IF (i.gt.nlat/2) lat(i) = -lat(i)
+ END DO
+
+ lat_sp = REAL(lat)
+
+ END SUBROUTINE gausll
+
+
+ SUBROUTINE lggaus( nlat, cosc, gwt, sinc, colat, wos2 )
+
+ IMPLICIT NONE
+
+ ! LGGAUS finds the Gaussian latitudes by finding the roots of the
+ ! ordinary Legendre polynomial of degree NLAT using Newton's
+ ! iteration method.
+
+ ! On entry:
+ integer NLAT ! the number of latitudes (degree of the polynomial)
+
+ ! On exit: for each Gaussian latitude
+ ! COSC - cos(colatitude) or sin(latitude)
+ ! GWT - the Gaussian weights
+ ! SINC - sin(colatitude) or cos(latitude)
+ ! COLAT - the colatitudes in radians
+ ! WOS2 - Gaussian weight over sin**2(colatitude)
+
+ REAL (KIND=HIGH) , DIMENSION(nlat) :: cosc , gwt , sinc , colat , wos2
+ REAL (KIND=HIGH) , PARAMETER :: pi = 3.141592653589793
+
+ ! Convergence criterion for iteration of cos latitude
+
+ REAL (KIND=4) , PARAMETER :: xlim = 1.0E-14
+
+ INTEGER :: nzero, i, j
+ REAL (KIND=HIGH) :: fi, fi1, a, b, g, gm, gp, gt, delta, c, d
+
+ ! The number of zeros between pole and equator
+
+ nzero = nlat/2
+
+ ! Set first guess for cos(colat)
+
+ DO i=1,nzero
+ cosc(i) = SIN( (i-0.5)*pi/nlat + pi*0.5 )
+ END DO
+
+ ! Constants for determining the derivative of the polynomial
+ fi = nlat
+ fi1 = fi+1.0
+ a = fi*fi1 / SQRT(4.0*fi1*fi1-1.0)
+ b = fi1*fi / SQRT(4.0*fi*fi-1.0)
+
+ ! Loop over latitudes, iterating the search for each root
+
+ DO i=1,nzero
+ j=0
+
+ ! Determine the value of the ordinary Legendre polynomial for
+ ! the current guess root
+
+ DO
+ CALL lgord( g, cosc(i), nlat )
+
+ ! Determine the derivative of the polynomial at this point
+
+ CALL lgord( gm, cosc(i), nlat-1 )
+ CALL lgord( gp, cosc(i), nlat+1 )
+ gt = (cosc(i)*cosc(i)-1.0) / (a*gp-b*gm)
+
+ ! Update the estimate of the root
+
+ delta = g*gt
+ cosc(i) = cosc(i) - delta
+
+ ! If convergence criterion has not been met, keep trying
+
+ j = j+1
+ IF( ABS(delta).GT.xlim ) CYCLE
+
+ ! Determine the Gaussian weights
+
+ c = 2.0 *( 1.0-cosc(i)*cosc(i) )
+ CALL lgord( d, cosc(i), nlat-1 )
+ d = d*d*fi*fi
+ gwt(i) = c *( fi-0.5 ) / d
+ EXIT
+
+ END DO
+
+ END DO
+
+ ! Determine the colatitudes and sin(colat) and weights over sin**2
+
+ DO i=1,nzero
+ colat(i)= ACOS(cosc(i))
+ sinc(i) = SIN(colat(i))
+ wos2(i) = gwt(i) /( sinc(i)*sinc(i) )
+ END DO
+
+ ! If NLAT is odd, set values at the equator
+
+ IF( MOD(nlat,2) .NE. 0 ) THEN
+ i = nzero+1
+ cosc(i) = 0.0
+ c = 2.0
+ CALL lgord( d, cosc(i), nlat-1 )
+ d = d*d*fi*fi
+ gwt(i) = c *( fi-0.5 ) / d
+ colat(i)= pi*0.5
+ sinc(i) = 1.0
+ wos2(i) = gwt(i)
+ END IF
+
+ ! Determine the southern hemisphere values by symmetry
+
+ DO i=nlat-nzero+1,nlat
+ cosc(i) =-cosc(nlat+1-i)
+ gwt(i) = gwt(nlat+1-i)
+ colat(i)= pi-colat(nlat+1-i)
+ sinc(i) = sinc(nlat+1-i)
+ wos2(i) = wos2(nlat+1-i)
+ END DO
+
+ END SUBROUTINE lggaus
+
+
+ SUBROUTINE lgord( f, cosc, n )
+
+ IMPLICIT NONE
+
+ ! LGORD calculates the value of an ordinary Legendre polynomial at a
+ ! specific latitude.
+
+ ! On entry:
+ ! cosc - COS(colatitude)
+ ! n - the degree of the polynomial
+
+ ! On exit:
+ ! f - the value of the Legendre polynomial of degree N at
+ ! latitude ASIN(cosc)
+
+ REAL (KIND=HIGH) :: s1, c4, a, b, fk, f, cosc, colat, c1, fn, ang
+ INTEGER :: n, k
+
+ ! Determine the colatitude
+
+ colat = ACOS(cosc)
+
+ c1 = SQRT(2.0_HIGH)
+ DO k=1,n
+ c1 = c1 * SQRT( 1.0 - 1.0/(4*k*k) )
+ END DO
+
+ fn = n
+ ang= fn * colat
+ s1 = 0.0
+ c4 = 1.0
+ a =-1.0
+ b = 0.0
+ DO k=0,n,2
+ IF (k.eq.n) c4 = 0.5 * c4
+ s1 = s1 + c4 * COS(ang)
+ a = a + 2.0
+ b = b + 1.0
+ fk = k
+ ang= colat * (fn-fk-2.0)
+ c4 = ( a * (fn-b+1.0) / ( b * (fn+fn-a) ) ) * c4
+ END DO
+
+ f = s1 * c1
+
+ END SUBROUTINE lgord
+
+
+ SUBROUTINE llij_gauss (lat, lon, proj, i, j)
+
+ IMPLICIT NONE
+
+ REAL (KIND=4) , INTENT(IN) :: lat, lon
+ REAL (KIND=4) , INTENT(OUT) :: i, j
+ TYPE (proj_info), INTENT(IN) :: proj
+
+ INTEGER :: n , n_low
+ LOGICAL :: found = .FALSE.
+ REAL (KIND=4) :: diff_1 , diff_nlat
+
+ ! The easy one first, get the x location. The calling routine has already made
+ ! sure that the necessary assumptions concerning the sign of the deltalon and the
+ ! relative east/west'ness of the longitude and the starting longitude are consistent
+ ! to allow this easy computation.
+
+ i = ( lon - proj%lon1 ) / proj%loninc + 1.
+
+ ! Since this is a global data set, we need to be concerned about wrapping the
+ ! fields around the globe.
+
+! IF ( ( proj%loninc .GT. 0 ) .AND. &
+! ( FLOOR((lon-proj%lon1)/proj%loninc) + 1 .GE. proj%ixdim ) .AND. &
+! ( lon + proj%loninc .GE. proj%lon1 + 360 ) ) THEN
+!! BUG: We may need to set proj%wrap, but proj is intent(in)
+!! WHAT IS THIS USED FOR?
+!! proj%wrap = .TRUE.
+! i = proj%ixdim
+! ELSE IF ( ( proj%loninc .LT. 0 ) .AND. &
+! ( FLOOR((lon-proj%lon1)/proj%loninc) + 1 .GE. proj%ixdim ) .AND. &
+! ( lon + proj%loninc .LE. proj%lon1 - 360 ) ) THEN
+! ! BUG: We may need to set proj%wrap, but proj is intent(in)
+! ! WHAT IS THIS USED FOR?
+! ! proj%wrap = .TRUE.
+! i = proj%ixdim
+! END IF
+
+ ! Yet another quicky test, can we find bounding values? If not, then we may be
+ ! dealing with putting data to a polar projection, so just give them them maximal
+ ! value for the location. This is an OK assumption for the interpolation across the
+ ! top of the pole, given how close the longitude lines are.
+
+ IF ( ABS(lat) .GT. ABS(proj%gauss_lat(1)) ) THEN
+
+ diff_1 = lat - proj%gauss_lat(1)
+ diff_nlat = lat - proj%gauss_lat(proj%nlat*2)
+
+ IF ( ABS(diff_1) .LT. ABS(diff_nlat) ) THEN
+ j = 1
+ ELSE
+ j = proj%nlat*2
+ END IF
+
+ ! If the latitude is between the two bounding values, we have to search and interpolate.
+
+ ELSE
+
+ DO n = 1 , proj%nlat*2 -1
+ IF ( ( proj%gauss_lat(n) - lat ) * ( proj%gauss_lat(n+1) - lat ) .LE. 0 ) THEN
+ found = .TRUE.
+ n_low = n
+ EXIT
+ END IF
+ END DO
+
+ ! Everything still OK?
+
+ IF ( .NOT. found ) THEN
+ PRINT '(A)','Troubles in river city. No bounding values of latitude found in the Gaussian routines.'
+ CALL llxy_error_fatal ( 'Gee_no_bounding_lats_Gaussian' )
+ END IF
+
+ j = ( ( proj%gauss_lat(n_low) - lat ) * ( n_low + 1 ) + &
+ ( lat - proj%gauss_lat(n_low+1) ) * ( n_low ) ) / &
+ ( proj%gauss_lat(n_low) - proj%gauss_lat(n_low+1) )
+
+ END IF
+
+ END SUBROUTINE llij_gauss
+
+
+ SUBROUTINE llxy_error_fatal(mesg)
+
+ IMPLICIT NONE
+
+ CHARACTER (LEN=*), INTENT(IN) :: mesg
+
+ WRITE(0,*) trim(mesg)
+ STOP
+
+ END SUBROUTINE llxy_error_fatal
+
+END MODULE llxy
Added: branches/atmos_physics/src/core_init_nhyd_atmos/module_mpas_core.F
===================================================================
--- branches/atmos_physics/src/core_init_nhyd_atmos/module_mpas_core.F (rev 0)
+++ branches/atmos_physics/src/core_init_nhyd_atmos/module_mpas_core.F 2011-01-05 00:56:27 UTC (rev 673)
@@ -0,0 +1,68 @@
+module mpas_core
+
+
+ contains
+
+
+ subroutine mpas_core_init(domain)
+
+ use grid_types
+ use configure
+ use test_cases
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+
+ end subroutine mpas_core_init
+
+
+ subroutine mpas_core_run(domain, output_obj, output_frame)
+
+ use grid_types
+ use io_output
+ use timer
+ use test_cases
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+ type (io_output_object), intent(inout) :: output_obj
+ integer, intent(inout) :: output_frame
+
+ integer :: ntimesteps, itimestep
+ real (kind=RKIND) :: dt
+ type (block_type), pointer :: block
+
+
+ call setup_nhyd_test_case(domain)
+
+ !
+ ! Note: The following initialization calls have been moved to mpas_setup_test_case()
+ ! since values computed by these routines are needed to produce initial fields
+ !
+ ! call initialize_advection_rk(mesh)
+ ! call initialize_deformation_weights(mesh)
+
+ block => domain % blocklist
+ do while (associated(block))
+ block % state % time_levs(1) % state % xtime % scalar = 0.0
+ block => block % next
+ end do
+
+ call output_state_for_domain(output_obj, domain, output_frame)
+
+ end subroutine mpas_core_run
+
+
+ subroutine mpas_core_finalize(domain)
+
+ use grid_types
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+
+ end subroutine mpas_core_finalize
+
+end module mpas_core
Added: branches/atmos_physics/src/core_init_nhyd_atmos/module_read_met.F
===================================================================
--- branches/atmos_physics/src/core_init_nhyd_atmos/module_read_met.F (rev 0)
+++ branches/atmos_physics/src/core_init_nhyd_atmos/module_read_met.F 2011-01-05 00:56:27 UTC (rev 673)
@@ -0,0 +1,409 @@
+module read_met
+
+ integer, parameter :: MAX_FILENAME_LEN = 1024
+
+ real (kind=4), parameter :: EARTH_RADIUS_M = 6370000. ! same as MM5 system
+
+ ! Projection codes for proj_info structure:
+ INTEGER, PRIVATE, PARAMETER :: PROJ_LATLON = 0
+ INTEGER, PRIVATE, PARAMETER :: PROJ_LC = 1
+ INTEGER, PRIVATE, PARAMETER :: PROJ_PS = 2
+ INTEGER, PRIVATE, PARAMETER :: PROJ_MERC = 3
+ INTEGER, PRIVATE, PARAMETER :: PROJ_GAUSS = 4
+
+
+ ! Derived types
+ type met_data
+ integer :: version, nx, ny, iproj
+ real (kind=4) :: xfcst, xlvl, startlat, startlon, starti, startj, &
+ deltalat, deltalon, dx, dy, xlonc, &
+ truelat1, truelat2, earth_radius
+ real (kind=4), pointer, dimension(:,:) :: slab
+ logical :: is_wind_grid_rel
+ character (len=9) :: field
+ character (len=24) :: hdate
+ character (len=25) :: units
+ character (len=32) :: map_source
+ character (len=46) :: desc
+ end type met_data
+
+
+ ! State variables?
+ integer :: input_unit
+ character (len=MAX_FILENAME_LEN) :: filename
+
+ contains
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Name: read_met_init
+ !
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine read_met_init(fg_source, source_is_constant, datestr, istatus)
+
+ implicit none
+
+ ! Arguments
+ integer, intent(out) :: istatus
+ logical, intent(in) :: source_is_constant
+ character (len=*), intent(in) :: fg_source
+ character (len=*), intent(in) :: datestr
+
+ ! Local variables
+ integer :: io_status
+ logical :: is_used
+
+ istatus = 0
+
+ ! 1) BUILD FILENAME BASED ON TIME
+ filename = ' '
+ if (.not. source_is_constant) then
+ write(filename, '(a)') trim(fg_source)//':'//trim(datestr)
+ else
+ write(filename, '(a)') trim(fg_source)
+ end if
+
+ ! 2) OPEN FILE
+ do input_unit=10,100
+ inquire(unit=input_unit, opened=is_used)
+ if (.not. is_used) exit
+ end do
+ if (input_unit > 100) write(0,*) 'Error: In read_met_init(), couldn''t find an available Fortran unit.'
+ open(unit=input_unit, file=trim(filename), status='old', form='unformatted', iostat=io_status)
+
+ if (io_status > 0) istatus = 1
+
+ return
+
+
+ end subroutine read_met_init
+
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Name: read_next_met_field
+ !
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine read_next_met_field(fg_data, istatus)
+
+ implicit none
+
+ ! Arguments
+ type (met_data), intent(inout) :: fg_data
+ integer, intent(out) :: istatus
+
+ ! Local variables
+ character (len=8) :: startloc
+
+ istatus = 1
+
+ ! 1) READ FORMAT VERSION
+ read(unit=input_unit,err=1001,end=1001) fg_data % version
+
+ ! PREGRID
+ if (fg_data % version == 3) then
+
+ read(unit=input_unit) fg_data % hdate, &
+ fg_data % xfcst, &
+ fg_data % field, &
+ fg_data % units, &
+ fg_data % desc, &
+ fg_data % xlvl, &
+ fg_data % nx, &
+ fg_data % ny, &
+ fg_data % iproj
+
+ fg_data % map_source = ' '
+
+ if (fg_data % field == 'HGT ') fg_data % field = 'GHT '
+
+ fg_data % starti = 1.0
+ fg_data % startj = 1.0
+
+ ! Cylindrical equidistant
+ if (fg_data % iproj == 0) then
+ fg_data % iproj = PROJ_LATLON
+ read(unit=input_unit,err=1001,end=1001) fg_data % startlat, &
+ fg_data % startlon, &
+ fg_data % deltalat, &
+ fg_data % deltalon
+
+ ! Mercator
+ else if (fg_data % iproj == 1) then
+ fg_data % iproj = PROJ_MERC
+ read(unit=input_unit,err=1001,end=1001) fg_data % startlat, &
+ fg_data % startlon, &
+ fg_data % dx, &
+ fg_data % dy, &
+ fg_data % truelat1
+
+ ! Lambert conformal
+ else if (fg_data % iproj == 3) then
+ fg_data % iproj = PROJ_LC
+ read(unit=input_unit,err=1001,end=1001) fg_data % startlat, &
+ fg_data % startlon, &
+ fg_data % dx, &
+ fg_data % dy, &
+ fg_data % xlonc, &
+ fg_data % truelat1, &
+ fg_data % truelat2
+
+ ! Polar stereographic
+ else if (fg_data % iproj == 5) then
+ fg_data % iproj = PROJ_PS
+ read(unit=input_unit,err=1001,end=1001) fg_data % startlat, &
+ fg_data % startlon, &
+ fg_data % dx, &
+ fg_data % dy, &
+ fg_data % xlonc, &
+ fg_data % truelat1
+
+ ! ?????????
+ else
+ write(0,*) 'Error: Unrecognized projection code ',fg_data % iproj,' when reading from '//trim(filename)
+
+ end if
+
+ fg_data % earth_radius = EARTH_RADIUS_M / 1000.
+
+#if (defined _GEOGRID) || (defined _METGRID)
+ fg_data % dx = fg_data % dx * 1000.
+ fg_data % dy = fg_data % dy * 1000.
+
+ if (fg_data % xlonc > 180.) fg_data % xlonc = fg_data%xlonc - 360.
+
+ if (fg_data % startlon > 180.) fg_data % startlon = fg_data%startlon - 360.
+
+ if (fg_data % startlat < -90.) fg_data % startlat = -90.
+ if (fg_data % startlat > 90.) fg_data % startlat = 90.
+#endif
+
+ fg_data % is_wind_grid_rel = .true.
+
+ allocate(fg_data % slab(fg_data % nx, fg_data % ny))
+ read(unit=input_unit,err=1001,end=1001) fg_data % slab
+
+ istatus = 0
+
+ ! GRIB_PREP
+ else if (fg_data % version == 4) then
+
+ read(unit=input_unit) fg_data % hdate, &
+ fg_data % xfcst, &
+ fg_data % map_source, &
+ fg_data % field, &
+ fg_data % units, &
+ fg_data % desc, &
+ fg_data % xlvl, &
+ fg_data % nx, &
+ fg_data % ny, &
+ fg_data % iproj
+
+ if (fg_data % field == 'HGT ') fg_data % field = 'GHT '
+
+ ! Cylindrical equidistant
+ if (fg_data % iproj == 0) then
+ fg_data % iproj = PROJ_LATLON
+ read(unit=input_unit,err=1001,end=1001) startloc, &
+ fg_data % startlat, &
+ fg_data % startlon, &
+ fg_data % deltalat, &
+ fg_data % deltalon
+
+ ! Mercator
+ else if (fg_data % iproj == 1) then
+ fg_data % iproj = PROJ_MERC
+ read(unit=input_unit,err=1001,end=1001) startloc, &
+ fg_data % startlat, &
+ fg_data % startlon, &
+ fg_data % dx, &
+ fg_data % dy, &
+ fg_data % truelat1
+
+ ! Lambert conformal
+ else if (fg_data % iproj == 3) then
+ fg_data % iproj = PROJ_LC
+ read(unit=input_unit,err=1001,end=1001) startloc, &
+ fg_data % startlat, &
+ fg_data % startlon, &
+ fg_data % dx, &
+ fg_data % dy, &
+ fg_data % xlonc, &
+ fg_data % truelat1, &
+ fg_data % truelat2
+
+ ! Polar stereographic
+ else if (fg_data % iproj == 5) then
+ fg_data % iproj = PROJ_PS
+ read(unit=input_unit,err=1001,end=1001) startloc, &
+ fg_data % startlat, &
+ fg_data % startlon, &
+ fg_data % dx, &
+ fg_data % dy, &
+ fg_data % xlonc, &
+ fg_data % truelat1
+
+ ! ?????????
+ else
+ write(0,*) 'Error: Unrecognized projection code ',fg_data % iproj,' when reading from '//trim(filename)
+
+ end if
+
+ if (startloc == 'CENTER ') then
+ fg_data % starti = real(fg_data % nx)/2.
+ fg_data % startj = real(fg_data % ny)/2.
+ else if (startloc == 'SWCORNER') then
+ fg_data % starti = 1.0
+ fg_data % startj = 1.0
+ end if
+
+ fg_data % earth_radius = EARTH_RADIUS_M / 1000.
+
+#if (defined _GEOGRID) || (defined _METGRID)
+ fg_data % dx = fg_data % dx * 1000.
+ fg_data % dy = fg_data % dy * 1000.
+
+ if (fg_data % xlonc > 180.) fg_data % xlonc = fg_data % xlonc - 360.
+
+ if (fg_data % startlon > 180.) fg_data % startlon = fg_data % startlon - 360.
+
+ if (fg_data % startlat < -90.) fg_data % startlat = -90.
+ if (fg_data % startlat > 90.) fg_data % startlat = 90.
+#endif
+
+ fg_data % is_wind_grid_rel = .true.
+
+ allocate(fg_data % slab(fg_data % nx, fg_data % ny))
+ read(unit=input_unit,err=1001,end=1001) fg_data % slab
+
+ istatus = 0
+
+ ! WPS
+ else if (fg_data % version == 5) then
+
+ read(unit=input_unit) fg_data % hdate, &
+ fg_data % xfcst, &
+ fg_data % map_source, &
+ fg_data % field, &
+ fg_data % units, &
+ fg_data % desc, &
+ fg_data % xlvl, &
+ fg_data % nx, &
+ fg_data % ny, &
+ fg_data % iproj
+
+ if (fg_data % field == 'HGT ') fg_data % field = 'GHT '
+
+ ! Cylindrical equidistant
+ if (fg_data % iproj == 0) then
+ fg_data % iproj = PROJ_LATLON
+ read(unit=input_unit,err=1001,end=1001) startloc, &
+ fg_data % startlat, &
+ fg_data % startlon, &
+ fg_data % deltalat, &
+ fg_data % deltalon, &
+ fg_data % earth_radius
+
+ ! Mercator
+ else if (fg_data % iproj == 1) then
+ fg_data % iproj = PROJ_MERC
+ read(unit=input_unit,err=1001,end=1001) startloc, &
+ fg_data % startlat, &
+ fg_data % startlon, &
+ fg_data % dx, &
+ fg_data % dy, &
+ fg_data % truelat1, &
+ fg_data % earth_radius
+
+ ! Lambert conformal
+ else if (fg_data % iproj == 3) then
+ fg_data % iproj = PROJ_LC
+ read(unit=input_unit,err=1001,end=1001) startloc, &
+ fg_data % startlat, &
+ fg_data % startlon, &
+ fg_data % dx, &
+ fg_data % dy, &
+ fg_data % xlonc, &
+ fg_data % truelat1, &
+ fg_data % truelat2, &
+ fg_data % earth_radius
+
+ ! Gaussian
+ else if (fg_data % iproj == 4) then
+ fg_data % iproj = PROJ_GAUSS
+ read(unit=input_unit,err=1001,end=1001) startloc, &
+ fg_data % startlat, &
+ fg_data % startlon, &
+ fg_data % deltalat, &
+ fg_data % deltalon, &
+ fg_data % earth_radius
+
+ ! Polar stereographic
+ else if (fg_data % iproj == 5) then
+ fg_data % iproj = PROJ_PS
+ read(unit=input_unit,err=1001,end=1001) startloc, &
+ fg_data % startlat, &
+ fg_data % startlon, &
+ fg_data % dx, &
+ fg_data % dy, &
+ fg_data % xlonc, &
+ fg_data % truelat1, &
+ fg_data % earth_radius
+
+ ! ?????????
+ else
+ write(0,*) 'Error: Unrecognized projection code ',fg_data % iproj,' when reading from '//trim(filename)
+
+ end if
+
+ if (startloc == 'CENTER ') then
+ fg_data % starti = real(fg_data % nx)/2.
+ fg_data % startj = real(fg_data % ny)/2.
+ else if (startloc == 'SWCORNER') then
+ fg_data % starti = 1.0
+ fg_data % startj = 1.0
+ end if
+
+#if (defined _GEOGRID) || (defined _METGRID)
+ fg_data % dx = fg_data % dx * 1000.
+ fg_data % dy = fg_data % dy * 1000.
+
+ if (fg_data % xlonc > 180.) fg_data % xlonc = fg_data % xlonc - 360.
+
+ if (fg_data % startlon > 180.) fg_data % startlon = fg_data % startlon - 360.
+
+ if (fg_data % startlat < -90.) fg_data % startlat = -90.
+ if (fg_data % startlat > 90.) fg_data % startlat = 90.
+#endif
+
+ read(unit=input_unit,err=1001,end=1001) fg_data % is_wind_grid_rel
+
+ allocate(fg_data % slab(fg_data % nx, fg_data % ny))
+ read(unit=input_unit,err=1001,end=1001) fg_data % slab
+
+ istatus = 0
+
+ else
+ write(0,*) 'Error: Didn''t recognize format version of data in '//trim(filename)//'.</font>
<font color="gray">'// &
+ 'Found version ',fg_data % version,' but expected either 3, 4, or 5. This could be an endian problem.'
+ end if
+
+ return
+
+ 1001 return
+
+ end subroutine read_next_met_field
+
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Name: read_met_close
+ !
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine read_met_close()
+
+ implicit none
+
+ close(unit=input_unit)
+ filename = 'UNINITIALIZED_FILENAME'
+
+ end subroutine read_met_close
+
+end module read_met
Added: branches/atmos_physics/src/core_init_nhyd_atmos/module_test_cases.F
===================================================================
--- branches/atmos_physics/src/core_init_nhyd_atmos/module_test_cases.F (rev 0)
+++ branches/atmos_physics/src/core_init_nhyd_atmos/module_test_cases.F 2011-01-05 00:56:27 UTC (rev 673)
@@ -0,0 +1,2643 @@
+module test_cases
+
+ use grid_types
+ use configure
+ use constants
+ use dmpar
+ use advection
+
+
+ contains
+
+
+ subroutine setup_nhyd_test_case(domain)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Configure grid metadata and model state for the hydrostatic 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
+ type (block_type), pointer :: block_ptr
+
+ if (config_test_case == 0) then
+ write(0,*) ' Using initial conditions from input file'
+ block_ptr => domain % blocklist
+ do while (associated(block_ptr))
+ do i=2,nTimeLevs
+ call 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
+
+ else if ((config_test_case == 1) .or. (config_test_case == 2) .or. (config_test_case == 3)) then
+ write(0,*) ' Jablonowski and Williamson baroclinic wave test case '
+ if (config_test_case == 1) write(0,*) ' no initial perturbation '
+ if (config_test_case == 2) write(0,*) ' initial perturbation included '
+ if (config_test_case == 3) write(0,*) ' normal-mode perturbation included '
+ block_ptr => domain % blocklist
+ do while (associated(block_ptr))
+ write(0,*) ' calling test case setup '
+ call nhyd_test_case_jw(block_ptr % mesh, block_ptr % state % time_levs(1) % state, block_ptr % diag, config_test_case)
+ write(0,*) ' returned from test case setup '
+ do i=2,nTimeLevs
+ call 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
+
+ else if ((config_test_case == 4) .or. (config_test_case ==5)) then
+
+ write(0,*) ' squall line - super cell test case '
+ if (config_test_case == 4) write(0,*) ' squall line test case'
+ if (config_test_case == 5) write(0,*) ' supercell test case'
+ block_ptr => domain % blocklist
+ do while (associated(block_ptr))
+ write(0,*) ' calling test case setup '
+ call nhyd_test_case_squall_line(domain % dminfo, block_ptr % mesh, block_ptr % state % time_levs(1) % state, block_ptr % diag, config_test_case)
+ write(0,*) ' returned from test case setup '
+ do i=2,nTimeLevs
+ call 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
+
+ else if (config_test_case == 6 ) then
+
+ write(0,*) ' mountain wave test case '
+ block_ptr => domain % blocklist
+ do while (associated(block_ptr))
+ write(0,*) ' calling test case setup '
+ call nhyd_test_case_mtn_wave(block_ptr % mesh, block_ptr % state % time_levs(1) % state, block_ptr % diag, config_test_case)
+ write(0,*) ' returned from test case setup '
+ do i=2,nTimeLevs
+ call 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
+
+ else if (config_test_case == 7 ) then
+
+ write(0,*) ' real-data GFS test case '
+ block_ptr => domain % blocklist
+ do while (associated(block_ptr))
+ call nhyd_test_case_gfs(domain % dminfo, block_ptr % mesh, block_ptr % fg, block_ptr % state % time_levs(1) % state, block_ptr % diag, config_test_case)
+ do i=2,nTimeLevs
+ call 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
+
+ else
+
+
+ write(0,*) ' Only test case 1, 2, 3, 4, 5, 6, and 7 are currently supported for nonhydrostatic core '
+ stop
+ end if
+
+ end subroutine setup_nhyd_test_case
+
+!----------------------------------------------------------------------------------------------------------
+
+ subroutine nhyd_test_case_jw(grid, state, diag, test_case)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Setup baroclinic wave test case from Jablonowski and Williamson 2008 (QJRMS)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (mesh_type), intent(inout) :: grid
+ type (state_type), intent(inout) :: state
+ type (diag_type), intent(inout) :: diag
+ integer, intent(in) :: test_case
+
+ real (kind=RKIND), parameter :: u0 = 35.0
+ real (kind=RKIND), parameter :: alpha_grid = 0. ! no grid rotation
+ real (kind=RKIND), parameter :: omega_e = 7.29212e-05
+ real (kind=RKIND), parameter :: t0b = 250., t0 = 288., delta_t = 4.8e+05, dtdz = 0.005, eta_t = 0.2
+ real (kind=RKIND), parameter :: u_perturbation = 1., pert_radius = 0.1, latitude_pert = 40., longitude_pert = 20.
+ real (kind=RKIND), parameter :: theta_c = pii/4.0
+ real (kind=RKIND), parameter :: lambda_c = 3.0*pii/2.0
+ real (kind=RKIND), parameter :: rh_max = 0.4 ! Maximum relative humidity
+ real (kind=RKIND), parameter :: k_x = 9. ! Normal mode wave number
+
+ real (kind=RKIND), dimension(:), pointer :: rdzw, dzu, rdzu, fzm, fzp
+ real (kind=RKIND), dimension(:,:), pointer :: zgrid, zx, zz, hx
+ real (kind=RKIND), dimension(:,:), pointer :: pressure, ppb, pb, rho, rb, rr, tb, rtb, p, pp, dss, t, rt
+ real (kind=RKIND), dimension(:,:,:), pointer :: zf, zf3, zb, zb3
+ real (kind=RKIND), dimension(:,:,:), pointer :: scalars
+ real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
+
+ integer :: iCell, iCell1, iCell2 , iEdge, vtx1, vtx2, ivtx, i, k, nz, nz1, itr, itrp, cell1, cell2, nCellsSolve
+
+ !This is temporary variable here. It just need when calculate tangential velocity v.
+ integer :: eoe, j
+ integer, dimension(:), pointer :: nEdgesOnEdge
+ integer, dimension(:,:), pointer :: edgesOnEdge, CellsOnEdge
+ real, dimension(:), pointer :: dvEdge, AreaCell
+ real, dimension(:,:), pointer :: weightsOnEdge
+
+ real (kind=RKIND) :: u, v, flux, fluxk, lat1, lat2, eta_v, r_pert, u_pert, lat_pert, lon_pert, r
+
+ real (kind=RKIND) :: ptop, p0, phi
+ real (kind=RKIND) :: lon_Edge
+
+ real (kind=RKIND) :: r_earth, etavs, ztemp, zd, zt, dz, gam, delt, str
+
+ real (kind=RKIND), dimension(grid % nVertLevels, grid % nCells) :: rel_hum, temperature, qv
+ real (kind=RKIND) :: ptmp, es, qvs, xnutr, znut, ptemp
+ integer :: iter
+
+ real (kind=RKIND), dimension(grid % nVertLevels + 1 ) :: hyai, hybi, znu, znw, znwc, znwv, hyam, hybm
+ real (kind=RKIND), dimension(grid % nVertLevels + 1 ) :: znuc, znuv, bn, divh, dpn
+
+ real (kind=RKIND), dimension(grid % nVertLevels + 1 ) :: sh, zw, ah
+ real (kind=RKIND), dimension(grid % nVertLevels ) :: zu, dzw, rdzwp, rdzwm
+ real (kind=RKIND), dimension(grid % nVertLevels ) :: eta, etav, teta, ppi, tt
+
+ real (kind=RKIND) :: d1, d2, d3, cf1, cf2, cf3, cof1, cof2, psurf
+
+ ! storage for (lat,z) arrays for zonal velocity calculation
+
+ integer, parameter :: nlat=361
+ real (kind=RKIND), dimension(grid % nVertLevels + 1) :: zz_1d, zgrid_1d, hx_1d
+ real (kind=RKIND), dimension(grid % nVertLevels) :: flux_zonal
+ real (kind=RKIND), dimension(nlat, grid % nVertLevels) :: u_2d, etavs_2d
+ real (kind=RKIND), dimension(nlat) :: lat_2d
+ real (kind=RKIND) :: dlat
+ real (kind=RKIND) :: z_edge, z_edge3, d2fdx2_cell1, d2fdx2_cell2
+
+ !
+ ! 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
+
+ weightsOnEdge => grid % weightsOnEdge % array
+ nEdgesOnEdge => grid % nEdgesOnEdge % array
+ edgesOnEdge => grid % edgesOnEdge % array
+ dvEdge => grid % dvEdge % array
+ AreaCell => grid % AreaCell % array
+ CellsOnEdge => grid % CellsOnEdge % array
+
+ deriv_two => grid % deriv_two % array
+ zf => grid % zf % array
+ zf3 => grid % zf3% array
+ zb => grid % zb % array
+ zb3 => grid % zb3% array
+
+ nz1 = grid % nVertLevels
+ nz = nz1 + 1
+ nCellsSolve = grid % nCellsSolve
+
+ zgrid => grid % zgrid % array
+ rdzw => grid % rdzw % array
+ dzu => grid % dzu % array
+ rdzu => grid % rdzu % array
+ fzm => grid % fzm % array
+ fzp => grid % fzp % array
+ zx => grid % zx % array
+ zz => grid % zz % array
+ hx => grid % hx % array
+ dss => grid % dss % array
+
+ pb => diag % exner_base % array
+ rb => diag % rho_base % array
+ tb => diag % theta_base % array
+ rtb => diag % rtheta_base % array
+ p => diag % exner % array
+
+ ppb => diag % pressure_base % array
+ pp => diag % pressure_p % array
+
+ rho => state % rho % array
+ rr => diag % rho_p % array
+ t => state % theta % array
+ rt => diag % rtheta_p % array
+
+ scalars => state % scalars % array
+
+ scalars(:,:,:) = 0.
+
+ call initialize_advection_rk(grid)
+ call initialize_deformation_weights(grid)
+
+ xnutr = 0.
+ zd = 12000.
+ znut = eta_t
+
+ etavs = (1.-0.252)*pii/2.
+ r_earth = a
+ p0 = 1.e+05
+
+ write(0,*) ' point 1 in test case setup '
+
+! We may pass in an hx(:,:) that has been precomputed elsewhere.
+! For now it is independent of k
+
+ do iCell=1,grid % nCells
+ do k=1,nz
+ phi = grid % latCell % array (iCell)
+ hx(k,iCell) = u0/gravity*cos(etavs)**1.5 &
+ *((-2.*sin(phi)**6 &
+ *(cos(phi)**2+1./3.)+10./63.) &
+ *(u0)*cos(etavs)**1.5 &
+ +(1.6*cos(phi)**3 &
+ *(sin(phi)**2+2./3.)-pii/4.)*r_earth*omega_e)
+ enddo
+ enddo
+
+ ! Metrics for hybrid coordinate and vertical stretching
+
+ str = 1.5
+ zt = 45000.
+ dz = zt/float(nz1)
+
+ write(0,*) ' hx computation complete '
+
+ do k=1,nz
+
+! sh(k) is the stretching specified for height surfaces
+
+ sh(k) = (real(k-1)*dz/zt)**str
+
+! to specify specific heights zc(k) for coordinate surfaces,
+! input zc(k) and define sh(k) = zc(k)/zt
+! zw(k) is the hieght of zeta surfaces
+! zw(k) = (k-1)*dz yields constant dzeta
+! and nonconstant dzeta/dz
+! zw(k) = sh(k)*zt yields nonconstant dzeta
+! and nearly constant dzeta/dz
+
+ zw(k) = float(k-1)*dz
+! zw(k) = sh(k)*zt
+!
+! ah(k) governs the transition between terrain-following
+! and pureheight coordinates
+! ah(k) = 0 is a terrain-following coordinate
+! ah(k) = 1 is a height coordinate
+
+ ah(k) = 1.-cos(.5*pii*(k-1)*dz/zt)**6
+! ah(k) = 0.
+ write(0,*) ' k, sh, zw, ah ',k,sh(k),zw(k),ah(k)
+ end do
+ do k=1,nz1
+ dzw (k) = zw(k+1)-zw(k)
+ rdzw(k) = 1./dzw(k)
+ zu(k ) = .5*(zw(k)+zw(k+1))
+ end do
+ do k=2,nz1
+ dzu (k) = .5*(dzw(k)+dzw(k-1))
+ rdzu(k) = 1./dzu(k)
+ fzp (k) = .5* dzw(k )/dzu(k)
+ fzm (k) = .5* dzw(k-1)/dzu(k)
+ rdzwp(k) = dzw(k-1)/(dzw(k )*(dzw(k)+dzw(k-1)))
+ rdzwm(k) = dzw(k )/(dzw(k-1)*(dzw(k)+dzw(k-1)))
+ end do
+
+!********** how are we storing cf1, cf2 and cf3?
+
+ COF1 = (2.*DZU(2)+DZU(3))/(DZU(2)+DZU(3))*DZW(1)/DZU(2)
+ COF2 = DZU(2) /(DZU(2)+DZU(3))*DZW(1)/DZU(3)
+ CF1 = FZP(2) + COF1
+ CF2 = FZM(2) - COF1 - COF2
+ CF3 = COF2
+
+! d1 = .5*dzw(1)
+! d2 = dzw(1)+.5*dzw(2)
+! d3 = dzw(1)+dzw(2)+.5*dzw(3)
+! cf1 = d2*d3*(d3-d2)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
+! cf2 = d1*d3*(d1-d3)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
+! cf3 = d1*d2*(d2-d1)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
+
+ write(0,*) ' cf1, cf2, cf3 = ',cf1,cf2,cf3
+
+ grid % cf1 % scalar = cf1
+ grid % cf2 % scalar = cf2
+ grid % cf3 % scalar = cf3
+
+ do iCell=1,grid % nCells
+ do k=1,nz
+ zgrid(k,iCell) = (1.-ah(k))*(sh(k)*(zt-hx(k,iCell))+hx(k,iCell)) &
+ + ah(k) * sh(k)* zt
+ end do
+ do k=1,nz1
+ zz (k,iCell) = (zw(k+1)-zw(k))/(zgrid(k+1,iCell)-zgrid(k,iCell))
+ end do
+ end do
+
+ do i=1, grid % nEdges
+ iCell1 = grid % CellsOnEdge % array(1,i)
+ iCell2 = grid % CellsOnEdge % array(2,i)
+ do k=1,nz
+ zx (k,i) = (zgrid(k,iCell2)-zgrid(k,iCell1)) / grid % dcEdge % array(i)
+ end do
+ end do
+ do i=1, grid % nCells
+ do k=1,nz1
+ ztemp = .5*(zgrid(k+1,i)+zgrid(k,i))
+ dss(k,i) = 0.
+ ztemp = zgrid(k,i)
+ if(ztemp.gt.zd+.1) then
+ dss(k,i) = dss(k,i)+xnutr*sin(.5*pii*(ztemp-zd)/(zt-zd))**2
+ end if
+ end do
+ enddo
+
+ do k=1,nz1
+ write(0,*) ' k, zgrid(k,1),hx(k,1) ',k,zgrid(k,1),hx(k,1)
+ enddo
+
+ do k=1,nz1
+ write(0,*) ' k, zx(k,1) ',k,zx(k,1)
+ enddo
+
+ write(0,*) ' grid metrics setup complete '
+
+!************** section for 2d (lat,z) calc for zonal velocity
+
+ dlat = 0.5*pii/float(nlat-1)
+ do i = 1,nlat
+
+ lat_2d(i) = float(i-1)*dlat
+! write(0,*) ' zonal setup, latitude = ',lat_2d(i)*180./pii
+
+ do k=1,nz
+ phi = lat_2d(i)
+ hx_1d(k) = u0/gravity*cos(etavs)**1.5 &
+ *((-2.*sin(phi)**6 &
+ *(cos(phi)**2+1./3.)+10./63.) &
+ *(u0)*cos(etavs)**1.5 &
+ +(1.6*cos(phi)**3 &
+ *(sin(phi)**2+2./3.)-pii/4.)*r_earth*omega_e)
+ enddo
+
+ do k=1,nz
+ zgrid_1d(k) = (1.-ah(k))*(sh(k)*(zt-hx_1d(k))+hx_1d(k)) &
+ + ah(k) * sh(k)* zt
+ end do
+ do k=1,nz1
+ zz_1d (k) = (zw(k+1)-zw(k))/(zgrid_1d(k+1)-zgrid_1d(k))
+ end do
+
+ do k=1,nz1
+ ztemp = .5*(zgrid_1d(k+1)+zgrid_1d(k))
+ ppb(k,i) = p0*exp(-gravity*ztemp/(rgas*t0b))
+ pb (k,i) = (ppb(k,i)/p0)**(rgas/cp)
+ rb (k,i) = ppb(k,i)/(rgas*t0b*zz_1d(k))
+ tb (k,i) = t0b/pb(k,i)
+ rtb(k,i) = rb(k,i)*tb(k,i)
+ p (k,i) = pb(k,i)
+ pp (k,i) = 0.
+ rr (k,i) = 0.
+ end do
+
+
+ do itr = 1,10
+
+ do k=1,nz1
+ eta (k) = (ppb(k,i)+pp(k,i))/p0
+ etav(k) = (eta(k)-.252)*pii/2.
+ if(eta(k).ge.znut) then
+ teta(k) = t0*eta(k)**(rgas*dtdz/gravity)
+ else
+ teta(k) = t0*eta(k)**(rgas*dtdz/gravity) + delta_t*(znut-eta(k))**5
+ end if
+ end do
+ ! phi = grid % latCell % array (i)
+ phi = lat_2d (i)
+ do k=1,nz1
+ tt(k) = 0.
+ tt(k) = teta(k)+.75*eta(k)*pii*u0/rgas*sin(etav(k)) &
+ *sqrt(cos(etav(k)))* &
+ ((-2.*sin(phi)**6 &
+ *(cos(phi)**2+1./3.)+10./63.) &
+ *2.*u0*cos(etav(k))**1.5 &
+ +(1.6*cos(phi)**3 &
+ *(sin(phi)**2+2./3.)-pii/4.)*r_earth*omega_e)
+
+
+ ztemp = .5*(zgrid_1d(k)+zgrid_1d(k+1))
+ ptemp = ppb(k,i) + pp(k,i)
+ qv(k,i) = 0.
+
+ end do
+
+ do itrp = 1,25
+ do k=1,nz1
+ rr(k,i) = (pp(k,i)/(rgas*zz_1d(k)) &
+ -rb(k,i)*(tt(k)-t0b))/tt(k)
+ end do
+
+ ppi(1) = p0-.5*dzw(1)*gravity &
+ *(1.25*(rr(1,i)+rb(1,i))*(1.+qv(1,i)) &
+ -.25*(rr(2,i)+rb(2,i))*(1.+qv(2,i)))
+
+ ppi(1) = ppi(1)-ppb(1,i)
+ do k=1,nz1-1
+ ppi(k+1) = ppi(k)-.5*dzu(k+1)*gravity* &
+ (rr(k ,i)+(rr(k ,i)+rb(k ,i))*qv(k ,i) &
+ +rr(k+1,i)+(rr(k+1,i)+rb(k+1,i))*qv(k+1,i))
+ end do
+
+ do k=1,nz1
+ pp(k,i) = .2*ppi(k)+.8*pp(k,i)
+ end do
+
+ end do ! end inner iteration loop itrp
+
+ end do ! end outer iteration loop itr
+
+ do k=1,nz1
+ etavs_2d(i,k) = (0.5*(ppb(k,i)+ppb(k,i)+pp(k,i)+pp(k,i))/p0 - 0.252)*pii/2.
+! u_2d(i,k) = u0*(sin(2.*lat_2d(i))**2) *(cos(etavs_2d(i,k))**1.5)
+ u_2d(i,k) = u0*(sin(2.*lat_2d(i))**2) *(cos(etavs_2d(i,k))**1.5)*(rb(k,i)+rr(k,i))
+ end do
+
+ end do ! end loop over latitudes for 2D zonal wind field calc
+
+! do i=1,nlat
+! do k=1,nz1
+! u_2d(i,k) = u_2d(i,k) - u0*(sin(2.*lat_2d(i))**2) *(cos(etavs_2d(nlat/2,k))**1.5)
+! end do
+! end do
+!
+! write(22,*) nz1,nlat,u_2d
+
+!******************************************************************
+
+!
+!---- baroclinc wave initialization ---------------------------------
+!
+! reference sounding based on dry isothermal atmosphere
+!
+ do i=1, grid % nCells
+ !write(0,*) ' thermodynamic setup, cell ',i
+ do k=1,nz1
+ ztemp = .5*(zgrid(k+1,i)+zgrid(k,i))
+ ppb(k,i) = p0*exp(-gravity*ztemp/(rgas*t0b))
+ pb (k,i) = (ppb(k,i)/p0)**(rgas/cp)
+ rb (k,i) = ppb(k,i)/(rgas*t0b*zz(k,i))
+ tb (k,i) = t0b/pb(k,i)
+ rtb(k,i) = rb(k,i)*tb(k,i)
+ p (k,i) = pb(k,i)
+ pp (k,i) = 0.
+ rr (k,i) = 0.
+ end do
+
+ if(i == 1) then
+ do k=1,nz1
+ write(0,*) ' k, ppb, pb, rb, tb (k,1) ',k,ppb(k,1),pb(k,1),rb(k,1)*zz(k,1),tb(k,1)
+ enddo
+ end if
+!
+! iterations to converge temperature as a function of pressure
+!
+ do itr = 1,10
+
+ do k=1,nz1
+ eta (k) = (ppb(k,i)+pp(k,i))/p0
+ etav(k) = (eta(k)-.252)*pii/2.
+ if(eta(k).ge.znut) then
+ teta(k) = t0*eta(k)**(rgas*dtdz/gravity)
+ else
+ teta(k) = t0*eta(k)**(rgas*dtdz/gravity) + delta_t*(znut-eta(k))**5
+ end if
+ end do
+ phi = grid % latCell % array (i)
+ do k=1,nz1
+ tt(k) = 0.
+ tt(k) = teta(k)+.75*eta(k)*pii*u0/rgas*sin(etav(k)) &
+ *sqrt(cos(etav(k)))* &
+ ((-2.*sin(phi)**6 &
+ *(cos(phi)**2+1./3.)+10./63.) &
+ *2.*u0*cos(etav(k))**1.5 &
+ +(1.6*cos(phi)**3 &
+ *(sin(phi)**2+2./3.)-pii/4.)*r_earth*omega_e)
+
+
+ !write(0,*) ' k, tt(k) ',k,tt(k)
+ ztemp = .5*(zgrid(k,i)+zgrid(k+1,i))
+ ptemp = ppb(k,i) + pp(k,i)
+! qv(k,i) = env_qv( ztemp, tt(k), ptemp, 0 )
+ qv(k,i) = 0.
+
+ end do
+! do k=2,nz1
+! cqw(k,i) = 1./(1.+.5*(qv(k,i)+qv(k-1,i)))
+! end do
+
+ do itrp = 1,25
+ do k=1,nz1
+ rr(k,i) = (pp(k,i)/(rgas*zz(k,i)) &
+ -rb(k,i)*(tt(k)-t0b))/tt(k)
+ end do
+
+ ppi(1) = p0-.5*dzw(1)*gravity &
+ *(1.25*(rr(1,i)+rb(1,i))*(1.+qv(1,i)) &
+ -.25*(rr(2,i)+rb(2,i))*(1.+qv(2,i)))
+
+ ppi(1) = ppi(1)-ppb(1,i)
+ do k=1,nz1-1
+ ppi(k+1) = ppi(k)-.5*dzu(k+1)*gravity* &
+ (rr(k ,i)+(rr(k ,i)+rb(k ,i))*qv(k ,i) &
+ +rr(k+1,i)+(rr(k+1,i)+rb(k+1,i))*qv(k+1,i))
+ end do
+
+ do k=1,nz1
+ pp(k,i) = .2*ppi(k)+.8*pp(k,i)
+ end do
+
+ end do ! end inner iteration loop itrp
+
+ end do ! end outer iteration loop itr
+
+ do k=1,nz1
+ p (k,i) = ((ppb(k,i)+pp(k,i))/p0)**(rgas/cp)
+ t (k,i) = tt(k)/p(k,i)
+ rt (k,i) = t(k,i)*rr(k,i)+rb(k,i)*(t(k,i)-tb(k,i))
+ rho (k,i) = rb(k,i) + rr(k,i)
+ end do
+
+ if(i == 1) then
+ do k=1,nz1
+ write(0,*) ' k, p, t, rt ',k,p(k,1),t(k,1),rt(k,1)
+ enddo
+ end if
+
+ end do ! end loop over cells
+
+ lat_pert = latitude_pert*pii/180.
+ lon_pert = longitude_pert*pii/180.
+
+ do iEdge=1,grid % nEdges
+
+ vtx1 = grid % VerticesOnEdge % array (1,iEdge)
+ vtx2 = grid % VerticesOnEdge % array (2,iEdge)
+ lat1 = grid%latVertex%array(vtx1)
+ lat2 = grid%latVertex%array(vtx2)
+ iCell1 = grid % cellsOnEdge % array(1,iEdge)
+ iCell2 = grid % cellsOnEdge % array(2,iEdge)
+ flux = (0.5*(lat2-lat1) - 0.125*(sin(4.*lat2) - sin(4.*lat1)))*a/grid % dvEdge % array(iEdge)
+
+ if (config_test_case == 2) then
+ r_pert = sphere_distance( grid % latEdge % array (iEdge), grid % lonEdge % array (iEdge), &
+ lat_pert, lon_pert, 1.)/(pert_radius)
+ u_pert = u_perturbation*exp(-r_pert**2)*(lat2-lat1)*a/grid % dvEdge % array(iEdge)
+
+ else if (config_test_case == 3) then
+ lon_Edge = grid % lonEdge % array(iEdge)
+ u_pert = u_perturbation*cos(k_x*(lon_Edge - lon_pert)) &
+ *(0.5*(lat2-lat1) - 0.125*(sin(4.*lat2) - sin(4.*lat1)))*a/grid % dvEdge % array(iEdge)
+ else
+ u_pert = 0.0
+ end if
+
+ call calc_flux_zonal(u_2d,etavs_2d,lat_2d,flux_zonal,lat1,lat2,grid % dvEdge % array(iEdge),a,u0,nz1,nlat)
+
+ do k=1,grid % nVertLevels
+!! etavs = (0.5*(ppb(k,iCell1)+ppb(k,iCell2)+pp(k,iCell1)+pp(k,iCell2))/p0 - 0.252)*pii/2.
+! etavs = (0.5*(ppb(k,1)+ppb(k,1)+pp(k,1)+pp(k,1))/p0 - 0.252)*pii/2.
+ etavs = (0.5*(ppb(k,440)+ppb(k,440)+pp(k,440)+pp(k,440))/p0 - 0.252)*pii/2. ! 10262 mesh
+! etavs = (0.5*(ppb(k,505)+ppb(k,505)+pp(k,505)+pp(k,505))/p0 - 0.252)*pii/2. ! 40962 mesh
+
+! fluxk = u0*flux*(cos(etavs)**1.5)
+
+ fluxk = u0*flux_zonal(k)/(0.5*(rb(k,iCell1)+rb(k,iCell2)+rr(k,iCell1)+rr(k,iCell2)))
+
+! if(k.eq.18) then
+! write(21,*) ' iEdge, u1, u2 ',iEdge,fluxk,u0*flux_zonal(k)
+! end if
+!! fluxk = u0*flux*(cos(znuv(k))**(1.5))
+!! fluxk = u0 * cos(grid % angleEdge % array(iEdge)) * (sin(lat1+lat2)**2) *(cos(etavs)**1.5)
+ state % u % array(k,iEdge) = fluxk + u_pert
+ end do
+
+ cell1 = grid % CellsOnEdge % array(1,i)
+ cell2 = grid % CellsOnEdge % array(2,i)
+ if(cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
+ do k=1,nz1
+ diag % ru % array (k,iEdge) = 0.5*(rho(k,cell1)+rho(k,cell2))*state % u % array (k,iEdge)
+ end do
+ end if
+
+ !
+ ! Generate rotated Coriolis field
+ !
+
+ grid % fEdge % array(iEdge) = 2.0 * omega * &
+ ( -cos(grid%lonEdge%array(iEdge)) * cos(grid%latEdge%array(iEdge)) * sin(alpha_grid) + &
+ sin(grid%latEdge%array(iEdge)) * cos(alpha_grid) &
+ )
+ 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_grid) + &
+ sin(grid%latVertex%array(iVtx)) * cos(alpha_grid) &
+ )
+ end do
+
+ !
+ ! CALCULATION OF OMEGA, RW = ZX * RU + ZZ * RW
+ !
+
+ !
+ ! pre-calculation z-metric terms in omega eqn.
+ !
+ do iEdge = 1,grid % nEdges
+ cell1 = CellsOnEdge(1,iEdge)
+ cell2 = CellsOnEdge(2,iEdge)
+ if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve ) then
+
+ do k = 1, grid%nVertLevels
+
+ if (config_theta_adv_order == 2) then
+
+ z_edge = (zgrid(k,cell1)+zgrid(k,cell2))/2.
+
+ else if (config_theta_adv_order == 3 .or. config_theta_adv_order ==4) then !theta_adv_order == 3 or 4
+
+ d2fdx2_cell1 = deriv_two(1,1,iEdge) * zgrid(k,cell1)
+ d2fdx2_cell2 = deriv_two(1,2,iEdge) * zgrid(k,cell2)
+ do i=1, grid % nEdgesOnCell % array (cell1)
+ if ( grid % CellsOnCell % array (i,cell1) > 0) &
+ d2fdx2_cell1 = d2fdx2_cell1 + deriv_two(i+1,1,iEdge) * zgrid(k,grid % CellsOnCell % array (i,cell1))
+ end do
+ do i=1, grid % nEdgesOnCell % array (cell2)
+ if ( grid % CellsOnCell % array (i,cell2) > 0) &
+ d2fdx2_cell2 = d2fdx2_cell2 + deriv_two(i+1,2,iEdge) * zgrid(k,grid % CellsOnCell % array (i,cell2))
+ end do
+
+ z_edge = 0.5*(zgrid(k,cell1) + zgrid(k,cell2)) &
+ - (grid % dcEdge % array(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12.
+
+ if (config_theta_adv_order == 3) then
+ z_edge3 = - (grid % dcEdge % array(iEdge) **2) * (d2fdx2_cell1 - d2fdx2_cell2) / 12.
+ else
+ z_edge3 = 0.
+ end if
+
+ end if
+
+ zb(k,1,iEdge) = (z_edge-zgrid(k,cell1))*dvEdge(iEdge)/AreaCell(cell1)
+ zb(k,2,iEdge) = (z_edge-zgrid(k,cell2))*dvEdge(iEdge)/AreaCell(cell2)
+ zb3(k,1,iEdge)= z_edge3*dvEdge(iEdge)/AreaCell(cell1)
+ zb3(k,2,iEdge)= z_edge3*dvEdge(iEdge)/AreaCell(cell2)
+
+ if (k /= 1) then
+ zf(k,1,iEdge) = ( fzm(k)*zz(k,cell1)+fzp(k)*zz(k-1,cell1))*zb(k,1,iEdge)
+ zf(k,2,iEdge) = ( fzm(k)*zz(k,cell2)+fzp(k)*zz(k-1,cell2))*zb(k,2,iEdge)
+ zf3(k,1,iEdge)= ( fzm(k)*zz(k,cell1)+fzp(k)*zz(k-1,cell1))*zb3(k,1,iEdge)
+ zf3(k,2,iEdge)= ( fzm(k)*zz(k,cell2)+fzp(k)*zz(k-1,cell2))*zb3(k,2,iEdge)
+ end if
+
+ end do
+
+ end if
+ end do
+
+ ! for including terrain
+ diag % rw % array = 0.
+ state % w % array = 0.
+ do iEdge = 1,grid % nEdges
+
+ cell1 = CellsOnEdge(1,iEdge)
+ cell2 = CellsOnEdge(2,iEdge)
+
+ if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve ) then
+ do k = 2, grid%nVertLevels
+ flux = (fzm(k)*diag % ru % array(k,iEdge)+fzp(k)*diag % ru % array(k-1,iEdge))
+ diag % rw % array(k,cell2) = diag % rw % array(k,cell2) + zf(k,2,iEdge)*flux
+ diag % rw % array(k,cell1) = diag % rw % array(k,cell1) - zf(k,1,iEdge)*flux
+
+ if (config_theta_adv_order ==3) then
+ diag % rw % array(k,cell2) = diag % rw % array(k,cell2) &
+ - sign(1.,diag % ru % array(k,iEdge))*config_coef_3rd_order*zf3(k,2,iEdge)*flux
+ diag % rw % array(k,cell1) = diag % rw % array(k,cell1) &
+ + sign(1.,diag % ru % array(k,iEdge))*config_coef_3rd_order*zf3(k,1,iEdge)*flux
+ end if
+
+ end do
+ end if
+
+ end do
+
+ ! Compute w from rho and rw
+ do iCell=1,grid%nCells
+ do k=2,grid%nVertLevels
+ state % w % array(k,iCell) = diag % rw % array(k,iCell) &
+ / (fzp(k) * state % rho % array(k-1,iCell) + fzm(k) * state % rho % array(k,iCell))
+ end do
+ end do
+
+
+ !
+ ! Compute mass fluxes tangential to each edge (i.e., through the faces of dual grid cells)
+ !
+ diag % v % array(:,:) = 0.0
+ do iEdge = 1, grid%nEdges
+ do i=1,nEdgesOnEdge(iEdge)
+ eoe = edgesOnEdge(i,iEdge)
+ if (eoe > 0) then
+ do k = 1, grid%nVertLevels
+ diag % v % array(k,iEdge) = diag % v %array(k,iEdge) + weightsOnEdge(i,iEdge) * state % u % array(k, eoe)
+ end do
+ end if
+ end do
+ end do
+
+ do i=1,10
+ psurf = (cf1*(ppb(1,i)+pp(1,i)) + cf2*(ppb(2,i)+pp(2,i)) + cf3*(ppb(3,i)+pp(3,i)))/100.
+
+ psurf = (ppb(1,i)+pp(1,i)) + .5*dzw(1)*gravity &
+ *(1.25*(rr(1,i)+rb(1,i))*(1.+qv(1,i)) &
+ -.25*(rr(2,i)+rb(2,i))*(1.+qv(2,i)))
+
+ write(0,*) ' i, psurf, lat ',i,psurf,grid%latCell%array(i)*180./3.1415828
+ enddo
+
+ end subroutine nhyd_test_case_jw
+
+ subroutine calc_flux_zonal(u_2d,etavs_2d,lat_2d,flux_zonal,lat1_in,lat2_in,dvEdge,a,u0,nz1,nlat)
+
+ implicit none
+ integer, intent(in) :: nz1,nlat
+ real (kind=RKIND), dimension(nlat,nz1), intent(in) :: u_2d,etavs_2d
+ real (kind=RKIND), dimension(nlat), intent(in) :: lat_2d
+ real (kind=RKIND), dimension(nz1), intent(out) :: flux_zonal
+ real (kind=RKIND), intent(in) :: lat1_in, lat2_in, dvEdge, a, u0
+
+ integer :: k,i
+ real (kind=RKIND) :: lat1, lat2, w1, w2
+ real (kind=RKIND) :: dlat,da,db
+
+ lat1 = abs(lat1_in)
+ lat2 = abs(lat2_in)
+ if(lat2 <= lat1) then
+ lat1 = abs(lat2_in)
+ lat2 = abs(lat1_in)
+ end if
+
+ do k=1,nz1
+ flux_zonal(k) = 0.
+ end do
+
+ do i=1,nlat-1
+ if( (lat1 <= lat_2d(i+1)) .and. (lat2 >= lat_2d(i)) ) then
+
+ dlat = lat_2d(i+1)-lat_2d(i)
+ da = (max(lat1,lat_2d(i))-lat_2d(i))/dlat
+ db = (min(lat2,lat_2d(i+1))-lat_2d(i))/dlat
+ w1 = (db-da) -0.5*(db-da)**2
+ w2 = 0.5*(db-da)**2
+
+ do k=1,nz1
+ flux_zonal(k) = flux_zonal(k) + w1*u_2d(i,k) + w2*u_2d(i+1,k)
+ end do
+
+ end if
+
+ end do
+
+! renormalize for setting cell-face fluxes
+
+ do k=1,nz1
+ flux_zonal(k) = sign(1.,lat2_in-lat1_in)*flux_zonal(k)*dlat*a/dvEdge/u0
+ end do
+
+ end subroutine calc_flux_zonal
+
+
+!----------------------------------------------------------------------------------------------------------
+
+ subroutine nhyd_test_case_squall_line(dminfo, grid, state, diag, test_case)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Setup squall line and supercell test case
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ type (mesh_type), intent(inout) :: grid
+ type (state_type), intent(inout) :: state
+ type (diag_type), intent(inout) :: diag
+ integer, intent(in) :: test_case
+
+ real (kind=RKIND), dimension(:), pointer :: rdzw, dzu, rdzu, fzm, fzp
+ real (kind=RKIND), dimension(:,:), pointer :: zgrid, zx, zz, hx, cqw
+ real (kind=RKIND), dimension(:,:), pointer :: ppb, pb, rho, rb, rr, tb, rtb, p, pp, dss, t, rt, u, ru
+ real (kind=RKIND), dimension(:,:,:), pointer :: scalars
+
+ !This is temporary variable here. It just need when calculate tangential velocity v.
+ integer :: eoe, j
+ integer, dimension(:), pointer :: nEdgesOnEdge
+ integer, dimension(:,:), pointer :: edgesOnEdge
+ real, dimension(:,:), pointer :: weightsOnEdge
+
+ integer :: iCell, iCell1, iCell2 , iEdge, vtx1, vtx2, ivtx, i, k, nz, nz1, itr, cell1, cell2, nCellsSolve
+ integer :: index_qv
+
+ real (kind=RKIND), dimension(grid % nVertLevels + 1 ) :: znu, znw, znwc, znwv
+ real (kind=RKIND), dimension(grid % nVertLevels + 1 ) :: znuc, znuv
+
+ real (kind=RKIND), dimension(grid % nVertLevels + 1 ) :: zc, zw, ah
+ real (kind=RKIND), dimension(grid % nVertLevels ) :: zu, dzw, rdzwp, rdzwm
+
+ real (kind=RKIND), dimension(grid % nVertLevels, grid % nCells) :: rh, thi, tbi, cqwb
+
+ real (kind=RKIND) :: r, xnutr
+ real (kind=RKIND) :: ztemp, zd, zt, dz, str
+
+ real (kind=RKIND), dimension(grid % nVertLevels ) :: qvb
+ real (kind=RKIND), dimension(grid % nVertLevels ) :: t_init_1d
+
+ real (kind=RKIND) :: d1, d2, d3, cf1, cf2, cf3, cof1, cof2
+ real (kind=RKIND) :: ztr, thetar, ttr, thetas, um, us, zts, pitop, pibtop, ptopb, ptop, rcp, rcv, p0
+ real (kind=RKIND) :: radx, radz, zcent, xmid, delt, xloc, rad, yloc, ymid, a_scale
+ real (kind=RKIND) :: pres, temp, es, qvs
+
+ !
+ ! Scale all distances
+ !
+
+ a_scale = 1.0
+
+ grid % xCell % array = grid % xCell % array * a_scale
+ grid % yCell % array = grid % yCell % array * a_scale
+ grid % zCell % array = grid % zCell % array * a_scale
+ grid % xVertex % array = grid % xVertex % array * a_scale
+ grid % yVertex % array = grid % yVertex % array * a_scale
+ grid % zVertex % array = grid % zVertex % array * a_scale
+ grid % xEdge % array = grid % xEdge % array * a_scale
+ grid % yEdge % array = grid % yEdge % array * a_scale
+ grid % zEdge % array = grid % zEdge % array * a_scale
+ grid % dvEdge % array = grid % dvEdge % array * a_scale
+ grid % dcEdge % array = grid % dcEdge % array * a_scale
+ grid % areaCell % array = grid % areaCell % array * a_scale**2.0
+ grid % areaTriangle % array = grid % areaTriangle % array * a_scale**2.0
+ grid % kiteAreasOnVertex % array = grid % kiteAreasOnVertex % array * a_scale**2.0
+
+ weightsOnEdge => grid % weightsOnEdge % array
+ nEdgesOnEdge => grid % nEdgesOnEdge % array
+ edgesOnEdge => grid % edgesOnEdge % array
+
+ nz1 = grid % nVertLevels
+ nz = nz1 + 1
+ nCellsSolve = grid % nCellsSolve
+
+ zgrid => grid % zgrid % array
+ rdzw => grid % rdzw % array
+ dzu => grid % dzu % array
+ rdzu => grid % rdzu % array
+ fzm => grid % fzm % array
+ fzp => grid % fzp % array
+ zx => grid % zx % array
+ zz => grid % zz % array
+ hx => grid % hx % array
+ dss => grid % dss % array
+
+ ppb => diag % pressure_base % array
+ pb => diag % exner_base % array
+ rb => diag % rho_base % array
+ tb => diag % theta_base % array
+ rtb => diag % rtheta_base % array
+ p => diag % exner % array
+ cqw => diag % cqw % array
+
+ rho => state % rho % array
+
+ pp => diag % pressure_p % array
+ rr => diag % rho_p % array
+ t => state % theta % array
+ rt => diag % rtheta_p % array
+ u => state % u % array
+ ru => diag % ru % array
+
+ scalars => state % scalars % array
+
+ index_qv = state % index_qv
+
+ scalars(:,:,:) = 0.
+
+ call initialize_advection_rk(grid)
+ call initialize_deformation_weights(grid)
+
+ xnutr = 0.
+ zd = 12000.
+
+ p0 = 1.e+05
+ rcp = rgas/cp
+ rcv = rgas/(cp-rgas)
+
+ write(0,*) ' point 1 in test case setup '
+
+! We may pass in an hx(:,:) that has been precomputed elsewhere.
+! For now it is independent of k
+
+ do iCell=1,grid % nCells
+ do k=1,nz
+ hx(k,iCell) = 0. ! squall line or supercell on flat plane
+ enddo
+ enddo
+
+ ! metrics for hybrid coordinate and vertical stretching
+
+ str = 1.0
+ zt = 20000.
+ dz = zt/float(nz1)
+
+! write(0,*) ' dz = ',dz
+ write(0,*) ' hx computation complete '
+
+ do k=1,nz
+
+! sh(k) is the stretching specified for height surfaces
+
+ zc(k) = zt*(real(k-1)*dz/zt)**str
+
+! to specify specific heights zc(k) for coordinate surfaces,
+! input zc(k)
+! zw(k) is the hieght of zeta surfaces
+! zw(k) = (k-1)*dz yields constant dzeta
+! and nonconstant dzeta/dz
+! zw(k) = sh(k)*zt yields nonconstant dzeta
+! and nearly constant dzeta/dz
+
+! zw(k) = float(k-1)*dz
+ zw(k) = zc(k)
+!
+! ah(k) governs the transition between terrain-following
+! and pureheight coordinates
+! ah(k) = 0 is a terrain-following coordinate
+! ah(k) = 1 is a height coordinate
+
+! ah(k) = 1.-cos(.5*pii*(k-1)*dz/zt)**6
+ ah(k) = 1.
+! write(0,*) ' k, zc, zw, ah ',k,zc(k),zw(k),ah(k)
+ end do
+ do k=1,nz1
+ dzw (k) = zw(k+1)-zw(k)
+ rdzw(k) = 1./dzw(k)
+ zu(k ) = .5*(zw(k)+zw(k+1))
+ end do
+ do k=2,nz1
+ dzu (k) = .5*(dzw(k)+dzw(k-1))
+ rdzu(k) = 1./dzu(k)
+ fzp (k) = .5* dzw(k )/dzu(k)
+ fzm (k) = .5* dzw(k-1)/dzu(k)
+ rdzwp(k) = dzw(k-1)/(dzw(k )*(dzw(k)+dzw(k-1)))
+ rdzwm(k) = dzw(k )/(dzw(k-1)*(dzw(k)+dzw(k-1)))
+ end do
+
+!********** how are we storing cf1, cf2 and cf3?
+
+ COF1 = (2.*DZU(2)+DZU(3))/(DZU(2)+DZU(3))*DZW(1)/DZU(2)
+ COF2 = DZU(2) /(DZU(2)+DZU(3))*DZW(1)/DZU(3)
+ CF1 = FZP(2) + COF1
+ CF2 = FZM(2) - COF1 - COF2
+ CF3 = COF2
+
+! d1 = .5*dzw(1)
+! d2 = dzw(1)+.5*dzw(2)
+! d3 = dzw(1)+dzw(2)+.5*dzw(3)
+! cf1 = d2*d3*(d3-d2)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
+! cf2 = d1*d3*(d1-d3)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
+! cf3 = d1*d2*(d2-d1)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
+
+ grid % cf1 % scalar = cf1
+ grid % cf2 % scalar = cf2
+ grid % cf3 % scalar = cf3
+
+ do iCell=1,grid % nCells
+ do k=1,nz
+ zgrid(k,iCell) = ah(k)*(zc(k)*(1.-hx(k,iCell)/zt)+hx(k,iCell)) &
+ + (1.-ah(k)) * zc(k)
+ end do
+ do k=1,nz1
+ zz (k,iCell) = (zw(k+1)-zw(k))/(zgrid(k+1,iCell)-zgrid(k,iCell))
+ end do
+ end do
+
+ do i=1, grid % nEdges
+ iCell1 = grid % CellsOnEdge % array(1,i)
+ iCell2 = grid % CellsOnEdge % array(2,i)
+ do k=1,nz
+ zx (k,i) = (zgrid(k,iCell2)-zgrid(k,iCell1)) / grid % dcEdge % array(i)
+ end do
+ end do
+ do i=1, grid % nCells
+ do k=1,nz1
+ ztemp = .5*(zgrid(k+1,i)+zgrid(k,i))
+ dss(k,i) = 0.
+ ztemp = zgrid(k,i)
+ if(ztemp.gt.zd+.1) then
+ dss(k,i) = dss(k,i)+xnutr*sin(.5*pii*(ztemp-zd)/(zt-zd))**2
+ end if
+ end do
+ enddo
+
+!
+! convective initialization
+!
+ ztr = 12000.
+ thetar = 343.
+ ttr = 213.
+ thetas = 300.5
+
+! write(0,*) ' rgas, cp, gravity ',rgas,cp, gravity
+
+ if ( config_test_case == 4) then ! squall line parameters
+ um = 12.
+ us = 10.
+ zts = 2500.
+ else if (config_test_case == 5) then !supercell parameters
+ um = 30.
+ us = 15.
+ zts = 5000.
+ end if
+
+ do i=1,grid % nCells
+ do k=1,nz1
+ ztemp = .5*(zgrid(k,i)+zgrid(k+1,i))
+ if(ztemp .gt. ztr) then
+ t (k,i) = thetar*exp(9.8*(ztemp-ztr)/(1003.*ttr))
+ rh(k,i) = 0.25
+ else
+ t (k,i) = 300.+43.*(ztemp/ztr)**1.25
+ rh(k,i) = (1.-0.75*(ztemp/ztr)**1.25)
+ if(t(k,i).lt.thetas) t(k,i) = thetas
+ end if
+ tb(k,i) = t(k,i)
+ thi(k,i) = t(k,i)
+ tbi(k,i) = t(k,i)
+ cqw(k,i) = 1.
+ cqwb(k,i) = 1.
+ end do
+ end do
+
+! rh(:,:) = 0.
+
+! set the velocity field - we are on a plane here.
+
+ do i=1, grid % nEdges
+ cell1 = grid % CellsOnEdge % array(1,i)
+ cell2 = grid % CellsOnEdge % array(2,i)
+ if(cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
+ do k=1,nz1
+ ztemp = .25*( zgrid(k,cell1 )+zgrid(k+1,cell1 ) &
+ +zgrid(k,cell2)+zgrid(k+1,cell2))
+ if(ztemp.lt.zts) then
+ u(k,i) = um*ztemp/zts
+ else
+ u(k,i) = um
+ end if
+ if(i == 1 ) grid % u_init % array(k) = u(k,i) - us
+ u(k,i) = cos(grid % angleEdge % array(i)) * (u(k,i) - us)
+ end do
+ end if
+ end do
+
+ call dmpar_bcast_reals(dminfo, nz1, grid % u_init % array)
+
+!
+! for reference sounding
+!
+ do itr=1,30
+
+ pitop = 1.-.5*dzw(1)*gravity*(1.+scalars(index_qv,1,1))/(cp*t(1,1)*zz(1,1))
+ pibtop = 1.-.5*dzw(1)*gravity*(1.+qvb(1))/(cp*tb(1,1)*zz(1,1))
+ do k=2,nz1
+ pitop = pitop-dzu(k)*gravity/(cp*cqw(k,1)*.5*(t(k,1)+t(k-1,1)) &
+ *.5*(zz(k,1)+zz(k-1,1)))
+ pibtop = pibtop-dzu(k)*gravity/(cp*cqwb(k,1)*.5*(tb(k,1)+tb(k-1,1)) &
+ *.5*(zz(k,1)+zz(k-1,1)))
+
+ !write(0,*) k,pitop,tb(k,1),dzu(k),tb(k,1)
+ end do
+ pitop = pitop-.5*dzw(nz1)*gravity*(1.+scalars(index_qv,nz1,1))/(cp*t(nz1,1)*zz(nz1,1))
+ pibtop = pibtop-.5*dzw(nz1)*gravity*(1.+qvb(nz1))/(cp*tb(nz1,1)*zz(nz1,1))
+
+ call dmpar_bcast_real(dminfo, pitop)
+ call dmpar_bcast_real(dminfo, pibtop)
+
+ ptopb = p0*pibtop**(1./rcp)
+ write(6,*) 'ptopb = ',.01*ptopb
+
+ do i=1, grid % nCells
+ pb(nz1,i) = pibtop+.5*dzw(nz1)*gravity*(1.+qvb(nz1))/(cp*tb(nz1,i)*zz(nz1,i))
+ p (nz1,i) = pitop+.5*dzw(nz1)*gravity*(1.+scalars(index_qv,nz1,i))/(cp*t (nz1,i)*zz(nz1,i))
+ do k=nz1-1,1,-1
+ pb(k,i) = pb(k+1,i) + dzu(k+1)*gravity/(cp*cqwb(k+1,i)*.5*(tb(k,i)+tb(k+1,i)) &
+ *.5*(zz(k,i)+zz(k+1,i)))
+ p (k,i) = p (k+1,i) + dzu(k+1)*gravity/(cp*cqw(k+1,i)*.5*(t (k,i)+t (k+1,i)) &
+ *.5*(zz(k,i)+zz(k+1,i)))
+ end do
+ do k=1,nz1
+ rb (k,i) = pb(k,i)**(1./rcv)/((rgas/p0)*tb(k,i)*zz(k,i))
+ rtb(k,i) = rb(k,i)*tb(k,i)
+ rr (k,i) = p (k,i)**(1./rcv)/((rgas/p0)*t (k,i)*zz(k,i))-rb(k,i)
+ end do
+ end do
+
+ !
+ ! update water vapor mixing ratio from humidity profile
+ !
+ do i= 1,grid%nCells
+ do k=1,nz1
+ temp = p(k,i)*thi(k,i)
+ pres = p0*p(k,i)**(1./rcp)
+ qvs = 380.*exp(17.27*(temp-273.)/(temp-36.))/pres
+ scalars(index_qv,k,i) = amin1(0.014,rh(k,i)*qvs)
+ end do
+ end do
+
+ do k=1,nz1
+!*********************************************************************
+! QVB = QV INCLUDES MOISTURE IN REFERENCE STATE
+! qvb(k) = scalars(index_qv,k,1)
+
+! QVB = 0 PRODUCES DRY REFERENCE STATE
+ qvb(k) = 0.
+!*********************************************************************
+ end do
+
+ do i= 1,grid%nCells
+ do k=1,nz1
+ t (k,i) = thi(k,i)*(1.+1.61*scalars(index_qv,k,i))
+ tb(k,i) = tbi(k,i)*(1.+1.61*qvb(k))
+ end do
+ do k=2,nz1
+ cqw (k,i) = 1./(1.+.5*(scalars(index_qv,k,i)+scalars(index_qv,k-1,i)))
+ cqwb(k,i) = 1./(1.+.5*(qvb(k)+qvb(k-1)))
+ end do
+ end do
+
+ end do !end of iteration loop
+
+ write(0,*) ' base state sounding '
+ write(0,*) ' k, pb, rb, tb, rtb, t, rr, p, qvb'
+ do k=1,grid%nVertLevels
+ write (0,'(i2,8(2x,f19.15))') k,pb(k,1),rb(k,1),tb(k,1),rtb(k,1),t(k,1),rr(k,1),p(k,1),qvb(k)
+ end do
+
+!
+! potential temperature perturbation
+!
+! delt = -10.
+! delt = -0.01
+ delt = 3.
+ radx = 10000.
+ radz = 1500.
+ zcent = 1500.
+
+ if (config_test_case == 4) then ! squall line prameters
+ call dmpar_max_real(dminfo, maxval(grid % xCell % array(:)), xmid)
+ xmid = xmid * 0.5
+ ymid = 0.0 ! Not used for squall line
+ else if (config_test_case == 5) then ! supercell parameters
+ call dmpar_max_real(dminfo, maxval(grid % xCell % array(:)), xmid)
+ call dmpar_max_real(dminfo, maxval(grid % yCell % array(:)), ymid)
+ xmid = xmid * 0.5
+ ymid = ymid * 0.5
+ end if
+
+ do i=1, grid % nCells
+ xloc = grid % xCell % array(i) - xmid
+ if (config_test_case == 4) then
+ yloc = 0. !squall line setting
+ else if (config_test_case == 5) then
+ yloc = grid % yCell % array(i) - ymid !supercell setting
+ end if
+
+ do k = 1,nz1
+ ztemp = .5*(zgrid(k+1,i)+zgrid(k,i))
+ rad =sqrt((xloc/radx)**2+(yloc/radx)**2+((ztemp-zcent)/radz)**2)
+ if(rad.lt.1) then
+ thi(k,i) = thi(k,i) + delt*cos(.5*pii*rad)**2
+ end if
+ t (k,i) = thi(k,i)*(1.+1.61*scalars(index_qv,k,i))
+ end do
+ end do
+
+ do itr=1,30
+
+ pitop = 1.-.5*dzw(1)*gravity*(1.+scalars(index_qv,1,1))/(cp*t(1,1)*zz(1,1))
+ do k=2,nz1
+ pitop = pitop-dzu(k)*gravity/(cp*cqw(k,1)*.5*(t (k,1)+t (k-1,1)) &
+ *.5*(zz(k,1)+zz(k-1,1)))
+ end do
+ pitop = pitop - .5*dzw(nz1)*gravity*(1.+scalars(index_qv,nz1,1))/(cp*t(nz1,1)*zz(nz1,1))
+ ptop = p0*pitop**(1./rcp)
+ write(0,*) 'ptop = ',.01*ptop, .01*ptopb
+
+ call dmpar_bcast_real(dminfo, pitop)
+
+ do i = 1, grid % nCells
+
+ pp(nz1,i) = ptop-ptopb+.5*dzw(nz1)*gravity* &
+ (rr(nz1,i)+(rr(nz1,i)+rb(nz1,i))*scalars(index_qv,nz1,i))
+ do k=nz1-1,1,-1
+! pp(k,i) = pp(k+1,i)+.5*dzu(k+1)*gravity* &
+! (rr(k ,i)+(rr(k ,i)+rb(k ,i))*scalars(index_qv,k ,i) &
+! +rr(k+1,i)+(rr(k+1,i)+rb(k+1,i))*scalars(index_qv,k+1,i))
+ pp(k,i) = pp(k+1,i)+dzu(k+1)*gravity*( &
+ fzm(k+1)*(rb(k+1,i)*(scalars(index_qv,k+1,i)-qvb(k+1)) &
+ +rr(k+1,i)*(1.+scalars(index_qv,k+1,i))) &
+ +fzp(k+1)*(rb(k ,i)*(scalars(index_qv,k ,i)-qvb(k)) &
+ +rr(k ,i)*(1.+scalars(index_qv,k ,i))))
+ end do
+ if (itr==1.and.i==1) then
+ do k=1,nz1
+ print *, "pp-check", pp(k,i)
+ end do
+ end if
+ do k=1,nz1
+ rt(k,i) = (pp(k,i)/(rgas*zz(k,i)) &
+ -rtb(k,i)*(p(k,i)-pb(k,i)))/p(k,i)
+ p (k,i) = (zz(k,i)*(rgas/p0)*(rtb(k,i)+rt(k,i)))**rcv
+ rr(k,i) = (rt(k,i)-rb(k,i)*(t(k,i)-tb(k,i)))/t(k,i)
+ end do
+
+ end do ! loop over cells
+
+ end do ! iteration loop
+!----------------------------------------------------------------------
+!
+ do k=1,nz1
+ grid % qv_init % array(k) = scalars(index_qv,k,1)
+ end do
+
+ t_init_1d(:) = t(:,1)
+ call dmpar_bcast_reals(dminfo, nz1, t_init_1d)
+ call dmpar_bcast_reals(dminfo, nz1, grid % qv_init % array)
+
+ do i=1,grid % ncells
+ do k=1,nz1
+ grid % t_init % array(k,i) = t_init_1d(k)
+ rho(k,i) = rb(k,i)+rr(k,i)
+ end do
+ end do
+
+ do i=1,grid % nEdges
+ cell1 = grid % CellsOnEdge % array(1,i)
+ cell2 = grid % CellsOnEdge % array(2,i)
+ if(cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
+ do k=1,nz1
+ ru (k,i) = 0.5*(rho(k,cell1)+rho(k,cell2))*u(k,i)
+ end do
+ end if
+ end do
+
+
+ !
+ ! we are assuming w and rw are zero for this initialization
+ ! i.e., no terrain
+ !
+ diag % rw % array = 0.
+ state % w % array = 0.
+
+ grid % zf % array = 0.
+ grid % zf3% array = 0.
+ grid % zb % array = 0.
+ grid % zb3% array = 0.
+
+ !
+ ! Generate rotated Coriolis field
+ !
+ do iEdge=1,grid % nEdges
+ grid % fEdge % array(iEdge) = 0.
+ end do
+
+ do iVtx=1,grid % nVertices
+ grid % fVertex % array(iVtx) = 0.
+ end do
+
+ !
+ ! Compute mass fluxes tangential to each edge (i.e., through the faces of dual grid cells)
+ !
+ diag % v % array(:,:) = 0.0
+ do iEdge = 1, grid%nEdges
+ do i=1,nEdgesOnEdge(iEdge)
+ eoe = edgesOnEdge(i,iEdge)
+ if (eoe > 0) then
+ do k = 1, grid%nVertLevels
+ diag % v % array(k,iEdge) = diag % v %array(k,iEdge) + weightsOnEdge(i,iEdge) * state % u % array(k, eoe)
+ end do
+ end if
+ end do
+ end do
+
+ ! write(0,*) ' k,u_init, t_init, qv_init '
+ ! do k=1,grid%nVertLevels
+ ! write(0,'(i2,3(2x,f14.10)') k,grid % u_init % array(k),grid % t_init% array(k),grid % qv_init % array(k)
+ ! end do
+
+ end subroutine nhyd_test_case_squall_line
+
+
+!----------------------------------------------------------------------------------------------------------
+
+
+ subroutine nhyd_test_case_mtn_wave(grid, state, diag, test_case)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Setup baroclinic wave test case from Jablonowski and Williamson 2008 (QJRMS)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (mesh_type), intent(inout) :: grid
+ type (state_type), intent(inout) :: state
+ type (diag_type), intent(inout) :: diag
+ integer, intent(in) :: test_case
+
+ real (kind=RKIND), parameter :: t0=288., hm=250.
+
+ real (kind=RKIND), dimension(:), pointer :: rdzw, dzu, rdzu, fzm, fzp
+ real (kind=RKIND), dimension(:,:), pointer :: zgrid, zx, zz, hx, cqw
+ real (kind=RKIND), dimension(:,:), pointer :: ppb, pb, rho, rb, rr, tb, rtb, p, pp, dss, t, rt, u, ru
+ real (kind=RKIND), dimension(:,:,:), pointer :: scalars, deriv_two, zf, zf3, zb, zb3
+
+ !This is temporary variable here. It just need when calculate tangential velocity v.
+ integer :: eoe, j
+ integer, dimension(:), pointer :: nEdgesOnEdge
+ integer, dimension(:,:), pointer :: edgesOnEdge, CellsOnEdge
+ real, dimension(:), pointer :: dvEdge, AreaCell, xCell, yCell
+ real, dimension(:,:), pointer :: weightsOnEdge
+
+ integer :: iCell, iCell1, iCell2 , iEdge, vtx1, vtx2, ivtx, i, k, nz, nz1, itr, itrp, cell1, cell2, nCellsSolve
+ integer :: index_qv
+
+ real (kind=RKIND) :: ptop, pitop, ptopb, p0, flux, d2fdx2_cell1, d2fdx2_cell2
+
+ real (kind=RKIND) :: ztemp, zd, zt, dz, str
+
+ real (kind=RKIND), dimension(grid % nVertLevels, grid % nCells) :: rh
+ real (kind=RKIND) :: ptmp, es, qvs, xnutr, ptemp
+ integer :: iter
+
+ real (kind=RKIND), dimension(grid % nVertLevels + 1 ) :: zc, zw, ah
+ real (kind=RKIND), dimension(grid % nVertLevels ) :: zu, dzw, rdzwp, rdzwm
+
+ real (kind=RKIND) :: d1, d2, d3, cof1, cof2, cf1, cf2, cf3
+ real (kind=RKIND) :: um, us, rcp, rcv
+ real (kind=RKIND) :: xmid, temp, pres, a_scale
+
+ real (kind=RKIND) :: xi, xa, xc, xla, zinv, xn2, xn2m, xn2l, sm, dzh, dzht, dzmin, z_edge, z_edge3
+
+ integer, dimension(grid % nCells, 2) :: next_cell
+ real (kind=RKIND), dimension(grid % nCells) :: hxzt
+ logical, parameter :: terrain_smooth = .false.
+
+ !
+ ! Scale all distances
+ !
+
+ a_scale = 1.0
+
+ grid % xCell % array = grid % xCell % array * a_scale
+ grid % yCell % array = grid % yCell % array * a_scale
+ grid % zCell % array = grid % zCell % array * a_scale
+ grid % xVertex % array = grid % xVertex % array * a_scale
+ grid % yVertex % array = grid % yVertex % array * a_scale
+ grid % zVertex % array = grid % zVertex % array * a_scale
+ grid % xEdge % array = grid % xEdge % array * a_scale
+ grid % yEdge % array = grid % yEdge % array * a_scale
+ grid % zEdge % array = grid % zEdge % array * a_scale
+ grid % dvEdge % array = grid % dvEdge % array * a_scale
+ grid % dcEdge % array = grid % dcEdge % array * a_scale
+ grid % areaCell % array = grid % areaCell % array * a_scale**2.0
+ grid % areaTriangle % array = grid % areaTriangle % array * a_scale**2.0
+ grid % kiteAreasOnVertex % array = grid % kiteAreasOnVertex % array * a_scale**2.0
+
+ weightsOnEdge => grid % weightsOnEdge % array
+ nEdgesOnEdge => grid % nEdgesOnEdge % array
+ edgesOnEdge => grid % edgesOnEdge % array
+ dvEdge => grid % dvEdge % array
+ AreaCell => grid % AreaCell % array
+ CellsOnEdge => grid % CellsOnEdge % array
+ deriv_two => grid % deriv_two % array
+
+ nz1 = grid % nVertLevels
+ nz = nz1 + 1
+ nCellsSolve = grid % nCellsSolve
+
+ zgrid => grid % zgrid % array
+ zf => grid % zf % array
+ zf3 => grid % zf3 % array
+ zb => grid % zb % array
+ zb3 => grid % zb3 % array
+ rdzw => grid % rdzw % array
+ dzu => grid % dzu % array
+ rdzu => grid % rdzu % array
+ fzm => grid % fzm % array
+ fzp => grid % fzp % array
+ zx => grid % zx % array
+ zz => grid % zz % array
+ hx => grid % hx % array
+ dss => grid % dss % array
+
+ xCell => grid % xCell % array
+ yCell => grid % yCell % array
+
+ ppb => diag % pressure_base % array
+ pb => diag % exner_base % array
+ rb => diag % rho_base % array
+ tb => diag % theta_base % array
+ rtb => diag % rtheta_base % array
+ p => diag % exner % array
+ cqw => diag % cqw % array
+
+ rho => state % rho % array
+
+ pp => diag % pressure_p % array
+ rr => diag % rho_p % array
+ t => state % theta % array
+ rt => diag % rtheta_p % array
+ u => state % u % array
+ ru => diag % ru % array
+
+ scalars => state % scalars % array
+
+ index_qv = state % index_qv
+
+ scalars(:,:,:) = 0.
+
+ call initialize_advection_rk(grid)
+ call initialize_deformation_weights(grid)
+
+ xnutr = 0.1
+ zd = 10500.
+
+ p0 = 1.e+05
+ rcp = rgas/cp
+ rcv = rgas/(cp-rgas)
+
+ ! for hx computation
+ xa = 5000. !SHP - should be changed based on grid distance
+ xla = 4000.
+ xc = maxval (grid % xCell % array(:))/2.
+
+ ! metrics for hybrid coordinate and vertical stretching
+ str = 1.0
+ zt = 21000.
+ dz = zt/float(nz1)
+! write(0,*) ' dz = ',dz
+
+ do k=1,nz
+
+! sh(k) is the stretching specified for height surfaces
+
+ zc(k) = zt*(real(k-1)*dz/zt)**str
+
+! to specify specific heights zc(k) for coordinate surfaces,
+! input zc(k)
+! zw(k) is the hieght of zeta surfaces
+! zw(k) = (k-1)*dz yields constant dzeta
+! and nonconstant dzeta/dz
+! zw(k) = sh(k)*zt yields nonconstant dzeta
+! and nearly constant dzeta/dz
+
+! zw(k) = float(k-1)*dz
+ zw(k) = zc(k)
+!
+! ah(k) governs the transition between terrain-following
+! and pureheight coordinates
+! ah(k) = 0 is a terrain-following coordinate
+! ah(k) = 1 is a height coordinate
+
+! ah(k) = 1.-cos(.5*pii*(k-1)*dz/zt)**6
+ ah(k) = 1.
+! write(0,*) ' k, zc, zw, ah ',k,zc(k),zw(k),ah(k)
+ end do
+ do k=1,nz1
+ dzw (k) = zw(k+1)-zw(k)
+ rdzw(k) = 1./dzw(k)
+ zu(k ) = .5*(zw(k)+zw(k+1))
+ end do
+ do k=2,nz1
+ dzu (k) = .5*(dzw(k)+dzw(k-1))
+ rdzu(k) = 1./dzu(k)
+ fzp (k) = .5* dzw(k )/dzu(k)
+ fzm (k) = .5* dzw(k-1)/dzu(k)
+ rdzwp(k) = dzw(k-1)/(dzw(k )*(dzw(k)+dzw(k-1)))
+ rdzwm(k) = dzw(k )/(dzw(k-1)*(dzw(k)+dzw(k-1)))
+ end do
+
+!********** how are we storing cf1, cf2 and cf3?
+
+ d1 = .5*dzw(1)
+ d2 = dzw(1)+.5*dzw(2)
+ d3 = dzw(1)+dzw(2)+.5*dzw(3)
+ !cf1 = d2*d3*(d3-d2)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
+ !cf2 = d1*d3*(d1-d3)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
+ !cf3 = d1*d2*(d2-d1)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
+
+ cof1 = (2.*dzu(2)+dzu(3))/(dzu(2)+dzu(3))*dzw(1)/dzu(2)
+ cof2 = dzu(2) /(dzu(2)+dzu(3))*dzw(1)/dzu(3)
+ cf1 = fzp(2) + cof1
+ cf2 = fzm(2) - cof1 - cof2
+ cf3 = cof2
+
+ grid % cf1 % scalar = cf1
+ grid % cf2 % scalar = cf2
+ grid % cf3 % scalar = cf3
+
+! setting for terrain
+ do iCell=1,grid % nCells
+ xi = grid % xCell % array(iCell)
+ !====1. for pure cosine mountain
+ ! if(abs(xi-xc).ge.2.*xa) then
+ ! hx(1,iCell) = 0.
+ ! else
+ ! hx(1,iCell) = hm*cos(.5*pii*(xi-xc)/(2.*xa))**2.
+ ! end if
+
+ !====2. for cosine mountain
+ !if(abs(xi-xc).lt.xa) THEN
+ ! hx(1,iCell) = hm*cos(pii*(xi-xc)/xla)**2. *cos(.5*pii*(xi-xc)/xa )**2.
+ ! else
+ ! hx(1,iCell) = 0.
+ ! end if
+
+ !====3. for shock mountain
+ hx(1,iCell) = hm*exp(-((xi-xc)/xa)**2)*cos(pii*(xi-xc)/xla)**2.
+
+ hx(nz,iCell) = zt
+
+!***** SHP -> get the temporary point information for the neighbor cell ->> should be changed!!!!!
+ do i=1,grid % nCells
+ !option 1
+ !IF(yCell(i).eq.yCell(iCell).and.xCell(i).eq.xCell(iCell)-sqrt(3.)*grid % dcEdge % array(1)) next_cell(iCell,1) = i
+ !IF(yCell(i).eq.yCell(iCell).and.xCell(i).eq.xCell(iCell)+sqrt(3.)*grid % dcEdge % array(1)) next_cell(iCell,2) = i
+ !option 2
+ next_cell(iCell,1) = iCell - 8 ! note ny=4
+ next_cell(iCell,2) = iCell + 8 ! note ny=4
+
+ if (xCell(iCell).le. 3.*grid % dcEdge % array(1)) then
+ next_cell(iCell,1) = 1
+ else if (xCell(iCell).ge. maxval(xCell(:))-3.*grid % dcEdge % array(1)) then
+ next_cell(iCell,2) = 1
+ end if
+
+ end do
+ enddo
+
+ write(0,*) ' hx computation complete '
+
+
+! smoothing grid for the upper level >> but not propoer for parallel programing
+ dzmin=.7
+ do k=2,nz1
+ sm = .25*min((zc(k)-zc(k-1))/dz,1.)
+ do i=1,grid % nCells
+ hx(k,i) = hx(k-1,i)
+ end do
+
+ do iter = 1,20 !iteration for smoothing
+
+ do i=1,grid % nCells
+ hxzt(i) = hx(k,i) + sm*(hx(k,next_cell(i,2))-2.*hx(k,i)+hx(k,next_cell(i,1)))
+ end do
+ dzh = zc(k) - zc(k-1)
+ do i=1,grid % nCells
+ dzht = zc(k)+hxzt(i) - zc(k-1)-hx(k-1,i)
+ if(dzht.lt.dzh) dzh = dzht
+ end do
+
+ if(dzh.gt.dzmin*(zc(k)-zc(k-1))) then
+ do i=1,grid % nCells
+ hx(k,i) = hxzt(i)
+ end do
+ else
+ goto 99 !SHP - this algorithm should be changed
+ end if
+
+ end do !end of iteration for smoothing
+99 print *,"PASS-SHP"
+ end do
+
+ do iCell=1,grid % nCells
+ do k=1,nz
+ if (terrain_smooth) then
+ zgrid(k,iCell) = ah(k)*(zc(k)*(1.-hx(k,iCell)/zt)+hx(k,iCell)) &
+ + (1.-ah(k)) * zc(k)
+ else
+ zgrid(k,iCell) = ah(k)*(zc(k)*(1.-hx(1,iCell)/zt)+hx(1,iCell)) &
+ + (1.-ah(k)) * zc(k)
+ end if
+ end do
+ do k=1,nz1
+ zz (k,iCell) = (zw(k+1)-zw(k))/(zgrid(k+1,iCell)-zgrid(k,iCell))
+ end do
+ end do
+
+ do i=1, grid % nEdges
+ iCell1 = grid % CellsOnEdge % array(1,i)
+ iCell2 = grid % CellsOnEdge % array(2,i)
+ do k=1,nz
+ zx (k,i) = (zgrid(k,iCell2)-zgrid(k,iCell1)) / grid % dcEdge % array(i)
+ end do
+ end do
+ do i=1, grid % nCells
+ do k=1,nz1
+ ztemp = .5*(zgrid(k+1,i)+zgrid(k,i))
+ dss(k,i) = 0.
+ ztemp = zgrid(k,i)
+ if(ztemp.gt.zd+.1) then
+ dss(k,i) = dss(k,i)+xnutr*sin(.5*pii*(ztemp-zd)/(zt-zd))**2
+ end if
+ end do
+ enddo
+
+ write(0,*) ' grid metrics setup complete '
+
+!
+! mountain wave initialization
+!
+ !SHP-original
+ !zinv = 1000.
+ !SHP-schar case
+ zinv = 3000.
+
+ xn2 = 0.0001
+ xn2m = 0.0000
+ xn2l = 0.0001
+
+ um = 10.
+ us = 0.
+
+ do i=1,grid % nCells
+ do k=1,nz1
+ ztemp = .5*(zgrid(k,i)+zgrid(k+1,i))
+ tb(k,i) = t0*(1. + xn2m/gravity*ztemp)
+ if(ztemp .le. zinv) then
+ t (k,i) = t0*(1.+xn2l/gravity*ztemp)
+ else
+ t (k,i) = t0*(1.+xn2l/gravity*zinv+xn2/gravity*(ztemp-zinv))
+ end if
+ rh(k,i) = 0.
+ end do
+ end do
+
+! set the velocity field - we are on a plane here.
+
+ do i=1, grid % nEdges
+ cell1 = grid % CellsOnEdge % array(1,i)
+ cell2 = grid % CellsOnEdge % array(2,i)
+ if(cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
+ do k=1,nz1
+ ztemp = .25*( zgrid(k,cell1 )+zgrid(k+1,cell1 ) &
+ +zgrid(k,cell2)+zgrid(k+1,cell2))
+ u(k,i) = um
+ if(i == 1 ) grid % u_init % array(k) = u(k,i) - us
+ u(k,i) = cos(grid % angleEdge % array(i)) * (u(k,i) - us)
+ end do
+ end if
+ end do
+
+!
+! reference sounding based on dry atmosphere
+!
+ pitop = 1.-.5*dzw(1)*gravity/(cp*tb(1,1)*zz(1,1))
+ do k=2,nz1
+ pitop = pitop-dzu(k)*gravity/(cp*(fzm(k)*tb(k,1)+fzp(k)*tb(k-1,1)) &
+ *(fzm(k)*zz(k,1)+fzp(k)*zz(k-1,1)))
+ end do
+ pitop = pitop-.5*dzw(nz1)*gravity/(cp*tb(nz1,1)*zz(nz1,1))
+ ptopb = p0*pitop**(1./rcp)
+
+ do i=1, grid % nCells
+ pb(nz1,i) = pitop+.5*dzw(nz1)*gravity/(cp*tb(nz1,i)*zz(nz1,i))
+ p (nz1,i) = pitop+.5*dzw(nz1)*gravity/(cp*t (nz1,i)*zz(nz1,i))
+ do k=nz1-1,1,-1
+ pb(k,i) = pb(k+1,i) + dzu(k+1)*gravity/(cp*.5*(tb(k,i)+tb(k+1,i)) &
+ *.5*(zz(k,i)+zz(k+1,i)))
+ p (k,i) = p (k+1,i) + dzu(k+1)*gravity/(cp*.5*(t (k,i)+t (k+1,i)) &
+ *.5*(zz(k,i)+zz(k+1,i)))
+ end do
+ do k=1,nz1
+ rb (k,i) = pb(k,i)**(1./rcv)/((rgas/p0)*tb(k,i)*zz(k,i))
+ rtb(k,i) = rb(k,i)*tb(k,i)
+ rr (k,i) = p (k,i)**(1./rcv)/((rgas/p0)*t (k,i)*zz(k,i))-rb(k,i)
+ cqw(k,i) = 1.
+ end do
+ end do
+
+ write(0,*) ' ***** base state sounding ***** '
+ write(0,*) 'k pb p rb rtb rr tb t'
+ do k=1,grid%nVertLevels
+ write(0,'(i2,7(2x,f14.9))') k,pb(k,1),p(k,1),rb(k,1),rtb(k,1),rr(k,1),tb(k,1),t(k,1)
+ end do
+
+ scalars(index_qv,:,:) = 0.
+
+!-------------------------------------------------------------------
+! ITERATIONS TO CONVERGE MOIST SOUNDING
+ do itr=1,30
+ pitop = 1.-.5*dzw(1)*gravity*(1.+scalars(index_qv,1,1))/(cp*t(1,1)*zz(1,1))
+
+ do k=2,nz1
+ pitop = pitop-dzu(k)*gravity/(cp*cqw(k,1)*(fzm(k)*t (k,1)+fzp(k)*t (k-1,1)) &
+ *(fzm(k)*zz(k,1)+fzp(k)*zz(k-1,1)))
+ end do
+ pitop = pitop - .5*dzw(nz1)*gravity*(1.+scalars(index_qv,nz1,1))/(cp*t(nz1,1)*zz(nz1,1))
+ ptop = p0*pitop**(1./rcp)
+
+ do i = 1, grid % nCells
+
+ pp(nz1,i) = ptop-ptopb+.5*dzw(nz1)*gravity* &
+ (rr(nz1,i)+(rr(nz1,i)+rb(nz1,i))*scalars(index_qv,nz1,i))
+ do k=nz1-1,1,-1
+ pp(k,i) = pp(k+1,i)+dzu(k+1)*gravity* &
+ (fzm(k)*(rr(k ,i)+(rr(k ,i)+rb(k ,i))*scalars(index_qv,k ,i)) &
+ +fzp(k)*(rr(k+1,i)+(rr(k+1,i)+rb(k+1,i))*scalars(index_qv,k+1,i)))
+ end do
+ do k=1,nz1
+ rt(k,i) = (pp(k,i)/(rgas*zz(k,i)) &
+ -rtb(k,i)*(p(k,i)-pb(k,i)))/p(k,i)
+ p (k,i) = (zz(k,i)*(rgas/p0)*(rtb(k,i)+rt(k,i)))**rcv
+ rr(k,i) = (rt(k,i)-rb(k,i)*(t(k,i)-tb(k,i)))/t(k,i)
+ end do
+!
+! update water vapor mixing ratio from humitidty profile
+!
+ do k=1,nz1
+ temp = p(k,i)*t(k,i)
+ pres = p0*p(k,i)**(1./rcp)
+ qvs = 380.*exp(17.27*(temp-273.)/(temp-36.))/pres
+ scalars(index_qv,k,i) = amin1(0.014,rh(k,i)*qvs)
+ end do
+
+ do k=1,nz1
+ t (k,i) = t(k,i)*(1.+1.61*scalars(index_qv,k,i))
+ end do
+ do k=2,nz1
+ cqw(k,i) = 1./(1.+.5*( scalars(index_qv,k-1,i) &
+ +scalars(index_qv,k ,i)))
+ end do
+
+ end do ! loop over cells
+
+ end do ! iteration loop
+!----------------------------------------------------------------------
+!
+ write(0,*) ' *** sounding for the simulation ***'
+ write(0,*) ' z theta pres qv rho_m u rr'
+ do k=1,nz1
+ write(6,'(8(f14.9,2x))') .5*(zgrid(k,1)+zgrid(k+1,1))/1000., &
+ t(k,1)/(1.+1.61*scalars(index_qv,k,1)), &
+ .01*p0*p(k,1)**(1./rcp), &
+ 1000.*scalars(index_qv,k,1), &
+ (rb(k,1)+rr(k,1))*(1.+scalars(index_qv,k,1)), &
+ grid % u_init % array(k), rr(k,1)
+ end do
+
+ do i=1,grid % ncells
+ do k=1,nz1
+ rho(k,i) = rb(k,i)+rr(k,i)
+ end do
+
+ do k=1,nz1
+ grid % t_init % array(k,i) = t(k,i)
+ end do
+ end do
+
+ do i=1,grid % nEdges
+ cell1 = grid % CellsOnEdge % array(1,i)
+ cell2 = grid % CellsOnEdge % array(2,i)
+ if(cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
+ do k=1,nz1
+ ru (k,i) = 0.5*(rho(k,cell1)+rho(k,cell2))*u(k,i)
+ end do
+ end if
+ end do
+
+!
+! pre-calculation z-metric terms in omega eqn.
+!
+ do iEdge = 1,grid % nEdges
+ cell1 = CellsOnEdge(1,iEdge)
+ cell2 = CellsOnEdge(2,iEdge)
+ if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve ) then
+
+ do k = 1, grid%nVertLevels
+
+ if (config_theta_adv_order == 2) then
+
+ z_edge = (zgrid(k,cell1)+zgrid(k,cell2))/2.
+
+ else !theta_adv_order == 3 or 4
+
+ d2fdx2_cell1 = deriv_two(1,1,iEdge) * zgrid(k,cell1)
+ d2fdx2_cell2 = deriv_two(1,2,iEdge) * zgrid(k,cell2)
+ do i=1, grid % nEdgesOnCell % array (cell1)
+ if ( grid % CellsOnCell % array (i,cell1) > 0) &
+ d2fdx2_cell1 = d2fdx2_cell1 + deriv_two(i+1,1,iEdge) * zgrid(k,grid % CellsOnCell % array (i,cell1))
+ end do
+ do i=1, grid % nEdgesOnCell % array (cell2)
+ if ( grid % CellsOnCell % array (i,cell2) > 0) &
+ d2fdx2_cell2 = d2fdx2_cell2 + deriv_two(i+1,2,iEdge) * zgrid(k,grid % CellsOnCell % array (i,cell2))
+ end do
+
+ z_edge = 0.5*(zgrid(k,cell1) + zgrid(k,cell2)) &
+ - (grid % dcEdge % array(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12.
+
+ if (config_theta_adv_order == 3) then
+ z_edge3 = - (grid % dcEdge % array(iEdge) **2) * (d2fdx2_cell1 - d2fdx2_cell2) / 12.
+ else
+ z_edge3 = 0.
+ end if
+
+ end if
+
+ zb(k,1,iEdge) = (z_edge-zgrid(k,cell1))*dvEdge(iEdge)/AreaCell(cell1)
+ zb(k,2,iEdge) = (z_edge-zgrid(k,cell2))*dvEdge(iEdge)/AreaCell(cell2)
+ zb3(k,1,iEdge)= z_edge3*dvEdge(iEdge)/AreaCell(cell1)
+ zb3(k,2,iEdge)= z_edge3*dvEdge(iEdge)/AreaCell(cell2)
+
+ if (k /= 1) then
+ zf(k,1,iEdge) = ( fzm(k)*zz(k,cell1)+fzp(k)*zz(k-1,cell1) )*zb(k,1,iEdge)
+ zf(k,2,iEdge) = ( fzm(k)*zz(k,cell2)+fzp(k)*zz(k-1,cell2) )*zb(k,2,iEdge)
+ zf3(k,1,iEdge)= ( fzm(k)*zz(k,cell1)+fzp(k)*zz(k-1,cell1) )*zb3(k,1,iEdge)
+ zf3(k,2,iEdge)= ( fzm(k)*zz(k,cell2)+fzp(k)*zz(k-1,cell2) )*zb3(k,2,iEdge)
+ end if
+
+ end do
+
+ end if
+ end do
+
+! for including terrain
+ state % w % array(:,:) = 0.0
+ diag % rw % array(:,:) = 0.0
+
+!
+! calculation of omega, rw = zx * ru + zz * rw
+!
+
+ do iEdge = 1,grid % nEdges
+
+ cell1 = CellsOnEdge(1,iEdge)
+ cell2 = CellsOnEdge(2,iEdge)
+
+ if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve ) then
+ do k = 2, grid%nVertLevels
+ flux = (fzm(k)*ru(k,iEdge)+fzp(k)*ru(k-1,iEdge))
+ diag % rw % array(k,cell2) = diag % rw % array(k,cell2) + zf(k,2,iEdge)*flux
+ diag % rw % array(k,cell1) = diag % rw % array(k,cell1) - zf(k,1,iEdge)*flux
+
+ if (config_theta_adv_order ==3) then
+ diag % rw % array(k,cell2) = diag % rw % array(k,cell2) &
+ - sign(1.,ru(k,iEdge))*config_coef_3rd_order*zf3(k,2,iEdge)*flux
+ diag % rw % array(k,cell1) = diag % rw % array(k,cell1) &
+ + sign(1.,ru(k,iEdge))*config_coef_3rd_order*zf3(k,1,iEdge)*flux
+ end if
+
+ end do
+ end if
+
+ end do
+
+ ! Compute w from rho and rw
+ do iCell=1,grid%nCells
+ do k=2,grid%nVertLevels
+ state % w % array(k,iCell) = diag % rw % array(k,iCell) &
+ / (fzp(k) * state % rho % array(k-1,iCell) + fzm(k) * state % rho % array(k,iCell))
+ end do
+ end do
+
+
+ do iEdge=1,grid % nEdges
+ grid % fEdge % array(iEdge) = 0.
+ end do
+
+ do iVtx=1,grid % nVertices
+ grid % fVertex % array(iVtx) = 0.
+ end do
+
+ !
+ ! Compute mass fluxes tangential to each edge (i.e., through the faces of dual grid cells)
+ !
+ diag % v % array(:,:) = 0.0
+ do iEdge = 1, grid%nEdges
+ do i=1,nEdgesOnEdge(iEdge)
+ eoe = edgesOnEdge(i,iEdge)
+ if (eoe > 0) then
+ do k = 1, grid%nVertLevels
+ diag % v % array(k,iEdge) = diag % v %array(k,iEdge) + weightsOnEdge(i,iEdge) * state % u % array(k, eoe)
+ end do
+ end if
+ end do
+ end do
+
+! do k=1,grid%nVertLevels
+! write(0,*) ' k,u_init, t_init, qv_init ',k,grid % u_init % array(k),grid % t_init% array(k),grid % qv_init % array(k)
+! end do
+
+ end subroutine nhyd_test_case_mtn_wave
+
+
+ subroutine nhyd_test_case_gfs(dminfo, grid, fg, state, diag, test_case)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Real-data test case using GFS data
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ use read_met
+ use llxy
+ use dmpar
+
+ implicit none
+
+ 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
+
+ real (kind=RKIND), parameter :: u0 = 35.0
+ real (kind=RKIND), parameter :: alpha_grid = 0. ! no grid rotation
+ real (kind=RKIND), parameter :: omega_e = 7.29212e-05
+ real (kind=RKIND), parameter :: t0b = 250., t0 = 288., delta_t = 4.8e+05, dtdz = 0.005, eta_t = 0.2
+ real (kind=RKIND), parameter :: u_perturbation = 1., pert_radius = 0.1, latitude_pert = 40., longitude_pert = 20.
+ real (kind=RKIND), parameter :: theta_c = pii/4.0
+ real (kind=RKIND), parameter :: lambda_c = 3.0*pii/2.0
+ real (kind=RKIND), parameter :: rh_max = 0.4 ! Maximum relative humidity
+ real (kind=RKIND), parameter :: k_x = 9. ! Normal mode wave number
+
+ type (met_data) :: field
+ type (proj_info) :: proj
+
+ real (kind=RKIND), dimension(:), pointer :: rdzw, dzu, rdzu, fzm, fzp
+ real (kind=RKIND), dimension(:), pointer :: vert_level, latPoints, lonPoints
+ real (kind=RKIND), dimension(:,:), pointer :: zgrid, zx, zz, hx
+ real (kind=RKIND), dimension(:,:), pointer :: pressure, ppb, pb, rho, rb, rr, tb, rtb, p, pp, dss, t, rt
+ real (kind=RKIND), dimension(:), pointer :: destField1d
+ real (kind=RKIND), dimension(:,:), pointer :: destField2d
+ real (kind=RKIND), dimension(:,:,:), pointer :: zf, zf3, zb, zb3
+ real (kind=RKIND), dimension(:,:,:), pointer :: scalars
+ real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
+
+ integer :: iCell, iCell1, iCell2 , iEdge, vtx1, vtx2, ivtx, i, k, nz, nz1, itr, itrp, cell1, cell2, nCellsSolve
+ integer :: nInterpPoints, ndims
+
+ !This is temporary variable here. It just need when calculate tangential velocity v.
+ integer :: eoe, j
+ integer, dimension(:), pointer :: nEdgesOnEdge
+ integer, dimension(:,:), pointer :: edgesOnEdge, CellsOnEdge, cellsOnCell
+ real (kind=RKIND), dimension(:), pointer :: dvEdge, AreaCell
+ real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge
+ real (kind=RKIND), dimension(:,:), pointer :: v
+
+ ! 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
+ character (len=1024) :: fname
+
+ real (kind=RKIND) :: u, flux, fluxk, lat1, lat2, eta_v, r_pert, u_pert, lat_pert, lon_pert, r
+ real (kind=4) :: lat, lon, x, y
+
+ real (kind=RKIND) :: ptop, p0, phi
+ real (kind=RKIND) :: lon_Edge
+
+ real (kind=RKIND) :: r_earth, etavs, ztemp, zd, zt, dz, gam, delt, str
+
+ real (kind=RKIND), dimension(grid % nVertLevels, grid % nCells) :: rel_hum, temperature, qv
+ real (kind=RKIND) :: ptmp, es, qvs, xnutr, znut, ptemp
+ integer :: iter
+
+ real (kind=RKIND), dimension(grid % nVertLevels + 1) :: hyai, hybi, znu, znw, znwc, znwv, hyam, hybm
+ real (kind=RKIND), dimension(grid % nVertLevels + 1) :: znuc, znuv, bn, divh, dpn
+
+ real (kind=RKIND), dimension(grid % nVertLevels + 1) :: sh, zw, ah
+ real (kind=RKIND), dimension(grid % nVertLevels) :: zu, dzw, rdzwp, rdzwm
+ real (kind=RKIND), dimension(grid % nVertLevels) :: eta, etav, teta, ppi, tt
+
+ real (kind=RKIND), dimension(grid % nCells) :: hs
+
+ real (kind=RKIND) :: d1, d2, d3, cf1, cf2, cf3, cof1, cof2, psurf
+
+ ! storage for (lat,z) arrays for zonal velocity calculation
+
+ integer, parameter :: nlat=361
+ real (kind=RKIND), dimension(grid % nVertLevels + 1) :: zz_1d, zgrid_1d, hx_1d
+ real (kind=RKIND), dimension(grid % nVertLevels) :: flux_zonal
+ real (kind=RKIND), dimension(nlat, grid % nVertLevels) :: u_2d, etavs_2d
+ real (kind=RKIND), dimension(nlat) :: lat_2d
+ real (kind=RKIND) :: dlat
+ real (kind=RKIND) :: z_edge, z_edge3, d2fdx2_cell1, d2fdx2_cell2
+
+ weightsOnEdge => grid % weightsOnEdge % array
+ nEdgesOnEdge => grid % nEdgesOnEdge % array
+ edgesOnEdge => grid % edgesOnEdge % array
+ dvEdge => grid % dvEdge % array
+ AreaCell => grid % AreaCell % array
+ CellsOnEdge => grid % CellsOnEdge % array
+ cellsOnCell => grid % cellsOnCell % array
+
+ deriv_two => grid % deriv_two % array
+ zf => grid % zf % array
+ zf3 => grid % zf3% array
+ zb => grid % zb % array
+ zb3 => grid % zb3% array
+
+ zgrid => grid % zgrid % array
+ rdzw => grid % rdzw % array
+ dzu => grid % dzu % array
+ rdzu => grid % rdzu % array
+ fzm => grid % fzm % array
+ fzp => grid % fzp % array
+ zx => grid % zx % array
+ zz => grid % zz % array
+ hx => grid % hx % array
+ dss => grid % dss % array
+
+ pb => diag % exner_base % array
+ rb => diag % rho_base % array
+ tb => diag % theta_base % array
+ rtb => diag % rtheta_base % array
+ p => diag % exner % array
+
+ ppb => diag % pressure_base % array
+ pp => diag % pressure_p % array
+
+ rho => state % rho % array
+ rr => diag % rho_p % array
+ t => state % theta % array
+ rt => diag % rtheta_p % array
+
+ scalars => state % scalars % array
+
+ nz1 = grid % nVertLevels
+ nz = nz1 + 1
+ nCellsSolve = grid % nCellsSolve
+
+
+ !
+ ! 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
+
+ scalars(:,:,:) = 0.
+
+ call initialize_advection_rk(grid)
+ call initialize_deformation_weights(grid)
+
+ xnutr = 0.
+ zd = 12000.
+ znut = eta_t
+
+ etavs = (1.-0.252)*pii/2.
+ r_earth = a
+ p0 = 1.e+05
+
+
+#if 0
+ !
+ ! 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
+ grid % hx % array(:,:) = 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)
+write(0,*) istatus
+write(0,*) 'min/max = ',minval(rarray(:,:,:)),maxval(rarray(:,:,:))
+ 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)
+
+ grid % hx % array(1,iPoint) = grid % hx % array(1,iPoint) + rarray(i,j,1)
+ nhs(iPoint) = nhs(iPoint) + 1
+
+ end do
+ end do
+
+ end do
+ end do
+
+ do iCell=1, grid % nCells
+ grid % hx % array(1,iCell) = grid % hx % array(1,iCell) / real(nhs(iCell))
+ end do
+
+ deallocate(rarray)
+ deallocate(nhs)
+
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! SMOOTH TOPOGRAPHY TO CREATE 3D HX FIELD
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ do k=2,grid%nVertLevels
+ grid % hx % array(k,:) = grid % hx % array(k-1,:)
+ do i=1,4
+ do iCell=1,grid%nCells
+ hs(iCell) = grid % hx % array(k,iCell)
+ do j = 1,grid % nEdgesOnCell % array(iCell)
+ hs(iCell) = hs(iCell) + grid % hx % array(k,cellsOnCell(j,iCell))
+ end do
+ hs(iCell) = hs(iCell) / real(grid%nEdgesOnCell%array(iCell)+1)
+ end do
+ do iCell=1,grid%nCells
+ grid % hx % array(k,iCell) = hs(iCell)
+ do j = 1,grid % nEdgesOnCell % array(iCell)
+ grid % hx % array(k,iCell) = grid % hx % array(k,iCell) + hs(cellsOnCell(j,iCell))
+ end do
+ grid % hx % array(k,iCell) = grid % hx % array(k,iCell) / real(grid%nEdgesOnCell%array(iCell)+1)
+ end do
+ end do
+ end do
+
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! CREATE VERTICAL GRID
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+ !
+ ! 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)
+write(0,*) istatus
+
+ 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)
+
+
+ !
+ ! Horizontally interpolate meteorological data
+ !
+ allocate(vert_level(config_nfglevels))
+ vert_level(:) = -1.0
+
+ call read_met_init(trim(config_met_prefix), .false., trim(config_init_date), istatus)
+
+ if (istatus /= 0) then
+ write(0,*) 'Error reading initial met data'
+ return
+ end if
+
+ call read_next_met_field(field, istatus)
+ do while (istatus == 0)
+ if (index(field % field, 'UU') /= 0 .or. &
+ index(field % field, 'VV') /= 0 .or. &
+ index(field % field, 'TT') /= 0 .or. &
+ index(field % field, 'RH') /= 0 .or. &
+ index(field % field, 'GHT') /= 0 .or. &
+ index(field % field, 'PMSL') /= 0 .or. &
+ index(field % field, 'PSFC') /= 0 .or. &
+ index(field % field, 'SOILHGT') /= 0 .or. &
+ index(field % field, 'PRES') /= 0) then
+
+ if (index(field % field, 'PMSL') == 0 .and. &
+ index(field % field, 'PSFC') == 0 .and. &
+ index(field % field, 'SOILHGT') == 0) then
+ do k=1,config_nfglevels
+ if (vert_level(k) == field % xlvl .or. vert_level(k) == -1.0) exit
+ end do
+ if (k > config_nfglevels) write(0,*) 'ERROR: We seem to have more levels than we thought we should!'
+ if (vert_level(k) == -1.0) vert_level(k) = field % xlvl
+ else
+ k = 1
+ end if
+
+ !
+ ! Set up projection
+ !
+ call map_init(proj)
+
+ if (field % iproj == PROJ_LATLON) then
+ call map_set(PROJ_LATLON, proj, &
+ latinc = field % deltalat, &
+ loninc = field % deltalon, &
+ knowni = 1.0_4, &
+ knownj = 1.0_4, &
+ lat1 = field % startlat, &
+ lon1 = field % startlon)
+ end if
+
+
+ !
+ ! Horizontally interpolate the field at level k
+ !
+ if (index(field % field, 'UU') /= 0) then
+write(0,*) 'Interpolating U at ', k, vert_level(k)
+ nInterpPoints = grid % nEdges
+ latPoints => grid % latEdge % array
+ lonPoints => grid % lonEdge % array
+ destField2d => fg % u % array
+ ndims = 2
+ else if (index(field % field, 'VV') /= 0) then
+write(0,*) 'Interpolating V at ', k, vert_level(k)
+ nInterpPoints = grid % nEdges
+ latPoints => grid % latEdge % array
+ lonPoints => grid % lonEdge % array
+ destField2d => fg % v % array
+ ndims = 2
+ else if (index(field % field, 'TT') /= 0) then
+write(0,*) 'Interpolating T at ', k, vert_level(k)
+ nInterpPoints = grid % nCells
+ latPoints => grid % latCell % array
+ lonPoints => grid % lonCell % array
+ destField2d => fg % t % array
+ ndims = 2
+ else if (index(field % field, 'RH') /= 0) then
+write(0,*) 'Interpolating RH at ', k, vert_level(k)
+ nInterpPoints = grid % nCells
+ latPoints => grid % latCell % array
+ lonPoints => grid % lonCell % array
+ destField2d => fg % rh % array
+ ndims = 2
+ else if (index(field % field, 'GHT') /= 0) then
+write(0,*) 'Interpolating GHT at ', k, vert_level(k)
+ nInterpPoints = grid % nCells
+ latPoints => grid % latCell % array
+ lonPoints => grid % lonCell % array
+ destField2d => fg % z % array
+ ndims = 2
+ else if (index(field % field, 'PRES') /= 0) then
+write(0,*) 'Interpolating PRES at ', k, vert_level(k)
+ nInterpPoints = grid % nCells
+ latPoints => grid % latCell % array
+ lonPoints => grid % lonCell % array
+ destField2d => fg % p % array
+ ndims = 2
+ else if (index(field % field, 'PMSL') /= 0) then
+write(0,*) 'Interpolating PMSL'
+ nInterpPoints = grid % nCells
+ latPoints => grid % latCell % array
+ lonPoints => grid % lonCell % array
+ destField1d => fg % pmsl % array
+ ndims = 1
+ else if (index(field % field, 'PSFC') /= 0) then
+write(0,*) 'Interpolating PSFC'
+ nInterpPoints = grid % nCells
+ latPoints => grid % latCell % array
+ lonPoints => grid % lonCell % array
+ destField1d => fg % psfc % array
+ ndims = 1
+ else if (index(field % field, 'SOILHGT') /= 0) then
+write(0,*) 'Interpolating SOILHGT'
+ nInterpPoints = grid % nCells
+ latPoints => grid % latCell % array
+ lonPoints => grid % lonCell % array
+ destField1d => fg % soilz % array
+ ndims = 1
+ end if
+
+ do i=1,nInterpPoints
+ lat = latPoints(i)*DEG_PER_RAD
+ lon = lonPoints(i)*DEG_PER_RAD
+ call latlon_to_ij(proj, lat, lon, x, y)
+ if (x < 0.0) then
+ lon = lon + 360.0
+ call latlon_to_ij(proj, lat, lon, x, y)
+ end if
+ if (ndims == 1) then
+ destField1d(i) = four_pt(field % nx, field % ny, field % slab, x, y)
+ else if (ndims == 2) then
+ destField2d(k,i) = four_pt(field % nx, field % ny, field % slab, x, y)
+ end if
+ end do
+ end if
+
+ deallocate(field % slab)
+ call read_next_met_field(field, istatus)
+ end do
+
+ call read_met_close()
+
+
+ !
+ ! Compute normal wind component and store in fg%u
+ !
+ do iEdge=1,grid%nEdges
+ do k=1,config_nfglevels
+ fg % u % array(k,iEdge) = cos(grid % angleEdge % array(iEdge)) * fg % u % array(k,iEdge) &
+ + sin(grid % angleEdge % array(iEdge)) * fg % v % array(k,iEdge)
+ end do
+ end do
+
+
+ !
+ ! Vertically interpolate meteorological data
+ !
+ do iCell=1,grid%nCells
+ do k=1,grid%nVertLevels
+ ! HGT
+ ! PRES
+ ! THETA
+ ! RH
+ ! T
+ end do
+ end do
+
+ do iEdge=1,grid%nEdges
+ do k=1,grid%nVertLevels
+ ! U
+ end do
+ end do
+
+
+ !
+ ! Diagnose fields needed in initial conditions file (u, w, rho, theta, scalars)
+ !
+
+ deallocate(vert_level)
+#endif
+
+
+ end subroutine nhyd_test_case_gfs
+
+
+ real function four_pt(nx, ny, array, xx, yy)
+
+ implicit none
+
+ integer, intent(in) :: nx, ny
+ real (kind=4), dimension(nx, ny), intent(in) :: array
+ real (kind=4), intent(in) :: xx, yy
+
+ integer :: min_x, max_x, min_y, max_y
+
+ min_x = floor(xx)
+ min_y = floor(yy)
+ max_x = ceiling(xx)
+ max_y = ceiling(yy)
+
+ if (min_x == 0) min_x = max_x
+ if (max_x == nx+1) max_x = min_x
+ if (min_y == 0) min_y = max_y
+ if (max_y == ny+1) max_y = min_y
+
+ if ((min_x < 1) .or. (max_x > nx) .or. (min_y < 1) .or. (max_y > ny)) then
+ write(0,*) '(x,y) location out of bounds'
+ four_pt = 0.0
+ return
+ end if
+
+ if (min_x == max_x) then
+ if (min_y == max_y) then
+ four_pt = array(min_x,min_y)
+ else
+ four_pt = array(min_x,min_y)*(real(max_y)-yy) + &
+ array(min_x,max_y)*(yy-real(min_y))
+ end if
+ else if (min_y == max_y) then
+ if (min_x == max_x) then
+ four_pt = array(min_x,min_y)
+ else
+ four_pt = array(min_x,min_y)*(real(max_x)-xx) + &
+ array(max_x,min_y)*(xx-real(min_x))
+ end if
+ else
+ four_pt = (yy - min_y) * (array(min_x,max_y)*(real(max_x)-xx) + &
+ array(max_x,max_y)*(xx-real(min_x))) + &
+ (max_y - yy) * (array(min_x,min_y)*(real(max_x)-xx) + &
+ array(max_x,min_y)*(xx-real(min_x)));
+ end if
+
+ return
+
+ end function four_pt
+
+
+ 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
+
+
+ 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)
+ nearest_cell = current_cell
+ nearest_distance = current_distance
+ do i = 1, nEdgesOnCell(current_cell)
+ iCell = cellsOnCell(i,current_cell)
+ d = sphere_distance(latCell(iCell), lonCell(iCell), target_lat, target_lon, 1.0)
+ if (d < nearest_distance) then
+ nearest_cell = iCell
+ nearest_distance = d
+ 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)
+
+ implicit none
+
+ real (kind=RKIND), intent(in) :: target_lat, target_lon
+ integer, intent(in) :: start_edge
+ integer, intent(in) :: nCells, nEdges, maxEdges
+ integer, dimension(nCells), intent(in) :: nEdgesOnCell
+ integer, dimension(maxEdges,nCells), intent(in) :: edgesOnCell
+ integer, dimension(2,nEdges), intent(in) :: cellsOnEdge
+ real (kind=RKIND), dimension(nCells), intent(in) :: latCell, lonCell
+ real (kind=RKIND), dimension(nEdges), intent(in) :: latEdge, lonEdge
+
+ integer :: i, cell1, cell2, iCell
+ integer :: iEdge
+ integer :: current_edge
+ real (kind=RKIND) :: cell1_dist, cell2_dist
+ real (kind=RKIND) :: current_distance, d
+ real (kind=RKIND) :: nearest_distance
+
+ nearest_edge = start_edge
+ current_edge = -1
+
+ do while (nearest_edge /= current_edge)
+ current_edge = nearest_edge
+ current_distance = sphere_distance(latEdge(current_edge), lonEdge(current_edge), target_lat, target_lon, 1.0)
+ nearest_edge = current_edge
+ nearest_distance = current_distance
+ cell1 = cellsOnEdge(1,current_edge)
+ cell2 = cellsOnEdge(2,current_edge)
+ cell1_dist = sphere_distance(latCell(cell1), lonCell(cell1), target_lat, target_lon, 1.0)
+ cell2_dist = sphere_distance(latCell(cell2), lonCell(cell2), target_lat, target_lon, 1.0)
+ if (cell1_dist < cell2_dist) then
+ iCell = cell1
+ else
+ iCell = cell2
+ end if
+ do i = 1, nEdgesOnCell(iCell)
+ iEdge = edgesOnCell(i,iCell)
+ d = sphere_distance(latEdge(iEdge), lonEdge(iEdge), target_lat, target_lon, 1.0)
+ if (d < nearest_distance) then
+ nearest_edge = iEdge
+ nearest_distance = d
+ end if
+ end do
+ end do
+
+ end function nearest_edge
+
+end module test_cases
Added: branches/atmos_physics/src/core_init_nhyd_atmos/read_geogrid.c
===================================================================
--- branches/atmos_physics/src/core_init_nhyd_atmos/read_geogrid.c (rev 0)
+++ branches/atmos_physics/src/core_init_nhyd_atmos/read_geogrid.c 2011-01-05 00:56:27 UTC (rev 673)
@@ -0,0 +1,139 @@
+/* File: read_geogrid.c
+
+ Sample subroutine to read an array from the geogrid binary format.
+
+ Notes: Depending on the compiler and compiler flags, the name of
+ the read_geogrid() routine may need to be adjusted with respect
+ to the number of trailing underscores when calling from Fortran.
+
+ Michael G. Duda, NCAR/MMM
+*/
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+
+#ifdef UNDERSCORE
+#define read_geogrid read_geogrid_
+#endif
+#ifdef DOUBLEUNDERSCORE
+#define read_geogrid read_geogrid__
+#endif
+
+#define BIG_ENDIAN 0
+#define LITTLE_ENDIAN 1
+
+int read_geogrid(
+ char * fname, /* The name of the file to read from */
+ int * len, /* The length of the filename */
+ float * rarray, /* The array to be filled */
+ int * nx, /* x-dimension of the array */
+ int * ny, /* y-dimension of the array */
+ int * nz, /* z-dimension of the array */
+ int * isigned, /* 0=unsigned data, 1=signed data */
+ int * endian, /* 0=big endian, 1=little endian */
+ float * scalefactor, /* value to multiply array elements by before truncation to integers */
+ int * wordsize, /* number of bytes to use for each array element */
+ int * status)
+{
+ int i, ival, cnt, narray;
+ int A2, B2;
+ int A3, B3, C3;
+ int A4, B4, C4, D4;
+ unsigned char * c;
+ char local_fname[1024];
+ FILE * bfile;
+
+ *status = 0;
+
+ narray = (*nx) * (*ny) * (*nz);
+
+ /* Make a null-terminated local copy of the filename */
+ strncpy(local_fname,fname,*len);
+ local_fname[*len]='\0';
+
+ /* Attempt to open file for reading */
+ if (!(bfile = fopen(local_fname,"rb")))
+ {
+ *status = 1;
+ return 1;
+ }
+
+ /* Allocate memory to hold bytes from file and read data */
+ c = (unsigned char *)malloc(sizeof(unsigned char)*(*wordsize) * narray);
+ cnt = fread((void *)c, sizeof(unsigned char), narray*(*wordsize), bfile);
+
+ fclose(bfile);
+
+ if (cnt == 0)
+ {
+ *status = 1;
+ return 1;
+ }
+
+ /*
+ Set up byte offsets for each wordsize depending on byte order.
+ A, B, C, D give the offsets of the LSB through MSB (i.e., for
+ word ABCD, A=MSB, D=LSB) in the array from the beginning of a word
+ */
+ if (*endian == BIG_ENDIAN) {
+ A2 = 0; B2 = 1;
+ A3 = 0; B3 = 1; C3 = 2;
+ A4 = 0; B4 = 1; C4 = 2; D4 = 3;
+ }
+ else {
+ B2 = 0; A2 = 1;
+ C3 = 0; B3 = 1; A3 = 2;
+ D4 = 0; C4 = 1; B4 = 2; A4 = 3;
+ }
+
+ /* Convert words from native byte order */
+ switch(*wordsize) {
+ case 1:
+ for(i=0; i<narray; i++)
+ {
+ ival = (int)(c[i]);
+ if ((*isigned) && (ival > (1 << 7))) ival -= (1 << 8);
+ rarray[i] = (float)ival;
+ }
+ break;
+
+ case 2:
+ for(i=0; i<narray; i++)
+ {
+ ival = (int)((c[2*i+A2]<<8) | (c[2*i+B2]));
+ if ((*isigned) && (ival > (1 << 15))) ival -= (1 << 16);
+ rarray[i] = (float)ival;
+ }
+ break;
+
+ case 3:
+ for(i=0; i<narray; i++)
+ {
+ ival = (int)((c[3*i+A3]<<16) | (c[3*i+B3]<<8) | c[3*i+C3]);
+ if ((*isigned) * (ival > (1 << 23))) ival -= (1 << 24);
+ rarray[i] = (float)ival;
+ }
+ break;
+
+ case 4:
+ for(i=0; i<narray; i++)
+ {
+ ival = (int)((c[4*i+A4]<<24) | (c[4*i+B4]<<16) | (c[4*i+C4]<<8) | c[4*i+D4]);
+ if ((*isigned) && (ival > (1 << 31))) ival -= (1 << 32);
+ rarray[i] = (float)ival;
+ }
+ break;
+ }
+
+ free(c);
+
+ /* Scale real-valued array by scalefactor */
+ if (*scalefactor != 1.0)
+ {
+ for (i=0; i<narray; i++)
+ rarray[i] = rarray[i] * (*scalefactor);
+ }
+
+ return 0;
+}
Modified: branches/atmos_physics/src/core_nhyd_atmos/Makefile
===================================================================
--- branches/atmos_physics/src/core_nhyd_atmos/Makefile 2011-01-04 17:14:40 UTC (rev 672)
+++ branches/atmos_physics/src/core_nhyd_atmos/Makefile 2011-01-05 00:56:27 UTC (rev 673)
@@ -1,6 +1,6 @@
.SUFFIXES: .F .o
-OBJS = module_core.o \
+OBJS = module_mpas_core.o \
module_test_cases.o \
module_time_integration.o \
module_advection.o
@@ -16,7 +16,7 @@
module_advection.o:
-module_core.o: module_advection.o module_test_cases.o module_time_integration.o
+module_mpas_core.o: module_advection.o module_test_cases.o module_time_integration.o
clean:
$(RM) *.o *.mod *.f90 libdycore.a
Modified: branches/atmos_physics/src/core_nhyd_atmos/Registry
===================================================================
--- branches/atmos_physics/src/core_nhyd_atmos/Registry 2011-01-04 17:14:40 UTC (rev 672)
+++ branches/atmos_physics/src/core_nhyd_atmos/Registry 2011-01-05 00:56:27 UTC (rev 673)
@@ -35,6 +35,7 @@
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_decomp_file_prefix graph.info.part.
namelist integer restart config_restart_interval 0
namelist logical restart config_do_restart false
namelist real restart config_restart_time 172800.0
@@ -237,7 +238,7 @@
var persistent real rtheta_p_save ( nVertLevels nCells Time ) 1 - rtheta_p_save diag - -
var persistent real rtheta_pp_old ( nVertLevels nCells Time ) 1 - rtheta_pp_old diag - -
-var persistent real rho_p ( nVertLevels nCells Time ) 1 iro rho_p diag - -
+var persistent real rho_p ( nVertLevels nCells Time ) 1 r rho_p diag - -
var persistent real rho_pp ( nVertLevels nCells Time ) 1 - rho_pp diag - -
var persistent real rho_p_save ( nVertLevels nCells Time ) 1 - rho_p_save diag - -
Deleted: branches/atmos_physics/src/core_nhyd_atmos/module_core.F
===================================================================
--- branches/atmos_physics/src/core_nhyd_atmos/module_core.F 2011-01-04 17:14:40 UTC (rev 672)
+++ branches/atmos_physics/src/core_nhyd_atmos/module_core.F 2011-01-05 00:56:27 UTC (rev 673)
@@ -1,245 +0,0 @@
-module core
-
- use framework
-
- type (io_output_object) :: restart_obj
- integer :: restart_frame
-
-
- contains
-
-
- subroutine mpas_init(domain)
-
- use configure
- use grid_types
- use test_cases
-
- implicit none
-
- type (domain_type), intent(inout) :: domain
-
- real (kind=RKIND) :: dt
- type (block_type), pointer :: block
-
-
- if (.not. config_do_restart) call setup_nhyd_test_case(domain)
-
- !
- ! Initialize core
- !
- dt = config_dt
- block => domain % blocklist
- do while (associated(block))
- call mpas_init_block(domain % dminfo, block, block % mesh, dt)
- block => block % next
- end do
-
- restart_frame = 1
-
- end subroutine mpas_init
-
-
- subroutine mpas_init_block(dminfo, block, mesh, dt)
-
- use grid_types
- ! use advection
- use time_integration
- use configure
- use RBF_interpolation
- use vector_reconstruction
-#ifdef DO_PHYSICS
- use module_physics_aquaplanet
- use module_physics_control
- use module_physics_init
- use module_physics_manager
-#endif
-
- implicit none
-
- type (dm_info), intent(in):: dminfo
- type (block_type), intent(inout) :: block
- type (mesh_type), intent(inout) :: mesh
- real (kind=RKIND), intent(in) :: dt
-
-
- if (.not. config_do_restart) then
- call init_coupled_diagnostics( block % state % time_levs(1) % state, block % diag, mesh)
- call compute_solve_diagnostics(dt, block % state % time_levs(1) % state, block % diag, mesh)
- end if
- call rbfInterp_initialize(mesh)
- call init_reconstruct(mesh)
- call reconstruct(block % state % time_levs(1) % state, block % diag, mesh)
-
- !
- ! Note: The following initialization calls have been moved to mpas_setup_test_case()
- ! since values computed by these routines are needed to produce initial fields
- !
- ! call initialize_advection_rk(mesh)
- ! call initialize_deformation_weights(mesh)
-
-#ifdef DO_PHYSICS
- !check that all the physics options are correctly defined and that at least one physics
- !parameterization is called (using the logical moist_physics):
- call physics_namelist_check
-
- !proceed with initialization of physics parameterization if moist_physics is set to true:
- if(moist_physics) then
-!initialization of all physics variables in registry:
- call physics_registry_init(config_do_restart, mesh, block % diag_physics, block % tend_physics)
- call physics_wrf_interface(mesh)
- call physics_init(dminfo, mesh, block % state % time_levs(1) % state, block % diag_physics)
-
-!initialization of some surface variables (temporary):
- call physics_aquaplanet_init(mesh, block % diag_physics)
- endif
-#endif
-
- if (.not. config_do_restart) block % state % time_levs(1) % state % xtime % scalar = 0.0
-
- end subroutine mpas_init_block
-
-
- subroutine mpas_run(domain, output_obj, output_frame)
-
- use grid_types
- use io_output
- use timer
-
- implicit none
-
- type (domain_type), intent(inout) :: domain
- type (io_output_object), intent(inout) :: output_obj
- integer, intent(inout) :: output_frame
-
- integer :: ntimesteps, itimestep
- real (kind=RKIND) :: dt
- type (block_type), pointer :: block_ptr
-
- ! Eventually, dt should be domain specific
- dt = config_dt
- ntimesteps = config_ntimesteps
-
- call write_output_frame(output_obj, output_frame, domain)
-
- ! During integration, time level 1 stores the model state at the beginning of the
- ! time step, and time level 2 stores the state advanced dt in time by timestep(...)
- do itimestep = 1,ntimesteps
- write(0,*) 'Doing timestep ', itimestep
- call timer_start("time integration")
- call mpas_timestep(domain, itimestep, dt)
- call timer_stop("time integration")
-
- ! Move time level 2 fields back into time level 1 for next time step
- call shift_time_levels_state(domain % blocklist % state)
-
- if (mod(itimestep, config_output_interval) == 0) then
- call write_output_frame(output_obj, output_frame, domain)
- end if
- if (mod(itimestep, config_restart_interval) == 0 .and. config_restart_interval > 0) then
- if (restart_frame == 1) call output_state_init(restart_obj, domain, "RESTART")
- call output_state_for_domain(restart_obj, domain, restart_frame)
- restart_frame = restart_frame + 1
- end if
- end do
-
- end subroutine mpas_run
-
-
- subroutine write_output_frame(output_obj, output_frame, domain)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Compute diagnostic fields for a domain and write model state to output file
- !
- ! Input/Output: domain - contains model state; diagnostic field are computed
- ! before returning
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- use grid_types
- use io_output
-
- implicit none
-
- integer, intent(inout) :: output_frame
- 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
- do while (associated(block_ptr))
- call compute_output_diagnostics(block_ptr % state % time_levs(1) % state, block_ptr % mesh)
- block_ptr => block_ptr % next
- end do
-
- call output_state_for_domain(output_obj, domain, output_frame)
- output_frame = output_frame + 1
-
- end subroutine write_output_frame
-
-
- subroutine compute_output_diagnostics(state, grid)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Compute diagnostic fields for a domain
- !
- ! Input: state - contains model prognostic fields
- ! grid - contains grid metadata
- !
- ! Output: state - upon returning, diagnostic fields will have be computed
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- use grid_types
-
- implicit none
-
- type (state_type), intent(inout) :: state
- type (mesh_type), intent(in) :: grid
-
- integer :: i, eoe
- integer :: iEdge, k
-
- end subroutine compute_output_diagnostics
-
-
- subroutine mpas_timestep(domain, itimestep, dt)
-
- use grid_types
- use time_integration
-#ifdef DO_PHYSICS
- use module_physics_control
- use module_physics_driver
- use module_physics_manager
-#endif
-
- implicit none
-
- type (domain_type), intent(inout) :: domain
- integer, intent(in) :: itimestep
- real (kind=RKIND), intent(in) :: dt
-
-#ifdef DO_PHYSICS
- !proceed with physics if moist_physics is set to true:
- if(moist_physics) then
- call physics_timetracker(itimestep)
- if(l_physics) call physics_driver(domain,itimestep)
- endif
-#endif
- call timestep(domain, dt, itimestep)
-
- end subroutine mpas_timestep
-
-
- subroutine mpas_finalize(domain)
-
- use grid_types
-
- implicit none
-
- type (domain_type), intent(inout) :: domain
-
- if (restart_frame > 1) call output_state_finalize(restart_obj, domain % dminfo)
-
- end subroutine mpas_finalize
-
-end module core
Copied: branches/atmos_physics/src/core_nhyd_atmos/module_mpas_core.F (from rev 667, branches/atmos_physics/src/core_nhyd_atmos/module_core.F)
===================================================================
--- branches/atmos_physics/src/core_nhyd_atmos/module_mpas_core.F (rev 0)
+++ branches/atmos_physics/src/core_nhyd_atmos/module_mpas_core.F 2011-01-05 00:56:27 UTC (rev 673)
@@ -0,0 +1,245 @@
+module mpas_core
+
+ use mpas_framework
+
+ type (io_output_object) :: restart_obj
+ integer :: restart_frame
+
+
+ contains
+
+
+ subroutine mpas_core_init(domain)
+
+ use configure
+ use grid_types
+ use test_cases
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+
+ real (kind=RKIND) :: dt
+ type (block_type), pointer :: block
+
+
+ if (.not. config_do_restart) call setup_nhyd_test_case(domain)
+
+ !
+ ! Initialize core
+ !
+ dt = config_dt
+ block => domain % blocklist
+ do while (associated(block))
+ call mpas_init_block(domain % dminfo, block, block % mesh, dt)
+ block => block % next
+ end do
+
+ restart_frame = 1
+
+ end subroutine mpas_core_init
+
+
+ subroutine mpas_init_block(dminfo, block, mesh, dt)
+
+ use grid_types
+ ! use advection
+ use time_integration
+ use configure
+ use RBF_interpolation
+ use vector_reconstruction
+#ifdef DO_PHYSICS
+ use module_physics_aquaplanet
+ use module_physics_control
+ use module_physics_init
+ use module_physics_manager
+#endif
+
+ implicit none
+
+ type (dm_info), intent(in):: dminfo
+ type (block_type), intent(inout) :: block
+ type (mesh_type), intent(inout) :: mesh
+ real (kind=RKIND), intent(in) :: dt
+
+
+ if (.not. config_do_restart) then
+ call init_coupled_diagnostics( block % state % time_levs(1) % state, block % diag, mesh)
+ call compute_solve_diagnostics(dt, block % state % time_levs(1) % state, block % diag, mesh)
+ end if
+ call rbfInterp_initialize(mesh)
+ call init_reconstruct(mesh)
+ call reconstruct(block % state % time_levs(1) % state, block % diag, mesh)
+
+ !
+ ! Note: The following initialization calls have been moved to mpas_setup_test_case()
+ ! since values computed by these routines are needed to produce initial fields
+ !
+ ! call initialize_advection_rk(mesh)
+ ! call initialize_deformation_weights(mesh)
+
+#ifdef DO_PHYSICS
+ !check that all the physics options are correctly defined and that at least one physics
+ !parameterization is called (using the logical moist_physics):
+ call physics_namelist_check
+
+ !proceed with initialization of physics parameterization if moist_physics is set to true:
+ if(moist_physics) then
+!initialization of all physics variables in registry:
+ call physics_registry_init(config_do_restart, mesh, block % diag_physics, block % tend_physics)
+ call physics_wrf_interface(mesh)
+ call physics_init(dminfo, mesh, block % state % time_levs(1) % state, block % diag_physics)
+
+!initialization of some surface variables (temporary):
+ call physics_aquaplanet_init(mesh, block % diag_physics)
+ endif
+#endif
+
+ if (.not. config_do_restart) block % state % time_levs(1) % state % xtime % scalar = 0.0
+
+ end subroutine mpas_init_block
+
+
+ subroutine mpas_core_run(domain, output_obj, output_frame)
+
+ use grid_types
+ use io_output
+ use timer
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+ type (io_output_object), intent(inout) :: output_obj
+ integer, intent(inout) :: output_frame
+
+ integer :: ntimesteps, itimestep
+ real (kind=RKIND) :: dt
+ type (block_type), pointer :: block_ptr
+
+ ! Eventually, dt should be domain specific
+ dt = config_dt
+ ntimesteps = config_ntimesteps
+
+ call write_output_frame(output_obj, output_frame, domain)
+
+ ! During integration, time level 1 stores the model state at the beginning of the
+ ! time step, and time level 2 stores the state advanced dt in time by timestep(...)
+ do itimestep = 1,ntimesteps
+ write(0,*) 'Doing timestep ', itimestep
+ call timer_start("time integration")
+ call mpas_timestep(domain, itimestep, dt)
+ call timer_stop("time integration")
+
+ ! Move time level 2 fields back into time level 1 for next time step
+ call shift_time_levels_state(domain % blocklist % state)
+
+ if (mod(itimestep, config_output_interval) == 0) then
+ call write_output_frame(output_obj, output_frame, domain)
+ end if
+ if (mod(itimestep, config_restart_interval) == 0 .and. config_restart_interval > 0) then
+ if (restart_frame == 1) call output_state_init(restart_obj, domain, "RESTART")
+ call output_state_for_domain(restart_obj, domain, restart_frame)
+ restart_frame = restart_frame + 1
+ end if
+ end do
+
+ end subroutine mpas_core_run
+
+
+ subroutine write_output_frame(output_obj, output_frame, domain)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Compute diagnostic fields for a domain and write model state to output file
+ !
+ ! Input/Output: domain - contains model state; diagnostic field are computed
+ ! before returning
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ use grid_types
+ use io_output
+
+ implicit none
+
+ integer, intent(inout) :: output_frame
+ 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
+ do while (associated(block_ptr))
+ call compute_output_diagnostics(block_ptr % state % time_levs(1) % state, block_ptr % mesh)
+ block_ptr => block_ptr % next
+ end do
+
+ call output_state_for_domain(output_obj, domain, output_frame)
+ output_frame = output_frame + 1
+
+ end subroutine write_output_frame
+
+
+ subroutine compute_output_diagnostics(state, grid)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Compute diagnostic fields for a domain
+ !
+ ! Input: state - contains model prognostic fields
+ ! grid - contains grid metadata
+ !
+ ! Output: state - upon returning, diagnostic fields will have be computed
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ use grid_types
+
+ implicit none
+
+ type (state_type), intent(inout) :: state
+ type (mesh_type), intent(in) :: grid
+
+ integer :: i, eoe
+ integer :: iEdge, k
+
+ end subroutine compute_output_diagnostics
+
+
+ subroutine mpas_timestep(domain, itimestep, dt)
+
+ use grid_types
+ use time_integration
+#ifdef DO_PHYSICS
+ use module_physics_control
+ use module_physics_driver
+ use module_physics_manager
+#endif
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+ integer, intent(in) :: itimestep
+ real (kind=RKIND), intent(in) :: dt
+
+#ifdef DO_PHYSICS
+ !proceed with physics if moist_physics is set to true:
+ if(moist_physics) then
+ call physics_timetracker(itimestep)
+ if(l_physics) call physics_driver(domain,itimestep)
+ endif
+#endif
+ call timestep(domain, dt, itimestep)
+
+ end subroutine mpas_timestep
+
+
+ subroutine mpas_core_finalize(domain)
+
+ use grid_types
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+
+ if (restart_frame > 1) call output_state_finalize(restart_obj, domain % dminfo)
+
+ end subroutine mpas_core_finalize
+
+end module mpas_core
Modified: branches/atmos_physics/src/core_ocean/Makefile
===================================================================
--- branches/atmos_physics/src/core_ocean/Makefile 2011-01-04 17:14:40 UTC (rev 672)
+++ branches/atmos_physics/src/core_ocean/Makefile 2011-01-05 00:56:27 UTC (rev 673)
@@ -1,6 +1,6 @@
.SUFFIXES: .F .o
-OBJS = module_core.o \
+OBJS = module_mpas_core.o \
module_test_cases.o \
module_advection.o \
module_time_integration.o \
@@ -19,7 +19,7 @@
module_global_diagnostics.o:
-module_core.o: module_advection.o module_global_diagnostics.o module_test_cases.o module_time_integration.o
+module_mpas_core.o: module_advection.o module_global_diagnostics.o module_test_cases.o module_time_integration.o
clean:
$(RM) *.o *.mod *.f90 libdycore.a
Modified: branches/atmos_physics/src/core_ocean/Registry
===================================================================
--- branches/atmos_physics/src/core_ocean/Registry 2011-01-04 17:14:40 UTC (rev 672)
+++ branches/atmos_physics/src/core_ocean/Registry 2011-01-05 00:56:27 UTC (rev 673)
@@ -7,9 +7,10 @@
namelist integer sw_model config_ntimesteps 7500
namelist integer sw_model config_output_interval 500
namelist integer sw_model config_stats_interval 100
-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_input_name grid.nc
+namelist character io config_output_name output.nc
+namelist character io config_restart_name restart.nc
+namelist character io config_decomp_file_prefix graph.info.part.
namelist integer restart config_restart_interval 0
namelist logical restart config_do_restart false
namelist real restart config_restart_time 172800.0
Deleted: branches/atmos_physics/src/core_ocean/module_core.F
===================================================================
--- branches/atmos_physics/src/core_ocean/module_core.F 2011-01-04 17:14:40 UTC (rev 672)
+++ branches/atmos_physics/src/core_ocean/module_core.F 2011-01-05 00:56:27 UTC (rev 673)
@@ -1,225 +0,0 @@
-module core
-
- use framework
-
- type (io_output_object) :: restart_obj
- integer :: restart_frame
-
-
- contains
-
-
- subroutine mpas_init(domain)
-
- use configure
- use grid_types
- use test_cases
-
- implicit none
-
- type (domain_type), intent(inout) :: domain
-
- real (kind=RKIND) :: dt
- type (block_type), pointer :: block
-
-
- if (.not. config_do_restart) call setup_sw_test_case(domain)
-
- !
- ! Initialize core
- !
- dt = config_dt
- block => domain % blocklist
- do while (associated(block))
- call mpas_init_block(block, block % mesh, dt)
- 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.
-
- ! call timer_start("global diagnostics")
- ! call computeGlobalDiagnostics(domain % dminfo, block % state % time_levs(1) % state, mesh, 0, dt)
- ! call timer_stop("global diagnostics")
- ! call output_state_init(output_obj, domain, "OUTPUT")
- ! call write_output_frame(output_obj, domain)
-
- restart_frame = 1
-
- end subroutine mpas_init
-
-
- subroutine mpas_init_block(block, mesh, dt)
-
- use grid_types
- use time_integration
- use RBF_interpolation
- use vector_reconstruction
-
- implicit none
-
- type (block_type), intent(inout) :: block
- type (mesh_type), intent(inout) :: mesh
- real (kind=RKIND), intent(in) :: dt
-
-
- call compute_solve_diagnostics(dt, block % state % time_levs(1) % state, mesh)
-
- call rbfInterp_initialize(mesh)
- call init_reconstruct(mesh)
- call reconstruct(block % state % time_levs(1) % state, block % diag, mesh)
-
- if (.not. config_do_restart) block % state % time_levs(1) % state % xtime % scalar = 0.0
-
- end subroutine mpas_init_block
-
-
- subroutine mpas_run(domain, output_obj, output_frame)
-
- use grid_types
- use io_output
- use timer
-
- implicit none
-
- type (domain_type), intent(inout) :: domain
- type (io_output_object), intent(inout) :: output_obj
- integer, intent(inout) :: output_frame
-
- integer :: ntimesteps, itimestep
- real (kind=RKIND) :: dt
- type (block_type), pointer :: block_ptr
-
- ! Eventually, dt should be domain specific
- dt = config_dt
- ntimesteps = config_ntimesteps
-
- call write_output_frame(output_obj, output_frame, domain)
-
- ! During integration, time level 1 stores the model state at the beginning of the
- ! time step, and time level 2 stores the state advanced dt in time by timestep(...)
- do itimestep = 1,ntimesteps
- write(0,*) 'Doing timestep ', itimestep
- call timer_start("time integration")
- call mpas_timestep(domain, itimestep, dt)
- call timer_stop("time integration")
-
- ! Move time level 2 fields back into time level 1 for next time step
- call shift_time_levels_state(domain % blocklist % state)
-
- if (mod(itimestep, config_output_interval) == 0) then
- call write_output_frame(output_obj, output_frame, domain)
- end if
- if (mod(itimestep, config_restart_interval) == 0 .and. config_restart_interval > 0) then
- if (restart_frame == 1) call output_state_init(restart_obj, domain, "RESTART")
- call output_state_for_domain(restart_obj, domain, restart_frame)
- restart_frame = restart_frame + 1
- end if
- end do
-
- end subroutine mpas_run
-
-
- subroutine write_output_frame(output_obj, output_frame, domain)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Compute diagnostic fields for a domain and write model state to output file
- !
- ! Input/Output: domain - contains model state; diagnostic field are computed
- ! before returning
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- use grid_types
- use io_output
-
- implicit none
-
- integer, intent(inout) :: output_frame
- 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
- do while (associated(block_ptr))
- call compute_output_diagnostics(block_ptr % state % time_levs(1) % state, block_ptr % mesh)
- block_ptr => block_ptr % next
- end do
-
- call output_state_for_domain(output_obj, domain, output_frame)
- output_frame = output_frame + 1
-
- end subroutine write_output_frame
-
-
- subroutine compute_output_diagnostics(state, grid)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Compute diagnostic fields for a domain
- !
- ! Input: state - contains model prognostic fields
- ! grid - contains grid metadata
- !
- ! Output: state - upon returning, diagnostic fields will have be computed
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- use grid_types
-
- implicit none
-
- type (state_type), intent(inout) :: state
- type (mesh_type), intent(in) :: grid
-
- integer :: i, eoe
- integer :: iEdge, k
-
- end subroutine compute_output_diagnostics
-
-
- subroutine mpas_timestep(domain, itimestep, dt)
-
- use grid_types
- use time_integration
- use timer
- use global_diagnostics
-
- implicit none
-
- type (domain_type), intent(inout) :: domain
- integer, intent(in) :: itimestep
- real (kind=RKIND), intent(in) :: dt
- type (block_type), pointer :: block_ptr
-
- call timestep(domain, dt)
-
- if (mod(itimestep, config_stats_interval) == 0) then
- block_ptr => domain % blocklist
- if(associated(block_ptr % next)) then
- write(0,*) 'Error: computeGlobalDiagnostics assumes ',&
- 'that there is only one block per processor.'
- end if
-
- call timer_start("global diagnostics")
- call computeGlobalDiagnostics(domain % dminfo, &
- block_ptr % state % time_levs(2) % state, block_ptr % mesh, &
- itimestep, dt)
- call timer_stop("global diagnostics")
- end if
-
- end subroutine mpas_timestep
-
-
- subroutine mpas_finalize(domain)
-
- use grid_types
-
- implicit none
-
- type (domain_type), intent(inout) :: domain
-
- if (restart_frame > 1) call output_state_finalize(restart_obj, domain % dminfo)
-
- end subroutine mpas_finalize
-
-end module core
Copied: branches/atmos_physics/src/core_ocean/module_mpas_core.F (from rev 667, branches/atmos_physics/src/core_ocean/module_core.F)
===================================================================
--- branches/atmos_physics/src/core_ocean/module_mpas_core.F (rev 0)
+++ branches/atmos_physics/src/core_ocean/module_mpas_core.F 2011-01-05 00:56:27 UTC (rev 673)
@@ -0,0 +1,225 @@
+module mpas_core
+
+ use mpas_framework
+
+ type (io_output_object) :: restart_obj
+ integer :: restart_frame
+
+
+ contains
+
+
+ subroutine mpas_core_init(domain)
+
+ use configure
+ use grid_types
+ use test_cases
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+
+ real (kind=RKIND) :: dt
+ type (block_type), pointer :: block
+
+
+ if (.not. config_do_restart) call setup_sw_test_case(domain)
+
+ !
+ ! Initialize core
+ !
+ dt = config_dt
+ block => domain % blocklist
+ do while (associated(block))
+ call mpas_init_block(block, block % mesh, dt)
+ 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.
+
+ ! call timer_start("global diagnostics")
+ ! call computeGlobalDiagnostics(domain % dminfo, block % state % time_levs(1) % state, mesh, 0, dt)
+ ! call timer_stop("global diagnostics")
+ ! call output_state_init(output_obj, domain, "OUTPUT")
+ ! call write_output_frame(output_obj, domain)
+
+ restart_frame = 1
+
+ end subroutine mpas_core_init
+
+
+ subroutine mpas_init_block(block, mesh, dt)
+
+ use grid_types
+ use time_integration
+ use RBF_interpolation
+ use vector_reconstruction
+
+ implicit none
+
+ type (block_type), intent(inout) :: block
+ type (mesh_type), intent(inout) :: mesh
+ real (kind=RKIND), intent(in) :: dt
+
+
+ call compute_solve_diagnostics(dt, block % state % time_levs(1) % state, mesh)
+
+ call rbfInterp_initialize(mesh)
+ call init_reconstruct(mesh)
+ call reconstruct(block % state % time_levs(1) % state, block % diag, mesh)
+
+ if (.not. config_do_restart) block % state % time_levs(1) % state % xtime % scalar = 0.0
+
+ end subroutine mpas_init_block
+
+
+ subroutine mpas_core_run(domain, output_obj, output_frame)
+
+ use grid_types
+ use io_output
+ use timer
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+ type (io_output_object), intent(inout) :: output_obj
+ integer, intent(inout) :: output_frame
+
+ integer :: ntimesteps, itimestep
+ real (kind=RKIND) :: dt
+ type (block_type), pointer :: block_ptr
+
+ ! Eventually, dt should be domain specific
+ dt = config_dt
+ ntimesteps = config_ntimesteps
+
+ call write_output_frame(output_obj, output_frame, domain)
+
+ ! During integration, time level 1 stores the model state at the beginning of the
+ ! time step, and time level 2 stores the state advanced dt in time by timestep(...)
+ do itimestep = 1,ntimesteps
+ write(0,*) 'Doing timestep ', itimestep
+ call timer_start("time integration")
+ call mpas_timestep(domain, itimestep, dt)
+ call timer_stop("time integration")
+
+ ! Move time level 2 fields back into time level 1 for next time step
+ call shift_time_levels_state(domain % blocklist % state)
+
+ if (mod(itimestep, config_output_interval) == 0) then
+ call write_output_frame(output_obj, output_frame, domain)
+ end if
+ if (mod(itimestep, config_restart_interval) == 0 .and. config_restart_interval > 0) then
+ if (restart_frame == 1) call output_state_init(restart_obj, domain, "RESTART")
+ call output_state_for_domain(restart_obj, domain, restart_frame)
+ restart_frame = restart_frame + 1
+ end if
+ end do
+
+ end subroutine mpas_core_run
+
+
+ subroutine write_output_frame(output_obj, output_frame, domain)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Compute diagnostic fields for a domain and write model state to output file
+ !
+ ! Input/Output: domain - contains model state; diagnostic field are computed
+ ! before returning
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ use grid_types
+ use io_output
+
+ implicit none
+
+ integer, intent(inout) :: output_frame
+ 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
+ do while (associated(block_ptr))
+ call compute_output_diagnostics(block_ptr % state % time_levs(1) % state, block_ptr % mesh)
+ block_ptr => block_ptr % next
+ end do
+
+ call output_state_for_domain(output_obj, domain, output_frame)
+ output_frame = output_frame + 1
+
+ end subroutine write_output_frame
+
+
+ subroutine compute_output_diagnostics(state, grid)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Compute diagnostic fields for a domain
+ !
+ ! Input: state - contains model prognostic fields
+ ! grid - contains grid metadata
+ !
+ ! Output: state - upon returning, diagnostic fields will have be computed
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ use grid_types
+
+ implicit none
+
+ type (state_type), intent(inout) :: state
+ type (mesh_type), intent(in) :: grid
+
+ integer :: i, eoe
+ integer :: iEdge, k
+
+ end subroutine compute_output_diagnostics
+
+
+ subroutine mpas_timestep(domain, itimestep, dt)
+
+ use grid_types
+ use time_integration
+ use timer
+ use global_diagnostics
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+ integer, intent(in) :: itimestep
+ real (kind=RKIND), intent(in) :: dt
+ type (block_type), pointer :: block_ptr
+
+ call timestep(domain, dt)
+
+ if (mod(itimestep, config_stats_interval) == 0) then
+ block_ptr => domain % blocklist
+ if(associated(block_ptr % next)) then
+ write(0,*) 'Error: computeGlobalDiagnostics assumes ',&
+ 'that there is only one block per processor.'
+ end if
+
+ call timer_start("global diagnostics")
+ call computeGlobalDiagnostics(domain % dminfo, &
+ block_ptr % state % time_levs(2) % state, block_ptr % mesh, &
+ itimestep, dt)
+ call timer_stop("global diagnostics")
+ end if
+
+ end subroutine mpas_timestep
+
+
+ subroutine mpas_core_finalize(domain)
+
+ use grid_types
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+
+ if (restart_frame > 1) call output_state_finalize(restart_obj, domain % dminfo)
+
+ end subroutine mpas_core_finalize
+
+end module mpas_core
Modified: branches/atmos_physics/src/core_sw/Makefile
===================================================================
--- branches/atmos_physics/src/core_sw/Makefile 2011-01-04 17:14:40 UTC (rev 672)
+++ branches/atmos_physics/src/core_sw/Makefile 2011-01-05 00:56:27 UTC (rev 673)
@@ -1,6 +1,6 @@
.SUFFIXES: .F .o
-OBJS = module_core.o \
+OBJS = module_mpas_core.o \
module_test_cases.o \
module_advection.o \
module_time_integration.o \
@@ -19,7 +19,7 @@
module_global_diagnostics.o:
-module_core.o: module_global_diagnostics.o module_test_cases.o module_time_integration.o module_advection.o
+module_mpas_core.o: module_global_diagnostics.o module_test_cases.o module_time_integration.o module_advection.o
clean:
$(RM) *.o *.mod *.f90 libdycore.a
Modified: branches/atmos_physics/src/core_sw/Registry
===================================================================
--- branches/atmos_physics/src/core_sw/Registry 2011-01-04 17:14:40 UTC (rev 672)
+++ branches/atmos_physics/src/core_sw/Registry 2011-01-05 00:56:27 UTC (rev 673)
@@ -13,9 +13,10 @@
namelist logical sw_model config_positive_definite false
namelist logical sw_model config_monotonic false
namelist real sw_model config_apvm_upwinding 0.5
-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_input_name grid.nc
+namelist character io config_output_name output.nc
+namelist character io config_restart_name restart.nc
+namelist character io config_decomp_file_prefix graph.info.part.
namelist integer restart config_restart_interval 0
namelist logical restart config_do_restart false
namelist real restart config_restart_time 172800.0
Deleted: branches/atmos_physics/src/core_sw/module_core.F
===================================================================
--- branches/atmos_physics/src/core_sw/module_core.F 2011-01-04 17:14:40 UTC (rev 672)
+++ branches/atmos_physics/src/core_sw/module_core.F 2011-01-05 00:56:27 UTC (rev 673)
@@ -1,217 +0,0 @@
-module core
-
- use framework
-
- type (io_output_object) :: restart_obj
- integer :: restart_frame
-
-
- contains
-
-
- subroutine mpas_init(domain)
-
- use configure
- use grid_types
- use test_cases
-
- implicit none
-
- type (domain_type), intent(inout) :: domain
-
- real (kind=RKIND) :: dt
- type (block_type), pointer :: block
-
-
- if (.not. config_do_restart) call setup_sw_test_case(domain)
-
- !
- ! Initialize core
- !
- dt = config_dt
- block => domain % blocklist
- do while (associated(block))
- call mpas_init_block(block, block % mesh, dt)
- block => block % next
- end do
-
- restart_frame = 1
-
- end subroutine mpas_init
-
-
- subroutine mpas_init_block(block, mesh, dt)
-
- use grid_types
- use time_integration
- use RBF_interpolation
- use vector_reconstruction
-
- implicit none
-
- type (block_type), intent(inout) :: block
- type (mesh_type), intent(inout) :: mesh
- real (kind=RKIND), intent(in) :: dt
-
-
- call compute_solve_diagnostics(dt, block % state % time_levs(1) % state, mesh)
-
- call rbfInterp_initialize(mesh)
- call init_reconstruct(mesh)
- call reconstruct(block % state % time_levs(1) % state, block % diag, mesh)
-
- if (.not. config_do_restart) block % state % time_levs(1) % state % xtime % scalar = 0.0
-
- end subroutine mpas_init_block
-
-
- subroutine mpas_run(domain, output_obj, output_frame)
-
- use grid_types
- use io_output
- use timer
-
- implicit none
-
- type (domain_type), intent(inout) :: domain
- type (io_output_object), intent(inout) :: output_obj
- integer, intent(inout) :: output_frame
-
- integer :: ntimesteps, itimestep
- real (kind=RKIND) :: dt
- type (block_type), pointer :: block_ptr
-
- ! Eventually, dt should be domain specific
- dt = config_dt
- ntimesteps = config_ntimesteps
-
- call write_output_frame(output_obj, output_frame, domain)
-
- ! During integration, time level 1 stores the model state at the beginning of the
- ! time step, and time level 2 stores the state advanced dt in time by timestep(...)
- do itimestep = 1,ntimesteps
- write(0,*) 'Doing timestep ', itimestep
- call timer_start("time integration")
- call mpas_timestep(domain, itimestep, dt)
- call timer_stop("time integration")
-
- ! Move time level 2 fields back into time level 1 for next time step
- call shift_time_levels_state(domain % blocklist % state)
-
- if (mod(itimestep, config_output_interval) == 0) then
- call write_output_frame(output_obj, output_frame, domain)
- end if
- if (mod(itimestep, config_restart_interval) == 0 .and. config_restart_interval > 0) then
- if (restart_frame == 1) call output_state_init(restart_obj, domain, "RESTART")
- call output_state_for_domain(restart_obj, domain, restart_frame)
- restart_frame = restart_frame + 1
- end if
- end do
-
- end subroutine mpas_run
-
-
- subroutine write_output_frame(output_obj, output_frame, domain)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Compute diagnostic fields for a domain and write model state to output file
- !
- ! Input/Output: domain - contains model state; diagnostic field are computed
- ! before returning
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- use grid_types
- use io_output
-
- implicit none
-
- integer, intent(inout) :: output_frame
- 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
- do while (associated(block_ptr))
- call compute_output_diagnostics(block_ptr % state % time_levs(1) % state, block_ptr % mesh)
- block_ptr => block_ptr % next
- end do
-
- call output_state_for_domain(output_obj, domain, output_frame)
- output_frame = output_frame + 1
-
- end subroutine write_output_frame
-
-
- subroutine compute_output_diagnostics(state, grid)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Compute diagnostic fields for a domain
- !
- ! Input: state - contains model prognostic fields
- ! grid - contains grid metadata
- !
- ! Output: state - upon returning, diagnostic fields will have be computed
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- use grid_types
-
- implicit none
-
- type (state_type), intent(inout) :: state
- type (mesh_type), intent(in) :: grid
-
- integer :: i, eoe
- integer :: iEdge, k
-
- end subroutine compute_output_diagnostics
-
-
- subroutine mpas_timestep(domain, itimestep, dt)
-
- use grid_types
- use time_integration
- use timer
- use global_diagnostics
-
- implicit none
-
- type (domain_type), intent(inout) :: domain
- integer, intent(in) :: itimestep
- real (kind=RKIND), intent(in) :: dt
- type (block_type), pointer :: block_ptr
-
- call timestep(domain, dt)
-
- if(config_stats_interval .gt. 0) then
- if(mod(itimestep, config_stats_interval) == 0) then
- block_ptr => domain % blocklist
- if(associated(block_ptr % next)) then
- write(0,*) 'Error: computeGlobalDiagnostics assumes ',&
- 'that there is only one block per processor.'
- end if
-
- call timer_start("global_diagnostics")
- call computeGlobalDiagnostics(domain % dminfo, &
- block_ptr % state % time_levs(2) % state, block_ptr % mesh, &
- itimestep, dt)
- call timer_stop("global_diagnostics")
- end if
- end if
-
- end subroutine mpas_timestep
-
-
- subroutine mpas_finalize(domain)
-
- use grid_types
-
- implicit none
-
- type (domain_type), intent(inout) :: domain
-
- if (restart_frame > 1) call output_state_finalize(restart_obj, domain % dminfo)
-
- end subroutine mpas_finalize
-
-end module core
Copied: branches/atmos_physics/src/core_sw/module_mpas_core.F (from rev 667, branches/atmos_physics/src/core_sw/module_core.F)
===================================================================
--- branches/atmos_physics/src/core_sw/module_mpas_core.F (rev 0)
+++ branches/atmos_physics/src/core_sw/module_mpas_core.F 2011-01-05 00:56:27 UTC (rev 673)
@@ -0,0 +1,217 @@
+module mpas_core
+
+ use mpas_framework
+
+ type (io_output_object) :: restart_obj
+ integer :: restart_frame
+
+
+ contains
+
+
+ subroutine mpas_core_init(domain)
+
+ use configure
+ use grid_types
+ use test_cases
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+
+ real (kind=RKIND) :: dt
+ type (block_type), pointer :: block
+
+
+ if (.not. config_do_restart) call setup_sw_test_case(domain)
+
+ !
+ ! Initialize core
+ !
+ dt = config_dt
+ block => domain % blocklist
+ do while (associated(block))
+ call mpas_init_block(block, block % mesh, dt)
+ block => block % next
+ end do
+
+ restart_frame = 1
+
+ end subroutine mpas_core_init
+
+
+ subroutine mpas_init_block(block, mesh, dt)
+
+ use grid_types
+ use time_integration
+ use RBF_interpolation
+ use vector_reconstruction
+
+ implicit none
+
+ type (block_type), intent(inout) :: block
+ type (mesh_type), intent(inout) :: mesh
+ real (kind=RKIND), intent(in) :: dt
+
+
+ call compute_solve_diagnostics(dt, block % state % time_levs(1) % state, mesh)
+
+ call rbfInterp_initialize(mesh)
+ call init_reconstruct(mesh)
+ call reconstruct(block % state % time_levs(1) % state, block % diag, mesh)
+
+ if (.not. config_do_restart) block % state % time_levs(1) % state % xtime % scalar = 0.0
+
+ end subroutine mpas_init_block
+
+
+ subroutine mpas_core_run(domain, output_obj, output_frame)
+
+ use grid_types
+ use io_output
+ use timer
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+ type (io_output_object), intent(inout) :: output_obj
+ integer, intent(inout) :: output_frame
+
+ integer :: ntimesteps, itimestep
+ real (kind=RKIND) :: dt
+ type (block_type), pointer :: block_ptr
+
+ ! Eventually, dt should be domain specific
+ dt = config_dt
+ ntimesteps = config_ntimesteps
+
+ call write_output_frame(output_obj, output_frame, domain)
+
+ ! During integration, time level 1 stores the model state at the beginning of the
+ ! time step, and time level 2 stores the state advanced dt in time by timestep(...)
+ do itimestep = 1,ntimesteps
+ write(0,*) 'Doing timestep ', itimestep
+ call timer_start("time integration")
+ call mpas_timestep(domain, itimestep, dt)
+ call timer_stop("time integration")
+
+ ! Move time level 2 fields back into time level 1 for next time step
+ call shift_time_levels_state(domain % blocklist % state)
+
+ if (mod(itimestep, config_output_interval) == 0) then
+ call write_output_frame(output_obj, output_frame, domain)
+ end if
+ if (mod(itimestep, config_restart_interval) == 0 .and. config_restart_interval > 0) then
+ if (restart_frame == 1) call output_state_init(restart_obj, domain, "RESTART")
+ call output_state_for_domain(restart_obj, domain, restart_frame)
+ restart_frame = restart_frame + 1
+ end if
+ end do
+
+ end subroutine mpas_core_run
+
+
+ subroutine write_output_frame(output_obj, output_frame, domain)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Compute diagnostic fields for a domain and write model state to output file
+ !
+ ! Input/Output: domain - contains model state; diagnostic field are computed
+ ! before returning
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ use grid_types
+ use io_output
+
+ implicit none
+
+ integer, intent(inout) :: output_frame
+ 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
+ do while (associated(block_ptr))
+ call compute_output_diagnostics(block_ptr % state % time_levs(1) % state, block_ptr % mesh)
+ block_ptr => block_ptr % next
+ end do
+
+ call output_state_for_domain(output_obj, domain, output_frame)
+ output_frame = output_frame + 1
+
+ end subroutine write_output_frame
+
+
+ subroutine compute_output_diagnostics(state, grid)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Compute diagnostic fields for a domain
+ !
+ ! Input: state - contains model prognostic fields
+ ! grid - contains grid metadata
+ !
+ ! Output: state - upon returning, diagnostic fields will have be computed
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ use grid_types
+
+ implicit none
+
+ type (state_type), intent(inout) :: state
+ type (mesh_type), intent(in) :: grid
+
+ integer :: i, eoe
+ integer :: iEdge, k
+
+ end subroutine compute_output_diagnostics
+
+
+ subroutine mpas_timestep(domain, itimestep, dt)
+
+ use grid_types
+ use time_integration
+ use timer
+ use global_diagnostics
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+ integer, intent(in) :: itimestep
+ real (kind=RKIND), intent(in) :: dt
+ type (block_type), pointer :: block_ptr
+
+ call timestep(domain, dt)
+
+ if(config_stats_interval .gt. 0) then
+ if(mod(itimestep, config_stats_interval) == 0) then
+ block_ptr => domain % blocklist
+ if(associated(block_ptr % next)) then
+ write(0,*) 'Error: computeGlobalDiagnostics assumes ',&
+ 'that there is only one block per processor.'
+ end if
+
+ call timer_start("global_diagnostics")
+ call computeGlobalDiagnostics(domain % dminfo, &
+ block_ptr % state % time_levs(2) % state, block_ptr % mesh, &
+ itimestep, dt)
+ call timer_stop("global_diagnostics")
+ end if
+ end if
+
+ end subroutine mpas_timestep
+
+
+ subroutine mpas_core_finalize(domain)
+
+ use grid_types
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+
+ if (restart_frame > 1) call output_state_finalize(restart_obj, domain % dminfo)
+
+ end subroutine mpas_core_finalize
+
+end module mpas_core
Modified: branches/atmos_physics/src/core_sw/module_time_integration.F
===================================================================
--- branches/atmos_physics/src/core_sw/module_time_integration.F 2011-01-04 17:14:40 UTC (rev 672)
+++ branches/atmos_physics/src/core_sw/module_time_integration.F 2011-01-05 00:56:27 UTC (rev 673)
@@ -779,16 +779,10 @@
!
circulation(:,:) = 0.0
do iEdge=1,nEdges
- if (verticesOnEdge(1,iEdge) <= nVertices) then
- do k=1,nVertLevels
- circulation(k,verticesOnEdge(1,iEdge)) = circulation(k,verticesOnEdge(1,iEdge)) - dcEdge(iEdge) * u(k,iEdge)
- end do
- end if
- if (verticesOnEdge(2,iEdge) <= nVertices) then
- do k=1,nVertLevels
- circulation(k,verticesOnEdge(2,iEdge)) = circulation(k,verticesOnEdge(2,iEdge)) + dcEdge(iEdge) * u(k,iEdge)
- end do
- end if
+ do k=1,nVertLevels
+ circulation(k,verticesOnEdge(1,iEdge)) = circulation(k,verticesOnEdge(1,iEdge)) - dcEdge(iEdge) * u(k,iEdge)
+ circulation(k,verticesOnEdge(2,iEdge)) = circulation(k,verticesOnEdge(2,iEdge)) + dcEdge(iEdge) * u(k,iEdge)
+ end do
end do
do iVertex=1,nVertices
do k=1,nVertLevels
@@ -845,11 +839,9 @@
do iEdge = 1,nEdges
do i=1,nEdgesOnEdge(iEdge)
eoe = edgesOnEdge(i,iEdge)
- if (eoe <= nEdges) then
- do k = 1,nVertLevels
- v(k,iEdge) = v(k,iEdge) + weightsOnEdge(i,iEdge) * u(k, eoe)
- end do
- end if
+ do k = 1,nVertLevels
+ v(k,iEdge) = v(k,iEdge) + weightsOnEdge(i,iEdge) * u(k, eoe)
+ end do
end do
end do
@@ -902,20 +894,19 @@
!
! Compute pv at the edges
- ! ( this computes pv_edge at all edges bounding real cells and distance-1 ghost cells )
+ ! ( this computes pv_edge at all edges bounding real cells )
!
pv_edge(:,:) = 0.0
do iVertex = 1,nVertices
do i=1,grid % vertexDegree
- iEdge = edgesOnVertex(i,iVertex)
- if(iEdge <= nEdges) then
- do k=1,nVertLevels
+ iEdge = edgesOnVertex(i,iVertex)
+ do k=1,nVertLevels
pv_edge(k,iEdge) = pv_edge(k,iEdge) + 0.5 * pv_vertex(k,iVertex)
- enddo
- endif
+ end do
end do
end do
+
!
! Modify PV edge with upstream bias.
!
Modified: branches/atmos_physics/src/driver/Makefile
===================================================================
--- branches/atmos_physics/src/driver/Makefile 2011-01-04 17:14:40 UTC (rev 672)
+++ branches/atmos_physics/src/driver/Makefile 2011-01-05 00:56:27 UTC (rev 673)
@@ -1,13 +1,13 @@
.SUFFIXES: .F .o
-OBJS = module_subdriver.o \
+OBJS = module_mpas_subdriver.o \
mpas.o
all: $(OBJS)
-module_subdriver.o:
+module_mpas_subdriver.o:
-mpas.o: module_subdriver.o
+mpas.o: module_mpas_subdriver.o
clean:
$(RM) *.o *.mod *.f90
Copied: branches/atmos_physics/src/driver/module_mpas_subdriver.F (from rev 667, branches/atmos_physics/src/driver/module_subdriver.F)
===================================================================
--- branches/atmos_physics/src/driver/module_mpas_subdriver.F (rev 0)
+++ branches/atmos_physics/src/driver/module_mpas_subdriver.F 2011-01-05 00:56:27 UTC (rev 673)
@@ -0,0 +1,86 @@
+module mpas_subdriver
+
+ use mpas_framework
+ use mpas_core
+
+ type (dm_info), pointer :: dminfo
+ type (domain_type), pointer :: domain
+ type (io_output_object) :: output_obj
+ integer :: output_frame
+
+
+ contains
+
+
+ subroutine mpas_init()
+
+ implicit none
+
+ real (kind=RKIND) :: dt
+
+ call timer_start("total time")
+ call timer_start("initialize")
+
+
+ !
+ ! Initialize infrastructure
+ !
+ call mpas_framework_init(dminfo, domain)
+
+
+ call input_state_for_domain(domain)
+
+
+ !
+ ! Initialize core
+ !
+ call mpas_core_init(domain)
+
+ call timer_stop("initialize")
+
+
+ !
+ ! Set up output streams to be written to by the MPAS core
+ !
+ output_frame = 1
+ call output_state_init(output_obj, domain, "OUTPUT")
+
+ end subroutine mpas_init
+
+
+ subroutine mpas_run()
+
+ implicit none
+
+ call mpas_core_run(domain, output_obj, output_frame)
+
+ end subroutine mpas_run
+
+
+ subroutine mpas_finalize()
+
+ implicit none
+
+ !
+ ! Finalize output streams
+ !
+ call output_state_finalize(output_obj, domain % dminfo)
+
+
+ !
+ ! Finalize core
+ !
+ call mpas_core_finalize(domain)
+
+ call timer_stop("total time")
+ call timer_write()
+
+
+ !
+ ! Finalize infrastructure
+ !
+ call mpas_framework_finalize(dminfo, domain)
+
+ end subroutine mpas_finalize
+
+end module mpas_subdriver
Deleted: branches/atmos_physics/src/driver/module_subdriver.F
===================================================================
--- branches/atmos_physics/src/driver/module_subdriver.F 2011-01-04 17:14:40 UTC (rev 672)
+++ branches/atmos_physics/src/driver/module_subdriver.F 2011-01-05 00:56:27 UTC (rev 673)
@@ -1,86 +0,0 @@
-module subdriver
-
- use framework
- use core
-
- type (dm_info), pointer :: dminfo
- type (domain_type), pointer :: domain
- type (io_output_object) :: output_obj
- integer :: output_frame
-
-
- contains
-
-
- subroutine init()
-
- implicit none
-
- real (kind=RKIND) :: dt
-
- call timer_start("total time")
- call timer_start("initialize")
-
-
- !
- ! Initialize infrastructure
- !
- call framework_init(dminfo, domain)
-
-
- call input_state_for_domain(domain)
-
-
- !
- ! Initialize core
- !
- call mpas_init(domain)
-
- call timer_stop("initialize")
-
-
- !
- ! Set up output streams to be written to by the MPAS core
- !
- output_frame = 1
- call output_state_init(output_obj, domain, "OUTPUT")
-
- end subroutine init
-
-
- subroutine run()
-
- implicit none
-
- call mpas_run(domain, output_obj, output_frame)
-
- end subroutine run
-
-
- subroutine finalize()
-
- implicit none
-
- !
- ! Finalize output streams
- !
- call output_state_finalize(output_obj, domain % dminfo)
-
-
- !
- ! Finalize core
- !
- call mpas_finalize(domain)
-
- call timer_stop("total time")
- call timer_write()
-
-
- !
- ! Finalize infrastructure
- !
- call framework_finalize(dminfo, domain)
-
- end subroutine finalize
-
-end module subdriver
Modified: branches/atmos_physics/src/driver/mpas.F
===================================================================
--- branches/atmos_physics/src/driver/mpas.F 2011-01-04 17:14:40 UTC (rev 672)
+++ branches/atmos_physics/src/driver/mpas.F 2011-01-05 00:56:27 UTC (rev 673)
@@ -1,14 +1,14 @@
program mpas
- use subdriver
+ use mpas_subdriver
implicit none
- call init()
+ call mpas_init()
- call run()
+ call mpas_run()
- call finalize()
+ call mpas_finalize()
stop
Modified: branches/atmos_physics/src/framework/Makefile
===================================================================
--- branches/atmos_physics/src/framework/Makefile 2011-01-04 17:14:40 UTC (rev 672)
+++ branches/atmos_physics/src/framework/Makefile 2011-01-05 00:56:27 UTC (rev 673)
@@ -4,7 +4,7 @@
ZOLTANOBJ = module_zoltan_interface.o
endif
-OBJS = module_framework.o \
+OBJS = module_mpas_framework.o \
module_timer.o \
module_configure.o \
module_constants.o \
@@ -23,7 +23,7 @@
framework: $(OBJS)
ar -ru libframework.a $(OBJS)
-module_framework.o: module_dmpar.o module_io_input.o module_io_output.o module_grid_types.o module_configure.o module_timer.o
+module_mpas_framework.o: module_dmpar.o module_io_input.o module_io_output.o module_grid_types.o module_configure.o module_timer.o
module_configure.o: module_dmpar.o
@@ -31,7 +31,7 @@
module_dmpar.o: module_sort.o streams.o
-module_block_decomp.o: module_grid_types.o module_hash.o
+module_block_decomp.o: module_grid_types.o module_hash.o module_configure.o
module_io_input.o: module_grid_types.o module_dmpar.o module_block_decomp.o module_sort.o module_configure.o $(ZOLTANOBJ)
Modified: branches/atmos_physics/src/framework/module_block_decomp.F
===================================================================
--- branches/atmos_physics/src/framework/module_block_decomp.F 2011-01-04 17:14:40 UTC (rev 672)
+++ branches/atmos_physics/src/framework/module_block_decomp.F 2011-01-05 00:56:27 UTC (rev 673)
@@ -18,6 +18,8 @@
subroutine block_decomp_cells_for_proc(dminfo, partial_global_graph_info, local_cell_list)
+ use configure
+
implicit none
type (dm_info), intent(in) :: dminfo
@@ -41,15 +43,15 @@
iunit = 50 + dminfo % my_proc_id
if (dminfo % nprocs < 10) then
- write(filename,'(a,i1)') 'graph.info.part.', dminfo % nprocs
+ write(filename,'(a,i1)') trim(config_decomp_file_prefix), dminfo % nprocs
else if (dminfo % nprocs < 100) then
- write(filename,'(a,i2)') 'graph.info.part.', dminfo % nprocs
+ write(filename,'(a,i2)') trim(config_decomp_file_prefix), dminfo % nprocs
else if (dminfo % nprocs < 1000) then
- write(filename,'(a,i3)') 'graph.info.part.', dminfo % nprocs
+ write(filename,'(a,i3)') trim(config_decomp_file_prefix), dminfo % nprocs
else if (dminfo % nprocs < 10000) then
- write(filename,'(a,i4)') 'graph.info.part.', dminfo % nprocs
+ write(filename,'(a,i4)') trim(config_decomp_file_prefix), dminfo % nprocs
else if (dminfo % nprocs < 100000) then
- write(filename,'(a,i5)') 'graph.info.part.', dminfo % nprocs
+ write(filename,'(a,i5)') trim(config_decomp_file_prefix), dminfo % nprocs
end if
open(unit=iunit, file=trim(filename), form='formatted', status='old', iostat=istatus)
Deleted: branches/atmos_physics/src/framework/module_framework.F
===================================================================
--- branches/atmos_physics/src/framework/module_framework.F 2011-01-04 17:14:40 UTC (rev 672)
+++ branches/atmos_physics/src/framework/module_framework.F 2011-01-05 00:56:27 UTC (rev 673)
@@ -1,44 +0,0 @@
-module framework
-
- use dmpar
- use grid_types
- use io_input
- use io_output
- use configure
- use timer
-
-
- contains
-
-
- subroutine framework_init(dminfo, domain)
-
- implicit none
-
- type (dm_info), pointer :: dminfo
- type (domain_type), pointer :: domain
-
- allocate(dminfo)
- call dmpar_init(dminfo)
-
- call read_namelist(dminfo)
-
- call allocate_domain(domain, dminfo)
-
- end subroutine framework_init
-
-
- subroutine framework_finalize(dminfo, domain)
-
- implicit none
-
- type (dm_info), pointer :: dminfo
- type (domain_type), pointer :: domain
-
- call deallocate_domain(domain)
-
- call dmpar_finalize(dminfo)
-
- end subroutine framework_finalize
-
-end module framework
Copied: branches/atmos_physics/src/framework/module_mpas_framework.F (from rev 667, branches/atmos_physics/src/framework/module_framework.F)
===================================================================
--- branches/atmos_physics/src/framework/module_mpas_framework.F (rev 0)
+++ branches/atmos_physics/src/framework/module_mpas_framework.F 2011-01-05 00:56:27 UTC (rev 673)
@@ -0,0 +1,44 @@
+module mpas_framework
+
+ use dmpar
+ use grid_types
+ use io_input
+ use io_output
+ use configure
+ use timer
+
+
+ contains
+
+
+ subroutine mpas_framework_init(dminfo, domain)
+
+ implicit none
+
+ type (dm_info), pointer :: dminfo
+ type (domain_type), pointer :: domain
+
+ allocate(dminfo)
+ call dmpar_init(dminfo)
+
+ call read_namelist(dminfo)
+
+ call allocate_domain(domain, dminfo)
+
+ end subroutine mpas_framework_init
+
+
+ subroutine mpas_framework_finalize(dminfo, domain)
+
+ implicit none
+
+ type (dm_info), pointer :: dminfo
+ type (domain_type), pointer :: domain
+
+ call deallocate_domain(domain)
+
+ call dmpar_finalize(dminfo)
+
+ end subroutine mpas_framework_finalize
+
+end module mpas_framework
</font>
</pre>