<p><b>dwj07@fsu.edu</b> 2011-10-21 13:18:00 -0600 (Fri, 21 Oct 2011)</p><p><br>
TRUNK COMMIT<br>
<br>
Merging the source_renaming branch to the trunk.<br>
<br>
This includes all module renames and subroutine renames. The naming scheme for modules and files was distributed earlier, and the subroutine naming scheme is similar.<br>
<br>
All subroutines have lowercase names, with underscores separating words. Shared subroutines have the prefix of mpas_ while core specific subroutines have the prefix of [core_abbreviation]_.<br>
<br>
For an example of [core_abbreviation]:<br>
Ocean - ocn<br>
Shallow Water - sw<br>
Hydrostatic Atmosphere - atmh<br>
</p><hr noshade><pre><font color="gray">
Property changes on: trunk/mpas
___________________________________________________________________
Modified: svn:mergeinfo
- /branches/ocean_projects/imp_vert_mix_mrp:754-986
/branches/ocean_projects/split_explicit_timestepping:1044-1097
/branches/ocean_projects/vert_adv_mrp:704-745
/branches/time_manager:924-962
+ /branches/ocean_projects/imp_vert_mix_mrp:754-986
/branches/ocean_projects/split_explicit_timestepping:1044-1097
/branches/ocean_projects/vert_adv_mrp:704-745
/branches/source_renaming:1082-1113
/branches/time_manager:924-962
Modified: trunk/mpas/Makefile
===================================================================
--- trunk/mpas/Makefile 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/Makefile 2011-10-21 19:18:00 UTC (rev 1114)
@@ -1,3 +1,4 @@
+CORE=hyd_atmos
#MODEL_FORMULATION = -DNCAR_FORMULATION
MODEL_FORMULATION = -DLANL_FORMULATION
@@ -82,7 +83,7 @@
ifort-serial:
( make all \
- "FC = mpif90" \
+ "FC = ifort" \
"CC = gcc" \
"SFC = ifort" \
"SCC = gcc" \
@@ -90,7 +91,7 @@
"CFLAGS = -O3 -m64" \
"LDFLAGS = -O3" \
"CORE = $(CORE)" \
- "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE -m64 $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
+ "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) -DUNDERSCORE -m64 $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
ifort-papi:
( make all \
Modified: trunk/mpas/namelist.input.ocean
===================================================================
--- trunk/mpas/namelist.input.ocean 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/namelist.input.ocean 2011-10-21 19:18:00 UTC (rev 1114)
@@ -1,10 +1,10 @@
&sw_model
- config_test_case = 0
- config_time_integration = 'rk4'
+ config_test_case = 5
+ config_time_integration = 'RK4'
config_rk_filter_btr_mode = .false.
config_dt = 10.0
config_start_time = '0000-01-01_00:00:00'
- config_run_duration = '2000_00:00:00'
+ config_run_duration = '-000_00:30:00'
config_stats_interval = 1920
/
&io
@@ -19,7 +19,7 @@
config_restart_interval = '120_00:00:00'
/
&grid
- config_vert_grid_type = 'zlevel'
+ config_vert_grid_type = 'isopycnal'
config_rho0 = 1000
/
&split_explicit_ts
Modified: trunk/mpas/namelist.input.sw
===================================================================
--- trunk/mpas/namelist.input.sw 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/namelist.input.sw 2011-10-21 19:18:00 UTC (rev 1114)
@@ -1,9 +1,9 @@
&sw_model
config_test_case = 5
config_time_integration = 'RK4'
- config_dt = 172.8
+ config_dt = 200.0
config_start_time = '0000-01-01_00:00:00'
- config_run_duration = '15_00:00:00'
+ config_run_duration = '00_05:00:00'
config_stats_interval = 0
config_h_ScaleWithMesh = .false.
config_h_mom_eddy_visc2 = 0.0
@@ -23,7 +23,7 @@
config_input_name = 'grid.nc'
config_output_name = 'output.nc'
config_restart_name = 'restart.nc'
- config_output_interval = '1_00:00:00'
+ config_output_interval = '0_01:00:00'
config_frames_per_outfile = 0
/
Modified: trunk/mpas/src/core_hyd_atmos/Makefile
===================================================================
--- trunk/mpas/src/core_hyd_atmos/Makefile 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_hyd_atmos/Makefile 2011-10-21 19:18:00 UTC (rev 1114)
@@ -1,22 +1,22 @@
.SUFFIXES: .F .o
-OBJS = module_mpas_core.o \
- module_test_cases.o \
- module_time_integration.o \
- module_advection.o
+OBJS = mpas_atmh_mpas_core.o \
+ mpas_atmh_test_cases.o \
+ mpas_atmh_time_integration.o \
+ mpas_atmh_advection.o
all: core_hyd
core_hyd: $(OBJS)
ar -ru libdycore.a $(OBJS)
-module_test_cases.o:
+mpas_atmh_test_cases.o:
-module_time_integration.o:
+mpas_atmh_time_integration.o:
-module_advection.o:
+mpas_atmh_advection.o:
-module_mpas_core.o: module_advection.o module_test_cases.o module_time_integration.o
+mpas_atmh_mpas_core.o: mpas_atmh_advection.o mpas_atmh_test_cases.o mpas_atmh_time_integration.o
clean:
$(RM) *.o *.mod *.f90 libdycore.a
Deleted: trunk/mpas/src/core_hyd_atmos/module_advection.F
===================================================================
--- trunk/mpas/src/core_hyd_atmos/module_advection.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_hyd_atmos/module_advection.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -1,688 +0,0 @@
-module advection
-
- use grid_types
- use configure
- use constants
-
-
- contains
-
-
- subroutine initialize_advection_rk( grid )
-
-!
-! compute the cell coefficients for the polynomial fit.
-! this is performed during setup for model integration.
-! WCS, 31 August 2009
-!
- implicit none
-
- type (mesh_type), intent(in) :: grid
-
- real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
- integer, dimension(:,:), pointer :: advCells
-
-! local variables
-
- real (kind=RKIND), dimension(2, grid % nEdges) :: thetae
- real (kind=RKIND), dimension(grid % nEdges) :: xe, ye
- real (kind=RKIND), dimension(grid % nCells) :: theta_abs
-
- real (kind=RKIND), dimension(25) :: xc, yc, zc ! cell center coordinates
- real (kind=RKIND), dimension(25) :: thetav, thetat, dl_sphere
- real (kind=RKIND) :: xm, ym, zm, dl, xec, yec, zec
- real (kind=RKIND) :: thetae_tmp, xe_tmp, ye_tmp
- real (kind=RKIND) :: xv1, xv2, yv1, yv2, zv1, zv2
- integer :: i, j, k, ip1, ip2, m, n, ip1a, ii
- integer :: iCell, iEdge
- real (kind=RKIND) :: pii
- real (kind=RKIND) :: x0, y0, x1, y1, x2, y2, x3, y3, x4, y4, x5, y5
- real (kind=RKIND) :: pdx1, pdx2, pdx3, pdy1, pdy2, pdy3, dx1, dx2, dy1, dy2
- real (kind=RKIND) :: angv1, angv2, dl1, dl2
- real (kind=RKIND), dimension(25) :: dxe, dye, x2v, y2v, xp, yp
-
- real (kind=RKIND) :: amatrix(25,25), bmatrix(25,25), wmatrix(25,25)
- real (kind=RKIND) :: length_scale
- integer :: ma,na, cell_add, mw, nn
- integer, dimension(25) :: cell_list
-
-
- integer :: cell1, cell2
- integer, parameter :: polynomial_order = 2
-! logical, parameter :: debug = .true.
- logical, parameter :: debug = .false.
-! logical, parameter :: least_squares = .false.
- logical, parameter :: least_squares = .true.
- logical :: add_the_cell, do_the_cell
-
- logical, parameter :: reset_poly = .true.
-
- real (kind=RKIND) :: rcell, cos2t, costsint, sin2t
-
-!---
-
- pii = 2.*asin(1.0)
-
- advCells => grid % advCells % array
- deriv_two => grid % deriv_two % array
- deriv_two(:,:,:) = 0.
-
- do iCell = 1, grid % nCells ! is this correct? - we need first halo cell also...
-
- cell_list(1) = iCell
- do i=2, grid % nEdgesOnCell % array(iCell)+1
- cell_list(i) = grid % CellsOnCell % array(i-1,iCell)
- end do
- n = grid % nEdgesOnCell % array(iCell) + 1
-
- if ( polynomial_order > 2 ) then
- do i=2,grid % nEdgesOnCell % array(iCell) + 1
- do j=1,grid % nEdgesOnCell % array ( cell_list(i) )
- cell_add = grid % CellsOnCell % array (j,cell_list(i))
- add_the_cell = .true.
- do k=1,n
- if ( cell_add == cell_list(k) ) add_the_cell = .false.
- end do
- if (add_the_cell) then
- n = n+1
- cell_list(n) = cell_add
- end if
- end do
- end do
- end if
-
- advCells(1,iCell) = n
-
-! check to see if we are reaching outside the halo
-
- do_the_cell = .true.
- do i=1,n
- if (cell_list(i) > grid % nCells) do_the_cell = .false.
- end do
-
-
- if ( .not. do_the_cell ) cycle
-
-
-! compute poynomial fit for this cell if all needed neighbors exist
- if ( grid % on_a_sphere ) then
-
- do i=1,n
- advCells(i+1,iCell) = cell_list(i)
- xc(i) = grid % xCell % array(advCells(i+1,iCell))/a
- yc(i) = grid % yCell % array(advCells(i+1,iCell))/a
- zc(i) = grid % zCell % array(advCells(i+1,iCell))/a
- end do
-
- theta_abs(iCell) = pii/2. - sphere_angle( xc(1), yc(1), zc(1), &
- xc(2), yc(2), zc(2), &
- 0., 0., 1. )
-
-! angles from cell center to neighbor centers (thetav)
-
- do i=1,n-1
-
- ip2 = i+2
- if (ip2 > n) ip2 = 2
-
- thetav(i) = sphere_angle( xc(1), yc(1), zc(1), &
- xc(i+1), yc(i+1), zc(i+1), &
- xc(ip2), yc(ip2), zc(ip2) )
-
- dl_sphere(i) = a*arc_length( xc(1), yc(1), zc(1), &
- xc(i+1), yc(i+1), zc(i+1) )
- end do
-
- length_scale = 1.
- do i=1,n-1
- dl_sphere(i) = dl_sphere(i)/length_scale
- end do
-
-! thetat(1) = 0. ! this defines the x direction, cell center 1 ->
- thetat(1) = theta_abs(iCell) ! this defines the x direction, longitude line
- do i=2,n-1
- thetat(i) = thetat(i-1) + thetav(i-1)
- end do
-
- do i=1,n-1
- xp(i) = cos(thetat(i)) * dl_sphere(i)
- yp(i) = sin(thetat(i)) * dl_sphere(i)
- end do
-
- else ! On an x-y plane
-
- do i=1,n-1
- 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)
-
- bmatrix = 0.
- amatrix = 0.
- wmatrix = 0.
-
- if (polynomial_order == 2) then
- na = 6
- ma = ma+1
-
- amatrix(1,1) = 1.
- wmatrix(1,1) = 1.
- do i=2,ma
- amatrix(i,1) = 1.
- amatrix(i,2) = xp(i-1)
- amatrix(i,3) = yp(i-1)
- amatrix(i,4) = xp(i-1)**2
- amatrix(i,5) = xp(i-1) * yp(i-1)
- amatrix(i,6) = yp(i-1)**2
-
- wmatrix(i,i) = 1.
- end do
-
- else if (polynomial_order == 3) then
- na = 10
- ma = ma+1
-
- amatrix(1,1) = 1.
- wmatrix(1,1) = 1.
- do i=2,ma
- amatrix(i,1) = 1.
- amatrix(i,2) = xp(i-1)
- amatrix(i,3) = yp(i-1)
-
- amatrix(i,4) = xp(i-1)**2
- amatrix(i,5) = xp(i-1) * yp(i-1)
- amatrix(i,6) = yp(i-1)**2
-
- amatrix(i,7) = xp(i-1)**3
- amatrix(i,8) = yp(i-1) * (xp(i-1)**2)
- amatrix(i,9) = xp(i-1) * (yp(i-1)**2)
- amatrix(i,10) = yp(i-1)**3
-
- wmatrix(i,i) = 1.
-
- end do
-
- else
- na = 15
- ma = ma+1
-
- amatrix(1,1) = 1.
- wmatrix(1,1) = 1.
- do i=2,ma
- amatrix(i,1) = 1.
- amatrix(i,2) = xp(i-1)
- amatrix(i,3) = yp(i-1)
-
- amatrix(i,4) = xp(i-1)**2
- amatrix(i,5) = xp(i-1) * yp(i-1)
- amatrix(i,6) = yp(i-1)**2
-
- amatrix(i,7) = xp(i-1)**3
- amatrix(i,8) = yp(i-1) * (xp(i-1)**2)
- amatrix(i,9) = xp(i-1) * (yp(i-1)**2)
- amatrix(i,10) = yp(i-1)**3
-
- amatrix(i,11) = xp(i-1)**4
- amatrix(i,12) = yp(i-1) * (xp(i-1)**3)
- amatrix(i,13) = (xp(i-1)**2)*(yp(i-1)**2)
- amatrix(i,14) = xp(i-1) * (yp(i-1)**3)
- amatrix(i,15) = yp(i-1)**4
-
- wmatrix(i,i) = 1.
-
- end do
-
- do i=1,mw
- wmatrix(i,i) = 1.
- end do
-
- end if
-
- call poly_fit_2( amatrix, bmatrix, wmatrix, ma, na, 25 )
-
- do i=1,grid % nEdgesOnCell % array (iCell)
- ip1 = i+1
- if (ip1 > n-1) ip1 = 1
-
- iEdge = grid % EdgesOnCell % array (i,iCell)
- xv1 = grid % xVertex % array(grid % verticesOnEdge % array (1,iedge))/a
- yv1 = grid % yVertex % array(grid % verticesOnEdge % array (1,iedge))/a
- zv1 = grid % zVertex % array(grid % verticesOnEdge % array (1,iedge))/a
- xv2 = grid % xVertex % array(grid % verticesOnEdge % array (2,iedge))/a
- yv2 = grid % yVertex % array(grid % verticesOnEdge % array (2,iedge))/a
- zv2 = grid % zVertex % array(grid % verticesOnEdge % array (2,iedge))/a
-
- if ( grid % on_a_sphere ) then
- call arc_bisect( xv1, yv1, zv1, &
- xv2, yv2, zv2, &
- xec, yec, zec )
-
- thetae_tmp = sphere_angle( xc(1), yc(1), zc(1), &
- xc(i+1), yc(i+1), zc(i+1), &
- xec, yec, zec )
- thetae_tmp = thetae_tmp + thetat(i)
- if (iCell == grid % cellsOnEdge % array(1,iEdge)) then
- thetae(1,grid % EdgesOnCell % array (i,iCell)) = thetae_tmp
- else
- thetae(2,grid % EdgesOnCell % array (i,iCell)) = thetae_tmp
- end if
- else
- xe(grid % EdgesOnCell % array (i,iCell)) = 0.5 * (xv1 + xv2)
- ye(grid % EdgesOnCell % array (i,iCell)) = 0.5 * (yv1 + yv2)
- end if
-
- end do
-
-! fill second derivative stencil for rk advection
-
- do i=1, grid % nEdgesOnCell % array (iCell)
- iEdge = grid % EdgesOnCell % array (i,iCell)
-
-
- if ( grid % on_a_sphere ) then
- if (iCell == grid % cellsOnEdge % array(1,iEdge)) then
-
- cos2t = cos(thetae(1,grid % EdgesOnCell % array (i,iCell)))
- sin2t = sin(thetae(1,grid % EdgesOnCell % array (i,iCell)))
- costsint = cos2t*sin2t
- cos2t = cos2t**2
- sin2t = sin2t**2
-
- do j=1,n
- deriv_two(j,1,iEdge) = 2.*cos2t*bmatrix(4,j) &
- + 2.*costsint*bmatrix(5,j) &
- + 2.*sin2t*bmatrix(6,j)
- end do
- else
-
- cos2t = cos(thetae(2,grid % EdgesOnCell % array (i,iCell)))
- sin2t = sin(thetae(2,grid % EdgesOnCell % array (i,iCell)))
- costsint = cos2t*sin2t
- cos2t = cos2t**2
- sin2t = sin2t**2
-
- do j=1,n
- deriv_two(j,2,iEdge) = 2.*cos2t*bmatrix(4,j) &
- + 2.*costsint*bmatrix(5,j) &
- + 2.*sin2t*bmatrix(6,j)
- end do
- end if
- else
- do j=1,n
- deriv_two(j,1,iEdge) = 2.*xe(iEdge)*xe(iEdge)*bmatrix(4,j) &
- + 2.*xe(iEdge)*ye(iEdge)*bmatrix(5,j) &
- + 2.*ye(iEdge)*ye(iEdge)*bmatrix(6,j)
- deriv_two(j,2,iEdge) = deriv_two(j,1,iEdge)
- end do
- end if
- end do
-
- end do ! end of loop over cells
-
- if (debug) stop
-
- end subroutine initialize_advection_rk
-
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! FUNCTION SPHERE_ANGLE
- !
- ! Computes the angle between arcs AB and AC, given points A, B, and C
- ! Equation numbers w.r.t. http://mathworld.wolfram.com/SphericalTrigonometry.html
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- real function sphere_angle(ax, ay, az, bx, by, bz, cx, cy, cz)
-
- implicit none
-
- real (kind=RKIND), intent(in) :: ax, ay, az, bx, by, bz, cx, cy, cz
-
- real (kind=RKIND) :: a, b, c ! Side lengths of spherical triangle ABC
-
- real (kind=RKIND) :: ABx, ABy, ABz ! The components of the vector AB
- real (kind=RKIND) :: mAB ! The magnitude of AB
- real (kind=RKIND) :: ACx, ACy, ACz ! The components of the vector AC
- real (kind=RKIND) :: mAC ! The magnitude of AC
-
- real (kind=RKIND) :: Dx ! The i-components of the cross product AB x AC
- real (kind=RKIND) :: Dy ! The j-components of the cross product AB x AC
- real (kind=RKIND) :: Dz ! The k-components of the cross product AB x AC
-
- real (kind=RKIND) :: s ! Semiperimeter of the triangle
- real (kind=RKIND) :: sin_angle
-
- a = acos(max(min(bx*cx + by*cy + bz*cz,1.0),-1.0)) ! Eqn. (3)
- b = acos(max(min(ax*cx + ay*cy + az*cz,1.0),-1.0)) ! Eqn. (2)
- c = acos(max(min(ax*bx + ay*by + az*bz,1.0),-1.0)) ! Eqn. (1)
-
- ABx = bx - ax
- ABy = by - ay
- ABz = bz - az
-
- ACx = cx - ax
- ACy = cy - ay
- ACz = cz - az
-
- Dx = (ABy * ACz) - (ABz * ACy)
- Dy = -((ABx * ACz) - (ABz * ACx))
- Dz = (ABx * ACy) - (ABy * ACx)
-
- s = 0.5*(a + b + c)
-! sin_angle = sqrt((sin(s-b)*sin(s-c))/(sin(b)*sin(c))) ! Eqn. (28)
- sin_angle = sqrt(min(1.,max(0.,(sin(s-b)*sin(s-c))/(sin(b)*sin(c))))) ! Eqn. (28)
-
- if ((Dx*ax + Dy*ay + Dz*az) >= 0.0) then
- sphere_angle = 2.0 * asin(max(min(sin_angle,1.0),-1.0))
- else
- sphere_angle = -2.0 * asin(max(min(sin_angle,1.0),-1.0))
- end if
-
- end function sphere_angle
-
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! FUNCTION PLANE_ANGLE
- !
- ! Computes the angle between vectors AB and AC, given points A, B, and C, and
- ! a vector (u,v,w) normal to the plane.
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- real function plane_angle(ax, ay, az, bx, by, bz, cx, cy, cz, u, v, w)
-
- implicit none
-
- real (kind=RKIND), intent(in) :: ax, ay, az, bx, by, bz, cx, cy, cz, u, v, w
-
- real (kind=RKIND) :: ABx, ABy, ABz ! The components of the vector AB
- real (kind=RKIND) :: mAB ! The magnitude of AB
- real (kind=RKIND) :: ACx, ACy, ACz ! The components of the vector AC
- real (kind=RKIND) :: mAC ! The magnitude of AC
-
- real (kind=RKIND) :: Dx ! The i-components of the cross product AB x AC
- real (kind=RKIND) :: Dy ! The j-components of the cross product AB x AC
- real (kind=RKIND) :: Dz ! The k-components of the cross product AB x AC
-
- real (kind=RKIND) :: cos_angle
-
- ABx = bx - ax
- ABy = by - ay
- ABz = bz - az
- mAB = sqrt(ABx**2.0 + ABy**2.0 + ABz**2.0)
-
- ACx = cx - ax
- ACy = cy - ay
- ACz = cz - az
- mAC = sqrt(ACx**2.0 + ACy**2.0 + ACz**2.0)
-
-
- Dx = (ABy * ACz) - (ABz * ACy)
- Dy = -((ABx * ACz) - (ABz * ACx))
- Dz = (ABx * ACy) - (ABy * ACx)
-
- cos_angle = (ABx*ACx + ABy*ACy + ABz*ACz) / (mAB * mAC)
-
- if ((Dx*u + Dy*v + Dz*w) >= 0.0) then
- plane_angle = acos(max(min(cos_angle,1.0),-1.0))
- else
- plane_angle = -acos(max(min(cos_angle,1.0),-1.0))
- end if
-
- end function plane_angle
-
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! FUNCTION ARC_LENGTH
- !
- ! Returns the length of the great circle arc from A=(ax, ay, az) to
- ! B=(bx, by, bz). It is assumed that both A and B lie on the surface of the
- ! same sphere centered at the origin.
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- real function arc_length(ax, ay, az, bx, by, bz)
-
- implicit none
-
- real (kind=RKIND), intent(in) :: ax, ay, az, bx, by, bz
-
- real (kind=RKIND) :: r, c
- real (kind=RKIND) :: cx, cy, cz
-
- cx = bx - ax
- cy = by - ay
- cz = bz - az
-
-! r = ax*ax + ay*ay + az*az
-! c = cx*cx + cy*cy + cz*cz
-!
-! arc_length = sqrt(r) * acos(1.0 - c/(2.0*r))
-
- r = sqrt(ax*ax + ay*ay + az*az)
- c = sqrt(cx*cx + cy*cy + cz*cz)
-! arc_length = sqrt(r) * 2.0 * asin(c/(2.0*r))
- arc_length = r * 2.0 * asin(c/(2.0*r))
-
- end function arc_length
-
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! SUBROUTINE ARC_BISECT
- !
- ! Returns the point C=(cx, cy, cz) that bisects the great circle arc from
- ! A=(ax, ay, az) to B=(bx, by, bz). It is assumed that A and B lie on the
- ! surface of a sphere centered at the origin.
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine arc_bisect(ax, ay, az, bx, by, bz, cx, cy, cz)
-
- implicit none
-
- real (kind=RKIND), intent(in) :: ax, ay, az, bx, by, bz
- real (kind=RKIND), intent(out) :: cx, cy, cz
-
- real (kind=RKIND) :: r ! Radius of the sphere
- real (kind=RKIND) :: d
-
- r = sqrt(ax*ax + ay*ay + az*az)
-
- cx = 0.5*(ax + bx)
- cy = 0.5*(ay + by)
- cz = 0.5*(az + bz)
-
- if (cx == 0. .and. cy == 0. .and. cz == 0.) then
- write(0,*) 'Error: arc_bisect: A and B are diametrically opposite'
- else
- d = sqrt(cx*cx + cy*cy + cz*cz)
- cx = r * cx / d
- cy = r * cy / d
- cz = r * cz / d
- end if
-
- end subroutine arc_bisect
-
-
- subroutine poly_fit_2(a_in,b_out,weights_in,m,n,ne)
-
- implicit none
-
- integer, intent(in) :: m,n,ne
- real (kind=RKIND), dimension(ne,ne), intent(in) :: a_in, weights_in
- real (kind=RKIND), dimension(ne,ne), intent(out) :: b_out
-
- ! local storage
-
- real (kind=RKIND), dimension(m,n) :: a
- real (kind=RKIND), dimension(n,m) :: b
- real (kind=RKIND), dimension(m,m) :: w,wt,h
- real (kind=RKIND), dimension(n,m) :: at, ath
- real (kind=RKIND), dimension(n,n) :: ata, ata_inv, atha, atha_inv
- integer, dimension(n) :: indx
- integer :: i,j
-
- if ( (ne<n) .or. (ne<m) ) then
- write(6,*) ' error in poly_fit_2 inversion ',m,n,ne
- stop
- end if
-
-! a(1:m,1:n) = a_in(1:n,1:m)
- a(1:m,1:n) = a_in(1:m,1:n)
- w(1:m,1:m) = weights_in(1:m,1:m)
- b_out(:,:) = 0.
-
- wt = transpose(w)
- h = matmul(wt,w)
- at = transpose(a)
- ath = matmul(at,h)
- atha = matmul(ath,a)
-
- ata = matmul(at,a)
-
-! if (m == n) then
-! call migs(a,n,b,indx)
-! else
-
- call migs(atha,n,atha_inv,indx)
-
- b = matmul(atha_inv,ath)
-
-! call migs(ata,n,ata_inv,indx)
-! b = matmul(ata_inv,at)
-! end if
- b_out(1:n,1:m) = b(1:n,1:m)
-
-! do i=1,n
-! write(6,*) ' i, indx ',i,indx(i)
-! end do
-!
-! write(6,*) ' '
-
- end subroutine poly_fit_2
-
-
-! Updated 10/24/2001.
-!
-!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 4.4 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! !
-! Please Note: !
-! !
-! (1) This computer program is written by Tao Pang in conjunction with !
-! his book, "An Introduction to Computational Physics," published !
-! by Cambridge University Press in 1997. !
-! !
-! (2) No warranties, express or implied, are made for this program. !
-! !
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!
-SUBROUTINE MIGS (A,N,X,INDX)
-!
-! Subroutine to invert matrix A(N,N) with the inverse stored
-! in X(N,N) in the output. Copyright (c) Tao Pang 2001.
-!
- IMPLICIT NONE
- INTEGER, INTENT (IN) :: N
- INTEGER :: I,J,K
- INTEGER, INTENT (OUT), DIMENSION (N) :: INDX
- REAL (kind=RKIND), INTENT (INOUT), DIMENSION (N,N):: A
- REAL (kind=RKIND), INTENT (OUT), DIMENSION (N,N):: X
- REAL (kind=RKIND), DIMENSION (N,N) :: B
-!
- DO I = 1, N
- DO J = 1, N
- B(I,J) = 0.0
- END DO
- END DO
- DO I = 1, N
- B(I,I) = 1.0
- END DO
-!
- CALL ELGS (A,N,INDX)
-!
- DO I = 1, N-1
- DO J = I+1, N
- DO K = 1, N
- B(INDX(J),K) = B(INDX(J),K)-A(INDX(J),I)*B(INDX(I),K)
- END DO
- END DO
- END DO
-!
- DO I = 1, N
- X(N,I) = B(INDX(N),I)/A(INDX(N),N)
- DO J = N-1, 1, -1
- X(J,I) = B(INDX(J),I)
- DO K = J+1, N
- X(J,I) = X(J,I)-A(INDX(J),K)*X(K,I)
- END DO
- X(J,I) = X(J,I)/A(INDX(J),J)
- END DO
- END DO
-END SUBROUTINE MIGS
-
-
-SUBROUTINE ELGS (A,N,INDX)
-!
-! Subroutine to perform the partial-pivoting Gaussian elimination.
-! A(N,N) is the original matrix in the input and transformed matrix
-! plus the pivoting element ratios below the diagonal in the output.
-! INDX(N) records the pivoting order. Copyright (c) Tao Pang 2001.
-!
- IMPLICIT NONE
- INTEGER, INTENT (IN) :: N
- INTEGER :: I,J,K,ITMP
- INTEGER, INTENT (OUT), DIMENSION (N) :: INDX
- REAL (kind=RKIND) :: C1,PI,PI1,PJ
- REAL (kind=RKIND), INTENT (INOUT), DIMENSION (N,N) :: A
- REAL (kind=RKIND), DIMENSION (N) :: C
-!
-! Initialize the index
-!
- DO I = 1, N
- INDX(I) = I
- END DO
-!
-! Find the rescaling factors, one from each row
-!
- DO I = 1, N
- C1= 0.0
- DO J = 1, N
- C1 = AMAX1(C1,ABS(A(I,J)))
- END DO
- C(I) = C1
- END DO
-!
-! Search the pivoting (largest) element from each column
-!
- DO J = 1, N-1
- PI1 = 0.0
- DO I = J, N
- PI = ABS(A(INDX(I),J))/C(INDX(I))
- IF (PI.GT.PI1) THEN
- PI1 = PI
- K = I
- ENDIF
- END DO
-!
-! Interchange the rows via INDX(N) to record pivoting order
-!
- ITMP = INDX(J)
- INDX(J) = INDX(K)
- INDX(K) = ITMP
- DO I = J+1, N
- PJ = A(INDX(I),J)/A(INDX(J),J)
-!
-! Record pivoting ratios below the diagonal
-!
- A(INDX(I),J) = PJ
-!
-! Modify other elements accordingly
-!
- DO K = J+1, N
- A(INDX(I),K) = A(INDX(I),K)-PJ*A(INDX(J),K)
- END DO
- END DO
- END DO
-!
-END SUBROUTINE ELGS
-
-end module advection
Deleted: trunk/mpas/src/core_hyd_atmos/module_mpas_core.F
===================================================================
--- trunk/mpas/src/core_hyd_atmos/module_mpas_core.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_hyd_atmos/module_mpas_core.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -1,301 +0,0 @@
-module mpas_core
-
- use mpas_framework
- use mpas_timekeeping
-
- type (io_output_object) :: restart_obj
- integer :: restart_frame
-
- integer :: current_outfile_frames
-
- type (MPAS_Clock_type) :: clock
-
- integer, parameter :: outputAlarmID = 1
- integer, parameter :: restartAlarmID = 2
-
- contains
-
-
- subroutine mpas_core_init(domain, startTimeStamp)
-
- use configure
- use grid_types
- use test_cases
-
- implicit none
-
- type (domain_type), intent(inout) :: domain
- character(len=*), intent(out) :: startTimeStamp
-
- real (kind=RKIND) :: dt
- type (block_type), pointer :: block
-
-
- if (.not. config_do_restart) call setup_hyd_test_case(domain)
-
- !
- ! Initialize core
- !
- dt = config_dt
-
- call simulation_clock_init(domain, dt, startTimeStamp)
-
- block => domain % blocklist
- do while (associated(block))
- call mpas_init_block(block, block % mesh, dt)
- block % state % time_levs(1) % state % xtime % scalar = startTimeStamp
- block => block % next
- end do
-
- restart_frame = 1
- current_outfile_frames = 0
-
- end subroutine mpas_core_init
-
-
- subroutine simulation_clock_init(domain, dt, startTimeStamp)
-
- implicit none
-
- type (domain_type), intent(inout) :: domain
- real (kind=RKIND), intent(in) :: dt
- character(len=*), intent(out) :: startTimeStamp
-
- type (MPAS_Time_Type) :: startTime, stopTime, alarmStartTime
- type (MPAS_TimeInterval_type) :: runDuration, timeStep, alarmTimeStep
- integer :: ierr
-
- call MPAS_setTime(curr_time=startTime, dateTimeString=config_start_time, ierr=ierr)
- call MPAS_setTimeInterval(timeStep, dt=dt, ierr=ierr)
-
- if (trim(config_run_duration) /= "none") then
- call MPAS_setTimeInterval(runDuration, timeString=config_run_duration, ierr=ierr)
- call MPAS_createClock(clock, startTime=startTime, timeStep=timeStep, runDuration=runDuration, ierr=ierr)
-
- if (trim(config_stop_time) /= "none") then
- call MPAS_setTime(curr_time=stopTime, dateTimeString=config_stop_time, ierr=ierr)
- if(startTime + runduration /= stopTime) then
- write(0,*) 'Warning: config_run_duration and config_stop_time are inconsitent: using config_run_duration.'
- end if
- end if
- else if (trim(config_stop_time) /= "none") then
- call MPAS_setTime(curr_time=stopTime, dateTimeString=config_stop_time, ierr=ierr)
- call MPAS_createClock(clock, startTime=startTime, timeStep=timeStep, stopTime=stopTime, ierr=ierr)
- else
- write(0,*) 'Error: Neither config_run_duration nor config_stop_time were specified.'
- call dmpar_abort(domain % dminfo)
- end if
-
- ! set output alarm
- call MPAS_setTimeInterval(alarmTimeStep, timeString=config_output_interval, ierr=ierr)
- alarmStartTime = startTime + alarmTimeStep
- call MPAS_addClockAlarm(clock, outputAlarmID, alarmStartTime, alarmTimeStep, ierr=ierr)
-
- ! set restart alarm, if necessary
- if (trim(config_restart_interval) /= "none") then
- call MPAS_setTimeInterval(alarmTimeStep, timeString=config_restart_interval, ierr=ierr)
- alarmStartTime = startTime + alarmTimeStep
- call MPAS_addClockAlarm(clock, restartAlarmID, alarmStartTime, alarmTimeStep, ierr=ierr)
- end if
-
- call MPAS_getTime(curr_time=startTime, dateTimeString=startTimeStamp, ierr=ierr)
-
- end subroutine simulation_clock_init
-
-
- subroutine mpas_init_block(block, mesh, dt)
-
- use grid_types
- use advection
- use time_integration
- use RBF_interpolation
- use vector_reconstruction
-
- implicit none
-
- type (block_type), intent(inout) :: block
- type (mesh_type), intent(inout) :: mesh
- real (kind=RKIND), intent(in) :: dt
-
-
- call compute_solver_constants(block % state % time_levs(1) % state, mesh)
- call compute_state_diagnostics(block % state % time_levs(1) % state, mesh)
- call compute_solve_diagnostics(dt, block % state % time_levs(1) % state, mesh)
- call initialize_advection_rk(mesh)
- call rbfInterp_initialize(mesh)
- call init_reconstruct(mesh)
- call reconstruct(mesh, block % state % time_levs(1) % state % u % array, &
- block % diag % uReconstructX % array, &
- block % diag % uReconstructY % array, &
- block % diag % uReconstructZ % array, &
- block % diag % uReconstructZonal % array, &
- block % diag % uReconstructMeridional % array &
- )
-
-
- end subroutine mpas_init_block
-
-
- subroutine mpas_core_run(domain, output_obj, output_frame)
-
- use grid_types
- use io_output
- use timer
-
- implicit none
-
- type (domain_type), intent(inout) :: domain
- type (io_output_object), intent(inout) :: output_obj
- integer, intent(inout) :: output_frame
-
- integer :: ntimesteps, itimestep
- real (kind=RKIND) :: dt
- type (block_type), pointer :: block_ptr
-
- type (MPAS_Time_Type) :: currTime
- character(len=32) :: timeStamp
- integer :: ierr
-
- ! Eventually, dt should be domain specific
- dt = config_dt
-
- currTime = MPAS_getClockTime(clock, MPAS_NOW, ierr)
- call MPAS_getTime(curr_time=currTime, dateTimeString=timeStamp, ierr=ierr)
- write(0,*) 'Initial time ', timeStamp
-
- call write_output_frame(output_obj, output_frame, domain)
-
- ! During integration, time level 1 stores the model state at the beginning of the
- ! time step, and time level 2 stores the state advanced dt in time by timestep(...)
- do while (.not. MPAS_isClockStopTime(clock))
-
- call MPAS_advanceClock(clock)
-
- currTime = MPAS_getClockTime(clock, MPAS_NOW, ierr)
- call MPAS_getTime(curr_time=currTime, dateTimeString=timeStamp, ierr=ierr)
- write(0,*) 'Doing timestep ', timeStamp
-
- call timer_start("time integration")
- call mpas_timestep(domain, dt, timeStamp)
- call timer_stop("time integration")
-
- ! Move time level 2 fields back into time level 1 for next time step
- call shift_time_levels_state(domain % blocklist % state)
-
- if (MPAS_isAlarmRinging(clock, outputAlarmID, ierr=ierr)) then
- call MPAS_resetClockAlarm(clock, outputAlarmID, ierr=ierr)
- if(output_frame == 1) call output_state_init(output_obj, domain, "OUTPUT", trim(timeStamp)) ! output_frame will always be > 1 here unless it is reset after the output file is finalized
- call write_output_frame(output_obj, output_frame, domain)
- end if
-
- if (MPAS_isAlarmRinging(clock, restartAlarmID, ierr=ierr)) then
- call MPAS_resetClockAlarm(clock, restartAlarmID, ierr=ierr)
- if (restart_frame == 1) call output_state_init(restart_obj, domain, "RESTART")
- call output_state_for_domain(restart_obj, domain, restart_frame)
- restart_frame = restart_frame + 1
- end if
-
- end do
-
- end subroutine mpas_core_run
-
-
- subroutine write_output_frame(output_obj, output_frame, domain)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Compute diagnostic fields for a domain and write model state to output file
- !
- ! Input/Output: domain - contains model state; diagnostic field are computed
- ! before returning
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- use grid_types
- use io_output
-
- implicit none
-
- integer, intent(inout) :: output_frame
- type (domain_type), intent(inout) :: domain
- type (io_output_object), intent(inout) :: output_obj
-
- integer :: i, j, k
- integer :: eoe
- type (block_type), pointer :: block_ptr
-
- block_ptr => domain % blocklist
- do while (associated(block_ptr))
- call compute_output_diagnostics(block_ptr % state % time_levs(1) % state, block_ptr % mesh)
- block_ptr => block_ptr % next
- end do
-
- call output_state_for_domain(output_obj, domain, output_frame)
- output_frame = output_frame + 1
-
- ! if the maximum number of frames per outfile has been reached, finalize outfile and reset frame
- if (config_frames_per_outfile > 0) then
- current_outfile_frames = current_outfile_frames + 1
- if(current_outfile_frames >= config_frames_per_outfile) then
- current_outfile_frames = 0
- call output_state_finalize(output_obj, domain % dminfo)
- output_frame = 1
- end if
- end if
-
- end subroutine write_output_frame
-
-
- subroutine compute_output_diagnostics(state, grid)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Compute diagnostic fields for a domain
- !
- ! Input: state - contains model prognostic fields
- ! grid - contains grid metadata
- !
- ! Output: state - upon returning, diagnostic fields will have be computed
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- use grid_types
-
- implicit none
-
- type (state_type), intent(inout) :: state
- type (mesh_type), intent(in) :: grid
-
- integer :: i, eoe
- integer :: iEdge, k
-
- end subroutine compute_output_diagnostics
-
-
- subroutine mpas_timestep(domain, dt, timeStamp)
-
- use grid_types
- use time_integration
-
- implicit none
-
- type (domain_type), intent(inout) :: domain
- real (kind=RKIND), intent(in) :: dt
- character(len=*), intent(in) :: timeStamp
-
- call timestep(domain, dt, timeStamp)
-
- end subroutine mpas_timestep
-
-
- subroutine mpas_core_finalize(domain)
-
- use grid_types
-
- implicit none
-
- integer :: ierr
-
- type (domain_type), intent(inout) :: domain
-
- if (restart_frame > 1) call output_state_finalize(restart_obj, domain % dminfo)
-
- call MPAS_destroyClock(clock, ierr)
-
- end subroutine mpas_core_finalize
-
-end module mpas_core
Deleted: trunk/mpas/src/core_hyd_atmos/module_test_cases.F
===================================================================
--- trunk/mpas/src/core_hyd_atmos/module_test_cases.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_hyd_atmos/module_test_cases.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -1,544 +0,0 @@
-module test_cases
-
- use grid_types
- use configure
- use constants
-
-
- contains
-
-
- subroutine setup_hyd_test_case(domain)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Configure grid metadata and model state for the hydrostatic test case
- ! specified in the namelist
- !
- ! Output: block - a subset (not necessarily proper) of the model domain to be
- ! initialized
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (domain_type), intent(inout) :: domain
-
- integer :: i
- type (block_type), pointer :: block_ptr
-
- if (config_test_case == 0) then
- write(0,*) ' need hydrostatic test case configuration, error stop '
- stop
-
- 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 % state % time_levs(1) % state, config_test_case)
- do i=2,nTimeLevs
- call copy_state(block_ptr % state % time_levs(i) % state, block_ptr % state % time_levs(1) % state)
- end do
-
- block_ptr => block_ptr % next
- end do
-
- else
- write(0,*) ' Only test case 1 and 2 are currently supported for hydrostatic core '
- stop
- end if
-
- end subroutine setup_hyd_test_case
-
-!----------------------------------------------------------------------------------------------------------
-
- subroutine hyd_test_case_1(grid, state, test_case)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Setup baroclinic wave test case from Jablonowski and Williamson 2008 (QJRMS)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (mesh_type), intent(inout) :: grid
- type (state_type), intent(inout) :: state
- integer, intent(in) :: test_case
-
- real (kind=RKIND), parameter :: u0 = 35.0
- real (kind=RKIND), parameter :: alpha_grid = 0. ! no grid rotation
- real (kind=RKIND), parameter :: omega_e = 7.29212e-05
- real (kind=RKIND), parameter :: t0 = 288., delta_t = 4.8e+05, dtdz = 0.005, eta_t = 0.2
- real (kind=RKIND), parameter :: u_perturbation = 1., pert_radius = 0.1, latitude_pert = 40., longitude_pert = 20.
- real (kind=RKIND), parameter :: theta_c = pii/4.0
- real (kind=RKIND), parameter :: lambda_c = 3.0*pii/2.0
- real (kind=RKIND), parameter :: rh_max = 0.4 ! Maximum relative humidity
- real (kind=RKIND), parameter :: k_x = 9. ! Normal mode wave number
-
- real (kind=RKIND), dimension(:), pointer :: rdnu, rdnw, fnm, fnp, dbn, dnu, dnw
- real (kind=RKIND), dimension(:), pointer :: surface_pressure
- real (kind=RKIND), dimension(:,:), pointer :: pressure, theta, alpha, geopotential, h
- real (kind=RKIND), dimension(:,:,:), pointer :: scalars
-
- integer :: iCell, iEdge, vtx1, vtx2, ivtx, k, nz, nz1, index_qv
- 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
- real (kind=RKIND), dimension(grid % nVertLevels + 1 ) :: znuc, znuv, bn, divh, dpn, teta
-
- real (kind=RKIND) :: HYAI_CAM26(27), HYBI_CAM26(27), HYAM_CAM26(26), HYBM_CAM26(26)
-
- logical, parameter :: cam26 = .true.
-
- data hyai_cam26 / 0.002194067, 0.004895209, 0.009882418, 0.018052010, &
- 0.029837240, 0.044623340, 0.061605870, 0.078512430, &
- 0.077312710, 0.075901310, 0.074240860, 0.072287440, &
- 0.069989330, 0.067285740, 0.064105090, 0.060363220, &
- 0.055961110, 0.050782250, 0.044689600, 0.037521910, &
- 0.029089490, 0.020847390, 0.013344430, 0.007084990, &
- 0.002521360, 0.000000000, 0.000000000/, &
- hybi_cam26 / 0.000000000, 0.000000000, 0.000000000, 0.000000000, &
- 0.000000000, 0.000000000, 0.000000000, 0.000000000, &
- 0.015053090, 0.032762280, 0.053596220, 0.078106270, &
- 0.106941100, 0.140863700, 0.180772000, 0.227722000, &
- 0.282956200, 0.347936400, 0.424382200, 0.514316800, &
- 0.620120200, 0.723535500, 0.817676800, 0.896215300, &
- 0.953476103, 0.985112200, 1.000000000/
-
- !
- ! Scale all distances and areas from a unit sphere to one with radius a
- !
- grid % xCell % array = grid % xCell % array * a
- grid % yCell % array = grid % yCell % array * a
- grid % zCell % array = grid % zCell % array * a
- grid % xVertex % array = grid % xVertex % array * a
- grid % yVertex % array = grid % yVertex % array * a
- grid % zVertex % array = grid % zVertex % array * a
- grid % xEdge % array = grid % xEdge % array * a
- grid % yEdge % array = grid % yEdge % array * a
- grid % zEdge % array = grid % zEdge % array * a
- grid % dvEdge % array = grid % dvEdge % array * a
- grid % dcEdge % array = grid % dcEdge % array * a
- grid % areaCell % array = grid % areaCell % array * a**2.0
- grid % areaTriangle % array = grid % areaTriangle % array * a**2.0
- grid % kiteAreasOnVertex % array = grid % kiteAreasOnVertex % array * a**2.0
-
- index_qv = state % index_qv
-
- nz1 = grid % nVertLevels
- nz = nz1 + 1
-
- rdnu => grid % rdnu % array
- rdnw => grid % rdnw % array
- fnm => grid % fnm % array
- fnp => grid % fnp % array
- dbn => grid % dbn % array
- dnu => grid % dnu % array
- dnw => grid % dnw % array
-
- surface_pressure => state % surface_pressure % array
- pressure => state % pressure % array
- theta => state % theta % array
- alpha => state % alpha % array
- geopotential => state % geopotential % array
- h => state % h % array
- scalars => state % scalars % array
-
- 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.*p0-ptop)/(p0-ptop)
-
- if (cam26) then
-
- if (grid % nVertLevels /= 26 ) then
- write(0,*) ' init is for 26 levels only, error stop '
- stop
- else
- do k=1,nz
- hyai(k) = hyai_cam26(k)
- hybi(k) = hybi_cam26(k)
- end do
-
- write(0,*) ' initialization using cam 26 levels '
-
- end if
-
- ptop = hyai(1)*p0
-
- do k=1,nz1
- hyam(k) = .5*(hyai(k)+hyai(k+1))
- hybm(k) = .5*(hybi(k)+hybi(k+1))
- znuc(nz-k) = hyam(k) + hybm(k)
- znwc(nz-k+1) = hyai(k) + hybi(k)
- znu (nz-k ) = (znuc(nz-k )*p0-ptop)/(p0-ptop)
- znw (nz-k+1) = (znwc(nz-k+1)*p0-ptop)/(p0-ptop)
-! znuv(nz-k ) = (znuc(nz-k )-.252)*pii/2.
-! znwv(nz-k+1) = (znwc(nz-k+1)-.252)*pii/2.
- bn(k+1) = hybi(nz-k)
- end do
-
- else ! analytic profile
-
- ptop = 219.4067
- znw(1) = 1.
-
- do k=1,nz1
-
- ! eta profile (constant deta for exp=1,)
-
- znw(k+1) = (1.-float(k)/float(nz1))**2.
-
- ! profile for tranisition from sigma to presure coordinate
- ! bn(k)=znw(k) for sigma coord, bn(k)=0 for p coord
- ! bn(1)=1, bn(nz)=0 must be satisfied
-
- bn(k+1) = znw(k+1)*sin(.5*pii*znw(k+1))**2
- !! bn(k+1) = znw(k+1)
-
- znu (k) = .5*(znw(k)+znw(k+1))
- znuc(k) = (znu(k )*(p0-ptop)+ptop)/p0
- znwc(k+1) = (znw(k+1)*(p0-ptop)+ptop)/p0
- end do
-
- end if ! cam or analytic grid-level profile
-
- !
- ! metrics for vertical stretching
- !
-
- 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.*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))
- dpn (k) = 0.
- divh(k) = 0.
- write (6,*) k,znw(k),dnw(k),bn(k),dbn(k)
- end do
-
- dpn(nz)=0.
- fnm(1) = 0.
- fnp(1) = 0.
- do k=2,nz1
- dnu (k) = .5*(dnw(k)+dnw(k-1))
- rdnu(k) = 1./dnu(k)
- fnp (k) = .5* dnw(k )/dnu(k)
- fnm (k) = .5* dnw(k-1)/dnu(k)
- end do
-
- !
- ! Initialize wind field
- !
-
- lat_pert = latitude_pert*pii/180.
- lon_pert = longitude_pert*pii/180.
-
- do iEdge=1,grid % nEdges
-
- vtx1 = grid % VerticesOnEdge % array (1,iEdge)
- vtx2 = grid % VerticesOnEdge % array (2,iEdge)
- lat1 = grid%latVertex%array(vtx1)
- lat2 = grid%latVertex%array(vtx2)
- flux = (0.5*(lat2-lat1) - 0.125*(sin(4.*lat2) - sin(4.*lat1)))*a/grid % dvEdge % array(iEdge)
-
- if (config_test_case == 2) then
- r_pert = sphere_distance( grid % latEdge % array (iEdge), grid % lonEdge % array (iEdge), &
- lat_pert, lon_pert, 1.)/(pert_radius)
- u_pert = u_perturbation*exp(-r_pert**2)*(lat2-lat1)*a/grid % dvEdge % array(iEdge)
-
- else if (config_test_case == 3) then
- lon_Edge = grid % lonEdge % array(iEdge)
- u_pert = u_perturbation*cos(k_x*(lon_Edge - lon_pert)) &
- *(0.5*(lat2-lat1) - 0.125*(sin(4.*lat2) - sin(4.*lat1)))*a/grid % dvEdge % array(iEdge)
- else
- u_pert = 0.0
- end if
-
-
- do k=1,grid % nVertLevels
- fluxk = u0*flux*(cos(znuv(k))**(1.5))
- state % u % array(k,iEdge) = fluxk + u_pert
- end do
-
- !
- ! Generate rotated Coriolis field
- !
-
- grid % fEdge % array(iEdge) = 2.0 * omega * &
- ( -cos(grid%lonEdge%array(iEdge)) * cos(grid%latEdge%array(iEdge)) * sin(alpha_grid) + &
- sin(grid%latEdge%array(iEdge)) * cos(alpha_grid) &
- )
- end do
-
- do iVtx=1,grid % nVertices
- grid % fVertex % array(iVtx) = 2.0 * omega * &
- (-cos(grid%lonVertex%array(iVtx)) * cos(grid%latVertex%array(iVtx)) * sin(alpha_grid) + &
- sin(grid%latVertex%array(iVtx)) * cos(alpha_grid) &
- )
- end do
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! 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
-
- phi = grid % latCell % array (iCell)
-
- surface_pressure(iCell) = p0
-
- do k=1,nz1
- h(k,iCell) = (1.-dbn(k))*(p0-ptop)+dbn(k)*(surface_pressure(iCell)-ptop)
- end do
-
- pressure(nz,iCell) = ptop
- do k=nz1,1,-1
- pressure(k,iCell) = pressure(k+1,iCell)-dnw(k)*h(k,iCell)
- end do
-
- do k=1,nz1
- 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.) &
- *2.*u0*cos(znuv(k))**1.5 &
- +(1.6*cos(phi)**3 &
- *(sin(phi)**2+2./3.)-pii/4.)*a*omega)
-
- theta (k,iCell) = theta(k,iCell)* &
- (0.5*(pressure(k,iCell)+pressure(k+1,iCell))/p0)**(-rgas/cp)
- alpha(k,iCell) = ((rgas/p0)*theta(k,iCell)* &
- (0.5*(pressure(k,iCell)+pressure(k+1,iCell))/p0)**cvpm)
-
- end do
- end do
-!
-! initialization for geopotential
-!
- do iCell=1,grid % nCells
-
- phi = grid % latCell % array (iCell)
-
- geopotential(1,iCell) = u0*cos(znwv(1))**1.5* &
- ((-2.*sin(phi)**6 &
- *(cos(phi)**2+1./3.)+10./63.) &
- *(u0)*cos(znwv(1))**1.5 &
- +(1.6*cos(phi)**3 &
- *(sin(phi)**2+2./3.)-pii/4.)*a*omega)
- do k=1,nz1
- geopotential(k+1,iCell) = geopotential(k,iCell)-dnw(k)*h(k,iCell)*alpha(k,iCell)
- 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 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)
- end do
-
-! When initializing a scalar, be sure not to put unreasonably large values
-! into indices in the moist class
-! scalars(2,:,:) = 1. ! transport test
-! scalars(2,:,:) = theta ! transport test
-! if (num_scalars >= 2) then
-! scalars(2,:,:) = 0.0
-! do iCell=1,grid%nCells
-! r = sphere_distance(theta_c, lambda_c, grid % latCell % array(iCell), grid % lonCell % array(iCell), a)
-! if (r < a/3.0) then
-! do k=1,grid%nVertLevels
-! scalars(2,k,iCell) = (1.0 / 2.0) * (1.0 + cos(pii*r*3.0/a))
-! end do
-! end if
-! end do
-! end if
-! if (num_scalars >= 3) scalars(3,:,:) = theta + 100. ! transport test
-! if (num_scalars >= 4) scalars(4,:,:) = theta + 200. ! transport test
-! if (num_scalars >= 5) scalars(5,:,:) = theta + 300. ! transport test
-
- end subroutine hyd_test_case_1
-
-
- real function sphere_distance(lat1, lon1, lat2, lon2, radius)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Compute the great-circle distance between (lat1, lon1) and (lat2, lon2) on a
- ! sphere with given radius.
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- real (kind=RKIND), intent(in) :: lat1, lon1, lat2, lon2, radius
-
- real (kind=RKIND) :: arg1
-
- arg1 = sqrt( sin(0.5*(lat2-lat1))**2 + &
- cos(lat1)*cos(lat2)*sin(0.5*(lon2-lon1))**2 )
- sphere_distance = 2.*radius*asin(arg1)
-
- end function sphere_distance
-
-
- real function AA(theta)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! A, used in height field computation for Rossby-Haurwitz wave
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- real (kind=RKIND), parameter :: w = 7.848e-6
- real (kind=RKIND), parameter :: K = 7.848e-6
- real (kind=RKIND), parameter :: R = 4.0
-
- real (kind=RKIND), intent(in) :: theta
-
- AA = 0.5 * w * (2.0 * omega + w) * cos(theta)**2.0 + &
- 0.25 * K**2.0 * cos(theta)**(2.0*R) * ((R+1.0)*cos(theta)**2.0 + 2.0*R**2.0 - R - 2.0 - 2.0*(R*cos(theta))**2.0)
-
- end function AA
-
-
- real function BB(theta)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! B, used in height field computation for Rossby-Haurwitz wave
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- real (kind=RKIND), parameter :: w = 7.848e-6
- real (kind=RKIND), parameter :: K = 7.848e-6
- real (kind=RKIND), parameter :: R = 4.0
-
- real (kind=RKIND), intent(in) :: theta
-
- BB = (2.0*(omega + w)*K / ((R+1.0)*(R+2.0))) * cos(theta)**R * ((R**2.0 + 2.0*R + 2.0) - ((R+1.0)*cos(theta))**2.0)
-
- end function BB
-
-
- real function CC(theta)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! C, used in height field computation for Rossby-Haurwitz wave
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- real (kind=RKIND), parameter :: w = 7.848e-6
- real (kind=RKIND), parameter :: K = 7.848e-6
- real (kind=RKIND), parameter :: R = 4.0
-
- real (kind=RKIND), intent(in) :: theta
-
- CC = 0.25 * K**2.0 * cos(theta)**(2.0*R) * ((R+1.0)*cos(theta)**2.0 - R - 2.0)
-
- end function CC
-
-end module test_cases
Deleted: trunk/mpas/src/core_hyd_atmos/module_time_integration.F
===================================================================
--- trunk/mpas/src/core_hyd_atmos/module_time_integration.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_hyd_atmos/module_time_integration.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -1,2122 +0,0 @@
-module time_integration
-
- use grid_types
- use configure
- use constants
- use dmpar
- use vector_reconstruction
-
-
- contains
-
-
- subroutine timestep(domain, dt, timeStamp)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Advance model state forward in time by the specified time step
- !
- ! Input: domain - current model state in time level 1 (e.g., time_levs(1)state%h(:,:))
- ! plus grid meta-data
- ! Output: domain - upon exit, time level 2 (e.g., time_levs(2)%state%h(:,:)) contains
- ! model state advanced forward in time by dt seconds
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (domain_type), intent(inout) :: domain
- real (kind=RKIND), intent(in) :: dt
- character(len=*), intent(in) :: timeStamp
-
- type (block_type), pointer :: block
-
- if (trim(config_time_integration) == 'SRK3') then
- call srk3(domain, dt)
- else
- write(0,*) 'Unknown time integration option '//trim(config_time_integration)
- write(0,*) 'Currently, only ''SRK3'' is supported.'
- stop
- end if
-
- block => domain % blocklist
- do while (associated(block))
- block % state % time_levs(2) % state % xtime % scalar = timeStamp
- block => block % next
- end do
-
- end subroutine timestep
-
-
- subroutine srk3(domain, dt)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Advance model state forward in time by the specified time step using
- ! time-split RK3 scheme
- !
- ! Hydrostatic (primitive eqns.) solver
- !
- ! Input: domain - current model state in time level 1 (e.g., time_levs(1)state%h(:,:))
- ! plus grid meta-data
- ! Output: domain - upon exit, time level 2 (e.g., time_levs(2)%state%h(:,:)) contains
- ! model state advanced forward in time by dt seconds
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (domain_type), intent(inout) :: domain
- real (kind=RKIND), intent(in) :: dt
-
- integer :: iCell, k
- type (block_type), pointer :: block
-
- integer, parameter :: TEND = 1
- integer :: rk_step, number_of_sub_steps
-
- real (kind=RKIND), dimension(3) :: rk_timestep, rk_sub_timestep
- integer, dimension(3) :: number_sub_steps
- integer :: small_step
- logical, parameter :: debug = .false.
- logical, parameter :: debug_mass_conservation = .true.
-
- real (kind=RKIND) :: domain_mass, scalar_mass, scalar_min, scalar_max
- real (kind=RKIND) :: global_domain_mass, global_scalar_mass, global_scalar_min, global_scalar_max
-
- !
- ! Initialize time_levs(2) with state at current time
- ! Initialize RK weights
- !
-
- number_of_sub_steps = config_number_of_sub_steps
-
- rk_timestep(1) = dt/3.
- rk_timestep(2) = dt/2.
- rk_timestep(3) = dt
-
- rk_sub_timestep(1) = dt/3.
- rk_sub_timestep(2) = dt/real(number_of_sub_steps)
- rk_sub_timestep(3) = dt/real(number_of_sub_steps)
-
- number_sub_steps(1) = 1
- number_sub_steps(2) = number_of_sub_steps/2
- number_sub_steps(3) = number_of_sub_steps
-
- if(debug) write(0,*) ' copy step in rk solver '
-
- block => domain % blocklist
- do while (associated(block))
- call copy_state( block % state % time_levs(2) % state, block % state % time_levs(1) % state )
- block => block % next
- end do
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! BEGIN RK loop
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-
- do rk_step = 1, 3
-
- if(debug) write(0,*) ' rk substep ', rk_step
-
- block => domain % blocklist
- do while (associated(block))
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % mesh % qtot % array(:,:), &
- 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 % nEdges, &
- block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % state % time_levs(2) % state % h % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % state % time_levs(2) % state % pressure % array(:,:), &
- block % mesh % nVertLevels+1, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % state % time_levs(2) % state % geopotential % array(:,:), &
- block % mesh % nVertLevels+1, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % state % time_levs(2) % state % alpha % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % state % time_levs(2) % state % pv_edge % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nEdges, &
- block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
- if (config_h_mom_eddy_visc4 > 0.0) then
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % state % time_levs(2) % state % divergence % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % state % time_levs(2) % state % vorticity % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nVertices, &
- block % parinfo % verticesToSend, block % parinfo % verticesToRecv)
- end if
- block => block % next
- end do
-
- if(debug) write(0,*) ' rk substep ', rk_step
-
- block => domain % blocklist
- do while (associated(block))
- call compute_dyn_tend( block % tend, block % state % time_levs(2) % state, block % mesh )
- block => block % next
- end do
-
- if(debug) write(0,*) ' returned from dyn_tend '
-
- !
- ! --- update halos for tendencies
- !
- block => domain % blocklist
- do while (associated(block))
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % tend % u % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nEdges, &
- block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % tend % theta % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- block => block % next
- end do
-
-
- ! --- advance over sub_steps
-
- block => domain % blocklist
- do while (associated(block))
- !
- ! Note: Scalars in new time level shouldn't be overwritten, since their provisional values
- ! from the previous RK step are needed to compute new scalar tendencies in advance_scalars.
- ! A cleaner way of preserving scalars should be added in future.
- !
- block % mesh % scalars_old % array(:,:,:) = block % state % time_levs(2) % state % scalars % array(:,:,:)
- call copy_state( block % state % time_levs(2) % state, block % state % time_levs(1) % state )
- block % state % time_levs(2) % state % scalars % array(:,:,:) = block % mesh % scalars_old % array(:,:,:)
- block => block % next
- end do
-
- if(debug) write(0,*) ' returned from copy_state '
-
- do small_step = 1, number_sub_steps(rk_step)
-
- if(debug) write(0,*) ' small step ',small_step
-
- block => domain % blocklist
- do while (associated(block))
- call advance_dynamics( block % tend, block % state % time_levs(2) % state, &
- block % mesh, &
- small_step, number_sub_steps(rk_step), rk_sub_timestep(rk_step) )
- block => block % next
- end do
-
- if(debug) write(0,*) ' dynamics advance complete '
-
- ! will need communications here?
- !
- ! --- update halos for prognostic variables
- !
- block => domain % blocklist
- do while (associated(block))
-!! call dmpar_exch_halo_field2dReal(domain % dminfo, block % state % time_levs(2) % state % u % array(:,:), &
-!! block % mesh % nVertLevels, block % mesh % nEdges, &
-!! block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % state % time_levs(2) % state % h_edge % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nEdges, &
- block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
-!! call dmpar_exch_halo_field2dReal(domain % dminfo, block % mesh % uhAvg % array(:,:), &
-!! block % mesh % nVertLevels, block % mesh % nEdges, &
-!! block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
-!! call dmpar_exch_halo_field2dReal(domain % dminfo, block % mesh % wwAvg % array(:,:), &
-!! block % mesh % nVertLevels+1, block % mesh % nCells, &
-!! block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % state % time_levs(2) % state % theta % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
-!! call dmpar_exch_halo_field2dReal(domain % dminfo, block % state % time_levs(2) % state % h % array(:,:), &
-!! block % mesh % nVertLevels, block % mesh % nCells, &
-!! block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
-!! call dmpar_exch_halo_field2dReal(domain % dminfo, block % tend % h % array(:,:), &
-!! block % mesh % nVertLevels, block % mesh % nCells, &
-!! block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call dmpar_exch_halo_field1dReal(domain % dminfo, block % mesh % dpsdt % array(:), &
- block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call dmpar_exch_halo_field1dReal(domain % dminfo, block % state % time_levs(2) % state % surface_pressure % array(:), &
- block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % state % time_levs(2) % state % alpha % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % state % time_levs(2) % state % ww % array(:,:), &
- block % mesh % nVertLevels+1, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % state % time_levs(2) % state % pressure % array(:,:), &
- block % mesh % nVertLevels+1, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
-!! call dmpar_exch_halo_field2dReal(domain % dminfo, block % mesh % pressure_old % array(:,:), &
-!! block % mesh % nVertLevels+1, block % mesh % nCells, &
-!! block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % state % time_levs(2) % state % geopotential % array(:,:), &
- block % mesh % nVertLevels+1, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- block => block % next
- end do
-
- end do
-
- if(debug) write(0,*) ' advance scalars '
-
-
- ! --- advance scalars with time integrated mass fluxes
-
- block => domain % blocklist
- do while (associated(block))
- !
- ! Note: The advance_scalars_mono routine can be used without limiting, and thus, encompasses
- ! the functionality of the advance_scalars routine; however, it is noticeably slower,
- ! so we keep the advance_scalars routine as well
- !
- if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then
- call advance_scalars( block % tend, &
- block % state % time_levs(1) % state, block % state % time_levs(2) % state, &
- block % mesh, rk_timestep(rk_step) )
- else
- call advance_scalars_mono( block % tend, &
- block % state % time_levs(1) % state, block % state % time_levs(2) % state, &
- block % mesh, rk_timestep(rk_step), rk_step, 3, &
- domain % dminfo, block % parinfo % cellsToSend, block % parinfo % cellsToRecv )
- end if
- block => block % next
- end do
-
- block => domain % blocklist
- do while (associated(block))
- call dmpar_exch_halo_field3dReal(domain % dminfo, block % tend % scalars % array(:,:,:), &
- block % tend % num_scalars, block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call dmpar_exch_halo_field3dReal(domain % dminfo, block % state % time_levs(2) % state % scalars % array(:,:,:), &
- block % tend % num_scalars, block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- block => block % next
- end do
-
-
- if(debug) write(0,*) ' advance scalars complete '
-
- ! --- compute some diagnostic quantities for the next timestep
-
- block => domain % blocklist
- do while (associated(block))
- call compute_solver_constants( block % state % time_levs(2) % state, block % mesh )
- call compute_state_diagnostics( block % state % time_levs(2) % state, block % mesh )
- call compute_solve_diagnostics( dt, block % state % time_levs(2) % state, block % mesh )
- block => block % next
- end do
-
- if(debug) write(0,*) ' diagnostics complete '
-
-
- ! might need communications here *****************************
-
- end do
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! 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 % mesh, block % state % time_levs(2) % state % u % array, &
- block % diag % uReconstructX % array, &
- block % diag % uReconstructY % array, &
- block % diag % uReconstructZ % array, &
- block % diag % uReconstructZonal % array, &
- block % diag % uReconstructMeridional % array &
- )
-
- call compute_w(block % state % time_levs(2) % state, block % state % 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
- domain_mass = 0.
- scalar_mass = 0.
- block => domain % blocklist
- scalar_min = block % state % time_levs(2) % state % scalars % array (2,1,1)
- scalar_max = block % state % time_levs(2) % state % scalars % array (2,1,1)
- do while(associated(block))
- do iCell = 1, block % mesh % nCellsSolve
- domain_mass = domain_mass + block % state % time_levs(2) % state % surface_pressure % array (iCell) * &
- block % mesh % areaCell % array (iCell) &
- - block % state % time_levs(2) % state % pressure % array (block % mesh % nVertLevels + 1, 1) * &
- block % mesh % areaCell % array (iCell)
- do k=1, block % mesh % nVertLevelsSolve
- scalar_mass = scalar_mass - block % state % time_levs(2) % state % scalars % array (2,k,iCell) * &
- block % state % time_levs(2) % state % h % array (k,iCell) * &
- block % mesh % dnw % array (k) * &
- block % mesh % areaCell % array (iCell)
- scalar_min = min(scalar_min,block % state % time_levs(2) % state % scalars % array (2,k,iCell))
- scalar_max = max(scalar_max,block % state % time_levs(2) % state % scalars % array (2,k,iCell))
- end do
- end do
- block => block % next
- end do
- call dmpar_sum_real(domain % dminfo, domain_mass, global_domain_mass)
- call dmpar_sum_real(domain % dminfo, scalar_mass, global_scalar_mass)
- call dmpar_min_real(domain % dminfo, scalar_min, global_scalar_min)
- call dmpar_max_real(domain % dminfo, scalar_max, global_scalar_max)
- write(0,*) ' mass in the domain = ',global_domain_mass
- write(0,*) ' scalar mass in the domain = ',global_scalar_mass
- write(0,*) ' scalar_min, scalar_max ',global_scalar_min, global_scalar_max
- end if
-
-
- end subroutine srk3
-
-!------------------------------------------------------------------------------------------------------------------
-
- subroutine compute_solver_constants(s, grid)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Compute height and normal wind tendencies, as well as diagnostic variables
- !
- ! Input: s - current model state
- ! grid - grid metadata
- !
- ! Output: tend - computed diagnostics (parallel velocities, v; mass fluxes, vh;
- ! circulation; vorticity; and kinetic energy, ke) and the
- ! tendencies for height (h) and u (u)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (state_type), intent(in) :: s
- type (mesh_type), intent(inout) :: grid
-
- integer :: iEdge, iCell, k, cell1, cell2, iq
-
- integer :: nCells, nEdges, nVertLevels
-
- nCells = grid % nCells
- nEdges = grid % nEdges
- nVertLevels = grid % nVertLevels
-
- grid % qtot % array = 0.
- grid % cqu % array = 1.
-
- if (s % num_scalars > 0) then
-
- do iCell = 1, nCells
- do k = 1, nVertLevels
- do iq = s % moist_start, s % moist_end
- grid % qtot % array(k,iCell) = grid % qtot % array(k,iCell) + s % scalars % array (iq, k, iCell)
- end do
- end do
- end do
-
- do iEdge = 1, nEdges
- do k = 1, nVertLevels
- cell1 = grid % cellsOnEdge % array(1,iEdge)
- cell2 = grid % cellsOnEdge % array(2,iEdge)
- grid % cqu % array(k,iEdge) = 1./( 1. + 0.5*(grid % qtot % array(k,cell1)+grid % qtot % array(k,cell2)) )
- end do
- end do
-
- end if
-
- end subroutine compute_solver_constants
-
-!------------------------------------------------------------------------------------------------------------------
-
- subroutine compute_state_diagnostics(s, grid)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Compute diagnostic variables
- !
- ! Input: s - current model state
- ! grid - grid metadata
- !
- ! Output: tend - computed diagnostics (parallel velocities, v; mass fluxes, vh;
- ! circulation; vorticity; and kinetic energy, ke) and the
- ! tendencies for height (h) and u (u)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (state_type), intent(inout) :: s
- type (mesh_type), intent(inout) :: grid
-
- real (kind=RKIND), dimension(:,:,:), pointer :: scalar
- real (kind=RKIND), dimension(:,:), pointer :: h, pressure, qtot, alpha, geopotential, theta
- real (kind=RKIND), dimension(:,:), pointer :: theta_old, ww_old, u_old, u, ww, h_edge_old, h_edge, h_old
- real (kind=RKIND), dimension(:), pointer :: surface_pressure, dbn, dnu, dnw
-
- integer :: iEdge, iCell, k, cell1, cell2, iq
- integer :: nCells, nEdges, nVertLevels
-
- real (kind=RKIND) :: p0,tm,ptop,ptmp
-
- h => s % h % array
- theta => s % theta % array
- pressure => s % pressure % array
- qtot => grid % qtot % array
- surface_pressure => s % surface_pressure % array
- alpha => s % alpha % array
- geopotential => s % geopotential % array
- scalar => s % scalars % array
- theta_old => grid % theta_old % array
- u_old => grid % u_old % array
- ww_old => grid % ww_old % array
- h_old => grid % h_old % array
- h_edge_old => grid % h_edge_old % array
- h_edge => s % h_edge % array
- u => s % u % array
- ww => s % ww % array
-
- dbn => grid % dbn % array
- dnu => grid % dnu % array
- dnw => grid % dnw % array
-
- nCells = grid % nCells
- nEdges = grid % nEdges
- nVertLevels = grid % nVertLevels
-
-
-
-! ptop = grid % ptop
-! p0 = grid % p0
-! ptop = 219.4067
- p0 = 1e+05
- ptop = pressure(nVertLevels+1,1)
-
-! write(0,*) ' ptop in compute_state_diagnostics ',ptop
-
-!*****************************
-
- do iCell = 1, nCells
- do k=1,nVertLevels
- h(k,iCell) = (1.-dbn(k))*(p0-ptop)+dbn(k)*(surface_pressure(iCell)-ptop)
- end do
-
- do k = nVertLevels, 1, -1
- pressure(k,iCell) = pressure(k+1,iCell) - dnw(k)*(1.+qtot(k,iCell))*h(k,iCell)
- end do
-
- do k=1, nVertLevels
- ! note that theta is not coupled here
- tm = (1.+1.61*scalar(1,k,iCell))*theta(k,iCell) ! assume scalar(1) is qv here?
- alpha(k,iCell) = (rgas/p0)*tm*(0.5*(pressure(k+1,iCell)+pressure(k,iCell))/p0)**cvpm
- geopotential(k+1,iCell) = geopotential(k,iCell) - dnw(k)*h(k,iCell)*alpha(k,iCell)
- end do
- end do
-
- theta_old(:,:) = theta(:,:)
- ww_old(:,:) = ww(:,:)
- u_old(:,:) = u(:,:)
- h_edge_old(:,:) = h_edge(:,:)
- h_old(:,:) = h(:,:)
-
- end subroutine compute_state_diagnostics
-
-!------------------------------------------------------------------------------------------
-
- subroutine compute_dyn_tend(tend, s, grid)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Compute height and normal wind tendencies, as well as diagnostic variables
- !
- ! Input: s - current model state
- ! grid - grid metadata
- !
- ! Output: tend - computed diagnostics (parallel velocities, v; mass fluxes, vh;
- ! circulation; vorticity; and kinetic energy, ke) and the
- ! tendencies for height (h) and u (u)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (tend_type), intent(inout) :: tend
- type (state_type), intent(in) :: s
- type (mesh_type), intent(in) :: grid
-
- integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j
- real (kind=RKIND) :: flux, vorticity_abs, h_vertex, workpv, q, upstream_bias
-
- integer :: nCells, nEdges, nVertices, nVertLevels
- real (kind=RKIND) :: h_mom_eddy_visc2, v_mom_eddy_visc2, h_mom_eddy_visc4
- real (kind=RKIND) :: h_theta_eddy_visc2, v_theta_eddy_visc2, h_theta_eddy_visc4
- real (kind=RKIND) :: u_diffusion
- real (kind=RKIND), dimension(:), pointer :: h_s, fVertex, fEdge, dvEdge, dcEdge, areaCell, areaTriangle, p_s
- real (kind=RKIND), dimension(:,:), pointer :: vh, weightsOnEdge, kiteAreasOnVertex, h_edge, h, u, v, tend_h, tend_u, &
- circulation, divergence, vorticity, ke, pv_edge, geopotential, theta, ww, &
- h_diabatic, tend_theta
- real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
- integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnVertex, verticesOnEdge, edgesOnCell, edgesOnEdge, edgesOnVertex
- integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge
-
- real (kind=RKIND), dimension( grid % nVertLevels + 1 ) :: wdtn, wdun
- real (kind=RKIND) :: theta_edge, theta_turb_flux, z1, z2, z3, z4, zm, z0, zp, r
- real (kind=RKIND) :: d2fdx2_cell1, d2fdx2_cell2
-
- real (kind=RKIND), dimension(:), pointer :: rdnu, rdnw, fnm, fnp
-
- real (kind=RKIND), allocatable, dimension(:,:) :: delsq_theta, delsq_divergence
- real (kind=RKIND), allocatable, dimension(:,:) :: delsq_u
- real (kind=RKIND), allocatable, dimension(:,:) :: delsq_circulation, delsq_vorticity
-
- h => s % h % array
- u => s % u % array
- h_edge => s % h_edge % array
- circulation => s % circulation % array
- divergence => s % divergence % array
- vorticity => s % vorticity % array
- ke => s % ke % array
- pv_edge => s % pv_edge % array
- geopotential => s % geopotential % array
- theta => s % theta % array
-
- weightsOnEdge => grid % weightsOnEdge % array
- cellsOnEdge => grid % cellsOnEdge % array
- verticesOnEdge => grid % verticesOnEdge % array
- nEdgesOnEdge => grid % nEdgesOnEdge % array
- edgesOnEdge => grid % edgesOnEdge % array
- dcEdge => grid % dcEdge % array
- dvEdge => grid % dvEdge % array
- areaCell => grid % areaCell % array
- areaTriangle => grid % areaTriangle % array
- fEdge => grid % fEdge % array
- deriv_two => grid % deriv_two % array
-
- vh => tend % vh % array
- tend_u => tend % u % array
- tend_theta => tend % theta % array
- h_diabatic => grid % h_diabatic % array
-
- ww => s % ww % array
- rdnu => grid % rdnu % array
- rdnw => grid % rdnw % array
- fnm => grid % fnm % array
- fnp => grid % fnp % array
-
- nCells = grid % nCells
- nEdges = grid % nEdges
- nVertLevels = grid % nVertLevels
- nVertices = grid % nVertices
-
- h_mom_eddy_visc2 = config_h_mom_eddy_visc2
- h_mom_eddy_visc4 = config_h_mom_eddy_visc4
- v_mom_eddy_visc2 = config_v_mom_eddy_visc2
- h_theta_eddy_visc2 = config_h_theta_eddy_visc2
- h_theta_eddy_visc4 = config_h_theta_eddy_visc4
- v_theta_eddy_visc2 = config_v_theta_eddy_visc2
-
-
- !
- ! Compute u (normal) velocity tendency for each edge (cell face)
- !
-
- tend_u(:,:) = 0.0
-
-#ifdef LANL_FORMULATION
- do iEdge=1,grid % nEdgesSolve
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
-
- do k=1,nVertLevels
- q = 0.0
- do j = 1,nEdgesOnEdge(iEdge)
- eoe = edgesOnEdge(j,iEdge)
- workpv = 0.5 * (pv_edge(k,iEdge) + pv_edge(k,eoe))
- q = q + weightsOnEdge(j,iEdge) * u(k,eoe) * workpv * h_edge(k,eoe)
- end do
- tend_u(k,iEdge) = q - (ke(k,cell2) - ke(k,cell1)) / dcEdge(iEdge)
- end do
- end do
-
-#endif
-
-#ifdef NCAR_FORMULATION
- !
- ! Compute mass fluxes tangential to each edge (i.e., through the faces of dual grid cells)
- !
- vh(:,:) = 0.0
- do iEdge=1,grid % nEdgesSolve
- do j=1,nEdgesOnEdge(iEdge)
- eoe = edgesOnEdge(j,iEdge)
- do k=1,nVertLevels
- vh(k,iEdge) = vh(k,iEdge) + weightsOnEdge(j,iEdge) * u(k,eoe) * h_edge(k,eoe)
- end do
- end do
- end do
-
- do iEdge=1,grid % nEdgesSolve
- vertex1 = verticesOnEdge(1,iEdge)
- vertex2 = verticesOnEdge(2,iEdge)
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
-
- do k=1,nVertLevels
- vorticity_abs = fEdge(iEdge) + (circulation(k,vertex1) + circulation(k,vertex2)) / &
- (areaTriangle(vertex1) + areaTriangle(vertex2))
-
- workpv = 2.0 * vorticity_abs / (h(k,cell1) + h(k,cell2))
-
- tend_u(k,iEdge) = workpv * vh(k,iEdge) - (ke(k,cell2) - ke(k,cell1)) / dcEdge(iEdge)
- end do
- end do
-#endif
-
-
- !
- ! horizontal mixing for u
- !
- if ( h_mom_eddy_visc2 > 0.0 ) then
- do iEdge=1,grid % nEdgesSolve
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- vertex1 = verticesOnEdge(1,iEdge)
- vertex2 = verticesOnEdge(2,iEdge)
-
- do k=1,nVertLevels
-
- !
- ! Compute diffusion, computed as </font>
<font color="black">abla divergence - k \times </font>
<font color="red">abla vorticity
- ! only valid for h_mom_eddy_visc2 == constant
- !
- u_diffusion = ( divergence(k,cell2) - divergence(k,cell1) ) / dcEdge(iEdge) &
- -( vorticity(k,vertex2) - vorticity(k,vertex1) ) / dvEdge(iEdge)
- u_diffusion = h_mom_eddy_visc2 * u_diffusion
-
- tend_u(k,iEdge) = tend_u(k,iEdge) + u_diffusion
- end do
- end do
- end if
-
- if ( h_mom_eddy_visc4 > 0.0 ) then
-
- allocate(delsq_divergence(nVertLevels, nCells+1))
- allocate(delsq_u(nVertLevels, nEdges+1))
- allocate(delsq_circulation(nVertLevels, nVertices+1))
- allocate(delsq_vorticity(nVertLevels, nVertices+1))
-
- delsq_u(:,:) = 0.0
-
- do iEdge=1,grid % nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- vertex1 = verticesOnEdge(1,iEdge)
- vertex2 = verticesOnEdge(2,iEdge)
-
- do k=1,nVertLevels
-
- !
- ! 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 do
-
- delsq_circulation(:,:) = 0.0
- do iEdge=1,nEdges
- 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)
- do k=1,nVertLevels
- delsq_vorticity(k,iVertex) = delsq_circulation(k,iVertex) * r
- end do
- end do
-
- delsq_divergence(:,:) = 0.0
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- do k=1,nVertLevels
- delsq_divergence(k,cell1) = delsq_divergence(k,cell1) + delsq_u(k,iEdge)*dvEdge(iEdge)
- delsq_divergence(k,cell2) = delsq_divergence(k,cell2) - delsq_u(k,iEdge)*dvEdge(iEdge)
- end do
- end do
- do iCell = 1,nCells
- r = 1.0 / areaCell(iCell)
- do k = 1,nVertLevels
- delsq_divergence(k,iCell) = delsq_divergence(k,iCell) * r
- end do
- end do
-
- 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 h_mom_eddy_visc4 == constant
- !
- u_diffusion = ( delsq_divergence(k,cell2) - delsq_divergence(k,cell1) ) / dcEdge(iEdge) &
- -( delsq_vorticity(k,vertex2) - delsq_vorticity(k,vertex1) ) / dvEdge(iEdge)
-
- tend_u(k,iEdge) = tend_u(k,iEdge) - h_mom_eddy_visc4 * u_diffusion
- end do
- end do
-
- deallocate(delsq_divergence)
- deallocate(delsq_u)
- deallocate(delsq_circulation)
- deallocate(delsq_vorticity)
-
- end if
-
-
- !
- ! vertical advection for u
- !
- do iEdge=1,grid % nEdgesSolve
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
-
- wdun(1) = 0.
- do k=2,nVertLevels
- wdun(k) = &
- (ww(k,cell1)/(h(k,cell1)+h(k-1,cell1)) +ww(k,cell2)/(h(k,cell2)+h(k-1,cell2)))* &
- rdnu(k)*(u(k,iEdge)-u(k-1,iEdge))
- end do
- wdun(nVertLevels+1) = 0.
-
- do k=1,nVertLevels
- tend_u(k,iEdge) = tend_u(k,iEdge) - 0.5*(wdun(k+1)+wdun(k))
- end do
- end do
-
-
- !
- ! vertical mixing for u - 2nd order
- !
- if ( v_mom_eddy_visc2 > 0.0 ) then
-
- do iEdge=1,grid % nEdgesSolve
-
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
-
- do k=2,nVertLevels-1
-
- z1 = 0.5*(geopotential(k-1,cell1)+geopotential(k-1,cell2))/gravity
- z2 = 0.5*(geopotential(k ,cell1)+geopotential(k ,cell2))/gravity
- z3 = 0.5*(geopotential(k+1,cell1)+geopotential(k+1,cell2))/gravity
- z4 = 0.5*(geopotential(k+2,cell1)+geopotential(k+2,cell2))/gravity
-
- zm = 0.5*(z1+z2)
- z0 = 0.5*(z2+z3)
- zp = 0.5*(z3+z4)
-
- tend_u(k,iEdge) = tend_u(k,iEdge) + v_mom_eddy_visc2*( &
- (u(k+1,iEdge)-u(k ,iEdge))/(zp-z0) &
- -(u(k ,iEdge)-u(k-1,iEdge))/(z0-zm) )/(0.5*(zp-zm))
- end do
- end do
-
- end if
-
-
-!----------- rhs for theta
-
- tend_theta(:,:) = 0.
-
-
- !
- ! horizontal mixing for theta - we could combine this with advection directly (i.e. as a turbulent flux),
- ! but here we can also code in hyperdiffusion if we wish (2nd order at present)
- !
- if ( h_theta_eddy_visc2 > 0.0 ) then
-
- do iEdge=1,grid % nEdges
- cell1 = grid % cellsOnEdge % array(1,iEdge)
- cell2 = grid % cellsOnEdge % array(2,iEdge)
-
- 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 do
-
- end if
-
- if ( h_theta_eddy_visc4 > 0.0 ) then
-
- 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)
-
- 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 do
-
- do iCell = 1, nCells
- r = 1.0 / areaCell(iCell)
- do k=1,nVertLevels
- delsq_theta(k,iCell) = delsq_theta(k,iCell) * r
- end do
- end do
-
- do iEdge=1,grid % nEdges
- cell1 = grid % cellsOnEdge % array(1,iEdge)
- cell2 = grid % cellsOnEdge % array(2,iEdge)
-
- 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
-
- end do
-
- deallocate(delsq_theta)
-
- end if
-
-
- !
- ! horizontal advection for theta
- !
-
- if (config_theta_adv_order == 2) then
-
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- 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
-
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
-
- 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)
- 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 do
-
- else if (config_theta_adv_order == 4) then
-
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
-
- 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)
- 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
-
-
- !
- ! vertical advection plus diabatic term
- ! Note: we are also dividing through by the cell area after the horizontal flux divergence
- !
- do iCell = 1, nCells
- wdtn(1) = 0.
- do k=2,nVertLevels
- wdtn(k) = ww(k,icell)*(fnm(k)*theta(k,iCell)+fnp(k)*theta(k-1,iCell))
- end do
- wdtn(nVertLevels+1) = 0.
- do k=1,nVertLevels
- tend_theta(k,iCell) = tend_theta(k,iCell)/areaCell(iCell) -rdnw(k)*(wdtn(k+1)-wdtn(k))
-!! tend_theta(k,iCell) = tend_theta(k) + h(k,iCell)*h_diabatic(k,iCell)
- end do
- end do
-
-
- !
- ! vertical mixing for theta - 2nd order
- !
- if ( v_theta_eddy_visc2 > 0.0 ) then
-
- do iCell = 1, grid % nCellsSolve
- do k=2,nVertLevels-1
- z1 = geopotential(k-1,iCell)/gravity
- z2 = geopotential(k ,iCell)/gravity
- z3 = geopotential(k+1,iCell)/gravity
- z4 = geopotential(k+2,iCell)/gravity
-
- zm = 0.5*(z1+z2)
- z0 = 0.5*(z2+z3)
- zp = 0.5*(z3+z4)
-
- tend_theta(k,iCell) = tend_theta(k,iCell) + v_theta_eddy_visc2*prandtl*h(k,iCell)*( &
- (theta(k+1,iCell)-theta(k ,iCell))/(zp-z0) &
- -(theta(k ,iCell)-theta(k-1,iCell))/(z0-zm) )/(0.5*(zp-zm))
- end do
- end do
-
- end if
-
- end subroutine compute_dyn_tend
-
-!---------------------------------------------------------------------------------------------------------
-
- subroutine advance_dynamics(tend, s, grid, small_step, number_small_steps, dt)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Advance the dry dynamics a small timestep (forward-backward integration)
- !
- ! Input: s - current model state
- ! tend - large-timestep tendency (d*/dt)
- ! grid - grid metadata
- ! dt - timestep
- !
- ! Output: s - model state advanced a timestep dt
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (tend_type), intent(in) :: tend
- type (state_type), intent(inout) :: s
- type (mesh_type), intent(in) :: grid
- real (kind=RKIND), intent(in) :: dt
- integer, intent(in) :: small_step, number_small_steps
-
- 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 :: nEdges, nVertices, nVertLevels
- real (kind=RKIND), dimension(:), pointer :: h_s, fVertex, fEdge, dvEdge, dcEdge, areaCell, areaTriangle, dpsdt, &
- surface_pressure
- real (kind=RKIND), dimension(:,:), pointer :: vh, weightsOnEdge, kiteAreasOnVertex, h_edge, h, u, v, tend_h, tend_u, &
- circulation, vorticity, ke, pv_edge, geopotential, alpha, theta, &
- pressure, pressure_old, tend_theta, uhAvg, wwAvg, ww, u_old, &
- theta_old, h_edge_old, qtot, ww_old, cqu, h_old
- real (kind=RKIND), dimension(:,:,:), pointer :: scalar
-
-! real (kind=RKIND), pointer :: smext, p0, ptop
- real (kind=RKIND) :: smext, smdiv, p0, ptop
- real (kind=RKIND) :: tm, ptmp, he_old
-
- integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnVertex, verticesOnEdge, edgesOnCell, edgesOnEdge, edgesOnVertex
- integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge
-
- real (kind=RKIND), dimension( grid % nVertLevels + 1) :: wdtn
-
- real (kind=RKIND), dimension(:), pointer :: dnw, dbn, rdnw, dnu, fnm, fnp
- real (kind=RKIND) :: maxpdt,minpdt, maxww, minww
- integer :: maxpt,minpt
-
- h => s % h % array
- u => s % u % array
- h_edge => s % h_edge % array
- theta => s % theta % array
-
-! u_old => s_old % u % array
-! h_edge_old => s_old % h_edge % array
-! theta_old => s_old % theta % array
-! ww_old => s_old % ww % array
-! h_old => s_old % h % array
- u_old => grid % u_old % array
- h_edge_old => grid % h_edge_old % array
- theta_old => grid % theta_old % array
- ww_old => grid % ww_old % array
- h_old => grid % h_old % array
-
- geopotential => s % geopotential % array
- alpha => s % alpha % array
- surface_pressure => s % surface_pressure % array
- pressure => s % pressure % array
- pressure_old => grid % pressure_old % array
-
- cellsOnEdge => grid % cellsOnEdge % array
- dcEdge => grid % dcEdge % array
- dvEdge => grid % dvEdge % array
- areaCell => grid % areaCell % array
- tend_h => tend % h % array
- tend_u => tend % u % array
- tend_theta => tend % theta % array
-
-
- uhAvg => grid % uhAvg % array
- wwAvg => grid % wwAvg % array
- dpsdt => grid % dpsdt % array
- qtot => grid % qtot % array
- cqu => grid % cqu % array
- ww => s % ww % array
- scalar => s % scalars % array
-
- dnw => grid % dnw % array
- dbn => grid % dbn % array
- dnu => grid % dnu % array
- rdnw => grid % rdnw % array
- fnm => grid % fnm % array
- fnp => grid % fnp % array
-
-! p0 => grid % p0
-! ptop => grid % ptop
-! smext => grid % smext
-
- nVertLevels = grid % nVertLevels
- nEdges = grid % nEdges
-
- p0 = 1.e+05
- ptop = pressure(nVertLevels+1,1)
- smext = 0.1
- smdiv = 0.1
-
-! write(0,*) ' ptop in advance_dynamics ',ptop
-
-!--- begin computations
-
-! we assume that the pressure, alpha, geopotential are already properly set
-! in first small step of a set, couple theta
-
- if(small_step == 1) then
-
- do iCell=1,grid % nCells
- do k=1,nVertLevels
- theta(k,iCell) = theta(k,iCell)*h(k,iCell)
- end do
- end do
-
- uhAvg = 0.
- wwAvg = 0.
- pressure_old(:,:) = pressure(:,:)
- dpsdt(:) = 0.
-
- end if
-
- !
- ! update horizontal momentum
- !
-
- do iEdge=1,grid % nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- 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
-
- !
- ! calculate omega, update theta
- !
-
- tend_h = 0.
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- do k=1,nVertLevels
- flux = u(k,iEdge) * dvEdge(iEdge) * h_edge(k,iEdge)
- tend_h(k,cell1) = tend_h(k,cell1) + flux
- tend_h(k,cell2) = tend_h(k,cell2) - flux
- end do
- do k=1,nVertLevels
- uhAvg(k,iEdge) = uhAvg(k,iEdge) + u(k,iEdge) * h_edge(k,iEdge)
- end do
- end do
-
- do iCell=1, grid % nCells
- dpsdt(iCell) = 0.
- do k=1,nVertLevels
- dpsdt(iCell) = dpsdt(iCell) + dnw(k)*tend_h(k,iCell)
- end do
- dpsdt(iCell) = dpsdt(iCell)/areaCell(iCell)
-
- surface_pressure(iCell) = surface_pressure(iCell) + dt*dpsdt(iCell)
-
- do k=1,nVertLevels
- h(k,iCell) = (1.-dbn(k))*(p0-ptop)+dbn(k)*(surface_pressure(iCell)-ptop)
- end do
-
- ! omega calculation
-
- ww(1,iCell) = 0.
- do k=2, nVertLevels
- ww(k,iCell) = ww(k-1,iCell)-dnw(k-1)*(dbn(k-1)*dpsdt(iCell)+tend_h(k-1,iCell)/areaCell(iCell))
- wwAvg(k,iCell) = wwAvg(k,iCell) + ww(k,iCell)
- end do
- ww(nVertLevels+1,iCell) = 0.
-
- ! theta update - theta should be coupled at this point...
-
- wdtn(1) = 0.
- do k = 2, nVertLevels
- wdtn(k) = (ww(k,iCell)-ww_old(k,iCell))*(fnm(k)*theta_old(k,iCell)+fnp(k)*theta_old(k-1,iCell))
- end do
- wdtn(nVertLevels+1) = 0.
-
- do k = 1, nVertLevels
- theta(k,iCell) = theta(k,iCell) + dt*tend_theta(k,iCell)
- theta(k,iCell) = theta(k,iCell) - dt*rdnw(k)*(wdtn(k+1)-wdtn(k))
- end do
- end do
-
- !
- ! add in perturbation horizontal flux divergence
- !
-
- do iEdge=1,nEdges
- 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
-
-
- ! compute some diagnostics using the new state
-
- do iCell = 1, grid % nCells
-
- do k = nVertLevels,1,-1
- pressure(k,iCell) = pressure(k+1,iCell) - dnw(k)*(1.+qtot(k,iCell))*h(k,iCell)
- end do
-
- do k=1, nVertLevels
- tm = (1.+1.61*scalar(1,k,iCell))*theta(k,iCell)/h(k,iCell) ! assume scalar(1) is qv here?
- alpha(k,iCell) = (rgas/p0)*tm* &
- (0.5*(pressure(k,iCell)+pressure(k+1,iCell))/p0)**cvpm
- geopotential(k+1,iCell) = geopotential(k,iCell) - dnw(k)*h(k,iCell)*alpha(k,iCell)
- end do
-
- if(small_step /= number_small_steps) then
- do k=1, nVertLevels+1
- ptmp = pressure(k,iCell)
- pressure(k,iCell) = pressure(k,iCell) + smdiv*(pressure(k,iCell)-pressure_old(k,iCell))
- pressure_old(k,iCell) = ptmp
- end do
- end if
-
- end do
-
-! if last small step of a set, decouple theta
-
- if(small_step == number_small_steps) then
- do iCell=1,grid % nCells
- do k=1,nVertLevels
- theta(k,iCell) = theta(k,iCell)/h(k,iCell)
- end do
- end do
- uhAvg = uhAvg/real(number_small_steps)
- wwAvg = wwAvg/real(number_small_steps)
- end if
-
- end subroutine advance_dynamics
-
-
- subroutine advance_scalars( tend, s_old, s_new, grid, dt)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !
- ! Input: s - current model state
- ! grid - grid metadata
- !
- ! Output: tend - computed scalar tendencies
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (tend_type), intent(in) :: tend
- type (state_type), intent(in) :: s_old
- type (state_type), intent(inout) :: s_new
- type (mesh_type), intent(in) :: grid
- real (kind=RKIND) :: dt
-
- integer :: i, iCell, iEdge, k, iScalar, cell1, cell2, num_scalars
- real (kind=RKIND) :: flux, scalar_edge, d2fdx2_cell1, d2fdx2_cell2
-
- real (kind=RKIND), dimension(:,:,:), pointer :: scalar_old, scalar_new, scalar_tend
- real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
- real (kind=RKIND), dimension(:,:), pointer :: uhAvg, h_old, h_new, wwAvg
- real (kind=RKIND), dimension(:), pointer :: dvEdge, dcEdge, areaCell
- integer, dimension(:,:), pointer :: cellsOnEdge
-
- real (kind=RKIND), dimension( s_old % num_scalars, grid % nVertLevels + 1 ) :: wdtn
- integer :: nVertLevels
-
- real (kind=RKIND), dimension(:), pointer :: fnm, fnp, rdnw
- real (kind=RKIND) :: coef_3rd_order
-
- num_scalars = s_old % num_scalars
-
- coef_3rd_order = 0.
- if (config_scalar_adv_order == 3) coef_3rd_order = 1.0
- if (config_scalar_adv_order == 3 .and. config_monotonic) coef_3rd_order = 0.25
-
- scalar_old => s_old % scalars % array
- scalar_new => s_new % scalars % array
- deriv_two => grid % deriv_two % array
- uhAvg => grid % uhAvg % array
- dvEdge => grid % dvEdge % array
- dcEdge => grid % dcEdge % array
- cellsOnEdge => grid % cellsOnEdge % array
- scalar_tend => tend % scalars % array
- h_old => s_old % h % array
- h_new => s_new % h % array
- wwAvg => grid % wwAvg % array
- areaCell => grid % areaCell % array
-
- fnm => grid % fnm % array
- fnp => grid % fnp % array
- rdnw => grid % rdnw % array
-
- nVertLevels = grid % nVertLevels
-
- scalar_tend = 0. ! testing purposes - we have no sources or sinks
-
- !
- ! Runge Kutta integration, so we compute fluxes from scalar_new values, update starts form scalar_old
- !
- !
- ! horizontal flux divergence, accumulate in scalar_tend
-
- if (config_scalar_adv_order == 2) then
-
- do iEdge=1,grid%nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- 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 do
- end do
-
- else if (config_scalar_adv_order == 3) then
-
- do iEdge=1,grid%nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
-
- 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)
- 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
- end do
- end do
-
- else if (config_scalar_adv_order == 4) then
-
- do iEdge=1,grid%nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
-
- 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)
- 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 do
-
- end do
- end if
-
-
- !
- ! vertical flux divergence
- !
-
- do iCell=1,grid % nCells
-
- wdtn(:,1) = 0.
- do k = 2, nVertLevels
- do iScalar=1,num_scalars
- wdtn(iScalar,k) = wwAvg(k,iCell)*(fnm(k)*scalar_new(iScalar,k,iCell)+fnp(k)*scalar_new(iScalar,k-1,iCell))
- end do
- end do
- wdtn(:,nVertLevels+1) = 0.
-
- do k=1,grid % nVertLevelsSolve
- do iScalar=1,num_scalars
- scalar_new(iScalar,k,iCell) = ( scalar_old(iScalar,k,iCell)*h_old(k,iCell) &
- + dt*( scalar_tend(iScalar,k,iCell) -rdnw(k)*(wdtn(iScalar,k+1)-wdtn(iScalar,k)) ) )/h_new(k,iCell)
-
- end do
- end do
- end do
-
- end subroutine advance_scalars
-
-
- subroutine advance_scalars_mono( tend, s_old, s_new, grid, dt, rk_step, rk_order, dminfo, cellsToSend, cellsToRecv)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !
- ! Input: s - current model state
- ! grid - grid metadata
- !
- ! Output: tend - computed scalar tendencies
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (tend_type), intent(in) :: tend
- type (state_type), intent(in) :: s_old
- type (state_type), intent(inout) :: s_new
- type (mesh_type), intent(in) :: grid
- integer, intent(in) :: rk_step, rk_order
- real (kind=RKIND), intent(in) :: dt
- type (dm_info), intent(in) :: dminfo
- type (exchange_list), pointer :: cellsToSend, cellsToRecv
-
- integer :: i, iCell, iEdge, k, iScalar, cell_upwind, cell1, cell2, num_scalars
- real (kind=RKIND) :: flux, scalar_edge, d2fdx2_cell1, d2fdx2_cell2
- real (kind=RKIND) :: fdir, flux_upwind, h_flux_upwind, s_upwind
-
- real (kind=RKIND), dimension(:,:,:), pointer :: scalar_old, scalar_new, scalar_tend
- real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
- real (kind=RKIND), dimension(:,:), pointer :: uhAvg, h_old, h_new, wwAvg
- real (kind=RKIND), dimension(:), pointer :: dvEdge, dcEdge, areaCell
- integer, dimension(:,:), pointer :: cellsOnEdge
-
- real (kind=RKIND), dimension( s_old % num_scalars, grid % nEdges+1) :: h_flux
- real (kind=RKIND), dimension( s_old % num_scalars, grid % nCells+1, 2 ) :: v_flux, v_flux_upwind, s_update
- real (kind=RKIND), dimension( s_old % num_scalars, grid % nCells+1, 2 ) :: scale_out, scale_in
- real (kind=RKIND), dimension( s_old % num_scalars ) :: s_max, s_min, s_max_update, s_min_update
-
- integer :: nVertLevels, km0, km1, ktmp, kcp1, kcm1
-
- real (kind=RKIND), dimension(:), pointer :: fnm, fnp, rdnw
- real (kind=RKIND), parameter :: eps=1.e-20
- real (kind=RKIND) :: coef_3rd_order
-
- num_scalars = s_old % num_scalars
-
- scalar_old => s_old % scalars % array
- scalar_new => s_new % scalars % array
- deriv_two => grid % deriv_two % array
- uhAvg => grid % uhAvg % array
- dvEdge => grid % dvEdge % array
- dcEdge => grid % dcEdge % array
- cellsOnEdge => grid % cellsOnEdge % array
- scalar_tend => tend % scalars % array
- h_old => s_old % h % array
- h_new => s_new % h % array
- wwAvg => grid % wwAvg % array
- areaCell => grid % areaCell % array
-
- fnm => grid % fnm % array
- fnp => grid % fnp % array
- rdnw => grid % rdnw % array
-
- nVertLevels = grid % nVertLevels
-
- scalar_tend = 0. ! testing purposes - we have no sources or sinks
-
- !
- ! Runge Kutta integration, so we compute fluxes from scalar_new values, update starts from scalar_old
- !
-
- km1 = 1
- km0 = 2
- v_flux(:,:,km1) = 0.
- v_flux_upwind(:,:,km1) = 0.
- scale_out(:,:,:) = 1.
- scale_in(:,:,:) = 1.
-
- coef_3rd_order = 0.
- if (config_scalar_adv_order == 3) coef_3rd_order = 1.0
- if (config_scalar_adv_order == 3 .and. config_monotonic) coef_3rd_order = 0.25
-
- do k = 1, grid % nVertLevels
- kcp1 = min(k+1,grid % nVertLevels)
- kcm1 = max(k-1,1)
-
-! vertical flux
-
- do iCell=1,grid % nCells
-
- if (k < grid % nVertLevels) then
- cell_upwind = k
- if (wwAvg(k+1,iCell) >= 0) cell_upwind = k+1
- do iScalar=1,num_scalars
- v_flux(iScalar,iCell,km0) = dt * wwAvg(k+1,iCell) * &
- (fnm(k+1) * scalar_new(iScalar,k+1,iCell) + fnp(k+1) * scalar_new(iScalar,k,iCell))
- v_flux_upwind(iScalar,iCell,km0) = dt * wwAvg(k+1,iCell) * scalar_old(iScalar,cell_upwind,iCell)
- v_flux(iScalar,iCell,km0) = v_flux(iScalar,iCell,km0) - v_flux_upwind(iScalar,iCell,km0)
-! v_flux(iScalar,iCell,km0) = 0. ! use only upwind - for testing
- s_update(iScalar,iCell,km0) = scalar_old(iScalar,k,iCell) * h_old(k,iCell) &
- - rdnw(k) * (v_flux_upwind(iScalar,iCell,km0) - v_flux_upwind(iScalar,iCell,km1))
- end do
- else
- do iScalar=1,num_scalars
- v_flux(iScalar,iCell,km0) = 0.
- v_flux_upwind(iScalar,iCell,km0) = 0.
- s_update(iScalar,iCell,km0) = scalar_old(iScalar,k,iCell) * h_old(k,iCell) &
- - rdnw(k) * (v_flux_upwind(iScalar,iCell,km0) - v_flux_upwind(iScalar,iCell,km1))
- end do
- end if
-
- end do
-
-! horizontal flux
-
- if (config_scalar_adv_order == 2) then
-
- do iEdge=1,grid%nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- 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
-
- do iEdge=1,grid%nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- 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
-
- 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
-
-
- if ( (rk_step == rk_order) .and. (config_monotonic .or. config_positive_definite) ) then
-
-!*************************************************************************************************************
-!--- limiter - we limit horizontal and vertical fluxes on level k
-!--- (these are h fluxes contributing to level k scalars, and v flux contributing to level k, k-1 scalars)
-
- do iCell=1,grid % nCells
-
- do iScalar=1,num_scalars
-
- s_max(iScalar) = max(scalar_old(iScalar,k,iCell), scalar_old(iScalar,kcp1,iCell), scalar_old(iScalar,kcm1,iCell))
- s_min(iScalar) = min(scalar_old(iScalar,k,iCell), scalar_old(iScalar,kcp1,iCell), scalar_old(iScalar,kcm1,iCell))
- s_max_update(iScalar) = s_update(iScalar,iCell,km0)
- s_min_update(iScalar) = s_update(iScalar,iCell,km0)
-
- ! add in vertical flux to get max and min estimate
- s_max_update(iScalar) = s_max_update(iScalar) &
- - rdnw(k) * (max(0.,v_flux(iScalar,iCell,km0)) - min(0.,v_flux(iScalar,iCell,km1)))
- s_min_update(iScalar) = s_min_update(iScalar) &
- - rdnw(k) * (min(0.,v_flux(iScalar,iCell,km0)) - max(0.,v_flux(iScalar,iCell,km1)))
-
- end do
-
- do i = 1, grid % nEdgesOnCell % array(iCell) ! go around the edges of each cell
- 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))
-
- 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
-
- if( config_positive_definite ) s_min(:) = 0.
-
- do iScalar=1,num_scalars
- scale_out (iScalar,iCell,km0) = 1.
- scale_in (iScalar,iCell,km0) = 1.
- s_max_update (iScalar) = s_max_update (iScalar) / h_new (k,iCell)
- s_min_update (iScalar) = s_min_update (iScalar) / h_new (k,iCell)
- s_upwind = s_update(iScalar,iCell,km0) / h_new(k,iCell)
- if ( s_max_update(iScalar) > s_max(iScalar) .and. config_monotonic) &
- scale_in (iScalar,iCell,km0) = max(0.,(s_max(iScalar)-s_upwind)/(s_max_update(iScalar)-s_upwind+eps))
- if ( s_min_update(iScalar) < s_min(iScalar) ) &
- scale_out (iScalar,iCell,km0) = max(0.,(s_upwind-s_min(iScalar))/(s_upwind-s_min_update(iScalar)+eps))
- end do
-
- end do ! end loop over cells to compute scale factor
-
-
- call dmpar_exch_halo_field2dReal(dminfo, scale_out(:,:,1), &
- num_scalars, grid % nCells, &
- cellsToSend, cellsToRecv)
- call dmpar_exch_halo_field2dReal(dminfo, scale_out(:,:,2), &
- num_scalars, grid % nCells, &
- cellsToSend, cellsToRecv)
- call dmpar_exch_halo_field2dReal(dminfo, scale_in(:,:,1), &
- num_scalars, grid % nCells, &
- cellsToSend, cellsToRecv)
- call dmpar_exch_halo_field2dReal(dminfo, scale_in(:,:,2), &
- num_scalars, grid % nCells, &
- cellsToSend, cellsToRecv)
-
- ! rescale the horizontal fluxes
-
- do iEdge = 1, grid % nEdges
- cell1 = grid % cellsOnEdge % array(1,iEdge)
- cell2 = grid % cellsOnEdge % array(2,iEdge)
- 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
-
- do iCell=1,grid % nCells
- do iScalar=1,num_scalars
- flux = v_flux(iScalar,iCell,km1)
- if (flux > 0) then
- flux = flux * min(scale_out(iScalar,iCell,km0), scale_in(iScalar,iCell,km1))
- else
- flux = flux * min(scale_in(iScalar,iCell,km0), scale_out(iScalar,iCell,km1))
- end if
- v_flux(iScalar,iCell,km1) = flux
- end do
- end do
-
-! end of limiter
-!*******************************************************************************************************************
-
- end if
-
-!--- update
-
- do iCell=1,grid % nCells
- ! add in upper vertical flux that was just renormalized
- do iScalar=1,num_scalars
- s_update(iScalar,iCell,km0) = s_update(iScalar,iCell,km0) + rdnw(k) * v_flux(iScalar,iCell,km1)
- if (k > 1) s_update(iScalar,iCell,km1) = s_update(iScalar,iCell,km1) - rdnw(k-1)*v_flux(iScalar,iCell,km1)
- end do
- end do
-
- do iEdge=1,grid%nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- 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
- if (k > 1) then
- do iCell=1,grid % nCells
- do iScalar=1,num_scalars
- s_update(iScalar,iCell,km1) = s_update(iScalar,iCell,km1) / h_new(k-1,iCell)
- end do
- end do
-
- do iCell=1,grid % nCells
- do iScalar=1,num_scalars
- scalar_new(iScalar,k-1,iCell) = s_update(iScalar,iCell,km1)
- end do
- end do
- end if
-
- ktmp = km1
- km1 = km0
- km0 = ktmp
-
- end do
-
- do iCell=1,grid % nCells
- do iScalar=1,num_scalars
- scalar_new(iScalar,grid % nVertLevels,iCell) = s_update(iScalar,iCell,km1) / h_new(grid%nVertLevels,iCell)
- end do
- end do
-
- end subroutine advance_scalars_mono
-
-
- subroutine compute_solve_diagnostics(dt, s, grid)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Compute diagnostic fields used in the tendency computations
- !
- ! Input: grid - grid metadata
- !
- ! Output: s - computed diagnostics
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- real (kind=RKIND), intent(in) :: dt
- type (state_type), intent(inout) :: s
- type (mesh_type), intent(in) :: grid
-
-
- integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j, cov
- real (kind=RKIND) :: flux, vorticity_abs, h_vertex, workpv, r
-
- 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
- integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnVertex, verticesOnEdge, edgesOnCell, edgesOnEdge, edgesOnVertex
- integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge
-
-
- h => s % h % array
- u => s % u % array
- v => s % v % array
- vh => s % vh % 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
- 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
-
- weightsOnEdge => grid % weightsOnEdge % array
- kiteAreasOnVertex => grid % kiteAreasOnVertex % array
- cellsOnEdge => grid % cellsOnEdge % array
- cellsOnVertex => grid % cellsOnVertex % array
- verticesOnEdge => grid % verticesOnEdge % array
- nEdgesOnCell => grid % nEdgesOnCell % array
- edgesOnCell => grid % edgesOnCell % array
- nEdgesOnEdge => grid % nEdgesOnEdge % array
- edgesOnEdge => grid % edgesOnEdge % array
- edgesOnVertex => grid % edgesOnVertex % array
- dcEdge => grid % dcEdge % array
- dvEdge => grid % dvEdge % array
- areaCell => grid % areaCell % array
- areaTriangle => grid % areaTriangle % array
- h_s => grid % h_s % array
- fVertex => grid % fVertex % array
- fEdge => grid % fEdge % array
-
- nCells = grid % nCells
- nEdges = grid % nEdges
- nVertices = grid % nVertices
- nVertLevels = grid % nVertLevels
-
- !
- ! Compute height on cell edges at velocity locations
- !
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- do k=1,nVertLevels
- h_edge(k,iEdge) = 0.5 * (h(k,cell1) + h(k,cell2))
- end do
- end do
-
- !
- ! Compute circulation and relative vorticity at each vertex
- !
- circulation(:,:) = 0.0
- do iEdge=1,nEdges
- do k=1,nVertLevels
- circulation(k,verticesOnEdge(1,iEdge)) = circulation(k,verticesOnEdge(1,iEdge)) - dcEdge(iEdge) * u(k,iEdge)
- circulation(k,verticesOnEdge(2,iEdge)) = circulation(k,verticesOnEdge(2,iEdge)) + dcEdge(iEdge) * u(k,iEdge)
- end do
- end do
- do iVertex=1,nVertices
- do k=1,nVertLevels
- vorticity(k,iVertex) = circulation(k,iVertex) / areaTriangle(iVertex)
- end do
- end do
-
-
- !
- ! Compute the divergence at each cell center
- !
- divergence(:,:) = 0.0
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- 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)
- do k = 1,nVertLevels
- divergence(k,iCell) = divergence(k,iCell) * r
- end do
- end do
-
-
- !
- ! Compute kinetic energy in each cell
- !
- ke(:,:) = 0.0
- do iCell=1,nCells
- do i=1,nEdgesOnCell(iCell)
- iEdge = edgesOnCell(i,iCell)
- do k=1,nVertLevels
- ke(k,iCell) = ke(k,iCell) + 0.25 * dcEdge(iEdge) * dvEdge(iEdge) * u(k,iEdge)**2.0
- end do
- end do
- do k=1,nVertLevels
- ke(k,iCell) = ke(k,iCell) / areaCell(iCell)
- end do
- end do
-
- !
- ! Compute v (tangential) velocities
- !
- v(:,:) = 0.0
- do iEdge = 1,nEdges
- do i=1,nEdgesOnEdge(iEdge)
- eoe = edgesOnEdge(i,iEdge)
- do k = 1,nVertLevels
- v(k,iEdge) = v(k,iEdge) + weightsOnEdge(i,iEdge) * u(k, eoe)
- end do
- end do
- end do
-
-
- ! tdr
- !
- ! Compute height at vertices, pv at vertices, and average pv to edge locations
- ! ( this computes pv_vertex at all vertices bounding real cells )
- !
- do iVertex = 1,nVertices
- do k=1,nVertLevels
- h_vertex = 0.0
- do i=1,grid % vertexDegree
- 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
- ! tdr
-
-
- ! tdr
- !
- ! Compute gradient of PV in the tangent direction
- ! ( this computes gradPVt at all edges bounding real cells )
- !
- do iEdge = 1,nEdges
- do k = 1,nVertLevels
- gradPVt(k,iEdge) = (pv_vertex(k,verticesOnEdge(2,iEdge)) - pv_vertex(k,verticesOnEdge(1,iEdge))) / &
- dvEdge(iEdge)
- end do
- end do
-
- ! tdr
- !
- ! Compute pv at the edges
- ! ( this computes pv_edge at all edges bounding real cells )
- !
- pv_edge(:,:) = 0.0
- do iVertex = 1,nVertices
- do i=1,grid % vertexDegree
- iEdge = edgesOnVertex(i,iVertex)
- do k=1,nVertLevels
- pv_edge(k,iEdge) = pv_edge(k,iEdge) + 0.5 * pv_vertex(k,iVertex)
- end do
- end do
- end do
- ! tdr
-
- ! tdr
- !
- ! Modify PV edge with upstream bias.
- !
- do iEdge = 1,nEdges
- do k = 1,nVertLevels
- pv_edge(k,iEdge) = pv_edge(k,iEdge) - config_apvm_upwinding * v(k,iEdge) * dt * gradPVt(k,iEdge)
- end do
- end do
-
-
- ! tdr
- !
- ! Compute pv at cell centers
- ! ( this computes pv_cell for all real cells )
- !
- pv_cell(:,:) = 0.0
- do iVertex = 1, nVertices
- do i=1,grid % vertexDegree
- 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 do
- end do
- ! tdr
-
- ! tdr
- !
- ! Compute gradient of PV in normal direction
- ! (tdr: 2009-10-02: this is not correct because the pv_cell in the halo is not correct)
- !
- gradPVn(:,:) = 0.0
- do iEdge = 1,nEdges
- do k = 1,nVertLevels
- gradPVn(k,iEdge) = (pv_cell(k,cellsOnEdge(2,iEdge)) - pv_cell(k,cellsOnEdge(1,iEdge))) / &
- dcEdge(iEdge)
- end do
- end do
- ! tdr
-
- ! Modify PV edge with upstream bias.
- !
- do iEdge = 1,nEdges
- do k = 1,nVertLevels
- pv_edge(k,iEdge) = pv_edge(k,iEdge) - config_apvm_upwinding * u(k,iEdge) * dt * gradPVn(k,iEdge)
- end do
- end do
-
-
- 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 (state_type), intent(inout) :: s_new
- type (state_type), intent(in) :: s_old
- type (mesh_type), 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
Copied: trunk/mpas/src/core_hyd_atmos/mpas_atmh_advection.F (from rev 1113, branches/source_renaming/src/core_hyd_atmos/mpas_atmh_advection.F)
===================================================================
--- trunk/mpas/src/core_hyd_atmos/mpas_atmh_advection.F (rev 0)
+++ trunk/mpas/src/core_hyd_atmos/mpas_atmh_advection.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -0,0 +1,688 @@
+module atmh_advection
+
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_constants
+
+
+ contains
+
+
+ subroutine atmh_initialize_advection_rk( grid )
+
+!
+! compute the cell coefficients for the polynomial fit.
+! this is performed during setup for model integration.
+! WCS, 31 August 2009
+!
+ implicit none
+
+ type (mesh_type), intent(in) :: grid
+
+ real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
+ integer, dimension(:,:), pointer :: advCells
+
+! local variables
+
+ real (kind=RKIND), dimension(2, grid % nEdges) :: thetae
+ real (kind=RKIND), dimension(grid % nEdges) :: xe, ye
+ real (kind=RKIND), dimension(grid % nCells) :: theta_abs
+
+ real (kind=RKIND), dimension(25) :: xc, yc, zc ! cell center coordinates
+ real (kind=RKIND), dimension(25) :: thetav, thetat, dl_sphere
+ real (kind=RKIND) :: xm, ym, zm, dl, xec, yec, zec
+ real (kind=RKIND) :: thetae_tmp, xe_tmp, ye_tmp
+ real (kind=RKIND) :: xv1, xv2, yv1, yv2, zv1, zv2
+ integer :: i, j, k, ip1, ip2, m, n, ip1a, ii
+ integer :: iCell, iEdge
+ real (kind=RKIND) :: pii
+ real (kind=RKIND) :: x0, y0, x1, y1, x2, y2, x3, y3, x4, y4, x5, y5
+ real (kind=RKIND) :: pdx1, pdx2, pdx3, pdy1, pdy2, pdy3, dx1, dx2, dy1, dy2
+ real (kind=RKIND) :: angv1, angv2, dl1, dl2
+ real (kind=RKIND), dimension(25) :: dxe, dye, x2v, y2v, xp, yp
+
+ real (kind=RKIND) :: amatrix(25,25), bmatrix(25,25), wmatrix(25,25)
+ real (kind=RKIND) :: length_scale
+ integer :: ma,na, cell_add, mw, nn
+ integer, dimension(25) :: cell_list
+
+
+ integer :: cell1, cell2
+ integer, parameter :: polynomial_order = 2
+! logical, parameter :: debug = .true.
+ logical, parameter :: debug = .false.
+! logical, parameter :: least_squares = .false.
+ logical, parameter :: least_squares = .true.
+ logical :: add_the_cell, do_the_cell
+
+ logical, parameter :: reset_poly = .true.
+
+ real (kind=RKIND) :: rcell, cos2t, costsint, sin2t
+
+!---
+
+ pii = 2.*asin(1.0)
+
+ advCells => grid % advCells % array
+ deriv_two => grid % deriv_two % array
+ deriv_two(:,:,:) = 0.
+
+ do iCell = 1, grid % nCells ! is this correct? - we need first halo cell also...
+
+ cell_list(1) = iCell
+ do i=2, grid % nEdgesOnCell % array(iCell)+1
+ cell_list(i) = grid % CellsOnCell % array(i-1,iCell)
+ end do
+ n = grid % nEdgesOnCell % array(iCell) + 1
+
+ if ( polynomial_order > 2 ) then
+ do i=2,grid % nEdgesOnCell % array(iCell) + 1
+ do j=1,grid % nEdgesOnCell % array ( cell_list(i) )
+ cell_add = grid % CellsOnCell % array (j,cell_list(i))
+ add_the_cell = .true.
+ do k=1,n
+ if ( cell_add == cell_list(k) ) add_the_cell = .false.
+ end do
+ if (add_the_cell) then
+ n = n+1
+ cell_list(n) = cell_add
+ end if
+ end do
+ end do
+ end if
+
+ advCells(1,iCell) = n
+
+! check to see if we are reaching outside the halo
+
+ do_the_cell = .true.
+ do i=1,n
+ if (cell_list(i) > grid % nCells) do_the_cell = .false.
+ end do
+
+
+ if ( .not. do_the_cell ) cycle
+
+
+! compute poynomial fit for this cell if all needed neighbors exist
+ if ( grid % on_a_sphere ) then
+
+ do i=1,n
+ advCells(i+1,iCell) = cell_list(i)
+ xc(i) = grid % xCell % array(advCells(i+1,iCell))/a
+ yc(i) = grid % yCell % array(advCells(i+1,iCell))/a
+ zc(i) = grid % zCell % array(advCells(i+1,iCell))/a
+ end do
+
+ theta_abs(iCell) = pii/2. - sphere_angle( xc(1), yc(1), zc(1), &
+ xc(2), yc(2), zc(2), &
+ 0., 0., 1. )
+
+! angles from cell center to neighbor centers (thetav)
+
+ do i=1,n-1
+
+ ip2 = i+2
+ if (ip2 > n) ip2 = 2
+
+ thetav(i) = sphere_angle( xc(1), yc(1), zc(1), &
+ xc(i+1), yc(i+1), zc(i+1), &
+ xc(ip2), yc(ip2), zc(ip2) )
+
+ dl_sphere(i) = a*arc_length( xc(1), yc(1), zc(1), &
+ xc(i+1), yc(i+1), zc(i+1) )
+ end do
+
+ length_scale = 1.
+ do i=1,n-1
+ dl_sphere(i) = dl_sphere(i)/length_scale
+ end do
+
+! thetat(1) = 0. ! this defines the x direction, cell center 1 ->
+ thetat(1) = theta_abs(iCell) ! this defines the x direction, longitude line
+ do i=2,n-1
+ thetat(i) = thetat(i-1) + thetav(i-1)
+ end do
+
+ do i=1,n-1
+ xp(i) = cos(thetat(i)) * dl_sphere(i)
+ yp(i) = sin(thetat(i)) * dl_sphere(i)
+ end do
+
+ else ! On an x-y plane
+
+ do i=1,n-1
+ 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)
+
+ bmatrix = 0.
+ amatrix = 0.
+ wmatrix = 0.
+
+ if (polynomial_order == 2) then
+ na = 6
+ ma = ma+1
+
+ amatrix(1,1) = 1.
+ wmatrix(1,1) = 1.
+ do i=2,ma
+ amatrix(i,1) = 1.
+ amatrix(i,2) = xp(i-1)
+ amatrix(i,3) = yp(i-1)
+ amatrix(i,4) = xp(i-1)**2
+ amatrix(i,5) = xp(i-1) * yp(i-1)
+ amatrix(i,6) = yp(i-1)**2
+
+ wmatrix(i,i) = 1.
+ end do
+
+ else if (polynomial_order == 3) then
+ na = 10
+ ma = ma+1
+
+ amatrix(1,1) = 1.
+ wmatrix(1,1) = 1.
+ do i=2,ma
+ amatrix(i,1) = 1.
+ amatrix(i,2) = xp(i-1)
+ amatrix(i,3) = yp(i-1)
+
+ amatrix(i,4) = xp(i-1)**2
+ amatrix(i,5) = xp(i-1) * yp(i-1)
+ amatrix(i,6) = yp(i-1)**2
+
+ amatrix(i,7) = xp(i-1)**3
+ amatrix(i,8) = yp(i-1) * (xp(i-1)**2)
+ amatrix(i,9) = xp(i-1) * (yp(i-1)**2)
+ amatrix(i,10) = yp(i-1)**3
+
+ wmatrix(i,i) = 1.
+
+ end do
+
+ else
+ na = 15
+ ma = ma+1
+
+ amatrix(1,1) = 1.
+ wmatrix(1,1) = 1.
+ do i=2,ma
+ amatrix(i,1) = 1.
+ amatrix(i,2) = xp(i-1)
+ amatrix(i,3) = yp(i-1)
+
+ amatrix(i,4) = xp(i-1)**2
+ amatrix(i,5) = xp(i-1) * yp(i-1)
+ amatrix(i,6) = yp(i-1)**2
+
+ amatrix(i,7) = xp(i-1)**3
+ amatrix(i,8) = yp(i-1) * (xp(i-1)**2)
+ amatrix(i,9) = xp(i-1) * (yp(i-1)**2)
+ amatrix(i,10) = yp(i-1)**3
+
+ amatrix(i,11) = xp(i-1)**4
+ amatrix(i,12) = yp(i-1) * (xp(i-1)**3)
+ amatrix(i,13) = (xp(i-1)**2)*(yp(i-1)**2)
+ amatrix(i,14) = xp(i-1) * (yp(i-1)**3)
+ amatrix(i,15) = yp(i-1)**4
+
+ wmatrix(i,i) = 1.
+
+ end do
+
+ do i=1,mw
+ wmatrix(i,i) = 1.
+ end do
+
+ end if
+
+ call poly_fit_2( amatrix, bmatrix, wmatrix, ma, na, 25 )
+
+ do i=1,grid % nEdgesOnCell % array (iCell)
+ ip1 = i+1
+ if (ip1 > n-1) ip1 = 1
+
+ iEdge = grid % EdgesOnCell % array (i,iCell)
+ xv1 = grid % xVertex % array(grid % verticesOnEdge % array (1,iedge))/a
+ yv1 = grid % yVertex % array(grid % verticesOnEdge % array (1,iedge))/a
+ zv1 = grid % zVertex % array(grid % verticesOnEdge % array (1,iedge))/a
+ xv2 = grid % xVertex % array(grid % verticesOnEdge % array (2,iedge))/a
+ yv2 = grid % yVertex % array(grid % verticesOnEdge % array (2,iedge))/a
+ zv2 = grid % zVertex % array(grid % verticesOnEdge % array (2,iedge))/a
+
+ if ( grid % on_a_sphere ) then
+ call arc_bisect( xv1, yv1, zv1, &
+ xv2, yv2, zv2, &
+ xec, yec, zec )
+
+ thetae_tmp = sphere_angle( xc(1), yc(1), zc(1), &
+ xc(i+1), yc(i+1), zc(i+1), &
+ xec, yec, zec )
+ thetae_tmp = thetae_tmp + thetat(i)
+ if (iCell == grid % cellsOnEdge % array(1,iEdge)) then
+ thetae(1,grid % EdgesOnCell % array (i,iCell)) = thetae_tmp
+ else
+ thetae(2,grid % EdgesOnCell % array (i,iCell)) = thetae_tmp
+ end if
+ else
+ xe(grid % EdgesOnCell % array (i,iCell)) = 0.5 * (xv1 + xv2)
+ ye(grid % EdgesOnCell % array (i,iCell)) = 0.5 * (yv1 + yv2)
+ end if
+
+ end do
+
+! fill second derivative stencil for rk advection
+
+ do i=1, grid % nEdgesOnCell % array (iCell)
+ iEdge = grid % EdgesOnCell % array (i,iCell)
+
+
+ if ( grid % on_a_sphere ) then
+ if (iCell == grid % cellsOnEdge % array(1,iEdge)) then
+
+ cos2t = cos(thetae(1,grid % EdgesOnCell % array (i,iCell)))
+ sin2t = sin(thetae(1,grid % EdgesOnCell % array (i,iCell)))
+ costsint = cos2t*sin2t
+ cos2t = cos2t**2
+ sin2t = sin2t**2
+
+ do j=1,n
+ deriv_two(j,1,iEdge) = 2.*cos2t*bmatrix(4,j) &
+ + 2.*costsint*bmatrix(5,j) &
+ + 2.*sin2t*bmatrix(6,j)
+ end do
+ else
+
+ cos2t = cos(thetae(2,grid % EdgesOnCell % array (i,iCell)))
+ sin2t = sin(thetae(2,grid % EdgesOnCell % array (i,iCell)))
+ costsint = cos2t*sin2t
+ cos2t = cos2t**2
+ sin2t = sin2t**2
+
+ do j=1,n
+ deriv_two(j,2,iEdge) = 2.*cos2t*bmatrix(4,j) &
+ + 2.*costsint*bmatrix(5,j) &
+ + 2.*sin2t*bmatrix(6,j)
+ end do
+ end if
+ else
+ do j=1,n
+ deriv_two(j,1,iEdge) = 2.*xe(iEdge)*xe(iEdge)*bmatrix(4,j) &
+ + 2.*xe(iEdge)*ye(iEdge)*bmatrix(5,j) &
+ + 2.*ye(iEdge)*ye(iEdge)*bmatrix(6,j)
+ deriv_two(j,2,iEdge) = deriv_two(j,1,iEdge)
+ end do
+ end if
+ end do
+
+ end do ! end of loop over cells
+
+ if (debug) stop
+
+ end subroutine atmh_initialize_advection_rk
+
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! FUNCTION SPHERE_ANGLE
+ !
+ ! Computes the angle between arcs AB and AC, given points A, B, and C
+ ! Equation numbers w.r.t. http://mathworld.wolfram.com/SphericalTrigonometry.html
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ real function sphere_angle(ax, ay, az, bx, by, bz, cx, cy, cz)
+
+ implicit none
+
+ real (kind=RKIND), intent(in) :: ax, ay, az, bx, by, bz, cx, cy, cz
+
+ real (kind=RKIND) :: a, b, c ! Side lengths of spherical triangle ABC
+
+ real (kind=RKIND) :: ABx, ABy, ABz ! The components of the vector AB
+ real (kind=RKIND) :: mAB ! The magnitude of AB
+ real (kind=RKIND) :: ACx, ACy, ACz ! The components of the vector AC
+ real (kind=RKIND) :: mAC ! The magnitude of AC
+
+ real (kind=RKIND) :: Dx ! The i-components of the cross product AB x AC
+ real (kind=RKIND) :: Dy ! The j-components of the cross product AB x AC
+ real (kind=RKIND) :: Dz ! The k-components of the cross product AB x AC
+
+ real (kind=RKIND) :: s ! Semiperimeter of the triangle
+ real (kind=RKIND) :: sin_angle
+
+ a = acos(max(min(bx*cx + by*cy + bz*cz,1.0),-1.0)) ! Eqn. (3)
+ b = acos(max(min(ax*cx + ay*cy + az*cz,1.0),-1.0)) ! Eqn. (2)
+ c = acos(max(min(ax*bx + ay*by + az*bz,1.0),-1.0)) ! Eqn. (1)
+
+ ABx = bx - ax
+ ABy = by - ay
+ ABz = bz - az
+
+ ACx = cx - ax
+ ACy = cy - ay
+ ACz = cz - az
+
+ Dx = (ABy * ACz) - (ABz * ACy)
+ Dy = -((ABx * ACz) - (ABz * ACx))
+ Dz = (ABx * ACy) - (ABy * ACx)
+
+ s = 0.5*(a + b + c)
+! sin_angle = sqrt((sin(s-b)*sin(s-c))/(sin(b)*sin(c))) ! Eqn. (28)
+ sin_angle = sqrt(min(1.,max(0.,(sin(s-b)*sin(s-c))/(sin(b)*sin(c))))) ! Eqn. (28)
+
+ if ((Dx*ax + Dy*ay + Dz*az) >= 0.0) then
+ sphere_angle = 2.0 * asin(max(min(sin_angle,1.0),-1.0))
+ else
+ sphere_angle = -2.0 * asin(max(min(sin_angle,1.0),-1.0))
+ end if
+
+ end function sphere_angle
+
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! FUNCTION PLANE_ANGLE
+ !
+ ! Computes the angle between vectors AB and AC, given points A, B, and C, and
+ ! a vector (u,v,w) normal to the plane.
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ real function plane_angle(ax, ay, az, bx, by, bz, cx, cy, cz, u, v, w)
+
+ implicit none
+
+ real (kind=RKIND), intent(in) :: ax, ay, az, bx, by, bz, cx, cy, cz, u, v, w
+
+ real (kind=RKIND) :: ABx, ABy, ABz ! The components of the vector AB
+ real (kind=RKIND) :: mAB ! The magnitude of AB
+ real (kind=RKIND) :: ACx, ACy, ACz ! The components of the vector AC
+ real (kind=RKIND) :: mAC ! The magnitude of AC
+
+ real (kind=RKIND) :: Dx ! The i-components of the cross product AB x AC
+ real (kind=RKIND) :: Dy ! The j-components of the cross product AB x AC
+ real (kind=RKIND) :: Dz ! The k-components of the cross product AB x AC
+
+ real (kind=RKIND) :: cos_angle
+
+ ABx = bx - ax
+ ABy = by - ay
+ ABz = bz - az
+ mAB = sqrt(ABx**2.0 + ABy**2.0 + ABz**2.0)
+
+ ACx = cx - ax
+ ACy = cy - ay
+ ACz = cz - az
+ mAC = sqrt(ACx**2.0 + ACy**2.0 + ACz**2.0)
+
+
+ Dx = (ABy * ACz) - (ABz * ACy)
+ Dy = -((ABx * ACz) - (ABz * ACx))
+ Dz = (ABx * ACy) - (ABy * ACx)
+
+ cos_angle = (ABx*ACx + ABy*ACy + ABz*ACz) / (mAB * mAC)
+
+ if ((Dx*u + Dy*v + Dz*w) >= 0.0) then
+ plane_angle = acos(max(min(cos_angle,1.0),-1.0))
+ else
+ plane_angle = -acos(max(min(cos_angle,1.0),-1.0))
+ end if
+
+ end function plane_angle
+
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! FUNCTION ARC_LENGTH
+ !
+ ! Returns the length of the great circle arc from A=(ax, ay, az) to
+ ! B=(bx, by, bz). It is assumed that both A and B lie on the surface of the
+ ! same sphere centered at the origin.
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ real function arc_length(ax, ay, az, bx, by, bz)
+
+ implicit none
+
+ real (kind=RKIND), intent(in) :: ax, ay, az, bx, by, bz
+
+ real (kind=RKIND) :: r, c
+ real (kind=RKIND) :: cx, cy, cz
+
+ cx = bx - ax
+ cy = by - ay
+ cz = bz - az
+
+! r = ax*ax + ay*ay + az*az
+! c = cx*cx + cy*cy + cz*cz
+!
+! arc_length = sqrt(r) * acos(1.0 - c/(2.0*r))
+
+ r = sqrt(ax*ax + ay*ay + az*az)
+ c = sqrt(cx*cx + cy*cy + cz*cz)
+! arc_length = sqrt(r) * 2.0 * asin(c/(2.0*r))
+ arc_length = r * 2.0 * asin(c/(2.0*r))
+
+ end function arc_length
+
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! SUBROUTINE ARC_BISECT
+ !
+ ! Returns the point C=(cx, cy, cz) that bisects the great circle arc from
+ ! A=(ax, ay, az) to B=(bx, by, bz). It is assumed that A and B lie on the
+ ! surface of a sphere centered at the origin.
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine arc_bisect(ax, ay, az, bx, by, bz, cx, cy, cz)
+
+ implicit none
+
+ real (kind=RKIND), intent(in) :: ax, ay, az, bx, by, bz
+ real (kind=RKIND), intent(out) :: cx, cy, cz
+
+ real (kind=RKIND) :: r ! Radius of the sphere
+ real (kind=RKIND) :: d
+
+ r = sqrt(ax*ax + ay*ay + az*az)
+
+ cx = 0.5*(ax + bx)
+ cy = 0.5*(ay + by)
+ cz = 0.5*(az + bz)
+
+ if (cx == 0. .and. cy == 0. .and. cz == 0.) then
+ write(0,*) 'Error: arc_bisect: A and B are diametrically opposite'
+ else
+ d = sqrt(cx*cx + cy*cy + cz*cz)
+ cx = r * cx / d
+ cy = r * cy / d
+ cz = r * cz / d
+ end if
+
+ end subroutine arc_bisect
+
+
+ subroutine poly_fit_2(a_in,b_out,weights_in,m,n,ne)
+
+ implicit none
+
+ integer, intent(in) :: m,n,ne
+ real (kind=RKIND), dimension(ne,ne), intent(in) :: a_in, weights_in
+ real (kind=RKIND), dimension(ne,ne), intent(out) :: b_out
+
+ ! local storage
+
+ real (kind=RKIND), dimension(m,n) :: a
+ real (kind=RKIND), dimension(n,m) :: b
+ real (kind=RKIND), dimension(m,m) :: w,wt,h
+ real (kind=RKIND), dimension(n,m) :: at, ath
+ real (kind=RKIND), dimension(n,n) :: ata, ata_inv, atha, atha_inv
+ integer, dimension(n) :: indx
+ integer :: i,j
+
+ if ( (ne<n) .or. (ne<m) ) then
+ write(6,*) ' error in poly_fit_2 inversion ',m,n,ne
+ stop
+ end if
+
+! a(1:m,1:n) = a_in(1:n,1:m)
+ a(1:m,1:n) = a_in(1:m,1:n)
+ w(1:m,1:m) = weights_in(1:m,1:m)
+ b_out(:,:) = 0.
+
+ wt = transpose(w)
+ h = matmul(wt,w)
+ at = transpose(a)
+ ath = matmul(at,h)
+ atha = matmul(ath,a)
+
+ ata = matmul(at,a)
+
+! if (m == n) then
+! call MIGS(a,n,b,indx)
+! else
+
+ call MIGS(atha,n,atha_inv,indx)
+
+ b = matmul(atha_inv,ath)
+
+! call MIGS(ata,n,ata_inv,indx)
+! b = matmul(ata_inv,at)
+! end if
+ b_out(1:n,1:m) = b(1:n,1:m)
+
+! do i=1,n
+! write(6,*) ' i, indx ',i,indx(i)
+! end do
+!
+! write(6,*) ' '
+
+ end subroutine poly_fit_2
+
+
+! Updated 10/24/2001.
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 4.4 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! !
+! Please Note: !
+! !
+! (1) This computer program is written by Tao Pang in conjunction with !
+! his book, "An Introduction to Computational Physics," published !
+! by Cambridge University Press in 1997. !
+! !
+! (2) No warranties, express or implied, are made for this program. !
+! !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+SUBROUTine MIGS (A,N,X,INDX)
+!
+! Subroutine to invert matrix A(N,N) with the inverse stored
+! in X(N,N) in the output. Copyright (c) Tao Pang 2001.
+!
+ IMPLICIT NONE
+ INTEGER, INTENT (IN) :: N
+ INTEGER :: I,J,K
+ INTEGER, INTENT (OUT), DIMENSION (N) :: INDX
+ REAL (kind=RKIND), INTENT (INOUT), DIMENSION (N,N):: A
+ REAL (kind=RKIND), INTENT (OUT), DIMENSION (N,N):: X
+ REAL (kind=RKIND), DIMENSION (N,N) :: B
+!
+ DO I = 1, N
+ DO J = 1, N
+ B(I,J) = 0.0
+ END DO
+ END DO
+ DO I = 1, N
+ B(I,I) = 1.0
+ END DO
+!
+ CALL ELGS (A,N,INDX)
+!
+ DO I = 1, N-1
+ DO J = I+1, N
+ DO K = 1, N
+ B(INDX(J),K) = B(INDX(J),K)-A(INDX(J),I)*B(INDX(I),K)
+ END DO
+ END DO
+ END DO
+!
+ DO I = 1, N
+ X(N,I) = B(INDX(N),I)/A(INDX(N),N)
+ DO J = N-1, 1, -1
+ X(J,I) = B(INDX(J),I)
+ DO K = J+1, N
+ X(J,I) = X(J,I)-A(INDX(J),K)*X(K,I)
+ END DO
+ X(J,I) = X(J,I)/A(INDX(J),J)
+ END DO
+ END DO
+END SUBROUTine MIGS
+
+
+SUBROUTINE ELGS (A,N,INDX)
+!
+! Subroutine to perform the partial-pivoting Gaussian elimination.
+! A(N,N) is the original matrix in the input and transformed matrix
+! plus the pivoting element ratios below the diagonal in the output.
+! INDX(N) records the pivoting order. Copyright (c) Tao Pang 2001.
+!
+ IMPLICIT NONE
+ INTEGER, INTENT (IN) :: N
+ INTEGER :: I,J,K,ITMP
+ INTEGER, INTENT (OUT), DIMENSION (N) :: INDX
+ REAL (kind=RKIND) :: C1,PI,PI1,PJ
+ REAL (kind=RKIND), INTENT (INOUT), DIMENSION (N,N) :: A
+ REAL (kind=RKIND), DIMENSION (N) :: C
+!
+! Initialize the index
+!
+ DO I = 1, N
+ INDX(I) = I
+ END DO
+!
+! Find the rescaling factors, one from each row
+!
+ DO I = 1, N
+ C1= 0.0
+ DO J = 1, N
+ C1 = AMAX1(C1,ABS(A(I,J)))
+ END DO
+ C(I) = C1
+ END DO
+!
+! Search the pivoting (largest) element from each column
+!
+ DO J = 1, N-1
+ PI1 = 0.0
+ DO I = J, N
+ PI = ABS(A(INDX(I),J))/C(INDX(I))
+ IF (PI.GT.PI1) THEN
+ PI1 = PI
+ K = I
+ ENDIF
+ END DO
+!
+! Interchange the rows via INDX(N) to record pivoting order
+!
+ ITMP = INDX(J)
+ INDX(J) = INDX(K)
+ INDX(K) = ITMP
+ DO I = J+1, N
+ PJ = A(INDX(I),J)/A(INDX(J),J)
+!
+! Record pivoting ratios below the diagonal
+!
+ A(INDX(I),J) = PJ
+!
+! Modify other elements accordingly
+!
+ DO K = J+1, N
+ A(INDX(I),K) = A(INDX(I),K)-PJ*A(INDX(J),K)
+ END DO
+ END DO
+ END DO
+!
+END SUBROUTINE ELGS
+
+end module atmh_advection
Copied: trunk/mpas/src/core_hyd_atmos/mpas_atmh_mpas_core.F (from rev 1113, branches/source_renaming/src/core_hyd_atmos/mpas_atmh_mpas_core.F)
===================================================================
--- trunk/mpas/src/core_hyd_atmos/mpas_atmh_mpas_core.F (rev 0)
+++ trunk/mpas/src/core_hyd_atmos/mpas_atmh_mpas_core.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -0,0 +1,302 @@
+module mpas_core
+
+ use mpas_framework
+ use mpas_timekeeping
+
+ type (io_output_object) :: restart_obj
+ integer :: restart_frame
+
+ integer :: current_outfile_frames
+
+ type (MPAS_Clock_type) :: clock
+
+ integer, parameter :: outputAlarmID = 1
+ integer, parameter :: restartAlarmID = 2
+
+
+ contains
+
+
+ subroutine mpas_core_init(domain, startTimeStamp)
+
+ use mpas_configure
+ use mpas_grid_types
+ use atmh_test_cases
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+ character(len=*), intent(out) :: startTimeStamp
+
+ real (kind=RKIND) :: dt
+ type (block_type), pointer :: block
+
+
+ if (.not. config_do_restart) call atmh_setup_test_case(domain)
+
+ !
+ ! Initialize core
+ !
+ dt = config_dt
+
+ call atmh_simulation_clock_init(domain, dt, startTimeStamp)
+
+ block => domain % blocklist
+ do while (associated(block))
+ call atmh_init_block(block, block % mesh, dt)
+ block % state % time_levs(1) % state % xtime % scalar = startTimeStamp
+ block => block % next
+ end do
+
+ restart_frame = 1
+ current_outfile_frames = 0
+
+ end subroutine mpas_core_init
+
+
+ subroutine mpas_core_run(domain, output_obj, output_frame)
+
+ use mpas_grid_types
+ use mpas_io_output
+ use mpas_timer
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+ type (io_output_object), intent(inout) :: output_obj
+ integer, intent(inout) :: output_frame
+
+ integer :: ntimesteps, itimestep
+ real (kind=RKIND) :: dt
+ type (block_type), pointer :: block_ptr
+
+ type (MPAS_Time_Type) :: currTime
+ character(len=32) :: timeStamp
+ integer :: ierr
+
+ ! Eventually, dt should be domain specific
+ dt = config_dt
+
+ currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr)
+ call mpas_get_time(curr_time=currTime, dateTimeString=timeStamp, ierr=ierr)
+ write(0,*) 'Initial time ', timeStamp
+
+ call atmh_write_output_frame(output_obj, output_frame, domain)
+
+ ! During integration, time level 1 stores the model state at the beginning of the
+ ! time step, and time level 2 stores the state advanced dt in time by timestep(...)
+ do while (.not. mpas_is_clock_stop_time(clock))
+
+ call mpas_advance_clock(clock)
+
+ currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr)
+ call mpas_get_time(curr_time=currTime, dateTimeString=timeStamp, ierr=ierr)
+ write(0,*) 'Doing timestep ', timeStamp
+
+ call mpas_timer_start("time integration")
+ call atmh_do_timestep(domain, dt, timeStamp)
+ call mpas_timer_stop("time integration")
+
+ ! Move time level 2 fields back into time level 1 for next time step
+ call mpas_shift_time_levels_state(domain % blocklist % state)
+
+ if (mpas_is_alarm_ringing(clock, outputAlarmID, ierr=ierr)) then
+ call mpas_reset_clock_alarm(clock, outputAlarmID, ierr=ierr)
+ if(output_frame == 1) call mpas_output_state_init(output_obj, domain, "OUTPUT", trim(timeStamp)) ! output_frame will always be > 1 here unless it is reset after the output file is finalized
+ call atmh_write_output_frame(output_obj, output_frame, domain)
+ end if
+
+ if (mpas_is_alarm_ringing(clock, restartAlarmID, ierr=ierr)) then
+ call mpas_reset_clock_alarm(clock, restartAlarmID, ierr=ierr)
+ if (restart_frame == 1) call mpas_output_state_init(restart_obj, domain, "RESTART")
+ call mpas_output_state_for_domain(restart_obj, domain, restart_frame)
+ restart_frame = restart_frame + 1
+ end if
+
+ end do
+
+ end subroutine mpas_core_run
+
+
+ subroutine mpas_core_finalize(domain)
+
+ use mpas_grid_types
+
+ implicit none
+
+ integer :: ierr
+
+ type (domain_type), intent(inout) :: domain
+
+ if (restart_frame > 1) call mpas_output_state_finalize(restart_obj, domain % dminfo)
+
+ call mpas_destroy_clock(clock, ierr)
+
+ end subroutine mpas_core_finalize
+
+
+ subroutine atmh_simulation_clock_init(domain, dt, startTimeStamp)
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+ real (kind=RKIND), intent(in) :: dt
+ character(len=*), intent(out) :: startTimeStamp
+
+ type (MPAS_Time_Type) :: startTime, stopTime, alarmStartTime
+ type (MPAS_TimeInterval_type) :: runDuration, timeStep, alarmTimeStep
+ integer :: ierr
+
+ call mpas_set_time(curr_time=startTime, dateTimeString=config_start_time, ierr=ierr)
+ call mpas_set_timeInterval(timeStep, dt=dt, ierr=ierr)
+
+ if (trim(config_run_duration) /= "none") then
+ call mpas_set_timeInterval(runDuration, timeString=config_run_duration, ierr=ierr)
+ call mpas_create_clock(clock, startTime=startTime, timeStep=timeStep, runDuration=runDuration, ierr=ierr)
+
+ if (trim(config_stop_time) /= "none") then
+ call mpas_set_time(curr_time=stopTime, dateTimeString=config_stop_time, ierr=ierr)
+ if(startTime + runduration /= stopTime) then
+ write(0,*) 'Warning: config_run_duration and config_stop_time are inconsitent: using config_run_duration.'
+ end if
+ end if
+ else if (trim(config_stop_time) /= "none") then
+ call mpas_set_time(curr_time=stopTime, dateTimeString=config_stop_time, ierr=ierr)
+ call mpas_create_clock(clock, startTime=startTime, timeStep=timeStep, stopTime=stopTime, ierr=ierr)
+ else
+ write(0,*) 'Error: Neither config_run_duration nor config_stop_time were specified.'
+ call mpas_dmpar_abort(domain % dminfo)
+ end if
+
+ ! set output alarm
+ call mpas_set_timeInterval(alarmTimeStep, timeString=config_output_interval, ierr=ierr)
+ alarmStartTime = startTime + alarmTimeStep
+ call mpas_add_clock_alarm(clock, outputAlarmID, alarmStartTime, alarmTimeStep, ierr=ierr)
+
+ ! set restart alarm, if necessary
+ if (trim(config_restart_interval) /= "none") then
+ call mpas_set_timeInterval(alarmTimeStep, timeString=config_restart_interval, ierr=ierr)
+ alarmStartTime = startTime + alarmTimeStep
+ call mpas_add_clock_alarm(clock, restartAlarmID, alarmStartTime, alarmTimeStep, ierr=ierr)
+ end if
+
+ call mpas_get_time(curr_time=startTime, dateTimeString=startTimeStamp, ierr=ierr)
+
+ end subroutine atmh_simulation_clock_init
+
+
+ subroutine atmh_init_block(block, mesh, dt)
+
+ use mpas_grid_types
+ use mpas_rbf_interpolation
+ use mpas_vector_reconstruction
+ use atmh_advection
+ use atmh_time_integration
+
+ implicit none
+
+ type (block_type), intent(inout) :: block
+ type (mesh_type), intent(inout) :: mesh
+ real (kind=RKIND), intent(in) :: dt
+
+
+ call atmh_compute_solver_constants(block % state % time_levs(1) % state, mesh)
+ call atmh_compute_state_diagnostics(block % state % time_levs(1) % state, mesh)
+ call atmh_compute_solve_diagnostics(dt, block % state % time_levs(1) % state, mesh)
+ call atmh_initialize_advection_rk(mesh)
+ call mpas_rbf_interp_initialize(mesh)
+ call mpas_init_reconstruct(mesh)
+ call mpas_reconstruct(mesh, block % state % time_levs(1) % state % u % array, &
+ block % diag % uReconstructX % array, &
+ block % diag % uReconstructY % array, &
+ block % diag % uReconstructZ % array, &
+ block % diag % uReconstructZonal % array, &
+ block % diag % uReconstructMeridional % array &
+ )
+
+
+ end subroutine atmh_init_block
+
+
+ subroutine atmh_write_output_frame(output_obj, output_frame, domain)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Compute diagnostic fields for a domain and write model state to output file
+ !
+ ! Input/Output: domain - contains model state; diagnostic field are computed
+ ! before returning
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ use mpas_grid_types
+ use mpas_io_output
+
+ implicit none
+
+ integer, intent(inout) :: output_frame
+ type (domain_type), intent(inout) :: domain
+ type (io_output_object), intent(inout) :: output_obj
+
+ integer :: i, j, k
+ integer :: eoe
+ type (block_type), pointer :: block_ptr
+
+ block_ptr => domain % blocklist
+ do while (associated(block_ptr))
+ call atmh_compute_output_diagnostics(block_ptr % state % time_levs(1) % state, block_ptr % mesh)
+ block_ptr => block_ptr % next
+ end do
+
+ call mpas_output_state_for_domain(output_obj, domain, output_frame)
+ output_frame = output_frame + 1
+
+ ! if the maximum number of frames per outfile has been reached, finalize outfile and reset frame
+ if (config_frames_per_outfile > 0) then
+ current_outfile_frames = current_outfile_frames + 1
+ if(current_outfile_frames >= config_frames_per_outfile) then
+ current_outfile_frames = 0
+ call mpas_output_state_finalize(output_obj, domain % dminfo)
+ output_frame = 1
+ end if
+ end if
+
+ end subroutine atmh_write_output_frame
+
+
+ subroutine atmh_compute_output_diagnostics(state, grid)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Compute diagnostic fields for a domain
+ !
+ ! Input: state - contains model prognostic fields
+ ! grid - contains grid metadata
+ !
+ ! Output: state - upon returning, diagnostic fields will have be computed
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ use mpas_grid_types
+
+ implicit none
+
+ type (state_type), intent(inout) :: state
+ type (mesh_type), intent(in) :: grid
+
+ integer :: i, eoe
+ integer :: iEdge, k
+
+ end subroutine atmh_compute_output_diagnostics
+
+
+ subroutine atmh_do_timestep(domain, dt, timeStamp)
+
+ use mpas_grid_types
+ use atmh_time_integration
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+ real (kind=RKIND), intent(in) :: dt
+ character(len=*), intent(in) :: timeStamp
+
+ call atmh_timestep(domain, dt, timeStamp)
+
+ end subroutine atmh_do_timestep
+
+end module mpas_core
Copied: trunk/mpas/src/core_hyd_atmos/mpas_atmh_test_cases.F (from rev 1113, branches/source_renaming/src/core_hyd_atmos/mpas_atmh_test_cases.F)
===================================================================
--- trunk/mpas/src/core_hyd_atmos/mpas_atmh_test_cases.F (rev 0)
+++ trunk/mpas/src/core_hyd_atmos/mpas_atmh_test_cases.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -0,0 +1,544 @@
+module atmh_test_cases
+
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_constants
+
+
+ contains
+
+
+ subroutine atmh_setup_test_case(domain)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Configure grid metadata and model state for the hydrostatic test case
+ ! specified in the namelist
+ !
+ ! Output: block - a subset (not necessarily proper) of the model domain to be
+ ! initialized
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+
+ integer :: i
+ type (block_type), pointer :: block_ptr
+
+ if (config_test_case == 0) then
+ write(0,*) ' need hydrostatic test case configuration, error stop '
+ stop
+
+ 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 atmh_test_case_1(block_ptr % mesh, block_ptr % state % time_levs(1) % state, config_test_case)
+ do i=2,nTimeLevs
+ call mpas_copy_state(block_ptr % state % time_levs(i) % state, block_ptr % state % time_levs(1) % state)
+ end do
+
+ block_ptr => block_ptr % next
+ end do
+
+ else
+ write(0,*) ' Only test case 1 and 2 are currently supported for hydrostatic core '
+ stop
+ end if
+
+ end subroutine atmh_setup_test_case
+
+!----------------------------------------------------------------------------------------------------------
+
+ subroutine atmh_test_case_1(grid, state, test_case)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Setup baroclinic wave test case from Jablonowski and Williamson 2008 (QJRMS)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (mesh_type), intent(inout) :: grid
+ type (state_type), intent(inout) :: state
+ integer, intent(in) :: test_case
+
+ real (kind=RKIND), parameter :: u0 = 35.0
+ real (kind=RKIND), parameter :: alpha_grid = 0. ! no grid rotation
+ real (kind=RKIND), parameter :: omega_e = 7.29212e-05
+ real (kind=RKIND), parameter :: t0 = 288., delta_t = 4.8e+05, dtdz = 0.005, eta_t = 0.2
+ real (kind=RKIND), parameter :: u_perturbation = 1., pert_radius = 0.1, latitude_pert = 40., longitude_pert = 20.
+ real (kind=RKIND), parameter :: theta_c = pii/4.0
+ real (kind=RKIND), parameter :: lambda_c = 3.0*pii/2.0
+ real (kind=RKIND), parameter :: rh_max = 0.4 ! Maximum relative humidity
+ real (kind=RKIND), parameter :: k_x = 9. ! Normal mode wave number
+
+ real (kind=RKIND), dimension(:), pointer :: rdnu, rdnw, fnm, fnp, dbn, dnu, dnw
+ real (kind=RKIND), dimension(:), pointer :: surface_pressure
+ real (kind=RKIND), dimension(:,:), pointer :: pressure, theta, alpha, geopotential, h
+ real (kind=RKIND), dimension(:,:,:), pointer :: scalars
+
+ integer :: iCell, iEdge, vtx1, vtx2, ivtx, k, nz, nz1, index_qv
+ 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
+ real (kind=RKIND), dimension(grid % nVertLevels + 1 ) :: znuc, znuv, bn, divh, dpn, teta
+
+ real (kind=RKIND) :: HYAI_CAM26(27), HYBI_CAM26(27), HYAM_CAM26(26), HYBM_CAM26(26)
+
+ logical, parameter :: cam26 = .true.
+
+ data hyai_cam26 / 0.002194067, 0.004895209, 0.009882418, 0.018052010, &
+ 0.029837240, 0.044623340, 0.061605870, 0.078512430, &
+ 0.077312710, 0.075901310, 0.074240860, 0.072287440, &
+ 0.069989330, 0.067285740, 0.064105090, 0.060363220, &
+ 0.055961110, 0.050782250, 0.044689600, 0.037521910, &
+ 0.029089490, 0.020847390, 0.013344430, 0.007084990, &
+ 0.002521360, 0.000000000, 0.000000000/, &
+ hybi_cam26 / 0.000000000, 0.000000000, 0.000000000, 0.000000000, &
+ 0.000000000, 0.000000000, 0.000000000, 0.000000000, &
+ 0.015053090, 0.032762280, 0.053596220, 0.078106270, &
+ 0.106941100, 0.140863700, 0.180772000, 0.227722000, &
+ 0.282956200, 0.347936400, 0.424382200, 0.514316800, &
+ 0.620120200, 0.723535500, 0.817676800, 0.896215300, &
+ 0.953476103, 0.985112200, 1.000000000/
+
+ !
+ ! Scale all distances and areas from a unit sphere to one with radius a
+ !
+ grid % xCell % array = grid % xCell % array * a
+ grid % yCell % array = grid % yCell % array * a
+ grid % zCell % array = grid % zCell % array * a
+ grid % xVertex % array = grid % xVertex % array * a
+ grid % yVertex % array = grid % yVertex % array * a
+ grid % zVertex % array = grid % zVertex % array * a
+ grid % xEdge % array = grid % xEdge % array * a
+ grid % yEdge % array = grid % yEdge % array * a
+ grid % zEdge % array = grid % zEdge % array * a
+ grid % dvEdge % array = grid % dvEdge % array * a
+ grid % dcEdge % array = grid % dcEdge % array * a
+ grid % areaCell % array = grid % areaCell % array * a**2.0
+ grid % areaTriangle % array = grid % areaTriangle % array * a**2.0
+ grid % kiteAreasOnVertex % array = grid % kiteAreasOnVertex % array * a**2.0
+
+ index_qv = state % index_qv
+
+ nz1 = grid % nVertLevels
+ nz = nz1 + 1
+
+ rdnu => grid % rdnu % array
+ rdnw => grid % rdnw % array
+ fnm => grid % fnm % array
+ fnp => grid % fnp % array
+ dbn => grid % dbn % array
+ dnu => grid % dnu % array
+ dnw => grid % dnw % array
+
+ surface_pressure => state % surface_pressure % array
+ pressure => state % pressure % array
+ theta => state % theta % array
+ alpha => state % alpha % array
+ geopotential => state % geopotential % array
+ h => state % h % array
+ scalars => state % scalars % array
+
+ 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.*p0-ptop)/(p0-ptop)
+
+ if (cam26) then
+
+ if (grid % nVertLevels /= 26 ) then
+ write(0,*) ' init is for 26 levels only, error stop '
+ stop
+ else
+ do k=1,nz
+ hyai(k) = hyai_cam26(k)
+ hybi(k) = hybi_cam26(k)
+ end do
+
+ write(0,*) ' initialization using cam 26 levels '
+
+ end if
+
+ ptop = hyai(1)*p0
+
+ do k=1,nz1
+ hyam(k) = .5*(hyai(k)+hyai(k+1))
+ hybm(k) = .5*(hybi(k)+hybi(k+1))
+ znuc(nz-k) = hyam(k) + hybm(k)
+ znwc(nz-k+1) = hyai(k) + hybi(k)
+ znu (nz-k ) = (znuc(nz-k )*p0-ptop)/(p0-ptop)
+ znw (nz-k+1) = (znwc(nz-k+1)*p0-ptop)/(p0-ptop)
+! znuv(nz-k ) = (znuc(nz-k )-.252)*pii/2.
+! znwv(nz-k+1) = (znwc(nz-k+1)-.252)*pii/2.
+ bn(k+1) = hybi(nz-k)
+ end do
+
+ else ! analytic profile
+
+ ptop = 219.4067
+ znw(1) = 1.
+
+ do k=1,nz1
+
+ ! eta profile (constant deta for exp=1,)
+
+ znw(k+1) = (1.-float(k)/float(nz1))**2.
+
+ ! profile for tranisition from sigma to presure coordinate
+ ! bn(k)=znw(k) for sigma coord, bn(k)=0 for p coord
+ ! bn(1)=1, bn(nz)=0 must be satisfied
+
+ bn(k+1) = znw(k+1)*sin(.5*pii*znw(k+1))**2
+ !! bn(k+1) = znw(k+1)
+
+ znu (k) = .5*(znw(k)+znw(k+1))
+ znuc(k) = (znu(k )*(p0-ptop)+ptop)/p0
+ znwc(k+1) = (znw(k+1)*(p0-ptop)+ptop)/p0
+ end do
+
+ end if ! cam or analytic grid-level profile
+
+ !
+ ! metrics for vertical stretching
+ !
+
+ 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.*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))
+ dpn (k) = 0.
+ divh(k) = 0.
+ write (6,*) k,znw(k),dnw(k),bn(k),dbn(k)
+ end do
+
+ dpn(nz)=0.
+ fnm(1) = 0.
+ fnp(1) = 0.
+ do k=2,nz1
+ dnu (k) = .5*(dnw(k)+dnw(k-1))
+ rdnu(k) = 1./dnu(k)
+ fnp (k) = .5* dnw(k )/dnu(k)
+ fnm (k) = .5* dnw(k-1)/dnu(k)
+ end do
+
+ !
+ ! Initialize wind field
+ !
+
+ lat_pert = latitude_pert*pii/180.
+ lon_pert = longitude_pert*pii/180.
+
+ do iEdge=1,grid % nEdges
+
+ vtx1 = grid % VerticesOnEdge % array (1,iEdge)
+ vtx2 = grid % VerticesOnEdge % array (2,iEdge)
+ lat1 = grid%latVertex%array(vtx1)
+ lat2 = grid%latVertex%array(vtx2)
+ flux = (0.5*(lat2-lat1) - 0.125*(sin(4.*lat2) - sin(4.*lat1)))*a/grid % dvEdge % array(iEdge)
+
+ if (config_test_case == 2) then
+ r_pert = sphere_distance( grid % latEdge % array (iEdge), grid % lonEdge % array (iEdge), &
+ lat_pert, lon_pert, 1.)/(pert_radius)
+ u_pert = u_perturbation*exp(-r_pert**2)*(lat2-lat1)*a/grid % dvEdge % array(iEdge)
+
+ else if (config_test_case == 3) then
+ lon_Edge = grid % lonEdge % array(iEdge)
+ u_pert = u_perturbation*cos(k_x*(lon_Edge - lon_pert)) &
+ *(0.5*(lat2-lat1) - 0.125*(sin(4.*lat2) - sin(4.*lat1)))*a/grid % dvEdge % array(iEdge)
+ else
+ u_pert = 0.0
+ end if
+
+
+ do k=1,grid % nVertLevels
+ fluxk = u0*flux*(cos(znuv(k))**(1.5))
+ state % u % array(k,iEdge) = fluxk + u_pert
+ end do
+
+ !
+ ! Generate rotated Coriolis field
+ !
+
+ grid % fEdge % array(iEdge) = 2.0 * omega * &
+ ( -cos(grid%lonEdge%array(iEdge)) * cos(grid%latEdge%array(iEdge)) * sin(alpha_grid) + &
+ sin(grid%latEdge%array(iEdge)) * cos(alpha_grid) &
+ )
+ end do
+
+ do iVtx=1,grid % nVertices
+ grid % fVertex % array(iVtx) = 2.0 * omega * &
+ (-cos(grid%lonVertex%array(iVtx)) * cos(grid%latVertex%array(iVtx)) * sin(alpha_grid) + &
+ sin(grid%latVertex%array(iVtx)) * cos(alpha_grid) &
+ )
+ end do
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! 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
+
+ phi = grid % latCell % array (iCell)
+
+ surface_pressure(iCell) = p0
+
+ do k=1,nz1
+ h(k,iCell) = (1.-dbn(k))*(p0-ptop)+dbn(k)*(surface_pressure(iCell)-ptop)
+ end do
+
+ pressure(nz,iCell) = ptop
+ do k=nz1,1,-1
+ pressure(k,iCell) = pressure(k+1,iCell)-dnw(k)*h(k,iCell)
+ end do
+
+ do k=1,nz1
+ 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.) &
+ *2.*u0*cos(znuv(k))**1.5 &
+ +(1.6*cos(phi)**3 &
+ *(sin(phi)**2+2./3.)-pii/4.)*a*omega)
+
+ theta (k,iCell) = theta(k,iCell)* &
+ (0.5*(pressure(k,iCell)+pressure(k+1,iCell))/p0)**(-rgas/cp)
+ alpha(k,iCell) = ((rgas/p0)*theta(k,iCell)* &
+ (0.5*(pressure(k,iCell)+pressure(k+1,iCell))/p0)**cvpm)
+
+ end do
+ end do
+!
+! initialization for geopotential
+!
+ do iCell=1,grid % nCells
+
+ phi = grid % latCell % array (iCell)
+
+ geopotential(1,iCell) = u0*cos(znwv(1))**1.5* &
+ ((-2.*sin(phi)**6 &
+ *(cos(phi)**2+1./3.)+10./63.) &
+ *(u0)*cos(znwv(1))**1.5 &
+ +(1.6*cos(phi)**3 &
+ *(sin(phi)**2+2./3.)-pii/4.)*a*omega)
+ do k=1,nz1
+ geopotential(k+1,iCell) = geopotential(k,iCell)-dnw(k)*h(k,iCell)*alpha(k,iCell)
+ 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 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)
+ end do
+
+! When initializing a scalar, be sure not to put unreasonably large values
+! into indices in the moist class
+! scalars(2,:,:) = 1. ! transport test
+! scalars(2,:,:) = theta ! transport test
+! if (num_scalars >= 2) then
+! scalars(2,:,:) = 0.0
+! do iCell=1,grid%nCells
+! r = sphere_distance(theta_c, lambda_c, grid % latCell % array(iCell), grid % lonCell % array(iCell), a)
+! if (r < a/3.0) then
+! do k=1,grid%nVertLevels
+! scalars(2,k,iCell) = (1.0 / 2.0) * (1.0 + cos(pii*r*3.0/a))
+! end do
+! end if
+! end do
+! end if
+! if (num_scalars >= 3) scalars(3,:,:) = theta + 100. ! transport test
+! if (num_scalars >= 4) scalars(4,:,:) = theta + 200. ! transport test
+! if (num_scalars >= 5) scalars(5,:,:) = theta + 300. ! transport test
+
+ end subroutine atmh_test_case_1
+
+
+ real function sphere_distance(lat1, lon1, lat2, lon2, radius)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Compute the great-circle distance between (lat1, lon1) and (lat2, lon2) on a
+ ! sphere with given radius.
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ real (kind=RKIND), intent(in) :: lat1, lon1, lat2, lon2, radius
+
+ real (kind=RKIND) :: arg1
+
+ arg1 = sqrt( sin(0.5*(lat2-lat1))**2 + &
+ cos(lat1)*cos(lat2)*sin(0.5*(lon2-lon1))**2 )
+ sphere_distance = 2.*radius*asin(arg1)
+
+ end function sphere_distance
+
+
+ real function AA(theta)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! A, used in height field computation for Rossby-Haurwitz wave
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ real (kind=RKIND), parameter :: w = 7.848e-6
+ real (kind=RKIND), parameter :: K = 7.848e-6
+ real (kind=RKIND), parameter :: R = 4.0
+
+ real (kind=RKIND), intent(in) :: theta
+
+ AA = 0.5 * w * (2.0 * omega + w) * cos(theta)**2.0 + &
+ 0.25 * K**2.0 * cos(theta)**(2.0*R) * ((R+1.0)*cos(theta)**2.0 + 2.0*R**2.0 - R - 2.0 - 2.0*(R*cos(theta))**2.0)
+
+ end function AA
+
+
+ real function BB(theta)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! B, used in height field computation for Rossby-Haurwitz wave
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ real (kind=RKIND), parameter :: w = 7.848e-6
+ real (kind=RKIND), parameter :: K = 7.848e-6
+ real (kind=RKIND), parameter :: R = 4.0
+
+ real (kind=RKIND), intent(in) :: theta
+
+ BB = (2.0*(omega + w)*K / ((R+1.0)*(R+2.0))) * cos(theta)**R * ((R**2.0 + 2.0*R + 2.0) - ((R+1.0)*cos(theta))**2.0)
+
+ end function BB
+
+
+ real function CC(theta)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! C, used in height field computation for Rossby-Haurwitz wave
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ real (kind=RKIND), parameter :: w = 7.848e-6
+ real (kind=RKIND), parameter :: K = 7.848e-6
+ real (kind=RKIND), parameter :: R = 4.0
+
+ real (kind=RKIND), intent(in) :: theta
+
+ CC = 0.25 * K**2.0 * cos(theta)**(2.0*R) * ((R+1.0)*cos(theta)**2.0 - R - 2.0)
+
+ end function CC
+
+end module atmh_test_cases
Copied: trunk/mpas/src/core_hyd_atmos/mpas_atmh_time_integration.F (from rev 1113, branches/source_renaming/src/core_hyd_atmos/mpas_atmh_time_integration.F)
===================================================================
--- trunk/mpas/src/core_hyd_atmos/mpas_atmh_time_integration.F (rev 0)
+++ trunk/mpas/src/core_hyd_atmos/mpas_atmh_time_integration.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -0,0 +1,2122 @@
+module atmh_time_integration
+
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_constants
+ use mpas_dmpar
+ use mpas_vector_reconstruction
+
+
+ contains
+
+
+ subroutine atmh_timestep(domain, dt, timeStamp)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Advance model state forward in time by the specified time step
+ !
+ ! Input: domain - current model state in time level 1 (e.g., time_levs(1)state%h(:,:))
+ ! plus grid meta-data
+ ! Output: domain - upon exit, time level 2 (e.g., time_levs(2)%state%h(:,:)) contains
+ ! model state advanced forward in time by dt seconds
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+ real (kind=RKIND), intent(in) :: dt
+ character(len=*), intent(in) :: timeStamp
+
+ type (block_type), pointer :: block
+
+ if (trim(config_time_integration) == 'SRK3') then
+ call atmh_srk3(domain, dt)
+ else
+ write(0,*) 'Unknown time integration option '//trim(config_time_integration)
+ write(0,*) 'Currently, only ''SRK3'' is supported.'
+ stop
+ end if
+
+ block => domain % blocklist
+ do while (associated(block))
+ block % state % time_levs(2) % state % xtime % scalar = timeStamp
+ block => block % next
+ end do
+
+ end subroutine atmh_timestep
+
+
+ subroutine atmh_srk3(domain, dt)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Advance model state forward in time by the specified time step using
+ ! time-split RK3 scheme
+ !
+ ! Hydrostatic (primitive eqns.) solver
+ !
+ ! Input: domain - current model state in time level 1 (e.g., time_levs(1)state%h(:,:))
+ ! plus grid meta-data
+ ! Output: domain - upon exit, time level 2 (e.g., time_levs(2)%state%h(:,:)) contains
+ ! model state advanced forward in time by dt seconds
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+ real (kind=RKIND), intent(in) :: dt
+
+ integer :: iCell, k
+ type (block_type), pointer :: block
+
+ integer, parameter :: TEND = 1
+ integer :: rk_step, number_of_sub_steps
+
+ real (kind=RKIND), dimension(3) :: rk_timestep, rk_sub_timestep
+ integer, dimension(3) :: number_sub_steps
+ integer :: small_step
+ logical, parameter :: debug = .false.
+ logical, parameter :: debug_mass_conservation = .true.
+
+ real (kind=RKIND) :: domain_mass, scalar_mass, scalar_min, scalar_max
+ real (kind=RKIND) :: global_domain_mass, global_scalar_mass, global_scalar_min, global_scalar_max
+
+ !
+ ! Initialize time_levs(2) with state at current time
+ ! Initialize RK weights
+ !
+
+ number_of_sub_steps = config_number_of_sub_steps
+
+ rk_timestep(1) = dt/3.
+ rk_timestep(2) = dt/2.
+ rk_timestep(3) = dt
+
+ rk_sub_timestep(1) = dt/3.
+ rk_sub_timestep(2) = dt/real(number_of_sub_steps)
+ rk_sub_timestep(3) = dt/real(number_of_sub_steps)
+
+ number_sub_steps(1) = 1
+ number_sub_steps(2) = number_of_sub_steps/2
+ number_sub_steps(3) = number_of_sub_steps
+
+ if(debug) write(0,*) ' copy step in rk solver '
+
+ block => domain % blocklist
+ do while (associated(block))
+ call mpas_copy_state( block % state % time_levs(2) % state, block % state % time_levs(1) % state )
+ block => block % next
+ end do
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! BEGIN RK loop
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+ do rk_step = 1, 3
+
+ if(debug) write(0,*) ' rk substep ', rk_step
+
+ block => domain % blocklist
+ do while (associated(block))
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % mesh % qtot % array(:,:), &
+ block % mesh % nVertLevels, block % mesh % nCells, &
+ block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % mesh % cqu % array(:,:), &
+ block % mesh % nVertLevels, block % mesh % nEdges, &
+ block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % h % array(:,:), &
+ block % mesh % nVertLevels, block % mesh % nCells, &
+ block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % pressure % array(:,:), &
+ block % mesh % nVertLevels+1, block % mesh % nCells, &
+ block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % geopotential % array(:,:), &
+ block % mesh % nVertLevels+1, block % mesh % nCells, &
+ block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % alpha % array(:,:), &
+ block % mesh % nVertLevels, block % mesh % nCells, &
+ block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % pv_edge % array(:,:), &
+ block % mesh % nVertLevels, block % mesh % nEdges, &
+ block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
+ if (config_h_mom_eddy_visc4 > 0.0) then
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % divergence % array(:,:), &
+ block % mesh % nVertLevels, block % mesh % nCells, &
+ block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % vorticity % array(:,:), &
+ block % mesh % nVertLevels, block % mesh % nVertices, &
+ block % parinfo % verticesToSend, block % parinfo % verticesToRecv)
+ end if
+ block => block % next
+ end do
+
+ if(debug) write(0,*) ' rk substep ', rk_step
+
+ block => domain % blocklist
+ do while (associated(block))
+ call atmh_compute_dyn_tend( block % tend, block % state % time_levs(2) % state, block % mesh )
+ block => block % next
+ end do
+
+ if(debug) write(0,*) ' returned from dyn_tend '
+
+ !
+ ! --- update halos for tendencies
+ !
+ block => domain % blocklist
+ do while (associated(block))
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % tend % u % array(:,:), &
+ block % mesh % nVertLevels, block % mesh % nEdges, &
+ block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % tend % theta % array(:,:), &
+ block % mesh % nVertLevels, block % mesh % nCells, &
+ block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ block => block % next
+ end do
+
+
+ ! --- advance over sub_steps
+
+ block => domain % blocklist
+ do while (associated(block))
+ !
+ ! Note: Scalars in new time level shouldn't be overwritten, since their provisional values
+ ! from the previous RK step are needed to compute new scalar tendencies in advance_scalars.
+ ! A cleaner way of preserving scalars should be added in future.
+ !
+ block % mesh % scalars_old % array(:,:,:) = block % state % time_levs(2) % state % scalars % array(:,:,:)
+ call mpas_copy_state( block % state % time_levs(2) % state, block % state % time_levs(1) % state )
+ block % state % time_levs(2) % state % scalars % array(:,:,:) = block % mesh % scalars_old % array(:,:,:)
+ block => block % next
+ end do
+
+ if(debug) write(0,*) ' returned from copy_state '
+
+ do small_step = 1, number_sub_steps(rk_step)
+
+ if(debug) write(0,*) ' small step ',small_step
+
+ block => domain % blocklist
+ do while (associated(block))
+ call atmh_advance_dynamics( block % tend, block % state % time_levs(2) % state, &
+ block % mesh, &
+ small_step, number_sub_steps(rk_step), rk_sub_timestep(rk_step) )
+ block => block % next
+ end do
+
+ if(debug) write(0,*) ' dynamics advance complete '
+
+ ! will need communications here?
+ !
+ ! --- update halos for prognostic variables
+ !
+ block => domain % blocklist
+ do while (associated(block))
+!! call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % u % array(:,:), &
+!! block % mesh % nVertLevels, block % mesh % nEdges, &
+!! block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % h_edge % array(:,:), &
+ block % mesh % nVertLevels, block % mesh % nEdges, &
+ block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
+!! call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % mesh % uhAvg % array(:,:), &
+!! block % mesh % nVertLevels, block % mesh % nEdges, &
+!! block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
+!! call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % mesh % wwAvg % array(:,:), &
+!! block % mesh % nVertLevels+1, block % mesh % nCells, &
+!! block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % theta % array(:,:), &
+ block % mesh % nVertLevels, block % mesh % nCells, &
+ block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+!! call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % h % array(:,:), &
+!! block % mesh % nVertLevels, block % mesh % nCells, &
+!! block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+!! call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % tend % h % array(:,:), &
+!! block % mesh % nVertLevels, block % mesh % nCells, &
+!! block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ call mpas_dmpar_exch_halo_field1d_real(domain % dminfo, block % mesh % dpsdt % array(:), &
+ block % mesh % nCells, &
+ block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ call mpas_dmpar_exch_halo_field1d_real(domain % dminfo, block % state % time_levs(2) % state % surface_pressure % array(:), &
+ block % mesh % nCells, &
+ block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % alpha % array(:,:), &
+ block % mesh % nVertLevels, block % mesh % nCells, &
+ block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % ww % array(:,:), &
+ block % mesh % nVertLevels+1, block % mesh % nCells, &
+ block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % pressure % array(:,:), &
+ block % mesh % nVertLevels+1, block % mesh % nCells, &
+ block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+!! call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % mesh % pressure_old % array(:,:), &
+!! block % mesh % nVertLevels+1, block % mesh % nCells, &
+!! block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % geopotential % array(:,:), &
+ block % mesh % nVertLevels+1, block % mesh % nCells, &
+ block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ block => block % next
+ end do
+
+ end do
+
+ if(debug) write(0,*) ' advance scalars '
+
+
+ ! --- advance scalars with time integrated mass fluxes
+
+ block => domain % blocklist
+ do while (associated(block))
+ !
+ ! Note: The advance_scalars_mono routine can be used without limiting, and thus, encompasses
+ ! the functionality of the advance_scalars routine; however, it is noticeably slower,
+ ! so we keep the advance_scalars routine as well
+ !
+ if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then
+ call atmh_advance_scalars( block % tend, &
+ block % state % time_levs(1) % state, block % state % time_levs(2) % state, &
+ block % mesh, rk_timestep(rk_step) )
+ else
+ call atmh_advance_scalars_mono( block % tend, &
+ block % state % time_levs(1) % state, block % state % time_levs(2) % state, &
+ block % mesh, rk_timestep(rk_step), rk_step, 3, &
+ domain % dminfo, block % parinfo % cellsToSend, block % parinfo % cellsToRecv )
+ end if
+ block => block % next
+ end do
+
+ block => domain % blocklist
+ do while (associated(block))
+ call mpas_dmpar_exch_halo_field3d_real(domain % dminfo, block % tend % scalars % array(:,:,:), &
+ block % tend % num_scalars, block % mesh % nVertLevels, block % mesh % nCells, &
+ block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ call mpas_dmpar_exch_halo_field3d_real(domain % dminfo, block % state % time_levs(2) % state % scalars % array(:,:,:), &
+ block % tend % num_scalars, block % mesh % nVertLevels, block % mesh % nCells, &
+ block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ block => block % next
+ end do
+
+
+ if(debug) write(0,*) ' advance scalars complete '
+
+ ! --- compute some diagnostic quantities for the next timestep
+
+ block => domain % blocklist
+ do while (associated(block))
+ call atmh_compute_solver_constants( block % state % time_levs(2) % state, block % mesh )
+ call atmh_compute_state_diagnostics( block % state % time_levs(2) % state, block % mesh )
+ call atmh_compute_solve_diagnostics( dt, block % state % time_levs(2) % state, block % mesh )
+ block => block % next
+ end do
+
+ if(debug) write(0,*) ' diagnostics complete '
+
+
+ ! might need communications here *****************************
+
+ end do
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! END RK loop
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ !
+ ! Compute full velocity vectors at cell centers, and compute vertical velocity diagnostic
+ !
+ block => domain % blocklist
+ do while (associated(block))
+ call mpas_reconstruct(block % mesh, block % state % time_levs(2) % state % u % array, &
+ block % diag % uReconstructX % array, &
+ block % diag % uReconstructY % array, &
+ block % diag % uReconstructZ % array, &
+ block % diag % uReconstructZonal % array, &
+ block % diag % uReconstructMeridional % array &
+ )
+
+ call atmh_compute_w(block % state % time_levs(2) % state, block % state % 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
+ domain_mass = 0.
+ scalar_mass = 0.
+ block => domain % blocklist
+ scalar_min = block % state % time_levs(2) % state % scalars % array (2,1,1)
+ scalar_max = block % state % time_levs(2) % state % scalars % array (2,1,1)
+ do while(associated(block))
+ do iCell = 1, block % mesh % nCellsSolve
+ domain_mass = domain_mass + block % state % time_levs(2) % state % surface_pressure % array (iCell) * &
+ block % mesh % areaCell % array (iCell) &
+ - block % state % time_levs(2) % state % pressure % array (block % mesh % nVertLevels + 1, 1) * &
+ block % mesh % areaCell % array (iCell)
+ do k=1, block % mesh % nVertLevelsSolve
+ scalar_mass = scalar_mass - block % state % time_levs(2) % state % scalars % array (2,k,iCell) * &
+ block % state % time_levs(2) % state % h % array (k,iCell) * &
+ block % mesh % dnw % array (k) * &
+ block % mesh % areaCell % array (iCell)
+ scalar_min = min(scalar_min,block % state % time_levs(2) % state % scalars % array (2,k,iCell))
+ scalar_max = max(scalar_max,block % state % time_levs(2) % state % scalars % array (2,k,iCell))
+ end do
+ end do
+ block => block % next
+ end do
+ call mpas_dmpar_sum_real(domain % dminfo, domain_mass, global_domain_mass)
+ call mpas_dmpar_sum_real(domain % dminfo, scalar_mass, global_scalar_mass)
+ call mpas_dmpar_min_real(domain % dminfo, scalar_min, global_scalar_min)
+ call mpas_dmpar_max_real(domain % dminfo, scalar_max, global_scalar_max)
+ write(0,*) ' mass in the domain = ',global_domain_mass
+ write(0,*) ' scalar mass in the domain = ',global_scalar_mass
+ write(0,*) ' scalar_min, scalar_max ',global_scalar_min, global_scalar_max
+ end if
+
+
+ end subroutine atmh_srk3
+
+!------------------------------------------------------------------------------------------------------------------
+
+ subroutine atmh_compute_solver_constants(s, grid)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Compute height and normal wind tendencies, as well as diagnostic variables
+ !
+ ! Input: s - current model state
+ ! grid - grid metadata
+ !
+ ! Output: tend - computed diagnostics (parallel velocities, v; mass fluxes, vh;
+ ! circulation; vorticity; and kinetic energy, ke) and the
+ ! tendencies for height (h) and u (u)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (state_type), intent(in) :: s
+ type (mesh_type), intent(inout) :: grid
+
+ integer :: iEdge, iCell, k, cell1, cell2, iq
+
+ integer :: nCells, nEdges, nVertLevels
+
+ nCells = grid % nCells
+ nEdges = grid % nEdges
+ nVertLevels = grid % nVertLevels
+
+ grid % qtot % array = 0.
+ grid % cqu % array = 1.
+
+ if (s % num_scalars > 0) then
+
+ do iCell = 1, nCells
+ do k = 1, nVertLevels
+ do iq = s % moist_start, s % moist_end
+ grid % qtot % array(k,iCell) = grid % qtot % array(k,iCell) + s % scalars % array (iq, k, iCell)
+ end do
+ end do
+ end do
+
+ do iEdge = 1, nEdges
+ do k = 1, nVertLevels
+ cell1 = grid % cellsOnEdge % array(1,iEdge)
+ cell2 = grid % cellsOnEdge % array(2,iEdge)
+ grid % cqu % array(k,iEdge) = 1./( 1. + 0.5*(grid % qtot % array(k,cell1)+grid % qtot % array(k,cell2)) )
+ end do
+ end do
+
+ end if
+
+ end subroutine atmh_compute_solver_constants
+
+!------------------------------------------------------------------------------------------------------------------
+
+ subroutine atmh_compute_state_diagnostics(s, grid)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Compute diagnostic variables
+ !
+ ! Input: s - current model state
+ ! grid - grid metadata
+ !
+ ! Output: tend - computed diagnostics (parallel velocities, v; mass fluxes, vh;
+ ! circulation; vorticity; and kinetic energy, ke) and the
+ ! tendencies for height (h) and u (u)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (state_type), intent(inout) :: s
+ type (mesh_type), intent(inout) :: grid
+
+ real (kind=RKIND), dimension(:,:,:), pointer :: scalar
+ real (kind=RKIND), dimension(:,:), pointer :: h, pressure, qtot, alpha, geopotential, theta
+ real (kind=RKIND), dimension(:,:), pointer :: theta_old, ww_old, u_old, u, ww, h_edge_old, h_edge, h_old
+ real (kind=RKIND), dimension(:), pointer :: surface_pressure, dbn, dnu, dnw
+
+ integer :: iEdge, iCell, k, cell1, cell2, iq
+ integer :: nCells, nEdges, nVertLevels
+
+ real (kind=RKIND) :: p0,tm,ptop,ptmp
+
+ h => s % h % array
+ theta => s % theta % array
+ pressure => s % pressure % array
+ qtot => grid % qtot % array
+ surface_pressure => s % surface_pressure % array
+ alpha => s % alpha % array
+ geopotential => s % geopotential % array
+ scalar => s % scalars % array
+ theta_old => grid % theta_old % array
+ u_old => grid % u_old % array
+ ww_old => grid % ww_old % array
+ h_old => grid % h_old % array
+ h_edge_old => grid % h_edge_old % array
+ h_edge => s % h_edge % array
+ u => s % u % array
+ ww => s % ww % array
+
+ dbn => grid % dbn % array
+ dnu => grid % dnu % array
+ dnw => grid % dnw % array
+
+ nCells = grid % nCells
+ nEdges = grid % nEdges
+ nVertLevels = grid % nVertLevels
+
+
+
+! ptop = grid % ptop
+! p0 = grid % p0
+! ptop = 219.4067
+ p0 = 1e+05
+ ptop = pressure(nVertLevels+1,1)
+
+! write(0,*) ' ptop in compute_state_diagnostics ',ptop
+
+!*****************************
+
+ do iCell = 1, nCells
+ do k=1,nVertLevels
+ h(k,iCell) = (1.-dbn(k))*(p0-ptop)+dbn(k)*(surface_pressure(iCell)-ptop)
+ end do
+
+ do k = nVertLevels, 1, -1
+ pressure(k,iCell) = pressure(k+1,iCell) - dnw(k)*(1.+qtot(k,iCell))*h(k,iCell)
+ end do
+
+ do k=1, nVertLevels
+ ! note that theta is not coupled here
+ tm = (1.+1.61*scalar(1,k,iCell))*theta(k,iCell) ! assume scalar(1) is qv here?
+ alpha(k,iCell) = (rgas/p0)*tm*(0.5*(pressure(k+1,iCell)+pressure(k,iCell))/p0)**cvpm
+ geopotential(k+1,iCell) = geopotential(k,iCell) - dnw(k)*h(k,iCell)*alpha(k,iCell)
+ end do
+ end do
+
+ theta_old(:,:) = theta(:,:)
+ ww_old(:,:) = ww(:,:)
+ u_old(:,:) = u(:,:)
+ h_edge_old(:,:) = h_edge(:,:)
+ h_old(:,:) = h(:,:)
+
+ end subroutine atmh_compute_state_diagnostics
+
+!------------------------------------------------------------------------------------------
+
+ subroutine atmh_compute_dyn_tend(tend, s, grid)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Compute height and normal wind tendencies, as well as diagnostic variables
+ !
+ ! Input: s - current model state
+ ! grid - grid metadata
+ !
+ ! Output: tend - computed diagnostics (parallel velocities, v; mass fluxes, vh;
+ ! circulation; vorticity; and kinetic energy, ke) and the
+ ! tendencies for height (h) and u (u)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (tend_type), intent(inout) :: tend
+ type (state_type), intent(in) :: s
+ type (mesh_type), intent(in) :: grid
+
+ integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j
+ real (kind=RKIND) :: flux, vorticity_abs, h_vertex, workpv, q, upstream_bias
+
+ integer :: nCells, nEdges, nVertices, nVertLevels
+ real (kind=RKIND) :: h_mom_eddy_visc2, v_mom_eddy_visc2, h_mom_eddy_visc4
+ real (kind=RKIND) :: h_theta_eddy_visc2, v_theta_eddy_visc2, h_theta_eddy_visc4
+ real (kind=RKIND) :: u_diffusion
+ real (kind=RKIND), dimension(:), pointer :: h_s, fVertex, fEdge, dvEdge, dcEdge, areaCell, areaTriangle, p_s
+ real (kind=RKIND), dimension(:,:), pointer :: vh, weightsOnEdge, kiteAreasOnVertex, h_edge, h, u, v, tend_h, tend_u, &
+ circulation, divergence, vorticity, ke, pv_edge, geopotential, theta, ww, &
+ h_diabatic, tend_theta
+ real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
+ integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnVertex, verticesOnEdge, edgesOnCell, edgesOnEdge, edgesOnVertex
+ integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge
+
+ real (kind=RKIND), dimension( grid % nVertLevels + 1 ) :: wdtn, wdun
+ real (kind=RKIND) :: theta_edge, theta_turb_flux, z1, z2, z3, z4, zm, z0, zp, r
+ real (kind=RKIND) :: d2fdx2_cell1, d2fdx2_cell2
+
+ real (kind=RKIND), dimension(:), pointer :: rdnu, rdnw, fnm, fnp
+
+ real (kind=RKIND), allocatable, dimension(:,:) :: delsq_theta, delsq_divergence
+ real (kind=RKIND), allocatable, dimension(:,:) :: delsq_u
+ real (kind=RKIND), allocatable, dimension(:,:) :: delsq_circulation, delsq_vorticity
+
+ h => s % h % array
+ u => s % u % array
+ h_edge => s % h_edge % array
+ circulation => s % circulation % array
+ divergence => s % divergence % array
+ vorticity => s % vorticity % array
+ ke => s % ke % array
+ pv_edge => s % pv_edge % array
+ geopotential => s % geopotential % array
+ theta => s % theta % array
+
+ weightsOnEdge => grid % weightsOnEdge % array
+ cellsOnEdge => grid % cellsOnEdge % array
+ verticesOnEdge => grid % verticesOnEdge % array
+ nEdgesOnEdge => grid % nEdgesOnEdge % array
+ edgesOnEdge => grid % edgesOnEdge % array
+ dcEdge => grid % dcEdge % array
+ dvEdge => grid % dvEdge % array
+ areaCell => grid % areaCell % array
+ areaTriangle => grid % areaTriangle % array
+ fEdge => grid % fEdge % array
+ deriv_two => grid % deriv_two % array
+
+ vh => tend % vh % array
+ tend_u => tend % u % array
+ tend_theta => tend % theta % array
+ h_diabatic => grid % h_diabatic % array
+
+ ww => s % ww % array
+ rdnu => grid % rdnu % array
+ rdnw => grid % rdnw % array
+ fnm => grid % fnm % array
+ fnp => grid % fnp % array
+
+ nCells = grid % nCells
+ nEdges = grid % nEdges
+ nVertLevels = grid % nVertLevels
+ nVertices = grid % nVertices
+
+ h_mom_eddy_visc2 = config_h_mom_eddy_visc2
+ h_mom_eddy_visc4 = config_h_mom_eddy_visc4
+ v_mom_eddy_visc2 = config_v_mom_eddy_visc2
+ h_theta_eddy_visc2 = config_h_theta_eddy_visc2
+ h_theta_eddy_visc4 = config_h_theta_eddy_visc4
+ v_theta_eddy_visc2 = config_v_theta_eddy_visc2
+
+
+ !
+ ! Compute u (normal) velocity tendency for each edge (cell face)
+ !
+
+ tend_u(:,:) = 0.0
+
+#ifdef LANL_FORMULATION
+ do iEdge=1,grid % nEdgesSolve
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+
+ do k=1,nVertLevels
+ q = 0.0
+ do j = 1,nEdgesOnEdge(iEdge)
+ eoe = edgesOnEdge(j,iEdge)
+ workpv = 0.5 * (pv_edge(k,iEdge) + pv_edge(k,eoe))
+ q = q + weightsOnEdge(j,iEdge) * u(k,eoe) * workpv * h_edge(k,eoe)
+ end do
+ tend_u(k,iEdge) = q - (ke(k,cell2) - ke(k,cell1)) / dcEdge(iEdge)
+ end do
+ end do
+
+#endif
+
+#ifdef NCAR_FORMULATION
+ !
+ ! Compute mass fluxes tangential to each edge (i.e., through the faces of dual grid cells)
+ !
+ vh(:,:) = 0.0
+ do iEdge=1,grid % nEdgesSolve
+ do j=1,nEdgesOnEdge(iEdge)
+ eoe = edgesOnEdge(j,iEdge)
+ do k=1,nVertLevels
+ vh(k,iEdge) = vh(k,iEdge) + weightsOnEdge(j,iEdge) * u(k,eoe) * h_edge(k,eoe)
+ end do
+ end do
+ end do
+
+ do iEdge=1,grid % nEdgesSolve
+ vertex1 = verticesOnEdge(1,iEdge)
+ vertex2 = verticesOnEdge(2,iEdge)
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+
+ do k=1,nVertLevels
+ vorticity_abs = fEdge(iEdge) + (circulation(k,vertex1) + circulation(k,vertex2)) / &
+ (areaTriangle(vertex1) + areaTriangle(vertex2))
+
+ workpv = 2.0 * vorticity_abs / (h(k,cell1) + h(k,cell2))
+
+ tend_u(k,iEdge) = workpv * vh(k,iEdge) - (ke(k,cell2) - ke(k,cell1)) / dcEdge(iEdge)
+ end do
+ end do
+#endif
+
+
+ !
+ ! horizontal mixing for u
+ !
+ if ( h_mom_eddy_visc2 > 0.0 ) then
+ do iEdge=1,grid % nEdgesSolve
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ vertex1 = verticesOnEdge(1,iEdge)
+ vertex2 = verticesOnEdge(2,iEdge)
+
+ do k=1,nVertLevels
+
+ !
+ ! Compute diffusion, computed as </font>
<font color="black">abla divergence - k \times </font>
<font color="blue">abla vorticity
+ ! only valid for h_mom_eddy_visc2 == constant
+ !
+ u_diffusion = ( divergence(k,cell2) - divergence(k,cell1) ) / dcEdge(iEdge) &
+ -( vorticity(k,vertex2) - vorticity(k,vertex1) ) / dvEdge(iEdge)
+ u_diffusion = h_mom_eddy_visc2 * u_diffusion
+
+ tend_u(k,iEdge) = tend_u(k,iEdge) + u_diffusion
+ end do
+ end do
+ end if
+
+ if ( h_mom_eddy_visc4 > 0.0 ) then
+
+ allocate(delsq_divergence(nVertLevels, nCells+1))
+ allocate(delsq_u(nVertLevels, nEdges+1))
+ allocate(delsq_circulation(nVertLevels, nVertices+1))
+ allocate(delsq_vorticity(nVertLevels, nVertices+1))
+
+ delsq_u(:,:) = 0.0
+
+ do iEdge=1,grid % nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ vertex1 = verticesOnEdge(1,iEdge)
+ vertex2 = verticesOnEdge(2,iEdge)
+
+ do k=1,nVertLevels
+
+ !
+ ! Compute diffusion, computed as </font>
<font color="black">abla divergence - k \times </font>
<font color="blue">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
+ 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)
+ do k=1,nVertLevels
+ delsq_vorticity(k,iVertex) = delsq_circulation(k,iVertex) * r
+ end do
+ end do
+
+ delsq_divergence(:,:) = 0.0
+ do iEdge=1,nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ do k=1,nVertLevels
+ delsq_divergence(k,cell1) = delsq_divergence(k,cell1) + delsq_u(k,iEdge)*dvEdge(iEdge)
+ delsq_divergence(k,cell2) = delsq_divergence(k,cell2) - delsq_u(k,iEdge)*dvEdge(iEdge)
+ end do
+ end do
+ do iCell = 1,nCells
+ r = 1.0 / areaCell(iCell)
+ do k = 1,nVertLevels
+ delsq_divergence(k,iCell) = delsq_divergence(k,iCell) * r
+ end do
+ end do
+
+ 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 h_mom_eddy_visc4 == constant
+ !
+ u_diffusion = ( delsq_divergence(k,cell2) - delsq_divergence(k,cell1) ) / dcEdge(iEdge) &
+ -( delsq_vorticity(k,vertex2) - delsq_vorticity(k,vertex1) ) / dvEdge(iEdge)
+
+ tend_u(k,iEdge) = tend_u(k,iEdge) - h_mom_eddy_visc4 * u_diffusion
+ end do
+ end do
+
+ deallocate(delsq_divergence)
+ deallocate(delsq_u)
+ deallocate(delsq_circulation)
+ deallocate(delsq_vorticity)
+
+ end if
+
+
+ !
+ ! vertical advection for u
+ !
+ do iEdge=1,grid % nEdgesSolve
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+
+ wdun(1) = 0.
+ do k=2,nVertLevels
+ wdun(k) = &
+ (ww(k,cell1)/(h(k,cell1)+h(k-1,cell1)) +ww(k,cell2)/(h(k,cell2)+h(k-1,cell2)))* &
+ rdnu(k)*(u(k,iEdge)-u(k-1,iEdge))
+ end do
+ wdun(nVertLevels+1) = 0.
+
+ do k=1,nVertLevels
+ tend_u(k,iEdge) = tend_u(k,iEdge) - 0.5*(wdun(k+1)+wdun(k))
+ end do
+ end do
+
+
+ !
+ ! vertical mixing for u - 2nd order
+ !
+ if ( v_mom_eddy_visc2 > 0.0 ) then
+
+ do iEdge=1,grid % nEdgesSolve
+
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+
+ do k=2,nVertLevels-1
+
+ z1 = 0.5*(geopotential(k-1,cell1)+geopotential(k-1,cell2))/gravity
+ z2 = 0.5*(geopotential(k ,cell1)+geopotential(k ,cell2))/gravity
+ z3 = 0.5*(geopotential(k+1,cell1)+geopotential(k+1,cell2))/gravity
+ z4 = 0.5*(geopotential(k+2,cell1)+geopotential(k+2,cell2))/gravity
+
+ zm = 0.5*(z1+z2)
+ z0 = 0.5*(z2+z3)
+ zp = 0.5*(z3+z4)
+
+ tend_u(k,iEdge) = tend_u(k,iEdge) + v_mom_eddy_visc2*( &
+ (u(k+1,iEdge)-u(k ,iEdge))/(zp-z0) &
+ -(u(k ,iEdge)-u(k-1,iEdge))/(z0-zm) )/(0.5*(zp-zm))
+ end do
+ end do
+
+ end if
+
+
+!----------- rhs for theta
+
+ tend_theta(:,:) = 0.
+
+
+ !
+ ! horizontal mixing for theta - we could combine this with advection directly (i.e. as a turbulent flux),
+ ! but here we can also code in hyperdiffusion if we wish (2nd order at present)
+ !
+ if ( h_theta_eddy_visc2 > 0.0 ) then
+
+ do iEdge=1,grid % nEdges
+ cell1 = grid % cellsOnEdge % array(1,iEdge)
+ cell2 = grid % cellsOnEdge % array(2,iEdge)
+
+ 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 do
+
+ end if
+
+ if ( h_theta_eddy_visc4 > 0.0 ) then
+
+ 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)
+
+ 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 do
+
+ do iCell = 1, nCells
+ r = 1.0 / areaCell(iCell)
+ do k=1,nVertLevels
+ delsq_theta(k,iCell) = delsq_theta(k,iCell) * r
+ end do
+ end do
+
+ do iEdge=1,grid % nEdges
+ cell1 = grid % cellsOnEdge % array(1,iEdge)
+ cell2 = grid % cellsOnEdge % array(2,iEdge)
+
+ 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
+
+ end do
+
+ deallocate(delsq_theta)
+
+ end if
+
+
+ !
+ ! horizontal advection for theta
+ !
+
+ if (config_theta_adv_order == 2) then
+
+ do iEdge=1,nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ 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
+
+ do iEdge=1,nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+
+ 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)
+ 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 do
+
+ else if (config_theta_adv_order == 4) then
+
+ do iEdge=1,nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+
+ 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)
+ 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
+
+
+ !
+ ! vertical advection plus diabatic term
+ ! Note: we are also dividing through by the cell area after the horizontal flux divergence
+ !
+ do iCell = 1, nCells
+ wdtn(1) = 0.
+ do k=2,nVertLevels
+ wdtn(k) = ww(k,icell)*(fnm(k)*theta(k,iCell)+fnp(k)*theta(k-1,iCell))
+ end do
+ wdtn(nVertLevels+1) = 0.
+ do k=1,nVertLevels
+ tend_theta(k,iCell) = tend_theta(k,iCell)/areaCell(iCell) -rdnw(k)*(wdtn(k+1)-wdtn(k))
+!! tend_theta(k,iCell) = tend_theta(k) + h(k,iCell)*h_diabatic(k,iCell)
+ end do
+ end do
+
+
+ !
+ ! vertical mixing for theta - 2nd order
+ !
+ if ( v_theta_eddy_visc2 > 0.0 ) then
+
+ do iCell = 1, grid % nCellsSolve
+ do k=2,nVertLevels-1
+ z1 = geopotential(k-1,iCell)/gravity
+ z2 = geopotential(k ,iCell)/gravity
+ z3 = geopotential(k+1,iCell)/gravity
+ z4 = geopotential(k+2,iCell)/gravity
+
+ zm = 0.5*(z1+z2)
+ z0 = 0.5*(z2+z3)
+ zp = 0.5*(z3+z4)
+
+ tend_theta(k,iCell) = tend_theta(k,iCell) + v_theta_eddy_visc2*prandtl*h(k,iCell)*( &
+ (theta(k+1,iCell)-theta(k ,iCell))/(zp-z0) &
+ -(theta(k ,iCell)-theta(k-1,iCell))/(z0-zm) )/(0.5*(zp-zm))
+ end do
+ end do
+
+ end if
+
+ end subroutine atmh_compute_dyn_tend
+
+!---------------------------------------------------------------------------------------------------------
+
+ subroutine atmh_advance_dynamics(tend, s, grid, small_step, number_small_steps, dt)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Advance the dry dynamics a small timestep (forward-backward integration)
+ !
+ ! Input: s - current model state
+ ! tend - large-timestep tendency (d*/dt)
+ ! grid - grid metadata
+ ! dt - timestep
+ !
+ ! Output: s - model state advanced a timestep dt
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (tend_type), intent(in) :: tend
+ type (state_type), intent(inout) :: s
+ type (mesh_type), intent(in) :: grid
+ real (kind=RKIND), intent(in) :: dt
+ integer, intent(in) :: small_step, number_small_steps
+
+ 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 :: nEdges, nVertices, nVertLevels
+ real (kind=RKIND), dimension(:), pointer :: h_s, fVertex, fEdge, dvEdge, dcEdge, areaCell, areaTriangle, dpsdt, &
+ surface_pressure
+ real (kind=RKIND), dimension(:,:), pointer :: vh, weightsOnEdge, kiteAreasOnVertex, h_edge, h, u, v, tend_h, tend_u, &
+ circulation, vorticity, ke, pv_edge, geopotential, alpha, theta, &
+ pressure, pressure_old, tend_theta, uhAvg, wwAvg, ww, u_old, &
+ theta_old, h_edge_old, qtot, ww_old, cqu, h_old
+ real (kind=RKIND), dimension(:,:,:), pointer :: scalar
+
+! real (kind=RKIND), pointer :: smext, p0, ptop
+ real (kind=RKIND) :: smext, smdiv, p0, ptop
+ real (kind=RKIND) :: tm, ptmp, he_old
+
+ integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnVertex, verticesOnEdge, edgesOnCell, edgesOnEdge, edgesOnVertex
+ integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge
+
+ real (kind=RKIND), dimension( grid % nVertLevels + 1) :: wdtn
+
+ real (kind=RKIND), dimension(:), pointer :: dnw, dbn, rdnw, dnu, fnm, fnp
+ real (kind=RKIND) :: maxpdt,minpdt, maxww, minww
+ integer :: maxpt,minpt
+
+ h => s % h % array
+ u => s % u % array
+ h_edge => s % h_edge % array
+ theta => s % theta % array
+
+! u_old => s_old % u % array
+! h_edge_old => s_old % h_edge % array
+! theta_old => s_old % theta % array
+! ww_old => s_old % ww % array
+! h_old => s_old % h % array
+ u_old => grid % u_old % array
+ h_edge_old => grid % h_edge_old % array
+ theta_old => grid % theta_old % array
+ ww_old => grid % ww_old % array
+ h_old => grid % h_old % array
+
+ geopotential => s % geopotential % array
+ alpha => s % alpha % array
+ surface_pressure => s % surface_pressure % array
+ pressure => s % pressure % array
+ pressure_old => grid % pressure_old % array
+
+ cellsOnEdge => grid % cellsOnEdge % array
+ dcEdge => grid % dcEdge % array
+ dvEdge => grid % dvEdge % array
+ areaCell => grid % areaCell % array
+ tend_h => tend % h % array
+ tend_u => tend % u % array
+ tend_theta => tend % theta % array
+
+
+ uhAvg => grid % uhAvg % array
+ wwAvg => grid % wwAvg % array
+ dpsdt => grid % dpsdt % array
+ qtot => grid % qtot % array
+ cqu => grid % cqu % array
+ ww => s % ww % array
+ scalar => s % scalars % array
+
+ dnw => grid % dnw % array
+ dbn => grid % dbn % array
+ dnu => grid % dnu % array
+ rdnw => grid % rdnw % array
+ fnm => grid % fnm % array
+ fnp => grid % fnp % array
+
+! p0 => grid % p0
+! ptop => grid % ptop
+! smext => grid % smext
+
+ nVertLevels = grid % nVertLevels
+ nEdges = grid % nEdges
+
+ p0 = 1.e+05
+ ptop = pressure(nVertLevels+1,1)
+ smext = 0.1
+ smdiv = 0.1
+
+! write(0,*) ' ptop in advance_dynamics ',ptop
+
+!--- begin computations
+
+! we assume that the pressure, alpha, geopotential are already properly set
+! in first small step of a set, couple theta
+
+ if(small_step == 1) then
+
+ do iCell=1,grid % nCells
+ do k=1,nVertLevels
+ theta(k,iCell) = theta(k,iCell)*h(k,iCell)
+ end do
+ end do
+
+ uhAvg = 0.
+ wwAvg = 0.
+ pressure_old(:,:) = pressure(:,:)
+ dpsdt(:) = 0.
+
+ end if
+
+ !
+ ! update horizontal momentum
+ !
+
+ do iEdge=1,grid % nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ 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
+
+ !
+ ! calculate omega, update theta
+ !
+
+ tend_h = 0.
+ do iEdge=1,nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ do k=1,nVertLevels
+ flux = u(k,iEdge) * dvEdge(iEdge) * h_edge(k,iEdge)
+ tend_h(k,cell1) = tend_h(k,cell1) + flux
+ tend_h(k,cell2) = tend_h(k,cell2) - flux
+ end do
+ do k=1,nVertLevels
+ uhAvg(k,iEdge) = uhAvg(k,iEdge) + u(k,iEdge) * h_edge(k,iEdge)
+ end do
+ end do
+
+ do iCell=1, grid % nCells
+ dpsdt(iCell) = 0.
+ do k=1,nVertLevels
+ dpsdt(iCell) = dpsdt(iCell) + dnw(k)*tend_h(k,iCell)
+ end do
+ dpsdt(iCell) = dpsdt(iCell)/areaCell(iCell)
+
+ surface_pressure(iCell) = surface_pressure(iCell) + dt*dpsdt(iCell)
+
+ do k=1,nVertLevels
+ h(k,iCell) = (1.-dbn(k))*(p0-ptop)+dbn(k)*(surface_pressure(iCell)-ptop)
+ end do
+
+ ! omega calculation
+
+ ww(1,iCell) = 0.
+ do k=2, nVertLevels
+ ww(k,iCell) = ww(k-1,iCell)-dnw(k-1)*(dbn(k-1)*dpsdt(iCell)+tend_h(k-1,iCell)/areaCell(iCell))
+ wwAvg(k,iCell) = wwAvg(k,iCell) + ww(k,iCell)
+ end do
+ ww(nVertLevels+1,iCell) = 0.
+
+ ! theta update - theta should be coupled at this point...
+
+ wdtn(1) = 0.
+ do k = 2, nVertLevels
+ wdtn(k) = (ww(k,iCell)-ww_old(k,iCell))*(fnm(k)*theta_old(k,iCell)+fnp(k)*theta_old(k-1,iCell))
+ end do
+ wdtn(nVertLevels+1) = 0.
+
+ do k = 1, nVertLevels
+ theta(k,iCell) = theta(k,iCell) + dt*tend_theta(k,iCell)
+ theta(k,iCell) = theta(k,iCell) - dt*rdnw(k)*(wdtn(k+1)-wdtn(k))
+ end do
+ end do
+
+ !
+ ! add in perturbation horizontal flux divergence
+ !
+
+ do iEdge=1,nEdges
+ 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
+
+
+ ! compute some diagnostics using the new state
+
+ do iCell = 1, grid % nCells
+
+ do k = nVertLevels,1,-1
+ pressure(k,iCell) = pressure(k+1,iCell) - dnw(k)*(1.+qtot(k,iCell))*h(k,iCell)
+ end do
+
+ do k=1, nVertLevels
+ tm = (1.+1.61*scalar(1,k,iCell))*theta(k,iCell)/h(k,iCell) ! assume scalar(1) is qv here?
+ alpha(k,iCell) = (rgas/p0)*tm* &
+ (0.5*(pressure(k,iCell)+pressure(k+1,iCell))/p0)**cvpm
+ geopotential(k+1,iCell) = geopotential(k,iCell) - dnw(k)*h(k,iCell)*alpha(k,iCell)
+ end do
+
+ if(small_step /= number_small_steps) then
+ do k=1, nVertLevels+1
+ ptmp = pressure(k,iCell)
+ pressure(k,iCell) = pressure(k,iCell) + smdiv*(pressure(k,iCell)-pressure_old(k,iCell))
+ pressure_old(k,iCell) = ptmp
+ end do
+ end if
+
+ end do
+
+! if last small step of a set, decouple theta
+
+ if(small_step == number_small_steps) then
+ do iCell=1,grid % nCells
+ do k=1,nVertLevels
+ theta(k,iCell) = theta(k,iCell)/h(k,iCell)
+ end do
+ end do
+ uhAvg = uhAvg/real(number_small_steps)
+ wwAvg = wwAvg/real(number_small_steps)
+ end if
+
+ end subroutine atmh_advance_dynamics
+
+
+ subroutine atmh_advance_scalars( tend, s_old, s_new, grid, dt)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !
+ ! Input: s - current model state
+ ! grid - grid metadata
+ !
+ ! Output: tend - computed scalar tendencies
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (tend_type), intent(in) :: tend
+ type (state_type), intent(in) :: s_old
+ type (state_type), intent(inout) :: s_new
+ type (mesh_type), intent(in) :: grid
+ real (kind=RKIND) :: dt
+
+ integer :: i, iCell, iEdge, k, iScalar, cell1, cell2, num_scalars
+ real (kind=RKIND) :: flux, scalar_edge, d2fdx2_cell1, d2fdx2_cell2
+
+ real (kind=RKIND), dimension(:,:,:), pointer :: scalar_old, scalar_new, scalar_tend
+ real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
+ real (kind=RKIND), dimension(:,:), pointer :: uhAvg, h_old, h_new, wwAvg
+ real (kind=RKIND), dimension(:), pointer :: dvEdge, dcEdge, areaCell
+ integer, dimension(:,:), pointer :: cellsOnEdge
+
+ real (kind=RKIND), dimension( s_old % num_scalars, grid % nVertLevels + 1 ) :: wdtn
+ integer :: nVertLevels
+
+ real (kind=RKIND), dimension(:), pointer :: fnm, fnp, rdnw
+ real (kind=RKIND) :: coef_3rd_order
+
+ num_scalars = s_old % num_scalars
+
+ coef_3rd_order = 0.
+ if (config_scalar_adv_order == 3) coef_3rd_order = 1.0
+ if (config_scalar_adv_order == 3 .and. config_monotonic) coef_3rd_order = 0.25
+
+ scalar_old => s_old % scalars % array
+ scalar_new => s_new % scalars % array
+ deriv_two => grid % deriv_two % array
+ uhAvg => grid % uhAvg % array
+ dvEdge => grid % dvEdge % array
+ dcEdge => grid % dcEdge % array
+ cellsOnEdge => grid % cellsOnEdge % array
+ scalar_tend => tend % scalars % array
+ h_old => s_old % h % array
+ h_new => s_new % h % array
+ wwAvg => grid % wwAvg % array
+ areaCell => grid % areaCell % array
+
+ fnm => grid % fnm % array
+ fnp => grid % fnp % array
+ rdnw => grid % rdnw % array
+
+ nVertLevels = grid % nVertLevels
+
+ scalar_tend = 0. ! testing purposes - we have no sources or sinks
+
+ !
+ ! Runge Kutta integration, so we compute fluxes from scalar_new values, update starts form scalar_old
+ !
+ !
+ ! horizontal flux divergence, accumulate in scalar_tend
+
+ if (config_scalar_adv_order == 2) then
+
+ do iEdge=1,grid%nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ 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 do
+ end do
+
+ else if (config_scalar_adv_order == 3) then
+
+ do iEdge=1,grid%nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+
+ 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)
+ 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
+ end do
+ end do
+
+ else if (config_scalar_adv_order == 4) then
+
+ do iEdge=1,grid%nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+
+ 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)
+ 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 do
+
+ end do
+ end if
+
+
+ !
+ ! vertical flux divergence
+ !
+
+ do iCell=1,grid % nCells
+
+ wdtn(:,1) = 0.
+ do k = 2, nVertLevels
+ do iScalar=1,num_scalars
+ wdtn(iScalar,k) = wwAvg(k,iCell)*(fnm(k)*scalar_new(iScalar,k,iCell)+fnp(k)*scalar_new(iScalar,k-1,iCell))
+ end do
+ end do
+ wdtn(:,nVertLevels+1) = 0.
+
+ do k=1,grid % nVertLevelsSolve
+ do iScalar=1,num_scalars
+ scalar_new(iScalar,k,iCell) = ( scalar_old(iScalar,k,iCell)*h_old(k,iCell) &
+ + dt*( scalar_tend(iScalar,k,iCell) -rdnw(k)*(wdtn(iScalar,k+1)-wdtn(iScalar,k)) ) )/h_new(k,iCell)
+
+ end do
+ end do
+ end do
+
+ end subroutine atmh_advance_scalars
+
+
+ subroutine atmh_advance_scalars_mono( tend, s_old, s_new, grid, dt, rk_step, rk_order, dminfo, cellsToSend, cellsToRecv)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !
+ ! Input: s - current model state
+ ! grid - grid metadata
+ !
+ ! Output: tend - computed scalar tendencies
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (tend_type), intent(in) :: tend
+ type (state_type), intent(in) :: s_old
+ type (state_type), intent(inout) :: s_new
+ type (mesh_type), intent(in) :: grid
+ integer, intent(in) :: rk_step, rk_order
+ real (kind=RKIND), intent(in) :: dt
+ type (dm_info), intent(in) :: dminfo
+ type (exchange_list), pointer :: cellsToSend, cellsToRecv
+
+ integer :: i, iCell, iEdge, k, iScalar, cell_upwind, cell1, cell2, num_scalars
+ real (kind=RKIND) :: flux, scalar_edge, d2fdx2_cell1, d2fdx2_cell2
+ real (kind=RKIND) :: fdir, flux_upwind, h_flux_upwind, s_upwind
+
+ real (kind=RKIND), dimension(:,:,:), pointer :: scalar_old, scalar_new, scalar_tend
+ real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
+ real (kind=RKIND), dimension(:,:), pointer :: uhAvg, h_old, h_new, wwAvg
+ real (kind=RKIND), dimension(:), pointer :: dvEdge, dcEdge, areaCell
+ integer, dimension(:,:), pointer :: cellsOnEdge
+
+ real (kind=RKIND), dimension( s_old % num_scalars, grid % nEdges+1) :: h_flux
+ real (kind=RKIND), dimension( s_old % num_scalars, grid % nCells+1, 2 ) :: v_flux, v_flux_upwind, s_update
+ real (kind=RKIND), dimension( s_old % num_scalars, grid % nCells+1, 2 ) :: scale_out, scale_in
+ real (kind=RKIND), dimension( s_old % num_scalars ) :: s_max, s_min, s_max_update, s_min_update
+
+ integer :: nVertLevels, km0, km1, ktmp, kcp1, kcm1
+
+ real (kind=RKIND), dimension(:), pointer :: fnm, fnp, rdnw
+ real (kind=RKIND), parameter :: eps=1.e-20
+ real (kind=RKIND) :: coef_3rd_order
+
+ num_scalars = s_old % num_scalars
+
+ scalar_old => s_old % scalars % array
+ scalar_new => s_new % scalars % array
+ deriv_two => grid % deriv_two % array
+ uhAvg => grid % uhAvg % array
+ dvEdge => grid % dvEdge % array
+ dcEdge => grid % dcEdge % array
+ cellsOnEdge => grid % cellsOnEdge % array
+ scalar_tend => tend % scalars % array
+ h_old => s_old % h % array
+ h_new => s_new % h % array
+ wwAvg => grid % wwAvg % array
+ areaCell => grid % areaCell % array
+
+ fnm => grid % fnm % array
+ fnp => grid % fnp % array
+ rdnw => grid % rdnw % array
+
+ nVertLevels = grid % nVertLevels
+
+ scalar_tend = 0. ! testing purposes - we have no sources or sinks
+
+ !
+ ! Runge Kutta integration, so we compute fluxes from scalar_new values, update starts from scalar_old
+ !
+
+ km1 = 1
+ km0 = 2
+ v_flux(:,:,km1) = 0.
+ v_flux_upwind(:,:,km1) = 0.
+ scale_out(:,:,:) = 1.
+ scale_in(:,:,:) = 1.
+
+ coef_3rd_order = 0.
+ if (config_scalar_adv_order == 3) coef_3rd_order = 1.0
+ if (config_scalar_adv_order == 3 .and. config_monotonic) coef_3rd_order = 0.25
+
+ do k = 1, grid % nVertLevels
+ kcp1 = min(k+1,grid % nVertLevels)
+ kcm1 = max(k-1,1)
+
+! vertical flux
+
+ do iCell=1,grid % nCells
+
+ if (k < grid % nVertLevels) then
+ cell_upwind = k
+ if (wwAvg(k+1,iCell) >= 0) cell_upwind = k+1
+ do iScalar=1,num_scalars
+ v_flux(iScalar,iCell,km0) = dt * wwAvg(k+1,iCell) * &
+ (fnm(k+1) * scalar_new(iScalar,k+1,iCell) + fnp(k+1) * scalar_new(iScalar,k,iCell))
+ v_flux_upwind(iScalar,iCell,km0) = dt * wwAvg(k+1,iCell) * scalar_old(iScalar,cell_upwind,iCell)
+ v_flux(iScalar,iCell,km0) = v_flux(iScalar,iCell,km0) - v_flux_upwind(iScalar,iCell,km0)
+! v_flux(iScalar,iCell,km0) = 0. ! use only upwind - for testing
+ s_update(iScalar,iCell,km0) = scalar_old(iScalar,k,iCell) * h_old(k,iCell) &
+ - rdnw(k) * (v_flux_upwind(iScalar,iCell,km0) - v_flux_upwind(iScalar,iCell,km1))
+ end do
+ else
+ do iScalar=1,num_scalars
+ v_flux(iScalar,iCell,km0) = 0.
+ v_flux_upwind(iScalar,iCell,km0) = 0.
+ s_update(iScalar,iCell,km0) = scalar_old(iScalar,k,iCell) * h_old(k,iCell) &
+ - rdnw(k) * (v_flux_upwind(iScalar,iCell,km0) - v_flux_upwind(iScalar,iCell,km1))
+ end do
+ end if
+
+ end do
+
+! horizontal flux
+
+ if (config_scalar_adv_order == 2) then
+
+ do iEdge=1,grid%nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ 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
+
+ do iEdge=1,grid%nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ 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
+
+ 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
+
+
+ if ( (rk_step == rk_order) .and. (config_monotonic .or. config_positive_definite) ) then
+
+!*************************************************************************************************************
+!--- limiter - we limit horizontal and vertical fluxes on level k
+!--- (these are h fluxes contributing to level k scalars, and v flux contributing to level k, k-1 scalars)
+
+ do iCell=1,grid % nCells
+
+ do iScalar=1,num_scalars
+
+ s_max(iScalar) = max(scalar_old(iScalar,k,iCell), scalar_old(iScalar,kcp1,iCell), scalar_old(iScalar,kcm1,iCell))
+ s_min(iScalar) = min(scalar_old(iScalar,k,iCell), scalar_old(iScalar,kcp1,iCell), scalar_old(iScalar,kcm1,iCell))
+ s_max_update(iScalar) = s_update(iScalar,iCell,km0)
+ s_min_update(iScalar) = s_update(iScalar,iCell,km0)
+
+ ! add in vertical flux to get max and min estimate
+ s_max_update(iScalar) = s_max_update(iScalar) &
+ - rdnw(k) * (max(0.,v_flux(iScalar,iCell,km0)) - min(0.,v_flux(iScalar,iCell,km1)))
+ s_min_update(iScalar) = s_min_update(iScalar) &
+ - rdnw(k) * (min(0.,v_flux(iScalar,iCell,km0)) - max(0.,v_flux(iScalar,iCell,km1)))
+
+ end do
+
+ do i = 1, grid % nEdgesOnCell % array(iCell) ! go around the edges of each cell
+ 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))
+
+ 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
+
+ if( config_positive_definite ) s_min(:) = 0.
+
+ do iScalar=1,num_scalars
+ scale_out (iScalar,iCell,km0) = 1.
+ scale_in (iScalar,iCell,km0) = 1.
+ s_max_update (iScalar) = s_max_update (iScalar) / h_new (k,iCell)
+ s_min_update (iScalar) = s_min_update (iScalar) / h_new (k,iCell)
+ s_upwind = s_update(iScalar,iCell,km0) / h_new(k,iCell)
+ if ( s_max_update(iScalar) > s_max(iScalar) .and. config_monotonic) &
+ scale_in (iScalar,iCell,km0) = max(0.,(s_max(iScalar)-s_upwind)/(s_max_update(iScalar)-s_upwind+eps))
+ if ( s_min_update(iScalar) < s_min(iScalar) ) &
+ scale_out (iScalar,iCell,km0) = max(0.,(s_upwind-s_min(iScalar))/(s_upwind-s_min_update(iScalar)+eps))
+ end do
+
+ end do ! end loop over cells to compute scale factor
+
+
+ call mpas_dmpar_exch_halo_field2d_real(dminfo, scale_out(:,:,1), &
+ num_scalars, grid % nCells, &
+ cellsToSend, cellsToRecv)
+ call mpas_dmpar_exch_halo_field2d_real(dminfo, scale_out(:,:,2), &
+ num_scalars, grid % nCells, &
+ cellsToSend, cellsToRecv)
+ call mpas_dmpar_exch_halo_field2d_real(dminfo, scale_in(:,:,1), &
+ num_scalars, grid % nCells, &
+ cellsToSend, cellsToRecv)
+ call mpas_dmpar_exch_halo_field2d_real(dminfo, scale_in(:,:,2), &
+ num_scalars, grid % nCells, &
+ cellsToSend, cellsToRecv)
+
+ ! rescale the horizontal fluxes
+
+ do iEdge = 1, grid % nEdges
+ cell1 = grid % cellsOnEdge % array(1,iEdge)
+ cell2 = grid % cellsOnEdge % array(2,iEdge)
+ 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
+
+ do iCell=1,grid % nCells
+ do iScalar=1,num_scalars
+ flux = v_flux(iScalar,iCell,km1)
+ if (flux > 0) then
+ flux = flux * min(scale_out(iScalar,iCell,km0), scale_in(iScalar,iCell,km1))
+ else
+ flux = flux * min(scale_in(iScalar,iCell,km0), scale_out(iScalar,iCell,km1))
+ end if
+ v_flux(iScalar,iCell,km1) = flux
+ end do
+ end do
+
+! end of limiter
+!*******************************************************************************************************************
+
+ end if
+
+!--- update
+
+ do iCell=1,grid % nCells
+ ! add in upper vertical flux that was just renormalized
+ do iScalar=1,num_scalars
+ s_update(iScalar,iCell,km0) = s_update(iScalar,iCell,km0) + rdnw(k) * v_flux(iScalar,iCell,km1)
+ if (k > 1) s_update(iScalar,iCell,km1) = s_update(iScalar,iCell,km1) - rdnw(k-1)*v_flux(iScalar,iCell,km1)
+ end do
+ end do
+
+ do iEdge=1,grid%nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ 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
+ if (k > 1) then
+ do iCell=1,grid % nCells
+ do iScalar=1,num_scalars
+ s_update(iScalar,iCell,km1) = s_update(iScalar,iCell,km1) / h_new(k-1,iCell)
+ end do
+ end do
+
+ do iCell=1,grid % nCells
+ do iScalar=1,num_scalars
+ scalar_new(iScalar,k-1,iCell) = s_update(iScalar,iCell,km1)
+ end do
+ end do
+ end if
+
+ ktmp = km1
+ km1 = km0
+ km0 = ktmp
+
+ end do
+
+ do iCell=1,grid % nCells
+ do iScalar=1,num_scalars
+ scalar_new(iScalar,grid % nVertLevels,iCell) = s_update(iScalar,iCell,km1) / h_new(grid%nVertLevels,iCell)
+ end do
+ end do
+
+ end subroutine atmh_advance_scalars_mono
+
+
+ subroutine atmh_compute_solve_diagnostics(dt, s, grid)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Compute diagnostic fields used in the tendency computations
+ !
+ ! Input: grid - grid metadata
+ !
+ ! Output: s - computed diagnostics
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ real (kind=RKIND), intent(in) :: dt
+ type (state_type), intent(inout) :: s
+ type (mesh_type), intent(in) :: grid
+
+
+ integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j, cov
+ real (kind=RKIND) :: flux, vorticity_abs, h_vertex, workpv, r
+
+ 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
+ integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnVertex, verticesOnEdge, edgesOnCell, edgesOnEdge, edgesOnVertex
+ integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge
+
+
+ h => s % h % array
+ u => s % u % array
+ v => s % v % array
+ vh => s % vh % 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
+ 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
+
+ weightsOnEdge => grid % weightsOnEdge % array
+ kiteAreasOnVertex => grid % kiteAreasOnVertex % array
+ cellsOnEdge => grid % cellsOnEdge % array
+ cellsOnVertex => grid % cellsOnVertex % array
+ verticesOnEdge => grid % verticesOnEdge % array
+ nEdgesOnCell => grid % nEdgesOnCell % array
+ edgesOnCell => grid % edgesOnCell % array
+ nEdgesOnEdge => grid % nEdgesOnEdge % array
+ edgesOnEdge => grid % edgesOnEdge % array
+ edgesOnVertex => grid % edgesOnVertex % array
+ dcEdge => grid % dcEdge % array
+ dvEdge => grid % dvEdge % array
+ areaCell => grid % areaCell % array
+ areaTriangle => grid % areaTriangle % array
+ h_s => grid % h_s % array
+ fVertex => grid % fVertex % array
+ fEdge => grid % fEdge % array
+
+ nCells = grid % nCells
+ nEdges = grid % nEdges
+ nVertices = grid % nVertices
+ nVertLevels = grid % nVertLevels
+
+ !
+ ! Compute height on cell edges at velocity locations
+ !
+ do iEdge=1,nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ do k=1,nVertLevels
+ h_edge(k,iEdge) = 0.5 * (h(k,cell1) + h(k,cell2))
+ end do
+ end do
+
+ !
+ ! Compute circulation and relative vorticity at each vertex
+ !
+ circulation(:,:) = 0.0
+ do iEdge=1,nEdges
+ do k=1,nVertLevels
+ circulation(k,verticesOnEdge(1,iEdge)) = circulation(k,verticesOnEdge(1,iEdge)) - dcEdge(iEdge) * u(k,iEdge)
+ circulation(k,verticesOnEdge(2,iEdge)) = circulation(k,verticesOnEdge(2,iEdge)) + dcEdge(iEdge) * u(k,iEdge)
+ end do
+ end do
+ do iVertex=1,nVertices
+ do k=1,nVertLevels
+ vorticity(k,iVertex) = circulation(k,iVertex) / areaTriangle(iVertex)
+ end do
+ end do
+
+
+ !
+ ! Compute the divergence at each cell center
+ !
+ divergence(:,:) = 0.0
+ do iEdge=1,nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ 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)
+ do k = 1,nVertLevels
+ divergence(k,iCell) = divergence(k,iCell) * r
+ end do
+ end do
+
+
+ !
+ ! Compute kinetic energy in each cell
+ !
+ ke(:,:) = 0.0
+ do iCell=1,nCells
+ do i=1,nEdgesOnCell(iCell)
+ iEdge = edgesOnCell(i,iCell)
+ do k=1,nVertLevels
+ ke(k,iCell) = ke(k,iCell) + 0.25 * dcEdge(iEdge) * dvEdge(iEdge) * u(k,iEdge)**2.0
+ end do
+ end do
+ do k=1,nVertLevels
+ ke(k,iCell) = ke(k,iCell) / areaCell(iCell)
+ end do
+ end do
+
+ !
+ ! Compute v (tangential) velocities
+ !
+ v(:,:) = 0.0
+ do iEdge = 1,nEdges
+ do i=1,nEdgesOnEdge(iEdge)
+ eoe = edgesOnEdge(i,iEdge)
+ do k = 1,nVertLevels
+ v(k,iEdge) = v(k,iEdge) + weightsOnEdge(i,iEdge) * u(k, eoe)
+ end do
+ end do
+ end do
+
+
+ ! tdr
+ !
+ ! Compute height at vertices, pv at vertices, and average pv to edge locations
+ ! ( this computes pv_vertex at all vertices bounding real cells )
+ !
+ do iVertex = 1,nVertices
+ do k=1,nVertLevels
+ h_vertex = 0.0
+ do i=1,grid % vertexDegree
+ 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
+ ! tdr
+
+
+ ! tdr
+ !
+ ! Compute gradient of PV in the tangent direction
+ ! ( this computes gradPVt at all edges bounding real cells )
+ !
+ do iEdge = 1,nEdges
+ do k = 1,nVertLevels
+ gradPVt(k,iEdge) = (pv_vertex(k,verticesOnEdge(2,iEdge)) - pv_vertex(k,verticesOnEdge(1,iEdge))) / &
+ dvEdge(iEdge)
+ end do
+ end do
+
+ ! tdr
+ !
+ ! Compute pv at the edges
+ ! ( this computes pv_edge at all edges bounding real cells )
+ !
+ pv_edge(:,:) = 0.0
+ do iVertex = 1,nVertices
+ do i=1,grid % vertexDegree
+ iEdge = edgesOnVertex(i,iVertex)
+ do k=1,nVertLevels
+ pv_edge(k,iEdge) = pv_edge(k,iEdge) + 0.5 * pv_vertex(k,iVertex)
+ end do
+ end do
+ end do
+ ! tdr
+
+ ! tdr
+ !
+ ! Modify PV edge with upstream bias.
+ !
+ do iEdge = 1,nEdges
+ do k = 1,nVertLevels
+ pv_edge(k,iEdge) = pv_edge(k,iEdge) - config_apvm_upwinding * v(k,iEdge) * dt * gradPVt(k,iEdge)
+ end do
+ end do
+
+
+ ! tdr
+ !
+ ! Compute pv at cell centers
+ ! ( this computes pv_cell for all real cells )
+ !
+ pv_cell(:,:) = 0.0
+ do iVertex = 1, nVertices
+ do i=1,grid % vertexDegree
+ 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 do
+ end do
+ ! tdr
+
+ ! tdr
+ !
+ ! Compute gradient of PV in normal direction
+ ! (tdr: 2009-10-02: this is not correct because the pv_cell in the halo is not correct)
+ !
+ gradPVn(:,:) = 0.0
+ do iEdge = 1,nEdges
+ do k = 1,nVertLevels
+ gradPVn(k,iEdge) = (pv_cell(k,cellsOnEdge(2,iEdge)) - pv_cell(k,cellsOnEdge(1,iEdge))) / &
+ dcEdge(iEdge)
+ end do
+ end do
+ ! tdr
+
+ ! Modify PV edge with upstream bias.
+ !
+ do iEdge = 1,nEdges
+ do k = 1,nVertLevels
+ pv_edge(k,iEdge) = pv_edge(k,iEdge) - config_apvm_upwinding * u(k,iEdge) * dt * gradPVn(k,iEdge)
+ end do
+ end do
+
+
+ end subroutine atmh_compute_solve_diagnostics
+
+
+ subroutine atmh_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 (state_type), intent(inout) :: s_new
+ type (state_type), intent(in) :: s_old
+ type (mesh_type), 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 atmh_compute_w
+
+end module atmh_time_integration
Modified: trunk/mpas/src/core_ocean/mpas_ocn_advection.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_advection.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_ocean/mpas_ocn_advection.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -1,8 +1,8 @@
module advection
- use grid_types
- use configure
- use constants
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_constants
contains
@@ -593,14 +593,14 @@
ata = matmul(at,a)
! if (m == n) then
-! call migs(a,n,b,indx)
+! call MIGS(a,n,b,indx)
! else
- call migs(atha,n,atha_inv,indx)
+ call MIGS(atha,n,atha_inv,indx)
b = matmul(atha_inv,ath)
-! call migs(ata,n,ata_inv,indx)
+! call MIGS(ata,n,ata_inv,indx)
! b = matmul(ata_inv,at)
! end if
b_out(1:n,1:m) = b(1:n,1:m)
@@ -630,7 +630,7 @@
! !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
-SUBROUTINE MIGS (A,N,X,INDX)
+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.
@@ -672,7 +672,7 @@
X(J,I) = X(J,I)/A(INDX(J),J)
END DO
END DO
-END SUBROUTINE MIGS
+END SUBROUTine MIGS
SUBROUTINE ELGS (A,N,INDX)
Modified: trunk/mpas/src/core_ocean/mpas_ocn_equation_of_state.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_equation_of_state.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_ocean/mpas_ocn_equation_of_state.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -14,9 +14,9 @@
module ocn_equation_of_state
- use grid_types
- use configure
- use timer
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_timer
use ocn_equation_of_state_linear
use ocn_equation_of_state_jm
@@ -99,7 +99,7 @@
if(.not.eosOn) return
- call timer_start("ocn_equation_of_state_rho")
+ call mpas_timer_start("ocn_equation_of_state_rho")
tracers => s % tracers % array
indexT = s % index_temperature
@@ -122,7 +122,7 @@
endif
- call timer_stop("ocn_equation_of_state_rho")
+ call mpas_timer_stop("ocn_equation_of_state_rho")
end subroutine ocn_equation_of_state_rho!}}}
Modified: trunk/mpas/src/core_ocean/mpas_ocn_equation_of_state_jm.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_equation_of_state_jm.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_ocean/mpas_ocn_equation_of_state_jm.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -14,9 +14,9 @@
module ocn_equation_of_state_jm
- use grid_types
- use configure
- use timer
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_timer
implicit none
private
@@ -194,7 +194,7 @@
err = 0
- call timer_start("equation_of_state_jm")
+ call mpas_timer_start("equation_of_state_jm")
nCells = grid % nCells
maxLevelCell => grid % maxLevelCell % array
@@ -239,7 +239,7 @@
write(0,*) 'Abort: In equation_of_state_jm', &
' k_displaced must be between 1 and nVertLevels for ', &
'displacement_type = absolute'
- call dmpar_abort(dminfo)
+ call mpas_dmpar_abort(dminfo)
endif
if (k_displaced == 0) then
@@ -309,7 +309,7 @@
deallocate(pRefEOS,p,p2)
- call timer_stop("equation_of_state_jm")
+ call mpas_timer_stop("equation_of_state_jm")
end subroutine ocn_equation_of_state_jm_rho!}}}
Modified: trunk/mpas/src/core_ocean/mpas_ocn_equation_of_state_linear.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_equation_of_state_linear.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_ocean/mpas_ocn_equation_of_state_linear.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -14,9 +14,9 @@
module ocn_equation_of_state_linear
- use grid_types
- use configure
- use timer
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_timer
implicit none
private
@@ -87,7 +87,7 @@
integer :: nCells, iCell, k
type (dm_info) :: dminfo
- call timer_start("ocn_equation_of_state_linear")
+ call mpas_timer_start("ocn_equation_of_state_linear")
maxLevelCell => grid % maxLevelCell % array
nCells = grid % nCells
@@ -103,7 +103,7 @@
end do
end do
- call timer_stop("ocn_equation_of_state_linear")
+ call mpas_timer_stop("ocn_equation_of_state_linear")
end subroutine ocn_equation_of_state_linear_rho!}}}
Modified: trunk/mpas/src/core_ocean/mpas_ocn_global_diagnostics.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_global_diagnostics.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_ocean/mpas_ocn_global_diagnostics.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -1,9 +1,9 @@
module global_diagnostics
- use grid_types
- use configure
- use constants
- use dmpar
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_constants
+ use mpas_dmpar
implicit none
save
@@ -218,7 +218,7 @@
nMaxes = nMaxes + nVariables
! global reduction of the 5 arrays (packed into 3 to minimize global communication)
- call dmpar_sum_real_array(dminfo, nSums, sums(1:nSums), reductions(1:nSums))
+ call mpas_dmpar_sum_real_array(dminfo, nSums, sums(1:nSums), reductions(1:nSums))
sums(1:nVariables) = reductions(1:nVariables)
areaCellGlobal = reductions(nVariables+1)
areaEdgeGlobal = reductions(nVariables+2)
@@ -227,11 +227,11 @@
nEdgesGlobal = int(reductions(nVariables+5))
nVerticesGlobal = int(reductions(nVariables+6))
- call dmpar_min_real_array(dminfo, nMins, mins(1:nMins), reductions(1:nMins))
+ call mpas_dmpar_min_real_array(dminfo, nMins, mins(1:nMins), reductions(1:nMins))
mins(1:nVariables) = reductions(1:nVariables)
verticalSumMins(1:nVariables) = reductions(nMins-nVariables+1:nMins)
- call dmpar_max_real_array(dminfo, nMaxes, maxes(1:nMaxes), reductions(1:nMaxes))
+ call mpas_dmpar_max_real_array(dminfo, nMaxes, maxes(1:nMaxes), reductions(1:nMaxes))
maxes(1:nVariables) = reductions(1:nVariables)
CFLNumberGlobal = reductions(nVariables+1)
verticalSumMaxes(1:nVariables) = reductions(nMaxes-nVariables+1:nMaxes)
@@ -474,7 +474,7 @@
real (kind=RKIND) :: localSum
localSum = sum(field)
- call dmpar_sum_real(dminfo, localSum, globalSum)
+ call mpas_dmpar_sum_real(dminfo, localSum, globalSum)
end subroutine computeGlobalSum
@@ -496,7 +496,7 @@
localSum = localSum + areas(elementIndex) * sum(field(:,elementIndex))
end do
- call dmpar_sum_real(dminfo, localSum, globalSum)
+ call mpas_dmpar_sum_real(dminfo, localSum, globalSum)
end subroutine computeAreaWeightedGlobalSum
@@ -531,7 +531,7 @@
real (kind=RKIND) :: localMin
localMin = minval(field)
- call dmpar_min_real(dminfo, localMin, globalMin)
+ call mpas_dmpar_min_real(dminfo, localMin, globalMin)
end subroutine computeGlobalMin
@@ -547,7 +547,7 @@
real (kind=RKIND) :: localMax
localMax = maxval(field)
- call dmpar_max_real(dminfo, localMax, globalMax)
+ call mpas_dmpar_max_real(dminfo, localMax, globalMax)
end subroutine computeGlobalMax
@@ -563,7 +563,7 @@
real (kind=RKIND) :: localMin
localMin = minval(sum(field,1))
- call dmpar_min_real(dminfo, localMin, globalMin)
+ call mpas_dmpar_min_real(dminfo, localMin, globalMin)
end subroutine computeGlobalVertSumHorizMin
@@ -579,7 +579,7 @@
real (kind=RKIND) :: localMax
localMax = maxval(sum(field,1))
- call dmpar_max_real(dminfo, localMax, globalMax)
+ call mpas_dmpar_max_real(dminfo, localMax, globalMax)
end subroutine computeGlobalVertSumHorizMax
@@ -595,7 +595,7 @@
real (kind=RKIND) :: localMin
localMin = minval(sum(h*field,1))
- call dmpar_min_real(dminfo, localMin, globalMin)
+ call mpas_dmpar_min_real(dminfo, localMin, globalMin)
end subroutine computeGlobalVertThicknessWeightedSumHorizMin
@@ -611,7 +611,7 @@
real (kind=RKIND) :: localMax
localMax = maxval(sum(h*field,1))
- call dmpar_max_real(dminfo, localMax, globalMax)
+ call mpas_dmpar_max_real(dminfo, localMax, globalMax)
end subroutine computeGlobalVertThicknessWeightedSumHorizMax
Modified: trunk/mpas/src/core_ocean/mpas_ocn_mpas_core.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_mpas_core.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_ocean/mpas_ocn_mpas_core.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -2,7 +2,7 @@
use mpas_framework
use mpas_timekeeping
- use dmpar
+ use mpas_dmpar
use test_cases
use ocn_time_integration
@@ -38,8 +38,8 @@
subroutine mpas_core_init(domain, startTimeStamp)!{{{
- use configure
- use grid_types
+ use mpas_configure
+ use mpas_grid_types
implicit none
@@ -81,7 +81,7 @@
err = err .or. err_tmp
if(err) then
- call dmpar_abort(dminfo)
+ call mpas_dmpar_abort(dminfo)
endif
if (.not. config_do_restart) call setup_sw_test_case(domain)
@@ -96,14 +96,14 @@
else
print *, ' Incorrect choice of config_vert_grid_type:',&
config_vert_grid_type
- call dmpar_abort(dminfo)
+ call mpas_dmpar_abort(dminfo)
endif
if (trim(config_new_btr_variables_from) == 'btr_avg' &
.and.trim(config_time_integration) == 'unsplit_explicit') then
print *, ' unsplit_explicit option must use',&
' config_new_btr_variables_from==last_subcycle'
- call dmpar_abort(dminfo)
+ call mpas_dmpar_abort(dminfo)
endif
!
@@ -127,10 +127,10 @@
! input arguement into mpas_init. Ask about that later. For now, there will be
! no initial statistics write.
- ! call timer_start("global diagnostics")
+ ! call mpas_timer_start("global diagnostics")
! call computeGlobalDiagnostics(domain % dminfo, block % state % time_levs(1) % state, mesh, 0, dt)
- ! call timer_stop("global diagnostics")
- ! call output_state_init(output_obj, domain, "OUTPUT")
+ ! call mpas_timer_stop("global diagnostics")
+ ! call mpas_output_state_init(output_obj, domain, "OUTPUT")
! call write_output_frame(output_obj, domain)
restart_frame = 1
@@ -150,57 +150,57 @@
type (MPAS_TimeInterval_type) :: runDuration, timeStep, alarmTimeStep
integer :: ierr
- call MPAS_setTime(curr_time=startTime, dateTimeString=config_start_time, ierr=ierr)
- call MPAS_setTimeInterval(timeStep, dt=dt, ierr=ierr)
+ call mpas_set_time(curr_time=startTime, dateTimeString=config_start_time, ierr=ierr)
+ call mpas_set_timeInterval(timeStep, dt=dt, ierr=ierr)
if (trim(config_run_duration) /= "none") then
- call MPAS_setTimeInterval(runDuration, timeString=config_run_duration, ierr=ierr)
- call MPAS_createClock(clock, startTime=startTime, timeStep=timeStep, runDuration=runDuration, ierr=ierr)
+ call mpas_set_timeInterval(runDuration, timeString=config_run_duration, ierr=ierr)
+ call mpas_create_clock(clock, startTime=startTime, timeStep=timeStep, runDuration=runDuration, ierr=ierr)
if (trim(config_stop_time) /= "none") then
- call MPAS_setTime(curr_time=stopTime, dateTimeString=config_stop_time, ierr=ierr)
+ call mpas_set_time(curr_time=stopTime, dateTimeString=config_stop_time, ierr=ierr)
if(startTime + runduration /= stopTime) then
write(0,*) 'Warning: config_run_duration and config_stop_time are inconsitent: using config_run_duration.'
end if
end if
else if (trim(config_stop_time) /= "none") then
- call MPAS_setTime(curr_time=stopTime, dateTimeString=config_stop_time, ierr=ierr)
- call MPAS_createClock(clock, startTime=startTime, timeStep=timeStep, stopTime=stopTime, ierr=ierr)
+ call mpas_set_time(curr_time=stopTime, dateTimeString=config_stop_time, ierr=ierr)
+ call mpas_create_clock(clock, startTime=startTime, timeStep=timeStep, stopTime=stopTime, ierr=ierr)
else
write(0,*) 'Error: Neither config_run_duration nor config_stop_time were specified.'
- call dmpar_finalize(domain % dminfo)
+ call mpas_dmpar_finalize(domain % dminfo)
end if
! set output alarm
- call MPAS_setTimeInterval(alarmTimeStep, timeString=config_output_interval, ierr=ierr)
+ call mpas_set_timeInterval(alarmTimeStep, timeString=config_output_interval, ierr=ierr)
alarmStartTime = startTime + alarmTimeStep
- call MPAS_addClockAlarm(clock, outputAlarmID, alarmStartTime, alarmTimeStep, ierr=ierr)
+ call mpas_add_clock_alarm(clock, outputAlarmID, alarmStartTime, alarmTimeStep, ierr=ierr)
! set restart alarm, if necessary
if (trim(config_restart_interval) /= "none") then
- call MPAS_setTimeInterval(alarmTimeStep, timeString=config_restart_interval, ierr=ierr)
+ call mpas_set_timeInterval(alarmTimeStep, timeString=config_restart_interval, ierr=ierr)
alarmStartTime = startTime + alarmTimeStep
- call MPAS_addClockAlarm(clock, restartAlarmID, alarmStartTime, alarmTimeStep, ierr=ierr)
+ call mpas_add_clock_alarm(clock, restartAlarmID, alarmStartTime, alarmTimeStep, ierr=ierr)
end if
!TODO: use this code if we desire to convert config_stats_interval to alarms
!(must also change config_stats_interval type to character)
! set stats alarm, if necessary
!if (trim(config_stats_interval) /= "none") then
- ! call MPAS_setTimeInterval(alarmTimeStep, timeString=config_stats_interval, ierr=ierr)
+ ! call mpas_set_timeInterval(alarmTimeStep, timeString=config_stats_interval, ierr=ierr)
! alarmStartTime = startTime + alarmTimeStep
- ! call MPAS_addClockAlarm(clock, statsAlarmID, alarmStartTime, alarmTimeStep, ierr=ierr)
+ ! call mpas_add_clock_alarm(clock, statsAlarmID, alarmStartTime, alarmTimeStep, ierr=ierr)
!end if
- call MPAS_getTime(curr_time=startTime, dateTimeString=startTimeStamp, ierr=ierr)
+ call mpas_get_time(curr_time=startTime, dateTimeString=startTimeStamp, ierr=ierr)
end subroutine simulation_clock_init!}}}
subroutine mpas_init_block(block, mesh, dt)!{{{
- use grid_types
- use RBF_interpolation
- use vector_reconstruction
+ use mpas_grid_types
+ use mpas_rbf_interpolation
+ use mpas_vector_reconstruction
implicit none
@@ -214,9 +214,9 @@
call compute_mesh_scaling(mesh)
- call rbfInterp_initialize(mesh)
- call init_reconstruct(mesh)
- call reconstruct(mesh, block % state % time_levs(1) % state % u % array, &
+ call mpas_rbf_interp_initialize(mesh)
+ call mpas_init_reconstruct(mesh)
+ call mpas_reconstruct(mesh, block % state % time_levs(1) % state % u % array, &
block % state % time_levs(1) % state % uReconstructX % array, &
block % state % time_levs(1) % state % uReconstructY % array, &
block % state % time_levs(1) % state % uReconstructZ % array, &
@@ -258,7 +258,7 @@
! mrp 110808 add, so that variables are copied to * variables for split explicit
do i=2,nTimeLevs
- call copy_state(block % state % time_levs(i) % state, &
+ call mpas_copy_state(block % state % time_levs(i) % state, &
block % state % time_levs(1) % state)
end do
! mrp 110808 add end
@@ -266,7 +266,7 @@
else
do i=2,nTimeLevs
- call copy_state(block % state % time_levs(i) % state, &
+ call mpas_copy_state(block % state % time_levs(i) % state, &
block % state % time_levs(1) % state)
end do
endif
@@ -275,9 +275,9 @@
subroutine mpas_core_run(domain, output_obj, output_frame)!{{{
- use grid_types
- use io_output
- use timer
+ use mpas_grid_types
+ use mpas_io_output
+ use mpas_timer
implicit none
@@ -296,8 +296,8 @@
! Eventually, dt should be domain specific
dt = config_dt
- currTime = MPAS_getClockTime(clock, MPAS_NOW, ierr)
- call MPAS_getTime(curr_time=currTime, dateTimeString=timeStamp, ierr=ierr)
+ currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr)
+ call mpas_get_time(curr_time=currTime, dateTimeString=timeStamp, ierr=ierr)
write(0,*) 'Initial time ', timeStamp
call write_output_frame(output_obj, output_frame, domain)
@@ -305,32 +305,32 @@
! During integration, time level 1 stores the model state at the beginning of the
! time step, and time level 2 stores the state advanced dt in time by timestep(...)
itimestep = 0
- do while (.not. MPAS_isClockStopTime(clock))
+ do while (.not. mpas_is_clock_stop_time(clock))
itimestep = itimestep + 1
- call MPAS_advanceClock(clock)
+ call mpas_advance_clock(clock)
- currTime = MPAS_getClockTime(clock, MPAS_NOW, ierr)
- call MPAS_getTime(curr_time=currTime, dateTimeString=timeStamp, ierr=ierr)
+ currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr)
+ call mpas_get_time(curr_time=currTime, dateTimeString=timeStamp, ierr=ierr)
write(0,*) 'Doing timestep ', timeStamp
- call timer_start("time integration")
+ call mpas_timer_start("time integration")
call mpas_timestep(domain, itimestep, dt, timeStamp)
- call timer_stop("time integration")
+ call mpas_timer_stop("time integration")
! Move time level 2 fields back into time level 1 for next time step
- call shift_time_levels_state(domain % blocklist % state)
+ call mpas_shift_time_levels_state(domain % blocklist % state)
- if (MPAS_isAlarmRinging(clock, outputAlarmID, ierr=ierr)) then
- call MPAS_resetClockAlarm(clock, outputAlarmID, ierr=ierr)
- if(output_frame == 1) call output_state_init(output_obj, domain, "OUTPUT", trim(timeStamp)) ! output_frame will always be > 1 here unless it is reset after the output file is finalized
+ if (mpas_is_alarm_ringing(clock, outputAlarmID, ierr=ierr)) then
+ call mpas_reset_clock_alarm(clock, outputAlarmID, ierr=ierr)
+ if(output_frame == 1) call mpas_output_state_init(output_obj, domain, "OUTPUT", trim(timeStamp)) ! output_frame will always be > 1 here unless it is reset after the output file is finalized
call write_output_frame(output_obj, output_frame, domain)
end if
- if (MPAS_isAlarmRinging(clock, restartAlarmID, ierr=ierr)) then
- call MPAS_resetClockAlarm(clock, restartAlarmID, ierr=ierr)
- if (restart_frame == 1) call output_state_init(restart_obj, domain, "RESTART")
- call output_state_for_domain(restart_obj, domain, restart_frame)
+ if (mpas_is_alarm_ringing(clock, restartAlarmID, ierr=ierr)) then
+ call mpas_reset_clock_alarm(clock, restartAlarmID, ierr=ierr)
+ if (restart_frame == 1) call mpas_output_state_init(restart_obj, domain, "RESTART")
+ call mpas_output_state_for_domain(restart_obj, domain, restart_frame)
restart_frame = restart_frame + 1
end if
@@ -346,8 +346,8 @@
! before returning
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- use grid_types
- use io_output
+ use mpas_grid_types
+ use mpas_io_output
implicit none
@@ -365,7 +365,7 @@
block_ptr => block_ptr % next
end do
- call output_state_for_domain(output_obj, domain, output_frame)
+ call mpas_output_state_for_domain(output_obj, domain, output_frame)
output_frame = output_frame + 1
! if the maximum number of frames per outfile has been reached, finalize outfile and reset frame
@@ -373,7 +373,7 @@
current_outfile_frames = current_outfile_frames + 1
if(current_outfile_frames >= config_frames_per_outfile) then
current_outfile_frames = 0
- call output_state_finalize(output_obj, domain % dminfo)
+ call mpas_output_state_finalize(output_obj, domain % dminfo)
output_frame = 1
end if
end if
@@ -390,7 +390,7 @@
! Output: state - upon returning, diagnostic fields will have be computed
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- use grid_types
+ use mpas_grid_types
implicit none
@@ -404,8 +404,8 @@
subroutine mpas_timestep(domain, itimestep, dt, timeStamp)!{{{
- use grid_types
- use timer
+ use mpas_grid_types
+ use mpas_timer
use global_diagnostics
implicit none
@@ -428,17 +428,17 @@
'that there is only one block per processor.'
end if
- call timer_start("global diagnostics")
+ call mpas_timer_start("global diagnostics")
call computeGlobalDiagnostics(domain % dminfo, &
block_ptr % state % time_levs(2) % state, block_ptr % mesh, &
itimestep, dt)
- call timer_stop("global diagnostics")
+ call mpas_timer_stop("global diagnostics")
end if
end if
!TODO: replace the above code block with this if we desire to convert config_stats_interval to use alarms
- !if (MPAS_isAlarmRinging(clock, statsAlarmID, ierr=ierr)) then
- ! call MPAS_resetClockAlarm(clock, statsAlarmID, ierr=ierr)
+ !if (mpas_is_alarm_ringing(clock, statsAlarmID, ierr=ierr)) then
+ ! call mpas_reset_clock_alarm(clock, statsAlarmID, ierr=ierr)
! block_ptr => domain % blocklist
! if (associated(block_ptr % next)) then
@@ -446,11 +446,11 @@
! 'that there is only one block per processor.'
! end if
- ! call timer_start("global diagnostics")
+ ! call mpas_timer_start("global diagnostics")
! call computeGlobalDiagnostics(domain % dminfo, &
! block_ptr % state % time_levs(2) % state, block_ptr % mesh, &
! timeStamp, dt)
- ! call timer_stop("global diagnostics")
+ ! call mpas_timer_stop("global diagnostics")
!end if
end subroutine mpas_timestep!}}}
@@ -458,8 +458,8 @@
subroutine init_ZLevel(domain)!{{{
! Initialize maxLevel and bouncary grid variables.
- use grid_types
- use configure
+ use mpas_grid_types
+ use mpas_configure
implicit none
@@ -622,9 +622,9 @@
subroutine compute_maxLevel(domain)!{{{
! Initialize maxLevel and bouncary grid variables.
- use grid_types
- use configure
- use constants
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_constants
implicit none
@@ -744,7 +744,7 @@
subroutine mpas_core_finalize(domain)!{{{
- use grid_types
+ use mpas_grid_types
implicit none
@@ -752,16 +752,16 @@
type (domain_type), intent(inout) :: domain
- if (restart_frame > 1) call output_state_finalize(restart_obj, domain % dminfo)
+ if (restart_frame > 1) call mpas_output_state_finalize(restart_obj, domain % dminfo)
- call MPAS_destroyClock(clock, ierr)
+ call mpas_destroy_clock(clock, ierr)
end subroutine mpas_core_finalize!}}}
subroutine compute_mesh_scaling(mesh)!{{{
- use grid_types
- use configure
+ use mpas_grid_types
+ use mpas_configure
implicit none
Modified: trunk/mpas/src/core_ocean/mpas_ocn_restoring.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_restoring.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_ocean/mpas_ocn_restoring.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -14,8 +14,8 @@
module ocn_restoring
- use grid_types
- use configure
+ use mpas_grid_types
+ use mpas_configure
implicit none
private
Modified: trunk/mpas/src/core_ocean/mpas_ocn_tendency.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_tendency.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_ocean/mpas_ocn_tendency.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -16,10 +16,10 @@
module ocn_tendency
- use grid_types
- use configure
- use constants
- use timer
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_constants
+ use mpas_timer
use ocn_thick_hadv
use ocn_thick_vadv
@@ -131,7 +131,7 @@
real (kind=RKIND), allocatable, dimension(:,:) :: delsq_u
real (kind=RKIND), allocatable, dimension(:,:) :: delsq_circulation, delsq_vorticity
- call timer_start("ocn_tend_h")
+ call mpas_timer_start("ocn_tend_h")
h => s % h % array
u => s % u % array
@@ -192,22 +192,22 @@
!
! for z-level, only compute height tendency for top layer.
- call timer_start("ocn_tend_h-horiz adv")
+ call mpas_timer_start("ocn_tend_h-horiz adv")
call ocn_thick_hadv_tend(grid, u, h_edge, tend_h, err)
- call timer_stop("ocn_tend_h-horiz adv")
+ call mpas_timer_stop("ocn_tend_h-horiz adv")
!
! height tendency: vertical advection term -d/dz(hw)
!
! Vertical advection computed for top layer of a z grid only.
- call timer_start("ocn_tend_h-vert adv")
+ call mpas_timer_start("ocn_tend_h-vert adv")
call ocn_thick_vadv_tend(grid, wtop, tend_h, err)
- call timer_stop("ocn_tend_h-vert adv")
- call timer_stop("ocn_tend_h")
+ call mpas_timer_stop("ocn_tend_h-vert adv")
+ call mpas_timer_stop("ocn_tend_h")
end subroutine ocn_tend_h!}}}
@@ -274,7 +274,7 @@
real (kind=RKIND), dimension(:,:), pointer :: u_src
real (kind=RKIND), parameter :: rho_ref = 1000.0
- call timer_start("ocn_tend_u")
+ call mpas_timer_start("ocn_tend_u")
h => s % h % array
u => s % u % array
@@ -338,25 +338,25 @@
! velocity tendency: nonlinear Coriolis term and grad of kinetic energy
!
- call timer_start("ocn_tend_u-coriolis")
+ call mpas_timer_start("ocn_tend_u-coriolis")
call ocn_vel_coriolis_tend(grid, pv_edge, h_edge, u, ke, tend_u, err)
- call timer_stop("ocn_tend_u-coriolis")
+ call mpas_timer_stop("ocn_tend_u-coriolis")
!
! velocity tendency: vertical advection term -w du/dz
!
- call timer_start("ocn_tend_u-vert adv")
+ call mpas_timer_start("ocn_tend_u-vert adv")
call ocn_vel_vadv_tend(grid, u, wtop, tend_u, err)
- call timer_stop("ocn_tend_u-vert adv")
+ call mpas_timer_stop("ocn_tend_u-vert adv")
!
! velocity tendency: pressure gradient
!
- call timer_start("ocn_tend_u-pressure grad")
+ call mpas_timer_start("ocn_tend_u-pressure grad")
if (config_vert_grid_type.eq.'isopycnal') then
call ocn_vel_pressure_grad_tend(grid, MontPot, tend_u, err)
@@ -364,18 +364,18 @@
call ocn_vel_pressure_grad_tend(grid, pressure, tend_u, err)
end if
- call timer_stop("ocn_tend_u-pressure grad")
+ call mpas_timer_stop("ocn_tend_u-pressure grad")
!
! velocity tendency: del2 dissipation, </font>
<font color="black">u_2 </font>
<font color="black">abla^2 u
! computed as </font>
<font color="black">u( </font>
<font color="black">abla divergence + k \times </font>
<font color="gray">abla vorticity )
! strictly only valid for config_h_mom_eddy_visc2 == constant
!
- call timer_start("ocn_tend_u-horiz mix")
+ call mpas_timer_start("ocn_tend_u-horiz mix")
call ocn_vel_hmix_tend(grid, divergence, vorticity, tend_u, err)
- call timer_stop("ocn_tend_u-horiz mix")
+ call mpas_timer_stop("ocn_tend_u-horiz mix")
!
! velocity tendency: forcing and bottom drag
@@ -383,23 +383,23 @@
! mrp 101115 note: in order to include flux boundary conditions, we will need to
! know the bottom edge with nonzero velocity and place the drag there.
- call timer_start("ocn_tend_u-forcings")
+ call mpas_timer_start("ocn_tend_u-forcings")
call ocn_vel_forcing_tend(grid, u, u_src, ke_edge, h_edge, tend_u, err)
- call timer_stop("ocn_tend_u-forcings")
+ call mpas_timer_stop("ocn_tend_u-forcings")
!
! velocity tendency: vertical mixing d/dz( nu_v du/dz))
!
if (.not.config_implicit_vertical_mix) then
- call timer_start("ocn_tend_u-explicit vert mix")
+ call mpas_timer_start("ocn_tend_u-explicit vert mix")
call ocn_vel_vmix_tend_explicit(grid, u, h_edge, vertvisctopofedge, tend_u, err)
- call timer_stop("ocn_tend_u-explicit vert mix")
+ call mpas_timer_stop("ocn_tend_u-explicit vert mix")
endif
- call timer_stop("ocn_tend_u")
+ call mpas_timer_stop("ocn_tend_u")
end subroutine ocn_tend_u!}}}
@@ -465,7 +465,7 @@
integer :: index_temperature, index_salinity, rrr
real (kind=RKIND), dimension(:), pointer :: temperatureRestore, salinityRestore
- call timer_start("ocn_tend_scalar")
+ call mpas_timer_start("ocn_tend_scalar")
u => s % u % array
h => s % h % array
@@ -515,31 +515,31 @@
! and then change maxLevelEdgeTop to maxLevelEdgeBot in the following section.
! tracer_edge at the boundary will also need to be defined for flux boundaries.
- call timer_start("ocn_tend_scalar-horiz adv")
+ call mpas_timer_start("ocn_tend_scalar-horiz adv")
call ocn_tracer_hadv_tend(grid, u, h_edge, tracers, tend_tr, err)
- call timer_stop("ocn_tend_scalar-horiz adv")
+ call mpas_timer_stop("ocn_tend_scalar-horiz adv")
!
! tracer tendency: vertical advection term -d/dz( h \phi w)
!
- call timer_start("ocn_tend_scalar-vert adv")
+ call mpas_timer_start("ocn_tend_scalar-vert adv")
call ocn_tracer_vadv_tend(grid, wtop, tracers, tend_tr, err)
- call timer_stop("ocn_tend_scalar-vert adv")
+ call mpas_timer_stop("ocn_tend_scalar-vert adv")
!
! tracer tendency: del2 horizontal tracer diffusion, div(h \kappa_2 </font>
<font color="gray">abla \phi)
!
- call timer_start("ocn_tend_scalar-horiz diff")
+ call mpas_timer_start("ocn_tend_scalar-horiz diff")
call ocn_tracer_hmix_tend(grid, h_edge, tracers, tend_tr, err)
- call timer_stop("ocn_tend_scalar-horiz diff")
+ call mpas_timer_stop("ocn_tend_scalar-horiz diff")
! mrp 110516 printing
!print *, 'tend_tr 1',minval(tend_tr(3,1,1:nCells)),&
@@ -552,11 +552,11 @@
! tracer tendency: vertical diffusion h d/dz( \kappa_v d\phi/dz)
!
if (.not.config_implicit_vertical_mix) then
- call timer_start("ocn_tend_scalar-explicit vert diff")
+ call mpas_timer_start("ocn_tend_scalar-explicit vert diff")
call ocn_tracer_vmix_tend_explicit(grid, h, vertdifftopofcell, tracers, tend_tr, err)
- call timer_stop("ocn_tend_scalar-explicit vert diff")
+ call mpas_timer_stop("ocn_tend_scalar-explicit vert diff")
endif
! mrp 110516 printing
@@ -567,14 +567,14 @@
!
! add restoring to T and S in top model layer
!
- call timer_start("ocn_tend_scalar-restoring")
+ call mpas_timer_start("ocn_tend_scalar-restoring")
call ocn_restoring_tend(grid, h, s%index_temperature, s%index_salinity, tracers, tend_tr, err)
- call timer_stop("ocn_tend_scalar-restoring")
+ call mpas_timer_stop("ocn_tend_scalar-restoring")
10 format(2i8,10e20.10)
- call timer_stop("ocn_tend_scalar")
+ call mpas_timer_stop("ocn_tend_scalar")
end subroutine ocn_tend_scalar!}}}
@@ -637,7 +637,7 @@
real (kind=RKIND) :: coef_3rd_order
real (kind=RKIND) :: r, h1, h2
- call timer_start("ocn_diagnostic_solve")
+ call mpas_timer_start("ocn_diagnostic_solve")
h => s % h % array
u => s % u % array
@@ -703,14 +703,14 @@
! mrp 110516 efficiency note: For z-level, only do this on level 1. h_edge for all
! lower levels is defined by hZlevel.
- call timer_start("ocn_diagnostic_solve-hEdge")
+ call mpas_timer_start("ocn_diagnostic_solve-hEdge")
coef_3rd_order = 0.
if (config_thickness_adv_order == 3) coef_3rd_order = 1.0
if (config_thickness_adv_order == 3 .and. config_monotonic) coef_3rd_order = 0.25
if (config_thickness_adv_order == 2) then
- call timer_start("ocn_diagnostic_solve-hEdge 2")
+ call mpas_timer_start("ocn_diagnostic_solve-hEdge 2")
do iEdge=1,nEdges
cell1 = cellsOnEdge(1,iEdge)
@@ -719,10 +719,10 @@
h_edge(k,iEdge) = 0.5 * (h(k,cell1) + h(k,cell2))
end do
end do
- call timer_stop("ocn_diagnostic_solve-hEdge 2")
+ call mpas_timer_stop("ocn_diagnostic_solve-hEdge 2")
else if (config_thickness_adv_order == 3) then
- call timer_start("ocn_diagnostic_solve-hEdge 3")
+ call mpas_timer_start("ocn_diagnostic_solve-hEdge 3")
do iEdge=1,nEdges
cell1 = cellsOnEdge(1,iEdge)
@@ -770,9 +770,9 @@
end do ! do k
end do ! do iEdge
- call timer_stop("ocn_diagnostic_solve-hEdge 3")
+ call mpas_timer_stop("ocn_diagnostic_solve-hEdge 3")
else if (config_thickness_adv_order == 4) then
- call timer_start("ocn_diagnostic_solve-hEdge 4")
+ call mpas_timer_start("ocn_diagnostic_solve-hEdge 4")
do iEdge=1,nEdges
cell1 = cellsOnEdge(1,iEdge)
@@ -810,9 +810,9 @@
end do ! do k
end do ! do iEdge
- call timer_stop("ocn_diagnostic_solve-hEdge 4")
+ call mpas_timer_stop("ocn_diagnostic_solve-hEdge 4")
endif ! if(config_thickness_adv_order == 2)
- call timer_stop("ocn_diagnostic_solve-hEdge")
+ call mpas_timer_stop("ocn_diagnostic_solve-hEdge")
!
! set the velocity and height at dummy address
@@ -1070,7 +1070,7 @@
call ocn_wtop(s,grid)
- call timer_stop("ocn_diagnostic_solve")
+ call mpas_timer_stop("ocn_diagnostic_solve")
end subroutine ocn_diagnostic_solve!}}}
@@ -1121,7 +1121,7 @@
maxLevelCell, maxLevelEdgeTop, maxLevelEdgeBot, &
maxLevelVertexBot, maxLevelVertexTop
- call timer_start("wTop")
+ call mpas_timer_start("wTop")
u => s % u % array
wTop => s % wTop % array
@@ -1176,7 +1176,7 @@
endif
- call timer_stop("wTop")
+ call mpas_timer_stop("wTop")
end subroutine ocn_wtop!}}}
@@ -1241,7 +1241,7 @@
real (kind=RKIND), dimension(:,:), pointer :: u_src
real (kind=RKIND), parameter :: rho_ref = 1000.0
- call timer_start("ocn_fuperp")
+ call mpas_timer_start("ocn_fuperp")
h => s % h % array
u => s % u % array
@@ -1305,7 +1305,7 @@
end do
end do
- call timer_stop("ocn_fuperp")
+ call mpas_timer_stop("ocn_fuperp")
end subroutine ocn_fuperp!}}}
Modified: trunk/mpas/src/core_ocean/mpas_ocn_test_cases.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_test_cases.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_ocean/mpas_ocn_test_cases.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -1,8 +1,8 @@
module test_cases
- use grid_types
- use configure
- use constants
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_constants
contains
@@ -72,14 +72,14 @@
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)
+ call mpas_dmpar_abort(dminfo)
end if
block_ptr => domain % blocklist
do while (associated(block_ptr))
do i=2,nTimeLevs
- call copy_state(block_ptr % state % time_levs(i) % state, &
+ call mpas_copy_state(block_ptr % state % time_levs(i) % state, &
block_ptr % state % time_levs(1) % state)
end do
Modified: trunk/mpas/src/core_ocean/mpas_ocn_thick_hadv.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_thick_hadv.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_ocean/mpas_ocn_thick_hadv.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -14,8 +14,8 @@
module ocn_thick_hadv
- use grid_types
- use configure
+ use mpas_grid_types
+ use mpas_configure
implicit none
private
Modified: trunk/mpas/src/core_ocean/mpas_ocn_thick_vadv.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_thick_vadv.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_ocean/mpas_ocn_thick_vadv.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -14,8 +14,8 @@
module ocn_thick_vadv
- use grid_types
- use configure
+ use mpas_grid_types
+ use mpas_configure
implicit none
private
Modified: trunk/mpas/src/core_ocean/mpas_ocn_time_integration.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_time_integration.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_ocean/mpas_ocn_time_integration.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -14,13 +14,13 @@
module ocn_time_integration
- use grid_types
- use configure
- use constants
- use dmpar
- use vector_reconstruction
- use spline_interpolation
- use timer
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_constants
+ use mpas_dmpar
+ use mpas_vector_reconstruction
+ use mpas_spline_interpolation
+ use mpas_timer
use ocn_time_integration_rk4
use ocn_time_integration_split
@@ -100,7 +100,7 @@
if (isNaN(sum(block % state % time_levs(2) % state % u % array))) then
write(0,*) 'Abort: NaN detected'
- call dmpar_abort(dminfo)
+ call mpas_dmpar_abort(dminfo)
endif
block => block % next
Modified: trunk/mpas/src/core_ocean/mpas_ocn_time_integration_rk4.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_time_integration_rk4.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_ocean/mpas_ocn_time_integration_rk4.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -13,13 +13,13 @@
module ocn_time_integration_rk4
- use grid_types
- use configure
- use constants
- use dmpar
- use vector_reconstruction
- use spline_interpolation
- use timer
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_constants
+ use mpas_dmpar
+ use mpas_vector_reconstruction
+ use mpas_spline_interpolation
+ use mpas_timer
use ocn_tendency
@@ -95,7 +95,7 @@
block => domain % blocklist
- call allocate_state(provis, &
+ call mpas_allocate_state(provis, &
block % mesh % nCells, block % mesh % nEdges, block % mesh % maxEdges, block % mesh % maxEdges2, &
block % mesh % nVertices, block % mesh % vertexDegree, block % mesh % nVertLevels )
@@ -117,7 +117,7 @@
end do
end do
- call copy_state(provis, block % state % time_levs(1) % state)
+ call mpas_copy_state(provis, block % state % time_levs(1) % state)
block => block % next
end do
@@ -133,36 +133,36 @@
rk_substep_weights(4) = 0.
- call timer_start("RK4-main loop")
+ call mpas_timer_start("RK4-main loop")
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! BEGIN RK loop
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
do rk_step = 1, 4
! --- update halos for diagnostic variables
- call timer_start("RK4-diagnostic halo update")
+ call mpas_timer_start("RK4-diagnostic halo update")
block => domain % blocklist
do while (associated(block))
- call dmpar_exch_halo_field2dReal(domain % dminfo, provis % pv_edge % array(:,:), &
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, provis % pv_edge % array(:,:), &
block % mesh % nVertLevels, block % mesh % nEdges, &
block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
if (config_h_mom_eddy_visc4 > 0.0) then
- call dmpar_exch_halo_field2dReal(domain % dminfo, provis % divergence % array(:,:), &
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % divergence % array(:,:), &
block % mesh % nVertLevels, block % mesh % nCells, &
block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call dmpar_exch_halo_field2dReal(domain % dminfo, provis % vorticity % array(:,:), &
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % vorticity % array(:,:), &
block % mesh % nVertLevels, block % mesh % nVertices, &
block % parinfo % verticesToSend, block % parinfo % verticesToRecv)
end if
block => block % next
end do
- call timer_stop("RK4-diagnostic halo update")
+ call mpas_timer_stop("RK4-diagnostic halo update")
! --- compute tendencies
- call timer_start("RK4-tendency computations")
+ call mpas_timer_start("RK4-tendency computations")
block => domain % blocklist
do while (associated(block))
if (.not.config_implicit_vertical_mix) then
@@ -181,29 +181,29 @@
call enforce_boundaryEdge(block % tend, block % mesh)
block => block % next
end do
- call timer_stop("RK4-tendency computations")
+ call mpas_timer_stop("RK4-tendency computations")
! --- update halos for prognostic variables
- call timer_start("RK4-pronostic halo update")
+ call mpas_timer_start("RK4-pronostic halo update")
block => domain % blocklist
do while (associated(block))
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % tend % u % array(:,:), &
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % tend % u % array(:,:), &
block % mesh % nVertLevels, block % mesh % nEdges, &
block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % tend % h % array(:,:), &
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % tend % h % array(:,:), &
block % mesh % nVertLevels, block % mesh % nCells, &
block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call dmpar_exch_halo_field3dReal(domain % dminfo, block % tend % tracers % array(:,:,:), &
+ call mpas_dmpar_exch_halo_field3d_real(domain % dminfo, block % tend % tracers % array(:,:,:), &
block % tend % num_tracers, block % mesh % nVertLevels, block % mesh % nCells, &
block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
block => block % next
end do
- call timer_stop("RK4-pronostic halo update")
+ call mpas_timer_stop("RK4-pronostic halo update")
! --- compute next substep state
- call timer_start("RK4-update diagnostic variables")
+ call mpas_timer_start("RK4-update diagnostic variables")
if (rk_step < 4) then
block => domain % blocklist
do while (associated(block))
@@ -232,13 +232,13 @@
block => block % next
end do
end if
- call timer_stop("RK4-update diagnostic variables")
+ call mpas_timer_stop("RK4-update diagnostic variables")
!--- accumulate update (for RK4)
- call timer_start("RK4-RK4 accumulate update")
+ call mpas_timer_start("RK4-RK4 accumulate update")
block => domain % blocklist
do while (associated(block))
block % state % time_levs(2) % state % u % array(:,:) = block % state % time_levs(2) % state % u % array(:,:) &
@@ -257,18 +257,18 @@
block => block % next
end do
- call timer_stop("RK4-RK4 accumulate update")
+ call mpas_timer_stop("RK4-RK4 accumulate update")
end do
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! END RK loop
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- call timer_stop("RK4-main loop")
+ call mpas_timer_stop("RK4-main loop")
!
! A little clean up at the end: decouple new scalar fields and compute diagnostics for new state
!
- call timer_start("RK4-cleaup phase")
+ call mpas_timer_start("RK4-cleaup phase")
block => domain % blocklist
do while (associated(block))
@@ -294,7 +294,7 @@
end do
if (config_implicit_vertical_mix) then
- call timer_start("RK4-implicit vert mix")
+ call mpas_timer_start("RK4-implicit vert mix")
allocate(A(nVertLevels),C(nVertLevels),uTemp(nVertLevels), &
tracersTemp(num_tracers,nVertLevels))
@@ -320,7 +320,7 @@
! mrp 110725 momentum decay term
if (config_mom_decay) then
- call timer_start("RK4-momentum decay")
+ call mpas_timer_start("RK4-momentum decay")
!
! Implicit solve for momentum decay
@@ -337,7 +337,7 @@
end do
end do
- call timer_stop("RK4-momentum decay")
+ call mpas_timer_stop("RK4-momentum decay")
end if
@@ -347,7 +347,7 @@
call ocn_diagnostic_solve(dt, block % state % time_levs(2) % state, block % mesh)
- call reconstruct(block % mesh, block % state % time_levs(2) % state % u % array, &
+ call mpas_reconstruct(block % mesh, block % state % time_levs(2) % state % u % array, &
block % state % time_levs(2) % state % uReconstructX % array, &
block % state % time_levs(2) % state % uReconstructY % array, &
block % state % time_levs(2) % state % uReconstructZ % array, &
@@ -357,9 +357,9 @@
block => block % next
end do
- call timer_stop("RK4-cleaup phase")
+ call mpas_timer_stop("RK4-cleaup phase")
- call deallocate_state(provis)
+ call mpas_deallocate_state(provis)
end subroutine ocn_time_integrator_rk4!}}}
@@ -412,7 +412,7 @@
real (kind=RKIND), dimension(:,:), pointer :: u_src
real (kind=RKIND), parameter :: rho_ref = 1000.0
- call timer_start("filter_btr_mode_tend_u")
+ call mpas_timer_start("filter_btr_mode_tend_u")
h => s % h % array
u => s % u % array
@@ -484,7 +484,7 @@
enddo ! iEdge
- call timer_stop("filter_btr_mode_tend_u")
+ call mpas_timer_stop("filter_btr_mode_tend_u")
end subroutine filter_btr_mode_tend_u!}}}
@@ -535,7 +535,7 @@
real (kind=RKIND), dimension(:,:), pointer :: u_src
real (kind=RKIND), parameter :: rho_ref = 1000.0
- call timer_start("filter_btr_mode_u")
+ call mpas_timer_start("filter_btr_mode_u")
h => s % h % array
u => s % u % array
@@ -603,7 +603,7 @@
enddo ! iEdge
- call timer_stop("filter_btr_mode_u")
+ call mpas_timer_stop("filter_btr_mode_u")
end subroutine filter_btr_mode_u!}}}
@@ -627,7 +627,7 @@
integer :: nCells, nEdges, nVertices, nVertLevels
integer :: iEdge, k
- call timer_start("enforce_boundaryEdge")
+ call mpas_timer_start("enforce_boundaryEdge")
nCells = grid % nCells
nEdges = grid % nEdges
@@ -648,7 +648,7 @@
enddo
enddo
- call timer_stop("enforce_boundaryEdge")
+ call mpas_timer_stop("enforce_boundaryEdge")
end subroutine enforce_boundaryEdge!}}}
Modified: trunk/mpas/src/core_ocean/mpas_ocn_time_integration_split.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_time_integration_split.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_ocean/mpas_ocn_time_integration_split.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -15,13 +15,13 @@
module ocn_time_integration_split
- use grid_types
- use configure
- use constants
- use dmpar
- use vector_reconstruction
- use spline_interpolation
- use timer
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_constants
+ use mpas_dmpar
+ use mpas_vector_reconstruction
+ use mpas_spline_interpolation
+ use mpas_timer
use ocn_tendency
@@ -99,7 +99,7 @@
real (kind=RKIND), dimension(:), allocatable:: A,C,uTemp, hNew
real (kind=RKIND), dimension(:,:), allocatable:: tracersTemp
- call timer_start("split_explicit_timestep")
+ call mpas_timer_start("split_explicit_timestep")
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
@@ -160,15 +160,15 @@
block => domain % blocklist
do while (associated(block))
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % state % time_levs(2) % state % pv_edge % array(:,:), &
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % pv_edge % array(:,:), &
block % mesh % nVertLevels, block % mesh % nEdges, &
block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
if (config_h_mom_eddy_visc4 > 0.0) then
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % state % time_levs(2) % state % divergence % array(:,:), &
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % divergence % array(:,:), &
block % mesh % nVertLevels, block % mesh % nCells, &
block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % state % time_levs(2) % state % vorticity % array(:,:), &
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % vorticity % array(:,:), &
block % mesh % nVertLevels, block % mesh % nVertices, &
block % parinfo % verticesToSend, block % parinfo % verticesToRecv)
end if
@@ -267,7 +267,7 @@
block => domain % blocklist
do while (associated(block))
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % state % time_levs(2) % state % uBcl % array(:,:), &
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % uBcl % array(:,:), &
block % mesh % nVertLevels, block % mesh % nEdges, &
block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
@@ -416,7 +416,7 @@
block => domain % blocklist
do while (associated(block))
- call dmpar_exch_halo_field1dReal(domain % dminfo, &
+ call mpas_dmpar_exch_halo_field1d_real(domain % dminfo, &
block % state % time_levs(newBtrSubcycleTime) % state % uBtrSubcycle % array(:), &
block % mesh % nEdges, &
block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
@@ -492,7 +492,7 @@
! block % state % time_levs(newBtrSubcycleTime) % state % sshSubcycle % array(:), &
- call dmpar_exch_halo_field1dReal(domain % dminfo, &
+ call mpas_dmpar_exch_halo_field1d_real(domain % dminfo, &
block % state % time_levs(newBtrSubcycleTime) % state % sshSubcycle % array(:), &
block % mesh % nCells, &
block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
@@ -660,7 +660,7 @@
block => domain % blocklist
do while (associated(block))
- call dmpar_exch_halo_field1dReal(domain % dminfo, &
+ call mpas_dmpar_exch_halo_field1d_real(domain % dminfo, &
block % state % time_levs(newBtrSubcycleTime) % state % uBtrSubcycle % array(:), &
block % mesh % nEdges, &
block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
@@ -729,7 +729,7 @@
block => domain % blocklist
do while (associated(block))
- call dmpar_exch_halo_field1dReal(domain % dminfo, &
+ call mpas_dmpar_exch_halo_field1d_real(domain % dminfo, &
block % state % time_levs(newBtrSubcycleTime) % state % sshSubcycle % array(:), &
block % mesh % nCells, &
block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
@@ -802,7 +802,7 @@
else
write(0,*) 'Abort: Unknown config_SSH_from option: '&
//trim(config_SSH_from)
- call dmpar_abort(dminfo)
+ call mpas_dmpar_abort(dminfo)
endif
block => block % next
@@ -813,7 +813,7 @@
block => domain % blocklist
do while (associated(block))
- call dmpar_exch_halo_field1dReal(domain % dminfo, &
+ call mpas_dmpar_exch_halo_field1d_real(domain % dminfo, &
block % state % time_levs(1) % state % FBtr % array(:), &
block % mesh % nEdges, &
block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
@@ -967,10 +967,10 @@
block => domain % blocklist
do while (associated(block))
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % tend % h % array(:,:), &
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % tend % h % array(:,:), &
block % mesh % nVertLevels, block % mesh % nCells, &
block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call dmpar_exch_halo_field3dReal(domain % dminfo, block % tend % tracers % array(:,:,:), &
+ call mpas_dmpar_exch_halo_field3d_real(domain % dminfo, block % tend % tracers % array(:,:,:), &
block % tend % num_tracers, block % mesh % nVertLevels, block % mesh % nCells, &
block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
block => block % next
@@ -1110,7 +1110,7 @@
else
write(0,*) 'Abort: Unknown config_new_btr_variables_from: '&
//trim(config_time_integration)
- call dmpar_abort(dminfo)
+ call mpas_dmpar_abort(dminfo)
endif
! Recompute final u to go on to next step.
@@ -1226,7 +1226,7 @@
call ocn_diagnostic_solve(dt, block % state % time_levs(2) % state, block % mesh)
- call reconstruct(block % mesh, block % state % time_levs(2) % state % u % array, &
+ call mpas_reconstruct(block % mesh, block % state % time_levs(2) % state % u % array, &
block % state % time_levs(2) % state % uReconstructX % array, &
block % state % time_levs(2) % state % uReconstructY % array, &
block % state % time_levs(2) % state % uReconstructZ % array, &
@@ -1236,7 +1236,7 @@
block => block % next
end do
- call timer_stop("split_explicit_timestep")
+ call mpas_timer_stop("split_explicit_timestep")
end subroutine ocn_time_integrator_split!}}}
@@ -1289,7 +1289,7 @@
real (kind=RKIND), dimension(:,:), pointer :: u_src
real (kind=RKIND), parameter :: rho_ref = 1000.0
- call timer_start("filter_btr_mode_tend_u")
+ call mpas_timer_start("filter_btr_mode_tend_u")
h => s % h % array
u => s % u % array
@@ -1361,7 +1361,7 @@
enddo ! iEdge
- call timer_stop("filter_btr_mode_tend_u")
+ call mpas_timer_stop("filter_btr_mode_tend_u")
end subroutine filter_btr_mode_tend_u!}}}
@@ -1412,7 +1412,7 @@
real (kind=RKIND), dimension(:,:), pointer :: u_src
real (kind=RKIND), parameter :: rho_ref = 1000.0
- call timer_start("filter_btr_mode_u")
+ call mpas_timer_start("filter_btr_mode_u")
h => s % h % array
u => s % u % array
@@ -1480,7 +1480,7 @@
enddo ! iEdge
- call timer_stop("filter_btr_mode_u")
+ call mpas_timer_stop("filter_btr_mode_u")
end subroutine filter_btr_mode_u!}}}
@@ -1504,7 +1504,7 @@
integer :: nCells, nEdges, nVertices, nVertLevels
integer :: iEdge, k
- call timer_start("enforce_boundaryEdge")
+ call mpas_timer_start("enforce_boundaryEdge")
nCells = grid % nCells
nEdges = grid % nEdges
@@ -1525,7 +1525,7 @@
enddo
enddo
- call timer_stop("enforce_boundaryEdge")
+ call mpas_timer_stop("enforce_boundaryEdge")
end subroutine enforce_boundaryEdge!}}}
Modified: trunk/mpas/src/core_ocean/mpas_ocn_tracer_hadv.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_tracer_hadv.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_ocean/mpas_ocn_tracer_hadv.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -14,8 +14,8 @@
module ocn_tracer_hadv
- use grid_types
- use configure
+ use mpas_grid_types
+ use mpas_configure
use ocn_tracer_hadv2
use ocn_tracer_hadv3
Modified: trunk/mpas/src/core_ocean/mpas_ocn_tracer_hadv2.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_tracer_hadv2.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_ocean/mpas_ocn_tracer_hadv2.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -14,9 +14,9 @@
module ocn_tracer_hadv2
- use grid_types
- use configure
- use timer
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_timer
implicit none
private
@@ -127,7 +127,7 @@
if(.not.hadv2On) return
- call timer_start("compute_scalar_tend-horiz adv 2")
+ call mpas_timer_start("compute_scalar_tend-horiz adv 2")
nEdges = grid % nEdges
maxLevelEdgeTop => grid % maxLevelEdgeTop % array
@@ -149,7 +149,7 @@
end do
end do
- call timer_stop("compute_scalar_tend-horiz adv 2")
+ call mpas_timer_stop("compute_scalar_tend-horiz adv 2")
!--------------------------------------------------------------------
end subroutine ocn_tracer_hadv2_tend!}}}
Modified: trunk/mpas/src/core_ocean/mpas_ocn_tracer_hadv3.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_tracer_hadv3.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_ocean/mpas_ocn_tracer_hadv3.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -14,9 +14,9 @@
module ocn_tracer_hadv3
- use grid_types
- use configure
- use timer
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_timer
implicit none
private
@@ -142,7 +142,7 @@
areaCell => grid % areaCell % array
deriv_two => grid % deriv_two % array
- call timer_start("compute_scalar_tend-horiz adv 3")
+ call mpas_timer_start("compute_scalar_tend-horiz adv 3")
do iEdge=1,nEdges
cell1 = cellsOnEdge(1,iEdge)
cell2 = cellsOnEdge(2,iEdge)
@@ -194,7 +194,7 @@
enddo
end do
end do
- call timer_stop("compute_scalar_tend-horiz adv 3")
+ call mpas_timer_stop("compute_scalar_tend-horiz adv 3")
!--------------------------------------------------------------------
Modified: trunk/mpas/src/core_ocean/mpas_ocn_tracer_hadv4.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_tracer_hadv4.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_ocean/mpas_ocn_tracer_hadv4.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -14,9 +14,9 @@
module ocn_tracer_hadv4
- use grid_types
- use configure
- use timer
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_timer
implicit none
private
@@ -139,7 +139,7 @@
areaCell => grid % areaCell % array
deriv_two => grid % deriv_two % array
- call timer_start("compute_scalar_tend-horiz adv 4")
+ call mpas_timer_start("compute_scalar_tend-horiz adv 4")
do iEdge=1,nEdges
cell1 = cellsOnEdge(1,iEdge)
@@ -182,7 +182,7 @@
enddo
end do
end do
- call timer_stop("compute_scalar_tend-horiz adv 4")
+ call mpas_timer_stop("compute_scalar_tend-horiz adv 4")
!--------------------------------------------------------------------
Modified: trunk/mpas/src/core_ocean/mpas_ocn_tracer_hmix.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_tracer_hmix.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_ocean/mpas_ocn_tracer_hmix.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -16,8 +16,8 @@
module ocn_tracer_hmix
- use grid_types
- use configure
+ use mpas_grid_types
+ use mpas_configure
use ocn_tracer_hmix_del2
use ocn_tracer_hmix_del4
Modified: trunk/mpas/src/core_ocean/mpas_ocn_tracer_hmix_del2.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_tracer_hmix_del2.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_ocean/mpas_ocn_tracer_hmix_del2.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -16,9 +16,9 @@
module ocn_tracer_hmix_del2
- use grid_types
- use configure
- use timer
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_timer
implicit none
private
@@ -134,7 +134,7 @@
if (.not.del2On) return
- call timer_start("compute_scalar_tend-horiz diff 2")
+ call mpas_timer_start("compute_scalar_tend-horiz diff 2")
nEdges = grid % nEdges
nVertLevels = grid % nVertLevels
@@ -179,7 +179,7 @@
end do
deallocate(boundaryMask)
- call timer_stop("compute_scalar_tend-horiz diff 2")
+ call mpas_timer_stop("compute_scalar_tend-horiz diff 2")
!--------------------------------------------------------------------
Modified: trunk/mpas/src/core_ocean/mpas_ocn_tracer_hmix_del4.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_tracer_hmix_del4.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_ocean/mpas_ocn_tracer_hmix_del4.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -16,9 +16,9 @@
module ocn_tracer_hmix_del4
- use grid_types
- use configure
- use timer
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_timer
implicit none
private
@@ -135,7 +135,7 @@
if (.not.Del4On) return
- call timer_start("compute_scalar_tend-horiz diff 4")
+ call mpas_timer_start("compute_scalar_tend-horiz diff 4")
nEdges = grid % nEdges
nCells = grid % nCells
@@ -212,7 +212,7 @@
end do
deallocate(delsq_tracer)
- call timer_stop("compute_scalar_tend-horiz diff 4")
+ call mpas_timer_stop("compute_scalar_tend-horiz diff 4")
!--------------------------------------------------------------------
end subroutine ocn_tracer_hmix_del4_tend!}}}
Modified: trunk/mpas/src/core_ocean/mpas_ocn_tracer_vadv.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_tracer_vadv.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_ocean/mpas_ocn_tracer_vadv.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -14,8 +14,8 @@
module ocn_tracer_vadv
- use grid_types
- use configure
+ use mpas_grid_types
+ use mpas_configure
use ocn_tracer_vadv_stencil
use ocn_tracer_vadv_spline
Modified: trunk/mpas/src/core_ocean/mpas_ocn_tracer_vadv_spline.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_tracer_vadv_spline.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_ocean/mpas_ocn_tracer_vadv_spline.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -14,8 +14,8 @@
module ocn_tracer_vadv_spline
- use grid_types
- use configure
+ use mpas_grid_types
+ use mpas_configure
use ocn_tracer_vadv_spline2
use ocn_tracer_vadv_spline3
Modified: trunk/mpas/src/core_ocean/mpas_ocn_tracer_vadv_spline2.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_tracer_vadv_spline2.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_ocean/mpas_ocn_tracer_vadv_spline2.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -14,9 +14,9 @@
module ocn_tracer_vadv_spline2
- use grid_types
- use configure
- use timer
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_timer
implicit none
private
@@ -125,7 +125,7 @@
if(.not.spline2On) return
! Compute tracerTop using linear interpolation.
- call timer_start("compute_scalar_tend-vert adv spline 2")
+ call mpas_timer_start("compute_scalar_tend-vert adv spline 2")
nCells = grid % nCells
nCellsSolve = grid % nCellsSolve
@@ -162,7 +162,7 @@
deallocate(tracerTop)
- call timer_stop("compute_scalar_tend-vert adv spline 2")
+ call mpas_timer_stop("compute_scalar_tend-vert adv spline 2")
!--------------------------------------------------------------------
end subroutine ocn_tracer_vadv_spline2_tend!}}}
Modified: trunk/mpas/src/core_ocean/mpas_ocn_tracer_vadv_spline3.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_tracer_vadv_spline3.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_ocean/mpas_ocn_tracer_vadv_spline3.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -14,10 +14,10 @@
module ocn_tracer_vadv_spline3
- use grid_types
- use configure
- use timer
- use spline_interpolation
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_timer
+ use mpas_spline_interpolation
implicit none
private
@@ -129,7 +129,7 @@
if(.not.spline3On) return
! Compute tracerTop using linear interpolation.
- call timer_start("compute_scalar_tend-vert adv spline 3")
+ call mpas_timer_start("compute_scalar_tend-vert adv spline 3")
nCells = grid % nCells
nCellsSolve = grid % nCellsSolve
@@ -165,10 +165,10 @@
! subroutine call.
tracersIn(1:maxLevelCell(iCell))=tracers(iTracer,1:maxLevelCell(iCell),iCell)
- call CubicSplineCoefficients(posZMidZLevel, &
+ call mpas_cubic_spline_coefficients(posZMidZLevel, &
tracersIn, maxLevelCell(iCell), tracer2ndDer)
- call InterpolateCubicSpline( &
+ call mpas_interpolate_cubic_spline( &
posZMidZLevel, tracersIn, tracer2ndDer, maxLevelCell(iCell), &
posZTopZLevel, tracersOut, maxLevelCell(iCell)-1 )
@@ -191,7 +191,7 @@
deallocate(tracersIn,tracersOut, posZMidZLevel, posZTopZLevel)
deallocate(tracerTop)
- call timer_stop("compute_scalar_tend-vert adv spline 3")
+ call mpas_timer_stop("compute_scalar_tend-vert adv spline 3")
!--------------------------------------------------------------------
end subroutine ocn_tracer_vadv_spline3_tend!}}}
Modified: trunk/mpas/src/core_ocean/mpas_ocn_tracer_vadv_stencil.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_tracer_vadv_stencil.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_ocean/mpas_ocn_tracer_vadv_stencil.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -14,8 +14,8 @@
module ocn_tracer_vadv_stencil
- use grid_types
- use configure
+ use mpas_grid_types
+ use mpas_configure
use ocn_tracer_vadv_stencil2
use ocn_tracer_vadv_stencil3
Modified: trunk/mpas/src/core_ocean/mpas_ocn_tracer_vadv_stencil2.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_tracer_vadv_stencil2.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_ocean/mpas_ocn_tracer_vadv_stencil2.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -14,9 +14,9 @@
module ocn_tracer_vadv_stencil2
- use grid_types
- use configure
- use timer
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_timer
implicit none
private
@@ -125,7 +125,7 @@
if(.not. stencil2On) return
- call timer_start("compute_scalar_tend-vert adv stencil 2")
+ call mpas_timer_start("compute_scalar_tend-vert adv stencil 2")
nCells = grid % nCells
nCellsSolve = grid % nCellsSolve
@@ -158,7 +158,7 @@
end do
deallocate(tracerTop)
- call timer_stop("compute_scalar_tend-vert adv stencil 2")
+ call mpas_timer_stop("compute_scalar_tend-vert adv stencil 2")
!--------------------------------------------------------------------
Modified: trunk/mpas/src/core_ocean/mpas_ocn_tracer_vadv_stencil3.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_tracer_vadv_stencil3.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_ocean/mpas_ocn_tracer_vadv_stencil3.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -14,9 +14,9 @@
module ocn_tracer_vadv_stencil3
- use grid_types
- use configure
- use timer
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_timer
implicit none
private
@@ -134,7 +134,7 @@
hRatioZLevelK => grid % hRatioZLevelK % array
hRatioZLevelKm1 => grid % hRatioZLevelKm1 % array
- call timer_start("compute_scalar_tend-vert adv stencil 3")
+ call mpas_timer_start("compute_scalar_tend-vert adv stencil 3")
allocate(tracerTop(num_tracers,nVertLevels+1,nCells))
@@ -181,7 +181,7 @@
end do
deallocate(tracerTop)
- call timer_stop("compute_scalar_tend-vert adv stencil 3")
+ call mpas_timer_stop("compute_scalar_tend-vert adv stencil 3")
!--------------------------------------------------------------------
Modified: trunk/mpas/src/core_ocean/mpas_ocn_tracer_vadv_stencil4.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_tracer_vadv_stencil4.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_ocean/mpas_ocn_tracer_vadv_stencil4.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -14,9 +14,9 @@
module ocn_tracer_vadv_stencil4
- use grid_types
- use configure
- use timer
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_timer
implicit none
private
@@ -126,7 +126,7 @@
if(.not. Stencil4On) return
- call timer_start("compute_scalar_tend-vert adv stencil 4")
+ call mpas_timer_start("compute_scalar_tend-vert adv stencil 4")
nCells = grid % nCells
nCellsSolve = grid % nCellsSolve
@@ -176,7 +176,7 @@
end do
deallocate(tracerTop)
- call timer_stop("compute_scalar_tend-vert adv stencil 4")
+ call mpas_timer_stop("compute_scalar_tend-vert adv stencil 4")
!--------------------------------------------------------------------
Modified: trunk/mpas/src/core_ocean/mpas_ocn_vel_coriolis.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_vel_coriolis.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_ocean/mpas_ocn_vel_coriolis.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -15,8 +15,8 @@
module ocn_vel_coriolis
- use grid_types
- use configure
+ use mpas_grid_types
+ use mpas_configure
implicit none
private
Modified: trunk/mpas/src/core_ocean/mpas_ocn_vel_forcing.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_vel_forcing.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_ocean/mpas_ocn_vel_forcing.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -14,8 +14,8 @@
module ocn_vel_forcing
- use grid_types
- use configure
+ use mpas_grid_types
+ use mpas_configure
use ocn_vel_forcing_windstress
use ocn_vel_forcing_bottomdrag
Modified: trunk/mpas/src/core_ocean/mpas_ocn_vel_forcing_bottomdrag.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_vel_forcing_bottomdrag.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_ocean/mpas_ocn_vel_forcing_bottomdrag.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -14,8 +14,8 @@
module ocn_vel_forcing_bottomdrag
- use grid_types
- use configure
+ use mpas_grid_types
+ use mpas_configure
implicit none
private
Modified: trunk/mpas/src/core_ocean/mpas_ocn_vel_forcing_windstress.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_vel_forcing_windstress.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_ocean/mpas_ocn_vel_forcing_windstress.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -14,8 +14,8 @@
module ocn_vel_forcing_windstress
- use grid_types
- use configure
+ use mpas_grid_types
+ use mpas_configure
implicit none
private
Modified: trunk/mpas/src/core_ocean/mpas_ocn_vel_hmix.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_vel_hmix.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_ocean/mpas_ocn_vel_hmix.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -16,8 +16,8 @@
module ocn_vel_hmix
- use grid_types
- use configure
+ use mpas_grid_types
+ use mpas_configure
use ocn_vel_hmix_del2
use ocn_vel_hmix_del4
Modified: trunk/mpas/src/core_ocean/mpas_ocn_vel_hmix_del2.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_vel_hmix_del2.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_ocean/mpas_ocn_vel_hmix_del2.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -14,9 +14,9 @@
module ocn_vel_hmix_del2
- use grid_types
- use configure
- use timer
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_timer
implicit none
private
@@ -132,7 +132,7 @@
if(.not.hmixDel2On) return
- call timer_start("compute_tend_u-horiz mix-del2")
+ call mpas_timer_start("compute_tend_u-horiz mix-del2")
nEdgesSolve = grid % nEdgesSolve
maxLevelEdgeTop => grid % maxLevelEdgeTop % array
@@ -165,7 +165,7 @@
end do
end do
- call timer_stop("compute_tend_u-horiz mix-del2")
+ call mpas_timer_stop("compute_tend_u-horiz mix-del2")
!--------------------------------------------------------------------
Modified: trunk/mpas/src/core_ocean/mpas_ocn_vel_hmix_del4.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_vel_hmix_del4.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_ocean/mpas_ocn_vel_hmix_del4.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -14,9 +14,9 @@
module ocn_vel_hmix_del4
- use grid_types
- use configure
- use timer
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_timer
implicit none
private
@@ -134,7 +134,7 @@
if(.not.hmixDel4On) return
- call timer_start("compute_tend-horiz mix-del4")
+ call mpas_timer_start("compute_tend-horiz mix-del4")
nCells = grid % nCells
nEdges = grid % nEdges
@@ -243,7 +243,7 @@
deallocate(delsq_circulation)
deallocate(delsq_vorticity)
- call timer_stop("compute_tend-horiz mix-del4")
+ call mpas_timer_stop("compute_tend-horiz mix-del4")
!--------------------------------------------------------------------
Modified: trunk/mpas/src/core_ocean/mpas_ocn_vel_pressure_grad.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_vel_pressure_grad.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_ocean/mpas_ocn_vel_pressure_grad.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -15,8 +15,8 @@
module ocn_vel_pressure_grad
- use grid_types
- use configure
+ use mpas_grid_types
+ use mpas_configure
implicit none
private
Modified: trunk/mpas/src/core_ocean/mpas_ocn_vel_vadv.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_vel_vadv.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_ocean/mpas_ocn_vel_vadv.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -15,8 +15,8 @@
module ocn_vel_vadv
- use grid_types
- use configure
+ use mpas_grid_types
+ use mpas_configure
implicit none
private
Modified: trunk/mpas/src/core_ocean/mpas_ocn_vmix.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_vmix.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_ocean/mpas_ocn_vmix.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -15,9 +15,9 @@
module ocn_vmix
- use grid_types
- use configure
- use timer
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_timer
use ocn_vmix_coefs_const
use ocn_vmix_coefs_tanh
@@ -199,7 +199,7 @@
if(implicitOn) return
- call timer_start("compute_tend_u-explicit vert mix")
+ call mpas_timer_start("compute_tend_u-explicit vert mix")
nEdgessolve = grid % nEdgesSolve
nVertLevels = grid % nVertLevels
@@ -224,7 +224,7 @@
end do
deallocate(fluxVertTop)
- call timer_stop("compute_tend_u-explicit vert mix")
+ call mpas_timer_stop("compute_tend_u-explicit vert mix")
!--------------------------------------------------------------------
@@ -418,7 +418,7 @@
if(implicitOn) return
- call timer_start("compute_scalar_tend-explicit vert diff")
+ call mpas_timer_start("compute_scalar_tend-explicit vert diff")
nCellsSolve = grid % nCellsSolve
nVertLevels = grid % nVertLevels
@@ -455,7 +455,7 @@
enddo ! iCell loop
deallocate(fluxVertTop)
- call timer_stop("compute_scalar_tend-explicit vert diff")
+ call mpas_timer_stop("compute_scalar_tend-explicit vert diff")
!--------------------------------------------------------------------
@@ -637,7 +637,7 @@
real (KIND=RKIND) :: m
integer i
- call timer_start("tridiagonal_solve")
+ call mpas_timer_start("tridiagonal_solve")
! Use work variables for b and r
bTemp(1) = b(1)
@@ -656,7 +656,7 @@
x(i) = (rTemp(i) - c(i)*x(i+1))/bTemp(i)
end do
- call timer_stop("tridiagonal_solve")
+ call mpas_timer_stop("tridiagonal_solve")
end subroutine tridiagonal_solve!}}}
@@ -684,7 +684,7 @@
real (KIND=RKIND) :: m
integer i,j
- call timer_start("tridiagonal_solve_mult")
+ call mpas_timer_start("tridiagonal_solve_mult")
! Use work variables for b and r
bTemp(1) = b(1)
@@ -711,7 +711,7 @@
end do
end do
- call timer_stop("tridiagonal_solve_mult")
+ call mpas_timer_stop("tridiagonal_solve_mult")
end subroutine tridiagonal_solve_mult!}}}
Modified: trunk/mpas/src/core_ocean/mpas_ocn_vmix_coefs_const.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_vmix_coefs_const.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_ocean/mpas_ocn_vmix_coefs_const.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -15,9 +15,9 @@
module ocn_vmix_coefs_const
- use grid_types
- use configure
- use timer
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_timer
implicit none
private
Modified: trunk/mpas/src/core_ocean/mpas_ocn_vmix_coefs_rich.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_vmix_coefs_rich.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_ocean/mpas_ocn_vmix_coefs_rich.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -15,10 +15,10 @@
module ocn_vmix_coefs_rich
- use grid_types
- use configure
- use constants
- use timer
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_constants
+ use mpas_timer
use ocn_equation_of_state
Modified: trunk/mpas/src/core_ocean/mpas_ocn_vmix_coefs_tanh.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_vmix_coefs_tanh.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_ocean/mpas_ocn_vmix_coefs_tanh.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -15,9 +15,9 @@
module ocn_vmix_coefs_tanh
- use grid_types
- use configure
- use timer
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_timer
implicit none
private
Modified: trunk/mpas/src/core_sw/Makefile
===================================================================
--- trunk/mpas/src/core_sw/Makefile 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_sw/Makefile 2011-10-21 19:18:00 UTC (rev 1114)
@@ -1,25 +1,25 @@
.SUFFIXES: .F .o
-OBJS = module_mpas_core.o \
- module_test_cases.o \
- module_advection.o \
- module_time_integration.o \
- module_global_diagnostics.o
+OBJS = mpas_sw_mpas_core.o \
+ mpas_sw_test_cases.o \
+ mpas_sw_advection.o \
+ mpas_sw_time_integration.o \
+ mpas_sw_global_diagnostics.o
all: core_sw
core_sw: $(OBJS)
ar -ru libdycore.a $(OBJS)
-module_test_cases.o:
+mpas_sw_test_cases.o:
-module_advection.o:
+mpas_sw_advection.o:
-module_time_integration.o:
+mpas_sw_time_integration.o:
-module_global_diagnostics.o:
+mpas_sw_global_diagnostics.o:
-module_mpas_core.o: module_global_diagnostics.o module_test_cases.o module_time_integration.o module_advection.o
+mpas_sw_mpas_core.o: mpas_sw_global_diagnostics.o mpas_sw_test_cases.o mpas_sw_time_integration.o mpas_sw_advection.o
clean:
$(RM) *.o *.mod *.f90 libdycore.a
Deleted: trunk/mpas/src/core_sw/module_advection.F
===================================================================
--- trunk/mpas/src/core_sw/module_advection.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_sw/module_advection.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -1,933 +0,0 @@
-module advection
-
- use grid_types
- use configure
- use constants
-
-
- contains
-
-
- subroutine initialize_advection_rk( grid )
-
-!
-! compute the cell coefficients for the polynomial fit.
-! this is performed during setup for model integration.
-! WCS, 31 August 2009
-!
- implicit none
-
- type (mesh_type), intent(in) :: grid
-
- real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
- integer, dimension(:,:), pointer :: advCells
-
-! local variables
-
- real (kind=RKIND), dimension(2, grid % nEdges) :: thetae
- real (kind=RKIND), dimension(grid % nEdges) :: xe, ye
- real (kind=RKIND), dimension(grid % nCells) :: theta_abs
-
- real (kind=RKIND), dimension(25) :: xc, yc, zc ! cell center coordinates
- real (kind=RKIND), dimension(25) :: thetav, thetat, dl_sphere
- real (kind=RKIND) :: xm, ym, zm, dl, xec, yec, zec
- real (kind=RKIND) :: thetae_tmp, xe_tmp, ye_tmp
- real (kind=RKIND) :: xv1, xv2, yv1, yv2, zv1, zv2
- integer :: i, j, k, ip1, ip2, m, n, ip1a, ii
- integer :: iCell, iEdge
- real (kind=RKIND) :: pii
- real (kind=RKIND) :: x0, y0, x1, y1, x2, y2, x3, y3, x4, y4, x5, y5
- real (kind=RKIND) :: pdx1, pdx2, pdx3, pdy1, pdy2, pdy3, dx1, dx2, dy1, dy2
- real (kind=RKIND) :: angv1, angv2, dl1, dl2
- real (kind=RKIND), dimension(25) :: dxe, dye, x2v, y2v, xp, yp
-
- real (kind=RKIND) :: amatrix(25,25), bmatrix(25,25), wmatrix(25,25)
- real (kind=RKIND) :: length_scale
- integer :: ma,na, cell_add, mw, nn
- integer, dimension(25) :: cell_list
-
-
- integer :: cell1, cell2
- integer, parameter :: polynomial_order = 2
-! logical, parameter :: debug = .true.
- logical, parameter :: debug = .false.
-! logical, parameter :: least_squares = .false.
- logical, parameter :: least_squares = .true.
- logical :: add_the_cell, do_the_cell
-
- logical, parameter :: reset_poly = .true.
-
- real (kind=RKIND) :: rcell, cos2t, costsint, sin2t
- real (kind=RKIND), dimension(grid%maxEdges) :: angle_2d
-
-!---
-
- pii = 2.*asin(1.0)
-
- advCells => grid % advCells % array
- deriv_two => grid % deriv_two % array
- deriv_two(:,:,:) = 0.
-
- do iCell = 1, grid % nCells ! is this correct? - we need first halo cell also...
-
- cell_list(1) = iCell
- do i=2, grid % nEdgesOnCell % array(iCell)+1
- cell_list(i) = grid % CellsOnCell % array(i-1,iCell)
- end do
- n = grid % nEdgesOnCell % array(iCell) + 1
-
- if ( polynomial_order > 2 ) then
- do i=2,grid % nEdgesOnCell % array(iCell) + 1
- do j=1,grid % nEdgesOnCell % array ( cell_list(i) )
- cell_add = grid % CellsOnCell % array (j,cell_list(i))
- add_the_cell = .true.
- do k=1,n
- if ( cell_add == cell_list(k) ) add_the_cell = .false.
- end do
- if (add_the_cell) then
- n = n+1
- cell_list(n) = cell_add
- end if
- end do
- end do
- end if
-
- advCells(1,iCell) = n
-
-! check to see if we are reaching outside the halo
-
- do_the_cell = .true.
- do i=1,n
- if (cell_list(i) > grid % nCells) do_the_cell = .false.
- end do
-
-
- if ( .not. do_the_cell ) cycle
-
-
-! compute poynomial fit for this cell if all needed neighbors exist
- if ( grid % on_a_sphere ) then
-
- do i=1,n
- advCells(i+1,iCell) = cell_list(i)
- xc(i) = grid % xCell % array(advCells(i+1,iCell))/a
- yc(i) = grid % yCell % array(advCells(i+1,iCell))/a
- zc(i) = grid % zCell % array(advCells(i+1,iCell))/a
- end do
-
- theta_abs(iCell) = pii/2. - sphere_angle( xc(1), yc(1), zc(1), &
- xc(2), yc(2), zc(2), &
- 0., 0., 1. )
-
-! angles from cell center to neighbor centers (thetav)
-
- do i=1,n-1
-
- ip2 = i+2
- if (ip2 > n) ip2 = 2
-
- thetav(i) = sphere_angle( xc(1), yc(1), zc(1), &
- xc(i+1), yc(i+1), zc(i+1), &
- xc(ip2), yc(ip2), zc(ip2) )
-
- dl_sphere(i) = a*arc_length( xc(1), yc(1), zc(1), &
- xc(i+1), yc(i+1), zc(i+1) )
- end do
-
- length_scale = 1.
- do i=1,n-1
- dl_sphere(i) = dl_sphere(i)/length_scale
- end do
-
-! thetat(1) = 0. ! this defines the x direction, cell center 1 ->
- thetat(1) = theta_abs(iCell) ! this defines the x direction, longitude line
- do i=2,n-1
- thetat(i) = thetat(i-1) + thetav(i-1)
- end do
-
- do i=1,n-1
- xp(i) = cos(thetat(i)) * dl_sphere(i)
- yp(i) = sin(thetat(i)) * dl_sphere(i)
- end do
-
- else ! On an x-y plane
-
- do i=1,n-1
-
- angle_2d(i) = grid%angleEdge%array(grid % EdgesOnCell % array(i,iCell))
- iEdge = grid % EdgesOnCell % array(i,iCell)
- if ( iCell .ne. grid % CellsOnEdge % array(1,iEdge)) &
- angle_2d(i) = angle_2d(i) - pii
-
-! xp(i) = grid % xCell % array(cell_list(i)) - grid % xCell % array(iCell)
-! yp(i) = grid % yCell % array(cell_list(i)) - grid % yCell % array(iCell)
-
- xp(i) = grid % dcEdge % array(grid % EdgesOnCell % array(i,iCell)) * cos(angle_2d(i))
- yp(i) = grid % dcEdge % array(grid % EdgesOnCell % array(i,iCell)) * sin(angle_2d(i))
-
- end do
-
- end if
-
-
- ma = n-1
- mw = grid % nEdgesOnCell % array (iCell)
-
- bmatrix = 0.
- amatrix = 0.
- wmatrix = 0.
-
- if (polynomial_order == 2) then
- na = 6
- ma = ma+1
-
- amatrix(1,1) = 1.
- wmatrix(1,1) = 1.
- do i=2,ma
- amatrix(i,1) = 1.
- amatrix(i,2) = xp(i-1)
- amatrix(i,3) = yp(i-1)
- amatrix(i,4) = xp(i-1)**2
- amatrix(i,5) = xp(i-1) * yp(i-1)
- amatrix(i,6) = yp(i-1)**2
-
- wmatrix(i,i) = 1.
- end do
-
- else if (polynomial_order == 3) then
- na = 10
- ma = ma+1
-
- amatrix(1,1) = 1.
- wmatrix(1,1) = 1.
- do i=2,ma
- amatrix(i,1) = 1.
- amatrix(i,2) = xp(i-1)
- amatrix(i,3) = yp(i-1)
-
- amatrix(i,4) = xp(i-1)**2
- amatrix(i,5) = xp(i-1) * yp(i-1)
- amatrix(i,6) = yp(i-1)**2
-
- amatrix(i,7) = xp(i-1)**3
- amatrix(i,8) = yp(i-1) * (xp(i-1)**2)
- amatrix(i,9) = xp(i-1) * (yp(i-1)**2)
- amatrix(i,10) = yp(i-1)**3
-
- wmatrix(i,i) = 1.
-
- end do
-
- else
- na = 15
- ma = ma+1
-
- amatrix(1,1) = 1.
- wmatrix(1,1) = 1.
- do i=2,ma
- amatrix(i,1) = 1.
- amatrix(i,2) = xp(i-1)
- amatrix(i,3) = yp(i-1)
-
- amatrix(i,4) = xp(i-1)**2
- amatrix(i,5) = xp(i-1) * yp(i-1)
- amatrix(i,6) = yp(i-1)**2
-
- amatrix(i,7) = xp(i-1)**3
- amatrix(i,8) = yp(i-1) * (xp(i-1)**2)
- amatrix(i,9) = xp(i-1) * (yp(i-1)**2)
- amatrix(i,10) = yp(i-1)**3
-
- amatrix(i,11) = xp(i-1)**4
- amatrix(i,12) = yp(i-1) * (xp(i-1)**3)
- amatrix(i,13) = (xp(i-1)**2)*(yp(i-1)**2)
- amatrix(i,14) = xp(i-1) * (yp(i-1)**3)
- amatrix(i,15) = yp(i-1)**4
-
- wmatrix(i,i) = 1.
-
- end do
-
- do i=1,mw
- wmatrix(i,i) = 1.
- end do
-
- end if
-
- call poly_fit_2( amatrix, bmatrix, wmatrix, ma, na, 25 )
-
- do i=1,grid % nEdgesOnCell % array (iCell)
- ip1 = i+1
- if (ip1 > n-1) ip1 = 1
-
- iEdge = grid % EdgesOnCell % array (i,iCell)
- xv1 = grid % xVertex % array(grid % verticesOnEdge % array (1,iedge))/a
- yv1 = grid % yVertex % array(grid % verticesOnEdge % array (1,iedge))/a
- zv1 = grid % zVertex % array(grid % verticesOnEdge % array (1,iedge))/a
- xv2 = grid % xVertex % array(grid % verticesOnEdge % array (2,iedge))/a
- yv2 = grid % yVertex % array(grid % verticesOnEdge % array (2,iedge))/a
- zv2 = grid % zVertex % array(grid % verticesOnEdge % array (2,iedge))/a
-
- if ( grid % on_a_sphere ) then
- call arc_bisect( xv1, yv1, zv1, &
- xv2, yv2, zv2, &
- xec, yec, zec )
-
- thetae_tmp = sphere_angle( xc(1), yc(1), zc(1), &
- xc(i+1), yc(i+1), zc(i+1), &
- xec, yec, zec )
- thetae_tmp = thetae_tmp + thetat(i)
- if (iCell == grid % cellsOnEdge % array(1,iEdge)) then
- thetae(1,grid % EdgesOnCell % array (i,iCell)) = thetae_tmp
- else
- thetae(2,grid % EdgesOnCell % array (i,iCell)) = thetae_tmp
- end if
-! else
-!
-! xe(grid % EdgesOnCell % array (i,iCell)) = 0.5 * (xv1 + xv2)
-! ye(grid % EdgesOnCell % array (i,iCell)) = 0.5 * (yv1 + yv2)
-
- end if
-
- end do
-
-! fill second derivative stencil for rk advection
-
- do i=1, grid % nEdgesOnCell % array (iCell)
- iEdge = grid % EdgesOnCell % array (i,iCell)
-
-
- if ( grid % on_a_sphere ) then
- if (iCell == grid % cellsOnEdge % array(1,iEdge)) then
-
- cos2t = cos(thetae(1,grid % EdgesOnCell % array (i,iCell)))
- sin2t = sin(thetae(1,grid % EdgesOnCell % array (i,iCell)))
- costsint = cos2t*sin2t
- cos2t = cos2t**2
- sin2t = sin2t**2
-
- do j=1,n
- deriv_two(j,1,iEdge) = 2.*cos2t*bmatrix(4,j) &
- + 2.*costsint*bmatrix(5,j) &
- + 2.*sin2t*bmatrix(6,j)
- end do
- else
-
- cos2t = cos(thetae(2,grid % EdgesOnCell % array (i,iCell)))
- sin2t = sin(thetae(2,grid % EdgesOnCell % array (i,iCell)))
- costsint = cos2t*sin2t
- cos2t = cos2t**2
- sin2t = sin2t**2
-
- do j=1,n
- deriv_two(j,2,iEdge) = 2.*cos2t*bmatrix(4,j) &
- + 2.*costsint*bmatrix(5,j) &
- + 2.*sin2t*bmatrix(6,j)
- end do
- end if
-
- else
-
- cos2t = cos(angle_2d(i))
- sin2t = sin(angle_2d(i))
- costsint = cos2t*sin2t
- cos2t = cos2t**2
- sin2t = sin2t**2
-
-! do j=1,n
-!
-! deriv_two(j,1,iEdge) = 2.*xe(iEdge)*xe(iEdge)*bmatrix(4,j) &
-! + 2.*xe(iEdge)*ye(iEdge)*bmatrix(5,j) &
-! + 2.*ye(iEdge)*ye(iEdge)*bmatrix(6,j)
-! end do
-
- if (iCell == grid % cellsOnEdge % array(1,iEdge)) then
- do j=1,n
- deriv_two(j,1,iEdge) = 2.*cos2t*bmatrix(4,j) &
- + 2.*costsint*bmatrix(5,j) &
- + 2.*sin2t*bmatrix(6,j)
- end do
- else
- do j=1,n
- deriv_two(j,2,iEdge) = 2.*cos2t*bmatrix(4,j) &
- + 2.*costsint*bmatrix(5,j) &
- + 2.*sin2t*bmatrix(6,j)
- end do
- end if
-
- end if
- end do
-
- end do ! end of loop over cells
-
- if (debug) stop
-
-
-! write(0,*) ' check for deriv2 coefficients, iEdge 4 '
-!
-! iEdge = 4
-! j = 1
-! iCell = grid % cellsOnEdge % array(1,iEdge)
-! write(0,*) ' j, icell, coef ',j,iCell,deriv_two(j,1,iEdge)
-! do j=2,7
-! write(0,*) ' j, icell, coef ',j,grid % CellsOnCell % array(j-1,iCell),deriv_two(j,1,iEdge)
-! end do
-!
-! j = 1
-! iCell = grid % cellsOnEdge % array(2,iEdge)
-! write(0,*) ' j, icell, coef ',j,iCell,deriv_two(j,2,iEdge)
-! do j=2,7
-! write(0,*) ' j, icell, coef ',j,grid % CellsOnCell % array(j-1,iCell),deriv_two(j,2,iEdge)
-! end do
-! stop
-
- end subroutine initialize_advection_rk
-
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! FUNCTION SPHERE_ANGLE
- !
- ! Computes the angle between arcs AB and AC, given points A, B, and C
- ! Equation numbers w.r.t. http://mathworld.wolfram.com/SphericalTrigonometry.html
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- real function sphere_angle(ax, ay, az, bx, by, bz, cx, cy, cz)
-
- implicit none
-
- real (kind=RKIND), intent(in) :: ax, ay, az, bx, by, bz, cx, cy, cz
-
- real (kind=RKIND) :: a, b, c ! Side lengths of spherical triangle ABC
-
- real (kind=RKIND) :: ABx, ABy, ABz ! The components of the vector AB
- real (kind=RKIND) :: mAB ! The magnitude of AB
- real (kind=RKIND) :: ACx, ACy, ACz ! The components of the vector AC
- real (kind=RKIND) :: mAC ! The magnitude of AC
-
- real (kind=RKIND) :: Dx ! The i-components of the cross product AB x AC
- real (kind=RKIND) :: Dy ! The j-components of the cross product AB x AC
- real (kind=RKIND) :: Dz ! The k-components of the cross product AB x AC
-
- real (kind=RKIND) :: s ! Semiperimeter of the triangle
- real (kind=RKIND) :: sin_angle
-
- a = acos(max(min(bx*cx + by*cy + bz*cz,1.0),-1.0)) ! Eqn. (3)
- b = acos(max(min(ax*cx + ay*cy + az*cz,1.0),-1.0)) ! Eqn. (2)
- c = acos(max(min(ax*bx + ay*by + az*bz,1.0),-1.0)) ! Eqn. (1)
-
- ABx = bx - ax
- ABy = by - ay
- ABz = bz - az
-
- ACx = cx - ax
- ACy = cy - ay
- ACz = cz - az
-
- Dx = (ABy * ACz) - (ABz * ACy)
- Dy = -((ABx * ACz) - (ABz * ACx))
- Dz = (ABx * ACy) - (ABy * ACx)
-
- s = 0.5*(a + b + c)
-! sin_angle = sqrt((sin(s-b)*sin(s-c))/(sin(b)*sin(c))) ! Eqn. (28)
- sin_angle = sqrt(min(1.,max(0.,(sin(s-b)*sin(s-c))/(sin(b)*sin(c))))) ! Eqn. (28)
-
- if ((Dx*ax + Dy*ay + Dz*az) >= 0.0) then
- sphere_angle = 2.0 * asin(max(min(sin_angle,1.0),-1.0))
- else
- sphere_angle = -2.0 * asin(max(min(sin_angle,1.0),-1.0))
- end if
-
- end function sphere_angle
-
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! FUNCTION PLANE_ANGLE
- !
- ! Computes the angle between vectors AB and AC, given points A, B, and C, and
- ! a vector (u,v,w) normal to the plane.
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- real function plane_angle(ax, ay, az, bx, by, bz, cx, cy, cz, u, v, w)
-
- implicit none
-
- real (kind=RKIND), intent(in) :: ax, ay, az, bx, by, bz, cx, cy, cz, u, v, w
-
- real (kind=RKIND) :: ABx, ABy, ABz ! The components of the vector AB
- real (kind=RKIND) :: mAB ! The magnitude of AB
- real (kind=RKIND) :: ACx, ACy, ACz ! The components of the vector AC
- real (kind=RKIND) :: mAC ! The magnitude of AC
-
- real (kind=RKIND) :: Dx ! The i-components of the cross product AB x AC
- real (kind=RKIND) :: Dy ! The j-components of the cross product AB x AC
- real (kind=RKIND) :: Dz ! The k-components of the cross product AB x AC
-
- real (kind=RKIND) :: cos_angle
-
- ABx = bx - ax
- ABy = by - ay
- ABz = bz - az
- mAB = sqrt(ABx**2.0 + ABy**2.0 + ABz**2.0)
-
- ACx = cx - ax
- ACy = cy - ay
- ACz = cz - az
- mAC = sqrt(ACx**2.0 + ACy**2.0 + ACz**2.0)
-
-
- Dx = (ABy * ACz) - (ABz * ACy)
- Dy = -((ABx * ACz) - (ABz * ACx))
- Dz = (ABx * ACy) - (ABy * ACx)
-
- cos_angle = (ABx*ACx + ABy*ACy + ABz*ACz) / (mAB * mAC)
-
- if ((Dx*u + Dy*v + Dz*w) >= 0.0) then
- plane_angle = acos(max(min(cos_angle,1.0),-1.0))
- else
- plane_angle = -acos(max(min(cos_angle,1.0),-1.0))
- end if
-
- end function plane_angle
-
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! FUNCTION ARC_LENGTH
- !
- ! Returns the length of the great circle arc from A=(ax, ay, az) to
- ! B=(bx, by, bz). It is assumed that both A and B lie on the surface of the
- ! same sphere centered at the origin.
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- real function arc_length(ax, ay, az, bx, by, bz)
-
- implicit none
-
- real (kind=RKIND), intent(in) :: ax, ay, az, bx, by, bz
-
- real (kind=RKIND) :: r, c
- real (kind=RKIND) :: cx, cy, cz
-
- cx = bx - ax
- cy = by - ay
- cz = bz - az
-
-! r = ax*ax + ay*ay + az*az
-! c = cx*cx + cy*cy + cz*cz
-!
-! arc_length = sqrt(r) * acos(1.0 - c/(2.0*r))
-
- r = sqrt(ax*ax + ay*ay + az*az)
- c = sqrt(cx*cx + cy*cy + cz*cz)
-! arc_length = sqrt(r) * 2.0 * asin(c/(2.0*r))
- arc_length = r * 2.0 * asin(c/(2.0*r))
-
- end function arc_length
-
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! SUBROUTINE ARC_BISECT
- !
- ! Returns the point C=(cx, cy, cz) that bisects the great circle arc from
- ! A=(ax, ay, az) to B=(bx, by, bz). It is assumed that A and B lie on the
- ! surface of a sphere centered at the origin.
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine arc_bisect(ax, ay, az, bx, by, bz, cx, cy, cz)
-
- implicit none
-
- real (kind=RKIND), intent(in) :: ax, ay, az, bx, by, bz
- real (kind=RKIND), intent(out) :: cx, cy, cz
-
- real (kind=RKIND) :: r ! Radius of the sphere
- real (kind=RKIND) :: d
-
- r = sqrt(ax*ax + ay*ay + az*az)
-
- cx = 0.5*(ax + bx)
- cy = 0.5*(ay + by)
- cz = 0.5*(az + bz)
-
- if (cx == 0. .and. cy == 0. .and. cz == 0.) then
- write(0,*) 'Error: arc_bisect: A and B are diametrically opposite'
- else
- d = sqrt(cx*cx + cy*cy + cz*cz)
- cx = r * cx / d
- cy = r * cy / d
- cz = r * cz / d
- end if
-
- end subroutine arc_bisect
-
-
- subroutine poly_fit_2(a_in,b_out,weights_in,m,n,ne)
-
- implicit none
-
- integer, intent(in) :: m,n,ne
- real (kind=RKIND), dimension(ne,ne), intent(in) :: a_in, weights_in
- real (kind=RKIND), dimension(ne,ne), intent(out) :: b_out
-
- ! local storage
-
- real (kind=RKIND), dimension(m,n) :: a
- real (kind=RKIND), dimension(n,m) :: b
- real (kind=RKIND), dimension(m,m) :: w,wt,h
- real (kind=RKIND), dimension(n,m) :: at, ath
- real (kind=RKIND), dimension(n,n) :: ata, ata_inv, atha, atha_inv
- integer, dimension(n) :: indx
- integer :: i,j
-
- if ( (ne<n) .or. (ne<m) ) then
- write(6,*) ' error in poly_fit_2 inversion ',m,n,ne
- stop
- end if
-
-! a(1:m,1:n) = a_in(1:n,1:m)
- a(1:m,1:n) = a_in(1:m,1:n)
- w(1:m,1:m) = weights_in(1:m,1:m)
- b_out(:,:) = 0.
-
- wt = transpose(w)
- h = matmul(wt,w)
- at = transpose(a)
- ath = matmul(at,h)
- atha = matmul(ath,a)
-
- ata = matmul(at,a)
-
-! if (m == n) then
-! call migs(a,n,b,indx)
-! else
-
- call migs(atha,n,atha_inv,indx)
-
- b = matmul(atha_inv,ath)
-
-! call migs(ata,n,ata_inv,indx)
-! b = matmul(ata_inv,at)
-! end if
- b_out(1:n,1:m) = b(1:n,1:m)
-
-! do i=1,n
-! write(6,*) ' i, indx ',i,indx(i)
-! end do
-!
-! write(6,*) ' '
-
- end subroutine poly_fit_2
-
-
-! Updated 10/24/2001.
-!
-!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 4.4 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! !
-! Please Note: !
-! !
-! (1) This computer program is written by Tao Pang in conjunction with !
-! his book, "An Introduction to Computational Physics," published !
-! by Cambridge University Press in 1997. !
-! !
-! (2) No warranties, express or implied, are made for this program. !
-! !
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!
-SUBROUTINE MIGS (A,N,X,INDX)
-!
-! Subroutine to invert matrix A(N,N) with the inverse stored
-! in X(N,N) in the output. Copyright (c) Tao Pang 2001.
-!
- IMPLICIT NONE
- INTEGER, INTENT (IN) :: N
- INTEGER :: I,J,K
- INTEGER, INTENT (OUT), DIMENSION (N) :: INDX
- REAL (kind=RKIND), INTENT (INOUT), DIMENSION (N,N):: A
- REAL (kind=RKIND), INTENT (OUT), DIMENSION (N,N):: X
- REAL (kind=RKIND), DIMENSION (N,N) :: B
-!
- DO I = 1, N
- DO J = 1, N
- B(I,J) = 0.0
- END DO
- END DO
- DO I = 1, N
- B(I,I) = 1.0
- END DO
-!
- CALL ELGS (A,N,INDX)
-!
- DO I = 1, N-1
- DO J = I+1, N
- DO K = 1, N
- B(INDX(J),K) = B(INDX(J),K)-A(INDX(J),I)*B(INDX(I),K)
- END DO
- END DO
- END DO
-!
- DO I = 1, N
- X(N,I) = B(INDX(N),I)/A(INDX(N),N)
- DO J = N-1, 1, -1
- X(J,I) = B(INDX(J),I)
- DO K = J+1, N
- X(J,I) = X(J,I)-A(INDX(J),K)*X(K,I)
- END DO
- X(J,I) = X(J,I)/A(INDX(J),J)
- END DO
- END DO
-END SUBROUTINE MIGS
-
-
-SUBROUTINE ELGS (A,N,INDX)
-!
-! Subroutine to perform the partial-pivoting Gaussian elimination.
-! A(N,N) is the original matrix in the input and transformed matrix
-! plus the pivoting element ratios below the diagonal in the output.
-! INDX(N) records the pivoting order. Copyright (c) Tao Pang 2001.
-!
- IMPLICIT NONE
- INTEGER, INTENT (IN) :: N
- INTEGER :: I,J,K,ITMP
- INTEGER, INTENT (OUT), DIMENSION (N) :: INDX
- REAL (kind=RKIND) :: C1,PI,PI1,PJ
- REAL (kind=RKIND), INTENT (INOUT), DIMENSION (N,N) :: A
- REAL (kind=RKIND), DIMENSION (N) :: C
-!
-! Initialize the index
-!
- DO I = 1, N
- INDX(I) = I
- END DO
-!
-! Find the rescaling factors, one from each row
-!
- DO I = 1, N
- C1= 0.0
- DO J = 1, N
- C1 = MAX(C1,ABS(A(I,J)))
- END DO
- C(I) = C1
- END DO
-!
-! Search the pivoting (largest) element from each column
-!
- DO J = 1, N-1
- PI1 = 0.0
- DO I = J, N
- PI = ABS(A(INDX(I),J))/C(INDX(I))
- IF (PI.GT.PI1) THEN
- PI1 = PI
- K = I
- ENDIF
- END DO
-!
-! Interchange the rows via INDX(N) to record pivoting order
-!
- ITMP = INDX(J)
- INDX(J) = INDX(K)
- INDX(K) = ITMP
- DO I = J+1, N
- PJ = A(INDX(I),J)/A(INDX(J),J)
-!
-! Record pivoting ratios below the diagonal
-!
- A(INDX(I),J) = PJ
-!
-! Modify other elements accordingly
-!
- DO K = J+1, N
- A(INDX(I),K) = A(INDX(I),K)-PJ*A(INDX(J),K)
- END DO
- END DO
- END DO
-!
-END SUBROUTINE ELGS
-
-!-------------------------------------------------------------
-
- subroutine initialize_deformation_weights( grid )
-
-!
-! compute the cell coefficients for the deformation calculations
-! WCS, 13 July 2010
-!
- implicit none
-
- type (mesh_type), intent(in) :: grid
-
- real (kind=RKIND), dimension(:,:), pointer :: defc_a, defc_b
- integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnCell
-
-! local variables
-
- real (kind=RKIND), dimension(2, grid % nEdges) :: thetae
- real (kind=RKIND), dimension(grid % nEdges) :: xe, ye
- real (kind=RKIND), dimension(grid % nCells) :: theta_abs
-
- real (kind=RKIND), dimension(25) :: xc, yc, zc ! cell center coordinates
- real (kind=RKIND), dimension(25) :: thetav, thetat, dl_sphere
- real (kind=RKIND) :: xm, ym, zm, dl, xec, yec, zec
- real (kind=RKIND) :: thetae_tmp, xe_tmp, ye_tmp
- real (kind=RKIND) :: xv1, xv2, yv1, yv2, zv1, zv2
- integer :: i, j, k, ip1, ip2, m, n, ip1a, ii
- integer :: iCell, iEdge
- real (kind=RKIND) :: pii
- real (kind=RKIND) :: x0, y0, x1, y1, x2, y2, x3, y3, x4, y4, x5, y5
- real (kind=RKIND) :: pdx1, pdx2, pdx3, pdy1, pdy2, pdy3, dx1, dx2, dy1, dy2
- real (kind=RKIND) :: angv1, angv2, dl1, dl2
- real (kind=RKIND), dimension(25) :: dxe, dye, x2v, y2v, xp, yp, xpt, ypt
-
- real (kind=RKIND) :: length_scale
- integer :: ma,na, cell_add, mw, nn
- integer, dimension(25) :: cell_list
-
- integer :: cell1, cell2, iv
- logical :: do_the_cell
- real (kind=RKIND) :: area_cell, sint2, cost2, sint_cost, sumw1, sumw2, xptt, area_cellt
-
- logical, parameter :: debug = .false.
-
- if (debug) write(0,*) ' in def weight calc '
-
- defc_a => grid % defc_a % array
- defc_b => grid % defc_b % array
- cellsOnEdge => grid % cellsOnEdge % array
- edgesOnCell => grid % edgesOnCell % array
-
- defc_a(:,:) = 0.
- defc_b(:,:) = 0.
-
- pii = 2.*asin(1.0)
-
- if (debug) write(0,*) ' beginning cell loop '
-
- do iCell = 1, grid % nCells
-
- if (debug) write(0,*) ' cell loop ', iCell
-
- cell_list(1) = iCell
- do i=2, grid % nEdgesOnCell % array(iCell)+1
- cell_list(i) = grid % CellsOnCell % array(i-1,iCell)
- end do
- n = grid % nEdgesOnCell % array(iCell) + 1
-
-! check to see if we are reaching outside the halo
-
- if (debug) write(0,*) ' points ', n
-
- do_the_cell = .true.
- do i=1,n
- if (cell_list(i) > grid % nCells) do_the_cell = .false.
- end do
-
-
- if (.not. do_the_cell) cycle
-
-
-! compute poynomial fit for this cell if all needed neighbors exist
- if (grid % on_a_sphere) then
-
- xc(1) = grid % xCell % array(iCell)/a
- yc(1) = grid % yCell % array(iCell)/a
- zc(1) = grid % zCell % array(iCell)/a
-
-
- do i=2,n
- iv = grid % verticesOnCell % array(i-1,iCell)
- xc(i) = grid % xVertex % array(iv)/a
- yc(i) = grid % yVertex % array(iv)/a
- zc(i) = grid % zVertex % array(iv)/a
- end do
-
- theta_abs(iCell) = pii/2. - sphere_angle( xc(1), yc(1), zc(1), &
- xc(2), yc(2), zc(2), &
- 0., 0., 1. )
-
-! angles from cell center to neighbor centers (thetav)
-
- do i=1,n-1
-
- ip2 = i+2
- if (ip2 > n) ip2 = 2
-
- thetav(i) = sphere_angle( xc(1), yc(1), zc(1), &
- xc(i+1), yc(i+1), zc(i+1), &
- xc(ip2), yc(ip2), zc(ip2) )
-
- dl_sphere(i) = a*arc_length( xc(1), yc(1), zc(1), &
- xc(i+1), yc(i+1), zc(i+1) )
- end do
-
- length_scale = 1.
- do i=1,n-1
- dl_sphere(i) = dl_sphere(i)/length_scale
- end do
-
- thetat(1) = 0. ! this defines the x direction, cell center 1 ->
-! thetat(1) = theta_abs(iCell) ! this defines the x direction, longitude line
- do i=2,n-1
- thetat(i) = thetat(i-1) + thetav(i-1)
- end do
-
- do i=1,n-1
- xp(i) = cos(thetat(i)) * dl_sphere(i)
- yp(i) = sin(thetat(i)) * dl_sphere(i)
- end do
-
- else ! On an x-y plane
-
- xp(1) = grid % xCell % array(iCell)
- yp(1) = grid % yCell % array(iCell)
-
-
- do i=2,n
- iv = grid % verticesOnCell % array(i-1,iCell)
- xp(i) = grid % xVertex % array(iv)
- yp(i) = grid % yVertex % array(iv)
- end do
-
- end if
-
-! thetat(1) = 0.
- thetat(1) = theta_abs(iCell)
- do i=2,n-1
- ip1 = i+1
- if (ip1 == n) ip1 = 1
- thetat(i) = plane_angle( 0.,0.,0., &
- xp(i)-xp(i-1), yp(i)-yp(i-1), 0., &
- xp(ip1)-xp(i), yp(ip1)-yp(i), 0., &
- 0., 0., 1.)
- thetat(i) = thetat(i) + thetat(i-1)
- end do
-
- area_cell = 0.
- area_cellt = 0.
- do i=1,n-1
- ip1 = i+1
- if (ip1 == n) ip1 = 1
- dl = sqrt((xp(ip1)-xp(i))**2 + (yp(ip1)-yp(i))**2)
- area_cell = area_cell + 0.25*(xp(i)+xp(ip1))*(yp(ip1)-yp(i)) - 0.25*(yp(i)+yp(ip1))*(xp(ip1)-xp(i))
- area_cellt = area_cellt + (0.25*(xp(i)+xp(ip1))*cos(thetat(i)) + 0.25*(yp(i)+yp(ip1))*sin(thetat(i)))*dl
- end do
- if (debug) write(0,*) ' area_cell, area_cellt ',area_cell, area_cellt,area_cell-area_cellt
-
- do i=1,n-1
- ip1 = i+1
- if (ip1 == n) ip1 = 1
- dl = sqrt((xp(ip1)-xp(i))**2 + (yp(ip1)-yp(i))**2)
- sint2 = (sin(thetat(i)))**2
- cost2 = (cos(thetat(i)))**2
- sint_cost = sin(thetat(i))*cos(thetat(i))
- defc_a(i,iCell) = dl*(cost2 - sint2)/area_cell
- defc_b(i,iCell) = dl*2.*sint_cost/area_cell
- if (cellsOnEdge(1,EdgesOnCell(i,iCell)) /= iCell) then
- defc_a(i,iCell) = - defc_a(i,iCell)
- defc_b(i,iCell) = - defc_b(i,iCell)
- end if
-
- end do
-
- end do
-
- if (debug) write(0,*) ' exiting def weight calc '
-
- end subroutine initialize_deformation_weights
-
-end module advection
Deleted: trunk/mpas/src/core_sw/module_global_diagnostics.F
===================================================================
--- trunk/mpas/src/core_sw/module_global_diagnostics.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_sw/module_global_diagnostics.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -1,384 +0,0 @@
-module global_diagnostics
-
- use grid_types
- use configure
- use constants
- use dmpar
-
- implicit none
- save
- public
-
- contains
-
- subroutine computeGlobalDiagnostics(dminfo, state, grid, timeIndex, dt)
-
- ! Note: this routine assumes that there is only one block per processor. No looping
- ! is preformed over blocks.
- ! dminfo is the domain info needed for global communication
- ! state contains the state variables needed to compute global diagnostics
- ! grid conains the meta data about the grid
- ! timeIndex is the current time step counter
- ! dt is the duration of each time step
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! INSTRUCTIONS !
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! To add a new Diagnostic as a Global Stat, follow these steps.
- ! 1. Define the array to integrate, and the variable for the value above.
- ! 2. Allocate the array with the correct dimensions.
- ! 3. Fill the array with the data to be integrated.
- ! eg. GlobalFluidThickness = Sum(h dA)/Sum(dA), See below for array filling
- ! 4. Call Function to compute Global Stat that you want.
- ! 5. Finish computing the global stat/integral
- ! 6. Write out your global stat to the file
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
- type (state_type), intent(inout) :: state
- type (mesh_type), intent(in) :: grid
- integer, intent(in) :: timeIndex
- real (kind=RKIND), intent(in) :: dt
-
- integer :: nVertLevels, nCellsSolve, nEdgesSolve, nVerticesSolve, nCellsGlobal, nEdgesGlobal, nVerticesGlobal, iTracer
- integer :: nCells
-
- ! Step 1
- ! 1. Define the array to integrate, and the variable for the value to be stored in after the integration
- real (kind=RKIND), dimension(:), pointer :: areaCell, dcEdge, dvEdge, areaTriangle, h_s, fCell, fEdge
- real (kind=RKIND), dimension(:,:), pointer :: h, u, v, h_edge, pv_edge, pv_vertex, pv_cell, h_vertex, weightsOnEdge
-
- real (kind=RKIND), dimension(:,:,:), pointer :: tracers
-
- real (kind=RKIND), dimension(:), allocatable :: volumeWeightedPotentialEnergyReservoir, averageThickness
- real (kind=RKIND), dimension(:), allocatable :: potentialEnstrophyReservior, areaEdge, h_s_edge
-
- real (kind=RKIND), dimension(:,:), allocatable :: cellVolume, cellArea, volumeWeightedPotentialVorticity
- real (kind=RKIND), dimension(:,:), allocatable :: volumeWeightedPotentialEnstrophy, vertexVolume, volumeWeightedKineticEnergy
- real (kind=RKIND), dimension(:,:), allocatable :: volumeWeightedPotentialEnergy, volumeWeightedPotentialEnergyTopography
- real (kind=RKIND), dimension(:,:), allocatable :: keTend_CoriolisForce, keTend_PressureGradient
- real (kind=RKIND), dimension(:,:), allocatable ::peTend_DivThickness, refAreaWeightedSurfaceHeight, refAreaWeightedSurfaceHeight_edge
-
- real (kind=RKIND) :: sumCellVolume, sumCellArea, sumVertexVolume, sumrefAreaWeightedSurfaceHeight
-
- real (kind=RKIND) :: globalFluidThickness, globalPotentialVorticity, globalPotentialEnstrophy, globalEnergy
- real (kind=RKIND) :: globalCoriolisEnergyTendency, globalKEPETendency, globalPotentialEnstrophyReservoir
- real (kind=RKIND) :: globalKineticEnergy, globalPotentialEnergy, globalPotentialEnergyReservoir
- real (kind=RKIND) :: globalKineticEnergyTendency, globalPotentialEnergyTendency
- real (kind=RKIND) :: global_temp, workpv, q
- real (kind=RKIND) :: volumeCellGlobal, volumeEdgeGlobal, CFLNumberGlobal
-
- integer :: elementIndex, variableIndex, nVariables, nSums, nMaxes, nMins
- integer :: timeLevel, eoe, iLevel, iCell, iEdge, iVertex
- integer :: fileID, iCell1, iCell2, j
-
- integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnCell, edgesOnEdge
- integer, dimension(:), pointer :: nEdgesOnEdge
-
- cellsOnEdge => grid % cellsOnEdge % array
- edgesOnCell => grid % edgesOnCell % array
-
- nVertLevels = grid % nVertLevels
- nCellsSolve = grid % nCellsSolve
- nEdgesSolve = grid % nEdgesSolve
- nVerticesSolve = grid % nVerticesSolve
- nCells = grid % nCells
-
- h_s => grid % h_s % array
- areaCell => grid % areaCell % array
- dcEdge => grid % dcEdge % array
- dvEdge => grid % dvEdge % array
- areaTriangle => grid % areaTriangle % array
- fCell => grid % fCell % array
- fEdge => grid % fEdge % array
- edgesOnEdge => grid % edgesOnEdge % array
- nEdgesOnEdge => grid % nEdgesOnEdge % array
-
- allocate(areaEdge(1:nEdgesSolve))
- areaEdge = dcEdge(1:nEdgesSolve)*dvEdge(1:nEdgesSolve)
- weightsOnEdge => grid % weightsOnEdge % array
-
- h => state % h % array
- u => state % u % array
- v => state % v % array
- tracers => state % tracers % array
- h_edge => state % h_edge % array
- h_vertex => state % h_vertex % array
- pv_edge => state % pv_edge % array
- pv_vertex => state % pv_vertex % array
- pv_cell => state % pv_cell % array
-
- ! Step 2
- ! 2. Allocate the array with the correct dimensions.
- allocate(cellVolume(nVertLevels,nCellsSolve))
- allocate(cellArea(nVertLevels,nCellsSolve))
- allocate(refAreaWeightedSurfaceHeight(nVertLevels,nCellsSolve))
- allocate(refAreaWeightedSurfaceHeight_edge(nVertLevels,nEdgesSolve))
- allocate(volumeWeightedPotentialVorticity(nVertLevels,nVerticesSolve))
- allocate(volumeWeightedPotentialEnstrophy(nVertLevels,nVerticesSolve))
- allocate(potentialEnstrophyReservior(nCellsSolve))
- allocate(vertexVolume(nVertLevels,nVerticesSolve))
- allocate(volumeWeightedKineticEnergy(nVertLevels,nEdgesSolve))
- allocate(volumeWeightedPotentialEnergy(nVertLevels,nCellsSolve))
- allocate(volumeWeightedPotentialEnergyTopography(nVertLevels,nCellsSolve))
- allocate(volumeWeightedPotentialEnergyReservoir(nCellsSolve))
- allocate(keTend_CoriolisForce(nVertLevels,nEdgesSolve))
- allocate(keTend_PressureGradient(nVertLevels,nEdgesSolve))
- allocate(peTend_DivThickness(nVertLevels,nCells))
-
- allocate(averageThickness(nCellsSolve))
-
- allocate(h_s_edge(nEdgesSOlve))
-
-
- cellVolume = 0
- refAreaWeightedSurfaceHeight = 0
- refAreaWeightedSurfaceHeight_edge = 0
- vertexVolume = 0
- cellArea = 0
- averageThickness = 0
- volumeWeightedPotentialVorticity = 0
- volumeWeightedPotentialEnstrophy = 0
- volumeWeightedKineticEnergy = 0
- volumeWeightedPotentialEnergy = 0
- volumeWeightedPotentialEnergyTopography = 0
- volumeWeightedPotentialEnergyReservoir = 0
- keTend_PressureGradient = 0
- peTend_DivThickness = 0
- keTend_CoriolisForce = 0
- h_s_edge = 0
-
- ! Build Arrays for Global Integrals
- ! Step 3
- ! 3. Fill the array with the data to be integrated.
- ! eg. GlobalFluidThickness = Sum(h dA)/Sum(dA), See below for array filling
- do iLevel = 1,nVertLevels
- ! eg. GlobalFluidThickness top (Sum( h dA)) = Sum(cellVolume)
- cellVolume(iLevel,:) = h(iLevel,1:nCellsSolve)*areaCell(1:nCellsSolve)
- ! eg. GlobalFluidThickness bot (Sum(dA)) = Sum(cellArea)
- cellArea(iLevel,:) = areaCell(1:nCellsSolve)
- volumeWeightedPotentialVorticity(iLevel,:) = pv_vertex(iLevel,1:nVerticesSolve) &
- *h_vertex(iLevel,1:nVerticesSolve)*areaTriangle(1:nVerticesSolve)
- volumeWeightedPotentialEnstrophy(iLevel,:) = pv_vertex(iLevel,1:nVerticesSolve) &
- *pv_vertex(iLevel,1:nVerticesSolve)*h_vertex(iLevel,1:nVerticesSolve)*areaTriangle(1:nVerticesSolve)
- vertexVolume(iLevel,:) = h_vertex(iLevel,1:nVerticesSolve)*areaTriangle(1:nVerticesSolve)
- volumeWeightedKineticEnergy(iLevel,:) = u(iLevel,1:nEdgesSolve)*u(iLevel,1:nEdgesSolve) &
- *h_edge(iLevel,1:nEdgesSolve)*areaEdge(1:nEdgesSolve)*0.5
- volumeWeightedPotentialEnergy(iLevel,:) = gravity*h(iLevel,1:nCellsSolve)*h(iLevel,1:nCellsSolve)*areaCell(1:nCellsSolve)*0.5
- volumeWeightedPotentialEnergyTopography(iLevel,:) = gravity*h(iLevel,1:nCellsSolve)*h_s(1:nCellsSolve)*areaCell(1:nCellsSolve)
- refAreaWeightedSurfaceHeight(iLevel,:) = areaCell(1:nCellsSolve)*(h(iLevel,1:nCellsSolve)+h_s(1:nCellsSolve))
-
- do iEdge = 1,nEdgesSolve
- q = 0.0
- do j = 1,nEdgesOnEdge(iEdge)
- eoe = edgesOnEdge(j,iEdge)
- workpv = 0.5 * (pv_edge(iLevel,iEdge) + pv_edge(iLevel,eoe))
- q = q + weightsOnEdge(j,iEdge) * u(iLevel,eoe) * workpv * h_edge(iLevel,eoe)
- end do
- keTend_CoriolisForce(iLevel,iEdge) = h_edge(iLevel,iEdge) * u(iLevel,iEdge) * q * areaEdge(iEdge)
-
- iCell1 = cellsOnEdge(1,iEdge)
- iCell2 = cellsOnEdge(2,iEdge)
-
- refAreaWeightedSurfaceHeight_edge(iLevel,iEdge) = areaEdge(iEdge)*(h_edge(iLevel,iEdge) + 0.5*(h_s(iCell1) + h_s(iCell2)))
-
- keTend_PressureGradient(iLevel,iEdge) = areaEdge(iEdge)*h_edge(iLevel,iEdge)*u(iLevel,iEdge) &
- *gravity*(h(iLevel,iCell2)+h_s(iCell2) - h(iLevel,iCell1)-h_s(iCell1))/dcEdge(iEdge)
- peTend_DivThickness(iLevel,iCell1) = peTend_DivThickness(iLevel,iCell1) &
- + h_edge(iLevel,iEdge)*u(iLevel,iEdge)*dvEdge(iEdge)
- peTend_DivThickness(iLevel,iCell2) = peTend_DivThickness(iLevel,iCell2) &
- - h_edge(iLevel,iEdge)*u(iLevel,iEdge)*dvEdge(iEdge)
- end do
-
- peTend_DivThickness(iLevel,:) = peTend_DivThickness(iLevel,1:nCells)*gravity &
- *(h(iLevel,1:nCells)+h_s(1:nCells))
- end do
-
- do iEdge = 1,nEdgesSolve
- iCell1 = cellsOnEdge(1,iEdge)
- iCell2 = cellsOnEdge(2,iEdge)
-
- h_s_edge(iEdge) = 0.5*(h_s(iCell1) + h_s(iCell2))
- end do
-
- ! Step 4
- ! 4. Call Function to compute Global Stat that you want.
- ! Computing Kinetic and Potential Energy Tendency Terms
- call computeGlobalSum(dminfo, nVertLevels, nEdgesSolve, keTend_PressureGradient, globalKineticEnergyTendency)
- call computeGlobalSum(dminfo, nVertLevels, nCells, peTend_DivThickness, globalPotentialEnergyTendency)
-
- ! Computing top and bottom of global mass integral
- call computeGlobalSum(dminfo, nVertLevels, nCellsSolve, cellVolume, sumCellVolume)
- call computeGlobalSum(dminfo, nVertLevels, nCellsSolve, cellArea, sumCellArea)
-
- globalKineticEnergyTendency = globalKineticEnergyTendency / sumCellVolume
- globalPotentialEnergyTendency = globalPotentialEnergyTendency / sumCellVolume
-
- ! Step 5
- ! 5. Finish computing the global stat/integral
- globalFluidThickness = sumCellVolume/sumCellArea
-
- ! Compute Average Sea Surface Height for Potential Energy and Enstrophy
- ! Reservoir computations
- call computeGlobalSum(dminfo, nVertLevels, nCellsSolve, refAreaWeightedSurfaceHeight, sumrefAreaWeightedSurfaceHeight)
-
- averageThickness(:) = (sumrefAreaWeightedSurfaceHeight/sumCellArea)-h_s(1:nCellsSolve)
-
- ! Compute Volume Weighted Averages of Potential Vorticity and Potential Enstrophy
- call computeGlobalSum(dminfo, nVertLevels, nVerticesSolve, volumeWeightedPotentialVorticity, globalPotentialVorticity)
- call computeGlobalSum(dminfo, nVertLevels, nVerticesSolve, volumeWeightedPotentialEnstrophy, globalPotentialEnstrophy)
- call computeGlobalSum(dminfo, nVertLevels, nVerticesSolve, vertexVolume, sumVertexVolume)
-
- globalPotentialVorticity = globalPotentialVorticity/sumVertexVolume
- globalPotentialEnstrophy = globalPotentialEnstrophy/sumVertexVolume
-
- ! Compte Potential Enstrophy Reservior
- potentialEnstrophyReservior(:) = areaCell(:)*fCell(:)*fCell(:)/averageThickness
- call computeGlobalSum(dminfo, 1, nCellsSolve, potentialEnstrophyReservior, globalPotentialEnstrophyReservoir)
- globalPotentialEnstrophyReservoir = globalPotentialEnstrophyReservoir/sumCellVolume
-
- globalPotentialEnstrophy = globalPotentialEnstrophy - globalPotentialEnstrophyReservoir
-
- ! Compute Kinetic and Potential Energy terms to be combined into total energy
- call computeGlobalSum(dminfo, nVertLevels, nEdgesSolve, volumeWeightedKineticEnergy, globalKineticEnergy)
- call computeGlobalSum(dminfo, nVertLevels, nCellsSolve, volumeWeightedPotentialEnergy, globalPotentialEnergy)
- call computeGlobalSum(dminfo, nVertLevels, nCellsSolve, volumeWeightedPotentialEnergyTopography, global_temp)
-
- globalKineticEnergy = globalKineticEnergy/sumCellVolume
- globalPotentialEnergy = (globalPotentialEnergy + global_temp)/sumCellVolume
-
- ! Compute Potential energy reservoir to be subtracted from potential energy term
- volumeWeightedPotentialEnergyReservoir(1:nCellsSolve) = areaCell(1:nCellsSolve)*averageThickness*averageThickness*gravity*0.5
- call computeGlobalSum(dminfo, nVertLevels, nCellsSolve, volumeWeightedPotentialEnergyReservoir, globalPotentialEnergyReservoir)
- volumeWeightedPotentialEnergyReservoir(1:nCellsSolve) = areaCell(1:nCellsSolve)*averageThickness*h_s(1:nCellsSolve)*gravity
- call computeGlobalSum(dminfo, nVertLevels, nCellsSolve, volumeWeightedPotentialEnergyReservoir, global_temp)
-
- globalPotentialEnergyReservoir = (globalPotentialEnergyReservoir + global_temp)/sumCellVolume
-
- globalPotentialEnergy = globalPotentialEnergy - globalPotentialEnergyReservoir
- globalEnergy = globalKineticEnergy + globalPotentialEnergy
-
- ! Compute Coriolis energy tendency term
- call computeGlobalSum(dminfo, nVertLevels, nEdgesSolve, keTend_CoriolisForce, globalCoriolisEnergyTendency)
- globalCoriolisEnergyTendency = globalCoriolisEnergyTendency/sumCellVolume
-
- ! Step 6
- ! 6. Write out your global stat to the file
- if (dminfo % my_proc_id == IO_NODE) then
- fileID = getFreeUnit()
-
- if (timeIndex/config_stats_interval == 1) then
- open(fileID, file='GlobalIntegrals.txt',STATUS='unknown')
- else
- open(fileID, file='GlobalIntegrals.txt',POSITION='append')
- endif
- write(fileID,'(1i0, 100es24.16)') timeIndex, timeIndex*dt, globalFluidThickness, globalPotentialVorticity, globalPotentialEnstrophy, &
- globalEnergy, globalCoriolisEnergyTendency, globalKineticEnergyTendency+globalPotentialEnergyTendency, &
- globalKineticEnergy, globalPotentialEnergy
- close(fileID)
- end if
-
- deallocate(areaEdge)
- end subroutine computeGlobalDiagnostics
-
- integer function getFreeUnit()
- implicit none
-
- integer :: index
- logical :: isOpened
-
- getFreeUnit = 0
- do index = 1,99
- if((index /= 5) .and. (index /= 6)) then
- inquire(unit = index, opened = isOpened)
- if( .not. isOpened) then
- getFreeUnit = index
- return
- end if
- end if
- end do
- end function getFreeUnit
-
- subroutine computeGlobalSum(dminfo, nVertLevels, nElements, field, globalSum)
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: nVertLevels, nElements
- real (kind=RKIND), dimension(nVertLevels, nElements), intent(in) :: field
- real (kind=RKIND), intent(out) :: globalSum
-
- real (kind=RKIND) :: localSum
-
- localSum = sum(field)
- call dmpar_sum_real(dminfo, localSum, globalSum)
-
- end subroutine computeGlobalSum
-
- subroutine computeGlobalMin(dminfo, nVertLevels, nElements, field, globalMin)
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: nVertLevels, nElements
- real (kind=RKIND), dimension(nVertLevels, nElements), intent(in) :: field
- real (kind=RKIND), intent(out) :: globalMin
-
- real (kind=RKIND) :: localMin
-
- localMin = minval(field)
- call dmpar_min_real(dminfo, localMin, globalMin)
-
- end subroutine computeGlobalMin
-
- subroutine computeGlobalMax(dminfo, nVertLevels, nElements, field, globalMax)
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: nVertLevels, nElements
- real (kind=RKIND), dimension(nVertLevels, nElements), intent(in) :: field
- real (kind=RKIND), intent(out) :: globalMax
-
- real (kind=RKIND) :: localMax
-
- localMax = maxval(field)
- call dmpar_max_real(dminfo, localMax, globalMax)
-
- end subroutine computeGlobalMax
-
- subroutine computeGlobalVertSumHorizMin(dminfo, nVertLevels, nElements, field, globalMin)
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: nVertLevels, nElements
- real (kind=RKIND), dimension(nVertLevels, nElements), intent(in) :: field
- real (kind=RKIND), intent(out) :: globalMin
-
- real (kind=RKIND) :: localMin
-
- localMin = minval(sum(field,1))
- call dmpar_min_real(dminfo, localMin, globalMin)
-
- end subroutine computeGlobalVertSumHorizMin
-
- subroutine computeGlobalVertSumHorizMax(dminfo, nVertLevels, nElements, field, globalMax)
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: nVertLevels, nElements
- real (kind=RKIND), dimension(nVertLevels, nElements), intent(in) :: field
- real (kind=RKIND), intent(out) :: globalMax
-
- real (kind=RKIND) :: localMax
-
- localMax = maxval(sum(field,1))
- call dmpar_max_real(dminfo, localMax, globalMax)
-
- end subroutine computeGlobalVertSumHorizMax
-
-end module global_diagnostics
Deleted: trunk/mpas/src/core_sw/module_mpas_core.F
===================================================================
--- trunk/mpas/src/core_sw/module_mpas_core.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_sw/module_mpas_core.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -1,382 +0,0 @@
-module mpas_core
-
- use mpas_framework
- use mpas_timekeeping
-
- type (io_output_object) :: restart_obj
- integer :: restart_frame
- integer :: current_outfile_frames
-
- type (MPAS_Clock_type) :: clock
-
- integer, parameter :: outputAlarmID = 1
- integer, parameter :: restartAlarmID = 2
- !integer, parameter :: statsAlarmID = 3
-
- contains
-
- subroutine mpas_core_init(domain, startTimeStamp)
-
- use configure
- use grid_types
- use test_cases
-
- implicit none
-
- type (domain_type), intent(inout) :: domain
- character(len=*), intent(out) :: startTimeStamp
-
- real (kind=RKIND) :: dt
- type (block_type), pointer :: block
-
-
- if (.not. config_do_restart) call setup_sw_test_case(domain)
-
- !
- ! Initialize core
- !
- dt = config_dt
-
- call simulation_clock_init(domain, dt, startTimeStamp)
-
- block => domain % blocklist
- do while (associated(block))
- call mpas_init_block(block, block % mesh, dt)
- block % state % time_levs(1) % state % xtime % scalar = startTimeStamp
- block => block % next
- end do
-
- restart_frame = 1
- current_outfile_frames = 0
-
- end subroutine mpas_core_init
-
-
- subroutine simulation_clock_init(domain, dt, startTimeStamp)
-
- implicit none
-
- type (domain_type), intent(inout) :: domain
- real (kind=RKIND), intent(in) :: dt
- character(len=*), intent(out) :: startTimeStamp
-
- type (MPAS_Time_Type) :: startTime, stopTime, alarmStartTime
- type (MPAS_TimeInterval_type) :: runDuration, timeStep, alarmTimeStep
- integer :: ierr
-
- call MPAS_setTime(curr_time=startTime, dateTimeString=config_start_time, ierr=ierr)
- call MPAS_setTimeInterval(timeStep, dt=dt, ierr=ierr)
-
- if (trim(config_run_duration) /= "none") then
- call MPAS_setTimeInterval(runDuration, timeString=config_run_duration, ierr=ierr)
- call MPAS_createClock(clock, startTime=startTime, timeStep=timeStep, runDuration=runDuration, ierr=ierr)
-
- if (trim(config_stop_time) /= "none") then
- call MPAS_setTime(curr_time=stopTime, dateTimeString=config_stop_time, ierr=ierr)
- if(startTime + runduration /= stopTime) then
- write(0,*) 'Warning: config_run_duration and config_stop_time are inconsitent: using config_run_duration.'
- end if
- end if
- else if (trim(config_stop_time) /= "none") then
- call MPAS_setTime(curr_time=stopTime, dateTimeString=config_stop_time, ierr=ierr)
- call MPAS_createClock(clock, startTime=startTime, timeStep=timeStep, stopTime=stopTime, ierr=ierr)
- else
- write(0,*) 'Error: Neither config_run_duration nor config_stop_time were specified.'
- call dmpar_abort(domain % dminfo)
- end if
-
- ! set output alarm
- call MPAS_setTimeInterval(alarmTimeStep, timeString=config_output_interval, ierr=ierr)
- alarmStartTime = startTime + alarmTimeStep
- call MPAS_addClockAlarm(clock, outputAlarmID, alarmStartTime, alarmTimeStep, ierr=ierr)
-
- ! set restart alarm, if necessary
- if (trim(config_restart_interval) /= "none") then
- call MPAS_setTimeInterval(alarmTimeStep, timeString=config_restart_interval, ierr=ierr)
- alarmStartTime = startTime + alarmTimeStep
- call MPAS_addClockAlarm(clock, restartAlarmID, alarmStartTime, alarmTimeStep, ierr=ierr)
- end if
-
- !TODO: use this code if we desire to convert config_stats_interval to alarms
- !(must also change config_stats_interval type to character)
- ! set stats alarm, if necessary
- !if (trim(config_stats_interval) /= "none") then
- ! call MPAS_setTimeInterval(alarmTimeStep, timeString=config_stats_interval, ierr=ierr)
- ! alarmStartTime = startTime + alarmTimeStep
- ! call MPAS_addClockAlarm(clock, statsAlarmID, alarmStartTime, alarmTimeStep, ierr=ierr)
- !end if
-
- call MPAS_getTime(curr_time=startTime, dateTimeString=startTimeStamp, ierr=ierr)
-
- end subroutine simulation_clock_init
-
-
- subroutine mpas_init_block(block, mesh, dt)
-
- use grid_types
- use time_integration
- use RBF_interpolation
- use vector_reconstruction
-
- implicit none
-
- type (block_type), intent(inout) :: block
- type (mesh_type), intent(inout) :: mesh
- real (kind=RKIND), intent(in) :: dt
-
-
- call compute_solve_diagnostics(dt, block % state % time_levs(1) % state, mesh)
- call compute_mesh_scaling(mesh)
-
- call rbfInterp_initialize(mesh)
- call init_reconstruct(mesh)
- call reconstruct(mesh, block % state % time_levs(1) % state % u % array, &
- block % state % time_levs(1) % state % uReconstructX % array, &
- block % state % time_levs(1) % state % uReconstructY % array, &
- block % state % time_levs(1) % state % uReconstructZ % array, &
- block % state % time_levs(1) % state % uReconstructZonal % array, &
- block % state % time_levs(1) % state % uReconstructMeridional % array &
- )
-
-
- end subroutine mpas_init_block
-
-
- subroutine mpas_core_run(domain, output_obj, output_frame)
-
- use grid_types
- use io_output
- use timer
-
- implicit none
-
- type (domain_type), intent(inout) :: domain
- type (io_output_object), intent(inout) :: output_obj
- integer, intent(inout) :: output_frame
-
- integer :: itimestep
- real (kind=RKIND) :: dt
- type (block_type), pointer :: block_ptr
-
- type (MPAS_Time_Type) :: currTime
- character(len=32) :: timeStamp
- integer :: ierr
-
- ! Eventually, dt should be domain specific
- dt = config_dt
-
- currTime = MPAS_getClockTime(clock, MPAS_NOW, ierr)
- call MPAS_getTime(curr_time=currTime, dateTimeString=timeStamp, ierr=ierr)
- write(0,*) 'Initial timestep ', timeStamp
-
- call write_output_frame(output_obj, output_frame, domain)
-
- ! During integration, time level 1 stores the model state at the beginning of the
- ! time step, and time level 2 stores the state advanced dt in time by timestep(...)
- itimestep = 0
- do while (.not. MPAS_isClockStopTime(clock))
-
- itimestep = itimestep + 1
- call MPAS_advanceClock(clock)
-
- currTime = MPAS_getClockTime(clock, MPAS_NOW, ierr)
- call MPAS_getTime(curr_time=currTime, dateTimeString=timeStamp, ierr=ierr)
- write(0,*) 'Doing timestep ', timeStamp
-
- call timer_start("time integration")
- call mpas_timestep(domain, itimestep, dt, timeStamp)
- call timer_stop("time integration")
-
- ! Move time level 2 fields back into time level 1 for next time step
- call shift_time_levels_state(domain % blocklist % state)
-
- !TODO: MPAS_getClockRingingAlarms is probably faster than multiple MPAS_isAlarmRinging...
-
- if (MPAS_isAlarmRinging(clock, outputAlarmID, ierr=ierr)) then
- call MPAS_resetClockAlarm(clock, outputAlarmID, ierr=ierr)
- if(output_frame == 1) call output_state_init(output_obj, domain, "OUTPUT", trim(timeStamp)) ! output_frame will always be > 1 here unless it is reset after the output file is finalized
- call write_output_frame(output_obj, output_frame, domain)
- end if
-
- if (MPAS_isAlarmRinging(clock, restartAlarmID, ierr=ierr)) then
- call MPAS_resetClockAlarm(clock, restartAlarmID, ierr=ierr)
- if (restart_frame == 1) call output_state_init(restart_obj, domain, "RESTART")
- call output_state_for_domain(restart_obj, domain, restart_frame)
- restart_frame = restart_frame + 1
- end if
-
- end do
-
- end subroutine mpas_core_run
-
-
- subroutine write_output_frame(output_obj, output_frame, domain)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Compute diagnostic fields for a domain and write model state to output file
- !
- ! Input/Output: domain - contains model state; diagnostic field are computed
- ! before returning
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- use grid_types
- use io_output
-
- implicit none
-
- type (io_output_object), intent(inout) :: output_obj
- integer, intent(inout) :: output_frame
- type (domain_type), intent(inout) :: domain
-
- integer :: i, j, k
- integer :: eoe
- type (block_type), pointer :: block_ptr
-
- block_ptr => domain % blocklist
- do while (associated(block_ptr))
- call compute_output_diagnostics(block_ptr % state % time_levs(1) % state, block_ptr % mesh)
- block_ptr => block_ptr % next
- end do
-
- call output_state_for_domain(output_obj, domain, output_frame)
- output_frame = output_frame + 1
-
- ! if the maximum number of frames per outfile has been reached, finalize outfile and reset frame
- if (config_frames_per_outfile > 0) then
- current_outfile_frames = current_outfile_frames + 1
- if(current_outfile_frames >= config_frames_per_outfile) then
- current_outfile_frames = 0
- call output_state_finalize(output_obj, domain % dminfo)
- output_frame = 1
- end if
- end if
-
- end subroutine write_output_frame
-
-
- subroutine compute_output_diagnostics(state, grid)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Compute diagnostic fields for a domain
- !
- ! Input: state - contains model prognostic fields
- ! grid - contains grid metadata
- !
- ! Output: state - upon returning, diagnostic fields will have be computed
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- use grid_types
-
- implicit none
-
- type (state_type), intent(inout) :: state
- type (mesh_type), intent(in) :: grid
-
- integer :: i, eoe
- integer :: iEdge, k
-
- end subroutine compute_output_diagnostics
-
-
- subroutine mpas_timestep(domain, itimestep, dt, timeStamp)
-
- use grid_types
- use time_integration
- use timer
- use global_diagnostics
-
- implicit none
-
- type (domain_type), intent(inout) :: domain
- integer, intent(in) :: itimestep
- real (kind=RKIND), intent(in) :: dt
- character(len=*), intent(in) :: timeStamp
-
- type (block_type), pointer :: block_ptr
- integer :: ierr
-
- call timestep(domain, dt, timeStamp)
-
- if(config_stats_interval .gt. 0) then
- if(mod(itimestep, config_stats_interval) == 0) then
- block_ptr => domain % blocklist
- if(associated(block_ptr % next)) then
- write(0,*) 'Error: computeGlobalDiagnostics assumes ',&
- 'that there is only one block per processor.'
- end if
-
- call timer_start("global_diagnostics")
- call computeGlobalDiagnostics(domain % dminfo, &
- block_ptr % state % time_levs(2) % state, block_ptr % mesh, &
- itimestep, dt)
- call timer_stop("global_diagnostics")
- end if
- end if
-
- !TODO: replace the above code block with this if we desire to convert config_stats_interval to use alarms
- !if (MPAS_isAlarmRinging(clock, statsAlarmID, ierr=ierr)) then
- ! call MPAS_resetClockAlarm(clock, statsAlarmID, ierr=ierr)
-
- ! block_ptr => domain % blocklist
- ! if(associated(block_ptr % next)) then
- ! write(0,*) 'Error: computeGlobalDiagnostics assumes ',&
- ! 'that there is only one block per processor.'
- ! end if
-
- ! call timer_start("global_diagnostics")
- ! call computeGlobalDiagnostics(domain % dminfo, &
- ! block_ptr % state % time_levs(2) % state, block_ptr % mesh, &
- ! timeStamp, dt)
- ! call timer_stop("global_diagnostics")
- !end if
-
- end subroutine mpas_timestep
-
-
- subroutine mpas_core_finalize(domain)
-
- use grid_types
-
- implicit none
-
- integer :: ierr
-
- type (domain_type), intent(inout) :: domain
-
- if (restart_frame > 1) call output_state_finalize(restart_obj, domain % dminfo)
-
- call MPAS_destroyClock(clock, ierr)
-
- end subroutine mpas_core_finalize
-
-
- subroutine compute_mesh_scaling(mesh)
-
- use grid_types
-
- implicit none
-
- type (mesh_type), intent(inout) :: mesh
-
- integer :: iEdge, cell1, cell2
- real (kind=RKIND), dimension(:), pointer :: meshDensity, meshScalingDel2, meshScalingDel4
-
- meshDensity => mesh % meshDensity % array
- meshScalingDel2 => mesh % meshScalingDel2 % array
- meshScalingDel4 => mesh % meshScalingDel4 % array
-
- !
- ! Compute the scaling factors to be used in the del2 and del4 dissipation
- !
- meshScalingDel2(:) = 1.0
- meshScalingDel4(:) = 1.0
- if (config_h_ScaleWithMesh) then
- do iEdge=1,mesh%nEdges
- cell1 = mesh % cellsOnEdge % array(1,iEdge)
- cell2 = mesh % cellsOnEdge % array(2,iEdge)
- meshScalingDel2(iEdge) = 1.0 / ( (meshDensity(cell1) + meshDensity(cell2) )/2.0)**(5.0/12.0)
- meshScalingDel4(iEdge) = 1.0 / ( (meshDensity(cell1) + meshDensity(cell2) )/2.0)**(5.0/6.0)
- end do
- end if
-
- end subroutine compute_mesh_scaling
-
-end module mpas_core
Deleted: trunk/mpas/src/core_sw/module_test_cases.F
===================================================================
--- trunk/mpas/src/core_sw/module_test_cases.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_sw/module_test_cases.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -1,527 +0,0 @@
-module test_cases
-
- use grid_types
- use configure
- use constants
-
-
- contains
-
-
- subroutine setup_sw_test_case(domain)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Configure grid metadata and model state for the shallow water test case
- ! specified in the namelist
- !
- ! Output: block - a subset (not necessarily proper) of the model domain to be
- ! initialized
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (domain_type), intent(inout) :: domain
-
- integer :: i
- type (block_type), pointer :: block_ptr
-
- if (config_test_case == 0) then
- write(0,*) 'Using initial conditions supplied in input file'
-
- else if (config_test_case == 1) then
- write(0,*) 'Setting up shallow water test case 1'
- write(0,*) ' -- Advection of Cosine Bell over the Pole'
-
- block_ptr => domain % blocklist
- do while (associated(block_ptr))
- call sw_test_case_1(block_ptr % mesh, block_ptr % state % time_levs(1) % state)
- do i=2,nTimeLevs
- call copy_state(block_ptr % state % time_levs(i) % state, block_ptr % state % time_levs(1) % state)
- end do
-
- block_ptr => block_ptr % next
- end do
-
- else if (config_test_case == 2) then
- write(0,*) 'Setting up shallow water test case 2'
- write(0,*) ' -- Setup shallow water test case 2: Global Steady State Nonlinear Zonal Geostrophic Flow'
-
- block_ptr => domain % blocklist
- do while (associated(block_ptr))
- call sw_test_case_2(block_ptr % mesh, block_ptr % state % time_levs(1) % state)
- do i=2,nTimeLevs
- call copy_state(block_ptr % state % time_levs(i) % state, block_ptr % state % time_levs(1) % state)
- end do
-
- block_ptr => block_ptr % next
- end do
-
- else if (config_test_case == 5) then
- write(0,*) 'Setting up shallow water test case 5'
- write(0,*) ' -- Setup shallow water test case 5: Zonal Flow over an Isolated Mountain'
-
- block_ptr => domain % blocklist
- do while (associated(block_ptr))
- call sw_test_case_5(block_ptr % mesh, block_ptr % state % time_levs(1) % state)
- do i=2,nTimeLevs
- call copy_state(block_ptr % state % time_levs(i) % state, block_ptr % state % time_levs(1) % state)
- end do
-
- block_ptr => block_ptr % next
- end do
-
- else if (config_test_case == 6) then
- write(0,*) 'Setting up shallow water test case 6'
- write(0,*) ' -- Rossby-Haurwitz Wave'
-
- block_ptr => domain % blocklist
- do while (associated(block_ptr))
- call sw_test_case_6(block_ptr % mesh, block_ptr % state % time_levs(1) % state)
- do i=2,nTimeLevs
- call copy_state(block_ptr % state % time_levs(i) % state, block_ptr % state % time_levs(1) % state)
- end do
-
- block_ptr => block_ptr % next
- end do
-
- else
- write(0,*) 'Only test case 1, 2, 5, and 6 are currently supported.'
- stop
- end if
-
- end subroutine setup_sw_test_case
-
-
- subroutine sw_test_case_1(grid, state)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Setup shallow water test case 1: Advection of Cosine Bell over the Pole
- !
- ! Reference: Williamson, D.L., et al., "A Standard Test Set for Numerical
- ! Approximations to the Shallow Water Equations in Spherical
- ! Geometry" J. of Comp. Phys., 102, pp. 211--224
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (mesh_type), intent(inout) :: grid
- type (state_type), intent(inout) :: state
-
- real (kind=RKIND), parameter :: u0 = 2.0 * pii * a / (12.0 * 86400.0)
- real (kind=RKIND), parameter :: h0 = 1000.0
- real (kind=RKIND), parameter :: theta_c = 0.0
- real (kind=RKIND), parameter :: lambda_c = 3.0*pii/2.0
- real (kind=RKIND), parameter :: alpha = pii/4.0
-
- integer :: iCell, iEdge, iVtx
- real (kind=RKIND) :: r, u, v
- real (kind=RKIND), allocatable, dimension(:) :: psiVertex
-
- !
- ! Scale all distances and areas from a unit sphere to one with radius a
- !
- grid % xCell % array = grid % xCell % array * a
- grid % yCell % array = grid % yCell % array * a
- grid % zCell % array = grid % zCell % array * a
- grid % xVertex % array = grid % xVertex % array * a
- grid % yVertex % array = grid % yVertex % array * a
- grid % zVertex % array = grid % zVertex % array * a
- grid % xEdge % array = grid % xEdge % array * a
- grid % yEdge % array = grid % yEdge % array * a
- grid % zEdge % array = grid % zEdge % array * a
- grid % dvEdge % array = grid % dvEdge % array * a
- grid % dcEdge % array = grid % dcEdge % array * a
- grid % areaCell % array = grid % areaCell % array * a**2.0
- grid % areaTriangle % array = grid % areaTriangle % array * a**2.0
- grid % kiteAreasOnVertex % array = grid % kiteAreasOnVertex % array * a**2.0
-
- !
- ! Initialize wind field
- !
- allocate(psiVertex(grid % nVertices))
- do iVtx=1,grid % nVertices
- psiVertex(iVtx) = -a * u0 * ( &
- sin(grid%latVertex%array(iVtx)) * cos(alpha) - &
- cos(grid%lonVertex%array(iVtx)) * cos(grid%latVertex%array(iVtx)) * sin(alpha) &
- )
- end do
- do iEdge=1,grid % nEdges
- state % u % array(1,iEdge) = -1.0 * ( &
- psiVertex(grid%verticesOnEdge%array(2,iEdge)) - &
- psiVertex(grid%verticesOnEdge%array(1,iEdge)) &
- ) / grid%dvEdge%array(iEdge)
- end do
- deallocate(psiVertex)
-
- !
- ! Initialize cosine bell at (theta_c, lambda_c)
- !
- do iCell=1,grid % nCells
- r = sphere_distance(theta_c, lambda_c, grid % latCell % array(iCell), grid % lonCell % array(iCell), a)
- if (r < a/3.0) then
- state % h % array(1,iCell) = (h0 / 2.0) * (1.0 + cos(pii*r*3.0/a))
- else
- state % h % array(1,iCell) = 0.0
- end if
- end do
-
- end subroutine sw_test_case_1
-
-
- subroutine sw_test_case_2(grid, state)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Setup shallow water test case 2: Global Steady State Nonlinear Zonal
- ! Geostrophic Flow
- !
- ! Reference: Williamson, D.L., et al., "A Standard Test Set for Numerical
- ! Approximations to the Shallow Water Equations in Spherical
- ! Geometry" J. of Comp. Phys., 102, pp. 211--224
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (mesh_type), intent(inout) :: grid
- type (state_type), intent(inout) :: state
-
- real (kind=RKIND), parameter :: u0 = 2.0 * pii * a / (12.0 * 86400.0)
- real (kind=RKIND), parameter :: gh0 = 29400.0
- real (kind=RKIND), parameter :: alpha = 0.0
-
- integer :: iCell, iEdge, iVtx
- real (kind=RKIND) :: u, v
- real (kind=RKIND), allocatable, dimension(:) :: psiVertex
-
-
- !
- ! Scale all distances and areas from a unit sphere to one with radius a
- !
- grid % xCell % array = grid % xCell % array * a
- grid % yCell % array = grid % yCell % array * a
- grid % zCell % array = grid % zCell % array * a
- grid % xVertex % array = grid % xVertex % array * a
- grid % yVertex % array = grid % yVertex % array * a
- grid % zVertex % array = grid % zVertex % array * a
- grid % xEdge % array = grid % xEdge % array * a
- grid % yEdge % array = grid % yEdge % array * a
- grid % zEdge % array = grid % zEdge % array * a
- grid % dvEdge % array = grid % dvEdge % array * a
- grid % dcEdge % array = grid % dcEdge % array * a
- grid % areaCell % array = grid % areaCell % array * a**2.0
- grid % areaTriangle % array = grid % areaTriangle % array * a**2.0
- grid % kiteAreasOnVertex % array = grid % kiteAreasOnVertex % array * a**2.0
-
-
- !
- ! Initialize wind field
- !
- allocate(psiVertex(grid % nVertices))
- do iVtx=1,grid % nVertices
- psiVertex(iVtx) = -a * u0 * ( &
- sin(grid%latVertex%array(iVtx)) * cos(alpha) - &
- cos(grid%lonVertex%array(iVtx)) * cos(grid%latVertex%array(iVtx)) * sin(alpha) &
- )
- end do
- do iEdge=1,grid % nEdges
- state % u % array(1,iEdge) = -1.0 * ( &
- psiVertex(grid%verticesOnEdge%array(2,iEdge)) - &
- psiVertex(grid%verticesOnEdge%array(1,iEdge)) &
- ) / grid%dvEdge%array(iEdge)
- end do
- deallocate(psiVertex)
-
- !
- ! Generate rotated Coriolis field
- !
- do iEdge=1,grid % nEdges
- grid % fEdge % array(iEdge) = 2.0 * omega * &
- ( -cos(grid%lonEdge%array(iEdge)) * cos(grid%latEdge%array(iEdge)) * sin(alpha) + &
- sin(grid%latEdge%array(iEdge)) * cos(alpha) &
- )
- end do
- do iVtx=1,grid % nVertices
- grid % fVertex % array(iVtx) = 2.0 * omega * &
- (-cos(grid%lonVertex%array(iVtx)) * cos(grid%latVertex%array(iVtx)) * sin(alpha) + &
- sin(grid%latVertex%array(iVtx)) * cos(alpha) &
- )
- end do
-
- !
- ! Initialize height field (actually, fluid thickness field)
- !
- do iCell=1,grid % nCells
- state % h % array(1,iCell) = (gh0 - (a * omega * u0 + 0.5 * u0**2.0) * &
- (-cos(grid%lonCell%array(iCell)) * cos(grid%latCell%array(iCell)) * sin(alpha) + &
- sin(grid%latCell%array(iCell)) * cos(alpha) &
- )**2.0 &
- ) / &
- gravity
- end do
-
- end subroutine sw_test_case_2
-
-
- subroutine sw_test_case_5(grid, state)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Setup shallow water test case 5: Zonal Flow over an Isolated Mountain
- !
- ! Reference: Williamson, D.L., et al., "A Standard Test Set for Numerical
- ! Approximations to the Shallow Water Equations in Spherical
- ! Geometry" J. of Comp. Phys., 102, pp. 211--224
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (mesh_type), intent(inout) :: grid
- type (state_type), intent(inout) :: state
-
- real (kind=RKIND), parameter :: u0 = 20.
- real (kind=RKIND), parameter :: gh0 = 5960.0*gravity
- real (kind=RKIND), parameter :: hs0 = 2000.
- real (kind=RKIND), parameter :: theta_c = pii/6.0
- real (kind=RKIND), parameter :: lambda_c = 3.0*pii/2.0
- real (kind=RKIND), parameter :: rr = pii/9.0
- real (kind=RKIND), parameter :: alpha = 0.0
-
- integer :: iCell, iEdge, iVtx
- real (kind=RKIND) :: r, u, v
- real (kind=RKIND), allocatable, dimension(:) :: psiVertex
-
-
- !
- ! Scale all distances and areas from a unit sphere to one with radius a
- !
- grid % xCell % array = grid % xCell % array * a
- grid % yCell % array = grid % yCell % array * a
- grid % zCell % array = grid % zCell % array * a
- grid % xVertex % array = grid % xVertex % array * a
- grid % yVertex % array = grid % yVertex % array * a
- grid % zVertex % array = grid % zVertex % array * a
- grid % xEdge % array = grid % xEdge % array * a
- grid % yEdge % array = grid % yEdge % array * a
- grid % zEdge % array = grid % zEdge % array * a
- grid % dvEdge % array = grid % dvEdge % array * a
- grid % dcEdge % array = grid % dcEdge % array * a
- grid % areaCell % array = grid % areaCell % array * a**2.0
- grid % areaTriangle % array = grid % areaTriangle % array * a**2.0
- grid % kiteAreasOnVertex % array = grid % kiteAreasOnVertex % array * a**2.0
-
- !
- ! Initialize wind field
- !
- allocate(psiVertex(grid % nVertices))
- do iVtx=1,grid % nVertices
- psiVertex(iVtx) = -a * u0 * ( &
- sin(grid%latVertex%array(iVtx)) * cos(alpha) - &
- cos(grid%lonVertex%array(iVtx)) * cos(grid%latVertex%array(iVtx)) * sin(alpha) &
- )
- end do
- do iEdge=1,grid % nEdges
- state % u % array(1,iEdge) = -1.0 * ( &
- psiVertex(grid%verticesOnEdge%array(2,iEdge)) - &
- psiVertex(grid%verticesOnEdge%array(1,iEdge)) &
- ) / grid%dvEdge%array(iEdge)
- end do
- deallocate(psiVertex)
-
- !
- ! Generate rotated Coriolis field
- !
- do iEdge=1,grid % nEdges
- grid % fEdge % array(iEdge) = 2.0 * omega * &
- (-cos(grid%lonEdge%array(iEdge)) * cos(grid%latEdge%array(iEdge)) * sin(alpha) + &
- sin(grid%latEdge%array(iEdge)) * cos(alpha) &
- )
- end do
- do iVtx=1,grid % nVertices
- grid % fVertex % array(iVtx) = 2.0 * omega * &
- (-cos(grid%lonVertex%array(iVtx)) * cos(grid%latVertex%array(iVtx)) * sin(alpha) + &
- sin(grid%latVertex%array(iVtx)) * cos(alpha) &
- )
- end do
-
- !
- ! Initialize mountain
- !
- do iCell=1,grid % nCells
- if (grid % lonCell % array(iCell) < 0.0) grid % lonCell % array(iCell) = grid % lonCell % array(iCell) + 2.0 * pii
- r = sqrt(min(rr**2.0, (grid % lonCell % array(iCell) - lambda_c)**2.0 + (grid % latCell % array(iCell) - theta_c)**2.0))
- grid % h_s % array(iCell) = hs0 * (1.0 - r/rr)
- end do
-
- !
- ! Initialize tracer fields
- !
- do iCell=1,grid % nCells
- r = sqrt(min(rr**2.0, (grid % lonCell % array(iCell) - lambda_c)**2.0 + (grid % latCell % array(iCell) - theta_c)**2.0))
- state % tracers % array(1,1,iCell) = 1.0 - r/rr
- end do
- if (grid%nTracers > 1) then
- do iCell=1,grid % nCells
- r = sqrt(min(rr**2.0, (grid % lonCell % array(iCell) - lambda_c)**2.0 + &
- (grid % latCell % array(iCell) - theta_c - pii/6.0)**2.0 &
- ) &
- )
- state % tracers % array(2,1,iCell) = 1.0 - r/rr
- end do
- end if
-
- !
- ! Initialize height field (actually, fluid thickness field)
- !
- do iCell=1,grid % nCells
- state % h % array(1,iCell) = (gh0 - (a * omega * u0 + 0.5 * u0**2.0) * &
- (-cos(grid%lonCell%array(iCell)) * cos(grid%latCell%array(iCell)) * sin(alpha) + &
- sin(grid%latCell%array(iCell)) * cos(alpha) &
- )**2.0 &
- ) / &
- gravity
- state % h % array(1,iCell) = state % h % array(1,iCell) - grid % h_s % array(iCell)
- end do
-
- end subroutine sw_test_case_5
-
-
- subroutine sw_test_case_6(grid, state)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Setup shallow water test case 6: Rossby-Haurwitz Wave
- !
- ! Reference: Williamson, D.L., et al., "A Standard Test Set for Numerical
- ! Approximations to the Shallow Water Equations in Spherical
- ! Geometry" J. of Comp. Phys., 102, pp. 211--224
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (mesh_type), intent(inout) :: grid
- type (state_type), intent(inout) :: state
-
- real (kind=RKIND), parameter :: h0 = 8000.0
- real (kind=RKIND), parameter :: w = 7.848e-6
- real (kind=RKIND), parameter :: K = 7.848e-6
- real (kind=RKIND), parameter :: R = 4.0
-
- integer :: iCell, iEdge, iVtx
- real (kind=RKIND) :: u, v
- real (kind=RKIND), allocatable, dimension(:) :: psiVertex
-
-
- !
- ! Scale all distances and areas from a unit sphere to one with radius a
- !
- grid % xCell % array = grid % xCell % array * a
- grid % yCell % array = grid % yCell % array * a
- grid % zCell % array = grid % zCell % array * a
- grid % xVertex % array = grid % xVertex % array * a
- grid % yVertex % array = grid % yVertex % array * a
- grid % zVertex % array = grid % zVertex % array * a
- grid % xEdge % array = grid % xEdge % array * a
- grid % yEdge % array = grid % yEdge % array * a
- grid % zEdge % array = grid % zEdge % array * a
- grid % dvEdge % array = grid % dvEdge % array * a
- grid % dcEdge % array = grid % dcEdge % array * a
- grid % areaCell % array = grid % areaCell % array * a**2.0
- grid % areaTriangle % array = grid % areaTriangle % array * a**2.0
- grid % kiteAreasOnVertex % array = grid % kiteAreasOnVertex % array * a**2.0
-
- !
- ! Initialize wind field
- !
- allocate(psiVertex(grid % nVertices))
- do iVtx=1,grid % nVertices
- psiVertex(iVtx) = -a * a * w * sin(grid%latVertex%array(iVtx)) + &
- a *a * K * (cos(grid%latVertex%array(iVtx))**R) * &
- sin(grid%latVertex%array(iVtx)) * cos(R * grid%lonVertex%array(iVtx))
- end do
- do iEdge=1,grid % nEdges
- state % u % array(1,iEdge) = -1.0 * ( &
- psiVertex(grid%verticesOnEdge%array(2,iEdge)) - &
- psiVertex(grid%verticesOnEdge%array(1,iEdge)) &
- ) / grid%dvEdge%array(iEdge)
- end do
- deallocate(psiVertex)
-
- !
- ! Initialize height field (actually, fluid thickness field)
- !
- do iCell=1,grid % nCells
- state % h % array(1,iCell) = (gravity * h0 + a*a*AA(grid%latCell%array(iCell)) + &
- a*a*BB(grid%latCell%array(iCell)) * cos(R*grid%lonCell%array(iCell)) + &
- a*a*CC(grid%latCell%array(iCell)) * cos(2.0*R*grid%lonCell%array(iCell)) &
- ) / gravity
- end do
-
- end subroutine sw_test_case_6
-
-
- real function sphere_distance(lat1, lon1, lat2, lon2, radius)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Compute the great-circle distance between (lat1, lon1) and (lat2, lon2) on a
- ! sphere with given radius.
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- real (kind=RKIND), intent(in) :: lat1, lon1, lat2, lon2, radius
-
- real (kind=RKIND) :: arg1
-
- arg1 = sqrt( sin(0.5*(lat2-lat1))**2 + &
- cos(lat1)*cos(lat2)*sin(0.5*(lon2-lon1))**2 )
- sphere_distance = 2.*radius*asin(arg1)
-
- end function sphere_distance
-
-
- real function AA(theta)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! A, used in height field computation for Rossby-Haurwitz wave
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- real (kind=RKIND), parameter :: w = 7.848e-6
- real (kind=RKIND), parameter :: K = 7.848e-6
- real (kind=RKIND), parameter :: R = 4.0
-
- real (kind=RKIND), intent(in) :: theta
-
- AA = 0.5 * w * (2.0 * omega + w) * cos(theta)**2.0 + &
- 0.25 * K**2.0 * cos(theta)**(2.0*R) * ((R+1.0)*cos(theta)**2.0 + 2.0*R**2.0 - R - 2.0 - 2.0*R**2.0 * cos(theta)**(-2.0))
-
- end function AA
-
-
- real function BB(theta)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! B, used in height field computation for Rossby-Haurwitz wave
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- real (kind=RKIND), parameter :: w = 7.848e-6
- real (kind=RKIND), parameter :: K = 7.848e-6
- real (kind=RKIND), parameter :: R = 4.0
-
- real (kind=RKIND), intent(in) :: theta
-
- BB = (2.0*(omega + w)*K / ((R+1.0)*(R+2.0))) * cos(theta)**R * ((R**2.0 + 2.0*R + 2.0) - ((R+1.0)*cos(theta))**2.0)
-
- end function BB
-
-
- real function CC(theta)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! C, used in height field computation for Rossby-Haurwitz wave
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- real (kind=RKIND), parameter :: w = 7.848e-6
- real (kind=RKIND), parameter :: K = 7.848e-6
- real (kind=RKIND), parameter :: R = 4.0
-
- real (kind=RKIND), intent(in) :: theta
-
- CC = 0.25 * K**2.0 * cos(theta)**(2.0*R) * ((R+1.0)*cos(theta)**2.0 - R - 2.0)
-
- end function CC
-
-end module test_cases
Deleted: trunk/mpas/src/core_sw/module_time_integration.F
===================================================================
--- trunk/mpas/src/core_sw/module_time_integration.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/core_sw/module_time_integration.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -1,1287 +0,0 @@
-module time_integration
-
- use vector_reconstruction
- use grid_types
- use configure
- use constants
- use dmpar
-
-
- contains
-
-
- subroutine timestep(domain, dt, timeStamp)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Advance model state forward in time by the specified time step
- !
- ! Input: domain - current model state in time level 1 (e.g., time_levs(1)state%h(:,:))
- ! plus grid meta-data
- ! Output: domain - upon exit, time level 2 (e.g., time_levs(2)%state%h(:,:)) contains
- ! model state advanced forward in time by dt seconds
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (domain_type), intent(inout) :: domain
- real (kind=RKIND), intent(in) :: dt
- character(len=*), intent(in) :: timeStamp
-
- type (block_type), pointer :: block
-
- if (trim(config_time_integration) == 'RK4') then
- call rk4(domain, dt)
- else
- write(0,*) 'Unknown time integration option '//trim(config_time_integration)
- write(0,*) 'Currently, only ''RK4'' is supported.'
- stop
- end if
-
- block => domain % blocklist
- do while (associated(block))
- block % state % time_levs(2) % state % xtime % scalar = timeStamp
- block => block % next
- end do
-
- end subroutine timestep
-
-
- subroutine rk4(domain, dt)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Advance model state forward in time by the specified time step using
- ! 4th order Runge-Kutta
- !
- ! Input: domain - current model state in time level 1 (e.g., time_levs(1)state%h(:,:))
- ! plus grid meta-data
- ! Output: domain - upon exit, time level 2 (e.g., time_levs(2)%state%h(:,:)) contains
- ! model state advanced forward in time by dt seconds
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (domain_type), intent(inout) :: domain
- real (kind=RKIND), intent(in) :: dt
-
- integer :: iCell, k
- type (block_type), pointer :: block
- type (state_type) :: provis
-
- integer :: rk_step
-
- real (kind=RKIND), dimension(4) :: rk_weights, rk_substep_weights
-
- block => domain % blocklist
- call allocate_state(provis, &
- block % mesh % nCells, block % mesh % nEdges, block % mesh % maxEdges, block % mesh % maxEdges2, &
- block % mesh % nVertices, block % mesh % vertexDegree, block % mesh % nVertLevels, &
- block % mesh % nTracers)
-
- !
- ! Initialize time_levs(2) with state at current time
- ! Initialize first RK state
- ! Couple tracers time_levs(2) with h in time-levels
- ! Initialize RK weights
- !
- block => domain % blocklist
- do while (associated(block))
-
- block % state % time_levs(2) % state % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:)
- block % state % time_levs(2) % state % h % array(:,:) = block % state % time_levs(1) % state % h % array(:,:)
- do iCell=1,block % mesh % nCells ! couple tracers to h
- do k=1,block % mesh % nVertLevels
- block % state % time_levs(2) % state % tracers % array(:,k,iCell) = block % state % time_levs(1) % state % tracers % array(:,k,iCell) &
- * block % state % time_levs(1) % state % h % array(k,iCell)
- end do
- end do
-
- call copy_state(provis, block % state % time_levs(1) % state)
-
- block => block % next
- end do
-
- rk_weights(1) = dt/6.
- rk_weights(2) = dt/3.
- rk_weights(3) = dt/3.
- rk_weights(4) = dt/6.
-
- rk_substep_weights(1) = dt/2.
- rk_substep_weights(2) = dt/2.
- rk_substep_weights(3) = dt
- rk_substep_weights(4) = 0.
-
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! BEGIN RK loop
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- do rk_step = 1, 4
-
-! --- update halos for diagnostic variables
-
- block => domain % blocklist
- do while (associated(block))
- call dmpar_exch_halo_field2dReal(domain % dminfo, provis % pv_edge % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nEdges, &
- block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
-
- if (config_h_mom_eddy_visc4 > 0.0) then
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % state % time_levs(2) % state % divergence % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % state % time_levs(2) % state % vorticity % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nVertices, &
- block % parinfo % verticesToSend, block % parinfo % verticesToRecv)
- end if
-
- block => block % next
- end do
-
-! --- compute tendencies
-
- block => domain % blocklist
- do while (associated(block))
- call compute_tend(block % tend, provis, block % mesh)
- call compute_scalar_tend(block % tend, provis, block % mesh)
- call enforce_boundaryEdge(block % tend, block % mesh)
- block => block % next
- end do
-
-! --- update halos for prognostic variables
-
- block => domain % blocklist
- do while (associated(block))
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % tend % u % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nEdges, &
- block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % tend % h % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call dmpar_exch_halo_field3dReal(domain % dminfo, block % tend % tracers % array(:,:,:), &
- block % mesh % nTracers, block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- block => block % next
- end do
-
-! --- compute next substep state
-
- if (rk_step < 4) then
- block => domain % blocklist
- do while (associated(block))
- provis % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:) &
- + rk_substep_weights(rk_step) * block % tend % u % array(:,:)
- provis % h % array(:,:) = block % state % time_levs(1) % state % h % array(:,:) &
- + rk_substep_weights(rk_step) * block % tend % h % array(:,:)
- do iCell=1,block % mesh % nCells
- do k=1,block % mesh % nVertLevels
- provis % tracers % array(:,k,iCell) = ( &
- block % state % time_levs(1) % state % h % array(k,iCell) * &
- block % state % time_levs(1) % state % tracers % array(:,k,iCell) &
- + rk_substep_weights(rk_step) * block % tend % tracers % array(:,k,iCell) &
- ) / provis % h % array(k,iCell)
- end do
- end do
- if (config_test_case == 1) then ! For case 1, wind field should be fixed
- provis % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:)
- end if
- call compute_solve_diagnostics(dt, provis, block % mesh)
- block => block % next
- end do
- end if
-
-!--- accumulate update (for RK4)
-
- block => domain % blocklist
- do while (associated(block))
- block % state % time_levs(2) % state % u % array(:,:) = block % state % time_levs(2) % state % u % array(:,:) &
- + rk_weights(rk_step) * block % tend % u % array(:,:)
- block % state % time_levs(2) % state % h % array(:,:) = block % state % time_levs(2) % state % h % array(:,:) &
- + rk_weights(rk_step) * block % tend % h % array(:,:)
- do iCell=1,block % mesh % nCells
- do k=1,block % mesh % nVertLevels
- block % state % time_levs(2) % state % tracers % array(:,k,iCell) = &
- block % state % time_levs(2) % state % tracers % array(:,k,iCell) &
- + rk_weights(rk_step) * block % tend % tracers % array(:,k,iCell)
- end do
- end do
- block => block % next
- end do
-
- end do
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! END RK loop
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-
- !
- ! A little clean up at the end: decouple new scalar fields and compute diagnostics for new state
- !
- block => domain % blocklist
- do while (associated(block))
- do iCell=1,block % mesh % nCells
- do k=1,block % mesh % nVertLevels
- block % state % time_levs(2) % state % tracers % array(:,k,iCell) = &
- block % state % time_levs(2) % state % tracers % array(:,k,iCell) &
- / block % state % time_levs(2) % state % h % array(k,iCell)
- end do
- end do
-
- if (config_test_case == 1) then ! For case 1, wind field should be fixed
- block % state % time_levs(2) % state % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:)
- end if
-
- call compute_solve_diagnostics(dt, block % state % time_levs(2) % state, block % mesh)
-
- call reconstruct(block % mesh, block % state % time_levs(2) % state % u % array, &
- block % state % time_levs(2) % state % uReconstructX % array, &
- block % state % time_levs(2) % state % uReconstructY % array, &
- block % state % time_levs(2) % state % uReconstructZ % array, &
- block % state % time_levs(2) % state % uReconstructZonal % array, &
- block % state % time_levs(2) % state % uReconstructMeridional % array &
- )
-
- block => block % next
- end do
-
- call deallocate_state(provis)
-
- end subroutine rk4
-
-
- subroutine compute_tend(tend, s, grid)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Compute height and normal wind tendencies, as well as diagnostic variables
- !
- ! Input: s - current model state
- ! grid - grid metadata
- !
- ! Output: tend - computed tendencies for prognostic variables
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (tend_type), intent(inout) :: tend
- type (state_type), intent(in) :: s
- type (mesh_type), intent(in) :: grid
-
- integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j
- real (kind=RKIND) :: flux, vorticity_abs, workpv, q, upstream_bias
-
- integer :: nCells, nEdges, nVertices, nVertLevels
- real (kind=RKIND), dimension(:), pointer :: h_s, fVertex, fEdge, dvEdge, dcEdge, areaCell, areaTriangle, &
- meshScalingDel2, meshScalingDel4
- real (kind=RKIND), dimension(:,:), pointer :: vh, weightsOnEdge, kiteAreasOnVertex, h_edge, h, u, v, tend_h, tend_u, &
- circulation, vorticity, ke, pv_edge, divergence, h_vertex
- integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnVertex, verticesOnEdge, edgesOnCell, edgesOnEdge, edgesOnVertex
- integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge
- real (kind=RKIND) :: r, u_diffusion
-
- real (kind=RKIND), allocatable, dimension(:,:) :: delsq_divergence
- real (kind=RKIND), allocatable, dimension(:,:) :: delsq_u
- real (kind=RKIND), allocatable, dimension(:,:) :: delsq_circulation, delsq_vorticity
-
- real (kind=RKIND), dimension(:,:), pointer :: u_src
- real (kind=RKIND), parameter :: rho_ref = 1000.0
- real (kind=RKIND) :: ke_edge
-
-
- h => s % h % array
- u => s % u % array
- v => s % v % array
- h_edge => s % h_edge % array
- circulation => s % circulation % array
- vorticity => s % vorticity % array
- divergence => s % divergence % array
- ke => s % ke % array
- pv_edge => s % pv_edge % array
- vh => s % vh % array
-
- weightsOnEdge => grid % weightsOnEdge % array
- kiteAreasOnVertex => grid % kiteAreasOnVertex % array
- cellsOnEdge => grid % cellsOnEdge % array
- cellsOnVertex => grid % cellsOnVertex % array
- verticesOnEdge => grid % verticesOnEdge % array
- nEdgesOnCell => grid % nEdgesOnCell % array
- edgesOnCell => grid % edgesOnCell % array
- nEdgesOnEdge => grid % nEdgesOnEdge % array
- edgesOnEdge => grid % edgesOnEdge % array
- edgesOnVertex => grid % edgesOnVertex % array
- dcEdge => grid % dcEdge % array
- dvEdge => grid % dvEdge % array
- areaCell => grid % areaCell % array
- areaTriangle => grid % areaTriangle % array
- h_s => grid % h_s % array
- fVertex => grid % fVertex % array
- fEdge => grid % fEdge % array
-
- tend_h => tend % h % array
- tend_u => tend % u % array
-
- nCells = grid % nCells
- nEdges = grid % nEdges
- nVertices = grid % nVertices
- nVertLevels = grid % nVertLevels
-
- u_src => grid % u_src % array
-
- meshScalingDel2 => grid % meshScalingDel2 % array
- meshScalingDel4 => grid % meshScalingDel4 % array
-
-
- !
- ! Compute height tendency for each cell
- !
- tend_h(:,:) = 0.0
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- do k=1,nVertLevels
- flux = u(k,iEdge) * dvEdge(iEdge) * h_edge(k,iEdge)
- tend_h(k,cell1) = tend_h(k,cell1) - flux
- tend_h(k,cell2) = tend_h(k,cell2) + flux
- end do
- end do
- do iCell=1,grid % nCellsSolve
- do k=1,nVertLevels
- tend_h(k,iCell) = tend_h(k,iCell) / areaCell(iCell)
- end do
- end do
-
-#ifdef LANL_FORMULATION
- !
- ! Compute u (normal) velocity tendency for each edge (cell face)
- !
- tend_u(:,:) = 0.0
- do iEdge=1,grid % nEdgesSolve
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- vertex1 = verticesOnEdge(1,iEdge)
- vertex2 = verticesOnEdge(2,iEdge)
-
- do k=1,nVertLevels
- q = 0.0
- do j = 1,nEdgesOnEdge(iEdge)
- eoe = edgesOnEdge(j,iEdge)
- workpv = 0.5 * (pv_edge(k,iEdge) + pv_edge(k,eoe))
- q = q + weightsOnEdge(j,iEdge) * u(k,eoe) * workpv * h_edge(k,eoe)
- end do
-
- tend_u(k,iEdge) = &
- q &
- - ( ke(k,cell2) - ke(k,cell1) + &
- gravity * (h(k,cell2) + h_s(cell2) - h(k,cell1) - h_s(cell1)) &
- ) / dcEdge(iEdge)
- end do
- end do
-
-
-#endif
-
-#ifdef NCAR_FORMULATION
- !
- ! Compute u (normal) velocity tendency for each edge (cell face)
- !
- tend_u(:,:) = 0.0
- do iEdge=1,grid % nEdgesSolve
- vertex1 = verticesOnEdge(1,iEdge)
- vertex2 = verticesOnEdge(2,iEdge)
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
-
- do k=1,nVertLevels
- vorticity_abs = fEdge(iEdge) + (circulation(k,vertex1) + circulation(k,vertex2)) / &
- (areaTriangle(vertex1) + areaTriangle(vertex2))
-
- workpv = 2.0 * vorticity_abs / (h(k,cell1) + h(k,cell2))
-
- tend_u(k,iEdge) = workpv * vh(k,iEdge) - &
- (ke(k,cell2) - ke(k,cell1) + &
- gravity * (h(k,cell2) + h_s(cell2) - h(k,cell1) - h_s(cell1)) &
- ) / &
- dcEdge(iEdge)
- end do
- end do
-#endif
-
- ! Compute diffusion, computed as </font>
<font color="black">abla divergence - k \times </font>
<font color="red">abla vorticity
- ! only valid for visc == constant
- if (config_h_mom_eddy_visc2 > 0.0) then
- do iEdge=1,grid % nEdgesSolve
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- vertex1 = verticesOnEdge(1,iEdge)
- vertex2 = verticesOnEdge(2,iEdge)
-
- do k=1,nVertLevels
- u_diffusion = ( divergence(k,cell2) - divergence(k,cell1) ) / dcEdge(iEdge) &
- -(vorticity(k,vertex2) - vorticity(k,vertex1) ) / dvEdge(iEdge)
- u_diffusion = meshScalingDel2(iEdge) * config_h_mom_eddy_visc2 * u_diffusion
- tend_u(k,iEdge) = tend_u(k,iEdge) + u_diffusion
- end do
- end do
- end if
-
- !
- ! velocity tendency: del4 dissipation, -</font>
<font color="black">u_4 </font>
<font color="red">abla^4 u
- ! computed as </font>
<font color="black">abla^2 u = </font>
<font color="black">abla divergence + k \times </font>
<font color="red">abla vorticity
- ! applied recursively.
- ! strictly only valid for h_mom_eddy_visc4 == constant
- !
- if (config_h_mom_eddy_visc4 > 0.0) then
- allocate(delsq_divergence(nVertLevels, nCells+1))
- allocate(delsq_u(nVertLevels, nEdges+1))
- allocate(delsq_circulation(nVertLevels, nVertices+1))
- allocate(delsq_vorticity(nVertLevels, nVertices+1))
-
- delsq_u(:,:) = 0.0
-
- ! Compute </font>
<font color="black">abla^2 u = </font>
<font color="black">abla divergence + k \times </font>
<font color="red">abla vorticity
- do iEdge=1,grid % nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- vertex1 = verticesOnEdge(1,iEdge)
- vertex2 = verticesOnEdge(2,iEdge)
-
- do k=1,nVertLevels
-
- delsq_u(k,iEdge) = ( divergence(k,cell2) - divergence(k,cell1) ) / dcEdge(iEdge) &
- -( vorticity(k,vertex2) - vorticity(k,vertex1)) / dvEdge(iEdge)
-
- end do
- end do
-
- ! vorticity using </font>
<font color="red">abla^2 u
- delsq_circulation(:,:) = 0.0
- do iEdge=1,nEdges
- vertex1 = verticesOnEdge(1,iEdge)
- vertex2 = verticesOnEdge(2,iEdge)
- do k=1,nVertLevels
- delsq_circulation(k,vertex1) = delsq_circulation(k,vertex1) &
- - dcEdge(iEdge) * delsq_u(k,iEdge)
- delsq_circulation(k,vertex2) = delsq_circulation(k,vertex2) &
- + dcEdge(iEdge) * delsq_u(k,iEdge)
- end do
- end do
- do iVertex=1,nVertices
- r = 1.0 / areaTriangle(iVertex)
- do k=1,nVertLevels
- delsq_vorticity(k,iVertex) = delsq_circulation(k,iVertex) * r
- end do
- end do
-
- ! Divergence using </font>
<font color="red">abla^2 u
- delsq_divergence(:,:) = 0.0
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- do k=1,nVertLevels
- delsq_divergence(k,cell1) = delsq_divergence(k,cell1) &
- + delsq_u(k,iEdge)*dvEdge(iEdge)
- delsq_divergence(k,cell2) = delsq_divergence(k,cell2) &
- - delsq_u(k,iEdge)*dvEdge(iEdge)
- end do
- end do
- do iCell = 1,nCells
- r = 1.0 / areaCell(iCell)
- do k = 1,nVertLevels
- delsq_divergence(k,iCell) = delsq_divergence(k,iCell) * r
- end do
- end do
-
- ! Compute - \kappa </font>
<font color="red">abla^4 u
- ! as </font>
<font color="black">abla div(</font>
<font color="black">abla^2 u) + k \times </font>
<font color="black">abla ( k \cross curl(</font>
<font color="red">abla^2 u) )
- do iEdge=1,grid % nEdgesSolve
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- vertex1 = verticesOnEdge(1,iEdge)
- vertex2 = verticesOnEdge(2,iEdge)
-
- do k=1,nVertLevels
-
- u_diffusion = ( delsq_divergence(k,cell2) &
- - delsq_divergence(k,cell1) ) / dcEdge(iEdge) &
- -( delsq_vorticity(k,vertex2) &
- - delsq_vorticity(k,vertex1) ) / dvEdge(iEdge)
-
- u_diffusion = meshScalingDel4(iEdge) * config_h_mom_eddy_visc4 * u_diffusion
- tend_u(k,iEdge) = tend_u(k,iEdge) - u_diffusion
-
- end do
- end do
-
- deallocate(delsq_divergence)
- deallocate(delsq_u)
- deallocate(delsq_circulation)
- deallocate(delsq_vorticity)
-
- end if
-
- ! Compute u (velocity) tendency from wind stress (u_src)
- if(config_wind_stress) then
- do iEdge=1,grid % nEdges
- tend_u(1,iEdge) = tend_u(1,iEdge) &
- + u_src(1,iEdge)/rho_ref/h_edge(1,iEdge)
- end do
- endif
-
- if (config_bottom_drag) then
- do iEdge=1,grid % nEdges
- ! bottom drag is the same as POP:
- ! -c |u| u where c is unitless and 1.0e-3.
- ! see POP Reference guide, section 3.4.4.
- ke_edge = 0.5 * ( ke(1,cellsOnEdge(1,iEdge)) &
- + ke(1,cellsOnEdge(2,iEdge)))
-
- tend_u(1,iEdge) = tend_u(1,iEdge) &
- - 1.0e-3*u(1,iEdge) &
- *sqrt(2.0*ke_edge)/h_edge(1,iEdge)
- end do
- endif
-
- end subroutine compute_tend
-
-
- subroutine compute_scalar_tend(tend, s, grid)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !
- ! Input: s - current model state
- ! grid - grid metadata
- !
- ! Output: tend - computed scalar tendencies
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (tend_type), intent(inout) :: tend
- type (state_type), intent(in) :: s
- type (mesh_type), intent(in) :: grid
-
- integer :: iCell, iEdge, k, iTracer, cell1, cell2, i
- real (kind=RKIND) :: flux, tracer_edge, r
- real (kind=RKIND) :: invAreaCell1, invAreaCell2, tracer_turb_flux
- integer, dimension(:,:), pointer :: boundaryEdge
- real (kind=RKIND), dimension(:,:), allocatable :: boundaryMask
- real (kind=RKIND), dimension(:,:,:), allocatable:: delsq_tracer
-
- real (kind=RKIND) :: d2fdx2_cell1, d2fdx2_cell2
- real (kind=RKIND), dimension(:), pointer :: dvEdge, dcEdge, areaCell
- real (kind=RKIND), dimension(:,:,:), pointer :: tracers, tracer_tend
- integer, dimension(:,:), pointer :: cellsOnEdge, boundaryCell
- real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
- real (kind=RKIND) :: coef_3rd_order
- real (kind=RKIND), dimension(:,:), pointer :: u, h_edge
-
- u => s % u % array
- h_edge => s % h_edge % array
- dcEdge => grid % dcEdge % array
- deriv_two => grid % deriv_two % array
- dvEdge => grid % dvEdge % array
- tracers => s % tracers % array
- cellsOnEdge => grid % cellsOnEdge % array
- boundaryCell=> grid % boundaryCell % array
- boundaryEdge=> grid % boundaryEdge % array
- areaCell => grid % areaCell % array
- tracer_tend => tend % tracers % array
-
- coef_3rd_order = 0.
- if (config_tracer_adv_order == 3) coef_3rd_order = 1.0
- if (config_tracer_adv_order == 3 .and. config_monotonic) coef_3rd_order = 0.25
-
-
- tracer_tend(:,:,:) = 0.0
-
- if (config_tracer_adv_order == 2) then
-
- do iEdge=1,grid % nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- if (cell1 <= grid%nCells .and. cell2 <= grid%nCells) then
- do k=1,grid % nVertLevels
- do iTracer=1,grid % nTracers
- tracer_edge = 0.5 * (tracers(iTracer,k,cell1) + tracers(iTracer,k,cell2))
- flux = u(k,iEdge) * dvEdge(iEdge) * h_edge(k,iEdge) * tracer_edge
- tracer_tend(iTracer,k,cell1) = tracer_tend(iTracer,k,cell1) - flux/areaCell(cell1)
- tracer_tend(iTracer,k,cell2) = tracer_tend(iTracer,k,cell2) + flux/areaCell(cell2)
- end do
- end do
- end if
- end do
-
- else if (config_tracer_adv_order == 3) then
-
- do iEdge=1,grid%nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
-
- !-- if a cell not on the most outside ring of the halo
- if (cell1 <= grid%nCells .and. cell2 <= grid%nCells) then
-
- do k=1,grid % nVertLevels
-
- d2fdx2_cell1 = 0.0
- d2fdx2_cell2 = 0.0
-
- do iTracer=1,grid % nTracers
-
- !-- if not a boundary cell
- if(boundaryCell(k,cell1).eq.0.and.boundaryCell(k,cell2).eq.0) then
-
- d2fdx2_cell1 = deriv_two(1,1,iEdge) * tracers(iTracer,k,cell1)
- d2fdx2_cell2 = deriv_two(1,2,iEdge) * tracers(iTracer,k,cell2)
-
- !-- all edges of cell 1
- do i=1, grid % nEdgesOnCell % array (cell1)
- d2fdx2_cell1 = d2fdx2_cell1 + &
- deriv_two(i+1,1,iEdge) * tracers(iTracer,k,grid % CellsOnCell % array (i,cell1))
- end do
-
- !-- all edges of cell 2
- do i=1, grid % nEdgesOnCell % array (cell2)
- d2fdx2_cell2 = d2fdx2_cell2 + &
- deriv_two(i+1,2,iEdge) * tracers(iTracer,k,grid % CellsOnCell % array (i,cell2))
- end do
-
- endif
-
- !-- if u > 0:
- if (u(k,iEdge) > 0) then
- flux = dvEdge(iEdge) * u(k,iEdge) * h_edge(k,iEdge) * ( &
- 0.5*(tracers(iTracer,k,cell1) + tracers(iTracer,k,cell2)) &
- -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
- -(dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12. )
- !-- else u <= 0:
- else
- flux = dvEdge(iEdge) * u(k,iEdge) * h_edge(k,iEdge) * ( &
- 0.5*(tracers(iTracer,k,cell1) + tracers(iTracer,k,cell2)) &
- -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
- +(dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12. )
- end if
-
- !-- update tendency
- tracer_tend(iTracer,k,cell1) = tracer_tend(iTracer,k,cell1) - flux/areaCell(cell1)
- tracer_tend(iTracer,k,cell2) = tracer_tend(iTracer,k,cell2) + flux/areaCell(cell2)
- enddo
- end do
- end if
- end do
-
- else if (config_tracer_adv_order == 4) then
-
- do iEdge=1,grid%nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
-
- !-- if an edge is not on the outer-most ring of the halo
- if (cell1 <= grid%nCells .and. cell2 <= grid%nCells) then
-
- do k=1,grid % nVertLevels
-
- d2fdx2_cell1 = 0.0
- d2fdx2_cell2 = 0.0
-
- do iTracer=1,grid % nTracers
-
- !-- if not a boundary cell
- if(boundaryCell(k,cell1).eq.0.and.boundaryCell(k,cell2).eq.0) then
-
- d2fdx2_cell1 = deriv_two(1,1,iEdge) * tracers(iTracer,k,cell1)
- d2fdx2_cell2 = deriv_two(1,2,iEdge) * tracers(iTracer,k,cell2)
-
- !-- all edges of cell 1
- do i=1, grid % nEdgesOnCell % array (cell1)
- d2fdx2_cell1 = d2fdx2_cell1 + &
- deriv_two(i+1,1,iEdge) * tracers(iTracer,k,grid % CellsOnCell % array (i,cell1))
- end do
-
- !-- all edges of cell 2
- do i=1, grid % nEdgesOnCell % array (cell2)
- d2fdx2_cell2 = d2fdx2_cell2 + &
- deriv_two(i+1,2,iEdge) * tracers(iTracer,k,grid % CellsOnCell % array (i,cell2))
- end do
-
- endif
-
- flux = dvEdge(iEdge) * u(k,iEdge) * h_edge(k,iEdge) * ( &
- 0.5*(tracers(iTracer,k,cell1) + tracers(iTracer,k,cell2)) &
- -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. )
-
- !-- update tendency
- tracer_tend(iTracer,k,cell1) = tracer_tend(iTracer,k,cell1) - flux/areaCell(cell1)
- tracer_tend(iTracer,k,cell2) = tracer_tend(iTracer,k,cell2) + flux/areaCell(cell2)
- enddo
- end do
- end if
- end do
-
- endif ! if (config_tracer_adv_order == 2 )
-
- !
- ! tracer tendency: del2 horizontal tracer diffusion, div(h \kappa_2 </font>
<font color="red">abla \phi)
- !
- if ( config_h_tracer_eddy_diff2 > 0.0 ) then
-
- !
- ! compute a boundary mask to enforce insulating boundary conditions in the horizontal
- !
- allocate(boundaryMask(grid % nVertLevels, grid % nEdges+1))
- boundaryMask = 1.0
- where(boundaryEdge.eq.1) boundaryMask=0.0
-
- do iEdge=1,grid % nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- invAreaCell1 = 1.0/areaCell(cell1)
- invAreaCell2 = 1.0/areaCell(cell2)
-
- do k=1,grid % nVertLevels
- do iTracer=1, grid % nTracers
- ! \kappa_2 </font>
<font color="red">abla \phi on edge
- tracer_turb_flux = config_h_tracer_eddy_diff2 &
- *( tracers(iTracer,k,cell2) - tracers(iTracer,k,cell1)) / dcEdge(iEdge)
-
- ! div(h \kappa_2 </font>
<font color="red">abla \phi) at cell center
- flux = dvEdge(iEdge) * h_edge(k,iEdge) * tracer_turb_flux * boundaryMask(k, iEdge)
- tracer_tend(iTracer,k,cell1) = tracer_tend(iTracer,k,cell1) + flux * invAreaCell1
- tracer_tend(iTracer,k,cell2) = tracer_tend(iTracer,k,cell2) - flux * invAreaCell2
- end do
- end do
-
- end do
-
- deallocate(boundaryMask)
-
- end if
-
- !
- ! tracer tendency: del4 horizontal tracer diffusion, &
- ! div(h \kappa_4 </font>
<font color="black">abla [div(h </font>
<font color="red">abla \phi)])
- !
- if ( config_h_tracer_eddy_diff4 > 0.0 ) then
-
- !
- ! compute a boundary mask to enforce insulating boundary conditions in the horizontal
- !
- allocate(boundaryMask(grid % nVertLevels, grid % nEdges+1))
- boundaryMask = 1.0
- where(boundaryEdge.eq.1) boundaryMask=0.0
-
- allocate(delsq_tracer(grid % nTracers, grid % nVertLevels, grid % nCells+1))
-
- delsq_tracer(:,:,:) = 0.
-
- ! first del2: div(h </font>
<font color="red">abla \phi) at cell center
- do iEdge=1,grid % nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
-
- do k=1,grid % nVertLevels
- do iTracer=1, grid % nTracers
- delsq_tracer(iTracer,k,cell1) = delsq_tracer(iTracer,k,cell1) &
- + dvEdge(iEdge) * h_edge(k,iEdge) * (tracers(iTracer,k,cell2) - tracers(iTracer,k,cell1)) / dcEdge(iEdge) * boundaryMask(k,iEdge)
- delsq_tracer(iTracer,k,cell2) = delsq_tracer(iTracer,k,cell2) &
- - dvEdge(iEdge) * h_edge(k,iEdge) * (tracers(iTracer,k,cell2) - tracers(iTracer,k,cell1)) / dcEdge(iEdge) * boundaryMask(k,iEdge)
- end do
- end do
-
- end do
-
- do iCell = 1, grid % nCells
- r = 1.0 / grid % areaCell % array(iCell)
- do k=1,grid % nVertLevels
- do iTracer=1,grid % nTracers
- delsq_tracer(iTracer,k,iCell) = delsq_tracer(iTracer,k,iCell) * r
- end do
- end do
- end do
-
- ! second del2: div(h </font>
<font color="gray">abla [delsq_tracer]) at cell center
- do iEdge=1,grid % nEdges
- cell1 = grid % cellsOnEdge % array(1,iEdge)
- cell2 = grid % cellsOnEdge % array(2,iEdge)
- invAreaCell1 = 1.0 / grid % areaCell % array(cell1)
- invAreaCell2 = 1.0 / grid % areaCell % array(cell2)
-
- do k=1,grid % nVertLevels
- do iTracer=1,grid % nTracers
- tracer_turb_flux = config_h_tracer_eddy_diff4 * (delsq_tracer(iTracer,k,cell2) - delsq_tracer(iTracer,k,cell1)) / dcEdge(iEdge)
- flux = dvEdge(iEdge) * tracer_turb_flux
- tracer_tend(iTracer,k,cell1) = tracer_tend(iTracer,k,cell1) - flux * invAreaCell1 * boundaryMask(k,iEdge)
- tracer_tend(iTracer,k,cell2) = tracer_tend(iTracer,k,cell2) + flux * invAreaCell2 * boundaryMask(k,iEdge)
- end do
- enddo
-
- end do
-
- deallocate(delsq_tracer)
- deallocate(boundaryMask)
-
- end if
-
- end subroutine compute_scalar_tend
-
-
- subroutine compute_solve_diagnostics(dt, s, grid)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Compute diagnostic fields used in the tendency computations
- !
- ! Input: grid - grid metadata
- !
- ! Output: s - computed diagnostics
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- real (kind=RKIND), intent(in) :: dt
- type (state_type), intent(inout) :: s
- type (mesh_type), intent(in) :: grid
-
-
- integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j, cov
- real (kind=RKIND) :: flux, vorticity_abs, workpv
-
- integer :: nCells, nEdges, nVertices, nVertLevels
- real (kind=RKIND), dimension(:), pointer :: h_s, fVertex, fEdge, dvEdge, dcEdge, areaCell, areaTriangle
- real (kind=RKIND), dimension(:,:), pointer :: vh, weightsOnEdge, kiteAreasOnVertex, h_edge, h, u, v, tend_h, tend_u, &
- circulation, vorticity, ke, pv_edge, pv_vertex, pv_cell, gradPVn, gradPVt, divergence, &
- h_vertex, vorticity_cell
- integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnVertex, verticesOnEdge, edgesOnCell, edgesOnEdge, edgesOnVertex, boundaryEdge, boundaryCell
- integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge
- real (kind=RKIND) :: r, h1, h2
- real (kind=RKIND) :: d2fdx2_cell1, d2fdx2_cell2
- real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
- real (kind=RKIND) :: coef_3rd_order
-
- h => s % h % array
- u => s % u % array
- v => s % v % array
- vh => s % vh % array
- h_edge => s % h_edge % array
- h_vertex => s % h_vertex % array
- tend_h => s % h % array
- tend_u => s % u % array
- circulation => s % circulation % array
- vorticity => s % vorticity % array
- divergence => s % divergence % array
- ke => s % ke % array
- pv_edge => s % pv_edge % array
- pv_vertex => s % pv_vertex % array
- pv_cell => s % pv_cell % array
- vorticity_cell => s % vorticity_cell % array
- gradPVn => s % gradPVn % array
- gradPVt => s % gradPVt % array
-
- weightsOnEdge => grid % weightsOnEdge % array
- kiteAreasOnVertex => grid % kiteAreasOnVertex % array
- cellsOnEdge => grid % cellsOnEdge % array
- cellsOnVertex => grid % cellsOnVertex % array
- verticesOnEdge => grid % verticesOnEdge % array
- nEdgesOnCell => grid % nEdgesOnCell % array
- edgesOnCell => grid % edgesOnCell % array
- nEdgesOnEdge => grid % nEdgesOnEdge % array
- edgesOnEdge => grid % edgesOnEdge % array
- edgesOnVertex => grid % edgesOnVertex % array
- dcEdge => grid % dcEdge % array
- dvEdge => grid % dvEdge % array
- areaCell => grid % areaCell % array
- areaTriangle => grid % areaTriangle % array
- h_s => grid % h_s % array
- fVertex => grid % fVertex % array
- fEdge => grid % fEdge % array
- deriv_two => grid % deriv_two % array
-
- nCells = grid % nCells
- nEdges = grid % nEdges
- nVertices = grid % nVertices
- nVertLevels = grid % nVertLevels
-
- boundaryEdge => grid % boundaryEdge % array
- boundaryCell => grid % boundaryCell % array
-
- !
- ! Find those cells that have an edge on the boundary
- !
- boundaryCell(:,:) = 0
- do iEdge=1,nEdges
- do k=1,nVertLevels
- if(boundaryEdge(k,iEdge).eq.1) then
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- boundaryCell(k,cell1) = 1
- boundaryCell(k,cell2) = 1
- endif
- enddo
- enddo
-
- !
- ! Compute height on cell edges at velocity locations
- ! Namelist options control the order of accuracy of the reconstructed h_edge value
- !
-
- coef_3rd_order = 0.
- if (config_thickness_adv_order == 3) coef_3rd_order = 1.0
- if (config_thickness_adv_order == 3 .and. config_monotonic) coef_3rd_order = 0.25
-
- if (config_thickness_adv_order == 2) then
-
- do iEdge=1,grid % nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- if (cell1 <= grid%nCells .and. cell2 <= grid%nCells) then
- do k=1,grid % nVertLevels
- h_edge(k,iEdge) = 0.5 * (h(k,cell1) + h(k,cell2))
- end do
- end if
- end do
-
- else if (config_thickness_adv_order == 3) then
-
- do iEdge=1,grid%nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
-
- !-- if a cell not on the most outside ring of the halo
- if (cell1 <= grid%nCells .and. cell2 <= grid%nCells) then
-
- do k=1,grid % nVertLevels
-
- d2fdx2_cell1 = 0.0
- d2fdx2_cell2 = 0.0
-
- !-- if not a boundary cell
- if(boundaryCell(k,cell1).eq.0.and.boundaryCell(k,cell2).eq.0) then
-
- d2fdx2_cell1 = deriv_two(1,1,iEdge) * h(k,cell1)
- d2fdx2_cell2 = deriv_two(1,2,iEdge) * h(k,cell2)
-
- !-- all edges of cell 1
- do i=1, grid % nEdgesOnCell % array (cell1)
- d2fdx2_cell1 = d2fdx2_cell1 + &
- deriv_two(i+1,1,iEdge) * h(k,grid % CellsOnCell % array (i,cell1))
- end do
-
- !-- all edges of cell 2
- do i=1, grid % nEdgesOnCell % array (cell2)
- d2fdx2_cell2 = d2fdx2_cell2 + &
- deriv_two(i+1,2,iEdge) * h(k,grid % CellsOnCell % array (i,cell2))
- end do
-
- endif
-
- !-- if u > 0:
- if (u(k,iEdge) > 0) then
- h_edge(k,iEdge) = &
- 0.5*(h(k,cell1) + h(k,cell2)) &
- -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
- -(dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12.
- !-- else u <= 0:
- else
- h_edge(k,iEdge) = &
- 0.5*(h(k,cell1) + h(k,cell2)) &
- -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
- +(dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12.
- end if
-
- end do ! do k
- end if ! if (cell1 <=
- end do ! do iEdge
-
- else if (config_thickness_adv_order == 4) then
-
- do iEdge=1,grid%nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
-
- !-- if a cell not on the most outside ring of the halo
- if (cell1 <= grid%nCells .and. cell2 <= grid%nCells) then
-
- do k=1,grid % nVertLevels
-
- d2fdx2_cell1 = 0.0
- d2fdx2_cell2 = 0.0
-
- !-- if not a boundary cell
- if(boundaryCell(k,cell1).eq.0.and.boundaryCell(k,cell2).eq.0) then
-
- d2fdx2_cell1 = deriv_two(1,1,iEdge) * h(k,cell1)
- d2fdx2_cell2 = deriv_two(1,2,iEdge) * h(k,cell2)
-
- !-- all edges of cell 1
- do i=1, grid % nEdgesOnCell % array (cell1)
- d2fdx2_cell1 = d2fdx2_cell1 + &
- deriv_two(i+1,1,iEdge) * h(k,grid % CellsOnCell % array (i,cell1))
- end do
-
- !-- all edges of cell 2
- do i=1, grid % nEdgesOnCell % array (cell2)
- d2fdx2_cell2 = d2fdx2_cell2 + &
- deriv_two(i+1,2,iEdge) * h(k,grid % CellsOnCell % array (i,cell2))
- end do
-
- endif
-
- h_edge(k,iEdge) = &
- 0.5*(h(k,cell1) + h(k,cell2)) &
- -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12.
-
- end do ! do k
- end if ! if (cell1 <=
- end do ! do iEdge
-
- endif ! if(config_thickness_adv_order == 2)
-
- !
- ! set the velocity in the nEdges+1 slot to zero, this is a dummy address
- ! used to when reading for edges that do not exist
- !
- u(:,nEdges+1) = 0.0
-
- !
- ! Compute circulation and relative vorticity at each vertex
- !
- circulation(:,:) = 0.0
- do iEdge=1,nEdges
- do k=1,nVertLevels
- circulation(k,verticesOnEdge(1,iEdge)) = circulation(k,verticesOnEdge(1,iEdge)) - dcEdge(iEdge) * u(k,iEdge)
- circulation(k,verticesOnEdge(2,iEdge)) = circulation(k,verticesOnEdge(2,iEdge)) + dcEdge(iEdge) * u(k,iEdge)
- end do
- end do
- do iVertex=1,nVertices
- do k=1,nVertLevels
- vorticity(k,iVertex) = circulation(k,iVertex) / areaTriangle(iVertex)
- end do
- end do
-
-
- !
- ! Compute the divergence at each cell center
- !
- divergence(:,:) = 0.0
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- if (cell1 <= nCells) then
- do k=1,nVertLevels
- divergence(k,cell1) = divergence(k,cell1) + u(k,iEdge)*dvEdge(iEdge)
- enddo
- endif
- if(cell2 <= nCells) then
- do k=1,nVertLevels
- divergence(k,cell2) = divergence(k,cell2) - u(k,iEdge)*dvEdge(iEdge)
- enddo
- end if
- end do
- do iCell = 1,nCells
- r = 1.0 / areaCell(iCell)
- do k = 1,nVertLevels
- divergence(k,iCell) = divergence(k,iCell) * r
- enddo
- enddo
-
- !
- ! Compute kinetic energy in each cell
- !
- ke(:,:) = 0.0
- do iCell=1,nCells
- do i=1,nEdgesOnCell(iCell)
- iEdge = edgesOnCell(i,iCell)
- do k=1,nVertLevels
- ke(k,iCell) = ke(k,iCell) + 0.25 * dcEdge(iEdge) * dvEdge(iEdge) * u(k,iEdge)**2.0
- end do
- end do
- do k=1,nVertLevels
- ke(k,iCell) = ke(k,iCell) / areaCell(iCell)
- end do
- end do
-
- !
- ! Compute v (tangential) velocities
- !
- v(:,:) = 0.0
- do iEdge = 1,nEdges
- do i=1,nEdgesOnEdge(iEdge)
- eoe = edgesOnEdge(i,iEdge)
- do k = 1,nVertLevels
- v(k,iEdge) = v(k,iEdge) + weightsOnEdge(i,iEdge) * u(k, eoe)
- end do
- end do
- end do
-
-#ifdef NCAR_FORMULATION
- !
- ! Compute mass fluxes tangential to each edge (i.e., through the faces of dual grid cells)
- !
- vh(:,:) = 0.0
- do iEdge=1,grid % nEdgesSolve
- do j=1,nEdgesOnEdge(iEdge)
- eoe = edgesOnEdge(j,iEdge)
- do k=1,nVertLevels
- vh(k,iEdge) = vh(k,iEdge) + weightsOnEdge(j,iEdge) * u(k,eoe) * h_edge(k,eoe)
- end do
- end do
- end do
-#endif
-
-
- !
- ! Compute height at vertices, pv at vertices, and average pv to edge locations
- ! ( this computes pv_vertex at all vertices bounding real cells and distance-1 ghost cells )
- !
- do iVertex = 1,nVertices
- do k=1,nVertLevels
- h_vertex(k,iVertex) = 0.0
- do i=1,grid % vertexDegree
- h_vertex(k,iVertex) = h_vertex(k,iVertex) + h(k,cellsOnVertex(i,iVertex)) * kiteAreasOnVertex(i,iVertex)
- end do
- h_vertex(k,iVertex) = h_vertex(k,iVertex) / areaTriangle(iVertex)
-
- pv_vertex(k,iVertex) = (fVertex(iVertex) + vorticity(k,iVertex)) / h_vertex(k,iVertex)
- end do
- end do
-
-
- !
- ! Compute gradient of PV in the tangent direction
- ! ( this computes gradPVt at all edges bounding real cells and distance-1 ghost cells )
- !
- do iEdge = 1,nEdges
- do k = 1,nVertLevels
- gradPVt(k,iEdge) = (pv_vertex(k,verticesOnEdge(2,iEdge)) - pv_vertex(k,verticesOnEdge(1,iEdge))) / &
- dvEdge(iEdge)
- enddo
- enddo
-
- !
- ! Compute pv at the edges
- ! ( this computes pv_edge at all edges bounding real cells )
- !
- pv_edge(:,:) = 0.0
- do iVertex = 1,nVertices
- do i=1,grid % vertexDegree
- iEdge = edgesOnVertex(i,iVertex)
- do k=1,nVertLevels
- pv_edge(k,iEdge) = pv_edge(k,iEdge) + 0.5 * pv_vertex(k,iVertex)
- end do
- end do
- end do
-
-
- !
- ! Modify PV edge with upstream bias.
- !
- do iEdge = 1,nEdges
- do k = 1,nVertLevels
- pv_edge(k,iEdge) = pv_edge(k,iEdge) - config_apvm_upwinding * v(k,iEdge) * dt * gradPVt(k,iEdge)
- enddo
- enddo
-
-
- !
- ! Compute pv at cell centers
- ! ( this computes pv_cell for all real cells and distance-1 ghost cells )
- !
- pv_cell(:,:) = 0.0
- vorticity_cell(:,:) = 0.0
- do iVertex = 1, nVertices
- do i=1,grid % vertexDegree
- iCell = cellsOnVertex(i,iVertex)
- if (iCell <= nCells) then
- do k = 1,nVertLevels
- pv_cell(k,iCell) = pv_cell(k,iCell) + kiteAreasOnVertex(i, iVertex) * pv_vertex(k, iVertex) / areaCell(iCell)
- vorticity_cell(k,iCell) = vorticity_cell(k,iCell) + kiteAreasOnVertex(i, iVertex) * vorticity(k, iVertex) / areaCell(iCell)
- enddo
- endif
- enddo
- enddo
-
-
- !
- ! Compute gradient of PV in normal direction
- ! ( this computes gradPVn for all edges bounding real cells )
- !
- gradPVn(:,:) = 0.0
- do iEdge = 1,nEdges
- if( cellsOnEdge(1,iEdge) <= nCells .and. cellsOnEdge(2,iEdge) <= nCells) then
- do k = 1,nVertLevels
- gradPVn(k,iEdge) = (pv_cell(k,cellsOnEdge(2,iEdge)) - pv_cell(k,cellsOnEdge(1,iEdge))) / &
- dcEdge(iEdge)
- enddo
- endif
- enddo
-
- ! Modify PV edge with upstream bias.
- !
- do iEdge = 1,nEdges
- do k = 1,nVertLevels
- pv_edge(k,iEdge) = pv_edge(k,iEdge) - config_apvm_upwinding * u(k,iEdge) * dt * gradPVn(k,iEdge)
- enddo
- enddo
-
- !
- ! set pv_edge = fEdge / h_edge at boundary points
- !
- ! if (maxval(boundaryEdge).ge.0) then
- ! do iEdge = 1,nEdges
- ! cell1 = cellsOnEdge(1,iEdge)
- ! cell2 = cellsOnEdge(2,iEdge)
- ! do k = 1,nVertLevels
- ! if(boundaryEdge(k,iEdge).eq.1) then
- ! v(k,iEdge) = 0.0
- ! if(cell1.gt.0) then
- ! h1 = h(k,cell1)
- ! pv_edge(k,iEdge) = fEdge(iEdge) / h1
- ! h_edge(k,iEdge) = h1
- ! else
- ! h2 = h(k,cell2)
- ! pv_edge(k,iEdge) = fEdge(iEdge) / h2
- ! h_edge(k,iEdge) = h2
- ! endif
- ! endif
- ! enddo
- ! enddo
- ! endif
-
-
- end subroutine compute_solve_diagnostics
-
-
- subroutine enforce_boundaryEdge(tend, grid)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Enforce any boundary conditions on the normal velocity at each edge
- !
- ! Input: grid - grid metadata
- !
- ! Output: tend_u set to zero at boundaryEdge == 1 locations
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-
- implicit none
-
- type (tend_type), intent(inout) :: tend
- type (mesh_type), intent(in) :: grid
-
- integer, dimension(:,:), pointer :: boundaryEdge
- real (kind=RKIND), dimension(:,:), pointer :: tend_u
- integer :: nCells, nEdges, nVertices, nVertLevels
- integer :: iEdge, k
-
- nCells = grid % nCells
- nEdges = grid % nEdges
- nVertices = grid % nVertices
- nVertLevels = grid % nVertLevels
-
- boundaryEdge => grid % boundaryEdge % array
- tend_u => tend % u % array
-
- if(maxval(boundaryEdge).le.0) return
-
- do iEdge = 1,nEdges
- do k = 1,nVertLevels
-
- if(boundaryEdge(k,iEdge).eq.1) then
- tend_u(k,iEdge) = 0.0
- endif
-
- enddo
- enddo
-
- end subroutine enforce_boundaryEdge
-
-
-end module time_integration
Copied: trunk/mpas/src/core_sw/mpas_sw_advection.F (from rev 1113, branches/source_renaming/src/core_sw/mpas_sw_advection.F)
===================================================================
--- trunk/mpas/src/core_sw/mpas_sw_advection.F (rev 0)
+++ trunk/mpas/src/core_sw/mpas_sw_advection.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -0,0 +1,933 @@
+module sw_advection
+
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_constants
+
+
+ contains
+
+
+ subroutine sw_initialize_advection_rk( grid )
+
+!
+! compute the cell coefficients for the polynomial fit.
+! this is performed during setup for model integration.
+! WCS, 31 August 2009
+!
+ implicit none
+
+ type (mesh_type), intent(in) :: grid
+
+ real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
+ integer, dimension(:,:), pointer :: advCells
+
+! local variables
+
+ real (kind=RKIND), dimension(2, grid % nEdges) :: thetae
+ real (kind=RKIND), dimension(grid % nEdges) :: xe, ye
+ real (kind=RKIND), dimension(grid % nCells) :: theta_abs
+
+ real (kind=RKIND), dimension(25) :: xc, yc, zc ! cell center coordinates
+ real (kind=RKIND), dimension(25) :: thetav, thetat, dl_sphere
+ real (kind=RKIND) :: xm, ym, zm, dl, xec, yec, zec
+ real (kind=RKIND) :: thetae_tmp, xe_tmp, ye_tmp
+ real (kind=RKIND) :: xv1, xv2, yv1, yv2, zv1, zv2
+ integer :: i, j, k, ip1, ip2, m, n, ip1a, ii
+ integer :: iCell, iEdge
+ real (kind=RKIND) :: pii
+ real (kind=RKIND) :: x0, y0, x1, y1, x2, y2, x3, y3, x4, y4, x5, y5
+ real (kind=RKIND) :: pdx1, pdx2, pdx3, pdy1, pdy2, pdy3, dx1, dx2, dy1, dy2
+ real (kind=RKIND) :: angv1, angv2, dl1, dl2
+ real (kind=RKIND), dimension(25) :: dxe, dye, x2v, y2v, xp, yp
+
+ real (kind=RKIND) :: amatrix(25,25), bmatrix(25,25), wmatrix(25,25)
+ real (kind=RKIND) :: length_scale
+ integer :: ma,na, cell_add, mw, nn
+ integer, dimension(25) :: cell_list
+
+
+ integer :: cell1, cell2
+ integer, parameter :: polynomial_order = 2
+! logical, parameter :: debug = .true.
+ logical, parameter :: debug = .false.
+! logical, parameter :: least_squares = .false.
+ logical, parameter :: least_squares = .true.
+ logical :: add_the_cell, do_the_cell
+
+ logical, parameter :: reset_poly = .true.
+
+ real (kind=RKIND) :: rcell, cos2t, costsint, sin2t
+ real (kind=RKIND), dimension(grid%maxEdges) :: angle_2d
+
+!---
+
+ pii = 2.*asin(1.0)
+
+ advCells => grid % advCells % array
+ deriv_two => grid % deriv_two % array
+ deriv_two(:,:,:) = 0.
+
+ do iCell = 1, grid % nCells ! is this correct? - we need first halo cell also...
+
+ cell_list(1) = iCell
+ do i=2, grid % nEdgesOnCell % array(iCell)+1
+ cell_list(i) = grid % CellsOnCell % array(i-1,iCell)
+ end do
+ n = grid % nEdgesOnCell % array(iCell) + 1
+
+ if ( polynomial_order > 2 ) then
+ do i=2,grid % nEdgesOnCell % array(iCell) + 1
+ do j=1,grid % nEdgesOnCell % array ( cell_list(i) )
+ cell_add = grid % CellsOnCell % array (j,cell_list(i))
+ add_the_cell = .true.
+ do k=1,n
+ if ( cell_add == cell_list(k) ) add_the_cell = .false.
+ end do
+ if (add_the_cell) then
+ n = n+1
+ cell_list(n) = cell_add
+ end if
+ end do
+ end do
+ end if
+
+ advCells(1,iCell) = n
+
+! check to see if we are reaching outside the halo
+
+ do_the_cell = .true.
+ do i=1,n
+ if (cell_list(i) > grid % nCells) do_the_cell = .false.
+ end do
+
+
+ if ( .not. do_the_cell ) cycle
+
+
+! compute poynomial fit for this cell if all needed neighbors exist
+ if ( grid % on_a_sphere ) then
+
+ do i=1,n
+ advCells(i+1,iCell) = cell_list(i)
+ xc(i) = grid % xCell % array(advCells(i+1,iCell))/a
+ yc(i) = grid % yCell % array(advCells(i+1,iCell))/a
+ zc(i) = grid % zCell % array(advCells(i+1,iCell))/a
+ end do
+
+ theta_abs(iCell) = pii/2. - sphere_angle( xc(1), yc(1), zc(1), &
+ xc(2), yc(2), zc(2), &
+ 0., 0., 1. )
+
+! angles from cell center to neighbor centers (thetav)
+
+ do i=1,n-1
+
+ ip2 = i+2
+ if (ip2 > n) ip2 = 2
+
+ thetav(i) = sphere_angle( xc(1), yc(1), zc(1), &
+ xc(i+1), yc(i+1), zc(i+1), &
+ xc(ip2), yc(ip2), zc(ip2) )
+
+ dl_sphere(i) = a*arc_length( xc(1), yc(1), zc(1), &
+ xc(i+1), yc(i+1), zc(i+1) )
+ end do
+
+ length_scale = 1.
+ do i=1,n-1
+ dl_sphere(i) = dl_sphere(i)/length_scale
+ end do
+
+! thetat(1) = 0. ! this defines the x direction, cell center 1 ->
+ thetat(1) = theta_abs(iCell) ! this defines the x direction, longitude line
+ do i=2,n-1
+ thetat(i) = thetat(i-1) + thetav(i-1)
+ end do
+
+ do i=1,n-1
+ xp(i) = cos(thetat(i)) * dl_sphere(i)
+ yp(i) = sin(thetat(i)) * dl_sphere(i)
+ end do
+
+ else ! On an x-y plane
+
+ do i=1,n-1
+
+ angle_2d(i) = grid%angleEdge%array(grid % EdgesOnCell % array(i,iCell))
+ iEdge = grid % EdgesOnCell % array(i,iCell)
+ if ( iCell .ne. grid % CellsOnEdge % array(1,iEdge)) &
+ angle_2d(i) = angle_2d(i) - pii
+
+! xp(i) = grid % xCell % array(cell_list(i)) - grid % xCell % array(iCell)
+! yp(i) = grid % yCell % array(cell_list(i)) - grid % yCell % array(iCell)
+
+ xp(i) = grid % dcEdge % array(grid % EdgesOnCell % array(i,iCell)) * cos(angle_2d(i))
+ yp(i) = grid % dcEdge % array(grid % EdgesOnCell % array(i,iCell)) * sin(angle_2d(i))
+
+ end do
+
+ end if
+
+
+ ma = n-1
+ mw = grid % nEdgesOnCell % array (iCell)
+
+ bmatrix = 0.
+ amatrix = 0.
+ wmatrix = 0.
+
+ if (polynomial_order == 2) then
+ na = 6
+ ma = ma+1
+
+ amatrix(1,1) = 1.
+ wmatrix(1,1) = 1.
+ do i=2,ma
+ amatrix(i,1) = 1.
+ amatrix(i,2) = xp(i-1)
+ amatrix(i,3) = yp(i-1)
+ amatrix(i,4) = xp(i-1)**2
+ amatrix(i,5) = xp(i-1) * yp(i-1)
+ amatrix(i,6) = yp(i-1)**2
+
+ wmatrix(i,i) = 1.
+ end do
+
+ else if (polynomial_order == 3) then
+ na = 10
+ ma = ma+1
+
+ amatrix(1,1) = 1.
+ wmatrix(1,1) = 1.
+ do i=2,ma
+ amatrix(i,1) = 1.
+ amatrix(i,2) = xp(i-1)
+ amatrix(i,3) = yp(i-1)
+
+ amatrix(i,4) = xp(i-1)**2
+ amatrix(i,5) = xp(i-1) * yp(i-1)
+ amatrix(i,6) = yp(i-1)**2
+
+ amatrix(i,7) = xp(i-1)**3
+ amatrix(i,8) = yp(i-1) * (xp(i-1)**2)
+ amatrix(i,9) = xp(i-1) * (yp(i-1)**2)
+ amatrix(i,10) = yp(i-1)**3
+
+ wmatrix(i,i) = 1.
+
+ end do
+
+ else
+ na = 15
+ ma = ma+1
+
+ amatrix(1,1) = 1.
+ wmatrix(1,1) = 1.
+ do i=2,ma
+ amatrix(i,1) = 1.
+ amatrix(i,2) = xp(i-1)
+ amatrix(i,3) = yp(i-1)
+
+ amatrix(i,4) = xp(i-1)**2
+ amatrix(i,5) = xp(i-1) * yp(i-1)
+ amatrix(i,6) = yp(i-1)**2
+
+ amatrix(i,7) = xp(i-1)**3
+ amatrix(i,8) = yp(i-1) * (xp(i-1)**2)
+ amatrix(i,9) = xp(i-1) * (yp(i-1)**2)
+ amatrix(i,10) = yp(i-1)**3
+
+ amatrix(i,11) = xp(i-1)**4
+ amatrix(i,12) = yp(i-1) * (xp(i-1)**3)
+ amatrix(i,13) = (xp(i-1)**2)*(yp(i-1)**2)
+ amatrix(i,14) = xp(i-1) * (yp(i-1)**3)
+ amatrix(i,15) = yp(i-1)**4
+
+ wmatrix(i,i) = 1.
+
+ end do
+
+ do i=1,mw
+ wmatrix(i,i) = 1.
+ end do
+
+ end if
+
+ call sw_poly_fit_2( amatrix, bmatrix, wmatrix, ma, na, 25 )
+
+ do i=1,grid % nEdgesOnCell % array (iCell)
+ ip1 = i+1
+ if (ip1 > n-1) ip1 = 1
+
+ iEdge = grid % EdgesOnCell % array (i,iCell)
+ xv1 = grid % xVertex % array(grid % verticesOnEdge % array (1,iedge))/a
+ yv1 = grid % yVertex % array(grid % verticesOnEdge % array (1,iedge))/a
+ zv1 = grid % zVertex % array(grid % verticesOnEdge % array (1,iedge))/a
+ xv2 = grid % xVertex % array(grid % verticesOnEdge % array (2,iedge))/a
+ yv2 = grid % yVertex % array(grid % verticesOnEdge % array (2,iedge))/a
+ zv2 = grid % zVertex % array(grid % verticesOnEdge % array (2,iedge))/a
+
+ if ( grid % on_a_sphere ) then
+ call sw_arc_bisect( xv1, yv1, zv1, &
+ xv2, yv2, zv2, &
+ xec, yec, zec )
+
+ thetae_tmp = sphere_angle( xc(1), yc(1), zc(1), &
+ xc(i+1), yc(i+1), zc(i+1), &
+ xec, yec, zec )
+ thetae_tmp = thetae_tmp + thetat(i)
+ if (iCell == grid % cellsOnEdge % array(1,iEdge)) then
+ thetae(1,grid % EdgesOnCell % array (i,iCell)) = thetae_tmp
+ else
+ thetae(2,grid % EdgesOnCell % array (i,iCell)) = thetae_tmp
+ end if
+! else
+!
+! xe(grid % EdgesOnCell % array (i,iCell)) = 0.5 * (xv1 + xv2)
+! ye(grid % EdgesOnCell % array (i,iCell)) = 0.5 * (yv1 + yv2)
+
+ end if
+
+ end do
+
+! fill second derivative stencil for rk advection
+
+ do i=1, grid % nEdgesOnCell % array (iCell)
+ iEdge = grid % EdgesOnCell % array (i,iCell)
+
+
+ if ( grid % on_a_sphere ) then
+ if (iCell == grid % cellsOnEdge % array(1,iEdge)) then
+
+ cos2t = cos(thetae(1,grid % EdgesOnCell % array (i,iCell)))
+ sin2t = sin(thetae(1,grid % EdgesOnCell % array (i,iCell)))
+ costsint = cos2t*sin2t
+ cos2t = cos2t**2
+ sin2t = sin2t**2
+
+ do j=1,n
+ deriv_two(j,1,iEdge) = 2.*cos2t*bmatrix(4,j) &
+ + 2.*costsint*bmatrix(5,j) &
+ + 2.*sin2t*bmatrix(6,j)
+ end do
+ else
+
+ cos2t = cos(thetae(2,grid % EdgesOnCell % array (i,iCell)))
+ sin2t = sin(thetae(2,grid % EdgesOnCell % array (i,iCell)))
+ costsint = cos2t*sin2t
+ cos2t = cos2t**2
+ sin2t = sin2t**2
+
+ do j=1,n
+ deriv_two(j,2,iEdge) = 2.*cos2t*bmatrix(4,j) &
+ + 2.*costsint*bmatrix(5,j) &
+ + 2.*sin2t*bmatrix(6,j)
+ end do
+ end if
+
+ else
+
+ cos2t = cos(angle_2d(i))
+ sin2t = sin(angle_2d(i))
+ costsint = cos2t*sin2t
+ cos2t = cos2t**2
+ sin2t = sin2t**2
+
+! do j=1,n
+!
+! deriv_two(j,1,iEdge) = 2.*xe(iEdge)*xe(iEdge)*bmatrix(4,j) &
+! + 2.*xe(iEdge)*ye(iEdge)*bmatrix(5,j) &
+! + 2.*ye(iEdge)*ye(iEdge)*bmatrix(6,j)
+! end do
+
+ if (iCell == grid % cellsOnEdge % array(1,iEdge)) then
+ do j=1,n
+ deriv_two(j,1,iEdge) = 2.*cos2t*bmatrix(4,j) &
+ + 2.*costsint*bmatrix(5,j) &
+ + 2.*sin2t*bmatrix(6,j)
+ end do
+ else
+ do j=1,n
+ deriv_two(j,2,iEdge) = 2.*cos2t*bmatrix(4,j) &
+ + 2.*costsint*bmatrix(5,j) &
+ + 2.*sin2t*bmatrix(6,j)
+ end do
+ end if
+
+ end if
+ end do
+
+ end do ! end of loop over cells
+
+ if (debug) stop
+
+
+! write(0,*) ' check for deriv2 coefficients, iEdge 4 '
+!
+! iEdge = 4
+! j = 1
+! iCell = grid % cellsOnEdge % array(1,iEdge)
+! write(0,*) ' j, icell, coef ',j,iCell,deriv_two(j,1,iEdge)
+! do j=2,7
+! write(0,*) ' j, icell, coef ',j,grid % CellsOnCell % array(j-1,iCell),deriv_two(j,1,iEdge)
+! end do
+!
+! j = 1
+! iCell = grid % cellsOnEdge % array(2,iEdge)
+! write(0,*) ' j, icell, coef ',j,iCell,deriv_two(j,2,iEdge)
+! do j=2,7
+! write(0,*) ' j, icell, coef ',j,grid % CellsOnCell % array(j-1,iCell),deriv_two(j,2,iEdge)
+! end do
+! stop
+
+ end subroutine sw_initialize_advection_rk
+
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! FUNCTION SPHERE_ANGLE
+ !
+ ! Computes the angle between arcs AB and AC, given points A, B, and C
+ ! Equation numbers w.r.t. http://mathworld.wolfram.com/SphericalTrigonometry.html
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ real function sphere_angle(ax, ay, az, bx, by, bz, cx, cy, cz)
+
+ implicit none
+
+ real (kind=RKIND), intent(in) :: ax, ay, az, bx, by, bz, cx, cy, cz
+
+ real (kind=RKIND) :: a, b, c ! Side lengths of spherical triangle ABC
+
+ real (kind=RKIND) :: ABx, ABy, ABz ! The components of the vector AB
+ real (kind=RKIND) :: mAB ! The magnitude of AB
+ real (kind=RKIND) :: ACx, ACy, ACz ! The components of the vector AC
+ real (kind=RKIND) :: mAC ! The magnitude of AC
+
+ real (kind=RKIND) :: Dx ! The i-components of the cross product AB x AC
+ real (kind=RKIND) :: Dy ! The j-components of the cross product AB x AC
+ real (kind=RKIND) :: Dz ! The k-components of the cross product AB x AC
+
+ real (kind=RKIND) :: s ! Semiperimeter of the triangle
+ real (kind=RKIND) :: sin_angle
+
+ a = acos(max(min(bx*cx + by*cy + bz*cz,1.0),-1.0)) ! Eqn. (3)
+ b = acos(max(min(ax*cx + ay*cy + az*cz,1.0),-1.0)) ! Eqn. (2)
+ c = acos(max(min(ax*bx + ay*by + az*bz,1.0),-1.0)) ! Eqn. (1)
+
+ ABx = bx - ax
+ ABy = by - ay
+ ABz = bz - az
+
+ ACx = cx - ax
+ ACy = cy - ay
+ ACz = cz - az
+
+ Dx = (ABy * ACz) - (ABz * ACy)
+ Dy = -((ABx * ACz) - (ABz * ACx))
+ Dz = (ABx * ACy) - (ABy * ACx)
+
+ s = 0.5*(a + b + c)
+! sin_angle = sqrt((sin(s-b)*sin(s-c))/(sin(b)*sin(c))) ! Eqn. (28)
+ sin_angle = sqrt(min(1.,max(0.,(sin(s-b)*sin(s-c))/(sin(b)*sin(c))))) ! Eqn. (28)
+
+ if ((Dx*ax + Dy*ay + Dz*az) >= 0.0) then
+ sphere_angle = 2.0 * asin(max(min(sin_angle,1.0),-1.0))
+ else
+ sphere_angle = -2.0 * asin(max(min(sin_angle,1.0),-1.0))
+ end if
+
+ end function sphere_angle
+
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! FUNCTION PLANE_ANGLE
+ !
+ ! Computes the angle between vectors AB and AC, given points A, B, and C, and
+ ! a vector (u,v,w) normal to the plane.
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ real function plane_angle(ax, ay, az, bx, by, bz, cx, cy, cz, u, v, w)
+
+ implicit none
+
+ real (kind=RKIND), intent(in) :: ax, ay, az, bx, by, bz, cx, cy, cz, u, v, w
+
+ real (kind=RKIND) :: ABx, ABy, ABz ! The components of the vector AB
+ real (kind=RKIND) :: mAB ! The magnitude of AB
+ real (kind=RKIND) :: ACx, ACy, ACz ! The components of the vector AC
+ real (kind=RKIND) :: mAC ! The magnitude of AC
+
+ real (kind=RKIND) :: Dx ! The i-components of the cross product AB x AC
+ real (kind=RKIND) :: Dy ! The j-components of the cross product AB x AC
+ real (kind=RKIND) :: Dz ! The k-components of the cross product AB x AC
+
+ real (kind=RKIND) :: cos_angle
+
+ ABx = bx - ax
+ ABy = by - ay
+ ABz = bz - az
+ mAB = sqrt(ABx**2.0 + ABy**2.0 + ABz**2.0)
+
+ ACx = cx - ax
+ ACy = cy - ay
+ ACz = cz - az
+ mAC = sqrt(ACx**2.0 + ACy**2.0 + ACz**2.0)
+
+
+ Dx = (ABy * ACz) - (ABz * ACy)
+ Dy = -((ABx * ACz) - (ABz * ACx))
+ Dz = (ABx * ACy) - (ABy * ACx)
+
+ cos_angle = (ABx*ACx + ABy*ACy + ABz*ACz) / (mAB * mAC)
+
+ if ((Dx*u + Dy*v + Dz*w) >= 0.0) then
+ plane_angle = acos(max(min(cos_angle,1.0),-1.0))
+ else
+ plane_angle = -acos(max(min(cos_angle,1.0),-1.0))
+ end if
+
+ end function plane_angle
+
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! FUNCTION ARC_LENGTH
+ !
+ ! Returns the length of the great circle arc from A=(ax, ay, az) to
+ ! B=(bx, by, bz). It is assumed that both A and B lie on the surface of the
+ ! same sphere centered at the origin.
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ real function arc_length(ax, ay, az, bx, by, bz)
+
+ implicit none
+
+ real (kind=RKIND), intent(in) :: ax, ay, az, bx, by, bz
+
+ real (kind=RKIND) :: r, c
+ real (kind=RKIND) :: cx, cy, cz
+
+ cx = bx - ax
+ cy = by - ay
+ cz = bz - az
+
+! r = ax*ax + ay*ay + az*az
+! c = cx*cx + cy*cy + cz*cz
+!
+! arc_length = sqrt(r) * acos(1.0 - c/(2.0*r))
+
+ r = sqrt(ax*ax + ay*ay + az*az)
+ c = sqrt(cx*cx + cy*cy + cz*cz)
+! arc_length = sqrt(r) * 2.0 * asin(c/(2.0*r))
+ arc_length = r * 2.0 * asin(c/(2.0*r))
+
+ end function arc_length
+
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! subroutine sw_arc_bisect
+ !
+ ! Returns the point C=(cx, cy, cz) that bisects the great circle arc from
+ ! A=(ax, ay, az) to B=(bx, by, bz). It is assumed that A and B lie on the
+ ! surface of a sphere centered at the origin.
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine sw_arc_bisect(ax, ay, az, bx, by, bz, cx, cy, cz)
+
+ implicit none
+
+ real (kind=RKIND), intent(in) :: ax, ay, az, bx, by, bz
+ real (kind=RKIND), intent(out) :: cx, cy, cz
+
+ real (kind=RKIND) :: r ! Radius of the sphere
+ real (kind=RKIND) :: d
+
+ r = sqrt(ax*ax + ay*ay + az*az)
+
+ cx = 0.5*(ax + bx)
+ cy = 0.5*(ay + by)
+ cz = 0.5*(az + bz)
+
+ if (cx == 0. .and. cy == 0. .and. cz == 0.) then
+ write(0,*) 'Error: arc_bisect: A and B are diametrically opposite'
+ else
+ d = sqrt(cx*cx + cy*cy + cz*cz)
+ cx = r * cx / d
+ cy = r * cy / d
+ cz = r * cz / d
+ end if
+
+ end subroutine sw_arc_bisect
+
+
+ subroutine sw_poly_fit_2(a_in,b_out,weights_in,m,n,ne)
+
+ implicit none
+
+ integer, intent(in) :: m,n,ne
+ real (kind=RKIND), dimension(ne,ne), intent(in) :: a_in, weights_in
+ real (kind=RKIND), dimension(ne,ne), intent(out) :: b_out
+
+ ! local storage
+
+ real (kind=RKIND), dimension(m,n) :: a
+ real (kind=RKIND), dimension(n,m) :: b
+ real (kind=RKIND), dimension(m,m) :: w,wt,h
+ real (kind=RKIND), dimension(n,m) :: at, ath
+ real (kind=RKIND), dimension(n,n) :: ata, ata_inv, atha, atha_inv
+ integer, dimension(n) :: indx
+ integer :: i,j
+
+ if ( (ne<n) .or. (ne<m) ) then
+ write(6,*) ' error in poly_fit_2 inversion ',m,n,ne
+ stop
+ end if
+
+! a(1:m,1:n) = a_in(1:n,1:m)
+ a(1:m,1:n) = a_in(1:m,1:n)
+ w(1:m,1:m) = weights_in(1:m,1:m)
+ b_out(:,:) = 0.
+
+ wt = transpose(w)
+ h = matmul(wt,w)
+ at = transpose(a)
+ ath = matmul(at,h)
+ atha = matmul(ath,a)
+
+ ata = matmul(at,a)
+
+! if (m == n) then
+! call sw_migs(a,n,b,indx)
+! else
+
+ call sw_migs(atha,n,atha_inv,indx)
+
+ b = matmul(atha_inv,ath)
+
+! call sw_migs(ata,n,ata_inv,indx)
+! b = matmul(ata_inv,at)
+! end if
+ b_out(1:n,1:m) = b(1:n,1:m)
+
+! do i=1,n
+! write(6,*) ' i, indx ',i,indx(i)
+! end do
+!
+! write(6,*) ' '
+
+ end subroutine sw_poly_fit_2
+
+
+! Updated 10/24/2001.
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 4.4 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! !
+! Please Note: !
+! !
+! (1) This computer program is written by Tao Pang in conjunction with !
+! his book, "An Introduction to Computational Physics," published !
+! by Cambridge University Press in 1997. !
+! !
+! (2) No warranties, express or implied, are made for this program. !
+! !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+subroutine sw_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 sw_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 sw_migs
+
+
+subroutine sw_elgs (A,N,INDX)
+!
+! subroutine to perform the partial-pivoting Gaussian elimination.
+! A(N,N) is the original matrix in the input and transformed matrix
+! plus the pivoting element ratios below the diagonal in the output.
+! INDX(N) records the pivoting order. Copyright (c) Tao Pang 2001.
+!
+ IMPLICIT NONE
+ INTEGER, INTENT (IN) :: N
+ INTEGER :: I,J,K,ITMP
+ INTEGER, INTENT (OUT), DIMENSION (N) :: INDX
+ REAL (kind=RKIND) :: C1,PI,PI1,PJ
+ REAL (kind=RKIND), INTENT (INOUT), DIMENSION (N,N) :: A
+ REAL (kind=RKIND), DIMENSION (N) :: C
+!
+! Initialize the index
+!
+ DO I = 1, N
+ INDX(I) = I
+ END DO
+!
+! Find the rescaling factors, one from each row
+!
+ DO I = 1, N
+ C1= 0.0
+ DO J = 1, N
+ C1 = MAX(C1,ABS(A(I,J)))
+ END DO
+ C(I) = C1
+ END DO
+!
+! Search the pivoting (largest) element from each column
+!
+ DO J = 1, N-1
+ PI1 = 0.0
+ DO I = J, N
+ PI = ABS(A(INDX(I),J))/C(INDX(I))
+ IF (PI.GT.PI1) THEN
+ PI1 = PI
+ K = I
+ ENDIF
+ END DO
+!
+! Interchange the rows via INDX(N) to record pivoting order
+!
+ ITMP = INDX(J)
+ INDX(J) = INDX(K)
+ INDX(K) = ITMP
+ DO I = J+1, N
+ PJ = A(INDX(I),J)/A(INDX(J),J)
+!
+! Record pivoting ratios below the diagonal
+!
+ A(INDX(I),J) = PJ
+!
+! Modify other elements accordingly
+!
+ DO K = J+1, N
+ A(INDX(I),K) = A(INDX(I),K)-PJ*A(INDX(J),K)
+ END DO
+ END DO
+ END DO
+!
+end subroutine sw_elgs
+
+!-------------------------------------------------------------
+
+ subroutine sw_initialize_deformation_weights( grid )
+
+!
+! compute the cell coefficients for the deformation calculations
+! WCS, 13 July 2010
+!
+ implicit none
+
+ type (mesh_type), intent(in) :: grid
+
+ real (kind=RKIND), dimension(:,:), pointer :: defc_a, defc_b
+ integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnCell
+
+! local variables
+
+ real (kind=RKIND), dimension(2, grid % nEdges) :: thetae
+ real (kind=RKIND), dimension(grid % nEdges) :: xe, ye
+ real (kind=RKIND), dimension(grid % nCells) :: theta_abs
+
+ real (kind=RKIND), dimension(25) :: xc, yc, zc ! cell center coordinates
+ real (kind=RKIND), dimension(25) :: thetav, thetat, dl_sphere
+ real (kind=RKIND) :: xm, ym, zm, dl, xec, yec, zec
+ real (kind=RKIND) :: thetae_tmp, xe_tmp, ye_tmp
+ real (kind=RKIND) :: xv1, xv2, yv1, yv2, zv1, zv2
+ integer :: i, j, k, ip1, ip2, m, n, ip1a, ii
+ integer :: iCell, iEdge
+ real (kind=RKIND) :: pii
+ real (kind=RKIND) :: x0, y0, x1, y1, x2, y2, x3, y3, x4, y4, x5, y5
+ real (kind=RKIND) :: pdx1, pdx2, pdx3, pdy1, pdy2, pdy3, dx1, dx2, dy1, dy2
+ real (kind=RKIND) :: angv1, angv2, dl1, dl2
+ real (kind=RKIND), dimension(25) :: dxe, dye, x2v, y2v, xp, yp, xpt, ypt
+
+ real (kind=RKIND) :: length_scale
+ integer :: ma,na, cell_add, mw, nn
+ integer, dimension(25) :: cell_list
+
+ integer :: cell1, cell2, iv
+ logical :: do_the_cell
+ real (kind=RKIND) :: area_cell, sint2, cost2, sint_cost, sumw1, sumw2, xptt, area_cellt
+
+ logical, parameter :: debug = .false.
+
+ if (debug) write(0,*) ' in def weight calc '
+
+ defc_a => grid % defc_a % array
+ defc_b => grid % defc_b % array
+ cellsOnEdge => grid % cellsOnEdge % array
+ edgesOnCell => grid % edgesOnCell % array
+
+ defc_a(:,:) = 0.
+ defc_b(:,:) = 0.
+
+ pii = 2.*asin(1.0)
+
+ if (debug) write(0,*) ' beginning cell loop '
+
+ do iCell = 1, grid % nCells
+
+ if (debug) write(0,*) ' cell loop ', iCell
+
+ cell_list(1) = iCell
+ do i=2, grid % nEdgesOnCell % array(iCell)+1
+ cell_list(i) = grid % CellsOnCell % array(i-1,iCell)
+ end do
+ n = grid % nEdgesOnCell % array(iCell) + 1
+
+! check to see if we are reaching outside the halo
+
+ if (debug) write(0,*) ' points ', n
+
+ do_the_cell = .true.
+ do i=1,n
+ if (cell_list(i) > grid % nCells) do_the_cell = .false.
+ end do
+
+
+ if (.not. do_the_cell) cycle
+
+
+! compute poynomial fit for this cell if all needed neighbors exist
+ if (grid % on_a_sphere) then
+
+ xc(1) = grid % xCell % array(iCell)/a
+ yc(1) = grid % yCell % array(iCell)/a
+ zc(1) = grid % zCell % array(iCell)/a
+
+
+ do i=2,n
+ iv = grid % verticesOnCell % array(i-1,iCell)
+ xc(i) = grid % xVertex % array(iv)/a
+ yc(i) = grid % yVertex % array(iv)/a
+ zc(i) = grid % zVertex % array(iv)/a
+ end do
+
+ theta_abs(iCell) = pii/2. - sphere_angle( xc(1), yc(1), zc(1), &
+ xc(2), yc(2), zc(2), &
+ 0., 0., 1. )
+
+! angles from cell center to neighbor centers (thetav)
+
+ do i=1,n-1
+
+ ip2 = i+2
+ if (ip2 > n) ip2 = 2
+
+ thetav(i) = sphere_angle( xc(1), yc(1), zc(1), &
+ xc(i+1), yc(i+1), zc(i+1), &
+ xc(ip2), yc(ip2), zc(ip2) )
+
+ dl_sphere(i) = a*arc_length( xc(1), yc(1), zc(1), &
+ xc(i+1), yc(i+1), zc(i+1) )
+ end do
+
+ length_scale = 1.
+ do i=1,n-1
+ dl_sphere(i) = dl_sphere(i)/length_scale
+ end do
+
+ thetat(1) = 0. ! this defines the x direction, cell center 1 ->
+! thetat(1) = theta_abs(iCell) ! this defines the x direction, longitude line
+ do i=2,n-1
+ thetat(i) = thetat(i-1) + thetav(i-1)
+ end do
+
+ do i=1,n-1
+ xp(i) = cos(thetat(i)) * dl_sphere(i)
+ yp(i) = sin(thetat(i)) * dl_sphere(i)
+ end do
+
+ else ! On an x-y plane
+
+ xp(1) = grid % xCell % array(iCell)
+ yp(1) = grid % yCell % array(iCell)
+
+
+ do i=2,n
+ iv = grid % verticesOnCell % array(i-1,iCell)
+ xp(i) = grid % xVertex % array(iv)
+ yp(i) = grid % yVertex % array(iv)
+ end do
+
+ end if
+
+! thetat(1) = 0.
+ thetat(1) = theta_abs(iCell)
+ do i=2,n-1
+ ip1 = i+1
+ if (ip1 == n) ip1 = 1
+ thetat(i) = plane_angle( 0.,0.,0., &
+ xp(i)-xp(i-1), yp(i)-yp(i-1), 0., &
+ xp(ip1)-xp(i), yp(ip1)-yp(i), 0., &
+ 0., 0., 1.)
+ thetat(i) = thetat(i) + thetat(i-1)
+ end do
+
+ area_cell = 0.
+ area_cellt = 0.
+ do i=1,n-1
+ ip1 = i+1
+ if (ip1 == n) ip1 = 1
+ dl = sqrt((xp(ip1)-xp(i))**2 + (yp(ip1)-yp(i))**2)
+ area_cell = area_cell + 0.25*(xp(i)+xp(ip1))*(yp(ip1)-yp(i)) - 0.25*(yp(i)+yp(ip1))*(xp(ip1)-xp(i))
+ area_cellt = area_cellt + (0.25*(xp(i)+xp(ip1))*cos(thetat(i)) + 0.25*(yp(i)+yp(ip1))*sin(thetat(i)))*dl
+ end do
+ if (debug) write(0,*) ' area_cell, area_cellt ',area_cell, area_cellt,area_cell-area_cellt
+
+ do i=1,n-1
+ ip1 = i+1
+ if (ip1 == n) ip1 = 1
+ dl = sqrt((xp(ip1)-xp(i))**2 + (yp(ip1)-yp(i))**2)
+ sint2 = (sin(thetat(i)))**2
+ cost2 = (cos(thetat(i)))**2
+ sint_cost = sin(thetat(i))*cos(thetat(i))
+ defc_a(i,iCell) = dl*(cost2 - sint2)/area_cell
+ defc_b(i,iCell) = dl*2.*sint_cost/area_cell
+ if (cellsOnEdge(1,EdgesOnCell(i,iCell)) /= iCell) then
+ defc_a(i,iCell) = - defc_a(i,iCell)
+ defc_b(i,iCell) = - defc_b(i,iCell)
+ end if
+
+ end do
+
+ end do
+
+ if (debug) write(0,*) ' exiting def weight calc '
+
+ end subroutine sw_initialize_deformation_weights
+
+end module sw_advection
Copied: trunk/mpas/src/core_sw/mpas_sw_global_diagnostics.F (from rev 1113, branches/source_renaming/src/core_sw/mpas_sw_global_diagnostics.F)
===================================================================
--- trunk/mpas/src/core_sw/mpas_sw_global_diagnostics.F (rev 0)
+++ trunk/mpas/src/core_sw/mpas_sw_global_diagnostics.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -0,0 +1,384 @@
+module sw_global_diagnostics
+
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_constants
+ use mpas_dmpar
+
+ implicit none
+ save
+ public
+
+ contains
+
+ subroutine sw_compute_global_diagnostics(dminfo, state, grid, timeIndex, dt)
+
+ ! Note: this routine assumes that there is only one block per processor. No looping
+ ! is preformed over blocks.
+ ! dminfo is the domain info needed for global communication
+ ! state contains the state variables needed to compute global diagnostics
+ ! grid conains the meta data about the grid
+ ! timeIndex is the current time step counter
+ ! dt is the duration of each time step
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! INSTRUCTIONS !
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! To add a new Diagnostic as a Global Stat, follow these steps.
+ ! 1. Define the array to integrate, and the variable for the value above.
+ ! 2. Allocate the array with the correct dimensions.
+ ! 3. Fill the array with the data to be integrated.
+ ! eg. GlobalFluidThickness = Sum(h dA)/Sum(dA), See below for array filling
+ ! 4. Call Function to compute Global Stat that you want.
+ ! 5. Finish computing the global stat/integral
+ ! 6. Write out your global stat to the file
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ type (state_type), intent(inout) :: state
+ type (mesh_type), intent(in) :: grid
+ integer, intent(in) :: timeIndex
+ real (kind=RKIND), intent(in) :: dt
+
+ integer :: nVertLevels, nCellsSolve, nEdgesSolve, nVerticesSolve, nCellsGlobal, nEdgesGlobal, nVerticesGlobal, iTracer
+ integer :: nCells
+
+ ! Step 1
+ ! 1. Define the array to integrate, and the variable for the value to be stored in after the integration
+ real (kind=RKIND), dimension(:), pointer :: areaCell, dcEdge, dvEdge, areaTriangle, h_s, fCell, fEdge
+ real (kind=RKIND), dimension(:,:), pointer :: h, u, v, h_edge, pv_edge, pv_vertex, pv_cell, h_vertex, weightsOnEdge
+
+ real (kind=RKIND), dimension(:,:,:), pointer :: tracers
+
+ real (kind=RKIND), dimension(:), allocatable :: volumeWeightedPotentialEnergyReservoir, averageThickness
+ real (kind=RKIND), dimension(:), allocatable :: potentialEnstrophyReservior, areaEdge, h_s_edge
+
+ real (kind=RKIND), dimension(:,:), allocatable :: cellVolume, cellArea, volumeWeightedPotentialVorticity
+ real (kind=RKIND), dimension(:,:), allocatable :: volumeWeightedPotentialEnstrophy, vertexVolume, volumeWeightedKineticEnergy
+ real (kind=RKIND), dimension(:,:), allocatable :: volumeWeightedPotentialEnergy, volumeWeightedPotentialEnergyTopography
+ real (kind=RKIND), dimension(:,:), allocatable :: keTend_CoriolisForce, keTend_PressureGradient
+ real (kind=RKIND), dimension(:,:), allocatable ::peTend_DivThickness, refAreaWeightedSurfaceHeight, refAreaWeightedSurfaceHeight_edge
+
+ real (kind=RKIND) :: sumCellVolume, sumCellArea, sumVertexVolume, sumrefAreaWeightedSurfaceHeight
+
+ real (kind=RKIND) :: globalFluidThickness, globalPotentialVorticity, globalPotentialEnstrophy, globalEnergy
+ real (kind=RKIND) :: globalCoriolisEnergyTendency, globalKEPETendency, globalPotentialEnstrophyReservoir
+ real (kind=RKIND) :: globalKineticEnergy, globalPotentialEnergy, globalPotentialEnergyReservoir
+ real (kind=RKIND) :: globalKineticEnergyTendency, globalPotentialEnergyTendency
+ real (kind=RKIND) :: global_temp, workpv, q
+ real (kind=RKIND) :: volumeCellGlobal, volumeEdgeGlobal, CFLNumberGlobal
+
+ integer :: elementIndex, variableIndex, nVariables, nSums, nMaxes, nMins
+ integer :: timeLevel, eoe, iLevel, iCell, iEdge, iVertex
+ integer :: fileID, iCell1, iCell2, j
+
+ integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnCell, edgesOnEdge
+ integer, dimension(:), pointer :: nEdgesOnEdge
+
+ cellsOnEdge => grid % cellsOnEdge % array
+ edgesOnCell => grid % edgesOnCell % array
+
+ nVertLevels = grid % nVertLevels
+ nCellsSolve = grid % nCellsSolve
+ nEdgesSolve = grid % nEdgesSolve
+ nVerticesSolve = grid % nVerticesSolve
+ nCells = grid % nCells
+
+ h_s => grid % h_s % array
+ areaCell => grid % areaCell % array
+ dcEdge => grid % dcEdge % array
+ dvEdge => grid % dvEdge % array
+ areaTriangle => grid % areaTriangle % array
+ fCell => grid % fCell % array
+ fEdge => grid % fEdge % array
+ edgesOnEdge => grid % edgesOnEdge % array
+ nEdgesOnEdge => grid % nEdgesOnEdge % array
+
+ allocate(areaEdge(1:nEdgesSolve))
+ areaEdge = dcEdge(1:nEdgesSolve)*dvEdge(1:nEdgesSolve)
+ weightsOnEdge => grid % weightsOnEdge % array
+
+ h => state % h % array
+ u => state % u % array
+ v => state % v % array
+ tracers => state % tracers % array
+ h_edge => state % h_edge % array
+ h_vertex => state % h_vertex % array
+ pv_edge => state % pv_edge % array
+ pv_vertex => state % pv_vertex % array
+ pv_cell => state % pv_cell % array
+
+ ! Step 2
+ ! 2. Allocate the array with the correct dimensions.
+ allocate(cellVolume(nVertLevels,nCellsSolve))
+ allocate(cellArea(nVertLevels,nCellsSolve))
+ allocate(refAreaWeightedSurfaceHeight(nVertLevels,nCellsSolve))
+ allocate(refAreaWeightedSurfaceHeight_edge(nVertLevels,nEdgesSolve))
+ allocate(volumeWeightedPotentialVorticity(nVertLevels,nVerticesSolve))
+ allocate(volumeWeightedPotentialEnstrophy(nVertLevels,nVerticesSolve))
+ allocate(potentialEnstrophyReservior(nCellsSolve))
+ allocate(vertexVolume(nVertLevels,nVerticesSolve))
+ allocate(volumeWeightedKineticEnergy(nVertLevels,nEdgesSolve))
+ allocate(volumeWeightedPotentialEnergy(nVertLevels,nCellsSolve))
+ allocate(volumeWeightedPotentialEnergyTopography(nVertLevels,nCellsSolve))
+ allocate(volumeWeightedPotentialEnergyReservoir(nCellsSolve))
+ allocate(keTend_CoriolisForce(nVertLevels,nEdgesSolve))
+ allocate(keTend_PressureGradient(nVertLevels,nEdgesSolve))
+ allocate(peTend_DivThickness(nVertLevels,nCells))
+
+ allocate(averageThickness(nCellsSolve))
+
+ allocate(h_s_edge(nEdgesSOlve))
+
+
+ cellVolume = 0
+ refAreaWeightedSurfaceHeight = 0
+ refAreaWeightedSurfaceHeight_edge = 0
+ vertexVolume = 0
+ cellArea = 0
+ averageThickness = 0
+ volumeWeightedPotentialVorticity = 0
+ volumeWeightedPotentialEnstrophy = 0
+ volumeWeightedKineticEnergy = 0
+ volumeWeightedPotentialEnergy = 0
+ volumeWeightedPotentialEnergyTopography = 0
+ volumeWeightedPotentialEnergyReservoir = 0
+ keTend_PressureGradient = 0
+ peTend_DivThickness = 0
+ keTend_CoriolisForce = 0
+ h_s_edge = 0
+
+ ! Build Arrays for Global Integrals
+ ! Step 3
+ ! 3. Fill the array with the data to be integrated.
+ ! eg. GlobalFluidThickness = Sum(h dA)/Sum(dA), See below for array filling
+ do iLevel = 1,nVertLevels
+ ! eg. GlobalFluidThickness top (Sum( h dA)) = Sum(cellVolume)
+ cellVolume(iLevel,:) = h(iLevel,1:nCellsSolve)*areaCell(1:nCellsSolve)
+ ! eg. GlobalFluidThickness bot (Sum(dA)) = Sum(cellArea)
+ cellArea(iLevel,:) = areaCell(1:nCellsSolve)
+ volumeWeightedPotentialVorticity(iLevel,:) = pv_vertex(iLevel,1:nVerticesSolve) &
+ *h_vertex(iLevel,1:nVerticesSolve)*areaTriangle(1:nVerticesSolve)
+ volumeWeightedPotentialEnstrophy(iLevel,:) = pv_vertex(iLevel,1:nVerticesSolve) &
+ *pv_vertex(iLevel,1:nVerticesSolve)*h_vertex(iLevel,1:nVerticesSolve)*areaTriangle(1:nVerticesSolve)
+ vertexVolume(iLevel,:) = h_vertex(iLevel,1:nVerticesSolve)*areaTriangle(1:nVerticesSolve)
+ volumeWeightedKineticEnergy(iLevel,:) = u(iLevel,1:nEdgesSolve)*u(iLevel,1:nEdgesSolve) &
+ *h_edge(iLevel,1:nEdgesSolve)*areaEdge(1:nEdgesSolve)*0.5
+ volumeWeightedPotentialEnergy(iLevel,:) = gravity*h(iLevel,1:nCellsSolve)*h(iLevel,1:nCellsSolve)*areaCell(1:nCellsSolve)*0.5
+ volumeWeightedPotentialEnergyTopography(iLevel,:) = gravity*h(iLevel,1:nCellsSolve)*h_s(1:nCellsSolve)*areaCell(1:nCellsSolve)
+ refAreaWeightedSurfaceHeight(iLevel,:) = areaCell(1:nCellsSolve)*(h(iLevel,1:nCellsSolve)+h_s(1:nCellsSolve))
+
+ do iEdge = 1,nEdgesSolve
+ q = 0.0
+ do j = 1,nEdgesOnEdge(iEdge)
+ eoe = edgesOnEdge(j,iEdge)
+ workpv = 0.5 * (pv_edge(iLevel,iEdge) + pv_edge(iLevel,eoe))
+ q = q + weightsOnEdge(j,iEdge) * u(iLevel,eoe) * workpv * h_edge(iLevel,eoe)
+ end do
+ keTend_CoriolisForce(iLevel,iEdge) = h_edge(iLevel,iEdge) * u(iLevel,iEdge) * q * areaEdge(iEdge)
+
+ iCell1 = cellsOnEdge(1,iEdge)
+ iCell2 = cellsOnEdge(2,iEdge)
+
+ refAreaWeightedSurfaceHeight_edge(iLevel,iEdge) = areaEdge(iEdge)*(h_edge(iLevel,iEdge) + 0.5*(h_s(iCell1) + h_s(iCell2)))
+
+ keTend_PressureGradient(iLevel,iEdge) = areaEdge(iEdge)*h_edge(iLevel,iEdge)*u(iLevel,iEdge) &
+ *gravity*(h(iLevel,iCell2)+h_s(iCell2) - h(iLevel,iCell1)-h_s(iCell1))/dcEdge(iEdge)
+ peTend_DivThickness(iLevel,iCell1) = peTend_DivThickness(iLevel,iCell1) &
+ + h_edge(iLevel,iEdge)*u(iLevel,iEdge)*dvEdge(iEdge)
+ peTend_DivThickness(iLevel,iCell2) = peTend_DivThickness(iLevel,iCell2) &
+ - h_edge(iLevel,iEdge)*u(iLevel,iEdge)*dvEdge(iEdge)
+ end do
+
+ peTend_DivThickness(iLevel,:) = peTend_DivThickness(iLevel,1:nCells)*gravity &
+ *(h(iLevel,1:nCells)+h_s(1:nCells))
+ end do
+
+ do iEdge = 1,nEdgesSolve
+ iCell1 = cellsOnEdge(1,iEdge)
+ iCell2 = cellsOnEdge(2,iEdge)
+
+ h_s_edge(iEdge) = 0.5*(h_s(iCell1) + h_s(iCell2))
+ end do
+
+ ! Step 4
+ ! 4. Call Function to compute Global Stat that you want.
+ ! Computing Kinetic and Potential Energy Tendency Terms
+ call sw_compute_global_sum(dminfo, nVertLevels, nEdgesSolve, keTend_PressureGradient, globalKineticEnergyTendency)
+ call sw_compute_global_sum(dminfo, nVertLevels, nCells, peTend_DivThickness, globalPotentialEnergyTendency)
+
+ ! Computing top and bottom of global mass integral
+ call sw_compute_global_sum(dminfo, nVertLevels, nCellsSolve, cellVolume, sumCellVolume)
+ call sw_compute_global_sum(dminfo, nVertLevels, nCellsSolve, cellArea, sumCellArea)
+
+ globalKineticEnergyTendency = globalKineticEnergyTendency / sumCellVolume
+ globalPotentialEnergyTendency = globalPotentialEnergyTendency / sumCellVolume
+
+ ! Step 5
+ ! 5. Finish computing the global stat/integral
+ globalFluidThickness = sumCellVolume/sumCellArea
+
+ ! Compute Average Sea Surface Height for Potential Energy and Enstrophy
+ ! Reservoir computations
+ call sw_compute_global_sum(dminfo, nVertLevels, nCellsSolve, refAreaWeightedSurfaceHeight, sumrefAreaWeightedSurfaceHeight)
+
+ averageThickness(:) = (sumrefAreaWeightedSurfaceHeight/sumCellArea)-h_s(1:nCellsSolve)
+
+ ! Compute Volume Weighted Averages of Potential Vorticity and Potential Enstrophy
+ call sw_compute_global_sum(dminfo, nVertLevels, nVerticesSolve, volumeWeightedPotentialVorticity, globalPotentialVorticity)
+ call sw_compute_global_sum(dminfo, nVertLevels, nVerticesSolve, volumeWeightedPotentialEnstrophy, globalPotentialEnstrophy)
+ call sw_compute_global_sum(dminfo, nVertLevels, nVerticesSolve, vertexVolume, sumVertexVolume)
+
+ globalPotentialVorticity = globalPotentialVorticity/sumVertexVolume
+ globalPotentialEnstrophy = globalPotentialEnstrophy/sumVertexVolume
+
+ ! Compte Potential Enstrophy Reservior
+ potentialEnstrophyReservior(:) = areaCell(:)*fCell(:)*fCell(:)/averageThickness
+ call sw_compute_global_sum(dminfo, 1, nCellsSolve, potentialEnstrophyReservior, globalPotentialEnstrophyReservoir)
+ globalPotentialEnstrophyReservoir = globalPotentialEnstrophyReservoir/sumCellVolume
+
+ globalPotentialEnstrophy = globalPotentialEnstrophy - globalPotentialEnstrophyReservoir
+
+ ! Compute Kinetic and Potential Energy terms to be combined into total energy
+ call sw_compute_global_sum(dminfo, nVertLevels, nEdgesSolve, volumeWeightedKineticEnergy, globalKineticEnergy)
+ call sw_compute_global_sum(dminfo, nVertLevels, nCellsSolve, volumeWeightedPotentialEnergy, globalPotentialEnergy)
+ call sw_compute_global_sum(dminfo, nVertLevels, nCellsSolve, volumeWeightedPotentialEnergyTopography, global_temp)
+
+ globalKineticEnergy = globalKineticEnergy/sumCellVolume
+ globalPotentialEnergy = (globalPotentialEnergy + global_temp)/sumCellVolume
+
+ ! Compute Potential energy reservoir to be subtracted from potential energy term
+ volumeWeightedPotentialEnergyReservoir(1:nCellsSolve) = areaCell(1:nCellsSolve)*averageThickness*averageThickness*gravity*0.5
+ call sw_compute_global_sum(dminfo, nVertLevels, nCellsSolve, volumeWeightedPotentialEnergyReservoir, globalPotentialEnergyReservoir)
+ volumeWeightedPotentialEnergyReservoir(1:nCellsSolve) = areaCell(1:nCellsSolve)*averageThickness*h_s(1:nCellsSolve)*gravity
+ call sw_compute_global_sum(dminfo, nVertLevels, nCellsSolve, volumeWeightedPotentialEnergyReservoir, global_temp)
+
+ globalPotentialEnergyReservoir = (globalPotentialEnergyReservoir + global_temp)/sumCellVolume
+
+ globalPotentialEnergy = globalPotentialEnergy - globalPotentialEnergyReservoir
+ globalEnergy = globalKineticEnergy + globalPotentialEnergy
+
+ ! Compute Coriolis energy tendency term
+ call sw_compute_global_sum(dminfo, nVertLevels, nEdgesSolve, keTend_CoriolisForce, globalCoriolisEnergyTendency)
+ globalCoriolisEnergyTendency = globalCoriolisEnergyTendency/sumCellVolume
+
+ ! Step 6
+ ! 6. Write out your global stat to the file
+ if (dminfo % my_proc_id == IO_NODE) then
+ fileID = sw_get_free_unit()
+
+ if (timeIndex/config_stats_interval == 1) then
+ open(fileID, file='GlobalIntegrals.txt',STATUS='unknown')
+ else
+ open(fileID, file='GlobalIntegrals.txt',POSITION='append')
+ endif
+ write(fileID,'(1i0, 100es24.16)') timeIndex, timeIndex*dt, globalFluidThickness, globalPotentialVorticity, globalPotentialEnstrophy, &
+ globalEnergy, globalCoriolisEnergyTendency, globalKineticEnergyTendency+globalPotentialEnergyTendency, &
+ globalKineticEnergy, globalPotentialEnergy
+ close(fileID)
+ end if
+
+ deallocate(areaEdge)
+ end subroutine sw_compute_global_diagnostics
+
+ integer function sw_get_free_unit()
+ implicit none
+
+ integer :: index
+ logical :: isOpened
+
+ sw_get_free_unit = 0
+ do index = 1,99
+ if((index /= 5) .and. (index /= 6)) then
+ inquire(unit = index, opened = isOpened)
+ if( .not. isOpened) then
+ sw_get_free_unit = index
+ return
+ end if
+ end if
+ end do
+ end function sw_get_free_unit
+
+ subroutine sw_compute_global_sum(dminfo, nVertLevels, nElements, field, globalSum)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: nVertLevels, nElements
+ real (kind=RKIND), dimension(nVertLevels, nElements), intent(in) :: field
+ real (kind=RKIND), intent(out) :: globalSum
+
+ real (kind=RKIND) :: localSum
+
+ localSum = sum(field)
+ call mpas_dmpar_sum_real(dminfo, localSum, globalSum)
+
+ end subroutine sw_compute_global_sum
+
+ subroutine sw_compute_global_min(dminfo, nVertLevels, nElements, field, globalMin)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: nVertLevels, nElements
+ real (kind=RKIND), dimension(nVertLevels, nElements), intent(in) :: field
+ real (kind=RKIND), intent(out) :: globalMin
+
+ real (kind=RKIND) :: localMin
+
+ localMin = minval(field)
+ call mpas_dmpar_min_real(dminfo, localMin, globalMin)
+
+ end subroutine sw_compute_global_min
+
+ subroutine sw_compute_global_max(dminfo, nVertLevels, nElements, field, globalMax)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: nVertLevels, nElements
+ real (kind=RKIND), dimension(nVertLevels, nElements), intent(in) :: field
+ real (kind=RKIND), intent(out) :: globalMax
+
+ real (kind=RKIND) :: localMax
+
+ localMax = maxval(field)
+ call mpas_dmpar_max_real(dminfo, localMax, globalMax)
+
+ end subroutine sw_compute_global_max
+
+ subroutine compute_global_vert_sum_horiz_min(dminfo, nVertLevels, nElements, field, globalMin)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: nVertLevels, nElements
+ real (kind=RKIND), dimension(nVertLevels, nElements), intent(in) :: field
+ real (kind=RKIND), intent(out) :: globalMin
+
+ real (kind=RKIND) :: localMin
+
+ localMin = minval(sum(field,1))
+ call mpas_dmpar_min_real(dminfo, localMin, globalMin)
+
+ end subroutine compute_global_vert_sum_horiz_min
+
+ subroutine sw_compute_global_vert_sum_horiz_max(dminfo, nVertLevels, nElements, field, globalMax)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: nVertLevels, nElements
+ real (kind=RKIND), dimension(nVertLevels, nElements), intent(in) :: field
+ real (kind=RKIND), intent(out) :: globalMax
+
+ real (kind=RKIND) :: localMax
+
+ localMax = maxval(sum(field,1))
+ call mpas_dmpar_max_real(dminfo, localMax, globalMax)
+
+ end subroutine sw_compute_global_vert_sum_horiz_max
+
+end module sw_global_diagnostics
Copied: trunk/mpas/src/core_sw/mpas_sw_mpas_core.F (from rev 1113, branches/source_renaming/src/core_sw/mpas_sw_mpas_core.F)
===================================================================
--- trunk/mpas/src/core_sw/mpas_sw_mpas_core.F (rev 0)
+++ trunk/mpas/src/core_sw/mpas_sw_mpas_core.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -0,0 +1,382 @@
+module mpas_core
+
+ use mpas_framework
+ use mpas_timekeeping
+
+ type (io_output_object) :: restart_obj
+ integer :: restart_frame
+ integer :: current_outfile_frames
+
+ type (MPAS_Clock_type) :: clock
+
+ integer, parameter :: outputAlarmID = 1
+ integer, parameter :: restartAlarmID = 2
+ !integer, parameter :: statsAlarmID = 3
+
+ contains
+
+ subroutine mpas_core_init(domain, startTimeStamp)
+
+ use mpas_configure
+ use mpas_grid_types
+ use sw_test_cases
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+ character(len=*), intent(out) :: startTimeStamp
+
+ real (kind=RKIND) :: dt
+ type (block_type), pointer :: block
+
+
+ if (.not. config_do_restart) call setup_sw_test_case(domain)
+
+ !
+ ! Initialize core
+ !
+ dt = config_dt
+
+ call simulation_clock_init(domain, dt, startTimeStamp)
+
+ block => domain % blocklist
+ do while (associated(block))
+ call mpas_init_block(block, block % mesh, dt)
+ block % state % time_levs(1) % state % xtime % scalar = startTimeStamp
+ block => block % next
+ end do
+
+ restart_frame = 1
+ current_outfile_frames = 0
+
+ end subroutine mpas_core_init
+
+
+ subroutine simulation_clock_init(domain, dt, startTimeStamp)
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+ real (kind=RKIND), intent(in) :: dt
+ character(len=*), intent(out) :: startTimeStamp
+
+ type (MPAS_Time_Type) :: startTime, stopTime, alarmStartTime
+ type (MPAS_TimeInterval_type) :: runDuration, timeStep, alarmTimeStep
+ integer :: ierr
+
+ call mpas_set_time(curr_time=startTime, dateTimeString=config_start_time, ierr=ierr)
+ call mpas_set_timeInterval(timeStep, dt=dt, ierr=ierr)
+
+ if (trim(config_run_duration) /= "none") then
+ call mpas_set_timeInterval(runDuration, timeString=config_run_duration, ierr=ierr)
+ call mpas_create_clock(clock, startTime=startTime, timeStep=timeStep, runDuration=runDuration, ierr=ierr)
+
+ if (trim(config_stop_time) /= "none") then
+ call mpas_set_time(curr_time=stopTime, dateTimeString=config_stop_time, ierr=ierr)
+ if(startTime + runduration /= stopTime) then
+ write(0,*) 'Warning: config_run_duration and config_stop_time are inconsitent: using config_run_duration.'
+ end if
+ end if
+ else if (trim(config_stop_time) /= "none") then
+ call mpas_set_time(curr_time=stopTime, dateTimeString=config_stop_time, ierr=ierr)
+ call mpas_create_clock(clock, startTime=startTime, timeStep=timeStep, stopTime=stopTime, ierr=ierr)
+ else
+ write(0,*) 'Error: Neither config_run_duration nor config_stop_time were specified.'
+ call mpas_dmpar_abort(domain % dminfo)
+ end if
+
+ ! set output alarm
+ call mpas_set_timeInterval(alarmTimeStep, timeString=config_output_interval, ierr=ierr)
+ alarmStartTime = startTime + alarmTimeStep
+ call mpas_add_clock_alarm(clock, outputAlarmID, alarmStartTime, alarmTimeStep, ierr=ierr)
+
+ ! set restart alarm, if necessary
+ if (trim(config_restart_interval) /= "none") then
+ call mpas_set_timeInterval(alarmTimeStep, timeString=config_restart_interval, ierr=ierr)
+ alarmStartTime = startTime + alarmTimeStep
+ call mpas_add_clock_alarm(clock, restartAlarmID, alarmStartTime, alarmTimeStep, ierr=ierr)
+ end if
+
+ !TODO: use this code if we desire to convert config_stats_interval to alarms
+ !(must also change config_stats_interval type to character)
+ ! set stats alarm, if necessary
+ !if (trim(config_stats_interval) /= "none") then
+ ! call mpas_set_timeInterval(alarmTimeStep, timeString=config_stats_interval, ierr=ierr)
+ ! alarmStartTime = startTime + alarmTimeStep
+ ! call mpas_add_clock_alarm(clock, statsAlarmID, alarmStartTime, alarmTimeStep, ierr=ierr)
+ !end if
+
+ call mpas_get_time(curr_time=startTime, dateTimeString=startTimeStamp, ierr=ierr)
+
+ end subroutine simulation_clock_init
+
+
+ subroutine mpas_init_block(block, mesh, dt)
+
+ use mpas_grid_types
+ use sw_time_integration
+ use mpas_rbf_interpolation
+ use mpas_vector_reconstruction
+
+ implicit none
+
+ type (block_type), intent(inout) :: block
+ type (mesh_type), intent(inout) :: mesh
+ real (kind=RKIND), intent(in) :: dt
+
+
+ call sw_compute_solve_diagnostics(dt, block % state % time_levs(1) % state, mesh)
+ call compute_mesh_scaling(mesh)
+
+ call mpas_rbf_interp_initialize(mesh)
+ call mpas_init_reconstruct(mesh)
+ call mpas_reconstruct(mesh, block % state % time_levs(1) % state % u % array, &
+ block % state % time_levs(1) % state % uReconstructX % array, &
+ block % state % time_levs(1) % state % uReconstructY % array, &
+ block % state % time_levs(1) % state % uReconstructZ % array, &
+ block % state % time_levs(1) % state % uReconstructZonal % array, &
+ block % state % time_levs(1) % state % uReconstructMeridional % array &
+ )
+
+
+ end subroutine mpas_init_block
+
+
+ subroutine mpas_core_run(domain, output_obj, output_frame)
+
+ use mpas_grid_types
+ use mpas_io_output
+ use mpas_timer
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+ type (io_output_object), intent(inout) :: output_obj
+ integer, intent(inout) :: output_frame
+
+ integer :: itimestep
+ real (kind=RKIND) :: dt
+ type (block_type), pointer :: block_ptr
+
+ type (MPAS_Time_Type) :: currTime
+ character(len=32) :: timeStamp
+ integer :: ierr
+
+ ! Eventually, dt should be domain specific
+ dt = config_dt
+
+ currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr)
+ call mpas_get_time(curr_time=currTime, dateTimeString=timeStamp, ierr=ierr)
+ write(0,*) 'Initial timestep ', timeStamp
+
+ call write_output_frame(output_obj, output_frame, domain)
+
+ ! During integration, time level 1 stores the model state at the beginning of the
+ ! time step, and time level 2 stores the state advanced dt in time by timestep(...)
+ itimestep = 0
+ do while (.not. mpas_is_clock_stop_time(clock))
+
+ itimestep = itimestep + 1
+ call mpas_advance_clock(clock)
+
+ currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr)
+ call mpas_get_time(curr_time=currTime, dateTimeString=timeStamp, ierr=ierr)
+ write(0,*) 'Doing timestep ', timeStamp
+
+ call mpas_timer_start("time integration")
+ call mpas_timestep(domain, itimestep, dt, timeStamp)
+ call mpas_timer_stop("time integration")
+
+ ! Move time level 2 fields back into time level 1 for next time step
+ call mpas_shift_time_levels_state(domain % blocklist % state)
+
+ !TODO: mpas_get_clock_ringing_alarms is probably faster than multiple mpas_is_alarm_ringing...
+
+ if (mpas_is_alarm_ringing(clock, outputAlarmID, ierr=ierr)) then
+ call mpas_reset_clock_alarm(clock, outputAlarmID, ierr=ierr)
+ if(output_frame == 1) call mpas_output_state_init(output_obj, domain, "OUTPUT", trim(timeStamp)) ! output_frame will always be > 1 here unless it is reset after the output file is finalized
+ call write_output_frame(output_obj, output_frame, domain)
+ end if
+
+ if (mpas_is_alarm_ringing(clock, restartAlarmID, ierr=ierr)) then
+ call mpas_reset_clock_alarm(clock, restartAlarmID, ierr=ierr)
+ if (restart_frame == 1) call mpas_output_state_init(restart_obj, domain, "RESTART")
+ call mpas_output_state_for_domain(restart_obj, domain, restart_frame)
+ restart_frame = restart_frame + 1
+ end if
+
+ end do
+
+ end subroutine mpas_core_run
+
+
+ subroutine write_output_frame(output_obj, output_frame, domain)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Compute diagnostic fields for a domain and write model state to output file
+ !
+ ! Input/Output: domain - contains model state; diagnostic field are computed
+ ! before returning
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ use mpas_grid_types
+ use mpas_io_output
+
+ implicit none
+
+ type (io_output_object), intent(inout) :: output_obj
+ integer, intent(inout) :: output_frame
+ type (domain_type), intent(inout) :: domain
+
+ integer :: i, j, k
+ integer :: eoe
+ type (block_type), pointer :: block_ptr
+
+ block_ptr => domain % blocklist
+ do while (associated(block_ptr))
+ call compute_output_diagnostics(block_ptr % state % time_levs(1) % state, block_ptr % mesh)
+ block_ptr => block_ptr % next
+ end do
+
+ call mpas_output_state_for_domain(output_obj, domain, output_frame)
+ output_frame = output_frame + 1
+
+ ! if the maximum number of frames per outfile has been reached, finalize outfile and reset frame
+ if (config_frames_per_outfile > 0) then
+ current_outfile_frames = current_outfile_frames + 1
+ if(current_outfile_frames >= config_frames_per_outfile) then
+ current_outfile_frames = 0
+ call mpas_output_state_finalize(output_obj, domain % dminfo)
+ output_frame = 1
+ end if
+ end if
+
+ end subroutine write_output_frame
+
+
+ subroutine compute_output_diagnostics(state, grid)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Compute diagnostic fields for a domain
+ !
+ ! Input: state - contains model prognostic fields
+ ! grid - contains grid metadata
+ !
+ ! Output: state - upon returning, diagnostic fields will have be computed
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ use mpas_grid_types
+
+ implicit none
+
+ type (state_type), intent(inout) :: state
+ type (mesh_type), intent(in) :: grid
+
+ integer :: i, eoe
+ integer :: iEdge, k
+
+ end subroutine compute_output_diagnostics
+
+
+ subroutine mpas_timestep(domain, itimestep, dt, timeStamp)
+
+ use mpas_grid_types
+ use sw_time_integration
+ use mpas_timer
+ use sw_global_diagnostics
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+ integer, intent(in) :: itimestep
+ real (kind=RKIND), intent(in) :: dt
+ character(len=*), intent(in) :: timeStamp
+
+ type (block_type), pointer :: block_ptr
+ integer :: ierr
+
+ call sw_timestep(domain, dt, timeStamp)
+
+ if(config_stats_interval .gt. 0) then
+ if(mod(itimestep, config_stats_interval) == 0) then
+ block_ptr => domain % blocklist
+ if(associated(block_ptr % next)) then
+ write(0,*) 'Error: computeGlobalDiagnostics assumes ',&
+ 'that there is only one block per processor.'
+ end if
+
+ call mpas_timer_start("global_diagnostics")
+ call sw_compute_global_diagnostics(domain % dminfo, &
+ block_ptr % state % time_levs(2) % state, block_ptr % mesh, &
+ itimestep, dt)
+ call mpas_timer_stop("global_diagnostics")
+ end if
+ end if
+
+ !TODO: replace the above code block with this if we desire to convert config_stats_interval to use alarms
+ !if (mpas_is_alarm_ringing(clock, statsAlarmID, ierr=ierr)) then
+ ! call mpas_reset_clock_alarm(clock, statsAlarmID, ierr=ierr)
+
+ ! block_ptr => domain % blocklist
+ ! if(associated(block_ptr % next)) then
+ ! write(0,*) 'Error: computeGlobalDiagnostics assumes ',&
+ ! 'that there is only one block per processor.'
+ ! end if
+
+ ! call mpas_timer_start("global_diagnostics")
+ ! call sw_compute_global_diagnostics(domain % dminfo, &
+ ! block_ptr % state % time_levs(2) % state, block_ptr % mesh, &
+ ! timeStamp, dt)
+ ! call mpas_timer_stop("global_diagnostics")
+ !end if
+
+ end subroutine mpas_timestep
+
+
+ subroutine mpas_core_finalize(domain)
+
+ use mpas_grid_types
+
+ implicit none
+
+ integer :: ierr
+
+ type (domain_type), intent(inout) :: domain
+
+ if (restart_frame > 1) call mpas_output_state_finalize(restart_obj, domain % dminfo)
+
+ call mpas_destroy_clock(clock, ierr)
+
+ end subroutine mpas_core_finalize
+
+
+ subroutine compute_mesh_scaling(mesh)
+
+ use mpas_grid_types
+
+ implicit none
+
+ type (mesh_type), intent(inout) :: mesh
+
+ integer :: iEdge, cell1, cell2
+ real (kind=RKIND), dimension(:), pointer :: meshDensity, meshScalingDel2, meshScalingDel4
+
+ meshDensity => mesh % meshDensity % array
+ meshScalingDel2 => mesh % meshScalingDel2 % array
+ meshScalingDel4 => mesh % meshScalingDel4 % array
+
+ !
+ ! Compute the scaling factors to be used in the del2 and del4 dissipation
+ !
+ meshScalingDel2(:) = 1.0
+ meshScalingDel4(:) = 1.0
+ if (config_h_ScaleWithMesh) then
+ do iEdge=1,mesh%nEdges
+ cell1 = mesh % cellsOnEdge % array(1,iEdge)
+ cell2 = mesh % cellsOnEdge % array(2,iEdge)
+ meshScalingDel2(iEdge) = 1.0 / ( (meshDensity(cell1) + meshDensity(cell2) )/2.0)**(5.0/12.0)
+ meshScalingDel4(iEdge) = 1.0 / ( (meshDensity(cell1) + meshDensity(cell2) )/2.0)**(5.0/6.0)
+ end do
+ end if
+
+ end subroutine compute_mesh_scaling
+
+end module mpas_core
Copied: trunk/mpas/src/core_sw/mpas_sw_test_cases.F (from rev 1113, branches/source_renaming/src/core_sw/mpas_sw_test_cases.F)
===================================================================
--- trunk/mpas/src/core_sw/mpas_sw_test_cases.F (rev 0)
+++ trunk/mpas/src/core_sw/mpas_sw_test_cases.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -0,0 +1,527 @@
+module sw_test_cases
+
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_constants
+
+
+ contains
+
+
+ subroutine setup_sw_test_case(domain)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Configure grid metadata and model state for the shallow water test case
+ ! specified in the namelist
+ !
+ ! Output: block - a subset (not necessarily proper) of the model domain to be
+ ! initialized
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+
+ integer :: i
+ type (block_type), pointer :: block_ptr
+
+ if (config_test_case == 0) then
+ write(0,*) 'Using initial conditions supplied in input file'
+
+ else if (config_test_case == 1) then
+ write(0,*) 'Setting up shallow water test case 1'
+ write(0,*) ' -- Advection of Cosine Bell over the Pole'
+
+ block_ptr => domain % blocklist
+ do while (associated(block_ptr))
+ call sw_test_case_1(block_ptr % mesh, block_ptr % state % time_levs(1) % state)
+ do i=2,nTimeLevs
+ call mpas_copy_state(block_ptr % state % time_levs(i) % state, block_ptr % state % time_levs(1) % state)
+ end do
+
+ block_ptr => block_ptr % next
+ end do
+
+ else if (config_test_case == 2) then
+ write(0,*) 'Setting up shallow water test case 2'
+ write(0,*) ' -- Setup shallow water test case 2: Global Steady State Nonlinear Zonal Geostrophic Flow'
+
+ block_ptr => domain % blocklist
+ do while (associated(block_ptr))
+ call sw_test_case_2(block_ptr % mesh, block_ptr % state % time_levs(1) % state)
+ do i=2,nTimeLevs
+ call mpas_copy_state(block_ptr % state % time_levs(i) % state, block_ptr % state % time_levs(1) % state)
+ end do
+
+ block_ptr => block_ptr % next
+ end do
+
+ else if (config_test_case == 5) then
+ write(0,*) 'Setting up shallow water test case 5'
+ write(0,*) ' -- Setup shallow water test case 5: Zonal Flow over an Isolated Mountain'
+
+ block_ptr => domain % blocklist
+ do while (associated(block_ptr))
+ call sw_test_case_5(block_ptr % mesh, block_ptr % state % time_levs(1) % state)
+ do i=2,nTimeLevs
+ call mpas_copy_state(block_ptr % state % time_levs(i) % state, block_ptr % state % time_levs(1) % state)
+ end do
+
+ block_ptr => block_ptr % next
+ end do
+
+ else if (config_test_case == 6) then
+ write(0,*) 'Setting up shallow water test case 6'
+ write(0,*) ' -- Rossby-Haurwitz Wave'
+
+ block_ptr => domain % blocklist
+ do while (associated(block_ptr))
+ call sw_test_case_6(block_ptr % mesh, block_ptr % state % time_levs(1) % state)
+ do i=2,nTimeLevs
+ call mpas_copy_state(block_ptr % state % time_levs(i) % state, block_ptr % state % time_levs(1) % state)
+ end do
+
+ block_ptr => block_ptr % next
+ end do
+
+ else
+ write(0,*) 'Only test case 1, 2, 5, and 6 are currently supported.'
+ stop
+ end if
+
+ end subroutine setup_sw_test_case
+
+
+ subroutine sw_test_case_1(grid, state)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Setup shallow water test case 1: Advection of Cosine Bell over the Pole
+ !
+ ! Reference: Williamson, D.L., et al., "A Standard Test Set for Numerical
+ ! Approximations to the Shallow Water Equations in Spherical
+ ! Geometry" J. of Comp. Phys., 102, pp. 211--224
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (mesh_type), intent(inout) :: grid
+ type (state_type), intent(inout) :: state
+
+ real (kind=RKIND), parameter :: u0 = 2.0 * pii * a / (12.0 * 86400.0)
+ real (kind=RKIND), parameter :: h0 = 1000.0
+ real (kind=RKIND), parameter :: theta_c = 0.0
+ real (kind=RKIND), parameter :: lambda_c = 3.0*pii/2.0
+ real (kind=RKIND), parameter :: alpha = pii/4.0
+
+ integer :: iCell, iEdge, iVtx
+ real (kind=RKIND) :: r, u, v
+ real (kind=RKIND), allocatable, dimension(:) :: psiVertex
+
+ !
+ ! Scale all distances and areas from a unit sphere to one with radius a
+ !
+ grid % xCell % array = grid % xCell % array * a
+ grid % yCell % array = grid % yCell % array * a
+ grid % zCell % array = grid % zCell % array * a
+ grid % xVertex % array = grid % xVertex % array * a
+ grid % yVertex % array = grid % yVertex % array * a
+ grid % zVertex % array = grid % zVertex % array * a
+ grid % xEdge % array = grid % xEdge % array * a
+ grid % yEdge % array = grid % yEdge % array * a
+ grid % zEdge % array = grid % zEdge % array * a
+ grid % dvEdge % array = grid % dvEdge % array * a
+ grid % dcEdge % array = grid % dcEdge % array * a
+ grid % areaCell % array = grid % areaCell % array * a**2.0
+ grid % areaTriangle % array = grid % areaTriangle % array * a**2.0
+ grid % kiteAreasOnVertex % array = grid % kiteAreasOnVertex % array * a**2.0
+
+ !
+ ! Initialize wind field
+ !
+ allocate(psiVertex(grid % nVertices))
+ do iVtx=1,grid % nVertices
+ psiVertex(iVtx) = -a * u0 * ( &
+ sin(grid%latVertex%array(iVtx)) * cos(alpha) - &
+ cos(grid%lonVertex%array(iVtx)) * cos(grid%latVertex%array(iVtx)) * sin(alpha) &
+ )
+ end do
+ do iEdge=1,grid % nEdges
+ state % u % array(1,iEdge) = -1.0 * ( &
+ psiVertex(grid%verticesOnEdge%array(2,iEdge)) - &
+ psiVertex(grid%verticesOnEdge%array(1,iEdge)) &
+ ) / grid%dvEdge%array(iEdge)
+ end do
+ deallocate(psiVertex)
+
+ !
+ ! Initialize cosine bell at (theta_c, lambda_c)
+ !
+ do iCell=1,grid % nCells
+ r = sphere_distance(theta_c, lambda_c, grid % latCell % array(iCell), grid % lonCell % array(iCell), a)
+ if (r < a/3.0) then
+ state % h % array(1,iCell) = (h0 / 2.0) * (1.0 + cos(pii*r*3.0/a))
+ else
+ state % h % array(1,iCell) = 0.0
+ end if
+ end do
+
+ end subroutine sw_test_case_1
+
+
+ subroutine sw_test_case_2(grid, state)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Setup shallow water test case 2: Global Steady State Nonlinear Zonal
+ ! Geostrophic Flow
+ !
+ ! Reference: Williamson, D.L., et al., "A Standard Test Set for Numerical
+ ! Approximations to the Shallow Water Equations in Spherical
+ ! Geometry" J. of Comp. Phys., 102, pp. 211--224
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (mesh_type), intent(inout) :: grid
+ type (state_type), intent(inout) :: state
+
+ real (kind=RKIND), parameter :: u0 = 2.0 * pii * a / (12.0 * 86400.0)
+ real (kind=RKIND), parameter :: gh0 = 29400.0
+ real (kind=RKIND), parameter :: alpha = 0.0
+
+ integer :: iCell, iEdge, iVtx
+ real (kind=RKIND) :: u, v
+ real (kind=RKIND), allocatable, dimension(:) :: psiVertex
+
+
+ !
+ ! Scale all distances and areas from a unit sphere to one with radius a
+ !
+ grid % xCell % array = grid % xCell % array * a
+ grid % yCell % array = grid % yCell % array * a
+ grid % zCell % array = grid % zCell % array * a
+ grid % xVertex % array = grid % xVertex % array * a
+ grid % yVertex % array = grid % yVertex % array * a
+ grid % zVertex % array = grid % zVertex % array * a
+ grid % xEdge % array = grid % xEdge % array * a
+ grid % yEdge % array = grid % yEdge % array * a
+ grid % zEdge % array = grid % zEdge % array * a
+ grid % dvEdge % array = grid % dvEdge % array * a
+ grid % dcEdge % array = grid % dcEdge % array * a
+ grid % areaCell % array = grid % areaCell % array * a**2.0
+ grid % areaTriangle % array = grid % areaTriangle % array * a**2.0
+ grid % kiteAreasOnVertex % array = grid % kiteAreasOnVertex % array * a**2.0
+
+
+ !
+ ! Initialize wind field
+ !
+ allocate(psiVertex(grid % nVertices))
+ do iVtx=1,grid % nVertices
+ psiVertex(iVtx) = -a * u0 * ( &
+ sin(grid%latVertex%array(iVtx)) * cos(alpha) - &
+ cos(grid%lonVertex%array(iVtx)) * cos(grid%latVertex%array(iVtx)) * sin(alpha) &
+ )
+ end do
+ do iEdge=1,grid % nEdges
+ state % u % array(1,iEdge) = -1.0 * ( &
+ psiVertex(grid%verticesOnEdge%array(2,iEdge)) - &
+ psiVertex(grid%verticesOnEdge%array(1,iEdge)) &
+ ) / grid%dvEdge%array(iEdge)
+ end do
+ deallocate(psiVertex)
+
+ !
+ ! Generate rotated Coriolis field
+ !
+ do iEdge=1,grid % nEdges
+ grid % fEdge % array(iEdge) = 2.0 * omega * &
+ ( -cos(grid%lonEdge%array(iEdge)) * cos(grid%latEdge%array(iEdge)) * sin(alpha) + &
+ sin(grid%latEdge%array(iEdge)) * cos(alpha) &
+ )
+ end do
+ do iVtx=1,grid % nVertices
+ grid % fVertex % array(iVtx) = 2.0 * omega * &
+ (-cos(grid%lonVertex%array(iVtx)) * cos(grid%latVertex%array(iVtx)) * sin(alpha) + &
+ sin(grid%latVertex%array(iVtx)) * cos(alpha) &
+ )
+ end do
+
+ !
+ ! Initialize height field (actually, fluid thickness field)
+ !
+ do iCell=1,grid % nCells
+ state % h % array(1,iCell) = (gh0 - (a * omega * u0 + 0.5 * u0**2.0) * &
+ (-cos(grid%lonCell%array(iCell)) * cos(grid%latCell%array(iCell)) * sin(alpha) + &
+ sin(grid%latCell%array(iCell)) * cos(alpha) &
+ )**2.0 &
+ ) / &
+ gravity
+ end do
+
+ end subroutine sw_test_case_2
+
+
+ subroutine sw_test_case_5(grid, state)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Setup shallow water test case 5: Zonal Flow over an Isolated Mountain
+ !
+ ! Reference: Williamson, D.L., et al., "A Standard Test Set for Numerical
+ ! Approximations to the Shallow Water Equations in Spherical
+ ! Geometry" J. of Comp. Phys., 102, pp. 211--224
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (mesh_type), intent(inout) :: grid
+ type (state_type), intent(inout) :: state
+
+ real (kind=RKIND), parameter :: u0 = 20.
+ real (kind=RKIND), parameter :: gh0 = 5960.0*gravity
+ real (kind=RKIND), parameter :: hs0 = 2000.
+ real (kind=RKIND), parameter :: theta_c = pii/6.0
+ real (kind=RKIND), parameter :: lambda_c = 3.0*pii/2.0
+ real (kind=RKIND), parameter :: rr = pii/9.0
+ real (kind=RKIND), parameter :: alpha = 0.0
+
+ integer :: iCell, iEdge, iVtx
+ real (kind=RKIND) :: r, u, v
+ real (kind=RKIND), allocatable, dimension(:) :: psiVertex
+
+
+ !
+ ! Scale all distances and areas from a unit sphere to one with radius a
+ !
+ grid % xCell % array = grid % xCell % array * a
+ grid % yCell % array = grid % yCell % array * a
+ grid % zCell % array = grid % zCell % array * a
+ grid % xVertex % array = grid % xVertex % array * a
+ grid % yVertex % array = grid % yVertex % array * a
+ grid % zVertex % array = grid % zVertex % array * a
+ grid % xEdge % array = grid % xEdge % array * a
+ grid % yEdge % array = grid % yEdge % array * a
+ grid % zEdge % array = grid % zEdge % array * a
+ grid % dvEdge % array = grid % dvEdge % array * a
+ grid % dcEdge % array = grid % dcEdge % array * a
+ grid % areaCell % array = grid % areaCell % array * a**2.0
+ grid % areaTriangle % array = grid % areaTriangle % array * a**2.0
+ grid % kiteAreasOnVertex % array = grid % kiteAreasOnVertex % array * a**2.0
+
+ !
+ ! Initialize wind field
+ !
+ allocate(psiVertex(grid % nVertices))
+ do iVtx=1,grid % nVertices
+ psiVertex(iVtx) = -a * u0 * ( &
+ sin(grid%latVertex%array(iVtx)) * cos(alpha) - &
+ cos(grid%lonVertex%array(iVtx)) * cos(grid%latVertex%array(iVtx)) * sin(alpha) &
+ )
+ end do
+ do iEdge=1,grid % nEdges
+ state % u % array(1,iEdge) = -1.0 * ( &
+ psiVertex(grid%verticesOnEdge%array(2,iEdge)) - &
+ psiVertex(grid%verticesOnEdge%array(1,iEdge)) &
+ ) / grid%dvEdge%array(iEdge)
+ end do
+ deallocate(psiVertex)
+
+ !
+ ! Generate rotated Coriolis field
+ !
+ do iEdge=1,grid % nEdges
+ grid % fEdge % array(iEdge) = 2.0 * omega * &
+ (-cos(grid%lonEdge%array(iEdge)) * cos(grid%latEdge%array(iEdge)) * sin(alpha) + &
+ sin(grid%latEdge%array(iEdge)) * cos(alpha) &
+ )
+ end do
+ do iVtx=1,grid % nVertices
+ grid % fVertex % array(iVtx) = 2.0 * omega * &
+ (-cos(grid%lonVertex%array(iVtx)) * cos(grid%latVertex%array(iVtx)) * sin(alpha) + &
+ sin(grid%latVertex%array(iVtx)) * cos(alpha) &
+ )
+ end do
+
+ !
+ ! Initialize mountain
+ !
+ do iCell=1,grid % nCells
+ if (grid % lonCell % array(iCell) < 0.0) grid % lonCell % array(iCell) = grid % lonCell % array(iCell) + 2.0 * pii
+ r = sqrt(min(rr**2.0, (grid % lonCell % array(iCell) - lambda_c)**2.0 + (grid % latCell % array(iCell) - theta_c)**2.0))
+ grid % h_s % array(iCell) = hs0 * (1.0 - r/rr)
+ end do
+
+ !
+ ! Initialize tracer fields
+ !
+ do iCell=1,grid % nCells
+ r = sqrt(min(rr**2.0, (grid % lonCell % array(iCell) - lambda_c)**2.0 + (grid % latCell % array(iCell) - theta_c)**2.0))
+ state % tracers % array(1,1,iCell) = 1.0 - r/rr
+ end do
+ if (grid%nTracers > 1) then
+ do iCell=1,grid % nCells
+ r = sqrt(min(rr**2.0, (grid % lonCell % array(iCell) - lambda_c)**2.0 + &
+ (grid % latCell % array(iCell) - theta_c - pii/6.0)**2.0 &
+ ) &
+ )
+ state % tracers % array(2,1,iCell) = 1.0 - r/rr
+ end do
+ end if
+
+ !
+ ! Initialize height field (actually, fluid thickness field)
+ !
+ do iCell=1,grid % nCells
+ state % h % array(1,iCell) = (gh0 - (a * omega * u0 + 0.5 * u0**2.0) * &
+ (-cos(grid%lonCell%array(iCell)) * cos(grid%latCell%array(iCell)) * sin(alpha) + &
+ sin(grid%latCell%array(iCell)) * cos(alpha) &
+ )**2.0 &
+ ) / &
+ gravity
+ state % h % array(1,iCell) = state % h % array(1,iCell) - grid % h_s % array(iCell)
+ end do
+
+ end subroutine sw_test_case_5
+
+
+ subroutine sw_test_case_6(grid, state)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Setup shallow water test case 6: Rossby-Haurwitz Wave
+ !
+ ! Reference: Williamson, D.L., et al., "A Standard Test Set for Numerical
+ ! Approximations to the Shallow Water Equations in Spherical
+ ! Geometry" J. of Comp. Phys., 102, pp. 211--224
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (mesh_type), intent(inout) :: grid
+ type (state_type), intent(inout) :: state
+
+ real (kind=RKIND), parameter :: h0 = 8000.0
+ real (kind=RKIND), parameter :: w = 7.848e-6
+ real (kind=RKIND), parameter :: K = 7.848e-6
+ real (kind=RKIND), parameter :: R = 4.0
+
+ integer :: iCell, iEdge, iVtx
+ real (kind=RKIND) :: u, v
+ real (kind=RKIND), allocatable, dimension(:) :: psiVertex
+
+
+ !
+ ! Scale all distances and areas from a unit sphere to one with radius a
+ !
+ grid % xCell % array = grid % xCell % array * a
+ grid % yCell % array = grid % yCell % array * a
+ grid % zCell % array = grid % zCell % array * a
+ grid % xVertex % array = grid % xVertex % array * a
+ grid % yVertex % array = grid % yVertex % array * a
+ grid % zVertex % array = grid % zVertex % array * a
+ grid % xEdge % array = grid % xEdge % array * a
+ grid % yEdge % array = grid % yEdge % array * a
+ grid % zEdge % array = grid % zEdge % array * a
+ grid % dvEdge % array = grid % dvEdge % array * a
+ grid % dcEdge % array = grid % dcEdge % array * a
+ grid % areaCell % array = grid % areaCell % array * a**2.0
+ grid % areaTriangle % array = grid % areaTriangle % array * a**2.0
+ grid % kiteAreasOnVertex % array = grid % kiteAreasOnVertex % array * a**2.0
+
+ !
+ ! Initialize wind field
+ !
+ allocate(psiVertex(grid % nVertices))
+ do iVtx=1,grid % nVertices
+ psiVertex(iVtx) = -a * a * w * sin(grid%latVertex%array(iVtx)) + &
+ a *a * K * (cos(grid%latVertex%array(iVtx))**R) * &
+ sin(grid%latVertex%array(iVtx)) * cos(R * grid%lonVertex%array(iVtx))
+ end do
+ do iEdge=1,grid % nEdges
+ state % u % array(1,iEdge) = -1.0 * ( &
+ psiVertex(grid%verticesOnEdge%array(2,iEdge)) - &
+ psiVertex(grid%verticesOnEdge%array(1,iEdge)) &
+ ) / grid%dvEdge%array(iEdge)
+ end do
+ deallocate(psiVertex)
+
+ !
+ ! Initialize height field (actually, fluid thickness field)
+ !
+ do iCell=1,grid % nCells
+ state % h % array(1,iCell) = (gravity * h0 + a*a*aa(grid%latCell%array(iCell)) + &
+ a*a*bb(grid%latCell%array(iCell)) * cos(R*grid%lonCell%array(iCell)) + &
+ a*a*cc(grid%latCell%array(iCell)) * cos(2.0*R*grid%lonCell%array(iCell)) &
+ ) / gravity
+ end do
+
+ end subroutine sw_test_case_6
+
+
+ real function sphere_distance(lat1, lon1, lat2, lon2, radius)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Compute the great-circle distance between (lat1, lon1) and (lat2, lon2) on a
+ ! sphere with given radius.
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ real (kind=RKIND), intent(in) :: lat1, lon1, lat2, lon2, radius
+
+ real (kind=RKIND) :: arg1
+
+ arg1 = sqrt( sin(0.5*(lat2-lat1))**2 + &
+ cos(lat1)*cos(lat2)*sin(0.5*(lon2-lon1))**2 )
+ sphere_distance = 2.*radius*asin(arg1)
+
+ end function sphere_distance
+
+
+ real function aa(theta)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! A, used in height field computation for Rossby-Haurwitz wave
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ real (kind=RKIND), parameter :: w = 7.848e-6
+ real (kind=RKIND), parameter :: K = 7.848e-6
+ real (kind=RKIND), parameter :: R = 4.0
+
+ real (kind=RKIND), intent(in) :: theta
+
+ aa = 0.5 * w * (2.0 * omega + w) * cos(theta)**2.0 + &
+ 0.25 * K**2.0 * cos(theta)**(2.0*R) * ((R+1.0)*cos(theta)**2.0 + 2.0*R**2.0 - R - 2.0 - 2.0*R**2.0 * cos(theta)**(-2.0))
+
+ end function aa
+
+
+ real function bb(theta)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! B, used in height field computation for Rossby-Haurwitz wave
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ real (kind=RKIND), parameter :: w = 7.848e-6
+ real (kind=RKIND), parameter :: K = 7.848e-6
+ real (kind=RKIND), parameter :: R = 4.0
+
+ real (kind=RKIND), intent(in) :: theta
+
+ bb = (2.0*(omega + w)*K / ((R+1.0)*(R+2.0))) * cos(theta)**R * ((R**2.0 + 2.0*R + 2.0) - ((R+1.0)*cos(theta))**2.0)
+
+ end function bb
+
+
+ real function cc(theta)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! C, used in height field computation for Rossby-Haurwitz wave
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ real (kind=RKIND), parameter :: w = 7.848e-6
+ real (kind=RKIND), parameter :: K = 7.848e-6
+ real (kind=RKIND), parameter :: R = 4.0
+
+ real (kind=RKIND), intent(in) :: theta
+
+ cc = 0.25 * K**2.0 * cos(theta)**(2.0*R) * ((R+1.0)*cos(theta)**2.0 - R - 2.0)
+
+ end function cc
+
+end module sw_test_cases
Copied: trunk/mpas/src/core_sw/mpas_sw_time_integration.F (from rev 1113, branches/source_renaming/src/core_sw/mpas_sw_time_integration.F)
===================================================================
--- trunk/mpas/src/core_sw/mpas_sw_time_integration.F (rev 0)
+++ trunk/mpas/src/core_sw/mpas_sw_time_integration.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -0,0 +1,1287 @@
+module sw_time_integration
+
+ use mpas_vector_reconstruction
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_constants
+ use mpas_dmpar
+
+
+ contains
+
+
+ subroutine sw_timestep(domain, dt, timeStamp)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Advance model state forward in time by the specified time step
+ !
+ ! Input: domain - current model state in time level 1 (e.g., time_levs(1)state%h(:,:))
+ ! plus grid meta-data
+ ! Output: domain - upon exit, time level 2 (e.g., time_levs(2)%state%h(:,:)) contains
+ ! model state advanced forward in time by dt seconds
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+ real (kind=RKIND), intent(in) :: dt
+ character(len=*), intent(in) :: timeStamp
+
+ type (block_type), pointer :: block
+
+ if (trim(config_time_integration) == 'RK4') then
+ call sw_rk4(domain, dt)
+ else
+ write(0,*) 'Unknown time integration option '//trim(config_time_integration)
+ write(0,*) 'Currently, only ''RK4'' is supported.'
+ stop
+ end if
+
+ block => domain % blocklist
+ do while (associated(block))
+ block % state % time_levs(2) % state % xtime % scalar = timeStamp
+ block => block % next
+ end do
+
+ end subroutine sw_timestep
+
+
+ subroutine sw_rk4(domain, dt)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Advance model state forward in time by the specified time step using
+ ! 4th order Runge-Kutta
+ !
+ ! Input: domain - current model state in time level 1 (e.g., time_levs(1)state%h(:,:))
+ ! plus grid meta-data
+ ! Output: domain - upon exit, time level 2 (e.g., time_levs(2)%state%h(:,:)) contains
+ ! model state advanced forward in time by dt seconds
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+ real (kind=RKIND), intent(in) :: dt
+
+ integer :: iCell, k
+ type (block_type), pointer :: block
+ type (state_type) :: provis
+
+ integer :: rk_step
+
+ real (kind=RKIND), dimension(4) :: rk_weights, rk_substep_weights
+
+ block => domain % blocklist
+ call mpas_allocate_state(provis, &
+ block % mesh % nCells, block % mesh % nEdges, block % mesh % maxEdges, block % mesh % maxEdges2, &
+ block % mesh % nVertices, block % mesh % vertexDegree, block % mesh % nVertLevels, &
+ block % mesh % nTracers)
+
+ !
+ ! Initialize time_levs(2) with state at current time
+ ! Initialize first RK state
+ ! Couple tracers time_levs(2) with h in time-levels
+ ! Initialize RK weights
+ !
+ block => domain % blocklist
+ do while (associated(block))
+
+ block % state % time_levs(2) % state % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:)
+ block % state % time_levs(2) % state % h % array(:,:) = block % state % time_levs(1) % state % h % array(:,:)
+ do iCell=1,block % mesh % nCells ! couple tracers to h
+ do k=1,block % mesh % nVertLevels
+ block % state % time_levs(2) % state % tracers % array(:,k,iCell) = block % state % time_levs(1) % state % tracers % array(:,k,iCell) &
+ * block % state % time_levs(1) % state % h % array(k,iCell)
+ end do
+ end do
+
+ call mpas_copy_state(provis, block % state % time_levs(1) % state)
+
+ block => block % next
+ end do
+
+ rk_weights(1) = dt/6.
+ rk_weights(2) = dt/3.
+ rk_weights(3) = dt/3.
+ rk_weights(4) = dt/6.
+
+ rk_substep_weights(1) = dt/2.
+ rk_substep_weights(2) = dt/2.
+ rk_substep_weights(3) = dt
+ rk_substep_weights(4) = 0.
+
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! BEGIN RK loop
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ do rk_step = 1, 4
+
+! --- update halos for diagnostic variables
+
+ block => domain % blocklist
+ do while (associated(block))
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, provis % pv_edge % array(:,:), &
+ block % mesh % nVertLevels, block % mesh % nEdges, &
+ block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
+
+ if (config_h_mom_eddy_visc4 > 0.0) then
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % divergence % array(:,:), &
+ block % mesh % nVertLevels, block % mesh % nCells, &
+ block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % vorticity % array(:,:), &
+ block % mesh % nVertLevels, block % mesh % nVertices, &
+ block % parinfo % verticesToSend, block % parinfo % verticesToRecv)
+ end if
+
+ block => block % next
+ end do
+
+! --- compute tendencies
+
+ block => domain % blocklist
+ do while (associated(block))
+ call sw_compute_tend(block % tend, provis, block % mesh)
+ call sw_compute_scalar_tend(block % tend, provis, block % mesh)
+ call sw_enforce_boundary_edge(block % tend, block % mesh)
+ block => block % next
+ end do
+
+! --- update halos for prognostic variables
+
+ block => domain % blocklist
+ do while (associated(block))
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % tend % u % array(:,:), &
+ block % mesh % nVertLevels, block % mesh % nEdges, &
+ block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % tend % h % array(:,:), &
+ block % mesh % nVertLevels, block % mesh % nCells, &
+ block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ call mpas_dmpar_exch_halo_field3d_real(domain % dminfo, block % tend % tracers % array(:,:,:), &
+ block % mesh % nTracers, block % mesh % nVertLevels, block % mesh % nCells, &
+ block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ block => block % next
+ end do
+
+! --- compute next substep state
+
+ if (rk_step < 4) then
+ block => domain % blocklist
+ do while (associated(block))
+ provis % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:) &
+ + rk_substep_weights(rk_step) * block % tend % u % array(:,:)
+ provis % h % array(:,:) = block % state % time_levs(1) % state % h % array(:,:) &
+ + rk_substep_weights(rk_step) * block % tend % h % array(:,:)
+ do iCell=1,block % mesh % nCells
+ do k=1,block % mesh % nVertLevels
+ provis % tracers % array(:,k,iCell) = ( &
+ block % state % time_levs(1) % state % h % array(k,iCell) * &
+ block % state % time_levs(1) % state % tracers % array(:,k,iCell) &
+ + rk_substep_weights(rk_step) * block % tend % tracers % array(:,k,iCell) &
+ ) / provis % h % array(k,iCell)
+ end do
+ end do
+ if (config_test_case == 1) then ! For case 1, wind field should be fixed
+ provis % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:)
+ end if
+ call sw_compute_solve_diagnostics(dt, provis, block % mesh)
+ block => block % next
+ end do
+ end if
+
+!--- accumulate update (for RK4)
+
+ block => domain % blocklist
+ do while (associated(block))
+ block % state % time_levs(2) % state % u % array(:,:) = block % state % time_levs(2) % state % u % array(:,:) &
+ + rk_weights(rk_step) * block % tend % u % array(:,:)
+ block % state % time_levs(2) % state % h % array(:,:) = block % state % time_levs(2) % state % h % array(:,:) &
+ + rk_weights(rk_step) * block % tend % h % array(:,:)
+ do iCell=1,block % mesh % nCells
+ do k=1,block % mesh % nVertLevels
+ block % state % time_levs(2) % state % tracers % array(:,k,iCell) = &
+ block % state % time_levs(2) % state % tracers % array(:,k,iCell) &
+ + rk_weights(rk_step) * block % tend % tracers % array(:,k,iCell)
+ end do
+ end do
+ block => block % next
+ end do
+
+ end do
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! END RK loop
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+ !
+ ! A little clean up at the end: decouple new scalar fields and compute diagnostics for new state
+ !
+ block => domain % blocklist
+ do while (associated(block))
+ do iCell=1,block % mesh % nCells
+ do k=1,block % mesh % nVertLevels
+ block % state % time_levs(2) % state % tracers % array(:,k,iCell) = &
+ block % state % time_levs(2) % state % tracers % array(:,k,iCell) &
+ / block % state % time_levs(2) % state % h % array(k,iCell)
+ end do
+ end do
+
+ if (config_test_case == 1) then ! For case 1, wind field should be fixed
+ block % state % time_levs(2) % state % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:)
+ end if
+
+ call sw_compute_solve_diagnostics(dt, block % state % time_levs(2) % state, block % mesh)
+
+ call mpas_reconstruct(block % mesh, block % state % time_levs(2) % state % u % array, &
+ block % state % time_levs(2) % state % uReconstructX % array, &
+ block % state % time_levs(2) % state % uReconstructY % array, &
+ block % state % time_levs(2) % state % uReconstructZ % array, &
+ block % state % time_levs(2) % state % uReconstructZonal % array, &
+ block % state % time_levs(2) % state % uReconstructMeridional % array &
+ )
+
+ block => block % next
+ end do
+
+ call mpas_deallocate_state(provis)
+
+ end subroutine sw_rk4
+
+
+ subroutine sw_compute_tend(tend, s, grid)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Compute height and normal wind tendencies, as well as diagnostic variables
+ !
+ ! Input: s - current model state
+ ! grid - grid metadata
+ !
+ ! Output: tend - computed tendencies for prognostic variables
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (tend_type), intent(inout) :: tend
+ type (state_type), intent(in) :: s
+ type (mesh_type), intent(in) :: grid
+
+ integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j
+ real (kind=RKIND) :: flux, vorticity_abs, workpv, q, upstream_bias
+
+ integer :: nCells, nEdges, nVertices, nVertLevels
+ real (kind=RKIND), dimension(:), pointer :: h_s, fVertex, fEdge, dvEdge, dcEdge, areaCell, areaTriangle, &
+ meshScalingDel2, meshScalingDel4
+ real (kind=RKIND), dimension(:,:), pointer :: vh, weightsOnEdge, kiteAreasOnVertex, h_edge, h, u, v, tend_h, tend_u, &
+ circulation, vorticity, ke, pv_edge, divergence, h_vertex
+ integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnVertex, verticesOnEdge, edgesOnCell, edgesOnEdge, edgesOnVertex
+ integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge
+ real (kind=RKIND) :: r, u_diffusion
+
+ real (kind=RKIND), allocatable, dimension(:,:) :: delsq_divergence
+ real (kind=RKIND), allocatable, dimension(:,:) :: delsq_u
+ real (kind=RKIND), allocatable, dimension(:,:) :: delsq_circulation, delsq_vorticity
+
+ real (kind=RKIND), dimension(:,:), pointer :: u_src
+ real (kind=RKIND), parameter :: rho_ref = 1000.0
+ real (kind=RKIND) :: ke_edge
+
+
+ h => s % h % array
+ u => s % u % array
+ v => s % v % array
+ h_edge => s % h_edge % array
+ circulation => s % circulation % array
+ vorticity => s % vorticity % array
+ divergence => s % divergence % array
+ ke => s % ke % array
+ pv_edge => s % pv_edge % array
+ vh => s % vh % array
+
+ weightsOnEdge => grid % weightsOnEdge % array
+ kiteAreasOnVertex => grid % kiteAreasOnVertex % array
+ cellsOnEdge => grid % cellsOnEdge % array
+ cellsOnVertex => grid % cellsOnVertex % array
+ verticesOnEdge => grid % verticesOnEdge % array
+ nEdgesOnCell => grid % nEdgesOnCell % array
+ edgesOnCell => grid % edgesOnCell % array
+ nEdgesOnEdge => grid % nEdgesOnEdge % array
+ edgesOnEdge => grid % edgesOnEdge % array
+ edgesOnVertex => grid % edgesOnVertex % array
+ dcEdge => grid % dcEdge % array
+ dvEdge => grid % dvEdge % array
+ areaCell => grid % areaCell % array
+ areaTriangle => grid % areaTriangle % array
+ h_s => grid % h_s % array
+ fVertex => grid % fVertex % array
+ fEdge => grid % fEdge % array
+
+ tend_h => tend % h % array
+ tend_u => tend % u % array
+
+ nCells = grid % nCells
+ nEdges = grid % nEdges
+ nVertices = grid % nVertices
+ nVertLevels = grid % nVertLevels
+
+ u_src => grid % u_src % array
+
+ meshScalingDel2 => grid % meshScalingDel2 % array
+ meshScalingDel4 => grid % meshScalingDel4 % array
+
+
+ !
+ ! Compute height tendency for each cell
+ !
+ tend_h(:,:) = 0.0
+ do iEdge=1,nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ do k=1,nVertLevels
+ flux = u(k,iEdge) * dvEdge(iEdge) * h_edge(k,iEdge)
+ tend_h(k,cell1) = tend_h(k,cell1) - flux
+ tend_h(k,cell2) = tend_h(k,cell2) + flux
+ end do
+ end do
+ do iCell=1,grid % nCellsSolve
+ do k=1,nVertLevels
+ tend_h(k,iCell) = tend_h(k,iCell) / areaCell(iCell)
+ end do
+ end do
+
+#ifdef LANL_FORMULATION
+ !
+ ! Compute u (normal) velocity tendency for each edge (cell face)
+ !
+ tend_u(:,:) = 0.0
+ do iEdge=1,grid % nEdgesSolve
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ vertex1 = verticesOnEdge(1,iEdge)
+ vertex2 = verticesOnEdge(2,iEdge)
+
+ do k=1,nVertLevels
+ q = 0.0
+ do j = 1,nEdgesOnEdge(iEdge)
+ eoe = edgesOnEdge(j,iEdge)
+ workpv = 0.5 * (pv_edge(k,iEdge) + pv_edge(k,eoe))
+ q = q + weightsOnEdge(j,iEdge) * u(k,eoe) * workpv * h_edge(k,eoe)
+ end do
+
+ tend_u(k,iEdge) = &
+ q &
+ - ( ke(k,cell2) - ke(k,cell1) + &
+ gravity * (h(k,cell2) + h_s(cell2) - h(k,cell1) - h_s(cell1)) &
+ ) / dcEdge(iEdge)
+ end do
+ end do
+
+
+#endif
+
+#ifdef NCAR_FORMULATION
+ !
+ ! Compute u (normal) velocity tendency for each edge (cell face)
+ !
+ tend_u(:,:) = 0.0
+ do iEdge=1,grid % nEdgesSolve
+ vertex1 = verticesOnEdge(1,iEdge)
+ vertex2 = verticesOnEdge(2,iEdge)
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+
+ do k=1,nVertLevels
+ vorticity_abs = fEdge(iEdge) + (circulation(k,vertex1) + circulation(k,vertex2)) / &
+ (areaTriangle(vertex1) + areaTriangle(vertex2))
+
+ workpv = 2.0 * vorticity_abs / (h(k,cell1) + h(k,cell2))
+
+ tend_u(k,iEdge) = workpv * vh(k,iEdge) - &
+ (ke(k,cell2) - ke(k,cell1) + &
+ gravity * (h(k,cell2) + h_s(cell2) - h(k,cell1) - h_s(cell1)) &
+ ) / &
+ dcEdge(iEdge)
+ end do
+ end do
+#endif
+
+ ! Compute diffusion, computed as </font>
<font color="black">abla divergence - k \times </font>
<font color="blue">abla vorticity
+ ! only valid for visc == constant
+ if (config_h_mom_eddy_visc2 > 0.0) then
+ do iEdge=1,grid % nEdgesSolve
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ vertex1 = verticesOnEdge(1,iEdge)
+ vertex2 = verticesOnEdge(2,iEdge)
+
+ do k=1,nVertLevels
+ u_diffusion = ( divergence(k,cell2) - divergence(k,cell1) ) / dcEdge(iEdge) &
+ -(vorticity(k,vertex2) - vorticity(k,vertex1) ) / dvEdge(iEdge)
+ u_diffusion = meshScalingDel2(iEdge) * config_h_mom_eddy_visc2 * u_diffusion
+ tend_u(k,iEdge) = tend_u(k,iEdge) + u_diffusion
+ end do
+ end do
+ end if
+
+ !
+ ! velocity tendency: del4 dissipation, -</font>
<font color="black">u_4 </font>
<font color="blue">abla^4 u
+ ! computed as </font>
<font color="black">abla^2 u = </font>
<font color="black">abla divergence + k \times </font>
<font color="blue">abla vorticity
+ ! applied recursively.
+ ! strictly only valid for h_mom_eddy_visc4 == constant
+ !
+ if (config_h_mom_eddy_visc4 > 0.0) then
+ allocate(delsq_divergence(nVertLevels, nCells+1))
+ allocate(delsq_u(nVertLevels, nEdges+1))
+ allocate(delsq_circulation(nVertLevels, nVertices+1))
+ allocate(delsq_vorticity(nVertLevels, nVertices+1))
+
+ delsq_u(:,:) = 0.0
+
+ ! Compute </font>
<font color="black">abla^2 u = </font>
<font color="black">abla divergence + k \times </font>
<font color="blue">abla vorticity
+ do iEdge=1,grid % nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ vertex1 = verticesOnEdge(1,iEdge)
+ vertex2 = verticesOnEdge(2,iEdge)
+
+ do k=1,nVertLevels
+
+ delsq_u(k,iEdge) = ( divergence(k,cell2) - divergence(k,cell1) ) / dcEdge(iEdge) &
+ -( vorticity(k,vertex2) - vorticity(k,vertex1)) / dvEdge(iEdge)
+
+ end do
+ end do
+
+ ! vorticity using </font>
<font color="blue">abla^2 u
+ delsq_circulation(:,:) = 0.0
+ do iEdge=1,nEdges
+ vertex1 = verticesOnEdge(1,iEdge)
+ vertex2 = verticesOnEdge(2,iEdge)
+ do k=1,nVertLevels
+ delsq_circulation(k,vertex1) = delsq_circulation(k,vertex1) &
+ - dcEdge(iEdge) * delsq_u(k,iEdge)
+ delsq_circulation(k,vertex2) = delsq_circulation(k,vertex2) &
+ + dcEdge(iEdge) * delsq_u(k,iEdge)
+ end do
+ end do
+ do iVertex=1,nVertices
+ r = 1.0 / areaTriangle(iVertex)
+ do k=1,nVertLevels
+ delsq_vorticity(k,iVertex) = delsq_circulation(k,iVertex) * r
+ end do
+ end do
+
+ ! Divergence using </font>
<font color="blue">abla^2 u
+ delsq_divergence(:,:) = 0.0
+ do iEdge=1,nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ do k=1,nVertLevels
+ delsq_divergence(k,cell1) = delsq_divergence(k,cell1) &
+ + delsq_u(k,iEdge)*dvEdge(iEdge)
+ delsq_divergence(k,cell2) = delsq_divergence(k,cell2) &
+ - delsq_u(k,iEdge)*dvEdge(iEdge)
+ end do
+ end do
+ do iCell = 1,nCells
+ r = 1.0 / areaCell(iCell)
+ do k = 1,nVertLevels
+ delsq_divergence(k,iCell) = delsq_divergence(k,iCell) * r
+ end do
+ end do
+
+ ! Compute - \kappa </font>
<font color="blue">abla^4 u
+ ! as </font>
<font color="black">abla div(</font>
<font color="black">abla^2 u) + k \times </font>
<font color="black">abla ( k \cross curl(</font>
<font color="blue">abla^2 u) )
+ do iEdge=1,grid % nEdgesSolve
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ vertex1 = verticesOnEdge(1,iEdge)
+ vertex2 = verticesOnEdge(2,iEdge)
+
+ do k=1,nVertLevels
+
+ u_diffusion = ( delsq_divergence(k,cell2) &
+ - delsq_divergence(k,cell1) ) / dcEdge(iEdge) &
+ -( delsq_vorticity(k,vertex2) &
+ - delsq_vorticity(k,vertex1) ) / dvEdge(iEdge)
+
+ u_diffusion = meshScalingDel4(iEdge) * config_h_mom_eddy_visc4 * u_diffusion
+ tend_u(k,iEdge) = tend_u(k,iEdge) - u_diffusion
+
+ end do
+ end do
+
+ deallocate(delsq_divergence)
+ deallocate(delsq_u)
+ deallocate(delsq_circulation)
+ deallocate(delsq_vorticity)
+
+ end if
+
+ ! Compute u (velocity) tendency from wind stress (u_src)
+ if(config_wind_stress) then
+ do iEdge=1,grid % nEdges
+ tend_u(1,iEdge) = tend_u(1,iEdge) &
+ + u_src(1,iEdge)/rho_ref/h_edge(1,iEdge)
+ end do
+ endif
+
+ if (config_bottom_drag) then
+ do iEdge=1,grid % nEdges
+ ! bottom drag is the same as POP:
+ ! -c |u| u where c is unitless and 1.0e-3.
+ ! see POP Reference guide, section 3.4.4.
+ ke_edge = 0.5 * ( ke(1,cellsOnEdge(1,iEdge)) &
+ + ke(1,cellsOnEdge(2,iEdge)))
+
+ tend_u(1,iEdge) = tend_u(1,iEdge) &
+ - 1.0e-3*u(1,iEdge) &
+ *sqrt(2.0*ke_edge)/h_edge(1,iEdge)
+ end do
+ endif
+
+ end subroutine sw_compute_tend
+
+
+ subroutine sw_compute_scalar_tend(tend, s, grid)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !
+ ! Input: s - current model state
+ ! grid - grid metadata
+ !
+ ! Output: tend - computed scalar tendencies
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (tend_type), intent(inout) :: tend
+ type (state_type), intent(in) :: s
+ type (mesh_type), intent(in) :: grid
+
+ integer :: iCell, iEdge, k, iTracer, cell1, cell2, i
+ real (kind=RKIND) :: flux, tracer_edge, r
+ real (kind=RKIND) :: invAreaCell1, invAreaCell2, tracer_turb_flux
+ integer, dimension(:,:), pointer :: boundaryEdge
+ real (kind=RKIND), dimension(:,:), allocatable :: boundaryMask
+ real (kind=RKIND), dimension(:,:,:), allocatable:: delsq_tracer
+
+ real (kind=RKIND) :: d2fdx2_cell1, d2fdx2_cell2
+ real (kind=RKIND), dimension(:), pointer :: dvEdge, dcEdge, areaCell
+ real (kind=RKIND), dimension(:,:,:), pointer :: tracers, tracer_tend
+ integer, dimension(:,:), pointer :: cellsOnEdge, boundaryCell
+ real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
+ real (kind=RKIND) :: coef_3rd_order
+ real (kind=RKIND), dimension(:,:), pointer :: u, h_edge
+
+ u => s % u % array
+ h_edge => s % h_edge % array
+ dcEdge => grid % dcEdge % array
+ deriv_two => grid % deriv_two % array
+ dvEdge => grid % dvEdge % array
+ tracers => s % tracers % array
+ cellsOnEdge => grid % cellsOnEdge % array
+ boundaryCell=> grid % boundaryCell % array
+ boundaryEdge=> grid % boundaryEdge % array
+ areaCell => grid % areaCell % array
+ tracer_tend => tend % tracers % array
+
+ coef_3rd_order = 0.
+ if (config_tracer_adv_order == 3) coef_3rd_order = 1.0
+ if (config_tracer_adv_order == 3 .and. config_monotonic) coef_3rd_order = 0.25
+
+
+ tracer_tend(:,:,:) = 0.0
+
+ if (config_tracer_adv_order == 2) then
+
+ do iEdge=1,grid % nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ if (cell1 <= grid%nCells .and. cell2 <= grid%nCells) then
+ do k=1,grid % nVertLevels
+ do iTracer=1,grid % nTracers
+ tracer_edge = 0.5 * (tracers(iTracer,k,cell1) + tracers(iTracer,k,cell2))
+ flux = u(k,iEdge) * dvEdge(iEdge) * h_edge(k,iEdge) * tracer_edge
+ tracer_tend(iTracer,k,cell1) = tracer_tend(iTracer,k,cell1) - flux/areaCell(cell1)
+ tracer_tend(iTracer,k,cell2) = tracer_tend(iTracer,k,cell2) + flux/areaCell(cell2)
+ end do
+ end do
+ end if
+ end do
+
+ else if (config_tracer_adv_order == 3) then
+
+ do iEdge=1,grid%nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+
+ !-- if a cell not on the most outside ring of the halo
+ if (cell1 <= grid%nCells .and. cell2 <= grid%nCells) then
+
+ do k=1,grid % nVertLevels
+
+ d2fdx2_cell1 = 0.0
+ d2fdx2_cell2 = 0.0
+
+ do iTracer=1,grid % nTracers
+
+ !-- if not a boundary cell
+ if(boundaryCell(k,cell1).eq.0.and.boundaryCell(k,cell2).eq.0) then
+
+ d2fdx2_cell1 = deriv_two(1,1,iEdge) * tracers(iTracer,k,cell1)
+ d2fdx2_cell2 = deriv_two(1,2,iEdge) * tracers(iTracer,k,cell2)
+
+ !-- all edges of cell 1
+ do i=1, grid % nEdgesOnCell % array (cell1)
+ d2fdx2_cell1 = d2fdx2_cell1 + &
+ deriv_two(i+1,1,iEdge) * tracers(iTracer,k,grid % CellsOnCell % array (i,cell1))
+ end do
+
+ !-- all edges of cell 2
+ do i=1, grid % nEdgesOnCell % array (cell2)
+ d2fdx2_cell2 = d2fdx2_cell2 + &
+ deriv_two(i+1,2,iEdge) * tracers(iTracer,k,grid % CellsOnCell % array (i,cell2))
+ end do
+
+ endif
+
+ !-- if u > 0:
+ if (u(k,iEdge) > 0) then
+ flux = dvEdge(iEdge) * u(k,iEdge) * h_edge(k,iEdge) * ( &
+ 0.5*(tracers(iTracer,k,cell1) + tracers(iTracer,k,cell2)) &
+ -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
+ -(dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12. )
+ !-- else u <= 0:
+ else
+ flux = dvEdge(iEdge) * u(k,iEdge) * h_edge(k,iEdge) * ( &
+ 0.5*(tracers(iTracer,k,cell1) + tracers(iTracer,k,cell2)) &
+ -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
+ +(dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12. )
+ end if
+
+ !-- update tendency
+ tracer_tend(iTracer,k,cell1) = tracer_tend(iTracer,k,cell1) - flux/areaCell(cell1)
+ tracer_tend(iTracer,k,cell2) = tracer_tend(iTracer,k,cell2) + flux/areaCell(cell2)
+ enddo
+ end do
+ end if
+ end do
+
+ else if (config_tracer_adv_order == 4) then
+
+ do iEdge=1,grid%nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+
+ !-- if an edge is not on the outer-most ring of the halo
+ if (cell1 <= grid%nCells .and. cell2 <= grid%nCells) then
+
+ do k=1,grid % nVertLevels
+
+ d2fdx2_cell1 = 0.0
+ d2fdx2_cell2 = 0.0
+
+ do iTracer=1,grid % nTracers
+
+ !-- if not a boundary cell
+ if(boundaryCell(k,cell1).eq.0.and.boundaryCell(k,cell2).eq.0) then
+
+ d2fdx2_cell1 = deriv_two(1,1,iEdge) * tracers(iTracer,k,cell1)
+ d2fdx2_cell2 = deriv_two(1,2,iEdge) * tracers(iTracer,k,cell2)
+
+ !-- all edges of cell 1
+ do i=1, grid % nEdgesOnCell % array (cell1)
+ d2fdx2_cell1 = d2fdx2_cell1 + &
+ deriv_two(i+1,1,iEdge) * tracers(iTracer,k,grid % CellsOnCell % array (i,cell1))
+ end do
+
+ !-- all edges of cell 2
+ do i=1, grid % nEdgesOnCell % array (cell2)
+ d2fdx2_cell2 = d2fdx2_cell2 + &
+ deriv_two(i+1,2,iEdge) * tracers(iTracer,k,grid % CellsOnCell % array (i,cell2))
+ end do
+
+ endif
+
+ flux = dvEdge(iEdge) * u(k,iEdge) * h_edge(k,iEdge) * ( &
+ 0.5*(tracers(iTracer,k,cell1) + tracers(iTracer,k,cell2)) &
+ -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. )
+
+ !-- update tendency
+ tracer_tend(iTracer,k,cell1) = tracer_tend(iTracer,k,cell1) - flux/areaCell(cell1)
+ tracer_tend(iTracer,k,cell2) = tracer_tend(iTracer,k,cell2) + flux/areaCell(cell2)
+ enddo
+ end do
+ end if
+ end do
+
+ endif ! if (config_tracer_adv_order == 2 )
+
+ !
+ ! tracer tendency: del2 horizontal tracer diffusion, div(h \kappa_2 </font>
<font color="blue">abla \phi)
+ !
+ if ( config_h_tracer_eddy_diff2 > 0.0 ) then
+
+ !
+ ! compute a boundary mask to enforce insulating boundary conditions in the horizontal
+ !
+ allocate(boundaryMask(grid % nVertLevels, grid % nEdges+1))
+ boundaryMask = 1.0
+ where(boundaryEdge.eq.1) boundaryMask=0.0
+
+ do iEdge=1,grid % nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ invAreaCell1 = 1.0/areaCell(cell1)
+ invAreaCell2 = 1.0/areaCell(cell2)
+
+ do k=1,grid % nVertLevels
+ do iTracer=1, grid % nTracers
+ ! \kappa_2 </font>
<font color="blue">abla \phi on edge
+ tracer_turb_flux = config_h_tracer_eddy_diff2 &
+ *( tracers(iTracer,k,cell2) - tracers(iTracer,k,cell1)) / dcEdge(iEdge)
+
+ ! div(h \kappa_2 </font>
<font color="blue">abla \phi) at cell center
+ flux = dvEdge(iEdge) * h_edge(k,iEdge) * tracer_turb_flux * boundaryMask(k, iEdge)
+ tracer_tend(iTracer,k,cell1) = tracer_tend(iTracer,k,cell1) + flux * invAreaCell1
+ tracer_tend(iTracer,k,cell2) = tracer_tend(iTracer,k,cell2) - flux * invAreaCell2
+ end do
+ end do
+
+ end do
+
+ deallocate(boundaryMask)
+
+ end if
+
+ !
+ ! tracer tendency: del4 horizontal tracer diffusion, &
+ ! div(h \kappa_4 </font>
<font color="black">abla [div(h </font>
<font color="blue">abla \phi)])
+ !
+ if ( config_h_tracer_eddy_diff4 > 0.0 ) then
+
+ !
+ ! compute a boundary mask to enforce insulating boundary conditions in the horizontal
+ !
+ allocate(boundaryMask(grid % nVertLevels, grid % nEdges+1))
+ boundaryMask = 1.0
+ where(boundaryEdge.eq.1) boundaryMask=0.0
+
+ allocate(delsq_tracer(grid % nTracers, grid % nVertLevels, grid % nCells+1))
+
+ delsq_tracer(:,:,:) = 0.
+
+ ! first del2: div(h </font>
<font color="blue">abla \phi) at cell center
+ do iEdge=1,grid % nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+
+ do k=1,grid % nVertLevels
+ do iTracer=1, grid % nTracers
+ delsq_tracer(iTracer,k,cell1) = delsq_tracer(iTracer,k,cell1) &
+ + dvEdge(iEdge) * h_edge(k,iEdge) * (tracers(iTracer,k,cell2) - tracers(iTracer,k,cell1)) / dcEdge(iEdge) * boundaryMask(k,iEdge)
+ delsq_tracer(iTracer,k,cell2) = delsq_tracer(iTracer,k,cell2) &
+ - dvEdge(iEdge) * h_edge(k,iEdge) * (tracers(iTracer,k,cell2) - tracers(iTracer,k,cell1)) / dcEdge(iEdge) * boundaryMask(k,iEdge)
+ end do
+ end do
+
+ end do
+
+ do iCell = 1, grid % nCells
+ r = 1.0 / grid % areaCell % array(iCell)
+ do k=1,grid % nVertLevels
+ do iTracer=1,grid % nTracers
+ delsq_tracer(iTracer,k,iCell) = delsq_tracer(iTracer,k,iCell) * r
+ end do
+ end do
+ end do
+
+ ! second del2: div(h </font>
<font color="gray">abla [delsq_tracer]) at cell center
+ do iEdge=1,grid % nEdges
+ cell1 = grid % cellsOnEdge % array(1,iEdge)
+ cell2 = grid % cellsOnEdge % array(2,iEdge)
+ invAreaCell1 = 1.0 / grid % areaCell % array(cell1)
+ invAreaCell2 = 1.0 / grid % areaCell % array(cell2)
+
+ do k=1,grid % nVertLevels
+ do iTracer=1,grid % nTracers
+ tracer_turb_flux = config_h_tracer_eddy_diff4 * (delsq_tracer(iTracer,k,cell2) - delsq_tracer(iTracer,k,cell1)) / dcEdge(iEdge)
+ flux = dvEdge(iEdge) * tracer_turb_flux
+ tracer_tend(iTracer,k,cell1) = tracer_tend(iTracer,k,cell1) - flux * invAreaCell1 * boundaryMask(k,iEdge)
+ tracer_tend(iTracer,k,cell2) = tracer_tend(iTracer,k,cell2) + flux * invAreaCell2 * boundaryMask(k,iEdge)
+ end do
+ enddo
+
+ end do
+
+ deallocate(delsq_tracer)
+ deallocate(boundaryMask)
+
+ end if
+
+ end subroutine sw_compute_scalar_tend
+
+
+ subroutine sw_compute_solve_diagnostics(dt, s, grid)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Compute diagnostic fields used in the tendency computations
+ !
+ ! Input: grid - grid metadata
+ !
+ ! Output: s - computed diagnostics
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ real (kind=RKIND), intent(in) :: dt
+ type (state_type), intent(inout) :: s
+ type (mesh_type), intent(in) :: grid
+
+
+ integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j, cov
+ real (kind=RKIND) :: flux, vorticity_abs, workpv
+
+ integer :: nCells, nEdges, nVertices, nVertLevels
+ real (kind=RKIND), dimension(:), pointer :: h_s, fVertex, fEdge, dvEdge, dcEdge, areaCell, areaTriangle
+ real (kind=RKIND), dimension(:,:), pointer :: vh, weightsOnEdge, kiteAreasOnVertex, h_edge, h, u, v, tend_h, tend_u, &
+ circulation, vorticity, ke, pv_edge, pv_vertex, pv_cell, gradPVn, gradPVt, divergence, &
+ h_vertex, vorticity_cell
+ integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnVertex, verticesOnEdge, edgesOnCell, edgesOnEdge, edgesOnVertex, boundaryEdge, boundaryCell
+ integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge
+ real (kind=RKIND) :: r, h1, h2
+ real (kind=RKIND) :: d2fdx2_cell1, d2fdx2_cell2
+ real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
+ real (kind=RKIND) :: coef_3rd_order
+
+ h => s % h % array
+ u => s % u % array
+ v => s % v % array
+ vh => s % vh % array
+ h_edge => s % h_edge % array
+ h_vertex => s % h_vertex % array
+ tend_h => s % h % array
+ tend_u => s % u % array
+ circulation => s % circulation % array
+ vorticity => s % vorticity % array
+ divergence => s % divergence % array
+ ke => s % ke % array
+ pv_edge => s % pv_edge % array
+ pv_vertex => s % pv_vertex % array
+ pv_cell => s % pv_cell % array
+ vorticity_cell => s % vorticity_cell % array
+ gradPVn => s % gradPVn % array
+ gradPVt => s % gradPVt % array
+
+ weightsOnEdge => grid % weightsOnEdge % array
+ kiteAreasOnVertex => grid % kiteAreasOnVertex % array
+ cellsOnEdge => grid % cellsOnEdge % array
+ cellsOnVertex => grid % cellsOnVertex % array
+ verticesOnEdge => grid % verticesOnEdge % array
+ nEdgesOnCell => grid % nEdgesOnCell % array
+ edgesOnCell => grid % edgesOnCell % array
+ nEdgesOnEdge => grid % nEdgesOnEdge % array
+ edgesOnEdge => grid % edgesOnEdge % array
+ edgesOnVertex => grid % edgesOnVertex % array
+ dcEdge => grid % dcEdge % array
+ dvEdge => grid % dvEdge % array
+ areaCell => grid % areaCell % array
+ areaTriangle => grid % areaTriangle % array
+ h_s => grid % h_s % array
+ fVertex => grid % fVertex % array
+ fEdge => grid % fEdge % array
+ deriv_two => grid % deriv_two % array
+
+ nCells = grid % nCells
+ nEdges = grid % nEdges
+ nVertices = grid % nVertices
+ nVertLevels = grid % nVertLevels
+
+ boundaryEdge => grid % boundaryEdge % array
+ boundaryCell => grid % boundaryCell % array
+
+ !
+ ! Find those cells that have an edge on the boundary
+ !
+ boundaryCell(:,:) = 0
+ do iEdge=1,nEdges
+ do k=1,nVertLevels
+ if(boundaryEdge(k,iEdge).eq.1) then
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ boundaryCell(k,cell1) = 1
+ boundaryCell(k,cell2) = 1
+ endif
+ enddo
+ enddo
+
+ !
+ ! Compute height on cell edges at velocity locations
+ ! Namelist options control the order of accuracy of the reconstructed h_edge value
+ !
+
+ coef_3rd_order = 0.
+ if (config_thickness_adv_order == 3) coef_3rd_order = 1.0
+ if (config_thickness_adv_order == 3 .and. config_monotonic) coef_3rd_order = 0.25
+
+ if (config_thickness_adv_order == 2) then
+
+ do iEdge=1,grid % nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ if (cell1 <= grid%nCells .and. cell2 <= grid%nCells) then
+ do k=1,grid % nVertLevels
+ h_edge(k,iEdge) = 0.5 * (h(k,cell1) + h(k,cell2))
+ end do
+ end if
+ end do
+
+ else if (config_thickness_adv_order == 3) then
+
+ do iEdge=1,grid%nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+
+ !-- if a cell not on the most outside ring of the halo
+ if (cell1 <= grid%nCells .and. cell2 <= grid%nCells) then
+
+ do k=1,grid % nVertLevels
+
+ d2fdx2_cell1 = 0.0
+ d2fdx2_cell2 = 0.0
+
+ !-- if not a boundary cell
+ if(boundaryCell(k,cell1).eq.0.and.boundaryCell(k,cell2).eq.0) then
+
+ d2fdx2_cell1 = deriv_two(1,1,iEdge) * h(k,cell1)
+ d2fdx2_cell2 = deriv_two(1,2,iEdge) * h(k,cell2)
+
+ !-- all edges of cell 1
+ do i=1, grid % nEdgesOnCell % array (cell1)
+ d2fdx2_cell1 = d2fdx2_cell1 + &
+ deriv_two(i+1,1,iEdge) * h(k,grid % CellsOnCell % array (i,cell1))
+ end do
+
+ !-- all edges of cell 2
+ do i=1, grid % nEdgesOnCell % array (cell2)
+ d2fdx2_cell2 = d2fdx2_cell2 + &
+ deriv_two(i+1,2,iEdge) * h(k,grid % CellsOnCell % array (i,cell2))
+ end do
+
+ endif
+
+ !-- if u > 0:
+ if (u(k,iEdge) > 0) then
+ h_edge(k,iEdge) = &
+ 0.5*(h(k,cell1) + h(k,cell2)) &
+ -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
+ -(dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12.
+ !-- else u <= 0:
+ else
+ h_edge(k,iEdge) = &
+ 0.5*(h(k,cell1) + h(k,cell2)) &
+ -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
+ +(dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12.
+ end if
+
+ end do ! do k
+ end if ! if (cell1 <=
+ end do ! do iEdge
+
+ else if (config_thickness_adv_order == 4) then
+
+ do iEdge=1,grid%nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+
+ !-- if a cell not on the most outside ring of the halo
+ if (cell1 <= grid%nCells .and. cell2 <= grid%nCells) then
+
+ do k=1,grid % nVertLevels
+
+ d2fdx2_cell1 = 0.0
+ d2fdx2_cell2 = 0.0
+
+ !-- if not a boundary cell
+ if(boundaryCell(k,cell1).eq.0.and.boundaryCell(k,cell2).eq.0) then
+
+ d2fdx2_cell1 = deriv_two(1,1,iEdge) * h(k,cell1)
+ d2fdx2_cell2 = deriv_two(1,2,iEdge) * h(k,cell2)
+
+ !-- all edges of cell 1
+ do i=1, grid % nEdgesOnCell % array (cell1)
+ d2fdx2_cell1 = d2fdx2_cell1 + &
+ deriv_two(i+1,1,iEdge) * h(k,grid % CellsOnCell % array (i,cell1))
+ end do
+
+ !-- all edges of cell 2
+ do i=1, grid % nEdgesOnCell % array (cell2)
+ d2fdx2_cell2 = d2fdx2_cell2 + &
+ deriv_two(i+1,2,iEdge) * h(k,grid % CellsOnCell % array (i,cell2))
+ end do
+
+ endif
+
+ h_edge(k,iEdge) = &
+ 0.5*(h(k,cell1) + h(k,cell2)) &
+ -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12.
+
+ end do ! do k
+ end if ! if (cell1 <=
+ end do ! do iEdge
+
+ endif ! if(config_thickness_adv_order == 2)
+
+ !
+ ! set the velocity in the nEdges+1 slot to zero, this is a dummy address
+ ! used to when reading for edges that do not exist
+ !
+ u(:,nEdges+1) = 0.0
+
+ !
+ ! Compute circulation and relative vorticity at each vertex
+ !
+ circulation(:,:) = 0.0
+ do iEdge=1,nEdges
+ do k=1,nVertLevels
+ circulation(k,verticesOnEdge(1,iEdge)) = circulation(k,verticesOnEdge(1,iEdge)) - dcEdge(iEdge) * u(k,iEdge)
+ circulation(k,verticesOnEdge(2,iEdge)) = circulation(k,verticesOnEdge(2,iEdge)) + dcEdge(iEdge) * u(k,iEdge)
+ end do
+ end do
+ do iVertex=1,nVertices
+ do k=1,nVertLevels
+ vorticity(k,iVertex) = circulation(k,iVertex) / areaTriangle(iVertex)
+ end do
+ end do
+
+
+ !
+ ! Compute the divergence at each cell center
+ !
+ divergence(:,:) = 0.0
+ do iEdge=1,nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ if (cell1 <= nCells) then
+ do k=1,nVertLevels
+ divergence(k,cell1) = divergence(k,cell1) + u(k,iEdge)*dvEdge(iEdge)
+ enddo
+ endif
+ if(cell2 <= nCells) then
+ do k=1,nVertLevels
+ divergence(k,cell2) = divergence(k,cell2) - u(k,iEdge)*dvEdge(iEdge)
+ enddo
+ end if
+ end do
+ do iCell = 1,nCells
+ r = 1.0 / areaCell(iCell)
+ do k = 1,nVertLevels
+ divergence(k,iCell) = divergence(k,iCell) * r
+ enddo
+ enddo
+
+ !
+ ! Compute kinetic energy in each cell
+ !
+ ke(:,:) = 0.0
+ do iCell=1,nCells
+ do i=1,nEdgesOnCell(iCell)
+ iEdge = edgesOnCell(i,iCell)
+ do k=1,nVertLevels
+ ke(k,iCell) = ke(k,iCell) + 0.25 * dcEdge(iEdge) * dvEdge(iEdge) * u(k,iEdge)**2.0
+ end do
+ end do
+ do k=1,nVertLevels
+ ke(k,iCell) = ke(k,iCell) / areaCell(iCell)
+ end do
+ end do
+
+ !
+ ! Compute v (tangential) velocities
+ !
+ v(:,:) = 0.0
+ do iEdge = 1,nEdges
+ do i=1,nEdgesOnEdge(iEdge)
+ eoe = edgesOnEdge(i,iEdge)
+ do k = 1,nVertLevels
+ v(k,iEdge) = v(k,iEdge) + weightsOnEdge(i,iEdge) * u(k, eoe)
+ end do
+ end do
+ end do
+
+#ifdef NCAR_FORMULATION
+ !
+ ! Compute mass fluxes tangential to each edge (i.e., through the faces of dual grid cells)
+ !
+ vh(:,:) = 0.0
+ do iEdge=1,grid % nEdgesSolve
+ do j=1,nEdgesOnEdge(iEdge)
+ eoe = edgesOnEdge(j,iEdge)
+ do k=1,nVertLevels
+ vh(k,iEdge) = vh(k,iEdge) + weightsOnEdge(j,iEdge) * u(k,eoe) * h_edge(k,eoe)
+ end do
+ end do
+ end do
+#endif
+
+
+ !
+ ! Compute height at vertices, pv at vertices, and average pv to edge locations
+ ! ( this computes pv_vertex at all vertices bounding real cells and distance-1 ghost cells )
+ !
+ do iVertex = 1,nVertices
+ do k=1,nVertLevels
+ h_vertex(k,iVertex) = 0.0
+ do i=1,grid % vertexDegree
+ h_vertex(k,iVertex) = h_vertex(k,iVertex) + h(k,cellsOnVertex(i,iVertex)) * kiteAreasOnVertex(i,iVertex)
+ end do
+ h_vertex(k,iVertex) = h_vertex(k,iVertex) / areaTriangle(iVertex)
+
+ pv_vertex(k,iVertex) = (fVertex(iVertex) + vorticity(k,iVertex)) / h_vertex(k,iVertex)
+ end do
+ end do
+
+
+ !
+ ! Compute gradient of PV in the tangent direction
+ ! ( this computes gradPVt at all edges bounding real cells and distance-1 ghost cells )
+ !
+ do iEdge = 1,nEdges
+ do k = 1,nVertLevels
+ gradPVt(k,iEdge) = (pv_vertex(k,verticesOnEdge(2,iEdge)) - pv_vertex(k,verticesOnEdge(1,iEdge))) / &
+ dvEdge(iEdge)
+ enddo
+ enddo
+
+ !
+ ! Compute pv at the edges
+ ! ( this computes pv_edge at all edges bounding real cells )
+ !
+ pv_edge(:,:) = 0.0
+ do iVertex = 1,nVertices
+ do i=1,grid % vertexDegree
+ iEdge = edgesOnVertex(i,iVertex)
+ do k=1,nVertLevels
+ pv_edge(k,iEdge) = pv_edge(k,iEdge) + 0.5 * pv_vertex(k,iVertex)
+ end do
+ end do
+ end do
+
+
+ !
+ ! Modify PV edge with upstream bias.
+ !
+ do iEdge = 1,nEdges
+ do k = 1,nVertLevels
+ pv_edge(k,iEdge) = pv_edge(k,iEdge) - config_apvm_upwinding * v(k,iEdge) * dt * gradPVt(k,iEdge)
+ enddo
+ enddo
+
+
+ !
+ ! Compute pv at cell centers
+ ! ( this computes pv_cell for all real cells and distance-1 ghost cells )
+ !
+ pv_cell(:,:) = 0.0
+ vorticity_cell(:,:) = 0.0
+ do iVertex = 1, nVertices
+ do i=1,grid % vertexDegree
+ iCell = cellsOnVertex(i,iVertex)
+ if (iCell <= nCells) then
+ do k = 1,nVertLevels
+ pv_cell(k,iCell) = pv_cell(k,iCell) + kiteAreasOnVertex(i, iVertex) * pv_vertex(k, iVertex) / areaCell(iCell)
+ vorticity_cell(k,iCell) = vorticity_cell(k,iCell) + kiteAreasOnVertex(i, iVertex) * vorticity(k, iVertex) / areaCell(iCell)
+ enddo
+ endif
+ enddo
+ enddo
+
+
+ !
+ ! Compute gradient of PV in normal direction
+ ! ( this computes gradPVn for all edges bounding real cells )
+ !
+ gradPVn(:,:) = 0.0
+ do iEdge = 1,nEdges
+ if( cellsOnEdge(1,iEdge) <= nCells .and. cellsOnEdge(2,iEdge) <= nCells) then
+ do k = 1,nVertLevels
+ gradPVn(k,iEdge) = (pv_cell(k,cellsOnEdge(2,iEdge)) - pv_cell(k,cellsOnEdge(1,iEdge))) / &
+ dcEdge(iEdge)
+ enddo
+ endif
+ enddo
+
+ ! Modify PV edge with upstream bias.
+ !
+ do iEdge = 1,nEdges
+ do k = 1,nVertLevels
+ pv_edge(k,iEdge) = pv_edge(k,iEdge) - config_apvm_upwinding * u(k,iEdge) * dt * gradPVn(k,iEdge)
+ enddo
+ enddo
+
+ !
+ ! set pv_edge = fEdge / h_edge at boundary points
+ !
+ ! if (maxval(boundaryEdge).ge.0) then
+ ! do iEdge = 1,nEdges
+ ! cell1 = cellsOnEdge(1,iEdge)
+ ! cell2 = cellsOnEdge(2,iEdge)
+ ! do k = 1,nVertLevels
+ ! if(boundaryEdge(k,iEdge).eq.1) then
+ ! v(k,iEdge) = 0.0
+ ! if(cell1.gt.0) then
+ ! h1 = h(k,cell1)
+ ! pv_edge(k,iEdge) = fEdge(iEdge) / h1
+ ! h_edge(k,iEdge) = h1
+ ! else
+ ! h2 = h(k,cell2)
+ ! pv_edge(k,iEdge) = fEdge(iEdge) / h2
+ ! h_edge(k,iEdge) = h2
+ ! endif
+ ! endif
+ ! enddo
+ ! enddo
+ ! endif
+
+
+ end subroutine sw_compute_solve_diagnostics
+
+
+ subroutine sw_enforce_boundary_edge(tend, grid)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Enforce any boundary conditions on the normal velocity at each edge
+ !
+ ! Input: grid - grid metadata
+ !
+ ! Output: tend_u set to zero at boundaryEdge == 1 locations
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+ implicit none
+
+ type (tend_type), intent(inout) :: tend
+ type (mesh_type), intent(in) :: grid
+
+ integer, dimension(:,:), pointer :: boundaryEdge
+ real (kind=RKIND), dimension(:,:), pointer :: tend_u
+ integer :: nCells, nEdges, nVertices, nVertLevels
+ integer :: iEdge, k
+
+ nCells = grid % nCells
+ nEdges = grid % nEdges
+ nVertices = grid % nVertices
+ nVertLevels = grid % nVertLevels
+
+ boundaryEdge => grid % boundaryEdge % array
+ tend_u => tend % u % array
+
+ if(maxval(boundaryEdge).le.0) return
+
+ do iEdge = 1,nEdges
+ do k = 1,nVertLevels
+
+ if(boundaryEdge(k,iEdge).eq.1) then
+ tend_u(k,iEdge) = 0.0
+ endif
+
+ enddo
+ enddo
+
+ end subroutine sw_enforce_boundary_edge
+
+
+end module sw_time_integration
Modified: trunk/mpas/src/driver/Makefile
===================================================================
--- trunk/mpas/src/driver/Makefile 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/driver/Makefile 2011-10-21 19:18:00 UTC (rev 1114)
@@ -1,13 +1,13 @@
.SUFFIXES: .F .o
-OBJS = module_mpas_subdriver.o \
+OBJS = mpas_subdriver.o \
mpas.o
all: $(OBJS)
-module_mpas_subdriver.o:
+mpas_subdriver.o:
-mpas.o: module_mpas_subdriver.o
+mpas.o: mpas_subdriver.o
clean:
$(RM) *.o *.mod *.f90
Deleted: trunk/mpas/src/driver/module_mpas_subdriver.F
===================================================================
--- trunk/mpas/src/driver/module_mpas_subdriver.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/driver/module_mpas_subdriver.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -1,93 +0,0 @@
-module mpas_subdriver
-
- use mpas_framework
- use mpas_core
-
- type (dm_info), pointer :: dminfo
- type (domain_type), pointer :: domain
- type (io_output_object) :: output_obj
- integer :: output_frame
-
-
- contains
-
-
- subroutine mpas_init()
-
- implicit none
-
- real (kind=RKIND) :: dt
- character(len=32) :: timeStamp
-
- call timer_start("total time")
- call timer_start("initialize")
-
-
- !
- ! Initialize infrastructure
- !
- call mpas_framework_init(dminfo, domain)
-
-
- call input_state_for_domain(domain)
-
-
- !
- ! Initialize core
- !
- call mpas_core_init(domain, timeStamp)
-
- call timer_stop("initialize")
-
-
- !
- ! Set up output streams to be written to by the MPAS core
- !
- output_frame = 1
-
- if(config_frames_per_outfile > 0) then
- call output_state_init(output_obj, domain, "OUTPUT", trim(timeStamp))
- else
- call output_state_init(output_obj, domain, "OUTPUT")
- end if
-
-
- end subroutine mpas_init
-
-
- subroutine mpas_run()
-
- implicit none
-
- call mpas_core_run(domain, output_obj, output_frame)
-
- end subroutine mpas_run
-
-
- subroutine mpas_finalize()
-
- implicit none
-
- !
- ! Finalize output streams
- !
- call output_state_finalize(output_obj, domain % dminfo)
-
-
- !
- ! Finalize core
- !
- call mpas_core_finalize(domain)
-
- call timer_stop("total time")
- call timer_write()
-
-
- !
- ! Finalize infrastructure
- !
- call mpas_framework_finalize(dminfo, domain)
-
- end subroutine mpas_finalize
-
-end module mpas_subdriver
Copied: trunk/mpas/src/driver/mpas_subdriver.F (from rev 1113, branches/source_renaming/src/driver/mpas_subdriver.F)
===================================================================
--- trunk/mpas/src/driver/mpas_subdriver.F (rev 0)
+++ trunk/mpas/src/driver/mpas_subdriver.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -0,0 +1,93 @@
+module mpas_subdriver
+
+ use mpas_framework
+ use mpas_core
+
+ type (dm_info), pointer :: dminfo
+ type (domain_type), pointer :: domain
+ type (io_output_object) :: output_obj
+ integer :: output_frame
+
+
+ contains
+
+
+ subroutine mpas_init()
+
+ implicit none
+
+ real (kind=RKIND) :: dt
+ character(len=32) :: timeStamp
+
+ call mpas_timer_start("total time")
+ call mpas_timer_start("initialize")
+
+
+ !
+ ! Initialize infrastructure
+ !
+ call mpas_framework_init(dminfo, domain)
+
+
+ call mpas_input_state_for_domain(domain)
+
+
+ !
+ ! Initialize core
+ !
+ call mpas_core_init(domain, timeStamp)
+
+ call mpas_timer_stop("initialize")
+
+
+ !
+ ! Set up output streams to be written to by the MPAS core
+ !
+ output_frame = 1
+
+ if(config_frames_per_outfile > 0) then
+ call mpas_output_state_init(output_obj, domain, "OUTPUT", trim(timeStamp))
+ else
+ call mpas_output_state_init(output_obj, domain, "OUTPUT")
+ end if
+
+
+ end subroutine mpas_init
+
+
+ subroutine mpas_run()
+
+ implicit none
+
+ call mpas_core_run(domain, output_obj, output_frame)
+
+ end subroutine mpas_run
+
+
+ subroutine mpas_finalize()
+
+ implicit none
+
+ !
+ ! Finalize output streams
+ !
+ call mpas_output_state_finalize(output_obj, domain % dminfo)
+
+
+ !
+ ! Finalize core
+ !
+ call mpas_core_finalize(domain)
+
+ call mpas_timer_stop("total time")
+ call mpas_timer_write()
+
+
+ !
+ ! Finalize infrastructure
+ !
+ call mpas_framework_finalize(dminfo, domain)
+
+ end subroutine mpas_finalize
+
+end module mpas_subdriver
Modified: trunk/mpas/src/framework/Makefile
===================================================================
--- trunk/mpas/src/framework/Makefile 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/framework/Makefile 2011-10-21 19:18:00 UTC (rev 1114)
@@ -1,21 +1,21 @@
.SUFFIXES: .F .o
ifdef ZOLTAN_HOME
- ZOLTANOBJ = module_zoltan_interface.o
+ ZOLTANOBJ = mpas_zoltan_interface.o
endif
-OBJS = module_mpas_framework.o \
- module_timer.o \
- module_mpas_timekeeping.o \
- module_configure.o \
- module_constants.o \
- module_grid_types.o \
- module_hash.o \
- module_sort.o \
- module_block_decomp.o \
- module_dmpar.o \
- module_io_input.o \
- module_io_output.o \
+OBJS = mpas_framework.o \
+ mpas_timer.o \
+ mpas_timekeeping.o \
+ mpas_configure.o \
+ mpas_constants.o \
+ mpas_grid_types.o \
+ mpas_hash.o \
+ mpas_sort.o \
+ mpas_block_decomp.o \
+ mpas_dmpar.o \
+ mpas_io_input.o \
+ mpas_io_output.o \
$(ZOLTANOBJ) \
streams.o
@@ -24,19 +24,19 @@
framework: $(OBJS)
ar -ru libframework.a $(OBJS)
-module_mpas_framework.o: module_dmpar.o module_io_input.o module_io_output.o module_grid_types.o module_configure.o module_timer.o
+mpas_framework.o: mpas_dmpar.o mpas_io_input.o mpas_io_output.o mpas_grid_types.o mpas_configure.o mpas_timer.o
-module_configure.o: module_dmpar.o
+mpas_configure.o: mpas_dmpar.o
-module_grid_types.o: module_dmpar.o
+mpas_grid_types.o: mpas_dmpar.o
-module_dmpar.o: module_sort.o streams.o
+mpas_dmpar.o: mpas_sort.o streams.o
-module_block_decomp.o: module_grid_types.o module_hash.o module_configure.o
+mpas_block_decomp.o: mpas_grid_types.o mpas_hash.o mpas_configure.o
-module_io_input.o: module_grid_types.o module_dmpar.o module_block_decomp.o module_sort.o module_configure.o module_mpas_timekeeping.o $(ZOLTANOBJ)
+mpas_io_input.o: mpas_grid_types.o mpas_dmpar.o mpas_block_decomp.o mpas_sort.o mpas_configure.o mpas_timekeeping.o $(ZOLTANOBJ)
-module_io_output.o: module_grid_types.o module_dmpar.o module_sort.o module_configure.o
+mpas_io_output.o: mpas_grid_types.o mpas_dmpar.o mpas_sort.o mpas_configure.o
clean:
$(RM) *.o *.mod *.f90 libframework.a
Deleted: trunk/mpas/src/framework/module_block_decomp.F
===================================================================
--- trunk/mpas/src/framework/module_block_decomp.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/framework/module_block_decomp.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -1,306 +0,0 @@
-module block_decomp
-
- use dmpar
- use hash
-
- type graph
- integer :: nVerticesTotal
- integer :: nVertices, maxDegree
- integer :: ghostStart
- integer, dimension(:), pointer :: vertexID
- integer, dimension(:), pointer :: nAdjacent
- integer, dimension(:,:), pointer :: adjacencyList
- end type graph
-
-
- contains
-
-
- subroutine block_decomp_cells_for_proc(dminfo, partial_global_graph_info, local_cell_list)
-
- use configure
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
- type (graph), intent(in) :: partial_global_graph_info
- integer, dimension(:), pointer :: local_cell_list
-
- integer, dimension(:), pointer :: global_cell_list
- integer, dimension(:), pointer :: global_start
-
- integer :: i, j, owner, iunit, istatus
- integer, dimension(:), pointer :: local_nvertices
- character (len=256) :: filename
-
- if (dminfo % nprocs > 1) then
-
- allocate(local_nvertices(dminfo % nprocs))
- allocate(global_start(dminfo % nprocs))
- allocate(global_cell_list(partial_global_graph_info % nVerticesTotal))
-
- if (dminfo % my_proc_id == IO_NODE) then
-
- iunit = 50 + dminfo % my_proc_id
- if (dminfo % nprocs < 10) then
- write(filename,'(a,i1)') trim(config_decomp_file_prefix), dminfo % nprocs
- else if (dminfo % nprocs < 100) then
- write(filename,'(a,i2)') trim(config_decomp_file_prefix), dminfo % nprocs
- else if (dminfo % nprocs < 1000) then
- write(filename,'(a,i3)') trim(config_decomp_file_prefix), dminfo % nprocs
- else if (dminfo % nprocs < 10000) then
- write(filename,'(a,i4)') trim(config_decomp_file_prefix), dminfo % nprocs
- else if (dminfo % nprocs < 100000) then
- write(filename,'(a,i5)') trim(config_decomp_file_prefix), dminfo % nprocs
- end if
-
- open(unit=iunit, file=trim(filename), form='formatted', status='old', iostat=istatus)
-
- if (istatus /= 0) then
- write(0,*) 'Could not open block decomposition file for ',dminfo % nprocs,' tasks.'
- write(0,*) 'Filename: ',trim(filename)
- call dmpar_abort(dminfo)
- end if
-
- local_nvertices(:) = 0
- do i=1,partial_global_graph_info % nVerticesTotal
- read(unit=iunit, fmt=*) owner
- local_nvertices(owner+1) = local_nvertices(owner+1) + 1
- end do
-
-! allocate(global_cell_list(partial_global_graph_info % nVerticesTotal))
-
- global_start(1) = 1
- do i=2,dminfo % nprocs
- global_start(i) = global_start(i-1) + local_nvertices(i-1)
- end do
-
- rewind(unit=iunit)
-
- do i=1,partial_global_graph_info % nVerticesTotal
- read(unit=iunit, fmt=*) owner
- global_cell_list(global_start(owner+1)) = i
- global_start(owner+1) = global_start(owner+1) + 1
- end do
-
- global_start(1) = 0
- do i=2,dminfo % nprocs
- global_start(i) = global_start(i-1) + local_nvertices(i-1)
- end do
-
- close(unit=iunit)
-
- call dmpar_bcast_ints(dminfo, dminfo % nprocs, local_nvertices)
- allocate(local_cell_list(local_nvertices(dminfo % my_proc_id + 1)))
-
- call dmpar_scatter_ints(dminfo, dminfo % nprocs, local_nvertices(dminfo % my_proc_id + 1), &
- global_start, local_nvertices, global_cell_list, local_cell_list)
-
- else
-
- call dmpar_bcast_ints(dminfo, dminfo % nprocs, local_nvertices)
- allocate(local_cell_list(local_nvertices(dminfo % my_proc_id + 1)))
-
- call dmpar_scatter_ints(dminfo, dminfo % nprocs, local_nvertices(dminfo % my_proc_id + 1), &
- global_start, local_nvertices, global_cell_list, local_cell_list)
-
- end if
-
- deallocate(local_nvertices)
- deallocate(global_start)
- deallocate(global_cell_list)
- else
- allocate(local_cell_list(partial_global_graph_info % nVerticesTotal))
- do i=1,size(local_cell_list)
- local_cell_list(i) = i
- end do
- endif
-
- end subroutine block_decomp_cells_for_proc
-
-
- subroutine block_decomp_partitioned_edge_list(nCells, cellIDList, maxCells, nEdges, cellsOnEdge, edgeIDList, ghostEdgeStart)
-
- implicit none
-
- integer, intent(in) :: nCells, maxCells, nEdges
- integer, dimension(nCells), intent(in) :: cellIDList
- integer, dimension(maxCells, nEdges), intent(in) :: cellsOnEdge
- integer, dimension(nEdges), intent(inout) :: edgeIDList
- integer, intent(inout) :: ghostEdgeStart
-
- integer :: i, j, lastEdge
- integer, dimension(nEdges) :: edgeIDListLocal
- type (hashtable) :: h
-
- call hash_init(h)
-
- do i=1,nCells
- ! OPTIMIZATION: Actually, if we can assume that all cellIDs are unique, the if-test is unnecessary
- if (.not. hash_search(h, cellIDList(i))) call hash_insert(h, cellIDList(i))
- end do
-
- lastEdge = 0
- ghostEdgeStart = nEdges+1
-
- edgeIDListLocal(:) = edgeIDList(:)
-
- do i=1,nEdges
- do j=1,maxCells
- if (cellsOnEdge(j,i) /= 0) exit
- end do
- if (j > maxCells) &
- write(0,*) 'Error in block_decomp_partitioned_edge_list: ',&
- 'edge/vertex is not adjacent to any valid cells'
- if (hash_search(h, cellsOnEdge(j,i))) then
- lastEdge = lastEdge + 1
- edgeIDList(lastEdge) = edgeIDListLocal(i)
- else
- ghostEdgeStart = ghostEdgeStart - 1
- edgeIDList(ghostEdgeStart) = edgeIDListLocal(i)
- end if
- if (ghostEdgeStart <= lastEdge) then
- write(0,*) 'block_decomp_partitioned_edge_list: ',&
- 'Somehow we have more edges than we thought we should.'
- end if
- end do
-
- if (ghostEdgeStart /= lastEdge + 1) then
- write(0,*) 'block_decomp_partitioned_edge_list:',&
- ' Somehow we didn''t have enough edges to fill edgeIDList.'
- end if
-
- call hash_destroy(h)
-
- end subroutine block_decomp_partitioned_edge_list
-
-
- subroutine block_decomp_all_edges_in_block(maxEdges, nCells, nEdgesOnCell, edgesOnCell, nEdges, edgeList)
-
- implicit none
-
- integer, intent(in) :: maxEdges, nCells
- integer, dimension(nCells), intent(in) :: nEdgesOnCell
- integer, dimension(maxEdges, nCells), intent(in) :: edgesOnCell
- integer, intent(out) :: nEdges
- integer, dimension(:), pointer :: edgeList
-
- integer :: i, j, k
- type (hashtable) :: h
-
- call hash_init(h)
-
- do i=1,nCells
- do j=1,nEdgesOnCell(i)
- if (.not. hash_search(h, edgesOnCell(j,i))) call hash_insert(h, edgesOnCell(j,i))
- end do
- end do
-
- nEdges = hash_size(h)
- allocate(edgeList(nEdges))
-
- call hash_destroy(h)
-
- call hash_init(h)
-
- k = 0
- do i=1,nCells
- do j=1,nEdgesOnCell(i)
- if (.not. hash_search(h, edgesOnCell(j,i))) then
- k = k + 1
- if (k > nEdges) then
- write(0,*) 'block_decomp_all_edges_in_block: ',&
- 'Trying to add more edges than expected.'
- return
- end if
- edgeList(k) = edgesOnCell(j,i)
- call hash_insert(h, edgesOnCell(j,i))
- end if
- end do
- end do
-
- call hash_destroy(h)
-
- if (k < nEdges) then
- write(0,*) 'block_decomp_all_edges_in_block: ',&
- 'Listed fewer edges than expected.'
- end if
-
- end subroutine block_decomp_all_edges_in_block
-
-
- subroutine block_decomp_add_halo(dminfo, local_graph_info, local_graph_with_halo)
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
- type (graph), intent(in) :: local_graph_info
- type (graph), intent(out) :: local_graph_with_halo
-
- integer :: i, j, k
- type (hashtable) :: h
-
-
- call hash_init(h)
-
- do i=1,local_graph_info % nVertices
- call hash_insert(h, local_graph_info % vertexID(i))
- end do
-
- do i=1,local_graph_info % nVertices
- do j=1,local_graph_info % nAdjacent(i)
- if (local_graph_info % adjacencyList(j,i) /= 0) then
- if (.not. hash_search(h, local_graph_info % adjacencyList(j,i))) then
- call hash_insert(h, local_graph_info % adjacencyList(j,i))
- end if
- end if
- end do
- end do
-
-
- local_graph_with_halo % nVertices = local_graph_info % nVertices
- local_graph_with_halo % maxDegree = local_graph_info % maxDegree
- local_graph_with_halo % nVerticesTotal = hash_size(h)
- local_graph_with_halo % ghostStart = local_graph_with_halo % nVertices + 1
- allocate(local_graph_with_halo % vertexID(local_graph_with_halo % nVerticesTotal))
- allocate(local_graph_with_halo % nAdjacent(local_graph_with_halo % nVerticesTotal))
- allocate(local_graph_with_halo % adjacencyList(local_graph_with_halo % maxDegree, local_graph_with_halo % nVerticesTotal))
-
- call hash_destroy(h)
-
- call hash_init(h)
-
- do i=1,local_graph_info % nVertices
- if (hash_search(h, local_graph_info % vertexID(i))) &
- write(0,*) 'block_decomp_add_halo: ', &
- 'There appear to be duplicates in vertexID list.'
- call hash_insert(h, local_graph_info % vertexID(i))
- local_graph_with_halo % vertexID(i) = local_graph_info % vertexID(i)
- local_graph_with_halo % nAdjacent(i) = local_graph_info % nAdjacent(i)
- local_graph_with_halo % adjacencyList(:,i) = local_graph_info % adjacencyList(:,i)
- end do
-
- k = local_graph_with_halo % ghostStart
- if (hash_size(h) /= k-1) &
- write(0,*) 'block_decomp_add_halo: ',&
- 'Somehow we don''t have the right number of non-ghost cells.'
- do i=1,local_graph_info % nVertices
- do j=1,local_graph_info % nAdjacent(i)
- if (local_graph_info % adjacencyList(j,i) /= 0) then
- if (.not. hash_search(h, local_graph_info % adjacencyList(j,i))) then
- call hash_insert(h, local_graph_info % adjacencyList(j,i))
- local_graph_with_halo % vertexID(k) = local_graph_info % adjacencyList(j,i)
- k = k + 1
- end if
- end if
- end do
- end do
- if (local_graph_with_halo % nVerticesTotal /= k-1) &
- write(0,*) 'block_decomp_add_halo: ',&
- 'Somehow we don''t have the right number of total cells.'
-
- call hash_destroy(h)
-
- end subroutine block_decomp_add_halo
-
-end module block_decomp
Deleted: trunk/mpas/src/framework/module_configure.F
===================================================================
--- trunk/mpas/src/framework/module_configure.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/framework/module_configure.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -1,36 +0,0 @@
-module configure
-
- use dmpar
-
-#include "config_defs.inc"
-
- contains
-
-
- subroutine read_namelist(dminfo)
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
-
- integer :: funit
-
-#include "config_namelist_defs.inc"
-
- funit = 21
-
- ! Set default values for namelist options
-#include "config_set_defaults.inc"
-
- if (dminfo % my_proc_id == IO_NODE) then
- open(funit,file='namelist.input',status='old',form='formatted')
-
-#include "config_namelist_reads.inc"
- close(funit)
- end if
-
-#include "config_bcast_namelist.inc"
-
- end subroutine read_namelist
-
-end module configure
Deleted: trunk/mpas/src/framework/module_constants.F
===================================================================
--- trunk/mpas/src/framework/module_constants.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/framework/module_constants.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -1,20 +0,0 @@
-module constants
-
- real (kind=RKIND), parameter :: pii = 3.141592653589793
- real (kind=RKIND), parameter :: a = 6371229.0
- real (kind=RKIND), parameter :: omega = 7.29212e-5
- real (kind=RKIND), parameter :: gravity = 9.80616
- real (kind=RKIND), parameter :: rgas = 287.
- real (kind=RKIND), parameter :: cp = 1003.
- real (kind=RKIND), parameter :: cv = 716. ! cp - rgas
- real (kind=RKIND), parameter :: cvpm = -.71385842 ! -cv/cp
- real (kind=RKIND), parameter :: prandtl = 1.0
-
-
- contains
-
- subroutine dummy()
-
- end subroutine dummy
-
-end module constants
Deleted: trunk/mpas/src/framework/module_dmpar.F
===================================================================
--- trunk/mpas/src/framework/module_dmpar.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/framework/module_dmpar.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -1,1928 +0,0 @@
-module dmpar
-
- use sort
-
-#ifdef _MPI
-include 'mpif.h'
- integer, parameter :: MPI_INTEGERKIND = MPI_INTEGER
-
-#if (RKIND == 8)
- integer, parameter :: MPI_REALKIND = MPI_DOUBLE_PRECISION
-#else
- integer, parameter :: MPI_REALKIND = MPI_REAL
-#endif
-#endif
-
- integer, parameter :: IO_NODE = 0
- integer, parameter :: BUFSIZE = 6000
-
-
- type dm_info
- integer :: nprocs, my_proc_id, comm, info
- end type dm_info
-
-
- type exchange_list
- integer :: procID
- integer :: nlist
- integer, dimension(:), pointer :: list
- type (exchange_list), pointer :: next
- real (kind=RKIND), dimension(:), pointer :: rbuffer
- integer, dimension(:), pointer :: ibuffer
- integer :: reqID
- end type exchange_list
-
-
- interface dmpar_alltoall_field
- module procedure dmpar_alltoall_field1dInteger
- module procedure dmpar_alltoall_field2dInteger
- module procedure dmpar_alltoall_field1dReal
- module procedure dmpar_alltoall_field2dReal
- module procedure dmpar_alltoall_field3dReal
- end interface
-
-
- contains
-
-
- subroutine dmpar_init(dminfo)
-
- implicit none
-
- type (dm_info), intent(inout) :: dminfo
-
-#ifdef _MPI
- integer :: mpi_rank, mpi_size
- integer :: mpi_ierr
-
- ! Find out our rank and the total number of processors
- call MPI_Init(mpi_ierr)
- call MPI_Comm_rank(MPI_COMM_WORLD, mpi_rank, mpi_ierr)
- call MPI_Comm_size(MPI_COMM_WORLD, mpi_size, mpi_ierr)
-
- dminfo % comm = MPI_COMM_WORLD
-
- dminfo % nprocs = mpi_size
- dminfo % my_proc_id = mpi_rank
-
- write(0,'(a,i5,a,i5,a)') 'task ', mpi_rank, ' of ', mpi_size, &
- ' is running'
-
- call open_streams(dminfo % my_proc_id)
-
- dminfo % info = MPI_INFO_NULL
-#else
- dminfo % comm = 0
- dminfo % my_proc_id = IO_NODE
- dminfo % nprocs = 1
-#endif
-
- end subroutine dmpar_init
-
-
- subroutine dmpar_finalize(dminfo)
-
- implicit none
-
- type (dm_info), intent(inout) :: dminfo
-
-#ifdef _MPI
- integer :: mpi_ierr
-
- call MPI_Finalize(mpi_ierr)
-#endif
-
- end subroutine dmpar_finalize
-
-
- subroutine dmpar_abort(dminfo)
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
-
-#ifdef _MPI
- integer :: mpi_ierr, mpi_errcode
-
- call MPI_Abort(dminfo % comm, mpi_errcode, mpi_ierr)
-#endif
-
- stop
-
- end subroutine dmpar_abort
-
-
- subroutine dmpar_global_abort(mesg)
-
- implicit none
-
- character (len=*), intent(in) :: mesg
-
-#ifdef _MPI
- integer :: mpi_ierr, mpi_errcode
-
- write(0,*) trim(mesg)
- call MPI_Abort(MPI_COMM_WORLD, mpi_errcode, mpi_ierr)
-#endif
-
- write(0,*) trim(mesg)
- stop
-
- end subroutine dmpar_global_abort
-
-
- subroutine dmpar_bcast_int(dminfo, i)
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
- integer, intent(inout) :: i
-
-#ifdef _MPI
- integer :: mpi_ierr
-
- call MPI_Bcast(i, 1, MPI_INTEGERKIND, IO_NODE, dminfo % comm, mpi_ierr)
-#endif
-
- end subroutine dmpar_bcast_int
-
-
- subroutine dmpar_bcast_ints(dminfo, n, iarray)
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: n
- integer, dimension(n), intent(inout) :: iarray
-
-#ifdef _MPI
- integer :: mpi_ierr
-
- call MPI_Bcast(iarray, n, MPI_INTEGERKIND, IO_NODE, dminfo % comm, mpi_ierr)
-#endif
-
- end subroutine dmpar_bcast_ints
-
-
- subroutine dmpar_bcast_real(dminfo, r)
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
- real (kind=RKIND), intent(inout) :: r
-
-#ifdef _MPI
- integer :: mpi_ierr
-
- call MPI_Bcast(r, 1, MPI_REALKIND, IO_NODE, dminfo % comm, mpi_ierr)
-#endif
-
- end subroutine dmpar_bcast_real
-
-
- subroutine dmpar_bcast_reals(dminfo, n, rarray)
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: n
- real (kind=RKIND), dimension(n), intent(inout) :: rarray
-
-#ifdef _MPI
- integer :: mpi_ierr
-
- call MPI_Bcast(rarray, n, MPI_REALKIND, IO_NODE, dminfo % comm, mpi_ierr)
-#endif
-
- end subroutine dmpar_bcast_reals
-
-
- subroutine dmpar_bcast_logical(dminfo, l)
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
- logical, intent(inout) :: l
-
-#ifdef _MPI
- integer :: mpi_ierr
- integer :: itemp
-
- if (dminfo % my_proc_id == IO_NODE) then
- if (l) then
- itemp = 1
- else
- itemp = 0
- end if
- end if
-
- call MPI_Bcast(itemp, 1, MPI_INTEGERKIND, IO_NODE, dminfo % comm, mpi_ierr)
-
- if (itemp == 1) then
- l = .true.
- else
- l = .false.
- end if
-#endif
-
- end subroutine dmpar_bcast_logical
-
-
- subroutine dmpar_bcast_char(dminfo, c)
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
- character (len=*), intent(inout) :: c
-
-#ifdef _MPI
- integer :: mpi_ierr
-
- call MPI_Bcast(c, len(c), MPI_CHARACTER, IO_NODE, dminfo % comm, mpi_ierr)
-#endif
-
- end subroutine dmpar_bcast_char
-
-
- subroutine dmpar_sum_int(dminfo, i, isum)
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: i
- integer, intent(out) :: isum
-
- integer :: mpi_ierr
-
-#ifdef _MPI
- call MPI_Allreduce(i, isum, 1, MPI_INTEGERKIND, MPI_SUM, dminfo % comm, mpi_ierr)
-#else
- isum = i
-#endif
-
- end subroutine dmpar_sum_int
-
-
- subroutine dmpar_sum_real(dminfo, r, rsum)
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
- real(kind=RKIND), intent(in) :: r
- real(kind=RKIND), intent(out) :: rsum
-
- integer :: mpi_ierr
-
-#ifdef _MPI
- call MPI_Allreduce(r, rsum, 1, MPI_REALKIND, MPI_SUM, dminfo % comm, mpi_ierr)
-#else
- rsum = r
-#endif
-
- end subroutine dmpar_sum_real
-
-
- subroutine dmpar_min_int(dminfo, i, imin)
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: i
- integer, intent(out) :: imin
-
- integer :: mpi_ierr
-
-#ifdef _MPI
- call MPI_Allreduce(i, imin, 1, MPI_INTEGERKIND, MPI_MIN, dminfo % comm, mpi_ierr)
-#else
- imin = i
-#endif
-
- end subroutine dmpar_min_int
-
-
- subroutine dmpar_min_real(dminfo, r, rmin)
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
- real(kind=RKIND), intent(in) :: r
- real(kind=RKIND), intent(out) :: rmin
-
- integer :: mpi_ierr
-
-#ifdef _MPI
- call MPI_Allreduce(r, rmin, 1, MPI_REALKIND, MPI_MIN, dminfo % comm, mpi_ierr)
-#else
- rmin = r
-#endif
-
- end subroutine dmpar_min_real
-
-
- subroutine dmpar_max_int(dminfo, i, imax)
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: i
- integer, intent(out) :: imax
-
- integer :: mpi_ierr
-
-#ifdef _MPI
- call MPI_Allreduce(i, imax, 1, MPI_INTEGERKIND, MPI_MAX, dminfo % comm, mpi_ierr)
-#else
- imax = i
-#endif
-
- end subroutine dmpar_max_int
-
-
- subroutine dmpar_max_real(dminfo, r, rmax)
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
- real(kind=RKIND), intent(in) :: r
- real(kind=RKIND), intent(out) :: rmax
-
- integer :: mpi_ierr
-
-#ifdef _MPI
- call MPI_Allreduce(r, rmax, 1, MPI_REALKIND, MPI_MAX, dminfo % comm, mpi_ierr)
-#else
- rmax = r
-#endif
-
- end subroutine dmpar_max_real
-
-
- subroutine dmpar_sum_int_array(dminfo, nElements, inArray, outArray)
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: nElements
- integer, dimension(nElements), intent(in) :: inArray
- integer, dimension(nElements), intent(out) :: outArray
-
- integer :: mpi_ierr
-
-#ifdef _MPI
- call MPI_Allreduce(inArray, outArray, nElements, MPI_INTEGERKIND, MPI_SUM, dminfo % comm, mpi_ierr)
-#else
- outArray = inArray
-#endif
-
- end subroutine dmpar_sum_int_array
-
-
- subroutine dmpar_min_int_array(dminfo, nElements, inArray, outArray)
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: nElements
- integer, dimension(nElements), intent(in) :: inArray
- integer, dimension(nElements), intent(out) :: outArray
-
- integer :: mpi_ierr
-
-#ifdef _MPI
- call MPI_Allreduce(inArray, outArray, nElements, MPI_INTEGERKIND, MPI_MIN, dminfo % comm, mpi_ierr)
-#else
- outArray = inArray
-#endif
-
- end subroutine dmpar_min_int_array
-
-
- subroutine dmpar_max_int_array(dminfo, nElements, inArray, outArray)
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: nElements
- integer, dimension(nElements), intent(in) :: inArray
- integer, dimension(nElements), intent(out) :: outArray
-
- integer :: mpi_ierr
-
-#ifdef _MPI
- call MPI_Allreduce(inArray, outArray, nElements, MPI_INTEGERKIND, MPI_MAX, dminfo % comm, mpi_ierr)
-#else
- outArray = inArray
-#endif
-
- end subroutine dmpar_max_int_array
-
-
- subroutine dmpar_sum_real_array(dminfo, nElements, inArray, outArray)
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: nElements
- real(kind=RKIND), dimension(nElements), intent(in) :: inArray
- real(kind=RKIND), dimension(nElements), intent(out) :: outArray
-
- integer :: mpi_ierr
-
-#ifdef _MPI
- call MPI_Allreduce(inArray, outArray, nElements, MPI_REALKIND, MPI_SUM, dminfo % comm, mpi_ierr)
-#else
- outArray = inArray
-#endif
-
- end subroutine dmpar_sum_real_array
-
-
- subroutine dmpar_min_real_array(dminfo, nElements, inArray, outArray)
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: nElements
- real(kind=RKIND), dimension(nElements), intent(in) :: inArray
- real(kind=RKIND), dimension(nElements), intent(out) :: outArray
-
- integer :: mpi_ierr
-
-#ifdef _MPI
- call MPI_Allreduce(inArray, outArray, nElements, MPI_REALKIND, MPI_MIN, dminfo % comm, mpi_ierr)
-#else
- outArray = inArray
-#endif
-
- end subroutine dmpar_min_real_array
-
-
- subroutine dmpar_max_real_array(dminfo, nElements, inArray, outArray)
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: nElements
- real(kind=RKIND), dimension(nElements), intent(in) :: inArray
- real(kind=RKIND), dimension(nElements), intent(out) :: outArray
-
- integer :: mpi_ierr
-
-#ifdef _MPI
- call MPI_Allreduce(inArray, outArray, nElements, MPI_REALKIND, MPI_MAX, dminfo % comm, mpi_ierr)
-#else
- outArray = inArray
-#endif
-
- end subroutine dmpar_max_real_array
-
-
- subroutine dmpar_scatter_ints(dminfo, nprocs, noutlist, displs, counts, inlist, outlist)
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: nprocs, noutlist
- integer, dimension(nprocs), intent(in) :: displs, counts
- integer, dimension(:), pointer :: inlist
- integer, dimension(noutlist), intent(inout) :: outlist
-
-#ifdef _MPI
- integer :: mpi_ierr
-
- call MPI_Scatterv(inlist, counts, displs, MPI_INTEGERKIND, outlist, noutlist, MPI_INTEGERKIND, IO_NODE, dminfo % comm, mpi_ierr)
-#endif
-
- end subroutine dmpar_scatter_ints
-
-
- subroutine dmpar_get_index_range(dminfo, &
- global_start, global_end, &
- local_start, local_end)
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: global_start, global_end
- integer, intent(out) :: local_start, local_end
-
- local_start = nint(real(dminfo % my_proc_id) * real(global_end - global_start + 1) / real(dminfo % nprocs)) + 1
- local_end = nint(real(dminfo % my_proc_id + 1) * real(global_end - global_start + 1) / real(dminfo % nprocs))
-
- end subroutine dmpar_get_index_range
-
-
- subroutine dmpar_compute_index_range(dminfo, &
- local_start, local_end, &
- global_start, global_end)
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: local_start, local_end
- integer, intent(inout) :: global_start, global_end
-
- integer :: n
- integer :: mpi_ierr
-
- n = local_end - local_start + 1
-
- if (dminfo % my_proc_id == 0) then
- global_start = 1
- global_end = global_start + n - 1
-
-#ifdef _MPI
- else if (dminfo % my_proc_id == dminfo % nprocs - 1) then
- call MPI_Recv(global_start, 1, MPI_INTEGERKIND, dminfo % my_proc_id - 1, 0, dminfo % comm, MPI_STATUS_IGNORE, mpi_ierr)
- global_end = global_start + n - 1
-
- else
- call MPI_Recv(global_start, 1, MPI_INTEGERKIND, dminfo % my_proc_id - 1, 0, dminfo % comm, MPI_STATUS_IGNORE, mpi_ierr)
- global_end = global_start + n
- call MPI_Send(global_end, 1, MPI_INTEGERKIND, dminfo % my_proc_id + 1, 0, dminfo % comm, mpi_ierr)
- global_end = global_end - 1
-#endif
-
- end if
-
-
- end subroutine dmpar_compute_index_range
-
-
- subroutine dmpar_get_owner_list(dminfo, &
- nOwnedList, nNeededList, &
- ownedList, neededList, &
- sendList, recvList)
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: nOwnedList, nNeededList
- integer, dimension(nOwnedList), intent(in) :: ownedList
- integer, dimension(nNeededList), intent(in) :: neededList
- type (exchange_list), pointer :: sendList
- type (exchange_list), pointer :: recvList
-
- integer :: i, j, k, kk
- integer :: totalSize, nMesgRecv, nMesgSend, recvNeighbor, sendNeighbor, currentProc
- integer :: numToSend, numToRecv
- integer, dimension(nOwnedList) :: recipientList
- integer, dimension(2,nOwnedList) :: ownedListSorted
- integer, allocatable, dimension(:) :: ownerListIn, ownerListOut
- type (exchange_list), pointer :: sendListPtr, recvListPtr
- integer :: mpi_ierr, mpi_rreq, mpi_sreq
-
-#ifdef _MPI
- allocate(sendList)
- allocate(recvList)
- nullify(sendList % next)
- nullify(recvList % next)
- sendListPtr => sendList
- recvListPtr => recvList
-
- do i=1,nOwnedList
- ownedListSorted(1,i) = ownedList(i)
- ownedListSorted(2,i) = i
- end do
- call quicksort(nOwnedList, ownedListSorted)
-
- call MPI_Allreduce(nNeededList, totalSize, 1, MPI_INTEGERKIND, MPI_MAX, dminfo % comm, mpi_ierr)
-
- allocate(ownerListIn(totalSize))
- allocate(ownerListOut(totalSize))
-
- nMesgRecv = nNeededList
- ownerListIn(1:nNeededList) = neededList(1:nNeededList)
-
- recvNeighbor = mod(dminfo % my_proc_id + dminfo % nprocs - 1, dminfo % nprocs)
- sendNeighbor = mod(dminfo % my_proc_id + 1, dminfo % nprocs)
-
- do i=1, dminfo % nprocs
-
- recipientList(:) = -1
- numToSend = 0
-
- currentProc = mod(dminfo % my_proc_id + dminfo % nprocs - i + 1, dminfo % nprocs)
- do j=1,nMesgRecv
- if (ownerListIn(j) > 0) then
- k = binary_search(ownedListSorted, 2, 1, nOwnedList, ownerListIn(j))
- if (k <= nOwnedList) then
- ownerListOut(j) = -1 * dminfo % my_proc_id
- numToSend = numToSend + 1
- recipientList(ownedListSorted(2,k)) = numToSend
- else
- ownerListOut(j) = ownerListIn(j)
- end if
- else
- ownerListOut(j) = ownerListIn(j)
- end if
- end do
-
- if (numToSend > 0) then
- allocate(sendListPtr % next)
- sendListPtr => sendListPtr % next
- sendListPtr % procID = currentProc
- sendListPtr % nlist = numToSend
- allocate(sendListPtr % list(numToSend))
- nullify(sendListPtr % next)
- kk = 1
- do j=1,nOwnedList
- if (recipientList(j) /= -1) then
- sendListPtr % list(recipientList(j)) = j
- kk = kk + 1
- end if
- end do
- end if
-
- nMesgSend = nMesgRecv
- call MPI_Irecv(nMesgRecv, 1, MPI_INTEGERKIND, recvNeighbor, i, dminfo % comm, mpi_rreq, mpi_ierr)
- call MPI_Isend(nMesgSend, 1, MPI_INTEGERKIND, sendNeighbor, i, dminfo % comm, mpi_sreq, mpi_ierr)
- call MPI_Wait(mpi_rreq, MPI_STATUS_IGNORE, mpi_ierr)
- call MPI_Wait(mpi_sreq, MPI_STATUS_IGNORE, mpi_ierr)
- call MPI_Irecv(ownerListIn, nMesgRecv, MPI_INTEGERKIND, recvNeighbor, i, dminfo % comm, mpi_rreq, mpi_ierr)
- call MPI_Isend(ownerListOut, nMesgSend, MPI_INTEGERKIND, sendNeighbor, i, dminfo % comm, mpi_sreq, mpi_ierr)
- call MPI_Wait(mpi_rreq, MPI_STATUS_IGNORE, mpi_ierr)
- call MPI_Wait(mpi_sreq, MPI_STATUS_IGNORE, mpi_ierr)
- end do
-
- do i=0, dminfo % nprocs - 1
-
- numToRecv = 0
- do j=1,nNeededList
- if (ownerListIn(j) == -i) numToRecv = numToRecv + 1
- end do
- if (numToRecv > 0) then
- allocate(recvListPtr % next)
- recvListPtr => recvListPtr % next
- recvListPtr % procID = i
- recvListPtr % nlist = numToRecv
- allocate(recvListPtr % list(numToRecv))
- nullify(recvListPtr % next)
- kk = 1
- do j=1,nNeededList
- if (ownerListIn(j) == -i) then
- recvListPtr % list(kk) = j
- kk = kk + 1
- end if
- end do
- end if
-
- end do
-
- deallocate(ownerListIn)
- deallocate(ownerListOut)
-
- sendListPtr => sendList
- sendList => sendList % next
- deallocate(sendListPtr)
-
- recvListPtr => recvList
- recvList => recvList % next
- deallocate(recvListPtr)
-
-#else
- allocate(recvList)
- recvList % procID = dminfo % my_proc_id
- recvList % nlist = nNeededList
- allocate(recvList % list(nNeededList))
- nullify(recvList % next)
- do j=1,nNeededList
- recvList % list(j) = j
- end do
-
- allocate(sendList)
- sendList % procID = dminfo % my_proc_id
- sendList % nlist = nOwnedList
- allocate(sendList % list(nOwnedList))
- nullify(sendList % next)
- do j=1,nOwnedList
- sendList % list(j) = j
- end do
-#endif
-
- end subroutine dmpar_get_owner_list
-
-
- subroutine dmpar_alltoall_field1dInteger(dminfo, arrayIn, arrayOut, nOwnedList, nNeededList, sendList, recvList)
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
- integer, dimension(*), intent(in) :: arrayIn
- integer, dimension(*), intent(inout) :: arrayOut
- integer, intent(in) :: nOwnedList, nNeededList
- type (exchange_list), pointer :: sendList, recvList
-
- type (exchange_list), pointer :: sendListPtr, recvListPtr
- integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
- integer :: mpi_ierr
- integer :: i
-
-#ifdef _MPI
-
- sendListPtr => sendList
- do while (associated(sendListPtr))
- if (sendListPtr % procID == dminfo % my_proc_id) exit
- sendListPtr => sendListPtr % next
- end do
-
- recvListPtr => recvList
- do while (associated(recvListPtr))
- if (recvListPtr % procID == dminfo % my_proc_id) exit
- recvListPtr => recvListPtr % next
- end do
-
- if (associated(recvListPtr) .and. associated(sendListPtr)) then
- do i=1,recvListPtr % nlist
- arrayOut(recvListPtr % list(i)) = arrayIn(sendListPtr % list(i))
- end do
- end if
-
- recvListPtr => recvList
- do while (associated(recvListPtr))
- if (recvListPtr % procID /= dminfo % my_proc_id) then
- allocate(recvListPtr % ibuffer(recvListPtr % nlist))
- call MPI_Irecv(recvListPtr % ibuffer, recvListPtr % nlist, MPI_INTEGERKIND, &
- recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
- end if
- recvListPtr => recvListPtr % next
- end do
-
- sendListPtr => sendList
- do while (associated(sendListPtr))
- if (sendListPtr % procID /= dminfo % my_proc_id) then
- allocate(sendListPtr % ibuffer(sendListPtr % nlist))
- call packSendBuf1dInteger(nOwnedList, arrayIn, sendListPtr, 1, sendListPtr % nlist, &
- sendListPtr % ibuffer, nPacked, lastPackedIdx)
- call MPI_Isend(sendListPtr % ibuffer, sendListPtr % nlist, MPI_INTEGERKIND, &
- sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
- end if
- sendListPtr => sendListPtr % next
- end do
-
- recvListPtr => recvList
- do while (associated(recvListPtr))
- if (recvListPtr % procID /= dminfo % my_proc_id) then
- call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- call unpackRecvBuf1dInteger(nNeededList, arrayOut, recvListPtr, 1, recvListPtr % nlist, &
- recvListPtr % ibuffer, nUnpacked, lastUnpackedIdx)
- deallocate(recvListPtr % ibuffer)
- end if
- recvListPtr => recvListPtr % next
- end do
-
- sendListPtr => sendList
- do while (associated(sendListPtr))
- if (sendListPtr % procID /= dminfo % my_proc_id) then
- call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- deallocate(sendListPtr % ibuffer)
- end if
- sendListPtr => sendListPtr % next
- end do
-
-#else
- if (nOwnedList /= nNeededList) then
- write(0,*) 'Error in dmpar_alltoall_field: For non-dmpar, ', &
- 'arrayIn and arrayOut dims must match.'
- call dmpar_abort(dminfo)
- else
- arrayOut(1:nNeededList) = arrayIn(1:nOwnedList)
- end if
-#endif
-
- end subroutine dmpar_alltoall_field1dInteger
-
-
- subroutine dmpar_alltoall_field2dInteger(dminfo, arrayIn, arrayOut, dim1, nOwnedList, nNeededList, sendList, recvList)
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: dim1, nOwnedList, nNeededList
- integer, dimension(dim1,*), intent(in) :: arrayIn
- integer, dimension(dim1,*), intent(inout) :: arrayOut
- type (exchange_list), pointer :: sendList, recvList
-
- type (exchange_list), pointer :: sendListPtr, recvListPtr
- integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
- integer :: mpi_ierr
- integer :: i, d2
-
-#ifdef _MPI
-
- sendListPtr => sendList
- do while (associated(sendListPtr))
- if (sendListPtr % procID == dminfo % my_proc_id) exit
- sendListPtr => sendListPtr % next
- end do
-
- recvListPtr => recvList
- do while (associated(recvListPtr))
- if (recvListPtr % procID == dminfo % my_proc_id) exit
- recvListPtr => recvListPtr % next
- end do
-
- if (associated(recvListPtr) .and. associated(sendListPtr)) then
- do i=1,recvListPtr % nlist
- arrayOut(:,recvListPtr % list(i)) = arrayIn(:,sendListPtr % list(i))
- end do
- end if
-
- recvListPtr => recvList
- do while (associated(recvListPtr))
- if (recvListPtr % procID /= dminfo % my_proc_id) then
- d2 = dim1 * recvListPtr % nlist
- allocate(recvListPtr % ibuffer(d2))
- call MPI_Irecv(recvListPtr % ibuffer, d2, MPI_INTEGERKIND, &
- recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
- end if
- recvListPtr => recvListPtr % next
- end do
-
- sendListPtr => sendList
- do while (associated(sendListPtr))
- if (sendListPtr % procID /= dminfo % my_proc_id) then
- d2 = dim1 * sendListPtr % nlist
- allocate(sendListPtr % ibuffer(d2))
- call packSendBuf2dInteger(1, dim1, nOwnedList, arrayIn, sendListPtr, 1, d2, &
- sendListPtr % ibuffer, nPacked, lastPackedIdx)
- call MPI_Isend(sendListPtr % ibuffer, d2, MPI_INTEGERKIND, &
- sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
- end if
- sendListPtr => sendListPtr % next
- end do
-
- recvListPtr => recvList
- do while (associated(recvListPtr))
- if (recvListPtr % procID /= dminfo % my_proc_id) then
- call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- d2 = dim1 * recvListPtr % nlist
- call unpackRecvBuf2dInteger(1, dim1, nNeededList, arrayOut, recvListPtr, 1, d2, &
- recvListPtr % ibuffer, nUnpacked, lastUnpackedIdx)
- deallocate(recvListPtr % ibuffer)
- end if
- recvListPtr => recvListPtr % next
- end do
-
- sendListPtr => sendList
- do while (associated(sendListPtr))
- if (sendListPtr % procID /= dminfo % my_proc_id) then
- call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- deallocate(sendListPtr % ibuffer)
- end if
- sendListPtr => sendListPtr % next
- end do
-
-#else
- if (nOwnedList /= nNeededList) then
- write(0,*) 'Error in dmpar_alltoall_field: For non-dmpar, ', &
- 'arrayIn and arrayOut dims must match.'
- call dmpar_abort(dminfo)
- else
- arrayOut(:,1:nNeededList) = arrayIn(:,1:nOwnedList)
- end if
-#endif
-
- end subroutine dmpar_alltoall_field2dInteger
-
-
- subroutine dmpar_alltoall_field1dReal(dminfo, arrayIn, arrayOut, nOwnedList, nNeededList, sendList, recvList)
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
- real (kind=RKIND), dimension(*), intent(in) :: arrayIn
- real (kind=RKIND), dimension(*), intent(inout) :: arrayOut
- integer, intent(in) :: nOwnedList, nNeededList
- type (exchange_list), pointer :: sendList, recvList
-
- type (exchange_list), pointer :: sendListPtr, recvListPtr
- integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
- integer :: mpi_ierr
- integer :: i
-
-#ifdef _MPI
-
- sendListPtr => sendList
- do while (associated(sendListPtr))
- if (sendListPtr % procID == dminfo % my_proc_id) exit
- sendListPtr => sendListPtr % next
- end do
-
- recvListPtr => recvList
- do while (associated(recvListPtr))
- if (recvListPtr % procID == dminfo % my_proc_id) exit
- recvListPtr => recvListPtr % next
- end do
-
- if (associated(recvListPtr) .and. associated(sendListPtr)) then
- do i=1,recvListPtr % nlist
- arrayOut(recvListPtr % list(i)) = arrayIn(sendListPtr % list(i))
- end do
- end if
-
- recvListPtr => recvList
- do while (associated(recvListPtr))
- if (recvListPtr % procID /= dminfo % my_proc_id) then
- allocate(recvListPtr % rbuffer(recvListPtr % nlist))
- call MPI_Irecv(recvListPtr % rbuffer, recvListPtr % nlist, MPI_REALKIND, &
- recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
- end if
- recvListPtr => recvListPtr % next
- end do
-
- sendListPtr => sendList
- do while (associated(sendListPtr))
- if (sendListPtr % procID /= dminfo % my_proc_id) then
- allocate(sendListPtr % rbuffer(sendListPtr % nlist))
- call packSendBuf1dReal(nOwnedList, arrayIn, sendListPtr, 1, sendListPtr % nlist, &
- sendListPtr % rbuffer, nPacked, lastPackedIdx)
- call MPI_Isend(sendListPtr % rbuffer, sendListPtr % nlist, MPI_REALKIND, &
- sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
- end if
- sendListPtr => sendListPtr % next
- end do
-
- recvListPtr => recvList
- do while (associated(recvListPtr))
- if (recvListPtr % procID /= dminfo % my_proc_id) then
- call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- call unpackRecvBuf1dReal(nNeededList, arrayOut, recvListPtr, 1, recvListPtr % nlist, &
- recvListPtr % rbuffer, nUnpacked, lastUnpackedIdx)
- deallocate(recvListPtr % rbuffer)
- end if
- recvListPtr => recvListPtr % next
- end do
-
- sendListPtr => sendList
- do while (associated(sendListPtr))
- if (sendListPtr % procID /= dminfo % my_proc_id) then
- call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- deallocate(sendListPtr % rbuffer)
- end if
- sendListPtr => sendListPtr % next
- end do
-
-#else
- if (nOwnedList /= nNeededList) then
- write(0,*) 'Error in dmpar_alltoall_field: For non-dmpar, ', &
- 'arrayIn and arrayOut dims must match.'
- call dmpar_abort(dminfo)
- else
- arrayOut(1:nNeededList) = arrayIn(1:nOwnedList)
- end if
-#endif
-
- end subroutine dmpar_alltoall_field1dReal
-
-
- subroutine dmpar_alltoall_field2dReal(dminfo, arrayIn, arrayOut, dim1, nOwnedList, nNeededList, sendList, recvList)
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: dim1, nOwnedList, nNeededList
- real (kind=RKIND), dimension(dim1,*), intent(in) :: arrayIn
- real (kind=RKIND), dimension(dim1,*), intent(inout) :: arrayOut
- type (exchange_list), pointer :: sendList, recvList
-
- type (exchange_list), pointer :: sendListPtr, recvListPtr
- integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
- integer :: mpi_ierr
- integer :: i, d2
-
-#ifdef _MPI
-
- sendListPtr => sendList
- do while (associated(sendListPtr))
- if (sendListPtr % procID == dminfo % my_proc_id) exit
- sendListPtr => sendListPtr % next
- end do
-
- recvListPtr => recvList
- do while (associated(recvListPtr))
- if (recvListPtr % procID == dminfo % my_proc_id) exit
- recvListPtr => recvListPtr % next
- end do
-
- if (associated(recvListPtr) .and. associated(sendListPtr)) then
- do i=1,recvListPtr % nlist
- arrayOut(:,recvListPtr % list(i)) = arrayIn(:,sendListPtr % list(i))
- end do
- end if
-
- recvListPtr => recvList
- do while (associated(recvListPtr))
- if (recvListPtr % procID /= dminfo % my_proc_id) then
- d2 = dim1 * recvListPtr % nlist
- allocate(recvListPtr % rbuffer(d2))
- call MPI_Irecv(recvListPtr % rbuffer, d2, MPI_REALKIND, &
- recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
- end if
- recvListPtr => recvListPtr % next
- end do
-
- sendListPtr => sendList
- do while (associated(sendListPtr))
- if (sendListPtr % procID /= dminfo % my_proc_id) then
- d2 = dim1 * sendListPtr % nlist
- allocate(sendListPtr % rbuffer(d2))
- call packSendBuf2dReal(1, dim1, nOwnedList, arrayIn, sendListPtr, 1, d2, &
- sendListPtr % rbuffer, nPacked, lastPackedIdx)
- call MPI_Isend(sendListPtr % rbuffer, d2, MPI_REALKIND, &
- sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
- end if
- sendListPtr => sendListPtr % next
- end do
-
- recvListPtr => recvList
- do while (associated(recvListPtr))
- if (recvListPtr % procID /= dminfo % my_proc_id) then
- call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- d2 = dim1 * recvListPtr % nlist
- call unpackRecvBuf2dReal(1, dim1, nNeededList, arrayOut, recvListPtr, 1, d2, &
- recvListPtr % rbuffer, nUnpacked, lastUnpackedIdx)
- deallocate(recvListPtr % rbuffer)
- end if
- recvListPtr => recvListPtr % next
- end do
-
- sendListPtr => sendList
- do while (associated(sendListPtr))
- if (sendListPtr % procID /= dminfo % my_proc_id) then
- call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- deallocate(sendListPtr % rbuffer)
- end if
- sendListPtr => sendListPtr % next
- end do
-
-#else
- if (nOwnedList /= nNeededList) then
- write(0,*) 'Error in dmpar_alltoall_field: For non-dmpar, ', &
- 'arrayIn and arrayOut dims must match.'
- call dmpar_abort(dminfo)
- else
- arrayOut(:,1:nNeededList) = arrayIn(:,1:nOwnedList)
- end if
-#endif
-
- end subroutine dmpar_alltoall_field2dReal
-
-
- subroutine dmpar_alltoall_field3dReal(dminfo, arrayIn, arrayOut, dim1, dim2, nOwnedList, nNeededList, sendList, recvList)
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: dim1, dim2, nOwnedList, nNeededList
- real (kind=RKIND), dimension(dim1,dim2,*), intent(in) :: arrayIn
- real (kind=RKIND), dimension(dim1,dim2,*), intent(inout) :: arrayOut
- type (exchange_list), pointer :: sendList, recvList
-
- type (exchange_list), pointer :: sendListPtr, recvListPtr
- integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
- integer :: mpi_ierr
- integer :: i, d3
-
-#ifdef _MPI
-
- sendListPtr => sendList
- do while (associated(sendListPtr))
- if (sendListPtr % procID == dminfo % my_proc_id) exit
- sendListPtr => sendListPtr % next
- end do
-
- recvListPtr => recvList
- do while (associated(recvListPtr))
- if (recvListPtr % procID == dminfo % my_proc_id) exit
- recvListPtr => recvListPtr % next
- end do
-
- if (associated(recvListPtr) .and. associated(sendListPtr)) then
- do i=1,recvListPtr % nlist
- arrayOut(:,:,recvListPtr % list(i)) = arrayIn(:,:,sendListPtr % list(i))
- end do
- end if
-
- recvListPtr => recvList
- do while (associated(recvListPtr))
- if (recvListPtr % procID /= dminfo % my_proc_id) then
- d3 = dim1 * dim2 * recvListPtr % nlist
- allocate(recvListPtr % rbuffer(d3))
- call MPI_Irecv(recvListPtr % rbuffer, d3, MPI_REALKIND, &
- recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
- end if
- recvListPtr => recvListPtr % next
- end do
-
- sendListPtr => sendList
- do while (associated(sendListPtr))
- if (sendListPtr % procID /= dminfo % my_proc_id) then
- d3 = dim1 * dim2 * sendListPtr % nlist
- allocate(sendListPtr % rbuffer(d3))
- call packSendBuf3dReal(1, dim1, 1, dim2, nOwnedList, arrayIn, sendListPtr, 1, d3, &
- sendListPtr % rbuffer, nPacked, lastPackedIdx)
- call MPI_Isend(sendListPtr % rbuffer, d3, MPI_REALKIND, &
- sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
- end if
- sendListPtr => sendListPtr % next
- end do
-
- recvListPtr => recvList
- do while (associated(recvListPtr))
- if (recvListPtr % procID /= dminfo % my_proc_id) then
- call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- d3 = dim1 * dim2 * recvListPtr % nlist
- call unpackRecvBuf3dReal(1, dim1, 1, dim2, nNeededList, arrayOut, recvListPtr, 1, d3, &
- recvListPtr % rbuffer, nUnpacked, lastUnpackedIdx)
- deallocate(recvListPtr % rbuffer)
- end if
- recvListPtr => recvListPtr % next
- end do
-
- sendListPtr => sendList
- do while (associated(sendListPtr))
- if (sendListPtr % procID /= dminfo % my_proc_id) then
- call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- deallocate(sendListPtr % rbuffer)
- end if
- sendListPtr => sendListPtr % next
- end do
-
-#else
- if (nOwnedList /= nNeededList) then
- write(0,*) 'Error in dmpar_alltoall_field: For non-dmpar, ', &
- 'arrayIn and arrayOut dims must match.'
- call dmpar_abort(dminfo)
- else
- arrayOut(:,:,1:nNeededList) = arrayIn(:,:,1:nOwnedList)
- end if
-#endif
-
- end subroutine dmpar_alltoall_field3dReal
-
-
- subroutine packSendBuf1dInteger(nField, field, sendList, startPackIdx, nBuffer, buffer, nPacked, lastPackedIdx)
-
- implicit none
-
- integer, intent(in) :: nField, nBuffer, startPackIdx
- integer, dimension(*), intent(in) :: field
- type (exchange_list), intent(in) :: sendList
- integer, dimension(nBuffer), intent(out) :: buffer
- integer, intent(inout) :: nPacked, lastPackedIdx
-
- integer :: i
-
- nPacked = 0
- do i=startPackIdx, sendList % nlist
- nPacked = nPacked + 1
- if (nPacked > nBuffer) then
- nPacked = nPacked - 1
- lastPackedIdx = i - 1
- return
- end if
- buffer(nPacked) = field(sendList % list(i))
- end do
- lastPackedIdx = sendList % nlist
-
- end subroutine packSendBuf1dInteger
-
-
- subroutine packSendBuf2dInteger(ds, de, nField, field, sendList, startPackIdx, nBuffer, buffer, nPacked, lastPackedIdx)
-
- implicit none
-
- integer, intent(in) :: ds, de, nField, nBuffer, startPackIdx
- integer, dimension(ds:de,*), intent(in) :: field
- type (exchange_list), intent(in) :: sendList
- integer, dimension(nBuffer), intent(out) :: buffer
- integer, intent(inout) :: nPacked, lastPackedIdx
-
- integer :: i, n
-
- n = de-ds+1
-
- if (n > nBuffer) then
- write(0,*) 'packSendBuf2dInteger: Not enough space in buffer', &
- ' to fit a single slice.'
- return
- end if
-
- nPacked = 0
- do i=startPackIdx, sendList % nlist
- nPacked = nPacked + n
- if (nPacked > nBuffer) then
- nPacked = nPacked - n
- lastPackedIdx = i - 1
- return
- end if
- buffer(nPacked-n+1:nPacked) = field(ds:de,sendList % list(i))
- end do
- lastPackedIdx = sendList % nlist
-
- end subroutine packSendBuf2dInteger
-
-
- subroutine packSendBuf3dInteger(d1s, d1e, d2s, d2e, nField, field, sendList, startPackIdx, nBuffer, buffer, nPacked, lastPackedIdx)
-
- implicit none
-
- integer, intent(in) :: d1s, d1e, d2s, d2e, nField, nBuffer, startPackIdx
- integer, dimension(d1s:d1e,d2s:d2e,*), intent(in) :: field
- type (exchange_list), intent(in) :: sendList
- integer, dimension(nBuffer), intent(out) :: buffer
- integer, intent(inout) :: nPacked, lastPackedIdx
-
- integer :: i, j, k, n
-
- n = (d1e-d1s+1) * (d2e-d2s+1)
-
- if (n > nBuffer) then
- write(0,*) 'packSendBuf3dInteger: Not enough space in buffer', &
- ' to fit a single slice.'
- return
- end if
-
- nPacked = 0
- do i=startPackIdx, sendList % nlist
- nPacked = nPacked + n
- if (nPacked > nBuffer) then
- nPacked = nPacked - n
- lastPackedIdx = i - 1
- return
- end if
- k = nPacked-n+1
- do j=d2s,d2e
- buffer(k:k+d1e-d1s) = field(d1s:d1e,j,sendList % list(i))
- k = k + d1e-d1s+1
- end do
- end do
- lastPackedIdx = sendList % nlist
-
- end subroutine packSendBuf3dInteger
-
-
- subroutine packSendBuf1dReal(nField, field, sendList, startPackIdx, nBuffer, buffer, nPacked, lastPackedIdx)
-
- implicit none
-
- integer, intent(in) :: nField, nBuffer, startPackIdx
- real (kind=RKIND), dimension(*), intent(in) :: field
- type (exchange_list), intent(in) :: sendList
- real (kind=RKIND), dimension(nBuffer), intent(out) :: buffer
- integer, intent(inout) :: nPacked, lastPackedIdx
-
- integer :: i
-
- nPacked = 0
- do i=startPackIdx, sendList % nlist
- nPacked = nPacked + 1
- if (nPacked > nBuffer) then
- nPacked = nPacked - 1
- lastPackedIdx = i - 1
- return
- end if
- buffer(nPacked) = field(sendList % list(i))
- end do
- lastPackedIdx = sendList % nlist
-
- end subroutine packSendBuf1dReal
-
-
- subroutine packSendBuf2dReal(ds, de, nField, field, sendList, startPackIdx, nBuffer, buffer, nPacked, lastPackedIdx)
-
- implicit none
-
- integer, intent(in) :: ds, de, nField, nBuffer, startPackIdx
- real (kind=RKIND), dimension(ds:de,*), intent(in) :: field
- type (exchange_list), intent(in) :: sendList
- real (kind=RKIND), dimension(nBuffer), intent(out) :: buffer
- integer, intent(inout) :: nPacked, lastPackedIdx
-
- integer :: i, n
-
- n = de-ds+1
-
- if (n > nBuffer) then
- write(0,*) 'packSendBuf2dReal: Not enough space in buffer', &
- ' to fit a single slice.'
- return
- end if
-
- nPacked = 0
- do i=startPackIdx, sendList % nlist
- nPacked = nPacked + n
- if (nPacked > nBuffer) then
- nPacked = nPacked - n
- lastPackedIdx = i - 1
- return
- end if
- buffer(nPacked-n+1:nPacked) = field(ds:de,sendList % list(i))
- end do
- lastPackedIdx = sendList % nlist
-
- end subroutine packSendBuf2dReal
-
-
- subroutine packSendBuf3dReal(d1s, d1e, d2s, d2e, nField, field, sendList, startPackIdx, nBuffer, buffer, nPacked, lastPackedIdx)
-
- implicit none
-
- integer, intent(in) :: d1s, d1e, d2s, d2e, nField, nBuffer, startPackIdx
- real (kind=RKIND), dimension(d1s:d1e,d2s:d2e,*), intent(in) :: field
- type (exchange_list), intent(in) :: sendList
- real (kind=RKIND), dimension(nBuffer), intent(out) :: buffer
- integer, intent(inout) :: nPacked, lastPackedIdx
-
- integer :: i, j, k, n
-
- n = (d1e-d1s+1) * (d2e-d2s+1)
-
- if (n > nBuffer) then
- write(0,*) 'packSendBuf3dReal: Not enough space in buffer', &
- ' to fit a single slice.'
- return
- end if
-
- nPacked = 0
- do i=startPackIdx, sendList % nlist
- nPacked = nPacked + n
- if (nPacked > nBuffer) then
- nPacked = nPacked - n
- lastPackedIdx = i - 1
- return
- end if
- k = nPacked-n+1
- do j=d2s,d2e
- buffer(k:k+d1e-d1s) = field(d1s:d1e,j,sendList % list(i))
- k = k + d1e-d1s+1
- end do
- end do
- lastPackedIdx = sendList % nlist
-
- end subroutine packSendBuf3dReal
-
-
- subroutine unpackRecvBuf1dInteger(nField, field, recvList, startUnpackIdx, nBuffer, buffer, nUnpacked, lastUnpackedIdx)
-
- implicit none
-
- integer, intent(in) :: nField, nBuffer, startUnpackIdx
- integer, dimension(*), intent(inout) :: field
- type (exchange_list), intent(in) :: recvList
- integer, dimension(nBuffer), intent(in) :: buffer
- integer, intent(inout) :: nUnpacked, lastUnpackedIdx
-
- integer :: i
-
- nUnpacked = 0
- do i=startUnpackIdx, recvList % nlist
- nUnpacked = nUnpacked + 1
- if (nUnpacked > nBuffer) then
- nUnpacked = nUnpacked - 1
- lastUnpackedIdx = i - 1
- return
- end if
- field(recvList % list(i)) = buffer(nUnpacked)
- end do
- lastUnpackedIdx = recvList % nlist
-
- end subroutine unpackRecvBuf1dInteger
-
-
- subroutine unpackRecvBuf2dInteger(ds, de, nField, field, recvList, startUnpackIdx, nBuffer, buffer, nUnpacked, lastUnpackedIdx)
-
- implicit none
-
- integer, intent(in) :: ds, de, nField, nBuffer, startUnpackIdx
- integer, dimension(ds:de,*), intent(inout) :: field
- type (exchange_list), intent(in) :: recvList
- integer, dimension(nBuffer), intent(in) :: buffer
- integer, intent(inout) :: nUnpacked, lastUnpackedIdx
-
- integer :: i, n
-
- n = de-ds+1
-
- nUnpacked = 0
- do i=startUnpackIdx, recvList % nlist
- nUnpacked = nUnpacked + n
- if (nUnpacked > nBuffer) then
- nUnpacked = nUnpacked - n
- lastUnpackedIdx = i - 1
- return
- end if
- field(ds:de,recvList % list(i)) = buffer(nUnpacked-n+1:nUnpacked)
- end do
- lastUnpackedIdx = recvList % nlist
-
- end subroutine unpackRecvBuf2dInteger
-
-
- subroutine unpackRecvBuf3dInteger(d1s, d1e, d2s, d2e, nField, field, recvList, startUnpackIdx, nBuffer, buffer, &
- nUnpacked, lastUnpackedIdx)
-
- implicit none
-
- integer, intent(in) :: d1s, d1e, d2s, d2e, nField, nBuffer, startUnpackIdx
- integer, dimension(d1s:d1e,d2s:d2e,*), intent(inout) :: field
- type (exchange_list), intent(in) :: recvList
- integer, dimension(nBuffer), intent(in) :: buffer
- integer, intent(inout) :: nUnpacked, lastUnpackedIdx
-
- integer :: i, j, k, n
-
- n = (d1e-d1s+1) * (d2e-d2s+1)
-
- nUnpacked = 0
- do i=startUnpackIdx, recvList % nlist
- nUnpacked = nUnpacked + n
- if (nUnpacked > nBuffer) then
- nUnpacked = nUnpacked - n
- lastUnpackedIdx = i - 1
- return
- end if
- k = nUnpacked-n+1
- do j=d2s,d2e
- field(d1s:d1e,j,recvList % list(i)) = buffer(k:k+d1e-d1s)
- k = k + d1e-d1s+1
- end do
- end do
- lastUnpackedIdx = recvList % nlist
-
- end subroutine unpackRecvBuf3dInteger
-
-
- subroutine dmpar_exch_halo_field1dInteger(dminfo, array, dim1, sendList, recvList)
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: dim1
- integer, dimension(*), intent(inout) :: array
- type (exchange_list), pointer :: sendList, recvList
-
- type (exchange_list), pointer :: sendListPtr, recvListPtr
- integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
- integer :: mpi_ierr
-
-#ifdef _MPI
-
- recvListPtr => recvList
- do while (associated(recvListPtr))
- if (recvListPtr % procID /= dminfo % my_proc_id) then
- allocate(recvListPtr % ibuffer(recvListPtr % nlist))
- call MPI_Irecv(recvListPtr % ibuffer, recvListPtr % nlist, MPI_INTEGERKIND, &
- recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
- end if
- recvListPtr => recvListPtr % next
- end do
-
- sendListPtr => sendList
- do while (associated(sendListPtr))
- if (sendListPtr % procID /= dminfo % my_proc_id) then
- allocate(sendListPtr % ibuffer(sendListPtr % nlist))
- call packSendBuf1dInteger(dim1, array, sendListPtr, 1, sendListPtr % nlist, sendListPtr % ibuffer, nPacked, lastPackedIdx)
- call MPI_Isend(sendListPtr % ibuffer, sendListPtr % nlist, MPI_INTEGERKIND, &
- sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
- end if
- sendListPtr => sendListPtr % next
- end do
-
- recvListPtr => recvList
- do while (associated(recvListPtr))
- if (recvListPtr % procID /= dminfo % my_proc_id) then
- call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- call unpackRecvBuf1dInteger(dim1, array, recvListPtr, 1, recvListPtr % nlist, recvListPtr % ibuffer, nUnpacked, lastUnpackedIdx)
- deallocate(recvListPtr % ibuffer)
- end if
- recvListPtr => recvListPtr % next
- end do
-
- sendListPtr => sendList
- do while (associated(sendListPtr))
- if (sendListPtr % procID /= dminfo % my_proc_id) then
- call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- deallocate(sendListPtr % ibuffer)
- end if
- sendListPtr => sendListPtr % next
- end do
-
-#endif
-
- end subroutine dmpar_exch_halo_field1dInteger
-
-
- subroutine dmpar_exch_halo_field2dInteger(dminfo, array, dim1, dim2, sendList, recvList)
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: dim1, dim2
- integer, dimension(dim1,*), intent(inout) :: array
- type (exchange_list), pointer :: sendList, recvList
-
- type (exchange_list), pointer :: sendListPtr, recvListPtr
- integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
- integer :: mpi_ierr
- integer :: d2
-
-#ifdef _MPI
-
- recvListPtr => recvList
- do while (associated(recvListPtr))
- if (recvListPtr % procID /= dminfo % my_proc_id) then
- d2 = dim1 * recvListPtr % nlist
- allocate(recvListPtr % ibuffer(d2))
- call MPI_Irecv(recvListPtr % ibuffer, d2, MPI_INTEGERKIND, &
- recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
- end if
- recvListPtr => recvListPtr % next
- end do
-
- sendListPtr => sendList
- do while (associated(sendListPtr))
- if (sendListPtr % procID /= dminfo % my_proc_id) then
- d2 = dim1 * sendListPtr % nlist
- allocate(sendListPtr % ibuffer(d2))
- call packSendBuf2dInteger(1, dim1, dim2, array, sendListPtr, 1, d2, sendListPtr % ibuffer, nPacked, lastPackedIdx)
- call MPI_Isend(sendListPtr % ibuffer, d2, MPI_INTEGERKIND, &
- sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
- end if
- sendListPtr => sendListPtr % next
- end do
-
- recvListPtr => recvList
- do while (associated(recvListPtr))
- if (recvListPtr % procID /= dminfo % my_proc_id) then
- call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- d2 = dim1 * recvListPtr % nlist
- call unpackRecvBuf2dInteger(1, dim1, dim2, array, recvListPtr, 1, d2, recvListPtr % ibuffer, nUnpacked, lastUnpackedIdx)
- deallocate(recvListPtr % ibuffer)
- end if
- recvListPtr => recvListPtr % next
- end do
-
- sendListPtr => sendList
- do while (associated(sendListPtr))
- if (sendListPtr % procID /= dminfo % my_proc_id) then
- call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- deallocate(sendListPtr % ibuffer)
- end if
- sendListPtr => sendListPtr % next
- end do
-
-#endif
-
- end subroutine dmpar_exch_halo_field2dInteger
-
-
- subroutine dmpar_exch_halo_field3dInteger(dminfo, array, dim1, dim2, dim3, sendList, recvList)
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: dim1, dim2, dim3
- integer, dimension(dim1,dim2,*), intent(inout) :: array
- type (exchange_list), pointer :: sendList, recvList
-
- type (exchange_list), pointer :: sendListPtr, recvListPtr
- integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
- integer :: mpi_ierr
- integer :: d3
-
-#ifdef _MPI
-
- recvListPtr => recvList
- do while (associated(recvListPtr))
- if (recvListPtr % procID /= dminfo % my_proc_id) then
- d3 = dim1 * dim2 * recvListPtr % nlist
- allocate(recvListPtr % ibuffer(d3))
- call MPI_Irecv(recvListPtr % ibuffer, d3, MPI_INTEGERKIND, &
- recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
- end if
- recvListPtr => recvListPtr % next
- end do
-
- sendListPtr => sendList
- do while (associated(sendListPtr))
- if (sendListPtr % procID /= dminfo % my_proc_id) then
- d3 = dim1 * dim2 * sendListPtr % nlist
- allocate(sendListPtr % ibuffer(d3))
- call packSendBuf3dInteger(1, dim1, 1, dim2, dim3, array, sendListPtr, 1, d3, &
- sendListPtr % ibuffer, nPacked, lastPackedIdx)
- call MPI_Isend(sendListPtr % ibuffer, d3, MPI_INTEGERKIND, &
- sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
- end if
- sendListPtr => sendListPtr % next
- end do
-
- recvListPtr => recvList
- do while (associated(recvListPtr))
- if (recvListPtr % procID /= dminfo % my_proc_id) then
- call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- d3 = dim1 * dim2 * recvListPtr % nlist
- call unpackRecvBuf3dInteger(1, dim1, 1, dim2, dim3, array, recvListPtr, 1, d3, &
- recvListPtr % ibuffer, nUnpacked, lastUnpackedIdx)
- deallocate(recvListPtr % ibuffer)
- end if
- recvListPtr => recvListPtr % next
- end do
-
- sendListPtr => sendList
- do while (associated(sendListPtr))
- if (sendListPtr % procID /= dminfo % my_proc_id) then
- call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- deallocate(sendListPtr % ibuffer)
- end if
- sendListPtr => sendListPtr % next
- end do
-
-#endif
-
- end subroutine dmpar_exch_halo_field3dInteger
-
-
- subroutine unpackRecvBuf1dReal(nField, field, recvList, startUnpackIdx, nBuffer, buffer, nUnpacked, lastUnpackedIdx)
-
- implicit none
-
- integer, intent(in) :: nField, nBuffer, startUnpackIdx
- real (kind=RKIND), dimension(*), intent(inout) :: field
- type (exchange_list), intent(in) :: recvList
- real (kind=RKIND), dimension(nBuffer), intent(in) :: buffer
- integer, intent(inout) :: nUnpacked, lastUnpackedIdx
-
- integer :: i
-
- nUnpacked = 0
- do i=startUnpackIdx, recvList % nlist
- nUnpacked = nUnpacked + 1
- if (nUnpacked > nBuffer) then
- nUnpacked = nUnpacked - 1
- lastUnpackedIdx = i - 1
- return
- end if
- field(recvList % list(i)) = buffer(nUnpacked)
- end do
- lastUnpackedIdx = recvList % nlist
-
- end subroutine unpackRecvBuf1dReal
-
-
- subroutine unpackRecvBuf2dReal(ds, de, nField, field, recvList, startUnpackIdx, nBuffer, buffer, nUnpacked, lastUnpackedIdx)
-
- implicit none
-
- integer, intent(in) :: ds, de, nField, nBuffer, startUnpackIdx
- real (kind=RKIND), dimension(ds:de,*), intent(inout) :: field
- type (exchange_list), intent(in) :: recvList
- real (kind=RKIND), dimension(nBuffer), intent(in) :: buffer
- integer, intent(inout) :: nUnpacked, lastUnpackedIdx
-
- integer :: i, n
-
- n = de-ds+1
-
- nUnpacked = 0
- do i=startUnpackIdx, recvList % nlist
- nUnpacked = nUnpacked + n
- if (nUnpacked > nBuffer) then
- nUnpacked = nUnpacked - n
- lastUnpackedIdx = i - 1
- return
- end if
- field(ds:de,recvList % list(i)) = buffer(nUnpacked-n+1:nUnpacked)
- end do
- lastUnpackedIdx = recvList % nlist
-
- end subroutine unpackRecvBuf2dReal
-
-
- subroutine unpackRecvBuf3dReal(d1s, d1e, d2s, d2e, nField, field, recvList, startUnpackIdx, nBuffer, buffer, &
- nUnpacked, lastUnpackedIdx)
-
- implicit none
-
- integer, intent(in) :: d1s, d1e, d2s, d2e, nField, nBuffer, startUnpackIdx
- real (kind=RKIND), dimension(d1s:d1e,d2s:d2e,*), intent(inout) :: field
- type (exchange_list), intent(in) :: recvList
- real (kind=RKIND), dimension(nBuffer), intent(in) :: buffer
- integer, intent(inout) :: nUnpacked, lastUnpackedIdx
-
- integer :: i, j, k, n
-
- n = (d1e-d1s+1) * (d2e-d2s+1)
-
- nUnpacked = 0
- do i=startUnpackIdx, recvList % nlist
- nUnpacked = nUnpacked + n
- if (nUnpacked > nBuffer) then
- nUnpacked = nUnpacked - n
- lastUnpackedIdx = i - 1
- return
- end if
- k = nUnpacked-n+1
- do j=d2s,d2e
- field(d1s:d1e,j,recvList % list(i)) = buffer(k:k+d1e-d1s)
- k = k + d1e-d1s+1
- end do
- end do
- lastUnpackedIdx = recvList % nlist
-
- end subroutine unpackRecvBuf3dReal
-
-
- subroutine dmpar_exch_halo_field1dReal(dminfo, array, dim1, sendList, recvList)
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: dim1
- real (kind=RKIND), dimension(*), intent(inout) :: array
- type (exchange_list), pointer :: sendList, recvList
-
- type (exchange_list), pointer :: sendListPtr, recvListPtr
- integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
- integer :: mpi_ierr
-
-#ifdef _MPI
-
- recvListPtr => recvList
- do while (associated(recvListPtr))
- if (recvListPtr % procID /= dminfo % my_proc_id) then
- allocate(recvListPtr % rbuffer(recvListPtr % nlist))
- call MPI_Irecv(recvListPtr % rbuffer, recvListPtr % nlist, MPI_REALKIND, &
- recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
- end if
- recvListPtr => recvListPtr % next
- end do
-
- sendListPtr => sendList
- do while (associated(sendListPtr))
- if (sendListPtr % procID /= dminfo % my_proc_id) then
- allocate(sendListPtr % rbuffer(sendListPtr % nlist))
- call packSendBuf1dReal(dim1, array, sendListPtr, 1, sendListPtr % nlist, sendListPtr % rbuffer, nPacked, lastPackedIdx)
- call MPI_Isend(sendListPtr % rbuffer, sendListPtr % nlist, MPI_REALKIND, &
- sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
- end if
- sendListPtr => sendListPtr % next
- end do
-
- recvListPtr => recvList
- do while (associated(recvListPtr))
- if (recvListPtr % procID /= dminfo % my_proc_id) then
- call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- call unpackRecvBuf1dReal(dim1, array, recvListPtr, 1, recvListPtr % nlist, recvListPtr % rbuffer, nUnpacked, lastUnpackedIdx)
- deallocate(recvListPtr % rbuffer)
- end if
- recvListPtr => recvListPtr % next
- end do
-
- sendListPtr => sendList
- do while (associated(sendListPtr))
- if (sendListPtr % procID /= dminfo % my_proc_id) then
- call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- deallocate(sendListPtr % rbuffer)
- end if
- sendListPtr => sendListPtr % next
- end do
-
-#endif
-
- end subroutine dmpar_exch_halo_field1dReal
-
-
- subroutine dmpar_exch_halo_field2dReal(dminfo, array, dim1, dim2, sendList, recvList)
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: dim1, dim2
- real (kind=RKIND), dimension(dim1,*), intent(inout) :: array
- type (exchange_list), pointer :: sendList, recvList
-
- type (exchange_list), pointer :: sendListPtr, recvListPtr
- integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
- integer :: mpi_ierr
- integer :: d2
-
-#ifdef _MPI
-
- recvListPtr => recvList
- do while (associated(recvListPtr))
- if (recvListPtr % procID /= dminfo % my_proc_id) then
- d2 = dim1 * recvListPtr % nlist
- allocate(recvListPtr % rbuffer(d2))
- call MPI_Irecv(recvListPtr % rbuffer, d2, MPI_REALKIND, &
- recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
- end if
- recvListPtr => recvListPtr % next
- end do
-
- sendListPtr => sendList
- do while (associated(sendListPtr))
- if (sendListPtr % procID /= dminfo % my_proc_id) then
- d2 = dim1 * sendListPtr % nlist
- allocate(sendListPtr % rbuffer(d2))
- call packSendBuf2dReal(1, dim1, dim2, array, sendListPtr, 1, d2, sendListPtr % rbuffer, nPacked, lastPackedIdx)
- call MPI_Isend(sendListPtr % rbuffer, d2, MPI_REALKIND, &
- sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
- end if
- sendListPtr => sendListPtr % next
- end do
-
- recvListPtr => recvList
- do while (associated(recvListPtr))
- if (recvListPtr % procID /= dminfo % my_proc_id) then
- call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- d2 = dim1 * recvListPtr % nlist
- call unpackRecvBuf2dReal(1, dim1, dim2, array, recvListPtr, 1, d2, recvListPtr % rbuffer, nUnpacked, lastUnpackedIdx)
- deallocate(recvListPtr % rbuffer)
- end if
- recvListPtr => recvListPtr % next
- end do
-
- sendListPtr => sendList
- do while (associated(sendListPtr))
- if (sendListPtr % procID /= dminfo % my_proc_id) then
- call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- deallocate(sendListPtr % rbuffer)
- end if
- sendListPtr => sendListPtr % next
- end do
-
-#endif
-
- end subroutine dmpar_exch_halo_field2dReal
-
-
- subroutine dmpar_exch_halo_field3dReal(dminfo, array, dim1, dim2, dim3, sendList, recvList)
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: dim1, dim2, dim3
- real (kind=RKIND), dimension(dim1,dim2,*), intent(inout) :: array
- type (exchange_list), pointer :: sendList, recvList
-
- type (exchange_list), pointer :: sendListPtr, recvListPtr
- integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
- integer :: mpi_ierr
- integer :: d3
-
-#ifdef _MPI
-
- recvListPtr => recvList
- do while (associated(recvListPtr))
- if (recvListPtr % procID /= dminfo % my_proc_id) then
- d3 = dim1 * dim2 * recvListPtr % nlist
- allocate(recvListPtr % rbuffer(d3))
- call MPI_Irecv(recvListPtr % rbuffer, d3, MPI_REALKIND, &
- recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
- end if
- recvListPtr => recvListPtr % next
- end do
-
- sendListPtr => sendList
- do while (associated(sendListPtr))
- if (sendListPtr % procID /= dminfo % my_proc_id) then
- d3 = dim1 * dim2 * sendListPtr % nlist
- allocate(sendListPtr % rbuffer(d3))
- call packSendBuf3dReal(1, dim1, 1, dim2, dim3, array, sendListPtr, 1, d3, &
- sendListPtr % rbuffer, nPacked, lastPackedIdx)
- call MPI_Isend(sendListPtr % rbuffer, d3, MPI_REALKIND, &
- sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
- end if
- sendListPtr => sendListPtr % next
- end do
-
- recvListPtr => recvList
- do while (associated(recvListPtr))
- if (recvListPtr % procID /= dminfo % my_proc_id) then
- call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- d3 = dim1 * dim2 * recvListPtr % nlist
- call unpackRecvBuf3dReal(1, dim1, 1, dim2, dim3, array, recvListPtr, 1, d3, &
- recvListPtr % rbuffer, nUnpacked, lastUnpackedIdx)
- deallocate(recvListPtr % rbuffer)
- end if
- recvListPtr => recvListPtr % next
- end do
-
- sendListPtr => sendList
- do while (associated(sendListPtr))
- if (sendListPtr % procID /= dminfo % my_proc_id) then
- call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- deallocate(sendListPtr % rbuffer)
- end if
- sendListPtr => sendListPtr % next
- end do
-
-#endif
-
- end subroutine dmpar_exch_halo_field3dReal
-
-
-end module dmpar
Deleted: trunk/mpas/src/framework/module_grid_types.F
===================================================================
--- trunk/mpas/src/framework/module_grid_types.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/framework/module_grid_types.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -1,219 +0,0 @@
-module grid_types
-
- use dmpar
-
- integer, parameter :: nTimeLevs = 2
-
-
- ! Derived type describing info for doing I/O specific to a field
- type io_info
- character (len=1024) :: fieldName
- integer, dimension(4) :: start
- integer, dimension(4) :: count
- logical :: input
- logical :: sfc
- logical :: restart
- logical :: output
- end type io_info
-
-
- ! Derived type for storing fields
- type field3DReal
- type (block_type), pointer :: block
- real (kind=RKIND), dimension(:,:,:), pointer :: array
- type (io_info), pointer :: ioinfo
- end type field3DReal
-
-
- ! Derived type for storing fields
- type field2DReal
- type (block_type), pointer :: block
- real (kind=RKIND), dimension(:,:), pointer :: array
- type (io_info), pointer :: ioinfo
- end type field2DReal
-
-
- ! Derived type for storing fields
- type field1DReal
- type (block_type), pointer :: block
- real (kind=RKIND), dimension(:), pointer :: array
- type (io_info), pointer :: ioinfo
- end type field1DReal
-
-
- ! Derived type for storing fields
- type field0DReal
- type (block_type), pointer :: block
- real (kind=RKIND) :: scalar
- type (io_info), pointer :: ioinfo
- end type field0DReal
-
-
- ! Derived type for storing fields
- type field2DInteger
- type (block_type), pointer :: block
- integer, dimension(:,:), pointer :: array
- type (io_info), pointer :: ioinfo
- end type field2DInteger
-
-
- ! Derived type for storing fields
- type field1DInteger
- type (block_type), pointer :: block
- integer, dimension(:), pointer :: array
- type (io_info), pointer :: ioinfo
- end type field1DInteger
-
-
- ! Derived type for storing fields
- type field1DChar
- type (block_type), pointer :: block
- character (len=64), dimension(:), pointer :: array
- type (io_info), pointer :: ioinfo
- end type field1DChar
-
-
- ! Derived type for storing fields
- type field0DChar
- type (block_type), pointer :: block
- character (len=64) :: scalar
- type (io_info), pointer :: ioinfo
- end type field0DChar
-
-
- ! Derived type for storing grid meta-data
- type mesh_type
-
-#include "field_dimensions.inc"
-
- logical :: on_a_sphere
- real (kind=RKIND) :: sphere_radius
-
-#include "time_invariant_fields.inc"
-
- end type mesh_type
-
-
-#include "variable_groups.inc"
-
-
- ! Type for storing (possibly architecture specific) information concerning to parallelism
- type parallel_info
- type (exchange_list), pointer :: cellsToSend ! List of types describing which cells to send to other blocks
- type (exchange_list), pointer :: cellsToRecv ! List of types describing which cells to receive from other blocks
- type (exchange_list), pointer :: edgesToSend ! List of types describing which edges to send to other blocks
- type (exchange_list), pointer :: edgesToRecv ! List of types describing which edges to receive from other blocks
- type (exchange_list), pointer :: verticesToSend ! List of types describing which vertices to send to other blocks
- type (exchange_list), pointer :: verticesToRecv ! List of types describing which vertices to receive from other blocks
- end type parallel_info
-
-
- ! Derived type for storing part of a domain; used as a basic unit of work for a process
- type block_type
-
-#include "block_group_members.inc"
-
- type (domain_type), pointer :: domain
-
- type (parallel_info), pointer :: parinfo
-
- type (block_type), pointer :: prev, next
- end type block_type
-
-
- ! Derived type for storing list of blocks from a domain to be handled by a process
- type domain_type
- type (block_type), pointer :: blocklist
-
- ! Also store parallelization info here
- type (dm_info), pointer :: dminfo
- end type domain_type
-
-
- contains
-
-
- subroutine allocate_domain(dom, dminfo)
-
- implicit none
-
- type (domain_type), pointer :: dom
- type (dm_info), pointer :: dminfo
-
- allocate(dom)
- nullify(dom % blocklist)
- dom % dminfo => dminfo
-
- end subroutine allocate_domain
-
-
- subroutine allocate_block(b, dom, &
-#include "dim_dummy_args.inc"
- )
-
- implicit none
-
- type (block_type), pointer :: b
- type (domain_type), pointer :: dom
-#include "dim_dummy_decls.inc"
-
- integer :: i
-
- nullify(b % prev)
- nullify(b % next)
-
- allocate(b % parinfo)
-
- b % domain => dom
-
-#include "block_allocs.inc"
-
- end subroutine allocate_block
-
-
-#include "group_alloc_routines.inc"
-
-
- subroutine deallocate_domain(dom)
-
- implicit none
-
- type (domain_type), pointer :: dom
-
- type (block_type), pointer :: block_ptr
-
- block_ptr => dom % blocklist
- do while (associated(block_ptr))
- call deallocate_block(block_ptr)
- block_ptr => block_ptr % next
- end do
-
- deallocate(dom)
-
- end subroutine deallocate_domain
-
-
- subroutine deallocate_block(b)
-
- implicit none
-
- type (block_type), intent(inout) :: b
-
- integer :: i
-
- deallocate(b % parinfo)
-
-#include "block_deallocs.inc"
-
- end subroutine deallocate_block
-
-
-#include "group_dealloc_routines.inc"
-
-
-#include "group_copy_routines.inc"
-
-
-#include "group_shift_level_routines.inc"
-
-end module grid_types
Deleted: trunk/mpas/src/framework/module_hash.F
===================================================================
--- trunk/mpas/src/framework/module_hash.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/framework/module_hash.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -1,175 +0,0 @@
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! MODULE HASH
-!
-! Purpose: This module provides a dictionary/hashtable with insert, search, and
-! remove routines.
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-module hash
-
- ! Parameters
- integer, parameter :: TABLESIZE=27183 ! Number of spaces in the table (the
- ! number of linked lists)
-
- type hashnode
- integer :: key
- type (hashnode), pointer :: next
- end type hashnode
-
- type hashnode_ptr
- type (hashnode), pointer :: p ! Pointer to a list of entries
- end type hashnode_ptr
-
- type hashtable
- integer :: size
- type (hashnode_ptr), dimension(TABLESIZE) :: table ! The hashtable array
- end type hashtable
-
-
- contains
-
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Name: hash_init
- !
- ! Purpose: To initialize a hashtable
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine hash_init(h)
-
- implicit none
-
- ! Arguments
- type (hashtable), intent(inout) :: h
-
- ! Local variables
- integer :: i
-
- h%size = 0
-
- do i=1,TABLESIZE
- nullify(h%table(i)%p)
- end do
-
- end subroutine hash_init
-
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Name: hash_insert
- !
- ! Purpose: Given a hashtable h and a key to be inserted into the hashtable,
- ! this routine adds key to the table.
- !
- ! NOTE: If the key already exists in the table, a second copy of the
- ! key is added to the table
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine hash_insert(h, key)
-
- implicit none
-
- ! Arguments
- integer, intent(in) :: key
- type (hashtable), intent(inout) :: h
-
- ! Local variables
- integer :: hashval, i
- type (hashnode), pointer :: hn
-
- hashval = mod(key, TABLESIZE) + 1
-
- allocate(hn)
- hn%key = key
- hn%next => h%table(hashval)%p
- h%table(hashval)%p => hn
-
- h%size = h%size + 1
-
- end subroutine hash_insert
-
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Name: hash_search
- !
- ! Purpose: This function returns TRUE if the specified key was found in the
- ! hashtable h, and FALSE otherwise.
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- logical function hash_search(h, key)
-
- implicit none
-
- ! Arguments
- integer, intent(in) :: key
- type (hashtable), intent(inout) :: h
-
- ! Local variables
- integer :: hashval, i
- type (hashnode), pointer :: cursor
-
- hash_search = .false.
-
- hashval = mod(key, TABLESIZE) + 1
-
- cursor => h%table(hashval)%p
- do while(associated(cursor))
- if (cursor%key == key) then
- hash_search = .true.
- return
- else
- cursor => cursor%next
- end if
- end do
-
- return
-
- end function hash_search
-
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Name: hash_size
- !
- ! Purpose: Returns the number of items in the hash table h.
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- integer function hash_size(h)
-
- implicit none
-
- ! Arguments
- type (hashtable) :: h
-
- hash_size = h%size
-
- return
-
- end function hash_size
-
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Name: hash_destroy
- !
- ! Purpose: Frees all memory associated with hashtable h. This routine may be
- ! used to remove all entries from a hashtable.
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine hash_destroy(h)
-
- implicit none
-
- ! Arguments
- type (hashtable), intent(inout) :: h
-
- ! Local variables
- integer :: i
- type (hashnode), pointer :: cursor, cursor_prev
-
- do i=1,TABLESIZE
- cursor => h%table(i)%p
- do while(associated(cursor))
- cursor_prev => cursor
- cursor => cursor%next
- deallocate(cursor_prev)
- end do
- nullify(h%table(i)%p)
- end do
-
- h%size = 0
-
- end subroutine hash_destroy
-
-end module hash
Deleted: trunk/mpas/src/framework/module_io_input.F
===================================================================
--- trunk/mpas/src/framework/module_io_input.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/framework/module_io_input.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -1,1614 +0,0 @@
-module io_input
-
- use grid_types
- use dmpar
- use block_decomp
- use sort
- use configure
- use mpas_timekeeping
-
-
-#ifdef HAVE_ZOLTAN
- use zoltan_interface
-#endif
-
- integer, parameter :: STREAM_INPUT=1, STREAM_SFC=2, STREAM_RESTART=3
-
- type io_input_object
- character (len=1024) :: filename
- integer :: rd_ncid
- integer :: stream
-
- integer :: time
-
-#include "io_input_obj_decls.inc"
- end type io_input_object
-
-
- interface io_input_field
- module procedure io_input_field0dReal
- module procedure io_input_field1dReal
- module procedure io_input_field2dReal
- module procedure io_input_field3dReal
- module procedure io_input_field1dInteger
- module procedure io_input_field2dInteger
- module procedure io_input_field0dChar
- module procedure io_input_field1dChar
- end interface io_input_field
-
- interface io_input_field_time
- module procedure io_input_field0dReal_time
- module procedure io_input_field1dReal_time
- module procedure io_input_field2dReal_time
- module procedure io_input_field3dReal_time
- module procedure io_input_field1dInteger_time
- module procedure io_input_field0dChar_time
- module procedure io_input_field1dChar_time
- end interface io_input_field_time
-
- type (exchange_list), pointer :: sendCellList, recvCellList
- type (exchange_list), pointer :: sendEdgeList, recvEdgeList
- type (exchange_list), pointer :: sendVertexList, recvVertexList
- type (exchange_list), pointer :: sendVertLevelList, recvVertLevelList
-
- integer :: readCellStart, readCellEnd, nReadCells
- integer :: readEdgeStart, readEdgeEnd, nReadEdges
- integer :: readVertexStart, readVertexEnd, nReadVertices
- integer :: readVertLevelStart, readVertLevelEnd, nReadVertLevels
-
-
- contains
-
-
- subroutine input_state_for_domain(domain)
-
- implicit none
-
- type (domain_type), pointer :: domain
-
- integer :: i, j, k
- type (io_input_object) :: input_obj
-#include "dim_decls.inc"
-
- character (len=16) :: c_on_a_sphere
- real (kind=RKIND) :: r_sphere_radius
-
- type (field1dInteger) :: indexToCellIDField
- type (field1dInteger) :: indexToEdgeIDField
- type (field1dInteger) :: indexToVertexIDField
- type (field1dInteger) :: nEdgesOnCellField
- type (field2dInteger) :: cellsOnCellField
- type (field2dInteger) :: edgesOnCellField
- type (field2dInteger) :: verticesOnCellField
- type (field2dInteger) :: cellsOnEdgeField
- type (field2dInteger) :: cellsOnVertexField
-
-#ifdef HAVE_ZOLTAN
-#ifdef _MPI
- type (field1dReal) :: xCellField, yCellField, zCellField
- type (field1dReal) :: xEdgeField, yEdgeField, zEdgeField
- type (field1dReal) :: xVertexField, yVertexField, zVertexField
-#endif
-#endif
-
- type (field1DChar) :: xtime
-
- integer, dimension(:), pointer :: indexToCellID_0Halo
- integer, dimension(:), pointer :: nEdgesOnCell_0Halo
- integer, dimension(:,:), pointer :: cellsOnCell_0Halo
-
- integer, dimension(:,:), pointer :: edgesOnCell_2Halo
- integer, dimension(:,:), pointer :: verticesOnCell_2Halo
- integer, dimension(:,:), pointer :: cellsOnEdge_2Halo
- integer, dimension(:,:), pointer :: cellsOnVertex_2Halo
-
- integer, dimension(:,:), pointer :: cellIDSorted
- integer, dimension(:,:), pointer :: edgeIDSorted
- integer, dimension(:,:), pointer :: vertexIDSorted
-
-#ifdef HAVE_ZOLTAN
-#ifdef _MPI
- real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell
- real (kind=RKIND), dimension(:), pointer :: xEdge, yEdge, zEdge
- real (kind=RKIND), dimension(:), pointer :: xVertex, yVertex, zVertex
-#endif
-#endif
-
- integer, dimension(:), pointer :: local_cell_list, local_edge_list, local_vertex_list
- integer, dimension(:), pointer :: local_vertlevel_list, needed_vertlevel_list
- integer :: nlocal_edges, nlocal_vertices
- type (exchange_list), pointer :: send1Halo, recv1Halo
- type (exchange_list), pointer :: send2Halo, recv2Halo
- type (graph) :: partial_global_graph_info
- type (graph) :: block_graph_0Halo, block_graph_1Halo, block_graph_2Halo
- integer :: ghostEdgeStart, ghostVertexStart
-
- type (MPAS_Time_type) :: startTime
- type (MPAS_Time_type) :: sliceTime
- type (MPAS_TimeInterval_type) :: timeDiff
- type (MPAS_TimeInterval_type) :: minTimeDiff
- character(len=32) :: timeStamp
-
- if (config_do_restart) then
- input_obj % filename = trim(config_restart_name)
- input_obj % stream = STREAM_RESTART
- else
- input_obj % filename = trim(config_input_name)
- input_obj % stream = STREAM_INPUT
- end if
- call io_input_init(input_obj, domain % dminfo)
-
-
- !
- ! Read global number of cells/edges/vertices
- !
-#include "read_dims.inc"
-
- !
- ! Determine the range of cells/edges/vertices that a processor will initially read
- ! from the input file
- !
- call dmpar_get_index_range(domain % dminfo, 1, nCells, readCellStart, readCellEnd)
- nReadCells = readCellEnd - readCellStart + 1
-
- call dmpar_get_index_range(domain % dminfo, 1, nEdges, readEdgeStart, readEdgeEnd)
- nReadEdges = readEdgeEnd - readEdgeStart + 1
-
- call dmpar_get_index_range(domain % dminfo, 1, nVertices, readVertexStart, readVertexEnd)
- nReadVertices = readVertexEnd - readVertexStart + 1
-
- readVertLevelStart = 1
- readVertLevelEnd = nVertLevels
- nReadVertLevels = nVertLevels
-
-
- !
- ! Allocate and read fields that we will need in order to ultimately work out
- ! which cells/edges/vertices are owned by each block, and which are ghost
- !
-
- ! Global cell indices
- allocate(indexToCellIDField % ioinfo)
- indexToCellIDField % ioinfo % fieldName = 'indexToCellID'
- indexToCellIDField % ioinfo % start(1) = readCellStart
- indexToCellIDField % ioinfo % count(1) = nReadCells
- allocate(indexToCellIDField % array(nReadCells))
- call io_input_field(input_obj, indexToCellIDField)
-
-#ifdef HAVE_ZOLTAN
-#ifdef _MPI
- ! Cell x-coordinates (in 3d Cartesian space)
- allocate(xCellField % ioinfo)
- xCellField % ioinfo % fieldName = 'xCell'
- xCellField % ioinfo % start(1) = readCellStart
- xCellField % ioinfo % count(1) = nReadCells
- allocate(xCellField % array(nReadCells))
- call io_input_field(input_obj, xCellField)
-
- ! Cell y-coordinates (in 3d Cartesian space)
- allocate(yCellField % ioinfo)
- yCellField % ioinfo % fieldName = 'yCell'
- yCellField % ioinfo % start(1) = readCellStart
- yCellField % ioinfo % count(1) = nReadCells
- allocate(yCellField % array(nReadCells))
- call io_input_field(input_obj, yCellField)
-
- ! Cell z-coordinates (in 3d Cartesian space)
- allocate(zCellField % ioinfo)
- zCellField % ioinfo % fieldName = 'zCell'
- zCellField % ioinfo % start(1) = readCellStart
- zCellField % ioinfo % count(1) = nReadCells
- allocate(zCellField % array(nReadCells))
- call io_input_field(input_obj, zCellField)
-#endif
-#endif
-
-
- ! Global edge indices
- allocate(indexToEdgeIDField % ioinfo)
- indexToEdgeIDField % ioinfo % fieldName = 'indexToEdgeID'
- indexToEdgeIDField % ioinfo % start(1) = readEdgeStart
- indexToEdgeIDField % ioinfo % count(1) = nReadEdges
- allocate(indexToEdgeIDField % array(nReadEdges))
- call io_input_field(input_obj, indexToEdgeIDField)
-
-#ifdef HAVE_ZOLTAN
-#ifdef _MPI
- ! Edge x-coordinates (in 3d Cartesian space)
- allocate(xEdgeField % ioinfo)
- xEdgeField % ioinfo % fieldName = 'xEdge'
- xEdgeField % ioinfo % start(1) = readEdgeStart
- xEdgeField % ioinfo % count(1) = nReadEdges
- allocate(xEdgeField % array(nReadEdges))
- call io_input_field(input_obj, xEdgeField)
-
- ! Edge y-coordinates (in 3d Cartesian space)
- allocate(yEdgeField % ioinfo)
- yEdgeField % ioinfo % fieldName = 'yEdge'
- yEdgeField % ioinfo % start(1) = readEdgeStart
- yEdgeField % ioinfo % count(1) = nReadEdges
- allocate(yEdgeField % array(nReadEdges))
- call io_input_field(input_obj, yEdgeField)
-
- ! Edge z-coordinates (in 3d Cartesian space)
- allocate(zEdgeField % ioinfo)
- zEdgeField % ioinfo % fieldName = 'zEdge'
- zEdgeField % ioinfo % start(1) = readEdgeStart
- zEdgeField % ioinfo % count(1) = nReadEdges
- allocate(zEdgeField % array(nReadEdges))
- call io_input_field(input_obj, zEdgeField)
-#endif
-#endif
-
- ! Global vertex indices
- allocate(indexToVertexIDField % ioinfo)
- indexToVertexIDField % ioinfo % fieldName = 'indexToVertexID'
- indexToVertexIDField % ioinfo % start(1) = readVertexStart
- indexToVertexIDField % ioinfo % count(1) = nReadVertices
- allocate(indexToVertexIDField % array(nReadVertices))
- call io_input_field(input_obj, indexToVertexIDField)
-
-#ifdef HAVE_ZOLTAN
-#ifdef _MPI
- ! Vertex x-coordinates (in 3d Cartesian space)
- allocate(xVertexField % ioinfo)
- xVertexField % ioinfo % fieldName = 'xVertex'
- xVertexField % ioinfo % start(1) = readVertexStart
- xVertexField % ioinfo % count(1) = nReadVertices
- allocate(xVertexField % array(nReadVertices))
- call io_input_field(input_obj, xVertexField)
-
- ! Vertex y-coordinates (in 3d Cartesian space)
- allocate(yVertexField % ioinfo)
- yVertexField % ioinfo % fieldName = 'yVertex'
- yVertexField % ioinfo % start(1) = readVertexStart
- yVertexField % ioinfo % count(1) = nReadVertices
- allocate(yVertexField % array(nReadVertices))
- call io_input_field(input_obj, yVertexField)
-
- ! Vertex z-coordinates (in 3d Cartesian space)
- allocate(zVertexField % ioinfo)
- zVertexField % ioinfo % fieldName = 'zVertex'
- zVertexField % ioinfo % start(1) = readVertexStart
- zVertexField % ioinfo % count(1) = nReadVertices
- allocate(zVertexField % array(nReadVertices))
- call io_input_field(input_obj, zVertexField)
-#endif
-#endif
-
- ! Number of cell/edges/vertices adjacent to each cell
- allocate(nEdgesOnCellField % ioinfo)
- nEdgesOnCellField % ioinfo % fieldName = 'nEdgesOnCell'
- nEdgesOnCellField % ioinfo % start(1) = readCellStart
- nEdgesOnCellField % ioinfo % count(1) = nReadCells
- allocate(nEdgesOnCellField % array(nReadCells))
- call io_input_field(input_obj, nEdgesOnCellField)
-
- ! Global indices of cells adjacent to each cell
- allocate(cellsOnCellField % ioinfo)
- cellsOnCellField % ioinfo % fieldName = 'cellsOnCell'
- cellsOnCellField % ioinfo % start(1) = 1
- cellsOnCellField % ioinfo % start(2) = readCellStart
- cellsOnCellField % ioinfo % count(1) = maxEdges
- cellsOnCellField % ioinfo % count(2) = nReadCells
- allocate(cellsOnCellField % array(maxEdges,nReadCells))
- call io_input_field(input_obj, cellsOnCellField)
-
- ! Global indices of edges adjacent to each cell
- allocate(edgesOnCellField % ioinfo)
- edgesOnCellField % ioinfo % fieldName = 'edgesOnCell'
- edgesOnCellField % ioinfo % start(1) = 1
- edgesOnCellField % ioinfo % start(2) = readCellStart
- edgesOnCellField % ioinfo % count(1) = maxEdges
- edgesOnCellField % ioinfo % count(2) = nReadCells
- allocate(edgesOnCellField % array(maxEdges,nReadCells))
- call io_input_field(input_obj, edgesOnCellField)
-
- ! Global indices of vertices adjacent to each cell
- allocate(verticesOnCellField % ioinfo)
- verticesOnCellField % ioinfo % fieldName = 'verticesOnCell'
- verticesOnCellField % ioinfo % start(1) = 1
- verticesOnCellField % ioinfo % start(2) = readCellStart
- verticesOnCellField % ioinfo % count(1) = maxEdges
- verticesOnCellField % ioinfo % count(2) = nReadCells
- allocate(verticesOnCellField % array(maxEdges,nReadCells))
- call io_input_field(input_obj, verticesOnCellField)
-
- ! Global indices of cells adjacent to each edge
- ! used for determining which edges are owned by a block, where
- ! iEdge is owned iff cellsOnEdge(1,iEdge) is an owned cell
- allocate(cellsOnEdgeField % ioinfo)
- cellsOnEdgeField % ioinfo % fieldName = 'cellsOnEdge'
- cellsOnEdgeField % ioinfo % start(1) = 1
- cellsOnEdgeField % ioinfo % start(2) = readEdgeStart
- cellsOnEdgeField % ioinfo % count(1) = 2
- cellsOnEdgeField % ioinfo % count(2) = nReadEdges
- allocate(cellsOnEdgeField % array(2,nReadEdges))
- call io_input_field(input_obj, cellsOnEdgeField)
-
- ! Global indices of cells adjacent to each vertex
- ! used for determining which vertices are owned by a block, where
- ! iVtx is owned iff cellsOnVertex(1,iVtx) is an owned cell
- allocate(cellsOnVertexField % ioinfo)
- cellsOnVertexField % ioinfo % fieldName = 'cellsOnVertex'
- cellsOnVertexField % ioinfo % start(1) = 1
- cellsOnVertexField % ioinfo % start(2) = readVertexStart
- cellsOnVertexField % ioinfo % count(1) = vertexDegree
- cellsOnVertexField % ioinfo % count(2) = nReadVertices
- allocate(cellsOnVertexField % array(vertexDegree,nReadVertices))
- call io_input_field(input_obj, cellsOnVertexField)
-
-
- !
- ! Set up a graph derived data type describing the connectivity for the cells
- ! that were read by this process
- ! A partial description is passed to the block decomp module by each process,
- ! and the block decomp module returns with a list of global cell indices
- ! that belong to the block on this process
- !
- partial_global_graph_info % nVertices = nReadCells
- partial_global_graph_info % nVerticesTotal = nCells
- partial_global_graph_info % maxDegree = maxEdges
- partial_global_graph_info % ghostStart = nVertices+1
- allocate(partial_global_graph_info % vertexID(nReadCells))
- allocate(partial_global_graph_info % nAdjacent(nReadCells))
- allocate(partial_global_graph_info % adjacencyList(maxEdges, nReadCells))
-
- partial_global_graph_info % vertexID(:) = indexToCellIDField % array(:)
- partial_global_graph_info % nAdjacent(:) = nEdgesOnCellField % array(:)
- partial_global_graph_info % adjacencyList(:,:) = cellsOnCellField % array(:,:)
-
-
- ! TODO: Ensure (by renaming or exchanging) that initial cell range on each proc is contiguous
- ! This situation may occur when reading a restart file with cells/edges/vertices written
- ! in a scrambled order
-
-
- ! Determine which cells are owned by this process
- call block_decomp_cells_for_proc(domain % dminfo, partial_global_graph_info, local_cell_list)
-
- deallocate(partial_global_graph_info % vertexID)
- deallocate(partial_global_graph_info % nAdjacent)
- deallocate(partial_global_graph_info % adjacencyList)
-
-
- allocate(indexToCellID_0Halo(size(local_cell_list)))
- allocate(nEdgesOnCell_0Halo(size(local_cell_list)))
- allocate(cellsOnCell_0Halo(maxEdges, size(local_cell_list)))
-
-#ifdef HAVE_ZOLTAN
-#ifdef _MPI
- allocate(xCell(size(local_cell_list)))
- allocate(yCell(size(local_cell_list)))
- allocate(zCell(size(local_cell_list)))
-#endif
-#endif
-
- !
- ! Now that each process has a list of cells that it owns, exchange cell connectivity
- ! information between the processes that read info for a cell and those that own that cell
- !
- call dmpar_get_owner_list(domain % dminfo, &
- size(indexToCellIDField % array), size(local_cell_list), &
- indexToCellIDField % array, local_cell_list, &
- sendCellList, recvCellList)
-
- call dmpar_alltoall_field(domain % dminfo, indexToCellIDField % array, indexToCellID_0Halo, &
- size(indexToCellIDField % array), size(local_cell_list), &
- sendCellList, recvCellList)
-
- call dmpar_alltoall_field(domain % dminfo, nEdgesOnCellField % array, nEdgesOnCell_0Halo, &
- size(indexToCellIDField % array), size(local_cell_list), &
- sendCellList, recvCellList)
-
- call dmpar_alltoall_field(domain % dminfo, cellsOnCellField % array, cellsOnCell_0Halo, &
- size(cellsOnCellField % array, 1), size(indexToCellIDField % array), size(local_cell_list), &
- sendCellList, recvCellList)
-
-#ifdef HAVE_ZOLTAN
-#ifdef _MPI
- call dmpar_alltoall_field(domain % dminfo, xCellField % array, xCell, &
- size(xCellField % array), size(local_cell_list), &
- sendCellList, recvCellList)
-
- call dmpar_alltoall_field(domain % dminfo, yCellField % array, yCell, &
- size(yCellField % array), size(local_cell_list), &
- sendCellList, recvCellList)
-
- call dmpar_alltoall_field(domain % dminfo, zCellField % array, zCell, &
- size(zCellField % array), size(local_cell_list), &
- sendCellList, recvCellList)
-#endif
-#endif
-
-
- deallocate(sendCellList % list)
- deallocate(sendCellList)
- deallocate(recvCellList % list)
- deallocate(recvCellList)
-
-
-
- !
- ! Build a graph of cell connectivity based on cells owned by this process
- !
- block_graph_0Halo % nVerticesTotal = size(local_cell_list)
- block_graph_0Halo % nVertices = size(local_cell_list)
- block_graph_0Halo % maxDegree = maxEdges
- block_graph_0Halo % ghostStart = size(local_cell_list) + 1
- allocate(block_graph_0Halo % vertexID(size(local_cell_list)))
- allocate(block_graph_0Halo % nAdjacent(size(local_cell_list)))
- allocate(block_graph_0Halo % adjacencyList(maxEdges, size(local_cell_list)))
-
- block_graph_0Halo % vertexID(:) = indexToCellID_0Halo(:)
- block_graph_0Halo % nAdjacent(:) = nEdgesOnCell_0Halo(:)
- block_graph_0Halo % adjacencyList(:,:) = cellsOnCell_0Halo(:,:)
-
- ! Get back a graph describing the owned cells plus the cells in the 1-halo
- call block_decomp_add_halo(domain % dminfo, block_graph_0Halo, block_graph_1Halo)
-
-
- !
- ! Work out exchange lists for 1-halo and exchange cell information for 1-halo
- !
- call dmpar_get_owner_list(domain % dminfo, &
- block_graph_0Halo % nVertices, block_graph_1Halo % nVerticesTotal, &
- block_graph_0Halo % vertexID, block_graph_1Halo % vertexID, &
- send1Halo, recv1Halo)
-
- call dmpar_alltoall_field(domain % dminfo, block_graph_0Halo % vertexID, block_graph_1Halo % vertexID, &
- block_graph_0Halo % nVertices, block_graph_1Halo % nVerticesTotal, &
- send1Halo, recv1Halo)
-
- call dmpar_alltoall_field(domain % dminfo, block_graph_0Halo % nAdjacent, block_graph_1Halo % nAdjacent, &
- block_graph_0Halo % nVertices, block_graph_1Halo % nVerticesTotal, &
- send1Halo, recv1Halo)
-
- call dmpar_alltoall_field(domain % dminfo, block_graph_0Halo % adjacencyList, block_graph_1Halo % adjacencyList, &
- block_graph_0Halo % maxDegree, block_graph_0Halo % nVertices, block_graph_1Halo % nVerticesTotal, &
- send1Halo, recv1Halo)
-
-
- !
- ! Work out exchange lists for 2-halo and exchange cell information for 2-halo
- !
- block_graph_1Halo % nVertices = block_graph_1Halo % nVerticesTotal
- block_graph_1Halo % ghostStart = block_graph_1Halo % nVerticesTotal + 1
-
- ! Get back a graph describing the owned and 1-halo cells plus the cells in the 2-halo
- call block_decomp_add_halo(domain % dminfo, block_graph_1Halo, block_graph_2Halo)
-
- block_graph_2Halo % nVertices = block_graph_0Halo % nVertices
- block_graph_2Halo % ghostStart = block_graph_2Halo % nVertices + 1
-
-#ifdef HAVE_ZOLTAN
-#ifdef _MPI
- !! For now, only use Zoltan with MPI
- !! Zoltan initialization
- call zoltanStart()
-
- !! Zoltan hook for cells
- call zoltanOrderLocHSFC_Cells(block_graph_2Halo%nVertices,block_graph_2Halo%VertexID,3,xCell,yCell,zCell)
-#endif
-#endif
-
- call dmpar_get_owner_list(domain % dminfo, &
- block_graph_0Halo % nVertices, block_graph_2Halo % nVerticesTotal, &
- block_graph_0Halo % vertexID, block_graph_2Halo % vertexID, &
- send2Halo, recv2Halo)
-
- call dmpar_alltoall_field(domain % dminfo, block_graph_0Halo % vertexID, block_graph_2Halo % vertexID, &
- block_graph_0Halo % nVertices, block_graph_2Halo % nVerticesTotal, &
- send2Halo, recv2Halo)
-
- call dmpar_alltoall_field(domain % dminfo, block_graph_0Halo % nAdjacent, block_graph_2Halo % nAdjacent, &
- block_graph_0Halo % nVertices, block_graph_2Halo % nVerticesTotal, &
- send2Halo, recv2Halo)
-
- call dmpar_alltoall_field(domain % dminfo, block_graph_0Halo % adjacencyList, block_graph_2Halo % adjacencyList, &
- block_graph_0Halo % maxDegree, block_graph_0Halo % nVertices, block_graph_2Halo % nVerticesTotal, &
- send2Halo, recv2Halo)
-
-
-
- !
- ! Knowing which cells are in block and the 2-halo, we can exchange lists of which edges are
- ! on each cell and which vertices are on each cell from the processes that read these
- ! fields for each cell to the processes that own the cells
- !
- allocate(edgesOnCell_2Halo(maxEdges, block_graph_2Halo % nVerticesTotal))
- allocate(verticesOnCell_2Halo(maxEdges, block_graph_2Halo % nVerticesTotal))
-
- call dmpar_get_owner_list(domain % dminfo, &
- size(indexToCellIDField % array), block_graph_2Halo % nVerticesTotal, &
- indexToCellIDField % array, block_graph_2Halo % vertexID, &
- sendCellList, recvCellList)
-
- call dmpar_alltoall_field(domain % dminfo, edgesOnCellField % array, edgesOnCell_2Halo, &
- maxEdges, nReadCells, block_graph_2Halo % nVerticesTotal, &
- sendCellList, recvCellList)
-
- call dmpar_alltoall_field(domain % dminfo, verticesOnCellField % array, verticesOnCell_2Halo, &
- maxEdges, nReadCells, block_graph_2Halo % nVerticesTotal, &
- sendCellList, recvCellList)
-
-
- !
- ! Get a list of which edges and vertices are adjacent to cells (including halo cells) in block
- !
- call block_decomp_all_edges_in_block(maxEdges, block_graph_2Halo % nVerticesTotal, block_graph_2Halo % nAdjacent, &
- edgesOnCell_2Halo, nlocal_edges, local_edge_list)
- call block_decomp_all_edges_in_block(maxEdges, block_graph_2Halo % nVerticesTotal, block_graph_2Halo % nAdjacent, &
- verticesOnCell_2Halo, nlocal_vertices, local_vertex_list)
-
- call dmpar_get_owner_list(domain % dminfo, &
- size(indexToEdgeIDField % array), nlocal_edges, &
- indexToEdgeIDField % array, local_edge_list, &
- sendEdgeList, recvEdgeList)
-
- call dmpar_get_owner_list(domain % dminfo, &
- size(indexToVertexIDField % array), nlocal_vertices, &
- indexToVertexIDField % array, local_vertex_list, &
- sendVertexList, recvVertexList)
-
-
-
- !
- ! Work out which edges and vertices are owned by this process, and which are ghost
- !
- allocate(cellsOnEdge_2Halo(2,nlocal_edges))
- allocate(cellsOnVertex_2Halo(vertexDegree,nlocal_vertices))
-
- call dmpar_alltoall_field(domain % dminfo, cellsOnEdgeField % array, cellsOnEdge_2Halo, &
- 2, size(cellsOnEdgeField % array, 2), nlocal_edges, &
- sendEdgeList, recvEdgeList)
-
- call dmpar_alltoall_field(domain % dminfo, cellsOnVertexField % array, cellsOnVertex_2Halo, &
- vertexDegree, size(cellsOnVertexField % array, 2), nlocal_vertices, &
- sendVertexList, recvVertexList)
-
-
- call block_decomp_partitioned_edge_list(block_graph_2Halo % nVertices, &
- block_graph_2Halo % vertexID(1:block_graph_2Halo % nVertices), &
- 2, nlocal_edges, cellsOnEdge_2Halo, local_edge_list, ghostEdgeStart)
- call block_decomp_partitioned_edge_list(block_graph_2Halo % nVertices, &
- block_graph_2Halo % vertexID(1:block_graph_2Halo % nVertices), &
- vertexDegree, nlocal_vertices, cellsOnVertex_2Halo, local_vertex_list, ghostVertexStart)
-
-
- ! At this point, local_edge_list(1;ghostEdgeStart-1) contains all of the owned edges for this block
- ! and local_edge_list(ghostEdgeStart:nlocal_edges) contains all of the ghost edges
-
- ! At this point, local_vertex_list(1;ghostVertexStart-1) contains all of the owned vertices for this block
- ! and local_vertex_list(ghostVertexStart:nlocal_vertices) contains all of the ghost vertices
-
- ! Also, at this point, block_graph_2Halo % vertexID(1:block_graph_2Halo%nVertices) contains all of the owned
- ! cells for this block, and block_graph_2Halo % vertexID(block_graph_2Halo%nVertices+1:block_graph_2Halo%nVerticesTotal)
- ! contains all of the ghost cells
-
-
- deallocate(sendEdgeList % list)
- deallocate(sendEdgeList)
- deallocate(recvEdgeList % list)
- deallocate(recvEdgeList)
-
- deallocate(sendVertexList % list)
- deallocate(sendVertexList)
- deallocate(recvVertexList % list)
- deallocate(recvVertexList)
-
-#ifdef HAVE_ZOLTAN
-#ifdef _MPI
- allocate(xEdge(nlocal_edges))
- allocate(yEdge(nlocal_edges))
- allocate(zEdge(nlocal_edges))
- allocate(xVertex(nlocal_vertices))
- allocate(yVertex(nlocal_vertices))
- allocate(zVertex(nlocal_vertices))
-#endif
-#endif
-
- !
- ! Knowing which edges/vertices are owned by this block and which are actually read
- ! from the input or restart file, we can build exchange lists to perform
- ! all-to-all field exchanges from process that reads a field to the processes that
- ! need them
- !
- call dmpar_get_owner_list(domain % dminfo, &
- size(indexToEdgeIDField % array), nlocal_edges, &
- indexToEdgeIDField % array, local_edge_list, &
- sendEdgeList, recvEdgeList)
-
- call dmpar_get_owner_list(domain % dminfo, &
- size(indexToVertexIDField % array), nlocal_vertices, &
- indexToVertexIDField % array, local_vertex_list, &
- sendVertexList, recvVertexList)
-
-#ifdef HAVE_ZOLTAN
-#ifdef _MPI
- call dmpar_alltoall_field(domain % dminfo, xEdgeField % array, xEdge, &
- size(xEdgeField % array), nlocal_edges, &
- sendEdgeList, recvEdgeList)
- call dmpar_alltoall_field(domain % dminfo, yEdgeField % array, yEdge, &
- size(yEdgeField % array), nlocal_edges, &
- sendEdgeList, recvEdgeList)
- call dmpar_alltoall_field(domain % dminfo, zEdgeField % array, zEdge, &
- size(zEdgeField % array), nlocal_edges, &
- sendEdgeList, recvEdgeList)
-
- call dmpar_alltoall_field(domain % dminfo, xVertexField % array, xVertex, &
- size(xVertexField % array), nlocal_vertices, &
- sendVertexList, recvVertexList)
- call dmpar_alltoall_field(domain % dminfo, yVertexField % array, yVertex, &
- size(yVertexField % array), nlocal_vertices, &
- sendVertexList, recvVertexList)
- call dmpar_alltoall_field(domain % dminfo, zVertexField % array, zVertex, &
- size(zVertexField % array), nlocal_vertices, &
- sendVertexList, recvVertexList)
- !!!!!!!!!!!!!!!!!!
- !! Reorder edges
- !!!!!!!!!!!!!!!!!!
- call zoltanOrderLocHSFC_Edges(ghostEdgeStart-1,local_edge_list,3,xEdge,yEdge,zEdge)
- !!!!!!!!!!!!!!!!!!
-
- !!!!!!!!!!!!!!!!!!
- !! Reorder vertices
- !!!!!!!!!!!!!!!!!!
- call zoltanOrderLocHSFC_Verts(ghostVertexStart-1,local_vertex_list,3,xVertex,yVertex,zVertex)
- !!!!!!!!!!!!!!!!!!
-
- deallocate(sendEdgeList % list)
- deallocate(sendEdgeList)
- deallocate(recvEdgeList % list)
- deallocate(recvEdgeList)
-
- deallocate(sendVertexList % list)
- deallocate(sendVertexList)
- deallocate(recvVertexList % list)
- deallocate(recvVertexList)
-
- !
- ! Knowing which edges/vertices are owned by this block and which are actually read
- ! from the input or restart file, we can build exchange lists to perform
- ! all-to-all field exchanges from process that reads a field to the processes that
- ! need them
- !
- call dmpar_get_owner_list(domain % dminfo, &
- size(indexToEdgeIDField % array), nlocal_edges, &
- indexToEdgeIDField % array, local_edge_list, &
- sendEdgeList, recvEdgeList)
-
- call dmpar_get_owner_list(domain % dminfo, &
- size(indexToVertexIDField % array), nlocal_vertices, &
- indexToVertexIDField % array, local_vertex_list, &
- sendVertexList, recvVertexList)
-
-#endif
-#endif
-
- !
- ! Build ownership and exchange lists for vertical levels
- ! Essentially, process 0 owns all vertical levels when reading and writing,
- ! and it distributes them or gathers them to/from all other processes
- !
- if (domain % dminfo % my_proc_id == 0) then
- allocate(local_vertlevel_list(nVertLevels))
- do i=1,nVertLevels
- local_vertlevel_list(i) = i
- end do
- else
- allocate(local_vertlevel_list(0))
- end if
- allocate(needed_vertlevel_list(nVertLevels))
- do i=1,nVertLevels
- needed_vertlevel_list(i) = i
- end do
-
- call dmpar_get_owner_list(domain % dminfo, &
- size(local_vertlevel_list), size(needed_vertlevel_list), &
- local_vertlevel_list, needed_vertlevel_list, &
- sendVertLevelList, recvVertLevelList)
-
- deallocate(local_vertlevel_list)
- deallocate(needed_vertlevel_list)
-
-
- !
- ! Read and distribute all fields given ownership lists and exchange lists (maybe already in block?)
- !
- allocate(domain % blocklist)
-
- nCells = block_graph_2Halo % nVerticesTotal
- nEdges = nlocal_edges
- nVertices = nlocal_vertices
-
- call allocate_block(domain % blocklist, domain, &
-#include "dim_dummy_args.inc"
- )
-
- !
- ! Read attributes
- !
- call io_input_get_att_text(input_obj, 'on_a_sphere', c_on_a_sphere)
- call io_input_get_att_real(input_obj, 'sphere_radius', r_sphere_radius)
- if (index(c_on_a_sphere, 'YES') /= 0) then
- domain % blocklist % mesh % on_a_sphere = .true.
- else
- domain % blocklist % mesh % on_a_sphere = .false.
- end if
- domain % blocklist % mesh % sphere_radius = r_sphere_radius
-
- if (.not. config_do_restart) then
- input_obj % time = 1
- else
- input_obj % time = 1
-
- !
- ! If doing a restart, we need to decide which time slice to read from the
- ! restart file
- !
- if (input_obj % rdLocalTime <= 0) then
- write(0,*) 'Error: Couldn''t find any times in restart file.'
- call dmpar_abort(domain % dminfo)
- end if
- if (domain % dminfo % my_proc_id == IO_NODE) then
- allocate(xtime % ioinfo)
- xtime % ioinfo % start(1) = 1
- xtime % ioinfo % count(1) = input_obj % rdLocalTime
- allocate(xtime % array(input_obj % rdLocalTime))
-
- xtime % ioinfo % fieldName = 'xtime'
- call io_input_field(input_obj, xtime)
-
- call MPAS_setTimeInterval(interval=minTimeDiff, DD=10000)
- call MPAS_setTime(curr_time=startTime, dateTimeString=config_start_time)
-
- do i=1,input_obj % rdLocalTime
- call MPAS_setTime(curr_time=sliceTime, dateTimeString=xtime % array(i))
- timeDiff = abs(sliceTime - startTime)
- if (timeDiff < minTimeDiff) then
- minTimeDiff = timeDiff
- input_obj % time = i
- end if
- end do
-
- timeStamp = xtime % array(input_obj % time)
-
- deallocate(xtime % ioinfo)
- deallocate(xtime % array)
- end if
-
- call dmpar_bcast_int(domain % dminfo, input_obj % time)
- call dmpar_bcast_char(domain % dminfo, timeStamp)
-
- write(0,*) 'Restarting model from time ', timeStamp
-
- end if
-
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Do the actual work of reading all fields in from the input or restart file
- ! For each field:
- ! 1) Each process reads a contiguous range of cell/edge/vertex indices, which
- ! may not correspond with the cells/edges/vertices that are owned by the
- ! process
- ! 2) All processes then send the global indices that were read to the
- ! processes that own those indices based on
- ! {send,recv}{Cell,Edge,Vertex,VertLevel}List
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- call read_and_distribute_fields(domain % dminfo, input_obj, domain % blocklist, &
- readCellStart, nReadCells, readEdgeStart, nReadEdges, readVertexStart, nReadVertices, &
- readVertLevelStart, nReadVertLevels, &
- sendCellList, recvCellList, sendEdgeList, recvEdgeList, sendVertexList, recvVertexList, &
- sendVertLevelList, recvVertLevelList)
-
-
- call io_input_finalize(input_obj, domain % dminfo)
-
-
- !
- ! Rename vertices in cellsOnCell, edgesOnCell, etc. to local indices
- !
- allocate(cellIDSorted(2,domain % blocklist % mesh % nCells))
- allocate(edgeIDSorted(2,domain % blocklist % mesh % nEdges))
- allocate(vertexIDSorted(2,domain % blocklist % mesh % nVertices))
-
- do i=1,domain % blocklist % mesh % nCells
- cellIDSorted(1,i) = domain % blocklist % mesh % indexToCellID % array(i)
- cellIDSorted(2,i) = i
- end do
- call quicksort(block_graph_2Halo % nVerticesTotal, cellIDSorted)
-
- do i=1,domain % blocklist % mesh % nEdges
- edgeIDSorted(1,i) = domain % blocklist % mesh % indexToEdgeID % array(i)
- edgeIDSorted(2,i) = i
- end do
- call quicksort(nlocal_edges, edgeIDSorted)
-
- do i=1,domain % blocklist % mesh % nVertices
- vertexIDSorted(1,i) = domain % blocklist % mesh % indexToVertexID % array(i)
- vertexIDSorted(2,i) = i
- end do
- call quicksort(nlocal_vertices, vertexIDSorted)
-
-
- do i=1,domain % blocklist % mesh % nCells
- do j=1,domain % blocklist % mesh % nEdgesOnCell % array(i)
-
- k = binary_search(cellIDSorted, 2, 1, domain % blocklist % mesh % nCells, &
- domain % blocklist % mesh % cellsOnCell % array(j,i))
- if (k <= domain % blocklist % mesh % nCells) then
- domain % blocklist % mesh % cellsOnCell % array(j,i) = cellIDSorted(2,k)
- else
- domain % blocklist % mesh % cellsOnCell % array(j,i) = domain % blocklist % mesh % nCells + 1
-! domain % blocklist % mesh % cellsOnCell % array(j,i) = 0
- end if
-
- k = binary_search(edgeIDSorted, 2, 1, domain % blocklist % mesh % nEdges, &
- domain % blocklist % mesh % edgesOnCell % array(j,i))
- if (k <= domain % blocklist % mesh % nEdges) then
- domain % blocklist % mesh % edgesOnCell % array(j,i) = edgeIDSorted(2,k)
- else
- domain % blocklist % mesh % edgesOnCell % array(j,i) = domain % blocklist % mesh % nEdges + 1
-! domain % blocklist % mesh % edgesOnCell % array(j,i) = 0
- end if
-
- k = binary_search(vertexIDSorted, 2, 1, domain % blocklist % mesh % nVertices, &
- domain % blocklist % mesh % verticesOnCell % array(j,i))
- if (k <= domain % blocklist % mesh % nVertices) then
- domain % blocklist % mesh % verticesOnCell % array(j,i) = vertexIDSorted(2,k)
- else
- domain % blocklist % mesh % verticesOnCell % array(j,i) = domain % blocklist % mesh % nVertices + 1
-! domain % blocklist % mesh % verticesOnCell % array(j,i) = 0
- end if
-
- end do
- end do
-
- do i=1,domain % blocklist % mesh % nEdges
- do j=1,2
-
- k = binary_search(cellIDSorted, 2, 1, domain % blocklist % mesh % nCells, &
- domain % blocklist % mesh % cellsOnEdge % array(j,i))
- if (k <= domain % blocklist % mesh % nCells) then
- domain % blocklist % mesh % cellsOnEdge % array(j,i) = cellIDSorted(2,k)
- else
- domain % blocklist % mesh % cellsOnEdge % array(j,i) = domain % blocklist % mesh % nCells + 1
-! domain % blocklist % mesh % cellsOnEdge % array(j,i) = 0
- end if
-
- k = binary_search(vertexIDSorted, 2, 1, domain % blocklist % mesh % nVertices, &
- domain % blocklist % mesh % verticesOnEdge % array(j,i))
- if (k <= domain % blocklist % mesh % nVertices) then
- domain % blocklist % mesh % verticesOnEdge % array(j,i) = vertexIDSorted(2,k)
- else
- domain % blocklist % mesh % verticesOnEdge % array(j,i) = domain % blocklist % mesh % nVertices + 1
-! domain % blocklist % mesh % verticesOnEdge % array(j,i) = 0
- end if
-
- end do
-
- do j=1,domain % blocklist % mesh % nEdgesOnEdge % array(i)
-
- k = binary_search(edgeIDSorted, 2, 1, domain % blocklist % mesh % nEdges, &
- domain % blocklist % mesh % edgesOnEdge % array(j,i))
- if (k <= domain % blocklist % mesh % nEdges) then
- domain % blocklist % mesh % edgesOnEdge % array(j,i) = edgeIDSorted(2,k)
- else
- domain % blocklist % mesh % edgesOnEdge % array(j,i) = domain % blocklist % mesh % nEdges + 1
-! domain % blocklist % mesh % edgesOnEdge % array(j,i) = 0
- end if
-
- end do
- end do
-
- do i=1,domain % blocklist % mesh % nVertices
- do j=1,vertexDegree
-
- k = binary_search(cellIDSorted, 2, 1, domain % blocklist % mesh % nCells, &
- domain % blocklist % mesh % cellsOnVertex % array(j,i))
- if (k <= domain % blocklist % mesh % nCells) then
- domain % blocklist % mesh % cellsOnVertex % array(j,i) = cellIDSorted(2,k)
- else
- domain % blocklist % mesh % cellsOnVertex % array(j,i) = domain % blocklist % mesh % nCells + 1
-! domain % blocklist % mesh % cellsOnVertex % array(j,i) = 0
- end if
-
- k = binary_search(edgeIDSorted, 2, 1, domain % blocklist % mesh % nEdges, &
- domain % blocklist % mesh % edgesOnVertex % array(j,i))
- if (k <= domain % blocklist % mesh % nEdges) then
- domain % blocklist % mesh % edgesOnVertex % array(j,i) = edgeIDSorted(2,k)
- else
- domain % blocklist % mesh % edgesOnVertex % array(j,i) = domain % blocklist % mesh % nEdges + 1
-! domain % blocklist % mesh % edgesOnVertex % array(j,i) = 0
- end if
-
- end do
- end do
-
- deallocate(cellIDSorted)
- deallocate(edgeIDSorted)
- deallocate(vertexIDSorted)
-
-
- !
- ! Work out halo exchange lists for cells, edges, and vertices
- !
- call dmpar_get_owner_list(domain % dminfo, &
- block_graph_2Halo % nVertices, block_graph_2Halo % nVerticesTotal, &
- block_graph_2Halo % vertexID(1:block_graph_2Halo % nVertices), block_graph_2Halo % vertexID, &
- domain % blocklist % parinfo % cellsToSend, domain % blocklist % parinfo % cellsToRecv)
-
- call dmpar_get_owner_list(domain % dminfo, &
- ghostEdgeStart-1, nlocal_edges, &
- local_edge_list(1:ghostEdgeStart-1), local_edge_list, &
- domain % blocklist % parinfo % edgesToSend, domain % blocklist % parinfo % edgesToRecv)
-
- call dmpar_get_owner_list(domain % dminfo, &
- ghostVertexStart-1, nlocal_vertices, &
- local_vertex_list(1:ghostVertexStart-1), local_vertex_list, &
- domain % blocklist % parinfo % verticesToSend, domain % blocklist % parinfo % verticesToRecv)
-
- domain % blocklist % mesh % nCellsSolve = block_graph_2Halo % nVertices
- domain % blocklist % mesh % nEdgesSolve = ghostEdgeStart-1
- domain % blocklist % mesh % nVerticesSolve = ghostVertexStart-1
- domain % blocklist % mesh % nVertLevelsSolve = domain % blocklist % mesh % nVertLevels ! No vertical decomp yet...
-
-
- !
- ! Deallocate fields, graphs, and other memory
- !
- deallocate(indexToCellIDField % ioinfo)
- deallocate(indexToCellIDField % array)
-#ifdef HAVE_ZOLTAN
-#ifdef _MPI
- deallocate(xCellField % ioinfo)
- deallocate(xCellField % array)
- deallocate(yCellField % ioinfo)
- deallocate(yCellField % array)
- deallocate(zCellField % ioinfo)
- deallocate(zCellField % array)
-#endif
-#endif
- deallocate(indexToEdgeIDField % ioinfo)
- deallocate(indexToEdgeIDField % array)
- deallocate(indexToVertexIDField % ioinfo)
- deallocate(indexToVertexIDField % array)
- deallocate(cellsOnCellField % ioinfo)
- deallocate(cellsOnCellField % array)
- deallocate(edgesOnCellField % ioinfo)
- deallocate(edgesOnCellField % array)
- deallocate(verticesOnCellField % ioinfo)
- deallocate(verticesOnCellField % array)
- deallocate(cellsOnEdgeField % ioinfo)
- deallocate(cellsOnEdgeField % array)
- deallocate(cellsOnVertexField % ioinfo)
- deallocate(cellsOnVertexField % array)
- deallocate(cellsOnCell_0Halo)
- deallocate(nEdgesOnCell_0Halo)
- deallocate(indexToCellID_0Halo)
- deallocate(cellsOnEdge_2Halo)
- deallocate(cellsOnVertex_2Halo)
- deallocate(edgesOnCell_2Halo)
- deallocate(verticesOnCell_2Halo)
- deallocate(block_graph_0Halo % vertexID)
- deallocate(block_graph_0Halo % nAdjacent)
- deallocate(block_graph_0Halo % adjacencyList)
-#ifdef HAVE_ZOLTAN
-#ifdef _MPI
- deallocate(xCell)
- deallocate(yCell)
- deallocate(zCell)
-#endif
-#endif
- end subroutine input_state_for_domain
-
-
- subroutine read_and_distribute_fields(dminfo, input_obj, block, &
- readCellsStart, readCellsCount, &
- readEdgesStart, readEdgesCount, &
- readVerticesStart, readVerticesCount, &
- readVertLevelsStart, readVertLevelsCount, &
- sendCellsList, recvCellsList, &
- sendEdgesList, recvEdgesList, &
- sendVerticesList, recvVerticesList, &
- sendVertLevelsList, recvVertLevelsList)
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
- type (io_input_object), intent(in) :: input_obj
- type (block_type), intent(inout) :: block
- integer, intent(in) :: readCellsStart, readCellsCount, readEdgesStart, readEdgesCount, readVerticesStart, readVerticesCount
- integer, intent(in) :: readVertLevelsStart, readVertLevelsCount
- type (exchange_list), pointer :: sendCellsList, recvCellsList
- type (exchange_list), pointer :: sendEdgesList, recvEdgesList
- type (exchange_list), pointer :: sendVerticesList, recvVerticesList
- type (exchange_list), pointer :: sendVertLevelsList, recvVertLevelsList
-
- type (field1dInteger) :: int1d
- type (field2dInteger) :: int2d
- type (field0dReal) :: real0d
- type (field1dReal) :: real1d
- type (field2dReal) :: real2d
- type (field3dReal) :: real3d
- type (field0dChar) :: char0d
- type (field1dChar) :: char1d
-
- integer :: i1, i2, i3, i4
-
- integer, dimension(:), pointer :: super_int1d
- integer, dimension(:,:), pointer :: super_int2d
- real (kind=RKIND) :: super_real0d
- real (kind=RKIND), dimension(:), pointer :: super_real1d
- real (kind=RKIND), dimension(:,:), pointer :: super_real2d
- real (kind=RKIND), dimension(:,:,:), pointer :: super_real3d
- character (len=64) :: super_char0d
- character (len=64), dimension(:), pointer :: super_char1d
-
- integer :: i, k
-
-#include "nondecomp_dims.inc"
-
- allocate(int1d % ioinfo)
- allocate(int2d % ioinfo)
- allocate(real0d % ioinfo)
- allocate(real1d % ioinfo)
- allocate(real2d % ioinfo)
- allocate(real3d % ioinfo)
- allocate(char0d % ioinfo)
- allocate(char1d % ioinfo)
-
-
-#include "io_input_fields.inc"
-
-#include "nondecomp_dims_dealloc.inc"
-
- end subroutine read_and_distribute_fields
-
-
-
- subroutine io_input_init(input_obj, dminfo)
-
- implicit none
-
- type (io_input_object), intent(inout) :: input_obj
- type (dm_info), intent(in) :: dminfo
-
- include 'netcdf.inc'
-
- integer :: nferr
-
-
-#ifdef OFFSET64BIT
- nferr = nf_open(trim(input_obj % filename), ior(NF_SHARE,NF_64BIT_OFFSET), input_obj % rd_ncid)
-#else
- nferr = nf_open(trim(input_obj % filename), NF_SHARE, input_obj % rd_ncid)
-#endif
-
- if (nferr /= NF_NOERR) then
- write(0,*) ' '
- if (input_obj % stream == STREAM_RESTART) then
- write(0,*) 'Error opening restart file ''', trim(input_obj % filename), ''''
- else if (input_obj % stream == STREAM_INPUT) then
- write(0,*) 'Error opening input file ''', trim(input_obj % filename), ''''
- else if (input_obj % stream == STREAM_SFC) then
- write(0,*) 'Error opening sfc file ''', trim(input_obj % filename), ''''
- end if
- write(0,*) ' '
- call dmpar_abort(dminfo)
- end if
-
-#include "netcdf_read_ids.inc"
-
- end subroutine io_input_init
-
-
- subroutine io_input_get_dimension(input_obj, dimname, dimsize)
-
- implicit none
-
- type (io_input_object), intent(in) :: input_obj
- character (len=*), intent(in) :: dimname
- integer, intent(out) :: dimsize
-
-#include "get_dimension_by_name.inc"
-
- end subroutine io_input_get_dimension
-
-
- subroutine io_input_get_att_real(input_obj, attname, attvalue)
-
- implicit none
-
- type (io_input_object), intent(in) :: input_obj
- character (len=*), intent(in) :: attname
- real (kind=RKIND), intent(out) :: attvalue
-
- include 'netcdf.inc'
-
- integer :: nferr
-
- if (RKIND == 8) then
- nferr = nf_get_att_double(input_obj % rd_ncid, NF_GLOBAL, attname, attvalue)
- else
- nferr = nf_get_att_real(input_obj % rd_ncid, NF_GLOBAL, attname, attvalue)
- end if
- if (nferr /= NF_NOERR) then
- write(0,*) 'Warning: Attribute '//trim(attname)//&
- ' not found in '//trim(input_obj % filename)
- if (index(attname, 'sphere_radius') /= 0) then
- write(0,*) ' Setting '//trim(attname)//' to 1.0'
- attvalue = 1.0
- end if
- end if
-
- end subroutine io_input_get_att_real
-
-
- subroutine io_input_get_att_text(input_obj, attname, attvalue)
-
- implicit none
-
- type (io_input_object), intent(in) :: input_obj
- character (len=*), intent(in) :: attname
- character (len=*), intent(out) :: attvalue
-
- include 'netcdf.inc'
-
- integer :: nferr
-
- nferr = nf_get_att_text(input_obj % rd_ncid, NF_GLOBAL, attname, attvalue)
- if (nferr /= NF_NOERR) then
- write(0,*) 'Warning: Attribute '//trim(attname)//&
- ' not found in '//trim(input_obj % filename)
- if (index(attname, 'on_a_sphere') /= 0) then
- write(0,*) ' Setting '//trim(attname)//' to ''YES'''
- attvalue = 'YES'
- end if
- end if
-
- end subroutine io_input_get_att_text
-
-
- subroutine io_input_field0dReal(input_obj, field)
-
- implicit none
-
- type (io_input_object), intent(in) :: input_obj
- type (field0dReal), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(1) :: start1, count1
-
- start1(1) = 1
- count1(1) = 1
-
-#include "input_field0dreal.inc"
-
-#if (RKIND == 8)
- nferr = nf_get_vara_double(input_obj % rd_ncid, varID, start1, count1, field % scalar)
-#else
- nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start1, count1, field % scalar)
-#endif
-
- end subroutine io_input_field0dReal
-
-
- subroutine io_input_field1dReal(input_obj, field)
-
- implicit none
-
- type (io_input_object), intent(in) :: input_obj
- type (field1dReal), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(1) :: start1, count1
-
- start1(1) = field % ioinfo % start(1)
- count1(1) = field % ioinfo % count(1)
-
- !
- ! Special case: we may want to read the xtime variable across the
- ! time dimension as a 1d array.
- !
- if (trim(field % ioinfo % fieldName) == 'xtime') then
- varID = input_obj % rdVarIDxtime
- end if
-
-#include "input_field1dreal.inc"
-
-#if (RKIND == 8)
- nferr = nf_get_vara_double(input_obj % rd_ncid, varID, start1, count1, field % array)
-#else
- nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start1, count1, field % array)
-#endif
-
- end subroutine io_input_field1dReal
-
-
- subroutine io_input_field2dReal(input_obj, field)
-
- implicit none
-
- type (io_input_object), intent(in) :: input_obj
- type (field2dReal), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(2) :: start2, count2
-
- start2(1) = field % ioinfo % start(1)
- start2(2) = field % ioinfo % start(2)
- count2(1) = field % ioinfo % count(1)
- count2(2) = field % ioinfo % count(2)
-
-#include "input_field2dreal.inc"
-
-#if (RKIND == 8)
- nferr = nf_get_vara_double(input_obj % rd_ncid, varID, start2, count2, field % array)
-#else
- nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start2, count2, field % array)
-#endif
-
- end subroutine io_input_field2dReal
-
-
- subroutine io_input_field3dReal(input_obj, field)
-
- implicit none
-
- type (io_input_object), intent(in) :: input_obj
- type (field3dReal), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(3) :: start3, count3
-
- start3(1) = field % ioinfo % start(1)
- start3(2) = field % ioinfo % start(2)
- start3(3) = field % ioinfo % start(3)
- count3(1) = field % ioinfo % count(1)
- count3(2) = field % ioinfo % count(2)
- count3(3) = field % ioinfo % count(3)
-
-#include "input_field3dreal.inc"
-
-#if (RKIND == 8)
- nferr = nf_get_vara_double(input_obj % rd_ncid, varID, start3, count3, field % array)
-#else
- nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start3, count3, field % array)
-#endif
-
- end subroutine io_input_field3dReal
-
-
- subroutine io_input_field0dReal_time(input_obj, field)
-
- implicit none
-
- type (io_input_object), intent(in) :: input_obj
- type (field0dReal), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(1) :: start1, count1
-
- start1(1) = input_obj % time
- count1(1) = 1
-
-#include "input_field0dreal_time.inc"
-
-#if (RKIND == 8)
- nferr = nf_get_vara_double(input_obj % rd_ncid, varID, start1, count1, field % scalar)
-#else
- nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start1, count1, field % scalar)
-#endif
-
- end subroutine io_input_field0dReal_time
-
-
- subroutine io_input_field1dReal_time(input_obj, field)
-
- implicit none
-
- type (io_input_object), intent(in) :: input_obj
- type (field1dReal), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(2) :: start2, count2
-
- start2(1) = field % ioinfo % start(1)
- start2(2) = input_obj % time
- count2(1) = field % ioinfo % count(1)
- count2(2) = 1
-
-#include "input_field1dreal_time.inc"
-
-#if (RKIND == 8)
- nferr = nf_get_vara_double(input_obj % rd_ncid, varID, start2, count2, field % array)
-#else
- nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start2, count2, field % array)
-#endif
-
- end subroutine io_input_field1dReal_time
-
-
- subroutine io_input_field2dReal_time(input_obj, field)
-
- implicit none
-
- type (io_input_object), intent(in) :: input_obj
- type (field2dReal), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(3) :: start3, count3
-
- start3(1) = field % ioinfo % start(1)
- start3(2) = field % ioinfo % start(2)
- start3(3) = input_obj % time
- count3(1) = field % ioinfo % count(1)
- count3(2) = field % ioinfo % count(2)
- count3(3) = 1
-
-#include "input_field2dreal_time.inc"
-
-#if (RKIND == 8)
- nferr = nf_get_vara_double(input_obj % rd_ncid, varID, start3, count3, field % array)
-#else
- nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start3, count3, field % array)
-#endif
-
- end subroutine io_input_field2dReal_time
-
-
- subroutine io_input_field3dReal_time(input_obj, field)
-
- implicit none
-
- type (io_input_object), intent(in) :: input_obj
- type (field3dReal), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(4) :: start4, count4
-
- start4(1) = field % ioinfo % start(1)
- start4(2) = field % ioinfo % start(2)
- start4(3) = field % ioinfo % start(3)
- start4(4) = input_obj % time
- count4(1) = field % ioinfo % count(1)
- count4(2) = field % ioinfo % count(2)
- count4(3) = field % ioinfo % count(3)
- count4(4) = 1
-
-#include "input_field3dreal_time.inc"
-
-#if (RKIND == 8)
- nferr = nf_get_vara_double(input_obj % rd_ncid, varID, start4, count4, field % array)
-#else
- nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start4, count4, field % array)
-#endif
-
- end subroutine io_input_field3dReal_time
-
-
- subroutine io_input_field1dInteger(input_obj, field)
-
- implicit none
-
- type (io_input_object), intent(in) :: input_obj
- type (field1dInteger), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(1) :: start1, count1
-
- start1(1) = field % ioinfo % start(1)
- count1(1) = field % ioinfo % count(1)
-
-#include "input_field1dinteger.inc"
-
- nferr = nf_get_vara_int(input_obj % rd_ncid, varID, start1, count1, field % array)
-
- end subroutine io_input_field1dInteger
-
-
- subroutine io_input_field2dInteger(input_obj, field)
-
- implicit none
-
- type (io_input_object), intent(in) :: input_obj
- type (field2dInteger), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(2) :: start2, count2
-
- start2(1) = field % ioinfo % start(1)
- start2(2) = field % ioinfo % start(2)
- count2(1) = field % ioinfo % count(1)
- count2(2) = field % ioinfo % count(2)
-
-#include "input_field2dinteger.inc"
-
- nferr = nf_get_vara_int(input_obj % rd_ncid, varID, start2, count2, field % array)
-
- end subroutine io_input_field2dInteger
-
-
- subroutine io_input_field1dInteger_time(input_obj, field)
-
- implicit none
-
- type (io_input_object), intent(in) :: input_obj
- type (field1dInteger), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(2) :: start2, count2
-
- start2(1) = field % ioinfo % start(1)
- start2(2) = input_obj % time
- count2(1) = field % ioinfo % count(1)
- count2(2) = 1
-
-#include "input_field1dinteger_time.inc"
-
- nferr = nf_get_vara_int(input_obj % rd_ncid, varID, start2, count2, field % array)
-
- end subroutine io_input_field1dInteger_time
-
-
- subroutine io_input_field0dChar_time(input_obj, field)
-
- implicit none
-
- type (io_input_object), intent(in) :: input_obj
- type (field0dChar), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(2) :: start1, count1
-
- start1(1) = 1
- count1(1) = 64
- start1(2) = input_obj % time
- count1(2) = 1
-
-#include "input_field0dchar_time.inc"
-
- nferr = nf_get_vara_text(input_obj % rd_ncid, varID, start1, count1, field % scalar)
-
- end subroutine io_input_field0dChar_time
-
-
- subroutine io_input_field1dChar_time(input_obj, field)
-
- implicit none
-
- type (io_input_object), intent(in) :: input_obj
- type (field1dChar), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(3) :: start2, count2
-
- start2(1) = 1
- start2(2) = field % ioinfo % start(1)
- start2(3) = input_obj % time
- count2(1) = 64
- count2(2) = field % ioinfo % count(1)
- count2(3) = 1
-
-#include "input_field1dchar_time.inc"
-
- nferr = nf_get_vara_text(input_obj % rd_ncid, varID, start2, count2, field % array)
-
- end subroutine io_input_field1dChar_time
-
-
- subroutine io_input_field0dChar(input_obj, field)
-
- implicit none
-
- type (io_input_object), intent(in) :: input_obj
- type (field0dChar), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(2) :: start1, count1
-
- start1(1) = 1
- count1(1) = 64
- start1(2) = 1
- count1(2) = 1
-
-#include "input_field0dchar.inc"
-
- nferr = nf_get_vara_text(input_obj % rd_ncid, varID, start1, count1, field % scalar)
-
- end subroutine io_input_field0dChar
-
-
- subroutine io_input_field1dChar(input_obj, field)
-
- implicit none
-
- type (io_input_object), intent(in) :: input_obj
- type (field1dChar), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(2) :: start1, count1
-
- start1(1) = 1
- count1(1) = 64
- start1(2) = field % ioinfo % start(1)
- count1(2) = field % ioinfo % count(1)
-
- !
- ! Special case: we may want to read the xtime variable across the
- ! time dimension as a 1d array.
- !
- if (trim(field % ioinfo % fieldName) == 'xtime') then
- varID = input_obj % rdVarIDxtime
- end if
-
-#include "input_field1dchar.inc"
-
- nferr = nf_get_vara_text(input_obj % rd_ncid, varID, start1, count1, field % array)
-
- end subroutine io_input_field1dChar
-
-
- subroutine io_input_finalize(input_obj, dminfo)
-
- implicit none
-
- type (io_input_object), intent(inout) :: input_obj
- type (dm_info), intent(in) :: dminfo
-
- include 'netcdf.inc'
-
- integer :: nferr
-
- nferr = nf_close(input_obj % rd_ncid)
-
- end subroutine io_input_finalize
-
-end module io_input
Deleted: trunk/mpas/src/framework/module_io_output.F
===================================================================
--- trunk/mpas/src/framework/module_io_output.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/framework/module_io_output.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -1,866 +0,0 @@
-module io_output
-
- use grid_types
- use dmpar
- use sort
- use configure
-
- integer, parameter :: OUTPUT = 1
- integer, parameter :: RESTART = 2
- integer, parameter :: SFC = 3
-
- type io_output_object
- integer :: wr_ncid
- character (len=1024) :: filename
-
- integer :: time
-
- integer :: stream
-
- integer :: wrDimIDStrLen
-#include "io_output_obj_decls.inc"
-
- logical :: validExchangeLists
- type (exchange_list), pointer :: sendCellsList, recvCellsList
- type (exchange_list), pointer :: sendEdgesList, recvEdgesList
- type (exchange_list), pointer :: sendVerticesList, recvVerticesList
- type (exchange_list), pointer :: sendVertLevelsList, recvVertLevelsList
- end type io_output_object
-
-
- interface io_output_field
- module procedure io_output_field0dReal
- module procedure io_output_field1dReal
- module procedure io_output_field2dReal
- module procedure io_output_field3dReal
- module procedure io_output_field1dInteger
- module procedure io_output_field2dInteger
- module procedure io_output_field0dChar
- module procedure io_output_field1dChar
- end interface io_output_field
-
- interface io_output_field_time
- module procedure io_output_field0dReal_time
- module procedure io_output_field1dReal_time
- module procedure io_output_field2dReal_time
- module procedure io_output_field3dReal_time
- module procedure io_output_field1dInteger_time
- module procedure io_output_field0dChar_time
- module procedure io_output_field1dChar_time
- end interface io_output_field_time
-
-
- contains
-
-
- subroutine output_state_init(output_obj, domain, stream, outputSuffix)
-
- implicit none
-
- type (io_output_object), intent(inout) :: output_obj
- type (domain_type), intent(in) :: domain
- character (len=*) :: stream
- character (len=*), optional :: outputSuffix
-
- character (len=128) :: tempfilename
-
- type (block_type), pointer :: block_ptr
-#include "output_dim_actual_decls.inc"
-
- block_ptr => domain % blocklist
- nullify(output_obj % sendCellsList)
- nullify(output_obj % recvCellsList)
- nullify(output_obj % sendEdgesList)
- nullify(output_obj % recvEdgesList)
- nullify(output_obj % sendVerticesList)
- nullify(output_obj % recvVerticesList)
- nullify(output_obj % sendVertLevelsList)
- nullify(output_obj % recvVertLevelsList)
- output_obj % validExchangeLists = .false.
-
-#include "output_dim_inits.inc"
-
- call dmpar_sum_int(domain % dminfo, block_ptr % mesh % nCellsSolve, nCellsGlobal)
- call dmpar_sum_int(domain % dminfo, block_ptr % mesh % nEdgesSolve, nEdgesGlobal)
- call dmpar_sum_int(domain % dminfo, block_ptr % mesh % nVerticesSolve, nVerticesGlobal)
- nVertLevelsGlobal = block_ptr % mesh % nVertLevels
-
- if (trim(stream) == 'OUTPUT') then
- if(present(outputSuffix)) then
- call insert_string_suffix(config_output_name, outputSuffix, tempfilename)
- else
- tempfilename = config_output_name
- end if
- output_obj % filename = trim(tempfilename)
- output_obj % stream = OUTPUT
- else if (trim(stream) == 'RESTART') then
- output_obj % filename = trim(config_restart_name)
- output_obj % stream = RESTART
- else if (trim(stream) == 'SFC') then
- ! Keep filename as whatever was set by the user
- output_obj % stream = SFC
- end if
-
- ! For now, we assume that a domain consists only of one block,
- ! although in future, work needs to be done to write model state
- ! from many distributed blocks
- call io_output_init(output_obj, domain % dminfo, &
- block_ptr % mesh, &
-#include "output_dim_actual_args.inc"
- )
-
- end subroutine output_state_init
-
-
- subroutine insert_string_suffix(stream, suffix, filename)
-
- implicit none
-
- character (len=*), intent(in) :: stream
- character (len=*), intent(in) :: suffix
- character (len=*), intent(out) :: filename
- integer :: length, i
-
- filename = trim(stream) // '.' // trim(suffix)
-
- length = len_trim(stream)
- do i=length-1,1,-1
- if(stream(i:i) == '.') then
- filename = trim(stream(:i)) // trim(suffix) // trim(stream(i:))
- exit
- end if
- end do
-
- end subroutine insert_string_suffix
-
-
- subroutine output_state_for_domain(output_obj, domain, itime)
-
- implicit none
-
- type (io_output_object), intent(inout) :: output_obj
- type (domain_type), intent(inout) :: domain
- integer, intent(in) :: itime
-
- integer :: i, j
- integer :: nCellsGlobal
- integer :: nEdgesGlobal
- integer :: nVerticesGlobal
- integer :: nVertLevelsGlobal
- integer, dimension(:), pointer :: neededCellList
- integer, dimension(:), pointer :: neededEdgeList
- integer, dimension(:), pointer :: neededVertexList
- integer, dimension(:), pointer :: neededVertLevelList
- integer, dimension(:,:), pointer :: cellsOnCell, edgesOnCell, verticesOnCell, &
- cellsOnEdge, verticesOnEdge, edgesOnEdge, cellsOnVertex, edgesOnVertex
- integer, dimension(:,:), pointer :: cellsOnCell_save, edgesOnCell_save, verticesOnCell_save, &
- cellsOnEdge_save, verticesOnEdge_save, edgesOnEdge_save, &
- cellsOnVertex_save, edgesOnVertex_save
- type (field1dInteger) :: int1d
- type (field2dInteger) :: int2d
- type (field0dReal) :: real0d
- type (field1dReal) :: real1d
- type (field2dReal) :: real2d
- type (field3dReal) :: real3d
- type (field0dChar) :: char0d
- type (field1dChar) :: char1d
-
- integer :: i1, i2, i3, i4
-
- integer, dimension(:), pointer :: super_int1d
- integer, dimension(:,:), pointer :: super_int2d
- real (kind=RKIND) :: super_real0d
- real (kind=RKIND), dimension(:), pointer :: super_real1d
- real (kind=RKIND), dimension(:,:), pointer :: super_real2d
- real (kind=RKIND), dimension(:,:,:), pointer :: super_real3d
- character (len=64) :: super_char0d
- character (len=64), dimension(:), pointer :: super_char1d
-
-#include "nondecomp_outputs.inc"
-
- output_obj % time = itime
-
- allocate(int1d % ioinfo)
- allocate(int2d % ioinfo)
- allocate(real0d % ioinfo)
- allocate(real1d % ioinfo)
- allocate(real2d % ioinfo)
- allocate(real3d % ioinfo)
- allocate(char0d % ioinfo)
- allocate(char1d % ioinfo)
-
- call dmpar_sum_int(domain % dminfo, domain % blocklist % mesh % nCellsSolve, nCellsGlobal)
- call dmpar_sum_int(domain % dminfo, domain % blocklist % mesh % nEdgesSolve, nEdgesGlobal)
- call dmpar_sum_int(domain % dminfo, domain % blocklist % mesh % nVerticesSolve, nVerticesGlobal)
- nVertLevelsGlobal = domain % blocklist % mesh % nVertLevels
-
- allocate(cellsOnCell(domain % blocklist % mesh % maxEdges, domain % blocklist % mesh % nCellsSolve))
- allocate(edgesOnCell(domain % blocklist % mesh % maxEdges, domain % blocklist % mesh % nCellsSolve))
- allocate(verticesOnCell(domain % blocklist % mesh % maxEdges, domain % blocklist % mesh % nCellsSolve))
- allocate(cellsOnEdge(2, domain % blocklist % mesh % nEdgesSolve))
- allocate(verticesOnEdge(2, domain % blocklist % mesh % nEdgesSolve))
- allocate(edgesOnEdge(2 * domain % blocklist % mesh % maxEdges, domain % blocklist % mesh % nEdgesSolve))
- allocate(cellsOnVertex(domain % blocklist % mesh % vertexDegree, domain % blocklist % mesh % nVerticesSolve))
- allocate(edgesOnVertex(domain % blocklist % mesh % vertexDegree, domain % blocklist % mesh % nVerticesSolve))
-
-
- !
- ! Convert connectivity information from local to global indices
- !
- do i=1,domain % blocklist % mesh % nCellsSolve
- do j=1,domain % blocklist % mesh % nEdgesOnCell % array(i)
- cellsOnCell(j,i) = domain % blocklist % mesh % indexToCellID % array( &
- domain % blocklist % mesh % cellsOnCell % array(j,i))
- edgesOnCell(j,i) = domain % blocklist % mesh % indexToEdgeID % array( &
- domain % blocklist % mesh % edgesOnCell % array(j,i))
- verticesOnCell(j,i) = domain % blocklist % mesh % indexToVertexID % array( &
- domain % blocklist % mesh % verticesOnCell % array(j,i))
- end do
- do j=domain % blocklist % mesh % nEdgesOnCell % array(i)+1,domain % blocklist % mesh % maxEdges
- cellsOnCell(j,i) = domain % blocklist % mesh % indexToCellID % array( &
- domain % blocklist % mesh % nEdgesOnCell % array(i))
- edgesOnCell(j,i) = domain % blocklist % mesh % indexToEdgeID % array( &
- domain % blocklist % mesh % nEdgesOnCell % array(i))
- verticesOnCell(j,i) = domain % blocklist % mesh % indexToVertexID % array( &
- domain % blocklist % mesh % nEdgesOnCell % array(i))
- end do
- end do
- do i=1,domain % blocklist % mesh % nEdgesSolve
- cellsOnEdge(1,i) = domain % blocklist % mesh % indexToCellID % array(domain % blocklist % mesh % cellsOnEdge % array(1,i))
- cellsOnEdge(2,i) = domain % blocklist % mesh % indexToCellID % array(domain % blocklist % mesh % cellsOnEdge % array(2,i))
- verticesOnEdge(1,i) = domain % blocklist % mesh % indexToVertexID % array( &
- domain % blocklist % mesh % verticesOnEdge % array(1,i))
- verticesOnEdge(2,i) = domain % blocklist % mesh % indexToVertexID % array( &
- domain % blocklist % mesh % verticesOnEdge % array(2,i))
- do j=1,domain % blocklist % mesh % nEdgesOnEdge % array(i)
- edgesOnEdge(j,i) = domain % blocklist % mesh % indexToEdgeID % array( &
- domain % blocklist % mesh % edgesOnEdge % array(j,i))
- end do
- do j=domain % blocklist % mesh % nEdgesOnEdge % array(i)+1,2*domain % blocklist % mesh % maxEdges
- if(domain % blocklist % mesh % nEdgesOnEdge % array(i) .eq. 0) then
- edgesOnEdge(j,i) = domain % blocklist % mesh % nEdgesSolve + 1
- else
- edgesOnEdge(j,i) = domain % blocklist % mesh % indexToEdgeID % array( &
- domain % blocklist % mesh % nEdgesOnEdge % array(i))
- endif
- end do
- end do
- do i=1,domain % blocklist % mesh % nVerticesSolve
- do j=1,domain % blocklist % mesh % vertexDegree
- cellsOnVertex(j,i) = domain % blocklist % mesh % indexToCellID % array( &
- domain % blocklist % mesh % cellsOnVertex % array(j,i))
- edgesOnVertex(j,i) = domain % blocklist % mesh % indexToEdgeID % array( &
- domain % blocklist % mesh % edgesOnVertex % array(j,i))
- end do
- end do
-
- if (domain % dminfo % my_proc_id == 0) then
- allocate(neededCellList(nCellsGlobal))
- allocate(neededEdgeList(nEdgesGlobal))
- allocate(neededVertexList(nVerticesGlobal))
- allocate(neededVertLevelList(nVertLevelsGlobal))
- do i=1,nCellsGlobal
- neededCellList(i) = i
- end do
- do i=1,nEdgesGlobal
- neededEdgeList(i) = i
- end do
- do i=1,nVerticesGlobal
- neededVertexList(i) = i
- end do
- do i=1,nVertLevelsGlobal
- neededVertLevelList(i) = i
- end do
- else
- allocate(neededCellList(0))
- allocate(neededEdgeList(0))
- allocate(neededVertexList(0))
- allocate(neededVertLevelList(0))
- end if
-
- if (.not. output_obj % validExchangeLists) then
- call dmpar_get_owner_list(domain % dminfo, &
- domain % blocklist % mesh % nCellsSolve, size(neededCellList), &
- domain % blocklist % mesh % indexToCellID % array, neededCellList, &
- output_obj % sendCellsList, output_obj % recvCellsList)
-
- call dmpar_get_owner_list(domain % dminfo, &
- domain % blocklist % mesh % nEdgesSolve, size(neededEdgeList), &
- domain % blocklist % mesh % indexToEdgeID % array, neededEdgeList, &
- output_obj % sendEdgesList, output_obj % recvEdgesList)
-
- call dmpar_get_owner_list(domain % dminfo, &
- domain % blocklist % mesh % nVerticesSolve, size(neededVertexList), &
- domain % blocklist % mesh % indexToVertexID % array, neededVertexList, &
- output_obj % sendVerticesList, output_obj % recvVerticesList)
-
- call dmpar_get_owner_list(domain % dminfo, &
- size(neededVertLevelList), size(neededVertLevelList), &
- neededVertLevelList, neededVertLevelList, &
- output_obj % sendVertLevelsList, output_obj % recvVertLevelsList)
-
- output_obj % validExchangeLists = .true.
- end if
-
- deallocate(neededCellList)
- deallocate(neededEdgeList)
- deallocate(neededVertexList)
-
- cellsOnCell_save => domain % blocklist % mesh % cellsOnCell % array
- edgesOnCell_save => domain % blocklist % mesh % edgesOnCell % array
- verticesOnCell_save => domain % blocklist % mesh % verticesOnCell % array
- cellsOnEdge_save => domain % blocklist % mesh % cellsOnEdge % array
- verticesOnEdge_save => domain % blocklist % mesh % verticesOnEdge % array
- edgesOnEdge_save => domain % blocklist % mesh % edgesOnEdge % array
- cellsOnVertex_save => domain % blocklist % mesh % cellsOnVertex % array
- edgesOnVertex_save => domain % blocklist % mesh % edgesOnVertex % array
-
- domain % blocklist % mesh % cellsOnCell % array => cellsOnCell
- domain % blocklist % mesh % edgesOnCell % array => edgesOnCell
- domain % blocklist % mesh % verticesOnCell % array => verticesOnCell
- domain % blocklist % mesh % cellsOnEdge % array => cellsOnEdge
- domain % blocklist % mesh % verticesOnEdge % array => verticesOnEdge
- domain % blocklist % mesh % edgesOnEdge % array => edgesOnEdge
- domain % blocklist % mesh % cellsOnVertex % array => cellsOnVertex
- domain % blocklist % mesh % edgesOnVertex % array => edgesOnVertex
-
-#include "io_output_fields.inc"
-
- domain % blocklist % mesh % cellsOnCell % array => cellsOnCell_save
- domain % blocklist % mesh % edgesOnCell % array => edgesOnCell_save
- domain % blocklist % mesh % verticesOnCell % array => verticesOnCell_save
- domain % blocklist % mesh % cellsOnEdge % array => cellsOnEdge_save
- domain % blocklist % mesh % verticesOnEdge % array => verticesOnEdge_save
- domain % blocklist % mesh % edgesOnEdge % array => edgesOnEdge_save
- domain % blocklist % mesh % cellsOnVertex % array => cellsOnVertex_save
- domain % blocklist % mesh % edgesOnVertex % array => edgesOnVertex_save
-
- deallocate(cellsOnCell)
- deallocate(edgesOnCell)
- deallocate(verticesOnCell)
- deallocate(cellsOnEdge)
- deallocate(verticesOnEdge)
- deallocate(edgesOnEdge)
- deallocate(cellsOnVertex)
- deallocate(edgesOnVertex)
-
-#include "nondecomp_outputs_dealloc.inc"
-
- end subroutine output_state_for_domain
-
-
- subroutine output_state_finalize(output_obj, dminfo)
-
- implicit none
-
- type (io_output_object), intent(inout) :: output_obj
- type (dm_info), intent(in) :: dminfo
-
- call io_output_finalize(output_obj, dminfo)
-
- end subroutine output_state_finalize
-
-
- subroutine io_output_init( output_obj, &
- dminfo, &
- mesh, &
-#include "dim_dummy_args.inc"
- )
-
- implicit none
-
- include 'netcdf.inc'
-
- type (io_output_object), intent(inout) :: output_obj
- type (dm_info), intent(in) :: dminfo
- type (mesh_type), intent(in) :: mesh
-#include "dim_dummy_decls.inc"
-
- integer :: nferr
- integer, dimension(10) :: dimlist
-
- if (dminfo % my_proc_id == 0) then
-#ifdef OFFSET64BIT
- nferr = nf_create(trim(output_obj % filename), ior(NF_CLOBBER,NF_64BIT_OFFSET), output_obj % wr_ncid)
-#else
- nferr = nf_create(trim(output_obj % filename), NF_CLOBBER, output_obj % wr_ncid)
-#endif
-
- nferr = nf_def_dim(output_obj % wr_ncid, 'StrLen', 64, output_obj % wrDimIDStrLen)
-#include "netcdf_def_dims_vars.inc"
-
- if (mesh % on_a_sphere) then
- nferr = nf_put_att_text(output_obj % wr_ncid, NF_GLOBAL, 'on_a_sphere', 16, 'YES ')
- else
- nferr = nf_put_att_text(output_obj % wr_ncid, NF_GLOBAL, 'on_a_sphere', 16, 'NO ')
- end if
- if (RKIND == 8) then
- nferr = nf_put_att_double(output_obj % wr_ncid, NF_GLOBAL, 'sphere_radius', NF_DOUBLE, 1, mesh % sphere_radius)
- else
- nferr = nf_put_att_real(output_obj % wr_ncid, NF_GLOBAL, 'sphere_radius', NF_FLOAT, 1, mesh % sphere_radius)
- end if
-
- nferr = nf_enddef(output_obj % wr_ncid)
- end if
-
- end subroutine io_output_init
-
-
- subroutine io_output_field0dReal(output_obj, field)
-
- implicit none
-
- type (io_output_object), intent(in) :: output_obj
- type (field0dReal), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(1) :: start1, count1
-
- start1(1) = 1
- count1(1) = 1
-
-#include "output_field0dreal.inc"
-
-#if (RKIND == 8)
- nferr = nf_put_vara_double(output_obj % wr_ncid, varID, start1, count1, field % scalar)
-#else
- nferr = nf_put_vara_real(output_obj % wr_ncid, varID, start1, count1, field % scalar)
-#endif
-
- nferr = nf_sync(output_obj % wr_ncid)
-
- end subroutine io_output_field0dReal
-
-
- subroutine io_output_field1dReal(output_obj, field)
-
- implicit none
-
- type (io_output_object), intent(in) :: output_obj
- type (field1dReal), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(1) :: start1, count1
-
- start1(1) = field % ioinfo % start(1)
- count1(1) = field % ioinfo % count(1)
-
-#include "output_field1dreal.inc"
-
-#if (RKIND == 8)
- nferr = nf_put_vara_double(output_obj % wr_ncid, VarID, start1, count1, field % array)
-#else
- nferr = nf_put_vara_real(output_obj % wr_ncid, VarID, start1, count1, field % array)
-#endif
-
- nferr = nf_sync(output_obj % wr_ncid)
-
- end subroutine io_output_field1dReal
-
-
- subroutine io_output_field2dReal(output_obj, field)
-
- implicit none
-
- type (io_output_object), intent(in) :: output_obj
- type (field2dReal), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(2) :: start2, count2
-
- start2(1) = field % ioinfo % start(1)
- start2(2) = field % ioinfo % start(2)
- count2(1) = field % ioinfo % count(1)
- count2(2) = field % ioinfo % count(2)
-
-#include "output_field2dreal.inc"
-
-#if (RKIND == 8)
- nferr = nf_put_vara_double(output_obj % wr_ncid, varID, start2, count2, field % array)
-#else
- nferr = nf_put_vara_real(output_obj % wr_ncid, varID, start2, count2, field % array)
-#endif
-
- nferr = nf_sync(output_obj % wr_ncid)
-
- end subroutine io_output_field2dReal
-
-
- subroutine io_output_field3dReal(output_obj, field)
-
- implicit none
-
- type (io_output_object), intent(in) :: output_obj
- type (field3dReal), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(3) :: start3, count3
-
- start3(1) = field % ioinfo % start(1)
- start3(2) = field % ioinfo % start(2)
- start3(3) = field % ioinfo % start(3)
- count3(1) = field % ioinfo % count(1)
- count3(2) = field % ioinfo % count(2)
- count3(3) = field % ioinfo % count(3)
-
-#include "output_field3dreal.inc"
-
-#if (RKIND == 8)
- nferr = nf_put_vara_double(output_obj % wr_ncid, varID, start3, count3, field % array)
-#else
- nferr = nf_put_vara_real(output_obj % wr_ncid, varID, start3, count3, field % array)
-#endif
-
- nferr = nf_sync(output_obj % wr_ncid)
-
- end subroutine io_output_field3dReal
-
-
- subroutine io_output_field0dReal_time(output_obj, field)
-
- implicit none
-
- type (io_output_object), intent(in) :: output_obj
- type (field0dReal), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(1) :: start1, count1
-
- start1(1) = output_obj % time
- count1(1) = 1
-
-#include "output_field0dreal_time.inc"
-
-#if (RKIND == 8)
- nferr = nf_put_vara_double(output_obj % wr_ncid, varID, start1, count1, field % scalar)
-#else
- nferr = nf_put_vara_real(output_obj % wr_ncid, varID, start1, count1, field % scalar)
-#endif
-
- nferr = nf_sync(output_obj % wr_ncid)
-
- end subroutine io_output_field0dReal_time
-
-
- subroutine io_output_field1dReal_time(output_obj, field)
-
- implicit none
-
- type (io_output_object), intent(in) :: output_obj
- type (field1dReal), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(2) :: start2, count2
-
- start2(1) = field % ioinfo % start(1)
- start2(2) = output_obj % time
- count2(1) = field % ioinfo % count(1)
- count2(2) = 1
-
-#include "output_field1dreal_time.inc"
-
-#if (RKIND == 8)
- nferr = nf_put_vara_double(output_obj % wr_ncid, varID, start2, count2, field % array)
-#else
- nferr = nf_put_vara_real(output_obj % wr_ncid, varID, start2, count2, field % array)
-#endif
-
- nferr = nf_sync(output_obj % wr_ncid)
-
- end subroutine io_output_field1dReal_time
-
-
- subroutine io_output_field2dReal_time(output_obj, field)
-
- implicit none
-
- type (io_output_object), intent(in) :: output_obj
- type (field2dReal), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(3) :: start3, count3
-
- start3(1) = field % ioinfo % start(1)
- start3(2) = field % ioinfo % start(2)
- start3(3) = output_obj % time
- count3(1) = field % ioinfo % count(1)
- count3(2) = field % ioinfo % count(2)
- count3(3) = 1
-
-#include "output_field2dreal_time.inc"
-
-#if (RKIND == 8)
- nferr = nf_put_vara_double(output_obj % wr_ncid, varID, start3, count3, field % array)
-#else
- nferr = nf_put_vara_real(output_obj % wr_ncid, varID, start3, count3, field % array)
-#endif
-
- nferr = nf_sync(output_obj % wr_ncid)
-
- end subroutine io_output_field2dReal_time
-
-
- subroutine io_output_field3dReal_time(output_obj, field)
-
- implicit none
-
- type (io_output_object), intent(in) :: output_obj
- type (field3dReal), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(4) :: start4, count4
-
- start4(1) = field % ioinfo % start(1)
- start4(2) = field % ioinfo % start(2)
- start4(3) = field % ioinfo % start(3)
- start4(4) = output_obj % time
- count4(1) = field % ioinfo % count(1)
- count4(2) = field % ioinfo % count(2)
- count4(3) = field % ioinfo % count(3)
- count4(4) = 1
-
-#include "output_field3dreal_time.inc"
-
-#if (RKIND == 8)
- nferr = nf_put_vara_double(output_obj % wr_ncid, varID, start4, count4, field % array)
-#else
- nferr = nf_put_vara_real(output_obj % wr_ncid, varID, start4, count4, field % array)
-#endif
-
- nferr = nf_sync(output_obj % wr_ncid)
-
- end subroutine io_output_field3dReal_time
-
-
- subroutine io_output_field1dInteger(output_obj, field)
-
- implicit none
-
- type (io_output_object), intent(in) :: output_obj
- type (field1dInteger), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(1) :: start1, count1
-
- start1(1) = field % ioinfo % start(1)
- count1(1) = field % ioinfo % count(1)
-
-#include "output_field1dinteger.inc"
-
- nferr = nf_put_vara_int(output_obj % wr_ncid, varID, start1, count1, field % array)
-
- nferr = nf_sync(output_obj % wr_ncid)
-
- end subroutine io_output_field1dInteger
-
-
- subroutine io_output_field2dInteger(output_obj, field)
-
- implicit none
-
- type (io_output_object), intent(in) :: output_obj
- type (field2dInteger), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(2) :: start2, count2
-
- start2(1) = field % ioinfo % start(1)
- start2(2) = field % ioinfo % start(2)
- count2(1) = field % ioinfo % count(1)
- count2(2) = field % ioinfo % count(2)
-
-#include "output_field2dinteger.inc"
-
- nferr = nf_put_vara_int(output_obj % wr_ncid, varID, start2, count2, field % array)
-
- nferr = nf_sync(output_obj % wr_ncid)
-
- end subroutine io_output_field2dInteger
-
-
- subroutine io_output_field1dInteger_time(output_obj, field)
-
- implicit none
-
- type (io_output_object), intent(in) :: output_obj
- type (field1dInteger), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(2) :: start2, count2
-
- start2(1) = field % ioinfo % start(1)
- start2(2) = output_obj % time
- count2(1) = field % ioinfo % count(1)
- count2(2) = 1
-
-#include "output_field1dinteger_time.inc"
-
- nferr = nf_put_vara_int(output_obj % wr_ncid, varID, start2, count2, field % array)
-
- nferr = nf_sync(output_obj % wr_ncid)
-
- end subroutine io_output_field1dInteger_time
-
-
- subroutine io_output_field0dChar_time(output_obj, field)
-
- implicit none
-
- type (io_output_object), intent(in) :: output_obj
- type (field0dChar), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(2) :: start1, count1
-
- start1(1) = 1
- count1(1) = 64
- start1(2) = output_obj % time
- count1(2) = 1
-
-#include "output_field0dchar_time.inc"
-
- nferr = nf_put_vara_text(output_obj % wr_ncid, varID, start1, count1, field % scalar)
-
- nferr = nf_sync(output_obj % wr_ncid)
-
- end subroutine io_output_field0dChar_time
-
-
- subroutine io_output_field1dChar_time(output_obj, field)
-
- implicit none
-
- type (io_output_object), intent(in) :: output_obj
- type (field1dChar), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(3) :: start2, count2
-
- start2(1) = 1
- start2(2) = field % ioinfo % start(1)
- start2(3) = output_obj % time
- count2(1) = 64
- count2(2) = field % ioinfo % count(1)
- count2(3) = 1
-
-#include "output_field1dchar_time.inc"
-
- nferr = nf_put_vara_text(output_obj % wr_ncid, varID, start2, count2, field % array)
-
- nferr = nf_sync(output_obj % wr_ncid)
-
- end subroutine io_output_field1dChar_time
-
-
- subroutine io_output_field0dChar(output_obj, field)
-
- implicit none
-
- type (io_output_object), intent(in) :: output_obj
- type (field0dChar), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(2) :: start1, count1
-
- start1(1) = 1
- count1(1) = 64
- start1(2) = 1
- count1(2) = 1
-
-#include "output_field0dchar.inc"
-
- nferr = nf_put_vara_text(output_obj % wr_ncid, varID, start1, count1, field % scalar)
-
- nferr = nf_sync(output_obj % wr_ncid)
-
- end subroutine io_output_field0dChar
-
-
- subroutine io_output_field1dChar(output_obj, field)
-
- implicit none
-
- type (io_output_object), intent(in) :: output_obj
- type (field1dChar), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(2) :: start1, count1
-
- start1(1) = 1
- count1(1) = 64
- start1(2) = field % ioinfo % start(1)
- count1(2) = field % ioinfo % count(1)
-
-#include "output_field1dchar.inc"
-
- nferr = nf_put_vara_text(output_obj % wr_ncid, VarID, start1, count1, field % array)
-
- nferr = nf_sync(output_obj % wr_ncid)
-
- end subroutine io_output_field1dChar
-
-
- subroutine io_output_finalize(output_obj, dminfo)
-
- implicit none
-
- include 'netcdf.inc'
-
- type (io_output_object), intent(inout) :: output_obj
- type (dm_info), intent(in) :: dminfo
-
- integer :: nferr
-
- if (dminfo % my_proc_id == 0) then
- nferr = nf_close(output_obj % wr_ncid)
- end if
-
- end subroutine io_output_finalize
-
-end module io_output
-
Deleted: trunk/mpas/src/framework/module_mpas_framework.F
===================================================================
--- trunk/mpas/src/framework/module_mpas_framework.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/framework/module_mpas_framework.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -1,49 +0,0 @@
-module mpas_framework
-
- use dmpar
- use grid_types
- use io_input
- use io_output
- use configure
- use timer
- use mpas_timekeeping
-
-
- contains
-
-
- subroutine mpas_framework_init(dminfo, domain)
-
- implicit none
-
- type (dm_info), pointer :: dminfo
- type (domain_type), pointer :: domain
-
- allocate(dminfo)
- call dmpar_init(dminfo)
-
- call read_namelist(dminfo)
-
- call allocate_domain(domain, dminfo)
-
- call mpas_timekeeping_init(config_calendar_type)
-
- end subroutine mpas_framework_init
-
-
- subroutine mpas_framework_finalize(dminfo, domain)
-
- implicit none
-
- type (dm_info), pointer :: dminfo
- type (domain_type), pointer :: domain
-
- call deallocate_domain(domain)
-
- call dmpar_finalize(dminfo)
-
- call mpas_timekeeping_finalize()
-
- end subroutine mpas_framework_finalize
-
-end module mpas_framework
Deleted: trunk/mpas/src/framework/module_mpas_timekeeping.F
===================================================================
--- trunk/mpas/src/framework/module_mpas_timekeeping.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/framework/module_mpas_timekeeping.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -1,1625 +0,0 @@
-module mpas_timekeeping
-
- use ESMF_BaseMod
- use ESMF_Stubs
- use ESMF_CalendarMod
- use ESMF_ClockMod
- use ESMF_TimeMod
- use ESMF_TimeIntervalMod
-
- private :: MPAS_CalibrateAlarms
- private :: MPAS_inRingingEnvelope
-
- integer, parameter :: MPAS_MAX_ALARMS = 20
- integer, parameter :: MPAS_NOW = 0, &
- MPAS_START_TIME = 1, &
- MPAS_STOP_TIME = 2
- integer, parameter :: MPAS_FORWARD = 1, &
- MPAS_BACKWARD = -1
- integer, parameter :: MPAS_GREGORIAN = 0, &
- MPAS_GREGORIAN_NOLEAP = 1, &
- MPAS_360DAY = 2
-
- integer :: TheCalendar
-
- integer, dimension(12), parameter :: daysInMonth = (/31,28,31,30,31,30,31,31,30,31,30,31/)
- integer, dimension(12), parameter :: daysInMonthLeap = (/31,29,31,30,31,30,31,31,30,31,30,31/)
-
-
- type MPAS_Time_type
- type (ESMF_Time) :: t
- end type
-
- type MPAS_TimeInterval_type
- type (ESMF_TimeInterval) :: ti
- end type
-
- type MPAS_Alarm_type
- integer :: alarmID
- logical :: isRecurring
- logical :: isSet
- type (MPAS_Time_type) :: ringTime
- type (MPAS_Time_type) :: prevRingTime
- type (MPAS_TimeInterval_type) :: ringTimeInterval
- type (MPAS_Alarm_type), pointer :: next
- end type
-
- type MPAS_Clock_type
- integer :: direction
- integer :: nAlarms
- type (ESMF_Clock) :: c
- type (MPAS_Alarm_type), pointer :: alarmListHead
- end type
-
- interface operator (+)
- module procedure add_t_ti
- module procedure add_ti_ti
- end interface
-
- interface operator (-)
- module procedure sub_t_t
- module procedure sub_t_ti
- module procedure sub_ti_ti
- module procedure neg_ti
- end interface
-
- interface operator (*)
- module procedure mul_ti_n
- end interface
-
- interface operator (/)
- module procedure div_ti_n
- end interface
-
- interface operator (.EQ.)
- module procedure eq_t_t
- module procedure eq_ti_ti
- end interface
-
- interface operator (.NE.)
- module procedure ne_t_t
- module procedure ne_ti_ti
- end interface
-
- interface operator (.LT.)
- module procedure lt_t_t
- module procedure lt_ti_ti
- end interface
-
- interface operator (.GT.)
- module procedure gt_t_t
- module procedure gt_ti_ti
- end interface
-
- interface operator (.LE.)
- module procedure le_t_t
- module procedure le_ti_ti
- end interface
-
- interface operator (.GE.)
- module procedure ge_t_t
- module procedure ge_ti_ti
- end interface
-
- interface abs
- module procedure abs_ti
- end interface
-
-
- contains
-
-
- subroutine mpas_timekeeping_init(calendar)
-
- implicit none
-
- integer, intent(in) :: calendar
-
- TheCalendar = calendar
-
- if (TheCalendar == MPAS_GREGORIAN) then
- call ESMF_Initialize(defaultCalendar=ESMF_CAL_GREGORIAN)
- else if (TheCalendar == MPAS_GREGORIAN_NOLEAP) then
- call ESMF_Initialize(defaultCalendar=ESMF_CAL_NOLEAP)
- else if (TheCalendar == MPAS_360DAY) then
- call ESMF_Initialize(defaultCalendar=ESMF_CAL_360DAY)
- else
- write(0,*) 'ERROR: mpas_timekeeping_init: Invalid calendar type'
- end if
-
- end subroutine mpas_timekeeping_init
-
-
- subroutine mpas_timekeeping_finalize()
-
- implicit none
-
- call ESMF_Finalize()
-
- end subroutine mpas_timekeeping_finalize
-
-
- subroutine MPAS_createClock(clock, startTime, timeStep, stopTime, runDuration, ierr)
-
- implicit none
-
- type (MPAS_Clock_type), intent(out) :: clock
- type (MPAS_Time_type), intent(in) :: startTime
- type (MPAS_TimeInterval_type), intent(in) :: timeStep
- type (MPAS_Time_type), intent(in), optional :: stopTime
- type (MPAS_TimeInterval_type), intent(in), optional :: runDuration
- integer, intent(out), optional :: ierr
-
- type (MPAS_Time_type) :: stop_time
-
- if (present(runDuration)) then
- stop_time = startTime + runDuration
- if (present(stopTime)) then
- if (stopTime /= stop_time) then
- if (present(ierr)) ierr = 1 ! stopTime and runDuration are inconsistent
- write(0,*) 'ERROR: MPAS_createClock: stopTime and runDuration are inconsistent'
- return
- end if
- end if
- else if (present(stopTime)) then
- stop_time = stopTime
- else
- if (present(ierr)) ierr = 1 ! neither stopTime nor runDuration are specified
- write(0,*) 'ERROR: MPAS_createClock: neither stopTime nor runDuration are specified'
- return
- end if
-
- clock % c = ESMF_ClockCreate(TimeStep=timeStep%ti, StartTime=startTime%t, StopTime=stop_time%t, rc=ierr)
- if (present(ierr)) then
- if (ierr == ESMF_SUCCESS) ierr = 0
- end if
- clock % direction = MPAS_FORWARD
- clock % nAlarms = 0
- nullify(clock % alarmListHead)
-
- end subroutine MPAS_createClock
-
-
- subroutine MPAS_destroyClock(clock, ierr)
-
- implicit none
-
- type (MPAS_Clock_type), intent(inout) :: clock
- integer, intent(out), optional :: ierr
-
- type (MPAS_Alarm_type), pointer :: alarmPtr
-
- alarmPtr => clock % alarmListHead
- do while (associated(alarmPtr))
- clock % alarmListHead => alarmPtr % next
- deallocate(alarmPtr)
- alarmPtr => clock % alarmListHead
- end do
-
- call ESMF_ClockDestroy(clock % c, rc=ierr)
- if (present(ierr)) then
- if (ierr == ESMF_SUCCESS) ierr = 0
- end if
-
- end subroutine MPAS_destroyClock
-
-
- logical function MPAS_isClockStartTime(clock, ierr)
-
- implicit none
-
- type (MPAS_Clock_type), intent(in) :: clock
- integer, intent(out), optional :: ierr
-
- type (ESMF_Time) :: currTime, startTime, stopTime
-
- call ESMF_ClockGet(clock % c, CurrTime=currTime, rc=ierr)
- call ESMF_ClockGet(clock % c, StartTime=startTime, rc=ierr)
- call ESMF_ClockGet(clock % c, StopTime=stopTime, rc=ierr)
- if (present(ierr)) then
- if (ierr == ESMF_SUCCESS) ierr = 0
- end if
-
- if (startTime <= stopTime) then
- MPAS_isClockStartTime = (currTime <= startTime)
- else
- MPAS_isClockStartTime = (currTime >= startTime)
- end if
-
- end function MPAS_isClockStartTime
-
-
- logical function MPAS_isClockStopTime(clock, ierr)
-
- implicit none
-
- type (MPAS_Clock_type), intent(in) :: clock
- integer, intent(out), optional :: ierr
-
- type (ESMF_Time) :: currTime, startTime, stopTime
-
- call ESMF_ClockGet(clock % c, CurrTime=currTime, rc=ierr)
- call ESMF_ClockGet(clock % c, StartTime=startTime, rc=ierr)
- call ESMF_ClockGet(clock % c, StopTime=stopTime, rc=ierr)
- if (present(ierr)) then
- if (ierr == ESMF_SUCCESS) ierr = 0
- end if
-
- if (startTime <= stopTime) then
- MPAS_isClockStopTime = (currTime >= stopTime)
- else
- MPAS_isClockStopTime = (currTime <= stopTime)
- end if
-
- end function MPAS_isClockStopTime
-
-
- subroutine MPAS_setClockDirection(clock, direction, ierr)
-
- implicit none
-
- type (MPAS_Clock_type), intent(inout) :: clock
- integer, intent(in) :: direction
- integer, intent(out), optional :: ierr
-
- type (MPAS_TimeInterval_type) :: timeStep
-
- if (direction == MPAS_FORWARD .and. clock % direction == MPAS_FORWARD) return
- if (direction == MPAS_BACKWARD .and. clock % direction == MPAS_BACKWARD) return
-
- clock % direction = direction
- call ESMF_ClockGet(clock % c, TimeStep=timeStep%ti, rc=ierr)
- timeStep = neg_ti(timeStep)
- call ESMF_ClockSet(clock % c, TimeStep=timeStep%ti, rc=ierr)
-
- ! specify a valid previousRingTime for each alarm
- call MPAS_CalibrateAlarms(clock, ierr);
-
- if (present(ierr)) then
- if (ierr == ESMF_SUCCESS) ierr = 0
- end if
-
- end subroutine MPAS_setClockDirection
-
-
-
- integer function MPAS_getClockDirection(clock, ierr)
-
- implicit none
-
- type (MPAS_Clock_type), intent(in) :: clock
- integer, intent(out), optional :: ierr
-
- if (present(ierr)) ierr = 0
-
- MPAS_getClockDirection = clock % direction
-
- end function MPAS_getClockDirection
-
-
- subroutine MPAS_setClockTimeStep(clock, timeStep, ierr)
-
- implicit none
-
- type (MPAS_Clock_type), intent(inout) :: clock
- type (MPAS_TimeInterval_type), intent(in) :: timeStep
- integer, intent(out), optional :: ierr
-
- call ESMF_ClockSet(clock % c, TimeStep=timeStep%ti, rc=ierr)
- if (present(ierr)) then
- if (ierr == ESMF_SUCCESS) ierr = 0
- end if
-
- end subroutine MPAS_setClockTimeStep
-
-
- type (MPAS_TimeInterval_type) function MPAS_getClockTimeStep(clock, ierr)
-
- implicit none
-
- type (MPAS_Clock_type), intent(in) :: clock
- integer, intent(out), optional :: ierr
-
- type (MPAS_TimeInterval_type) :: timeStep
-
- call ESMF_ClockGet(clock % c, TimeStep=timeStep%ti, rc=ierr)
- if (present(ierr)) then
- if (ierr == ESMF_SUCCESS) ierr = 0
- end if
-
- MPAS_getClockTimeStep = timeStep
-
- end function MPAS_getClockTimeStep
-
-
- subroutine MPAS_advanceClock(clock, timeStep, ierr)
-
- implicit none
-
- type (MPAS_Clock_type), intent(inout) :: clock
- type (MPAS_TimeInterval_type), intent(in), optional :: timeStep
- integer, intent(out), optional :: ierr
-
- type (ESMF_TimeInterval) :: time_step
-
- if (present(timeStep)) then
- call ESMF_ClockGet(clock % c, TimeStep=time_step, rc=ierr)
- call ESMF_ClockSet(clock % c, TimeStep=timeStep % ti, rc=ierr)
- call ESMF_ClockAdvance(clock % c, rc=ierr)
- call ESMF_ClockSet(clock % c, TimeStep=time_step, rc=ierr)
- else
- call ESMF_ClockAdvance(clock % c, rc=ierr)
- end if
- if (present(ierr)) then
- if (ierr == ESMF_SUCCESS) ierr = 0
- end if
-
- end subroutine MPAS_advanceClock
-
-
- subroutine MPAS_setClockTime(clock, clock_time, whichTime, ierr)
-
- implicit none
-
- type (MPAS_Clock_type), intent(inout) :: clock
- type (MPAS_Time_type), intent(in) :: clock_time
- integer, intent(in) :: whichTime
- integer, intent(out), optional :: ierr
-
- if (whichTime == MPAS_NOW) then
- call ESMF_ClockSet(clock % c, CurrTime=clock_time%t, rc=ierr)
- call MPAS_CalibrateAlarms(clock, ierr);
- else if (whichTime == MPAS_START_TIME) then
- call ESMF_ClockSet(clock % c, StartTime=clock_time%t, rc=ierr)
- else if (whichTime == MPAS_STOP_TIME) then
- call ESMF_ClockSet(clock % c, StopTime=clock_time%t, rc=ierr)
- else if (present(ierr)) then
- ierr = 1
- end if
- if (present(ierr)) then
- if (ierr == ESMF_SUCCESS) ierr = 0
- end if
-
- end subroutine MPAS_setClockTime
-
-
- type (MPAS_Time_type) function MPAS_getClockTime(clock, whichTime, ierr)
-
- implicit none
-
- type (MPAS_Clock_type), intent(in) :: clock
- integer, intent(in) :: whichTime
- integer, intent(out), optional :: ierr
-
- type (MPAS_Time_type) :: clock_time
-
- if (whichTime == MPAS_NOW) then
- call ESMF_ClockGet(clock % c, CurrTime=clock_time%t, rc=ierr)
- else if (whichTime == MPAS_START_TIME) then
- call ESMF_ClockGet(clock % c, StartTime=clock_time%t, rc=ierr)
- else if (whichTime == MPAS_STOP_TIME) then
- call ESMF_ClockGet(clock % c, StopTime=clock_time%t, rc=ierr)
- else if (present(ierr)) then
- ierr = 1
- end if
- if (present(ierr)) then
- if (ierr == ESMF_SUCCESS) ierr = 0
- end if
-
- MPAS_getClockTime = clock_time
-
- end function MPAS_getClockTime
-
-
- subroutine MPAS_addClockAlarm(clock, alarmID, alarmTime, alarmTimeInterval, ierr)
-! TODO: possibly add a stop time for recurring alarms
-
- implicit none
-
- type (MPAS_Clock_type), intent(inout) :: clock
- integer, intent(in) :: alarmID
- type (MPAS_Time_type), intent(in) :: alarmTime
- type (MPAS_TimeInterval_type), intent(in), optional :: alarmTimeInterval
- integer, intent(out), optional :: ierr
-
- type (MPAS_Alarm_type), pointer :: alarmPtr
-
- ! Add a new entry to the linked list of alarms for this clock
- if (.not. associated(clock % alarmListHead)) then
- allocate(clock % alarmListHead)
- nullify(clock % alarmListHead % next)
- alarmPtr => clock % alarmListHead
- else
- alarmPtr => clock % alarmListHead
- do while (associated(alarmPtr % next))
- if (alarmPtr % alarmID == alarmID) then
- write(0,*) 'OOPS -- we have a duplicate alarmID', alarmID
- if (present(ierr)) ierr = 1
- return
- end if
- alarmPtr => alarmPtr % next
- end do
- if (alarmPtr % alarmID == alarmID) then
- write(0,*) 'OOPS -- we have a duplicate alarmID', alarmID
- if (present(ierr)) ierr = 1
- return
- end if
- allocate(alarmPtr % next)
- alarmPtr => alarmPtr % next
- nullify(alarmPtr % next)
- end if
-
- alarmPtr % alarmID = alarmID
-
- clock % nAlarms = clock % nAlarms + 1
-
- alarmPtr % isSet = .true.
- alarmPtr % ringTime = alarmTime
-
-
- if (present(alarmTimeInterval)) then
- alarmPtr % isRecurring = .true.
- alarmPtr % ringTimeInterval = alarmTimeInterval
- if(clock % direction == MPAS_FORWARD) then
- alarmPtr % prevRingTime = alarmTime - alarmTimeInterval
- else
- alarmPtr % prevRingTime = alarmTime + alarmTimeInterval
- end if
- else
- alarmPtr % isRecurring = .false.
- alarmPtr % prevRingTime = alarmTime
- end if
- if (present(ierr)) then
- if (ierr == ESMF_SUCCESS) ierr = 0
- end if
-
- end subroutine MPAS_addClockAlarm
-
-
- subroutine MPAS_removeClockAlarm(clock, alarmID, ierr)
-
- implicit none
-
- type (MPAS_Clock_type), intent(inout) :: clock
- integer, intent(in) :: alarmID
- integer, intent(out), optional :: ierr
-
- type (MPAS_Alarm_type), pointer :: alarmPtr
- type (MPAS_Alarm_type), pointer :: alarmParentPtr
-
- if (present(ierr)) ierr = 0
-
- alarmPtr => clock % alarmListHead
- alarmParentPtr = alarmPtr
- do while (associated(alarmPtr))
- if (alarmPtr % alarmID == alarmID) then
- alarmParentPtr % next => alarmPtr % next
- deallocate(alarmPtr)
- exit
- end if
- alarmParentPtr = alarmPtr
- alarmPtr => alarmPtr % next
- end do
-
- end subroutine MPAS_removeClockAlarm
-
-
-
- subroutine MPAS_printAlarm(clock, alarmID, ierr)
-
- implicit none
-
- type (MPAS_Clock_type), intent(in) :: clock
- integer, intent(in) :: alarmID
- integer, intent(out) :: ierr
-
- type (MPAS_Alarm_type), pointer :: alarmPtr
-
- type (MPAS_TimeInterval_type) :: alarmTimeInterval
- type (MPAS_Time_type) :: alarmTime
- character (len=32) :: printString
-
- ierr = 0
-
- alarmPtr => clock % alarmListHead
- do while (associated(alarmPtr))
- if (alarmPtr % alarmID == alarmID) then
- write(0,*) 'ALARM ', alarmID
-
- write(0,*) 'isRecurring', alarmPtr % isRecurring
-
- write(0,*) 'isSet', alarmPtr % isSet
-
- call MPAS_getTime(alarmPtr % ringTime, dateTimeString=printString, ierr=ierr)
- write(0,*) 'ringTime', printString
-
- call MPAS_getTime(alarmPtr % prevRingTime, dateTimeString=printString, ierr=ierr)
- write(0,*) 'prevRingTime', printString
-
- call MPAS_getTimeInterval(alarmPtr % ringTimeInterval, timeString=printString, ierr=ierr)
- write(0,*) 'ringTimeInterval', printString
-
- exit
- end if
- alarmPtr => alarmPtr % next
- end do
-
- end subroutine MPAS_printAlarm
-
-
-
- logical function MPAS_isAlarmRinging(clock, alarmID, interval, ierr)
-
- implicit none
-
- type (MPAS_Clock_type), intent(in) :: clock
- integer, intent(in) :: alarmID
- type (MPAS_TimeInterval_type), intent(in), optional :: interval
- integer, intent(out), optional :: ierr
-
- type (MPAS_Alarm_type), pointer :: alarmPtr
-
- if (present(ierr)) ierr = 0
-
- MPAS_isAlarmRinging = .false.
-
- alarmPtr => clock % alarmListHead
- do while (associated(alarmPtr))
- if (alarmPtr % alarmID == alarmID) then
- if (alarmPtr % isSet) then
- if (MPAS_inRingingEnvelope(clock, alarmPtr, interval, ierr)) then
- MPAS_isAlarmRinging = .true.
- end if
- end if
- exit
- end if
- alarmPtr => alarmPtr % next
- end do
-
- end function MPAS_isAlarmRinging
-
-
-
- subroutine MPAS_getClockRingingAlarms(clock, nAlarms, alarmList, interval, ierr)
-
- implicit none
-
- type (MPAS_Clock_type), intent(in) :: clock
- integer, intent(out) :: nAlarms
- integer, dimension(MPAS_MAX_ALARMS), intent(out) :: alarmList
- type (MPAS_TimeInterval_type), intent(in), optional :: interval
- integer, intent(out), optional :: ierr
-
- type (MPAS_Alarm_type), pointer :: alarmPtr
-
- if (present(ierr)) ierr = 0
-
- nAlarms = 0
-
- alarmPtr => clock % alarmListHead
- do while (associated(alarmPtr))
- if (alarmPtr % isSet) then
- if (MPAS_inRingingEnvelope(clock, alarmPtr, interval, ierr)) then
- nAlarms = nAlarms + 1
- alarmList(nAlarms) = alarmPtr % alarmID
- end if
- end if
- alarmPtr => alarmPtr % next
- end do
-
- end subroutine MPAS_getClockRingingAlarms
-
-
- logical function MPAS_inRingingEnvelope(clock, alarmPtr, interval, ierr)
-
- implicit none
-
- type (MPAS_Clock_type), intent(in) :: clock
- type (MPAS_Alarm_type), pointer, intent(in) :: alarmPtr
- type (MPAS_TimeInterval_type), intent(in), optional :: interval
- integer, intent(out), optional :: ierr
-
- type (MPAS_Time_type) :: alarmNow
- type (MPAS_Time_type) :: alarmThreshold
-
- alarmNow = MPAS_getClockTime(clock, MPAS_NOW, ierr)
- alarmThreshold = alarmPtr % ringTime
-
- MPAS_inRingingEnvelope = .false.
-
- if(clock % direction == MPAS_FORWARD) then
-
- if (present(interval)) then
- alarmNow = alarmNow + interval;
- end if
-
- if (alarmPtr % isRecurring) then
- alarmThreshold = alarmPtr % prevRingTime + alarmPtr % ringTimeInterval
- end if
-
- if (alarmThreshold <= alarmNow) then
- MPAS_inRingingEnvelope = .true.
- end if
- else
-
- if (present(interval)) then
- alarmNow = alarmNow - interval;
- end if
-
- if (alarmPtr % isRecurring) then
- alarmThreshold = alarmPtr % prevRingTime - alarmPtr % ringTimeInterval
- end if
-
- if (alarmThreshold >= alarmNow) then
- MPAS_inRingingEnvelope = .true.
- end if
- end if
-
- end function MPAS_inRingingEnvelope
-
-
-
- subroutine MPAS_resetClockAlarm(clock, alarmID, interval, ierr)
-
- implicit none
-
- type (MPAS_Clock_type), intent(inout) :: clock
- integer, intent(in) :: alarmID
- type (MPAS_TimeInterval_type), intent(in), optional :: interval
- integer, intent(out), optional :: ierr
-
- type (MPAS_Time_type) :: alarmNow
- type (MPAS_Alarm_type), pointer :: alarmPtr
-
- if (present(ierr)) ierr = 0
-
- alarmPtr => clock % alarmListHead
- do while (associated(alarmPtr))
-
- if (alarmPtr % alarmID == alarmID) then
-
- if (MPAS_inRingingEnvelope(clock, alarmPtr, interval, ierr)) then
-
- if (.not. alarmPtr % isRecurring) then
- alarmPtr % isSet = .false.
- else
- alarmNow = MPAS_getClockTime(clock, MPAS_NOW, ierr)
-
- if(clock % direction == MPAS_FORWARD) then
- if (present(interval)) then
- alarmNow = alarmNow + interval
- end if
-
- do while(alarmPtr % prevRingTime <= alarmNow)
- alarmPtr % prevRingTime = alarmPtr % prevRingTime + alarmPtr % ringTimeInterval
- end do
- alarmPtr % prevRingTime = alarmPtr % prevRingTime - alarmPtr % ringTimeInterval
- else
- if (present(interval)) then
- alarmNow = alarmNow - interval
- end if
-
- do while(alarmPtr % prevRingTime >= alarmNow)
- alarmPtr % prevRingTime = alarmPtr % prevRingTime - alarmPtr % ringTimeInterval
- end do
- alarmPtr % prevRingTime = alarmPtr % prevRingTime + alarmPtr % ringTimeInterval
- end if
- end if
- end if
- exit
- end if
- alarmPtr => alarmPtr % next
- end do
-
- end subroutine MPAS_resetClockAlarm
-
-
-
- ! specify a valid previousRingTime for each alarm
- subroutine MPAS_CalibrateAlarms(clock, ierr)
-
- implicit none
-
- type (MPAS_Clock_type), intent(in) :: clock
- integer, intent(out), optional :: ierr
-
- type (MPAS_Time_type) :: now
- type (MPAS_Time_type) :: previousRingTime
- type (MPAS_Time_type) :: negativeNeighborRingTime
- type (MPAS_Time_type) :: positiveNeighborRingTime
- type (MPAS_TimeInterval_type) :: ringTimeInterval
- type (MPAS_Alarm_type), pointer :: alarmPtr
-
- now = MPAS_getClockTime(clock, MPAS_NOW, ierr)
-
- alarmPtr => clock % alarmListHead
- do while (associated(alarmPtr))
-
- if (.not. alarmPtr % isRecurring) then
- alarmPtr % isSet = .true.
- else
-
- previousRingTime = alarmPtr % prevRingTime
-
- if (previousRingTime <= now) then
-
- do while(previousRingTime <= now)
- previousRingTime = previousRingTime + alarmPtr % ringTimeInterval
- end do
- positiveNeighborRingTime = previousRingTime
-
- do while(previousRingTime >= now)
- previousRingTime = previousRingTime - alarmPtr % ringTimeInterval
- end do
- negativeNeighborRingTime = previousRingTime
-
- else
-
- do while(previousRingTime >= now)
- previousRingTime = previousRingTime - alarmPtr % ringTimeInterval
- end do
- negativeNeighborRingTime = previousRingTime
-
- do while(previousRingTime <= now)
- previousRingTime = previousRingTime + alarmPtr % ringTimeInterval
- end do
- positiveNeighborRingTime = previousRingTime
-
- end if
-
- if (clock % direction == MPAS_FORWARD) then
- alarmPtr % prevRingTime = negativeNeighborRingTime
- else
- alarmPtr % prevRingTime = positiveNeighborRingTime
- end if
-
- end if
-
- alarmPtr => alarmPtr % next
-
- end do
-
- if (present(ierr)) then
- if (ierr == ESMF_SUCCESS) ierr = 0
- end if
-
- end subroutine MPAS_CalibrateAlarms
-
-
- subroutine MPAS_setTime(curr_time, YYYY, MM, DD, DoY, H, M, S, S_n, S_d, dateTimeString, ierr)
-
- implicit none
-
- type (MPAS_Time_type), intent(out) :: curr_time
- integer, intent(in), optional :: YYYY
- integer, intent(in), optional :: MM
- integer, intent(in), optional :: DD
- integer, intent(in), optional :: DoY
- integer, intent(in), optional :: H
- integer, intent(in), optional :: M
- integer, intent(in), optional :: S
- integer, intent(in), optional :: S_n
- integer, intent(in), optional :: S_d
- character (len=*), intent(in), optional :: dateTimeString
- integer, intent(out), optional :: ierr
-
- integer, parameter :: integerMaxDigits = 8
- integer :: year, month, day, hour, min, sec
- integer :: numerator, denominator, denominatorPower
-
- character (len=50) :: dateTimeString_
- character (len=50) :: dateSubString
- character (len=50) :: timeSubString
- character (len=50) :: secDecSubString
- character(len=50), pointer, dimension(:) :: subStrings
-
- if (present(dateTimeString)) then
-
- dateTimeString_ = dateTimeString
- numerator = 0
- denominator = 1
-
- call SplitString(dateTimeString_, ".", subStrings)
- if (size(subStrings) == 2) then ! contains second decimals
- dateTimeString_ = subStrings(1)
- secDecSubString = subStrings(2)(:integerMaxDigits)
- deallocate(subStrings)
- denominatorPower = len_trim(secDecSubString)
- if(denominatorPower > 0) then
- read(secDecSubString,*) numerator
- if(numerator > 0) then
- denominator = 10**denominatorPower
- end if
- end if
- else if (size(subStrings) /= 1) then
- deallocate(subStrings)
- if (present(ierr)) ierr = 1
- write(0,*) 'ERROR: Invalid DateTime string', dateTimeString
- return
- end if
-
- call SplitString(dateTimeString_, "_", subStrings)
-
- if(size(subStrings) == 2) then ! contains a date and time
- dateSubString = subStrings(1)
- timeSubString = subStrings(2)
- deallocate(subStrings)
-
- call SplitString(timeSubString, ":", subStrings)
-
- if (size(subStrings) == 3) then
- read(subStrings(1),*) hour
- read(subStrings(2),*) min
- read(subStrings(3),*) sec
- deallocate(subStrings)
- else
- deallocate(subStrings)
- if (present(ierr)) ierr = 1
- write(0,*) 'ERROR: Invalid DateTime string (invalid time substring)', dateTimeString
- return
- end if
-
- else if(size(subStrings) == 1) then ! contains only a date- assume all time values are 0
- dateSubString = subStrings(1)
- deallocate(subStrings)
-
- hour = 0
- min = 0
- sec = 0
-
- else
- deallocate(subStrings)
- if (present(ierr)) ierr = 1
- write(0,*) 'ERROR: Invalid DateTime string', dateTimeString
- return
- end if
-
- call SplitString(dateSubString, "-", subStrings)
-
- if (size(subStrings) == 3) then
- read(subStrings(1),*) year
- read(subStrings(2),*) month
- read(subStrings(3),*) day
- deallocate(subStrings)
- else
- deallocate(subStrings)
- if (present(ierr)) ierr = 1
- write(0,*) 'ERROR: Invalid DateTime string (invalid date substring)', dateTimeString
- return
- end if
-
- call ESMF_TimeSet(curr_time % t, YY=year, MM=month, DD=day, H=hour, M=min, S=sec, Sn=numerator, Sd=denominator, rc=ierr)
-
- else
-
- if (present(DoY)) then
- call getMonthDay(YYYY, DoY, month, day)
-
- ! consistency check
- if (present(MM)) then
- if (MM /= month) then
- if (present(ierr)) ierr = 1
- write(0,*) 'ERROR: MPAS_setTime : DoY and MM are inconsistent - using DoY'
- end if
- end if
- if (present(DD)) then
- if (DD /= day) then
- if (present(ierr)) ierr = 1
- write(0,*) 'ERROR: MPAS_setTime : DoY and DD are inconsistent - using DoY'
- end if
- end if
- else
- if (present(MM)) then
- month = MM
- else
- if (present(ierr)) ierr = 1
- write(0,*) 'ERROR: MPAS_setTime : Neither DoY nor MM are specified'
- return
- end if
-
- if (present(DD)) then
- day = DD
- else
- if (present(ierr)) ierr = 1
- write(0,*) 'ERROR: MPAS_setTime : Neither DoY nor DD are specified'
- return
- end if
- end if
-
- if (.not. isValidDate(YYYY,month,day)) then
- write(0,*) 'ERROR: MPAS_setTime : Invalid date'
- return
- end if
-
- call ESMF_TimeSet(curr_time % t, YY=YYYY, MM=month, DD=day, H=H, M=M, S=S, Sn=S_n, Sd=S_d, rc=ierr)
-
- end if
-
- if (present(ierr)) then
- if (ierr == ESMF_SUCCESS) ierr = 0
- end if
-
- end subroutine MPAS_setTime
-
-
- subroutine MPAS_getTime(curr_time, YYYY, MM, DD, DoY, H, M, S, S_n, S_d, dateTimeString, ierr)
-
- implicit none
-
- type (MPAS_Time_type), intent(in) :: curr_time
- integer, intent(out), optional :: YYYY
- integer, intent(out), optional :: MM
- integer, intent(out), optional :: DD
- integer, intent(out), optional :: DoY
- integer, intent(out), optional :: H
- integer, intent(out), optional :: M
- integer, intent(out), optional :: S
- integer, intent(out), optional :: S_n
- integer, intent(out), optional :: S_d
- character (len=32), intent(out), optional :: dateTimeString
- integer, intent(out), optional :: ierr
-
- call ESMF_TimeGet(curr_time % t, YY=YYYY, MM=MM, DD=DD, H=H, M=M, S=S, Sn=S_n, Sd=S_d, rc=ierr)
- call ESMF_TimeGet(curr_time % t, dayOfYear=DoY, rc=ierr)
- call ESMF_TimeGet(curr_time % t, timeString=dateTimeString, rc=ierr)
- if (present(ierr)) then
- if (ierr == ESMF_SUCCESS) ierr = 0
- end if
-
- end subroutine MPAS_getTime
-
-
- subroutine MPAS_setTimeInterval(interval, DD, H, M, S, S_n, S_d, timeString, dt, ierr)
-
- implicit none
-
- type (MPAS_TimeInterval_type), intent(out) :: interval
- integer, intent(in), optional :: DD
- integer, intent(in), optional :: H
- integer, intent(in), optional :: M
- integer, intent(in), optional :: S
- integer, intent(in), optional :: S_n
- integer, intent(in), optional :: S_d
- character (len=*), intent(in), optional :: timeString
- real (kind=RKIND), intent(in), optional :: dt
- integer, intent(out), optional :: ierr
-
- integer, parameter :: integerMaxDigits = 8
- integer :: days, hours, minutes, seconds
- integer :: numerator, denominator, denominatorPower
- type (MPAS_TimeInterval_type) :: zeroInterval
-
- integer :: day, hour, min, sec
- character (len=50) :: timeString_
- character (len=50) :: daySubString
- character (len=50) :: timeSubString
- character (len=50) :: secDecSubString
- character(len=50), pointer, dimension(:) :: subStrings
-
-! if (present(DD)) then
-! days = DD
-! else
-! days = 0
-! end if
-
-! if (present(H)) then
-! hours = H
-! else
-! hours = 0
-! end if
-
-! if (present(M)) then
-! minutes = M
-! else
-! minutes = 0
-! end if
-
-! if (present(S)) then
-! seconds = S
-! else
-! seconds = 0
-! end if
-
-
- !
- ! Reduce minute count to something less than one hour
- !
-! do while (minutes > 1440)
-! days = days + 1
-! minutes = minutes - 1440
-! end do
-! do while (minutes > 60)
-! hours = hours + 1
-! minutes = minutes - 60
-! end do
-! do while (minutes < -1440)
-! days = days - 1
-! minutes = minutes + 1440
-! end do
-! do while (minutes < -60)
-! hours = hours - 1
-! minutes = minutes + 60
-! end do
-
- !
- ! Reduce hour count to something less than one day
- !
-! do while (hours > 24)
-! days = days + 1
-! hours = hours - 24
-! end do
-! do while (hours < -24)
-! days = days - 1
-! hours = hours + 24
-! end do
-
- !
- ! Any leftover minutes and hours are given to the second count
- !
-! seconds = seconds + hours*3600 + minutes*60
-
-! call ESMF_TimeIntervalSet(interval % ti, D=days, S=seconds, Sn=S_n, Sd=S_d, rc=ierr)
-
-
- if (present(timeString) .or. present(dt)) then
-
-
- if(present(dt)) then
- write (timeString_,*) "00:00:", dt
- else
- timeString_ = timeString
- end if
-
- numerator = 0
- denominator = 1
-
- call SplitString(timeString_, ".", subStrings)
-
- if (size(subStrings) == 2) then ! contains second decimals
- timeString_ = subStrings(1)
- secDecSubString = subStrings(2)(:integerMaxDigits)
- deallocate(subStrings)
-
- denominatorPower = len_trim(secDecSubString)
- if(denominatorPower > 0) then
- read(secDecSubString,*) numerator
- if(numerator > 0) then
- denominator = 10**denominatorPower
- end if
- end if
- else if (size(subStrings) /= 1) then
- deallocate(subStrings)
- if (present(ierr)) ierr = 1
- write(0,*) 'ERROR: Invalid TimeInterval string', timeString
- return
- end if
-
- call SplitString(timeString_, "_", subStrings)
-
- if(size(subStrings) == 2) then ! contains a day and time
- daySubString = subStrings(1)
- timeSubString = subStrings(2)
- deallocate(subStrings)
- read(daySubString,*) day
- else if(size(subStrings) == 1) then ! contains only a time- assume day is 0
- timeSubString = subStrings(1)
- deallocate(subStrings)
- day = 0
- else
- deallocate(subStrings)
- if (present(ierr)) ierr = 1
- write(0,*) 'ERROR: Invalid TimeInterval string', timeString
- return
- end if
-
- call SplitString(timeSubString, ":", subStrings)
-
- if (size(subStrings) == 3) then
- read(subStrings(1),*) hour
- read(subStrings(2),*) min
- read(subStrings(3),*) sec
- deallocate(subStrings)
- else
- deallocate(subStrings)
- if (present(ierr)) ierr = 1
- write(0,*) 'ERROR: Invalid TimeInterval string (invalid time substring)', timeString
- return
- end if
-
- call ESMF_TimeIntervalSet(interval % ti, D=day, H=hour, M=min, S=sec, Sn=numerator, Sd=denominator, rc=ierr)
-
- else
-
- call ESMF_TimeIntervalSet(interval % ti, D=DD, H=H, M=M, S=S, Sn=S_n, Sd=S_d, rc=ierr)
-
- end if
-
- ! verify that time interval is positive
- call ESMF_TimeIntervalSet(zeroInterval % ti, D=0, H=0, M=0, S=0, rc=ierr)
-
- if (present(ierr)) then
- if (ierr == ESMF_SUCCESS) ierr = 0
- end if
-
- if (interval <= zeroInterval) then
- if (present(ierr)) ierr = 1
- write(0,*) 'ERROR: TimeInterval must be greater than 0', timeString !'ERROR: TimeInterval cannot be negative'
- end if
-
-
-
- end subroutine MPAS_setTimeInterval
-
-
- subroutine MPAS_getTimeInterval(interval, DD, H, M, S, S_n, S_d, timeString, dt, ierr)
-! TODO: add double-precision seconds
-
- implicit none
-
- type (MPAS_TimeInterval_type), intent(in) :: interval
- integer, intent(out), optional :: DD
- integer, intent(out), optional :: H
- integer, intent(out), optional :: M
- integer, intent(out), optional :: S
- integer, intent(out), optional :: S_n
- integer, intent(out), optional :: S_d
- character (len=32), intent(out), optional :: timeString
- real (kind=RKIND), intent(out), optional :: dt
- integer, intent(out), optional :: ierr
-
- integer :: days, seconds, sn, sd
-
- call ESMF_TimeIntervalGet(interval % ti, D=days, S=seconds, Sn=sn, Sd=sd, rc=ierr)
-
- if (present(dt)) then
- dt = (days * 24 * 60 * 60) + seconds + (sn / sd)
- end if
-
- if (present(DD)) then
- DD = days
- days = 0
- end if
-
- if (present(H)) then
- H = (seconds - mod(seconds,3600)) / 3600
- seconds = seconds - H*3600
- H = H + days * 24
- days = 0
- end if
-
- if (present(M)) then
- M = (seconds - mod(seconds,60)) / 60
- seconds = seconds - M*60
- M = M + days * 1440
- days = 0
- end if
-
- if (present(S)) then
- S = seconds
- end if
-
- if (present(S_n)) then
- S_n = sn
- end if
-
- if (present(S_d)) then
- S_d = sd
- end if
-
- if (present(timeString)) then
- call ESMF_TimeIntervalGet(interval % ti, timeString=timeString, rc=ierr)
- end if
-
- if (present(ierr)) then
- if (ierr == ESMF_SUCCESS) ierr = 0
- end if
-
- end subroutine MPAS_getTimeInterval
-
-
- type (MPAS_Time_type) function add_t_ti(t, ti)
-
- implicit none
-
- type (MPAS_Time_type), intent(in) :: t
- type (MPAS_TimeInterval_type), intent(in) :: ti
-
- add_t_ti % t = t % t + ti % ti
-
- end function add_t_ti
-
-
- type (MPAS_TimeInterval_type) function add_ti_ti(ti1, ti2)
-
- implicit none
-
- type (MPAS_TimeInterval_type), intent(in) :: ti1, ti2
-
- add_ti_ti % ti = ti1 % ti + ti2 % ti
-
- end function add_ti_ti
-
-
- type (MPAS_TimeInterval_type) function sub_t_t(t1, t2)
-
- implicit none
-
- type (MPAS_Time_type), intent(in) :: t1, t2
-
- sub_t_t % ti = t1 % t - t2 % t
-
- end function sub_t_t
-
-
- type (MPAS_Time_type) function sub_t_ti(t, ti)
-
- implicit none
-
- type (MPAS_Time_type), intent(in) :: t
- type (MPAS_TimeInterval_type), intent(in) :: ti
-
- sub_t_ti % t = t % t - ti % ti
-
- end function sub_t_ti
-
-
- type (MPAS_TimeInterval_type) function sub_ti_ti(ti1, ti2)
-
- implicit none
-
- type (MPAS_TimeInterval_type), intent(in) :: ti1, ti2
-
- sub_ti_ti % ti = ti1 % ti - ti2 % ti
-
- end function sub_ti_ti
-
-
- type (MPAS_TimeInterval_type) function mul_ti_n(ti, n)
-
- implicit none
-
- type (MPAS_TimeInterval_type), intent(in) :: ti
- integer, intent(in) :: n
-
- mul_ti_n % ti = ti % ti * n
-
- end function mul_ti_n
-
-
- type (MPAS_TimeInterval_type) function div_ti_n(ti, n)
-
- implicit none
-
- type (MPAS_TimeInterval_type), intent(in) :: ti
- integer, intent(in) :: n
-
- div_ti_n % ti = ti % ti / n
-
- end function div_ti_n
-
-
- logical function eq_t_t(t1, t2)
-
- implicit none
-
- type (MPAS_Time_type), intent(in) :: t1, t2
-
- eq_t_t = (t1 % t == t2 % t)
-
- end function eq_t_t
-
-
- logical function ne_t_t(t1, t2)
-
- implicit none
-
- type (MPAS_Time_type), intent(in) :: t1, t2
-
- ne_t_t = (t1 % t /= t2 % t)
-
- end function ne_t_t
-
-
- logical function lt_t_t(t1, t2)
-
- implicit none
-
- type (MPAS_Time_type), intent(in) :: t1, t2
-
- lt_t_t = (t1 % t < t2 % t)
-
- end function lt_t_t
-
-
- logical function gt_t_t(t1, t2)
-
- implicit none
-
- type (MPAS_Time_type), intent(in) :: t1, t2
-
- gt_t_t = (t1 % t > t2 % t)
-
- end function gt_t_t
-
-
- logical function le_t_t(t1, t2)
-
- implicit none
-
- type (MPAS_Time_type), intent(in) :: t1, t2
-
- le_t_t = (t1 % t <= t2 % t)
-
- end function le_t_t
-
-
- logical function ge_t_t(t1, t2)
-
- implicit none
-
- type (MPAS_Time_type), intent(in) :: t1, t2
-
- ge_t_t = (t1 % t >= t2 % t)
-
- end function ge_t_t
-
-
- logical function eq_ti_ti(ti1, ti2)
-
- implicit none
-
- type (MPAS_TimeInterval_type), intent(in) :: ti1, ti2
-
- eq_ti_ti = (ti1 % ti == ti2 % ti)
-
- end function eq_ti_ti
-
-
- logical function ne_ti_ti(ti1, ti2)
-
- implicit none
-
- type (MPAS_TimeInterval_type), intent(in) :: ti1, ti2
-
- ne_ti_ti = (ti1 % ti /= ti2 % ti)
-
- end function ne_ti_ti
-
-
- logical function lt_ti_ti(ti1, ti2)
-
- implicit none
-
- type (MPAS_TimeInterval_type), intent(in) :: ti1, ti2
-
- lt_ti_ti = (ti1 % ti < ti2 % ti)
-
- end function lt_ti_ti
-
-
- logical function gt_ti_ti(ti1, ti2)
-
- implicit none
-
- type (MPAS_TimeInterval_type), intent(in) :: ti1, ti2
-
- gt_ti_ti = (ti1 % ti > ti2 % ti)
-
- end function gt_ti_ti
-
-
- logical function le_ti_ti(ti1, ti2)
-
- implicit none
-
- type (MPAS_TimeInterval_type), intent(in) :: ti1, ti2
-
- le_ti_ti = (ti1 % ti <= ti2 % ti)
-
- end function le_ti_ti
-
-
- logical function ge_ti_ti(ti1, ti2)
-
- implicit none
-
- type (MPAS_TimeInterval_type), intent(in) :: ti1, ti2
-
- ge_ti_ti = (ti1 % ti >= ti2 % ti)
-
- end function ge_ti_ti
-
-
- type (MPAS_TimeInterval_type) function neg_ti(ti)
-
- implicit none
-
- type (MPAS_TimeInterval_type), intent(in) :: ti
-
- integer :: rc
- integer :: D, S, Sn, Sd
-
- call ESMF_TimeIntervalGet(ti % ti, D=D, S=S, Sn=Sn, Sd=Sd, rc=rc)
- D = -D
- S = -S
- Sn = -Sn
- call ESMF_TimeIntervalSet(neg_ti % ti, D=D, S=S, Sn=Sn, Sd=Sd, rc=rc)
-
- end function neg_ti
-
-
- type (MPAS_TimeInterval_type) function abs_ti(ti)
-
- implicit none
-
- type (MPAS_TimeInterval_type), intent(in) :: ti
-
- type (MPAS_TimeInterval_type) :: zeroInterval
- integer :: rc
- integer :: D, S, Sn, Sd
-
- call ESMF_TimeIntervalSet(zeroInterval % ti, D=0, H=0, M=0, S=0, rc=rc)
-
- if(ti < zeroInterval) then
- call ESMF_TimeIntervalGet(ti % ti, D=D, S=S, Sn=Sn, Sd=Sd, rc=rc)
- D = -D
- S = -S
- Sn = -Sn
- call ESMF_TimeIntervalSet(abs_ti % ti, D=D, S=S, Sn=Sn, Sd=Sd, rc=rc)
- else
- abs_ti = ti
- end if
-
- end function abs_ti
-
-
-! TODO: Implement this function
-! type (MPAS_TimeInterval_type) function mod(ti1, ti2)
-!
-! implicit none
-!
-! type (MPAS_TimeInterval_type), intent(in) :: ti1, ti2
-!
-! mod % ti = mod(ti1 % ti, ti2 % ti)
-!
-! end function mod
-
-
- subroutine SplitString(string, delimiter, subStrings)
-
- implicit none
-
- character(len=*), intent(in) :: string
- character, intent(in) :: delimiter
- character(len=*), pointer, dimension(:) :: subStrings
-
- integer :: i, start, index
-
- index = 1
- do i = 1, len(string)
- if(string(i:i) == delimiter) then
- index = index + 1
- end if
- end do
-
- allocate(subStrings(1:index))
-
- start = 1
- index = 1
- do i = 1, len(string)
- if(string(i:i) == delimiter) then
- subStrings(index) = string(start:i-1)
- index = index + 1
- start = i + 1
- end if
- end do
- subStrings(index) = string(start:len(string))
-
- end subroutine SplitString
-
-
- subroutine getMonthDay(YYYY, DoY, month, day)
-
- implicit none
-
- integer, intent(in) :: YYYY, DoY
- integer, intent(out) :: month, day
-
- integer, dimension(12) :: dpm
-
- if (isLeapYear(YYYY)) then
- dpm(:) = daysInMonthLeap
- else
- dpm(:) = daysInMonth
- end if
-
- month = 1
- day = DoY
- do while (day > dpm(month))
- day = day - dpm(month)
- month = month + 1
- end do
-
- end subroutine getMonthDay
-
-
- logical function isValidDate(YYYY, MM, DD)
-
- integer, intent(in) :: YYYY, MM, DD
- integer :: daysInMM
-
- isValidDate = .true.
-
- ! TODO: ???? Gregorian calendar has no year zero, but perhaps 0 = 1 BC ???
- !if (YYYY == 0) then
- ! isValidDate = .false.
- ! return
- !end if
-
- if (MM < 1 .or. MM > 12) then
- isValidDate = .false.
- return
- end if
-
- if (DD < 1) then
- isValidDate = .false.
- return
- end if
-
- if(TheCalendar == MPAS_360DAY) then
- daysInMM = 30
- else
- if (TheCalendar == MPAS_GREGORIAN .and. isLeapYear(YYYY)) then
- daysInMM = daysInMonthLeap(MM)
- else
- daysInMM = daysInMonth(MM)
- end if
- end if
-
- if (DD > daysInMM) then
- isValidDate = .false.
- return
- end if
-
- end function
-
-
- logical function isLeapYear(year)
-
- implicit none
-
- integer, intent(in) :: year
-
- isLeapYear = .false.
-
- if (mod(year,4) == 0) then
- if (mod(year,100) == 0) then
- if (mod(year,400) == 0) then
- isLeapYear = .true.
- end if
- else
- isLeapYear = .true.
- end if
- end if
-
- end function isLeapYear
-
-
-
-
-
-end module mpas_timekeeping
-
-
-
-subroutine wrf_error_fatal(msg)
-
- implicit none
-
- character (len=*) :: msg
-
- write(0,*) 'MPAS_TIMEKEEPING: '//trim(msg)
-
- stop
-
-end subroutine wrf_error_fatal
Deleted: trunk/mpas/src/framework/module_sort.F
===================================================================
--- trunk/mpas/src/framework/module_sort.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/framework/module_sort.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -1,230 +0,0 @@
-module sort
-
- interface quicksort
- module procedure quicksort_int
- module procedure quicksort_real
- end interface
-
-
- contains
-
-
- recursive subroutine mergesort(array, d1, n1, n2)
-
- implicit none
-
- ! Arguments
- integer, intent(in) :: n1, n2, d1
- integer, dimension(1:d1,n1:n2), intent(inout) :: array
-
- ! Local variables
- integer :: i, j, k
- integer :: rtemp
- integer, dimension(1:d1,1:n2-n1+1) :: temp
-
- if (n1 >= n2) return
-
- if (n2 - n1 == 1) then
- if (array(1,n1) > array(1,n2)) then
- do i=1,d1
- rtemp = array(i,n1)
- array(i,n1) = array(i,n2)
- array(i,n2) = rtemp
- end do
- end if
- return
- end if
-
- call mergesort(array(1:d1,n1:n1+(n2-n1+1)/2), d1, n1, n1+(n2-n1+1)/2)
- call mergesort(array(1:d1,n1+((n2-n1+1)/2)+1:n2), d1, n1+((n2-n1+1)/2)+1, n2)
-
- i = n1
- j = n1 + ((n2-n1+1)/2) + 1
- k = 1
- do while (i <= n1+(n2-n1+1)/2 .and. j <= n2)
- if (array(1,i) < array(1,j)) then
- temp(1:d1,k) = array(1:d1,i)
- k = k + 1
- i = i + 1
- else
- temp(1:d1,k) = array(1:d1,j)
- k = k + 1
- j = j + 1
- end if
- end do
-
- if (i <= n1+(n2-n1+1)/2) then
- do while (i <= n1+(n2-n1+1)/2)
- temp(1:d1,k) = array(1:d1,i)
- i = i + 1
- k = k + 1
- end do
- else
- do while (j <= n2)
- temp(1:d1,k) = array(1:d1,j)
- j = j + 1
- k = k + 1
- end do
- end if
-
- array(1:d1,n1:n2) = temp(1:d1,1:k-1)
-
- end subroutine mergesort
-
-
- subroutine quicksort_int(nArray, array)
-
- implicit none
-
- integer, intent(in) :: nArray
- integer, dimension(2,nArray), intent(inout) :: array
-
- integer :: i, j, top, l, r, pivot, s
- integer :: pivot_value
- integer, dimension(2) :: temp
- integer, dimension(1000) :: lstack, rstack
-
- if (nArray < 1) return
-
- top = 1
- lstack(top) = 1
- rstack(top) = nArray
-
- do while (top > 0)
-
- l = lstack(top)
- r = rstack(top)
- top = top - 1
-
- pivot = (l+r)/2
-
- pivot_value = array(1,pivot)
- temp(:) = array(:,pivot)
- array(:,pivot) = array(:,r)
- array(:,r) = temp(:)
-
- s = l
- do i=l,r-1
- if (array(1,i) <= pivot_value) then
- temp(:) = array(:,s)
- array(:,s) = array(:,i)
- array(:,i) = temp(:)
- s = s + 1
- end if
- end do
-
- temp(:) = array(:,s)
- array(:,s) = array(:,r)
- array(:,r) = temp(:)
-
- if (s-1 > l) then
- top = top + 1
-if (top > 1000) write(0,*) 'Error: Quicksort exhausted its stack.'
- lstack(top) = l
- rstack(top) = s-1
- end if
-
- if (r > s+1) then
- top = top + 1
-if (top > 1000) write(0,*) 'Error: Quicksort exhausted its stack.'
- lstack(top) = s+1
- rstack(top) = r
- end if
- end do
-
- end subroutine quicksort_int
-
-
- subroutine quicksort_real(nArray, array)
-
- implicit none
-
- integer, intent(in) :: nArray
- real (kind=RKIND), dimension(2,nArray), intent(inout) :: array
-
- integer :: i, j, top, l, r, pivot, s
- real (kind=RKIND) :: pivot_value
- real (kind=RKIND), dimension(2) :: temp
- integer, dimension(1000) :: lstack, rstack
-
- if (nArray < 1) return
-
- top = 1
- lstack(top) = 1
- rstack(top) = nArray
-
- do while (top > 0)
-
- l = lstack(top)
- r = rstack(top)
- top = top - 1
-
- pivot = (l+r)/2
-
- pivot_value = array(1,pivot)
- temp(:) = array(:,pivot)
- array(:,pivot) = array(:,r)
- array(:,r) = temp(:)
-
- s = l
- do i=l,r-1
- if (array(1,i) <= pivot_value) then
- temp(:) = array(:,s)
- array(:,s) = array(:,i)
- array(:,i) = temp(:)
- s = s + 1
- end if
- end do
-
- temp(:) = array(:,s)
- array(:,s) = array(:,r)
- array(:,r) = temp(:)
-
- if (s-1 > l) then
- top = top + 1
-if (top > 1000) write(0,*) 'Error: Quicksort exhausted its stack.'
- lstack(top) = l
- rstack(top) = s-1
- end if
-
- if (r > s+1) then
- top = top + 1
-if (top > 1000) write(0,*) 'Error: Quicksort exhausted its stack.'
- lstack(top) = s+1
- rstack(top) = r
- end if
- end do
-
- end subroutine quicksort_real
-
-
- integer function binary_search(array, d1, n1, n2, key)
-
- implicit none
-
- integer, intent(in) :: d1, n1, n2, key
- integer, dimension(d1,n1:n2), intent(in) :: array
-
- integer :: l, u, k
-
- binary_search = n2+1
-
- l = n1
- u = n2
- k = (l+u)/2
- do while (u >= l)
- if (array(1,k) == key) then
- binary_search = k
- exit
- else if (array(1,k) < key) then
- l = k + 1
- k = (l+u)/2
- else
- u = k - 1
- k = (l+u)/2
- end if
- end do
-
- end function binary_search
-
-end module sort
Deleted: trunk/mpas/src/framework/module_timer.F
===================================================================
--- trunk/mpas/src/framework/module_timer.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/framework/module_timer.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -1,293 +0,0 @@
- module timer
-
- implicit none
- save
-! private
-
-#ifdef _PAPI
- include 'f90papi.h'
-#endif
-
-#ifdef _MPI
- include 'mpif.h'
-#endif
-
- type timer_node
- character (len=72) :: timer_name
- logical :: running, printable
- integer :: levels, calls
- real (kind=RKIND) :: start_time, end_time, total_time
- real (kind=RKIND) :: max_time, min_time, avg_time
- type (timer_node), pointer :: next
- end type timer_node
-
- type (timer_node), pointer :: all_timers
- integer :: levels
-
- public :: timer_start, &
- timer_stop, &
- timer_write
-
- contains
-
- subroutine timer_start(timer_name, clear_timer, timer_ptr)!{{{
- character (len=*), intent (in) :: timer_name !< Input: name of timer, stored as name of timer
- logical, optional, intent(in) :: clear_timer !< Input: flag to clear timer
- type (timer_node), optional, pointer, intent(out) :: timer_ptr !< Output: pointer to store timer in module
-
- logical :: timer_added, timer_found, string_equal, check_flag
- type (timer_node), pointer :: current, temp
-
- integer :: clock, hz, usecs
-
- timer_added = .false.
- timer_found = .false.
-
- if(.not.associated(all_timers)) then
- timer_added = .true.
- allocate(all_timers)
- allocate(all_timers%next)
- levels = 0
-
- all_timers%timer_name = ''
- current => all_timers%next
- nullify(current%next)
- else
- current => all_timers%next
- timer_search: do while ((.not.timer_found) .and. associated(current))
- string_equal = (trim(current%timer_name) == trim(timer_name))
- if(string_equal) then
- timer_found = .true.
- else
- current => current%next
- endif
- end do timer_search
- endif
-
- if(present(timer_ptr)) then
- timer_found = .true.
- if(.not.associated(timer_ptr)) then
- current => all_timers
- find_end_ptr: do while((.not.timer_added) .and. (associated(current%next)))
- current => current%next
- end do find_end_ptr
-
- allocate(timer_ptr)
-
- current%next => timer_ptr
- current => timer_ptr
- nullify(timer_ptr%next)
- current%levels = levels
- current%timer_name = timer_name
- current%running = .false.
- current%total_time = 0.0
- current%max_time = 0.0
- current%min_time = 100000000.0
- current%avg_time = 0.0
- current%calls = 0
- endif
- endif
-
- if(.not.timer_found) then
- current => all_timers
- find_end: do while((.not.timer_added) .and. (associated(current%next)))
- current => current%next
- end do find_end
-
- allocate(current%next)
- current => current%next
-
- nullify(current%next)
- timer_added = .true.
- endif
-
- if(timer_added .and. (.not.timer_found)) then
- current%levels = levels
- current%timer_name = timer_name
- current%running = .false.
- current%total_time = 0.0
- current%max_time = 0.0
- current%min_time = 100000000.0
- current%avg_time = 0.0
- current%calls = 0
- endif
-
- if((timer_added .or. timer_found) .and. (.not.current%running)) then
- current%running = .true.
- levels = levels + 1
-
-#ifdef _PAPI
- call PAPIF_get_real_usec(usecs, check_flag)
- current%start_time = usecs/1.0e6
-#elif _MPI
- current%start_time = MPI_Wtime()
-#else
- call system_clock (count=clock)
- call system_clock (count_rate=hz)
- current%start_time = real(clock,kind=RKIND)/real(hz,kind=RKIND)
-#endif
- endif
-
- if(present(clear_timer)) then
- if(clear_timer) then
- current%start_time = 0.0
- current%end_time = 0.0
- current%total_time = 0.0
- current%max_time = 0.0
- current%min_time = 0.0
- current%avg_time = 0.0
- current%calls = 0
- current%running = .false.
- endif
- endif
-
- if(present(timer_ptr)) then
- timer_ptr => current
- endif
-
- end subroutine timer_start!}}}
-
- subroutine timer_stop(timer_name, timer_ptr)!{{{
- character (len=*), intent(in) :: timer_name !< Input: name of timer to stop
- type (timer_node), pointer, intent(in), optional :: timer_ptr !< Input: pointer to timer, for stopping
-
- type (timer_node), pointer :: current
-
- real (kind=RKIND) :: time_temp
- logical :: timer_found, string_equal, check_flag
- integer :: clock, hz, usecs
-
- timer_found = .false.
-
- if(present(timer_ptr)) then
- timer_found = .true.
- current => timer_ptr
- endif
-
- if(.not.associated(all_timers)) then
- print *,' timer_stop :: timer_stop called with no timers initialized'
- else if(.not. timer_found) then
- current => all_timers
- timer_find: do while(.not.timer_found .and. associated(current))
- string_equal = (trim(current%timer_name) == trim(timer_name))
-
- if(string_equal) then
- timer_found = .true.
- else
- current => current%next
- endif
- end do timer_find
- endif
-
- if(.not.timer_found) then
- print *,' timer_stop :: timer_stop called with timer_name =', timer_name,' when timer has not been started.'
- stop
- endif
-
- if(current%running) then
- current%running = .false.
- levels = levels - 1
-
-#ifdef _PAPI
- call PAPIF_get_real_usec(usecs, check_flag)
- current%end_time = usecs/1.0e6
-#elif _MPI
- current%end_time = MPI_Wtime()
-#else
- call system_clock(count=clock)
- call system_clock(count_rate=hz)
- current%end_time = real(clock,kind=RKIND)/real(hz,kind=RKIND)
-#endif
-
- time_temp = current%end_time - current%start_time
- current%total_time = current%total_time + time_temp
-
- if(time_temp > current%max_time) then
- current%max_time = time_temp
- endif
-
- if(time_temp < current%min_time) then
- current%min_time = time_temp
- endif
-
- current%avg_time = current%avg_time + time_temp
- current%calls = current%calls + 1
- endif
-
- end subroutine timer_stop!}}}
-
- recursive subroutine timer_write(timer_ptr, total_ptr)!{{{
- type (timer_node), pointer, intent(inout), optional :: timer_ptr
- type (timer_node), pointer, intent(in), optional :: total_ptr
- character (len=10) :: tname
-
- logical :: total_found, string_equals
- type (timer_node), pointer :: current, total
- real (kind=RKIND) :: percent
- integer :: i
-
- total_found = .false.
-
- if(present(timer_ptr) .and. (.not.present(total_ptr))) then
- print *,'timer_write :: timer_ptr valid, but total_ptr is not assigned.'
- stop
- else if(present(timer_ptr)) then
- tname = ''
- do i=0,timer_ptr%levels+2
- tname = tname//' '
-! write(*,'(a,$)') ' '
- end do
-! tname = tname//timer_ptr%timer_name
-
- if(timer_ptr%total_time == 0.0d0) then
- timer_ptr%min_time = 0.0d0
- timer_ptr%max_time = 0.0d0
- timer_ptr%avg_time = 0.0d0
- percent = 0.0d0
- else
- timer_ptr%avg_time = timer_ptr%avg_time/timer_ptr%calls
- percent = timer_ptr%total_time/total_ptr%total_time
- endif
-
- write(*,'(i2, 1x, a35, f15.5, i10, 3f15.5, f8.2)') timer_ptr%levels, tname(1:timer_ptr%levels)//timer_ptr%timer_name, timer_ptr%total_time, timer_ptr%calls, timer_ptr%min_time, timer_ptr%max_time, timer_ptr%avg_time, percent
- return
- endif
-
- total => all_timers
-
- find_total: do while((.not.total_found) .and. associated(total))
- string_equals = (trim(total%timer_name) == trim("total time"))
- if(string_equals) then
- total_found = .true.
- else
- total => total%next
- endif
- end do find_total
-
- if(.not.total_found) then
- print *,' timer_write :: no timer named "total time" found.'
- stop
- end if
-
- write(*,'(3x, a10, 24x, a15, a10, a13, a15, a15, a15)') 'timer_name', 'total', 'calls', 'min', 'max', 'avg', 'percent'
- write(*,'(i2, 1x, a35, f15.5, i10, 3f15.5)') total%levels, total%timer_name, total%total_time, total%calls, total%min_time, total%max_time, total%avg_time
-
- current => all_timers
-
- print_timers: do while(associated(current))
- string_equals = (trim(current%timer_name) == trim("total time"))
- string_equals = string_equals .or. (trim(current%timer_name) == trim(" "))
-
- if(.not.string_equals) then
- call timer_write(current, total)
- current => current%next
- else
- current => current%next
- endif
- end do print_timers
-
- end subroutine timer_write!}}}
-
- end module timer
-
-! vim: foldmethod=marker et ts=2
Deleted: trunk/mpas/src/framework/module_zoltan_interface.F
===================================================================
--- trunk/mpas/src/framework/module_zoltan_interface.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/framework/module_zoltan_interface.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -1,581 +0,0 @@
-module zoltan_interface
- use zoltan
-
- implicit none
-
- include 'mpif.h'
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !! Data for reordering cells
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- integer :: numCells
- integer, dimension(:), pointer :: cellIDs
- integer :: geomDim
- real (kind=RKIND), dimension(:), pointer :: cellCoordX, cellCoordY, cellCoordZ
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !! Data for reordering edges
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- integer :: numEdges
- integer, dimension(:), pointer :: edgeIDs
- real (kind=RKIND), dimension(:), pointer :: edgeCoordX, edgeCoordY, edgeCoordZ
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !! Data for reordering vertices
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- integer :: numVerts
- integer, dimension(:), pointer :: vertIDs
- real (kind=RKIND), dimension(:), pointer :: vertCoordX, vertCoordY, vertCoordZ
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-
- contains
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !! Perhaps not necessary, but implemented in case it helps
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine zoltanStart()
-
- integer(Zoltan_INT) :: error
- real(Zoltan_FLOAT) :: version
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !! Body of subroutine
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- error = Zoltan_Initialize(version)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- end subroutine
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine zoltanOrderLocHSFC_Cells(in_numcells,in_cellIDs,in_geomDim,in_cellX, &
- in_cellY, in_cellZ)
- implicit none
-
- integer :: in_numcells
- integer, dimension(:), pointer :: in_cellIDs
- integer :: in_geomDim
- real (kind=RKIND), dimension(:), pointer :: in_cellX, in_cellY, in_cellZ
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !! local variables
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- type(Zoltan_Struct), pointer :: zz_obj
- integer(ZOLTAN_INT) :: ierr
-
- integer :: numGidEntries, i
- integer(ZOLTAN_INT), allocatable :: global_ids(:), permIndices(:),permGIDs(:)
- real(kind=RKIND), allocatable :: permXs(:),permYs(:),permZs(:)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !! Body of subroutine
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- numCells = in_numcells
- cellIDs => in_cellIDs
- geomDim = in_geomDim
- cellCoordX => in_cellX
- cellCoordY => in_cellY
- cellCoordZ => in_cellZ
-
- nullify(zz_obj)
- zz_obj => Zoltan_Create(MPI_COMM_SELF)
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !! General Zoltan Parameters
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ierr = Zoltan_Set_Param(zz_obj, "ORDER_METHOD", "LOCAL_HSFC")
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !! register query functions
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ierr = Zoltan_Set_Fn(zz_obj, ZOLTAN_NUM_OBJ_FN_TYPE,zqfNumCells)
- ierr = Zoltan_Set_Fn(zz_obj, ZOLTAN_OBJ_LIST_FN_TYPE,zqfGetCells)
- ierr = Zoltan_Set_Fn(zz_obj, ZOLTAN_NUM_GEOM_FN_TYPE,zqfGeomDim)
- ierr = Zoltan_Set_Fn(zz_obj, ZOLTAN_GEOM_FN_TYPE, zqfGetCellGeom)
-
- numGidEntries=1
-
- allocate(global_ids(numCells))
- allocate(permIndices(numCells))
- allocate(permGIDs(numCells))
- allocate(permXs(numCells))
- allocate(permYs(numCells))
- allocate(permZs(numCells))
-
- !! MMW: There might be a way to use cellIDs directly
- do i=1,numCells
- global_ids(i) = cellIDs(i)
- end do
-
- ierr = Zoltan_Order(zz_obj, numGidEntries, numCells, global_ids, permIndices);
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!
- !! This is necessary for now until we fix a small bug in Zoltan_Order
- !!!!!!!!!!!!!!!!!!!!!!!!!!
- do i=1,numCells
- permGIDs(i) = global_ids(permIndices(i)+1)
- permXs(i) = cellCoordX(permIndices(i)+1)
- permYs(i) = cellCoordY(permIndices(i)+1)
- permZs(i) = cellCoordZ(permIndices(i)+1)
- end do
-
- !!do i=1,numCells
- !! write(*,*) global_ids(i), permGIDs(i)
- !!end do
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!
- !! Actually change the ordering of the cells
- !!!!!!!!!!!!!!!!!!!!!!!!!!
- do i=1,numCells
- cellIDs(i) = permGIDs(i)
- cellCoordX(i) = permXs(i)
- cellCoordY(i) = permYs(i)
- cellCoordZ(i) = permZs(i)
- end do
- !!!!!!!!!!!!!!!!!!!!!!!!!!
-
- deallocate(global_ids)
- deallocate(permIndices)
- deallocate(permGIDs)
- deallocate(permXs)
- deallocate(permYs)
- deallocate(permZs)
-
- call Zoltan_Destroy(zz_obj)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- end subroutine zoltanOrderLocHSFC_Cells
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !! zoltan query function:
- !! Returns number of cells
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- integer function zqfNumCells(data, ierr)
-
- ! Local declarations
- integer(ZOLTAN_INT), intent(in) :: data(*)
- integer(ZOLTAN_INT), intent(out) :: ierr
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- zqfNumCells = numCells
- ierr = ZOLTAN_OK
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- end function zqfNumCells
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !! zoltan query function:
- !! Returns lists of Cell IDs
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine zqfGetCells (data, num_gid_entries, num_lid_entries, global_ids, &
- local_ids, wgt_dim, obj_wgts, ierr)
- integer(ZOLTAN_INT), intent(in) :: data(*)
- integer(ZOLTAN_INT), intent(in) :: num_gid_entries, num_lid_entries
- integer(ZOLTAN_INT), intent(out) :: global_ids(*), local_ids(*)
- integer(ZOLTAN_INT), intent(in) :: wgt_dim
- real(ZOLTAN_FLOAT), intent(out) :: obj_wgts(*)
- integer(ZOLTAN_INT), intent(out) :: ierr
-
- ! local declarations
- integer :: i
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- do i= 1, numCells
- global_ids(i) = cellIDs(i)
- local_ids(i) = i
- end do
-
- ierr = ZOLTAN_OK
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- end subroutine zqfGetCells
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !! Zoltan Query Function:
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- integer function zqfGeomDim(data, ierr)
- !use zoltan
- implicit none
- integer(ZOLTAN_INT), intent(in) :: data(*)
- integer(ZOLTAN_INT) :: ierr
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- zqfGeomDim = geomDim
- ierr = ZOLTAN_OK
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- end function zqfGeomDim
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !! Zoltan Query Function:
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine zqfGetCellGeom(data, num_gid_entries, num_lid_entries, global_id, &
- local_id, geom_vec, ierr)
- !use zoltan
- implicit none
-
- integer(ZOLTAN_INT), intent(in) :: data(*)
- integer(ZOLTAN_INT), intent(in) :: num_gid_entries, num_lid_entries
- integer(ZOLTAN_INT), intent(in) :: global_id, local_id
- real(ZOLTAN_DOUBLE), intent(out) :: geom_vec(*)
- integer(ZOLTAN_INT), intent(out) :: ierr
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !! Assuming geom_dim is 3
- geom_vec(1) = cellCoordX(local_id)
- geom_vec(2) = cellCoordY(local_id)
- geom_vec(3) = cellCoordZ(local_id)
-
- ierr = ZOLTAN_OK
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- end subroutine zqfGetCellGeom
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !! The ordering functions should perhaps be refactored so that there
- !! are not separate functions for cells, edges, and vertices
- !! Not sure if this is worth it with the additional conditionals that would
- !! be required.
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine zoltanOrderLocHSFC_Edges(in_numedges,in_edgeIDs,in_geomDim,in_edgeX, &
- in_edgeY, in_edgeZ)
- implicit none
-
- integer :: in_numedges
- integer, dimension(:), pointer :: in_edgeIDs
- integer :: in_geomDim
- real (kind=RKIND), dimension(:), pointer :: in_edgeX, in_edgeY, in_edgeZ
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !! local variables
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- type(Zoltan_Struct), pointer :: zz_obj
- integer(ZOLTAN_INT) :: ierr
-
- integer :: numGidEntries, i
- integer(ZOLTAN_INT), allocatable :: global_ids(:), permIndices(:),permGIDs(:)
- real(kind=RKIND), allocatable :: permXs(:),permYs(:),permZs(:)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !! Body of subroutine
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- numEdges = in_numedges
- edgeIDs => in_edgeIDs
- geomDim = in_geomDim
- edgeCoordX => in_edgeX
- edgeCoordY => in_edgeY
- edgeCoordZ => in_edgeZ
-
- nullify(zz_obj)
- zz_obj => Zoltan_Create(MPI_COMM_SELF)
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !! General Zoltan Parameters
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ierr = Zoltan_Set_Param(zz_obj, "ORDER_METHOD", "LOCAL_HSFC")
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !! register query functions
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ierr = Zoltan_Set_Fn(zz_obj, ZOLTAN_NUM_OBJ_FN_TYPE,zqfNumEdges)
- ierr = Zoltan_Set_Fn(zz_obj, ZOLTAN_OBJ_LIST_FN_TYPE,zqfGetEdges)
- ierr = Zoltan_Set_Fn(zz_obj, ZOLTAN_NUM_GEOM_FN_TYPE,zqfGeomDim)
- ierr = Zoltan_Set_Fn(zz_obj, ZOLTAN_GEOM_FN_TYPE, zqfGetEdgeGeom)
-
- numGidEntries=1
-
- allocate(global_ids(numEdges))
- allocate(permIndices(numEdges))
- allocate(permGIDs(numEdges))
- allocate(permXs(numEdges))
- allocate(permYs(numEdges))
- allocate(permZs(numEdges))
-
- !! MMW: There might be a way to use edgeIDs directly
- do i=1,numEdges
- global_ids(i) = edgeIDs(i)
- end do
-
- ierr = Zoltan_Order(zz_obj, numGidEntries, numEdges, global_ids, permIndices);
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!
- !! This is necessary for now until we fix a small bug in Zoltan_Order
- !!!!!!!!!!!!!!!!!!!!!!!!!!
- do i=1,numEdges
- permGIDs(i) = global_ids(permIndices(i)+1)
- permXs(i) = edgeCoordX(permIndices(i)+1)
- permYs(i) = edgeCoordY(permIndices(i)+1)
- permZs(i) = edgeCoordZ(permIndices(i)+1)
- end do
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!
- !! Actually change the ordering of the edges
- !!!!!!!!!!!!!!!!!!!!!!!!!!
- do i=1,numEdges
- edgeIDs(i) = permGIDs(i)
- edgeCoordX(i) = permXs(i)
- edgeCoordY(i) = permYs(i)
- edgeCoordZ(i) = permZs(i)
- end do
- !!!!!!!!!!!!!!!!!!!!!!!!!!
-
- deallocate(global_ids)
- deallocate(permIndices)
- deallocate(permGIDs)
- deallocate(permXs)
- deallocate(permYs)
- deallocate(permZs)
-
- call Zoltan_Destroy(zz_obj)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- end subroutine zoltanOrderLocHSFC_Edges
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !! zoltan query function:
- !! Returns number of edges
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- integer function zqfNumEdges(data, ierr)
- ! Local declarations
- integer(ZOLTAN_INT), intent(in) :: data(*)
- integer(ZOLTAN_INT), intent(out) :: ierr
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- zqfNumEdges = numEdges
- ierr = ZOLTAN_OK
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- end function zqfNumEdges
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !! zoltan query function:
- !! Returns lists of Edge IDs
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine zqfGetEdges (data, num_gid_entries, num_lid_entries, global_ids, &
- local_ids, wgt_dim, obj_wgts, ierr)
- integer(ZOLTAN_INT), intent(in) :: data(*)
- integer(ZOLTAN_INT), intent(in) :: num_gid_entries, num_lid_entries
- integer(ZOLTAN_INT), intent(out) :: global_ids(*), local_ids(*)
- integer(ZOLTAN_INT), intent(in) :: wgt_dim
- real(ZOLTAN_FLOAT), intent(out) :: obj_wgts(*)
- integer(ZOLTAN_INT), intent(out) :: ierr
-
- ! local declarations
- integer :: i
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- do i= 1, numEdges
- global_ids(i) = edgeIDs(i)
- local_ids(i) = i
- end do
-
- ierr = ZOLTAN_OK
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- end subroutine zqfGetEdges
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !! Zoltan Query Function:
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine zqfGetEdgeGeom(data, num_gid_entries, num_lid_entries, global_id, &
- local_id, geom_vec, ierr)
- !use zoltan
- implicit none
-
- integer(ZOLTAN_INT), intent(in) :: data(*)
- integer(ZOLTAN_INT), intent(in) :: num_gid_entries, num_lid_entries
- integer(ZOLTAN_INT), intent(in) :: global_id, local_id
- real(ZOLTAN_DOUBLE), intent(out) :: geom_vec(*)
- integer(ZOLTAN_INT), intent(out) :: ierr
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !! Assuming geom_dim is 3
- geom_vec(1) = edgeCoordX(local_id)
- geom_vec(2) = edgeCoordY(local_id)
- geom_vec(3) = edgeCoordZ(local_id)
-
- ierr = ZOLTAN_OK
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- end subroutine zqfGetEdgeGeom
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine zoltanOrderLocHSFC_Verts(in_numverts,in_vertIDs,in_geomDim,in_vertX, &
- in_vertY, in_vertZ)
- implicit none
-
- integer :: in_numverts
- integer, dimension(:), pointer :: in_vertIDs
- integer :: in_geomDim
- real (kind=RKIND), dimension(:), pointer :: in_vertX, in_vertY, in_vertZ
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !! local variables
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- type(Zoltan_Struct), pointer :: zz_obj
- integer(ZOLTAN_INT) :: ierr
-
- integer :: numGidEntries, i
- integer(ZOLTAN_INT), allocatable :: global_ids(:), permIndices(:),permGIDs(:)
- real(kind=RKIND), allocatable :: permXs(:),permYs(:),permZs(:)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !! Body of subroutine
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- numVerts = in_numverts
- vertIDs => in_vertIDs
- geomDim = in_geomDim
- vertCoordX => in_vertX
- vertCoordY => in_vertY
- vertCoordZ => in_vertZ
-
- nullify(zz_obj)
- zz_obj => Zoltan_Create(MPI_COMM_SELF)
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !! General Zoltan Parameters
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ierr = Zoltan_Set_Param(zz_obj, "ORDER_METHOD", "LOCAL_HSFC")
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !! register query functions
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ierr = Zoltan_Set_Fn(zz_obj, ZOLTAN_NUM_OBJ_FN_TYPE,zqfNumVerts)
- ierr = Zoltan_Set_Fn(zz_obj, ZOLTAN_OBJ_LIST_FN_TYPE,zqfGetVerts)
- ierr = Zoltan_Set_Fn(zz_obj, ZOLTAN_NUM_GEOM_FN_TYPE,zqfGeomDim)
- ierr = Zoltan_Set_Fn(zz_obj, ZOLTAN_GEOM_FN_TYPE, zqfGetVertGeom)
-
- numGidEntries=1
-
- allocate(global_ids(numVerts))
- allocate(permIndices(numVerts))
- allocate(permGIDs(numVerts))
- allocate(permXs(numVerts))
- allocate(permYs(numVerts))
- allocate(permZs(numVerts))
-
- !! MMW: There might be a way to use vertIDs directly
- do i=1,numVerts
- global_ids(i) = vertIDs(i)
- end do
-
- ierr = Zoltan_Order(zz_obj, numGidEntries, numVerts, global_ids, permIndices);
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!
- !! This is necessary for now until we fix a small bug in Zoltan_Order
- !!!!!!!!!!!!!!!!!!!!!!!!!!
- do i=1,numVerts
- permGIDs(i) = global_ids(permIndices(i)+1)
- permXs(i) = vertCoordX(permIndices(i)+1)
- permYs(i) = vertCoordY(permIndices(i)+1)
- permZs(i) = vertCoordZ(permIndices(i)+1)
- end do
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!
- !! Actually change the ordering of the verts
- !!!!!!!!!!!!!!!!!!!!!!!!!!
- do i=1,numVerts
- vertIDs(i) = permGIDs(i)
- vertCoordX(i) = permXs(i)
- vertCoordY(i) = permYs(i)
- vertCoordZ(i) = permZs(i)
- end do
- !!!!!!!!!!!!!!!!!!!!!!!!!!
-
- deallocate(global_ids)
- deallocate(permIndices)
- deallocate(permGIDs)
- deallocate(permXs)
- deallocate(permYs)
- deallocate(permZs)
-
- call Zoltan_Destroy(zz_obj)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- end subroutine zoltanOrderLocHSFC_Verts
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !! zoltan query function:
- !! Returns number of verts
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- integer function zqfNumVerts(data, ierr)
-
- ! Local declarations
- integer(ZOLTAN_INT), intent(in) :: data(*)
- integer(ZOLTAN_INT), intent(out) :: ierr
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- zqfNumVerts = numVerts
- ierr = ZOLTAN_OK
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- end function zqfNumVerts
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !! zoltan query function:
- !! Returns lists of Vert IDs
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine zqfGetVerts (data, num_gid_entries, num_lid_entries, global_ids, &
- local_ids, wgt_dim, obj_wgts, ierr)
-
- integer(ZOLTAN_INT), intent(in) :: data(*)
- integer(ZOLTAN_INT), intent(in) :: num_gid_entries, num_lid_entries
- integer(ZOLTAN_INT), intent(out) :: global_ids(*), local_ids(*)
- integer(ZOLTAN_INT), intent(in) :: wgt_dim
- real(ZOLTAN_FLOAT), intent(out) :: obj_wgts(*)
- integer(ZOLTAN_INT), intent(out) :: ierr
-
- ! local declarations
- integer :: i
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- do i= 1, numVerts
- global_ids(i) = vertIDs(i)
- local_ids(i) = i
- end do
-
- ierr = ZOLTAN_OK
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- end subroutine zqfGetVerts
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !! Zoltan Query Function:
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine zqfGetVertGeom(data, num_gid_entries, num_lid_entries, global_id, &
- local_id, geom_vec, ierr)
- !use zoltan
- implicit none
-
- integer(ZOLTAN_INT), intent(in) :: data(*)
- integer(ZOLTAN_INT), intent(in) :: num_gid_entries, num_lid_entries
- integer(ZOLTAN_INT), intent(in) :: global_id, local_id
- real(ZOLTAN_DOUBLE), intent(out) :: geom_vec(*)
- integer(ZOLTAN_INT), intent(out) :: ierr
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !! Assuming geom_dim is 3
- geom_vec(1) = vertCoordX(local_id)
- geom_vec(2) = vertCoordY(local_id)
- geom_vec(3) = vertCoordZ(local_id)
-
- ierr = ZOLTAN_OK
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- end subroutine zqfGetVertGeom
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-
-
-
-end module zoltan_interface
Copied: trunk/mpas/src/framework/mpas_block_decomp.F (from rev 1113, branches/source_renaming/src/framework/mpas_block_decomp.F)
===================================================================
--- trunk/mpas/src/framework/mpas_block_decomp.F (rev 0)
+++ trunk/mpas/src/framework/mpas_block_decomp.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -0,0 +1,306 @@
+module mpas_block_decomp
+
+ use mpas_dmpar
+ use mpas_hash
+
+ type graph
+ integer :: nVerticesTotal
+ integer :: nVertices, maxDegree
+ integer :: ghostStart
+ integer, dimension(:), pointer :: vertexID
+ integer, dimension(:), pointer :: nAdjacent
+ integer, dimension(:,:), pointer :: adjacencyList
+ end type graph
+
+
+ contains
+
+
+ subroutine mpas_block_decomp_cells_for_proc(dminfo, partial_global_graph_info, local_cell_list)
+
+ use mpas_configure
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ type (graph), intent(in) :: partial_global_graph_info
+ integer, dimension(:), pointer :: local_cell_list
+
+ integer, dimension(:), pointer :: global_cell_list
+ integer, dimension(:), pointer :: global_start
+
+ integer :: i, j, owner, iunit, istatus
+ integer, dimension(:), pointer :: local_nvertices
+ character (len=256) :: filename
+
+ if (dminfo % nprocs > 1) then
+
+ allocate(local_nvertices(dminfo % nprocs))
+ allocate(global_start(dminfo % nprocs))
+ allocate(global_cell_list(partial_global_graph_info % nVerticesTotal))
+
+ if (dminfo % my_proc_id == IO_NODE) then
+
+ iunit = 50 + dminfo % my_proc_id
+ if (dminfo % nprocs < 10) then
+ write(filename,'(a,i1)') trim(config_decomp_file_prefix), dminfo % nprocs
+ else if (dminfo % nprocs < 100) then
+ write(filename,'(a,i2)') trim(config_decomp_file_prefix), dminfo % nprocs
+ else if (dminfo % nprocs < 1000) then
+ write(filename,'(a,i3)') trim(config_decomp_file_prefix), dminfo % nprocs
+ else if (dminfo % nprocs < 10000) then
+ write(filename,'(a,i4)') trim(config_decomp_file_prefix), dminfo % nprocs
+ else if (dminfo % nprocs < 100000) then
+ write(filename,'(a,i5)') trim(config_decomp_file_prefix), dminfo % nprocs
+ end if
+
+ open(unit=iunit, file=trim(filename), form='formatted', status='old', iostat=istatus)
+
+ if (istatus /= 0) then
+ write(0,*) 'Could not open block decomposition file for ',dminfo % nprocs,' tasks.'
+ write(0,*) 'Filename: ',trim(filename)
+ call mpas_dmpar_abort(dminfo)
+ end if
+
+ local_nvertices(:) = 0
+ do i=1,partial_global_graph_info % nVerticesTotal
+ read(unit=iunit, fmt=*) owner
+ local_nvertices(owner+1) = local_nvertices(owner+1) + 1
+ end do
+
+! allocate(global_cell_list(partial_global_graph_info % nVerticesTotal))
+
+ global_start(1) = 1
+ do i=2,dminfo % nprocs
+ global_start(i) = global_start(i-1) + local_nvertices(i-1)
+ end do
+
+ rewind(unit=iunit)
+
+ do i=1,partial_global_graph_info % nVerticesTotal
+ read(unit=iunit, fmt=*) owner
+ global_cell_list(global_start(owner+1)) = i
+ global_start(owner+1) = global_start(owner+1) + 1
+ end do
+
+ global_start(1) = 0
+ do i=2,dminfo % nprocs
+ global_start(i) = global_start(i-1) + local_nvertices(i-1)
+ end do
+
+ close(unit=iunit)
+
+ call mpas_dmpar_bcast_ints(dminfo, dminfo % nprocs, local_nvertices)
+ allocate(local_cell_list(local_nvertices(dminfo % my_proc_id + 1)))
+
+ call mpas_dmpar_scatter_ints(dminfo, dminfo % nprocs, local_nvertices(dminfo % my_proc_id + 1), &
+ global_start, local_nvertices, global_cell_list, local_cell_list)
+
+ else
+
+ call mpas_dmpar_bcast_ints(dminfo, dminfo % nprocs, local_nvertices)
+ allocate(local_cell_list(local_nvertices(dminfo % my_proc_id + 1)))
+
+ call mpas_dmpar_scatter_ints(dminfo, dminfo % nprocs, local_nvertices(dminfo % my_proc_id + 1), &
+ global_start, local_nvertices, global_cell_list, local_cell_list)
+
+ end if
+
+ deallocate(local_nvertices)
+ deallocate(global_start)
+ deallocate(global_cell_list)
+ else
+ allocate(local_cell_list(partial_global_graph_info % nVerticesTotal))
+ do i=1,size(local_cell_list)
+ local_cell_list(i) = i
+ end do
+ endif
+
+ end subroutine mpas_block_decomp_cells_for_proc
+
+
+ subroutine mpas_block_decomp_partitioned_edge_list(nCells, cellIDList, maxCells, nEdges, cellsOnEdge, edgeIDList, ghostEdgeStart)
+
+ implicit none
+
+ integer, intent(in) :: nCells, maxCells, nEdges
+ integer, dimension(nCells), intent(in) :: cellIDList
+ integer, dimension(maxCells, nEdges), intent(in) :: cellsOnEdge
+ integer, dimension(nEdges), intent(inout) :: edgeIDList
+ integer, intent(inout) :: ghostEdgeStart
+
+ integer :: i, j, lastEdge
+ integer, dimension(nEdges) :: edgeIDListLocal
+ type (hashtable) :: h
+
+ call mpas_hash_init(h)
+
+ do i=1,nCells
+ ! OPTIMIZATION: Actually, if we can assume that all cellIDs are unique, the if-test is unnecessary
+ if (.not. mpas_hash_search(h, cellIDList(i))) call mpas_hash_insert(h, cellIDList(i))
+ end do
+
+ lastEdge = 0
+ ghostEdgeStart = nEdges+1
+
+ edgeIDListLocal(:) = edgeIDList(:)
+
+ do i=1,nEdges
+ do j=1,maxCells
+ if (cellsOnEdge(j,i) /= 0) exit
+ end do
+ if (j > maxCells) &
+ write(0,*) 'Error in block_decomp_partitioned_edge_list: ',&
+ 'edge/vertex is not adjacent to any valid cells'
+ if (mpas_hash_search(h, cellsOnEdge(j,i))) then
+ lastEdge = lastEdge + 1
+ edgeIDList(lastEdge) = edgeIDListLocal(i)
+ else
+ ghostEdgeStart = ghostEdgeStart - 1
+ edgeIDList(ghostEdgeStart) = edgeIDListLocal(i)
+ end if
+ if (ghostEdgeStart <= lastEdge) then
+ write(0,*) 'block_decomp_partitioned_edge_list: ',&
+ 'Somehow we have more edges than we thought we should.'
+ end if
+ end do
+
+ if (ghostEdgeStart /= lastEdge + 1) then
+ write(0,*) 'block_decomp_partitioned_edge_list:',&
+ ' Somehow we didn''t have enough edges to fill edgeIDList.'
+ end if
+
+ call mpas_hash_destroy(h)
+
+ end subroutine mpas_block_decomp_partitioned_edge_list
+
+
+ subroutine mpas_block_decomp_all_edges_in_block(maxEdges, nCells, nEdgesOnCell, edgesOnCell, nEdges, edgeList)
+
+ implicit none
+
+ integer, intent(in) :: maxEdges, nCells
+ integer, dimension(nCells), intent(in) :: nEdgesOnCell
+ integer, dimension(maxEdges, nCells), intent(in) :: edgesOnCell
+ integer, intent(out) :: nEdges
+ integer, dimension(:), pointer :: edgeList
+
+ integer :: i, j, k
+ type (hashtable) :: h
+
+ call mpas_hash_init(h)
+
+ do i=1,nCells
+ do j=1,nEdgesOnCell(i)
+ if (.not. mpas_hash_search(h, edgesOnCell(j,i))) call mpas_hash_insert(h, edgesOnCell(j,i))
+ end do
+ end do
+
+ nEdges = mpas_hash_size(h)
+ allocate(edgeList(nEdges))
+
+ call mpas_hash_destroy(h)
+
+ call mpas_hash_init(h)
+
+ k = 0
+ do i=1,nCells
+ do j=1,nEdgesOnCell(i)
+ if (.not. mpas_hash_search(h, edgesOnCell(j,i))) then
+ k = k + 1
+ if (k > nEdges) then
+ write(0,*) 'block_decomp_all_edges_in_block: ',&
+ 'Trying to add more edges than expected.'
+ return
+ end if
+ edgeList(k) = edgesOnCell(j,i)
+ call mpas_hash_insert(h, edgesOnCell(j,i))
+ end if
+ end do
+ end do
+
+ call mpas_hash_destroy(h)
+
+ if (k < nEdges) then
+ write(0,*) 'block_decomp_all_edges_in_block: ',&
+ 'Listed fewer edges than expected.'
+ end if
+
+ end subroutine mpas_block_decomp_all_edges_in_block
+
+
+ subroutine mpas_block_decomp_add_halo(dminfo, local_graph_info, local_graph_with_halo)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ type (graph), intent(in) :: local_graph_info
+ type (graph), intent(out) :: local_graph_with_halo
+
+ integer :: i, j, k
+ type (hashtable) :: h
+
+
+ call mpas_hash_init(h)
+
+ do i=1,local_graph_info % nVertices
+ call mpas_hash_insert(h, local_graph_info % vertexID(i))
+ end do
+
+ do i=1,local_graph_info % nVertices
+ do j=1,local_graph_info % nAdjacent(i)
+ if (local_graph_info % adjacencyList(j,i) /= 0) then
+ if (.not. mpas_hash_search(h, local_graph_info % adjacencyList(j,i))) then
+ call mpas_hash_insert(h, local_graph_info % adjacencyList(j,i))
+ end if
+ end if
+ end do
+ end do
+
+
+ local_graph_with_halo % nVertices = local_graph_info % nVertices
+ local_graph_with_halo % maxDegree = local_graph_info % maxDegree
+ local_graph_with_halo % nVerticesTotal = mpas_hash_size(h)
+ local_graph_with_halo % ghostStart = local_graph_with_halo % nVertices + 1
+ allocate(local_graph_with_halo % vertexID(local_graph_with_halo % nVerticesTotal))
+ allocate(local_graph_with_halo % nAdjacent(local_graph_with_halo % nVerticesTotal))
+ allocate(local_graph_with_halo % adjacencyList(local_graph_with_halo % maxDegree, local_graph_with_halo % nVerticesTotal))
+
+ call mpas_hash_destroy(h)
+
+ call mpas_hash_init(h)
+
+ do i=1,local_graph_info % nVertices
+ if (mpas_hash_search(h, local_graph_info % vertexID(i))) &
+ write(0,*) 'block_decomp_add_halo: ', &
+ 'There appear to be duplicates in vertexID list.'
+ call mpas_hash_insert(h, local_graph_info % vertexID(i))
+ local_graph_with_halo % vertexID(i) = local_graph_info % vertexID(i)
+ local_graph_with_halo % nAdjacent(i) = local_graph_info % nAdjacent(i)
+ local_graph_with_halo % adjacencyList(:,i) = local_graph_info % adjacencyList(:,i)
+ end do
+
+ k = local_graph_with_halo % ghostStart
+ if (mpas_hash_size(h) /= k-1) &
+ write(0,*) 'block_decomp_add_halo: ',&
+ 'Somehow we don''t have the right number of non-ghost cells.'
+ do i=1,local_graph_info % nVertices
+ do j=1,local_graph_info % nAdjacent(i)
+ if (local_graph_info % adjacencyList(j,i) /= 0) then
+ if (.not. mpas_hash_search(h, local_graph_info % adjacencyList(j,i))) then
+ call mpas_hash_insert(h, local_graph_info % adjacencyList(j,i))
+ local_graph_with_halo % vertexID(k) = local_graph_info % adjacencyList(j,i)
+ k = k + 1
+ end if
+ end if
+ end do
+ end do
+ if (local_graph_with_halo % nVerticesTotal /= k-1) &
+ write(0,*) 'block_decomp_add_halo: ',&
+ 'Somehow we don''t have the right number of total cells.'
+
+ call mpas_hash_destroy(h)
+
+ end subroutine mpas_block_decomp_add_halo
+
+end module mpas_block_decomp
Copied: trunk/mpas/src/framework/mpas_configure.F (from rev 1113, branches/source_renaming/src/framework/mpas_configure.F)
===================================================================
--- trunk/mpas/src/framework/mpas_configure.F (rev 0)
+++ trunk/mpas/src/framework/mpas_configure.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -0,0 +1,36 @@
+module mpas_configure
+
+ use mpas_dmpar
+
+#include "config_defs.inc"
+
+ contains
+
+
+ subroutine mpas_read_namelist(dminfo)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+
+ integer :: funit
+
+#include "config_namelist_defs.inc"
+
+ funit = 21
+
+ ! Set default values for namelist options
+#include "config_set_defaults.inc"
+
+ if (dminfo % my_proc_id == IO_NODE) then
+ open(funit,file='namelist.input',status='old',form='formatted')
+
+#include "config_namelist_reads.inc"
+ close(funit)
+ end if
+
+#include "config_bcast_namelist.inc"
+
+ end subroutine mpas_read_namelist
+
+end module mpas_configure
Copied: trunk/mpas/src/framework/mpas_constants.F (from rev 1113, branches/source_renaming/src/framework/mpas_constants.F)
===================================================================
--- trunk/mpas/src/framework/mpas_constants.F (rev 0)
+++ trunk/mpas/src/framework/mpas_constants.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -0,0 +1,20 @@
+module mpas_constants
+
+ real (kind=RKIND), parameter :: pii = 3.141592653589793
+ real (kind=RKIND), parameter :: a = 6371229.0
+ real (kind=RKIND), parameter :: omega = 7.29212e-5
+ real (kind=RKIND), parameter :: gravity = 9.80616
+ real (kind=RKIND), parameter :: rgas = 287.
+ real (kind=RKIND), parameter :: cp = 1003.
+ real (kind=RKIND), parameter :: cv = 716. ! cp - rgas
+ real (kind=RKIND), parameter :: cvpm = -.71385842 ! -cv/cp
+ real (kind=RKIND), parameter :: prandtl = 1.0
+
+
+ contains
+
+ subroutine dummy()
+
+ end subroutine dummy
+
+end module mpas_constants
Copied: trunk/mpas/src/framework/mpas_dmpar.F (from rev 1113, branches/source_renaming/src/framework/mpas_dmpar.F)
===================================================================
--- trunk/mpas/src/framework/mpas_dmpar.F (rev 0)
+++ trunk/mpas/src/framework/mpas_dmpar.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -0,0 +1,1928 @@
+module mpas_dmpar
+
+ use mpas_sort
+
+#ifdef _MPI
+include 'mpif.h'
+ integer, parameter :: MPI_INTEGERKIND = MPI_INTEGER
+
+#if (RKIND == 8)
+ integer, parameter :: MPI_REALKIND = MPI_DOUBLE_PRECISION
+#else
+ integer, parameter :: MPI_REALKIND = MPI_REAL
+#endif
+#endif
+
+ integer, parameter :: IO_NODE = 0
+ integer, parameter :: BUFSIZE = 6000
+
+
+ type dm_info
+ integer :: nprocs, my_proc_id, comm, info
+ end type dm_info
+
+
+ type exchange_list
+ integer :: procID
+ integer :: nlist
+ integer, dimension(:), pointer :: list
+ type (exchange_list), pointer :: next
+ real (kind=RKIND), dimension(:), pointer :: rbuffer
+ integer, dimension(:), pointer :: ibuffer
+ integer :: reqID
+ end type exchange_list
+
+
+ interface mpas_dmpar_alltoall_field
+ module procedure mpas_dmpar_alltoall_field1d_integer
+ module procedure mpas_dmpar_alltoall_field2d_integer
+ module procedure mpas_dmpar_alltoall_field1d_real
+ module procedure mpas_dmpar_alltoall_field2d_real
+ module procedure mpas_dmpar_alltoall_field3d_real
+ end interface
+
+
+ contains
+
+
+ subroutine mpas_dmpar_init(dminfo)
+
+ implicit none
+
+ type (dm_info), intent(inout) :: dminfo
+
+#ifdef _MPI
+ integer :: mpi_rank, mpi_size
+ integer :: mpi_ierr
+
+ ! Find out our rank and the total number of processors
+ call MPI_Init(mpi_ierr)
+ call MPI_Comm_rank(MPI_COMM_WORLD, mpi_rank, mpi_ierr)
+ call MPI_Comm_size(MPI_COMM_WORLD, mpi_size, mpi_ierr)
+
+ dminfo % comm = MPI_COMM_WORLD
+
+ dminfo % nprocs = mpi_size
+ dminfo % my_proc_id = mpi_rank
+
+ write(0,'(a,i5,a,i5,a)') 'task ', mpi_rank, ' of ', mpi_size, &
+ ' is running'
+
+ call open_streams(dminfo % my_proc_id)
+
+ dminfo % info = MPI_INFO_NULL
+#else
+ dminfo % comm = 0
+ dminfo % my_proc_id = IO_NODE
+ dminfo % nprocs = 1
+#endif
+
+ end subroutine mpas_dmpar_init
+
+
+ subroutine mpas_dmpar_finalize(dminfo)
+
+ implicit none
+
+ type (dm_info), intent(inout) :: dminfo
+
+#ifdef _MPI
+ integer :: mpi_ierr
+
+ call MPI_Finalize(mpi_ierr)
+#endif
+
+ end subroutine mpas_dmpar_finalize
+
+
+ subroutine mpas_dmpar_abort(dminfo)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+
+#ifdef _MPI
+ integer :: mpi_ierr, mpi_errcode
+
+ call MPI_Abort(dminfo % comm, mpi_errcode, mpi_ierr)
+#endif
+
+ stop
+
+ end subroutine mpas_dmpar_abort
+
+
+ subroutine mpas_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 mpas_dmpar_global_abort
+
+
+ subroutine mpas_dmpar_bcast_int(dminfo, i)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(inout) :: i
+
+#ifdef _MPI
+ integer :: mpi_ierr
+
+ call MPI_Bcast(i, 1, MPI_INTEGERKIND, IO_NODE, dminfo % comm, mpi_ierr)
+#endif
+
+ end subroutine mpas_dmpar_bcast_int
+
+
+ subroutine mpas_dmpar_bcast_ints(dminfo, n, iarray)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: n
+ integer, dimension(n), intent(inout) :: iarray
+
+#ifdef _MPI
+ integer :: mpi_ierr
+
+ call MPI_Bcast(iarray, n, MPI_INTEGERKIND, IO_NODE, dminfo % comm, mpi_ierr)
+#endif
+
+ end subroutine mpas_dmpar_bcast_ints
+
+
+ subroutine mpas_dmpar_bcast_real(dminfo, r)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ real (kind=RKIND), intent(inout) :: r
+
+#ifdef _MPI
+ integer :: mpi_ierr
+
+ call MPI_Bcast(r, 1, MPI_REALKIND, IO_NODE, dminfo % comm, mpi_ierr)
+#endif
+
+ end subroutine mpas_dmpar_bcast_real
+
+
+ subroutine mpas_dmpar_bcast_reals(dminfo, n, rarray)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: n
+ real (kind=RKIND), dimension(n), intent(inout) :: rarray
+
+#ifdef _MPI
+ integer :: mpi_ierr
+
+ call MPI_Bcast(rarray, n, MPI_REALKIND, IO_NODE, dminfo % comm, mpi_ierr)
+#endif
+
+ end subroutine mpas_dmpar_bcast_reals
+
+
+ subroutine mpas_dmpar_bcast_logical(dminfo, l)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ logical, intent(inout) :: l
+
+#ifdef _MPI
+ integer :: mpi_ierr
+ integer :: itemp
+
+ if (dminfo % my_proc_id == IO_NODE) then
+ if (l) then
+ itemp = 1
+ else
+ itemp = 0
+ end if
+ end if
+
+ call MPI_Bcast(itemp, 1, MPI_INTEGERKIND, IO_NODE, dminfo % comm, mpi_ierr)
+
+ if (itemp == 1) then
+ l = .true.
+ else
+ l = .false.
+ end if
+#endif
+
+ end subroutine mpas_dmpar_bcast_logical
+
+
+ subroutine mpas_dmpar_bcast_char(dminfo, c)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ character (len=*), intent(inout) :: c
+
+#ifdef _MPI
+ integer :: mpi_ierr
+
+ call MPI_Bcast(c, len(c), MPI_CHARACTER, IO_NODE, dminfo % comm, mpi_ierr)
+#endif
+
+ end subroutine mpas_dmpar_bcast_char
+
+
+ subroutine mpas_dmpar_sum_int(dminfo, i, isum)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: i
+ integer, intent(out) :: isum
+
+ integer :: mpi_ierr
+
+#ifdef _MPI
+ call MPI_Allreduce(i, isum, 1, MPI_INTEGERKIND, MPI_SUM, dminfo % comm, mpi_ierr)
+#else
+ isum = i
+#endif
+
+ end subroutine mpas_dmpar_sum_int
+
+
+ subroutine mpas_dmpar_sum_real(dminfo, r, rsum)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ real(kind=RKIND), intent(in) :: r
+ real(kind=RKIND), intent(out) :: rsum
+
+ integer :: mpi_ierr
+
+#ifdef _MPI
+ call MPI_Allreduce(r, rsum, 1, MPI_REALKIND, MPI_SUM, dminfo % comm, mpi_ierr)
+#else
+ rsum = r
+#endif
+
+ end subroutine mpas_dmpar_sum_real
+
+
+ subroutine mpas_dmpar_min_int(dminfo, i, imin)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: i
+ integer, intent(out) :: imin
+
+ integer :: mpi_ierr
+
+#ifdef _MPI
+ call MPI_Allreduce(i, imin, 1, MPI_INTEGERKIND, MPI_MIN, dminfo % comm, mpi_ierr)
+#else
+ imin = i
+#endif
+
+ end subroutine mpas_dmpar_min_int
+
+
+ subroutine mpas_dmpar_min_real(dminfo, r, rmin)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ real(kind=RKIND), intent(in) :: r
+ real(kind=RKIND), intent(out) :: rmin
+
+ integer :: mpi_ierr
+
+#ifdef _MPI
+ call MPI_Allreduce(r, rmin, 1, MPI_REALKIND, MPI_MIN, dminfo % comm, mpi_ierr)
+#else
+ rmin = r
+#endif
+
+ end subroutine mpas_dmpar_min_real
+
+
+ subroutine mpas_dmpar_max_int(dminfo, i, imax)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: i
+ integer, intent(out) :: imax
+
+ integer :: mpi_ierr
+
+#ifdef _MPI
+ call MPI_Allreduce(i, imax, 1, MPI_INTEGERKIND, MPI_MAX, dminfo % comm, mpi_ierr)
+#else
+ imax = i
+#endif
+
+ end subroutine mpas_dmpar_max_int
+
+
+ subroutine mpas_dmpar_max_real(dminfo, r, rmax)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ real(kind=RKIND), intent(in) :: r
+ real(kind=RKIND), intent(out) :: rmax
+
+ integer :: mpi_ierr
+
+#ifdef _MPI
+ call MPI_Allreduce(r, rmax, 1, MPI_REALKIND, MPI_MAX, dminfo % comm, mpi_ierr)
+#else
+ rmax = r
+#endif
+
+ end subroutine mpas_dmpar_max_real
+
+
+ subroutine mpas_dmpar_sum_int_array(dminfo, nElements, inArray, outArray)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: nElements
+ integer, dimension(nElements), intent(in) :: inArray
+ integer, dimension(nElements), intent(out) :: outArray
+
+ integer :: mpi_ierr
+
+#ifdef _MPI
+ call MPI_Allreduce(inArray, outArray, nElements, MPI_INTEGERKIND, MPI_SUM, dminfo % comm, mpi_ierr)
+#else
+ outArray = inArray
+#endif
+
+ end subroutine mpas_dmpar_sum_int_array
+
+
+ subroutine mpas_dmpar_min_int_array(dminfo, nElements, inArray, outArray)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: nElements
+ integer, dimension(nElements), intent(in) :: inArray
+ integer, dimension(nElements), intent(out) :: outArray
+
+ integer :: mpi_ierr
+
+#ifdef _MPI
+ call MPI_Allreduce(inArray, outArray, nElements, MPI_INTEGERKIND, MPI_MIN, dminfo % comm, mpi_ierr)
+#else
+ outArray = inArray
+#endif
+
+ end subroutine mpas_dmpar_min_int_array
+
+
+ subroutine mpas_dmpar_max_int_array(dminfo, nElements, inArray, outArray)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: nElements
+ integer, dimension(nElements), intent(in) :: inArray
+ integer, dimension(nElements), intent(out) :: outArray
+
+ integer :: mpi_ierr
+
+#ifdef _MPI
+ call MPI_Allreduce(inArray, outArray, nElements, MPI_INTEGERKIND, MPI_MAX, dminfo % comm, mpi_ierr)
+#else
+ outArray = inArray
+#endif
+
+ end subroutine mpas_dmpar_max_int_array
+
+
+ subroutine mpas_dmpar_sum_real_array(dminfo, nElements, inArray, outArray)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: nElements
+ real(kind=RKIND), dimension(nElements), intent(in) :: inArray
+ real(kind=RKIND), dimension(nElements), intent(out) :: outArray
+
+ integer :: mpi_ierr
+
+#ifdef _MPI
+ call MPI_Allreduce(inArray, outArray, nElements, MPI_REALKIND, MPI_SUM, dminfo % comm, mpi_ierr)
+#else
+ outArray = inArray
+#endif
+
+ end subroutine mpas_dmpar_sum_real_array
+
+
+ subroutine mpas_dmpar_min_real_array(dminfo, nElements, inArray, outArray)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: nElements
+ real(kind=RKIND), dimension(nElements), intent(in) :: inArray
+ real(kind=RKIND), dimension(nElements), intent(out) :: outArray
+
+ integer :: mpi_ierr
+
+#ifdef _MPI
+ call MPI_Allreduce(inArray, outArray, nElements, MPI_REALKIND, MPI_MIN, dminfo % comm, mpi_ierr)
+#else
+ outArray = inArray
+#endif
+
+ end subroutine mpas_dmpar_min_real_array
+
+
+ subroutine mpas_dmpar_max_real_array(dminfo, nElements, inArray, outArray)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: nElements
+ real(kind=RKIND), dimension(nElements), intent(in) :: inArray
+ real(kind=RKIND), dimension(nElements), intent(out) :: outArray
+
+ integer :: mpi_ierr
+
+#ifdef _MPI
+ call MPI_Allreduce(inArray, outArray, nElements, MPI_REALKIND, MPI_MAX, dminfo % comm, mpi_ierr)
+#else
+ outArray = inArray
+#endif
+
+ end subroutine mpas_dmpar_max_real_array
+
+
+ subroutine mpas_dmpar_scatter_ints(dminfo, nprocs, noutlist, displs, counts, inlist, outlist)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: nprocs, noutlist
+ integer, dimension(nprocs), intent(in) :: displs, counts
+ integer, dimension(:), pointer :: inlist
+ integer, dimension(noutlist), intent(inout) :: outlist
+
+#ifdef _MPI
+ integer :: mpi_ierr
+
+ call MPI_Scatterv(inlist, counts, displs, MPI_INTEGERKIND, outlist, noutlist, MPI_INTEGERKIND, IO_NODE, dminfo % comm, mpi_ierr)
+#endif
+
+ end subroutine mpas_dmpar_scatter_ints
+
+
+ subroutine mpas_dmpar_get_index_range(dminfo, &
+ global_start, global_end, &
+ local_start, local_end)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: global_start, global_end
+ integer, intent(out) :: local_start, local_end
+
+ local_start = nint(real(dminfo % my_proc_id) * real(global_end - global_start + 1) / real(dminfo % nprocs)) + 1
+ local_end = nint(real(dminfo % my_proc_id + 1) * real(global_end - global_start + 1) / real(dminfo % nprocs))
+
+ end subroutine mpas_dmpar_get_index_range
+
+
+ subroutine mpas_dmpar_compute_index_range(dminfo, &
+ local_start, local_end, &
+ global_start, global_end)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: local_start, local_end
+ integer, intent(inout) :: global_start, global_end
+
+ integer :: n
+ integer :: mpi_ierr
+
+ n = local_end - local_start + 1
+
+ if (dminfo % my_proc_id == 0) then
+ global_start = 1
+ global_end = global_start + n - 1
+
+#ifdef _MPI
+ else if (dminfo % my_proc_id == dminfo % nprocs - 1) then
+ call MPI_Recv(global_start, 1, MPI_INTEGERKIND, dminfo % my_proc_id - 1, 0, dminfo % comm, MPI_STATUS_IGNORE, mpi_ierr)
+ global_end = global_start + n - 1
+
+ else
+ call MPI_Recv(global_start, 1, MPI_INTEGERKIND, dminfo % my_proc_id - 1, 0, dminfo % comm, MPI_STATUS_IGNORE, mpi_ierr)
+ global_end = global_start + n
+ call MPI_Send(global_end, 1, MPI_INTEGERKIND, dminfo % my_proc_id + 1, 0, dminfo % comm, mpi_ierr)
+ global_end = global_end - 1
+#endif
+
+ end if
+
+
+ end subroutine mpas_dmpar_compute_index_range
+
+
+ subroutine mpas_dmpar_get_owner_list(dminfo, &
+ nOwnedList, nNeededList, &
+ ownedList, neededList, &
+ sendList, recvList)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: nOwnedList, nNeededList
+ integer, dimension(nOwnedList), intent(in) :: ownedList
+ integer, dimension(nNeededList), intent(in) :: neededList
+ type (exchange_list), pointer :: sendList
+ type (exchange_list), pointer :: recvList
+
+ integer :: i, j, k, kk
+ integer :: totalSize, nMesgRecv, nMesgSend, recvNeighbor, sendNeighbor, currentProc
+ integer :: numToSend, numToRecv
+ integer, dimension(nOwnedList) :: recipientList
+ integer, dimension(2,nOwnedList) :: ownedListSorted
+ integer, allocatable, dimension(:) :: ownerListIn, ownerListOut
+ type (exchange_list), pointer :: sendListPtr, recvListPtr
+ integer :: mpi_ierr, mpi_rreq, mpi_sreq
+
+#ifdef _MPI
+ allocate(sendList)
+ allocate(recvList)
+ nullify(sendList % next)
+ nullify(recvList % next)
+ sendListPtr => sendList
+ recvListPtr => recvList
+
+ do i=1,nOwnedList
+ ownedListSorted(1,i) = ownedList(i)
+ ownedListSorted(2,i) = i
+ end do
+ call quicksort(nOwnedList, ownedListSorted)
+
+ call MPI_Allreduce(nNeededList, totalSize, 1, MPI_INTEGERKIND, MPI_MAX, dminfo % comm, mpi_ierr)
+
+ allocate(ownerListIn(totalSize))
+ allocate(ownerListOut(totalSize))
+
+ nMesgRecv = nNeededList
+ ownerListIn(1:nNeededList) = neededList(1:nNeededList)
+
+ recvNeighbor = mod(dminfo % my_proc_id + dminfo % nprocs - 1, dminfo % nprocs)
+ sendNeighbor = mod(dminfo % my_proc_id + 1, dminfo % nprocs)
+
+ do i=1, dminfo % nprocs
+
+ recipientList(:) = -1
+ numToSend = 0
+
+ currentProc = mod(dminfo % my_proc_id + dminfo % nprocs - i + 1, dminfo % nprocs)
+ do j=1,nMesgRecv
+ if (ownerListIn(j) > 0) then
+ k = mpas_binary_search(ownedListSorted, 2, 1, nOwnedList, ownerListIn(j))
+ if (k <= nOwnedList) then
+ ownerListOut(j) = -1 * dminfo % my_proc_id
+ numToSend = numToSend + 1
+ recipientList(ownedListSorted(2,k)) = numToSend
+ else
+ ownerListOut(j) = ownerListIn(j)
+ end if
+ else
+ ownerListOut(j) = ownerListIn(j)
+ end if
+ end do
+
+ if (numToSend > 0) then
+ allocate(sendListPtr % next)
+ sendListPtr => sendListPtr % next
+ sendListPtr % procID = currentProc
+ sendListPtr % nlist = numToSend
+ allocate(sendListPtr % list(numToSend))
+ nullify(sendListPtr % next)
+ kk = 1
+ do j=1,nOwnedList
+ if (recipientList(j) /= -1) then
+ sendListPtr % list(recipientList(j)) = j
+ kk = kk + 1
+ end if
+ end do
+ end if
+
+ nMesgSend = nMesgRecv
+ call MPI_Irecv(nMesgRecv, 1, MPI_INTEGERKIND, recvNeighbor, i, dminfo % comm, mpi_rreq, mpi_ierr)
+ call MPI_Isend(nMesgSend, 1, MPI_INTEGERKIND, sendNeighbor, i, dminfo % comm, mpi_sreq, mpi_ierr)
+ call MPI_Wait(mpi_rreq, MPI_STATUS_IGNORE, mpi_ierr)
+ call MPI_Wait(mpi_sreq, MPI_STATUS_IGNORE, mpi_ierr)
+ call MPI_Irecv(ownerListIn, nMesgRecv, MPI_INTEGERKIND, recvNeighbor, i, dminfo % comm, mpi_rreq, mpi_ierr)
+ call MPI_Isend(ownerListOut, nMesgSend, MPI_INTEGERKIND, sendNeighbor, i, dminfo % comm, mpi_sreq, mpi_ierr)
+ call MPI_Wait(mpi_rreq, MPI_STATUS_IGNORE, mpi_ierr)
+ call MPI_Wait(mpi_sreq, MPI_STATUS_IGNORE, mpi_ierr)
+ end do
+
+ do i=0, dminfo % nprocs - 1
+
+ numToRecv = 0
+ do j=1,nNeededList
+ if (ownerListIn(j) == -i) numToRecv = numToRecv + 1
+ end do
+ if (numToRecv > 0) then
+ allocate(recvListPtr % next)
+ recvListPtr => recvListPtr % next
+ recvListPtr % procID = i
+ recvListPtr % nlist = numToRecv
+ allocate(recvListPtr % list(numToRecv))
+ nullify(recvListPtr % next)
+ kk = 1
+ do j=1,nNeededList
+ if (ownerListIn(j) == -i) then
+ recvListPtr % list(kk) = j
+ kk = kk + 1
+ end if
+ end do
+ end if
+
+ end do
+
+ deallocate(ownerListIn)
+ deallocate(ownerListOut)
+
+ sendListPtr => sendList
+ sendList => sendList % next
+ deallocate(sendListPtr)
+
+ recvListPtr => recvList
+ recvList => recvList % next
+ deallocate(recvListPtr)
+
+#else
+ allocate(recvList)
+ recvList % procID = dminfo % my_proc_id
+ recvList % nlist = nNeededList
+ allocate(recvList % list(nNeededList))
+ nullify(recvList % next)
+ do j=1,nNeededList
+ recvList % list(j) = j
+ end do
+
+ allocate(sendList)
+ sendList % procID = dminfo % my_proc_id
+ sendList % nlist = nOwnedList
+ allocate(sendList % list(nOwnedList))
+ nullify(sendList % next)
+ do j=1,nOwnedList
+ sendList % list(j) = j
+ end do
+#endif
+
+ end subroutine mpas_dmpar_get_owner_list
+
+
+ subroutine mpas_dmpar_alltoall_field1d_integer(dminfo, arrayIn, arrayOut, nOwnedList, nNeededList, sendList, recvList)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, dimension(*), intent(in) :: arrayIn
+ integer, dimension(*), intent(inout) :: arrayOut
+ integer, intent(in) :: nOwnedList, nNeededList
+ type (exchange_list), pointer :: sendList, recvList
+
+ type (exchange_list), pointer :: sendListPtr, recvListPtr
+ integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
+ integer :: mpi_ierr
+ integer :: i
+
+#ifdef _MPI
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID == dminfo % my_proc_id) exit
+ sendListPtr => sendListPtr % next
+ end do
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID == dminfo % my_proc_id) exit
+ recvListPtr => recvListPtr % next
+ end do
+
+ if (associated(recvListPtr) .and. associated(sendListPtr)) then
+ do i=1,recvListPtr % nlist
+ arrayOut(recvListPtr % list(i)) = arrayIn(sendListPtr % list(i))
+ end do
+ end if
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ allocate(recvListPtr % ibuffer(recvListPtr % nlist))
+ call MPI_Irecv(recvListPtr % ibuffer, recvListPtr % nlist, MPI_INTEGERKIND, &
+ recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ allocate(sendListPtr % ibuffer(sendListPtr % nlist))
+ call mpas_pack_send_buf1d_integer(nOwnedList, arrayIn, sendListPtr, 1, sendListPtr % nlist, &
+ sendListPtr % ibuffer, nPacked, lastPackedIdx)
+ call MPI_Isend(sendListPtr % ibuffer, sendListPtr % nlist, MPI_INTEGERKIND, &
+ sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ call mpas_unpack_recv_buf1d_integer(nNeededList, arrayOut, recvListPtr, 1, recvListPtr % nlist, &
+ recvListPtr % ibuffer, nUnpacked, lastUnpackedIdx)
+ deallocate(recvListPtr % ibuffer)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ deallocate(sendListPtr % ibuffer)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+#else
+ if (nOwnedList /= nNeededList) then
+ write(0,*) 'Error in dmpar_alltoall_field: For non-dmpar, ', &
+ 'arrayIn and arrayOut dims must match.'
+ call mpas_dmpar_abort(dminfo)
+ else
+ arrayOut(1:nNeededList) = arrayIn(1:nOwnedList)
+ end if
+#endif
+
+ end subroutine mpas_dmpar_alltoall_field1d_integer
+
+
+ subroutine mpas_dmpar_alltoall_field2d_integer(dminfo, arrayIn, arrayOut, dim1, nOwnedList, nNeededList, sendList, recvList)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: dim1, nOwnedList, nNeededList
+ integer, dimension(dim1,*), intent(in) :: arrayIn
+ integer, dimension(dim1,*), intent(inout) :: arrayOut
+ type (exchange_list), pointer :: sendList, recvList
+
+ type (exchange_list), pointer :: sendListPtr, recvListPtr
+ integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
+ integer :: mpi_ierr
+ integer :: i, d2
+
+#ifdef _MPI
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID == dminfo % my_proc_id) exit
+ sendListPtr => sendListPtr % next
+ end do
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID == dminfo % my_proc_id) exit
+ recvListPtr => recvListPtr % next
+ end do
+
+ if (associated(recvListPtr) .and. associated(sendListPtr)) then
+ do i=1,recvListPtr % nlist
+ arrayOut(:,recvListPtr % list(i)) = arrayIn(:,sendListPtr % list(i))
+ end do
+ end if
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ d2 = dim1 * recvListPtr % nlist
+ allocate(recvListPtr % ibuffer(d2))
+ call MPI_Irecv(recvListPtr % ibuffer, d2, MPI_INTEGERKIND, &
+ recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ d2 = dim1 * sendListPtr % nlist
+ allocate(sendListPtr % ibuffer(d2))
+ call mpas_pack_send_buf2d_integer(1, dim1, nOwnedList, arrayIn, sendListPtr, 1, d2, &
+ sendListPtr % ibuffer, nPacked, lastPackedIdx)
+ call MPI_Isend(sendListPtr % ibuffer, d2, MPI_INTEGERKIND, &
+ sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ d2 = dim1 * recvListPtr % nlist
+ call mpas_unpack_recv_buf2d_integer(1, dim1, nNeededList, arrayOut, recvListPtr, 1, d2, &
+ recvListPtr % ibuffer, nUnpacked, lastUnpackedIdx)
+ deallocate(recvListPtr % ibuffer)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ deallocate(sendListPtr % ibuffer)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+#else
+ if (nOwnedList /= nNeededList) then
+ write(0,*) 'Error in dmpar_alltoall_field: For non-dmpar, ', &
+ 'arrayIn and arrayOut dims must match.'
+ call mpas_dmpar_abort(dminfo)
+ else
+ arrayOut(:,1:nNeededList) = arrayIn(:,1:nOwnedList)
+ end if
+#endif
+
+ end subroutine mpas_dmpar_alltoall_field2d_integer
+
+
+ subroutine mpas_dmpar_alltoall_field1d_real(dminfo, arrayIn, arrayOut, nOwnedList, nNeededList, sendList, recvList)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ real (kind=RKIND), dimension(*), intent(in) :: arrayIn
+ real (kind=RKIND), dimension(*), intent(inout) :: arrayOut
+ integer, intent(in) :: nOwnedList, nNeededList
+ type (exchange_list), pointer :: sendList, recvList
+
+ type (exchange_list), pointer :: sendListPtr, recvListPtr
+ integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
+ integer :: mpi_ierr
+ integer :: i
+
+#ifdef _MPI
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID == dminfo % my_proc_id) exit
+ sendListPtr => sendListPtr % next
+ end do
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID == dminfo % my_proc_id) exit
+ recvListPtr => recvListPtr % next
+ end do
+
+ if (associated(recvListPtr) .and. associated(sendListPtr)) then
+ do i=1,recvListPtr % nlist
+ arrayOut(recvListPtr % list(i)) = arrayIn(sendListPtr % list(i))
+ end do
+ end if
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ allocate(recvListPtr % rbuffer(recvListPtr % nlist))
+ call MPI_Irecv(recvListPtr % rbuffer, recvListPtr % nlist, MPI_REALKIND, &
+ recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ allocate(sendListPtr % rbuffer(sendListPtr % nlist))
+ call mpas_pack_send_buf1d_real(nOwnedList, arrayIn, sendListPtr, 1, sendListPtr % nlist, &
+ sendListPtr % rbuffer, nPacked, lastPackedIdx)
+ call MPI_Isend(sendListPtr % rbuffer, sendListPtr % nlist, MPI_REALKIND, &
+ sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ call mpas_unpack_recv_buf1d_real(nNeededList, arrayOut, recvListPtr, 1, recvListPtr % nlist, &
+ recvListPtr % rbuffer, nUnpacked, lastUnpackedIdx)
+ deallocate(recvListPtr % rbuffer)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ deallocate(sendListPtr % rbuffer)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+#else
+ if (nOwnedList /= nNeededList) then
+ write(0,*) 'Error in dmpar_alltoall_field: For non-dmpar, ', &
+ 'arrayIn and arrayOut dims must match.'
+ call mpas_dmpar_abort(dminfo)
+ else
+ arrayOut(1:nNeededList) = arrayIn(1:nOwnedList)
+ end if
+#endif
+
+ end subroutine mpas_dmpar_alltoall_field1d_real
+
+
+ subroutine mpas_dmpar_alltoall_field2d_real(dminfo, arrayIn, arrayOut, dim1, nOwnedList, nNeededList, sendList, recvList)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: dim1, nOwnedList, nNeededList
+ real (kind=RKIND), dimension(dim1,*), intent(in) :: arrayIn
+ real (kind=RKIND), dimension(dim1,*), intent(inout) :: arrayOut
+ type (exchange_list), pointer :: sendList, recvList
+
+ type (exchange_list), pointer :: sendListPtr, recvListPtr
+ integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
+ integer :: mpi_ierr
+ integer :: i, d2
+
+#ifdef _MPI
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID == dminfo % my_proc_id) exit
+ sendListPtr => sendListPtr % next
+ end do
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID == dminfo % my_proc_id) exit
+ recvListPtr => recvListPtr % next
+ end do
+
+ if (associated(recvListPtr) .and. associated(sendListPtr)) then
+ do i=1,recvListPtr % nlist
+ arrayOut(:,recvListPtr % list(i)) = arrayIn(:,sendListPtr % list(i))
+ end do
+ end if
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ d2 = dim1 * recvListPtr % nlist
+ allocate(recvListPtr % rbuffer(d2))
+ call MPI_Irecv(recvListPtr % rbuffer, d2, MPI_REALKIND, &
+ recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ d2 = dim1 * sendListPtr % nlist
+ allocate(sendListPtr % rbuffer(d2))
+ call mpas_pack_send_buf2d_real(1, dim1, nOwnedList, arrayIn, sendListPtr, 1, d2, &
+ sendListPtr % rbuffer, nPacked, lastPackedIdx)
+ call MPI_Isend(sendListPtr % rbuffer, d2, MPI_REALKIND, &
+ sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ d2 = dim1 * recvListPtr % nlist
+ call mpas_unpack_recv_buf2d_real(1, dim1, nNeededList, arrayOut, recvListPtr, 1, d2, &
+ recvListPtr % rbuffer, nUnpacked, lastUnpackedIdx)
+ deallocate(recvListPtr % rbuffer)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ deallocate(sendListPtr % rbuffer)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+#else
+ if (nOwnedList /= nNeededList) then
+ write(0,*) 'Error in dmpar_alltoall_field: For non-dmpar, ', &
+ 'arrayIn and arrayOut dims must match.'
+ call mpas_dmpar_abort(dminfo)
+ else
+ arrayOut(:,1:nNeededList) = arrayIn(:,1:nOwnedList)
+ end if
+#endif
+
+ end subroutine mpas_dmpar_alltoall_field2d_real
+
+
+ subroutine mpas_dmpar_alltoall_field3d_real(dminfo, arrayIn, arrayOut, dim1, dim2, nOwnedList, nNeededList, sendList, recvList)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: dim1, dim2, nOwnedList, nNeededList
+ real (kind=RKIND), dimension(dim1,dim2,*), intent(in) :: arrayIn
+ real (kind=RKIND), dimension(dim1,dim2,*), intent(inout) :: arrayOut
+ type (exchange_list), pointer :: sendList, recvList
+
+ type (exchange_list), pointer :: sendListPtr, recvListPtr
+ integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
+ integer :: mpi_ierr
+ integer :: i, d3
+
+#ifdef _MPI
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID == dminfo % my_proc_id) exit
+ sendListPtr => sendListPtr % next
+ end do
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID == dminfo % my_proc_id) exit
+ recvListPtr => recvListPtr % next
+ end do
+
+ if (associated(recvListPtr) .and. associated(sendListPtr)) then
+ do i=1,recvListPtr % nlist
+ arrayOut(:,:,recvListPtr % list(i)) = arrayIn(:,:,sendListPtr % list(i))
+ end do
+ end if
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ d3 = dim1 * dim2 * recvListPtr % nlist
+ allocate(recvListPtr % rbuffer(d3))
+ call MPI_Irecv(recvListPtr % rbuffer, d3, MPI_REALKIND, &
+ recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ d3 = dim1 * dim2 * sendListPtr % nlist
+ allocate(sendListPtr % rbuffer(d3))
+ call mpas_pack_send_buf3d_real(1, dim1, 1, dim2, nOwnedList, arrayIn, sendListPtr, 1, d3, &
+ sendListPtr % rbuffer, nPacked, lastPackedIdx)
+ call MPI_Isend(sendListPtr % rbuffer, d3, MPI_REALKIND, &
+ sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ d3 = dim1 * dim2 * recvListPtr % nlist
+ call mpas_unpack_recv_buf3d_real(1, dim1, 1, dim2, nNeededList, arrayOut, recvListPtr, 1, d3, &
+ recvListPtr % rbuffer, nUnpacked, lastUnpackedIdx)
+ deallocate(recvListPtr % rbuffer)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ deallocate(sendListPtr % rbuffer)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+#else
+ if (nOwnedList /= nNeededList) then
+ write(0,*) 'Error in dmpar_alltoall_field: For non-dmpar, ', &
+ 'arrayIn and arrayOut dims must match.'
+ call mpas_dmpar_abort(dminfo)
+ else
+ arrayOut(:,:,1:nNeededList) = arrayIn(:,:,1:nOwnedList)
+ end if
+#endif
+
+ end subroutine mpas_dmpar_alltoall_field3d_real
+
+
+ subroutine mpas_pack_send_buf1d_integer(nField, field, sendList, startPackIdx, nBuffer, buffer, nPacked, lastPackedIdx)
+
+ implicit none
+
+ integer, intent(in) :: nField, nBuffer, startPackIdx
+ integer, dimension(*), intent(in) :: field
+ type (exchange_list), intent(in) :: sendList
+ integer, dimension(nBuffer), intent(out) :: buffer
+ integer, intent(inout) :: nPacked, lastPackedIdx
+
+ integer :: i
+
+ nPacked = 0
+ do i=startPackIdx, sendList % nlist
+ nPacked = nPacked + 1
+ if (nPacked > nBuffer) then
+ nPacked = nPacked - 1
+ lastPackedIdx = i - 1
+ return
+ end if
+ buffer(nPacked) = field(sendList % list(i))
+ end do
+ lastPackedIdx = sendList % nlist
+
+ end subroutine mpas_pack_send_buf1d_integer
+
+
+ subroutine mpas_pack_send_buf2d_integer(ds, de, nField, field, sendList, startPackIdx, nBuffer, buffer, nPacked, lastPackedIdx)
+
+ implicit none
+
+ integer, intent(in) :: ds, de, nField, nBuffer, startPackIdx
+ integer, dimension(ds:de,*), intent(in) :: field
+ type (exchange_list), intent(in) :: sendList
+ integer, dimension(nBuffer), intent(out) :: buffer
+ integer, intent(inout) :: nPacked, lastPackedIdx
+
+ integer :: i, n
+
+ n = de-ds+1
+
+ if (n > nBuffer) then
+ write(0,*) 'packSendBuf2dInteger: Not enough space in buffer', &
+ ' to fit a single slice.'
+ return
+ end if
+
+ nPacked = 0
+ do i=startPackIdx, sendList % nlist
+ nPacked = nPacked + n
+ if (nPacked > nBuffer) then
+ nPacked = nPacked - n
+ lastPackedIdx = i - 1
+ return
+ end if
+ buffer(nPacked-n+1:nPacked) = field(ds:de,sendList % list(i))
+ end do
+ lastPackedIdx = sendList % nlist
+
+ end subroutine mpas_pack_send_buf2d_integer
+
+
+ subroutine mpas_pack_send_buf3d_integer(d1s, d1e, d2s, d2e, nField, field, sendList, startPackIdx, nBuffer, buffer, nPacked, lastPackedIdx)
+
+ implicit none
+
+ integer, intent(in) :: d1s, d1e, d2s, d2e, nField, nBuffer, startPackIdx
+ integer, dimension(d1s:d1e,d2s:d2e,*), intent(in) :: field
+ type (exchange_list), intent(in) :: sendList
+ integer, dimension(nBuffer), intent(out) :: buffer
+ integer, intent(inout) :: nPacked, lastPackedIdx
+
+ integer :: i, j, k, n
+
+ n = (d1e-d1s+1) * (d2e-d2s+1)
+
+ if (n > nBuffer) then
+ write(0,*) 'packSendBuf3dInteger: Not enough space in buffer', &
+ ' to fit a single slice.'
+ return
+ end if
+
+ nPacked = 0
+ do i=startPackIdx, sendList % nlist
+ nPacked = nPacked + n
+ if (nPacked > nBuffer) then
+ nPacked = nPacked - n
+ lastPackedIdx = i - 1
+ return
+ end if
+ k = nPacked-n+1
+ do j=d2s,d2e
+ buffer(k:k+d1e-d1s) = field(d1s:d1e,j,sendList % list(i))
+ k = k + d1e-d1s+1
+ end do
+ end do
+ lastPackedIdx = sendList % nlist
+
+ end subroutine mpas_pack_send_buf3d_integer
+
+
+ subroutine mpas_pack_send_buf1d_real(nField, field, sendList, startPackIdx, nBuffer, buffer, nPacked, lastPackedIdx)
+
+ implicit none
+
+ integer, intent(in) :: nField, nBuffer, startPackIdx
+ real (kind=RKIND), dimension(*), intent(in) :: field
+ type (exchange_list), intent(in) :: sendList
+ real (kind=RKIND), dimension(nBuffer), intent(out) :: buffer
+ integer, intent(inout) :: nPacked, lastPackedIdx
+
+ integer :: i
+
+ nPacked = 0
+ do i=startPackIdx, sendList % nlist
+ nPacked = nPacked + 1
+ if (nPacked > nBuffer) then
+ nPacked = nPacked - 1
+ lastPackedIdx = i - 1
+ return
+ end if
+ buffer(nPacked) = field(sendList % list(i))
+ end do
+ lastPackedIdx = sendList % nlist
+
+ end subroutine mpas_pack_send_buf1d_real
+
+
+ subroutine mpas_pack_send_buf2d_real(ds, de, nField, field, sendList, startPackIdx, nBuffer, buffer, nPacked, lastPackedIdx)
+
+ implicit none
+
+ integer, intent(in) :: ds, de, nField, nBuffer, startPackIdx
+ real (kind=RKIND), dimension(ds:de,*), intent(in) :: field
+ type (exchange_list), intent(in) :: sendList
+ real (kind=RKIND), dimension(nBuffer), intent(out) :: buffer
+ integer, intent(inout) :: nPacked, lastPackedIdx
+
+ integer :: i, n
+
+ n = de-ds+1
+
+ if (n > nBuffer) then
+ write(0,*) 'packSendBuf2dReal: Not enough space in buffer', &
+ ' to fit a single slice.'
+ return
+ end if
+
+ nPacked = 0
+ do i=startPackIdx, sendList % nlist
+ nPacked = nPacked + n
+ if (nPacked > nBuffer) then
+ nPacked = nPacked - n
+ lastPackedIdx = i - 1
+ return
+ end if
+ buffer(nPacked-n+1:nPacked) = field(ds:de,sendList % list(i))
+ end do
+ lastPackedIdx = sendList % nlist
+
+ end subroutine mpas_pack_send_buf2d_real
+
+
+ subroutine mpas_pack_send_buf3d_real(d1s, d1e, d2s, d2e, nField, field, sendList, startPackIdx, nBuffer, buffer, nPacked, lastPackedIdx)
+
+ implicit none
+
+ integer, intent(in) :: d1s, d1e, d2s, d2e, nField, nBuffer, startPackIdx
+ real (kind=RKIND), dimension(d1s:d1e,d2s:d2e,*), intent(in) :: field
+ type (exchange_list), intent(in) :: sendList
+ real (kind=RKIND), dimension(nBuffer), intent(out) :: buffer
+ integer, intent(inout) :: nPacked, lastPackedIdx
+
+ integer :: i, j, k, n
+
+ n = (d1e-d1s+1) * (d2e-d2s+1)
+
+ if (n > nBuffer) then
+ write(0,*) 'packSendBuf3dReal: Not enough space in buffer', &
+ ' to fit a single slice.'
+ return
+ end if
+
+ nPacked = 0
+ do i=startPackIdx, sendList % nlist
+ nPacked = nPacked + n
+ if (nPacked > nBuffer) then
+ nPacked = nPacked - n
+ lastPackedIdx = i - 1
+ return
+ end if
+ k = nPacked-n+1
+ do j=d2s,d2e
+ buffer(k:k+d1e-d1s) = field(d1s:d1e,j,sendList % list(i))
+ k = k + d1e-d1s+1
+ end do
+ end do
+ lastPackedIdx = sendList % nlist
+
+ end subroutine mpas_pack_send_buf3d_real
+
+
+ subroutine mpas_unpack_recv_buf1d_integer(nField, field, recvList, startUnpackIdx, nBuffer, buffer, nUnpacked, lastUnpackedIdx)
+
+ implicit none
+
+ integer, intent(in) :: nField, nBuffer, startUnpackIdx
+ integer, dimension(*), intent(inout) :: field
+ type (exchange_list), intent(in) :: recvList
+ integer, dimension(nBuffer), intent(in) :: buffer
+ integer, intent(inout) :: nUnpacked, lastUnpackedIdx
+
+ integer :: i
+
+ nUnpacked = 0
+ do i=startUnpackIdx, recvList % nlist
+ nUnpacked = nUnpacked + 1
+ if (nUnpacked > nBuffer) then
+ nUnpacked = nUnpacked - 1
+ lastUnpackedIdx = i - 1
+ return
+ end if
+ field(recvList % list(i)) = buffer(nUnpacked)
+ end do
+ lastUnpackedIdx = recvList % nlist
+
+ end subroutine mpas_unpack_recv_buf1d_integer
+
+
+ subroutine mpas_unpack_recv_buf2d_integer(ds, de, nField, field, recvList, startUnpackIdx, nBuffer, buffer, nUnpacked, lastUnpackedIdx)
+
+ implicit none
+
+ integer, intent(in) :: ds, de, nField, nBuffer, startUnpackIdx
+ integer, dimension(ds:de,*), intent(inout) :: field
+ type (exchange_list), intent(in) :: recvList
+ integer, dimension(nBuffer), intent(in) :: buffer
+ integer, intent(inout) :: nUnpacked, lastUnpackedIdx
+
+ integer :: i, n
+
+ n = de-ds+1
+
+ nUnpacked = 0
+ do i=startUnpackIdx, recvList % nlist
+ nUnpacked = nUnpacked + n
+ if (nUnpacked > nBuffer) then
+ nUnpacked = nUnpacked - n
+ lastUnpackedIdx = i - 1
+ return
+ end if
+ field(ds:de,recvList % list(i)) = buffer(nUnpacked-n+1:nUnpacked)
+ end do
+ lastUnpackedIdx = recvList % nlist
+
+ end subroutine mpas_unpack_recv_buf2d_integer
+
+
+ subroutine mpas_unpack_recv_buf3d_integer(d1s, d1e, d2s, d2e, nField, field, recvList, startUnpackIdx, nBuffer, buffer, &
+ nUnpacked, lastUnpackedIdx)
+
+ implicit none
+
+ integer, intent(in) :: d1s, d1e, d2s, d2e, nField, nBuffer, startUnpackIdx
+ integer, dimension(d1s:d1e,d2s:d2e,*), intent(inout) :: field
+ type (exchange_list), intent(in) :: recvList
+ integer, dimension(nBuffer), intent(in) :: buffer
+ integer, intent(inout) :: nUnpacked, lastUnpackedIdx
+
+ integer :: i, j, k, n
+
+ n = (d1e-d1s+1) * (d2e-d2s+1)
+
+ nUnpacked = 0
+ do i=startUnpackIdx, recvList % nlist
+ nUnpacked = nUnpacked + n
+ if (nUnpacked > nBuffer) then
+ nUnpacked = nUnpacked - n
+ lastUnpackedIdx = i - 1
+ return
+ end if
+ k = nUnpacked-n+1
+ do j=d2s,d2e
+ field(d1s:d1e,j,recvList % list(i)) = buffer(k:k+d1e-d1s)
+ k = k + d1e-d1s+1
+ end do
+ end do
+ lastUnpackedIdx = recvList % nlist
+
+ end subroutine mpas_unpack_recv_buf3d_integer
+
+
+ subroutine mpas_dmpar_exch_halo_field1d_integer(dminfo, array, dim1, sendList, recvList)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: dim1
+ integer, dimension(*), intent(inout) :: array
+ type (exchange_list), pointer :: sendList, recvList
+
+ type (exchange_list), pointer :: sendListPtr, recvListPtr
+ integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
+ integer :: mpi_ierr
+
+#ifdef _MPI
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ allocate(recvListPtr % ibuffer(recvListPtr % nlist))
+ call MPI_Irecv(recvListPtr % ibuffer, recvListPtr % nlist, MPI_INTEGERKIND, &
+ recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ allocate(sendListPtr % ibuffer(sendListPtr % nlist))
+ call mpas_pack_send_buf1d_integer(dim1, array, sendListPtr, 1, sendListPtr % nlist, sendListPtr % ibuffer, nPacked, lastPackedIdx)
+ call MPI_Isend(sendListPtr % ibuffer, sendListPtr % nlist, MPI_INTEGERKIND, &
+ sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ call mpas_unpack_recv_buf1d_integer(dim1, array, recvListPtr, 1, recvListPtr % nlist, recvListPtr % ibuffer, nUnpacked, lastUnpackedIdx)
+ deallocate(recvListPtr % ibuffer)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ deallocate(sendListPtr % ibuffer)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+#endif
+
+ end subroutine mpas_dmpar_exch_halo_field1d_integer
+
+
+ subroutine mpas_dmpar_exch_halo_field2d_integer(dminfo, array, dim1, dim2, sendList, recvList)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: dim1, dim2
+ integer, dimension(dim1,*), intent(inout) :: array
+ type (exchange_list), pointer :: sendList, recvList
+
+ type (exchange_list), pointer :: sendListPtr, recvListPtr
+ integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
+ integer :: mpi_ierr
+ integer :: d2
+
+#ifdef _MPI
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ d2 = dim1 * recvListPtr % nlist
+ allocate(recvListPtr % ibuffer(d2))
+ call MPI_Irecv(recvListPtr % ibuffer, d2, MPI_INTEGERKIND, &
+ recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ d2 = dim1 * sendListPtr % nlist
+ allocate(sendListPtr % ibuffer(d2))
+ call mpas_pack_send_buf2d_integer(1, dim1, dim2, array, sendListPtr, 1, d2, sendListPtr % ibuffer, nPacked, lastPackedIdx)
+ call MPI_Isend(sendListPtr % ibuffer, d2, MPI_INTEGERKIND, &
+ sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ d2 = dim1 * recvListPtr % nlist
+ call mpas_unpack_recv_buf2d_integer(1, dim1, dim2, array, recvListPtr, 1, d2, recvListPtr % ibuffer, nUnpacked, lastUnpackedIdx)
+ deallocate(recvListPtr % ibuffer)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ deallocate(sendListPtr % ibuffer)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+#endif
+
+ end subroutine mpas_dmpar_exch_halo_field2d_integer
+
+
+ subroutine mpas_dmpar_exch_halo_field3d_integer(dminfo, array, dim1, dim2, dim3, sendList, recvList)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: dim1, dim2, dim3
+ integer, dimension(dim1,dim2,*), intent(inout) :: array
+ type (exchange_list), pointer :: sendList, recvList
+
+ type (exchange_list), pointer :: sendListPtr, recvListPtr
+ integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
+ integer :: mpi_ierr
+ integer :: d3
+
+#ifdef _MPI
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ d3 = dim1 * dim2 * recvListPtr % nlist
+ allocate(recvListPtr % ibuffer(d3))
+ call MPI_Irecv(recvListPtr % ibuffer, d3, MPI_INTEGERKIND, &
+ recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ d3 = dim1 * dim2 * sendListPtr % nlist
+ allocate(sendListPtr % ibuffer(d3))
+ call mpas_pack_send_buf3d_integer(1, dim1, 1, dim2, dim3, array, sendListPtr, 1, d3, &
+ sendListPtr % ibuffer, nPacked, lastPackedIdx)
+ call MPI_Isend(sendListPtr % ibuffer, d3, MPI_INTEGERKIND, &
+ sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ d3 = dim1 * dim2 * recvListPtr % nlist
+ call mpas_unpack_recv_buf3d_integer(1, dim1, 1, dim2, dim3, array, recvListPtr, 1, d3, &
+ recvListPtr % ibuffer, nUnpacked, lastUnpackedIdx)
+ deallocate(recvListPtr % ibuffer)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ deallocate(sendListPtr % ibuffer)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+#endif
+
+ end subroutine mpas_dmpar_exch_halo_field3d_integer
+
+
+ subroutine mpas_unpack_recv_buf1d_real(nField, field, recvList, startUnpackIdx, nBuffer, buffer, nUnpacked, lastUnpackedIdx)
+
+ implicit none
+
+ integer, intent(in) :: nField, nBuffer, startUnpackIdx
+ real (kind=RKIND), dimension(*), intent(inout) :: field
+ type (exchange_list), intent(in) :: recvList
+ real (kind=RKIND), dimension(nBuffer), intent(in) :: buffer
+ integer, intent(inout) :: nUnpacked, lastUnpackedIdx
+
+ integer :: i
+
+ nUnpacked = 0
+ do i=startUnpackIdx, recvList % nlist
+ nUnpacked = nUnpacked + 1
+ if (nUnpacked > nBuffer) then
+ nUnpacked = nUnpacked - 1
+ lastUnpackedIdx = i - 1
+ return
+ end if
+ field(recvList % list(i)) = buffer(nUnpacked)
+ end do
+ lastUnpackedIdx = recvList % nlist
+
+ end subroutine mpas_unpack_recv_buf1d_real
+
+
+ subroutine mpas_unpack_recv_buf2d_real(ds, de, nField, field, recvList, startUnpackIdx, nBuffer, buffer, nUnpacked, lastUnpackedIdx)
+
+ implicit none
+
+ integer, intent(in) :: ds, de, nField, nBuffer, startUnpackIdx
+ real (kind=RKIND), dimension(ds:de,*), intent(inout) :: field
+ type (exchange_list), intent(in) :: recvList
+ real (kind=RKIND), dimension(nBuffer), intent(in) :: buffer
+ integer, intent(inout) :: nUnpacked, lastUnpackedIdx
+
+ integer :: i, n
+
+ n = de-ds+1
+
+ nUnpacked = 0
+ do i=startUnpackIdx, recvList % nlist
+ nUnpacked = nUnpacked + n
+ if (nUnpacked > nBuffer) then
+ nUnpacked = nUnpacked - n
+ lastUnpackedIdx = i - 1
+ return
+ end if
+ field(ds:de,recvList % list(i)) = buffer(nUnpacked-n+1:nUnpacked)
+ end do
+ lastUnpackedIdx = recvList % nlist
+
+ end subroutine mpas_unpack_recv_buf2d_real
+
+
+ subroutine mpas_unpack_recv_buf3d_real(d1s, d1e, d2s, d2e, nField, field, recvList, startUnpackIdx, nBuffer, buffer, &
+ nUnpacked, lastUnpackedIdx)
+
+ implicit none
+
+ integer, intent(in) :: d1s, d1e, d2s, d2e, nField, nBuffer, startUnpackIdx
+ real (kind=RKIND), dimension(d1s:d1e,d2s:d2e,*), intent(inout) :: field
+ type (exchange_list), intent(in) :: recvList
+ real (kind=RKIND), dimension(nBuffer), intent(in) :: buffer
+ integer, intent(inout) :: nUnpacked, lastUnpackedIdx
+
+ integer :: i, j, k, n
+
+ n = (d1e-d1s+1) * (d2e-d2s+1)
+
+ nUnpacked = 0
+ do i=startUnpackIdx, recvList % nlist
+ nUnpacked = nUnpacked + n
+ if (nUnpacked > nBuffer) then
+ nUnpacked = nUnpacked - n
+ lastUnpackedIdx = i - 1
+ return
+ end if
+ k = nUnpacked-n+1
+ do j=d2s,d2e
+ field(d1s:d1e,j,recvList % list(i)) = buffer(k:k+d1e-d1s)
+ k = k + d1e-d1s+1
+ end do
+ end do
+ lastUnpackedIdx = recvList % nlist
+
+ end subroutine mpas_unpack_recv_buf3d_real
+
+
+ subroutine mpas_dmpar_exch_halo_field1d_real(dminfo, array, dim1, sendList, recvList)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: dim1
+ real (kind=RKIND), dimension(*), intent(inout) :: array
+ type (exchange_list), pointer :: sendList, recvList
+
+ type (exchange_list), pointer :: sendListPtr, recvListPtr
+ integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
+ integer :: mpi_ierr
+
+#ifdef _MPI
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ allocate(recvListPtr % rbuffer(recvListPtr % nlist))
+ call MPI_Irecv(recvListPtr % rbuffer, recvListPtr % nlist, MPI_REALKIND, &
+ recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ allocate(sendListPtr % rbuffer(sendListPtr % nlist))
+ call mpas_pack_send_buf1d_real(dim1, array, sendListPtr, 1, sendListPtr % nlist, sendListPtr % rbuffer, nPacked, lastPackedIdx)
+ call MPI_Isend(sendListPtr % rbuffer, sendListPtr % nlist, MPI_REALKIND, &
+ sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ call mpas_unpack_recv_buf1d_real(dim1, array, recvListPtr, 1, recvListPtr % nlist, recvListPtr % rbuffer, nUnpacked, lastUnpackedIdx)
+ deallocate(recvListPtr % rbuffer)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ deallocate(sendListPtr % rbuffer)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+#endif
+
+ end subroutine mpas_dmpar_exch_halo_field1d_real
+
+
+ subroutine mpas_dmpar_exch_halo_field2d_real(dminfo, array, dim1, dim2, sendList, recvList)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: dim1, dim2
+ real (kind=RKIND), dimension(dim1,*), intent(inout) :: array
+ type (exchange_list), pointer :: sendList, recvList
+
+ type (exchange_list), pointer :: sendListPtr, recvListPtr
+ integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
+ integer :: mpi_ierr
+ integer :: d2
+
+#ifdef _MPI
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ d2 = dim1 * recvListPtr % nlist
+ allocate(recvListPtr % rbuffer(d2))
+ call MPI_Irecv(recvListPtr % rbuffer, d2, MPI_REALKIND, &
+ recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ d2 = dim1 * sendListPtr % nlist
+ allocate(sendListPtr % rbuffer(d2))
+ call mpas_pack_send_buf2d_real(1, dim1, dim2, array, sendListPtr, 1, d2, sendListPtr % rbuffer, nPacked, lastPackedIdx)
+ call MPI_Isend(sendListPtr % rbuffer, d2, MPI_REALKIND, &
+ sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ d2 = dim1 * recvListPtr % nlist
+ call mpas_unpack_recv_buf2d_real(1, dim1, dim2, array, recvListPtr, 1, d2, recvListPtr % rbuffer, nUnpacked, lastUnpackedIdx)
+ deallocate(recvListPtr % rbuffer)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ deallocate(sendListPtr % rbuffer)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+#endif
+
+ end subroutine mpas_dmpar_exch_halo_field2d_real
+
+
+ subroutine mpas_dmpar_exch_halo_field3d_real(dminfo, array, dim1, dim2, dim3, sendList, recvList)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: dim1, dim2, dim3
+ real (kind=RKIND), dimension(dim1,dim2,*), intent(inout) :: array
+ type (exchange_list), pointer :: sendList, recvList
+
+ type (exchange_list), pointer :: sendListPtr, recvListPtr
+ integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
+ integer :: mpi_ierr
+ integer :: d3
+
+#ifdef _MPI
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ d3 = dim1 * dim2 * recvListPtr % nlist
+ allocate(recvListPtr % rbuffer(d3))
+ call MPI_Irecv(recvListPtr % rbuffer, d3, MPI_REALKIND, &
+ recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ d3 = dim1 * dim2 * sendListPtr % nlist
+ allocate(sendListPtr % rbuffer(d3))
+ call mpas_pack_send_buf3d_real(1, dim1, 1, dim2, dim3, array, sendListPtr, 1, d3, &
+ sendListPtr % rbuffer, nPacked, lastPackedIdx)
+ call MPI_Isend(sendListPtr % rbuffer, d3, MPI_REALKIND, &
+ sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ d3 = dim1 * dim2 * recvListPtr % nlist
+ call mpas_unpack_recv_buf3d_real(1, dim1, 1, dim2, dim3, array, recvListPtr, 1, d3, &
+ recvListPtr % rbuffer, nUnpacked, lastUnpackedIdx)
+ deallocate(recvListPtr % rbuffer)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ deallocate(sendListPtr % rbuffer)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+#endif
+
+ end subroutine mpas_dmpar_exch_halo_field3d_real
+
+
+end module mpas_dmpar
Copied: trunk/mpas/src/framework/mpas_framework.F (from rev 1113, branches/source_renaming/src/framework/mpas_framework.F)
===================================================================
--- trunk/mpas/src/framework/mpas_framework.F (rev 0)
+++ trunk/mpas/src/framework/mpas_framework.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -0,0 +1,49 @@
+module mpas_framework
+
+ use mpas_dmpar
+ use mpas_grid_types
+ use mpas_io_input
+ use mpas_io_output
+ use mpas_configure
+ use mpas_timer
+ use mpas_timekeeping
+
+
+ contains
+
+
+ subroutine mpas_framework_init(dminfo, domain)
+
+ implicit none
+
+ type (dm_info), pointer :: dminfo
+ type (domain_type), pointer :: domain
+
+ allocate(dminfo)
+ call mpas_dmpar_init(dminfo)
+
+ call mpas_read_namelist(dminfo)
+
+ call mpas_allocate_domain(domain, dminfo)
+
+ call mpas_timekeeping_init(config_calendar_type)
+
+ end subroutine mpas_framework_init
+
+
+ subroutine mpas_framework_finalize(dminfo, domain)
+
+ implicit none
+
+ type (dm_info), pointer :: dminfo
+ type (domain_type), pointer :: domain
+
+ call mpas_deallocate_domain(domain)
+
+ call mpas_dmpar_finalize(dminfo)
+
+ call mpas_timekeeping_finalize()
+
+ end subroutine mpas_framework_finalize
+
+end module mpas_framework
Copied: trunk/mpas/src/framework/mpas_grid_types.F (from rev 1113, branches/source_renaming/src/framework/mpas_grid_types.F)
===================================================================
--- trunk/mpas/src/framework/mpas_grid_types.F (rev 0)
+++ trunk/mpas/src/framework/mpas_grid_types.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -0,0 +1,219 @@
+module mpas_grid_types
+
+ use mpas_dmpar
+
+ integer, parameter :: nTimeLevs = 2
+
+
+ ! Derived type describing info for doing I/O specific to a field
+ type io_info
+ character (len=1024) :: fieldName
+ integer, dimension(4) :: start
+ integer, dimension(4) :: count
+ logical :: input
+ logical :: sfc
+ logical :: restart
+ logical :: output
+ end type io_info
+
+
+ ! Derived type for storing fields
+ type field3DReal
+ type (block_type), pointer :: block
+ real (kind=RKIND), dimension(:,:,:), pointer :: array
+ type (io_info), pointer :: ioinfo
+ end type field3DReal
+
+
+ ! Derived type for storing fields
+ type field2DReal
+ type (block_type), pointer :: block
+ real (kind=RKIND), dimension(:,:), pointer :: array
+ type (io_info), pointer :: ioinfo
+ end type field2DReal
+
+
+ ! Derived type for storing fields
+ type field1DReal
+ type (block_type), pointer :: block
+ real (kind=RKIND), dimension(:), pointer :: array
+ type (io_info), pointer :: ioinfo
+ end type field1DReal
+
+
+ ! Derived type for storing fields
+ type field0DReal
+ type (block_type), pointer :: block
+ real (kind=RKIND) :: scalar
+ type (io_info), pointer :: ioinfo
+ end type field0DReal
+
+
+ ! Derived type for storing fields
+ type field2DInteger
+ type (block_type), pointer :: block
+ integer, dimension(:,:), pointer :: array
+ type (io_info), pointer :: ioinfo
+ end type field2DInteger
+
+
+ ! Derived type for storing fields
+ type field1DInteger
+ type (block_type), pointer :: block
+ integer, dimension(:), pointer :: array
+ type (io_info), pointer :: ioinfo
+ end type field1DInteger
+
+
+ ! Derived type for storing fields
+ type field1DChar
+ type (block_type), pointer :: block
+ character (len=64), dimension(:), pointer :: array
+ type (io_info), pointer :: ioinfo
+ end type field1DChar
+
+
+ ! Derived type for storing fields
+ type field0DChar
+ type (block_type), pointer :: block
+ character (len=64) :: scalar
+ type (io_info), pointer :: ioinfo
+ end type field0DChar
+
+
+ ! Derived type for storing grid meta-data
+ type mesh_type
+
+#include "field_dimensions.inc"
+
+ logical :: on_a_sphere
+ real (kind=RKIND) :: sphere_radius
+
+#include "time_invariant_fields.inc"
+
+ end type mesh_type
+
+
+#include "variable_groups.inc"
+
+
+ ! Type for storing (possibly architecture specific) information concerning to parallelism
+ type parallel_info
+ type (exchange_list), pointer :: cellsToSend ! List of types describing which cells to send to other blocks
+ type (exchange_list), pointer :: cellsToRecv ! List of types describing which cells to receive from other blocks
+ type (exchange_list), pointer :: edgesToSend ! List of types describing which edges to send to other blocks
+ type (exchange_list), pointer :: edgesToRecv ! List of types describing which edges to receive from other blocks
+ type (exchange_list), pointer :: verticesToSend ! List of types describing which vertices to send to other blocks
+ type (exchange_list), pointer :: verticesToRecv ! List of types describing which vertices to receive from other blocks
+ end type parallel_info
+
+
+ ! Derived type for storing part of a domain; used as a basic unit of work for a process
+ type block_type
+
+#include "block_group_members.inc"
+
+ type (domain_type), pointer :: domain
+
+ type (parallel_info), pointer :: parinfo
+
+ type (block_type), pointer :: prev, next
+ end type block_type
+
+
+ ! Derived type for storing list of blocks from a domain to be handled by a process
+ type domain_type
+ type (block_type), pointer :: blocklist
+
+ ! Also store parallelization info here
+ type (dm_info), pointer :: dminfo
+ end type domain_type
+
+
+ contains
+
+
+ subroutine mpas_allocate_domain(dom, dminfo)
+
+ implicit none
+
+ type (domain_type), pointer :: dom
+ type (dm_info), pointer :: dminfo
+
+ allocate(dom)
+ nullify(dom % blocklist)
+ dom % dminfo => dminfo
+
+ end subroutine mpas_allocate_domain
+
+
+ subroutine mpas_allocate_block(b, dom, &
+#include "dim_dummy_args.inc"
+ )
+
+ implicit none
+
+ type (block_type), pointer :: b
+ type (domain_type), pointer :: dom
+#include "dim_dummy_decls.inc"
+
+ integer :: i
+
+ nullify(b % prev)
+ nullify(b % next)
+
+ allocate(b % parinfo)
+
+ b % domain => dom
+
+#include "block_allocs.inc"
+
+ end subroutine mpas_allocate_block
+
+
+#include "group_alloc_routines.inc"
+
+
+ subroutine mpas_deallocate_domain(dom)
+
+ implicit none
+
+ type (domain_type), pointer :: dom
+
+ type (block_type), pointer :: block_ptr
+
+ block_ptr => dom % blocklist
+ do while (associated(block_ptr))
+ call mpas_deallocate_block(block_ptr)
+ block_ptr => block_ptr % next
+ end do
+
+ deallocate(dom)
+
+ end subroutine mpas_deallocate_domain
+
+
+ subroutine mpas_deallocate_block(b)
+
+ implicit none
+
+ type (block_type), intent(inout) :: b
+
+ integer :: i
+
+ deallocate(b % parinfo)
+
+#include "block_deallocs.inc"
+
+ end subroutine mpas_deallocate_block
+
+
+#include "group_dealloc_routines.inc"
+
+
+#include "group_copy_routines.inc"
+
+
+#include "group_shift_level_routines.inc"
+
+end module mpas_grid_types
Copied: trunk/mpas/src/framework/mpas_hash.F (from rev 1113, branches/source_renaming/src/framework/mpas_hash.F)
===================================================================
--- trunk/mpas/src/framework/mpas_hash.F (rev 0)
+++ trunk/mpas/src/framework/mpas_hash.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -0,0 +1,175 @@
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! MODULE HASH
+!
+! Purpose: This module provides a dictionary/hashtable with insert, search, and
+! remove routines.
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+module mpas_hash
+
+ ! Parameters
+ integer, parameter :: TABLESIZE=27183 ! Number of spaces in the table (the
+ ! number of linked lists)
+
+ type hashnode
+ integer :: key
+ type (hashnode), pointer :: next
+ end type hashnode
+
+ type hashnode_ptr
+ type (hashnode), pointer :: p ! Pointer to a list of entries
+ end type hashnode_ptr
+
+ type hashtable
+ integer :: size
+ type (hashnode_ptr), dimension(TABLESIZE) :: table ! The hashtable array
+ end type hashtable
+
+
+ contains
+
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Name: hash_init
+ !
+ ! Purpose: To initialize a hashtable
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine mpas_hash_init(h)
+
+ implicit none
+
+ ! Arguments
+ type (hashtable), intent(inout) :: h
+
+ ! Local variables
+ integer :: i
+
+ h%size = 0
+
+ do i=1,TABLESIZE
+ nullify(h%table(i)%p)
+ end do
+
+ end subroutine mpas_hash_init
+
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Name: hash_insert
+ !
+ ! Purpose: Given a hashtable h and a key to be inserted into the hashtable,
+ ! this routine adds key to the table.
+ !
+ ! NOTE: If the key already exists in the table, a second copy of the
+ ! key is added to the table
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine mpas_hash_insert(h, key)
+
+ implicit none
+
+ ! Arguments
+ integer, intent(in) :: key
+ type (hashtable), intent(inout) :: h
+
+ ! Local variables
+ integer :: hashval, i
+ type (hashnode), pointer :: hn
+
+ hashval = mod(key, TABLESIZE) + 1
+
+ allocate(hn)
+ hn%key = key
+ hn%next => h%table(hashval)%p
+ h%table(hashval)%p => hn
+
+ h%size = h%size + 1
+
+ end subroutine mpas_hash_insert
+
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Name: hash_search
+ !
+ ! Purpose: This function returns TRUE if the specified key was found in the
+ ! hashtable h, and FALSE otherwise.
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ logical function mpas_hash_search(h, key)
+
+ implicit none
+
+ ! Arguments
+ integer, intent(in) :: key
+ type (hashtable), intent(inout) :: h
+
+ ! Local variables
+ integer :: hashval, i
+ type (hashnode), pointer :: cursor
+
+ mpas_hash_search = .false.
+
+ hashval = mod(key, TABLESIZE) + 1
+
+ cursor => h%table(hashval)%p
+ do while(associated(cursor))
+ if (cursor%key == key) then
+ mpas_hash_search = .true.
+ return
+ else
+ cursor => cursor%next
+ end if
+ end do
+
+ return
+
+ end function mpas_hash_search
+
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Name: hash_size
+ !
+ ! Purpose: Returns the number of items in the hash table h.
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ integer function mpas_hash_size(h)
+
+ implicit none
+
+ ! Arguments
+ type (hashtable) :: h
+
+ mpas_hash_size = h%size
+
+ return
+
+ end function mpas_hash_size
+
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Name: hash_destroy
+ !
+ ! Purpose: Frees all memory associated with hashtable h. This routine may be
+ ! used to remove all entries from a hashtable.
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine mpas_hash_destroy(h)
+
+ implicit none
+
+ ! Arguments
+ type (hashtable), intent(inout) :: h
+
+ ! Local variables
+ integer :: i
+ type (hashnode), pointer :: cursor, cursor_prev
+
+ do i=1,TABLESIZE
+ cursor => h%table(i)%p
+ do while(associated(cursor))
+ cursor_prev => cursor
+ cursor => cursor%next
+ deallocate(cursor_prev)
+ end do
+ nullify(h%table(i)%p)
+ end do
+
+ h%size = 0
+
+ end subroutine mpas_hash_destroy
+
+end module mpas_hash
Copied: trunk/mpas/src/framework/mpas_io_input.F (from rev 1113, branches/source_renaming/src/framework/mpas_io_input.F)
===================================================================
--- trunk/mpas/src/framework/mpas_io_input.F (rev 0)
+++ trunk/mpas/src/framework/mpas_io_input.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -0,0 +1,1614 @@
+module mpas_io_input
+
+ use mpas_grid_types
+ use mpas_dmpar
+ use mpas_block_decomp
+ use mpas_sort
+ use mpas_configure
+ use mpas_timekeeping
+
+
+#ifdef HAVE_ZOLTAN
+ use mpas_zoltan_interface
+#endif
+
+ integer, parameter :: STREAM_INPUT=1, STREAM_SFC=2, STREAM_RESTART=3
+
+ type io_input_object
+ character (len=1024) :: filename
+ integer :: rd_ncid
+ integer :: stream
+
+ integer :: time
+
+#include "io_input_obj_decls.inc"
+ end type io_input_object
+
+
+ interface mpas_io_input_field
+ module procedure mpas_io_input_field0d_real
+ module procedure mpas_io_input_field1d_real
+ module procedure mpas_io_input_field2d_real
+ module procedure mpas_io_input_field3d_real
+ module procedure mpas_io_input_field1d_integer
+ module procedure mpas_io_input_field2d_integer
+ module procedure mpas_io_input_field0d_char
+ module procedure mpas_io_input_field1d_char
+ end interface mpas_io_input_field
+
+ interface mpas_io_input_field_time
+ module procedure mpas_io_input_field0d_real_time
+ module procedure mpas_io_input_field1d_real_time
+ module procedure mpas_io_input_field2d_real_time
+ module procedure mpas_io_input_field3d_real_time
+ module procedure mpas_io_input_field1d_integer_time
+ module procedure mpas_io_input_field0d_char_time
+ module procedure mpas_io_input_field1d_char_time
+ end interface mpas_io_input_field_time
+
+ type (exchange_list), pointer :: sendCellList, recvCellList
+ type (exchange_list), pointer :: sendEdgeList, recvEdgeList
+ type (exchange_list), pointer :: sendVertexList, recvVertexList
+ type (exchange_list), pointer :: sendVertLevelList, recvVertLevelList
+
+ integer :: readCellStart, readCellEnd, nReadCells
+ integer :: readEdgeStart, readEdgeEnd, nReadEdges
+ integer :: readVertexStart, readVertexEnd, nReadVertices
+ integer :: readVertLevelStart, readVertLevelEnd, nReadVertLevels
+
+
+ contains
+
+
+ subroutine mpas_input_state_for_domain(domain)
+
+ implicit none
+
+ type (domain_type), pointer :: domain
+
+ integer :: i, j, k
+ type (io_input_object) :: input_obj
+#include "dim_decls.inc"
+
+ character (len=16) :: c_on_a_sphere
+ real (kind=RKIND) :: r_sphere_radius
+
+ type (field1dInteger) :: indexToCellIDField
+ type (field1dInteger) :: indexToEdgeIDField
+ type (field1dInteger) :: indexToVertexIDField
+ type (field1dInteger) :: nEdgesOnCellField
+ type (field2dInteger) :: cellsOnCellField
+ type (field2dInteger) :: edgesOnCellField
+ type (field2dInteger) :: verticesOnCellField
+ type (field2dInteger) :: cellsOnEdgeField
+ type (field2dInteger) :: cellsOnVertexField
+
+#ifdef HAVE_ZOLTAN
+#ifdef _MPI
+ type (field1dReal) :: xCellField, yCellField, zCellField
+ type (field1dReal) :: xEdgeField, yEdgeField, zEdgeField
+ type (field1dReal) :: xVertexField, yVertexField, zVertexField
+#endif
+#endif
+
+ type (field1DChar) :: xtime
+
+ integer, dimension(:), pointer :: indexToCellID_0Halo
+ integer, dimension(:), pointer :: nEdgesOnCell_0Halo
+ integer, dimension(:,:), pointer :: cellsOnCell_0Halo
+
+ integer, dimension(:,:), pointer :: edgesOnCell_2Halo
+ integer, dimension(:,:), pointer :: verticesOnCell_2Halo
+ integer, dimension(:,:), pointer :: cellsOnEdge_2Halo
+ integer, dimension(:,:), pointer :: cellsOnVertex_2Halo
+
+ integer, dimension(:,:), pointer :: cellIDSorted
+ integer, dimension(:,:), pointer :: edgeIDSorted
+ integer, dimension(:,:), pointer :: vertexIDSorted
+
+#ifdef HAVE_ZOLTAN
+#ifdef _MPI
+ real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell
+ real (kind=RKIND), dimension(:), pointer :: xEdge, yEdge, zEdge
+ real (kind=RKIND), dimension(:), pointer :: xVertex, yVertex, zVertex
+#endif
+#endif
+
+ integer, dimension(:), pointer :: local_cell_list, local_edge_list, local_vertex_list
+ integer, dimension(:), pointer :: local_vertlevel_list, needed_vertlevel_list
+ integer :: nlocal_edges, nlocal_vertices
+ type (exchange_list), pointer :: send1Halo, recv1Halo
+ type (exchange_list), pointer :: send2Halo, recv2Halo
+ type (graph) :: partial_global_graph_info
+ type (graph) :: block_graph_0Halo, block_graph_1Halo, block_graph_2Halo
+ integer :: ghostEdgeStart, ghostVertexStart
+
+ type (MPAS_Time_type) :: startTime
+ type (MPAS_Time_type) :: sliceTime
+ type (MPAS_TimeInterval_type) :: timeDiff
+ type (MPAS_TimeInterval_type) :: minTimeDiff
+ character(len=32) :: timeStamp
+
+ if (config_do_restart) then
+ input_obj % filename = trim(config_restart_name)
+ input_obj % stream = STREAM_RESTART
+ else
+ input_obj % filename = trim(config_input_name)
+ input_obj % stream = STREAM_INPUT
+ end if
+ call mpas_io_input_init(input_obj, domain % dminfo)
+
+
+ !
+ ! Read global number of cells/edges/vertices
+ !
+#include "read_dims.inc"
+
+ !
+ ! Determine the range of cells/edges/vertices that a processor will initially read
+ ! from the input file
+ !
+ call mpas_dmpar_get_index_range(domain % dminfo, 1, nCells, readCellStart, readCellEnd)
+ nReadCells = readCellEnd - readCellStart + 1
+
+ call mpas_dmpar_get_index_range(domain % dminfo, 1, nEdges, readEdgeStart, readEdgeEnd)
+ nReadEdges = readEdgeEnd - readEdgeStart + 1
+
+ call mpas_dmpar_get_index_range(domain % dminfo, 1, nVertices, readVertexStart, readVertexEnd)
+ nReadVertices = readVertexEnd - readVertexStart + 1
+
+ readVertLevelStart = 1
+ readVertLevelEnd = nVertLevels
+ nReadVertLevels = nVertLevels
+
+
+ !
+ ! Allocate and read fields that we will need in order to ultimately work out
+ ! which cells/edges/vertices are owned by each block, and which are ghost
+ !
+
+ ! Global cell indices
+ allocate(indexToCellIDField % ioinfo)
+ indexToCellIDField % ioinfo % fieldName = 'indexToCellID'
+ indexToCellIDField % ioinfo % start(1) = readCellStart
+ indexToCellIDField % ioinfo % count(1) = nReadCells
+ allocate(indexToCellIDField % array(nReadCells))
+ call mpas_io_input_field(input_obj, indexToCellIDField)
+
+#ifdef HAVE_ZOLTAN
+#ifdef _MPI
+ ! Cell x-coordinates (in 3d Cartesian space)
+ allocate(xCellField % ioinfo)
+ xCellField % ioinfo % fieldName = 'xCell'
+ xCellField % ioinfo % start(1) = readCellStart
+ xCellField % ioinfo % count(1) = nReadCells
+ allocate(xCellField % array(nReadCells))
+ call mpas_io_input_field(input_obj, xCellField)
+
+ ! Cell y-coordinates (in 3d Cartesian space)
+ allocate(yCellField % ioinfo)
+ yCellField % ioinfo % fieldName = 'yCell'
+ yCellField % ioinfo % start(1) = readCellStart
+ yCellField % ioinfo % count(1) = nReadCells
+ allocate(yCellField % array(nReadCells))
+ call mpas_io_input_field(input_obj, yCellField)
+
+ ! Cell z-coordinates (in 3d Cartesian space)
+ allocate(zCellField % ioinfo)
+ zCellField % ioinfo % fieldName = 'zCell'
+ zCellField % ioinfo % start(1) = readCellStart
+ zCellField % ioinfo % count(1) = nReadCells
+ allocate(zCellField % array(nReadCells))
+ call mpas_io_input_field(input_obj, zCellField)
+#endif
+#endif
+
+
+ ! Global edge indices
+ allocate(indexToEdgeIDField % ioinfo)
+ indexToEdgeIDField % ioinfo % fieldName = 'indexToEdgeID'
+ indexToEdgeIDField % ioinfo % start(1) = readEdgeStart
+ indexToEdgeIDField % ioinfo % count(1) = nReadEdges
+ allocate(indexToEdgeIDField % array(nReadEdges))
+ call mpas_io_input_field(input_obj, indexToEdgeIDField)
+
+#ifdef HAVE_ZOLTAN
+#ifdef _MPI
+ ! Edge x-coordinates (in 3d Cartesian space)
+ allocate(xEdgeField % ioinfo)
+ xEdgeField % ioinfo % fieldName = 'xEdge'
+ xEdgeField % ioinfo % start(1) = readEdgeStart
+ xEdgeField % ioinfo % count(1) = nReadEdges
+ allocate(xEdgeField % array(nReadEdges))
+ call mpas_io_input_field(input_obj, xEdgeField)
+
+ ! Edge y-coordinates (in 3d Cartesian space)
+ allocate(yEdgeField % ioinfo)
+ yEdgeField % ioinfo % fieldName = 'yEdge'
+ yEdgeField % ioinfo % start(1) = readEdgeStart
+ yEdgeField % ioinfo % count(1) = nReadEdges
+ allocate(yEdgeField % array(nReadEdges))
+ call mpas_io_input_field(input_obj, yEdgeField)
+
+ ! Edge z-coordinates (in 3d Cartesian space)
+ allocate(zEdgeField % ioinfo)
+ zEdgeField % ioinfo % fieldName = 'zEdge'
+ zEdgeField % ioinfo % start(1) = readEdgeStart
+ zEdgeField % ioinfo % count(1) = nReadEdges
+ allocate(zEdgeField % array(nReadEdges))
+ call mpas_io_input_field(input_obj, zEdgeField)
+#endif
+#endif
+
+ ! Global vertex indices
+ allocate(indexToVertexIDField % ioinfo)
+ indexToVertexIDField % ioinfo % fieldName = 'indexToVertexID'
+ indexToVertexIDField % ioinfo % start(1) = readVertexStart
+ indexToVertexIDField % ioinfo % count(1) = nReadVertices
+ allocate(indexToVertexIDField % array(nReadVertices))
+ call mpas_io_input_field(input_obj, indexToVertexIDField)
+
+#ifdef HAVE_ZOLTAN
+#ifdef _MPI
+ ! Vertex x-coordinates (in 3d Cartesian space)
+ allocate(xVertexField % ioinfo)
+ xVertexField % ioinfo % fieldName = 'xVertex'
+ xVertexField % ioinfo % start(1) = readVertexStart
+ xVertexField % ioinfo % count(1) = nReadVertices
+ allocate(xVertexField % array(nReadVertices))
+ call mpas_io_input_field(input_obj, xVertexField)
+
+ ! Vertex y-coordinates (in 3d Cartesian space)
+ allocate(yVertexField % ioinfo)
+ yVertexField % ioinfo % fieldName = 'yVertex'
+ yVertexField % ioinfo % start(1) = readVertexStart
+ yVertexField % ioinfo % count(1) = nReadVertices
+ allocate(yVertexField % array(nReadVertices))
+ call mpas_io_input_field(input_obj, yVertexField)
+
+ ! Vertex z-coordinates (in 3d Cartesian space)
+ allocate(zVertexField % ioinfo)
+ zVertexField % ioinfo % fieldName = 'zVertex'
+ zVertexField % ioinfo % start(1) = readVertexStart
+ zVertexField % ioinfo % count(1) = nReadVertices
+ allocate(zVertexField % array(nReadVertices))
+ call mpas_io_input_field(input_obj, zVertexField)
+#endif
+#endif
+
+ ! Number of cell/edges/vertices adjacent to each cell
+ allocate(nEdgesOnCellField % ioinfo)
+ nEdgesOnCellField % ioinfo % fieldName = 'nEdgesOnCell'
+ nEdgesOnCellField % ioinfo % start(1) = readCellStart
+ nEdgesOnCellField % ioinfo % count(1) = nReadCells
+ allocate(nEdgesOnCellField % array(nReadCells))
+ call mpas_io_input_field(input_obj, nEdgesOnCellField)
+
+ ! Global indices of cells adjacent to each cell
+ allocate(cellsOnCellField % ioinfo)
+ cellsOnCellField % ioinfo % fieldName = 'cellsOnCell'
+ cellsOnCellField % ioinfo % start(1) = 1
+ cellsOnCellField % ioinfo % start(2) = readCellStart
+ cellsOnCellField % ioinfo % count(1) = maxEdges
+ cellsOnCellField % ioinfo % count(2) = nReadCells
+ allocate(cellsOnCellField % array(maxEdges,nReadCells))
+ call mpas_io_input_field(input_obj, cellsOnCellField)
+
+ ! Global indices of edges adjacent to each cell
+ allocate(edgesOnCellField % ioinfo)
+ edgesOnCellField % ioinfo % fieldName = 'edgesOnCell'
+ edgesOnCellField % ioinfo % start(1) = 1
+ edgesOnCellField % ioinfo % start(2) = readCellStart
+ edgesOnCellField % ioinfo % count(1) = maxEdges
+ edgesOnCellField % ioinfo % count(2) = nReadCells
+ allocate(edgesOnCellField % array(maxEdges,nReadCells))
+ call mpas_io_input_field(input_obj, edgesOnCellField)
+
+ ! Global indices of vertices adjacent to each cell
+ allocate(verticesOnCellField % ioinfo)
+ verticesOnCellField % ioinfo % fieldName = 'verticesOnCell'
+ verticesOnCellField % ioinfo % start(1) = 1
+ verticesOnCellField % ioinfo % start(2) = readCellStart
+ verticesOnCellField % ioinfo % count(1) = maxEdges
+ verticesOnCellField % ioinfo % count(2) = nReadCells
+ allocate(verticesOnCellField % array(maxEdges,nReadCells))
+ call mpas_io_input_field(input_obj, verticesOnCellField)
+
+ ! Global indices of cells adjacent to each edge
+ ! used for determining which edges are owned by a block, where
+ ! iEdge is owned iff cellsOnEdge(1,iEdge) is an owned cell
+ allocate(cellsOnEdgeField % ioinfo)
+ cellsOnEdgeField % ioinfo % fieldName = 'cellsOnEdge'
+ cellsOnEdgeField % ioinfo % start(1) = 1
+ cellsOnEdgeField % ioinfo % start(2) = readEdgeStart
+ cellsOnEdgeField % ioinfo % count(1) = 2
+ cellsOnEdgeField % ioinfo % count(2) = nReadEdges
+ allocate(cellsOnEdgeField % array(2,nReadEdges))
+ call mpas_io_input_field(input_obj, cellsOnEdgeField)
+
+ ! Global indices of cells adjacent to each vertex
+ ! used for determining which vertices are owned by a block, where
+ ! iVtx is owned iff cellsOnVertex(1,iVtx) is an owned cell
+ allocate(cellsOnVertexField % ioinfo)
+ cellsOnVertexField % ioinfo % fieldName = 'cellsOnVertex'
+ cellsOnVertexField % ioinfo % start(1) = 1
+ cellsOnVertexField % ioinfo % start(2) = readVertexStart
+ cellsOnVertexField % ioinfo % count(1) = vertexDegree
+ cellsOnVertexField % ioinfo % count(2) = nReadVertices
+ allocate(cellsOnVertexField % array(vertexDegree,nReadVertices))
+ call mpas_io_input_field(input_obj, cellsOnVertexField)
+
+
+ !
+ ! Set up a graph derived data type describing the connectivity for the cells
+ ! that were read by this process
+ ! A partial description is passed to the block decomp module by each process,
+ ! and the block decomp module returns with a list of global cell indices
+ ! that belong to the block on this process
+ !
+ partial_global_graph_info % nVertices = nReadCells
+ partial_global_graph_info % nVerticesTotal = nCells
+ partial_global_graph_info % maxDegree = maxEdges
+ partial_global_graph_info % ghostStart = nVertices+1
+ allocate(partial_global_graph_info % vertexID(nReadCells))
+ allocate(partial_global_graph_info % nAdjacent(nReadCells))
+ allocate(partial_global_graph_info % adjacencyList(maxEdges, nReadCells))
+
+ partial_global_graph_info % vertexID(:) = indexToCellIDField % array(:)
+ partial_global_graph_info % nAdjacent(:) = nEdgesOnCellField % array(:)
+ partial_global_graph_info % adjacencyList(:,:) = cellsOnCellField % array(:,:)
+
+
+ ! TODO: Ensure (by renaming or exchanging) that initial cell range on each proc is contiguous
+ ! This situation may occur when reading a restart file with cells/edges/vertices written
+ ! in a scrambled order
+
+
+ ! Determine which cells are owned by this process
+ call mpas_block_decomp_cells_for_proc(domain % dminfo, partial_global_graph_info, local_cell_list)
+
+ deallocate(partial_global_graph_info % vertexID)
+ deallocate(partial_global_graph_info % nAdjacent)
+ deallocate(partial_global_graph_info % adjacencyList)
+
+
+ allocate(indexToCellID_0Halo(size(local_cell_list)))
+ allocate(nEdgesOnCell_0Halo(size(local_cell_list)))
+ allocate(cellsOnCell_0Halo(maxEdges, size(local_cell_list)))
+
+#ifdef HAVE_ZOLTAN
+#ifdef _MPI
+ allocate(xCell(size(local_cell_list)))
+ allocate(yCell(size(local_cell_list)))
+ allocate(zCell(size(local_cell_list)))
+#endif
+#endif
+
+ !
+ ! Now that each process has a list of cells that it owns, exchange cell connectivity
+ ! information between the processes that read info for a cell and those that own that cell
+ !
+ call mpas_dmpar_get_owner_list(domain % dminfo, &
+ size(indexToCellIDField % array), size(local_cell_list), &
+ indexToCellIDField % array, local_cell_list, &
+ sendCellList, recvCellList)
+
+ call mpas_dmpar_alltoall_field(domain % dminfo, indexToCellIDField % array, indexToCellID_0Halo, &
+ size(indexToCellIDField % array), size(local_cell_list), &
+ sendCellList, recvCellList)
+
+ call mpas_dmpar_alltoall_field(domain % dminfo, nEdgesOnCellField % array, nEdgesOnCell_0Halo, &
+ size(indexToCellIDField % array), size(local_cell_list), &
+ sendCellList, recvCellList)
+
+ call mpas_dmpar_alltoall_field(domain % dminfo, cellsOnCellField % array, cellsOnCell_0Halo, &
+ size(cellsOnCellField % array, 1), size(indexToCellIDField % array), size(local_cell_list), &
+ sendCellList, recvCellList)
+
+#ifdef HAVE_ZOLTAN
+#ifdef _MPI
+ call mpas_dmpar_alltoall_field(domain % dminfo, xCellField % array, xCell, &
+ size(xCellField % array), size(local_cell_list), &
+ sendCellList, recvCellList)
+
+ call mpas_dmpar_alltoall_field(domain % dminfo, yCellField % array, yCell, &
+ size(yCellField % array), size(local_cell_list), &
+ sendCellList, recvCellList)
+
+ call mpas_dmpar_alltoall_field(domain % dminfo, zCellField % array, zCell, &
+ size(zCellField % array), size(local_cell_list), &
+ sendCellList, recvCellList)
+#endif
+#endif
+
+
+ deallocate(sendCellList % list)
+ deallocate(sendCellList)
+ deallocate(recvCellList % list)
+ deallocate(recvCellList)
+
+
+
+ !
+ ! Build a graph of cell connectivity based on cells owned by this process
+ !
+ block_graph_0Halo % nVerticesTotal = size(local_cell_list)
+ block_graph_0Halo % nVertices = size(local_cell_list)
+ block_graph_0Halo % maxDegree = maxEdges
+ block_graph_0Halo % ghostStart = size(local_cell_list) + 1
+ allocate(block_graph_0Halo % vertexID(size(local_cell_list)))
+ allocate(block_graph_0Halo % nAdjacent(size(local_cell_list)))
+ allocate(block_graph_0Halo % adjacencyList(maxEdges, size(local_cell_list)))
+
+ block_graph_0Halo % vertexID(:) = indexToCellID_0Halo(:)
+ block_graph_0Halo % nAdjacent(:) = nEdgesOnCell_0Halo(:)
+ block_graph_0Halo % adjacencyList(:,:) = cellsOnCell_0Halo(:,:)
+
+ ! Get back a graph describing the owned cells plus the cells in the 1-halo
+ call mpas_block_decomp_add_halo(domain % dminfo, block_graph_0Halo, block_graph_1Halo)
+
+
+ !
+ ! Work out exchange lists for 1-halo and exchange cell information for 1-halo
+ !
+ call mpas_dmpar_get_owner_list(domain % dminfo, &
+ block_graph_0Halo % nVertices, block_graph_1Halo % nVerticesTotal, &
+ block_graph_0Halo % vertexID, block_graph_1Halo % vertexID, &
+ send1Halo, recv1Halo)
+
+ call mpas_dmpar_alltoall_field(domain % dminfo, block_graph_0Halo % vertexID, block_graph_1Halo % vertexID, &
+ block_graph_0Halo % nVertices, block_graph_1Halo % nVerticesTotal, &
+ send1Halo, recv1Halo)
+
+ call mpas_dmpar_alltoall_field(domain % dminfo, block_graph_0Halo % nAdjacent, block_graph_1Halo % nAdjacent, &
+ block_graph_0Halo % nVertices, block_graph_1Halo % nVerticesTotal, &
+ send1Halo, recv1Halo)
+
+ call mpas_dmpar_alltoall_field(domain % dminfo, block_graph_0Halo % adjacencyList, block_graph_1Halo % adjacencyList, &
+ block_graph_0Halo % maxDegree, block_graph_0Halo % nVertices, block_graph_1Halo % nVerticesTotal, &
+ send1Halo, recv1Halo)
+
+
+ !
+ ! Work out exchange lists for 2-halo and exchange cell information for 2-halo
+ !
+ block_graph_1Halo % nVertices = block_graph_1Halo % nVerticesTotal
+ block_graph_1Halo % ghostStart = block_graph_1Halo % nVerticesTotal + 1
+
+ ! Get back a graph describing the owned and 1-halo cells plus the cells in the 2-halo
+ call mpas_block_decomp_add_halo(domain % dminfo, block_graph_1Halo, block_graph_2Halo)
+
+ block_graph_2Halo % nVertices = block_graph_0Halo % nVertices
+ block_graph_2Halo % ghostStart = block_graph_2Halo % nVertices + 1
+
+#ifdef HAVE_ZOLTAN
+#ifdef _MPI
+ !! For now, only use Zoltan with MPI
+ !! Zoltan initialization
+ call mpas_zoltan_start()
+
+ !! Zoltan hook for cells
+ call mpas_zoltan_order_loc_hsfc_cells(block_graph_2Halo%nVertices,block_graph_2Halo%VertexID,3,xCell,yCell,zCell)
+#endif
+#endif
+
+ call mpas_dmpar_get_owner_list(domain % dminfo, &
+ block_graph_0Halo % nVertices, block_graph_2Halo % nVerticesTotal, &
+ block_graph_0Halo % vertexID, block_graph_2Halo % vertexID, &
+ send2Halo, recv2Halo)
+
+ call mpas_dmpar_alltoall_field(domain % dminfo, block_graph_0Halo % vertexID, block_graph_2Halo % vertexID, &
+ block_graph_0Halo % nVertices, block_graph_2Halo % nVerticesTotal, &
+ send2Halo, recv2Halo)
+
+ call mpas_dmpar_alltoall_field(domain % dminfo, block_graph_0Halo % nAdjacent, block_graph_2Halo % nAdjacent, &
+ block_graph_0Halo % nVertices, block_graph_2Halo % nVerticesTotal, &
+ send2Halo, recv2Halo)
+
+ call mpas_dmpar_alltoall_field(domain % dminfo, block_graph_0Halo % adjacencyList, block_graph_2Halo % adjacencyList, &
+ block_graph_0Halo % maxDegree, block_graph_0Halo % nVertices, block_graph_2Halo % nVerticesTotal, &
+ send2Halo, recv2Halo)
+
+
+
+ !
+ ! Knowing which cells are in block and the 2-halo, we can exchange lists of which edges are
+ ! on each cell and which vertices are on each cell from the processes that read these
+ ! fields for each cell to the processes that own the cells
+ !
+ allocate(edgesOnCell_2Halo(maxEdges, block_graph_2Halo % nVerticesTotal))
+ allocate(verticesOnCell_2Halo(maxEdges, block_graph_2Halo % nVerticesTotal))
+
+ call mpas_dmpar_get_owner_list(domain % dminfo, &
+ size(indexToCellIDField % array), block_graph_2Halo % nVerticesTotal, &
+ indexToCellIDField % array, block_graph_2Halo % vertexID, &
+ sendCellList, recvCellList)
+
+ call mpas_dmpar_alltoall_field(domain % dminfo, edgesOnCellField % array, edgesOnCell_2Halo, &
+ maxEdges, nReadCells, block_graph_2Halo % nVerticesTotal, &
+ sendCellList, recvCellList)
+
+ call mpas_dmpar_alltoall_field(domain % dminfo, verticesOnCellField % array, verticesOnCell_2Halo, &
+ maxEdges, nReadCells, block_graph_2Halo % nVerticesTotal, &
+ sendCellList, recvCellList)
+
+
+ !
+ ! Get a list of which edges and vertices are adjacent to cells (including halo cells) in block
+ !
+ call mpas_block_decomp_all_edges_in_block(maxEdges, block_graph_2Halo % nVerticesTotal, block_graph_2Halo % nAdjacent, &
+ edgesOnCell_2Halo, nlocal_edges, local_edge_list)
+ call mpas_block_decomp_all_edges_in_block(maxEdges, block_graph_2Halo % nVerticesTotal, block_graph_2Halo % nAdjacent, &
+ verticesOnCell_2Halo, nlocal_vertices, local_vertex_list)
+
+ call mpas_dmpar_get_owner_list(domain % dminfo, &
+ size(indexToEdgeIDField % array), nlocal_edges, &
+ indexToEdgeIDField % array, local_edge_list, &
+ sendEdgeList, recvEdgeList)
+
+ call mpas_dmpar_get_owner_list(domain % dminfo, &
+ size(indexToVertexIDField % array), nlocal_vertices, &
+ indexToVertexIDField % array, local_vertex_list, &
+ sendVertexList, recvVertexList)
+
+
+
+ !
+ ! Work out which edges and vertices are owned by this process, and which are ghost
+ !
+ allocate(cellsOnEdge_2Halo(2,nlocal_edges))
+ allocate(cellsOnVertex_2Halo(vertexDegree,nlocal_vertices))
+
+ call mpas_dmpar_alltoall_field(domain % dminfo, cellsOnEdgeField % array, cellsOnEdge_2Halo, &
+ 2, size(cellsOnEdgeField % array, 2), nlocal_edges, &
+ sendEdgeList, recvEdgeList)
+
+ call mpas_dmpar_alltoall_field(domain % dminfo, cellsOnVertexField % array, cellsOnVertex_2Halo, &
+ vertexDegree, size(cellsOnVertexField % array, 2), nlocal_vertices, &
+ sendVertexList, recvVertexList)
+
+
+ call mpas_block_decomp_partitioned_edge_list(block_graph_2Halo % nVertices, &
+ block_graph_2Halo % vertexID(1:block_graph_2Halo % nVertices), &
+ 2, nlocal_edges, cellsOnEdge_2Halo, local_edge_list, ghostEdgeStart)
+ call mpas_block_decomp_partitioned_edge_list(block_graph_2Halo % nVertices, &
+ block_graph_2Halo % vertexID(1:block_graph_2Halo % nVertices), &
+ vertexDegree, nlocal_vertices, cellsOnVertex_2Halo, local_vertex_list, ghostVertexStart)
+
+
+ ! At this point, local_edge_list(1;ghostEdgeStart-1) contains all of the owned edges for this block
+ ! and local_edge_list(ghostEdgeStart:nlocal_edges) contains all of the ghost edges
+
+ ! At this point, local_vertex_list(1;ghostVertexStart-1) contains all of the owned vertices for this block
+ ! and local_vertex_list(ghostVertexStart:nlocal_vertices) contains all of the ghost vertices
+
+ ! Also, at this point, block_graph_2Halo % vertexID(1:block_graph_2Halo%nVertices) contains all of the owned
+ ! cells for this block, and block_graph_2Halo % vertexID(block_graph_2Halo%nVertices+1:block_graph_2Halo%nVerticesTotal)
+ ! contains all of the ghost cells
+
+
+ deallocate(sendEdgeList % list)
+ deallocate(sendEdgeList)
+ deallocate(recvEdgeList % list)
+ deallocate(recvEdgeList)
+
+ deallocate(sendVertexList % list)
+ deallocate(sendVertexList)
+ deallocate(recvVertexList % list)
+ deallocate(recvVertexList)
+
+#ifdef HAVE_ZOLTAN
+#ifdef _MPI
+ allocate(xEdge(nlocal_edges))
+ allocate(yEdge(nlocal_edges))
+ allocate(zEdge(nlocal_edges))
+ allocate(xVertex(nlocal_vertices))
+ allocate(yVertex(nlocal_vertices))
+ allocate(zVertex(nlocal_vertices))
+#endif
+#endif
+
+ !
+ ! Knowing which edges/vertices are owned by this block and which are actually read
+ ! from the input or restart file, we can build exchange lists to perform
+ ! all-to-all field exchanges from process that reads a field to the processes that
+ ! need them
+ !
+ call mpas_dmpar_get_owner_list(domain % dminfo, &
+ size(indexToEdgeIDField % array), nlocal_edges, &
+ indexToEdgeIDField % array, local_edge_list, &
+ sendEdgeList, recvEdgeList)
+
+ call mpas_dmpar_get_owner_list(domain % dminfo, &
+ size(indexToVertexIDField % array), nlocal_vertices, &
+ indexToVertexIDField % array, local_vertex_list, &
+ sendVertexList, recvVertexList)
+
+#ifdef HAVE_ZOLTAN
+#ifdef _MPI
+ call mpas_dmpar_alltoall_field(domain % dminfo, xEdgeField % array, xEdge, &
+ size(xEdgeField % array), nlocal_edges, &
+ sendEdgeList, recvEdgeList)
+ call mpas_dmpar_alltoall_field(domain % dminfo, yEdgeField % array, yEdge, &
+ size(yEdgeField % array), nlocal_edges, &
+ sendEdgeList, recvEdgeList)
+ call mpas_dmpar_alltoall_field(domain % dminfo, zEdgeField % array, zEdge, &
+ size(zEdgeField % array), nlocal_edges, &
+ sendEdgeList, recvEdgeList)
+
+ call mpas_dmpar_alltoall_field(domain % dminfo, xVertexField % array, xVertex, &
+ size(xVertexField % array), nlocal_vertices, &
+ sendVertexList, recvVertexList)
+ call mpas_dmpar_alltoall_field(domain % dminfo, yVertexField % array, yVertex, &
+ size(yVertexField % array), nlocal_vertices, &
+ sendVertexList, recvVertexList)
+ call mpas_dmpar_alltoall_field(domain % dminfo, zVertexField % array, zVertex, &
+ size(zVertexField % array), nlocal_vertices, &
+ sendVertexList, recvVertexList)
+ !!!!!!!!!!!!!!!!!!
+ !! Reorder edges
+ !!!!!!!!!!!!!!!!!!
+ call mpas_zoltan_order_loc_hsfc_edges(ghostEdgeStart-1,local_edge_list,3,xEdge,yEdge,zEdge)
+ !!!!!!!!!!!!!!!!!!
+
+ !!!!!!!!!!!!!!!!!!
+ !! Reorder vertices
+ !!!!!!!!!!!!!!!!!!
+ call mpas_zoltan_order_loc_hsfc_verts(ghostVertexStart-1,local_vertex_list,3,xVertex,yVertex,zVertex)
+ !!!!!!!!!!!!!!!!!!
+
+ deallocate(sendEdgeList % list)
+ deallocate(sendEdgeList)
+ deallocate(recvEdgeList % list)
+ deallocate(recvEdgeList)
+
+ deallocate(sendVertexList % list)
+ deallocate(sendVertexList)
+ deallocate(recvVertexList % list)
+ deallocate(recvVertexList)
+
+ !
+ ! Knowing which edges/vertices are owned by this block and which are actually read
+ ! from the input or restart file, we can build exchange lists to perform
+ ! all-to-all field exchanges from process that reads a field to the processes that
+ ! need them
+ !
+ call mpas_dmpar_get_owner_list(domain % dminfo, &
+ size(indexToEdgeIDField % array), nlocal_edges, &
+ indexToEdgeIDField % array, local_edge_list, &
+ sendEdgeList, recvEdgeList)
+
+ call mpas_dmpar_get_owner_list(domain % dminfo, &
+ size(indexToVertexIDField % array), nlocal_vertices, &
+ indexToVertexIDField % array, local_vertex_list, &
+ sendVertexList, recvVertexList)
+
+#endif
+#endif
+
+ !
+ ! Build ownership and exchange lists for vertical levels
+ ! Essentially, process 0 owns all vertical levels when reading and writing,
+ ! and it distributes them or gathers them to/from all other processes
+ !
+ if (domain % dminfo % my_proc_id == 0) then
+ allocate(local_vertlevel_list(nVertLevels))
+ do i=1,nVertLevels
+ local_vertlevel_list(i) = i
+ end do
+ else
+ allocate(local_vertlevel_list(0))
+ end if
+ allocate(needed_vertlevel_list(nVertLevels))
+ do i=1,nVertLevels
+ needed_vertlevel_list(i) = i
+ end do
+
+ call mpas_dmpar_get_owner_list(domain % dminfo, &
+ size(local_vertlevel_list), size(needed_vertlevel_list), &
+ local_vertlevel_list, needed_vertlevel_list, &
+ sendVertLevelList, recvVertLevelList)
+
+ deallocate(local_vertlevel_list)
+ deallocate(needed_vertlevel_list)
+
+
+ !
+ ! Read and distribute all fields given ownership lists and exchange lists (maybe already in block?)
+ !
+ allocate(domain % blocklist)
+
+ nCells = block_graph_2Halo % nVerticesTotal
+ nEdges = nlocal_edges
+ nVertices = nlocal_vertices
+
+ call mpas_allocate_block(domain % blocklist, domain, &
+#include "dim_dummy_args.inc"
+ )
+
+ !
+ ! Read attributes
+ !
+ call mpas_io_input_get_att_text(input_obj, 'on_a_sphere', c_on_a_sphere)
+ call mpas_io_input_get_att_real(input_obj, 'sphere_radius', r_sphere_radius)
+ if (index(c_on_a_sphere, 'YES') /= 0) then
+ domain % blocklist % mesh % on_a_sphere = .true.
+ else
+ domain % blocklist % mesh % on_a_sphere = .false.
+ end if
+ domain % blocklist % mesh % sphere_radius = r_sphere_radius
+
+ if (.not. config_do_restart) then
+ input_obj % time = 1
+ else
+ input_obj % time = 1
+
+ !
+ ! If doing a restart, we need to decide which time slice to read from the
+ ! restart file
+ !
+ if (input_obj % rdLocalTime <= 0) then
+ write(0,*) 'Error: Couldn''t find any times in restart file.'
+ call mpas_dmpar_abort(domain % dminfo)
+ end if
+ if (domain % dminfo % my_proc_id == IO_NODE) then
+ allocate(xtime % ioinfo)
+ xtime % ioinfo % start(1) = 1
+ xtime % ioinfo % count(1) = input_obj % rdLocalTime
+ allocate(xtime % array(input_obj % rdLocalTime))
+
+ xtime % ioinfo % fieldName = 'xtime'
+ call mpas_io_input_field(input_obj, xtime)
+
+ call mpas_set_timeInterval(interval=minTimeDiff, DD=10000)
+ call mpas_set_time(curr_time=startTime, dateTimeString=config_start_time)
+
+ do i=1,input_obj % rdLocalTime
+ call mpas_set_time(curr_time=sliceTime, dateTimeString=xtime % array(i))
+ timeDiff = abs(sliceTime - startTime)
+ if (timeDiff < minTimeDiff) then
+ minTimeDiff = timeDiff
+ input_obj % time = i
+ end if
+ end do
+
+ timeStamp = xtime % array(input_obj % time)
+
+ deallocate(xtime % ioinfo)
+ deallocate(xtime % array)
+ end if
+
+ call mpas_dmpar_bcast_int(domain % dminfo, input_obj % time)
+ call mpas_dmpar_bcast_char(domain % dminfo, timeStamp)
+
+ write(0,*) 'Restarting model from time ', timeStamp
+
+ end if
+
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Do the actual work of reading all fields in from the input or restart file
+ ! For each field:
+ ! 1) Each process reads a contiguous range of cell/edge/vertex indices, which
+ ! may not correspond with the cells/edges/vertices that are owned by the
+ ! process
+ ! 2) All processes then send the global indices that were read to the
+ ! processes that own those indices based on
+ ! {send,recv}{Cell,Edge,Vertex,VertLevel}List
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ call mpas_read_and_distribute_fields(domain % dminfo, input_obj, domain % blocklist, &
+ readCellStart, nReadCells, readEdgeStart, nReadEdges, readVertexStart, nReadVertices, &
+ readVertLevelStart, nReadVertLevels, &
+ sendCellList, recvCellList, sendEdgeList, recvEdgeList, sendVertexList, recvVertexList, &
+ sendVertLevelList, recvVertLevelList)
+
+
+ call mpas_io_input_finalize(input_obj, domain % dminfo)
+
+
+ !
+ ! Rename vertices in cellsOnCell, edgesOnCell, etc. to local indices
+ !
+ allocate(cellIDSorted(2,domain % blocklist % mesh % nCells))
+ allocate(edgeIDSorted(2,domain % blocklist % mesh % nEdges))
+ allocate(vertexIDSorted(2,domain % blocklist % mesh % nVertices))
+
+ do i=1,domain % blocklist % mesh % nCells
+ cellIDSorted(1,i) = domain % blocklist % mesh % indexToCellID % array(i)
+ cellIDSorted(2,i) = i
+ end do
+ call quicksort(block_graph_2Halo % nVerticesTotal, cellIDSorted)
+
+ do i=1,domain % blocklist % mesh % nEdges
+ edgeIDSorted(1,i) = domain % blocklist % mesh % indexToEdgeID % array(i)
+ edgeIDSorted(2,i) = i
+ end do
+ call quicksort(nlocal_edges, edgeIDSorted)
+
+ do i=1,domain % blocklist % mesh % nVertices
+ vertexIDSorted(1,i) = domain % blocklist % mesh % indexToVertexID % array(i)
+ vertexIDSorted(2,i) = i
+ end do
+ call quicksort(nlocal_vertices, vertexIDSorted)
+
+
+ do i=1,domain % blocklist % mesh % nCells
+ do j=1,domain % blocklist % mesh % nEdgesOnCell % array(i)
+
+ k = mpas_binary_search(cellIDSorted, 2, 1, domain % blocklist % mesh % nCells, &
+ domain % blocklist % mesh % cellsOnCell % array(j,i))
+ if (k <= domain % blocklist % mesh % nCells) then
+ domain % blocklist % mesh % cellsOnCell % array(j,i) = cellIDSorted(2,k)
+ else
+ domain % blocklist % mesh % cellsOnCell % array(j,i) = domain % blocklist % mesh % nCells + 1
+! domain % blocklist % mesh % cellsOnCell % array(j,i) = 0
+ end if
+
+ k = mpas_binary_search(edgeIDSorted, 2, 1, domain % blocklist % mesh % nEdges, &
+ domain % blocklist % mesh % edgesOnCell % array(j,i))
+ if (k <= domain % blocklist % mesh % nEdges) then
+ domain % blocklist % mesh % edgesOnCell % array(j,i) = edgeIDSorted(2,k)
+ else
+ domain % blocklist % mesh % edgesOnCell % array(j,i) = domain % blocklist % mesh % nEdges + 1
+! domain % blocklist % mesh % edgesOnCell % array(j,i) = 0
+ end if
+
+ k = mpas_binary_search(vertexIDSorted, 2, 1, domain % blocklist % mesh % nVertices, &
+ domain % blocklist % mesh % verticesOnCell % array(j,i))
+ if (k <= domain % blocklist % mesh % nVertices) then
+ domain % blocklist % mesh % verticesOnCell % array(j,i) = vertexIDSorted(2,k)
+ else
+ domain % blocklist % mesh % verticesOnCell % array(j,i) = domain % blocklist % mesh % nVertices + 1
+! domain % blocklist % mesh % verticesOnCell % array(j,i) = 0
+ end if
+
+ end do
+ end do
+
+ do i=1,domain % blocklist % mesh % nEdges
+ do j=1,2
+
+ k = mpas_binary_search(cellIDSorted, 2, 1, domain % blocklist % mesh % nCells, &
+ domain % blocklist % mesh % cellsOnEdge % array(j,i))
+ if (k <= domain % blocklist % mesh % nCells) then
+ domain % blocklist % mesh % cellsOnEdge % array(j,i) = cellIDSorted(2,k)
+ else
+ domain % blocklist % mesh % cellsOnEdge % array(j,i) = domain % blocklist % mesh % nCells + 1
+! domain % blocklist % mesh % cellsOnEdge % array(j,i) = 0
+ end if
+
+ k = mpas_binary_search(vertexIDSorted, 2, 1, domain % blocklist % mesh % nVertices, &
+ domain % blocklist % mesh % verticesOnEdge % array(j,i))
+ if (k <= domain % blocklist % mesh % nVertices) then
+ domain % blocklist % mesh % verticesOnEdge % array(j,i) = vertexIDSorted(2,k)
+ else
+ domain % blocklist % mesh % verticesOnEdge % array(j,i) = domain % blocklist % mesh % nVertices + 1
+! domain % blocklist % mesh % verticesOnEdge % array(j,i) = 0
+ end if
+
+ end do
+
+ do j=1,domain % blocklist % mesh % nEdgesOnEdge % array(i)
+
+ k = mpas_binary_search(edgeIDSorted, 2, 1, domain % blocklist % mesh % nEdges, &
+ domain % blocklist % mesh % edgesOnEdge % array(j,i))
+ if (k <= domain % blocklist % mesh % nEdges) then
+ domain % blocklist % mesh % edgesOnEdge % array(j,i) = edgeIDSorted(2,k)
+ else
+ domain % blocklist % mesh % edgesOnEdge % array(j,i) = domain % blocklist % mesh % nEdges + 1
+! domain % blocklist % mesh % edgesOnEdge % array(j,i) = 0
+ end if
+
+ end do
+ end do
+
+ do i=1,domain % blocklist % mesh % nVertices
+ do j=1,vertexDegree
+
+ k = mpas_binary_search(cellIDSorted, 2, 1, domain % blocklist % mesh % nCells, &
+ domain % blocklist % mesh % cellsOnVertex % array(j,i))
+ if (k <= domain % blocklist % mesh % nCells) then
+ domain % blocklist % mesh % cellsOnVertex % array(j,i) = cellIDSorted(2,k)
+ else
+ domain % blocklist % mesh % cellsOnVertex % array(j,i) = domain % blocklist % mesh % nCells + 1
+! domain % blocklist % mesh % cellsOnVertex % array(j,i) = 0
+ end if
+
+ k = mpas_binary_search(edgeIDSorted, 2, 1, domain % blocklist % mesh % nEdges, &
+ domain % blocklist % mesh % edgesOnVertex % array(j,i))
+ if (k <= domain % blocklist % mesh % nEdges) then
+ domain % blocklist % mesh % edgesOnVertex % array(j,i) = edgeIDSorted(2,k)
+ else
+ domain % blocklist % mesh % edgesOnVertex % array(j,i) = domain % blocklist % mesh % nEdges + 1
+! domain % blocklist % mesh % edgesOnVertex % array(j,i) = 0
+ end if
+
+ end do
+ end do
+
+ deallocate(cellIDSorted)
+ deallocate(edgeIDSorted)
+ deallocate(vertexIDSorted)
+
+
+ !
+ ! Work out halo exchange lists for cells, edges, and vertices
+ !
+ call mpas_dmpar_get_owner_list(domain % dminfo, &
+ block_graph_2Halo % nVertices, block_graph_2Halo % nVerticesTotal, &
+ block_graph_2Halo % vertexID(1:block_graph_2Halo % nVertices), block_graph_2Halo % vertexID, &
+ domain % blocklist % parinfo % cellsToSend, domain % blocklist % parinfo % cellsToRecv)
+
+ call mpas_dmpar_get_owner_list(domain % dminfo, &
+ ghostEdgeStart-1, nlocal_edges, &
+ local_edge_list(1:ghostEdgeStart-1), local_edge_list, &
+ domain % blocklist % parinfo % edgesToSend, domain % blocklist % parinfo % edgesToRecv)
+
+ call mpas_dmpar_get_owner_list(domain % dminfo, &
+ ghostVertexStart-1, nlocal_vertices, &
+ local_vertex_list(1:ghostVertexStart-1), local_vertex_list, &
+ domain % blocklist % parinfo % verticesToSend, domain % blocklist % parinfo % verticesToRecv)
+
+ domain % blocklist % mesh % nCellsSolve = block_graph_2Halo % nVertices
+ domain % blocklist % mesh % nEdgesSolve = ghostEdgeStart-1
+ domain % blocklist % mesh % nVerticesSolve = ghostVertexStart-1
+ domain % blocklist % mesh % nVertLevelsSolve = domain % blocklist % mesh % nVertLevels ! No vertical decomp yet...
+
+
+ !
+ ! Deallocate fields, graphs, and other memory
+ !
+ deallocate(indexToCellIDField % ioinfo)
+ deallocate(indexToCellIDField % array)
+#ifdef HAVE_ZOLTAN
+#ifdef _MPI
+ deallocate(xCellField % ioinfo)
+ deallocate(xCellField % array)
+ deallocate(yCellField % ioinfo)
+ deallocate(yCellField % array)
+ deallocate(zCellField % ioinfo)
+ deallocate(zCellField % array)
+#endif
+#endif
+ deallocate(indexToEdgeIDField % ioinfo)
+ deallocate(indexToEdgeIDField % array)
+ deallocate(indexToVertexIDField % ioinfo)
+ deallocate(indexToVertexIDField % array)
+ deallocate(cellsOnCellField % ioinfo)
+ deallocate(cellsOnCellField % array)
+ deallocate(edgesOnCellField % ioinfo)
+ deallocate(edgesOnCellField % array)
+ deallocate(verticesOnCellField % ioinfo)
+ deallocate(verticesOnCellField % array)
+ deallocate(cellsOnEdgeField % ioinfo)
+ deallocate(cellsOnEdgeField % array)
+ deallocate(cellsOnVertexField % ioinfo)
+ deallocate(cellsOnVertexField % array)
+ deallocate(cellsOnCell_0Halo)
+ deallocate(nEdgesOnCell_0Halo)
+ deallocate(indexToCellID_0Halo)
+ deallocate(cellsOnEdge_2Halo)
+ deallocate(cellsOnVertex_2Halo)
+ deallocate(edgesOnCell_2Halo)
+ deallocate(verticesOnCell_2Halo)
+ deallocate(block_graph_0Halo % vertexID)
+ deallocate(block_graph_0Halo % nAdjacent)
+ deallocate(block_graph_0Halo % adjacencyList)
+#ifdef HAVE_ZOLTAN
+#ifdef _MPI
+ deallocate(xCell)
+ deallocate(yCell)
+ deallocate(zCell)
+#endif
+#endif
+ end subroutine mpas_input_state_for_domain
+
+
+ subroutine mpas_read_and_distribute_fields(dminfo, input_obj, block, &
+ readCellsStart, readCellsCount, &
+ readEdgesStart, readEdgesCount, &
+ readVerticesStart, readVerticesCount, &
+ readVertLevelsStart, readVertLevelsCount, &
+ sendCellsList, recvCellsList, &
+ sendEdgesList, recvEdgesList, &
+ sendVerticesList, recvVerticesList, &
+ sendVertLevelsList, recvVertLevelsList)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ type (io_input_object), intent(in) :: input_obj
+ type (block_type), intent(inout) :: block
+ integer, intent(in) :: readCellsStart, readCellsCount, readEdgesStart, readEdgesCount, readVerticesStart, readVerticesCount
+ integer, intent(in) :: readVertLevelsStart, readVertLevelsCount
+ type (exchange_list), pointer :: sendCellsList, recvCellsList
+ type (exchange_list), pointer :: sendEdgesList, recvEdgesList
+ type (exchange_list), pointer :: sendVerticesList, recvVerticesList
+ type (exchange_list), pointer :: sendVertLevelsList, recvVertLevelsList
+
+ type (field1dInteger) :: int1d
+ type (field2dInteger) :: int2d
+ type (field0dReal) :: real0d
+ type (field1dReal) :: real1d
+ type (field2dReal) :: real2d
+ type (field3dReal) :: real3d
+ type (field0dChar) :: char0d
+ type (field1dChar) :: char1d
+
+ integer :: i1, i2, i3, i4
+
+ integer, dimension(:), pointer :: super_int1d
+ integer, dimension(:,:), pointer :: super_int2d
+ real (kind=RKIND) :: super_real0d
+ real (kind=RKIND), dimension(:), pointer :: super_real1d
+ real (kind=RKIND), dimension(:,:), pointer :: super_real2d
+ real (kind=RKIND), dimension(:,:,:), pointer :: super_real3d
+ character (len=64) :: super_char0d
+ character (len=64), dimension(:), pointer :: super_char1d
+
+ integer :: i, k
+
+#include "nondecomp_dims.inc"
+
+ allocate(int1d % ioinfo)
+ allocate(int2d % ioinfo)
+ allocate(real0d % ioinfo)
+ allocate(real1d % ioinfo)
+ allocate(real2d % ioinfo)
+ allocate(real3d % ioinfo)
+ allocate(char0d % ioinfo)
+ allocate(char1d % ioinfo)
+
+
+#include "io_input_fields.inc"
+
+#include "nondecomp_dims_dealloc.inc"
+
+ end subroutine mpas_read_and_distribute_fields
+
+
+
+ subroutine mpas_io_input_init(input_obj, dminfo)
+
+ implicit none
+
+ type (io_input_object), intent(inout) :: input_obj
+ type (dm_info), intent(in) :: dminfo
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+
+
+#ifdef OFFSET64BIT
+ nferr = nf_open(trim(input_obj % filename), ior(NF_SHARE,NF_64BIT_OFFSET), input_obj % rd_ncid)
+#else
+ nferr = nf_open(trim(input_obj % filename), NF_SHARE, input_obj % rd_ncid)
+#endif
+
+ if (nferr /= NF_NOERR) then
+ write(0,*) ' '
+ if (input_obj % stream == STREAM_RESTART) then
+ write(0,*) 'Error opening restart file ''', trim(input_obj % filename), ''''
+ else if (input_obj % stream == STREAM_INPUT) then
+ write(0,*) 'Error opening input file ''', trim(input_obj % filename), ''''
+ else if (input_obj % stream == STREAM_SFC) then
+ write(0,*) 'Error opening sfc file ''', trim(input_obj % filename), ''''
+ end if
+ write(0,*) ' '
+ call mpas_dmpar_abort(dminfo)
+ end if
+
+#include "netcdf_read_ids.inc"
+
+ end subroutine mpas_io_input_init
+
+
+ subroutine mpas_io_input_get_dimension(input_obj, dimname, dimsize)
+
+ implicit none
+
+ type (io_input_object), intent(in) :: input_obj
+ character (len=*), intent(in) :: dimname
+ integer, intent(out) :: dimsize
+
+#include "get_dimension_by_name.inc"
+
+ end subroutine mpas_io_input_get_dimension
+
+
+ subroutine mpas_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 mpas_io_input_get_att_real
+
+
+ subroutine mpas_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 mpas_io_input_get_att_text
+
+
+ subroutine mpas_io_input_field0d_real(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 mpas_io_input_field0d_real
+
+
+ subroutine mpas_io_input_field1d_real(input_obj, field)
+
+ implicit none
+
+ type (io_input_object), intent(in) :: input_obj
+ type (field1dReal), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(1) :: start1, count1
+
+ start1(1) = field % ioinfo % start(1)
+ count1(1) = field % ioinfo % count(1)
+
+ !
+ ! Special case: we may want to read the xtime variable across the
+ ! time dimension as a 1d array.
+ !
+ if (trim(field % ioinfo % fieldName) == 'xtime') then
+ varID = input_obj % rdVarIDxtime
+ end if
+
+#include "input_field1dreal.inc"
+
+#if (RKIND == 8)
+ nferr = nf_get_vara_double(input_obj % rd_ncid, varID, start1, count1, field % array)
+#else
+ nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start1, count1, field % array)
+#endif
+
+ end subroutine mpas_io_input_field1d_real
+
+
+ subroutine mpas_io_input_field2d_real(input_obj, field)
+
+ implicit none
+
+ type (io_input_object), intent(in) :: input_obj
+ type (field2dReal), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(2) :: start2, count2
+
+ start2(1) = field % ioinfo % start(1)
+ start2(2) = field % ioinfo % start(2)
+ count2(1) = field % ioinfo % count(1)
+ count2(2) = field % ioinfo % count(2)
+
+#include "input_field2dreal.inc"
+
+#if (RKIND == 8)
+ nferr = nf_get_vara_double(input_obj % rd_ncid, varID, start2, count2, field % array)
+#else
+ nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start2, count2, field % array)
+#endif
+
+ end subroutine mpas_io_input_field2d_real
+
+
+ subroutine mpas_io_input_field3d_real(input_obj, field)
+
+ implicit none
+
+ type (io_input_object), intent(in) :: input_obj
+ type (field3dReal), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(3) :: start3, count3
+
+ start3(1) = field % ioinfo % start(1)
+ start3(2) = field % ioinfo % start(2)
+ start3(3) = field % ioinfo % start(3)
+ count3(1) = field % ioinfo % count(1)
+ count3(2) = field % ioinfo % count(2)
+ count3(3) = field % ioinfo % count(3)
+
+#include "input_field3dreal.inc"
+
+#if (RKIND == 8)
+ nferr = nf_get_vara_double(input_obj % rd_ncid, varID, start3, count3, field % array)
+#else
+ nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start3, count3, field % array)
+#endif
+
+ end subroutine mpas_io_input_field3d_real
+
+
+ subroutine mpas_io_input_field0d_real_time(input_obj, field)
+
+ implicit none
+
+ type (io_input_object), intent(in) :: input_obj
+ type (field0dReal), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(1) :: start1, count1
+
+ start1(1) = input_obj % time
+ count1(1) = 1
+
+#include "input_field0dreal_time.inc"
+
+#if (RKIND == 8)
+ nferr = nf_get_vara_double(input_obj % rd_ncid, varID, start1, count1, field % scalar)
+#else
+ nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start1, count1, field % scalar)
+#endif
+
+ end subroutine mpas_io_input_field0d_real_time
+
+
+ subroutine mpas_io_input_field1d_real_time(input_obj, field)
+
+ implicit none
+
+ type (io_input_object), intent(in) :: input_obj
+ type (field1dReal), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(2) :: start2, count2
+
+ start2(1) = field % ioinfo % start(1)
+ start2(2) = input_obj % time
+ count2(1) = field % ioinfo % count(1)
+ count2(2) = 1
+
+#include "input_field1dreal_time.inc"
+
+#if (RKIND == 8)
+ nferr = nf_get_vara_double(input_obj % rd_ncid, varID, start2, count2, field % array)
+#else
+ nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start2, count2, field % array)
+#endif
+
+ end subroutine mpas_io_input_field1d_real_time
+
+
+ subroutine mpas_io_input_field2d_real_time(input_obj, field)
+
+ implicit none
+
+ type (io_input_object), intent(in) :: input_obj
+ type (field2dReal), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(3) :: start3, count3
+
+ start3(1) = field % ioinfo % start(1)
+ start3(2) = field % ioinfo % start(2)
+ start3(3) = input_obj % time
+ count3(1) = field % ioinfo % count(1)
+ count3(2) = field % ioinfo % count(2)
+ count3(3) = 1
+
+#include "input_field2dreal_time.inc"
+
+#if (RKIND == 8)
+ nferr = nf_get_vara_double(input_obj % rd_ncid, varID, start3, count3, field % array)
+#else
+ nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start3, count3, field % array)
+#endif
+
+ end subroutine mpas_io_input_field2d_real_time
+
+
+ subroutine mpas_io_input_field3d_real_time(input_obj, field)
+
+ implicit none
+
+ type (io_input_object), intent(in) :: input_obj
+ type (field3dReal), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(4) :: start4, count4
+
+ start4(1) = field % ioinfo % start(1)
+ start4(2) = field % ioinfo % start(2)
+ start4(3) = field % ioinfo % start(3)
+ start4(4) = input_obj % time
+ count4(1) = field % ioinfo % count(1)
+ count4(2) = field % ioinfo % count(2)
+ count4(3) = field % ioinfo % count(3)
+ count4(4) = 1
+
+#include "input_field3dreal_time.inc"
+
+#if (RKIND == 8)
+ nferr = nf_get_vara_double(input_obj % rd_ncid, varID, start4, count4, field % array)
+#else
+ nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start4, count4, field % array)
+#endif
+
+ end subroutine mpas_io_input_field3d_real_time
+
+
+ subroutine mpas_io_input_field1d_integer(input_obj, field)
+
+ implicit none
+
+ type (io_input_object), intent(in) :: input_obj
+ type (field1dInteger), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(1) :: start1, count1
+
+ start1(1) = field % ioinfo % start(1)
+ count1(1) = field % ioinfo % count(1)
+
+#include "input_field1dinteger.inc"
+
+ nferr = nf_get_vara_int(input_obj % rd_ncid, varID, start1, count1, field % array)
+
+ end subroutine mpas_io_input_field1d_integer
+
+
+ subroutine mpas_io_input_field2d_integer(input_obj, field)
+
+ implicit none
+
+ type (io_input_object), intent(in) :: input_obj
+ type (field2dInteger), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(2) :: start2, count2
+
+ start2(1) = field % ioinfo % start(1)
+ start2(2) = field % ioinfo % start(2)
+ count2(1) = field % ioinfo % count(1)
+ count2(2) = field % ioinfo % count(2)
+
+#include "input_field2dinteger.inc"
+
+ nferr = nf_get_vara_int(input_obj % rd_ncid, varID, start2, count2, field % array)
+
+ end subroutine mpas_io_input_field2d_integer
+
+
+ subroutine mpas_io_input_field1d_integer_time(input_obj, field)
+
+ implicit none
+
+ type (io_input_object), intent(in) :: input_obj
+ type (field1dInteger), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(2) :: start2, count2
+
+ start2(1) = field % ioinfo % start(1)
+ start2(2) = input_obj % time
+ count2(1) = field % ioinfo % count(1)
+ count2(2) = 1
+
+#include "input_field1dinteger_time.inc"
+
+ nferr = nf_get_vara_int(input_obj % rd_ncid, varID, start2, count2, field % array)
+
+ end subroutine mpas_io_input_field1d_integer_time
+
+
+ subroutine mpas_io_input_field0d_char_time(input_obj, field)
+
+ implicit none
+
+ type (io_input_object), intent(in) :: input_obj
+ type (field0dChar), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(2) :: start1, count1
+
+ start1(1) = 1
+ count1(1) = 64
+ start1(2) = input_obj % time
+ count1(2) = 1
+
+#include "input_field0dchar_time.inc"
+
+ nferr = nf_get_vara_text(input_obj % rd_ncid, varID, start1, count1, field % scalar)
+
+ end subroutine mpas_io_input_field0d_char_time
+
+
+ subroutine mpas_io_input_field1d_char_time(input_obj, field)
+
+ implicit none
+
+ type (io_input_object), intent(in) :: input_obj
+ type (field1dChar), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(3) :: start2, count2
+
+ start2(1) = 1
+ start2(2) = field % ioinfo % start(1)
+ start2(3) = input_obj % time
+ count2(1) = 64
+ count2(2) = field % ioinfo % count(1)
+ count2(3) = 1
+
+#include "input_field1dchar_time.inc"
+
+ nferr = nf_get_vara_text(input_obj % rd_ncid, varID, start2, count2, field % array)
+
+ end subroutine mpas_io_input_field1d_char_time
+
+
+ subroutine mpas_io_input_field0d_char(input_obj, field)
+
+ implicit none
+
+ type (io_input_object), intent(in) :: input_obj
+ type (field0dChar), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(2) :: start1, count1
+
+ start1(1) = 1
+ count1(1) = 64
+ start1(2) = 1
+ count1(2) = 1
+
+#include "input_field0dchar.inc"
+
+ nferr = nf_get_vara_text(input_obj % rd_ncid, varID, start1, count1, field % scalar)
+
+ end subroutine mpas_io_input_field0d_char
+
+
+ subroutine mpas_io_input_field1d_char(input_obj, field)
+
+ implicit none
+
+ type (io_input_object), intent(in) :: input_obj
+ type (field1dChar), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(2) :: start1, count1
+
+ start1(1) = 1
+ count1(1) = 64
+ start1(2) = field % ioinfo % start(1)
+ count1(2) = field % ioinfo % count(1)
+
+ !
+ ! Special case: we may want to read the xtime variable across the
+ ! time dimension as a 1d array.
+ !
+ if (trim(field % ioinfo % fieldName) == 'xtime') then
+ varID = input_obj % rdVarIDxtime
+ end if
+
+#include "input_field1dchar.inc"
+
+ nferr = nf_get_vara_text(input_obj % rd_ncid, varID, start1, count1, field % array)
+
+ end subroutine mpas_io_input_field1d_char
+
+
+ subroutine mpas_io_input_finalize(input_obj, dminfo)
+
+ implicit none
+
+ type (io_input_object), intent(inout) :: input_obj
+ type (dm_info), intent(in) :: dminfo
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+
+ nferr = nf_close(input_obj % rd_ncid)
+
+ end subroutine mpas_io_input_finalize
+
+end module mpas_io_input
Copied: trunk/mpas/src/framework/mpas_io_output.F (from rev 1113, branches/source_renaming/src/framework/mpas_io_output.F)
===================================================================
--- trunk/mpas/src/framework/mpas_io_output.F (rev 0)
+++ trunk/mpas/src/framework/mpas_io_output.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -0,0 +1,865 @@
+module mpas_io_output
+
+ use mpas_grid_types
+ use mpas_dmpar
+ use mpas_sort
+ use mpas_configure
+
+ integer, parameter :: OUTPUT = 1
+ integer, parameter :: RESTART = 2
+ integer, parameter :: SFC = 3
+
+ type io_output_object
+ integer :: wr_ncid
+ character (len=1024) :: filename
+
+ integer :: time
+
+ integer :: stream
+
+ integer :: wrDimIDStrLen
+#include "io_output_obj_decls.inc"
+
+ logical :: validExchangeLists
+ type (exchange_list), pointer :: sendCellsList, recvCellsList
+ type (exchange_list), pointer :: sendEdgesList, recvEdgesList
+ type (exchange_list), pointer :: sendVerticesList, recvVerticesList
+ type (exchange_list), pointer :: sendVertLevelsList, recvVertLevelsList
+ end type io_output_object
+
+
+ interface mpas_io_output_field
+ module procedure mpas_io_output_field0d_real
+ module procedure mpas_io_output_field1d_real
+ module procedure mpas_io_output_field2d_real
+ module procedure mpas_io_output_field3d_real
+ module procedure mpas_io_output_field1d_integer
+ module procedure mpas_io_output_field2d_integer
+ module procedure mpas_io_output_field0d_char
+ module procedure mpas_io_output_field1d_char
+ end interface mpas_io_output_field
+
+ interface mpas_io_output_field_time
+ module procedure mpas_io_output_field0d_real_time
+ module procedure mpas_io_output_field1d_real_time
+ module procedure mpas_io_output_field2d_real_time
+ module procedure mpas_io_output_field3d_real_time
+ module procedure mpas_io_output_field1d_integer_time
+ module procedure mpas_io_output_field0d_char_time
+ module procedure mpas_io_output_field1d_char_time
+ end interface mpas_io_output_field_time
+
+
+ contains
+
+
+ subroutine mpas_output_state_init(output_obj, domain, stream, outputSuffix)
+
+ implicit none
+
+ type (io_output_object), intent(inout) :: output_obj
+ type (domain_type), intent(in) :: domain
+ character (len=*) :: stream
+ character (len=*), optional :: outputSuffix
+
+ character (len=128) :: tempfilename
+
+ type (block_type), pointer :: block_ptr
+#include "output_dim_actual_decls.inc"
+
+ block_ptr => domain % blocklist
+ nullify(output_obj % sendCellsList)
+ nullify(output_obj % recvCellsList)
+ nullify(output_obj % sendEdgesList)
+ nullify(output_obj % recvEdgesList)
+ nullify(output_obj % sendVerticesList)
+ nullify(output_obj % recvVerticesList)
+ nullify(output_obj % sendVertLevelsList)
+ nullify(output_obj % recvVertLevelsList)
+ output_obj % validExchangeLists = .false.
+
+#include "output_dim_inits.inc"
+
+ call mpas_dmpar_sum_int(domain % dminfo, block_ptr % mesh % nCellsSolve, nCellsGlobal)
+ call mpas_dmpar_sum_int(domain % dminfo, block_ptr % mesh % nEdgesSolve, nEdgesGlobal)
+ call mpas_dmpar_sum_int(domain % dminfo, block_ptr % mesh % nVerticesSolve, nVerticesGlobal)
+ nVertLevelsGlobal = block_ptr % mesh % nVertLevels
+
+ if (trim(stream) == 'OUTPUT') then
+ if(present(outputSuffix)) then
+ call mpas_insert_string_suffix(config_output_name, outputSuffix, tempfilename)
+ else
+ tempfilename = config_output_name
+ end if
+ output_obj % filename = trim(tempfilename)
+ output_obj % stream = OUTPUT
+ else if (trim(stream) == 'RESTART') then
+ output_obj % filename = trim(config_restart_name)
+ output_obj % stream = RESTART
+ else if (trim(stream) == 'SFC') then
+ ! Keep filename as whatever was set by the user
+ output_obj % stream = SFC
+ end if
+
+ ! For now, we assume that a domain consists only of one block,
+ ! although in future, work needs to be done to write model state
+ ! from many distributed blocks
+ call mpas_io_output_init(output_obj, domain % dminfo, &
+ block_ptr % mesh, &
+#include "output_dim_actual_args.inc"
+ )
+
+ end subroutine mpas_output_state_init
+
+
+ subroutine mpas_insert_string_suffix(stream, suffix, filename)
+
+ implicit none
+
+ character (len=*), intent(in) :: stream
+ character (len=*), intent(in) :: suffix
+ character (len=*), intent(out) :: filename
+ integer :: length, i
+
+ filename = trim(stream) // '.' // trim(suffix)
+
+ length = len_trim(stream)
+ do i=length-1,1,-1
+ if(stream(i:i) == '.') then
+ filename = trim(stream(:i)) // trim(suffix) // trim(stream(i:))
+ exit
+ end if
+ end do
+
+ end subroutine mpas_insert_string_suffix
+
+
+ subroutine mpas_output_state_for_domain(output_obj, domain, itime)
+
+ implicit none
+
+ type (io_output_object), intent(inout) :: output_obj
+ type (domain_type), intent(inout) :: domain
+ integer, intent(in) :: itime
+
+ integer :: i, j
+ integer :: nCellsGlobal
+ integer :: nEdgesGlobal
+ integer :: nVerticesGlobal
+ integer :: nVertLevelsGlobal
+ integer, dimension(:), pointer :: neededCellList
+ integer, dimension(:), pointer :: neededEdgeList
+ integer, dimension(:), pointer :: neededVertexList
+ integer, dimension(:), pointer :: neededVertLevelList
+ integer, dimension(:,:), pointer :: cellsOnCell, edgesOnCell, verticesOnCell, &
+ cellsOnEdge, verticesOnEdge, edgesOnEdge, cellsOnVertex, edgesOnVertex
+ integer, dimension(:,:), pointer :: cellsOnCell_save, edgesOnCell_save, verticesOnCell_save, &
+ cellsOnEdge_save, verticesOnEdge_save, edgesOnEdge_save, &
+ cellsOnVertex_save, edgesOnVertex_save
+ type (field1dInteger) :: int1d
+ type (field2dInteger) :: int2d
+ type (field0dReal) :: real0d
+ type (field1dReal) :: real1d
+ type (field2dReal) :: real2d
+ type (field3dReal) :: real3d
+ type (field0dChar) :: char0d
+ type (field1dChar) :: char1d
+
+ integer :: i1, i2, i3, i4
+
+ integer, dimension(:), pointer :: super_int1d
+ integer, dimension(:,:), pointer :: super_int2d
+ real (kind=RKIND) :: super_real0d
+ real (kind=RKIND), dimension(:), pointer :: super_real1d
+ real (kind=RKIND), dimension(:,:), pointer :: super_real2d
+ real (kind=RKIND), dimension(:,:,:), pointer :: super_real3d
+ character (len=64) :: super_char0d
+ character (len=64), dimension(:), pointer :: super_char1d
+
+#include "nondecomp_outputs.inc"
+
+ output_obj % time = itime
+
+ allocate(int1d % ioinfo)
+ allocate(int2d % ioinfo)
+ allocate(real0d % ioinfo)
+ allocate(real1d % ioinfo)
+ allocate(real2d % ioinfo)
+ allocate(real3d % ioinfo)
+ allocate(char0d % ioinfo)
+ allocate(char1d % ioinfo)
+
+ call mpas_dmpar_sum_int(domain % dminfo, domain % blocklist % mesh % nCellsSolve, nCellsGlobal)
+ call mpas_dmpar_sum_int(domain % dminfo, domain % blocklist % mesh % nEdgesSolve, nEdgesGlobal)
+ call mpas_dmpar_sum_int(domain % dminfo, domain % blocklist % mesh % nVerticesSolve, nVerticesGlobal)
+ nVertLevelsGlobal = domain % blocklist % mesh % nVertLevels
+
+ allocate(cellsOnCell(domain % blocklist % mesh % maxEdges, domain % blocklist % mesh % nCellsSolve))
+ allocate(edgesOnCell(domain % blocklist % mesh % maxEdges, domain % blocklist % mesh % nCellsSolve))
+ allocate(verticesOnCell(domain % blocklist % mesh % maxEdges, domain % blocklist % mesh % nCellsSolve))
+ allocate(cellsOnEdge(2, domain % blocklist % mesh % nEdgesSolve))
+ allocate(verticesOnEdge(2, domain % blocklist % mesh % nEdgesSolve))
+ allocate(edgesOnEdge(2 * domain % blocklist % mesh % maxEdges, domain % blocklist % mesh % nEdgesSolve))
+ allocate(cellsOnVertex(domain % blocklist % mesh % vertexDegree, domain % blocklist % mesh % nVerticesSolve))
+ allocate(edgesOnVertex(domain % blocklist % mesh % vertexDegree, domain % blocklist % mesh % nVerticesSolve))
+
+
+ !
+ ! Convert connectivity information from local to global indices
+ !
+ do i=1,domain % blocklist % mesh % nCellsSolve
+ do j=1,domain % blocklist % mesh % nEdgesOnCell % array(i)
+ cellsOnCell(j,i) = domain % blocklist % mesh % indexToCellID % array( &
+ domain % blocklist % mesh % cellsOnCell % array(j,i))
+ edgesOnCell(j,i) = domain % blocklist % mesh % indexToEdgeID % array( &
+ domain % blocklist % mesh % edgesOnCell % array(j,i))
+ verticesOnCell(j,i) = domain % blocklist % mesh % indexToVertexID % array( &
+ domain % blocklist % mesh % verticesOnCell % array(j,i))
+ end do
+ do j=domain % blocklist % mesh % nEdgesOnCell % array(i)+1,domain % blocklist % mesh % maxEdges
+ cellsOnCell(j,i) = domain % blocklist % mesh % indexToCellID % array( &
+ domain % blocklist % mesh % nEdgesOnCell % array(i))
+ edgesOnCell(j,i) = domain % blocklist % mesh % indexToEdgeID % array( &
+ domain % blocklist % mesh % nEdgesOnCell % array(i))
+ verticesOnCell(j,i) = domain % blocklist % mesh % indexToVertexID % array( &
+ domain % blocklist % mesh % nEdgesOnCell % array(i))
+ end do
+ end do
+ do i=1,domain % blocklist % mesh % nEdgesSolve
+ cellsOnEdge(1,i) = domain % blocklist % mesh % indexToCellID % array(domain % blocklist % mesh % cellsOnEdge % array(1,i))
+ cellsOnEdge(2,i) = domain % blocklist % mesh % indexToCellID % array(domain % blocklist % mesh % cellsOnEdge % array(2,i))
+ verticesOnEdge(1,i) = domain % blocklist % mesh % indexToVertexID % array( &
+ domain % blocklist % mesh % verticesOnEdge % array(1,i))
+ verticesOnEdge(2,i) = domain % blocklist % mesh % indexToVertexID % array( &
+ domain % blocklist % mesh % verticesOnEdge % array(2,i))
+ do j=1,domain % blocklist % mesh % nEdgesOnEdge % array(i)
+ edgesOnEdge(j,i) = domain % blocklist % mesh % indexToEdgeID % array( &
+ domain % blocklist % mesh % edgesOnEdge % array(j,i))
+ end do
+ do j=domain % blocklist % mesh % nEdgesOnEdge % array(i)+1,2*domain % blocklist % mesh % maxEdges
+ if(domain % blocklist % mesh % nEdgesOnEdge % array(i) .eq. 0) then
+ edgesOnEdge(j,i) = domain % blocklist % mesh % nEdgesSolve + 1
+ else
+ edgesOnEdge(j,i) = domain % blocklist % mesh % indexToEdgeID % array( &
+ domain % blocklist % mesh % nEdgesOnEdge % array(i))
+ endif
+ end do
+ end do
+ do i=1,domain % blocklist % mesh % nVerticesSolve
+ do j=1,domain % blocklist % mesh % vertexDegree
+ cellsOnVertex(j,i) = domain % blocklist % mesh % indexToCellID % array( &
+ domain % blocklist % mesh % cellsOnVertex % array(j,i))
+ edgesOnVertex(j,i) = domain % blocklist % mesh % indexToEdgeID % array( &
+ domain % blocklist % mesh % edgesOnVertex % array(j,i))
+ end do
+ end do
+
+ if (domain % dminfo % my_proc_id == 0) then
+ allocate(neededCellList(nCellsGlobal))
+ allocate(neededEdgeList(nEdgesGlobal))
+ allocate(neededVertexList(nVerticesGlobal))
+ allocate(neededVertLevelList(nVertLevelsGlobal))
+ do i=1,nCellsGlobal
+ neededCellList(i) = i
+ end do
+ do i=1,nEdgesGlobal
+ neededEdgeList(i) = i
+ end do
+ do i=1,nVerticesGlobal
+ neededVertexList(i) = i
+ end do
+ do i=1,nVertLevelsGlobal
+ neededVertLevelList(i) = i
+ end do
+ else
+ allocate(neededCellList(0))
+ allocate(neededEdgeList(0))
+ allocate(neededVertexList(0))
+ allocate(neededVertLevelList(0))
+ end if
+
+ if (.not. output_obj % validExchangeLists) then
+ call mpas_dmpar_get_owner_list(domain % dminfo, &
+ domain % blocklist % mesh % nCellsSolve, size(neededCellList), &
+ domain % blocklist % mesh % indexToCellID % array, neededCellList, &
+ output_obj % sendCellsList, output_obj % recvCellsList)
+
+ call mpas_dmpar_get_owner_list(domain % dminfo, &
+ domain % blocklist % mesh % nEdgesSolve, size(neededEdgeList), &
+ domain % blocklist % mesh % indexToEdgeID % array, neededEdgeList, &
+ output_obj % sendEdgesList, output_obj % recvEdgesList)
+
+ call mpas_dmpar_get_owner_list(domain % dminfo, &
+ domain % blocklist % mesh % nVerticesSolve, size(neededVertexList), &
+ domain % blocklist % mesh % indexToVertexID % array, neededVertexList, &
+ output_obj % sendVerticesList, output_obj % recvVerticesList)
+
+ call mpas_dmpar_get_owner_list(domain % dminfo, &
+ size(neededVertLevelList), size(neededVertLevelList), &
+ neededVertLevelList, neededVertLevelList, &
+ output_obj % sendVertLevelsList, output_obj % recvVertLevelsList)
+
+ output_obj % validExchangeLists = .true.
+ end if
+
+ deallocate(neededCellList)
+ deallocate(neededEdgeList)
+ deallocate(neededVertexList)
+
+ cellsOnCell_save => domain % blocklist % mesh % cellsOnCell % array
+ edgesOnCell_save => domain % blocklist % mesh % edgesOnCell % array
+ verticesOnCell_save => domain % blocklist % mesh % verticesOnCell % array
+ cellsOnEdge_save => domain % blocklist % mesh % cellsOnEdge % array
+ verticesOnEdge_save => domain % blocklist % mesh % verticesOnEdge % array
+ edgesOnEdge_save => domain % blocklist % mesh % edgesOnEdge % array
+ cellsOnVertex_save => domain % blocklist % mesh % cellsOnVertex % array
+ edgesOnVertex_save => domain % blocklist % mesh % edgesOnVertex % array
+
+ domain % blocklist % mesh % cellsOnCell % array => cellsOnCell
+ domain % blocklist % mesh % edgesOnCell % array => edgesOnCell
+ domain % blocklist % mesh % verticesOnCell % array => verticesOnCell
+ domain % blocklist % mesh % cellsOnEdge % array => cellsOnEdge
+ domain % blocklist % mesh % verticesOnEdge % array => verticesOnEdge
+ domain % blocklist % mesh % edgesOnEdge % array => edgesOnEdge
+ domain % blocklist % mesh % cellsOnVertex % array => cellsOnVertex
+ domain % blocklist % mesh % edgesOnVertex % array => edgesOnVertex
+
+#include "io_output_fields.inc"
+
+ domain % blocklist % mesh % cellsOnCell % array => cellsOnCell_save
+ domain % blocklist % mesh % edgesOnCell % array => edgesOnCell_save
+ domain % blocklist % mesh % verticesOnCell % array => verticesOnCell_save
+ domain % blocklist % mesh % cellsOnEdge % array => cellsOnEdge_save
+ domain % blocklist % mesh % verticesOnEdge % array => verticesOnEdge_save
+ domain % blocklist % mesh % edgesOnEdge % array => edgesOnEdge_save
+ domain % blocklist % mesh % cellsOnVertex % array => cellsOnVertex_save
+ domain % blocklist % mesh % edgesOnVertex % array => edgesOnVertex_save
+
+ deallocate(cellsOnCell)
+ deallocate(edgesOnCell)
+ deallocate(verticesOnCell)
+ deallocate(cellsOnEdge)
+ deallocate(verticesOnEdge)
+ deallocate(edgesOnEdge)
+ deallocate(cellsOnVertex)
+ deallocate(edgesOnVertex)
+
+#include "nondecomp_outputs_dealloc.inc"
+
+ end subroutine mpas_output_state_for_domain
+
+
+ subroutine mpas_output_state_finalize(output_obj, dminfo)
+
+ implicit none
+
+ type (io_output_object), intent(inout) :: output_obj
+ type (dm_info), intent(in) :: dminfo
+
+ call mpas_io_output_finalize(output_obj, dminfo)
+
+ end subroutine mpas_output_state_finalize
+
+
+ subroutine mpas_io_output_init( output_obj, &
+ dminfo, &
+ mesh, &
+#include "dim_dummy_args.inc"
+ )
+
+ implicit none
+
+ include 'netcdf.inc'
+
+ type (io_output_object), intent(inout) :: output_obj
+ type (dm_info), intent(in) :: dminfo
+ type (mesh_type), intent(in) :: mesh
+#include "dim_dummy_decls.inc"
+
+ integer :: nferr
+ integer, dimension(10) :: dimlist
+
+ if (dminfo % my_proc_id == 0) then
+#ifdef OFFSET64BIT
+ nferr = nf_create(trim(output_obj % filename), ior(NF_CLOBBER,NF_64BIT_OFFSET), output_obj % wr_ncid)
+#else
+ nferr = nf_create(trim(output_obj % filename), NF_CLOBBER, output_obj % wr_ncid)
+#endif
+
+ nferr = nf_def_dim(output_obj % wr_ncid, 'StrLen', 64, output_obj % wrDimIDStrLen)
+#include "netcdf_def_dims_vars.inc"
+
+ if (mesh % on_a_sphere) then
+ nferr = nf_put_att_text(output_obj % wr_ncid, NF_GLOBAL, 'on_a_sphere', 16, 'YES ')
+ else
+ nferr = nf_put_att_text(output_obj % wr_ncid, NF_GLOBAL, 'on_a_sphere', 16, 'NO ')
+ end if
+ if (RKIND == 8) then
+ nferr = nf_put_att_double(output_obj % wr_ncid, NF_GLOBAL, 'sphere_radius', NF_DOUBLE, 1, mesh % sphere_radius)
+ else
+ nferr = nf_put_att_real(output_obj % wr_ncid, NF_GLOBAL, 'sphere_radius', NF_FLOAT, 1, mesh % sphere_radius)
+ end if
+
+ nferr = nf_enddef(output_obj % wr_ncid)
+ end if
+
+ end subroutine mpas_io_output_init
+
+
+ subroutine mpas_io_output_field0d_real(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 mpas_io_output_field0d_real
+
+
+ subroutine mpas_io_output_field1d_real(output_obj, field)
+
+ implicit none
+
+ type (io_output_object), intent(in) :: output_obj
+ type (field1dReal), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(1) :: start1, count1
+
+ start1(1) = field % ioinfo % start(1)
+ count1(1) = field % ioinfo % count(1)
+
+#include "output_field1dreal.inc"
+
+#if (RKIND == 8)
+ nferr = nf_put_vara_double(output_obj % wr_ncid, VarID, start1, count1, field % array)
+#else
+ nferr = nf_put_vara_real(output_obj % wr_ncid, VarID, start1, count1, field % array)
+#endif
+
+ nferr = nf_sync(output_obj % wr_ncid)
+
+ end subroutine mpas_io_output_field1d_real
+
+
+ subroutine mpas_io_output_field2d_real(output_obj, field)
+
+ implicit none
+
+ type (io_output_object), intent(in) :: output_obj
+ type (field2dReal), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(2) :: start2, count2
+
+ start2(1) = field % ioinfo % start(1)
+ start2(2) = field % ioinfo % start(2)
+ count2(1) = field % ioinfo % count(1)
+ count2(2) = field % ioinfo % count(2)
+
+#include "output_field2dreal.inc"
+
+#if (RKIND == 8)
+ nferr = nf_put_vara_double(output_obj % wr_ncid, varID, start2, count2, field % array)
+#else
+ nferr = nf_put_vara_real(output_obj % wr_ncid, varID, start2, count2, field % array)
+#endif
+
+ nferr = nf_sync(output_obj % wr_ncid)
+
+ end subroutine mpas_io_output_field2d_real
+
+
+ subroutine mpas_io_output_field3d_real(output_obj, field)
+
+ implicit none
+
+ type (io_output_object), intent(in) :: output_obj
+ type (field3dReal), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(3) :: start3, count3
+
+ start3(1) = field % ioinfo % start(1)
+ start3(2) = field % ioinfo % start(2)
+ start3(3) = field % ioinfo % start(3)
+ count3(1) = field % ioinfo % count(1)
+ count3(2) = field % ioinfo % count(2)
+ count3(3) = field % ioinfo % count(3)
+
+#include "output_field3dreal.inc"
+
+#if (RKIND == 8)
+ nferr = nf_put_vara_double(output_obj % wr_ncid, varID, start3, count3, field % array)
+#else
+ nferr = nf_put_vara_real(output_obj % wr_ncid, varID, start3, count3, field % array)
+#endif
+
+ nferr = nf_sync(output_obj % wr_ncid)
+
+ end subroutine mpas_io_output_field3d_real
+
+
+ subroutine mpas_io_output_field0d_real_time(output_obj, field)
+
+ implicit none
+
+ type (io_output_object), intent(in) :: output_obj
+ type (field0dReal), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(1) :: start1, count1
+
+ start1(1) = output_obj % time
+ count1(1) = 1
+
+#include "output_field0dreal_time.inc"
+
+#if (RKIND == 8)
+ nferr = nf_put_vara_double(output_obj % wr_ncid, varID, start1, count1, field % scalar)
+#else
+ nferr = nf_put_vara_real(output_obj % wr_ncid, varID, start1, count1, field % scalar)
+#endif
+
+ nferr = nf_sync(output_obj % wr_ncid)
+
+ end subroutine mpas_io_output_field0d_real_time
+
+
+ subroutine mpas_io_output_field1d_real_time(output_obj, field)
+
+ implicit none
+
+ type (io_output_object), intent(in) :: output_obj
+ type (field1dReal), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(2) :: start2, count2
+
+ start2(1) = field % ioinfo % start(1)
+ start2(2) = output_obj % time
+ count2(1) = field % ioinfo % count(1)
+ count2(2) = 1
+
+#include "output_field1dreal_time.inc"
+
+#if (RKIND == 8)
+ nferr = nf_put_vara_double(output_obj % wr_ncid, varID, start2, count2, field % array)
+#else
+ nferr = nf_put_vara_real(output_obj % wr_ncid, varID, start2, count2, field % array)
+#endif
+
+ nferr = nf_sync(output_obj % wr_ncid)
+
+ end subroutine mpas_io_output_field1d_real_time
+
+
+ subroutine mpas_io_output_field2d_real_time(output_obj, field)
+
+ implicit none
+
+ type (io_output_object), intent(in) :: output_obj
+ type (field2dReal), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(3) :: start3, count3
+
+ start3(1) = field % ioinfo % start(1)
+ start3(2) = field % ioinfo % start(2)
+ start3(3) = output_obj % time
+ count3(1) = field % ioinfo % count(1)
+ count3(2) = field % ioinfo % count(2)
+ count3(3) = 1
+
+#include "output_field2dreal_time.inc"
+
+#if (RKIND == 8)
+ nferr = nf_put_vara_double(output_obj % wr_ncid, varID, start3, count3, field % array)
+#else
+ nferr = nf_put_vara_real(output_obj % wr_ncid, varID, start3, count3, field % array)
+#endif
+
+ nferr = nf_sync(output_obj % wr_ncid)
+
+ end subroutine mpas_io_output_field2d_real_time
+
+
+ subroutine mpas_io_output_field3d_real_time(output_obj, field)
+
+ implicit none
+
+ type (io_output_object), intent(in) :: output_obj
+ type (field3dReal), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(4) :: start4, count4
+
+ start4(1) = field % ioinfo % start(1)
+ start4(2) = field % ioinfo % start(2)
+ start4(3) = field % ioinfo % start(3)
+ start4(4) = output_obj % time
+ count4(1) = field % ioinfo % count(1)
+ count4(2) = field % ioinfo % count(2)
+ count4(3) = field % ioinfo % count(3)
+ count4(4) = 1
+
+#include "output_field3dreal_time.inc"
+
+#if (RKIND == 8)
+ nferr = nf_put_vara_double(output_obj % wr_ncid, varID, start4, count4, field % array)
+#else
+ nferr = nf_put_vara_real(output_obj % wr_ncid, varID, start4, count4, field % array)
+#endif
+
+ nferr = nf_sync(output_obj % wr_ncid)
+
+ end subroutine mpas_io_output_field3d_real_time
+
+
+ subroutine mpas_io_output_field1d_integer(output_obj, field)
+
+ implicit none
+
+ type (io_output_object), intent(in) :: output_obj
+ type (field1dInteger), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(1) :: start1, count1
+
+ start1(1) = field % ioinfo % start(1)
+ count1(1) = field % ioinfo % count(1)
+
+#include "output_field1dinteger.inc"
+
+ nferr = nf_put_vara_int(output_obj % wr_ncid, varID, start1, count1, field % array)
+
+ nferr = nf_sync(output_obj % wr_ncid)
+
+ end subroutine mpas_io_output_field1d_integer
+
+
+ subroutine mpas_io_output_field2d_integer(output_obj, field)
+
+ implicit none
+
+ type (io_output_object), intent(in) :: output_obj
+ type (field2dInteger), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(2) :: start2, count2
+
+ start2(1) = field % ioinfo % start(1)
+ start2(2) = field % ioinfo % start(2)
+ count2(1) = field % ioinfo % count(1)
+ count2(2) = field % ioinfo % count(2)
+
+#include "output_field2dinteger.inc"
+
+ nferr = nf_put_vara_int(output_obj % wr_ncid, varID, start2, count2, field % array)
+
+ nferr = nf_sync(output_obj % wr_ncid)
+
+ end subroutine mpas_io_output_field2d_integer
+
+
+ subroutine mpas_io_output_field1d_integer_time(output_obj, field)
+
+ implicit none
+
+ type (io_output_object), intent(in) :: output_obj
+ type (field1dInteger), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(2) :: start2, count2
+
+ start2(1) = field % ioinfo % start(1)
+ start2(2) = output_obj % time
+ count2(1) = field % ioinfo % count(1)
+ count2(2) = 1
+
+#include "output_field1dinteger_time.inc"
+
+ nferr = nf_put_vara_int(output_obj % wr_ncid, varID, start2, count2, field % array)
+
+ nferr = nf_sync(output_obj % wr_ncid)
+
+ end subroutine mpas_io_output_field1d_integer_time
+
+
+ subroutine mpas_io_output_field0d_char_time(output_obj, field)
+
+ implicit none
+
+ type (io_output_object), intent(in) :: output_obj
+ type (field0dChar), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(2) :: start1, count1
+
+ start1(1) = 1
+ count1(1) = 64
+ start1(2) = output_obj % time
+ count1(2) = 1
+
+#include "output_field0dchar_time.inc"
+
+ nferr = nf_put_vara_text(output_obj % wr_ncid, varID, start1, count1, field % scalar)
+
+ nferr = nf_sync(output_obj % wr_ncid)
+
+ end subroutine mpas_io_output_field0d_char_time
+
+
+ subroutine mpas_io_output_field1d_char_time(output_obj, field)
+
+ implicit none
+
+ type (io_output_object), intent(in) :: output_obj
+ type (field1dChar), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(3) :: start2, count2
+
+ start2(1) = 1
+ start2(2) = field % ioinfo % start(1)
+ start2(3) = output_obj % time
+ count2(1) = 64
+ count2(2) = field % ioinfo % count(1)
+ count2(3) = 1
+
+#include "output_field1dchar_time.inc"
+
+ nferr = nf_put_vara_text(output_obj % wr_ncid, varID, start2, count2, field % array)
+
+ nferr = nf_sync(output_obj % wr_ncid)
+
+ end subroutine mpas_io_output_field1d_char_time
+
+
+ subroutine mpas_io_output_field0d_char(output_obj, field)
+
+ implicit none
+
+ type (io_output_object), intent(in) :: output_obj
+ type (field0dChar), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(2) :: start1, count1
+
+ start1(1) = 1
+ count1(1) = 64
+ start1(2) = 1
+ count1(2) = 1
+
+#include "output_field0dchar.inc"
+
+ nferr = nf_put_vara_text(output_obj % wr_ncid, varID, start1, count1, field % scalar)
+
+ nferr = nf_sync(output_obj % wr_ncid)
+
+ end subroutine mpas_io_output_field0d_char
+
+
+ subroutine mpas_io_output_field1d_char(output_obj, field)
+
+ implicit none
+
+ type (io_output_object), intent(in) :: output_obj
+ type (field1dChar), intent(inout) :: field
+
+ include 'netcdf.inc'
+
+ integer :: nferr
+ integer :: varID
+ integer, dimension(2) :: start1, count1
+
+ start1(1) = 1
+ count1(1) = 64
+ start1(2) = field % ioinfo % start(1)
+ count1(2) = field % ioinfo % count(1)
+
+#include "output_field1dchar.inc"
+
+ nferr = nf_put_vara_text(output_obj % wr_ncid, VarID, start1, count1, field % array)
+
+ nferr = nf_sync(output_obj % wr_ncid)
+
+ end subroutine mpas_io_output_field1d_char
+
+
+ subroutine mpas_io_output_finalize(output_obj, dminfo)
+
+ implicit none
+
+ include 'netcdf.inc'
+
+ type (io_output_object), intent(inout) :: output_obj
+ type (dm_info), intent(in) :: dminfo
+
+ integer :: nferr
+
+ if (dminfo % my_proc_id == 0) then
+ nferr = nf_close(output_obj % wr_ncid)
+ end if
+
+ end subroutine mpas_io_output_finalize
+
+end module mpas_io_output
Copied: trunk/mpas/src/framework/mpas_sort.F (from rev 1113, branches/source_renaming/src/framework/mpas_sort.F)
===================================================================
--- trunk/mpas/src/framework/mpas_sort.F (rev 0)
+++ trunk/mpas/src/framework/mpas_sort.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -0,0 +1,230 @@
+module mpas_sort
+
+ interface quicksort
+ module procedure mpas_quicksort_int
+ module procedure mpas_quicksort_real
+ end interface
+
+
+ contains
+
+
+ recursive subroutine mpas_mergesort(array, d1, n1, n2)
+
+ implicit none
+
+ ! Arguments
+ integer, intent(in) :: n1, n2, d1
+ integer, dimension(1:d1,n1:n2), intent(inout) :: array
+
+ ! Local variables
+ integer :: i, j, k
+ integer :: rtemp
+ integer, dimension(1:d1,1:n2-n1+1) :: temp
+
+ if (n1 >= n2) return
+
+ if (n2 - n1 == 1) then
+ if (array(1,n1) > array(1,n2)) then
+ do i=1,d1
+ rtemp = array(i,n1)
+ array(i,n1) = array(i,n2)
+ array(i,n2) = rtemp
+ end do
+ end if
+ return
+ end if
+
+ call mpas_mergesort(array(1:d1,n1:n1+(n2-n1+1)/2), d1, n1, n1+(n2-n1+1)/2)
+ call mpas_mergesort(array(1:d1,n1+((n2-n1+1)/2)+1:n2), d1, n1+((n2-n1+1)/2)+1, n2)
+
+ i = n1
+ j = n1 + ((n2-n1+1)/2) + 1
+ k = 1
+ do while (i <= n1+(n2-n1+1)/2 .and. j <= n2)
+ if (array(1,i) < array(1,j)) then
+ temp(1:d1,k) = array(1:d1,i)
+ k = k + 1
+ i = i + 1
+ else
+ temp(1:d1,k) = array(1:d1,j)
+ k = k + 1
+ j = j + 1
+ end if
+ end do
+
+ if (i <= n1+(n2-n1+1)/2) then
+ do while (i <= n1+(n2-n1+1)/2)
+ temp(1:d1,k) = array(1:d1,i)
+ i = i + 1
+ k = k + 1
+ end do
+ else
+ do while (j <= n2)
+ temp(1:d1,k) = array(1:d1,j)
+ j = j + 1
+ k = k + 1
+ end do
+ end if
+
+ array(1:d1,n1:n2) = temp(1:d1,1:k-1)
+
+ end subroutine mpas_mergesort
+
+
+ subroutine mpas_quicksort_int(nArray, array)
+
+ implicit none
+
+ integer, intent(in) :: nArray
+ integer, dimension(2,nArray), intent(inout) :: array
+
+ integer :: i, j, top, l, r, pivot, s
+ integer :: pivot_value
+ integer, dimension(2) :: temp
+ integer, dimension(1000) :: lstack, rstack
+
+ if (nArray < 1) return
+
+ top = 1
+ lstack(top) = 1
+ rstack(top) = nArray
+
+ do while (top > 0)
+
+ l = lstack(top)
+ r = rstack(top)
+ top = top - 1
+
+ pivot = (l+r)/2
+
+ pivot_value = array(1,pivot)
+ temp(:) = array(:,pivot)
+ array(:,pivot) = array(:,r)
+ array(:,r) = temp(:)
+
+ s = l
+ do i=l,r-1
+ if (array(1,i) <= pivot_value) then
+ temp(:) = array(:,s)
+ array(:,s) = array(:,i)
+ array(:,i) = temp(:)
+ s = s + 1
+ end if
+ end do
+
+ temp(:) = array(:,s)
+ array(:,s) = array(:,r)
+ array(:,r) = temp(:)
+
+ if (s-1 > l) then
+ top = top + 1
+if (top > 1000) write(0,*) 'Error: Quicksort exhausted its stack.'
+ lstack(top) = l
+ rstack(top) = s-1
+ end if
+
+ if (r > s+1) then
+ top = top + 1
+if (top > 1000) write(0,*) 'Error: Quicksort exhausted its stack.'
+ lstack(top) = s+1
+ rstack(top) = r
+ end if
+ end do
+
+ end subroutine mpas_quicksort_int
+
+
+ subroutine mpas_quicksort_real(nArray, array)
+
+ implicit none
+
+ integer, intent(in) :: nArray
+ real (kind=RKIND), dimension(2,nArray), intent(inout) :: array
+
+ integer :: i, j, top, l, r, pivot, s
+ real (kind=RKIND) :: pivot_value
+ real (kind=RKIND), dimension(2) :: temp
+ integer, dimension(1000) :: lstack, rstack
+
+ if (nArray < 1) return
+
+ top = 1
+ lstack(top) = 1
+ rstack(top) = nArray
+
+ do while (top > 0)
+
+ l = lstack(top)
+ r = rstack(top)
+ top = top - 1
+
+ pivot = (l+r)/2
+
+ pivot_value = array(1,pivot)
+ temp(:) = array(:,pivot)
+ array(:,pivot) = array(:,r)
+ array(:,r) = temp(:)
+
+ s = l
+ do i=l,r-1
+ if (array(1,i) <= pivot_value) then
+ temp(:) = array(:,s)
+ array(:,s) = array(:,i)
+ array(:,i) = temp(:)
+ s = s + 1
+ end if
+ end do
+
+ temp(:) = array(:,s)
+ array(:,s) = array(:,r)
+ array(:,r) = temp(:)
+
+ if (s-1 > l) then
+ top = top + 1
+if (top > 1000) write(0,*) 'Error: Quicksort exhausted its stack.'
+ lstack(top) = l
+ rstack(top) = s-1
+ end if
+
+ if (r > s+1) then
+ top = top + 1
+if (top > 1000) write(0,*) 'Error: Quicksort exhausted its stack.'
+ lstack(top) = s+1
+ rstack(top) = r
+ end if
+ end do
+
+ end subroutine mpas_quicksort_real
+
+
+ integer function mpas_binary_search(array, d1, n1, n2, key)
+
+ implicit none
+
+ integer, intent(in) :: d1, n1, n2, key
+ integer, dimension(d1,n1:n2), intent(in) :: array
+
+ integer :: l, u, k
+
+ mpas_binary_search = n2+1
+
+ l = n1
+ u = n2
+ k = (l+u)/2
+ do while (u >= l)
+ if (array(1,k) == key) then
+ mpas_binary_search = k
+ exit
+ else if (array(1,k) < key) then
+ l = k + 1
+ k = (l+u)/2
+ else
+ u = k - 1
+ k = (l+u)/2
+ end if
+ end do
+
+ end function mpas_binary_search
+
+end module mpas_sort
Copied: trunk/mpas/src/framework/mpas_timekeeping.F (from rev 1113, branches/source_renaming/src/framework/mpas_timekeeping.F)
===================================================================
--- trunk/mpas/src/framework/mpas_timekeeping.F (rev 0)
+++ trunk/mpas/src/framework/mpas_timekeeping.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -0,0 +1,1625 @@
+module mpas_timekeeping
+
+ use ESMF_BaseMod
+ use ESMF_Stubs
+ use ESMF_CalendarMod
+ use ESMF_ClockMod
+ use ESMF_TimeMod
+ use ESMF_TimeIntervalMod
+
+ private :: mpas_calibrate_alarms
+ private :: mpas_in_ringing_envelope
+
+ integer, parameter :: MPAS_MAX_ALARMS = 20
+ integer, parameter :: MPAS_NOW = 0, &
+ MPAS_START_TIME = 1, &
+ MPAS_STOP_TIME = 2
+ integer, parameter :: MPAS_FORWARD = 1, &
+ MPAS_BACKWARD = -1
+ integer, parameter :: MPAS_GREGORIAN = 0, &
+ MPAS_GREGORIAN_NOLEAP = 1, &
+ MPAS_360DAY = 2
+
+ integer :: TheCalendar
+
+ integer, dimension(12), parameter :: daysInMonth = (/31,28,31,30,31,30,31,31,30,31,30,31/)
+ integer, dimension(12), parameter :: daysInMonthLeap = (/31,29,31,30,31,30,31,31,30,31,30,31/)
+
+
+ type MPAS_Time_type
+ type (ESMF_Time) :: t
+ end type
+
+ type MPAS_TimeInterval_type
+ type (ESMF_TimeInterval) :: ti
+ end type
+
+ type MPAS_Alarm_type
+ integer :: alarmID
+ logical :: isRecurring
+ logical :: isSet
+ type (MPAS_Time_type) :: ringTime
+ type (MPAS_Time_type) :: prevRingTime
+ type (MPAS_TimeInterval_type) :: ringTimeInterval
+ type (MPAS_Alarm_type), pointer :: next
+ end type
+
+ type MPAS_Clock_type
+ integer :: direction
+ integer :: nAlarms
+ type (ESMF_Clock) :: c
+ type (MPAS_Alarm_type), pointer :: alarmListHead
+ end type
+
+ interface operator (+)
+ module procedure add_t_ti
+ module procedure add_ti_ti
+ end interface
+
+ interface operator (-)
+ module procedure sub_t_t
+ module procedure sub_t_ti
+ module procedure sub_ti_ti
+ module procedure neg_ti
+ end interface
+
+ interface operator (*)
+ module procedure mul_ti_n
+ end interface
+
+ interface operator (/)
+ module procedure div_ti_n
+ end interface
+
+ interface operator (.EQ.)
+ module procedure eq_t_t
+ module procedure eq_ti_ti
+ end interface
+
+ interface operator (.NE.)
+ module procedure ne_t_t
+ module procedure ne_ti_ti
+ end interface
+
+ interface operator (.LT.)
+ module procedure lt_t_t
+ module procedure lt_ti_ti
+ end interface
+
+ interface operator (.GT.)
+ module procedure gt_t_t
+ module procedure gt_ti_ti
+ end interface
+
+ interface operator (.LE.)
+ module procedure le_t_t
+ module procedure le_ti_ti
+ end interface
+
+ interface operator (.GE.)
+ module procedure ge_t_t
+ module procedure ge_ti_ti
+ end interface
+
+ interface abs
+ module procedure abs_ti
+ end interface
+
+
+ contains
+
+
+ subroutine mpas_timekeeping_init(calendar)
+
+ implicit none
+
+ integer, intent(in) :: calendar
+
+ TheCalendar = calendar
+
+ if (TheCalendar == MPAS_GREGORIAN) then
+ call ESMF_Initialize(defaultCalendar=ESMF_CAL_GREGORIAN)
+ else if (TheCalendar == MPAS_GREGORIAN_NOLEAP) then
+ call ESMF_Initialize(defaultCalendar=ESMF_CAL_NOLEAP)
+ else if (TheCalendar == MPAS_360DAY) then
+ call ESMF_Initialize(defaultCalendar=ESMF_CAL_360DAY)
+ else
+ write(0,*) 'ERROR: mpas_timekeeping_init: Invalid calendar type'
+ end if
+
+ end subroutine mpas_timekeeping_init
+
+
+ subroutine mpas_timekeeping_finalize()
+
+ implicit none
+
+ call ESMF_Finalize()
+
+ end subroutine mpas_timekeeping_finalize
+
+
+ subroutine mpas_create_clock(clock, startTime, timeStep, stopTime, runDuration, ierr)
+
+ implicit none
+
+ type (MPAS_Clock_type), intent(out) :: clock
+ type (MPAS_Time_type), intent(in) :: startTime
+ type (MPAS_TimeInterval_type), intent(in) :: timeStep
+ type (MPAS_Time_type), intent(in), optional :: stopTime
+ type (MPAS_TimeInterval_type), intent(in), optional :: runDuration
+ integer, intent(out), optional :: ierr
+
+ type (MPAS_Time_type) :: stop_time
+
+ if (present(runDuration)) then
+ stop_time = startTime + runDuration
+ if (present(stopTime)) then
+ if (stopTime /= stop_time) then
+ if (present(ierr)) ierr = 1 ! stopTime and runDuration are inconsistent
+ write(0,*) 'ERROR: MPAS_createClock: stopTime and runDuration are inconsistent'
+ return
+ end if
+ end if
+ else if (present(stopTime)) then
+ stop_time = stopTime
+ else
+ if (present(ierr)) ierr = 1 ! neither stopTime nor runDuration are specified
+ write(0,*) 'ERROR: MPAS_createClock: neither stopTime nor runDuration are specified'
+ return
+ end if
+
+ clock % c = ESMF_ClockCreate(TimeStep=timeStep%ti, StartTime=startTime%t, StopTime=stop_time%t, rc=ierr)
+ if (present(ierr)) then
+ if (ierr == ESMF_SUCCESS) ierr = 0
+ end if
+ clock % direction = MPAS_FORWARD
+ clock % nAlarms = 0
+ nullify(clock % alarmListHead)
+
+ end subroutine mpas_create_clock
+
+
+ subroutine mpas_destroy_clock(clock, ierr)
+
+ implicit none
+
+ type (MPAS_Clock_type), intent(inout) :: clock
+ integer, intent(out), optional :: ierr
+
+ type (MPAS_Alarm_type), pointer :: alarmPtr
+
+ alarmPtr => clock % alarmListHead
+ do while (associated(alarmPtr))
+ clock % alarmListHead => alarmPtr % next
+ deallocate(alarmPtr)
+ alarmPtr => clock % alarmListHead
+ end do
+
+ call ESMF_ClockDestroy(clock % c, rc=ierr)
+ if (present(ierr)) then
+ if (ierr == ESMF_SUCCESS) ierr = 0
+ end if
+
+ end subroutine mpas_destroy_clock
+
+
+ logical function mpas_is_clock_start_time(clock, ierr)
+
+ implicit none
+
+ type (MPAS_Clock_type), intent(in) :: clock
+ integer, intent(out), optional :: ierr
+
+ type (ESMF_Time) :: currTime, startTime, stopTime
+
+ call ESMF_ClockGet(clock % c, CurrTime=currTime, rc=ierr)
+ call ESMF_ClockGet(clock % c, StartTime=startTime, rc=ierr)
+ call ESMF_ClockGet(clock % c, StopTime=stopTime, rc=ierr)
+ if (present(ierr)) then
+ if (ierr == ESMF_SUCCESS) ierr = 0
+ end if
+
+ if (startTime <= stopTime) then
+ mpas_is_clock_start_time = (currTime <= startTime)
+ else
+ mpas_is_clock_start_time = (currTime >= startTime)
+ end if
+
+ end function mpas_is_clock_start_time
+
+
+ logical function mpas_is_clock_stop_time(clock, ierr)
+
+ implicit none
+
+ type (MPAS_Clock_type), intent(in) :: clock
+ integer, intent(out), optional :: ierr
+
+ type (ESMF_Time) :: currTime, startTime, stopTime
+
+ call ESMF_ClockGet(clock % c, CurrTime=currTime, rc=ierr)
+ call ESMF_ClockGet(clock % c, StartTime=startTime, rc=ierr)
+ call ESMF_ClockGet(clock % c, StopTime=stopTime, rc=ierr)
+ if (present(ierr)) then
+ if (ierr == ESMF_SUCCESS) ierr = 0
+ end if
+
+ if (startTime <= stopTime) then
+ mpas_is_clock_stop_time = (currTime >= stopTime)
+ else
+ mpas_is_clock_stop_time = (currTime <= stopTime)
+ end if
+
+ end function mpas_is_clock_stop_time
+
+
+ subroutine mpas_set_clock_direction(clock, direction, ierr)
+
+ implicit none
+
+ type (MPAS_Clock_type), intent(inout) :: clock
+ integer, intent(in) :: direction
+ integer, intent(out), optional :: ierr
+
+ type (MPAS_TimeInterval_type) :: timeStep
+
+ if (direction == MPAS_FORWARD .and. clock % direction == MPAS_FORWARD) return
+ if (direction == MPAS_BACKWARD .and. clock % direction == MPAS_BACKWARD) return
+
+ clock % direction = direction
+ call ESMF_ClockGet(clock % c, TimeStep=timeStep%ti, rc=ierr)
+ timeStep = neg_ti(timeStep)
+ call ESMF_ClockSet(clock % c, TimeStep=timeStep%ti, rc=ierr)
+
+ ! specify a valid previousRingTime for each alarm
+ call mpas_calibrate_alarms(clock, ierr);
+
+ if (present(ierr)) then
+ if (ierr == ESMF_SUCCESS) ierr = 0
+ end if
+
+ end subroutine mpas_set_clock_direction
+
+
+
+ integer function mpas_get_clock_direction(clock, ierr)
+
+ implicit none
+
+ type (MPAS_Clock_type), intent(in) :: clock
+ integer, intent(out), optional :: ierr
+
+ if (present(ierr)) ierr = 0
+
+ mpas_get_clock_direction = clock % direction
+
+ end function mpas_get_clock_direction
+
+
+ subroutine mpas_set_clock_timestep(clock, timeStep, ierr)
+
+ implicit none
+
+ type (MPAS_Clock_type), intent(inout) :: clock
+ type (MPAS_TimeInterval_type), intent(in) :: timeStep
+ integer, intent(out), optional :: ierr
+
+ call ESMF_ClockSet(clock % c, TimeStep=timeStep%ti, rc=ierr)
+ if (present(ierr)) then
+ if (ierr == ESMF_SUCCESS) ierr = 0
+ end if
+
+ end subroutine mpas_set_clock_timestep
+
+
+ type (MPAS_TimeInterval_type) function mpas_get_clock_timestep(clock, ierr)
+
+ implicit none
+
+ type (MPAS_Clock_type), intent(in) :: clock
+ integer, intent(out), optional :: ierr
+
+ type (MPAS_TimeInterval_type) :: timeStep
+
+ call ESMF_ClockGet(clock % c, TimeStep=timeStep%ti, rc=ierr)
+ if (present(ierr)) then
+ if (ierr == ESMF_SUCCESS) ierr = 0
+ end if
+
+ mpas_get_clock_timestep = timeStep
+
+ end function mpas_get_clock_timestep
+
+
+ subroutine mpas_advance_clock(clock, timeStep, ierr)
+
+ implicit none
+
+ type (MPAS_Clock_type), intent(inout) :: clock
+ type (MPAS_TimeInterval_type), intent(in), optional :: timeStep
+ integer, intent(out), optional :: ierr
+
+ type (ESMF_TimeInterval) :: time_step
+
+ if (present(timeStep)) then
+ call ESMF_ClockGet(clock % c, TimeStep=time_step, rc=ierr)
+ call ESMF_ClockSet(clock % c, TimeStep=timeStep % ti, rc=ierr)
+ call ESMF_ClockAdvance(clock % c, rc=ierr)
+ call ESMF_ClockSet(clock % c, TimeStep=time_step, rc=ierr)
+ else
+ call ESMF_ClockAdvance(clock % c, rc=ierr)
+ end if
+ if (present(ierr)) then
+ if (ierr == ESMF_SUCCESS) ierr = 0
+ end if
+
+ end subroutine mpas_advance_clock
+
+
+ subroutine mpas_set_clock_time(clock, clock_time, whichTime, ierr)
+
+ implicit none
+
+ type (MPAS_Clock_type), intent(inout) :: clock
+ type (MPAS_Time_type), intent(in) :: clock_time
+ integer, intent(in) :: whichTime
+ integer, intent(out), optional :: ierr
+
+ if (whichTime == MPAS_NOW) then
+ call ESMF_ClockSet(clock % c, CurrTime=clock_time%t, rc=ierr)
+ call mpas_calibrate_alarms(clock, ierr);
+ else if (whichTime == MPAS_START_TIME) then
+ call ESMF_ClockSet(clock % c, StartTime=clock_time%t, rc=ierr)
+ else if (whichTime == MPAS_STOP_TIME) then
+ call ESMF_ClockSet(clock % c, StopTime=clock_time%t, rc=ierr)
+ else if (present(ierr)) then
+ ierr = 1
+ end if
+ if (present(ierr)) then
+ if (ierr == ESMF_SUCCESS) ierr = 0
+ end if
+
+ end subroutine mpas_set_clock_time
+
+
+ type (MPAS_Time_type) function mpas_get_clock_time(clock, whichTime, ierr)
+
+ implicit none
+
+ type (MPAS_Clock_type), intent(in) :: clock
+ integer, intent(in) :: whichTime
+ integer, intent(out), optional :: ierr
+
+ type (MPAS_Time_type) :: clock_time
+
+ if (whichTime == MPAS_NOW) then
+ call ESMF_ClockGet(clock % c, CurrTime=clock_time%t, rc=ierr)
+ else if (whichTime == MPAS_START_TIME) then
+ call ESMF_ClockGet(clock % c, StartTime=clock_time%t, rc=ierr)
+ else if (whichTime == MPAS_STOP_TIME) then
+ call ESMF_ClockGet(clock % c, StopTime=clock_time%t, rc=ierr)
+ else if (present(ierr)) then
+ ierr = 1
+ end if
+ if (present(ierr)) then
+ if (ierr == ESMF_SUCCESS) ierr = 0
+ end if
+
+ mpas_get_clock_time = clock_time
+
+ end function mpas_get_clock_time
+
+
+ subroutine mpas_add_clock_alarm(clock, alarmID, alarmTime, alarmTimeInterval, ierr)
+! TODO: possibly add a stop time for recurring alarms
+
+ implicit none
+
+ type (MPAS_Clock_type), intent(inout) :: clock
+ integer, intent(in) :: alarmID
+ type (MPAS_Time_type), intent(in) :: alarmTime
+ type (MPAS_TimeInterval_type), intent(in), optional :: alarmTimeInterval
+ integer, intent(out), optional :: ierr
+
+ type (MPAS_Alarm_type), pointer :: alarmPtr
+
+ ! Add a new entry to the linked list of alarms for this clock
+ if (.not. associated(clock % alarmListHead)) then
+ allocate(clock % alarmListHead)
+ nullify(clock % alarmListHead % next)
+ alarmPtr => clock % alarmListHead
+ else
+ alarmPtr => clock % alarmListHead
+ do while (associated(alarmPtr % next))
+ if (alarmPtr % alarmID == alarmID) then
+ write(0,*) 'OOPS -- we have a duplicate alarmID', alarmID
+ if (present(ierr)) ierr = 1
+ return
+ end if
+ alarmPtr => alarmPtr % next
+ end do
+ if (alarmPtr % alarmID == alarmID) then
+ write(0,*) 'OOPS -- we have a duplicate alarmID', alarmID
+ if (present(ierr)) ierr = 1
+ return
+ end if
+ allocate(alarmPtr % next)
+ alarmPtr => alarmPtr % next
+ nullify(alarmPtr % next)
+ end if
+
+ alarmPtr % alarmID = alarmID
+
+ clock % nAlarms = clock % nAlarms + 1
+
+ alarmPtr % isSet = .true.
+ alarmPtr % ringTime = alarmTime
+
+
+ if (present(alarmTimeInterval)) then
+ alarmPtr % isRecurring = .true.
+ alarmPtr % ringTimeInterval = alarmTimeInterval
+ if(clock % direction == MPAS_FORWARD) then
+ alarmPtr % prevRingTime = alarmTime - alarmTimeInterval
+ else
+ alarmPtr % prevRingTime = alarmTime + alarmTimeInterval
+ end if
+ else
+ alarmPtr % isRecurring = .false.
+ alarmPtr % prevRingTime = alarmTime
+ end if
+ if (present(ierr)) then
+ if (ierr == ESMF_SUCCESS) ierr = 0
+ end if
+
+ end subroutine mpas_add_clock_alarm
+
+
+ subroutine mpas_remove_clock_alarm(clock, alarmID, ierr)
+
+ implicit none
+
+ type (MPAS_Clock_type), intent(inout) :: clock
+ integer, intent(in) :: alarmID
+ integer, intent(out), optional :: ierr
+
+ type (MPAS_Alarm_type), pointer :: alarmPtr
+ type (MPAS_Alarm_type), pointer :: alarmParentPtr
+
+ if (present(ierr)) ierr = 0
+
+ alarmPtr => clock % alarmListHead
+ alarmParentPtr = alarmPtr
+ do while (associated(alarmPtr))
+ if (alarmPtr % alarmID == alarmID) then
+ alarmParentPtr % next => alarmPtr % next
+ deallocate(alarmPtr)
+ exit
+ end if
+ alarmParentPtr = alarmPtr
+ alarmPtr => alarmPtr % next
+ end do
+
+ end subroutine mpas_remove_clock_alarm
+
+
+
+ subroutine mpas_print_alarm(clock, alarmID, ierr)
+
+ implicit none
+
+ type (MPAS_Clock_type), intent(in) :: clock
+ integer, intent(in) :: alarmID
+ integer, intent(out) :: ierr
+
+ type (MPAS_Alarm_type), pointer :: alarmPtr
+
+ type (MPAS_TimeInterval_type) :: alarmTimeInterval
+ type (MPAS_Time_type) :: alarmTime
+ character (len=32) :: printString
+
+ ierr = 0
+
+ alarmPtr => clock % alarmListHead
+ do while (associated(alarmPtr))
+ if (alarmPtr % alarmID == alarmID) then
+ write(0,*) 'ALARM ', alarmID
+
+ write(0,*) 'isRecurring', alarmPtr % isRecurring
+
+ write(0,*) 'isSet', alarmPtr % isSet
+
+ call mpas_get_time(alarmPtr % ringTime, dateTimeString=printString, ierr=ierr)
+ write(0,*) 'ringTime', printString
+
+ call mpas_get_time(alarmPtr % prevRingTime, dateTimeString=printString, ierr=ierr)
+ write(0,*) 'prevRingTime', printString
+
+ call mpas_get_timeInterval(alarmPtr % ringTimeInterval, timeString=printString, ierr=ierr)
+ write(0,*) 'ringTimeInterval', printString
+
+ exit
+ end if
+ alarmPtr => alarmPtr % next
+ end do
+
+ end subroutine mpas_print_alarm
+
+
+
+ logical function mpas_is_alarm_ringing(clock, alarmID, interval, ierr)
+
+ implicit none
+
+ type (MPAS_Clock_type), intent(in) :: clock
+ integer, intent(in) :: alarmID
+ type (MPAS_TimeInterval_type), intent(in), optional :: interval
+ integer, intent(out), optional :: ierr
+
+ type (MPAS_Alarm_type), pointer :: alarmPtr
+
+ if (present(ierr)) ierr = 0
+
+ mpas_is_alarm_ringing = .false.
+
+ alarmPtr => clock % alarmListHead
+ do while (associated(alarmPtr))
+ if (alarmPtr % alarmID == alarmID) then
+ if (alarmPtr % isSet) then
+ if (mpas_in_ringing_envelope(clock, alarmPtr, interval, ierr)) then
+ mpas_is_alarm_ringing = .true.
+ end if
+ end if
+ exit
+ end if
+ alarmPtr => alarmPtr % next
+ end do
+
+ end function mpas_is_alarm_ringing
+
+
+
+ subroutine mpas_get_clock_ringing_alarms(clock, nAlarms, alarmList, interval, ierr)
+
+ implicit none
+
+ type (MPAS_Clock_type), intent(in) :: clock
+ integer, intent(out) :: nAlarms
+ integer, dimension(MPAS_MAX_ALARMS), intent(out) :: alarmList
+ type (MPAS_TimeInterval_type), intent(in), optional :: interval
+ integer, intent(out), optional :: ierr
+
+ type (MPAS_Alarm_type), pointer :: alarmPtr
+
+ if (present(ierr)) ierr = 0
+
+ nAlarms = 0
+
+ alarmPtr => clock % alarmListHead
+ do while (associated(alarmPtr))
+ if (alarmPtr % isSet) then
+ if (mpas_in_ringing_envelope(clock, alarmPtr, interval, ierr)) then
+ nAlarms = nAlarms + 1
+ alarmList(nAlarms) = alarmPtr % alarmID
+ end if
+ end if
+ alarmPtr => alarmPtr % next
+ end do
+
+ end subroutine mpas_get_clock_ringing_alarms
+
+
+ logical function mpas_in_ringing_envelope(clock, alarmPtr, interval, ierr)
+
+ implicit none
+
+ type (MPAS_Clock_type), intent(in) :: clock
+ type (MPAS_Alarm_type), pointer, intent(in) :: alarmPtr
+ type (MPAS_TimeInterval_type), intent(in), optional :: interval
+ integer, intent(out), optional :: ierr
+
+ type (MPAS_Time_type) :: alarmNow
+ type (MPAS_Time_type) :: alarmThreshold
+
+ alarmNow = mpas_get_clock_time(clock, MPAS_NOW, ierr)
+ alarmThreshold = alarmPtr % ringTime
+
+ mpas_in_ringing_envelope = .false.
+
+ if(clock % direction == MPAS_FORWARD) then
+
+ if (present(interval)) then
+ alarmNow = alarmNow + interval;
+ end if
+
+ if (alarmPtr % isRecurring) then
+ alarmThreshold = alarmPtr % prevRingTime + alarmPtr % ringTimeInterval
+ end if
+
+ if (alarmThreshold <= alarmNow) then
+ mpas_in_ringing_envelope = .true.
+ end if
+ else
+
+ if (present(interval)) then
+ alarmNow = alarmNow - interval;
+ end if
+
+ if (alarmPtr % isRecurring) then
+ alarmThreshold = alarmPtr % prevRingTime - alarmPtr % ringTimeInterval
+ end if
+
+ if (alarmThreshold >= alarmNow) then
+ mpas_in_ringing_envelope = .true.
+ end if
+ end if
+
+ end function mpas_in_ringing_envelope
+
+
+
+ subroutine mpas_reset_clock_alarm(clock, alarmID, interval, ierr)
+
+ implicit none
+
+ type (MPAS_Clock_type), intent(inout) :: clock
+ integer, intent(in) :: alarmID
+ type (MPAS_TimeInterval_type), intent(in), optional :: interval
+ integer, intent(out), optional :: ierr
+
+ type (MPAS_Time_type) :: alarmNow
+ type (MPAS_Alarm_type), pointer :: alarmPtr
+
+ if (present(ierr)) ierr = 0
+
+ alarmPtr => clock % alarmListHead
+ do while (associated(alarmPtr))
+
+ if (alarmPtr % alarmID == alarmID) then
+
+ if (mpas_in_ringing_envelope(clock, alarmPtr, interval, ierr)) then
+
+ if (.not. alarmPtr % isRecurring) then
+ alarmPtr % isSet = .false.
+ else
+ alarmNow = mpas_get_clock_time(clock, MPAS_NOW, ierr)
+
+ if(clock % direction == MPAS_FORWARD) then
+ if (present(interval)) then
+ alarmNow = alarmNow + interval
+ end if
+
+ do while(alarmPtr % prevRingTime <= alarmNow)
+ alarmPtr % prevRingTime = alarmPtr % prevRingTime + alarmPtr % ringTimeInterval
+ end do
+ alarmPtr % prevRingTime = alarmPtr % prevRingTime - alarmPtr % ringTimeInterval
+ else
+ if (present(interval)) then
+ alarmNow = alarmNow - interval
+ end if
+
+ do while(alarmPtr % prevRingTime >= alarmNow)
+ alarmPtr % prevRingTime = alarmPtr % prevRingTime - alarmPtr % ringTimeInterval
+ end do
+ alarmPtr % prevRingTime = alarmPtr % prevRingTime + alarmPtr % ringTimeInterval
+ end if
+ end if
+ end if
+ exit
+ end if
+ alarmPtr => alarmPtr % next
+ end do
+
+ end subroutine mpas_reset_clock_alarm
+
+
+
+ ! specify a valid previousRingTime for each alarm
+ subroutine mpas_calibrate_alarms(clock, ierr)
+
+ implicit none
+
+ type (MPAS_Clock_type), intent(in) :: clock
+ integer, intent(out), optional :: ierr
+
+ type (MPAS_Time_type) :: now
+ type (MPAS_Time_type) :: previousRingTime
+ type (MPAS_Time_type) :: negativeNeighborRingTime
+ type (MPAS_Time_type) :: positiveNeighborRingTime
+ type (MPAS_TimeInterval_type) :: ringTimeInterval
+ type (MPAS_Alarm_type), pointer :: alarmPtr
+
+ now = mpas_get_clock_time(clock, MPAS_NOW, ierr)
+
+ alarmPtr => clock % alarmListHead
+ do while (associated(alarmPtr))
+
+ if (.not. alarmPtr % isRecurring) then
+ alarmPtr % isSet = .true.
+ else
+
+ previousRingTime = alarmPtr % prevRingTime
+
+ if (previousRingTime <= now) then
+
+ do while(previousRingTime <= now)
+ previousRingTime = previousRingTime + alarmPtr % ringTimeInterval
+ end do
+ positiveNeighborRingTime = previousRingTime
+
+ do while(previousRingTime >= now)
+ previousRingTime = previousRingTime - alarmPtr % ringTimeInterval
+ end do
+ negativeNeighborRingTime = previousRingTime
+
+ else
+
+ do while(previousRingTime >= now)
+ previousRingTime = previousRingTime - alarmPtr % ringTimeInterval
+ end do
+ negativeNeighborRingTime = previousRingTime
+
+ do while(previousRingTime <= now)
+ previousRingTime = previousRingTime + alarmPtr % ringTimeInterval
+ end do
+ positiveNeighborRingTime = previousRingTime
+
+ end if
+
+ if (clock % direction == MPAS_FORWARD) then
+ alarmPtr % prevRingTime = negativeNeighborRingTime
+ else
+ alarmPtr % prevRingTime = positiveNeighborRingTime
+ end if
+
+ end if
+
+ alarmPtr => alarmPtr % next
+
+ end do
+
+ if (present(ierr)) then
+ if (ierr == ESMF_SUCCESS) ierr = 0
+ end if
+
+ end subroutine mpas_calibrate_alarms
+
+
+ subroutine mpas_set_time(curr_time, YYYY, MM, DD, DoY, H, M, S, S_n, S_d, dateTimeString, ierr)
+
+ implicit none
+
+ type (MPAS_Time_type), intent(out) :: curr_time
+ integer, intent(in), optional :: YYYY
+ integer, intent(in), optional :: MM
+ integer, intent(in), optional :: DD
+ integer, intent(in), optional :: DoY
+ integer, intent(in), optional :: H
+ integer, intent(in), optional :: M
+ integer, intent(in), optional :: S
+ integer, intent(in), optional :: S_n
+ integer, intent(in), optional :: S_d
+ character (len=*), intent(in), optional :: dateTimeString
+ integer, intent(out), optional :: ierr
+
+ integer, parameter :: integerMaxDigits = 8
+ integer :: year, month, day, hour, min, sec
+ integer :: numerator, denominator, denominatorPower
+
+ character (len=50) :: dateTimeString_
+ character (len=50) :: dateSubString
+ character (len=50) :: timeSubString
+ character (len=50) :: secDecSubString
+ character(len=50), pointer, dimension(:) :: subStrings
+
+ if (present(dateTimeString)) then
+
+ dateTimeString_ = dateTimeString
+ numerator = 0
+ denominator = 1
+
+ call mpas_split_string(dateTimeString_, ".", subStrings)
+ if (size(subStrings) == 2) then ! contains second decimals
+ dateTimeString_ = subStrings(1)
+ secDecSubString = subStrings(2)(:integerMaxDigits)
+ deallocate(subStrings)
+ denominatorPower = len_trim(secDecSubString)
+ if(denominatorPower > 0) then
+ read(secDecSubString,*) numerator
+ if(numerator > 0) then
+ denominator = 10**denominatorPower
+ end if
+ end if
+ else if (size(subStrings) /= 1) then
+ deallocate(subStrings)
+ if (present(ierr)) ierr = 1
+ write(0,*) 'ERROR: Invalid DateTime string', dateTimeString
+ return
+ end if
+
+ call mpas_split_string(dateTimeString_, "_", subStrings)
+
+ if(size(subStrings) == 2) then ! contains a date and time
+ dateSubString = subStrings(1)
+ timeSubString = subStrings(2)
+ deallocate(subStrings)
+
+ call mpas_split_string(timeSubString, ":", subStrings)
+
+ if (size(subStrings) == 3) then
+ read(subStrings(1),*) hour
+ read(subStrings(2),*) min
+ read(subStrings(3),*) sec
+ deallocate(subStrings)
+ else
+ deallocate(subStrings)
+ if (present(ierr)) ierr = 1
+ write(0,*) 'ERROR: Invalid DateTime string (invalid time substring)', dateTimeString
+ return
+ end if
+
+ else if(size(subStrings) == 1) then ! contains only a date- assume all time values are 0
+ dateSubString = subStrings(1)
+ deallocate(subStrings)
+
+ hour = 0
+ min = 0
+ sec = 0
+
+ else
+ deallocate(subStrings)
+ if (present(ierr)) ierr = 1
+ write(0,*) 'ERROR: Invalid DateTime string', dateTimeString
+ return
+ end if
+
+ call mpas_split_string(dateSubString, "-", subStrings)
+
+ if (size(subStrings) == 3) then
+ read(subStrings(1),*) year
+ read(subStrings(2),*) month
+ read(subStrings(3),*) day
+ deallocate(subStrings)
+ else
+ deallocate(subStrings)
+ if (present(ierr)) ierr = 1
+ write(0,*) 'ERROR: Invalid DateTime string (invalid date substring)', dateTimeString
+ return
+ end if
+
+ call ESMF_TimeSet(curr_time % t, YY=year, MM=month, DD=day, H=hour, M=min, S=sec, Sn=numerator, Sd=denominator, rc=ierr)
+
+ else
+
+ if (present(DoY)) then
+ call mpas_get_month_day(YYYY, DoY, month, day)
+
+ ! consistency check
+ if (present(MM)) then
+ if (MM /= month) then
+ if (present(ierr)) ierr = 1
+ write(0,*) 'ERROR: MPAS_setTime : DoY and MM are inconsistent - using DoY'
+ end if
+ end if
+ if (present(DD)) then
+ if (DD /= day) then
+ if (present(ierr)) ierr = 1
+ write(0,*) 'ERROR: MPAS_setTime : DoY and DD are inconsistent - using DoY'
+ end if
+ end if
+ else
+ if (present(MM)) then
+ month = MM
+ else
+ if (present(ierr)) ierr = 1
+ write(0,*) 'ERROR: MPAS_setTime : Neither DoY nor MM are specified'
+ return
+ end if
+
+ if (present(DD)) then
+ day = DD
+ else
+ if (present(ierr)) ierr = 1
+ write(0,*) 'ERROR: MPAS_setTime : Neither DoY nor DD are specified'
+ return
+ end if
+ end if
+
+ if (.not. isValidDate(YYYY,month,day)) then
+ write(0,*) 'ERROR: MPAS_setTime : Invalid date'
+ return
+ end if
+
+ call ESMF_TimeSet(curr_time % t, YY=YYYY, MM=month, DD=day, H=H, M=M, S=S, Sn=S_n, Sd=S_d, rc=ierr)
+
+ end if
+
+ if (present(ierr)) then
+ if (ierr == ESMF_SUCCESS) ierr = 0
+ end if
+
+ end subroutine mpas_set_time
+
+
+ subroutine mpas_get_time(curr_time, YYYY, MM, DD, DoY, H, M, S, S_n, S_d, dateTimeString, ierr)
+
+ implicit none
+
+ type (MPAS_Time_type), intent(in) :: curr_time
+ integer, intent(out), optional :: YYYY
+ integer, intent(out), optional :: MM
+ integer, intent(out), optional :: DD
+ integer, intent(out), optional :: DoY
+ integer, intent(out), optional :: H
+ integer, intent(out), optional :: M
+ integer, intent(out), optional :: S
+ integer, intent(out), optional :: S_n
+ integer, intent(out), optional :: S_d
+ character (len=32), intent(out), optional :: dateTimeString
+ integer, intent(out), optional :: ierr
+
+ call ESMF_TimeGet(curr_time % t, YY=YYYY, MM=MM, DD=DD, H=H, M=M, S=S, Sn=S_n, Sd=S_d, rc=ierr)
+ call ESMF_TimeGet(curr_time % t, dayOfYear=DoY, rc=ierr)
+ call ESMF_TimeGet(curr_time % t, timeString=dateTimeString, rc=ierr)
+ if (present(ierr)) then
+ if (ierr == ESMF_SUCCESS) ierr = 0
+ end if
+
+ end subroutine mpas_get_time
+
+
+ subroutine mpas_set_timeInterval(interval, DD, H, M, S, S_n, S_d, timeString, dt, ierr)
+
+ implicit none
+
+ type (MPAS_TimeInterval_type), intent(out) :: interval
+ integer, intent(in), optional :: DD
+ integer, intent(in), optional :: H
+ integer, intent(in), optional :: M
+ integer, intent(in), optional :: S
+ integer, intent(in), optional :: S_n
+ integer, intent(in), optional :: S_d
+ character (len=*), intent(in), optional :: timeString
+ real (kind=RKIND), intent(in), optional :: dt
+ integer, intent(out), optional :: ierr
+
+ integer, parameter :: integerMaxDigits = 8
+ integer :: days, hours, minutes, seconds
+ integer :: numerator, denominator, denominatorPower
+ type (MPAS_TimeInterval_type) :: zeroInterval
+
+ integer :: day, hour, min, sec
+ character (len=50) :: timeString_
+ character (len=50) :: daySubString
+ character (len=50) :: timeSubString
+ character (len=50) :: secDecSubString
+ character(len=50), pointer, dimension(:) :: subStrings
+
+! if (present(DD)) then
+! days = DD
+! else
+! days = 0
+! end if
+
+! if (present(H)) then
+! hours = H
+! else
+! hours = 0
+! end if
+
+! if (present(M)) then
+! minutes = M
+! else
+! minutes = 0
+! end if
+
+! if (present(S)) then
+! seconds = S
+! else
+! seconds = 0
+! end if
+
+
+ !
+ ! Reduce minute count to something less than one hour
+ !
+! do while (minutes > 1440)
+! days = days + 1
+! minutes = minutes - 1440
+! end do
+! do while (minutes > 60)
+! hours = hours + 1
+! minutes = minutes - 60
+! end do
+! do while (minutes < -1440)
+! days = days - 1
+! minutes = minutes + 1440
+! end do
+! do while (minutes < -60)
+! hours = hours - 1
+! minutes = minutes + 60
+! end do
+
+ !
+ ! Reduce hour count to something less than one day
+ !
+! do while (hours > 24)
+! days = days + 1
+! hours = hours - 24
+! end do
+! do while (hours < -24)
+! days = days - 1
+! hours = hours + 24
+! end do
+
+ !
+ ! Any leftover minutes and hours are given to the second count
+ !
+! seconds = seconds + hours*3600 + minutes*60
+
+! call ESMF_TimeIntervalSet(interval % ti, D=days, S=seconds, Sn=S_n, Sd=S_d, rc=ierr)
+
+
+ if (present(timeString) .or. present(dt)) then
+
+
+ if(present(dt)) then
+ write (timeString_,*) "00:00:", dt
+ else
+ timeString_ = timeString
+ end if
+
+ numerator = 0
+ denominator = 1
+
+ call mpas_split_string(timeString_, ".", subStrings)
+
+ if (size(subStrings) == 2) then ! contains second decimals
+ timeString_ = subStrings(1)
+ secDecSubString = subStrings(2)(:integerMaxDigits)
+ deallocate(subStrings)
+
+ denominatorPower = len_trim(secDecSubString)
+ if(denominatorPower > 0) then
+ read(secDecSubString,*) numerator
+ if(numerator > 0) then
+ denominator = 10**denominatorPower
+ end if
+ end if
+ else if (size(subStrings) /= 1) then
+ deallocate(subStrings)
+ if (present(ierr)) ierr = 1
+ write(0,*) 'ERROR: Invalid TimeInterval string', timeString
+ return
+ end if
+
+ call mpas_split_string(timeString_, "_", subStrings)
+
+ if(size(subStrings) == 2) then ! contains a day and time
+ daySubString = subStrings(1)
+ timeSubString = subStrings(2)
+ deallocate(subStrings)
+ read(daySubString,*) day
+ else if(size(subStrings) == 1) then ! contains only a time- assume day is 0
+ timeSubString = subStrings(1)
+ deallocate(subStrings)
+ day = 0
+ else
+ deallocate(subStrings)
+ if (present(ierr)) ierr = 1
+ write(0,*) 'ERROR: Invalid TimeInterval string', timeString
+ return
+ end if
+
+ call mpas_split_string(timeSubString, ":", subStrings)
+
+ if (size(subStrings) == 3) then
+ read(subStrings(1),*) hour
+ read(subStrings(2),*) min
+ read(subStrings(3),*) sec
+ deallocate(subStrings)
+ else
+ deallocate(subStrings)
+ if (present(ierr)) ierr = 1
+ write(0,*) 'ERROR: Invalid TimeInterval string (invalid time substring)', timeString
+ return
+ end if
+
+ call ESMF_TimeIntervalSet(interval % ti, D=day, H=hour, M=min, S=sec, Sn=numerator, Sd=denominator, rc=ierr)
+
+ else
+
+ call ESMF_TimeIntervalSet(interval % ti, D=DD, H=H, M=M, S=S, Sn=S_n, Sd=S_d, rc=ierr)
+
+ end if
+
+ ! verify that time interval is positive
+ call ESMF_TimeIntervalSet(zeroInterval % ti, D=0, H=0, M=0, S=0, rc=ierr)
+
+ if (present(ierr)) then
+ if (ierr == ESMF_SUCCESS) ierr = 0
+ end if
+
+ if (interval <= zeroInterval) then
+ if (present(ierr)) ierr = 1
+ write(0,*) 'ERROR: TimeInterval must be greater than 0', timeString !'ERROR: TimeInterval cannot be negative'
+ end if
+
+
+
+ end subroutine mpas_set_timeInterval
+
+
+ subroutine mpas_get_timeInterval(interval, DD, H, M, S, S_n, S_d, timeString, dt, ierr)
+! TODO: add double-precision seconds
+
+ implicit none
+
+ type (MPAS_TimeInterval_type), intent(in) :: interval
+ integer, intent(out), optional :: DD
+ integer, intent(out), optional :: H
+ integer, intent(out), optional :: M
+ integer, intent(out), optional :: S
+ integer, intent(out), optional :: S_n
+ integer, intent(out), optional :: S_d
+ character (len=32), intent(out), optional :: timeString
+ real (kind=RKIND), intent(out), optional :: dt
+ integer, intent(out), optional :: ierr
+
+ integer :: days, seconds, sn, sd
+
+ call ESMF_TimeIntervalGet(interval % ti, D=days, S=seconds, Sn=sn, Sd=sd, rc=ierr)
+
+ if (present(dt)) then
+ dt = (days * 24 * 60 * 60) + seconds + (sn / sd)
+ end if
+
+ if (present(DD)) then
+ DD = days
+ days = 0
+ end if
+
+ if (present(H)) then
+ H = (seconds - mod(seconds,3600)) / 3600
+ seconds = seconds - H*3600
+ H = H + days * 24
+ days = 0
+ end if
+
+ if (present(M)) then
+ M = (seconds - mod(seconds,60)) / 60
+ seconds = seconds - M*60
+ M = M + days * 1440
+ days = 0
+ end if
+
+ if (present(S)) then
+ S = seconds
+ end if
+
+ if (present(S_n)) then
+ S_n = sn
+ end if
+
+ if (present(S_d)) then
+ S_d = sd
+ end if
+
+ if (present(timeString)) then
+ call ESMF_TimeIntervalGet(interval % ti, timeString=timeString, rc=ierr)
+ end if
+
+ if (present(ierr)) then
+ if (ierr == ESMF_SUCCESS) ierr = 0
+ end if
+
+ end subroutine mpas_get_timeInterval
+
+
+ type (MPAS_Time_type) function add_t_ti(t, ti)
+
+ implicit none
+
+ type (MPAS_Time_type), intent(in) :: t
+ type (MPAS_TimeInterval_type), intent(in) :: ti
+
+ add_t_ti % t = t % t + ti % ti
+
+ end function add_t_ti
+
+
+ type (MPAS_TimeInterval_type) function add_ti_ti(ti1, ti2)
+
+ implicit none
+
+ type (MPAS_TimeInterval_type), intent(in) :: ti1, ti2
+
+ add_ti_ti % ti = ti1 % ti + ti2 % ti
+
+ end function add_ti_ti
+
+
+ type (MPAS_TimeInterval_type) function sub_t_t(t1, t2)
+
+ implicit none
+
+ type (MPAS_Time_type), intent(in) :: t1, t2
+
+ sub_t_t % ti = t1 % t - t2 % t
+
+ end function sub_t_t
+
+
+ type (MPAS_Time_type) function sub_t_ti(t, ti)
+
+ implicit none
+
+ type (MPAS_Time_type), intent(in) :: t
+ type (MPAS_TimeInterval_type), intent(in) :: ti
+
+ sub_t_ti % t = t % t - ti % ti
+
+ end function sub_t_ti
+
+
+ type (MPAS_TimeInterval_type) function sub_ti_ti(ti1, ti2)
+
+ implicit none
+
+ type (MPAS_TimeInterval_type), intent(in) :: ti1, ti2
+
+ sub_ti_ti % ti = ti1 % ti - ti2 % ti
+
+ end function sub_ti_ti
+
+
+ type (MPAS_TimeInterval_type) function mul_ti_n(ti, n)
+
+ implicit none
+
+ type (MPAS_TimeInterval_type), intent(in) :: ti
+ integer, intent(in) :: n
+
+ mul_ti_n % ti = ti % ti * n
+
+ end function mul_ti_n
+
+
+ type (MPAS_TimeInterval_type) function div_ti_n(ti, n)
+
+ implicit none
+
+ type (MPAS_TimeInterval_type), intent(in) :: ti
+ integer, intent(in) :: n
+
+ div_ti_n % ti = ti % ti / n
+
+ end function div_ti_n
+
+
+ logical function eq_t_t(t1, t2)
+
+ implicit none
+
+ type (MPAS_Time_type), intent(in) :: t1, t2
+
+ eq_t_t = (t1 % t == t2 % t)
+
+ end function eq_t_t
+
+
+ logical function ne_t_t(t1, t2)
+
+ implicit none
+
+ type (MPAS_Time_type), intent(in) :: t1, t2
+
+ ne_t_t = (t1 % t /= t2 % t)
+
+ end function ne_t_t
+
+
+ logical function lt_t_t(t1, t2)
+
+ implicit none
+
+ type (MPAS_Time_type), intent(in) :: t1, t2
+
+ lt_t_t = (t1 % t < t2 % t)
+
+ end function lt_t_t
+
+
+ logical function gt_t_t(t1, t2)
+
+ implicit none
+
+ type (MPAS_Time_type), intent(in) :: t1, t2
+
+ gt_t_t = (t1 % t > t2 % t)
+
+ end function gt_t_t
+
+
+ logical function le_t_t(t1, t2)
+
+ implicit none
+
+ type (MPAS_Time_type), intent(in) :: t1, t2
+
+ le_t_t = (t1 % t <= t2 % t)
+
+ end function le_t_t
+
+
+ logical function ge_t_t(t1, t2)
+
+ implicit none
+
+ type (MPAS_Time_type), intent(in) :: t1, t2
+
+ ge_t_t = (t1 % t >= t2 % t)
+
+ end function ge_t_t
+
+
+ logical function eq_ti_ti(ti1, ti2)
+
+ implicit none
+
+ type (MPAS_TimeInterval_type), intent(in) :: ti1, ti2
+
+ eq_ti_ti = (ti1 % ti == ti2 % ti)
+
+ end function eq_ti_ti
+
+
+ logical function ne_ti_ti(ti1, ti2)
+
+ implicit none
+
+ type (MPAS_TimeInterval_type), intent(in) :: ti1, ti2
+
+ ne_ti_ti = (ti1 % ti /= ti2 % ti)
+
+ end function ne_ti_ti
+
+
+ logical function lt_ti_ti(ti1, ti2)
+
+ implicit none
+
+ type (MPAS_TimeInterval_type), intent(in) :: ti1, ti2
+
+ lt_ti_ti = (ti1 % ti < ti2 % ti)
+
+ end function lt_ti_ti
+
+
+ logical function gt_ti_ti(ti1, ti2)
+
+ implicit none
+
+ type (MPAS_TimeInterval_type), intent(in) :: ti1, ti2
+
+ gt_ti_ti = (ti1 % ti > ti2 % ti)
+
+ end function gt_ti_ti
+
+
+ logical function le_ti_ti(ti1, ti2)
+
+ implicit none
+
+ type (MPAS_TimeInterval_type), intent(in) :: ti1, ti2
+
+ le_ti_ti = (ti1 % ti <= ti2 % ti)
+
+ end function le_ti_ti
+
+
+ logical function ge_ti_ti(ti1, ti2)
+
+ implicit none
+
+ type (MPAS_TimeInterval_type), intent(in) :: ti1, ti2
+
+ ge_ti_ti = (ti1 % ti >= ti2 % ti)
+
+ end function ge_ti_ti
+
+
+ type (MPAS_TimeInterval_type) function neg_ti(ti)
+
+ implicit none
+
+ type (MPAS_TimeInterval_type), intent(in) :: ti
+
+ integer :: rc
+ integer :: D, S, Sn, Sd
+
+ call ESMF_TimeIntervalGet(ti % ti, D=D, S=S, Sn=Sn, Sd=Sd, rc=rc)
+ D = -D
+ S = -S
+ Sn = -Sn
+ call ESMF_TimeIntervalSet(neg_ti % ti, D=D, S=S, Sn=Sn, Sd=Sd, rc=rc)
+
+ end function neg_ti
+
+
+ type (MPAS_TimeInterval_type) function abs_ti(ti)
+
+ implicit none
+
+ type (MPAS_TimeInterval_type), intent(in) :: ti
+
+ type (MPAS_TimeInterval_type) :: zeroInterval
+ integer :: rc
+ integer :: D, S, Sn, Sd
+
+ call ESMF_TimeIntervalSet(zeroInterval % ti, D=0, H=0, M=0, S=0, rc=rc)
+
+ if(ti < zeroInterval) then
+ call ESMF_TimeIntervalGet(ti % ti, D=D, S=S, Sn=Sn, Sd=Sd, rc=rc)
+ D = -D
+ S = -S
+ Sn = -Sn
+ call ESMF_TimeIntervalSet(abs_ti % ti, D=D, S=S, Sn=Sn, Sd=Sd, rc=rc)
+ else
+ abs_ti = ti
+ end if
+
+ end function abs_ti
+
+
+! TODO: Implement this function
+! type (MPAS_TimeInterval_type) function mod(ti1, ti2)
+!
+! implicit none
+!
+! type (MPAS_TimeInterval_type), intent(in) :: ti1, ti2
+!
+! mod % ti = mod(ti1 % ti, ti2 % ti)
+!
+! end function mod
+
+
+ subroutine mpas_split_string(string, delimiter, subStrings)
+
+ implicit none
+
+ character(len=*), intent(in) :: string
+ character, intent(in) :: delimiter
+ character(len=*), pointer, dimension(:) :: subStrings
+
+ integer :: i, start, index
+
+ index = 1
+ do i = 1, len(string)
+ if(string(i:i) == delimiter) then
+ index = index + 1
+ end if
+ end do
+
+ allocate(subStrings(1:index))
+
+ start = 1
+ index = 1
+ do i = 1, len(string)
+ if(string(i:i) == delimiter) then
+ subStrings(index) = string(start:i-1)
+ index = index + 1
+ start = i + 1
+ end if
+ end do
+ subStrings(index) = string(start:len(string))
+
+ end subroutine mpas_split_string
+
+
+ subroutine mpas_get_month_day(YYYY, DoY, month, day)
+
+ implicit none
+
+ integer, intent(in) :: YYYY, DoY
+ integer, intent(out) :: month, day
+
+ integer, dimension(12) :: dpm
+
+ if (isLeapYear(YYYY)) then
+ dpm(:) = daysInMonthLeap
+ else
+ dpm(:) = daysInMonth
+ end if
+
+ month = 1
+ day = DoY
+ do while (day > dpm(month))
+ day = day - dpm(month)
+ month = month + 1
+ end do
+
+ end subroutine mpas_get_month_day
+
+
+ logical function isValidDate(YYYY, MM, DD)
+
+ integer, intent(in) :: YYYY, MM, DD
+ integer :: daysInMM
+
+ isValidDate = .true.
+
+ ! TODO: ???? Gregorian calendar has no year zero, but perhaps 0 = 1 BC ???
+ !if (YYYY == 0) then
+ ! isValidDate = .false.
+ ! return
+ !end if
+
+ if (MM < 1 .or. MM > 12) then
+ isValidDate = .false.
+ return
+ end if
+
+ if (DD < 1) then
+ isValidDate = .false.
+ return
+ end if
+
+ if(TheCalendar == MPAS_360DAY) then
+ daysInMM = 30
+ else
+ if (TheCalendar == MPAS_GREGORIAN .and. isLeapYear(YYYY)) then
+ daysInMM = daysInMonthLeap(MM)
+ else
+ daysInMM = daysInMonth(MM)
+ end if
+ end if
+
+ if (DD > daysInMM) then
+ isValidDate = .false.
+ return
+ end if
+
+ end function
+
+
+ logical function isLeapYear(year)
+
+ implicit none
+
+ integer, intent(in) :: year
+
+ isLeapYear = .false.
+
+ if (mod(year,4) == 0) then
+ if (mod(year,100) == 0) then
+ if (mod(year,400) == 0) then
+ isLeapYear = .true.
+ end if
+ else
+ isLeapYear = .true.
+ end if
+ end if
+
+ end function isLeapYear
+
+
+
+
+
+end module mpas_timekeeping
+
+
+
+subroutine wrf_error_fatal(msg)
+
+ implicit none
+
+ character (len=*) :: msg
+
+ write(0,*) 'MPAS_TIMEKEEPING: '//trim(msg)
+
+ stop
+
+end subroutine wrf_error_fatal
Copied: trunk/mpas/src/framework/mpas_timer.F (from rev 1113, branches/source_renaming/src/framework/mpas_timer.F)
===================================================================
--- trunk/mpas/src/framework/mpas_timer.F (rev 0)
+++ trunk/mpas/src/framework/mpas_timer.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -0,0 +1,293 @@
+ module mpas_timer
+
+ implicit none
+ save
+! private
+
+#ifdef _PAPI
+ include 'f90papi.h'
+#endif
+
+#ifdef _MPI
+ include 'mpif.h'
+#endif
+
+ type timer_node
+ character (len=72) :: timer_name
+ logical :: running, printable
+ integer :: levels, calls
+ real (kind=RKIND) :: start_time, end_time, total_time
+ real (kind=RKIND) :: max_time, min_time, avg_time
+ type (timer_node), pointer :: next
+ end type timer_node
+
+ type (timer_node), pointer :: all_timers
+ integer :: levels
+
+ public :: mpas_timer_start, &
+ mpas_timer_stop, &
+ mpas_timer_write
+
+ contains
+
+ subroutine mpas_timer_start(timer_name, clear_timer, timer_ptr)!{{{
+ character (len=*), intent (in) :: timer_name !< Input: name of timer, stored as name of timer
+ logical, optional, intent(in) :: clear_timer !< Input: flag to clear timer
+ type (timer_node), optional, pointer, intent(out) :: timer_ptr !< Output: pointer to store timer in module
+
+ logical :: timer_added, timer_found, string_equal, check_flag
+ type (timer_node), pointer :: current, temp
+
+ integer :: clock, hz, usecs
+
+ timer_added = .false.
+ timer_found = .false.
+
+ if(.not.associated(all_timers)) then
+ timer_added = .true.
+ allocate(all_timers)
+ allocate(all_timers%next)
+ levels = 0
+
+ all_timers%timer_name = ''
+ current => all_timers%next
+ nullify(current%next)
+ else
+ current => all_timers%next
+ timer_search: do while ((.not.timer_found) .and. associated(current))
+ string_equal = (trim(current%timer_name) == trim(timer_name))
+ if(string_equal) then
+ timer_found = .true.
+ else
+ current => current%next
+ endif
+ end do timer_search
+ endif
+
+ if(present(timer_ptr)) then
+ timer_found = .true.
+ if(.not.associated(timer_ptr)) then
+ current => all_timers
+ find_end_ptr: do while((.not.timer_added) .and. (associated(current%next)))
+ current => current%next
+ end do find_end_ptr
+
+ allocate(timer_ptr)
+
+ current%next => timer_ptr
+ current => timer_ptr
+ nullify(timer_ptr%next)
+ current%levels = levels
+ current%timer_name = timer_name
+ current%running = .false.
+ current%total_time = 0.0
+ current%max_time = 0.0
+ current%min_time = 100000000.0
+ current%avg_time = 0.0
+ current%calls = 0
+ endif
+ endif
+
+ if(.not.timer_found) then
+ current => all_timers
+ find_end: do while((.not.timer_added) .and. (associated(current%next)))
+ current => current%next
+ end do find_end
+
+ allocate(current%next)
+ current => current%next
+
+ nullify(current%next)
+ timer_added = .true.
+ endif
+
+ if(timer_added .and. (.not.timer_found)) then
+ current%levels = levels
+ current%timer_name = timer_name
+ current%running = .false.
+ current%total_time = 0.0
+ current%max_time = 0.0
+ current%min_time = 100000000.0
+ current%avg_time = 0.0
+ current%calls = 0
+ endif
+
+ if((timer_added .or. timer_found) .and. (.not.current%running)) then
+ current%running = .true.
+ levels = levels + 1
+
+#ifdef _PAPI
+ call PAPIF_get_real_usec(usecs, check_flag)
+ current%start_time = usecs/1.0e6
+#elif _MPI
+ current%start_time = MPI_Wtime()
+#else
+ call system_clock (count=clock)
+ call system_clock (count_rate=hz)
+ current%start_time = real(clock,kind=RKIND)/real(hz,kind=RKIND)
+#endif
+ endif
+
+ if(present(clear_timer)) then
+ if(clear_timer) then
+ current%start_time = 0.0
+ current%end_time = 0.0
+ current%total_time = 0.0
+ current%max_time = 0.0
+ current%min_time = 0.0
+ current%avg_time = 0.0
+ current%calls = 0
+ current%running = .false.
+ endif
+ endif
+
+ if(present(timer_ptr)) then
+ timer_ptr => current
+ endif
+
+ end subroutine mpas_timer_start!}}}
+
+ subroutine mpas_timer_stop(timer_name, timer_ptr)!{{{
+ character (len=*), intent(in) :: timer_name !< Input: name of timer to stop
+ type (timer_node), pointer, intent(in), optional :: timer_ptr !< Input: pointer to timer, for stopping
+
+ type (timer_node), pointer :: current
+
+ real (kind=RKIND) :: time_temp
+ logical :: timer_found, string_equal, check_flag
+ integer :: clock, hz, usecs
+
+ timer_found = .false.
+
+ if(present(timer_ptr)) then
+ timer_found = .true.
+ current => timer_ptr
+ endif
+
+ if(.not.associated(all_timers)) then
+ print *,' timer_stop :: timer_stop called with no timers initialized'
+ else if(.not. timer_found) then
+ current => all_timers
+ timer_find: do while(.not.timer_found .and. associated(current))
+ string_equal = (trim(current%timer_name) == trim(timer_name))
+
+ if(string_equal) then
+ timer_found = .true.
+ else
+ current => current%next
+ endif
+ end do timer_find
+ endif
+
+ if(.not.timer_found) then
+ print *,' timer_stop :: timer_stop called with timer_name =', timer_name,' when timer has not been started.'
+ stop
+ endif
+
+ if(current%running) then
+ current%running = .false.
+ levels = levels - 1
+
+#ifdef _PAPI
+ call PAPIF_get_real_usec(usecs, check_flag)
+ current%end_time = usecs/1.0e6
+#elif _MPI
+ current%end_time = MPI_Wtime()
+#else
+ call system_clock(count=clock)
+ call system_clock(count_rate=hz)
+ current%end_time = real(clock,kind=RKIND)/real(hz,kind=RKIND)
+#endif
+
+ time_temp = current%end_time - current%start_time
+ current%total_time = current%total_time + time_temp
+
+ if(time_temp > current%max_time) then
+ current%max_time = time_temp
+ endif
+
+ if(time_temp < current%min_time) then
+ current%min_time = time_temp
+ endif
+
+ current%avg_time = current%avg_time + time_temp
+ current%calls = current%calls + 1
+ endif
+
+ end subroutine mpas_timer_stop!}}}
+
+ recursive subroutine mpas_timer_write(timer_ptr, total_ptr)!{{{
+ type (timer_node), pointer, intent(inout), optional :: timer_ptr
+ type (timer_node), pointer, intent(in), optional :: total_ptr
+ character (len=10) :: tname
+
+ logical :: total_found, string_equals
+ type (timer_node), pointer :: current, total
+ real (kind=RKIND) :: percent
+ integer :: i
+
+ total_found = .false.
+
+ if(present(timer_ptr) .and. (.not.present(total_ptr))) then
+ print *,'timer_write :: timer_ptr valid, but total_ptr is not assigned.'
+ stop
+ else if(present(timer_ptr)) then
+ tname = ''
+ do i=0,timer_ptr%levels+2
+ tname = tname//' '
+! write(*,'(a,$)') ' '
+ end do
+! tname = tname//timer_ptr%timer_name
+
+ if(timer_ptr%total_time == 0.0d0) then
+ timer_ptr%min_time = 0.0d0
+ timer_ptr%max_time = 0.0d0
+ timer_ptr%avg_time = 0.0d0
+ percent = 0.0d0
+ else
+ timer_ptr%avg_time = timer_ptr%avg_time/timer_ptr%calls
+ percent = timer_ptr%total_time/total_ptr%total_time
+ endif
+
+ write(*,'(i2, 1x, a35, f15.5, i10, 3f15.5, f8.2)') timer_ptr%levels, tname(1:timer_ptr%levels)//timer_ptr%timer_name, timer_ptr%total_time, timer_ptr%calls, timer_ptr%min_time, timer_ptr%max_time, timer_ptr%avg_time, percent
+ return
+ endif
+
+ total => all_timers
+
+ find_total: do while((.not.total_found) .and. associated(total))
+ string_equals = (trim(total%timer_name) == trim("total time"))
+ if(string_equals) then
+ total_found = .true.
+ else
+ total => total%next
+ endif
+ end do find_total
+
+ if(.not.total_found) then
+ print *,' timer_write :: no timer named "total time" found.'
+ stop
+ end if
+
+ write(*,'(3x, a10, 24x, a15, a10, a13, a15, a15, a15)') 'timer_name', 'total', 'calls', 'min', 'max', 'avg', 'percent'
+ write(*,'(i2, 1x, a35, f15.5, i10, 3f15.5)') total%levels, total%timer_name, total%total_time, total%calls, total%min_time, total%max_time, total%avg_time
+
+ current => all_timers
+
+ print_timers: do while(associated(current))
+ string_equals = (trim(current%timer_name) == trim("total time"))
+ string_equals = string_equals .or. (trim(current%timer_name) == trim(" "))
+
+ if(.not.string_equals) then
+ call mpas_timer_write(current, total)
+ current => current%next
+ else
+ current => current%next
+ endif
+ end do print_timers
+
+ end subroutine mpas_timer_write!}}}
+
+ end module mpas_timer
+
+! vim: foldmethod=marker et ts=2
Copied: trunk/mpas/src/framework/mpas_zoltan_interface.F (from rev 1113, branches/source_renaming/src/framework/mpas_zoltan_interface.F)
===================================================================
--- trunk/mpas/src/framework/mpas_zoltan_interface.F (rev 0)
+++ trunk/mpas/src/framework/mpas_zoltan_interface.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -0,0 +1,581 @@
+module mpas_zoltan_interface
+ use zoltan
+
+ implicit none
+
+ include 'mpif.h'
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! Data for reordering cells
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ integer :: numCells
+ integer, dimension(:), pointer :: cellIDs
+ integer :: geomDim
+ real (kind=RKIND), dimension(:), pointer :: cellCoordX, cellCoordY, cellCoordZ
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! Data for reordering edges
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ integer :: numEdges
+ integer, dimension(:), pointer :: edgeIDs
+ real (kind=RKIND), dimension(:), pointer :: edgeCoordX, edgeCoordY, edgeCoordZ
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! Data for reordering vertices
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ integer :: numVerts
+ integer, dimension(:), pointer :: vertIDs
+ real (kind=RKIND), dimension(:), pointer :: vertCoordX, vertCoordY, vertCoordZ
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+ contains
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! Perhaps not necessary, but implemented in case it helps
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine mpas_zoltan_start()
+
+ integer(Zoltan_INT) :: error
+ real(Zoltan_FLOAT) :: version
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! Body of subroutine
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ error = Zoltan_Initialize(version)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ end subroutine
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine mpas_zoltan_order_loc_hsfc_cells(in_numcells,in_cellIDs,in_geomDim,in_cellX, &
+ in_cellY, in_cellZ)
+ implicit none
+
+ integer :: in_numcells
+ integer, dimension(:), pointer :: in_cellIDs
+ integer :: in_geomDim
+ real (kind=RKIND), dimension(:), pointer :: in_cellX, in_cellY, in_cellZ
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! local variables
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ type(Zoltan_Struct), pointer :: zz_obj
+ integer(ZOLTAN_INT) :: ierr
+
+ integer :: numGidEntries, i
+ integer(ZOLTAN_INT), allocatable :: global_ids(:), permIndices(:),permGIDs(:)
+ real(kind=RKIND), allocatable :: permXs(:),permYs(:),permZs(:)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! Body of subroutine
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ numCells = in_numcells
+ cellIDs => in_cellIDs
+ geomDim = in_geomDim
+ cellCoordX => in_cellX
+ cellCoordY => in_cellY
+ cellCoordZ => in_cellZ
+
+ nullify(zz_obj)
+ zz_obj => Zoltan_Create(MPI_COMM_SELF)
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! General Zoltan Parameters
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ierr = Zoltan_Set_Param(zz_obj, "ORDER_METHOD", "LOCAL_HSFC")
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! register query functions
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ierr = Zoltan_Set_Fn(zz_obj, ZOLTAN_NUM_OBJ_FN_TYPE,zqfNumCells)
+ ierr = Zoltan_Set_Fn(zz_obj, ZOLTAN_OBJ_LIST_FN_TYPE,zqfGetCells)
+ ierr = Zoltan_Set_Fn(zz_obj, ZOLTAN_NUM_GEOM_FN_TYPE,zqfGeomDim)
+ ierr = Zoltan_Set_Fn(zz_obj, ZOLTAN_GEOM_FN_TYPE, zqfGetCellGeom)
+
+ numGidEntries=1
+
+ allocate(global_ids(numCells))
+ allocate(permIndices(numCells))
+ allocate(permGIDs(numCells))
+ allocate(permXs(numCells))
+ allocate(permYs(numCells))
+ allocate(permZs(numCells))
+
+ !! MMW: There might be a way to use cellIDs directly
+ do i=1,numCells
+ global_ids(i) = cellIDs(i)
+ end do
+
+ ierr = Zoltan_Order(zz_obj, numGidEntries, numCells, global_ids, permIndices);
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! This is necessary for now until we fix a small bug in Zoltan_Order
+ !!!!!!!!!!!!!!!!!!!!!!!!!!
+ do i=1,numCells
+ permGIDs(i) = global_ids(permIndices(i)+1)
+ permXs(i) = cellCoordX(permIndices(i)+1)
+ permYs(i) = cellCoordY(permIndices(i)+1)
+ permZs(i) = cellCoordZ(permIndices(i)+1)
+ end do
+
+ !!do i=1,numCells
+ !! write(*,*) global_ids(i), permGIDs(i)
+ !!end do
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! Actually change the ordering of the cells
+ !!!!!!!!!!!!!!!!!!!!!!!!!!
+ do i=1,numCells
+ cellIDs(i) = permGIDs(i)
+ cellCoordX(i) = permXs(i)
+ cellCoordY(i) = permYs(i)
+ cellCoordZ(i) = permZs(i)
+ end do
+ !!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ deallocate(global_ids)
+ deallocate(permIndices)
+ deallocate(permGIDs)
+ deallocate(permXs)
+ deallocate(permYs)
+ deallocate(permZs)
+
+ call Zoltan_Destroy(zz_obj)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ end subroutine mpas_zoltan_order_loc_hsfc_cells
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! zoltan query function:
+ !! Returns number of cells
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ integer function zqfNumCells(data, ierr)
+
+ ! Local declarations
+ integer(ZOLTAN_INT), intent(in) :: data(*)
+ integer(ZOLTAN_INT), intent(out) :: ierr
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ zqfNumCells = numCells
+ ierr = ZOLTAN_OK
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ end function zqfNumCells
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! zoltan query function:
+ !! Returns lists of Cell IDs
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine mpas_zqf_get_cells (data, num_gid_entries, num_lid_entries, global_ids, &
+ local_ids, wgt_dim, obj_wgts, ierr)
+ integer(ZOLTAN_INT), intent(in) :: data(*)
+ integer(ZOLTAN_INT), intent(in) :: num_gid_entries, num_lid_entries
+ integer(ZOLTAN_INT), intent(out) :: global_ids(*), local_ids(*)
+ integer(ZOLTAN_INT), intent(in) :: wgt_dim
+ real(ZOLTAN_FLOAT), intent(out) :: obj_wgts(*)
+ integer(ZOLTAN_INT), intent(out) :: ierr
+
+ ! local declarations
+ integer :: i
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ do i= 1, numCells
+ global_ids(i) = cellIDs(i)
+ local_ids(i) = i
+ end do
+
+ ierr = ZOLTAN_OK
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ end subroutine mpas_zqf_get_cells
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! Zoltan Query Function:
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ integer function zqfGeomDim(data, ierr)
+ !use zoltan
+ implicit none
+ integer(ZOLTAN_INT), intent(in) :: data(*)
+ integer(ZOLTAN_INT) :: ierr
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ zqfGeomDim = geomDim
+ ierr = ZOLTAN_OK
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ end function zqfGeomDim
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! Zoltan Query Function:
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine mpas_zqf_get_cell_geom(data, num_gid_entries, num_lid_entries, global_id, &
+ local_id, geom_vec, ierr)
+ !use zoltan
+ implicit none
+
+ integer(ZOLTAN_INT), intent(in) :: data(*)
+ integer(ZOLTAN_INT), intent(in) :: num_gid_entries, num_lid_entries
+ integer(ZOLTAN_INT), intent(in) :: global_id, local_id
+ real(ZOLTAN_DOUBLE), intent(out) :: geom_vec(*)
+ integer(ZOLTAN_INT), intent(out) :: ierr
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! Assuming geom_dim is 3
+ geom_vec(1) = cellCoordX(local_id)
+ geom_vec(2) = cellCoordY(local_id)
+ geom_vec(3) = cellCoordZ(local_id)
+
+ ierr = ZOLTAN_OK
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ end subroutine mpas_zqf_get_cell_geom
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! The ordering functions should perhaps be refactored so that there
+ !! are not separate functions for cells, edges, and vertices
+ !! Not sure if this is worth it with the additional conditionals that would
+ !! be required.
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine mpas_zoltan_order_loc_hsfc_edges(in_numedges,in_edgeIDs,in_geomDim,in_edgeX, &
+ in_edgeY, in_edgeZ)
+ implicit none
+
+ integer :: in_numedges
+ integer, dimension(:), pointer :: in_edgeIDs
+ integer :: in_geomDim
+ real (kind=RKIND), dimension(:), pointer :: in_edgeX, in_edgeY, in_edgeZ
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! local variables
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ type(Zoltan_Struct), pointer :: zz_obj
+ integer(ZOLTAN_INT) :: ierr
+
+ integer :: numGidEntries, i
+ integer(ZOLTAN_INT), allocatable :: global_ids(:), permIndices(:),permGIDs(:)
+ real(kind=RKIND), allocatable :: permXs(:),permYs(:),permZs(:)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! Body of subroutine
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ numEdges = in_numedges
+ edgeIDs => in_edgeIDs
+ geomDim = in_geomDim
+ edgeCoordX => in_edgeX
+ edgeCoordY => in_edgeY
+ edgeCoordZ => in_edgeZ
+
+ nullify(zz_obj)
+ zz_obj => Zoltan_Create(MPI_COMM_SELF)
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! General Zoltan Parameters
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ierr = Zoltan_Set_Param(zz_obj, "ORDER_METHOD", "LOCAL_HSFC")
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! register query functions
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ierr = Zoltan_Set_Fn(zz_obj, ZOLTAN_NUM_OBJ_FN_TYPE,zqfNumEdges)
+ ierr = Zoltan_Set_Fn(zz_obj, ZOLTAN_OBJ_LIST_FN_TYPE,zqfGetEdges)
+ ierr = Zoltan_Set_Fn(zz_obj, ZOLTAN_NUM_GEOM_FN_TYPE,zqfGeomDim)
+ ierr = Zoltan_Set_Fn(zz_obj, ZOLTAN_GEOM_FN_TYPE, zqfGetEdgeGeom)
+
+ numGidEntries=1
+
+ allocate(global_ids(numEdges))
+ allocate(permIndices(numEdges))
+ allocate(permGIDs(numEdges))
+ allocate(permXs(numEdges))
+ allocate(permYs(numEdges))
+ allocate(permZs(numEdges))
+
+ !! MMW: There might be a way to use edgeIDs directly
+ do i=1,numEdges
+ global_ids(i) = edgeIDs(i)
+ end do
+
+ ierr = Zoltan_Order(zz_obj, numGidEntries, numEdges, global_ids, permIndices);
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! This is necessary for now until we fix a small bug in Zoltan_Order
+ !!!!!!!!!!!!!!!!!!!!!!!!!!
+ do i=1,numEdges
+ permGIDs(i) = global_ids(permIndices(i)+1)
+ permXs(i) = edgeCoordX(permIndices(i)+1)
+ permYs(i) = edgeCoordY(permIndices(i)+1)
+ permZs(i) = edgeCoordZ(permIndices(i)+1)
+ end do
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! Actually change the ordering of the edges
+ !!!!!!!!!!!!!!!!!!!!!!!!!!
+ do i=1,numEdges
+ edgeIDs(i) = permGIDs(i)
+ edgeCoordX(i) = permXs(i)
+ edgeCoordY(i) = permYs(i)
+ edgeCoordZ(i) = permZs(i)
+ end do
+ !!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ deallocate(global_ids)
+ deallocate(permIndices)
+ deallocate(permGIDs)
+ deallocate(permXs)
+ deallocate(permYs)
+ deallocate(permZs)
+
+ call Zoltan_Destroy(zz_obj)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ end subroutine mpas_zoltan_order_loc_hsfc_edges
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! zoltan query function:
+ !! Returns number of edges
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ integer function zqfNumEdges(data, ierr)
+ ! Local declarations
+ integer(ZOLTAN_INT), intent(in) :: data(*)
+ integer(ZOLTAN_INT), intent(out) :: ierr
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ zqfNumEdges = numEdges
+ ierr = ZOLTAN_OK
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ end function zqfNumEdges
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! zoltan query function:
+ !! Returns lists of Edge IDs
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine mpas_zqf_get_edges (data, num_gid_entries, num_lid_entries, global_ids, &
+ local_ids, wgt_dim, obj_wgts, ierr)
+ integer(ZOLTAN_INT), intent(in) :: data(*)
+ integer(ZOLTAN_INT), intent(in) :: num_gid_entries, num_lid_entries
+ integer(ZOLTAN_INT), intent(out) :: global_ids(*), local_ids(*)
+ integer(ZOLTAN_INT), intent(in) :: wgt_dim
+ real(ZOLTAN_FLOAT), intent(out) :: obj_wgts(*)
+ integer(ZOLTAN_INT), intent(out) :: ierr
+
+ ! local declarations
+ integer :: i
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ do i= 1, numEdges
+ global_ids(i) = edgeIDs(i)
+ local_ids(i) = i
+ end do
+
+ ierr = ZOLTAN_OK
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ end subroutine mpas_zqf_get_edges
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! Zoltan Query Function:
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine mpas_zqf_get_edge_geom(data, num_gid_entries, num_lid_entries, global_id, &
+ local_id, geom_vec, ierr)
+ !use zoltan
+ implicit none
+
+ integer(ZOLTAN_INT), intent(in) :: data(*)
+ integer(ZOLTAN_INT), intent(in) :: num_gid_entries, num_lid_entries
+ integer(ZOLTAN_INT), intent(in) :: global_id, local_id
+ real(ZOLTAN_DOUBLE), intent(out) :: geom_vec(*)
+ integer(ZOLTAN_INT), intent(out) :: ierr
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! Assuming geom_dim is 3
+ geom_vec(1) = edgeCoordX(local_id)
+ geom_vec(2) = edgeCoordY(local_id)
+ geom_vec(3) = edgeCoordZ(local_id)
+
+ ierr = ZOLTAN_OK
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ end subroutine mpas_zqf_get_edge_geom
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine mpas_zoltan_order_loc_hsfc_verts(in_numverts,in_vertIDs,in_geomDim,in_vertX, &
+ in_vertY, in_vertZ)
+ implicit none
+
+ integer :: in_numverts
+ integer, dimension(:), pointer :: in_vertIDs
+ integer :: in_geomDim
+ real (kind=RKIND), dimension(:), pointer :: in_vertX, in_vertY, in_vertZ
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! local variables
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ type(Zoltan_Struct), pointer :: zz_obj
+ integer(ZOLTAN_INT) :: ierr
+
+ integer :: numGidEntries, i
+ integer(ZOLTAN_INT), allocatable :: global_ids(:), permIndices(:),permGIDs(:)
+ real(kind=RKIND), allocatable :: permXs(:),permYs(:),permZs(:)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! Body of subroutine
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ numVerts = in_numverts
+ vertIDs => in_vertIDs
+ geomDim = in_geomDim
+ vertCoordX => in_vertX
+ vertCoordY => in_vertY
+ vertCoordZ => in_vertZ
+
+ nullify(zz_obj)
+ zz_obj => Zoltan_Create(MPI_COMM_SELF)
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! General Zoltan Parameters
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ierr = Zoltan_Set_Param(zz_obj, "ORDER_METHOD", "LOCAL_HSFC")
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! register query functions
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ierr = Zoltan_Set_Fn(zz_obj, ZOLTAN_NUM_OBJ_FN_TYPE,zqfNumVerts)
+ ierr = Zoltan_Set_Fn(zz_obj, ZOLTAN_OBJ_LIST_FN_TYPE,zqfGetVerts)
+ ierr = Zoltan_Set_Fn(zz_obj, ZOLTAN_NUM_GEOM_FN_TYPE,zqfGeomDim)
+ ierr = Zoltan_Set_Fn(zz_obj, ZOLTAN_GEOM_FN_TYPE, zqfGetVertGeom)
+
+ numGidEntries=1
+
+ allocate(global_ids(numVerts))
+ allocate(permIndices(numVerts))
+ allocate(permGIDs(numVerts))
+ allocate(permXs(numVerts))
+ allocate(permYs(numVerts))
+ allocate(permZs(numVerts))
+
+ !! MMW: There might be a way to use vertIDs directly
+ do i=1,numVerts
+ global_ids(i) = vertIDs(i)
+ end do
+
+ ierr = Zoltan_Order(zz_obj, numGidEntries, numVerts, global_ids, permIndices);
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! This is necessary for now until we fix a small bug in Zoltan_Order
+ !!!!!!!!!!!!!!!!!!!!!!!!!!
+ do i=1,numVerts
+ permGIDs(i) = global_ids(permIndices(i)+1)
+ permXs(i) = vertCoordX(permIndices(i)+1)
+ permYs(i) = vertCoordY(permIndices(i)+1)
+ permZs(i) = vertCoordZ(permIndices(i)+1)
+ end do
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! Actually change the ordering of the verts
+ !!!!!!!!!!!!!!!!!!!!!!!!!!
+ do i=1,numVerts
+ vertIDs(i) = permGIDs(i)
+ vertCoordX(i) = permXs(i)
+ vertCoordY(i) = permYs(i)
+ vertCoordZ(i) = permZs(i)
+ end do
+ !!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ deallocate(global_ids)
+ deallocate(permIndices)
+ deallocate(permGIDs)
+ deallocate(permXs)
+ deallocate(permYs)
+ deallocate(permZs)
+
+ call Zoltan_Destroy(zz_obj)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ end subroutine mpas_zoltan_order_loc_hsfc_verts
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! zoltan query function:
+ !! Returns number of verts
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ integer function zqfNumVerts(data, ierr)
+
+ ! Local declarations
+ integer(ZOLTAN_INT), intent(in) :: data(*)
+ integer(ZOLTAN_INT), intent(out) :: ierr
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ zqfNumVerts = numVerts
+ ierr = ZOLTAN_OK
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ end function zqfNumVerts
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! zoltan query function:
+ !! Returns lists of Vert IDs
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine mpas_zqf_get_verts (data, num_gid_entries, num_lid_entries, global_ids, &
+ local_ids, wgt_dim, obj_wgts, ierr)
+
+ integer(ZOLTAN_INT), intent(in) :: data(*)
+ integer(ZOLTAN_INT), intent(in) :: num_gid_entries, num_lid_entries
+ integer(ZOLTAN_INT), intent(out) :: global_ids(*), local_ids(*)
+ integer(ZOLTAN_INT), intent(in) :: wgt_dim
+ real(ZOLTAN_FLOAT), intent(out) :: obj_wgts(*)
+ integer(ZOLTAN_INT), intent(out) :: ierr
+
+ ! local declarations
+ integer :: i
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ do i= 1, numVerts
+ global_ids(i) = vertIDs(i)
+ local_ids(i) = i
+ end do
+
+ ierr = ZOLTAN_OK
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ end subroutine mpas_zqf_get_verts
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! Zoltan Query Function:
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine mpas_zqf_get_vert_geom(data, num_gid_entries, num_lid_entries, global_id, &
+ local_id, geom_vec, ierr)
+ !use zoltan
+ implicit none
+
+ integer(ZOLTAN_INT), intent(in) :: data(*)
+ integer(ZOLTAN_INT), intent(in) :: num_gid_entries, num_lid_entries
+ integer(ZOLTAN_INT), intent(in) :: global_id, local_id
+ real(ZOLTAN_DOUBLE), intent(out) :: geom_vec(*)
+ integer(ZOLTAN_INT), intent(out) :: ierr
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! Assuming geom_dim is 3
+ geom_vec(1) = vertCoordX(local_id)
+ geom_vec(2) = vertCoordY(local_id)
+ geom_vec(3) = vertCoordZ(local_id)
+
+ ierr = ZOLTAN_OK
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ end subroutine mpas_zqf_get_vert_geom
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+
+
+end module mpas_zoltan_interface
Modified: trunk/mpas/src/operators/Makefile
===================================================================
--- trunk/mpas/src/operators/Makefile 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/operators/Makefile 2011-10-21 19:18:00 UTC (rev 1114)
@@ -1,15 +1,15 @@
.SUFFIXES: .F .o
-OBJS = module_RBF_interpolation.o module_vector_reconstruction.o module_spline_interpolation.o
+OBJS = mpas_rbf_interpolation.o mpas_vector_reconstruction.o mpas_spline_interpolation.o
all: operators
operators: $(OBJS)
ar -ru libops.a $(OBJS)
-module_vector_reconstruction.o: module_RBF_interpolation.o
-module_RBF_interpolation.o:
-module_spline_interpolation:
+mpas_vector_reconstruction.o: mpas_rbf_interpolation.o
+mpas_rbf_interpolation.o:
+mpas_spline_interpolation:
clean:
$(RM) *.o *.mod *.f90 libops.a
Deleted: trunk/mpas/src/operators/module_RBF_interpolation.F
===================================================================
--- trunk/mpas/src/operators/module_RBF_interpolation.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/operators/module_RBF_interpolation.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -1,1824 +0,0 @@
-module RBF_interpolation
- use dmpar
- use grid_types
-
- implicit none
- private
- save
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Purpose: perform interpolation of scalar and vector functions in 2D
-! and 3D using Radial Basis Functions (RBFs).
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- ! Initialize the geometry that will be useful from interpolation
- public :: rbfInterp_initialize
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Routines for perofrming interpolation in 2D (including Jacobian and Hessian)
- ! at locations that vary using a function that is fixed. This is useful
- ! for finding the location on the the RBF reconstruction of a function
- ! (e.g., a height field) that minimizes the distance to a point in 3D space
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- public :: rbfInterp_loc_2D_sca_const_compCoeffs, &
- rbfInterp_loc_2D_sca_lin_compCoeffs, &
- rbfInterp_loc_2D_sca_const_evalWithDerivs, &
- rbfInterp_loc_2D_sca_lin_evalWithDerivs
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Routines for computing scalar interpolaiton coefficients in 3D (coplanar points
- ! in 3D) with support for either constant or constant and linear basis
- ! functions in addition to RBFs. In constrast to the two subroutines
- ! above, these coefficients are valid for computing the value of the
- ! interpolant at a fixe point in space using function values that may
- ! vary (e.g., in time) at each of the interpolation "source" points.
- ! The last 3 routines can be used to compute coefficients for imposing both Neumann
- ! and Dirichlet boundary conditions.
- ! Pseudocode for function reconstruction at the destinationPoint is as follows
- ! Dirichlet: functionAtDestination = sum(functionAtSources*dirichletCoefficients)
- ! Neumann: functionAtDestination = sum(functionOrDerivAtSources*neumannCoefficients)
- ! where functionOrDerivAtSource = functionAtSources where .not.(isInterface)
- ! = functionNormalDerivAtSources where isInterface
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- public :: rbfInterp_func_3D_sca_const_dir_compCoeffs, &
- rbfInterp_func_3DPlane_sca_lin_dir_compCoeffs, &
- rbfInterp_func_3D_sca_lin_dir_compCoeffs, &
- rbfInterp_func_3D_sca_const_dirNeu_compCoeffs, &
- rbfInterp_func_3DPlane_sca_lin_dirNeu_compCoeffs, &
- rbfInterp_func_3D_sca_lin_dirNeu_compCoeffs
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Routines for computing vector interpolaiton coefficients in 3D (coplanar points
- ! in 3D) with support for only constant basis functions in addition to RBFs.
- ! (Linear basis functions can cause problems: a linear vortex flow u = y xHat - x yHat
- ! cannot be reconstructed from vectors that are only normal to the cell edges in 2D.
- ! Therefore, we don't support them). As with the scalar 3D subroutines
- ! above, these coefficients are valid for computing the value of the
- ! interpolant at a fixe point in space using function values that may
- ! vary (e.g., in time) at each of the interpolation "source" points.
- ! The user supplies to these routines a set of sourcePoints and unitVectors
- ! as well as a destinationPoint and, for the last 2 routines, flags for
- ! which points are tangent to the interface and which of the supplied unitVectors
- ! is the normal at the corresponding point.
- !
- ! The first two routines compute coefficients that can be used to interpolate
- ! a vector function to the destination point given "function dot unitVector" values
- ! at each source point. These routines are useful, for example, for reconstructing
- ! the full vector velocity at cell centers from the normal components of the velocity
- ! at cell faces (or cell edges in 2D), or for computing the full velocity at an
- ! immersed boundary image point based on the normal velocity at several faces and
- ! the full velocity at boundary points (e.g., a no-slip boundary condition).
- !
- ! The last two routines compute coefficients that can be used to interpolate
- ! a vector function to the destination point given "function dot unitVector" values
- ! at non-tangent source point and "dFunction/dn dot unitVector" values at
- ! tangent source point. These routines are useful, for example, for computing the
- ! full velocity at an immersed boundary image point based on the normal velocity at
- ! several faces, the normal velocity at boundary points (e.g., u dot n = 0 for a
- ! no-penetration boundary condition on a fixed boundary), and the normal derivative
- ! of the tangential components of velocity at the boundary points (e.g., a free-slip
- ! boundary condition).
- ! Pseudocode for function reconstruction at the destinationPoint is as follows
- ! dirichlet: functionAtDestination_i = sum_j(functionDotUnitVectorAtSources_j*coefficients_j,i)
- ! for i = x,y,z
- ! tangentNeumann: functionAtDestination_i &
- ! = sum_(j where .not isTangent) (functionDotUnitVectorAtSources_j*coefficients_j,i) &
- ! + sum_(j where isTangent) ((dFunction/dn dot UnitVector)_j*coefficients_j,i)
- ! for i = x,y,z
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- public :: rbfInterp_func_3D_vec_const_dir_compCoeffs, &
- rbfInterp_func_3DPlane_vec_const_dir_compCoeffs!, &
- !rbfInterp_func_3D_vec_const_tanNeu_compCoeffs, &
- !rbfInterp_func_3DPlane_vec_const_tanNeu_compCoeffs
-
- contains
-
- subroutine rbfInterp_initialize(grid)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Purpose: compute geometric fields that will be potentially useful for calling
- ! the interpolation routines
- !
- ! Input: the grid
- !
- ! Output:
- ! edgeNormalVectors - the unit vector at the center of each edge tangent to the sphere
- ! cellTangentPlane - 2 orthogonal unit vectors in the tangent plane of each cell
- ! The first unit vector is chosen to point toward the center of the first
- ! edge on the cell.
- ! localVerticalUnitVectors - the unit normal vector of the tangent plane at the center
- ! of each cell
- !
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (mesh_type), intent(inout) :: grid
-
- integer :: nCells, nEdges
- integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnCell
- integer :: iEdge, iCell, cell1, cell2
- real(kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell, xEdge, yEdge, zEdge
- real(kind=RKIND), dimension(:,:), pointer :: localVerticalUnitVectors, edgeNormalVectors
- real(kind=RKIND), dimension(:,:,:), pointer :: cellTangentPlane
- real(kind=RKIND), dimension(3) :: xHatPlane, yHatPlane, rHat
- real(kind=RKIND) :: normalDotRHat
- logical :: on_a_sphere
-
- xCell => grid % xCell % array
- yCell => grid % yCell % array
- zCell => grid % zCell % array
- xEdge => grid % xEdge % array
- yEdge => grid % yEdge % array
- zEdge => grid % zEdge % array
- cellsOnEdge => grid % cellsOnEdge % array
- edgesOnCell => grid % edgesOnCell % array
- nCells = grid % nCells
- nEdges = grid % nEdges
- on_a_sphere = grid % on_a_sphere
-
- localVerticalUnitVectors => grid % localVerticalUnitVectors % array
- edgeNormalVectors => grid % edgeNormalVectors % array
- cellTangentPlane => grid % cellTangentPlane % array
-
- ! init arrays
- edgeNormalVectors = 0
- localVerticalUnitVectors = 0
-
- ! loop over all cells to be solved on this block
- do iCell=1,nCells
- if(on_a_sphere) then
- localVerticalUnitVectors(1,iCell) = xCell(iCell)
- localVerticalUnitVectors(2,iCell) = yCell(iCell)
- localVerticalUnitVectors(3,iCell) = zCell(iCell)
- call unit_vec_in_R3(localVerticalUnitVectors(:,iCell))
- else ! on a plane
- localVerticalUnitVectors(:,iCell) = (/ 0., 0., 1. /)
- end if
- end do
-
- do iEdge = 1,nEdges
- iCell = cellsOnEdge(1,iEdge) ! the normal vector points from the first cell toward the edge
- if(iCell == nCells+1) then ! this is a boundary edge
- ! the first cell bordering this edge is not real, use the second cell
- ! The normal should always point outward at boundaries, away from the valid cell center
- iCell = cellsOnEdge(2,iEdge)
- end if
- ! the normal points from the cell location to the edge location
- edgeNormalVectors(1,iEdge) = xEdge(iEdge) - xCell(iCell)
- edgeNormalVectors(2,iEdge) = yEdge(iEdge) - yCell(iCell)
- edgeNormalVectors(3,iEdge) = zEdge(iEdge) - zCell(iCell)
- call unit_vec_in_R3(edgeNormalVectors(:,iEdge))
- end do
-
- do iCell=1,nCells
- iEdge = edgesOnCell(1,iCell)
- ! xHat and yHat are a local basis in the plane of the horizontal cell
- ! we arbitrarily choose xHat to point toward the first edge
- rHat = localVerticalUnitVectors(:,iCell)
- normalDotRHat = sum(edgeNormalVectors(:,iEdge)*rHat)
- xHatPlane = edgeNormalVectors(:,iEdge) - normalDotRHat*rHat
- call unit_vec_in_R3(xHatPlane)
-
- call cross_product_in_R3(rHat, xHatPlane, yHatPlane)
- call unit_vec_in_R3(yHatPlane) ! just to be sure...
- cellTangentPlane(:,1,iCell) = xHatPlane
- cellTangentPlane(:,2,iCell) = yHatPlane
- end do
-
- end subroutine rbfInterp_initialize
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Purpose: Compute interpolation coefficients in 2D that can be used to
- ! reconstruct a given scalar function at varying locations. This is useful
- ! for finding the location on the the RBF reconstruction of a function
- ! (e.g., a height field) that minimizes the distance to a point in 3D space.
- ! The reconstruction is performed with basis functions that are RBFs and constant
- ! Input:
- ! pointCount - the number of "source" points and functionValues supplied
- ! coeffCount - the size of coefficients, must be at least pointCount + 1
- ! points - the location of the "source" points in the 2D space where the values of
- ! the function are known
- ! fieldValues - the values of the function of interest at the points
- ! alpha - a constant that give the characteristic length scale of the RBFs,
- ! should be on the order of the distance between points
- ! Output:
- ! coefficients - the coefficients needed to perform interpolation of the funciton
- ! at destination points yet to be specified
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine rbfInterp_loc_2D_sca_const_compCoeffs(pointCount, coeffCount, &
- points, fieldValues, alpha, coefficients)
-
- integer, intent(in) :: pointCount, coeffCount
- real(kind=RKIND), dimension(pointCount,2), intent(in) :: points
- real(kind=RKIND), dimension(pointCount), intent(in) :: fieldValues
- real(kind=RKIND), intent(in) :: alpha
- real(kind=RKIND), dimension(coeffCount), intent(out) :: coefficients
-
- integer :: i, j, matrixSize
- real(kind=RKIND), dimension(pointCount+1,pointCount+1) :: matrix
- real(kind=RKIND), dimension(pointCount+1) :: rhs
- integer, dimension(pointCount+1) :: pivotIndices
- real(kind=RKIND) :: rSquared
-
- matrixSize = pointCount+1
- coefficients = 0.0
- matrix = 0.0
- rhs = 0.0
-
- rhs(1:pointCount) = fieldValues
-
- do j=1,pointCount
- do i=j,pointCount
- rSquared = sum((points(j,:) - points(i,:))**2)/alpha**2
- matrix(i,j) = evaluateRBF(rSquared)
- matrix(j,i) = matrix(i,j)
- end do
- end do
- do j=1,pointCount
- matrix(pointCount+1,j) = 1.0
- matrix(j,pointCount+1) = 1.0
- end do
-
- call LEGS(matrix(1:matrixSize,1:matrixSize), matrixSize, rhs(1:matrixSize), &
- coefficients(1:matrixSize), pivotIndices(1:matrixSize))
-
- end subroutine rbfInterp_loc_2D_sca_const_compCoeffs
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Purpose: Compute interpolation coefficients in 2D that can be used to
- ! reconstruct a given scalar function at varying locations. This is useful
- ! for finding the location on the the RBF reconstruction of a function
- ! (e.g., a height field) that minimizes the distance to a point in 3D space.
- ! The reconstruction is performed with basis functions that are RBFs plus constant
- ! and linear
- ! Input:
- ! pointCount - the number of "source" points and functionValues supplied
- ! coeffCount - the size of coefficients, must be at least pointCount + 3
- ! points - the location of the "source" points in the 2D space where the values of
- ! the function are known
- ! fieldValues - the values of the function of interest at the points
- ! alpha - a constant that give the characteristic length scale of the RBFs,
- ! should be on the order of the distance between points
- ! Output:
- ! coefficients - the coefficients needed to perform interpolation of the funciton
- ! at destination points yet to be specified
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine rbfInterp_loc_2D_sca_lin_compCoeffs(pointCount, coeffCount, &
- points, fieldValues, alpha, coefficients)
-
- integer, intent(in) :: pointCount, coeffCount
- real(kind=RKIND), dimension(pointCount,2), intent(in) :: points
- real(kind=RKIND), dimension(pointCount), intent(in) :: fieldValues
- real(kind=RKIND), intent(in) :: alpha
- real(kind=RKIND), dimension(coeffCount), intent(out) :: coefficients
-
- integer :: i, j, matrixSize
- real(kind=RKIND), dimension(pointCount+3,pointCount+3) :: matrix
- real(kind=RKIND), dimension(pointCount+3) :: rhs
- integer, dimension(pointCount+3) :: pivotIndices
- real(kind=RKIND) :: rSquared
-
- coefficients = 0.0
- matrix = 0.0
- rhs = 0.0
-
- rhs(1:pointCount) = fieldValues
-
- do j=1,pointCount
- do i=j,pointCount
- rSquared = sum((points(j,:) - points(i,:))**2)/alpha**2
- matrix(i,j) = evaluateRBF(rSquared)
- matrix(j,i) = matrix(i,j)
- end do
- end do
- matrixSize = pointCount+3
- do j=1,pointCount
- matrix(pointCount+1,j) = 1.0
- matrix(pointCount+2,j) = points(j,1)
- matrix(pointCount+3,j) = points(j,2)
- matrix(j,pointCount+1:pointCount+3) = matrix(pointCount+1:pointCount+3, j)
- end do
- call LEGS(matrix(1:matrixSize,1:matrixSize), matrixSize, rhs(1:matrixSize), &
- coefficients(1:matrixSize), pivotIndices(1:matrixSize))
-
- end subroutine rbfInterp_loc_2D_sca_lin_compCoeffs
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Purpose: Evalute a scalar function in 2D using coefficients computed in
- ! rbfInterp_loc_2D_sca_const_compCoeffs. This
- ! function can be called repeatedly with different destination points
- ! to quickly evaluate the interpolating function using the same
- ! coefficients. This is useful for finding the location on the the
- ! RBF reconstruction of a function (e.g., a height field) that minimizes
- ! the distance to a point in 3D space. The reconstruction is performed
- ! with basis functions that are RBFs and constant
- ! Input:
- ! fieldCount - the number fields to be evaluated. This is useful for reconstructing,
- ! for example, the x-, y- and z-components of a vector field at the same
- ! point in 2D
- ! coeffCount - the size of coefficients, must be at least pointCount + 1
- ! pointCount - the number of "source" points and functionValues supplied
- ! coefficients - the coefficients needed to perform interpolation of the funciton
- ! at the evaluationPoint
- ! evaluationPoint - the point in 2D where the function is to be reconstructed
- ! points - the location of the "source" points in the 2D space where the values of
- ! the function are known
- ! alpha - a constant that give the characteristic length scale of the RBFs,
- ! should be on the order of the distance between points
- ! Output:
- ! derivs - the value of the function, the 2 components of its Jacobian and
- ! the 3 unique components of its Hessian at the evaluationPoint
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine rbfInterp_loc_2D_sca_const_evalWithDerivs(fieldCount, coeffCount, &
- pointCount, coefficients, evaluationPoint, points, alpha, derivs)
- integer, intent(in) :: fieldCount, coeffCount, pointCount
- real(kind=RKIND), dimension(coeffCount, fieldCount), intent(in) :: coefficients
- real(kind=RKIND), dimension(2), intent(in) :: evaluationPoint
- real(kind=RKIND), dimension(pointCount,2), intent(in) :: points
- real(kind=RKIND), intent(in) :: alpha
-
- real(kind=RKIND), dimension(6,fieldCount), intent(out) :: derivs
-
- integer :: pointIndex
- real(kind=RKIND) :: x, y, rSquared, rbfValue, rbfDerivOverR, rbfSecondDeriv
-
- derivs = 0.0
- do pointIndex = 1, pointCount
- x = (evaluationPoint(1) - points(pointIndex,1))
- y = (evaluationPoint(2) - points(pointIndex,2))
- rSquared = x**2 + y**2
- call evaluateRBFAndDerivs(rSquared/alpha**2, rbfValue, rbfDerivOverR, rbfSecondDeriv)
- rbfDerivOverR = rbfDerivOverR/alpha**2
- rbfSecondDeriv = rbfSecondDeriv/alpha**2
- if(rSquared/alpha**2 < 1e-7) then
- ! terms 2,3 and 5 are zero by radial symmetry of the RBF
- derivs(1,:) = derivs(1,:) + coefficients(pointIndex,:)*rbfValue
- derivs(4,:) = derivs(4,:) + coefficients(pointIndex,:)*rbfSecondDeriv
- derivs(6,:) = derivs(6,:) + coefficients(pointIndex,:)*rbfSecondDeriv
- else
- call evaluateRBFAndDerivs(rSquared, rbfValue, rbfDerivOverR, rbfSecondDeriv)
- derivs(1,:) = derivs(1,:) + coefficients(pointIndex,:)*rbfValue
- derivs(2,:) = derivs(2,:) + coefficients(pointIndex,:)*rbfDerivOverR*x
- derivs(3,:) = derivs(3,:) + coefficients(pointIndex,:)*rbfDerivOverR*y
- derivs(4,:) = derivs(4,:) + coefficients(pointIndex,:) &
- * (rbfSecondDeriv*x**2 + rbfDerivOverR*y**2)/rSquared
- derivs(5,:) = derivs(5,:) + coefficients(pointIndex,:) &
- * (rbfSecondDeriv - rbfDerivOverR)*x*y/rSquared
- derivs(6,:) = derivs(6,:) + coefficients(pointIndex,:) &
- * (rbfSecondDeriv*y**2 + rbfDerivOverR*x**2)/rSquared
- end if
- end do
- derivs(1,:) = derivs(1,:) + coefficients(pointCount+1,:)
- end subroutine rbfInterp_loc_2D_sca_const_evalWithDerivs
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Purpose: Evalute a scalar function in 2D using coefficients computed in
- ! rbfInterp_loc_2D_sca_const_compCoeffs. This
- ! function can be called repeatedly with different destination points
- ! to quickly evaluate the interpolating function using the same
- ! coefficients. This is useful for finding the location on the the
- ! RBF reconstruction of a function (e.g., a height field) that minimizes
- ! the distance to a point in 3D space. The reconstruction is performed
- ! with basis functions that are RBFs, constant and linear
- ! Input:
- ! fieldCount - the number fields to be evaluated. This is useful for reconstructing,
- ! for example, the x-, y- and z-components of a vector field at the same
- ! point in 2D
- ! coeffCount - the size of coefficients, must be at least pointCount + 1
- ! pointCount - the number of "source" points and functionValues supplied
- ! coefficients - the coefficients needed to perform interpolation of the funciton
- ! at the evaluationPoint
- ! evaluationPoint - the point in 2D where the function is to be reconstructed
- ! points - the location of the "source" points in the 2D space where the values of
- ! the function are known
- ! alpha - a constant that give the characteristic length scale of the RBFs,
- ! should be on the order of the distance between points
- ! Output:
- ! derivs - the value of the function, the 2 components of its Jacobian and
- ! the 3 unique components of its Hessian at the evaluationPoint
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine rbfInterp_loc_2D_sca_lin_evalWithDerivs(fieldCount, coeffCount, &
- pointCount, coefficients, evaluationPoint, points, alpha, derivs)
- integer, intent(in) :: fieldCount, coeffCount, pointCount
- real(kind=RKIND), dimension(coeffCount, fieldCount), intent(in) :: coefficients
- real(kind=RKIND), dimension(2), intent(in) :: evaluationPoint
- real(kind=RKIND), dimension(pointCount,2), intent(in) :: points
- real(kind=RKIND), intent(in) :: alpha
-
- real(kind=RKIND), dimension(6,fieldCount), intent(out) :: derivs
-
- integer :: pointIndex
- real(kind=RKIND) :: x, y, rSquared, rbfValue, rbfDerivOverR, rbfSecondDeriv
-
- derivs = 0.0
- do pointIndex = 1, pointCount
- x = (evaluationPoint(1) - points(pointIndex,1))
- y = (evaluationPoint(2) - points(pointIndex,2))
- rSquared = x**2 + y**2
- call evaluateRBFAndDerivs(rSquared/alpha**2, rbfValue, rbfDerivOverR, rbfSecondDeriv)
- rbfDerivOverR = rbfDerivOverR/alpha**2
- rbfSecondDeriv = rbfSecondDeriv/alpha**2
- if(rSquared/alpha**2 < 1e-7) then
- ! terms 2,3 and 5 are zero by radial symmetry of the RBF
- derivs(1,:) = derivs(1,:) + coefficients(pointIndex,:)*rbfValue
- derivs(4,:) = derivs(4,:) + coefficients(pointIndex,:)*rbfSecondDeriv
- derivs(6,:) = derivs(6,:) + coefficients(pointIndex,:)*rbfSecondDeriv
- else
- call evaluateRBFAndDerivs(rSquared, rbfValue, rbfDerivOverR, rbfSecondDeriv)
- derivs(1,:) = derivs(1,:) + coefficients(pointIndex,:)*rbfValue
- derivs(2,:) = derivs(2,:) + coefficients(pointIndex,:)*rbfDerivOverR*x
- derivs(3,:) = derivs(3,:) + coefficients(pointIndex,:)*rbfDerivOverR*y
- derivs(4,:) = derivs(4,:) + coefficients(pointIndex,:) &
- * (rbfSecondDeriv*x**2 + rbfDerivOverR*y**2)/rSquared
- derivs(5,:) = derivs(5,:) + coefficients(pointIndex,:) &
- * (rbfSecondDeriv - rbfDerivOverR)*x*y/rSquared
- derivs(6,:) = derivs(6,:) + coefficients(pointIndex,:) &
- * (rbfSecondDeriv*y**2 + rbfDerivOverR*x**2)/rSquared
- end if
- end do
- derivs(1,:) = derivs(1,:) + coefficients(pointCount+1,:) &
- + coefficients(pointCount+2,:)*evaluationPoint(1) &
- + coefficients(pointCount+3,:)*evaluationPoint(2)
- derivs(2,:) = derivs(2,:) + coefficients(pointCount+2,:)
- derivs(3,:) = derivs(3,:) + coefficients(pointCount+3,:)
-
- end subroutine rbfInterp_loc_2D_sca_lin_evalWithDerivs
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Purpose: Compute interpolation coefficients in 3D that can be used to
- ! interpolate a number of scalar functions at a given locations. This is useful
- ! if the interpolation location does not change with time, or if several
- ! fields are to be interpolated at a given time step. (If both the fields
- ! and the interpolation locations vary with time, there is no clear advantage in
- ! using either this method or the method for 2D interpoaltion above; for simplicity
- ! and because we foresee more uses for the method of this subroutine, we have not
- ! implemented a 3D version of the fixed field, variable interpolation location method
- ! as we have in 2D.) Coefficients are produced for handling Dirichlet boundary
- ! conditions (or no boundaries). The interpolation is performed with basis functions
- ! that are RBFs plus a constant.
- ! Input:
- ! pointCount - the number of "source" points and functionValues supplied
- ! sourcePoints - the location of the "source" points in the 3D space where the values of
- ! the function are known
- ! destinationPoint - the point where the interpolation will be performed
- ! alpha - a constant that give the characteristic length scale of the RBFs,
- ! should be on the order of the distance between points
- ! Output:
- ! coefficients - the coefficients used to interpolate a function with Dirichlet
- ! boundary conditions to the specified destinationPoint
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine rbfInterp_func_3D_sca_const_dir_compCoeffs( &
- pointCount, sourcePoints, destinationPoint, alpha, coefficients)
-
- integer, intent(in) :: pointCount
- real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints
- real(kind=RKIND), dimension(3), intent(in) :: destinationPoint
- real(kind=RKIND), intent(in) :: alpha
- real(kind=RKIND), dimension(pointCount), intent(out) :: coefficients
-
- integer :: i, j
- integer :: matrixSize
-
- real(kind=RKIND), dimension(:,:), pointer :: dirichletMatrix
- real(kind=RKIND), dimension(:), pointer :: rhs, coeffs
- integer, dimension(:), pointer :: pivotIndices
-
- matrixSize = pointCount+1 !! 1 extra space for constant
-
- allocate(dirichletMatrix(matrixSize,matrixSize))
- allocate(rhs(matrixSize))
- allocate(coeffs(matrixSize))
- allocate(pivotIndices(matrixSize))
-
- dirichletMatrix = 0.0
- rhs = 0.0
- coeffs = 0.0
-
- call setUpScalarRBFDirichletMatrixAndRHS(pointCount, sourcePoints, destinationPoint, &
- alpha, dirichletMatrix(1:pointCount,1:pointCount), rhs(1:pointCount))
-
- do i = 1, pointCount
- dirichletMatrix(i,pointCount+1) = 1.0
- dirichletMatrix(pointCount+1,i) = dirichletMatrix(i,pointCount+1)
- end do
-
- rhs(pointCount+1) = 1.0
-
- ! solve each linear system
- call LEGS(dirichletMatrix, matrixSize, rhs, coeffs, pivotIndices)
- coefficients = coeffs(1:pointCount)
-
- deallocate(dirichletMatrix)
- deallocate(rhs)
- deallocate(coeffs)
- deallocate(pivotIndices)
-
- end subroutine rbfInterp_func_3D_sca_const_dir_compCoeffs
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Purpose: Compute interpolation coefficients in a plane in 3D that can be used to
- ! interpolate a number of scalar functions at a given locations. This is useful
- ! if the interpolation location does not change with time, or if several
- ! fields are to be interpolated at a given time step. (If both the fields
- ! and the interpolation locations vary with time, there is no clear advantage in
- ! using either this method or the method for 2D interpoaltion above; for simplicity
- ! and because we foresee more uses for the method of this subroutine, we have not
- ! implemented a 3D version of the fixed field, variable interpolation location method
- ! as we have in 2D.) Coefficients are produced for handling both Dirichlet (or no)
- ! boundary conditions. The interpolation is performed with basis functions that are
- ! RBFs plus constant and linear. All points are projected into the plane given by the
- ! planeBasisVectors.
- ! Input:
- ! pointCount - the number of "source" points and functionValues supplied
- ! sourcePoints - the location of the "source" points in the 3D space where the values of
- ! the function are known. The points will be projected into the plane given by
- ! planeBasisVectors
- ! destinationPoint - the point in 3D where the interpolation will be performed. The
- ! destinationPoint will be projected into the plane given by planeBasisVectors.
- ! alpha - a constant that give the characteristic length scale of the RBFs,
- ! should be on the order of the distance between points
- ! planeBasisVectors - the basis fectors for the plane where interpolation is performed.
- ! All points are projected into this plane.
- ! Output:
- ! coefficients - the coefficients used to interpolate a function with Dirichlet
- ! boundary conditions to the specified destinationPoint
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine rbfInterp_func_3DPlane_sca_lin_dir_compCoeffs( &
- pointCount, sourcePoints, destinationPoint, &
- alpha, planeBasisVectors, coefficients)
-
- integer, intent(in) :: pointCount
- real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints
- real(kind=RKIND), dimension(3), intent(in) :: destinationPoint
- real(kind=RKIND), intent(in) :: alpha
- real(kind=RKIND), dimension(2,3) :: planeBasisVectors
- real(kind=RKIND), dimension(pointCount), intent(out) :: coefficients
-
- integer :: i, j
- integer :: matrixSize
-
- real(kind=RKIND), dimension(:,:), pointer :: dirichletMatrix
- real(kind=RKIND), dimension(:), pointer :: rhs, coeffs
- integer, dimension(:), pointer :: pivotIndices
-
- matrixSize = pointCount+3 !! 3 extra space for constant and 2 planar dimensions
-
- allocate(dirichletMatrix(matrixSize,matrixSize))
- allocate(rhs(matrixSize))
- allocate(coeffs(matrixSize))
- allocate(pivotIndices(matrixSize))
-
- dirichletMatrix = 0.0
- rhs = 0.0
- coeffs = 0.0
-
- call setUpScalarRBFDirichletMatrixAndRHS(pointCount, sourcePoints, destinationPoint, &
- alpha, dirichletMatrix(1:pointCount,1:pointCount), rhs(1:pointCount))
-
- do i = 1, pointCount
- dirichletMatrix(i,pointCount+1) = 1.0
- dirichletMatrix(i,pointCount+2) = sum(sourcePoints(i,1:3)*planeBasisVectors(1,:))
- dirichletMatrix(i,pointCount+3) = sum(sourcePoints(i,1:3)*planeBasisVectors(2,:))
- dirichletMatrix(pointCount+1:pointCount+3,i) &
- = dirichletMatrix(i,pointCount+1:pointCount+3)
- end do
-
- rhs(pointCount+1) = 1.0
- rhs(pointCount+2) = sum(destinationPoint(1:3)*planeBasisVectors(1,:))
- rhs(pointCount+3) = sum(destinationPoint(1:3)*planeBasisVectors(2,:))
-
- ! solve each linear system
- call LEGS(dirichletMatrix, matrixSize, rhs, coeffs, pivotIndices)
- coefficients = coeffs(1:pointCount)
-
- deallocate(dirichletMatrix)
- deallocate(rhs)
- deallocate(coeffs)
- deallocate(pivotIndices)
-
- end subroutine rbfInterp_func_3DPlane_sca_lin_dir_compCoeffs
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Purpose: Compute interpolation coefficients in 3D that can be used to
- ! interpolate a number of scalar functions at a given locations. This is useful
- ! if the interpolation location does not change with time, or if several
- ! fields are to be interpolated at a given time step. (If both the fields
- ! and the interpolation locations vary with time, there is no clear advantage in
- ! using either this method or the method for 2D interpoaltion above; for simplicity
- ! and because we foresee more uses for the method of this subroutine, we have not
- ! implemented a 3D version of the fixed field, variable interpolation location method
- ! as we have in 2D.) Coefficients are produced for handling both Dirichlet (or no)
- ! boundary conditions. The interpolation is performed with basis functions that are
- ! RBFs plus constant and linear.
- ! Input:
- ! pointCount - the number of "source" points and functionValues supplied
- ! sourcePoints - the location of the "source" points in the 3D space where the values of
- ! the function are known
- ! destinationPoint - the point where the interpolation will be performed
- ! alpha - a constant that give the characteristic length scale of the RBFs,
- ! should be on the order of the distance between points
- ! Output:
- ! coefficients - the coefficients used to interpolate a function with Dirichlet
- ! boundary conditions to the specified destinationPoint
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine rbfInterp_func_3D_sca_lin_dir_compCoeffs(pointCount, &
- sourcePoints, destinationPoint, alpha, coefficients)
-
- integer, intent(in) :: pointCount
- real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints
- real(kind=RKIND), dimension(3), intent(in) :: destinationPoint
- real(kind=RKIND), intent(in) :: alpha
- real(kind=RKIND), dimension(pointCount), intent(out) :: coefficients
-
- integer :: i, j
- integer :: matrixSize
-
- real(kind=RKIND), dimension(:,:), pointer :: dirichletMatrix
- real(kind=RKIND), dimension(:), pointer :: rhs, coeffs
- integer, dimension(:), pointer :: pivotIndices
-
- matrixSize = pointCount+4 !! 4 extra space for constant and linear in 3D
-
- allocate(dirichletMatrix(matrixSize,matrixSize))
- allocate(rhs(matrixSize))
- allocate(coeffs(matrixSize))
- allocate(pivotIndices(matrixSize))
-
- dirichletMatrix = 0.0
- rhs = 0.0
- coeffs = 0.0
-
- call setUpScalarRBFDirichletMatrixAndRHS(pointCount, sourcePoints, destinationPoint, &
- alpha, dirichletMatrix(1:pointCount,1:pointCount), rhs(1:pointCount))
-
- do i = 1, pointCount
- dirichletMatrix(i,pointCount+1) = 1.0
- dirichletMatrix(i,pointCount+2:pointCount+4) = sourcePoints(i,1:3)
- dirichletMatrix(pointCount+1:pointCount+4,i) &
- = dirichletMatrix(i,pointCount+1:pointCount+4)
- end do
-
- rhs(pointCount+1) = 1.0
- rhs(pointCount+2:pointCount+4) = destinationPoint(1:3)
-
- ! solve each linear system
- call LEGS(dirichletMatrix, matrixSize, rhs, coeffs, pivotIndices)
- coefficients = coeffs(1:pointCount)
-
- deallocate(dirichletMatrix)
- deallocate(rhs)
- deallocate(coeffs)
- deallocate(pivotIndices)
-
- end subroutine rbfInterp_func_3D_sca_lin_dir_compCoeffs
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Purpose: Compute interpolation coefficients in 3D that can be used to
- ! interpolate a number of scalar functions at a given locations. This is useful
- ! if the interpolation location does not change with time, or if several
- ! fields are to be interpolated at a given time step. (If both the fields
- ! and the interpolation locations vary with time, there is no clear advantage in
- ! using either this method or the method for 2D interpoaltion above; for simplicity
- ! and because we foresee more uses for the method of this subroutine, we have not
- ! implemented a 3D version of the fixed field, variable interpolation location method
- ! as we have in 2D.) Coefficients are produced for handling both Dirichlet and Neumann
- ! boundary conditions. The interpolation is performed with basis functions that are
- ! RBFs plus a constant.
- ! Input:
- ! pointCount - the number of "source" points and functionValues supplied
- ! sourcePoints - the location of the "source" points in the 3D space where the values of
- ! the function are known
- ! isInterface - a logical array indicating which of the source points (if any) are at
- ! at the domain interface. These points and their normals will be used to compute the
- ! neumannCoefficients below
- ! interfaceNormals - a 3D normal vector for each sourcePoint. These vectors are only used
- ! at points where isInterface == .true., and can take arbitrary values elsewehere. The
- ! normal vector is used to compute coefficients for the normal derivative of the
- ! interpolating function in order to impose the Neumann Boundary condition
- ! destinationPoint - the point where the interpolation will be performed
- ! alpha - a constant that give the characteristic length scale of the RBFs,
- ! should be on the order of the distance between points
- ! Output:
- ! dirichletCoefficients - the coefficients used to interpolate a function with Dirichlet
- ! boundary conditions to the specified destinationPoint
- ! neumannCoefficients - the coefficients used to interpolate a function with Neumann
- ! boundary conditions to the specified destinationPoint
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine rbfInterp_func_3D_sca_const_dirNeu_compCoeffs( &
- pointCount, sourcePoints, isInterface, interfaceNormals, destinationPoint, &
- alpha, dirichletCoefficients, neumannCoefficients)
-
- integer, intent(in) :: pointCount
- real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints
- logical, dimension(pointCount), intent(in) :: isInterface
- real(kind=RKIND), dimension(pointCount,3), intent(in) :: interfaceNormals
- real(kind=RKIND), dimension(3), intent(in) :: destinationPoint
- real(kind=RKIND), intent(in) :: alpha
- real(kind=RKIND), dimension(pointCount), intent(out) :: &
- dirichletCoefficients, neumannCoefficients
-
- integer :: i, j
- integer :: matrixSize
-
- real(kind=RKIND), dimension(:,:), pointer :: dirichletMatrix, neumannMatrix
- real(kind=RKIND), dimension(:), pointer :: rhs, rhsCopy, coeffs
- integer, dimension(:), pointer :: pivotIndices
-
- matrixSize = pointCount+1 !! 1 extra space for constant
-
- allocate(dirichletMatrix(matrixSize,matrixSize))
- allocate(neumannMatrix(matrixSize,matrixSize))
- allocate(rhs(matrixSize))
- allocate(rhsCopy(matrixSize))
- allocate(coeffs(matrixSize))
- allocate(pivotIndices(matrixSize))
-
- dirichletMatrix = 0.0
- neumannMatrix = 0.0
- rhs = 0.0
- rhsCopy = 0.0
- coeffs = 0.0
-
- call setUpScalarRBFMatrixAndRHS(pointCount, &
- sourcePoints, isInterface, interfaceNormals, destinationPoint, &
- alpha, dirichletMatrix(1:pointCount,1:pointCount), &
- neumannMatrix(1:pointCount,1:pointCount), rhs(1:pointCount))
-
- do i = 1, pointCount
- dirichletMatrix(i,pointCount+1) = 1.0
- if(isInterface(i)) then
- neumannMatrix(i,pointCount+1) = 0.0
- else
- neumannMatrix(i,pointCount+1) = dirichletMatrix(i,pointCount+1)
- end if
- dirichletMatrix(pointCount+1,i) = dirichletMatrix(i,pointCount+1)
- neumannMatrix(pointCount+1,i) = neumannMatrix(i,pointCount+1)
- end do
-
- rhs(pointCount+1) = 1.0
-
- ! solve each linear system
- rhsCopy = rhs
- call LEGS(dirichletMatrix, matrixSize, rhs, coeffs, pivotIndices)
- dirichletCoefficients = coeffs(1:pointCount)
-
- call LEGS(neumannMatrix, matrixSize, rhsCopy, coeffs, pivotIndices)
- neumannCoefficients = coeffs(1:pointCount)
-
- deallocate(dirichletMatrix)
- deallocate(neumannMatrix)
- deallocate(rhs)
- deallocate(rhsCopy)
- deallocate(coeffs)
- deallocate(pivotIndices)
-
- end subroutine rbfInterp_func_3D_sca_const_dirNeu_compCoeffs
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Purpose: Compute interpolation coefficients in a plane in 3D that can be used to
- ! interpolate a number of scalar functions at a given locations. This is useful
- ! if the interpolation location does not change with time, or if several
- ! fields are to be interpolated at a given time step. (If both the fields
- ! and the interpolation locations vary with time, there is no clear advantage in
- ! using either this method or the method for 2D interpoaltion above; for simplicity
- ! and because we foresee more uses for the method of this subroutine, we have not
- ! implemented a 3D version of the fixed field, variable interpolation location method
- ! as we have in 2D.) Coefficients are produced for handling both Dirichlet and Neumann
- ! boundary conditions. The interpolation is performed with basis functions that are
- ! RBFs plus constant and linear. All points are projected into the plane given by the
- ! planeBasisVectors.
- ! Input:
- ! pointCount - the number of "source" points and functionValues supplied
- ! sourcePoints - the location of the "source" points in the 3D space where the values of
- ! the function are known. The sourcePoints will be projected into the plane given by
- ! planeBasisVectors
- ! isInterface - a logical array indicating which of the source points (if any) are at
- ! at the domain interface. These points and their normals will be used to compute the
- ! neumannCoefficients below
- ! interfaceNormals - a 3D normal vector for each sourcePoint. These vectors are only used
- ! at points where isInterface == .true., and can take arbitrary values elsewehere. The
- ! normal vector is used to compute coefficients for the normal derivative of the
- ! interpolating function in order to impose the Neumann Boundary condition
- ! destinationPoint - the point in 3D where the interpolation will be performed. The
- ! destinationPoint will be projected into the plane given by planeBasisVectors.
- ! alpha - a constant that give the characteristic length scale of the RBFs,
- ! should be on the order of the distance between points
- ! planeBasisVectors - the basis fectors for the plane where interpolation is performed.
- ! All points are projected into this plane.
- ! Output:
- ! dirichletCoefficients - the coefficients used to interpolate a function with Dirichlet
- ! boundary conditions to the specified destinationPoint
- ! neumannCoefficients - the coefficients used to interpolate a function with Neumann
- ! boundary conditions to the specified destinationPoint
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine rbfInterp_func_3DPlane_sca_lin_dirNeu_compCoeffs( &
- pointCount, sourcePoints, isInterface, interfaceNormals, destinationPoint, &
- alpha, planeBasisVectors, dirichletCoefficients, neumannCoefficients)
-
- integer, intent(in) :: pointCount
- real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints
- logical, dimension(pointCount), intent(in) :: isInterface
- real(kind=RKIND), dimension(pointCount,3), intent(in) :: interfaceNormals
- real(kind=RKIND), dimension(3), intent(in) :: destinationPoint
- real(kind=RKIND), intent(in) :: alpha
- real(kind=RKIND), dimension(2,3) :: planeBasisVectors
- real(kind=RKIND), dimension(pointCount), intent(out) :: &
- dirichletCoefficients, neumannCoefficients
-
- integer :: i, j
- integer :: matrixSize
-
- real(kind=RKIND), dimension(:,:), pointer :: dirichletMatrix, neumannMatrix
- real(kind=RKIND), dimension(:), pointer :: rhs, rhsCopy, coeffs
- integer, dimension(:), pointer :: pivotIndices
-
- matrixSize = pointCount+3 !! 3 extra space for constant and 2 planar dimensions
-
- allocate(dirichletMatrix(matrixSize,matrixSize))
- allocate(neumannMatrix(matrixSize,matrixSize))
- allocate(rhs(matrixSize))
- allocate(rhsCopy(matrixSize))
- allocate(coeffs(matrixSize))
- allocate(pivotIndices(matrixSize))
-
- dirichletMatrix = 0.0
- neumannMatrix = 0.0
- rhs = 0.0
- rhsCopy = 0.0
- coeffs = 0.0
-
- call setUpScalarRBFMatrixAndRHS(pointCount, &
- sourcePoints, isInterface, interfaceNormals, destinationPoint, &
- alpha, dirichletMatrix(1:pointCount,1:pointCount), &
- neumannMatrix(1:pointCount,1:pointCount), rhs(1:pointCount))
-
- do i = 1, pointCount
- dirichletMatrix(i,pointCount+1) = 1.0
- dirichletMatrix(i,pointCount+2) = sum(sourcePoints(i,1:3)*planeBasisVectors(1,:))
- dirichletMatrix(i,pointCount+3) = sum(sourcePoints(i,1:3)*planeBasisVectors(2,:))
- if(isInterface(i)) then
- neumannMatrix(i,pointCount+1) = 0.0
- neumannMatrix(i,pointCount+2) = sum(interfaceNormals(i,1:3)*planeBasisVectors(1,:))
- neumannMatrix(i,pointCount+3) = sum(interfaceNormals(i,1:3)*planeBasisVectors(2,:))
- else
- neumannMatrix(i,pointCount+1:pointCount+3) &
- = dirichletMatrix(i,pointCount+1:pointCount+3)
- end if
- dirichletMatrix(pointCount+1:pointCount+3,i) &
- = dirichletMatrix(i,pointCount+1:pointCount+3)
- neumannMatrix(pointCount+1:pointCount+3,i) &
- = neumannMatrix(i,pointCount+1:pointCount+3)
- end do
-
- rhs(pointCount+1) = 1.0
- rhs(pointCount+2) = sum(destinationPoint(1:3)*planeBasisVectors(1,:))
- rhs(pointCount+3) = sum(destinationPoint(1:3)*planeBasisVectors(2,:))
-
- ! solve each linear system
- rhsCopy = rhs
- call LEGS(dirichletMatrix, matrixSize, rhs, coeffs, pivotIndices)
- dirichletCoefficients = coeffs(1:pointCount)
-
- call LEGS(neumannMatrix, matrixSize, rhsCopy, coeffs, pivotIndices)
- neumannCoefficients = coeffs(1:pointCount)
-
- deallocate(dirichletMatrix)
- deallocate(neumannMatrix)
- deallocate(rhs)
- deallocate(rhsCopy)
- deallocate(coeffs)
- deallocate(pivotIndices)
-
- end subroutine rbfInterp_func_3DPlane_sca_lin_dirNeu_compCoeffs
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Purpose: Compute interpolation coefficients in 3D that can be used to
- ! interpolate a number of scalar functions at a given locations. This is useful
- ! if the interpolation location does not change with time, or if several
- ! fields are to be interpolated at a given time step. (If both the fields
- ! and the interpolation locations vary with time, there is no clear advantage in
- ! using either this method or the method for 2D interpoaltion above; for simplicity
- ! and because we foresee more uses for the method of this subroutine, we have not
- ! implemented a 3D version of the fixed field, variable interpolation location method
- ! as we have in 2D.) Coefficients are produced for handling both Dirichlet and Neumann
- ! boundary conditions. The interpolation is performed with basis functions that are
- ! RBFs plus constant and linear.
- ! Input:
- ! pointCount - the number of "source" points and functionValues supplied
- ! sourcePoints - the location of the "source" points in the 3D space where the values of
- ! the function are known
- ! isInterface - a logical array indicating which of the source points (if any) are at
- ! at the domain interface. These points and their normals will be used to compute the
- ! neumannCoefficients below
- ! interfaceNormals - a 3D normal vector for each sourcePoint. These vectors are only used
- ! at points where isInterface == .true., and can take arbitrary values elsewehere. The
- ! normal vector is used to compute coefficients for the normal derivative of the
- ! interpolating function in order to impose the Neumann Boundary condition
- ! destinationPoint - the point where the interpolation will be performed
- ! alpha - a constant that give the characteristic length scale of the RBFs,
- ! should be on the order of the distance between points
- ! Output:
- ! dirichletCoefficients - the coefficients used to interpolate a function with Dirichlet
- ! boundary conditions to the specified destinationPoint
- ! neumannCoefficients - the coefficients used to interpolate a function with Neumann
- ! boundary conditions to the specified destinationPoint
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine rbfInterp_func_3D_sca_lin_dirNeu_compCoeffs(pointCount, &
- sourcePoints, isInterface, interfaceNormals, destinationPoint, &
- alpha, dirichletCoefficients, neumannCoefficients)
-
- integer, intent(in) :: pointCount
- real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints
- logical, dimension(pointCount), intent(in) :: isInterface
- real(kind=RKIND), dimension(pointCount,3), intent(in) :: interfaceNormals
- real(kind=RKIND), dimension(3), intent(in) :: destinationPoint
- real(kind=RKIND), intent(in) :: alpha
- real(kind=RKIND), dimension(pointCount), intent(out) :: &
- dirichletCoefficients, neumannCoefficients
-
- integer :: i, j
- integer :: matrixSize
-
- real(kind=RKIND), dimension(:,:), pointer :: dirichletMatrix, neumannMatrix
- real(kind=RKIND), dimension(:), pointer :: rhs, rhsCopy, coeffs
- integer, dimension(:), pointer :: pivotIndices
-
- matrixSize = pointCount+4 !! 4 extra space for constant and linear in 3D
-
- allocate(dirichletMatrix(matrixSize,matrixSize))
- allocate(neumannMatrix(matrixSize,matrixSize))
- allocate(rhs(matrixSize))
- allocate(rhsCopy(matrixSize))
- allocate(coeffs(matrixSize))
- allocate(pivotIndices(matrixSize))
-
- dirichletMatrix = 0.0
- neumannMatrix = 0.0
- rhs = 0.0
- rhsCopy = 0.0
- coeffs = 0.0
-
- call setUpScalarRBFMatrixAndRHS(pointCount, &
- sourcePoints, isInterface, interfaceNormals, destinationPoint, &
- alpha, dirichletMatrix(1:pointCount,1:pointCount), &
- neumannMatrix(1:pointCount,1:pointCount), rhs(1:pointCount))
-
- do i = 1, pointCount
- dirichletMatrix(i,pointCount+1) = 1.0
- dirichletMatrix(i,pointCount+2:pointCount+4) = sourcePoints(i,1:3)
- if(isInterface(i)) then
- neumannMatrix(i,pointCount+1) = 0.0
- neumannMatrix(i,pointCount+2:pointCount+4) = interfaceNormals(i,1:3)
- else
- neumannMatrix(i,pointCount+1:pointCount+4) &
- = dirichletMatrix(i,pointCount+1:pointCount+4)
- end if
- dirichletMatrix(pointCount+1:pointCount+4,i) &
- = dirichletMatrix(i,pointCount+1:pointCount+4)
- neumannMatrix(pointCount+1:pointCount+4,i) &
- = neumannMatrix(i,pointCount+1:pointCount+4)
- end do
-
- rhs(pointCount+1) = 1.0
- rhs(pointCount+2:pointCount+4) = destinationPoint(1:3)
-
- ! solve each linear system
- rhsCopy = rhs
- call LEGS(dirichletMatrix, matrixSize, rhs, coeffs, pivotIndices)
- dirichletCoefficients = coeffs(1:pointCount)
-
- call LEGS(neumannMatrix, matrixSize, rhsCopy, coeffs, pivotIndices)
- neumannCoefficients = coeffs(1:pointCount)
-
- deallocate(dirichletMatrix)
- deallocate(neumannMatrix)
- deallocate(rhs)
- deallocate(rhsCopy)
- deallocate(coeffs)
- deallocate(pivotIndices)
-
- end subroutine rbfInterp_func_3D_sca_lin_dirNeu_compCoeffs
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Purpose: Compute interpolation coefficients in 3D that can be used to
- ! interpolate a number of vector functions at a given locations. This is useful
- ! if the interpolation location does not change with time, or if several
- ! fields are to be interpolated at a given time step. (If both the vector fields
- ! and the interpolation locations vary with time, there is no clear advantage in
- ! using either this method or the method for 2D interpoaltion above; for simplicity
- ! and because we foresee more uses for the method of this subroutine, we have not
- ! implemented a 3D version of the fixed field, variable interpolation location method
- ! as we have in 2D.) Coefficients are produced for handling Dirichlet boundary
- ! conditions (or no boundaries). The interpolation is performed with basis functions
- ! that are RBFs plus a constant.
- ! Input:
- ! pointCount - the number of "source" points and functionValues supplied
- ! sourcePoints - the location of the "source" points in the 3D space where the values of
- ! the function are known
- ! unitVectors - the unit vectors associated with each of the sourcePoints. Interpolation
- ! is performed by supplying the value of the vector function dotted into each of these unit
- ! vectors. If multiple unit vectors are supplied at the same sourcePoint, they *must* be
- ! orthogonal for the interpolation to succeed.
- ! destinationPoint - the point where the interpolation will be performed
- ! alpha - a constant that give the characteristic length scale of the RBFs,
- ! should be on the order of the distance between points
- ! Output:
- ! coefficients - the coefficients used to interpolate a function with Dirichlet
- ! boundary conditions to the specified destinationPoint
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine rbfInterp_func_3D_vec_const_dir_compCoeffs(pointCount, &
- sourcePoints, unitVectors, destinationPoint, &
- alpha, coefficients)
-
- integer, intent(in) :: pointCount
- real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints
- real(kind=RKIND), dimension(pointCount,3), intent(in) :: unitVectors
- real(kind=RKIND), dimension(3), intent(in) :: destinationPoint
- real(kind=RKIND), intent(in) :: alpha
- real(kind=RKIND), dimension(pointCount, 3), intent(out) :: coefficients
-
- integer :: i, j
- integer :: matrixSize
-
- real(kind=RKIND), dimension(:,:), pointer :: matrix, matrixCopy
- real(kind=RKIND), dimension(:,:), pointer :: rhs, coeffs
- integer, dimension(:), pointer :: pivotIndices
-
- matrixSize = pointCount+3 ! extra space for constant vector
-
- allocate(matrix(matrixSize,matrixSize))
- allocate(matrixCopy(matrixSize,matrixSize))
- allocate(rhs(matrixSize,3))
- allocate(coeffs(matrixSize,3))
- allocate(pivotIndices(matrixSize))
-
- matrix = 0.0
- rhs = 0.0
- coeffs = 0.0
-
- call setUpVectorDirichletRBFMatrixAndRHS(pointCount, 3, &
- sourcePoints, unitVectors, destinationPoint, &
- alpha, matrix(1:pointCount,1:pointCount), rhs(1:pointCount,:))
-
- do i = 1, pointCount
- matrix(i,pointCount+1:pointCount+3) = unitVectors(i,:)
- matrix(pointCount+1:pointCount+3,i) &
- = matrix(i,pointCount+1:pointCount+3)
- end do
- do i = 1, 3
- rhs(pointCount+i,i) = 1.0 ! the unit vector in the ith direction
- end do
-
- ! solve each linear system
- do i = 1, 3
- matrixCopy = matrix
- call LEGS(matrixCopy, matrixSize, rhs(:,i), coeffs(:,i), pivotIndices)
- end do
- coefficients = coeffs(1:pointCount,:)
-
- deallocate(matrix)
- deallocate(matrixCopy)
- deallocate(rhs)
- deallocate(coeffs)
- deallocate(pivotIndices)
-
- end subroutine rbfInterp_func_3D_vec_const_dir_compCoeffs
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Purpose: Compute interpolation coefficients in 3D that can be used to
- ! interpolate a number of vector functions at a given locations. This is useful
- ! if the interpolation location does not change with time, or if several
- ! fields are to be interpolated at a given time step. (If both the vector fields
- ! and the interpolation locations vary with time, there is no clear advantage in
- ! using either this method or the method for 2D interpoaltion above; for simplicity
- ! and because we foresee more uses for the method of this subroutine, we have not
- ! implemented a 3D version of the fixed field, variable interpolation location method
- ! as we have in 2D.) Coefficients are produced for handling Dirichlet boundary
- ! conditions (or no boundaries). The interpolation is performed with basis functions
- ! that are RBFs plus a constant.
- ! Input:
- ! pointCount - the number of "source" points and functionValues supplied
- ! sourcePoints - the location of the "source" points in the 3D space where the values of
- ! the function are known. The sourcePoints are projected into the plane given by
- ! planeBasisVectors
- ! unitVectors - the unit vectors associated with each of the sourcePoints. Interpolation
- ! is performed by supplying the value of the vector function dotted into each of these unit
- ! vectors. If multiple unit vectors are supplied at the same sourcePoint, they *must* be
- ! orthogonal for the interpolation to succeed. The unitVectors are projected into the
- ! plane given by planeBasisVectors
- ! destinationPoint - the point where the interpolation will be performed. The destinationPoint
- ! is projected into the plane given by planeBasisVectors
- ! alpha - a constant that give the characteristic length scale of the RBFs,
- ! should be on the order of the distance between points
- ! planeBasisVectors - the basis fectors for the plane where interpolation is performed.
- ! All points are projected into this plane.
- ! Output:
- ! coefficients - the coefficients used to interpolate a function with Dirichlet
- ! boundary conditions to the specified destinationPoint
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine rbfInterp_func_3DPlane_vec_const_dir_compCoeffs(pointCount, &
- sourcePoints, unitVectors, destinationPoint, &
- alpha, planeBasisVectors, coefficients)
-
- integer, intent(in) :: pointCount
- real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints
- real(kind=RKIND), dimension(pointCount,3), intent(in) :: unitVectors
- real(kind=RKIND), dimension(3), intent(in) :: destinationPoint
- real(kind=RKIND), intent(in) :: alpha
- real(kind=RKIND), dimension(2,3) :: planeBasisVectors
- real(kind=RKIND), dimension(pointCount, 3), intent(out) :: coefficients
-
- integer :: i, j
- integer :: matrixSize
-
- real(kind=RKIND) :: rSquared, rbfValue, unitVectorDotProduct
-
- real(kind=RKIND), dimension(pointCount,2) :: planarSourcePoints
- real(kind=RKIND), dimension(pointCount,2) :: planarUnitVectors
- real(kind=RKIND), dimension(2) :: planarDestinationPoint
-
- real(kind=RKIND), dimension(:,:), pointer :: matrix, matrixCopy
- real(kind=RKIND), dimension(:,:), pointer :: rhs, coeffs
- integer, dimension(:), pointer :: pivotIndices
-
- matrixSize = pointCount+2 ! space for constant vector in plane
-
- allocate(matrix(matrixSize,matrixSize))
- allocate(matrixCopy(matrixSize,matrixSize))
- allocate(rhs(matrixSize,2))
- allocate(coeffs(matrixSize,2))
- allocate(pivotIndices(matrixSize))
-
- matrix = 0.0
- rhs = 0.0
- coeffs = 0.0
-
- do i = 1, pointCount
- planarSourcePoints(i,1) = sum(sourcePoints(i,:)*planeBasisVectors(1,:))
- planarSourcePoints(i,2) = sum(sourcePoints(i,:)*planeBasisVectors(2,:))
- planarUnitVectors(i,1) = sum(unitVectors(i,:)*planeBasisVectors(1,:))
- planarUnitVectors(i,2) = sum(unitVectors(i,:)*planeBasisVectors(2,:))
- end do
- planarDestinationPoint(1) = sum(destinationPoint*planeBasisVectors(1,:))
- planarDestinationPoint(2) = sum(destinationPoint*planeBasisVectors(2,:))
-
- call setUpVectorDirichletRBFMatrixAndRHS(pointCount, 2, &
- planarSourcePoints, planarUnitVectors, planarDestinationPoint, &
- alpha, matrix(1:pointCount,1:pointCount), rhs(1:pointCount,:))
-
- do i = 1, pointCount
- matrix(i,pointCount+1:pointCount+2) = planarUnitVectors(i,:)
- matrix(pointCount+1:pointCount+2,i) = matrix(i,pointCount+1:pointCount+2)
- end do
- do i = 1,2
- rhs(pointCount+i,i) = 1.0 ! the unit vector in the ith direction
- end do
-
- ! solve each linear system
- matrixCopy = matrix
- call LEGS(matrix, matrixSize, rhs(:,1), coeffs(:,1), pivotIndices)
- call LEGS(matrixCopy, matrixSize, rhs(:,2), coeffs(:,2), pivotIndices)
-
-
- do i = 1,3
- coefficients(:,i) = planeBasisVectors(1,i)*coeffs(1:pointCount,1) &
- + planeBasisVectors(2,i)*coeffs(1:pointCount,2)
- end do
-
- deallocate(matrix)
- deallocate(matrixCopy)
- deallocate(rhs)
- deallocate(coeffs)
- deallocate(pivotIndices)
-
- end subroutine rbfInterp_func_3DPlane_vec_const_dir_compCoeffs
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Purpose: Compute interpolation coefficients in 3D that can be used to
- ! interpolate a number of vector functions at a given locations. This is useful
- ! if the interpolation location does not change with time, or if several
- ! fields are to be interpolated at a given time step. (If both the vector fields
- ! and the interpolation locations vary with time, there is no clear advantage in
- ! using either this method or the method for 2D interpoaltion above; for simplicity
- ! and because we foresee more uses for the method of this subroutine, we have not
- ! implemented a 3D version of the fixed field, variable interpolation location method
- ! as we have in 2D.) Coefficients are produced for handling Dirichlet normal /
- ! Neumann tangential boundary conditions (such as free slip). The interpolation is
- ! performed with basis functions that are RBFs plus a constant.
- ! Input:
- ! pointCount - the number of "source" points and functionValues supplied
- ! sourcePoints - the location of the "source" points in the 3D space where the values of
- ! the function are known
- ! isTangentToInterface - a logical array indicating which sourcePoints/unitVectors are
- ! tangent to the interface where the boundary condition will be applied. A Neumann
- ! boundary condition will be applied at these points in these directions.
- ! normalVectorIndex - where isTangentToInterface == .true., the index into unitVectors that
- ! gives the normal vector at the same sourcePoint. This information is needed to compute
- ! the Neumann boundary condition at this point.
- ! unitVectors - the unit vectors associated with each of the sourcePoints. Interpolation
- ! is performed by supplying the value of the vector function dotted into each of these unit
- ! vectors. If multiple unit vectors are supplied at the same sourcePoint, they *must* be
- ! orthogonal for the interpolation to succeed. A normal vector and two tangential vectors
- ! are needed at each interface point in order to satisfy the Dirichlet normal boundary
- ! condition and the Neumann tangential boundary conditions at these points.
- ! destinationPoint - the point where the interpolation will be performed
- ! alpha - a constant that give the characteristic length scale of the RBFs,
- ! should be on the order of the distance between points
- ! Output:
- ! coefficients - the coefficients used to interpolate a function with Dirichlet
- ! boundary conditions to the specified destinationPoint
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine rbfInterp_func_3D_vec_const_tanNeu_compCoeffs(pointCount, &
- sourcePoints, isTangentToInterface, normalVectorIndex, unitVectors, destinationPoint, &
- alpha, coefficients)
-
- integer, intent(in) :: pointCount
- real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints
- logical, dimension(pointCount), intent(in) :: isTangentToInterface
- integer, dimension(pointCount), intent(in) :: normalVectorIndex
- real(kind=RKIND), dimension(pointCount,3), intent(in) :: unitVectors
- real(kind=RKIND), dimension(3), intent(in) :: destinationPoint
- real(kind=RKIND), intent(in) :: alpha
- real(kind=RKIND), dimension(pointCount, 3), intent(out) :: coefficients
-
- integer :: i, j
- integer :: matrixSize
-
- real(kind=RKIND), dimension(:,:), pointer :: matrix, matrixCopy
- real(kind=RKIND), dimension(:,:), pointer :: rhs, coeffs
- integer, dimension(:), pointer :: pivotIndices
-
- matrixSize = pointCount+3 ! extra space for constant vector
-
- allocate(matrix(matrixSize,matrixSize))
- allocate(matrixCopy(matrixSize,matrixSize))
- allocate(rhs(matrixSize,3))
- allocate(coeffs(matrixSize,3))
- allocate(pivotIndices(matrixSize))
-
- matrix = 0.0
- rhs = 0.0
- coeffs = 0.0
-
- call setUpVectorFreeSlipRBFMatrixAndRHS(pointCount, 3, &
- sourcePoints, isTangentToInterface, normalVectorIndex, unitVectors, destinationPoint, &
- alpha, matrix(1:pointCount,1:pointCount), rhs(1:pointCount,:))
-
- do i = 1, pointCount
- matrix(pointCount+1:pointCount+3,i) = unitVectors(i,:)
- if(.not. isTangentToInterface(i)) then
- matrix(i,pointCount+1:pointCount+3) = matrix(pointCount+1:pointCount+3,i)
- end if
- end do
- do i = 1, 3
- rhs(pointCount+i,i) = 1.0 ! the unit vector in the ith direction
- end do
-
- ! solve each linear system
- do i = 1, 3
- matrixCopy = matrix
- call LEGS(matrixCopy, matrixSize, rhs(:,i), coeffs(:,i), pivotIndices)
- end do
- coefficients = coeffs(1:pointCount,:)
-
- deallocate(matrix)
- deallocate(matrixCopy)
- deallocate(rhs)
- deallocate(coeffs)
- deallocate(pivotIndices)
-
- end subroutine rbfInterp_func_3D_vec_const_tanNeu_compCoeffs
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Purpose: Compute interpolation coefficients in 3D that can be used to
- ! interpolate a number of vector functions at a given locations. This is useful
- ! if the interpolation location does not change with time, or if several
- ! fields are to be interpolated at a given time step. (If both the vector fields
- ! and the interpolation locations vary with time, there is no clear advantage in
- ! using either this method or the method for 2D interpoaltion above; for simplicity
- ! and because we foresee more uses for the method of this subroutine, we have not
- ! implemented a 3D version of the fixed field, variable interpolation location method
- ! as we have in 2D.) Coefficients are produced for handling Dirichlet normal /
- ! Neumann tangential boundary conditions (such as free slip). The interpolation is
- ! performed with basis functions that are RBFs plus a constant.
- ! Input:
- ! pointCount - the number of "source" points and functionValues supplied
- ! sourcePoints - the location of the "source" points in the 3D space where the values of
- ! the function are known. The sourcePoints are projected into the plane given by
- ! planeBasisVectors
- ! isTangentToInterface - a logical array indicating which sourcePoints/unitVectors are
- ! tangent to the interface where the boundary condition will be applied. A Neumann
- ! boundary condition will be applied at these points in these directions.
- ! normalVectorIndex - where isTangentToInterface == .true., the index into unitVectors that
- ! gives the normal vector at the same sourcePoint. This information is needed to compute
- ! the Neumann boundary condition at this point.
- ! unitVectors - the unit vectors associated with each of the sourcePoints. Interpolation
- ! is performed by supplying the value of the vector function dotted into each of these unit
- ! vectors. If multiple unit vectors are supplied at the same sourcePoint, they *must* be
- ! orthogonal for the interpolation to succeed. A normal vector and two tangential vectors
- ! are needed at each interface point in order to satisfy the Dirichlet normal boundary
- ! condition and the Neumann tangential boundary conditions at these points. The unitVectors
- ! are projected into the plane given by planeBasisVectors
- ! destinationPoint - the point where the interpolation will be performed. The destinationPoint
- ! is projected into the plane given by planeBasisVectors
- ! alpha - a constant that give the characteristic length scale of the RBFs,
- ! should be on the order of the distance between points
- ! planeBasisVectors - the basis fectors for the plane where interpolation is performed.
- ! All points are projected into this plane.
- ! Output:
- ! coefficients - the coefficients used to interpolate a function with Dirichlet
- ! boundary conditions to the specified destinationPoint
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine rbfInterp_func_3DPlane_vec_const_tanNeu_compCoeffs(&
- pointCount, sourcePoints, isTangentToInterface, normalVectorIndex, unitVectors, &
- destinationPoint, alpha, planeBasisVectors, coefficients)
-
- integer, intent(in) :: pointCount
- real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints
- logical, dimension(pointCount), intent(in) :: isTangentToInterface
- integer, dimension(pointCount), intent(in) :: normalVectorIndex
- real(kind=RKIND), dimension(pointCount,3), intent(in) :: unitVectors
- real(kind=RKIND), dimension(3), intent(in) :: destinationPoint
- real(kind=RKIND), intent(in) :: alpha
- real(kind=RKIND), dimension(2,3), intent(in) :: planeBasisVectors
- real(kind=RKIND), dimension(pointCount, 3), intent(out) :: coefficients
-
- integer :: i, j
- integer :: matrixSize
-
- real(kind=RKIND), dimension(pointCount,2) :: planarSourcePoints
- real(kind=RKIND), dimension(pointCount,2) :: planarUnitVectors
- real(kind=RKIND), dimension(2) :: planarDestinationPoint
-
- real(kind=RKIND), dimension(:,:), pointer :: matrix, matrixCopy
- real(kind=RKIND), dimension(:,:), pointer :: rhs, coeffs
- integer, dimension(:), pointer :: pivotIndices
-
- matrixSize = pointCount+2 ! space for constant vector in plane
-
- allocate(matrix(matrixSize,matrixSize))
- allocate(matrixCopy(matrixSize,matrixSize))
- allocate(rhs(matrixSize,2))
- allocate(coeffs(matrixSize,2))
- allocate(pivotIndices(matrixSize))
-
- matrix = 0.0
- rhs = 0.0
- coeffs = 0.0
-
- do i = 1, pointCount
- planarSourcePoints(i,1) = sum(sourcePoints(i,:)*planeBasisVectors(1,:))
- planarSourcePoints(i,2) = sum(sourcePoints(i,:)*planeBasisVectors(2,:))
- planarUnitVectors(i,1) = sum(unitVectors(i,:)*planeBasisVectors(1,:))
- planarUnitVectors(i,2) = sum(unitVectors(i,:)*planeBasisVectors(2,:))
- end do
- planarDestinationPoint(1) = sum(destinationPoint*planeBasisVectors(1,:))
- planarDestinationPoint(2) = sum(destinationPoint*planeBasisVectors(2,:))
- call setUpVectorFreeSlipRBFMatrixAndRHS(pointCount, 2, &
- planarSourcePoints, isTangentToInterface, normalVectorIndex, planarUnitVectors, &
- planarDestinationPoint, alpha, matrix(1:pointCount,1:pointCount), rhs(1:pointCount,:))
-
- do i = 1, pointCount
- matrix(pointCount+1,i) = sum(unitVectors(i,:)*planeBasisVectors(1,:))
- matrix(pointCount+2,i) = sum(unitVectors(i,:)*planeBasisVectors(2,:))
- if(.not. isTangentToInterface(i)) then
- matrix(i,pointCount+1:pointCount+2) = matrix(pointCount+1:pointCount+2,i)
- end if
- end do
- do i = 1,2
- rhs(pointCount+i,i) = 1.0 ! the unit vector in the ith direction
- end do
-
- ! solve each linear system
- matrixCopy = matrix
- call LEGS(matrix, matrixSize, rhs(:,1), coeffs(:,1), pivotIndices)
- call LEGS(matrixCopy, matrixSize, rhs(:,2), coeffs(:,2), pivotIndices)
-
- coefficients(:,1) = planeBasisVectors(1,1)*coeffs(1:pointCount,1) &
- + planeBasisVectors(2,1)*coeffs(1:pointCount,2)
- coefficients(:,2) = planeBasisVectors(1,2)*coeffs(1:pointCount,1) &
- + planeBasisVectors(2,2)*coeffs(1:pointCount,2)
- coefficients(:,3) = planeBasisVectors(1,3)*coeffs(1:pointCount,1) &
- + planeBasisVectors(2,3)*coeffs(1:pointCount,2)
-
- deallocate(matrix)
- deallocate(matrixCopy)
- deallocate(rhs)
- deallocate(coeffs)
- deallocate(pivotIndices)
-
- end subroutine rbfInterp_func_3DPlane_vec_const_tanNeu_compCoeffs
-
-
-!!!!!!!!!!!!!!!!!!!!!
-! private subroutines
-!!!!!!!!!!!!!!!!!!!!!
-
- function evaluateRBF(rSquared) result(rbfValue)
- real(kind=RKIND), intent(in) :: rSquared
- real(kind=RKIND) :: rbfValue
-
- ! inverse multiquadratic
- rbfValue = 1/sqrt(1 + rSquared)
-
- end function evaluateRBF
-
- subroutine evaluateRBFAndDeriv(rSquared, rbfValue, rbfDerivOverR)
- real(kind=RKIND), intent(in) :: rSquared
- real(kind=RKIND), intent(out) :: rbfValue, rbfDerivOverR
-
- ! inverse multiquadratic
- rbfValue = 1/sqrt(1 + rSquared)
- rbfDerivOverR = -rbfValue**3
-
- end subroutine evaluateRBFAndDeriv
-
- subroutine evaluateRBFAndDerivs(rSquared, rbfValue, rbfDerivOverR, rbfSecondDeriv)
- real(kind=RKIND), intent(in) :: rSquared
- real(kind=RKIND), intent(out) :: rbfValue, rbfDerivOverR, rbfSecondDeriv
-
- ! inverse multiquadratic
- rbfValue = 1/sqrt(1 + rSquared)
- rbfDerivOverR = -rbfValue**3
- rbfSecondDeriv = (2*rSquared-1)*rbfValue**5
-
- end subroutine evaluateRBFAndDerivs
-
- subroutine setUpScalarRBFDirichletMatrixAndRHS(pointCount, sourcePoints, destinationPoint, &
- alpha, dirichletMatrix, rhs)
-
- integer, intent(in) :: pointCount
- real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints
- real(kind=RKIND), dimension(3), intent(in) :: destinationPoint
- real(kind=RKIND), intent(in) :: alpha
- real(kind=RKIND), dimension(pointCount,pointCount), intent(out) :: dirichletMatrix
- real(kind=RKIND), dimension(pointCount), intent(out) :: rhs
-
- integer :: i, j
-
- real(kind=RKIND) :: rSquared, rbfValue
-
- do j = 1, pointCount
- do i = 1, pointCount
- rSquared = sum((sourcePoints(i,:)-sourcePoints(j,:))**2)/alpha**2
- rbfValue = evaluateRBF(rSquared)
- dirichletMatrix(i,j) = rbfValue
- end do
- end do
-
- do j = 1, pointCount
- rSquared = sum((destinationPoint-sourcePoints(j,:))**2)/alpha**2
- rhs(j) = evaluateRBF(rSquared)
- end do
-
- end subroutine setUpScalarRBFDirichletMatrixAndRHS
-
- subroutine setUpScalarRBFMatrixAndRHS(pointCount, &
- sourcePoints, isInterface, interfaceNormals, destinationPoint, &
- alpha, dirichletMatrix, neumannMatrix, rhs)
-
- integer, intent(in) :: pointCount
- real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints
- logical, dimension(pointCount), intent(in) :: isInterface
- real(kind=RKIND), dimension(pointCount,3), intent(in) :: interfaceNormals
- real(kind=RKIND), dimension(3), intent(in) :: destinationPoint
- real(kind=RKIND), intent(in) :: alpha
- real(kind=RKIND), dimension(pointCount,pointCount), intent(out) :: &
- dirichletMatrix, neumannMatrix
- real(kind=RKIND), dimension(pointCount), intent(out) :: rhs
-
- integer :: i, j
-
- real(kind=RKIND) :: rSquared, rbfValue, rbfDerivOverR, normalDotX
-
- do j = 1, pointCount
- if(isInterface(j)) then
- do i = 1, pointCount
- rSquared = sum((sourcePoints(i,:)-sourcePoints(j,:))**2)/alpha**2
- normalDotX = sum(interfaceNormals(j,:) &
- * (sourcePoints(j,:)-sourcePoints(i,:)))
- call evaluateRBFAndDeriv(rSquared, rbfValue, rbfDerivOverR)
- rbfDerivOverR = rbfDerivOverR/alpha**2
- dirichletMatrix(i,j) = rbfValue
- neumannMatrix(i,j) = rbfDerivOverR*normalDotX
- end do
- else
- do i = 1, pointCount
- rSquared = sum((sourcePoints(i,:)-sourcePoints(j,:))**2)/alpha**2
- rbfValue = evaluateRBF(rSquared)
- dirichletMatrix(i,j) = rbfValue
- neumannMatrix(i,j) = rbfValue
- end do
- end if
- end do
-
- do j = 1, pointCount
- rSquared = sum((destinationPoint-sourcePoints(j,:))**2)/alpha**2
- rhs(j) = evaluateRBF(rSquared)
- end do
-
- end subroutine setUpScalarRBFMatrixAndRHS
-
- subroutine setUpVectorDirichletRBFMatrixAndRHS(pointCount, dimensions, &
- sourcePoints, unitVectors, destinationPoint, &
- alpha, matrix, rhs)
-
- integer, intent(in) :: pointCount, dimensions
- real(kind=RKIND), dimension(pointCount,dimensions), intent(in) :: sourcePoints
- real(kind=RKIND), dimension(pointCount,dimensions), intent(in) :: unitVectors
- real(kind=RKIND), dimension(dimensions), intent(in) :: destinationPoint
- real(kind=RKIND), intent(in) :: alpha
- real(kind=RKIND), dimension(pointCount,pointCount), intent(out) :: matrix
- real(kind=RKIND), dimension(pointCount,dimensions), intent(out) :: rhs
-
- integer :: i, j
-
- real(kind=RKIND) :: rSquared, rbfValue, unitVectorDotProduct
-
- do j = 1, pointCount
- do i = j, pointCount
- rSquared = sum((sourcePoints(i,:)-sourcePoints(j,:))**2)/alpha**2
- rbfValue = evaluateRBF(rSquared)
- unitVectorDotProduct = sum(unitVectors(i,:)*unitVectors(j,:))
- matrix(i,j) = rbfValue*unitVectorDotProduct
- matrix(j,i) = matrix(i,j)
- end do
- end do
-
- do j = 1, pointCount
- rSquared = sum((destinationPoint-sourcePoints(j,:))**2)/alpha**2
- rhs(j,:) = evaluateRBF(rSquared)*unitVectors(j,:)
- end do
-
- end subroutine setUpVectorDirichletRBFMatrixAndRHS
-
- subroutine setUpVectorFreeSlipRBFMatrixAndRHS(pointCount, dimensions, &
- sourcePoints, isTangentToInterface, normalVectorIndex, unitVectors, destinationPoint, &
- alpha, matrix, rhs)
-
- integer, intent(in) :: pointCount, dimensions
- real(kind=RKIND), dimension(pointCount,dimensions), intent(in) :: sourcePoints
- logical, dimension(pointCount), intent(in) :: isTangentToInterface
- integer, dimension(pointCount), intent(in) :: normalVectorIndex
- real(kind=RKIND), dimension(pointCount,dimensions), intent(in) :: unitVectors
- real(kind=RKIND), dimension(dimensions), intent(in) :: destinationPoint
- real(kind=RKIND), intent(in) :: alpha
- real(kind=RKIND), dimension(pointCount,pointCount), intent(out) :: matrix
- real(kind=RKIND), dimension(pointCount,dimensions), intent(out) :: rhs
-
- integer :: i, j
-
- real(kind=RKIND) :: rSquared, rbfValue, rbfDerivOverR, normalVector(dimensions), &
- normalDotX, unitVectorDotProduct
-
- do j = 1, pointCount
- if(isTangentToInterface(j)) then
- do i = 1, pointCount
- rSquared = sum((sourcePoints(i,:)-sourcePoints(j,:))**2)/alpha**2
- normalVector = unitVectors(normalVectorIndex(j),:)
- normalDotX = sum(normalVector * (sourcePoints(j,:)-sourcePoints(i,:)))
- call evaluateRBFAndDeriv(rSquared, rbfValue, rbfDerivOverR)
- rbfDerivOverR = rbfDerivOverR/alpha**2
- unitVectorDotProduct = sum(unitVectors(i,:)*unitVectors(j,:))
- matrix(i,j) = rbfDerivOverR*normalDotX*unitVectorDotProduct
- end do
- else
- do i = 1, pointCount
- rSquared = sum((sourcePoints(i,:)-sourcePoints(j,:))**2)/alpha**2
- rbfValue = evaluateRBF(rSquared)
- unitVectorDotProduct = sum(unitVectors(i,:)*unitVectors(j,:))
- matrix(i,j) = rbfValue*unitVectorDotProduct
- end do
- end if
- end do
-
- do j = 1, pointCount
- rSquared = sum((destinationPoint-sourcePoints(j,:))**2)/alpha**2
- rhs(j,:) = evaluateRBF(rSquared)*unitVectors(j,:)
- end do
-
- end subroutine setUpVectorFreeSlipRBFMatrixAndRHS
-
- subroutine unit_vec_in_R3(xin)
- implicit none
- real (kind=RKIND), intent(inout) :: xin(3)
- real (kind=RKIND) :: mag
- mag = sqrt(xin(1)**2+xin(2)**2+xin(3)**2)
- xin(:) = xin(:) / mag
- end subroutine unit_vec_in_R3
-
- subroutine cross_product_in_R3(p_1,p_2,p_out)
- real (kind=RKIND), intent(in) :: p_1 (3), p_2 (3)
- real (kind=RKIND), intent(out) :: p_out (3)
-
- p_out(1) = p_1(2)*p_2(3)-p_1(3)*p_2(2)
- p_out(2) = p_1(3)*p_2(1)-p_1(1)*p_2(3)
- p_out(3) = p_1(1)*p_2(2)-p_1(2)*p_2(1)
- end subroutine cross_product_in_R3
-
-! Updated 10/24/2001.
-!
-!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 4.3 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! !
-! Please Note: !
-! !
-! (1) This computer program is written by Tao Pang in conjunction with !
-! his book, "An Introduction to Computational Physics," published !
-! by Cambridge University Press in 1997. !
-! !
-! (2) No warranties, express or implied, are made for this program. !
-! !
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!
-!PROGRAM EX43
-!
-!
-! An example of solving linear equation set A(N,N)*X(N) = B(N)
-! with the partial-pivoting Gaussian elimination scheme. The
-! numerical values are for the Wheatstone bridge example discussed
-! in Section 4.1 in the book with all resistances being 100 ohms
-! and the voltage 200 volts.
-!
-! IMPLICIT NONE
-! INTEGER, PARAMETER :: N=3
-! INTEGER :: I,J
-! INTEGER, DIMENSION (N) :: INDX
-! REAL, DIMENSION (N) :: X,B
-! REAL, DIMENSION (N,N) :: A
-! DATA B /200.0,0.0,0.0/, &
-! ((A(I,J), J=1,N),I=1,N) /100.0,100.0,100.0,-100.0, &
-! 300.0,-100.0,-100.0,-100.0, 300.0/
-!
-! CALL LEGS (A,N,B,X,INDX)
-!
-! WRITE (6, "(F16.8)") (X(I), I=1,N)
-!END PROGRAM EX43
-
-
-SUBROUTINE LEGS (A,N,B,X,INDX)
-!
-! Subroutine to solve the equation A(N,N)*X(N) = B(N) with the
-! partial-pivoting Gaussian elimination scheme.
-! Copyright (c) Tao Pang 2001.
-!
- IMPLICIT NONE
- integer, INTENT (IN) :: N
- integer :: I,J
- integer, INTENT (OUT), DIMENSION (N) :: INDX
- real(kind=RKIND), INTENT (INOUT), DIMENSION (N,N) :: A
- real(kind=RKIND), INTENT (INOUT), DIMENSION (N) :: B
- real(kind=RKIND), INTENT (OUT), DIMENSION (N) :: X
-!
- CALL ELGS (A,N,INDX)
-!
- DO I = 1, N-1
- DO J = I+1, N
- B(INDX(J)) = B(INDX(J))-A(INDX(J),I)*B(INDX(I))
- END DO
- END DO
-!
- X(N) = B(INDX(N))/A(INDX(N),N)
- DO I = N-1, 1, -1
- X(I) = B(INDX(I))
- DO J = I+1, N
- X(I) = X(I)-A(INDX(I),J)*X(J)
- END DO
- X(I) = X(I)/A(INDX(I),I)
- END DO
-!
-END SUBROUTINE LEGS
-!
-
-
-
-! Updated 10/24/2001.
-!
-!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 4.4 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! !
-! Please Note: !
-! !
-! (1) This computer program is written by Tao Pang in conjunction with !
-! his book, "An Introduction to Computational Physics," published !
-! by Cambridge University Press in 1997. !
-! !
-! (2) No warranties, express or implied, are made for this program. !
-! !
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!
-SUBROUTINE MIGS (A,N,X,INDX)
-!
-! Subroutine to invert matrix A(N,N) with the inverse stored
-! in X(N,N) in the output. Copyright (c) Tao Pang 2001.
-!
- IMPLICIT NONE
- integer, INTENT (IN) :: N
- integer :: I,J,K
- integer, INTENT (OUT), DIMENSION (N) :: INDX
- real(kind=RKIND), INTENT (INOUT), DIMENSION (N,N):: A
- real(kind=RKIND), INTENT (OUT), DIMENSION (N,N):: X
- real(kind=RKIND), DIMENSION (N,N) :: B
-!
- DO I = 1, N
- DO J = 1, N
- B(I,J) = 0.0
- END DO
- END DO
- DO I = 1, N
- B(I,I) = 1.0
- END DO
-!
- CALL ELGS (A,N,INDX)
-!
- DO I = 1, N-1
- DO J = I+1, N
- DO K = 1, N
- B(INDX(J),K) = B(INDX(J),K)-A(INDX(J),I)*B(INDX(I),K)
- END DO
- END DO
- END DO
-!
- DO I = 1, N
- X(N,I) = B(INDX(N),I)/A(INDX(N),N)
- DO J = N-1, 1, -1
- X(J,I) = B(INDX(J),I)
- DO K = J+1, N
- X(J,I) = X(J,I)-A(INDX(J),K)*X(K,I)
- END DO
- X(J,I) = X(J,I)/A(INDX(J),J)
- END DO
- END DO
-END SUBROUTINE MIGS
-
-
-SUBROUTINE ELGS (A,N,INDX)
-!
-! Subroutine to perform the partial-pivoting Gaussian elimination.
-! A(N,N) is the original matrix in the input and transformed matrix
-! plus the pivoting element ratios below the diagonal in the output.
-! INDX(N) records the pivoting order. Copyright (c) Tao Pang 2001.
-!
- IMPLICIT NONE
- integer, INTENT (IN) :: N
- integer :: I,J,K,ITMP
- integer, INTENT (OUT), DIMENSION (N) :: INDX
- real(kind=RKIND) :: C1,PI,PI1,PJ
- real(kind=RKIND), INTENT (INOUT), DIMENSION (N,N) :: A
- real(kind=RKIND), DIMENSION (N) :: C
-!
-! Initialize the index
-!
- DO I = 1, N
- INDX(I) = I
- END DO
-!
-! Find the rescaling factors, one from each row
-!
- DO I = 1, N
- C1= 0.0
- DO J = 1, N
- !C1 = AMAX1(C1,ABS(A(I,J)))
- C1 = MAX(C1,ABS(A(I,J)))
- END DO
- C(I) = C1
- END DO
-!
-! Search the pivoting (largest) element from each column
-!
- DO J = 1, N-1
- PI1 = 0.0
- DO I = J, N
- PI = ABS(A(INDX(I),J))/C(INDX(I))
- IF (PI.GT.PI1) THEN
- PI1 = PI
- K = I
- ENDIF
- END DO
-!
-! Interchange the rows via INDX(N) to record pivoting order
-!
- ITMP = INDX(J)
- INDX(J) = INDX(K)
- INDX(K) = ITMP
- DO I = J+1, N
- PJ = A(INDX(I),J)/A(INDX(J),J)
-!
-! Record pivoting ratios below the diagonal
-!
- A(INDX(I),J) = PJ
-!
-! Modify other elements accordingly
-!
- DO K = J+1, N
- A(INDX(I),K) = A(INDX(I),K)-PJ*A(INDX(J),K)
- END DO
- END DO
- END DO
-!
-END SUBROUTINE ELGS
-
-end module RBF_interpolation
-
Deleted: trunk/mpas/src/operators/module_spline_interpolation.F
===================================================================
--- trunk/mpas/src/operators/module_spline_interpolation.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/operators/module_spline_interpolation.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -1,427 +0,0 @@
-module spline_interpolation
-
- implicit none
-
- private
-
- public :: CubicSplineCoefficients, InterpolateCubicSpline, &
- IntegrateCubicSpline, IntegrateColumnCubicSpline, InterpolateLinear, &
- TestInterpolate
-
-! Short Descriptions:
-
-! CubicSplineCoefficients: Compute second derivatives at nodes.
-! This must be run before any of the other cubic spine functions.
-
-! InterpolateCubicSpline: Compute cubic spline interpolation.
-
-! IntegrateCubicSpline: Compute a single integral from spline data.
-
-! IntegrateColumnCubicSpline: Compute multiple integrals from spline data.
-
-! InterpolateLinear: Compute linear interpolation.
-
-! TestInterpolate: Test spline interpolation subroutines.
-
- contains
-
- subroutine CubicSplineCoefficients(x,y,n,y2ndDer)
-
-! Given arrays x(1:n) and y(1:n) containing a function,
-! i.e., y(i) = f(x(i)), with x monotonically increasing
-! this routine returns an array y2ndDer(1:n) that contains
-! the second derivatives of the interpolating function at x(1:n).
-! This routine uses boundary conditions for a natural spline,
-! with zero second derivative on that boundary.
-
-! INPUT PARAMETERS:
-
- integer, intent(in) :: &
- n ! number of nodes
- real(kind=RKIND), intent(in), dimension(n) :: &
- x, &! location of nodes
- y ! value at nodes
-
-! OUTPUT PARAMETERS:
-
- real(kind=RKIND), intent(out), dimension(n) :: &
- y2ndDer ! dy^2/dx^2 at each node
-
-! local variables:
-
- integer :: i
- real(kind=RKIND) :: &
- temp,xRatio,a(n)
-
- y2ndDer(1)=0.0
- y2ndDer(n)=0.0
- a(1)=0.0
-
- do i=2,n-1
- xRatio=(x(i)-x(i-1))/(x(i+1)-x(i-1))
- temp=1.0/(2.0+xRatio*y2ndDer(i-1))
- y2ndDer(i)=temp*(xRatio-1.0)
- a(i) = temp*(6.0*((y(i+1)-y(i))/(x(i+1)-x(i)) &
- -(y(i)-y(i-1))/(x(i)-x(i-1)))/(x(i+1)-x(i-1)) &
- -xRatio*a(i-1))
- enddo
-
- do i=n-1,1,-1
- y2ndDer(i)=y2ndDer(i)*y2ndDer(i+1)+a(i)
- enddo
-
- end subroutine CubicSplineCoefficients
-
-
- subroutine InterpolateCubicSpline( &
- x,y,y2ndDer,n, &
- xOut,yOut,nOut)
-
-! Given the arrays x(1:n) and y(1:n), which tabulate a function,
-! and given the array y2ndDer(1:n), which is the output from
-! CubicSplineCoefficients above, this routine returns the
-! cubic-spline interpolated values of yOut(1:nOut) at xOut(1:nOut).
-! This subroutine assumes that both x and xOut are monotonically
-! increasing, and that all values of xOut are within the first and
-! last values of x.
-
-! INPUT PARAMETERS:
-
- real (kind=RKIND), dimension(n), intent(in) :: &
- x, &! node location, input grid
- y, &! interpolation variable, input grid
- y2ndDer ! 2nd derivative of y at nodes
-
- real (kind=RKIND), dimension(nOut), intent(in) :: &
- xOut ! node location, output grid
-
- integer, intent(in) :: &
- n, &! number of nodes, input grid
- nOut ! number of nodes, output grid
-
-! OUTPUT PARAMETERS:
-
- real (kind=RKIND), dimension(nOut), intent(out) :: &
- yOut ! interpolation variable, output grid
-
-! local variables:
-
- integer :: &
- kIn, kOut ! counters
-
- real (kind=RKIND) :: &
- a, b, h
-
- kOut = 1
-
- kInLoop: do kIn = 1,n-1
-
- h = x(kIn+1)-x(kIn)
-
- do while(xOut(kOut) < x(kIn+1))
-
- a = (x(kIn+1)-xOut(kOut))/h
- b = (xOut(kOut)-x (kIn) )/h
- yOut(kOut) = a*y(kIn) + b*y(kIn+1) &
- + ((a**3-a)*y2ndDer(kIn) + (b**3-b)*y2ndDer(kIn+1)) &
- *(h**2)/6.0
-
- kOut = kOut + 1
-
- if (kOut>nOut) exit kInLoop
-
- enddo
-
- enddo kInLoop
-
-end subroutine InterpolateCubicSpline
-
-
-subroutine IntegrateCubicSpline(x,y,y2ndDer,n,x1,x2,y_integral)
-
-! Given the arrays x(1:n) and y(1:n), which tabulate a function,
-! and given the array y2ndDer(1:n), which is the output from
-! CubicSplineCoefficients above, this routine returns y_integral,
-! the integral of y from x1 to x2. The integration formula was
-! created by analytically integrating a cubic spline between each node.
-! This subroutine assumes that x is monotonically increasing, and
-! that x1 < x2.
-
-! INPUT PARAMETERS:
-
- integer, intent(in) :: &
- n ! number of nodes
- real(kind=RKIND), intent(in), dimension(n) :: &
- x, &! location of nodes
- y, &! value at nodes
- y2ndDer ! dy^2/dx^2 at each node
- real(kind=RKIND), intent(in) :: &
- x1,x2 ! limits of integration
-
-! OUTPUT PARAMETERS:
-
- real(kind=RKIND), intent(out) :: &
- y_integral ! integral of y
-
-! local variables:
-
- integer :: i,j,k
- real(kind=RKIND) :: h,h2, A2,B2, F1,F2, eps1
-
- if (x1<x(1).or.x2>x(n).or.x1>x2) then
- print *, 'error on integration bounds'
- endif
-
- y_integral = 0.0
- eps1 = 1e-14*x2
-
- do j=1,n-1 ! loop through sections
- ! section x(j) ... x(j+1)
-
- if (x2<=x(j) +eps1) exit
- if (x1>=x(j+1)-eps1) cycle
-
- h = x(j+1) - x(j)
- h2 = h**2
-
- ! left side:
- if (x1<x(j)) then
- F1 = -y(j)*h*0.5 + y2ndDer(j)*h**3/24.0
- else
- A2 = (x(j+1)-x1 )**2/h2
- B2 = (x1 -x(j))**2/h2
- F1 = 0.5*h*( -y(j)*A2 + y(j+1)*B2 &
- + y2ndDer(j) *h2*(-0.5*A2**2 + A2)/6.0 &
- + y2ndDer(j+1)*h2*( 0.5*B2**2 - B2)/6.0 )
- endif
-
- ! right side:
- if (x2>x(j+1)) then
- F2 = y(j+1)*h*0.5 - y2ndDer(j+1)*h**3/24.0
- else
- A2 = (x(j+1)-x2 )**2/h2
- B2 = (x2 -x(j))**2/h2
- F2 = 0.5*h*( -y(j)*A2 + y(j+1)*B2 &
- + y2ndDer(j) *h2*(-0.5*A2**2 + A2)/6.0 &
- + y2ndDer(j+1)*h2*( 0.5*B2**2 - B2)/6.0 )
- endif
-
- y_integral = y_integral + F2 - F1
-
- enddo ! j
-
- end subroutine IntegrateCubicSpline
-
-
- subroutine IntegrateColumnCubicSpline( &
- x,y,y2ndDer,n, &
- xOut,y_integral, nOut)
-
-! Given the arrays x(1:n) and y(1:n), which tabulate a function,
-! and given the array y2ndDer(1:n), which is the output from
-! CubicSplineCoefficients above, this routine returns
-! y_integral(1:nOut), the integral of y.
-! This is a cumulative integration, so that
-! y_integral(j) holds the integral of y from x(1) to xOut(j).
-! The integration formula was created by analytically integrating a
-! cubic spline between each node.
-! This subroutine assumes that both x and xOut are monotonically
-! increasing, and that all values of xOut are within the first and
-
-! INPUT PARAMETERS:
-
- integer, intent(in) :: &
- n, &! number of nodes
- nOut ! number of output locations to compute integral
- real(kind=RKIND), intent(in), dimension(n) :: &
- x, &! location of nodes
- y, &! value at nodes
- y2ndDer ! dy^2/dx^2 at each node
- real(kind=RKIND), dimension(nOut), intent(in) :: &
- xOut ! output locations to compute integral
-
-! OUTPUT PARAMETERS:
-
- real(kind=RKIND), dimension(nOut), intent(out) :: &
- y_integral ! integral from 0 to xOut
-
-! local variables:
-
- integer :: i,j,k
- real(kind=RKIND) :: h,h2, A2,B2, F1,F2, eps1
-
- y_integral = 0.0
- j = 1
- h = x(j+1) - x(j)
- h2 = h**2
- F1 = -y(j)*h*0.5 + y2ndDer(j)*h**3/24.0
- eps1 = 0.0 ! note: could use 1e-12*xOut(nOut)
-
- k_loop: do k = 1,nOut
-
- if (k>1) y_integral(k) = y_integral(k-1)
-
- do while(xOut(k) > x(j+1)-eps1)
- F2 = y(j+1)*h*0.5 - y2ndDer(j+1)*h**3/24.0
-
- y_integral(k) = y_integral(k) + F2 - F1
- j = j+1
- h = x(j+1) - x(j)
- h2 = h**2
- F1 = -y(j)*h*0.5 + y2ndDer(j)*h**3/24.0
- if (abs(xOut(k) - x(j+1))<eps1) cycle k_loop
- enddo
-
- A2 = (x(j+1) - xOut(k))**2/h2
- B2 = (xOut(k) - x(j) )**2/h2
- F2 = 0.5*h*( -y(j)*A2 + y(j+1)*B2 &
- + y2ndDer(j) *h2*(-0.5*A2**2 + A2)/6.0 &
- + y2ndDer(j+1)*h2*( 0.5*B2**2 - B2)/6.0 )
-
- y_integral(k) = y_integral(k) + F2 - F1
-
- if (k < nOut) then
- A2 = (x(j+1) -xOut(k))**2/h2
- B2 = (xOut(k) -x(j) )**2/h2
- F1 = 0.5*h*( -y(j)*A2 + y(j+1)*B2 &
- + y2ndDer(j) *h2*(-0.5*A2**2 + A2)/6.0 &
- + y2ndDer(j+1)*h2*( 0.5*B2**2 - B2)/6.0 )
- endif
-
- enddo k_loop
-
- end subroutine IntegrateColumnCubicSpline
-
-
- subroutine InterpolateLinear( &
- x,y,n, &
- xOut,yOut,nOut)
-
-! Given the arrays x(1:n) and y(1:n), which tabulate a function,
-! this routine returns the linear interpolated values of yOut(1:nOut)
-! at xOut(1:nOut).
-! This subroutine assumes that both x and xOut are monotonically
-! increasing, and that all values of xOut are within the first and
-! last values of x.
-
-! !INPUT PARAMETERS:
-
- real (kind=RKIND), dimension(n), intent(in) :: &
- x, &! node location, input grid
- y ! interpolation variable, input grid
-
- real (kind=RKIND), dimension(nOut), intent(in) :: &
- xOut ! node location, output grid
-
- integer, intent(in) :: &
- N, &! number of nodes, input grid
- NOut ! number of nodes, output grid
-
-! !OUTPUT PARAMETERS:
-
- real (kind=RKIND), dimension(nOut), intent(out) :: &
- yOut ! interpolation variable, output grid
-
-!-----------------------------------------------------------------------
-!
-! local variables
-!
-!-----------------------------------------------------------------------
-
- integer :: &
- kIn, kOut ! counters
-
- kOut = 1
-
- kInLoop: do kIn = 1,n-1
-
- do while(xOut(kOut) < x(kIn+1))
-
- yOut(kOut) = y(kIn) &
- + (y(kIn+1)-y(kIn)) &
- /(x(kIn+1) -x(kIn) ) &
- *(xOut(kOut) -x(kIn) )
-
- kOut = kOut + 1
-
- if (kOut>nOut) exit kInLoop
-
- enddo
-
- enddo kInLoop
-
- end subroutine InterpolateLinear
-
-
- subroutine TestInterpolate
-
-! Test function to show how to operate the cubic spline subroutines
-
- integer, parameter :: &
- n = 10
- real (kind=RKIND), dimension(n) :: &
- y, x, y2ndDer
-
- integer, parameter :: &
- nOut = 100
- real (kind=RKIND), dimension(nOut) :: &
- yOut, xOut
-
- integer :: &
- k
-
-!-----------------------------------------------------------------------
-!
-! Create x, y, xOut
-!
-!-----------------------------------------------------------------------
-
- do k=1,n
- x(k) = k-4
- ! trig function:
- y(k) = sin(x(k)/2)
- enddo
-
- do k=1,nOut
- xOut(k) = x(1) + k/(nOut+1.0)*(x(n)-x(1))
- enddo
-
-!-----------------------------------------------------------------------
-!
-! Interpolate
-!
-!-----------------------------------------------------------------------
-
- ! First, compute second derivative values at each node, y2ndDer.
- call CubicSplineCoefficients(x,y,n,y2ndDer)
-
- ! Compute interpolated values yOut.
- call InterpolateCubicSpline( &
- x,y,y2ndDer,n, &
- xOut,yOut,nOut)
-
- ! The following output can be copied directly into Matlab
- print *, 'subplot(2,1,1)'
- print '(a,10f8.4,a)', 'x = [',x,'];'
- print '(a,10f8.4,a)', 'y = [',y,'];'
- print '(a,100f8.4,a)', 'xOut = [',xOut,'];'
- print '(a,100f8.4,a)', 'yOut = [',yOut,'];'
- print *, "plot(x,y,'-*r',xOut,yOut,'x')"
-
- ! Compute interpolated values yOut.
- call IntegrateColumnCubicSpline( &
- x,y,y2ndDer,n, &
- xOut,yOut,nOut)
-
- ! The following output can be copied directly into Matlab
- print *, 'subplot(2,1,2)'
- print '(a,10f8.4,a)', 'x = [',x,'];'
- print '(a,10f8.4,a)', 'y = 2*cos(-3/2) -2*cos(x/2);'
- print '(a,100f8.4,a)', 'xOut = [',xOut,'];'
- print '(a,100f8.4,a)', 'yOut = [',yOut,'];'
- print *, "plot(x,y,'-*r',xOut,yOut,'x')"
-
- end subroutine TestInterpolate
-
-end module spline_interpolation
-
Deleted: trunk/mpas/src/operators/module_vector_reconstruction.F
===================================================================
--- trunk/mpas/src/operators/module_vector_reconstruction.F 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/operators/module_vector_reconstruction.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -1,196 +0,0 @@
-module vector_reconstruction
-
- use grid_types
- use configure
- use constants
- use RBF_interpolation
-
- implicit none
-
- public :: init_reconstruct, reconstruct
-
- contains
-
- subroutine init_reconstruct(grid)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Purpose: pre-compute coefficients used by the reconstruct() routine
- !
- ! Input: grid meta data
- !
- ! Output: grid % coeffs_reconstruct - coefficients used to reconstruct
- ! velocity vectors at cell centers
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (mesh_type), intent(inout) :: grid
-
- ! temporary arrays needed in the (to be constructed) init procedure
- integer :: nCellsSolve
- integer, dimension(:,:), pointer :: edgesOnCell
- integer, dimension(:), pointer :: nEdgesOnCell
- integer :: i, iCell, iEdge, pointCount, maxEdgeCount
- real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell, xEdge, yEdge, zEdge
- real (kind=RKIND) :: r, cellCenter(3), alpha, tangentPlane(2,3)
- real (kind=RKIND), allocatable, dimension(:,:) :: edgeOnCellLocations, edgeOnCellNormals, &
- coeffs
-
- real(kind=RKIND), dimension(:,:), pointer :: edgeNormalVectors
- real(kind=RKIND), dimension(:,:,:), pointer :: cellTangentPlane
-
- real (kind=RKIND), dimension(:,:,:), pointer :: coeffs_reconstruct
-
- !========================================================
- ! arrays filled and saved during init procedure
- !========================================================
- coeffs_reconstruct => grid % coeffs_reconstruct % array
-
- !========================================================
- ! temporary variables needed for init procedure
- !========================================================
- xCell => grid % xCell % array
- yCell => grid % yCell % array
- zCell => grid % zCell % array
- xEdge => grid % xEdge % array
- yEdge => grid % yEdge % array
- zEdge => grid % zEdge % array
- edgesOnCell => grid % edgesOnCell % array
- nEdgesOnCell=> grid % nEdgesOnCell % array
- nCellsSolve = grid % nCellsSolve
- edgeNormalVectors => grid % edgeNormalVectors % array
- cellTangentPlane => grid % cellTangentPlane % array
-
-
- ! init arrays
- coeffs_reconstruct = 0.0
-
- maxEdgeCount = maxval(nEdgesOnCell)
-
- allocate(edgeOnCellLocations(maxEdgeCount,3))
- allocate(edgeOnCellNormals(maxEdgeCount,3))
- allocate(coeffs(maxEdgeCount,3))
-
- ! loop over all cells to be solved on this block
- do iCell=1,nCellsSolve
- pointCount = nEdgesOnCell(iCell)
- cellCenter(1) = xCell(iCell)
- cellCenter(2) = yCell(iCell)
- cellCenter(3) = zCell(iCell)
-
- do i=1,pointCount
- iEdge = edgesOnCell(i,iCell)
- edgeOnCellLocations(i,1) = xEdge(iEdge)
- edgeOnCellLocations(i,2) = yEdge(iEdge)
- edgeOnCellLocations(i,3) = zEdge(iEdge)
- edgeOnCellNormals(i,:) = edgeNormalVectors(:, iEdge)
- end do
-
- alpha = 0.0
- do i=1,pointCount
- r = sqrt(sum((cellCenter - edgeOnCellLocations(i,:))**2))
- alpha = alpha + r
- enddo
- alpha = alpha/pointCount
-
- tangentPlane(1,:) = cellTangentPlane(:,1,iCell)
- tangentPlane(2,:) = cellTangentPlane(:,2,iCell)
-
- call rbfInterp_func_3DPlane_vec_const_dir_compCoeffs(pointCount, &
- edgeOnCellLocations(1:pointCount,:), &
- edgeOnCellNormals(1:pointCount,:), &
- cellCenter, alpha, tangentPlane, coeffs(1:pointCount,:))
-
- do i=1,pointCount
- coeffs_reconstruct(:,i,iCell) = coeffs(i,:)
- end do
-
- enddo ! iCell
-
- deallocate(edgeOnCellLocations)
- deallocate(edgeOnCellNormals)
- deallocate(coeffs)
-
- end subroutine init_reconstruct
-
- subroutine reconstruct(grid, u, uReconstructX, uReconstructY, uReconstructZ, uReconstructZonal, uReconstructMeridional)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Purpose: reconstruct vector field at cell centers based on radial basis functions
- !
- ! Input: grid meta data and vector component data residing at cell edges
- !
- ! Output: reconstructed vector field (measured in X,Y,Z) located at cell centers
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (mesh_type), intent(in) :: grid
- real (kind=RKIND), dimension(:,:), intent(in) :: u
- real (kind=RKIND), dimension(:,:), intent(out) :: uReconstructX, uReconstructY, uReconstructZ
- real (kind=RKIND), dimension(:,:), intent(out) :: uReconstructZonal, uReconstructMeridional
-
- ! 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 :: latCell, lonCell
-
- real (kind=RKIND), dimension(:,:,:), pointer :: coeffs_reconstruct
-
- logical :: on_a_sphere
-
- real (kind=RKIND) :: clat, slat, clon, slon
-
-
- ! stored arrays used during compute procedure
- coeffs_reconstruct => grid % coeffs_reconstruct % array
-
- ! temporary variables
- edgesOnCell => grid % edgesOnCell % array
- nEdgesOnCell=> grid % nEdgesOnCell % array
- nCellsSolve = grid % nCellsSolve
-
- latCell => grid % latCell % array
- lonCell => grid % lonCell % array
- on_a_sphere = grid % on_a_sphere
-
- ! init the intent(out)
- uReconstructX = 0.0
- uReconstructY = 0.0
- uReconstructZ = 0.0
-
- ! loop over cell centers
- do iCell=1,nCellsSolve
- ! a more efficient reconstruction where rbf_values*matrix_reconstruct has been precomputed
- ! in coeffs_reconstruct
- do i=1,nEdgesOnCell(iCell)
- iEdge = edgesOnCell(i,iCell)
- uReconstructX(:,iCell) = uReconstructX(:,iCell) &
- + coeffs_reconstruct(1,i,iCell) * u(:,iEdge)
- uReconstructY(:,iCell) = uReconstructY(:,iCell) &
- + coeffs_reconstruct(2,i,iCell) * u(:,iEdge)
- uReconstructZ(:,iCell) = uReconstructZ(:,iCell) &
- + coeffs_reconstruct(3,i,iCell) * u(:,iEdge)
-
- enddo
- enddo ! iCell
-
- if(on_a_sphere) then
- do iCell=1,nCellsSolve
- clat = cos(latCell(iCell))
- slat = sin(latCell(iCell))
- clon = cos(lonCell(iCell))
- slon = sin(lonCell(iCell))
- uReconstructZonal(:,iCell) = -uReconstructX(:,iCell)*slon + uReconstructY(:,iCell)*clon
- uReconstructMeridional(:,iCell) = -(uReconstructX(:,iCell)*clon &
- + uReconstructY(:,iCell)*slon)*slat &
- + uReconstructZ(:,iCell)*clat
- end do
- else
- uReconstructZonal = uReconstructX
- uReconstructMeridional = uReconstructY
- end if
-
- end subroutine reconstruct
-
-end module vector_reconstruction
Copied: trunk/mpas/src/operators/mpas_rbf_interpolation.F (from rev 1113, branches/source_renaming/src/operators/mpas_rbf_interpolation.F)
===================================================================
--- trunk/mpas/src/operators/mpas_rbf_interpolation.F (rev 0)
+++ trunk/mpas/src/operators/mpas_rbf_interpolation.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -0,0 +1,1824 @@
+module mpas_rbf_interpolation
+ use mpas_dmpar
+ use mpas_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 :: mpas_rbf_interp_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 :: mpas_rbf_interp_loc_2D_sca_const_comp_coeffs, &
+ mpas_rbf_interp_loc_2D_sca_lin_comp_coeffs, &
+ mpas_rbf_interp_loc_2D_sca_const_eval_with_derivs, &
+ mpas_rbf_interp_loc_2D_sca_lin_eval_with_derivs
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! 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 :: mpas_rbf_interp_func_3D_sca_const_dir_comp_coeffs, &
+ mpas_rbf_interp_func_3D_plane_sca_lin_dir_comp_coeffs, &
+ mpas_rbf_interp_func_3D_sca_lin_dir_comp_coeffs, &
+ mpas_rbf_interp_func_3D_sca_const_dir_neu_comp_coeffs, &
+ mpas_rbf_interp_func_3D_plane_sca_lin_dir_neu_comp_coeffs, &
+ mpas_rbf_interp_func_3D_sca_lin_dir_neu_comp_coeffs
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! 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 :: mpas_rbf_interp_func_3D_vec_const_dir_comp_coeffs, &
+ mpas_rbf_interp_func_3D_plane_vec_const_dir_comp_coeffs!, &
+ !mpas_rbf_interp_func_3D_vec_const_tan_neu_comp_coeffs, &
+ !mpas_rbf_interp_func_3D_plane_vec_const_tan_neu_comp_coeffs
+
+ contains
+
+ subroutine mpas_rbf_interp_initialize(grid)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Purpose: compute geometric fields that will be potentially useful for calling
+ ! the interpolation routines
+ !
+ ! Input: the grid
+ !
+ ! Output:
+ ! edgeNormalVectors - the unit vector at the center of each edge tangent to the sphere
+ ! cellTangentPlane - 2 orthogonal unit vectors in the tangent plane of each cell
+ ! The first unit vector is chosen to point toward the center of the first
+ ! edge on the cell.
+ ! localVerticalUnitVectors - the unit normal vector of the tangent plane at the center
+ ! of each cell
+ !
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (mesh_type), intent(inout) :: grid
+
+ integer :: nCells, nEdges
+ integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnCell
+ integer :: iEdge, iCell, cell1, cell2
+ real(kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell, xEdge, yEdge, zEdge
+ real(kind=RKIND), dimension(:,:), pointer :: localVerticalUnitVectors, edgeNormalVectors
+ real(kind=RKIND), dimension(:,:,:), pointer :: cellTangentPlane
+ real(kind=RKIND), dimension(3) :: xHatPlane, yHatPlane, rHat
+ real(kind=RKIND) :: normalDotRHat
+ logical :: on_a_sphere
+
+ xCell => grid % xCell % array
+ yCell => grid % yCell % array
+ zCell => grid % zCell % array
+ xEdge => grid % xEdge % array
+ yEdge => grid % yEdge % array
+ zEdge => grid % zEdge % array
+ cellsOnEdge => grid % cellsOnEdge % array
+ edgesOnCell => grid % edgesOnCell % array
+ nCells = grid % nCells
+ nEdges = grid % nEdges
+ on_a_sphere = grid % on_a_sphere
+
+ localVerticalUnitVectors => grid % localVerticalUnitVectors % array
+ edgeNormalVectors => grid % edgeNormalVectors % array
+ cellTangentPlane => grid % cellTangentPlane % array
+
+ ! init arrays
+ edgeNormalVectors = 0
+ localVerticalUnitVectors = 0
+
+ ! loop over all cells to be solved on this block
+ do iCell=1,nCells
+ if(on_a_sphere) then
+ localVerticalUnitVectors(1,iCell) = xCell(iCell)
+ localVerticalUnitVectors(2,iCell) = yCell(iCell)
+ localVerticalUnitVectors(3,iCell) = zCell(iCell)
+ call mpas_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 mpas_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 mpas_unit_vec_in_r3(xHatPlane)
+
+ call mpas_cross_product_in_r3(rHat, xHatPlane, yHatPlane)
+ call mpas_unit_vec_in_r3(yHatPlane) ! just to be sure...
+ cellTangentPlane(:,1,iCell) = xHatPlane
+ cellTangentPlane(:,2,iCell) = yHatPlane
+ end do
+
+ end subroutine mpas_rbf_interp_initialize
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Purpose: Compute interpolation coefficients in 2D that can be used to
+ ! reconstruct a given scalar function at varying locations. This is useful
+ ! for finding the location on the the RBF reconstruction of a function
+ ! (e.g., a height field) that minimizes the distance to a point in 3D space.
+ ! The reconstruction is performed with basis functions that are RBFs and constant
+ ! Input:
+ ! pointCount - the number of "source" points and functionValues supplied
+ ! coeffCount - the size of coefficients, must be at least pointCount + 1
+ ! points - the location of the "source" points in the 2D space where the values of
+ ! the function are known
+ ! fieldValues - the values of the function of interest at the points
+ ! alpha - a constant that give the characteristic length scale of the RBFs,
+ ! should be on the order of the distance between points
+ ! Output:
+ ! coefficients - the coefficients needed to perform interpolation of the funciton
+ ! at destination points yet to be specified
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine mpas_rbf_interp_loc_2D_sca_const_comp_coeffs(pointCount, coeffCount, &
+ 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) = evaluate_rbf(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 mpas_legs(matrix(1:matrixSize,1:matrixSize), matrixSize, rhs(1:matrixSize), &
+ coefficients(1:matrixSize), pivotIndices(1:matrixSize))
+
+ end subroutine mpas_rbf_interp_loc_2D_sca_const_comp_coeffs
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Purpose: Compute interpolation coefficients in 2D that can be used to
+ ! reconstruct a given scalar function at varying locations. This is useful
+ ! for finding the location on the the RBF reconstruction of a function
+ ! (e.g., a height field) that minimizes the distance to a point in 3D space.
+ ! The reconstruction is performed with basis functions that are RBFs plus constant
+ ! and linear
+ ! Input:
+ ! pointCount - the number of "source" points and functionValues supplied
+ ! coeffCount - the size of coefficients, must be at least pointCount + 3
+ ! points - the location of the "source" points in the 2D space where the values of
+ ! the function are known
+ ! fieldValues - the values of the function of interest at the points
+ ! alpha - a constant that give the characteristic length scale of the RBFs,
+ ! should be on the order of the distance between points
+ ! Output:
+ ! coefficients - the coefficients needed to perform interpolation of the funciton
+ ! at destination points yet to be specified
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine mpas_rbf_interp_loc_2D_sca_lin_comp_coeffs(pointCount, coeffCount, &
+ 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) = evaluate_rbf(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 mpas_legs(matrix(1:matrixSize,1:matrixSize), matrixSize, rhs(1:matrixSize), &
+ coefficients(1:matrixSize), pivotIndices(1:matrixSize))
+
+ end subroutine mpas_rbf_interp_loc_2D_sca_lin_comp_coeffs
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Purpose: Evalute a scalar function in 2D using coefficients computed in
+ ! rbfInterp_loc_2D_sca_const_compCoeffs. This
+ ! function can be called repeatedly with different destination points
+ ! to quickly evaluate the interpolating function using the same
+ ! coefficients. This is useful for finding the location on the the
+ ! RBF reconstruction of a function (e.g., a height field) that minimizes
+ ! the distance to a point in 3D space. The reconstruction is performed
+ ! with basis functions that are RBFs and constant
+ ! Input:
+ ! fieldCount - the number fields to be evaluated. This is useful for reconstructing,
+ ! for example, the x-, y- and z-components of a vector field at the same
+ ! point in 2D
+ ! coeffCount - the size of coefficients, must be at least pointCount + 1
+ ! pointCount - the number of "source" points and functionValues supplied
+ ! coefficients - the coefficients needed to perform interpolation of the funciton
+ ! at the evaluationPoint
+ ! evaluationPoint - the point in 2D where the function is to be reconstructed
+ ! points - the location of the "source" points in the 2D space where the values of
+ ! the function are known
+ ! alpha - a constant that give the characteristic length scale of the RBFs,
+ ! should be on the order of the distance between points
+ ! Output:
+ ! derivs - the value of the function, the 2 components of its Jacobian and
+ ! the 3 unique components of its Hessian at the evaluationPoint
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine mpas_rbf_interp_loc_2D_sca_const_eval_with_derivs(fieldCount, coeffCount, &
+ 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 mpas_evaluate_rbf_and_derivs(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 mpas_evaluate_rbf_and_derivs(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 mpas_rbf_interp_loc_2D_sca_const_eval_with_derivs
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Purpose: Evalute a scalar function in 2D using coefficients computed in
+ ! rbfInterp_loc_2D_sca_const_compCoeffs. This
+ ! function can be called repeatedly with different destination points
+ ! to quickly evaluate the interpolating function using the same
+ ! coefficients. This is useful for finding the location on the the
+ ! RBF reconstruction of a function (e.g., a height field) that minimizes
+ ! the distance to a point in 3D space. The reconstruction is performed
+ ! with basis functions that are RBFs, constant and linear
+ ! Input:
+ ! fieldCount - the number fields to be evaluated. This is useful for reconstructing,
+ ! for example, the x-, y- and z-components of a vector field at the same
+ ! point in 2D
+ ! coeffCount - the size of coefficients, must be at least pointCount + 1
+ ! pointCount - the number of "source" points and functionValues supplied
+ ! coefficients - the coefficients needed to perform interpolation of the funciton
+ ! at the evaluationPoint
+ ! evaluationPoint - the point in 2D where the function is to be reconstructed
+ ! points - the location of the "source" points in the 2D space where the values of
+ ! the function are known
+ ! alpha - a constant that give the characteristic length scale of the RBFs,
+ ! should be on the order of the distance between points
+ ! Output:
+ ! derivs - the value of the function, the 2 components of its Jacobian and
+ ! the 3 unique components of its Hessian at the evaluationPoint
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine mpas_rbf_interp_loc_2D_sca_lin_eval_with_derivs(fieldCount, coeffCount, &
+ 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 mpas_evaluate_rbf_and_derivs(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 mpas_evaluate_rbf_and_derivs(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 mpas_rbf_interp_loc_2D_sca_lin_eval_with_derivs
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Purpose: Compute interpolation coefficients in 3D that can be used to
+ ! interpolate a number of scalar functions at a given locations. This is useful
+ ! if the interpolation location does not change with time, or if several
+ ! fields are to be interpolated at a given time step. (If both the fields
+ ! and the interpolation locations vary with time, there is no clear advantage in
+ ! using either this method or the method for 2D interpoaltion above; for simplicity
+ ! and because we foresee more uses for the method of this subroutine, we have not
+ ! implemented a 3D version of the fixed field, variable interpolation location method
+ ! as we have in 2D.) Coefficients are produced for handling Dirichlet boundary
+ ! conditions (or no boundaries). The interpolation is performed with basis functions
+ ! that are RBFs plus a constant.
+ ! Input:
+ ! pointCount - the number of "source" points and functionValues supplied
+ ! sourcePoints - the location of the "source" points in the 3D space where the values of
+ ! the function are known
+ ! destinationPoint - the point where the interpolation will be performed
+ ! alpha - a constant that give the characteristic length scale of the RBFs,
+ ! should be on the order of the distance between points
+ ! Output:
+ ! coefficients - the coefficients used to interpolate a function with Dirichlet
+ ! boundary conditions to the specified destinationPoint
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine mpas_rbf_interp_func_3D_sca_const_dir_comp_coeffs( &
+ 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 mpas_set_up_scalar_rbf_dirichlet_matrix_and_rhs(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 mpas_legs(dirichletMatrix, matrixSize, rhs, coeffs, pivotIndices)
+ coefficients = coeffs(1:pointCount)
+
+ deallocate(dirichletMatrix)
+ deallocate(rhs)
+ deallocate(coeffs)
+ deallocate(pivotIndices)
+
+ end subroutine mpas_rbf_interp_func_3D_sca_const_dir_comp_coeffs
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Purpose: Compute interpolation coefficients in a plane in 3D that can be used to
+ ! interpolate a number of scalar functions at a given locations. This is useful
+ ! if the interpolation location does not change with time, or if several
+ ! fields are to be interpolated at a given time step. (If both the fields
+ ! and the interpolation locations vary with time, there is no clear advantage in
+ ! using either this method or the method for 2D interpoaltion above; for simplicity
+ ! and because we foresee more uses for the method of this subroutine, we have not
+ ! implemented a 3D version of the fixed field, variable interpolation location method
+ ! as we have in 2D.) Coefficients are produced for handling both Dirichlet (or no)
+ ! boundary conditions. The interpolation is performed with basis functions that are
+ ! RBFs plus constant and linear. All points are projected into the plane given by the
+ ! planeBasisVectors.
+ ! Input:
+ ! pointCount - the number of "source" points and functionValues supplied
+ ! sourcePoints - the location of the "source" points in the 3D space where the values of
+ ! the function are known. The points will be projected into the plane given by
+ ! planeBasisVectors
+ ! destinationPoint - the point in 3D where the interpolation will be performed. The
+ ! destinationPoint will be projected into the plane given by planeBasisVectors.
+ ! alpha - a constant that give the characteristic length scale of the RBFs,
+ ! should be on the order of the distance between points
+ ! planeBasisVectors - the basis fectors for the plane where interpolation is performed.
+ ! All points are projected into this plane.
+ ! Output:
+ ! coefficients - the coefficients used to interpolate a function with Dirichlet
+ ! boundary conditions to the specified destinationPoint
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine mpas_rbf_interp_func_3D_plane_sca_lin_dir_comp_coeffs( &
+ 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 mpas_set_up_scalar_rbf_dirichlet_matrix_and_rhs(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 mpas_legs(dirichletMatrix, matrixSize, rhs, coeffs, pivotIndices)
+ coefficients = coeffs(1:pointCount)
+
+ deallocate(dirichletMatrix)
+ deallocate(rhs)
+ deallocate(coeffs)
+ deallocate(pivotIndices)
+
+ end subroutine mpas_rbf_interp_func_3D_plane_sca_lin_dir_comp_coeffs
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Purpose: Compute interpolation coefficients in 3D that can be used to
+ ! interpolate a number of scalar functions at a given locations. This is useful
+ ! if the interpolation location does not change with time, or if several
+ ! fields are to be interpolated at a given time step. (If both the fields
+ ! and the interpolation locations vary with time, there is no clear advantage in
+ ! using either this method or the method for 2D interpoaltion above; for simplicity
+ ! and because we foresee more uses for the method of this subroutine, we have not
+ ! implemented a 3D version of the fixed field, variable interpolation location method
+ ! as we have in 2D.) Coefficients are produced for handling both Dirichlet (or no)
+ ! boundary conditions. The interpolation is performed with basis functions that are
+ ! RBFs plus constant and linear.
+ ! Input:
+ ! pointCount - the number of "source" points and functionValues supplied
+ ! sourcePoints - the location of the "source" points in the 3D space where the values of
+ ! the function are known
+ ! destinationPoint - the point where the interpolation will be performed
+ ! alpha - a constant that give the characteristic length scale of the RBFs,
+ ! should be on the order of the distance between points
+ ! Output:
+ ! coefficients - the coefficients used to interpolate a function with Dirichlet
+ ! boundary conditions to the specified destinationPoint
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine mpas_rbf_interp_func_3D_sca_lin_dir_comp_coeffs(pointCount, &
+ 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 mpas_set_up_scalar_rbf_dirichlet_matrix_and_rhs(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 mpas_legs(dirichletMatrix, matrixSize, rhs, coeffs, pivotIndices)
+ coefficients = coeffs(1:pointCount)
+
+ deallocate(dirichletMatrix)
+ deallocate(rhs)
+ deallocate(coeffs)
+ deallocate(pivotIndices)
+
+ end subroutine mpas_rbf_interp_func_3D_sca_lin_dir_comp_coeffs
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Purpose: Compute interpolation coefficients in 3D that can be used to
+ ! interpolate a number of scalar functions at a given locations. This is useful
+ ! if the interpolation location does not change with time, or if several
+ ! fields are to be interpolated at a given time step. (If both the fields
+ ! and the interpolation locations vary with time, there is no clear advantage in
+ ! using either this method or the method for 2D interpoaltion above; for simplicity
+ ! and because we foresee more uses for the method of this subroutine, we have not
+ ! implemented a 3D version of the fixed field, variable interpolation location method
+ ! as we have in 2D.) Coefficients are produced for handling both Dirichlet and Neumann
+ ! boundary conditions. The interpolation is performed with basis functions that are
+ ! RBFs plus a constant.
+ ! Input:
+ ! pointCount - the number of "source" points and functionValues supplied
+ ! sourcePoints - the location of the "source" points in the 3D space where the values of
+ ! the function are known
+ ! isInterface - a logical array indicating which of the source points (if any) are at
+ ! at the domain interface. These points and their normals will be used to compute the
+ ! neumannCoefficients below
+ ! interfaceNormals - a 3D normal vector for each sourcePoint. These vectors are only used
+ ! at points where isInterface == .true., and can take arbitrary values elsewehere. The
+ ! normal vector is used to compute coefficients for the normal derivative of the
+ ! interpolating function in order to impose the Neumann Boundary condition
+ ! destinationPoint - the point where the interpolation will be performed
+ ! alpha - a constant that give the characteristic length scale of the RBFs,
+ ! should be on the order of the distance between points
+ ! Output:
+ ! dirichletCoefficients - the coefficients used to interpolate a function with Dirichlet
+ ! boundary conditions to the specified destinationPoint
+ ! neumannCoefficients - the coefficients used to interpolate a function with Neumann
+ ! boundary conditions to the specified destinationPoint
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine mpas_rbf_interp_func_3D_sca_const_dir_neu_comp_coeffs( &
+ 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 mpas_set_up_scalar_rbf_matrix_and_rhs(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 mpas_legs(dirichletMatrix, matrixSize, rhs, coeffs, pivotIndices)
+ dirichletCoefficients = coeffs(1:pointCount)
+
+ call mpas_legs(neumannMatrix, matrixSize, rhsCopy, coeffs, pivotIndices)
+ neumannCoefficients = coeffs(1:pointCount)
+
+ deallocate(dirichletMatrix)
+ deallocate(neumannMatrix)
+ deallocate(rhs)
+ deallocate(rhsCopy)
+ deallocate(coeffs)
+ deallocate(pivotIndices)
+
+ end subroutine mpas_rbf_interp_func_3D_sca_const_dir_neu_comp_coeffs
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Purpose: Compute interpolation coefficients in a plane in 3D that can be used to
+ ! interpolate a number of scalar functions at a given locations. This is useful
+ ! if the interpolation location does not change with time, or if several
+ ! fields are to be interpolated at a given time step. (If both the fields
+ ! and the interpolation locations vary with time, there is no clear advantage in
+ ! using either this method or the method for 2D interpoaltion above; for simplicity
+ ! and because we foresee more uses for the method of this subroutine, we have not
+ ! implemented a 3D version of the fixed field, variable interpolation location method
+ ! as we have in 2D.) Coefficients are produced for handling both Dirichlet and Neumann
+ ! boundary conditions. The interpolation is performed with basis functions that are
+ ! RBFs plus constant and linear. All points are projected into the plane given by the
+ ! planeBasisVectors.
+ ! Input:
+ ! pointCount - the number of "source" points and functionValues supplied
+ ! sourcePoints - the location of the "source" points in the 3D space where the values of
+ ! the function are known. The sourcePoints will be projected into the plane given by
+ ! planeBasisVectors
+ ! isInterface - a logical array indicating which of the source points (if any) are at
+ ! at the domain interface. These points and their normals will be used to compute the
+ ! neumannCoefficients below
+ ! interfaceNormals - a 3D normal vector for each sourcePoint. These vectors are only used
+ ! at points where isInterface == .true., and can take arbitrary values elsewehere. The
+ ! normal vector is used to compute coefficients for the normal derivative of the
+ ! interpolating function in order to impose the Neumann Boundary condition
+ ! destinationPoint - the point in 3D where the interpolation will be performed. The
+ ! destinationPoint will be projected into the plane given by planeBasisVectors.
+ ! alpha - a constant that give the characteristic length scale of the RBFs,
+ ! should be on the order of the distance between points
+ ! planeBasisVectors - the basis fectors for the plane where interpolation is performed.
+ ! All points are projected into this plane.
+ ! Output:
+ ! dirichletCoefficients - the coefficients used to interpolate a function with Dirichlet
+ ! boundary conditions to the specified destinationPoint
+ ! neumannCoefficients - the coefficients used to interpolate a function with Neumann
+ ! boundary conditions to the specified destinationPoint
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine mpas_rbf_interp_func_3D_plane_sca_lin_dir_neu_comp_coeffs( &
+ 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 mpas_set_up_scalar_rbf_matrix_and_rhs(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 mpas_legs(dirichletMatrix, matrixSize, rhs, coeffs, pivotIndices)
+ dirichletCoefficients = coeffs(1:pointCount)
+
+ call mpas_legs(neumannMatrix, matrixSize, rhsCopy, coeffs, pivotIndices)
+ neumannCoefficients = coeffs(1:pointCount)
+
+ deallocate(dirichletMatrix)
+ deallocate(neumannMatrix)
+ deallocate(rhs)
+ deallocate(rhsCopy)
+ deallocate(coeffs)
+ deallocate(pivotIndices)
+
+ end subroutine mpas_rbf_interp_func_3D_plane_sca_lin_dir_neu_comp_coeffs
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Purpose: Compute interpolation coefficients in 3D that can be used to
+ ! interpolate a number of scalar functions at a given locations. This is useful
+ ! if the interpolation location does not change with time, or if several
+ ! fields are to be interpolated at a given time step. (If both the fields
+ ! and the interpolation locations vary with time, there is no clear advantage in
+ ! using either this method or the method for 2D interpoaltion above; for simplicity
+ ! and because we foresee more uses for the method of this subroutine, we have not
+ ! implemented a 3D version of the fixed field, variable interpolation location method
+ ! as we have in 2D.) Coefficients are produced for handling both Dirichlet and Neumann
+ ! boundary conditions. The interpolation is performed with basis functions that are
+ ! RBFs plus constant and linear.
+ ! Input:
+ ! pointCount - the number of "source" points and functionValues supplied
+ ! sourcePoints - the location of the "source" points in the 3D space where the values of
+ ! the function are known
+ ! isInterface - a logical array indicating which of the source points (if any) are at
+ ! at the domain interface. These points and their normals will be used to compute the
+ ! neumannCoefficients below
+ ! interfaceNormals - a 3D normal vector for each sourcePoint. These vectors are only used
+ ! at points where isInterface == .true., and can take arbitrary values elsewehere. The
+ ! normal vector is used to compute coefficients for the normal derivative of the
+ ! interpolating function in order to impose the Neumann Boundary condition
+ ! destinationPoint - the point where the interpolation will be performed
+ ! alpha - a constant that give the characteristic length scale of the RBFs,
+ ! should be on the order of the distance between points
+ ! Output:
+ ! dirichletCoefficients - the coefficients used to interpolate a function with Dirichlet
+ ! boundary conditions to the specified destinationPoint
+ ! neumannCoefficients - the coefficients used to interpolate a function with Neumann
+ ! boundary conditions to the specified destinationPoint
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine mpas_rbf_interp_func_3D_sca_lin_dir_neu_comp_coeffs(pointCount, &
+ 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 mpas_set_up_scalar_rbf_matrix_and_rhs(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 mpas_legs(dirichletMatrix, matrixSize, rhs, coeffs, pivotIndices)
+ dirichletCoefficients = coeffs(1:pointCount)
+
+ call mpas_legs(neumannMatrix, matrixSize, rhsCopy, coeffs, pivotIndices)
+ neumannCoefficients = coeffs(1:pointCount)
+
+ deallocate(dirichletMatrix)
+ deallocate(neumannMatrix)
+ deallocate(rhs)
+ deallocate(rhsCopy)
+ deallocate(coeffs)
+ deallocate(pivotIndices)
+
+ end subroutine mpas_rbf_interp_func_3D_sca_lin_dir_neu_comp_coeffs
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Purpose: Compute interpolation coefficients in 3D that can be used to
+ ! interpolate a number of vector functions at a given locations. This is useful
+ ! if the interpolation location does not change with time, or if several
+ ! fields are to be interpolated at a given time step. (If both the vector fields
+ ! and the interpolation locations vary with time, there is no clear advantage in
+ ! using either this method or the method for 2D interpoaltion above; for simplicity
+ ! and because we foresee more uses for the method of this subroutine, we have not
+ ! implemented a 3D version of the fixed field, variable interpolation location method
+ ! as we have in 2D.) Coefficients are produced for handling Dirichlet boundary
+ ! conditions (or no boundaries). The interpolation is performed with basis functions
+ ! that are RBFs plus a constant.
+ ! Input:
+ ! pointCount - the number of "source" points and functionValues supplied
+ ! sourcePoints - the location of the "source" points in the 3D space where the values of
+ ! the function are known
+ ! unitVectors - the unit vectors associated with each of the sourcePoints. Interpolation
+ ! is performed by supplying the value of the vector function dotted into each of these unit
+ ! vectors. If multiple unit vectors are supplied at the same sourcePoint, they *must* be
+ ! orthogonal for the interpolation to succeed.
+ ! destinationPoint - the point where the interpolation will be performed
+ ! alpha - a constant that give the characteristic length scale of the RBFs,
+ ! should be on the order of the distance between points
+ ! Output:
+ ! coefficients - the coefficients used to interpolate a function with Dirichlet
+ ! boundary conditions to the specified destinationPoint
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine mpas_rbf_interp_func_3D_vec_const_dir_comp_coeffs(pointCount, &
+ 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 mpas_set_up_vector_dirichlet_rbf_matrix_and_rhs(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 mpas_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 mpas_rbf_interp_func_3D_vec_const_dir_comp_coeffs
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Purpose: Compute interpolation coefficients in 3D that can be used to
+ ! interpolate a number of vector functions at a given locations. This is useful
+ ! if the interpolation location does not change with time, or if several
+ ! fields are to be interpolated at a given time step. (If both the vector fields
+ ! and the interpolation locations vary with time, there is no clear advantage in
+ ! using either this method or the method for 2D interpoaltion above; for simplicity
+ ! and because we foresee more uses for the method of this subroutine, we have not
+ ! implemented a 3D version of the fixed field, variable interpolation location method
+ ! as we have in 2D.) Coefficients are produced for handling Dirichlet boundary
+ ! conditions (or no boundaries). The interpolation is performed with basis functions
+ ! that are RBFs plus a constant.
+ ! Input:
+ ! pointCount - the number of "source" points and functionValues supplied
+ ! sourcePoints - the location of the "source" points in the 3D space where the values of
+ ! the function are known. The sourcePoints are projected into the plane given by
+ ! planeBasisVectors
+ ! unitVectors - the unit vectors associated with each of the sourcePoints. Interpolation
+ ! is performed by supplying the value of the vector function dotted into each of these unit
+ ! vectors. If multiple unit vectors are supplied at the same sourcePoint, they *must* be
+ ! orthogonal for the interpolation to succeed. The unitVectors are projected into the
+ ! plane given by planeBasisVectors
+ ! destinationPoint - the point where the interpolation will be performed. The destinationPoint
+ ! is projected into the plane given by planeBasisVectors
+ ! alpha - a constant that give the characteristic length scale of the RBFs,
+ ! should be on the order of the distance between points
+ ! planeBasisVectors - the basis fectors for the plane where interpolation is performed.
+ ! All points are projected into this plane.
+ ! Output:
+ ! coefficients - the coefficients used to interpolate a function with Dirichlet
+ ! boundary conditions to the specified destinationPoint
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine mpas_rbf_interp_func_3D_plane_vec_const_dir_comp_coeffs(pointCount, &
+ 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 mpas_set_up_vector_dirichlet_rbf_matrix_and_rhs(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 mpas_legs(matrix, matrixSize, rhs(:,1), coeffs(:,1), pivotIndices)
+ call mpas_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 mpas_rbf_interp_func_3D_plane_vec_const_dir_comp_coeffs
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Purpose: Compute interpolation coefficients in 3D that can be used to
+ ! interpolate a number of vector functions at a given locations. This is useful
+ ! if the interpolation location does not change with time, or if several
+ ! fields are to be interpolated at a given time step. (If both the vector fields
+ ! and the interpolation locations vary with time, there is no clear advantage in
+ ! using either this method or the method for 2D interpoaltion above; for simplicity
+ ! and because we foresee more uses for the method of this subroutine, we have not
+ ! implemented a 3D version of the fixed field, variable interpolation location method
+ ! as we have in 2D.) Coefficients are produced for handling Dirichlet normal /
+ ! Neumann tangential boundary conditions (such as free slip). The interpolation is
+ ! performed with basis functions that are RBFs plus a constant.
+ ! Input:
+ ! pointCount - the number of "source" points and functionValues supplied
+ ! sourcePoints - the location of the "source" points in the 3D space where the values of
+ ! the function are known
+ ! isTangentToInterface - a logical array indicating which sourcePoints/unitVectors are
+ ! tangent to the interface where the boundary condition will be applied. A Neumann
+ ! boundary condition will be applied at these points in these directions.
+ ! normalVectorIndex - where isTangentToInterface == .true., the index into unitVectors that
+ ! gives the normal vector at the same sourcePoint. This information is needed to compute
+ ! the Neumann boundary condition at this point.
+ ! unitVectors - the unit vectors associated with each of the sourcePoints. Interpolation
+ ! is performed by supplying the value of the vector function dotted into each of these unit
+ ! vectors. If multiple unit vectors are supplied at the same sourcePoint, they *must* be
+ ! orthogonal for the interpolation to succeed. A normal vector and two tangential vectors
+ ! are needed at each interface point in order to satisfy the Dirichlet normal boundary
+ ! condition and the Neumann tangential boundary conditions at these points.
+ ! destinationPoint - the point where the interpolation will be performed
+ ! alpha - a constant that give the characteristic length scale of the RBFs,
+ ! should be on the order of the distance between points
+ ! Output:
+ ! coefficients - the coefficients used to interpolate a function with Dirichlet
+ ! boundary conditions to the specified destinationPoint
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine mpas_rbf_interp_func_3D_vec_const_tan_neu_comp_coeffs(pointCount, &
+ 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 mpas_set_up_vector_free_slip_rbf_matrix_and_rhs(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 mpas_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 mpas_rbf_interp_func_3D_vec_const_tan_neu_comp_coeffs
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Purpose: Compute interpolation coefficients in 3D that can be used to
+ ! interpolate a number of vector functions at a given locations. This is useful
+ ! if the interpolation location does not change with time, or if several
+ ! fields are to be interpolated at a given time step. (If both the vector fields
+ ! and the interpolation locations vary with time, there is no clear advantage in
+ ! using either this method or the method for 2D interpoaltion above; for simplicity
+ ! and because we foresee more uses for the method of this subroutine, we have not
+ ! implemented a 3D version of the fixed field, variable interpolation location method
+ ! as we have in 2D.) Coefficients are produced for handling Dirichlet normal /
+ ! Neumann tangential boundary conditions (such as free slip). The interpolation is
+ ! performed with basis functions that are RBFs plus a constant.
+ ! Input:
+ ! pointCount - the number of "source" points and functionValues supplied
+ ! sourcePoints - the location of the "source" points in the 3D space where the values of
+ ! the function are known. The sourcePoints are projected into the plane given by
+ ! planeBasisVectors
+ ! isTangentToInterface - a logical array indicating which sourcePoints/unitVectors are
+ ! tangent to the interface where the boundary condition will be applied. A Neumann
+ ! boundary condition will be applied at these points in these directions.
+ ! normalVectorIndex - where isTangentToInterface == .true., the index into unitVectors that
+ ! gives the normal vector at the same sourcePoint. This information is needed to compute
+ ! the Neumann boundary condition at this point.
+ ! unitVectors - the unit vectors associated with each of the sourcePoints. Interpolation
+ ! is performed by supplying the value of the vector function dotted into each of these unit
+ ! vectors. If multiple unit vectors are supplied at the same sourcePoint, they *must* be
+ ! orthogonal for the interpolation to succeed. A normal vector and two tangential vectors
+ ! are needed at each interface point in order to satisfy the Dirichlet normal boundary
+ ! condition and the Neumann tangential boundary conditions at these points. The unitVectors
+ ! are projected into the plane given by planeBasisVectors
+ ! destinationPoint - the point where the interpolation will be performed. The destinationPoint
+ ! is projected into the plane given by planeBasisVectors
+ ! alpha - a constant that give the characteristic length scale of the RBFs,
+ ! should be on the order of the distance between points
+ ! planeBasisVectors - the basis fectors for the plane where interpolation is performed.
+ ! All points are projected into this plane.
+ ! Output:
+ ! coefficients - the coefficients used to interpolate a function with Dirichlet
+ ! boundary conditions to the specified destinationPoint
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine mpas_rbf_interp_func_3D_plane_vec_const_tan_neu_comp_coeffs(&
+ 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 mpas_set_up_vector_free_slip_rbf_matrix_and_rhs(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 mpas_legs(matrix, matrixSize, rhs(:,1), coeffs(:,1), pivotIndices)
+ call mpas_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 mpas_rbf_interp_func_3D_plane_vec_const_tan_neu_comp_coeffs
+
+
+!!!!!!!!!!!!!!!!!!!!!
+! private subroutines
+!!!!!!!!!!!!!!!!!!!!!
+
+ function evaluate_rbf(rSquared) result(rbfValue)
+ real(kind=RKIND), intent(in) :: rSquared
+ real(kind=RKIND) :: rbfValue
+
+ ! inverse multiquadratic
+ rbfValue = 1/sqrt(1 + rSquared)
+
+ end function evaluate_rbf
+
+ subroutine mpas_evaluate_rbf_and_deriv(rSquared, rbfValue, rbfDerivOverR)
+ real(kind=RKIND), intent(in) :: rSquared
+ real(kind=RKIND), intent(out) :: rbfValue, rbfDerivOverR
+
+ ! inverse multiquadratic
+ rbfValue = 1/sqrt(1 + rSquared)
+ rbfDerivOverR = -rbfValue**3
+
+ end subroutine mpas_evaluate_rbf_and_deriv
+
+ subroutine mpas_evaluate_rbf_and_derivs(rSquared, rbfValue, rbfDerivOverR, rbfSecondDeriv)
+ real(kind=RKIND), intent(in) :: rSquared
+ real(kind=RKIND), intent(out) :: rbfValue, rbfDerivOverR, rbfSecondDeriv
+
+ ! inverse multiquadratic
+ rbfValue = 1/sqrt(1 + rSquared)
+ rbfDerivOverR = -rbfValue**3
+ rbfSecondDeriv = (2*rSquared-1)*rbfValue**5
+
+ end subroutine mpas_evaluate_rbf_and_derivs
+
+ subroutine mpas_set_up_scalar_rbf_dirichlet_matrix_and_rhs(pointCount, sourcePoints, destinationPoint, &
+ alpha, dirichletMatrix, rhs)
+
+ integer, intent(in) :: pointCount
+ real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints
+ real(kind=RKIND), dimension(3), intent(in) :: destinationPoint
+ real(kind=RKIND), intent(in) :: alpha
+ real(kind=RKIND), dimension(pointCount,pointCount), intent(out) :: dirichletMatrix
+ real(kind=RKIND), dimension(pointCount), intent(out) :: rhs
+
+ integer :: 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 = evaluate_rbf(rSquared)
+ dirichletMatrix(i,j) = rbfValue
+ end do
+ end do
+
+ do j = 1, pointCount
+ rSquared = sum((destinationPoint-sourcePoints(j,:))**2)/alpha**2
+ rhs(j) = evaluate_rbf(rSquared)
+ end do
+
+ end subroutine mpas_set_up_scalar_rbf_dirichlet_matrix_and_rhs
+
+ subroutine mpas_set_up_scalar_rbf_matrix_and_rhs(pointCount, &
+ sourcePoints, isInterface, interfaceNormals, destinationPoint, &
+ alpha, dirichletMatrix, neumannMatrix, rhs)
+
+ integer, intent(in) :: pointCount
+ real(kind=RKIND), dimension(pointCount,3), intent(in) :: sourcePoints
+ logical, dimension(pointCount), intent(in) :: isInterface
+ real(kind=RKIND), dimension(pointCount,3), intent(in) :: interfaceNormals
+ real(kind=RKIND), dimension(3), intent(in) :: destinationPoint
+ real(kind=RKIND), intent(in) :: alpha
+ real(kind=RKIND), dimension(pointCount,pointCount), intent(out) :: &
+ dirichletMatrix, neumannMatrix
+ real(kind=RKIND), dimension(pointCount), intent(out) :: rhs
+
+ integer :: 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 mpas_evaluate_rbf_and_deriv(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 = evaluate_rbf(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) = evaluate_rbf(rSquared)
+ end do
+
+ end subroutine mpas_set_up_scalar_rbf_matrix_and_rhs
+
+ subroutine mpas_set_up_vector_dirichlet_rbf_matrix_and_rhs(pointCount, dimensions, &
+ sourcePoints, unitVectors, destinationPoint, &
+ alpha, matrix, rhs)
+
+ integer, intent(in) :: pointCount, dimensions
+ real(kind=RKIND), dimension(pointCount,dimensions), intent(in) :: sourcePoints
+ real(kind=RKIND), dimension(pointCount,dimensions), intent(in) :: unitVectors
+ real(kind=RKIND), dimension(dimensions), intent(in) :: destinationPoint
+ real(kind=RKIND), intent(in) :: alpha
+ real(kind=RKIND), dimension(pointCount,pointCount), intent(out) :: matrix
+ real(kind=RKIND), dimension(pointCount,dimensions), intent(out) :: rhs
+
+ integer :: 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 = evaluate_rbf(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,:) = evaluate_rbf(rSquared)*unitVectors(j,:)
+ end do
+
+ end subroutine mpas_set_up_vector_dirichlet_rbf_matrix_and_rhs
+
+ subroutine mpas_set_up_vector_free_slip_rbf_matrix_and_rhs(pointCount, dimensions, &
+ sourcePoints, isTangentToInterface, normalVectorIndex, unitVectors, destinationPoint, &
+ alpha, matrix, rhs)
+
+ integer, intent(in) :: pointCount, dimensions
+ real(kind=RKIND), dimension(pointCount,dimensions), intent(in) :: sourcePoints
+ logical, dimension(pointCount), intent(in) :: isTangentToInterface
+ integer, dimension(pointCount), intent(in) :: normalVectorIndex
+ real(kind=RKIND), dimension(pointCount,dimensions), intent(in) :: unitVectors
+ real(kind=RKIND), dimension(dimensions), intent(in) :: destinationPoint
+ real(kind=RKIND), intent(in) :: alpha
+ real(kind=RKIND), dimension(pointCount,pointCount), intent(out) :: matrix
+ real(kind=RKIND), dimension(pointCount,dimensions), intent(out) :: rhs
+
+ integer :: 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 mpas_evaluate_rbf_and_deriv(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 = evaluate_rbf(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,:) = evaluate_rbf(rSquared)*unitVectors(j,:)
+ end do
+
+ end subroutine mpas_set_up_vector_free_slip_rbf_matrix_and_rhs
+
+ subroutine mpas_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 mpas_unit_vec_in_r3
+
+ subroutine mpas_cross_product_in_r3(p_1,p_2,p_out)
+ real (kind=RKIND), intent(in) :: p_1 (3), p_2 (3)
+ real (kind=RKIND), intent(out) :: p_out (3)
+
+ p_out(1) = p_1(2)*p_2(3)-p_1(3)*p_2(2)
+ p_out(2) = p_1(3)*p_2(1)-p_1(1)*p_2(3)
+ p_out(3) = p_1(1)*p_2(2)-p_1(2)*p_2(1)
+ end subroutine mpas_cross_product_in_r3
+
+! 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 mpas_legs (A,N,B,X,INDX)
+!
+! WRITE (6, "(F16.8)") (X(I), I=1,N)
+!END PROGRAM EX43
+
+
+subroutine mpas_legs (A,N,B,X,INDX)
+!
+! subroutine to solve the equation A(N,N)*X(N) = B(N) with the
+! partial-pivoting Gaussian elimination scheme.
+! Copyright (c) Tao Pang 2001.
+!
+ 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 mpas_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 mpas_rbf_interpolation
+
Copied: trunk/mpas/src/operators/mpas_spline_interpolation.F (from rev 1113, branches/source_renaming/src/operators/mpas_spline_interpolation.F)
===================================================================
--- trunk/mpas/src/operators/mpas_spline_interpolation.F (rev 0)
+++ trunk/mpas/src/operators/mpas_spline_interpolation.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -0,0 +1,430 @@
+module mpas_spline_interpolation
+
+ implicit none
+
+ private
+
+ public :: mpas_cubic_spline_coefficients, &
+ mpas_interpolate_cubic_spline, &
+ mpas_integrate_cubic_spline, &
+ mpas_integrate_column_cubic_spline, &
+ mpas_interpolate_linear, &
+ mpas_test_interpolate
+
+! Short Descriptions:
+
+! mpas_cubic_spline_coefficients: Compute second derivatives at nodes.
+! This must be run before any of the other cubic spine functions.
+
+! mpas_interpolate_cubic_spline: Compute cubic spline interpolation.
+
+! mpas_integrate_cubic_spline: Compute a single integral from spline data.
+
+! mpas_integrate_column_cubic_spline: Compute multiple integrals from spline data.
+
+! mpas_interpolate_linear: Compute linear interpolation.
+
+! mpas_test_interpolate: Test spline interpolation subroutines.
+
+ contains
+
+ subroutine mpas_cubic_spline_coefficients(x,y,n,y2ndDer)
+
+! Given arrays x(1:n) and y(1:n) containing a function,
+! i.e., y(i) = f(x(i)), with x monotonically increasing
+! this routine returns an array y2ndDer(1:n) that contains
+! the second derivatives of the interpolating function at x(1:n).
+! This routine uses boundary conditions for a natural spline,
+! with zero second derivative on that boundary.
+
+! INPUT PARAMETERS:
+
+ integer, intent(in) :: &
+ n ! number of nodes
+ real(kind=RKIND), intent(in), dimension(n) :: &
+ x, &! location of nodes
+ y ! value at nodes
+
+! OUTPUT PARAMETERS:
+
+ real(kind=RKIND), intent(out), dimension(n) :: &
+ y2ndDer ! dy^2/dx^2 at each node
+
+! local variables:
+
+ integer :: i
+ real(kind=RKIND) :: &
+ temp,xRatio,a(n)
+
+ y2ndDer(1)=0.0
+ y2ndDer(n)=0.0
+ a(1)=0.0
+
+ do i=2,n-1
+ xRatio=(x(i)-x(i-1))/(x(i+1)-x(i-1))
+ temp=1.0/(2.0+xRatio*y2ndDer(i-1))
+ y2ndDer(i)=temp*(xRatio-1.0)
+ a(i) = temp*(6.0*((y(i+1)-y(i))/(x(i+1)-x(i)) &
+ -(y(i)-y(i-1))/(x(i)-x(i-1)))/(x(i+1)-x(i-1)) &
+ -xRatio*a(i-1))
+ enddo
+
+ do i=n-1,1,-1
+ y2ndDer(i)=y2ndDer(i)*y2ndDer(i+1)+a(i)
+ enddo
+
+ end subroutine mpas_cubic_spline_coefficients
+
+
+ subroutine mpas_interpolate_cubic_spline( &
+ x,y,y2ndDer,n, &
+ xOut,yOut,nOut)
+
+! Given the arrays x(1:n) and y(1:n), which tabulate a function,
+! and given the array y2ndDer(1:n), which is the output from
+! CubicSplineCoefficients above, this routine returns the
+! cubic-spline interpolated values of yOut(1:nOut) at xOut(1:nOut).
+! This subroutine assumes that both x and xOut are monotonically
+! increasing, and that all values of xOut are within the first and
+! last values of x.
+
+! INPUT PARAMETERS:
+
+ real (kind=RKIND), dimension(n), intent(in) :: &
+ x, &! node location, input grid
+ y, &! interpolation variable, input grid
+ y2ndDer ! 2nd derivative of y at nodes
+
+ real (kind=RKIND), dimension(nOut), intent(in) :: &
+ xOut ! node location, output grid
+
+ integer, intent(in) :: &
+ n, &! number of nodes, input grid
+ nOut ! number of nodes, output grid
+
+! OUTPUT PARAMETERS:
+
+ real (kind=RKIND), dimension(nOut), intent(out) :: &
+ yOut ! interpolation variable, output grid
+
+! local variables:
+
+ integer :: &
+ kIn, kOut ! counters
+
+ real (kind=RKIND) :: &
+ a, b, h
+
+ kOut = 1
+
+ kInLoop: do kIn = 1,n-1
+
+ h = x(kIn+1)-x(kIn)
+
+ do while(xOut(kOut) < x(kIn+1))
+
+ a = (x(kIn+1)-xOut(kOut))/h
+ b = (xOut(kOut)-x (kIn) )/h
+ yOut(kOut) = a*y(kIn) + b*y(kIn+1) &
+ + ((a**3-a)*y2ndDer(kIn) + (b**3-b)*y2ndDer(kIn+1)) &
+ *(h**2)/6.0
+
+ kOut = kOut + 1
+
+ if (kOut>nOut) exit kInLoop
+
+ enddo
+
+ enddo kInLoop
+
+end subroutine mpas_interpolate_cubic_spline
+
+
+subroutine mpas_integrate_cubic_spline(x,y,y2ndDer,n,x1,x2,y_integral)
+
+! Given the arrays x(1:n) and y(1:n), which tabulate a function,
+! and given the array y2ndDer(1:n), which is the output from
+! CubicSplineCoefficients above, this routine returns y_integral,
+! the integral of y from x1 to x2. The integration formula was
+! created by analytically integrating a cubic spline between each node.
+! This subroutine assumes that x is monotonically increasing, and
+! that x1 < x2.
+
+! INPUT PARAMETERS:
+
+ integer, intent(in) :: &
+ n ! number of nodes
+ real(kind=RKIND), intent(in), dimension(n) :: &
+ x, &! location of nodes
+ y, &! value at nodes
+ y2ndDer ! dy^2/dx^2 at each node
+ real(kind=RKIND), intent(in) :: &
+ x1,x2 ! limits of integration
+
+! OUTPUT PARAMETERS:
+
+ real(kind=RKIND), intent(out) :: &
+ y_integral ! integral of y
+
+! local variables:
+
+ integer :: i,j,k
+ real(kind=RKIND) :: h,h2, A2,B2, F1,F2, eps1
+
+ if (x1<x(1).or.x2>x(n).or.x1>x2) then
+ print *, 'error on integration bounds'
+ endif
+
+ y_integral = 0.0
+ eps1 = 1e-14*x2
+
+ do j=1,n-1 ! loop through sections
+ ! section x(j) ... x(j+1)
+
+ if (x2<=x(j) +eps1) exit
+ if (x1>=x(j+1)-eps1) cycle
+
+ h = x(j+1) - x(j)
+ h2 = h**2
+
+ ! left side:
+ if (x1<x(j)) then
+ F1 = -y(j)*h*0.5 + y2ndDer(j)*h**3/24.0
+ else
+ A2 = (x(j+1)-x1 )**2/h2
+ B2 = (x1 -x(j))**2/h2
+ F1 = 0.5*h*( -y(j)*A2 + y(j+1)*B2 &
+ + y2ndDer(j) *h2*(-0.5*A2**2 + A2)/6.0 &
+ + y2ndDer(j+1)*h2*( 0.5*B2**2 - B2)/6.0 )
+ endif
+
+ ! right side:
+ if (x2>x(j+1)) then
+ F2 = y(j+1)*h*0.5 - y2ndDer(j+1)*h**3/24.0
+ else
+ A2 = (x(j+1)-x2 )**2/h2
+ B2 = (x2 -x(j))**2/h2
+ F2 = 0.5*h*( -y(j)*A2 + y(j+1)*B2 &
+ + y2ndDer(j) *h2*(-0.5*A2**2 + A2)/6.0 &
+ + y2ndDer(j+1)*h2*( 0.5*B2**2 - B2)/6.0 )
+ endif
+
+ y_integral = y_integral + F2 - F1
+
+ enddo ! j
+
+ end subroutine mpas_integrate_cubic_spline
+
+
+ subroutine mpas_integrate_column_cubic_spline( &
+ x,y,y2ndDer,n, &
+ xOut,y_integral, nOut)
+
+! Given the arrays x(1:n) and y(1:n), which tabulate a function,
+! and given the array y2ndDer(1:n), which is the output from
+! CubicSplineCoefficients above, this routine returns
+! y_integral(1:nOut), the integral of y.
+! This is a cumulative integration, so that
+! y_integral(j) holds the integral of y from x(1) to xOut(j).
+! The integration formula was created by analytically integrating a
+! cubic spline between each node.
+! This subroutine assumes that both x and xOut are monotonically
+! increasing, and that all values of xOut are within the first and
+
+! INPUT PARAMETERS:
+
+ integer, intent(in) :: &
+ n, &! number of nodes
+ nOut ! number of output locations to compute integral
+ real(kind=RKIND), intent(in), dimension(n) :: &
+ x, &! location of nodes
+ y, &! value at nodes
+ y2ndDer ! dy^2/dx^2 at each node
+ real(kind=RKIND), dimension(nOut), intent(in) :: &
+ xOut ! output locations to compute integral
+
+! OUTPUT PARAMETERS:
+
+ real(kind=RKIND), dimension(nOut), intent(out) :: &
+ y_integral ! integral from 0 to xOut
+
+! local variables:
+
+ integer :: i,j,k
+ real(kind=RKIND) :: h,h2, A2,B2, F1,F2, eps1
+
+ y_integral = 0.0
+ j = 1
+ h = x(j+1) - x(j)
+ h2 = h**2
+ F1 = -y(j)*h*0.5 + y2ndDer(j)*h**3/24.0
+ eps1 = 0.0 ! note: could use 1e-12*xOut(nOut)
+
+ k_loop: do k = 1,nOut
+
+ if (k>1) y_integral(k) = y_integral(k-1)
+
+ do while(xOut(k) > x(j+1)-eps1)
+ F2 = y(j+1)*h*0.5 - y2ndDer(j+1)*h**3/24.0
+
+ y_integral(k) = y_integral(k) + F2 - F1
+ j = j+1
+ h = x(j+1) - x(j)
+ h2 = h**2
+ F1 = -y(j)*h*0.5 + y2ndDer(j)*h**3/24.0
+ if (abs(xOut(k) - x(j+1))<eps1) cycle k_loop
+ enddo
+
+ A2 = (x(j+1) - xOut(k))**2/h2
+ B2 = (xOut(k) - x(j) )**2/h2
+ F2 = 0.5*h*( -y(j)*A2 + y(j+1)*B2 &
+ + y2ndDer(j) *h2*(-0.5*A2**2 + A2)/6.0 &
+ + y2ndDer(j+1)*h2*( 0.5*B2**2 - B2)/6.0 )
+
+ y_integral(k) = y_integral(k) + F2 - F1
+
+ if (k < nOut) then
+ A2 = (x(j+1) -xOut(k))**2/h2
+ B2 = (xOut(k) -x(j) )**2/h2
+ F1 = 0.5*h*( -y(j)*A2 + y(j+1)*B2 &
+ + y2ndDer(j) *h2*(-0.5*A2**2 + A2)/6.0 &
+ + y2ndDer(j+1)*h2*( 0.5*B2**2 - B2)/6.0 )
+ endif
+
+ enddo k_loop
+
+ end subroutine mpas_integrate_column_cubic_spline
+
+
+ subroutine mpas_interpolate_linear( &
+ x,y,n, &
+ xOut,yOut,nOut)
+
+! Given the arrays x(1:n) and y(1:n), which tabulate a function,
+! this routine returns the linear interpolated values of yOut(1:nOut)
+! at xOut(1:nOut).
+! This subroutine assumes that both x and xOut are monotonically
+! increasing, and that all values of xOut are within the first and
+! last values of x.
+
+! !INPUT PARAMETERS:
+
+ real (kind=RKIND), dimension(n), intent(in) :: &
+ x, &! node location, input grid
+ y ! interpolation variable, input grid
+
+ real (kind=RKIND), dimension(nOut), intent(in) :: &
+ xOut ! node location, output grid
+
+ integer, intent(in) :: &
+ N, &! number of nodes, input grid
+ NOut ! number of nodes, output grid
+
+! !OUTPUT PARAMETERS:
+
+ real (kind=RKIND), dimension(nOut), intent(out) :: &
+ yOut ! interpolation variable, output grid
+
+!-----------------------------------------------------------------------
+!
+! local variables
+!
+!-----------------------------------------------------------------------
+
+ integer :: &
+ kIn, kOut ! counters
+
+ kOut = 1
+
+ kInLoop: do kIn = 1,n-1
+
+ do while(xOut(kOut) < x(kIn+1))
+
+ yOut(kOut) = y(kIn) &
+ + (y(kIn+1)-y(kIn)) &
+ /(x(kIn+1) -x(kIn) ) &
+ *(xOut(kOut) -x(kIn) )
+
+ kOut = kOut + 1
+
+ if (kOut>nOut) exit kInLoop
+
+ enddo
+
+ enddo kInLoop
+
+ end subroutine mpas_interpolate_linear
+
+
+ subroutine mpas_test_interpolate
+
+! Test function to show how to operate the cubic spline subroutines
+
+ integer, parameter :: &
+ n = 10
+ real (kind=RKIND), dimension(n) :: &
+ y, x, y2ndDer
+
+ integer, parameter :: &
+ nOut = 100
+ real (kind=RKIND), dimension(nOut) :: &
+ yOut, xOut
+
+ integer :: &
+ k
+
+!-----------------------------------------------------------------------
+!
+! Create x, y, xOut
+!
+!-----------------------------------------------------------------------
+
+ do k=1,n
+ x(k) = k-4
+ ! trig function:
+ y(k) = sin(x(k)/2)
+ enddo
+
+ do k=1,nOut
+ xOut(k) = x(1) + k/(nOut+1.0)*(x(n)-x(1))
+ enddo
+
+!-----------------------------------------------------------------------
+!
+! Interpolate
+!
+!-----------------------------------------------------------------------
+
+ ! First, compute second derivative values at each node, y2ndDer.
+ call mpas_cubic_spline_coefficients(x,y,n,y2ndDer)
+
+ ! Compute interpolated values yOut.
+ call mpas_interpolate_cubic_spline( &
+ x,y,y2ndDer,n, &
+ xOut,yOut,nOut)
+
+ ! The following output can be copied directly into Matlab
+ print *, 'subplot(2,1,1)'
+ print '(a,10f8.4,a)', 'x = [',x,'];'
+ print '(a,10f8.4,a)', 'y = [',y,'];'
+ print '(a,100f8.4,a)', 'xOut = [',xOut,'];'
+ print '(a,100f8.4,a)', 'yOut = [',yOut,'];'
+ print *, "plot(x,y,'-*r',xOut,yOut,'x')"
+
+ ! Compute interpolated values yOut.
+ call mpas_integrate_column_cubic_spline( &
+ x,y,y2ndDer,n, &
+ xOut,yOut,nOut)
+
+ ! The following output can be copied directly into Matlab
+ print *, 'subplot(2,1,2)'
+ print '(a,10f8.4,a)', 'x = [',x,'];'
+ print '(a,10f8.4,a)', 'y = 2*cos(-3/2) -2*cos(x/2);'
+ print '(a,100f8.4,a)', 'xOut = [',xOut,'];'
+ print '(a,100f8.4,a)', 'yOut = [',yOut,'];'
+ print *, "plot(x,y,'-*r',xOut,yOut,'x')"
+
+ end subroutine mpas_test_interpolate
+
+end module mpas_spline_interpolation
+
Copied: trunk/mpas/src/operators/mpas_vector_reconstruction.F (from rev 1113, branches/source_renaming/src/operators/mpas_vector_reconstruction.F)
===================================================================
--- trunk/mpas/src/operators/mpas_vector_reconstruction.F (rev 0)
+++ trunk/mpas/src/operators/mpas_vector_reconstruction.F 2011-10-21 19:18:00 UTC (rev 1114)
@@ -0,0 +1,196 @@
+module mpas_vector_reconstruction
+
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_constants
+ use mpas_rbf_interpolation
+
+ implicit none
+
+ public :: mpas_init_reconstruct, mpas_reconstruct
+
+ contains
+
+ subroutine mpas_init_reconstruct(grid)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Purpose: pre-compute coefficients used by the reconstruct() routine
+ !
+ ! Input: grid meta data
+ !
+ ! Output: grid % coeffs_reconstruct - coefficients used to reconstruct
+ ! velocity vectors at cell centers
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (mesh_type), intent(inout) :: grid
+
+ ! temporary arrays needed in the (to be constructed) init procedure
+ integer :: nCellsSolve
+ integer, dimension(:,:), pointer :: edgesOnCell
+ integer, dimension(:), pointer :: nEdgesOnCell
+ integer :: i, iCell, iEdge, pointCount, maxEdgeCount
+ real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell, xEdge, yEdge, zEdge
+ real (kind=RKIND) :: r, cellCenter(3), alpha, tangentPlane(2,3)
+ real (kind=RKIND), allocatable, dimension(:,:) :: edgeOnCellLocations, edgeOnCellNormals, &
+ coeffs
+
+ real(kind=RKIND), dimension(:,:), pointer :: edgeNormalVectors
+ real(kind=RKIND), dimension(:,:,:), pointer :: cellTangentPlane
+
+ real (kind=RKIND), dimension(:,:,:), pointer :: coeffs_reconstruct
+
+ !========================================================
+ ! arrays filled and saved during init procedure
+ !========================================================
+ coeffs_reconstruct => grid % coeffs_reconstruct % array
+
+ !========================================================
+ ! temporary variables needed for init procedure
+ !========================================================
+ xCell => grid % xCell % array
+ yCell => grid % yCell % array
+ zCell => grid % zCell % array
+ xEdge => grid % xEdge % array
+ yEdge => grid % yEdge % array
+ zEdge => grid % zEdge % array
+ edgesOnCell => grid % edgesOnCell % array
+ nEdgesOnCell=> grid % nEdgesOnCell % array
+ nCellsSolve = grid % nCellsSolve
+ edgeNormalVectors => grid % edgeNormalVectors % array
+ cellTangentPlane => grid % cellTangentPlane % array
+
+
+ ! init arrays
+ coeffs_reconstruct = 0.0
+
+ maxEdgeCount = maxval(nEdgesOnCell)
+
+ allocate(edgeOnCellLocations(maxEdgeCount,3))
+ allocate(edgeOnCellNormals(maxEdgeCount,3))
+ allocate(coeffs(maxEdgeCount,3))
+
+ ! loop over all cells to be solved on this block
+ do iCell=1,nCellsSolve
+ pointCount = nEdgesOnCell(iCell)
+ cellCenter(1) = xCell(iCell)
+ cellCenter(2) = yCell(iCell)
+ cellCenter(3) = zCell(iCell)
+
+ do i=1,pointCount
+ iEdge = edgesOnCell(i,iCell)
+ edgeOnCellLocations(i,1) = xEdge(iEdge)
+ edgeOnCellLocations(i,2) = yEdge(iEdge)
+ edgeOnCellLocations(i,3) = zEdge(iEdge)
+ edgeOnCellNormals(i,:) = edgeNormalVectors(:, iEdge)
+ end do
+
+ alpha = 0.0
+ do i=1,pointCount
+ r = sqrt(sum((cellCenter - edgeOnCellLocations(i,:))**2))
+ alpha = alpha + r
+ enddo
+ alpha = alpha/pointCount
+
+ tangentPlane(1,:) = cellTangentPlane(:,1,iCell)
+ tangentPlane(2,:) = cellTangentPlane(:,2,iCell)
+
+ call mpas_rbf_interp_func_3D_plane_vec_const_dir_comp_coeffs(pointCount, &
+ edgeOnCellLocations(1:pointCount,:), &
+ edgeOnCellNormals(1:pointCount,:), &
+ cellCenter, alpha, tangentPlane, coeffs(1:pointCount,:))
+
+ do i=1,pointCount
+ coeffs_reconstruct(:,i,iCell) = coeffs(i,:)
+ end do
+
+ enddo ! iCell
+
+ deallocate(edgeOnCellLocations)
+ deallocate(edgeOnCellNormals)
+ deallocate(coeffs)
+
+ end subroutine mpas_init_reconstruct
+
+ subroutine mpas_reconstruct(grid, u, uReconstructX, uReconstructY, uReconstructZ, uReconstructZonal, uReconstructMeridional)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Purpose: reconstruct vector field at cell centers based on radial basis functions
+ !
+ ! Input: grid meta data and vector component data residing at cell edges
+ !
+ ! Output: reconstructed vector field (measured in X,Y,Z) located at cell centers
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (mesh_type), intent(in) :: grid
+ real (kind=RKIND), dimension(:,:), intent(in) :: u
+ real (kind=RKIND), dimension(:,:), intent(out) :: uReconstructX, uReconstructY, uReconstructZ
+ real (kind=RKIND), dimension(:,:), intent(out) :: uReconstructZonal, uReconstructMeridional
+
+ ! 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 :: latCell, lonCell
+
+ real (kind=RKIND), dimension(:,:,:), pointer :: coeffs_reconstruct
+
+ logical :: on_a_sphere
+
+ real (kind=RKIND) :: clat, slat, clon, slon
+
+
+ ! stored arrays used during compute procedure
+ coeffs_reconstruct => grid % coeffs_reconstruct % array
+
+ ! temporary variables
+ edgesOnCell => grid % edgesOnCell % array
+ nEdgesOnCell=> grid % nEdgesOnCell % array
+ nCellsSolve = grid % nCellsSolve
+
+ latCell => grid % latCell % array
+ lonCell => grid % lonCell % array
+ on_a_sphere = grid % on_a_sphere
+
+ ! init the intent(out)
+ uReconstructX = 0.0
+ uReconstructY = 0.0
+ uReconstructZ = 0.0
+
+ ! loop over cell centers
+ do iCell=1,nCellsSolve
+ ! a more efficient reconstruction where rbf_values*matrix_reconstruct has been precomputed
+ ! in coeffs_reconstruct
+ do i=1,nEdgesOnCell(iCell)
+ iEdge = edgesOnCell(i,iCell)
+ uReconstructX(:,iCell) = uReconstructX(:,iCell) &
+ + coeffs_reconstruct(1,i,iCell) * u(:,iEdge)
+ uReconstructY(:,iCell) = uReconstructY(:,iCell) &
+ + coeffs_reconstruct(2,i,iCell) * u(:,iEdge)
+ uReconstructZ(:,iCell) = uReconstructZ(:,iCell) &
+ + coeffs_reconstruct(3,i,iCell) * u(:,iEdge)
+
+ enddo
+ enddo ! iCell
+
+ if(on_a_sphere) then
+ do iCell=1,nCellsSolve
+ clat = cos(latCell(iCell))
+ slat = sin(latCell(iCell))
+ clon = cos(lonCell(iCell))
+ slon = sin(lonCell(iCell))
+ uReconstructZonal(:,iCell) = -uReconstructX(:,iCell)*slon + uReconstructY(:,iCell)*clon
+ uReconstructMeridional(:,iCell) = -(uReconstructX(:,iCell)*clon &
+ + uReconstructY(:,iCell)*slon)*slat &
+ + uReconstructZ(:,iCell)*clat
+ end do
+ else
+ uReconstructZonal = uReconstructX
+ uReconstructMeridional = uReconstructY
+ end if
+
+ end subroutine mpas_reconstruct
+
+end module mpas_vector_reconstruction
Modified: trunk/mpas/src/registry/gen_inc.c
===================================================================
--- trunk/mpas/src/registry/gen_inc.c 2011-10-21 19:04:04 UTC (rev 1113)
+++ trunk/mpas/src/registry/gen_inc.c 2011-10-21 19:18:00 UTC (rev 1114)
@@ -139,10 +139,10 @@
fd = fopen("config_bcast_namelist.inc", "w");
nls_ptr = nls;
while (nls_ptr) {
- if (nls_ptr->vtype == INTEGER) fortprintf(fd, " call dmpar_bcast_int(dminfo, %s)</font>
<font color="red">", nls_ptr->name);
- if (nls_ptr->vtype == REAL) fortprintf(fd, " call dmpar_bcast_real(dminfo, %s)</font>
<font color="red">", nls_ptr->name);
- if (nls_ptr->vtype == LOGICAL) fortprintf(fd, " call dmpar_bcast_logical(dminfo, %s)</font>
<font color="red">", nls_ptr->name);
- if (nls_ptr->vtype == CHARACTER) fortprintf(fd, " call dmpar_bcast_char(dminfo, %s)</font>
<font color="blue">", nls_ptr->name);
+ if (nls_ptr->vtype == INTEGER) fortprintf(fd, " call mpas_dmpar_bcast_int(dminfo, %s)</font>
<font color="blue">", nls_ptr->name);
+ if (nls_ptr->vtype == REAL) fortprintf(fd, " call mpas_dmpar_bcast_real(dminfo, %s)</font>
<font color="blue">", nls_ptr->name);
+ if (nls_ptr->vtype == LOGICAL) fortprintf(fd, " call mpas_dmpar_bcast_logical(dminfo, %s)</font>
<font color="blue">", nls_ptr->name);
+ if (nls_ptr->vtype == CHARACTER) fortprintf(fd, " call mpas_dmpar_bcast_char(dminfo, %s)</font>
<font color="black">", nls_ptr->name);
nls_ptr = nls_ptr->next;
}
fortprintf(fd, "</font>
<font color="gray">");
@@ -253,8 +253,8 @@
fd = fopen("read_dims.inc", "w");
dim_ptr = dims;
while (dim_ptr) {
- if (dim_ptr->constant_value < 0 && !dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, " call io_input_get_dimension(input_obj, \'%s\', %s)</font>
<font color="red">", dim_ptr->name_in_file, dim_ptr->name_in_code);
- else if (dim_ptr->constant_value < 0 && dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, " call io_input_get_dimension(input_obj, \'%s\', %s)</font>
<font color="blue">", dim_ptr->name_in_file, dim_ptr->name_in_file);
+ if (dim_ptr->constant_value < 0 && !dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, " call mpas_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 mpas_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;
}
@@ -474,13 +474,13 @@
fortprintf(fd, " allocate(b %% %s %% time_levs(%i))</font>
<font color="black">", group_ptr->name, group_ptr->vlist->var->ntime_levs);
fortprintf(fd, " do i=1,b %% %s %% nTimeLevels</font>
<font color="black">", group_ptr->name);
fortprintf(fd, " allocate(b %% %s %% time_levs(i) %% %s)</font>
<font color="red">", group_ptr->name, group_ptr->name);
- fortprintf(fd, " call allocate_%s(b %% %s %% time_levs(i) %% %s, &</font>
<font color="blue">", group_ptr->name, group_ptr->name, group_ptr->name);
+ fortprintf(fd, " call mpas_allocate_%s(b %% %s %% time_levs(i) %% %s, &</font>
<font color="black">", group_ptr->name, group_ptr->name, group_ptr->name);
fortprintf(fd, "#include \"dim_dummy_args.inc\"</font>
<font color="black">");
fortprintf(fd, " )</font>
<font color="black">");
fortprintf(fd, " end do</font>
<font color="black"></font>
<font color="red">");
}
else {
- fortprintf(fd, " call allocate_%s(b %% %s, &</font>
<font color="blue">", group_ptr->name, group_ptr->name);
+ fortprintf(fd, " call mpas_allocate_%s(b %% %s, &</font>
<font color="black">", group_ptr->name, group_ptr->name);
fortprintf(fd, "#include \"dim_dummy_args.inc\"</font>
<font color="black">");
fortprintf(fd, " )</font>
<font color="black"></font>
<font color="gray">");
}
@@ -495,13 +495,13 @@
while (group_ptr) {
if (group_ptr->vlist->var->ntime_levs > 1) {
fortprintf(fd, " do i=1,b %% %s %% nTimeLevels</font>
<font color="red">", group_ptr->name);
- fortprintf(fd, " call deallocate_%s(b %% %s %% time_levs(i) %% %s)</font>
<font color="blue">", group_ptr->name, group_ptr->name, group_ptr->name);
+ fortprintf(fd, " call mpas_deallocate_%s(b %% %s %% time_levs(i) %% %s)</font>
<font color="black">", group_ptr->name, group_ptr->name, group_ptr->name);
fortprintf(fd, " deallocate(b %% %s %% time_levs(i) %% %s)</font>
<font color="black">", group_ptr->name, group_ptr->name);
fortprintf(fd, " end do</font>
<font color="black">");
fortprintf(fd, " deallocate(b %% %s %% time_levs)</font>
<font color="red">", group_ptr->name);
}
else {
- fortprintf(fd, " call deallocate_%s(b %% %s)</font>
<font color="blue">", group_ptr->name, group_ptr->name);
+ fortprintf(fd, " call mpas_deallocate_%s(b %% %s)</font>
<font color="black">", group_ptr->name, group_ptr->name);
}
fortprintf(fd, " deallocate(b %% %s)</font>
<font color="black"></font>
<font color="gray">", group_ptr->name);
group_ptr = group_ptr->next;
@@ -512,7 +512,7 @@
fd = fopen("group_alloc_routines.inc", "w");
group_ptr = groups;
while (group_ptr) {
- fortprintf(fd, " subroutine allocate_%s(%s, &</font>
<font color="blue">", group_ptr->name, group_ptr->name);
+ fortprintf(fd, " subroutine mpas_allocate_%s(%s, &</font>
<font color="black">", group_ptr->name, group_ptr->name);
fortprintf(fd, "#include \"dim_dummy_args.inc\"</font>
<font color="black">");
fortprintf(fd, " )</font>
<font color="black">");
fortprintf(fd, "</font>
<font color="gray">");
@@ -659,7 +659,7 @@
}
}
- fortprintf(fd, " end subroutine allocate_%s</font>
<font color="black"></font>
<font color="black"></font>
<font color="blue">", group_ptr->name);
+ fortprintf(fd, " end subroutine mpas_allocate_%s</font>
<font color="black"></font>
<font color="black"></font>
<font color="gray">", group_ptr->name);
group_ptr = group_ptr->next;
}
fclose(fd);
@@ -668,7 +668,7 @@
fd = fopen("group_dealloc_routines.inc", "w");
group_ptr = groups;
while (group_ptr) {
- fortprintf(fd, " subroutine deallocate_%s(%s)</font>
<font color="blue">", group_ptr->name, group_ptr->name);
+ fortprintf(fd, " subroutine mpas_deallocate_%s(%s)</font>
<font color="black">", group_ptr->name, group_ptr->name);
fortprintf(fd, "</font>
<font color="black">");
fortprintf(fd, " implicit none</font>
<font color="black">");
fortprintf(fd, "</font>
<font color="gray">");
@@ -705,7 +705,7 @@
}
}
- fortprintf(fd, " end subroutine deallocate_%s</font>
<font color="black"></font>
<font color="black"></font>
<font color="blue">", group_ptr->name);
+ fortprintf(fd, " end subroutine mpas_deallocate_%s</font>
<font color="black"></font>
<font color="black"></font>
<font color="gray">", group_ptr->name);
group_ptr = group_ptr->next;
}
fclose(fd);
@@ -714,7 +714,7 @@
fd = fopen("group_copy_routines.inc", "w");
group_ptr = groups;
while (group_ptr) {
- fortprintf(fd, " subroutine copy_%s(dest, src)</font>
<font color="blue">", group_ptr->name);
+ fortprintf(fd, " subroutine mpas_copy_%s(dest, src)</font>
<font color="black">", group_ptr->name);
fortprintf(fd, "</font>
<font color="black">");
fortprintf(fd, " implicit none</font>
<font color="black">");
fortprintf(fd, "</font>
<font color="gray">");
@@ -748,7 +748,7 @@
}
}
fortprintf(fd, "</font>
<font color="red">");
- fortprintf(fd, " end subroutine copy_%s</font>
<font color="black"></font>
<font color="black"></font>
<font color="blue">", group_ptr->name);
+ fortprintf(fd, " end subroutine mpas_copy_%s</font>
<font color="black"></font>
<font color="black"></font>
<font color="gray">", group_ptr->name);
group_ptr = group_ptr->next;
}
fclose(fd);
@@ -758,7 +758,7 @@
group_ptr = groups;
while (group_ptr) {
if (group_ptr->vlist->var->ntime_levs > 1) {
- fortprintf(fd, " subroutine shift_time_levels_%s(%s)</font>
<font color="blue">", group_ptr->name, group_ptr->name);
+ fortprintf(fd, " subroutine mpas_shift_time_levels_%s(%s)</font>
<font color="black">", group_ptr->name, group_ptr->name);
fortprintf(fd, "</font>
<font color="black">");
fortprintf(fd, " implicit none</font>
<font color="black">");
fortprintf(fd, "</font>
<font color="gray">");
@@ -773,7 +773,7 @@
fortprintf(fd, " end do</font>
<font color="black">");
fortprintf(fd, " %s %% time_levs(%s %% nTimeLevels) %% %s => sptr</font>
<font color="black">", group_ptr->name, group_ptr->name, group_ptr->name);
fortprintf(fd, "</font>
<font color="red">");
- fortprintf(fd, " end subroutine shift_time_levels_%s</font>
<font color="black"></font>
<font color="black"></font>
<font color="blue">", group_ptr->name);
+ fortprintf(fd, " end subroutine mpas_shift_time_levels_%s</font>
<font color="black"></font>
<font color="black"></font>
<font color="gray">", group_ptr->name);
}
group_ptr = group_ptr->next;
}
@@ -1362,12 +1362,12 @@
fortprintf(fd, " %s%id %% ioinfo %% fieldName = \'%s\'</font>
<font color="red">", vtype, var_ptr->ndims, var_ptr->name_in_file);
if (var_ptr->timedim)
- fortprintf(fd, " call io_input_field_time(input_obj, %s%id)</font>
<font color="blue">", vtype, var_ptr->ndims);
+ fortprintf(fd, " call mpas_io_input_field_time(input_obj, %s%id)</font>
<font color="red">", vtype, var_ptr->ndims);
else
- fortprintf(fd, " call io_input_field(input_obj, %s%id)</font>
<font color="blue">", vtype, var_ptr->ndims);
+ fortprintf(fd, " call mpas_io_input_field(input_obj, %s%id)</font>
<font color="red">", vtype, var_ptr->ndims);
if (var_ptr->ndims > 0) {
- fortprintf(fd, " call dmpar_alltoall_field(dminfo, &</font>
<font color="blue">");
+ fortprintf(fd, " call mpas_dmpar_alltoall_field(dminfo, &</font>
<font color="black">");
if (strncmp(var_ptr->super_array, "-", 1024) != 0)
fortprintf(fd, " %s%id %% array, super_%s%id, &</font>
<font color="gray">", vtype, var_ptr->ndims, vtype, var_ptr->ndims);
else
@@ -1982,7 +1982,7 @@
}
fortprintf(fd, " %s%id %% ioinfo %% fieldName = \'%s\'</font>
<font color="red">", vtype, var_ptr->ndims, var_ptr->name_in_file);
- fortprintf(fd, " call dmpar_alltoall_field(domain %% dminfo, &</font>
<font color="blue">");
+ fortprintf(fd, " call mpas_dmpar_alltoall_field(domain %% dminfo, &</font>
<font color="black">");
if (strncmp(var_ptr->super_array, "-", 1024) != 0)
fortprintf(fd, " super_%s%id, %s%id %% array, &</font>
<font color="gray">", vtype, var_ptr->ndims, vtype, var_ptr->ndims);
else
@@ -2067,9 +2067,9 @@
}
if (var_ptr->timedim)
- fortprintf(fd, " if (domain %% dminfo %% my_proc_id == IO_NODE) call io_output_field_time(output_obj, %s%id)</font>
<font color="blue">", vtype, var_ptr->ndims);
+ fortprintf(fd, " if (domain %% dminfo %% my_proc_id == IO_NODE) call mpas_io_output_field_time(output_obj, %s%id)</font>
<font color="red">", vtype, var_ptr->ndims);
else
- fortprintf(fd, " if (domain %% dminfo %% my_proc_id == IO_NODE) call io_output_field(output_obj, %s%id)</font>
<font color="blue">", vtype, var_ptr->ndims);
+ fortprintf(fd, " if (domain %% dminfo %% my_proc_id == IO_NODE) call mpas_io_output_field(output_obj, %s%id)</font>
<font color="black">", vtype, var_ptr->ndims);
if (var_ptr->ndims > 0) {
fortprintf(fd, " deallocate(%s%id %% array)</font>
<font color="black">", vtype, var_ptr->ndims);
if (strncmp(var_ptr->super_array, "-", 1024) != 0)
</font>
</pre>