<p><b>gaw06e@fsu.edu</b> 2011-04-29 12:46:19 -0600 (Fri, 29 Apr 2011)</p><p>- Initial import<br>
</p><hr noshade><pre><font color="gray">Added: branches/ocean_projects/triangle_border_swm/Makefile
===================================================================
--- branches/ocean_projects/triangle_border_swm/Makefile (rev 0)
+++ branches/ocean_projects/triangle_border_swm/Makefile 2011-04-29 18:46:19 UTC (rev 810)
@@ -0,0 +1,203 @@
+#MODEL_FORMULATION = -DNCAR_FORMULATION
+MODEL_FORMULATION = -DLANL_FORMULATION
+
+FILE_OFFSET = -DOFFSET64BIT
+
+#########################
+# Section for Zoltan TPL
+#########################
+ifdef ZOLTAN_HOME
+ ZOLTAN_DEFINE = -DHAVE_ZOLTAN
+endif
+#########################
+
+
+dummy:
+ @( echo "try one of:"; \
+ echo " make xlf"; \
+ echo " make pgi"; \
+ echo " make ifort"; \
+ echo " make gfortran"; \
+ )
+
+xlf:
+ ( make all \
+ "FC = mpxlf90" \
+ "CC = mpcc" \
+ "SFC = xlf90" \
+ "SCC = xlc" \
+ "FFLAGS = -qrealsize=8 -g -C " \
+ "CFLAGS = -g" \
+ "LDFLAGS = -g -C" \
+ "CORE = $(CORE)" \
+ "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) -D_MPI $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
+
+ftn:
+ ( make all \
+ "FC = ftn" \
+ "CC = cc" \
+ "SFC = ftn" \
+ "SCC = cc" \
+ "FFLAGS = -i4 -r8 -gopt -O2 -Mvect=nosse -Kieee -convert big_endian" \
+ "CFLAGS = -fast" \
+ "LDFLAGS = " \
+ "CORE = $(CORE)" \
+ "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
+
+pgi:
+ ( make all \
+ "FC = mpif90" \
+ "CC = mpicc" \
+ "SFC = pgf90" \
+ "SCC = pgcc" \
+ "FFLAGS = -r8 -O3 -byteswapio" \
+ "CFLAGS = -O3" \
+ "LDFLAGS = -O3" \
+ "CORE = $(CORE)" \
+ "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
+
+pgi-llnl:
+ ( make all \
+ "FC = mpipgf90" \
+ "CC = pgcc" \
+ "SFC = pgf90" \
+ "SCC = pgcc" \
+ "FFLAGS = -i4 -r8 -g -O2 -byteswapio" \
+ "CFLAGS = -fast" \
+ "LDFLAGS = " \
+ "CORE = $(CORE)" \
+ "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
+
+pgi-serial:
+ ( make all \
+ "FC = pgf90" \
+ "CC = pgcc" \
+ "SFC = pgf90" \
+ "SCC = pgcc" \
+ "FFLAGS = -r8 -O0 -g -Mbounds -Mchkptr -byteswapio" \
+ "CFLAGS = -O0 -g" \
+ "LDFLAGS = -O0 -g -Mbounds -Mchkptr" \
+ "CORE = $(CORE)" \
+ "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) -DUNDERSCORE $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
+
+ifort:
+ ( make all \
+ "FC = mpif90" \
+ "CC = gcc" \
+ "SFC = ifort" \
+ "SCC = gcc" \
+ "FFLAGS = -real-size 64 -O3 -convert big_endian" \
+ "CFLAGS = -O3 -m64" \
+ "LDFLAGS = -O3" \
+ "CORE = $(CORE)" \
+ "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE -m64 $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
+
+gfortran:
+ ( make all \
+ "FC = mpif90" \
+ "CC = mpicc" \
+ "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) -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) $(EXPAND_LEVELS) -DUNDERSCORE -m64 $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
+
+g95:
+ ( make all \
+ "FC = mpif90" \
+ "CC = mpicc" \
+ "SFC = g95" \
+ "SCC = gcc" \
+ "FFLAGS = -O3 -ffree-line-length-huge -r8 -fendian=big" \
+ "CFLAGS = -O3" \
+ "LDFLAGS = -O3" \
+ "CORE = $(CORE)" \
+ "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
+
+g95-serial:
+ ( make all \
+ "FC = g95" \
+ "CC = gcc" \
+ "SFC = g95" \
+ "SCC = gcc" \
+ "FFLAGS = -O3 -ffree-line-length-huge -r8 -fendian=big" \
+ "CFLAGS = -O3" \
+ "LDFLAGS = -O3" \
+ "CORE = $(CORE)" \
+ "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) -DUNDERSCORE $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
+
+
+CPPINCLUDES = -I../inc -I$(NETCDF)/include
+FCINCLUDES = -I../inc -I$(NETCDF)/include
+LIBS = -L$(NETCDF)/lib -lnetcdf
+
+RM = rm -f
+CPP = cpp -C -P -traditional
+RANLIB = ranlib
+
+#########################
+# Section for Zoltan TPL
+#########################
+ifdef ZOLTAN_HOME
+ ifdef ZOLTAN_INC_PATH
+ FCINCLUDES += -I$(ZOLTAN_INC_PATH)
+ else
+ FCINCLUDES += -I$(ZOLTAN_HOME)/include
+ endif
+
+ ifdef ZOLTAN_LIB_PATH
+ LIBS += -L$(ZOLTAN_LIB_PATH) -lzoltan
+ else
+ LIBS += -L$(ZOLTAN_HOME)/lib -lzoltan
+ endif
+endif
+#########################
+
+
+ifdef CORE
+
+all: mpas_main
+
+mpas_main:
+ cd src; make FC="$(FC)" \
+ CC="$(CC)" \
+ CFLAGS="$(CFLAGS)" \
+ FFLAGS="$(FFLAGS)" \
+ LDFLAGS="$(LDFLAGS)" \
+ RM="$(RM)" \
+ CPP="$(CPP)" \
+ CPPFLAGS="$(CPPFLAGS)" \
+ LIBS="$(LIBS)" \
+ CPPINCLUDES="$(CPPINCLUDES)" \
+ FCINCLUDES="$(FCINCLUDES)" \
+ CORE="$(CORE)"
+ if [ ! -e $(CORE)_model.exe ]; then ln -s src/$(CORE)_model.exe .; fi
+
+clean:
+ cd src; make clean RM="$(RM)" CORE="$(CORE)"
+ $(RM) $(CORE)_model.exe
+
+else
+
+all: errmsg
+clean: errmsg
+errmsg:
+ @echo "************ ERROR ************"
+ @echo "No CORE specified. Quitting."
+ @echo "************ ERROR ************"
+
+endif
Added: branches/ocean_projects/triangle_border_swm/README
===================================================================
--- branches/ocean_projects/triangle_border_swm/README (rev 0)
+++ branches/ocean_projects/triangle_border_swm/README 2011-04-29 18:46:19 UTC (rev 810)
@@ -0,0 +1,146 @@
+swmodel: A 2d shallow water model on a C-grid staggering.
+
+2 Sept 2009 -- Long overdue update to this readme.
+
+21 May 2009 -- Added vertical dimension (currently fixed at 1) and 3d scalar array dimensioned
+ (nTracers,nVertLevels,nCells).
+ Pushed loop over blocks down into RK4 time integration; now each RK step loops
+ over blocks, and ghost-cell updates can be performed between steps.
+ Temporary storage for intermediate RK steps is allocated once when a block is created
+ Various other re-arrangements to code.
+
+15 May 2009 -- The "h" field is now consistently treated as fluid thickness.
+ Fixed the computation of "vh".
+ Added kiteAreasOnVertex and separate fEdge and fVertex fields to input files.
+ Two formulations are now available in module_time_integration.F for computation
+ of terms in the u tendency equation; either is selectable by suitably defining
+ MODEL_FORMULATION in the Makefile.
+
+13 May 2009 -- Initial version
+
+
+I. Code layout
+
+ The swmodel is written in Fortran (plus one C routine), with some of the code being generated
+ by a C program called the "registry". All of the Fortran code for the model is contained in the
+ src/ directory, while the registry program resides in the Registry/ directory. When building the
+ model with the 'make' command, the registry is first compiled in the Registry/ directory; after
+ the registry is built, it is run by make to generate pieces of Fortran code that are included in
+ various hand-written Fortran routines in the src/ directory; these registry-generated pieces of
+ code are placed in the inc/ directory. After running the registry program, the main swmodel code
+ in the src/ directory is compiled, and the final executable, swmodel, is linked into the top-level
+ directory. At present, the only external package needed by the model is the NetCDF library, which
+ is linked in the swmodel executable. However, if the need arises to build other software libraries
+ when the swmodel code is built, these packages can be located in the external/ directory.
+
+ Briefly, the main Fortran source files in the src/ directory are as follows:
+
+ swmodel.F -- Contains the main program, which essentially calls routines within other
+ modules.
+
+ module_block_decomp.F -- Contains code to read a mesh decomposition file to decompose the
+ model grid into "blocks", each of which is solved for by a single MPI
+ process.
+
+ module_configure.F -- Contains user-specified configuration information (e.g., model time,
+ number of timesteps to simulate, interval between writes of model state,
+ and which shallow water test case to run) that is read from a Fortran
+ namelist (namelist.input). The actual variables in the namelist are
+ defined in the Registry/Registry file, and the code to read these variables
+ as a namelist is generated by the registry program.
+
+ module_constants.F -- Contains definitions of constants used at various points in the model
+ (e.g., radius of the earth, omega, gravity, pi).
+
+ module_dmpar.F -- Contains routines to perform distributed memory operations, such as
+ update ghost cells in a block, determine which block owns a list of cells,
+ and perform collective operations like broadcasts and sums. These operations
+ are currently implemented using MPI.
+
+ module_grid_types.F -- Contains definitions of derived data types used in the model, as well
+ as routines for allocating and deallocating each type. The members of
+ two of the types (grid meta, which contains time-invariant fields, and
+ grid_state, which contains time-varying fields) are supplied by registry-
+ generated code, and, therefore, all fields in the model should ultimately
+ be defined in the Registry/Registry file.
+
+ module_hash.F -- A simple dictionary/hash table implementation.
+
+ module_io_input.F -- Contain code for reading grid and model state information from an input
+ module_io_output.F file (grid.nc or restart.nc) and writing model state to an output file
+ (output.nc or restart.nc). Like the fields in module_grid_types, the
+ actual code to read or write a particular field is generated by the
+ registry program at compile time.
+
+ module_sort.F -- Contains implementations of mergesort, quicksort, and binary search.
+
+ module_sw_solver.F -- Contains the main solver loop, which advances each block of the domain
+ forward in time by a specified delta-t and periodically writes model state
+ to an output file.
+
+ module_test_cases.F -- Contains routines (one per test case) to initialize the model state for
+ the particular case specified in the user input (namelist) file.
+
+ module_time_integration.F -- Contains time integration routine (currently RK4) and a function
+ to compute the tendencies for prognostic variables given the current
+ model state.
+
+ module_timer.F -- Contains functions to measure the execution time between two points
+ in the code.
+
+
+II. Building the code
+
+ The swmodel code may be built using the included Makefile, after suitably editing this file to
+ set compiler and compiler flags appropriate to the system. Additionally, the environment
+ variable NETCDF must be set to the path of the NetCDF installation. In the Makefile, the following
+ should be set:
+
+ FC -- The MPI Fortran compiler if compiling a parallel executable; otherwise, the serial
+ Fortran compiler.
+
+ CC -- The MPI C compiler if compiling a parallel executable; otherwise, the serial C compiler.
+
+ SFC -- The serial Fortran compiler; the same as $(FC) when compiling a serial executable.
+
+ SCC -- The serial C compiler; the same as $(CC) when compiling a serial executable.
+
+ FFLAGS -- Flags specified to the compiler when compiling Fortran source files; there aren't
+ any particular flags to be specified, although one might want to add debugging or
+ optimization flags here
+
+ LDFLAGS -- Flags given when linking the final executable; again, nothing in particular needs
+ to be given here, although debugging and optimization flags can be helpful.
+
+ CPPFLAGS -- These should *not* be changed, since -DRKIND=8 will set the kind of Fortran
+ reals to be 8-bytes, which is necessary for reading the double precision model initial
+ state from the input file, grid.nc. If building a serial executable, -D_MPI should
+ not appear in the definition of CPPFLAGS.
+
+ CPPINCLUDES -- The flags necessary to tell the C preprocessor where to find include/header files.
+
+ FCINCLUDES -- The flags necessary to tell the compiler where to find NetCDF include/header files.
+
+ LIBS -- The flags necessary to tell the compiler where to find NetCDF libraries; typically,
+ these flags must include a flag specifying the path to libraries, as well as flags to
+ link the libraries themselves (either libnetcdf.a, or in some installations, libnetcdff.a
+ and libnetcdf.a)
+
+
+
+III. Running the code
+
+ After successfully compiling but before running, it will be necessary to have downloaded an input
+ file, and, if the code was compiled for parallel execution, a grid decomposition file. These input
+ files may be downloaded for several grid sizes from http://www.mmm.ucar.edu/people/duda/files/mpas/,
+ where the name of the tar file indicates the number of grid cells. Once the input files (grid.nc
+ and graph.info.part.?) have been copied into the top-level directory, the swmodel executable may be
+ run.
+
+ For a parallel run, a graph.info.part.N file must be present in the run directory, where N is the
+ number of processors to run on; then, the swmodel executable may be run with mpirun, mpiexec, etc.
+
+ For a serial run, no grid decomposition file (i.e., graph.info.part.*) file is necessary. It should
+ be noted that to run the code in serial, the code must not have been compiled with mpif90/mpicc, since
+ no graph.info.part.1 files are available (although one could be trivially generated).
+
Added: branches/ocean_projects/triangle_border_swm/namelist.input
===================================================================
--- branches/ocean_projects/triangle_border_swm/namelist.input (rev 0)
+++ branches/ocean_projects/triangle_border_swm/namelist.input 2011-04-29 18:46:19 UTC (rev 810)
@@ -0,0 +1 @@
+link namelist.input.sw
\ No newline at end of file
Property changes on: branches/ocean_projects/triangle_border_swm/namelist.input
___________________________________________________________________
Added: svn:special
+ *
Added: branches/ocean_projects/triangle_border_swm/namelist.input.sw
===================================================================
--- branches/ocean_projects/triangle_border_swm/namelist.input.sw (rev 0)
+++ branches/ocean_projects/triangle_border_swm/namelist.input.sw 2011-04-29 18:46:19 UTC (rev 810)
@@ -0,0 +1,30 @@
+&sw_model
+ config_test_case = 5
+ config_time_integration = 'RK4'
+ config_dt = 172.8
+ config_ntimesteps = 7500
+ config_output_interval = 500
+ config_stats_interval = 0
+ config_h_mom_eddy_visc2 = 0.0
+ config_h_mom_eddy_visc4 = 0.0
+ config_h_tracer_eddy_diff2 = 0.0
+ config_h_tracer_eddy_diff4 = 0.0
+ config_thickness_adv_order = 2
+ config_tracer_adv_order = 2
+ config_positive_definite = .false.
+ config_monotonic = .false.
+ config_wind_stress = .false.
+ config_bottom_drag = .false.
+/
+
+&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
+/
Added: branches/ocean_projects/triangle_border_swm/src/Makefile
===================================================================
--- branches/ocean_projects/triangle_border_swm/src/Makefile (rev 0)
+++ branches/ocean_projects/triangle_border_swm/src/Makefile 2011-04-29 18:46:19 UTC (rev 810)
@@ -0,0 +1,40 @@
+.SUFFIXES: .F .c .o
+
+all: mpas
+
+mpas: reg_includes externals frame ops dycore drver
+ $(FC) $(LDFLAGS) -o $(CORE)_model.exe driver/*.o -L. -ldycore -lops -lframework $(LIBS)
+
+reg_includes:
+ ( cd registry; make CC="$(SCC)" )
+ ( cd inc; ../registry/parse ../core_$(CORE)/Registry )
+
+externals:
+ ( cd external; make FC="$(FC)" SFC="$(SFC)" CC="$(CC)" SCC="$(SCC)" FFLAGS="$(FFLAGS)" CFLAGS="$(CFLAGS)" CPP="$(CPP)" RANLIB="$(RANLIB)" NETCDF="$(NETCDF)" CORE="$(CORE)" )
+
+frame:
+ ( cd framework; make all )
+ ln -sf framework/libframework.a libframework.a
+
+ops:
+ ( cd operators; make all )
+ ln -sf operators/libops.a libops.a
+
+dycore:
+ ( cd core_$(CORE); make all )
+ ln -sf core_$(CORE)/libdycore.a libdycore.a
+
+drver:
+ ( cd driver; make all )
+
+clean:
+ $(RM) $(CORE)_model.exe libframework.a libops.a libdycore.a
+ ( cd registry; make clean )
+ ( cd external; make clean )
+ ( cd framework; make clean )
+ ( cd operators; make clean )
+ ( cd inc; rm -f *.inc )
+ if [ -d core_$(CORE) ] ; then \
+ ( cd core_$(CORE); make clean ) \
+ fi;
+ ( cd driver; make clean )
Added: branches/ocean_projects/triangle_border_swm/src/core_sw/Makefile
===================================================================
--- branches/ocean_projects/triangle_border_swm/src/core_sw/Makefile (rev 0)
+++ branches/ocean_projects/triangle_border_swm/src/core_sw/Makefile 2011-04-29 18:46:19 UTC (rev 810)
@@ -0,0 +1,30 @@
+.SUFFIXES: .F .o
+
+OBJS = module_mpas_core.o \
+ module_test_cases.o \
+ module_advection.o \
+ module_time_integration.o \
+ module_global_diagnostics.o
+
+all: core_sw
+
+core_sw: $(OBJS)
+ ar -ru libdycore.a $(OBJS)
+
+module_test_cases.o:
+
+module_advection.o:
+
+module_time_integration.o:
+
+module_global_diagnostics.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
+
+.F.o:
+ $(RM) $@ $*.mod
+ $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90
+ $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../framework -I../operators
Added: branches/ocean_projects/triangle_border_swm/src/core_sw/Registry
===================================================================
--- branches/ocean_projects/triangle_border_swm/src/core_sw/Registry (rev 0)
+++ branches/ocean_projects/triangle_border_swm/src/core_sw/Registry 2011-04-29 18:46:19 UTC (rev 810)
@@ -0,0 +1,151 @@
+#
+# namelist type namelist_record name default_value
+#
+namelist integer sw_model config_test_case 5
+namelist character sw_model config_time_integration RK4
+namelist real sw_model config_dt 172.8
+namelist integer sw_model config_ntimesteps 7500
+namelist integer sw_model config_output_interval 500
+namelist integer sw_model config_stats_interval 100
+namelist real sw_model config_h_mom_eddy_visc2 0.0
+namelist real sw_model config_h_mom_eddy_visc4 0.0
+namelist real sw_model config_h_tracer_eddy_diff2 0.0
+namelist real sw_model config_h_tracer_eddy_diff4 0.0
+namelist integer sw_model config_thickness_adv_order 2
+namelist integer sw_model config_tracer_adv_order 2
+namelist logical sw_model config_positive_definite false
+namelist logical sw_model config_monotonic false
+namelist logical sw_model config_wind_stress false
+namelist logical sw_model config_bottom_drag 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_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 R3 3
+dim FIFTEEN 15
+dim TWENTYONE 21
+dim vertexDegree vertexDegree
+dim nVertLevels nVertLevels
+dim nTracers nTracers
+
+#
+# var persistence type name_in_file ( dims ) time_levs iro- name_in_code struct super-array array_class
+#
+var persistent real xtime ( Time ) 2 ro xtime state - -
+
+var persistent real latCell ( nCells ) 0 iro latCell mesh - -
+var persistent real lonCell ( nCells ) 0 iro lonCell mesh - -
+var persistent real xCell ( nCells ) 0 iro xCell mesh - -
+var persistent real yCell ( nCells ) 0 iro yCell mesh - -
+var persistent real zCell ( nCells ) 0 iro zCell mesh - -
+var persistent integer indexToCellID ( nCells ) 0 iro indexToCellID mesh - -
+
+var persistent real latEdge ( nEdges ) 0 iro latEdge mesh - -
+var persistent real lonEdge ( nEdges ) 0 iro lonEdge mesh - -
+var persistent real xEdge ( nEdges ) 0 iro xEdge mesh - -
+var persistent real yEdge ( nEdges ) 0 iro yEdge mesh - -
+var persistent real zEdge ( nEdges ) 0 iro zEdge mesh - -
+var persistent integer indexToEdgeID ( nEdges ) 0 iro indexToEdgeID mesh - -
+
+var persistent real latVertex ( nVertices ) 0 iro latVertex mesh - -
+var persistent real lonVertex ( nVertices ) 0 iro lonVertex mesh - -
+var persistent real xVertex ( nVertices ) 0 iro xVertex mesh - -
+var persistent real yVertex ( nVertices ) 0 iro yVertex mesh - -
+var persistent real zVertex ( nVertices ) 0 iro zVertex mesh - -
+var persistent integer indexToVertexID ( nVertices ) 0 iro indexToVertexID mesh - -
+
+var persistent integer cellsOnEdge ( TWO nEdges ) 0 iro cellsOnEdge mesh - -
+var persistent integer nEdgesOnCell ( nCells ) 0 iro nEdgesOnCell mesh - -
+var persistent integer nEdgesOnEdge ( nEdges ) 0 iro nEdgesOnEdge mesh - -
+var persistent integer edgesOnCell ( maxEdges nCells ) 0 iro edgesOnCell mesh - -
+var persistent integer edgesOnEdge ( maxEdges2 nEdges ) 0 iro edgesOnEdge mesh - -
+
+var persistent real weightsOnEdge ( maxEdges2 nEdges ) 0 iro weightsOnEdge mesh - -
+var persistent real dvEdge ( nEdges ) 0 iro dvEdge mesh - -
+var persistent real dcEdge ( nEdges ) 0 iro dcEdge mesh - -
+var persistent real angleEdge ( nEdges ) 0 iro angleEdge mesh - -
+var persistent real areaCell ( nCells ) 0 iro areaCell mesh - -
+var persistent real areaTriangle ( nVertices ) 0 iro areaTriangle mesh - -
+
+var persistent real edgeNormalVectors ( R3 nEdges ) 0 o edgeNormalVectors mesh - -
+var persistent real localVerticalUnitVectors ( R3 nCells ) 0 o localVerticalUnitVectors mesh - -
+var persistent real cellTangentPlane ( R3 TWO nEdges ) 0 o cellTangentPlane mesh - -
+
+var persistent integer cellsOnCell ( maxEdges nCells ) 0 iro cellsOnCell mesh - -
+var persistent integer verticesOnCell ( maxEdges nCells ) 0 iro verticesOnCell mesh - -
+var persistent integer verticesOnEdge ( TWO nEdges ) 0 iro verticesOnEdge mesh - -
+var persistent integer edgesOnVertex ( vertexDegree nVertices ) 0 iro edgesOnVertex mesh - -
+var persistent integer cellsOnVertex ( vertexDegree nVertices ) 0 iro cellsOnVertex mesh - -
+var persistent real kiteAreasOnVertex ( vertexDegree nVertices ) 0 iro kiteAreasOnVertex mesh - -
+var persistent real fEdge ( nEdges ) 0 iro fEdge mesh - -
+var persistent real fVertex ( nVertices ) 0 iro fVertex mesh - -
+var persistent real fCell ( nCells ) 0 iro fCell mesh - -
+var persistent real h_s ( nCells ) 0 iro h_s mesh - -
+
+# Space needed for advection
+var persistent real deriv_two ( FIFTEEN TWO nEdges ) 0 o deriv_two mesh - -
+var persistent integer advCells ( TWENTYONE nCells ) 0 - advCells mesh - -
+
+# !! NOTE: the following arrays are needed to allow the use
+# !! of the module_advection.F w/o alteration
+# Space needed for deformation calculation weights
+var persistent real defc_a ( maxEdges nCells ) 0 - defc_a mesh - -
+var persistent real defc_b ( maxEdges nCells ) 0 - defc_b mesh - -
+var persistent real kdiff ( nVertLevels nCells Time ) 0 - kdiff mesh - -
+
+# Arrays required for reconstruction of velocity field
+var persistent real coeffs_reconstruct ( R3 maxEdges nCells ) 0 - coeffs_reconstruct mesh - -
+
+# Boundary conditions: read from input, saved in restart and written to output
+var persistent integer boundaryEdge ( nVertLevels nEdges ) 0 iro boundaryEdge mesh - -
+var persistent integer boundaryVertex ( nVertLevels nVertices ) 0 iro boundaryVertex mesh - -
+var persistent integer boundaryCell ( nVertLevels nCells ) 0 iro boundaryCell mesh - -
+var persistent real u_src ( nVertLevels nEdges ) 0 iro u_src mesh - -
+
+# Prognostic variables: read from input, saved in restart, and written to output
+var persistent real u ( nVertLevels nEdges Time ) 2 iro u state - -
+var persistent real h ( nVertLevels nCells Time ) 2 iro h state - -
+var persistent real tracers ( nTracers nVertLevels nCells Time ) 2 iro tracers state - -
+
+# Tendency variables
+var persistent real tend_u ( nVertLevels nEdges Time ) 1 - u tend - -
+var persistent real tend_h ( nVertLevels nCells Time ) 1 - h tend - -
+var persistent real tend_tracers ( nTracers nVertLevels nCells Time ) 1 - tracers tend - -
+
+# Diagnostic fields: only written to output
+var persistent real v ( nVertLevels nEdges Time ) 2 o v state - -
+var persistent real divergence ( nVertLevels nCells Time ) 2 o divergence state - -
+var persistent real vorticity ( nVertLevels nVertices Time ) 2 o vorticity state - -
+var persistent real vorticity_cell ( nVertLevels nCells Time ) 2 o vorticity_cell state - -
+var persistent real pv_edge ( nVertLevels nEdges Time ) 2 o pv_edge state - -
+var persistent real h_edge ( nVertLevels nEdges Time ) 2 o h_edge state - -
+var persistent real ke ( nVertLevels nCells Time ) 2 o ke state - -
+var persistent real pv_vertex ( nVertLevels nVertices Time ) 2 o pv_vertex state - -
+var persistent real pv_cell ( nVertLevels nCells Time ) 2 o pv_cell state - -
+var persistent real uReconstructX ( nVertLevels nCells Time ) 2 o uReconstructX state - -
+var persistent real uReconstructY ( nVertLevels nCells Time ) 2 o uReconstructY state - -
+var persistent real uReconstructZ ( nVertLevels nCells Time ) 2 o uReconstructZ state - -
+var persistent real uReconstructZonal ( nVertLevels nCells Time ) 2 o uReconstructZonal state - -
+var persistent real uReconstructMeridional ( nVertLevels nCells Time ) 2 o uReconstructMeridional state - -
+
+# Other diagnostic variables: neither read nor written to any files
+var persistent real vh ( nVertLevels nEdges Time ) 2 - vh state - -
+var persistent real circulation ( nVertLevels nVertices Time ) 2 - circulation state - -
+var persistent real gradPVt ( nVertLevels nEdges Time ) 2 - gradPVt state - -
+var persistent real gradPVn ( nVertLevels nEdges Time ) 2 - gradPVn state - -
+var persistent real h_vertex ( nVertLevels nVertices Time ) 2 - h_vertex state - -
+
Added: branches/ocean_projects/triangle_border_swm/src/core_sw/module_advection.F
===================================================================
--- branches/ocean_projects/triangle_border_swm/src/core_sw/module_advection.F (rev 0)
+++ branches/ocean_projects/triangle_border_swm/src/core_sw/module_advection.F 2011-04-29 18:46:19 UTC (rev 810)
@@ -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 = MAX(C1,ABS(A(I,J)))
+ END DO
+ C(I) = C1
+ END DO
+!
+! Search the pivoting (largest) element from each column
+!
+ DO J = 1, N-1
+ PI1 = 0.0
+ DO I = J, N
+ PI = ABS(A(INDX(I),J))/C(INDX(I))
+ IF (PI.GT.PI1) THEN
+ PI1 = PI
+ K = I
+ ENDIF
+ END DO
+!
+! Interchange the rows via INDX(N) to record pivoting order
+!
+ ITMP = INDX(J)
+ INDX(J) = INDX(K)
+ INDX(K) = ITMP
+ DO I = J+1, N
+ PJ = A(INDX(I),J)/A(INDX(J),J)
+!
+! Record pivoting ratios below the diagonal
+!
+ A(INDX(I),J) = PJ
+!
+! Modify other elements accordingly
+!
+ DO K = J+1, N
+ A(INDX(I),K) = A(INDX(I),K)-PJ*A(INDX(J),K)
+ END DO
+ END DO
+ END DO
+!
+END SUBROUTINE ELGS
+
+!-------------------------------------------------------------
+
+ subroutine 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/ocean_projects/triangle_border_swm/src/core_sw/module_global_diagnostics.F
===================================================================
--- branches/ocean_projects/triangle_border_swm/src/core_sw/module_global_diagnostics.F (rev 0)
+++ branches/ocean_projects/triangle_border_swm/src/core_sw/module_global_diagnostics.F 2011-04-29 18:46:19 UTC (rev 810)
@@ -0,0 +1,384 @@
+module global_diagnostics
+
+ use grid_types
+ use configure
+ use constants
+ use dmpar
+
+ implicit none
+ save
+ public
+
+ contains
+
+ subroutine computeGlobalDiagnostics(dminfo, state, grid, timeIndex, dt)
+
+ ! Note: this routine assumes that there is only one block per processor. No looping
+ ! is preformed over blocks.
+ ! dminfo is the domain info needed for global communication
+ ! state contains the state variables needed to compute global diagnostics
+ ! grid conains the meta data about the grid
+ ! timeIndex is the current time step counter
+ ! dt is the duration of each time step
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! INSTRUCTIONS !
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! To add a new Diagnostic as a Global Stat, follow these steps.
+ ! 1. Define the array to integrate, and the variable for the value above.
+ ! 2. Allocate the array with the correct dimensions.
+ ! 3. Fill the array with the data to be integrated.
+ ! eg. GlobalFluidThickness = Sum(h dA)/Sum(dA), See below for array filling
+ ! 4. Call Function to compute Global Stat that you want.
+ ! 5. Finish computing the global stat/integral
+ ! 6. Write out your global stat to the file
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ type (state_type), intent(inout) :: state
+ type (mesh_type), intent(in) :: grid
+ integer, intent(in) :: timeIndex
+ real (kind=RKIND), intent(in) :: dt
+
+ integer :: nVertLevels, nCellsSolve, nEdgesSolve, nVerticesSolve, nCellsGlobal, nEdgesGlobal, nVerticesGlobal, iTracer
+ integer :: nCells
+
+ ! Step 1
+ ! 1. Define the array to integrate, and the variable for the value to be stored in after the integration
+ real (kind=RKIND), dimension(:), pointer :: areaCell, dcEdge, dvEdge, areaTriangle, h_s, fCell, fEdge
+ real (kind=RKIND), dimension(:,:), pointer :: h, u, v, h_edge, pv_edge, pv_vertex, pv_cell, h_vertex, weightsOnEdge
+
+ real (kind=RKIND), dimension(:,:,:), pointer :: tracers
+
+ real (kind=RKIND), dimension(:), allocatable :: volumeWeightedPotentialEnergyReservoir, averageThickness
+ real (kind=RKIND), dimension(:), allocatable :: potentialEnstrophyReservior, areaEdge, h_s_edge
+
+ real (kind=RKIND), dimension(:,:), allocatable :: cellVolume, cellArea, volumeWeightedPotentialVorticity
+ real (kind=RKIND), dimension(:,:), allocatable :: volumeWeightedPotentialEnstrophy, vertexVolume, volumeWeightedKineticEnergy
+ real (kind=RKIND), dimension(:,:), allocatable :: volumeWeightedPotentialEnergy, volumeWeightedPotentialEnergyTopography
+ real (kind=RKIND), dimension(:,:), allocatable :: keTend_CoriolisForce, keTend_PressureGradient
+ real (kind=RKIND), dimension(:,:), allocatable ::peTend_DivThickness, refAreaWeightedSurfaceHeight, refAreaWeightedSurfaceHeight_edge
+
+ real (kind=RKIND) :: sumCellVolume, sumCellArea, sumVertexVolume, sumrefAreaWeightedSurfaceHeight
+
+ real (kind=RKIND) :: globalFluidThickness, globalPotentialVorticity, globalPotentialEnstrophy, globalEnergy
+ real (kind=RKIND) :: globalCoriolisEnergyTendency, globalKEPETendency, globalPotentialEnstrophyReservoir
+ real (kind=RKIND) :: globalKineticEnergy, globalPotentialEnergy, globalPotentialEnergyReservoir
+ real (kind=RKIND) :: globalKineticEnergyTendency, globalPotentialEnergyTendency
+ real (kind=RKIND) :: global_temp, workpv, q
+ real (kind=RKIND) :: volumeCellGlobal, volumeEdgeGlobal, CFLNumberGlobal
+
+ integer :: elementIndex, variableIndex, nVariables, nSums, nMaxes, nMins
+ integer :: timeLevel, eoe, iLevel, iCell, iEdge, iVertex
+ integer :: fileID, iCell1, iCell2, j
+
+ integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnCell, edgesOnEdge
+ integer, dimension(:), pointer :: nEdgesOnEdge
+
+ cellsOnEdge => grid % cellsOnEdge % array
+ edgesOnCell => grid % edgesOnCell % array
+
+ nVertLevels = grid % nVertLevels
+ nCellsSolve = grid % nCellsSolve
+ nEdgesSolve = grid % nEdgesSolve
+ nVerticesSolve = grid % nVerticesSolve
+ nCells = grid % nCells
+
+ h_s => grid % h_s % array
+ areaCell => grid % areaCell % array
+ dcEdge => grid % dcEdge % array
+ dvEdge => grid % dvEdge % array
+ areaTriangle => grid % areaTriangle % array
+ fCell => grid % fCell % array
+ fEdge => grid % fEdge % array
+ edgesOnEdge => grid % edgesOnEdge % array
+ nEdgesOnEdge => grid % nEdgesOnEdge % array
+
+ allocate(areaEdge(1:nEdgesSolve))
+ areaEdge = dcEdge(1:nEdgesSolve)*dvEdge(1:nEdgesSolve)
+ weightsOnEdge => grid % weightsOnEdge % array
+
+ h => state % h % array
+ u => state % u % array
+ v => state % v % array
+ tracers => state % tracers % array
+ h_edge => state % h_edge % array
+ h_vertex => state % h_vertex % array
+ pv_edge => state % pv_edge % array
+ pv_vertex => state % pv_vertex % array
+ pv_cell => state % pv_cell % array
+
+ ! Step 2
+ ! 2. Allocate the array with the correct dimensions.
+ allocate(cellVolume(nVertLevels,nCellsSolve))
+ allocate(cellArea(nVertLevels,nCellsSolve))
+ allocate(refAreaWeightedSurfaceHeight(nVertLevels,nCellsSolve))
+ allocate(refAreaWeightedSurfaceHeight_edge(nVertLevels,nEdgesSolve))
+ allocate(volumeWeightedPotentialVorticity(nVertLevels,nVerticesSolve))
+ allocate(volumeWeightedPotentialEnstrophy(nVertLevels,nVerticesSolve))
+ allocate(potentialEnstrophyReservior(nCellsSolve))
+ allocate(vertexVolume(nVertLevels,nVerticesSolve))
+ allocate(volumeWeightedKineticEnergy(nVertLevels,nEdgesSolve))
+ allocate(volumeWeightedPotentialEnergy(nVertLevels,nCellsSolve))
+ allocate(volumeWeightedPotentialEnergyTopography(nVertLevels,nCellsSolve))
+ allocate(volumeWeightedPotentialEnergyReservoir(nCellsSolve))
+ allocate(keTend_CoriolisForce(nVertLevels,nEdgesSolve))
+ allocate(keTend_PressureGradient(nVertLevels,nEdgesSolve))
+ allocate(peTend_DivThickness(nVertLevels,nCells))
+
+ allocate(averageThickness(nCellsSolve))
+
+ allocate(h_s_edge(nEdgesSOlve))
+
+
+ cellVolume = 0
+ refAreaWeightedSurfaceHeight = 0
+ refAreaWeightedSurfaceHeight_edge = 0
+ vertexVolume = 0
+ cellArea = 0
+ averageThickness = 0
+ volumeWeightedPotentialVorticity = 0
+ volumeWeightedPotentialEnstrophy = 0
+ volumeWeightedKineticEnergy = 0
+ volumeWeightedPotentialEnergy = 0
+ volumeWeightedPotentialEnergyTopography = 0
+ volumeWeightedPotentialEnergyReservoir = 0
+ keTend_PressureGradient = 0
+ peTend_DivThickness = 0
+ keTend_CoriolisForce = 0
+ h_s_edge = 0
+
+ ! Build Arrays for Global Integrals
+ ! Step 3
+ ! 3. Fill the array with the data to be integrated.
+ ! eg. GlobalFluidThickness = Sum(h dA)/Sum(dA), See below for array filling
+ do iLevel = 1,nVertLevels
+ ! eg. GlobalFluidThickness top (Sum( h dA)) = Sum(cellVolume)
+ cellVolume(iLevel,:) = h(iLevel,1:nCellsSolve)*areaCell(1:nCellsSolve)
+ ! eg. GlobalFluidThickness bot (Sum(dA)) = Sum(cellArea)
+ cellArea(iLevel,:) = areaCell(1:nCellsSolve)
+ volumeWeightedPotentialVorticity(iLevel,:) = pv_vertex(iLevel,1:nVerticesSolve) &
+ *h_vertex(iLevel,1:nVerticesSolve)*areaTriangle(1:nVerticesSolve)
+ volumeWeightedPotentialEnstrophy(iLevel,:) = pv_vertex(iLevel,1:nVerticesSolve) &
+ *pv_vertex(iLevel,1:nVerticesSolve)*h_vertex(iLevel,1:nVerticesSolve)*areaTriangle(1:nVerticesSolve)
+ vertexVolume(iLevel,:) = h_vertex(iLevel,1:nVerticesSolve)*areaTriangle(1:nVerticesSolve)
+ volumeWeightedKineticEnergy(iLevel,:) = u(iLevel,1:nEdgesSolve)*u(iLevel,1:nEdgesSolve) &
+ *h_edge(iLevel,1:nEdgesSolve)*areaEdge(1:nEdgesSolve)*0.5
+ volumeWeightedPotentialEnergy(iLevel,:) = gravity*h(iLevel,1:nCellsSolve)*h(iLevel,1:nCellsSolve)*areaCell(1:nCellsSolve)*0.5
+ volumeWeightedPotentialEnergyTopography(iLevel,:) = gravity*h(iLevel,1:nCellsSolve)*h_s(1:nCellsSolve)*areaCell(1:nCellsSolve)
+ refAreaWeightedSurfaceHeight(iLevel,:) = areaCell(1:nCellsSolve)*(h(iLevel,1:nCellsSolve)+h_s(1:nCellsSolve))
+
+ do iEdge = 1,nEdgesSolve
+ q = 0.0
+ do j = 1,nEdgesOnEdge(iEdge)
+ eoe = edgesOnEdge(j,iEdge)
+ workpv = 0.5 * (pv_edge(iLevel,iEdge) + pv_edge(iLevel,eoe))
+ q = q + weightsOnEdge(j,iEdge) * u(iLevel,eoe) * workpv * h_edge(iLevel,eoe)
+ end do
+ keTend_CoriolisForce(iLevel,iEdge) = h_edge(iLevel,iEdge) * u(iLevel,iEdge) * q * areaEdge(iEdge)
+
+ iCell1 = cellsOnEdge(1,iEdge)
+ iCell2 = cellsOnEdge(2,iEdge)
+
+ refAreaWeightedSurfaceHeight_edge(iLevel,iEdge) = areaEdge(iEdge)*(h_edge(iLevel,iEdge) + 0.5*(h_s(iCell1) + h_s(iCell2)))
+
+ keTend_PressureGradient(iLevel,iEdge) = areaEdge(iEdge)*h_edge(iLevel,iEdge)*u(iLevel,iEdge) &
+ *gravity*(h(iLevel,iCell2)+h_s(iCell2) - h(iLevel,iCell1)-h_s(iCell1))/dcEdge(iEdge)
+ peTend_DivThickness(iLevel,iCell1) = peTend_DivThickness(iLevel,iCell1) &
+ + h_edge(iLevel,iEdge)*u(iLevel,iEdge)*dvEdge(iEdge)
+ peTend_DivThickness(iLevel,iCell2) = peTend_DivThickness(iLevel,iCell2) &
+ - h_edge(iLevel,iEdge)*u(iLevel,iEdge)*dvEdge(iEdge)
+ end do
+
+ peTend_DivThickness(iLevel,:) = peTend_DivThickness(iLevel,1:nCells)*gravity &
+ *(h(iLevel,1:nCells)+h_s(1:nCells))
+ end do
+
+ do iEdge = 1,nEdgesSolve
+ iCell1 = cellsOnEdge(1,iEdge)
+ iCell2 = cellsOnEdge(2,iEdge)
+
+ h_s_edge(iEdge) = 0.5*(h_s(iCell1) + h_s(iCell2))
+ end do
+
+ ! Step 4
+ ! 4. Call Function to compute Global Stat that you want.
+ ! Computing Kinetic and Potential Energy Tendency Terms
+ call computeGlobalSum(dminfo, nVertLevels, nEdgesSolve, keTend_PressureGradient, globalKineticEnergyTendency)
+ call computeGlobalSum(dminfo, nVertLevels, nCells, peTend_DivThickness, globalPotentialEnergyTendency)
+
+ ! Computing top and bottom of global mass integral
+ call computeGlobalSum(dminfo, nVertLevels, nCellsSolve, cellVolume, sumCellVolume)
+ call computeGlobalSum(dminfo, nVertLevels, nCellsSolve, cellArea, sumCellArea)
+
+ globalKineticEnergyTendency = globalKineticEnergyTendency / sumCellVolume
+ globalPotentialEnergyTendency = globalPotentialEnergyTendency / sumCellVolume
+
+ ! Step 5
+ ! 5. Finish computing the global stat/integral
+ globalFluidThickness = sumCellVolume/sumCellArea
+
+ ! Compute Average Sea Surface Height for Potential Energy and Enstrophy
+ ! Reservoir computations
+ call computeGlobalSum(dminfo, nVertLevels, nCellsSolve, refAreaWeightedSurfaceHeight, sumrefAreaWeightedSurfaceHeight)
+
+ averageThickness(:) = (sumrefAreaWeightedSurfaceHeight/sumCellArea)-h_s(1:nCellsSolve)
+
+ ! Compute Volume Weighted Averages of Potential Vorticity and Potential Enstrophy
+ call computeGlobalSum(dminfo, nVertLevels, nVerticesSolve, volumeWeightedPotentialVorticity, globalPotentialVorticity)
+ call computeGlobalSum(dminfo, nVertLevels, nVerticesSolve, volumeWeightedPotentialEnstrophy, globalPotentialEnstrophy)
+ call computeGlobalSum(dminfo, nVertLevels, nVerticesSolve, vertexVolume, sumVertexVolume)
+
+ globalPotentialVorticity = globalPotentialVorticity/sumVertexVolume
+ globalPotentialEnstrophy = globalPotentialEnstrophy/sumVertexVolume
+
+ ! Compte Potential Enstrophy Reservior
+ potentialEnstrophyReservior(:) = areaCell(:)*fCell(:)*fCell(:)/averageThickness
+ call computeGlobalSum(dminfo, 1, nCellsSolve, potentialEnstrophyReservior, globalPotentialEnstrophyReservoir)
+ globalPotentialEnstrophyReservoir = globalPotentialEnstrophyReservoir/sumCellVolume
+
+ globalPotentialEnstrophy = globalPotentialEnstrophy - globalPotentialEnstrophyReservoir
+
+ ! Compute Kinetic and Potential Energy terms to be combined into total energy
+ call computeGlobalSum(dminfo, nVertLevels, nEdgesSolve, volumeWeightedKineticEnergy, globalKineticEnergy)
+ call computeGlobalSum(dminfo, nVertLevels, nCellsSolve, volumeWeightedPotentialEnergy, globalPotentialEnergy)
+ call computeGlobalSum(dminfo, nVertLevels, nCellsSolve, volumeWeightedPotentialEnergyTopography, global_temp)
+
+ globalKineticEnergy = globalKineticEnergy/sumCellVolume
+ globalPotentialEnergy = (globalPotentialEnergy + global_temp)/sumCellVolume
+
+ ! Compute Potential energy reservoir to be subtracted from potential energy term
+ volumeWeightedPotentialEnergyReservoir(1:nCellsSolve) = areaCell(1:nCellsSolve)*averageThickness*averageThickness*gravity*0.5
+ call computeGlobalSum(dminfo, nVertLevels, nCellsSolve, volumeWeightedPotentialEnergyReservoir, globalPotentialEnergyReservoir)
+ volumeWeightedPotentialEnergyReservoir(1:nCellsSolve) = areaCell(1:nCellsSolve)*averageThickness*h_s(1:nCellsSolve)*gravity
+ call computeGlobalSum(dminfo, nVertLevels, nCellsSolve, volumeWeightedPotentialEnergyReservoir, global_temp)
+
+ globalPotentialEnergyReservoir = (globalPotentialEnergyReservoir + global_temp)/sumCellVolume
+
+ globalPotentialEnergy = globalPotentialEnergy - globalPotentialEnergyReservoir
+ globalEnergy = globalKineticEnergy + globalPotentialEnergy
+
+ ! Compute Coriolis energy tendency term
+ call computeGlobalSum(dminfo, nVertLevels, nEdgesSolve, keTend_CoriolisForce, globalCoriolisEnergyTendency)
+ globalCoriolisEnergyTendency = globalCoriolisEnergyTendency/sumCellVolume
+
+ ! Step 6
+ ! 6. Write out your global stat to the file
+ if (dminfo % my_proc_id == IO_NODE) then
+ fileID = getFreeUnit()
+
+ if (timeIndex/config_stats_interval == 1) then
+ open(fileID, file='GlobalIntegrals.txt',STATUS='unknown')
+ else
+ open(fileID, file='GlobalIntegrals.txt',POSITION='append')
+ endif
+ write(fileID,'(1i0, 100es24.16)') timeIndex, timeIndex*dt, globalFluidThickness, globalPotentialVorticity, globalPotentialEnstrophy, &
+ globalEnergy, globalCoriolisEnergyTendency, globalKineticEnergyTendency+globalPotentialEnergyTendency, &
+ globalKineticEnergy, globalPotentialEnergy
+ close(fileID)
+ end if
+
+ deallocate(areaEdge)
+ end subroutine computeGlobalDiagnostics
+
+ integer function getFreeUnit()
+ implicit none
+
+ integer :: index
+ logical :: isOpened
+
+ getFreeUnit = 0
+ do index = 1,99
+ if((index /= 5) .and. (index /= 6)) then
+ inquire(unit = index, opened = isOpened)
+ if( .not. isOpened) then
+ getFreeUnit = index
+ return
+ end if
+ end if
+ end do
+ end function getFreeUnit
+
+ subroutine computeGlobalSum(dminfo, nVertLevels, nElements, field, globalSum)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: nVertLevels, nElements
+ real (kind=RKIND), dimension(nVertLevels, nElements), intent(in) :: field
+ real (kind=RKIND), intent(out) :: globalSum
+
+ real (kind=RKIND) :: localSum
+
+ localSum = sum(field)
+ call dmpar_sum_real(dminfo, localSum, globalSum)
+
+ end subroutine computeGlobalSum
+
+ subroutine computeGlobalMin(dminfo, nVertLevels, nElements, field, globalMin)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: nVertLevels, nElements
+ real (kind=RKIND), dimension(nVertLevels, nElements), intent(in) :: field
+ real (kind=RKIND), intent(out) :: globalMin
+
+ real (kind=RKIND) :: localMin
+
+ localMin = minval(field)
+ call dmpar_min_real(dminfo, localMin, globalMin)
+
+ end subroutine computeGlobalMin
+
+ subroutine computeGlobalMax(dminfo, nVertLevels, nElements, field, globalMax)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: nVertLevels, nElements
+ real (kind=RKIND), dimension(nVertLevels, nElements), intent(in) :: field
+ real (kind=RKIND), intent(out) :: globalMax
+
+ real (kind=RKIND) :: localMax
+
+ localMax = maxval(field)
+ call dmpar_max_real(dminfo, localMax, globalMax)
+
+ end subroutine computeGlobalMax
+
+ subroutine computeGlobalVertSumHorizMin(dminfo, nVertLevels, nElements, field, globalMin)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: nVertLevels, nElements
+ real (kind=RKIND), dimension(nVertLevels, nElements), intent(in) :: field
+ real (kind=RKIND), intent(out) :: globalMin
+
+ real (kind=RKIND) :: localMin
+
+ localMin = minval(sum(field,1))
+ call dmpar_min_real(dminfo, localMin, globalMin)
+
+ end subroutine computeGlobalVertSumHorizMin
+
+ subroutine computeGlobalVertSumHorizMax(dminfo, nVertLevels, nElements, field, globalMax)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: nVertLevels, nElements
+ real (kind=RKIND), dimension(nVertLevels, nElements), intent(in) :: field
+ real (kind=RKIND), intent(out) :: globalMax
+
+ real (kind=RKIND) :: localMax
+
+ localMax = maxval(sum(field,1))
+ call dmpar_max_real(dminfo, localMax, globalMax)
+
+ end subroutine computeGlobalVertSumHorizMax
+
+end module global_diagnostics
Added: branches/ocean_projects/triangle_border_swm/src/core_sw/module_mpas_core.F
===================================================================
--- branches/ocean_projects/triangle_border_swm/src/core_sw/module_mpas_core.F (rev 0)
+++ branches/ocean_projects/triangle_border_swm/src/core_sw/module_mpas_core.F 2011-04-29 18:46:19 UTC (rev 810)
@@ -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, 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
Added: branches/ocean_projects/triangle_border_swm/src/core_sw/module_test_cases.F
===================================================================
--- branches/ocean_projects/triangle_border_swm/src/core_sw/module_test_cases.F (rev 0)
+++ branches/ocean_projects/triangle_border_swm/src/core_sw/module_test_cases.F 2011-04-29 18:46:19 UTC (rev 810)
@@ -0,0 +1,527 @@
+module test_cases
+
+ use grid_types
+ use configure
+ use constants
+
+
+ contains
+
+
+ subroutine setup_sw_test_case(domain)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Configure grid metadata and model state for the shallow water test case
+ ! specified in the namelist
+ !
+ ! Output: block - a subset (not necessarily proper) of the model domain to be
+ ! initialized
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+
+ integer :: i
+ type (block_type), pointer :: block_ptr
+
+ if (config_test_case == 0) then
+ write(0,*) 'Using initial conditions supplied in input file'
+
+ else if (config_test_case == 1) then
+ write(0,*) 'Setting up shallow water test case 1'
+ write(0,*) ' -- Advection of Cosine Bell over the Pole'
+
+ block_ptr => domain % blocklist
+ do while (associated(block_ptr))
+ call sw_test_case_1(block_ptr % mesh, block_ptr % state % time_levs(1) % state)
+ 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 == 2) then
+ write(0,*) 'Setting up shallow water test case 2'
+ write(0,*) ' -- Setup shallow water test case 2: Global Steady State Nonlinear Zonal Geostrophic Flow'
+
+ block_ptr => domain % blocklist
+ do while (associated(block_ptr))
+ call sw_test_case_2(block_ptr % mesh, block_ptr % state % time_levs(1) % state)
+ 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 == 5) then
+ write(0,*) 'Setting up shallow water test case 5'
+ write(0,*) ' -- Setup shallow water test case 5: Zonal Flow over an Isolated Mountain'
+
+ block_ptr => domain % blocklist
+ do while (associated(block_ptr))
+ call sw_test_case_5(block_ptr % mesh, block_ptr % state % time_levs(1) % state)
+ 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,*) 'Setting up shallow water test case 6'
+ write(0,*) ' -- Rossby-Haurwitz Wave'
+
+ block_ptr => domain % blocklist
+ do while (associated(block_ptr))
+ call sw_test_case_6(block_ptr % mesh, block_ptr % state % time_levs(1) % state)
+ 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, 5, and 6 are currently supported.'
+ stop
+ end if
+
+ end subroutine setup_sw_test_case
+
+
+ subroutine sw_test_case_1(grid, state)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Setup shallow water test case 1: Advection of Cosine Bell over the Pole
+ !
+ ! Reference: Williamson, D.L., et al., "A Standard Test Set for Numerical
+ ! Approximations to the Shallow Water Equations in Spherical
+ ! Geometry" J. of Comp. Phys., 102, pp. 211--224
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (mesh_type), intent(inout) :: grid
+ type (state_type), intent(inout) :: state
+
+ real (kind=RKIND), parameter :: u0 = 2.0 * pii * a / (12.0 * 86400.0)
+ real (kind=RKIND), parameter :: h0 = 1000.0
+ real (kind=RKIND), parameter :: theta_c = 0.0
+ real (kind=RKIND), parameter :: lambda_c = 3.0*pii/2.0
+ real (kind=RKIND), parameter :: alpha = pii/4.0
+
+ integer :: iCell, iEdge, iVtx
+ real (kind=RKIND) :: r, u, v
+ real (kind=RKIND), allocatable, dimension(:) :: psiVertex
+
+ !
+ ! Scale all distances and areas from a unit sphere to one with radius a
+ !
+ grid % xCell % array = grid % xCell % array * a
+ grid % yCell % array = grid % yCell % array * a
+ grid % zCell % array = grid % zCell % array * a
+ grid % xVertex % array = grid % xVertex % array * a
+ grid % yVertex % array = grid % yVertex % array * a
+ grid % zVertex % array = grid % zVertex % array * a
+ grid % xEdge % array = grid % xEdge % array * a
+ grid % yEdge % array = grid % yEdge % array * a
+ grid % zEdge % array = grid % zEdge % array * a
+ grid % dvEdge % array = grid % dvEdge % array * a
+ grid % dcEdge % array = grid % dcEdge % array * a
+ grid % areaCell % array = grid % areaCell % array * a**2.0
+ grid % areaTriangle % array = grid % areaTriangle % array * a**2.0
+ grid % kiteAreasOnVertex % array = grid % kiteAreasOnVertex % array * a**2.0
+
+ !
+ ! Initialize wind field
+ !
+ allocate(psiVertex(grid % nVertices))
+ do iVtx=1,grid % nVertices
+ psiVertex(iVtx) = -a * u0 * ( &
+ sin(grid%latVertex%array(iVtx)) * cos(alpha) - &
+ cos(grid%lonVertex%array(iVtx)) * cos(grid%latVertex%array(iVtx)) * sin(alpha) &
+ )
+ end do
+ do iEdge=1,grid % nEdges
+ state % u % array(1,iEdge) = -1.0 * ( &
+ psiVertex(grid%verticesOnEdge%array(2,iEdge)) - &
+ psiVertex(grid%verticesOnEdge%array(1,iEdge)) &
+ ) / grid%dvEdge%array(iEdge)
+ end do
+ deallocate(psiVertex)
+
+ !
+ ! Initialize cosine bell at (theta_c, lambda_c)
+ !
+ do iCell=1,grid % nCells
+ r = sphere_distance(theta_c, lambda_c, grid % latCell % array(iCell), grid % lonCell % array(iCell), a)
+ if (r < a/3.0) then
+ state % h % array(1,iCell) = (h0 / 2.0) * (1.0 + cos(pii*r*3.0/a))
+ else
+ state % h % array(1,iCell) = 0.0
+ end if
+ end do
+
+ end subroutine sw_test_case_1
+
+
+ subroutine sw_test_case_2(grid, state)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Setup shallow water test case 2: Global Steady State Nonlinear Zonal
+ ! Geostrophic Flow
+ !
+ ! Reference: Williamson, D.L., et al., "A Standard Test Set for Numerical
+ ! Approximations to the Shallow Water Equations in Spherical
+ ! Geometry" J. of Comp. Phys., 102, pp. 211--224
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (mesh_type), intent(inout) :: grid
+ type (state_type), intent(inout) :: state
+
+ real (kind=RKIND), parameter :: u0 = 2.0 * pii * a / (12.0 * 86400.0)
+ real (kind=RKIND), parameter :: gh0 = 29400.0
+ real (kind=RKIND), parameter :: alpha = 0.0
+
+ integer :: iCell, iEdge, iVtx
+ real (kind=RKIND) :: u, v
+ real (kind=RKIND), allocatable, dimension(:) :: psiVertex
+
+
+ !
+ ! Scale all distances and areas from a unit sphere to one with radius a
+ !
+ grid % xCell % array = grid % xCell % array * a
+ grid % yCell % array = grid % yCell % array * a
+ grid % zCell % array = grid % zCell % array * a
+ grid % xVertex % array = grid % xVertex % array * a
+ grid % yVertex % array = grid % yVertex % array * a
+ grid % zVertex % array = grid % zVertex % array * a
+ grid % xEdge % array = grid % xEdge % array * a
+ grid % yEdge % array = grid % yEdge % array * a
+ grid % zEdge % array = grid % zEdge % array * a
+ grid % dvEdge % array = grid % dvEdge % array * a
+ grid % dcEdge % array = grid % dcEdge % array * a
+ grid % areaCell % array = grid % areaCell % array * a**2.0
+ grid % areaTriangle % array = grid % areaTriangle % array * a**2.0
+ grid % kiteAreasOnVertex % array = grid % kiteAreasOnVertex % array * a**2.0
+
+
+ !
+ ! Initialize wind field
+ !
+ allocate(psiVertex(grid % nVertices))
+ do iVtx=1,grid % nVertices
+ psiVertex(iVtx) = -a * u0 * ( &
+ sin(grid%latVertex%array(iVtx)) * cos(alpha) - &
+ cos(grid%lonVertex%array(iVtx)) * cos(grid%latVertex%array(iVtx)) * sin(alpha) &
+ )
+ end do
+ do iEdge=1,grid % nEdges
+ state % u % array(1,iEdge) = -1.0 * ( &
+ psiVertex(grid%verticesOnEdge%array(2,iEdge)) - &
+ psiVertex(grid%verticesOnEdge%array(1,iEdge)) &
+ ) / grid%dvEdge%array(iEdge)
+ end do
+ deallocate(psiVertex)
+
+ !
+ ! Generate rotated Coriolis field
+ !
+ do iEdge=1,grid % nEdges
+ grid % fEdge % array(iEdge) = 2.0 * omega * &
+ ( -cos(grid%lonEdge%array(iEdge)) * cos(grid%latEdge%array(iEdge)) * sin(alpha) + &
+ sin(grid%latEdge%array(iEdge)) * cos(alpha) &
+ )
+ end do
+ do iVtx=1,grid % nVertices
+ grid % fVertex % array(iVtx) = 2.0 * omega * &
+ (-cos(grid%lonVertex%array(iVtx)) * cos(grid%latVertex%array(iVtx)) * sin(alpha) + &
+ sin(grid%latVertex%array(iVtx)) * cos(alpha) &
+ )
+ end do
+
+ !
+ ! Initialize height field (actually, fluid thickness field)
+ !
+ do iCell=1,grid % nCells
+ state % h % array(1,iCell) = (gh0 - (a * omega * u0 + 0.5 * u0**2.0) * &
+ (-cos(grid%lonCell%array(iCell)) * cos(grid%latCell%array(iCell)) * sin(alpha) + &
+ sin(grid%latCell%array(iCell)) * cos(alpha) &
+ )**2.0 &
+ ) / &
+ gravity
+ end do
+
+ end subroutine sw_test_case_2
+
+
+ subroutine sw_test_case_5(grid, state)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Setup shallow water test case 5: Zonal Flow over an Isolated Mountain
+ !
+ ! Reference: Williamson, D.L., et al., "A Standard Test Set for Numerical
+ ! Approximations to the Shallow Water Equations in Spherical
+ ! Geometry" J. of Comp. Phys., 102, pp. 211--224
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (mesh_type), intent(inout) :: grid
+ type (state_type), intent(inout) :: state
+
+ real (kind=RKIND), parameter :: u0 = 20.
+ real (kind=RKIND), parameter :: gh0 = 5960.0*gravity
+ real (kind=RKIND), parameter :: hs0 = 2000.
+ real (kind=RKIND), parameter :: theta_c = pii/6.0
+ real (kind=RKIND), parameter :: lambda_c = 3.0*pii/2.0
+ real (kind=RKIND), parameter :: rr = pii/9.0
+ real (kind=RKIND), parameter :: alpha = 0.0
+
+ integer :: iCell, iEdge, iVtx
+ real (kind=RKIND) :: r, u, v
+ real (kind=RKIND), allocatable, dimension(:) :: psiVertex
+
+
+ !
+ ! Scale all distances and areas from a unit sphere to one with radius a
+ !
+ grid % xCell % array = grid % xCell % array * a
+ grid % yCell % array = grid % yCell % array * a
+ grid % zCell % array = grid % zCell % array * a
+ grid % xVertex % array = grid % xVertex % array * a
+ grid % yVertex % array = grid % yVertex % array * a
+ grid % zVertex % array = grid % zVertex % array * a
+ grid % xEdge % array = grid % xEdge % array * a
+ grid % yEdge % array = grid % yEdge % array * a
+ grid % zEdge % array = grid % zEdge % array * a
+ grid % dvEdge % array = grid % dvEdge % array * a
+ grid % dcEdge % array = grid % dcEdge % array * a
+ grid % areaCell % array = grid % areaCell % array * a**2.0
+ grid % areaTriangle % array = grid % areaTriangle % array * a**2.0
+ grid % kiteAreasOnVertex % array = grid % kiteAreasOnVertex % array * a**2.0
+
+ !
+ ! Initialize wind field
+ !
+ allocate(psiVertex(grid % nVertices))
+ do iVtx=1,grid % nVertices
+ psiVertex(iVtx) = -a * u0 * ( &
+ sin(grid%latVertex%array(iVtx)) * cos(alpha) - &
+ cos(grid%lonVertex%array(iVtx)) * cos(grid%latVertex%array(iVtx)) * sin(alpha) &
+ )
+ end do
+ do iEdge=1,grid % nEdges
+ state % u % array(1,iEdge) = -1.0 * ( &
+ psiVertex(grid%verticesOnEdge%array(2,iEdge)) - &
+ psiVertex(grid%verticesOnEdge%array(1,iEdge)) &
+ ) / grid%dvEdge%array(iEdge)
+ end do
+ deallocate(psiVertex)
+
+ !
+ ! Generate rotated Coriolis field
+ !
+ do iEdge=1,grid % nEdges
+ grid % fEdge % array(iEdge) = 2.0 * omega * &
+ (-cos(grid%lonEdge%array(iEdge)) * cos(grid%latEdge%array(iEdge)) * sin(alpha) + &
+ sin(grid%latEdge%array(iEdge)) * cos(alpha) &
+ )
+ end do
+ do iVtx=1,grid % nVertices
+ grid % fVertex % array(iVtx) = 2.0 * omega * &
+ (-cos(grid%lonVertex%array(iVtx)) * cos(grid%latVertex%array(iVtx)) * sin(alpha) + &
+ sin(grid%latVertex%array(iVtx)) * cos(alpha) &
+ )
+ end do
+
+ !
+ ! Initialize mountain
+ !
+ do iCell=1,grid % nCells
+ if (grid % lonCell % array(iCell) < 0.0) grid % lonCell % array(iCell) = grid % lonCell % array(iCell) + 2.0 * pii
+ r = sqrt(min(rr**2.0, (grid % lonCell % array(iCell) - lambda_c)**2.0 + (grid % latCell % array(iCell) - theta_c)**2.0))
+ grid % h_s % array(iCell) = hs0 * (1.0 - r/rr)
+ end do
+
+ !
+ ! Initialize tracer fields
+ !
+ do iCell=1,grid % nCells
+ r = sqrt(min(rr**2.0, (grid % lonCell % array(iCell) - lambda_c)**2.0 + (grid % latCell % array(iCell) - theta_c)**2.0))
+ state % tracers % array(1,1,iCell) = 1.0 - r/rr
+ end do
+ if (grid%nTracers > 1) then
+ do iCell=1,grid % nCells
+ r = sqrt(min(rr**2.0, (grid % lonCell % array(iCell) - lambda_c)**2.0 + &
+ (grid % latCell % array(iCell) - theta_c - pii/6.0)**2.0 &
+ ) &
+ )
+ state % tracers % array(2,1,iCell) = 1.0 - r/rr
+ end do
+ end if
+
+ !
+ ! Initialize height field (actually, fluid thickness field)
+ !
+ do iCell=1,grid % nCells
+ state % h % array(1,iCell) = (gh0 - (a * omega * u0 + 0.5 * u0**2.0) * &
+ (-cos(grid%lonCell%array(iCell)) * cos(grid%latCell%array(iCell)) * sin(alpha) + &
+ sin(grid%latCell%array(iCell)) * cos(alpha) &
+ )**2.0 &
+ ) / &
+ gravity
+ state % h % array(1,iCell) = state % h % array(1,iCell) - grid % h_s % array(iCell)
+ end do
+
+ end subroutine sw_test_case_5
+
+
+ subroutine sw_test_case_6(grid, state)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Setup shallow water test case 6: Rossby-Haurwitz Wave
+ !
+ ! Reference: Williamson, D.L., et al., "A Standard Test Set for Numerical
+ ! Approximations to the Shallow Water Equations in Spherical
+ ! Geometry" J. of Comp. Phys., 102, pp. 211--224
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (mesh_type), intent(inout) :: grid
+ type (state_type), intent(inout) :: state
+
+ real (kind=RKIND), parameter :: h0 = 8000.0
+ real (kind=RKIND), parameter :: w = 7.848e-6
+ real (kind=RKIND), parameter :: K = 7.848e-6
+ real (kind=RKIND), parameter :: R = 4.0
+
+ integer :: iCell, iEdge, iVtx
+ real (kind=RKIND) :: u, v
+ real (kind=RKIND), allocatable, dimension(:) :: psiVertex
+
+
+ !
+ ! Scale all distances and areas from a unit sphere to one with radius a
+ !
+ grid % xCell % array = grid % xCell % array * a
+ grid % yCell % array = grid % yCell % array * a
+ grid % zCell % array = grid % zCell % array * a
+ grid % xVertex % array = grid % xVertex % array * a
+ grid % yVertex % array = grid % yVertex % array * a
+ grid % zVertex % array = grid % zVertex % array * a
+ grid % xEdge % array = grid % xEdge % array * a
+ grid % yEdge % array = grid % yEdge % array * a
+ grid % zEdge % array = grid % zEdge % array * a
+ grid % dvEdge % array = grid % dvEdge % array * a
+ grid % dcEdge % array = grid % dcEdge % array * a
+ grid % areaCell % array = grid % areaCell % array * a**2.0
+ grid % areaTriangle % array = grid % areaTriangle % array * a**2.0
+ grid % kiteAreasOnVertex % array = grid % kiteAreasOnVertex % array * a**2.0
+
+ !
+ ! Initialize wind field
+ !
+ allocate(psiVertex(grid % nVertices))
+ do iVtx=1,grid % nVertices
+ psiVertex(iVtx) = -a * a * w * sin(grid%latVertex%array(iVtx)) + &
+ a *a * K * (cos(grid%latVertex%array(iVtx))**R) * &
+ sin(grid%latVertex%array(iVtx)) * cos(R * grid%lonVertex%array(iVtx))
+ end do
+ do iEdge=1,grid % nEdges
+ state % u % array(1,iEdge) = -1.0 * ( &
+ psiVertex(grid%verticesOnEdge%array(2,iEdge)) - &
+ psiVertex(grid%verticesOnEdge%array(1,iEdge)) &
+ ) / grid%dvEdge%array(iEdge)
+ end do
+ deallocate(psiVertex)
+
+ !
+ ! Initialize height field (actually, fluid thickness field)
+ !
+ do iCell=1,grid % nCells
+ state % h % array(1,iCell) = (gravity * h0 + a*a*AA(grid%latCell%array(iCell)) + &
+ a*a*BB(grid%latCell%array(iCell)) * cos(R*grid%lonCell%array(iCell)) + &
+ a*a*CC(grid%latCell%array(iCell)) * cos(2.0*R*grid%lonCell%array(iCell)) &
+ ) / gravity
+ end do
+
+ end subroutine sw_test_case_6
+
+
+ real function sphere_distance(lat1, lon1, lat2, lon2, radius)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Compute the great-circle distance between (lat1, lon1) and (lat2, lon2) on a
+ ! sphere with given radius.
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ real (kind=RKIND), intent(in) :: lat1, lon1, lat2, lon2, radius
+
+ real (kind=RKIND) :: arg1
+
+ arg1 = sqrt( sin(0.5*(lat2-lat1))**2 + &
+ cos(lat1)*cos(lat2)*sin(0.5*(lon2-lon1))**2 )
+ sphere_distance = 2.*radius*asin(arg1)
+
+ end function sphere_distance
+
+
+ real function AA(theta)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! A, used in height field computation for Rossby-Haurwitz wave
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ real (kind=RKIND), parameter :: w = 7.848e-6
+ real (kind=RKIND), parameter :: K = 7.848e-6
+ real (kind=RKIND), parameter :: R = 4.0
+
+ real (kind=RKIND), intent(in) :: theta
+
+ AA = 0.5 * w * (2.0 * omega + w) * cos(theta)**2.0 + &
+ 0.25 * K**2.0 * cos(theta)**(2.0*R) * ((R+1.0)*cos(theta)**2.0 + 2.0*R**2.0 - R - 2.0 - 2.0*R**2.0 * cos(theta)**(-2.0))
+
+ end function AA
+
+
+ real function BB(theta)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! B, used in height field computation for Rossby-Haurwitz wave
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ real (kind=RKIND), parameter :: w = 7.848e-6
+ real (kind=RKIND), parameter :: K = 7.848e-6
+ real (kind=RKIND), parameter :: R = 4.0
+
+ real (kind=RKIND), intent(in) :: theta
+
+ BB = (2.0*(omega + w)*K / ((R+1.0)*(R+2.0))) * cos(theta)**R * ((R**2.0 + 2.0*R + 2.0) - ((R+1.0)*cos(theta))**2.0)
+
+ end function BB
+
+
+ real function CC(theta)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! C, used in height field computation for Rossby-Haurwitz wave
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ real (kind=RKIND), parameter :: w = 7.848e-6
+ real (kind=RKIND), parameter :: K = 7.848e-6
+ real (kind=RKIND), parameter :: R = 4.0
+
+ real (kind=RKIND), intent(in) :: theta
+
+ CC = 0.25 * K**2.0 * cos(theta)**(2.0*R) * ((R+1.0)*cos(theta)**2.0 - R - 2.0)
+
+ end function CC
+
+end module test_cases
Added: branches/ocean_projects/triangle_border_swm/src/core_sw/module_time_integration.F
===================================================================
--- branches/ocean_projects/triangle_border_swm/src/core_sw/module_time_integration.F (rev 0)
+++ branches/ocean_projects/triangle_border_swm/src/core_sw/module_time_integration.F 2011-04-29 18:46:19 UTC (rev 810)
@@ -0,0 +1,1274 @@
+module time_integration
+
+ use vector_reconstruction
+ use grid_types
+ use configure
+ use constants
+ use dmpar
+
+
+ contains
+
+
+ subroutine timestep(domain, dt)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Advance model state forward in time by the specified time step
+ !
+ ! Input: domain - current model state in time level 1 (e.g., time_levs(1)state%h(:,:))
+ ! plus grid meta-data
+ ! Output: domain - upon exit, time level 2 (e.g., time_levs(2)%state%h(:,:)) contains
+ ! model state advanced forward in time by dt seconds
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+ real (kind=RKIND), intent(in) :: dt
+
+ type (block_type), pointer :: block
+
+ if (trim(config_time_integration) == 'RK4') then
+ call rk4(domain, dt)
+ else
+ write(0,*) 'Unknown time integration option '//trim(config_time_integration)
+ write(0,*) 'Currently, only ''RK4'' is supported.'
+ stop
+ end if
+
+ block => domain % blocklist
+ do while (associated(block))
+ block % state % time_levs(2) % state % xtime % scalar = block % state % time_levs(1) % state % xtime % scalar + dt
+ block => block % next
+ end do
+
+ end subroutine timestep
+
+
+ subroutine rk4(domain, dt)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Advance model state forward in time by the specified time step using
+ ! 4th order Runge-Kutta
+ !
+ ! Input: domain - current model state in time level 1 (e.g., time_levs(1)state%h(:,:))
+ ! plus grid meta-data
+ ! Output: domain - upon exit, time level 2 (e.g., time_levs(2)%state%h(:,:)) contains
+ ! model state advanced forward in time by dt seconds
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+ real (kind=RKIND), intent(in) :: dt
+
+ integer :: iCell, k
+ type (block_type), pointer :: block
+ type (state_type) :: provis
+
+ integer :: rk_step
+
+ real (kind=RKIND), dimension(4) :: rk_weights, rk_substep_weights
+
+ block => domain % blocklist
+ call allocate_state(provis, &
+ block % mesh % nCells, block % mesh % nEdges, block % mesh % maxEdges, block % mesh % maxEdges2, &
+ block % mesh % nVertices, block % mesh % vertexDegree, block % mesh % nVertLevels, &
+ block % mesh % nTracers)
+
+ !
+ ! Initialize time_levs(2) with state at current time
+ ! Initialize first RK state
+ ! Couple tracers time_levs(2) with h in time-levels
+ ! Initialize RK weights
+ !
+ block => domain % blocklist
+ do while (associated(block))
+
+ block % state % time_levs(2) % state % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:)
+ block % state % time_levs(2) % state % h % array(:,:) = block % state % time_levs(1) % state % h % array(:,:)
+ do iCell=1,block % mesh % nCells ! couple tracers to h
+ do k=1,block % mesh % nVertLevels
+ block % state % time_levs(2) % state % tracers % array(:,k,iCell) = block % state % time_levs(1) % state % tracers % array(:,k,iCell) &
+ * block % state % time_levs(1) % state % h % array(k,iCell)
+ end do
+ end do
+
+ call copy_state(provis, block % state % time_levs(1) % state)
+
+ block => block % next
+ end do
+
+ rk_weights(1) = dt/6.
+ rk_weights(2) = dt/3.
+ rk_weights(3) = dt/3.
+ rk_weights(4) = dt/6.
+
+ rk_substep_weights(1) = dt/2.
+ rk_substep_weights(2) = dt/2.
+ rk_substep_weights(3) = dt
+ rk_substep_weights(4) = 0.
+
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! BEGIN RK loop
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ do rk_step = 1, 4
+
+! --- update halos for diagnostic variables
+
+ block => domain % blocklist
+ do while (associated(block))
+ call dmpar_exch_halo_field2dReal(domain % dminfo, provis % pv_edge % array(:,:), &
+ block % mesh % nVertLevels, block % mesh % nEdges, &
+ block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
+
+ if (config_h_mom_eddy_visc4 > 0.0) then
+ call dmpar_exch_halo_field2dReal(domain % dminfo, block % state % time_levs(2) % state % divergence % array(:,:), &
+ block % mesh % nVertLevels, block % mesh % nCells, &
+ block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ call dmpar_exch_halo_field2dReal(domain % dminfo, block % state % time_levs(2) % state % vorticity % array(:,:), &
+ block % mesh % nVertLevels, block % mesh % nVertices, &
+ block % parinfo % verticesToSend, block % parinfo % verticesToRecv)
+ end if
+
+ block => block % next
+ end do
+
+! --- compute tendencies
+
+ block => domain % blocklist
+ do while (associated(block))
+ call compute_tend(block % tend, provis, block % mesh)
+ call compute_scalar_tend(block % tend, provis, block % mesh)
+ call enforce_boundaryEdge(block % tend, block % mesh)
+ block => block % next
+ end do
+
+! --- update halos for prognostic variables
+
+ block => domain % blocklist
+ do while (associated(block))
+ call dmpar_exch_halo_field2dReal(domain % dminfo, block % tend % u % array(:,:), &
+ block % mesh % nVertLevels, block % mesh % nEdges, &
+ block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
+ call dmpar_exch_halo_field2dReal(domain % dminfo, block % tend % h % array(:,:), &
+ block % mesh % nVertLevels, block % mesh % nCells, &
+ block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ call dmpar_exch_halo_field3dReal(domain % dminfo, block % tend % tracers % array(:,:,:), &
+ block % mesh % nTracers, block % mesh % nVertLevels, block % mesh % nCells, &
+ block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ block => block % next
+ end do
+
+! --- compute next substep state
+
+ if (rk_step < 4) then
+ block => domain % blocklist
+ do while (associated(block))
+ provis % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:) &
+ + rk_substep_weights(rk_step) * block % tend % u % array(:,:)
+ provis % h % array(:,:) = block % state % time_levs(1) % state % h % array(:,:) &
+ + rk_substep_weights(rk_step) * block % tend % h % array(:,:)
+ do iCell=1,block % mesh % nCells
+ do k=1,block % mesh % nVertLevels
+ provis % tracers % array(:,k,iCell) = ( &
+ block % state % time_levs(1) % state % h % array(k,iCell) * &
+ block % state % time_levs(1) % state % tracers % array(:,k,iCell) &
+ + rk_substep_weights(rk_step) * block % tend % tracers % array(:,k,iCell) &
+ ) / provis % h % array(k,iCell)
+ end do
+ end do
+ if (config_test_case == 1) then ! For case 1, wind field should be fixed
+ provis % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:)
+ end if
+ call compute_solve_diagnostics(dt, provis, block % mesh)
+ block => block % next
+ end do
+ end if
+
+!--- accumulate update (for RK4)
+
+ block => domain % blocklist
+ do while (associated(block))
+ block % state % time_levs(2) % state % u % array(:,:) = block % state % time_levs(2) % state % u % array(:,:) &
+ + rk_weights(rk_step) * block % tend % u % array(:,:)
+ block % state % time_levs(2) % state % h % array(:,:) = block % state % time_levs(2) % state % h % array(:,:) &
+ + rk_weights(rk_step) * block % tend % h % array(:,:)
+ do iCell=1,block % mesh % nCells
+ do k=1,block % mesh % nVertLevels
+ block % state % time_levs(2) % state % tracers % array(:,k,iCell) = &
+ block % state % time_levs(2) % state % tracers % array(:,k,iCell) &
+ + rk_weights(rk_step) * block % tend % tracers % array(:,k,iCell)
+ end do
+ end do
+ block => block % next
+ end do
+
+ end do
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! END RK loop
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+ !
+ ! A little clean up at the end: decouple new scalar fields and compute diagnostics for new state
+ !
+ block => domain % blocklist
+ do while (associated(block))
+ do iCell=1,block % mesh % nCells
+ do k=1,block % mesh % nVertLevels
+ block % state % time_levs(2) % state % tracers % array(:,k,iCell) = &
+ block % state % time_levs(2) % state % tracers % array(:,k,iCell) &
+ / block % state % time_levs(2) % state % h % array(k,iCell)
+ end do
+ end do
+
+ if (config_test_case == 1) then ! For case 1, wind field should be fixed
+ block % state % time_levs(2) % state % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:)
+ end if
+
+ call compute_solve_diagnostics(dt, block % state % time_levs(2) % state, block % mesh)
+
+ call reconstruct(block % state % time_levs(2) % state, block % mesh)
+
+ block => block % next
+ end do
+
+ call deallocate_state(provis)
+
+ end subroutine rk4
+
+
+ subroutine compute_tend(tend, s, grid)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Compute height and normal wind tendencies, as well as diagnostic variables
+ !
+ ! Input: s - current model state
+ ! grid - grid metadata
+ !
+ ! Output: tend - computed tendencies for prognostic variables
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (tend_type), intent(inout) :: tend
+ type (state_type), intent(in) :: s
+ type (mesh_type), intent(in) :: grid
+
+ integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j
+ real (kind=RKIND) :: flux, vorticity_abs, workpv, q, upstream_bias
+
+ integer :: nCells, nEdges, nVertices, nVertLevels
+ real (kind=RKIND), dimension(:), pointer :: h_s, fVertex, fEdge, dvEdge, dcEdge, areaCell, areaTriangle
+ real (kind=RKIND), dimension(:,:), pointer :: vh, weightsOnEdge, kiteAreasOnVertex, h_edge, h, u, v, tend_h, tend_u, &
+ circulation, vorticity, ke, pv_edge, divergence, h_vertex
+ integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnVertex, verticesOnEdge, edgesOnCell, edgesOnEdge, edgesOnVertex
+ integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge
+ real (kind=RKIND) :: r, u_diffusion
+
+ real (kind=RKIND), allocatable, dimension(:,:) :: delsq_divergence
+ real (kind=RKIND), allocatable, dimension(:,:) :: delsq_u
+ real (kind=RKIND), allocatable, dimension(:,:) :: delsq_circulation, delsq_vorticity
+
+ real (kind=RKIND), dimension(:,:), pointer :: u_src
+ real (kind=RKIND), parameter :: rho_ref = 1000.0
+ real (kind=RKIND) :: ke_edge
+
+ h => s % h % array
+ u => s % u % array
+ v => s % v % array
+ h_edge => s % h_edge % array
+ circulation => s % circulation % array
+ vorticity => s % vorticity % array
+ divergence => s % divergence % array
+ ke => s % ke % array
+ pv_edge => s % pv_edge % array
+ vh => s % vh % array
+
+ weightsOnEdge => grid % weightsOnEdge % array
+ kiteAreasOnVertex => grid % kiteAreasOnVertex % array
+ cellsOnEdge => grid % cellsOnEdge % array
+ cellsOnVertex => grid % cellsOnVertex % array
+ verticesOnEdge => grid % verticesOnEdge % array
+ nEdgesOnCell => grid % nEdgesOnCell % array
+ edgesOnCell => grid % edgesOnCell % array
+ nEdgesOnEdge => grid % nEdgesOnEdge % array
+ edgesOnEdge => grid % edgesOnEdge % array
+ edgesOnVertex => grid % edgesOnVertex % array
+ dcEdge => grid % dcEdge % array
+ dvEdge => grid % dvEdge % array
+ areaCell => grid % areaCell % array
+ areaTriangle => grid % areaTriangle % array
+ h_s => grid % h_s % array
+ fVertex => grid % fVertex % array
+ fEdge => grid % fEdge % array
+
+ tend_h => tend % h % array
+ tend_u => tend % u % array
+
+ nCells = grid % nCells
+ nEdges = grid % nEdges
+ nVertices = grid % nVertices
+ nVertLevels = grid % nVertLevels
+
+ u_src => grid % u_src % array
+
+ !
+ ! Compute height tendency for each cell
+ !
+ tend_h(:,:) = 0.0
+ do iEdge=1,nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ do k=1,nVertLevels
+ flux = u(k,iEdge) * dvEdge(iEdge) * h_edge(k,iEdge)
+ tend_h(k,cell1) = tend_h(k,cell1) - flux
+ tend_h(k,cell2) = tend_h(k,cell2) + flux
+ end do
+ end do
+ do iCell=1,grid % nCellsSolve
+ do k=1,nVertLevels
+ tend_h(k,iCell) = tend_h(k,iCell) / areaCell(iCell)
+ end do
+ end do
+
+#ifdef LANL_FORMULATION
+ !
+ ! Compute u (normal) velocity tendency for each edge (cell face)
+ !
+ tend_u(:,:) = 0.0
+ do iEdge=1,grid % nEdgesSolve
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ vertex1 = verticesOnEdge(1,iEdge)
+ vertex2 = verticesOnEdge(2,iEdge)
+
+ do k=1,nVertLevels
+ q = 0.0
+ do j = 1,nEdgesOnEdge(iEdge)
+ eoe = edgesOnEdge(j,iEdge)
+ workpv = 0.5 * (pv_edge(k,iEdge) + pv_edge(k,eoe))
+ q = q + weightsOnEdge(j,iEdge) * u(k,eoe) * workpv * h_edge(k,eoe)
+ end do
+
+ tend_u(k,iEdge) = &
+ q &
+ - ( ke(k,cell2) - ke(k,cell1) + &
+ gravity * (h(k,cell2) + h_s(cell2) - h(k,cell1) - h_s(cell1)) &
+ ) / dcEdge(iEdge)
+ end do
+ end do
+
+
+#endif
+
+#ifdef NCAR_FORMULATION
+ !
+ ! Compute u (normal) velocity tendency for each edge (cell face)
+ !
+ tend_u(:,:) = 0.0
+ do iEdge=1,grid % nEdgesSolve
+ vertex1 = verticesOnEdge(1,iEdge)
+ vertex2 = verticesOnEdge(2,iEdge)
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+
+ do k=1,nVertLevels
+ vorticity_abs = fEdge(iEdge) + (circulation(k,vertex1) + circulation(k,vertex2)) / &
+ (areaTriangle(vertex1) + areaTriangle(vertex2))
+
+ workpv = 2.0 * vorticity_abs / (h(k,cell1) + h(k,cell2))
+
+ tend_u(k,iEdge) = workpv * vh(k,iEdge) - &
+ (ke(k,cell2) - ke(k,cell1) + &
+ gravity * (h(k,cell2) + h_s(cell2) - h(k,cell1) - h_s(cell1)) &
+ ) / &
+ dcEdge(iEdge)
+ end do
+ end do
+#endif
+
+ ! Compute diffusion, computed as </font>
<font color="black">abla divergence - k \times </font>
<font color="blue">abla vorticity
+ ! only valid for visc == constant
+ if (config_h_mom_eddy_visc2 > 0.0) then
+ do iEdge=1,grid % nEdgesSolve
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ vertex1 = verticesOnEdge(1,iEdge)
+ vertex2 = verticesOnEdge(2,iEdge)
+
+ do k=1,nVertLevels
+ u_diffusion = ( divergence(k,cell2) - divergence(k,cell1) ) / dcEdge(iEdge) &
+ -(vorticity(k,vertex2) - vorticity(k,vertex1) ) / dvEdge(iEdge)
+ u_diffusion = config_h_mom_eddy_visc2 * u_diffusion
+ tend_u(k,iEdge) = tend_u(k,iEdge) + u_diffusion
+ end do
+ end do
+ end if
+
+ !
+ ! velocity tendency: del4 dissipation, -</font>
<font color="black">u_4 </font>
<font color="blue">abla^4 u
+ ! computed as </font>
<font color="black">abla^2 u = </font>
<font color="black">abla divergence + k \times </font>
<font color="blue">abla vorticity
+ ! applied recursively.
+ ! strictly only valid for h_mom_eddy_visc4 == constant
+ !
+ if (config_h_mom_eddy_visc4 > 0.0) then
+ allocate(delsq_divergence(nVertLevels, nCells+1))
+ allocate(delsq_u(nVertLevels, nEdges+1))
+ allocate(delsq_circulation(nVertLevels, nVertices+1))
+ allocate(delsq_vorticity(nVertLevels, nVertices+1))
+
+ delsq_u(:,:) = 0.0
+
+ ! Compute </font>
<font color="black">abla^2 u = </font>
<font color="black">abla divergence + k \times </font>
<font color="blue">abla vorticity
+ do iEdge=1,grid % nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ vertex1 = verticesOnEdge(1,iEdge)
+ vertex2 = verticesOnEdge(2,iEdge)
+
+ do k=1,nVertLevels
+
+ delsq_u(k,iEdge) = ( divergence(k,cell2) - divergence(k,cell1) ) / dcEdge(iEdge) &
+ -( vorticity(k,vertex2) - vorticity(k,vertex1)) / dvEdge(iEdge)
+
+ end do
+ end do
+
+ ! vorticity using </font>
<font color="blue">abla^2 u
+ delsq_circulation(:,:) = 0.0
+ do iEdge=1,nEdges
+ vertex1 = verticesOnEdge(1,iEdge)
+ vertex2 = verticesOnEdge(2,iEdge)
+ do k=1,nVertLevels
+ delsq_circulation(k,vertex1) = delsq_circulation(k,vertex1) &
+ - dcEdge(iEdge) * delsq_u(k,iEdge)
+ delsq_circulation(k,vertex2) = delsq_circulation(k,vertex2) &
+ + dcEdge(iEdge) * delsq_u(k,iEdge)
+ end do
+ end do
+ do iVertex=1,nVertices
+ r = 1.0 / areaTriangle(iVertex)
+ do k=1,nVertLevels
+ delsq_vorticity(k,iVertex) = delsq_circulation(k,iVertex) * r
+ end do
+ end do
+
+ ! Divergence using </font>
<font color="blue">abla^2 u
+ delsq_divergence(:,:) = 0.0
+ do iEdge=1,nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ do k=1,nVertLevels
+ delsq_divergence(k,cell1) = delsq_divergence(k,cell1) &
+ + delsq_u(k,iEdge)*dvEdge(iEdge)
+ delsq_divergence(k,cell2) = delsq_divergence(k,cell2) &
+ - delsq_u(k,iEdge)*dvEdge(iEdge)
+ end do
+ end do
+ do iCell = 1,nCells
+ r = 1.0 / areaCell(iCell)
+ do k = 1,nVertLevels
+ delsq_divergence(k,iCell) = delsq_divergence(k,iCell) * r
+ end do
+ end do
+
+ ! Compute - \kappa </font>
<font color="blue">abla^4 u
+ ! as </font>
<font color="black">abla div(</font>
<font color="black">abla^2 u) + k \times </font>
<font color="black">abla ( k \cross curl(</font>
<font color="blue">abla^2 u) )
+ do iEdge=1,grid % nEdgesSolve
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ vertex1 = verticesOnEdge(1,iEdge)
+ vertex2 = verticesOnEdge(2,iEdge)
+
+ do k=1,nVertLevels
+
+ u_diffusion = ( delsq_divergence(k,cell2) &
+ - delsq_divergence(k,cell1) ) / dcEdge(iEdge) &
+ -( delsq_vorticity(k,vertex2) &
+ - delsq_vorticity(k,vertex1) ) / dvEdge(iEdge)
+
+ u_diffusion = config_h_mom_eddy_visc4 * u_diffusion
+ tend_u(k,iEdge) = tend_u(k,iEdge) - u_diffusion
+
+ end do
+ end do
+
+ deallocate(delsq_divergence)
+ deallocate(delsq_u)
+ deallocate(delsq_circulation)
+ deallocate(delsq_vorticity)
+
+ end if
+
+ ! Compute u (velocity) tendency from wind stress (u_src)
+ if(config_wind_stress) then
+ do iEdge=1,grid % nEdges
+ tend_u(1,iEdge) = tend_u(1,iEdge) &
+ + u_src(1,iEdge)/rho_ref/h_edge(1,iEdge)
+ end do
+ endif
+
+ if (config_bottom_drag) then
+ do iEdge=1,grid % nEdges
+ ! bottom drag is the same as POP:
+ ! -c |u| u where c is unitless and 1.0e-3.
+ ! see POP Reference guide, section 3.4.4.
+ ke_edge = 0.5 * ( ke(1,cellsOnEdge(1,iEdge)) &
+ + ke(1,cellsOnEdge(2,iEdge)))
+
+ tend_u(1,iEdge) = tend_u(1,iEdge) &
+ - 1.0e-3*u(1,iEdge) &
+ *sqrt(2.0*ke_edge)/h_edge(1,iEdge)
+ end do
+ endif
+
+ end subroutine compute_tend
+
+
+ subroutine compute_scalar_tend(tend, s, grid)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !
+ ! Input: s - current model state
+ ! grid - grid metadata
+ !
+ ! Output: tend - computed scalar tendencies
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (tend_type), intent(inout) :: tend
+ type (state_type), intent(in) :: s
+ type (mesh_type), intent(in) :: grid
+
+ integer :: iCell, iEdge, k, iTracer, cell1, cell2, i
+ real (kind=RKIND) :: flux, tracer_edge, r
+ real (kind=RKIND) :: invAreaCell1, invAreaCell2, tracer_turb_flux
+ integer, dimension(:,:), pointer :: boundaryEdge
+ real (kind=RKIND), dimension(:,:), allocatable :: boundaryMask
+ real (kind=RKIND), dimension(:,:,:), allocatable:: delsq_tracer
+
+ real (kind=RKIND) :: d2fdx2_cell1, d2fdx2_cell2
+ real (kind=RKIND), dimension(:), pointer :: dvEdge, dcEdge, areaCell
+ real (kind=RKIND), dimension(:,:,:), pointer :: tracers, tracer_tend
+ integer, dimension(:,:), pointer :: cellsOnEdge, boundaryCell
+ real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
+ real (kind=RKIND) :: coef_3rd_order
+ real (kind=RKIND), dimension(:,:), pointer :: u, h_edge
+
+ u => s % u % array
+ h_edge => s % h_edge % array
+ dcEdge => grid % dcEdge % array
+ deriv_two => grid % deriv_two % array
+ dvEdge => grid % dvEdge % array
+ tracers => s % tracers % array
+ cellsOnEdge => grid % cellsOnEdge % array
+ boundaryCell=> grid % boundaryCell % array
+ boundaryEdge=> grid % boundaryEdge % array
+ areaCell => grid % areaCell % array
+ tracer_tend => tend % tracers % array
+
+ coef_3rd_order = 0.
+ if (config_tracer_adv_order == 3) coef_3rd_order = 1.0
+ if (config_tracer_adv_order == 3 .and. config_monotonic) coef_3rd_order = 0.25
+
+
+ tracer_tend(:,:,:) = 0.0
+
+ if (config_tracer_adv_order == 2) then
+
+ do iEdge=1,grid % nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ if (cell1 <= grid%nCells .and. cell2 <= grid%nCells) then
+ do k=1,grid % nVertLevels
+ do iTracer=1,grid % nTracers
+ tracer_edge = 0.5 * (tracers(iTracer,k,cell1) + tracers(iTracer,k,cell2))
+ flux = u(k,iEdge) * dvEdge(iEdge) * h_edge(k,iEdge) * tracer_edge
+ tracer_tend(iTracer,k,cell1) = tracer_tend(iTracer,k,cell1) - flux/areaCell(cell1)
+ tracer_tend(iTracer,k,cell2) = tracer_tend(iTracer,k,cell2) + flux/areaCell(cell2)
+ end do
+ end do
+ end if
+ end do
+
+ else if (config_tracer_adv_order == 3) then
+
+ do iEdge=1,grid%nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+
+ !-- if a cell not on the most outside ring of the halo
+ if (cell1 <= grid%nCells .and. cell2 <= grid%nCells) then
+
+ do k=1,grid % nVertLevels
+
+ d2fdx2_cell1 = 0.0
+ d2fdx2_cell2 = 0.0
+
+ do iTracer=1,grid % nTracers
+
+ !-- if not a boundary cell
+ if(boundaryCell(k,cell1).eq.0.and.boundaryCell(k,cell2).eq.0) then
+
+ d2fdx2_cell1 = deriv_two(1,1,iEdge) * tracers(iTracer,k,cell1)
+ d2fdx2_cell2 = deriv_two(1,2,iEdge) * tracers(iTracer,k,cell2)
+
+ !-- all edges of cell 1
+ do i=1, grid % nEdgesOnCell % array (cell1)
+ d2fdx2_cell1 = d2fdx2_cell1 + &
+ deriv_two(i+1,1,iEdge) * tracers(iTracer,k,grid % CellsOnCell % array (i,cell1))
+ end do
+
+ !-- all edges of cell 2
+ do i=1, grid % nEdgesOnCell % array (cell2)
+ d2fdx2_cell2 = d2fdx2_cell2 + &
+ deriv_two(i+1,2,iEdge) * tracers(iTracer,k,grid % CellsOnCell % array (i,cell2))
+ end do
+
+ endif
+
+ !-- if u > 0:
+ if (u(k,iEdge) > 0) then
+ flux = dvEdge(iEdge) * u(k,iEdge) * h_edge(k,iEdge) * ( &
+ 0.5*(tracers(iTracer,k,cell1) + tracers(iTracer,k,cell2)) &
+ -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
+ -(dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12. )
+ !-- else u <= 0:
+ else
+ flux = dvEdge(iEdge) * u(k,iEdge) * h_edge(k,iEdge) * ( &
+ 0.5*(tracers(iTracer,k,cell1) + tracers(iTracer,k,cell2)) &
+ -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
+ +(dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12. )
+ end if
+
+ !-- update tendency
+ tracer_tend(iTracer,k,cell1) = tracer_tend(iTracer,k,cell1) - flux/areaCell(cell1)
+ tracer_tend(iTracer,k,cell2) = tracer_tend(iTracer,k,cell2) + flux/areaCell(cell2)
+ enddo
+ end do
+ end if
+ end do
+
+ else if (config_tracer_adv_order == 4) then
+
+ do iEdge=1,grid%nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+
+ !-- if an edge is not on the outer-most ring of the halo
+ if (cell1 <= grid%nCells .and. cell2 <= grid%nCells) then
+
+ do k=1,grid % nVertLevels
+
+ d2fdx2_cell1 = 0.0
+ d2fdx2_cell2 = 0.0
+
+ do iTracer=1,grid % nTracers
+
+ !-- if not a boundary cell
+ if(boundaryCell(k,cell1).eq.0.and.boundaryCell(k,cell2).eq.0) then
+
+ d2fdx2_cell1 = deriv_two(1,1,iEdge) * tracers(iTracer,k,cell1)
+ d2fdx2_cell2 = deriv_two(1,2,iEdge) * tracers(iTracer,k,cell2)
+
+ !-- all edges of cell 1
+ do i=1, grid % nEdgesOnCell % array (cell1)
+ d2fdx2_cell1 = d2fdx2_cell1 + &
+ deriv_two(i+1,1,iEdge) * tracers(iTracer,k,grid % CellsOnCell % array (i,cell1))
+ end do
+
+ !-- all edges of cell 2
+ do i=1, grid % nEdgesOnCell % array (cell2)
+ d2fdx2_cell2 = d2fdx2_cell2 + &
+ deriv_two(i+1,2,iEdge) * tracers(iTracer,k,grid % CellsOnCell % array (i,cell2))
+ end do
+
+ endif
+
+ flux = dvEdge(iEdge) * u(k,iEdge) * h_edge(k,iEdge) * ( &
+ 0.5*(tracers(iTracer,k,cell1) + tracers(iTracer,k,cell2)) &
+ -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. )
+
+ !-- update tendency
+ tracer_tend(iTracer,k,cell1) = tracer_tend(iTracer,k,cell1) - flux/areaCell(cell1)
+ tracer_tend(iTracer,k,cell2) = tracer_tend(iTracer,k,cell2) + flux/areaCell(cell2)
+ enddo
+ end do
+ end if
+ end do
+
+ endif ! if (config_tracer_adv_order == 2 )
+
+ !
+ ! tracer tendency: del2 horizontal tracer diffusion, div(h \kappa_2 </font>
<font color="blue">abla \phi)
+ !
+ if ( config_h_tracer_eddy_diff2 > 0.0 ) then
+
+ !
+ ! compute a boundary mask to enforce insulating boundary conditions in the horizontal
+ !
+ allocate(boundaryMask(grid % nVertLevels, grid % nEdges+1))
+ boundaryMask = 1.0
+ where(boundaryEdge.eq.1) boundaryMask=0.0
+
+ do iEdge=1,grid % nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ invAreaCell1 = 1.0/areaCell(cell1)
+ invAreaCell2 = 1.0/areaCell(cell2)
+
+ do k=1,grid % nVertLevels
+ do iTracer=1, grid % nTracers
+ ! \kappa_2 </font>
<font color="blue">abla \phi on edge
+ tracer_turb_flux = config_h_tracer_eddy_diff2 &
+ *( tracers(iTracer,k,cell2) - tracers(iTracer,k,cell1)) / dcEdge(iEdge)
+
+ ! div(h \kappa_2 </font>
<font color="blue">abla \phi) at cell center
+ flux = dvEdge(iEdge) * h_edge(k,iEdge) * tracer_turb_flux * boundaryMask(k, iEdge)
+ tracer_tend(iTracer,k,cell1) = tracer_tend(iTracer,k,cell1) + flux * invAreaCell1
+ tracer_tend(iTracer,k,cell2) = tracer_tend(iTracer,k,cell2) - flux * invAreaCell2
+ end do
+ end do
+
+ end do
+
+ deallocate(boundaryMask)
+
+ end if
+
+ !
+ ! tracer tendency: del4 horizontal tracer diffusion, &
+ ! div(h \kappa_4 </font>
<font color="black">abla [div(h </font>
<font color="blue">abla \phi)])
+ !
+ if ( config_h_tracer_eddy_diff4 > 0.0 ) then
+
+ !
+ ! compute a boundary mask to enforce insulating boundary conditions in the horizontal
+ !
+ allocate(boundaryMask(grid % nVertLevels, grid % nEdges+1))
+ boundaryMask = 1.0
+ where(boundaryEdge.eq.1) boundaryMask=0.0
+
+ allocate(delsq_tracer(grid % nTracers, grid % nVertLevels, grid % nCells+1))
+
+ delsq_tracer(:,:,:) = 0.
+
+ ! first del2: div(h </font>
<font color="blue">abla \phi) at cell center
+ do iEdge=1,grid % nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+
+ do k=1,grid % nVertLevels
+ do iTracer=1, grid % nTracers
+ delsq_tracer(iTracer,k,cell1) = delsq_tracer(iTracer,k,cell1) &
+ + dvEdge(iEdge) * h_edge(k,iEdge) * (tracers(iTracer,k,cell2) - tracers(iTracer,k,cell1)) / dcEdge(iEdge) * boundaryMask(k,iEdge)
+ delsq_tracer(iTracer,k,cell2) = delsq_tracer(iTracer,k,cell2) &
+ - dvEdge(iEdge) * h_edge(k,iEdge) * (tracers(iTracer,k,cell2) - tracers(iTracer,k,cell1)) / dcEdge(iEdge) * boundaryMask(k,iEdge)
+ end do
+ end do
+
+ end do
+
+ do iCell = 1, grid % nCells
+ r = 1.0 / grid % areaCell % array(iCell)
+ do k=1,grid % nVertLevels
+ do iTracer=1,grid % nTracers
+ delsq_tracer(iTracer,k,iCell) = delsq_tracer(iTracer,k,iCell) * r
+ end do
+ end do
+ end do
+
+ ! second del2: div(h </font>
<font color="gray">abla [delsq_tracer]) at cell center
+ do iEdge=1,grid % nEdges
+ cell1 = grid % cellsOnEdge % array(1,iEdge)
+ cell2 = grid % cellsOnEdge % array(2,iEdge)
+ invAreaCell1 = 1.0 / grid % areaCell % array(cell1)
+ invAreaCell2 = 1.0 / grid % areaCell % array(cell2)
+
+ do k=1,grid % nVertLevels
+ do iTracer=1,grid % nTracers
+ tracer_turb_flux = config_h_tracer_eddy_diff4 * (delsq_tracer(iTracer,k,cell2) - delsq_tracer(iTracer,k,cell1)) / dcEdge(iEdge)
+ flux = dvEdge(iEdge) * tracer_turb_flux
+ tracer_tend(iTracer,k,cell1) = tracer_tend(iTracer,k,cell1) - flux * invAreaCell1 * boundaryMask(k,iEdge)
+ tracer_tend(iTracer,k,cell2) = tracer_tend(iTracer,k,cell2) + flux * invAreaCell2 * boundaryMask(k,iEdge)
+ end do
+ enddo
+
+ end do
+
+ deallocate(delsq_tracer)
+ deallocate(boundaryMask)
+
+ end if
+
+ end subroutine compute_scalar_tend
+
+
+ subroutine compute_solve_diagnostics(dt, s, grid)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Compute diagnostic fields used in the tendency computations
+ !
+ ! Input: grid - grid metadata
+ !
+ ! Output: s - computed diagnostics
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ real (kind=RKIND), intent(in) :: dt
+ type (state_type), intent(inout) :: s
+ type (mesh_type), intent(in) :: grid
+
+
+ integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j, cov
+ real (kind=RKIND) :: flux, vorticity_abs, workpv
+
+ integer :: nCells, nEdges, nVertices, nVertLevels
+ real (kind=RKIND), dimension(:), pointer :: h_s, fVertex, fEdge, dvEdge, dcEdge, areaCell, areaTriangle
+ real (kind=RKIND), dimension(:,:), pointer :: vh, weightsOnEdge, kiteAreasOnVertex, h_edge, h, u, v, tend_h, tend_u, &
+ circulation, vorticity, ke, pv_edge, pv_vertex, pv_cell, gradPVn, gradPVt, divergence, &
+ h_vertex, vorticity_cell
+ integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnVertex, verticesOnEdge, edgesOnCell, edgesOnEdge, edgesOnVertex, boundaryEdge, boundaryCell
+ integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge
+ real (kind=RKIND) :: r, h1, h2
+ real (kind=RKIND) :: d2fdx2_cell1, d2fdx2_cell2
+ real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
+ real (kind=RKIND) :: coef_3rd_order
+
+ h => s % h % array
+ u => s % u % array
+ v => s % v % array
+ vh => s % vh % array
+ h_edge => s % h_edge % array
+ h_vertex => s % h_vertex % array
+ tend_h => s % h % array
+ tend_u => s % u % array
+ circulation => s % circulation % array
+ vorticity => s % vorticity % array
+ divergence => s % divergence % array
+ ke => s % ke % array
+ pv_edge => s % pv_edge % array
+ pv_vertex => s % pv_vertex % array
+ pv_cell => s % pv_cell % array
+ vorticity_cell => s % vorticity_cell % array
+ gradPVn => s % gradPVn % array
+ gradPVt => s % gradPVt % array
+
+ weightsOnEdge => grid % weightsOnEdge % array
+ kiteAreasOnVertex => grid % kiteAreasOnVertex % array
+ cellsOnEdge => grid % cellsOnEdge % array
+ cellsOnVertex => grid % cellsOnVertex % array
+ verticesOnEdge => grid % verticesOnEdge % array
+ nEdgesOnCell => grid % nEdgesOnCell % array
+ edgesOnCell => grid % edgesOnCell % array
+ nEdgesOnEdge => grid % nEdgesOnEdge % array
+ edgesOnEdge => grid % edgesOnEdge % array
+ edgesOnVertex => grid % edgesOnVertex % array
+ dcEdge => grid % dcEdge % array
+ dvEdge => grid % dvEdge % array
+ areaCell => grid % areaCell % array
+ areaTriangle => grid % areaTriangle % array
+ h_s => grid % h_s % array
+ fVertex => grid % fVertex % array
+ fEdge => grid % fEdge % array
+ deriv_two => grid % deriv_two % array
+
+ nCells = grid % nCells
+ nEdges = grid % nEdges
+ nVertices = grid % nVertices
+ nVertLevels = grid % nVertLevels
+
+ boundaryEdge => grid % boundaryEdge % array
+ boundaryCell => grid % boundaryCell % array
+
+ !
+ ! Find those cells that have an edge on the boundary
+ !
+ boundaryCell(:,:) = 0
+ do iEdge=1,nEdges
+ do k=1,nVertLevels
+ if(boundaryEdge(k,iEdge).eq.1) then
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ boundaryCell(k,cell1) = 1
+ boundaryCell(k,cell2) = 1
+ endif
+ enddo
+ enddo
+
+ !
+ ! Compute height on cell edges at velocity locations
+ ! Namelist options control the order of accuracy of the reconstructed h_edge value
+ !
+
+ coef_3rd_order = 0.
+ if (config_thickness_adv_order == 3) coef_3rd_order = 1.0
+ if (config_thickness_adv_order == 3 .and. config_monotonic) coef_3rd_order = 0.25
+
+ if (config_thickness_adv_order == 2) then
+
+ do iEdge=1,grid % nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ if (cell1 <= grid%nCells .and. cell2 <= grid%nCells) then
+ do k=1,grid % nVertLevels
+ h_edge(k,iEdge) = 0.5 * (h(k,cell1) + h(k,cell2))
+ end do
+ end if
+ end do
+
+ else if (config_thickness_adv_order == 3) then
+
+ do iEdge=1,grid%nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+
+ !-- if a cell not on the most outside ring of the halo
+ if (cell1 <= grid%nCells .and. cell2 <= grid%nCells) then
+
+ do k=1,grid % nVertLevels
+
+ d2fdx2_cell1 = 0.0
+ d2fdx2_cell2 = 0.0
+
+ !-- if not a boundary cell
+ if(boundaryCell(k,cell1).eq.0.and.boundaryCell(k,cell2).eq.0) then
+
+ d2fdx2_cell1 = deriv_two(1,1,iEdge) * h(k,cell1)
+ d2fdx2_cell2 = deriv_two(1,2,iEdge) * h(k,cell2)
+
+ !-- all edges of cell 1
+ do i=1, grid % nEdgesOnCell % array (cell1)
+ d2fdx2_cell1 = d2fdx2_cell1 + &
+ deriv_two(i+1,1,iEdge) * h(k,grid % CellsOnCell % array (i,cell1))
+ end do
+
+ !-- all edges of cell 2
+ do i=1, grid % nEdgesOnCell % array (cell2)
+ d2fdx2_cell2 = d2fdx2_cell2 + &
+ deriv_two(i+1,2,iEdge) * h(k,grid % CellsOnCell % array (i,cell2))
+ end do
+
+ endif
+
+ !-- if u > 0:
+ if (u(k,iEdge) > 0) then
+ h_edge(k,iEdge) = &
+ 0.5*(h(k,cell1) + h(k,cell2)) &
+ -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
+ -(dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12.
+ !-- else u <= 0:
+ else
+ h_edge(k,iEdge) = &
+ 0.5*(h(k,cell1) + h(k,cell2)) &
+ -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
+ +(dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12.
+ end if
+
+ end do ! do k
+ end if ! if (cell1 <=
+ end do ! do iEdge
+
+ else if (config_thickness_adv_order == 4) then
+
+ do iEdge=1,grid%nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+
+ !-- if a cell not on the most outside ring of the halo
+ if (cell1 <= grid%nCells .and. cell2 <= grid%nCells) then
+
+ do k=1,grid % nVertLevels
+
+ d2fdx2_cell1 = 0.0
+ d2fdx2_cell2 = 0.0
+
+ !-- if not a boundary cell
+ if(boundaryCell(k,cell1).eq.0.and.boundaryCell(k,cell2).eq.0) then
+
+ d2fdx2_cell1 = deriv_two(1,1,iEdge) * h(k,cell1)
+ d2fdx2_cell2 = deriv_two(1,2,iEdge) * h(k,cell2)
+
+ !-- all edges of cell 1
+ do i=1, grid % nEdgesOnCell % array (cell1)
+ d2fdx2_cell1 = d2fdx2_cell1 + &
+ deriv_two(i+1,1,iEdge) * h(k,grid % CellsOnCell % array (i,cell1))
+ end do
+
+ !-- all edges of cell 2
+ do i=1, grid % nEdgesOnCell % array (cell2)
+ d2fdx2_cell2 = d2fdx2_cell2 + &
+ deriv_two(i+1,2,iEdge) * h(k,grid % CellsOnCell % array (i,cell2))
+ end do
+
+ endif
+
+ h_edge(k,iEdge) = &
+ 0.5*(h(k,cell1) + h(k,cell2)) &
+ -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12.
+
+ end do ! do k
+ end if ! if (cell1 <=
+ end do ! do iEdge
+
+ endif ! if(config_thickness_adv_order == 2)
+
+ !
+ ! set the velocity in the nEdges+1 slot to zero, this is a dummy address
+ ! used to when reading for edges that do not exist
+ !
+ u(:,nEdges+1) = 0.0
+
+ !
+ ! Compute circulation and relative vorticity at each vertex
+ !
+ circulation(:,:) = 0.0
+ do iEdge=1,nEdges
+ 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
+ vorticity(k,iVertex) = circulation(k,iVertex) / areaTriangle(iVertex)
+ end do
+ end do
+
+
+ !
+ ! Compute the divergence at each cell center
+ !
+ divergence(:,:) = 0.0
+ do iEdge=1,nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ if (cell1 <= nCells) then
+ do k=1,nVertLevels
+ divergence(k,cell1) = divergence(k,cell1) + u(k,iEdge)*dvEdge(iEdge)
+ enddo
+ endif
+ if(cell2 <= nCells) then
+ do k=1,nVertLevels
+ divergence(k,cell2) = divergence(k,cell2) - u(k,iEdge)*dvEdge(iEdge)
+ enddo
+ end if
+ end do
+ do iCell = 1,nCells
+ r = 1.0 / areaCell(iCell)
+ do k = 1,nVertLevels
+ divergence(k,iCell) = divergence(k,iCell) * r
+ enddo
+ enddo
+
+ !
+ ! Compute kinetic energy in each cell
+ !
+ ke(:,:) = 0.0
+ do iCell=1,nCells
+ do i=1,nEdgesOnCell(iCell)
+ iEdge = edgesOnCell(i,iCell)
+ do k=1,nVertLevels
+ ke(k,iCell) = ke(k,iCell) + 0.25 * dcEdge(iEdge) * dvEdge(iEdge) * u(k,iEdge)**2.0
+ end do
+ end do
+ do k=1,nVertLevels
+ ke(k,iCell) = ke(k,iCell) / areaCell(iCell)
+ end do
+ end do
+
+ !
+ ! Compute v (tangential) velocities
+ !
+ v(:,:) = 0.0
+ do iEdge = 1,nEdges
+ do i=1,nEdgesOnEdge(iEdge)
+ eoe = edgesOnEdge(i,iEdge)
+ do k = 1,nVertLevels
+ v(k,iEdge) = v(k,iEdge) + weightsOnEdge(i,iEdge) * u(k, eoe)
+ end do
+ end do
+ end do
+
+#ifdef NCAR_FORMULATION
+ !
+ ! Compute mass fluxes tangential to each edge (i.e., through the faces of dual grid cells)
+ !
+ vh(:,:) = 0.0
+ do iEdge=1,grid % nEdgesSolve
+ do j=1,nEdgesOnEdge(iEdge)
+ eoe = edgesOnEdge(j,iEdge)
+ do k=1,nVertLevels
+ vh(k,iEdge) = vh(k,iEdge) + weightsOnEdge(j,iEdge) * u(k,eoe) * h_edge(k,eoe)
+ end do
+ end do
+ end do
+#endif
+
+
+ !
+ ! Compute height at vertices, pv at vertices, and average pv to edge locations
+ ! ( this computes pv_vertex at all vertices bounding real cells and distance-1 ghost cells )
+ !
+ do iVertex = 1,nVertices
+ do k=1,nVertLevels
+ h_vertex(k,iVertex) = 0.0
+ do i=1,grid % vertexDegree
+ h_vertex(k,iVertex) = h_vertex(k,iVertex) + h(k,cellsOnVertex(i,iVertex)) * kiteAreasOnVertex(i,iVertex)
+ end do
+ h_vertex(k,iVertex) = h_vertex(k,iVertex) / areaTriangle(iVertex)
+
+ pv_vertex(k,iVertex) = (fVertex(iVertex) + vorticity(k,iVertex)) / h_vertex(k,iVertex)
+ end do
+ end do
+
+
+ !
+ ! Compute gradient of PV in the tangent direction
+ ! ( this computes gradPVt at all edges bounding real cells and distance-1 ghost cells )
+ !
+ do iEdge = 1,nEdges
+ do k = 1,nVertLevels
+ gradPVt(k,iEdge) = (pv_vertex(k,verticesOnEdge(2,iEdge)) - pv_vertex(k,verticesOnEdge(1,iEdge))) / &
+ dvEdge(iEdge)
+ enddo
+ enddo
+
+ !
+ ! Compute pv at the edges
+ ! ( 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)
+ do k=1,nVertLevels
+ pv_edge(k,iEdge) = pv_edge(k,iEdge) + 0.5 * pv_vertex(k,iVertex)
+ end do
+ end do
+ end do
+
+
+ !
+ ! Modify PV edge with upstream bias.
+ !
+ do iEdge = 1,nEdges
+ do k = 1,nVertLevels
+ pv_edge(k,iEdge) = pv_edge(k,iEdge) - config_apvm_upwinding * v(k,iEdge) * dt * gradPVt(k,iEdge)
+ enddo
+ enddo
+
+
+ !
+ ! Compute pv at cell centers
+ ! ( this computes pv_cell for all real cells and distance-1 ghost cells )
+ !
+ pv_cell(:,:) = 0.0
+ vorticity_cell(:,:) = 0.0
+ do iVertex = 1, nVertices
+ do i=1,grid % vertexDegree
+ iCell = cellsOnVertex(i,iVertex)
+ if (iCell <= nCells) then
+ do k = 1,nVertLevels
+ pv_cell(k,iCell) = pv_cell(k,iCell) + kiteAreasOnVertex(i, iVertex) * pv_vertex(k, iVertex) / areaCell(iCell)
+ vorticity_cell(k,iCell) = vorticity_cell(k,iCell) + kiteAreasOnVertex(i, iVertex) * vorticity(k, iVertex) / areaCell(iCell)
+ enddo
+ endif
+ enddo
+ enddo
+
+
+ !
+ ! Compute gradient of PV in normal direction
+ ! ( this computes gradPVn for all edges bounding real cells )
+ !
+ gradPVn(:,:) = 0.0
+ do iEdge = 1,nEdges
+ if( cellsOnEdge(1,iEdge) <= nCells .and. cellsOnEdge(2,iEdge) <= nCells) then
+ do k = 1,nVertLevels
+ gradPVn(k,iEdge) = (pv_cell(k,cellsOnEdge(2,iEdge)) - pv_cell(k,cellsOnEdge(1,iEdge))) / &
+ dcEdge(iEdge)
+ enddo
+ endif
+ enddo
+
+ ! Modify PV edge with upstream bias.
+ !
+ do iEdge = 1,nEdges
+ do k = 1,nVertLevels
+ pv_edge(k,iEdge) = pv_edge(k,iEdge) - config_apvm_upwinding * u(k,iEdge) * dt * gradPVn(k,iEdge)
+ enddo
+ enddo
+
+ !
+ ! set pv_edge = fEdge / h_edge at boundary points
+ !
+ ! if (maxval(boundaryEdge).ge.0) then
+ ! do iEdge = 1,nEdges
+ ! cell1 = cellsOnEdge(1,iEdge)
+ ! cell2 = cellsOnEdge(2,iEdge)
+ ! do k = 1,nVertLevels
+ ! if(boundaryEdge(k,iEdge).eq.1) then
+ ! v(k,iEdge) = 0.0
+ ! if(cell1.gt.0) then
+ ! h1 = h(k,cell1)
+ ! pv_edge(k,iEdge) = fEdge(iEdge) / h1
+ ! h_edge(k,iEdge) = h1
+ ! else
+ ! h2 = h(k,cell2)
+ ! pv_edge(k,iEdge) = fEdge(iEdge) / h2
+ ! h_edge(k,iEdge) = h2
+ ! endif
+ ! endif
+ ! enddo
+ ! enddo
+ ! endif
+
+
+ end subroutine compute_solve_diagnostics
+
+
+ subroutine enforce_boundaryEdge(tend, grid)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Enforce any boundary conditions on the normal velocity at each edge
+ !
+ ! Input: grid - grid metadata
+ !
+ ! Output: tend_u set to zero at boundaryEdge == 1 locations
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+ implicit none
+
+ type (tend_type), intent(inout) :: tend
+ type (mesh_type), intent(in) :: grid
+
+ integer, dimension(:,:), pointer :: boundaryEdge
+ real (kind=RKIND), dimension(:,:), pointer :: tend_u
+ integer :: nCells, nEdges, nVertices, nVertLevels
+ integer :: iEdge, k
+
+ nCells = grid % nCells
+ nEdges = grid % nEdges
+ nVertices = grid % nVertices
+ nVertLevels = grid % nVertLevels
+
+ boundaryEdge => grid % boundaryEdge % array
+ tend_u => tend % u % array
+
+ if(maxval(boundaryEdge).le.0) return
+
+ do iEdge = 1,nEdges
+ do k = 1,nVertLevels
+
+ if(boundaryEdge(k,iEdge).eq.1) then
+ tend_u(k,iEdge) = 0.0
+ endif
+
+ enddo
+ enddo
+
+ end subroutine enforce_boundaryEdge
+
+
+end module time_integration
Added: branches/ocean_projects/triangle_border_swm/src/driver/Makefile
===================================================================
--- branches/ocean_projects/triangle_border_swm/src/driver/Makefile (rev 0)
+++ branches/ocean_projects/triangle_border_swm/src/driver/Makefile 2011-04-29 18:46:19 UTC (rev 810)
@@ -0,0 +1,18 @@
+.SUFFIXES: .F .o
+
+OBJS = module_mpas_subdriver.o \
+ mpas.o
+
+all: $(OBJS)
+
+module_mpas_subdriver.o:
+
+mpas.o: module_mpas_subdriver.o
+
+clean:
+ $(RM) *.o *.mod *.f90
+
+.F.o:
+ $(RM) $@ $*.mod
+ $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90
+ $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../framework -I../core_$(CORE)
Added: branches/ocean_projects/triangle_border_swm/src/driver/module_mpas_subdriver.F
===================================================================
--- branches/ocean_projects/triangle_border_swm/src/driver/module_mpas_subdriver.F (rev 0)
+++ branches/ocean_projects/triangle_border_swm/src/driver/module_mpas_subdriver.F 2011-04-29 18:46:19 UTC (rev 810)
@@ -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
Added: branches/ocean_projects/triangle_border_swm/src/driver/mpas.F
===================================================================
--- branches/ocean_projects/triangle_border_swm/src/driver/mpas.F (rev 0)
+++ branches/ocean_projects/triangle_border_swm/src/driver/mpas.F 2011-04-29 18:46:19 UTC (rev 810)
@@ -0,0 +1,15 @@
+program mpas
+
+ use mpas_subdriver
+
+ implicit none
+
+ call mpas_init()
+
+ call mpas_run()
+
+ call mpas_finalize()
+
+ stop
+
+end program mpas
Added: branches/ocean_projects/triangle_border_swm/src/external/Makefile
===================================================================
--- branches/ocean_projects/triangle_border_swm/src/external/Makefile (rev 0)
+++ branches/ocean_projects/triangle_border_swm/src/external/Makefile 2011-04-29 18:46:19 UTC (rev 810)
@@ -0,0 +1,9 @@
+.SUFFIXES: .F .c .o
+
+all: dummy
+
+dummy:
+ echo "*** Compiling external packages ***"
+
+clean:
+ echo "*** Cleaning external packages ***"
Added: branches/ocean_projects/triangle_border_swm/src/framework/Makefile
===================================================================
--- branches/ocean_projects/triangle_border_swm/src/framework/Makefile (rev 0)
+++ branches/ocean_projects/triangle_border_swm/src/framework/Makefile 2011-04-29 18:46:19 UTC (rev 810)
@@ -0,0 +1,49 @@
+.SUFFIXES: .F .o
+
+ifdef ZOLTAN_HOME
+ ZOLTANOBJ = module_zoltan_interface.o
+endif
+
+OBJS = module_mpas_framework.o \
+ module_timer.o \
+ module_configure.o \
+ module_constants.o \
+ module_grid_types.o \
+ module_hash.o \
+ module_sort.o \
+ module_block_decomp.o \
+ module_dmpar.o \
+ module_io_input.o \
+ module_io_output.o \
+ $(ZOLTANOBJ) \
+ streams.o
+
+all: framework
+
+framework: $(OBJS)
+ ar -ru libframework.a $(OBJS)
+
+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
+
+module_grid_types.o: module_dmpar.o
+
+module_dmpar.o: module_sort.o streams.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)
+
+module_io_output.o: module_grid_types.o module_dmpar.o module_sort.o module_configure.o
+
+clean:
+ $(RM) *.o *.mod *.f90 libframework.a
+
+.F.o:
+ $(RM) $@ $*.mod
+ $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90
+ $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES)
+
+.c.o:
+ $(CC) $(CFLAGS) $(CPPFLAGS) $(CPPINCLUDES) -c $<
Added: branches/ocean_projects/triangle_border_swm/src/framework/module_block_decomp.F
===================================================================
--- branches/ocean_projects/triangle_border_swm/src/framework/module_block_decomp.F (rev 0)
+++ branches/ocean_projects/triangle_border_swm/src/framework/module_block_decomp.F 2011-04-29 18:46:19 UTC (rev 810)
@@ -0,0 +1,306 @@
+module block_decomp
+
+ use dmpar
+ use hash
+
+ type graph
+ integer :: nVerticesTotal
+ integer :: nVertices, maxDegree
+ integer :: ghostStart
+ integer, dimension(:), pointer :: vertexID
+ integer, dimension(:), pointer :: nAdjacent
+ integer, dimension(:,:), pointer :: adjacencyList
+ end type graph
+
+
+ contains
+
+
+ subroutine block_decomp_cells_for_proc(dminfo, partial_global_graph_info, local_cell_list)
+
+ use configure
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ type (graph), intent(in) :: partial_global_graph_info
+ integer, dimension(:), pointer :: local_cell_list
+
+ integer, dimension(:), pointer :: global_cell_list
+ integer, dimension(:), pointer :: global_start
+
+ integer :: i, j, owner, iunit, istatus
+ integer, dimension(:), pointer :: local_nvertices
+ character (len=256) :: filename
+
+ if (dminfo % nprocs > 1) then
+
+ allocate(local_nvertices(dminfo % nprocs))
+ allocate(global_start(dminfo % nprocs))
+ allocate(global_cell_list(partial_global_graph_info % nVerticesTotal))
+
+ if (dminfo % my_proc_id == IO_NODE) then
+
+ iunit = 50 + dminfo % my_proc_id
+ if (dminfo % nprocs < 10) then
+ write(filename,'(a,i1)') trim(config_decomp_file_prefix), dminfo % nprocs
+ else if (dminfo % nprocs < 100) then
+ write(filename,'(a,i2)') trim(config_decomp_file_prefix), dminfo % nprocs
+ else if (dminfo % nprocs < 1000) then
+ write(filename,'(a,i3)') trim(config_decomp_file_prefix), dminfo % nprocs
+ else if (dminfo % nprocs < 10000) then
+ write(filename,'(a,i4)') trim(config_decomp_file_prefix), dminfo % nprocs
+ else if (dminfo % nprocs < 100000) then
+ 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)
+
+ if (istatus /= 0) then
+ write(0,*) 'Could not open block decomposition file for ',dminfo % nprocs,' tasks.'
+ write(0,*) 'Filename: ',trim(filename)
+ call dmpar_abort(dminfo)
+ end if
+
+ local_nvertices(:) = 0
+ do i=1,partial_global_graph_info % nVerticesTotal
+ read(unit=iunit, fmt=*) owner
+ local_nvertices(owner+1) = local_nvertices(owner+1) + 1
+ end do
+
+! allocate(global_cell_list(partial_global_graph_info % nVerticesTotal))
+
+ global_start(1) = 1
+ do i=2,dminfo % nprocs
+ global_start(i) = global_start(i-1) + local_nvertices(i-1)
+ end do
+
+ rewind(unit=iunit)
+
+ do i=1,partial_global_graph_info % nVerticesTotal
+ read(unit=iunit, fmt=*) owner
+ global_cell_list(global_start(owner+1)) = i
+ global_start(owner+1) = global_start(owner+1) + 1
+ end do
+
+ global_start(1) = 0
+ do i=2,dminfo % nprocs
+ global_start(i) = global_start(i-1) + local_nvertices(i-1)
+ end do
+
+ close(unit=iunit)
+
+ call dmpar_bcast_ints(dminfo, dminfo % nprocs, local_nvertices)
+ allocate(local_cell_list(local_nvertices(dminfo % my_proc_id + 1)))
+
+ call dmpar_scatter_ints(dminfo, dminfo % nprocs, local_nvertices(dminfo % my_proc_id + 1), &
+ global_start, local_nvertices, global_cell_list, local_cell_list)
+
+ else
+
+ call dmpar_bcast_ints(dminfo, dminfo % nprocs, local_nvertices)
+ allocate(local_cell_list(local_nvertices(dminfo % my_proc_id + 1)))
+
+ call dmpar_scatter_ints(dminfo, dminfo % nprocs, local_nvertices(dminfo % my_proc_id + 1), &
+ global_start, local_nvertices, global_cell_list, local_cell_list)
+
+ end if
+
+ deallocate(local_nvertices)
+ deallocate(global_start)
+ deallocate(global_cell_list)
+ else
+ allocate(local_cell_list(partial_global_graph_info % nVerticesTotal))
+ do i=1,size(local_cell_list)
+ local_cell_list(i) = i
+ end do
+ endif
+
+ end subroutine block_decomp_cells_for_proc
+
+
+ subroutine block_decomp_partitioned_edge_list(nCells, cellIDList, maxCells, nEdges, cellsOnEdge, edgeIDList, ghostEdgeStart)
+
+ implicit none
+
+ integer, intent(in) :: nCells, maxCells, nEdges
+ integer, dimension(nCells), intent(in) :: cellIDList
+ integer, dimension(maxCells, nEdges), intent(in) :: cellsOnEdge
+ integer, dimension(nEdges), intent(inout) :: edgeIDList
+ integer, intent(inout) :: ghostEdgeStart
+
+ integer :: i, j, lastEdge
+ integer, dimension(nEdges) :: edgeIDListLocal
+ type (hashtable) :: h
+
+ call hash_init(h)
+
+ do i=1,nCells
+ ! OPTIMIZATION: Actually, if we can assume that all cellIDs are unique, the if-test is unnecessary
+ if (.not. hash_search(h, cellIDList(i))) call hash_insert(h, cellIDList(i))
+ end do
+
+ lastEdge = 0
+ ghostEdgeStart = nEdges+1
+
+ edgeIDListLocal(:) = edgeIDList(:)
+
+ do i=1,nEdges
+ do j=1,maxCells
+ if (cellsOnEdge(j,i) /= 0) exit
+ end do
+ if (j > maxCells) &
+ write(0,*) 'Error in block_decomp_partitioned_edge_list: ',&
+ 'edge/vertex is not adjacent to any valid cells'
+ if (hash_search(h, cellsOnEdge(j,i))) then
+ lastEdge = lastEdge + 1
+ edgeIDList(lastEdge) = edgeIDListLocal(i)
+ else
+ ghostEdgeStart = ghostEdgeStart - 1
+ edgeIDList(ghostEdgeStart) = edgeIDListLocal(i)
+ end if
+ if (ghostEdgeStart <= lastEdge) then
+ write(0,*) 'block_decomp_partitioned_edge_list: ',&
+ 'Somehow we have more edges than we thought we should.'
+ end if
+ end do
+
+ if (ghostEdgeStart /= lastEdge + 1) then
+ write(0,*) 'block_decomp_partitioned_edge_list:',&
+ ' Somehow we didn''t have enough edges to fill edgeIDList.'
+ end if
+
+ call hash_destroy(h)
+
+ end subroutine block_decomp_partitioned_edge_list
+
+
+ subroutine block_decomp_all_edges_in_block(maxEdges, nCells, nEdgesOnCell, edgesOnCell, nEdges, edgeList)
+
+ implicit none
+
+ integer, intent(in) :: maxEdges, nCells
+ integer, dimension(nCells), intent(in) :: nEdgesOnCell
+ integer, dimension(maxEdges, nCells), intent(in) :: edgesOnCell
+ integer, intent(out) :: nEdges
+ integer, dimension(:), pointer :: edgeList
+
+ integer :: i, j, k
+ type (hashtable) :: h
+
+ call hash_init(h)
+
+ do i=1,nCells
+ do j=1,nEdgesOnCell(i)
+ if (.not. hash_search(h, edgesOnCell(j,i))) call hash_insert(h, edgesOnCell(j,i))
+ end do
+ end do
+
+ nEdges = hash_size(h)
+ allocate(edgeList(nEdges))
+
+ call hash_destroy(h)
+
+ call hash_init(h)
+
+ k = 0
+ do i=1,nCells
+ do j=1,nEdgesOnCell(i)
+ if (.not. hash_search(h, edgesOnCell(j,i))) then
+ k = k + 1
+ if (k > nEdges) then
+ write(0,*) 'block_decomp_all_edges_in_block: ',&
+ 'Trying to add more edges than expected.'
+ return
+ end if
+ edgeList(k) = edgesOnCell(j,i)
+ call hash_insert(h, edgesOnCell(j,i))
+ end if
+ end do
+ end do
+
+ call hash_destroy(h)
+
+ if (k < nEdges) then
+ write(0,*) 'block_decomp_all_edges_in_block: ',&
+ 'Listed fewer edges than expected.'
+ end if
+
+ end subroutine block_decomp_all_edges_in_block
+
+
+ subroutine block_decomp_add_halo(dminfo, local_graph_info, local_graph_with_halo)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ type (graph), intent(in) :: local_graph_info
+ type (graph), intent(out) :: local_graph_with_halo
+
+ integer :: i, j, k
+ type (hashtable) :: h
+
+
+ call hash_init(h)
+
+ do i=1,local_graph_info % nVertices
+ call hash_insert(h, local_graph_info % vertexID(i))
+ end do
+
+ do i=1,local_graph_info % nVertices
+ do j=1,local_graph_info % nAdjacent(i)
+ if (local_graph_info % adjacencyList(j,i) /= 0) then
+ if (.not. hash_search(h, local_graph_info % adjacencyList(j,i))) then
+ call hash_insert(h, local_graph_info % adjacencyList(j,i))
+ end if
+ end if
+ end do
+ end do
+
+
+ local_graph_with_halo % nVertices = local_graph_info % nVertices
+ local_graph_with_halo % maxDegree = local_graph_info % maxDegree
+ local_graph_with_halo % nVerticesTotal = hash_size(h)
+ local_graph_with_halo % ghostStart = local_graph_with_halo % nVertices + 1
+ allocate(local_graph_with_halo % vertexID(local_graph_with_halo % nVerticesTotal))
+ allocate(local_graph_with_halo % nAdjacent(local_graph_with_halo % nVerticesTotal))
+ allocate(local_graph_with_halo % adjacencyList(local_graph_with_halo % maxDegree, local_graph_with_halo % nVerticesTotal))
+
+ call hash_destroy(h)
+
+ call hash_init(h)
+
+ do i=1,local_graph_info % nVertices
+ if (hash_search(h, local_graph_info % vertexID(i))) &
+ write(0,*) 'block_decomp_add_halo: ', &
+ 'There appear to be duplicates in vertexID list.'
+ call hash_insert(h, local_graph_info % vertexID(i))
+ local_graph_with_halo % vertexID(i) = local_graph_info % vertexID(i)
+ local_graph_with_halo % nAdjacent(i) = local_graph_info % nAdjacent(i)
+ local_graph_with_halo % adjacencyList(:,i) = local_graph_info % adjacencyList(:,i)
+ end do
+
+ k = local_graph_with_halo % ghostStart
+ if (hash_size(h) /= k-1) &
+ write(0,*) 'block_decomp_add_halo: ',&
+ 'Somehow we don''t have the right number of non-ghost cells.'
+ do i=1,local_graph_info % nVertices
+ do j=1,local_graph_info % nAdjacent(i)
+ if (local_graph_info % adjacencyList(j,i) /= 0) then
+ if (.not. hash_search(h, local_graph_info % adjacencyList(j,i))) then
+ call hash_insert(h, local_graph_info % adjacencyList(j,i))
+ local_graph_with_halo % vertexID(k) = local_graph_info % adjacencyList(j,i)
+ k = k + 1
+ end if
+ end if
+ end do
+ end do
+ if (local_graph_with_halo % nVerticesTotal /= k-1) &
+ write(0,*) 'block_decomp_add_halo: ',&
+ 'Somehow we don''t have the right number of total cells.'
+
+ call hash_destroy(h)
+
+ end subroutine block_decomp_add_halo
+
+end module block_decomp
Added: branches/ocean_projects/triangle_border_swm/src/framework/module_configure.F
===================================================================
--- branches/ocean_projects/triangle_border_swm/src/framework/module_configure.F (rev 0)
+++ branches/ocean_projects/triangle_border_swm/src/framework/module_configure.F 2011-04-29 18:46:19 UTC (rev 810)
@@ -0,0 +1,36 @@
+module configure
+
+ use dmpar
+
+#include "config_defs.inc"
+
+ contains
+
+
+ subroutine read_namelist(dminfo)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+
+ integer :: funit
+
+#include "config_namelist_defs.inc"
+
+ funit = 21
+
+ ! Set default values for namelist options
+#include "config_set_defaults.inc"
+
+ if (dminfo % my_proc_id == IO_NODE) then
+ open(funit,file='namelist.input',status='old',form='formatted')
+
+#include "config_namelist_reads.inc"
+ close(funit)
+ end if
+
+#include "config_bcast_namelist.inc"
+
+ end subroutine read_namelist
+
+end module configure
Added: branches/ocean_projects/triangle_border_swm/src/framework/module_constants.F
===================================================================
--- branches/ocean_projects/triangle_border_swm/src/framework/module_constants.F (rev 0)
+++ branches/ocean_projects/triangle_border_swm/src/framework/module_constants.F 2011-04-29 18:46:19 UTC (rev 810)
@@ -0,0 +1,20 @@
+module constants
+
+ real (kind=RKIND), parameter :: pii = 3.141592653589793
+ real (kind=RKIND), parameter :: a = 6371229.0
+ real (kind=RKIND), parameter :: omega = 7.29212e-5
+ real (kind=RKIND), parameter :: gravity = 9.80616
+ real (kind=RKIND), parameter :: rgas = 287.
+ real (kind=RKIND), parameter :: cp = 1003.
+ real (kind=RKIND), parameter :: cv = 716. ! cp - rgas
+ real (kind=RKIND), parameter :: cvpm = -.71385842 ! -cv/cp
+ real (kind=RKIND), parameter :: prandtl = 1.0
+
+
+ contains
+
+ subroutine dummy()
+
+ end subroutine dummy
+
+end module constants
Added: branches/ocean_projects/triangle_border_swm/src/framework/module_dmpar.F
===================================================================
--- branches/ocean_projects/triangle_border_swm/src/framework/module_dmpar.F (rev 0)
+++ branches/ocean_projects/triangle_border_swm/src/framework/module_dmpar.F 2011-04-29 18:46:19 UTC (rev 810)
@@ -0,0 +1,1928 @@
+module dmpar
+
+ use sort
+
+#ifdef _MPI
+include 'mpif.h'
+ integer, parameter :: MPI_INTEGERKIND = MPI_INTEGER
+
+#if (RKIND == 8)
+ integer, parameter :: MPI_REALKIND = MPI_DOUBLE_PRECISION
+#else
+ integer, parameter :: MPI_REALKIND = MPI_REAL
+#endif
+#endif
+
+ integer, parameter :: IO_NODE = 0
+ integer, parameter :: BUFSIZE = 6000
+
+
+ type dm_info
+ integer :: nprocs, my_proc_id, comm, info
+ end type dm_info
+
+
+ type exchange_list
+ integer :: procID
+ integer :: nlist
+ integer, dimension(:), pointer :: list
+ type (exchange_list), pointer :: next
+ real (kind=RKIND), dimension(:), pointer :: rbuffer
+ integer, dimension(:), pointer :: ibuffer
+ integer :: reqID
+ end type exchange_list
+
+
+ interface dmpar_alltoall_field
+ module procedure dmpar_alltoall_field1dInteger
+ module procedure dmpar_alltoall_field2dInteger
+ module procedure dmpar_alltoall_field1dReal
+ module procedure dmpar_alltoall_field2dReal
+ module procedure dmpar_alltoall_field3dReal
+ end interface
+
+
+ contains
+
+
+ subroutine dmpar_init(dminfo)
+
+ implicit none
+
+ type (dm_info), intent(inout) :: dminfo
+
+#ifdef _MPI
+ integer :: mpi_rank, mpi_size
+ integer :: mpi_ierr
+
+ ! Find out our rank and the total number of processors
+ call MPI_Init(mpi_ierr)
+ call MPI_Comm_rank(MPI_COMM_WORLD, mpi_rank, mpi_ierr)
+ call MPI_Comm_size(MPI_COMM_WORLD, mpi_size, mpi_ierr)
+
+ dminfo % comm = MPI_COMM_WORLD
+
+ dminfo % nprocs = mpi_size
+ dminfo % my_proc_id = mpi_rank
+
+ write(0,'(a,i5,a,i5,a)') 'task ', mpi_rank, ' of ', mpi_size, &
+ ' is running'
+
+ call open_streams(dminfo % my_proc_id)
+
+ dminfo % info = MPI_INFO_NULL
+#else
+ dminfo % comm = 0
+ dminfo % my_proc_id = IO_NODE
+ dminfo % nprocs = 1
+#endif
+
+ end subroutine dmpar_init
+
+
+ subroutine dmpar_finalize(dminfo)
+
+ implicit none
+
+ type (dm_info), intent(inout) :: dminfo
+
+#ifdef _MPI
+ integer :: mpi_ierr
+
+ call MPI_Finalize(mpi_ierr)
+#endif
+
+ end subroutine dmpar_finalize
+
+
+ subroutine dmpar_abort(dminfo)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+
+#ifdef _MPI
+ integer :: mpi_ierr, mpi_errcode
+
+ call MPI_Abort(dminfo % comm, mpi_errcode, mpi_ierr)
+#endif
+
+ stop
+
+ end subroutine dmpar_abort
+
+
+ subroutine dmpar_global_abort(mesg)
+
+ implicit none
+
+ character (len=*), intent(in) :: mesg
+
+#ifdef _MPI
+ integer :: mpi_ierr, mpi_errcode
+
+ write(0,*) trim(mesg)
+ call MPI_Abort(MPI_COMM_WORLD, mpi_errcode, mpi_ierr)
+#endif
+
+ write(0,*) trim(mesg)
+ stop
+
+ end subroutine dmpar_global_abort
+
+
+ subroutine dmpar_bcast_int(dminfo, i)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(inout) :: i
+
+#ifdef _MPI
+ integer :: mpi_ierr
+
+ call MPI_Bcast(i, 1, MPI_INTEGERKIND, IO_NODE, dminfo % comm, mpi_ierr)
+#endif
+
+ end subroutine dmpar_bcast_int
+
+
+ subroutine dmpar_bcast_ints(dminfo, n, iarray)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: n
+ integer, dimension(n), intent(inout) :: iarray
+
+#ifdef _MPI
+ integer :: mpi_ierr
+
+ call MPI_Bcast(iarray, n, MPI_INTEGERKIND, IO_NODE, dminfo % comm, mpi_ierr)
+#endif
+
+ end subroutine dmpar_bcast_ints
+
+
+ subroutine dmpar_bcast_real(dminfo, r)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ real (kind=RKIND), intent(inout) :: r
+
+#ifdef _MPI
+ integer :: mpi_ierr
+
+ call MPI_Bcast(r, 1, MPI_REALKIND, IO_NODE, dminfo % comm, mpi_ierr)
+#endif
+
+ end subroutine dmpar_bcast_real
+
+
+ subroutine dmpar_bcast_reals(dminfo, n, rarray)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: n
+ real (kind=RKIND), dimension(n), intent(inout) :: rarray
+
+#ifdef _MPI
+ integer :: mpi_ierr
+
+ call MPI_Bcast(rarray, n, MPI_REALKIND, IO_NODE, dminfo % comm, mpi_ierr)
+#endif
+
+ end subroutine dmpar_bcast_reals
+
+
+ subroutine dmpar_bcast_logical(dminfo, l)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ logical, intent(inout) :: l
+
+#ifdef _MPI
+ integer :: mpi_ierr
+ integer :: itemp
+
+ if (dminfo % my_proc_id == IO_NODE) then
+ if (l) then
+ itemp = 1
+ else
+ itemp = 0
+ end if
+ end if
+
+ call MPI_Bcast(itemp, 1, MPI_INTEGERKIND, IO_NODE, dminfo % comm, mpi_ierr)
+
+ if (itemp == 1) then
+ l = .true.
+ else
+ l = .false.
+ end if
+#endif
+
+ end subroutine dmpar_bcast_logical
+
+
+ subroutine dmpar_bcast_char(dminfo, c)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ character (len=*), intent(inout) :: c
+
+#ifdef _MPI
+ integer :: mpi_ierr
+
+ call MPI_Bcast(c, len(c), MPI_CHARACTER, IO_NODE, dminfo % comm, mpi_ierr)
+#endif
+
+ end subroutine dmpar_bcast_char
+
+
+ subroutine dmpar_sum_int(dminfo, i, isum)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: i
+ integer, intent(out) :: isum
+
+ integer :: mpi_ierr
+
+#ifdef _MPI
+ call MPI_Allreduce(i, isum, 1, MPI_INTEGERKIND, MPI_SUM, dminfo % comm, mpi_ierr)
+#else
+ isum = i
+#endif
+
+ end subroutine dmpar_sum_int
+
+
+ subroutine dmpar_sum_real(dminfo, r, rsum)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ real(kind=RKIND), intent(in) :: r
+ real(kind=RKIND), intent(out) :: rsum
+
+ integer :: mpi_ierr
+
+#ifdef _MPI
+ call MPI_Allreduce(r, rsum, 1, MPI_REALKIND, MPI_SUM, dminfo % comm, mpi_ierr)
+#else
+ rsum = r
+#endif
+
+ end subroutine dmpar_sum_real
+
+
+ subroutine dmpar_min_int(dminfo, i, imin)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: i
+ integer, intent(out) :: imin
+
+ integer :: mpi_ierr
+
+#ifdef _MPI
+ call MPI_Allreduce(i, imin, 1, MPI_INTEGERKIND, MPI_MIN, dminfo % comm, mpi_ierr)
+#else
+ imin = i
+#endif
+
+ end subroutine dmpar_min_int
+
+
+ subroutine dmpar_min_real(dminfo, r, rmin)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ real(kind=RKIND), intent(in) :: r
+ real(kind=RKIND), intent(out) :: rmin
+
+ integer :: mpi_ierr
+
+#ifdef _MPI
+ call MPI_Allreduce(r, rmin, 1, MPI_REALKIND, MPI_MIN, dminfo % comm, mpi_ierr)
+#else
+ rmin = r
+#endif
+
+ end subroutine dmpar_min_real
+
+
+ subroutine dmpar_max_int(dminfo, i, imax)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: i
+ integer, intent(out) :: imax
+
+ integer :: mpi_ierr
+
+#ifdef _MPI
+ call MPI_Allreduce(i, imax, 1, MPI_INTEGERKIND, MPI_MAX, dminfo % comm, mpi_ierr)
+#else
+ imax = i
+#endif
+
+ end subroutine dmpar_max_int
+
+
+ subroutine dmpar_max_real(dminfo, r, rmax)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ real(kind=RKIND), intent(in) :: r
+ real(kind=RKIND), intent(out) :: rmax
+
+ integer :: mpi_ierr
+
+#ifdef _MPI
+ call MPI_Allreduce(r, rmax, 1, MPI_REALKIND, MPI_MAX, dminfo % comm, mpi_ierr)
+#else
+ rmax = r
+#endif
+
+ end subroutine dmpar_max_real
+
+
+ subroutine dmpar_sum_int_array(dminfo, nElements, inArray, outArray)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: nElements
+ integer, dimension(nElements), intent(in) :: inArray
+ integer, dimension(nElements), intent(out) :: outArray
+
+ integer :: mpi_ierr
+
+#ifdef _MPI
+ call MPI_Allreduce(inArray, outArray, nElements, MPI_INTEGERKIND, MPI_SUM, dminfo % comm, mpi_ierr)
+#else
+ outArray = inArray
+#endif
+
+ end subroutine dmpar_sum_int_array
+
+
+ subroutine dmpar_min_int_array(dminfo, nElements, inArray, outArray)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: nElements
+ integer, dimension(nElements), intent(in) :: inArray
+ integer, dimension(nElements), intent(out) :: outArray
+
+ integer :: mpi_ierr
+
+#ifdef _MPI
+ call MPI_Allreduce(inArray, outArray, nElements, MPI_INTEGERKIND, MPI_MIN, dminfo % comm, mpi_ierr)
+#else
+ outArray = inArray
+#endif
+
+ end subroutine dmpar_min_int_array
+
+
+ subroutine dmpar_max_int_array(dminfo, nElements, inArray, outArray)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: nElements
+ integer, dimension(nElements), intent(in) :: inArray
+ integer, dimension(nElements), intent(out) :: outArray
+
+ integer :: mpi_ierr
+
+#ifdef _MPI
+ call MPI_Allreduce(inArray, outArray, nElements, MPI_INTEGERKIND, MPI_MAX, dminfo % comm, mpi_ierr)
+#else
+ outArray = inArray
+#endif
+
+ end subroutine dmpar_max_int_array
+
+
+ subroutine dmpar_sum_real_array(dminfo, nElements, inArray, outArray)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: nElements
+ real(kind=RKIND), dimension(nElements), intent(in) :: inArray
+ real(kind=RKIND), dimension(nElements), intent(out) :: outArray
+
+ integer :: mpi_ierr
+
+#ifdef _MPI
+ call MPI_Allreduce(inArray, outArray, nElements, MPI_REALKIND, MPI_SUM, dminfo % comm, mpi_ierr)
+#else
+ outArray = inArray
+#endif
+
+ end subroutine dmpar_sum_real_array
+
+
+ subroutine dmpar_min_real_array(dminfo, nElements, inArray, outArray)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: nElements
+ real(kind=RKIND), dimension(nElements), intent(in) :: inArray
+ real(kind=RKIND), dimension(nElements), intent(out) :: outArray
+
+ integer :: mpi_ierr
+
+#ifdef _MPI
+ call MPI_Allreduce(inArray, outArray, nElements, MPI_REALKIND, MPI_MIN, dminfo % comm, mpi_ierr)
+#else
+ outArray = inArray
+#endif
+
+ end subroutine dmpar_min_real_array
+
+
+ subroutine dmpar_max_real_array(dminfo, nElements, inArray, outArray)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: nElements
+ real(kind=RKIND), dimension(nElements), intent(in) :: inArray
+ real(kind=RKIND), dimension(nElements), intent(out) :: outArray
+
+ integer :: mpi_ierr
+
+#ifdef _MPI
+ call MPI_Allreduce(inArray, outArray, nElements, MPI_REALKIND, MPI_MAX, dminfo % comm, mpi_ierr)
+#else
+ outArray = inArray
+#endif
+
+ end subroutine dmpar_max_real_array
+
+
+ subroutine dmpar_scatter_ints(dminfo, nprocs, noutlist, displs, counts, inlist, outlist)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: nprocs, noutlist
+ integer, dimension(nprocs), intent(in) :: displs, counts
+ integer, dimension(:), pointer :: inlist
+ integer, dimension(noutlist), intent(inout) :: outlist
+
+#ifdef _MPI
+ integer :: mpi_ierr
+
+ call MPI_Scatterv(inlist, counts, displs, MPI_INTEGERKIND, outlist, noutlist, MPI_INTEGERKIND, IO_NODE, dminfo % comm, mpi_ierr)
+#endif
+
+ end subroutine dmpar_scatter_ints
+
+
+ subroutine dmpar_get_index_range(dminfo, &
+ global_start, global_end, &
+ local_start, local_end)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: global_start, global_end
+ integer, intent(out) :: local_start, local_end
+
+ local_start = nint(real(dminfo % my_proc_id) * real(global_end - global_start + 1) / real(dminfo % nprocs)) + 1
+ local_end = nint(real(dminfo % my_proc_id + 1) * real(global_end - global_start + 1) / real(dminfo % nprocs))
+
+ end subroutine dmpar_get_index_range
+
+
+ subroutine dmpar_compute_index_range(dminfo, &
+ local_start, local_end, &
+ global_start, global_end)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: local_start, local_end
+ integer, intent(inout) :: global_start, global_end
+
+ integer :: n
+ integer :: mpi_ierr
+
+ n = local_end - local_start + 1
+
+ if (dminfo % my_proc_id == 0) then
+ global_start = 1
+ global_end = global_start + n - 1
+
+#ifdef _MPI
+ else if (dminfo % my_proc_id == dminfo % nprocs - 1) then
+ call MPI_Recv(global_start, 1, MPI_INTEGERKIND, dminfo % my_proc_id - 1, 0, dminfo % comm, MPI_STATUS_IGNORE, mpi_ierr)
+ global_end = global_start + n - 1
+
+ else
+ call MPI_Recv(global_start, 1, MPI_INTEGERKIND, dminfo % my_proc_id - 1, 0, dminfo % comm, MPI_STATUS_IGNORE, mpi_ierr)
+ global_end = global_start + n
+ call MPI_Send(global_end, 1, MPI_INTEGERKIND, dminfo % my_proc_id + 1, 0, dminfo % comm, mpi_ierr)
+ global_end = global_end - 1
+#endif
+
+ end if
+
+
+ end subroutine dmpar_compute_index_range
+
+
+ subroutine dmpar_get_owner_list(dminfo, &
+ nOwnedList, nNeededList, &
+ ownedList, neededList, &
+ sendList, recvList)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: nOwnedList, nNeededList
+ integer, dimension(nOwnedList), intent(in) :: ownedList
+ integer, dimension(nNeededList), intent(in) :: neededList
+ type (exchange_list), pointer :: sendList
+ type (exchange_list), pointer :: recvList
+
+ integer :: i, j, k, kk
+ integer :: totalSize, nMesgRecv, nMesgSend, recvNeighbor, sendNeighbor, currentProc
+ integer :: numToSend, numToRecv
+ integer, dimension(nOwnedList) :: recipientList
+ integer, dimension(2,nOwnedList) :: ownedListSorted
+ integer, allocatable, dimension(:) :: ownerListIn, ownerListOut
+ type (exchange_list), pointer :: sendListPtr, recvListPtr
+ integer :: mpi_ierr, mpi_rreq, mpi_sreq
+
+#ifdef _MPI
+ allocate(sendList)
+ allocate(recvList)
+ nullify(sendList % next)
+ nullify(recvList % next)
+ sendListPtr => sendList
+ recvListPtr => recvList
+
+ do i=1,nOwnedList
+ ownedListSorted(1,i) = ownedList(i)
+ ownedListSorted(2,i) = i
+ end do
+ call quicksort(nOwnedList, ownedListSorted)
+
+ call MPI_Allreduce(nNeededList, totalSize, 1, MPI_INTEGERKIND, MPI_MAX, dminfo % comm, mpi_ierr)
+
+ allocate(ownerListIn(totalSize))
+ allocate(ownerListOut(totalSize))
+
+ nMesgRecv = nNeededList
+ ownerListIn(1:nNeededList) = neededList(1:nNeededList)
+
+ recvNeighbor = mod(dminfo % my_proc_id + dminfo % nprocs - 1, dminfo % nprocs)
+ sendNeighbor = mod(dminfo % my_proc_id + 1, dminfo % nprocs)
+
+ do i=1, dminfo % nprocs
+
+ recipientList(:) = -1
+ numToSend = 0
+
+ currentProc = mod(dminfo % my_proc_id + dminfo % nprocs - i + 1, dminfo % nprocs)
+ do j=1,nMesgRecv
+ if (ownerListIn(j) > 0) then
+ k = binary_search(ownedListSorted, 2, 1, nOwnedList, ownerListIn(j))
+ if (k <= nOwnedList) then
+ ownerListOut(j) = -1 * dminfo % my_proc_id
+ numToSend = numToSend + 1
+ recipientList(ownedListSorted(2,k)) = numToSend
+ else
+ ownerListOut(j) = ownerListIn(j)
+ end if
+ else
+ ownerListOut(j) = ownerListIn(j)
+ end if
+ end do
+
+ if (numToSend > 0) then
+ allocate(sendListPtr % next)
+ sendListPtr => sendListPtr % next
+ sendListPtr % procID = currentProc
+ sendListPtr % nlist = numToSend
+ allocate(sendListPtr % list(numToSend))
+ nullify(sendListPtr % next)
+ kk = 1
+ do j=1,nOwnedList
+ if (recipientList(j) /= -1) then
+ sendListPtr % list(recipientList(j)) = j
+ kk = kk + 1
+ end if
+ end do
+ end if
+
+ nMesgSend = nMesgRecv
+ call MPI_Irecv(nMesgRecv, 1, MPI_INTEGERKIND, recvNeighbor, i, dminfo % comm, mpi_rreq, mpi_ierr)
+ call MPI_Isend(nMesgSend, 1, MPI_INTEGERKIND, sendNeighbor, i, dminfo % comm, mpi_sreq, mpi_ierr)
+ call MPI_Wait(mpi_rreq, MPI_STATUS_IGNORE, mpi_ierr)
+ call MPI_Wait(mpi_sreq, MPI_STATUS_IGNORE, mpi_ierr)
+ call MPI_Irecv(ownerListIn, nMesgRecv, MPI_INTEGERKIND, recvNeighbor, i, dminfo % comm, mpi_rreq, mpi_ierr)
+ call MPI_Isend(ownerListOut, nMesgSend, MPI_INTEGERKIND, sendNeighbor, i, dminfo % comm, mpi_sreq, mpi_ierr)
+ call MPI_Wait(mpi_rreq, MPI_STATUS_IGNORE, mpi_ierr)
+ call MPI_Wait(mpi_sreq, MPI_STATUS_IGNORE, mpi_ierr)
+ end do
+
+ do i=0, dminfo % nprocs - 1
+
+ numToRecv = 0
+ do j=1,nNeededList
+ if (ownerListIn(j) == -i) numToRecv = numToRecv + 1
+ end do
+ if (numToRecv > 0) then
+ allocate(recvListPtr % next)
+ recvListPtr => recvListPtr % next
+ recvListPtr % procID = i
+ recvListPtr % nlist = numToRecv
+ allocate(recvListPtr % list(numToRecv))
+ nullify(recvListPtr % next)
+ kk = 1
+ do j=1,nNeededList
+ if (ownerListIn(j) == -i) then
+ recvListPtr % list(kk) = j
+ kk = kk + 1
+ end if
+ end do
+ end if
+
+ end do
+
+ deallocate(ownerListIn)
+ deallocate(ownerListOut)
+
+ sendListPtr => sendList
+ sendList => sendList % next
+ deallocate(sendListPtr)
+
+ recvListPtr => recvList
+ recvList => recvList % next
+ deallocate(recvListPtr)
+
+#else
+ allocate(recvList)
+ recvList % procID = dminfo % my_proc_id
+ recvList % nlist = nNeededList
+ allocate(recvList % list(nNeededList))
+ nullify(recvList % next)
+ do j=1,nNeededList
+ recvList % list(j) = j
+ end do
+
+ allocate(sendList)
+ sendList % procID = dminfo % my_proc_id
+ sendList % nlist = nOwnedList
+ allocate(sendList % list(nOwnedList))
+ nullify(sendList % next)
+ do j=1,nOwnedList
+ sendList % list(j) = j
+ end do
+#endif
+
+ end subroutine dmpar_get_owner_list
+
+
+ subroutine dmpar_alltoall_field1dInteger(dminfo, arrayIn, arrayOut, nOwnedList, nNeededList, sendList, recvList)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, dimension(*), intent(in) :: arrayIn
+ integer, dimension(*), intent(inout) :: arrayOut
+ integer, intent(in) :: nOwnedList, nNeededList
+ type (exchange_list), pointer :: sendList, recvList
+
+ type (exchange_list), pointer :: sendListPtr, recvListPtr
+ integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
+ integer :: mpi_ierr
+ integer :: i
+
+#ifdef _MPI
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID == dminfo % my_proc_id) exit
+ sendListPtr => sendListPtr % next
+ end do
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID == dminfo % my_proc_id) exit
+ recvListPtr => recvListPtr % next
+ end do
+
+ if (associated(recvListPtr) .and. associated(sendListPtr)) then
+ do i=1,recvListPtr % nlist
+ arrayOut(recvListPtr % list(i)) = arrayIn(sendListPtr % list(i))
+ end do
+ end if
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ allocate(recvListPtr % ibuffer(recvListPtr % nlist))
+ call MPI_Irecv(recvListPtr % ibuffer, recvListPtr % nlist, MPI_INTEGERKIND, &
+ recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ allocate(sendListPtr % ibuffer(sendListPtr % nlist))
+ call packSendBuf1dInteger(nOwnedList, arrayIn, sendListPtr, 1, sendListPtr % nlist, &
+ sendListPtr % ibuffer, nPacked, lastPackedIdx)
+ call MPI_Isend(sendListPtr % ibuffer, sendListPtr % nlist, MPI_INTEGERKIND, &
+ sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ call unpackRecvBuf1dInteger(nNeededList, arrayOut, recvListPtr, 1, recvListPtr % nlist, &
+ recvListPtr % ibuffer, nUnpacked, lastUnpackedIdx)
+ deallocate(recvListPtr % ibuffer)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ deallocate(sendListPtr % ibuffer)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+#else
+ if (nOwnedList /= nNeededList) then
+ write(0,*) 'Error in dmpar_alltoall_field: For non-dmpar, ', &
+ 'arrayIn and arrayOut dims must match.'
+ call dmpar_abort(dminfo)
+ else
+ arrayOut(1:nNeededList) = arrayIn(1:nOwnedList)
+ end if
+#endif
+
+ end subroutine dmpar_alltoall_field1dInteger
+
+
+ subroutine dmpar_alltoall_field2dInteger(dminfo, arrayIn, arrayOut, dim1, nOwnedList, nNeededList, sendList, recvList)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: dim1, nOwnedList, nNeededList
+ integer, dimension(dim1,*), intent(in) :: arrayIn
+ integer, dimension(dim1,*), intent(inout) :: arrayOut
+ type (exchange_list), pointer :: sendList, recvList
+
+ type (exchange_list), pointer :: sendListPtr, recvListPtr
+ integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
+ integer :: mpi_ierr
+ integer :: i, d2
+
+#ifdef _MPI
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID == dminfo % my_proc_id) exit
+ sendListPtr => sendListPtr % next
+ end do
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID == dminfo % my_proc_id) exit
+ recvListPtr => recvListPtr % next
+ end do
+
+ if (associated(recvListPtr) .and. associated(sendListPtr)) then
+ do i=1,recvListPtr % nlist
+ arrayOut(:,recvListPtr % list(i)) = arrayIn(:,sendListPtr % list(i))
+ end do
+ end if
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ d2 = dim1 * recvListPtr % nlist
+ allocate(recvListPtr % ibuffer(d2))
+ call MPI_Irecv(recvListPtr % ibuffer, d2, MPI_INTEGERKIND, &
+ recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ d2 = dim1 * sendListPtr % nlist
+ allocate(sendListPtr % ibuffer(d2))
+ call packSendBuf2dInteger(1, dim1, nOwnedList, arrayIn, sendListPtr, 1, d2, &
+ sendListPtr % ibuffer, nPacked, lastPackedIdx)
+ call MPI_Isend(sendListPtr % ibuffer, d2, MPI_INTEGERKIND, &
+ sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ d2 = dim1 * recvListPtr % nlist
+ call unpackRecvBuf2dInteger(1, dim1, nNeededList, arrayOut, recvListPtr, 1, d2, &
+ recvListPtr % ibuffer, nUnpacked, lastUnpackedIdx)
+ deallocate(recvListPtr % ibuffer)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ deallocate(sendListPtr % ibuffer)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+#else
+ if (nOwnedList /= nNeededList) then
+ write(0,*) 'Error in dmpar_alltoall_field: For non-dmpar, ', &
+ 'arrayIn and arrayOut dims must match.'
+ call dmpar_abort(dminfo)
+ else
+ arrayOut(:,1:nNeededList) = arrayIn(:,1:nOwnedList)
+ end if
+#endif
+
+ end subroutine dmpar_alltoall_field2dInteger
+
+
+ subroutine dmpar_alltoall_field1dReal(dminfo, arrayIn, arrayOut, nOwnedList, nNeededList, sendList, recvList)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ real (kind=RKIND), dimension(*), intent(in) :: arrayIn
+ real (kind=RKIND), dimension(*), intent(inout) :: arrayOut
+ integer, intent(in) :: nOwnedList, nNeededList
+ type (exchange_list), pointer :: sendList, recvList
+
+ type (exchange_list), pointer :: sendListPtr, recvListPtr
+ integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
+ integer :: mpi_ierr
+ integer :: i
+
+#ifdef _MPI
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID == dminfo % my_proc_id) exit
+ sendListPtr => sendListPtr % next
+ end do
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID == dminfo % my_proc_id) exit
+ recvListPtr => recvListPtr % next
+ end do
+
+ if (associated(recvListPtr) .and. associated(sendListPtr)) then
+ do i=1,recvListPtr % nlist
+ arrayOut(recvListPtr % list(i)) = arrayIn(sendListPtr % list(i))
+ end do
+ end if
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ allocate(recvListPtr % rbuffer(recvListPtr % nlist))
+ call MPI_Irecv(recvListPtr % rbuffer, recvListPtr % nlist, MPI_REALKIND, &
+ recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ allocate(sendListPtr % rbuffer(sendListPtr % nlist))
+ call packSendBuf1dReal(nOwnedList, arrayIn, sendListPtr, 1, sendListPtr % nlist, &
+ sendListPtr % rbuffer, nPacked, lastPackedIdx)
+ call MPI_Isend(sendListPtr % rbuffer, sendListPtr % nlist, MPI_REALKIND, &
+ sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ call unpackRecvBuf1dReal(nNeededList, arrayOut, recvListPtr, 1, recvListPtr % nlist, &
+ recvListPtr % rbuffer, nUnpacked, lastUnpackedIdx)
+ deallocate(recvListPtr % rbuffer)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ deallocate(sendListPtr % rbuffer)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+#else
+ if (nOwnedList /= nNeededList) then
+ write(0,*) 'Error in dmpar_alltoall_field: For non-dmpar, ', &
+ 'arrayIn and arrayOut dims must match.'
+ call dmpar_abort(dminfo)
+ else
+ arrayOut(1:nNeededList) = arrayIn(1:nOwnedList)
+ end if
+#endif
+
+ end subroutine dmpar_alltoall_field1dReal
+
+
+ subroutine dmpar_alltoall_field2dReal(dminfo, arrayIn, arrayOut, dim1, nOwnedList, nNeededList, sendList, recvList)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: dim1, nOwnedList, nNeededList
+ real (kind=RKIND), dimension(dim1,*), intent(in) :: arrayIn
+ real (kind=RKIND), dimension(dim1,*), intent(inout) :: arrayOut
+ type (exchange_list), pointer :: sendList, recvList
+
+ type (exchange_list), pointer :: sendListPtr, recvListPtr
+ integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
+ integer :: mpi_ierr
+ integer :: i, d2
+
+#ifdef _MPI
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID == dminfo % my_proc_id) exit
+ sendListPtr => sendListPtr % next
+ end do
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID == dminfo % my_proc_id) exit
+ recvListPtr => recvListPtr % next
+ end do
+
+ if (associated(recvListPtr) .and. associated(sendListPtr)) then
+ do i=1,recvListPtr % nlist
+ arrayOut(:,recvListPtr % list(i)) = arrayIn(:,sendListPtr % list(i))
+ end do
+ end if
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ d2 = dim1 * recvListPtr % nlist
+ allocate(recvListPtr % rbuffer(d2))
+ call MPI_Irecv(recvListPtr % rbuffer, d2, MPI_REALKIND, &
+ recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ d2 = dim1 * sendListPtr % nlist
+ allocate(sendListPtr % rbuffer(d2))
+ call packSendBuf2dReal(1, dim1, nOwnedList, arrayIn, sendListPtr, 1, d2, &
+ sendListPtr % rbuffer, nPacked, lastPackedIdx)
+ call MPI_Isend(sendListPtr % rbuffer, d2, MPI_REALKIND, &
+ sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ d2 = dim1 * recvListPtr % nlist
+ call unpackRecvBuf2dReal(1, dim1, nNeededList, arrayOut, recvListPtr, 1, d2, &
+ recvListPtr % rbuffer, nUnpacked, lastUnpackedIdx)
+ deallocate(recvListPtr % rbuffer)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ deallocate(sendListPtr % rbuffer)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+#else
+ if (nOwnedList /= nNeededList) then
+ write(0,*) 'Error in dmpar_alltoall_field: For non-dmpar, ', &
+ 'arrayIn and arrayOut dims must match.'
+ call dmpar_abort(dminfo)
+ else
+ arrayOut(:,1:nNeededList) = arrayIn(:,1:nOwnedList)
+ end if
+#endif
+
+ end subroutine dmpar_alltoall_field2dReal
+
+
+ subroutine dmpar_alltoall_field3dReal(dminfo, arrayIn, arrayOut, dim1, dim2, nOwnedList, nNeededList, sendList, recvList)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: dim1, dim2, nOwnedList, nNeededList
+ real (kind=RKIND), dimension(dim1,dim2,*), intent(in) :: arrayIn
+ real (kind=RKIND), dimension(dim1,dim2,*), intent(inout) :: arrayOut
+ type (exchange_list), pointer :: sendList, recvList
+
+ type (exchange_list), pointer :: sendListPtr, recvListPtr
+ integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
+ integer :: mpi_ierr
+ integer :: i, d3
+
+#ifdef _MPI
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID == dminfo % my_proc_id) exit
+ sendListPtr => sendListPtr % next
+ end do
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID == dminfo % my_proc_id) exit
+ recvListPtr => recvListPtr % next
+ end do
+
+ if (associated(recvListPtr) .and. associated(sendListPtr)) then
+ do i=1,recvListPtr % nlist
+ arrayOut(:,:,recvListPtr % list(i)) = arrayIn(:,:,sendListPtr % list(i))
+ end do
+ end if
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ d3 = dim1 * dim2 * recvListPtr % nlist
+ allocate(recvListPtr % rbuffer(d3))
+ call MPI_Irecv(recvListPtr % rbuffer, d3, MPI_REALKIND, &
+ recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ d3 = dim1 * dim2 * sendListPtr % nlist
+ allocate(sendListPtr % rbuffer(d3))
+ call packSendBuf3dReal(1, dim1, 1, dim2, nOwnedList, arrayIn, sendListPtr, 1, d3, &
+ sendListPtr % rbuffer, nPacked, lastPackedIdx)
+ call MPI_Isend(sendListPtr % rbuffer, d3, MPI_REALKIND, &
+ sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ d3 = dim1 * dim2 * recvListPtr % nlist
+ call unpackRecvBuf3dReal(1, dim1, 1, dim2, nNeededList, arrayOut, recvListPtr, 1, d3, &
+ recvListPtr % rbuffer, nUnpacked, lastUnpackedIdx)
+ deallocate(recvListPtr % rbuffer)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ deallocate(sendListPtr % rbuffer)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+#else
+ if (nOwnedList /= nNeededList) then
+ write(0,*) 'Error in dmpar_alltoall_field: For non-dmpar, ', &
+ 'arrayIn and arrayOut dims must match.'
+ call dmpar_abort(dminfo)
+ else
+ arrayOut(:,:,1:nNeededList) = arrayIn(:,:,1:nOwnedList)
+ end if
+#endif
+
+ end subroutine dmpar_alltoall_field3dReal
+
+
+ subroutine packSendBuf1dInteger(nField, field, sendList, startPackIdx, nBuffer, buffer, nPacked, lastPackedIdx)
+
+ implicit none
+
+ integer, intent(in) :: nField, nBuffer, startPackIdx
+ integer, dimension(*), intent(in) :: field
+ type (exchange_list), intent(in) :: sendList
+ integer, dimension(nBuffer), intent(out) :: buffer
+ integer, intent(inout) :: nPacked, lastPackedIdx
+
+ integer :: i
+
+ nPacked = 0
+ do i=startPackIdx, sendList % nlist
+ nPacked = nPacked + 1
+ if (nPacked > nBuffer) then
+ nPacked = nPacked - 1
+ lastPackedIdx = i - 1
+ return
+ end if
+ buffer(nPacked) = field(sendList % list(i))
+ end do
+ lastPackedIdx = sendList % nlist
+
+ end subroutine packSendBuf1dInteger
+
+
+ subroutine packSendBuf2dInteger(ds, de, nField, field, sendList, startPackIdx, nBuffer, buffer, nPacked, lastPackedIdx)
+
+ implicit none
+
+ integer, intent(in) :: ds, de, nField, nBuffer, startPackIdx
+ integer, dimension(ds:de,*), intent(in) :: field
+ type (exchange_list), intent(in) :: sendList
+ integer, dimension(nBuffer), intent(out) :: buffer
+ integer, intent(inout) :: nPacked, lastPackedIdx
+
+ integer :: i, n
+
+ n = de-ds+1
+
+ if (n > nBuffer) then
+ write(0,*) 'packSendBuf2dInteger: Not enough space in buffer', &
+ ' to fit a single slice.'
+ return
+ end if
+
+ nPacked = 0
+ do i=startPackIdx, sendList % nlist
+ nPacked = nPacked + n
+ if (nPacked > nBuffer) then
+ nPacked = nPacked - n
+ lastPackedIdx = i - 1
+ return
+ end if
+ buffer(nPacked-n+1:nPacked) = field(ds:de,sendList % list(i))
+ end do
+ lastPackedIdx = sendList % nlist
+
+ end subroutine packSendBuf2dInteger
+
+
+ subroutine packSendBuf3dInteger(d1s, d1e, d2s, d2e, nField, field, sendList, startPackIdx, nBuffer, buffer, nPacked, lastPackedIdx)
+
+ implicit none
+
+ integer, intent(in) :: d1s, d1e, d2s, d2e, nField, nBuffer, startPackIdx
+ integer, dimension(d1s:d1e,d2s:d2e,*), intent(in) :: field
+ type (exchange_list), intent(in) :: sendList
+ integer, dimension(nBuffer), intent(out) :: buffer
+ integer, intent(inout) :: nPacked, lastPackedIdx
+
+ integer :: i, j, k, n
+
+ n = (d1e-d1s+1) * (d2e-d2s+1)
+
+ if (n > nBuffer) then
+ write(0,*) 'packSendBuf3dInteger: Not enough space in buffer', &
+ ' to fit a single slice.'
+ return
+ end if
+
+ nPacked = 0
+ do i=startPackIdx, sendList % nlist
+ nPacked = nPacked + n
+ if (nPacked > nBuffer) then
+ nPacked = nPacked - n
+ lastPackedIdx = i - 1
+ return
+ end if
+ k = nPacked-n+1
+ do j=d2s,d2e
+ buffer(k:k+d1e-d1s) = field(d1s:d1e,j,sendList % list(i))
+ k = k + d1e-d1s+1
+ end do
+ end do
+ lastPackedIdx = sendList % nlist
+
+ end subroutine packSendBuf3dInteger
+
+
+ subroutine packSendBuf1dReal(nField, field, sendList, startPackIdx, nBuffer, buffer, nPacked, lastPackedIdx)
+
+ implicit none
+
+ integer, intent(in) :: nField, nBuffer, startPackIdx
+ real (kind=RKIND), dimension(*), intent(in) :: field
+ type (exchange_list), intent(in) :: sendList
+ real (kind=RKIND), dimension(nBuffer), intent(out) :: buffer
+ integer, intent(inout) :: nPacked, lastPackedIdx
+
+ integer :: i
+
+ nPacked = 0
+ do i=startPackIdx, sendList % nlist
+ nPacked = nPacked + 1
+ if (nPacked > nBuffer) then
+ nPacked = nPacked - 1
+ lastPackedIdx = i - 1
+ return
+ end if
+ buffer(nPacked) = field(sendList % list(i))
+ end do
+ lastPackedIdx = sendList % nlist
+
+ end subroutine packSendBuf1dReal
+
+
+ subroutine packSendBuf2dReal(ds, de, nField, field, sendList, startPackIdx, nBuffer, buffer, nPacked, lastPackedIdx)
+
+ implicit none
+
+ integer, intent(in) :: ds, de, nField, nBuffer, startPackIdx
+ real (kind=RKIND), dimension(ds:de,*), intent(in) :: field
+ type (exchange_list), intent(in) :: sendList
+ real (kind=RKIND), dimension(nBuffer), intent(out) :: buffer
+ integer, intent(inout) :: nPacked, lastPackedIdx
+
+ integer :: i, n
+
+ n = de-ds+1
+
+ if (n > nBuffer) then
+ write(0,*) 'packSendBuf2dReal: Not enough space in buffer', &
+ ' to fit a single slice.'
+ return
+ end if
+
+ nPacked = 0
+ do i=startPackIdx, sendList % nlist
+ nPacked = nPacked + n
+ if (nPacked > nBuffer) then
+ nPacked = nPacked - n
+ lastPackedIdx = i - 1
+ return
+ end if
+ buffer(nPacked-n+1:nPacked) = field(ds:de,sendList % list(i))
+ end do
+ lastPackedIdx = sendList % nlist
+
+ end subroutine packSendBuf2dReal
+
+
+ subroutine packSendBuf3dReal(d1s, d1e, d2s, d2e, nField, field, sendList, startPackIdx, nBuffer, buffer, nPacked, lastPackedIdx)
+
+ implicit none
+
+ integer, intent(in) :: d1s, d1e, d2s, d2e, nField, nBuffer, startPackIdx
+ real (kind=RKIND), dimension(d1s:d1e,d2s:d2e,*), intent(in) :: field
+ type (exchange_list), intent(in) :: sendList
+ real (kind=RKIND), dimension(nBuffer), intent(out) :: buffer
+ integer, intent(inout) :: nPacked, lastPackedIdx
+
+ integer :: i, j, k, n
+
+ n = (d1e-d1s+1) * (d2e-d2s+1)
+
+ if (n > nBuffer) then
+ write(0,*) 'packSendBuf3dReal: Not enough space in buffer', &
+ ' to fit a single slice.'
+ return
+ end if
+
+ nPacked = 0
+ do i=startPackIdx, sendList % nlist
+ nPacked = nPacked + n
+ if (nPacked > nBuffer) then
+ nPacked = nPacked - n
+ lastPackedIdx = i - 1
+ return
+ end if
+ k = nPacked-n+1
+ do j=d2s,d2e
+ buffer(k:k+d1e-d1s) = field(d1s:d1e,j,sendList % list(i))
+ k = k + d1e-d1s+1
+ end do
+ end do
+ lastPackedIdx = sendList % nlist
+
+ end subroutine packSendBuf3dReal
+
+
+ subroutine unpackRecvBuf1dInteger(nField, field, recvList, startUnpackIdx, nBuffer, buffer, nUnpacked, lastUnpackedIdx)
+
+ implicit none
+
+ integer, intent(in) :: nField, nBuffer, startUnpackIdx
+ integer, dimension(*), intent(inout) :: field
+ type (exchange_list), intent(in) :: recvList
+ integer, dimension(nBuffer), intent(in) :: buffer
+ integer, intent(inout) :: nUnpacked, lastUnpackedIdx
+
+ integer :: i
+
+ nUnpacked = 0
+ do i=startUnpackIdx, recvList % nlist
+ nUnpacked = nUnpacked + 1
+ if (nUnpacked > nBuffer) then
+ nUnpacked = nUnpacked - 1
+ lastUnpackedIdx = i - 1
+ return
+ end if
+ field(recvList % list(i)) = buffer(nUnpacked)
+ end do
+ lastUnpackedIdx = recvList % nlist
+
+ end subroutine unpackRecvBuf1dInteger
+
+
+ subroutine unpackRecvBuf2dInteger(ds, de, nField, field, recvList, startUnpackIdx, nBuffer, buffer, nUnpacked, lastUnpackedIdx)
+
+ implicit none
+
+ integer, intent(in) :: ds, de, nField, nBuffer, startUnpackIdx
+ integer, dimension(ds:de,*), intent(inout) :: field
+ type (exchange_list), intent(in) :: recvList
+ integer, dimension(nBuffer), intent(in) :: buffer
+ integer, intent(inout) :: nUnpacked, lastUnpackedIdx
+
+ integer :: i, n
+
+ n = de-ds+1
+
+ nUnpacked = 0
+ do i=startUnpackIdx, recvList % nlist
+ nUnpacked = nUnpacked + n
+ if (nUnpacked > nBuffer) then
+ nUnpacked = nUnpacked - n
+ lastUnpackedIdx = i - 1
+ return
+ end if
+ field(ds:de,recvList % list(i)) = buffer(nUnpacked-n+1:nUnpacked)
+ end do
+ lastUnpackedIdx = recvList % nlist
+
+ end subroutine unpackRecvBuf2dInteger
+
+
+ subroutine unpackRecvBuf3dInteger(d1s, d1e, d2s, d2e, nField, field, recvList, startUnpackIdx, nBuffer, buffer, &
+ nUnpacked, lastUnpackedIdx)
+
+ implicit none
+
+ integer, intent(in) :: d1s, d1e, d2s, d2e, nField, nBuffer, startUnpackIdx
+ integer, dimension(d1s:d1e,d2s:d2e,*), intent(inout) :: field
+ type (exchange_list), intent(in) :: recvList
+ integer, dimension(nBuffer), intent(in) :: buffer
+ integer, intent(inout) :: nUnpacked, lastUnpackedIdx
+
+ integer :: i, j, k, n
+
+ n = (d1e-d1s+1) * (d2e-d2s+1)
+
+ nUnpacked = 0
+ do i=startUnpackIdx, recvList % nlist
+ nUnpacked = nUnpacked + n
+ if (nUnpacked > nBuffer) then
+ nUnpacked = nUnpacked - n
+ lastUnpackedIdx = i - 1
+ return
+ end if
+ k = nUnpacked-n+1
+ do j=d2s,d2e
+ field(d1s:d1e,j,recvList % list(i)) = buffer(k:k+d1e-d1s)
+ k = k + d1e-d1s+1
+ end do
+ end do
+ lastUnpackedIdx = recvList % nlist
+
+ end subroutine unpackRecvBuf3dInteger
+
+
+ subroutine dmpar_exch_halo_field1dInteger(dminfo, array, dim1, sendList, recvList)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: dim1
+ integer, dimension(*), intent(inout) :: array
+ type (exchange_list), pointer :: sendList, recvList
+
+ type (exchange_list), pointer :: sendListPtr, recvListPtr
+ integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
+ integer :: mpi_ierr
+
+#ifdef _MPI
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ allocate(recvListPtr % ibuffer(recvListPtr % nlist))
+ call MPI_Irecv(recvListPtr % ibuffer, recvListPtr % nlist, MPI_INTEGERKIND, &
+ recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ allocate(sendListPtr % ibuffer(sendListPtr % nlist))
+ call packSendBuf1dInteger(dim1, array, sendListPtr, 1, sendListPtr % nlist, sendListPtr % ibuffer, nPacked, lastPackedIdx)
+ call MPI_Isend(sendListPtr % ibuffer, sendListPtr % nlist, MPI_INTEGERKIND, &
+ sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ call unpackRecvBuf1dInteger(dim1, array, recvListPtr, 1, recvListPtr % nlist, recvListPtr % ibuffer, nUnpacked, lastUnpackedIdx)
+ deallocate(recvListPtr % ibuffer)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ deallocate(sendListPtr % ibuffer)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+#endif
+
+ end subroutine dmpar_exch_halo_field1dInteger
+
+
+ subroutine dmpar_exch_halo_field2dInteger(dminfo, array, dim1, dim2, sendList, recvList)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: dim1, dim2
+ integer, dimension(dim1,*), intent(inout) :: array
+ type (exchange_list), pointer :: sendList, recvList
+
+ type (exchange_list), pointer :: sendListPtr, recvListPtr
+ integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
+ integer :: mpi_ierr
+ integer :: d2
+
+#ifdef _MPI
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ d2 = dim1 * recvListPtr % nlist
+ allocate(recvListPtr % ibuffer(d2))
+ call MPI_Irecv(recvListPtr % ibuffer, d2, MPI_INTEGERKIND, &
+ recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ d2 = dim1 * sendListPtr % nlist
+ allocate(sendListPtr % ibuffer(d2))
+ call packSendBuf2dInteger(1, dim1, dim2, array, sendListPtr, 1, d2, sendListPtr % ibuffer, nPacked, lastPackedIdx)
+ call MPI_Isend(sendListPtr % ibuffer, d2, MPI_INTEGERKIND, &
+ sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ d2 = dim1 * recvListPtr % nlist
+ call unpackRecvBuf2dInteger(1, dim1, dim2, array, recvListPtr, 1, d2, recvListPtr % ibuffer, nUnpacked, lastUnpackedIdx)
+ deallocate(recvListPtr % ibuffer)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ deallocate(sendListPtr % ibuffer)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+#endif
+
+ end subroutine dmpar_exch_halo_field2dInteger
+
+
+ subroutine dmpar_exch_halo_field3dInteger(dminfo, array, dim1, dim2, dim3, sendList, recvList)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: dim1, dim2, dim3
+ integer, dimension(dim1,dim2,*), intent(inout) :: array
+ type (exchange_list), pointer :: sendList, recvList
+
+ type (exchange_list), pointer :: sendListPtr, recvListPtr
+ integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
+ integer :: mpi_ierr
+ integer :: d3
+
+#ifdef _MPI
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ d3 = dim1 * dim2 * recvListPtr % nlist
+ allocate(recvListPtr % ibuffer(d3))
+ call MPI_Irecv(recvListPtr % ibuffer, d3, MPI_INTEGERKIND, &
+ recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ d3 = dim1 * dim2 * sendListPtr % nlist
+ allocate(sendListPtr % ibuffer(d3))
+ call packSendBuf3dInteger(1, dim1, 1, dim2, dim3, array, sendListPtr, 1, d3, &
+ sendListPtr % ibuffer, nPacked, lastPackedIdx)
+ call MPI_Isend(sendListPtr % ibuffer, d3, MPI_INTEGERKIND, &
+ sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ d3 = dim1 * dim2 * recvListPtr % nlist
+ call unpackRecvBuf3dInteger(1, dim1, 1, dim2, dim3, array, recvListPtr, 1, d3, &
+ recvListPtr % ibuffer, nUnpacked, lastUnpackedIdx)
+ deallocate(recvListPtr % ibuffer)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ deallocate(sendListPtr % ibuffer)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+#endif
+
+ end subroutine dmpar_exch_halo_field3dInteger
+
+
+ subroutine unpackRecvBuf1dReal(nField, field, recvList, startUnpackIdx, nBuffer, buffer, nUnpacked, lastUnpackedIdx)
+
+ implicit none
+
+ integer, intent(in) :: nField, nBuffer, startUnpackIdx
+ real (kind=RKIND), dimension(*), intent(inout) :: field
+ type (exchange_list), intent(in) :: recvList
+ real (kind=RKIND), dimension(nBuffer), intent(in) :: buffer
+ integer, intent(inout) :: nUnpacked, lastUnpackedIdx
+
+ integer :: i
+
+ nUnpacked = 0
+ do i=startUnpackIdx, recvList % nlist
+ nUnpacked = nUnpacked + 1
+ if (nUnpacked > nBuffer) then
+ nUnpacked = nUnpacked - 1
+ lastUnpackedIdx = i - 1
+ return
+ end if
+ field(recvList % list(i)) = buffer(nUnpacked)
+ end do
+ lastUnpackedIdx = recvList % nlist
+
+ end subroutine unpackRecvBuf1dReal
+
+
+ subroutine unpackRecvBuf2dReal(ds, de, nField, field, recvList, startUnpackIdx, nBuffer, buffer, nUnpacked, lastUnpackedIdx)
+
+ implicit none
+
+ integer, intent(in) :: ds, de, nField, nBuffer, startUnpackIdx
+ real (kind=RKIND), dimension(ds:de,*), intent(inout) :: field
+ type (exchange_list), intent(in) :: recvList
+ real (kind=RKIND), dimension(nBuffer), intent(in) :: buffer
+ integer, intent(inout) :: nUnpacked, lastUnpackedIdx
+
+ integer :: i, n
+
+ n = de-ds+1
+
+ nUnpacked = 0
+ do i=startUnpackIdx, recvList % nlist
+ nUnpacked = nUnpacked + n
+ if (nUnpacked > nBuffer) then
+ nUnpacked = nUnpacked - n
+ lastUnpackedIdx = i - 1
+ return
+ end if
+ field(ds:de,recvList % list(i)) = buffer(nUnpacked-n+1:nUnpacked)
+ end do
+ lastUnpackedIdx = recvList % nlist
+
+ end subroutine unpackRecvBuf2dReal
+
+
+ subroutine unpackRecvBuf3dReal(d1s, d1e, d2s, d2e, nField, field, recvList, startUnpackIdx, nBuffer, buffer, &
+ nUnpacked, lastUnpackedIdx)
+
+ implicit none
+
+ integer, intent(in) :: d1s, d1e, d2s, d2e, nField, nBuffer, startUnpackIdx
+ real (kind=RKIND), dimension(d1s:d1e,d2s:d2e,*), intent(inout) :: field
+ type (exchange_list), intent(in) :: recvList
+ real (kind=RKIND), dimension(nBuffer), intent(in) :: buffer
+ integer, intent(inout) :: nUnpacked, lastUnpackedIdx
+
+ integer :: i, j, k, n
+
+ n = (d1e-d1s+1) * (d2e-d2s+1)
+
+ nUnpacked = 0
+ do i=startUnpackIdx, recvList % nlist
+ nUnpacked = nUnpacked + n
+ if (nUnpacked > nBuffer) then
+ nUnpacked = nUnpacked - n
+ lastUnpackedIdx = i - 1
+ return
+ end if
+ k = nUnpacked-n+1
+ do j=d2s,d2e
+ field(d1s:d1e,j,recvList % list(i)) = buffer(k:k+d1e-d1s)
+ k = k + d1e-d1s+1
+ end do
+ end do
+ lastUnpackedIdx = recvList % nlist
+
+ end subroutine unpackRecvBuf3dReal
+
+
+ subroutine dmpar_exch_halo_field1dReal(dminfo, array, dim1, sendList, recvList)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: dim1
+ real (kind=RKIND), dimension(*), intent(inout) :: array
+ type (exchange_list), pointer :: sendList, recvList
+
+ type (exchange_list), pointer :: sendListPtr, recvListPtr
+ integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
+ integer :: mpi_ierr
+
+#ifdef _MPI
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ allocate(recvListPtr % rbuffer(recvListPtr % nlist))
+ call MPI_Irecv(recvListPtr % rbuffer, recvListPtr % nlist, MPI_REALKIND, &
+ recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ allocate(sendListPtr % rbuffer(sendListPtr % nlist))
+ call packSendBuf1dReal(dim1, array, sendListPtr, 1, sendListPtr % nlist, sendListPtr % rbuffer, nPacked, lastPackedIdx)
+ call MPI_Isend(sendListPtr % rbuffer, sendListPtr % nlist, MPI_REALKIND, &
+ sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ call unpackRecvBuf1dReal(dim1, array, recvListPtr, 1, recvListPtr % nlist, recvListPtr % rbuffer, nUnpacked, lastUnpackedIdx)
+ deallocate(recvListPtr % rbuffer)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ deallocate(sendListPtr % rbuffer)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+#endif
+
+ end subroutine dmpar_exch_halo_field1dReal
+
+
+ subroutine dmpar_exch_halo_field2dReal(dminfo, array, dim1, dim2, sendList, recvList)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: dim1, dim2
+ real (kind=RKIND), dimension(dim1,*), intent(inout) :: array
+ type (exchange_list), pointer :: sendList, recvList
+
+ type (exchange_list), pointer :: sendListPtr, recvListPtr
+ integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
+ integer :: mpi_ierr
+ integer :: d2
+
+#ifdef _MPI
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ d2 = dim1 * recvListPtr % nlist
+ allocate(recvListPtr % rbuffer(d2))
+ call MPI_Irecv(recvListPtr % rbuffer, d2, MPI_REALKIND, &
+ recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ d2 = dim1 * sendListPtr % nlist
+ allocate(sendListPtr % rbuffer(d2))
+ call packSendBuf2dReal(1, dim1, dim2, array, sendListPtr, 1, d2, sendListPtr % rbuffer, nPacked, lastPackedIdx)
+ call MPI_Isend(sendListPtr % rbuffer, d2, MPI_REALKIND, &
+ sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ d2 = dim1 * recvListPtr % nlist
+ call unpackRecvBuf2dReal(1, dim1, dim2, array, recvListPtr, 1, d2, recvListPtr % rbuffer, nUnpacked, lastUnpackedIdx)
+ deallocate(recvListPtr % rbuffer)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ deallocate(sendListPtr % rbuffer)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+#endif
+
+ end subroutine dmpar_exch_halo_field2dReal
+
+
+ subroutine dmpar_exch_halo_field3dReal(dminfo, array, dim1, dim2, dim3, sendList, recvList)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: dim1, dim2, dim3
+ real (kind=RKIND), dimension(dim1,dim2,*), intent(inout) :: array
+ type (exchange_list), pointer :: sendList, recvList
+
+ type (exchange_list), pointer :: sendListPtr, recvListPtr
+ integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
+ integer :: mpi_ierr
+ integer :: d3
+
+#ifdef _MPI
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ d3 = dim1 * dim2 * recvListPtr % nlist
+ allocate(recvListPtr % rbuffer(d3))
+ call MPI_Irecv(recvListPtr % rbuffer, d3, MPI_REALKIND, &
+ recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ d3 = dim1 * dim2 * sendListPtr % nlist
+ allocate(sendListPtr % rbuffer(d3))
+ call packSendBuf3dReal(1, dim1, 1, dim2, dim3, array, sendListPtr, 1, d3, &
+ sendListPtr % rbuffer, nPacked, lastPackedIdx)
+ call MPI_Isend(sendListPtr % rbuffer, d3, MPI_REALKIND, &
+ sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ d3 = dim1 * dim2 * recvListPtr % nlist
+ call unpackRecvBuf3dReal(1, dim1, 1, dim2, dim3, array, recvListPtr, 1, d3, &
+ recvListPtr % rbuffer, nUnpacked, lastUnpackedIdx)
+ deallocate(recvListPtr % rbuffer)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ deallocate(sendListPtr % rbuffer)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+#endif
+
+ end subroutine dmpar_exch_halo_field3dReal
+
+
+end module dmpar
Added: branches/ocean_projects/triangle_border_swm/src/framework/module_grid_types.F
===================================================================
--- branches/ocean_projects/triangle_border_swm/src/framework/module_grid_types.F (rev 0)
+++ branches/ocean_projects/triangle_border_swm/src/framework/module_grid_types.F 2011-04-29 18:46:19 UTC (rev 810)
@@ -0,0 +1,202 @@
+module grid_types
+
+ use dmpar
+
+ integer, parameter :: nTimeLevs = 2
+
+
+ ! Derived type describing info for doing I/O specific to a field
+ type io_info
+ character (len=1024) :: fieldName
+ integer, dimension(4) :: start
+ integer, dimension(4) :: count
+ logical :: input
+ logical :: restart
+ logical :: output
+ end type io_info
+
+
+ ! Derived type for storing fields
+ type field3DReal
+ type (block_type), pointer :: block
+ real (kind=RKIND), dimension(:,:,:), pointer :: array
+ type (io_info), pointer :: ioinfo
+ end type field3DReal
+
+
+ ! Derived type for storing fields
+ type field2DReal
+ type (block_type), pointer :: block
+ real (kind=RKIND), dimension(:,:), pointer :: array
+ type (io_info), pointer :: ioinfo
+ end type field2DReal
+
+
+ ! Derived type for storing fields
+ type field1DReal
+ type (block_type), pointer :: block
+ real (kind=RKIND), dimension(:), pointer :: array
+ type (io_info), pointer :: ioinfo
+ end type field1DReal
+
+
+ ! Derived type for storing fields
+ type field0DReal
+ type (block_type), pointer :: block
+ real (kind=RKIND) :: scalar
+ type (io_info), pointer :: ioinfo
+ end type field0DReal
+
+
+ ! Derived type for storing fields
+ type field2DInteger
+ type (block_type), pointer :: block
+ integer, dimension(:,:), pointer :: array
+ type (io_info), pointer :: ioinfo
+ end type field2DInteger
+
+
+ ! Derived type for storing fields
+ type field1DInteger
+ type (block_type), pointer :: block
+ integer, dimension(:), pointer :: array
+ type (io_info), pointer :: ioinfo
+ end type field1DInteger
+
+
+ ! Derived type for storing grid meta-data
+ type mesh_type
+
+#include "field_dimensions.inc"
+
+ logical :: on_a_sphere
+ real (kind=RKIND) :: sphere_radius
+
+#include "time_invariant_fields.inc"
+
+ end type mesh_type
+
+
+#include "variable_groups.inc"
+
+
+ ! Type for storing (possibly architecture specific) information concerning to parallelism
+ type parallel_info
+ type (exchange_list), pointer :: cellsToSend ! List of types describing which cells to send to other blocks
+ type (exchange_list), pointer :: cellsToRecv ! List of types describing which cells to receive from other blocks
+ type (exchange_list), pointer :: edgesToSend ! List of types describing which edges to send to other blocks
+ type (exchange_list), pointer :: edgesToRecv ! List of types describing which edges to receive from other blocks
+ type (exchange_list), pointer :: verticesToSend ! List of types describing which vertices to send to other blocks
+ type (exchange_list), pointer :: verticesToRecv ! List of types describing which vertices to receive from other blocks
+ end type parallel_info
+
+
+ ! Derived type for storing part of a domain; used as a basic unit of work for a process
+ type block_type
+
+#include "block_group_members.inc"
+
+ type (domain_type), pointer :: domain
+
+ type (parallel_info), pointer :: parinfo
+
+ type (block_type), pointer :: prev, next
+ end type block_type
+
+
+ ! Derived type for storing list of blocks from a domain to be handled by a process
+ type domain_type
+ type (block_type), pointer :: blocklist
+
+ ! Also store parallelization info here
+ type (dm_info), pointer :: dminfo
+ end type domain_type
+
+
+ contains
+
+
+ subroutine allocate_domain(dom, dminfo)
+
+ implicit none
+
+ type (domain_type), pointer :: dom
+ type (dm_info), pointer :: dminfo
+
+ allocate(dom)
+ nullify(dom % blocklist)
+ dom % dminfo => dminfo
+
+ end subroutine allocate_domain
+
+
+ subroutine allocate_block(b, dom, &
+#include "dim_dummy_args.inc"
+ )
+
+ implicit none
+
+ type (block_type), pointer :: b
+ type (domain_type), pointer :: dom
+#include "dim_dummy_decls.inc"
+
+ integer :: i
+
+ nullify(b % prev)
+ nullify(b % next)
+
+ allocate(b % parinfo)
+
+ b % domain => dom
+
+#include "block_allocs.inc"
+
+ end subroutine allocate_block
+
+
+#include "group_alloc_routines.inc"
+
+
+ subroutine deallocate_domain(dom)
+
+ implicit none
+
+ type (domain_type), pointer :: dom
+
+ type (block_type), pointer :: block_ptr
+
+ block_ptr => dom % blocklist
+ do while (associated(block_ptr))
+ call deallocate_block(block_ptr)
+ block_ptr => block_ptr % next
+ end do
+
+ deallocate(dom)
+
+ end subroutine deallocate_domain
+
+
+ subroutine deallocate_block(b)
+
+ implicit none
+
+ type (block_type), intent(inout) :: b
+
+ integer :: i
+
+ deallocate(b % parinfo)
+
+#include "block_deallocs.inc"
+
+ end subroutine deallocate_block
+
+
+#include "group_dealloc_routines.inc"
+
+
+#include "group_copy_routines.inc"
+
+
+#include "group_shift_level_routines.inc"
+
+end module grid_types
Added: branches/ocean_projects/triangle_border_swm/src/framework/module_hash.F
===================================================================
--- branches/ocean_projects/triangle_border_swm/src/framework/module_hash.F (rev 0)
+++ branches/ocean_projects/triangle_border_swm/src/framework/module_hash.F 2011-04-29 18:46:19 UTC (rev 810)
@@ -0,0 +1,175 @@
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! MODULE HASH
+!
+! Purpose: This module provides a dictionary/hashtable with insert, search, and
+! remove routines.
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+module hash
+
+ ! Parameters
+ integer, parameter :: TABLESIZE=27183 ! Number of spaces in the table (the
+ ! number of linked lists)
+
+ type hashnode
+ integer :: key
+ type (hashnode), pointer :: next
+ end type hashnode
+
+ type hashnode_ptr
+ type (hashnode), pointer :: p ! Pointer to a list of entries
+ end type hashnode_ptr
+
+ type hashtable
+ integer :: size
+ type (hashnode_ptr), dimension(TABLESIZE) :: table ! The hashtable array
+ end type hashtable
+
+
+ contains
+
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Name: hash_init
+ !
+ ! Purpose: To initialize a hashtable
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine hash_init(h)
+
+ implicit none
+
+ ! Arguments
+ type (hashtable), intent(inout) :: h
+
+ ! Local variables
+ integer :: i
+
+ h%size = 0
+
+ do i=1,TABLESIZE
+ nullify(h%table(i)%p)
+ end do
+
+ end subroutine hash_init
+
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Name: hash_insert
+ !
+ ! Purpose: Given a hashtable h and a key to be inserted into the hashtable,
+ ! this routine adds key to the table.
+ !
+ ! NOTE: If the key already exists in the table, a second copy of the
+ ! key is added to the table
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine hash_insert(h, key)
+
+ implicit none
+
+ ! Arguments
+ integer, intent(in) :: key
+ type (hashtable), intent(inout) :: h
+
+ ! Local variables
+ integer :: hashval, i
+ type (hashnode), pointer :: hn
+
+ hashval = mod(key, TABLESIZE) + 1
+
+ allocate(hn)
+ hn%key = key
+ hn%next => h%table(hashval)%p
+ h%table(hashval)%p => hn
+
+ h%size = h%size + 1
+
+ end subroutine hash_insert
+
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Name: hash_search
+ !
+ ! Purpose: This function returns TRUE if the specified key was found in the
+ ! hashtable h, and FALSE otherwise.
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ logical function hash_search(h, key)
+
+ implicit none
+
+ ! Arguments
+ integer, intent(in) :: key
+ type (hashtable), intent(inout) :: h
+
+ ! Local variables
+ integer :: hashval, i
+ type (hashnode), pointer :: cursor
+
+ hash_search = .false.
+
+ hashval = mod(key, TABLESIZE) + 1
+
+ cursor => h%table(hashval)%p
+ do while(associated(cursor))
+ if (cursor%key == key) then
+ hash_search = .true.
+ return
+ else
+ cursor => cursor%next
+ end if
+ end do
+
+ return
+
+ end function hash_search
+
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Name: hash_size
+ !
+ ! Purpose: Returns the number of items in the hash table h.
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ integer function hash_size(h)
+
+ implicit none
+
+ ! Arguments
+ type (hashtable) :: h
+
+ hash_size = h%size
+
+ return
+
+ end function hash_size
+
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Name: hash_destroy
+ !
+ ! Purpose: Frees all memory associated with hashtable h. This routine may be
+ ! used to remove all entries from a hashtable.
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine hash_destroy(h)
+
+ implicit none
+
+ ! Arguments
+ type (hashtable), intent(inout) :: h
+
+ ! Local variables
+ integer :: i
+ type (hashnode), pointer :: cursor, cursor_prev
+
+ do i=1,TABLESIZE
+ cursor => h%table(i)%p
+ do while(associated(cursor))
+ cursor_prev => cursor
+ cursor => cursor%next
+ deallocate(cursor_prev)
+ end do
+ nullify(h%table(i)%p)
+ end do
+
+ h%size = 0
+
+ end subroutine hash_destroy
+
+end module hash
Added: branches/ocean_projects/triangle_border_swm/src/framework/module_io_input.F
===================================================================
--- branches/ocean_projects/triangle_border_swm/src/framework/module_io_input.F (rev 0)
+++ branches/ocean_projects/triangle_border_swm/src/framework/module_io_input.F 2011-04-29 18:46:19 UTC (rev 810)
@@ -0,0 +1,1471 @@
+module io_input
+
+ use grid_types
+ use dmpar
+ use block_decomp
+ use sort
+ use configure
+
+#ifdef HAVE_ZOLTAN
+ use zoltan_interface
+#endif
+
+ type io_input_object
+ character (len=1024) :: filename
+ integer :: rd_ncid
+
+ integer :: time
+
+#include "io_input_obj_decls.inc"
+ end type io_input_object
+
+
+ interface io_input_field
+ module procedure io_input_field0dReal
+ module procedure io_input_field1dReal
+ module procedure io_input_field2dReal
+ module procedure io_input_field3dReal
+ module procedure io_input_field1dInteger
+ module procedure io_input_field2dInteger
+ end interface io_input_field
+
+ interface io_input_field_time
+ module procedure io_input_field0dReal_time
+ module procedure io_input_field1dReal_time
+ module procedure io_input_field2dReal_time
+ module procedure io_input_field3dReal_time
+ end interface io_input_field_time
+
+
+ contains
+
+
+ subroutine input_state_for_domain(domain)
+
+ implicit none
+
+ type (domain_type), pointer :: domain
+
+ integer :: i, j, k
+ type (io_input_object) :: input_obj
+#include "dim_decls.inc"
+
+ character (len=16) :: c_on_a_sphere
+ real (kind=RKIND) :: r_sphere_radius
+
+ integer :: readCellStart, readCellEnd, nReadCells
+ integer :: readEdgeStart, readEdgeEnd, nReadEdges
+ integer :: readVertexStart, readVertexEnd, nReadVertices
+ integer :: readVertLevelStart, readVertLevelEnd, nReadVertLevels
+
+ type (field1dInteger) :: indexToCellIDField
+ type (field1dInteger) :: indexToEdgeIDField
+ type (field1dInteger) :: indexToVertexIDField
+ type (field1dInteger) :: nEdgesOnCellField
+ type (field2dInteger) :: cellsOnCellField
+ type (field2dInteger) :: edgesOnCellField
+ type (field2dInteger) :: verticesOnCellField
+ type (field2dInteger) :: cellsOnEdgeField
+ type (field2dInteger) :: cellsOnVertexField
+
+#ifdef HAVE_ZOLTAN
+#ifdef _MPI
+ type (field1dReal) :: xCellField, yCellField, zCellField
+ type (field1dReal) :: xEdgeField, yEdgeField, zEdgeField
+ type (field1dReal) :: xVertexField, yVertexField, zVertexField
+#endif
+#endif
+
+ type (field1dReal) :: xtime
+
+ integer, dimension(:), pointer :: indexToCellID_0Halo
+ integer, dimension(:), pointer :: nEdgesOnCell_0Halo
+ integer, dimension(:,:), pointer :: cellsOnCell_0Halo
+
+ integer, dimension(:,:), pointer :: edgesOnCell_2Halo
+ integer, dimension(:,:), pointer :: verticesOnCell_2Halo
+ integer, dimension(:,:), pointer :: cellsOnEdge_2Halo
+ integer, dimension(:,:), pointer :: cellsOnVertex_2Halo
+
+ integer, dimension(:,:), pointer :: cellIDSorted
+ integer, dimension(:,:), pointer :: edgeIDSorted
+ integer, dimension(:,:), pointer :: vertexIDSorted
+
+#ifdef HAVE_ZOLTAN
+#ifdef _MPI
+ real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell
+ real (kind=RKIND), dimension(:), pointer :: xEdge, yEdge, zEdge
+ real (kind=RKIND), dimension(:), pointer :: xVertex, yVertex, zVertex
+#endif
+#endif
+
+ integer, dimension(:), pointer :: local_cell_list, local_edge_list, local_vertex_list
+ integer, dimension(:), pointer :: local_vertlevel_list, needed_vertlevel_list
+ integer :: nlocal_edges, nlocal_vertices
+ type (exchange_list), pointer :: sendCellList, recvCellList
+ type (exchange_list), pointer :: sendEdgeList, recvEdgeList
+ type (exchange_list), pointer :: sendVertexList, recvVertexList
+ type (exchange_list), pointer :: sendVertLevelList, recvVertLevelList
+ type (exchange_list), pointer :: sendVertLevelP1List, recvVertLevelP1List
+ type (exchange_list), pointer :: send1Halo, recv1Halo
+ type (exchange_list), pointer :: send2Halo, recv2Halo
+ type (graph) :: partial_global_graph_info
+ type (graph) :: block_graph_0Halo, block_graph_1Halo, block_graph_2Halo
+ integer :: ghostEdgeStart, ghostVertexStart
+
+ real (kind=RKIND) :: tdiff
+ integer :: idxTdiff
+
+ if (config_do_restart) then
+ input_obj % filename = trim(config_restart_name)
+ else
+ input_obj % filename = trim(config_input_name)
+ end if
+ call io_input_init(input_obj, domain % dminfo)
+
+
+ !
+ ! Read global number of cells/edges/vertices
+ !
+#include "read_dims.inc"
+
+ !
+ ! Determine the range of cells/edges/vertices that a processor will initially read
+ ! from the input file
+ !
+ call dmpar_get_index_range(domain % dminfo, 1, nCells, readCellStart, readCellEnd)
+ nReadCells = readCellEnd - readCellStart + 1
+
+ call dmpar_get_index_range(domain % dminfo, 1, nEdges, readEdgeStart, readEdgeEnd)
+ nReadEdges = readEdgeEnd - readEdgeStart + 1
+
+ call dmpar_get_index_range(domain % dminfo, 1, nVertices, readVertexStart, readVertexEnd)
+ nReadVertices = readVertexEnd - readVertexStart + 1
+
+ readVertLevelStart = 1
+ readVertLevelEnd = nVertLevels
+ nReadVertLevels = nVertLevels
+
+
+ !
+ ! Allocate and read fields that we will need in order to ultimately work out
+ ! which cells/edges/vertices are owned by each block, and which are ghost
+ !
+
+ ! Global cell indices
+ allocate(indexToCellIDField % ioinfo)
+ indexToCellIDField % ioinfo % fieldName = 'indexToCellID'
+ indexToCellIDField % ioinfo % start(1) = readCellStart
+ indexToCellIDField % ioinfo % count(1) = nReadCells
+ allocate(indexToCellIDField % array(nReadCells))
+ call io_input_field(input_obj, indexToCellIDField)
+
+#ifdef HAVE_ZOLTAN
+#ifdef _MPI
+ ! Cell x-coordinates (in 3d Cartesian space)
+ allocate(xCellField % ioinfo)
+ xCellField % ioinfo % fieldName = 'xCell'
+ xCellField % ioinfo % start(1) = readCellStart
+ xCellField % ioinfo % count(1) = nReadCells
+ allocate(xCellField % array(nReadCells))
+ call io_input_field(input_obj, xCellField)
+
+ ! Cell y-coordinates (in 3d Cartesian space)
+ allocate(yCellField % ioinfo)
+ yCellField % ioinfo % fieldName = 'yCell'
+ yCellField % ioinfo % start(1) = readCellStart
+ yCellField % ioinfo % count(1) = nReadCells
+ allocate(yCellField % array(nReadCells))
+ call io_input_field(input_obj, yCellField)
+
+ ! Cell z-coordinates (in 3d Cartesian space)
+ allocate(zCellField % ioinfo)
+ zCellField % ioinfo % fieldName = 'zCell'
+ zCellField % ioinfo % start(1) = readCellStart
+ zCellField % ioinfo % count(1) = nReadCells
+ allocate(zCellField % array(nReadCells))
+ call io_input_field(input_obj, zCellField)
+#endif
+#endif
+
+
+ ! Global edge indices
+ allocate(indexToEdgeIDField % ioinfo)
+ indexToEdgeIDField % ioinfo % fieldName = 'indexToEdgeID'
+ indexToEdgeIDField % ioinfo % start(1) = readEdgeStart
+ indexToEdgeIDField % ioinfo % count(1) = nReadEdges
+ allocate(indexToEdgeIDField % array(nReadEdges))
+ call io_input_field(input_obj, indexToEdgeIDField)
+
+#ifdef HAVE_ZOLTAN
+#ifdef _MPI
+ ! Edge x-coordinates (in 3d Cartesian space)
+ allocate(xEdgeField % ioinfo)
+ xEdgeField % ioinfo % fieldName = 'xEdge'
+ xEdgeField % ioinfo % start(1) = readEdgeStart
+ xEdgeField % ioinfo % count(1) = nReadEdges
+ allocate(xEdgeField % array(nReadEdges))
+ call io_input_field(input_obj, xEdgeField)
+
+ ! Edge y-coordinates (in 3d Cartesian space)
+ allocate(yEdgeField % ioinfo)
+ yEdgeField % ioinfo % fieldName = 'yEdge'
+ yEdgeField % ioinfo % start(1) = readEdgeStart
+ yEdgeField % ioinfo % count(1) = nReadEdges
+ allocate(yEdgeField % array(nReadEdges))
+ call io_input_field(input_obj, yEdgeField)
+
+ ! Edge z-coordinates (in 3d Cartesian space)
+ allocate(zEdgeField % ioinfo)
+ zEdgeField % ioinfo % fieldName = 'zEdge'
+ zEdgeField % ioinfo % start(1) = readEdgeStart
+ zEdgeField % ioinfo % count(1) = nReadEdges
+ allocate(zEdgeField % array(nReadEdges))
+ call io_input_field(input_obj, zEdgeField)
+#endif
+#endif
+
+ ! Global vertex indices
+ allocate(indexToVertexIDField % ioinfo)
+ indexToVertexIDField % ioinfo % fieldName = 'indexToVertexID'
+ indexToVertexIDField % ioinfo % start(1) = readVertexStart
+ indexToVertexIDField % ioinfo % count(1) = nReadVertices
+ allocate(indexToVertexIDField % array(nReadVertices))
+ call io_input_field(input_obj, indexToVertexIDField)
+
+#ifdef HAVE_ZOLTAN
+#ifdef _MPI
+ ! Vertex x-coordinates (in 3d Cartesian space)
+ allocate(xVertexField % ioinfo)
+ xVertexField % ioinfo % fieldName = 'xVertex'
+ xVertexField % ioinfo % start(1) = readVertexStart
+ xVertexField % ioinfo % count(1) = nReadVertices
+ allocate(xVertexField % array(nReadVertices))
+ call io_input_field(input_obj, xVertexField)
+
+ ! Vertex y-coordinates (in 3d Cartesian space)
+ allocate(yVertexField % ioinfo)
+ yVertexField % ioinfo % fieldName = 'yVertex'
+ yVertexField % ioinfo % start(1) = readVertexStart
+ yVertexField % ioinfo % count(1) = nReadVertices
+ allocate(yVertexField % array(nReadVertices))
+ call io_input_field(input_obj, yVertexField)
+
+ ! Vertex z-coordinates (in 3d Cartesian space)
+ allocate(zVertexField % ioinfo)
+ zVertexField % ioinfo % fieldName = 'zVertex'
+ zVertexField % ioinfo % start(1) = readVertexStart
+ zVertexField % ioinfo % count(1) = nReadVertices
+ allocate(zVertexField % array(nReadVertices))
+ call io_input_field(input_obj, zVertexField)
+#endif
+#endif
+
+ ! Number of cell/edges/vertices adjacent to each cell
+ allocate(nEdgesOnCellField % ioinfo)
+ nEdgesOnCellField % ioinfo % fieldName = 'nEdgesOnCell'
+ nEdgesOnCellField % ioinfo % start(1) = readCellStart
+ nEdgesOnCellField % ioinfo % count(1) = nReadCells
+ allocate(nEdgesOnCellField % array(nReadCells))
+ call io_input_field(input_obj, nEdgesOnCellField)
+
+ ! Global indices of cells adjacent to each cell
+ allocate(cellsOnCellField % ioinfo)
+ cellsOnCellField % ioinfo % fieldName = 'cellsOnCell'
+ cellsOnCellField % ioinfo % start(1) = 1
+ cellsOnCellField % ioinfo % start(2) = readCellStart
+ cellsOnCellField % ioinfo % count(1) = maxEdges
+ cellsOnCellField % ioinfo % count(2) = nReadCells
+ allocate(cellsOnCellField % array(maxEdges,nReadCells))
+ call io_input_field(input_obj, cellsOnCellField)
+
+ ! Global indices of edges adjacent to each cell
+ allocate(edgesOnCellField % ioinfo)
+ edgesOnCellField % ioinfo % fieldName = 'edgesOnCell'
+ edgesOnCellField % ioinfo % start(1) = 1
+ edgesOnCellField % ioinfo % start(2) = readCellStart
+ edgesOnCellField % ioinfo % count(1) = maxEdges
+ edgesOnCellField % ioinfo % count(2) = nReadCells
+ allocate(edgesOnCellField % array(maxEdges,nReadCells))
+ call io_input_field(input_obj, edgesOnCellField)
+
+ ! Global indices of vertices adjacent to each cell
+ allocate(verticesOnCellField % ioinfo)
+ verticesOnCellField % ioinfo % fieldName = 'verticesOnCell'
+ verticesOnCellField % ioinfo % start(1) = 1
+ verticesOnCellField % ioinfo % start(2) = readCellStart
+ verticesOnCellField % ioinfo % count(1) = maxEdges
+ verticesOnCellField % ioinfo % count(2) = nReadCells
+ allocate(verticesOnCellField % array(maxEdges,nReadCells))
+ call io_input_field(input_obj, verticesOnCellField)
+
+ ! Global indices of cells adjacent to each edge
+ ! used for determining which edges are owned by a block, where
+ ! iEdge is owned iff cellsOnEdge(1,iEdge) is an owned cell
+ allocate(cellsOnEdgeField % ioinfo)
+ cellsOnEdgeField % ioinfo % fieldName = 'cellsOnEdge'
+ cellsOnEdgeField % ioinfo % start(1) = 1
+ cellsOnEdgeField % ioinfo % start(2) = readEdgeStart
+ cellsOnEdgeField % ioinfo % count(1) = 2
+ cellsOnEdgeField % ioinfo % count(2) = nReadEdges
+ allocate(cellsOnEdgeField % array(2,nReadEdges))
+ call io_input_field(input_obj, cellsOnEdgeField)
+
+ ! Global indices of cells adjacent to each vertex
+ ! used for determining which vertices are owned by a block, where
+ ! iVtx is owned iff cellsOnVertex(1,iVtx) is an owned cell
+ allocate(cellsOnVertexField % ioinfo)
+ cellsOnVertexField % ioinfo % fieldName = 'cellsOnVertex'
+ cellsOnVertexField % ioinfo % start(1) = 1
+ cellsOnVertexField % ioinfo % start(2) = readVertexStart
+ cellsOnVertexField % ioinfo % count(1) = vertexDegree
+ cellsOnVertexField % ioinfo % count(2) = nReadVertices
+ allocate(cellsOnVertexField % array(vertexDegree,nReadVertices))
+ call io_input_field(input_obj, cellsOnVertexField)
+
+
+ !
+ ! Set up a graph derived data type describing the connectivity for the cells
+ ! that were read by this process
+ ! A partial description is passed to the block decomp module by each process,
+ ! and the block decomp module returns with a list of global cell indices
+ ! that belong to the block on this process
+ !
+ partial_global_graph_info % nVertices = nReadCells
+ partial_global_graph_info % nVerticesTotal = nCells
+ partial_global_graph_info % maxDegree = maxEdges
+ partial_global_graph_info % ghostStart = nVertices+1
+ allocate(partial_global_graph_info % vertexID(nReadCells))
+ allocate(partial_global_graph_info % nAdjacent(nReadCells))
+ allocate(partial_global_graph_info % adjacencyList(maxEdges, nReadCells))
+
+ partial_global_graph_info % vertexID(:) = indexToCellIDField % array(:)
+ partial_global_graph_info % nAdjacent(:) = nEdgesOnCellField % array(:)
+ partial_global_graph_info % adjacencyList(:,:) = cellsOnCellField % array(:,:)
+
+
+ ! TODO: Ensure (by renaming or exchanging) that initial cell range on each proc is contiguous
+ ! This situation may occur when reading a restart file with cells/edges/vertices written
+ ! in a scrambled order
+
+
+ ! Determine which cells are owned by this process
+ call block_decomp_cells_for_proc(domain % dminfo, partial_global_graph_info, local_cell_list)
+
+ deallocate(partial_global_graph_info % vertexID)
+ deallocate(partial_global_graph_info % nAdjacent)
+ deallocate(partial_global_graph_info % adjacencyList)
+
+
+ allocate(indexToCellID_0Halo(size(local_cell_list)))
+ allocate(nEdgesOnCell_0Halo(size(local_cell_list)))
+ allocate(cellsOnCell_0Halo(maxEdges, size(local_cell_list)))
+
+#ifdef HAVE_ZOLTAN
+#ifdef _MPI
+ allocate(xCell(size(local_cell_list)))
+ allocate(yCell(size(local_cell_list)))
+ allocate(zCell(size(local_cell_list)))
+#endif
+#endif
+
+ !
+ ! Now that each process has a list of cells that it owns, exchange cell connectivity
+ ! information between the processes that read info for a cell and those that own that cell
+ !
+ call dmpar_get_owner_list(domain % dminfo, &
+ size(indexToCellIDField % array), size(local_cell_list), &
+ indexToCellIDField % array, local_cell_list, &
+ sendCellList, recvCellList)
+
+ call dmpar_alltoall_field(domain % dminfo, indexToCellIDField % array, indexToCellID_0Halo, &
+ size(indexToCellIDField % array), size(local_cell_list), &
+ sendCellList, recvCellList)
+
+ call dmpar_alltoall_field(domain % dminfo, nEdgesOnCellField % array, nEdgesOnCell_0Halo, &
+ size(indexToCellIDField % array), size(local_cell_list), &
+ sendCellList, recvCellList)
+
+ call dmpar_alltoall_field(domain % dminfo, cellsOnCellField % array, cellsOnCell_0Halo, &
+ size(cellsOnCellField % array, 1), size(indexToCellIDField % array), size(local_cell_list), &
+ sendCellList, recvCellList)
+
+#ifdef HAVE_ZOLTAN
+#ifdef _MPI
+ call dmpar_alltoall_field(domain % dminfo, xCellField % array, xCell, &
+ size(xCellField % array), size(local_cell_list), &
+ sendCellList, recvCellList)
+
+ call dmpar_alltoall_field(domain % dminfo, yCellField % array, yCell, &
+ size(yCellField % array), size(local_cell_list), &
+ sendCellList, recvCellList)
+
+ call dmpar_alltoall_field(domain % dminfo, zCellField % array, zCell, &
+ size(zCellField % array), size(local_cell_list), &
+ sendCellList, recvCellList)
+#endif
+#endif
+
+
+ deallocate(sendCellList % list)
+ deallocate(sendCellList)
+ deallocate(recvCellList % list)
+ deallocate(recvCellList)
+
+
+
+ !
+ ! Build a graph of cell connectivity based on cells owned by this process
+ !
+ block_graph_0Halo % nVerticesTotal = size(local_cell_list)
+ block_graph_0Halo % nVertices = size(local_cell_list)
+ block_graph_0Halo % maxDegree = maxEdges
+ block_graph_0Halo % ghostStart = size(local_cell_list) + 1
+ allocate(block_graph_0Halo % vertexID(size(local_cell_list)))
+ allocate(block_graph_0Halo % nAdjacent(size(local_cell_list)))
+ allocate(block_graph_0Halo % adjacencyList(maxEdges, size(local_cell_list)))
+
+ block_graph_0Halo % vertexID(:) = indexToCellID_0Halo(:)
+ block_graph_0Halo % nAdjacent(:) = nEdgesOnCell_0Halo(:)
+ block_graph_0Halo % adjacencyList(:,:) = cellsOnCell_0Halo(:,:)
+
+ ! Get back a graph describing the owned cells plus the cells in the 1-halo
+ call block_decomp_add_halo(domain % dminfo, block_graph_0Halo, block_graph_1Halo)
+
+
+ !
+ ! Work out exchange lists for 1-halo and exchange cell information for 1-halo
+ !
+ call dmpar_get_owner_list(domain % dminfo, &
+ block_graph_0Halo % nVertices, block_graph_1Halo % nVerticesTotal, &
+ block_graph_0Halo % vertexID, block_graph_1Halo % vertexID, &
+ send1Halo, recv1Halo)
+
+ call dmpar_alltoall_field(domain % dminfo, block_graph_0Halo % vertexID, block_graph_1Halo % vertexID, &
+ block_graph_0Halo % nVertices, block_graph_1Halo % nVerticesTotal, &
+ send1Halo, recv1Halo)
+
+ call dmpar_alltoall_field(domain % dminfo, block_graph_0Halo % nAdjacent, block_graph_1Halo % nAdjacent, &
+ block_graph_0Halo % nVertices, block_graph_1Halo % nVerticesTotal, &
+ send1Halo, recv1Halo)
+
+ call dmpar_alltoall_field(domain % dminfo, block_graph_0Halo % adjacencyList, block_graph_1Halo % adjacencyList, &
+ block_graph_0Halo % maxDegree, block_graph_0Halo % nVertices, block_graph_1Halo % nVerticesTotal, &
+ send1Halo, recv1Halo)
+
+
+ !
+ ! Work out exchange lists for 2-halo and exchange cell information for 2-halo
+ !
+ block_graph_1Halo % nVertices = block_graph_1Halo % nVerticesTotal
+ block_graph_1Halo % ghostStart = block_graph_1Halo % nVerticesTotal + 1
+
+ ! Get back a graph describing the owned and 1-halo cells plus the cells in the 2-halo
+ call block_decomp_add_halo(domain % dminfo, block_graph_1Halo, block_graph_2Halo)
+
+ block_graph_2Halo % nVertices = block_graph_0Halo % nVertices
+ block_graph_2Halo % ghostStart = block_graph_2Halo % nVertices + 1
+
+#ifdef HAVE_ZOLTAN
+#ifdef _MPI
+ !! For now, only use Zoltan with MPI
+ !! Zoltan initialization
+ call zoltanStart()
+
+ !! Zoltan hook for cells
+ call zoltanOrderLocHSFC_Cells(block_graph_2Halo%nVertices,block_graph_2Halo%VertexID,3,xCell,yCell,zCell)
+#endif
+#endif
+
+ call dmpar_get_owner_list(domain % dminfo, &
+ block_graph_0Halo % nVertices, block_graph_2Halo % nVerticesTotal, &
+ block_graph_0Halo % vertexID, block_graph_2Halo % vertexID, &
+ send2Halo, recv2Halo)
+
+ call dmpar_alltoall_field(domain % dminfo, block_graph_0Halo % vertexID, block_graph_2Halo % vertexID, &
+ block_graph_0Halo % nVertices, block_graph_2Halo % nVerticesTotal, &
+ send2Halo, recv2Halo)
+
+ call dmpar_alltoall_field(domain % dminfo, block_graph_0Halo % nAdjacent, block_graph_2Halo % nAdjacent, &
+ block_graph_0Halo % nVertices, block_graph_2Halo % nVerticesTotal, &
+ send2Halo, recv2Halo)
+
+ call dmpar_alltoall_field(domain % dminfo, block_graph_0Halo % adjacencyList, block_graph_2Halo % adjacencyList, &
+ block_graph_0Halo % maxDegree, block_graph_0Halo % nVertices, block_graph_2Halo % nVerticesTotal, &
+ send2Halo, recv2Halo)
+
+
+
+ !
+ ! Knowing which cells are in block and the 2-halo, we can exchange lists of which edges are
+ ! on each cell and which vertices are on each cell from the processes that read these
+ ! fields for each cell to the processes that own the cells
+ !
+ allocate(edgesOnCell_2Halo(maxEdges, block_graph_2Halo % nVerticesTotal))
+ allocate(verticesOnCell_2Halo(maxEdges, block_graph_2Halo % nVerticesTotal))
+
+ call dmpar_get_owner_list(domain % dminfo, &
+ size(indexToCellIDField % array), block_graph_2Halo % nVerticesTotal, &
+ indexToCellIDField % array, block_graph_2Halo % vertexID, &
+ sendCellList, recvCellList)
+
+ call dmpar_alltoall_field(domain % dminfo, edgesOnCellField % array, edgesOnCell_2Halo, &
+ maxEdges, nReadCells, block_graph_2Halo % nVerticesTotal, &
+ sendCellList, recvCellList)
+
+ call dmpar_alltoall_field(domain % dminfo, verticesOnCellField % array, verticesOnCell_2Halo, &
+ maxEdges, nReadCells, block_graph_2Halo % nVerticesTotal, &
+ sendCellList, recvCellList)
+
+
+ !
+ ! Get a list of which edges and vertices are adjacent to cells (including halo cells) in block
+ !
+ call block_decomp_all_edges_in_block(maxEdges, block_graph_2Halo % nVerticesTotal, block_graph_2Halo % nAdjacent, &
+ edgesOnCell_2Halo, nlocal_edges, local_edge_list)
+ call block_decomp_all_edges_in_block(maxEdges, block_graph_2Halo % nVerticesTotal, block_graph_2Halo % nAdjacent, &
+ verticesOnCell_2Halo, nlocal_vertices, local_vertex_list)
+
+ call dmpar_get_owner_list(domain % dminfo, &
+ size(indexToEdgeIDField % array), nlocal_edges, &
+ indexToEdgeIDField % array, local_edge_list, &
+ sendEdgeList, recvEdgeList)
+
+ call dmpar_get_owner_list(domain % dminfo, &
+ size(indexToVertexIDField % array), nlocal_vertices, &
+ indexToVertexIDField % array, local_vertex_list, &
+ sendVertexList, recvVertexList)
+
+
+
+ !
+ ! Work out which edges and vertices are owned by this process, and which are ghost
+ !
+ allocate(cellsOnEdge_2Halo(2,nlocal_edges))
+ allocate(cellsOnVertex_2Halo(vertexDegree,nlocal_vertices))
+
+ call dmpar_alltoall_field(domain % dminfo, cellsOnEdgeField % array, cellsOnEdge_2Halo, &
+ 2, size(cellsOnEdgeField % array, 2), nlocal_edges, &
+ sendEdgeList, recvEdgeList)
+
+ call dmpar_alltoall_field(domain % dminfo, cellsOnVertexField % array, cellsOnVertex_2Halo, &
+ vertexDegree, size(cellsOnVertexField % array, 2), nlocal_vertices, &
+ sendVertexList, recvVertexList)
+
+
+ call block_decomp_partitioned_edge_list(block_graph_2Halo % nVertices, &
+ block_graph_2Halo % vertexID(1:block_graph_2Halo % nVertices), &
+ 2, nlocal_edges, cellsOnEdge_2Halo, local_edge_list, ghostEdgeStart)
+ call block_decomp_partitioned_edge_list(block_graph_2Halo % nVertices, &
+ block_graph_2Halo % vertexID(1:block_graph_2Halo % nVertices), &
+ vertexDegree, nlocal_vertices, cellsOnVertex_2Halo, local_vertex_list, ghostVertexStart)
+
+
+ ! At this point, local_edge_list(1;ghostEdgeStart-1) contains all of the owned edges for this block
+ ! and local_edge_list(ghostEdgeStart:nlocal_edges) contains all of the ghost edges
+
+ ! At this point, local_vertex_list(1;ghostVertexStart-1) contains all of the owned vertices for this block
+ ! and local_vertex_list(ghostVertexStart:nlocal_vertices) contains all of the ghost vertices
+
+ ! Also, at this point, block_graph_2Halo % vertexID(1:block_graph_2Halo%nVertices) contains all of the owned
+ ! cells for this block, and block_graph_2Halo % vertexID(block_graph_2Halo%nVertices+1:block_graph_2Halo%nVerticesTotal)
+ ! contains all of the ghost cells
+
+
+ deallocate(sendEdgeList % list)
+ deallocate(sendEdgeList)
+ deallocate(recvEdgeList % list)
+ deallocate(recvEdgeList)
+
+ deallocate(sendVertexList % list)
+ deallocate(sendVertexList)
+ deallocate(recvVertexList % list)
+ deallocate(recvVertexList)
+
+#ifdef HAVE_ZOLTAN
+#ifdef _MPI
+ allocate(xEdge(nlocal_edges))
+ allocate(yEdge(nlocal_edges))
+ allocate(zEdge(nlocal_edges))
+ allocate(xVertex(nlocal_vertices))
+ allocate(yVertex(nlocal_vertices))
+ allocate(zVertex(nlocal_vertices))
+#endif
+#endif
+
+ !
+ ! Knowing which edges/vertices are owned by this block and which are actually read
+ ! from the input or restart file, we can build exchange lists to perform
+ ! all-to-all field exchanges from process that reads a field to the processes that
+ ! need them
+ !
+ call dmpar_get_owner_list(domain % dminfo, &
+ size(indexToEdgeIDField % array), nlocal_edges, &
+ indexToEdgeIDField % array, local_edge_list, &
+ sendEdgeList, recvEdgeList)
+
+ call dmpar_get_owner_list(domain % dminfo, &
+ size(indexToVertexIDField % array), nlocal_vertices, &
+ indexToVertexIDField % array, local_vertex_list, &
+ sendVertexList, recvVertexList)
+
+#ifdef HAVE_ZOLTAN
+#ifdef _MPI
+ call dmpar_alltoall_field(domain % dminfo, xEdgeField % array, xEdge, &
+ size(xEdgeField % array), nlocal_edges, &
+ sendEdgeList, recvEdgeList)
+ call dmpar_alltoall_field(domain % dminfo, yEdgeField % array, yEdge, &
+ size(yEdgeField % array), nlocal_edges, &
+ sendEdgeList, recvEdgeList)
+ call dmpar_alltoall_field(domain % dminfo, zEdgeField % array, zEdge, &
+ size(zEdgeField % array), nlocal_edges, &
+ sendEdgeList, recvEdgeList)
+
+ call dmpar_alltoall_field(domain % dminfo, xVertexField % array, xVertex, &
+ size(xVertexField % array), nlocal_vertices, &
+ sendVertexList, recvVertexList)
+ call dmpar_alltoall_field(domain % dminfo, yVertexField % array, yVertex, &
+ size(yVertexField % array), nlocal_vertices, &
+ sendVertexList, recvVertexList)
+ call dmpar_alltoall_field(domain % dminfo, zVertexField % array, zVertex, &
+ size(zVertexField % array), nlocal_vertices, &
+ sendVertexList, recvVertexList)
+ !!!!!!!!!!!!!!!!!!
+ !! Reorder edges
+ !!!!!!!!!!!!!!!!!!
+ call zoltanOrderLocHSFC_Edges(ghostEdgeStart-1,local_edge_list,3,xEdge,yEdge,zEdge)
+ !!!!!!!!!!!!!!!!!!
+
+ !!!!!!!!!!!!!!!!!!
+ !! Reorder vertices
+ !!!!!!!!!!!!!!!!!!
+ call zoltanOrderLocHSFC_Verts(ghostVertexStart-1,local_vertex_list,3,xVertex,yVertex,zVertex)
+ !!!!!!!!!!!!!!!!!!
+
+ deallocate(sendEdgeList % list)
+ deallocate(sendEdgeList)
+ deallocate(recvEdgeList % list)
+ deallocate(recvEdgeList)
+
+ deallocate(sendVertexList % list)
+ deallocate(sendVertexList)
+ deallocate(recvVertexList % list)
+ deallocate(recvVertexList)
+
+ !
+ ! Knowing which edges/vertices are owned by this block and which are actually read
+ ! from the input or restart file, we can build exchange lists to perform
+ ! all-to-all field exchanges from process that reads a field to the processes that
+ ! need them
+ !
+ call dmpar_get_owner_list(domain % dminfo, &
+ size(indexToEdgeIDField % array), nlocal_edges, &
+ indexToEdgeIDField % array, local_edge_list, &
+ sendEdgeList, recvEdgeList)
+
+ call dmpar_get_owner_list(domain % dminfo, &
+ size(indexToVertexIDField % array), nlocal_vertices, &
+ indexToVertexIDField % array, local_vertex_list, &
+ sendVertexList, recvVertexList)
+
+#endif
+#endif
+
+ !
+ ! Build ownership and exchange lists for vertical levels
+ ! Essentially, process 0 owns all vertical levels when reading and writing,
+ ! and it distributes them or gathers them to/from all other processes
+ !
+ if (domain % dminfo % my_proc_id == 0) then
+ allocate(local_vertlevel_list(nVertLevels))
+ do i=1,nVertLevels
+ local_vertlevel_list(i) = i
+ end do
+ else
+ allocate(local_vertlevel_list(0))
+ end if
+ allocate(needed_vertlevel_list(nVertLevels))
+ do i=1,nVertLevels
+ needed_vertlevel_list(i) = i
+ end do
+
+ call dmpar_get_owner_list(domain % dminfo, &
+ size(local_vertlevel_list), size(needed_vertlevel_list), &
+ local_vertlevel_list, needed_vertlevel_list, &
+ sendVertLevelList, recvVertLevelList)
+
+ deallocate(local_vertlevel_list)
+ deallocate(needed_vertlevel_list)
+
+ if (domain % dminfo % my_proc_id == 0) then
+ allocate(local_vertlevel_list(nVertLevels+1))
+ do i=1,nVertLevels+1
+ local_vertlevel_list(i) = i
+ end do
+ else
+ allocate(local_vertlevel_list(0))
+ end if
+ allocate(needed_vertlevel_list(nVertLevels+1))
+ do i=1,nVertLevels+1
+ needed_vertlevel_list(i) = i
+ end do
+
+ call dmpar_get_owner_list(domain % dminfo, &
+ size(local_vertlevel_list), size(needed_vertlevel_list), &
+ local_vertlevel_list, needed_vertlevel_list, &
+ sendVertLevelP1List, recvVertLevelP1List)
+
+ deallocate(local_vertlevel_list)
+ deallocate(needed_vertlevel_list)
+
+
+ !
+ ! Read and distribute all fields given ownership lists and exchange lists (maybe already in block?)
+ !
+ allocate(domain % blocklist)
+
+ nCells = block_graph_2Halo % nVerticesTotal
+ nEdges = nlocal_edges
+ nVertices = nlocal_vertices
+
+ call allocate_block(domain % blocklist, domain, &
+#include "dim_dummy_args.inc"
+ )
+
+ !
+ ! Read attributes
+ !
+ call io_input_get_att_text(input_obj, 'on_a_sphere', c_on_a_sphere)
+ call io_input_get_att_real(input_obj, 'sphere_radius', r_sphere_radius)
+ if (index(c_on_a_sphere, 'YES') /= 0) then
+ domain % blocklist % mesh % on_a_sphere = .true.
+ else
+ domain % blocklist % mesh % on_a_sphere = .false.
+ end if
+ domain % blocklist % mesh % sphere_radius = r_sphere_radius
+
+ if (.not. config_do_restart) then
+ input_obj % time = 1
+ else
+ input_obj % time = 1
+
+ !
+ ! If doing a restart, we need to decide which time slice to read from the
+ ! restart file
+ !
+ if (input_obj % rdLocalTime <= 0) then
+ write(0,*) 'Error: Couldn''t find any times in restart file.'
+ call dmpar_abort(domain % dminfo)
+ end if
+ if (domain % dminfo % my_proc_id == IO_NODE) then
+ allocate(xtime % ioinfo)
+ xtime % ioinfo % start(1) = 1
+ xtime % ioinfo % count(1) = input_obj % rdLocalTime
+ allocate(xtime % array(input_obj % rdLocalTime))
+
+ xtime % ioinfo % fieldName = 'xtime'
+ call io_input_field(input_obj, xtime)
+
+ tdiff = 1.E20
+ do i=1,input_obj % rdLocalTime
+ if (abs(xtime % array(i) - config_restart_time) < tdiff) then
+ input_obj % time = i
+ tdiff = abs(xtime % array(i) - config_restart_time)
+ end if
+ end do
+
+ tdiff = xtime % array(input_obj % time)
+
+ deallocate(xtime % ioinfo)
+ deallocate(xtime % array)
+ end if
+
+ call dmpar_bcast_int(domain % dminfo, input_obj % time)
+ call dmpar_bcast_real(domain % dminfo, tdiff)
+
+ write(0,*) 'Restarting model from time ', tdiff
+
+ end if
+
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Do the actual work of reading all fields in from the input or restart file
+ ! For each field:
+ ! 1) Each process reads a contiguous range of cell/edge/vertex indices, which
+ ! may not correspond with the cells/edges/vertices that are owned by the
+ ! process
+ ! 2) All processes then send the global indices that were read to the
+ ! processes that own those indices based on
+ ! {send,recv}{Cell,Edge,Vertex,VertLevel}List
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ call read_and_distribute_fields(domain % dminfo, input_obj, domain % blocklist, &
+ readCellStart, nReadCells, readEdgeStart, nReadEdges, readVertexStart, nReadVertices, &
+ readVertLevelStart, nReadVertLevels, &
+ sendCellList, recvCellList, sendEdgeList, recvEdgeList, sendVertexList, recvVertexList, &
+ sendVertLevelList, recvVertLevelList, sendVertLevelP1List, recvVertLevelP1List)
+
+
+ call io_input_finalize(input_obj, domain % dminfo)
+
+
+ !
+ ! Rename vertices in cellsOnCell, edgesOnCell, etc. to local indices
+ !
+ allocate(cellIDSorted(2,domain % blocklist % mesh % nCells))
+ allocate(edgeIDSorted(2,domain % blocklist % mesh % nEdges))
+ allocate(vertexIDSorted(2,domain % blocklist % mesh % nVertices))
+
+ do i=1,domain % blocklist % mesh % nCells
+ cellIDSorted(1,i) = domain % blocklist % mesh % indexToCellID % array(i)
+ cellIDSorted(2,i) = i
+ end do
+ call quicksort(block_graph_2Halo % nVerticesTotal, cellIDSorted)
+
+ do i=1,domain % blocklist % mesh % nEdges
+ edgeIDSorted(1,i) = domain % blocklist % mesh % indexToEdgeID % array(i)
+ edgeIDSorted(2,i) = i
+ end do
+ call quicksort(nlocal_edges, edgeIDSorted)
+
+ do i=1,domain % blocklist % mesh % nVertices
+ vertexIDSorted(1,i) = domain % blocklist % mesh % indexToVertexID % array(i)
+ vertexIDSorted(2,i) = i
+ end do
+ call quicksort(nlocal_vertices, vertexIDSorted)
+
+
+ do i=1,domain % blocklist % mesh % nCells
+ do j=1,domain % blocklist % mesh % nEdgesOnCell % array(i)
+
+ k = binary_search(cellIDSorted, 2, 1, domain % blocklist % mesh % nCells, &
+ domain % blocklist % mesh % cellsOnCell % array(j,i))
+ if (k <= domain % blocklist % mesh % nCells) then
+ domain % blocklist % mesh % cellsOnCell % array(j,i) = cellIDSorted(2,k)
+ else
+ domain % blocklist % mesh % cellsOnCell % array(j,i) = domain % blocklist % mesh % nCells + 1
+! domain % blocklist % mesh % cellsOnCell % array(j,i) = 0
+ end if
+
+ k = binary_search(edgeIDSorted, 2, 1, domain % blocklist % mesh % nEdges, &
+ domain % blocklist % mesh % edgesOnCell % array(j,i))
+ if (k <= domain % blocklist % mesh % nEdges) then
+ domain % blocklist % mesh % edgesOnCell % array(j,i) = edgeIDSorted(2,k)
+ else
+ domain % blocklist % mesh % edgesOnCell % array(j,i) = domain % blocklist % mesh % nEdges + 1
+! domain % blocklist % mesh % edgesOnCell % array(j,i) = 0
+ end if
+
+ k = binary_search(vertexIDSorted, 2, 1, domain % blocklist % mesh % nVertices, &
+ domain % blocklist % mesh % verticesOnCell % array(j,i))
+ if (k <= domain % blocklist % mesh % nVertices) then
+ domain % blocklist % mesh % verticesOnCell % array(j,i) = vertexIDSorted(2,k)
+ else
+ domain % blocklist % mesh % verticesOnCell % array(j,i) = domain % blocklist % mesh % nVertices + 1
+! domain % blocklist % mesh % verticesOnCell % array(j,i) = 0
+ end if
+
+ end do
+ end do
+
+ do i=1,domain % blocklist % mesh % nEdges
+ do j=1,2
+
+ k = binary_search(cellIDSorted, 2, 1, domain % blocklist % mesh % nCells, &
+ domain % blocklist % mesh % cellsOnEdge % array(j,i))
+ if (k <= domain % blocklist % mesh % nCells) then
+ domain % blocklist % mesh % cellsOnEdge % array(j,i) = cellIDSorted(2,k)
+ else
+ domain % blocklist % mesh % cellsOnEdge % array(j,i) = domain % blocklist % mesh % nCells + 1
+! domain % blocklist % mesh % cellsOnEdge % array(j,i) = 0
+ end if
+
+ k = binary_search(vertexIDSorted, 2, 1, domain % blocklist % mesh % nVertices, &
+ domain % blocklist % mesh % verticesOnEdge % array(j,i))
+ if (k <= domain % blocklist % mesh % nVertices) then
+ domain % blocklist % mesh % verticesOnEdge % array(j,i) = vertexIDSorted(2,k)
+ else
+ domain % blocklist % mesh % verticesOnEdge % array(j,i) = domain % blocklist % mesh % nVertices + 1
+! domain % blocklist % mesh % verticesOnEdge % array(j,i) = 0
+ end if
+
+ end do
+
+ do j=1,domain % blocklist % mesh % nEdgesOnEdge % array(i)
+
+ k = binary_search(edgeIDSorted, 2, 1, domain % blocklist % mesh % nEdges, &
+ domain % blocklist % mesh % edgesOnEdge % array(j,i))
+ if (k <= domain % blocklist % mesh % nEdges) then
+ domain % blocklist % mesh % edgesOnEdge % array(j,i) = edgeIDSorted(2,k)
+ else
+ domain % blocklist % mesh % edgesOnEdge % array(j,i) = domain % blocklist % mesh % nEdges + 1
+! domain % blocklist % mesh % edgesOnEdge % array(j,i) = 0
+ end if
+
+ end do
+ end do
+
+ do i=1,domain % blocklist % mesh % nVertices
+ do j=1,vertexDegree
+
+ k = binary_search(cellIDSorted, 2, 1, domain % blocklist % mesh % nCells, &
+ domain % blocklist % mesh % cellsOnVertex % array(j,i))
+ if (k <= domain % blocklist % mesh % nCells) then
+ domain % blocklist % mesh % cellsOnVertex % array(j,i) = cellIDSorted(2,k)
+ else
+ domain % blocklist % mesh % cellsOnVertex % array(j,i) = domain % blocklist % mesh % nCells + 1
+! domain % blocklist % mesh % cellsOnVertex % array(j,i) = 0
+ end if
+
+ k = binary_search(edgeIDSorted, 2, 1, domain % blocklist % mesh % nEdges, &
+ domain % blocklist % mesh % edgesOnVertex % array(j,i))
+ if (k <= domain % blocklist % mesh % nEdges) then
+ domain % blocklist % mesh % edgesOnVertex % array(j,i) = edgeIDSorted(2,k)
+ else
+ domain % blocklist % mesh % edgesOnVertex % array(j,i) = domain % blocklist % mesh % nEdges + 1
+! domain % blocklist % mesh % edgesOnVertex % array(j,i) = 0
+ end if
+
+ end do
+ end do
+
+ deallocate(cellIDSorted)
+ deallocate(edgeIDSorted)
+ deallocate(vertexIDSorted)
+
+
+ !
+ ! Work out halo exchange lists for cells, edges, and vertices
+ !
+ call dmpar_get_owner_list(domain % dminfo, &
+ block_graph_2Halo % nVertices, block_graph_2Halo % nVerticesTotal, &
+ block_graph_2Halo % vertexID(1:block_graph_2Halo % nVertices), block_graph_2Halo % vertexID, &
+ domain % blocklist % parinfo % cellsToSend, domain % blocklist % parinfo % cellsToRecv)
+
+ call dmpar_get_owner_list(domain % dminfo, &
+ ghostEdgeStart-1, nlocal_edges, &
+ local_edge_list(1:ghostEdgeStart-1), local_edge_list, &
+ domain % blocklist % parinfo % edgesToSend, domain % blocklist % parinfo % edgesToRecv)
+
+ call dmpar_get_owner_list(domain % dminfo, &
+ ghostVertexStart-1, nlocal_vertices, &
+ local_vertex_list(1:ghostVertexStart-1), local_vertex_list, &
+ domain % blocklist % parinfo % verticesToSend, domain % blocklist % parinfo % verticesToRecv)
+
+ domain % blocklist % mesh % nCellsSolve = block_graph_2Halo % nVertices
+ domain % blocklist % mesh % nEdgesSolve = ghostEdgeStart-1
+ domain % blocklist % mesh % nVerticesSolve = ghostVertexStart-1
+ domain % blocklist % mesh % nVertLevelsSolve = domain % blocklist % mesh % nVertLevels ! No vertical decomp yet...
+
+
+ !
+ ! Deallocate fields, graphs, and other memory
+ !
+ deallocate(indexToCellIDField % ioinfo)
+ deallocate(indexToCellIDField % array)
+#ifdef HAVE_ZOLTAN
+#ifdef _MPI
+ deallocate(xCellField % ioinfo)
+ deallocate(xCellField % array)
+ deallocate(yCellField % ioinfo)
+ deallocate(yCellField % array)
+ deallocate(zCellField % ioinfo)
+ deallocate(zCellField % array)
+#endif
+#endif
+ deallocate(indexToEdgeIDField % ioinfo)
+ deallocate(indexToEdgeIDField % array)
+ deallocate(indexToVertexIDField % ioinfo)
+ deallocate(indexToVertexIDField % array)
+ deallocate(cellsOnCellField % ioinfo)
+ deallocate(cellsOnCellField % array)
+ deallocate(edgesOnCellField % ioinfo)
+ deallocate(edgesOnCellField % array)
+ deallocate(verticesOnCellField % ioinfo)
+ deallocate(verticesOnCellField % array)
+ deallocate(cellsOnEdgeField % ioinfo)
+ deallocate(cellsOnEdgeField % array)
+ deallocate(cellsOnVertexField % ioinfo)
+ deallocate(cellsOnVertexField % array)
+ deallocate(cellsOnCell_0Halo)
+ deallocate(nEdgesOnCell_0Halo)
+ deallocate(indexToCellID_0Halo)
+ deallocate(cellsOnEdge_2Halo)
+ deallocate(cellsOnVertex_2Halo)
+ deallocate(edgesOnCell_2Halo)
+ deallocate(verticesOnCell_2Halo)
+ deallocate(block_graph_0Halo % vertexID)
+ deallocate(block_graph_0Halo % nAdjacent)
+ deallocate(block_graph_0Halo % adjacencyList)
+#ifdef HAVE_ZOLTAN
+#ifdef _MPI
+ deallocate(xCell)
+ deallocate(yCell)
+ deallocate(zCell)
+#endif
+#endif
+ end subroutine input_state_for_domain
+
+
+ subroutine read_and_distribute_fields(dminfo, input_obj, block, &
+ readCellsStart, readCellsCount, &
+ readEdgesStart, readEdgesCount, &
+ readVerticesStart, readVerticesCount, &
+ readVertLevelsStart, readVertLevelsCount, &
+ sendCellsList, recvCellsList, &
+ sendEdgesList, recvEdgesList, &
+ sendVerticesList, recvVerticesList, &
+ sendVertLevelsList, recvVertLevelsList, &
+ sendVertLevelsP1List, recvVertLevelsP1List)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ type (io_input_object), intent(in) :: input_obj
+ type (block_type), intent(inout) :: block
+ integer, intent(in) :: readCellsStart, readCellsCount, readEdgesStart, readEdgesCount, readVerticesStart, readVerticesCount
+ integer, intent(in) :: readVertLevelsStart, readVertLevelsCount
+ type (exchange_list), pointer :: sendCellsList, recvCellsList
+ type (exchange_list), pointer :: sendEdgesList, recvEdgesList
+ type (exchange_list), pointer :: sendVerticesList, recvVerticesList
+ type (exchange_list), pointer :: sendVertLevelsList, recvVertLevelsList
+ type (exchange_list), pointer :: sendVertLevelsP1List, recvVertLevelsP1List
+
+ type (field1dInteger) :: int1d
+ type (field2dInteger) :: int2d
+ type (field0dReal) :: real0d
+ type (field1dReal) :: real1d
+ type (field2dReal) :: real2d
+ type (field3dReal) :: real3d
+
+ integer :: i1, i2, i3, i4
+
+ integer, dimension(:), pointer :: super_int1d
+ integer, dimension(:,:), pointer :: super_int2d
+ real (kind=RKIND) :: super_real0d
+ real (kind=RKIND), dimension(:), pointer :: super_real1d
+ real (kind=RKIND), dimension(:,:), pointer :: super_real2d
+ real (kind=RKIND), dimension(:,:,:), pointer :: super_real3d
+
+ integer :: k
+
+ allocate(int1d % ioinfo)
+ allocate(int2d % ioinfo)
+ allocate(real0d % ioinfo)
+ allocate(real1d % ioinfo)
+ allocate(real2d % ioinfo)
+ allocate(real3d % ioinfo)
+
+
+#include "io_input_fields.inc"
+
+ end subroutine read_and_distribute_fields
+
+
+
+ subroutine io_input_init(input_obj, dminfo)
+
+ implicit none
+
+ type (io_input_object), intent(inout) :: input_obj
+ type (dm_info), intent(in) :: dminfo
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+
+
+#ifdef OFFSET64BIT
+ nferr = nf_open(trim(input_obj % filename), ior(NF_SHARE,NF_64BIT_OFFSET), input_obj % rd_ncid)
+#else
+ nferr = nf_open(trim(input_obj % filename), NF_SHARE, input_obj % rd_ncid)
+#endif
+
+ if (nferr /= NF_NOERR) then
+ write(0,*) ' '
+ if (config_do_restart) then
+ write(0,*) 'Error opening restart file ''', trim(input_obj % filename), ''''
+ else
+ write(0,*) 'Error opening input file ''', trim(input_obj % filename), ''''
+ end if
+ write(0,*) ' '
+ call dmpar_abort(dminfo)
+ end if
+
+#include "netcdf_read_ids.inc"
+
+ end subroutine io_input_init
+
+
+ subroutine io_input_get_dimension(input_obj, dimname, dimsize)
+
+ implicit none
+
+ type (io_input_object), intent(in) :: input_obj
+ character (len=*), intent(in) :: dimname
+ integer, intent(out) :: dimsize
+
+#include "get_dimension_by_name.inc"
+
+ end subroutine io_input_get_dimension
+
+
+ subroutine io_input_get_att_real(input_obj, attname, attvalue)
+
+ implicit none
+
+ type (io_input_object), intent(in) :: input_obj
+ character (len=*), intent(in) :: attname
+ real (kind=RKIND), intent(out) :: attvalue
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+
+ if (RKIND == 8) then
+ nferr = nf_get_att_double(input_obj % rd_ncid, NF_GLOBAL, attname, attvalue)
+ else
+ nferr = nf_get_att_real(input_obj % rd_ncid, NF_GLOBAL, attname, attvalue)
+ end if
+ if (nferr /= NF_NOERR) then
+ write(0,*) 'Warning: Attribute '//trim(attname)//&
+ ' not found in '//trim(input_obj % filename)
+ if (index(attname, 'sphere_radius') /= 0) then
+ write(0,*) ' Setting '//trim(attname)//' to 1.0'
+ attvalue = 1.0
+ end if
+ end if
+
+ end subroutine io_input_get_att_real
+
+
+ subroutine io_input_get_att_text(input_obj, attname, attvalue)
+
+ implicit none
+
+ type (io_input_object), intent(in) :: input_obj
+ character (len=*), intent(in) :: attname
+ character (len=*), intent(out) :: attvalue
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+
+ nferr = nf_get_att_text(input_obj % rd_ncid, NF_GLOBAL, attname, attvalue)
+ if (nferr /= NF_NOERR) then
+ write(0,*) 'Warning: Attribute '//trim(attname)//&
+ ' not found in '//trim(input_obj % filename)
+ if (index(attname, 'on_a_sphere') /= 0) then
+ write(0,*) ' Setting '//trim(attname)//' to ''YES'''
+ attvalue = 'YES'
+ end if
+ end if
+
+ end subroutine io_input_get_att_text
+
+
+ subroutine io_input_field0dReal(input_obj, field)
+
+ implicit none
+
+ type (io_input_object), intent(in) :: input_obj
+ type (field0dReal), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(1) :: start1, count1
+
+ start1(1) = 1
+ count1(1) = 1
+
+#include "input_field0dreal.inc"
+
+#if (RKIND == 8)
+ nferr = nf_get_vara_double(input_obj % rd_ncid, varID, start1, count1, field % scalar)
+#else
+ nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start1, count1, field % scalar)
+#endif
+
+ end subroutine io_input_field0dReal
+
+
+ subroutine io_input_field1dReal(input_obj, field)
+
+ implicit none
+
+ type (io_input_object), intent(in) :: input_obj
+ type (field1dReal), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(1) :: start1, count1
+
+ start1(1) = field % ioinfo % start(1)
+ count1(1) = field % ioinfo % count(1)
+
+ !
+ ! Special case: we may want to read the xtime variable across the
+ ! time dimension as a 1d array.
+ !
+ if (trim(field % ioinfo % fieldName) == 'xtime') then
+ varID = input_obj % rdVarIDxtime
+ end if
+
+#include "input_field1dreal.inc"
+
+#if (RKIND == 8)
+ nferr = nf_get_vara_double(input_obj % rd_ncid, varID, start1, count1, field % array)
+#else
+ nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start1, count1, field % array)
+#endif
+
+ end subroutine io_input_field1dReal
+
+
+ subroutine io_input_field2dReal(input_obj, field)
+
+ implicit none
+
+ type (io_input_object), intent(in) :: input_obj
+ type (field2dReal), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(2) :: start2, count2
+
+ start2(1) = field % ioinfo % start(1)
+ start2(2) = field % ioinfo % start(2)
+ count2(1) = field % ioinfo % count(1)
+ count2(2) = field % ioinfo % count(2)
+
+#include "input_field2dreal.inc"
+
+#if (RKIND == 8)
+ nferr = nf_get_vara_double(input_obj % rd_ncid, varID, start2, count2, field % array)
+#else
+ nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start2, count2, field % array)
+#endif
+
+ end subroutine io_input_field2dReal
+
+
+ subroutine io_input_field3dReal(input_obj, field)
+
+ implicit none
+
+ type (io_input_object), intent(in) :: input_obj
+ type (field3dReal), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(3) :: start3, count3
+
+ start3(1) = field % ioinfo % start(1)
+ start3(2) = field % ioinfo % start(2)
+ start3(3) = field % ioinfo % start(3)
+ count3(1) = field % ioinfo % count(1)
+ count3(2) = field % ioinfo % count(2)
+ count3(3) = field % ioinfo % count(3)
+
+#include "input_field3dreal.inc"
+
+#if (RKIND == 8)
+ nferr = nf_get_vara_double(input_obj % rd_ncid, varID, start3, count3, field % array)
+#else
+ nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start3, count3, field % array)
+#endif
+
+ end subroutine io_input_field3dReal
+
+
+ subroutine io_input_field0dReal_time(input_obj, field)
+
+ implicit none
+
+ type (io_input_object), intent(in) :: input_obj
+ type (field0dReal), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(1) :: start1, count1
+
+ start1(1) = input_obj % time
+ count1(1) = 1
+
+#include "input_field0dreal_time.inc"
+
+#if (RKIND == 8)
+ nferr = nf_get_vara_double(input_obj % rd_ncid, varID, start1, count1, field % scalar)
+#else
+ nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start1, count1, field % scalar)
+#endif
+
+ end subroutine io_input_field0dReal_time
+
+
+ subroutine io_input_field1dReal_time(input_obj, field)
+
+ implicit none
+
+ type (io_input_object), intent(in) :: input_obj
+ type (field1dReal), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(2) :: start2, count2
+
+ start2(1) = field % ioinfo % start(1)
+ start2(2) = input_obj % time
+ count2(1) = field % ioinfo % count(1)
+ count2(2) = 1
+
+#include "input_field1dreal_time.inc"
+
+#if (RKIND == 8)
+ nferr = nf_get_vara_double(input_obj % rd_ncid, varID, start2, count2, field % array)
+#else
+ nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start2, count2, field % array)
+#endif
+
+ end subroutine io_input_field1dReal_time
+
+
+ subroutine io_input_field2dReal_time(input_obj, field)
+
+ implicit none
+
+ type (io_input_object), intent(in) :: input_obj
+ type (field2dReal), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(3) :: start3, count3
+
+ start3(1) = field % ioinfo % start(1)
+ start3(2) = field % ioinfo % start(2)
+ start3(3) = input_obj % time
+ count3(1) = field % ioinfo % count(1)
+ count3(2) = field % ioinfo % count(2)
+ count3(3) = 1
+
+#include "input_field2dreal_time.inc"
+
+#if (RKIND == 8)
+ nferr = nf_get_vara_double(input_obj % rd_ncid, varID, start3, count3, field % array)
+#else
+ nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start3, count3, field % array)
+#endif
+
+ end subroutine io_input_field2dReal_time
+
+
+ subroutine io_input_field3dReal_time(input_obj, field)
+
+ implicit none
+
+ type (io_input_object), intent(in) :: input_obj
+ type (field3dReal), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(4) :: start4, count4
+
+ start4(1) = field % ioinfo % start(1)
+ start4(2) = field % ioinfo % start(2)
+ start4(3) = field % ioinfo % start(3)
+ start4(4) = input_obj % time
+ count4(1) = field % ioinfo % count(1)
+ count4(2) = field % ioinfo % count(2)
+ count4(3) = field % ioinfo % count(3)
+ count4(4) = 1
+
+#include "input_field3dreal_time.inc"
+
+#if (RKIND == 8)
+ nferr = nf_get_vara_double(input_obj % rd_ncid, varID, start4, count4, field % array)
+#else
+ nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start4, count4, field % array)
+#endif
+
+ end subroutine io_input_field3dReal_time
+
+
+ subroutine io_input_field1dInteger(input_obj, field)
+
+ implicit none
+
+ type (io_input_object), intent(in) :: input_obj
+ type (field1dInteger), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(1) :: start1, count1
+
+ start1(1) = field % ioinfo % start(1)
+ count1(1) = field % ioinfo % count(1)
+
+#include "input_field1dinteger.inc"
+
+ nferr = nf_get_vara_int(input_obj % rd_ncid, varID, start1, count1, field % array)
+
+ end subroutine io_input_field1dInteger
+
+
+ subroutine io_input_field2dInteger(input_obj, field)
+
+ implicit none
+
+ type (io_input_object), intent(in) :: input_obj
+ type (field2dInteger), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(2) :: start2, count2
+
+ start2(1) = field % ioinfo % start(1)
+ start2(2) = field % ioinfo % start(2)
+ count2(1) = field % ioinfo % count(1)
+ count2(2) = field % ioinfo % count(2)
+
+#include "input_field2dinteger.inc"
+
+ nferr = nf_get_vara_int(input_obj % rd_ncid, varID, start2, count2, field % array)
+
+ end subroutine io_input_field2dInteger
+
+
+ subroutine io_input_finalize(input_obj, dminfo)
+
+ implicit none
+
+ type (io_input_object), intent(inout) :: input_obj
+ type (dm_info), intent(in) :: dminfo
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+
+ nferr = nf_close(input_obj % rd_ncid)
+
+ end subroutine io_input_finalize
+
+end module io_input
Added: branches/ocean_projects/triangle_border_swm/src/framework/module_io_output.F
===================================================================
--- branches/ocean_projects/triangle_border_swm/src/framework/module_io_output.F (rev 0)
+++ branches/ocean_projects/triangle_border_swm/src/framework/module_io_output.F 2011-04-29 18:46:19 UTC (rev 810)
@@ -0,0 +1,692 @@
+module io_output
+
+ use grid_types
+ use dmpar
+ use sort
+ use configure
+
+ integer, parameter :: OUTPUT = 1
+ integer, parameter :: RESTART = 2
+
+ type io_output_object
+ integer :: wr_ncid
+ character (len=1024) :: filename
+
+ integer :: time
+
+ integer :: stream
+
+#include "io_output_obj_decls.inc"
+
+ logical :: validExchangeLists
+ type (exchange_list), pointer :: sendCellsList, recvCellsList
+ type (exchange_list), pointer :: sendEdgesList, recvEdgesList
+ type (exchange_list), pointer :: sendVerticesList, recvVerticesList
+ type (exchange_list), pointer :: sendVertLevelsList, recvVertLevelsList
+ type (exchange_list), pointer :: sendVertLevelsP1List, recvVertLevelsP1List
+ end type io_output_object
+
+
+ interface io_output_field
+ module procedure io_output_field0dReal
+ module procedure io_output_field1dReal
+ module procedure io_output_field2dReal
+ module procedure io_output_field3dReal
+ module procedure io_output_field1dInteger
+ module procedure io_output_field2dInteger
+ end interface io_output_field
+
+ interface io_output_field_time
+ module procedure io_output_field0dReal_time
+ module procedure io_output_field1dReal_time
+ module procedure io_output_field2dReal_time
+ module procedure io_output_field3dReal_time
+ end interface io_output_field_time
+
+
+ contains
+
+
+ subroutine output_state_init(output_obj, domain, stream)
+
+ implicit none
+
+ type (io_output_object), intent(inout) :: output_obj
+ type (domain_type), intent(in) :: domain
+ character (len=*) :: stream
+
+ type (block_type), pointer :: block_ptr
+#include "output_dim_actual_decls.inc"
+
+ block_ptr => domain % blocklist
+ nullify(output_obj % sendCellsList)
+ nullify(output_obj % recvCellsList)
+ nullify(output_obj % sendEdgesList)
+ nullify(output_obj % recvEdgesList)
+ nullify(output_obj % sendVerticesList)
+ nullify(output_obj % recvVerticesList)
+ nullify(output_obj % sendVertLevelsList)
+ nullify(output_obj % recvVertLevelsList)
+ nullify(output_obj % sendVertLevelsP1List)
+ nullify(output_obj % recvVertLevelsP1List)
+ output_obj % validExchangeLists = .false.
+
+#include "output_dim_inits.inc"
+
+ call dmpar_sum_int(domain % dminfo, block_ptr % mesh % nCellsSolve, nCellsGlobal)
+ call dmpar_sum_int(domain % dminfo, block_ptr % mesh % nEdgesSolve, nEdgesGlobal)
+ call dmpar_sum_int(domain % dminfo, block_ptr % mesh % nVerticesSolve, nVerticesGlobal)
+ nVertLevelsGlobal = block_ptr % mesh % nVertLevels
+
+ if (trim(stream) == 'OUTPUT') then
+ output_obj % filename = trim(config_output_name)
+ output_obj % stream = OUTPUT
+ else if (trim(stream) == 'RESTART') then
+ output_obj % filename = trim(config_restart_name)
+ output_obj % stream = RESTART
+ end if
+
+ ! For now, we assume that a domain consists only of one block,
+ ! although in future, work needs to be done to write model state
+ ! from many distributed blocks
+ call io_output_init(output_obj, domain % dminfo, &
+ block_ptr % mesh, &
+#include "output_dim_actual_args.inc"
+ )
+
+ end subroutine output_state_init
+
+
+ subroutine output_state_for_domain(output_obj, domain, itime)
+
+ implicit none
+
+ type (io_output_object), intent(inout) :: output_obj
+ type (domain_type), intent(inout) :: domain
+ integer, intent(in) :: itime
+
+ integer :: i, j
+ integer :: nCellsGlobal
+ integer :: nEdgesGlobal
+ integer :: nVerticesGlobal
+ integer :: nVertLevelsGlobal
+ integer, dimension(:), pointer :: neededCellList
+ integer, dimension(:), pointer :: neededEdgeList
+ integer, dimension(:), pointer :: neededVertexList
+ integer, dimension(:), pointer :: neededVertLevelList
+ integer, dimension(:), pointer :: neededVertLevelP1List
+ integer, dimension(:,:), pointer :: cellsOnCell, edgesOnCell, verticesOnCell, &
+ cellsOnEdge, verticesOnEdge, edgesOnEdge, cellsOnVertex, edgesOnVertex
+ integer, dimension(:,:), pointer :: cellsOnCell_save, edgesOnCell_save, verticesOnCell_save, &
+ cellsOnEdge_save, verticesOnEdge_save, edgesOnEdge_save, &
+ cellsOnVertex_save, edgesOnVertex_save
+ type (field1dInteger) :: int1d
+ type (field2dInteger) :: int2d
+ type (field0dReal) :: real0d
+ type (field1dReal) :: real1d
+ type (field2dReal) :: real2d
+ type (field3dReal) :: real3d
+
+ integer :: i1, i2, i3, i4
+
+ integer, dimension(:), pointer :: super_int1d
+ integer, dimension(:,:), pointer :: super_int2d
+ real :: super_real0d
+ real (kind=RKIND), dimension(:), pointer :: super_real1d
+ real (kind=RKIND), dimension(:,:), pointer :: super_real2d
+ real (kind=RKIND), dimension(:,:,:), pointer :: super_real3d
+
+ output_obj % time = itime
+
+ allocate(int1d % ioinfo)
+ allocate(int2d % ioinfo)
+ allocate(real0d % ioinfo)
+ allocate(real1d % ioinfo)
+ allocate(real2d % ioinfo)
+ allocate(real3d % ioinfo)
+
+ call dmpar_sum_int(domain % dminfo, domain % blocklist % mesh % nCellsSolve, nCellsGlobal)
+ call dmpar_sum_int(domain % dminfo, domain % blocklist % mesh % nEdgesSolve, nEdgesGlobal)
+ call dmpar_sum_int(domain % dminfo, domain % blocklist % mesh % nVerticesSolve, nVerticesGlobal)
+ nVertLevelsGlobal = domain % blocklist % mesh % nVertLevels
+
+ allocate(cellsOnCell(domain % blocklist % mesh % maxEdges, domain % blocklist % mesh % nCellsSolve))
+ allocate(edgesOnCell(domain % blocklist % mesh % maxEdges, domain % blocklist % mesh % nCellsSolve))
+ allocate(verticesOnCell(domain % blocklist % mesh % maxEdges, domain % blocklist % mesh % nCellsSolve))
+ allocate(cellsOnEdge(2, domain % blocklist % mesh % nEdgesSolve))
+ allocate(verticesOnEdge(2, domain % blocklist % mesh % nEdgesSolve))
+ allocate(edgesOnEdge(2 * domain % blocklist % mesh % maxEdges, domain % blocklist % mesh % nEdgesSolve))
+ allocate(cellsOnVertex(domain % blocklist % mesh % vertexDegree, domain % blocklist % mesh % nVerticesSolve))
+ allocate(edgesOnVertex(domain % blocklist % mesh % vertexDegree, domain % blocklist % mesh % nVerticesSolve))
+
+
+ !
+ ! Convert connectivity information from local to global indices
+ !
+ do i=1,domain % blocklist % mesh % nCellsSolve
+ do j=1,domain % blocklist % mesh % nEdgesOnCell % array(i)
+ cellsOnCell(j,i) = domain % blocklist % mesh % indexToCellID % array( &
+ domain % blocklist % mesh % cellsOnCell % array(j,i))
+ edgesOnCell(j,i) = domain % blocklist % mesh % indexToEdgeID % array( &
+ domain % blocklist % mesh % edgesOnCell % array(j,i))
+ verticesOnCell(j,i) = domain % blocklist % mesh % indexToVertexID % array( &
+ domain % blocklist % mesh % verticesOnCell % array(j,i))
+ end do
+ do j=domain % blocklist % mesh % nEdgesOnCell % array(i)+1,domain % blocklist % mesh % maxEdges
+ cellsOnCell(j,i) = domain % blocklist % mesh % indexToCellID % array( &
+ domain % blocklist % mesh % nEdgesOnCell % array(i))
+ edgesOnCell(j,i) = domain % blocklist % mesh % indexToEdgeID % array( &
+ domain % blocklist % mesh % nEdgesOnCell % array(i))
+ verticesOnCell(j,i) = domain % blocklist % mesh % indexToVertexID % array( &
+ domain % blocklist % mesh % nEdgesOnCell % array(i))
+ end do
+ end do
+ do i=1,domain % blocklist % mesh % nEdgesSolve
+ cellsOnEdge(1,i) = domain % blocklist % mesh % indexToCellID % array(domain % blocklist % mesh % cellsOnEdge % array(1,i))
+ cellsOnEdge(2,i) = domain % blocklist % mesh % indexToCellID % array(domain % blocklist % mesh % cellsOnEdge % array(2,i))
+ verticesOnEdge(1,i) = domain % blocklist % mesh % indexToVertexID % array( &
+ domain % blocklist % mesh % verticesOnEdge % array(1,i))
+ verticesOnEdge(2,i) = domain % blocklist % mesh % indexToVertexID % array( &
+ domain % blocklist % mesh % verticesOnEdge % array(2,i))
+ do j=1,domain % blocklist % mesh % nEdgesOnEdge % array(i)
+ edgesOnEdge(j,i) = domain % blocklist % mesh % indexToEdgeID % array( &
+ domain % blocklist % mesh % edgesOnEdge % array(j,i))
+ end do
+ do j=domain % blocklist % mesh % nEdgesOnEdge % array(i)+1,2*domain % blocklist % mesh % maxEdges
+ if(domain % blocklist % mesh % nEdgesOnEdge % array(i) .eq. 0) then
+ edgesOnEdge(j,i) = domain % blocklist % mesh % nEdgesSolve + 1
+ else
+ edgesOnEdge(j,i) = domain % blocklist % mesh % indexToEdgeID % array( &
+ domain % blocklist % mesh % nEdgesOnEdge % array(i))
+ endif
+ end do
+ end do
+ do i=1,domain % blocklist % mesh % nVerticesSolve
+ do j=1,domain % blocklist % mesh % vertexDegree
+ cellsOnVertex(j,i) = domain % blocklist % mesh % indexToCellID % array( &
+ domain % blocklist % mesh % cellsOnVertex % array(j,i))
+ edgesOnVertex(j,i) = domain % blocklist % mesh % indexToEdgeID % array( &
+ domain % blocklist % mesh % edgesOnVertex % array(j,i))
+ end do
+ end do
+
+ if (domain % dminfo % my_proc_id == 0) then
+ allocate(neededCellList(nCellsGlobal))
+ allocate(neededEdgeList(nEdgesGlobal))
+ allocate(neededVertexList(nVerticesGlobal))
+ allocate(neededVertLevelList(nVertLevelsGlobal))
+ allocate(neededVertLevelP1List(nVertLevelsGlobal+1))
+ do i=1,nCellsGlobal
+ neededCellList(i) = i
+ end do
+ do i=1,nEdgesGlobal
+ neededEdgeList(i) = i
+ end do
+ do i=1,nVerticesGlobal
+ neededVertexList(i) = i
+ end do
+ do i=1,nVertLevelsGlobal
+ neededVertLevelList(i) = i
+ end do
+ do i=1,nVertLevelsGlobal+1
+ neededVertLevelP1List(i) = i
+ end do
+ else
+ allocate(neededCellList(0))
+ allocate(neededEdgeList(0))
+ allocate(neededVertexList(0))
+ allocate(neededVertLevelList(0))
+ allocate(neededVertLevelP1List(0))
+ end if
+
+ if (.not. output_obj % validExchangeLists) then
+ call dmpar_get_owner_list(domain % dminfo, &
+ domain % blocklist % mesh % nCellsSolve, size(neededCellList), &
+ domain % blocklist % mesh % indexToCellID % array, neededCellList, &
+ output_obj % sendCellsList, output_obj % recvCellsList)
+
+ call dmpar_get_owner_list(domain % dminfo, &
+ domain % blocklist % mesh % nEdgesSolve, size(neededEdgeList), &
+ domain % blocklist % mesh % indexToEdgeID % array, neededEdgeList, &
+ output_obj % sendEdgesList, output_obj % recvEdgesList)
+
+ call dmpar_get_owner_list(domain % dminfo, &
+ domain % blocklist % mesh % nVerticesSolve, size(neededVertexList), &
+ domain % blocklist % mesh % indexToVertexID % array, neededVertexList, &
+ output_obj % sendVerticesList, output_obj % recvVerticesList)
+
+ call dmpar_get_owner_list(domain % dminfo, &
+ size(neededVertLevelList), size(neededVertLevelList), &
+ neededVertLevelList, neededVertLevelList, &
+ output_obj % sendVertLevelsList, output_obj % recvVertLevelsList)
+
+ call dmpar_get_owner_list(domain % dminfo, &
+ size(neededVertLevelP1List), size(neededVertLevelP1List), &
+ neededVertLevelP1List, neededVertLevelP1List, &
+ output_obj % sendVertLevelsP1List, output_obj % recvVertLevelsP1List)
+
+ output_obj % validExchangeLists = .true.
+ end if
+
+ deallocate(neededCellList)
+ deallocate(neededEdgeList)
+ deallocate(neededVertexList)
+
+ cellsOnCell_save => domain % blocklist % mesh % cellsOnCell % array
+ edgesOnCell_save => domain % blocklist % mesh % edgesOnCell % array
+ verticesOnCell_save => domain % blocklist % mesh % verticesOnCell % array
+ cellsOnEdge_save => domain % blocklist % mesh % cellsOnEdge % array
+ verticesOnEdge_save => domain % blocklist % mesh % verticesOnEdge % array
+ edgesOnEdge_save => domain % blocklist % mesh % edgesOnEdge % array
+ cellsOnVertex_save => domain % blocklist % mesh % cellsOnVertex % array
+ edgesOnVertex_save => domain % blocklist % mesh % edgesOnVertex % array
+
+ domain % blocklist % mesh % cellsOnCell % array => cellsOnCell
+ domain % blocklist % mesh % edgesOnCell % array => edgesOnCell
+ domain % blocklist % mesh % verticesOnCell % array => verticesOnCell
+ domain % blocklist % mesh % cellsOnEdge % array => cellsOnEdge
+ domain % blocklist % mesh % verticesOnEdge % array => verticesOnEdge
+ domain % blocklist % mesh % edgesOnEdge % array => edgesOnEdge
+ domain % blocklist % mesh % cellsOnVertex % array => cellsOnVertex
+ domain % blocklist % mesh % edgesOnVertex % array => edgesOnVertex
+
+#include "io_output_fields.inc"
+
+ domain % blocklist % mesh % cellsOnCell % array => cellsOnCell_save
+ domain % blocklist % mesh % edgesOnCell % array => edgesOnCell_save
+ domain % blocklist % mesh % verticesOnCell % array => verticesOnCell_save
+ domain % blocklist % mesh % cellsOnEdge % array => cellsOnEdge_save
+ domain % blocklist % mesh % verticesOnEdge % array => verticesOnEdge_save
+ domain % blocklist % mesh % edgesOnEdge % array => edgesOnEdge_save
+ domain % blocklist % mesh % cellsOnVertex % array => cellsOnVertex_save
+ domain % blocklist % mesh % edgesOnVertex % array => edgesOnVertex_save
+
+ deallocate(cellsOnCell)
+ deallocate(edgesOnCell)
+ deallocate(verticesOnCell)
+ deallocate(cellsOnEdge)
+ deallocate(verticesOnEdge)
+ deallocate(edgesOnEdge)
+ deallocate(cellsOnVertex)
+ deallocate(edgesOnVertex)
+
+ end subroutine output_state_for_domain
+
+
+ subroutine output_state_finalize(output_obj, dminfo)
+
+ implicit none
+
+ type (io_output_object), intent(inout) :: output_obj
+ type (dm_info), intent(in) :: dminfo
+
+ call io_output_finalize(output_obj, dminfo)
+
+ end subroutine output_state_finalize
+
+
+ subroutine io_output_init( output_obj, &
+ dminfo, &
+ mesh, &
+#include "dim_dummy_args.inc"
+ )
+
+ implicit none
+
+ include 'netcdf.inc'
+
+ type (io_output_object), intent(inout) :: output_obj
+ type (dm_info), intent(in) :: dminfo
+ type (mesh_type), intent(in) :: mesh
+#include "dim_dummy_decls.inc"
+
+ integer :: nferr
+ integer, dimension(10) :: dimlist
+
+ if (dminfo % my_proc_id == 0) then
+#ifdef OFFSET64BIT
+ nferr = nf_create(trim(output_obj % filename), ior(NF_CLOBBER,NF_64BIT_OFFSET), output_obj % wr_ncid)
+#else
+ nferr = nf_create(trim(output_obj % filename), NF_CLOBBER, output_obj % wr_ncid)
+#endif
+
+#include "netcdf_def_dims_vars.inc"
+
+ if (mesh % on_a_sphere) then
+ nferr = nf_put_att_text(output_obj % wr_ncid, NF_GLOBAL, 'on_a_sphere', 16, 'YES ')
+ else
+ nferr = nf_put_att_text(output_obj % wr_ncid, NF_GLOBAL, 'on_a_sphere', 16, 'NO ')
+ end if
+ if (RKIND == 8) then
+ nferr = nf_put_att_double(output_obj % wr_ncid, NF_GLOBAL, 'sphere_radius', NF_DOUBLE, 1, mesh % sphere_radius)
+ else
+ nferr = nf_put_att_real(output_obj % wr_ncid, NF_GLOBAL, 'sphere_radius', NF_FLOAT, 1, mesh % sphere_radius)
+ end if
+
+ nferr = nf_enddef(output_obj % wr_ncid)
+ end if
+
+ end subroutine io_output_init
+
+
+ subroutine io_output_field0dReal(output_obj, field)
+
+ implicit none
+
+ type (io_output_object), intent(in) :: output_obj
+ type (field0dReal), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(1) :: start1, count1
+
+ start1(1) = 1
+ count1(1) = 1
+
+#include "output_field0dreal.inc"
+
+#if (RKIND == 8)
+ nferr = nf_put_vara_double(output_obj % wr_ncid, varID, start1, count1, field % scalar)
+#else
+ nferr = nf_put_vara_real(output_obj % wr_ncid, varID, start1, count1, field % scalar)
+#endif
+
+ nferr = nf_sync(output_obj % wr_ncid)
+
+ end subroutine io_output_field0dReal
+
+
+ subroutine io_output_field1dReal(output_obj, field)
+
+ implicit none
+
+ type (io_output_object), intent(in) :: output_obj
+ type (field1dReal), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(1) :: start1, count1
+
+ start1(1) = field % ioinfo % start(1)
+ count1(1) = field % ioinfo % count(1)
+
+#include "output_field1dreal.inc"
+
+#if (RKIND == 8)
+ nferr = nf_put_vara_double(output_obj % wr_ncid, VarID, start1, count1, field % array)
+#else
+ nferr = nf_put_vara_real(output_obj % wr_ncid, VarID, start1, count1, field % array)
+#endif
+
+ nferr = nf_sync(output_obj % wr_ncid)
+
+ end subroutine io_output_field1dReal
+
+
+ subroutine io_output_field2dReal(output_obj, field)
+
+ implicit none
+
+ type (io_output_object), intent(in) :: output_obj
+ type (field2dReal), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(2) :: start2, count2
+
+ start2(1) = field % ioinfo % start(1)
+ start2(2) = field % ioinfo % start(2)
+ count2(1) = field % ioinfo % count(1)
+ count2(2) = field % ioinfo % count(2)
+
+#include "output_field2dreal.inc"
+
+#if (RKIND == 8)
+ nferr = nf_put_vara_double(output_obj % wr_ncid, varID, start2, count2, field % array)
+#else
+ nferr = nf_put_vara_real(output_obj % wr_ncid, varID, start2, count2, field % array)
+#endif
+
+ nferr = nf_sync(output_obj % wr_ncid)
+
+ end subroutine io_output_field2dReal
+
+
+ subroutine io_output_field3dReal(output_obj, field)
+
+ implicit none
+
+ type (io_output_object), intent(in) :: output_obj
+ type (field3dReal), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(3) :: start3, count3
+
+ start3(1) = field % ioinfo % start(1)
+ start3(2) = field % ioinfo % start(2)
+ start3(3) = field % ioinfo % start(3)
+ count3(1) = field % ioinfo % count(1)
+ count3(2) = field % ioinfo % count(2)
+ count3(3) = field % ioinfo % count(3)
+
+#include "output_field3dreal.inc"
+
+#if (RKIND == 8)
+ nferr = nf_put_vara_double(output_obj % wr_ncid, varID, start3, count3, field % array)
+#else
+ nferr = nf_put_vara_real(output_obj % wr_ncid, varID, start3, count3, field % array)
+#endif
+
+ nferr = nf_sync(output_obj % wr_ncid)
+
+ end subroutine io_output_field3dReal
+
+
+ subroutine io_output_field0dReal_time(output_obj, field)
+
+ implicit none
+
+ type (io_output_object), intent(in) :: output_obj
+ type (field0dReal), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(1) :: start1, count1
+
+ start1(1) = output_obj % time
+ count1(1) = 1
+
+#include "output_field0dreal_time.inc"
+
+#if (RKIND == 8)
+ nferr = nf_put_vara_double(output_obj % wr_ncid, varID, start1, count1, field % scalar)
+#else
+ nferr = nf_put_vara_real(output_obj % wr_ncid, varID, start1, count1, field % scalar)
+#endif
+
+ nferr = nf_sync(output_obj % wr_ncid)
+
+ end subroutine io_output_field0dReal_time
+
+
+ subroutine io_output_field1dReal_time(output_obj, field)
+
+ implicit none
+
+ type (io_output_object), intent(in) :: output_obj
+ type (field1dReal), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(2) :: start2, count2
+
+ start2(1) = field % ioinfo % start(1)
+ start2(2) = output_obj % time
+ count2(1) = field % ioinfo % count(1)
+ count2(2) = 1
+
+#include "output_field1dreal_time.inc"
+
+#if (RKIND == 8)
+ nferr = nf_put_vara_double(output_obj % wr_ncid, varID, start2, count2, field % array)
+#else
+ nferr = nf_put_vara_real(output_obj % wr_ncid, varID, start2, count2, field % array)
+#endif
+
+ nferr = nf_sync(output_obj % wr_ncid)
+
+ end subroutine io_output_field1dReal_time
+
+
+ subroutine io_output_field2dReal_time(output_obj, field)
+
+ implicit none
+
+ type (io_output_object), intent(in) :: output_obj
+ type (field2dReal), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(3) :: start3, count3
+
+ start3(1) = field % ioinfo % start(1)
+ start3(2) = field % ioinfo % start(2)
+ start3(3) = output_obj % time
+ count3(1) = field % ioinfo % count(1)
+ count3(2) = field % ioinfo % count(2)
+ count3(3) = 1
+
+#include "output_field2dreal_time.inc"
+
+#if (RKIND == 8)
+ nferr = nf_put_vara_double(output_obj % wr_ncid, varID, start3, count3, field % array)
+#else
+ nferr = nf_put_vara_real(output_obj % wr_ncid, varID, start3, count3, field % array)
+#endif
+
+ nferr = nf_sync(output_obj % wr_ncid)
+
+ end subroutine io_output_field2dReal_time
+
+
+ subroutine io_output_field3dReal_time(output_obj, field)
+
+ implicit none
+
+ type (io_output_object), intent(in) :: output_obj
+ type (field3dReal), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(4) :: start4, count4
+
+ start4(1) = field % ioinfo % start(1)
+ start4(2) = field % ioinfo % start(2)
+ start4(3) = field % ioinfo % start(3)
+ start4(4) = output_obj % time
+ count4(1) = field % ioinfo % count(1)
+ count4(2) = field % ioinfo % count(2)
+ count4(3) = field % ioinfo % count(3)
+ count4(4) = 1
+
+#include "output_field3dreal_time.inc"
+
+#if (RKIND == 8)
+ nferr = nf_put_vara_double(output_obj % wr_ncid, varID, start4, count4, field % array)
+#else
+ nferr = nf_put_vara_real(output_obj % wr_ncid, varID, start4, count4, field % array)
+#endif
+
+ nferr = nf_sync(output_obj % wr_ncid)
+
+ end subroutine io_output_field3dReal_time
+
+
+ subroutine io_output_field1dInteger(output_obj, field)
+
+ implicit none
+
+ type (io_output_object), intent(in) :: output_obj
+ type (field1dInteger), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(1) :: start1, count1
+
+ start1(1) = field % ioinfo % start(1)
+ count1(1) = field % ioinfo % count(1)
+
+#include "output_field1dinteger.inc"
+
+ nferr = nf_put_vara_int(output_obj % wr_ncid, varID, start1, count1, field % array)
+
+ nferr = nf_sync(output_obj % wr_ncid)
+
+ end subroutine io_output_field1dInteger
+
+
+ subroutine io_output_field2dInteger(output_obj, field)
+
+ implicit none
+
+ type (io_output_object), intent(in) :: output_obj
+ type (field2dInteger), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(2) :: start2, count2
+
+ start2(1) = field % ioinfo % start(1)
+ start2(2) = field % ioinfo % start(2)
+ count2(1) = field % ioinfo % count(1)
+ count2(2) = field % ioinfo % count(2)
+
+#include "output_field2dinteger.inc"
+
+ nferr = nf_put_vara_int(output_obj % wr_ncid, varID, start2, count2, field % array)
+
+ nferr = nf_sync(output_obj % wr_ncid)
+
+ end subroutine io_output_field2dInteger
+
+
+ subroutine io_output_finalize(output_obj, dminfo)
+
+ implicit none
+
+ include 'netcdf.inc'
+
+ type (io_output_object), intent(inout) :: output_obj
+ type (dm_info), intent(in) :: dminfo
+
+ integer :: nferr
+
+ if (dminfo % my_proc_id == 0) then
+ nferr = nf_close(output_obj % wr_ncid)
+ end if
+
+ end subroutine io_output_finalize
+
+end module io_output
+
Added: branches/ocean_projects/triangle_border_swm/src/framework/module_mpas_framework.F
===================================================================
--- branches/ocean_projects/triangle_border_swm/src/framework/module_mpas_framework.F (rev 0)
+++ branches/ocean_projects/triangle_border_swm/src/framework/module_mpas_framework.F 2011-04-29 18:46:19 UTC (rev 810)
@@ -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
Added: branches/ocean_projects/triangle_border_swm/src/framework/module_sort.F
===================================================================
--- branches/ocean_projects/triangle_border_swm/src/framework/module_sort.F (rev 0)
+++ branches/ocean_projects/triangle_border_swm/src/framework/module_sort.F 2011-04-29 18:46:19 UTC (rev 810)
@@ -0,0 +1,162 @@
+module sort
+
+
+ contains
+
+
+ recursive subroutine mergesort(array, d1, n1, n2)
+
+ implicit none
+
+ ! Arguments
+ integer, intent(in) :: n1, n2, d1
+ integer, dimension(1:d1,n1:n2), intent(inout) :: array
+
+ ! Local variables
+ integer :: i, j, k
+ integer :: rtemp
+ integer, dimension(1:d1,1:n2-n1+1) :: temp
+
+ if (n1 >= n2) return
+
+ if (n2 - n1 == 1) then
+ if (array(1,n1) > array(1,n2)) then
+ do i=1,d1
+ rtemp = array(i,n1)
+ array(i,n1) = array(i,n2)
+ array(i,n2) = rtemp
+ end do
+ end if
+ return
+ end if
+
+ call mergesort(array(1:d1,n1:n1+(n2-n1+1)/2), d1, n1, n1+(n2-n1+1)/2)
+ call mergesort(array(1:d1,n1+((n2-n1+1)/2)+1:n2), d1, n1+((n2-n1+1)/2)+1, n2)
+
+ i = n1
+ j = n1 + ((n2-n1+1)/2) + 1
+ k = 1
+ do while (i <= n1+(n2-n1+1)/2 .and. j <= n2)
+ if (array(1,i) < array(1,j)) then
+ temp(1:d1,k) = array(1:d1,i)
+ k = k + 1
+ i = i + 1
+ else
+ temp(1:d1,k) = array(1:d1,j)
+ k = k + 1
+ j = j + 1
+ end if
+ end do
+
+ if (i <= n1+(n2-n1+1)/2) then
+ do while (i <= n1+(n2-n1+1)/2)
+ temp(1:d1,k) = array(1:d1,i)
+ i = i + 1
+ k = k + 1
+ end do
+ else
+ do while (j <= n2)
+ temp(1:d1,k) = array(1:d1,j)
+ j = j + 1
+ k = k + 1
+ end do
+ end if
+
+ array(1:d1,n1:n2) = temp(1:d1,1:k-1)
+
+ end subroutine mergesort
+
+
+ subroutine quicksort(nArray, array)
+
+ implicit none
+
+ integer, intent(in) :: nArray
+ integer, dimension(2,nArray), intent(inout) :: array
+
+ integer :: i, j, top, l, r, pivot, s
+ integer :: pivot_value
+ integer, dimension(2) :: temp
+ integer, dimension(1000) :: lstack, rstack
+
+ if (nArray < 1) return
+
+ top = 1
+ lstack(top) = 1
+ rstack(top) = nArray
+
+ do while (top > 0)
+
+ l = lstack(top)
+ r = rstack(top)
+ top = top - 1
+
+ pivot = (l+r)/2
+
+ pivot_value = array(1,pivot)
+ temp(:) = array(:,pivot)
+ array(:,pivot) = array(:,r)
+ array(:,r) = temp(:)
+
+ s = l
+ do i=l,r-1
+ if (array(1,i) <= pivot_value) then
+ temp(:) = array(:,s)
+ array(:,s) = array(:,i)
+ array(:,i) = temp(:)
+ s = s + 1
+ end if
+ end do
+
+ temp(:) = array(:,s)
+ array(:,s) = array(:,r)
+ array(:,r) = temp(:)
+
+ if (s-1 > l) then
+ top = top + 1
+if (top > 1000) write(0,*) 'Error: Quicksort exhausted its stack.'
+ lstack(top) = l
+ rstack(top) = s-1
+ end if
+
+ if (r > s+1) then
+ top = top + 1
+if (top > 1000) write(0,*) 'Error: Quicksort exhausted its stack.'
+ lstack(top) = s+1
+ rstack(top) = r
+ end if
+ end do
+
+ end subroutine quicksort
+
+
+ integer function binary_search(array, d1, n1, n2, key)
+
+ implicit none
+
+ integer, intent(in) :: d1, n1, n2, key
+ integer, dimension(d1,n1:n2), intent(in) :: array
+
+ integer :: l, u, k
+
+ binary_search = n2+1
+
+ l = n1
+ u = n2
+ k = (l+u)/2
+ do while (u >= l)
+ if (array(1,k) == key) then
+ binary_search = k
+ exit
+ else if (array(1,k) < key) then
+ l = k + 1
+ k = (l+u)/2
+ else
+ u = k - 1
+ k = (l+u)/2
+ end if
+ end do
+
+ end function binary_search
+
+end module sort
Added: branches/ocean_projects/triangle_border_swm/src/framework/module_timer.F
===================================================================
--- branches/ocean_projects/triangle_border_swm/src/framework/module_timer.F (rev 0)
+++ branches/ocean_projects/triangle_border_swm/src/framework/module_timer.F 2011-04-29 18:46:19 UTC (rev 810)
@@ -0,0 +1,406 @@
+ MODULE timer
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! This module contains utilities for timing individual blocks of code.
+!
+! The module is comprised of three subroutines. These are discussed below:
+!
+! 1) timer_start. This subroutine starts a timer.
+!
+! input: event_name CHARACTER (LEN=72) name of event
+! clear_timer LOGICAL,OPTIONAL clear accumulated times
+!
+! The block of code being timed is associated with an event.
+! The subroutine argument is a character string called event_name.
+! The character string provides a name for the event (or block of code)
+! to be timed. A timer event has a logical attribute called "running"
+! to indicate if the timer is "on" or "off". This is analogous to
+! a stopwatch being "on" or "off".
+!
+! If the event does not already exist, its start time is initialized
+! to the current time, and the timer is turned on. On the other hand,
+! if the event already exists and the timer is off, then the start
+! time is re-initialized to the current time, and the timer is turned
+! on. If it already exists and is on, nothing happens.
+!
+! The optional argument, clear_timer, allows the accumulated times
+! associated with the event to be cleared.
+!
+! 2) timer_stop. this subroutine stops a timer.
+!
+! input: event_name CHARACTER (LEN=72) name of event
+!
+! This subroutine records the current time and turns the timer off.
+! It subtracts the start time of the input event from the current time
+! and records accumulated time for the event.
+!
+! 3) timer_write. this subroutine writes a list of the timings.
+!
+! input: event_name CHARACTER (LEN=72) name of event
+!
+! This subroutine writes a list of times for each event.
+!
+! If an event called "total time" has been initiated, then
+! the subroutine writes the fractional time of the total time
+! for each event.
+!
+! For example...
+!
+! CALL timer_start ("total time")
+! DO i = 1,100
+!
+! CALL timer_start ("event 1")
+! < code block 1 >
+! CALL timer_stop ("event 1")
+!
+! CALL timer_start ("event 2")
+! < code block 2 >
+! CALL timer_stop ("event 2")
+! ENDDO
+!
+! CALL timer_stop ("total_time")
+! CALL timer_write ()
+!
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ IMPLICIT NONE
+ SAVE
+ PRIVATE
+
+#ifdef _MPI
+ include 'mpif.h'
+#endif
+
+ TYPE timer_node
+ CHARACTER (LEN=72) :: event_name
+ LOGICAL :: running
+ REAL :: cpu_start, cpu_stop, cpu_total
+ REAL :: wall_start,wall_stop,wall_total
+ TYPE (timer_node), POINTER :: next
+ END TYPE timer_node
+
+ TYPE (timer_node), POINTER :: timer_events
+
+! public member functions
+ PUBLIC :: &
+ timer_start, &
+ timer_stop, &
+ timer_write
+ CONTAINS
+!cccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5cccgtgccc6ccccccccc7cc
+ SUBROUTINE timer_start (event_name,clear_timer)
+! 19 SEPTEMBER 2002
+ CHARACTER (LEN=*),INTENT (IN) :: event_name
+ LOGICAL ,OPTIONAL,INTENT (IN) :: clear_timer
+ LOGICAL :: event_added,event_found,string_equal
+ INTEGER :: clock,hz
+ TYPE (timer_node), POINTER :: current,temp
+
+ event_added = .FALSE.
+ event_found = .FALSE.
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! THE FIRST TIME timer_start IS CALLED, INITIALIZE LIST
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ IF (.NOT.ASSOCIATED (timer_events)) THEN
+ event_added = .TRUE.
+ ALLOCATE (timer_events); ALLOCATE (timer_events%next)
+ timer_events%event_name = ' '
+ current => timer_events%next
+ NULLIFY (current%next)
+ ELSE
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! LOOK THROUGH THE LIST OF EVENTS TO FIND EVENTS WHICH ALREADY EXIST
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ current => timer_events
+ DO WHILE ((.NOT.event_found).AND.(ASSOCIATED (current)))
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! IF AN EVENTS NAME IS ALREADY ON THE LIST, THEN IT ALREADY EXISTS.
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ string_equal = (TRIM (current%event_name)==TRIM (event_name))
+ IF (string_equal) THEN
+ event_found = .TRUE.
+ ENDIF
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! IF NOT FOUND, THEN KEEP LOOKING
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ IF (.NOT.event_found) THEN
+ current => current%next
+ ENDIF
+ ENDDO
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! IF NOT FOUND, THEN LOOK THROUGH LIST TO FIND POSITION TO ADD NEW EVENT
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ IF (.NOT.event_found) THEN
+ current => timer_events
+ DO WHILE ((.NOT.event_added).AND.(ASSOCIATED (current%next)))
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! ADD A NEW NODE IN THE MIDDLE OF THE LIST
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ IF (LLT (TRIM (current%event_name),TRIM (event_name)).AND. &
+ LLT (TRIM (event_name),TRIM (current%next%event_name))) THEN
+ event_added = .TRUE.
+ temp => current%next
+ NULLIFY (current%next); ALLOCATE (current%next)
+ current => current%next
+ current%next => temp
+ ENDIF
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! IF NOT ADDED, THEN KEEP LOOKING
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ IF (.NOT.event_added) THEN
+ current => current%next
+ ENDIF
+ ENDDO
+ ENDIF
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! IF THE END OF THE LIST IS REACHED AND NOT ADDED
+! AND NOT DOES NOT ALREADY EXIST THEN ADD TO END OF LIST
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ IF ((.NOT.event_added).AND.(.NOT.event_found)) THEN
+ event_added = .TRUE.
+ ALLOCATE (current%next)
+ current => current%next
+ NULLIFY (current%next)
+ ENDIF
+ ENDIF
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! IF NEW EVENT ADDED, THEN INITIALIZE STUFF
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ IF (event_added) THEN
+ current%event_name = event_name
+ current%running = .FALSE.
+ current% cpu_total = 0.0
+ current%wall_total = 0.0
+ ENDIF
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! If (NEW EVENT ADDED) OR (THE EVENT WAS FOUND ON THE LIST BUT IS NOT
+! CURRENTLY running) THEN TURN TIMER ON AND GET THE BEGINNING TIME
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ IF ((event_added).OR.((event_found).AND.(.NOT.current%running))) THEN
+ current%running = .TRUE.
+
+ current% cpu_start = 0.0 ! figure this out later
+
+ CALL system_clock (count=clock)
+ CALL system_clock (count_rate=hz)
+ current%wall_start = REAL (clock)/REAL (hz)
+
+ ENDIF
+
+ IF (PRESENT (clear_timer)) THEN
+ IF (clear_timer) THEN
+ current% cpu_start = 0.0
+ current% cpu_stop = 0.0
+ current% cpu_total = 0.0
+ current%wall_start = 0.0
+ current%wall_stop = 0.0
+ current%wall_total = 0.0
+ ENDIF
+ ENDIF
+
+ END SUBROUTINE timer_start
+!cccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5cccgtgccc6ccccccccc7cc
+ SUBROUTINE timer_stop (event_name)
+! 19 SEPTEMBER 2002
+ LOGICAL :: event_found,string_equal
+ INTEGER :: clock,hz
+ CHARACTER (LEN=*), intent(in) :: event_name
+ TYPE (timer_node), POINTER :: current
+
+ event_found = .FALSE.
+
+ IF (.NOT.ASSOCIATED (timer_events)) THEN
+ PRINT *,' timer_stop :: timer_stop called with no events initiated '
+ STOP
+ ELSE
+ current => timer_events
+ DO WHILE ((.NOT.event_found).AND.(ASSOCIATED (current)))
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! THE EVENT IS FOUND
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ string_equal = (TRIM (current%event_name)==TRIM (event_name))
+ IF (string_equal) THEN
+ event_found = .TRUE.
+ ENDIF
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! IF NOT FOUND THEN KEEP LOOKING
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ IF (.NOT.event_found) THEN
+ current => current%next
+ ENDIF
+ ENDDO
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! IF THE END OF THE LIST IS REACHED AND EVENT NOT FOUND THEN ERROR
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ IF (.NOT.event_found) THEN
+ PRINT *,' timer_stop :: timer_stop called with event_name = "', &
+ event_name,'"'
+ PRINT *,' this event has not been initiated '
+ STOP
+ ENDIF
+ ENDIF
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! IF THE TIMER IS CURRENTLY running, THEN TURN THE TIMER OFF,
+! GET THE STOPPING TIME AND TOTAL ACCUMULATED TIME
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ IF (current%running) THEN
+ current%running = .FALSE.
+
+ current% cpu_stop = 0.0 ! figure this out later
+
+ CALL system_clock (count=clock)
+ CALL system_clock (count_rate=hz)
+ current%wall_stop = REAL (clock)/REAL (hz)
+
+ current% cpu_total = current% cpu_total + &
+ (current% cpu_stop-current% cpu_start)
+ current%wall_total = current%wall_total + &
+ (current%wall_stop-current%wall_start)
+ ENDIF
+
+ END SUBROUTINE timer_stop
+!cccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5cccgtgccc6ccccccccc7cc
+ SUBROUTINE timer_write ( component_name )
+! 19 SEPTEMBER 2002
+ CHARACTER(len=*), intent(in), optional :: component_name
+
+ LOGICAL :: total_found,string_equal
+ INTEGER :: task, my_task, npe
+ INTEGER :: ierr
+ INTEGER :: clock,hz
+ REAL :: cpu_now, cpu_save, cpu_temp
+ REAL :: wall_now,wall_save,wall_temp
+ REAL :: frac
+
+ TYPE (timer_node), POINTER :: current
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! GET THE CURRENT TIME
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ cpu_now = 0.0 ! figure this out later
+
+ CALL system_clock (count=clock)
+ CALL system_clock (count_rate=hz)
+ wall_now = REAL (clock)/REAL (hz)
+
+#ifdef _MPI
+ CALL MPI_BARRIER (MPI_COMM_WORLD,ierr)
+#endif
+
+ IF (.NOT.ASSOCIATED (timer_events)) THEN
+ PRINT *,' timer_write :: timer_write called with no events initiated '
+ STOP
+ ELSE
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! LOOK FOR AN EVENT CALLED 'total time'
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ total_found = .FALSE.
+ current => timer_events%next
+ DO WHILE ((.NOT.total_found).AND.(ASSOCIATED (current)))
+ string_equal = (TRIM (current%event_name)=='total time')
+ IF (string_equal) THEN
+ total_found = .TRUE.
+ IF (current%running) THEN
+ cpu_save = current% cpu_total + &
+ ( cpu_now-current% cpu_start)
+ wall_save = current%wall_total + &
+ (wall_now-current%wall_start)
+ ELSE
+ cpu_save = current% cpu_total
+ wall_save = current%wall_total
+ ENDIF
+ ENDIF
+ IF (.NOT.total_found) THEN
+ current => current%next
+ ENDIF
+ ENDDO
+
+! tdr -- need to link to POP MPI
+! my_task = get_my_task(component_name)
+! npe = get_my_npe(component_name)
+ my_task = 0
+ npe = 1
+
+ DO task = 0,npe-1
+ IF (task==my_task) THEN
+ PRINT *,' '
+ IF (total_found) THEN
+ IF (my_task==0) THEN
+ PRINT *,' TIMINGS (process:event,running,', &
+ 'cpu,wall,100*(wall/total wall))'
+ ENDIF
+ PRINT 20,task,current%event_name,current%running, &
+ cpu_save,wall_save
+ PRINT *,' '
+ ELSE
+ IF (my_task==0) THEN
+ PRINT *,' TIMINGS (process:event,running,', &
+ 'cpu,wall)'
+ ENDIF
+ ENDIF
+
+ current => timer_events%next
+ DO WHILE (ASSOCIATED (current))
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! IF THE TIMER IS RUNNING, COMPUTE THE ACCUMULATED TIME USING THE CURRENT TIME
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ IF (current%running) THEN
+ cpu_temp = current% cpu_total + &
+ ( cpu_now-current% cpu_start)
+ wall_temp = current%wall_total + &
+ (wall_now-current%wall_start)
+ ELSE
+ cpu_temp = current% cpu_total
+ wall_temp = current%wall_total
+ ENDIF
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! IF 'total time' EVENT EXISTS, THEN COMPUTE WALL TIME FRACTION
+! USING TOTAL TIME
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ IF (total_found) THEN
+ string_equal = (TRIM (current%event_name)=='total time')
+ IF (.NOT.string_equal) THEN
+ frac = 100.*wall_temp/(wall_save+1.E-5)
+ PRINT 10, task,current%event_name,current%running, &
+ cpu_temp,wall_temp,frac
+ ENDIF
+ ELSE
+ PRINT 20, task,current%event_name,current%running, &
+ cpu_temp,wall_temp
+ ENDIF
+ current => current%next
+ ENDDO
+ ENDIF
+
+#ifdef _MPI
+ CALL MPI_BARRIER (MPI_COMM_WORLD,ierr)
+#endif
+
+ ENDDO
+ ENDIF
+
+#ifdef _MPI
+ CALL MPI_BARRIER (MPI_COMM_WORLD,ierr)
+#endif
+
+ 10 FORMAT (1x,i5,' : ',a20,l1,2f15.5,f8.2)
+ 20 FORMAT (1x,i5,' : ',a20,l1,2f15.5 )
+
+ END SUBROUTINE timer_write
+!cccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5cccgtgccc6ccccccccc7cc
+ CHARACTER*03 FUNCTION integer_to_string (i) RESULT (string)
+ INTEGER :: i,n
+ REAL*8 :: xi
+ CHARACTER*01 :: char_i(3)
+ CHARACTER*01 :: integers(12)
+
+ integers = (/'0','1','2','3','4','5','6','7','8','9','0','1'/)
+
+ xi = FLOAT (i)/1000.0
+ DO n = 1,3
+ char_i(n) = integers(INT (10.*xi+0.00001)+1)
+ xi = 10.*xi - FLOAT (INT (10.*xi)) + 0.00001
+ ENDDO
+ string = char_i(1)//char_i(2)//char_i(3)
+
+ END FUNCTION integer_to_string
+!cccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5cccgtgccc6ccccccccc7cc
+ END MODULE timer
+!cccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5cccgtgccc6ccccccccc7cc
Added: branches/ocean_projects/triangle_border_swm/src/framework/module_zoltan_interface.F
===================================================================
--- branches/ocean_projects/triangle_border_swm/src/framework/module_zoltan_interface.F (rev 0)
+++ branches/ocean_projects/triangle_border_swm/src/framework/module_zoltan_interface.F 2011-04-29 18:46:19 UTC (rev 810)
@@ -0,0 +1,581 @@
+module zoltan_interface
+ use zoltan
+
+ implicit none
+
+ include 'mpif.h'
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! Data for reordering cells
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ integer :: numCells
+ integer, dimension(:), pointer :: cellIDs
+ integer :: geomDim
+ real (kind=RKIND), dimension(:), pointer :: cellCoordX, cellCoordY, cellCoordZ
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! Data for reordering edges
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ integer :: numEdges
+ integer, dimension(:), pointer :: edgeIDs
+ real (kind=RKIND), dimension(:), pointer :: edgeCoordX, edgeCoordY, edgeCoordZ
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! Data for reordering vertices
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ integer :: numVerts
+ integer, dimension(:), pointer :: vertIDs
+ real (kind=RKIND), dimension(:), pointer :: vertCoordX, vertCoordY, vertCoordZ
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+ contains
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! Perhaps not necessary, but implemented in case it helps
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine zoltanStart()
+
+ integer(Zoltan_INT) :: error
+ real(Zoltan_FLOAT) :: version
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! Body of subroutine
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ error = Zoltan_Initialize(version)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ end subroutine
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine zoltanOrderLocHSFC_Cells(in_numcells,in_cellIDs,in_geomDim,in_cellX, &
+ in_cellY, in_cellZ)
+ implicit none
+
+ integer :: in_numcells
+ integer, dimension(:), pointer :: in_cellIDs
+ integer :: in_geomDim
+ real (kind=RKIND), dimension(:), pointer :: in_cellX, in_cellY, in_cellZ
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! local variables
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ type(Zoltan_Struct), pointer :: zz_obj
+ integer(ZOLTAN_INT) :: ierr
+
+ integer :: numGidEntries, i
+ integer(ZOLTAN_INT), allocatable :: global_ids(:), permIndices(:),permGIDs(:)
+ real(kind=RKIND), allocatable :: permXs(:),permYs(:),permZs(:)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! Body of subroutine
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ numCells = in_numcells
+ cellIDs => in_cellIDs
+ geomDim = in_geomDim
+ cellCoordX => in_cellX
+ cellCoordY => in_cellY
+ cellCoordZ => in_cellZ
+
+ nullify(zz_obj)
+ zz_obj => Zoltan_Create(MPI_COMM_SELF)
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! General Zoltan Parameters
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ierr = Zoltan_Set_Param(zz_obj, "ORDER_METHOD", "LOCAL_HSFC")
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! register query functions
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ierr = Zoltan_Set_Fn(zz_obj, ZOLTAN_NUM_OBJ_FN_TYPE,zqfNumCells)
+ ierr = Zoltan_Set_Fn(zz_obj, ZOLTAN_OBJ_LIST_FN_TYPE,zqfGetCells)
+ ierr = Zoltan_Set_Fn(zz_obj, ZOLTAN_NUM_GEOM_FN_TYPE,zqfGeomDim)
+ ierr = Zoltan_Set_Fn(zz_obj, ZOLTAN_GEOM_FN_TYPE, zqfGetCellGeom)
+
+ numGidEntries=1
+
+ allocate(global_ids(numCells))
+ allocate(permIndices(numCells))
+ allocate(permGIDs(numCells))
+ allocate(permXs(numCells))
+ allocate(permYs(numCells))
+ allocate(permZs(numCells))
+
+ !! MMW: There might be a way to use cellIDs directly
+ do i=1,numCells
+ global_ids(i) = cellIDs(i)
+ end do
+
+ ierr = Zoltan_Order(zz_obj, numGidEntries, numCells, global_ids, permIndices);
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! This is necessary for now until we fix a small bug in Zoltan_Order
+ !!!!!!!!!!!!!!!!!!!!!!!!!!
+ do i=1,numCells
+ permGIDs(i) = global_ids(permIndices(i)+1)
+ permXs(i) = cellCoordX(permIndices(i)+1)
+ permYs(i) = cellCoordY(permIndices(i)+1)
+ permZs(i) = cellCoordZ(permIndices(i)+1)
+ end do
+
+ !!do i=1,numCells
+ !! write(*,*) global_ids(i), permGIDs(i)
+ !!end do
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! Actually change the ordering of the cells
+ !!!!!!!!!!!!!!!!!!!!!!!!!!
+ do i=1,numCells
+ cellIDs(i) = permGIDs(i)
+ cellCoordX(i) = permXs(i)
+ cellCoordY(i) = permYs(i)
+ cellCoordZ(i) = permZs(i)
+ end do
+ !!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ deallocate(global_ids)
+ deallocate(permIndices)
+ deallocate(permGIDs)
+ deallocate(permXs)
+ deallocate(permYs)
+ deallocate(permZs)
+
+ call Zoltan_Destroy(zz_obj)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ end subroutine zoltanOrderLocHSFC_Cells
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! zoltan query function:
+ !! Returns number of cells
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ integer function zqfNumCells(data, ierr)
+
+ ! Local declarations
+ integer(ZOLTAN_INT), intent(in) :: data(*)
+ integer(ZOLTAN_INT), intent(out) :: ierr
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ zqfNumCells = numCells
+ ierr = ZOLTAN_OK
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ end function zqfNumCells
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! zoltan query function:
+ !! Returns lists of Cell IDs
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine zqfGetCells (data, num_gid_entries, num_lid_entries, global_ids, &
+ local_ids, wgt_dim, obj_wgts, ierr)
+ integer(ZOLTAN_INT), intent(in) :: data(*)
+ integer(ZOLTAN_INT), intent(in) :: num_gid_entries, num_lid_entries
+ integer(ZOLTAN_INT), intent(out) :: global_ids(*), local_ids(*)
+ integer(ZOLTAN_INT), intent(in) :: wgt_dim
+ real(ZOLTAN_FLOAT), intent(out) :: obj_wgts(*)
+ integer(ZOLTAN_INT), intent(out) :: ierr
+
+ ! local declarations
+ integer :: i
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ do i= 1, numCells
+ global_ids(i) = cellIDs(i)
+ local_ids(i) = i
+ end do
+
+ ierr = ZOLTAN_OK
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ end subroutine zqfGetCells
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! Zoltan Query Function:
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ integer function zqfGeomDim(data, ierr)
+ !use zoltan
+ implicit none
+ integer(ZOLTAN_INT), intent(in) :: data(*)
+ integer(ZOLTAN_INT) :: ierr
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ zqfGeomDim = geomDim
+ ierr = ZOLTAN_OK
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ end function zqfGeomDim
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! Zoltan Query Function:
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine zqfGetCellGeom(data, num_gid_entries, num_lid_entries, global_id, &
+ local_id, geom_vec, ierr)
+ !use zoltan
+ implicit none
+
+ integer(ZOLTAN_INT), intent(in) :: data(*)
+ integer(ZOLTAN_INT), intent(in) :: num_gid_entries, num_lid_entries
+ integer(ZOLTAN_INT), intent(in) :: global_id, local_id
+ real(ZOLTAN_DOUBLE), intent(out) :: geom_vec(*)
+ integer(ZOLTAN_INT), intent(out) :: ierr
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! Assuming geom_dim is 3
+ geom_vec(1) = cellCoordX(local_id)
+ geom_vec(2) = cellCoordY(local_id)
+ geom_vec(3) = cellCoordZ(local_id)
+
+ ierr = ZOLTAN_OK
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ end subroutine zqfGetCellGeom
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! The ordering functions should perhaps be refactored so that there
+ !! are not separate functions for cells, edges, and vertices
+ !! Not sure if this is worth it with the additional conditionals that would
+ !! be required.
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine zoltanOrderLocHSFC_Edges(in_numedges,in_edgeIDs,in_geomDim,in_edgeX, &
+ in_edgeY, in_edgeZ)
+ implicit none
+
+ integer :: in_numedges
+ integer, dimension(:), pointer :: in_edgeIDs
+ integer :: in_geomDim
+ real (kind=RKIND), dimension(:), pointer :: in_edgeX, in_edgeY, in_edgeZ
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! local variables
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ type(Zoltan_Struct), pointer :: zz_obj
+ integer(ZOLTAN_INT) :: ierr
+
+ integer :: numGidEntries, i
+ integer(ZOLTAN_INT), allocatable :: global_ids(:), permIndices(:),permGIDs(:)
+ real(kind=RKIND), allocatable :: permXs(:),permYs(:),permZs(:)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! Body of subroutine
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ numEdges = in_numedges
+ edgeIDs => in_edgeIDs
+ geomDim = in_geomDim
+ edgeCoordX => in_edgeX
+ edgeCoordY => in_edgeY
+ edgeCoordZ => in_edgeZ
+
+ nullify(zz_obj)
+ zz_obj => Zoltan_Create(MPI_COMM_SELF)
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! General Zoltan Parameters
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ierr = Zoltan_Set_Param(zz_obj, "ORDER_METHOD", "LOCAL_HSFC")
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! register query functions
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ierr = Zoltan_Set_Fn(zz_obj, ZOLTAN_NUM_OBJ_FN_TYPE,zqfNumEdges)
+ ierr = Zoltan_Set_Fn(zz_obj, ZOLTAN_OBJ_LIST_FN_TYPE,zqfGetEdges)
+ ierr = Zoltan_Set_Fn(zz_obj, ZOLTAN_NUM_GEOM_FN_TYPE,zqfGeomDim)
+ ierr = Zoltan_Set_Fn(zz_obj, ZOLTAN_GEOM_FN_TYPE, zqfGetEdgeGeom)
+
+ numGidEntries=1
+
+ allocate(global_ids(numEdges))
+ allocate(permIndices(numEdges))
+ allocate(permGIDs(numEdges))
+ allocate(permXs(numEdges))
+ allocate(permYs(numEdges))
+ allocate(permZs(numEdges))
+
+ !! MMW: There might be a way to use edgeIDs directly
+ do i=1,numEdges
+ global_ids(i) = edgeIDs(i)
+ end do
+
+ ierr = Zoltan_Order(zz_obj, numGidEntries, numEdges, global_ids, permIndices);
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! This is necessary for now until we fix a small bug in Zoltan_Order
+ !!!!!!!!!!!!!!!!!!!!!!!!!!
+ do i=1,numEdges
+ permGIDs(i) = global_ids(permIndices(i)+1)
+ permXs(i) = edgeCoordX(permIndices(i)+1)
+ permYs(i) = edgeCoordY(permIndices(i)+1)
+ permZs(i) = edgeCoordZ(permIndices(i)+1)
+ end do
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! Actually change the ordering of the edges
+ !!!!!!!!!!!!!!!!!!!!!!!!!!
+ do i=1,numEdges
+ edgeIDs(i) = permGIDs(i)
+ edgeCoordX(i) = permXs(i)
+ edgeCoordY(i) = permYs(i)
+ edgeCoordZ(i) = permZs(i)
+ end do
+ !!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ deallocate(global_ids)
+ deallocate(permIndices)
+ deallocate(permGIDs)
+ deallocate(permXs)
+ deallocate(permYs)
+ deallocate(permZs)
+
+ call Zoltan_Destroy(zz_obj)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ end subroutine zoltanOrderLocHSFC_Edges
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! zoltan query function:
+ !! Returns number of edges
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ integer function zqfNumEdges(data, ierr)
+ ! Local declarations
+ integer(ZOLTAN_INT), intent(in) :: data(*)
+ integer(ZOLTAN_INT), intent(out) :: ierr
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ zqfNumEdges = numEdges
+ ierr = ZOLTAN_OK
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ end function zqfNumEdges
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! zoltan query function:
+ !! Returns lists of Edge IDs
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine zqfGetEdges (data, num_gid_entries, num_lid_entries, global_ids, &
+ local_ids, wgt_dim, obj_wgts, ierr)
+ integer(ZOLTAN_INT), intent(in) :: data(*)
+ integer(ZOLTAN_INT), intent(in) :: num_gid_entries, num_lid_entries
+ integer(ZOLTAN_INT), intent(out) :: global_ids(*), local_ids(*)
+ integer(ZOLTAN_INT), intent(in) :: wgt_dim
+ real(ZOLTAN_FLOAT), intent(out) :: obj_wgts(*)
+ integer(ZOLTAN_INT), intent(out) :: ierr
+
+ ! local declarations
+ integer :: i
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ do i= 1, numEdges
+ global_ids(i) = edgeIDs(i)
+ local_ids(i) = i
+ end do
+
+ ierr = ZOLTAN_OK
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ end subroutine zqfGetEdges
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! Zoltan Query Function:
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine zqfGetEdgeGeom(data, num_gid_entries, num_lid_entries, global_id, &
+ local_id, geom_vec, ierr)
+ !use zoltan
+ implicit none
+
+ integer(ZOLTAN_INT), intent(in) :: data(*)
+ integer(ZOLTAN_INT), intent(in) :: num_gid_entries, num_lid_entries
+ integer(ZOLTAN_INT), intent(in) :: global_id, local_id
+ real(ZOLTAN_DOUBLE), intent(out) :: geom_vec(*)
+ integer(ZOLTAN_INT), intent(out) :: ierr
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! Assuming geom_dim is 3
+ geom_vec(1) = edgeCoordX(local_id)
+ geom_vec(2) = edgeCoordY(local_id)
+ geom_vec(3) = edgeCoordZ(local_id)
+
+ ierr = ZOLTAN_OK
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ end subroutine zqfGetEdgeGeom
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine zoltanOrderLocHSFC_Verts(in_numverts,in_vertIDs,in_geomDim,in_vertX, &
+ in_vertY, in_vertZ)
+ implicit none
+
+ integer :: in_numverts
+ integer, dimension(:), pointer :: in_vertIDs
+ integer :: in_geomDim
+ real (kind=RKIND), dimension(:), pointer :: in_vertX, in_vertY, in_vertZ
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! local variables
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ type(Zoltan_Struct), pointer :: zz_obj
+ integer(ZOLTAN_INT) :: ierr
+
+ integer :: numGidEntries, i
+ integer(ZOLTAN_INT), allocatable :: global_ids(:), permIndices(:),permGIDs(:)
+ real(kind=RKIND), allocatable :: permXs(:),permYs(:),permZs(:)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! Body of subroutine
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ numVerts = in_numverts
+ vertIDs => in_vertIDs
+ geomDim = in_geomDim
+ vertCoordX => in_vertX
+ vertCoordY => in_vertY
+ vertCoordZ => in_vertZ
+
+ nullify(zz_obj)
+ zz_obj => Zoltan_Create(MPI_COMM_SELF)
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! General Zoltan Parameters
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ierr = Zoltan_Set_Param(zz_obj, "ORDER_METHOD", "LOCAL_HSFC")
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! register query functions
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ierr = Zoltan_Set_Fn(zz_obj, ZOLTAN_NUM_OBJ_FN_TYPE,zqfNumVerts)
+ ierr = Zoltan_Set_Fn(zz_obj, ZOLTAN_OBJ_LIST_FN_TYPE,zqfGetVerts)
+ ierr = Zoltan_Set_Fn(zz_obj, ZOLTAN_NUM_GEOM_FN_TYPE,zqfGeomDim)
+ ierr = Zoltan_Set_Fn(zz_obj, ZOLTAN_GEOM_FN_TYPE, zqfGetVertGeom)
+
+ numGidEntries=1
+
+ allocate(global_ids(numVerts))
+ allocate(permIndices(numVerts))
+ allocate(permGIDs(numVerts))
+ allocate(permXs(numVerts))
+ allocate(permYs(numVerts))
+ allocate(permZs(numVerts))
+
+ !! MMW: There might be a way to use vertIDs directly
+ do i=1,numVerts
+ global_ids(i) = vertIDs(i)
+ end do
+
+ ierr = Zoltan_Order(zz_obj, numGidEntries, numVerts, global_ids, permIndices);
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! This is necessary for now until we fix a small bug in Zoltan_Order
+ !!!!!!!!!!!!!!!!!!!!!!!!!!
+ do i=1,numVerts
+ permGIDs(i) = global_ids(permIndices(i)+1)
+ permXs(i) = vertCoordX(permIndices(i)+1)
+ permYs(i) = vertCoordY(permIndices(i)+1)
+ permZs(i) = vertCoordZ(permIndices(i)+1)
+ end do
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! Actually change the ordering of the verts
+ !!!!!!!!!!!!!!!!!!!!!!!!!!
+ do i=1,numVerts
+ vertIDs(i) = permGIDs(i)
+ vertCoordX(i) = permXs(i)
+ vertCoordY(i) = permYs(i)
+ vertCoordZ(i) = permZs(i)
+ end do
+ !!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ deallocate(global_ids)
+ deallocate(permIndices)
+ deallocate(permGIDs)
+ deallocate(permXs)
+ deallocate(permYs)
+ deallocate(permZs)
+
+ call Zoltan_Destroy(zz_obj)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ end subroutine zoltanOrderLocHSFC_Verts
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! zoltan query function:
+ !! Returns number of verts
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ integer function zqfNumVerts(data, ierr)
+
+ ! Local declarations
+ integer(ZOLTAN_INT), intent(in) :: data(*)
+ integer(ZOLTAN_INT), intent(out) :: ierr
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ zqfNumVerts = numVerts
+ ierr = ZOLTAN_OK
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ end function zqfNumVerts
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! zoltan query function:
+ !! Returns lists of Vert IDs
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine zqfGetVerts (data, num_gid_entries, num_lid_entries, global_ids, &
+ local_ids, wgt_dim, obj_wgts, ierr)
+
+ integer(ZOLTAN_INT), intent(in) :: data(*)
+ integer(ZOLTAN_INT), intent(in) :: num_gid_entries, num_lid_entries
+ integer(ZOLTAN_INT), intent(out) :: global_ids(*), local_ids(*)
+ integer(ZOLTAN_INT), intent(in) :: wgt_dim
+ real(ZOLTAN_FLOAT), intent(out) :: obj_wgts(*)
+ integer(ZOLTAN_INT), intent(out) :: ierr
+
+ ! local declarations
+ integer :: i
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ do i= 1, numVerts
+ global_ids(i) = vertIDs(i)
+ local_ids(i) = i
+ end do
+
+ ierr = ZOLTAN_OK
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ end subroutine zqfGetVerts
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! Zoltan Query Function:
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine zqfGetVertGeom(data, num_gid_entries, num_lid_entries, global_id, &
+ local_id, geom_vec, ierr)
+ !use zoltan
+ implicit none
+
+ integer(ZOLTAN_INT), intent(in) :: data(*)
+ integer(ZOLTAN_INT), intent(in) :: num_gid_entries, num_lid_entries
+ integer(ZOLTAN_INT), intent(in) :: global_id, local_id
+ real(ZOLTAN_DOUBLE), intent(out) :: geom_vec(*)
+ integer(ZOLTAN_INT), intent(out) :: ierr
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! Assuming geom_dim is 3
+ geom_vec(1) = vertCoordX(local_id)
+ geom_vec(2) = vertCoordY(local_id)
+ geom_vec(3) = vertCoordZ(local_id)
+
+ ierr = ZOLTAN_OK
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ end subroutine zqfGetVertGeom
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+
+
+end module zoltan_interface
Added: branches/ocean_projects/triangle_border_swm/src/framework/streams.c
===================================================================
--- branches/ocean_projects/triangle_border_swm/src/framework/streams.c (rev 0)
+++ branches/ocean_projects/triangle_border_swm/src/framework/streams.c 2011-04-29 18:46:19 UTC (rev 810)
@@ -0,0 +1,39 @@
+#include <stdio.h>
+#include <fcntl.h>
+#include <unistd.h>
+
+#ifdef UNDERSCORE
+#define open_streams open_streams_
+#define close_streams close_streams_
+#else
+#ifdef DOUBLEUNDERSCORE
+#define open_streams open_streams__
+#define close_streams close_streams__
+#endif
+#endif
+
+int fd_out, fd_err;
+
+void open_streams(int * id)
+{
+ char fname[128];
+
+ sprintf(fname, "log.%4.4i.err", *id);
+ fd_err = open(fname,O_CREAT|O_WRONLY|O_TRUNC,0644);
+ if (dup2(fd_err, 2) < 0) {
+ printf("Error duplicating STDERR</font>
<font color="blue">");
+ return;
+ }
+
+ sprintf(fname, "log.%4.4i.out", *id);
+ fd_out = open(fname,O_CREAT|O_WRONLY|O_TRUNC,0644);
+ if (dup2(fd_out, 1) < 0) {
+ printf("Error duplicating STDOUT</font>
<font color="gray">");
+ return;
+ }
+}
+
+void close_streams()
+{
+
+}
Added: branches/ocean_projects/triangle_border_swm/src/operators/Makefile
===================================================================
--- branches/ocean_projects/triangle_border_swm/src/operators/Makefile (rev 0)
+++ branches/ocean_projects/triangle_border_swm/src/operators/Makefile 2011-04-29 18:46:19 UTC (rev 810)
@@ -0,0 +1,20 @@
+.SUFFIXES: .F .o
+
+OBJS = module_RBF_interpolation.o module_vector_reconstruction.o module_spline_interpolation.o
+
+all: operators
+
+operators: $(OBJS)
+ ar -ru libops.a $(OBJS)
+
+module_vector_reconstruction.o: module_RBF_interpolation.o
+module_RBF_interpolation.o:
+module_spline_interpolation:
+
+clean:
+ $(RM) *.o *.mod *.f90 libops.a
+
+.F.o:
+ $(RM) $@ $*.mod
+ $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90
+ $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../framework
Added: branches/ocean_projects/triangle_border_swm/src/operators/module_RBF_interpolation.F
===================================================================
--- branches/ocean_projects/triangle_border_swm/src/operators/module_RBF_interpolation.F (rev 0)
+++ branches/ocean_projects/triangle_border_swm/src/operators/module_RBF_interpolation.F 2011-04-29 18:46:19 UTC (rev 810)
@@ -0,0 +1,1824 @@
+module RBF_interpolation
+ use dmpar
+ use grid_types
+
+ implicit none
+ private
+ save
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Purpose: perform interpolation of scalar and vector functions in 2D
+! and 3D using Radial Basis Functions (RBFs).
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ ! Initialize the geometry that will be useful from interpolation
+ public :: rbfInterp_initialize
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Routines for perofrming interpolation in 2D (including Jacobian and Hessian)
+ ! at locations that vary using a function that is fixed. This is useful
+ ! for finding the location on the the RBF reconstruction of a function
+ ! (e.g., a height field) that minimizes the distance to a point in 3D space
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ public :: rbfInterp_loc_2D_sca_const_compCoeffs, &
+ rbfInterp_loc_2D_sca_lin_compCoeffs, &
+ rbfInterp_loc_2D_sca_const_evalWithDerivs, &
+ rbfInterp_loc_2D_sca_lin_evalWithDerivs
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Routines for computing scalar interpolaiton coefficients in 3D (coplanar points
+ ! in 3D) with support for either constant or constant and linear basis
+ ! functions in addition to RBFs. In constrast to the two subroutines
+ ! above, these coefficients are valid for computing the value of the
+ ! interpolant at a fixe point in space using function values that may
+ ! vary (e.g., in time) at each of the interpolation "source" points.
+ ! The last 3 routines can be used to compute coefficients for imposing both Neumann
+ ! and Dirichlet boundary conditions.
+ ! Pseudocode for function reconstruction at the destinationPoint is as follows
+ ! Dirichlet: functionAtDestination = sum(functionAtSources*dirichletCoefficients)
+ ! Neumann: functionAtDestination = sum(functionOrDerivAtSources*neumannCoefficients)
+ ! where functionOrDerivAtSource = functionAtSources where .not.(isInterface)
+ ! = functionNormalDerivAtSources where isInterface
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ public :: rbfInterp_func_3D_sca_const_dir_compCoeffs, &
+ rbfInterp_func_3DPlane_sca_lin_dir_compCoeffs, &
+ rbfInterp_func_3D_sca_lin_dir_compCoeffs, &
+ rbfInterp_func_3D_sca_const_dirNeu_compCoeffs, &
+ rbfInterp_func_3DPlane_sca_lin_dirNeu_compCoeffs, &
+ rbfInterp_func_3D_sca_lin_dirNeu_compCoeffs
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Routines for computing vector interpolaiton coefficients in 3D (coplanar points
+ ! in 3D) with support for only constant basis functions in addition to RBFs.
+ ! (Linear basis functions can cause problems: a linear vortex flow u = y xHat - x yHat
+ ! cannot be reconstructed from vectors that are only normal to the cell edges in 2D.
+ ! Therefore, we don't support them). As with the scalar 3D subroutines
+ ! above, these coefficients are valid for computing the value of the
+ ! interpolant at a fixe point in space using function values that may
+ ! vary (e.g., in time) at each of the interpolation "source" points.
+ ! The user supplies to these routines a set of sourcePoints and unitVectors
+ ! as well as a destinationPoint and, for the last 2 routines, flags for
+ ! which points are tangent to the interface and which of the supplied unitVectors
+ ! is the normal at the corresponding point.
+ !
+ ! The first two routines compute coefficients that can be used to interpolate
+ ! a vector function to the destination point given "function dot unitVector" values
+ ! at each source point. These routines are useful, for example, for reconstructing
+ ! the full vector velocity at cell centers from the normal components of the velocity
+ ! at cell faces (or cell edges in 2D), or for computing the full velocity at an
+ ! immersed boundary image point based on the normal velocity at several faces and
+ ! the full velocity at boundary points (e.g., a no-slip boundary condition).
+ !
+ ! The last two routines compute coefficients that can be used to interpolate
+ ! a vector function to the destination point given "function dot unitVector" values
+ ! at non-tangent source point and "dFunction/dn dot unitVector" values at
+ ! tangent source point. These routines are useful, for example, for computing the
+ ! full velocity at an immersed boundary image point based on the normal velocity at
+ ! several faces, the normal velocity at boundary points (e.g., u dot n = 0 for a
+ ! no-penetration boundary condition on a fixed boundary), and the normal derivative
+ ! of the tangential components of velocity at the boundary points (e.g., a free-slip
+ ! boundary condition).
+ ! Pseudocode for function reconstruction at the destinationPoint is as follows
+ ! dirichlet: functionAtDestination_i = sum_j(functionDotUnitVectorAtSources_j*coefficients_j,i)
+ ! for i = x,y,z
+ ! tangentNeumann: functionAtDestination_i &
+ ! = sum_(j where .not isTangent) (functionDotUnitVectorAtSources_j*coefficients_j,i) &
+ ! + sum_(j where isTangent) ((dFunction/dn dot UnitVector)_j*coefficients_j,i)
+ ! for i = x,y,z
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ public :: rbfInterp_func_3D_vec_const_dir_compCoeffs, &
+ rbfInterp_func_3DPlane_vec_const_dir_compCoeffs!, &
+ !rbfInterp_func_3D_vec_const_tanNeu_compCoeffs, &
+ !rbfInterp_func_3DPlane_vec_const_tanNeu_compCoeffs
+
+ contains
+
+ subroutine rbfInterp_initialize(grid)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Purpose: compute geometric fields that will be potentially useful for calling
+ ! the interpolation routines
+ !
+ ! Input: the grid
+ !
+ ! Output:
+ ! edgeNormalVectors - the unit vector at the center of each edge tangent to the sphere
+ ! cellTangentPlane - 2 orthogonal unit vectors in the tangent plane of each cell
+ ! The first unit vector is chosen to point toward the center of the first
+ ! edge on the cell.
+ ! localVerticalUnitVectors - the unit normal vector of the tangent plane at the center
+ ! of each cell
+ !
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (mesh_type), intent(inout) :: grid
+
+ integer :: nCells, nEdges
+ integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnCell
+ integer :: iEdge, iCell, cell1, cell2
+ real(kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell, xEdge, yEdge, zEdge
+ real(kind=RKIND), dimension(:,:), pointer :: localVerticalUnitVectors, edgeNormalVectors
+ real(kind=RKIND), dimension(:,:,:), pointer :: cellTangentPlane
+ real(kind=RKIND), dimension(3) :: xHatPlane, yHatPlane, rHat
+ real(kind=RKIND) :: normalDotRHat
+ logical :: on_a_sphere
+
+ xCell => grid % xCell % array
+ yCell => grid % yCell % array
+ zCell => grid % zCell % array
+ xEdge => grid % xEdge % array
+ yEdge => grid % yEdge % array
+ zEdge => grid % zEdge % array
+ cellsOnEdge => grid % cellsOnEdge % array
+ edgesOnCell => grid % edgesOnCell % array
+ nCells = grid % nCells
+ nEdges = grid % nEdges
+ on_a_sphere = grid % on_a_sphere
+
+ localVerticalUnitVectors => grid % localVerticalUnitVectors % array
+ edgeNormalVectors => grid % edgeNormalVectors % array
+ cellTangentPlane => grid % cellTangentPlane % array
+
+ ! init arrays
+ edgeNormalVectors = 0
+ localVerticalUnitVectors = 0
+
+ ! loop over all cells to be solved on this block
+ do iCell=1,nCells
+ if(on_a_sphere) then
+ localVerticalUnitVectors(1,iCell) = xCell(iCell)
+ localVerticalUnitVectors(2,iCell) = yCell(iCell)
+ localVerticalUnitVectors(3,iCell) = zCell(iCell)
+ call unit_vec_in_R3(localVerticalUnitVectors(:,iCell))
+ else ! on a plane
+ localVerticalUnitVectors(:,iCell) = (/ 0., 0., 1. /)
+ end if
+ end do
+
+ do iEdge = 1,nEdges
+ iCell = cellsOnEdge(1,iEdge) ! the normal vector points from the first cell toward the edge
+ if(iCell == nCells+1) then ! this is a boundary edge
+ ! the first cell bordering this edge is not real, use the second cell
+ ! The normal should always point outward at boundaries, away from the valid cell center
+ iCell = cellsOnEdge(2,iEdge)
+ end if
+ ! the normal points from the cell location to the edge location
+ edgeNormalVectors(1,iEdge) = xEdge(iEdge) - xCell(iCell)
+ edgeNormalVectors(2,iEdge) = yEdge(iEdge) - yCell(iCell)
+ edgeNormalVectors(3,iEdge) = zEdge(iEdge) - zCell(iCell)
+ call unit_vec_in_R3(edgeNormalVectors(:,iEdge))
+ end do
+
+ do iCell=1,nCells
+ iEdge = edgesOnCell(1,iCell)
+ ! xHat and yHat are a local basis in the plane of the horizontal cell
+ ! we arbitrarily choose xHat to point toward the first edge
+ rHat = localVerticalUnitVectors(:,iCell)
+ normalDotRHat = sum(edgeNormalVectors(:,iEdge)*rHat)
+ xHatPlane = edgeNormalVectors(:,iEdge) - normalDotRHat*rHat
+ call unit_vec_in_R3(xHatPlane)
+
+ call cross_product_in_R3(rHat, xHatPlane, yHatPlane)
+ call unit_vec_in_R3(yHatPlane) ! just to be sure...
+ cellTangentPlane(:,1,iCell) = xHatPlane
+ cellTangentPlane(:,2,iCell) = yHatPlane
+ end do
+
+ end subroutine rbfInterp_initialize
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Purpose: Compute interpolation coefficients in 2D that can be used to
+ ! reconstruct a given scalar function at varying locations. This is useful
+ ! for finding the location on the the RBF reconstruction of a function
+ ! (e.g., a height field) that minimizes the distance to a point in 3D space.
+ ! The reconstruction is performed with basis functions that are RBFs and constant
+ ! Input:
+ ! pointCount - the number of "source" points and functionValues supplied
+ ! coeffCount - the size of coefficients, must be at least pointCount + 1
+ ! points - the location of the "source" points in the 2D space where the values of
+ ! the function are known
+ ! fieldValues - the values of the function of interest at the points
+ ! alpha - a constant that give the characteristic length scale of the RBFs,
+ ! should be on the order of the distance between points
+ ! Output:
+ ! coefficients - the coefficients needed to perform interpolation of the funciton
+ ! at destination points yet to be specified
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine rbfInterp_loc_2D_sca_const_compCoeffs(pointCount, coeffCount, &
+ points, fieldValues, alpha, coefficients)
+
+ integer, intent(in) :: pointCount, coeffCount
+ real(kind=RKIND), dimension(pointCount,2), intent(in) :: points
+ real(kind=RKIND), dimension(pointCount), intent(in) :: fieldValues
+ real(kind=RKIND), intent(in) :: alpha
+ real(kind=RKIND), dimension(coeffCount), intent(out) :: coefficients
+
+ integer :: i, j, matrixSize
+ real(kind=RKIND), dimension(pointCount+1,pointCount+1) :: matrix
+ real(kind=RKIND), dimension(pointCount+1) :: rhs
+ integer, dimension(pointCount+1) :: pivotIndices
+ real(kind=RKIND) :: rSquared
+
+ matrixSize = pointCount+1
+ coefficients = 0.0
+ matrix = 0.0
+ rhs = 0.0
+
+ rhs(1:pointCount) = fieldValues
+
+ do j=1,pointCount
+ do i=j,pointCount
+ rSquared = sum((points(j,:) - points(i,:))**2)/alpha**2
+ matrix(i,j) = evaluateRBF(rSquared)
+ matrix(j,i) = matrix(i,j)
+ end do
+ end do
+ do j=1,pointCount
+ matrix(pointCount+1,j) = 1.0
+ matrix(j,pointCount+1) = 1.0
+ end do
+
+ call LEGS(matrix(1:matrixSize,1:matrixSize), matrixSize, rhs(1:matrixSize), &
+ coefficients(1:matrixSize), pivotIndices(1:matrixSize))
+
+ end subroutine rbfInterp_loc_2D_sca_const_compCoeffs
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Purpose: Compute interpolation coefficients in 2D that can be used to
+ ! reconstruct a given scalar function at varying locations. This is useful
+ ! for finding the location on the the RBF reconstruction of a function
+ ! (e.g., a height field) that minimizes the distance to a point in 3D space.
+ ! The reconstruction is performed with basis functions that are RBFs plus constant
+ ! and linear
+ ! Input:
+ ! pointCount - the number of "source" points and functionValues supplied
+ ! coeffCount - the size of coefficients, must be at least pointCount + 3
+ ! points - the location of the "source" points in the 2D space where the values of
+ ! the function are known
+ ! fieldValues - the values of the function of interest at the points
+ ! alpha - a constant that give the characteristic length scale of the RBFs,
+ ! should be on the order of the distance between points
+ ! Output:
+ ! coefficients - the coefficients needed to perform interpolation of the funciton
+ ! at destination points yet to be specified
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine rbfInterp_loc_2D_sca_lin_compCoeffs(pointCount, coeffCount, &
+ points, fieldValues, alpha, coefficients)
+
+ integer, intent(in) :: pointCount, coeffCount
+ real(kind=RKIND), dimension(pointCount,2), intent(in) :: points
+ real(kind=RKIND), dimension(pointCount), intent(in) :: fieldValues
+ real(kind=RKIND), intent(in) :: alpha
+ real(kind=RKIND), dimension(coeffCount), intent(out) :: coefficients
+
+ integer :: i, j, matrixSize
+ real(kind=RKIND), dimension(pointCount+3,pointCount+3) :: matrix
+ real(kind=RKIND), dimension(pointCount+3) :: rhs
+ integer, dimension(pointCount+3) :: pivotIndices
+ real(kind=RKIND) :: rSquared
+
+ coefficients = 0.0
+ matrix = 0.0
+ rhs = 0.0
+
+ rhs(1:pointCount) = fieldValues
+
+ do j=1,pointCount
+ do i=j,pointCount
+ rSquared = sum((points(j,:) - points(i,:))**2)/alpha**2
+ matrix(i,j) = evaluateRBF(rSquared)
+ matrix(j,i) = matrix(i,j)
+ end do
+ end do
+ matrixSize = pointCount+3
+ do j=1,pointCount
+ matrix(pointCount+1,j) = 1.0
+ matrix(pointCount+2,j) = points(j,1)
+ matrix(pointCount+3,j) = points(j,2)
+ matrix(j,pointCount+1:pointCount+3) = matrix(pointCount+1:pointCount+3, j)
+ end do
+ call LEGS(matrix(1:matrixSize,1:matrixSize), matrixSize, rhs(1:matrixSize), &
+ coefficients(1:matrixSize), pivotIndices(1:matrixSize))
+
+ end subroutine rbfInterp_loc_2D_sca_lin_compCoeffs
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Purpose: Evalute a scalar function in 2D using coefficients computed in
+ ! rbfInterp_loc_2D_sca_const_compCoeffs. This
+ ! function can be called repeatedly with different destination points
+ ! to quickly evaluate the interpolating function using the same
+ ! coefficients. This is useful for finding the location on the the
+ ! RBF reconstruction of a function (e.g., a height field) that minimizes
+ ! the distance to a point in 3D space. The reconstruction is performed
+ ! with basis functions that are RBFs and constant
+ ! Input:
+ ! fieldCount - the number fields to be evaluated. This is useful for reconstructing,
+ ! for example, the x-, y- and z-components of a vector field at the same
+ ! point in 2D
+ ! coeffCount - the size of coefficients, must be at least pointCount + 1
+ ! pointCount - the number of "source" points and functionValues supplied
+ ! coefficients - the coefficients needed to perform interpolation of the funciton
+ ! at the evaluationPoint
+ ! evaluationPoint - the point in 2D where the function is to be reconstructed
+ ! points - the location of the "source" points in the 2D space where the values of
+ ! the function are known
+ ! alpha - a constant that give the characteristic length scale of the RBFs,
+ ! should be on the order of the distance between points
+ ! Output:
+ ! derivs - the value of the function, the 2 components of its Jacobian and
+ ! the 3 unique components of its Hessian at the evaluationPoint
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine rbfInterp_loc_2D_sca_const_evalWithDerivs(fieldCount, coeffCount, &
+ pointCount, coefficients, evaluationPoint, points, alpha, derivs)
+ integer, intent(in) :: fieldCount, coeffCount, pointCount
+ real(kind=RKIND), dimension(coeffCount, fieldCount), intent(in) :: coefficients
+ real(kind=RKIND), dimension(2), intent(in) :: evaluationPoint
+ real(kind=RKIND), dimension(pointCount,2), intent(in) :: points
+ real(kind=RKIND), intent(in) :: alpha
+
+ real(kind=RKIND), dimension(6,fieldCount), intent(out) :: derivs
+
+ integer :: pointIndex
+ real(kind=RKIND) :: x, y, rSquared, rbfValue, rbfDerivOverR, rbfSecondDeriv
+
+ derivs = 0.0
+ do pointIndex = 1, pointCount
+ x = (evaluationPoint(1) - points(pointIndex,1))
+ y = (evaluationPoint(2) - points(pointIndex,2))
+ rSquared = x**2 + y**2
+ call evaluateRBFAndDerivs(rSquared/alpha**2, rbfValue, rbfDerivOverR, rbfSecondDeriv)
+ rbfDerivOverR = rbfDerivOverR/alpha**2
+ rbfSecondDeriv = rbfSecondDeriv/alpha**2
+ if(rSquared/alpha**2 < 1e-7) then
+ ! terms 2,3 and 5 are zero by radial symmetry of the RBF
+ derivs(1,:) = derivs(1,:) + coefficients(pointIndex,:)*rbfValue
+ derivs(4,:) = derivs(4,:) + coefficients(pointIndex,:)*rbfSecondDeriv
+ derivs(6,:) = derivs(6,:) + coefficients(pointIndex,:)*rbfSecondDeriv
+ else
+ call evaluateRBFAndDerivs(rSquared, rbfValue, rbfDerivOverR, rbfSecondDeriv)
+ derivs(1,:) = derivs(1,:) + coefficients(pointIndex,:)*rbfValue
+ derivs(2,:) = derivs(2,:) + coefficients(pointIndex,:)*rbfDerivOverR*x
+ derivs(3,:) = derivs(3,:) + coefficients(pointIndex,:)*rbfDerivOverR*y
+ derivs(4,:) = derivs(4,:) + coefficients(pointIndex,:) &
+ * (rbfSecondDeriv*x**2 + rbfDerivOverR*y**2)/rSquared
+ derivs(5,:) = derivs(5,:) + coefficients(pointIndex,:) &
+ * (rbfSecondDeriv - rbfDerivOverR)*x*y/rSquared
+ derivs(6,:) = derivs(6,:) + coefficients(pointIndex,:) &
+ * (rbfSecondDeriv*y**2 + rbfDerivOverR*x**2)/rSquared
+ end if
+ end do
+ derivs(1,:) = derivs(1,:) + coefficients(pointCount+1,:)
+ end subroutine rbfInterp_loc_2D_sca_const_evalWithDerivs
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Purpose: Evalute a scalar function in 2D using coefficients computed in
+ ! rbfInterp_loc_2D_sca_const_compCoeffs. This
+ ! function can be called repeatedly with different destination points
+ ! to quickly evaluate the interpolating function using the same
+ ! coefficients. This is useful for finding the location on the the
+ ! RBF reconstruction of a function (e.g., a height field) that minimizes
+ ! the distance to a point in 3D space. The reconstruction is performed
+ ! with basis functions that are RBFs, constant and linear
+ ! Input:
+ ! fieldCount - the number fields to be evaluated. This is useful for reconstructing,
+ ! for example, the x-, y- and z-components of a vector field at the same
+ ! point in 2D
+ ! coeffCount - the size of coefficients, must be at least pointCount + 1
+ ! pointCount - the number of "source" points and functionValues supplied
+ ! coefficients - the coefficients needed to perform interpolation of the funciton
+ ! at the evaluationPoint
+ ! evaluationPoint - the point in 2D where the function is to be reconstructed
+ ! points - the location of the "source" points in the 2D space where the values of
+ ! the function are known
+ ! alpha - a constant that give the characteristic length scale of the RBFs,
+ ! should be on the order of the distance between points
+ ! Output:
+ ! derivs - the value of the function, the 2 components of its Jacobian and
+ ! the 3 unique components of its Hessian at the evaluationPoint
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine rbfInterp_loc_2D_sca_lin_evalWithDerivs(fieldCount, coeffCount, &
+ pointCount, coefficients, evaluationPoint, points, alpha, derivs)
+ integer, intent(in) :: fieldCount, coeffCount, pointCount
+ real(kind=RKIND), dimension(coeffCount, fieldCount), intent(in) :: coefficients
+ real(kind=RKIND), dimension(2), intent(in) :: evaluationPoint
+ real(kind=RKIND), dimension(pointCount,2), intent(in) :: points
+ real(kind=RKIND), intent(in) :: alpha
+
+ real(kind=RKIND), dimension(6,fieldCount), intent(out) :: derivs
+
+ integer :: pointIndex
+ real(kind=RKIND) :: x, y, rSquared, rbfValue, rbfDerivOverR, rbfSecondDeriv
+
+ derivs = 0.0
+ do pointIndex = 1, pointCount
+ x = (evaluationPoint(1) - points(pointIndex,1))
+ y = (evaluationPoint(2) - points(pointIndex,2))
+ rSquared = x**2 + y**2
+ call evaluateRBFAndDerivs(rSquared/alpha**2, rbfValue, rbfDerivOverR, rbfSecondDeriv)
+ rbfDerivOverR = rbfDerivOverR/alpha**2
+ rbfSecondDeriv = rbfSecondDeriv/alpha**2
+ if(rSquared/alpha**2 < 1e-7) then
+ ! terms 2,3 and 5 are zero by radial symmetry of the RBF
+ derivs(1,:) = derivs(1,:) + coefficients(pointIndex,:)*rbfValue
+ derivs(4,:) = derivs(4,:) + coefficients(pointIndex,:)*rbfSecondDeriv
+ derivs(6,:) = derivs(6,:) + coefficients(pointIndex,:)*rbfSecondDeriv
+ else
+ call evaluateRBFAndDerivs(rSquared, rbfValue, rbfDerivOverR, rbfSecondDeriv)
+ derivs(1,:) = derivs(1,:) + coefficients(pointIndex,:)*rbfValue
+ derivs(2,:) = derivs(2,:) + coefficients(pointIndex,:)*rbfDerivOverR*x
+ derivs(3,:) = derivs(3,:) + coefficients(pointIndex,:)*rbfDerivOverR*y
+ derivs(4,:) = derivs(4,:) + coefficients(pointIndex,:) &
+ * (rbfSecondDeriv*x**2 + rbfDerivOverR*y**2)/rSquared
+ derivs(5,:) = derivs(5,:) + coefficients(pointIndex,:) &
+ * (rbfSecondDeriv - rbfDerivOverR)*x*y/rSquared
+ derivs(6,:) = derivs(6,:) + coefficients(pointIndex,:) &
+ * (rbfSecondDeriv*y**2 + rbfDerivOverR*x**2)/rSquared
+ end if
+ end do
+ derivs(1,:) = derivs(1,:) + coefficients(pointCount+1,:) &
+ + coefficients(pointCount+2,:)*evaluationPoint(1) &
+ + coefficients(pointCount+3,:)*evaluationPoint(2)
+ derivs(2,:) = derivs(2,:) + coefficients(pointCount+2,:)
+ derivs(3,:) = derivs(3,:) + coefficients(pointCount+3,:)
+
+ end subroutine rbfInterp_loc_2D_sca_lin_evalWithDerivs
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Purpose: Compute interpolation coefficients in 3D that can be used to
+ ! interpolate a number of scalar functions at a given locations. This is useful
+ ! if the interpolation location does not change with time, or if several
+ ! fields are to be interpolated at a given time step. (If both the fields
+ ! and the interpolation locations vary with time, there is no clear advantage in
+ ! using either this method or the method for 2D interpoaltion above; for simplicity
+ ! and because we foresee more uses for the method of this subroutine, we have not
+ ! implemented a 3D version of the fixed field, variable interpolation location method
+ ! as we have in 2D.) Coefficients are produced for handling Dirichlet boundary
+ ! conditions (or no boundaries). The interpolation is performed with basis functions
+ ! that are RBFs plus a constant.
+ ! Input:
+ ! pointCount - the number of "source" points and functionValues supplied
+ ! sourcePoints - the location of the "source" points in the 3D space where the values of
+ ! the function are known
+ ! destinationPoint - the point where the interpolation will be performed
+ ! alpha - a constant that give the characteristic length scale of the RBFs,
+ ! should be on the order of the distance between points
+ ! Output:
+ ! coefficients - the coefficients used to interpolate a function with Dirichlet
+ ! boundary conditions to the specified destinationPoint
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine rbfInterp_func_3D_sca_const_dir_compCoeffs( &
+ pointCount, sourcePoints, destinationPoint, alpha, coefficients)
+
+ integer, intent(in) :: pointCount
+ real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints
+ real(kind=RKIND), dimension(3), intent(in) :: destinationPoint
+ real(kind=RKIND), intent(in) :: alpha
+ real(kind=RKIND), dimension(pointCount), intent(out) :: coefficients
+
+ integer :: i, j
+ integer :: matrixSize
+
+ real(kind=RKIND), dimension(:,:), pointer :: dirichletMatrix
+ real(kind=RKIND), dimension(:), pointer :: rhs, coeffs
+ integer, dimension(:), pointer :: pivotIndices
+
+ matrixSize = pointCount+1 !! 1 extra space for constant
+
+ allocate(dirichletMatrix(matrixSize,matrixSize))
+ allocate(rhs(matrixSize))
+ allocate(coeffs(matrixSize))
+ allocate(pivotIndices(matrixSize))
+
+ dirichletMatrix = 0.0
+ rhs = 0.0
+ coeffs = 0.0
+
+ call setUpScalarRBFDirichletMatrixAndRHS(pointCount, sourcePoints, destinationPoint, &
+ alpha, dirichletMatrix(1:pointCount,1:pointCount), rhs(1:pointCount))
+
+ do i = 1, pointCount
+ dirichletMatrix(i,pointCount+1) = 1.0
+ dirichletMatrix(pointCount+1,i) = dirichletMatrix(i,pointCount+1)
+ end do
+
+ rhs(pointCount+1) = 1.0
+
+ ! solve each linear system
+ call LEGS(dirichletMatrix, matrixSize, rhs, coeffs, pivotIndices)
+ coefficients = coeffs(1:pointCount)
+
+ deallocate(dirichletMatrix)
+ deallocate(rhs)
+ deallocate(coeffs)
+ deallocate(pivotIndices)
+
+ end subroutine rbfInterp_func_3D_sca_const_dir_compCoeffs
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Purpose: Compute interpolation coefficients in a plane in 3D that can be used to
+ ! interpolate a number of scalar functions at a given locations. This is useful
+ ! if the interpolation location does not change with time, or if several
+ ! fields are to be interpolated at a given time step. (If both the fields
+ ! and the interpolation locations vary with time, there is no clear advantage in
+ ! using either this method or the method for 2D interpoaltion above; for simplicity
+ ! and because we foresee more uses for the method of this subroutine, we have not
+ ! implemented a 3D version of the fixed field, variable interpolation location method
+ ! as we have in 2D.) Coefficients are produced for handling both Dirichlet (or no)
+ ! boundary conditions. The interpolation is performed with basis functions that are
+ ! RBFs plus constant and linear. All points are projected into the plane given by the
+ ! planeBasisVectors.
+ ! Input:
+ ! pointCount - the number of "source" points and functionValues supplied
+ ! sourcePoints - the location of the "source" points in the 3D space where the values of
+ ! the function are known. The points will be projected into the plane given by
+ ! planeBasisVectors
+ ! destinationPoint - the point in 3D where the interpolation will be performed. The
+ ! destinationPoint will be projected into the plane given by planeBasisVectors.
+ ! alpha - a constant that give the characteristic length scale of the RBFs,
+ ! should be on the order of the distance between points
+ ! planeBasisVectors - the basis fectors for the plane where interpolation is performed.
+ ! All points are projected into this plane.
+ ! Output:
+ ! coefficients - the coefficients used to interpolate a function with Dirichlet
+ ! boundary conditions to the specified destinationPoint
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine rbfInterp_func_3DPlane_sca_lin_dir_compCoeffs( &
+ pointCount, sourcePoints, destinationPoint, &
+ alpha, planeBasisVectors, coefficients)
+
+ integer, intent(in) :: pointCount
+ real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints
+ real(kind=RKIND), dimension(3), intent(in) :: destinationPoint
+ real(kind=RKIND), intent(in) :: alpha
+ real(kind=RKIND), dimension(2,3) :: planeBasisVectors
+ real(kind=RKIND), dimension(pointCount), intent(out) :: coefficients
+
+ integer :: i, j
+ integer :: matrixSize
+
+ real(kind=RKIND), dimension(:,:), pointer :: dirichletMatrix
+ real(kind=RKIND), dimension(:), pointer :: rhs, coeffs
+ integer, dimension(:), pointer :: pivotIndices
+
+ matrixSize = pointCount+3 !! 3 extra space for constant and 2 planar dimensions
+
+ allocate(dirichletMatrix(matrixSize,matrixSize))
+ allocate(rhs(matrixSize))
+ allocate(coeffs(matrixSize))
+ allocate(pivotIndices(matrixSize))
+
+ dirichletMatrix = 0.0
+ rhs = 0.0
+ coeffs = 0.0
+
+ call setUpScalarRBFDirichletMatrixAndRHS(pointCount, sourcePoints, destinationPoint, &
+ alpha, dirichletMatrix(1:pointCount,1:pointCount), rhs(1:pointCount))
+
+ do i = 1, pointCount
+ dirichletMatrix(i,pointCount+1) = 1.0
+ dirichletMatrix(i,pointCount+2) = sum(sourcePoints(i,1:3)*planeBasisVectors(1,:))
+ dirichletMatrix(i,pointCount+3) = sum(sourcePoints(i,1:3)*planeBasisVectors(2,:))
+ dirichletMatrix(pointCount+1:pointCount+3,i) &
+ = dirichletMatrix(i,pointCount+1:pointCount+3)
+ end do
+
+ rhs(pointCount+1) = 1.0
+ rhs(pointCount+2) = sum(destinationPoint(1:3)*planeBasisVectors(1,:))
+ rhs(pointCount+3) = sum(destinationPoint(1:3)*planeBasisVectors(2,:))
+
+ ! solve each linear system
+ call LEGS(dirichletMatrix, matrixSize, rhs, coeffs, pivotIndices)
+ coefficients = coeffs(1:pointCount)
+
+ deallocate(dirichletMatrix)
+ deallocate(rhs)
+ deallocate(coeffs)
+ deallocate(pivotIndices)
+
+ end subroutine rbfInterp_func_3DPlane_sca_lin_dir_compCoeffs
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Purpose: Compute interpolation coefficients in 3D that can be used to
+ ! interpolate a number of scalar functions at a given locations. This is useful
+ ! if the interpolation location does not change with time, or if several
+ ! fields are to be interpolated at a given time step. (If both the fields
+ ! and the interpolation locations vary with time, there is no clear advantage in
+ ! using either this method or the method for 2D interpoaltion above; for simplicity
+ ! and because we foresee more uses for the method of this subroutine, we have not
+ ! implemented a 3D version of the fixed field, variable interpolation location method
+ ! as we have in 2D.) Coefficients are produced for handling both Dirichlet (or no)
+ ! boundary conditions. The interpolation is performed with basis functions that are
+ ! RBFs plus constant and linear.
+ ! Input:
+ ! pointCount - the number of "source" points and functionValues supplied
+ ! sourcePoints - the location of the "source" points in the 3D space where the values of
+ ! the function are known
+ ! destinationPoint - the point where the interpolation will be performed
+ ! alpha - a constant that give the characteristic length scale of the RBFs,
+ ! should be on the order of the distance between points
+ ! Output:
+ ! coefficients - the coefficients used to interpolate a function with Dirichlet
+ ! boundary conditions to the specified destinationPoint
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine rbfInterp_func_3D_sca_lin_dir_compCoeffs(pointCount, &
+ sourcePoints, destinationPoint, alpha, coefficients)
+
+ integer, intent(in) :: pointCount
+ real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints
+ real(kind=RKIND), dimension(3), intent(in) :: destinationPoint
+ real(kind=RKIND), intent(in) :: alpha
+ real(kind=RKIND), dimension(pointCount), intent(out) :: coefficients
+
+ integer :: i, j
+ integer :: matrixSize
+
+ real(kind=RKIND), dimension(:,:), pointer :: dirichletMatrix
+ real(kind=RKIND), dimension(:), pointer :: rhs, coeffs
+ integer, dimension(:), pointer :: pivotIndices
+
+ matrixSize = pointCount+4 !! 4 extra space for constant and linear in 3D
+
+ allocate(dirichletMatrix(matrixSize,matrixSize))
+ allocate(rhs(matrixSize))
+ allocate(coeffs(matrixSize))
+ allocate(pivotIndices(matrixSize))
+
+ dirichletMatrix = 0.0
+ rhs = 0.0
+ coeffs = 0.0
+
+ call setUpScalarRBFDirichletMatrixAndRHS(pointCount, sourcePoints, destinationPoint, &
+ alpha, dirichletMatrix(1:pointCount,1:pointCount), rhs(1:pointCount))
+
+ do i = 1, pointCount
+ dirichletMatrix(i,pointCount+1) = 1.0
+ dirichletMatrix(i,pointCount+2:pointCount+4) = sourcePoints(i,1:3)
+ dirichletMatrix(pointCount+1:pointCount+4,i) &
+ = dirichletMatrix(i,pointCount+1:pointCount+4)
+ end do
+
+ rhs(pointCount+1) = 1.0
+ rhs(pointCount+2:pointCount+4) = destinationPoint(1:3)
+
+ ! solve each linear system
+ call LEGS(dirichletMatrix, matrixSize, rhs, coeffs, pivotIndices)
+ coefficients = coeffs(1:pointCount)
+
+ deallocate(dirichletMatrix)
+ deallocate(rhs)
+ deallocate(coeffs)
+ deallocate(pivotIndices)
+
+ end subroutine rbfInterp_func_3D_sca_lin_dir_compCoeffs
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Purpose: Compute interpolation coefficients in 3D that can be used to
+ ! interpolate a number of scalar functions at a given locations. This is useful
+ ! if the interpolation location does not change with time, or if several
+ ! fields are to be interpolated at a given time step. (If both the fields
+ ! and the interpolation locations vary with time, there is no clear advantage in
+ ! using either this method or the method for 2D interpoaltion above; for simplicity
+ ! and because we foresee more uses for the method of this subroutine, we have not
+ ! implemented a 3D version of the fixed field, variable interpolation location method
+ ! as we have in 2D.) Coefficients are produced for handling both Dirichlet and Neumann
+ ! boundary conditions. The interpolation is performed with basis functions that are
+ ! RBFs plus a constant.
+ ! Input:
+ ! pointCount - the number of "source" points and functionValues supplied
+ ! sourcePoints - the location of the "source" points in the 3D space where the values of
+ ! the function are known
+ ! isInterface - a logical array indicating which of the source points (if any) are at
+ ! at the domain interface. These points and their normals will be used to compute the
+ ! neumannCoefficients below
+ ! interfaceNormals - a 3D normal vector for each sourcePoint. These vectors are only used
+ ! at points where isInterface == .true., and can take arbitrary values elsewehere. The
+ ! normal vector is used to compute coefficients for the normal derivative of the
+ ! interpolating function in order to impose the Neumann Boundary condition
+ ! destinationPoint - the point where the interpolation will be performed
+ ! alpha - a constant that give the characteristic length scale of the RBFs,
+ ! should be on the order of the distance between points
+ ! Output:
+ ! dirichletCoefficients - the coefficients used to interpolate a function with Dirichlet
+ ! boundary conditions to the specified destinationPoint
+ ! neumannCoefficients - the coefficients used to interpolate a function with Neumann
+ ! boundary conditions to the specified destinationPoint
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine rbfInterp_func_3D_sca_const_dirNeu_compCoeffs( &
+ pointCount, sourcePoints, isInterface, interfaceNormals, destinationPoint, &
+ alpha, dirichletCoefficients, neumannCoefficients)
+
+ integer, intent(in) :: pointCount
+ real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints
+ logical, dimension(pointCount), intent(in) :: isInterface
+ real(kind=RKIND), dimension(pointCount,3), intent(in) :: interfaceNormals
+ real(kind=RKIND), dimension(3), intent(in) :: destinationPoint
+ real(kind=RKIND), intent(in) :: alpha
+ real(kind=RKIND), dimension(pointCount), intent(out) :: &
+ dirichletCoefficients, neumannCoefficients
+
+ integer :: i, j
+ integer :: matrixSize
+
+ real(kind=RKIND), dimension(:,:), pointer :: dirichletMatrix, neumannMatrix
+ real(kind=RKIND), dimension(:), pointer :: rhs, rhsCopy, coeffs
+ integer, dimension(:), pointer :: pivotIndices
+
+ matrixSize = pointCount+1 !! 1 extra space for constant
+
+ allocate(dirichletMatrix(matrixSize,matrixSize))
+ allocate(neumannMatrix(matrixSize,matrixSize))
+ allocate(rhs(matrixSize))
+ allocate(rhsCopy(matrixSize))
+ allocate(coeffs(matrixSize))
+ allocate(pivotIndices(matrixSize))
+
+ dirichletMatrix = 0.0
+ neumannMatrix = 0.0
+ rhs = 0.0
+ rhsCopy = 0.0
+ coeffs = 0.0
+
+ call setUpScalarRBFMatrixAndRHS(pointCount, &
+ sourcePoints, isInterface, interfaceNormals, destinationPoint, &
+ alpha, dirichletMatrix(1:pointCount,1:pointCount), &
+ neumannMatrix(1:pointCount,1:pointCount), rhs(1:pointCount))
+
+ do i = 1, pointCount
+ dirichletMatrix(i,pointCount+1) = 1.0
+ if(isInterface(i)) then
+ neumannMatrix(i,pointCount+1) = 0.0
+ else
+ neumannMatrix(i,pointCount+1) = dirichletMatrix(i,pointCount+1)
+ end if
+ dirichletMatrix(pointCount+1,i) = dirichletMatrix(i,pointCount+1)
+ neumannMatrix(pointCount+1,i) = neumannMatrix(i,pointCount+1)
+ end do
+
+ rhs(pointCount+1) = 1.0
+
+ ! solve each linear system
+ rhsCopy = rhs
+ call LEGS(dirichletMatrix, matrixSize, rhs, coeffs, pivotIndices)
+ dirichletCoefficients = coeffs(1:pointCount)
+
+ call LEGS(neumannMatrix, matrixSize, rhsCopy, coeffs, pivotIndices)
+ neumannCoefficients = coeffs(1:pointCount)
+
+ deallocate(dirichletMatrix)
+ deallocate(neumannMatrix)
+ deallocate(rhs)
+ deallocate(rhsCopy)
+ deallocate(coeffs)
+ deallocate(pivotIndices)
+
+ end subroutine rbfInterp_func_3D_sca_const_dirNeu_compCoeffs
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Purpose: Compute interpolation coefficients in a plane in 3D that can be used to
+ ! interpolate a number of scalar functions at a given locations. This is useful
+ ! if the interpolation location does not change with time, or if several
+ ! fields are to be interpolated at a given time step. (If both the fields
+ ! and the interpolation locations vary with time, there is no clear advantage in
+ ! using either this method or the method for 2D interpoaltion above; for simplicity
+ ! and because we foresee more uses for the method of this subroutine, we have not
+ ! implemented a 3D version of the fixed field, variable interpolation location method
+ ! as we have in 2D.) Coefficients are produced for handling both Dirichlet and Neumann
+ ! boundary conditions. The interpolation is performed with basis functions that are
+ ! RBFs plus constant and linear. All points are projected into the plane given by the
+ ! planeBasisVectors.
+ ! Input:
+ ! pointCount - the number of "source" points and functionValues supplied
+ ! sourcePoints - the location of the "source" points in the 3D space where the values of
+ ! the function are known. The sourcePoints will be projected into the plane given by
+ ! planeBasisVectors
+ ! isInterface - a logical array indicating which of the source points (if any) are at
+ ! at the domain interface. These points and their normals will be used to compute the
+ ! neumannCoefficients below
+ ! interfaceNormals - a 3D normal vector for each sourcePoint. These vectors are only used
+ ! at points where isInterface == .true., and can take arbitrary values elsewehere. The
+ ! normal vector is used to compute coefficients for the normal derivative of the
+ ! interpolating function in order to impose the Neumann Boundary condition
+ ! destinationPoint - the point in 3D where the interpolation will be performed. The
+ ! destinationPoint will be projected into the plane given by planeBasisVectors.
+ ! alpha - a constant that give the characteristic length scale of the RBFs,
+ ! should be on the order of the distance between points
+ ! planeBasisVectors - the basis fectors for the plane where interpolation is performed.
+ ! All points are projected into this plane.
+ ! Output:
+ ! dirichletCoefficients - the coefficients used to interpolate a function with Dirichlet
+ ! boundary conditions to the specified destinationPoint
+ ! neumannCoefficients - the coefficients used to interpolate a function with Neumann
+ ! boundary conditions to the specified destinationPoint
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine rbfInterp_func_3DPlane_sca_lin_dirNeu_compCoeffs( &
+ pointCount, sourcePoints, isInterface, interfaceNormals, destinationPoint, &
+ alpha, planeBasisVectors, dirichletCoefficients, neumannCoefficients)
+
+ integer, intent(in) :: pointCount
+ real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints
+ logical, dimension(pointCount), intent(in) :: isInterface
+ real(kind=RKIND), dimension(pointCount,3), intent(in) :: interfaceNormals
+ real(kind=RKIND), dimension(3), intent(in) :: destinationPoint
+ real(kind=RKIND), intent(in) :: alpha
+ real(kind=RKIND), dimension(2,3) :: planeBasisVectors
+ real(kind=RKIND), dimension(pointCount), intent(out) :: &
+ dirichletCoefficients, neumannCoefficients
+
+ integer :: i, j
+ integer :: matrixSize
+
+ real(kind=RKIND), dimension(:,:), pointer :: dirichletMatrix, neumannMatrix
+ real(kind=RKIND), dimension(:), pointer :: rhs, rhsCopy, coeffs
+ integer, dimension(:), pointer :: pivotIndices
+
+ matrixSize = pointCount+3 !! 3 extra space for constant and 2 planar dimensions
+
+ allocate(dirichletMatrix(matrixSize,matrixSize))
+ allocate(neumannMatrix(matrixSize,matrixSize))
+ allocate(rhs(matrixSize))
+ allocate(rhsCopy(matrixSize))
+ allocate(coeffs(matrixSize))
+ allocate(pivotIndices(matrixSize))
+
+ dirichletMatrix = 0.0
+ neumannMatrix = 0.0
+ rhs = 0.0
+ rhsCopy = 0.0
+ coeffs = 0.0
+
+ call setUpScalarRBFMatrixAndRHS(pointCount, &
+ sourcePoints, isInterface, interfaceNormals, destinationPoint, &
+ alpha, dirichletMatrix(1:pointCount,1:pointCount), &
+ neumannMatrix(1:pointCount,1:pointCount), rhs(1:pointCount))
+
+ do i = 1, pointCount
+ dirichletMatrix(i,pointCount+1) = 1.0
+ dirichletMatrix(i,pointCount+2) = sum(sourcePoints(i,1:3)*planeBasisVectors(1,:))
+ dirichletMatrix(i,pointCount+3) = sum(sourcePoints(i,1:3)*planeBasisVectors(2,:))
+ if(isInterface(i)) then
+ neumannMatrix(i,pointCount+1) = 0.0
+ neumannMatrix(i,pointCount+2) = sum(interfaceNormals(i,1:3)*planeBasisVectors(1,:))
+ neumannMatrix(i,pointCount+3) = sum(interfaceNormals(i,1:3)*planeBasisVectors(2,:))
+ else
+ neumannMatrix(i,pointCount+1:pointCount+3) &
+ = dirichletMatrix(i,pointCount+1:pointCount+3)
+ end if
+ dirichletMatrix(pointCount+1:pointCount+3,i) &
+ = dirichletMatrix(i,pointCount+1:pointCount+3)
+ neumannMatrix(pointCount+1:pointCount+3,i) &
+ = neumannMatrix(i,pointCount+1:pointCount+3)
+ end do
+
+ rhs(pointCount+1) = 1.0
+ rhs(pointCount+2) = sum(destinationPoint(1:3)*planeBasisVectors(1,:))
+ rhs(pointCount+3) = sum(destinationPoint(1:3)*planeBasisVectors(2,:))
+
+ ! solve each linear system
+ rhsCopy = rhs
+ call LEGS(dirichletMatrix, matrixSize, rhs, coeffs, pivotIndices)
+ dirichletCoefficients = coeffs(1:pointCount)
+
+ call LEGS(neumannMatrix, matrixSize, rhsCopy, coeffs, pivotIndices)
+ neumannCoefficients = coeffs(1:pointCount)
+
+ deallocate(dirichletMatrix)
+ deallocate(neumannMatrix)
+ deallocate(rhs)
+ deallocate(rhsCopy)
+ deallocate(coeffs)
+ deallocate(pivotIndices)
+
+ end subroutine rbfInterp_func_3DPlane_sca_lin_dirNeu_compCoeffs
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Purpose: Compute interpolation coefficients in 3D that can be used to
+ ! interpolate a number of scalar functions at a given locations. This is useful
+ ! if the interpolation location does not change with time, or if several
+ ! fields are to be interpolated at a given time step. (If both the fields
+ ! and the interpolation locations vary with time, there is no clear advantage in
+ ! using either this method or the method for 2D interpoaltion above; for simplicity
+ ! and because we foresee more uses for the method of this subroutine, we have not
+ ! implemented a 3D version of the fixed field, variable interpolation location method
+ ! as we have in 2D.) Coefficients are produced for handling both Dirichlet and Neumann
+ ! boundary conditions. The interpolation is performed with basis functions that are
+ ! RBFs plus constant and linear.
+ ! Input:
+ ! pointCount - the number of "source" points and functionValues supplied
+ ! sourcePoints - the location of the "source" points in the 3D space where the values of
+ ! the function are known
+ ! isInterface - a logical array indicating which of the source points (if any) are at
+ ! at the domain interface. These points and their normals will be used to compute the
+ ! neumannCoefficients below
+ ! interfaceNormals - a 3D normal vector for each sourcePoint. These vectors are only used
+ ! at points where isInterface == .true., and can take arbitrary values elsewehere. The
+ ! normal vector is used to compute coefficients for the normal derivative of the
+ ! interpolating function in order to impose the Neumann Boundary condition
+ ! destinationPoint - the point where the interpolation will be performed
+ ! alpha - a constant that give the characteristic length scale of the RBFs,
+ ! should be on the order of the distance between points
+ ! Output:
+ ! dirichletCoefficients - the coefficients used to interpolate a function with Dirichlet
+ ! boundary conditions to the specified destinationPoint
+ ! neumannCoefficients - the coefficients used to interpolate a function with Neumann
+ ! boundary conditions to the specified destinationPoint
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine rbfInterp_func_3D_sca_lin_dirNeu_compCoeffs(pointCount, &
+ sourcePoints, isInterface, interfaceNormals, destinationPoint, &
+ alpha, dirichletCoefficients, neumannCoefficients)
+
+ integer, intent(in) :: pointCount
+ real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints
+ logical, dimension(pointCount), intent(in) :: isInterface
+ real(kind=RKIND), dimension(pointCount,3), intent(in) :: interfaceNormals
+ real(kind=RKIND), dimension(3), intent(in) :: destinationPoint
+ real(kind=RKIND), intent(in) :: alpha
+ real(kind=RKIND), dimension(pointCount), intent(out) :: &
+ dirichletCoefficients, neumannCoefficients
+
+ integer :: i, j
+ integer :: matrixSize
+
+ real(kind=RKIND), dimension(:,:), pointer :: dirichletMatrix, neumannMatrix
+ real(kind=RKIND), dimension(:), pointer :: rhs, rhsCopy, coeffs
+ integer, dimension(:), pointer :: pivotIndices
+
+ matrixSize = pointCount+4 !! 4 extra space for constant and linear in 3D
+
+ allocate(dirichletMatrix(matrixSize,matrixSize))
+ allocate(neumannMatrix(matrixSize,matrixSize))
+ allocate(rhs(matrixSize))
+ allocate(rhsCopy(matrixSize))
+ allocate(coeffs(matrixSize))
+ allocate(pivotIndices(matrixSize))
+
+ dirichletMatrix = 0.0
+ neumannMatrix = 0.0
+ rhs = 0.0
+ rhsCopy = 0.0
+ coeffs = 0.0
+
+ call setUpScalarRBFMatrixAndRHS(pointCount, &
+ sourcePoints, isInterface, interfaceNormals, destinationPoint, &
+ alpha, dirichletMatrix(1:pointCount,1:pointCount), &
+ neumannMatrix(1:pointCount,1:pointCount), rhs(1:pointCount))
+
+ do i = 1, pointCount
+ dirichletMatrix(i,pointCount+1) = 1.0
+ dirichletMatrix(i,pointCount+2:pointCount+4) = sourcePoints(i,1:3)
+ if(isInterface(i)) then
+ neumannMatrix(i,pointCount+1) = 0.0
+ neumannMatrix(i,pointCount+2:pointCount+4) = interfaceNormals(i,1:3)
+ else
+ neumannMatrix(i,pointCount+1:pointCount+4) &
+ = dirichletMatrix(i,pointCount+1:pointCount+4)
+ end if
+ dirichletMatrix(pointCount+1:pointCount+4,i) &
+ = dirichletMatrix(i,pointCount+1:pointCount+4)
+ neumannMatrix(pointCount+1:pointCount+4,i) &
+ = neumannMatrix(i,pointCount+1:pointCount+4)
+ end do
+
+ rhs(pointCount+1) = 1.0
+ rhs(pointCount+2:pointCount+4) = destinationPoint(1:3)
+
+ ! solve each linear system
+ rhsCopy = rhs
+ call LEGS(dirichletMatrix, matrixSize, rhs, coeffs, pivotIndices)
+ dirichletCoefficients = coeffs(1:pointCount)
+
+ call LEGS(neumannMatrix, matrixSize, rhsCopy, coeffs, pivotIndices)
+ neumannCoefficients = coeffs(1:pointCount)
+
+ deallocate(dirichletMatrix)
+ deallocate(neumannMatrix)
+ deallocate(rhs)
+ deallocate(rhsCopy)
+ deallocate(coeffs)
+ deallocate(pivotIndices)
+
+ end subroutine rbfInterp_func_3D_sca_lin_dirNeu_compCoeffs
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Purpose: Compute interpolation coefficients in 3D that can be used to
+ ! interpolate a number of vector functions at a given locations. This is useful
+ ! if the interpolation location does not change with time, or if several
+ ! fields are to be interpolated at a given time step. (If both the vector fields
+ ! and the interpolation locations vary with time, there is no clear advantage in
+ ! using either this method or the method for 2D interpoaltion above; for simplicity
+ ! and because we foresee more uses for the method of this subroutine, we have not
+ ! implemented a 3D version of the fixed field, variable interpolation location method
+ ! as we have in 2D.) Coefficients are produced for handling Dirichlet boundary
+ ! conditions (or no boundaries). The interpolation is performed with basis functions
+ ! that are RBFs plus a constant.
+ ! Input:
+ ! pointCount - the number of "source" points and functionValues supplied
+ ! sourcePoints - the location of the "source" points in the 3D space where the values of
+ ! the function are known
+ ! unitVectors - the unit vectors associated with each of the sourcePoints. Interpolation
+ ! is performed by supplying the value of the vector function dotted into each of these unit
+ ! vectors. If multiple unit vectors are supplied at the same sourcePoint, they *must* be
+ ! orthogonal for the interpolation to succeed.
+ ! destinationPoint - the point where the interpolation will be performed
+ ! alpha - a constant that give the characteristic length scale of the RBFs,
+ ! should be on the order of the distance between points
+ ! Output:
+ ! coefficients - the coefficients used to interpolate a function with Dirichlet
+ ! boundary conditions to the specified destinationPoint
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine rbfInterp_func_3D_vec_const_dir_compCoeffs(pointCount, &
+ sourcePoints, unitVectors, destinationPoint, &
+ alpha, coefficients)
+
+ integer, intent(in) :: pointCount
+ real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints
+ real(kind=RKIND), dimension(pointCount,3), intent(in) :: unitVectors
+ real(kind=RKIND), dimension(3), intent(in) :: destinationPoint
+ real(kind=RKIND), intent(in) :: alpha
+ real(kind=RKIND), dimension(pointCount, 3), intent(out) :: coefficients
+
+ integer :: i, j
+ integer :: matrixSize
+
+ real(kind=RKIND), dimension(:,:), pointer :: matrix, matrixCopy
+ real(kind=RKIND), dimension(:,:), pointer :: rhs, coeffs
+ integer, dimension(:), pointer :: pivotIndices
+
+ matrixSize = pointCount+3 ! extra space for constant vector
+
+ allocate(matrix(matrixSize,matrixSize))
+ allocate(matrixCopy(matrixSize,matrixSize))
+ allocate(rhs(matrixSize,3))
+ allocate(coeffs(matrixSize,3))
+ allocate(pivotIndices(matrixSize))
+
+ matrix = 0.0
+ rhs = 0.0
+ coeffs = 0.0
+
+ call setUpVectorDirichletRBFMatrixAndRHS(pointCount, 3, &
+ sourcePoints, unitVectors, destinationPoint, &
+ alpha, matrix(1:pointCount,1:pointCount), rhs(1:pointCount,:))
+
+ do i = 1, pointCount
+ matrix(i,pointCount+1:pointCount+3) = unitVectors(i,:)
+ matrix(pointCount+1:pointCount+3,i) &
+ = matrix(i,pointCount+1:pointCount+3)
+ end do
+ do i = 1, 3
+ rhs(pointCount+i,i) = 1.0 ! the unit vector in the ith direction
+ end do
+
+ ! solve each linear system
+ do i = 1, 3
+ matrixCopy = matrix
+ call LEGS(matrixCopy, matrixSize, rhs(:,i), coeffs(:,i), pivotIndices)
+ end do
+ coefficients = coeffs(1:pointCount,:)
+
+ deallocate(matrix)
+ deallocate(matrixCopy)
+ deallocate(rhs)
+ deallocate(coeffs)
+ deallocate(pivotIndices)
+
+ end subroutine rbfInterp_func_3D_vec_const_dir_compCoeffs
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Purpose: Compute interpolation coefficients in 3D that can be used to
+ ! interpolate a number of vector functions at a given locations. This is useful
+ ! if the interpolation location does not change with time, or if several
+ ! fields are to be interpolated at a given time step. (If both the vector fields
+ ! and the interpolation locations vary with time, there is no clear advantage in
+ ! using either this method or the method for 2D interpoaltion above; for simplicity
+ ! and because we foresee more uses for the method of this subroutine, we have not
+ ! implemented a 3D version of the fixed field, variable interpolation location method
+ ! as we have in 2D.) Coefficients are produced for handling Dirichlet boundary
+ ! conditions (or no boundaries). The interpolation is performed with basis functions
+ ! that are RBFs plus a constant.
+ ! Input:
+ ! pointCount - the number of "source" points and functionValues supplied
+ ! sourcePoints - the location of the "source" points in the 3D space where the values of
+ ! the function are known. The sourcePoints are projected into the plane given by
+ ! planeBasisVectors
+ ! unitVectors - the unit vectors associated with each of the sourcePoints. Interpolation
+ ! is performed by supplying the value of the vector function dotted into each of these unit
+ ! vectors. If multiple unit vectors are supplied at the same sourcePoint, they *must* be
+ ! orthogonal for the interpolation to succeed. The unitVectors are projected into the
+ ! plane given by planeBasisVectors
+ ! destinationPoint - the point where the interpolation will be performed. The destinationPoint
+ ! is projected into the plane given by planeBasisVectors
+ ! alpha - a constant that give the characteristic length scale of the RBFs,
+ ! should be on the order of the distance between points
+ ! planeBasisVectors - the basis fectors for the plane where interpolation is performed.
+ ! All points are projected into this plane.
+ ! Output:
+ ! coefficients - the coefficients used to interpolate a function with Dirichlet
+ ! boundary conditions to the specified destinationPoint
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine rbfInterp_func_3DPlane_vec_const_dir_compCoeffs(pointCount, &
+ sourcePoints, unitVectors, destinationPoint, &
+ alpha, planeBasisVectors, coefficients)
+
+ integer, intent(in) :: pointCount
+ real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints
+ real(kind=RKIND), dimension(pointCount,3), intent(in) :: unitVectors
+ real(kind=RKIND), dimension(3), intent(in) :: destinationPoint
+ real(kind=RKIND), intent(in) :: alpha
+ real(kind=RKIND), dimension(2,3) :: planeBasisVectors
+ real(kind=RKIND), dimension(pointCount, 3), intent(out) :: coefficients
+
+ integer :: i, j
+ integer :: matrixSize
+
+ real(kind=RKIND) :: rSquared, rbfValue, unitVectorDotProduct
+
+ real(kind=RKIND), dimension(pointCount,2) :: planarSourcePoints
+ real(kind=RKIND), dimension(pointCount,2) :: planarUnitVectors
+ real(kind=RKIND), dimension(2) :: planarDestinationPoint
+
+ real(kind=RKIND), dimension(:,:), pointer :: matrix, matrixCopy
+ real(kind=RKIND), dimension(:,:), pointer :: rhs, coeffs
+ integer, dimension(:), pointer :: pivotIndices
+
+ matrixSize = pointCount+2 ! space for constant vector in plane
+
+ allocate(matrix(matrixSize,matrixSize))
+ allocate(matrixCopy(matrixSize,matrixSize))
+ allocate(rhs(matrixSize,2))
+ allocate(coeffs(matrixSize,2))
+ allocate(pivotIndices(matrixSize))
+
+ matrix = 0.0
+ rhs = 0.0
+ coeffs = 0.0
+
+ do i = 1, pointCount
+ planarSourcePoints(i,1) = sum(sourcePoints(i,:)*planeBasisVectors(1,:))
+ planarSourcePoints(i,2) = sum(sourcePoints(i,:)*planeBasisVectors(2,:))
+ planarUnitVectors(i,1) = sum(unitVectors(i,:)*planeBasisVectors(1,:))
+ planarUnitVectors(i,2) = sum(unitVectors(i,:)*planeBasisVectors(2,:))
+ end do
+ planarDestinationPoint(1) = sum(destinationPoint*planeBasisVectors(1,:))
+ planarDestinationPoint(2) = sum(destinationPoint*planeBasisVectors(2,:))
+
+ call setUpVectorDirichletRBFMatrixAndRHS(pointCount, 2, &
+ planarSourcePoints, planarUnitVectors, planarDestinationPoint, &
+ alpha, matrix(1:pointCount,1:pointCount), rhs(1:pointCount,:))
+
+ do i = 1, pointCount
+ matrix(i,pointCount+1:pointCount+2) = planarUnitVectors(i,:)
+ matrix(pointCount+1:pointCount+2,i) = matrix(i,pointCount+1:pointCount+2)
+ end do
+ do i = 1,2
+ rhs(pointCount+i,i) = 1.0 ! the unit vector in the ith direction
+ end do
+
+ ! solve each linear system
+ matrixCopy = matrix
+ call LEGS(matrix, matrixSize, rhs(:,1), coeffs(:,1), pivotIndices)
+ call LEGS(matrixCopy, matrixSize, rhs(:,2), coeffs(:,2), pivotIndices)
+
+
+ do i = 1,3
+ coefficients(:,i) = planeBasisVectors(1,i)*coeffs(1:pointCount,1) &
+ + planeBasisVectors(2,i)*coeffs(1:pointCount,2)
+ end do
+
+ deallocate(matrix)
+ deallocate(matrixCopy)
+ deallocate(rhs)
+ deallocate(coeffs)
+ deallocate(pivotIndices)
+
+ end subroutine rbfInterp_func_3DPlane_vec_const_dir_compCoeffs
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Purpose: Compute interpolation coefficients in 3D that can be used to
+ ! interpolate a number of vector functions at a given locations. This is useful
+ ! if the interpolation location does not change with time, or if several
+ ! fields are to be interpolated at a given time step. (If both the vector fields
+ ! and the interpolation locations vary with time, there is no clear advantage in
+ ! using either this method or the method for 2D interpoaltion above; for simplicity
+ ! and because we foresee more uses for the method of this subroutine, we have not
+ ! implemented a 3D version of the fixed field, variable interpolation location method
+ ! as we have in 2D.) Coefficients are produced for handling Dirichlet normal /
+ ! Neumann tangential boundary conditions (such as free slip). The interpolation is
+ ! performed with basis functions that are RBFs plus a constant.
+ ! Input:
+ ! pointCount - the number of "source" points and functionValues supplied
+ ! sourcePoints - the location of the "source" points in the 3D space where the values of
+ ! the function are known
+ ! isTangentToInterface - a logical array indicating which sourcePoints/unitVectors are
+ ! tangent to the interface where the boundary condition will be applied. A Neumann
+ ! boundary condition will be applied at these points in these directions.
+ ! normalVectorIndex - where isTangentToInterface == .true., the index into unitVectors that
+ ! gives the normal vector at the same sourcePoint. This information is needed to compute
+ ! the Neumann boundary condition at this point.
+ ! unitVectors - the unit vectors associated with each of the sourcePoints. Interpolation
+ ! is performed by supplying the value of the vector function dotted into each of these unit
+ ! vectors. If multiple unit vectors are supplied at the same sourcePoint, they *must* be
+ ! orthogonal for the interpolation to succeed. A normal vector and two tangential vectors
+ ! are needed at each interface point in order to satisfy the Dirichlet normal boundary
+ ! condition and the Neumann tangential boundary conditions at these points.
+ ! destinationPoint - the point where the interpolation will be performed
+ ! alpha - a constant that give the characteristic length scale of the RBFs,
+ ! should be on the order of the distance between points
+ ! Output:
+ ! coefficients - the coefficients used to interpolate a function with Dirichlet
+ ! boundary conditions to the specified destinationPoint
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine rbfInterp_func_3D_vec_const_tanNeu_compCoeffs(pointCount, &
+ sourcePoints, isTangentToInterface, normalVectorIndex, unitVectors, destinationPoint, &
+ alpha, coefficients)
+
+ integer, intent(in) :: pointCount
+ real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints
+ logical, dimension(pointCount), intent(in) :: isTangentToInterface
+ integer, dimension(pointCount), intent(in) :: normalVectorIndex
+ real(kind=RKIND), dimension(pointCount,3), intent(in) :: unitVectors
+ real(kind=RKIND), dimension(3), intent(in) :: destinationPoint
+ real(kind=RKIND), intent(in) :: alpha
+ real(kind=RKIND), dimension(pointCount, 3), intent(out) :: coefficients
+
+ integer :: i, j
+ integer :: matrixSize
+
+ real(kind=RKIND), dimension(:,:), pointer :: matrix, matrixCopy
+ real(kind=RKIND), dimension(:,:), pointer :: rhs, coeffs
+ integer, dimension(:), pointer :: pivotIndices
+
+ matrixSize = pointCount+3 ! extra space for constant vector
+
+ allocate(matrix(matrixSize,matrixSize))
+ allocate(matrixCopy(matrixSize,matrixSize))
+ allocate(rhs(matrixSize,3))
+ allocate(coeffs(matrixSize,3))
+ allocate(pivotIndices(matrixSize))
+
+ matrix = 0.0
+ rhs = 0.0
+ coeffs = 0.0
+
+ call setUpVectorFreeSlipRBFMatrixAndRHS(pointCount, 3, &
+ sourcePoints, isTangentToInterface, normalVectorIndex, unitVectors, destinationPoint, &
+ alpha, matrix(1:pointCount,1:pointCount), rhs(1:pointCount,:))
+
+ do i = 1, pointCount
+ matrix(pointCount+1:pointCount+3,i) = unitVectors(i,:)
+ if(.not. isTangentToInterface(i)) then
+ matrix(i,pointCount+1:pointCount+3) = matrix(pointCount+1:pointCount+3,i)
+ end if
+ end do
+ do i = 1, 3
+ rhs(pointCount+i,i) = 1.0 ! the unit vector in the ith direction
+ end do
+
+ ! solve each linear system
+ do i = 1, 3
+ matrixCopy = matrix
+ call LEGS(matrixCopy, matrixSize, rhs(:,i), coeffs(:,i), pivotIndices)
+ end do
+ coefficients = coeffs(1:pointCount,:)
+
+ deallocate(matrix)
+ deallocate(matrixCopy)
+ deallocate(rhs)
+ deallocate(coeffs)
+ deallocate(pivotIndices)
+
+ end subroutine rbfInterp_func_3D_vec_const_tanNeu_compCoeffs
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Purpose: Compute interpolation coefficients in 3D that can be used to
+ ! interpolate a number of vector functions at a given locations. This is useful
+ ! if the interpolation location does not change with time, or if several
+ ! fields are to be interpolated at a given time step. (If both the vector fields
+ ! and the interpolation locations vary with time, there is no clear advantage in
+ ! using either this method or the method for 2D interpoaltion above; for simplicity
+ ! and because we foresee more uses for the method of this subroutine, we have not
+ ! implemented a 3D version of the fixed field, variable interpolation location method
+ ! as we have in 2D.) Coefficients are produced for handling Dirichlet normal /
+ ! Neumann tangential boundary conditions (such as free slip). The interpolation is
+ ! performed with basis functions that are RBFs plus a constant.
+ ! Input:
+ ! pointCount - the number of "source" points and functionValues supplied
+ ! sourcePoints - the location of the "source" points in the 3D space where the values of
+ ! the function are known. The sourcePoints are projected into the plane given by
+ ! planeBasisVectors
+ ! isTangentToInterface - a logical array indicating which sourcePoints/unitVectors are
+ ! tangent to the interface where the boundary condition will be applied. A Neumann
+ ! boundary condition will be applied at these points in these directions.
+ ! normalVectorIndex - where isTangentToInterface == .true., the index into unitVectors that
+ ! gives the normal vector at the same sourcePoint. This information is needed to compute
+ ! the Neumann boundary condition at this point.
+ ! unitVectors - the unit vectors associated with each of the sourcePoints. Interpolation
+ ! is performed by supplying the value of the vector function dotted into each of these unit
+ ! vectors. If multiple unit vectors are supplied at the same sourcePoint, they *must* be
+ ! orthogonal for the interpolation to succeed. A normal vector and two tangential vectors
+ ! are needed at each interface point in order to satisfy the Dirichlet normal boundary
+ ! condition and the Neumann tangential boundary conditions at these points. The unitVectors
+ ! are projected into the plane given by planeBasisVectors
+ ! destinationPoint - the point where the interpolation will be performed. The destinationPoint
+ ! is projected into the plane given by planeBasisVectors
+ ! alpha - a constant that give the characteristic length scale of the RBFs,
+ ! should be on the order of the distance between points
+ ! planeBasisVectors - the basis fectors for the plane where interpolation is performed.
+ ! All points are projected into this plane.
+ ! Output:
+ ! coefficients - the coefficients used to interpolate a function with Dirichlet
+ ! boundary conditions to the specified destinationPoint
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine rbfInterp_func_3DPlane_vec_const_tanNeu_compCoeffs(&
+ pointCount, sourcePoints, isTangentToInterface, normalVectorIndex, unitVectors, &
+ destinationPoint, alpha, planeBasisVectors, coefficients)
+
+ integer, intent(in) :: pointCount
+ real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints
+ logical, dimension(pointCount), intent(in) :: isTangentToInterface
+ integer, dimension(pointCount), intent(in) :: normalVectorIndex
+ real(kind=RKIND), dimension(pointCount,3), intent(in) :: unitVectors
+ real(kind=RKIND), dimension(3), intent(in) :: destinationPoint
+ real(kind=RKIND), intent(in) :: alpha
+ real(kind=RKIND), dimension(2,3), intent(in) :: planeBasisVectors
+ real(kind=RKIND), dimension(pointCount, 3), intent(out) :: coefficients
+
+ integer :: i, j
+ integer :: matrixSize
+
+ real(kind=RKIND), dimension(pointCount,2) :: planarSourcePoints
+ real(kind=RKIND), dimension(pointCount,2) :: planarUnitVectors
+ real(kind=RKIND), dimension(2) :: planarDestinationPoint
+
+ real(kind=RKIND), dimension(:,:), pointer :: matrix, matrixCopy
+ real(kind=RKIND), dimension(:,:), pointer :: rhs, coeffs
+ integer, dimension(:), pointer :: pivotIndices
+
+ matrixSize = pointCount+2 ! space for constant vector in plane
+
+ allocate(matrix(matrixSize,matrixSize))
+ allocate(matrixCopy(matrixSize,matrixSize))
+ allocate(rhs(matrixSize,2))
+ allocate(coeffs(matrixSize,2))
+ allocate(pivotIndices(matrixSize))
+
+ matrix = 0.0
+ rhs = 0.0
+ coeffs = 0.0
+
+ do i = 1, pointCount
+ planarSourcePoints(i,1) = sum(sourcePoints(i,:)*planeBasisVectors(1,:))
+ planarSourcePoints(i,2) = sum(sourcePoints(i,:)*planeBasisVectors(2,:))
+ planarUnitVectors(i,1) = sum(unitVectors(i,:)*planeBasisVectors(1,:))
+ planarUnitVectors(i,2) = sum(unitVectors(i,:)*planeBasisVectors(2,:))
+ end do
+ planarDestinationPoint(1) = sum(destinationPoint*planeBasisVectors(1,:))
+ planarDestinationPoint(2) = sum(destinationPoint*planeBasisVectors(2,:))
+ call setUpVectorFreeSlipRBFMatrixAndRHS(pointCount, 2, &
+ planarSourcePoints, isTangentToInterface, normalVectorIndex, planarUnitVectors, &
+ planarDestinationPoint, alpha, matrix(1:pointCount,1:pointCount), rhs(1:pointCount,:))
+
+ do i = 1, pointCount
+ matrix(pointCount+1,i) = sum(unitVectors(i,:)*planeBasisVectors(1,:))
+ matrix(pointCount+2,i) = sum(unitVectors(i,:)*planeBasisVectors(2,:))
+ if(.not. isTangentToInterface(i)) then
+ matrix(i,pointCount+1:pointCount+2) = matrix(pointCount+1:pointCount+2,i)
+ end if
+ end do
+ do i = 1,2
+ rhs(pointCount+i,i) = 1.0 ! the unit vector in the ith direction
+ end do
+
+ ! solve each linear system
+ matrixCopy = matrix
+ call LEGS(matrix, matrixSize, rhs(:,1), coeffs(:,1), pivotIndices)
+ call LEGS(matrixCopy, matrixSize, rhs(:,2), coeffs(:,2), pivotIndices)
+
+ coefficients(:,1) = planeBasisVectors(1,1)*coeffs(1:pointCount,1) &
+ + planeBasisVectors(2,1)*coeffs(1:pointCount,2)
+ coefficients(:,2) = planeBasisVectors(1,2)*coeffs(1:pointCount,1) &
+ + planeBasisVectors(2,2)*coeffs(1:pointCount,2)
+ coefficients(:,3) = planeBasisVectors(1,3)*coeffs(1:pointCount,1) &
+ + planeBasisVectors(2,3)*coeffs(1:pointCount,2)
+
+ deallocate(matrix)
+ deallocate(matrixCopy)
+ deallocate(rhs)
+ deallocate(coeffs)
+ deallocate(pivotIndices)
+
+ end subroutine rbfInterp_func_3DPlane_vec_const_tanNeu_compCoeffs
+
+
+!!!!!!!!!!!!!!!!!!!!!
+! private subroutines
+!!!!!!!!!!!!!!!!!!!!!
+
+ function evaluateRBF(rSquared) result(rbfValue)
+ real(kind=RKIND), intent(in) :: rSquared
+ real(kind=RKIND) :: rbfValue
+
+ ! inverse multiquadratic
+ rbfValue = 1/sqrt(1 + rSquared)
+
+ end function evaluateRBF
+
+ subroutine evaluateRBFAndDeriv(rSquared, rbfValue, rbfDerivOverR)
+ real(kind=RKIND), intent(in) :: rSquared
+ real(kind=RKIND), intent(out) :: rbfValue, rbfDerivOverR
+
+ ! inverse multiquadratic
+ rbfValue = 1/sqrt(1 + rSquared)
+ rbfDerivOverR = -rbfValue**3
+
+ end subroutine evaluateRBFAndDeriv
+
+ subroutine evaluateRBFAndDerivs(rSquared, rbfValue, rbfDerivOverR, rbfSecondDeriv)
+ real(kind=RKIND), intent(in) :: rSquared
+ real(kind=RKIND), intent(out) :: rbfValue, rbfDerivOverR, rbfSecondDeriv
+
+ ! inverse multiquadratic
+ rbfValue = 1/sqrt(1 + rSquared)
+ rbfDerivOverR = -rbfValue**3
+ rbfSecondDeriv = (2*rSquared-1)*rbfValue**5
+
+ end subroutine evaluateRBFAndDerivs
+
+ subroutine setUpScalarRBFDirichletMatrixAndRHS(pointCount, sourcePoints, destinationPoint, &
+ alpha, dirichletMatrix, rhs)
+
+ integer, intent(in) :: pointCount
+ real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints
+ real(kind=RKIND), dimension(3), intent(in) :: destinationPoint
+ real(kind=RKIND), intent(in) :: alpha
+ real(kind=RKIND), dimension(pointCount,pointCount), intent(out) :: dirichletMatrix
+ real(kind=RKIND), dimension(pointCount), intent(out) :: rhs
+
+ integer :: i, j
+
+ real(kind=RKIND) :: rSquared, rbfValue
+
+ do j = 1, pointCount
+ do i = 1, pointCount
+ rSquared = sum((sourcePoints(i,:)-sourcePoints(j,:))**2)/alpha**2
+ rbfValue = evaluateRBF(rSquared)
+ dirichletMatrix(i,j) = rbfValue
+ end do
+ end do
+
+ do j = 1, pointCount
+ rSquared = sum((destinationPoint-sourcePoints(j,:))**2)/alpha**2
+ rhs(j) = evaluateRBF(rSquared)
+ end do
+
+ end subroutine setUpScalarRBFDirichletMatrixAndRHS
+
+ subroutine setUpScalarRBFMatrixAndRHS(pointCount, &
+ sourcePoints, isInterface, interfaceNormals, destinationPoint, &
+ alpha, dirichletMatrix, neumannMatrix, rhs)
+
+ integer, intent(in) :: pointCount
+ real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints
+ logical, dimension(pointCount), intent(in) :: isInterface
+ real(kind=RKIND), dimension(pointCount,3), intent(in) :: interfaceNormals
+ real(kind=RKIND), dimension(3), intent(in) :: destinationPoint
+ real(kind=RKIND), intent(in) :: alpha
+ real(kind=RKIND), dimension(pointCount,pointCount), intent(out) :: &
+ dirichletMatrix, neumannMatrix
+ real(kind=RKIND), dimension(pointCount), intent(out) :: rhs
+
+ integer :: i, j
+
+ real(kind=RKIND) :: rSquared, rbfValue, rbfDerivOverR, normalDotX
+
+ do j = 1, pointCount
+ if(isInterface(j)) then
+ do i = 1, pointCount
+ rSquared = sum((sourcePoints(i,:)-sourcePoints(j,:))**2)/alpha**2
+ normalDotX = sum(interfaceNormals(j,:) &
+ * (sourcePoints(j,:)-sourcePoints(i,:)))
+ call evaluateRBFAndDeriv(rSquared, rbfValue, rbfDerivOverR)
+ rbfDerivOverR = rbfDerivOverR/alpha**2
+ dirichletMatrix(i,j) = rbfValue
+ neumannMatrix(i,j) = rbfDerivOverR*normalDotX
+ end do
+ else
+ do i = 1, pointCount
+ rSquared = sum((sourcePoints(i,:)-sourcePoints(j,:))**2)/alpha**2
+ rbfValue = evaluateRBF(rSquared)
+ dirichletMatrix(i,j) = rbfValue
+ neumannMatrix(i,j) = rbfValue
+ end do
+ end if
+ end do
+
+ do j = 1, pointCount
+ rSquared = sum((destinationPoint-sourcePoints(j,:))**2)/alpha**2
+ rhs(j) = evaluateRBF(rSquared)
+ end do
+
+ end subroutine setUpScalarRBFMatrixAndRHS
+
+ subroutine setUpVectorDirichletRBFMatrixAndRHS(pointCount, dimensions, &
+ sourcePoints, unitVectors, destinationPoint, &
+ alpha, matrix, rhs)
+
+ integer, intent(in) :: pointCount, dimensions
+ real(kind=RKIND), dimension(pointCount,dimensions), intent(in) :: sourcePoints
+ real(kind=RKIND), dimension(pointCount,dimensions), intent(in) :: unitVectors
+ real(kind=RKIND), dimension(dimensions), intent(in) :: destinationPoint
+ real(kind=RKIND), intent(in) :: alpha
+ real(kind=RKIND), dimension(pointCount,pointCount), intent(out) :: matrix
+ real(kind=RKIND), dimension(pointCount,dimensions), intent(out) :: rhs
+
+ integer :: i, j
+
+ real(kind=RKIND) :: rSquared, rbfValue, unitVectorDotProduct
+
+ do j = 1, pointCount
+ do i = j, pointCount
+ rSquared = sum((sourcePoints(i,:)-sourcePoints(j,:))**2)/alpha**2
+ rbfValue = evaluateRBF(rSquared)
+ unitVectorDotProduct = sum(unitVectors(i,:)*unitVectors(j,:))
+ matrix(i,j) = rbfValue*unitVectorDotProduct
+ matrix(j,i) = matrix(i,j)
+ end do
+ end do
+
+ do j = 1, pointCount
+ rSquared = sum((destinationPoint-sourcePoints(j,:))**2)/alpha**2
+ rhs(j,:) = evaluateRBF(rSquared)*unitVectors(j,:)
+ end do
+
+ end subroutine setUpVectorDirichletRBFMatrixAndRHS
+
+ subroutine setUpVectorFreeSlipRBFMatrixAndRHS(pointCount, dimensions, &
+ sourcePoints, isTangentToInterface, normalVectorIndex, unitVectors, destinationPoint, &
+ alpha, matrix, rhs)
+
+ integer, intent(in) :: pointCount, dimensions
+ real(kind=RKIND), dimension(pointCount,dimensions), intent(in) :: sourcePoints
+ logical, dimension(pointCount), intent(in) :: isTangentToInterface
+ integer, dimension(pointCount), intent(in) :: normalVectorIndex
+ real(kind=RKIND), dimension(pointCount,dimensions), intent(in) :: unitVectors
+ real(kind=RKIND), dimension(dimensions), intent(in) :: destinationPoint
+ real(kind=RKIND), intent(in) :: alpha
+ real(kind=RKIND), dimension(pointCount,pointCount), intent(out) :: matrix
+ real(kind=RKIND), dimension(pointCount,dimensions), intent(out) :: rhs
+
+ integer :: i, j
+
+ real(kind=RKIND) :: rSquared, rbfValue, rbfDerivOverR, normalVector(dimensions), &
+ normalDotX, unitVectorDotProduct
+
+ do j = 1, pointCount
+ if(isTangentToInterface(j)) then
+ do i = 1, pointCount
+ rSquared = sum((sourcePoints(i,:)-sourcePoints(j,:))**2)/alpha**2
+ normalVector = unitVectors(normalVectorIndex(j),:)
+ normalDotX = sum(normalVector * (sourcePoints(j,:)-sourcePoints(i,:)))
+ call evaluateRBFAndDeriv(rSquared, rbfValue, rbfDerivOverR)
+ rbfDerivOverR = rbfDerivOverR/alpha**2
+ unitVectorDotProduct = sum(unitVectors(i,:)*unitVectors(j,:))
+ matrix(i,j) = rbfDerivOverR*normalDotX*unitVectorDotProduct
+ end do
+ else
+ do i = 1, pointCount
+ rSquared = sum((sourcePoints(i,:)-sourcePoints(j,:))**2)/alpha**2
+ rbfValue = evaluateRBF(rSquared)
+ unitVectorDotProduct = sum(unitVectors(i,:)*unitVectors(j,:))
+ matrix(i,j) = rbfValue*unitVectorDotProduct
+ end do
+ end if
+ end do
+
+ do j = 1, pointCount
+ rSquared = sum((destinationPoint-sourcePoints(j,:))**2)/alpha**2
+ rhs(j,:) = evaluateRBF(rSquared)*unitVectors(j,:)
+ end do
+
+ end subroutine setUpVectorFreeSlipRBFMatrixAndRHS
+
+ subroutine unit_vec_in_R3(xin)
+ implicit none
+ real (kind=RKIND), intent(inout) :: xin(3)
+ real (kind=RKIND) :: mag
+ mag = sqrt(xin(1)**2+xin(2)**2+xin(3)**2)
+ xin(:) = xin(:) / mag
+ end subroutine unit_vec_in_R3
+
+ subroutine cross_product_in_R3(p_1,p_2,p_out)
+ real (kind=RKIND), intent(in) :: p_1 (3), p_2 (3)
+ real (kind=RKIND), intent(out) :: p_out (3)
+
+ p_out(1) = p_1(2)*p_2(3)-p_1(3)*p_2(2)
+ p_out(2) = p_1(3)*p_2(1)-p_1(1)*p_2(3)
+ p_out(3) = p_1(1)*p_2(2)-p_1(2)*p_2(1)
+ end subroutine cross_product_in_R3
+
+! Updated 10/24/2001.
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 4.3 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! !
+! 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. !
+! !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!PROGRAM EX43
+!
+!
+! An example of solving linear equation set A(N,N)*X(N) = B(N)
+! with the partial-pivoting Gaussian elimination scheme. The
+! numerical values are for the Wheatstone bridge example discussed
+! in Section 4.1 in the book with all resistances being 100 ohms
+! and the voltage 200 volts.
+!
+! IMPLICIT NONE
+! INTEGER, PARAMETER :: N=3
+! INTEGER :: I,J
+! INTEGER, DIMENSION (N) :: INDX
+! REAL, DIMENSION (N) :: X,B
+! REAL, DIMENSION (N,N) :: A
+! DATA B /200.0,0.0,0.0/, &
+! ((A(I,J), J=1,N),I=1,N) /100.0,100.0,100.0,-100.0, &
+! 300.0,-100.0,-100.0,-100.0, 300.0/
+!
+! CALL LEGS (A,N,B,X,INDX)
+!
+! WRITE (6, "(F16.8)") (X(I), I=1,N)
+!END PROGRAM EX43
+
+
+SUBROUTINE LEGS (A,N,B,X,INDX)
+!
+! Subroutine to solve the equation A(N,N)*X(N) = B(N) with the
+! partial-pivoting Gaussian elimination scheme.
+! Copyright (c) Tao Pang 2001.
+!
+ IMPLICIT NONE
+ integer, INTENT (IN) :: N
+ integer :: I,J
+ integer, INTENT (OUT), DIMENSION (N) :: INDX
+ real(kind=RKIND), INTENT (INOUT), DIMENSION (N,N) :: A
+ real(kind=RKIND), INTENT (INOUT), DIMENSION (N) :: B
+ real(kind=RKIND), INTENT (OUT), DIMENSION (N) :: X
+!
+ CALL ELGS (A,N,INDX)
+!
+ DO I = 1, N-1
+ DO J = I+1, N
+ B(INDX(J)) = B(INDX(J))-A(INDX(J),I)*B(INDX(I))
+ END DO
+ END DO
+!
+ X(N) = B(INDX(N))/A(INDX(N),N)
+ DO I = N-1, 1, -1
+ X(I) = B(INDX(I))
+ DO J = I+1, N
+ X(I) = X(I)-A(INDX(I),J)*X(J)
+ END DO
+ X(I) = X(I)/A(INDX(I),I)
+ END DO
+!
+END SUBROUTINE LEGS
+!
+
+
+
+! 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)))
+ C1 = MAX(C1,ABS(A(I,J)))
+ END DO
+ C(I) = C1
+ END DO
+!
+! Search the pivoting (largest) element from each column
+!
+ DO J = 1, N-1
+ PI1 = 0.0
+ DO I = J, N
+ PI = ABS(A(INDX(I),J))/C(INDX(I))
+ IF (PI.GT.PI1) THEN
+ PI1 = PI
+ K = I
+ ENDIF
+ END DO
+!
+! Interchange the rows via INDX(N) to record pivoting order
+!
+ ITMP = INDX(J)
+ INDX(J) = INDX(K)
+ INDX(K) = ITMP
+ DO I = J+1, N
+ PJ = A(INDX(I),J)/A(INDX(J),J)
+!
+! Record pivoting ratios below the diagonal
+!
+ A(INDX(I),J) = PJ
+!
+! Modify other elements accordingly
+!
+ DO K = J+1, N
+ A(INDX(I),K) = A(INDX(I),K)-PJ*A(INDX(J),K)
+ END DO
+ END DO
+ END DO
+!
+END SUBROUTINE ELGS
+
+end module RBF_interpolation
+
Added: branches/ocean_projects/triangle_border_swm/src/operators/module_spline_interpolation.F
===================================================================
--- branches/ocean_projects/triangle_border_swm/src/operators/module_spline_interpolation.F (rev 0)
+++ branches/ocean_projects/triangle_border_swm/src/operators/module_spline_interpolation.F 2011-04-29 18:46:19 UTC (rev 810)
@@ -0,0 +1,427 @@
+module spline_interpolation
+
+ implicit none
+
+ private
+
+ public :: CubicSplineCoefficients, InterpolateCubicSpline, &
+ IntegrateCubicSpline, IntegrateColumnCubicSpline, InterpolateLinear, &
+ TestInterpolate
+
+! Short Descriptions:
+
+! CubicSplineCoefficients: Compute second derivatives at nodes.
+! This must be run before any of the other cubic spine functions.
+
+! InterpolateCubicSpline: Compute cubic spline interpolation.
+
+! IntegrateCubicSpline: Compute a single integral from spline data.
+
+! IntegrateColumnCubicSpline: Compute multiple integrals from spline data.
+
+! InterpolateLinear: Compute linear interpolation.
+
+! TestInterpolate: Test spline interpolation subroutines.
+
+ contains
+
+ subroutine CubicSplineCoefficients(x,y,n,y2ndDer)
+
+! Given arrays x(1:n) and y(1:n) containing a function,
+! i.e., y(i) = f(x(i)), with x monotonically increasing
+! this routine returns an array y2ndDer(1:n) that contains
+! the second derivatives of the interpolating function at x(1:n).
+! This routine uses boundary conditions for a natural spline,
+! with zero second derivative on that boundary.
+
+! INPUT PARAMETERS:
+
+ integer, intent(in) :: &
+ n ! number of nodes
+ real(kind=RKIND), intent(in), dimension(n) :: &
+ x, &! location of nodes
+ y ! value at nodes
+
+! OUTPUT PARAMETERS:
+
+ real(kind=RKIND), intent(out), dimension(n) :: &
+ y2ndDer ! dy^2/dx^2 at each node
+
+! local variables:
+
+ integer :: i
+ real(kind=RKIND) :: &
+ temp,xRatio,a(n)
+
+ y2ndDer(1)=0.0
+ y2ndDer(n)=0.0
+ a(1)=0.0
+
+ do i=2,n-1
+ xRatio=(x(i)-x(i-1))/(x(i+1)-x(i-1))
+ temp=1.0/(2.0+xRatio*y2ndDer(i-1))
+ y2ndDer(i)=temp*(xRatio-1.0)
+ a(i) = temp*(6.0*((y(i+1)-y(i))/(x(i+1)-x(i)) &
+ -(y(i)-y(i-1))/(x(i)-x(i-1)))/(x(i+1)-x(i-1)) &
+ -xRatio*a(i-1))
+ enddo
+
+ do i=n-1,1,-1
+ y2ndDer(i)=y2ndDer(i)*y2ndDer(i+1)+a(i)
+ enddo
+
+ end subroutine CubicSplineCoefficients
+
+
+ subroutine InterpolateCubicSpline( &
+ x,y,y2ndDer,n, &
+ xOut,yOut,nOut)
+
+! Given the arrays x(1:n) and y(1:n), which tabulate a function,
+! and given the array y2ndDer(1:n), which is the output from
+! CubicSplineCoefficients above, this routine returns the
+! cubic-spline interpolated values of yOut(1:nOut) at xOut(1:nOut).
+! This subroutine assumes that both x and xOut are monotonically
+! increasing, and that all values of xOut are within the first and
+! last values of x.
+
+! INPUT PARAMETERS:
+
+ real (kind=RKIND), dimension(n), intent(in) :: &
+ x, &! node location, input grid
+ y, &! interpolation variable, input grid
+ y2ndDer ! 2nd derivative of y at nodes
+
+ real (kind=RKIND), dimension(nOut), intent(in) :: &
+ xOut ! node location, output grid
+
+ integer, intent(in) :: &
+ n, &! number of nodes, input grid
+ nOut ! number of nodes, output grid
+
+! OUTPUT PARAMETERS:
+
+ real (kind=RKIND), dimension(nOut), intent(out) :: &
+ yOut ! interpolation variable, output grid
+
+! local variables:
+
+ integer :: &
+ kIn, kOut ! counters
+
+ real (kind=RKIND) :: &
+ a, b, h
+
+ kOut = 1
+
+ kInLoop: do kIn = 1,n-1
+
+ h = x(kIn+1)-x(kIn)
+
+ do while(xOut(kOut) < x(kIn+1))
+
+ a = (x(kIn+1)-xOut(kOut))/h
+ b = (xOut(kOut)-x (kIn) )/h
+ yOut(kOut) = a*y(kIn) + b*y(kIn+1) &
+ + ((a**3-a)*y2ndDer(kIn) + (b**3-b)*y2ndDer(kIn+1)) &
+ *(h**2)/6.0
+
+ kOut = kOut + 1
+
+ if (kOut>nOut) exit kInLoop
+
+ enddo
+
+ enddo kInLoop
+
+end subroutine InterpolateCubicSpline
+
+
+subroutine IntegrateCubicSpline(x,y,y2ndDer,n,x1,x2,y_integral)
+
+! Given the arrays x(1:n) and y(1:n), which tabulate a function,
+! and given the array y2ndDer(1:n), which is the output from
+! CubicSplineCoefficients above, this routine returns y_integral,
+! the integral of y from x1 to x2. The integration formula was
+! created by analytically integrating a cubic spline between each node.
+! This subroutine assumes that x is monotonically increasing, and
+! that x1 < x2.
+
+! INPUT PARAMETERS:
+
+ integer, intent(in) :: &
+ n ! number of nodes
+ real(kind=RKIND), intent(in), dimension(n) :: &
+ x, &! location of nodes
+ y, &! value at nodes
+ y2ndDer ! dy^2/dx^2 at each node
+ real(kind=RKIND), intent(in) :: &
+ x1,x2 ! limits of integration
+
+! OUTPUT PARAMETERS:
+
+ real(kind=RKIND), intent(out) :: &
+ y_integral ! integral of y
+
+! local variables:
+
+ integer :: i,j,k
+ real(kind=RKIND) :: h,h2, A2,B2, F1,F2, eps1
+
+ if (x1<x(1).or.x2>x(n).or.x1>x2) then
+ print *, 'error on integration bounds'
+ endif
+
+ y_integral = 0.0
+ eps1 = 1e-14*x2
+
+ do j=1,n-1 ! loop through sections
+ ! section x(j) ... x(j+1)
+
+ if (x2<=x(j) +eps1) exit
+ if (x1>=x(j+1)-eps1) cycle
+
+ h = x(j+1) - x(j)
+ h2 = h**2
+
+ ! left side:
+ if (x1<x(j)) then
+ F1 = -y(j)*h*0.5 + y2ndDer(j)*h**3/24.0
+ else
+ A2 = (x(j+1)-x1 )**2/h2
+ B2 = (x1 -x(j))**2/h2
+ F1 = 0.5*h*( -y(j)*A2 + y(j+1)*B2 &
+ + y2ndDer(j) *h2*(-0.5*A2**2 + A2)/6.0 &
+ + y2ndDer(j+1)*h2*( 0.5*B2**2 - B2)/6.0 )
+ endif
+
+ ! right side:
+ if (x2>x(j+1)) then
+ F2 = y(j+1)*h*0.5 - y2ndDer(j+1)*h**3/24.0
+ else
+ A2 = (x(j+1)-x2 )**2/h2
+ B2 = (x2 -x(j))**2/h2
+ F2 = 0.5*h*( -y(j)*A2 + y(j+1)*B2 &
+ + y2ndDer(j) *h2*(-0.5*A2**2 + A2)/6.0 &
+ + y2ndDer(j+1)*h2*( 0.5*B2**2 - B2)/6.0 )
+ endif
+
+ y_integral = y_integral + F2 - F1
+
+ enddo ! j
+
+ end subroutine IntegrateCubicSpline
+
+
+ subroutine IntegrateColumnCubicSpline( &
+ x,y,y2ndDer,n, &
+ xOut,y_integral, nOut)
+
+! Given the arrays x(1:n) and y(1:n), which tabulate a function,
+! and given the array y2ndDer(1:n), which is the output from
+! CubicSplineCoefficients above, this routine returns
+! y_integral(1:nOut), the integral of y.
+! This is a cumulative integration, so that
+! y_integral(j) holds the integral of y from x(1) to xOut(j).
+! The integration formula was created by analytically integrating a
+! cubic spline between each node.
+! This subroutine assumes that both x and xOut are monotonically
+! increasing, and that all values of xOut are within the first and
+
+! INPUT PARAMETERS:
+
+ integer, intent(in) :: &
+ n, &! number of nodes
+ nOut ! number of output locations to compute integral
+ real(kind=RKIND), intent(in), dimension(n) :: &
+ x, &! location of nodes
+ y, &! value at nodes
+ y2ndDer ! dy^2/dx^2 at each node
+ real(kind=RKIND), dimension(nOut), intent(in) :: &
+ xOut ! output locations to compute integral
+
+! OUTPUT PARAMETERS:
+
+ real(kind=RKIND), dimension(nOut), intent(out) :: &
+ y_integral ! integral from 0 to xOut
+
+! local variables:
+
+ integer :: i,j,k
+ real(kind=RKIND) :: h,h2, A2,B2, F1,F2, eps1
+
+ y_integral = 0.0
+ j = 1
+ h = x(j+1) - x(j)
+ h2 = h**2
+ F1 = -y(j)*h*0.5 + y2ndDer(j)*h**3/24.0
+ eps1 = 0.0 ! note: could use 1e-12*xOut(nOut)
+
+ k_loop: do k = 1,nOut
+
+ if (k>1) y_integral(k) = y_integral(k-1)
+
+ do while(xOut(k) > x(j+1)-eps1)
+ F2 = y(j+1)*h*0.5 - y2ndDer(j+1)*h**3/24.0
+
+ y_integral(k) = y_integral(k) + F2 - F1
+ j = j+1
+ h = x(j+1) - x(j)
+ h2 = h**2
+ F1 = -y(j)*h*0.5 + y2ndDer(j)*h**3/24.0
+ if (abs(xOut(k) - x(j+1))<eps1) cycle k_loop
+ enddo
+
+ A2 = (x(j+1) - xOut(k))**2/h2
+ B2 = (xOut(k) - x(j) )**2/h2
+ F2 = 0.5*h*( -y(j)*A2 + y(j+1)*B2 &
+ + y2ndDer(j) *h2*(-0.5*A2**2 + A2)/6.0 &
+ + y2ndDer(j+1)*h2*( 0.5*B2**2 - B2)/6.0 )
+
+ y_integral(k) = y_integral(k) + F2 - F1
+
+ if (k < nOut) then
+ A2 = (x(j+1) -xOut(k))**2/h2
+ B2 = (xOut(k) -x(j) )**2/h2
+ F1 = 0.5*h*( -y(j)*A2 + y(j+1)*B2 &
+ + y2ndDer(j) *h2*(-0.5*A2**2 + A2)/6.0 &
+ + y2ndDer(j+1)*h2*( 0.5*B2**2 - B2)/6.0 )
+ endif
+
+ enddo k_loop
+
+ end subroutine IntegrateColumnCubicSpline
+
+
+ subroutine InterpolateLinear( &
+ x,y,n, &
+ xOut,yOut,nOut)
+
+! Given the arrays x(1:n) and y(1:n), which tabulate a function,
+! this routine returns the linear interpolated values of yOut(1:nOut)
+! at xOut(1:nOut).
+! This subroutine assumes that both x and xOut are monotonically
+! increasing, and that all values of xOut are within the first and
+! last values of x.
+
+! !INPUT PARAMETERS:
+
+ real (kind=RKIND), dimension(n), intent(in) :: &
+ x, &! node location, input grid
+ y ! interpolation variable, input grid
+
+ real (kind=RKIND), dimension(nOut), intent(in) :: &
+ xOut ! node location, output grid
+
+ integer, intent(in) :: &
+ N, &! number of nodes, input grid
+ NOut ! number of nodes, output grid
+
+! !OUTPUT PARAMETERS:
+
+ real (kind=RKIND), dimension(nOut), intent(out) :: &
+ yOut ! interpolation variable, output grid
+
+!-----------------------------------------------------------------------
+!
+! local variables
+!
+!-----------------------------------------------------------------------
+
+ integer :: &
+ kIn, kOut ! counters
+
+ kOut = 1
+
+ kInLoop: do kIn = 1,n-1
+
+ do while(xOut(kOut) < x(kIn+1))
+
+ yOut(kOut) = y(kIn) &
+ + (y(kIn+1)-y(kIn)) &
+ /(x(kIn+1) -x(kIn) ) &
+ *(xOut(kOut) -x(kIn) )
+
+ kOut = kOut + 1
+
+ if (kOut>nOut) exit kInLoop
+
+ enddo
+
+ enddo kInLoop
+
+ end subroutine InterpolateLinear
+
+
+ subroutine TestInterpolate
+
+! Test function to show how to operate the cubic spline subroutines
+
+ integer, parameter :: &
+ n = 10
+ real (kind=RKIND), dimension(n) :: &
+ y, x, y2ndDer
+
+ integer, parameter :: &
+ nOut = 100
+ real (kind=RKIND), dimension(nOut) :: &
+ yOut, xOut
+
+ integer :: &
+ k
+
+!-----------------------------------------------------------------------
+!
+! Create x, y, xOut
+!
+!-----------------------------------------------------------------------
+
+ do k=1,n
+ x(k) = k-4
+ ! trig function:
+ y(k) = sin(x(k)/2)
+ enddo
+
+ do k=1,nOut
+ xOut(k) = x(1) + k/(nOut+1.0)*(x(n)-x(1))
+ enddo
+
+!-----------------------------------------------------------------------
+!
+! Interpolate
+!
+!-----------------------------------------------------------------------
+
+ ! First, compute second derivative values at each node, y2ndDer.
+ call CubicSplineCoefficients(x,y,n,y2ndDer)
+
+ ! Compute interpolated values yOut.
+ call InterpolateCubicSpline( &
+ x,y,y2ndDer,n, &
+ xOut,yOut,nOut)
+
+ ! The following output can be copied directly into Matlab
+ print *, 'subplot(2,1,1)'
+ print '(a,10f8.4,a)', 'x = [',x,'];'
+ print '(a,10f8.4,a)', 'y = [',y,'];'
+ print '(a,100f8.4,a)', 'xOut = [',xOut,'];'
+ print '(a,100f8.4,a)', 'yOut = [',yOut,'];'
+ print *, "plot(x,y,'-*r',xOut,yOut,'x')"
+
+ ! Compute interpolated values yOut.
+ call IntegrateColumnCubicSpline( &
+ x,y,y2ndDer,n, &
+ xOut,yOut,nOut)
+
+ ! The following output can be copied directly into Matlab
+ print *, 'subplot(2,1,2)'
+ print '(a,10f8.4,a)', 'x = [',x,'];'
+ print '(a,10f8.4,a)', 'y = 2*cos(-3/2) -2*cos(x/2);'
+ print '(a,100f8.4,a)', 'xOut = [',xOut,'];'
+ print '(a,100f8.4,a)', 'yOut = [',yOut,'];'
+ print *, "plot(x,y,'-*r',xOut,yOut,'x')"
+
+ end subroutine TestInterpolate
+
+end module spline_interpolation
+
Added: branches/ocean_projects/triangle_border_swm/src/operators/module_vector_reconstruction.F
===================================================================
--- branches/ocean_projects/triangle_border_swm/src/operators/module_vector_reconstruction.F (rev 0)
+++ branches/ocean_projects/triangle_border_swm/src/operators/module_vector_reconstruction.F 2011-04-29 18:46:19 UTC (rev 810)
@@ -0,0 +1,203 @@
+module vector_reconstruction
+
+ use grid_types
+ use configure
+ use constants
+ use RBF_interpolation
+
+ implicit none
+
+ public :: init_reconstruct, reconstruct
+
+ contains
+
+ subroutine init_reconstruct(grid)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Purpose: pre-compute coefficients used by the reconstruct() routine
+ !
+ ! Input: grid meta data
+ !
+ ! Output: grid % coeffs_reconstruct - coefficients used to reconstruct
+ ! velocity vectors at cell centers
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (mesh_type), intent(inout) :: grid
+
+ ! temporary arrays needed in the (to be constructed) init procedure
+ integer :: nCellsSolve
+ integer, dimension(:,:), pointer :: edgesOnCell
+ integer, dimension(:), pointer :: nEdgesOnCell
+ integer :: i, iCell, iEdge, pointCount, maxEdgeCount
+ real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell, xEdge, yEdge, zEdge
+ real (kind=RKIND) :: r, cellCenter(3), alpha, tangentPlane(2,3)
+ real (kind=RKIND), allocatable, dimension(:,:) :: edgeOnCellLocations, edgeOnCellNormals, &
+ coeffs
+
+ real(kind=RKIND), dimension(:,:), pointer :: edgeNormalVectors
+ real(kind=RKIND), dimension(:,:,:), pointer :: cellTangentPlane
+
+ real (kind=RKIND), dimension(:,:,:), pointer :: coeffs_reconstruct
+
+ !========================================================
+ ! arrays filled and saved during init procedure
+ !========================================================
+ coeffs_reconstruct => grid % coeffs_reconstruct % array
+
+ !========================================================
+ ! temporary variables needed for init procedure
+ !========================================================
+ xCell => grid % xCell % array
+ yCell => grid % yCell % array
+ zCell => grid % zCell % array
+ xEdge => grid % xEdge % array
+ yEdge => grid % yEdge % array
+ zEdge => grid % zEdge % array
+ edgesOnCell => grid % edgesOnCell % array
+ nEdgesOnCell=> grid % nEdgesOnCell % array
+ nCellsSolve = grid % nCellsSolve
+ edgeNormalVectors => grid % edgeNormalVectors % array
+ cellTangentPlane => grid % cellTangentPlane % array
+
+
+ ! init arrays
+ coeffs_reconstruct = 0.0
+
+ maxEdgeCount = maxval(nEdgesOnCell)
+
+ allocate(edgeOnCellLocations(maxEdgeCount,3))
+ allocate(edgeOnCellNormals(maxEdgeCount,3))
+ allocate(coeffs(maxEdgeCount,3))
+
+ ! loop over all cells to be solved on this block
+ do iCell=1,nCellsSolve
+ pointCount = nEdgesOnCell(iCell)
+ cellCenter(1) = xCell(iCell)
+ cellCenter(2) = yCell(iCell)
+ cellCenter(3) = zCell(iCell)
+
+ do i=1,pointCount
+ iEdge = edgesOnCell(i,iCell)
+ edgeOnCellLocations(i,1) = xEdge(iEdge)
+ edgeOnCellLocations(i,2) = yEdge(iEdge)
+ edgeOnCellLocations(i,3) = zEdge(iEdge)
+ edgeOnCellNormals(i,:) = edgeNormalVectors(:, iEdge)
+ end do
+
+ alpha = 0.0
+ do i=1,pointCount
+ r = sqrt(sum((cellCenter - edgeOnCellLocations(i,:))**2))
+ alpha = alpha + r
+ enddo
+ alpha = alpha/pointCount
+
+ tangentPlane(1,:) = cellTangentPlane(:,1,iCell)
+ tangentPlane(2,:) = cellTangentPlane(:,2,iCell)
+
+ call rbfInterp_func_3DPlane_vec_const_dir_compCoeffs(pointCount, &
+ edgeOnCellLocations(1:pointCount,:), &
+ edgeOnCellNormals(1:pointCount,:), &
+ cellCenter, alpha, tangentPlane, coeffs(1:pointCount,:))
+
+ do i=1,pointCount
+ coeffs_reconstruct(:,i,iCell) = coeffs(i,:)
+ end do
+
+ enddo ! iCell
+
+ deallocate(edgeOnCellLocations)
+ deallocate(edgeOnCellNormals)
+ deallocate(coeffs)
+
+ end subroutine init_reconstruct
+
+ subroutine reconstruct(state, grid)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Purpose: reconstruct vector field at cell centers based on radial basis functions
+ !
+ ! Input: grid meta data and vector component data residing at cell edges
+ !
+ ! Output: reconstructed vector field (measured in X,Y,Z) located at cell centers
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (state_type), intent(inout) :: state
+ type (mesh_type), intent(in) :: grid
+
+ ! temporary arrays needed in the compute procedure
+ integer :: nCellsSolve
+ integer, dimension(:,:), pointer :: edgesOnCell
+ integer, dimension(:), pointer :: nEdgesOnCell
+ integer :: iCell,iEdge, i
+ real (kind=RKIND), dimension(:,:), pointer :: u
+ real(kind=RKIND), dimension(:), pointer :: latCell, lonCell
+ real (kind=RKIND), dimension(:,:), pointer :: uReconstructX, uReconstructY, uReconstructZ
+ real (kind=RKIND), dimension(:,:), pointer :: uReconstructZonal, uReconstructMeridional
+
+ real (kind=RKIND), dimension(:,:,:), pointer :: coeffs_reconstruct
+
+ logical :: on_a_sphere
+
+ real (kind=RKIND) :: clat, slat, clon, slon
+
+
+ ! stored arrays used during compute procedure
+ coeffs_reconstruct => grid % coeffs_reconstruct % array
+
+ ! temporary variables
+ edgesOnCell => grid % edgesOnCell % array
+ nEdgesOnCell=> grid % nEdgesOnCell % array
+ nCellsSolve = grid % nCellsSolve
+ u => state % u % array
+ uReconstructX => state % uReconstructX % array
+ uReconstructY => state % uReconstructY % array
+ uReconstructZ => state % uReconstructZ % array
+
+ latCell => grid % latCell % array
+ lonCell => grid % lonCell % array
+ uReconstructZonal => state % uReconstructZonal % array
+ uReconstructMeridional => state % uReconstructMeridional % array
+ on_a_sphere = grid % on_a_sphere
+
+ ! init the intent(out)
+ uReconstructX = 0.0
+ uReconstructY = 0.0
+ uReconstructZ = 0.0
+
+ ! loop over cell centers
+ do iCell=1,nCellsSolve
+ ! a more efficient reconstruction where rbf_values*matrix_reconstruct has been precomputed
+ ! in coeffs_reconstruct
+ do i=1,nEdgesOnCell(iCell)
+ iEdge = edgesOnCell(i,iCell)
+ uReconstructX(:,iCell) = uReconstructX(:,iCell) &
+ + coeffs_reconstruct(1,i,iCell) * u(:,iEdge)
+ uReconstructY(:,iCell) = uReconstructY(:,iCell) &
+ + coeffs_reconstruct(2,i,iCell) * u(:,iEdge)
+ uReconstructZ(:,iCell) = uReconstructZ(:,iCell) &
+ + coeffs_reconstruct(3,i,iCell) * u(:,iEdge)
+
+ enddo
+ enddo ! iCell
+
+ if(on_a_sphere) then
+ do iCell=1,nCellsSolve
+ clat = cos(latCell(iCell))
+ slat = sin(latCell(iCell))
+ clon = cos(lonCell(iCell))
+ slon = sin(lonCell(iCell))
+ uReconstructZonal(:,iCell) = -uReconstructX(:,iCell)*slon + uReconstructY(:,iCell)*clon
+ uReconstructMeridional(:,iCell) = -(uReconstructX(:,iCell)*clon &
+ + uReconstructY(:,iCell)*slon)*slat &
+ + uReconstructZ(:,iCell)*clat
+ end do
+ else
+ uReconstructZonal = uReconstructX
+ uReconstructMeridional = uReconstructY
+ end if
+
+ end subroutine reconstruct
+
+end module vector_reconstruction
Added: branches/ocean_projects/triangle_border_swm/src/registry/Makefile
===================================================================
--- branches/ocean_projects/triangle_border_swm/src/registry/Makefile (rev 0)
+++ branches/ocean_projects/triangle_border_swm/src/registry/Makefile 2011-04-29 18:46:19 UTC (rev 810)
@@ -0,0 +1,14 @@
+.SUFFIXES: .c .o
+
+OBJS = parse.o dictionary.o gen_inc.o fortprintf.o
+
+all: parse
+
+parse: $(OBJS)
+ $(CC) -o $@ $(OBJS)
+
+clean:
+ $(RM) *.o parse
+
+.c.o:
+ $(CC) -c $<
Added: branches/ocean_projects/triangle_border_swm/src/registry/dictionary.c
===================================================================
--- branches/ocean_projects/triangle_border_swm/src/registry/dictionary.c (rev 0)
+++ branches/ocean_projects/triangle_border_swm/src/registry/dictionary.c 2011-04-29 18:46:19 UTC (rev 810)
@@ -0,0 +1,115 @@
+#include <stdlib.h>
+#include <string.h>
+#include "dictionary.h"
+
+int hashstring(char *);
+
+void dict_alloc(struct dtable ** dict)
+{
+ int i;
+
+ *dict = (struct dtable *)malloc(sizeof(struct dtable));
+
+ for(i=0; i<TABLESIZE; i++)
+ (*dict)->table[i] = NULL;
+
+ (*dict)->size = 0;
+}
+
+
+void dict_insert(struct dtable * dict, char * word)
+{
+ int hval;
+ struct dnode * dptr;
+
+ hval = hashstring(word) % TABLESIZE;
+
+ dptr = (struct dnode *)malloc(sizeof(struct dnode));
+ strncpy(dptr->key, word, 1024);
+ dptr->next = dict->table[hval];
+ dict->table[hval] = dptr;
+
+ dict->size++;
+}
+
+
+void dict_remove(struct dtable * dict, char * word)
+{
+ int hval;
+ struct dnode * dptr_prev;
+ struct dnode * dptr;
+
+ hval = hashstring(word) % TABLESIZE;
+
+ dptr_prev = 0;
+ dptr = dict->table[hval];
+
+ while (dptr && strncmp(dptr->key, word, 1024) != 0) {
+ dptr_prev = dptr;
+ dptr = dptr->next;
+ }
+
+ if (dptr) {
+ if (dptr_prev)
+ dptr_prev->next = dptr->next;
+ else
+ dict->table[hval] = dict->table[hval]->next;
+ free(dptr);
+ dict->size--;
+ }
+}
+
+
+int dict_search(struct dtable * dict, char * word)
+{
+ int hval;
+ struct dnode * dptr;
+
+ hval = hashstring(word) % TABLESIZE;
+
+ dptr = dict->table[hval];
+ while (dptr && strncmp(dptr->key, word, 1024) != 0)
+ dptr = dptr->next;
+
+ if (!dptr) return 0;
+
+ return 1;
+}
+
+
+int dict_size(struct dtable * dict)
+{
+ return dict->size;
+}
+
+
+void dict_free(struct dtable ** dict)
+{
+ int i;
+ struct dnode * dptr;
+
+ for(i=0; i<TABLESIZE; i++) {
+ while ((*dict)->table[i]) {
+ dptr = (*dict)->table[i];
+ (*dict)->table[i] = (*dict)->table[i]->next;
+ free(dptr);
+ }
+ }
+
+ free(*dict);
+}
+
+
+int hashstring(char * word)
+{
+ int i;
+ int hval;
+
+ hval = 0;
+
+ for(i=0; i<1024 && word[i] != '\0'; i++) {
+ hval = hval + (int)word[i];
+ }
+
+ return hval;
+}
Added: branches/ocean_projects/triangle_border_swm/src/registry/dictionary.h
===================================================================
--- branches/ocean_projects/triangle_border_swm/src/registry/dictionary.h (rev 0)
+++ branches/ocean_projects/triangle_border_swm/src/registry/dictionary.h 2011-04-29 18:46:19 UTC (rev 810)
@@ -0,0 +1,19 @@
+
+#define TABLESIZE 271
+
+struct dnode {
+ char key[1024];
+ struct dnode * next;
+};
+
+struct dtable {
+ int size;
+ struct dnode * table[TABLESIZE];
+};
+
+void dict_alloc(struct dtable **);
+void dict_insert(struct dtable *, char *);
+void dict_remove(struct dtable *, char *);
+int dict_search(struct dtable *, char *);
+int dict_size(struct dtable *);
+void dict_free(struct dtable **);
Added: branches/ocean_projects/triangle_border_swm/src/registry/fortprintf.c
===================================================================
--- branches/ocean_projects/triangle_border_swm/src/registry/fortprintf.c (rev 0)
+++ branches/ocean_projects/triangle_border_swm/src/registry/fortprintf.c 2011-04-29 18:46:19 UTC (rev 810)
@@ -0,0 +1,68 @@
+#include <stdio.h>
+#include <stdarg.h>
+
+#define MAX_LINE_LEN 132
+
+char printbuf[MAX_LINE_LEN+2];
+char fbuffer[1024];
+int nbuf = 0;
+
+void fortprintf(FILE * fd, char * str, ...)
+{
+ int i, nl, sp, inquotes;
+ va_list ap;
+
+ va_start(ap, str);
+ i = vsnprintf(fbuffer+nbuf, 1024, str, ap);
+ va_end(ap);
+
+ nbuf = nbuf + i;
+
+ inquotes = 0;
+ do {
+ nl = sp = -1;
+ for(i=0; i<MAX_LINE_LEN-1 && i<nbuf; i++) {
+ if (fbuffer[i] == '\'' && (fbuffer[i+1] != '\'' || i == nbuf-1)) inquotes = (inquotes + 1) % 2;
+ if (fbuffer[i] == '</font>
<font color="blue">') nl = i;
+ if (fbuffer[i] == ' ' && i != nbuf-1 && fbuffer[i+1] != '&') sp = i;
+ }
+ if (nbuf <= MAX_LINE_LEN) sp = -1;
+
+ if (nl > 0) {
+ snprintf(printbuf, nl+2, "%s", fbuffer);
+ fprintf(fd, "%s", printbuf);
+ nl++;
+ for(i=0; nl<nbuf; i++, nl++)
+ fbuffer[i] = fbuffer[nl];
+ nbuf = i;
+ }
+ else if (sp > 0) {
+ snprintf(printbuf, sp+2, "%s", fbuffer);
+ i = sp+1;
+ if (inquotes) printbuf[i++] = '\'';
+ printbuf[i++] = '&';
+ printbuf[i++] = '</font>
<font color="gray">';
+ printbuf[i++] = '\0';
+ fprintf(fd, "%s", printbuf);
+ sp++;
+ i = 0;
+ if (inquotes) {
+ inquotes = (inquotes + 1) % 2;
+ fbuffer[i++] = '/';
+ fbuffer[i++] = '/';
+ fbuffer[i++] = '\'';
+ }
+ for( ; sp<nbuf; i++, sp++)
+ fbuffer[i] = fbuffer[sp];
+ nbuf = i;
+ }
+ } while (nl > 0 || sp > 0);
+
+}
+
+void fortprint_flush(FILE * fd)
+{
+ snprintf(printbuf, nbuf+1, "%s", fbuffer);
+ fprintf(fd, "%s", printbuf);
+ nbuf = 0;
+}
Added: branches/ocean_projects/triangle_border_swm/src/registry/fortprintf.h
===================================================================
--- branches/ocean_projects/triangle_border_swm/src/registry/fortprintf.h (rev 0)
+++ branches/ocean_projects/triangle_border_swm/src/registry/fortprintf.h 2011-04-29 18:46:19 UTC (rev 810)
@@ -0,0 +1,2 @@
+void fortprintf(FILE *, char *, ...);
+void fortprint_flush(FILE *);
Added: branches/ocean_projects/triangle_border_swm/src/registry/gen_inc.c
===================================================================
--- branches/ocean_projects/triangle_border_swm/src/registry/gen_inc.c (rev 0)
+++ branches/ocean_projects/triangle_border_swm/src/registry/gen_inc.c 2011-04-29 18:46:19 UTC (rev 810)
@@ -0,0 +1,1642 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include "dictionary.h"
+#include "registry_types.h"
+#include "gen_inc.h"
+#include "fortprintf.h"
+
+int is_derived_dim(char * d)
+{
+ if (strchr(d, (int)'+')) return 1;
+ if (strchr(d, (int)'-')) return 1;
+
+ return 0;
+}
+
+void split_derived_dim_string(char * dim, char ** p1, char ** p2)
+{
+ char * cp, * cm, * c;
+ int n;
+
+ cp = strchr(dim, (int)'+');
+ cm = strchr(dim, (int)'-');
+ if (!cp)
+ c = cm;
+ else if (!cm)
+ c = cp;
+ else if (cm < cp)
+ c = cm;
+ else
+ c = cp;
+
+ n = c - dim;
+ *p1 = (char *)malloc(n*sizeof(char));
+ snprintf(*p1, n, "%s", dim+1);
+
+ *p2 = (char *)malloc((strlen(dim)-n+1)*sizeof(char));
+ sprintf(*p2, "%s", dim+n);
+}
+
+void gen_namelists(struct namelist * nls)
+{
+ struct namelist * nls_ptr;
+ struct dtable * dictionary;
+ int done;
+ char nlrecord[1024];
+ FILE * fd;
+
+ /*
+ * Generate config_type.inc
+ */
+ fd = fopen("config_defs.inc", "w");
+
+ nls_ptr = nls;
+ while (nls_ptr) {
+ if (nls_ptr->vtype == INTEGER) fortprintf(fd, " integer :: %s</font>
<font color="blue">",nls_ptr->name);
+ if (nls_ptr->vtype == REAL) fortprintf(fd, " real (KIND=RKIND) :: %s</font>
<font color="blue">",nls_ptr->name);
+ if (nls_ptr->vtype == LOGICAL) fortprintf(fd, " logical :: %s</font>
<font color="blue">",nls_ptr->name);
+ if (nls_ptr->vtype == CHARACTER) fortprintf(fd, " character (len=32) :: %s</font>
<font color="blue">",nls_ptr->name);
+
+ nls_ptr = nls_ptr->next;
+ }
+
+ fclose(fd);
+
+
+ /*
+ * Generate namelist_defs.inc
+ */
+ fd = fopen("config_namelist_defs.inc", "w");
+ dict_alloc(&dictionary);
+
+ done = 0;
+
+ while (!done) {
+ nls_ptr = nls;
+ while (nls_ptr && dict_search(dictionary, nls_ptr->record))
+ nls_ptr = nls_ptr->next;
+
+ if (nls_ptr) {
+ dict_insert(dictionary, nls_ptr->record);
+ strncpy(nlrecord, nls_ptr->record, 1024);
+ fortprintf(fd, " namelist /%s/ %s", nls_ptr->record, nls_ptr->name);
+ nls_ptr = nls_ptr->next;
+ while(nls_ptr) {
+ if (strncmp(nls_ptr->record, nlrecord, 1024) == 0)
+ fortprintf(fd, ", &</font>
<font color="blue"> %s", nls_ptr->name);
+ nls_ptr = nls_ptr->next;
+ }
+ fortprintf(fd, "</font>
<font color="blue">");
+ }
+ else
+ done = 1;
+ }
+
+
+ dict_free(&dictionary);
+ fclose(fd);
+
+
+ /*
+ * Generate namelist_reads.inc
+ */
+ fd = fopen("config_set_defaults.inc", "w");
+ nls_ptr = nls;
+ while (nls_ptr) {
+ if (nls_ptr->vtype == INTEGER) fortprintf(fd, " %s = %i</font>
<font color="blue">", nls_ptr->name, nls_ptr->defval.ival);
+ if (nls_ptr->vtype == REAL) fortprintf(fd, " %s = %f</font>
<font color="blue">", nls_ptr->name, nls_ptr->defval.rval);
+ if (nls_ptr->vtype == LOGICAL) {
+ if (nls_ptr->defval.lval == 0)
+ fortprintf(fd, " %s = .false.</font>
<font color="blue">", nls_ptr->name);
+ else
+ fortprintf(fd, " %s = .true.</font>
<font color="blue">", nls_ptr->name);
+ }
+ if (nls_ptr->vtype == CHARACTER)
+ fortprintf(fd, " %s = \"%s\"</font>
<font color="blue">", nls_ptr->name, nls_ptr->defval.cval);
+ nls_ptr = nls_ptr->next;
+ }
+ fortprintf(fd, "</font>
<font color="blue">");
+ fclose(fd);
+
+
+ fd = fopen("config_namelist_reads.inc", "w");
+ dict_alloc(&dictionary);
+ nls_ptr = nls;
+ while (nls_ptr) {
+ if (!dict_search(dictionary, nls_ptr->record)) {
+ fortprintf(fd, " read(funit,%s)</font>
<font color="blue">", nls_ptr->record);
+ dict_insert(dictionary, nls_ptr->record);
+ }
+ nls_ptr = nls_ptr->next;
+ }
+ fortprintf(fd, "</font>
<font color="blue">");
+
+ dict_free(&dictionary);
+ fclose(fd);
+
+
+ fd = fopen("config_bcast_namelist.inc", "w");
+ nls_ptr = nls;
+ while (nls_ptr) {
+ if (nls_ptr->vtype == INTEGER) fortprintf(fd, " call dmpar_bcast_int(dminfo, %s)</font>
<font color="blue">", nls_ptr->name);
+ if (nls_ptr->vtype == REAL) fortprintf(fd, " call dmpar_bcast_real(dminfo, %s)</font>
<font color="blue">", nls_ptr->name);
+ if (nls_ptr->vtype == LOGICAL) fortprintf(fd, " call dmpar_bcast_logical(dminfo, %s)</font>
<font color="blue">", nls_ptr->name);
+ if (nls_ptr->vtype == CHARACTER) fortprintf(fd, " call dmpar_bcast_char(dminfo, %s)</font>
<font color="blue">", nls_ptr->name);
+ nls_ptr = nls_ptr->next;
+ }
+ fortprintf(fd, "</font>
<font color="blue">");
+ fclose(fd);
+}
+
+
+void gen_field_defs(struct group_list * groups, struct variable * vars, struct dimension * dims)
+{
+ struct variable * var_ptr;
+ struct variable * var_ptr2;
+ struct variable_list * var_list_ptr;
+ struct variable_list * var_list_ptr2;
+ struct dimension * dim_ptr;
+ struct dimension_list * dimlist_ptr;
+ struct group_list * group_ptr;
+ FILE * fd;
+ char super_array[1024];
+ char array_class[1024];
+ int i;
+ int class_start, class_end;
+ int vtype;
+
+
+ /*
+ * Generate declarations of dimensions
+ */
+ fd = fopen("field_dimensions.inc", "w");
+ dim_ptr = dims;
+ while (dim_ptr) {
+ if (dim_ptr->constant_value < 0 && !dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, " integer :: %s</font>
<font color="blue">", dim_ptr->name_in_code);
+ if (dim_ptr->constant_value < 0 && dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, " integer :: %s</font>
<font color="blue">", dim_ptr->name_in_file);
+ dim_ptr = dim_ptr->next;
+ }
+ dim_ptr = dims;
+ while (dim_ptr) {
+ if (dim_ptr->constant_value < 0 && !dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, " integer :: %sSolve</font>
<font color="blue">", dim_ptr->name_in_code);
+ if (dim_ptr->constant_value < 0 && dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, " integer :: %sSolve</font>
<font color="blue">", dim_ptr->name_in_file);
+ dim_ptr = dim_ptr->next;
+ }
+
+ fclose(fd);
+
+
+ /*
+ * Generate dummy dimension argument list
+ */
+ fd = fopen("dim_dummy_args.inc", "w");
+ dim_ptr = dims;
+ if (dim_ptr && dim_ptr->constant_value < 0 && !dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) {
+ fortprintf(fd, " %s", dim_ptr->name_in_code);
+ dim_ptr = dim_ptr->next;
+ }
+ else if (dim_ptr && dim_ptr->constant_value < 0 && dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) {
+ fortprintf(fd, " %s", dim_ptr->name_in_file);
+ dim_ptr = dim_ptr->next;
+ }
+ while (dim_ptr) {
+ if (dim_ptr->constant_value < 0 && !dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, ", %s", dim_ptr->name_in_code);
+ if (dim_ptr->constant_value < 0 && dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, ", %s", dim_ptr->name_in_file);
+ dim_ptr = dim_ptr->next;
+ }
+ fortprintf(fd, " &</font>
<font color="blue">");
+
+ fclose(fd);
+
+
+ /*
+ * Generate dummy dimension argument declaration list
+ */
+ fd = fopen("dim_dummy_decls.inc", "w");
+ dim_ptr = dims;
+ if (dim_ptr && dim_ptr->constant_value < 0 && !dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) {
+ fortprintf(fd, " integer, intent(in) :: %s", dim_ptr->name_in_code);
+ dim_ptr = dim_ptr->next;
+ }
+ else if (dim_ptr && dim_ptr->constant_value < 0 && dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) {
+ fortprintf(fd, " integer, intent(in) :: %s", dim_ptr->name_in_file);
+ dim_ptr = dim_ptr->next;
+ }
+ while (dim_ptr) {
+ if (dim_ptr->constant_value < 0 && !dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, ", %s", dim_ptr->name_in_code);
+ if (dim_ptr->constant_value < 0 && dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, ", %s", dim_ptr->name_in_file);
+ dim_ptr = dim_ptr->next;
+ }
+ fortprintf(fd, "</font>
<font color="blue">");
+
+ fclose(fd);
+
+
+ /*
+ * Generate declarations of dimensions
+ */
+ fd = fopen("dim_decls.inc", "w");
+ dim_ptr = dims;
+ while (dim_ptr) {
+ if (dim_ptr->constant_value < 0 && !dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, " integer :: %s</font>
<font color="blue">", dim_ptr->name_in_code);
+ if (dim_ptr->constant_value < 0 && dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, " integer :: %s</font>
<font color="blue">", dim_ptr->name_in_file);
+ dim_ptr = dim_ptr->next;
+ }
+
+ fclose(fd);
+
+
+ /*
+ * Generate calls to read dimensions from input file
+ */
+ fd = fopen("read_dims.inc", "w");
+ dim_ptr = dims;
+ while (dim_ptr) {
+ if (dim_ptr->constant_value < 0 && !dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, " call io_input_get_dimension(input_obj, \'%s\', %s)</font>
<font color="blue">", dim_ptr->name_in_file, dim_ptr->name_in_code);
+ else if (dim_ptr->constant_value < 0 && dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, " call io_input_get_dimension(input_obj, \'%s\', %s)</font>
<font color="blue">", dim_ptr->name_in_file, dim_ptr->name_in_file);
+ dim_ptr = dim_ptr->next;
+ }
+
+ fclose(fd);
+
+
+ /*
+ * Generate declarations of mesh group
+ */
+ fd = fopen("time_invariant_fields.inc", "w");
+ group_ptr = groups;
+ while (group_ptr) {
+
+ if (!strncmp(group_ptr->name, "mesh", 1024)) {
+
+ var_list_ptr = group_ptr->vlist;
+ memcpy(super_array, var_list_ptr->var->super_array, 1024);
+ i = 1;
+ while (var_list_ptr) {
+ if (strncmp(super_array, var_list_ptr->var->super_array, 1024) != 0) {
+ memcpy(super_array, var_list_ptr->var->super_array, 1024);
+ i = 1;
+ }
+ if (strncmp(var_list_ptr->var->array_class, "-", 1024) != 0) fortprintf(fd, " integer :: index_%s = %i</font>
<font color="blue">", var_list_ptr->var->name_in_code, i++);
+ var_list_ptr = var_list_ptr->next;
+ }
+
+ var_list_ptr = group_ptr->vlist;
+ memcpy(super_array, var_list_ptr->var->super_array, 1024);
+ memcpy(array_class, var_list_ptr->var->array_class, 1024);
+ class_start = 1;
+ class_end = 1;
+ i = 1;
+ while (var_list_ptr) {
+ if (strncmp(var_list_ptr->var->super_array, "-", 1024) != 0) {
+ if (strncmp(super_array, var_list_ptr->var->super_array, 1024) != 0) {
+ if (strncmp(super_array, "-", 1024) != 0) fortprintf(fd, " integer :: %s_end = %i</font>
<font color="blue">", array_class, class_end);
+ if (strncmp(super_array, "-", 1024) != 0) fortprintf(fd, " integer :: num_%s = %i</font>
<font color="blue">", super_array, i);
+ class_start = 1;
+ class_end = 1;
+ i = 1;
+ memcpy(super_array, var_list_ptr->var->super_array, 1024);
+ memcpy(array_class, var_list_ptr->var->array_class, 1024);
+ fortprintf(fd, " integer :: %s_start = %i</font>
<font color="blue">", array_class, class_start);
+ }
+ else if (strncmp(array_class, var_list_ptr->var->array_class, 1024) != 0) {
+ fortprintf(fd, " integer :: %s_end = %i</font>
<font color="blue">", array_class, class_end);
+ class_start = class_end+1;
+ class_end = class_start;
+ memcpy(array_class, var_list_ptr->var->array_class, 1024);
+ fortprintf(fd, " integer :: %s_start = %i</font>
<font color="blue">", array_class, class_start);
+ i++;
+ }
+ else {
+ class_end++;
+ i++;
+ }
+ }
+ var_list_ptr = var_list_ptr->next;
+ }
+ if (strncmp(super_array, "-", 1024) != 0) fortprintf(fd, " integer :: %s_end = %i</font>
<font color="blue">", array_class, class_end);
+ if (strncmp(super_array, "-", 1024) != 0) fortprintf(fd, " integer :: num_%s = %i</font>
<font color="blue">", super_array, i);
+
+ var_list_ptr = group_ptr->vlist;
+ while (var_list_ptr) {
+ var_ptr = var_list_ptr->var;
+ if (!strncmp(var_ptr->super_array, "-", 1024)) {
+ if (var_ptr->vtype == INTEGER) fortprintf(fd, " type (field%idInteger), pointer :: %s</font>
<font color="blue">", var_ptr->ndims, var_ptr->name_in_code);
+ if (var_ptr->vtype == REAL) fortprintf(fd, " type (field%idReal), pointer :: %s</font>
<font color="blue">", var_ptr->ndims, var_ptr->name_in_code);
+ }
+ else {
+ if (var_ptr->vtype == INTEGER) fortprintf(fd, " type (field%idInteger), pointer :: %s</font>
<font color="blue">", var_ptr->ndims+1, var_ptr->super_array);
+ if (var_ptr->vtype == REAL) fortprintf(fd, " type (field%idReal), pointer :: %s</font>
<font color="blue">", var_ptr->ndims+1, var_ptr->super_array);
+ while (var_list_ptr->next && !strncmp(var_list_ptr->next->var->super_array, var_list_ptr->var->super_array, 1024)) var_list_ptr = var_list_ptr->next;
+ }
+ var_list_ptr = var_list_ptr->next;
+ }
+ break;
+ }
+ group_ptr = group_ptr->next;
+ }
+
+ fclose(fd);
+
+
+ /*
+ * Generate declarations of non-mesh groups
+ */
+ fd = fopen("variable_groups.inc", "w");
+
+ group_ptr = groups;
+ while (group_ptr) {
+ if (strncmp(group_ptr->name, "mesh", 1024)) {
+ fortprintf(fd, " type %s_type</font>
<font color="blue">", group_ptr->name);
+
+ var_list_ptr = group_ptr->vlist;
+ memcpy(super_array, var_list_ptr->var->super_array, 1024);
+ i = 1;
+ while (var_list_ptr) {
+ if (strncmp(super_array, var_list_ptr->var->super_array, 1024) != 0) {
+ memcpy(super_array, var_list_ptr->var->super_array, 1024);
+ i = 1;
+ }
+ if (strncmp(var_list_ptr->var->array_class, "-", 1024) != 0) fortprintf(fd, " integer :: index_%s = %i</font>
<font color="blue">", var_list_ptr->var->name_in_code, i++);
+ var_list_ptr = var_list_ptr->next;
+ }
+
+ var_list_ptr = group_ptr->vlist;
+ sprintf(super_array, "-");
+ sprintf(array_class, "-");
+ class_start = 1;
+ class_end = 1;
+ i = 1;
+
+ while (var_list_ptr) {
+
+ /* Is the current variable in a super array? */
+ if (strncmp(var_list_ptr->var->super_array, "-", 1024) != 0) {
+
+ /* Have we hit the beginning of a new super array? */
+ if (strncmp(super_array, var_list_ptr->var->super_array, 1024) != 0) {
+ /* Finish off the previous super array? */
+ if (strncmp(super_array, "-", 1024) != 0) {
+ fortprintf(fd, " integer :: %s_end = %i</font>
<font color="blue">", array_class, class_end);
+ fortprintf(fd, " integer :: num_%s = %i</font>
<font color="blue">", super_array, i);
+ }
+ class_start = 1;
+ class_end = 1;
+ i = 1;
+ memcpy(super_array, var_list_ptr->var->super_array, 1024);
+ memcpy(array_class, var_list_ptr->var->array_class, 1024);
+ fortprintf(fd, " integer :: %s_start = %i</font>
<font color="blue">", array_class, class_start);
+ }
+ /* Or have we hit the beginning of a new array class? */
+ else if (strncmp(array_class, var_list_ptr->var->array_class, 1024) != 0) {
+ fortprintf(fd, " integer :: %s_end = %i</font>
<font color="blue">", array_class, class_end);
+ class_start = class_end+1;
+ class_end = class_start;
+ memcpy(array_class, var_list_ptr->var->array_class, 1024);
+ fortprintf(fd, " integer :: %s_start = %i</font>
<font color="blue">", array_class, class_start);
+ i++;
+ }
+ else {
+ class_end++;
+ i++;
+ }
+
+ }
+ var_list_ptr = var_list_ptr->next;
+
+ }
+ if (strncmp(super_array, "-", 1024) != 0) fortprintf(fd, " integer :: %s_end = %i</font>
<font color="blue">", array_class, class_end);
+ if (strncmp(super_array, "-", 1024) != 0) fortprintf(fd, " integer :: num_%s = %i</font>
<font color="blue">", super_array, i);
+
+ var_list_ptr = group_ptr->vlist;
+ while (var_list_ptr) {
+ var_ptr = var_list_ptr->var;
+ if (!strncmp(var_ptr->super_array, "-", 1024)) {
+ if (var_ptr->vtype == INTEGER) fortprintf(fd, " type (field%idInteger), pointer :: %s</font>
<font color="blue">", var_ptr->ndims, var_ptr->name_in_code);
+ if (var_ptr->vtype == REAL) fortprintf(fd, " type (field%idReal), pointer :: %s</font>
<font color="blue">", var_ptr->ndims, var_ptr->name_in_code);
+ }
+ else {
+ if (var_ptr->vtype == INTEGER) fortprintf(fd, " type (field%idInteger), pointer :: %s</font>
<font color="blue">", var_ptr->ndims+1, var_ptr->super_array);
+ if (var_ptr->vtype == REAL) fortprintf(fd, " type (field%idReal), pointer :: %s</font>
<font color="blue">", var_ptr->ndims+1, var_ptr->super_array);
+ while (var_list_ptr->next && !strncmp(var_list_ptr->next->var->super_array, var_list_ptr->var->super_array, 1024)) var_list_ptr = var_list_ptr->next;
+ }
+ var_list_ptr = var_list_ptr->next;
+ }
+
+ fortprintf(fd, " end type %s_type</font>
<font color="black"></font>
<font color="black"></font>
<font color="blue">", group_ptr->name);
+
+ if (group_ptr->vlist->var->ntime_levs > 1) {
+ fortprintf(fd, " type %s_pointer_type</font>
<font color="blue">", group_ptr->name);
+ fortprintf(fd, " type (%s_type), pointer :: %s </font>
<font color="blue">", group_ptr->name, group_ptr->name);
+ fortprintf(fd, " end type %s_pointer_type</font>
<font color="black"></font>
<font color="black"></font>
<font color="blue">", group_ptr->name);
+
+ fortprintf(fd, " type %s_multilevel_type</font>
<font color="blue">", group_ptr->name);
+ fortprintf(fd, " integer :: nTimeLevels</font>
<font color="blue">");
+ fortprintf(fd, " type (%s_pointer_type), dimension(:), pointer :: time_levs</font>
<font color="blue">", group_ptr->name);
+ fortprintf(fd, " end type %s_multilevel_type</font>
<font color="black"></font>
<font color="black"></font>
<font color="blue">", group_ptr->name);
+ }
+
+ }
+ group_ptr = group_ptr->next;
+ }
+
+ fclose(fd);
+
+ /*
+ * Generate instantiations of variable groups in block_type
+ */
+ fd = fopen("block_group_members.inc", "w");
+
+ group_ptr = groups;
+ while (group_ptr) {
+ if (group_ptr->vlist->var->ntime_levs > 1)
+ fortprintf(fd, " type (%s_multilevel_type), pointer :: %s</font>
<font color="blue">", group_ptr->name, group_ptr->name);
+ else
+ fortprintf(fd, " type (%s_type), pointer :: %s</font>
<font color="blue">", group_ptr->name, group_ptr->name);
+ group_ptr = group_ptr->next;
+ }
+
+ fclose(fd);
+
+
+ /* To be included in allocate_block */
+ fd = fopen("block_allocs.inc", "w");
+ group_ptr = groups;
+ while (group_ptr) {
+ fortprintf(fd, " allocate(b %% %s)</font>
<font color="blue">", group_ptr->name);
+ if (group_ptr->vlist->var->ntime_levs > 1) {
+ fortprintf(fd, " b %% %s %% nTimeLevels = %i</font>
<font color="blue">", group_ptr->name, group_ptr->vlist->var->ntime_levs);
+ fortprintf(fd, " allocate(b %% %s %% time_levs(%i))</font>
<font color="blue">", group_ptr->name, group_ptr->vlist->var->ntime_levs);
+ fortprintf(fd, " do i=1,b %% %s %% nTimeLevels</font>
<font color="blue">", group_ptr->name);
+ fortprintf(fd, " allocate(b %% %s %% time_levs(i) %% %s)</font>
<font color="blue">", group_ptr->name, group_ptr->name);
+ fortprintf(fd, " call allocate_%s(b %% %s %% time_levs(i) %% %s, &</font>
<font color="blue">", group_ptr->name, group_ptr->name, group_ptr->name);
+ fortprintf(fd, "#include \"dim_dummy_args.inc\"</font>
<font color="blue">");
+ fortprintf(fd, " )</font>
<font color="blue">");
+ fortprintf(fd, " end do</font>
<font color="black"></font>
<font color="blue">");
+ }
+ else {
+ fortprintf(fd, " call allocate_%s(b %% %s, &</font>
<font color="blue">", group_ptr->name, group_ptr->name);
+ fortprintf(fd, "#include \"dim_dummy_args.inc\"</font>
<font color="blue">");
+ fortprintf(fd, " )</font>
<font color="black"></font>
<font color="blue">");
+ }
+ group_ptr = group_ptr->next;
+ }
+ fclose(fd);
+
+
+ /* To be included in deallocate_block */
+ fd = fopen("block_deallocs.inc", "w");
+ group_ptr = groups;
+ while (group_ptr) {
+ if (group_ptr->vlist->var->ntime_levs > 1) {
+ fortprintf(fd, " do i=1,b %% %s %% nTimeLevels</font>
<font color="blue">", group_ptr->name);
+ fortprintf(fd, " call deallocate_%s(b %% %s %% time_levs(i) %% %s)</font>
<font color="blue">", group_ptr->name, group_ptr->name, group_ptr->name);
+ fortprintf(fd, " deallocate(b %% %s %% time_levs(i) %% %s)</font>
<font color="blue">", group_ptr->name, group_ptr->name);
+ fortprintf(fd, " end do</font>
<font color="blue">");
+ fortprintf(fd, " deallocate(b %% %s %% time_levs)</font>
<font color="blue">", group_ptr->name);
+ }
+ else {
+ fortprintf(fd, " call deallocate_%s(b %% %s)</font>
<font color="blue">", group_ptr->name, group_ptr->name);
+ }
+ fortprintf(fd, " deallocate(b %% %s)</font>
<font color="black"></font>
<font color="blue">", group_ptr->name);
+ group_ptr = group_ptr->next;
+ }
+ fclose(fd);
+
+ /* Definitions of allocate subroutines */
+ fd = fopen("group_alloc_routines.inc", "w");
+ group_ptr = groups;
+ while (group_ptr) {
+ fortprintf(fd, " subroutine allocate_%s(%s, &</font>
<font color="blue">", group_ptr->name, group_ptr->name);
+ fortprintf(fd, "#include \"dim_dummy_args.inc\"</font>
<font color="blue">");
+ fortprintf(fd, " )</font>
<font color="blue">");
+ fortprintf(fd, "</font>
<font color="blue">");
+ fortprintf(fd, " implicit none</font>
<font color="blue">");
+ fortprintf(fd, "</font>
<font color="blue">");
+ fortprintf(fd, " type (%s_type), intent(inout) :: %s</font>
<font color="blue">", group_ptr->name, group_ptr->name);
+ fortprintf(fd, "#include \"dim_dummy_decls.inc\"</font>
<font color="blue">");
+ fortprintf(fd, "</font>
<font color="blue">");
+
+ if (!strncmp(group_ptr->name, "mesh", 1024)) {
+ dim_ptr = dims;
+ while (dim_ptr) {
+ if (dim_ptr->constant_value < 0 && !dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, " %s %% %s = %s</font>
<font color="blue">", group_ptr->name, dim_ptr->name_in_code, dim_ptr->name_in_code);
+ if (dim_ptr->constant_value < 0 && dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, " %s %% %s = %s</font>
<font color="blue">", group_ptr->name, dim_ptr->name_in_file, dim_ptr->name_in_file);
+ dim_ptr = dim_ptr->next;
+ }
+ fortprintf(fd, "</font>
<font color="blue">");
+ }
+
+
+ var_list_ptr = group_ptr->vlist;
+ while (var_list_ptr) {
+ var_ptr = var_list_ptr->var;
+ if (strncmp(var_ptr->super_array, "-", 1024) != 0) {
+ memcpy(super_array, var_ptr->super_array, 1024);
+ memcpy(array_class, var_ptr->array_class, 1024);
+ i = 0;
+ while (var_list_ptr && strncmp(super_array, var_list_ptr->var->super_array, 1024) == 0) {
+ i++;
+ var_list_ptr2 = var_list_ptr;
+ var_list_ptr = var_list_ptr->next;
+ }
+ var_ptr2 = var_list_ptr2->var;
+ fortprintf(fd, " allocate(%s %% %s)</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array);
+ fortprintf(fd, " allocate(%s %% %s %% ioinfo)</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array);
+ fortprintf(fd, " allocate(%s %% %s %% array(%i, ", group_ptr->name, var_ptr2->super_array, i);
+ dimlist_ptr = var_ptr2->dimlist;
+ if (!strncmp(dimlist_ptr->dim->name_in_file, "nCells", 1024) ||
+ !strncmp(dimlist_ptr->dim->name_in_file, "nEdges", 1024) ||
+ !strncmp(dimlist_ptr->dim->name_in_file, "nVertices", 1024))
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, "%s + 1", dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, "%s + 1", dimlist_ptr->dim->name_in_file);
+ else
+ if (dimlist_ptr->dim->namelist_defined) fortprintf(fd, "%s", dimlist_ptr->dim->name_in_file);
+ else fortprintf(fd, "%s", dimlist_ptr->dim->name_in_code);
+ dimlist_ptr = dimlist_ptr->next;
+ while (dimlist_ptr) {
+ if (!strncmp(dimlist_ptr->dim->name_in_file, "nCells", 1024) ||
+ !strncmp(dimlist_ptr->dim->name_in_file, "nEdges", 1024) ||
+ !strncmp(dimlist_ptr->dim->name_in_file, "nVertices", 1024))
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, ", %s + 1", dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, ", %s + 1", dimlist_ptr->dim->name_in_file);
+ else
+ if (dimlist_ptr->dim->namelist_defined) fortprintf(fd, ", %s", dimlist_ptr->dim->name_in_file);
+ else fortprintf(fd, ", %s", dimlist_ptr->dim->name_in_code);
+ dimlist_ptr = dimlist_ptr->next;
+ }
+ fortprintf(fd, "))</font>
<font color="blue">");
+ fortprintf(fd, " %s %% %s %% array = 0</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array ); /* initialize field to zero */
+
+ if (var_ptr2->iostreams & INPUT0)
+ fortprintf(fd, " %s %% %s %% ioinfo %% input = .true.</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array);
+ else
+ fortprintf(fd, " %s %% %s %% ioinfo %% input = .false.</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array);
+
+ if (var_ptr2->iostreams & RESTART0)
+ fortprintf(fd, " %s %% %s %% ioinfo %% restart = .true.</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array);
+ else
+ fortprintf(fd, " %s %% %s %% ioinfo %% restart = .false.</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array);
+
+ if (var_ptr2->iostreams & OUTPUT0)
+ fortprintf(fd, " %s %% %s %% ioinfo %% output = .true.</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array);
+ else
+ fortprintf(fd, " %s %% %s %% ioinfo %% output = .false.</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array);
+ fortprintf(fd, "</font>
<font color="blue">");
+ }
+ else {
+ fortprintf(fd, " allocate(%s %% %s)</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code);
+ fortprintf(fd, " allocate(%s %% %s %% ioinfo)</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code);
+ if (var_ptr->ndims > 0) {
+ fortprintf(fd, " allocate(%s %% %s %% array(", group_ptr->name, var_ptr->name_in_code);
+ dimlist_ptr = var_ptr->dimlist;
+ if (!strncmp(dimlist_ptr->dim->name_in_file, "nCells", 1024) ||
+ !strncmp(dimlist_ptr->dim->name_in_file, "nEdges", 1024) ||
+ !strncmp(dimlist_ptr->dim->name_in_file, "nVertices", 1024))
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, "%s + 1", dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, "%s + 1", dimlist_ptr->dim->name_in_file);
+ else
+ if (dimlist_ptr->dim->namelist_defined) fortprintf(fd, "%s", dimlist_ptr->dim->name_in_file);
+ else fortprintf(fd, "%s", dimlist_ptr->dim->name_in_code);
+ dimlist_ptr = dimlist_ptr->next;
+ while (dimlist_ptr) {
+ if (!strncmp(dimlist_ptr->dim->name_in_file, "nCells", 1024) ||
+ !strncmp(dimlist_ptr->dim->name_in_file, "nEdges", 1024) ||
+ !strncmp(dimlist_ptr->dim->name_in_file, "nVertices", 1024))
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, ", %s + 1", dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, ", %s + 1", dimlist_ptr->dim->name_in_file);
+ else
+ if (dimlist_ptr->dim->namelist_defined) fortprintf(fd, ", %s", dimlist_ptr->dim->name_in_file);
+ else fortprintf(fd, ", %s", dimlist_ptr->dim->name_in_code);
+ dimlist_ptr = dimlist_ptr->next;
+ }
+ fortprintf(fd, "))</font>
<font color="blue">");
+ fortprintf(fd, " %s %% %s %% array = 0</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code ); /* initialize field to zero */
+
+ }
+ if (var_ptr->iostreams & INPUT0)
+ fortprintf(fd, " %s %% %s %% ioinfo %% input = .true.</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code);
+ else
+ fortprintf(fd, " %s %% %s %% ioinfo %% input = .false.</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code);
+
+ if (var_ptr->iostreams & RESTART0)
+ fortprintf(fd, " %s %% %s %% ioinfo %% restart = .true.</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code);
+ else
+ fortprintf(fd, " %s %% %s %% ioinfo %% restart = .false.</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code);
+
+ if (var_ptr->iostreams & OUTPUT0)
+ fortprintf(fd, " %s %% %s %% ioinfo %% output = .true.</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code);
+ else
+ fortprintf(fd, " %s %% %s %% ioinfo %% output = .false.</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code);
+ fortprintf(fd, "</font>
<font color="blue">");
+
+ var_list_ptr = var_list_ptr->next;
+ }
+ }
+
+ fortprintf(fd, " end subroutine allocate_%s</font>
<font color="black"></font>
<font color="black"></font>
<font color="blue">", group_ptr->name);
+ group_ptr = group_ptr->next;
+ }
+ fclose(fd);
+
+ /* Definitions of deallocate subroutines */
+ fd = fopen("group_dealloc_routines.inc", "w");
+ group_ptr = groups;
+ while (group_ptr) {
+ fortprintf(fd, " subroutine deallocate_%s(%s)</font>
<font color="blue">", group_ptr->name, group_ptr->name);
+ fortprintf(fd, "</font>
<font color="blue">");
+ fortprintf(fd, " implicit none</font>
<font color="blue">");
+ fortprintf(fd, "</font>
<font color="blue">");
+ fortprintf(fd, " type (%s_type), intent(inout) :: %s</font>
<font color="blue">", group_ptr->name, group_ptr->name);
+ fortprintf(fd, "</font>
<font color="blue">");
+
+ var_list_ptr = group_ptr->vlist;
+ while (var_list_ptr) {
+ var_ptr = var_list_ptr->var;
+ if (strncmp(var_ptr->super_array, "-", 1024) != 0) {
+ memcpy(super_array, var_ptr->super_array, 1024);
+ memcpy(array_class, var_ptr->array_class, 1024);
+ i = 0;
+ while (var_list_ptr && strncmp(super_array, var_list_ptr->var->super_array, 1024) == 0) {
+ i++;
+ var_list_ptr2 = var_list_ptr;
+ var_list_ptr = var_list_ptr->next;
+ }
+ fortprintf(fd, " deallocate(%s %% %s %% array)</font>
<font color="blue">", group_ptr->name, var_list_ptr2->var->super_array);
+ fortprintf(fd, " deallocate(%s %% %s %% ioinfo)</font>
<font color="blue">", group_ptr->name, var_list_ptr2->var->super_array);
+ fortprintf(fd, " deallocate(%s %% %s)</font>
<font color="black"></font>
<font color="blue">", group_ptr->name, var_list_ptr2->var->super_array);
+ }
+ else {
+ if (var_ptr->ndims > 0) {
+ fortprintf(fd, " deallocate(%s %% %s %% array)</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code);
+ fortprintf(fd, " deallocate(%s %% %s %% ioinfo)</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code);
+ fortprintf(fd, " deallocate(%s %% %s)</font>
<font color="black"></font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code);
+ }
+ else {
+ fortprintf(fd, " deallocate(%s %% %s %% ioinfo)</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code);
+ fortprintf(fd, " deallocate(%s %% %s)</font>
<font color="black"></font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code);
+ }
+ var_list_ptr = var_list_ptr->next;
+ }
+ }
+
+ fortprintf(fd, " end subroutine deallocate_%s</font>
<font color="black"></font>
<font color="black"></font>
<font color="blue">", group_ptr->name);
+ group_ptr = group_ptr->next;
+ }
+ fclose(fd);
+
+ /* Definitions of copy subroutines */
+ fd = fopen("group_copy_routines.inc", "w");
+ group_ptr = groups;
+ while (group_ptr) {
+ fortprintf(fd, " subroutine copy_%s(dest, src)</font>
<font color="blue">", group_ptr->name);
+ fortprintf(fd, "</font>
<font color="blue">");
+ fortprintf(fd, " implicit none</font>
<font color="blue">");
+ fortprintf(fd, "</font>
<font color="blue">");
+ fortprintf(fd, " type (%s_type), intent(in) :: src</font>
<font color="blue">", group_ptr->name);
+ fortprintf(fd, " type (%s_type), intent(inout) :: dest</font>
<font color="blue">", group_ptr->name);
+ fortprintf(fd, "</font>
<font color="blue">");
+ var_list_ptr = group_ptr->vlist;
+ while (var_list_ptr) {
+ var_ptr = var_list_ptr->var;
+ if (strncmp(var_ptr->super_array, "-", 1024) != 0) {
+ memcpy(super_array, var_ptr->super_array, 1024);
+ memcpy(array_class, var_ptr->array_class, 1024);
+ i = 0;
+ while (var_list_ptr && strncmp(super_array, var_list_ptr->var->super_array, 1024) == 0) {
+ i++;
+ var_list_ptr2 = var_list_ptr;
+ var_list_ptr = var_list_ptr->next;
+ }
+ var_ptr2 = var_list_ptr2->var;
+ if (var_ptr2->ndims > 0)
+ fortprintf(fd, " dest %% %s %% array = src %% %s %% array</font>
<font color="blue">", var_ptr2->super_array, var_ptr2->super_array);
+ else
+ fortprintf(fd, " dest %% %s %% scalar = src %% %s %% scalar</font>
<font color="blue">", var_ptr2->super_array, var_ptr2->super_array);
+ }
+ else {
+ if (var_ptr->ndims > 0)
+ fortprintf(fd, " dest %% %s %% array = src %% %s %% array</font>
<font color="blue">", var_ptr->name_in_code, var_ptr->name_in_code);
+ else
+ fortprintf(fd, " dest %% %s %% scalar = src %% %s %% scalar</font>
<font color="blue">", var_ptr->name_in_code, var_ptr->name_in_code);
+ var_list_ptr = var_list_ptr->next;
+ }
+ }
+ fortprintf(fd, "</font>
<font color="blue">");
+ fortprintf(fd, " end subroutine copy_%s</font>
<font color="black"></font>
<font color="black"></font>
<font color="blue">", group_ptr->name);
+ group_ptr = group_ptr->next;
+ }
+ fclose(fd);
+
+ /* Definitions of shift_time_level subroutines */
+ fd = fopen("group_shift_level_routines.inc", "w");
+ group_ptr = groups;
+ while (group_ptr) {
+ if (group_ptr->vlist->var->ntime_levs > 1) {
+ fortprintf(fd, " subroutine shift_time_levels_%s(%s)</font>
<font color="blue">", group_ptr->name, group_ptr->name);
+ fortprintf(fd, "</font>
<font color="blue">");
+ fortprintf(fd, " implicit none</font>
<font color="blue">");
+ fortprintf(fd, "</font>
<font color="blue">");
+ fortprintf(fd, " type (%s_multilevel_type), intent(inout) :: %s</font>
<font color="blue">", group_ptr->name, group_ptr->name);
+ fortprintf(fd, "</font>
<font color="blue">");
+ fortprintf(fd, " integer :: i</font>
<font color="blue">");
+ fortprintf(fd, " type (%s_type), pointer :: sptr</font>
<font color="blue">", group_ptr->name);
+ fortprintf(fd, "</font>
<font color="blue">");
+ fortprintf(fd, " sptr => %s %% time_levs(1) %% %s</font>
<font color="blue">", group_ptr->name, group_ptr->name);
+ fortprintf(fd, " do i=1,%s %% nTimeLevels-1</font>
<font color="blue">", group_ptr->name);
+ fortprintf(fd, " %s %% time_levs(i) %% %s => %s %% time_levs(i+1) %% %s</font>
<font color="blue">", group_ptr->name, group_ptr->name, group_ptr->name, group_ptr->name);
+ fortprintf(fd, " end do</font>
<font color="blue">");
+ fortprintf(fd, " %s %% time_levs(%s %% nTimeLevels) %% %s => sptr</font>
<font color="blue">", group_ptr->name, group_ptr->name, group_ptr->name);
+ fortprintf(fd, "</font>
<font color="blue">");
+ fortprintf(fd, " end subroutine shift_time_levels_%s</font>
<font color="black"></font>
<font color="black"></font>
<font color="blue">", group_ptr->name);
+ }
+ group_ptr = group_ptr->next;
+ }
+ fclose(fd);
+
+}
+
+
+void gen_reads(struct group_list * groups, struct variable * vars, struct dimension * dims)
+{
+ struct variable * var_ptr;
+ struct variable_list * var_list_ptr;
+ struct dimension * dim_ptr;
+ struct dimension_list * dimlist_ptr, * lastdim;
+ struct group_list * group_ptr;
+ struct dtable * dictionary;
+ FILE * fd;
+ char vtype[5];
+ char fname[32];
+ char struct_deref[1024];
+ char * cp1, * cp2;
+ int i, j;
+ int ivtype;
+
+
+ /*
+ * Generate declarations of IDs belonging in io_input_object
+ */
+ fd = fopen("io_input_obj_decls.inc", "w");
+
+ fortprintf(fd, " integer :: rdDimIDTime</font>
<font color="blue">");
+ dim_ptr = dims;
+ while (dim_ptr) {
+ if (dim_ptr->constant_value < 0 && !dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, " integer :: rdDimID%s</font>
<font color="blue">", dim_ptr->name_in_file);
+ dim_ptr = dim_ptr->next;
+ }
+ fortprintf(fd, "</font>
<font color="blue">");
+
+ fortprintf(fd, " integer :: rdLocalTime</font>
<font color="blue">");
+ dim_ptr = dims;
+ while (dim_ptr) {
+ if (dim_ptr->constant_value < 0 && !dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, " integer :: rdLocal%s</font>
<font color="blue">", dim_ptr->name_in_file);
+ dim_ptr = dim_ptr->next;
+ }
+ fortprintf(fd, "</font>
<font color="blue">");
+
+ var_ptr = vars;
+ while (var_ptr) {
+ fortprintf(fd, " integer :: rdVarID%s</font>
<font color="blue">", var_ptr->name_in_file);
+ var_ptr = var_ptr->next;
+ }
+
+ fclose(fd);
+
+
+ /*
+ * Generate read and distribute code
+ */
+ fd = fopen("io_input_fields.inc", "w");
+
+ group_ptr = groups;
+ while (group_ptr) {
+ var_list_ptr = group_ptr->vlist;
+ while (var_list_ptr) {
+ var_ptr = var_list_ptr->var;
+
+ if (group_ptr->vlist->var->ntime_levs > 1)
+ snprintf(struct_deref, 1024, "block %% %s %% time_levs(1) %% %s", group_ptr->name, group_ptr->name);
+ else
+ snprintf(struct_deref, 1024, "block %% %s", group_ptr->name);
+
+ i = 1;
+ dimlist_ptr = var_ptr->dimlist;
+ if (var_ptr->vtype == INTEGER) sprintf(vtype, "int");
+ else if (var_ptr->vtype == REAL) sprintf(vtype, "real");
+
+ if (strncmp(var_ptr->super_array, "-", 1024) != 0) {
+ fortprintf(fd, " if ((%s %% %s %% ioinfo %% input .and. .not. config_do_restart) .or. &</font>
<font color="blue">", struct_deref, var_ptr->super_array);
+ fortprintf(fd, " (%s %% %s %% ioinfo %% restart .and. config_do_restart)) then</font>
<font color="blue">", struct_deref, var_ptr->super_array);
+ }
+ else {
+ fortprintf(fd, " if ((%s %% %s %% ioinfo %% input .and. .not. config_do_restart) .or. &</font>
<font color="blue">", struct_deref, var_ptr->name_in_code);
+ fortprintf(fd, " (%s %% %s %% ioinfo %% restart .and. config_do_restart)) then</font>
<font color="blue">", struct_deref, var_ptr->name_in_code);
+ }
+ while (dimlist_ptr) {
+ if (i < var_ptr->ndims) {
+ fortprintf(fd, " %s%id %% ioinfo %% start(%i) = 1</font>
<font color="blue">", vtype, var_ptr->ndims, i);
+ if (dimlist_ptr->dim->constant_value < 0)
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, " %s%id %% ioinfo %% count(%i) = block %% mesh %% %s</font>
<font color="blue">", vtype, var_ptr->ndims, i, dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, " %s%id %% ioinfo %% count(%i) = block %% mesh %% %s</font>
<font color="blue">", vtype, var_ptr->ndims, i, dimlist_ptr->dim->name_in_file);
+ else
+ fortprintf(fd, " %s%id %% ioinfo %% count(%i) = %s</font>
<font color="blue">", vtype, var_ptr->ndims, i, dimlist_ptr->dim->name_in_code);
+ }
+ else {
+ if (is_derived_dim(dimlist_ptr->dim->name_in_code)) {
+ split_derived_dim_string(dimlist_ptr->dim->name_in_code, &cp1, &cp2);
+ fortprintf(fd, " %s%id %% ioinfo %% start(%i) = read%sStart</font>
<font color="blue">", vtype, var_ptr->ndims, i, cp1);
+ fortprintf(fd, " %s%id %% ioinfo %% count(%i) = read%sCount%s</font>
<font color="blue">", vtype, var_ptr->ndims, i, cp1, cp2);
+ free(cp1);
+ free(cp2);
+ }
+ else {
+ if (dimlist_ptr->dim->namelist_defined) {
+ fortprintf(fd, " %s%id %% ioinfo %% start(%i) = read%sStart</font>
<font color="blue">", vtype, var_ptr->ndims, i, dimlist_ptr->dim->name_in_file+1);
+ fortprintf(fd, " %s%id %% ioinfo %% count(%i) = read%sCount</font>
<font color="blue">", vtype, var_ptr->ndims, i, dimlist_ptr->dim->name_in_file+1);
+ }
+ else {
+ fortprintf(fd, " %s%id %% ioinfo %% start(%i) = read%sStart</font>
<font color="blue">", vtype, var_ptr->ndims, i, dimlist_ptr->dim->name_in_code+1);
+ fortprintf(fd, " %s%id %% ioinfo %% count(%i) = read%sCount</font>
<font color="blue">", vtype, var_ptr->ndims, i, dimlist_ptr->dim->name_in_code+1);
+ }
+ }
+ }
+ dimlist_ptr = dimlist_ptr->next;
+ i++;
+ }
+
+ if (var_ptr->ndims > 0) {
+ fortprintf(fd, " allocate(%s%id %% array(", vtype, var_ptr->ndims);
+ i = 1;
+ dimlist_ptr = var_ptr->dimlist;
+
+ if (i < var_ptr->ndims) {
+ if (dimlist_ptr->dim->constant_value < 0)
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, "block %% mesh %% %s", dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, "block %% mesh %% %s", dimlist_ptr->dim->name_in_file);
+ else
+ fortprintf(fd, "%s", dimlist_ptr->dim->name_in_code);
+ }
+ else {
+ if (is_derived_dim(dimlist_ptr->dim->name_in_code)) {
+ split_derived_dim_string(dimlist_ptr->dim->name_in_code, &cp1, &cp2);
+ fortprintf(fd, "read%sCount%s", cp1, cp2);
+ free(cp1);
+ free(cp2);
+ }
+ else
+ if (dimlist_ptr->dim->namelist_defined) fortprintf(fd, "read%sCount", dimlist_ptr->dim->name_in_file+1);
+ else fortprintf(fd, "read%sCount", dimlist_ptr->dim->name_in_code+1);
+ }
+
+ dimlist_ptr = dimlist_ptr->next;
+ i++;
+ while (dimlist_ptr) {
+ if (i < var_ptr->ndims) {
+ if (dimlist_ptr->dim->constant_value < 0)
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, ", block %% mesh %% %s", dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, ", block %% mesh %% %s", dimlist_ptr->dim->name_in_file);
+ else
+ fortprintf(fd, ", %s", dimlist_ptr->dim->name_in_code);
+ }
+ else {
+ if (is_derived_dim(dimlist_ptr->dim->name_in_code)) {
+ split_derived_dim_string(dimlist_ptr->dim->name_in_code, &cp1, &cp2);
+ fortprintf(fd, ", read%sCount%s", cp1, cp2);
+ free(cp1);
+ free(cp2);
+ }
+ else
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, ", read%sCount", dimlist_ptr->dim->name_in_code+1);
+ else fortprintf(fd, ", read%sCount", dimlist_ptr->dim->name_in_file+1);
+ }
+ dimlist_ptr = dimlist_ptr->next;
+ i++;
+ }
+ fortprintf(fd, "))</font>
<font color="black"></font>
<font color="blue">");
+
+ if (strncmp(var_ptr->super_array, "-", 1024) != 0) {
+ fortprintf(fd, " allocate(super_%s%id(", vtype, var_ptr->ndims);
+ i = 1;
+ dimlist_ptr = var_ptr->dimlist;
+
+ if (i < var_ptr->ndims) {
+ if (dimlist_ptr->dim->constant_value < 0)
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, "block %% mesh %% %s", dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, "block %% mesh %% %s", dimlist_ptr->dim->name_in_file);
+ else
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, "%s", dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, "%s", dimlist_ptr->dim->name_in_file);
+ }
+ dimlist_ptr = dimlist_ptr->next;
+ i++;
+ while (dimlist_ptr) {
+ if (dimlist_ptr->dim->constant_value < 0)
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, ", block %% mesh %% %s", dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, ", block %% mesh %% %s", dimlist_ptr->dim->name_in_file);
+ else
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, ", %s", dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, ", %s", dimlist_ptr->dim->name_in_file);
+
+ dimlist_ptr = dimlist_ptr->next;
+ i++;
+ }
+ fortprintf(fd, "))</font>
<font color="black"></font>
<font color="blue">");
+ }
+ }
+
+ fortprintf(fd, " %s%id %% ioinfo %% fieldName = \'%s\'</font>
<font color="blue">", vtype, var_ptr->ndims, var_ptr->name_in_file);
+ if (var_ptr->timedim)
+ fortprintf(fd, " call io_input_field_time(input_obj, %s%id)</font>
<font color="blue">", vtype, var_ptr->ndims);
+ else
+ fortprintf(fd, " call io_input_field(input_obj, %s%id)</font>
<font color="blue">", vtype, var_ptr->ndims);
+
+ if (var_ptr->ndims > 0) {
+ fortprintf(fd, " call dmpar_alltoall_field(dminfo, &</font>
<font color="blue">");
+ if (strncmp(var_ptr->super_array, "-", 1024) != 0)
+ fortprintf(fd, " %s%id %% array, super_%s%id, &</font>
<font color="blue">", vtype, var_ptr->ndims, vtype, var_ptr->ndims);
+ else
+ fortprintf(fd, " %s%id %% array, %s %% %s %% array, &</font>
<font color="blue">", vtype, var_ptr->ndims, struct_deref, var_ptr->name_in_code);
+
+ i = 1;
+ dimlist_ptr = var_ptr->dimlist;
+
+ if (i < var_ptr->ndims)
+ if (dimlist_ptr->dim->constant_value < 0)
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, " block %% mesh %% %s", dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, " block %% mesh %% %s", dimlist_ptr->dim->name_in_file);
+ else
+ fortprintf(fd, " %s", dimlist_ptr->dim->name_in_code);
+ else {
+ lastdim = dimlist_ptr;
+ if (is_derived_dim(dimlist_ptr->dim->name_in_code)) {
+ split_derived_dim_string(dimlist_ptr->dim->name_in_code, &cp1, &cp2);
+ fortprintf(fd, " read%sCount%s", cp1, cp2);
+ free(cp1);
+ free(cp2);
+ }
+ else
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, " read%sCount", dimlist_ptr->dim->name_in_code+1);
+ else fortprintf(fd, " read%sCount", dimlist_ptr->dim->name_in_file+1);
+ }
+
+ dimlist_ptr = dimlist_ptr->next;
+ i++;
+ while (dimlist_ptr) {
+ if (i < var_ptr->ndims)
+ if (dimlist_ptr->dim->constant_value < 0)
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, ", block %% mesh %% %s", dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, ", block %% mesh %% %s", dimlist_ptr->dim->name_in_file);
+ else
+ fortprintf(fd, ", %s", dimlist_ptr->dim->name_in_code);
+ else {
+ lastdim = dimlist_ptr;
+ if (is_derived_dim(dimlist_ptr->dim->name_in_code)) {
+ split_derived_dim_string(dimlist_ptr->dim->name_in_code, &cp1, &cp2);
+ fortprintf(fd, ", read%sCount%s", cp1, cp2);
+ free(cp1);
+ free(cp2);
+ }
+ else
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, ", read%sCount", dimlist_ptr->dim->name_in_code+1);
+ else fortprintf(fd, ", read%sCount", dimlist_ptr->dim->name_in_file+1);
+ }
+ dimlist_ptr = dimlist_ptr->next;
+ i++;
+ }
+ if (!lastdim->dim->namelist_defined) fortprintf(fd, ", block %% mesh %% %s, &</font>
<font color="blue">", lastdim->dim->name_in_code);
+ else fortprintf(fd, ", block %% mesh %% %s, &</font>
<font color="blue">", lastdim->dim->name_in_file);
+
+ if (is_derived_dim(lastdim->dim->name_in_code))
+ fortprintf(fd, " send%sList, recv%sList)</font>
<font color="blue">", lastdim->dim->name_in_file+1, lastdim->dim->name_in_file+1);
+ else
+ if (lastdim->dim->namelist_defined)
+ fortprintf(fd, " send%sList, recv%sList)</font>
<font color="blue">", lastdim->dim->name_in_file+1, lastdim->dim->name_in_file+1);
+ else
+ fortprintf(fd, " send%sList, recv%sList)</font>
<font color="blue">", lastdim->dim->name_in_code+1, lastdim->dim->name_in_code+1);
+
+
+ /* Copy from super_ array to field */
+ if (strncmp(var_ptr->super_array, "-", 1024) != 0) {
+ i = 1;
+ dimlist_ptr = var_ptr->dimlist;
+ while (i <= var_ptr->ndims) {
+ if (dimlist_ptr->dim->constant_value < 0)
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, " do i%i=1,block %% mesh %% %s</font>
<font color="blue">", i, dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, " do i%i=1,block %% mesh %% %s</font>
<font color="blue">", i, dimlist_ptr->dim->name_in_file);
+ else
+ fortprintf(fd, " do i%i=1,%s</font>
<font color="blue">", i, dimlist_ptr->dim->name_in_code);
+
+ i++;
+ dimlist_ptr = dimlist_ptr->next;
+ }
+
+ fortprintf(fd, " %s %% %s %% array(%s %% index_%s,", struct_deref, var_ptr->super_array, struct_deref, var_ptr->name_in_code);
+
+ for(i=1; i<=var_ptr->ndims; i++) {
+ fortprintf(fd, "i%i",i);
+ if (i < var_ptr->ndims) fortprintf(fd, ",");
+ }
+ fortprintf(fd, ") = super_%s%id(", vtype, var_ptr->ndims);
+ for(i=1; i<=var_ptr->ndims; i++) {
+ fortprintf(fd, "i%i",i);
+ if (i < var_ptr->ndims) fortprintf(fd, ",");
+ }
+ fortprintf(fd, ")</font>
<font color="blue">");
+
+ i = 1;
+ while (i <= var_ptr->ndims) {
+ fortprintf(fd, " end do</font>
<font color="blue">");
+ i++;
+ }
+ }
+
+ fortprintf(fd, " deallocate(%s%id %% array)</font>
<font color="blue">", vtype, var_ptr->ndims);
+ if (strncmp(var_ptr->super_array, "-", 1024) != 0)
+ fortprintf(fd, " deallocate(super_%s%id)</font>
<font color="blue">", vtype, var_ptr->ndims);
+ }
+ else {
+ fortprintf(fd, " %s %% %s %% scalar = %s%id %% scalar</font>
<font color="blue">", struct_deref, var_ptr->name_in_code, vtype, var_ptr->ndims);
+ }
+
+ fortprintf(fd, " end if</font>
<font color="black"></font>
<font color="blue">");
+
+ var_list_ptr = var_list_ptr->next;
+ }
+ group_ptr = group_ptr->next;
+ }
+
+ fclose(fd);
+
+
+ /*
+ * Generate NetCDF reads of dimension and variable IDs
+ */
+ fd = fopen("netcdf_read_ids.inc", "w");
+
+ fortprintf(fd, " nferr = nf_inq_unlimdim(input_obj %% rd_ncid, input_obj %% rdDimIDTime)</font>
<font color="blue">");
+ fortprintf(fd, " nferr = nf_inq_dimlen(input_obj %% rd_ncid, input_obj %% rdDimIDTime, input_obj %% rdLocalTime)</font>
<font color="blue">");
+ dim_ptr = dims;
+ while (dim_ptr) {
+ if (dim_ptr->constant_value < 0 && !dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) {
+ fortprintf(fd, " nferr = nf_inq_dimid(input_obj %% rd_ncid, \'%s\', input_obj %% rdDimID%s)</font>
<font color="blue">", dim_ptr->name_in_file, dim_ptr->name_in_file);
+ fortprintf(fd, " nferr = nf_inq_dimlen(input_obj %% rd_ncid, input_obj %% rdDimID%s, input_obj %% rdLocal%s)</font>
<font color="blue">", dim_ptr->name_in_file, dim_ptr->name_in_file);
+ }
+ dim_ptr = dim_ptr->next;
+ }
+ fortprintf(fd, "</font>
<font color="blue">");
+
+ var_ptr = vars;
+ while (var_ptr) {
+ fortprintf(fd, " nferr = nf_inq_varid(input_obj %% rd_ncid, \'%s\', input_obj %% rdVarID%s)</font>
<font color="blue">", var_ptr->name_in_file, var_ptr->name_in_file);
+ var_ptr = var_ptr->next;
+ }
+
+ fclose(fd);
+
+
+ /*
+ * Generate code to return dimension given its name
+ */
+ fd = fopen("get_dimension_by_name.inc", "w");
+
+ dim_ptr = dims;
+ while (dim_ptr->constant_value >= 0 || is_derived_dim(dim_ptr->name_in_code)) dim_ptr = dim_ptr->next;
+ if (!dim_ptr->namelist_defined) {
+ fortprintf(fd, " if (trim(dimname) == \'%s\') then</font>
<font color="blue">", dim_ptr->name_in_code);
+ fortprintf(fd, " dimsize = input_obj %% rdLocal%s</font>
<font color="blue">", dim_ptr->name_in_file);
+ }
+ else {
+ fortprintf(fd, " if (trim(dimname) == \'%s\') then</font>
<font color="blue">", dim_ptr->name_in_file);
+ fortprintf(fd, " dimsize = %s</font>
<font color="blue">", dim_ptr->name_in_code);
+ }
+ dim_ptr = dim_ptr->next;
+ while (dim_ptr) {
+ if (dim_ptr->constant_value < 0 && !is_derived_dim(dim_ptr->name_in_code)) {
+ if (!dim_ptr->namelist_defined) {
+ fortprintf(fd, " else if (trim(dimname) == \'%s\') then</font>
<font color="blue">", dim_ptr->name_in_code);
+ fortprintf(fd, " dimsize = input_obj %% rdLocal%s</font>
<font color="blue">", dim_ptr->name_in_file);
+ }
+ else {
+ fortprintf(fd, " else if (trim(dimname) == \'%s\') then</font>
<font color="blue">", dim_ptr->name_in_file);
+ fortprintf(fd, " dimsize = %s</font>
<font color="blue">", dim_ptr->name_in_code);
+ }
+ }
+ dim_ptr = dim_ptr->next;
+ }
+ fortprintf(fd, " end if</font>
<font color="blue">");
+
+ fclose(fd);
+
+
+ /*
+ * Generate code to read 0d, 1d, 2d, 3d time-invariant fields
+ */
+ for(j=0; j<2; j++) {
+ for(i=0; i<=3; i++) {
+ if (j == 0) {
+ sprintf(fname, "input_field%idinteger.inc", i);
+ ivtype = INTEGER;
+ }
+ else {
+ sprintf(fname, "input_field%idreal.inc", i);
+ ivtype = REAL;
+ }
+ fd = fopen(fname, "w");
+
+ var_ptr = vars;
+ while (var_ptr && (var_ptr->ndims != i || var_ptr->vtype != ivtype || var_ptr->timedim)) var_ptr = var_ptr->next;
+ if (var_ptr) {
+ fortprintf(fd, " if (trim(field %% ioinfo %% fieldName) == \'%s\') then</font>
<font color="blue">", var_ptr->name_in_file);
+ fortprintf(fd, " varID = input_obj %% rdVarID%s</font>
<font color="blue">", var_ptr->name_in_file);
+ var_ptr = var_ptr->next;
+ while (var_ptr) {
+ if (var_ptr->ndims == i && var_ptr->vtype == ivtype && !var_ptr->timedim) {
+ fortprintf(fd, " else if (trim(field %% ioinfo %% fieldName) == \'%s\') then</font>
<font color="blue">", var_ptr->name_in_file);
+ fortprintf(fd, " varID = input_obj %% rdVarID%s</font>
<font color="blue">", var_ptr->name_in_file);
+ }
+ var_ptr = var_ptr->next;
+ }
+ fortprintf(fd, " end if</font>
<font color="blue">");
+ }
+
+ fclose(fd);
+ }
+ }
+
+
+ /*
+ * Generate code to read 0d, 1d, 2d, 3d time-varying real fields
+ */
+ for(i=0; i<=3; i++) {
+ sprintf(fname, "input_field%idreal_time.inc", i);
+ fd = fopen(fname, "w");
+
+ var_ptr = vars;
+ while (var_ptr && (var_ptr->ndims != i || var_ptr->vtype != REAL || !var_ptr->timedim)) var_ptr = var_ptr->next;
+ if (var_ptr) {
+ fortprintf(fd, " if (trim(field %% ioinfo %% fieldName) == \'%s\') then</font>
<font color="blue">", var_ptr->name_in_file);
+ fortprintf(fd, " varID = input_obj %% rdVarID%s</font>
<font color="blue">", var_ptr->name_in_file);
+ var_ptr = var_ptr->next;
+ while (var_ptr) {
+ if (var_ptr->ndims == i && var_ptr->vtype == REAL && var_ptr->timedim) {
+ fortprintf(fd, " else if (trim(field %% ioinfo %% fieldName) == \'%s\') then</font>
<font color="blue">", var_ptr->name_in_file);
+ fortprintf(fd, " varID = input_obj %% rdVarID%s</font>
<font color="blue">", var_ptr->name_in_file);
+ }
+ var_ptr = var_ptr->next;
+ }
+ fortprintf(fd, " end if</font>
<font color="blue">");
+ }
+
+ fclose(fd);
+ }
+
+}
+
+
+void gen_writes(struct group_list * groups, struct variable * vars, struct dimension * dims, struct namelist * namelists)
+{
+ struct variable * var_ptr;
+ struct variable_list * var_list_ptr;
+ struct dimension * dim_ptr;
+ struct dimension_list * dimlist_ptr, * lastdim;
+ struct group_list * group_ptr;
+ struct dtable * dictionary;
+ struct namelist * nl;
+ FILE * fd;
+ char vtype[5];
+ char fname[32];
+ char struct_deref[1024];
+ char * cp1, * cp2;
+ int i, j;
+ int ivtype;
+
+
+ /*
+ * Generate declarations of IDs belonging in io_output_object
+ */
+ fd = fopen("io_output_obj_decls.inc", "w");
+
+ fortprintf(fd, " integer :: wrDimIDTime</font>
<font color="blue">");
+ dim_ptr = dims;
+ while (dim_ptr) {
+ fortprintf(fd, " integer :: wrDimID%s</font>
<font color="blue">", dim_ptr->name_in_file);
+ dim_ptr = dim_ptr->next;
+ }
+ fortprintf(fd, "</font>
<font color="blue">");
+
+ var_ptr = vars;
+ while (var_ptr) {
+ fortprintf(fd, " integer :: wrVarID%s</font>
<font color="blue">", var_ptr->name_in_file);
+ var_ptr = var_ptr->next;
+ }
+
+ fclose(fd);
+
+
+ /*
+ * Generate declarations of temporary dimension variables used for arguments
+ */
+ fd = fopen("output_dim_actual_decls.inc", "w");
+
+ dim_ptr = dims;
+ while (dim_ptr) {
+ if (dim_ptr->constant_value < 0 && !dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, " integer :: %sGlobal</font>
<font color="blue">", dim_ptr->name_in_code);
+ if (dim_ptr->constant_value < 0 && dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, " integer :: %sGlobal</font>
<font color="blue">", dim_ptr->name_in_file);
+ dim_ptr = dim_ptr->next;
+ }
+ fortprintf(fd, "</font>
<font color="blue">");
+
+ fclose(fd);
+
+
+ /*
+ * Generate initialization of temporary dimension variables used for arguments
+ */
+ fd = fopen("output_dim_inits.inc", "w");
+
+ dim_ptr = dims;
+ while (dim_ptr) {
+ if (dim_ptr->constant_value < 0 && !dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, " %sGlobal = block_ptr %% mesh %% %s</font>
<font color="blue">", dim_ptr->name_in_code, dim_ptr->name_in_code);
+ if (dim_ptr->constant_value < 0 && dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, " %sGlobal = block_ptr %% mesh %% %s</font>
<font color="blue">", dim_ptr->name_in_file, dim_ptr->name_in_file);
+ dim_ptr = dim_ptr->next;
+ }
+ fortprintf(fd, "</font>
<font color="blue">");
+
+ fclose(fd);
+
+
+ /*
+ * Generate actual dimension argument list
+ */
+ fd = fopen("output_dim_actual_args.inc", "w");
+ dim_ptr = dims;
+ if (dim_ptr && dim_ptr->constant_value < 0 && !is_derived_dim(dim_ptr->name_in_code)) {
+ if (!dim_ptr->namelist_defined) fortprintf(fd, " %sGlobal", dim_ptr->name_in_code);
+ else fortprintf(fd, " %sGlobal", dim_ptr->name_in_file);
+ dim_ptr = dim_ptr->next;
+ }
+ while (dim_ptr) {
+ if (dim_ptr->constant_value < 0 && !dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, ", %sGlobal", dim_ptr->name_in_code);
+ if (dim_ptr->constant_value < 0 && dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, ", %sGlobal", dim_ptr->name_in_file);
+ dim_ptr = dim_ptr->next;
+ }
+ fortprintf(fd, " &</font>
<font color="blue">");
+
+ fclose(fd);
+
+
+ /*
+ * Generate NetCDF calls to define dimensions, variables, and global attributes
+ */
+ fd = fopen("netcdf_def_dims_vars.inc", "w");
+
+ fortprintf(fd, " nferr = nf_def_dim(output_obj %% wr_ncid, \'Time\', NF_UNLIMITED, output_obj %% wrDimIDTime)</font>
<font color="blue">");
+ dim_ptr = dims;
+ while (dim_ptr) {
+ fortprintf(fd, " nferr = nf_def_dim(output_obj %% wr_ncid, \'%s\', %s, output_obj %% wrDimID%s)</font>
<font color="blue">", dim_ptr->name_in_file, dim_ptr->name_in_code, dim_ptr->name_in_file);
+ dim_ptr = dim_ptr->next;
+ }
+ fortprintf(fd, "</font>
<font color="blue">");
+
+ var_ptr = vars;
+ while (var_ptr) {
+ fortprintf(fd, " if (.false. &</font>
<font color="blue">");
+ if (var_ptr->iostreams & RESTART0) fortprintf(fd, " .or. output_obj %% stream == RESTART &</font>
<font color="blue">");
+ if (var_ptr->iostreams & OUTPUT0) fortprintf(fd, " .or. output_obj %% stream == OUTPUT &</font>
<font color="blue">");
+ fortprintf(fd, " ) then</font>
<font color="blue">");
+ dimlist_ptr = var_ptr->dimlist;
+ i = 1;
+ while(dimlist_ptr) {
+ fortprintf(fd, " dimlist(%i) = output_obj %% wrDimID%s</font>
<font color="blue">", i++, dimlist_ptr->dim->name_in_file);
+ dimlist_ptr = dimlist_ptr->next;
+ }
+ if (var_ptr->timedim) fortprintf(fd, " dimlist(%i) = output_obj %% wrDimIDTime</font>
<font color="blue">", i++);
+ if (var_ptr->vtype == INTEGER)
+ fortprintf(fd, " nferr = nf_def_var(output_obj %% wr_ncid, \'%s\', NF_INT, %i, dimlist, output_obj %% wrVarID%s)</font>
<font color="blue">", var_ptr->name_in_file, var_ptr->ndims + var_ptr->timedim, var_ptr->name_in_file);
+ else if (var_ptr->vtype == REAL)
+ fortprintf(fd, " nferr = nf_def_var(output_obj %% wr_ncid, \'%s\', NF_DOUBLE, %i, dimlist, output_obj %% wrVarID%s)</font>
<font color="blue">", var_ptr->name_in_file, var_ptr->ndims + var_ptr->timedim, var_ptr->name_in_file);
+
+ fortprintf(fd, " end if</font>
<font color="black"></font>
<font color="blue">");
+
+ var_ptr = var_ptr->next;
+ }
+
+ nl = namelists;
+ while (nl) {
+ if (nl->vtype == INTEGER)
+ fortprintf(fd, " nferr = nf_put_att_int(output_obj %% wr_ncid, NF_GLOBAL, \'%s\', NF_INT, 1, %s)</font>
<font color="blue">", nl->name, nl->name);
+ else if (nl->vtype == REAL) {
+ fortprintf(fd, " if (RKIND == 8) then</font>
<font color="blue">", nl->name);
+ fortprintf(fd, " nferr = nf_put_att_double(output_obj %% wr_ncid, NF_GLOBAL, \'%s\', NF_DOUBLE, 1, %s)</font>
<font color="blue">", nl->name, nl->name);
+ fortprintf(fd, " else if (RKIND == 4) then</font>
<font color="blue">", nl->name);
+ fortprintf(fd, " nferr = nf_put_att_real(output_obj %% wr_ncid, NF_GLOBAL, \'%s\', NF_FLOAT, 1, %s)</font>
<font color="blue">", nl->name, nl->name);
+ fortprintf(fd, " end if</font>
<font color="blue">");
+ }
+ else if (nl->vtype == CHARACTER)
+ fortprintf(fd, " nferr = nf_put_att_text(output_obj %% wr_ncid, NF_GLOBAL, \'%s\', len_trim(%s), trim(%s))</font>
<font color="blue">", nl->name, nl->name, nl->name);
+ else if (nl->vtype == LOGICAL) {
+ fortprintf(fd, " if (%s) then</font>
<font color="blue">", nl->name);
+ fortprintf(fd, " nferr = nf_put_att_text(output_obj %% wr_ncid, NF_GLOBAL, \'%s\', 1, \'T\')</font>
<font color="blue">", nl->name);
+ fortprintf(fd, " else</font>
<font color="blue">");
+ fortprintf(fd, " nferr = nf_put_att_text(output_obj %% wr_ncid, NF_GLOBAL, \'%s\', 1, \'F\')</font>
<font color="blue">", nl->name);
+ fortprintf(fd, " end if</font>
<font color="blue">");
+ }
+ nl = nl->next;
+ }
+
+ fclose(fd);
+
+
+ /*
+ * Generate collect and write code
+ */
+ fd = fopen("io_output_fields.inc", "w");
+
+ group_ptr = groups;
+ while (group_ptr) {
+ var_list_ptr = group_ptr->vlist;
+ while (var_list_ptr) {
+ var_ptr = var_list_ptr->var;
+
+ if (group_ptr->vlist->var->ntime_levs > 1)
+ snprintf(struct_deref, 1024, "domain %% blocklist %% %s %% time_levs(1) %% %s", group_ptr->name, group_ptr->name);
+ else
+ snprintf(struct_deref, 1024, "domain %% blocklist %% %s", group_ptr->name);
+
+ i = 1;
+ dimlist_ptr = var_ptr->dimlist;
+ if (var_ptr->vtype == INTEGER) sprintf(vtype, "int");
+ else if (var_ptr->vtype == REAL) sprintf(vtype, "real");
+
+ if (strncmp(var_ptr->super_array, "-", 1024) != 0) {
+ fortprintf(fd, " if ((%s %% %s %% ioinfo %% output .and. output_obj %% stream == OUTPUT) .or. &</font>
<font color="blue">", struct_deref, var_ptr->super_array);
+ fortprintf(fd, " (%s %% %s %% ioinfo %% restart .and. output_obj %% stream == RESTART)) then</font>
<font color="blue">", struct_deref, var_ptr->super_array);
+ }
+ else {
+ fortprintf(fd, " if ((%s %% %s %% ioinfo %% output .and. output_obj %% stream == OUTPUT) .or. &</font>
<font color="blue">", struct_deref, var_ptr->name_in_code);
+ fortprintf(fd, " (%s %% %s %% ioinfo %% restart .and. output_obj %% stream == RESTART)) then</font>
<font color="blue">", struct_deref, var_ptr->name_in_code);
+ }
+
+ if (var_ptr->ndims > 0) {
+ while (dimlist_ptr) {
+ if (i < var_ptr->ndims) {
+ fortprintf(fd, " %s%id %% ioinfo %% start(%i) = 1</font>
<font color="blue">", vtype, var_ptr->ndims, i);
+ if (dimlist_ptr->dim->constant_value < 0)
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, " %s%id %% ioinfo %% count(%i) = domain %% blocklist %% mesh %% %s</font>
<font color="blue">", vtype, var_ptr->ndims, i, dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, " %s%id %% ioinfo %% count(%i) = domain %% blocklist %% mesh %% %s</font>
<font color="blue">", vtype, var_ptr->ndims, i, dimlist_ptr->dim->name_in_file);
+ else
+ fortprintf(fd, " %s%id %% ioinfo %% count(%i) = %s</font>
<font color="blue">", vtype, var_ptr->ndims, i, dimlist_ptr->dim->name_in_code);
+ }
+ else {
+ fortprintf(fd, " %s%id %% ioinfo %% start(%i) = 1</font>
<font color="blue">", vtype, var_ptr->ndims, i);
+ if (is_derived_dim(dimlist_ptr->dim->name_in_code)) {
+ split_derived_dim_string(dimlist_ptr->dim->name_in_code, &cp1, &cp2);
+ fortprintf(fd, " %s%id %% ioinfo %% count(%i) = n%sGlobal%s</font>
<font color="blue">", vtype, var_ptr->ndims, i, cp1, cp2);
+ free(cp1);
+ free(cp2);
+ }
+ else
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, " %s%id %% ioinfo %% count(%i) = %sGlobal</font>
<font color="blue">", vtype, var_ptr->ndims, i, dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, " %s%id %% ioinfo %% count(%i) = %sGlobal</font>
<font color="blue">", vtype, var_ptr->ndims, i, dimlist_ptr->dim->name_in_file);
+ }
+ dimlist_ptr = dimlist_ptr->next;
+ i++;
+ }
+
+ fortprintf(fd, " allocate(%s%id %% array(", vtype, var_ptr->ndims);
+ i = 1;
+ dimlist_ptr = var_ptr->dimlist;
+
+ if (i < var_ptr->ndims)
+ if (dimlist_ptr->dim->constant_value < 0)
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, "domain %% blocklist %% mesh %% %s", dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, "domain %% blocklist %% mesh %% %s", dimlist_ptr->dim->name_in_file);
+ else
+ fortprintf(fd, "%s", dimlist_ptr->dim->name_in_code);
+ else {
+ if (is_derived_dim(dimlist_ptr->dim->name_in_code)) {
+ split_derived_dim_string(dimlist_ptr->dim->name_in_code, &cp1, &cp2);
+ fortprintf(fd, "n%sGlobal%s", cp1, cp2);
+ free(cp1);
+ free(cp2);
+ }
+ else
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, "%sGlobal", dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, "%sGlobal", dimlist_ptr->dim->name_in_file);
+ lastdim = dimlist_ptr;
+ }
+ dimlist_ptr = dimlist_ptr->next;
+ i++;
+ while (dimlist_ptr) {
+ if (i < var_ptr->ndims)
+ if (dimlist_ptr->dim->constant_value < 0)
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, ", domain %% blocklist %% mesh %% %s", dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, ", domain %% blocklist %% mesh %% %s", dimlist_ptr->dim->name_in_file);
+ else
+ fortprintf(fd, ", %s", dimlist_ptr->dim->name_in_code);
+ else {
+ if (is_derived_dim(dimlist_ptr->dim->name_in_code)) {
+ split_derived_dim_string(dimlist_ptr->dim->name_in_code, &cp1, &cp2);
+ fortprintf(fd, ", n%sGlobal%s", cp1, cp2);
+ free(cp1);
+ free(cp2);
+ }
+ else
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, ", %sGlobal", dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, ", %sGlobal", dimlist_ptr->dim->name_in_file);
+ lastdim = dimlist_ptr;
+ }
+ dimlist_ptr = dimlist_ptr->next;
+ i++;
+ }
+ fortprintf(fd, "))</font>
<font color="black"></font>
<font color="blue">");
+
+ if (strncmp(var_ptr->super_array, "-", 1024) != 0) {
+ if (var_ptr->ndims > 0) {
+ fortprintf(fd, " allocate(super_%s%id(", vtype, var_ptr->ndims);
+ i = 1;
+ dimlist_ptr = var_ptr->dimlist;
+ while (dimlist_ptr) {
+ if (dimlist_ptr->dim->constant_value < 0)
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, "domain %% blocklist %% mesh %% %s", dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, "domain %% blocklist %% mesh %% %s", dimlist_ptr->dim->name_in_file);
+ else
+ fortprintf(fd, "%s", dimlist_ptr->dim->name_in_code);
+
+ if (i < var_ptr->ndims) fortprintf(fd, ", ");
+
+ dimlist_ptr = dimlist_ptr->next;
+ i++;
+ }
+ fortprintf(fd, "))</font>
<font color="black"></font>
<font color="blue">");
+ }
+
+ /* Copy from field to super_ array */
+ i = 1;
+ dimlist_ptr = var_ptr->dimlist;
+ while (i <= var_ptr->ndims) {
+ if (dimlist_ptr->dim->constant_value < 0)
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, " do i%i=1,domain %% blocklist %% mesh %% %s</font>
<font color="blue">", i, dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, " do i%i=1,domain %% blocklist %% mesh %% %s</font>
<font color="blue">", i, dimlist_ptr->dim->name_in_file);
+ else
+ fortprintf(fd, " do i%i=1,%s</font>
<font color="blue">", i, dimlist_ptr->dim->name_in_code);
+
+ i++;
+ dimlist_ptr = dimlist_ptr->next;
+ }
+
+ fortprintf(fd, " super_%s%id(", vtype, var_ptr->ndims);
+ for(i=1; i<=var_ptr->ndims; i++) {
+ fortprintf(fd, "i%i",i);
+ if (i < var_ptr->ndims) fortprintf(fd, ",");
+ }
+ fortprintf(fd, ") = %s %% %s %% array(", struct_deref, var_ptr->super_array);
+ fortprintf(fd, "%s %% index_%s", struct_deref, var_ptr->name_in_code);
+ for(i=1; i<=var_ptr->ndims; i++) {
+ fortprintf(fd, ",i%i",i);
+ }
+ fortprintf(fd, ")</font>
<font color="blue">");
+
+ i = 1;
+ while (i <= var_ptr->ndims) {
+ fortprintf(fd, " end do</font>
<font color="blue">");
+ i++;
+ }
+ }
+
+ fortprintf(fd, " %s%id %% ioinfo %% fieldName = \'%s\'</font>
<font color="blue">", vtype, var_ptr->ndims, var_ptr->name_in_file);
+ fortprintf(fd, " call dmpar_alltoall_field(domain %% dminfo, &</font>
<font color="blue">");
+ if (strncmp(var_ptr->super_array, "-", 1024) != 0)
+ fortprintf(fd, " super_%s%id, %s%id %% array, &</font>
<font color="blue">", vtype, var_ptr->ndims, vtype, var_ptr->ndims);
+ else
+ fortprintf(fd, " %s %% %s %% array, %s%id %% array, &</font>
<font color="blue">", struct_deref, var_ptr->name_in_code, vtype, var_ptr->ndims);
+
+ i = 1;
+ dimlist_ptr = var_ptr->dimlist;
+
+ if (dimlist_ptr->dim->constant_value < 0)
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, " domain %% blocklist %% mesh %% %s", dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, " domain %% blocklist %% mesh %% %s", dimlist_ptr->dim->name_in_file);
+ else
+ fortprintf(fd, " %s", dimlist_ptr->dim->name_in_code);
+
+ dimlist_ptr = dimlist_ptr->next;
+ i++;
+ while (dimlist_ptr) {
+ if (dimlist_ptr->dim->constant_value < 0)
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, ", domain %% blocklist %% mesh %% %s", dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, ", domain %% blocklist %% mesh %% %s", dimlist_ptr->dim->name_in_file);
+ else
+ fortprintf(fd, ", %s", dimlist_ptr->dim->name_in_code);
+
+ dimlist_ptr = dimlist_ptr->next;
+ i++;
+ }
+
+ if (is_derived_dim(lastdim->dim->name_in_code)) {
+ split_derived_dim_string(lastdim->dim->name_in_code, &cp1, &cp2);
+ fortprintf(fd, ", n%sGlobal%s, &</font>
<font color="blue">", cp1, cp2);
+ fortprintf(fd, " output_obj %% send%sList, output_obj %% recv%sList)</font>
<font color="blue">", lastdim->dim->name_in_file+1, lastdim->dim->name_in_file+1);
+ free(cp1);
+ free(cp2);
+ }
+ else {
+ if (!lastdim->dim->namelist_defined) {
+ fortprintf(fd, ", %sGlobal, &</font>
<font color="blue">", lastdim->dim->name_in_code);
+ fortprintf(fd, " output_obj %% send%sList, output_obj %% recv%sList)</font>
<font color="blue">", lastdim->dim->name_in_code+1, lastdim->dim->name_in_code+1);
+ }
+ else {
+ fortprintf(fd, ", %sGlobal, &</font>
<font color="blue">", lastdim->dim->name_in_file);
+ fortprintf(fd, " output_obj %% send%sList, output_obj %% recv%sList)</font>
<font color="blue">", lastdim->dim->name_in_file+1, lastdim->dim->name_in_file+1);
+ }
+ }
+ }
+ else {
+ fortprintf(fd, " %s%id %% ioinfo %% fieldName = \'%s\'</font>
<font color="blue">", vtype, var_ptr->ndims, var_ptr->name_in_file);
+ fortprintf(fd, " %s%id %% scalar = %s %% %s %% scalar</font>
<font color="blue">", vtype, var_ptr->ndims, struct_deref, var_ptr->name_in_code);
+ }
+
+ if (var_ptr->timedim)
+ fortprintf(fd, " if (domain %% dminfo %% my_proc_id == IO_NODE) call io_output_field_time(output_obj, %s%id)</font>
<font color="blue">", vtype, var_ptr->ndims);
+ else
+ fortprintf(fd, " if (domain %% dminfo %% my_proc_id == IO_NODE) call io_output_field(output_obj, %s%id)</font>
<font color="blue">", vtype, var_ptr->ndims);
+ if (var_ptr->ndims > 0) {
+ fortprintf(fd, " deallocate(%s%id %% array)</font>
<font color="blue">", vtype, var_ptr->ndims);
+ if (strncmp(var_ptr->super_array, "-", 1024) != 0)
+ fortprintf(fd, " deallocate(super_%s%id)</font>
<font color="blue">", vtype, var_ptr->ndims);
+ }
+ fortprintf(fd, " end if</font>
<font color="black"></font>
<font color="blue">");
+
+ var_list_ptr = var_list_ptr->next;
+ }
+ group_ptr = group_ptr->next;
+ }
+
+ fclose(fd);
+
+
+ /*
+ * Generate code to write 0d, 1d, 2d, 3d time-invariant fields
+ */
+ for(j=0; j<2; j++) {
+ for(i=0; i<=3; i++) {
+ if (j == 0) {
+ sprintf(fname, "output_field%idinteger.inc", i);
+ ivtype = INTEGER;
+ }
+ else {
+ sprintf(fname, "output_field%idreal.inc", i);
+ ivtype = REAL;
+ }
+ fd = fopen(fname, "w");
+
+ var_ptr = vars;
+ while (var_ptr && (var_ptr->ndims != i || var_ptr->vtype != ivtype || var_ptr->timedim)) var_ptr = var_ptr->next;
+ if (var_ptr) {
+ fortprintf(fd, " if (trim(field %% ioinfo %% fieldName) == \'%s\') then</font>
<font color="blue">", var_ptr->name_in_file);
+ fortprintf(fd, " varID = output_obj %% wrVarID%s</font>
<font color="blue">", var_ptr->name_in_file);
+ var_ptr = var_ptr->next;
+ while (var_ptr) {
+ if (var_ptr->ndims == i && var_ptr->vtype == ivtype && !var_ptr->timedim) {
+ fortprintf(fd, " else if (trim(field %% ioinfo %% fieldName) == \'%s\') then</font>
<font color="blue">", var_ptr->name_in_file);
+ fortprintf(fd, " varID = output_obj %% wrVarID%s</font>
<font color="blue">", var_ptr->name_in_file);
+ }
+ var_ptr = var_ptr->next;
+ }
+ fortprintf(fd, " end if</font>
<font color="blue">");
+ }
+
+ fclose(fd);
+ }
+ }
+
+
+ /*
+ * Generate code to write 0d, 1d, 2d, 3d real time-varying fields
+ */
+ for(i=0; i<=3; i++) {
+ sprintf(fname, "output_field%idreal_time.inc", i);
+ fd = fopen(fname, "w");
+
+ var_ptr = vars;
+ while (var_ptr && (var_ptr->ndims != i || var_ptr->vtype != REAL || !var_ptr->timedim)) var_ptr = var_ptr->next;
+ if (var_ptr) {
+ fortprintf(fd, " if (trim(field %% ioinfo %% fieldName) == \'%s\') then</font>
<font color="blue">", var_ptr->name_in_file);
+ fortprintf(fd, " varID = output_obj %% wrVarID%s</font>
<font color="blue">", var_ptr->name_in_file);
+ var_ptr = var_ptr->next;
+ while (var_ptr) {
+ if (var_ptr->ndims == i && var_ptr->vtype == REAL && var_ptr->timedim) {
+ fortprintf(fd, " else if (trim(field %% ioinfo %% fieldName) == \'%s\') then</font>
<font color="blue">", var_ptr->name_in_file);
+ fortprintf(fd, " varID = output_obj %% wrVarID%s</font>
<font color="blue">", var_ptr->name_in_file);
+ }
+ var_ptr = var_ptr->next;
+ }
+ fortprintf(fd, " end if</font>
<font color="gray">");
+ }
+
+ fclose(fd);
+ }
+
+}
Added: branches/ocean_projects/triangle_border_swm/src/registry/gen_inc.h
===================================================================
--- branches/ocean_projects/triangle_border_swm/src/registry/gen_inc.h (rev 0)
+++ branches/ocean_projects/triangle_border_swm/src/registry/gen_inc.h 2011-04-29 18:46:19 UTC (rev 810)
@@ -0,0 +1,4 @@
+void gen_namelists(struct namelist *);
+void gen_field_defs(struct group_list * groups, struct variable *, struct dimension *);
+void gen_reads(struct group_list * groups, struct variable *, struct dimension *);
+void gen_writes(struct group_list * groups, struct variable *, struct dimension *, struct namelist *);
Added: branches/ocean_projects/triangle_border_swm/src/registry/parse.c
===================================================================
--- branches/ocean_projects/triangle_border_swm/src/registry/parse.c (rev 0)
+++ branches/ocean_projects/triangle_border_swm/src/registry/parse.c 2011-04-29 18:46:19 UTC (rev 810)
@@ -0,0 +1,444 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include "registry_types.h"
+#include "gen_inc.h"
+
+int parse_reg(FILE *, struct namelist **, struct dimension **, struct variable **, struct group_list **);
+int getword(FILE *, char *);
+int is_integer_constant(char *);
+void sort_vars(struct variable *);
+void sort_group_vars(struct group_list *);
+
+int main(int argc, char ** argv)
+{
+ FILE * regfile;
+ struct namelist * nls;
+ struct dimension * dims;
+ struct variable * vars;
+ struct group_list * groups;
+
+ if (argc != 2) {
+ fprintf(stderr,"</font>
<font color="black">Usage: %s filename</font>
<font color="black"></font>
<font color="blue">", argv[0]);
+ return 1;
+ }
+
+ if (regfile = fopen(argv[1], "r")) {
+ nls = NULL;
+ dims = NULL;
+ vars = NULL;
+ if (parse_reg(regfile, &nls, &dims, &vars, &groups)) {
+ return 1;
+ }
+ }
+ else {
+ fprintf(stderr,"</font>
<font color="black">Error: Could not open file %s for reading.</font>
<font color="black"></font>
<font color="blue">", argv[1]);
+ return 1;
+ }
+
+ sort_vars(vars);
+ sort_group_vars(groups);
+
+ gen_namelists(nls);
+ gen_field_defs(groups, vars, dims);
+ gen_reads(groups, vars, dims);
+ gen_writes(groups, vars, dims, nls);
+
+ return 0;
+}
+
+
+int parse_reg(FILE * regfile, struct namelist ** nls, struct dimension ** dims, struct variable ** vars, struct group_list ** groups)
+{
+ char word[1024];
+ struct namelist * nls_ptr;
+ struct namelist * nls_chk_ptr;
+ struct dimension * dim_ptr;
+ struct variable * var_ptr;
+ struct dimension_list * dimlist_ptr;
+ struct dimension * dimlist_cursor;
+ struct group_list * grouplist_ptr;
+ struct variable_list * vlist_cursor;
+
+ NEW_NAMELIST(nls_ptr)
+ NEW_DIMENSION(dim_ptr)
+ NEW_VARIABLE(var_ptr)
+ NEW_GROUP_LIST(grouplist_ptr);
+ *nls = nls_ptr;
+ *dims = dim_ptr;
+ *vars = var_ptr;
+ *groups = grouplist_ptr;
+
+ while(getword(regfile, word) != EOF) {
+ if (strncmp(word, "namelist", 1024) == 0) {
+ NEW_NAMELIST(nls_ptr->next)
+ nls_ptr = nls_ptr->next;
+
+ getword(regfile, word);
+ if (strncmp(word, "real", 1024) == 0)
+ nls_ptr->vtype = REAL;
+ else if (strncmp(word, "integer", 1024) == 0)
+ nls_ptr->vtype = INTEGER;
+ else if (strncmp(word, "logical", 1024) == 0)
+ nls_ptr->vtype = LOGICAL;
+ else if (strncmp(word, "character", 1024) == 0)
+ nls_ptr->vtype = CHARACTER;
+
+ getword(regfile, nls_ptr->record);
+ getword(regfile, nls_ptr->name);
+
+ getword(regfile, word);
+ if (nls_ptr->vtype == REAL)
+ nls_ptr->defval.rval = (float)atof(word);
+ else if (nls_ptr->vtype == INTEGER)
+ nls_ptr->defval.ival = atoi(word);
+ else if (nls_ptr->vtype == LOGICAL) {
+ if (strncmp(word, "true", 1024) == 0)
+ nls_ptr->defval.lval = 1;
+ else if (strncmp(word, "false", 1024) == 0)
+ nls_ptr->defval.lval = 0;
+ }
+ else if (nls_ptr->vtype == CHARACTER)
+ strncpy(nls_ptr->defval.cval, word, 32);
+ }
+ else if (strncmp(word, "dim", 1024) == 0) {
+ NEW_DIMENSION(dim_ptr->next)
+ dim_ptr = dim_ptr->next;
+ dim_ptr->namelist_defined = 0;
+ getword(regfile, dim_ptr->name_in_file);
+ getword(regfile, dim_ptr->name_in_code);
+ dim_ptr->constant_value = is_integer_constant(dim_ptr->name_in_code);
+ if (strncmp(dim_ptr->name_in_code, "namelist:", 9) == 0) {
+ dim_ptr->namelist_defined = 1;
+ sprintf(dim_ptr->name_in_code, "%s", (dim_ptr->name_in_code)+9);
+
+ /* Check that the referenced namelist variable is defined as an integer variable */
+ nls_chk_ptr = (*nls)->next;
+ while (nls_chk_ptr) {
+ if (strncmp(nls_chk_ptr->name, dim_ptr->name_in_code, 1024) == 0) {
+ if (nls_chk_ptr->vtype != INTEGER) {
+ printf("</font>
<font color="black">Registry error: Namelist variable %s must be an integer for namelist-derived dimension %s</font>
<font color="black"></font>
<font color="blue">", nls_chk_ptr->name, dim_ptr->name_in_file);
+ return 1;
+ }
+ break;
+ }
+ nls_chk_ptr = nls_chk_ptr->next;
+ }
+ if (!nls_chk_ptr) {
+ printf("</font>
<font color="black">Registry error: Namelist variable %s not defined for namelist-derived dimension %s</font>
<font color="black"></font>
<font color="blue">", dim_ptr->name_in_code, dim_ptr->name_in_file);
+ return 1;
+ }
+ }
+ }
+ else if (strncmp(word, "var", 1024) == 0) {
+ NEW_VARIABLE(var_ptr->next)
+ var_ptr = var_ptr->next;
+ var_ptr->ndims = 0;
+ var_ptr->timedim = 0;
+ var_ptr->iostreams = 0;
+
+ /*
+ * persistence
+ */
+ getword(regfile, word);
+ if (strncmp(word, "persistent", 1024) == 0)
+ var_ptr->persistence = PERSISTENT;
+ else if (strncmp(word, "scratch", 1024) == 0)
+ var_ptr->persistence = SCRATCH;
+
+ getword(regfile, word);
+ if (strncmp(word, "real", 1024) == 0)
+ var_ptr->vtype = REAL;
+ else if (strncmp(word, "integer", 1024) == 0)
+ var_ptr->vtype = INTEGER;
+ else if (strncmp(word, "logical", 1024) == 0)
+ var_ptr->vtype = LOGICAL;
+
+ getword(regfile, var_ptr->name_in_file);
+
+ NEW_DIMENSION_LIST(dimlist_ptr)
+ var_ptr->dimlist = dimlist_ptr;
+
+ getword(regfile, word); /* Should have just read a right paren */
+ getword(regfile, word);
+ while (strncmp(word, ")", 1024) != 0) {
+
+ if (strncmp(word, "Time", 1024) == 0) {
+ var_ptr->timedim = 1;
+ }
+ else {
+ NEW_DIMENSION_LIST(dimlist_ptr->next)
+ dimlist_ptr->next->prev = dimlist_ptr;
+ dimlist_ptr = dimlist_ptr->next;
+
+ dimlist_cursor = (*dims)->next;
+ while (dimlist_cursor && (strncmp(word, dimlist_cursor->name_in_file, 1024) != 0)) dimlist_cursor = dimlist_cursor->next;
+ if (dimlist_cursor) {
+ dimlist_ptr->dim = dimlist_cursor;
+ }
+ else {
+ fprintf(stderr, "Error: Unknown dimension %s for variable %s</font>
<font color="blue">", word, var_ptr->name_in_file);
+ return 1;
+ }
+ }
+ getword(regfile, word);
+ }
+
+ /*
+ * time_dim
+ */
+ getword(regfile, word);
+ var_ptr->ntime_levs = atoi(word);
+
+ /*
+ * I/O info
+ */
+ getword(regfile, word);
+ if (strchr(word, (int)'i')) var_ptr->iostreams |= INPUT0;
+ if (strchr(word, (int)'r')) var_ptr->iostreams |= RESTART0;
+ if (strchr(word, (int)'o')) var_ptr->iostreams |= OUTPUT0;
+
+ getword(regfile, var_ptr->name_in_code);
+
+ /*
+ * struct
+ */
+ getword(regfile, var_ptr->struct_group);
+ grouplist_ptr = *groups;
+ grouplist_ptr = grouplist_ptr->next;
+ while (grouplist_ptr && strncmp(var_ptr->struct_group, grouplist_ptr->name, 1024)) {
+ grouplist_ptr = grouplist_ptr->next;
+ }
+ if (!grouplist_ptr) {
+ grouplist_ptr = *groups;
+ while(grouplist_ptr->next) grouplist_ptr = grouplist_ptr->next;
+ NEW_GROUP_LIST(grouplist_ptr->next);
+ grouplist_ptr = grouplist_ptr->next;
+ memcpy(grouplist_ptr->name, var_ptr->struct_group, (size_t)1024);
+ NEW_VARIABLE_LIST(grouplist_ptr->vlist);
+ grouplist_ptr->vlist->var = var_ptr;
+ }
+ else {
+ vlist_cursor = grouplist_ptr->vlist;
+ while (vlist_cursor->next) vlist_cursor = vlist_cursor->next;
+ NEW_VARIABLE_LIST(vlist_cursor->next);
+ vlist_cursor->next->prev = vlist_cursor;
+ vlist_cursor = vlist_cursor->next;
+ vlist_cursor->var = var_ptr;
+ }
+
+
+ getword(regfile, var_ptr->super_array);
+ getword(regfile, var_ptr->array_class);
+
+ dimlist_ptr = var_ptr->dimlist;
+ if (var_ptr->dimlist) var_ptr->dimlist = var_ptr->dimlist->next;
+ if (dimlist_ptr) free(dimlist_ptr);
+
+ dimlist_ptr = var_ptr->dimlist;
+ while (dimlist_ptr) {
+ var_ptr->ndims++;
+ dimlist_ptr = dimlist_ptr->next;
+ }
+ }
+ }
+
+ nls_ptr = *nls;
+ if ((*nls)->next) *nls = (*nls)->next;
+ if (nls_ptr) free(nls_ptr);
+
+ dim_ptr = *dims;
+ if ((*dims)->next) *dims = (*dims)->next;
+ if (dim_ptr) free(dim_ptr);
+
+ var_ptr = *vars;
+ if ((*vars)->next) *vars = (*vars)->next;
+ if (var_ptr) free(var_ptr);
+
+ grouplist_ptr = *groups;
+ if ((*groups)->next) *groups = (*groups)->next;
+ if (grouplist_ptr) free(grouplist_ptr);
+
+ return 0;
+}
+
+int getword(FILE * regfile, char * word)
+{
+ int i;
+ int c;
+
+ i = 0;
+
+ do { c = getc(regfile); } while (((char)c == ' ' || (char)c == '</font>
<font color="blue">' || (char)c == '\t') && c != EOF);
+
+ while ((char)c == '#') {
+ do { c = getc(regfile); } while ((char)c != '</font>
<font color="blue">' && c != EOF);
+ do { c = getc(regfile); } while (((char)c == ' ' || (char)c == '</font>
<font color="blue">' || (char)c == '\t') && c != EOF);
+ };
+ while((char)c != ' ' && (char)c != '</font>
<font color="blue">' && (char)c != '\t' && c != EOF && (char)c != '#') {
+ word[i++] = (char)c;
+ c = (char)getc(regfile);
+ }
+ word[i] = '\0';
+
+ if ((char)c == '#') do { c = getc(regfile); } while ((char)c != '</font>
<font color="gray">' && c != EOF);
+
+ return c;
+}
+
+int is_integer_constant(char * c) {
+ int i;
+
+ i = 0;
+ while (c[i] != '\0') {
+ if (c[i] < '0' || c[i] > '9') return -1;
+ i++;
+ }
+
+ return atoi(c);
+}
+
+void sort_vars(struct variable * vars)
+{
+ struct variable * var_ptr;
+ struct variable * var_ptr2;
+ struct variable * var_ptr2_prev;
+ char super_array[1024];
+ char array_class[1024];
+
+ var_ptr = vars;
+
+/* Attempt at sorting first on super-array, then on class in the same loop
+ while (var_ptr) {
+ memcpy(super_array, var_ptr->super_array, 1024);
+ memcpy(array_class, var_ptr->array_class, 1024);
+ var_ptr2_prev = var_ptr;
+ var_ptr2 = var_ptr->next;
+ if (var_ptr2 &&
+ (strncmp(super_array, var_ptr2->super_array, 1024) != 0 || strncmp(array_class, var_ptr2->array_class, 1024) != 0)) {
+ while (var_ptr2) {
+ if (strncmp(super_array, var_ptr2->super_array, 1024) == 0 && strncmp(array_class, var_ptr2->array_class, 1024) == 0) {
+ var_ptr2_prev->next = var_ptr2->next;
+ var_ptr2->next = var_ptr->next;
+ var_ptr->next = var_ptr2;
+ var_ptr2 = var_ptr2_prev->next;
+ }
+ else {
+ var_ptr2_prev = var_ptr2_prev->next;
+ var_ptr2 = var_ptr2->next;
+ }
+ }
+ }
+ var_ptr = var_ptr->next;
+ }
+*/
+
+ while (var_ptr) {
+ memcpy(super_array, var_ptr->super_array, 1024);
+ var_ptr2_prev = var_ptr;
+ var_ptr2 = var_ptr->next;
+ if (var_ptr2 && strncmp(super_array, var_ptr2->super_array, 1024) != 0) {
+ while (var_ptr2) {
+ if (strncmp(super_array, var_ptr2->super_array, 1024) == 0) {
+ var_ptr2_prev->next = var_ptr2->next;
+ var_ptr2->next = var_ptr->next;
+ var_ptr->next = var_ptr2;
+ var_ptr2 = var_ptr2_prev->next;
+ }
+ else {
+ var_ptr2_prev = var_ptr2_prev->next;
+ var_ptr2 = var_ptr2->next;
+ }
+ }
+ }
+ var_ptr = var_ptr->next;
+ }
+
+ var_ptr = vars;
+
+ while (var_ptr) {
+ memcpy(array_class, var_ptr->array_class, 1024);
+ var_ptr2_prev = var_ptr;
+ var_ptr2 = var_ptr->next;
+ if (var_ptr2 && strncmp(array_class, var_ptr2->array_class, 1024) != 0) {
+ while (var_ptr2) {
+ if (strncmp(array_class, var_ptr2->array_class, 1024) == 0) {
+ var_ptr2_prev->next = var_ptr2->next;
+ var_ptr2->next = var_ptr->next;
+ var_ptr->next = var_ptr2;
+ var_ptr2 = var_ptr2_prev->next;
+ }
+ else {
+ var_ptr2_prev = var_ptr2_prev->next;
+ var_ptr2 = var_ptr2->next;
+ }
+ }
+ }
+ var_ptr = var_ptr->next;
+ }
+}
+
+
+void sort_group_vars(struct group_list * groups)
+{
+ struct variable_list * var_list;
+ struct variable_list * var_ptr;
+ struct variable_list * var_ptr2;
+ struct variable_list * var_ptr2_prev;
+ struct group_list * group_ptr;
+ char super_array[1024];
+ char array_class[1024];
+
+ group_ptr = groups;
+
+ while (group_ptr) {
+
+ var_ptr = group_ptr->vlist;
+
+ while (var_ptr) {
+ memcpy(super_array, var_ptr->var->super_array, 1024);
+ var_ptr2_prev = var_ptr;
+ var_ptr2 = var_ptr->next;
+ if (var_ptr2 && strncmp(super_array, var_ptr2->var->super_array, 1024) != 0) {
+ while (var_ptr2) {
+ if (strncmp(super_array, var_ptr2->var->super_array, 1024) == 0) {
+ var_ptr2_prev->next = var_ptr2->next;
+ var_ptr2->next = var_ptr->next;
+ var_ptr->next = var_ptr2;
+ var_ptr2 = var_ptr2_prev->next;
+ }
+ else {
+ var_ptr2_prev = var_ptr2_prev->next;
+ var_ptr2 = var_ptr2->next;
+ }
+ }
+ }
+ var_ptr = var_ptr->next;
+ }
+
+ var_ptr = group_ptr->vlist;
+
+ while (var_ptr) {
+ memcpy(array_class, var_ptr->var->array_class, 1024);
+ var_ptr2_prev = var_ptr;
+ var_ptr2 = var_ptr->next;
+ if (var_ptr2 && strncmp(array_class, var_ptr2->var->array_class, 1024) != 0) {
+ while (var_ptr2) {
+ if (strncmp(array_class, var_ptr2->var->array_class, 1024) == 0) {
+ var_ptr2_prev->next = var_ptr2->next;
+ var_ptr2->next = var_ptr->next;
+ var_ptr->next = var_ptr2;
+ var_ptr2 = var_ptr2_prev->next;
+ }
+ else {
+ var_ptr2_prev = var_ptr2_prev->next;
+ var_ptr2 = var_ptr2->next;
+ }
+ }
+ }
+ var_ptr = var_ptr->next;
+ }
+
+ group_ptr = group_ptr->next;
+ }
+}
Added: branches/ocean_projects/triangle_border_swm/src/registry/registry_types.h
===================================================================
--- branches/ocean_projects/triangle_border_swm/src/registry/registry_types.h (rev 0)
+++ branches/ocean_projects/triangle_border_swm/src/registry/registry_types.h 2011-04-29 18:46:19 UTC (rev 810)
@@ -0,0 +1,75 @@
+#define INTEGER 0
+#define REAL 1
+#define LOGICAL 2
+#define CHARACTER 3
+
+#define PERSISTENT 0
+#define SCRATCH 1
+
+#define INPUT0 0x00000001
+#define RESTART0 0x00000002
+#define OUTPUT0 0x00000004
+
+#define NEW_NAMELIST(X) X = (struct namelist *)malloc(sizeof(struct namelist)); X->next = NULL;
+#define NEW_DIMENSION(X) X = (struct dimension *)malloc(sizeof(struct dimension)); X->next = NULL;
+#define NEW_DIMENSION_LIST(X) X = (struct dimension_list *)malloc(sizeof(struct dimension_list)); X->dim = NULL; X->prev = NULL; X->next = NULL;
+#define NEW_VARIABLE(X) X = (struct variable *)malloc(sizeof(struct variable)); X->dimlist = NULL; X->next = NULL;
+#define NEW_VARIABLE_LIST(X) X = (struct variable_list *)malloc(sizeof(struct variable_list)); X->var = NULL; X->prev = NULL; X->next = NULL;
+#define NEW_GROUP_LIST(X) X = (struct group_list *)malloc(sizeof(struct group_list)); X->vlist = NULL; X->next = NULL;
+
+union default_val {
+ int ival;
+ float rval;
+ int lval;
+ char cval[32];
+};
+
+struct namelist {
+ char name[1024];
+ char record[1024];
+ int vtype;
+ union default_val defval;
+ struct namelist * next;
+};
+
+struct dimension {
+ char name_in_file[1024];
+ char name_in_code[1024];
+ int constant_value;
+ int namelist_defined;
+ struct dimension * next;
+};
+
+struct dimension_list {
+ struct dimension * dim;
+ struct dimension_list * prev;
+ struct dimension_list * next;
+};
+
+struct variable_list {
+ struct variable * var;
+ struct variable_list * prev;
+ struct variable_list * next;
+};
+
+struct group_list {
+ char name[1024];
+ struct variable_list * vlist;
+ struct group_list * next;
+};
+
+struct variable {
+ char name_in_file[1024];
+ char name_in_code[1024];
+ char struct_group[1024];
+ char super_array[1024];
+ char array_class[1024];
+ int persistence;
+ int vtype;
+ int ndims;
+ int timedim;
+ int ntime_levs;
+ int iostreams;
+ struct dimension_list * dimlist;
+ struct variable * next;
+};
</font>
</pre>