<p><b>mhecht@lanl.gov</b> 2010-06-23 11:20:20 -0600 (Wed, 23 Jun 2010)</p><p>Appears to be successful merge of trunk (at r362) back onto my<br>
branch. Use of O(3) advection does not produce bit-for-bit same result<br>
in output through 1000 timesteps of test problem 6 -- some change<br>
(bug-fix?) on trunk must be responsible for this -- but it produces<br>
precisely the same max/min range in passive tracers at ts 500 as<br>
before merge. Should be ready to try with land/ocean boundaries. Merge<br>
is documented in my notes file, coy_test_100405.rtf.<br>
</p><hr noshade><pre><font color="gray">Modified: branches/ocean_projects/port_adv_mwh/Makefile
===================================================================
--- branches/ocean_projects/port_adv_mwh/Makefile 2010-06-18 22:07:12 UTC (rev 362)
+++ branches/ocean_projects/port_adv_mwh/Makefile 2010-06-23 17:20:20 UTC (rev 363)
@@ -1,9 +1,12 @@
#MODEL_FORMULATION = -DNCAR_FORMULATION
MODEL_FORMULATION = -DLANL_FORMULATION
+ifeq ($(CORE),hyd_atmos)
EXPAND_LEVELS = -DEXPAND_LEVELS=26
-#FILE_OFFSET = -DOFFSET64BIT
+endif
+FILE_OFFSET = -DOFFSET64BIT
+
#########################
# Section for Zoltan TPL
#########################
@@ -33,6 +36,18 @@
"CORE = $(CORE)" \
"CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) $(EXPAND_LEVELS) -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" \
+ "CFLAGS = -fast" \
+ "LDFLAGS = " \
+ "CORE = $(CORE)" \
+ "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) $(EXPAND_LEVELS) -D_MPI -DUNDERSCORE $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
+
pgi:
( make all \
"FC = mpif90" \
@@ -45,6 +60,18 @@
"CORE = $(CORE)" \
"CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) $(EXPAND_LEVELS) -D_MPI -DUNDERSCORE $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
+pgi-llnl:
+ ( make all \
+ "FC = mpipgf90" \
+ "CC = pgcc" \
+ "SFC = pgf90" \
+ "SCC = pgcc" \
+ "FFLAGS = -i4 -r8 -g -O2" \
+ "CFLAGS = -fast" \
+ "LDFLAGS = " \
+ "CORE = $(CORE)" \
+ "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) $(EXPAND_LEVELS) -D_MPI -DUNDERSCORE $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
+
pgi-serial:
( make all \
"FC = pgf90" \
@@ -75,14 +102,37 @@
"CC = mpicc" \
"SFC = gfortran" \
"SCC = gcc" \
- "FFLAGS = -O3 -m64 -ffree-line-length-none" \
+ "FFLAGS = -O3 -m64 -ffree-line-length-none -fdefault-real-8" \
"CFLAGS = -O3 -m64" \
"LDFLAGS = -O3 -m64" \
"CORE = $(CORE)" \
"CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) $(EXPAND_LEVELS) -D_MPI -DUNDERSCORE -m64 $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
+g95:
+ ( make all \
+ "FC = mpif90" \
+ "CC = mpicc" \
+ "SFC = g95" \
+ "SCC = gcc" \
+ "FFLAGS = -O3 -ffree-line-length-huge -r8" \
+ "CFLAGS = -O3" \
+ "LDFLAGS = -O3" \
+ "CORE = $(CORE)" \
+ "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) $(EXPAND_LEVELS) -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" \
+ "CFLAGS = -O3" \
+ "LDFLAGS = -O3" \
+ "CORE = $(CORE)" \
+ "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) $(EXPAND_LEVELS) -DUNDERSCORE $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
+
CPPINCLUDES = -I../inc -I$(NETCDF)/include
FCINCLUDES = -I../inc -I$(NETCDF)/include
LIBS = -L$(NETCDF)/lib -lnetcdf
Modified: branches/ocean_projects/port_adv_mwh/namelist.input.hyd_atmos
===================================================================
--- branches/ocean_projects/port_adv_mwh/namelist.input.hyd_atmos 2010-06-18 22:07:12 UTC (rev 362)
+++ branches/ocean_projects/port_adv_mwh/namelist.input.hyd_atmos 2010-06-23 17:20:20 UTC (rev 363)
@@ -13,6 +13,7 @@
config_v_theta_eddy_visc2 = 0.0
config_theta_adv_order = 2
config_scalar_adv_order = 2
+ config_mp_physics = 0
/
&io
Modified: branches/ocean_projects/port_adv_mwh/namelist.input.ocean
===================================================================
--- branches/ocean_projects/port_adv_mwh/namelist.input.ocean 2010-06-18 22:07:12 UTC (rev 362)
+++ branches/ocean_projects/port_adv_mwh/namelist.input.ocean 2010-06-23 17:20:20 UTC (rev 363)
@@ -1,11 +1,11 @@
&sw_model
- config_test_case = 5
+ config_test_case = 0
config_time_integration = 'RK4'
- config_dt = 300.0
- config_ntimesteps = 3000
- config_output_interval = 300
- config_stats_interval = 10
- config_visc = 4.0
+ config_dt = 60.0
+ config_ntimesteps = 1440000
+ config_output_interval = 14400
+ config_stats_interval = 1440
+ config_visc = 1.0e5
/
&io
@@ -15,7 +15,31 @@
/
&restart
- config_restart_interval = 864000
+ config_restart_interval = 115200
config_do_restart = .false.
config_restart_time = 1036800.0
/
+
+&grid
+ config_vert_grid_type = 'zlevel'
+ config_rho0 = 1028
+/
+&hmix
+ config_hor_diffusion = 1.0e4
+/
+&vmix
+ config_vert_visc_type = 'tanh'
+ config_vert_diff_type = 'tanh'
+ config_vmixTanhViscMax = 2.5e-1
+ config_vmixTanhViscMin = 1.0e-4
+ config_vmixTanhDiffMax = 2.5e-2
+ config_vmixTanhDiffMin = 1.0e-5
+ config_vmixTanhZMid = -100
+ config_vmixTanhZWidth = 100
+ config_vert_viscosity = 2.5e-4
+ config_vert_diffusion = 2.5e-5
+/
+&advection
+ config_hor_tracer_adv = 'upwind'
+ config_vert_tracer_adv = 'upwind'
+/
Modified: branches/ocean_projects/port_adv_mwh/src/core_hyd_atmos/Makefile
===================================================================
--- branches/ocean_projects/port_adv_mwh/src/core_hyd_atmos/Makefile 2010-06-18 22:07:12 UTC (rev 362)
+++ branches/ocean_projects/port_adv_mwh/src/core_hyd_atmos/Makefile 2010-06-23 17:20:20 UTC (rev 363)
@@ -19,10 +19,9 @@
mpas_interface.o: module_advection.o module_test_cases.o module_time_integration.o
clean:
- $(RM) *.o *.mod libdycore.a
+ $(RM) *.o *.mod *.f90 libdycore.a
.F.o:
$(RM) $@ $*.mod
$(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90
$(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../framework -I../operators
- $(RM) $*.f90
Modified: branches/ocean_projects/port_adv_mwh/src/core_hyd_atmos/Registry
===================================================================
--- branches/ocean_projects/port_adv_mwh/src/core_hyd_atmos/Registry 2010-06-18 22:07:12 UTC (rev 362)
+++ branches/ocean_projects/port_adv_mwh/src/core_hyd_atmos/Registry 2010-06-23 17:20:20 UTC (rev 363)
@@ -17,6 +17,7 @@
namelist integer sw_model config_scalar_adv_order 2
namelist logical sw_model config_positive_definite false
namelist logical sw_model config_monotonic true
+namelist integer sw_model config_mp_physics 0
namelist character io config_input_name grid.nc
namelist character io config_output_name output.nc
namelist character io config_restart_name restart.nc
@@ -80,6 +81,10 @@
var real areaCell ( nCells ) iro areaCell - -
var real areaTriangle ( nVertices ) iro areaTriangle - -
+var real edgeNormalVectors ( R3 nEdges ) o edgeNormalVectors - -
+var real localVerticalUnitVectors ( R3 nCells ) o localVerticalUnitVectors - -
+var real cellTangentPlane ( R3 TWO nEdges ) o cellTangentPlane - -
+
var integer cellsOnCell ( maxEdges nCells ) iro cellsOnCell - -
var integer verticesOnCell ( maxEdges nCells ) iro verticesOnCell - -
var integer verticesOnEdge ( TWO nEdges ) iro verticesOnEdge - -
@@ -111,6 +116,7 @@
# state variables diagnosed from prognostic state
var real h ( nVertLevels nCells Time ) ro h - -
var real ww ( nVertLevelsP1 nCells Time ) ro ww - -
+var real w ( nVertLevelsP1 nCells Time ) ro w - -
var real pressure ( nVertLevelsP1 nCells Time ) ro pressure - -
var real geopotential ( nVertLevelsP1 nCells Time ) ro geopotential - -
var real alpha ( nVertLevels nCells Time ) iro alpha - -
@@ -127,6 +133,8 @@
var real uReconstructX ( nVertLevels nCells Time ) o uReconstructX - -
var real uReconstructY ( nVertLevels nCells Time ) o uReconstructY - -
var real uReconstructZ ( nVertLevels nCells Time ) o uReconstructZ - -
+var real uReconstructZonal ( nVertLevels nCells Time ) o uReconstructZonal - -
+var real uReconstructMeridional ( nVertLevels nCells Time ) o uReconstructMeridional - -
# Other diagnostic variables: neither read nor written to any files
var real vh ( nVertLevels nEdges Time ) - vh - -
Modified: branches/ocean_projects/port_adv_mwh/src/core_hyd_atmos/module_advection.F
===================================================================
--- branches/ocean_projects/port_adv_mwh/src/core_hyd_atmos/module_advection.F 2010-06-18 22:07:12 UTC (rev 362)
+++ branches/ocean_projects/port_adv_mwh/src/core_hyd_atmos/module_advection.F 2010-06-23 17:20:20 UTC (rev 363)
@@ -25,6 +25,7 @@
! 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
@@ -96,56 +97,68 @@
do_the_cell = .true.
do i=1,n
- if (cell_list(i) <= 0) do_the_cell = .false.
+ 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
+ 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. )
+ 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
+ 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) )
- 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
- 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
- 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
-! 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
+ else ! On an x-y plane
- do i=1,n-1
- xp(i) = cos(thetat(i)) * dl_sphere(i)
- yp(i) = sin(thetat(i)) * dl_sphere(i)
- end do
+ do i=1,n-1
+ xp(i) = grid % xCell % array(cell_list(i)) - grid % xCell % array(iCell)
+ yp(i) = grid % yCell % array(cell_list(i)) - grid % yCell % array(iCell)
+ end do
+ end if
+
+
ma = n-1
mw = grid % nEdgesOnCell % array (iCell)
@@ -244,20 +257,25 @@
yv2 = grid % yVertex % array(grid % verticesOnEdge % array (2,iedge))/a
zv2 = grid % zVertex % array(grid % verticesOnEdge % array (2,iedge))/a
- call arc_bisect( xv1, yv1, zv1, &
- xv2, yv2, zv2, &
- xec, yec, zec )
+ 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
+ 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
- thetae(2,grid % EdgesOnCell % array (i,iCell)) = thetae_tmp
+ 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
@@ -266,31 +284,40 @@
iEdge = grid % EdgesOnCell % array (i,iCell)
- if (iCell == grid % cellsOnEdge % array(1,iEdge)) then
+ 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
+ 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
+ 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(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)
+ 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)
+ deriv_two(j,2,iEdge) = deriv_two(j,1,iEdge)
end do
end if
end do
Modified: branches/ocean_projects/port_adv_mwh/src/core_hyd_atmos/module_test_cases.F
===================================================================
--- branches/ocean_projects/port_adv_mwh/src/core_hyd_atmos/module_test_cases.F 2010-06-18 22:07:12 UTC (rev 362)
+++ branches/ocean_projects/port_adv_mwh/src/core_hyd_atmos/module_test_cases.F 2010-06-23 17:20:20 UTC (rev 363)
@@ -28,10 +28,11 @@
write(0,*) ' need hydrostatic test case configuration, error stop '
stop
- else if ((config_test_case == 1) .or. (config_test_case == 2)) then
+ else if ((config_test_case == 1) .or. (config_test_case == 2) .or. (config_test_case == 3)) then
write(0,*) ' Jablonowski and Williamson baroclinic wave test case '
if (config_test_case == 1) write(0,*) ' no initial perturbation '
if (config_test_case == 2) write(0,*) ' initial perturbation included '
+ if (config_test_case == 3) write(0,*) ' normal-mode perturbation included '
block_ptr => domain % blocklist
do while (associated(block_ptr))
call hyd_test_case_1(block_ptr % mesh, block_ptr % time_levs(1) % state, config_test_case)
@@ -69,6 +70,8 @@
real (kind=RKIND), parameter :: u_perturbation = 1., pert_radius = 0.1, latitude_pert = 40., longitude_pert = 20.
real (kind=RKIND), parameter :: theta_c = pii/4.0
real (kind=RKIND), parameter :: lambda_c = 3.0*pii/2.0
+ real (kind=RKIND), parameter :: rh_max = 0.4 ! Maximum relative humidity
+ real (kind=RKIND), parameter :: k_x = 9. ! Normal mode wave number
real (kind=RKIND), dimension(:), pointer :: rdnu, rdnw, fnm, fnp, dbn, dnu, dnw
real (kind=RKIND), dimension(:), pointer :: surface_pressure
@@ -79,7 +82,12 @@
real (kind=RKIND) :: u, v, flux, fluxk, lat1, lat2, eta_v, r_pert, u_pert, lat_pert, lon_pert, r
real (kind=RKIND) :: ptop, p0, phi
+ real (kind=RKIND) :: lon_Edge
+ real (kind=RKIND), dimension(grid % nVertLevels, grid % nCells) :: rel_hum, temperature
+ real (kind=RKIND) :: ptmp, es, qvs
+ integer :: iter
+
! real (kind=RKIND), dimension(grid % nVertLevelsP1 ) :: hyai, hybi, znu, znw, znwc, znwv, hyam, hybm
! real (kind=RKIND), dimension(grid % nVertLevelsP1 ) :: znuc, znuv, bn, divh, dpn, teta, phi
real (kind=RKIND), dimension(grid % nVertLevels + 1 ) :: hyai, hybi, znu, znw, znwc, znwv, hyam, hybm
@@ -141,13 +149,14 @@
h => state % h % array
scalars => state % scalars % array
- scalars = 0.
+ scalars(:,:,:) = 0.
p0 = 100000.
bn (1) = 1.
znw(1) = 1.
znwc(1) = 1.
- znwv(1) = (znwc(1)-.252)*pii/2.
+ !znwv(1) = (znwc(1)-.252)*pii/2.
+ znwv(1) = ((znwc(1)-.252)*pii/2.*p0-ptop)/(p0-ptop)
if (cam26) then
@@ -208,8 +217,10 @@
!
do k=1,nz1
- znuv(k ) = (znuc(k )-.252)*pii/2.
- znwv(k+1) = (znwc(k+1)-.252)*pii/2.
+ !znuv(k ) = (znuc(k )-.252)*pii/2.
+ !znwv(k+1) = (znwc(k+1)-.252)*pii/2.
+ znuv(k ) = ((znuc(k )-.252)*pii/2.*p0-ptop)/(p0-ptop)
+ znwv(k+1) = ((znwc(k+1)-.252)*pii/2.*p0-ptop)/(p0-ptop)
dnw (k) = znw(k+1)-znw(k)
rdnw(k) = 1./dnw(k)
dbn (k) = rdnw(k)*(bn(k+1)-bn(k))
@@ -247,6 +258,11 @@
r_pert = sphere_distance( grid % latEdge % array (iEdge), grid % lonEdge % array (iEdge), &
lat_pert, lon_pert, 1.)/(pert_radius)
u_pert = u_perturbation*exp(-r_pert**2)*(lat2-lat1)*a/grid % dvEdge % array(iEdge)
+
+ else if (config_test_case == 3) then
+ lon_Edge = grid % lonEdge % array(iEdge)
+ u_pert = u_perturbation*cos(k_x*(lon_Edge - lon_pert)) &
+ *(0.5*(lat2-lat1) - 0.125*(sin(4.*lat2) - sin(4.*lat1)))*a/grid % dvEdge % array(iEdge)
else
u_pert = 0.0
end if
@@ -274,14 +290,16 @@
)
end do
- do k=1,nz1
- if(znuc(k).ge.eta_t) then
- teta(k) = t0*znuc(k)**(rgas*dtdz/gravity)
- else
- teta(k) = t0*znuc(k)**(rgas*dtdz/gravity) + delta_t*(eta_t-znuc(k))**5
- end if
- write(6,*) ' k, reference t ',k,teta(k)
- end do
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! To get hydrostatic balance with misture -- soln. 2.
+! original scheme by Jablonowski
+! T' = -1./R_d *(p/p_0) * d(phi')/d(eta)
+! = -1./R_d * eta * d(phi')/d(eta)
+! soln. 2 -> derive temperature profile from hydrostatic balance with moisture
+!
+! T_v = -1/(1+q_v)*(p/R_d)* d(eta)/d(p_d) * d(phi)/d(eta)
+! phi'(k) = phi(k+1) + d(eta)* alpha_pert * d(eta)/d(p_d)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
do iCell=1,grid % nCells
@@ -299,8 +317,13 @@
end do
do k=1,nz1
-
- theta (k,iCell) = teta(k)+.75*znuc(k)*pii*u0/rgas*sin(znuv(k)) &
+ ptmp = 0.5*(pressure(k,iCell)+pressure(k+1,iCell))
+ if (znuc(k) >= eta_t) then
+ teta(k) = t0*(ptmp/p0)**(rgas*dtdz/gravity)
+ else
+ teta(k) = t0*(ptmp/p0)**(rgas*dtdz/gravity) + delta_t*(eta_t-ptmp/p0)**5
+ end if
+ theta (k,iCell) = teta(k)+.75*ptmp/h(k,iCell)*pii*u0/rgas*sin(znuv(k)) &
*sqrt(cos(znuv(k)))* &
((-2.*sin(phi)**6 &
*(cos(phi)**2+1./3.)+10./63.) &
@@ -333,9 +356,89 @@
end do
end do
+ write(6,*) 'ptop_dry = ',ptop,' zt_dry = ',geopotential(nz,1)/gravity
+
+ write(6,*) ' full sounding for dry'
+ do k=1,nz1
+ write(6,*) k, geopotential(k,1)/gravity, 0.01*pressure(k,1), theta(k,1), &
+ theta(k,1)*(pressure(k,1)/p0)**(rgas/cp)
+ end do
+
+!
+! initialization for moisture
+!
+ if (config_mp_physics /= 0) then
+
+ do iCell=1,grid % nCells
+ do k=1,nz1
+ ptmp = 0.5*(pressure(k,iCell) + pressure(k+1,iCell))
+ if (ptmp < 50000.) then
+ rel_hum(k,iCell) = 0.0
+ else
+ rel_hum(k,iCell) = (1.-((p0-ptmp)/50000.)**1.25)
+ end if
+ rel_hum(k,iCell) = min(rh_max,rel_hum(k,iCell))
+ end do
+ end do
+ else
+ rel_hum(:,:) = 0.
+ end if
+
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! iteration
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ do iter=1,30
+ do iCell=1,grid % nCells
+
+ phi = grid % latCell % array (iCell)
+ do k=1,nz1
+ ptmp = 0.5*(pressure(k+1,iCell)+pressure(k,iCell))
+
+ if(znuc(k) >= eta_t) then
+ teta(k) = t0*(ptmp/p0)**(rgas*dtdz/gravity)
+ else
+ teta(k) = t0*(ptmp/p0)**(rgas*dtdz/gravity) + delta_t*(eta_t-ptmp/p0)**5
+ end if
+
+ temperature (k,iCell) = teta(k)+.75*ptmp/h(k,iCell)*pii*u0/rgas*sin(znuv(k)) &
+ *sqrt(cos(znuv(k)))* &
+ ((-2.*sin(phi)**6 &
+ *(cos(phi)**2+1./3.)+10./63.) &
+ *2.*u0*cos(znuv(k))**1.5 &
+ +(1.6*cos(phi)**3 &
+ *(sin(phi)**2+2./3.)-pii/4.)*a*omega)
+
+ temperature(k,iCell) = temperature(k,iCell)/(1.+0.61*scalars(index_qv,k,iCell))
+
+ theta (k,iCell) = temperature(k,iCell)* &
+ (0.5*(pressure(k,iCell)+pressure(k+1,iCell))/p0)**(-rgas/cp)
+ alpha (k,iCell) = (rgas/p0)*theta(k,iCell)*(1.+1.61*scalars(index_qv,k,iCell))* &
+ (0.5*(pressure(k,iCell)+pressure(k+1,iCell))/p0)**cvpm
+
+ if (temperature(k,iCell) > 273.15) then
+ es = 1000.*0.6112*exp(17.67*(temperature(k,iCell)-273.15)/(temperature(k,iCell)-29.65))
+ else
+ es = 1000.*0.6112*exp(21.8745584*(temperature(k,iCell)-273.16)/(temperature(k,iCell)-7.66))
+ end if
+ qvs = (287.04/461.6)*es/(ptmp-es)
+! qvs = 380.*exp(17.27*(temperature(k,iCell)-273.)/(temperature(k,iCell)-36.))/ptmp
+
+ scalars(index_qv,k,iCell) = rel_hum(k,iCell)*qvs
+ end do
+
+ do k=nz1,1,-1
+ pressure(k,iCell) = pressure(k+1,iCell)-dnw(k)*h(k,iCell)*(1.+scalars(index_qv,k,iCell))
+ geopotential(k,iCell) = geopotential(k+1,iCell)+dnw(k)*h(k,iCell)*alpha(k,iCell)
+ end do
+
+ end do
+ end do
+
write(6,*) 'ptop = ',ptop,' zt = ',geopotential(nz,1)/gravity
- write(6,*) ' full sounding '
+ write(6,*) ' full sounding with moisture'
do k=1,nz1
write(6,*) k, geopotential(k,1)/gravity, 0.01*pressure(k,1), theta(k,1), &
theta(k,1)*(pressure(k,1)/p0)**(rgas/cp)
Modified: branches/ocean_projects/port_adv_mwh/src/core_hyd_atmos/module_time_integration.F
===================================================================
--- branches/ocean_projects/port_adv_mwh/src/core_hyd_atmos/module_time_integration.F 2010-06-18 22:07:12 UTC (rev 362)
+++ branches/ocean_projects/port_adv_mwh/src/core_hyd_atmos/module_time_integration.F 2010-06-23 17:20:20 UTC (rev 363)
@@ -4,6 +4,7 @@
use configure
use constants
use dmpar
+ use vector_reconstruction
contains
@@ -118,8 +119,8 @@
block % mesh % nVertLevels, block % mesh % nCells, &
block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
call dmpar_exch_halo_field2dReal(domain % dminfo, block % mesh % cqu % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ block % mesh % nVertLevels, block % mesh % nEdges, &
+ block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
call dmpar_exch_halo_field2dReal(domain % dminfo, block % time_levs(2) % state % h % array(:,:), &
block % mesh % nVertLevels, block % mesh % nCells, &
block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
@@ -314,6 +315,16 @@
! END RK loop
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !
+ ! Compute full velocity vectors at cell centers, and compute vertical velocity diagnostic
+ !
+ block => domain % blocklist
+ do while (associated(block))
+ call reconstruct(block % time_levs(2) % state, block % mesh)
+ call compute_w(block % time_levs(2) % state, block % time_levs(1) % state, block % mesh, dt)
+ block => block % next
+ end do
+
if(debug) write(0,*) ' rk step complete - mass diagnostics '
if(debug .or. debug_mass_conservation) then
@@ -395,9 +406,7 @@
do k = 1, nVertLevels
cell1 = grid % cellsOnEdge % array(1,iEdge)
cell2 = grid % cellsOnEdge % array(2,iEdge)
- if (cell1 > 0 .and. cell2 > 0) then
- grid % cqu % array(k,iEdge) = 1./( 1. + 0.5*(grid % qtot % array(k,cell1)+grid % qtot % array(k,cell2)) )
- end if
+ grid % cqu % array(k,iEdge) = 1./( 1. + 0.5*(grid % qtot % array(k,cell1)+grid % qtot % array(k,cell2)) )
end do
end do
@@ -671,10 +680,10 @@
if ( h_mom_eddy_visc4 > 0.0 ) then
- allocate(delsq_divergence(nVertLevels, nCells))
- allocate(delsq_u(nVertLevels, nEdges))
- allocate(delsq_circulation(nVertLevels, nVertices))
- allocate(delsq_vorticity(nVertLevels, nVertices))
+ 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
@@ -684,33 +693,25 @@
vertex1 = verticesOnEdge(1,iEdge)
vertex2 = verticesOnEdge(2,iEdge)
- if (cell1 > 0 .and. cell2 > 0) then
- do k=1,nVertLevels
+ do k=1,nVertLevels
- !
- ! Compute diffusion, computed as </font>
<font color="black">abla divergence - k \times </font>
<font color="red">abla vorticity
- ! only valid for h_mom_eddy_visc4 == constant
- !
- u_diffusion = ( divergence(k,cell2) - divergence(k,cell1) ) / dcEdge(iEdge) &
- -( vorticity(k,vertex2) - vorticity(k,vertex1) ) / dvEdge(iEdge)
-
- delsq_u(k,iEdge) = delsq_u(k,iEdge) + u_diffusion
- end do
- end if
+ !
+ ! Compute diffusion, computed as </font>
<font color="black">abla divergence - k \times </font>
<font color="gray">abla vorticity
+ ! only valid for h_mom_eddy_visc4 == constant
+ !
+ u_diffusion = ( divergence(k,cell2) - divergence(k,cell1) ) / dcEdge(iEdge) &
+ -( vorticity(k,vertex2) - vorticity(k,vertex1) ) / dvEdge(iEdge)
+
+ delsq_u(k,iEdge) = delsq_u(k,iEdge) + u_diffusion
+ end do
end do
delsq_circulation(:,:) = 0.0
do iEdge=1,nEdges
- if (verticesOnEdge(1,iEdge) > 0) then
- do k=1,nVertLevels
- delsq_circulation(k,verticesOnEdge(1,iEdge)) = delsq_circulation(k,verticesOnEdge(1,iEdge)) - dcEdge(iEdge) * delsq_u(k,iEdge)
- end do
- end if
- if (verticesOnEdge(2,iEdge) > 0) then
- do k=1,nVertLevels
- delsq_circulation(k,verticesOnEdge(2,iEdge)) = delsq_circulation(k,verticesOnEdge(2,iEdge)) + dcEdge(iEdge) * delsq_u(k,iEdge)
- end do
- end if
+ do k=1,nVertLevels
+ delsq_circulation(k,verticesOnEdge(1,iEdge)) = delsq_circulation(k,verticesOnEdge(1,iEdge)) - dcEdge(iEdge) * delsq_u(k,iEdge)
+ delsq_circulation(k,verticesOnEdge(2,iEdge)) = delsq_circulation(k,verticesOnEdge(2,iEdge)) + dcEdge(iEdge) * delsq_u(k,iEdge)
+ end do
end do
do iVertex=1,nVertices
r = 1.0 / areaTriangle(iVertex)
@@ -723,16 +724,10 @@
do iEdge=1,nEdges
cell1 = cellsOnEdge(1,iEdge)
cell2 = cellsOnEdge(2,iEdge)
- if (cell1 > 0) then
- do k=1,nVertLevels
- delsq_divergence(k,cell1) = delsq_divergence(k,cell1) + delsq_u(k,iEdge)*dvEdge(iEdge)
- end do
- end if
- if(cell2 > 0) then
- do k=1,nVertLevels
- delsq_divergence(k,cell2) = delsq_divergence(k,cell2) - delsq_u(k,iEdge)*dvEdge(iEdge)
- end do
- end if
+ 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)
@@ -833,37 +828,33 @@
do iEdge=1,grid % nEdges
cell1 = grid % cellsOnEdge % array(1,iEdge)
cell2 = grid % cellsOnEdge % array(2,iEdge)
- if (cell1 > 0 .and. cell2 > 0) then
- do k=1,grid % nVertLevels
- theta_turb_flux = h_theta_eddy_visc2*prandtl*(theta(k,cell2) - theta(k,cell1))/dcEdge(iEdge)
- flux = dvEdge (iEdge) * h_edge(k,iEdge) * theta_turb_flux
- tend_theta(k,cell1) = tend_theta(k,cell1) + flux
- tend_theta(k,cell2) = tend_theta(k,cell2) - flux
- end do
+ do k=1,grid % nVertLevels
+ theta_turb_flux = h_theta_eddy_visc2*prandtl*(theta(k,cell2) - theta(k,cell1))/dcEdge(iEdge)
+ flux = dvEdge (iEdge) * h_edge(k,iEdge) * theta_turb_flux
+ tend_theta(k,cell1) = tend_theta(k,cell1) + flux
+ tend_theta(k,cell2) = tend_theta(k,cell2) - flux
+ end do
- end if
end do
end if
if ( h_theta_eddy_visc4 > 0.0 ) then
- allocate(delsq_theta(nVertLevels, nCells))
+ allocate(delsq_theta(nVertLevels, nCells+1))
delsq_theta(:,:) = 0.
do iEdge=1,grid % nEdges
cell1 = grid % cellsOnEdge % array(1,iEdge)
cell2 = grid % cellsOnEdge % array(2,iEdge)
- if (cell1 > 0 .and. cell2 > 0) then
- do k=1,grid % nVertLevels
- delsq_theta(k,cell1) = delsq_theta(k,cell1) + dvEdge(iEdge)*h_edge(k,iEdge)*(theta(k,cell2) - theta(k,cell1))/dcEdge(iEdge)
- delsq_theta(k,cell2) = delsq_theta(k,cell2) - dvEdge(iEdge)*h_edge(k,iEdge)*(theta(k,cell2) - theta(k,cell1))/dcEdge(iEdge)
- end do
+ do k=1,grid % nVertLevels
+ delsq_theta(k,cell1) = delsq_theta(k,cell1) + dvEdge(iEdge)*h_edge(k,iEdge)*(theta(k,cell2) - theta(k,cell1))/dcEdge(iEdge)
+ delsq_theta(k,cell2) = delsq_theta(k,cell2) - dvEdge(iEdge)*h_edge(k,iEdge)*(theta(k,cell2) - theta(k,cell1))/dcEdge(iEdge)
+ end do
- end if
end do
do iCell = 1, nCells
@@ -876,17 +867,15 @@
do iEdge=1,grid % nEdges
cell1 = grid % cellsOnEdge % array(1,iEdge)
cell2 = grid % cellsOnEdge % array(2,iEdge)
- if (cell1 > 0 .and. cell2 > 0) then
- do k=1,grid % nVertLevels
- theta_turb_flux = h_theta_eddy_visc4*prandtl*(delsq_theta(k,cell2) - delsq_theta(k,cell1))/dcEdge(iEdge)
- flux = dvEdge (iEdge) * theta_turb_flux
+ do k=1,grid % nVertLevels
+ theta_turb_flux = h_theta_eddy_visc4*prandtl*(delsq_theta(k,cell2) - delsq_theta(k,cell1))/dcEdge(iEdge)
+ flux = dvEdge (iEdge) * theta_turb_flux
- tend_theta(k,cell1) = tend_theta(k,cell1) - flux
- tend_theta(k,cell2) = tend_theta(k,cell2) + flux
- end do
+ tend_theta(k,cell1) = tend_theta(k,cell1) - flux
+ tend_theta(k,cell2) = tend_theta(k,cell2) + flux
+ end do
- end if
end do
deallocate(delsq_theta)
@@ -903,14 +892,12 @@
do iEdge=1,nEdges
cell1 = cellsOnEdge(1,iEdge)
cell2 = cellsOnEdge(2,iEdge)
- if (cell1 > 0 .and. cell2 > 0) then
- do k=1,grid % nVertLevels
- flux = dvEdge(iEdge) * h_edge(k,iEdge) * u(k,iEdge) * ( &
- 0.5*(theta(k,cell1) + theta(k,cell2)) )
- tend_theta(k,cell1) = tend_theta(k,cell1) - flux
- tend_theta(k,cell2) = tend_theta(k,cell2) + flux
- end do
- end if
+ do k=1,grid % nVertLevels
+ flux = dvEdge(iEdge) * h_edge(k,iEdge) * u(k,iEdge) * ( &
+ 0.5*(theta(k,cell1) + theta(k,cell2)) )
+ tend_theta(k,cell1) = tend_theta(k,cell1) - flux
+ tend_theta(k,cell2) = tend_theta(k,cell2) + flux
+ end do
end do
else if (config_theta_adv_order == 3) then
@@ -918,37 +905,33 @@
do iEdge=1,nEdges
cell1 = cellsOnEdge(1,iEdge)
cell2 = cellsOnEdge(2,iEdge)
- if (cell1 > 0 .and. cell2 > 0) then
- do k=1,grid % nVertLevels
+ do k=1,grid % nVertLevels
- d2fdx2_cell1 = deriv_two(1,1,iEdge) * theta(k,cell1)
- d2fdx2_cell2 = deriv_two(1,2,iEdge) * theta(k,cell2)
- do i=1, grid % nEdgesOnCell % array (cell1)
- if ( grid % CellsOnCell % array (i,cell1) > 0) &
- d2fdx2_cell1 = d2fdx2_cell1 + deriv_two(i+1,1,iEdge) * theta(k,grid % CellsOnCell % array (i,cell1))
- end do
- do i=1, grid % nEdgesOnCell % array (cell2)
- if ( grid % CellsOnCell % array (i,cell2) > 0) &
- d2fdx2_cell2 = d2fdx2_cell2 + deriv_two(i+1,2,iEdge) * theta(k,grid % CellsOnCell % array (i,cell2))
- end do
+ d2fdx2_cell1 = deriv_two(1,1,iEdge) * theta(k,cell1)
+ d2fdx2_cell2 = deriv_two(1,2,iEdge) * theta(k,cell2)
+ do i=1, grid % nEdgesOnCell % array (cell1)
+ d2fdx2_cell1 = d2fdx2_cell1 + deriv_two(i+1,1,iEdge) * theta(k,grid % CellsOnCell % array (i,cell1))
+ end do
+ do i=1, grid % nEdgesOnCell % array (cell2)
+ d2fdx2_cell2 = d2fdx2_cell2 + deriv_two(i+1,2,iEdge) * theta(k,grid % CellsOnCell % array (i,cell2))
+ end do
! 3rd order stencil
- if( u(k,iEdge) > 0) then
- flux = dvEdge(iEdge) * h_edge(k,iEdge) * u(k,iEdge) * ( &
- 0.5*(theta(k,cell1) + theta(k,cell2)) &
- -(dcEdge(iEdge) **2) * (d2fdx2_cell1) / 6. )
- else
- flux = dvEdge(iEdge) * h_edge(k,iEdge) * u(k,iEdge) * ( &
- 0.5*(theta(k,cell1) + theta(k,cell2)) &
- -(dcEdge(iEdge) **2) * (d2fdx2_cell2) / 6. )
- end if
-
- tend_theta(k,cell1) = tend_theta(k,cell1) - flux
- tend_theta(k,cell2) = tend_theta(k,cell2) + flux
-
- end do
- end if
+ if( u(k,iEdge) > 0) then
+ flux = dvEdge(iEdge) * h_edge(k,iEdge) * u(k,iEdge) * ( &
+ 0.5*(theta(k,cell1) + theta(k,cell2)) &
+ -(dcEdge(iEdge) **2) * (d2fdx2_cell1) / 6. )
+ else
+ flux = dvEdge(iEdge) * h_edge(k,iEdge) * u(k,iEdge) * ( &
+ 0.5*(theta(k,cell1) + theta(k,cell2)) &
+ -(dcEdge(iEdge) **2) * (d2fdx2_cell2) / 6. )
+ end if
+
+ tend_theta(k,cell1) = tend_theta(k,cell1) - flux
+ tend_theta(k,cell2) = tend_theta(k,cell2) + flux
+
+ end do
end do
else if (config_theta_adv_order == 4) then
@@ -956,30 +939,25 @@
do iEdge=1,nEdges
cell1 = cellsOnEdge(1,iEdge)
cell2 = cellsOnEdge(2,iEdge)
- if (cell1 > 0 .and. cell2 > 0) then
- do k=1,grid % nVertLevels
+ do k=1,grid % nVertLevels
- d2fdx2_cell1 = deriv_two(1,1,iEdge) * theta(k,cell1)
- d2fdx2_cell2 = deriv_two(1,2,iEdge) * theta(k,cell2)
- do i=1, grid % nEdgesOnCell % array (cell1)
- if ( grid % CellsOnCell % array (i,cell1) > 0) &
- d2fdx2_cell1 = d2fdx2_cell1 + deriv_two(i+1,1,iEdge) * theta(k,grid % CellsOnCell % array (i,cell1))
- end do
- do i=1, grid % nEdgesOnCell % array (cell2)
- if ( grid % CellsOnCell % array (i,cell2) > 0) &
- d2fdx2_cell2 = d2fdx2_cell2 + deriv_two(i+1,2,iEdge) * theta(k,grid % CellsOnCell % array (i,cell2))
- end do
-
- flux = dvEdge(iEdge) * h_edge(k,iEdge) * u(k,iEdge) * ( &
- 0.5*(theta(k,cell1) + theta(k,cell2)) &
- -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. )
-
- tend_theta(k,cell1) = tend_theta(k,cell1) - flux
- tend_theta(k,cell2) = tend_theta(k,cell2) + flux
- end do
-
- end if
+ d2fdx2_cell1 = deriv_two(1,1,iEdge) * theta(k,cell1)
+ d2fdx2_cell2 = deriv_two(1,2,iEdge) * theta(k,cell2)
+ do i=1, grid % nEdgesOnCell % array (cell1)
+ d2fdx2_cell1 = d2fdx2_cell1 + deriv_two(i+1,1,iEdge) * theta(k,grid % CellsOnCell % array (i,cell1))
+ end do
+ do i=1, grid % nEdgesOnCell % array (cell2)
+ d2fdx2_cell2 = d2fdx2_cell2 + deriv_two(i+1,2,iEdge) * theta(k,grid % CellsOnCell % array (i,cell2))
+ end do
+
+ flux = dvEdge(iEdge) * h_edge(k,iEdge) * u(k,iEdge) * ( &
+ 0.5*(theta(k,cell1) + theta(k,cell2)) &
+ -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. )
+
+ tend_theta(k,cell1) = tend_theta(k,cell1) - flux
+ tend_theta(k,cell2) = tend_theta(k,cell2) + flux
+ end do
end do
end if
@@ -1162,18 +1140,16 @@
do iEdge=1,grid % nEdges
cell1 = cellsOnEdge(1,iEdge)
cell2 = cellsOnEdge(2,iEdge)
- if (cell1 > 0 .and. cell2 > 0) then
- do k=1,nVertLevels
- u(k,iEdge) = u(k,iEdge) + dt*tend_u(k,iEdge) &
- -(0.5*dt/dcEdge(iEdge))*( &
- (geopotential(k+1,cell2)-geopotential(k+1,cell1)) &
- +(geopotential(k ,cell2)-geopotential(k ,cell1)) &
- +cqu(k,iEdge)*(alpha(k,cell2)+alpha(k,cell1))* &
- 0.5*(pressure(k+1,cell2)-pressure(k+1,cell1) &
- +pressure(k ,cell2)-pressure(k ,cell1))) &
- -smext*dcEdge(iEdge)*(dpsdt(cell2)-dpsdt(cell1))/h_edge(k,iEdge)
- end do
- end if
+ do k=1,nVertLevels
+ u(k,iEdge) = u(k,iEdge) + dt*tend_u(k,iEdge) &
+ -(0.5*dt/dcEdge(iEdge))*( &
+ (geopotential(k+1,cell2)-geopotential(k+1,cell1)) &
+ +(geopotential(k ,cell2)-geopotential(k ,cell1)) &
+ +cqu(k,iEdge)*(alpha(k,cell2)+alpha(k,cell1))* &
+ 0.5*(pressure(k+1,cell2)-pressure(k+1,cell1) &
+ +pressure(k ,cell2)-pressure(k ,cell1))) &
+ -smext*dcEdge(iEdge)*(dpsdt(cell2)-dpsdt(cell1))/h_edge(k,iEdge)
+ end do
end do
!
@@ -1184,14 +1160,12 @@
do iEdge=1,nEdges
cell1 = cellsOnEdge(1,iEdge)
cell2 = cellsOnEdge(2,iEdge)
- if (cell1 > 0 .and. cell2 > 0) then
- 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 if
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
+ do k=1,nVertLevels
uhAvg(k,iEdge) = uhAvg(k,iEdge) + u(k,iEdge) * h_edge(k,iEdge)
end do
end do
@@ -1237,18 +1211,16 @@
!
do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- if (cell1 > 0 .and. cell2 > 0) then
- do k=1,nVertLevels
- h_edge(k,iEdge) = 0.5*(h(k,cell1)+h(k,cell2)) ! here is update of h_edge
- he_old = 0.5*(h_old(k,cell1)+h_old(k,cell2))
- flux = 0.5*(u(k,iEdge) * h_edge(k,iEdge) - u_old(k,iEdge) * he_old)* &
- (theta_old(k,cell1)+theta_old(k,cell2))*dvEdge(iEdge)
- theta(k,cell1) = theta(k,cell1) - dt*flux/areaCell(cell1)
- theta(k,cell2) = theta(k,cell2) + dt*flux/areaCell(cell2)
- end do
- end if
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ do k=1,nVertLevels
+ h_edge(k,iEdge) = 0.5*(h(k,cell1)+h(k,cell2)) ! here is update of h_edge
+ he_old = 0.5*(h_old(k,cell1)+h_old(k,cell2))
+ flux = 0.5*(u(k,iEdge) * h_edge(k,iEdge) - u_old(k,iEdge) * he_old)* &
+ (theta_old(k,cell1)+theta_old(k,cell2))*dvEdge(iEdge)
+ theta(k,cell1) = theta(k,cell1) - dt*flux/areaCell(cell1)
+ theta(k,cell2) = theta(k,cell2) + dt*flux/areaCell(cell2)
+ end do
end do
@@ -1360,16 +1332,14 @@
do iEdge=1,grid%nEdges
cell1 = cellsOnEdge(1,iEdge)
cell2 = cellsOnEdge(2,iEdge)
- if (cell1 > 0 .and. cell2 > 0) then
- do k=1,grid % nVertLevels
- do iScalar=1,num_scalars
- scalar_edge = 0.5 * (scalar_new(iScalar,k,cell1) + scalar_new(iScalar,k,cell2))
- flux = uhAvg(k,iEdge) * dvEdge(iEdge) * scalar_edge
- scalar_tend(iScalar,k,cell1) = scalar_tend(iScalar,k,cell1) - flux/areaCell(cell1)
- scalar_tend(iScalar,k,cell2) = scalar_tend(iScalar,k,cell2) + flux/areaCell(cell2)
- end do
+ do k=1,grid % nVertLevels
+ do iScalar=1,num_scalars
+ scalar_edge = 0.5 * (scalar_new(iScalar,k,cell1) + scalar_new(iScalar,k,cell2))
+ flux = uhAvg(k,iEdge) * dvEdge(iEdge) * scalar_edge
+ scalar_tend(iScalar,k,cell1) = scalar_tend(iScalar,k,cell1) - flux/areaCell(cell1)
+ scalar_tend(iScalar,k,cell2) = scalar_tend(iScalar,k,cell2) + flux/areaCell(cell2)
end do
- end if
+ end do
end do
else if (config_scalar_adv_order == 3) then
@@ -1377,53 +1347,49 @@
do iEdge=1,grid%nEdges
cell1 = cellsOnEdge(1,iEdge)
cell2 = cellsOnEdge(2,iEdge)
- if (cell1 > 0 .and. cell2 > 0) then
- do k=1,grid % nVertLevels
+ do k=1,grid % nVertLevels
- do iScalar=1,num_scalars
- d2fdx2_cell1 = deriv_two(1,1,iEdge) * scalar_new(iScalar,k,cell1)
- d2fdx2_cell2 = deriv_two(1,2,iEdge) * scalar_new(iScalar,k,cell2)
- do i=1, grid % nEdgesOnCell % array (cell1)
- if ( grid % CellsOnCell % array (i,cell1) > 0) &
- d2fdx2_cell1 = d2fdx2_cell1 + &
- deriv_two(i+1,1,iEdge) * scalar_new(iScalar,k,grid % CellsOnCell % array (i,cell1))
- end do
- do i=1, grid % nEdgesOnCell % array (cell2)
- if ( grid % CellsOnCell % array (i,cell2) > 0) &
- d2fdx2_cell2 = d2fdx2_cell2 + &
- deriv_two(i+1,2,iEdge) * scalar_new(iScalar,k,grid % CellsOnCell % array (i,cell2))
- end do
-
- if (uhAvg(k,iEdge) > 0) then
- flux = dvEdge(iEdge) * uhAvg(k,iEdge) * ( &
- 0.5*(scalar_new(iScalar,k,cell1) + scalar_new(iScalar,k,cell2)) &
- -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
- -(dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12. )
- else
- flux = dvEdge(iEdge) * uhAvg(k,iEdge) * ( &
- 0.5*(scalar_new(iScalar,k,cell1) + scalar_new(iScalar,k,cell2)) &
- -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
- +(dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12. )
- end if
+ do iScalar=1,num_scalars
+ d2fdx2_cell1 = deriv_two(1,1,iEdge) * scalar_new(iScalar,k,cell1)
+ d2fdx2_cell2 = deriv_two(1,2,iEdge) * scalar_new(iScalar,k,cell2)
+ do i=1, grid % nEdgesOnCell % array (cell1)
+ d2fdx2_cell1 = d2fdx2_cell1 + &
+ deriv_two(i+1,1,iEdge) * scalar_new(iScalar,k,grid % CellsOnCell % array (i,cell1))
+ end do
+ do i=1, grid % nEdgesOnCell % array (cell2)
+ d2fdx2_cell2 = d2fdx2_cell2 + &
+ deriv_two(i+1,2,iEdge) * scalar_new(iScalar,k,grid % CellsOnCell % array (i,cell2))
+ end do
+ if (uhAvg(k,iEdge) > 0) then
+ flux = dvEdge(iEdge) * uhAvg(k,iEdge) * ( &
+ 0.5*(scalar_new(iScalar,k,cell1) + scalar_new(iScalar,k,cell2)) &
+ -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
+ -(dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12. )
+ else
+ flux = dvEdge(iEdge) * uhAvg(k,iEdge) * ( &
+ 0.5*(scalar_new(iScalar,k,cell1) + scalar_new(iScalar,k,cell2)) &
+ -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
+ +(dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12. )
+ end if
+
! old version of the above code, with coef_3rd_order assumed to be 1.0
-! if (uhAvg(k,iEdge) > 0) then
-! flux = dvEdge(iEdge) * uhAvg(k,iEdge) * ( &
-! 0.5*(scalar_new(iScalar,k,cell1) + scalar_new(iScalar,k,cell2)) &
-! -(dcEdge(iEdge) **2) * (d2fdx2_cell1) / 6. )
-! else
-! flux = dvEdge(iEdge) * uhAvg(k,iEdge) * ( &
-! 0.5*(scalar_new(iScalar,k,cell1) + scalar_new(iScalar,k,cell2)) &
-! -(dcEdge(iEdge) **2) * (d2fdx2_cell2) / 6. )
-! end if
-
- scalar_tend(iScalar,k,cell1) = scalar_tend(iScalar,k,cell1) - flux/areaCell(cell1)
- scalar_tend(iScalar,k,cell2) = scalar_tend(iScalar,k,cell2) + flux/areaCell(cell2)
-
- end do
+! if (uhAvg(k,iEdge) > 0) then
+! flux = dvEdge(iEdge) * uhAvg(k,iEdge) * ( &
+! 0.5*(scalar_new(iScalar,k,cell1) + scalar_new(iScalar,k,cell2)) &
+! -(dcEdge(iEdge) **2) * (d2fdx2_cell1) / 6. )
+! else
+! flux = dvEdge(iEdge) * uhAvg(k,iEdge) * ( &
+! 0.5*(scalar_new(iScalar,k,cell1) + scalar_new(iScalar,k,cell2)) &
+! -(dcEdge(iEdge) **2) * (d2fdx2_cell2) / 6. )
+! end if
+
+ scalar_tend(iScalar,k,cell1) = scalar_tend(iScalar,k,cell1) - flux/areaCell(cell1)
+ scalar_tend(iScalar,k,cell2) = scalar_tend(iScalar,k,cell2) + flux/areaCell(cell2)
+
end do
- end if
+ end do
end do
else if (config_scalar_adv_order == 4) then
@@ -1431,33 +1397,29 @@
do iEdge=1,grid%nEdges
cell1 = cellsOnEdge(1,iEdge)
cell2 = cellsOnEdge(2,iEdge)
- if (cell1 > 0 .and. cell2 > 0) then
- do k=1,grid % nVertLevels
+ do k=1,grid % nVertLevels
- do iScalar=1,num_scalars
- d2fdx2_cell1 = deriv_two(1,1,iEdge) * scalar_new(iScalar,k,cell1)
- d2fdx2_cell2 = deriv_two(1,2,iEdge) * scalar_new(iScalar,k,cell2)
- do i=1, grid % nEdgesOnCell % array (cell1)
- if ( grid % CellsOnCell % array (i,cell1) > 0) &
- d2fdx2_cell1 = d2fdx2_cell1 + &
- deriv_two(i+1,1,iEdge) * scalar_new(iScalar,k,grid % CellsOnCell % array (i,cell1))
- end do
- do i=1, grid % nEdgesOnCell % array (cell2)
- if ( grid % CellsOnCell % array (i,cell2) > 0) &
- d2fdx2_cell2 = d2fdx2_cell2 + &
- deriv_two(i+1,2,iEdge) * scalar_new(iScalar,k,grid % CellsOnCell % array (i,cell2))
- end do
-
- flux = dvEdge(iEdge) * uhAvg(k,iEdge) * ( &
- 0.5*(scalar_new(iScalar,k,cell1) + scalar_new(iScalar,k,cell2)) &
- -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. )
-
- scalar_tend(iScalar,k,cell1) = scalar_tend(iScalar,k,cell1) - flux/areaCell(cell1)
- scalar_tend(iScalar,k,cell2) = scalar_tend(iScalar,k,cell2) + flux/areaCell(cell2)
- end do
+ do iScalar=1,num_scalars
+ d2fdx2_cell1 = deriv_two(1,1,iEdge) * scalar_new(iScalar,k,cell1)
+ d2fdx2_cell2 = deriv_two(1,2,iEdge) * scalar_new(iScalar,k,cell2)
+ do i=1, grid % nEdgesOnCell % array (cell1)
+ d2fdx2_cell1 = d2fdx2_cell1 + &
+ deriv_two(i+1,1,iEdge) * scalar_new(iScalar,k,grid % CellsOnCell % array (i,cell1))
+ end do
+ do i=1, grid % nEdgesOnCell % array (cell2)
+ d2fdx2_cell2 = d2fdx2_cell2 + &
+ deriv_two(i+1,2,iEdge) * scalar_new(iScalar,k,grid % CellsOnCell % array (i,cell2))
+ end do
+
+ flux = dvEdge(iEdge) * uhAvg(k,iEdge) * ( &
+ 0.5*(scalar_new(iScalar,k,cell1) + scalar_new(iScalar,k,cell2)) &
+ -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. )
+
+ scalar_tend(iScalar,k,cell1) = scalar_tend(iScalar,k,cell1) - flux/areaCell(cell1)
+ scalar_tend(iScalar,k,cell2) = scalar_tend(iScalar,k,cell2) + flux/areaCell(cell2)
end do
- end if
+ end do
end do
end if
@@ -1519,9 +1481,9 @@
real (kind=RKIND), dimension(:), pointer :: dvEdge, dcEdge, areaCell
integer, dimension(:,:), pointer :: cellsOnEdge
- real (kind=RKIND), dimension( num_scalars, grid % nEdges) :: h_flux
- real (kind=RKIND), dimension( num_scalars, grid % nCells, 2 ) :: v_flux, v_flux_upwind, s_update
- real (kind=RKIND), dimension( num_scalars, grid % nCells, 2 ) :: scale_out, scale_in
+ real (kind=RKIND), dimension( num_scalars, grid % nEdges+1) :: h_flux
+ real (kind=RKIND), dimension( num_scalars, grid % nCells+1, 2 ) :: v_flux, v_flux_upwind, s_update
+ real (kind=RKIND), dimension( num_scalars, grid % nCells+1, 2 ) :: scale_out, scale_in
real (kind=RKIND), dimension( num_scalars ) :: s_max, s_min, s_max_update, s_min_update
integer :: nVertLevels, km0, km1, ktmp, kcp1, kcm1
@@ -1604,19 +1566,17 @@
do iEdge=1,grid%nEdges
cell1 = cellsOnEdge(1,iEdge)
cell2 = cellsOnEdge(2,iEdge)
- if (cell1 > 0 .and. cell2 > 0) then
- cell_upwind = cell2
- if (uhAvg(k,iEdge) >= 0) cell_upwind = cell1
- do iScalar=1,num_scalars
- scalar_edge = 0.5 * (scalar_new(iScalar,k,cell1) + scalar_new(iScalar,k,cell2))
- h_flux(iScalar,iEdge) = dt * uhAvg(k,iEdge) * dvEdge(iEdge) * scalar_edge
- h_flux_upwind = dt * uhAvg(k,iEdge) * dvEdge(iEdge) * scalar_old(iScalar,k,cell_upwind)
- h_flux(iScalar,iEdge) = h_flux(iScalar,iEdge) - h_flux_upwind
-! h_flux(iScalar,iEdge) = 0. ! use only upwind - for testing
- s_update(iScalar,cell1,km0) = s_update(iScalar,cell1,km0) - h_flux_upwind / grid % areaCell % array(cell1)
- s_update(iScalar,cell2,km0) = s_update(iScalar,cell2,km0) + h_flux_upwind / grid % areaCell % array(cell2)
- end do
- end if
+ cell_upwind = cell2
+ if (uhAvg(k,iEdge) >= 0) cell_upwind = cell1
+ do iScalar=1,num_scalars
+ scalar_edge = 0.5 * (scalar_new(iScalar,k,cell1) + scalar_new(iScalar,k,cell2))
+ h_flux(iScalar,iEdge) = dt * uhAvg(k,iEdge) * dvEdge(iEdge) * scalar_edge
+ h_flux_upwind = dt * uhAvg(k,iEdge) * dvEdge(iEdge) * scalar_old(iScalar,k,cell_upwind)
+ h_flux(iScalar,iEdge) = h_flux(iScalar,iEdge) - h_flux_upwind
+! h_flux(iScalar,iEdge) = 0. ! use only upwind - for testing
+ s_update(iScalar,cell1,km0) = s_update(iScalar,cell1,km0) - h_flux_upwind / grid % areaCell % array(cell1)
+ s_update(iScalar,cell2,km0) = s_update(iScalar,cell2,km0) + h_flux_upwind / grid % areaCell % array(cell2)
+ end do
end do
else if (config_scalar_adv_order >= 3) then
@@ -1624,44 +1584,40 @@
do iEdge=1,grid%nEdges
cell1 = cellsOnEdge(1,iEdge)
cell2 = cellsOnEdge(2,iEdge)
- if (cell1 > 0 .and. cell2 > 0) then
- cell_upwind = cell2
- if (uhAvg(k,iEdge) >= 0) cell_upwind = cell1
- do iScalar=1,num_scalars
+ cell_upwind = cell2
+ if (uhAvg(k,iEdge) >= 0) cell_upwind = cell1
+ do iScalar=1,num_scalars
+
+ d2fdx2_cell1 = deriv_two(1,1,iEdge) * scalar_new(iScalar,k,cell1)
+ d2fdx2_cell2 = deriv_two(1,2,iEdge) * scalar_new(iScalar,k,cell2)
+ do i=1, grid % nEdgesOnCell % array (cell1)
+ d2fdx2_cell1 = d2fdx2_cell1 + &
+ deriv_two(i+1,1,iEdge) * scalar_new(iScalar,k,grid % CellsOnCell % array (i,cell1))
+ end do
+ do i=1, grid % nEdgesOnCell % array (cell2)
+ d2fdx2_cell2 = d2fdx2_cell2 + &
+ deriv_two(i+1,2,iEdge) * scalar_new(iScalar,k,grid % CellsOnCell % array (i,cell2))
+ end do
+
+ if (uhAvg(k,iEdge) > 0) then
+ flux = dvEdge(iEdge) * uhAvg(k,iEdge) * ( &
+ 0.5*(scalar_new(iScalar,k,cell1) + scalar_new(iScalar,k,cell2)) &
+ -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
+ -(dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12. )
+ else
+ flux = dvEdge(iEdge) * uhAvg(k,iEdge) * ( &
+ 0.5*(scalar_new(iScalar,k,cell1) + scalar_new(iScalar,k,cell2)) &
+ -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
+ +(dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12. )
+ end if
- d2fdx2_cell1 = deriv_two(1,1,iEdge) * scalar_new(iScalar,k,cell1)
- d2fdx2_cell2 = deriv_two(1,2,iEdge) * scalar_new(iScalar,k,cell2)
- do i=1, grid % nEdgesOnCell % array (cell1)
- if ( grid % CellsOnCell % array (i,cell1) > 0) &
- d2fdx2_cell1 = d2fdx2_cell1 + &
- deriv_two(i+1,1,iEdge) * scalar_new(iScalar,k,grid % CellsOnCell % array (i,cell1))
- end do
- do i=1, grid % nEdgesOnCell % array (cell2)
- if ( grid % CellsOnCell % array (i,cell2) > 0) &
- d2fdx2_cell2 = d2fdx2_cell2 + &
- deriv_two(i+1,2,iEdge) * scalar_new(iScalar,k,grid % CellsOnCell % array (i,cell2))
- end do
-
- if (uhAvg(k,iEdge) > 0) then
- flux = dvEdge(iEdge) * uhAvg(k,iEdge) * ( &
- 0.5*(scalar_new(iScalar,k,cell1) + scalar_new(iScalar,k,cell2)) &
- -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
- -(dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12. )
- else
- flux = dvEdge(iEdge) * uhAvg(k,iEdge) * ( &
- 0.5*(scalar_new(iScalar,k,cell1) + scalar_new(iScalar,k,cell2)) &
- -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
- +(dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12. )
- end if
-
- h_flux(iScalar,iEdge) = dt * flux
- h_flux_upwind = dt * uhAvg(k,iEdge) * dvEdge(iEdge) * scalar_old(iScalar,k,cell_upwind)
- h_flux(iScalar,iEdge) = h_flux(iScalar,iEdge) - h_flux_upwind
-! h_flux(iScalar,iEdge) = 0. ! use only upwind - for testing
- s_update(iScalar,cell1,km0) = s_update(iScalar,cell1,km0) - h_flux_upwind / grid % areaCell % array(cell1)
- s_update(iScalar,cell2,km0) = s_update(iScalar,cell2,km0) + h_flux_upwind / grid % areaCell % array(cell2)
- end do
- end if
+ h_flux(iScalar,iEdge) = dt * flux
+ h_flux_upwind = dt * uhAvg(k,iEdge) * dvEdge(iEdge) * scalar_old(iScalar,k,cell_upwind)
+ h_flux(iScalar,iEdge) = h_flux(iScalar,iEdge) - h_flux_upwind
+! h_flux(iScalar,iEdge) = 0. ! use only upwind - for testing
+ s_update(iScalar,cell1,km0) = s_update(iScalar,cell1,km0) - h_flux_upwind / grid % areaCell % array(cell1)
+ s_update(iScalar,cell2,km0) = s_update(iScalar,cell2,km0) + h_flux_upwind / grid % areaCell % array(cell2)
+ end do
end do
end if
@@ -1691,24 +1647,22 @@
end do
do i = 1, grid % nEdgesOnCell % array(iCell) ! go around the edges of each cell
- if (grid % cellsOnCell % array(i,iCell) > 0) then
- do iScalar=1,num_scalars
+ do iScalar=1,num_scalars
- s_max(iScalar) = max(scalar_old(iScalar,k,grid % cellsOnCell % array(i,iCell)), s_max(iScalar))
- s_min(iScalar) = min(scalar_old(iScalar,k,grid % cellsOnCell % array(i,iCell)), s_min(iScalar))
+ s_max(iScalar) = max(scalar_old(iScalar,k,grid % cellsOnCell % array(i,iCell)), s_max(iScalar))
+ s_min(iScalar) = min(scalar_old(iScalar,k,grid % cellsOnCell % array(i,iCell)), s_min(iScalar))
- iEdge = grid % EdgesOnCell % array (i,iCell)
- if (iCell == cellsOnEdge(1,iEdge)) then
- fdir = 1.0
- else
- fdir = -1.0
- end if
- flux = -fdir * h_flux(iScalar,iEdge)/grid % areaCell % array(iCell)
- s_max_update(iScalar) = s_max_update(iScalar) + max(0.,flux)
- s_min_update(iScalar) = s_min_update(iScalar) + min(0.,flux)
-
- end do
- end if
+ iEdge = grid % EdgesOnCell % array (i,iCell)
+ if (iCell == cellsOnEdge(1,iEdge)) then
+ fdir = 1.0
+ else
+ fdir = -1.0
+ end if
+ flux = -fdir * h_flux(iScalar,iEdge)/grid % areaCell % array(iCell)
+ s_max_update(iScalar) = s_max_update(iScalar) + max(0.,flux)
+ s_min_update(iScalar) = s_min_update(iScalar) + min(0.,flux)
+
+ end do
end do
@@ -1747,17 +1701,15 @@
do iEdge = 1, grid % nEdges
cell1 = grid % cellsOnEdge % array(1,iEdge)
cell2 = grid % cellsOnEdge % array(2,iEdge)
- if (cell1 > 0 .and. cell2 > 0) then
- do iScalar=1,num_scalars
- flux = h_flux(iScalar,iEdge)
- if (flux > 0) then
- flux = flux * min(scale_out(iScalar,cell1,km0), scale_in(iScalar,cell2,km0))
- else
- flux = flux * min(scale_in(iScalar,cell1,km0), scale_out(iScalar,cell2,km0))
- end if
- h_flux(iScalar,iEdge) = flux
- end do
- end if
+ do iScalar=1,num_scalars
+ flux = h_flux(iScalar,iEdge)
+ if (flux > 0) then
+ flux = flux * min(scale_out(iScalar,cell1,km0), scale_in(iScalar,cell2,km0))
+ else
+ flux = flux * min(scale_in(iScalar,cell1,km0), scale_out(iScalar,cell2,km0))
+ end if
+ h_flux(iScalar,iEdge) = flux
+ end do
end do
! rescale the vertical flux
@@ -1792,14 +1744,12 @@
do iEdge=1,grid%nEdges
cell1 = cellsOnEdge(1,iEdge)
cell2 = cellsOnEdge(2,iEdge)
- if (cell1 > 0 .and. cell2 > 0) then
- do iScalar=1,num_scalars
- s_update(iScalar,cell1,km0) = s_update(iScalar,cell1,km0) - &
- h_flux(iScalar,iEdge) / grid % areaCell % array(cell1)
- s_update(iScalar,cell2,km0) = s_update(iScalar,cell2,km0) + &
- h_flux(iScalar,iEdge) / grid % areaCell % array(cell2)
- end do
- end if
+ do iScalar=1,num_scalars
+ s_update(iScalar,cell1,km0) = s_update(iScalar,cell1,km0) - &
+ h_flux(iScalar,iEdge) / grid % areaCell % array(cell1)
+ s_update(iScalar,cell2,km0) = s_update(iScalar,cell2,km0) + &
+ h_flux(iScalar,iEdge) / grid % areaCell % array(cell2)
+ end do
end do
! decouple from mass
@@ -1906,11 +1856,9 @@
do iEdge=1,nEdges
cell1 = cellsOnEdge(1,iEdge)
cell2 = cellsOnEdge(2,iEdge)
- if (cell1 > 0 .and. cell2 > 0) then
- do k=1,nVertLevels
- h_edge(k,iEdge) = 0.5 * (h(k,cell1) + h(k,cell2))
- end do
- end if
+ do k=1,nVertLevels
+ h_edge(k,iEdge) = 0.5 * (h(k,cell1) + h(k,cell2))
+ end do
end do
!
@@ -1918,16 +1866,10 @@
!
circulation(:,:) = 0.0
do iEdge=1,nEdges
- if (verticesOnEdge(1,iEdge) > 0) then
- do k=1,nVertLevels
- circulation(k,verticesOnEdge(1,iEdge)) = circulation(k,verticesOnEdge(1,iEdge)) - dcEdge(iEdge) * u(k,iEdge)
- end do
- end if
- if (verticesOnEdge(2,iEdge) > 0) then
- do k=1,nVertLevels
- circulation(k,verticesOnEdge(2,iEdge)) = circulation(k,verticesOnEdge(2,iEdge)) + dcEdge(iEdge) * u(k,iEdge)
- end do
- end if
+ do k=1,nVertLevels
+ circulation(k,verticesOnEdge(1,iEdge)) = circulation(k,verticesOnEdge(1,iEdge)) - dcEdge(iEdge) * u(k,iEdge)
+ circulation(k,verticesOnEdge(2,iEdge)) = circulation(k,verticesOnEdge(2,iEdge)) + dcEdge(iEdge) * u(k,iEdge)
+ end do
end do
do iVertex=1,nVertices
do k=1,nVertLevels
@@ -1943,16 +1885,10 @@
do iEdge=1,nEdges
cell1 = cellsOnEdge(1,iEdge)
cell2 = cellsOnEdge(2,iEdge)
- if (cell1 > 0) then
- do k=1,nVertLevels
- divergence(k,cell1) = divergence(k,cell1) + u(k,iEdge)*dvEdge(iEdge)
- end do
- end if
- if(cell2 > 0) then
- do k=1,nVertLevels
- divergence(k,cell2) = divergence(k,cell2) - u(k,iEdge)*dvEdge(iEdge)
- end do
- end if
+ do k=1,nVertLevels
+ divergence(k,cell1) = divergence(k,cell1) + u(k,iEdge)*dvEdge(iEdge)
+ divergence(k,cell2) = divergence(k,cell2) - u(k,iEdge)*dvEdge(iEdge)
+ end do
end do
do iCell = 1,nCells
r = 1.0 / areaCell(iCell)
@@ -1985,11 +1921,9 @@
do iEdge = 1,nEdges
do i=1,nEdgesOnEdge(iEdge)
eoe = edgesOnEdge(i,iEdge)
- if (eoe > 0) then
- do k = 1,nVertLevels
- v(k,iEdge) = v(k,iEdge) + weightsOnEdge(i,iEdge) * u(k, eoe)
- end do
- end if
+ do k = 1,nVertLevels
+ v(k,iEdge) = v(k,iEdge) + weightsOnEdge(i,iEdge) * u(k, eoe)
+ end do
end do
end do
@@ -2001,7 +1935,7 @@
!
VTX_LOOP: do iVertex = 1,nVertices
do i=1,grid % vertexDegree
- if (cellsOnVertex(i,iVertex) <= 0) cycle VTX_LOOP
+ if (cellsOnVertex(i,iVertex) > nCells) cycle VTX_LOOP
end do
do k=1,nVertLevels
h_vertex = 0.0
@@ -2036,12 +1970,10 @@
pv_edge(:,:) = 0.0
do iVertex = 1,nVertices
do i=1,grid % vertexDegree
- iEdge = edgesOnVertex(i,iVertex)
- if(iEdge > 0) then
- do k=1,nVertLevels
+ iEdge = edgesOnVertex(i,iVertex)
+ do k=1,nVertLevels
pv_edge(k,iEdge) = pv_edge(k,iEdge) + 0.5 * pv_vertex(k,iVertex)
- end do
- end if
+ end do
end do
end do
! tdr
@@ -2065,12 +1997,10 @@
pv_cell(:,:) = 0.0
do iVertex = 1, nVertices
do i=1,grid % vertexDegree
- iCell = cellsOnVertex(i,iVertex)
- if( iCell > 0) then
- do k = 1,nVertLevels
+ iCell = cellsOnVertex(i,iVertex)
+ do k = 1,nVertLevels
pv_cell(k,iCell) = pv_cell(k,iCell) + kiteAreasOnVertex(i, iVertex) * pv_vertex(k, iVertex) / areaCell(iCell)
- end do
- end if
+ end do
end do
end do
! tdr
@@ -2082,12 +2012,10 @@
!
gradPVn(:,:) = 0.0
do iEdge = 1,nEdges
- if( cellsOnEdge(1,iEdge) > 0 .and. cellsOnEdge(2,iEdge) > 0) then
- do k = 1,nVertLevels
+ do k = 1,nVertLevels
gradPVn(k,iEdge) = (pv_cell(k,cellsOnEdge(2,iEdge)) - pv_cell(k,cellsOnEdge(1,iEdge))) / &
dcEdge(iEdge)
- end do
- end if
+ end do
end do
! tdr
@@ -2102,4 +2030,84 @@
end subroutine compute_solve_diagnostics
+
+ subroutine compute_w (s_new, s_old, grid, dt )
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Compute (diagnose) vertical velocity (used by physics)
+ !
+ ! Input: s_new - current model state
+ ! s_old - previous model state
+ ! grid - grid metadata
+ ! dt - timestep between new and old
+ !
+ ! Output: w (m/s)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (grid_state), intent(inout) :: s_new
+ type (grid_state), intent(in) :: s_old
+ type (grid_meta), intent(inout) :: grid
+
+ real (kind=RKIND), intent(in) :: dt
+
+ real (kind=RKIND), dimension(:,:), pointer :: geo_new, geo_old, u, ww, h, w
+ real (kind=RKIND), dimension(:), pointer :: dvEdge, rdnw, fnm, fnp
+
+ integer :: iEdge, iCell, k, cell1, cell2
+ real (kind=RKIND), dimension( grid % nVertlevels + 1 ) :: wdwn
+ real (kind=RKIND) :: flux
+
+ geo_new => s_new % geopotential % array
+ geo_old => s_old % geopotential % array
+ u => s_new % u % array
+ ww => s_new % ww % array
+ h => s_new % h % array
+ w => s_new % w % array
+ dvEdge => grid % dvEdge % array
+ rdnw => grid % rdnw % array
+ fnm => grid % fnm % array
+ fnp => grid % fnp % array
+
+ w = 0.
+
+ do iCell=1, grid % nCellsSolve
+ wdwn(1) = 0.
+ do k=2,grid % nVertlevels + 1
+ wdwn(k) = (0.5*(ww(k,iCell)+ww(k-1,iCell))/h(k-1,iCell)) &
+ *rdnw(k-1)*(geo_new(k,iCell)-geo_new(k-1,iCell))
+ enddo
+ w(1,iCell) = 0.
+ do k=2, grid % nVertLevels
+ w(k,iCell) = (((geo_new(k,iCell)-geo_old(k,iCell))/dt)+ &
+ fnm(k)*wdwn(k+1)+fnp(k)*wdwn(k))/gravity
+ enddo
+ k = grid % nVertLevels + 1
+ w(k,iCell) = ((geo_new(k,iCell)-geo_old(k,iCell))/dt)/gravity
+ enddo
+
+ do iEdge=1, grid % nEdges
+ cell1 = grid % cellsOnEdge % array (1,iEdge)
+ cell2 = grid % cellsOnEdge % array (2,iEdge)
+ if (cell1 <= grid % nCellsSolve .or. cell2 <= grid % nCellsSolve ) then
+ do k=2, grid % nVertLevels
+ flux = 0.25*(u(k,iEdge)+u(k-1,iEdge)*(geo_new(k,cell2)-geo_new(k,cell1))) * dvEdge(iEdge) / gravity
+ w(k,cell1) = w(k,cell1) + flux/ grid % AreaCell % array (cell1)
+ w(k,cell2) = w(k,cell2) + flux/ grid % AreaCell % array (cell2)
+ enddo
+ k = 1
+ flux = 0.5*(1.5*u(1,iEdge)-0.5*u(2,iEdge)*(geo_new(k,cell2)-geo_new(k,cell1))) * dvEdge(iEdge) / gravity
+ w(k,cell1) = w(k,cell1) + flux/ grid % AreaCell % array (cell1)
+ w(k,cell2) = w(k,cell2) + flux/ grid % AreaCell % array (cell2)
+
+ k = grid % nVertLevels + 1
+ flux = 0.5*(1.5*u(k-1,iEdge)-0.5*u(k-2,iEdge)*(geo_new(k,cell2)-geo_new(k,cell1))) * dvEdge(iEdge) / gravity
+ w(k,cell1) = w(k,cell1) + flux/ grid % AreaCell % array (cell1)
+ w(k,cell2) = w(k,cell2) + flux/ grid % AreaCell % array (cell2)
+
+ end if
+ end do
+
+ end subroutine compute_w
+
end module time_integration
Modified: branches/ocean_projects/port_adv_mwh/src/core_hyd_atmos/mpas_interface.F
===================================================================
--- branches/ocean_projects/port_adv_mwh/src/core_hyd_atmos/mpas_interface.F 2010-06-18 22:07:12 UTC (rev 362)
+++ branches/ocean_projects/port_adv_mwh/src/core_hyd_atmos/mpas_interface.F 2010-06-23 17:20:20 UTC (rev 363)
@@ -17,6 +17,8 @@
use grid_types
use advection
use time_integration
+ use RBF_interpolation
+ use vector_reconstruction
implicit none
@@ -28,6 +30,9 @@
call compute_state_diagnostics(block % time_levs(1) % state, mesh)
call compute_solve_diagnostics(dt, block % time_levs(1) % state, mesh)
call initialize_advection_rk(mesh)
+ call rbfInterp_initialize(mesh)
+ call init_reconstruct(mesh)
+ call reconstruct(block % time_levs(1) % state, mesh)
end subroutine mpas_init
Modified: branches/ocean_projects/port_adv_mwh/src/core_ocean/Makefile
===================================================================
--- branches/ocean_projects/port_adv_mwh/src/core_ocean/Makefile 2010-06-18 22:07:12 UTC (rev 362)
+++ branches/ocean_projects/port_adv_mwh/src/core_ocean/Makefile 2010-06-23 17:20:20 UTC (rev 363)
@@ -19,10 +19,9 @@
mpas_interface.o: module_global_diagnostics.o module_test_cases.o module_time_integration.o
clean:
- $(RM) *.o *.mod libdycore.a
+ $(RM) *.o *.mod *.f90 libdycore.a
.F.o:
$(RM) $@ $*.mod
$(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90
$(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../framework -I../operators
- $(RM) $*.f90
Modified: branches/ocean_projects/port_adv_mwh/src/core_ocean/Registry
===================================================================
--- branches/ocean_projects/port_adv_mwh/src/core_ocean/Registry 2010-06-18 22:07:12 UTC (rev 362)
+++ branches/ocean_projects/port_adv_mwh/src/core_ocean/Registry 2010-06-23 17:20:20 UTC (rev 363)
@@ -6,9 +6,7 @@
namelist real sw_model config_dt 172.8
namelist integer sw_model config_ntimesteps 7500
namelist integer sw_model config_output_interval 500
-# mrp 100120:
namelist integer sw_model config_stats_interval 100
-# mrp 100120 end
namelist real sw_model config_visc 0.0
namelist character io config_input_name grid.nc
namelist character io config_output_name output.nc
@@ -16,7 +14,23 @@
namelist integer restart config_restart_interval 0
namelist logical restart config_do_restart false
namelist real restart config_restart_time 172800.0
+namelist character grid config_vert_grid_type isopycnal
+namelist real grid config_rho0 1028
+namelist real hmix config_hor_diffusion 2000.0
+namelist character vmix config_vert_visc_type const
+namelist character vmix config_vert_diff_type const
+namelist real vmix config_vert_viscosity 2.5e-4
+namelist real vmix config_vert_diffusion 2.5e-5
+namelist real vmix config_vmixTanhViscMax 2.5e-1
+namelist real vmix config_vmixTanhViscMin 1.0e-4
+namelist real vmix config_vmixTanhDiffMax 2.5e-2
+namelist real vmix config_vmixTanhDiffMin 1.0e-5
+namelist real vmix config_vmixTanhZMid -100
+namelist real vmix config_vmixTanhZWidth 100
+namelist character advection config_hor_tracer_adv 'centered'
+namelist character advection config_vert_tracer_adv 'centered'
+
#
# dim type name_in_file name_in_code
#
@@ -29,7 +43,7 @@
dim R3 3
dim vertexDegree vertexDegree
dim nVertLevels nVertLevels
-dim nTracers nTracers
+dim nVertLevelsP1 nVertLevels+1
#
# var type name_in_file ( dims ) iro- name_in_code super-array array_class
@@ -70,6 +84,10 @@
var real areaCell ( nCells ) iro areaCell - -
var real areaTriangle ( nVertices ) iro areaTriangle - -
+var real edgeNormalVectors ( R3 nEdges ) o edgeNormalVectors - -
+var real localVerticalUnitVectors ( R3 nCells ) o localVerticalUnitVectors - -
+var real cellTangentPlane ( R3 TWO nEdges ) o cellTangentPlane - -
+
var integer cellsOnCell ( maxEdges nCells ) iro cellsOnCell - -
var integer verticesOnCell ( maxEdges nCells ) iro verticesOnCell - -
var integer verticesOnEdge ( TWO nEdges ) iro verticesOnEdge - -
@@ -79,19 +97,30 @@
var real fEdge ( nEdges ) iro fEdge - -
var real fVertex ( nVertices ) iro fVertex - -
var real h_s ( nCells ) iro h_s - -
-var real rho ( nVertLevels nCells Time ) iro rho - -
# Arrays required for reconstruction of velocity field
var real coeffs_reconstruct ( R3 maxEdges nCells ) - coeffs_reconstruct - -
+# Arrays for z-level version of mpas-ocean
+var integer maxLevelsCell ( nCells ) iro kmaxCell - -
+var integer maxLevelsEdge ( nEdges ) iro kmaxEdge - -
+var real hZLevel ( nVertLevels ) iro hZLevel - -
+var real zMidZLevel ( nVertLevels ) iro zMidZLevel - -
+var real zTopZLevel ( nVertLevelsP1 ) iro zTopZLevel - -
+
# Boundary conditions: read from input, saved in restart and written to output
-var integer uBC ( nVertLevels nEdges ) iro uBC - -
+var integer boundaryEdge ( nVertLevels nEdges ) iro boundaryEdge - -
+var integer boundaryVertex ( nVertLevels nVertices ) iro boundaryVertex - -
var real u_src ( nVertLevels nEdges ) iro u_src - -
# Prognostic variables: read from input, saved in restart, and written to output
var real u ( nVertLevels nEdges Time ) iro u - -
var real h ( nVertLevels nCells Time ) iro h - -
-var real tracers ( nTracers nVertLevels nCells Time ) iro tracers - -
+var real rho ( nVertLevels nCells Time ) iro rho - -
+var real temperature ( nVertLevels nCells Time ) iro temperature tracers dynamics
+var real salinity ( nVertLevels nCells Time ) iro salinity tracers dynamics
+var real tracer1 ( nVertLevels nCells Time ) iro tracer1 tracers testing
+var real tracer2 ( nVertLevels nCells Time ) iro tracer2 tracers testing
# Diagnostic fields: only written to output
var real v ( nVertLevels nEdges Time ) o v - -
@@ -100,21 +129,25 @@
var real pv_edge ( nVertLevels nEdges Time ) o pv_edge - -
var real h_edge ( nVertLevels nEdges Time ) o h_edge - -
var real ke ( nVertLevels nCells Time ) o ke - -
+var real ke_edge ( nVertLevels nEdges Time ) o ke_edge - -
var real pv_vertex ( nVertLevels nVertices Time ) o pv_vertex - -
var real pv_cell ( nVertLevels nCells Time ) o pv_cell - -
var real uReconstructX ( nVertLevels nCells Time ) o uReconstructX - -
var real uReconstructY ( nVertLevels nCells Time ) o uReconstructY - -
var real uReconstructZ ( nVertLevels nCells Time ) o uReconstructZ - -
-# mrp 100112:
-var real zmid ( nVertLevels nCells Time ) o zmid - -
-var real zbot ( nVertLevels nCells Time ) o zbot - -
-var real zSurface ( nCells Time ) o zSurface - -
-var real pmid ( nVertLevels nCells Time ) o pmid - -
-var real pbot ( nVertLevels nCells Time ) o pbot - -
+var real uReconstructZonal ( nVertLevels nCells Time ) o uReconstructZonal - -
+var real uReconstructMeridional ( nVertLevels nCells Time ) o uReconstructMeridional - -
+var real zMid ( nVertLevels nCells Time ) o zMid - -
+var real zTop ( nVertLevelsP1 nCells Time ) o zTop - -
+var real zMidEdge ( nVertLevels nEdges Time ) o zMidEdge - -
+var real zTopEdge ( nVertLevelsP1 nEdges Time ) o zTopEdge - -
+var real p ( nVertLevels nCells Time ) o p - -
+var real pTop ( nVertLevelsP1 nCells Time ) o pTop - -
+var real pZLevel ( nVertLevels nCells Time ) o pZLevel - -
var real MontPot ( nVertLevels nCells Time ) o MontPot - -
-# mrp 100112 end
+var real wTop ( nVertLevelsP1 nCells Time ) o wTop - -
+var real ssh ( nCells Time ) o ssh - -
-
# Other diagnostic variables: neither read nor written to any files
var real vh ( nVertLevels nEdges Time ) - vh - -
var real circulation ( nVertLevels nVertices Time ) - circulation - -
Modified: branches/ocean_projects/port_adv_mwh/src/core_ocean/module_global_diagnostics.F
===================================================================
--- branches/ocean_projects/port_adv_mwh/src/core_ocean/module_global_diagnostics.F 2010-06-18 22:07:12 UTC (rev 362)
+++ branches/ocean_projects/port_adv_mwh/src/core_ocean/module_global_diagnostics.F 2010-06-23 17:20:20 UTC (rev 363)
@@ -32,15 +32,18 @@
integer, intent(in) :: timeIndex
real (kind=RKIND), intent(in) :: dt
- integer :: nVertLevels, nCellsSolve, nEdgesSolve, nVerticesSolve, nCellsGlobal, nEdgesGlobal, nVerticesGlobal
+ integer :: nVertLevels, nCellsSolve, nEdgesSolve, nVerticesSolve, nCellsGlobal, nEdgesGlobal, nVerticesGlobal, iTracer
+
real (kind=RKIND) :: areaCellGlobal, areaEdgeGlobal, areaTriangleGlobal
real (kind=RKIND), dimension(:), pointer :: areaCell, dcEdge, dvEdge, areaTriangle, areaEdge
real (kind=RKIND), dimension(:,:), pointer :: h, u, v, h_edge, circulation, vorticity, ke, pv_edge, pv_vertex, &
- pv_cell, gradPVn, gradPVt, zmid, zbot, pmid, pbot, MontPot
+ pv_cell, gradPVn, gradPVt, zMid, zTop, p, pTop, MontPot, wTop, rho, tracerTemp
+ real (kind=RKIND), dimension(:,:,:), pointer :: tracers
+
real (kind=RKIND) :: volumeCellGlobal, volumeEdgeGlobal, CFLNumberGlobal
real (kind=RKIND) :: localCFL, localSum
integer :: elementIndex, variableIndex, nVariables, nSums, nMaxes, nMins
- integer :: timeLevel
+ integer :: timeLevel,k,i
integer, parameter :: kMaxVariables = 1024 ! this must be a little more than double the number of variables to be reduced
@@ -62,7 +65,10 @@
h => state % h % array
u => state % u % array
+ rho => state % rho % array
+ tracers => state % tracers % array
v => state % v % array
+ wTop => state % wTop % array
h_edge => state % h_edge % array
circulation => state % circulation % array
vorticity => state % vorticity % array
@@ -72,10 +78,10 @@
pv_cell => state % pv_cell % array
gradPVn => state % gradPVn % array
gradPVt => state % gradPVt % array
- zmid => state % zmid % array
- zbot => state % zbot % array
- pmid => state % pmid % array
- pbot => state % pbot % array
+ zMid => state % zMid % array
+ zTop => state % zTop % array
+ p => state % p % array
+ pTop => state % pTop % array
MontPot => state % MontPot % array
variableIndex = 0
@@ -148,28 +154,28 @@
gradPVt(:,1:nEdgesSolve), sums(variableIndex), mins(variableIndex), maxes(variableIndex), verticalSumMins(variableIndex), &
verticalSumMaxes(variableIndex))
- ! zmid
+ ! zMid
variableIndex = variableIndex + 1
call computeFieldAreaWeightedLocalStats(dminfo, nVertLevels, nCellsSolve, areaCell(1:nCellsSolve), &
- zmid(:,1:nCellsSolve), sums(variableIndex), mins(variableIndex), maxes(variableIndex), verticalSumMins(variableIndex), &
+ zMid(:,1:nCellsSolve), sums(variableIndex), mins(variableIndex), maxes(variableIndex), verticalSumMins(variableIndex), &
verticalSumMaxes(variableIndex))
- ! zbot
+ ! zTop
variableIndex = variableIndex + 1
call computeFieldAreaWeightedLocalStats(dminfo, nVertLevels, nCellsSolve, areaCell(1:nCellsSolve), &
- zbot(:,1:nCellsSolve), sums(variableIndex), mins(variableIndex), maxes(variableIndex), verticalSumMins(variableIndex), &
+ zTop(:,1:nCellsSolve), sums(variableIndex), mins(variableIndex), maxes(variableIndex), verticalSumMins(variableIndex), &
verticalSumMaxes(variableIndex))
- ! pmid
+ ! p
variableIndex = variableIndex + 1
call computeFieldVolumeWeightedLocalStats(dminfo, nVertLevels, nCellsSolve, areaCell(1:nCellsSolve), h(:,1:nCellsSolve), &
- pmid(:,1:nCellsSolve), sums(variableIndex), mins(variableIndex), maxes(variableIndex), verticalSumMins(variableIndex), &
+ p(:,1:nCellsSolve), sums(variableIndex), mins(variableIndex), maxes(variableIndex), verticalSumMins(variableIndex), &
verticalSumMaxes(variableIndex))
- ! pbot
+ ! pTop
variableIndex = variableIndex + 1
call computeFieldVolumeWeightedLocalStats(dminfo, nVertLevels, nCellsSolve, areaCell(1:nCellsSolve), h(:,1:nCellsSolve), &
- pbot(:,1:nCellsSolve), sums(variableIndex), mins(variableIndex), maxes(variableIndex), verticalSumMins(variableIndex), &
+ pTop(:,1:nCellsSolve), sums(variableIndex), mins(variableIndex), maxes(variableIndex), verticalSumMins(variableIndex), &
verticalSumMaxes(variableIndex))
! MontPot
@@ -178,6 +184,23 @@
MontPot(:,1:nCellsSolve), sums(variableIndex), mins(variableIndex), maxes(variableIndex), verticalSumMins(variableIndex), &
verticalSumMaxes(variableIndex))
+ ! wTop vertical velocity
+ variableIndex = variableIndex + 1
+ call computeFieldVolumeWeightedLocalStats(dminfo, nVertLevels+1, nCellsSolve, areaCell(1:nCellsSolve), h(:,1:nCellsSolve), &
+ wTop(:,1:nCellsSolve), sums(variableIndex), mins(variableIndex), maxes(variableIndex), verticalSumMins(variableIndex), &
+ verticalSumMaxes(variableIndex))
+
+ ! Tracers
+ allocate(tracerTemp(nVertLevels,nCellsSolve))
+ do iTracer=1,num_tracers
+ variableIndex = variableIndex + 1
+ tracerTemp = Tracers(iTracer,:,1:nCellsSolve)
+ call computeFieldVolumeWeightedLocalStats(dminfo, nVertLevels, nCellsSolve, areaCell(1:nCellsSolve), h(:,1:nCellsSolve), &
+ tracerTemp, sums(variableIndex), mins(variableIndex), maxes(variableIndex), verticalSumMins(variableIndex), &
+ verticalSumMaxes(variableIndex))
+ enddo
+ deallocate(tracerTemp)
+
nVariables = variableIndex
nSums = nVariables
nMins = nVariables
@@ -284,19 +307,19 @@
variableIndex = variableIndex + 1
averages(variableIndex) = sums(variableIndex)/volumeEdgeGlobal
- ! zmid
+ ! zMid
variableIndex = variableIndex + 1
averages(variableIndex) = sums(variableIndex)/(areaCellGlobal*nVertLevels)
- ! zbot
+ ! zTop
variableIndex = variableIndex + 1
averages(variableIndex) = sums(variableIndex)/(areaCellGlobal*nVertLevels)
- ! pmid
+ ! p
variableIndex = variableIndex + 1
averages(variableIndex) = sums(variableIndex)/volumeCellGlobal
- ! pbot
+ ! pTop
variableIndex = variableIndex + 1
averages(variableIndex) = sums(variableIndex)/volumeCellGlobal
@@ -304,6 +327,16 @@
variableIndex = variableIndex + 1
averages(variableIndex) = sums(variableIndex)/volumeCellGlobal
+ ! wTop vertical velocity
+ variableIndex = variableIndex + 1
+ averages(variableIndex) = sums(variableIndex)/volumeCellGlobal
+
+ ! Tracers
+ do iTracer=1,num_tracers
+ variableIndex = variableIndex + 1
+ averages(variableIndex) = sums(variableIndex)/volumeCellGlobal
+ enddo
+
! write out the data to files
if (dminfo % my_proc_id == IO_NODE) then
fileID = getFreeUnit()
Modified: branches/ocean_projects/port_adv_mwh/src/core_ocean/module_test_cases.F
===================================================================
--- branches/ocean_projects/port_adv_mwh/src/core_ocean/module_test_cases.F 2010-06-18 22:07:12 UTC (rev 362)
+++ branches/ocean_projects/port_adv_mwh/src/core_ocean/module_test_cases.F 2010-06-23 17:20:20 UTC (rev 363)
@@ -23,9 +23,17 @@
integer :: i, iCell, iEdge, iVtx, iLevel
type (block_type), pointer :: block_ptr
+ type (dm_info) :: dminfo
+
+ ! mrp 100507: for diagnostic output
+ integer :: iTracer
+ real (kind=RKIND), dimension(:), pointer :: xCell,yCell, &
+ hZLevel, zMidZLevel, zTopZLevel
real (kind=RKIND), dimension(:,:), pointer :: h, u, u_src, rho
+ real (kind=RKIND), dimension(:,:,:), pointer :: tracers
real (kind=RKIND) :: delta_rho
integer :: nCells, nEdges, nVertices, nVertLevels
+ ! mrp 100507 end: for diagnostic output
if (config_test_case == 0) then
write(0,*) 'Using initial conditions supplied in input file'
@@ -71,90 +79,115 @@
end do
else
- write(0,*) &
- 'Only test case 1, 2, 5, and 6 are currently supported.'
- stop
+ write(0,*) 'Abort: config_test_case=',config_test_case
+ write(0,*) 'Only test case 1, 2, 5, and 6 ', &
+ 'are currently supported. '
+ call dmpar_abort(dminfo)
end if
- ! mrp 100121:
- !
- ! Initialize u_src, rho, alpha
- ! This is a temporary fix until everything is specified correctly
- ! in an initial conditions file.
- !
block_ptr => domain % blocklist
do while (associated(block_ptr))
+
+ do i=2,nTimeLevs
+ call copy_state(block_ptr % time_levs(1) % state, &
+ block_ptr % time_levs(i) % state)
+ end do
+
+ block_ptr => block_ptr % next
+ end do
+
+ ! Initialize z-level grid variables from h, read in from input file.
+ block_ptr => domain % blocklist
+ do while (associated(block_ptr))
h => block_ptr % time_levs(1) % state % h % array
u => block_ptr % time_levs(1) % state % u % array
rho => block_ptr % time_levs(1) % state % rho % array
-
+ tracers => block_ptr % time_levs(1) % state % tracers % array
u_src => block_ptr % mesh % u_src % array
+ xCell => block_ptr % mesh % xCell % array
+ yCell => block_ptr % mesh % yCell % array
+ hZLevel => block_ptr % mesh % hZLevel % array
+ zMidZLevel => block_ptr % mesh % zMidZLevel % array
+ zTopZLevel => block_ptr % mesh % zTopZLevel % array
+
nCells = block_ptr % mesh % nCells
nEdges = block_ptr % mesh % nEdges
nVertices = block_ptr % mesh % nVertices
nVertLevels = block_ptr % mesh % nVertLevels
- ! Momentum forcing u_src
- if (config_test_case > 0) then
- ! for shallow water test cases:
- u_src = 0.0
- elseif (config_test_case == 0 ) then
- ! for rectangular basin:
- do iEdge=1,nEdges
- u_src(1:nVertLevels, iEdge) = u_src(1, iEdge) / nVertLevels
- end do
- endif
+ if (config_vert_grid_type.eq.'zlevel') then
+ ! These should eventually be in an input file. For now
+ ! I just read them in from h(:,1).
+ hZLevel = h(:,1)
+ zTopZLevel(1) = 0.0
+ do iLevel = 1,nVertLevels
+ zMidZLevel(iLevel) = zTopZLevel(iLevel)-0.5*hZLevel(iLevel)
+ zTopZLevel(iLevel+1) = zTopZLevel(iLevel)- hZLevel(iLevel)
+ enddo
+ if (config_vert_grid_type.eq.'isopycnal') then
+ print *, ' Using isopycnal coordinates'
+ elseif (config_vert_grid_type.eq.'zlevel') then
+ print *, ' Using z-level coordinates'
+ else
+ print *, ' Incorrect choice of config_vert_grid_type:',&
+ config_vert_grid_type
+ call dmpar_abort(dminfo)
+ endif
- ! define the density for multiple layers
- delta_rho=0.0
- do iLevel = 1,nVertLevels
- rho(iLevel,1) = delta_rho*(iLevel-1)
- enddo
- rho(:,1) = rho(:,1) - sum(rho(:,1))/nVertLevels + 1000.0
- do iLevel = 1,nVertLevels
- rho(iLevel,:) = rho(iLevel,1)
- enddo
+ ! Set tracers, if not done in grid.nc file
+ !tracers = 0.0
+ do iCell = 1,nCells
+ do iLevel = 1,nVertLevels
+ ! for 20 layer test
+ ! tracers(index_temperature,iLevel,iCell) = 5.0 ! temperature
+ ! tracers(index_salinity,iLevel,iCell) = 1.4 + iLevel*0.6 ! salinity
-#ifdef EXPAND_LEVELS
- print '(10a)', 'EXPAND_LEVELS compiler flag is on.', &
- ' Copying h and u from k=1 to other levels.'
- print '(a,i5)', 'EXPAND_LEVELS =', EXPAND_LEVELS
- print '(a,i5)', 'nVertLevels =', nVertLevels
- do iCell=1,nCells
- ! make the total thickness equal to the single-layer thickness:
- h(1:nVertLevels, iCell) = h(1,iCell) / nVertLevels
- end do
+ ! for x3, 25 layer test
+ tracers(index_temperature,iLevel,iCell) = 10.0 ! temperature
+ tracers(index_salinity,iLevel,iCell) = 1.4 + iLevel*0.6 ! salinity
- do iEdge=1,nEdges
- u(2:nVertLevels, iEdge) = u(1,iEdge)
- end do
-#else
- print '(10a)', 'EXPAND_LEVELS compiler flag is off.'
-#endif
+ tracers(index_tracer1,iLevel,iCell) = 1.0
+ tracers(index_tracer2,iLevel,iCell) = &
+ (yCell(iCell)/4000.e3 + xCell(iCell)/2500.e3 )/2.0
- do i=2,nTimeLevs
- call copy_state(block_ptr % time_levs(1) % state, &
- block_ptr % time_levs(i) % state)
- end do
+ rho(iLevel,iCell) = 1000.0*( 1.0 &
+ - 2.5e-4*tracers(index_temperature,iLevel,iCell) &
+ + 7.6e-4*tracers(index_salinity,iLevel,iCell))
+ enddo
+ enddo
+
+ endif
+
! print some diagnostics
print '(10a)', 'ilevel',&
' rho ',&
' min u max u ',&
+ ' min u_src max u_src ', &
' min h max h ',&
- ' min u_src max u_src '
+ ' hZLevel zMidZlevel', &
+ ' zTopZlevel'
do iLevel = 1,nVertLevels
print '(i5,20es12.4)', ilevel, rho(ilevel,1), &
- minval(u(iLevel,:)), maxval(u(iLevel,:)), &
- minval(h(iLevel,:)), maxval(h(iLevel,:)), &
- minval(u_src(iLevel,:)), maxval(u_src(iLevel,:))
+ minval(u(iLevel,1:nEdges)), maxval(u(iLevel,1:nEdges)), &
+ minval(u_src(iLevel,1:nEdges)), maxval(u_src(iLevel,1:nEdges)), &
+ minval(h(iLevel,1:nCells)), maxval(h(iLevel,1:nCells)), &
+ hZLevel(iLevel),zMidZlevel(iLevel),zTopZlevel(iLevel)
enddo
+ print '(10a)', 'itracer ilevel min tracer max tracer'
+ do iTracer=1,num_tracers
+ do iLevel = 1,nVertLevels
+ print '(2i5,20es12.4)', iTracer,ilevel, &
+ minval(tracers(itracer,iLevel,1:nCells)), maxval(tracers(itracer,iLevel,1:nCells))
+ enddo
+ enddo
+
block_ptr => block_ptr % next
end do
- ! mrp 100121 end
+
end subroutine setup_sw_test_case
Modified: branches/ocean_projects/port_adv_mwh/src/core_ocean/module_time_integration.F
===================================================================
--- branches/ocean_projects/port_adv_mwh/src/core_ocean/module_time_integration.F 2010-06-18 22:07:12 UTC (rev 362)
+++ branches/ocean_projects/port_adv_mwh/src/core_ocean/module_time_integration.F 2010-06-23 17:20:20 UTC (rev 363)
@@ -4,14 +4,10 @@
use configure
use constants
use dmpar
- ! xsad 10-02-05:
use vector_reconstruction
- ! xsad 10-02-05 end
-
contains
-
subroutine timestep(domain, dt)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Advance model state forward in time by the specified time step
@@ -26,27 +22,28 @@
type (domain_type), intent(inout) :: domain
real (kind=RKIND), intent(in) :: dt
- integer errorcode,ierr
+ type (dm_info) :: dminfo
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,*) 'Abort: Unknown time integration option '&
+ //trim(config_time_integration)
write(0,*) 'Currently, only ''RK4'' is supported.'
- stop
+ call dmpar_abort(dminfo)
end if
block => domain % blocklist
do while (associated(block))
- block % time_levs(2) % state % xtime % scalar = block % time_levs(1) % state % xtime % scalar + dt
- ! mrp 100310 I added this to avoid running with NaNs
+ block % time_levs(2) % state % xtime % scalar &
+ = block % time_levs(1) % state % xtime % scalar + dt
+
if (isNaN(sum(block % time_levs(2) % state % u % array))) then
- print *, 'Stopping: NaN detected'
- call MPI_abort(MPI_COMM_WORLD,errorcode,ierr)
+ write(0,*) 'Abort: NaN detected'
+ call dmpar_abort(dminfo)
endif
- ! mrp 100310 end
block => block % next
end do
@@ -70,7 +67,7 @@
type (domain_type), intent(inout) :: domain
real (kind=RKIND), intent(in) :: dt
- integer :: iCell, k
+ integer :: iCell, k, i
type (block_type), pointer :: block
integer, parameter :: PROVIS = 1
@@ -114,11 +111,10 @@
rk_substep_weights(4) = 0.
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! BEGIN RK loop
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
do rk_step = 1, 4
-
! --- update halos for diagnostic variables
block => domain % blocklist
@@ -133,10 +129,9 @@
block => domain % blocklist
do while (associated(block))
-
call compute_tend(block % intermediate_step(TEND), block % intermediate_step(PROVIS), block % mesh)
call compute_scalar_tend(block % intermediate_step(TEND), block % intermediate_step(PROVIS), block % mesh)
- call enforce_uBC(block % intermediate_step(TEND), block % mesh)
+ call enforce_boundaryEdge(block % intermediate_step(TEND), block % mesh)
block => block % next
end do
@@ -151,7 +146,7 @@
block % mesh % nVertLevels, block % mesh % nCells, &
block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
call dmpar_exch_halo_field3dReal(domain % dminfo, block % intermediate_step(TEND) % tracers % array(:,:,:), &
- block % mesh % nTracers, block % mesh % nVertLevels, block % mesh % nCells, &
+ num_tracers, block % mesh % nVertLevels, block % mesh % nCells, &
block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
block => block % next
end do
@@ -161,6 +156,7 @@
if (rk_step < 4) then
block => domain % blocklist
do while (associated(block))
+
block % intermediate_step(PROVIS) % u % array(:,:) = block % time_levs(1) % state % u % array(:,:) &
+ rk_substep_weights(rk_step) * block % intermediate_step(TEND) % u % array(:,:)
block % intermediate_step(PROVIS) % h % array(:,:) = block % time_levs(1) % state % h % array(:,:) &
@@ -173,6 +169,7 @@
+ rk_substep_weights(rk_step) * block % intermediate_step(TEND) % tracers % array(:,k,iCell) &
) / block % intermediate_step(PROVIS) % h % array(k,iCell)
end do
+
end do
if (config_test_case == 1) then ! For case 1, wind field should be fixed
block % intermediate_step(PROVIS) % u % array(:,:) = block % time_levs(1) % state % u % array(:,:)
@@ -182,6 +179,8 @@
end do
end if
+
+
!--- accumulate update (for RK4)
block => domain % blocklist
@@ -190,6 +189,7 @@
+ rk_weights(rk_step) * block % intermediate_step(TEND) % u % array(:,:)
block % time_levs(2) % state % h % array(:,:) = block % time_levs(2) % state % h % array(:,:) &
+ rk_weights(rk_step) * block % intermediate_step(TEND) % h % array(:,:)
+
do iCell=1,block % mesh % nCells
do k=1,block % mesh % nVertLevels
block % time_levs(2) % state % tracers % array(:,k,iCell) = &
@@ -197,15 +197,15 @@
+ rk_weights(rk_step) * block % intermediate_step(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
!
@@ -225,10 +225,7 @@
call compute_solve_diagnostics(dt, block % time_levs(2) % state, block % mesh)
- ! xsad 10-02-09:
- ! commenting this out until we incorporate the necessary lapack routines into mpas
- !call reconstruct(block % time_levs(2) % state, block % mesh)
- ! xsad 10-02-09 end
+ call reconstruct(block % time_levs(2) % state, block % mesh)
block => block % next
end do
@@ -253,40 +250,44 @@
type (grid_meta), intent(in) :: grid
integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j
- real (kind=RKIND) :: flux, vorticity_abs, h_vertex, 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
- integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnVertex, verticesOnEdge, edgesOnCell, edgesOnEdge, edgesOnVertex
+ real (kind=RKIND) :: flux, vorticity_abs, h_vertex, workpv, q, &
+ upstream_bias, wTopEdge, rho0Inv
+ real (kind=RKIND), dimension(:), pointer :: &
+ h_s, fVertex, fEdge, dvEdge, dcEdge, areaCell, areaTriangle, &
+ zMidZLevel, zTopZLevel
+ real (kind=RKIND), dimension(:,:), pointer :: &
+ weightsOnEdge, kiteAreasOnVertex, h_edge, h, u, v, wTop, &
+ tend_h, tend_u, circulation, vorticity, ke, ke_edge, pv_edge, &
+ divergence, MontPot, pZLevel, zMidEdge, zTopEdge
+ type (dm_info) :: dminfo
+
integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge
- real (kind=RKIND) :: u_diffusion, visc
+ integer, dimension(:,:), pointer :: &
+ cellsOnEdge, cellsOnVertex, verticesOnEdge, edgesOnCell, &
+ edgesOnEdge, edgesOnVertex
+ real (kind=RKIND) :: u_diffusion
+ real (kind=RKIND), dimension(:), allocatable:: fluxVertTop,w_dudzTopEdge, vertViscTop
- !mrp 100112:
- real (kind=RKIND), dimension(:,:), pointer :: MontPot
- !mrp 100112 end
-
-!ocean
real (kind=RKIND), dimension(:,:), pointer :: u_src
real (kind=RKIND), parameter :: rho_ref = 1000.0
-!ocean
- visc = config_visc
-
h => s % h % array
u => s % u % array
v => s % v % array
+ wTop => s % wTop % array
h_edge => s % h_edge % array
circulation => s % circulation % array
vorticity => s % vorticity % array
divergence => s % divergence % array
ke => s % ke % array
+ ke_edge => s % ke_edge % array
pv_edge => s % pv_edge % array
- vh => s % vh % array
- !mrp 100112:
MontPot => s % MontPot % array
- !mrp 100112 end
+ pZLevel => s % pZLevel % array
+ zTopEdge => s % zTopEdge % array
+ zMidEdge => s % zMidEdge % array
weightsOnEdge => grid % weightsOnEdge % array
kiteAreasOnVertex => grid % kiteAreasOnVertex % array
@@ -305,6 +306,8 @@
h_s => grid % h_s % array
fVertex => grid % fVertex % array
fEdge => grid % fEdge % array
+ zMidZLevel => grid % zMidZLevel % array
+ zTopZLevel => grid % zTopZLevel % array
tend_h => tend % h % array
tend_u => tend % u % array
@@ -314,57 +317,129 @@
nVertices = grid % nVertices
nVertLevels = grid % nVertLevels
-!ocean
u_src => grid % u_src % array
-!ocean
-
!
- ! Compute height tendency for each cell
+ ! height tendency: horizontal advection term -</font>
<font color="red">abla\cdot ( hu)
!
+ ! See Ringler et al. (2010) jcp paper, eqn 19, 21, and fig. 3.
+ ! for explanation of divergence operator.
tend_h(:,:) = 0.0
do iEdge=1,nEdges
cell1 = cellsOnEdge(1,iEdge)
cell2 = cellsOnEdge(2,iEdge)
- if (cell1 > 0) then
+ if (cell1 <= nCells) then
do k=1,nVertLevels
flux = u(k,iEdge) * dvEdge(iEdge) * h_edge(k,iEdge)
tend_h(k,cell1) = tend_h(k,cell1) - flux
end do
end if
- if (cell2 > 0) then
+ if (cell2 <= nCells) then
do k=1,nVertLevels
flux = u(k,iEdge) * dvEdge(iEdge) * h_edge(k,iEdge)
tend_h(k,cell2) = tend_h(k,cell2) + flux
end do
end if
end do
- do iCell=1,grid % nCellsSolve
+ do iCell=1,nCells
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)
+ ! height tendency: vertical advection term -d/dz(hw)
!
+ if (config_vert_grid_type.eq.'zlevel') then
+
+ do iCell=1,nCells
+
+ tend_h(1,iCell) = tend_h(1,iCell) + wTop(2,iCell)
+
+ ! This next loop is to verify that h for levels below the first
+ ! remain constant. At a later time this could be replaced
+ ! by just tend_h(2:nVertLevels,:) = 0.0, and then there is
+ ! no need to compute the horizontal tend_h term for k=2:nVertLevels
+ ! on a zlevel grid, above.
+ do k=2,nVertLevels
+ tend_h(k,iCell) = tend_h(k,iCell) &
+ - (wTop(k,iCell) - wTop(k+1,iCell))
+ end do
+
+ end do
+ endif ! coordinate type
+
+ !
+ ! velocity tendency: vertical advection term -w du/dz
+ !
+ allocate(w_dudzTopEdge(nVertLevels+1))
+ w_dudzTopEdge(1) = 0.0
+ w_dudzTopEdge(nVertLevels+1) = 0.0
tend_u(:,:) = 0.0
- do iEdge=1,grid % nEdgesSolve
+ if (config_vert_grid_type.eq.'zlevel') then
+ do iEdge=1,grid % nEdgesSolve
cell1 = cellsOnEdge(1,iEdge)
cell2 = cellsOnEdge(2,iEdge)
+
+ do k=2,nVertLevels
+ ! Average w from cell center to edge
+ wTopEdge = 0.5*(wTop(k,cell1)+wTop(k,cell2))
+
+ ! compute dudz at vertical interface with first order derivative.
+ w_dudzTopEdge(k) = wTopEdge * (u(k-1,iEdge)-u(k,iEdge)) &
+ / (zMidZLevel(k-1) - zMidZLevel(k))
+ end do
+
+ ! Average w*du/dz from vertical interface to vertical middle of cell
+ do k=1,nVertLevels
+ tend_u(k,iEdge) = - 0.5 * (w_dudzTopEdge(k) + w_dudzTopEdge(k+1))
+ enddo
+ enddo
+ endif
+ deallocate(w_dudzTopEdge)
+
+ !
+ ! velocity tendency: pressure gradient
+ !
+ rho0Inv = 1.0/config_rho0
+ if (config_vert_grid_type.eq.'isopycnal') then
+ do iEdge=1,grid % nEdgesSolve
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ do k=1,nVertLevels
+ tend_u(k,iEdge) = tend_u(k,iEdge) &
+ - (MontPot(k,cell2) - MontPot(k,cell1))/dcEdge(iEdge)
+ end do
+ enddo
+ elseif (config_vert_grid_type.eq.'zlevel') then
+ do iEdge=1,grid % nEdgesSolve
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ do k=1,nVertLevels
+ tend_u(k,iEdge) = tend_u(k,iEdge) &
+ - rho0Inv*( pZLevel(k,cell2) &
+ - pZLevel(k,cell1) )/dcEdge(iEdge)
+ end do
+ enddo
+ endif
+
+ !
+ ! velocity tendency: -q(h u^\perp) - </font>
<font color="blue">abla K
+ ! +</font>
<font color="black">u_h(</font>
<font color="black">abla \delta + {\bf k}\times </font>
<font color="blue">abla \xi)
+ !
+ ! Compute diffusion, computed as </font>
<font color="black">abla divergence - k \times </font>
<font color="red">abla vorticity
+ ! only valid for visc == constant
+ 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
- !
- ! Compute diffusion, computed as </font>
<font color="black">abla divergence - k \times </font>
<font color="gray">abla vorticity
- ! only valid for visc == constant
- !
u_diffusion = ( divergence(k,cell2) - divergence(k,cell1) ) / dcEdge(iEdge) &
-(vorticity(k,vertex2) - vorticity(k,vertex1) ) / dvEdge(iEdge)
- u_diffusion = visc * u_diffusion
+ u_diffusion = config_visc * u_diffusion
q = 0.0
do j = 1,nEdgesOnEdge(iEdge)
@@ -372,55 +447,84 @@
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
- ! mrp 100112, this is the original shallow water formulation with grad H:
- !tend_u(k,iEdge) = &
- ! q &
- ! + u_diffusion &
- ! - ( ke(k,cell2) - ke(k,cell1) &
- ! gravity * (h(k,cell2) + h_s(cell2) - h(k,cell1) - h_s(cell1)) &
- ! ) / dcEdge(iEdge)
- ! mrp 100112, changed to grad Montgomery potential:
- tend_u(k,iEdge) = &
- q &
+ tend_u(k,iEdge) = tend_u(k,iEdge) &
+ + q &
+ u_diffusion &
- - ( ke(k,cell2) - ke(k,cell1) &
- + MontPot(k,cell2) - MontPot(k,cell1) &
- ) / dcEdge(iEdge)
- ! mrp 100112 end
+ - ( ke(k,cell2) - ke(k,cell1) ) / dcEdge(iEdge)
-!ocean
- tend_u(k,iEdge) = tend_u(k,iEdge) + u_src(k,iEdge)/rho_ref/h_edge(k,iEdge)
-!ocean
-
end do
end do
-#endif
-#ifdef NCAR_FORMULATION
!
- ! Compute u (normal) velocity tendency for each edge (cell face)
+ ! velocity tendency: forcing and bottom drag
!
- 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))
+ ! forcing in top layer only
+ tend_u(1,iEdge) = tend_u(1,iEdge) &
+ + u_src(1,iEdge)/rho_ref/h_edge(1,iEdge)
- workpv = 2.0 * vorticity_abs / (h(k,cell1) + h(k,cell2))
+ ! 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.
+ tend_u(nVertLevels,iEdge) = tend_u(nVertLevels,iEdge) &
+ - 1.0e-3*u(nVertLevels,iEdge) &
+ *sqrt(2.0*ke_edge(nVertLevels,iEdge))
- 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
+ ! mrp 100603 The following method is more straight forward,
+ ! that the above method of computing ke_edge, but I have
+ ! not verified that v is working correctly yet.
+ !tend_u(nVertLevels,iEdge) = tend_u(nVertLevels,iEdge) &
+ ! - 1.0e-3*u(nVertLevels,iEdge) &
+ ! *sqrt(u(nVertLevels,iEdge)**2 + v(nVertLevels,iEdge)**2)
+
+ ! old bottom drag, just linear friction
+ ! du/dt = u/tau where tau=100 days.
+ !tend_u(nVertLevels,iEdge) = tend_u(nVertLevels,iEdge) &
+ ! - u(nVertLevels,iEdge)/(100.0*86400.0)
+
+ enddo
+
+ !
+ ! velocity tendency: vertical mixing d/dz( nu_v du/dz))
+ !
+ allocate(vertViscTop(nVertLevels+1))
+ if (config_vert_visc_type.eq.'const') then
+ vertViscTop = config_vert_viscosity
+ elseif (config_vert_visc_type.eq.'tanh') then
+ if (config_vert_grid_type.ne.'zlevel') then
+ write(0,*) 'Abort: config_vert_visc_type.eq.tanh may only', &
+ ' use config_vert_grid_type of zlevel at this time'
+ call dmpar_abort(dminfo)
+ endif
+
+ do k=1,nVertLevels+1
+ vertViscTop(k) = -(config_vmixTanhViscMax-config_vmixTanhViscMin)/2.0 &
+ *tanh(-(zTopZLevel(k)-config_vmixTanhZMid) &
+ /config_vmixTanhZWidth) &
+ + (config_vmixTanhViscMax+config_vmixTanhViscMin)/2
+ enddo
+ else
+ write(0,*) 'Abort: unrecognized config_vert_visc_type'
+ call dmpar_abort(dminfo)
+ endif
+
+ allocate(fluxVertTop(1:nVertLevels+1))
+ fluxVertTop(1) = 0.0
+ fluxVertTop(nVertLevels+1) = 0.0
+ do iEdge=1,grid % nEdgesSolve
+ do k=2,nVertLevels
+ fluxVertTop(k) = vertViscTop(k) &
+ * ( u(k-1,iEdge) - u(k,iEdge) ) &
+ / (zMidEdge(k-1,iEdge) - zMidEdge(k,iEdge))
+ enddo
+ do k=1,nVertLevels
+ tend_u(k,iEdge) = tend_u(k,iEdge) &
+ + (fluxVertTop(k) - fluxVertTop(k+1)) &
+ /(zTopEdge(k,iEdge) - zTopEdge(k+1,iEdge))
+ enddo
end do
-#endif
+ deallocate(fluxVertTop, vertViscTop)
end subroutine compute_tend
@@ -440,33 +544,258 @@
type (grid_state), intent(in) :: s
type (grid_meta), intent(in) :: grid
- integer :: iCell, iEdge, k, iTracer, cell1, cell2
- real (kind=RKIND) :: flux, tracer_edge
+ integer :: iCell, iEdge, k, iTracer, cell1, cell2, upwindCell,&
+ nEdges, nCells, nVertLevels
+ real (kind=RKIND) :: flux, tracer_edge, r
+ real (kind=RKIND) :: dist
+ real (kind=RKIND), dimension(:), pointer :: &
+ h_s, fVertex, fEdge, dvEdge, dcEdge, areaCell, areaTriangle
+ real (kind=RKIND), dimension(:,:), pointer :: &
+ u,h,wTop, h_edge, zMid, zTop
+ real (kind=RKIND), dimension(:,:,:), pointer :: &
+ tracers, tend_tr
+ type (dm_info) :: dminfo
- tend % tracers % array(:,:,:) = 0.0
- do iEdge=1,grid % nEdges
- cell1 = grid % cellsOnEdge % array(1,iEdge)
- cell2 = grid % cellsOnEdge % array(2,iEdge)
- if (cell1 > 0 .and. cell2 > 0) then
- do k=1,grid % nVertLevels
- do iTracer=1,grid % nTracers
- tracer_edge = 0.5 * (s % tracers % array(iTracer,k,cell1) + s % tracers % array(iTracer,k,cell2))
- flux = s % u % array(k,iEdge) * grid % dvEdge % array(iEdge) * s % h_edge % array(k,iEdge) * tracer_edge
- tend % tracers % array(iTracer,k,cell1) = tend % tracers % array(iTracer,k,cell1) - flux
- tend % tracers % array(iTracer,k,cell2) = tend % tracers % array(iTracer,k,cell2) + flux
- end do
+ integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge
+ integer, dimension(:,:), pointer :: cellsOnEdge
+ real (kind=RKIND), dimension(:), pointer :: &
+ zTopZLevel
+ real (kind=RKIND), dimension(:,:), allocatable:: fluxVertTop, tracerTop
+ real (kind=RKIND), dimension(:,:,:), allocatable::tr_flux, tr_div
+
+ real (kind=RKIND), dimension(:), allocatable:: vertDiffTop
+
+ u => s % u % array
+ h => s % h % array
+ wTop => s % wTop % array
+ tracers => s % tracers % array
+ h_edge => s % h_edge % array
+ zMid => s % zMid % array
+ zTop => s % zTop % array
+
+ tend_tr => tend % tracers % array
+
+ areaCell => grid % areaCell % array
+ cellsOnEdge => grid % cellsOnEdge % array
+ dvEdge => grid % dvEdge % array
+ dcEdge => grid % dcEdge % array
+ zTopZLevel => grid % zTopZLevel % array
+
+ nEdges = grid % nEdges
+ nCells = grid % nCells
+ nVertLevels = grid % nVertLevels
+
+ !
+ ! tracer tendency: horizontal advection term -div( h \phi u)
+ !
+ tend_tr(:,:,:) = 0.0
+ if (config_hor_tracer_adv.eq.'centered') then
+
+ do iEdge=1,nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ if (cell1 <= nCells .and. cell2 <= nCells) then
+ do k=1,nVertLevels
+ do iTracer=1,num_tracers
+ tracer_edge = 0.5 * ( tracers(iTracer,k,cell1) &
+ + tracers(iTracer,k,cell2))
+ flux = u(k,iEdge) * dvEdge(iEdge) * h_edge(k,iEdge) &
+ * tracer_edge
+ tend_tr(iTracer,k,cell1) = tend_tr(iTracer,k,cell1) - flux
+ tend_tr(iTracer,k,cell2) = tend_tr(iTracer,k,cell2) + flux
end do
- end if
- end do
+ end do
+ end if
+ end do
+ elseif (config_hor_tracer_adv.eq.'upwind') then
+
+ do iEdge=1,nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ if (cell1 <= nCells .and. cell2 <= nCells) then
+ do k=1,nVertLevels
+ if (u(k,iEdge)>0.0) then
+ upwindCell = cell1
+ else
+ upwindCell = cell2
+ endif
+ do iTracer=1,num_tracers
+ flux = u(k,iEdge) * dvEdge(iEdge) * h_edge(k,iEdge) &
+ * tracers(iTracer,k,upwindCell)
+ tend_tr(iTracer,k,cell1) = tend_tr(iTracer,k,cell1) - flux
+ tend_tr(iTracer,k,cell2) = tend_tr(iTracer,k,cell2) + flux
+ end do
+ end do
+ end if
+ end do
+
+ endif
do iCell=1,grid % nCellsSolve
do k=1,grid % nVertLevelsSolve
- do iTracer=1,grid % nTracers
- tend % tracers % array(iTracer,k,iCell) = tend % tracers % array(iTracer,k,iCell) / grid % areaCell % array(iCell)
+ do iTracer=1,num_tracers
+ tend_tr(iTracer,k,iCell) = tend_tr(iTracer,k,iCell) / areaCell(iCell)
end do
end do
end do
+ !
+ ! tracer tendency: vertical advection term -d/dz( h \phi w)
+ !
+ allocate(tracerTop(num_tracers,nVertLevels+1))
+ tracerTop(:,1)=0.0
+ tracerTop(:,nVertLevels+1)=0.0
+ do iCell=1,grid % nCellsSolve
+
+ if (config_vert_tracer_adv.eq.'centered') then
+ do k=2,nVertLevels
+ do iTracer=1,num_tracers
+ tracerTop(iTracer,k) = ( tracers(iTracer,k-1,iCell) &
+ +tracers(iTracer,k ,iCell))/2.0
+ end do
+ end do
+
+ elseif (config_vert_tracer_adv.eq.'upwind') then
+ do k=2,nVertLevels
+ if (wTop(k,iCell)>0.0) then
+ upwindCell = k
+ else
+ upwindCell = k-1
+ endif
+ do iTracer=1,num_tracers
+ tracerTop(iTracer,k) = tracers(iTracer,upwindCell,iCell)
+ end do
+ end do
+
+ endif
+
+ do k=1,nVertLevels
+ do iTracer=1,num_tracers
+ tend_tr(iTracer,k,iCell) = tend_tr(iTracer,k,iCell) &
+ - ( wTop(k ,iCell)*tracerTop(iTracer,k ) &
+ - wTop(k+1,iCell)*tracerTop(iTracer,k+1))
+ end do
+ end do
+
+ enddo ! iCell
+ deallocate(tracerTop)
+
+ !
+ ! tracer tendency: horizontal tracer diffusion
+ ! div(h \kappa_h </font>
<font color="blue">abla\phi )
+ !
+ ! first compute \kappa_h </font>
<font color="blue">abla\phi at horizontal edges.
+ allocate(tr_flux(num_tracers,nVertLevels,nEdges))
+ tr_flux(:,:,:) = 0.0
+ do iEdge=1,nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ if (cell1 <= nCells .and. cell2 <= nCells) then
+ do k=1,nVertLevels
+ do iTracer=1,num_tracers
+ tr_flux(iTracer,k,iEdge) = h_edge(k,iEdge)*config_hor_diffusion * &
+ (Tracers(iTracer,k,cell2) - Tracers(iTracer,k,cell1))/dcEdge(iEdge)
+ enddo
+ enddo
+ endif
+ enddo
+
+ ! Compute the divergence, div(h \kappa_h </font>
<font color="blue">abla\phi) at cell centers
+ allocate(tr_div(num_tracers,nVertLevels,nCells))
+ tr_div(:,:,:) = 0.0
+ do iEdge=1,nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ if (cell1 <= nCells) then
+ do k=1,nVertLevels
+ do iTracer=1,num_tracers
+ tr_div(iTracer,k,cell1) = tr_div(iTracer,k,cell1) &
+ + tr_flux(iTracer,k,iEdge)*dvEdge(iEdge)
+ enddo
+ enddo
+ endif
+ if (cell2 <= nCells) then
+ do k=1,nVertLevels
+ do iTracer=1,num_tracers
+ tr_div(iTracer,k,cell2) = tr_div(iTracer,k,cell2) &
+ - tr_flux(iTracer,k,iEdge)*dvEdge(iEdge)
+ enddo
+ enddo
+ end if
+ end do
+
+ ! add div(h \kappa_h </font>
<font color="gray">abla\phi ) to tracer tendency
+ do iCell = 1,nCells
+ r = 1.0 / areaCell(iCell)
+ do k = 1,nVertLevels
+ do iTracer=1,num_tracers
+ tend_tr(iTracer,k,iCell) = tend_tr(iTracer,k,iCell) &
+ + tr_div(iTracer,k,iCell)*r
+ enddo
+ enddo
+ enddo
+ deallocate(tr_flux, tr_div)
+
+ !
+ ! tracer tendency: vertical diffusion h d/dz( \kappa_v d\phi/dz)
+ !
+ allocate(vertDiffTop(nVertLevels+1))
+ if (config_vert_diff_type.eq.'const') then
+ vertDiffTop = config_vert_diffusion
+ elseif (config_vert_diff_type.eq.'tanh') then
+ if (config_vert_grid_type.ne.'zlevel') then
+ write(0,*) 'Abort: config_vert_diff_type.eq.tanh may only', &
+ ' use config_vert_grid_type of zlevel at this time'
+ call dmpar_abort(dminfo)
+ endif
+
+ do k=1,nVertLevels+1
+ vertDiffTop(k) = -(config_vmixTanhDiffMax-config_vmixTanhDiffMin)/2.0 &
+ *tanh(-(zTopZLevel(k)-config_vmixTanhZMid) &
+ /config_vmixTanhZWidth) &
+ + (config_vmixTanhDiffMax+config_vmixTanhDiffMin)/2
+ enddo
+ else
+ write(0,*) 'Abort: unrecognized config_vert_diff_type'
+ call dmpar_abort(dminfo)
+ endif
+
+ allocate(fluxVertTop(num_tracers,nVertLevels+1))
+ fluxVertTop(:,1) = 0.0
+ fluxVertTop(:,nVertLevels+1) = 0.0
+ do iCell=1,grid % nCellsSolve
+ do k=2,nVertLevels
+ do iTracer=1,num_tracers
+ ! compute \kappa_v d\phi/dz
+ fluxVertTop(iTracer,k) = vertDiffTop(k) &
+ * (tracers(iTracer,k-1,iCell) - tracers(iTracer,k,iCell) )&
+ / (zMid(k-1,iCell) -zMid(k,iCell))
+ enddo
+ enddo
+
+ do k=1,nVertLevels
+ dist = zTop(k,iCell) - zTop(k+1,iCell)
+ do iTracer=1,num_tracers
+ tend_tr(iTracer,k,iCell) = tend_tr(iTracer,k,iCell) &
+ + h(k,iCell)*(fluxVertTop(iTracer,k) - fluxVertTop(iTracer,k+1))/dist
+ enddo
+ enddo
+
+ enddo ! iCell loop
+ deallocate(fluxVertTop, vertDiffTop)
+
+
+ ! print some diagnostics - for debugging
+! print *, 'after vertical mixing',&
+! 'iTracer,k, minval(tend_tr(itracer,k,:)), maxval(tend_tr(itracer,k,:))'
+! do iTracer=1,num_tracers
+! do k = 1,nVertLevels
+! print '(2i5,20es12.4)', iTracer,k, &
+! minval(tend_tr(itracer,k,:)), maxval(tend_tr(itracer,k,:))
+! enddo
+! enddo
+
+
end subroutine compute_scalar_tend
@@ -487,21 +816,24 @@
integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j, cov
- real (kind=RKIND) :: flux, vorticity_abs, h_vertex, workpv
+ real (kind=RKIND) :: flux, vorticity_abs, h_vertex, workpv, delta_p
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
- !mrp 100112:
+
+
+ real (kind=RKIND), dimension(:), pointer :: &
+ h_s, fVertex, fEdge, dvEdge, dcEdge, areaCell, areaTriangle, &
+ hZLevel, ssh
real (kind=RKIND), dimension(:,:), pointer :: &
- zmid, zbot, pmid, pbot, MontPot, rho
- real (kind=RKIND), dimension(:), pointer :: zSurface
- real (kind=RKIND) :: delta_p
+ weightsOnEdge, kiteAreasOnVertex, h_edge, h, u, v, w, wTop, &
+ circulation, vorticity, ke, ke_edge, &
+ pv_edge, pv_vertex, pv_cell, gradPVn, gradPVt, divergence, &
+ zMid, zTop, zMidEdge, zTopEdge, p, pTop, MontPot, rho, temperature, salinity, pZLevel
+ real (kind=RKIND), dimension(:,:,:), pointer :: tracers
+ real (kind=RKIND), dimension(:,:), allocatable:: div_u
character :: c1*6
- !mrp 100112 end
- integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnVertex, verticesOnEdge, edgesOnCell, edgesOnEdge, edgesOnVertex, uBC
+ integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnVertex, verticesOnEdge, edgesOnCell, edgesOnEdge, edgesOnVertex, boundaryEdge
integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge
real (kind=RKIND) :: r, h1, h2
@@ -509,28 +841,29 @@
h => s % h % array
u => s % u % array
v => s % v % array
- vh => s % vh % array
+ wTop => s % wTop % array
h_edge => s % h_edge % 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
+ ke_edge => s % ke_edge % array
pv_edge => s % pv_edge % array
pv_vertex => s % pv_vertex % array
pv_cell => s % pv_cell % array
gradPVn => s % gradPVn % array
gradPVt => s % gradPVt % array
- !mrp 100112:
rho => s % rho % array
- zmid => s % zmid % array
- zbot => s % zbot % array
- pmid => s % pmid % array
- pbot => s % pbot % array
+ tracers => s % tracers % array
+ zMid => s % zMid % array
+ zTop => s % zTop % array
+ zMidEdge => s % zMidEdge % array
+ zTopEdge => s % zTopEdge % array
+ p => s % p % array
+ pZLevel => s % pZLevel % array
+ pTop => s % pTop % array
MontPot => s % MontPot % array
- zSurface => s % zSurface % array
- !mrp 100112 end
+ ssh => s % ssh % array
weightsOnEdge => grid % weightsOnEdge % array
kiteAreasOnVertex => grid % kiteAreasOnVertex % array
@@ -549,13 +882,14 @@
h_s => grid % h_s % array
fVertex => grid % fVertex % array
fEdge => grid % fEdge % array
+ hZLevel => grid % hZLevel % array
nCells = grid % nCells
nEdges = grid % nEdges
nVertices = grid % nVertices
nVertLevels = grid % nVertLevels
- uBC => grid % uBC % array
+ boundaryEdge => grid % boundaryEdge % array
!
! Compute height on cell edges at velocity locations
@@ -563,24 +897,39 @@
do iEdge=1,nEdges
cell1 = cellsOnEdge(1,iEdge)
cell2 = cellsOnEdge(2,iEdge)
- if (cell1 > 0 .and. cell2 > 0) then
+ if (cell1 <= nCells .and. cell2 <= nCells) then
do k=1,nVertLevels
h_edge(k,iEdge) = 0.5 * (h(k,cell1) + h(k,cell2))
end do
+ elseif(cell1 <= nCells) then
+ do k=1,nVertLevels
+ h_edge(k,iEdge) = h(k,cell1)
+ end do
+ elseif(cell2 <= nCells) then
+ do k=1,nVertLevels
+ h_edge(k,iEdge) = h(k,cell2)
+ end do
end if
end do
+
!
+ ! 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
- if (verticesOnEdge(1,iEdge) > 0) then
+ if (verticesOnEdge(1,iEdge) <= nVertices) then
do k=1,nVertLevels
circulation(k,verticesOnEdge(1,iEdge)) = circulation(k,verticesOnEdge(1,iEdge)) - dcEdge(iEdge) * u(k,iEdge)
end do
end if
- if (verticesOnEdge(2,iEdge) > 0) then
+ if (verticesOnEdge(2,iEdge) <= nVertices) then
do k=1,nVertLevels
circulation(k,verticesOnEdge(2,iEdge)) = circulation(k,verticesOnEdge(2,iEdge)) + dcEdge(iEdge) * u(k,iEdge)
end do
@@ -592,6 +941,7 @@
end do
end do
+
!
! Compute the divergence at each cell center
!
@@ -599,12 +949,12 @@
do iEdge=1,nEdges
cell1 = cellsOnEdge(1,iEdge)
cell2 = cellsOnEdge(2,iEdge)
- if (cell1 > 0) then
+ if (cell1 <= nCells) then
do k=1,nVertLevels
divergence(k,cell1) = divergence(k,cell1) + u(k,iEdge)*dvEdge(iEdge)
enddo
endif
- if(cell2 > 0) then
+ if(cell2 <= nCells) then
do k=1,nVertLevels
divergence(k,cell2) = divergence(k,cell2) - u(k,iEdge)*dvEdge(iEdge)
enddo
@@ -634,13 +984,14 @@
end do
!
+ !
! Compute v (tangential) velocities
!
v(:,:) = 0.0
do iEdge = 1,nEdges
do i=1,nEdgesOnEdge(iEdge)
eoe = edgesOnEdge(i,iEdge)
- if (eoe > 0) then
+ if (eoe <= nEdges) then
do k = 1,nVertLevels
v(k,iEdge) = v(k,iEdge) + weightsOnEdge(i,iEdge) * u(k, eoe)
end do
@@ -648,30 +999,30 @@
end do
end do
-#ifdef NCAR_FORMULATION
!
- ! Compute mass fluxes tangential to each edge (i.e., through the faces of dual grid cells)
+ ! Compute ke on cell edges at velocity locations for quadratic bottom drag.
!
- vh(:,:) = 0.0
- do iEdge=1,grid % nEdgesSolve
- do j=1,nEdgesOnEdge(iEdge)
- eoe = edgesOnEdge(j,iEdge)
+ do iEdge=1,nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ if (cell1 <= nCells .and. cell2 <= nCells) then
do k=1,nVertLevels
- vh(k,iEdge) = vh(k,iEdge) + weightsOnEdge(j,iEdge) * u(k,eoe) * h_edge(k,eoe)
+ ke_edge(k,iEdge) = 0.5 * (ke(k,cell1) + ke(k,cell2))
end do
- end do
+ else
+ do k=1,nVertLevels
+ ke_edge(k,iEdge) = 0.0
+ end do
+ end if
end do
-#endif
-
- ! tdr
!
! 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 )
!
VTX_LOOP: do iVertex = 1,nVertices
do i=1,grid % vertexDegree
- if (cellsOnVertex(i,iVertex) <= 0) cycle VTX_LOOP
+ if (cellsOnVertex(i,iVertex) > nCells) cycle VTX_LOOP
end do
do k=1,nVertLevels
h_vertex = 0.0
@@ -679,14 +1030,12 @@
h_vertex = h_vertex + h(k,cellsOnVertex(i,iVertex)) * kiteAreasOnVertex(i,iVertex)
end do
h_vertex = h_vertex / areaTriangle(iVertex)
-
+
pv_vertex(k,iVertex) = (fVertex(iVertex) + vorticity(k,iVertex)) / h_vertex
end do
end do VTX_LOOP
- ! tdr
- ! tdr
!
! Compute gradient of PV in the tangent direction
! ( this computes gradPVt at all edges bounding real cells and distance-1 ghost cells )
@@ -698,7 +1047,6 @@
enddo
enddo
- ! tdr
!
! Compute pv at the edges
! ( this computes pv_edge at all edges bounding real cells and distance-1 ghost cells )
@@ -707,16 +1055,14 @@
do iVertex = 1,nVertices
do i=1,grid % vertexDegree
iEdge = edgesOnVertex(i,iVertex)
- if(iEdge > 0) then
+ if(iEdge <= nEdges) then
do k=1,nVertLevels
pv_edge(k,iEdge) = pv_edge(k,iEdge) + 0.5 * pv_vertex(k,iVertex)
enddo
endif
end do
end do
- ! tdr
- ! tdr
!
! Modify PV edge with upstream bias.
!
@@ -727,7 +1073,6 @@
enddo
- ! tdr
!
! Compute pv at cell centers
! ( this computes pv_cell for all real cells and distance-1 ghost cells )
@@ -736,31 +1081,29 @@
do iVertex = 1, nVertices
do i=1,grid % vertexDegree
iCell = cellsOnVertex(i,iVertex)
- if( iCell > 0) then
+ 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)
enddo
endif
enddo
enddo
- ! tdr
- ! tdr
!
! 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) > 0 .and. cellsOnEdge(2,iEdge) > 0) then
+ 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
- ! tdr
+
! Modify PV edge with upstream bias.
!
do iEdge = 1,nEdges
@@ -770,25 +1113,29 @@
enddo
!
- ! set pv_edge = fEdge / h_edge at boundary points
+ ! Compute sea surface height
!
- if (maxval(uBC).gt.0) then
- do iEdge = 1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- do k = 1,nVertLevels
- if(uBC(k,iEdge).eq.1) then
- if(cell1.gt.0) h1 = h(k,cell1)
- if(cell2.gt.0) h2 = h(k,cell2)
- pv_edge(k,iEdge) = fEdge(iEdge) / ( max(h1,h2) )
- v(k,iEdge) = 0.0
- endif
- enddo
+ do iCell=1,nCells
+ ssh(iCell) = h(1,iCell) - hZLevel(1)
enddo
+
+ !
+ ! equation of state
+ !
+ ! For a isopycnal model, density should remain constant.
+ if (config_vert_grid_type.eq.'zlevel') then
+ do iCell=1,nCells
+ do k=1,nVertLevels
+ ! Linear equation of state, for the time being
+ rho(k,iCell) = 1000.0*( 1.0 &
+ - 2.5e-4*tracers(index_temperature,k,iCell) &
+ + 7.6e-4*tracers(index_salinity,k,iCell))
+ end do
+ end do
endif
- !mrp 100112:
- !
+
+ ! For Isopycnal model.
! Compute mid- and bottom-depth of each layer, from bottom up.
! Then compute mid- and bottom-pressure of each layer, and
! Montgomery Potential, from top down
@@ -798,41 +1145,119 @@
! h_s is ocean topography: elevation above lowest point,
! and is positive. z coordinates are pos upward, and z=0
! is at lowest ocean point.
- zbot(nVertLevels,iCell) = h_s(iCell)
- zmid(nVertLevels,iCell) = zbot(nVertLevels,iCell) + 0.5*h(nVertLevels,iCell)
- do k=nVertLevels-1,1,-1
- zbot(k,iCell) = zbot(k+1,iCell) + h(k+1,iCell)
- zmid(k,iCell) = zbot(k,iCell) + 0.5*h(k,iCell)
+ zTop(nVertLevels+1,iCell) = h_s(iCell)
+ do k=nVertLevels,1,-1
+ zMid(k,iCell) = zTop(k+1,iCell) + 0.5*h(k,iCell)
+ zTop(k,iCell) = zTop(k+1,iCell) + h(k,iCell)
end do
- ! rather than using zbot(0,iCell), I am adding another 2D variable.
- zSurface(iCell) = zbot(1,iCell) + h(1,iCell)
- ! assume pressure at the surface is zero for now.
- pmid(1,iCell) = 0.5*rho(1,iCell)*gravity* h(1,iCell) ! + psurf(iCell)
- pbot(1,iCell) = rho(1,iCell)*gravity* h(1,iCell) ! + psurf(iCell)
- MontPot(1,iCell) = gravity * zSurface(iCell)
- do k=2,nVertLevels
+ ! assume atmospheric pressure at the surface is zero for now.
+ pTop(1,iCell) = 0.0
+ do k=1,nVertLevels
delta_p = rho(k,iCell)*gravity* h(k,iCell)
- pmid(k,iCell) = pbot(k-1,iCell) + 0.5*delta_p
- pbot(k,iCell) = pbot(k-1,iCell) + delta_p
+ p(k ,iCell) = pTop(k,iCell) + 0.5*delta_p
+ pTop(k+1,iCell) = pTop(k,iCell) + delta_p
+ end do
+ MontPot(1,iCell) = gravity * zTop(1,iCell)
+ do k=2,nVertLevels
! from delta M = p delta / rho
MontPot(k,iCell) = MontPot(k-1,iCell) &
- + pbot(k-1,iCell)*(1.0/rho(k,iCell) - 1.0/rho(k-1,iCell))
+ + pTop(k,iCell)*(1.0/rho(k,iCell) - 1.0/rho(k-1,iCell))
end do
+
end do
- !mrp 100112 end
+ do iEdge=1,nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ if(cell1<=nCells .and. cell2<=nCells) then
+ do k=1,nVertLevels
+ zTopEdge(k,iEdge) = (zTop(k,cell1)+zTop(k,cell2))/2.0
+ zMidEdge(k,iEdge) = (zMid(k,cell1)+zMid(k,cell2))/2.0
+ enddo
+ zTopEdge(nVertLevels+1,iEdge) = ( zTop(nVertLevels+1,cell1) &
+ + zTop(nVertLevels+1,cell2))/2.0
+ endif
+ enddo
+
+
+ ! For z-level model.
+ ! Compute pressure at middle of each level.
+ ! pZLevel and p should only differ at k=1, where p is
+ ! pressure at middle of layer including SSH, and pZLevel is
+ ! pressure at a depth of hZLevel(1)/2.
+ !
+ do iCell=1,nCells
+ ! compute pressure for z-level coordinates
+ ! assume atmospheric pressure at the surface is zero for now.
+ pZLevel(1,iCell) = rho(1,iCell)*gravity &
+ * (h(1,iCell)-0.5*hZLevel(1))
+ do k=2,nVertLevels
+ delta_p = rho(k,iCell)*gravity*hZLevel(k)
+ pZLevel(k,iCell) = pZLevel(k-1,iCell) + 0.5*delta_p
+ end do
+
+ end do
+
+ ! compute vertical velocity
+ if (config_vert_grid_type.eq.'isopycnal') then
+ ! set vertical velocity to zero in isopycnal case
+ wTop=0.0
+
+ elseif (config_vert_grid_type.eq.'zlevel') then
+
+ !
+ ! Compute div(u) for each cell
+ ! See Ringler et al. (2010) jcp paper, eqn 19, 21, and fig. 3.
+ !
+ allocate(div_u(nVertLevels,nCells))
+ div_u(:,:) = 0.0
+ do iEdge=1,nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ if (cell1 <= nCells) then
+ do k=1,nVertLevels
+ flux = u(k,iEdge) * dvEdge(iEdge)
+ div_u(k,cell1) = div_u(k,cell1) + flux
+ end do
+ end if
+ if (cell2 <= nCells) then
+ do k=1,nVertLevels
+ flux = u(k,iEdge) * dvEdge(iEdge)
+ div_u(k,cell2) = div_u(k,cell2) - flux
+ end do
+ end if
+ end do
+
+ do iCell=1,nCells
+ do k=1,nVertLevels
+ div_u(k,iCell) = div_u(k,iCell) / areaCell(iCell)
+ end do
+
+ ! Vertical velocity at bottom is zero.
+ ! this next line can be set permanently somewhere upon startup.
+ wTop(nVertLevels+1,iCell) = 0.0
+ do k=nVertLevels,1,-1
+ wTop(k,iCell) = wTop(k+1,iCell) - div_u(k,iCell)*h(k,iCell)
+ end do
+
+ end do
+ deallocate(div_u)
+
+ endif
+
+
end subroutine compute_solve_diagnostics
- subroutine enforce_uBC(tend, grid)
+ 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 uBC == 1 locations
+ ! Output: tend_u set to zero at boundaryEdge == 1 locations
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -841,7 +1266,7 @@
type (grid_state), intent(inout) :: tend
type (grid_meta), intent(in) :: grid
- integer, dimension(:,:), pointer :: uBC
+ integer, dimension(:,:), pointer :: boundaryEdge
real (kind=RKIND), dimension(:,:), pointer :: tend_u
integer :: nCells, nEdges, nVertices, nVertLevels
integer :: iEdge, k
@@ -851,21 +1276,21 @@
nVertices = grid % nVertices
nVertLevels = grid % nVertLevels
- uBC => grid % uBC % array
+ boundaryEdge => grid % boundaryEdge % array
tend_u => tend % u % array
- if(maxval(uBC).le.0) return
+ if(maxval(boundaryEdge).le.0) return
do iEdge = 1,nEdges
do k = 1,nVertLevels
- if(uBC(k,iEdge).eq.1) then
+ if(boundaryEdge(k,iEdge).eq.1) then
tend_u(k,iEdge) = 0.0
endif
enddo
enddo
- end subroutine enforce_uBC
+ end subroutine enforce_boundaryEdge
end module time_integration
Modified: branches/ocean_projects/port_adv_mwh/src/core_ocean/mpas_interface.F
===================================================================
--- branches/ocean_projects/port_adv_mwh/src/core_ocean/mpas_interface.F 2010-06-18 22:07:12 UTC (rev 362)
+++ branches/ocean_projects/port_adv_mwh/src/core_ocean/mpas_interface.F 2010-06-23 17:20:20 UTC (rev 363)
@@ -16,6 +16,8 @@
use grid_types
use time_integration
+ use RBF_interpolation
+ use vector_reconstruction
implicit none
@@ -25,10 +27,9 @@
call compute_solve_diagnostics(dt, block % time_levs(1) % state, mesh)
- ! xsad 10-02-09:
- ! commenting this out until we incorporate the necessary lapack routines into mpas
- ! call init_reconstruct(block_ptr % mesh)
- ! xsad 10-02-09 end
+ call rbfInterp_initialize(mesh)
+ call init_reconstruct(mesh)
+ call reconstruct(block % time_levs(1) % state, mesh)
! mrp 100316 In order for this to work, we need to pass domain % dminfo as an
! input arguement into mpas_init. Ask about that later. For now, there will be
@@ -37,7 +38,6 @@
! call timer_start("global diagnostics")
! call computeGlobalDiagnostics(domain % dminfo, block % time_levs(1) % state, mesh, 0, dt)
! call timer_stop("global diagnostics")
-! ! xsad 10-02-08 end
! call output_state_init(output_obj, domain, "OUTPUT")
! call write_output_frame(output_obj, domain)
@@ -74,10 +74,7 @@
call timestep(domain, dt)
- ! mrp 100120:
if (mod(itimestep, config_stats_interval) == 0) then
- ! xsad 10-02-08:
- !call write_stats(domain, itimestep, dt)
block_ptr => domain % blocklist
if(associated(block_ptr % next)) then
write(0,*) 'Error: computeGlobalDiagnostics assumes ',&
@@ -89,9 +86,7 @@
block_ptr % time_levs(2) % state, block_ptr % mesh, &
itimestep, dt)
call timer_stop("global diagnostics")
- ! xsad 10-02-08 end
end if
- ! mrp 100120 end
end subroutine mpas_timestep
Modified: branches/ocean_projects/port_adv_mwh/src/core_sw/Registry
===================================================================
--- branches/ocean_projects/port_adv_mwh/src/core_sw/Registry 2010-06-18 22:07:12 UTC (rev 362)
+++ branches/ocean_projects/port_adv_mwh/src/core_sw/Registry 2010-06-23 17:20:20 UTC (rev 363)
@@ -27,9 +27,9 @@
dim nVertices nVertices
dim TWO 2
dim R3 3
-dim vertexDegree vertexDegree
dim FIFTEEN 15
dim TWENTYONE 21
+dim vertexDegree vertexDegree
dim nVertLevels nVertLevels
dim nTracers nTracers
@@ -72,6 +72,10 @@
var real areaCell ( nCells ) iro areaCell - -
var real areaTriangle ( nVertices ) iro areaTriangle - -
+var real edgeNormalVectors ( R3 nEdges ) o edgeNormalVectors - -
+var real localVerticalUnitVectors ( R3 nCells ) o localVerticalUnitVectors - -
+var real cellTangentPlane ( R3 TWO nEdges ) o cellTangentPlane - -
+
var integer cellsOnCell ( maxEdges nCells ) iro cellsOnCell - -
var integer verticesOnCell ( maxEdges nCells ) iro verticesOnCell - -
var integer verticesOnEdge ( TWO nEdges ) iro verticesOnEdge - -
@@ -110,6 +114,8 @@
var real uReconstructX ( nVertLevels nCells Time ) o uReconstructX - -
var real uReconstructY ( nVertLevels nCells Time ) o uReconstructY - -
var real uReconstructZ ( nVertLevels nCells Time ) o uReconstructZ - -
+var real uReconstructZonal ( nVertLevels nCells Time ) o uReconstructZonal - -
+var real uReconstructMeridional ( nVertLevels nCells Time ) o uReconstructMeridional - -
# Other diagnostic variables: neither read nor written to any files
var real vh ( nVertLevels nEdges Time ) - vh - -
Modified: branches/ocean_projects/port_adv_mwh/src/core_sw/mpas_interface.F
===================================================================
--- branches/ocean_projects/port_adv_mwh/src/core_sw/mpas_interface.F 2010-06-18 22:07:12 UTC (rev 362)
+++ branches/ocean_projects/port_adv_mwh/src/core_sw/mpas_interface.F 2010-06-23 17:20:20 UTC (rev 363)
@@ -2,7 +2,6 @@
use grid_types
use test_cases
- use vector_reconstruction
implicit none
@@ -18,6 +17,8 @@
use grid_types
use advection
use time_integration
+ use RBF_interpolation
+ use vector_reconstruction
implicit none
@@ -26,6 +27,8 @@
real (kind=RKIND), intent(in) :: dt
call compute_solve_diagnostics(dt, block % time_levs(1) % state, mesh)
+
+ call rbfInterp_initialize(mesh)
call init_reconstruct(mesh)
call reconstruct(block % time_levs(1) % state, mesh)
call initialize_advection_rk(mesh)
Modified: branches/ocean_projects/port_adv_mwh/src/driver/Makefile
===================================================================
--- branches/ocean_projects/port_adv_mwh/src/driver/Makefile 2010-06-18 22:07:12 UTC (rev 362)
+++ branches/ocean_projects/port_adv_mwh/src/driver/Makefile 2010-06-23 17:20:20 UTC (rev 363)
@@ -10,10 +10,9 @@
mpas.o: module_subdriver.o
clean:
- $(RM) *.o *.mod
+ $(RM) *.o *.mod *.f90
.F.o:
$(RM) $@ $*.mod
$(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90
$(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../framework -I../core_$(CORE)
- $(RM) $*.f90
Modified: branches/ocean_projects/port_adv_mwh/src/framework/Makefile
===================================================================
--- branches/ocean_projects/port_adv_mwh/src/framework/Makefile 2010-06-18 22:07:12 UTC (rev 362)
+++ branches/ocean_projects/port_adv_mwh/src/framework/Makefile 2010-06-23 17:20:20 UTC (rev 363)
@@ -35,13 +35,12 @@
module_io_output.o: module_grid_types.o module_dmpar.o module_sort.o module_configure.o
clean:
- $(RM) *.o *.mod libframework.a
+ $(RM) *.o *.mod *.f90 libframework.a
.F.o:
$(RM) $@ $*.mod
$(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90
$(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES)
- $(RM) $*.f90
.c.o:
$(CC) $(CFLAGS) $(CPPFLAGS) $(CPPINCLUDES) -c $<
Modified: branches/ocean_projects/port_adv_mwh/src/framework/module_block_decomp.F
===================================================================
--- branches/ocean_projects/port_adv_mwh/src/framework/module_block_decomp.F 2010-06-18 22:07:12 UTC (rev 362)
+++ branches/ocean_projects/port_adv_mwh/src/framework/module_block_decomp.F 2010-06-23 17:20:20 UTC (rev 363)
@@ -142,7 +142,11 @@
edgeIDListLocal(:) = edgeIDList(:)
do i=1,nEdges
- if (hash_search(h, cellsOnEdge(1,i))) then
+ 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
@@ -231,8 +235,10 @@
do i=1,local_graph_info % nVertices
do j=1,local_graph_info % nAdjacent(i)
- if (.not. hash_search(h, local_graph_info % adjacencyList(j,i))) then
- call hash_insert(h, local_graph_info % adjacencyList(j,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
@@ -264,10 +270,12 @@
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 (.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
+ 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
Modified: branches/ocean_projects/port_adv_mwh/src/framework/module_dmpar.F
===================================================================
--- branches/ocean_projects/port_adv_mwh/src/framework/module_dmpar.F 2010-06-18 22:07:12 UTC (rev 362)
+++ branches/ocean_projects/port_adv_mwh/src/framework/module_dmpar.F 2010-06-23 17:20:20 UTC (rev 363)
@@ -110,6 +110,25 @@
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
@@ -688,8 +707,8 @@
implicit none
type (dm_info), intent(in) :: dminfo
- integer, dimension(nOwnedList), intent(in) :: arrayIn
- integer, dimension(nNeededList), intent(inout) :: arrayOut
+ integer, dimension(*), intent(in) :: arrayIn
+ integer, dimension(*), intent(inout) :: arrayOut
integer, intent(in) :: nOwnedList, nNeededList
type (exchange_list), pointer :: sendList, recvList
@@ -765,7 +784,7 @@
write(0,*) 'Error in dmpar_alltoall_field: For non-dmpar, arrayIn and arrayOut dims must match.'
call dmpar_abort(dminfo)
else
- arrayOut(:) = arrayIn(:)
+ arrayOut(1:nNeededList) = arrayIn(1:nOwnedList)
end if
#endif
@@ -778,8 +797,8 @@
type (dm_info), intent(in) :: dminfo
integer, intent(in) :: dim1, nOwnedList, nNeededList
- integer, dimension(dim1,nOwnedList), intent(in) :: arrayIn
- integer, dimension(dim1,nNeededList), intent(inout) :: arrayOut
+ integer, dimension(dim1,*), intent(in) :: arrayIn
+ integer, dimension(dim1,*), intent(inout) :: arrayOut
type (exchange_list), pointer :: sendList, recvList
type (exchange_list), pointer :: sendListPtr, recvListPtr
@@ -857,7 +876,7 @@
write(0,*) 'Error in dmpar_alltoall_field: For non-dmpar, arrayIn and arrayOut dims must match.'
call dmpar_abort(dminfo)
else
- arrayOut(:,:) = arrayIn(:,:)
+ arrayOut(:,1:nNeededList) = arrayIn(:,1:nOwnedList)
end if
#endif
@@ -869,8 +888,8 @@
implicit none
type (dm_info), intent(in) :: dminfo
- real (kind=RKIND), dimension(nOwnedList), intent(in) :: arrayIn
- real (kind=RKIND), dimension(nNeededList), intent(inout) :: arrayOut
+ 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
@@ -946,7 +965,7 @@
write(0,*) 'Error in dmpar_alltoall_field: For non-dmpar, arrayIn and arrayOut dims must match.'
call dmpar_abort(dminfo)
else
- arrayOut(:) = arrayIn(:)
+ arrayOut(1:nNeededList) = arrayIn(1:nOwnedList)
end if
#endif
@@ -959,8 +978,8 @@
type (dm_info), intent(in) :: dminfo
integer, intent(in) :: dim1, nOwnedList, nNeededList
- real (kind=RKIND), dimension(dim1,nOwnedList), intent(in) :: arrayIn
- real (kind=RKIND), dimension(dim1,nNeededList), intent(inout) :: arrayOut
+ 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
@@ -1038,7 +1057,7 @@
write(0,*) 'Error in dmpar_alltoall_field: For non-dmpar, arrayIn and arrayOut dims must match.'
call dmpar_abort(dminfo)
else
- arrayOut(:,:) = arrayIn(:,:)
+ arrayOut(:,1:nNeededList) = arrayIn(:,1:nOwnedList)
end if
#endif
@@ -1051,8 +1070,8 @@
type (dm_info), intent(in) :: dminfo
integer, intent(in) :: dim1, dim2, nOwnedList, nNeededList
- real (kind=RKIND), dimension(dim1,dim2,nOwnedList), intent(in) :: arrayIn
- real (kind=RKIND), dimension(dim1,dim2,nNeededList), intent(inout) :: arrayOut
+ 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
@@ -1130,7 +1149,7 @@
write(0,*) 'Error in dmpar_alltoall_field: For non-dmpar, arrayIn and arrayOut dims must match.'
call dmpar_abort(dminfo)
else
- arrayOut(:,:,:) = arrayIn(:,:,:)
+ arrayOut(:,:,1:nNeededList) = arrayIn(:,:,1:nOwnedList)
end if
#endif
@@ -1142,7 +1161,7 @@
implicit none
integer, intent(in) :: nField, nBuffer, startPackIdx
- integer, dimension(nField), intent(in) :: field
+ integer, dimension(*), intent(in) :: field
type (exchange_list), intent(in) :: sendList
integer, dimension(nBuffer), intent(out) :: buffer
integer, intent(inout) :: nPacked, lastPackedIdx
@@ -1169,7 +1188,7 @@
implicit none
integer, intent(in) :: ds, de, nField, nBuffer, startPackIdx
- integer, dimension(ds:de,1:nField), intent(in) :: field
+ integer, dimension(ds:de,*), intent(in) :: field
type (exchange_list), intent(in) :: sendList
integer, dimension(nBuffer), intent(out) :: buffer
integer, intent(inout) :: nPacked, lastPackedIdx
@@ -1203,7 +1222,7 @@
implicit none
integer, intent(in) :: nField, nBuffer, startPackIdx
- real (kind=RKIND), dimension(nField), intent(in) :: field
+ 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
@@ -1230,7 +1249,7 @@
implicit none
integer, intent(in) :: ds, de, nField, nBuffer, startPackIdx
- real (kind=RKIND), dimension(ds:de,1:nField), intent(in) :: field
+ 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
@@ -1264,7 +1283,7 @@
implicit none
integer, intent(in) :: d1s, d1e, d2s, d2e, nField, nBuffer, startPackIdx
- real (kind=RKIND), dimension(d1s:d1e,d2s:d2e,1:nField), intent(in) :: field
+ 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
@@ -1302,7 +1321,7 @@
implicit none
integer, intent(in) :: nField, nBuffer, startUnpackIdx
- integer, dimension(nField), intent(inout) :: field
+ integer, dimension(*), intent(inout) :: field
type (exchange_list), intent(in) :: recvList
integer, dimension(nBuffer), intent(in) :: buffer
integer, intent(inout) :: nUnpacked, lastUnpackedIdx
@@ -1329,7 +1348,7 @@
implicit none
integer, intent(in) :: ds, de, nField, nBuffer, startUnpackIdx
- integer, dimension(ds:de,1:nField), intent(inout) :: field
+ integer, dimension(ds:de,*), intent(inout) :: field
type (exchange_list), intent(in) :: recvList
integer, dimension(nBuffer), intent(in) :: buffer
integer, intent(inout) :: nUnpacked, lastUnpackedIdx
@@ -1358,7 +1377,7 @@
implicit none
integer, intent(in) :: nField, nBuffer, startUnpackIdx
- real (kind=RKIND), dimension(nField), intent(inout) :: field
+ 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
@@ -1385,7 +1404,7 @@
implicit none
integer, intent(in) :: ds, de, nField, nBuffer, startUnpackIdx
- real (kind=RKIND), dimension(ds:de,1:nField), intent(inout) :: field
+ 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
@@ -1415,7 +1434,7 @@
implicit none
integer, intent(in) :: d1s, d1e, d2s, d2e, nField, nBuffer, startUnpackIdx
- real (kind=RKIND), dimension(d1s:d1e,d2s:d2e,1:nField), intent(inout) :: field
+ 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
@@ -1449,7 +1468,7 @@
type (dm_info), intent(in) :: dminfo
integer, intent(in) :: dim1
- real (kind=RKIND), dimension(dim1), intent(inout) :: array
+ real (kind=RKIND), dimension(*), intent(inout) :: array
type (exchange_list), pointer :: sendList, recvList
type (exchange_list), pointer :: sendListPtr, recvListPtr
@@ -1509,7 +1528,7 @@
type (dm_info), intent(in) :: dminfo
integer, intent(in) :: dim1, dim2
- real (kind=RKIND), dimension(dim1,dim2), intent(inout) :: array
+ real (kind=RKIND), dimension(dim1,*), intent(inout) :: array
type (exchange_list), pointer :: sendList, recvList
type (exchange_list), pointer :: sendListPtr, recvListPtr
@@ -1573,7 +1592,7 @@
type (dm_info), intent(in) :: dminfo
integer, intent(in) :: dim1, dim2, dim3
- real (kind=RKIND), dimension(dim1,dim2,dim3), intent(inout) :: array
+ real (kind=RKIND), dimension(dim1,dim2,*), intent(inout) :: array
type (exchange_list), pointer :: sendList, recvList
type (exchange_list), pointer :: sendListPtr, recvListPtr
Modified: branches/ocean_projects/port_adv_mwh/src/framework/module_grid_types.F
===================================================================
--- branches/ocean_projects/port_adv_mwh/src/framework/module_grid_types.F 2010-06-18 22:07:12 UTC (rev 362)
+++ branches/ocean_projects/port_adv_mwh/src/framework/module_grid_types.F 2010-06-23 17:20:20 UTC (rev 363)
@@ -70,6 +70,9 @@
#include "field_dimensions.inc"
+ logical :: on_a_sphere
+ real (kind=RKIND) :: sphere_radius
+
#include "time_invariant_fields.inc"
end type grid_meta
Modified: branches/ocean_projects/port_adv_mwh/src/framework/module_io_input.F
===================================================================
--- branches/ocean_projects/port_adv_mwh/src/framework/module_io_input.F 2010-06-18 22:07:12 UTC (rev 362)
+++ branches/ocean_projects/port_adv_mwh/src/framework/module_io_input.F 2010-06-23 17:20:20 UTC (rev 363)
@@ -21,6 +21,7 @@
interface io_input_field
+ module procedure io_input_field0dReal
module procedure io_input_field1dReal
module procedure io_input_field2dReal
module procedure io_input_field3dReal
@@ -48,6 +49,9 @@
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
@@ -102,6 +106,7 @@
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
@@ -692,7 +697,28 @@
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?)
!
@@ -706,6 +732,18 @@
#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
@@ -764,7 +802,7 @@
readCellStart, nReadCells, readEdgeStart, nReadEdges, readVertexStart, nReadVertices, &
readVertLevelStart, nReadVertLevels, &
sendCellList, recvCellList, sendEdgeList, recvEdgeList, sendVertexList, recvVertexList, &
- sendVertLevelList, recvVertLevelList)
+ sendVertLevelList, recvVertLevelList, sendVertLevelP1List, recvVertLevelP1List)
call io_input_finalize(input_obj, domain % dminfo)
@@ -804,7 +842,8 @@
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) = 0
+ 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, &
@@ -812,7 +851,8 @@
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) = 0
+ 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, &
@@ -820,7 +860,8 @@
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) = 0
+ domain % blocklist % mesh % verticesOnCell % array(j,i) = domain % blocklist % mesh % nVertices + 1
+! domain % blocklist % mesh % verticesOnCell % array(j,i) = 0
end if
end do
@@ -834,7 +875,8 @@
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) = 0
+ 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, &
@@ -842,7 +884,8 @@
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) = 0
+ domain % blocklist % mesh % verticesOnEdge % array(j,i) = domain % blocklist % mesh % nVertices + 1
+! domain % blocklist % mesh % verticesOnEdge % array(j,i) = 0
end if
end do
@@ -854,7 +897,8 @@
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) = 0
+ domain % blocklist % mesh % edgesOnEdge % array(j,i) = domain % blocklist % mesh % nEdges + 1
+! domain % blocklist % mesh % edgesOnEdge % array(j,i) = 0
end if
end do
@@ -868,7 +912,8 @@
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) = 0
+ 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, &
@@ -876,7 +921,8 @@
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) = 0
+ domain % blocklist % mesh % edgesOnVertex % array(j,i) = domain % blocklist % mesh % nEdges + 1
+! domain % blocklist % mesh % edgesOnVertex % array(j,i) = 0
end if
end do
@@ -968,7 +1014,8 @@
sendCellsList, recvCellsList, &
sendEdgesList, recvEdgesList, &
sendVerticesList, recvVerticesList, &
- sendVertLevelsList, recvVertLevelsList)
+ sendVertLevelsList, recvVertLevelsList, &
+ sendVertLevelsP1List, recvVertLevelsP1List)
implicit none
@@ -981,6 +1028,7 @@
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
@@ -993,10 +1041,10 @@
integer, dimension(:), pointer :: super_int1d
integer, dimension(:,:), pointer :: super_int2d
- real :: super_real0d
- real, dimension(:), pointer :: super_real1d
- real, dimension(:,:), pointer :: super_real2d
- real, dimension(:,:,:), pointer :: super_real3d
+ 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
@@ -1031,6 +1079,17 @@
#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"
@@ -1056,7 +1115,86 @@
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
Modified: branches/ocean_projects/port_adv_mwh/src/framework/module_io_output.F
===================================================================
--- branches/ocean_projects/port_adv_mwh/src/framework/module_io_output.F 2010-06-18 22:07:12 UTC (rev 362)
+++ branches/ocean_projects/port_adv_mwh/src/framework/module_io_output.F 2010-06-23 17:20:20 UTC (rev 363)
@@ -23,10 +23,12 @@
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
@@ -65,6 +67,8 @@
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"
@@ -86,6 +90,7 @@
! 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"
)
@@ -109,6 +114,7 @@
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, &
@@ -126,9 +132,9 @@
integer, dimension(:), pointer :: super_int1d
integer, dimension(:,:), pointer :: super_int2d
real :: super_real0d
- real, dimension(:), pointer :: super_real1d
- real, dimension(:,:), pointer :: super_real2d
- real, dimension(:,:,:), pointer :: super_real3d
+ 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
@@ -187,8 +193,12 @@
domain % blocklist % mesh % edgesOnEdge % array(j,i))
end do
do j=domain % blocklist % mesh % nEdgesOnEdge % array(i)+1,2*domain % blocklist % mesh % maxEdges
- edgesOnEdge(j,i) = domain % blocklist % mesh % indexToEdgeID % array( &
+ 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
@@ -205,6 +215,7 @@
allocate(neededEdgeList(nEdgesGlobal))
allocate(neededVertexList(nVerticesGlobal))
allocate(neededVertLevelList(nVertLevelsGlobal))
+ allocate(neededVertLevelP1List(nVertLevelsGlobal+1))
do i=1,nCellsGlobal
neededCellList(i) = i
end do
@@ -217,11 +228,15 @@
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
@@ -245,6 +260,11 @@
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
@@ -307,6 +327,7 @@
subroutine io_output_init( output_obj, &
dminfo, &
+ mesh, &
#include "dim_dummy_args.inc"
)
@@ -316,6 +337,7 @@
type (io_output_object), intent(inout) :: output_obj
type (dm_info), intent(in) :: dminfo
+ type (grid_meta), intent(in) :: mesh
#include "dim_dummy_decls.inc"
integer :: nferr
@@ -329,6 +351,17 @@
#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
@@ -336,6 +369,35 @@
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
Modified: branches/ocean_projects/port_adv_mwh/src/framework/module_zoltan_interface.F
===================================================================
--- branches/ocean_projects/port_adv_mwh/src/framework/module_zoltan_interface.F 2010-06-18 22:07:12 UTC (rev 362)
+++ branches/ocean_projects/port_adv_mwh/src/framework/module_zoltan_interface.F 2010-06-23 17:20:20 UTC (rev 363)
@@ -1,9 +1,10 @@
module zoltan_interface
use zoltan
- use mpi
implicit none
+ include 'mpif.h'
+
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! Data for reordering cells
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Modified: branches/ocean_projects/port_adv_mwh/src/operators/Makefile
===================================================================
--- branches/ocean_projects/port_adv_mwh/src/operators/Makefile 2010-06-18 22:07:12 UTC (rev 362)
+++ branches/ocean_projects/port_adv_mwh/src/operators/Makefile 2010-06-23 17:20:20 UTC (rev 363)
@@ -1,19 +1,19 @@
.SUFFIXES: .F .o
-OBJS = module_vector_reconstruction.o
+OBJS = module_RBF_interpolation.o module_vector_reconstruction.o
all: operators
operators: $(OBJS)
ar -ru libops.a $(OBJS)
-module_vector_reconstruction.o:
+module_vector_reconstruction.o: module_RBF_interpolation.o
+module_RBF_interpolation.o:
clean:
- $(RM) *.o *.mod libops.a
+ $(RM) *.o *.mod *.f90 libops.a
.F.o:
$(RM) $@ $*.mod
$(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90
$(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../framework
- $(RM) $*.f90
Copied: branches/ocean_projects/port_adv_mwh/src/operators/module_RBF_interpolation.F (from rev 362, trunk/mpas/src/operators/module_RBF_interpolation.F)
===================================================================
--- branches/ocean_projects/port_adv_mwh/src/operators/module_RBF_interpolation.F (rev 0)
+++ branches/ocean_projects/port_adv_mwh/src/operators/module_RBF_interpolation.F 2010-06-23 17:20:20 UTC (rev 363)
@@ -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 (grid_meta), 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
+
Modified: branches/ocean_projects/port_adv_mwh/src/operators/module_vector_reconstruction.F
===================================================================
--- branches/ocean_projects/port_adv_mwh/src/operators/module_vector_reconstruction.F 2010-06-18 22:07:12 UTC (rev 362)
+++ branches/ocean_projects/port_adv_mwh/src/operators/module_vector_reconstruction.F 2010-06-23 17:20:20 UTC (rev 363)
@@ -1,454 +1,203 @@
module vector_reconstruction
- use grid_types
- use configure
- use constants
+ use grid_types
+ use configure
+ use constants
+ use RBF_interpolation
- implicit none
+ implicit none
- public :: init_reconstruct, reconstruct
+ public :: init_reconstruct, reconstruct
- contains
+ 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
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ 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
+ implicit none
- type (grid_meta), intent(inout) :: grid
+ type (grid_meta), intent(inout) :: grid
- ! temporary arrays needed in the (to be constructed) init procedure
- integer :: nCells, nEdges, nVertLevels, nCellsSolve
- integer, dimension(:,:), pointer :: cellsOnCell, edgesOnCell, cellsOnEdge
- integer, dimension(:), pointer :: nEdgesOnCell
- integer :: iEdge, iCell, k, cell1, cell2, EdgeMax, j, i, npoints, matrixSize
- integer :: lwork, info
- integer, allocatable, dimension(:) :: pivotingIndices
- real (kind=RKIND), dimension(:), pointer :: dcEdge, xCell, yCell, zCell
- real (kind=RKIND) :: r, rbfValue, v, X1(3), X2(3), alpha, rHat(3), normalDotRHat
- real (kind=RKIND) :: xPlane, yPlane, xNormalPlane, yNormalPlane, xHatPlane(3), yHatPlane(3)
- real (kind=RKIND), allocatable, dimension(:,:,:) :: xLoc
+ ! 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 :: coeffs_reconstruct
- real (kind=RKIND), allocatable, dimension(:,:) :: mwork
- real (kind=RKIND), dimension(:,:), pointer :: matrix, invMatrix
- real (kind=RKIND), dimension(:,:), pointer :: normals
+ real(kind=RKIND), dimension(:,:), pointer :: edgeNormalVectors
+ real(kind=RKIND), dimension(:,:,:), pointer :: cellTangentPlane
- !========================================================
- ! arrays filled and saved during init procedure
- !========================================================
- coeffs_reconstruct => grid % coeffs_reconstruct % array
+ real (kind=RKIND), dimension(:,:,:), pointer :: coeffs_reconstruct
- !========================================================
- ! temporary variables needed for init procedure
- !========================================================
- xCell => grid % xCell % array
- yCell => grid % yCell % array
- zCell => grid % zCell % array
- cellsOnCell => grid % cellsOnCell % array
- cellsOnEdge => grid % cellsOnEdge % array
- edgesOnCell => grid % edgesOnCell % array
- nEdgesOnCell=> grid % nEdgesOnCell % array
- dcEdge => grid % dcEdge % array
- nCells = grid % nCells
- nCellsSolve = grid % nCellsSolve
- nEdges = grid % nEdges
- nVertLevels = grid % nVertLevels
+ !========================================================
+ ! arrays filled and saved during init procedure
+ !========================================================
+ coeffs_reconstruct => grid % coeffs_reconstruct % array
- ! allocate arrays
- EdgeMax = maxval(nEdgesOnCell)
- allocate(xLoc(3,EdgeMax,nCells))
+ !========================================================
+ ! 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
- allocate(normals(3,EdgeMax))
-
- ! init arrays
- coeffs_reconstruct = 0.0
- normals = 0
- ! loop over all cells to be solved on this block
- do iCell=1,nCellsSolve
+ ! init arrays
+ coeffs_reconstruct = 0.0
- ! fill normal vector and xLoc arrays
- ! X1 is the location of the reconstruction, X2 are the neighboring centers,
- ! xLoc is the edge positions
- cell1 = iCell
- X1(1) = xCell(cell1)
- X1(2) = yCell(cell1)
- X1(3) = zCell(cell1)
+ maxEdgeCount = maxval(nEdgesOnCell)
- rHat = X1
- call unit_vector_in_R3(rHat)
+ allocate(edgeOnCellLocations(maxEdgeCount,3))
+ allocate(edgeOnCellNormals(maxEdgeCount,3))
+ allocate(coeffs(maxEdgeCount,3))
- do j=1,nEdgesOnCell(iCell)
- iEdge = edgesOnCell(j,iCell)
- if (iCell == cellsOnEdge(1,iEdge)) then
- cell2 = cellsOnEdge(2,iEdge)
- X2(1) = xCell(cell2)
- X2(2) = yCell(cell2)
- X2(3) = zCell(cell2)
- normals(:,j) = X2(:) - X1(:)
- else
- cell2 = cellsOnEdge(1,iEdge)
- X2(1) = xCell(cell2)
- X2(2) = yCell(cell2)
- X2(3) = zCell(cell2)
- normals(:,j) = X1(:) - X2(:)
- endif
+ ! 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)
- call unit_vector_in_R3(normals(:,j))
+ 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
- xLoc(:,j,iCell) = 0.5*(X2(:) + X1(:))
- enddo
+ alpha = 0.0
+ do i=1,pointCount
+ r = sqrt(sum((cellCenter - edgeOnCellLocations(i,:))**2))
+ alpha = alpha + r
+ enddo
+ alpha = alpha/pointCount
- npoints = nEdgesOnCell(iCell) ! only loop over the number of edges for this cell
- matrixSize = npoints+2 ! room for 2 vector components for constant flow
- ! basis functions
- allocate(matrix(matrixSize,matrixSize))
- matrix = 0.0
- alpha = 0.0
- do i=1,npoints
- call get_distance(xLoc(:,i,iCell),X1(:),r)
- alpha = alpha + r
- enddo
- alpha = alpha / npoints
- do j=1,npoints
- do i=1,npoints
- call get_distance(xLoc(:,i,iCell),xLoc(:,j,iCell),r)
- r = r / alpha
- call evaluate_rbf(r,rbfValue)
- call get_dotproduct(normals(:,i),normals(:,j),v)
- matrix(i,j) = v*rbfValue
- enddo
- enddo
+ tangentPlane(1,:) = cellTangentPlane(:,1,iCell)
+ tangentPlane(2,:) = cellTangentPlane(:,2,iCell)
- ! add matrix entries to suppoert constant flow
- ! xHat and yHat are a local basis in the plane of the horizontal cell
- ! we arbitrarily choose xHat to point toward the first edge
- call get_dotproduct(normals(:,1),rHat,normalDotRHat)
- xHatPlane = normals(:,1) - normalDotRHat*rHat(:)
- call unit_vector_in_R3(xHatPlane)
+ 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
- call cross_product_in_R3(rHat, xHatPlane, yHatPlane)
- call unit_vector_in_R3(yHatPlane) ! just to be sure...
+ enddo ! iCell
- do j=1,npoints
- call get_dotproduct(normals(:,j),xHatPlane, xNormalPlane)
- call get_dotproduct(normals(:,j),yHatPlane, yNormalPlane)
- matrix(j,npoints+1) = xNormalPlane
- matrix(j,npoints+2) = yNormalPlane
- matrix(npoints+1,j) = matrix(j,npoints+1)
- matrix(npoints+2,j) = matrix(j,npoints+2)
- end do
-
-
- ! invert matrix
- allocate(invMatrix(matrixSize,matrixSize))
- allocate(pivotingIndices(matrixSize))
- invMatrix = 0.0
- pivotingIndices = 0
- call migs(matrix,matrixSize,invMatrix,pivotingIndices)
+ deallocate(edgeOnCellLocations)
+ deallocate(edgeOnCellNormals)
+ deallocate(coeffs)
- ! compute the coefficients for reconstructing uX, uY, uZ at cell centers from
- ! u_i normal to edges
- ! uX = sum_j(coeffs(1,j) * u_j) (similarly for Y,Z)
- ! coeffs(:,j) = sum_i(rbf_values(i) * normal(:,i) * matrix(i,j))
- do i=1,npoints
- ! compute value of RBF when evaluated between reconstruction location and edge locations
- call get_distance(xLoc(:,i,iCell), X1(:), r)
- r = r / alpha
- call evaluate_rbf(r,rbfValue)
+ end subroutine init_reconstruct
- ! project the normals onto tangent plane of the cell
- ! normal = normal - (normal dot r_hat) r_hat
- ! rHat, the unit vector pointing from the domain center to the cell center
- call get_dotproduct(normals(:,i),rHat,normalDotRHat)
- normals(:,i) = normals(:,i) - normalDotRHat*rHat(:)
+ 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
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- do j=1,npoints
- coeffs_reconstruct(:,j,iCell) = coeffs_reconstruct(:,j,iCell) &
- + rbfValue * normals(:,i) * invMatrix(i,j)
- enddo
- enddo
- ! polynomial parts
- do j=1,npoints
- coeffs_reconstruct(:,j,iCell) = coeffs_reconstruct(:,j,iCell) &
- + invMatrix(npoints+1,j)*xHatPlane
- coeffs_reconstruct(:,j,iCell) = coeffs_reconstruct(:,j,iCell) &
- + invMatrix(npoints+2,j)*yHatPlane
- enddo
+ implicit none
- deallocate(matrix)
- deallocate(invMatrix)
- deallocate(pivotingIndices)
+ type (grid_state), intent(inout) :: state
+ type (grid_meta), intent(in) :: grid
- enddo ! iCell
+ ! 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
- deallocate(xLoc)
- deallocate(normals)
+ real (kind=RKIND), dimension(:,:,:), pointer :: coeffs_reconstruct
- end subroutine init_reconstruct
+ logical :: on_a_sphere
+ real (kind=RKIND) :: clat, slat, clon, slon
- subroutine reconstruct(s, 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
+ ! stored arrays used during compute procedure
+ coeffs_reconstruct => grid % coeffs_reconstruct % array
- type (grid_state), intent(inout) :: s
- type (grid_meta), intent(in) :: grid
+ ! 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
- ! 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 :: uReconstructX, uReconstructY, uReconstructZ
+ latCell => grid % latCell % array
+ lonCell => grid % lonCell % array
+ uReconstructZonal => state % uReconstructZonal % array
+ uReconstructMeridional => state % uReconstructMeridional % array
+ on_a_sphere = grid % on_a_sphere
- real (kind=RKIND), dimension(:,:,:), pointer :: coeffs_reconstruct
+ ! init the intent(out)
+ uReconstructX = 0.0
+ uReconstructY = 0.0
+ uReconstructZ = 0.0
- ! stored arrays used during compute procedure
- coeffs_reconstruct => grid % coeffs_reconstruct % array
+ ! 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)
- ! temporary variables
- edgesOnCell => grid % edgesOnCell % array
- nEdgesOnCell=> grid % nEdgesOnCell % array
- nCellsSolve = grid % nCellsSolve
- u => s % u % array
- uReconstructX => s % uReconstructX % array
- uReconstructY => s % uReconstructY % array
- uReconstructZ => s % uReconstructZ % array
+ enddo
+ enddo ! iCell
- ! init the intent(out)
- uReconstructX = 0.0
- uReconstructY = 0.0
- uReconstructZ = 0.0
-
- ! loop over cell centers
+ if(on_a_sphere) then
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
+ 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 subroutine reconstruct
- subroutine get_distance(x1,x2,xout)
- implicit none
- real(kind=RKIND), intent(in) :: x1(3), x2(3)
- real(kind=RKIND), intent(out) :: xout
- xout = sqrt( (x1(1)-x2(1))**2 + (x1(2)-x2(2))**2 + (x1(3)-x2(3))**2 )
- end subroutine get_distance
-
- subroutine get_dotproduct(x1,x2,xout)
- implicit none
- real(kind=RKIND), intent(in) :: x1(3), x2(3)
- real(kind=RKIND), intent(out) :: xout
- xout = x1(1)*x2(1) + x1(2)*x2(2) + x1(3)*x2(3)
- end subroutine get_dotproduct
-
-
- subroutine unit_vector_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_vector_in_R3
-
-
- subroutine evaluate_rbf(xin,xout)
- real(kind=RKIND), intent(in) :: xin
- real(kind=RKIND), intent(out) :: xout
-
- ! Gaussian
- ! xout = exp(-r**2)
-
- ! multiquadrics
- xout = 1.0 / sqrt(1.0**2 + xin**2)
-
- ! other
- ! xout = 1.0 / (1.0**2 + r**2)
-
- end subroutine evaluate_rbf
-
-!======================================================================
-! BEGINNING OF CROSS_PRODUCT_IN_R3
-!======================================================================
- subroutine cross_product_in_R3(p_1,p_2,p_out)
-
-!-----------------------------------------------------------------------
-! PURPOSE: compute p_1 cross p_2 and place in p_out
-!-----------------------------------------------------------------------
-
-!-----------------------------------------------------------------------
-! intent(in)
-!-----------------------------------------------------------------------
- real (kind=RKIND), intent(in) :: &
- p_1 (3), &
- p_2 (3)
-
-!-----------------------------------------------------------------------
-! intent(out)
-!-----------------------------------------------------------------------
- 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
-!======================================================================
-! END OF CROSS_PRODUCT_IN_R3
-!======================================================================
-
-! 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 vector_reconstruction
Modified: branches/ocean_projects/port_adv_mwh/src/registry/gen_inc.c
===================================================================
--- branches/ocean_projects/port_adv_mwh/src/registry/gen_inc.c 2010-06-18 22:07:12 UTC (rev 362)
+++ branches/ocean_projects/port_adv_mwh/src/registry/gen_inc.c 2010-06-23 17:20:20 UTC (rev 363)
@@ -222,12 +222,14 @@
fd = fopen("field_dimensions.inc", "w");
dim_ptr = dims;
while (dim_ptr) {
- if (dim_ptr->constant_value < 0 && !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_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="red">", dim_ptr->name_in_file);
dim_ptr = dim_ptr->next;
}
dim_ptr = dims;
while (dim_ptr) {
- if (dim_ptr->constant_value < 0 && !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_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="gray">", dim_ptr->name_in_file);
dim_ptr = dim_ptr->next;
}
@@ -239,12 +241,17 @@
*/
fd = fopen("dim_dummy_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 && 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 && !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_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="gray">");
@@ -257,12 +264,17 @@
*/
fd = fopen("dim_dummy_decls.inc", "w");
dim_ptr = dims;
- if (dim_ptr && dim_ptr->constant_value < 0 && !is_derived_dim(dim_ptr->name_in_code)) {
+ 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 && !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_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="gray">");
@@ -276,7 +288,8 @@
fd = fopen("dim_decls.inc", "w");
dim_ptr = dims;
while (dim_ptr) {
- if (dim_ptr->constant_value < 0 && !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_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="gray">", dim_ptr->name_in_file);
dim_ptr = dim_ptr->next;
}
@@ -289,7 +302,8 @@
fd = fopen("read_dims.inc", "w");
dim_ptr = dims;
while (dim_ptr) {
- if (dim_ptr->constant_value < 0 && !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);
+ 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="gray">", dim_ptr->name_in_file, dim_ptr->name_in_file);
dim_ptr = dim_ptr->next;
}
@@ -365,7 +379,8 @@
dim_ptr = dims;
while (dim_ptr) {
- if (dim_ptr->constant_value < 0 && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, " g %% %s = %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, " g %% %s = %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, " g %% %s = %s</font>
<font color="black">", dim_ptr->name_in_file, dim_ptr->name_in_file);
dim_ptr = dim_ptr->next;
}
fortprintf(fd, "</font>
<font color="gray">");
@@ -387,10 +402,22 @@
fortprintf(fd, " allocate(g %% %s %% ioinfo)</font>
<font color="red">", var_ptr2->super_array);
fortprintf(fd, " allocate(g %% %s %% array(%i, ", var_ptr2->super_array, i);
dimlist_ptr = var_ptr2->dimlist;
- fortprintf(fd, "%s", dimlist_ptr->dim->name_in_code);
+ 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))
+ fortprintf(fd, "%s + 1", dimlist_ptr->dim->name_in_code);
+ 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) {
- fortprintf(fd, ", %s", dimlist_ptr->dim->name_in_code);
+ 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))
+ fortprintf(fd, ", %s + 1", dimlist_ptr->dim->name_in_code);
+ 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="gray">");
@@ -414,16 +441,30 @@
else {
fortprintf(fd, " allocate(g %% %s)</font>
<font color="black">", var_ptr->name_in_code);
fortprintf(fd, " allocate(g %% %s %% ioinfo)</font>
<font color="red">", var_ptr->name_in_code);
- fortprintf(fd, " allocate(g %% %s %% array(", var_ptr->name_in_code);
- dimlist_ptr = var_ptr->dimlist;
- fortprintf(fd, "%s", dimlist_ptr->dim->name_in_code);
- dimlist_ptr = dimlist_ptr->next;
- while (dimlist_ptr) {
- fortprintf(fd, ", %s", dimlist_ptr->dim->name_in_code);
+ if (var_ptr->ndims > 0) {
+ fortprintf(fd, " allocate(g %% %s %% array(", 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))
+ fortprintf(fd, "%s + 1", dimlist_ptr->dim->name_in_code);
+ 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))
+ fortprintf(fd, ", %s + 1", dimlist_ptr->dim->name_in_code);
+ 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="red">");
+
}
- fortprintf(fd, "))</font>
<font color="red">");
-
if (var_ptr->iostreams & INPUT0)
fortprintf(fd, " g %% %s %% ioinfo %% input = .true.</font>
<font color="gray">", var_ptr->name_in_code);
else
@@ -473,9 +514,15 @@
fortprintf(fd, " deallocate(g %% %s)</font>
<font color="black"></font>
<font color="red">", var_ptr2->super_array);
}
else {
- fortprintf(fd, " deallocate(g %% %s %% array)</font>
<font color="red">", var_ptr->name_in_code);
- fortprintf(fd, " deallocate(g %% %s %% ioinfo)</font>
<font color="red">", var_ptr->name_in_code);
- fortprintf(fd, " deallocate(g %% %s)</font>
<font color="black"></font>
<font color="blue">", var_ptr->name_in_code);
+ if (var_ptr->ndims > 0) {
+ fortprintf(fd, " deallocate(g %% %s %% array)</font>
<font color="blue">", var_ptr->name_in_code);
+ fortprintf(fd, " deallocate(g %% %s %% ioinfo)</font>
<font color="blue">", var_ptr->name_in_code);
+ fortprintf(fd, " deallocate(g %% %s)</font>
<font color="black"></font>
<font color="blue">", var_ptr->name_in_code);
+ }
+ else {
+ fortprintf(fd, " deallocate(g %% %s %% ioinfo)</font>
<font color="blue">", var_ptr->name_in_code);
+ fortprintf(fd, " deallocate(g %% %s)</font>
<font color="black"></font>
<font color="gray">", var_ptr->name_in_code);
+ }
var_ptr = var_ptr->next;
}
}
@@ -508,10 +555,22 @@
fortprintf(fd, " allocate(s %% %s %% ioinfo)</font>
<font color="red">", var_ptr2->super_array);
fortprintf(fd, " allocate(s %% %s %% array(%i, ", var_ptr2->super_array, i);
dimlist_ptr = var_ptr2->dimlist;
- fortprintf(fd, "b %% mesh %% %s", dimlist_ptr->dim->name_in_code);
+ 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))
+ fortprintf(fd, "b %% mesh %% %s + 1", dimlist_ptr->dim->name_in_code);
+ else
+ if (dimlist_ptr->dim->namelist_defined) fortprintf(fd, "b %% mesh %% %s", dimlist_ptr->dim->name_in_file);
+ else fortprintf(fd, "b %% mesh %% %s", dimlist_ptr->dim->name_in_code);
dimlist_ptr = dimlist_ptr->next;
while (dimlist_ptr) {
- fortprintf(fd, ", b %% mesh %% %s", dimlist_ptr->dim->name_in_code);
+ 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))
+ fortprintf(fd, ", b %% mesh %% %s + 1", dimlist_ptr->dim->name_in_code);
+ else
+ if (dimlist_ptr->dim->namelist_defined) fortprintf(fd, ", b %% mesh %% %s", dimlist_ptr->dim->name_in_file);
+ else fortprintf(fd, ", b %% mesh %% %s", dimlist_ptr->dim->name_in_code);
dimlist_ptr = dimlist_ptr->next;
}
fortprintf(fd, "))</font>
<font color="gray">");
@@ -538,10 +597,32 @@
fortprintf(fd, " allocate(s %% %s %% ioinfo)</font>
<font color="red">", var_ptr->name_in_code);
fortprintf(fd, " allocate(s %% %s %% array(", var_ptr->name_in_code);
dimlist_ptr = var_ptr->dimlist;
- fortprintf(fd, "b %% mesh %% %s", dimlist_ptr->dim->name_in_code);
+ if (dimlist_ptr->dim->constant_value < 0) {
+ 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))
+ fortprintf(fd, "b %% mesh %% %s + 1", dimlist_ptr->dim->name_in_code);
+ else
+ if (dimlist_ptr->dim->namelist_defined) fortprintf(fd, "b %% mesh %% %s", dimlist_ptr->dim->name_in_file);
+ else fortprintf(fd, "b %% mesh %% %s", dimlist_ptr->dim->name_in_code);
+ }
+ else {
+ fortprintf(fd, "%i", dimlist_ptr->dim->constant_value);
+ }
dimlist_ptr = dimlist_ptr->next;
while (dimlist_ptr) {
- fortprintf(fd, ", b %% mesh %% %s", dimlist_ptr->dim->name_in_code);
+ if (dimlist_ptr->dim->constant_value < 0) {
+ 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))
+ fortprintf(fd, ", b %% mesh %% %s + 1", dimlist_ptr->dim->name_in_code);
+ else
+ if (dimlist_ptr->dim->namelist_defined) fortprintf(fd, ", b %% mesh %% %s", dimlist_ptr->dim->name_in_file);
+ else fortprintf(fd, ", b %% mesh %% %s", dimlist_ptr->dim->name_in_code);
+ }
+ else {
+ fortprintf(fd, ", %i", dimlist_ptr->dim->constant_value);
+ }
dimlist_ptr = dimlist_ptr->next;
}
fortprintf(fd, "))</font>
<font color="gray">");
@@ -725,7 +806,7 @@
fortprintf(fd, " integer :: rdDimIDTime</font>
<font color="red">");
dim_ptr = dims;
while (dim_ptr) {
- if (dim_ptr->constant_value < 0 && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, " integer :: rdDimID%s</font>
<font color="blue">", dim_ptr->name_in_file);
+ 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="black">", dim_ptr->name_in_file);
dim_ptr = dim_ptr->next;
}
fortprintf(fd, "</font>
<font color="gray">");
@@ -733,7 +814,7 @@
fortprintf(fd, " integer :: rdLocalTime</font>
<font color="red">");
dim_ptr = dims;
while (dim_ptr) {
- if (dim_ptr->constant_value < 0 && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, " integer :: rdLocal%s</font>
<font color="blue">", dim_ptr->name_in_file);
+ 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="black">", dim_ptr->name_in_file);
dim_ptr = dim_ptr->next;
}
fortprintf(fd, "</font>
<font color="gray">");
@@ -793,7 +874,8 @@
fortprintf(fd, "#endif</font>
<font color="red">");
}
if (dimlist_ptr->dim->constant_value < 0)
- 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);
+ 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="black">", vtype, var_ptr->ndims, i, dimlist_ptr->dim->name_in_file);
else
fortprintf(fd, " %s%id %% ioinfo %% count(%i) = %s</font>
<font color="gray">", vtype, var_ptr->ndims, i, dimlist_ptr->dim->name_in_code);
if (has_vert_dim) {
@@ -826,7 +908,8 @@
if (i < var_ptr->ndims) {
if (dimlist_ptr->dim->constant_value < 0)
- fortprintf(fd, "block %% mesh %% %s", dimlist_ptr->dim->name_in_code);
+ 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);
}
@@ -846,7 +929,8 @@
while (dimlist_ptr) {
if (i < var_ptr->ndims) {
if (dimlist_ptr->dim->constant_value < 0)
- fortprintf(fd, ", block %% mesh %% %s", dimlist_ptr->dim->name_in_code);
+ 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);
}
@@ -872,7 +956,8 @@
if (i < var_ptr->ndims) {
if (dimlist_ptr->dim->constant_value < 0)
- fortprintf(fd, "block %% mesh %% %s", dimlist_ptr->dim->name_in_code);
+ 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);
}
@@ -880,7 +965,8 @@
i++;
while (dimlist_ptr) {
if (dimlist_ptr->dim->constant_value < 0)
- fortprintf(fd, ", block %% mesh %% %s", dimlist_ptr->dim->name_in_code);
+ 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);
dimlist_ptr = dimlist_ptr->next;
@@ -936,7 +1022,8 @@
if (i < var_ptr->ndims)
if (dimlist_ptr->dim->constant_value < 0)
- fortprintf(fd, " block %% mesh %% %s", dimlist_ptr->dim->name_in_code);
+ 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 {
@@ -956,7 +1043,8 @@
while (dimlist_ptr) {
if (i < var_ptr->ndims)
if (dimlist_ptr->dim->constant_value < 0)
- fortprintf(fd, ", block %% mesh %% %s", dimlist_ptr->dim->name_in_code);
+ 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 {
@@ -976,10 +1064,7 @@
fortprintf(fd, ", block %% mesh %% %s, &</font>
<font color="red">", lastdim->dim->name_in_code);
if (is_derived_dim(lastdim->dim->name_in_code)) {
- split_derived_dim_string(lastdim->dim->name_in_code, &cp1, &cp2);
- fortprintf(fd, " send%sList, recv%sList)</font>
<font color="red">", cp1, cp1);
- free(cp1);
- free(cp2);
+ fortprintf(fd, " send%sList, recv%sList)</font>
<font color="black">", lastdim->dim->name_in_file+1, lastdim->dim->name_in_file+1);
}
else
fortprintf(fd, " send%sList, recv%sList)</font>
<font color="gray">", lastdim->dim->name_in_code+1, lastdim->dim->name_in_code+1);
@@ -991,7 +1076,8 @@
dimlist_ptr = var_ptr->dimlist;
while (i <= var_ptr->ndims) {
if (dimlist_ptr->dim->constant_value < 0)
- fortprintf(fd, " do i%i=1,block %% mesh %% %s</font>
<font color="blue">", i, dimlist_ptr->dim->name_in_code);
+ 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="black">", i, dimlist_ptr->dim->name_in_file);
else
fortprintf(fd, " do i%i=1,%s</font>
<font color="gray">", i, dimlist_ptr->dim->name_in_code);
@@ -1026,7 +1112,10 @@
fortprintf(fd, " deallocate(super_%s%id)</font>
<font color="red">", vtype, var_ptr->ndims);
}
else {
- fortprintf(fd, " block %% time_levs(1) %% state %% %s %% scalar = %s%id %% scalar</font>
<font color="blue">", var_ptr->name_in_code, vtype, var_ptr->ndims);
+ if (var_ptr->timedim)
+ fortprintf(fd, " block %% time_levs(1) %% state %% %s %% scalar = %s%id %% scalar</font>
<font color="blue">", var_ptr->name_in_code, vtype, var_ptr->ndims);
+ else
+ fortprintf(fd, " block %% mesh %% %s %% scalar = %s%id %% scalar</font>
<font color="black">", var_ptr->name_in_code, vtype, var_ptr->ndims);
}
fortprintf(fd, " end if</font>
<font color="black"></font>
<font color="gray">");
@@ -1046,7 +1135,7 @@
fortprintf(fd, " nferr = nf_inq_dimlen(input_obj %% rd_ncid, input_obj %% rdDimIDTime, input_obj %% rdLocalTime)</font>
<font color="red">");
dim_ptr = dims;
while (dim_ptr) {
- if (dim_ptr->constant_value < 0 && !is_derived_dim(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, " nferr = nf_inq_dimid(input_obj %% rd_ncid, \'%s\', input_obj %% rdDimID%s)</font>
<font color="black">", 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="gray">", dim_ptr->name_in_file, dim_ptr->name_in_file);
}
@@ -1070,13 +1159,25 @@
dim_ptr = dims;
while (dim_ptr->constant_value >= 0 || is_derived_dim(dim_ptr->name_in_code)) dim_ptr = dim_ptr->next;
- fortprintf(fd, " if (trim(dimname) == \'%s\') then</font>
<font color="red">", dim_ptr->name_in_code);
- fortprintf(fd, " dimsize = input_obj %% rdLocal%s</font>
<font color="blue">", dim_ptr->name_in_file);
+ 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="red">", 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)) {
- fortprintf(fd, " else if (trim(dimname) == \'%s\') then</font>
<font color="red">", dim_ptr->name_in_code);
- fortprintf(fd, " dimsize = input_obj %% rdLocal%s</font>
<font color="blue">", dim_ptr->name_in_file);
+ 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="gray">", dim_ptr->name_in_code);
+ }
}
dim_ptr = dim_ptr->next;
}
@@ -1086,10 +1187,10 @@
/*
- * Generate code to read 1d, 2d, 3d time-invariant fields
+ * Generate code to read 0d, 1d, 2d, 3d time-invariant fields
*/
for(j=0; j<2; j++) {
- for(i=1; i<=3; i++) {
+ for(i=0; i<=3; i++) {
if (j == 0) {
sprintf(fname, "input_field%idinteger.inc", i);
ivtype = INTEGER;
@@ -1194,7 +1295,8 @@
dim_ptr = dims;
while (dim_ptr) {
- if (dim_ptr->constant_value < 0 && !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_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="black">", dim_ptr->name_in_file);
dim_ptr = dim_ptr->next;
}
fortprintf(fd, "</font>
<font color="gray">");
@@ -1209,7 +1311,8 @@
dim_ptr = dims;
while (dim_ptr) {
- if (dim_ptr->constant_value < 0 && !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_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="black">", dim_ptr->name_in_file, dim_ptr->name_in_file);
dim_ptr = dim_ptr->next;
}
fortprintf(fd, "</font>
<font color="gray">");
@@ -1223,11 +1326,13 @@
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)) {
- fortprintf(fd, " %sGlobal", 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 && !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_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="gray">");
@@ -1335,7 +1440,8 @@
if (i < var_ptr->ndims) {
fortprintf(fd, " %s%id %% ioinfo %% start(%i) = 1</font>
<font color="red">", vtype, var_ptr->ndims, i);
if (dimlist_ptr->dim->constant_value < 0)
- 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);
+ 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="black">", vtype, var_ptr->ndims, i, dimlist_ptr->dim->name_in_file);
else
fortprintf(fd, " %s%id %% ioinfo %% count(%i) = %s</font>
<font color="gray">", vtype, var_ptr->ndims, i, dimlist_ptr->dim->name_in_code);
}
@@ -1360,7 +1466,8 @@
if (i < var_ptr->ndims)
if (dimlist_ptr->dim->constant_value < 0)
- fortprintf(fd, "domain %% blocklist %% mesh %% %s", dimlist_ptr->dim->name_in_code);
+ 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 {
@@ -1379,7 +1486,8 @@
while (dimlist_ptr) {
if (i < var_ptr->ndims)
if (dimlist_ptr->dim->constant_value < 0)
- fortprintf(fd, ", domain %% blocklist %% mesh %% %s", dimlist_ptr->dim->name_in_code);
+ 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 {
@@ -1405,7 +1513,8 @@
dimlist_ptr = var_ptr->dimlist;
while (dimlist_ptr) {
if (dimlist_ptr->dim->constant_value < 0)
- fortprintf(fd, "domain %% blocklist %% mesh %% %s", dimlist_ptr->dim->name_in_code);
+ 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);
@@ -1422,7 +1531,8 @@
dimlist_ptr = var_ptr->dimlist;
while (i <= var_ptr->ndims) {
if (dimlist_ptr->dim->constant_value < 0)
- fortprintf(fd, " do i%i=1,domain %% blocklist %% mesh %% %s</font>
<font color="blue">", i, dimlist_ptr->dim->name_in_code);
+ 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="black">", i, dimlist_ptr->dim->name_in_file);
else
fortprintf(fd, " do i%i=1,%s</font>
<font color="gray">", i, dimlist_ptr->dim->name_in_code);
@@ -1467,7 +1577,8 @@
dimlist_ptr = var_ptr->dimlist;
if (dimlist_ptr->dim->constant_value < 0)
- fortprintf(fd, " domain %% blocklist %% mesh %% %s", dimlist_ptr->dim->name_in_code);
+ 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);
@@ -1475,7 +1586,8 @@
i++;
while (dimlist_ptr) {
if (dimlist_ptr->dim->constant_value < 0)
- fortprintf(fd, ", domain %% blocklist %% mesh %% %s", dimlist_ptr->dim->name_in_code);
+ 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);
@@ -1486,7 +1598,7 @@
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="red">", cp1, cp2);
- fortprintf(fd, " output_obj %% send%sList, output_obj %% recv%sList)</font>
<font color="blue">", cp1, cp1);
+ fortprintf(fd, " output_obj %% send%sList, output_obj %% recv%sList)</font>
<font color="gray">", lastdim->dim->name_in_file+1, lastdim->dim->name_in_file+1);
free(cp1);
free(cp2);
}
@@ -1497,7 +1609,10 @@
}
else {
fortprintf(fd, " %s%id %% ioinfo %% fieldName = \'%s\'</font>
<font color="red">", vtype, var_ptr->ndims, var_ptr->name_in_file);
- fortprintf(fd, " %s%id %% scalar = domain %% blocklist %% time_levs(1) %% state %% %s %% scalar</font>
<font color="blue">", vtype, var_ptr->ndims, var_ptr->name_in_code);
+ if (var_ptr->timedim)
+ fortprintf(fd, " %s%id %% scalar = domain %% blocklist %% time_levs(1) %% state %% %s %% scalar</font>
<font color="blue">", vtype, var_ptr->ndims, var_ptr->name_in_code);
+ else
+ fortprintf(fd, " %s%id %% scalar = domain %% blocklist %% mesh %% %s %% scalar</font>
<font color="gray">", vtype, var_ptr->ndims, var_ptr->name_in_code);
}
if (var_ptr->timedim)
@@ -1518,10 +1633,10 @@
/*
- * Generate code to write 1d, 2d, 3d time-invariant fields
+ * Generate code to write 0d, 1d, 2d, 3d time-invariant fields
*/
for(j=0; j<2; j++) {
- for(i=1; i<=3; i++) {
+ for(i=0; i<=3; i++) {
if (j == 0) {
sprintf(fname, "output_field%idinteger.inc", i);
ivtype = INTEGER;
Modified: branches/ocean_projects/port_adv_mwh/src/registry/parse.c
===================================================================
--- branches/ocean_projects/port_adv_mwh/src/registry/parse.c 2010-06-18 22:07:12 UTC (rev 362)
+++ branches/ocean_projects/port_adv_mwh/src/registry/parse.c 2010-06-23 17:20:20 UTC (rev 363)
@@ -49,6 +49,7 @@
{
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;
@@ -96,9 +97,31 @@
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="gray">", dim_ptr->name_in_code, dim_ptr->name_in_file);
+ return 1;
+ }
+ }
}
else if (strncmp(word, "var", 1024) == 0) {
NEW_VARIABLE(var_ptr->next)
Modified: branches/ocean_projects/port_adv_mwh/src/registry/registry_types.h
===================================================================
--- branches/ocean_projects/port_adv_mwh/src/registry/registry_types.h 2010-06-18 22:07:12 UTC (rev 362)
+++ branches/ocean_projects/port_adv_mwh/src/registry/registry_types.h 2010-06-23 17:20:20 UTC (rev 363)
@@ -31,6 +31,7 @@
char name_in_file[1024];
char name_in_code[1024];
int constant_value;
+ int namelist_defined;
struct dimension * next;
};
</font>
</pre>