From 477648d2e3c4e9f691d102b7e52d87478992ac1e Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Wed, 11 Jun 2014 11:39:36 -0300 Subject: [PATCH 01/91] INTEGRALS: Utilize 'newunit=' option, to get file unit automatically. This option requires Fortran 2008 compiler. Signed-off-by: Grzegorz Kowal --- src/integrals.F90 | 29 +++++------------------------ 1 file changed, 5 insertions(+), 24 deletions(-) diff --git a/src/integrals.F90 b/src/integrals.F90 index 50752a6..3c9d88f 100644 --- a/src/integrals.F90 +++ b/src/integrals.F90 @@ -93,7 +93,6 @@ module integrals ! import external variables and subroutines ! - use error , only : print_error use mpitools , only : master use parameters , only : get_parameter_integer @@ -109,7 +108,6 @@ module integrals ! local variables ! character(len=32) :: fname - logical :: lex, lop ! !------------------------------------------------------------------------------- ! @@ -136,35 +134,18 @@ module integrals ! if (master) then -! find the first available file handler to use -! - funit = 6 - lex = .false. - lop = .true. - do while(.not. lex .or. lop .and. funit < 100) - funit = funit + 1 - inquire(unit = funit, exist = lex, opened = lop) - end do - -! check if the file handler could be found -! - if (funit >= 100) then - call print_error('integrals::initialize_integrals' & - , 'Could not find any available file handlers!') - iret = 300 - end if - ! generate the integrals file name ! write(fname, "('integrals_',i2.2,'.dat')") irun -! create a new file +! create a new integrals file ! #ifdef INTEL - open (unit = funit, file = fname, form = 'formatted', status = 'replace' & - , buffered = 'yes') + open (newunit = funit, file = fname, form = 'formatted' & + , status = 'replace', buffered = 'yes') #else /* INTEL */ - open (unit = funit, file = fname, form = 'formatted', status = 'replace') + open (newunit = funit, file = fname, form = 'formatted' & + , status = 'replace') #endif /* INTEL */ ! write the integral file header From 1417d45def94fe0331637fc9029be882cc6fd7d5 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Wed, 11 Jun 2014 12:34:32 -0300 Subject: [PATCH 02/91] COORDINATES: Add domain volume and its inversion. Also calculate properly the domain sizes xlen, ylen, and zlen and use them to generate coordinates. Signed-off-by: Grzegorz Kowal --- src/coordinates.F90 | 24 +++++++++++++++++++++--- 1 file changed, 21 insertions(+), 3 deletions(-) diff --git a/src/coordinates.F90 b/src/coordinates.F90 index e12ebdb..e86566e 100644 --- a/src/coordinates.F90 +++ b/src/coordinates.F90 @@ -83,6 +83,11 @@ module coordinates real(kind=8), save :: zmax = 1.0d+00 real(kind=8), save :: zlen = 1.0d+00 +! the domain volume and its inversion +! + real(kind=8), save :: vol = 1.0d+00 + real(kind=8), save :: voli = 1.0d+00 + ! the block coordinates for all levels of refinement ! real(kind=8), dimension(:,:), allocatable, save :: ax , ay , az @@ -239,6 +244,19 @@ module coordinates call get_parameter_real ("zmax" , zmax ) #endif /* NDIMS == 3 */ +! calculate the domain sizes +! + xlen = xmax - xmin + ylen = ymax - ymin +#if NDIMS == 3 + zlen = zmax - zmin +#endif /* NDIMS == 3 */ + +! calculate the domain volume +! + vol = xlen * ylen * zlen + voli = 1.0d+00 / vol + ! allocate space for coordinate variables ! allocate(ax (toplev, im)) @@ -280,10 +298,10 @@ module coordinates ! calculate the cell sizes for each level ! - adx (l) = (xmax - xmin) / (ir * ni) - ady (l) = (ymax - ymin) / (jr * nj) + adx (l) = xlen / (ir * ni) + ady (l) = ylen / (jr * nj) #if NDIMS == 3 - adz (l) = (zmax - zmin) / (kr * nk) + adz (l) = zlen / (kr * nk) #endif /* NDIMS == 3 */ #if NDIMS == 2 adr (l) = sqrt(adx(l)**2 + ady(l)**2) From 288d6f201ebcfb6581322ce68fc848fb05c1e4d8 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Wed, 11 Jun 2014 13:18:02 -0300 Subject: [PATCH 03/91] INTEGRALS: Implement storing variable statistics. Variable statistics, like average, minimum, and maximum values are now stored in a separate file 'statistics_??.dat'. Statistics of density, pressure, velocity, magnetic field, divergence potential and Mach numbers, if they are applicable, are stored. Signed-off-by: Grzegorz Kowal --- src/integrals.F90 | 188 ++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 165 insertions(+), 23 deletions(-) diff --git a/src/integrals.F90 b/src/integrals.F90 index 3c9d88f..2b7f4fc 100644 --- a/src/integrals.F90 +++ b/src/integrals.F90 @@ -50,9 +50,11 @@ module integrals ! ================= ! ! funit - a file handler to the integrals file; +! sunit - a file handler to the statistics file; ! iintd - the number of steps between subsequent intervals storing; ! integer(kind=4), save :: funit = 7 + integer(kind=4), save :: sunit = 8 integer(kind=4), save :: iintd = 1 ! by default everything is private @@ -155,6 +157,32 @@ module integrals , 'ener', 'ekin', 'emag', 'eint' write(funit,"('#')") +! generate the statistics file name +! + write(fname, "('statistics_',i2.2,'.dat')") irun + +! create a new statistics file +! +#ifdef INTEL + open (newunit = sunit, file = fname, form = 'formatted' & + , status = 'replace', buffered = 'yes') +#else /* INTEL */ + open (newunit = sunit, file = fname, form = 'formatted' & + , status = 'replace') +#endif /* INTEL */ + +! write the integral file header +! + write(sunit,"('#',a8,23(1x,a18))") 'step', 'time' & + , 'mean(dens)', 'min(dens)', 'max(dens)' & + , 'mean(pres)', 'min(pres)', 'max(pres)' & + , 'mean(velo)', 'min(velo)', 'max(velo)' & + , 'mean(magn)', 'min(magn)', 'max(magn)' & + , 'mean(bpsi)', 'min(bpsi)', 'max(bpsi)' & + , 'mean(Mson)', 'min(Mson)', 'max(Mson)' & + , 'mean(Malf)', 'min(Malf)', 'max(Malf)' + write(sunit,"('#')") + end if ! master #ifdef PROFILE @@ -195,9 +223,12 @@ module integrals call start_timer(imi) #endif /* PROFILE */ -! close the integrals file +! close the integrals and statistics files ! - if (master) close(funit) + if (master) then + close(funit) + close(sunit) + end if #ifdef PROFILE ! stop accounting time for module initialization/finalization @@ -225,13 +256,17 @@ module integrals ! import external variables and subroutines ! use blocks , only : block_meta, block_data, list_data - use coordinates , only : ib, ie, jb, je, kb, ke - use coordinates , only : advol - use equations , only : idn, imx, imy, imz, ien, ibx, iby, ibz + use coordinates , only : in, jn, kn, ib, jb, kb, ie, je, ke + use coordinates , only : advol, voli + use equations , only : idn, ipr, ivx, ivy, ivz, ibx, iby, ibz, ibp + use equations , only : ien, imx, imy, imz + use equations , only : gamma, csnd use evolution , only : step, time, dt use mpitools , only : master #ifdef MPI use mpitools , only : reduce_sum_real_array + use mpitools , only : reduce_minimum_real_array + use mpitools , only : reduce_maximum_real_array #endif /* MPI */ ! local variables are not implicit by default @@ -253,7 +288,13 @@ module integrals ! local arrays ! - real(kind=8), dimension(narr) :: arr + real(kind=8), dimension(narr) :: inarr, avarr, mnarr, mxarr + real(kind=8), dimension(in,jn,kn) :: vel, mag, sqd, tmp + +! parameters +! + real(kind=8), parameter :: eps = epsilon(1.0d+00) + real(kind=8), parameter :: big = huge(1.0d+00) ! !------------------------------------------------------------------------------- ! @@ -269,7 +310,25 @@ module integrals ! reset the integrals array ! - arr(:) = 0.0d+00 + inarr(:) = 0.0d+00 + avarr(:) = 0.0d+00 + mnarr(:) = big + mxarr(:) = - big + +! reset some statistics if they are not used +! + if (ipr < 1) then + mnarr(2) = 0.0d+00 + mxarr(2) = 0.0d+00 + end if + if (ibx < 1) then + mnarr(4) = 0.0d+00 + mxarr(4) = 0.0d+00 + mnarr(5) = 0.0d+00 + mxarr(5) = 0.0d+00 + mnarr(7) = 0.0d+00 + mxarr(7) = 0.0d+00 + end if ! associate the pointer with the first block on the data block list ! @@ -286,30 +345,93 @@ module integrals ! sum up density and momenta components ! - arr(1) = arr(1) + sum(pdata%u(idn,ib:ie,jb:je,kb:ke)) * dvol - arr(2) = arr(2) + sum(pdata%u(imx,ib:ie,jb:je,kb:ke)) * dvol - arr(3) = arr(3) + sum(pdata%u(imy,ib:ie,jb:je,kb:ke)) * dvol - arr(4) = arr(4) + sum(pdata%u(imz,ib:ie,jb:je,kb:ke)) * dvol + inarr(1) = inarr(1) + sum(pdata%u(idn,ib:ie,jb:je,kb:ke)) * dvol + inarr(2) = inarr(2) + sum(pdata%u(imx,ib:ie,jb:je,kb:ke)) * dvol + inarr(3) = inarr(3) + sum(pdata%u(imy,ib:ie,jb:je,kb:ke)) * dvol + inarr(4) = inarr(4) + sum(pdata%u(imz,ib:ie,jb:je,kb:ke)) * dvol ! sum up total energy ! if (ien > 0) then - arr(5) = arr(5) + sum(pdata%u(ien,ib:ie,jb:je,kb:ke)) * dvol + inarr(5) = inarr(5) + sum(pdata%u(ien,ib:ie,jb:je,kb:ke)) * dvol end if ! sum up kinetic energy ! - arr(6) = arr(6) + sum((pdata%u(imx,ib:ie,jb:je,kb:ke)**2 & - + pdata%u(imy,ib:ie,jb:je,kb:ke)**2 & - + pdata%u(imz,ib:ie,jb:je,kb:ke)**2) & - / pdata%u(idn,ib:ie,jb:je,kb:ke)) * dvolh + inarr(6) = inarr(6) + sum((pdata%u(imx,ib:ie,jb:je,kb:ke)**2 & + + pdata%u(imy,ib:ie,jb:je,kb:ke)**2 & + + pdata%u(imz,ib:ie,jb:je,kb:ke)**2) & + / pdata%u(idn,ib:ie,jb:je,kb:ke)) * dvolh ! sum up magnetic energy ! if (ibx > 0) then - arr(7) = arr(7) + sum(pdata%u(ibx,ib:ie,jb:je,kb:ke)**2 & - + pdata%u(iby,ib:ie,jb:je,kb:ke)**2 & - + pdata%u(ibz,ib:ie,jb:je,kb:ke)**2) * dvolh + inarr(7) = inarr(7) + sum(pdata%u(ibx,ib:ie,jb:je,kb:ke)**2 & + + pdata%u(iby,ib:ie,jb:je,kb:ke)**2 & + + pdata%u(ibz,ib:ie,jb:je,kb:ke)**2) * dvolh + end if + +! get average, minimum and maximum values of density +! + tmp(:,:,:) = pdata%q(idn,ib:ie,jb:je,kb:ke) + avarr(1) = avarr(1) + sum(tmp(:,:,:)) * dvol + mnarr(1) = min(mnarr(1), minval(tmp(:,:,:))) + mxarr(1) = max(mxarr(1), maxval(tmp(:,:,:))) + +! get average, minimum and maximum values of pressure +! + if (ipr > 0) then + tmp(:,:,:) = pdata%q(ipr,ib:ie,jb:je,kb:ke) + avarr(2) = avarr(2) + sum(tmp(:,:,:)) * dvol + mnarr(2) = min(mnarr(2), minval(tmp(:,:,:))) + mxarr(2) = max(mxarr(2), maxval(tmp(:,:,:))) + end if + +! get average, minimum and maximum values of velocity amplitude +! + vel(:,:,:) = sqrt(sum(pdata%q(ivx:ivz,ib:ie,jb:je,kb:ke)**2, 1)) + avarr(3) = avarr(3) + sum(vel(:,:,:)) * dvol + mnarr(3) = min(mnarr(3), minval(vel(:,:,:))) + mxarr(3) = max(mxarr(3), maxval(vel(:,:,:))) + +! get average, minimum and maximum values of magnetic field amplitude, and +! divergence potential +! + if (ibx > 0) then + mag(:,:,:) = sqrt(sum(pdata%q(ibx:ibz,ib:ie,jb:je,kb:ke)**2, 1)) + avarr(4) = avarr(4) + sum(mag(:,:,:)) * dvol + mnarr(4) = min(mnarr(4), minval(mag(:,:,:))) + mxarr(4) = max(mxarr(4), maxval(mag(:,:,:))) + + tmp(:,:,:) = pdata%q(ibp,ib:ie,jb:je,kb:ke) + avarr(5) = avarr(5) + sum(tmp(:,:,:)) * dvol + mnarr(5) = min(mnarr(5), minval(tmp(:,:,:))) + mxarr(5) = max(mxarr(5), maxval(tmp(:,:,:))) + end if + +! calculate square root of density +! + sqd(:,:,:) = sqrt(pdata%q(idn,ib:ie,jb:je,kb:ke)) + +! get average, minimum and maximum values of sonic Mach number +! + if (ipr > 0) then + tmp(:,:,:) = sqd(:,:,:) * vel(:,:,:) & + / sqrt(gamma * pdata%q(ipr,ib:ie,jb:je,kb:ke)) + else + tmp(:,:,:) = vel(:,:,:) / csnd + end if + avarr(6) = avarr(6) + sum(tmp(:,:,:)) * dvol + mnarr(6) = min(mnarr(6), minval(tmp(:,:,:))) + mxarr(6) = max(mxarr(6), maxval(tmp(:,:,:))) + +! get average, minimum and maximum values of Alfvénic Mach number +! + if (ibx > 0) then + tmp(:,:,:) = sqd(:,:,:) * vel(:,:,:) / max(eps, mag(:,:,:)) + avarr(7) = avarr(7) + sum(tmp(:,:,:)) * dvol + mnarr(7) = min(mnarr(7), minval(tmp(:,:,:))) + mxarr(7) = max(mxarr(7), maxval(tmp(:,:,:))) end if ! associate the pointer with the next block on the list @@ -321,16 +443,36 @@ module integrals #ifdef MPI ! sum the integral array from all processes ! - call reduce_sum_real_array(narr, arr(:), iret) + call reduce_sum_real_array(narr, inarr(:), iret) + +! reduce average, minimum and maximum values +! + call reduce_sum_real_array(narr, avarr(:), iret) + call reduce_minimum_real_array(narr, mnarr(:), iret) + call reduce_maximum_real_array(narr, mxarr(:), iret) #endif /* MPI */ ! calculate the internal energy ! - if (ien > 0) arr(8) = arr(5) - arr(6) - arr(7) + if (ien > 0) inarr(8) = inarr(5) - inarr(6) - inarr(7) -! write down the integrals to the integrals file +! normalize the averages by the volume of domain ! - if (master) write(funit,"(i9,10(1x,1e18.8))") step, time, dt, arr(1:8) + avarr(:) = avarr(:) * voli + +! write down the integrals and statistics to appropriate files +! + if (master) then + write(funit,"(i9,10(1x,1e18.8))") step, time, dt, inarr(1:8) + write(sunit,"(i9,23(1x,1e18.8))") step, time & + , avarr(1), mnarr(1), mxarr(1) & + , avarr(2), mnarr(2), mxarr(2) & + , avarr(3), mnarr(3), mxarr(3) & + , avarr(4), mnarr(4), mxarr(4) & + , avarr(5), mnarr(5), mxarr(5) & + , avarr(6), mnarr(6), mxarr(6) & + , avarr(7), mnarr(7), mxarr(7) + end if #ifdef PROFILE ! stop accounting time for the integrals storing From 9d53305eb66020da5c1851d197bc35831dd11574 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Wed, 11 Jun 2014 18:48:06 -0300 Subject: [PATCH 04/91] PROBLEMS: Improve the edge interpolation in the blast problem. Signed-off-by: Grzegorz Kowal --- src/problems.F90 | 102 +++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 86 insertions(+), 16 deletions(-) diff --git a/src/problems.F90 b/src/problems.F90 index 1982aa2..0211fc3 100644 --- a/src/problems.F90 +++ b/src/problems.F90 @@ -264,7 +264,11 @@ module problems ! integer :: i, j, k real(kind=8) :: xl, yl, zl, xu, yu, zu, rl, ru - real(kind=8) :: xb, yb, xt, yt +#if NDIMS == 3 +#else /* NDIMS == 3 */ + real(kind=8) :: rlu, rul, xb, yb, xt, yt + real(kind=8) :: sn, ph +#endif /* NDIMS == 3 */ real(kind=8) :: dx, dy, dz, dxh, dyh, dzh, daxy real(kind=8) :: fc_amb, fc_ovr @@ -447,26 +451,92 @@ module problems ! if (ipr > 0) q(ipr,i) = pr_amb #else /* NDIMS == 3 */ -! calculate the bounds of area integration + +! calculate the distance of remaining corners ! - xb = max(xl, sqrt(max(0.0d+00, r2 - yu * yu))) - xt = min(xu, sqrt(max(0.0d+00, r2 - yl * yl))) - yb = max(yl, sqrt(max(0.0d+00, r2 - xu * xu))) - yt = min(yu, sqrt(max(0.0d+00, r2 - xl * xl))) + rlu = xl * xl + yu * yu + rul = xu * xu + yl * yl -! integrate the area below the circle within the current cell for both -! functions, y = f(x) and x = g(y), and then average them to be sure that we -! are getting the ideal symmetry +! separate in the cases of which corners lay inside, and which outside +! the radius ! - fc_ovr = 0.5d+00 * (r2 * (asin(xt / radius) - asin(xb / radius)) & - + (xt * yb - xb * yt)) - yl * (xt - xb) - fc_ovr = fc_ovr + (xb - xl) * dy + if (min(rlu, rul) >= r2) then - fc_amb = 0.5d+00 * (r2 * (asin(yt / radius) - asin(yb / radius)) & - + (yt * xb - yb * xt)) - xl * (yt - yb) - fc_amb = fc_amb + (yb - yl) * dx +! only one cell corner inside the radius +! +! calculate middle coordinates of the radius-edge crossing point +! + xb = sqrt(r2 - yl**2) - xl + yb = sqrt(r2 - xl**2) - yl - fc_ovr = 0.5d+00 * (fc_ovr + fc_amb) +! calculate the sin(½φ), φ, and sin(φ) +! + sn = 0.5d+00 * sqrt(xb**2 + yb**2) / radius + ph = 2.0d+00 * asin(sn) + sn = sin(ph) + +! calculate the area of cell intersection with the radius +! + fc_ovr = 0.5d+00 * (xb * yb + (ph - sn) * r2) + + else if (rlu >= r2) then + +! two lower corners inside the radius +! +! calculate middle coordinates of the radius-edge crossing point +! + yb = sqrt(r2 - xl**2) - yl + yt = sqrt(r2 - xu**2) - yl + +! calculate the sin(½φ), φ, and sin(φ) +! + sn = 0.5d+00 * sqrt(dx**2 + (yt - yb)**2) / radius + ph = 2.0d+00 * asin(sn) + sn = sin(ph) + +! calculate the area of cell intersection with the radius +! + fc_ovr = 0.5d+00 * ((yt + yb) * dx + (ph - sn) * r2) + + else if (rul >= r2) then + +! two left corners inside the radius +! +! calculate middle coordinates of the radius-edge crossing point +! + xb = sqrt(r2 - yl**2) - xl + xt = sqrt(r2 - yu**2) - xl + +! calculate the sin(½φ), φ, and sin(φ) +! + sn = 0.5d+00 * sqrt((xt - xb)**2 + dy**2) / radius + ph = 2.0d+00 * asin(sn) + sn = sin(ph) + +! calculate the area of cell intersection with the radius +! + fc_ovr = 0.5d+00 * ((xt + xb) * dy + (ph - sn) * r2) + + else + +! three corners inside the radius +! +! calculate middle coordinates of the radius-edge crossing point +! + xt = xu - sqrt(r2 - yu**2) + yt = yu - sqrt(r2 - xu**2) + +! calculate the sin(½φ), φ, and sin(φ) +! + sn = 0.5d+00 * sqrt(xt**2 + yt**2) / radius + ph = 2.0d+00 * asin(sn) + sn = sin(ph) + +! calculate the area of cell intersection with the radius +! + fc_ovr = daxy - 0.5d+00 * (xt * yt - (ph - sn) * r2) + + end if ! normalize coefficients ! From f328991398c87a08aa48c597c14b21255b0c2321 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Wed, 11 Jun 2014 22:08:18 -0300 Subject: [PATCH 05/91] DOMAINS: Replace (xmax - xmin) with xlen, etc.. Signed-off-by: Grzegorz Kowal --- src/domains.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/domains.F90 b/src/domains.F90 index 8c3eda3..1cb5bb6 100644 --- a/src/domains.F90 +++ b/src/domains.F90 @@ -144,7 +144,7 @@ module domains use blocks , only : metablock_set_coordinates, metablock_set_bounds use blocks , only : nsides, nfaces use boundaries , only : bnd_type, bnd_periodic - use coordinates , only : xmin, xmax, ymin, ymax, zmin, zmax + use coordinates , only : xmin, ymin, zmin, xlen, ylen, zlen use coordinates , only : ir, jr, kr ! local variables are not implicit by default @@ -257,9 +257,9 @@ module domains !! ! calculate block sizes ! - xl = (xmax - xmin) / ir - yl = (ymax - ymin) / jr - zl = (zmax - zmin) / kr + xl = xlen / ir + yl = ylen / jr + zl = zlen / kr ! fill out block structure fields ! From 847687b045df286c1dc515c8eedc423d234df2a2 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Wed, 11 Jun 2014 22:45:35 -0300 Subject: [PATCH 06/91] PROBLEMS: Fix parameters in blast problem setup file. Signed-off-by: Grzegorz Kowal --- problems/blast.in | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/problems/blast.in b/problems/blast.in index 6047626..2a692cf 100644 --- a/problems/blast.in +++ b/problems/blast.in @@ -1,13 +1,13 @@ # problem name and parameters # problem = "blast" -dens = 1.00d+00 -ratio = 1.00d+02 -radius = 1.00d-01 -csnd = 4.08d-01 -gamma = 1.67d-01 -buni = 0.00d+00 -angle = 0.00d+00 +dens = 1.0000d+00 +ratio = 1.0000d+02 +radius = 1.0000d-01 +buni = 0.0000d+00 +angle = 4.5000d+01 +csnd = 4.0825d-01 +gamma = 1.6667d+00 # physics # @@ -28,19 +28,19 @@ clip_extrema = "off" rdimx = 2 rdimy = 3 rdimz = 1 -xmin = -0.5 -xmax = 0.5 -ymin = -0.75 -ymax = 0.75 -zmin = -0.5 -zmax = 0.5 +xmin = -5.00d-01 +xmax = 5.00d-01 +ymin = -7.50d-01 +ymax = 7.50d-01 +zmin = -5.00d-01 +zmax = 5.00d-01 # refinement control # ncells = 8 nghost = 2 minlev = 1 -maxlev = 7 +maxlev = 6 crefmin = 2.00d-01 crefmax = 8.00d-01 epsref = 1.00d-02 From 9695af7a643390c23337533cdbc2afdf3960270f Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Wed, 11 Jun 2014 22:52:11 -0300 Subject: [PATCH 07/91] PROBLEMS: Fix parameters in implosion setup file. Signed-off-by: Grzegorz Kowal --- problems/implosion.in | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/problems/implosion.in b/problems/implosion.in index c8fec38..b920f4f 100644 --- a/problems/implosion.in +++ b/problems/implosion.in @@ -23,31 +23,31 @@ ncells = 8 nghosts = 2 rdimx = 1 rdimy = 1 -xmin = -1.00d+00 +xmin = 0.00d+00 xmax = 1.00d+00 -ymin = -1.00d+00 +ymin = 0.00d+00 ymax = 1.00d+00 # refinement control # -maxlev = 8 +maxlev = 7 # boundary conditions # -#xlbndry = "reflecting" -#xubndry = "reflecting" -#ylbndry = "reflecting" -#yubndry = "reflecting" +xlbndry = "reflecting" +xubndry = "reflecting" +ylbndry = "reflecting" +yubndry = "reflecting" # runtime control parameters # -tmax = 1.00d+00 +tmax = 4.00d+00 cfl = 4.00d-01 # data output control # precise_snapshots = "on" snapshot_type = "p" -snapshot_interval = 1.0d-02 +snapshot_interval = 1.0d-01 restart_number = -1 -integrals_interval = 1 +integrals_interval = 10 From 7500981dbe519b7ae37a9b7d4eb6f1037ed601c7 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Wed, 11 Jun 2014 23:06:28 -0300 Subject: [PATCH 08/91] DRIVER: Update boundaries just after problem initialization. Otherwise we can get some kind of mass leaking problem, like in the case of Kelvin-Helmholtz test. Signed-off-by: Grzegorz Kowal --- src/driver.F90 | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/driver.F90 b/src/driver.F90 index d735eee..1fbcb00 100644 --- a/src/driver.F90 +++ b/src/driver.F90 @@ -36,6 +36,7 @@ program amun ! use blocks , only : initialize_blocks, finalize_blocks, get_nleafs use boundaries , only : initialize_boundaries, finalize_boundaries + use boundaries , only : boundary_variables use coordinates , only : initialize_coordinates, finalize_coordinates use equations , only : initialize_equations, finalize_equations use evolution , only : initialize_evolution, finalize_evolution @@ -442,6 +443,10 @@ program amun ! call generate_mesh() +! update boundaries +! + call boundary_variables() + ! calculate new timestep ! call new_time_step(dtnext) From a375cb12c58b1f8c23e27c1fca918657d1dbe4b5 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Wed, 11 Jun 2014 23:08:47 -0300 Subject: [PATCH 09/91] PROBLEMS: Fix parameters in the Kelvin-Helmholtz setup file. Signed-off-by: Grzegorz Kowal --- problems/kh.in | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/problems/kh.in b/problems/kh.in index e31efee..8d16acb 100644 --- a/problems/kh.in +++ b/problems/kh.in @@ -14,16 +14,13 @@ equation_of_state = "adi" # methods # time_advance = "rk2" -riemann_solver = "hllc" +riemann_solver = "hlld" reconstruction = "limo3" limiter = "mc" fix_positivity = "off" # mesh parameters # -rdimx = 1 -rdimy = 1 -rdimz = 1 xmin = -5.0d-01 xmax = 5.0d-01 ymin = -5.0d-01 @@ -49,7 +46,6 @@ zubndry = "periodic" # runtime control parameters # -nmax = 1000000 tmax = 1.0d+00 cfl = 4.0d-01 From 3f34888b6a6261910b90af18772645d781186d16 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Sat, 21 Jun 2014 19:59:15 -0300 Subject: [PATCH 10/91] PROBLEM: Improve integration at surface in 3D blast problem. Signed-off-by: Grzegorz Kowal --- src/problems.F90 | 113 ++++++++++++++++++++++++++++++++++++++--------- 1 file changed, 92 insertions(+), 21 deletions(-) diff --git a/src/problems.F90 b/src/problems.F90 index 0211fc3..fa38422 100644 --- a/src/problems.F90 +++ b/src/problems.F90 @@ -229,12 +229,12 @@ module problems use blocks , only : block_data use constants , only : d2r use coordinates, only : im, jm, km - use coordinates, only : ax, ay, az, adx, ady, adz + use coordinates, only : ax, ay, az, adx, ady, adz, advol use equations , only : prim2cons use equations , only : gamma use equations , only : nv use equations , only : idn, ivx, ivy, ivz, ipr, ibx, iby, ibz, ibp - use parameters , only : get_parameter_real + use parameters , only : get_parameter_real, get_parameter_integer ! local variables are not implicit by default ! @@ -246,12 +246,15 @@ module problems ! default parameter values ! - real(kind=8), save :: dens = 1.00d+00 - real(kind=8), save :: ratio = 1.00d+02 - real(kind=8), save :: radius = 1.00d-01 - real(kind=8), save :: csnd = 4.0824829046386301635d-01 - real(kind=8), save :: buni = 1.00d+00 - real(kind=8), save :: angle = 4.50d+01 + real(kind=8), save :: dens = 1.00d+00 + real(kind=8), save :: ratio = 1.00d+02 + real(kind=8), save :: radius = 1.00d-01 + real(kind=8), save :: csnd = 4.0824829046386301635d-01 + real(kind=8), save :: buni = 1.00d+00 + real(kind=8), save :: angle = 4.50d+01 +#if NDIMS == 3 + integer , save :: nsubgrid = 10 +#endif /* NDIMS == 3 */ ! local saved parameters ! @@ -262,14 +265,18 @@ module problems ! local variables ! - integer :: i, j, k + integer :: i, j, k, ic, jc, kc real(kind=8) :: xl, yl, zl, xu, yu, zu, rl, ru #if NDIMS == 3 + real(kind=8) :: xb, yb, zb + real(kind=8) :: xt, yt, zt + real(kind=8) :: fc_inc #else /* NDIMS == 3 */ - real(kind=8) :: rlu, rul, xb, yb, xt, yt + real(kind=8) :: xb, yb + real(kind=8) :: xt, yt real(kind=8) :: sn, ph #endif /* NDIMS == 3 */ - real(kind=8) :: dx, dy, dz, dxh, dyh, dzh, daxy + real(kind=8) :: dx, dy, dz, dxh, dyh, dzh, dvol real(kind=8) :: fc_amb, fc_ovr ! local arrays @@ -278,6 +285,13 @@ module problems real(kind=8), dimension(im) :: x real(kind=8), dimension(jm) :: y real(kind=8), dimension(km) :: z + +#if NDIMS == 3 +! allocatable arrays +! + real(kind=8), dimension(:), allocatable :: xm, ym, zm + real(kind=8), dimension(:), allocatable :: xp, yp, zp +#endif /* NDIMS == 3 */ ! !------------------------------------------------------------------------------- ! @@ -300,6 +314,16 @@ module problems call get_parameter_real("buni" , buni ) call get_parameter_real("angle" , angle ) +#if NDIMS == 3 +! get the fine grid resolution +! + call get_parameter_integer("nsubgrid", nsubgrid) + +! correct subgrid resolution if necessary +! + nsubgrid = max(1, nsubgrid) +#endif /* NDIMS == 3 */ + ! calculate the overdense and ambient region densities ! dn_amb = dens @@ -347,7 +371,33 @@ module problems #else /* NDIMS == 3 */ dzh = 1.0d+00 #endif /* NDIMS == 3 */ - daxy = dx * dy + dvol = advol(pdata%meta%level) + +#if NDIMS == 3 +! allocate subgrid coordinates +! + allocate(xm(nsubgrid), ym(nsubgrid), zm(nsubgrid)) + allocate(xp(nsubgrid), yp(nsubgrid), zp(nsubgrid)) + +! and generate them +! + xm(:) = (1.0d+00 * (/(i, i = 0, nsubgrid - 1)/)) / nsubgrid + ym(:) = xm(:) + zm(:) = xm(:) + xm(:) = xm(:) * dx + ym(:) = ym(:) * dy + zm(:) = zm(:) * dz + xp(:) = (1.0d+00 * (/(i, i = 1, nsubgrid )/)) / nsubgrid + yp(:) = xp(:) + zp(:) = xp(:) + xp(:) = xp(:) * dx + yp(:) = yp(:) * dy + zp(:) = zp(:) * dz + +! calculate the factor increment for the given subgrid +! + fc_inc = dvol / nsubgrid**3 +#endif /* NDIMS == 3 */ ! set the ambient density and pressure ! @@ -440,16 +490,30 @@ module problems else #if NDIMS == 3 -! in 3D simply set the ambient values since the integration is more complex +! interpolate the factor using subgrid ! + fc_ovr = 0.0d+00 + do kc = 1, nsubgrid + zb = (zl + zm(kc))**2 + zt = (zl + zp(kc))**2 + do jc = 1, nsubgrid + yb = (yl + ym(jc))**2 + yt = (yl + yp(jc))**2 + do ic = 1, nsubgrid + xb = (xl + xm(ic))**2 + xt = (xl + xp(ic))**2 -! set the ambient region density +! update the integration factor depending on the subcell position ! - q(idn,i) = dn_amb + if ((xt + yt + zt) <= r2) then + fc_ovr = fc_ovr + fc_inc + else if ((xb + yb + zb) < r2) then + fc_ovr = fc_ovr + 0.5d+00 * fc_inc + end if -! set the ambient medium pressure -! - if (ipr > 0) q(ipr,i) = pr_amb + end do ! ic = 1, nsubgrid + end do ! jc = 1, nsubgrid + end do ! kc = 1, nsubgrid #else /* NDIMS == 3 */ ! calculate the distance of remaining corners @@ -534,13 +598,14 @@ module problems ! calculate the area of cell intersection with the radius ! - fc_ovr = daxy - 0.5d+00 * (xt * yt - (ph - sn) * r2) + fc_ovr = dvol - 0.5d+00 * (xt * yt - (ph - sn) * r2) end if +#endif /* NDIMS == 3 */ ! normalize coefficients ! - fc_ovr = fc_ovr / daxy + fc_ovr = fc_ovr / dvol fc_amb = 1.0d+00 - fc_ovr ! integrate the density over the edge cells @@ -550,7 +615,6 @@ module problems ! integrate the pressure over the edge cells ! if (ipr > 0) q(ipr,i) = fc_ovr * pr_ovr + fc_amb * pr_amb -#endif /* NDIMS == 3 */ end if @@ -571,6 +635,13 @@ module problems end do ! j = 1, jm end do ! k = 1, km +#if NDIMS == 3 +! deallocate subgrid coordinates +! + deallocate(xm, ym, zm) + deallocate(xp, yp, zp) +#endif /* NDIMS == 3 */ + #ifdef PROFILE ! stop accounting time for the problems setup ! From ee9f32d7ddddf4107998e4ad65f3372960f2a1c5 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Mon, 23 Jun 2014 09:49:13 -0300 Subject: [PATCH 11/91] PROBLEMS: Fix compilation after last commit. Signed-off-by: Grzegorz Kowal --- src/problems.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/problems.F90 b/src/problems.F90 index fa38422..342501a 100644 --- a/src/problems.F90 +++ b/src/problems.F90 @@ -272,6 +272,7 @@ module problems real(kind=8) :: xt, yt, zt real(kind=8) :: fc_inc #else /* NDIMS == 3 */ + real(kind=8) :: rlu, rul real(kind=8) :: xb, yb real(kind=8) :: xt, yt real(kind=8) :: sn, ph From b12335528ac50fbf20ca93f2b5af414c12ba55d1 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Mon, 23 Jun 2014 10:10:29 -0300 Subject: [PATCH 12/91] MESH: Move part of update_mesh() to check_data_block_refinement(). The first part of update_mesh(), where we check and update the refinement flags, has been moved to a new private subroutine check_data_block_refinement(). Signed-off-by: Grzegorz Kowal --- src/mesh.F90 | 373 +++++++++++++++++++++++++++++++++------------------ 1 file changed, 243 insertions(+), 130 deletions(-) diff --git a/src/mesh.F90 b/src/mesh.F90 index baa8ac2..f16bbb5 100644 --- a/src/mesh.F90 +++ b/src/mesh.F90 @@ -831,137 +831,9 @@ module mesh call start_timer(imu) #endif /* PROFILE */ -!! DETERMINE THE REFINEMENT OF ALL DATA BLOCKS -!! -! set the pointer to the first block on the data block list +! check the refinement criterion of all data blocks at the current process ! - pdata => list_data - -! iterate over all blocks in the data block list -! - do while (associated(pdata)) - -! assign a pointer to the meta block associated with the current data block -! - pmeta => pdata%meta - -! continue if the current data block has a meta block associated -! - if (associated(pmeta)) then - -! if the associated meta block is a leaf -! - if (pmeta%leaf) then - -! check the refinement criterion for the current data block -! - pmeta%refine = check_refinement_criterion(pdata) - -! correct the refinement of the block for the base and top levels -! - if (pmeta%level < minlev) pmeta%refine = 1 - if (pmeta%level == minlev) pmeta%refine = max(0, pmeta%refine) - if (pmeta%level == maxlev) pmeta%refine = min(0, pmeta%refine) - if (pmeta%level > maxlev) pmeta%refine = -1 - - end if ! pmeta is a leaf - - end if ! pmeta associated - -! assign a pointer to the next data block -! - pdata => pdata%next - - end do ! pdata - -#ifdef MPI -!! EXCHANGE REFINEMENT FLAGS BETWEEN ALL PROCESSES -!! -! get the number of leafs -! - nl = get_nleafs() - -! allocate a buffer for the refinement field values -! - allocate(ibuf(nl)) - -! reset the buffer -! - ibuf(:) = 0 - -! reset the leaf block counter -! - l = 0 - -! set the pointer to the first block on the meta block list -! - pmeta => list_meta - -! iterate over all meta blocks -! - do while (associated(pmeta)) - -! process only leafs -! - if (pmeta%leaf) then - -! increase the leaf block counter -! - l = l + 1 - -! store the refinement flag for all blocks at the current process for -! exchange with other processors -! - ibuf(l) = pmeta%refine - - end if ! pmeta is the leaf - -! assign a pointer to the next meta block -! - pmeta => pmeta%next - - end do ! pmeta - -! update refinement flags across all processors -! - call reduce_sum_integer_array(nl, ibuf(1:nl), iret) - -! reset the leaf block counter -! - l = 0 - -! set the pointer to the first block on the meta block list -! - pmeta => list_meta - -! iterate over all meta blocks -! - do while (associated(pmeta)) - -! process only leafs -! - if (pmeta%leaf) then - -! increase the leaf block counter -! - l = l + 1 - -! update non-local block refinement flags -! - pmeta%refine = ibuf(l) - - end if ! pmeta is the leaf - -! assign a pointer to the next meta block -! - pmeta => pmeta%next - - end do ! pmeta - -! deallocate the buffer -! - if (allocated(ibuf)) deallocate(ibuf) -#endif /* MPI */ + call check_data_block_refinement() !! SELECT NEIGHBORS OF REFINED BLOCKS TO BE REFINED IF NECESSARY !! @@ -1826,6 +1698,247 @@ module mesh !------------------------------------------------------------------------------- ! end subroutine restrict_block +! +!=============================================================================== +!! +!!*** PRIVATE SUBROUTINES **************************************************** +!! +!=============================================================================== +! +!=============================================================================== +! +! subroutine CHECK_DATA_BLOCK_REFINEMENT: +! -------------------------------------- +! +! Subroutine scans over all data blocks, gets and corrects their refinement +! flags. If the MPI is used, the refinement flags are syncronized among all +! processes. +! +! +!=============================================================================== +! + subroutine check_data_block_refinement() + +! import external procedures and variables +! + use blocks , only : block_meta, block_data, list_meta, list_data +#ifdef MPI + use blocks , only : get_nleafs +#endif /* MPI */ + use coordinates , only : minlev, maxlev + use error , only : print_error +#ifdef MPI +#ifdef DEBUG + use mpitools , only : nproc +#endif /* DEBUG */ + use mpitools , only : reduce_sum_integer_array +#endif /* MPI */ + use refinement , only : check_refinement_criterion + +! local variables are not implicit by default +! + implicit none + +! local pointers +! + type(block_meta), pointer :: pmeta + type(block_data), pointer :: pdata + +#ifdef MPI +! local variables +! + integer(kind=4) :: nl, l + integer :: iret + +! array for storing the refinement flags +! + integer(kind=4), dimension(:), allocatable :: ibuf +#endif /* MPI */ + +!------------------------------------------------------------------------------- +! +! 1) reset the refinement flag for all meta blocks +! +! assign pmeta to the first meta block on the list +! + pmeta => list_meta + +! iterate over all meta blocks +! + do while (associated(pmeta)) + +! reset the refinement flag of pmeta +! + pmeta%refine = 0 + +! assign pmeta to the next meta block +! + pmeta => pmeta%next + + end do ! iterate over meta blocks + +! 2) determine the refinement of data block from the current process +! +! assign pdata to the first data block on the list +! + pdata => list_data + +! iterate over all data blocks +! + do while (associated(pdata)) + +! assign pmeta to the meta block associated with pdata +! + pmeta => pdata%meta + +#ifdef DEBUG +! check if pmeta is associated +! + if (associated(pmeta)) then + +! check if pmeta is a leaf +! + if (pmeta%leaf) then +#endif /* DEBUG */ + +! check the refinement criterion for the current data block +! + pmeta%refine = check_refinement_criterion(pdata) + +! correct the refinement flag for the minimum and maximum levels +! + if (pmeta%level < minlev) pmeta%refine = 1 + if (pmeta%level == minlev) pmeta%refine = max(0, pmeta%refine) + if (pmeta%level == maxlev) pmeta%refine = min(0, pmeta%refine) + if (pmeta%level > maxlev) pmeta%refine = -1 + +#ifdef DEBUG + else ! pmeta is a leaf + call print_error("mesh::check_data_block_refinement" & + , "Associated meta block is not a leaf!") + end if ! pmeta is a leaf + + else ! pmeta associated + call print_error("mesh::check_data_block_refinement" & + , "No meta block associated with the current data block!") + end if ! pmeta associated +#endif /* DEBUG */ + +! assign pdata to the next data block +! + pdata => pdata%next + + end do ! iterate over data blocks + +#ifdef MPI +! 3) synchronize the refinement flags between all processes +! +! get the number of leafs +! + nl = get_nleafs() + +! allocate a buffer for the refinement flags +! + allocate(ibuf(nl)) + +! check if the buffer was allocated successfully +! + if (allocated(ibuf)) then + +! reset the buffer +! + ibuf(1:nl) = 0 + +! reset the leaf block counter +! + l = 0 + +! assign pmeta to the first meta block on the list +! + pmeta => list_meta + +! iterate over all meta blocks +! + do while (associated(pmeta)) + +! process only leafs +! + if (pmeta%leaf) then + +! increase the leaf block counter +! + l = l + 1 + +! store the refinement flag in the buffer +! + ibuf(l) = pmeta%refine + + end if ! pmeta is a leaf + +! assign pmeta to the next meta block +! + pmeta => pmeta%next + + end do ! iterate over meta blocks + +! update refinement flags across all processes +! + call reduce_sum_integer_array(nl, ibuf(1:nl), iret) + +! reset the leaf block counter +! + l = 0 + +! assign pmeta to the first meta block on the list +! + pmeta => list_meta + +! iterate over all meta blocks +! + do while (associated(pmeta)) + +! process only leafs +! + if (pmeta%leaf) then + +! increase the leaf block counter +! + l = l + 1 + +#ifdef DEBUG +! check if the MPI update process does not change the local refinement flags +! + if (pmeta%process == nproc .and. pmeta%refine /= ibuf(l)) then + call print_error("mesh::check_data_block_refinement" & + , "Refinement flag does not match after MPI reduction!") + end if +#endif /* DEBUG */ + +! restore the refinement flags +! + pmeta%refine = ibuf(l) + + end if ! pmeta is a leaf + +! assign pmeta to the next meta block +! + pmeta => pmeta%next + + end do ! iterate over meta blocks + +! deallocate the refinement flag buffer +! + deallocate(ibuf) + + else ! buffer couldn't be allocated + call print_error("mesh::check_data_block_refinement" & + , "Refinement flag buffer could not be allocated!") + end if ! buffer couldn't be allocated +#endif /* MPI */ + +!------------------------------------------------------------------------------- +! + end subroutine check_data_block_refinement !=============================================================================== ! From 83c1a5da1e0f466ada2d9203da0f02dff0fb7f22 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Mon, 23 Jun 2014 10:33:10 -0300 Subject: [PATCH 13/91] MESH: Move the second part of update_mesh() to update_neighbor_refinement(). The second part of update_mesh(), in which we update neighbor refinement flags, has been moved to a new subroutine update_neighbor_refinement(). Signed-off-by: Grzegorz Kowal --- src/mesh.F90 | 100 +++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 73 insertions(+), 27 deletions(-) diff --git a/src/mesh.F90 b/src/mesh.F90 index f16bbb5..b4bc2a4 100644 --- a/src/mesh.F90 +++ b/src/mesh.F90 @@ -835,39 +835,17 @@ module mesh ! call check_data_block_refinement() -!! SELECT NEIGHBORS OF REFINED BLOCKS TO BE REFINED IF NECESSARY +! update neighbor refinement flags, if they need to be refined as well +! + call update_neighbor_refinement() + +!! CHECK IF BLOCK CHILDREN CAN BE DEREFINED !! ! iterate over all levels starting from top and correct the refinement ! of neighbor blocks ! do l = toplev, 1, -1 -! set the pointer to the first block on the meta block list -! - pmeta => list_meta - -! iterate over all meta blocks -! - do while (associated(pmeta)) - -! check only leafs at the current level -! - if (pmeta%leaf .and. pmeta%level == l) then - -! select all neighbors which lay on lower levels to be refined as well -! - call set_neighbors_refine(pmeta) - - end if ! the leaf at level l - -! assign a pointer to the next block -! - pmeta => pmeta%next - - end do ! meta blocks - -!! CHECK IF BLOCK CHILDREN CAN BE DEREFINED -!! ! now check all derefined block if their siblings are set for derefinement too ! and are at the same level; check only levels > 1 ! @@ -1939,6 +1917,74 @@ module mesh !------------------------------------------------------------------------------- ! end subroutine check_data_block_refinement +! +!=============================================================================== +! +! subroutine UPDATE_NEIGHBOR_REFINEMENT: +! ------------------------------------- +! +! Subroutine scans over all neighbors of blocks selected for refinement or +! derefinement, and if necessary selects them to be refined as well, or +! cancels their derefinement. +! +! +!=============================================================================== +! + subroutine update_neighbor_refinement() + +! import external procedures and variables +! + use blocks , only : block_meta, list_meta + use blocks , only : set_neighbors_refine + use coordinates , only : toplev + +! local variables are not implicit by default +! + implicit none + +! local pointers +! + type(block_meta), pointer :: pmeta + +! local variables +! + integer(kind=4) :: l + +!------------------------------------------------------------------------------- +! +! iterate down over all levels and correct the refinement of neighbor blocks +! + do l = toplev, 1, -1 + +! assign pmeta to the first meta block on the list +! + pmeta => list_meta + +! iterate over all meta blocks +! + do while (associated(pmeta)) + +! check only leafs at the current level +! + if (pmeta%leaf .and. pmeta%level == l) then + +! correct neighbor refinement flags +! + call set_neighbors_refine(pmeta) + + end if ! the leaf at level l + +! assign pmeta to the next meta block +! + pmeta => pmeta%next + + end do ! iterate over meta blocks + + end do ! levels + +!------------------------------------------------------------------------------- +! + end subroutine update_neighbor_refinement !=============================================================================== ! From fe60e70e57614a7bb7d2fc641c7ad3059e3d4b7b Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Mon, 23 Jun 2014 13:03:24 -0300 Subject: [PATCH 14/91] MESH: Move child processing from update_mesh() to prepare_sibling_derefinement(). After checking refinement flags and process neighbors, we need to check if all siblings of blocks which were selected for derefinement, are eligible for derefinement too, i.e. lay at the same level, and are also selected for derefinement. After this step, we bring all siblings to the same processor, so the derefinement can be done efficiently. In this commit, the above step is moved from update_mesh() to prepare_sibling_derefinement(). Signed-off-by: Grzegorz Kowal --- src/mesh.F90 | 505 +++++++++++++++++++++++++++++++-------------------- 1 file changed, 306 insertions(+), 199 deletions(-) diff --git a/src/mesh.F90 b/src/mesh.F90 index b4bc2a4..a528e36 100644 --- a/src/mesh.F90 +++ b/src/mesh.F90 @@ -839,206 +839,10 @@ module mesh ! call update_neighbor_refinement() -!! CHECK IF BLOCK CHILDREN CAN BE DEREFINED -!! -! iterate over all levels starting from top and correct the refinement -! of neighbor blocks +! check if all siblings of blocks marked to be derefined can be derefined as +! well, if not cancel their deferinement flags ! - do l = toplev, 1, -1 - -! now check all derefined block if their siblings are set for derefinement too -! and are at the same level; check only levels > 1 -! - if (l > 1) then - -! set the pointer to the first block on the meta block list -! - pmeta => list_meta - -! iterate over all blocks -! - do while (associated(pmeta)) - -! check only leafs at the current level -! - if (pmeta%leaf .and. pmeta%level == l) then - -! check blocks which are selected to be derefined -! - if (pmeta%refine == -1) then - -! assign a pointer to the parent of the current block -! - pparent => pmeta%parent - -! check if parent is associated with any block -! - if (associated(pparent)) then - -! reset derefinement flag -! - flag = .true. - -! iterate over all children -! - do p = 1, nchildren - -! assign a pointer to the current child -! - pchild => pparent%child(p)%ptr - -! check if the current child is the leaf -! - flag = flag .and. (pchild%leaf) - -! check if the current child is set to be derefined -! - flag = flag .and. (pchild%refine == -1) - - end do ! over all children - -! if not all children can be derefined, cancel the derefinement -! - if (.not. flag) then - -! iterate over all children -! - do p = 1, nchildren - -! assign a pointer to the current child -! - pchild => pparent%child(p)%ptr - -! reset derefinement of the current child -! - pchild%refine = max(0, pchild%refine) - - end do ! children - - end if ! ~flag - - end if ! pparent is associated - - end if ! refine = -1 - - end if ! leafs at level l - -! assign a pointer to the next block -! - pmeta => pmeta%next - - end do ! meta blocks - - end if ! l > 1 - - end do ! levels - -#ifdef MPI -!! BRING BACK ALL CHILDREN SELECTED FOR DEREFINEMENT TO THE SAME PROCESS -!! -! set the pointer to the first block on the meta block list -! - pmeta => list_meta - -! iterate over all meta blocks -! - do while (associated(pmeta)) - -! process only parent blocks (not leafs) -! - if (.not. pmeta%leaf) then - -! check if the first child is selected for derefinement -! - if (pmeta%child(1)%ptr%refine == -1) then - -! check if the parent blocks is on the same processor as the next block, if not -! move it to the same processor -! - if (pmeta%process /= pmeta%next%process) & - pmeta%process = pmeta%next%process - -! find the case when child blocks are spread across at least 2 processors -! - flag = .false. - do p = 1, nchildren - flag = flag .or. (pmeta%child(p)%ptr%process /= pmeta%process) - end do - - if (flag) then - -! iterate over all children -! - do p = 1, nchildren - -! generate the tag for communication -! - itag = pmeta%child(p)%ptr%process * nprocs + pmeta%process & - + nprocs + p + 1 - -! if the current children is not on the same processor, then ... -! - if (pmeta%child(p)%ptr%process /= pmeta%process) then - -! if the meta block is on the same process -! - if (pmeta%process == nproc) then - -! allocate data blocks for children on the processor which will receive data -! - call append_datablock(pdata) - call link_blocks(pmeta%child(p)%ptr, pdata) - -! receive the data -! - call receive_real_array(size(rbuf) & - , pmeta%child(p)%ptr%process, itag, rbuf, iret) - -! coppy buffer to data -! - pmeta%child(p)%ptr%data%u(:,:,:,:) = rbuf(:,:,:,:) - - end if - -! send data to the right processor and deallocate data block -! - if (pmeta%child(p)%ptr%process == nproc) then - -! copy data to buffer -! - rbuf(:,:,:,:) = pmeta%child(p)%ptr%data%u(:,:,:,:) - -! send data -! - call send_real_array(size(rbuf), pmeta%process & - , itag, rbuf, iret) - -! deallocate data block -! - call remove_datablock(pmeta%child(p)%ptr%data) - - end if - -! set the current processor of the block -! - pmeta%child(p)%ptr%process = pmeta%process - - end if ! if child is are on different processes - - end do ! nchildren - - end if ! children spread over different processes - - end if ! children selected for derefinement - - end if ! the block is parent - -! assign a pointer to the next block -! - pmeta => pmeta%next - - end do ! over meta blocks -#endif /* MPI */ + call prepare_sibling_derefinement() !! DEREFINE SELECTED BLOCKS !! @@ -1985,6 +1789,309 @@ module mesh !------------------------------------------------------------------------------- ! end subroutine update_neighbor_refinement +! +!=============================================================================== +! +! subroutine PREPARE_SIBLING_DEREFINEMENT: +! --------------------------------------- +! +! Subroutine scans over all blocks selected for derefinement and checks if +! their siblings can be derefined as well. If any of them cannot be +! derefined, the derefinement of all siblings is canceled. Then, if MPI is +! used, the subroutine brings back all siblings together to lay on +! the same process. +! +! +!=============================================================================== +! + subroutine prepare_sibling_derefinement() + +! import external procedures and variables +! + use blocks , only : block_meta, list_meta +#ifdef MPI + use blocks , only : block_data +#endif /* MPI */ + use blocks , only : nchildren + use blocks , only : set_neighbors_refine +#ifdef MPI + use blocks , only : append_datablock, remove_datablock, link_blocks +#endif /* MPI */ + use coordinates , only : toplev +#ifdef MPI + use coordinates , only : im, jm, km + use equations , only : nv +#endif /* MPI */ + use error , only : print_error +#ifdef MPI + use mpitools , only : nprocs, nproc + use mpitools , only : send_real_array, receive_real_array +#endif /* MPI */ + +! local variables are not implicit by default +! + implicit none + +! local pointers +! + type(block_meta), pointer :: pmeta, pparent, pchild +#ifdef MPI + type(block_data), pointer :: pdata +#endif /* MPI */ + +! local variables +! + logical :: flag + integer(kind=4) :: l, p + +#ifdef MPI +! tag for the MPI data exchange +! + integer(kind=4) :: itag + integer :: iret + +! local buffer for data block exchange +! + real(kind=8), dimension(nv,im,jm,km) :: rbuf +#endif /* MPI */ + +!------------------------------------------------------------------------------- +! +! 1) check if the siblings of the block selected for derefinement, can be +! derefined as well, if not cancel the derefinement of all siblings +! +! iterate over levels and check sibling derefinement +! + do l = 2, toplev + +! assign pmeta to the first meta block on the list +! + pmeta => list_meta + +! iterate over all meta blocks +! + do while (associated(pmeta)) + +! check only leafs at the current level +! + if (pmeta%leaf .and. pmeta%level == l) then + +! check if block is selected for derefinement +! + if (pmeta%refine == -1) then + +! assign pparent to the parent block of pmeta +! + pparent => pmeta%parent + +#ifdef DEBUG +! check if pparent is associated +! + if (associated(pparent)) then +#endif /* DEBUG */ + +! reset derefinement flag +! + flag = .true. + +! iterate over all children +! + do p = 1, nchildren + +! assign pchild to the current child +! + pchild => pparent%child(p)%ptr + +#ifdef DEBUG +! check if pchild is associated +! + if (associated(pchild)) then +#endif /* DEBUG */ + +! check if the current child is a leaf and selected for derefinement as well +! + flag = flag .and. (pchild%leaf .and. pchild%refine == -1) + +#ifdef DEBUG + else ! pchild is associated + call print_error("mesh::check_children_derefinement" & + , "Children does not exist!") + end if ! pparent is associated +#endif /* DEBUG */ + + end do ! over all children + +! if children can be derefined, set the refine flag of the parent to -1, +! otherwise, cancel the derefinement of all siblings +! + if (flag) then + pparent%refine = -1 + else + +! iterate over all children +! + do p = 1, nchildren + +! assign pchild to the current child +! + pchild => pparent%child(p)%ptr + +! reset its derefinement +! + pchild%refine = max(0, pchild%refine) + + end do ! children + + end if ! ~flag + +#ifdef DEBUG + else ! pparent is associated + call print_error("mesh::check_children_derefinement" & + , "Current meta block has no parent!") + end if ! pparent is associated +#endif /* DEBUG */ + + end if ! %refine = -1 + + end if ! only leafs at level l + +! assign pmeta to the next meta block +! + pmeta => pmeta%next + + end do ! iterate over meta blocks + + end do ! levels + +#ifdef MPI +! 2) bring all siblings together to the same process +! +! assign pmeta to the first meta block on the list +! + pmeta => list_meta + +! iterate over all meta blocks +! + do while (associated(pmeta)) + +! process only parent blocks (not leafs) +! + if (.not. pmeta%leaf) then + +! check if the first child is selected for derefinement +! + if (pmeta%refine == -1) then + +! assign pchild with the first child +! + pchild => pmeta%child(1)%ptr + +! set the parent process to be the same as the first child +! + pmeta%process = pchild%process + +! iterate over remaining children and if they are not on the same process, +! bring them to the parent's one +! + do p = 2, nchildren + +! assign pchild to the current child +! + pchild => pmeta%child(p)%ptr + +! if pchild belongs to a different process move its data block to the process +! of its parent +! + if (pchild%process /= pmeta%process) then + +! generate the tag for communication +! + itag = pchild%process * nprocs + pmeta%process + nprocs + p + 1 + +! send data block from the current child to the parent process and deallocate it +! + if (pchild%process == nproc) then + +! assign pdata to the daba block of the current child +! + pdata => pchild%data + +#ifdef DEBUG +! check if pdata is associated +! + if (associated(pdata)) then +#endif /* DEBUG */ + +! copy data to the local buffer +! + rbuf(:,:,:,:) = pdata%u(:,:,:,:) + +#ifdef DEBUG + else ! pdata associated + call print_error("mesh::check_children_derefinement" & + , "Current child has no data block associated!") + end if ! pdata associated +#endif /* DEBUG */ + +! send data +! + call send_real_array(size(rbuf), pmeta%process & + , itag, rbuf(:,:,:,:), iret) + +! deallocate the associated data block (it has to be pchild%data, and not pdata, +! otherwise, pchild%data won't be nullified) +! + call remove_datablock(pchild%data) + + end if ! pchild%process == nproc + +! allocate data block at the curent child, and receive its data from +! a different process +! + if (pmeta%process == nproc) then + +! allocate data block for the current child +! + call append_datablock(pdata) + call link_blocks(pchild, pdata) + +! receive the data +! + call receive_real_array(size(rbuf) & + , pchild%process, itag, rbuf(:,:,:,:), iret) + +! copy buffer to data block +! + pdata%u(:,:,:,:) = rbuf(:,:,:,:) + + end if ! pmeta%process == nproc + +! set the current processor of the block +! + pchild%process = pmeta%process + + end if ! pchild belongs to a different process + + end do ! children + +! reset the parent %refine flag +! + pmeta%refine = 0 + + end if ! pmeta children are selected for derefinement + + end if ! the block is parent + +! assign pmeta to the next meta block +! + pmeta => pmeta%next + + end do ! iterate over meta blocks +#endif /* MPI */ + +!------------------------------------------------------------------------------- +! + end subroutine prepare_sibling_derefinement !=============================================================================== ! From d38e543a8207ed0d92ef32a23a3a8a070ab5ce18 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Mon, 23 Jun 2014 15:09:28 -0300 Subject: [PATCH 15/91] BLOCKS: Move dblocks update to append_datablock() and remove_datablock(). The data block counter dblocks shouldn't be update in allocate_datablock() and deallocate_datablock(), since these subroutines can be used to allocate temporary data blocks. Instead, the counter dblocks should count only allocated data blocks which are stored in the list_data data block list. Therefore, move the update of dblocks to append_datablock() and remove_datablock(). Signed-off-by: Grzegorz Kowal --- src/blocks.F90 | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/src/blocks.F90 b/src/blocks.F90 index 7222a0b..04a9268 100644 --- a/src/blocks.F90 +++ b/src/blocks.F90 @@ -72,7 +72,8 @@ module blocks ! integer(kind=4), save :: last_id -! the number of allocated meta and data blocks, and the number of leafs +! the number of allocated meta and data blocks (inserted in the lists), +! and the number of leafs ! integer(kind=4), save :: mblocks, dblocks, nleafs @@ -668,6 +669,10 @@ module blocks ! last_data => pdata +! increase the number of data blocks in the list +! + dblocks = dblocks + 1 + !------------------------------------------------------------------------------- ! end subroutine append_datablock @@ -733,6 +738,10 @@ module blocks end if ! %meta associated +! decrease the number of allocated data blocks in the list +! + dblocks = dblocks - 1 + ! deallocate the associated data block ! call deallocate_datablock(pdata) @@ -1036,10 +1045,6 @@ module blocks ! pdata%u => pdata%u0 -! increase the number of allocated data blocks -! - dblocks = dblocks + 1 - #ifdef PROFILE ! stop accounting time for the data block allocation ! @@ -1091,10 +1096,6 @@ module blocks ! if (associated(pdata)) then -! decrease the number of allocated data blocks -! - dblocks = dblocks - 1 - ! nullify field pointing to the previous and next blocks on the data block list ! nullify(pdata%prev) From 2093a206bb24050c34e397bdbb9922a040b77a92 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Mon, 23 Jun 2014 15:17:41 -0300 Subject: [PATCH 16/91] BLOCKS: Move mblocks update to append_metablock(), remove_metablock(), etc. Similarily to dblocks, mblocks should count the number of allocated meta block which are stored in the meta block list, therefore it should be updated in append_metablock(), remove_metablock(), insert_metablock_*(), etc. Signed-off-by: Grzegorz Kowal --- src/blocks.F90 | 24 ++++++++++++++++-------- 1 file changed, 16 insertions(+), 8 deletions(-) diff --git a/src/blocks.F90 b/src/blocks.F90 index 04a9268..9ad29a2 100644 --- a/src/blocks.F90 +++ b/src/blocks.F90 @@ -550,6 +550,10 @@ module blocks ! last_meta => pmeta +! increase the number of allocated meta blocks stored in the meta block list +! + mblocks = mblocks + 1 + !------------------------------------------------------------------------------- ! end subroutine append_metablock @@ -602,6 +606,10 @@ module blocks if (associated(pmeta%prev)) pmeta%prev%next => pmeta%next if (associated(pmeta%next)) pmeta%next%prev => pmeta%prev +! decrease the number of allocated meta blocks stored in the meta block list +! + mblocks = mblocks - 1 + ! deallocate memory used by the meta block ! call deallocate_metablock(pmeta) @@ -858,10 +866,6 @@ module blocks pmeta%zmin = 0.0d+00 pmeta%zmax = 1.0d+00 -! increase the number of allocated meta blocks -! - mblocks = mblocks + 1 - #ifdef PROFILE ! stop accounting time for the meta block allocation ! @@ -921,10 +925,6 @@ module blocks ! if (pmeta%leaf) nleafs = nleafs - 1 -! decrease the number of allocated meta blocks -! - mblocks = mblocks - 1 - ! nullify fields pointing to previous and next block on the meta block list ! nullify(pmeta%prev) @@ -2879,6 +2879,10 @@ module blocks end if +! increase the number of allocated meta blocks stored in the meta block list +! + mblocks = mblocks + 1 + !------------------------------------------------------------------------------- ! end subroutine insert_metablock_after @@ -2974,6 +2978,10 @@ module blocks end if +! increase the number of allocated meta blocks stored in the meta block list +! + mblocks = mblocks + 1 + !------------------------------------------------------------------------------- ! end subroutine insert_metablock_before From 2b27685b41c9148e54d30c56c9f3392998652b9a Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Mon, 23 Jun 2014 15:23:36 -0300 Subject: [PATCH 17/91] BLOCKS: Update the number of leafs in remove_metablock(). Signed-off-by: Grzegorz Kowal --- src/blocks.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/blocks.F90 b/src/blocks.F90 index 9ad29a2..bfbfa63 100644 --- a/src/blocks.F90 +++ b/src/blocks.F90 @@ -606,6 +606,10 @@ module blocks if (associated(pmeta%prev)) pmeta%prev%next => pmeta%next if (associated(pmeta%next)) pmeta%next%prev => pmeta%prev +! set this block to be not a leaf +! + call metablock_unset_leaf(pmeta) + ! decrease the number of allocated meta blocks stored in the meta block list ! mblocks = mblocks - 1 @@ -921,10 +925,6 @@ module blocks ! if (associated(pmeta)) then -! decrease the number of leafs -! - if (pmeta%leaf) nleafs = nleafs - 1 - ! nullify fields pointing to previous and next block on the meta block list ! nullify(pmeta%prev) From c3d456e5b57a676c16fee5b354383a8e7dc7824e Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Mon, 23 Jun 2014 15:28:25 -0300 Subject: [PATCH 18/91] BLOCKS: Fix metablock_set_leaf() and metablock_unset_leaf(). Update the leaf state and counter nleafs in metablock_set_leaf() and metablock_unset_leaf() only if they really change the state. Signed-off-by: Grzegorz Kowal --- src/blocks.F90 | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/blocks.F90 b/src/blocks.F90 index bfbfa63..cdf9f6f 100644 --- a/src/blocks.F90 +++ b/src/blocks.F90 @@ -2565,6 +2565,10 @@ module blocks ! !------------------------------------------------------------------------------- ! +! return, if it is a leaf already +! + if (pmeta%leaf) return + ! set the block's leaf flag ! pmeta%leaf = .true. @@ -2602,6 +2606,10 @@ module blocks ! !------------------------------------------------------------------------------- ! +! return, if is not a leaf +! + if (.not. pmeta%leaf) return + ! unset the block's leaf flag ! pmeta%leaf = .false. From 6f9de6e6c53bbca17975dbd01a52163f7e4ed4ad Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Mon, 23 Jun 2014 16:14:36 -0300 Subject: [PATCH 19/91] MESH: Move block restriction to derefine_selected_blocks(). The actual block restriction has been moved from update_mesh() to a separate one called derefine_selected_blocks(). Signed-off-by: Grzegorz Kowal --- src/mesh.F90 | 157 ++++++++++++++++++++++++++++++++++++--------------- 1 file changed, 113 insertions(+), 44 deletions(-) diff --git a/src/mesh.F90 b/src/mesh.F90 index a528e36..417660a 100644 --- a/src/mesh.F90 +++ b/src/mesh.F90 @@ -844,47 +844,9 @@ module mesh ! call prepare_sibling_derefinement() -!! DEREFINE SELECTED BLOCKS -!! -! perform the actual derefinement +! restrict selected blocks ! - do l = toplev, 2, -1 - - pmeta => list_meta - do while (associated(pmeta)) - - if (pmeta%leaf) then - if (pmeta%level .eq. l) then - if (pmeta%refine .eq. -1) then - pparent => pmeta%parent - - if (associated(pparent)) then -#ifdef MPI - if (pmeta%process .eq. nproc) then -#endif /* MPI */ - if (.not. associated(pparent%data)) then - call append_datablock(pdata) - call link_blocks(pparent, pdata) - end if - call restrict_block(pparent) -#ifdef MPI - end if -#endif /* MPI */ - - call derefine_block(pparent) - pmeta => pparent - else - call print_error("mesh::update_mesh" & - , "Parent of derefined block is not associated!") - end if - end if - end if - end if - - pmeta => pmeta%next - end do - - end do + call derefine_selected_blocks() !! REFINE SELECTED BLOCKS !! @@ -1801,6 +1763,10 @@ module mesh ! used, the subroutine brings back all siblings together to lay on ! the same process. ! +! Note: This subroutine sets %refine flag of the parent to -1 to let the next +! executed subroutine derefine_selected_blocks() which parent block +! has to be derefined. That subroutine resets %refine flag of the +! parent after performing full restriction. ! !=============================================================================== ! @@ -2074,10 +2040,6 @@ module mesh end do ! children -! reset the parent %refine flag -! - pmeta%refine = 0 - end if ! pmeta children are selected for derefinement end if ! the block is parent @@ -2092,6 +2054,113 @@ module mesh !------------------------------------------------------------------------------- ! end subroutine prepare_sibling_derefinement +! +!=============================================================================== +! +! subroutine DEREFINE_SELECTED_BLOCKS: +! ----------------------------------- +! +! Subroutine scans over all blocks and actually restrict those selected +! for derefinement. +! +! Note: This subroutine resets %refine flag set in subroutine +! prepare_sibling_derefinement(). +! +!=============================================================================== +! + subroutine derefine_selected_blocks() + +! import external procedures and variables +! + use blocks , only : block_meta, block_data, list_meta + use blocks , only : append_datablock, link_blocks, derefine_block + use coordinates , only : toplev +#ifdef MPI + use mpitools , only : nproc +#endif /* MPI */ + +! local variables are not implicit by default +! + implicit none + +! local pointers +! + type(block_meta), pointer :: pmeta + type(block_data), pointer :: pdata + +! local variables +! + integer(kind=4) :: l + +!------------------------------------------------------------------------------- +! +! start from the top level and iterating down restrict the blocks selected +! for derefinement +! + do l = toplev - 1, 1, -1 + +! assign pmeta to the first meta block on the list +! + pmeta => list_meta + +! iterate over all meta blocks +! + do while (associated(pmeta)) + +! process non-leafs at the current level selected for restriction +! + if (.not. pmeta%leaf .and. pmeta%level == l & + .and. pmeta%refine == -1) then + +#ifdef MPI +! check if pmeta belongs to the current process +! + if (pmeta%process == nproc) then +#endif /* MPI */ + +! check if a data block is associated with pmeta, if not create one +! + if (.not. associated(pmeta%data)) then + +! append new data block +! + call append_datablock(pdata) + +! link it with the current pmeta +! + call link_blocks(pmeta, pdata) + + end if ! no data block associated + +! perform the block restriction +! + call restrict_block(pmeta) + +#ifdef MPI + end if ! pmeta belongs to the current process +#endif /* MPI */ + +! perform block derefinement +! + call derefine_block(pmeta) + +! reset the refinement flag of the current block +! + pmeta%refine = 0 + + end if ! leaf at current level selected for derefinement + +! assign pmeta to the next meta block +! + pmeta => pmeta%next + + end do ! iterate over meta blocks + + end do ! levels + +!------------------------------------------------------------------------------- +! + end subroutine derefine_selected_blocks !=============================================================================== ! From 1821c485d598ef654d0b570938253825fccf38c9 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Mon, 23 Jun 2014 16:27:00 -0300 Subject: [PATCH 20/91] MESH: Move block prolongation to refine_selected_blocks(). The actual block prolongation has been moved from update_mesh() to a separate one called refine_selected_blocks(). Signed-off-by: Grzegorz Kowal --- src/mesh.F90 | 129 +++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 100 insertions(+), 29 deletions(-) diff --git a/src/mesh.F90 b/src/mesh.F90 index 417660a..3225b24 100644 --- a/src/mesh.F90 +++ b/src/mesh.F90 @@ -848,36 +848,9 @@ module mesh ! call derefine_selected_blocks() -!! REFINE SELECTED BLOCKS -!! -! perform the actual refinement starting from the lowest level +! prolong selected blocks ! - do l = 1, toplev - 1 - - pmeta => list_meta - do while (associated(pmeta)) - if (pmeta%leaf) then - if (pmeta%level .eq. l) then - if (pmeta%refine .eq. 1) then - pparent => pmeta -#ifdef MPI - if (pmeta%process .eq. nproc) then -#endif /* MPI */ - call refine_block(pmeta, .true.) - call prolong_block(pparent) - call remove_datablock(pparent%data) -#ifdef MPI - else - call refine_block(pmeta, .false.) - end if -#endif /* MPI */ - end if - end if - end if - pmeta => pmeta%next - end do - - end do ! l = 1, toplev - 1 + call refine_selected_blocks() #ifdef MPI ! redistribute blocks equally among all processors @@ -2161,6 +2134,104 @@ module mesh !------------------------------------------------------------------------------- ! end subroutine derefine_selected_blocks +! +!=============================================================================== +! +! subroutine REFINE_SELECTED_BLOCKS: +! --------------------------------- +! +! Subroutine scans over all blocks and prolongates those selected for +! refinement. +! +! +!=============================================================================== +! + subroutine refine_selected_blocks() + +! import external procedures and variables +! + use blocks , only : block_meta, list_meta + use blocks , only : refine_block, remove_datablock + use coordinates , only : toplev +#ifdef MPI + use mpitools , only : nproc +#endif /* MPI */ + +! local variables are not implicit by default +! + implicit none + +! local pointers +! + type(block_meta), pointer :: pmeta, pparent + +! local variables +! + integer(kind=4) :: l + +!------------------------------------------------------------------------------- +! +! iterate over all levels and prolong those selected for prolongation +! + do l = 1, toplev - 1 + +! assign pmeta to the first meta block on the list +! + pmeta => list_meta + +! iterate over all meta blocks +! + do while (associated(pmeta)) + +! process leafs at the current level selected for prolongation +! + if (pmeta%leaf .and. pmeta%level == l .and. pmeta%refine == 1) then + +! assign pparent with the new parent block +! + pparent => pmeta + +#ifdef MPI +! check if pmeta belongs to the current process +! + if (pmeta%process == nproc) then +#endif /* MPI */ + +! prepare child blocks with allocating the data blocks +! + call refine_block(pmeta, .true.) + +! perform the data prolongation +! + call prolong_block(pparent) + +! remove the data block associated with the new parent +! + call remove_datablock(pparent%data) + +#ifdef MPI + else ! pmeta belongs to the current process + +! prepare child blocks without actually allocating the data blocks +! + call refine_block(pmeta, .false.) + + end if ! pmeta belongs to the current process +#endif /* MPI */ + + end if ! leaf at current level selected for refinement + +! assign pmeta to the next meta block +! + pmeta => pmeta%next + + end do ! iterate over meta blocks + + end do ! levels + +!------------------------------------------------------------------------------- +! + end subroutine refine_selected_blocks !=============================================================================== ! From 153cc89980ad53344554f4b1ce3a399c0e527258 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Mon, 23 Jun 2014 16:34:28 -0300 Subject: [PATCH 21/91] MESH: Remove unused variables from update_mesh(). Signed-off-by: Grzegorz Kowal --- src/mesh.F90 | 44 -------------------------------------------- 1 file changed, 44 deletions(-) diff --git a/src/mesh.F90 b/src/mesh.F90 index 3225b24..51d4e03 100644 --- a/src/mesh.F90 +++ b/src/mesh.F90 @@ -771,58 +771,14 @@ module mesh ! import external procedures and variables ! - use blocks , only : block_meta, block_data, list_meta, list_data - use blocks , only : nchildren, ndims, nsides, nfaces - use blocks , only : get_nleafs - use blocks , only : refine_block, derefine_block - use blocks , only : append_datablock, remove_datablock, link_blocks - use blocks , only : set_neighbors_refine #ifdef DEBUG use blocks , only : check_neighbors #endif /* DEBUG */ - use coordinates , only : minlev, maxlev, toplev, im, jm, km - use equations , only : nv - use error , only : print_error -#ifdef MPI - use mpitools , only : master, nprocs, nproc - use mpitools , only : reduce_sum_integer_array - use mpitools , only : send_real_array, receive_real_array -#endif /* MPI */ - use refinement , only : check_refinement_criterion ! local variables are not implicit by default ! implicit none -! local variables -! - logical :: flag - integer(kind=4) :: nl, i, j, k, l, n, p - integer :: iret - -! local pointers -! - type(block_meta), pointer :: pmeta, pneigh, pchild, pparent - type(block_data), pointer :: pdata - -#ifdef MPI -! tag for the MPI data exchange -! - integer(kind=4) :: itag - -! array for storing the refinement flags -! - integer(kind=4), dimension(:), allocatable :: ibuf - -! array for number of data block for autobalancing -! - integer(kind=4), dimension(0:nprocs-1) :: lb - -! local buffer for data block exchange -! - real(kind=8) , dimension(nv,im,jm,km) :: rbuf -#endif /* MPI */ - !------------------------------------------------------------------------------- ! #ifdef PROFILE From 64a483cb91ffe18a2e71675d222bf2f020860919 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Mon, 23 Jun 2014 16:39:00 -0300 Subject: [PATCH 22/91] MESH: Spell checking in update_mesh(). Signed-off-by: Grzegorz Kowal --- src/mesh.F90 | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/src/mesh.F90 b/src/mesh.F90 index 51d4e03..b62c298 100644 --- a/src/mesh.F90 +++ b/src/mesh.F90 @@ -759,10 +759,10 @@ module mesh ! subroutine UPDATE_MESH: ! ---------------------- ! -! Subroutine checks the refinement criterion for each data block, and -! refines or derefines it if necessary by restricting or prolongating -! the block data. In the MPI version the data blocks are redistributed -! among all processes after the mesh update. +! Subroutine checks the refinement criterion for each block, and refines +! or restricts it if necessary by prolongating or restricting its data. +! In the MPI version the data blocks are redistributed among all processes +! after the mesh update. ! ! !=============================================================================== @@ -795,8 +795,7 @@ module mesh ! call update_neighbor_refinement() -! check if all siblings of blocks marked to be derefined can be derefined as -! well, if not cancel their deferinement flags +! prepare siblings of blocks marked for restriction ! call prepare_sibling_derefinement() From 62d413303c294d883c19fbae349d9cdc43cd7b77 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Mon, 23 Jun 2014 16:42:45 -0300 Subject: [PATCH 23/91] MESH: Spell check in recently added subroutines. Signed-off-by: Grzegorz Kowal --- src/mesh.F90 | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/src/mesh.F90 b/src/mesh.F90 index b62c298..171d78b 100644 --- a/src/mesh.F90 +++ b/src/mesh.F90 @@ -1988,10 +1988,9 @@ module mesh ! subroutine DEREFINE_SELECTED_BLOCKS: ! ----------------------------------- ! -! Subroutine scans over all blocks and actually restrict those selected -! for derefinement. +! Subroutine scans over all blocks and restrict those selected. ! -! Note: This subroutine resets %refine flag set in subroutine +! Note: This subroutine resets the flag %refine set in subroutine ! prepare_sibling_derefinement(). ! !=============================================================================== @@ -2022,8 +2021,7 @@ module mesh !------------------------------------------------------------------------------- ! -! start from the top level and iterating down restrict the blocks selected -! for derefinement +! iterate over levels and restrict the blocks selected for restriction ! do l = toplev - 1, 1, -1 @@ -2068,7 +2066,7 @@ module mesh end if ! pmeta belongs to the current process #endif /* MPI */ -! perform block derefinement +! perform the mesh derefinement ! call derefine_block(pmeta) @@ -2076,7 +2074,7 @@ module mesh ! pmeta%refine = 0 - end if ! leaf at current level selected for derefinement + end if ! non-leaf at current level selected for derefinement ! assign pmeta to the next meta block ! @@ -2095,8 +2093,7 @@ module mesh ! subroutine REFINE_SELECTED_BLOCKS: ! --------------------------------- ! -! Subroutine scans over all blocks and prolongates those selected for -! refinement. +! Subroutine scans over all blocks and prolongates those selected. ! ! !=============================================================================== From f816303472124dc81de666660d625341f567908c Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Mon, 23 Jun 2014 16:51:13 -0300 Subject: [PATCH 24/91] MESH: Remove unnecessary import in generate_mesh(). Signed-off-by: Grzegorz Kowal --- src/mesh.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/mesh.F90 b/src/mesh.F90 index 171d78b..5f7a3e2 100644 --- a/src/mesh.F90 +++ b/src/mesh.F90 @@ -458,7 +458,7 @@ module mesh use blocks , only : block_meta, block_data, list_meta, list_data use blocks , only : ndims, nchildren, nsides, nfaces use blocks , only : allocate_datablock, deallocate_datablock - use blocks , only : append_datablock, remove_datablock + use blocks , only : append_datablock use blocks , only : link_blocks, unlink_blocks, refine_block use blocks , only : get_mblocks, get_nleafs use blocks , only : set_neighbors_refine From 37d3fd0d8755e2d3d5e0d70b1e1c441042a11cb5 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Sat, 5 Jul 2014 13:22:16 -0300 Subject: [PATCH 25/91] BLOCKS: Add face, edge and corner neighbor fields to meta block structure. This commit extends the meta block structure by fields in which we store pointers to face, edge and corner neighbors. In the current implementation the boundary update is only done for block faces, meaning that the corners are not properly updated between the blocks on different levels. This, of course, can create unexpected problems, like improper interpolation in the ghost zones, resulting in NaNs there. The fields for neighbor pointers should allow for a quick access to neighbors for full, properly done, boundary update. Signed-off-by: Grzegorz Kowal --- src/blocks.F90 | 49 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 49 insertions(+) diff --git a/src/blocks.F90 b/src/blocks.F90 index cdf9f6f..09f6e14 100644 --- a/src/blocks.F90 +++ b/src/blocks.F90 @@ -123,6 +123,55 @@ module blocks ! type(pointer_meta) :: child(nchildren) +#if NDIMS == 2 + ! pointers to edge neighbor meta blocks with + ! indices: + ! 1 - the direction of the edge normal vector + ! 2 - the side of the cube + ! 3 - the half of the edge + ! and dimensions [1:2,1:2,1:2] + ! + type(pointer_meta) :: edges(ndims,nsides,nsides) + + ! pointers to corner neighbor meta blocks with + ! indices: + ! 1 - the first coordinate + ! 2 - the second coordinate + ! and dimensions [1:2,1:2] + ! + type(pointer_meta) :: corners(nsides,nsides) +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + ! pointers to face neighbor meta blocks with + ! indices: + ! 1 - the direction of the face normal vector + ! 2 - the side of the cube + ! 3 - the first perpendicular coordinate + ! 4 - the second perpendicular coordinate + ! and dimensions [1:3,1:2,1:2,1:2] + ! + type(pointer_meta) :: faces(ndims,nsides,nsides,nsides) + + ! pointers to edge neighbor meta blocks with + ! indices: + ! 1 - the direction of the edge + ! 2 - the first perpendicular coordinate + ! 3 - the second perpendicular coordinate + ! 4 - the half of the edge + ! and dimensions [1:3,1:2,1:2,1:2] + ! + type(pointer_meta) :: edges(ndims,nsides,nsides,nsides) + + ! pointers to corner neighbor meta blocks with + ! indices: + ! 1 - the first coordinate (1 or 2) + ! 2 - the second coordinate (1 or 2) + ! 3 - the third coordinate (1 or 2) + ! and dimensions [1:2,1:2,1:2] + ! + type(pointer_meta) :: corners(nsides,nsides,nsides) +#endif /* NDIMS == 3 */ + ! pointers to neighbor meta blocks ! type(pointer_meta) :: neigh(ndims,nsides,nfaces) From 5262f29e3a68d2484bea1669112444b3e50fa8b8 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Sat, 5 Jul 2014 13:45:55 -0300 Subject: [PATCH 26/91] BLOCKS: Nullify new neighbor fields in allocate_metablock(). Signed-off-by: Grzegorz Kowal --- src/blocks.F90 | 28 +++++++++++++++++++++++++++- 1 file changed, 27 insertions(+), 1 deletion(-) diff --git a/src/blocks.F90 b/src/blocks.F90 index 09f6e14..dca62d9 100644 --- a/src/blocks.F90 +++ b/src/blocks.F90 @@ -845,7 +845,7 @@ module blocks ! local variables ! - integer :: i, j, k + integer :: n, i, j, k ! !------------------------------------------------------------------------------- ! @@ -874,6 +874,32 @@ module blocks nullify(pmeta%child(i)%ptr) end do +! nullify fields pointing to face, edge, and corner neighbors +! +#if NDIMS == 2 + do i = 1, nsides + do j = 1, nsides + do n = 1, ndims + nullify(pmeta%edges(n,i,j)%ptr) + end do ! ndims + nullify(pmeta%corners(i,j)%ptr) + end do ! nsides + end do ! nsides +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + do i = 1, nsides + do j = 1, nsides + do k = 1, nsides + do n = 1, ndims + nullify(pmeta%faces(n,i,j,k)%ptr) + nullify(pmeta%edges(n,i,j,k)%ptr) + end do ! ndims + nullify(pmeta%corners(i,j,k)%ptr) + end do ! nsides + end do ! nsides + end do ! nsides +#endif /* NDIMS == 3 */ + ! nullify fields pointing to neighbors ! do i = 1, ndims From 1b3eb9c933f939feec320770b1b333f74dafbd96 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Sat, 5 Jul 2014 13:50:48 -0300 Subject: [PATCH 27/91] BLOCKS: Nullify new neighbor fields in deallocate_metablock(). Signed-off-by: Grzegorz Kowal --- src/blocks.F90 | 28 +++++++++++++++++++++++++++- 1 file changed, 27 insertions(+), 1 deletion(-) diff --git a/src/blocks.F90 b/src/blocks.F90 index dca62d9..4635a4e 100644 --- a/src/blocks.F90 +++ b/src/blocks.F90 @@ -986,7 +986,7 @@ module blocks ! local variables ! - integer :: i, j, k + integer :: n, i, j, k ! !------------------------------------------------------------------------------- ! @@ -1015,6 +1015,32 @@ module blocks nullify(pmeta%child(i)%ptr) end do +! nullify fields pointing to face, edge, and corner neighbors +! +#if NDIMS == 2 + do i = 1, nsides + do j = 1, nsides + do n = 1, ndims + nullify(pmeta%edges(n,i,j)%ptr) + end do ! ndims + nullify(pmeta%corners(i,j)%ptr) + end do ! nsides + end do ! nsides +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + do i = 1, nsides + do j = 1, nsides + do k = 1, nsides + do n = 1, ndims + nullify(pmeta%faces(n,i,j,k)%ptr) + nullify(pmeta%edges(n,i,j,k)%ptr) + end do ! ndims + nullify(pmeta%corners(i,j,k)%ptr) + end do ! nsides + end do ! nsides + end do ! nsides +#endif /* NDIMS == 3 */ + ! nullify fields pointing to neighbors ! do i = 1, ndims From 9e7b0b3e9de20d20a335856841d4ceabc9f4bc52 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Sun, 6 Jul 2014 20:09:45 -0300 Subject: [PATCH 28/91] BLOCKS: Change the meaning of indices in neighbor pointers. The fields of the meta block structure pointing to face, edge and corner neighbors have new interpretation now. In face and edge fields, first 2 or 3 indices (for 2D and 3D, respectively) describe the corner coordinates to which the considered face or edge is linked. Then the last index describe of the direction of the normal to the block face, or in other words on which plane of the corner the face border plane is considered, in the case of face neighbor. In the case of the edge neighbour, the last pointer describe the direction along which the edge is positioned. Signed-off-by: Grzegorz Kowal --- src/blocks.F90 | 57 ++++++++++++++++++++++++++------------------------ 1 file changed, 30 insertions(+), 27 deletions(-) diff --git a/src/blocks.F90 b/src/blocks.F90 index 4635a4e..fecf240 100644 --- a/src/blocks.F90 +++ b/src/blocks.F90 @@ -126,17 +126,18 @@ module blocks #if NDIMS == 2 ! pointers to edge neighbor meta blocks with ! indices: - ! 1 - the direction of the edge normal vector - ! 2 - the side of the cube - ! 3 - the half of the edge + ! 1 - the X corner coordinate + ! 2 - the Y corner coordinate + ! 3 - the direction of the edge from the corner + ! with above coordinates ! and dimensions [1:2,1:2,1:2] ! - type(pointer_meta) :: edges(ndims,nsides,nsides) + type(pointer_meta) :: edges(nsides,nsides,ndims) ! pointers to corner neighbor meta blocks with ! indices: - ! 1 - the first coordinate - ! 2 - the second coordinate + ! 1 - the X corner coordinate + ! 2 - the Y corner coordinate ! and dimensions [1:2,1:2] ! type(pointer_meta) :: corners(nsides,nsides) @@ -144,29 +145,31 @@ module blocks #if NDIMS == 3 ! pointers to face neighbor meta blocks with ! indices: - ! 1 - the direction of the face normal vector - ! 2 - the side of the cube - ! 3 - the first perpendicular coordinate - ! 4 - the second perpendicular coordinate - ! and dimensions [1:3,1:2,1:2,1:2] + ! 1 - the X corner coordinate + ! 2 - the Y corner coordinate + ! 3 - the Z corner coordinate + ! 4 - the direction of the face normal vector + ! from the corner with above coordinates + ! and dimensions [1:2,1:2,1:2,1:3] ! - type(pointer_meta) :: faces(ndims,nsides,nsides,nsides) + type(pointer_meta) :: faces(nsides,nsides,nsides,ndims) ! pointers to edge neighbor meta blocks with ! indices: - ! 1 - the direction of the edge - ! 2 - the first perpendicular coordinate - ! 3 - the second perpendicular coordinate - ! 4 - the half of the edge - ! and dimensions [1:3,1:2,1:2,1:2] + ! 1 - the X corner coordinate + ! 2 - the Y corner coordinate + ! 3 - the Z corner coordinate + ! 4 - the direction of the edge from the corner + ! with above coordinates + ! and dimensions [1:2,1:2,1:2,1:3] ! - type(pointer_meta) :: edges(ndims,nsides,nsides,nsides) + type(pointer_meta) :: edges(nsides,nsides,nsides,ndims) ! pointers to corner neighbor meta blocks with ! indices: - ! 1 - the first coordinate (1 or 2) - ! 2 - the second coordinate (1 or 2) - ! 3 - the third coordinate (1 or 2) + ! 1 - the X corner coordinate + ! 2 - the Y corner coordinate + ! 3 - the Z corner coordinate ! and dimensions [1:2,1:2,1:2] ! type(pointer_meta) :: corners(nsides,nsides,nsides) @@ -880,7 +883,7 @@ module blocks do i = 1, nsides do j = 1, nsides do n = 1, ndims - nullify(pmeta%edges(n,i,j)%ptr) + nullify(pmeta%edges(i,j,n)%ptr) end do ! ndims nullify(pmeta%corners(i,j)%ptr) end do ! nsides @@ -891,8 +894,8 @@ module blocks do j = 1, nsides do k = 1, nsides do n = 1, ndims - nullify(pmeta%faces(n,i,j,k)%ptr) - nullify(pmeta%edges(n,i,j,k)%ptr) + nullify(pmeta%faces(i,j,k,n)%ptr) + nullify(pmeta%edges(i,j,k,n)%ptr) end do ! ndims nullify(pmeta%corners(i,j,k)%ptr) end do ! nsides @@ -1021,7 +1024,7 @@ module blocks do i = 1, nsides do j = 1, nsides do n = 1, ndims - nullify(pmeta%edges(n,i,j)%ptr) + nullify(pmeta%edges(i,j,n)%ptr) end do ! ndims nullify(pmeta%corners(i,j)%ptr) end do ! nsides @@ -1032,8 +1035,8 @@ module blocks do j = 1, nsides do k = 1, nsides do n = 1, ndims - nullify(pmeta%faces(n,i,j,k)%ptr) - nullify(pmeta%edges(n,i,j,k)%ptr) + nullify(pmeta%faces(i,j,k,n)%ptr) + nullify(pmeta%edges(i,j,k,n)%ptr) end do ! ndims nullify(pmeta%corners(i,j,k)%ptr) end do ! nsides From 6ae36d29d9b06ae5f9b1351f652105f004532672 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Mon, 7 Jul 2014 12:46:39 -0300 Subject: [PATCH 29/91] BLOCKS: Update edge and corner pointers in refine_block() for 2D. This commit updated the child edge and corner pointers in refine_block() for 2D case. It updates corresponding neighbor edge and corner pointers as well. Signed-off-by: Grzegorz Kowal --- src/blocks.F90 | 162 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 162 insertions(+) diff --git a/src/blocks.F90 b/src/blocks.F90 index fecf240..911bef4 100644 --- a/src/blocks.F90 +++ b/src/blocks.F90 @@ -1575,6 +1575,168 @@ module blocks end do ! nchildren +! update edge neighbor pointers of children, and the corresponding edge +! pointers of neighbors +! +#if NDIMS == 2 + pchild => pmeta%child(1)%ptr + if (associated(pmeta%edges(1,1,1)%ptr)) then + pneigh => pmeta%edges(1,1,1)%ptr + pchild%edges(1,1,1)%ptr => pmeta%edges(1,1,1)%ptr + pchild%edges(2,1,1)%ptr => pmeta%edges(1,1,1)%ptr + pneigh%edges(1,2,1)%ptr => pchild + if (pneigh%level > pmeta%level) pneigh%edges(2,2,1)%ptr => pchild + end if + pchild%edges(1,2,1)%ptr => pmeta%child(3)%ptr + pchild%edges(2,2,1)%ptr => pmeta%child(3)%ptr + if (associated(pmeta%edges(1,1,2)%ptr)) then + pneigh => pmeta%edges(1,1,2)%ptr + pchild%edges(1,1,2)%ptr => pmeta%edges(1,1,2)%ptr + pchild%edges(1,2,2)%ptr => pmeta%edges(1,1,2)%ptr + pneigh%edges(2,1,2)%ptr => pchild + if (pneigh%level > pmeta%level) pneigh%edges(2,2,2)%ptr => pchild + end if + pchild%edges(2,1,2)%ptr => pmeta%child(2)%ptr + pchild%edges(2,2,2)%ptr => pmeta%child(2)%ptr + + pchild => pmeta%child(2)%ptr + if (associated(pmeta%edges(2,1,1)%ptr)) then + pneigh => pmeta%edges(2,1,1)%ptr + pchild%edges(1,1,1)%ptr => pmeta%edges(2,1,1)%ptr + pchild%edges(2,1,1)%ptr => pmeta%edges(2,1,1)%ptr + pneigh%edges(2,2,1)%ptr => pchild + if (pneigh%level > pmeta%level) pneigh%edges(1,2,1)%ptr => pchild + end if + pchild%edges(1,2,1)%ptr => pmeta%child(4)%ptr + pchild%edges(2,2,1)%ptr => pmeta%child(4)%ptr + pchild%edges(1,1,2)%ptr => pmeta%child(1)%ptr + pchild%edges(1,2,2)%ptr => pmeta%child(1)%ptr + if (associated(pmeta%edges(2,1,2)%ptr)) then + pneigh => pmeta%edges(2,1,2)%ptr + pchild%edges(2,1,2)%ptr => pmeta%edges(2,1,2)%ptr + pchild%edges(2,2,2)%ptr => pmeta%edges(2,1,2)%ptr + pneigh%edges(1,1,2)%ptr => pchild + if (pneigh%level > pmeta%level) pneigh%edges(1,2,2)%ptr => pchild + end if + + pchild => pmeta%child(3)%ptr + pchild%edges(1,1,1)%ptr => pmeta%child(1)%ptr + pchild%edges(2,1,1)%ptr => pmeta%child(1)%ptr + if (associated(pmeta%edges(1,2,1)%ptr)) then + pneigh => pmeta%edges(1,2,1)%ptr + pchild%edges(1,2,1)%ptr => pmeta%edges(1,2,1)%ptr + pchild%edges(2,2,1)%ptr => pmeta%edges(1,2,1)%ptr + pneigh%edges(1,1,1)%ptr => pchild + if (pneigh%level > pmeta%level) pneigh%edges(2,1,1)%ptr => pchild + end if + if (associated(pmeta%edges(1,2,2)%ptr)) then + pneigh => pmeta%edges(1,2,2)%ptr + pchild%edges(1,1,2)%ptr => pmeta%edges(1,2,2)%ptr + pchild%edges(1,2,2)%ptr => pmeta%edges(1,2,2)%ptr + pneigh%edges(2,2,2)%ptr => pchild + if (pneigh%level > pmeta%level) pneigh%edges(2,1,2)%ptr => pchild + end if + pchild%edges(2,1,2)%ptr => pmeta%child(4)%ptr + pchild%edges(2,2,2)%ptr => pmeta%child(4)%ptr + + pchild => pmeta%child(4)%ptr + pchild%edges(1,1,1)%ptr => pmeta%child(2)%ptr + pchild%edges(2,1,1)%ptr => pmeta%child(2)%ptr + if (associated(pmeta%edges(2,2,1)%ptr)) then + pneigh => pmeta%edges(2,2,1)%ptr + pchild%edges(1,2,1)%ptr => pmeta%edges(2,2,1)%ptr + pchild%edges(2,2,1)%ptr => pmeta%edges(2,2,1)%ptr + pneigh%edges(2,1,1)%ptr => pchild + if (pneigh%level > pmeta%level) pneigh%edges(1,1,1)%ptr => pchild + end if + pchild%edges(1,1,2)%ptr => pmeta%child(3)%ptr + pchild%edges(1,2,2)%ptr => pmeta%child(3)%ptr + if (associated(pmeta%edges(2,2,2)%ptr)) then + pneigh => pmeta%edges(2,2,2)%ptr + pchild%edges(2,1,2)%ptr => pmeta%edges(2,2,2)%ptr + pchild%edges(2,2,2)%ptr => pmeta%edges(2,2,2)%ptr + pneigh%edges(1,2,2)%ptr => pchild + if (pneigh%level > pmeta%level) pneigh%edges(1,1,2)%ptr => pchild + end if +#endif /* NDIMS == 2 */ + +! update corner neighbor pointers of children, and corresponding neighbor +! corners if they lay at larger level +! +#if NDIMS == 2 + pchild => pmeta%child(1)%ptr + if (associated(pmeta%corners(1,1)%ptr)) then + pneigh => pmeta%corners(1,1)%ptr + pchild%corners(1,1)%ptr => pmeta%corners(1,1)%ptr + pneigh%corners(2,2)%ptr => pchild + end if + if (associated(pmeta%edges(2,1,1)%ptr)) then + pneigh => pmeta%edges(2,1,1)%ptr + pchild%corners(2,1)%ptr => pmeta%edges(2,1,1)%ptr + if (pneigh%level > pmeta%level) pneigh%corners(1,2)%ptr => pchild + endif + if (associated(pmeta%edges(1,2,2)%ptr)) then + pneigh => pmeta%edges(1,2,2)%ptr + pchild%corners(1,2)%ptr => pmeta%edges(1,2,2)%ptr + if (pneigh%level > pmeta%level) pneigh%corners(2,1)%ptr => pchild + end if + pchild%corners(2,2)%ptr => pmeta%child(4)%ptr + + pchild => pmeta%child(2)%ptr + if (associated(pmeta%edges(1,1,1)%ptr)) then + pneigh => pmeta%edges(1,1,1)%ptr + pchild%corners(1,1)%ptr => pmeta%edges(1,1,1)%ptr + if (pneigh%level > pmeta%level) pneigh%corners(2,2)%ptr => pchild + end if + if (associated(pmeta%corners(2,1)%ptr)) then + pneigh => pmeta%corners(2,1)%ptr + pchild%corners(2,1)%ptr => pmeta%corners(2,1)%ptr + pneigh%corners(1,2)%ptr => pchild + end if + pchild%corners(1,2)%ptr => pmeta%child(3)%ptr + if (associated(pmeta%edges(2,2,2)%ptr)) then + pneigh => pmeta%edges(2,2,2)%ptr + pchild%corners(2,2)%ptr => pmeta%edges(2,2,2)%ptr + if (pneigh%level > pmeta%level) pneigh%corners(1,1)%ptr => pchild + end if + + pchild => pmeta%child(3)%ptr + if (associated(pmeta%edges(1,1,2)%ptr)) then + pneigh => pmeta%edges(1,1,2)%ptr + pchild%corners(1,1)%ptr => pmeta%edges(1,1,2)%ptr + if (pneigh%level > pmeta%level) pneigh%corners(2,2)%ptr => pchild + end if + pchild%corners(2,1)%ptr => pmeta%child(2)%ptr + if (associated(pmeta%corners(1,2)%ptr)) then + pneigh => pmeta%corners(1,2)%ptr + pchild%corners(1,2)%ptr => pmeta%corners(1,2)%ptr + pneigh%corners(2,1)%ptr => pchild + end if + if (associated(pmeta%edges(2,2,1)%ptr)) then + pneigh => pmeta%edges(2,2,1)%ptr + pchild%corners(2,2)%ptr => pmeta%edges(2,2,1)%ptr + if (pneigh%level > pmeta%level) pneigh%corners(1,1)%ptr => pchild + end if + + pchild => pmeta%child(4)%ptr + pchild%corners(1,1)%ptr => pmeta%child(1)%ptr + if (associated(pmeta%edges(2,1,2)%ptr)) then + pneigh => pmeta%edges(2,1,2)%ptr + pchild%corners(2,1)%ptr => pmeta%edges(2,1,2)%ptr + if (pneigh%level > pmeta%level) pneigh%corners(1,2)%ptr => pchild + end if + if (associated(pmeta%edges(1,2,1)%ptr)) then + pneigh => pmeta%edges(1,2,1)%ptr + pchild%corners(1,2)%ptr => pmeta%edges(1,2,1)%ptr + if (pneigh%level > pmeta%level) pneigh%corners(2,1)%ptr => pchild + end if + if (associated(pmeta%corners(2,2)%ptr)) then + pneigh => pmeta%corners(2,2)%ptr + pchild%corners(2,2)%ptr => pmeta%corners(2,2)%ptr + pneigh%corners(1,1)%ptr => pchild + end if +#endif /* NDIMS == 2 */ + !! ASSIGN PROPER NEIGHBORS FOR THE CHILDREN IN THE INTERIOR OF THE PARENT BLOCK !! ! iterate over faces and update the interior of the block From 09ddc6cb0009391028b63869022b1902bcf9d653 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Mon, 7 Jul 2014 16:48:44 -0300 Subject: [PATCH 30/91] BLOCKS: Correct neighbor pointers in refine_block() for 2D case. If we refine the lowest block, which neighbor fields point to itself, we should point them to the proper children. Include this case in refine_block() for 2D. Signed-off-by: Grzegorz Kowal --- src/blocks.F90 | 220 ++++++++++++++++++++++++++++++++++++------------- 1 file changed, 164 insertions(+), 56 deletions(-) diff --git a/src/blocks.F90 b/src/blocks.F90 index 911bef4..87270d2 100644 --- a/src/blocks.F90 +++ b/src/blocks.F90 @@ -1579,84 +1579,136 @@ module blocks ! pointers of neighbors ! #if NDIMS == 2 +! child (1,1) pchild => pmeta%child(1)%ptr +! X if (associated(pmeta%edges(1,1,1)%ptr)) then pneigh => pmeta%edges(1,1,1)%ptr - pchild%edges(1,1,1)%ptr => pmeta%edges(1,1,1)%ptr - pchild%edges(2,1,1)%ptr => pmeta%edges(1,1,1)%ptr - pneigh%edges(1,2,1)%ptr => pchild - if (pneigh%level > pmeta%level) pneigh%edges(2,2,1)%ptr => pchild + if (pneigh%id == pmeta%id) then + pchild%edges(1,1,1)%ptr => pmeta%child(3)%ptr + pchild%edges(2,1,1)%ptr => pmeta%child(3)%ptr + else + pchild%edges(1,1,1)%ptr => pmeta%edges(1,1,1)%ptr + pchild%edges(2,1,1)%ptr => pmeta%edges(1,1,1)%ptr + pneigh%edges(1,2,1)%ptr => pchild + if (pneigh%level > pmeta%level) pneigh%edges(2,2,1)%ptr => pchild + end if end if pchild%edges(1,2,1)%ptr => pmeta%child(3)%ptr pchild%edges(2,2,1)%ptr => pmeta%child(3)%ptr +! Y if (associated(pmeta%edges(1,1,2)%ptr)) then pneigh => pmeta%edges(1,1,2)%ptr - pchild%edges(1,1,2)%ptr => pmeta%edges(1,1,2)%ptr - pchild%edges(1,2,2)%ptr => pmeta%edges(1,1,2)%ptr - pneigh%edges(2,1,2)%ptr => pchild - if (pneigh%level > pmeta%level) pneigh%edges(2,2,2)%ptr => pchild + if (pneigh%id == pmeta%id) then + pchild%edges(1,1,2)%ptr => pmeta%child(2)%ptr + pchild%edges(1,2,2)%ptr => pmeta%child(2)%ptr + else + pchild%edges(1,1,2)%ptr => pmeta%edges(1,1,2)%ptr + pchild%edges(1,2,2)%ptr => pmeta%edges(1,1,2)%ptr + pneigh%edges(2,1,2)%ptr => pchild + if (pneigh%level > pmeta%level) pneigh%edges(2,2,2)%ptr => pchild + end if end if pchild%edges(2,1,2)%ptr => pmeta%child(2)%ptr pchild%edges(2,2,2)%ptr => pmeta%child(2)%ptr +! child (2,1) pchild => pmeta%child(2)%ptr +! X if (associated(pmeta%edges(2,1,1)%ptr)) then pneigh => pmeta%edges(2,1,1)%ptr - pchild%edges(1,1,1)%ptr => pmeta%edges(2,1,1)%ptr - pchild%edges(2,1,1)%ptr => pmeta%edges(2,1,1)%ptr - pneigh%edges(2,2,1)%ptr => pchild - if (pneigh%level > pmeta%level) pneigh%edges(1,2,1)%ptr => pchild + if (pneigh%id == pmeta%id) then + pchild%edges(1,1,1)%ptr => pmeta%child(4)%ptr + pchild%edges(2,1,1)%ptr => pmeta%child(4)%ptr + else + pchild%edges(1,1,1)%ptr => pmeta%edges(2,1,1)%ptr + pchild%edges(2,1,1)%ptr => pmeta%edges(2,1,1)%ptr + pneigh%edges(2,2,1)%ptr => pchild + if (pneigh%level > pmeta%level) pneigh%edges(1,2,1)%ptr => pchild + end if end if pchild%edges(1,2,1)%ptr => pmeta%child(4)%ptr pchild%edges(2,2,1)%ptr => pmeta%child(4)%ptr +! Y pchild%edges(1,1,2)%ptr => pmeta%child(1)%ptr pchild%edges(1,2,2)%ptr => pmeta%child(1)%ptr if (associated(pmeta%edges(2,1,2)%ptr)) then pneigh => pmeta%edges(2,1,2)%ptr - pchild%edges(2,1,2)%ptr => pmeta%edges(2,1,2)%ptr - pchild%edges(2,2,2)%ptr => pmeta%edges(2,1,2)%ptr - pneigh%edges(1,1,2)%ptr => pchild - if (pneigh%level > pmeta%level) pneigh%edges(1,2,2)%ptr => pchild + if (pneigh%id == pmeta%id) then + pchild%edges(2,1,2)%ptr => pmeta%child(1)%ptr + pchild%edges(2,2,2)%ptr => pmeta%child(1)%ptr + else + pchild%edges(2,1,2)%ptr => pmeta%edges(2,1,2)%ptr + pchild%edges(2,2,2)%ptr => pmeta%edges(2,1,2)%ptr + pneigh%edges(1,1,2)%ptr => pchild + if (pneigh%level > pmeta%level) pneigh%edges(1,2,2)%ptr => pchild + end if end if +! child (1,2) pchild => pmeta%child(3)%ptr +! X pchild%edges(1,1,1)%ptr => pmeta%child(1)%ptr pchild%edges(2,1,1)%ptr => pmeta%child(1)%ptr if (associated(pmeta%edges(1,2,1)%ptr)) then pneigh => pmeta%edges(1,2,1)%ptr - pchild%edges(1,2,1)%ptr => pmeta%edges(1,2,1)%ptr - pchild%edges(2,2,1)%ptr => pmeta%edges(1,2,1)%ptr - pneigh%edges(1,1,1)%ptr => pchild - if (pneigh%level > pmeta%level) pneigh%edges(2,1,1)%ptr => pchild + if (pneigh%id == pmeta%id) then + pchild%edges(1,2,1)%ptr => pmeta%child(1)%ptr + pchild%edges(2,2,1)%ptr => pmeta%child(1)%ptr + else + pchild%edges(1,2,1)%ptr => pmeta%edges(1,2,1)%ptr + pchild%edges(2,2,1)%ptr => pmeta%edges(1,2,1)%ptr + pneigh%edges(1,1,1)%ptr => pchild + if (pneigh%level > pmeta%level) pneigh%edges(2,1,1)%ptr => pchild + end if end if +! Y if (associated(pmeta%edges(1,2,2)%ptr)) then pneigh => pmeta%edges(1,2,2)%ptr - pchild%edges(1,1,2)%ptr => pmeta%edges(1,2,2)%ptr - pchild%edges(1,2,2)%ptr => pmeta%edges(1,2,2)%ptr - pneigh%edges(2,2,2)%ptr => pchild - if (pneigh%level > pmeta%level) pneigh%edges(2,1,2)%ptr => pchild + if (pneigh%id == pmeta%id) then + pchild%edges(1,1,2)%ptr => pmeta%child(4)%ptr + pchild%edges(1,2,2)%ptr => pmeta%child(4)%ptr + else + pchild%edges(1,1,2)%ptr => pmeta%edges(1,2,2)%ptr + pchild%edges(1,2,2)%ptr => pmeta%edges(1,2,2)%ptr + pneigh%edges(2,2,2)%ptr => pchild + if (pneigh%level > pmeta%level) pneigh%edges(2,1,2)%ptr => pchild + end if end if pchild%edges(2,1,2)%ptr => pmeta%child(4)%ptr pchild%edges(2,2,2)%ptr => pmeta%child(4)%ptr +! child (2,2) pchild => pmeta%child(4)%ptr +! X pchild%edges(1,1,1)%ptr => pmeta%child(2)%ptr pchild%edges(2,1,1)%ptr => pmeta%child(2)%ptr if (associated(pmeta%edges(2,2,1)%ptr)) then pneigh => pmeta%edges(2,2,1)%ptr - pchild%edges(1,2,1)%ptr => pmeta%edges(2,2,1)%ptr - pchild%edges(2,2,1)%ptr => pmeta%edges(2,2,1)%ptr - pneigh%edges(2,1,1)%ptr => pchild - if (pneigh%level > pmeta%level) pneigh%edges(1,1,1)%ptr => pchild + if (pneigh%id == pmeta%id) then + pchild%edges(1,1,1)%ptr => pmeta%child(2)%ptr + pchild%edges(2,1,1)%ptr => pmeta%child(2)%ptr + else + pchild%edges(1,2,1)%ptr => pmeta%edges(2,2,1)%ptr + pchild%edges(2,2,1)%ptr => pmeta%edges(2,2,1)%ptr + pneigh%edges(2,1,1)%ptr => pchild + if (pneigh%level > pmeta%level) pneigh%edges(1,1,1)%ptr => pchild + end if end if +! Y pchild%edges(1,1,2)%ptr => pmeta%child(3)%ptr pchild%edges(1,2,2)%ptr => pmeta%child(3)%ptr if (associated(pmeta%edges(2,2,2)%ptr)) then pneigh => pmeta%edges(2,2,2)%ptr - pchild%edges(2,1,2)%ptr => pmeta%edges(2,2,2)%ptr - pchild%edges(2,2,2)%ptr => pmeta%edges(2,2,2)%ptr - pneigh%edges(1,2,2)%ptr => pchild - if (pneigh%level > pmeta%level) pneigh%edges(1,1,2)%ptr => pchild + if (pneigh%id == pmeta%id) then + pchild%edges(2,1,2)%ptr => pmeta%child(3)%ptr + pchild%edges(2,2,2)%ptr => pmeta%child(3)%ptr + else + pchild%edges(2,1,2)%ptr => pmeta%edges(2,2,2)%ptr + pchild%edges(2,2,2)%ptr => pmeta%edges(2,2,2)%ptr + pneigh%edges(1,2,2)%ptr => pchild + if (pneigh%level > pmeta%level) pneigh%edges(1,1,2)%ptr => pchild + end if end if #endif /* NDIMS == 2 */ @@ -1664,76 +1716,132 @@ module blocks ! corners if they lay at larger level ! #if NDIMS == 2 +! child (1,1) pchild => pmeta%child(1)%ptr + if (associated(pmeta%corners(1,1)%ptr)) then pneigh => pmeta%corners(1,1)%ptr - pchild%corners(1,1)%ptr => pmeta%corners(1,1)%ptr - pneigh%corners(2,2)%ptr => pchild + if (pneigh%id == pmeta%id) then + pchild%corners(1,1)%ptr => pmeta%child(4)%ptr + else + pchild%corners(1,1)%ptr => pmeta%corners(1,1)%ptr + pneigh%corners(2,2)%ptr => pchild + end if end if if (associated(pmeta%edges(2,1,1)%ptr)) then pneigh => pmeta%edges(2,1,1)%ptr - pchild%corners(2,1)%ptr => pmeta%edges(2,1,1)%ptr - if (pneigh%level > pmeta%level) pneigh%corners(1,2)%ptr => pchild + if (pneigh%id == pmeta%id) then + pchild%corners(2,1)%ptr => pmeta%child(4)%ptr + else + pchild%corners(2,1)%ptr => pmeta%edges(2,1,1)%ptr + if (pneigh%level > pmeta%level) pneigh%corners(1,2)%ptr => pchild + end if endif if (associated(pmeta%edges(1,2,2)%ptr)) then pneigh => pmeta%edges(1,2,2)%ptr - pchild%corners(1,2)%ptr => pmeta%edges(1,2,2)%ptr - if (pneigh%level > pmeta%level) pneigh%corners(2,1)%ptr => pchild + if (pneigh%id == pmeta%id) then + pchild%corners(2,1)%ptr => pmeta%child(4)%ptr + else + pchild%corners(1,2)%ptr => pmeta%edges(1,2,2)%ptr + if (pneigh%level > pmeta%level) pneigh%corners(2,1)%ptr => pchild + end if end if pchild%corners(2,2)%ptr => pmeta%child(4)%ptr +! child (2,1) pchild => pmeta%child(2)%ptr + if (associated(pmeta%edges(1,1,1)%ptr)) then pneigh => pmeta%edges(1,1,1)%ptr - pchild%corners(1,1)%ptr => pmeta%edges(1,1,1)%ptr - if (pneigh%level > pmeta%level) pneigh%corners(2,2)%ptr => pchild + if (pneigh%id == pmeta%id) then + pchild%corners(1,1)%ptr => pmeta%child(3)%ptr + else + pchild%corners(1,1)%ptr => pmeta%edges(1,1,1)%ptr + if (pneigh%level > pmeta%level) pneigh%corners(2,2)%ptr => pchild + end if end if if (associated(pmeta%corners(2,1)%ptr)) then pneigh => pmeta%corners(2,1)%ptr - pchild%corners(2,1)%ptr => pmeta%corners(2,1)%ptr - pneigh%corners(1,2)%ptr => pchild + if (pneigh%id == pmeta%id) then + pchild%corners(2,1)%ptr => pmeta%child(3)%ptr + else + pchild%corners(2,1)%ptr => pmeta%corners(2,1)%ptr + pneigh%corners(1,2)%ptr => pchild + end if end if pchild%corners(1,2)%ptr => pmeta%child(3)%ptr if (associated(pmeta%edges(2,2,2)%ptr)) then pneigh => pmeta%edges(2,2,2)%ptr - pchild%corners(2,2)%ptr => pmeta%edges(2,2,2)%ptr - if (pneigh%level > pmeta%level) pneigh%corners(1,1)%ptr => pchild + if (pneigh%id == pmeta%id) then + pchild%corners(2,2)%ptr => pmeta%child(3)%ptr + else + pchild%corners(2,2)%ptr => pmeta%edges(2,2,2)%ptr + if (pneigh%level > pmeta%level) pneigh%corners(1,1)%ptr => pchild + end if end if +! child (1,2) pchild => pmeta%child(3)%ptr + if (associated(pmeta%edges(1,1,2)%ptr)) then pneigh => pmeta%edges(1,1,2)%ptr - pchild%corners(1,1)%ptr => pmeta%edges(1,1,2)%ptr - if (pneigh%level > pmeta%level) pneigh%corners(2,2)%ptr => pchild + if (pneigh%id == pmeta%id) then + pchild%corners(1,1)%ptr => pmeta%child(2)%ptr + else + pchild%corners(1,1)%ptr => pmeta%edges(1,1,2)%ptr + if (pneigh%level > pmeta%level) pneigh%corners(2,2)%ptr => pchild + end if end if pchild%corners(2,1)%ptr => pmeta%child(2)%ptr if (associated(pmeta%corners(1,2)%ptr)) then pneigh => pmeta%corners(1,2)%ptr - pchild%corners(1,2)%ptr => pmeta%corners(1,2)%ptr - pneigh%corners(2,1)%ptr => pchild + if (pneigh%id == pmeta%id) then + pchild%corners(1,2)%ptr => pmeta%child(2)%ptr + else + pchild%corners(1,2)%ptr => pmeta%corners(1,2)%ptr + pneigh%corners(2,1)%ptr => pchild + end if end if if (associated(pmeta%edges(2,2,1)%ptr)) then pneigh => pmeta%edges(2,2,1)%ptr - pchild%corners(2,2)%ptr => pmeta%edges(2,2,1)%ptr - if (pneigh%level > pmeta%level) pneigh%corners(1,1)%ptr => pchild + if (pneigh%id == pmeta%id) then + pchild%corners(2,2)%ptr => pmeta%child(2)%ptr + else + pchild%corners(2,2)%ptr => pmeta%edges(2,2,1)%ptr + if (pneigh%level > pmeta%level) pneigh%corners(1,1)%ptr => pchild + end if end if +! child (2,2) pchild => pmeta%child(4)%ptr + pchild%corners(1,1)%ptr => pmeta%child(1)%ptr if (associated(pmeta%edges(2,1,2)%ptr)) then pneigh => pmeta%edges(2,1,2)%ptr - pchild%corners(2,1)%ptr => pmeta%edges(2,1,2)%ptr - if (pneigh%level > pmeta%level) pneigh%corners(1,2)%ptr => pchild + if (pneigh%id == pmeta%id) then + pchild%corners(2,1)%ptr => pmeta%child(1)%ptr + else + pchild%corners(2,1)%ptr => pmeta%edges(2,1,2)%ptr + if (pneigh%level > pmeta%level) pneigh%corners(1,2)%ptr => pchild + end if end if if (associated(pmeta%edges(1,2,1)%ptr)) then pneigh => pmeta%edges(1,2,1)%ptr - pchild%corners(1,2)%ptr => pmeta%edges(1,2,1)%ptr - if (pneigh%level > pmeta%level) pneigh%corners(2,1)%ptr => pchild + if (pneigh%id == pmeta%id) then + pchild%corners(1,2)%ptr => pmeta%child(1)%ptr + else + pchild%corners(1,2)%ptr => pmeta%edges(1,2,1)%ptr + if (pneigh%level > pmeta%level) pneigh%corners(2,1)%ptr => pchild + end if end if if (associated(pmeta%corners(2,2)%ptr)) then pneigh => pmeta%corners(2,2)%ptr - pchild%corners(2,2)%ptr => pmeta%corners(2,2)%ptr - pneigh%corners(1,1)%ptr => pchild + if (pneigh%id == pmeta%id) then + pchild%corners(2,2)%ptr => pmeta%child(1)%ptr + else + pchild%corners(2,2)%ptr => pmeta%corners(2,2)%ptr + pneigh%corners(1,1)%ptr => pchild + end if end if #endif /* NDIMS == 2 */ From 1abca59d6a7a63c53481c6909b25f4380fb4c5bf Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Mon, 7 Jul 2014 17:11:54 -0300 Subject: [PATCH 31/91] BLOCKS: Update edge and corner pointers in derefine_block(). Signed-off-by: Grzegorz Kowal --- src/blocks.F90 | 140 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 140 insertions(+) diff --git a/src/blocks.F90 b/src/blocks.F90 index 87270d2..e74d026 100644 --- a/src/blocks.F90 +++ b/src/blocks.F90 @@ -2249,6 +2249,146 @@ module blocks end if +! update edge neighbor pointers of the parent +! +#if NDIMS == 2 +! child (1,1) + pchild => pmeta%child(1)%ptr +! X + if (associated(pchild%edges(1,1,1)%ptr)) then + pneigh => pchild%edges(1,1,1)%ptr + if (pneigh%id == pmeta%child(3)%ptr%id) then + pmeta%edges(1,1,1)%ptr => pmeta + else + pmeta%edges(1,1,1)%ptr => pchild%edges(1,1,1)%ptr + end if + end if +! Y + if (associated(pchild%edges(1,1,2)%ptr)) then + pneigh => pchild%edges(1,1,2)%ptr + if (pneigh%id == pmeta%child(2)%ptr%id) then + pmeta%edges(1,1,2)%ptr => pmeta + else + pmeta%edges(1,1,2)%ptr => pchild%edges(1,1,2)%ptr + end if + end if + +! child (2,1) + pchild => pmeta%child(2)%ptr +! X + if (associated(pchild%edges(2,1,1)%ptr)) then + pneigh => pchild%edges(2,1,1)%ptr + if (pneigh%id == pmeta%child(4)%ptr%id) then + pmeta%edges(2,1,1)%ptr => pmeta + else + pmeta%edges(2,1,1)%ptr => pchild%edges(2,1,1)%ptr + end if + end if +! Y + if (associated(pchild%edges(2,1,2)%ptr)) then + pneigh => pchild%edges(2,1,2)%ptr + if (pneigh%id == pmeta%child(1)%ptr%id) then + pmeta%edges(2,1,2)%ptr => pmeta + else + pmeta%edges(2,1,2)%ptr => pchild%edges(2,1,2)%ptr + end if + end if + +! child (1,2) + pchild => pmeta%child(3)%ptr +! X + if (associated(pchild%edges(1,2,1)%ptr)) then + pneigh => pchild%edges(1,2,1)%ptr + if (pneigh%id == pmeta%child(1)%ptr%id) then + pmeta%edges(1,2,1)%ptr => pmeta + else + pmeta%edges(1,2,1)%ptr => pchild%edges(1,2,1)%ptr + end if + end if +! Y + if (associated(pchild%edges(1,2,2)%ptr)) then + pneigh => pchild%edges(1,2,2)%ptr + if (pneigh%id == pmeta%child(4)%ptr%id) then + pmeta%edges(1,2,2)%ptr => pmeta + else + pmeta%edges(1,2,2)%ptr => pchild%edges(1,2,2)%ptr + end if + end if + +! child (2,2) + pchild => pmeta%child(4)%ptr +! X + if (associated(pchild%edges(2,2,1)%ptr)) then + pneigh => pchild%edges(2,2,1)%ptr + if (pneigh%id == pmeta%child(2)%ptr%id) then + pmeta%edges(2,2,1)%ptr => pmeta + else + pmeta%edges(2,2,1)%ptr => pchild%edges(2,2,1)%ptr + end if + end if +! Y + if (associated(pchild%edges(2,2,2)%ptr)) then + pneigh => pchild%edges(2,2,2)%ptr + if (pneigh%id == pmeta%child(3)%ptr%id) then + pmeta%edges(2,2,2)%ptr => pmeta + else + pmeta%edges(2,2,2)%ptr => pchild%edges(2,2,2)%ptr + end if + end if +#endif /* NDIMS == 2 */ + +! update corner neighbor pointers of the parent +! +#if NDIMS == 2 +! corner (1,1) + pchild => pmeta%child(1)%ptr + + if (associated(pchild%corners(1,1)%ptr)) then + pneigh => pchild%corners(1,1)%ptr + if (pneigh%id == pmeta%child(4)%ptr%id) then + pmeta%corners(1,1)%ptr => pmeta + else + pmeta%corners(1,1)%ptr => pchild%corners(1,1)%ptr + end if + end if + +! corner (2,1) + pchild => pmeta%child(2)%ptr + + if (associated(pchild%corners(2,1)%ptr)) then + pneigh => pchild%corners(2,1)%ptr + if (pneigh%id == pmeta%child(3)%ptr%id) then + pmeta%corners(2,1)%ptr => pmeta + else + pmeta%corners(2,1)%ptr => pchild%corners(2,1)%ptr + end if + end if + +! corner (1,2) + pchild => pmeta%child(3)%ptr + + if (associated(pchild%corners(1,2)%ptr)) then + pneigh => pchild%corners(1,2)%ptr + if (pneigh%id == pmeta%child(2)%ptr%id) then + pmeta%corners(1,2)%ptr => pmeta + else + pmeta%corners(1,2)%ptr => pchild%corners(1,2)%ptr + end if + end if + +! corner (2,2) + pchild => pmeta%child(4)%ptr + + if (associated(pchild%corners(2,2)%ptr)) then + pneigh => pchild%corners(2,2)%ptr + if (pneigh%id == pmeta%child(1)%ptr%id) then + pmeta%corners(2,2)%ptr => pmeta + else + pmeta%corners(2,2)%ptr => pchild%corners(2,2)%ptr + end if + end if +#endif /* NDIMS == 2 */ + ! iterate over dimensions, sides, and faces ! do i = 1, ndims From ac4c7742dbd177b8c943599a2dc7a57cc46814f5 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Sun, 13 Jul 2014 09:17:05 -0300 Subject: [PATCH 32/91] BLOCKS: Update face neighbor pointers in refine_block() in 3D case. Signed-off-by: Grzegorz Kowal --- src/blocks.F90 | 629 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 629 insertions(+) diff --git a/src/blocks.F90 b/src/blocks.F90 index e74d026..297a9d2 100644 --- a/src/blocks.F90 +++ b/src/blocks.F90 @@ -1575,6 +1575,635 @@ module blocks end do ! nchildren +#if NDIMS == 3 +! update face neighbor pointers (only in 3D) and the corresponding neighbor +! face pointers +! +! child (1,1,1) + pchild => pmeta%child(1)%ptr +! X + if (associated(pmeta%faces(1,1,1,1)%ptr)) then + pneigh => pmeta%faces(1,1,1,1)%ptr + if (pneigh%id == pmeta%id) then + pchild%faces(1,1,1,1)%ptr => pmeta%child(2)%ptr + pchild%faces(1,2,1,1)%ptr => pmeta%child(2)%ptr + pchild%faces(1,1,2,1)%ptr => pmeta%child(2)%ptr + pchild%faces(1,2,2,1)%ptr => pmeta%child(2)%ptr + else + pchild%faces(1,1,1,1)%ptr => pmeta%faces(1,1,1,1)%ptr + pchild%faces(1,2,1,1)%ptr => pmeta%faces(1,1,1,1)%ptr + pchild%faces(1,1,2,1)%ptr => pmeta%faces(1,1,1,1)%ptr + pchild%faces(1,2,2,1)%ptr => pmeta%faces(1,1,1,1)%ptr + pneigh%faces(2,1,1,1)%ptr => pchild + if (pneigh%level > pmeta%level) then + pneigh%faces(2,2,1,1)%ptr => pchild + pneigh%faces(2,1,2,1)%ptr => pchild + pneigh%faces(2,2,2,1)%ptr => pchild + end if + end if + end if + pchild%faces(2,1,1,1)%ptr => pmeta%child(2)%ptr + pchild%faces(2,2,1,1)%ptr => pmeta%child(2)%ptr + pchild%faces(2,1,2,1)%ptr => pmeta%child(2)%ptr + pchild%faces(2,2,2,1)%ptr => pmeta%child(2)%ptr +! Y + if (associated(pmeta%faces(1,1,1,2)%ptr)) then + pneigh => pmeta%faces(1,1,1,2)%ptr + if (pneigh%id == pmeta%id) then + pchild%faces(1,1,1,2)%ptr => pmeta%child(3)%ptr + pchild%faces(2,1,1,2)%ptr => pmeta%child(3)%ptr + pchild%faces(1,1,2,2)%ptr => pmeta%child(3)%ptr + pchild%faces(2,1,2,2)%ptr => pmeta%child(3)%ptr + else + pchild%faces(1,1,1,2)%ptr => pmeta%faces(1,1,1,2)%ptr + pchild%faces(2,1,1,2)%ptr => pmeta%faces(1,1,1,2)%ptr + pchild%faces(1,1,2,2)%ptr => pmeta%faces(1,1,1,2)%ptr + pchild%faces(2,1,2,2)%ptr => pmeta%faces(1,1,1,2)%ptr + pneigh%faces(1,2,1,2)%ptr => pchild + if (pneigh%level > pmeta%level) then + pneigh%faces(2,2,1,2)%ptr => pchild + pneigh%faces(1,2,2,2)%ptr => pchild + pneigh%faces(2,2,2,2)%ptr => pchild + end if + end if + end if + pchild%faces(1,2,1,2)%ptr => pmeta%child(3)%ptr + pchild%faces(2,2,1,2)%ptr => pmeta%child(3)%ptr + pchild%faces(1,2,2,2)%ptr => pmeta%child(3)%ptr + pchild%faces(2,2,2,2)%ptr => pmeta%child(3)%ptr +! Z + if (associated(pmeta%faces(1,1,1,3)%ptr)) then + pneigh => pmeta%faces(1,1,1,3)%ptr + if (pneigh%id == pmeta%id) then + pchild%faces(1,1,1,3)%ptr => pmeta%child(5)%ptr + pchild%faces(2,1,1,3)%ptr => pmeta%child(5)%ptr + pchild%faces(1,1,2,3)%ptr => pmeta%child(5)%ptr + pchild%faces(2,1,2,3)%ptr => pmeta%child(5)%ptr + else + pchild%faces(1,1,1,3)%ptr => pmeta%faces(1,1,1,3)%ptr + pchild%faces(2,1,1,3)%ptr => pmeta%faces(1,1,1,3)%ptr + pchild%faces(1,2,1,3)%ptr => pmeta%faces(1,1,1,3)%ptr + pchild%faces(2,2,1,3)%ptr => pmeta%faces(1,1,1,3)%ptr + pneigh%faces(1,1,2,3)%ptr => pchild + if (pneigh%level > pmeta%level) then + pneigh%faces(2,1,2,3)%ptr => pchild + pneigh%faces(1,2,2,3)%ptr => pchild + pneigh%faces(2,2,2,3)%ptr => pchild + end if + end if + end if + pchild%faces(1,1,2,3)%ptr => pmeta%child(5)%ptr + pchild%faces(2,1,2,3)%ptr => pmeta%child(5)%ptr + pchild%faces(1,2,2,3)%ptr => pmeta%child(5)%ptr + pchild%faces(2,2,2,3)%ptr => pmeta%child(5)%ptr + +! child (2,1,1) + pchild => pmeta%child(2)%ptr +! X + pchild%faces(1,1,1,1)%ptr => pmeta%child(1)%ptr + pchild%faces(1,2,1,1)%ptr => pmeta%child(1)%ptr + pchild%faces(1,1,2,1)%ptr => pmeta%child(1)%ptr + pchild%faces(1,2,2,1)%ptr => pmeta%child(1)%ptr + if (associated(pmeta%faces(2,1,1,1)%ptr)) then + pneigh => pmeta%faces(2,1,1,1)%ptr + if (pneigh%id == pmeta%id) then + pchild%faces(2,1,1,1)%ptr => pmeta%child(1)%ptr + pchild%faces(2,2,1,1)%ptr => pmeta%child(1)%ptr + pchild%faces(2,1,2,1)%ptr => pmeta%child(1)%ptr + pchild%faces(2,2,2,1)%ptr => pmeta%child(1)%ptr + else + pchild%faces(2,1,1,1)%ptr => pmeta%faces(2,1,1,1)%ptr + pchild%faces(2,2,1,1)%ptr => pmeta%faces(2,1,1,1)%ptr + pchild%faces(2,1,2,1)%ptr => pmeta%faces(2,1,1,1)%ptr + pchild%faces(2,2,2,1)%ptr => pmeta%faces(2,1,1,1)%ptr + pneigh%faces(1,1,1,1)%ptr => pchild + if (pneigh%level > pmeta%level) then + pneigh%faces(1,2,1,1)%ptr => pchild + pneigh%faces(1,1,2,1)%ptr => pchild + pneigh%faces(1,2,2,1)%ptr => pchild + end if + end if + end if +! Y + if (associated(pmeta%faces(2,1,1,2)%ptr)) then + pneigh => pmeta%faces(2,1,1,2)%ptr + if (pneigh%id == pmeta%id) then + pchild%faces(1,1,1,2)%ptr => pmeta%child(4)%ptr + pchild%faces(2,1,1,2)%ptr => pmeta%child(4)%ptr + pchild%faces(1,1,2,2)%ptr => pmeta%child(4)%ptr + pchild%faces(2,1,2,2)%ptr => pmeta%child(4)%ptr + else + pchild%faces(1,1,1,2)%ptr => pmeta%faces(2,1,1,2)%ptr + pchild%faces(2,1,1,2)%ptr => pmeta%faces(2,1,1,2)%ptr + pchild%faces(1,1,2,2)%ptr => pmeta%faces(2,1,1,2)%ptr + pchild%faces(2,1,2,2)%ptr => pmeta%faces(2,1,1,2)%ptr + pneigh%faces(2,2,1,2)%ptr => pchild + if (pneigh%level > pmeta%level) then + pneigh%faces(1,2,1,2)%ptr => pchild + pneigh%faces(1,2,2,2)%ptr => pchild + pneigh%faces(2,2,2,2)%ptr => pchild + end if + end if + end if + pchild%faces(1,2,1,2)%ptr => pmeta%child(4)%ptr + pchild%faces(2,2,1,2)%ptr => pmeta%child(4)%ptr + pchild%faces(1,2,2,2)%ptr => pmeta%child(4)%ptr + pchild%faces(2,2,2,2)%ptr => pmeta%child(4)%ptr +! Z + if (associated(pmeta%faces(2,1,1,3)%ptr)) then + pneigh => pmeta%faces(2,1,1,3)%ptr + if (pneigh%id == pmeta%id) then + pchild%faces(1,1,1,3)%ptr => pmeta%child(6)%ptr + pchild%faces(2,1,1,3)%ptr => pmeta%child(6)%ptr + pchild%faces(1,1,2,3)%ptr => pmeta%child(6)%ptr + pchild%faces(2,1,2,3)%ptr => pmeta%child(6)%ptr + else + pchild%faces(1,1,1,3)%ptr => pmeta%faces(2,1,1,3)%ptr + pchild%faces(2,1,1,3)%ptr => pmeta%faces(2,1,1,3)%ptr + pchild%faces(1,2,1,3)%ptr => pmeta%faces(2,1,1,3)%ptr + pchild%faces(2,2,1,3)%ptr => pmeta%faces(2,1,1,3)%ptr + pneigh%faces(2,1,2,3)%ptr => pchild + if (pneigh%level > pmeta%level) then + pneigh%faces(1,1,2,3)%ptr => pchild + pneigh%faces(1,2,2,3)%ptr => pchild + pneigh%faces(2,2,2,3)%ptr => pchild + end if + end if + end if + pchild%faces(1,1,2,3)%ptr => pmeta%child(6)%ptr + pchild%faces(2,1,2,3)%ptr => pmeta%child(6)%ptr + pchild%faces(1,2,2,3)%ptr => pmeta%child(6)%ptr + pchild%faces(2,2,2,3)%ptr => pmeta%child(6)%ptr + +! child (1,2,1) + pchild => pmeta%child(3)%ptr +! X + if (associated(pmeta%faces(1,2,1,1)%ptr)) then + pneigh => pmeta%faces(1,2,1,1)%ptr + if (pneigh%id == pmeta%id) then + pchild%faces(1,1,1,1)%ptr => pmeta%child(4)%ptr + pchild%faces(1,2,1,1)%ptr => pmeta%child(4)%ptr + pchild%faces(1,1,2,1)%ptr => pmeta%child(4)%ptr + pchild%faces(1,2,2,1)%ptr => pmeta%child(4)%ptr + else + pchild%faces(1,1,1,1)%ptr => pmeta%faces(1,2,1,1)%ptr + pchild%faces(1,2,1,1)%ptr => pmeta%faces(1,2,1,1)%ptr + pchild%faces(1,1,2,1)%ptr => pmeta%faces(1,2,1,1)%ptr + pchild%faces(1,2,2,1)%ptr => pmeta%faces(1,2,1,1)%ptr + pneigh%faces(2,2,1,1)%ptr => pchild + if (pneigh%level > pmeta%level) then + pneigh%faces(2,1,1,1)%ptr => pchild + pneigh%faces(2,1,2,1)%ptr => pchild + pneigh%faces(2,2,2,1)%ptr => pchild + end if + end if + end if + pchild%faces(2,1,1,1)%ptr => pmeta%child(4)%ptr + pchild%faces(2,2,1,1)%ptr => pmeta%child(4)%ptr + pchild%faces(2,1,2,1)%ptr => pmeta%child(4)%ptr + pchild%faces(2,2,2,1)%ptr => pmeta%child(4)%ptr +! Y + pchild%faces(1,1,1,2)%ptr => pmeta%child(1)%ptr + pchild%faces(2,1,1,2)%ptr => pmeta%child(1)%ptr + pchild%faces(1,1,2,2)%ptr => pmeta%child(1)%ptr + pchild%faces(2,1,2,2)%ptr => pmeta%child(1)%ptr + if (associated(pmeta%faces(1,2,1,2)%ptr)) then + pneigh => pmeta%faces(1,2,1,2)%ptr + if (pneigh%id == pmeta%id) then + pchild%faces(1,2,1,2)%ptr => pmeta%child(1)%ptr + pchild%faces(2,2,1,2)%ptr => pmeta%child(1)%ptr + pchild%faces(1,2,2,2)%ptr => pmeta%child(1)%ptr + pchild%faces(2,2,2,2)%ptr => pmeta%child(1)%ptr + else + pchild%faces(1,2,1,2)%ptr => pmeta%faces(1,2,1,2)%ptr + pchild%faces(2,2,1,2)%ptr => pmeta%faces(1,2,1,2)%ptr + pchild%faces(1,2,2,2)%ptr => pmeta%faces(1,2,1,2)%ptr + pchild%faces(2,2,2,2)%ptr => pmeta%faces(1,2,1,2)%ptr + pneigh%faces(1,1,1,2)%ptr => pchild + if (pneigh%level > pmeta%level) then + pneigh%faces(2,1,1,2)%ptr => pchild + pneigh%faces(1,1,2,2)%ptr => pchild + pneigh%faces(2,1,2,2)%ptr => pchild + end if + end if + end if +! Z + if (associated(pmeta%faces(1,2,1,3)%ptr)) then + pneigh => pmeta%faces(1,2,1,3)%ptr + if (pneigh%id == pmeta%id) then + pchild%faces(1,1,1,3)%ptr => pmeta%child(7)%ptr + pchild%faces(2,1,1,3)%ptr => pmeta%child(7)%ptr + pchild%faces(1,1,2,3)%ptr => pmeta%child(7)%ptr + pchild%faces(2,1,2,3)%ptr => pmeta%child(7)%ptr + else + pchild%faces(1,1,1,3)%ptr => pmeta%faces(1,2,1,3)%ptr + pchild%faces(2,1,1,3)%ptr => pmeta%faces(1,2,1,3)%ptr + pchild%faces(1,2,1,3)%ptr => pmeta%faces(1,2,1,3)%ptr + pchild%faces(2,2,1,3)%ptr => pmeta%faces(1,2,1,3)%ptr + pneigh%faces(1,2,2,3)%ptr => pchild + if (pneigh%level > pmeta%level) then + pneigh%faces(1,1,2,3)%ptr => pchild + pneigh%faces(2,1,2,3)%ptr => pchild + pneigh%faces(2,2,2,3)%ptr => pchild + end if + end if + end if + pchild%faces(1,1,2,3)%ptr => pmeta%child(7)%ptr + pchild%faces(2,1,2,3)%ptr => pmeta%child(7)%ptr + pchild%faces(1,2,2,3)%ptr => pmeta%child(7)%ptr + pchild%faces(2,2,2,3)%ptr => pmeta%child(7)%ptr + +! child (2,2,1) + pchild => pmeta%child(4)%ptr +! X + pchild%faces(1,1,1,1)%ptr => pmeta%child(3)%ptr + pchild%faces(1,2,1,1)%ptr => pmeta%child(3)%ptr + pchild%faces(1,1,2,1)%ptr => pmeta%child(3)%ptr + pchild%faces(1,2,2,1)%ptr => pmeta%child(3)%ptr + if (associated(pmeta%faces(2,2,1,1)%ptr)) then + pneigh => pmeta%faces(2,2,1,1)%ptr + if (pneigh%id == pmeta%id) then + pchild%faces(2,1,1,1)%ptr => pmeta%child(3)%ptr + pchild%faces(2,2,1,1)%ptr => pmeta%child(3)%ptr + pchild%faces(2,1,2,1)%ptr => pmeta%child(3)%ptr + pchild%faces(2,2,2,1)%ptr => pmeta%child(3)%ptr + else + pchild%faces(2,1,1,1)%ptr => pmeta%faces(2,2,1,1)%ptr + pchild%faces(2,2,1,1)%ptr => pmeta%faces(2,2,1,1)%ptr + pchild%faces(2,1,2,1)%ptr => pmeta%faces(2,2,1,1)%ptr + pchild%faces(2,2,2,1)%ptr => pmeta%faces(2,2,1,1)%ptr + pneigh%faces(1,2,1,1)%ptr => pchild + if (pneigh%level > pmeta%level) then + pneigh%faces(1,1,1,1)%ptr => pchild + pneigh%faces(1,1,2,1)%ptr => pchild + pneigh%faces(1,2,2,1)%ptr => pchild + end if + end if + end if +! Y + pchild%faces(1,1,1,2)%ptr => pmeta%child(2)%ptr + pchild%faces(2,1,1,2)%ptr => pmeta%child(2)%ptr + pchild%faces(1,1,2,2)%ptr => pmeta%child(2)%ptr + pchild%faces(2,1,2,2)%ptr => pmeta%child(2)%ptr + if (associated(pmeta%faces(2,2,1,2)%ptr)) then + pneigh => pmeta%faces(2,2,1,2)%ptr + if (pneigh%id == pmeta%id) then + pchild%faces(1,2,1,2)%ptr => pmeta%child(2)%ptr + pchild%faces(2,2,1,2)%ptr => pmeta%child(2)%ptr + pchild%faces(1,2,2,2)%ptr => pmeta%child(2)%ptr + pchild%faces(2,2,2,2)%ptr => pmeta%child(2)%ptr + else + pchild%faces(1,2,1,2)%ptr => pmeta%faces(2,2,1,2)%ptr + pchild%faces(2,2,1,2)%ptr => pmeta%faces(2,2,1,2)%ptr + pchild%faces(1,2,2,2)%ptr => pmeta%faces(2,2,1,2)%ptr + pchild%faces(2,2,2,2)%ptr => pmeta%faces(2,2,1,2)%ptr + pneigh%faces(2,1,1,2)%ptr => pchild + if (pneigh%level > pmeta%level) then + pneigh%faces(1,1,1,2)%ptr => pchild + pneigh%faces(1,1,2,2)%ptr => pchild + pneigh%faces(2,1,2,2)%ptr => pchild + end if + end if + end if +! Z + if (associated(pmeta%faces(2,2,1,3)%ptr)) then + pneigh => pmeta%faces(2,2,1,3)%ptr + if (pneigh%id == pmeta%id) then + pchild%faces(1,1,1,3)%ptr => pmeta%child(8)%ptr + pchild%faces(2,1,1,3)%ptr => pmeta%child(8)%ptr + pchild%faces(1,1,2,3)%ptr => pmeta%child(8)%ptr + pchild%faces(2,1,2,3)%ptr => pmeta%child(8)%ptr + else + pchild%faces(1,1,1,3)%ptr => pmeta%faces(2,2,1,3)%ptr + pchild%faces(2,1,1,3)%ptr => pmeta%faces(2,2,1,3)%ptr + pchild%faces(1,2,1,3)%ptr => pmeta%faces(2,2,1,3)%ptr + pchild%faces(2,2,1,3)%ptr => pmeta%faces(2,2,1,3)%ptr + pneigh%faces(2,2,2,3)%ptr => pchild + if (pneigh%level > pmeta%level) then + pneigh%faces(1,1,2,3)%ptr => pchild + pneigh%faces(2,1,2,3)%ptr => pchild + pneigh%faces(1,2,2,3)%ptr => pchild + end if + end if + end if + pchild%faces(1,1,2,3)%ptr => pmeta%child(8)%ptr + pchild%faces(2,1,2,3)%ptr => pmeta%child(8)%ptr + pchild%faces(1,2,2,3)%ptr => pmeta%child(8)%ptr + pchild%faces(2,2,2,3)%ptr => pmeta%child(8)%ptr + +! child (1,1,2) + pchild => pmeta%child(5)%ptr +! X + if (associated(pmeta%faces(1,1,2,1)%ptr)) then + pneigh => pmeta%faces(1,1,2,1)%ptr + if (pneigh%id == pmeta%id) then + pchild%faces(1,1,1,1)%ptr => pmeta%child(6)%ptr + pchild%faces(1,2,1,1)%ptr => pmeta%child(6)%ptr + pchild%faces(1,1,2,1)%ptr => pmeta%child(6)%ptr + pchild%faces(1,2,2,1)%ptr => pmeta%child(6)%ptr + else + pchild%faces(1,1,1,1)%ptr => pmeta%faces(1,1,2,1)%ptr + pchild%faces(1,2,1,1)%ptr => pmeta%faces(1,1,2,1)%ptr + pchild%faces(1,1,2,1)%ptr => pmeta%faces(1,1,2,1)%ptr + pchild%faces(1,2,2,1)%ptr => pmeta%faces(1,1,2,1)%ptr + pneigh%faces(2,1,2,1)%ptr => pchild + if (pneigh%level > pmeta%level) then + pneigh%faces(2,1,1,1)%ptr => pchild + pneigh%faces(2,2,1,1)%ptr => pchild + pneigh%faces(2,2,2,1)%ptr => pchild + end if + end if + end if + pchild%faces(2,1,1,1)%ptr => pmeta%child(6)%ptr + pchild%faces(2,2,1,1)%ptr => pmeta%child(6)%ptr + pchild%faces(2,1,2,1)%ptr => pmeta%child(6)%ptr + pchild%faces(2,2,2,1)%ptr => pmeta%child(6)%ptr +! Y + if (associated(pmeta%faces(1,1,2,2)%ptr)) then + pneigh => pmeta%faces(1,1,2,2)%ptr + if (pneigh%id == pmeta%id) then + pchild%faces(1,1,1,2)%ptr => pmeta%child(7)%ptr + pchild%faces(2,1,1,2)%ptr => pmeta%child(7)%ptr + pchild%faces(1,1,2,2)%ptr => pmeta%child(7)%ptr + pchild%faces(2,1,2,2)%ptr => pmeta%child(7)%ptr + else + pchild%faces(1,1,1,2)%ptr => pmeta%faces(1,1,2,2)%ptr + pchild%faces(2,1,1,2)%ptr => pmeta%faces(1,1,2,2)%ptr + pchild%faces(1,1,2,2)%ptr => pmeta%faces(1,1,2,2)%ptr + pchild%faces(2,1,2,2)%ptr => pmeta%faces(1,1,2,2)%ptr + pneigh%faces(1,2,2,2)%ptr => pchild + if (pneigh%level > pmeta%level) then + pneigh%faces(1,2,1,2)%ptr => pchild + pneigh%faces(2,2,1,2)%ptr => pchild + pneigh%faces(2,2,2,2)%ptr => pchild + end if + end if + end if + pchild%faces(1,2,1,2)%ptr => pmeta%child(7)%ptr + pchild%faces(2,2,1,2)%ptr => pmeta%child(7)%ptr + pchild%faces(1,2,2,2)%ptr => pmeta%child(7)%ptr + pchild%faces(2,2,2,2)%ptr => pmeta%child(7)%ptr +! Z + pchild%faces(1,1,1,3)%ptr => pmeta%child(1)%ptr + pchild%faces(2,1,1,3)%ptr => pmeta%child(1)%ptr + pchild%faces(1,2,1,3)%ptr => pmeta%child(1)%ptr + pchild%faces(2,2,1,3)%ptr => pmeta%child(1)%ptr + if (associated(pmeta%faces(1,1,2,3)%ptr)) then + pneigh => pmeta%faces(1,1,2,3)%ptr + if (pneigh%id == pmeta%id) then + pchild%faces(1,1,2,3)%ptr => pmeta%child(1)%ptr + pchild%faces(2,1,2,3)%ptr => pmeta%child(1)%ptr + pchild%faces(1,2,2,3)%ptr => pmeta%child(1)%ptr + pchild%faces(2,2,2,3)%ptr => pmeta%child(1)%ptr + else + pchild%faces(1,1,2,3)%ptr => pmeta%faces(1,1,2,3)%ptr + pchild%faces(2,1,2,3)%ptr => pmeta%faces(1,1,2,3)%ptr + pchild%faces(1,2,2,3)%ptr => pmeta%faces(1,1,2,3)%ptr + pchild%faces(2,2,2,3)%ptr => pmeta%faces(1,1,2,3)%ptr + pneigh%faces(1,1,1,3)%ptr => pchild + if (pneigh%level > pmeta%level) then + pneigh%faces(2,1,1,3)%ptr => pchild + pneigh%faces(1,2,1,3)%ptr => pchild + pneigh%faces(2,2,1,3)%ptr => pchild + end if + end if + end if + +! child (2,1,2) + pchild => pmeta%child(6)%ptr +! X + pchild%faces(1,1,1,1)%ptr => pmeta%child(5)%ptr + pchild%faces(1,2,1,1)%ptr => pmeta%child(5)%ptr + pchild%faces(1,1,2,1)%ptr => pmeta%child(5)%ptr + pchild%faces(1,2,2,1)%ptr => pmeta%child(5)%ptr + if (associated(pmeta%faces(2,1,2,1)%ptr)) then + pneigh => pmeta%faces(2,1,2,1)%ptr + if (pneigh%id == pmeta%id) then + pchild%faces(2,1,1,1)%ptr => pmeta%child(5)%ptr + pchild%faces(2,2,1,1)%ptr => pmeta%child(5)%ptr + pchild%faces(2,1,2,1)%ptr => pmeta%child(5)%ptr + pchild%faces(2,2,2,1)%ptr => pmeta%child(5)%ptr + else + pchild%faces(2,1,1,1)%ptr => pmeta%faces(2,1,2,1)%ptr + pchild%faces(2,2,1,1)%ptr => pmeta%faces(2,1,2,1)%ptr + pchild%faces(2,1,2,1)%ptr => pmeta%faces(2,1,2,1)%ptr + pchild%faces(2,2,2,1)%ptr => pmeta%faces(2,1,2,1)%ptr + pneigh%faces(1,1,2,1)%ptr => pchild + if (pneigh%level > pmeta%level) then + pneigh%faces(1,1,1,1)%ptr => pchild + pneigh%faces(1,2,1,1)%ptr => pchild + pneigh%faces(1,2,2,1)%ptr => pchild + end if + end if + end if +! Y + if (associated(pmeta%faces(2,2,1,2)%ptr)) then + pneigh => pmeta%faces(2,2,1,2)%ptr + if (pneigh%id == pmeta%id) then + pchild%faces(1,1,1,2)%ptr => pmeta%child(8)%ptr + pchild%faces(2,1,1,2)%ptr => pmeta%child(8)%ptr + pchild%faces(1,1,2,2)%ptr => pmeta%child(8)%ptr + pchild%faces(2,1,2,2)%ptr => pmeta%child(8)%ptr + else + pchild%faces(1,1,1,2)%ptr => pmeta%faces(2,2,1,2)%ptr + pchild%faces(2,1,1,2)%ptr => pmeta%faces(2,2,1,2)%ptr + pchild%faces(1,1,2,2)%ptr => pmeta%faces(2,2,1,2)%ptr + pchild%faces(2,1,2,2)%ptr => pmeta%faces(2,2,1,2)%ptr + pneigh%faces(2,2,2,2)%ptr => pchild + if (pneigh%level > pmeta%level) then + pneigh%faces(1,2,1,2)%ptr => pchild + pneigh%faces(2,2,1,2)%ptr => pchild + pneigh%faces(1,2,2,2)%ptr => pchild + end if + end if + end if + pchild%faces(1,2,1,2)%ptr => pmeta%child(8)%ptr + pchild%faces(2,2,1,2)%ptr => pmeta%child(8)%ptr + pchild%faces(1,2,2,2)%ptr => pmeta%child(8)%ptr + pchild%faces(2,2,2,2)%ptr => pmeta%child(8)%ptr +! Z + pchild%faces(1,1,1,3)%ptr => pmeta%child(2)%ptr + pchild%faces(2,1,1,3)%ptr => pmeta%child(2)%ptr + pchild%faces(1,2,1,3)%ptr => pmeta%child(2)%ptr + pchild%faces(2,2,1,3)%ptr => pmeta%child(2)%ptr + if (associated(pmeta%faces(2,1,2,3)%ptr)) then + pneigh => pmeta%faces(2,1,2,3)%ptr + if (pneigh%id == pmeta%id) then + pchild%faces(1,1,2,3)%ptr => pmeta%child(2)%ptr + pchild%faces(2,1,2,3)%ptr => pmeta%child(2)%ptr + pchild%faces(1,2,2,3)%ptr => pmeta%child(2)%ptr + pchild%faces(2,2,2,3)%ptr => pmeta%child(2)%ptr + else + pchild%faces(1,1,2,3)%ptr => pmeta%faces(2,1,2,3)%ptr + pchild%faces(2,1,2,3)%ptr => pmeta%faces(2,1,2,3)%ptr + pchild%faces(1,2,2,3)%ptr => pmeta%faces(2,1,2,3)%ptr + pchild%faces(2,2,2,3)%ptr => pmeta%faces(2,1,2,3)%ptr + pneigh%faces(2,1,1,3)%ptr => pchild + if (pneigh%level > pmeta%level) then + pneigh%faces(1,1,1,3)%ptr => pchild + pneigh%faces(1,2,1,3)%ptr => pchild + pneigh%faces(2,2,1,3)%ptr => pchild + end if + end if + end if + +! child (1,2,2) + pchild => pmeta%child(7)%ptr +! X + if (associated(pmeta%faces(1,2,2,1)%ptr)) then + pneigh => pmeta%faces(1,2,2,1)%ptr + if (pneigh%id == pmeta%id) then + pchild%faces(1,1,1,1)%ptr => pmeta%child(8)%ptr + pchild%faces(1,2,1,1)%ptr => pmeta%child(8)%ptr + pchild%faces(1,1,2,1)%ptr => pmeta%child(8)%ptr + pchild%faces(1,2,2,1)%ptr => pmeta%child(8)%ptr + else + pchild%faces(1,1,1,1)%ptr => pmeta%faces(1,2,2,1)%ptr + pchild%faces(1,2,1,1)%ptr => pmeta%faces(1,2,2,1)%ptr + pchild%faces(1,1,2,1)%ptr => pmeta%faces(1,2,2,1)%ptr + pchild%faces(1,2,2,1)%ptr => pmeta%faces(1,2,2,1)%ptr + pneigh%faces(2,2,2,1)%ptr => pchild + if (pneigh%level > pmeta%level) then + pneigh%faces(2,1,1,1)%ptr => pchild + pneigh%faces(2,2,1,1)%ptr => pchild + pneigh%faces(2,1,2,1)%ptr => pchild + end if + end if + end if + pchild%faces(2,1,1,1)%ptr => pmeta%child(8)%ptr + pchild%faces(2,2,1,1)%ptr => pmeta%child(8)%ptr + pchild%faces(2,1,2,1)%ptr => pmeta%child(8)%ptr + pchild%faces(2,2,2,1)%ptr => pmeta%child(8)%ptr +! Y + pchild%faces(1,1,1,2)%ptr => pmeta%child(5)%ptr + pchild%faces(2,1,1,2)%ptr => pmeta%child(5)%ptr + pchild%faces(1,1,2,2)%ptr => pmeta%child(5)%ptr + pchild%faces(2,1,2,2)%ptr => pmeta%child(5)%ptr + if (associated(pmeta%faces(1,2,2,2)%ptr)) then + pneigh => pmeta%faces(1,2,2,2)%ptr + if (pneigh%id == pmeta%id) then + pchild%faces(1,2,1,2)%ptr => pmeta%child(5)%ptr + pchild%faces(2,2,1,2)%ptr => pmeta%child(5)%ptr + pchild%faces(1,2,2,2)%ptr => pmeta%child(5)%ptr + pchild%faces(2,2,2,2)%ptr => pmeta%child(5)%ptr + else + pchild%faces(1,2,1,2)%ptr => pmeta%faces(1,2,2,2)%ptr + pchild%faces(2,2,1,2)%ptr => pmeta%faces(1,2,2,2)%ptr + pchild%faces(1,2,2,2)%ptr => pmeta%faces(1,2,2,2)%ptr + pchild%faces(2,2,2,2)%ptr => pmeta%faces(1,2,2,2)%ptr + pneigh%faces(1,1,2,2)%ptr => pchild + if (pneigh%level > pmeta%level) then + pneigh%faces(1,1,1,2)%ptr => pchild + pneigh%faces(2,1,1,2)%ptr => pchild + pneigh%faces(2,1,2,2)%ptr => pchild + end if + end if + end if +! Z + pchild%faces(1,1,1,3)%ptr => pmeta%child(3)%ptr + pchild%faces(2,1,1,3)%ptr => pmeta%child(3)%ptr + pchild%faces(1,2,1,3)%ptr => pmeta%child(3)%ptr + pchild%faces(2,2,1,3)%ptr => pmeta%child(3)%ptr + if (associated(pmeta%faces(1,1,1,3)%ptr)) then + pneigh => pmeta%faces(1,1,1,3)%ptr + if (pneigh%id == pmeta%id) then + pchild%faces(1,1,2,3)%ptr => pmeta%child(3)%ptr + pchild%faces(2,1,2,3)%ptr => pmeta%child(3)%ptr + pchild%faces(1,2,2,3)%ptr => pmeta%child(3)%ptr + pchild%faces(2,2,2,3)%ptr => pmeta%child(3)%ptr + else + pchild%faces(1,1,2,3)%ptr => pmeta%faces(1,1,1,3)%ptr + pchild%faces(2,1,2,3)%ptr => pmeta%faces(1,1,1,3)%ptr + pchild%faces(1,2,2,3)%ptr => pmeta%faces(1,1,1,3)%ptr + pchild%faces(2,2,2,3)%ptr => pmeta%faces(1,1,1,3)%ptr + pneigh%faces(1,2,1,3)%ptr => pchild + if (pneigh%level > pmeta%level) then + pneigh%faces(1,1,1,3)%ptr => pchild + pneigh%faces(2,1,1,3)%ptr => pchild + pneigh%faces(2,2,1,3)%ptr => pchild + end if + end if + end if + +! child (2,2,2) + pchild => pmeta%child(8)%ptr +! X + pchild%faces(1,1,1,1)%ptr => pmeta%child(7)%ptr + pchild%faces(1,2,1,1)%ptr => pmeta%child(7)%ptr + pchild%faces(1,1,2,1)%ptr => pmeta%child(7)%ptr + pchild%faces(1,2,2,1)%ptr => pmeta%child(7)%ptr + if (associated(pmeta%faces(2,2,2,1)%ptr)) then + pneigh => pmeta%faces(2,2,2,1)%ptr + if (pneigh%id == pmeta%id) then + pchild%faces(2,1,1,1)%ptr => pmeta%child(7)%ptr + pchild%faces(2,2,1,1)%ptr => pmeta%child(7)%ptr + pchild%faces(2,1,2,1)%ptr => pmeta%child(7)%ptr + pchild%faces(2,2,2,1)%ptr => pmeta%child(7)%ptr + else + pchild%faces(2,1,1,1)%ptr => pmeta%faces(2,2,2,1)%ptr + pchild%faces(2,2,1,1)%ptr => pmeta%faces(2,2,2,1)%ptr + pchild%faces(2,1,2,1)%ptr => pmeta%faces(2,2,2,1)%ptr + pchild%faces(2,2,2,1)%ptr => pmeta%faces(2,2,2,1)%ptr + pneigh%faces(1,2,2,1)%ptr => pchild + if (pneigh%level > pmeta%level) then + pneigh%faces(1,1,1,1)%ptr => pchild + pneigh%faces(1,2,1,1)%ptr => pchild + pneigh%faces(1,1,2,1)%ptr => pchild + end if + end if + end if +! Y + pchild%faces(1,1,1,2)%ptr => pmeta%child(6)%ptr + pchild%faces(2,1,1,2)%ptr => pmeta%child(6)%ptr + pchild%faces(1,1,2,2)%ptr => pmeta%child(6)%ptr + pchild%faces(2,1,2,2)%ptr => pmeta%child(6)%ptr + if (associated(pmeta%faces(2,2,2,2)%ptr)) then + pneigh => pmeta%faces(2,2,2,2)%ptr + if (pneigh%id == pmeta%id) then + pchild%faces(1,2,1,2)%ptr => pmeta%child(6)%ptr + pchild%faces(2,2,1,2)%ptr => pmeta%child(6)%ptr + pchild%faces(1,2,2,2)%ptr => pmeta%child(6)%ptr + pchild%faces(2,2,2,2)%ptr => pmeta%child(6)%ptr + else + pchild%faces(1,2,1,2)%ptr => pmeta%faces(2,2,2,2)%ptr + pchild%faces(2,2,1,2)%ptr => pmeta%faces(2,2,2,2)%ptr + pchild%faces(1,2,2,2)%ptr => pmeta%faces(2,2,2,2)%ptr + pchild%faces(2,2,2,2)%ptr => pmeta%faces(2,2,2,2)%ptr + pneigh%faces(2,1,2,2)%ptr => pchild + if (pneigh%level > pmeta%level) then + pneigh%faces(1,1,1,2)%ptr => pchild + pneigh%faces(2,1,1,2)%ptr => pchild + pneigh%faces(1,1,2,2)%ptr => pchild + end if + end if + end if +! Z + pchild%faces(1,1,1,3)%ptr => pmeta%child(4)%ptr + pchild%faces(2,1,1,3)%ptr => pmeta%child(4)%ptr + pchild%faces(1,2,1,3)%ptr => pmeta%child(4)%ptr + pchild%faces(2,2,1,3)%ptr => pmeta%child(4)%ptr + if (associated(pmeta%faces(2,2,2,3)%ptr)) then + pneigh => pmeta%faces(2,2,2,3)%ptr + if (pneigh%id == pmeta%id) then + pchild%faces(1,1,2,3)%ptr => pmeta%child(4)%ptr + pchild%faces(2,1,2,3)%ptr => pmeta%child(4)%ptr + pchild%faces(1,2,2,3)%ptr => pmeta%child(4)%ptr + pchild%faces(2,2,2,3)%ptr => pmeta%child(4)%ptr + else + pchild%faces(1,1,2,3)%ptr => pmeta%faces(2,2,2,3)%ptr + pchild%faces(2,1,2,3)%ptr => pmeta%faces(2,2,2,3)%ptr + pchild%faces(1,2,2,3)%ptr => pmeta%faces(2,2,2,3)%ptr + pchild%faces(2,2,2,3)%ptr => pmeta%faces(2,2,2,3)%ptr + pneigh%faces(2,2,1,3)%ptr => pchild + if (pneigh%level > pmeta%level) then + pneigh%faces(1,1,1,3)%ptr => pchild + pneigh%faces(2,1,1,3)%ptr => pchild + pneigh%faces(1,2,1,3)%ptr => pchild + end if + end if + end if +#endif /* NDIMS == 3 */ + ! update edge neighbor pointers of children, and the corresponding edge ! pointers of neighbors ! From 9d2b829179bc950c797c8539897c272a32f996ed Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Mon, 14 Jul 2014 13:25:30 -0300 Subject: [PATCH 33/91] EVOLUTION: Add check for NaNs in variables if DEBUG=Y. Signed-off-by: Grzegorz Kowal --- src/evolution.F90 | 85 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 85 insertions(+) diff --git a/src/evolution.F90 b/src/evolution.F90 index 7941ade..4fea276 100644 --- a/src/evolution.F90 +++ b/src/evolution.F90 @@ -257,6 +257,12 @@ module evolution ! call boundary_variables() +#ifdef DEBUG +! check variables for NaNs +! + call check_variables() +#endif /* DEBUG */ + ! set all meta blocks to be updated ! call set_blocks_update(.true.) @@ -818,6 +824,85 @@ module evolution !------------------------------------------------------------------------------- ! end subroutine update_variables +#ifdef DEBUG +! +!=============================================================================== +! +! subroutine CHECK_VARIABLES: +! -------------------------- +! +! Subroutine iterates over all data blocks and converts the conservative +! variables to their primitive representation. +! +! +!=============================================================================== +! + subroutine check_variables() + +! include external procedures +! + use coordinates , only : im, jm, km + use equations , only : nv, pvars, cvars + +! include external variables +! + use blocks , only : block_meta, list_meta + use blocks , only : block_data, list_data + +! local variables are not implicit by default +! + implicit none + +! local variables +! + integer :: i, j, k, p + +! local pointers +! + type(block_meta), pointer :: pmeta + type(block_data), pointer :: pdata +! +!------------------------------------------------------------------------------- +! +! associate the pointer with the first block on the data block list +! + pdata => list_data + +! iterate over all data blocks +! + do while (associated(pdata)) + +! associate pmeta with the corresponding meta block +! + pmeta => pdata%meta + +! check if there are NaNs in primitive variables +! + do k = 1, km + do j = 1, jm + do i = 1, im + do p = 1, nv + if (isnan(pdata%u(p,i,j,k))) then + print *, 'U NaN:', cvars(p), pdata%meta%id, i, j, k + end if + if (isnan(pdata%q(p,i,j,k))) then + print *, 'Q NaN:', pvars(p), pdata%meta%id, i, j, k + end if + end do ! p = 1, nv + end do ! i = 1, im + end do ! j = 1, jm + end do ! k = 1, km + +! assign pointer to the next block +! + pdata => pdata%next + + end do + +!------------------------------------------------------------------------------- +! + end subroutine check_variables +#endif /* DEBUG */ !=============================================================================== ! From c74e63162c14e36b32aaff16364efc3f49c0eb2f Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 15 Jul 2014 07:15:18 -0300 Subject: [PATCH 34/91] BLOCKS: Separate children and neighbor pointer update in refine_block(). In order to avoid inconsistencies in the face, edge and corner neighbor pointer update in refine_block(), like updating the neighbour's pointer in the middle while it might be still needed in another pointer update, separate the children and neighbor pointers update. First, update the face, edge and corner neighbor pointers for the newly created children only, and when this step is done, update the neighbor' face, edge and corner pointers. Signed-off-by: Grzegorz Kowal --- src/blocks.F90 | 169 +++++++++++++++++++++++++++++++++++++++---------- 1 file changed, 136 insertions(+), 33 deletions(-) diff --git a/src/blocks.F90 b/src/blocks.F90 index 297a9d2..e2a8dc7 100644 --- a/src/blocks.F90 +++ b/src/blocks.F90 @@ -2204,8 +2204,7 @@ module blocks end if #endif /* NDIMS == 3 */ -! update edge neighbor pointers of children, and the corresponding edge -! pointers of neighbors +! update edge neighbor pointers of children ! #if NDIMS == 2 ! child (1,1) @@ -2219,8 +2218,6 @@ module blocks else pchild%edges(1,1,1)%ptr => pmeta%edges(1,1,1)%ptr pchild%edges(2,1,1)%ptr => pmeta%edges(1,1,1)%ptr - pneigh%edges(1,2,1)%ptr => pchild - if (pneigh%level > pmeta%level) pneigh%edges(2,2,1)%ptr => pchild end if end if pchild%edges(1,2,1)%ptr => pmeta%child(3)%ptr @@ -2234,8 +2231,6 @@ module blocks else pchild%edges(1,1,2)%ptr => pmeta%edges(1,1,2)%ptr pchild%edges(1,2,2)%ptr => pmeta%edges(1,1,2)%ptr - pneigh%edges(2,1,2)%ptr => pchild - if (pneigh%level > pmeta%level) pneigh%edges(2,2,2)%ptr => pchild end if end if pchild%edges(2,1,2)%ptr => pmeta%child(2)%ptr @@ -2252,8 +2247,6 @@ module blocks else pchild%edges(1,1,1)%ptr => pmeta%edges(2,1,1)%ptr pchild%edges(2,1,1)%ptr => pmeta%edges(2,1,1)%ptr - pneigh%edges(2,2,1)%ptr => pchild - if (pneigh%level > pmeta%level) pneigh%edges(1,2,1)%ptr => pchild end if end if pchild%edges(1,2,1)%ptr => pmeta%child(4)%ptr @@ -2269,8 +2262,6 @@ module blocks else pchild%edges(2,1,2)%ptr => pmeta%edges(2,1,2)%ptr pchild%edges(2,2,2)%ptr => pmeta%edges(2,1,2)%ptr - pneigh%edges(1,1,2)%ptr => pchild - if (pneigh%level > pmeta%level) pneigh%edges(1,2,2)%ptr => pchild end if end if @@ -2287,8 +2278,6 @@ module blocks else pchild%edges(1,2,1)%ptr => pmeta%edges(1,2,1)%ptr pchild%edges(2,2,1)%ptr => pmeta%edges(1,2,1)%ptr - pneigh%edges(1,1,1)%ptr => pchild - if (pneigh%level > pmeta%level) pneigh%edges(2,1,1)%ptr => pchild end if end if ! Y @@ -2300,8 +2289,6 @@ module blocks else pchild%edges(1,1,2)%ptr => pmeta%edges(1,2,2)%ptr pchild%edges(1,2,2)%ptr => pmeta%edges(1,2,2)%ptr - pneigh%edges(2,2,2)%ptr => pchild - if (pneigh%level > pmeta%level) pneigh%edges(2,1,2)%ptr => pchild end if end if pchild%edges(2,1,2)%ptr => pmeta%child(4)%ptr @@ -2315,13 +2302,11 @@ module blocks if (associated(pmeta%edges(2,2,1)%ptr)) then pneigh => pmeta%edges(2,2,1)%ptr if (pneigh%id == pmeta%id) then - pchild%edges(1,1,1)%ptr => pmeta%child(2)%ptr - pchild%edges(2,1,1)%ptr => pmeta%child(2)%ptr + pchild%edges(1,2,1)%ptr => pmeta%child(2)%ptr + pchild%edges(2,2,1)%ptr => pmeta%child(2)%ptr else pchild%edges(1,2,1)%ptr => pmeta%edges(2,2,1)%ptr pchild%edges(2,2,1)%ptr => pmeta%edges(2,2,1)%ptr - pneigh%edges(2,1,1)%ptr => pchild - if (pneigh%level > pmeta%level) pneigh%edges(1,1,1)%ptr => pchild end if end if ! Y @@ -2335,8 +2320,6 @@ module blocks else pchild%edges(2,1,2)%ptr => pmeta%edges(2,2,2)%ptr pchild%edges(2,2,2)%ptr => pmeta%edges(2,2,2)%ptr - pneigh%edges(1,2,2)%ptr => pchild - if (pneigh%level > pmeta%level) pneigh%edges(1,1,2)%ptr => pchild end if end if #endif /* NDIMS == 2 */ @@ -2354,7 +2337,6 @@ module blocks pchild%corners(1,1)%ptr => pmeta%child(4)%ptr else pchild%corners(1,1)%ptr => pmeta%corners(1,1)%ptr - pneigh%corners(2,2)%ptr => pchild end if end if if (associated(pmeta%edges(2,1,1)%ptr)) then @@ -2363,16 +2345,14 @@ module blocks pchild%corners(2,1)%ptr => pmeta%child(4)%ptr else pchild%corners(2,1)%ptr => pmeta%edges(2,1,1)%ptr - if (pneigh%level > pmeta%level) pneigh%corners(1,2)%ptr => pchild end if endif if (associated(pmeta%edges(1,2,2)%ptr)) then pneigh => pmeta%edges(1,2,2)%ptr if (pneigh%id == pmeta%id) then - pchild%corners(2,1)%ptr => pmeta%child(4)%ptr + pchild%corners(1,2)%ptr => pmeta%child(4)%ptr else pchild%corners(1,2)%ptr => pmeta%edges(1,2,2)%ptr - if (pneigh%level > pmeta%level) pneigh%corners(2,1)%ptr => pchild end if end if pchild%corners(2,2)%ptr => pmeta%child(4)%ptr @@ -2386,7 +2366,6 @@ module blocks pchild%corners(1,1)%ptr => pmeta%child(3)%ptr else pchild%corners(1,1)%ptr => pmeta%edges(1,1,1)%ptr - if (pneigh%level > pmeta%level) pneigh%corners(2,2)%ptr => pchild end if end if if (associated(pmeta%corners(2,1)%ptr)) then @@ -2395,7 +2374,6 @@ module blocks pchild%corners(2,1)%ptr => pmeta%child(3)%ptr else pchild%corners(2,1)%ptr => pmeta%corners(2,1)%ptr - pneigh%corners(1,2)%ptr => pchild end if end if pchild%corners(1,2)%ptr => pmeta%child(3)%ptr @@ -2405,7 +2383,6 @@ module blocks pchild%corners(2,2)%ptr => pmeta%child(3)%ptr else pchild%corners(2,2)%ptr => pmeta%edges(2,2,2)%ptr - if (pneigh%level > pmeta%level) pneigh%corners(1,1)%ptr => pchild end if end if @@ -2418,7 +2395,6 @@ module blocks pchild%corners(1,1)%ptr => pmeta%child(2)%ptr else pchild%corners(1,1)%ptr => pmeta%edges(1,1,2)%ptr - if (pneigh%level > pmeta%level) pneigh%corners(2,2)%ptr => pchild end if end if pchild%corners(2,1)%ptr => pmeta%child(2)%ptr @@ -2428,7 +2404,6 @@ module blocks pchild%corners(1,2)%ptr => pmeta%child(2)%ptr else pchild%corners(1,2)%ptr => pmeta%corners(1,2)%ptr - pneigh%corners(2,1)%ptr => pchild end if end if if (associated(pmeta%edges(2,2,1)%ptr)) then @@ -2437,7 +2412,6 @@ module blocks pchild%corners(2,2)%ptr => pmeta%child(2)%ptr else pchild%corners(2,2)%ptr => pmeta%edges(2,2,1)%ptr - if (pneigh%level > pmeta%level) pneigh%corners(1,1)%ptr => pchild end if end if @@ -2451,7 +2425,6 @@ module blocks pchild%corners(2,1)%ptr => pmeta%child(1)%ptr else pchild%corners(2,1)%ptr => pmeta%edges(2,1,2)%ptr - if (pneigh%level > pmeta%level) pneigh%corners(1,2)%ptr => pchild end if end if if (associated(pmeta%edges(1,2,1)%ptr)) then @@ -2460,7 +2433,6 @@ module blocks pchild%corners(1,2)%ptr => pmeta%child(1)%ptr else pchild%corners(1,2)%ptr => pmeta%edges(1,2,1)%ptr - if (pneigh%level > pmeta%level) pneigh%corners(2,1)%ptr => pchild end if end if if (associated(pmeta%corners(2,2)%ptr)) then @@ -2469,11 +2441,142 @@ module blocks pchild%corners(2,2)%ptr => pmeta%child(1)%ptr else pchild%corners(2,2)%ptr => pmeta%corners(2,2)%ptr - pneigh%corners(1,1)%ptr => pchild end if end if #endif /* NDIMS == 2 */ +! update neighbor's edge pointers +! +#if NDIMS == 2 +! child (1,1) + pchild => pmeta%child(1)%ptr +! X + if (associated(pchild%edges(1,1,1)%ptr)) then + pneigh => pchild%edges(1,1,1)%ptr + pneigh%edges(1,2,1)%ptr => pchild + if (pneigh%level == pchild%level) pneigh%edges(2,2,1)%ptr => pchild + end if +! Y + if (associated(pchild%edges(1,1,2)%ptr)) then + pneigh => pchild%edges(1,1,2)%ptr + pneigh%edges(2,1,2)%ptr => pchild + if (pneigh%level == pchild%level) pneigh%edges(2,2,2)%ptr => pchild + end if + +! child (2,1) + pchild => pmeta%child(2)%ptr +! X + if (associated(pchild%edges(2,1,1)%ptr)) then + pneigh => pchild%edges(2,1,1)%ptr + pneigh%edges(2,2,1)%ptr => pchild + if (pneigh%level == pchild%level) pneigh%edges(1,2,1)%ptr => pchild + end if +! Y + if (associated(pchild%edges(2,1,2)%ptr)) then + pneigh => pchild%edges(2,1,2)%ptr + pneigh%edges(1,1,2)%ptr => pchild + if (pneigh%level == pchild%level) pneigh%edges(1,2,2)%ptr => pchild + end if + +! child (1,2) + pchild => pmeta%child(3)%ptr +! X + if (associated(pchild%edges(1,2,1)%ptr)) then + pneigh => pchild%edges(1,2,1)%ptr + pneigh%edges(1,1,1)%ptr => pchild + if (pneigh%level == pchild%level) pneigh%edges(2,1,1)%ptr => pchild + end if +! Y + if (associated(pchild%edges(1,2,2)%ptr)) then + pneigh => pchild%edges(1,2,2)%ptr + pneigh%edges(2,2,2)%ptr => pchild + if (pneigh%level == pchild%level) pneigh%edges(2,1,2)%ptr => pchild + end if + +! child (2,2) + pchild => pmeta%child(4)%ptr +! X + if (associated(pchild%edges(2,2,1)%ptr)) then + pneigh => pchild%edges(2,2,1)%ptr + pneigh%edges(2,1,1)%ptr => pchild + if (pneigh%level == pchild%level) pneigh%edges(1,1,1)%ptr => pchild + end if +! Y + if (associated(pchild%edges(2,2,2)%ptr)) then + pneigh => pchild%edges(2,2,2)%ptr + pneigh%edges(1,2,2)%ptr => pchild + if (pneigh%level == pchild%level) pneigh%edges(1,1,2)%ptr => pchild + end if +#endif /* NDIMS == 2 */ + +! update neighbor's corner pointers +! +#if NDIMS == 2 +! child (1,1) + pchild => pmeta%child(1)%ptr + + if (associated(pmeta%corners(1,1)%ptr)) then + pneigh => pmeta%corners(1,1)%ptr + pneigh%corners(2,2)%ptr => pchild + end if + if (associated(pmeta%edges(2,1,1)%ptr)) then + pneigh => pmeta%edges(2,1,1)%ptr + if (pneigh%level > pmeta%level) pneigh%corners(1,2)%ptr => pchild + endif + if (associated(pmeta%edges(1,2,2)%ptr)) then + pneigh => pmeta%edges(1,2,2)%ptr + if (pneigh%level > pmeta%level) pneigh%corners(2,1)%ptr => pchild + end if + +! child (2,1) + pchild => pmeta%child(2)%ptr + + if (associated(pmeta%edges(1,1,1)%ptr)) then + pneigh => pmeta%edges(1,1,1)%ptr + if (pneigh%level > pmeta%level) pneigh%corners(2,2)%ptr => pchild + end if + if (associated(pmeta%corners(2,1)%ptr)) then + pneigh => pmeta%corners(2,1)%ptr + pneigh%corners(1,2)%ptr => pchild + end if + if (associated(pmeta%edges(2,2,2)%ptr)) then + pneigh => pmeta%edges(2,2,2)%ptr + if (pneigh%level > pmeta%level) pneigh%corners(1,1)%ptr => pchild + end if + +! child (1,2) + pchild => pmeta%child(3)%ptr + + if (associated(pmeta%edges(1,1,2)%ptr)) then + pneigh => pmeta%edges(1,1,2)%ptr + if (pneigh%level > pmeta%level) pneigh%corners(2,2)%ptr => pchild + end if + if (associated(pmeta%corners(1,2)%ptr)) then + pneigh => pmeta%corners(1,2)%ptr + pneigh%corners(2,1)%ptr => pchild + end if + if (associated(pmeta%edges(2,2,1)%ptr)) then + pneigh => pmeta%edges(2,2,1)%ptr + if (pneigh%level > pmeta%level) pneigh%corners(1,1)%ptr => pchild + end if + +! child (2,2) + pchild => pmeta%child(4)%ptr + + if (associated(pmeta%edges(2,1,2)%ptr)) then + pneigh => pmeta%edges(2,1,2)%ptr + if (pneigh%level > pmeta%level) pneigh%corners(1,2)%ptr => pchild + end if + if (associated(pmeta%edges(1,2,1)%ptr)) then + pneigh => pmeta%edges(1,2,1)%ptr + if (pneigh%level > pmeta%level) pneigh%corners(2,1)%ptr => pchild + end if + if (associated(pmeta%corners(2,2)%ptr)) then + pneigh => pmeta%corners(2,2)%ptr + pneigh%corners(1,1)%ptr => pchild + end if +#endif /* NDIMS == 2 */ + !! ASSIGN PROPER NEIGHBORS FOR THE CHILDREN IN THE INTERIOR OF THE PARENT BLOCK !! ! iterate over faces and update the interior of the block From d238a6ef45083330d55b0087061a6bc29c4dcfa0 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 15 Jul 2014 07:24:10 -0300 Subject: [PATCH 35/91] BLOCKS: Update neighbors' pointer in derefine_block() in 2D. During the derefinement process, we first update the face, edge, and corner neighbor pointer of the parent block. When this step is done, we update the corresponsing pointers of the neighbors. Signed-off-by: Grzegorz Kowal --- src/blocks.F90 | 160 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 160 insertions(+) diff --git a/src/blocks.F90 b/src/blocks.F90 index e2a8dc7..7bd94fd 100644 --- a/src/blocks.F90 +++ b/src/blocks.F90 @@ -3121,6 +3121,166 @@ module blocks end if #endif /* NDIMS == 2 */ +! update neighbor's edge pointers +! +#if NDIMS == 2 +! corner (1,1) +! X + if (associated(pmeta%edges(1,1,1)%ptr)) then + pneigh => pmeta%edges(1,1,1)%ptr + pneigh%edges(1,2,1)%ptr => pmeta + if (pneigh%level > pmeta%level) pneigh%edges(2,2,1)%ptr => pmeta + end if +! Y + if (associated(pmeta%edges(1,1,2)%ptr)) then + pneigh => pmeta%edges(1,1,2)%ptr + pneigh%edges(2,1,2)%ptr => pmeta + if (pneigh%level > pmeta%level) pneigh%edges(2,2,2)%ptr => pmeta + end if + +! child (2,1) +! X + if (associated(pmeta%edges(2,1,1)%ptr)) then + pneigh => pmeta%edges(2,1,1)%ptr + pneigh%edges(2,2,1)%ptr => pmeta + if (pneigh%level > pmeta%level) pneigh%edges(1,2,1)%ptr => pmeta + end if +! Y + if (associated(pmeta%edges(2,1,2)%ptr)) then + pneigh => pmeta%edges(2,1,2)%ptr + pneigh%edges(1,1,2)%ptr => pmeta + if (pneigh%level > pmeta%level) pneigh%edges(1,2,2)%ptr => pmeta + end if + +! child (1,2) +! X + if (associated(pmeta%edges(1,2,1)%ptr)) then + pneigh => pmeta%edges(1,2,1)%ptr + pneigh%edges(1,1,1)%ptr => pmeta + if (pneigh%level > pmeta%level) pneigh%edges(2,1,1)%ptr => pmeta + end if +! Y + if (associated(pmeta%edges(1,2,2)%ptr)) then + pneigh => pmeta%edges(1,2,2)%ptr + pneigh%edges(2,2,2)%ptr => pmeta + if (pneigh%level > pmeta%level) pneigh%edges(2,1,2)%ptr => pmeta + end if + +! child (2,2) +! X + if (associated(pmeta%edges(2,2,1)%ptr)) then + pneigh => pmeta%edges(2,2,1)%ptr + pneigh%edges(2,1,1)%ptr => pmeta + if (pneigh%level > pmeta%level) pneigh%edges(1,1,1)%ptr => pmeta + end if +! Y + if (associated(pmeta%edges(2,2,2)%ptr)) then + pneigh => pmeta%edges(2,2,2)%ptr + pneigh%edges(1,2,2)%ptr => pmeta + if (pneigh%level > pmeta%level) pneigh%edges(1,1,2)%ptr => pmeta + end if +#endif /* NDIMS == 2 */ + +! update neighbor's corner pointers +! +#if NDIMS == 2 +! corner (1,1) + pchild => pmeta%child(1)%ptr + + if (associated(pchild%corners(1,1)%ptr)) then + pneigh => pchild%corners(1,1)%ptr + pneigh%corners(2,2)%ptr => pmeta + end if + if (associated(pchild%corners(2,1)%ptr)) then + pneigh => pchild%corners(2,1)%ptr + if (pneigh%level == pchild%level) then + if (pneigh%id /= pmeta%child(4)%ptr%id) then + pneigh%corners(1,2)%ptr => pmeta + end if + end if + end if + if (associated(pchild%corners(1,2)%ptr)) then + pneigh => pchild%corners(1,2)%ptr + if (pneigh%level == pchild%level) then + if (pneigh%id /= pmeta%child(4)%ptr%id) then + pneigh%corners(2,1)%ptr => pmeta + end if + end if + end if + +! corner (2,1) + pchild => pmeta%child(2)%ptr + + if (associated(pchild%corners(1,1)%ptr)) then + pneigh => pchild%corners(1,1)%ptr + if (pneigh%level == pchild%level) then + if (pneigh%id /= pmeta%child(3)%ptr%id) then + pneigh%corners(2,2)%ptr => pmeta + end if + end if + end if + if (associated(pchild%corners(2,1)%ptr)) then + pneigh => pchild%corners(2,1)%ptr + pneigh%corners(1,2)%ptr => pmeta + end if + if (associated(pchild%corners(2,2)%ptr)) then + pneigh => pchild%corners(2,2)%ptr + if (pneigh%level == pchild%level) then + if (pneigh%id /= pmeta%child(3)%ptr%id) then + pneigh%corners(1,1)%ptr => pmeta + end if + end if + end if + +! corner (1,2) + pchild => pmeta%child(3)%ptr + + if (associated(pchild%corners(1,1)%ptr)) then + pneigh => pchild%corners(1,1)%ptr + if (pneigh%level == pchild%level) then + if (pneigh%id /= pmeta%child(2)%ptr%id) then + pneigh%corners(2,2)%ptr => pmeta + end if + end if + end if + if (associated(pchild%corners(1,2)%ptr)) then + pneigh => pchild%corners(1,2)%ptr + pneigh%corners(2,1)%ptr => pmeta + end if + if (associated(pchild%corners(2,2)%ptr)) then + pneigh => pchild%corners(2,2)%ptr + if (pneigh%level == pchild%level) then + if (pneigh%id /= pmeta%child(2)%ptr%id) then + pneigh%corners(1,1)%ptr => pmeta + end if + end if + end if + +! corner (2,2) + pchild => pmeta%child(4)%ptr + + if (associated(pchild%corners(2,1)%ptr)) then + pneigh => pchild%corners(2,1)%ptr + if (pneigh%level == pchild%level) then + if (pneigh%id /= pmeta%child(1)%ptr%id) then + pneigh%corners(1,2)%ptr => pmeta + end if + end if + end if + if (associated(pchild%corners(1,2)%ptr)) then + pneigh => pchild%corners(1,2)%ptr + if (pneigh%level == pchild%level) then + if (pneigh%id /= pmeta%child(1)%ptr%id) then + pneigh%corners(2,1)%ptr => pmeta + end if + end if + end if + if (associated(pchild%corners(2,2)%ptr)) then + pneigh => pchild%corners(2,2)%ptr + pneigh%corners(1,1)%ptr => pmeta + end if +#endif /* NDIMS == 2 */ + ! iterate over dimensions, sides, and faces ! do i = 1, ndims From 9cb8f52725e77bfef545cd74ea850faea10ff97a Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 15 Jul 2014 07:27:25 -0300 Subject: [PATCH 36/91] DOMAINS: Associate face, edge and corner pointers in generate_mesh(). In generate_mesh() after creating the base structure of the blocks, we associate their neighbor pointers (faces, edges, and corners) with the proper neighbors. Signed-off-by: Grzegorz Kowal --- src/domains.F90 | 206 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 206 insertions(+) diff --git a/src/domains.F90 b/src/domains.F90 index 1cb5bb6..6cf43b4 100644 --- a/src/domains.F90 +++ b/src/domains.F90 @@ -167,6 +167,8 @@ module domains ! allocatable arrays ! integer, dimension(:,:,:), allocatable :: cfg + integer, dimension(:) , allocatable :: im, jm, km + integer, dimension(:) , allocatable :: ip, jp, kp ! local pointer array ! @@ -461,6 +463,210 @@ module domains end if #endif /* NDIMS == 3 */ +! allocate indices +! + allocate(im(ir), ip(ir)) + allocate(jm(jr), jp(jr)) +#if NDIMS == 3 + allocate(km(kr), kp(kr)) +#endif /* NDIMS == 3 */ + +! generate indices +! + im(:) = cshift((/(i, i = 1, ir)/),-1) + ip(:) = cshift((/(i, i = 1, ir)/), 1) + jm(:) = cshift((/(j, j = 1, jr)/),-1) + jp(:) = cshift((/(j, j = 1, jr)/), 1) +#if NDIMS == 3 + km(:) = cshift((/(k, k = 1, kr)/),-1) + kp(:) = cshift((/(k, k = 1, kr)/), 1) +#endif /* NDIMS == 3 */ + +! check periodicity and reset the edge indices if box is not periodic +! + if (bnd_type(1,1) /= bnd_periodic .or. bnd_type(1,2) /= bnd_periodic) then + im( 1) = 0 + ip(ir) = 0 + end if + if (bnd_type(2,1) /= bnd_periodic .or. bnd_type(2,2) /= bnd_periodic) then + jm( 1) = 0 + jp(jr) = 0 + end if +#if NDIMS == 3 + if (bnd_type(3,1) /= bnd_periodic .or. bnd_type(3,2) /= bnd_periodic) then + km( 1) = 0 + kp(kr) = 0 + end if +#endif /* NDIMS == 3 */ + +! iterate over all initial blocks +! + do k = 1, kr + do j = 1, jr + do i = 1, ir + +! assign pmeta with the current block +! + pmeta => block_array(i,j,k)%ptr + +#if NDIMS == 3 +! assign face neighbor pointers +! + if (im(i) > 0) then + pmeta%faces(1,1,1,1)%ptr => block_array(im(i),j,k)%ptr + pmeta%faces(1,2,1,1)%ptr => block_array(im(i),j,k)%ptr + pmeta%faces(1,1,2,1)%ptr => block_array(im(i),j,k)%ptr + pmeta%faces(1,2,2,1)%ptr => block_array(im(i),j,k)%ptr + end if + if (ip(i) > 0) then + pmeta%faces(2,1,1,1)%ptr => block_array(ip(i),j,k)%ptr + pmeta%faces(2,2,1,1)%ptr => block_array(ip(i),j,k)%ptr + pmeta%faces(2,1,2,1)%ptr => block_array(ip(i),j,k)%ptr + pmeta%faces(2,2,2,1)%ptr => block_array(ip(i),j,k)%ptr + end if + + if (jm(j) > 0) then + pmeta%faces(1,1,1,2)%ptr => block_array(i,jm(j),k)%ptr + pmeta%faces(2,1,1,2)%ptr => block_array(i,jm(j),k)%ptr + pmeta%faces(1,1,2,2)%ptr => block_array(i,jm(j),k)%ptr + pmeta%faces(2,1,2,2)%ptr => block_array(i,jm(j),k)%ptr + end if + if (jp(j) > 0) then + pmeta%faces(1,2,1,2)%ptr => block_array(i,jp(j),k)%ptr + pmeta%faces(2,2,1,2)%ptr => block_array(i,jp(j),k)%ptr + pmeta%faces(1,2,2,2)%ptr => block_array(i,jp(j),k)%ptr + pmeta%faces(2,2,2,2)%ptr => block_array(i,jp(j),k)%ptr + end if + + if (km(k) > 0) then + pmeta%faces(1,1,1,3)%ptr => block_array(i,j,km(k))%ptr + pmeta%faces(2,1,1,3)%ptr => block_array(i,j,km(k))%ptr + pmeta%faces(1,2,1,3)%ptr => block_array(i,j,km(k))%ptr + pmeta%faces(2,2,1,3)%ptr => block_array(i,j,km(k))%ptr + end if + if (kp(k) > 0) then + pmeta%faces(1,1,2,3)%ptr => block_array(i,j,kp(k))%ptr + pmeta%faces(2,1,2,3)%ptr => block_array(i,j,kp(k))%ptr + pmeta%faces(1,2,2,3)%ptr => block_array(i,j,kp(k))%ptr + pmeta%faces(2,2,2,3)%ptr => block_array(i,j,kp(k))%ptr + end if +#endif /* NDIMS == 3 */ + +! assign edge neighbor pointers +! +#if NDIMS == 2 + if (im(i) > 0) then + pmeta%edges(1,1,2)%ptr => block_array(im(i),j,k)%ptr + pmeta%edges(1,2,2)%ptr => block_array(im(i),j,k)%ptr + end if + if (ip(i) > 0) then + pmeta%edges(2,1,2)%ptr => block_array(ip(i),j,k)%ptr + pmeta%edges(2,2,2)%ptr => block_array(ip(i),j,k)%ptr + end if + if (jm(j) > 0) then + pmeta%edges(1,1,1)%ptr => block_array(i,jm(j),k)%ptr + pmeta%edges(2,1,1)%ptr => block_array(i,jm(j),k)%ptr + end if + if (jp(j) > 0) then + pmeta%edges(1,2,1)%ptr => block_array(i,jp(j),k)%ptr + pmeta%edges(2,2,1)%ptr => block_array(i,jp(j),k)%ptr + end if +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + if (jm(j) > 0 .and. km(k) > 0) then + pmeta%edges(1,1,1,1)%ptr => block_array(i,jm(j),km(k))%ptr + pmeta%edges(2,1,1,1)%ptr => block_array(i,jm(j),km(k))%ptr + end if + if (jp(j) > 0 .and. km(k) > 0) then + pmeta%edges(1,2,1,1)%ptr => block_array(i,jp(j),km(k))%ptr + pmeta%edges(2,2,1,1)%ptr => block_array(i,jp(j),km(k))%ptr + end if + if (jm(j) > 0 .and. kp(k) > 0) then + pmeta%edges(1,1,2,1)%ptr => block_array(i,jm(j),kp(k))%ptr + pmeta%edges(2,1,2,1)%ptr => block_array(i,jm(j),kp(k))%ptr + end if + if (jp(j) > 0 .and. kp(k) > 0) then + pmeta%edges(1,2,2,1)%ptr => block_array(i,jp(j),kp(k))%ptr + pmeta%edges(2,2,2,1)%ptr => block_array(i,jp(j),kp(k))%ptr + end if + + if (im(i) > 0 .and. km(k) > 0) then + pmeta%edges(1,1,1,2)%ptr => block_array(im(i),j,km(k))%ptr + pmeta%edges(1,2,1,2)%ptr => block_array(im(i),j,km(k))%ptr + end if + if (ip(i) > 0 .and. km(k) > 0) then + pmeta%edges(2,1,1,2)%ptr => block_array(ip(i),j,km(k))%ptr + pmeta%edges(2,2,1,2)%ptr => block_array(ip(i),j,km(k))%ptr + end if + if (im(i) > 0 .and. kp(k) > 0) then + pmeta%edges(1,1,2,2)%ptr => block_array(im(i),j,kp(k))%ptr + pmeta%edges(1,2,2,2)%ptr => block_array(im(i),j,kp(k))%ptr + end if + if (ip(i) > 0 .and. kp(k) > 0) then + pmeta%edges(2,1,2,2)%ptr => block_array(ip(i),j,kp(k))%ptr + pmeta%edges(2,2,2,2)%ptr => block_array(ip(i),j,kp(k))%ptr + end if + + if (im(i) > 0 .and. jm(j) > 0) then + pmeta%edges(1,1,1,3)%ptr => block_array(im(i),jm(j),k)%ptr + pmeta%edges(1,1,2,3)%ptr => block_array(im(i),jm(j),k)%ptr + end if + if (ip(i) > 0 .and. jm(j) > 0) then + pmeta%edges(2,1,1,3)%ptr => block_array(ip(i),jm(j),k)%ptr + pmeta%edges(2,1,2,3)%ptr => block_array(ip(i),jm(j),k)%ptr + end if + if (im(i) > 0 .and. jp(j) > 0) then + pmeta%edges(1,2,1,3)%ptr => block_array(im(i),jp(j),k)%ptr + pmeta%edges(1,2,2,3)%ptr => block_array(im(i),jp(j),k)%ptr + end if + if (ip(i) > 0 .and. jp(j) > 0) then + pmeta%edges(2,2,1,3)%ptr => block_array(ip(i),jp(j),k)%ptr + pmeta%edges(2,2,2,3)%ptr => block_array(ip(i),jp(j),k)%ptr + end if +#endif /* NDIMS == 3 */ + +! assign corner neighbor pointers +! +#if NDIMS == 2 + if (im(i) > 0 .and. jm(j) > 0) & + pmeta%corners(1,1)%ptr => block_array(im(i),jm(j),k)%ptr + if (ip(i) > 0 .and. jm(j) > 0) & + pmeta%corners(2,1)%ptr => block_array(ip(i),jm(j),k)%ptr + if (im(i) > 0 .and. jp(j) > 0) & + pmeta%corners(1,2)%ptr => block_array(im(i),jp(j),k)%ptr + if (ip(i) > 0 .and. jp(j) > 0) & + pmeta%corners(2,2)%ptr => block_array(ip(i),jp(j),k)%ptr +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + if (im(i) > 0 .and. jm(j) > 0 .and. km(k) > 0) & + pmeta%corners(1,1,1)%ptr => block_array(im(i),jm(j),km(k))%ptr + if (ip(i) > 0 .and. jm(j) > 0 .and. km(k) > 0) & + pmeta%corners(2,1,1)%ptr => block_array(ip(i),jm(j),km(k))%ptr + if (im(i) > 0 .and. jp(j) > 0 .and. km(k) > 0) & + pmeta%corners(1,2,1)%ptr => block_array(im(i),jp(j),km(k))%ptr + if (ip(i) > 0 .and. jp(j) > 0 .and. km(k) > 0) & + pmeta%corners(2,2,1)%ptr => block_array(ip(i),jp(j),km(k))%ptr + if (im(i) > 0 .and. jm(j) > 0 .and. kp(k) > 0) & + pmeta%corners(1,1,2)%ptr => block_array(im(i),jm(j),kp(k))%ptr + if (ip(i) > 0 .and. jm(j) > 0 .and. kp(k) > 0) & + pmeta%corners(2,1,2)%ptr => block_array(ip(i),jm(j),kp(k))%ptr + if (im(i) > 0 .and. jp(j) > 0 .and. kp(k) > 0) & + pmeta%corners(1,2,2)%ptr => block_array(im(i),jp(j),kp(k))%ptr + if (ip(i) > 0 .and. jp(j) > 0 .and. kp(k) > 0) & + pmeta%corners(2,2,2)%ptr => block_array(ip(i),jp(j),kp(k))%ptr +#endif /* NDIMS == 3 */ + end do ! over i + end do ! over j + end do ! over k + +! deallocate indices +! + deallocate(im, ip) + deallocate(jm, jp) +#if NDIMS == 3 + deallocate(km, kp) +#endif /* NDIMS == 3 */ + ! deallocate the block pointer array ! deallocate(block_array) From 93321a283f71675cfcc22f1b2b9738bd697ec15b Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 15 Jul 2014 07:30:54 -0300 Subject: [PATCH 37/91] BLOCKS: Add %corner field to block_info structure. This field stores the location of the corner neighbour pointer and is used in determining which face, edge or corner we are referring to when we perform MPI boundary update. Signed-off-by: Grzegorz Kowal --- src/blocks.F90 | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/blocks.F90 b/src/blocks.F90 index 7bd94fd..0915a8d 100644 --- a/src/blocks.F90 +++ b/src/blocks.F90 @@ -291,6 +291,12 @@ module blocks ! integer(kind=4) :: direction, side, face + ! the corner index determining the position of + ! the corner boundary and when direction is + ! specified also the face or edge boundaries + ! + integer(kind=4) :: corner(NDIMS) + ! the level difference between the block and ! its neighbor ! From 6c7c6c60b23a0b3d90d9e0dab9602084d6836c3c Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 15 Jul 2014 08:06:25 -0300 Subject: [PATCH 38/91] BOUNDARIES: Implement block_corner_copy(). This subroutines takes the variable array of the neighbor and extracts the corner region corresponding to the corner position. Signed-off-by: Grzegorz Kowal --- src/boundaries.F90 | 97 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 97 insertions(+) diff --git a/src/boundaries.F90 b/src/boundaries.F90 index 0a3f837..c008710 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -3541,6 +3541,103 @@ module boundaries ! !=============================================================================== ! +! CORNER UPDATE SUBROUTINES +! +!=============================================================================== +! +! subroutine BLOCK_CORNER_COPY: +! ---------------------------- +! +! Subroutine returns the corner boundary region by copying the corresponding +! region from the provided input variable array. +! +! Arguments: +! +! ic, jc, kc - the corner position; +! qn - the input neighbor variable array; +! qb - the output corner boundary array; +! +!=============================================================================== +! + subroutine block_corner_copy(ic, jc, kc, qn, qb) + +! import external procedures and variables +! + use coordinates , only : ng + use coordinates , only : im , jm , km + use coordinates , only : ib , jb , kb + use coordinates , only : ie , je , ke + use coordinates , only : ibu, jbu, kbu + use coordinates , only : iel, jel, kel + use equations , only : nv + +! local variables are not implicit by default +! + implicit none + +! subroutine arguments +! + integer , intent(in) :: ic, jc, kc + real(kind=8), dimension(1:nv,1:im,1:jm,1:km), intent(in) :: qn +#if NDIMS == 2 + real(kind=8), dimension(1:nv,1:ng,1:ng,1:km), intent(out) :: qb +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + real(kind=8), dimension(1:nv,1:ng,1:ng,1:ng), intent(out) :: qb +#endif /* NDIMS == 3 */ + +! local indices +! + integer :: il, jl, kl + integer :: iu, ju, ku +! +!------------------------------------------------------------------------------- +! +! prepare source corner region indices +! + if (ic == 1) then + il = iel + iu = ie + else + il = ib + iu = ibu + end if + if (jc == 1) then + jl = jel + ju = je + else + jl = jb + ju = jbu + end if +#if NDIMS == 3 + if (kc == 1) then + kl = kel + ku = ke + else + kl = kb + ku = kbu + end if +#endif /* NDIMS == 3 */ + +! return corner region in the output array +! +#if NDIMS == 2 + qb(1:nv,1:ng,1:ng,1:km) = qn(1:nv,il:iu,jl:ju, 1:km) +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + qb(1:nv,1:ng,1:ng,1:ng) = qn(1:nv,il:iu,jl:ju,kl:ku) +#endif /* NDIMS == 3 */ + +!------------------------------------------------------------------------------- +! + end subroutine block_corner_copy +! +!=============================================================================== +! +! FLUX UPDATE SUBROUTINES +! +!=============================================================================== +! ! subroutine CORRECT_FLUX: ! ----------------------- ! From 56ab5b246dae6f8d3af757e97f06a9cd2f5c4f46 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 15 Jul 2014 08:29:04 -0300 Subject: [PATCH 39/91] BOUNDARIES: Add subroutine boundaries_corner_copy(). This subroutines scans over all leaf blocks and their corner neighbor pointers and updates corner boundary regions between blocks at the same refinement level. Signed-off-by: Grzegorz Kowal --- src/boundaries.F90 | 473 ++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 471 insertions(+), 2 deletions(-) diff --git a/src/boundaries.F90 b/src/boundaries.F90 index c008710..b7576b2 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -2774,6 +2774,475 @@ module boundaries ! !=============================================================================== ! +! DOMAIN BOUNDARY UPDATE SUBROUTINES +! +!=============================================================================== +! +! subroutine BOUNDARIES_CORNER_COPY: +! --------------------------------- +! +! Subroutine scans over all leaf blocks in order to find corner neighbors at +! the same level, and perform the update of the corner boundaries between +! them. +! +! +!=============================================================================== +! + subroutine boundaries_corner_copy() + +! import external procedures and variables +! + use blocks , only : nsides + use blocks , only : block_meta, block_data + use blocks , only : list_meta + use blocks , only : block_info, pointer_info + use coordinates , only : ng + use coordinates , only : im , jm , km + use coordinates , only : ibl, jbl, kbl + use coordinates , only : ieu, jeu, keu +#ifdef MPI + use equations , only : nv +#endif /* MPI */ + use mpitools , only : nproc, nprocs, npmax +#ifdef MPI + use mpitools , only : send_real_array, receive_real_array +#endif /* MPI */ + +! local variables are not implicit by default +! + implicit none + +! local pointers +! + type(block_meta), pointer :: pmeta, pneigh +#ifdef MPI + type(block_info), pointer :: pinfo +#endif /* MPI */ + +! local variables +! + integer :: i , j , k + integer :: il, jl, kl + integer :: iu, ju, ku + integer :: iret +#ifdef MPI + integer :: isend, irecv, nblocks, itag, l + +! local pointer arrays +! + type(pointer_info), dimension(0:npmax,0:npmax) :: block_array + +! local arrays +! + integer , dimension(0:npmax,0:npmax) :: block_counter + real(kind=8), dimension(:,:,:,:,:) , allocatable :: rbuf +#endif /* MPI */ +! +!------------------------------------------------------------------------------- +! +#ifdef PROFILE +! start accounting time for copy boundary update +! + call start_timer(imc) +#endif /* PROFILE */ + +#ifdef MPI +!! 1. PREPARE THE BLOCK EXCHANGE ARRAYS FOR MPI +!! +! reset the exchange block counters +! + block_counter(:,:) = 0 + +! nullify the info pointers +! + do irecv = 0, npmax + do isend = 0, npmax + nullify(block_array(isend,irecv)%ptr) + end do + end do +#endif /* MPI */ + +!! 2. UPDATE VARIABLE CORNER BOUNDARIES BETWEEN BLOCKS BELONGING TO THE SAME +!! PROCESS AND PREPARE THE EXCHANGE BLOCK LIST OF BLOCKS WHICH BELONG TO +!! DIFFERENT PROCESSES +!! +! assign the pointer to the first block on the meta block list +! + pmeta => list_meta + +! scan all meta blocks and process blocks at the current level +! + do while(associated(pmeta)) + +! check if the block is leaf +! + if (pmeta%leaf) then + +! scan over all block corners +! +#if NDIMS == 3 + do k = 1, nsides +#endif /* NDIMS == 3 */ + do j = 1, nsides + do i = 1, nsides + +! assign pneigh to the current neighbor +! +#if NDIMS == 2 + pneigh => pmeta%corners(i,j)%ptr +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + pneigh => pmeta%corners(i,j,k)%ptr +#endif /* NDIMS == 3 */ + +! check if the neighbor is associated +! + if (associated(pneigh)) then + +! check if the neighbor is at the same level +! + if (pneigh%level == pmeta%level) then + +! skip if the block and its neighbor are not marked for update +! + if (pmeta%update .and. pneigh%update) then + +#ifdef MPI +! check if the block and its neighbor belong to the same process +! + if (pmeta%process == pneigh%process) then + +! check if the neighbor belongs to the current process +! + if (pmeta%process == nproc) then +#endif /* MPI */ + +! prepare the region indices for corner boundary update +! + if (i == 1) then + il = 1 + iu = ibl + else + il = ieu + iu = im + end if + if (j == 1) then + jl = 1 + ju = jbl + else + jl = jeu + ju = jm + end if +#if NDIMS == 3 + if (k == 1) then + kl = 1 + ku = kbl + else + kl = keu + ku = km + end if +#endif /* NDIMS == 3 */ + +! extract the corresponding corner region from the neighbor and insert it in +! the current data block +! +#if NDIMS == 2 + call block_corner_copy(i, j, k & + , pneigh%data%q(1:nv, 1:im, 1:jm, 1:km) & + , pmeta%data%q(1:nv,il:iu,jl:ju, 1:km)) +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + call block_corner_copy(i, j, k & + , pneigh%data%q(1:nv, 1:im, 1:jm, 1:km) & + , pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku)) +#endif /* NDIMS == 3 */ + +#ifdef MPI + end if ! pneigh on the current process + + else ! block and neighbor belong to different processes + +! increase the counter for number of blocks to exchange +! + block_counter(pneigh%process,pmeta%process) = & + block_counter(pneigh%process,pmeta%process) + 1 + +! allocate a new info object +! + allocate(pinfo) + +! fill out only fields which are used +! + pinfo%block => pmeta + pinfo%neigh => pneigh + pinfo%corner(1) = i + pinfo%corner(2) = j +#if NDIMS == 3 + pinfo%corner(3) = k +#endif /* NDIMS == 3 */ + +! nullify pointer fields of the object +! + nullify(pinfo%prev) + nullify(pinfo%next) + +! if the list is not empty append the newly created block to it +! + if (associated(block_array(pneigh%process & + ,pmeta%process)%ptr)) & + pinfo%prev => block_array(pneigh%process & + ,pmeta%process)%ptr + +! point the list to the newly created block +! + block_array(pneigh%process,pmeta%process)%ptr => pinfo + + end if ! block and neighbor belong to different processes +#endif /* MPI */ + + end if ! pmeta and pneigh marked for update + + end if ! neighbor at the same level + + end if ! neighbor associated + + end do ! i = 1, nsides + end do ! j = 1, nsides +#if NDIMS == 3 + end do ! k = 1, nsides +#endif /* NDIMS == 3 */ + + end if ! leaf + +! associate the pointer to the next meta block +! + pmeta => pmeta%next + + end do ! meta blocks + +#ifdef MPI +!! 3. UPDATE VARIABLE BOUNDARIES BETWEEN BLOCKS BELONGING TO DIFFERENT PROCESSES +!! +! iterate over sending and receiving processors +! + do irecv = 0, npmax + do isend = 0, npmax + +! process only pairs which have something to exchange +! + if (block_counter(isend,irecv) > 0) then + +! obtain the number of blocks to exchange +! + nblocks = block_counter(isend,irecv) + +! prepare the tag for communication +! + itag = 100 * (irecv * nprocs + isend + 1) + 11 + +! allocate data buffer for variables to exchange +! +#if NDIMS == 2 + allocate(rbuf(nblocks,nv,ng,ng,km)) +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + allocate(rbuf(nblocks,nv,ng,ng,ng)) +#endif /* NDIMS == 3 */ + +! if isend == nproc we are sending data from the neighbor block +! + if (isend == nproc) then + +! reset the block counter +! + l = 0 + +! associate the pointer with the first block in the exchange list +! + pinfo => block_array(isend,irecv)%ptr + +! scan over all blocks on the block exchange list +! + do while(associated(pinfo)) + +! increase the block counter +! + l = l + 1 + +! assign pneigh to the associated neighbor block +! + pneigh => pinfo%neigh + +! get the corner coordinates +! + i = pinfo%corner(1) + j = pinfo%corner(2) +#if NDIMS == 3 + k = pinfo%corner(3) +#endif /* NDIMS == 3 */ + +! extract the corresponding corner region from the neighbor and insert it +! to the buffer +! +#if NDIMS == 2 + call block_corner_copy(i, j, k & + , pneigh%data%q(1:nv, 1:im, 1:jm, 1:km) & + , rbuf(l,1:nv,1:ng,1:ng,1:km)) +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + call block_corner_copy(i, j, k & + , pneigh%data%q(1:nv, 1:im, 1:jm, 1:km) & + , rbuf(l,1:nv,1:ng,1:ng,1:ng)) +#endif /* NDIMS == 3 */ + +! associate the pointer with the next block +! + pinfo => pinfo%prev + + end do ! %ptr block list + +! send the data buffer to another process +! + call send_real_array(size(rbuf), irecv, itag, rbuf(:,:,:,:,:), iret) + + end if ! isend = nproc + +! if irecv == nproc we are receiving data from the neighbor block +! + if (irecv == nproc) then + +! receive the data buffer +! + call receive_real_array(size(rbuf(:,:,:,:,:)), isend, itag & + , rbuf(:,:,:,:,:), iret) + +! reset the block counter +! + l = 0 + +! associate the pointer with the first block in the exchange list +! + pinfo => block_array(isend,irecv)%ptr + +! iterate over all received blocks and update boundaries of the corresponding +! data blocks +! + do while(associated(pinfo)) + +! increase the block counter +! + l = l + 1 + +! assign a pointer to the associated data block +! + pmeta => pinfo%block + +! get the corner coordinates +! + i = pinfo%corner(1) + j = pinfo%corner(2) +#if NDIMS == 3 + k = pinfo%corner(3) +#endif /* NDIMS == 3 */ + +! calculate the insertion indices +! + if (i == 1) then + il = 1 + iu = ibl + else + il = ieu + iu = im + end if + if (j == 1) then + jl = 1 + ju = jbl + else + jl = jeu + ju = jm + end if +#if NDIMS == 3 + if (k == 1) then + kl = 1 + ku = kbl + else + kl = keu + ku = km + end if +#endif /* NDIMS == 3 */ + +! update the corresponding corner region of the current block +! +#if NDIMS == 2 + pmeta%data%q(1:nv,il:iu,jl:ju, 1:km) = rbuf(l,1:nv,1:ng,1:ng,1:km) +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = rbuf(l,1:nv,1:ng,1:ng,1:ng) +#endif /* NDIMS == 3 */ + +! associate the pointer with the next block +! + pinfo => pinfo%prev + + end do ! %ptr block list + + end if ! irecv = nproc + +! deallocate data buffer +! + if (allocated(rbuf)) deallocate(rbuf) + +! associate the pointer with the first block in the exchange list +! + pinfo => block_array(isend,irecv)%ptr + +! scan over all blocks on the exchange block list +! + do while(associated(pinfo)) + +! associate the exchange list pointer +! + block_array(isend,irecv)%ptr => pinfo%prev + +! nullify the pointer fields +! + nullify(pinfo%prev) + nullify(pinfo%next) + nullify(pinfo%block) + nullify(pinfo%neigh) + +! deallocate the object +! + deallocate(pinfo) + +! associate the pointer with the next block +! + pinfo => block_array(isend,irecv)%ptr + + end do ! %ptr block list + + end if ! if block_count > 0 + + end do ! isend + end do ! irecv +#endif /* MPI */ + +#ifdef PROFILE +! stop accounting time for copy boundary update +! + call stop_timer(imc) +#endif /* PROFILE */ + +!------------------------------------------------------------------------------- +! + end subroutine boundaries_corner_copy +! +!=============================================================================== +! +! BLOCK BOUNDARY UPDATE SUBROUTINES +! +!=============================================================================== +! ! subroutine BOUNDARY_SPECIFIC: ! ---------------------------- ! @@ -3541,7 +4010,7 @@ module boundaries ! !=============================================================================== ! -! CORNER UPDATE SUBROUTINES +! BLOCK CORNER UPDATE SUBROUTINES ! !=============================================================================== ! @@ -3634,7 +4103,7 @@ module boundaries ! !=============================================================================== ! -! FLUX UPDATE SUBROUTINES +! BLOCK FLUX UPDATE SUBROUTINES ! !=============================================================================== ! From 188be54d63cd58d43241f380ae238f8b0027d5e6 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 15 Jul 2014 08:31:48 -0300 Subject: [PATCH 40/91] BOUNDARIES: Call boundaries_corner_copy() in boundary_variables(). Signed-off-by: Grzegorz Kowal --- src/boundaries.F90 | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/boundaries.F90 b/src/boundaries.F90 index b7576b2..6c766c6 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -346,6 +346,10 @@ module boundaries ! call update_corners() +! update corner boundaries between blocks at the same levels +! + call boundaries_corner_copy() + ! convert updated primitive variables to conservative ones in all ghost cells ! call update_ghost_cells() From 637d318c0e6c456870593d44ad81d400c131de78 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 15 Jul 2014 10:53:09 -0300 Subject: [PATCH 41/91] BOUNDARIES: Implement block_corner_restrict(). This subroutines takes the variable array of the higher level neighbor, restricts it and extracts the corner region corresponding to the corner position. Signed-off-by: Grzegorz Kowal --- src/boundaries.F90 | 106 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 106 insertions(+) diff --git a/src/boundaries.F90 b/src/boundaries.F90 index 6c766c6..4726f06 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -4107,6 +4107,112 @@ module boundaries ! !=============================================================================== ! +! subroutine BLOCK_CORNER_RESTRICT: +! -------------------------------- +! +! Subroutine returns the corner boundary region by restricting +! the corresponding region from the provided input variable array. +! +! Arguments: +! +! ic, jc, kc - the corner position; +! qn - the input neighbor variable array; +! qb - the output corner boundary array; +! +!=============================================================================== +! + subroutine block_corner_restrict(ic, jc, kc, qn, qb) + +! import external procedures and variables +! + use coordinates , only : ng, nd + use coordinates , only : im , jm , km + use coordinates , only : ib , jb , kb + use coordinates , only : ie , je , ke + use equations , only : nv + +! local variables are not implicit by default +! + implicit none + +! subroutine arguments +! + integer , intent(in) :: ic, jc, kc + real(kind=8), dimension(1:nv,1:im,1:jm,1:km), intent(in) :: qn +#if NDIMS == 2 + real(kind=8), dimension(1:nv,1:ng,1:ng,1:km), intent(out) :: qb +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + real(kind=8), dimension(1:nv,1:ng,1:ng,1:ng), intent(out) :: qb +#endif /* NDIMS == 3 */ + +! local variables +! + integer :: il, jl, kl + integer :: ip, jp, kp + integer :: iu, ju, ku +! +!------------------------------------------------------------------------------- +! +! prepare source corner region indices +! + if (ic == 1) then + il = ie - nd + 1 + ip = il + 1 + iu = ie + else + il = ib + ip = il + 1 + iu = ib + nd - 1 + end if + if (jc == 1) then + jl = je - nd + 1 + jp = jl + 1 + ju = je + else + jl = jb + jp = jl + 1 + ju = jb + nd - 1 + end if +#if NDIMS == 3 + if (kc == 1) then + kl = ke - nd + 1 + kp = kl + 1 + ku = ke + else + kl = kb + kp = kl + 1 + ku = kb + nd - 1 + end if +#endif /* NDIMS == 3 */ + +! return corner region in the output array +! +#if NDIMS == 2 + qb(1:nv,1:ng,1:ng,1:km) = & + 2.50d-01 * ((qn(1:nv,il:iu:2,jl:ju:2, 1:km ) & + + qn(1:nv,ip:iu:2,jp:ju:2, 1:km )) & + + (qn(1:nv,il:iu:2,jp:ju:2, 1:km ) & + + qn(1:nv,ip:iu:2,jl:ju:2, 1:km ))) +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + qb(1:nv,1:ng,1:ng,1:ng) = & + 1.25d-01 * (((qn(1:nv,il:iu:2,jl:ju:2,kl:ku:2) & + + qn(1:nv,ip:iu:2,jp:ju:2,kp:ku:2)) & + + (qn(1:nv,il:iu:2,jl:ju:2,kp:ku:2) & + + qn(1:nv,ip:iu:2,jp:ju:2,kl:ku:2))) & + + ((qn(1:nv,il:iu:2,jp:ju:2,kp:ku:2) & + + qn(1:nv,ip:iu:2,jl:ju:2,kl:ku:2)) & + + (qn(1:nv,il:iu:2,jp:ju:2,kl:ku:2) & + + qn(1:nv,ip:iu:2,jl:ju:2,kp:ku:2)))) +#endif /* NDIMS == 3 */ + +!------------------------------------------------------------------------------- +! + end subroutine block_corner_restrict +! +!=============================================================================== +! ! BLOCK FLUX UPDATE SUBROUTINES ! !=============================================================================== From 268a5378ccce520c6570a17a3bbe68b1263ef033 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 15 Jul 2014 11:08:54 -0300 Subject: [PATCH 42/91] BOUNDARIES: Add subroutine boundaries_corner_restrict(). This subroutines scans over all leaf blocks and their corner neighbor pointers and updates corner boundary regions from neighbor at higher level. Signed-off-by: Grzegorz Kowal --- src/boundaries.F90 | 460 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 460 insertions(+) diff --git a/src/boundaries.F90 b/src/boundaries.F90 index 4726f06..ad0b961 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -3243,6 +3243,466 @@ module boundaries ! !=============================================================================== ! +! subroutine BOUNDARIES_CORNER_RESTRICT: +! ------------------------------------- +! +! Subroutine scans over all leaf blocks in order to find corner neighbors at +! different levels, and update the corner boundaries of blocks at lower levels +! by restricting variables from higher level blocks. +! +! +!=============================================================================== +! + subroutine boundaries_corner_restrict() + +! import external procedures and variables +! + use blocks , only : nsides + use blocks , only : block_meta, block_data + use blocks , only : list_meta + use blocks , only : block_info, pointer_info + use coordinates , only : ng + use coordinates , only : im , jm , km + use coordinates , only : ibl, jbl, kbl + use coordinates , only : ieu, jeu, keu +#ifdef MPI + use equations , only : nv +#endif /* MPI */ + use mpitools , only : nproc, nprocs, npmax +#ifdef MPI + use mpitools , only : send_real_array, receive_real_array +#endif /* MPI */ + +! local variables are not implicit by default +! + implicit none + +! local pointers +! + type(block_meta), pointer :: pmeta, pneigh +#ifdef MPI + type(block_info), pointer :: pinfo +#endif /* MPI */ + +! local variables +! + integer :: i , j , k + integer :: il, jl, kl + integer :: iu, ju, ku + integer :: iret +#ifdef MPI + integer :: isend, irecv, nblocks, itag, l + +! local pointer arrays +! + type(pointer_info), dimension(0:npmax,0:npmax) :: block_array + +! local arrays +! + integer , dimension(0:npmax,0:npmax) :: block_counter + real(kind=8), dimension(:,:,:,:,:) , allocatable :: rbuf +#endif /* MPI */ +! +!------------------------------------------------------------------------------- +! +#ifdef PROFILE +! start accounting time for restrict boundary update +! + call start_timer(imr) +#endif /* PROFILE */ + +#ifdef MPI +!! 1. PREPARE THE BLOCK EXCHANGE ARRAYS FOR MPI +!! +! reset the exchange block counters +! + block_counter(:,:) = 0 + +! nullify the info pointers +! + do irecv = 0, npmax + do isend = 0, npmax + nullify(block_array(isend,irecv)%ptr) + end do + end do +#endif /* MPI */ + +!! 2. UPDATE VARIABLE CORNER BOUNDARIES BETWEEN BLOCKS BELONGING TO THE SAME +!! PROCESS AND PREPARE THE EXCHANGE BLOCK LIST OF BLOCKS WHICH BELONG TO +!! DIFFERENT PROCESSES +!! +! assign the pointer to the first block on the meta block list +! + pmeta => list_meta + +! scan all meta blocks and process blocks at the current level +! + do while(associated(pmeta)) + +! check if the block is leaf +! + if (pmeta%leaf) then + +! scan over all block corners +! +#if NDIMS == 3 + do k = 1, nsides +#endif /* NDIMS == 3 */ + do j = 1, nsides + do i = 1, nsides + +! assign pneigh to the current neighbor +! +#if NDIMS == 2 + pneigh => pmeta%corners(i,j)%ptr +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + pneigh => pmeta%corners(i,j,k)%ptr +#endif /* NDIMS == 3 */ + +! check if the neighbor is associated +! + if (associated(pneigh)) then + +! check if the neighbor is at higher level +! + if (pneigh%level > pmeta%level) then + +! skip if the block and its neighbor are not marked for update +! + if (pmeta%update .and. pneigh%update) then + +#ifdef MPI +! check if the block and its neighbor belong to the same process +! + if (pmeta%process == pneigh%process) then + +! check if the neighbor belongs to the current process +! + if (pmeta%process == nproc) then +#endif /* MPI */ + +! prepare the region indices for corner boundary update +! + if (i == 1) then + il = 1 + iu = ibl + else + il = ieu + iu = im + end if + if (j == 1) then + jl = 1 + ju = jbl + else + jl = jeu + ju = jm + end if +#if NDIMS == 3 + if (k == 1) then + kl = 1 + ku = kbl + else + kl = keu + ku = km + end if +#endif /* NDIMS == 3 */ + +! restrict and extract the corresponding corner region from the neighbor and +! insert it in the current data block +! +#if NDIMS == 2 + call block_corner_restrict(i, j, k & + , pneigh%data%q(1:nv, 1:im, 1:jm, 1:km) & + , pmeta%data%q(1:nv,il:iu,jl:ju, 1:km)) +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + call block_corner_restrict(i, j, k & + , pneigh%data%q(1:nv, 1:im, 1:jm, 1:km) & + , pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku)) +#endif /* NDIMS == 3 */ + +#ifdef MPI + end if ! block on the current processor + + else ! block and neighbor on different processors + +! increase the counter for number of blocks to exchange +! + block_counter(pneigh%process,pmeta%process) = & + block_counter(pneigh%process,pmeta%process) + 1 + +! allocate a new info object +! + allocate(pinfo) + +! fill out only fields which are used +! + pinfo%block => pmeta + pinfo%neigh => pneigh + pinfo%corner(1) = i + pinfo%corner(2) = j +#if NDIMS == 3 + pinfo%corner(3) = k +#endif /* NDIMS == 3 */ + +! nullify pointer fields of the object +! + nullify(pinfo%prev) + nullify(pinfo%next) + +! if the list is not empty append the newly created block to it +! + if (associated(block_array(pneigh%process & + ,pmeta%process)%ptr)) & + pinfo%prev => block_array(pneigh%process & + ,pmeta%process)%ptr + +! point the list to the newly created block +! + block_array(pneigh%process,pmeta%process)%ptr => pinfo + + end if ! block and neighbor on different processors +#endif /* MPI */ + end if ! pmeta and pneigh marked for update + + end if ! neighbor at higher level + + end if ! neighbor associated + + end do ! i = 1, nsides + end do ! j = 1, nsides +#if NDIMS == 3 + end do ! k = 1, nsides +#endif /* NDIMS == 3 */ + + end if ! leaf + +! assign the pointer to the next block on the list +! + pmeta => pmeta%next + + end do ! meta blocks + +#ifdef MPI +!! 3. UPDATE VARIABLE BOUNDARIES BETWEEN BLOCKS BELONGING TO DIFFERENT PROCESSES +!! +! iterate over sending and receiving processors +! + do irecv = 0, npmax + do isend = 0, npmax + +! process only pairs which have something to exchange +! + if (block_counter(isend,irecv) > 0) then + +! obtain the number of blocks to exchange +! + nblocks = block_counter(isend,irecv) + +! prepare the tag for communication +! + itag = 100 * (irecv * nprocs + isend + 1) + 12 + +! allocate data buffer for variables to exchange +! +#if NDIMS == 2 + allocate(rbuf(nblocks,nv,ng,ng,km)) +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + allocate(rbuf(nblocks,nv,ng,ng,ng)) +#endif /* NDIMS == 3 */ + +! if isend == nproc we are sending data from the neighbor block +! + if (isend == nproc) then + +! reset the block counter +! + l = 0 + +! associate the pointer with the first block in the exchange list +! + pinfo => block_array(isend,irecv)%ptr + +! scan over all blocks on the block exchange list +! + do while(associated(pinfo)) + +! increase the block counter +! + l = l + 1 + +! assign pneigh to the associated neighbor block +! + pneigh => pinfo%neigh + +! get the corner coordinates +! + i = pinfo%corner(1) + j = pinfo%corner(2) +#if NDIMS == 3 + k = pinfo%corner(3) +#endif /* NDIMS == 3 */ + +! restrict and extract the corresponding corner region from the neighbor and +! insert it to the buffer +! +#if NDIMS == 2 + call block_corner_restrict(i, j, k & + , pneigh%data%q(1:nv, 1:im, 1:jm, 1:km) & + , rbuf(l,1:nv,1:ng,1:ng,1:km)) +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + call block_corner_restrict(i, j, k & + , pneigh%data%q(1:nv, 1:im, 1:jm, 1:km) & + , rbuf(l,1:nv,1:ng,1:ng,1:ng)) +#endif /* NDIMS == 3 */ + +! associate the pointer with the next block +! + pinfo => pinfo%prev + + end do ! %ptr block list + +! send the data buffer to another process +! + call send_real_array(size(rbuf), irecv, itag, rbuf(:,:,:,:,:), iret) + + end if ! isend = nproc + +! if irecv == nproc we are receiving data from the neighbor block +! + if (irecv == nproc) then + +! receive the data buffer +! + call receive_real_array(size(rbuf(:,:,:,:,:)), isend, itag & + , rbuf(:,:,:,:,:), iret) + +! reset the block counter +! + l = 0 + +! associate the pointer with the first block in the exchange list +! + pinfo => block_array(isend,irecv)%ptr + +! iterate over all received blocks and update boundaries of the corresponding +! data blocks +! + do while(associated(pinfo)) + +! increase the block counter +! + l = l + 1 + +! assign a pointer to the associated data block +! + pmeta => pinfo%block + +! get the corner coordinates +! + i = pinfo%corner(1) + j = pinfo%corner(2) +#if NDIMS == 3 + k = pinfo%corner(3) +#endif /* NDIMS == 3 */ + +! calculate the insertion indices +! + if (i == 1) then + il = 1 + iu = ibl + else + il = ieu + iu = im + end if + if (j == 1) then + jl = 1 + ju = jbl + else + jl = jeu + ju = jm + end if +#if NDIMS == 3 + if (k == 1) then + kl = 1 + ku = kbl + else + kl = keu + ku = km + end if +#endif /* NDIMS == 3 */ + +! update the corresponding corner region of the current block +! +#if NDIMS == 2 + pmeta%data%q(1:nv,il:iu,jl:ju, 1:km) = rbuf(l,1:nv,1:ng,1:ng,1:km) +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = rbuf(l,1:nv,1:ng,1:ng,1:ng) +#endif /* NDIMS == 3 */ + +! associate the pointer with the next block +! + pinfo => pinfo%prev + + end do ! %ptr block list + + end if ! irecv = nproc + +! deallocate data buffer +! + if (allocated(rbuf)) deallocate(rbuf) + +! associate the pointer with the first block in the exchange list +! + pinfo => block_array(isend,irecv)%ptr + +! scan over all blocks on the exchange block list +! + do while(associated(pinfo)) + +! associate the exchange list pointer +! + block_array(isend,irecv)%ptr => pinfo%prev + +! nullify the pointer fields +! + nullify(pinfo%prev) + nullify(pinfo%next) + nullify(pinfo%block) + nullify(pinfo%neigh) + +! deallocate the object +! + deallocate(pinfo) + +! associate the pointer with the next block +! + pinfo => block_array(isend,irecv)%ptr + + end do ! %ptr block list + + end if ! if block_count > 0 + + end do ! isend + end do ! irecv +#endif /* MPI */ + +#ifdef PROFILE +! stop accounting time for restrict boundary update +! + call stop_timer(imr) +#endif /* PROFILE */ + +!------------------------------------------------------------------------------- +! + end subroutine boundaries_corner_restrict +! +!=============================================================================== +! ! BLOCK BOUNDARY UPDATE SUBROUTINES ! !=============================================================================== From b1fa32f8bad0f6c61a9926a1fc82747f32137508 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 15 Jul 2014 11:11:25 -0300 Subject: [PATCH 43/91] BOUNDARIES: Call boundaries_corner_restrict() in boundary_variables(). Signed-off-by: Grzegorz Kowal --- src/boundaries.F90 | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/boundaries.F90 b/src/boundaries.F90 index ad0b961..f5919f5 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -350,6 +350,10 @@ module boundaries ! call boundaries_corner_copy() +! restricts corner boundaries from blocks at higher levels +! + call boundaries_corner_restrict() + ! convert updated primitive variables to conservative ones in all ghost cells ! call update_ghost_cells() From 8eb5a1aaff783306e93baf5e237b99c6fa1b899f Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 15 Jul 2014 11:17:47 -0300 Subject: [PATCH 44/91] BOUNDARIES: Implement block_corner_prolong(). This subroutines takes the variable array of the lower level neighbor, prolongates it and extracts the corner region corresponding to the corner position. Signed-off-by: Grzegorz Kowal --- src/boundaries.F90 | 158 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 158 insertions(+) diff --git a/src/boundaries.F90 b/src/boundaries.F90 index f5919f5..fb3fd5b 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -4677,6 +4677,164 @@ module boundaries ! !=============================================================================== ! +! subroutine BLOCK_CORNER_PROLONG: +! ------------------------------- +! +! Subroutine returns the corner boundary region by prolongating +! the corresponding region from the provided input variable array. +! +! Arguments: +! +! ic, jc, kc - the corner position; +! qn - the input neighbor variable array; +! qb - the output corner boundary array; +! +!=============================================================================== +! + subroutine block_corner_prolong(ic, jc, kc, qn, qb) + +! import external procedures and variables +! + use coordinates , only : ng, nh + use coordinates , only : im , jm , km + use coordinates , only : ib , jb , kb + use coordinates , only : ie , je , ke + use equations , only : nv + use interpolations , only : limiter + +! local variables are not implicit by default +! + implicit none + +! subroutine arguments +! + integer , intent(in) :: ic, jc, kc + real(kind=8), dimension(1:nv,1:im,1:jm,1:km), intent(in) :: qn +#if NDIMS == 2 + real(kind=8), dimension(1:nv,1:ng,1:ng,1:km), intent(out) :: qb +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + real(kind=8), dimension(1:nv,1:ng,1:ng,1:ng), intent(out) :: qb +#endif /* NDIMS == 3 */ + +! local variables +! + integer :: i, j, k, p + integer :: il, jl, kl + integer :: iu, ju, ku + integer :: is, js, ks + integer :: it, jt, kt + integer :: im1, jm1, km1 + integer :: ip1, jp1, kp1 + real(kind=8) :: dql, dqr + real(kind=8) :: dqx, dqy, dqz + real(kind=8) :: dq1, dq2, dq3, dq4 +! +!------------------------------------------------------------------------------- +! +! prepare source corner region indices +! + if (ic == 1) then + il = ie - nh + 1 + iu = ie + else + il = ib + iu = ib + nh - 1 + end if + if (jc == 1) then + jl = je - nh + 1 + ju = je + else + jl = jb + ju = jb + nh - 1 + end if +#if NDIMS == 3 + if (kc == 1) then + kl = ke - nh + 1 + ku = ke + else + kl = kb + ku = kb + nh - 1 + end if +#endif /* NDIMS == 3 */ + +! interpolate and return corner region in the output array +! +#if NDIMS == 2 + do k = 1, km + kt = 1 +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + do k = kl, ku + km1 = k - 1 + kp1 = k + 1 + ks = 2 * (k - kl) + 1 + kt = ks + 1 +#endif /* NDIMS == 3 */ + do j = jl, ju + jm1 = j - 1 + jp1 = j + 1 + js = 2 * (j - jl) + 1 + jt = js + 1 + do i = il, iu + im1 = i - 1 + ip1 = i + 1 + is = 2 * (i - il) + 1 + it = is + 1 + +! iterate over all variables +! + do p = 1, nv + + dql = qn(p,i ,j,k) - qn(p,im1,j,k) + dqr = qn(p,ip1,j,k) - qn(p,i ,j,k) + dqx = limiter(0.25d+00, dql, dqr) + + dql = qn(p,i,j ,k) - qn(p,i,jm1,k) + dqr = qn(p,i,jp1,k) - qn(p,i,j ,k) + dqy = limiter(0.25d+00, dql, dqr) + +#if NDIMS == 3 + dql = qn(p,i,j,k ) - qn(p,i,j,km1) + dqr = qn(p,i,j,kp1) - qn(p,i,j,k ) + dqz = limiter(0.25d+00, dql, dqr) +#endif /* NDIMS == 3 */ + +#if NDIMS == 2 + dq1 = dqx + dqy + dq2 = dqx - dqy + qb(p,is,js,k ) = qn(p,i,j,k) - dq1 + qb(p,it,js,k ) = qn(p,i,j,k) + dq2 + qb(p,is,jt,k ) = qn(p,i,j,k) - dq2 + qb(p,it,jt,k ) = qn(p,i,j,k) + dq1 +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + dq1 = dqx + dqy + dqz + dq2 = dqx - dqy - dqz + dq3 = dqx - dqy + dqz + dq4 = dqx + dqy - dqz + qb(p,is,js,ks) = qn(p,i,j,k) - dq1 + qb(p,it,js,ks) = qn(p,i,j,k) + dq2 + qb(p,is,jt,ks) = qn(p,i,j,k) - dq3 + qb(p,it,jt,ks) = qn(p,i,j,k) + dq4 + qb(p,is,js,kt) = qn(p,i,j,k) - dq4 + qb(p,it,js,kt) = qn(p,i,j,k) + dq3 + qb(p,is,jt,kt) = qn(p,i,j,k) - dq2 + qb(p,it,jt,kt) = qn(p,i,j,k) + dq1 +#endif /* NDIMS == 3 */ + + end do ! q = 1, nv + + end do ! i = il, iu + end do ! j = jl, ju + end do ! k = kl, ku + +!------------------------------------------------------------------------------- +! + end subroutine block_corner_prolong +! +!=============================================================================== +! ! BLOCK FLUX UPDATE SUBROUTINES ! !=============================================================================== From 9254b5997a2cdc7683eaddb5c10e2c2218396ab2 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 15 Jul 2014 11:35:18 -0300 Subject: [PATCH 45/91] BOUNDARIES: Add subroutine boundaries_corner_prolong(). This subroutines scans over all leaf blocks and their corner neighbor pointers and updates corner boundary regions from neighbor at lower level. Signed-off-by: Grzegorz Kowal --- src/boundaries.F90 | 471 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 471 insertions(+) diff --git a/src/boundaries.F90 b/src/boundaries.F90 index fb3fd5b..fa80f6f 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -3707,6 +3707,477 @@ module boundaries ! !=============================================================================== ! +! subroutine BOUNDARIES_CORNER_PROLONG: +! ------------------------------------ +! +! Subroutine scans over all leaf blocks in order to find corner neighbors at +! different levels, and update the corner boundaries of blocks at higher +! levels by prolongating variables from lower level blocks. +! +! +!=============================================================================== +! + subroutine boundaries_corner_prolong() + +! import external procedures and variables +! + use blocks , only : nsides + use blocks , only : block_meta, block_data + use blocks , only : list_meta + use blocks , only : block_info, pointer_info + use coordinates , only : ng + use coordinates , only : im , jm , km + use coordinates , only : ibl, jbl, kbl + use coordinates , only : ieu, jeu, keu +#ifdef MPI + use equations , only : nv +#endif /* MPI */ + use mpitools , only : nproc, nprocs, npmax +#ifdef MPI + use mpitools , only : send_real_array, receive_real_array +#endif /* MPI */ + +! local variables are not implicit by default +! + implicit none + +! local pointers +! + type(block_meta), pointer :: pmeta, pneigh +#ifdef MPI + type(block_info), pointer :: pinfo +#endif /* MPI */ + +! local variables +! + integer :: i , j , k + integer :: il, jl, kl + integer :: iu, ju, ku + integer :: iret +#ifdef MPI + integer :: isend, irecv, nblocks, itag, l + +! local pointer arrays +! + type(pointer_info), dimension(0:npmax,0:npmax) :: block_array + +! local arrays +! + integer , dimension(0:npmax,0:npmax) :: block_counter + real(kind=8), dimension(:,:,:,:,:) , allocatable :: rbuf +#endif /* MPI */ +! +!------------------------------------------------------------------------------- +! +#ifdef PROFILE +! start accounting time for prolong boundary update +! + call start_timer(imp) +#endif /* PROFILE */ + +#ifdef MPI +!! 1. PREPARE THE BLOCK EXCHANGE ARRAYS FOR MPI +!! +! reset the exchange block counters +! + block_counter(:,:) = 0 + +! nullify the info pointers +! + do irecv = 0, npmax + do isend = 0, npmax + nullify(block_array(isend,irecv)%ptr) + end do + end do +#endif /* MPI */ + +!! 2. UPDATE VARIABLE CORNER BOUNDARIES BETWEEN BLOCKS BELONGING TO THE SAME +!! PROCESS AND PREPARE THE EXCHANGE BLOCK LIST OF BLOCKS WHICH BELONG TO +!! DIFFERENT PROCESSES +!! +! assign the pointer to the first block on the meta block list +! + pmeta => list_meta + +! scan all meta blocks and process blocks at the current level +! + do while(associated(pmeta)) + +! check if the block is leaf +! + if (pmeta%leaf) then + +! scan over all block corners +! +#if NDIMS == 3 + do k = 1, nsides +#endif /* NDIMS == 3 */ + do j = 1, nsides + do i = 1, nsides + +! assign pneigh to the current neighbor +! +#if NDIMS == 2 + pneigh => pmeta%corners(i,j)%ptr +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + pneigh => pmeta%corners(i,j,k)%ptr +#endif /* NDIMS == 3 */ + +! check if the neighbor is associated +! + if (associated(pneigh)) then + +! check if the neighbor lays at lower level +! + if (pneigh%level < pmeta%level) then + +! skip if the block and its neighbor are not marked for update +! + if (pmeta%update .and. pneigh%update) then + +! process only external corners +! +#if NDIMS == 2 + if (pneigh%corners(3-i,3-j)%ptr%id == pmeta%id) then +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + if (pneigh%corners(3-i,3-j,3-k)%ptr%id == pmeta%id) then +#endif /* NDIMS == 3 */ + +#ifdef MPI +! check if the block and its neighbor belong to the same process +! + if (pmeta%process == pneigh%process) then + +! check if the neighbor belongs to the current process +! + if (pmeta%process == nproc) then +#endif /* MPI */ + +! prepare the region indices for corner boundary update +! + if (i == 1) then + il = 1 + iu = ibl + else + il = ieu + iu = im + end if + if (j == 1) then + jl = 1 + ju = jbl + else + jl = jeu + ju = jm + end if +#if NDIMS == 3 + if (k == 1) then + kl = 1 + ku = kbl + else + kl = keu + ku = km + end if +#endif /* NDIMS == 3 */ + +! restrict and extract the corresponding corner region from the neighbor and +! insert it in the current data block +! +#if NDIMS == 2 + call block_corner_prolong(i, j, k & + , pneigh%data%q(1:nv, 1:im, 1:jm, 1:km) & + , pmeta%data%q(1:nv,il:iu,jl:ju, 1:km)) +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + call block_corner_prolong(i, j, k & + , pneigh%data%q(1:nv, 1:im, 1:jm, 1:km) & + , pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku)) +#endif /* NDIMS == 3 */ + +#ifdef MPI + end if ! block on the current processor + + else ! block and neighbor on different processors + +! increase the counter for number of blocks to exchange +! + block_counter(pneigh%process,pmeta%process) = & + block_counter(pneigh%process,pmeta%process) + 1 + +! allocate a new info object +! + allocate(pinfo) + +! fill out only fields which are used +! + pinfo%block => pmeta + pinfo%neigh => pneigh + pinfo%corner(1) = i + pinfo%corner(2) = j +#if NDIMS == 3 + pinfo%corner(3) = k +#endif /* NDIMS == 3 */ + +! nullify pointer fields of the object +! + nullify(pinfo%prev) + nullify(pinfo%next) + +! if the list is not empty append the newly created block to it +! + if (associated(block_array(pneigh%process & + ,pmeta%process)%ptr)) & + pinfo%prev => block_array(pneigh%process & + ,pmeta%process)%ptr + +! point the list to the newly created block +! + block_array(pneigh%process,pmeta%process)%ptr => pinfo + + end if ! block and neighbor on different processors +#endif /* MPI */ + end if ! only external corners + + end if ! pmeta and pneigh marked for update + + end if ! neighbor at lower level + + end if ! neighbor associated + + end do ! i = 1, nsides + end do ! j = 1, nsides +#if NDIMS == 3 + end do ! k = 1, nsides +#endif /* NDIMS == 3 */ + + end if ! leaf + +! assign the pointer to the next block on the list +! + pmeta => pmeta%next + + end do ! meta blocks + +#ifdef MPI +!! 3. UPDATE VARIABLE BOUNDARIES BETWEEN BLOCKS BELONGING TO DIFFERENT PROCESSES +!! +! iterate over sending and receiving processors +! + do irecv = 0, npmax + do isend = 0, npmax + +! process only pairs which have something to exchange +! + if (block_counter(isend,irecv) > 0) then + +! obtain the number of blocks to exchange +! + nblocks = block_counter(isend,irecv) + +! prepare the tag for communication +! + itag = 100 * (irecv * nprocs + isend + 1) + 13 + +! allocate data buffer for variables to exchange +! +#if NDIMS == 2 + allocate(rbuf(nblocks,nv,ng,ng,km)) +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + allocate(rbuf(nblocks,nv,ng,ng,ng)) +#endif /* NDIMS == 3 */ + +! if isend == nproc we are sending data from the neighbor block +! + if (isend == nproc) then + +! reset the block counter +! + l = 0 + +! associate the pointer with the first block in the exchange list +! + pinfo => block_array(isend,irecv)%ptr + +! scan over all blocks on the block exchange list +! + do while(associated(pinfo)) + +! increase the block counter +! + l = l + 1 + +! assign pneigh to the associated neighbor block +! + pneigh => pinfo%neigh + +! get the corner coordinates +! + i = pinfo%corner(1) + j = pinfo%corner(2) +#if NDIMS == 3 + k = pinfo%corner(3) +#endif /* NDIMS == 3 */ + +! restrict and extract the corresponding corner region from the neighbor and +! insert it to the buffer +! +#if NDIMS == 2 + call block_corner_prolong(i, j, k & + , pneigh%data%q(1:nv, 1:im, 1:jm, 1:km) & + , rbuf(l,1:nv,1:ng,1:ng,1:km)) +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + call block_corner_prolong(i, j, k & + , pneigh%data%q(1:nv, 1:im, 1:jm, 1:km) & + , rbuf(l,1:nv,1:ng,1:ng,1:ng)) +#endif /* NDIMS == 3 */ + +! associate the pointer with the next block +! + pinfo => pinfo%prev + + end do ! %ptr block list + +! send the data buffer to another process +! + call send_real_array(size(rbuf), irecv, itag, rbuf(:,:,:,:,:), iret) + + end if ! isend = nproc + +! if irecv == nproc we are receiving data from the neighbor block +! + if (irecv == nproc) then + +! receive the data buffer +! + call receive_real_array(size(rbuf(:,:,:,:,:)), isend, itag & + , rbuf(:,:,:,:,:), iret) + +! reset the block counter +! + l = 0 + +! associate the pointer with the first block in the exchange list +! + pinfo => block_array(isend,irecv)%ptr + +! iterate over all received blocks and update boundaries of the corresponding +! data blocks +! + do while(associated(pinfo)) + +! increase the block counter +! + l = l + 1 + +! assign a pointer to the associated data block +! + pmeta => pinfo%block + +! get the corner coordinates +! + i = pinfo%corner(1) + j = pinfo%corner(2) +#if NDIMS == 3 + k = pinfo%corner(3) +#endif /* NDIMS == 3 */ + +! calculate the insertion indices +! + if (i == 1) then + il = 1 + iu = ibl + else + il = ieu + iu = im + end if + if (j == 1) then + jl = 1 + ju = jbl + else + jl = jeu + ju = jm + end if +#if NDIMS == 3 + if (k == 1) then + kl = 1 + ku = kbl + else + kl = keu + ku = km + end if +#endif /* NDIMS == 3 */ + +! update the corresponding corner region of the current block +! +#if NDIMS == 2 + pmeta%data%q(1:nv,il:iu,jl:ju, 1:km) = rbuf(l,1:nv,1:ng,1:ng,1:km) +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = rbuf(l,1:nv,1:ng,1:ng,1:ng) +#endif /* NDIMS == 3 */ + +! associate the pointer with the next block +! + pinfo => pinfo%prev + + end do ! %ptr block list + + end if ! irecv = nproc + +! deallocate data buffer +! + if (allocated(rbuf)) deallocate(rbuf) + +! associate the pointer with the first block in the exchange list +! + pinfo => block_array(isend,irecv)%ptr + +! scan over all blocks on the exchange block list +! + do while(associated(pinfo)) + +! associate the exchange list pointer +! + block_array(isend,irecv)%ptr => pinfo%prev + +! nullify the pointer fields +! + nullify(pinfo%prev) + nullify(pinfo%next) + nullify(pinfo%block) + nullify(pinfo%neigh) + +! deallocate the object +! + deallocate(pinfo) + +! associate the pointer with the next block +! + pinfo => block_array(isend,irecv)%ptr + + end do ! %ptr block list + + end if ! if block_count > 0 + + end do ! isend + end do ! irecv +#endif /* MPI */ + +#ifdef PROFILE +! stop accounting time for prolong boundary update +! + call stop_timer(imp) +#endif /* PROFILE */ + +!------------------------------------------------------------------------------- +! + end subroutine boundaries_corner_prolong +! +!=============================================================================== +! ! BLOCK BOUNDARY UPDATE SUBROUTINES ! !=============================================================================== From 309eb2aad274cbadef3aae7dca3886257a7407f2 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 15 Jul 2014 11:36:17 -0300 Subject: [PATCH 46/91] BOUNDARIES: Call boundaries_corner_prolong() in boundary_variables(). Signed-off-by: Grzegorz Kowal --- src/boundaries.F90 | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/boundaries.F90 b/src/boundaries.F90 index fa80f6f..3a83ffc 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -354,6 +354,10 @@ module boundaries ! call boundaries_corner_restrict() +! prolong corner boundaries from blocks at lower levels +! + call boundaries_corner_prolong() + ! convert updated primitive variables to conservative ones in all ghost cells ! call update_ghost_cells() From 6dcf96f4ab56f19b9bbd37a5eeb3377c929c0156 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 15 Jul 2014 11:45:52 -0300 Subject: [PATCH 47/91] BOUNDARIES: Implement block_edge_copy(). This subroutines takes the variable array of the neighbor and extracts the edge region corresponding to the edge position. Signed-off-by: Grzegorz Kowal --- src/boundaries.F90 | 145 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 145 insertions(+) diff --git a/src/boundaries.F90 b/src/boundaries.F90 index 3a83ffc..f402bf5 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -4953,6 +4953,151 @@ module boundaries ! !=============================================================================== ! +! BLOCK EDGE UPDATE SUBROUTINES +! +!=============================================================================== +! +! subroutine BLOCK_EDGE_COPY: +! -------------------------- +! +! Subroutine returns the edge boundary region by copying the corresponding +! region from the provided input variable array. +! +! Arguments: +! +! nc - the edge direction; +! ic, jc, kc - the corner position; +! qn - the input neighbor variable array; +! qb - the output corner boundary array; +! +!=============================================================================== +! + subroutine block_edge_copy(nc, ic, jc, kc, qn, qb) + +! import external procedures and variables +! + use coordinates , only : ng + use coordinates , only : in , jn , kn + use coordinates , only : im , jm , km + use coordinates , only : ib , jb , kb + use coordinates , only : ie , je , ke + use coordinates , only : ibu, jbu, kbu + use coordinates , only : iel, jel, kel + use equations , only : nv + +! local variables are not implicit by default +! + implicit none + +! subroutine arguments +! + integer , intent(in) :: nc, ic, jc, kc + real(kind=8), dimension(1:nv,1:im,1:jm,1:km), intent(in) :: qn + real(kind=8), dimension( : , : , : , : ), intent(out) :: qb + +! local indices +! + integer :: il, jl, kl + integer :: iu, ju, ku +! +!------------------------------------------------------------------------------- +! +! depending on the direction +! + select case(nc) + case(1) + +! prepare source corner region indices +! + if (jc == 1) then + jl = jel + ju = je + else + jl = jb + ju = jbu + end if +#if NDIMS == 3 + if (kc == 1) then + kl = kel + ku = ke + else + kl = kb + ku = kbu + end if +#endif /* NDIMS == 3 */ + +! return corner region in the output array +! +#if NDIMS == 2 + qb(1:nv,1:in,1:ng,1:km) = qn(1:nv,ib:ie,jl:ju, 1:km) +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + qb(1:nv,1:in,1:ng,1:ng) = qn(1:nv,ib:ie,jl:ju,kl:ku) +#endif /* NDIMS == 3 */ + + case(2) + +! prepare source corner region indices +! + if (ic == 1) then + il = iel + iu = ie + else + il = ib + iu = ibu + end if +#if NDIMS == 3 + if (kc == 1) then + kl = kb + ku = kbu + else + kl = kel + ku = ke + end if +#endif /* NDIMS == 3 */ + +! return corner region in the output array +! +#if NDIMS == 2 + qb(1:nv,1:ng,1:jn,1:km) = qn(1:nv,il:iu,jb:je, 1:km) +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + qb(1:nv,1:ng,1:jn,1:ng) = qn(1:nv,il:iu,jb:je,kl:ku) +#endif /* NDIMS == 3 */ + +#if NDIMS == 3 + case(3) + +! prepare source corner region indices +! + if (ic == 1) then + il = iel + iu = ie + else + il = ib + iu = ibu + end if + if (jc == 1) then + jl = jel + ju = je + else + jl = jb + ju = jbu + end if + +! return corner region in the output array +! + qb(1:nv,1:ng,1:ng,1:kn) = qn(1:nv,il:iu,jl:ju,kb:ke) +#endif /* NDIMS == 3 */ + + end select + +!------------------------------------------------------------------------------- +! + end subroutine block_edge_copy +! +!=============================================================================== +! ! BLOCK CORNER UPDATE SUBROUTINES ! !=============================================================================== From 18abac963914d78cb4f7ff4daece82a251b2920d Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 15 Jul 2014 12:23:56 -0300 Subject: [PATCH 48/91] BOUNDARIES: Copy half of edge in block_edge_copy(). We copy just the half of the edge in block_edge_copy(), since another half is updated from a different corner. Signed-off-by: Grzegorz Kowal --- src/boundaries.F90 | 44 +++++++++++++++++++++++++++++++++++++++----- 1 file changed, 39 insertions(+), 5 deletions(-) diff --git a/src/boundaries.F90 b/src/boundaries.F90 index f402bf5..88117a9 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -4997,6 +4997,7 @@ module boundaries ! local indices ! + integer :: ih, jh, kh integer :: il, jl, kl integer :: iu, ju, ku ! @@ -5007,8 +5008,19 @@ module boundaries select case(nc) case(1) +! calculate half size +! + ih = in / 2 + ! prepare source corner region indices ! + if (ic == 1) then + il = ib + iu = ib + ih - 1 + else + il = ie - ih + 1 + iu = ie + end if if (jc == 1) then jl = jel ju = je @@ -5029,14 +5041,18 @@ module boundaries ! return corner region in the output array ! #if NDIMS == 2 - qb(1:nv,1:in,1:ng,1:km) = qn(1:nv,ib:ie,jl:ju, 1:km) + qb(1:nv,1:ih,1:ng,1:km) = qn(1:nv,il:iu,jl:ju, 1:km) #endif /* NDIMS == 2 */ #if NDIMS == 3 - qb(1:nv,1:in,1:ng,1:ng) = qn(1:nv,ib:ie,jl:ju,kl:ku) + qb(1:nv,1:ih,1:ng,1:ng) = qn(1:nv,il:iu,jl:ju,kl:ku) #endif /* NDIMS == 3 */ case(2) +! calculate half size +! + jh = jn / 2 + ! prepare source corner region indices ! if (ic == 1) then @@ -5046,6 +5062,13 @@ module boundaries il = ib iu = ibu end if + if (jc == 1) then + jl = jb + ju = jb + jh - 1 + else + jl = je - jh + 1 + ju = je + end if #if NDIMS == 3 if (kc == 1) then kl = kb @@ -5059,15 +5082,19 @@ module boundaries ! return corner region in the output array ! #if NDIMS == 2 - qb(1:nv,1:ng,1:jn,1:km) = qn(1:nv,il:iu,jb:je, 1:km) + qb(1:nv,1:ng,1:jh,1:km) = qn(1:nv,il:iu,jl:ju, 1:km) #endif /* NDIMS == 2 */ #if NDIMS == 3 - qb(1:nv,1:ng,1:jn,1:ng) = qn(1:nv,il:iu,jb:je,kl:ku) + qb(1:nv,1:ng,1:jh,1:ng) = qn(1:nv,il:iu,jl:ju,kl:ku) #endif /* NDIMS == 3 */ #if NDIMS == 3 case(3) +! calculate half size +! + kh = kn / 2 + ! prepare source corner region indices ! if (ic == 1) then @@ -5084,10 +5111,17 @@ module boundaries jl = jb ju = jbu end if + if (kc == 1) then + kl = kb + ku = kb + kh - 1 + else + kl = ke - kh + 1 + ku = ke + end if ! return corner region in the output array ! - qb(1:nv,1:ng,1:ng,1:kn) = qn(1:nv,il:iu,jl:ju,kb:ke) + qb(1:nv,1:ng,1:ng,1:kh) = qn(1:nv,il:iu,jl:ju,kl:ku) #endif /* NDIMS == 3 */ end select From 59f7ab45f05609eea6a86c5bf305949f21eaf3d6 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 15 Jul 2014 12:27:53 -0300 Subject: [PATCH 49/91] BOUNDARIES: Add subroutine boundaries_edge_copy(). This subroutines scans over all leaf blocks and their edge neighbor pointers and updates edge boundary regions from neighbor at lower level. Signed-off-by: Grzegorz Kowal --- src/boundaries.F90 | 579 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 579 insertions(+) diff --git a/src/boundaries.F90 b/src/boundaries.F90 index 88117a9..5a3206e 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -2790,6 +2790,585 @@ module boundaries ! !=============================================================================== ! +! subroutine BOUNDARIES_EDGE_COPY: +! ------------------------------- +! +! Subroutine scans over all leaf blocks in order to find corner neighbors at +! the same level, and perform the update of the corner boundaries between +! them. +! +! Arguments: +! +! idir - the direction to be processed; +! +!=============================================================================== +! + subroutine boundaries_edge_copy(idir) + +! import external procedures and variables +! + use blocks , only : nsides + use blocks , only : block_meta, block_data + use blocks , only : list_meta + use blocks , only : block_info, pointer_info + use coordinates , only : ng + use coordinates , only : in , jn , kn + use coordinates , only : im , jm , km + use coordinates , only : ib , jb , kb + use coordinates , only : ie , je , ke + use coordinates , only : ibl, jbl, kbl + use coordinates , only : ieu, jeu, keu +#ifdef MPI + use equations , only : nv +#endif /* MPI */ + use mpitools , only : nproc, nprocs, npmax +#ifdef MPI + use mpitools , only : send_real_array, receive_real_array +#endif /* MPI */ + +! local variables are not implicit by default +! + implicit none + +! subroutine arguments +! + integer, intent(in) :: idir + +! local pointers +! + type(block_meta), pointer :: pmeta, pneigh +#ifdef MPI + type(block_info), pointer :: pinfo +#endif /* MPI */ + +! local variables +! + integer :: i , j , k + integer :: ih, jh, kh + integer :: il, jl, kl + integer :: iu, ju, ku + integer :: iret +#ifdef MPI + integer :: isend, irecv, nblocks, itag, l + +! local pointer arrays +! + type(pointer_info), dimension(0:npmax,0:npmax) :: block_array + +! local arrays +! + integer , dimension(0:npmax,0:npmax) :: block_counter + real(kind=8), dimension(:,:,:,:,:) , allocatable :: rbuf +#endif /* MPI */ +! +!------------------------------------------------------------------------------- +! +#ifdef PROFILE +! start accounting time for copy boundary update +! + call start_timer(imc) +#endif /* PROFILE */ + +! calculate half sizes +! + ih = in / 2 + jh = jn / 2 +#if NDIMS == 3 + kh = kn / 2 +#endif /* NDIMS == 3 */ + +#ifdef MPI +!! 1. PREPARE THE BLOCK EXCHANGE ARRAYS FOR MPI +!! +! reset the exchange block counters +! + block_counter(:,:) = 0 + +! nullify the info pointers +! + do irecv = 0, npmax + do isend = 0, npmax + nullify(block_array(isend,irecv)%ptr) + end do + end do +#endif /* MPI */ + +!! 2. UPDATE VARIABLE CORNER BOUNDARIES BETWEEN BLOCKS BELONGING TO THE SAME +!! PROCESS AND PREPARE THE EXCHANGE BLOCK LIST OF BLOCKS WHICH BELONG TO +!! DIFFERENT PROCESSES +!! +! assign the pointer to the first block on the meta block list +! + pmeta => list_meta + +! scan all meta blocks and process blocks at the current level +! + do while(associated(pmeta)) + +! check if the block is leaf +! + if (pmeta%leaf) then + +! scan over all block corners +! +#if NDIMS == 3 + do k = 1, nsides +#endif /* NDIMS == 3 */ + do j = 1, nsides + do i = 1, nsides + +! assign pneigh to the current neighbor +! +#if NDIMS == 2 + pneigh => pmeta%edges(i,j,idir)%ptr +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + pneigh => pmeta%edges(i,j,k,idir)%ptr +#endif /* NDIMS == 3 */ + +! check if the neighbor is associated +! + if (associated(pneigh)) then + +! check if the neighbor is at the same level +! + if (pneigh%level == pmeta%level) then + +! skip if the block and its neighbor are not marked for update +! + if (pmeta%update .and. pneigh%update) then + +#ifdef MPI +! check if the block and its neighbor belong to the same process +! + if (pmeta%process == pneigh%process) then + +! check if the neighbor belongs to the current process +! + if (pmeta%process == nproc) then +#endif /* MPI */ + +! prepare the region indices for edge boundary update +! + if (i == 1) then + il = 1 + iu = ibl + else + il = ieu + iu = im + end if + if (j == 1) then + jl = 1 + ju = jbl + else + jl = jeu + ju = jm + end if +#if NDIMS == 3 + if (k == 1) then + kl = 1 + ku = kbl + else + kl = keu + ku = km + end if +#endif /* NDIMS == 3 */ + +! extract the corresponding edge region from the neighbor and insert it in +! the current data block +! + select case(idir) + case(1) + if (i == 1) then + il = ib + iu = ib + ih - 1 + else + il = ie - ih + 1 + iu = ie + end if + case(2) + if (j == 1) then + jl = jb + ju = jb + jh - 1 + else + jl = je - jh + 1 + ju = je + end if +#if NDIMS == 3 + case(3) + if (k == 1) then + kl = kb + ku = kb + kh - 1 + else + kl = ke - kh + 1 + ku = ke + end if +#endif /* NDIMS == 3 */ + end select +#if NDIMS == 2 + call block_edge_copy(idir, i, j, k & + , pneigh%data%q(1:nv, 1:im, 1:jm, 1:km) & + , pmeta%data%q(1:nv,il:iu,jl:ju, 1:km)) +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + call block_edge_copy(idir, i, j, k & + , pneigh%data%q(1:nv, 1:im, 1:jm, 1:km) & + , pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku)) +#endif /* NDIMS == 3 */ + +#ifdef MPI + end if ! pneigh on the current process + + else ! block and neighbor belong to different processes + +! increase the counter for number of blocks to exchange +! + block_counter(pneigh%process,pmeta%process) = & + block_counter(pneigh%process,pmeta%process) + 1 + +! allocate a new info object +! + allocate(pinfo) + +! fill out only fields which are used +! + pinfo%block => pmeta + pinfo%neigh => pneigh + pinfo%direction = idir + pinfo%corner(1) = i + pinfo%corner(2) = j +#if NDIMS == 3 + pinfo%corner(3) = k +#endif /* NDIMS == 3 */ + +! nullify pointer fields of the object +! + nullify(pinfo%prev) + nullify(pinfo%next) + +! if the list is not empty append the newly created block to it +! + if (associated(block_array(pneigh%process & + ,pmeta%process)%ptr)) & + pinfo%prev => block_array(pneigh%process & + ,pmeta%process)%ptr + +! point the list to the newly created block +! + block_array(pneigh%process,pmeta%process)%ptr => pinfo + + end if ! block and neighbor belong to different processes +#endif /* MPI */ + + end if ! pmeta and pneigh marked for update + + end if ! neighbor at the same level + + end if ! neighbor associated + + end do ! i = 1, nsides + end do ! j = 1, nsides +#if NDIMS == 3 + end do ! k = 1, nsides +#endif /* NDIMS == 3 */ + + end if ! leaf + +! associate the pointer to the next meta block +! + pmeta => pmeta%next + + end do ! meta blocks + +#ifdef MPI +!! 3. UPDATE VARIABLE BOUNDARIES BETWEEN BLOCKS BELONGING TO DIFFERENT PROCESSES +!! +! iterate over sending and receiving processors +! + do irecv = 0, npmax + do isend = 0, npmax + +! process only pairs which have something to exchange +! + if (block_counter(isend,irecv) > 0) then + +! obtain the number of blocks to exchange +! + nblocks = block_counter(isend,irecv) + +! prepare the tag for communication +! + itag = 100 * (irecv * nprocs + isend + 1) + 21 + +! allocate data buffer for variables to exchange +! + select case(idir) +#if NDIMS == 2 + case(1) + allocate(rbuf(nblocks,nv,ih,ng,km)) + case(2) + allocate(rbuf(nblocks,nv,ng,jh,km)) +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + case(1) + allocate(rbuf(nblocks,nv,ih,ng,ng)) + case(2) + allocate(rbuf(nblocks,nv,ng,jh,ng)) + case(3) + allocate(rbuf(nblocks,nv,ng,ng,kh)) +#endif /* NDIMS == 3 */ + end select + +! if isend == nproc we are sending data from the neighbor block +! + if (isend == nproc) then + +! reset the block counter +! + l = 0 + +! associate the pointer with the first block in the exchange list +! + pinfo => block_array(isend,irecv)%ptr + +! scan over all blocks on the block exchange list +! + do while(associated(pinfo)) + +! increase the block counter +! + l = l + 1 + +! assign pneigh to the associated neighbor block +! + pneigh => pinfo%neigh + +! get the corner coordinates +! + i = pinfo%corner(1) + j = pinfo%corner(2) +#if NDIMS == 3 + k = pinfo%corner(3) +#endif /* NDIMS == 3 */ + +! extract the corresponding edge region from the neighbor and insert it +! to the buffer +! + select case(idir) + case(1) +#if NDIMS == 2 + call block_edge_copy(idir, i, j, k & + , pneigh%data%q(1:nv,1:im,1:jm,1:km) & + , rbuf(l,1:nv,1:ih,1:ng,1:km)) +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + call block_edge_copy(idir, i, j, k & + , pneigh%data%q(1:nv,1:im,1:jm,1:km) & + , rbuf(l,1:nv,1:ih,1:ng,1:ng)) +#endif /* NDIMS == 3 */ + case(2) +#if NDIMS == 2 + call block_edge_copy(idir, i, j, k & + , pneigh%data%q(1:nv,1:im,1:jm,1:km) & + , rbuf(l,1:nv,1:ng,1:jh,1:km)) +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + call block_edge_copy(idir, i, j, k & + , pneigh%data%q(1:nv,1:im,1:jm,1:km) & + , rbuf(l,1:nv,1:ng,1:jh,1:ng)) +#endif /* NDIMS == 3 */ +#if NDIMS == 3 + case(3) + call block_edge_copy(idir, i, j, k & + , pneigh%data%q(1:nv,1:im,1:jm,1:km) & + , rbuf(l,1:nv,1:ng,1:ng,1:kh)) +#endif /* NDIMS == 3 */ + end select + +! associate the pointer with the next block +! + pinfo => pinfo%prev + + end do ! %ptr block list + +! send the data buffer to another process +! + call send_real_array(size(rbuf), irecv, itag, rbuf(:,:,:,:,:), iret) + + end if ! isend = nproc + +! if irecv == nproc we are receiving data from the neighbor block +! + if (irecv == nproc) then + +! receive the data buffer +! + call receive_real_array(size(rbuf(:,:,:,:,:)), isend, itag & + , rbuf(:,:,:,:,:), iret) + +! reset the block counter +! + l = 0 + +! associate the pointer with the first block in the exchange list +! + pinfo => block_array(isend,irecv)%ptr + +! iterate over all received blocks and update boundaries of the corresponding +! data blocks +! + do while(associated(pinfo)) + +! increase the block counter +! + l = l + 1 + +! assign a pointer to the associated data block +! + pmeta => pinfo%block + +! get the corner coordinates +! + i = pinfo%corner(1) + j = pinfo%corner(2) +#if NDIMS == 3 + k = pinfo%corner(3) +#endif /* NDIMS == 3 */ + +! calculate the insertion indices +! + if (i == 1) then + il = 1 + iu = ibl + else + il = ieu + iu = im + end if + if (j == 1) then + jl = 1 + ju = jbl + else + jl = jeu + ju = jm + end if +#if NDIMS == 3 + if (k == 1) then + kl = 1 + ku = kbl + else + kl = keu + ku = km + end if +#endif /* NDIMS == 3 */ + +! update the corresponding corner region of the current block +! + select case(idir) + case(1) + if (i == 1) then + il = ib + iu = ib + ih - 1 + else + il = ie - ih + 1 + iu = ie + end if +#if NDIMS == 2 + pmeta%data%q(1:nv,il:iu,jl:ju, 1:km) = & + rbuf(l,1:nv,1:ih,1:ng,1:km) +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = & + rbuf(l,1:nv,1:ih,1:ng,1:ng) +#endif /* NDIMS == 3 */ + case(2) + if (j == 1) then + jl = jb + ju = jb + jh - 1 + else + jl = je - jh + 1 + ju = je + end if +#if NDIMS == 2 + pmeta%data%q(1:nv,il:iu,jl:ju, 1:km) = & + rbuf(l,1:nv,1:ng,1:jh,1:km) +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = & + rbuf(l,1:nv,1:ng,1:jh,1:ng) +#endif /* NDIMS == 3 */ +#if NDIMS == 3 + case(3) + if (k == 1) then + kl = kb + ku = kb + kh - 1 + else + kl = ke - kh + 1 + ku = ke + end if + pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = & + rbuf(l,1:nv,1:ng,1:ng,1:kh) +#endif /* NDIMS == 3 */ + end select + +! associate the pointer with the next block +! + pinfo => pinfo%prev + + end do ! %ptr block list + + end if ! irecv = nproc + +! deallocate data buffer +! + if (allocated(rbuf)) deallocate(rbuf) + +! associate the pointer with the first block in the exchange list +! + pinfo => block_array(isend,irecv)%ptr + +! scan over all blocks on the exchange block list +! + do while(associated(pinfo)) + +! associate the exchange list pointer +! + block_array(isend,irecv)%ptr => pinfo%prev + +! nullify the pointer fields +! + nullify(pinfo%prev) + nullify(pinfo%next) + nullify(pinfo%block) + nullify(pinfo%neigh) + +! deallocate the object +! + deallocate(pinfo) + +! associate the pointer with the next block +! + pinfo => block_array(isend,irecv)%ptr + + end do ! %ptr block list + + end if ! if block_count > 0 + + end do ! isend + end do ! irecv +#endif /* MPI */ + +#ifdef PROFILE +! stop accounting time for copy boundary update +! + call stop_timer(imc) +#endif /* PROFILE */ + +!------------------------------------------------------------------------------- +! + end subroutine boundaries_edge_copy +! +!=============================================================================== +! ! subroutine BOUNDARIES_CORNER_COPY: ! --------------------------------- ! From d2130c5cc6a7b2c82e9e1680ba0aa20610679de6 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 15 Jul 2014 12:29:26 -0300 Subject: [PATCH 50/91] BOUNDARIES: Call boundaries_edge_copy() in boundary_variables(). Signed-off-by: Grzegorz Kowal --- src/boundaries.F90 | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/boundaries.F90 b/src/boundaries.F90 index 5a3206e..31841c4 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -346,6 +346,12 @@ module boundaries ! call update_corners() +! update edge boundaries between blocks at the same levels +! + do idir = 1, ndims + call boundaries_edge_copy(idir) + end do ! idir + ! update corner boundaries between blocks at the same levels ! call boundaries_corner_copy() From 110c29a487d804c04b9f667e6efb49b90a222aed Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 15 Jul 2014 12:38:54 -0300 Subject: [PATCH 51/91] BOUNDARIES: Implement block_edge_restrict(). This subroutines takes the variable array of the neighbor, restricts it and extracts the edge region corresponding to the edge position. Signed-off-by: Grzegorz Kowal --- src/boundaries.F90 | 221 +++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 214 insertions(+), 7 deletions(-) diff --git a/src/boundaries.F90 b/src/boundaries.F90 index 31841c4..f66052e 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -5553,7 +5553,7 @@ module boundaries ! nc - the edge direction; ! ic, jc, kc - the corner position; ! qn - the input neighbor variable array; -! qb - the output corner boundary array; +! qb - the output edge boundary array; ! !=============================================================================== ! @@ -5597,7 +5597,7 @@ module boundaries ! ih = in / 2 -! prepare source corner region indices +! prepare source edge region indices ! if (ic == 1) then il = ib @@ -5623,7 +5623,7 @@ module boundaries end if #endif /* NDIMS == 3 */ -! return corner region in the output array +! return edge region in the output array ! #if NDIMS == 2 qb(1:nv,1:ih,1:ng,1:km) = qn(1:nv,il:iu,jl:ju, 1:km) @@ -5638,7 +5638,7 @@ module boundaries ! jh = jn / 2 -! prepare source corner region indices +! prepare source edge region indices ! if (ic == 1) then il = iel @@ -5664,7 +5664,7 @@ module boundaries end if #endif /* NDIMS == 3 */ -! return corner region in the output array +! return edge region in the output array ! #if NDIMS == 2 qb(1:nv,1:ng,1:jh,1:km) = qn(1:nv,il:iu,jl:ju, 1:km) @@ -5680,7 +5680,7 @@ module boundaries ! kh = kn / 2 -! prepare source corner region indices +! prepare source edge region indices ! if (ic == 1) then il = iel @@ -5704,7 +5704,7 @@ module boundaries ku = ke end if -! return corner region in the output array +! return edge region in the output array ! qb(1:nv,1:ng,1:ng,1:kh) = qn(1:nv,il:iu,jl:ju,kl:ku) #endif /* NDIMS == 3 */ @@ -5717,6 +5717,213 @@ module boundaries ! !=============================================================================== ! +! subroutine BLOCK_EDGE_RESTRICT: +! ------------------------------ +! +! Subroutine returns the edge boundary region by restricting the corresponding +! region from the provided input variable array. +! +! Arguments: +! +! nc - the edge direction; +! ic, jc, kc - the corner position; +! qn - the input neighbor variable array; +! qb - the output edge boundary array; +! +!=============================================================================== +! + subroutine block_edge_restrict(nc, ic, jc, kc, qn, qb) + +! import external procedures and variables +! + use coordinates , only : ng, nd + use coordinates , only : in + use coordinates , only : in , jn , kn + use coordinates , only : im , jm , km + use coordinates , only : ib , jb , kb + use coordinates , only : ie , je , ke + use equations , only : nv + +! local variables are not implicit by default +! + implicit none + +! subroutine arguments +! + integer , intent(in) :: nc, ic, jc, kc + real(kind=8), dimension(1:nv,1:im,1:jm,1:km), intent(in) :: qn + real(kind=8), dimension( : , : , : , : ), intent(out) :: qb + +! local variables +! + integer :: ih, jh, kh + integer :: il, jl, kl + integer :: ip, jp, kp + integer :: iu, ju, ku +! +!------------------------------------------------------------------------------- +! +! depending on the direction +! + select case(nc) + case(1) + +! calculate half size +! + ih = in / 2 + +! prepare source edge region indices +! + il = ib + ip = il + 1 + iu = ie + if (jc == 1) then + jl = je - nd + 1 + jp = jl + 1 + ju = je + else + jl = jb + jp = jl + 1 + ju = jb + nd - 1 + end if +#if NDIMS == 3 + if (kc == 1) then + kl = ke - nd + 1 + kp = kl + 1 + ku = ke + else + kl = kb + kp = kl + 1 + ku = kb + nd - 1 + end if +#endif /* NDIMS == 3 */ + +! return edge region in the output array +! +#if NDIMS == 2 + qb(1:nv,1:ih,1:ng,1:km) = & + 2.50d-01 * ((qn(1:nv,il:iu:2,jl:ju:2, 1:km ) & + + qn(1:nv,ip:iu:2,jp:ju:2, 1:km )) & + + (qn(1:nv,il:iu:2,jp:ju:2, 1:km ) & + + qn(1:nv,ip:iu:2,jl:ju:2, 1:km ))) +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + qb(1:nv,1:ih,1:ng,1:ng) = & + 1.25d-01 * (((qn(1:nv,il:iu:2,jl:ju:2,kl:ku:2) & + + qn(1:nv,ip:iu:2,jp:ju:2,kp:ku:2)) & + + (qn(1:nv,il:iu:2,jl:ju:2,kp:ku:2) & + + qn(1:nv,ip:iu:2,jp:ju:2,kl:ku:2))) & + + ((qn(1:nv,il:iu:2,jp:ju:2,kp:ku:2) & + + qn(1:nv,ip:iu:2,jl:ju:2,kl:ku:2)) & + + (qn(1:nv,il:iu:2,jp:ju:2,kl:ku:2) & + + qn(1:nv,ip:iu:2,jl:ju:2,kp:ku:2)))) +#endif /* NDIMS == 3 */ + + case(2) + +! calculate half size +! + jh = jn / 2 + +! prepare source edge region indices +! + if (ic == 1) then + il = ie - nd + 1 + ip = il + 1 + iu = ie + else + il = ib + ip = il + 1 + iu = ib + nd - 1 + end if + jl = jb + jp = jl + 1 + ju = je +#if NDIMS == 3 + if (kc == 1) then + kl = ke - nd + 1 + kp = kl + 1 + ku = ke + else + kl = kb + kp = kl + 1 + ku = kb + nd - 1 + end if +#endif /* NDIMS == 3 */ + +! return edge region in the output array +! +#if NDIMS == 2 + qb(1:nv,1:ng,1:jh,1:km) = & + 2.50d-01 * ((qn(1:nv,il:iu:2,jl:ju:2, 1:km ) & + + qn(1:nv,ip:iu:2,jp:ju:2, 1:km )) & + + (qn(1:nv,il:iu:2,jp:ju:2, 1:km ) & + + qn(1:nv,ip:iu:2,jl:ju:2, 1:km ))) +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + qb(1:nv,1:ng,1:jh,1:ng) = & + 1.25d-01 * (((qn(1:nv,il:iu:2,jl:ju:2,kl:ku:2) & + + qn(1:nv,ip:iu:2,jp:ju:2,kp:ku:2)) & + + (qn(1:nv,il:iu:2,jl:ju:2,kp:ku:2) & + + qn(1:nv,ip:iu:2,jp:ju:2,kl:ku:2))) & + + ((qn(1:nv,il:iu:2,jp:ju:2,kp:ku:2) & + + qn(1:nv,ip:iu:2,jl:ju:2,kl:ku:2)) & + + (qn(1:nv,il:iu:2,jp:ju:2,kl:ku:2) & + + qn(1:nv,ip:iu:2,jl:ju:2,kp:ku:2)))) +#endif /* NDIMS == 3 */ + +#if NDIMS == 3 + case(3) + +! calculate half size +! + kh = kn / 2 + +! prepare source edge region indices +! + if (ic == 1) then + il = ie - nd + 1 + ip = il + 1 + iu = ie + else + il = ib + ip = il + 1 + iu = ib + nd - 1 + end if + if (jc == 1) then + jl = je - nd + 1 + jp = jl + 1 + ju = je + else + jl = jb + jp = jl + 1 + ju = jb + nd - 1 + end if + kl = kb + kp = kl + 1 + ku = ke + +! return edge region in the output array +! + qb(1:nv,1:ng,1:ng,1:kh) = & + 1.25d-01 * (((qn(1:nv,il:iu:2,jl:ju:2,kl:ku:2) & + + qn(1:nv,ip:iu:2,jp:ju:2,kp:ku:2)) & + + (qn(1:nv,il:iu:2,jl:ju:2,kp:ku:2) & + + qn(1:nv,ip:iu:2,jp:ju:2,kl:ku:2))) & + + ((qn(1:nv,il:iu:2,jp:ju:2,kp:ku:2) & + + qn(1:nv,ip:iu:2,jl:ju:2,kl:ku:2)) & + + (qn(1:nv,il:iu:2,jp:ju:2,kl:ku:2) & + + qn(1:nv,ip:iu:2,jl:ju:2,kp:ku:2)))) +#endif /* NDIMS == 3 */ + + end select + +!------------------------------------------------------------------------------- +! + end subroutine block_edge_restrict +! +!=============================================================================== +! ! BLOCK CORNER UPDATE SUBROUTINES ! !=============================================================================== From 3ef963eda4720038beb7aac49a66f24abb8ecc04 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 15 Jul 2014 12:48:52 -0300 Subject: [PATCH 52/91] BOUNDARIES: Add subroutine boundaries_edge_restrict(). This subroutines scans over all leaf blocks and their edge neighbor pointers and updates edge boundary regions from neighbors at higher level. Signed-off-by: Grzegorz Kowal --- src/boundaries.F90 | 579 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 579 insertions(+) diff --git a/src/boundaries.F90 b/src/boundaries.F90 index f66052e..7a28a95 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -3375,6 +3375,585 @@ module boundaries ! !=============================================================================== ! +! subroutine BOUNDARIES_EDGE_RESTRICT: +! ----------------------------------- +! +! Subroutine scans over all leaf blocks in order to find edge neighbors at +! the different levels, and perform the update of the edge boundaries between +! them. +! +! Arguments: +! +! idir - the direction to be processed; +! +!=============================================================================== +! + subroutine boundaries_edge_restrict(idir) + +! import external procedures and variables +! + use blocks , only : nsides + use blocks , only : block_meta, block_data + use blocks , only : list_meta + use blocks , only : block_info, pointer_info + use coordinates , only : ng + use coordinates , only : in , jn , kn + use coordinates , only : im , jm , km + use coordinates , only : ib , jb , kb + use coordinates , only : ie , je , ke + use coordinates , only : ibl, jbl, kbl + use coordinates , only : ieu, jeu, keu +#ifdef MPI + use equations , only : nv +#endif /* MPI */ + use mpitools , only : nproc, nprocs, npmax +#ifdef MPI + use mpitools , only : send_real_array, receive_real_array +#endif /* MPI */ + +! local variables are not implicit by default +! + implicit none + +! subroutine arguments +! + integer, intent(in) :: idir + +! local pointers +! + type(block_meta), pointer :: pmeta, pneigh +#ifdef MPI + type(block_info), pointer :: pinfo +#endif /* MPI */ + +! local variables +! + integer :: i , j , k + integer :: ih, jh, kh + integer :: il, jl, kl + integer :: iu, ju, ku + integer :: iret +#ifdef MPI + integer :: isend, irecv, nblocks, itag, l + +! local pointer arrays +! + type(pointer_info), dimension(0:npmax,0:npmax) :: block_array + +! local arrays +! + integer , dimension(0:npmax,0:npmax) :: block_counter + real(kind=8), dimension(:,:,:,:,:) , allocatable :: rbuf +#endif /* MPI */ +! +!------------------------------------------------------------------------------- +! +#ifdef PROFILE +! start accounting time for restrict boundary update +! + call start_timer(imr) +#endif /* PROFILE */ + +! calculate half sizes +! + ih = in / 2 + jh = jn / 2 +#if NDIMS == 3 + kh = kn / 2 +#endif /* NDIMS == 3 */ + +#ifdef MPI +!! 1. PREPARE THE BLOCK EXCHANGE ARRAYS FOR MPI +!! +! reset the exchange block counters +! + block_counter(:,:) = 0 + +! nullify the info pointers +! + do irecv = 0, npmax + do isend = 0, npmax + nullify(block_array(isend,irecv)%ptr) + end do + end do +#endif /* MPI */ + +!! 2. UPDATE VARIABLE EDGE BOUNDARIES BETWEEN BLOCKS BELONGING TO DIFFERENT +!! PROCESS AND PREPARE THE EXCHANGE BLOCK LIST OF BLOCKS WHICH BELONG TO +!! DIFFERENT PROCESSES +!! +! assign the pointer to the first block on the meta block list +! + pmeta => list_meta + +! scan all meta blocks and process blocks at the current level +! + do while(associated(pmeta)) + +! check if the block is leaf +! + if (pmeta%leaf) then + +! scan over all block corners +! +#if NDIMS == 3 + do k = 1, nsides +#endif /* NDIMS == 3 */ + do j = 1, nsides + do i = 1, nsides + +! assign pneigh to the current neighbor +! +#if NDIMS == 2 + pneigh => pmeta%edges(i,j,idir)%ptr +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + pneigh => pmeta%edges(i,j,k,idir)%ptr +#endif /* NDIMS == 3 */ + +! check if the neighbor is associated +! + if (associated(pneigh)) then + +! check if the neighbor is at higher level +! + if (pneigh%level > pmeta%level) then + +! skip if the block and its neighbor are not marked for update +! + if (pmeta%update .and. pneigh%update) then + +#ifdef MPI +! check if the block and its neighbor belong to the same process +! + if (pmeta%process == pneigh%process) then + +! check if the neighbor belongs to the current process +! + if (pmeta%process == nproc) then +#endif /* MPI */ + +! prepare the region indices for edge boundary update +! + if (i == 1) then + il = 1 + iu = ibl + else + il = ieu + iu = im + end if + if (j == 1) then + jl = 1 + ju = jbl + else + jl = jeu + ju = jm + end if +#if NDIMS == 3 + if (k == 1) then + kl = 1 + ku = kbl + else + kl = keu + ku = km + end if +#endif /* NDIMS == 3 */ + +! extract the corresponding edge region from the neighbor and insert it in +! the current data block +! + select case(idir) + case(1) + if (i == 1) then + il = ib + iu = ib + ih - 1 + else + il = ie - ih + 1 + iu = ie + end if + case(2) + if (j == 1) then + jl = jb + ju = jb + jh - 1 + else + jl = je - jh + 1 + ju = je + end if +#if NDIMS == 3 + case(3) + if (k == 1) then + kl = kb + ku = kb + kh - 1 + else + kl = ke - kh + 1 + ku = ke + end if +#endif /* NDIMS == 3 */ + end select +#if NDIMS == 2 + call block_edge_restrict(idir, i, j, k & + , pneigh%data%q(1:nv, 1:im, 1:jm, 1:km) & + , pmeta%data%q(1:nv,il:iu,jl:ju, 1:km)) +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + call block_edge_restrict(idir, i, j, k & + , pneigh%data%q(1:nv, 1:im, 1:jm, 1:km) & + , pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku)) +#endif /* NDIMS == 3 */ + +#ifdef MPI + end if ! pneigh on the current process + + else ! block and neighbor belong to different processes + +! increase the counter for number of blocks to exchange +! + block_counter(pneigh%process,pmeta%process) = & + block_counter(pneigh%process,pmeta%process) + 1 + +! allocate a new info object +! + allocate(pinfo) + +! fill out only fields which are used +! + pinfo%block => pmeta + pinfo%neigh => pneigh + pinfo%direction = idir + pinfo%corner(1) = i + pinfo%corner(2) = j +#if NDIMS == 3 + pinfo%corner(3) = k +#endif /* NDIMS == 3 */ + +! nullify pointer fields of the object +! + nullify(pinfo%prev) + nullify(pinfo%next) + +! if the list is not empty append the newly created block to it +! + if (associated(block_array(pneigh%process & + ,pmeta%process)%ptr)) & + pinfo%prev => block_array(pneigh%process & + ,pmeta%process)%ptr + +! point the list to the newly created block +! + block_array(pneigh%process,pmeta%process)%ptr => pinfo + + end if ! block and neighbor belong to different processes +#endif /* MPI */ + + end if ! pmeta and pneigh marked for update + + end if ! neighbor at the same level + + end if ! neighbor associated + + end do ! i = 1, nsides + end do ! j = 1, nsides +#if NDIMS == 3 + end do ! k = 1, nsides +#endif /* NDIMS == 3 */ + + end if ! leaf + +! associate the pointer to the next meta block +! + pmeta => pmeta%next + + end do ! meta blocks + +#ifdef MPI +!! 3. UPDATE VARIABLE BOUNDARIES BETWEEN BLOCKS BELONGING TO DIFFERENT PROCESSES +!! +! iterate over sending and receiving processors +! + do irecv = 0, npmax + do isend = 0, npmax + +! process only pairs which have something to exchange +! + if (block_counter(isend,irecv) > 0) then + +! obtain the number of blocks to exchange +! + nblocks = block_counter(isend,irecv) + +! prepare the tag for communication +! + itag = 100 * (irecv * nprocs + isend + 1) + 22 + +! allocate data buffer for variables to exchange +! + select case(idir) +#if NDIMS == 2 + case(1) + allocate(rbuf(nblocks,nv,ih,ng,km)) + case(2) + allocate(rbuf(nblocks,nv,ng,jh,km)) +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + case(1) + allocate(rbuf(nblocks,nv,ih,ng,ng)) + case(2) + allocate(rbuf(nblocks,nv,ng,jh,ng)) + case(3) + allocate(rbuf(nblocks,nv,ng,ng,kh)) +#endif /* NDIMS == 3 */ + end select + +! if isend == nproc we are sending data from the neighbor block +! + if (isend == nproc) then + +! reset the block counter +! + l = 0 + +! associate the pointer with the first block in the exchange list +! + pinfo => block_array(isend,irecv)%ptr + +! scan over all blocks on the block exchange list +! + do while(associated(pinfo)) + +! increase the block counter +! + l = l + 1 + +! assign pneigh to the associated neighbor block +! + pneigh => pinfo%neigh + +! get the corner coordinates +! + i = pinfo%corner(1) + j = pinfo%corner(2) +#if NDIMS == 3 + k = pinfo%corner(3) +#endif /* NDIMS == 3 */ + +! extract the corresponding edge region from the neighbor and insert it +! to the buffer +! + select case(idir) + case(1) +#if NDIMS == 2 + call block_edge_restrict(idir, i, j, k & + , pneigh%data%q(1:nv,1:im,1:jm,1:km) & + , rbuf(l,1:nv,1:ih,1:ng,1:km)) +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + call block_edge_restrict(idir, i, j, k & + , pneigh%data%q(1:nv,1:im,1:jm,1:km) & + , rbuf(l,1:nv,1:ih,1:ng,1:ng)) +#endif /* NDIMS == 3 */ + case(2) +#if NDIMS == 2 + call block_edge_restrict(idir, i, j, k & + , pneigh%data%q(1:nv,1:im,1:jm,1:km) & + , rbuf(l,1:nv,1:ng,1:jh,1:km)) +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + call block_edge_restrict(idir, i, j, k & + , pneigh%data%q(1:nv,1:im,1:jm,1:km) & + , rbuf(l,1:nv,1:ng,1:jh,1:ng)) +#endif /* NDIMS == 3 */ +#if NDIMS == 3 + case(3) + call block_edge_restrict(idir, i, j, k & + , pneigh%data%q(1:nv,1:im,1:jm,1:km) & + , rbuf(l,1:nv,1:ng,1:ng,1:kh)) +#endif /* NDIMS == 3 */ + end select + +! associate the pointer with the next block +! + pinfo => pinfo%prev + + end do ! %ptr block list + +! send the data buffer to another process +! + call send_real_array(size(rbuf), irecv, itag, rbuf(:,:,:,:,:), iret) + + end if ! isend = nproc + +! if irecv == nproc we are receiving data from the neighbor block +! + if (irecv == nproc) then + +! receive the data buffer +! + call receive_real_array(size(rbuf(:,:,:,:,:)), isend, itag & + , rbuf(:,:,:,:,:), iret) + +! reset the block counter +! + l = 0 + +! associate the pointer with the first block in the exchange list +! + pinfo => block_array(isend,irecv)%ptr + +! iterate over all received blocks and update boundaries of the corresponding +! data blocks +! + do while(associated(pinfo)) + +! increase the block counter +! + l = l + 1 + +! assign a pointer to the associated data block +! + pmeta => pinfo%block + +! get the corner coordinates +! + i = pinfo%corner(1) + j = pinfo%corner(2) +#if NDIMS == 3 + k = pinfo%corner(3) +#endif /* NDIMS == 3 */ + +! calculate the insertion indices +! + if (i == 1) then + il = 1 + iu = ibl + else + il = ieu + iu = im + end if + if (j == 1) then + jl = 1 + ju = jbl + else + jl = jeu + ju = jm + end if +#if NDIMS == 3 + if (k == 1) then + kl = 1 + ku = kbl + else + kl = keu + ku = km + end if +#endif /* NDIMS == 3 */ + +! update the corresponding corner region of the current block +! + select case(idir) + case(1) + if (i == 1) then + il = ib + iu = ib + ih - 1 + else + il = ie - ih + 1 + iu = ie + end if +#if NDIMS == 2 + pmeta%data%q(1:nv,il:iu,jl:ju, 1:km) = & + rbuf(l,1:nv,1:ih,1:ng,1:km) +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = & + rbuf(l,1:nv,1:ih,1:ng,1:ng) +#endif /* NDIMS == 3 */ + case(2) + if (j == 1) then + jl = jb + ju = jb + jh - 1 + else + jl = je - jh + 1 + ju = je + end if +#if NDIMS == 2 + pmeta%data%q(1:nv,il:iu,jl:ju, 1:km) = & + rbuf(l,1:nv,1:ng,1:jh,1:km) +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = & + rbuf(l,1:nv,1:ng,1:jh,1:ng) +#endif /* NDIMS == 3 */ +#if NDIMS == 3 + case(3) + if (k == 1) then + kl = kb + ku = kb + kh - 1 + else + kl = ke - kh + 1 + ku = ke + end if + pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = & + rbuf(l,1:nv,1:ng,1:ng,1:kh) +#endif /* NDIMS == 3 */ + end select + +! associate the pointer with the next block +! + pinfo => pinfo%prev + + end do ! %ptr block list + + end if ! irecv = nproc + +! deallocate data buffer +! + if (allocated(rbuf)) deallocate(rbuf) + +! associate the pointer with the first block in the exchange list +! + pinfo => block_array(isend,irecv)%ptr + +! scan over all blocks on the exchange block list +! + do while(associated(pinfo)) + +! associate the exchange list pointer +! + block_array(isend,irecv)%ptr => pinfo%prev + +! nullify the pointer fields +! + nullify(pinfo%prev) + nullify(pinfo%next) + nullify(pinfo%block) + nullify(pinfo%neigh) + +! deallocate the object +! + deallocate(pinfo) + +! associate the pointer with the next block +! + pinfo => block_array(isend,irecv)%ptr + + end do ! %ptr block list + + end if ! if block_count > 0 + + end do ! isend + end do ! irecv +#endif /* MPI */ + +#ifdef PROFILE +! stop accounting time for restrict boundary update +! + call stop_timer(imr) +#endif /* PROFILE */ + +!------------------------------------------------------------------------------- +! + end subroutine boundaries_edge_restrict +! +!=============================================================================== +! ! subroutine BOUNDARIES_CORNER_COPY: ! --------------------------------- ! From 89df65f75497ba505f8bb6ad10c7af77594a96bb Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 15 Jul 2014 12:50:01 -0300 Subject: [PATCH 53/91] BOUNDARIES: Call boundaries_edge_restrict() in boundary_variables(). Signed-off-by: Grzegorz Kowal --- src/boundaries.F90 | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/boundaries.F90 b/src/boundaries.F90 index 7a28a95..d53d566 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -356,6 +356,12 @@ module boundaries ! call boundaries_corner_copy() +! restricts edge boundaries from block at higher level +! + do idir = 1, ndims + call boundaries_edge_restrict(idir) + end do ! idir + ! restricts corner boundaries from blocks at higher levels ! call boundaries_corner_restrict() From 62e7235a3a6339e6070626627615afdd8ec40c66 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 15 Jul 2014 13:24:30 -0300 Subject: [PATCH 54/91] BOUNDARIES: Implement block_edge_prolong(). This subroutine takes the variable array of the neighbor, prolongs it and extracts the edge region corresponding to the edge position. Signed-off-by: Grzegorz Kowal --- src/boundaries.F90 | 232 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 232 insertions(+) diff --git a/src/boundaries.F90 b/src/boundaries.F90 index d53d566..77c4551 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -6509,6 +6509,238 @@ module boundaries ! !=============================================================================== ! +! subroutine BLOCK_EDGE_PROLONG: +! ----------------------------- +! +! Subroutine returns the edge boundary region by prolongating +! the corresponding region from the provided input variable array. +! +! Arguments: +! +! nc - the edge direction; +! ic, jc, kc - the corner position; +! qn - the input neighbor variable array; +! qb - the output edge boundary array; +! +!=============================================================================== +! + subroutine block_edge_prolong(nc, ic, jc, kc, qn, qb) + +! import external procedures and variables +! + use coordinates , only : ng, nh + use coordinates , only : in + use coordinates , only : in , jn , kn + use coordinates , only : im , jm , km + use coordinates , only : ib , jb , kb + use coordinates , only : ie , je , ke + use equations , only : nv + use interpolations , only : limiter + +! local variables are not implicit by default +! + implicit none + +! subroutine arguments +! + integer , intent(in) :: nc, ic, jc, kc + real(kind=8), dimension(1:nv,1:im,1:jm,1:km), intent(in) :: qn + real(kind=8), dimension( : , : , : , : ), intent(out) :: qb + +! local variables +! + integer :: i, j, k, p + integer :: ih, jh, kh + integer :: il, jl, kl + integer :: iu, ju, ku + integer :: is, js, ks + integer :: it, jt, kt + integer :: im1, jm1, km1 + integer :: ip1, jp1, kp1 + real(kind=8) :: dql, dqr + real(kind=8) :: dqx, dqy, dqz + real(kind=8) :: dq1, dq2, dq3, dq4 +! +!------------------------------------------------------------------------------- +! +! depending on the direction +! + select case(nc) + case(1) + +! calculate half size +! + ih = in / 2 + +! prepare source edge region indices +! + if (ic == 0) then + il = ib + iu = ib + ih + nh - 1 + else + il = ie - ih - nh + 1 + iu = ie + end if + if (jc == 1) then + jl = je - nh + 1 + ju = je + else + jl = jb + ju = jb + nh - 1 + end if +#if NDIMS == 3 + if (kc == 1) then + kl = ke - nh + 1 + ku = ke + else + kl = kb + ku = kb + nh - 1 + end if +#endif /* NDIMS == 3 */ + + case(2) + +! calculate half size +! + jh = jn / 2 + +! prepare source edge region indices +! + if (ic == 1) then + il = ie - nh + 1 + iu = ie + else + il = ib + iu = ib + nh - 1 + end if + if (jc == 0) then + jl = jb + ju = jb + jh + nh - 1 + else + jl = je - jh - nh + 1 + ju = je + end if +#if NDIMS == 3 + if (kc == 1) then + kl = ke - nh + 1 + ku = ke + else + kl = kb + ku = kb + nh - 1 + end if +#endif /* NDIMS == 3 */ + +#if NDIMS == 3 + case(3) + +! calculate half size +! + kh = kn / 2 + +! prepare source edge region indices +! + if (ic == 1) then + il = ie - nh + 1 + iu = ie + else + il = ib + iu = ib + nh - 1 + end if + if (jc == 1) then + jl = je - nh + 1 + ju = je + else + jl = jb + ju = jb + nh - 1 + end if + if (kc == 0) then + kl = kb + ku = kb + kh + nh - 1 + else + kl = ke - kh - nh + 1 + ku = ke + end if +#endif /* NDIMS == 3 */ + + end select + +! return edge region in the output array +! +#if NDIMS == 2 + do k = 1, km + kt = 1 +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + do k = kl, ku + km1 = k - 1 + kp1 = k + 1 + ks = 2 * (k - kl) + 1 + kt = ks + 1 +#endif /* NDIMS == 3 */ + do j = jl, ju + jm1 = j - 1 + jp1 = j + 1 + js = 2 * (j - jl) + 1 + jt = js + 1 + do i = il, iu + im1 = i - 1 + ip1 = i + 1 + is = 2 * (i - il) + 1 + it = is + 1 + +! iterate over all variables +! + do p = 1, nv + + dql = qn(p,i ,j,k) - qn(p,im1,j,k) + dqr = qn(p,ip1,j,k) - qn(p,i ,j,k) + dqx = limiter(0.25d+00, dql, dqr) + + dql = qn(p,i,j ,k) - qn(p,i,jm1,k) + dqr = qn(p,i,jp1,k) - qn(p,i,j ,k) + dqy = limiter(0.25d+00, dql, dqr) + +#if NDIMS == 3 + dql = qn(p,i,j,k ) - qn(p,i,j,km1) + dqr = qn(p,i,j,kp1) - qn(p,i,j,k ) + dqz = limiter(0.25d+00, dql, dqr) +#endif /* NDIMS == 3 */ + +#if NDIMS == 2 + dq1 = dqx + dqy + dq2 = dqx - dqy + qb(p,is,js,k ) = qn(p,i,j,k) - dq1 + qb(p,it,js,k ) = qn(p,i,j,k) + dq2 + qb(p,is,jt,k ) = qn(p,i,j,k) - dq2 + qb(p,it,jt,k ) = qn(p,i,j,k) + dq1 +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + dq1 = dqx + dqy + dqz + dq2 = dqx - dqy - dqz + dq3 = dqx - dqy + dqz + dq4 = dqx + dqy - dqz + qb(p,is,js,ks) = qn(p,i,j,k) - dq1 + qb(p,it,js,ks) = qn(p,i,j,k) + dq2 + qb(p,is,jt,ks) = qn(p,i,j,k) - dq3 + qb(p,it,jt,ks) = qn(p,i,j,k) + dq4 + qb(p,is,js,kt) = qn(p,i,j,k) - dq4 + qb(p,it,js,kt) = qn(p,i,j,k) + dq3 + qb(p,is,jt,kt) = qn(p,i,j,k) - dq2 + qb(p,it,jt,kt) = qn(p,i,j,k) + dq1 +#endif /* NDIMS == 3 */ + + end do ! q = 1, nv + + end do ! i = il, iu + end do ! j = jl, ju + end do ! k = kl, ku + +!------------------------------------------------------------------------------- +! + end subroutine block_edge_prolong +! +!=============================================================================== +! ! BLOCK CORNER UPDATE SUBROUTINES ! !=============================================================================== From 65cb4e747d1787255cb5cf3a2615aadbaf893f26 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 15 Jul 2014 13:25:32 -0300 Subject: [PATCH 55/91] BOUNDARIES: Add subroutine boundaries_edge_prolong(). This subroutine scans over all leaf blocks and their edge neighbor pointers and updates edge boundary regions from neighbors at lower levels. Signed-off-by: Grzegorz Kowal --- src/boundaries.F90 | 590 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 590 insertions(+) diff --git a/src/boundaries.F90 b/src/boundaries.F90 index 77c4551..75d2670 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -3960,6 +3960,596 @@ module boundaries ! !=============================================================================== ! +! subroutine BOUNDARIES_EDGE_PROLONG: +! ---------------------------------- +! +! Subroutine scans over all leaf blocks in order to find edge neighbors at +! the different levels, and perform the update of the edge boundaries between +! them. +! +! Arguments: +! +! idir - the direction to be processed; +! +!=============================================================================== +! + subroutine boundaries_edge_prolong(idir) + +! import external procedures and variables +! + use blocks , only : nsides + use blocks , only : block_meta, block_data + use blocks , only : list_meta + use blocks , only : block_info, pointer_info + use coordinates , only : ng + use coordinates , only : in , jn , kn + use coordinates , only : im , jm , km + use coordinates , only : ib , jb , kb + use coordinates , only : ie , je , ke + use coordinates , only : ibl, jbl, kbl + use coordinates , only : ieu, jeu, keu +#ifdef MPI + use equations , only : nv +#endif /* MPI */ + use mpitools , only : nproc, nprocs, npmax +#ifdef MPI + use mpitools , only : send_real_array, receive_real_array +#endif /* MPI */ + +! local variables are not implicit by default +! + implicit none + +! subroutine arguments +! + integer, intent(in) :: idir + +! local pointers +! + type(block_meta), pointer :: pmeta, pneigh +#ifdef MPI + type(block_info), pointer :: pinfo +#endif /* MPI */ + +! local variables +! + integer :: i , j , k + integer :: ic, jc, kc + integer :: ih, jh, kh + integer :: il, jl, kl + integer :: iu, ju, ku + integer :: iret +#ifdef MPI + integer :: isend, irecv, nblocks, itag, l + +! local pointer arrays +! + type(pointer_info), dimension(0:npmax,0:npmax) :: block_array + +! local arrays +! + integer , dimension(0:npmax,0:npmax) :: block_counter + real(kind=8), dimension(:,:,:,:,:) , allocatable :: rbuf +#endif /* MPI */ +! +!------------------------------------------------------------------------------- +! +#ifdef PROFILE +! start accounting time for prolong boundary update +! + call start_timer(imp) +#endif /* PROFILE */ + +! calculate the sizes +! + ih = in + ng + jh = jn + ng +#if NDIMS == 3 + kh = kn + ng +#endif /* NDIMS == 3 */ + +#ifdef MPI +!! 1. PREPARE THE BLOCK EXCHANGE ARRAYS FOR MPI +!! +! reset the exchange block counters +! + block_counter(:,:) = 0 + +! nullify the info pointers +! + do irecv = 0, npmax + do isend = 0, npmax + nullify(block_array(isend,irecv)%ptr) + end do + end do +#endif /* MPI */ + +!! 2. UPDATE VARIABLE EDGE BOUNDARIES BETWEEN BLOCKS BELONGING TO DIFFERENT +!! PROCESS AND PREPARE THE EXCHANGE BLOCK LIST OF BLOCKS WHICH BELONG TO +!! DIFFERENT PROCESSES +!! +! assign the pointer to the first block on the meta block list +! + pmeta => list_meta + +! scan all meta blocks and process blocks at the current level +! + do while(associated(pmeta)) + +! check if the block is leaf +! + if (pmeta%leaf) then + +! scan over all block corners +! +#if NDIMS == 3 + do k = 1, nsides + kc = k +#endif /* NDIMS == 3 */ + do j = 1, nsides + jc = j + do i = 1, nsides + ic = i + +! assign pneigh to the current neighbor +! +#if NDIMS == 2 + pneigh => pmeta%edges(i,j,idir)%ptr +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + pneigh => pmeta%edges(i,j,k,idir)%ptr +#endif /* NDIMS == 3 */ + +! check if the neighbor is associated +! + if (associated(pneigh)) then + +! check if the neighbor lays at lower level +! + if (pneigh%level < pmeta%level) then + +! skip if the block and its neighbor are not marked for update +! + if (pmeta%update .and. pneigh%update) then + +#ifdef MPI +! check if the block and its neighbor belong to the same process +! + if (pmeta%process == pneigh%process) then + +! check if the neighbor belongs to the current process +! + if (pmeta%process == nproc) then +#endif /* MPI */ + +! prepare the region indices for edge boundary update +! + if (i == 1) then + il = 1 + iu = ibl + else + il = ieu + iu = im + end if + if (j == 1) then + jl = 1 + ju = jbl + else + jl = jeu + ju = jm + end if +#if NDIMS == 3 + if (k == 1) then + kl = 1 + ku = kbl + else + kl = keu + ku = km + end if +#endif /* NDIMS == 3 */ + +! extract the corresponding edge region from the neighbor and insert it in +! the current data block +! + select case(idir) + case(1) + ic = pmeta%pos(1) + if (ic == 0) then + il = ib + iu = im + else + il = 1 + iu = ie + end if + case(2) + jc = pmeta%pos(2) + if (jc == 0) then + jl = jb + ju = jm + else + jl = 1 + ju = je + end if +#if NDIMS == 3 + case(3) + kc = pmeta%pos(3) + if (kc == 0) then + kl = kb + ku = km + else + kl = 1 + ku = ke + end if +#endif /* NDIMS == 3 */ + end select +#if NDIMS == 2 + call block_edge_prolong(idir, ic, jc, kc & + , pneigh%data%q(1:nv, 1:im, 1:jm, 1:km) & + , pmeta%data%q(1:nv,il:iu,jl:ju, 1:km)) +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + call block_edge_prolong(idir, ic, jc, kc & + , pneigh%data%q(1:nv, 1:im, 1:jm, 1:km) & + , pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku)) +#endif /* NDIMS == 3 */ + +#ifdef MPI + end if ! pneigh on the current process + + else ! block and neighbor belong to different processes + +! increase the counter for number of blocks to exchange +! + block_counter(pneigh%process,pmeta%process) = & + block_counter(pneigh%process,pmeta%process) + 1 + +! allocate a new info object +! + allocate(pinfo) + +! fill out only fields which are used +! + pinfo%block => pmeta + pinfo%neigh => pneigh + pinfo%direction = idir + pinfo%corner(1) = i + pinfo%corner(2) = j +#if NDIMS == 3 + pinfo%corner(3) = k +#endif /* NDIMS == 3 */ + +! nullify pointer fields of the object +! + nullify(pinfo%prev) + nullify(pinfo%next) + +! if the list is not empty append the newly created block to it +! + if (associated(block_array(pneigh%process & + ,pmeta%process)%ptr)) & + pinfo%prev => block_array(pneigh%process & + ,pmeta%process)%ptr + +! point the list to the newly created block +! + block_array(pneigh%process,pmeta%process)%ptr => pinfo + + end if ! block and neighbor belong to different processes +#endif /* MPI */ + + end if ! pmeta and pneigh marked for update + + end if ! neighbor at lower level + + end if ! neighbor associated + + end do ! i = 1, nsides + end do ! j = 1, nsides +#if NDIMS == 3 + end do ! k = 1, nsides +#endif /* NDIMS == 3 */ + + end if ! leaf + +! associate the pointer to the next meta block +! + pmeta => pmeta%next + + end do ! meta blocks + +#ifdef MPI +!! 3. UPDATE VARIABLE BOUNDARIES BETWEEN BLOCKS BELONGING TO DIFFERENT PROCESSES +!! +! iterate over sending and receiving processors +! + do irecv = 0, npmax + do isend = 0, npmax + +! process only pairs which have something to exchange +! + if (block_counter(isend,irecv) > 0) then + +! obtain the number of blocks to exchange +! + nblocks = block_counter(isend,irecv) + +! prepare the tag for communication +! + itag = 100 * (irecv * nprocs + isend + 1) + 22 + +! allocate data buffer for variables to exchange +! + select case(idir) +#if NDIMS == 2 + case(1) + allocate(rbuf(nblocks,nv,ih,ng,km)) + case(2) + allocate(rbuf(nblocks,nv,ng,jh,km)) +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + case(1) + allocate(rbuf(nblocks,nv,ih,ng,ng)) + case(2) + allocate(rbuf(nblocks,nv,ng,jh,ng)) + case(3) + allocate(rbuf(nblocks,nv,ng,ng,kh)) +#endif /* NDIMS == 3 */ + end select + +! if isend == nproc we are sending data from the neighbor block +! + if (isend == nproc) then + +! reset the block counter +! + l = 0 + +! associate the pointer with the first block in the exchange list +! + pinfo => block_array(isend,irecv)%ptr + +! scan over all blocks on the block exchange list +! + do while(associated(pinfo)) + +! increase the block counter +! + l = l + 1 + +! assign pmeta and pneigh to the associated blocks +! + pmeta => pinfo%block + pneigh => pinfo%neigh + +! get the corner coordinates +! + i = pinfo%corner(1) + j = pinfo%corner(2) +#if NDIMS == 3 + k = pinfo%corner(3) +#endif /* NDIMS == 3 */ + +! extract the corresponding edge region from the neighbor and insert it +! to the buffer +! + select case(idir) + case(1) + i = pmeta%pos(1) +#if NDIMS == 2 + call block_edge_prolong(idir, i, j, k & + , pneigh%data%q(1:nv,1:im,1:jm,1:km) & + , rbuf(l,1:nv,1:ih,1:ng,1:km)) +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + call block_edge_prolong(idir, i, j, k & + , pneigh%data%q(1:nv,1:im,1:jm,1:km) & + , rbuf(l,1:nv,1:ih,1:ng,1:ng)) +#endif /* NDIMS == 3 */ + case(2) + j = pmeta%pos(2) +#if NDIMS == 2 + call block_edge_prolong(idir, i, j, k & + , pneigh%data%q(1:nv,1:im,1:jm,1:km) & + , rbuf(l,1:nv,1:ng,1:jh,1:km)) +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + call block_edge_prolong(idir, i, j, k & + , pneigh%data%q(1:nv,1:im,1:jm,1:km) & + , rbuf(l,1:nv,1:ng,1:jh,1:ng)) +#endif /* NDIMS == 3 */ +#if NDIMS == 3 + case(3) + k = pmeta%pos(3) + call block_edge_prolong(idir, i, j, k & + , pneigh%data%q(1:nv,1:im,1:jm,1:km) & + , rbuf(l,1:nv,1:ng,1:ng,1:kh)) +#endif /* NDIMS == 3 */ + end select + +! associate the pointer with the next block +! + pinfo => pinfo%prev + + end do ! %ptr block list + +! send the data buffer to another process +! + call send_real_array(size(rbuf), irecv, itag, rbuf(:,:,:,:,:), iret) + + end if ! isend = nproc + +! if irecv == nproc we are receiving data from the neighbor block +! + if (irecv == nproc) then + +! receive the data buffer +! + call receive_real_array(size(rbuf(:,:,:,:,:)), isend, itag & + , rbuf(:,:,:,:,:), iret) + +! reset the block counter +! + l = 0 + +! associate the pointer with the first block in the exchange list +! + pinfo => block_array(isend,irecv)%ptr + +! iterate over all received blocks and update boundaries of the corresponding +! data blocks +! + do while(associated(pinfo)) + +! increase the block counter +! + l = l + 1 + +! assign a pointer to the associated data block +! + pmeta => pinfo%block + +! get the corner coordinates +! + i = pinfo%corner(1) + j = pinfo%corner(2) +#if NDIMS == 3 + k = pinfo%corner(3) +#endif /* NDIMS == 3 */ + +! calculate the insertion indices +! + if (i == 1) then + il = 1 + iu = ibl + else + il = ieu + iu = im + end if + if (j == 1) then + jl = 1 + ju = jbl + else + jl = jeu + ju = jm + end if +#if NDIMS == 3 + if (k == 1) then + kl = 1 + ku = kbl + else + kl = keu + ku = km + end if +#endif /* NDIMS == 3 */ + +! update the corresponding corner region of the current block +! + select case(idir) + case(1) + if (pmeta%pos(1) == 0) then + il = ib + iu = im + else + il = 1 + iu = ie + end if +#if NDIMS == 2 + pmeta%data%q(1:nv,il:iu,jl:ju, 1:km) = & + rbuf(l,1:nv,1:ih,1:ng,1:km) +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = & + rbuf(l,1:nv,1:ih,1:ng,1:ng) +#endif /* NDIMS == 3 */ + case(2) + if (pmeta%pos(2) == 0) then + jl = jb + ju = jm + else + jl = 1 + ju = je + end if +#if NDIMS == 2 + pmeta%data%q(1:nv,il:iu,jl:ju, 1:km) = & + rbuf(l,1:nv,1:ng,1:jh,1:km) +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = & + rbuf(l,1:nv,1:ng,1:jh,1:ng) +#endif /* NDIMS == 3 */ +#if NDIMS == 3 + case(3) + if (pmeta%pos(3) == 0) then + kl = kb + ku = km + else + kl = 1 + ku = ke + end if + pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = & + rbuf(l,1:nv,1:ng,1:ng,1:kh) +#endif /* NDIMS == 3 */ + end select + +! associate the pointer with the next block +! + pinfo => pinfo%prev + + end do ! %ptr block list + + end if ! irecv = nproc + +! deallocate data buffer +! + if (allocated(rbuf)) deallocate(rbuf) + +! associate the pointer with the first block in the exchange list +! + pinfo => block_array(isend,irecv)%ptr + +! scan over all blocks on the exchange block list +! + do while(associated(pinfo)) + +! associate the exchange list pointer +! + block_array(isend,irecv)%ptr => pinfo%prev + +! nullify the pointer fields +! + nullify(pinfo%prev) + nullify(pinfo%next) + nullify(pinfo%block) + nullify(pinfo%neigh) + +! deallocate the object +! + deallocate(pinfo) + +! associate the pointer with the next block +! + pinfo => block_array(isend,irecv)%ptr + + end do ! %ptr block list + + end if ! if block_count > 0 + + end do ! isend + end do ! irecv +#endif /* MPI */ + +#ifdef PROFILE +! stop accounting time for prolong boundary update +! + call stop_timer(imp) +#endif /* PROFILE */ + +!------------------------------------------------------------------------------- +! + end subroutine boundaries_edge_prolong +! +!=============================================================================== +! ! subroutine BOUNDARIES_CORNER_COPY: ! --------------------------------- ! From 518f12b19e2f8f25d28099a63008844109ce8a6a Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 15 Jul 2014 13:26:31 -0300 Subject: [PATCH 56/91] BOUNDARIES: Call boundaries_edge_prolong() in boundary_variables(). Signed-off-by: Grzegorz Kowal --- src/boundaries.F90 | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/boundaries.F90 b/src/boundaries.F90 index 75d2670..736cad5 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -366,6 +366,12 @@ module boundaries ! call boundaries_corner_restrict() +! prolongs edge boundaries from block at lower level +! + do idir = 1, ndims + call boundaries_edge_prolong(idir) + end do ! idir + ! prolong corner boundaries from blocks at lower levels ! call boundaries_corner_prolong() From 85f72fe1e01cb6bcd25f4229e92617d9e4ed34f3 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 15 Jul 2014 18:59:01 -0300 Subject: [PATCH 57/91] BLOCKS: Don't set interior corner pointers if neighbor at lower level. If we refine a block, and the neighbor lays at the same level of the parent, do not assign the child's interior corner pointer. Those pointers are null then. This is not a problem for corner boundary update, since this corner is updated in boundaries_edge_prolong, therefore all corners of the finer blocks are fully consisten with their neighbors. This also removes unnecessary condition check in boundaries_corner_prolong(). Signed-off-by: Grzegorz Kowal --- src/blocks.F90 | 24 ++++++++++++++++-------- src/boundaries.F90 | 11 ----------- 2 files changed, 16 insertions(+), 19 deletions(-) diff --git a/src/blocks.F90 b/src/blocks.F90 index 0915a8d..ad71997 100644 --- a/src/blocks.F90 +++ b/src/blocks.F90 @@ -2350,7 +2350,8 @@ module blocks if (pneigh%id == pmeta%id) then pchild%corners(2,1)%ptr => pmeta%child(4)%ptr else - pchild%corners(2,1)%ptr => pmeta%edges(2,1,1)%ptr + if (pneigh%level > pmeta%level) & + pchild%corners(2,1)%ptr => pmeta%edges(2,1,1)%ptr end if endif if (associated(pmeta%edges(1,2,2)%ptr)) then @@ -2358,7 +2359,8 @@ module blocks if (pneigh%id == pmeta%id) then pchild%corners(1,2)%ptr => pmeta%child(4)%ptr else - pchild%corners(1,2)%ptr => pmeta%edges(1,2,2)%ptr + if (pneigh%level > pmeta%level) & + pchild%corners(1,2)%ptr => pmeta%edges(1,2,2)%ptr end if end if pchild%corners(2,2)%ptr => pmeta%child(4)%ptr @@ -2371,7 +2373,8 @@ module blocks if (pneigh%id == pmeta%id) then pchild%corners(1,1)%ptr => pmeta%child(3)%ptr else - pchild%corners(1,1)%ptr => pmeta%edges(1,1,1)%ptr + if (pneigh%level > pmeta%level) & + pchild%corners(1,1)%ptr => pmeta%edges(1,1,1)%ptr end if end if if (associated(pmeta%corners(2,1)%ptr)) then @@ -2388,7 +2391,8 @@ module blocks if (pneigh%id == pmeta%id) then pchild%corners(2,2)%ptr => pmeta%child(3)%ptr else - pchild%corners(2,2)%ptr => pmeta%edges(2,2,2)%ptr + if (pneigh%level > pmeta%level) & + pchild%corners(2,2)%ptr => pmeta%edges(2,2,2)%ptr end if end if @@ -2400,7 +2404,8 @@ module blocks if (pneigh%id == pmeta%id) then pchild%corners(1,1)%ptr => pmeta%child(2)%ptr else - pchild%corners(1,1)%ptr => pmeta%edges(1,1,2)%ptr + if (pneigh%level > pmeta%level) & + pchild%corners(1,1)%ptr => pmeta%edges(1,1,2)%ptr end if end if pchild%corners(2,1)%ptr => pmeta%child(2)%ptr @@ -2417,7 +2422,8 @@ module blocks if (pneigh%id == pmeta%id) then pchild%corners(2,2)%ptr => pmeta%child(2)%ptr else - pchild%corners(2,2)%ptr => pmeta%edges(2,2,1)%ptr + if (pneigh%level > pmeta%level) & + pchild%corners(2,2)%ptr => pmeta%edges(2,2,1)%ptr end if end if @@ -2430,7 +2436,8 @@ module blocks if (pneigh%id == pmeta%id) then pchild%corners(2,1)%ptr => pmeta%child(1)%ptr else - pchild%corners(2,1)%ptr => pmeta%edges(2,1,2)%ptr + if (pneigh%level > pmeta%level) & + pchild%corners(2,1)%ptr => pmeta%edges(2,1,2)%ptr end if end if if (associated(pmeta%edges(1,2,1)%ptr)) then @@ -2438,7 +2445,8 @@ module blocks if (pneigh%id == pmeta%id) then pchild%corners(1,2)%ptr => pmeta%child(1)%ptr else - pchild%corners(1,2)%ptr => pmeta%edges(1,2,1)%ptr + if (pneigh%level > pmeta%level) & + pchild%corners(1,2)%ptr => pmeta%edges(1,2,1)%ptr end if end if if (associated(pmeta%corners(2,2)%ptr)) then diff --git a/src/boundaries.F90 b/src/boundaries.F90 index 736cad5..0421073 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -5606,15 +5606,6 @@ module boundaries ! if (pmeta%update .and. pneigh%update) then -! process only external corners -! -#if NDIMS == 2 - if (pneigh%corners(3-i,3-j)%ptr%id == pmeta%id) then -#endif /* NDIMS == 2 */ -#if NDIMS == 3 - if (pneigh%corners(3-i,3-j,3-k)%ptr%id == pmeta%id) then -#endif /* NDIMS == 3 */ - #ifdef MPI ! check if the block and its neighbor belong to the same process ! @@ -5707,8 +5698,6 @@ module boundaries end if ! block and neighbor on different processors #endif /* MPI */ - end if ! only external corners - end if ! pmeta and pneigh marked for update end if ! neighbor at lower level From 75653bf226e7f49ab873232ee8d81dcc8b8e6d6b Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 22 Jul 2014 03:15:57 -0300 Subject: [PATCH 58/91] BLOCKS: Remove 3D face neighbor pointer update in refine_block(). This non-working update of the face neighbor pointers will be replaced. Signed-off-by: Grzegorz Kowal --- src/blocks.F90 | 629 ------------------------------------------------- 1 file changed, 629 deletions(-) diff --git a/src/blocks.F90 b/src/blocks.F90 index ad71997..9f720d4 100644 --- a/src/blocks.F90 +++ b/src/blocks.F90 @@ -1581,635 +1581,6 @@ module blocks end do ! nchildren -#if NDIMS == 3 -! update face neighbor pointers (only in 3D) and the corresponding neighbor -! face pointers -! -! child (1,1,1) - pchild => pmeta%child(1)%ptr -! X - if (associated(pmeta%faces(1,1,1,1)%ptr)) then - pneigh => pmeta%faces(1,1,1,1)%ptr - if (pneigh%id == pmeta%id) then - pchild%faces(1,1,1,1)%ptr => pmeta%child(2)%ptr - pchild%faces(1,2,1,1)%ptr => pmeta%child(2)%ptr - pchild%faces(1,1,2,1)%ptr => pmeta%child(2)%ptr - pchild%faces(1,2,2,1)%ptr => pmeta%child(2)%ptr - else - pchild%faces(1,1,1,1)%ptr => pmeta%faces(1,1,1,1)%ptr - pchild%faces(1,2,1,1)%ptr => pmeta%faces(1,1,1,1)%ptr - pchild%faces(1,1,2,1)%ptr => pmeta%faces(1,1,1,1)%ptr - pchild%faces(1,2,2,1)%ptr => pmeta%faces(1,1,1,1)%ptr - pneigh%faces(2,1,1,1)%ptr => pchild - if (pneigh%level > pmeta%level) then - pneigh%faces(2,2,1,1)%ptr => pchild - pneigh%faces(2,1,2,1)%ptr => pchild - pneigh%faces(2,2,2,1)%ptr => pchild - end if - end if - end if - pchild%faces(2,1,1,1)%ptr => pmeta%child(2)%ptr - pchild%faces(2,2,1,1)%ptr => pmeta%child(2)%ptr - pchild%faces(2,1,2,1)%ptr => pmeta%child(2)%ptr - pchild%faces(2,2,2,1)%ptr => pmeta%child(2)%ptr -! Y - if (associated(pmeta%faces(1,1,1,2)%ptr)) then - pneigh => pmeta%faces(1,1,1,2)%ptr - if (pneigh%id == pmeta%id) then - pchild%faces(1,1,1,2)%ptr => pmeta%child(3)%ptr - pchild%faces(2,1,1,2)%ptr => pmeta%child(3)%ptr - pchild%faces(1,1,2,2)%ptr => pmeta%child(3)%ptr - pchild%faces(2,1,2,2)%ptr => pmeta%child(3)%ptr - else - pchild%faces(1,1,1,2)%ptr => pmeta%faces(1,1,1,2)%ptr - pchild%faces(2,1,1,2)%ptr => pmeta%faces(1,1,1,2)%ptr - pchild%faces(1,1,2,2)%ptr => pmeta%faces(1,1,1,2)%ptr - pchild%faces(2,1,2,2)%ptr => pmeta%faces(1,1,1,2)%ptr - pneigh%faces(1,2,1,2)%ptr => pchild - if (pneigh%level > pmeta%level) then - pneigh%faces(2,2,1,2)%ptr => pchild - pneigh%faces(1,2,2,2)%ptr => pchild - pneigh%faces(2,2,2,2)%ptr => pchild - end if - end if - end if - pchild%faces(1,2,1,2)%ptr => pmeta%child(3)%ptr - pchild%faces(2,2,1,2)%ptr => pmeta%child(3)%ptr - pchild%faces(1,2,2,2)%ptr => pmeta%child(3)%ptr - pchild%faces(2,2,2,2)%ptr => pmeta%child(3)%ptr -! Z - if (associated(pmeta%faces(1,1,1,3)%ptr)) then - pneigh => pmeta%faces(1,1,1,3)%ptr - if (pneigh%id == pmeta%id) then - pchild%faces(1,1,1,3)%ptr => pmeta%child(5)%ptr - pchild%faces(2,1,1,3)%ptr => pmeta%child(5)%ptr - pchild%faces(1,1,2,3)%ptr => pmeta%child(5)%ptr - pchild%faces(2,1,2,3)%ptr => pmeta%child(5)%ptr - else - pchild%faces(1,1,1,3)%ptr => pmeta%faces(1,1,1,3)%ptr - pchild%faces(2,1,1,3)%ptr => pmeta%faces(1,1,1,3)%ptr - pchild%faces(1,2,1,3)%ptr => pmeta%faces(1,1,1,3)%ptr - pchild%faces(2,2,1,3)%ptr => pmeta%faces(1,1,1,3)%ptr - pneigh%faces(1,1,2,3)%ptr => pchild - if (pneigh%level > pmeta%level) then - pneigh%faces(2,1,2,3)%ptr => pchild - pneigh%faces(1,2,2,3)%ptr => pchild - pneigh%faces(2,2,2,3)%ptr => pchild - end if - end if - end if - pchild%faces(1,1,2,3)%ptr => pmeta%child(5)%ptr - pchild%faces(2,1,2,3)%ptr => pmeta%child(5)%ptr - pchild%faces(1,2,2,3)%ptr => pmeta%child(5)%ptr - pchild%faces(2,2,2,3)%ptr => pmeta%child(5)%ptr - -! child (2,1,1) - pchild => pmeta%child(2)%ptr -! X - pchild%faces(1,1,1,1)%ptr => pmeta%child(1)%ptr - pchild%faces(1,2,1,1)%ptr => pmeta%child(1)%ptr - pchild%faces(1,1,2,1)%ptr => pmeta%child(1)%ptr - pchild%faces(1,2,2,1)%ptr => pmeta%child(1)%ptr - if (associated(pmeta%faces(2,1,1,1)%ptr)) then - pneigh => pmeta%faces(2,1,1,1)%ptr - if (pneigh%id == pmeta%id) then - pchild%faces(2,1,1,1)%ptr => pmeta%child(1)%ptr - pchild%faces(2,2,1,1)%ptr => pmeta%child(1)%ptr - pchild%faces(2,1,2,1)%ptr => pmeta%child(1)%ptr - pchild%faces(2,2,2,1)%ptr => pmeta%child(1)%ptr - else - pchild%faces(2,1,1,1)%ptr => pmeta%faces(2,1,1,1)%ptr - pchild%faces(2,2,1,1)%ptr => pmeta%faces(2,1,1,1)%ptr - pchild%faces(2,1,2,1)%ptr => pmeta%faces(2,1,1,1)%ptr - pchild%faces(2,2,2,1)%ptr => pmeta%faces(2,1,1,1)%ptr - pneigh%faces(1,1,1,1)%ptr => pchild - if (pneigh%level > pmeta%level) then - pneigh%faces(1,2,1,1)%ptr => pchild - pneigh%faces(1,1,2,1)%ptr => pchild - pneigh%faces(1,2,2,1)%ptr => pchild - end if - end if - end if -! Y - if (associated(pmeta%faces(2,1,1,2)%ptr)) then - pneigh => pmeta%faces(2,1,1,2)%ptr - if (pneigh%id == pmeta%id) then - pchild%faces(1,1,1,2)%ptr => pmeta%child(4)%ptr - pchild%faces(2,1,1,2)%ptr => pmeta%child(4)%ptr - pchild%faces(1,1,2,2)%ptr => pmeta%child(4)%ptr - pchild%faces(2,1,2,2)%ptr => pmeta%child(4)%ptr - else - pchild%faces(1,1,1,2)%ptr => pmeta%faces(2,1,1,2)%ptr - pchild%faces(2,1,1,2)%ptr => pmeta%faces(2,1,1,2)%ptr - pchild%faces(1,1,2,2)%ptr => pmeta%faces(2,1,1,2)%ptr - pchild%faces(2,1,2,2)%ptr => pmeta%faces(2,1,1,2)%ptr - pneigh%faces(2,2,1,2)%ptr => pchild - if (pneigh%level > pmeta%level) then - pneigh%faces(1,2,1,2)%ptr => pchild - pneigh%faces(1,2,2,2)%ptr => pchild - pneigh%faces(2,2,2,2)%ptr => pchild - end if - end if - end if - pchild%faces(1,2,1,2)%ptr => pmeta%child(4)%ptr - pchild%faces(2,2,1,2)%ptr => pmeta%child(4)%ptr - pchild%faces(1,2,2,2)%ptr => pmeta%child(4)%ptr - pchild%faces(2,2,2,2)%ptr => pmeta%child(4)%ptr -! Z - if (associated(pmeta%faces(2,1,1,3)%ptr)) then - pneigh => pmeta%faces(2,1,1,3)%ptr - if (pneigh%id == pmeta%id) then - pchild%faces(1,1,1,3)%ptr => pmeta%child(6)%ptr - pchild%faces(2,1,1,3)%ptr => pmeta%child(6)%ptr - pchild%faces(1,1,2,3)%ptr => pmeta%child(6)%ptr - pchild%faces(2,1,2,3)%ptr => pmeta%child(6)%ptr - else - pchild%faces(1,1,1,3)%ptr => pmeta%faces(2,1,1,3)%ptr - pchild%faces(2,1,1,3)%ptr => pmeta%faces(2,1,1,3)%ptr - pchild%faces(1,2,1,3)%ptr => pmeta%faces(2,1,1,3)%ptr - pchild%faces(2,2,1,3)%ptr => pmeta%faces(2,1,1,3)%ptr - pneigh%faces(2,1,2,3)%ptr => pchild - if (pneigh%level > pmeta%level) then - pneigh%faces(1,1,2,3)%ptr => pchild - pneigh%faces(1,2,2,3)%ptr => pchild - pneigh%faces(2,2,2,3)%ptr => pchild - end if - end if - end if - pchild%faces(1,1,2,3)%ptr => pmeta%child(6)%ptr - pchild%faces(2,1,2,3)%ptr => pmeta%child(6)%ptr - pchild%faces(1,2,2,3)%ptr => pmeta%child(6)%ptr - pchild%faces(2,2,2,3)%ptr => pmeta%child(6)%ptr - -! child (1,2,1) - pchild => pmeta%child(3)%ptr -! X - if (associated(pmeta%faces(1,2,1,1)%ptr)) then - pneigh => pmeta%faces(1,2,1,1)%ptr - if (pneigh%id == pmeta%id) then - pchild%faces(1,1,1,1)%ptr => pmeta%child(4)%ptr - pchild%faces(1,2,1,1)%ptr => pmeta%child(4)%ptr - pchild%faces(1,1,2,1)%ptr => pmeta%child(4)%ptr - pchild%faces(1,2,2,1)%ptr => pmeta%child(4)%ptr - else - pchild%faces(1,1,1,1)%ptr => pmeta%faces(1,2,1,1)%ptr - pchild%faces(1,2,1,1)%ptr => pmeta%faces(1,2,1,1)%ptr - pchild%faces(1,1,2,1)%ptr => pmeta%faces(1,2,1,1)%ptr - pchild%faces(1,2,2,1)%ptr => pmeta%faces(1,2,1,1)%ptr - pneigh%faces(2,2,1,1)%ptr => pchild - if (pneigh%level > pmeta%level) then - pneigh%faces(2,1,1,1)%ptr => pchild - pneigh%faces(2,1,2,1)%ptr => pchild - pneigh%faces(2,2,2,1)%ptr => pchild - end if - end if - end if - pchild%faces(2,1,1,1)%ptr => pmeta%child(4)%ptr - pchild%faces(2,2,1,1)%ptr => pmeta%child(4)%ptr - pchild%faces(2,1,2,1)%ptr => pmeta%child(4)%ptr - pchild%faces(2,2,2,1)%ptr => pmeta%child(4)%ptr -! Y - pchild%faces(1,1,1,2)%ptr => pmeta%child(1)%ptr - pchild%faces(2,1,1,2)%ptr => pmeta%child(1)%ptr - pchild%faces(1,1,2,2)%ptr => pmeta%child(1)%ptr - pchild%faces(2,1,2,2)%ptr => pmeta%child(1)%ptr - if (associated(pmeta%faces(1,2,1,2)%ptr)) then - pneigh => pmeta%faces(1,2,1,2)%ptr - if (pneigh%id == pmeta%id) then - pchild%faces(1,2,1,2)%ptr => pmeta%child(1)%ptr - pchild%faces(2,2,1,2)%ptr => pmeta%child(1)%ptr - pchild%faces(1,2,2,2)%ptr => pmeta%child(1)%ptr - pchild%faces(2,2,2,2)%ptr => pmeta%child(1)%ptr - else - pchild%faces(1,2,1,2)%ptr => pmeta%faces(1,2,1,2)%ptr - pchild%faces(2,2,1,2)%ptr => pmeta%faces(1,2,1,2)%ptr - pchild%faces(1,2,2,2)%ptr => pmeta%faces(1,2,1,2)%ptr - pchild%faces(2,2,2,2)%ptr => pmeta%faces(1,2,1,2)%ptr - pneigh%faces(1,1,1,2)%ptr => pchild - if (pneigh%level > pmeta%level) then - pneigh%faces(2,1,1,2)%ptr => pchild - pneigh%faces(1,1,2,2)%ptr => pchild - pneigh%faces(2,1,2,2)%ptr => pchild - end if - end if - end if -! Z - if (associated(pmeta%faces(1,2,1,3)%ptr)) then - pneigh => pmeta%faces(1,2,1,3)%ptr - if (pneigh%id == pmeta%id) then - pchild%faces(1,1,1,3)%ptr => pmeta%child(7)%ptr - pchild%faces(2,1,1,3)%ptr => pmeta%child(7)%ptr - pchild%faces(1,1,2,3)%ptr => pmeta%child(7)%ptr - pchild%faces(2,1,2,3)%ptr => pmeta%child(7)%ptr - else - pchild%faces(1,1,1,3)%ptr => pmeta%faces(1,2,1,3)%ptr - pchild%faces(2,1,1,3)%ptr => pmeta%faces(1,2,1,3)%ptr - pchild%faces(1,2,1,3)%ptr => pmeta%faces(1,2,1,3)%ptr - pchild%faces(2,2,1,3)%ptr => pmeta%faces(1,2,1,3)%ptr - pneigh%faces(1,2,2,3)%ptr => pchild - if (pneigh%level > pmeta%level) then - pneigh%faces(1,1,2,3)%ptr => pchild - pneigh%faces(2,1,2,3)%ptr => pchild - pneigh%faces(2,2,2,3)%ptr => pchild - end if - end if - end if - pchild%faces(1,1,2,3)%ptr => pmeta%child(7)%ptr - pchild%faces(2,1,2,3)%ptr => pmeta%child(7)%ptr - pchild%faces(1,2,2,3)%ptr => pmeta%child(7)%ptr - pchild%faces(2,2,2,3)%ptr => pmeta%child(7)%ptr - -! child (2,2,1) - pchild => pmeta%child(4)%ptr -! X - pchild%faces(1,1,1,1)%ptr => pmeta%child(3)%ptr - pchild%faces(1,2,1,1)%ptr => pmeta%child(3)%ptr - pchild%faces(1,1,2,1)%ptr => pmeta%child(3)%ptr - pchild%faces(1,2,2,1)%ptr => pmeta%child(3)%ptr - if (associated(pmeta%faces(2,2,1,1)%ptr)) then - pneigh => pmeta%faces(2,2,1,1)%ptr - if (pneigh%id == pmeta%id) then - pchild%faces(2,1,1,1)%ptr => pmeta%child(3)%ptr - pchild%faces(2,2,1,1)%ptr => pmeta%child(3)%ptr - pchild%faces(2,1,2,1)%ptr => pmeta%child(3)%ptr - pchild%faces(2,2,2,1)%ptr => pmeta%child(3)%ptr - else - pchild%faces(2,1,1,1)%ptr => pmeta%faces(2,2,1,1)%ptr - pchild%faces(2,2,1,1)%ptr => pmeta%faces(2,2,1,1)%ptr - pchild%faces(2,1,2,1)%ptr => pmeta%faces(2,2,1,1)%ptr - pchild%faces(2,2,2,1)%ptr => pmeta%faces(2,2,1,1)%ptr - pneigh%faces(1,2,1,1)%ptr => pchild - if (pneigh%level > pmeta%level) then - pneigh%faces(1,1,1,1)%ptr => pchild - pneigh%faces(1,1,2,1)%ptr => pchild - pneigh%faces(1,2,2,1)%ptr => pchild - end if - end if - end if -! Y - pchild%faces(1,1,1,2)%ptr => pmeta%child(2)%ptr - pchild%faces(2,1,1,2)%ptr => pmeta%child(2)%ptr - pchild%faces(1,1,2,2)%ptr => pmeta%child(2)%ptr - pchild%faces(2,1,2,2)%ptr => pmeta%child(2)%ptr - if (associated(pmeta%faces(2,2,1,2)%ptr)) then - pneigh => pmeta%faces(2,2,1,2)%ptr - if (pneigh%id == pmeta%id) then - pchild%faces(1,2,1,2)%ptr => pmeta%child(2)%ptr - pchild%faces(2,2,1,2)%ptr => pmeta%child(2)%ptr - pchild%faces(1,2,2,2)%ptr => pmeta%child(2)%ptr - pchild%faces(2,2,2,2)%ptr => pmeta%child(2)%ptr - else - pchild%faces(1,2,1,2)%ptr => pmeta%faces(2,2,1,2)%ptr - pchild%faces(2,2,1,2)%ptr => pmeta%faces(2,2,1,2)%ptr - pchild%faces(1,2,2,2)%ptr => pmeta%faces(2,2,1,2)%ptr - pchild%faces(2,2,2,2)%ptr => pmeta%faces(2,2,1,2)%ptr - pneigh%faces(2,1,1,2)%ptr => pchild - if (pneigh%level > pmeta%level) then - pneigh%faces(1,1,1,2)%ptr => pchild - pneigh%faces(1,1,2,2)%ptr => pchild - pneigh%faces(2,1,2,2)%ptr => pchild - end if - end if - end if -! Z - if (associated(pmeta%faces(2,2,1,3)%ptr)) then - pneigh => pmeta%faces(2,2,1,3)%ptr - if (pneigh%id == pmeta%id) then - pchild%faces(1,1,1,3)%ptr => pmeta%child(8)%ptr - pchild%faces(2,1,1,3)%ptr => pmeta%child(8)%ptr - pchild%faces(1,1,2,3)%ptr => pmeta%child(8)%ptr - pchild%faces(2,1,2,3)%ptr => pmeta%child(8)%ptr - else - pchild%faces(1,1,1,3)%ptr => pmeta%faces(2,2,1,3)%ptr - pchild%faces(2,1,1,3)%ptr => pmeta%faces(2,2,1,3)%ptr - pchild%faces(1,2,1,3)%ptr => pmeta%faces(2,2,1,3)%ptr - pchild%faces(2,2,1,3)%ptr => pmeta%faces(2,2,1,3)%ptr - pneigh%faces(2,2,2,3)%ptr => pchild - if (pneigh%level > pmeta%level) then - pneigh%faces(1,1,2,3)%ptr => pchild - pneigh%faces(2,1,2,3)%ptr => pchild - pneigh%faces(1,2,2,3)%ptr => pchild - end if - end if - end if - pchild%faces(1,1,2,3)%ptr => pmeta%child(8)%ptr - pchild%faces(2,1,2,3)%ptr => pmeta%child(8)%ptr - pchild%faces(1,2,2,3)%ptr => pmeta%child(8)%ptr - pchild%faces(2,2,2,3)%ptr => pmeta%child(8)%ptr - -! child (1,1,2) - pchild => pmeta%child(5)%ptr -! X - if (associated(pmeta%faces(1,1,2,1)%ptr)) then - pneigh => pmeta%faces(1,1,2,1)%ptr - if (pneigh%id == pmeta%id) then - pchild%faces(1,1,1,1)%ptr => pmeta%child(6)%ptr - pchild%faces(1,2,1,1)%ptr => pmeta%child(6)%ptr - pchild%faces(1,1,2,1)%ptr => pmeta%child(6)%ptr - pchild%faces(1,2,2,1)%ptr => pmeta%child(6)%ptr - else - pchild%faces(1,1,1,1)%ptr => pmeta%faces(1,1,2,1)%ptr - pchild%faces(1,2,1,1)%ptr => pmeta%faces(1,1,2,1)%ptr - pchild%faces(1,1,2,1)%ptr => pmeta%faces(1,1,2,1)%ptr - pchild%faces(1,2,2,1)%ptr => pmeta%faces(1,1,2,1)%ptr - pneigh%faces(2,1,2,1)%ptr => pchild - if (pneigh%level > pmeta%level) then - pneigh%faces(2,1,1,1)%ptr => pchild - pneigh%faces(2,2,1,1)%ptr => pchild - pneigh%faces(2,2,2,1)%ptr => pchild - end if - end if - end if - pchild%faces(2,1,1,1)%ptr => pmeta%child(6)%ptr - pchild%faces(2,2,1,1)%ptr => pmeta%child(6)%ptr - pchild%faces(2,1,2,1)%ptr => pmeta%child(6)%ptr - pchild%faces(2,2,2,1)%ptr => pmeta%child(6)%ptr -! Y - if (associated(pmeta%faces(1,1,2,2)%ptr)) then - pneigh => pmeta%faces(1,1,2,2)%ptr - if (pneigh%id == pmeta%id) then - pchild%faces(1,1,1,2)%ptr => pmeta%child(7)%ptr - pchild%faces(2,1,1,2)%ptr => pmeta%child(7)%ptr - pchild%faces(1,1,2,2)%ptr => pmeta%child(7)%ptr - pchild%faces(2,1,2,2)%ptr => pmeta%child(7)%ptr - else - pchild%faces(1,1,1,2)%ptr => pmeta%faces(1,1,2,2)%ptr - pchild%faces(2,1,1,2)%ptr => pmeta%faces(1,1,2,2)%ptr - pchild%faces(1,1,2,2)%ptr => pmeta%faces(1,1,2,2)%ptr - pchild%faces(2,1,2,2)%ptr => pmeta%faces(1,1,2,2)%ptr - pneigh%faces(1,2,2,2)%ptr => pchild - if (pneigh%level > pmeta%level) then - pneigh%faces(1,2,1,2)%ptr => pchild - pneigh%faces(2,2,1,2)%ptr => pchild - pneigh%faces(2,2,2,2)%ptr => pchild - end if - end if - end if - pchild%faces(1,2,1,2)%ptr => pmeta%child(7)%ptr - pchild%faces(2,2,1,2)%ptr => pmeta%child(7)%ptr - pchild%faces(1,2,2,2)%ptr => pmeta%child(7)%ptr - pchild%faces(2,2,2,2)%ptr => pmeta%child(7)%ptr -! Z - pchild%faces(1,1,1,3)%ptr => pmeta%child(1)%ptr - pchild%faces(2,1,1,3)%ptr => pmeta%child(1)%ptr - pchild%faces(1,2,1,3)%ptr => pmeta%child(1)%ptr - pchild%faces(2,2,1,3)%ptr => pmeta%child(1)%ptr - if (associated(pmeta%faces(1,1,2,3)%ptr)) then - pneigh => pmeta%faces(1,1,2,3)%ptr - if (pneigh%id == pmeta%id) then - pchild%faces(1,1,2,3)%ptr => pmeta%child(1)%ptr - pchild%faces(2,1,2,3)%ptr => pmeta%child(1)%ptr - pchild%faces(1,2,2,3)%ptr => pmeta%child(1)%ptr - pchild%faces(2,2,2,3)%ptr => pmeta%child(1)%ptr - else - pchild%faces(1,1,2,3)%ptr => pmeta%faces(1,1,2,3)%ptr - pchild%faces(2,1,2,3)%ptr => pmeta%faces(1,1,2,3)%ptr - pchild%faces(1,2,2,3)%ptr => pmeta%faces(1,1,2,3)%ptr - pchild%faces(2,2,2,3)%ptr => pmeta%faces(1,1,2,3)%ptr - pneigh%faces(1,1,1,3)%ptr => pchild - if (pneigh%level > pmeta%level) then - pneigh%faces(2,1,1,3)%ptr => pchild - pneigh%faces(1,2,1,3)%ptr => pchild - pneigh%faces(2,2,1,3)%ptr => pchild - end if - end if - end if - -! child (2,1,2) - pchild => pmeta%child(6)%ptr -! X - pchild%faces(1,1,1,1)%ptr => pmeta%child(5)%ptr - pchild%faces(1,2,1,1)%ptr => pmeta%child(5)%ptr - pchild%faces(1,1,2,1)%ptr => pmeta%child(5)%ptr - pchild%faces(1,2,2,1)%ptr => pmeta%child(5)%ptr - if (associated(pmeta%faces(2,1,2,1)%ptr)) then - pneigh => pmeta%faces(2,1,2,1)%ptr - if (pneigh%id == pmeta%id) then - pchild%faces(2,1,1,1)%ptr => pmeta%child(5)%ptr - pchild%faces(2,2,1,1)%ptr => pmeta%child(5)%ptr - pchild%faces(2,1,2,1)%ptr => pmeta%child(5)%ptr - pchild%faces(2,2,2,1)%ptr => pmeta%child(5)%ptr - else - pchild%faces(2,1,1,1)%ptr => pmeta%faces(2,1,2,1)%ptr - pchild%faces(2,2,1,1)%ptr => pmeta%faces(2,1,2,1)%ptr - pchild%faces(2,1,2,1)%ptr => pmeta%faces(2,1,2,1)%ptr - pchild%faces(2,2,2,1)%ptr => pmeta%faces(2,1,2,1)%ptr - pneigh%faces(1,1,2,1)%ptr => pchild - if (pneigh%level > pmeta%level) then - pneigh%faces(1,1,1,1)%ptr => pchild - pneigh%faces(1,2,1,1)%ptr => pchild - pneigh%faces(1,2,2,1)%ptr => pchild - end if - end if - end if -! Y - if (associated(pmeta%faces(2,2,1,2)%ptr)) then - pneigh => pmeta%faces(2,2,1,2)%ptr - if (pneigh%id == pmeta%id) then - pchild%faces(1,1,1,2)%ptr => pmeta%child(8)%ptr - pchild%faces(2,1,1,2)%ptr => pmeta%child(8)%ptr - pchild%faces(1,1,2,2)%ptr => pmeta%child(8)%ptr - pchild%faces(2,1,2,2)%ptr => pmeta%child(8)%ptr - else - pchild%faces(1,1,1,2)%ptr => pmeta%faces(2,2,1,2)%ptr - pchild%faces(2,1,1,2)%ptr => pmeta%faces(2,2,1,2)%ptr - pchild%faces(1,1,2,2)%ptr => pmeta%faces(2,2,1,2)%ptr - pchild%faces(2,1,2,2)%ptr => pmeta%faces(2,2,1,2)%ptr - pneigh%faces(2,2,2,2)%ptr => pchild - if (pneigh%level > pmeta%level) then - pneigh%faces(1,2,1,2)%ptr => pchild - pneigh%faces(2,2,1,2)%ptr => pchild - pneigh%faces(1,2,2,2)%ptr => pchild - end if - end if - end if - pchild%faces(1,2,1,2)%ptr => pmeta%child(8)%ptr - pchild%faces(2,2,1,2)%ptr => pmeta%child(8)%ptr - pchild%faces(1,2,2,2)%ptr => pmeta%child(8)%ptr - pchild%faces(2,2,2,2)%ptr => pmeta%child(8)%ptr -! Z - pchild%faces(1,1,1,3)%ptr => pmeta%child(2)%ptr - pchild%faces(2,1,1,3)%ptr => pmeta%child(2)%ptr - pchild%faces(1,2,1,3)%ptr => pmeta%child(2)%ptr - pchild%faces(2,2,1,3)%ptr => pmeta%child(2)%ptr - if (associated(pmeta%faces(2,1,2,3)%ptr)) then - pneigh => pmeta%faces(2,1,2,3)%ptr - if (pneigh%id == pmeta%id) then - pchild%faces(1,1,2,3)%ptr => pmeta%child(2)%ptr - pchild%faces(2,1,2,3)%ptr => pmeta%child(2)%ptr - pchild%faces(1,2,2,3)%ptr => pmeta%child(2)%ptr - pchild%faces(2,2,2,3)%ptr => pmeta%child(2)%ptr - else - pchild%faces(1,1,2,3)%ptr => pmeta%faces(2,1,2,3)%ptr - pchild%faces(2,1,2,3)%ptr => pmeta%faces(2,1,2,3)%ptr - pchild%faces(1,2,2,3)%ptr => pmeta%faces(2,1,2,3)%ptr - pchild%faces(2,2,2,3)%ptr => pmeta%faces(2,1,2,3)%ptr - pneigh%faces(2,1,1,3)%ptr => pchild - if (pneigh%level > pmeta%level) then - pneigh%faces(1,1,1,3)%ptr => pchild - pneigh%faces(1,2,1,3)%ptr => pchild - pneigh%faces(2,2,1,3)%ptr => pchild - end if - end if - end if - -! child (1,2,2) - pchild => pmeta%child(7)%ptr -! X - if (associated(pmeta%faces(1,2,2,1)%ptr)) then - pneigh => pmeta%faces(1,2,2,1)%ptr - if (pneigh%id == pmeta%id) then - pchild%faces(1,1,1,1)%ptr => pmeta%child(8)%ptr - pchild%faces(1,2,1,1)%ptr => pmeta%child(8)%ptr - pchild%faces(1,1,2,1)%ptr => pmeta%child(8)%ptr - pchild%faces(1,2,2,1)%ptr => pmeta%child(8)%ptr - else - pchild%faces(1,1,1,1)%ptr => pmeta%faces(1,2,2,1)%ptr - pchild%faces(1,2,1,1)%ptr => pmeta%faces(1,2,2,1)%ptr - pchild%faces(1,1,2,1)%ptr => pmeta%faces(1,2,2,1)%ptr - pchild%faces(1,2,2,1)%ptr => pmeta%faces(1,2,2,1)%ptr - pneigh%faces(2,2,2,1)%ptr => pchild - if (pneigh%level > pmeta%level) then - pneigh%faces(2,1,1,1)%ptr => pchild - pneigh%faces(2,2,1,1)%ptr => pchild - pneigh%faces(2,1,2,1)%ptr => pchild - end if - end if - end if - pchild%faces(2,1,1,1)%ptr => pmeta%child(8)%ptr - pchild%faces(2,2,1,1)%ptr => pmeta%child(8)%ptr - pchild%faces(2,1,2,1)%ptr => pmeta%child(8)%ptr - pchild%faces(2,2,2,1)%ptr => pmeta%child(8)%ptr -! Y - pchild%faces(1,1,1,2)%ptr => pmeta%child(5)%ptr - pchild%faces(2,1,1,2)%ptr => pmeta%child(5)%ptr - pchild%faces(1,1,2,2)%ptr => pmeta%child(5)%ptr - pchild%faces(2,1,2,2)%ptr => pmeta%child(5)%ptr - if (associated(pmeta%faces(1,2,2,2)%ptr)) then - pneigh => pmeta%faces(1,2,2,2)%ptr - if (pneigh%id == pmeta%id) then - pchild%faces(1,2,1,2)%ptr => pmeta%child(5)%ptr - pchild%faces(2,2,1,2)%ptr => pmeta%child(5)%ptr - pchild%faces(1,2,2,2)%ptr => pmeta%child(5)%ptr - pchild%faces(2,2,2,2)%ptr => pmeta%child(5)%ptr - else - pchild%faces(1,2,1,2)%ptr => pmeta%faces(1,2,2,2)%ptr - pchild%faces(2,2,1,2)%ptr => pmeta%faces(1,2,2,2)%ptr - pchild%faces(1,2,2,2)%ptr => pmeta%faces(1,2,2,2)%ptr - pchild%faces(2,2,2,2)%ptr => pmeta%faces(1,2,2,2)%ptr - pneigh%faces(1,1,2,2)%ptr => pchild - if (pneigh%level > pmeta%level) then - pneigh%faces(1,1,1,2)%ptr => pchild - pneigh%faces(2,1,1,2)%ptr => pchild - pneigh%faces(2,1,2,2)%ptr => pchild - end if - end if - end if -! Z - pchild%faces(1,1,1,3)%ptr => pmeta%child(3)%ptr - pchild%faces(2,1,1,3)%ptr => pmeta%child(3)%ptr - pchild%faces(1,2,1,3)%ptr => pmeta%child(3)%ptr - pchild%faces(2,2,1,3)%ptr => pmeta%child(3)%ptr - if (associated(pmeta%faces(1,1,1,3)%ptr)) then - pneigh => pmeta%faces(1,1,1,3)%ptr - if (pneigh%id == pmeta%id) then - pchild%faces(1,1,2,3)%ptr => pmeta%child(3)%ptr - pchild%faces(2,1,2,3)%ptr => pmeta%child(3)%ptr - pchild%faces(1,2,2,3)%ptr => pmeta%child(3)%ptr - pchild%faces(2,2,2,3)%ptr => pmeta%child(3)%ptr - else - pchild%faces(1,1,2,3)%ptr => pmeta%faces(1,1,1,3)%ptr - pchild%faces(2,1,2,3)%ptr => pmeta%faces(1,1,1,3)%ptr - pchild%faces(1,2,2,3)%ptr => pmeta%faces(1,1,1,3)%ptr - pchild%faces(2,2,2,3)%ptr => pmeta%faces(1,1,1,3)%ptr - pneigh%faces(1,2,1,3)%ptr => pchild - if (pneigh%level > pmeta%level) then - pneigh%faces(1,1,1,3)%ptr => pchild - pneigh%faces(2,1,1,3)%ptr => pchild - pneigh%faces(2,2,1,3)%ptr => pchild - end if - end if - end if - -! child (2,2,2) - pchild => pmeta%child(8)%ptr -! X - pchild%faces(1,1,1,1)%ptr => pmeta%child(7)%ptr - pchild%faces(1,2,1,1)%ptr => pmeta%child(7)%ptr - pchild%faces(1,1,2,1)%ptr => pmeta%child(7)%ptr - pchild%faces(1,2,2,1)%ptr => pmeta%child(7)%ptr - if (associated(pmeta%faces(2,2,2,1)%ptr)) then - pneigh => pmeta%faces(2,2,2,1)%ptr - if (pneigh%id == pmeta%id) then - pchild%faces(2,1,1,1)%ptr => pmeta%child(7)%ptr - pchild%faces(2,2,1,1)%ptr => pmeta%child(7)%ptr - pchild%faces(2,1,2,1)%ptr => pmeta%child(7)%ptr - pchild%faces(2,2,2,1)%ptr => pmeta%child(7)%ptr - else - pchild%faces(2,1,1,1)%ptr => pmeta%faces(2,2,2,1)%ptr - pchild%faces(2,2,1,1)%ptr => pmeta%faces(2,2,2,1)%ptr - pchild%faces(2,1,2,1)%ptr => pmeta%faces(2,2,2,1)%ptr - pchild%faces(2,2,2,1)%ptr => pmeta%faces(2,2,2,1)%ptr - pneigh%faces(1,2,2,1)%ptr => pchild - if (pneigh%level > pmeta%level) then - pneigh%faces(1,1,1,1)%ptr => pchild - pneigh%faces(1,2,1,1)%ptr => pchild - pneigh%faces(1,1,2,1)%ptr => pchild - end if - end if - end if -! Y - pchild%faces(1,1,1,2)%ptr => pmeta%child(6)%ptr - pchild%faces(2,1,1,2)%ptr => pmeta%child(6)%ptr - pchild%faces(1,1,2,2)%ptr => pmeta%child(6)%ptr - pchild%faces(2,1,2,2)%ptr => pmeta%child(6)%ptr - if (associated(pmeta%faces(2,2,2,2)%ptr)) then - pneigh => pmeta%faces(2,2,2,2)%ptr - if (pneigh%id == pmeta%id) then - pchild%faces(1,2,1,2)%ptr => pmeta%child(6)%ptr - pchild%faces(2,2,1,2)%ptr => pmeta%child(6)%ptr - pchild%faces(1,2,2,2)%ptr => pmeta%child(6)%ptr - pchild%faces(2,2,2,2)%ptr => pmeta%child(6)%ptr - else - pchild%faces(1,2,1,2)%ptr => pmeta%faces(2,2,2,2)%ptr - pchild%faces(2,2,1,2)%ptr => pmeta%faces(2,2,2,2)%ptr - pchild%faces(1,2,2,2)%ptr => pmeta%faces(2,2,2,2)%ptr - pchild%faces(2,2,2,2)%ptr => pmeta%faces(2,2,2,2)%ptr - pneigh%faces(2,1,2,2)%ptr => pchild - if (pneigh%level > pmeta%level) then - pneigh%faces(1,1,1,2)%ptr => pchild - pneigh%faces(2,1,1,2)%ptr => pchild - pneigh%faces(1,1,2,2)%ptr => pchild - end if - end if - end if -! Z - pchild%faces(1,1,1,3)%ptr => pmeta%child(4)%ptr - pchild%faces(2,1,1,3)%ptr => pmeta%child(4)%ptr - pchild%faces(1,2,1,3)%ptr => pmeta%child(4)%ptr - pchild%faces(2,2,1,3)%ptr => pmeta%child(4)%ptr - if (associated(pmeta%faces(2,2,2,3)%ptr)) then - pneigh => pmeta%faces(2,2,2,3)%ptr - if (pneigh%id == pmeta%id) then - pchild%faces(1,1,2,3)%ptr => pmeta%child(4)%ptr - pchild%faces(2,1,2,3)%ptr => pmeta%child(4)%ptr - pchild%faces(1,2,2,3)%ptr => pmeta%child(4)%ptr - pchild%faces(2,2,2,3)%ptr => pmeta%child(4)%ptr - else - pchild%faces(1,1,2,3)%ptr => pmeta%faces(2,2,2,3)%ptr - pchild%faces(2,1,2,3)%ptr => pmeta%faces(2,2,2,3)%ptr - pchild%faces(1,2,2,3)%ptr => pmeta%faces(2,2,2,3)%ptr - pchild%faces(2,2,2,3)%ptr => pmeta%faces(2,2,2,3)%ptr - pneigh%faces(2,2,1,3)%ptr => pchild - if (pneigh%level > pmeta%level) then - pneigh%faces(1,1,1,3)%ptr => pchild - pneigh%faces(2,1,1,3)%ptr => pchild - pneigh%faces(1,2,1,3)%ptr => pchild - end if - end if - end if -#endif /* NDIMS == 3 */ - ! update edge neighbor pointers of children ! #if NDIMS == 2 From 1f7e65b359d895d86ae6a5e08f845e6c8a68b8ef Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 22 Jul 2014 03:25:06 -0300 Subject: [PATCH 59/91] BLOCKS: Rewrite 2D neighbor pointers update in refine_block(). This update of 2D neighbor pointers iterates over corners instead of updating each neighbor pointer explicitely. It updates both, edge and corner neighbor pointers at once. Signed-off-by: Grzegorz Kowal --- src/blocks.F90 | 336 +++++++++++++++---------------------------------- 1 file changed, 100 insertions(+), 236 deletions(-) diff --git a/src/blocks.F90 b/src/blocks.F90 index 9f720d4..e626617 100644 --- a/src/blocks.F90 +++ b/src/blocks.F90 @@ -1581,253 +1581,117 @@ module blocks end do ! nchildren -! update edge neighbor pointers of children +! update neighbor pointers of the parent block ! #if NDIMS == 2 -! child (1,1) - pchild => pmeta%child(1)%ptr -! X - if (associated(pmeta%edges(1,1,1)%ptr)) then - pneigh => pmeta%edges(1,1,1)%ptr - if (pneigh%id == pmeta%id) then - pchild%edges(1,1,1)%ptr => pmeta%child(3)%ptr - pchild%edges(2,1,1)%ptr => pmeta%child(3)%ptr - else - pchild%edges(1,1,1)%ptr => pmeta%edges(1,1,1)%ptr - pchild%edges(2,1,1)%ptr => pmeta%edges(1,1,1)%ptr - end if - end if - pchild%edges(1,2,1)%ptr => pmeta%child(3)%ptr - pchild%edges(2,2,1)%ptr => pmeta%child(3)%ptr -! Y - if (associated(pmeta%edges(1,1,2)%ptr)) then - pneigh => pmeta%edges(1,1,2)%ptr - if (pneigh%id == pmeta%id) then - pchild%edges(1,1,2)%ptr => pmeta%child(2)%ptr - pchild%edges(1,2,2)%ptr => pmeta%child(2)%ptr - else - pchild%edges(1,1,2)%ptr => pmeta%edges(1,1,2)%ptr - pchild%edges(1,2,2)%ptr => pmeta%edges(1,1,2)%ptr - end if - end if - pchild%edges(2,1,2)%ptr => pmeta%child(2)%ptr - pchild%edges(2,2,2)%ptr => pmeta%child(2)%ptr + do jp = 1, nsides + jr = 3 - jp + do ip = 1, nsides + ir = 3 - ip -! child (2,1) - pchild => pmeta%child(2)%ptr -! X - if (associated(pmeta%edges(2,1,1)%ptr)) then - pneigh => pmeta%edges(2,1,1)%ptr - if (pneigh%id == pmeta%id) then - pchild%edges(1,1,1)%ptr => pmeta%child(4)%ptr - pchild%edges(2,1,1)%ptr => pmeta%child(4)%ptr - else - pchild%edges(1,1,1)%ptr => pmeta%edges(2,1,1)%ptr - pchild%edges(2,1,1)%ptr => pmeta%edges(2,1,1)%ptr - end if - end if - pchild%edges(1,2,1)%ptr => pmeta%child(4)%ptr - pchild%edges(2,2,1)%ptr => pmeta%child(4)%ptr -! Y - pchild%edges(1,1,2)%ptr => pmeta%child(1)%ptr - pchild%edges(1,2,2)%ptr => pmeta%child(1)%ptr - if (associated(pmeta%edges(2,1,2)%ptr)) then - pneigh => pmeta%edges(2,1,2)%ptr - if (pneigh%id == pmeta%id) then - pchild%edges(2,1,2)%ptr => pmeta%child(1)%ptr - pchild%edges(2,2,2)%ptr => pmeta%child(1)%ptr - else - pchild%edges(2,1,2)%ptr => pmeta%edges(2,1,2)%ptr - pchild%edges(2,2,2)%ptr => pmeta%edges(2,1,2)%ptr - end if - end if - -! child (1,2) - pchild => pmeta%child(3)%ptr -! X - pchild%edges(1,1,1)%ptr => pmeta%child(1)%ptr - pchild%edges(2,1,1)%ptr => pmeta%child(1)%ptr - if (associated(pmeta%edges(1,2,1)%ptr)) then - pneigh => pmeta%edges(1,2,1)%ptr - if (pneigh%id == pmeta%id) then - pchild%edges(1,2,1)%ptr => pmeta%child(1)%ptr - pchild%edges(2,2,1)%ptr => pmeta%child(1)%ptr - else - pchild%edges(1,2,1)%ptr => pmeta%edges(1,2,1)%ptr - pchild%edges(2,2,1)%ptr => pmeta%edges(1,2,1)%ptr - end if - end if -! Y - if (associated(pmeta%edges(1,2,2)%ptr)) then - pneigh => pmeta%edges(1,2,2)%ptr - if (pneigh%id == pmeta%id) then - pchild%edges(1,1,2)%ptr => pmeta%child(4)%ptr - pchild%edges(1,2,2)%ptr => pmeta%child(4)%ptr - else - pchild%edges(1,1,2)%ptr => pmeta%edges(1,2,2)%ptr - pchild%edges(1,2,2)%ptr => pmeta%edges(1,2,2)%ptr - end if - end if - pchild%edges(2,1,2)%ptr => pmeta%child(4)%ptr - pchild%edges(2,2,2)%ptr => pmeta%child(4)%ptr - -! child (2,2) - pchild => pmeta%child(4)%ptr -! X - pchild%edges(1,1,1)%ptr => pmeta%child(2)%ptr - pchild%edges(2,1,1)%ptr => pmeta%child(2)%ptr - if (associated(pmeta%edges(2,2,1)%ptr)) then - pneigh => pmeta%edges(2,2,1)%ptr - if (pneigh%id == pmeta%id) then - pchild%edges(1,2,1)%ptr => pmeta%child(2)%ptr - pchild%edges(2,2,1)%ptr => pmeta%child(2)%ptr - else - pchild%edges(1,2,1)%ptr => pmeta%edges(2,2,1)%ptr - pchild%edges(2,2,1)%ptr => pmeta%edges(2,2,1)%ptr - end if - end if -! Y - pchild%edges(1,1,2)%ptr => pmeta%child(3)%ptr - pchild%edges(1,2,2)%ptr => pmeta%child(3)%ptr - if (associated(pmeta%edges(2,2,2)%ptr)) then - pneigh => pmeta%edges(2,2,2)%ptr - if (pneigh%id == pmeta%id) then - pchild%edges(2,1,2)%ptr => pmeta%child(3)%ptr - pchild%edges(2,2,2)%ptr => pmeta%child(3)%ptr - else - pchild%edges(2,1,2)%ptr => pmeta%edges(2,2,2)%ptr - pchild%edges(2,2,2)%ptr => pmeta%edges(2,2,2)%ptr - end if - end if -#endif /* NDIMS == 2 */ - -! update corner neighbor pointers of children, and corresponding neighbor -! corners if they lay at larger level +! calculate the child index ! -#if NDIMS == 2 -! child (1,1) - pchild => pmeta%child(1)%ptr + p = 2 * (jp - 1) + ip - if (associated(pmeta%corners(1,1)%ptr)) then - pneigh => pmeta%corners(1,1)%ptr - if (pneigh%id == pmeta%id) then - pchild%corners(1,1)%ptr => pmeta%child(4)%ptr - else - pchild%corners(1,1)%ptr => pmeta%corners(1,1)%ptr - end if - end if - if (associated(pmeta%edges(2,1,1)%ptr)) then - pneigh => pmeta%edges(2,1,1)%ptr - if (pneigh%id == pmeta%id) then - pchild%corners(2,1)%ptr => pmeta%child(4)%ptr - else - if (pneigh%level > pmeta%level) & - pchild%corners(2,1)%ptr => pmeta%edges(2,1,1)%ptr - end if - endif - if (associated(pmeta%edges(1,2,2)%ptr)) then - pneigh => pmeta%edges(1,2,2)%ptr - if (pneigh%id == pmeta%id) then - pchild%corners(1,2)%ptr => pmeta%child(4)%ptr - else - if (pneigh%level > pmeta%level) & - pchild%corners(1,2)%ptr => pmeta%edges(1,2,2)%ptr - end if - end if - pchild%corners(2,2)%ptr => pmeta%child(4)%ptr +! associate pchild with the proper child +! + pchild => pmeta%child(p)%ptr -! child (2,1) - pchild => pmeta%child(2)%ptr +!--- update edge neighbor pointers --- +! +! update external edges +! +! along X-direction +! + pneigh => pmeta%edges(ip,jp,1)%ptr + if (associated(pneigh)) then + if (pneigh%id == pmeta%id) then + q = 2 * (jr - 1) + ip + pchild%edges(ip,jp,1)%ptr => pmeta%child(q)%ptr + pchild%edges(ir,jp,1)%ptr => pmeta%child(q)%ptr + else + pchild%edges(ip,jp,1)%ptr => pneigh + pchild%edges(ir,jp,1)%ptr => pneigh + end if + end if ! pneigh associated - if (associated(pmeta%edges(1,1,1)%ptr)) then - pneigh => pmeta%edges(1,1,1)%ptr - if (pneigh%id == pmeta%id) then - pchild%corners(1,1)%ptr => pmeta%child(3)%ptr - else - if (pneigh%level > pmeta%level) & - pchild%corners(1,1)%ptr => pmeta%edges(1,1,1)%ptr - end if - end if - if (associated(pmeta%corners(2,1)%ptr)) then - pneigh => pmeta%corners(2,1)%ptr - if (pneigh%id == pmeta%id) then - pchild%corners(2,1)%ptr => pmeta%child(3)%ptr - else - pchild%corners(2,1)%ptr => pmeta%corners(2,1)%ptr - end if - end if - pchild%corners(1,2)%ptr => pmeta%child(3)%ptr - if (associated(pmeta%edges(2,2,2)%ptr)) then - pneigh => pmeta%edges(2,2,2)%ptr - if (pneigh%id == pmeta%id) then - pchild%corners(2,2)%ptr => pmeta%child(3)%ptr - else - if (pneigh%level > pmeta%level) & - pchild%corners(2,2)%ptr => pmeta%edges(2,2,2)%ptr - end if - end if +! along Y-direction +! + pneigh => pmeta%edges(ip,jp,2)%ptr + if (associated(pneigh)) then + if (pneigh%id == pmeta%id) then + q = 2 * (jp - 1) + ir + pchild%edges(ip,jp,2)%ptr => pmeta%child(q)%ptr + pchild%edges(ip,jr,2)%ptr => pmeta%child(q)%ptr + else + pchild%edges(ip,jp,2)%ptr => pneigh + pchild%edges(ip,jr,2)%ptr => pneigh + end if + end if ! pneigh associated -! child (1,2) - pchild => pmeta%child(3)%ptr +! update internal edges +! +! along X-direction +! + q = 2 * (jr - 1) + ip + pchild%edges(ip,jr,1)%ptr => pmeta%child(q)%ptr + pchild%edges(ir,jr,1)%ptr => pmeta%child(q)%ptr - if (associated(pmeta%edges(1,1,2)%ptr)) then - pneigh => pmeta%edges(1,1,2)%ptr - if (pneigh%id == pmeta%id) then - pchild%corners(1,1)%ptr => pmeta%child(2)%ptr - else - if (pneigh%level > pmeta%level) & - pchild%corners(1,1)%ptr => pmeta%edges(1,1,2)%ptr - end if - end if - pchild%corners(2,1)%ptr => pmeta%child(2)%ptr - if (associated(pmeta%corners(1,2)%ptr)) then - pneigh => pmeta%corners(1,2)%ptr - if (pneigh%id == pmeta%id) then - pchild%corners(1,2)%ptr => pmeta%child(2)%ptr - else - pchild%corners(1,2)%ptr => pmeta%corners(1,2)%ptr - end if - end if - if (associated(pmeta%edges(2,2,1)%ptr)) then - pneigh => pmeta%edges(2,2,1)%ptr - if (pneigh%id == pmeta%id) then - pchild%corners(2,2)%ptr => pmeta%child(2)%ptr - else - if (pneigh%level > pmeta%level) & - pchild%corners(2,2)%ptr => pmeta%edges(2,2,1)%ptr - end if - end if +! along Y-direction +! + q = 2 * (jp - 1) + ir + pchild%edges(ir,jp,2)%ptr => pmeta%child(q)%ptr + pchild%edges(ir,jr,2)%ptr => pmeta%child(q)%ptr -! child (2,2) - pchild => pmeta%child(4)%ptr +!--- update corner neighbor pointers --- +! +! calculate the index of opposite child +! + q = 2 * (jr - 1) + ir - pchild%corners(1,1)%ptr => pmeta%child(1)%ptr - if (associated(pmeta%edges(2,1,2)%ptr)) then - pneigh => pmeta%edges(2,1,2)%ptr - if (pneigh%id == pmeta%id) then - pchild%corners(2,1)%ptr => pmeta%child(1)%ptr - else - if (pneigh%level > pmeta%level) & - pchild%corners(2,1)%ptr => pmeta%edges(2,1,2)%ptr - end if - end if - if (associated(pmeta%edges(1,2,1)%ptr)) then - pneigh => pmeta%edges(1,2,1)%ptr - if (pneigh%id == pmeta%id) then - pchild%corners(1,2)%ptr => pmeta%child(1)%ptr - else - if (pneigh%level > pmeta%level) & - pchild%corners(1,2)%ptr => pmeta%edges(1,2,1)%ptr - end if - end if - if (associated(pmeta%corners(2,2)%ptr)) then - pneigh => pmeta%corners(2,2)%ptr - if (pneigh%id == pmeta%id) then - pchild%corners(2,2)%ptr => pmeta%child(1)%ptr - else - pchild%corners(2,2)%ptr => pmeta%corners(2,2)%ptr - end if - end if +! update corner located at the parent's one +! + pneigh => pmeta%corners(ip,jp)%ptr + if (associated(pneigh)) then + if (pneigh%id == pmeta%id) then + pchild%corners(ip,jp)%ptr => pmeta%child(q)%ptr + else + pchild%corners(ip,jp)%ptr => pneigh + end if + end if ! pneigh associated + +! update corner touching another child +! + pchild%corners(ir,jr)%ptr => pmeta%child(q)%ptr + +! update corners laying on parent's edges +! +! along X-direction +! + pneigh => pmeta%edges(ir,jp,1)%ptr + if (associated(pneigh)) then + if (pneigh%id == pmeta%id) then + pchild%corners(ir,jp)%ptr => pmeta%child(q)%ptr + else + if (pneigh%level > pmeta%level) & + pchild%corners(ir,jp)%ptr => pneigh + end if + end if ! pneigh associated + +! along Y-direction +! + pneigh => pmeta%edges(ip,jr,2)%ptr + if (associated(pneigh)) then + if (pneigh%id == pmeta%id) then + pchild%corners(ip,jr)%ptr => pmeta%child(q)%ptr + else + if (pneigh%level > pmeta%level) & + pchild%corners(ip,jr)%ptr => pneigh + end if + end if ! pneigh associated + + end do ! ip = 1, nsides + end do ! jp = 1, nsides #endif /* NDIMS == 2 */ ! update neighbor's edge pointers From 5f932ff90632508998e166a1c56819cfe69b82cd Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 22 Jul 2014 03:35:09 -0300 Subject: [PATCH 60/91] BLOCKS: Add missing variables in refine_block(). Signed-off-by: Grzegorz Kowal --- src/blocks.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/blocks.F90 b/src/blocks.F90 index e626617..875918a 100644 --- a/src/blocks.F90 +++ b/src/blocks.F90 @@ -1370,6 +1370,8 @@ module blocks ! logical, save :: first = .true. integer :: p, q, i, j, k, ic, jc, kc, cf + integer :: ip, jp, kp + integer :: ir, jr, kr real(kind=8) :: xln, yln, zln, xmn, xmx, ymn, ymx, zmn, zmx ! local arrays From 2b9513e776ef5f2d8157ed87140d0ed65e3a4fd1 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 22 Jul 2014 03:36:04 -0300 Subject: [PATCH 61/91] BLOCKS: Rewrite 2D neighbor' pointers update in refine_block(). This update of 2D neighbor' pointers iterates over corners instead of updating each neighbor's pointer explicitely. It updates both, edge and corner neighbor pointers of connected neighbors at once. Signed-off-by: Grzegorz Kowal --- src/blocks.F90 | 167 ++++++++++++++----------------------------------- 1 file changed, 48 insertions(+), 119 deletions(-) diff --git a/src/blocks.F90 b/src/blocks.F90 index 875918a..0730439 100644 --- a/src/blocks.F90 +++ b/src/blocks.F90 @@ -1696,136 +1696,65 @@ module blocks end do ! jp = 1, nsides #endif /* NDIMS == 2 */ -! update neighbor's edge pointers +! update neighbor pointers of the neighbor blocks ! #if NDIMS == 2 -! child (1,1) - pchild => pmeta%child(1)%ptr -! X - if (associated(pchild%edges(1,1,1)%ptr)) then - pneigh => pchild%edges(1,1,1)%ptr - pneigh%edges(1,2,1)%ptr => pchild - if (pneigh%level == pchild%level) pneigh%edges(2,2,1)%ptr => pchild - end if -! Y - if (associated(pchild%edges(1,1,2)%ptr)) then - pneigh => pchild%edges(1,1,2)%ptr - pneigh%edges(2,1,2)%ptr => pchild - if (pneigh%level == pchild%level) pneigh%edges(2,2,2)%ptr => pchild - end if + do jp = 1, nsides + jr = 3 - jp + do ip = 1, nsides + ir = 3 - ip -! child (2,1) - pchild => pmeta%child(2)%ptr -! X - if (associated(pchild%edges(2,1,1)%ptr)) then - pneigh => pchild%edges(2,1,1)%ptr - pneigh%edges(2,2,1)%ptr => pchild - if (pneigh%level == pchild%level) pneigh%edges(1,2,1)%ptr => pchild - end if -! Y - if (associated(pchild%edges(2,1,2)%ptr)) then - pneigh => pchild%edges(2,1,2)%ptr - pneigh%edges(1,1,2)%ptr => pchild - if (pneigh%level == pchild%level) pneigh%edges(1,2,2)%ptr => pchild - end if - -! child (1,2) - pchild => pmeta%child(3)%ptr -! X - if (associated(pchild%edges(1,2,1)%ptr)) then - pneigh => pchild%edges(1,2,1)%ptr - pneigh%edges(1,1,1)%ptr => pchild - if (pneigh%level == pchild%level) pneigh%edges(2,1,1)%ptr => pchild - end if -! Y - if (associated(pchild%edges(1,2,2)%ptr)) then - pneigh => pchild%edges(1,2,2)%ptr - pneigh%edges(2,2,2)%ptr => pchild - if (pneigh%level == pchild%level) pneigh%edges(2,1,2)%ptr => pchild - end if - -! child (2,2) - pchild => pmeta%child(4)%ptr -! X - if (associated(pchild%edges(2,2,1)%ptr)) then - pneigh => pchild%edges(2,2,1)%ptr - pneigh%edges(2,1,1)%ptr => pchild - if (pneigh%level == pchild%level) pneigh%edges(1,1,1)%ptr => pchild - end if -! Y - if (associated(pchild%edges(2,2,2)%ptr)) then - pneigh => pchild%edges(2,2,2)%ptr - pneigh%edges(1,2,2)%ptr => pchild - if (pneigh%level == pchild%level) pneigh%edges(1,1,2)%ptr => pchild - end if -#endif /* NDIMS == 2 */ - -! update neighbor's corner pointers +! calculate the child index ! -#if NDIMS == 2 -! child (1,1) - pchild => pmeta%child(1)%ptr + p = 2 * (jp - 1) + ip - if (associated(pmeta%corners(1,1)%ptr)) then - pneigh => pmeta%corners(1,1)%ptr - pneigh%corners(2,2)%ptr => pchild - end if - if (associated(pmeta%edges(2,1,1)%ptr)) then - pneigh => pmeta%edges(2,1,1)%ptr - if (pneigh%level > pmeta%level) pneigh%corners(1,2)%ptr => pchild - endif - if (associated(pmeta%edges(1,2,2)%ptr)) then - pneigh => pmeta%edges(1,2,2)%ptr - if (pneigh%level > pmeta%level) pneigh%corners(2,1)%ptr => pchild - end if +! associate pchild with the proper child +! + pchild => pmeta%child(p)%ptr -! child (2,1) - pchild => pmeta%child(2)%ptr +!--- update neighbor's edge pointers --- +! +! along X-direction +! + pneigh => pchild%edges(ip,jp,1)%ptr + if (associated(pneigh)) then + pneigh%edges(ip,jr,1)%ptr => pchild + if (pneigh%level > pmeta%level) pneigh%edges(ir,jr,1)%ptr => pchild + end if ! pneigh associated - if (associated(pmeta%edges(1,1,1)%ptr)) then - pneigh => pmeta%edges(1,1,1)%ptr - if (pneigh%level > pmeta%level) pneigh%corners(2,2)%ptr => pchild - end if - if (associated(pmeta%corners(2,1)%ptr)) then - pneigh => pmeta%corners(2,1)%ptr - pneigh%corners(1,2)%ptr => pchild - end if - if (associated(pmeta%edges(2,2,2)%ptr)) then - pneigh => pmeta%edges(2,2,2)%ptr - if (pneigh%level > pmeta%level) pneigh%corners(1,1)%ptr => pchild - end if +! along Y-direction +! + pneigh => pchild%edges(ip,jp,2)%ptr + if (associated(pneigh)) then + pneigh%edges(ir,jp,2)%ptr => pchild + if (pneigh%level > pmeta%level) pneigh%edges(ir,jr,2)%ptr => pchild + end if ! pneigh associated -! child (1,2) - pchild => pmeta%child(3)%ptr +!--- update neighbor's corner pointers --- +! +! neighbor corner located at the parent's one +! + pneigh => pmeta%corners(ip,jp)%ptr + if (associated(pneigh)) pneigh%corners(ir,jr)%ptr => pchild - if (associated(pmeta%edges(1,1,2)%ptr)) then - pneigh => pmeta%edges(1,1,2)%ptr - if (pneigh%level > pmeta%level) pneigh%corners(2,2)%ptr => pchild - end if - if (associated(pmeta%corners(1,2)%ptr)) then - pneigh => pmeta%corners(1,2)%ptr - pneigh%corners(2,1)%ptr => pchild - end if - if (associated(pmeta%edges(2,2,1)%ptr)) then - pneigh => pmeta%edges(2,2,1)%ptr - if (pneigh%level > pmeta%level) pneigh%corners(1,1)%ptr => pchild - end if +! neighbor corners laying on the parent's edges +! +! along X-direction +! + pneigh => pmeta%edges(ir,jp,1)%ptr + if (associated(pneigh)) then + if (pneigh%level > pmeta%level) pneigh%corners(ip,jr)%ptr => pchild + end if ! pneigh associated -! child (2,2) - pchild => pmeta%child(4)%ptr +! along Y-direction +! + pneigh => pmeta%edges(ip,jr,2)%ptr + if (associated(pneigh)) then + if (pneigh%level > pmeta%level) pneigh%corners(ir,jp)%ptr => pchild + end if ! pneigh associated - if (associated(pmeta%edges(2,1,2)%ptr)) then - pneigh => pmeta%edges(2,1,2)%ptr - if (pneigh%level > pmeta%level) pneigh%corners(1,2)%ptr => pchild - end if - if (associated(pmeta%edges(1,2,1)%ptr)) then - pneigh => pmeta%edges(1,2,1)%ptr - if (pneigh%level > pmeta%level) pneigh%corners(2,1)%ptr => pchild - end if - if (associated(pmeta%corners(2,2)%ptr)) then - pneigh => pmeta%corners(2,2)%ptr - pneigh%corners(1,1)%ptr => pchild - end if + end do ! ip = 1, nsides + end do ! jp = 1, nsides #endif /* NDIMS == 2 */ !! ASSIGN PROPER NEIGHBORS FOR THE CHILDREN IN THE INTERIOR OF THE PARENT BLOCK From 939f3106cb3f11cd65eecde3a5e85fee369cf872 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 22 Jul 2014 03:44:28 -0300 Subject: [PATCH 62/91] BLOCKS: Rewrite 2D neighbor pointers update in derefine_block(). This update of 2D neighbor pointers for derefined block iterates over corners instead of updating each neighbor pointer explicitely. It updates both, edge and corner neighbor pointers at once. Signed-off-by: Grzegorz Kowal --- src/blocks.F90 | 181 ++++++++++++++----------------------------------- 1 file changed, 51 insertions(+), 130 deletions(-) diff --git a/src/blocks.F90 b/src/blocks.F90 index 0730439..a8aa69c 100644 --- a/src/blocks.F90 +++ b/src/blocks.F90 @@ -2117,7 +2117,10 @@ module blocks ! local variables ! - integer :: i, j, k, l, p + integer :: l , p , q + integer :: i , j , k + integer :: ip, jp, kp + integer :: ir, jr, kr ! local saved variables ! @@ -2161,144 +2164,62 @@ module blocks end if -! update edge neighbor pointers of the parent +! update neighbor pointers of the parent block ! #if NDIMS == 2 -! child (1,1) - pchild => pmeta%child(1)%ptr -! X - if (associated(pchild%edges(1,1,1)%ptr)) then - pneigh => pchild%edges(1,1,1)%ptr - if (pneigh%id == pmeta%child(3)%ptr%id) then - pmeta%edges(1,1,1)%ptr => pmeta - else - pmeta%edges(1,1,1)%ptr => pchild%edges(1,1,1)%ptr - end if - end if -! Y - if (associated(pchild%edges(1,1,2)%ptr)) then - pneigh => pchild%edges(1,1,2)%ptr - if (pneigh%id == pmeta%child(2)%ptr%id) then - pmeta%edges(1,1,2)%ptr => pmeta - else - pmeta%edges(1,1,2)%ptr => pchild%edges(1,1,2)%ptr - end if - end if + do jp = 1, nsides + jr = 3 - jp + do ip = 1, nsides + ir = 3 - ip -! child (2,1) - pchild => pmeta%child(2)%ptr -! X - if (associated(pchild%edges(2,1,1)%ptr)) then - pneigh => pchild%edges(2,1,1)%ptr - if (pneigh%id == pmeta%child(4)%ptr%id) then - pmeta%edges(2,1,1)%ptr => pmeta - else - pmeta%edges(2,1,1)%ptr => pchild%edges(2,1,1)%ptr - end if - end if -! Y - if (associated(pchild%edges(2,1,2)%ptr)) then - pneigh => pchild%edges(2,1,2)%ptr - if (pneigh%id == pmeta%child(1)%ptr%id) then - pmeta%edges(2,1,2)%ptr => pmeta - else - pmeta%edges(2,1,2)%ptr => pchild%edges(2,1,2)%ptr - end if - end if - -! child (1,2) - pchild => pmeta%child(3)%ptr -! X - if (associated(pchild%edges(1,2,1)%ptr)) then - pneigh => pchild%edges(1,2,1)%ptr - if (pneigh%id == pmeta%child(1)%ptr%id) then - pmeta%edges(1,2,1)%ptr => pmeta - else - pmeta%edges(1,2,1)%ptr => pchild%edges(1,2,1)%ptr - end if - end if -! Y - if (associated(pchild%edges(1,2,2)%ptr)) then - pneigh => pchild%edges(1,2,2)%ptr - if (pneigh%id == pmeta%child(4)%ptr%id) then - pmeta%edges(1,2,2)%ptr => pmeta - else - pmeta%edges(1,2,2)%ptr => pchild%edges(1,2,2)%ptr - end if - end if - -! child (2,2) - pchild => pmeta%child(4)%ptr -! X - if (associated(pchild%edges(2,2,1)%ptr)) then - pneigh => pchild%edges(2,2,1)%ptr - if (pneigh%id == pmeta%child(2)%ptr%id) then - pmeta%edges(2,2,1)%ptr => pmeta - else - pmeta%edges(2,2,1)%ptr => pchild%edges(2,2,1)%ptr - end if - end if -! Y - if (associated(pchild%edges(2,2,2)%ptr)) then - pneigh => pchild%edges(2,2,2)%ptr - if (pneigh%id == pmeta%child(3)%ptr%id) then - pmeta%edges(2,2,2)%ptr => pmeta - else - pmeta%edges(2,2,2)%ptr => pchild%edges(2,2,2)%ptr - end if - end if -#endif /* NDIMS == 2 */ - -! update corner neighbor pointers of the parent +! calculate the child index ! -#if NDIMS == 2 -! corner (1,1) - pchild => pmeta%child(1)%ptr + p = 2 * (jp - 1) + ip - if (associated(pchild%corners(1,1)%ptr)) then - pneigh => pchild%corners(1,1)%ptr - if (pneigh%id == pmeta%child(4)%ptr%id) then - pmeta%corners(1,1)%ptr => pmeta - else - pmeta%corners(1,1)%ptr => pchild%corners(1,1)%ptr - end if - end if +! associate pchild with the proper child +! + pchild => pmeta%child(p)%ptr -! corner (2,1) - pchild => pmeta%child(2)%ptr +!--- update edge neighbor pointers --- +! +! along X-direction +! + pneigh => pchild%edges(ip,jp,1)%ptr + if (associated(pneigh)) then + q = 2 * (jr - 1) + ip + if (pneigh%id == pmeta%child(q)%ptr%id) then + pmeta%edges(ip,jp,1)%ptr => pmeta + else + pmeta%edges(ip,jp,1)%ptr => pneigh + end if + end if ! pneigh associated - if (associated(pchild%corners(2,1)%ptr)) then - pneigh => pchild%corners(2,1)%ptr - if (pneigh%id == pmeta%child(3)%ptr%id) then - pmeta%corners(2,1)%ptr => pmeta - else - pmeta%corners(2,1)%ptr => pchild%corners(2,1)%ptr - end if - end if +! along Y-direction +! + pneigh => pchild%edges(ip,jp,2)%ptr + if (associated(pneigh)) then + q = 2 * (jp - 1) + ir + if (pneigh%id == pmeta%child(q)%ptr%id) then + pmeta%edges(ip,jp,2)%ptr => pmeta + else + pmeta%edges(ip,jp,2)%ptr => pneigh + end if + end if ! pneigh associated -! corner (1,2) - pchild => pmeta%child(3)%ptr +!--- update corner neighbor pointers --- +! + pneigh => pchild%corners(ip,jp)%ptr + if (associated(pneigh)) then + q = 2 * (jr - 1) + ir + if (pneigh%id == pmeta%child(q)%ptr%id) then + pmeta%corners(ip,jp)%ptr => pmeta + else + pmeta%corners(ip,jp)%ptr => pneigh + end if + end if ! pneigh associated - if (associated(pchild%corners(1,2)%ptr)) then - pneigh => pchild%corners(1,2)%ptr - if (pneigh%id == pmeta%child(2)%ptr%id) then - pmeta%corners(1,2)%ptr => pmeta - else - pmeta%corners(1,2)%ptr => pchild%corners(1,2)%ptr - end if - end if - -! corner (2,2) - pchild => pmeta%child(4)%ptr - - if (associated(pchild%corners(2,2)%ptr)) then - pneigh => pchild%corners(2,2)%ptr - if (pneigh%id == pmeta%child(1)%ptr%id) then - pmeta%corners(2,2)%ptr => pmeta - else - pmeta%corners(2,2)%ptr => pchild%corners(2,2)%ptr - end if - end if + end do ! ip = 1, nsides + end do ! jp = 1, nsides #endif /* NDIMS == 2 */ ! update neighbor's edge pointers From ebed23ef712de1bfb87134d92f9009677c04fef1 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 22 Jul 2014 03:51:00 -0300 Subject: [PATCH 63/91] BLOCKS: Rewrite 2D neighbor' pointers update in derefine_block(). This update of 2D neighbor' pointers for derefined block iterates over corners instead of updating each neighbor's pointer explicitely. It updates both, edge and corner neighbor pointers of connected neighbors at once. Signed-off-by: Grzegorz Kowal --- src/blocks.F90 | 189 +++++++++++-------------------------------------- 1 file changed, 41 insertions(+), 148 deletions(-) diff --git a/src/blocks.F90 b/src/blocks.F90 index a8aa69c..c20aff8 100644 --- a/src/blocks.F90 +++ b/src/blocks.F90 @@ -2222,164 +2222,57 @@ module blocks end do ! jp = 1, nsides #endif /* NDIMS == 2 */ -! update neighbor's edge pointers +! update neighbor pointers of the neighbor blocks ! #if NDIMS == 2 -! corner (1,1) -! X - if (associated(pmeta%edges(1,1,1)%ptr)) then - pneigh => pmeta%edges(1,1,1)%ptr - pneigh%edges(1,2,1)%ptr => pmeta - if (pneigh%level > pmeta%level) pneigh%edges(2,2,1)%ptr => pmeta - end if -! Y - if (associated(pmeta%edges(1,1,2)%ptr)) then - pneigh => pmeta%edges(1,1,2)%ptr - pneigh%edges(2,1,2)%ptr => pmeta - if (pneigh%level > pmeta%level) pneigh%edges(2,2,2)%ptr => pmeta - end if + do jp = 1, nsides + jr = 3 - jp + do ip = 1, nsides + ir = 3 - ip -! child (2,1) -! X - if (associated(pmeta%edges(2,1,1)%ptr)) then - pneigh => pmeta%edges(2,1,1)%ptr - pneigh%edges(2,2,1)%ptr => pmeta - if (pneigh%level > pmeta%level) pneigh%edges(1,2,1)%ptr => pmeta - end if -! Y - if (associated(pmeta%edges(2,1,2)%ptr)) then - pneigh => pmeta%edges(2,1,2)%ptr - pneigh%edges(1,1,2)%ptr => pmeta - if (pneigh%level > pmeta%level) pneigh%edges(1,2,2)%ptr => pmeta - end if - -! child (1,2) -! X - if (associated(pmeta%edges(1,2,1)%ptr)) then - pneigh => pmeta%edges(1,2,1)%ptr - pneigh%edges(1,1,1)%ptr => pmeta - if (pneigh%level > pmeta%level) pneigh%edges(2,1,1)%ptr => pmeta - end if -! Y - if (associated(pmeta%edges(1,2,2)%ptr)) then - pneigh => pmeta%edges(1,2,2)%ptr - pneigh%edges(2,2,2)%ptr => pmeta - if (pneigh%level > pmeta%level) pneigh%edges(2,1,2)%ptr => pmeta - end if - -! child (2,2) -! X - if (associated(pmeta%edges(2,2,1)%ptr)) then - pneigh => pmeta%edges(2,2,1)%ptr - pneigh%edges(2,1,1)%ptr => pmeta - if (pneigh%level > pmeta%level) pneigh%edges(1,1,1)%ptr => pmeta - end if -! Y - if (associated(pmeta%edges(2,2,2)%ptr)) then - pneigh => pmeta%edges(2,2,2)%ptr - pneigh%edges(1,2,2)%ptr => pmeta - if (pneigh%level > pmeta%level) pneigh%edges(1,1,2)%ptr => pmeta - end if -#endif /* NDIMS == 2 */ - -! update neighbor's corner pointers +!--- update neighbor's edge pointers --- ! -#if NDIMS == 2 -! corner (1,1) - pchild => pmeta%child(1)%ptr +! along X-direction +! + pneigh => pmeta%edges(ip,jp,1)%ptr + if (associated(pneigh)) then + pneigh%edges(ip,jr,1)%ptr => pmeta + if (pneigh%level > pmeta%level) pneigh%edges(ir,jr,1)%ptr => pmeta + end if ! pneigh associated - if (associated(pchild%corners(1,1)%ptr)) then - pneigh => pchild%corners(1,1)%ptr - pneigh%corners(2,2)%ptr => pmeta - end if - if (associated(pchild%corners(2,1)%ptr)) then - pneigh => pchild%corners(2,1)%ptr - if (pneigh%level == pchild%level) then - if (pneigh%id /= pmeta%child(4)%ptr%id) then - pneigh%corners(1,2)%ptr => pmeta +! along Y-direction +! + pneigh => pmeta%edges(ip,jp,2)%ptr + if (associated(pneigh)) then + pneigh%edges(ir,jp,2)%ptr => pmeta + if (pneigh%level > pmeta%level) pneigh%edges(ir,jr,2)%ptr => pmeta end if - end if - end if - if (associated(pchild%corners(1,2)%ptr)) then - pneigh => pchild%corners(1,2)%ptr - if (pneigh%level == pchild%level) then - if (pneigh%id /= pmeta%child(4)%ptr%id) then - pneigh%corners(2,1)%ptr => pmeta - end if - end if - end if -! corner (2,1) - pchild => pmeta%child(2)%ptr +!--- update neighbor's corner pointers --- +! +! neighbor corner linked to the parent's corner +! + pneigh => pmeta%corners(ip,jp)%ptr + if (associated(pneigh)) pneigh%corners(ir,jr)%ptr => pmeta - if (associated(pchild%corners(1,1)%ptr)) then - pneigh => pchild%corners(1,1)%ptr - if (pneigh%level == pchild%level) then - if (pneigh%id /= pmeta%child(3)%ptr%id) then - pneigh%corners(2,2)%ptr => pmeta - end if - end if - end if - if (associated(pchild%corners(2,1)%ptr)) then - pneigh => pchild%corners(2,1)%ptr - pneigh%corners(1,2)%ptr => pmeta - end if - if (associated(pchild%corners(2,2)%ptr)) then - pneigh => pchild%corners(2,2)%ptr - if (pneigh%level == pchild%level) then - if (pneigh%id /= pmeta%child(3)%ptr%id) then - pneigh%corners(1,1)%ptr => pmeta - end if - end if - end if +! nullify neighbor corners pointing to parent's edges +! +! along X-direction +! + pneigh => pmeta%edges(ir,jp,1)%ptr + if (associated(pneigh)) then + if (pneigh%level > pmeta%level) nullify(pneigh%corners(ip,jr)%ptr) + end if ! pneigh associated -! corner (1,2) - pchild => pmeta%child(3)%ptr +! along Y-direction +! + pneigh => pmeta%edges(ip,jr,2)%ptr + if (associated(pneigh)) then + if (pneigh%level > pmeta%level) nullify(pneigh%corners(ir,jp)%ptr) + end if ! pneigh associated - if (associated(pchild%corners(1,1)%ptr)) then - pneigh => pchild%corners(1,1)%ptr - if (pneigh%level == pchild%level) then - if (pneigh%id /= pmeta%child(2)%ptr%id) then - pneigh%corners(2,2)%ptr => pmeta - end if - end if - end if - if (associated(pchild%corners(1,2)%ptr)) then - pneigh => pchild%corners(1,2)%ptr - pneigh%corners(2,1)%ptr => pmeta - end if - if (associated(pchild%corners(2,2)%ptr)) then - pneigh => pchild%corners(2,2)%ptr - if (pneigh%level == pchild%level) then - if (pneigh%id /= pmeta%child(2)%ptr%id) then - pneigh%corners(1,1)%ptr => pmeta - end if - end if - end if - -! corner (2,2) - pchild => pmeta%child(4)%ptr - - if (associated(pchild%corners(2,1)%ptr)) then - pneigh => pchild%corners(2,1)%ptr - if (pneigh%level == pchild%level) then - if (pneigh%id /= pmeta%child(1)%ptr%id) then - pneigh%corners(1,2)%ptr => pmeta - end if - end if - end if - if (associated(pchild%corners(1,2)%ptr)) then - pneigh => pchild%corners(1,2)%ptr - if (pneigh%level == pchild%level) then - if (pneigh%id /= pmeta%child(1)%ptr%id) then - pneigh%corners(2,1)%ptr => pmeta - end if - end if - end if - if (associated(pchild%corners(2,2)%ptr)) then - pneigh => pchild%corners(2,2)%ptr - pneigh%corners(1,1)%ptr => pmeta - end if + end do ! ip = 1, nsides + end do ! jp = 1, nsides #endif /* NDIMS == 2 */ ! iterate over dimensions, sides, and faces From 94262bd3a2b5a5c1b5a7b5aa9f2ff62b310b2739 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 22 Jul 2014 04:04:30 -0300 Subject: [PATCH 64/91] BLOCKS: Remove unnecessary variables in refine_block(). Signed-off-by: Grzegorz Kowal --- src/blocks.F90 | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/src/blocks.F90 b/src/blocks.F90 index c20aff8..e6d2eed 100644 --- a/src/blocks.F90 +++ b/src/blocks.F90 @@ -1369,7 +1369,8 @@ module blocks ! local variables ! logical, save :: first = .true. - integer :: p, q, i, j, k, ic, jc, kc, cf + integer :: p , q + integer :: i , j , k integer :: ip, jp, kp integer :: ir, jr, kr real(kind=8) :: xln, yln, zln, xmn, xmx, ymn, ymx, zmn, zmx @@ -1481,7 +1482,7 @@ module blocks !! ! set corresponding configuration of the new blocks ! - cf = pmeta%conf + q = pmeta%conf ! calculate sizes of the child blocks ! @@ -1507,12 +1508,12 @@ module blocks ! set the child configuration number ! - call metablock_set_configuration(pchild, config(cf,p)) + call metablock_set_configuration(pchild, config(q,p)) ! associate the parent's children array element with the freshly created ! meta block ! - pmeta%child(order(cf,p))%ptr => pchild + pmeta%child(order(q,p))%ptr => pchild end do ! nchildren @@ -1553,10 +1554,10 @@ module blocks ! calculate the block coordinates in effective resolution units ! - ic = 2 * pmeta%coords(1) + i - jc = 2 * pmeta%coords(2) + j + ip = 2 * pmeta%coords(1) + i + jp = 2 * pmeta%coords(2) + j #if NDIMS == 3 - kc = 2 * pmeta%coords(3) + k + kp = 2 * pmeta%coords(3) + k #endif /* NDIMS == 3 */ ! calculate block bounds @@ -1575,7 +1576,7 @@ module blocks ! set the effective resolution coordinates ! - call metablock_set_coordinates(pchild, ic, jc, kc) + call metablock_set_coordinates(pchild, ip, jp, kp) ! set the child block bounds ! From c3f12c2984e7b6ac7a459e067643456bc1a072ba Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 22 Jul 2014 04:12:26 -0300 Subject: [PATCH 65/91] BLOCKS: Add 3D neighbor pointer update in refine_block(). This adds the neighbor pointer update in 3D case in refine_block(). Signed-off-by: Grzegorz Kowal --- src/blocks.F90 | 389 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 389 insertions(+) diff --git a/src/blocks.F90 b/src/blocks.F90 index e6d2eed..14f5e21 100644 --- a/src/blocks.F90 +++ b/src/blocks.F90 @@ -1696,6 +1696,395 @@ module blocks end do ! ip = 1, nsides end do ! jp = 1, nsides #endif /* NDIMS == 2 */ +#if NDIMS == 3 + do kp = 1, nsides + kr = 3 - kp + do jp = 1, nsides + jr = 3 - jp + do ip = 1, nsides + ir = 3 - ip + +! calculate the child index +! + p = 4 * (kp - 1) + 2 * (jp - 1) + ip + +! associate pchild with the proper child +! + pchild => pmeta%child(p)%ptr + +!--- update face neighbor pointers --- +! +! prepare the index of neighbor child for X-faces +! + q = 4 * (kp - 1) + 2 * (jp - 1) + ir + +! set the internal side neighbor pointer +! + do k = 1, nsides + do j = 1, nsides + pchild%faces(ir,j,k,1)%ptr => pmeta%child(q)%ptr + end do ! j = 1, nsides + end do ! k = 1, nsides + +! associate pneigh with the X-face neighbor +! + pneigh => pmeta%faces(ip,jp,kp,1)%ptr + +! set the external side neighbor pointer +! + if (associated(pneigh)) then + if (pneigh%id == pmeta%id) then + do k = 1, nsides + do j = 1, nsides + pchild%faces(ip,j,k,1)%ptr => pmeta%child(q)%ptr + end do ! j = 1, nsides + end do ! k = 1, nsides + else + do k = 1, nsides + do j = 1, nsides + pchild%faces(ip,j,k,1)%ptr => pneigh + end do ! j = 1, nsides + end do ! k = 1, nsides + end if + end if ! pneigh associated + +! prepare the index of neighbor child for Y-faces +! + q = 4 * (kp - 1) + 2 * (jr - 1) + ip + +! set the internal side neighbor pointer +! + do k = 1, nsides + do i = 1, nsides + pchild%faces(i,jr,k,2)%ptr => pmeta%child(q)%ptr + end do ! i = 1, nsides + end do ! k = 1, nsides + +! associate pneigh with the Y-face neighbor +! + pneigh => pmeta%faces(ip,jp,kp,2)%ptr + +! set the external side neighbor pointer +! + if (associated(pneigh)) then + if (pneigh%id == pmeta%id) then + do k = 1, nsides + do i = 1, nsides + pchild%faces(i,jp,k,2)%ptr => pmeta%child(q)%ptr + end do ! i = 1, nsides + end do ! k = 1, nsides + else + do k = 1, nsides + do i = 1, nsides + pchild%faces(i,jp,k,2)%ptr => pneigh + end do ! i = 1, nsides + end do ! k = 1, nsides + end if + end if ! pneigh associated + +! prepare the index of neighbor child for Z-faces +! + q = 4 * (kr - 1) + 2 * (jp - 1) + ip + +! set the internal side neighbor pointer +! + do j = 1, nsides + do i = 1, nsides + pchild%faces(i,j,kr,3)%ptr => pmeta%child(q)%ptr + end do ! i = 1, nsides + end do ! j = 1, nsides + +! associate pneigh with the Z-face neighbor +! + pneigh => pmeta%faces(ip,jp,kp,3)%ptr + +! set the external side neighbor pointer +! + if (associated(pneigh)) then + if (pneigh%id == pmeta%id) then + do j = 1, nsides + do i = 1, nsides + pchild%faces(i,j,kp,3)%ptr => pmeta%child(q)%ptr + end do ! i = 1, nsides + end do ! j = 1, nsides + else + do j = 1, nsides + do i = 1, nsides + pchild%faces(i,j,kp,3)%ptr => pneigh + end do ! i = 1, nsides + end do ! j = 1, nsides + end if + end if ! pneigh associated + +!--- update edge neighbor pointers --- +! +! process child edges which lay on the parent's edges +! +! along X direction +! + pneigh => pmeta%edges(ip,jp,kp,1)%ptr + if (associated(pneigh)) then + if (pneigh%id == pmeta%id) then + q = 4 * (kr - 1) + 2 * (jr - 1) + ip + pchild%edges(ip,jp,kp,1)%ptr => pmeta%child(q)%ptr + pchild%edges(ir,jp,kp,1)%ptr => pmeta%child(q)%ptr + else + pchild%edges(ip,jp,kp,1)%ptr => pneigh + pchild%edges(ir,jp,kp,1)%ptr => pneigh + end if + end if ! pneigh associated + +! along Y direction +! + pneigh => pmeta%edges(ip,jp,kp,2)%ptr + if (associated(pneigh)) then + if (pneigh%id == pmeta%id) then + q = 4 * (kr - 1) + 2 * (jp - 1) + ir + pchild%edges(ip,jp,kp,2)%ptr => pmeta%child(q)%ptr + pchild%edges(ip,jr,kp,2)%ptr => pmeta%child(q)%ptr + else + pchild%edges(ip,jp,kp,2)%ptr => pneigh + pchild%edges(ip,jr,kp,2)%ptr => pneigh + end if + end if ! pneigh associated + +! along Z direction +! + pneigh => pmeta%edges(ip,jp,kp,3)%ptr + if (associated(pneigh)) then + if (pneigh%id == pmeta%id) then + q = 4 * (kp - 1) + 2 * (jr - 1) + ir + pchild%edges(ip,jp,kp,3)%ptr => pmeta%child(q)%ptr + pchild%edges(ip,jp,kr,3)%ptr => pmeta%child(q)%ptr + else + pchild%edges(ip,jp,kp,3)%ptr => pneigh + pchild%edges(ip,jp,kr,3)%ptr => pneigh + end if + end if ! pneigh associated + +! process child edges which are neighbors with other children +! +! along X direction +! + q = 4 * (kr - 1) + 2 * (jr - 1) + ip + pchild%edges(ip,jr,kr,1)%ptr => pmeta%child(q)%ptr + pchild%edges(ir,jr,kr,1)%ptr => pmeta%child(q)%ptr + +! along Y direction +! + q = 4 * (kr - 1) + 2 * (jp - 1) + ir + pchild%edges(ir,jp,kr,2)%ptr => pmeta%child(q)%ptr + pchild%edges(ir,jr,kr,2)%ptr => pmeta%child(q)%ptr + +! along Z direction +! + q = 4 * (kp - 1) + 2 * (jr - 1) + ir + pchild%edges(ir,jr,kp,3)%ptr => pmeta%child(q)%ptr + pchild%edges(ir,jr,kr,3)%ptr => pmeta%child(q)%ptr + +! process child edges on the parent's X-face +! +! along Z-edge +! + pneigh => pmeta%faces(ip,jr,kp,1)%ptr + if (associated(pneigh)) then + if (pneigh%id == pmeta%id) then + q = 4 * (kp - 1) + 2 * (jr - 1) + ir + pchild%edges(ip,jr,kp,3)%ptr => pmeta%child(q)%ptr + pchild%edges(ip,jr,kr,3)%ptr => pmeta%child(q)%ptr + else + if (pneigh%level > pmeta%level) then + pchild%edges(ip,jr,kp,3)%ptr => pneigh + pchild%edges(ip,jr,kr,3)%ptr => pneigh + end if + end if + end if ! pneigh associated + +! along Y-edge +! + pneigh => pmeta%faces(ip,jp,kr,1)%ptr + if (associated(pneigh)) then + if (pneigh%id == pmeta%id) then + q = 4 * (kr - 1) + 2 * (jp - 1) + ir + pchild%edges(ip,jp,kr,2)%ptr => pmeta%child(q)%ptr + pchild%edges(ip,jr,kr,2)%ptr => pmeta%child(q)%ptr + else + if (pneigh%level > pmeta%level) then + pchild%edges(ip,jp,kr,2)%ptr => pneigh + pchild%edges(ip,jr,kr,2)%ptr => pneigh + end if + end if + end if ! pneigh associated + +! process child edges on the parent's Y-face +! +! along Z-edge +! + pneigh => pmeta%faces(ir,jp,kp,2)%ptr + if (associated(pneigh)) then + if (pneigh%id == pmeta%id) then + q = 4 * (kp - 1) + 2 * (jr - 1) + ir + pchild%edges(ir,jp,kp,3)%ptr => pmeta%child(q)%ptr + pchild%edges(ir,jp,kr,3)%ptr => pmeta%child(q)%ptr + else + if (pneigh%level > pmeta%level) then + pchild%edges(ir,jp,kp,3)%ptr => pneigh + pchild%edges(ir,jp,kr,3)%ptr => pneigh + end if + end if + end if ! pneigh associated + +! along X-edge +! + pneigh => pmeta%faces(ip,jp,kr,2)%ptr + if (associated(pneigh)) then + if (pneigh%id == pmeta%id) then + q = 4 * (kr - 1) + 2 * (jr - 1) + ip + pchild%edges(ip,jp,kr,1)%ptr => pmeta%child(q)%ptr + pchild%edges(ir,jp,kr,1)%ptr => pmeta%child(q)%ptr + else + if (pneigh%level > pmeta%level) then + pchild%edges(ip,jp,kr,1)%ptr => pneigh + pchild%edges(ir,jp,kr,1)%ptr => pneigh + end if + end if + end if ! pneigh associated + +! process child edges on the parent's Z-face +! +! along Y-edge +! + pneigh => pmeta%faces(ir,jp,kp,3)%ptr + if (associated(pneigh)) then + if (pneigh%id == pmeta%id) then + q = 4 * (kr - 1) + 2 * (jp - 1) + ir + pchild%edges(ir,jp,kp,2)%ptr => pmeta%child(q)%ptr + pchild%edges(ir,jr,kp,2)%ptr => pmeta%child(q)%ptr + else + if (pneigh%level > pmeta%level) then + pchild%edges(ir,jp,kp,2)%ptr => pneigh + pchild%edges(ir,jr,kp,2)%ptr => pneigh + end if + end if + end if ! pneigh associated + +! along X-edge +! + pneigh => pmeta%faces(ip,jr,kp,3)%ptr + if (associated(pneigh)) then + if (pneigh%id == pmeta%id) then + q = 4 * (kr - 1) + 2 * (jr - 1) + ip + pchild%edges(ip,jr,kp,1)%ptr => pmeta%child(q)%ptr + pchild%edges(ir,jr,kp,1)%ptr => pmeta%child(q)%ptr + else + if (pneigh%level > pmeta%level) then + pchild%edges(ip,jr,kp,1)%ptr => pneigh + pchild%edges(ir,jr,kp,1)%ptr => pneigh + end if + end if + end if ! pneigh associated + +!--- update corner neighbor pointers --- +! +! calculate the index of the neighbor child +! + q = 4 * (kr - 1) + 2 * (jr - 1) + ir + +! process child corner which overlaps with the parent's one +! + pneigh => pmeta%corners(ip,jp,kp)%ptr + if (associated(pneigh)) then + if (pneigh%id == pmeta%id) then + pchild%corners(ip,jp,kp)%ptr => pmeta%child(q)%ptr + else + pchild%corners(ip,jp,kp)%ptr => pmeta%corners(ip,jp,kp)%ptr + end if + end if ! pneigh associated + +! process child corner which points to another child +! + pchild%corners(ir,jr,kr)%ptr => pmeta%child(q)%ptr + +! process child corners which lay on parent's edges +! +! along X direction +! + pneigh => pmeta%edges(ir,jp,kp,1)%ptr + if (associated(pneigh)) then + if (pneigh%id == pmeta%id) then + pchild%corners(ir,jp,kp)%ptr => pmeta%child(q)%ptr + else + if (pneigh%level > pmeta%level) & + pchild%corners(ir,jp,kp)%ptr => pneigh + end if + end if ! pneigh associated + +! along Y direction +! + pneigh => pmeta%edges(ip,jr,kp,2)%ptr + if (associated(pneigh)) then + if (pneigh%id == pmeta%id) then + pchild%corners(ip,jr,kp)%ptr => pmeta%child(q)%ptr + else + if (pneigh%level > pmeta%level) & + pchild%corners(ip,jr,kp)%ptr => pneigh + end if + end if ! pneigh associated + +! along Z-direction +! + pneigh => pmeta%edges(ip,jp,kr,3)%ptr + if (associated(pneigh)) then + if (pneigh%id == pmeta%id) then + pchild%corners(ip,jp,kr)%ptr => pmeta%child(q)%ptr + else + if (pneigh%level > pmeta%level) & + pchild%corners(ip,jp,kr)%ptr => pneigh + end if + end if ! pneigh associated + +! process child corners which lay on parent's faces +! +! on X-face +! + pneigh => pmeta%faces(ip,jr,kr,1)%ptr + if (associated(pneigh)) then + if (pneigh%id == pmeta%id) then + pchild%corners(ip,jr,kr)%ptr => pmeta%child(q)%ptr + else + if (pneigh%level > pmeta%level) & + pchild%corners(ip,jr,kr)%ptr => pneigh + end if + end if ! pneigh associated + +! on Y-face +! + pneigh => pmeta%faces(ir,jp,kr,2)%ptr + if (associated(pneigh)) then + if (pneigh%id == pmeta%id) then + pchild%corners(ir,jp,kr)%ptr => pmeta%child(q)%ptr + else + if (pneigh%level > pmeta%level) & + pchild%corners(ir,jp,kr)%ptr => pneigh + end if + end if ! pneigh associated + +! on Z-face +! + pneigh => pmeta%faces(ir,jr,kp,3)%ptr + if (associated(pneigh)) then + if (pneigh%id == pmeta%id) then + pchild%corners(ir,jr,kp)%ptr => pmeta%child(q)%ptr + else + if (pneigh%level > pmeta%level) & + pchild%corners(ir,jr,kp)%ptr => pneigh + end if + end if ! pneigh associated + + end do ! ip = 1, nsides + end do ! jp = 1, nsides + end do ! kp = 1, nsides +#endif /* NDIMS == 3 */ ! update neighbor pointers of the neighbor blocks ! From 847a2022856ea6e9525f43e629069c0695e83d3e Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 22 Jul 2014 04:17:11 -0300 Subject: [PATCH 66/91] BLOCKS: Add 3D neighbor' pointers update in refine_block(). This adds the neighbor' pointer update in 3D case in refine_block(). Signed-off-by: Grzegorz Kowal --- src/blocks.F90 | 230 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 230 insertions(+) diff --git a/src/blocks.F90 b/src/blocks.F90 index 14f5e21..54a735b 100644 --- a/src/blocks.F90 +++ b/src/blocks.F90 @@ -2146,6 +2146,236 @@ module blocks end do ! ip = 1, nsides end do ! jp = 1, nsides #endif /* NDIMS == 2 */ +#if NDIMS == 3 +! update neighbor's face pointers (only in 3D) +! + do kp = 1, nsides + kr = 3 - kp + do jp = 1, nsides + jr = 3 - jp + do ip = 1, nsides + ir = 3 - ip + +! calculate the child index +! + p = 4 * (kp - 1) + 2 * (jp - 1) + ip + +! associate pchild with the proper child +! + pchild => pmeta%child(p)%ptr + +!--- update neighbor's face pointers --- +! +! assign pneigh to the X-face neighbor +! + pneigh => pmeta%faces(ip,jp,kp,1)%ptr + +! set the corresponding neighbor face pointers +! + if (associated(pneigh)) then + if (pneigh%level > pmeta%level) then + do k = 1, nsides + do j = 1, nsides + pneigh%faces(ir,j,k,1)%ptr => pchild + end do + end do + else + pneigh%faces(ir,jp,kp,1)%ptr => pchild + end if + end if ! pneigh associated + +! assign pneigh to the Y-face neighbor +! + pneigh => pmeta%faces(ip,jp,kp,2)%ptr + +! set the corresponding neighbor face pointers +! + if (associated(pneigh)) then + if (pneigh%level > pmeta%level) then + do k = 1, nsides + do i = 1, nsides + pneigh%faces(i,jr,k,2)%ptr => pchild + end do + end do + else + pneigh%faces(ip,jr,kp,2)%ptr => pchild + end if + end if ! pneigh associated + +! assign pneigh to the Z-face neighbor +! + pneigh => pmeta%faces(ip,jp,kp,3)%ptr + +! set the corresponding neighbor face pointers +! + if (associated(pneigh)) then + if (pneigh%level > pmeta%level) then + do j = 1, nsides + do i = 1, nsides + pneigh%faces(i,j,kr,3)%ptr => pchild + end do + end do + else + pneigh%faces(ip,jp,kr,3)%ptr => pchild + end if + end if ! pneigh associated + +!--- update neighbor's edge pointers --- +! +! along X direction +! + pneigh => pmeta%edges(ip,jp,kp,1)%ptr + if (associated(pneigh)) then + pneigh%edges(ip,jr,kr,1)%ptr => pchild + if (pneigh%level > pmeta%level) & + pneigh%edges(ir,jr,kr,1)%ptr => pchild + end if ! pneigh associated + +! along Y direction +! + pneigh => pmeta%edges(ip,jp,kp,2)%ptr + if (associated(pneigh)) then + pneigh%edges(ir,jp,kr,2)%ptr => pchild + if (pneigh%level > pmeta%level) & + pneigh%edges(ir,jr,kr,2)%ptr => pchild + end if ! pneigh associated + +! along Z direction +! + pneigh => pmeta%edges(ip,jp,kp,3)%ptr + if (associated(pneigh)) then + pneigh%edges(ir,jr,kp,3)%ptr => pchild + if (pneigh%level > pmeta%level) & + pneigh%edges(ir,jr,kr,3)%ptr => pchild + end if ! pneigh associated + +! process child edges on the parent's X face +! +! Z-direction +! + pneigh => pmeta%faces(ip,jr,kp,1)%ptr + if (associated(pneigh)) then + if (pneigh%level == pchild%level) then + pneigh%edges(ir,jp,kp,3)%ptr => pchild + pneigh%edges(ir,jp,kr,3)%ptr => pchild + end if + end if ! pneigh associated + +! Y-direction +! + pneigh => pmeta%faces(ip,jp,kr,1)%ptr + if (associated(pneigh)) then + if (pneigh%level == pchild%level) then + pneigh%edges(ir,jp,kp,2)%ptr => pchild + pneigh%edges(ir,jr,kp,2)%ptr => pchild + end if + end if ! pneigh associated + +! process child edges on the parent's Y face +! +! Z-direction +! + pneigh => pmeta%faces(ir,jp,kp,2)%ptr + if (associated(pneigh)) then + if (pneigh%level == pchild%level) then + pneigh%edges(ip,jr,kp,3)%ptr => pchild + pneigh%edges(ip,jr,kr,3)%ptr => pchild + end if + end if ! pneigh associated +! X-direction +! + pneigh => pmeta%faces(ip,jp,kr,2)%ptr + if (associated(pneigh)) then + if (pneigh%level == pchild%level) then + pneigh%edges(ip,jr,kp,1)%ptr => pchild + pneigh%edges(ir,jr,kp,1)%ptr => pchild + end if + end if ! pneigh associated + +! process child edges on the parent's Z face +! +! Y-direction +! + pneigh => pmeta%faces(ir,jp,kp,3)%ptr + if (associated(pneigh)) then + if (pneigh%level == pchild%level) then + pneigh%edges(ip,jp,kr,2)%ptr => pchild + pneigh%edges(ip,jr,kr,2)%ptr => pchild + end if + end if ! pneigh associated +! X-direction +! + pneigh => pmeta%faces(ip,jr,kp,3)%ptr + if (associated(pneigh)) then + if (pneigh%level == pchild%level) then + pneigh%edges(ip,jp,kr,1)%ptr => pchild + pneigh%edges(ir,jp,kr,1)%ptr => pchild + end if + end if ! pneigh associated + +!--- update neighbor's corner pointers --- +! +! calculate the index of the opposite child +! + q = 4 * (kr - 1) + 2 * (jr - 1) + ir + +! update neighbor's corner which overlaps with the parent's one +! + pneigh => pmeta%corners(ip,jp,kp)%ptr + if (associated(pneigh)) pneigh%corners(ir,jr,kr)%ptr => pchild + +! process neighbot's corners which lay on parent's edges +! +! X-edge +! + pneigh => pmeta%edges(ir,jp,kp,1)%ptr + if (associated(pneigh)) then + if (pneigh%level > pmeta%level) & + pneigh%corners(ip,jr,kr)%ptr => pchild + end if ! pneigh associated +! Y-edge +! + pneigh => pmeta%edges(ip,jr,kp,2)%ptr + if (associated(pneigh)) then + if (pneigh%level > pmeta%level) & + pneigh%corners(ir,jp,kr)%ptr => pchild + end if ! pneigh associated +! Z-edge +! + pneigh => pmeta%edges(ip,jp,kr,3)%ptr + if (associated(pneigh)) then + if (pneigh%level > pmeta%level) & + pneigh%corners(ir,jr,kp)%ptr => pchild + end if ! pneigh associated + +! process child corners which lay on parent's faces +! +! X-face +! + pneigh => pmeta%faces(ip,jr,kr,1)%ptr + if (associated(pneigh)) then + if (pneigh%level > pmeta%level) & + pneigh%corners(ir,jp,kp)%ptr => pchild + end if ! pneigh associated +! Y-face +! + pneigh => pmeta%faces(ir,jp,kr,2)%ptr + if (associated(pneigh)) then + if (pneigh%level > pmeta%level) & + pneigh%corners(ip,jr,kp)%ptr => pchild + end if ! pneigh associated +! Z-face +! + pneigh => pmeta%faces(ir,jr,kp,3)%ptr + if (associated(pneigh)) then + if (pneigh%level > pmeta%level) & + pneigh%corners(ip,jp,kr)%ptr => pchild + end if ! pneigh associated + + end do ! ip = 1, nsides + end do ! jp = 1, nsides + end do ! kp = 1, nsides +#endif /* NDIMS == 3 */ !! ASSIGN PROPER NEIGHBORS FOR THE CHILDREN IN THE INTERIOR OF THE PARENT BLOCK !! From 5268d1eac9ef381c70fbe4c9c5dfdd3c1e244331 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 22 Jul 2014 04:21:01 -0300 Subject: [PATCH 67/91] BLOCKS: Add 3D neighbor pointer update in derefine_block(). This adds the neighbor pointer update in 3D case in derefine_block(). Signed-off-by: Grzegorz Kowal --- src/blocks.F90 | 135 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 135 insertions(+) diff --git a/src/blocks.F90 b/src/blocks.F90 index 54a735b..87ab86a 100644 --- a/src/blocks.F90 +++ b/src/blocks.F90 @@ -2841,6 +2841,141 @@ module blocks end do ! ip = 1, nsides end do ! jp = 1, nsides #endif /* NDIMS == 2 */ +#if NDIMS == 3 + do kp = 1, nsides + kr = 3 - kp + do jp = 1, nsides + jr = 3 - jp + do ip = 1, nsides + ir = 3 - ip + +! calculate the child index +! + p = 4 * (kp - 1) + 2 * (jp - 1) + ip + +! associate pchild with the proper child +! + pchild => pmeta%child(p)%ptr + +!--- update face neighbor pointers --- +! +! assign pneigh to the X-face neighbor +! + pneigh => pchild%faces(ip,jp,kp,1)%ptr + +! set the corresponding neighbor face pointers +! + if (associated(pneigh)) then + q = 4 * (kp - 1) + 2 * (jp - 1) + ir + if (pneigh%id == pmeta%child(q)%ptr%id) then + pmeta%faces(ip,jp,kp,1)%ptr => pmeta + else + pmeta%faces(ip,jp,kp,1)%ptr => pneigh + end if + end if + +! assign pneigh to the Y-face neighbor +! + pneigh => pchild%faces(ip,jp,kp,2)%ptr + +! set the corresponding neighbor face pointers +! + if (associated(pneigh)) then + q = 4 * (kp - 1) + 2 * (jr - 1) + ip + if (pneigh%id == pmeta%child(q)%ptr%id) then + pmeta%faces(ip,jp,kp,2)%ptr => pmeta + else + pmeta%faces(ip,jp,kp,2)%ptr => pneigh + end if + end if + +! assign pneigh to the Z-face neighbor +! + pneigh => pchild%faces(ip,jp,kp,3)%ptr + +! set the corresponding neighbor face pointers +! + if (associated(pneigh)) then + q = 4 * (kr - 1) + 2 * (jp - 1) + ip + if (pneigh%id == pmeta%child(q)%ptr%id) then + pmeta%faces(ip,jp,kp,3)%ptr => pmeta + else + pmeta%faces(ip,jp,kp,3)%ptr => pneigh + end if + end if + +!--- update edge neighbor pointers --- +! +! associate pneigh with the X edge neighbor +! + pneigh => pchild%edges(ip,jp,kp,1)%ptr + +! process edge along X-direction if pneigh associated +! + if (associated(pneigh)) then + q = 4 * (kr - 1) + 2 * (jr - 1) + ip + if (pneigh%id == pmeta%child(q)%ptr%id) then + pmeta%edges(ip,jp,kp,1)%ptr => pmeta + else + pmeta%edges(ip,jp,kp,1)%ptr => pneigh + end if + end if ! pneigh associated + +! associate pneigh with the Y edge neighbor +! + pneigh => pchild%edges(ip,jp,kp,2)%ptr + +! process edge along Y-direction if pneigh associated +! + if (associated(pneigh)) then + q = 4 * (kr - 1) + 2 * (jp - 1) + ir + if (pneigh%id == pmeta%child(q)%ptr%id) then + pmeta%edges(ip,jp,kp,2)%ptr => pmeta + else + pmeta%edges(ip,jp,kp,2)%ptr => pneigh + end if + end if ! pneigh associated + +! associate pneigh with the Z edge neighbor +! + pneigh => pchild%edges(ip,jp,kp,3)%ptr + +! process edge along Y-direction if pneigh associated +! + if (associated(pneigh)) then + q = 4 * (kp - 1) + 2 * (jr - 1) + ir + if (pneigh%id == pmeta%child(q)%ptr%id) then + pmeta%edges(ip,jp,kp,3)%ptr => pmeta + else + pmeta%edges(ip,jp,kp,3)%ptr => pneigh + end if + end if ! pneigh associated + +!--- update corner neighbor pointers --- +! +! associate pneigh with the corner neighbor +! + pneigh => pchild%corners(ip,jp,kp)%ptr + +! update the corner neighbor pointer +! + if (associated(pneigh)) then + +! calculate the index of the opposite child +! + q = 4 * (kr - 1) + 2 * (jr - 1) + ir + + if (pneigh%id == pmeta%child(q)%ptr%id) then + pmeta%corners(ip,jp,kp)%ptr => pmeta + else + pmeta%corners(ip,jp,kp)%ptr => pneigh + end if + end if ! pneigh associated + + end do ! ip = 1, nsides + end do ! jp = 1, nsides + end do ! kp = 1, nsides +#endif /* NDIMS == 3 */ ! update neighbor pointers of the neighbor blocks ! From b94bcf472c3781fc80c7e2c753c4e4acc05e4b7c Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 22 Jul 2014 04:23:49 -0300 Subject: [PATCH 68/91] BLOCKS: Add 3D neighbor' pointers update in derefine_block(). This adds the neighbor' pointer update in 3D case in derefine_block(). Signed-off-by: Grzegorz Kowal --- src/blocks.F90 | 195 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 195 insertions(+) diff --git a/src/blocks.F90 b/src/blocks.F90 index 87ab86a..de98b2b 100644 --- a/src/blocks.F90 +++ b/src/blocks.F90 @@ -3029,6 +3029,201 @@ module blocks end do ! ip = 1, nsides end do ! jp = 1, nsides #endif /* NDIMS == 2 */ +#if NDIMS == 3 + do kp = 1, nsides + kr = 3 - kp + do jp = 1, nsides + jr = 3 - jp + do ip = 1, nsides + ir = 3 - ip + +!--- update neighbor's face pointers --- +! +! assign pneigh to the X-face neighbor +! + pneigh => pmeta%faces(ip,jp,kp,1)%ptr + +! set the corresponding neighbor face pointers +! + if (associated(pneigh)) then + if (pneigh%level > pmeta%level) then + do k = 1, nsides + do j = 1, nsides + pneigh%faces(ir,j,k,1)%ptr => pmeta + end do + end do + else + pneigh%faces(ir,jp,kp,1)%ptr => pmeta + end if + end if ! pneigh associated + +! assign pneigh to the Y-face neighbor +! + pneigh => pmeta%faces(ip,jp,kp,2)%ptr + +! set the corresponding neighbor face pointers +! + if (associated(pneigh)) then + if (pneigh%level > pmeta%level) then + do k = 1, nsides + do i = 1, nsides + pneigh%faces(i,jr,k,2)%ptr => pmeta + end do + end do + else + pneigh%faces(ip,jr,kp,2)%ptr => pmeta + end if + end if ! pneigh associated + +! assign pneigh to the Z-face neighbor +! + pneigh => pmeta%faces(ip,jp,kp,3)%ptr + +! set the corresponding neighbor face pointers +! + if (associated(pneigh)) then + if (pneigh%level > pmeta%level) then + do j = 1, nsides + do i = 1, nsides + pneigh%faces(i,j,kr,3)%ptr => pmeta + end do + end do + else + pneigh%faces(ip,jp,kr,3)%ptr => pmeta + end if + end if ! pneigh associated + +!--- update neighbor's edge pointers --- +! +! process the edges in all directions which lay on the parent's edges +! +! X-edge +! + pneigh => pmeta%edges(ip,jp,kp,1)%ptr + if (associated(pneigh)) then + pneigh%edges(ip,jr,kr,1)%ptr => pmeta + if (pneigh%level > pmeta%level) & + pneigh%edges(ir,jr,kr,1)%ptr => pmeta + end if ! pneigh associated + +! Y-edge +! + pneigh => pmeta%edges(ip,jp,kp,2)%ptr + if (associated(pneigh)) then + pneigh%edges(ir,jp,kr,2)%ptr => pmeta + if (pneigh%level > pmeta%level) & + pneigh%edges(ir,jr,kr,2)%ptr => pmeta + end if ! pneigh associated + +! Z-edge +! + pneigh => pmeta%edges(ip,jp,kp,3)%ptr + if (associated(pneigh)) then + pneigh%edges(ir,jr,kp,3)%ptr => pmeta + if (pneigh%level > pmeta%level) & + pneigh%edges(ir,jr,kr,3)%ptr => pmeta + end if ! pneigh associated + +! nullify neighbors edge pointers if they are on higher levels +! +! X-face +! + pneigh => pmeta%faces(ip,jr,kp,1)%ptr + if (associated(pneigh)) then + if (pneigh%level > pmeta%level) then + nullify(pneigh%edges(ir,jp,kp,3)%ptr) + nullify(pneigh%edges(ir,jp,kr,3)%ptr) + end if + end if ! pneigh associated + pneigh => pmeta%faces(ip,jp,kr,1)%ptr + if (associated(pneigh)) then + if (pneigh%level > pmeta%level) then + nullify(pneigh%edges(ir,jp,kp,2)%ptr) + nullify(pneigh%edges(ir,jr,kp,2)%ptr) + end if + end if ! pneigh associated + +! Y-face +! + pneigh => pmeta%faces(ir,jp,kp,2)%ptr + if (associated(pneigh)) then + if (pneigh%level > pmeta%level) then + nullify(pneigh%edges(ip,jr,kp,3)%ptr) + nullify(pneigh%edges(ip,jr,kr,3)%ptr) + end if + end if ! pneigh associated + pneigh => pmeta%faces(ip,jp,kr,2)%ptr + if (associated(pneigh)) then + if (pneigh%level > pmeta%level) then + nullify(pneigh%edges(ip,jr,kp,1)%ptr) + nullify(pneigh%edges(ir,jr,kp,1)%ptr) + end if + end if ! pneigh associated + +! Z-face +! + pneigh => pmeta%faces(ir,jp,kp,3)%ptr + if (associated(pneigh)) then + if (pneigh%level > pmeta%level) then + nullify(pneigh%edges(ip,jp,kr,2)%ptr) + nullify(pneigh%edges(ip,jr,kr,2)%ptr) + end if + end if ! pneigh associated + pneigh => pmeta%faces(ip,jr,kp,3)%ptr + if (associated(pneigh)) then + if (pneigh%level > pmeta%level) then + nullify(pneigh%edges(ip,jp,kr,1)%ptr) + nullify(pneigh%edges(ir,jp,kr,1)%ptr) + end if + end if ! pneigh associated + +!--- update neighbor's corner pointers --- +! +! associate pneigh with the corner pointer +! + pneigh => pmeta%corners(ip,jp,kp)%ptr + if (associated(pneigh)) pneigh%corners(ir,jr,kr)%ptr => pmeta + +! nullify neighbor corners pointing to pmeta edges +! + pneigh => pmeta%edges(ir,jp,kp,1)%ptr + if (associated(pneigh)) then + if (pneigh%level > pmeta%level) & + nullify(pneigh%corners(ip,jr,kr)%ptr) + end if ! pneigh associated + pneigh => pmeta%edges(ip,jr,kp,2)%ptr + if (associated(pneigh)) then + if (pneigh%level > pmeta%level) & + nullify(pneigh%corners(ir,jp,kr)%ptr) + end if ! pneigh associated + pneigh => pmeta%edges(ip,jp,kr,3)%ptr + if (associated(pneigh)) then + if (pneigh%level > pmeta%level) & + nullify(pneigh%corners(ir,jr,kp)%ptr) + end if ! pneigh associated + +! nullify neighbor corners pointing to pmeta faces +! + pneigh => pmeta%faces(ip,jr,kr,1)%ptr + if (associated(pneigh)) then + if (pneigh%level > pmeta%level) & + nullify(pneigh%corners(ir,jp,kp)%ptr) + end if ! pneigh associated + pneigh => pmeta%faces(ir,jp,kr,2)%ptr + if (associated(pneigh)) then + if (pneigh%level > pmeta%level) & + nullify(pneigh%corners(ip,jr,kp)%ptr) + end if ! pneigh associated + pneigh => pmeta%faces(ir,jr,kp,3)%ptr + if (associated(pneigh)) then + if (pneigh%level > pmeta%level) & + nullify(pneigh%corners(ip,jp,kr)%ptr) + end if ! pneigh associated + + end do ! ip = 1, nsides + end do ! jp = 1, nsides + end do ! kp = 1, nsides +#endif /* NDIMS == 3 */ ! iterate over dimensions, sides, and faces ! From fc34acfed0e57206470d0594d57165664b06f303 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 22 Jul 2014 07:39:19 -0300 Subject: [PATCH 69/91] BOUNDARIES: Add subroutine block_face_copy(). This subroutine extracts the face region from the domain of input variable array by copying it to output array. Signed-off-by: Grzegorz Kowal --- src/boundaries.F90 | 168 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 168 insertions(+) diff --git a/src/boundaries.F90 b/src/boundaries.F90 index 0421073..b936234 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -6705,6 +6705,174 @@ module boundaries !------------------------------------------------------------------------------- ! end subroutine boundary_prolong +#if NDIMS == 3 +! +!=============================================================================== +! +! BLOCK FACE UPDATE SUBROUTINES +! +!=============================================================================== +! +! subroutine BLOCK_FACE_COPY: +! -------------------------- +! +! Subroutine returns the face boundary region copied it from the provided +! input variable array. +! +! Arguments: +! +! nc - the face direction; +! ic, jc, kc - the corner position; +! qn - the input neighbor variable array; +! qb - the output face boundary array; +! +!=============================================================================== +! + subroutine block_face_copy(nc, ic, jc, kc, qn, qb) + +! import external procedures and variables +! + use coordinates , only : ng + use coordinates , only : in , jn , kn + use coordinates , only : im , jm , km + use coordinates , only : ib , jb , kb + use coordinates , only : ie , je , ke + use coordinates , only : ibu, jbu, kbu + use coordinates , only : iel, jel, kel + use equations , only : nv + +! local variables are not implicit by default +! + implicit none + +! subroutine arguments +! + integer , intent(in) :: nc, ic, jc, kc + real(kind=8), dimension(1:nv,1:im,1:jm,1:km), intent(in) :: qn + real(kind=8), dimension( : , : , : , : ), intent(out) :: qb + +! local indices +! + integer :: ih, jh, kh + integer :: il, jl, kl + integer :: iu, ju, ku +! +!------------------------------------------------------------------------------- +! +! process depending on the direction +! + select case(nc) + case(1) + +! calculate half sizes +! + jh = jn / 2 + kh = kn / 2 + +! prepare indices for the face region +! + if (ic == 1) then + il = iel + iu = ie + else + il = ib + iu = ibu + end if + if (jc == 1) then + jl = jb + ju = jb + jh - 1 + else + jl = je - jh + 1 + ju = je + end if + if (kc == 1) then + kl = kb + ku = kb + kh - 1 + else + kl = ke - kh + 1 + ku = ke + end if + +! copy the face region to the output array +! + qb(1:nv,1:ng,1:jh,1:kh) = qn(1:nv,il:iu,jl:ju,kl:ku) + + case(2) + +! calculate half sizes +! + ih = in / 2 + kh = kn / 2 + +! prepare indices for the face region +! + if (ic == 1) then + il = ib + iu = ib + ih - 1 + else + il = ie - ih + 1 + iu = ie + end if + if (jc == 1) then + jl = jel + ju = je + else + jl = jb + ju = jbu + end if + if (kc == 1) then + kl = kb + ku = kb + kh - 1 + else + kl = ke - kh + 1 + ku = ke + end if + +! copy the face region to the output array +! + qb(1:nv,1:ih,1:ng,1:kh) = qn(1:nv,il:iu,jl:ju,kl:ku) + + case(3) + +! calculate half sizes +! + ih = in / 2 + jh = jn / 2 + +! prepare indices for the face region +! + if (ic == 1) then + il = ib + iu = ib + ih - 1 + else + il = ie - ih + 1 + iu = ie + end if + if (jc == 1) then + jl = jb + ju = jb + jh - 1 + else + jl = je - jh + 1 + ju = je + end if + if (kc == 1) then + kl = kel + ku = ke + else + kl = kb + ku = kbu + end if + +! copy the face region to the output array +! + qb(1:nv,1:ih,1:jh,1:ng) = qn(1:nv,il:iu,jl:ju,kl:ku) + + end select + +!------------------------------------------------------------------------------- +! + end subroutine block_face_copy +#endif /* NDIMS == 3 */ ! !=============================================================================== ! From 5fd6d9d6649e98935c4335a928266c122acbf2d7 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 22 Jul 2014 07:48:43 -0300 Subject: [PATCH 70/91] BOUNDARIES: Add subroutine block_face_restrict(). This subroutine extracts the face region from the domain of input variable array by restricting it to output array. Signed-off-by: Grzegorz Kowal --- src/boundaries.F90 | 170 ++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 169 insertions(+), 1 deletion(-) diff --git a/src/boundaries.F90 b/src/boundaries.F90 index b936234..7160207 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -6716,7 +6716,7 @@ module boundaries ! subroutine BLOCK_FACE_COPY: ! -------------------------- ! -! Subroutine returns the face boundary region copied it from the provided +! Subroutine returns the face boundary region copied from the provided ! input variable array. ! ! Arguments: @@ -6872,6 +6872,174 @@ module boundaries !------------------------------------------------------------------------------- ! end subroutine block_face_copy +! +!=============================================================================== +! +! subroutine BLOCK_FACE_RESTRICT: +! ------------------------------ +! +! Subroutine returns the face boundary region restricted from the provided +! input variable array. +! +! Arguments: +! +! nc - the face direction; +! ic, jc, kc - the corner position; +! qn - the input neighbor variable array; +! qb - the output face boundary array; +! +!=============================================================================== +! + subroutine block_face_restrict(nc, ic, jc, kc, qn, qb) + +! import external procedures and variables +! + use coordinates , only : ng, nd + use coordinates , only : in + use coordinates , only : in , jn , kn + use coordinates , only : im , jm , km + use coordinates , only : ib , jb , kb + use coordinates , only : ie , je , ke + use equations , only : nv + +! local variables are not implicit by default +! + implicit none + +! subroutine arguments +! + integer , intent(in) :: nc, ic, jc, kc + real(kind=8), dimension(1:nv,1:im,1:jm,1:km), intent(in) :: qn + real(kind=8), dimension( : , : , : , : ), intent(out) :: qb + +! local variables +! + integer :: ih, jh, kh + integer :: il, jl, kl + integer :: ip, jp, kp + integer :: iu, ju, ku +! +!------------------------------------------------------------------------------- +! +! process depending on the direction +! + select case(nc) + case(1) + +! calculate half sizes +! + jh = jn / 2 + kh = kn / 2 + +! prepare indices for the face region +! + if (ic == 1) then + il = ie - nd + 1 + ip = il + 1 + iu = ie + else + il = ib + ip = il + 1 + iu = ib + nd - 1 + end if + jl = jb + jp = jl + 1 + ju = je + kl = kb + kp = kl + 1 + ku = ke + +! restrict the face region to the output array +! + qb(1:nv,1:ng,1:jh,1:kh) = & + 1.25d-01 * (((qn(1:nv,il:iu:2,jl:ju:2,kl:ku:2) & + + qn(1:nv,ip:iu:2,jp:ju:2,kp:ku:2)) & + + (qn(1:nv,il:iu:2,jl:ju:2,kp:ku:2) & + + qn(1:nv,ip:iu:2,jp:ju:2,kl:ku:2))) & + + ((qn(1:nv,il:iu:2,jp:ju:2,kp:ku:2) & + + qn(1:nv,ip:iu:2,jl:ju:2,kl:ku:2)) & + + (qn(1:nv,il:iu:2,jp:ju:2,kl:ku:2) & + + qn(1:nv,ip:iu:2,jl:ju:2,kp:ku:2)))) + + case(2) + +! calculate half sizes +! + ih = in / 2 + kh = kn / 2 + +! prepare indices for the face region +! + il = ib + ip = il + 1 + iu = ie + if (jc == 1) then + jl = je - nd + 1 + jp = jl + 1 + ju = je + else + jl = jb + jp = jl + 1 + ju = jb + nd - 1 + end if + kl = kb + kp = kl + 1 + ku = ke + +! restrict the face region to the output array +! + qb(1:nv,1:ih,1:ng,1:kh) = & + 1.25d-01 * (((qn(1:nv,il:iu:2,jl:ju:2,kl:ku:2) & + + qn(1:nv,ip:iu:2,jp:ju:2,kp:ku:2)) & + + (qn(1:nv,il:iu:2,jl:ju:2,kp:ku:2) & + + qn(1:nv,ip:iu:2,jp:ju:2,kl:ku:2))) & + + ((qn(1:nv,il:iu:2,jp:ju:2,kp:ku:2) & + + qn(1:nv,ip:iu:2,jl:ju:2,kl:ku:2)) & + + (qn(1:nv,il:iu:2,jp:ju:2,kl:ku:2) & + + qn(1:nv,ip:iu:2,jl:ju:2,kp:ku:2)))) + + case(3) + +! calculate half sizes +! + ih = in / 2 + jh = jn / 2 + +! prepare indices for the face region +! + il = ib + ip = il + 1 + iu = ie + jl = jb + jp = jl + 1 + ju = je + if (kc == 1) then + kl = ke - nd + 1 + kp = kl + 1 + ku = ke + else + kl = kb + kp = kl + 1 + ku = kb + nd - 1 + end if + +! restrict the face region to the output array +! + qb(1:nv,1:ih,1:jh,1:ng) = & + 1.25d-01 * (((qn(1:nv,il:iu:2,jl:ju:2,kl:ku:2) & + + qn(1:nv,ip:iu:2,jp:ju:2,kp:ku:2)) & + + (qn(1:nv,il:iu:2,jl:ju:2,kp:ku:2) & + + qn(1:nv,ip:iu:2,jp:ju:2,kl:ku:2))) & + + ((qn(1:nv,il:iu:2,jp:ju:2,kp:ku:2) & + + qn(1:nv,ip:iu:2,jl:ju:2,kl:ku:2)) & + + (qn(1:nv,il:iu:2,jp:ju:2,kl:ku:2) & + + qn(1:nv,ip:iu:2,jl:ju:2,kp:ku:2)))) + + end select + +!------------------------------------------------------------------------------- +! + end subroutine block_face_restrict #endif /* NDIMS == 3 */ ! !=============================================================================== From b3d587727aa12a772be40436ba5f1887a5202714 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 22 Jul 2014 07:55:02 -0300 Subject: [PATCH 71/91] BOUNDARIES: Add subroutine block_face_prolong(). This subroutine extracts the face region from the domain of input variable array by prolongating it to output array. Signed-off-by: Grzegorz Kowal --- src/boundaries.F90 | 218 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 218 insertions(+) diff --git a/src/boundaries.F90 b/src/boundaries.F90 index 7160207..b314826 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -7040,6 +7040,224 @@ module boundaries !------------------------------------------------------------------------------- ! end subroutine block_face_restrict +! +!=============================================================================== +! +! subroutine BLOCK_FACE_PROLONG: +! ----------------------------- +! +! Subroutine returns the face boundary region prolongated from the provided +! input variable array. +! +! Arguments: +! +! nc - the face direction; +! ic, jc, kc - the corner position; +! qn - the input neighbor variable array; +! qb - the output face boundary array; +! +!=============================================================================== +! + subroutine block_face_prolong(nc, ic, jc, kc, qn, qb) + +! import external procedures and variables +! + use coordinates , only : ng, nh + use coordinates , only : in + use coordinates , only : in , jn , kn + use coordinates , only : im , jm , km + use coordinates , only : ib , jb , kb + use coordinates , only : ie , je , ke + use equations , only : nv + use interpolations , only : limiter + +! local variables are not implicit by default +! + implicit none + +! subroutine arguments +! + integer , intent(in) :: nc, ic, jc, kc + real(kind=8), dimension(1:nv,1:im,1:jm,1:km), intent(in) :: qn + real(kind=8), dimension( : , : , : , : ), intent(out) :: qb + +! local variables +! + integer :: i, j, k, p + integer :: ih, jh, kh + integer :: il, jl, kl + integer :: iu, ju, ku + integer :: is, js, ks + integer :: it, jt, kt + integer :: im1, jm1, km1 + integer :: ip1, jp1, kp1 + real(kind=8) :: dql, dqr + real(kind=8) :: dqx, dqy, dqz + real(kind=8) :: dq1, dq2, dq3, dq4 +! +!------------------------------------------------------------------------------- +! +! process depending on the direction +! + select case(nc) + case(1) + +! calculate half sizes +! + jh = jn / 2 + kh = kn / 2 + +! prepare indices for the face region +! + if (ic == 1) then + il = ie - nh + 1 + iu = ie + else + il = ib + iu = ib + nh - 1 + end if + if (jc == 0) then + jl = jb + ju = jb + jh + nh - 1 + else + jl = je - jh - nh + 1 + ju = je + end if + if (kc == 0) then + kl = kb + ku = kb + kh + nh - 1 + else + kl = ke - kh - nh + 1 + ku = ke + end if + + case(2) + +! calculate half sizes +! + ih = in / 2 + kh = kn / 2 + +! prepare indices for the face region +! + if (ic == 0) then + il = ib + iu = ib + ih + nh - 1 + else + il = ie - ih - nh + 1 + iu = ie + end if + if (jc == 1) then + jl = je - nh + 1 + ju = je + else + jl = jb + ju = jb + nh - 1 + end if + if (kc == 0) then + kl = kb + ku = kb + kh + nh - 1 + else + kl = ke - kh - nh + 1 + ku = ke + end if + + case(3) + +! calculate half sizes +! + ih = in / 2 + jh = jn / 2 + +! prepare indices for the face region +! + if (ic == 0) then + il = ib + iu = ib + ih + nh - 1 + else + il = ie - ih - nh + 1 + iu = ie + end if + if (jc == 0) then + jl = jb + ju = jb + jh + nh - 1 + else + jl = je - jh - nh + 1 + ju = je + end if + if (kc == 1) then + kl = ke - nh + 1 + ku = ke + else + kl = kb + ku = kb + nh - 1 + end if + + end select + +! iterate over all face region cells +! + do k = kl, ku + km1 = k - 1 + kp1 = k + 1 + ks = 2 * (k - kl) + 1 + kt = ks + 1 + do j = jl, ju + jm1 = j - 1 + jp1 = j + 1 + js = 2 * (j - jl) + 1 + jt = js + 1 + do i = il, iu + im1 = i - 1 + ip1 = i + 1 + is = 2 * (i - il) + 1 + it = is + 1 + +! iterate over all variables +! + do p = 1, nv + +! calculate limited derivatives in all directions +! + dql = qn(p,i ,j,k) - qn(p,im1,j,k) + dqr = qn(p,ip1,j,k) - qn(p,i ,j,k) + dqx = limiter(0.25d+00, dql, dqr) + + dql = qn(p,i,j ,k) - qn(p,i,jm1,k) + dqr = qn(p,i,jp1,k) - qn(p,i,j ,k) + dqy = limiter(0.25d+00, dql, dqr) + + dql = qn(p,i,j,k ) - qn(p,i,j,km1) + dqr = qn(p,i,j,kp1) - qn(p,i,j,k ) + dqz = limiter(0.25d+00, dql, dqr) + +! calculate the derivative terms +! + dq1 = dqx + dqy + dqz + dq2 = dqx - dqy - dqz + dq3 = dqx - dqy + dqz + dq4 = dqx + dqy - dqz + +! prolongate the face region to the output array +! + qb(p,is,js,ks) = qn(p,i,j,k) - dq1 + qb(p,it,js,ks) = qn(p,i,j,k) + dq2 + qb(p,is,jt,ks) = qn(p,i,j,k) - dq3 + qb(p,it,jt,ks) = qn(p,i,j,k) + dq4 + qb(p,is,js,kt) = qn(p,i,j,k) - dq4 + qb(p,it,js,kt) = qn(p,i,j,k) + dq3 + qb(p,is,jt,kt) = qn(p,i,j,k) - dq2 + qb(p,it,jt,kt) = qn(p,i,j,k) + dq1 + + end do ! q = 1, nv + + end do ! i = il, iu + end do ! j = jl, ju + end do ! k = kl, ku + +!------------------------------------------------------------------------------- +! + end subroutine block_face_prolong #endif /* NDIMS == 3 */ ! !=============================================================================== From 7a9922facd44afaeccb421acc23136f75786681e Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 22 Jul 2014 08:09:22 -0300 Subject: [PATCH 72/91] BOUNDARIES: Add subroutine boundaries_face_copy(). This subroutine scans over all leafs and update their face boundaries if both blocks lay on the same level. Signed-off-by: Grzegorz Kowal --- src/boundaries.F90 | 556 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 556 insertions(+) diff --git a/src/boundaries.F90 b/src/boundaries.F90 index b314826..49e55b6 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -2801,6 +2801,562 @@ module boundaries !------------------------------------------------------------------------------- ! end subroutine prolong_boundaries +#if NDIMS == 3 +! +!=============================================================================== +! +! DOMAIN FACE BOUNDARY UPDATE SUBROUTINES +! +!=============================================================================== +! +! subroutine BOUNDARIES_FACE_COPY: +! ------------------------------- +! +! Subroutine scans over all leaf blocks in order to find face neighbors which +! are the same level, and perform the update of the face boundaries between +! them. +! +! Arguments: +! +! idir - the direction to be processed; +! +!=============================================================================== +! + subroutine boundaries_face_copy(idir) + +! import external procedures and variables +! + use blocks , only : nsides + use blocks , only : block_meta, block_data + use blocks , only : list_meta + use blocks , only : block_info, pointer_info + use coordinates , only : ng + use coordinates , only : in , jn , kn + use coordinates , only : im , jm , km + use coordinates , only : ib , jb , kb + use coordinates , only : ie , je , ke + use coordinates , only : ibl, jbl, kbl + use coordinates , only : ieu, jeu, keu +#ifdef MPI + use equations , only : nv +#endif /* MPI */ + use mpitools , only : nproc, nprocs, npmax +#ifdef MPI + use mpitools , only : send_real_array, receive_real_array +#endif /* MPI */ + +! local variables are not implicit by default +! + implicit none + +! subroutine arguments +! + integer, intent(in) :: idir + +! local pointers +! + type(block_meta), pointer :: pmeta, pneigh +#ifdef MPI + type(block_info), pointer :: pinfo +#endif /* MPI */ + +! local variables +! + integer :: i , j , k + integer :: ih, jh, kh + integer :: il, jl, kl + integer :: iu, ju, ku + integer :: iret +#ifdef MPI + integer :: isend, irecv, nblocks, itag, l + +! local pointer arrays +! + type(pointer_info), dimension(0:npmax,0:npmax) :: block_array + +! local arrays +! + integer , dimension(0:npmax,0:npmax) :: block_counter + real(kind=8), dimension(:,:,:,:,:) , allocatable :: rbuf +#endif /* MPI */ +! +!------------------------------------------------------------------------------- +! +#ifdef PROFILE +! start accounting time for copy boundary update +! + call start_timer(imc) +#endif /* PROFILE */ + +! calculate half sizes +! + ih = in / 2 + jh = jn / 2 + kh = kn / 2 + +#ifdef MPI +!! 1. PREPARE THE BLOCK EXCHANGE ARRAYS FOR MPI +!! +! reset the exchange block counters +! + block_counter(:,:) = 0 + +! nullify the info pointers +! + do irecv = 0, npmax + do isend = 0, npmax + nullify(block_array(isend,irecv)%ptr) + end do + end do +#endif /* MPI */ + +!! 2. UPDATE VARIABLE FACE BOUNDARIES BETWEEN BLOCKS BELONGING TO THE SAME +!! PROCESS AND PREPARE THE EXCHANGE BLOCK LIST OF BLOCKS WHICH BELONG TO +!! DIFFERENT PROCESSES +!! +! associate pmeta with the first block on the meta block list +! + pmeta => list_meta + +! scan all meta blocks +! + do while(associated(pmeta)) + +! check if the block is leaf +! + if (pmeta%leaf) then + +! scan over all block corners +! + do k = 1, nsides + do j = 1, nsides + do i = 1, nsides + +! associate pneigh with the current neighbor +! + pneigh => pmeta%faces(i,j,k,idir)%ptr + +! check if the neighbor is associated +! + if (associated(pneigh)) then + +! check if the neighbor is at the same level +! + if (pneigh%level == pmeta%level) then + +! process only the block and its neighbor which are marked for update +! + if (pmeta%update .and. pneigh%update) then + +#ifdef MPI +! check if the block and its neighbor belong to the same process +! + if (pmeta%process == pneigh%process) then + +! check if the neighbor belongs to the current process +! + if (pneigh%process == nproc) then +#endif /* MPI */ + +! prepare region indices for the face boundary update +! + select case(idir) + case(1) + if (i == 1) then + il = 1 + iu = ibl + else + il = ieu + iu = im + end if + if (j == 1) then + jl = jb + ju = jb + jh - 1 + else + jl = je - jh + 1 + ju = je + end if + if (k == 1) then + kl = kb + ku = kb + kh - 1 + else + kl = ke - kh + 1 + ku = ke + end if + case(2) + if (i == 1) then + il = ib + iu = ib + ih - 1 + else + il = ie - ih + 1 + iu = ie + end if + if (j == 1) then + jl = 1 + ju = jbl + else + jl = jeu + ju = jm + end if + if (k == 1) then + kl = kb + ku = kb + kh - 1 + else + kl = ke - kh + 1 + ku = ke + end if + case(3) + if (i == 1) then + il = ib + iu = ib + ih - 1 + else + il = ie - ih + 1 + iu = ie + end if + if (j == 1) then + jl = jb + ju = jb + jh - 1 + else + jl = je - jh + 1 + ju = je + end if + if (k == 1) then + kl = 1 + ku = kbl + else + kl = keu + ku = km + end if + end select + +! extract the corresponding face region from the neighbor and insert it in +! the current data block +! + call block_face_copy(idir, i, j, k & + , pneigh%data%q(1:nv, 1:im, 1:jm, 1:km) & + , pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku)) + +#ifdef MPI + end if ! pneigh on the current process + + else ! block and neighbor belong to different processes + +! increase the counter for number of blocks to exchange +! + block_counter(pneigh%process,pmeta%process) = & + block_counter(pneigh%process,pmeta%process) + 1 + +! allocate a new info object +! + allocate(pinfo) + +! fill out only fields which are used +! + pinfo%block => pmeta + pinfo%neigh => pneigh + pinfo%direction = idir + pinfo%corner(1) = i + pinfo%corner(2) = j + pinfo%corner(3) = k + +! nullify pointer fields of the object +! + nullify(pinfo%prev) + nullify(pinfo%next) + +! if the list is not empty append the newly created block to it +! + if (associated(block_array(pneigh%process & + ,pmeta%process)%ptr)) & + pinfo%prev => block_array(pneigh%process & + ,pmeta%process)%ptr + +! point the list to the newly created block +! + block_array(pneigh%process,pmeta%process)%ptr => pinfo + + end if ! block and neighbor belong to different processes +#endif /* MPI */ + + end if ! pmeta and pneigh marked for update + + end if ! neighbor at the same level + + end if ! neighbor associated + + end do ! i = 1, nsides + end do ! j = 1, nsides + end do ! k = 1, nsides + + end if ! leaf + +! associate pmeta with the next meta block +! + pmeta => pmeta%next + + end do ! meta blocks + +#ifdef MPI +!! 3. UPDATE VARIABLE BOUNDARIES BETWEEN BLOCKS BELONGING TO DIFFERENT PROCESSES +!! +! iterate over sending and receiving processors +! + do irecv = 0, npmax + do isend = 0, npmax + +! process only pairs which have anything to exchange +! + if (block_counter(isend,irecv) > 0) then + +! obtain the number of blocks to exchange +! + nblocks = block_counter(isend,irecv) + +! prepare the tag for communication +! + itag = 100 * (irecv * nprocs + isend + 1) + 11 + +! allocate data buffer for variables to exchange +! + select case(idir) + case(1) + allocate(rbuf(nblocks,nv,ng,jh,kh)) + case(2) + allocate(rbuf(nblocks,nv,ih,ng,kh)) + case(3) + allocate(rbuf(nblocks,nv,ih,jh,ng)) + end select + +! if isend == nproc we are sending data +! + if (isend == nproc) then + +! reset the block counter +! + l = 0 + +! associate pinfo with the first block in the exchange list +! + pinfo => block_array(isend,irecv)%ptr + +! scan over all blocks on the block exchange list +! + do while(associated(pinfo)) + +! increase the block counter +! + l = l + 1 + +! associate pneigh with pinfo%neigh +! + pneigh => pinfo%neigh + +! get the corner coordinates +! + i = pinfo%corner(1) + j = pinfo%corner(2) + k = pinfo%corner(3) + +! extract the corresponding face region from the neighbor and insert it +! to the buffer +! + select case(idir) + case(1) + call block_face_copy(idir, i, j, k & + , pneigh%data%q(1:nv,1:im,1:jm,1:km) & + , rbuf(l,1:nv,1:ng,1:jh,1:kh)) + case(2) + call block_face_copy(idir, i, j, k & + , pneigh%data%q(1:nv,1:im,1:jm,1:km) & + , rbuf(l,1:nv,1:ih,1:ng,1:kh)) + case(3) + call block_face_copy(idir, i, j, k & + , pneigh%data%q(1:nv,1:im,1:jm,1:km) & + , rbuf(l,1:nv,1:ih,1:jh,1:ng)) + end select + +! associate pinfo with the next block +! + pinfo => pinfo%prev + + end do ! %ptr block list + +! send the data buffer to another process +! + call send_real_array(size(rbuf), irecv, itag, rbuf(:,:,:,:,:), iret) + + end if ! isend = nproc + +! if irecv == nproc we are receiving data +! + if (irecv == nproc) then + +! receive the data buffer +! + call receive_real_array(size(rbuf(:,:,:,:,:)), isend, itag & + , rbuf(:,:,:,:,:), iret) + +! reset the block counter +! + l = 0 + +! associate pinfo with the first block in the exchange list +! + pinfo => block_array(isend,irecv)%ptr + +! iterate over all received blocks and update boundaries of the corresponding +! data blocks +! + do while(associated(pinfo)) + +! increase the block counter +! + l = l + 1 + +! associate pmeta with pinfo%block +! + pmeta => pinfo%block + +! get the corner coordinates +! + i = pinfo%corner(1) + j = pinfo%corner(2) + k = pinfo%corner(3) + +! update the corresponding face region of the current block +! + select case(idir) + case(1) + if (i == 1) then + il = 1 + iu = ibl + else + il = ieu + iu = im + end if + if (j == 1) then + jl = jb + ju = jb + jh - 1 + else + jl = je - jh + 1 + ju = je + end if + if (k == 1) then + kl = kb + ku = kb + kh - 1 + else + kl = ke - kh + 1 + ku = ke + end if + pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = & + rbuf(l,1:nv,1:ng,1:jh,1:kh) + case(2) + if (i == 1) then + il = ib + iu = ib + ih - 1 + else + il = ie - ih + 1 + iu = ie + end if + if (j == 1) then + jl = 1 + ju = jbl + else + jl = jeu + ju = jm + end if + if (k == 1) then + kl = kb + ku = kb + kh - 1 + else + kl = ke - kh + 1 + ku = ke + end if + pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = & + rbuf(l,1:nv,1:ih,1:ng,1:kh) + case(3) + if (i == 1) then + il = ib + iu = ib + ih - 1 + else + il = ie - ih + 1 + iu = ie + end if + if (j == 1) then + jl = jb + ju = jb + jh - 1 + else + jl = je - jh + 1 + ju = je + end if + if (k == 1) then + kl = 1 + ku = kbl + else + kl = keu + ku = km + end if + pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = & + rbuf(l,1:nv,1:ih,1:jh,1:ng) + end select + +! associate pinfo with the next block +! + pinfo => pinfo%prev + + end do ! %ptr block list + + end if ! irecv = nproc + +! deallocate data buffer +! + if (allocated(rbuf)) deallocate(rbuf) + +! associate pinfo with the first block in the exchange list +! + pinfo => block_array(isend,irecv)%ptr + +! scan over all blocks on the exchange block list +! + do while(associated(pinfo)) + +! associate the exchange list pointer with the previous block on the list +! + block_array(isend,irecv)%ptr => pinfo%prev + +! nullify the current pointer fields +! + nullify(pinfo%prev) + nullify(pinfo%next) + nullify(pinfo%block) + nullify(pinfo%neigh) + +! deallocate the object +! + deallocate(pinfo) + +! associate pinfo with the next block +! + pinfo => block_array(isend,irecv)%ptr + + end do ! %ptr block list + + end if ! if block_count > 0 + + end do ! isend + end do ! irecv +#endif /* MPI */ + +#ifdef PROFILE +! stop accounting time for copy boundary update +! + call stop_timer(imc) +#endif /* PROFILE */ + +!------------------------------------------------------------------------------- +! + end subroutine boundaries_face_copy +#endif /* NDIMS == 3 */ ! !=============================================================================== ! From c91faac5f4cf6e87dac178b761e0986e19d1b7f8 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 22 Jul 2014 08:21:26 -0300 Subject: [PATCH 73/91] BOUNDARIES: Add subroutine boundaries_face_restrict(). This subroutine scans over all leafs and update their face boundaries restricting higher level neighbors to lower level ones. Signed-off-by: Grzegorz Kowal --- src/boundaries.F90 | 552 ++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 551 insertions(+), 1 deletion(-) diff --git a/src/boundaries.F90 b/src/boundaries.F90 index 49e55b6..1c81e5b 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -2944,7 +2944,7 @@ module boundaries ! if (pneigh%level == pmeta%level) then -! process only the block and its neighbor which are marked for update +! process only blocks and neighbors which are marked for update ! if (pmeta%update .and. pneigh%update) then @@ -3356,6 +3356,556 @@ module boundaries !------------------------------------------------------------------------------- ! end subroutine boundaries_face_copy +! +!=============================================================================== +! +! subroutine BOUNDARIES_FACE_RESTRICT: +! ----------------------------------- +! +! Subroutine scans over all leaf blocks in order to find face neighbors which +! are on different levels, and perform the update of face boundaries of +! lower blocks by restricting their from higher level neighbors. +! +! Arguments: +! +! idir - the direction to be processed; +! +!=============================================================================== +! + subroutine boundaries_face_restrict(idir) + +! import external procedures and variables +! + use blocks , only : nsides + use blocks , only : block_meta, block_data + use blocks , only : list_meta + use blocks , only : block_info, pointer_info + use coordinates , only : ng + use coordinates , only : in , jn , kn + use coordinates , only : im , jm , km + use coordinates , only : ib , jb , kb + use coordinates , only : ie , je , ke + use coordinates , only : ibl, jbl, kbl + use coordinates , only : ieu, jeu, keu +#ifdef MPI + use equations , only : nv +#endif /* MPI */ + use mpitools , only : nproc, nprocs, npmax +#ifdef MPI + use mpitools , only : send_real_array, receive_real_array +#endif /* MPI */ + +! local variables are not implicit by default +! + implicit none + +! subroutine arguments +! + integer, intent(in) :: idir + +! local pointers +! + type(block_meta), pointer :: pmeta, pneigh +#ifdef MPI + type(block_info), pointer :: pinfo +#endif /* MPI */ + +! local variables +! + integer :: i , j , k + integer :: ih, jh, kh + integer :: il, jl, kl + integer :: iu, ju, ku + integer :: iret +#ifdef MPI + integer :: isend, irecv, nblocks, itag, l + +! local pointer arrays +! + type(pointer_info), dimension(0:npmax,0:npmax) :: block_array + +! local arrays +! + integer , dimension(0:npmax,0:npmax) :: block_counter + real(kind=8), dimension(:,:,:,:,:) , allocatable :: rbuf +#endif /* MPI */ +! +!------------------------------------------------------------------------------- +! +#ifdef PROFILE +! start accounting time for restrict boundary update +! + call start_timer(imr) +#endif /* PROFILE */ + +! calculate half sizes +! + ih = in / 2 + jh = jn / 2 + kh = kn / 2 + +#ifdef MPI +!! 1. PREPARE THE BLOCK EXCHANGE ARRAYS FOR MPI +!! +! reset the exchange block counters +! + block_counter(:,:) = 0 + +! nullify the info pointers +! + do irecv = 0, npmax + do isend = 0, npmax + nullify(block_array(isend,irecv)%ptr) + end do + end do +#endif /* MPI */ + +!! 2. UPDATE VARIABLE FACE BOUNDARIES BETWEEN BLOCKS BELONGING TO DIFFERENT +!! PROCESS AND PREPARE THE EXCHANGE BLOCK LIST OF BLOCKS WHICH BELONG TO +!! DIFFERENT PROCESSES +!! +! associate pmeta with the first block on the meta block list +! + pmeta => list_meta + +! scan all meta blocks +! + do while(associated(pmeta)) + +! check if the block is leaf +! + if (pmeta%leaf) then + +! scan over all block corners +! + do k = 1, nsides + do j = 1, nsides + do i = 1, nsides + +! associate pneigh with the current neighbor +! + pneigh => pmeta%faces(i,j,k,idir)%ptr + +! check if the neighbor is associated +! + if (associated(pneigh)) then + +! check if the neighbor is at higher level +! + if (pneigh%level > pmeta%level) then + +! process only blocks and neighbors which are marked for update +! + if (pmeta%update .and. pneigh%update) then + +#ifdef MPI +! check if the block and its neighbor belong to the same process +! + if (pmeta%process == pneigh%process) then + +! check if the neighbor belongs to the current process +! + if (pmeta%process == nproc) then +#endif /* MPI */ + +! prepare the region indices for face boundary update +! + select case(idir) + case(1) + if (i == 1) then + il = 1 + iu = ibl + else + il = ieu + iu = im + end if + if (j == 1) then + jl = jb + ju = jb + jh - 1 + else + jl = je - jh + 1 + ju = je + end if + if (k == 1) then + kl = kb + ku = kb + kh - 1 + else + kl = ke - kh + 1 + ku = ke + end if + case(2) + if (i == 1) then + il = ib + iu = ib + ih - 1 + else + il = ie - ih + 1 + iu = ie + end if + if (j == 1) then + jl = 1 + ju = jbl + else + jl = jeu + ju = jm + end if + if (k == 1) then + kl = kb + ku = kb + kh - 1 + else + kl = ke - kh + 1 + ku = ke + end if + case(3) + if (i == 1) then + il = ib + iu = ib + ih - 1 + else + il = ie - ih + 1 + iu = ie + end if + if (j == 1) then + jl = jb + ju = jb + jh - 1 + else + jl = je - jh + 1 + ju = je + end if + if (k == 1) then + kl = 1 + ku = kbl + else + kl = keu + ku = km + end if + end select + +! extract the corresponding face region from the neighbor and insert it in +! the current data block +! + call block_face_restrict(idir, i, j, k & + , pneigh%data%q(1:nv, 1:im, 1:jm, 1:km) & + , pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku)) + +#ifdef MPI + end if ! pneigh on the current process + + else ! block and neighbor belong to different processes + +! increase the counter for number of blocks to exchange +! + block_counter(pneigh%process,pmeta%process) = & + block_counter(pneigh%process,pmeta%process) + 1 + +! allocate a new info object +! + allocate(pinfo) + +! fill out only fields which are used +! + pinfo%block => pmeta + pinfo%neigh => pneigh + pinfo%direction = idir + pinfo%corner(1) = i + pinfo%corner(2) = j + pinfo%corner(3) = k + +! nullify pointer fields of the object +! + nullify(pinfo%prev) + nullify(pinfo%next) + +! if the list is not empty append the newly created block to it +! + if (associated(block_array(pneigh%process & + ,pmeta%process)%ptr)) & + pinfo%prev => block_array(pneigh%process & + ,pmeta%process)%ptr + +! point the list to the newly created block +! + block_array(pneigh%process,pmeta%process)%ptr => pinfo + + end if ! block and neighbor belong to different processes +#endif /* MPI */ + + end if ! pmeta and pneigh marked for update + + end if ! neighbor at the same level + + end if ! neighbor associated + + end do ! i = 1, nsides + end do ! j = 1, nsides + end do ! k = 1, nsides + + end if ! leaf + +! associate pmeta with the next meta block +! + pmeta => pmeta%next + + end do ! meta blocks + +#ifdef MPI +!! 3. UPDATE VARIABLE BOUNDARIES BETWEEN BLOCKS BELONGING TO DIFFERENT PROCESSES +!! +! iterate over sending and receiving processors +! + do irecv = 0, npmax + do isend = 0, npmax + +! process only pairs which have something to exchange +! + if (block_counter(isend,irecv) > 0) then + +! obtain the number of blocks to exchange +! + nblocks = block_counter(isend,irecv) + +! prepare the tag for communication +! + itag = 100 * (irecv * nprocs + isend + 1) + 12 + +! allocate data buffer for variables to exchange +! + select case(idir) + case(1) + allocate(rbuf(nblocks,nv,ng,jh,kh)) + case(2) + allocate(rbuf(nblocks,nv,ih,ng,kh)) + case(3) + allocate(rbuf(nblocks,nv,ih,jh,ng)) + end select + +! if isend == nproc we are sending data +! + if (isend == nproc) then + +! reset the block counter +! + l = 0 + +! associate pinfo with the first block in the exchange list +! + pinfo => block_array(isend,irecv)%ptr + +! scan over all blocks on the block exchange list +! + do while(associated(pinfo)) + +! increase the block counter +! + l = l + 1 + +! associate pneigh with pinfo%neigh +! + pneigh => pinfo%neigh + +! get the corner coordinates +! + i = pinfo%corner(1) + j = pinfo%corner(2) + k = pinfo%corner(3) + +! extract the corresponding face region from the neighbor and insert it +! to the buffer +! + select case(idir) + case(1) + call block_face_restrict(idir, i, j, k & + , pneigh%data%q(1:nv,1:im,1:jm,1:km) & + , rbuf(l,1:nv,1:ng,1:jh,1:kh)) + case(2) + call block_face_restrict(idir, i, j, k & + , pneigh%data%q(1:nv,1:im,1:jm,1:km) & + , rbuf(l,1:nv,1:ih,1:ng,1:kh)) + case(3) + call block_face_restrict(idir, i, j, k & + , pneigh%data%q(1:nv,1:im,1:jm,1:km) & + , rbuf(l,1:nv,1:ih,1:jh,1:ng)) + end select + +! associate pinfo with the next block +! + pinfo => pinfo%prev + + end do ! %ptr block list + +! send the data buffer to another process +! + call send_real_array(size(rbuf), irecv, itag, rbuf(:,:,:,:,:), iret) + + end if ! isend = nproc + +! if irecv == nproc we are receiving data +! + if (irecv == nproc) then + +! receive the data buffer +! + call receive_real_array(size(rbuf(:,:,:,:,:)), isend, itag & + , rbuf(:,:,:,:,:), iret) + +! reset the block counter +! + l = 0 + +! associate pinfo with the first block in the exchange list +! + pinfo => block_array(isend,irecv)%ptr + +! iterate over all received blocks and update boundaries of the corresponding +! data blocks +! + do while(associated(pinfo)) + +! increase the block counter +! + l = l + 1 + +! associate pmeta with pinfo%block +! + pmeta => pinfo%block + +! get the corner coordinates +! + i = pinfo%corner(1) + j = pinfo%corner(2) + k = pinfo%corner(3) + +! update the corresponding face region of the current block +! + select case(idir) + case(1) + if (i == 1) then + il = 1 + iu = ibl + else + il = ieu + iu = im + end if + if (j == 1) then + jl = jb + ju = jb + jh - 1 + else + jl = je - jh + 1 + ju = je + end if + if (k == 1) then + kl = kb + ku = kb + kh - 1 + else + kl = ke - kh + 1 + ku = ke + end if + pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = & + rbuf(l,1:nv,1:ng,1:jh,1:kh) + case(2) + if (i == 1) then + il = ib + iu = ib + ih - 1 + else + il = ie - ih + 1 + iu = ie + end if + if (j == 1) then + jl = 1 + ju = jbl + else + jl = jeu + ju = jm + end if + if (k == 1) then + kl = kb + ku = kb + kh - 1 + else + kl = ke - kh + 1 + ku = ke + end if + pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = & + rbuf(l,1:nv,1:ih,1:ng,1:kh) + case(3) + if (i == 1) then + il = ib + iu = ib + ih - 1 + else + il = ie - ih + 1 + iu = ie + end if + if (j == 1) then + jl = jb + ju = jb + jh - 1 + else + jl = je - jh + 1 + ju = je + end if + if (k == 1) then + kl = 1 + ku = kbl + else + kl = keu + ku = km + end if + pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = & + rbuf(l,1:nv,1:ih,1:jh,1:ng) + end select + +! associate pinfo with the next block +! + pinfo => pinfo%prev + + end do ! %ptr block list + + end if ! irecv = nproc + +! deallocate data buffer +! + if (allocated(rbuf)) deallocate(rbuf) + +! associate pinfo with the first block in the exchange list +! + pinfo => block_array(isend,irecv)%ptr + +! scan over all blocks on the exchange block list +! + do while(associated(pinfo)) + +! associate the exchange list pointer with the previous block +! + block_array(isend,irecv)%ptr => pinfo%prev + +! nullify the pointer fields +! + nullify(pinfo%prev) + nullify(pinfo%next) + nullify(pinfo%block) + nullify(pinfo%neigh) + +! deallocate the object +! + deallocate(pinfo) + +! associate pinfo with the next block +! + pinfo => block_array(isend,irecv)%ptr + + end do ! %ptr block list + + end if ! if block_count > 0 + + end do ! isend + end do ! irecv +#endif /* MPI */ + +#ifdef PROFILE +! stop accounting time for restrict boundary update +! + call stop_timer(imr) +#endif /* PROFILE */ + +!------------------------------------------------------------------------------- +! + end subroutine boundaries_face_restrict #endif /* NDIMS == 3 */ ! !=============================================================================== From 6461e353cb7c0796a58b1ae82c11b91011d0e80d Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 22 Jul 2014 08:30:44 -0300 Subject: [PATCH 74/91] BOUNDARIES: Add subroutine boundaries_face_prolong(). This subroutine scans over all leafs and update their face boundaries prolongating lower level neighbors to higher level blocks. Signed-off-by: Grzegorz Kowal --- src/boundaries.F90 | 572 ++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 571 insertions(+), 1 deletion(-) diff --git a/src/boundaries.F90 b/src/boundaries.F90 index 1c81e5b..135c2c5 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -3364,7 +3364,7 @@ module boundaries ! ! Subroutine scans over all leaf blocks in order to find face neighbors which ! are on different levels, and perform the update of face boundaries of -! lower blocks by restricting their from higher level neighbors. +! lower blocks by restricting them from higher level neighbors. ! ! Arguments: ! @@ -3906,6 +3906,576 @@ module boundaries !------------------------------------------------------------------------------- ! end subroutine boundaries_face_restrict +! +!=============================================================================== +! +! subroutine BOUNDARIES_FACE_PROLONG: +! ---------------------------------- +! +! Subroutine scans over all leaf blocks in order to find face neighbors which +! are on different levels, and perform the update of face boundaries of +! higher blocks by prolongating them from higher level neighbors. +! +! Arguments: +! +! idir - the direction to be processed; +! +!=============================================================================== +! + subroutine boundaries_face_prolong(idir) + +! import external procedures and variables +! + use blocks , only : nsides + use blocks , only : block_meta, block_data + use blocks , only : list_meta + use blocks , only : block_info, pointer_info + use coordinates , only : ng + use coordinates , only : in , jn , kn + use coordinates , only : im , jm , km + use coordinates , only : ib , jb , kb + use coordinates , only : ie , je , ke + use coordinates , only : ibl, jbl, kbl + use coordinates , only : ieu, jeu, keu +#ifdef MPI + use equations , only : nv +#endif /* MPI */ + use mpitools , only : nproc, nprocs, npmax +#ifdef MPI + use mpitools , only : send_real_array, receive_real_array +#endif /* MPI */ + +! local variables are not implicit by default +! + implicit none + +! subroutine arguments +! + integer, intent(in) :: idir + +! local pointers +! + type(block_meta), pointer :: pmeta, pneigh +#ifdef MPI + type(block_info), pointer :: pinfo +#endif /* MPI */ + +! local variables +! + integer :: i , j , k + integer :: ic, jc, kc + integer :: ih, jh, kh + integer :: il, jl, kl + integer :: iu, ju, ku + integer :: iret +#ifdef MPI + integer :: isend, irecv, nblocks, itag, l + +! local pointer arrays +! + type(pointer_info), dimension(0:npmax,0:npmax) :: block_array + +! local arrays +! + integer , dimension(0:npmax,0:npmax) :: block_counter + real(kind=8), dimension(:,:,:,:,:) , allocatable :: rbuf +#endif /* MPI */ +! +!------------------------------------------------------------------------------- +! +#ifdef PROFILE +! start accounting time for prolong boundary update +! + call start_timer(imp) +#endif /* PROFILE */ + +! calculate the sizes +! + ih = in + ng + jh = jn + ng + kh = kn + ng + +#ifdef MPI +!! 1. PREPARE THE BLOCK EXCHANGE ARRAYS FOR MPI +!! +! reset the exchange block counters +! + block_counter(:,:) = 0 + +! nullify the info pointers +! + do irecv = 0, npmax + do isend = 0, npmax + nullify(block_array(isend,irecv)%ptr) + end do + end do +#endif /* MPI */ + +!! 2. UPDATE VARIABLE FACE BOUNDARIES BETWEEN BLOCKS BELONGING TO DIFFERENT +!! PROCESS AND PREPARE THE EXCHANGE BLOCK LIST OF BLOCKS WHICH BELONG TO +!! DIFFERENT PROCESSES +!! +! associate pmeta with the first block on the meta block list +! + pmeta => list_meta + +! scan all meta blocks +! + do while(associated(pmeta)) + +! check if the block is leaf +! + if (pmeta%leaf) then + +! scan over all block corners +! + do k = 1, nsides + kc = k + do j = 1, nsides + jc = j + do i = 1, nsides + ic = i + +! associate pneigh with the current neighbor +! + pneigh => pmeta%faces(i,j,k,idir)%ptr + +! check if the neighbor is associated +! + if (associated(pneigh)) then + +! check if the neighbor lays at lower level +! + if (pneigh%level < pmeta%level) then + +! process only blocks and neighbors which are marked for update +! + if (pmeta%update .and. pneigh%update) then + +#ifdef MPI +! check if the block and its neighbor belong to the same process +! + if (pmeta%process == pneigh%process) then + +! check if the neighbor belongs to the current process +! + if (pmeta%process == nproc) then +#endif /* MPI */ + +! extract the corresponding face region from the neighbor and insert it in +! the current data block +! + select case(idir) + case(1) + jc = pmeta%pos(2) + kc = pmeta%pos(3) + if (i == 1) then + il = 1 + iu = ibl + else + il = ieu + iu = im + end if + if (jc == 0) then + jl = jb + ju = jm + else + jl = 1 + ju = je + end if + if (kc == 0) then + kl = kb + ku = km + else + kl = 1 + ku = ke + end if + + case(2) + ic = pmeta%pos(1) + kc = pmeta%pos(3) + if (ic == 0) then + il = ib + iu = im + else + il = 1 + iu = ie + end if + if (j == 1) then + jl = 1 + ju = jbl + else + jl = jeu + ju = jm + end if + if (kc == 0) then + kl = kb + ku = km + else + kl = 1 + ku = ke + end if + + case(3) + ic = pmeta%pos(1) + jc = pmeta%pos(2) + if (ic == 0) then + il = ib + iu = im + else + il = 1 + iu = ie + end if + if (jc == 0) then + jl = jb + ju = jm + else + jl = 1 + ju = je + end if + if (k == 1) then + kl = 1 + ku = kbl + else + kl = keu + ku = km + end if + end select + +! extract the corresponding face region from the neighbor and insert it in +! the current data block +! + call block_face_prolong(idir, ic, jc, kc & + , pneigh%data%q(1:nv, 1:im, 1:jm, 1:km) & + , pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku)) + +#ifdef MPI + end if ! pneigh on the current process + + else ! block and neighbor belong to different processes + +! increase the counter for number of blocks to exchange +! + block_counter(pneigh%process,pmeta%process) = & + block_counter(pneigh%process,pmeta%process) + 1 + +! allocate a new info object +! + allocate(pinfo) + +! fill out only fields which are used +! + pinfo%block => pmeta + pinfo%neigh => pneigh + pinfo%direction = idir + pinfo%corner(1) = i + pinfo%corner(2) = j + pinfo%corner(3) = k + +! nullify pointer fields of the object +! + nullify(pinfo%prev) + nullify(pinfo%next) + +! if the list is not empty append the newly created block to it +! + if (associated(block_array(pneigh%process & + ,pmeta%process)%ptr)) & + pinfo%prev => block_array(pneigh%process & + ,pmeta%process)%ptr + +! point the list to the newly created block +! + block_array(pneigh%process,pmeta%process)%ptr => pinfo + + end if ! block and neighbor belong to different processes +#endif /* MPI */ + + end if ! pmeta and pneigh marked for update + + end if ! neighbor at lower level + + end if ! neighbor associated + + end do ! i = 1, nsides + end do ! j = 1, nsides + end do ! k = 1, nsides + + end if ! leaf + +! associate pmeta with the next meta block +! + pmeta => pmeta%next + + end do ! meta blocks + +#ifdef MPI +!! 3. UPDATE VARIABLE BOUNDARIES BETWEEN BLOCKS BELONGING TO DIFFERENT PROCESSES +!! +! iterate over sending and receiving processors +! + do irecv = 0, npmax + do isend = 0, npmax + +! process only pairs which have something to exchange +! + if (block_counter(isend,irecv) > 0) then + +! obtain the number of blocks to exchange +! + nblocks = block_counter(isend,irecv) + +! prepare the tag for communication +! + itag = 100 * (irecv * nprocs + isend + 1) + 13 + +! allocate data buffer for variables to exchange +! + select case(idir) + case(1) + allocate(rbuf(nblocks,nv,ng,jh,kh)) + case(2) + allocate(rbuf(nblocks,nv,ih,ng,kh)) + case(3) + allocate(rbuf(nblocks,nv,ih,jh,ng)) + end select + +! if isend == nproc we are sending data +! + if (isend == nproc) then + +! reset the block counter +! + l = 0 + +! associate pinfo with the first block in the exchange list +! + pinfo => block_array(isend,irecv)%ptr + +! scan over all blocks on the block exchange list +! + do while(associated(pinfo)) + +! increase the block counter +! + l = l + 1 + +! prepare pointer for updated meta block and its neighbor +! + pmeta => pinfo%block + pneigh => pinfo%neigh + +! get the corner coordinates +! + i = pinfo%corner(1) + j = pinfo%corner(2) + k = pinfo%corner(3) + +! extract the corresponding face region from the neighbor and insert it +! to the buffer +! + select case(idir) + case(1) + j = pmeta%pos(2) + k = pmeta%pos(3) + call block_face_prolong(idir, i, j, k & + , pneigh%data%q(1:nv,1:im,1:jm,1:km) & + , rbuf(l,1:nv,1:ng,1:jh,1:kh)) + case(2) + i = pmeta%pos(1) + k = pmeta%pos(3) + call block_face_prolong(idir, i, j, k & + , pneigh%data%q(1:nv,1:im,1:jm,1:km) & + , rbuf(l,1:nv,1:ih,1:ng,1:kh)) + case(3) + i = pmeta%pos(1) + j = pmeta%pos(2) + call block_face_prolong(idir, i, j, k & + , pneigh%data%q(1:nv,1:im,1:jm,1:km) & + , rbuf(l,1:nv,1:ih,1:jh,1:ng)) + end select + +! associate pinfo with the next block +! + pinfo => pinfo%prev + + end do ! %ptr block list + +! send the data buffer to another process +! + call send_real_array(size(rbuf), irecv, itag, rbuf(:,:,:,:,:), iret) + + end if ! isend = nproc + +! if irecv == nproc we are receiving data +! + if (irecv == nproc) then + +! receive the data buffer +! + call receive_real_array(size(rbuf(:,:,:,:,:)), isend, itag & + , rbuf(:,:,:,:,:), iret) + +! reset the block counter +! + l = 0 + +! associate pinfo with the first block in the exchange list +! + pinfo => block_array(isend,irecv)%ptr + +! iterate over all received blocks and update boundaries of the corresponding +! data blocks +! + do while(associated(pinfo)) + +! increase the block counter +! + l = l + 1 + +! prepare the pointer to updated block +! + pmeta => pinfo%block + +! get the corner coordinates +! + i = pinfo%corner(1) + j = pinfo%corner(2) + k = pinfo%corner(3) + +! update the corresponding face region of the current block +! + select case(idir) + case(1) + if (i == 1) then + il = 1 + iu = ibl + else + il = ieu + iu = im + end if + if (pmeta%pos(2) == 0) then + jl = jb + ju = jm + else + jl = 1 + ju = je + end if + if (pmeta%pos(3) == 0) then + kl = kb + ku = km + else + kl = 1 + ku = ke + end if + pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = & + rbuf(l,1:nv,1:ng,1:jh,1:kh) + case(2) + if (j == 1) then + jl = 1 + ju = jbl + else + jl = jeu + ju = jm + end if + if (pmeta%pos(1) == 0) then + il = ib + iu = im + else + il = 1 + iu = ie + end if + if (pmeta%pos(3) == 0) then + kl = kb + ku = km + else + kl = 1 + ku = ke + end if + pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = & + rbuf(l,1:nv,1:ih,1:ng,1:kh) + case(3) + if (k == 1) then + kl = 1 + ku = kbl + else + kl = keu + ku = km + end if + if (pmeta%pos(1) == 0) then + il = ib + iu = im + else + il = 1 + iu = ie + end if + if (pmeta%pos(2) == 0) then + jl = jb + ju = jm + else + jl = 1 + ju = je + end if + pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = & + rbuf(l,1:nv,1:ih,1:jh,1:ng) + end select + +! associate pinfo with the next block +! + pinfo => pinfo%prev + + end do ! %ptr block list + + end if ! irecv = nproc + +! deallocate data buffer +! + if (allocated(rbuf)) deallocate(rbuf) + +! associate pinfo with the first block in the exchange list +! + pinfo => block_array(isend,irecv)%ptr + +! scan over all blocks on the exchange block list +! + do while(associated(pinfo)) + +! associate the exchange list pointer +! + block_array(isend,irecv)%ptr => pinfo%prev + +! nullify the pointer fields +! + nullify(pinfo%prev) + nullify(pinfo%next) + nullify(pinfo%block) + nullify(pinfo%neigh) + +! deallocate the object +! + deallocate(pinfo) + +! associate pinfo with the next block +! + pinfo => block_array(isend,irecv)%ptr + + end do ! %ptr block list + + end if ! if block_count > 0 + + end do ! isend + end do ! irecv +#endif /* MPI */ + +#ifdef PROFILE +! stop accounting time for prolong boundary update +! + call stop_timer(imp) +#endif /* PROFILE */ + +!------------------------------------------------------------------------------- +! + end subroutine boundaries_face_prolong #endif /* NDIMS == 3 */ ! !=============================================================================== From 24436a015033db575d2801d3d2b5929a2c46c56d Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 22 Jul 2014 08:56:09 -0300 Subject: [PATCH 75/91] BOUNDARIES: Fix MPI exchange IDs and correct comments. Signed-off-by: Grzegorz Kowal --- src/boundaries.F90 | 150 +++++++++++++++++++++++++++------------------ 1 file changed, 89 insertions(+), 61 deletions(-) diff --git a/src/boundaries.F90 b/src/boundaries.F90 index 135c2c5..a4ce12f 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -3914,7 +3914,7 @@ module boundaries ! ! Subroutine scans over all leaf blocks in order to find face neighbors which ! are on different levels, and perform the update of face boundaries of -! higher blocks by prolongating them from higher level neighbors. +! higher blocks by prolongating them from lower level neighbors. ! ! Arguments: ! @@ -4480,15 +4480,15 @@ module boundaries ! !=============================================================================== ! -! DOMAIN BOUNDARY UPDATE SUBROUTINES +! DOMAIN EDGE BOUNDARY UPDATE SUBROUTINES ! !=============================================================================== ! ! subroutine BOUNDARIES_EDGE_COPY: ! ------------------------------- ! -! Subroutine scans over all leaf blocks in order to find corner neighbors at -! the same level, and perform the update of the corner boundaries between +! Subroutine scans over all leaf blocks in order to find edge neighbors which +! are the same level, and perform the update of the edge boundaries between ! them. ! ! Arguments: @@ -4587,15 +4587,15 @@ module boundaries end do #endif /* MPI */ -!! 2. UPDATE VARIABLE CORNER BOUNDARIES BETWEEN BLOCKS BELONGING TO THE SAME +!! 2. UPDATE VARIABLE EDGE BOUNDARIES BETWEEN BLOCKS BELONGING TO THE SAME !! PROCESS AND PREPARE THE EXCHANGE BLOCK LIST OF BLOCKS WHICH BELONG TO !! DIFFERENT PROCESSES !! -! assign the pointer to the first block on the meta block list +! associate pmeta with the first block on the meta block list ! pmeta => list_meta -! scan all meta blocks and process blocks at the current level +! scan all meta blocks ! do while(associated(pmeta)) @@ -4611,7 +4611,7 @@ module boundaries do j = 1, nsides do i = 1, nsides -! assign pneigh to the current neighbor +! associate pneigh with the current neighbor ! #if NDIMS == 2 pneigh => pmeta%edges(i,j,idir)%ptr @@ -4628,7 +4628,7 @@ module boundaries ! if (pneigh%level == pmeta%level) then -! skip if the block and its neighbor are not marked for update +! process only blocks and neighbors which are marked for update ! if (pmeta%update .and. pneigh%update) then @@ -5066,9 +5066,9 @@ module boundaries ! subroutine BOUNDARIES_EDGE_RESTRICT: ! ----------------------------------- ! -! Subroutine scans over all leaf blocks in order to find edge neighbors at -! the different levels, and perform the update of the edge boundaries between -! them. +! Subroutine scans over all leaf blocks in order to find edge neighbors which +! are on different levels, and perform the update of edge boundaries of +! lower blocks by restricting them from higher level neighbors. ! ! Arguments: ! @@ -5170,11 +5170,11 @@ module boundaries !! PROCESS AND PREPARE THE EXCHANGE BLOCK LIST OF BLOCKS WHICH BELONG TO !! DIFFERENT PROCESSES !! -! assign the pointer to the first block on the meta block list +! associate pmeta with the first block on the meta block list ! pmeta => list_meta -! scan all meta blocks and process blocks at the current level +! scan all meta blocks ! do while(associated(pmeta)) @@ -5207,7 +5207,7 @@ module boundaries ! if (pneigh%level > pmeta%level) then -! skip if the block and its neighbor are not marked for update +! process only blocks and neighbors which are marked for update ! if (pmeta%update .and. pneigh%update) then @@ -5645,9 +5645,9 @@ module boundaries ! subroutine BOUNDARIES_EDGE_PROLONG: ! ---------------------------------- ! -! Subroutine scans over all leaf blocks in order to find edge neighbors at -! the different levels, and perform the update of the edge boundaries between -! them. +! Subroutine scans over all leaf blocks in order to find edge neighbors which +! are on different levels, and perform the update of edge boundaries of +! higher blocks by prolongating them from lower level neighbors. ! ! Arguments: ! @@ -5750,11 +5750,11 @@ module boundaries !! PROCESS AND PREPARE THE EXCHANGE BLOCK LIST OF BLOCKS WHICH BELONG TO !! DIFFERENT PROCESSES !! -! assign the pointer to the first block on the meta block list +! associate pmeta with the first block on the meta block list ! pmeta => list_meta -! scan all meta blocks and process blocks at the current level +! scan all meta blocks ! do while(associated(pmeta)) @@ -5790,7 +5790,7 @@ module boundaries ! if (pneigh%level < pmeta%level) then -! skip if the block and its neighbor are not marked for update +! process only blocks and neighbors which are marked for update ! if (pmeta%update .and. pneigh%update) then @@ -5957,7 +5957,7 @@ module boundaries ! prepare the tag for communication ! - itag = 100 * (irecv * nprocs + isend + 1) + 22 + itag = 100 * (irecv * nprocs + isend + 1) + 23 ! allocate data buffer for variables to exchange ! @@ -6232,6 +6232,10 @@ module boundaries ! !=============================================================================== ! +! DOMAIN CORNER BOUNDARY UPDATE SUBROUTINES +! +!=============================================================================== +! ! subroutine BOUNDARIES_CORNER_COPY: ! --------------------------------- ! @@ -6320,11 +6324,11 @@ module boundaries !! PROCESS AND PREPARE THE EXCHANGE BLOCK LIST OF BLOCKS WHICH BELONG TO !! DIFFERENT PROCESSES !! -! assign the pointer to the first block on the meta block list +! associate pmeta with the first block on the meta block list ! pmeta => list_meta -! scan all meta blocks and process blocks at the current level +! scan all meta blocks ! do while(associated(pmeta)) @@ -6492,7 +6496,7 @@ module boundaries ! prepare the tag for communication ! - itag = 100 * (irecv * nprocs + isend + 1) + 11 + itag = 100 * (irecv * nprocs + isend + 1) + 31 ! allocate data buffer for variables to exchange ! @@ -6696,9 +6700,9 @@ module boundaries ! subroutine BOUNDARIES_CORNER_RESTRICT: ! ------------------------------------- ! -! Subroutine scans over all leaf blocks in order to find corner neighbors at -! different levels, and update the corner boundaries of blocks at lower levels -! by restricting variables from higher level blocks. +! Subroutine scans over all leaf blocks in order to find corner neighbors +! which are on different levels, and perform the update of corner boundaries +! of lower blocks by restricting them from higher level neighbors. ! ! !=============================================================================== @@ -6781,11 +6785,11 @@ module boundaries !! PROCESS AND PREPARE THE EXCHANGE BLOCK LIST OF BLOCKS WHICH BELONG TO !! DIFFERENT PROCESSES !! -! assign the pointer to the first block on the meta block list +! associate pmeta with the first block on the meta block list ! pmeta => list_meta -! scan all meta blocks and process blocks at the current level +! scan all meta blocks ! do while(associated(pmeta)) @@ -6952,7 +6956,7 @@ module boundaries ! prepare the tag for communication ! - itag = 100 * (irecv * nprocs + isend + 1) + 12 + itag = 100 * (irecv * nprocs + isend + 1) + 32 ! allocate data buffer for variables to exchange ! @@ -7241,11 +7245,11 @@ module boundaries !! PROCESS AND PREPARE THE EXCHANGE BLOCK LIST OF BLOCKS WHICH BELONG TO !! DIFFERENT PROCESSES !! -! assign the pointer to the first block on the meta block list +! associate pmeta with the first block on the meta block list ! pmeta => list_meta -! scan all meta blocks and process blocks at the current level +! scan all meta blocks ! do while(associated(pmeta)) @@ -7412,7 +7416,7 @@ module boundaries ! prepare the tag for communication ! - itag = 100 * (irecv * nprocs + isend + 1) + 13 + itag = 100 * (irecv * nprocs + isend + 1) + 33 ! allocate data buffer for variables to exchange ! @@ -7460,12 +7464,12 @@ module boundaries ! #if NDIMS == 2 call block_corner_prolong(i, j, k & - , pneigh%data%q(1:nv, 1:im, 1:jm, 1:km) & + , pneigh%data%q(1:nv,1:im,1:jm,1:km) & , rbuf(l,1:nv,1:ng,1:ng,1:km)) #endif /* NDIMS == 2 */ #if NDIMS == 3 call block_corner_prolong(i, j, k & - , pneigh%data%q(1:nv, 1:im, 1:jm, 1:km) & + , pneigh%data%q(1:nv,1:im,1:jm,1:km) & , rbuf(l,1:nv,1:ng,1:ng,1:ng)) #endif /* NDIMS == 3 */ @@ -8914,7 +8918,7 @@ module boundaries dq3 = dqx - dqy + dqz dq4 = dqx + dqy - dqz -! prolongate the face region to the output array +! prolong the face region to the output array ! qb(p,is,js,ks) = qn(p,i,j,k) - dq1 qb(p,it,js,ks) = qn(p,i,j,k) + dq2 @@ -8988,7 +8992,7 @@ module boundaries ! !------------------------------------------------------------------------------- ! -! depending on the direction +! process depending on the direction ! select case(nc) case(1) @@ -8997,7 +9001,7 @@ module boundaries ! ih = in / 2 -! prepare source edge region indices +! prepare indices for the edge region ! if (ic == 1) then il = ib @@ -9023,7 +9027,7 @@ module boundaries end if #endif /* NDIMS == 3 */ -! return edge region in the output array +! copy the edge region to the output array ! #if NDIMS == 2 qb(1:nv,1:ih,1:ng,1:km) = qn(1:nv,il:iu,jl:ju, 1:km) @@ -9038,7 +9042,7 @@ module boundaries ! jh = jn / 2 -! prepare source edge region indices +! prepare indices for the edge region ! if (ic == 1) then il = iel @@ -9064,7 +9068,7 @@ module boundaries end if #endif /* NDIMS == 3 */ -! return edge region in the output array +! copy the edge region to the output array ! #if NDIMS == 2 qb(1:nv,1:ng,1:jh,1:km) = qn(1:nv,il:iu,jl:ju, 1:km) @@ -9104,7 +9108,7 @@ module boundaries ku = ke end if -! return edge region in the output array +! copy the edge region to the output array ! qb(1:nv,1:ng,1:ng,1:kh) = qn(1:nv,il:iu,jl:ju,kl:ku) #endif /* NDIMS == 3 */ @@ -9163,7 +9167,7 @@ module boundaries ! !------------------------------------------------------------------------------- ! -! depending on the direction +! process depending on the direction ! select case(nc) case(1) @@ -9172,7 +9176,7 @@ module boundaries ! ih = in / 2 -! prepare source edge region indices +! prepare indices for the edge region ! il = ib ip = il + 1 @@ -9198,7 +9202,7 @@ module boundaries end if #endif /* NDIMS == 3 */ -! return edge region in the output array +! restrict the edge region to the output array ! #if NDIMS == 2 qb(1:nv,1:ih,1:ng,1:km) = & @@ -9225,7 +9229,7 @@ module boundaries ! jh = jn / 2 -! prepare source edge region indices +! prepare indices for the edge region ! if (ic == 1) then il = ie - nd + 1 @@ -9251,7 +9255,7 @@ module boundaries end if #endif /* NDIMS == 3 */ -! return edge region in the output array +! restrict the edge region to the output array ! #if NDIMS == 2 qb(1:nv,1:ng,1:jh,1:km) = & @@ -9279,7 +9283,7 @@ module boundaries ! kh = kn / 2 -! prepare source edge region indices +! prepare indices for the edge region ! if (ic == 1) then il = ie - nd + 1 @@ -9303,7 +9307,7 @@ module boundaries kp = kl + 1 ku = ke -! return edge region in the output array +! restrict the edge region to the output array ! qb(1:nv,1:ng,1:ng,1:kh) = & 1.25d-01 * (((qn(1:nv,il:iu:2,jl:ju:2,kl:ku:2) & @@ -9378,7 +9382,7 @@ module boundaries ! !------------------------------------------------------------------------------- ! -! depending on the direction +! process depending on the direction ! select case(nc) case(1) @@ -9387,7 +9391,7 @@ module boundaries ! ih = in / 2 -! prepare source edge region indices +! prepare indices for the edge region ! if (ic == 0) then il = ib @@ -9419,7 +9423,7 @@ module boundaries ! jh = jn / 2 -! prepare source edge region indices +! prepare indices for the edge region ! if (ic == 1) then il = ie - nh + 1 @@ -9452,7 +9456,7 @@ module boundaries ! kh = kn / 2 -! prepare source edge region indices +! prepare indices for the edge region ! if (ic == 1) then il = ie - nh + 1 @@ -9479,7 +9483,7 @@ module boundaries end select -! return edge region in the output array +! iterate over all edge region cells ! #if NDIMS == 2 do k = 1, km @@ -9507,6 +9511,8 @@ module boundaries ! do p = 1, nv +! calculate limited derivatives in all directions +! dql = qn(p,i ,j,k) - qn(p,im1,j,k) dqr = qn(p,ip1,j,k) - qn(p,i ,j,k) dqx = limiter(0.25d+00, dql, dqr) @@ -9522,18 +9528,28 @@ module boundaries #endif /* NDIMS == 3 */ #if NDIMS == 2 +! calculate the derivative terms +! dq1 = dqx + dqy dq2 = dqx - dqy + +! prolong the edge region to the output array +! qb(p,is,js,k ) = qn(p,i,j,k) - dq1 qb(p,it,js,k ) = qn(p,i,j,k) + dq2 qb(p,is,jt,k ) = qn(p,i,j,k) - dq2 qb(p,it,jt,k ) = qn(p,i,j,k) + dq1 #endif /* NDIMS == 2 */ #if NDIMS == 3 +! calculate the derivative terms +! dq1 = dqx + dqy + dqz dq2 = dqx - dqy - dqz dq3 = dqx - dqy + dqz dq4 = dqx + dqy - dqz + +! prolong the edge region to the output array +! qb(p,is,js,ks) = qn(p,i,j,k) - dq1 qb(p,it,js,ks) = qn(p,i,j,k) + dq2 qb(p,is,jt,ks) = qn(p,i,j,k) - dq3 @@ -9608,7 +9624,7 @@ module boundaries ! !------------------------------------------------------------------------------- ! -! prepare source corner region indices +! prepare indices for the corner region ! if (ic == 1) then il = iel @@ -9634,7 +9650,7 @@ module boundaries end if #endif /* NDIMS == 3 */ -! return corner region in the output array +! copy the corner region to the output array ! #if NDIMS == 2 qb(1:nv,1:ng,1:ng,1:km) = qn(1:nv,il:iu,jl:ju, 1:km) @@ -9696,7 +9712,7 @@ module boundaries ! !------------------------------------------------------------------------------- ! -! prepare source corner region indices +! prepare indices for the corner region ! if (ic == 1) then il = ie - nd + 1 @@ -9728,7 +9744,7 @@ module boundaries end if #endif /* NDIMS == 3 */ -! return corner region in the output array +! restrict the corner region to the output array ! #if NDIMS == 2 qb(1:nv,1:ng,1:ng,1:km) = & @@ -9810,7 +9826,7 @@ module boundaries ! !------------------------------------------------------------------------------- ! -! prepare source corner region indices +! prepare indices for the corner region ! if (ic == 1) then il = ie - nh + 1 @@ -9836,7 +9852,7 @@ module boundaries end if #endif /* NDIMS == 3 */ -! interpolate and return corner region in the output array +! iterate over all corner region cells ! #if NDIMS == 2 do k = 1, km @@ -9864,6 +9880,8 @@ module boundaries ! do p = 1, nv +! calculate limited derivatives in all directions +! dql = qn(p,i ,j,k) - qn(p,im1,j,k) dqr = qn(p,ip1,j,k) - qn(p,i ,j,k) dqx = limiter(0.25d+00, dql, dqr) @@ -9879,18 +9897,28 @@ module boundaries #endif /* NDIMS == 3 */ #if NDIMS == 2 +! calculate the derivative terms +! dq1 = dqx + dqy dq2 = dqx - dqy + +! prolong the corner region to the output array +! qb(p,is,js,k ) = qn(p,i,j,k) - dq1 qb(p,it,js,k ) = qn(p,i,j,k) + dq2 qb(p,is,jt,k ) = qn(p,i,j,k) - dq2 qb(p,it,jt,k ) = qn(p,i,j,k) + dq1 #endif /* NDIMS == 2 */ #if NDIMS == 3 +! calculate the derivative terms +! dq1 = dqx + dqy + dqz dq2 = dqx - dqy - dqz dq3 = dqx - dqy + dqz dq4 = dqx + dqy - dqz + +! prolong the corner region to the output array +! qb(p,is,js,ks) = qn(p,i,j,k) - dq1 qb(p,it,js,ks) = qn(p,i,j,k) + dq2 qb(p,is,jt,ks) = qn(p,i,j,k) - dq3 From ba6b6c13ac0b480d33020eaf02e1bb8330de95e6 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 22 Jul 2014 08:59:50 -0300 Subject: [PATCH 76/91] BOUNDARIES: Call face boundary subroutines in boundary_variables(). Signed-off-by: Grzegorz Kowal --- src/boundaries.F90 | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/src/boundaries.F90 b/src/boundaries.F90 index a4ce12f..45fc36c 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -346,6 +346,14 @@ module boundaries ! call update_corners() +#if NDIMS == 3 +! update face boundaries between blocks at the same levels +! + do idir = 1, ndims + call boundaries_face_copy(idir) + end do ! idir +#endif /* NDIMS == 3 */ + ! update edge boundaries between blocks at the same levels ! do idir = 1, ndims @@ -356,6 +364,14 @@ module boundaries ! call boundaries_corner_copy() +#if NDIMS == 3 +! restrict face boundaries from higher level blocks +! + do idir = 1, ndims + call boundaries_face_restrict(idir) + end do ! idir +#endif /* NDIMS == 3 */ + ! restricts edge boundaries from block at higher level ! do idir = 1, ndims @@ -366,6 +382,14 @@ module boundaries ! call boundaries_corner_restrict() +#if NDIMS == 3 +! prolong face boundaries from lower level blocks +! + do idir = 1, ndims + call boundaries_face_prolong(idir) + end do ! idir +#endif /* NDIMS == 3 */ + ! prolongs edge boundaries from block at lower level ! do idir = 1, ndims From 1c8ca86d5d1cad2219c49798f600aae04494711e Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 22 Jul 2014 15:33:38 -0300 Subject: [PATCH 77/91] IO: Put write all subroutines in interface definition. Signed-off-by: Grzegorz Kowal --- src/io.F90 | 3917 +++++++++++++++++++++++++++++++--------------------- 1 file changed, 2324 insertions(+), 1593 deletions(-) diff --git a/src/io.F90 b/src/io.F90 index d9948c3..5b246b1 100644 --- a/src/io.F90 +++ b/src/io.F90 @@ -41,6 +41,23 @@ module io ! implicit none +! subroutine interfaces +! + interface write_array +#ifdef HDF5 + module procedure write_1d_array_integer_h5 + module procedure write_2d_array_integer_h5 + module procedure write_3d_array_integer_h5 + module procedure write_4d_array_integer_h5 + module procedure write_5d_array_integer_h5 + module procedure write_1d_array_double_h5 + module procedure write_2d_array_double_h5 + module procedure write_3d_array_double_h5 + module procedure write_4d_array_double_h5 + module procedure write_5d_array_double_h5 +#endif /* HDF5 */ + end interface + #ifdef PROFILE ! timer indices ! @@ -2100,25 +2117,25 @@ module io ! store metadata in the HDF5 file ! - call write_vector_integer_h5(gid, 'indices', cm(1), idx) - call write_vector_integer_h5(gid, 'parent' , am(1), par) - call write_vector_integer_h5(gid, 'data' , am(1), dat) - call write_vector_integer_h5(gid, 'id' , am(1), id) - call write_vector_integer_h5(gid, 'cpu' , am(1), cpu) - call write_vector_integer_h5(gid, 'level' , am(1), lev) - call write_vector_integer_h5(gid, 'config' , am(1), cfg) - call write_vector_integer_h5(gid, 'refine' , am(1), ref) - call write_vector_integer_h5(gid, 'leaf' , am(1), lea) - call write_vector_double_h5 (gid, 'xmin' , am(1), xmn) - call write_vector_double_h5 (gid, 'xmax' , am(1), xmx) - call write_vector_double_h5 (gid, 'ymin' , am(1), ymn) - call write_vector_double_h5 (gid, 'ymax' , am(1), ymx) - call write_vector_double_h5 (gid, 'zmin' , am(1), zmn) - call write_vector_double_h5 (gid, 'zmax' , am(1), zmx) - call write_array2_integer_h5(gid, 'child' , dm(:), chl) - call write_array2_integer_h5(gid, 'pos' , pm(:), pos) - call write_array2_integer_h5(gid, 'coord' , pm(:), cor) - call write_array4_integer_h5(gid, 'neigh' , qm(:), ngh) + call write_array(gid, 'indices', cm(1), idx) + call write_array(gid, 'parent' , am(1), par) + call write_array(gid, 'data' , am(1), dat) + call write_array(gid, 'id' , am(1), id) + call write_array(gid, 'cpu' , am(1), cpu) + call write_array(gid, 'level' , am(1), lev) + call write_array(gid, 'config' , am(1), cfg) + call write_array(gid, 'refine' , am(1), ref) + call write_array(gid, 'leaf' , am(1), lea) + call write_array(gid, 'xmin' , am(1), xmn) + call write_array(gid, 'xmax' , am(1), xmx) + call write_array(gid, 'ymin' , am(1), ymn) + call write_array(gid, 'ymax' , am(1), ymx) + call write_array(gid, 'zmin' , am(1), zmn) + call write_array(gid, 'zmax' , am(1), zmx) + call write_array(gid, 'child' , dm(:), chl(:,:)) + call write_array(gid, 'pos' , pm(:), pos(:,:)) + call write_array(gid, 'coord' , pm(:), cor(:,:)) + call write_array(gid, 'neigh' , qm(:), ngh(:,:,:,:)) ! deallocate allocatable arrays ! @@ -2559,9 +2576,9 @@ module io ! store data arrays in the current group ! - call write_vector_integer_h5(gid, 'meta', am(1), id) - call write_array5_double_h5 (gid, 'uvar', dm(:), uv) - call write_array5_double_h5 (gid, 'qvar', dm(:), qv) + call write_array(gid, 'meta', am(1), id) + call write_array(gid, 'uvar', dm(:), uv) + call write_array(gid, 'qvar', dm(:), qv) ! deallocate allocatable arrays ! @@ -2862,13 +2879,13 @@ module io ! write the arrays to the HDF5 file ! - call write_vector_integer_h5(gid, 'levels', cm(1), lev) - call write_vector_integer_h5(gid, 'refine', cm(1), ref) - call write_array2_integer_h5(gid, 'coords', cm(:), cor) - call write_array3_double_h5 (gid, 'bounds', dm(:), bnd) - call write_vector_double_h5 (gid, 'dx' , am(1), adx(1:maxlev)) - call write_vector_double_h5 (gid, 'dy' , am(1), ady(1:maxlev)) - call write_vector_double_h5 (gid, 'dz' , am(1), adz(1:maxlev)) + call write_array(gid, 'levels', cm(1), lev) + call write_array(gid, 'refine', cm(1), ref) + call write_array(gid, 'coords', cm(:), cor) + call write_array(gid, 'bounds', dm(:), bnd) + call write_array(gid, 'dx' , am(1), adx(1:maxlev)) + call write_array(gid, 'dy' , am(1), ady(1:maxlev)) + call write_array(gid, 'dz' , am(1), adz(1:maxlev)) ! deallocate temporary arrays ! @@ -3039,7 +3056,7 @@ module io ! write the variable array to the HDF5 file ! - call write_array4_double_h5(gid, trim(pvars(n)), dm, qarr) + call write_array(gid, trim(pvars(n)), dm, qarr) end do ! n = 1, nv @@ -3211,7 +3228,7 @@ module io ! write the variable array to the HDF5 file ! - call write_array4_double_h5(gid, trim(cvars(n)), dm, qarr) + call write_array(gid, trim(cvars(n)), dm, qarr) end do ! n = 1, nv @@ -3251,133 +3268,6 @@ module io ! !=============================================================================== ! -! write_vector_integer_h5: subroutine stores a 1D integer vector in a group -! -! arguments: -! gid - the HDF5 group identifier -! name - the string name representing the dataset -! length - the vector length -! value - the data -! -!=============================================================================== -! - subroutine write_vector_integer_h5(gid, name, length, data) - -! references to other modules -! - use error, only : print_error - use hdf5 , only : hid_t, hsize_t, H5T_NATIVE_INTEGER - use hdf5 , only : h5screate_simple_f, h5sclose_f & - , h5dcreate_f, h5dwrite_f, h5dclose_f - -! declare variables -! - implicit none - -! input variables -! - integer(hid_t) , intent(in) :: gid - character(len=*) , intent(in) :: name - integer(hsize_t) , intent(in) :: length - integer(kind=4) , dimension(:), intent(in) :: data - -! local variables -! - integer(hid_t) :: sid, did - integer(hsize_t), dimension(1) :: am - integer :: err -! -!------------------------------------------------------------------------------- -! -! prepare the vector dimensions -! - am(1) = length - -! create space for the vector -! - call h5screate_simple_f(1, am, sid, err) - -! check if the space has been created successfuly -! - if (err .ge. 0) then - -! create the dataset -! - call h5dcreate_f(gid, name, H5T_NATIVE_INTEGER, sid, did, err) - -! check if the dataset has been created successfuly -! - if (err .ge. 0) then - -! write the dataset data -! - call h5dwrite_f(did, H5T_NATIVE_INTEGER, data(:), am, err, sid) - -! check if the dataset has been written successfuly -! - if (err .gt. 0) then - -! print error about the problem with writing down the dataset -! - call print_error("io::write_vector_integer_h5" & - , "Cannot write dataset: " // trim(name)) - - end if - -! close the dataset -! - call h5dclose_f(did, err) - -! check if the dataset has been closed successfuly -! - if (err .gt. 0) then - -! print error about the problem with closing the dataset -! - call print_error("io::write_vector_integer_h5" & - , "Cannot close dataset: " // trim(name)) - - end if - - else - -! print error about the problem with creating the dataset -! - call print_error("io::write_vector_integer_h5" & - , "Cannot create dataset: " // trim(name)) - - end if - -! release the space -! - call h5sclose_f(sid, err) - -! check if the space has been released successfuly -! - if (err .gt. 0) then - -! print error about the problem with closing the space -! - call print_error("io::write_vector_integer_h5" & - , "Cannot close space for dataset: " // trim(name)) - - end if - - else - -! print error about the problem with creating the space for the attribute -! - call print_error("io::write_vector_integer_h5" & - , "Cannot create space for dataset: " // trim(name)) - - end if - -!------------------------------------------------------------------------------- -! - end subroutine write_vector_integer_h5 -! -!=============================================================================== -! ! read_vector_integer_h5: subroutine reads a 1D integer vector ! ! arguments: @@ -3467,216 +3357,6 @@ module io ! !=============================================================================== ! -! write_array2_integer_h5: subroutine stores a 2D integer array in a group -! -! arguments: -! gid - the HDF5 group identifier -! name - the string name representing the dataset -! dm - the data dimensions -! value - the data -! -!=============================================================================== -! - subroutine write_array2_integer_h5(gid, name, dm, var) - -! references to other modules -! - use error, only : print_error - use hdf5 , only : hid_t, hsize_t, H5T_NATIVE_INTEGER - use hdf5 , only : h5screate_simple_f, h5sclose_f & - , h5dcreate_f, h5dwrite_f, h5dclose_f -#ifdef COMPRESS - use hdf5 , only : H5P_DATASET_CREATE_F - use hdf5 , only : h5pcreate_f, h5pset_chunk_f, h5pclose_f -#ifdef DEFLATE - use hdf5 , only : h5pset_deflate_f -#endif /* DEFLATE */ -#ifdef SZIP - use hdf5 , only : H5_SZIP_NN_OM_F - use hdf5 , only : h5pset_szip_f -#endif /* SZIP */ -#endif /* COMPRESS */ - -! declare variables -! - implicit none - -! input variables -! - integer(hid_t) , intent(in) :: gid - character(len=*) , intent(in) :: name - integer(hsize_t), dimension(2) , intent(in) :: dm - integer(kind=4) , dimension(:,:), intent(in) :: var - -! local variables -! - integer(hid_t) :: sid, pid, did - integer :: err -#ifdef COMPRESS - logical :: compress = .false. -#endif /* COMPRESS */ -! -!------------------------------------------------------------------------------- -! -! create space for the vector -! - call h5screate_simple_f(2, dm, sid, err) - -! check if the space has been created successfuly -! - if (err .ge. 0) then - -#ifdef COMPRESS -! prepare compression -! - call h5pcreate_f(H5P_DATASET_CREATE_F, pid, err) - -! check if the properties have been created properly -! - if (err .ge. 0) then - -! so far ok, so turn on the compression -! - compress = .true. - -! set the chunk size -! - call h5pset_chunk_f(pid, 2, dm, err) - -! check if the chunk size has been set properly -! - if (err .gt. 0) then - -! print error about the problem with setting the chunk size -! - call print_error("io::write_array4_integer_h5" & - , "Cannot set the size of the chunk!") - -! setting the size of the chunk failed, so turn off the compression -! - compress = .false. - - end if - -! set the compression algorithm -! -#ifdef DEFLATE - call h5pset_deflate_f(pid, 9, err) -#endif /* DEFLATE */ -#ifdef SZIP - if (product(dm) .ge. 32) & - call h5pset_szip_f(pid, H5_SZIP_NN_OM_F, 32, err) -#endif /* SZIP */ - -! check if the compression algorithm has been set properly -! - if (err .gt. 0) then - -! print error about the problem with setting the compression method -! - call print_error("io::write_array4_integer_h5" & - , "Cannot set the compression method!") - -! setting compression method failed, so turn off the compression -! - compress = .false. - - end if - - end if - -! check if it is safe to use compression -! - if (compress) then - -! create the dataset -! - call h5dcreate_f(gid, name, H5T_NATIVE_INTEGER, sid, did, err, pid) - - else -#endif /* COMPRESS */ - -! create the dataset -! - call h5dcreate_f(gid, name, H5T_NATIVE_INTEGER, sid, did, err) - -#ifdef COMPRESS - end if -#endif /* COMPRESS */ - -! check if the dataset has been created successfuly -! - if (err .ge. 0) then - -! write the dataset data -! - call h5dwrite_f(did, H5T_NATIVE_INTEGER, var(:,:), dm, err, sid) - -! check if the dataset has been written successfuly -! - if (err .gt. 0) then - -! print error about the problem with writing down the dataset -! - call print_error("io::write_array2_integer_h5" & - , "Cannot write dataset: " // trim(name)) - - end if - -! close the dataset -! - call h5dclose_f(did, err) - -! check if the dataset has been closed successfuly -! - if (err .gt. 0) then - -! print error about the problem with closing the dataset -! - call print_error("io::write_array2_integer_h5" & - , "Cannot close dataset: " // trim(name)) - - end if - - else - -! print error about the problem with creating the dataset -! - call print_error("io::write_array2_integer_h5" & - , "Cannot create dataset: " // trim(name)) - - end if - -! release the space -! - call h5sclose_f(sid, err) - -! check if the space has been released successfuly -! - if (err .gt. 0) then - -! print error about the problem with closing the space -! - call print_error("io::write_array2_integer_h5" & - , "Cannot close space for dataset: " // trim(name)) - - end if - - else - -! print error about the problem with creating the space for the attribute -! - call print_error("io::write_array2_integer_h5" & - , "Cannot create space for dataset: " // trim(name)) - - end if - -!------------------------------------------------------------------------------- -! - end subroutine write_array2_integer_h5 -! -!=============================================================================== -! ! read_array2_integer_h5: subroutine reads a 2D integer array ! ! arguments: @@ -3766,216 +3446,6 @@ module io ! !=============================================================================== ! -! write_array4_integer_h5: subroutine stores a 4D integer array in a group -! -! arguments: -! gid - the HDF5 group identifier -! name - the string name representing the dataset -! dm - the data dimensions -! value - the data -! -!=============================================================================== -! - subroutine write_array4_integer_h5(gid, name, dm, var) - -! references to other modules -! - use error, only : print_error - use hdf5 , only : hid_t, hsize_t, H5T_NATIVE_INTEGER - use hdf5 , only : h5screate_simple_f, h5sclose_f & - , h5dcreate_f, h5dwrite_f, h5dclose_f -#ifdef COMPRESS - use hdf5 , only : H5P_DATASET_CREATE_F - use hdf5 , only : h5pcreate_f, h5pset_chunk_f, h5pclose_f -#ifdef DEFLATE - use hdf5 , only : h5pset_deflate_f -#endif /* DEFLATE */ -#ifdef SZIP - use hdf5 , only : H5_SZIP_NN_OM_F - use hdf5 , only : h5pset_szip_f -#endif /* SZIP */ -#endif /* COMPRESS */ - -! declare variables -! - implicit none - -! input variables -! - integer(hid_t) , intent(in) :: gid - character(len=*) , intent(in) :: name - integer(hsize_t), dimension(4) , intent(in) :: dm - integer(kind=4) , dimension(:,:,:,:), intent(in) :: var - -! local variables -! - integer(hid_t) :: sid, pid, did - integer :: err -#ifdef COMPRESS - logical :: compress = .false. -#endif /* COMPRESS */ -! -!------------------------------------------------------------------------------- -! -! create space for the vector -! - call h5screate_simple_f(4, dm, sid, err) - -! check if the space has been created successfuly -! - if (err .ge. 0) then - -#ifdef COMPRESS -! prepare compression -! - call h5pcreate_f(H5P_DATASET_CREATE_F, pid, err) - -! check if the properties have been created properly -! - if (err .ge. 0) then - -! so far ok, so turn on the compression -! - compress = .true. - -! set the chunk size -! - call h5pset_chunk_f(pid, 4, dm, err) - -! check if the chunk size has been set properly -! - if (err .gt. 0) then - -! print error about the problem with setting the chunk size -! - call print_error("io::write_array4_integer_h5" & - , "Cannot set the size of the chunk!") - -! setting the size of the chunk failed, so turn off the compression -! - compress = .false. - - end if - -! set the compression algorithm -! -#ifdef DEFLATE - call h5pset_deflate_f(pid, 9, err) -#endif /* DEFLATE */ -#ifdef SZIP - if (product(dm) .ge. 32) & - call h5pset_szip_f(pid, H5_SZIP_NN_OM_F, 32, err) -#endif /* SZIP */ - -! check if the compression algorithm has been set properly -! - if (err .gt. 0) then - -! print error about the problem with setting the compression method -! - call print_error("io::write_array4_integer_h5" & - , "Cannot set the compression method!") - -! setting compression method failed, so turn off the compression -! - compress = .false. - - end if - - end if - -! check if it is safe to use compression -! - if (compress) then - -! create the dataset -! - call h5dcreate_f(gid, name, H5T_NATIVE_INTEGER, sid, did, err, pid) - - else -#endif /* COMPRESS */ - -! create the dataset -! - call h5dcreate_f(gid, name, H5T_NATIVE_INTEGER, sid, did, err) - -#ifdef COMPRESS - end if -#endif /* COMPRESS */ - -! check if the dataset has been created successfuly -! - if (err .ge. 0) then - -! write the dataset data -! - call h5dwrite_f(did, H5T_NATIVE_INTEGER, var(:,:,:,:), dm, err, sid) - -! check if the dataset has been written successfuly -! - if (err .gt. 0) then - -! print error about the problem with writing down the dataset -! - call print_error("io::write_array4_integer_h5" & - , "Cannot write dataset: " // trim(name)) - - end if - -! close the dataset -! - call h5dclose_f(did, err) - -! check if the dataset has been closed successfuly -! - if (err .gt. 0) then - -! print error about the problem with closing the dataset -! - call print_error("io::write_array4_integer_h5" & - , "Cannot close dataset: " // trim(name)) - - end if - - else - -! print error about the problem with creating the dataset -! - call print_error("io::write_array4_integer_h5" & - , "Cannot create dataset: " // trim(name)) - - end if - -! release the space -! - call h5sclose_f(sid, err) - -! check if the space has been released successfuly -! - if (err .gt. 0) then - -! print error about the problem with closing the space -! - call print_error("io::write_array4_integer_h5" & - , "Cannot close space for dataset: " // trim(name)) - - end if - - else - -! print error about the problem with creating the space for the attribute -! - call print_error("io::write_array4_integer_h5" & - , "Cannot create space for dataset: " // trim(name)) - - end if - -!------------------------------------------------------------------------------- -! - end subroutine write_array4_integer_h5 -! -!=============================================================================== -! ! read_array4_integer_h5: subroutine reads a 4D integer array ! ! arguments: @@ -4065,131 +3535,6 @@ module io ! !=============================================================================== ! -! write_vector_double_h5: subroutine stores a 1D double precision vector in -! a group -! -! arguments: -! gid - the HDF5 group identifier -! -!=============================================================================== -! - subroutine write_vector_double_h5(gid, name, length, data) - -! references to other modules -! - use error, only : print_error - use hdf5 , only : hid_t, hsize_t, H5T_NATIVE_DOUBLE - use hdf5 , only : h5screate_simple_f, h5sclose_f & - , h5dcreate_f, h5dwrite_f, h5dclose_f - -! declare variables -! - implicit none - -! input variables -! - integer(hid_t) , intent(in) :: gid - character(len=*) , intent(in) :: name - integer(hsize_t) , intent(in) :: length - real(kind=8) , dimension(:), intent(in) :: data - -! local variables -! - integer(hid_t) :: sid, did - integer(hsize_t), dimension(1) :: am - integer :: err -! -!------------------------------------------------------------------------------- -! -! prepare the vector dimensions -! - am(1) = length - -! create space for the vector -! - call h5screate_simple_f(1, am, sid, err) - -! check if the space has been created successfuly -! - if (err .ge. 0) then - -! create the dataset -! - call h5dcreate_f(gid, name, H5T_NATIVE_DOUBLE, sid, did, err) - -! check if the dataset has been created successfuly -! - if (err .ge. 0) then - -! write the dataset data -! - call h5dwrite_f(did, H5T_NATIVE_DOUBLE, data(:), am, err, sid) - -! check if the dataset has been written successfuly -! - if (err .gt. 0) then - -! print error about the problem with writing down the dataset -! - call print_error("io::write_vector_double_h5" & - , "Cannot write dataset: " // trim(name)) - - end if - -! close the dataset -! - call h5dclose_f(did, err) - -! check if the dataset has been closed successfuly -! - if (err .gt. 0) then - -! print error about the problem with closing the dataset -! - call print_error("io::write_vector_double_h5" & - , "Cannot close dataset: " // trim(name)) - - end if - - else - -! print error about the problem with creating the dataset -! - call print_error("io::write_vector_double_h5" & - , "Cannot create dataset: " // trim(name)) - - end if - -! release the space -! - call h5sclose_f(sid, err) - -! check if the space has been released successfuly -! - if (err .gt. 0) then - -! print error about the problem with closing the space -! - call print_error("io::write_vector_double_h5" & - , "Cannot close space for dataset: " // trim(name)) - - end if - - else - -! print error about the problem with creating the space for the attribute -! - call print_error("io::write_vector_double_h5" & - , "Cannot create space for dataset: " // trim(name)) - - end if - -!------------------------------------------------------------------------------- -! - end subroutine write_vector_double_h5 -! -!=============================================================================== -! ! read_vector_double_h5: subroutine reads a 1D double precision vector ! ! arguments: @@ -4279,790 +3624,6 @@ module io ! !=============================================================================== ! -! write_array4_float_h5: subroutine stores a 4D single precision array -! -! arguments: -! gid - the HDF5 group identifier where the dataset should be located -! name - the string name representing the dataset -! dm - the dataset dimensions -! value - the dataset values -! -!=============================================================================== -! - subroutine write_array4_float_h5(gid, name, dm, var) - -! references to other modules -! - use error, only : print_error, print_warning - use hdf5 , only : hid_t, hsize_t, H5T_NATIVE_REAL - use hdf5 , only : h5screate_simple_f, h5sclose_f & - , h5dcreate_f, h5dwrite_f, h5dclose_f - use hdf5 , only : H5P_DATASET_CREATE_F - use hdf5 , only : h5pcreate_f, h5pset_chunk_f, h5pclose_f -#ifdef DEFLATE - use hdf5 , only : h5pset_deflate_f -#endif /* DEFLATE */ -#ifdef SZIP - use hdf5 , only : H5_SZIP_NN_OM_F - use hdf5 , only : h5pset_szip_f -#endif /* SZIP */ - -! define default variables -! - implicit none - -! input variables -! - integer(hid_t) , intent(in) :: gid - character(len=*) , intent(in) :: name - integer(hsize_t), dimension(4) , intent(in) :: dm - real(kind=4) , dimension(:,:,:,:), intent(in) :: var - -! local variables -! - integer(hid_t) :: sid, pid, did - integer :: err -! -!------------------------------------------------------------------------------- -! -! create a space for the dataset dimensions -! - call h5screate_simple_f(4, dm(:), sid, err) - -! print an error, if the space for dimensions couldn't be created -! - if (err .eq. -1) call print_error("io::write_array4_float_h5" & - , "Cannot create a space for the dataset: " // trim(name)) - -! prepare the compression properties -! - call h5pcreate_f(H5P_DATASET_CREATE_F, pid, err) - -! if the compression properties could be created properly, set the compression -! algorithm and strength -! - if (err .eq. 0) then - -! set the chunk size -! - call h5pset_chunk_f(pid, 4, dm(:), err) - -! print a warning, if the chunk size couldn't be set properly -! - if (err .eq. -1) call print_warning("io::write_array4_float_h5" & - , "Cannot set the size of chunk!") - -! set the compression algorithm -! -#ifdef DEFLATE - call h5pset_deflate_f(pid, 9, err) -#endif /* DEFLATE */ -#ifdef SZIP - if (product(dm) .ge. 32) & - call h5pset_szip_f(pid, H5_SZIP_NN_OM_F, 32, err) -#endif /* SZIP */ - -! print a warning, if the compression algorithm couldn't be set -! - if (err .eq. -1) call print_warning("io::write_array4_float_h5" & - , "Cannot set the compression method!") - - else - -! print a warning, if the property list couldn't be created -! - call print_warning("io::write_array4_float_h5" & - , "Cannot create a property list!") - - end if - -! create the dataset -! - call h5dcreate_f(gid, name, H5T_NATIVE_REAL, sid, did, err, pid) - -! print an error, if the dataset couldn't be created -! - if (err .eq. -1) call print_error("io::write_array4_float_h5" & - , "Cannot create the dataset: " // trim(name)) - -! write the dataset values -! - call h5dwrite_f(did, H5T_NATIVE_REAL, var(:,:,:,:), dm, err, sid) - -! print an error, if the dataset couldn't be written successfuly -! - if (err .eq. -1) call print_error("io::write_array4_float_h5" & - , "Cannot write the dataset: " // trim(name)) - -! close the dataset -! - call h5dclose_f(did, err) - -! print an error, if the dataset couldn't be closed -! - if (err .eq. -1) call print_error("io::write_array4_float_h5" & - , "Cannot close the dataset: " // trim(name)) - -! if the property list is created -! - if (pid .ne. -1) then - -! terminate access to the property list -! - call h5pclose_f(pid, err) - -! print a warning, if the property list couldn't be closed -! - if (err .eq. -1) call print_warning("io::write_array4_float_h5" & - , "Cannot close the property list!") - - end if - -! release the dataspace of the current dataset -! - call h5sclose_f(sid, err) - -! print an error, if the space couldn't be released successfuly -! - if (err .eq. -1) call print_error("io::write_array4_float_h5" & - , "Cannot close the space for the dataset: " // trim(name)) - -!------------------------------------------------------------------------------- -! - end subroutine write_array4_float_h5 -! -!=============================================================================== -! -! write_array3_double_h5: subroutine stores a 3D double precision array -! -! arguments: -! gid - the HDF5 group identifier -! name - the string name representing the dataset -! dm - the data dimensions -! value - the data -! -!=============================================================================== -! - subroutine write_array3_double_h5(gid, name, dm, var) - -! references to other modules -! - use error, only : print_error - use hdf5 , only : hid_t, hsize_t, H5T_NATIVE_DOUBLE - use hdf5 , only : h5screate_simple_f, h5sclose_f & - , h5dcreate_f, h5dwrite_f, h5dclose_f -#ifdef COMPRESS - use hdf5 , only : H5P_DATASET_CREATE_F - use hdf5 , only : h5pcreate_f, h5pset_chunk_f, h5pclose_f -#ifdef DEFLATE - use hdf5 , only : h5pset_deflate_f -#endif /* DEFLATE */ -#ifdef SZIP - use hdf5 , only : H5_SZIP_NN_OM_F - use hdf5 , only : h5pset_szip_f -#endif /* SZIP */ -#endif /* COMPRESS */ - -! declare variables -! - implicit none - -! input variables -! - integer(hid_t) , intent(in) :: gid - character(len=*) , intent(in) :: name - integer(hsize_t), dimension(3) , intent(in) :: dm - real(kind=8) , dimension(:,:,:), intent(in) :: var - -! local variables -! - integer(hid_t) :: sid, pid, did - integer :: err -#ifdef COMPRESS - logical :: compress = .false. -#endif /* COMPRESS */ -! -!------------------------------------------------------------------------------- -! -! create space for the vector -! - call h5screate_simple_f(3, dm, sid, err) - -! check if the space has been created successfuly -! - if (err .ge. 0) then - -#ifdef COMPRESS -! prepare compression -! - call h5pcreate_f(H5P_DATASET_CREATE_F, pid, err) - -! check if the properties have been created properly -! - if (err .ge. 0) then - -! so far ok, so turn on the compression -! - compress = .true. - -! set the chunk size -! - call h5pset_chunk_f(pid, 3, dm, err) - -! check if the chunk size has been set properly -! - if (err .gt. 0) then - -! print error about the problem with setting the chunk size -! - call print_error("io::write_array3_double_h5" & - , "Cannot set the size of the chunk!") - -! setting the size of the chunk failed, so turn off the compression -! - compress = .false. - - end if - -! set the compression algorithm -! -#ifdef DEFLATE - call h5pset_deflate_f(pid, 9, err) -#endif /* DEFLATE */ -#ifdef SZIP - if (product(dm) .ge. 32) & - call h5pset_szip_f(pid, H5_SZIP_NN_OM_F, 32, err) -#endif /* SZIP */ - -! check if the compression algorithm has been set properly -! - if (err .gt. 0) then - -! print error about the problem with setting the compression method -! - call print_error("io::write_array3_double_h5" & - , "Cannot set the compression method!") - -! setting compression method failed, so turn off the compression -! - compress = .false. - - end if - - end if - -! check if it is safe to use compression -! - if (compress) then - -! create the dataset -! - call h5dcreate_f(gid, name, H5T_NATIVE_DOUBLE, sid, did, err, pid) - - else -#endif /* COMPRESS */ - -! create the dataset -! - call h5dcreate_f(gid, name, H5T_NATIVE_DOUBLE, sid, did, err) - -#ifdef COMPRESS - end if -#endif /* COMPRESS */ - -! check if the dataset has been created successfuly -! - if (err .ge. 0) then - -! write the dataset data -! - call h5dwrite_f(did, H5T_NATIVE_DOUBLE, var(:,:,:), dm, err, sid) - -! check if the dataset has been written successfuly -! - if (err .gt. 0) then - -! print error about the problem with writing down the dataset -! - call print_error("io::write_array3_double_h5" & - , "Cannot write dataset: " // trim(name)) - - end if - -! close the dataset -! - call h5dclose_f(did, err) - -! check if the dataset has been closed successfuly -! - if (err .gt. 0) then - -! print error about the problem with closing the dataset -! - call print_error("io::write_array3_double_h5" & - , "Cannot close dataset: " // trim(name)) - - end if - - else - -! print error about the problem with creating the dataset -! - call print_error("io::write_array3_double_h5" & - , "Cannot create dataset: " // trim(name)) - - end if - -! release the space -! - call h5sclose_f(sid, err) - -! check if the space has been released successfuly -! - if (err .gt. 0) then - -! print error about the problem with closing the space -! - call print_error("io::write_array3_double_h5" & - , "Cannot close space for dataset: " // trim(name)) - - end if - - else - -! print error about the problem with creating the space for the attribute -! - call print_error("io::write_array3_double_h5" & - , "Cannot create space for dataset: " // trim(name)) - - end if - -!------------------------------------------------------------------------------- -! - end subroutine write_array3_double_h5 -! -!=============================================================================== -! -! write_array4_double_h5: subroutine stores a 4D double precision array -! -! arguments: -! gid - the HDF5 group identifier -! name - the string name representing the dataset -! dm - the data dimensions -! value - the data -! -!=============================================================================== -! - subroutine write_array4_double_h5(gid, name, dm, var) - -! references to other modules -! - use error, only : print_error - use hdf5 , only : hid_t, hsize_t, H5T_NATIVE_DOUBLE - use hdf5 , only : h5screate_simple_f, h5sclose_f & - , h5dcreate_f, h5dwrite_f, h5dclose_f -#ifdef COMPRESS - use hdf5 , only : H5P_DATASET_CREATE_F - use hdf5 , only : h5pcreate_f, h5pset_chunk_f, h5pclose_f -#ifdef DEFLATE - use hdf5 , only : h5pset_deflate_f -#endif /* DEFLATE */ -#ifdef SZIP - use hdf5 , only : H5_SZIP_NN_OM_F - use hdf5 , only : h5pset_szip_f -#endif /* SZIP */ -#endif /* COMPRESS */ - -! declare variables -! - implicit none - -! input variables -! - integer(hid_t) , intent(in) :: gid - character(len=*) , intent(in) :: name - integer(hsize_t), dimension(4) , intent(in) :: dm - real(kind=8) , dimension(:,:,:,:), intent(in) :: var - -! local variables -! - integer(hid_t) :: sid, pid, did - integer :: err -#ifdef COMPRESS - logical :: compress = .false. -#endif /* COMPRESS */ -! -!------------------------------------------------------------------------------- -! -! create space for the vector -! - call h5screate_simple_f(4, dm, sid, err) - -! check if the space has been created successfuly -! - if (err .ge. 0) then - -#ifdef COMPRESS -! prepare compression -! - call h5pcreate_f(H5P_DATASET_CREATE_F, pid, err) - -! check if the properties have been created properly -! - if (err .ge. 0) then - -! so far ok, so turn on the compression -! - compress = .true. - -! set the chunk size -! - call h5pset_chunk_f(pid, 4, dm, err) - -! check if the chunk size has been set properly -! - if (err .gt. 0) then - -! print error about the problem with setting the chunk size -! - call print_error("io::write_array4_double_h5" & - , "Cannot set the size of the chunk!") - -! setting the size of the chunk failed, so turn off the compression -! - compress = .false. - - end if - -! set the compression algorithm -! -#ifdef DEFLATE - call h5pset_deflate_f(pid, 9, err) -#endif /* DEFLATE */ -#ifdef SZIP - if (product(dm) .ge. 32) & - call h5pset_szip_f(pid, H5_SZIP_NN_OM_F, 32, err) -#endif /* SZIP */ - -! check if the compression algorithm has been set properly -! - if (err .gt. 0) then - -! print error about the problem with setting the compression method -! - call print_error("io::write_array4_double_h5" & - , "Cannot set the compression method!") - -! setting compression method failed, so turn off the compression -! - compress = .false. - - end if - - end if - -! check if it is safe to use compression -! - if (compress) then - -! create the dataset -! - call h5dcreate_f(gid, name, H5T_NATIVE_DOUBLE, sid, did, err, pid) - - else -#endif /* COMPRESS */ - -! create the dataset -! - call h5dcreate_f(gid, name, H5T_NATIVE_DOUBLE, sid, did, err) - -#ifdef COMPRESS - end if -#endif /* COMPRESS */ - -! check if the dataset has been created successfuly -! - if (err .ge. 0) then - -! write the dataset data -! - call h5dwrite_f(did, H5T_NATIVE_DOUBLE, var(:,:,:,:), dm, err, sid) - -! check if the dataset has been written successfuly -! - if (err .gt. 0) then - -! print error about the problem with writing down the dataset -! - call print_error("io::write_array4_double_h5" & - , "Cannot write dataset: " // trim(name)) - - end if - -! close the dataset -! - call h5dclose_f(did, err) - -! check if the dataset has been closed successfuly -! - if (err .gt. 0) then - -! print error about the problem with closing the dataset -! - call print_error("io::write_array4_double_h5" & - , "Cannot close dataset: " // trim(name)) - - end if - - else - -! print error about the problem with creating the dataset -! - call print_error("io::write_array4_double_h5" & - , "Cannot create dataset: " // trim(name)) - - end if - -! release the space -! - call h5sclose_f(sid, err) - -! check if the space has been released successfuly -! - if (err .gt. 0) then - -! print error about the problem with closing the space -! - call print_error("io::write_array4_double_h5" & - , "Cannot close space for dataset: " // trim(name)) - - end if - - else - -! print error about the problem with creating the space for the attribute -! - call print_error("io::write_array4_double_h5" & - , "Cannot create space for dataset: " // trim(name)) - - end if - -!------------------------------------------------------------------------------- -! - end subroutine write_array4_double_h5 -! -!=============================================================================== -! -! write_array5_double_h5: subroutine stores a 5D double precision array -! -! arguments: -! gid - the HDF5 group identifier -! name - the string name representing the dataset -! dm - the data dimensions -! value - the data -! -!=============================================================================== -! - subroutine write_array5_double_h5(gid, name, dm, var) - -! references to other modules -! - use error, only : print_error - use hdf5 , only : hid_t, hsize_t, H5T_NATIVE_DOUBLE - use hdf5 , only : h5screate_simple_f, h5sclose_f & - , h5dcreate_f, h5dwrite_f, h5dclose_f -#ifdef COMPRESS - use hdf5 , only : H5P_DATASET_CREATE_F - use hdf5 , only : h5pcreate_f, h5pset_chunk_f, h5pclose_f -#ifdef DEFLATE - use hdf5 , only : h5pset_deflate_f -#endif /* DEFLATE */ -#ifdef SZIP - use hdf5 , only : H5_SZIP_NN_OM_F - use hdf5 , only : h5pset_szip_f -#endif /* SZIP */ -#endif /* COMPRESS */ - -! declare variables -! - implicit none - -! input variables -! - integer(hid_t) , intent(in) :: gid - character(len=*) , intent(in) :: name - integer(hsize_t), dimension(5) , intent(in) :: dm - real(kind=8) , dimension(:,:,:,:,:), intent(in) :: var - -! local variables -! - integer(hid_t) :: sid, pid, did - integer :: err -#ifdef COMPRESS - logical :: compress = .false. -#endif /* COMPRESS */ -! -!------------------------------------------------------------------------------- -! -! create space for the vector -! - call h5screate_simple_f(5, dm, sid, err) - -! check if the space has been created successfuly -! - if (err .ge. 0) then - -#ifdef COMPRESS -! prepare compression -! - call h5pcreate_f(H5P_DATASET_CREATE_F, pid, err) - -! check if the properties have been created properly -! - if (err .ge. 0) then - -! so far ok, so turn on the compression -! - compress = .true. - -! set the chunk size -! - call h5pset_chunk_f(pid, 5, dm, err) - -! check if the chunk size has been set properly -! - if (err .gt. 0) then - -! print error about the problem with setting the chunk size -! - call print_error("io::write_array5_double_h5" & - , "Cannot set the size of the chunk!") - -! setting the size of the chunk failed, so turn off the compression -! - compress = .false. - - end if - -! set the compression algorithm -! -#ifdef DEFLATE - call h5pset_deflate_f(pid, 9, err) -#endif /* DEFLATE */ -#ifdef SZIP - if (product(dm) .ge. 32) & - call h5pset_szip_f(pid, H5_SZIP_NN_OM_F, 32, err) -#endif /* SZIP */ - -! check if the compression algorithm has been set properly -! - if (err .gt. 0) then - -! print error about the problem with setting the compression method -! - call print_error("io::write_array5_double_h5" & - , "Cannot set the compression method!") - -! setting compression method failed, so turn off the compression -! - compress = .false. - - end if - - end if - -! check if it is safe to use compression -! - if (compress) then - -! create the dataset -! - call h5dcreate_f(gid, name, H5T_NATIVE_DOUBLE, sid, did, err, pid) - - else -#endif /* COMPRESS */ - -! create the dataset -! - call h5dcreate_f(gid, name, H5T_NATIVE_DOUBLE, sid, did, err) - -#ifdef COMPRESS - end if -#endif /* COMPRESS */ - -! check if the dataset has been created successfuly -! - if (err .ge. 0) then - -! write the dataset data -! - call h5dwrite_f(did, H5T_NATIVE_DOUBLE, var(:,:,:,:,:), dm, err, sid) - -! check if the dataset has been written successfuly -! - if (err .gt. 0) then - -! print error about the problem with writing down the dataset -! - call print_error("io::write_array5_double_h5" & - , "Cannot write dataset: " // trim(name)) - - end if - -! close the dataset -! - call h5dclose_f(did, err) - -! check if the dataset has been closed successfuly -! - if (err .gt. 0) then - -! print error about the problem with closing the dataset -! - call print_error("io::write_array5_double_h5" & - , "Cannot close dataset: " // trim(name)) - - end if - - else - -! print error about the problem with creating the dataset -! - call print_error("io::write_array5_double_h5" & - , "Cannot create dataset: " // trim(name)) - - end if - -! release the space -! - call h5sclose_f(sid, err) - -! check if the space has been released successfuly -! - if (err .gt. 0) then - -! print error about the problem with closing the space -! - call print_error("io::write_array5_double_h5" & - , "Cannot close space for dataset: " // trim(name)) - - end if - - else - -! print error about the problem with creating the space for the attribute -! - call print_error("io::write_array5_double_h5" & - , "Cannot create space for dataset: " // trim(name)) - - end if - -!------------------------------------------------------------------------------- -! - end subroutine write_array5_double_h5 -! -!=============================================================================== -! ! read_array5_double_h5: subroutine reads a 5D double precision array ! ! arguments: @@ -5149,216 +3710,2386 @@ module io !------------------------------------------------------------------------------- ! end subroutine read_array5_double_h5 -! -!=============================================================================== -! -! write_array6_double_h5: subroutine stores a 6D double precision array -! -! arguments: -! gid - the HDF5 group identifier -! name - the string name representing the dataset -! dm - the data dimensions -! value - the data -! -!=============================================================================== -! - subroutine write_array6_double_h5(gid, name, dm, var) -! references to other modules +!=============================================================================== ! - use error, only : print_error - use hdf5 , only : hid_t, hsize_t, H5T_NATIVE_DOUBLE - use hdf5 , only : h5screate_simple_f, h5sclose_f & - , h5dcreate_f, h5dwrite_f, h5dclose_f +! WRITE_ARRAY SUBROUTINES +! +!=============================================================================== +! +! subroutine WRITE_1D_ARRAY_INTEGER_H5: +! ------------------------------------ +! +! Subroutine stores a one-dimensional integer array in a group specified by +! identifier. +! +! Arguments: +! +! gid - the HDF5 group identifier +! name - the string name describing the array +! dm - the array dimensions +! value - the array values +! +!=============================================================================== +! + subroutine write_1d_array_integer_h5(gid, name, ln, var) + +! import procedures and variables from other modules +! + use error , only : print_error, print_warning + use hdf5 , only : H5T_NATIVE_INTEGER #ifdef COMPRESS - use hdf5 , only : H5P_DATASET_CREATE_F - use hdf5 , only : h5pcreate_f, h5pset_chunk_f, h5pclose_f + use hdf5 , only : H5P_DATASET_CREATE_F +#ifdef SZIP + use hdf5 , only : H5_SZIP_NN_OM_F +#endif /* SZIP */ +#endif /* COMPRESS */ + use hdf5 , only : hid_t, hsize_t + use hdf5 , only : h5screate_simple_f, h5sclose_f + use hdf5 , only : h5dcreate_f, h5dwrite_f, h5dclose_f +#ifdef COMPRESS + use hdf5 , only : h5pcreate_f, h5pset_chunk_f, h5pclose_f #ifdef DEFLATE - use hdf5 , only : h5pset_deflate_f + use hdf5 , only : h5pset_deflate_f #endif /* DEFLATE */ #ifdef SZIP - use hdf5 , only : H5_SZIP_NN_OM_F - use hdf5 , only : h5pset_szip_f + use hdf5 , only : h5pset_szip_f #endif /* SZIP */ #endif /* COMPRESS */ -! declare variables +! local variables are not implicit by default ! implicit none -! input variables +! subroutine arguments ! - integer(hid_t) , intent(in) :: gid - character(len=*) , intent(in) :: name - integer(hsize_t), dimension(6) , intent(in) :: dm - real(kind=8) , dimension(:,:,:,:,:,:), intent(in) :: var + integer(hid_t) , intent(in) :: gid + character(len=*) , intent(in) :: name + integer(hsize_t) , intent(in) :: ln + integer(kind=4) , dimension(:), intent(in) :: var -! local variables -! - integer(hid_t) :: sid, pid, did - integer :: err #ifdef COMPRESS +! test for compression +! logical :: compress = .false. #endif /* COMPRESS */ + +! HDF5 object identifiers +! + integer(hid_t) :: sid, pid, did + +! array dimensions +! + integer(hsize_t), dimension(1) :: dm + +! procedure return value +! + integer :: iret + +! subroutine name string +! + character(len=*), parameter :: fname = "io::write_1d_array_integer_h5" ! !------------------------------------------------------------------------------- ! -! create space for the vector +! substitute array dimensions ! - call h5screate_simple_f(6, dm, sid, err) + dm(1) = ln -! check if the space has been created successfuly +! create a space for the array ! - if (err .ge. 0) then + call h5screate_simple_f(1, dm(1:1), sid, iret) + +! check if the space has been created successfuly, if not quit +! + if (iret < 0) then + +! print error about the problem with creating the space +! + call print_error(fname, "Cannot create space for dataset: " // trim(name)) + +! quit the subroutine +! + return + + end if #ifdef COMPRESS -! prepare compression +! prepare the property object for compression ! - call h5pcreate_f(H5P_DATASET_CREATE_F, pid, err) + call h5pcreate_f(H5P_DATASET_CREATE_F, pid, iret) -! check if the properties have been created properly +! check if the object has been created properly, if not quit ! - if (err .ge. 0) then + if (iret < 0) then + +! print error about the problem with creating the compression property +! + call print_error(fname, "Cannot create property for dataset: " & + // trim(name)) + +! quit the subroutine +! + return + + end if ! so far ok, so turn on the compression ! - compress = .true. + compress = .true. ! set the chunk size ! - call h5pset_chunk_f(pid, 6, dm, err) + call h5pset_chunk_f(pid, 1, dm(1:1), iret) ! check if the chunk size has been set properly ! - if (err .gt. 0) then + if (iret > 0) then ! print error about the problem with setting the chunk size ! - call print_error("io::write_array6_double_h5" & - , "Cannot set the size of the chunk!") + call print_warning(fname, "Cannot set the size of the chunk!") ! setting the size of the chunk failed, so turn off the compression ! - compress = .false. + compress = .false. - end if + end if ! set the compression algorithm ! #ifdef DEFLATE - call h5pset_deflate_f(pid, 9, err) + call h5pset_deflate_f(pid, 9, iret) #endif /* DEFLATE */ #ifdef SZIP - if (product(dm) .ge. 32) & - call h5pset_szip_f(pid, H5_SZIP_NN_OM_F, 32, err) + if (dm >= 32) call h5pset_szip_f(pid, H5_SZIP_NN_OM_F, 32, iret) #endif /* SZIP */ ! check if the compression algorithm has been set properly ! - if (err .gt. 0) then + if (iret > 0) then ! print error about the problem with setting the compression method ! - call print_error("io::write_array6_double_h5" & - , "Cannot set the compression method!") + call print_warning(fname, "Cannot set the compression method!") ! setting compression method failed, so turn off the compression ! - compress = .false. + compress = .false. - end if - - end if + end if ! check if it is safe to use compression ! - if (compress) then + if (compress) then ! create the dataset ! - call h5dcreate_f(gid, name, H5T_NATIVE_DOUBLE, sid, did, err, pid) + call h5dcreate_f(gid, name, H5T_NATIVE_INTEGER, sid, did, iret, pid) - else -#endif /* COMPRESS */ + else ! create the dataset ! - call h5dcreate_f(gid, name, H5T_NATIVE_DOUBLE, sid, did, err) + call h5dcreate_f(gid, name, H5T_NATIVE_INTEGER, sid, did, iret) -#ifdef COMPRESS - end if + end if +#else /* COMPRESS */ +! create the dataset +! + call h5dcreate_f(gid, name, H5T_NATIVE_INTEGER, sid, did, iret) #endif /* COMPRESS */ ! check if the dataset has been created successfuly ! - if (err .ge. 0) then + if (iret >= 0) then ! write the dataset data ! - call h5dwrite_f(did, H5T_NATIVE_DOUBLE, var(:,:,:,:,:,:), dm, err, sid) + call h5dwrite_f(did, H5T_NATIVE_INTEGER, var(:), dm(1:1), iret, sid) ! check if the dataset has been written successfuly ! - if (err .gt. 0) then + if (iret > 0) then ! print error about the problem with writing down the dataset ! - call print_error("io::write_array6_double_h5" & - , "Cannot write dataset: " // trim(name)) - - end if - -! close the dataset -! - call h5dclose_f(did, err) - -! check if the dataset has been closed successfuly -! - if (err .gt. 0) then - -! print error about the problem with closing the dataset -! - call print_error("io::write_array6_double_h5" & - , "Cannot close dataset: " // trim(name)) - - end if - - else - -! print error about the problem with creating the dataset -! - call print_error("io::write_array6_double_h5" & - , "Cannot create dataset: " // trim(name)) + call print_error(fname, "Cannot write dataset: " // trim(name)) end if -! close the space +! close the dataset ! - call h5sclose_f(sid, err) + call h5dclose_f(did, iret) -! check if the space has been released successfuly +! check if the dataset has been closed successfuly ! - if (err .gt. 0) then + if (iret > 0) then -! print error about the problem with closing the space +! print error about the problem with closing the dataset ! - call print_error("io::write_array6_double_h5" & - , "Cannot close space for dataset: " // trim(name)) + call print_error(fname, "Cannot close dataset: " // trim(name)) end if else -! print error about the problem with creating the space for the attribute +! print error about the problem with creating the dataset ! - call print_error("io::write_array6_double_h5" & - , "Cannot create space for dataset: " // trim(name)) + call print_error(fname, "Cannot create dataset: " // trim(name)) + + end if + +! release the space +! + call h5sclose_f(sid, iret) + +! check if the space has been released successfuly +! + if (iret > 0) then + +! print error about the problem with closing the space +! + call print_error(fname, "Cannot close space for dataset: " // trim(name)) end if !------------------------------------------------------------------------------- ! - end subroutine write_array6_double_h5 + end subroutine write_1d_array_integer_h5 +! +!=============================================================================== +! +! subroutine WRITE_2D_ARRAY_INTEGER_H5: +! ------------------------------------ +! +! Subroutine stores a two-dimensional integer array in a group specified by +! identifier. +! +! Arguments: +! +! gid - the HDF5 group identifier +! name - the string name describing the array +! dm - the array dimensions +! value - the array values +! +!=============================================================================== +! + subroutine write_2d_array_integer_h5(gid, name, dm, var) + +! import procedures and variables from other modules +! + use error , only : print_error, print_warning + use hdf5 , only : H5T_NATIVE_INTEGER +#ifdef COMPRESS + use hdf5 , only : H5P_DATASET_CREATE_F +#ifdef SZIP + use hdf5 , only : H5_SZIP_NN_OM_F +#endif /* SZIP */ +#endif /* COMPRESS */ + use hdf5 , only : hid_t, hsize_t + use hdf5 , only : h5screate_simple_f, h5sclose_f + use hdf5 , only : h5dcreate_f, h5dwrite_f, h5dclose_f +#ifdef COMPRESS + use hdf5 , only : h5pcreate_f, h5pset_chunk_f, h5pclose_f +#ifdef DEFLATE + use hdf5 , only : h5pset_deflate_f +#endif /* DEFLATE */ +#ifdef SZIP + use hdf5 , only : h5pset_szip_f +#endif /* SZIP */ +#endif /* COMPRESS */ + +! local variables are not implicit by default +! + implicit none + +! subroutine arguments +! + integer(hid_t) , intent(in) :: gid + character(len=*) , intent(in) :: name + integer(hsize_t), dimension(2) , intent(in) :: dm + integer(kind=4) , dimension(:,:), intent(in) :: var + +#ifdef COMPRESS +! test for compression +! + logical :: compress = .false. +#endif /* COMPRESS */ + +! HDF5 object identifiers +! + integer(hid_t) :: sid, pid, did + +! procedure return value +! + integer :: iret + +! subroutine name string +! + character(len=*), parameter :: fname = "io::write_2d_array_integer_h5" +! +!------------------------------------------------------------------------------- +! +! create a space for the array +! + call h5screate_simple_f(2, dm(1:2), sid, iret) + +! check if the space has been created successfuly, if not quit +! + if (iret < 0) then + +! print error about the problem with creating the space +! + call print_error(fname, "Cannot create space for dataset: " // trim(name)) + +! quit the subroutine +! + return + + end if + +#ifdef COMPRESS +! prepare the property object for compression +! + call h5pcreate_f(H5P_DATASET_CREATE_F, pid, iret) + +! check if the object has been created properly, if not quit +! + if (iret < 0) then + +! print error about the problem with creating the compression property +! + call print_error(fname, "Cannot create property for dataset: " & + // trim(name)) + +! quit the subroutine +! + return + + end if + +! so far ok, so turn on the compression +! + compress = .true. + +! set the chunk size +! + call h5pset_chunk_f(pid, 2, dm(1:2), iret) + +! check if the chunk size has been set properly +! + if (iret > 0) then + +! print error about the problem with setting the chunk size +! + call print_warning(fname, "Cannot set the size of the chunk!") + +! setting the size of the chunk failed, so turn off the compression +! + compress = .false. + + end if + +! set the compression algorithm +! +#ifdef DEFLATE + call h5pset_deflate_f(pid, 9, iret) +#endif /* DEFLATE */ +#ifdef SZIP + if (product(dm(1:2)) >= 32) & + call h5pset_szip_f(pid, H5_SZIP_NN_OM_F, 32, iret) +#endif /* SZIP */ + +! check if the compression algorithm has been set properly +! + if (iret > 0) then + +! print error about the problem with setting the compression method +! + call print_warning(fname, "Cannot set the compression method!") + +! setting compression method failed, so turn off the compression +! + compress = .false. + + end if + +! check if it is safe to use compression +! + if (compress) then + +! create the dataset +! + call h5dcreate_f(gid, name, H5T_NATIVE_INTEGER, sid, did, iret, pid) + + else + +! create the dataset +! + call h5dcreate_f(gid, name, H5T_NATIVE_INTEGER, sid, did, iret) + + end if +#else /* COMPRESS */ +! create the dataset +! + call h5dcreate_f(gid, name, H5T_NATIVE_INTEGER, sid, did, iret) +#endif /* COMPRESS */ + +! check if the dataset has been created successfuly +! + if (iret >= 0) then + +! write the dataset data +! + call h5dwrite_f(did, H5T_NATIVE_INTEGER, var(:,:), dm(1:2), iret, sid) + +! check if the dataset has been written successfuly +! + if (iret > 0) then + +! print error about the problem with writing down the dataset +! + call print_error(fname, "Cannot write dataset: " // trim(name)) + + end if + +! close the dataset +! + call h5dclose_f(did, iret) + +! check if the dataset has been closed successfuly +! + if (iret > 0) then + +! print error about the problem with closing the dataset +! + call print_error(fname, "Cannot close dataset: " // trim(name)) + + end if + + else + +! print error about the problem with creating the dataset +! + call print_error(fname, "Cannot create dataset: " // trim(name)) + + end if + +! release the space +! + call h5sclose_f(sid, iret) + +! check if the space has been released successfuly +! + if (iret > 0) then + +! print error about the problem with closing the space +! + call print_error(fname, "Cannot close space for dataset: " // trim(name)) + + end if + +!------------------------------------------------------------------------------- +! + end subroutine write_2d_array_integer_h5 +! +!=============================================================================== +! +! subroutine WRITE_3D_ARRAY_INTEGER_H5: +! ------------------------------------ +! +! Subroutine stores a three-dimensional integer array in a group specified by +! identifier. +! +! Arguments: +! +! gid - the HDF5 group identifier +! name - the string name describing the array +! dm - the array dimensions +! value - the array values +! +!=============================================================================== +! + subroutine write_3d_array_integer_h5(gid, name, dm, var) + +! import procedures and variables from other modules +! + use error , only : print_error, print_warning + use hdf5 , only : H5T_NATIVE_INTEGER +#ifdef COMPRESS + use hdf5 , only : H5P_DATASET_CREATE_F +#ifdef SZIP + use hdf5 , only : H5_SZIP_NN_OM_F +#endif /* SZIP */ +#endif /* COMPRESS */ + use hdf5 , only : hid_t, hsize_t + use hdf5 , only : h5screate_simple_f, h5sclose_f + use hdf5 , only : h5dcreate_f, h5dwrite_f, h5dclose_f +#ifdef COMPRESS + use hdf5 , only : h5pcreate_f, h5pset_chunk_f, h5pclose_f +#ifdef DEFLATE + use hdf5 , only : h5pset_deflate_f +#endif /* DEFLATE */ +#ifdef SZIP + use hdf5 , only : h5pset_szip_f +#endif /* SZIP */ +#endif /* COMPRESS */ + +! local variables are not implicit by default +! + implicit none + +! subroutine arguments +! + integer(hid_t) , intent(in) :: gid + character(len=*) , intent(in) :: name + integer(hsize_t), dimension(3) , intent(in) :: dm + integer(kind=4) , dimension(:,:,:), intent(in) :: var + +#ifdef COMPRESS +! test for compression +! + logical :: compress = .false. +#endif /* COMPRESS */ + +! HDF5 object identifiers +! + integer(hid_t) :: sid, pid, did + +! procedure return value +! + integer :: iret + +! subroutine name string +! + character(len=*), parameter :: fname = "io::write_3d_array_integer_h5" +! +!------------------------------------------------------------------------------- +! +! create a space for the array +! + call h5screate_simple_f(3, dm(1:3), sid, iret) + +! check if the space has been created successfuly, if not quit +! + if (iret < 0) then + +! print error about the problem with creating the space +! + call print_error(fname, "Cannot create space for dataset: " // trim(name)) + +! quit the subroutine +! + return + + end if + +#ifdef COMPRESS +! prepare the property object for compression +! + call h5pcreate_f(H5P_DATASET_CREATE_F, pid, iret) + +! check if the object has been created properly, if not quit +! + if (iret < 0) then + +! print error about the problem with creating the compression property +! + call print_error(fname, "Cannot create property for dataset: " & + // trim(name)) + +! quit the subroutine +! + return + + end if + +! so far ok, so turn on the compression +! + compress = .true. + +! set the chunk size +! + call h5pset_chunk_f(pid, 3, dm(1:3), iret) + +! check if the chunk size has been set properly +! + if (iret > 0) then + +! print error about the problem with setting the chunk size +! + call print_warning(fname, "Cannot set the size of the chunk!") + +! setting the size of the chunk failed, so turn off the compression +! + compress = .false. + + end if + +! set the compression algorithm +! +#ifdef DEFLATE + call h5pset_deflate_f(pid, 9, iret) +#endif /* DEFLATE */ +#ifdef SZIP + if (product(dm(1:3)) >= 32) & + call h5pset_szip_f(pid, H5_SZIP_NN_OM_F, 32, iret) +#endif /* SZIP */ + +! check if the compression algorithm has been set properly +! + if (iret > 0) then + +! print error about the problem with setting the compression method +! + call print_warning(fname, "Cannot set the compression method!") + +! setting compression method failed, so turn off the compression +! + compress = .false. + + end if + +! check if it is safe to use compression +! + if (compress) then + +! create the dataset +! + call h5dcreate_f(gid, name, H5T_NATIVE_INTEGER, sid, did, iret, pid) + + else + +! create the dataset +! + call h5dcreate_f(gid, name, H5T_NATIVE_INTEGER, sid, did, iret) + + end if +#else /* COMPRESS */ +! create the dataset +! + call h5dcreate_f(gid, name, H5T_NATIVE_INTEGER, sid, did, iret) +#endif /* COMPRESS */ + +! check if the dataset has been created successfuly +! + if (iret >= 0) then + +! write the dataset data +! + call h5dwrite_f(did, H5T_NATIVE_INTEGER, var(:,:,:), dm(1:3), iret, sid) + +! check if the dataset has been written successfuly +! + if (iret > 0) then + +! print error about the problem with writing down the dataset +! + call print_error(fname, "Cannot write dataset: " // trim(name)) + + end if + +! close the dataset +! + call h5dclose_f(did, iret) + +! check if the dataset has been closed successfuly +! + if (iret > 0) then + +! print error about the problem with closing the dataset +! + call print_error(fname, "Cannot close dataset: " // trim(name)) + + end if + + else + +! print error about the problem with creating the dataset +! + call print_error(fname, "Cannot create dataset: " // trim(name)) + + end if + +! release the space +! + call h5sclose_f(sid, iret) + +! check if the space has been released successfuly +! + if (iret > 0) then + +! print error about the problem with closing the space +! + call print_error(fname, "Cannot close space for dataset: " // trim(name)) + + end if + +!------------------------------------------------------------------------------- +! + end subroutine write_3d_array_integer_h5 +! +!=============================================================================== +! +! subroutine WRITE_4D_ARRAY_INTEGER_H5: +! ------------------------------------ +! +! Subroutine stores a four-dimensional integer array in a group specified by +! identifier. +! +! Arguments: +! +! gid - the HDF5 group identifier +! name - the string name describing the array +! dm - the array dimensions +! value - the array values +! +!=============================================================================== +! + subroutine write_4d_array_integer_h5(gid, name, dm, var) + +! import procedures and variables from other modules +! + use error , only : print_error, print_warning + use hdf5 , only : H5T_NATIVE_INTEGER +#ifdef COMPRESS + use hdf5 , only : H5P_DATASET_CREATE_F +#ifdef SZIP + use hdf5 , only : H5_SZIP_NN_OM_F +#endif /* SZIP */ +#endif /* COMPRESS */ + use hdf5 , only : hid_t, hsize_t + use hdf5 , only : h5screate_simple_f, h5sclose_f + use hdf5 , only : h5dcreate_f, h5dwrite_f, h5dclose_f +#ifdef COMPRESS + use hdf5 , only : h5pcreate_f, h5pset_chunk_f, h5pclose_f +#ifdef DEFLATE + use hdf5 , only : h5pset_deflate_f +#endif /* DEFLATE */ +#ifdef SZIP + use hdf5 , only : h5pset_szip_f +#endif /* SZIP */ +#endif /* COMPRESS */ + +! local variables are not implicit by default +! + implicit none + +! subroutine arguments +! + integer(hid_t) , intent(in) :: gid + character(len=*) , intent(in) :: name + integer(hsize_t), dimension(4) , intent(in) :: dm + integer(kind=4) , dimension(:,:,:,:), intent(in) :: var + +#ifdef COMPRESS +! test for compression +! + logical :: compress = .false. +#endif /* COMPRESS */ + +! HDF5 object identifiers +! + integer(hid_t) :: sid, pid, did + +! procedure return value +! + integer :: iret + +! subroutine name string +! + character(len=*), parameter :: fname = "io::write_4d_array_integer_h5" +! +!------------------------------------------------------------------------------- +! +! create a space for the array +! + call h5screate_simple_f(4, dm(1:4), sid, iret) + +! check if the space has been created successfuly, if not quit +! + if (iret < 0) then + +! print error about the problem with creating the space +! + call print_error(fname, "Cannot create space for dataset: " // trim(name)) + +! quit the subroutine +! + return + + end if + +#ifdef COMPRESS +! prepare the property object for compression +! + call h5pcreate_f(H5P_DATASET_CREATE_F, pid, iret) + +! check if the object has been created properly, if not quit +! + if (iret < 0) then + +! print error about the problem with creating the compression property +! + call print_error(fname, "Cannot create property for dataset: " & + // trim(name)) + +! quit the subroutine +! + return + + end if + +! so far ok, so turn on the compression +! + compress = .true. + +! set the chunk size +! + call h5pset_chunk_f(pid, 4, dm(1:4), iret) + +! check if the chunk size has been set properly +! + if (iret > 0) then + +! print error about the problem with setting the chunk size +! + call print_warning(fname, "Cannot set the size of the chunk!") + +! setting the size of the chunk failed, so turn off the compression +! + compress = .false. + + end if + +! set the compression algorithm +! +#ifdef DEFLATE + call h5pset_deflate_f(pid, 9, iret) +#endif /* DEFLATE */ +#ifdef SZIP + if (product(dm(1:4)) >= 32) & + call h5pset_szip_f(pid, H5_SZIP_NN_OM_F, 32, iret) +#endif /* SZIP */ + +! check if the compression algorithm has been set properly +! + if (iret > 0) then + +! print error about the problem with setting the compression method +! + call print_warning(fname, "Cannot set the compression method!") + +! setting compression method failed, so turn off the compression +! + compress = .false. + + end if + +! check if it is safe to use compression +! + if (compress) then + +! create the dataset +! + call h5dcreate_f(gid, name, H5T_NATIVE_INTEGER, sid, did, iret, pid) + + else + +! create the dataset +! + call h5dcreate_f(gid, name, H5T_NATIVE_INTEGER, sid, did, iret) + + end if +#else /* COMPRESS */ +! create the dataset +! + call h5dcreate_f(gid, name, H5T_NATIVE_INTEGER, sid, did, iret) +#endif /* COMPRESS */ + +! check if the dataset has been created successfuly +! + if (iret >= 0) then + +! write the dataset data +! + call h5dwrite_f(did, H5T_NATIVE_INTEGER, var(:,:,:,:), dm(1:4), iret, sid) + +! check if the dataset has been written successfuly +! + if (iret > 0) then + +! print error about the problem with writing down the dataset +! + call print_error(fname, "Cannot write dataset: " // trim(name)) + + end if + +! close the dataset +! + call h5dclose_f(did, iret) + +! check if the dataset has been closed successfuly +! + if (iret > 0) then + +! print error about the problem with closing the dataset +! + call print_error(fname, "Cannot close dataset: " // trim(name)) + + end if + + else + +! print error about the problem with creating the dataset +! + call print_error(fname, "Cannot create dataset: " // trim(name)) + + end if + +! release the space +! + call h5sclose_f(sid, iret) + +! check if the space has been released successfuly +! + if (iret > 0) then + +! print error about the problem with closing the space +! + call print_error(fname, "Cannot close space for dataset: " // trim(name)) + + end if + +!------------------------------------------------------------------------------- +! + end subroutine write_4d_array_integer_h5 +! +!=============================================================================== +! +! subroutine WRITE_5D_ARRAY_INTEGER_H5: +! ------------------------------------ +! +! Subroutine stores a five-dimensional integer array in a group specified by +! identifier. +! +! Arguments: +! +! gid - the HDF5 group identifier +! name - the string name describing the array +! dm - the array dimensions +! value - the array values +! +!=============================================================================== +! + subroutine write_5d_array_integer_h5(gid, name, dm, var) + +! import procedures and variables from other modules +! + use error , only : print_error, print_warning + use hdf5 , only : H5T_NATIVE_INTEGER +#ifdef COMPRESS + use hdf5 , only : H5P_DATASET_CREATE_F +#ifdef SZIP + use hdf5 , only : H5_SZIP_NN_OM_F +#endif /* SZIP */ +#endif /* COMPRESS */ + use hdf5 , only : hid_t, hsize_t + use hdf5 , only : h5screate_simple_f, h5sclose_f + use hdf5 , only : h5dcreate_f, h5dwrite_f, h5dclose_f +#ifdef COMPRESS + use hdf5 , only : h5pcreate_f, h5pset_chunk_f, h5pclose_f +#ifdef DEFLATE + use hdf5 , only : h5pset_deflate_f +#endif /* DEFLATE */ +#ifdef SZIP + use hdf5 , only : h5pset_szip_f +#endif /* SZIP */ +#endif /* COMPRESS */ + +! local variables are not implicit by default +! + implicit none + +! subroutine arguments +! + integer(hid_t) , intent(in) :: gid + character(len=*) , intent(in) :: name + integer(hsize_t), dimension(5) , intent(in) :: dm + integer(kind=4) , dimension(:,:,:,:,:), intent(in) :: var + +#ifdef COMPRESS +! test for compression +! + logical :: compress = .false. +#endif /* COMPRESS */ + +! HDF5 object identifiers +! + integer(hid_t) :: sid, pid, did + +! procedure return value +! + integer :: iret + +! subroutine name string +! + character(len=*), parameter :: fname = "io::write_5d_array_integer_h5" +! +!------------------------------------------------------------------------------- +! +! create a space for the array +! + call h5screate_simple_f(5, dm(1:5), sid, iret) + +! check if the space has been created successfuly, if not quit +! + if (iret < 0) then + +! print error about the problem with creating the space +! + call print_error(fname, "Cannot create space for dataset: " // trim(name)) + +! quit the subroutine +! + return + + end if + +#ifdef COMPRESS +! prepare the property object for compression +! + call h5pcreate_f(H5P_DATASET_CREATE_F, pid, iret) + +! check if the object has been created properly, if not quit +! + if (iret < 0) then + +! print error about the problem with creating the compression property +! + call print_error(fname, "Cannot create property for dataset: " & + // trim(name)) + +! quit the subroutine +! + return + + end if + +! so far ok, so turn on the compression +! + compress = .true. + +! set the chunk size +! + call h5pset_chunk_f(pid, 5, dm(1:5), iret) + +! check if the chunk size has been set properly +! + if (iret > 0) then + +! print error about the problem with setting the chunk size +! + call print_warning(fname, "Cannot set the size of the chunk!") + +! setting the size of the chunk failed, so turn off the compression +! + compress = .false. + + end if + +! set the compression algorithm +! +#ifdef DEFLATE + call h5pset_deflate_f(pid, 9, iret) +#endif /* DEFLATE */ +#ifdef SZIP + if (product(dm(1:5)) >= 32) & + call h5pset_szip_f(pid, H5_SZIP_NN_OM_F, 32, iret) +#endif /* SZIP */ + +! check if the compression algorithm has been set properly +! + if (iret > 0) then + +! print error about the problem with setting the compression method +! + call print_warning(fname, "Cannot set the compression method!") + +! setting compression method failed, so turn off the compression +! + compress = .false. + + end if + +! check if it is safe to use compression +! + if (compress) then + +! create the dataset +! + call h5dcreate_f(gid, name, H5T_NATIVE_INTEGER, sid, did, iret, pid) + + else + +! create the dataset +! + call h5dcreate_f(gid, name, H5T_NATIVE_INTEGER, sid, did, iret) + + end if +#else /* COMPRESS */ +! create the dataset +! + call h5dcreate_f(gid, name, H5T_NATIVE_INTEGER, sid, did, iret) +#endif /* COMPRESS */ + +! check if the dataset has been created successfuly +! + if (iret >= 0) then + +! write the dataset data +! + call h5dwrite_f(did, H5T_NATIVE_INTEGER, var(:,:,:,:,:), dm(1:5) & + , iret, sid) + +! check if the dataset has been written successfuly +! + if (iret > 0) then + +! print error about the problem with writing down the dataset +! + call print_error(fname, "Cannot write dataset: " // trim(name)) + + end if + +! close the dataset +! + call h5dclose_f(did, iret) + +! check if the dataset has been closed successfuly +! + if (iret > 0) then + +! print error about the problem with closing the dataset +! + call print_error(fname, "Cannot close dataset: " // trim(name)) + + end if + + else + +! print error about the problem with creating the dataset +! + call print_error(fname, "Cannot create dataset: " // trim(name)) + + end if + +! release the space +! + call h5sclose_f(sid, iret) + +! check if the space has been released successfuly +! + if (iret > 0) then + +! print error about the problem with closing the space +! + call print_error(fname, "Cannot close space for dataset: " // trim(name)) + + end if + +!------------------------------------------------------------------------------- +! + end subroutine write_5d_array_integer_h5 +! +!=============================================================================== +! +! subroutine WRITE_1D_ARRAY_DOUBLE_H5: +! ----------------------------------- +! +! Subroutine stores a one-dimensional double precision array in a group +! specified by identifier. +! +! Arguments: +! +! gid - the HDF5 group identifier +! name - the string name describing the array +! dm - the array dimensions +! value - the array values +! +!=============================================================================== +! + subroutine write_1d_array_double_h5(gid, name, ln, var) + +! import procedures and variables from other modules +! + use error , only : print_error, print_warning + use hdf5 , only : H5T_NATIVE_DOUBLE +#ifdef COMPRESS + use hdf5 , only : H5P_DATASET_CREATE_F +#ifdef SZIP + use hdf5 , only : H5_SZIP_NN_OM_F +#endif /* SZIP */ +#endif /* COMPRESS */ + use hdf5 , only : hid_t, hsize_t + use hdf5 , only : h5screate_simple_f, h5sclose_f + use hdf5 , only : h5dcreate_f, h5dwrite_f, h5dclose_f +#ifdef COMPRESS + use hdf5 , only : h5pcreate_f, h5pset_chunk_f, h5pclose_f +#ifdef DEFLATE + use hdf5 , only : h5pset_deflate_f +#endif /* DEFLATE */ +#ifdef SZIP + use hdf5 , only : h5pset_szip_f +#endif /* SZIP */ +#endif /* COMPRESS */ + +! local variables are not implicit by default +! + implicit none + +! subroutine arguments +! + integer(hid_t) , intent(in) :: gid + character(len=*) , intent(in) :: name + integer(hsize_t) , intent(in) :: ln + real(kind=8) , dimension(:), intent(in) :: var + +#ifdef COMPRESS +! test for compression +! + logical :: compress = .false. +#endif /* COMPRESS */ + +! HDF5 object identifiers +! + integer(hid_t) :: sid, pid, did + +! array dimensions +! + integer(hsize_t), dimension(1) :: dm + +! procedure return value +! + integer :: iret + +! subroutine name string +! + character(len=*), parameter :: fname = "io::write_1d_array_double_h5" +! +!------------------------------------------------------------------------------- +! +! substitute array dimensions +! + dm(1) = ln + +! create a space for the array +! + call h5screate_simple_f(1, dm(1:1), sid, iret) + +! check if the space has been created successfuly, if not quit +! + if (iret < 0) then + +! print error about the problem with creating the space +! + call print_error(fname, "Cannot create space for dataset: " // trim(name)) + +! quit the subroutine +! + return + + end if + +#ifdef COMPRESS +! prepare the property object for compression +! + call h5pcreate_f(H5P_DATASET_CREATE_F, pid, iret) + +! check if the object has been created properly, if not quit +! + if (iret < 0) then + +! print error about the problem with creating the compression property +! + call print_error(fname, "Cannot create property for dataset: " & + // trim(name)) + +! quit the subroutine +! + return + + end if + +! so far ok, so turn on the compression +! + compress = .true. + +! set the chunk size +! + call h5pset_chunk_f(pid, 1, dm(1:1), iret) + +! check if the chunk size has been set properly +! + if (iret > 0) then + +! print error about the problem with setting the chunk size +! + call print_warning(fname, "Cannot set the size of the chunk!") + +! setting the size of the chunk failed, so turn off the compression +! + compress = .false. + + end if + +! set the compression algorithm +! +#ifdef DEFLATE + call h5pset_deflate_f(pid, 9, iret) +#endif /* DEFLATE */ +#ifdef SZIP + if (dm >= 32) call h5pset_szip_f(pid, H5_SZIP_NN_OM_F, 32, iret) +#endif /* SZIP */ + +! check if the compression algorithm has been set properly +! + if (iret > 0) then + +! print error about the problem with setting the compression method +! + call print_warning(fname, "Cannot set the compression method!") + +! setting compression method failed, so turn off the compression +! + compress = .false. + + end if + +! check if it is safe to use compression +! + if (compress) then + +! create the dataset +! + call h5dcreate_f(gid, name, H5T_NATIVE_DOUBLE, sid, did, iret, pid) + + else + +! create the dataset +! + call h5dcreate_f(gid, name, H5T_NATIVE_DOUBLE, sid, did, iret) + + end if +#else /* COMPRESS */ +! create the dataset +! + call h5dcreate_f(gid, name, H5T_NATIVE_DOUBLE, sid, did, iret) +#endif /* COMPRESS */ + +! check if the dataset has been created successfuly +! + if (iret >= 0) then + +! write the dataset data +! + call h5dwrite_f(did, H5T_NATIVE_DOUBLE, var(:), dm(1:1), iret, sid) + +! check if the dataset has been written successfuly +! + if (iret > 0) then + +! print error about the problem with writing down the dataset +! + call print_error(fname, "Cannot write dataset: " // trim(name)) + + end if + +! close the dataset +! + call h5dclose_f(did, iret) + +! check if the dataset has been closed successfuly +! + if (iret > 0) then + +! print error about the problem with closing the dataset +! + call print_error(fname, "Cannot close dataset: " // trim(name)) + + end if + + else + +! print error about the problem with creating the dataset +! + call print_error(fname, "Cannot create dataset: " // trim(name)) + + end if + +! release the space +! + call h5sclose_f(sid, iret) + +! check if the space has been released successfuly +! + if (iret > 0) then + +! print error about the problem with closing the space +! + call print_error(fname, "Cannot close space for dataset: " // trim(name)) + + end if + +!------------------------------------------------------------------------------- +! + end subroutine write_1d_array_double_h5 +! +!=============================================================================== +! +! subroutine WRITE_2D_ARRAY_DOUBLE_H5: +! ------------------------------------ +! +! Subroutine stores a two-dimensional double precision array in a group +! specified by identifier. +! +! Arguments: +! +! gid - the HDF5 group identifier +! name - the string name describing the array +! dm - the array dimensions +! value - the array values +! +!=============================================================================== +! + subroutine write_2d_array_double_h5(gid, name, dm, var) + +! import procedures and variables from other modules +! + use error , only : print_error, print_warning + use hdf5 , only : H5T_NATIVE_DOUBLE +#ifdef COMPRESS + use hdf5 , only : H5P_DATASET_CREATE_F +#ifdef SZIP + use hdf5 , only : H5_SZIP_NN_OM_F +#endif /* SZIP */ +#endif /* COMPRESS */ + use hdf5 , only : hid_t, hsize_t + use hdf5 , only : h5screate_simple_f, h5sclose_f + use hdf5 , only : h5dcreate_f, h5dwrite_f, h5dclose_f +#ifdef COMPRESS + use hdf5 , only : h5pcreate_f, h5pset_chunk_f, h5pclose_f +#ifdef DEFLATE + use hdf5 , only : h5pset_deflate_f +#endif /* DEFLATE */ +#ifdef SZIP + use hdf5 , only : h5pset_szip_f +#endif /* SZIP */ +#endif /* COMPRESS */ + +! local variables are not implicit by default +! + implicit none + +! subroutine arguments +! + integer(hid_t) , intent(in) :: gid + character(len=*) , intent(in) :: name + integer(hsize_t), dimension(2) , intent(in) :: dm + real(kind=8) , dimension(:,:), intent(in) :: var + +#ifdef COMPRESS +! test for compression +! + logical :: compress = .false. +#endif /* COMPRESS */ + +! HDF5 object identifiers +! + integer(hid_t) :: sid, pid, did + +! procedure return value +! + integer :: iret + +! subroutine name string +! + character(len=*), parameter :: fname = "io::write_2d_array_double_h5" +! +!------------------------------------------------------------------------------- +! +! create a space for the array +! + call h5screate_simple_f(2, dm(1:2), sid, iret) + +! check if the space has been created successfuly, if not quit +! + if (iret < 0) then + +! print error about the problem with creating the space +! + call print_error(fname, "Cannot create space for dataset: " // trim(name)) + +! quit the subroutine +! + return + + end if + +#ifdef COMPRESS +! prepare the property object for compression +! + call h5pcreate_f(H5P_DATASET_CREATE_F, pid, iret) + +! check if the object has been created properly, if not quit +! + if (iret < 0) then + +! print error about the problem with creating the compression property +! + call print_error(fname, "Cannot create property for dataset: " & + // trim(name)) + +! quit the subroutine +! + return + + end if + +! so far ok, so turn on the compression +! + compress = .true. + +! set the chunk size +! + call h5pset_chunk_f(pid, 2, dm(1:2), iret) + +! check if the chunk size has been set properly +! + if (iret > 0) then + +! print error about the problem with setting the chunk size +! + call print_warning(fname, "Cannot set the size of the chunk!") + +! setting the size of the chunk failed, so turn off the compression +! + compress = .false. + + end if + +! set the compression algorithm +! +#ifdef DEFLATE + call h5pset_deflate_f(pid, 9, iret) +#endif /* DEFLATE */ +#ifdef SZIP + if (product(dm(1:2)) >= 32) & + call h5pset_szip_f(pid, H5_SZIP_NN_OM_F, 32, iret) +#endif /* SZIP */ + +! check if the compression algorithm has been set properly +! + if (iret > 0) then + +! print error about the problem with setting the compression method +! + call print_warning(fname, "Cannot set the compression method!") + +! setting compression method failed, so turn off the compression +! + compress = .false. + + end if + +! check if it is safe to use compression +! + if (compress) then + +! create the dataset +! + call h5dcreate_f(gid, name, H5T_NATIVE_DOUBLE, sid, did, iret, pid) + + else + +! create the dataset +! + call h5dcreate_f(gid, name, H5T_NATIVE_DOUBLE, sid, did, iret) + + end if +#else /* COMPRESS */ +! create the dataset +! + call h5dcreate_f(gid, name, H5T_NATIVE_DOUBLE, sid, did, iret) +#endif /* COMPRESS */ + +! check if the dataset has been created successfuly +! + if (iret >= 0) then + +! write the dataset data +! + call h5dwrite_f(did, H5T_NATIVE_DOUBLE, var(:,:), dm(1:2), iret, sid) + +! check if the dataset has been written successfuly +! + if (iret > 0) then + +! print error about the problem with writing down the dataset +! + call print_error(fname, "Cannot write dataset: " // trim(name)) + + end if + +! close the dataset +! + call h5dclose_f(did, iret) + +! check if the dataset has been closed successfuly +! + if (iret > 0) then + +! print error about the problem with closing the dataset +! + call print_error(fname, "Cannot close dataset: " // trim(name)) + + end if + + else + +! print error about the problem with creating the dataset +! + call print_error(fname, "Cannot create dataset: " // trim(name)) + + end if + +! release the space +! + call h5sclose_f(sid, iret) + +! check if the space has been released successfuly +! + if (iret > 0) then + +! print error about the problem with closing the space +! + call print_error(fname, "Cannot close space for dataset: " // trim(name)) + + end if + +!------------------------------------------------------------------------------- +! + end subroutine write_2d_array_double_h5 +! +!=============================================================================== +! +! subroutine WRITE_3D_ARRAY_DOUBLE_H5: +! ----------------------------------- +! +! Subroutine stores a three-dimensional double precision array in a group +! specified by identifier. +! +! Arguments: +! +! gid - the HDF5 group identifier +! name - the string name describing the array +! dm - the array dimensions +! value - the array values +! +!=============================================================================== +! + subroutine write_3d_array_double_h5(gid, name, dm, var) + +! import procedures and variables from other modules +! + use error , only : print_error, print_warning + use hdf5 , only : H5T_NATIVE_DOUBLE +#ifdef COMPRESS + use hdf5 , only : H5P_DATASET_CREATE_F +#ifdef SZIP + use hdf5 , only : H5_SZIP_NN_OM_F +#endif /* SZIP */ +#endif /* COMPRESS */ + use hdf5 , only : hid_t, hsize_t + use hdf5 , only : h5screate_simple_f, h5sclose_f + use hdf5 , only : h5dcreate_f, h5dwrite_f, h5dclose_f +#ifdef COMPRESS + use hdf5 , only : h5pcreate_f, h5pset_chunk_f, h5pclose_f +#ifdef DEFLATE + use hdf5 , only : h5pset_deflate_f +#endif /* DEFLATE */ +#ifdef SZIP + use hdf5 , only : h5pset_szip_f +#endif /* SZIP */ +#endif /* COMPRESS */ + +! local variables are not implicit by default +! + implicit none + +! subroutine arguments +! + integer(hid_t) , intent(in) :: gid + character(len=*) , intent(in) :: name + integer(hsize_t), dimension(3) , intent(in) :: dm + real(kind=8) , dimension(:,:,:), intent(in) :: var + +#ifdef COMPRESS +! test for compression +! + logical :: compress = .false. +#endif /* COMPRESS */ + +! HDF5 object identifiers +! + integer(hid_t) :: sid, pid, did + +! procedure return value +! + integer :: iret + +! subroutine name string +! + character(len=*), parameter :: fname = "io::write_3d_array_double_h5" +! +!------------------------------------------------------------------------------- +! +! create a space for the array +! + call h5screate_simple_f(3, dm(1:3), sid, iret) + +! check if the space has been created successfuly, if not quit +! + if (iret < 0) then + +! print error about the problem with creating the space +! + call print_error(fname, "Cannot create space for dataset: " // trim(name)) + +! quit the subroutine +! + return + + end if + +#ifdef COMPRESS +! prepare the property object for compression +! + call h5pcreate_f(H5P_DATASET_CREATE_F, pid, iret) + +! check if the object has been created properly, if not quit +! + if (iret < 0) then + +! print error about the problem with creating the compression property +! + call print_error(fname, "Cannot create property for dataset: " & + // trim(name)) + +! quit the subroutine +! + return + + end if + +! so far ok, so turn on the compression +! + compress = .true. + +! set the chunk size +! + call h5pset_chunk_f(pid, 3, dm(1:3), iret) + +! check if the chunk size has been set properly +! + if (iret > 0) then + +! print error about the problem with setting the chunk size +! + call print_warning(fname, "Cannot set the size of the chunk!") + +! setting the size of the chunk failed, so turn off the compression +! + compress = .false. + + end if + +! set the compression algorithm +! +#ifdef DEFLATE + call h5pset_deflate_f(pid, 9, iret) +#endif /* DEFLATE */ +#ifdef SZIP + if (product(dm(1:3)) >= 32) & + call h5pset_szip_f(pid, H5_SZIP_NN_OM_F, 32, iret) +#endif /* SZIP */ + +! check if the compression algorithm has been set properly +! + if (iret > 0) then + +! print error about the problem with setting the compression method +! + call print_warning(fname, "Cannot set the compression method!") + +! setting compression method failed, so turn off the compression +! + compress = .false. + + end if + +! check if it is safe to use compression +! + if (compress) then + +! create the dataset +! + call h5dcreate_f(gid, name, H5T_NATIVE_DOUBLE, sid, did, iret, pid) + + else + +! create the dataset +! + call h5dcreate_f(gid, name, H5T_NATIVE_DOUBLE, sid, did, iret) + + end if +#else /* COMPRESS */ +! create the dataset +! + call h5dcreate_f(gid, name, H5T_NATIVE_DOUBLE, sid, did, iret) +#endif /* COMPRESS */ + +! check if the dataset has been created successfuly +! + if (iret >= 0) then + +! write the dataset data +! + call h5dwrite_f(did, H5T_NATIVE_DOUBLE, var(:,:,:), dm(1:3), iret, sid) + +! check if the dataset has been written successfuly +! + if (iret > 0) then + +! print error about the problem with writing down the dataset +! + call print_error(fname, "Cannot write dataset: " // trim(name)) + + end if + +! close the dataset +! + call h5dclose_f(did, iret) + +! check if the dataset has been closed successfuly +! + if (iret > 0) then + +! print error about the problem with closing the dataset +! + call print_error(fname, "Cannot close dataset: " // trim(name)) + + end if + + else + +! print error about the problem with creating the dataset +! + call print_error(fname, "Cannot create dataset: " // trim(name)) + + end if + +! release the space +! + call h5sclose_f(sid, iret) + +! check if the space has been released successfuly +! + if (iret > 0) then + +! print error about the problem with closing the space +! + call print_error(fname, "Cannot close space for dataset: " // trim(name)) + + end if + +!------------------------------------------------------------------------------- +! + end subroutine write_3d_array_double_h5 +! +!=============================================================================== +! +! subroutine WRITE_4D_ARRAY_DOUBLE_H5: +! ------------------------------------ +! +! Subroutine stores a four-dimensional double precision array in a group +! specified by identifier. +! +! Arguments: +! +! gid - the HDF5 group identifier +! name - the string name describing the array +! dm - the array dimensions +! value - the array values +! +!=============================================================================== +! + subroutine write_4d_array_double_h5(gid, name, dm, var) + +! import procedures and variables from other modules +! + use error , only : print_error, print_warning + use hdf5 , only : H5T_NATIVE_DOUBLE +#ifdef COMPRESS + use hdf5 , only : H5P_DATASET_CREATE_F +#ifdef SZIP + use hdf5 , only : H5_SZIP_NN_OM_F +#endif /* SZIP */ +#endif /* COMPRESS */ + use hdf5 , only : hid_t, hsize_t + use hdf5 , only : h5screate_simple_f, h5sclose_f + use hdf5 , only : h5dcreate_f, h5dwrite_f, h5dclose_f +#ifdef COMPRESS + use hdf5 , only : h5pcreate_f, h5pset_chunk_f, h5pclose_f +#ifdef DEFLATE + use hdf5 , only : h5pset_deflate_f +#endif /* DEFLATE */ +#ifdef SZIP + use hdf5 , only : h5pset_szip_f +#endif /* SZIP */ +#endif /* COMPRESS */ + +! local variables are not implicit by default +! + implicit none + +! subroutine arguments +! + integer(hid_t) , intent(in) :: gid + character(len=*) , intent(in) :: name + integer(hsize_t), dimension(4) , intent(in) :: dm + real(kind=8) , dimension(:,:,:,:), intent(in) :: var + +#ifdef COMPRESS +! test for compression +! + logical :: compress = .false. +#endif /* COMPRESS */ + +! HDF5 object identifiers +! + integer(hid_t) :: sid, pid, did + +! procedure return value +! + integer :: iret + +! subroutine name string +! + character(len=*), parameter :: fname = "io::write_4d_array_double_h5" +! +!------------------------------------------------------------------------------- +! +! create a space for the array +! + call h5screate_simple_f(4, dm(1:4), sid, iret) + +! check if the space has been created successfuly, if not quit +! + if (iret < 0) then + +! print error about the problem with creating the space +! + call print_error(fname, "Cannot create space for dataset: " // trim(name)) + +! quit the subroutine +! + return + + end if + +#ifdef COMPRESS +! prepare the property object for compression +! + call h5pcreate_f(H5P_DATASET_CREATE_F, pid, iret) + +! check if the object has been created properly, if not quit +! + if (iret < 0) then + +! print error about the problem with creating the compression property +! + call print_error(fname, "Cannot create property for dataset: " & + // trim(name)) + +! quit the subroutine +! + return + + end if + +! so far ok, so turn on the compression +! + compress = .true. + +! set the chunk size +! + call h5pset_chunk_f(pid, 4, dm(1:4), iret) + +! check if the chunk size has been set properly +! + if (iret > 0) then + +! print error about the problem with setting the chunk size +! + call print_warning(fname, "Cannot set the size of the chunk!") + +! setting the size of the chunk failed, so turn off the compression +! + compress = .false. + + end if + +! set the compression algorithm +! +#ifdef DEFLATE + call h5pset_deflate_f(pid, 9, iret) +#endif /* DEFLATE */ +#ifdef SZIP + if (product(dm(1:4)) >= 32) & + call h5pset_szip_f(pid, H5_SZIP_NN_OM_F, 32, iret) +#endif /* SZIP */ + +! check if the compression algorithm has been set properly +! + if (iret > 0) then + +! print error about the problem with setting the compression method +! + call print_warning(fname, "Cannot set the compression method!") + +! setting compression method failed, so turn off the compression +! + compress = .false. + + end if + +! check if it is safe to use compression +! + if (compress) then + +! create the dataset +! + call h5dcreate_f(gid, name, H5T_NATIVE_DOUBLE, sid, did, iret, pid) + + else + +! create the dataset +! + call h5dcreate_f(gid, name, H5T_NATIVE_DOUBLE, sid, did, iret) + + end if +#else /* COMPRESS */ +! create the dataset +! + call h5dcreate_f(gid, name, H5T_NATIVE_DOUBLE, sid, did, iret) +#endif /* COMPRESS */ + +! check if the dataset has been created successfuly +! + if (iret >= 0) then + +! write the dataset data +! + call h5dwrite_f(did, H5T_NATIVE_DOUBLE, var(:,:,:,:), dm(1:4), iret, sid) + +! check if the dataset has been written successfuly +! + if (iret > 0) then + +! print error about the problem with writing down the dataset +! + call print_error(fname, "Cannot write dataset: " // trim(name)) + + end if + +! close the dataset +! + call h5dclose_f(did, iret) + +! check if the dataset has been closed successfuly +! + if (iret > 0) then + +! print error about the problem with closing the dataset +! + call print_error(fname, "Cannot close dataset: " // trim(name)) + + end if + + else + +! print error about the problem with creating the dataset +! + call print_error(fname, "Cannot create dataset: " // trim(name)) + + end if + +! release the space +! + call h5sclose_f(sid, iret) + +! check if the space has been released successfuly +! + if (iret > 0) then + +! print error about the problem with closing the space +! + call print_error(fname, "Cannot close space for dataset: " // trim(name)) + + end if + +!------------------------------------------------------------------------------- +! + end subroutine write_4d_array_double_h5 +! +!=============================================================================== +! +! subroutine WRITE_5D_ARRAY_DOUBLE_H5: +! ----------------------------------- +! +! Subroutine stores a five-dimensional double precision array in a group +! specified by identifier. +! +! Arguments: +! +! gid - the HDF5 group identifier +! name - the string name describing the array +! dm - the array dimensions +! value - the array values +! +!=============================================================================== +! + subroutine write_5d_array_double_h5(gid, name, dm, var) + +! import procedures and variables from other modules +! + use error , only : print_error, print_warning + use hdf5 , only : H5T_NATIVE_DOUBLE +#ifdef COMPRESS + use hdf5 , only : H5P_DATASET_CREATE_F +#ifdef SZIP + use hdf5 , only : H5_SZIP_NN_OM_F +#endif /* SZIP */ +#endif /* COMPRESS */ + use hdf5 , only : hid_t, hsize_t + use hdf5 , only : h5screate_simple_f, h5sclose_f + use hdf5 , only : h5dcreate_f, h5dwrite_f, h5dclose_f +#ifdef COMPRESS + use hdf5 , only : h5pcreate_f, h5pset_chunk_f, h5pclose_f +#ifdef DEFLATE + use hdf5 , only : h5pset_deflate_f +#endif /* DEFLATE */ +#ifdef SZIP + use hdf5 , only : h5pset_szip_f +#endif /* SZIP */ +#endif /* COMPRESS */ + +! local variables are not implicit by default +! + implicit none + +! subroutine arguments +! + integer(hid_t) , intent(in) :: gid + character(len=*) , intent(in) :: name + integer(hsize_t), dimension(5) , intent(in) :: dm + real(kind=8) , dimension(:,:,:,:,:), intent(in) :: var + +#ifdef COMPRESS +! test for compression +! + logical :: compress = .false. +#endif /* COMPRESS */ + +! HDF5 object identifiers +! + integer(hid_t) :: sid, pid, did + +! procedure return value +! + integer :: iret + +! subroutine name string +! + character(len=*), parameter :: fname = "io::write_5d_array_double_h5" +! +!------------------------------------------------------------------------------- +! +! create a space for the array +! + call h5screate_simple_f(5, dm(1:5), sid, iret) + +! check if the space has been created successfuly, if not quit +! + if (iret < 0) then + +! print error about the problem with creating the space +! + call print_error(fname, "Cannot create space for dataset: " // trim(name)) + +! quit the subroutine +! + return + + end if + +#ifdef COMPRESS +! prepare the property object for compression +! + call h5pcreate_f(H5P_DATASET_CREATE_F, pid, iret) + +! check if the object has been created properly, if not quit +! + if (iret < 0) then + +! print error about the problem with creating the compression property +! + call print_error(fname, "Cannot create property for dataset: " & + // trim(name)) + +! quit the subroutine +! + return + + end if + +! so far ok, so turn on the compression +! + compress = .true. + +! set the chunk size +! + call h5pset_chunk_f(pid, 5, dm(1:5), iret) + +! check if the chunk size has been set properly +! + if (iret > 0) then + +! print error about the problem with setting the chunk size +! + call print_warning(fname, "Cannot set the size of the chunk!") + +! setting the size of the chunk failed, so turn off the compression +! + compress = .false. + + end if + +! set the compression algorithm +! +#ifdef DEFLATE + call h5pset_deflate_f(pid, 9, iret) +#endif /* DEFLATE */ +#ifdef SZIP + if (product(dm(1:5)) >= 32) & + call h5pset_szip_f(pid, H5_SZIP_NN_OM_F, 32, iret) +#endif /* SZIP */ + +! check if the compression algorithm has been set properly +! + if (iret > 0) then + +! print error about the problem with setting the compression method +! + call print_warning(fname, "Cannot set the compression method!") + +! setting compression method failed, so turn off the compression +! + compress = .false. + + end if + +! check if it is safe to use compression +! + if (compress) then + +! create the dataset +! + call h5dcreate_f(gid, name, H5T_NATIVE_DOUBLE, sid, did, iret, pid) + + else + +! create the dataset +! + call h5dcreate_f(gid, name, H5T_NATIVE_DOUBLE, sid, did, iret) + + end if +#else /* COMPRESS */ +! create the dataset +! + call h5dcreate_f(gid, name, H5T_NATIVE_DOUBLE, sid, did, iret) +#endif /* COMPRESS */ + +! check if the dataset has been created successfuly +! + if (iret >= 0) then + +! write the dataset data +! + call h5dwrite_f(did, H5T_NATIVE_DOUBLE, var(:,:,:,:,:), dm(1:5) & + , iret, sid) + +! check if the dataset has been written successfuly +! + if (iret > 0) then + +! print error about the problem with writing down the dataset +! + call print_error(fname, "Cannot write dataset: " // trim(name)) + + end if + +! close the dataset +! + call h5dclose_f(did, iret) + +! check if the dataset has been closed successfuly +! + if (iret > 0) then + +! print error about the problem with closing the dataset +! + call print_error(fname, "Cannot close dataset: " // trim(name)) + + end if + + else + +! print error about the problem with creating the dataset +! + call print_error(fname, "Cannot create dataset: " // trim(name)) + + end if + +! release the space +! + call h5sclose_f(sid, iret) + +! check if the space has been released successfuly +! + if (iret > 0) then + +! print error about the problem with closing the space +! + call print_error(fname, "Cannot close space for dataset: " // trim(name)) + + end if + +!------------------------------------------------------------------------------- +! + end subroutine write_5d_array_double_h5 #endif /* HDF5 */ !=============================================================================== From aae27192dfd9eb4482cf8a1e27b90ca9a2050214 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 22 Jul 2014 16:02:50 -0300 Subject: [PATCH 78/91] IO: Put all read subroutines in interface definition. Signed-off-by: Grzegorz Kowal --- src/io.F90 | 1483 ++++++++++++++++++++++++++++++++++++---------------- 1 file changed, 1018 insertions(+), 465 deletions(-) diff --git a/src/io.F90 b/src/io.F90 index 5b246b1..f517d5c 100644 --- a/src/io.F90 +++ b/src/io.F90 @@ -55,6 +55,20 @@ module io module procedure write_3d_array_double_h5 module procedure write_4d_array_double_h5 module procedure write_5d_array_double_h5 +#endif /* HDF5 */ + end interface + interface read_array +#ifdef HDF5 + module procedure read_1d_array_integer_h5 + module procedure read_2d_array_integer_h5 + module procedure read_3d_array_integer_h5 + module procedure read_4d_array_integer_h5 + module procedure read_5d_array_integer_h5 + module procedure read_1d_array_double_h5 + module procedure read_2d_array_double_h5 + module procedure read_3d_array_double_h5 + module procedure read_4d_array_double_h5 + module procedure read_5d_array_double_h5 #endif /* HDF5 */ end interface @@ -2302,23 +2316,23 @@ module io ! read metablock fields from the HDF5 file ! - call read_vector_integer_h5(gid, 'id' , am(:), id (:)) - call read_vector_integer_h5(gid, 'cpu' , am(:), cpu(:)) - call read_vector_integer_h5(gid, 'level' , am(:), lev(:)) - call read_vector_integer_h5(gid, 'config' , am(:), cfg(:)) - call read_vector_integer_h5(gid, 'refine' , am(:), ref(:)) - call read_vector_integer_h5(gid, 'leaf' , am(:), lea(:)) - call read_vector_integer_h5(gid, 'parent' , am(:), par(:)) - call read_vector_double_h5 (gid, 'xmin' , am(:), xmn(:)) - call read_vector_double_h5 (gid, 'xmax' , am(:), xmx(:)) - call read_vector_double_h5 (gid, 'ymin' , am(:), ymn(:)) - call read_vector_double_h5 (gid, 'ymax' , am(:), ymx(:)) - call read_vector_double_h5 (gid, 'zmin' , am(:), zmn(:)) - call read_vector_double_h5 (gid, 'zmax' , am(:), zmx(:)) - call read_array2_integer_h5(gid, 'pos' , pm(:), pos(:,:)) - call read_array2_integer_h5(gid, 'coord' , pm(:), cor(:,:)) - call read_array2_integer_h5(gid, 'child' , dm(:), chl(:,:)) - call read_array4_integer_h5(gid, 'neigh' , qm(:), ngh(:,:,:,:)) + call read_array(gid, 'id' , am(:), id (:)) + call read_array(gid, 'cpu' , am(:), cpu(:)) + call read_array(gid, 'level' , am(:), lev(:)) + call read_array(gid, 'config' , am(:), cfg(:)) + call read_array(gid, 'refine' , am(:), ref(:)) + call read_array(gid, 'leaf' , am(:), lea(:)) + call read_array(gid, 'parent' , am(:), par(:)) + call read_array(gid, 'xmin' , am(:), xmn(:)) + call read_array(gid, 'xmax' , am(:), xmx(:)) + call read_array(gid, 'ymin' , am(:), ymn(:)) + call read_array(gid, 'ymax' , am(:), ymx(:)) + call read_array(gid, 'zmin' , am(:), zmn(:)) + call read_array(gid, 'zmax' , am(:), zmx(:)) + call read_array(gid, 'pos' , pm(:), pos(:,:)) + call read_array(gid, 'coord' , pm(:), cor(:,:)) + call read_array(gid, 'child' , dm(:), chl(:,:)) + call read_array(gid, 'neigh' , qm(:), ngh(:,:,:,:)) ! check if the maximum level has been changed, is so, rescale block coordinates ! @@ -2714,9 +2728,9 @@ module io ! read array data from the HDF5 file ! - call read_vector_integer_h5(gid, 'meta', dm(1:1), id(:) ) - call read_array5_double_h5 (gid, 'uvar', dm(1:5), uv(:,:,:,:,:)) - call read_array5_double_h5 (gid, 'qvar', dm(1:5), qv(:,:,:,:,:)) + call read_array(gid, 'meta', dm(1:1), id(:) ) + call read_array(gid, 'uvar', dm(1:5), uv(:,:,:,:,:)) + call read_array(gid, 'qvar', dm(1:5), qv(:,:,:,:,:)) ! close the data block group ! @@ -3265,451 +3279,6 @@ module io !------------------------------------------------------------------------------- ! end subroutine write_conservative_variables_h5 -! -!=============================================================================== -! -! read_vector_integer_h5: subroutine reads a 1D integer vector -! -! arguments: -! gid - the HDF5 group identifier -! name - the string name representing the dataset -! length - the vector length -! value - the data -! -!=============================================================================== -! - subroutine read_vector_integer_h5(gid, name, dm, data) - -! references to other modules -! - use error, only : print_error - use hdf5 , only : hid_t, hsize_t, H5T_NATIVE_INTEGER - use hdf5 , only : h5dopen_f, h5dread_f, h5dclose_f - -! declare variables -! - implicit none - -! input variables -! - integer(hid_t) , intent(in) :: gid - character(len=*) , intent(in) :: name - integer(hsize_t), dimension(1), intent(inout) :: dm - integer(kind=4) , dimension(:), intent(inout) :: data - -! local variables -! - integer(hid_t) :: did - integer :: err -! -!------------------------------------------------------------------------------- -! -! open the dataset -! - call h5dopen_f(gid, name, did, err) - -! check if the dataset has been opened successfuly -! - if (err .ge. 0) then - -! read the dataset data -! - call h5dread_f(did, H5T_NATIVE_INTEGER, data(:), dm(:), err) - -! check if the dataset has been read successfuly -! - if (err .gt. 0) then - -! print error about the problem with reading the dataset -! - call print_error("io::read_vector_integer_h5" & - , "Cannot read dataset: " // trim(name)) - - end if - -! close the dataset -! - call h5dclose_f(did, err) - -! check if the dataset has been closed successfuly -! - if (err .gt. 0) then - -! print error about the problem with closing the dataset -! - call print_error("io::read_vector_integer_h5" & - , "Cannot close dataset: " // trim(name)) - - end if - - else - -! print error about the problem with opening the dataset -! - call print_error("io::read_vector_integer_h5" & - , "Cannot open dataset: " // trim(name)) - - end if - -!------------------------------------------------------------------------------- -! - end subroutine read_vector_integer_h5 -! -!=============================================================================== -! -! read_array2_integer_h5: subroutine reads a 2D integer array -! -! arguments: -! gid - the HDF5 group identifier -! name - the string name representing the dataset -! dm - the data dimensions -! value - the data -! -!=============================================================================== -! - subroutine read_array2_integer_h5(gid, name, dm, var) - -! references to other modules -! - use error, only : print_error - use hdf5 , only : hid_t, hsize_t, H5T_NATIVE_INTEGER - use hdf5 , only : h5dopen_f, h5dread_f, h5dclose_f - -! declare variables -! - implicit none - -! input variables -! - integer(hid_t) , intent(in) :: gid - character(len=*) , intent(in) :: name - integer(hsize_t), dimension(2) , intent(inout) :: dm - integer(kind=4) , dimension(:,:), intent(inout) :: var - -! local variables -! - integer(hid_t) :: did - integer :: err -! -!------------------------------------------------------------------------------- -! -! open the dataset -! - call h5dopen_f(gid, name, did, err) - -! check if the dataset has been opened successfuly -! - if (err .ge. 0) then - -! read dataset data -! - call h5dread_f(did, H5T_NATIVE_INTEGER, var(:,:), dm(:), err) - -! check if the dataset has been read successfuly -! - if (err .gt. 0) then - -! print error about the problem with reading the dataset -! - call print_error("io::read_array2_integer_h5" & - , "Cannot read dataset: " // trim(name)) - - end if - -! close the dataset -! - call h5dclose_f(did, err) - -! check if the dataset has been closed successfuly -! - if (err .gt. 0) then - -! print error about the problem with closing the dataset -! - call print_error("io::read_array2_integer_h5" & - , "Cannot close dataset: " // trim(name)) - - end if - - else - -! print error about the problem with opening the dataset -! - call print_error("io::read_array2_integer_h5" & - , "Cannot open dataset: " // trim(name)) - - end if - -!------------------------------------------------------------------------------- -! - end subroutine read_array2_integer_h5 -! -!=============================================================================== -! -! read_array4_integer_h5: subroutine reads a 4D integer array -! -! arguments: -! gid - the HDF5 group identifier -! name - the string name representing the dataset -! dm - the data dimensions -! value - the data -! -!=============================================================================== -! - subroutine read_array4_integer_h5(gid, name, dm, var) - -! references to other modules -! - use error, only : print_error - use hdf5 , only : hid_t, hsize_t, H5T_NATIVE_INTEGER - use hdf5 , only : h5dopen_f, h5dread_f, h5dclose_f - -! declare variables -! - implicit none - -! input variables -! - integer(hid_t) , intent(in) :: gid - character(len=*) , intent(in) :: name - integer(hsize_t), dimension(4) , intent(inout) :: dm - integer(kind=4) , dimension(:,:,:,:), intent(inout) :: var - -! local variables -! - integer(hid_t) :: did - integer :: err -! -!------------------------------------------------------------------------------- -! -! open the dataset -! - call h5dopen_f(gid, name, did, err) - -! check if the dataset has been opened successfuly -! - if (err .ge. 0) then - -! read dataset data -! - call h5dread_f(did, H5T_NATIVE_INTEGER, var(:,:,:,:), dm(:), err) - -! check if the dataset has been read successfuly -! - if (err .gt. 0) then - -! print error about the problem with reading the dataset -! - call print_error("io::read_array4_integer_h5" & - , "Cannot read dataset: " // trim(name)) - - end if - -! close the dataset -! - call h5dclose_f(did, err) - -! check if the dataset has been closed successfuly -! - if (err .gt. 0) then - -! print error about the problem with closing the dataset -! - call print_error("io::read_array4_integer_h5" & - , "Cannot close dataset: " // trim(name)) - - end if - - else - -! print error about the problem with opening the dataset -! - call print_error("io::read_array4_integer_h5" & - , "Cannot open dataset: " // trim(name)) - - end if - -!------------------------------------------------------------------------------- -! - end subroutine read_array4_integer_h5 -! -!=============================================================================== -! -! read_vector_double_h5: subroutine reads a 1D double precision vector -! -! arguments: -! gid - the HDF5 group identifier -! name - the string name representing the dataset -! dm - the vector dimensions -! value - the data -! -!=============================================================================== -! - subroutine read_vector_double_h5(gid, name, dm, data) - -! references to other modules -! - use error, only : print_error - use hdf5 , only : hid_t, hsize_t, H5T_NATIVE_DOUBLE - use hdf5 , only : h5dopen_f, h5dread_f, h5dclose_f - -! declare variables -! - implicit none - -! input variables -! - integer(hid_t) , intent(in) :: gid - character(len=*) , intent(in) :: name - integer(hsize_t), dimension(1), intent(inout) :: dm - real(kind=8) , dimension(:), intent(inout) :: data - -! local variables -! - integer(hid_t) :: did - integer :: err -! -!------------------------------------------------------------------------------- -! -! open the dataset -! - call h5dopen_f(gid, name, did, err) - -! check if the dataset has been opened successfuly -! - if (err .ge. 0) then - -! read the dataset data -! - call h5dread_f(did, H5T_NATIVE_DOUBLE, data(:), dm(:), err) - -! check if the dataset has been read successfuly -! - if (err .gt. 0) then - -! print error about the problem with reading the dataset -! - call print_error("io::read_vector_double_h5" & - , "Cannot read dataset: " // trim(name)) - - end if - -! close the dataset -! - call h5dclose_f(did, err) - -! check if the dataset has been closed successfuly -! - if (err .gt. 0) then - -! print error about the problem with closing the dataset -! - call print_error("io::read_vector_double_h5" & - , "Cannot close dataset: " // trim(name)) - - end if - - else - -! print error about the problem with opening the dataset -! - call print_error("io::read_vector_double_h5" & - , "Cannot open dataset: " // trim(name)) - - end if - -!------------------------------------------------------------------------------- -! - end subroutine read_vector_double_h5 -! -!=============================================================================== -! -! read_array5_double_h5: subroutine reads a 5D double precision array -! -! arguments: -! gid - the HDF5 group identifier -! name - the string name representing the dataset -! dm - the data dimensions -! value - the data -! -!=============================================================================== -! - subroutine read_array5_double_h5(gid, name, dm, var) - -! references to other modules -! - use error, only : print_error - use hdf5 , only : hid_t, hsize_t, H5T_NATIVE_DOUBLE - use hdf5 , only : h5dopen_f, h5dread_f, h5dclose_f - -! declare variables -! - implicit none - -! input variables -! - integer(hid_t) , intent(in) :: gid - character(len=*) , intent(in) :: name - integer(hsize_t), dimension(5) , intent(inout) :: dm - real(kind=8) , dimension(:,:,:,:,:), intent(inout) :: var - -! local variables -! - integer(hid_t) :: did - integer :: err -! -!------------------------------------------------------------------------------- -! -! open the dataset -! - call h5dopen_f(gid, name, did, err) - -! check if the dataset has been opened successfuly -! - if (err .ge. 0) then - -! read dataset -! - call h5dread_f(did, H5T_NATIVE_DOUBLE, var(:,:,:,:,:), dm(:), err) - -! check if the dataset has been read successfuly -! - if (err .gt. 0) then - -! print error about the problem with reading the dataset -! - call print_error("io::read_array5_double_h5" & - , "Cannot read dataset: " // trim(name)) - - end if - -! close the dataset -! - call h5dclose_f(did, err) - -! check if the dataset has been closed successfuly -! - if (err .gt. 0) then - -! print error about the problem with closing the dataset -! - call print_error("io::read_array5_double_h5" & - , "Cannot close dataset: " // trim(name)) - - end if - - else - -! print error about the problem with opening the dataset -! - call print_error("io::read_array5_double_h5" & - , "Cannot open dataset: " // trim(name)) - - end if - -!------------------------------------------------------------------------------- -! - end subroutine read_array5_double_h5 !=============================================================================== ! @@ -6090,6 +5659,990 @@ module io !------------------------------------------------------------------------------- ! end subroutine write_5d_array_double_h5 + +!=============================================================================== +! +! READ_ARRAY SUBROUTINES +! +!=============================================================================== +! +! subroutine READ_1D_ARRAY_INTEGER_H5: +! ----------------------------------- +! +! Subroutine restores a one-dimensional integer array from a group specified +! by identifier. +! +! Arguments: +! +! gid - the HDF5 group identifier +! name - the string name describing the array +! dm - the array dimensions +! value - the array values +! +!=============================================================================== +! + subroutine read_1d_array_integer_h5(gid, name, dm, var) + +! import procedures and variables from other modules +! + use error , only : print_error + use hdf5 , only : H5T_NATIVE_INTEGER + use hdf5 , only : hid_t, hsize_t + use hdf5 , only : h5dopen_f, h5dread_f, h5dclose_f + +! local variables are not implicit by default +! + implicit none + +! subroutine arguments +! + integer(hid_t) , intent(in) :: gid + character(len=*) , intent(in) :: name + integer(hsize_t), dimension(1), intent(inout) :: dm + integer(kind=4) , dimension(:), intent(inout) :: var + +! local variables +! + integer(hid_t) :: did + integer :: iret + +! subroutine name string +! + character(len=*), parameter :: fname = "io::read_1d_array_integer_h5" +! +!------------------------------------------------------------------------------- +! +! open the dataset +! + call h5dopen_f(gid, name, did, iret) + +! check if the dataset has been opened successfuly +! + if (iret < 0) then + +! print error about the problem with opening the data space +! + call print_error(fname, "Cannot open dataset: " // trim(name)) + +! quit the subroutine +! + return + + end if + +! read dataset data +! + call h5dread_f(did, H5T_NATIVE_INTEGER, var(:), dm(1:1), iret) + +! check if the dataset has been read successfuly +! + if (iret > 0) then + +! print error about the problem with reading the dataset +! + call print_error(fname, "Cannot read dataset: " // trim(name)) + + end if + +! close the dataset +! + call h5dclose_f(did, iret) + +! check if the dataset has been closed successfuly +! + if (iret > 0) then + +! print error about the problem with closing the dataset +! + call print_error(fname, "Cannot close dataset: " // trim(name)) + + end if + +!------------------------------------------------------------------------------- +! + end subroutine read_1d_array_integer_h5 +! +!=============================================================================== +! +! subroutine READ_2D_ARRAY_INTEGER_H5: +! ----------------------------------- +! +! Subroutine restores a two-dimensional integer array from a group specified +! by identifier. +! +! Arguments: +! +! gid - the HDF5 group identifier +! name - the string name describing the array +! dm - the array dimensions +! value - the array values +! +!=============================================================================== +! + subroutine read_2d_array_integer_h5(gid, name, dm, var) + +! import procedures and variables from other modules +! + use error , only : print_error + use hdf5 , only : H5T_NATIVE_INTEGER + use hdf5 , only : hid_t, hsize_t + use hdf5 , only : h5dopen_f, h5dread_f, h5dclose_f + +! local variables are not implicit by default +! + implicit none + +! subroutine arguments +! + integer(hid_t) , intent(in) :: gid + character(len=*) , intent(in) :: name + integer(hsize_t), dimension(2) , intent(inout) :: dm + integer(kind=4) , dimension(:,:), intent(inout) :: var + +! local variables +! + integer(hid_t) :: did + integer :: iret + +! subroutine name string +! + character(len=*), parameter :: fname = "io::read_2d_array_integer_h5" +! +!------------------------------------------------------------------------------- +! +! open the dataset +! + call h5dopen_f(gid, name, did, iret) + +! check if the dataset has been opened successfuly +! + if (iret < 0) then + +! print error about the problem with opening the data space +! + call print_error(fname, "Cannot open dataset: " // trim(name)) + +! quit the subroutine +! + return + + end if + +! read dataset data +! + call h5dread_f(did, H5T_NATIVE_INTEGER, var(:,:), dm(1:2), iret) + +! check if the dataset has been read successfuly +! + if (iret > 0) then + +! print error about the problem with reading the dataset +! + call print_error(fname, "Cannot read dataset: " // trim(name)) + + end if + +! close the dataset +! + call h5dclose_f(did, iret) + +! check if the dataset has been closed successfuly +! + if (iret > 0) then + +! print error about the problem with closing the dataset +! + call print_error(fname, "Cannot close dataset: " // trim(name)) + + end if + +!------------------------------------------------------------------------------- +! + end subroutine read_2d_array_integer_h5 +! +!=============================================================================== +! +! subroutine READ_3D_ARRAY_INTEGER_H5: +! ----------------------------------- +! +! Subroutine restores a three-dimensional integer array from a group specified +! by identifier. +! +! Arguments: +! +! gid - the HDF5 group identifier +! name - the string name describing the array +! dm - the array dimensions +! value - the array values +! +!=============================================================================== +! + subroutine read_3d_array_integer_h5(gid, name, dm, var) + +! import procedures and variables from other modules +! + use error , only : print_error + use hdf5 , only : H5T_NATIVE_INTEGER + use hdf5 , only : hid_t, hsize_t + use hdf5 , only : h5dopen_f, h5dread_f, h5dclose_f + +! local variables are not implicit by default +! + implicit none + +! subroutine arguments +! + integer(hid_t) , intent(in) :: gid + character(len=*) , intent(in) :: name + integer(hsize_t), dimension(3) , intent(inout) :: dm + integer(kind=4) , dimension(:,:,:), intent(inout) :: var + +! local variables +! + integer(hid_t) :: did + integer :: iret + +! subroutine name string +! + character(len=*), parameter :: fname = "io::read_3d_array_integer_h5" +! +!------------------------------------------------------------------------------- +! +! open the dataset +! + call h5dopen_f(gid, name, did, iret) + +! check if the dataset has been opened successfuly +! + if (iret < 0) then + +! print error about the problem with opening the data space +! + call print_error(fname, "Cannot open dataset: " // trim(name)) + +! quit the subroutine +! + return + + end if + +! read dataset data +! + call h5dread_f(did, H5T_NATIVE_INTEGER, var(:,:,:), dm(1:3), iret) + +! check if the dataset has been read successfuly +! + if (iret > 0) then + +! print error about the problem with reading the dataset +! + call print_error(fname, "Cannot read dataset: " // trim(name)) + + end if + +! close the dataset +! + call h5dclose_f(did, iret) + +! check if the dataset has been closed successfuly +! + if (iret > 0) then + +! print error about the problem with closing the dataset +! + call print_error(fname, "Cannot close dataset: " // trim(name)) + + end if + +!------------------------------------------------------------------------------- +! + end subroutine read_3d_array_integer_h5 +! +!=============================================================================== +! +! subroutine READ_4D_ARRAY_INTEGER_H5: +! ----------------------------------- +! +! Subroutine restores a four-dimensional integer array from a group specified +! by identifier. +! +! Arguments: +! +! gid - the HDF5 group identifier +! name - the string name describing the array +! dm - the array dimensions +! value - the array values +! +!=============================================================================== +! + subroutine read_4d_array_integer_h5(gid, name, dm, var) + +! import procedures and variables from other modules +! + use error , only : print_error + use hdf5 , only : H5T_NATIVE_INTEGER + use hdf5 , only : hid_t, hsize_t + use hdf5 , only : h5dopen_f, h5dread_f, h5dclose_f + +! local variables are not implicit by default +! + implicit none + +! subroutine arguments +! + integer(hid_t) , intent(in) :: gid + character(len=*) , intent(in) :: name + integer(hsize_t), dimension(4) , intent(inout) :: dm + integer(kind=4) , dimension(:,:,:,:), intent(inout) :: var + +! local variables +! + integer(hid_t) :: did + integer :: iret + +! subroutine name string +! + character(len=*), parameter :: fname = "io::read_4d_array_integer_h5" +! +!------------------------------------------------------------------------------- +! +! open the dataset +! + call h5dopen_f(gid, name, did, iret) + +! check if the dataset has been opened successfuly +! + if (iret < 0) then + +! print error about the problem with opening the data space +! + call print_error(fname, "Cannot open dataset: " // trim(name)) + +! quit the subroutine +! + return + + end if + +! read dataset data +! + call h5dread_f(did, H5T_NATIVE_INTEGER, var(:,:,:,:), dm(1:4), iret) + +! check if the dataset has been read successfuly +! + if (iret > 0) then + +! print error about the problem with reading the dataset +! + call print_error(fname, "Cannot read dataset: " // trim(name)) + + end if + +! close the dataset +! + call h5dclose_f(did, iret) + +! check if the dataset has been closed successfuly +! + if (iret > 0) then + +! print error about the problem with closing the dataset +! + call print_error(fname, "Cannot close dataset: " // trim(name)) + + end if + +!------------------------------------------------------------------------------- +! + end subroutine read_4d_array_integer_h5 +! +!=============================================================================== +! +! subroutine READ_5D_ARRAY_INTEGER_H5: +! ----------------------------------- +! +! Subroutine restores a five-dimensional integer array from a group specified +! by identifier. +! +! Arguments: +! +! gid - the HDF5 group identifier +! name - the string name describing the array +! dm - the array dimensions +! value - the array values +! +!=============================================================================== +! + subroutine read_5d_array_integer_h5(gid, name, dm, var) + +! import procedures and variables from other modules +! + use error , only : print_error + use hdf5 , only : H5T_NATIVE_INTEGER + use hdf5 , only : hid_t, hsize_t + use hdf5 , only : h5dopen_f, h5dread_f, h5dclose_f + +! local variables are not implicit by default +! + implicit none + +! subroutine arguments +! + integer(hid_t) , intent(in) :: gid + character(len=*) , intent(in) :: name + integer(hsize_t), dimension(5) , intent(inout) :: dm + integer(kind=4) , dimension(:,:,:,:,:), intent(inout) :: var + +! local variables +! + integer(hid_t) :: did + integer :: iret + +! subroutine name string +! + character(len=*), parameter :: fname = "io::read_5d_array_integer_h5" +! +!------------------------------------------------------------------------------- +! +! open the dataset +! + call h5dopen_f(gid, name, did, iret) + +! check if the dataset has been opened successfuly +! + if (iret < 0) then + +! print error about the problem with opening the data space +! + call print_error(fname, "Cannot open dataset: " // trim(name)) + +! quit the subroutine +! + return + + end if + +! read dataset data +! + call h5dread_f(did, H5T_NATIVE_INTEGER, var(:,:,:,:,:), dm(1:5), iret) + +! check if the dataset has been read successfuly +! + if (iret > 0) then + +! print error about the problem with reading the dataset +! + call print_error(fname, "Cannot read dataset: " // trim(name)) + + end if + +! close the dataset +! + call h5dclose_f(did, iret) + +! check if the dataset has been closed successfuly +! + if (iret > 0) then + +! print error about the problem with closing the dataset +! + call print_error(fname, "Cannot close dataset: " // trim(name)) + + end if + +!------------------------------------------------------------------------------- +! + end subroutine read_5d_array_integer_h5 +! +!=============================================================================== +! +! subroutine READ_1D_ARRAY_DOUBLE_H5: +! ---------------------------------- +! +! Subroutine restores a one-dimensional double precision array from a group +! specified by identifier. +! +! Arguments: +! +! gid - the HDF5 group identifier +! name - the string name describing the array +! dm - the array dimensions +! value - the array values +! +!=============================================================================== +! + subroutine read_1d_array_double_h5(gid, name, dm, var) + +! import procedures and variables from other modules +! + use error , only : print_error + use hdf5 , only : H5T_NATIVE_DOUBLE + use hdf5 , only : hid_t, hsize_t + use hdf5 , only : h5dopen_f, h5dread_f, h5dclose_f + +! local variables are not implicit by default +! + implicit none + +! subroutine arguments +! + integer(hid_t) , intent(in) :: gid + character(len=*) , intent(in) :: name + integer(hsize_t), dimension(1), intent(inout) :: dm + real(kind=8) , dimension(:), intent(inout) :: var + +! local variables +! + integer(hid_t) :: did + integer :: iret + +! subroutine name string +! + character(len=*), parameter :: fname = "io::read_1d_array_double_h5" +! +!------------------------------------------------------------------------------- +! +! open the dataset +! + call h5dopen_f(gid, name, did, iret) + +! check if the dataset has been opened successfuly +! + if (iret < 0) then + +! print error about the problem with opening the data space +! + call print_error(fname, "Cannot open dataset: " // trim(name)) + +! quit the subroutine +! + return + + end if + +! read dataset data +! + call h5dread_f(did, H5T_NATIVE_DOUBLE, var(:), dm(1:1), iret) + +! check if the dataset has been read successfuly +! + if (iret > 0) then + +! print error about the problem with reading the dataset +! + call print_error(fname, "Cannot read dataset: " // trim(name)) + + end if + +! close the dataset +! + call h5dclose_f(did, iret) + +! check if the dataset has been closed successfuly +! + if (iret > 0) then + +! print error about the problem with closing the dataset +! + call print_error(fname, "Cannot close dataset: " // trim(name)) + + end if + +!------------------------------------------------------------------------------- +! + end subroutine read_1d_array_double_h5 +! +!=============================================================================== +! +! subroutine READ_2D_ARRAY_DOUBLE_H5: +! ----------------------------------- +! +! Subroutine restores a two-dimensional double precision array from a group +! specified by identifier. +! +! Arguments: +! +! gid - the HDF5 group identifier +! name - the string name describing the array +! dm - the array dimensions +! value - the array values +! +!=============================================================================== +! + subroutine read_2d_array_double_h5(gid, name, dm, var) + +! import procedures and variables from other modules +! + use error , only : print_error + use hdf5 , only : H5T_NATIVE_DOUBLE + use hdf5 , only : hid_t, hsize_t + use hdf5 , only : h5dopen_f, h5dread_f, h5dclose_f + +! local variables are not implicit by default +! + implicit none + +! subroutine arguments +! + integer(hid_t) , intent(in) :: gid + character(len=*) , intent(in) :: name + integer(hsize_t), dimension(2) , intent(inout) :: dm + real(kind=8) , dimension(:,:), intent(inout) :: var + +! local variables +! + integer(hid_t) :: did + integer :: iret + +! subroutine name string +! + character(len=*), parameter :: fname = "io::read_2d_array_double_h5" +! +!------------------------------------------------------------------------------- +! +! open the dataset +! + call h5dopen_f(gid, name, did, iret) + +! check if the dataset has been opened successfuly +! + if (iret < 0) then + +! print error about the problem with opening the data space +! + call print_error(fname, "Cannot open dataset: " // trim(name)) + +! quit the subroutine +! + return + + end if + +! read dataset data +! + call h5dread_f(did, H5T_NATIVE_DOUBLE, var(:,:), dm(1:2), iret) + +! check if the dataset has been read successfuly +! + if (iret > 0) then + +! print error about the problem with reading the dataset +! + call print_error(fname, "Cannot read dataset: " // trim(name)) + + end if + +! close the dataset +! + call h5dclose_f(did, iret) + +! check if the dataset has been closed successfuly +! + if (iret > 0) then + +! print error about the problem with closing the dataset +! + call print_error(fname, "Cannot close dataset: " // trim(name)) + + end if + +!------------------------------------------------------------------------------- +! + end subroutine read_2d_array_double_h5 +! +!=============================================================================== +! +! subroutine READ_3D_ARRAY_DOUBLE_H5: +! ----------------------------------- +! +! Subroutine restores a three-dimensional double precision array from a group +! specified by identifier. +! +! Arguments: +! +! gid - the HDF5 group identifier +! name - the string name describing the array +! dm - the array dimensions +! value - the array values +! +!=============================================================================== +! + subroutine read_3d_array_double_h5(gid, name, dm, var) + +! import procedures and variables from other modules +! + use error , only : print_error + use hdf5 , only : H5T_NATIVE_DOUBLE + use hdf5 , only : hid_t, hsize_t + use hdf5 , only : h5dopen_f, h5dread_f, h5dclose_f + +! local variables are not implicit by default +! + implicit none + +! subroutine arguments +! + integer(hid_t) , intent(in) :: gid + character(len=*) , intent(in) :: name + integer(hsize_t), dimension(3) , intent(inout) :: dm + real(kind=8) , dimension(:,:,:), intent(inout) :: var + +! local variables +! + integer(hid_t) :: did + integer :: iret + +! subroutine name string +! + character(len=*), parameter :: fname = "io::read_3d_array_double_h5" +! +!------------------------------------------------------------------------------- +! +! open the dataset +! + call h5dopen_f(gid, name, did, iret) + +! check if the dataset has been opened successfuly +! + if (iret < 0) then + +! print error about the problem with opening the data space +! + call print_error(fname, "Cannot open dataset: " // trim(name)) + +! quit the subroutine +! + return + + end if + +! read dataset data +! + call h5dread_f(did, H5T_NATIVE_DOUBLE, var(:,:,:), dm(1:3), iret) + +! check if the dataset has been read successfuly +! + if (iret > 0) then + +! print error about the problem with reading the dataset +! + call print_error(fname, "Cannot read dataset: " // trim(name)) + + end if + +! close the dataset +! + call h5dclose_f(did, iret) + +! check if the dataset has been closed successfuly +! + if (iret > 0) then + +! print error about the problem with closing the dataset +! + call print_error(fname, "Cannot close dataset: " // trim(name)) + + end if + +!------------------------------------------------------------------------------- +! + end subroutine read_3d_array_double_h5 +! +!=============================================================================== +! +! subroutine READ_4D_ARRAY_DOUBLE_H5: +! ----------------------------------- +! +! Subroutine restores a four-dimensional double precision array from a group +! specified by identifier. +! +! Arguments: +! +! gid - the HDF5 group identifier +! name - the string name describing the array +! dm - the array dimensions +! value - the array values +! +!=============================================================================== +! + subroutine read_4d_array_double_h5(gid, name, dm, var) + +! import procedures and variables from other modules +! + use error , only : print_error + use hdf5 , only : H5T_NATIVE_DOUBLE + use hdf5 , only : hid_t, hsize_t + use hdf5 , only : h5dopen_f, h5dread_f, h5dclose_f + +! local variables are not implicit by default +! + implicit none + +! subroutine arguments +! + integer(hid_t) , intent(in) :: gid + character(len=*) , intent(in) :: name + integer(hsize_t), dimension(4) , intent(inout) :: dm + real(kind=8) , dimension(:,:,:,:), intent(inout) :: var + +! local variables +! + integer(hid_t) :: did + integer :: iret + +! subroutine name string +! + character(len=*), parameter :: fname = "io::read_4d_array_double_h5" +! +!------------------------------------------------------------------------------- +! +! open the dataset +! + call h5dopen_f(gid, name, did, iret) + +! check if the dataset has been opened successfuly +! + if (iret < 0) then + +! print error about the problem with opening the data space +! + call print_error(fname, "Cannot open dataset: " // trim(name)) + +! quit the subroutine +! + return + + end if + +! read dataset data +! + call h5dread_f(did, H5T_NATIVE_DOUBLE, var(:,:,:,:), dm(1:4), iret) + +! check if the dataset has been read successfuly +! + if (iret > 0) then + +! print error about the problem with reading the dataset +! + call print_error(fname, "Cannot read dataset: " // trim(name)) + + end if + +! close the dataset +! + call h5dclose_f(did, iret) + +! check if the dataset has been closed successfuly +! + if (iret > 0) then + +! print error about the problem with closing the dataset +! + call print_error(fname, "Cannot close dataset: " // trim(name)) + + end if + +!------------------------------------------------------------------------------- +! + end subroutine read_4d_array_double_h5 +! +!=============================================================================== +! +! subroutine READ_5D_ARRAY_DOUBLE_H5: +! ----------------------------------- +! +! Subroutine restores a five-dimensional double precision array from a group +! specified by identifier. +! +! Arguments: +! +! gid - the HDF5 group identifier +! name - the string name describing the array +! dm - the array dimensions +! value - the array values +! +!=============================================================================== +! + subroutine read_5d_array_double_h5(gid, name, dm, var) + +! import procedures and variables from other modules +! + use error , only : print_error + use hdf5 , only : H5T_NATIVE_DOUBLE + use hdf5 , only : hid_t, hsize_t + use hdf5 , only : h5dopen_f, h5dread_f, h5dclose_f + +! local variables are not implicit by default +! + implicit none + +! subroutine arguments +! + integer(hid_t) , intent(in) :: gid + character(len=*) , intent(in) :: name + integer(hsize_t), dimension(5) , intent(inout) :: dm + real(kind=8) , dimension(:,:,:,:,:), intent(inout) :: var + +! local variables +! + integer(hid_t) :: did + integer :: iret + +! subroutine name string +! + character(len=*), parameter :: fname = "io::read_5d_array_double_h5" +! +!------------------------------------------------------------------------------- +! +! open the dataset +! + call h5dopen_f(gid, name, did, iret) + +! check if the dataset has been opened successfuly +! + if (iret < 0) then + +! print error about the problem with opening the data space +! + call print_error(fname, "Cannot open dataset: " // trim(name)) + +! quit the subroutine +! + return + + end if + +! read dataset data +! + call h5dread_f(did, H5T_NATIVE_DOUBLE, var(:,:,:,:,:), dm(1:5), iret) + +! check if the dataset has been read successfuly +! + if (iret > 0) then + +! print error about the problem with reading the dataset +! + call print_error(fname, "Cannot read dataset: " // trim(name)) + + end if + +! close the dataset +! + call h5dclose_f(did, iret) + +! check if the dataset has been closed successfuly +! + if (iret > 0) then + +! print error about the problem with closing the dataset +! + call print_error(fname, "Cannot close dataset: " // trim(name)) + + end if + +!------------------------------------------------------------------------------- +! + end subroutine read_5d_array_double_h5 #endif /* HDF5 */ !=============================================================================== From 8caa16c236aaf3f7bbde8315ebd788ecce8dd160 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 22 Jul 2014 16:22:29 -0300 Subject: [PATCH 79/91] IO: Store face, edge, and corner pointers in restart file. All neighbor pointers, face, edge, and corners are stored in restart files in group 'metablocks'. Signed-off-by: Grzegorz Kowal --- src/io.F90 | 257 ++++++++++++++++++++++++++++++++++++++--------------- 1 file changed, 183 insertions(+), 74 deletions(-) diff --git a/src/io.F90 b/src/io.F90 index f517d5c..ba1b947 100644 --- a/src/io.F90 +++ b/src/io.F90 @@ -1976,42 +1976,51 @@ module io ! !=============================================================================== ! -! write_metablocks_h5: subroutine writes metablocks in the HDF5 format connected -! to the provided identifier +! subroutine WRITE_METABLOCKS_H5: +! ------------------------------ ! -! info: this subroutine stores only the metablocks +! Subroutine stores all meta blocks with their complete fields in 'metablock' +! group in a provided file identifier. ! -! arguments: -! fid - the HDF5 file identifier +! Arguments: +! +! fid - the HDF5 file identifier; ! !=============================================================================== ! subroutine write_metablocks_h5(fid) -! references to other modules +! import procedures and variables from other modules ! - use blocks , only : block_meta, list_meta - use blocks , only : get_last_id, get_mblocks, nchildren, nsides, nfaces - use error , only : print_error - use hdf5 , only : hid_t, hsize_t - use hdf5 , only : h5gcreate_f, h5gclose_f + use blocks , only : block_meta, list_meta + use blocks , only : ndims, nchildren, nsides, nfaces + use blocks , only : get_last_id, get_mblocks + use error , only : print_error + use hdf5 , only : hid_t, hsize_t + use hdf5 , only : h5gcreate_f, h5gclose_f -! declare variables +! local variables are not implicit by default ! implicit none -! input variables +! subroutine arguments ! integer(hid_t), intent(in) :: fid ! local variables ! integer(hid_t) :: gid - integer(kind=4) :: l, p, i, j, k - integer :: err + integer(kind=4) :: i, j, k, l, n, p + integer :: iret integer(hsize_t), dimension(1) :: am, cm integer(hsize_t), dimension(2) :: dm, pm integer(hsize_t), dimension(4) :: qm +#if NDIMS == 2 + integer(hsize_t), dimension(4) :: nm +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + integer(hsize_t), dimension(5) :: nm +#endif /* NDIMS == 3 */ ! local allocatable arrays ! @@ -2021,20 +2030,33 @@ module io real (kind=8), dimension(:) , allocatable :: xmn, xmx, ymn, ymx, zmn, zmx integer(kind=4), dimension(:,:), allocatable :: chl, pos, cor integer(kind=4), dimension(:,:,:,:), allocatable :: ngh +#if NDIMS == 2 + integer(kind=4), dimension(:,:,:,:) , allocatable :: edges + integer(kind=4), dimension(:,:,:) , allocatable :: corners +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + integer(kind=4), dimension(:,:,:,:,:), allocatable :: faces + integer(kind=4), dimension(:,:,:,:,:), allocatable :: edges + integer(kind=4), dimension(:,:,:,:) , allocatable :: corners +#endif /* NDIMS == 3 */ ! local pointers ! type(block_meta), pointer :: pmeta + +! subroutine name string +! + character(len=*), parameter :: fname = "io::write_metablocks_h5" ! !------------------------------------------------------------------------------- ! ! create the group for metadata ! - call h5gcreate_f(fid, 'metablocks', gid, err) + call h5gcreate_f(fid, 'metablocks', gid, iret) ! check if the group has been created successfuly ! - if (err .ge. 0) then + if (iret >= 0) then ! prepate dimensions ! @@ -2048,12 +2070,22 @@ module io qm(2) = NDIMS qm(3) = nsides qm(4) = nfaces + nm(1) = get_mblocks() + nm(2) = nsides + nm(3) = nsides +#if NDIMS == 2 + nm(4) = ndims +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + nm(4) = nsides + nm(5) = ndims +#endif /* NDIMS == 3 */ -! only process if there are some metablocks +! only store data from processes that have any meta blocks ! if (am(1) > 0) then -! allocate arrays to store metablocks data +! allocate arrays to store meta block fields ! allocate(idx(cm(1))) allocate(par(am(1))) @@ -2074,22 +2106,52 @@ module io allocate(pos(pm(1),pm(2))) allocate(cor(pm(1),pm(2))) allocate(ngh(qm(1),qm(2),qm(3),qm(4))) +#if NDIMS == 2 + allocate(edges (nm(1),nm(2),nm(3),nm(4))) + allocate(corners(nm(1),nm(2),nm(3))) +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + allocate(faces (nm(1),nm(2),nm(3),nm(4),nm(5))) + allocate(edges (nm(1),nm(2),nm(3),nm(4),nm(5))) + allocate(corners(nm(1),nm(2),nm(3),nm(4))) +#endif /* NDIMS == 3 */ -! reset vectors +! reset stored arrays ! - idx(:) = -1 - par(:) = -1 - dat(:) = -1 - lea(:) = -1 - chl(:,:) = -1 - ngh(:,:,:,:) = -1 + idx(:) = -1 + par(:) = -1 + dat(:) = -1 + lea(:) = -1 + chl(:,:) = -1 + ngh(:,:,:,:) = -1 +#if NDIMS == 2 + edges(:,:,:,:) = -1 + corners(:,:,:) = -1 +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + faces(:,:,:,:,:) = -1 + edges(:,:,:,:,:) = -1 + corners(:,:,:,:) = -1 +#endif /* NDIMS == 3 */ -! iterate over all metablocks and fill in the arrays for storage +! reset the block counter +! + l = 0 + +! associate pmeta with the first block on the meta block list ! - l = 1 pmeta => list_meta + +! iterate over all meta blocks and fill in the arrays for storage +! do while(associated(pmeta)) +! increase the block counter +! + l = l + 1 + +! store meta block fields +! idx(pmeta%id) = l if (associated(pmeta%parent)) par(l) = pmeta%parent%id @@ -2125,66 +2187,113 @@ module io end do end do - l = l + 1 +! store face, edge and corner neighbor pointers +! +#if NDIMS == 2 + do i = 1, nsides + do j = 1, nsides + do n = 1, ndims + if (associated(pmeta%edges(i,j,n)%ptr)) & + edges(l,i,j,n) = pmeta%edges(i,j,n)%ptr%id + end do ! ndims + if (associated(pmeta%corners(i,j)%ptr)) & + corners(l,i,j) = pmeta%corners(i,j)%ptr%id + end do ! i = 1, nsides + end do ! j = 1, nsides +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + do i = 1, nsides + do j = 1, nsides + do k = 1, nsides + do n = 1, ndims + if (associated(pmeta%faces(i,j,k,n)%ptr)) & + faces(l,i,j,k,n) = pmeta%faces(i,j,k,n)%ptr%id + if (associated(pmeta%edges(i,j,k,n)%ptr)) & + edges(l,i,j,k,n) = pmeta%edges(i,j,k,n)%ptr%id + end do ! ndims + if (associated(pmeta%corners(i,j,k)%ptr)) & + corners(l,i,j,k) = pmeta%corners(i,j,k)%ptr%id + end do ! i = 1, nsides + end do ! j = 1, nsides + end do ! k = 1, nsides +#endif /* NDIMS == 3 */ + +! associate pmeta with the next block on the list +! pmeta => pmeta%next - end do -! store metadata in the HDF5 file -! - call write_array(gid, 'indices', cm(1), idx) - call write_array(gid, 'parent' , am(1), par) - call write_array(gid, 'data' , am(1), dat) - call write_array(gid, 'id' , am(1), id) - call write_array(gid, 'cpu' , am(1), cpu) - call write_array(gid, 'level' , am(1), lev) - call write_array(gid, 'config' , am(1), cfg) - call write_array(gid, 'refine' , am(1), ref) - call write_array(gid, 'leaf' , am(1), lea) - call write_array(gid, 'xmin' , am(1), xmn) - call write_array(gid, 'xmax' , am(1), xmx) - call write_array(gid, 'ymin' , am(1), ymn) - call write_array(gid, 'ymax' , am(1), ymx) - call write_array(gid, 'zmin' , am(1), zmn) - call write_array(gid, 'zmax' , am(1), zmx) - call write_array(gid, 'child' , dm(:), chl(:,:)) - call write_array(gid, 'pos' , pm(:), pos(:,:)) - call write_array(gid, 'coord' , pm(:), cor(:,:)) - call write_array(gid, 'neigh' , qm(:), ngh(:,:,:,:)) + end do ! over all meta blocks -! deallocate allocatable arrays +! store meta block data in the HDF5 file ! - if (allocated(idx)) deallocate(idx) - if (allocated(par)) deallocate(par) - if (allocated(dat)) deallocate(dat) - if (allocated(id) ) deallocate(id) - if (allocated(cpu)) deallocate(cpu) - if (allocated(lev)) deallocate(lev) - if (allocated(cfg)) deallocate(cfg) - if (allocated(ref)) deallocate(ref) - if (allocated(lea)) deallocate(lea) - if (allocated(xmn)) deallocate(xmn) - if (allocated(xmx)) deallocate(xmx) - if (allocated(ymn)) deallocate(ymn) - if (allocated(ymx)) deallocate(ymx) - if (allocated(zmn)) deallocate(zmn) - if (allocated(zmx)) deallocate(zmx) - if (allocated(chl)) deallocate(chl) - if (allocated(cor)) deallocate(cor) - if (allocated(ngh)) deallocate(ngh) + call write_array(gid, 'indices', cm(1) , idx) + call write_array(gid, 'parent' , am(1) , par) + call write_array(gid, 'data' , am(1) , dat) + call write_array(gid, 'id' , am(1) , id ) + call write_array(gid, 'cpu' , am(1) , cpu) + call write_array(gid, 'level' , am(1) , lev) + call write_array(gid, 'config' , am(1) , cfg) + call write_array(gid, 'refine' , am(1) , ref) + call write_array(gid, 'leaf' , am(1) , lea) + call write_array(gid, 'xmin' , am(1) , xmn) + call write_array(gid, 'xmax' , am(1) , xmx) + call write_array(gid, 'ymin' , am(1) , ymn) + call write_array(gid, 'ymax' , am(1) , ymx) + call write_array(gid, 'zmin' , am(1) , zmn) + call write_array(gid, 'zmax' , am(1) , zmx) + call write_array(gid, 'child' , dm(:) , chl(:,:)) + call write_array(gid, 'pos' , pm(:) , pos(:,:)) + call write_array(gid, 'coord' , pm(:) , cor(:,:)) + call write_array(gid, 'neigh' , qm(:) , ngh(:,:,:,:)) +#if NDIMS == 2 + call write_array(gid, 'edges' , nm(1:4), edges(:,:,:,:)) + call write_array(gid, 'corners', nm(1:3), corners(:,:,:)) +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + call write_array(gid, 'faces' , nm(1:5), faces(:,:,:,:,:)) + call write_array(gid, 'edges' , nm(1:5), edges(:,:,:,:,:)) + call write_array(gid, 'corners', nm(1:4), corners(:,:,:,:)) +#endif /* NDIMS == 3 */ + +! deallocate allocated arrays +! + if (allocated(idx)) deallocate(idx) + if (allocated(par)) deallocate(par) + if (allocated(dat)) deallocate(dat) + if (allocated(id) ) deallocate(id) + if (allocated(cpu)) deallocate(cpu) + if (allocated(lev)) deallocate(lev) + if (allocated(cfg)) deallocate(cfg) + if (allocated(ref)) deallocate(ref) + if (allocated(lea)) deallocate(lea) + if (allocated(xmn)) deallocate(xmn) + if (allocated(xmx)) deallocate(xmx) + if (allocated(ymn)) deallocate(ymn) + if (allocated(ymx)) deallocate(ymx) + if (allocated(zmn)) deallocate(zmn) + if (allocated(zmx)) deallocate(zmx) + if (allocated(chl)) deallocate(chl) + if (allocated(cor)) deallocate(cor) + if (allocated(ngh)) deallocate(ngh) +#if NDIMS == 3 + if (allocated(faces)) deallocate(faces) +#endif /* NDIMS == 3 */ + if (allocated(edges)) deallocate(edges) + if (allocated(corners)) deallocate(corners) end if ! meta blocks > 0 ! close the group ! - call h5gclose_f(gid, err) + call h5gclose_f(gid, iret) ! check if the group has been closed successfuly ! - if (err .gt. 0) then + if (iret > 0) then ! print error about the problem with closing the group ! - call print_error("io::write_metablocks_h5", "Cannot close the group!") + call print_error(fname, "Cannot close the group!") end if @@ -2192,7 +2301,7 @@ module io ! print error about the problem with creating the group ! - call print_error("io::write_metablocks_h5", "Cannot create the group!") + call print_error(fname, "Cannot create the group!") end if From 478adea863f0a822de823416966a26d508516c49 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 22 Jul 2014 16:42:13 -0300 Subject: [PATCH 80/91] IO: Restore face, edge, and corner pointers from restart file. All neighbor pointers, face, edge, and corners are properly restored from restart files during job restart. Signed-off-by: Grzegorz Kowal --- src/io.F90 | 267 +++++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 196 insertions(+), 71 deletions(-) diff --git a/src/io.F90 b/src/io.F90 index ba1b947..eae0a28 100644 --- a/src/io.F90 +++ b/src/io.F90 @@ -2311,49 +2311,58 @@ module io ! !=============================================================================== ! -! read_metablocks_h5: subroutine reads metablocks from the restart HDF5 file -! and restores all their structure fields +! subroutine READ_METABLOCKS_H5: +! ----------------------------- ! -! info: this subroutine restores metablocks only +! Subroutine restores all meta blocks with their complete fields from +! 'metablock' group in a provided restart file identifier. ! -! arguments: -! fid - the HDF5 file identifier +! Arguments: +! +! fid - the HDF5 file identifier; ! !=============================================================================== ! subroutine read_metablocks_h5(fid) -! references to other modules +! import procedures and variables from other modules ! - use blocks , only : block_meta, list_meta - use blocks , only : nchildren, nsides, nfaces - use blocks , only : get_mblocks - use blocks , only : metablock_set_id, metablock_set_process & - , metablock_set_refinement, metablock_set_configuration & - , metablock_set_level, metablock_set_position & - , metablock_set_coordinates, metablock_set_bounds & - , metablock_set_leaf - use error , only : print_error - use hdf5 , only : hid_t, hsize_t - use hdf5 , only : h5gopen_f, h5gclose_f - use mpitools, only : nprocs + use blocks , only : block_meta, list_meta + use blocks , only : ndims, nchildren, nsides, nfaces + use blocks , only : get_mblocks + use blocks , only : metablock_set_id, metablock_set_process + use blocks , only : metablock_set_refinement + use blocks , only : metablock_set_configuration + use blocks , only : metablock_set_level, metablock_set_position + use blocks , only : metablock_set_coordinates, metablock_set_bounds + use blocks , only : metablock_set_leaf + use error , only : print_error + use hdf5 , only : hid_t, hsize_t + use hdf5 , only : h5gopen_f, h5gclose_f + use mpitools , only : nprocs -! declare variables +! local variables are not implicit by default ! implicit none -! input variables +! subroutine arguments ! integer(hid_t), intent(in) :: fid ! local variables ! integer(hid_t) :: gid - integer(kind=4) :: l, p, i, j, k, lcpu + integer(kind=4) :: i, j, k, l, p, n, ip, lcpu integer :: err integer(hsize_t), dimension(1) :: am integer(hsize_t), dimension(2) :: dm, pm integer(hsize_t), dimension(4) :: qm +#if NDIMS == 2 + integer(hsize_t), dimension(4) :: nm +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + integer(hsize_t), dimension(5) :: nm +#endif /* NDIMS == 3 */ ! local allocatable arrays ! @@ -2363,10 +2372,23 @@ module io real (kind=8), dimension(:) , allocatable :: xmn, xmx, ymn, ymx, zmn, zmx integer(kind=4), dimension(:,:), allocatable :: chl, pos, cor integer(kind=4), dimension(:,:,:,:), allocatable :: ngh +#if NDIMS == 2 + integer(kind=4), dimension(:,:,:,:) , allocatable :: edges + integer(kind=4), dimension(:,:,:) , allocatable :: corners +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + integer(kind=4), dimension(:,:,:,:,:), allocatable :: faces + integer(kind=4), dimension(:,:,:,:,:), allocatable :: edges + integer(kind=4), dimension(:,:,:,:) , allocatable :: corners +#endif /* NDIMS == 3 */ ! local pointers ! type(block_meta), pointer :: pmeta + +! subroutine name string +! + character(len=*), parameter :: fname = "io::read_metablocks_h5" ! !------------------------------------------------------------------------------- ! @@ -2380,7 +2402,7 @@ module io ! check if the group has been opened successfuly ! - if (err .ge. 0) then + if (err >= 0) then ! prepate dimensions ! @@ -2393,8 +2415,18 @@ module io qm(2) = NDIMS qm(3) = nsides qm(4) = nfaces + nm(1) = get_mblocks() + nm(2) = nsides + nm(3) = nsides +#if NDIMS == 2 + nm(4) = ndims +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + nm(4) = nsides + nm(5) = ndims +#endif /* NDIMS == 3 */ -! allocate arrays to store metablocks data +! allocate arrays to restore metablocks data ! allocate(id (am(1))) allocate(cpu(am(1))) @@ -2414,14 +2446,32 @@ module io allocate(pos(pm(1),pm(2))) allocate(cor(pm(1),pm(2))) allocate(ngh(qm(1),qm(2),qm(3),qm(4))) +#if NDIMS == 2 + allocate(edges (nm(1),nm(2),nm(3),nm(4))) + allocate(corners(nm(1),nm(2),nm(3))) +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + allocate(faces (nm(1),nm(2),nm(3),nm(4),nm(5))) + allocate(edges (nm(1),nm(2),nm(3),nm(4),nm(5))) + allocate(corners(nm(1),nm(2),nm(3),nm(4))) +#endif /* NDIMS == 3 */ ! reset vectors ! - par(:) = -1 - dat(:) = -1 - lea(:) = -1 - chl(:,:) = -1 - ngh(:,:,:,:) = -1 + par(:) = -1 + dat(:) = -1 + lea(:) = -1 + chl(:,:) = -1 + ngh(:,:,:,:) = -1 +#if NDIMS == 2 + edges(:,:,:,:) = -1 + corners(:,:,:) = -1 +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + faces(:,:,:,:,:) = -1 + edges(:,:,:,:,:) = -1 + corners(:,:,:,:) = -1 +#endif /* NDIMS == 3 */ ! read metablock fields from the HDF5 file ! @@ -2442,6 +2492,15 @@ module io call read_array(gid, 'coord' , pm(:), cor(:,:)) call read_array(gid, 'child' , dm(:), chl(:,:)) call read_array(gid, 'neigh' , qm(:), ngh(:,:,:,:)) +#if NDIMS == 2 + call read_array(gid, 'edges' , nm(1:4), edges(:,:,:,:)) + call read_array(gid, 'corners', nm(1:3), corners(:,:,:)) +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + call read_array(gid, 'faces' , nm(1:5), faces(:,:,:,:,:)) + call read_array(gid, 'edges' , nm(1:5), edges(:,:,:,:,:)) + call read_array(gid, 'corners', nm(1:4), corners(:,:,:,:)) +#endif /* NDIMS == 3 */ ! check if the maximum level has been changed, is so, rescale block coordinates ! @@ -2452,12 +2511,24 @@ module io cor(:,:) = cor(:,:) * ucor end if -! prepare the array of pointers to metablocks +! reset the block counter +! + l = 0 + +! associate pmeta with the first block on the meta block list ! - l = 1 pmeta => list_meta + +! iterate over all meta blocks and restore their fields +! do while(associated(pmeta)) +! increase the block counter +! + l = l + 1 + +! restore meta block fields +! block_array(id(l))%ptr => pmeta call metablock_set_id (pmeta, id (l)) @@ -2468,61 +2539,116 @@ module io call metablock_set_position (pmeta, pos(l,1), pos(l,2), pos(l,3)) call metablock_set_coordinates (pmeta, cor(l,1), cor(l,2), cor(l,3)) call metablock_set_bounds (pmeta, xmn(l), xmx(l), ymn(l), ymx(l) & - , zmn(l), zmx(l)) + , zmn(l), zmx(l)) - if (lea(l) .eq. 1) call metablock_set_leaf(pmeta) + if (lea(l) == 1) call metablock_set_leaf(pmeta) - l = l + 1 - pmeta => pmeta%next - end do - -! iterate over all metablocks and restore pointers +! associate pmeta with the next block on the list +! + pmeta => pmeta%next + + end do ! over all meta blocks + +! reset the block counter +! + l = 0 + +! associate pmeta with the first block on the meta block list ! - l = 1 pmeta => list_meta + +! iterate over all meta blocks and restore their pointers +! do while(associated(pmeta)) - if (par(l) .gt. 0) pmeta%parent => block_array(par(l))%ptr +! increase the block counter +! + l = l + 1 +! restore %parent pointer +! + if (par(l) > 0) pmeta%parent => block_array(par(l))%ptr + +! restore %child pointers +! do p = 1, nchildren - if (chl(l,p) .gt. 0) then + if (chl(l,p) > 0) then pmeta%child(p)%ptr => block_array(chl(l,p))%ptr end if - end do + end do ! p = 1, nchildren - do i = 1, NDIMS +! restore %neigh pointers +! + do i = 1, ndims do j = 1, nsides do k = 1, nfaces - if (ngh(l,i,j,k) .gt. 0) then - pmeta%neigh(i,j,k)%ptr => block_array(ngh(l,i,j,k))%ptr - end if - end do - end do - end do + if (ngh(l,i,j,k) > 0) & + pmeta%neigh(i,j,k)%ptr => block_array(ngh(l,i,j,k))%ptr + end do ! k = 1, nfaces + end do ! j = 1, nsides + end do ! i = 1, ndims - l = l + 1 +! restore %faces, %edges and %corners neighbor pointers +! +#if NDIMS == 2 + do i = 1, nsides + do j = 1, nsides + do n = 1, ndims + ip = edges(l,i,j,n) + if (ip > 0) pmeta%edges(i,j,n)%ptr => block_array(ip)%ptr + end do ! n = 1, ndims + ip = corners(l,i,j) + if (ip > 0) pmeta%corners(i,j)%ptr => block_array(ip)%ptr + end do ! i = 1, nsides + end do ! j = 1, nsides +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + do i = 1, nsides + do j = 1, nsides + do k = 1, nsides + do n = 1, ndims + ip = faces(l,i,j,k,n) + if (ip > 0) pmeta%faces(i,j,k,n)%ptr => block_array(ip)%ptr + ip = edges(l,i,j,k,n) + if (ip > 0) pmeta%edges(i,j,k,n)%ptr => block_array(ip)%ptr + end do ! n = 1, ndims + ip = corners(l,i,j,k) + if (ip > 0) pmeta%corners(i,j,k)%ptr => block_array(ip)%ptr + end do ! i = 1, nsides + end do ! j = 1, nsides + end do ! k = 1, nsides +#endif /* NDIMS == 3 */ + +! associate pmeta with the next block on the list +! pmeta => pmeta%next - end do + + end do ! over all meta blocks ! deallocate allocatable arrays ! - if (allocated(id) ) deallocate(id ) - if (allocated(par)) deallocate(par) - if (allocated(dat)) deallocate(dat) - if (allocated(cpu)) deallocate(cpu) - if (allocated(lev)) deallocate(lev) - if (allocated(cfg)) deallocate(cfg) - if (allocated(ref)) deallocate(ref) - if (allocated(lea)) deallocate(lea) - if (allocated(xmn)) deallocate(xmn) - if (allocated(xmx)) deallocate(xmx) - if (allocated(ymn)) deallocate(ymn) - if (allocated(ymx)) deallocate(ymx) - if (allocated(zmn)) deallocate(zmn) - if (allocated(zmx)) deallocate(zmx) - if (allocated(chl)) deallocate(chl) - if (allocated(cor)) deallocate(cor) - if (allocated(ngh)) deallocate(ngh) + if (allocated(id) ) deallocate(id ) + if (allocated(par)) deallocate(par) + if (allocated(dat)) deallocate(dat) + if (allocated(cpu)) deallocate(cpu) + if (allocated(lev)) deallocate(lev) + if (allocated(cfg)) deallocate(cfg) + if (allocated(ref)) deallocate(ref) + if (allocated(lea)) deallocate(lea) + if (allocated(xmn)) deallocate(xmn) + if (allocated(xmx)) deallocate(xmx) + if (allocated(ymn)) deallocate(ymn) + if (allocated(ymx)) deallocate(ymx) + if (allocated(zmn)) deallocate(zmn) + if (allocated(zmx)) deallocate(zmx) + if (allocated(chl)) deallocate(chl) + if (allocated(cor)) deallocate(cor) + if (allocated(ngh)) deallocate(ngh) +#if NDIMS == 3 + if (allocated(faces)) deallocate(faces) +#endif /* NDIMS == 3 */ + if (allocated(edges)) deallocate(edges) + if (allocated(corners)) deallocate(corners) ! close the group ! @@ -2530,12 +2656,11 @@ module io ! check if the group has been closed successfuly ! - if (err .gt. 0) then + if (err > 0) then ! print error about the problem with closing the group ! - call print_error("io::read_metablocks_h5" & - , "Cannot close metablock group!") + call print_error(fname, "Cannot close metablock group!") end if @@ -2543,7 +2668,7 @@ module io ! print error about the problem with opening the group ! - call print_error("io::read_metablocks_h5", "Cannot open metablock group!") + call print_error(fname, "Cannot open metablock group!") end if From 7d81648cdf9eba28c21073ac4fc95a6855d548c1 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 22 Jul 2014 22:13:48 -0300 Subject: [PATCH 81/91] IO: Put attribute subroutines in interfaces. Signed-off-by: Grzegorz Kowal --- src/io.F90 | 1501 ++++++++++++++++++++++++++++++---------------------- 1 file changed, 877 insertions(+), 624 deletions(-) diff --git a/src/io.F90 b/src/io.F90 index eae0a28..9517359 100644 --- a/src/io.F90 +++ b/src/io.F90 @@ -43,6 +43,22 @@ module io ! subroutine interfaces ! + interface write_attribute +#ifdef HDF5 + module procedure write_scalar_attribute_integer_h5 + module procedure write_scalar_attribute_double_h5 + module procedure write_vector_attribute_integer_h5 + module procedure write_vector_attribute_double_h5 +#endif /* HDF5 */ + end interface + interface read_attribute +#ifdef HDF5 + module procedure read_scalar_attribute_integer_h5 + module procedure read_scalar_attribute_double_h5 + module procedure read_vector_attribute_integer_h5 + module procedure read_vector_attribute_double_h5 +#endif /* HDF5 */ + end interface interface write_array #ifdef HDF5 module procedure write_1d_array_integer_h5 @@ -1133,38 +1149,38 @@ module io ! store the integer attributes ! - call write_attribute_integer_h5(gid, 'ndims' , NDIMS ) - call write_attribute_integer_h5(gid, 'last_id', get_last_id()) - call write_attribute_integer_h5(gid, 'mblocks', get_mblocks()) - call write_attribute_integer_h5(gid, 'dblocks', get_dblocks()) - call write_attribute_integer_h5(gid, 'nleafs' , get_nleafs() ) - call write_attribute_integer_h5(gid, 'ncells' , nn ) - call write_attribute_integer_h5(gid, 'nghost' , ng ) - call write_attribute_integer_h5(gid, 'minlev' , minlev ) - call write_attribute_integer_h5(gid, 'maxlev' , maxlev ) - call write_attribute_integer_h5(gid, 'toplev' , toplev ) - call write_attribute_integer_h5(gid, 'nprocs' , nprocs ) - call write_attribute_integer_h5(gid, 'nproc' , nproc ) - call write_attribute_integer_h5(gid, 'nseeds' , nseeds ) - call write_attribute_integer_h5(gid, 'step' , step ) - call write_attribute_integer_h5(gid, 'isnap' , isnap ) + call write_attribute(gid, 'ndims' , NDIMS ) + call write_attribute(gid, 'last_id', get_last_id()) + call write_attribute(gid, 'mblocks', get_mblocks()) + call write_attribute(gid, 'dblocks', get_dblocks()) + call write_attribute(gid, 'nleafs' , get_nleafs() ) + call write_attribute(gid, 'ncells' , nn ) + call write_attribute(gid, 'nghost' , ng ) + call write_attribute(gid, 'minlev' , minlev ) + call write_attribute(gid, 'maxlev' , maxlev ) + call write_attribute(gid, 'toplev' , toplev ) + call write_attribute(gid, 'nprocs' , nprocs ) + call write_attribute(gid, 'nproc' , nproc ) + call write_attribute(gid, 'nseeds' , nseeds ) + call write_attribute(gid, 'step' , step ) + call write_attribute(gid, 'isnap' , isnap ) ! store the real attributes ! - call write_attribute_double_h5(gid, 'xmin', xmin) - call write_attribute_double_h5(gid, 'xmax', xmax) - call write_attribute_double_h5(gid, 'ymin', ymin) - call write_attribute_double_h5(gid, 'ymax', ymax) - call write_attribute_double_h5(gid, 'zmin', zmin) - call write_attribute_double_h5(gid, 'zmax', zmax) - call write_attribute_double_h5(gid, 'time', time) - call write_attribute_double_h5(gid, 'dt' , dt ) - call write_attribute_double_h5(gid, 'dtn' , dtn ) + call write_attribute(gid, 'xmin', xmin) + call write_attribute(gid, 'xmax', xmax) + call write_attribute(gid, 'ymin', ymin) + call write_attribute(gid, 'ymax', ymax) + call write_attribute(gid, 'zmin', zmin) + call write_attribute(gid, 'zmax', zmax) + call write_attribute(gid, 'time', time) + call write_attribute(gid, 'dt' , dt ) + call write_attribute(gid, 'dtn' , dtn ) ! store the vector attributes ! - call write_attribute_vector_integer_h5(gid, 'dims' , (/ in, jn, kn /)) - call write_attribute_vector_integer_h5(gid, 'rdims', (/ ir, jr, kr /)) + call write_attribute(gid, 'dims' , (/ in, jn, kn /)) + call write_attribute(gid, 'rdims', (/ ir, jr, kr /)) ! store random number generator seed values ! @@ -1180,7 +1196,7 @@ module io ! store them in the current group ! - call write_attribute_vector_integer_h5(gid, 'seeds', seeds(:)) + call write_attribute(gid, 'seeds', seeds(:)) ! deallocate seed array ! @@ -1277,30 +1293,30 @@ module io ! restore integer attributes ! - call read_attribute_integer_h5(gid, 'ndims' , lndims ) - call read_attribute_integer_h5(gid, 'maxlev' , lmaxlev ) - call read_attribute_integer_h5(gid, 'nprocs' , nfiles ) - call read_attribute_integer_h5(gid, 'nproc' , lnproc ) - call read_attribute_integer_h5(gid, 'mblocks', lmblocks) - call read_attribute_integer_h5(gid, 'nleafs' , lnleafs ) - call read_attribute_integer_h5(gid, 'last_id', llast_id) - call read_attribute_integer_h5(gid, 'ncells' , lncells ) - call read_attribute_integer_h5(gid, 'nghost' , lnghost ) - call read_attribute_integer_h5(gid, 'nseeds' , lnseeds ) - call read_attribute_integer_h5(gid, 'step' , step ) - call read_attribute_integer_h5(gid, 'isnap' , isnap ) + call read_attribute(gid, 'ndims' , lndims ) + call read_attribute(gid, 'maxlev' , lmaxlev ) + call read_attribute(gid, 'nprocs' , nfiles ) + call read_attribute(gid, 'nproc' , lnproc ) + call read_attribute(gid, 'mblocks', lmblocks) + call read_attribute(gid, 'nleafs' , lnleafs ) + call read_attribute(gid, 'last_id', llast_id) + call read_attribute(gid, 'ncells' , lncells ) + call read_attribute(gid, 'nghost' , lnghost ) + call read_attribute(gid, 'nseeds' , lnseeds ) + call read_attribute(gid, 'step' , step ) + call read_attribute(gid, 'isnap' , isnap ) ! restore double precision attributes ! - call read_attribute_double_h5(gid, 'xmin', xmin) - call read_attribute_double_h5(gid, 'xmax', xmax) - call read_attribute_double_h5(gid, 'ymin', ymin) - call read_attribute_double_h5(gid, 'ymax', ymax) - call read_attribute_double_h5(gid, 'zmin', zmin) - call read_attribute_double_h5(gid, 'zmax', zmax) - call read_attribute_double_h5(gid, 'time', time) - call read_attribute_double_h5(gid, 'dt' , dt ) - call read_attribute_double_h5(gid, 'dtn' , dtn ) + call read_attribute(gid, 'xmin', xmin) + call read_attribute(gid, 'xmax', xmax) + call read_attribute(gid, 'ymin', ymin) + call read_attribute(gid, 'ymax', ymax) + call read_attribute(gid, 'zmin', zmin) + call read_attribute(gid, 'zmax', zmax) + call read_attribute(gid, 'time', time) + call read_attribute(gid, 'dt' , dt ) + call read_attribute(gid, 'dtn' , dtn ) ! check the number of dimensions ! @@ -1355,7 +1371,7 @@ module io ! store them in the current group ! - call read_attribute_vector_integer_h5(gid, 'seeds', seeds(:)) + call read_attribute(gid, 'seeds', seeds(:)) ! set the seed values ! @@ -1401,580 +1417,6 @@ module io end subroutine read_attributes_h5 ! !=============================================================================== -!! -!!--- ATTRIBUTE SUBROUTINES -------------------------------------------------- -!! -!=============================================================================== -! -!=============================================================================== -! -! subroutine READ_ATTRIBUTE_INTEGER_H5: -! ------------------------------------ -! -! Subroutine reads a value of the integer attribute provided by the group -! identifier to which it is linked and its name. -! -! Arguments: -! -! gid - the group identifier to which the attribute is linked; -! aname - the attribute name; -! avalue - the attribute value; -! -!=============================================================================== -! - subroutine read_attribute_integer_h5(gid, aname, avalue) - -! import external procedures and variables -! - use error , only : print_error - use hdf5 , only : hid_t, hsize_t, H5T_NATIVE_INTEGER - use hdf5 , only : h5aexists_by_name_f - use hdf5 , only : h5aopen_by_name_f, h5aread_f, h5aclose_f - -! local variables are not implicit by default -! - implicit none - -! attribute arguments -! - integer(hid_t) , intent(in) :: gid - character(len=*), intent(in) :: aname - integer , intent(inout) :: avalue - -! local variables -! - logical :: exists = .false. - integer(hid_t) :: aid - integer(hsize_t), dimension(1) :: am = (/ 1 /) - integer :: ierr -! -!------------------------------------------------------------------------------- -! -! check if the attribute exists in the group provided by gid -! - call h5aexists_by_name_f(gid, '.', aname, exists, ierr) - if (ierr /= 0) then - call print_error("io::read_attribute_integer_h5" & - , "Cannot check if attribute exists :" // trim(aname)) - return - end if - if (.not. exists) then - call print_error("io::read_attribute_integer_h5" & - , "Attribute does not exist :" // trim(aname)) - return - end if - -! open the attribute -! - call h5aopen_by_name_f(gid, '.', aname, aid, ierr) - if (ierr /= 0) then - call print_error("io::read_attribute_integer_h5" & - , "Cannot open attribute :" // trim(aname)) - return - end if - -! read attribute value -! - call h5aread_f(aid, H5T_NATIVE_INTEGER, avalue, am(:), ierr) - if (ierr /= 0) then - call print_error("io::read_attribute_integer_h5" & - , "Cannot read attribute :" // trim(aname)) - end if - -! close the attribute -! - call h5aclose_f(aid, ierr) - if (ierr /= 0) then - call print_error("io::read_attribute_integer_h5" & - , "Cannot close attribute :" // trim(aname)) - return - end if - -!------------------------------------------------------------------------------- -! - end subroutine read_attribute_integer_h5 -! -!=============================================================================== -! -! subroutine READ_ATTRIBUTE_DOUBLE_H5: -! ----------------------------------- -! -! Subroutine reads a value of the double precision attribute provided by -! the group identifier to which it is linked and its name. -! -! Arguments: -! -! gid - the group identifier to which the attribute is linked; -! aname - the attribute name; -! avalue - the attribute value; -! -!=============================================================================== -! - subroutine read_attribute_double_h5(gid, aname, avalue) - -! import external procedures and variables -! - use error , only : print_error - use hdf5 , only : hid_t, hsize_t, H5T_NATIVE_DOUBLE - use hdf5 , only : h5aexists_by_name_f - use hdf5 , only : h5aopen_by_name_f, h5aread_f, h5aclose_f - -! local variables are not implicit by default -! - implicit none - -! attribute arguments -! - integer(hid_t) , intent(in) :: gid - character(len=*), intent(in) :: aname - real(kind=8) , intent(inout) :: avalue - -! local variables -! - logical :: exists = .false. - integer(hid_t) :: aid - integer(hsize_t), dimension(1) :: am = (/ 1 /) - integer :: ierr -! -!------------------------------------------------------------------------------- -! -! check if the attribute exists in the group provided by gid -! - call h5aexists_by_name_f(gid, '.', aname, exists, ierr) - if (ierr /= 0) then - call print_error("io::read_attribute_double_h5" & - , "Cannot check if attribute exists :" // trim(aname)) - return - end if - if (.not. exists) then - call print_error("io::read_attribute_double_h5" & - , "Attribute does not exist :" // trim(aname)) - return - end if - -! open the attribute -! - call h5aopen_by_name_f(gid, '.', aname, aid, ierr) - if (ierr /= 0) then - call print_error("io::read_attribute_double_h5" & - , "Cannot open attribute :" // trim(aname)) - return - end if - -! read attribute value -! - call h5aread_f(aid, H5T_NATIVE_DOUBLE, avalue, am(:), ierr) - if (ierr /= 0) then - call print_error("io::read_attribute_double_h5" & - , "Cannot read attribute :" // trim(aname)) - end if - -! close the attribute -! - call h5aclose_f(aid, ierr) - if (ierr /= 0) then - call print_error("io::read_attribute_double_h5" & - , "Cannot close attribute :" // trim(aname)) - return - end if - -!------------------------------------------------------------------------------- -! - end subroutine read_attribute_double_h5 -! -!=============================================================================== -! -! subroutine READ_ATTRIBUTE_VECTOR_INTEGER_H5: -! ------------------------------------------- -! -! Subroutine reads a vector of the integer attribute provided by the group -! identifier to which it is linked and its name. -! -! Arguments: -! -! gid - the group identifier to which the attribute is linked; -! aname - the attribute name; -! avalue - the attribute value; -! -!=============================================================================== -! - subroutine read_attribute_vector_integer_h5(gid, aname, avalue) - -! import external procedures and variables -! - use error , only : print_error - use hdf5 , only : hid_t, hsize_t, H5T_NATIVE_INTEGER - use hdf5 , only : h5aexists_by_name_f, h5aget_space_f - use hdf5 , only : h5aopen_by_name_f, h5aread_f, h5aclose_f - use hdf5 , only : h5sclose_f, h5sget_simple_extent_dims_f - -! local variables are not implicit by default -! - implicit none - -! attribute arguments -! - integer(hid_t) , intent(in) :: gid - character(len=*) , intent(in) :: aname - integer , dimension(:), intent(inout) :: avalue - -! local variables -! - logical :: exists = .false. - integer(hid_t) :: aid, sid - integer(hsize_t), dimension(1) :: am, bm - integer(hsize_t) :: alen - integer :: ierr -! -!------------------------------------------------------------------------------- -! -! check if the attribute exists in the group provided by gid -! - call h5aexists_by_name_f(gid, '.', aname, exists, ierr) - if (ierr /= 0) then - call print_error("io::read_attribute_vector_integer_h5" & - , "Cannot check if attribute exists :" // trim(aname)) - return - end if - if (.not. exists) then - call print_error("io::read_attribute_vector_integer_h5" & - , "Attribute does not exist :" // trim(aname)) - return - end if - -! open the attribute -! - call h5aopen_by_name_f(gid, '.', aname, aid, ierr) - if (ierr /= 0) then - call print_error("io::read_attribute_vector_integer_h5" & - , "Cannot open attribute :" // trim(aname)) - return - end if - -! get the attribute space -! - call h5aget_space_f(aid, sid, ierr) - if (ierr == 0) then - call h5sget_simple_extent_dims_f(sid, am, bm, ierr) - if (ierr /= 1) then - call print_error("io::read_attribute_vector_integer_h5" & - , "Cannot get attribute dimensions :" // trim(aname)) - end if - call h5sclose_f(sid, ierr) - if (ierr /= 0) then - call print_error("io::read_attribute_vector_integer_h5" & - , "Cannot close the attribute space :" // trim(aname)) - end if - else - call print_error("io::read_attribute_vector_integer_h5" & - , "Cannot get the attribute space :" // trim(aname)) - return - end if - -! check if the output array is large enough -! - if (am(1) > size(avalue)) then - call print_error("io::read_attribute_vector_integer_h5" & - , "Attribute too large for output argument :" // trim(aname)) - return - end if - -! read attribute value -! - call h5aread_f(aid, H5T_NATIVE_INTEGER, avalue, am(:), ierr) - if (ierr /= 0) then - call print_error("io::read_attribute_vector_integer_h5" & - , "Cannot read attribute :" // trim(aname)) - end if - -! close the attribute -! - call h5aclose_f(aid, ierr) - if (ierr /= 0) then - call print_error("io::read_attribute_vector_integer_h5" & - , "Cannot close attribute :" // trim(aname)) - return - end if - -!------------------------------------------------------------------------------- -! - end subroutine read_attribute_vector_integer_h5 -! -!=============================================================================== -! -! subroutine WRITE_ATTRIBUTE_INTEGER_H5: -! ------------------------------------- -! -! Subroutine stores a value of the integer attribute in the group provided -! by an identifier and the attribute name. -! -! Arguments: -! -! gid - the group identifier to which the attribute should be linked; -! aname - the attribute name; -! avalue - the attribute value; -! -!=============================================================================== -! - subroutine write_attribute_integer_h5(gid, aname, avalue) - -! import external procedures and variables -! - use error , only : print_error - use hdf5 , only : hid_t, hsize_t, H5T_NATIVE_INTEGER - use hdf5 , only : h5screate_simple_f, h5sclose_f - use hdf5 , only : h5acreate_f, h5awrite_f, h5aclose_f - -! local variables are not implicit by default -! - implicit none - -! attribute arguments -! - integer(hid_t) , intent(in) :: gid - character(len=*), intent(in) :: aname - integer , intent(in) :: avalue - -! local variables -! - integer(hid_t) :: sid, aid - integer(hsize_t), dimension(1) :: am = (/ 1 /) - integer :: ierr -! -!------------------------------------------------------------------------------- -! -! create space for the attribute value -! - call h5screate_simple_f(1, am, sid, ierr) - if (ierr /= 0) then - call print_error("io::write_attribute_integer_h5" & - , "Cannot create space for attribute :" // trim(aname)) - return - end if - -! create the attribute in the given group -! - call h5acreate_f(gid, aname, H5T_NATIVE_INTEGER, sid, aid, ierr) - if (ierr == 0) then - -! write the attribute data -! - call h5awrite_f(aid, H5T_NATIVE_INTEGER, avalue, am, ierr) - if (ierr /= 0) then - call print_error("io::write_attribute_integer_h5" & - , "Cannot write the attribute data in :" // trim(aname)) - end if - -! close the attribute -! - call h5aclose_f(aid, ierr) - if (ierr /= 0) then - call print_error("io::write_attribute_integer_h5" & - , "Cannot close attribute :" // trim(aname)) - end if - - else - call print_error("io::write_attribute_integer_h5" & - , "Cannot create attribute :" // trim(aname)) - end if - -! release the space -! - call h5sclose_f(sid, ierr) - if (ierr /= 0) then - call print_error("io::write_attribute_integer_h5" & - , "Cannot close space for attribute :" // trim(aname)) - end if - -!------------------------------------------------------------------------------- -! - end subroutine write_attribute_integer_h5 -! -!=============================================================================== -! -! subroutine WRITE_ATTRIBUTE_DOUBLE_H5: -! ------------------------------------ -! -! Subroutine stores a value of the double precision attribute in the group -! provided by an identifier and the attribute name. -! -! Arguments: -! -! gid - the group identifier to which the attribute should be linked; -! aname - the attribute name; -! avalue - the attribute value; -! -!=============================================================================== -! - subroutine write_attribute_double_h5(gid, aname, avalue) - -! import external procedures and variables -! - use error , only : print_error - use hdf5 , only : hid_t, hsize_t, H5T_NATIVE_DOUBLE - use hdf5 , only : h5screate_simple_f, h5sclose_f - use hdf5 , only : h5acreate_f, h5awrite_f, h5aclose_f - -! local variables are not implicit by default -! - implicit none - -! attribute arguments -! - integer(hid_t) , intent(in) :: gid - character(len=*), intent(in) :: aname - real(kind=8) , intent(in) :: avalue - -! local variables -! - integer(hid_t) :: sid, aid - integer(hsize_t), dimension(1) :: am = (/ 1 /) - integer :: ierr -! -!------------------------------------------------------------------------------- -! -! create space for the attribute value -! - call h5screate_simple_f(1, am, sid, ierr) - if (ierr /= 0) then - call print_error("io::write_attribute_double_h5" & - , "Cannot create space for attribute :" // trim(aname)) - return - end if - -! create the attribute in the given group -! - call h5acreate_f(gid, aname, H5T_NATIVE_DOUBLE, sid, aid, ierr) - if (ierr == 0) then - -! write the attribute data -! - call h5awrite_f(aid, H5T_NATIVE_DOUBLE, avalue, am, ierr) - if (ierr /= 0) then - call print_error("io::write_attribute_double_h5" & - , "Cannot write the attribute data in :" // trim(aname)) - end if - -! close the attribute -! - call h5aclose_f(aid, ierr) - if (ierr /= 0) then - call print_error("io::write_attribute_double_h5" & - , "Cannot close attribute :" // trim(aname)) - end if - - else - call print_error("io::write_attribute_double_h5" & - , "Cannot create attribute :" // trim(aname)) - end if - -! release the space -! - call h5sclose_f(sid, ierr) - if (ierr /= 0) then - call print_error("io::write_attribute_double_h5" & - , "Cannot close space for attribute :" // trim(aname)) - end if - -!------------------------------------------------------------------------------- -! - end subroutine write_attribute_double_h5 -! -!=============================================================================== -! -! subroutine WRITE_ATTRIBUTE_VECTOR_INTEGER_H5: -! -------------------------------------------- -! -! Subroutine stores a vector of the integer attribute in the group provided -! by an identifier and the attribute name. -! -! Arguments: -! -! gid - the group identifier to which the attribute should be linked; -! aname - the attribute name; -! avalue - the attribute values; -! -!=============================================================================== -! - subroutine write_attribute_vector_integer_h5(gid, aname, avalue) - -! import external procedures and variables -! - use error , only : print_error - use hdf5 , only : hid_t, hsize_t, H5T_NATIVE_INTEGER - use hdf5 , only : h5screate_simple_f, h5sclose_f - use hdf5 , only : h5acreate_f, h5awrite_f, h5aclose_f - -! local variables are not implicit by default -! - implicit none - -! attribute arguments -! - integer(hid_t) , intent(in) :: gid - character(len=*) , intent(in) :: aname - integer , dimension(:), intent(in) :: avalue - -! local variables -! - integer(hid_t) :: sid, aid - integer(hsize_t), dimension(1) :: am = (/ 1 /) - integer :: ierr -! -!------------------------------------------------------------------------------- -! -! set the proper attribute length -! - am(1) = size(avalue) - -! create space for the attribute value -! - call h5screate_simple_f(1, am, sid, ierr) - if (ierr /= 0) then - call print_error("io::write_attribute_vector_integer_h5" & - , "Cannot create space for attribute :" // trim(aname)) - return - end if - -! create the attribute in the given group -! - call h5acreate_f(gid, aname, H5T_NATIVE_INTEGER, sid, aid, ierr) - if (ierr == 0) then - -! write the attribute data -! - call h5awrite_f(aid, H5T_NATIVE_INTEGER, avalue, am, ierr) - if (ierr /= 0) then - call print_error("io::write_attribute_vector_integer_h5" & - , "Cannot write the attribute data in :" // trim(aname)) - end if - -! close the attribute -! - call h5aclose_f(aid, ierr) - if (ierr /= 0) then - call print_error("io::write_attribute_vector_integer_h5" & - , "Cannot close attribute :" // trim(aname)) - end if - - else - call print_error("io::write_attribute_vector_integer_h5" & - , "Cannot create attribute :" // trim(aname)) - end if - -! release the space -! - call h5sclose_f(sid, ierr) - if (ierr /= 0) then - call print_error("io::write_attribute_vector_integer_h5" & - , "Cannot close space for attribute :" // trim(aname)) - end if - -!------------------------------------------------------------------------------- -! - end subroutine write_attribute_vector_integer_h5 -! -!=============================================================================== ! ! subroutine WRITE_METABLOCKS_H5: ! ------------------------------ @@ -2925,7 +2367,7 @@ module io , "Cannot open the attribute group!") return end if - call read_attribute_integer_h5(gid, 'dblocks', dblocks) + call read_attribute(gid, 'dblocks', dblocks) call h5gclose_f(gid, ierr) if (ierr /= 0) then call print_error("io::read_datablocks_h5" & @@ -3513,7 +2955,818 @@ module io !------------------------------------------------------------------------------- ! end subroutine write_conservative_variables_h5 +! +!=============================================================================== +! +! WRITE_ATTRIBUTE SUBROUTINES +! +!=============================================================================== +! +! subroutine WRITE_SCALAR_ATTRIBUTE_INTEGER_H5: +! -------------------------------------------- +! +! Subroutine stores a value of the integer attribute in the group provided +! by an identifier and the attribute name. +! +! Arguments: +! +! gid - the group identifier to which the attribute should be linked; +! aname - the attribute name; +! avalue - the attribute value; +! +!=============================================================================== +! + subroutine write_scalar_attribute_integer_h5(gid, aname, avalue) +! import procedures and variables from other modules +! + use error , only : print_error + use hdf5 , only : H5T_NATIVE_INTEGER + use hdf5 , only : hid_t, hsize_t + use hdf5 , only : h5screate_simple_f, h5sclose_f + use hdf5 , only : h5acreate_f, h5awrite_f, h5aclose_f + +! local variables are not implicit by default +! + implicit none + +! subroutine arguments +! + integer(hid_t) , intent(in) :: gid + character(len=*), intent(in) :: aname + integer(kind=4) , intent(in) :: avalue + +! local variables +! + integer(hid_t) :: sid, aid + integer(hsize_t), dimension(1) :: am = (/ 1 /) + integer :: ierr + +! subroutine name string +! + character(len=*), parameter :: fname = & + "io::write_scalar_attribute_integer_h5" +! +!------------------------------------------------------------------------------- +! +! create space for the attribute value +! + call h5screate_simple_f(1, am, sid, ierr) + if (ierr /= 0) then + call print_error(fname & + , "Cannot create space for attribute :" // trim(aname)) + return + end if + +! create the attribute in the given group +! + call h5acreate_f(gid, aname, H5T_NATIVE_INTEGER, sid, aid, ierr) + if (ierr == 0) then + +! write the attribute data +! + call h5awrite_f(aid, H5T_NATIVE_INTEGER, avalue, am, ierr) + if (ierr /= 0) then + call print_error(fname & + , "Cannot write the attribute data in :" // trim(aname)) + end if + +! close the attribute +! + call h5aclose_f(aid, ierr) + if (ierr /= 0) then + call print_error(fname, "Cannot close attribute :" // trim(aname)) + end if + + else + call print_error(fname, "Cannot create attribute :" // trim(aname)) + end if + +! release the space +! + call h5sclose_f(sid, ierr) + if (ierr /= 0) then + call print_error(fname & + , "Cannot close space for attribute :" // trim(aname)) + end if + +!------------------------------------------------------------------------------- +! + end subroutine write_scalar_attribute_integer_h5 +! +!=============================================================================== +! +! subroutine WRITE_SCALAR_ATTRIBUTE_DOUBLE_H5: +! ------------------------------------------- +! +! Subroutine stores a value of the double precision attribute in the group +! provided by an identifier and the attribute name. +! +! Arguments: +! +! gid - the group identifier to which the attribute should be linked; +! aname - the attribute name; +! avalue - the attribute value; +! +!=============================================================================== +! + subroutine write_scalar_attribute_double_h5(gid, aname, avalue) + +! import procedures and variables from other modules +! + use error , only : print_error + use hdf5 , only : H5T_NATIVE_DOUBLE + use hdf5 , only : hid_t, hsize_t + use hdf5 , only : h5screate_simple_f, h5sclose_f + use hdf5 , only : h5acreate_f, h5awrite_f, h5aclose_f + +! local variables are not implicit by default +! + implicit none + +! attribute arguments +! + integer(hid_t) , intent(in) :: gid + character(len=*), intent(in) :: aname + real(kind=8) , intent(in) :: avalue + +! local variables +! + integer(hid_t) :: sid, aid + integer(hsize_t), dimension(1) :: am = (/ 1 /) + integer :: ierr + +! subroutine name string +! + character(len=*), parameter :: fname = & + "io::write_scalar_attribute_double_h5" +! +!------------------------------------------------------------------------------- +! +! create space for the attribute value +! + call h5screate_simple_f(1, am, sid, ierr) + if (ierr /= 0) then + call print_error(fname & + , "Cannot create space for attribute :" // trim(aname)) + return + end if + +! create the attribute in the given group +! + call h5acreate_f(gid, aname, H5T_NATIVE_DOUBLE, sid, aid, ierr) + if (ierr == 0) then + +! write the attribute data +! + call h5awrite_f(aid, H5T_NATIVE_DOUBLE, avalue, am, ierr) + if (ierr /= 0) then + call print_error(fname & + , "Cannot write the attribute data in :" // trim(aname)) + end if + +! close the attribute +! + call h5aclose_f(aid, ierr) + if (ierr /= 0) then + call print_error(fname, "Cannot close attribute :" // trim(aname)) + end if + + else + call print_error(fname, "Cannot create attribute :" // trim(aname)) + end if + +! release the space +! + call h5sclose_f(sid, ierr) + if (ierr /= 0) then + call print_error(fname & + , "Cannot close space for attribute :" // trim(aname)) + end if + +!------------------------------------------------------------------------------- +! + end subroutine write_scalar_attribute_double_h5 +! +!=============================================================================== +! +! subroutine WRITE_VECTOR_ATTRIBUTE_INTEGER_H5: +! -------------------------------------------- +! +! Subroutine stores a vector of the integer attribute in the group provided +! by an identifier and the attribute name. +! +! Arguments: +! +! gid - the group identifier to which the attribute should be linked; +! aname - the attribute name; +! avalue - the attribute values; +! +!=============================================================================== +! + subroutine write_vector_attribute_integer_h5(gid, aname, avalue) + +! import procedures and variables from other modules +! + use error , only : print_error + use hdf5 , only : hid_t, hsize_t, H5T_NATIVE_INTEGER + use hdf5 , only : h5screate_simple_f, h5sclose_f + use hdf5 , only : h5acreate_f, h5awrite_f, h5aclose_f + +! local variables are not implicit by default +! + implicit none + +! attribute arguments +! + integer(hid_t) , intent(in) :: gid + character(len=*) , intent(in) :: aname + integer(kind=4) , dimension(:), intent(in) :: avalue + +! local variables +! + integer(hid_t) :: sid, aid + integer(hsize_t), dimension(1) :: am = (/ 1 /) + integer :: ierr + +! subroutine name string +! + character(len=*), parameter :: fname = & + "io::write_vector_attribute_integer_h5" +! +!------------------------------------------------------------------------------- +! +! set the proper attribute length +! + am(1) = size(avalue) + +! create space for the attribute value +! + call h5screate_simple_f(1, am, sid, ierr) + if (ierr /= 0) then + call print_error(fname & + , "Cannot create space for attribute :" // trim(aname)) + return + end if + +! create the attribute in the given group +! + call h5acreate_f(gid, aname, H5T_NATIVE_INTEGER, sid, aid, ierr) + if (ierr == 0) then + +! write the attribute data +! + call h5awrite_f(aid, H5T_NATIVE_INTEGER, avalue, am, ierr) + if (ierr /= 0) then + call print_error(fname & + , "Cannot write the attribute data in :" // trim(aname)) + end if + +! close the attribute +! + call h5aclose_f(aid, ierr) + if (ierr /= 0) then + call print_error(fname, "Cannot close attribute :" // trim(aname)) + end if + + else + call print_error(fname, "Cannot create attribute :" // trim(aname)) + end if + +! release the space +! + call h5sclose_f(sid, ierr) + if (ierr /= 0) then + call print_error(fname & + , "Cannot close space for attribute :" // trim(aname)) + end if + +!------------------------------------------------------------------------------- +! + end subroutine write_vector_attribute_integer_h5 +! +!=============================================================================== +! +! subroutine WRITE_VECTOR_ATTRIBUTE_DOUBLE_H5: +! ------------------------------------------- +! +! Subroutine stores a vector of the double precision attribute in the group +! provided by an identifier and the attribute name. +! +! Arguments: +! +! gid - the group identifier to which the attribute should be linked; +! aname - the attribute name; +! avalue - the attribute values; +! +!=============================================================================== +! + subroutine write_vector_attribute_double_h5(gid, aname, avalue) + +! import procedures and variables from other modules +! + use error , only : print_error + use hdf5 , only : H5T_NATIVE_DOUBLE + use hdf5 , only : hid_t, hsize_t + use hdf5 , only : h5screate_simple_f, h5sclose_f + use hdf5 , only : h5acreate_f, h5awrite_f, h5aclose_f + +! local variables are not implicit by default +! + implicit none + +! attribute arguments +! + integer(hid_t) , intent(in) :: gid + character(len=*) , intent(in) :: aname + real(kind=8) , dimension(:), intent(in) :: avalue + +! local variables +! + integer(hid_t) :: sid, aid + integer(hsize_t), dimension(1) :: am = (/ 1 /) + integer :: ierr + +! subroutine name string +! + character(len=*), parameter :: fname = & + "io::write_vector_attribute_double_h5" +! +!------------------------------------------------------------------------------- +! +! set the proper attribute length +! + am(1) = size(avalue) + +! create space for the attribute value +! + call h5screate_simple_f(1, am, sid, ierr) + if (ierr /= 0) then + call print_error(fname & + , "Cannot create space for attribute :" // trim(aname)) + return + end if + +! create the attribute in the given group +! + call h5acreate_f(gid, aname, H5T_NATIVE_DOUBLE, sid, aid, ierr) + if (ierr == 0) then + +! write the attribute data +! + call h5awrite_f(aid, H5T_NATIVE_DOUBLE, avalue, am, ierr) + if (ierr /= 0) then + call print_error(fname & + , "Cannot write the attribute data in :" // trim(aname)) + end if + +! close the attribute +! + call h5aclose_f(aid, ierr) + if (ierr /= 0) then + call print_error(fname, "Cannot close attribute :" // trim(aname)) + end if + + else + call print_error(fname, "Cannot create attribute :" // trim(aname)) + end if + +! release the space +! + call h5sclose_f(sid, ierr) + if (ierr /= 0) then + call print_error(fname & + , "Cannot close space for attribute :" // trim(aname)) + end if + +!------------------------------------------------------------------------------- +! + end subroutine write_vector_attribute_double_h5 + +!=============================================================================== +! +! READ_ATTRIBUTE SUBROUTINES +! +!=============================================================================== +! +! subroutine READ_SCALAR_ATTRIBUTE_INTEGER_H5: +! ------------------------------------------- +! +! Subroutine reads a value of the integer attribute provided by the group +! identifier to which it is linked and its name. +! +! Arguments: +! +! gid - the group identifier to which the attribute is linked; +! aname - the attribute name; +! avalue - the attribute value; +! +!=============================================================================== +! + subroutine read_scalar_attribute_integer_h5(gid, aname, avalue) + +! import procedures and variables from other modules +! + use error , only : print_error + use hdf5 , only : H5T_NATIVE_INTEGER + use hdf5 , only : hid_t, hsize_t + use hdf5 , only : h5aexists_by_name_f + use hdf5 , only : h5aopen_by_name_f, h5aread_f, h5aclose_f + +! local variables are not implicit by default +! + implicit none + +! attribute arguments +! + integer(hid_t) , intent(in) :: gid + character(len=*), intent(in) :: aname + integer(kind=4) , intent(inout) :: avalue + +! local variables +! + logical :: exists = .false. + integer(hid_t) :: aid + integer(hsize_t), dimension(1) :: am = (/ 1 /) + integer :: ierr + +! subroutine name string +! + character(len=*), parameter :: fname = & + "io::read_scalar_attribute_integer_h5" +! +!------------------------------------------------------------------------------- +! +! check if the attribute exists in the group provided by gid +! + call h5aexists_by_name_f(gid, '.', aname, exists, ierr) + if (ierr /= 0) then + call print_error(fname & + , "Cannot check if attribute exists :" // trim(aname)) + return + end if + if (.not. exists) then + call print_error(fname, "Attribute does not exist :" // trim(aname)) + return + end if + +! open the attribute +! + call h5aopen_by_name_f(gid, '.', aname, aid, ierr) + if (ierr /= 0) then + call print_error(fname, "Cannot open attribute :" // trim(aname)) + return + end if + +! read attribute value +! + call h5aread_f(aid, H5T_NATIVE_INTEGER, avalue, am(:), ierr) + if (ierr /= 0) then + call print_error(fname, "Cannot read attribute :" // trim(aname)) + end if + +! close the attribute +! + call h5aclose_f(aid, ierr) + if (ierr /= 0) then + call print_error(fname, "Cannot close attribute :" // trim(aname)) + return + end if + +!------------------------------------------------------------------------------- +! + end subroutine read_scalar_attribute_integer_h5 +! +!=============================================================================== +! +! subroutine READ_SCALAR_ATTRIBUTE_DOUBLE_H5: +! ------------------------------------------ +! +! Subroutine reads a value of the double precision attribute provided by +! the group identifier to which it is linked and its name. +! +! Arguments: +! +! gid - the group identifier to which the attribute is linked; +! aname - the attribute name; +! avalue - the attribute value; +! +!=============================================================================== +! + subroutine read_scalar_attribute_double_h5(gid, aname, avalue) + +! import procedures and variables from other modules +! + use error , only : print_error + use hdf5 , only : H5T_NATIVE_DOUBLE + use hdf5 , only : hid_t, hsize_t + use hdf5 , only : h5aexists_by_name_f + use hdf5 , only : h5aopen_by_name_f, h5aread_f, h5aclose_f + +! local variables are not implicit by default +! + implicit none + +! attribute arguments +! + integer(hid_t) , intent(in) :: gid + character(len=*), intent(in) :: aname + real(kind=8) , intent(inout) :: avalue + +! local variables +! + logical :: exists = .false. + integer(hid_t) :: aid + integer(hsize_t), dimension(1) :: am = (/ 1 /) + integer :: ierr + +! subroutine name string +! + character(len=*), parameter :: fname = & + "io::read_scalar_attribute_double_h5" +! +!------------------------------------------------------------------------------- +! +! check if the attribute exists in the group provided by gid +! + call h5aexists_by_name_f(gid, '.', aname, exists, ierr) + if (ierr /= 0) then + call print_error(fname & + , "Cannot check if attribute exists :" // trim(aname)) + return + end if + if (.not. exists) then + call print_error(fname, "Attribute does not exist :" // trim(aname)) + return + end if + +! open the attribute +! + call h5aopen_by_name_f(gid, '.', aname, aid, ierr) + if (ierr /= 0) then + call print_error(fname, "Cannot open attribute :" // trim(aname)) + return + end if + +! read attribute value +! + call h5aread_f(aid, H5T_NATIVE_DOUBLE, avalue, am(:), ierr) + if (ierr /= 0) then + call print_error(fname, "Cannot read attribute :" // trim(aname)) + end if + +! close the attribute +! + call h5aclose_f(aid, ierr) + if (ierr /= 0) then + call print_error(fname, "Cannot close attribute :" // trim(aname)) + return + end if + +!------------------------------------------------------------------------------- +! + end subroutine read_scalar_attribute_double_h5 +! +!=============================================================================== +! +! subroutine READ_VECTOR_ATTRIBUTE_INTEGER_H5: +! ------------------------------------------- +! +! Subroutine reads a vector of the integer attribute provided by the group +! identifier to which it is linked and its name. +! +! Arguments: +! +! gid - the group identifier to which the attribute is linked; +! aname - the attribute name; +! avalue - the attribute value; +! +!=============================================================================== +! + subroutine read_vector_attribute_integer_h5(gid, aname, avalue) + +! import procedures and variables from other modules +! + use error , only : print_error + use hdf5 , only : H5T_NATIVE_INTEGER + use hdf5 , only : hid_t, hsize_t + use hdf5 , only : h5aexists_by_name_f, h5aget_space_f + use hdf5 , only : h5aopen_by_name_f, h5aread_f, h5aclose_f + use hdf5 , only : h5sclose_f, h5sget_simple_extent_dims_f + +! local variables are not implicit by default +! + implicit none + +! attribute arguments +! + integer(hid_t) , intent(in) :: gid + character(len=*) , intent(in) :: aname + integer(kind=4) , dimension(:), intent(inout) :: avalue + +! local variables +! + logical :: exists = .false. + integer(hid_t) :: aid, sid + integer(hsize_t), dimension(1) :: am, bm + integer(hsize_t) :: alen + integer :: ierr + +! subroutine name string +! + character(len=*), parameter :: fname = & + "io::read_vector_attribute_integer_h5" +! +!------------------------------------------------------------------------------- +! +! check if the attribute exists in the group provided by gid +! + call h5aexists_by_name_f(gid, '.', aname, exists, ierr) + if (ierr /= 0) then + call print_error(fname & + , "Cannot check if attribute exists :" // trim(aname)) + return + end if + if (.not. exists) then + call print_error(fname, "Attribute does not exist :" // trim(aname)) + return + end if + +! open the attribute +! + call h5aopen_by_name_f(gid, '.', aname, aid, ierr) + if (ierr /= 0) then + call print_error(fname, "Cannot open attribute :" // trim(aname)) + return + end if + +! get the attribute space +! + call h5aget_space_f(aid, sid, ierr) + if (ierr == 0) then + call h5sget_simple_extent_dims_f(sid, am, bm, ierr) + if (ierr /= 1) then + call print_error(fname & + , "Cannot get attribute dimensions :" // trim(aname)) + end if + call h5sclose_f(sid, ierr) + if (ierr /= 0) then + call print_error(fname & + , "Cannot close the attribute space :" // trim(aname)) + end if + else + call print_error(fname & + , "Cannot get the attribute space :" // trim(aname)) + return + end if + +! check if the output array is large enough +! + if (am(1) > size(avalue)) then + call print_error(fname & + , "Attribute too large for output argument :" // trim(aname)) + return + end if + +! read attribute value +! + call h5aread_f(aid, H5T_NATIVE_INTEGER, avalue, am(:), ierr) + if (ierr /= 0) then + call print_error(fname, "Cannot read attribute :" // trim(aname)) + end if + +! close the attribute +! + call h5aclose_f(aid, ierr) + if (ierr /= 0) then + call print_error(fname, "Cannot close attribute :" // trim(aname)) + return + end if + +!------------------------------------------------------------------------------- +! + end subroutine read_vector_attribute_integer_h5 +! +!=============================================================================== +! +! subroutine READ_VECTOR_ATTRIBUTE_DOUBLE_H5: +! ------------------------------------------ +! +! Subroutine reads a vector of the double precision attribute provided by +! the group identifier to which it is linked and its name. +! +! Arguments: +! +! gid - the group identifier to which the attribute is linked; +! aname - the attribute name; +! avalue - the attribute value; +! +!=============================================================================== +! + subroutine read_vector_attribute_double_h5(gid, aname, avalue) + +! import procedures and variables from other modules +! + use error , only : print_error + use hdf5 , only : H5T_NATIVE_DOUBLE + use hdf5 , only : hid_t, hsize_t + use hdf5 , only : h5aexists_by_name_f, h5aget_space_f + use hdf5 , only : h5aopen_by_name_f, h5aread_f, h5aclose_f + use hdf5 , only : h5sclose_f, h5sget_simple_extent_dims_f + +! local variables are not implicit by default +! + implicit none + +! attribute arguments +! + integer(hid_t) , intent(in) :: gid + character(len=*) , intent(in) :: aname + real(kind=8) , dimension(:), intent(inout) :: avalue + +! local variables +! + logical :: exists = .false. + integer(hid_t) :: aid, sid + integer(hsize_t), dimension(1) :: am, bm + integer(hsize_t) :: alen + integer :: ierr + +! subroutine name string +! + character(len=*), parameter :: fname = & + "io::read_vector_attribute_double_h5" +! +!------------------------------------------------------------------------------- +! +! check if the attribute exists in the group provided by gid +! + call h5aexists_by_name_f(gid, '.', aname, exists, ierr) + if (ierr /= 0) then + call print_error(fname & + , "Cannot check if attribute exists :" // trim(aname)) + return + end if + if (.not. exists) then + call print_error(fname, "Attribute does not exist :" // trim(aname)) + return + end if + +! open the attribute +! + call h5aopen_by_name_f(gid, '.', aname, aid, ierr) + if (ierr /= 0) then + call print_error(fname, "Cannot open attribute :" // trim(aname)) + return + end if + +! get the attribute space +! + call h5aget_space_f(aid, sid, ierr) + if (ierr == 0) then + call h5sget_simple_extent_dims_f(sid, am, bm, ierr) + if (ierr /= 1) then + call print_error(fname & + , "Cannot get attribute dimensions :" // trim(aname)) + end if + call h5sclose_f(sid, ierr) + if (ierr /= 0) then + call print_error(fname & + , "Cannot close the attribute space :" // trim(aname)) + end if + else + call print_error(fname & + , "Cannot get the attribute space :" // trim(aname)) + return + end if + +! check if the output array is large enough +! + if (am(1) > size(avalue)) then + call print_error(fname & + , "Attribute too large for output argument :" // trim(aname)) + return + end if + +! read attribute value +! + call h5aread_f(aid, H5T_NATIVE_DOUBLE, avalue, am(:), ierr) + if (ierr /= 0) then + call print_error(fname, "Cannot read attribute :" // trim(aname)) + end if + +! close the attribute +! + call h5aclose_f(aid, ierr) + if (ierr /= 0) then + call print_error(fname, "Cannot close attribute :" // trim(aname)) + return + end if + +!------------------------------------------------------------------------------- +! + end subroutine read_vector_attribute_double_h5 +! !=============================================================================== ! ! WRITE_ARRAY SUBROUTINES From e79a64c5a5b5e3336add0d17ce85e9973fb99532 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Wed, 23 Jul 2014 15:47:31 -0300 Subject: [PATCH 82/91] BOUNDARIES: Reimplement specific boundary conditions. This patch introduces specific boundary conditions for new neighbor pointers. Signed-off-by: Grzegorz Kowal --- src/boundaries.F90 | 420 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 420 insertions(+) diff --git a/src/boundaries.F90 b/src/boundaries.F90 index 45fc36c..f324e5f 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -346,6 +346,10 @@ module boundaries ! call update_corners() +! update specific boundaries +! + call boundaries_specific() + #if NDIMS == 3 ! update face boundaries between blocks at the same levels ! @@ -400,6 +404,10 @@ module boundaries ! call boundaries_corner_prolong() +! update specific boundaries +! + call boundaries_specific() + ! convert updated primitive variables to conservative ones in all ghost cells ! call update_ghost_cells() @@ -2825,6 +2833,132 @@ module boundaries !------------------------------------------------------------------------------- ! end subroutine prolong_boundaries +! +!=============================================================================== +! +! subroutine BOUNDARIES_SPECIFIC: +! ----------------------------------- +! +! Subroutine scans over all leaf blocks in order to find blocks without +! neighbors, then updates its boundaries for selected type. +! +! +!=============================================================================== +! + subroutine boundaries_specific() + +! import external procedures and variables +! + use blocks , only : block_meta, list_meta + use blocks , only : ndims, nsides + use coordinates , only : im, jm, km + use equations , only : nv +#ifdef MPI + use mpitools , only : nproc +#endif /* MPI */ + +! local variables are not implicit by default +! + implicit none + +! local pointers +! + type(block_meta), pointer :: pmeta, pneigh + +! local variables +! + integer :: i, j, k, n +! +!------------------------------------------------------------------------------- +! +#ifdef PROFILE +! start accounting time for specific boundary update +! + call start_timer(ims) +#endif /* PROFILE */ + +! associate pmeta with the first block on the meta list +! + pmeta => list_meta + +! scan all blocks on meta block list +! + do while(associated(pmeta)) + +! check if the current meta block is a leaf +! + if (pmeta%leaf) then + +! process only if this block is marked for update +! + if (pmeta%update) then + +#ifdef MPI +! check if the current block belongs to the local process +! + if (pmeta%process == nproc) then +#endif /* MPI */ + +#if NDIMS == 2 +! iterate over all edge neighbors +! + do j = 1, nsides + do i = 1, nsides + do n = 1, ndims + +! if the face neighbor is not associated, apply specific boundaries +! + if (.not. associated(pmeta%edges(i,j,n)%ptr)) & + call block_boundary_specific(i, j, k, 3 - n & + , pmeta%data%q(1:nv,1:im,1:jm,1:km)) + + end do ! n = 1, ndims + end do ! i = 1, sides + end do ! j = 1, sides +#endif /* NDIMS == 2 */ +#if NDIMS == 3 +! iterate over all face neighbors +! + do k = 1, nsides + do j = 1, nsides + do i = 1, nsides + do n = 1, ndims + +! if the face neighbor is not associated, apply specific boundaries +! + if (.not. associated(pmeta%faces(i,j,k,n)%ptr)) & + call block_boundary_specific(i, j, k, n & + , pmeta%data%q(1:nv,1:im,1:jm,1:km)) + + end do ! n = 1, ndims + end do ! i = 1, sides + end do ! j = 1, sides + end do ! k = 1, sides +#endif /* NDIMS == 3 */ + +#ifdef MPI + end if ! block belong to the local process +#endif /* MPI */ + + end if ! pmeta is marked for update + + end if ! leaf + +! associate pmeta with the next block on the list +! + pmeta => pmeta%next + + end do ! meta blocks + +#ifdef PROFILE +! stop accounting time for specific boundary update +! + call stop_timer(ims) +#endif /* PROFILE */ + +!------------------------------------------------------------------------------- +! + end subroutine boundaries_specific #if NDIMS == 3 ! !=============================================================================== @@ -9965,6 +10099,292 @@ module boundaries ! !=============================================================================== ! +! subroutine BLOCK_BOUNDARY_SPECIFIC: +! ---------------------------------- +! +! Subroutine applies specific boundary conditions to the pointed data block. +! +! Arguments: +! +! pdata - the pointer to modified data block; +! idir - the direction to be processed; +! iside - the side to be processed; +! +!=============================================================================== +! + subroutine block_boundary_specific(ic, jc, kc, nc, qn) + +! import external procedures and variables +! + use coordinates , only : im , jm , km , ng + use coordinates , only : ib , jb , kb , ie , je , ke + use coordinates , only : ibl, jbl, kbl, ieu, jeu, keu + use equations , only : nv + use equations , only : idn, ivx, ivy, ivz, ibx, iby, ibz, ibp + use error , only : print_error, print_warning + +! local variables are not implicit by default +! + implicit none + +! subroutine arguments +! + integer , intent(in) :: ic, jc, kc + integer , intent(in) :: nc + real(kind=8), dimension(1:nv,1:im,1:jm,1:km), intent(inout) :: qn + +! local variables +! + integer :: i , j , k + integer :: il, jl, kl + integer :: iu, ju, ku + integer :: is, js, ks + integer :: it, jt, kt +! +!------------------------------------------------------------------------------- +! +! apply specific boundaries depending on the direction +! + select case(nc) + case(1) + +! prepare indices for the boundaries +! + if (jc == 1) then + jl = 1 + ju = jm / 2 - 1 + else + jl = jm / 2 + ju = jm + end if +#if NDIMS == 3 + if (kc == 1) then + kl = 1 + ku = km / 2 - 1 + else + kl = km / 2 + ku = km + end if +#else /* NDIMS == 3 */ + kl = 1 + ku = km +#endif /* NDIMS == 3 */ + +! apply selected boundary condition +! + select case(bnd_type(nc,ic)) + +! "open" boundary conditions +! + case(bnd_open) + + if (ic == 1) then + do i = ibl, 1, -1 + qn(1:nv,i,jl:ju,kl:ku) = qn(1:nv,ib,jl:ju,kl:ku) + end do + else + do i = ieu, im + qn(1:nv,i,jl:ju,kl:ku) = qn(1:nv,ie,jl:ju,kl:ku) + end do + end if + +! "reflective" boundary conditions +! + case(bnd_reflective) + + if (ic == 1) then + do i = 1, ng + it = ib - i + is = ibl + i + + qn(1:nv,it,jl:ju,kl:ku) = qn(1:nv,is,jl:ju,kl:ku) + qn(ivx ,it,jl:ju,kl:ku) = - qn(ivx ,is,jl:ju,kl:ku) + end do + else + do i = 1, ng + it = ie + i + is = ieu - i + + qn(1:nv,it,jl:ju,kl:ku) = qn(1:nv,is,jl:ju,kl:ku) + qn(ivx ,it,jl:ju,kl:ku) = - qn(ivx ,is,jl:ju,kl:ku) + end do + end if + +! wrong boundary conditions +! + case default + + if (ic == 1) then + call print_error("boundaries:boundary_specific()" & + , "Wrong left X boundary type!") + else + call print_error("boundaries:boundary_specific()" & + , "Wrong right X boundary type!") + end if + + end select + + case(2) + +! prepare indices for the boundaries +! + if (ic == 1) then + il = 1 + iu = im / 2 - 1 + else + il = im / 2 + iu = im + end if +#if NDIMS == 3 + if (kc == 1) then + kl = 1 + ku = km / 2 - 1 + else + kl = km / 2 + ku = km + end if +#else /* NDIMS == 3 */ + kl = 1 + ku = km +#endif /* NDIMS == 3 */ + +! apply selected boundary condition +! + select case(bnd_type(nc,jc)) + +! "open" boundary conditions +! + case(bnd_open) + + if (jc == 1) then + do j = jbl, 1, -1 + qn(1:nv,il:iu,j,kl:ku) = qn(1:nv,il:iu,jb,kl:ku) + end do + else + do j = jeu, jm + qn(1:nv,il:iu,j,kl:ku) = qn(1:nv,il:iu,je,kl:ku) + end do + end if + +! "reflective" boundary conditions +! + case(bnd_reflective) + + if (jc == 1) then + do j = 1, ng + jt = jb - j + js = jbl + j + + qn(1:nv,il:iu,jt,kl:ku) = qn(1:nv,il:iu,js,kl:ku) + qn(ivy ,il:iu,jt,kl:ku) = - qn(ivy ,il:iu,js,kl:ku) + end do + else + do j = 1, ng + jt = je + j + js = jeu - j + + qn(1:nv,il:iu,jt,kl:ku) = qn(1:nv,il:iu,js,kl:ku) + qn(ivy ,il:iu,jt,kl:ku) = - qn(ivy ,il:iu,js,kl:ku) + end do + end if + +! wrong boundary conditions +! + case default + + if (jc == 1) then + call print_error("boundaries:boundary_specific()" & + , "Wrong left Y boundary type!") + else + call print_error("boundaries:boundary_specific()" & + , "Wrong right Y boundary type!") + end if + + end select + +#if NDIMS == 3 + case(3) + +! prepare indices for the boundaries +! + if (ic == 1) then + il = 1 + iu = im / 2 - 1 + else + il = im / 2 + iu = im + end if + if (jc == 1) then + jl = 1 + ju = jm / 2 - 1 + else + jl = jm / 2 + ju = jm + end if + +! apply selected boundary condition +! + select case(bnd_type(nc,kc)) + +! "open" boundary conditions +! + case(bnd_open) + + if (kc == 1) then + do k = kbl, 1, -1 + qn(1:nv,il:iu,jl:ju,k) = qn(1:nv,il:iu,jl:ju,kb) + end do + else + do k = keu, km + qn(1:nv,il:iu,jl:ju,k) = qn(1:nv,il:iu,jl:ju,ke) + end do + end if + +! "reflective" boundary conditions +! + case(bnd_reflective) + + if (kc == 1) then + do k = 1, ng + kt = kb - k + ks = kbl + k + + qn(1:nv,il:iu,jl:ju,kt) = qn(1:nv,il:iu,jl:ju,ks) + qn(ivz ,il:iu,jl:ju,kt) = - qn(ivz ,il:iu,jl:ju,ks) + end do + else + do k = 1, ng + kt = ke + k + ks = keu - k + + qn(1:nv,il:iu,jl:ju,kt) = qn(1:nv,il:iu,jl:ju,ks) + qn(ivz ,il:iu,jl:ju,kt) = - qn(ivz ,il:iu,jl:ju,ks) + end do + end if + +! wrong boundary conditions +! + case default + + if (kc == 1) then + call print_error("boundaries:boundary_specific()" & + , "Wrong left Z boundary type!") + else + call print_error("boundaries:boundary_specific()" & + , "Wrong right Z boundary type!") + end if + + end select + +#endif /* NDIMS == 3 */ + end select + +!------------------------------------------------------------------------------- +! + end subroutine block_boundary_specific +! +!=============================================================================== +! ! BLOCK FLUX UPDATE SUBROUTINES ! !=============================================================================== From fa41c2a96e8d42a2a1f2df9de9c11e3373870242 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Wed, 23 Jul 2014 16:02:09 -0300 Subject: [PATCH 83/91] BOUNDARIES: Skip periodic boundaries in boundaries_specific(). Signed-off-by: Grzegorz Kowal --- src/boundaries.F90 | 53 ++++++++++++++++++++++++++++++++-------------- 1 file changed, 37 insertions(+), 16 deletions(-) diff --git a/src/boundaries.F90 b/src/boundaries.F90 index f324e5f..f804c4c 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -2856,6 +2856,7 @@ module boundaries #ifdef MPI use mpitools , only : nproc #endif /* MPI */ + use mpitools , only : periodic ! local variables are not implicit by default ! @@ -2900,11 +2901,18 @@ module boundaries #endif /* MPI */ #if NDIMS == 2 -! iterate over all edge neighbors +! iterate over all directions ! - do j = 1, nsides - do i = 1, nsides - do n = 1, ndims + do n = 1, ndims + +! process boundaries only if they are not periodic in a given direction +! + if (.not. periodic(n)) then + +! iterate over all corners +! + do j = 1, nsides + do i = 1, nsides ! if the face neighbor is not associated, apply specific boundaries ! @@ -2912,17 +2920,27 @@ module boundaries call block_boundary_specific(i, j, k, 3 - n & , pmeta%data%q(1:nv,1:im,1:jm,1:km)) - end do ! n = 1, ndims - end do ! i = 1, sides - end do ! j = 1, sides + end do ! i = 1, sides + end do ! j = 1, sides + + end if ! not periodic + + end do ! n = 1, ndims #endif /* NDIMS == 2 */ #if NDIMS == 3 -! iterate over all face neighbors +! iterate over all directions ! - do k = 1, nsides - do j = 1, nsides - do i = 1, nsides - do n = 1, ndims + do n = 1, ndims + +! process boundaries only if they are not periodic in a given direction +! + if (.not. periodic(n)) then + +! iterate over all corners +! + do k = 1, nsides + do j = 1, nsides + do i = 1, nsides ! if the face neighbor is not associated, apply specific boundaries ! @@ -2930,10 +2948,13 @@ module boundaries call block_boundary_specific(i, j, k, n & , pmeta%data%q(1:nv,1:im,1:jm,1:km)) - end do ! n = 1, ndims - end do ! i = 1, sides - end do ! j = 1, sides - end do ! k = 1, sides + end do ! i = 1, sides + end do ! j = 1, sides + end do ! k = 1, sides + + end if ! not periodic + + end do ! n = 1, ndims #endif /* NDIMS == 3 */ #ifdef MPI From 2d8ce746167adb2059a58d267cc9cb8a2ef2aa2d Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Wed, 23 Jul 2014 16:13:50 -0300 Subject: [PATCH 84/91] BOUNDARIES: Correct argument descriptions in block_boundary_specific(). Signed-off-by: Grzegorz Kowal --- src/boundaries.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/boundaries.F90 b/src/boundaries.F90 index f804c4c..ca35d62 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -2837,7 +2837,7 @@ module boundaries !=============================================================================== ! ! subroutine BOUNDARIES_SPECIFIC: -! ----------------------------------- +! ------------------------------ ! ! Subroutine scans over all leaf blocks in order to find blocks without ! neighbors, then updates its boundaries for selected type. @@ -10127,9 +10127,9 @@ module boundaries ! ! Arguments: ! -! pdata - the pointer to modified data block; -! idir - the direction to be processed; -! iside - the side to be processed; +! nc - the edge direction; +! ic, jc, kc - the corner position; +! qn - the variable array; ! !=============================================================================== ! From 8d78e3c099c01db108fd2fa116b75f4fe2e661a2 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Wed, 23 Jul 2014 22:49:18 -0300 Subject: [PATCH 85/91] BOUNDARIES: Rewrite flux update subroutines. This patch rewrites two subroutines boundary_fluxes() and related block_update_flux() in order to use new pointers (faces in 3D and edges in 2D). It also signficantly simplifies block_update_flux() comparing to previous version correct_flux(). Signed-off-by: Grzegorz Kowal --- src/boundaries.F90 | 843 ++++++++++++++++++++++----------------------- 1 file changed, 414 insertions(+), 429 deletions(-) diff --git a/src/boundaries.F90 b/src/boundaries.F90 index ca35d62..9e4fae9 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -427,7 +427,10 @@ module boundaries ! subroutine BOUNDARY_FLUXES: ! -------------------------- ! -! Subroutine updates the numerical fluxes of neighors at different levels. +! Subroutine updates the numerical fluxes for blocks which have neighbors +! at higher level. The fluxes of neighbors at higher level are calulated +! with smaller error, therefore they are restricted down and the flux +! of lower level meta block is updated. ! ! !=============================================================================== @@ -440,12 +443,12 @@ module boundaries #ifdef MPI use blocks , only : block_info, pointer_info #endif /* MPI */ - use blocks , only : ndims, nsides, nfaces - use coordinates , only : toplev -#ifdef MPI - use coordinates , only : im, jm, km -#endif /* MPI */ - use coordinates , only : ibl, ie, jbl, je, kbl, ke + use blocks , only : ndims, nsides + use coordinates , only : minlev, maxlev + use coordinates , only : in, jn, kn + use coordinates , only : ib, ie, ibl + use coordinates , only : jb, je, jbl + use coordinates , only : kb, ke, kbl #ifdef MPI use equations , only : nv use mpitools , only : nprocs, nproc, npmax @@ -465,8 +468,11 @@ module boundaries ! local variables ! - integer :: idir, iside, iface - integer :: is, js, ks + integer :: n, m + integer :: i, is, it, il, iu, ih + integer :: j, js, jt, jl, ju, jh + integer :: k, ks, kt, kl, ku, kh + #ifdef MPI integer :: irecv, isend, nblocks, itag, l, iret #endif /* MPI */ @@ -474,21 +480,34 @@ module boundaries #ifdef MPI ! local pointer arrays ! - type(pointer_info), dimension(ndims,0:nprocs-1,0:nprocs-1) :: block_array + type(pointer_info), dimension(0:nprocs-1,0:nprocs-1) :: block_array #endif /* MPI */ #ifdef MPI ! local arrays ! - integer , dimension(ndims,0:nprocs-1,0:nprocs-1) :: block_counter - real(kind=8), dimension(:,:,:,:), allocatable :: rbuf + integer , dimension(0:nprocs-1,0:nprocs-1) :: block_counter + real(kind=8), dimension(:,:,:,:), allocatable :: rbuf #endif /* MPI */ ! !------------------------------------------------------------------------------- ! ! do not correct fluxes if we do not use adaptive mesh ! - if (toplev == 1) return + if (minlev == maxlev) return + +! calculate half sizes +! + ih = in / 2 + jh = jn / 2 +#if NDIMS == 2 + kh = kn + kl = 1 + ku = kn +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + kh = kn / 2 +#endif /* NDIMS == 3 */ #ifdef PROFILE ! start accounting time for flux boundary update @@ -501,22 +520,20 @@ module boundaries !! ! reset the block counter ! - block_counter(:,:,:) = 0 + block_counter(:,:) = 0 ! nullify pointers to blocks which need to be exchanged between processes ! do irecv = 0, npmax do isend = 0, npmax - do idir = 1, ndims - nullify(block_array(idir,irecv,isend)%ptr) - end do ! idir + nullify(block_array(isend,irecv)%ptr) end do ! isend end do ! irecv #endif /* MPI */ -!! 2. UPDATE THE FLUX BOUNDARIES BETWEEN THE LOCAL BLOCKS +!! 2. UPDATE THE FLUX BOUNDARIES BETWEEN LOCAL BLOCKS !! -! assign the pointer to the first block on the meta list +! associate pmeta with the first block on the meta list ! pmeta => list_meta @@ -524,144 +541,222 @@ module boundaries ! do while(associated(pmeta)) -! check if the meta block is the leaf +! check if the meta block is leaf ! if (pmeta%leaf) then -! iterate over all block neighbors +! iterate over all dimensions ! - do idir = 1, ndims - do iside = 1, nsides - do iface = 1, nfaces + do n = 1, ndims +#if NDIMS == 2 + m = 3 - n +#endif /* NDIMS == 2 */ -! associate a pointer to the current neighbor +! iterate over all corners ! - pneigh => pmeta%neigh(idir,iside,iface)%ptr +#if NDIMS == 3 + do k = 1, nsides +#endif /* NDIMS == 3 */ + do j = 1, nsides + do i = 1, nsides + +! associate pneigh with the current neighbor +! +#if NDIMS == 2 + pneigh => pmeta%edges(i,j,m)%ptr +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + pneigh => pmeta%faces(i,j,k,n)%ptr +#endif /* NDIMS == 3 */ ! check if the neighbor is associated ! - if (associated(pneigh)) then + if (associated(pneigh)) then -! check if the neighbor has high level than the current block +! check if the neighbor is at highed level than the current block ! - if (pmeta%level < pneigh%level) then + if (pneigh%level > pmeta%level) then #ifdef MPI -! check if the block and neighbor belong to the same process, if so, update -! fluxes directly +! check if the current block and its neighbor belong to the same process, if so, +! update fluxes directly ! - if (pmeta%process == nproc .and. pneigh%process == nproc) then + if (pmeta%process == nproc .and. & + pneigh%process == nproc) then #endif /* MPI */ ! update directional flux from the neighbor ! - select case(idir) - case(1) + select case(n) + case(1) -! prepare the boundary layer index depending on the side +! prepare the boundary layer indices depending on the corner position ! - if (iside == 1) then - is = ie - else - is = ibl - end if - -! correct the flux from the neighor at higher level -! - call correct_flux(pmeta%data & - , pneigh%data%f(idir,:,is,:,:), idir, iside, iface) - - case(2) - -! prepare the boundary layer index depending on the side -! - if (iside == 1) then - js = je - else - js = jbl - end if - -! correct the flux from the neighor at higher level -! - call correct_flux(pmeta%data & - , pneigh%data%f(idir,:,:,js,:), idir, iside, iface) - + if (i == 1) then + is = ie + it = ibl + else + is = ibl + it = ie + end if + if (j == 1) then + jl = jb + ju = jb + jh - 1 + else + jl = je - jh + 1 + ju = je + end if #if NDIMS == 3 - case(3) - -! prepare the boundary layer index depending on the side -! - if (iside == 1) then - ks = ke - else - ks = kbl - end if - -! correct the flux from the neighor at higher level -! - call correct_flux(pmeta%data & - , pneigh%data%f(idir,:,:,:,ks), idir, iside, iface) + if (k == 1) then + kl = kb + ku = kb + kh - 1 + else + kl = ke - kh + 1 + ku = ke + end if #endif /* NDIMS == 3 */ - end select +! update the flux edge from the neighbor at higher level +! + call block_update_flux(i, j, k, n & + , pneigh%data%f(n,1:nv,is,jb:je,kb:ke) & + , pmeta%data%f(n,1:nv,it,jl:ju,kl:ku)) + + case(2) + +! prepare the boundary layer indices depending on the corner position +! + if (i == 1) then + il = ib + iu = ib + ih - 1 + else + il = ie - ih + 1 + iu = ie + end if + if (j == 1) then + js = je + jt = jbl + else + js = jbl + jt = je + end if +#if NDIMS == 3 + if (k == 1) then + kl = kb + ku = kb + kh - 1 + else + kl = ke - kh + 1 + ku = ke + end if +#endif /* NDIMS == 3 */ + +! update the flux edge from the neighbor at higher level +! + call block_update_flux(i, j, k, n & + , pneigh%data%f(n,1:nv,ib:ie,js,kb:ke) & + , pmeta%data%f(n,1:nv,il:iu,jt,kl:ku)) + +#if NDIMS == 3 + case(3) + +! prepare the boundary layer indices depending on the corner position +! + if (i == 1) then + il = ib + iu = ib + ih - 1 + else + il = ie - ih + 1 + iu = ie + end if + if (j == 1) then + jl = jb + ju = jb + jh - 1 + else + jl = je - jh + 1 + ju = je + end if + if (k == 1) then + ks = ke + kt = kbl + else + ks = kbl + kt = ke + end if + +! update the flux edge from the neighbor at higher level +! + call block_update_flux(i, j, k, n & + , pneigh%data%f(n,1:nv,ib:ie,jb:je,ks) & + , pmeta%data%f(n,1:nv,il:iu,jl:ju,kt)) +#endif /* NDIMS == 3 */ + + end select #ifdef MPI -! block belong to different processes, therefore prepare the block exchange -! arrays +! blocks belong to different processes, therefore prepare the block exchange +! object ! - else + else ! increase the counter for the number of blocks to exchange ! - block_counter(idir,pmeta%process,pneigh%process) = & - block_counter(idir,pmeta%process,pneigh%process) + 1 + block_counter(pneigh%process,pmeta%process) = & + block_counter(pneigh%process,pmeta%process) + 1 ! allocate a new info object ! - allocate(pinfo) + allocate(pinfo) ! fill out its fields ! - pinfo%block => pmeta - pinfo%neigh => pneigh - pinfo%direction = idir - pinfo%side = iside - pinfo%face = iface - pinfo%level_difference = pmeta%level - pneigh%level + pinfo%block => pmeta + pinfo%neigh => pneigh + pinfo%direction = n + pinfo%corner(1) = i + pinfo%corner(2) = j +#if NDIMS == 3 + pinfo%corner(3) = k +#endif /* NDIMS == 3 */ + pinfo%level_difference = pmeta%level - pneigh%level ! nullify pointer fields ! - nullify(pinfo%prev) - nullify(pinfo%next) + nullify(pinfo%prev) + nullify(pinfo%next) ! check if the list is empty ! - if (associated(block_array(idir,pmeta%process,pneigh%process)%ptr)) then + if (associated(block_array(pneigh%process & + ,pmeta%process)%ptr)) then + ! if it is, associate the newly created block with it ! - pinfo%prev => & - block_array(idir,pmeta%process,pneigh%process)%ptr + pinfo%prev => & + block_array(pneigh%process,pmeta%process)%ptr - end if ! %ptr associated + end if ! %ptr associated ! point the list to the newly created block ! - block_array(idir,pmeta%process,pneigh%process)%ptr => pinfo + block_array(pneigh%process,pmeta%process)%ptr => pinfo - end if ! pmeta and pneigh on local process + end if ! pmeta and pneigh on local process #endif /* MPI */ - end if ! pmeta level < pneigh level + end if ! pmeta level < pneigh level - end if ! pneigh associated + end if ! pneigh associated - end do ! iface - end do ! iside - end do ! idir + end do ! i = 1, nsides + end do ! j = 1, nsides +#if NDIMS == 3 + end do ! k = 1, nsides +#endif /* NDIMS == 3 */ + end do ! n = 1, ndims end if ! leaf -! associate the pointer with the next block +! associate pmeta with the next block ! pmeta => pmeta%next ! assign pointer to the next meta block in the list @@ -672,143 +767,116 @@ module boundaries ! do irecv = 0, npmax do isend = 0, npmax - do idir = 1, ndims ! process only pairs which have anything to exchange ! - if (block_counter(idir,irecv,isend) > 0) then + if (block_counter(isend,irecv) > 0) then ! obtain the number of blocks to exchange ! - nblocks = block_counter(idir,irecv,isend) + nblocks = block_counter(isend,irecv) ! prepare the tag for communication ! - itag = (irecv * nprocs + isend) * nprocs + idir + itag = 100 * (irecv * nprocs + isend) * nprocs -! allocate the buffer for variables depending on the direction +! allocate the buffer for variable exchange ! - select case(idir) - case(1) - allocate(rbuf(nblocks,nv,jm,km)) - case(2) - allocate(rbuf(nblocks,nv,im,km)) -#if NDIMS == 3 - case(3) - allocate(rbuf(nblocks,nv,im,jm)) -#endif /* NDIMS == 3 */ - end select + allocate(rbuf(nblocks,nv,ih,kh)) ! if isend == nproc we are sending data ! - if (isend == nproc) then + if (isend == nproc) then ! reset the block counter ! l = 0 -! fill out the buffer with the data from all blocks depepnding on the direction +! associate pinfo with the first block in the exchange list ! - select case(idir) - case(1) - -! associate the pointer with the first block in the exchange list -! - pinfo => block_array(idir,irecv,isend)%ptr + pinfo => block_array(isend,irecv)%ptr ! scan all blocks on the list ! - do while(associated(pinfo)) + do while(associated(pinfo)) ! increase the block count ! - l = l + 1 + l = l + 1 -! prepare the ghost layer index depending on the side +! associate pneigh pointer ! - if (pinfo%side == 1) then + pneigh => pinfo%neigh + +! get neighbor direction and corner coordinates +! + n = pinfo%direction + i = pinfo%corner(1) + j = pinfo%corner(2) +#if NDIMS == 3 + k = pinfo%corner(3) +#endif /* NDIMS == 3 */ + +! update directional flux from the neighbor +! + select case(n) + case(1) + +! prepare the boundary layer index depending on the side +! + if (i == 1) then is = ie else is = ibl end if -! fill the buffer with data from the current block +! update the flux edge from the neighbor at higher level ! - rbuf(l,:,:,:) = pinfo%neigh%data%f(idir,:,is,:,:) + call block_update_flux(i, j, k, n & + , pneigh%data%f(n,1:nv,is,jb:je,kb:ke) & + , rbuf(l,1:nv,1:jh,1:kh)) -! associate the pointer with the next block + case(2) + +! prepare the boundary layer index depending on the side ! - pinfo => pinfo%prev - - end do ! %ptr blocks - - case(2) - -! associate the pointer with the first block in the exchange list -! - pinfo => block_array(idir,irecv,isend)%ptr - -! scan all blocks on the list -! - do while(associated(pinfo)) - -! increase the block count -! - l = l + 1 - -! prepare the ghost layer index depending on the side -! - if (pinfo%side == 1) then + if (j == 1) then js = je else js = jbl end if -! fill the buffer with data from the current block +! update the flux edge from the neighbor at higher level ! - rbuf(l,:,:,:) = pinfo%neigh%data%f(idir,:,:,js,:) - -! associate the pointer with the next block -! - pinfo => pinfo%prev - - end do ! %ptr blocks + call block_update_flux(i, j, k, n & + , pneigh%data%f(n,1:nv,ib:ie,js,kb:ke) & + , rbuf(l,1:nv,1:ih,1:kh)) #if NDIMS == 3 - case(3) + case(3) -! associate the pointer with the first block in the exchange list +! prepare the boundary layer index depending on the side ! - pinfo => block_array(idir,irecv,isend)%ptr - -! scan all blocks on the list -! - do while(associated(pinfo)) - -! increase the block count -! - l = l + 1 - -! prepare the ghost layer index depending on the side -! - if (pinfo%side == 1) then + if (k == 1) then ks = ke else ks = kbl end if -! fill the buffer with data from the current block +! update the flux edge from the neighbor at higher level ! - rbuf(l,:,:,:) = pinfo%neigh%data%f(idir,:,:,:,ks) - -! associate the pointer with the next block -! - pinfo => pinfo%prev - - end do ! %ptr blocks + call block_update_flux(i, j, k, n & + , pneigh%data%f(n,1:nv,ib:ie,jb:je,ks) & + , rbuf(l,1:nv,1:ih,1:jh)) #endif /* NDIMS == 3 */ - end select + end select + +! associate pinfo with the next block +! + pinfo => pinfo%prev + + end do ! %ptr blocks ! send the data buffer to another process ! @@ -830,155 +898,169 @@ module boundaries ! l = 0 -! iterate over all received blocks and update fluxes depending on the direction +! associate pinfo with the first block in the exchange list ! - select case(idir) - case(1) - -! associate the pointer with the first block in the exchange list -! - pinfo => block_array(idir,irecv,isend)%ptr + pinfo => block_array(isend,irecv)%ptr ! scan all blocks on the list ! - do while(associated(pinfo)) + do while(associated(pinfo)) ! increase the block count ! - l = l + 1 + l = l + 1 -! set side and face indices +! associate pmeta pointer ! - iside = pinfo%side - iface = pinfo%face + pmeta => pinfo%block -! associate pointers to the meta block and neighbor +! get neighbor direction and corner indices ! - pmeta => pinfo%block - pneigh => pmeta%neigh(idir,iside,iface)%ptr - -! update fluxes -! - call correct_flux(pmeta%data, rbuf(l,:,:,:) & - , idir, iside, iface) - -! associate the pointer with the next block -! - pinfo => pinfo%prev - - end do ! %ptr blocks - - case(2) - -! associate the pointer with the first block in the exchange list -! - pinfo => block_array(idir,irecv,isend)%ptr - -! scan all blocks on the list -! - do while(associated(pinfo)) - -! increase the block count -! - l = l + 1 - -! set side and face indices -! - iside = pinfo%side - iface = pinfo%face - -! associate pointers to the meta block and neighbor -! - pmeta => pinfo%block - pneigh => pmeta%neigh(idir,iside,iface)%ptr - -! update fluxes -! - call correct_flux(pmeta%data, rbuf(l,:,:,:) & - , idir, iside, iface) - -! associate the pointer with the next block -! - pinfo => pinfo%prev - - end do ! %ptr blocks - + n = pinfo%direction + i = pinfo%corner(1) + j = pinfo%corner(2) #if NDIMS == 3 - case(3) - -! associate the pointer with the first block in the exchange list -! - pinfo => block_array(idir,irecv,isend)%ptr - -! scan all blocks on the list -! - do while(associated(pinfo)) - -! increase the block count -! - l = l + 1 - -! set side and face indices -! - iside = pinfo%side - iface = pinfo%face - -! associate pointers to the meta block and neighbor -! - pmeta => pinfo%block - pneigh => pmeta%neigh(idir,iside,iface)%ptr - -! update fluxes -! - call correct_flux(pmeta%data, rbuf(l,:,:,:) & - , idir, iside, iface) - -! associate the pointer with the next block -! - pinfo => pinfo%prev - - end do ! %ptr blocks + k = pinfo%corner(3) #endif /* NDIMS == 3 */ - end select +! update directional flux from the neighbor +! + select case(n) + case(1) + +! prepare the boundary layer indices depending on the corner position +! + if (i == 1) then + it = ibl + else + it = ie + end if + if (j == 1) then + jl = jb + ju = jb + jh - 1 + else + jl = je - jh + 1 + ju = je + end if +#if NDIMS == 3 + if (k == 1) then + kl = kb + ku = kb + kh - 1 + else + kl = ke - kh + 1 + ku = ke + end if +#endif /* NDIMS == 3 */ + +! update the flux edge from the neighbor at higher level +! + pmeta%data%f(n,1:nv,it,jl:ju,kl:ku) = rbuf(l,1:nv,1:jh,1:kh) + + case(2) + +! prepare the boundary layer indices depending on the corner position +! + if (i == 1) then + il = ib + iu = ib + ih - 1 + else + il = ie - ih + 1 + iu = ie + end if + if (j == 1) then + jt = jbl + else + jt = je + end if +#if NDIMS == 3 + if (k == 1) then + kl = kb + ku = kb + kh - 1 + else + kl = ke - kh + 1 + ku = ke + end if +#endif /* NDIMS == 3 */ + +! update the flux edge from the neighbor at higher level +! + pmeta%data%f(n,1:nv,il:iu,jt,kl:ku) = rbuf(l,1:nv,1:ih,1:kh) + +#if NDIMS == 3 + case(3) + +! prepare the boundary layer indices depending on the corner position +! + if (i == 1) then + il = ib + iu = ib + ih - 1 + else + il = ie - ih + 1 + iu = ie + end if + if (j == 1) then + jl = jb + ju = jb + jh - 1 + else + jl = je - jh + 1 + ju = je + end if + if (k == 1) then + kt = kbl + else + kt = ke + end if + +! update the flux edge from the neighbor at higher level +! + pmeta%data%f(n,1:nv,il:iu,jl:ju,kt) = rbuf(l,1:nv,1:ih,1:jh) +#endif /* NDIMS == 3 */ + + end select + +! associate pinfo with the next block +! + pinfo => pinfo%prev + + end do ! %ptr blocks end if ! irecv = nproc ! deallocate data buffer ! - deallocate(rbuf) + deallocate(rbuf) -! associate the pointer with the first block in the exchange list +! associate pinfo with the first block in the exchange list ! - pinfo => block_array(idir,irecv,isend)%ptr + pinfo => block_array(isend,irecv)%ptr ! scan all blocks on the exchange list ! - do while(associated(pinfo)) + do while(associated(pinfo)) ! associate the exchange list pointer ! - block_array(idir,irecv,isend)%ptr => pinfo%prev + block_array(isend,irecv)%ptr => pinfo%prev ! nullify pointer fields ! - nullify(pinfo%prev) - nullify(pinfo%next) - nullify(pinfo%block) - nullify(pinfo%neigh) + nullify(pinfo%prev) + nullify(pinfo%next) + nullify(pinfo%block) + nullify(pinfo%neigh) ! deallocate info block ! - deallocate(pinfo) + deallocate(pinfo) -! associate the pointer with the next block +! associate pinfo with the next block ! - pinfo => block_array(idir,irecv,isend)%ptr + pinfo => block_array(isend,irecv)%ptr - end do ! %ptr blocks + end do ! %ptr blocks + + end if ! if block_count > 0 - end if ! if block_count > 0 - end do ! idir end do ! isend end do ! irecv #endif /* MPI */ @@ -10410,26 +10492,27 @@ module boundaries ! !=============================================================================== ! -! subroutine CORRECT_FLUX: -! ----------------------- +! subroutine BLOCK_UPDATE_FLUX: +! ---------------------------- ! ! Subroutine updates the boundary flux from the provided flux array. ! ! Arguments: ! -! pdata - the input data block; -! f - the flux array; -! idir, iside, iface - the positions of the neighbor block; +! nc - the edge direction; +! ic, jc, kc - the corner position; +! fn - the correcting flux array; +! fb - the corrected flux array; ! !=============================================================================== ! - subroutine correct_flux(pdata, f, idir, iside, iface) + subroutine block_update_flux(nc, ic, jc, kc, fn, fb) ! import external procedures and variables ! use blocks , only : block_data - use coordinates , only : ng, in, jn, kn, ih, jh, kh & - , ib, jb, kb, ie, je, ke, ibl, jbl, kbl + use coordinates , only : in, jn, kn + use equations , only : nv ! local variables are not implicit by default ! @@ -10437,166 +10520,68 @@ module boundaries ! subroutine arguments ! - type(block_data), pointer , intent(inout) :: pdata - real , dimension(:,:,:), intent(in) :: f - integer , intent(in) :: idir, iside, iface - -! local variables -! - integer :: i, ic, it, il, iu, i1, i2 - integer :: j, jc, jt, jl, ju, j1, j2 -#if NDIMS == 3 - integer :: k, kc, kt, kl, ku, k1, k2 -#endif /* NDIMS == 3 */ + integer , intent(in) :: ic, jc, kc + integer , intent(in) :: nc + real(kind=8), dimension(:,:,:), intent(in) :: fn + real(kind=8), dimension(:,:,:), intent(inout) :: fb ! !------------------------------------------------------------------------------- ! ! update fluxes for each direction separately ! - select case(idir) + select case(nc) ! X direction ! case(1) -! index of the slice which will be updated -! - if (iside == 1) then ! left side - it = ibl - else ! right side - it = ie - end if - -! convert face number to index -! - jc = mod(iface - 1, 2) -#if NDIMS == 3 - kc = (iface - 1) / 2 -#endif /* NDIMS == 3 */ - -! bounds for the perpendicular update -! - jl = jb + (jh - ng) * jc - ju = jh + (jh - ng) * jc -#if NDIMS == 3 - kl = kb + (kh - ng) * kc - ku = kh + (kh - ng) * kc -#endif /* NDIMS == 3 */ - -! iterate over perpendicular direction -! - do j = jl, ju - j1 = 2 * (j - jl) + jb - j2 = j1 + 1 - #if NDIMS == 2 - pdata%f(idir,:,it,j,:) = 5.0d-01 * (f(:,j1,:) + f(:,j2,:)) +! average fluxes from higher level neighbor +! + fb(1:nv,:,:) = (fn(1:nv,1:jn:2,1:kn) + fn(1:nv,2:jn:2,1:kn)) / 2.0d+00 #endif /* NDIMS == 2 */ #if NDIMS == 3 - do k = kl, ku - k1 = 2 * (k - kl) + kb - k2 = k1 + 1 - - pdata%f(idir,:,it,j,k) = 2.5d-01 * ((f(:,j1,k1) + f(:,j2,k2)) & - + (f(:,j2,k1) + f(:,j1,k2))) - end do +! average fluxes from higher level neighbor +! + fb(1:nv,:,:) = ((fn(1:nv,1:in:2,1:kn:2) + fn(1:nv,2:in:2,2:kn:2)) & + + (fn(1:nv,1:in:2,2:kn:2) + fn(1:nv,2:in:2,1:kn:2))) & + / 4.0d+00 #endif /* NDIMS == 3 */ - end do ! Y direction ! case(2) -! index of the slice which will be updated -! - if (iside == 1) then ! left side - jt = jbl - else ! right side - jt = je - end if - -! convert face number to index -! - ic = mod(iface - 1, 2) -#if NDIMS == 3 - kc = (iface - 1) / 2 -#endif /* NDIMS == 3 */ - -! bounds for the perpendicular update -! - il = ib + (ih - ng) * ic - iu = ih + (ih - ng) * ic -#if NDIMS == 3 - kl = kb + (kh - ng) * kc - ku = kh + (kh - ng) * kc -#endif /* NDIMS == 3 */ - -! iterate over perpendicular direction -! - do i = il, iu - i1 = 2 * (i - il) + ib - i2 = i1 + 1 - #if NDIMS == 2 - pdata%f(idir,:,i,jt,:) = 5.0d-01 * (f(:,i1,:) + f(:,i2,:)) +! average fluxes from higher level neighbor +! + fb(1:nv,:,:) = (fn(1:nv,1:in:2,1:kn) + fn(1:nv,2:in:2,1:kn)) / 2.0d+00 #endif /* NDIMS == 2 */ #if NDIMS == 3 - do k = kl, ku - k1 = 2 * (k - kl) + kb - k2 = k1 + 1 - - pdata%f(idir,:,i,jt,k) = 2.5d-01 * ((f(:,i1,k1) + f(:,i2,k2)) & - + (f(:,i2,k1) + f(:,i1,k2))) - end do +! average fluxes from higher level neighbor +! + fb(1:nv,:,:) = ((fn(1:nv,1:in:2,1:kn:2) + fn(1:nv,2:in:2,2:kn:2)) & + + (fn(1:nv,1:in:2,2:kn:2) + fn(1:nv,2:in:2,1:kn:2))) & + / 4.0d+00 #endif /* NDIMS == 3 */ - end do #if NDIMS == 3 ! Z direction ! case(3) -! index of the slice which will be updated +! average fluxes from higher level neighbor ! - if (iside == 1) then ! left side - kt = kbl - else ! right side - kt = ke - end if - -! convert face number to index -! - ic = mod(iface - 1, 2) - jc = (iface - 1) / 2 - -! bounds for the perpendicular update -! - il = ib + (ih - ng) * ic - iu = ih + (ih - ng) * ic - jl = jb + (jh - ng) * jc - ju = jh + (jh - ng) * jc - -! iterate over perpendicular direction -! - do i = il, iu - i1 = 2 * (i - il) + ib - i2 = i1 + 1 - - do j = jl, ju - j1 = 2 * (j - jl) + jb - j2 = j1 + 1 - - pdata%f(idir,:,i,j,kt) = 2.5d-01 * ((f(:,i1,j1) + f(:,i2,j2)) & - + (f(:,i2,j1) + f(:,i1,j2))) - end do - end do + fb(1:nv,:,:) = ((fn(1:nv,1:in:2,1:jn:2) + fn(1:nv,2:in:2,2:jn:2)) & + + (fn(1:nv,1:in:2,2:jn:2) + fn(1:nv,2:in:2,1:jn:2))) & + / 4.0d+00 #endif /* NDIMS == 3 */ end select !------------------------------------------------------------------------------- ! - end subroutine correct_flux + end subroutine block_update_flux !=============================================================================== ! From b19352cb5ef4a030e5fdbe5827b44f43b4d2588e Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Wed, 23 Jul 2014 23:06:26 -0300 Subject: [PATCH 86/91] BOUNDARIES: Remove old boundary subroutines. All subroutines which use %neigh field of meta block have been removed, since the new format using %faces, %edges, and %corners is completed. Signed-off-by: Grzegorz Kowal --- src/boundaries.F90 | 3120 +++++--------------------------------------- 1 file changed, 301 insertions(+), 2819 deletions(-) diff --git a/src/boundaries.F90 b/src/boundaries.F90 index 9e4fae9..c9eac4a 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -281,8 +281,6 @@ module boundaries ! import external procedures and variables ! use blocks , only : ndims - use coordinates , only : toplev - use mpitools , only : periodic ! local variables are not implicit by default ! @@ -290,7 +288,7 @@ module boundaries ! local variables ! - integer :: idir, ilev + integer :: idir ! !------------------------------------------------------------------------------- ! @@ -300,52 +298,6 @@ module boundaries call start_timer(imv) #endif /* PROFILE */ -! step down from the top level -! - do ilev = toplev, 1, -1 - -! iterate over all directions -! - do idir = 1, ndims - -! update boundaries which don't have neighbors and which are not periodic -! - if (.not. periodic(idir)) call specific_boundaries(ilev, idir) - -! copy boundaries between blocks at the same levels -! - call copy_boundaries(ilev, idir) - - end do ! directions - -! restrict blocks from higher level neighbors -! - do idir = 1, ndims - - call restrict_boundaries(ilev - 1, idir) - - end do ! directions - - end do ! levels - -! step up from the first level -! - do ilev = 1, toplev - -! prolong boundaries from lower level neighbors -! - do idir = 1, ndims - - call prolong_boundaries(ilev, idir) - - end do ! boundaries - - end do ! levels - -! finally, update the corners -! - call update_corners() - ! update specific boundaries ! call boundaries_specific() @@ -1083,1838 +1035,9 @@ module boundaries ! !=============================================================================== ! -! subroutine UPDATE_CORNERS: -! ------------------------- -! -! Subroutine scans over all data blocks and updates their edges and corners. -! This is required since the boundary update by restriction leaves the corners -! untouched in some cases, which may result in unphysical values, like -! negative density or pressure. The edge/corner update should not influence -! the solution, but just assure, that the variables are physical in all -! cells. -! +! DOMAIN SPECIFIC BOUNDARY SUBROUTINES ! !=============================================================================== -! - subroutine update_corners() - -! include external variables -! - use blocks , only : block_data, list_data - use coordinates , only : im, jm, km, it, jt, kt, nh - use coordinates , only : ibl, jbl, kbl, ieu, jeu, keu - use equations , only : nv - -! local variables are not implicit by default -! - implicit none - -! local variables -! - integer :: i, j, k, p - -! local pointers -! - type(block_data), pointer :: pdata -! -!------------------------------------------------------------------------------- -! -! assign the pointer to the first block on the list -! - pdata => list_data - -! scan all data blocks until the last is reached -! - do while(associated(pdata)) - -! iterate over all variables -! - do p = 1, nv - -! edges -! -#if NDIMS == 3 - do i = 1, im - - pdata%q(p,i, 1:nh, 1:nh) = pdata%q(p,i,jbl,kbl) - pdata%q(p,i,jt:jm, 1:nh) = pdata%q(p,i,jeu,kbl) - pdata%q(p,i, 1:nh,kt:km) = pdata%q(p,i,jbl,keu) - pdata%q(p,i,jt:jm,kt:km) = pdata%q(p,i,jeu,keu) - - end do - - do j = 1, jm - - pdata%q(p, 1:nh,j, 1:nh) = pdata%q(p,ibl,j,kbl) - pdata%q(p,it:im,j, 1:nh) = pdata%q(p,ieu,j,kbl) - pdata%q(p, 1:nh,j,kt:km) = pdata%q(p,ibl,j,keu) - pdata%q(p,it:im,j,kt:km) = pdata%q(p,ieu,j,keu) - - end do -#endif /* == 3 */ - - do k = 1, km - - pdata%q(p, 1:nh, 1:nh,k) = pdata%q(p,ibl,jbl,k) - pdata%q(p,it:im, 1:nh,k) = pdata%q(p,ieu,jbl,k) - pdata%q(p, 1:nh,jt:jm,k) = pdata%q(p,ibl,jeu,k) - pdata%q(p,it:im,jt:jm,k) = pdata%q(p,ieu,jeu,k) - - end do - -! corners -! -#if NDIMS == 3 - pdata%q(p, 1:nh, 1:nh, 1:nh) = pdata%q(p,ibl,jbl,kbl) - pdata%q(p,it:im, 1:nh, 1:nh) = pdata%q(p,ieu,jbl,kbl) - pdata%q(p, 1:nh,jt:jm, 1:nh) = pdata%q(p,ibl,jeu,kbl) - pdata%q(p,it:im,jt:jm, 1:nh) = pdata%q(p,ieu,jeu,kbl) - pdata%q(p, 1:nh, 1:nh,kt:km) = pdata%q(p,ibl,jbl,keu) - pdata%q(p,it:im, 1:nh,kt:km) = pdata%q(p,ieu,jbl,keu) - pdata%q(p, 1:nh,jt:jm,kt:km) = pdata%q(p,ibl,jeu,keu) - pdata%q(p,it:im,jt:jm,kt:km) = pdata%q(p,ieu,jeu,keu) -#endif /* == 3 */ - - end do - -! assign the pointer to the next block on the list -! - pdata => pdata%next - - end do ! data blocks - -!------------------------------------------------------------------------------- -! - end subroutine update_corners -! -!=============================================================================== -! -! subroutine UPDATE_GHOST_CELLS: -! ----------------------------- -! -! Subroutine updates conservative variables in all ghost cells from -! already updated primitive variables. -! -! -!=============================================================================== -! - subroutine update_ghost_cells() - -! include external variables -! - use blocks , only : block_data, list_data - use coordinates , only : im , jm , km , in , jn , kn - use coordinates , only : ib , jb , kb , ie , je , ke - use coordinates , only : ibl, jbl, kbl, ieu, jeu, keu - use equations , only : nv - use equations , only : prim2cons - -! local variables are not implicit by default -! - implicit none - -! local variables -! - integer :: i, j, k - -! local pointers -! - type(block_data), pointer :: pdata -! -!------------------------------------------------------------------------------- -! -! assign the pointer to the first block on the list -! - pdata => list_data - -! scan all data blocks until the last is reached -! - do while(associated(pdata)) - -! update the X and Y boundary ghost cells -! - do k = 1, km - -! update lower layers of the Y boundary -! - do j = 1, jbl - call prim2cons(im, pdata%q(1:nv,1:im,j,k), pdata%u(1:nv,1:im,j,k)) - end do ! j = 1, jbl - -! update upper layers of the Y boundary -! - do j = jeu, jm - call prim2cons(im, pdata%q(1:nv,1:im,j,k), pdata%u(1:nv,1:im,j,k)) - end do ! j = jeu, jm - -! update remaining left layers of the X boundary -! - do i = 1, ibl - call prim2cons(jn, pdata%q(1:nv,i,jb:je,k), pdata%u(1:nv,i,jb:je,k)) - end do ! i = 1, ibl - -! update remaining right layers of the X boundary -! - do i = ieu, im - call prim2cons(jn, pdata%q(1:nv,i,jb:je,k), pdata%u(1:nv,i,jb:je,k)) - end do ! i = 1, ibl - - end do ! k = 1, km - -#if NDIMS == 3 -! update the Z boundary ghost cells -! - do j = jb, je - -! update the remaining front layers of the Z boundary -! - do k = 1, kbl - call prim2cons(in, pdata%q(1:nv,ib:ie,j,k), pdata%u(1:nv,ib:ie,j,k)) - end do ! k = 1, kbl - -! update the remaining back layers of the Z boundary -! - do k = keu, km - call prim2cons(in, pdata%q(1:nv,ib:ie,j,k), pdata%u(1:nv,ib:ie,j,k)) - end do ! k = keu, km - - end do ! j = jb, je -#endif /* NDIMS == 3 */ - -! assign the pointer to the next block on the list -! - pdata => pdata%next - - end do ! data blocks - -!------------------------------------------------------------------------------- -! - end subroutine update_ghost_cells -! -!=============================================================================== -! -! subroutine SPECIFIC_BOUNDARIES: -! ------------------------------ -! -! Subroutine scans over all leaf blocks in order to find blocks without -! neighbors, then updates the boundaries for selected type. -! -! Arguments: -! -! ilev - the level to be processed; -! idir - the direction to be processed; -! -!=============================================================================== -! - subroutine specific_boundaries(ilev, idir) - -! import external procedures and variables -! - use blocks , only : block_meta, list_meta - use blocks , only : nsides -#ifdef MPI - use mpitools , only : nproc -#endif /* MPI */ - -! local variables are not implicit by default -! - implicit none - -! subroutine arguments -! - integer, intent(in) :: ilev, idir - -! local pointers -! - type(block_meta), pointer :: pmeta, pneigh - -! local variables -! - integer :: iside -! -!------------------------------------------------------------------------------- -! -#ifdef PROFILE -! start accounting time for specific boundary update -! - call start_timer(ims) -#endif /* PROFILE */ - -! assign the pointer with the first block on the meta list -! - pmeta => list_meta - -! scan all data blocks until the last is reached -! - do while(associated(pmeta)) - -! check if the current meta block is a leaf -! - if (pmeta%leaf .and. pmeta%level == ilev) then - -! process only if this block is marked for update -! - if (pmeta%update) then - -#ifdef MPI -! check if the current block belongs to the local process -! - if (pmeta%process == nproc) then -#endif /* MPI */ - -! iterate over all neighbors -! - do iside = 1, nsides - -! assign a neighbor pointer to the current neighbor -! - pneigh => pmeta%neigh(idir,iside,1)%ptr - -! make sure that the neighbor is not associated, then apply specific boundaries -! - if (.not. associated(pneigh)) & - call boundary_specific(pmeta%data, idir, iside) - - end do ! sides - -#ifdef MPI - end if ! block belong to the local process -#endif /* MPI */ - - end if ! pmeta is marked for update - - end if ! leaf - -! assign the pointer to the next block on the list -! - pmeta => pmeta%next - - end do ! meta blocks - -#ifdef PROFILE -! stop accounting time for specific boundary update -! - call stop_timer(ims) -#endif /* PROFILE */ - -!------------------------------------------------------------------------------- -! - end subroutine specific_boundaries -! -!=============================================================================== -! -! subroutine COPY_BOUNDARIES: -! -------------------------- -! -! Subroutine scans over all leaf blocks in order to find neighbors at -! the same level, and then updates the boundaries between them. -! -! Arguments: -! -! ilev - the level to be processed; -! idir - the direction to be processed; -! -!=============================================================================== -! - subroutine copy_boundaries(ilev, idir) - -! import external procedures and variables -! - use blocks , only : ndims, nsides, nfaces - use blocks , only : block_meta, block_data, list_meta - use blocks , only : block_info, pointer_info - use coordinates , only : toplev - use coordinates , only : ng, nd, nh, im, jm, km - use coordinates , only : ib, jb, kb, ie, je, ke - use coordinates , only : ibu, jbu, kbu, iel, jel, kel -#ifdef MPI - use equations , only : nv -#endif /* MPI */ - use mpitools , only : nproc, nprocs, npmax, periodic -#ifdef MPI - use mpitools , only : send_real_array, receive_real_array -#endif /* MPI */ - -! local variables are not implicit by default -! - implicit none - -! subroutine arguments -! - integer, intent(in) :: ilev, idir - -! local pointers -! - type(block_meta), pointer :: pmeta, pneigh - type(block_data), pointer :: pdata -#ifdef MPI - type(block_info), pointer :: pinfo -#endif /* MPI */ - -! local variables -! - integer :: iside, iface, nside, nface - integer :: iret - integer :: il, jl, kl, iu, ju, ku -#ifdef MPI - integer :: isend, irecv, nblocks, itag, l - -! local pointer arrays -! - type(pointer_info), dimension(0:npmax,0:npmax) :: block_array - -! local arrays -! - integer , dimension(0:npmax,0:npmax) :: block_counter - real(kind=8), dimension(:,:,:,:,:), allocatable :: rbuf -#endif /* MPI */ -! -!------------------------------------------------------------------------------- -! -#ifdef PROFILE -! start accounting time for copy boundary update -! - call start_timer(imc) -#endif /* PROFILE */ - -#ifdef MPI -!! 1. PREPARE THE BLOCK EXCHANGE ARRAYS FOR MPI -!! -! reset the exchange block counters -! - block_counter(:,:) = 0 - -! nullify the info pointers -! - do irecv = 0, npmax - do isend = 0, npmax - nullify(block_array(irecv,isend)%ptr) - end do - end do -#endif /* MPI */ - -!! 2. UPDATE VARIABLE BOUNDARIES BETWEEN BLOCKS BELONGING TO THE SAME PROCESS -!! AND PREPARE THE EXCHANGE BLOCK LIST OF BLOCKS WHICH BELONG TO -!! DIFFERENT PROCESSES -!! -! assign the pointer to the first block on the meta block list -! - pmeta => list_meta - -! scan all meta blocks and process blocks at the current level -! - do while(associated(pmeta)) - -! check if the block is a leaf at the current level -! - if (pmeta%leaf .and. pmeta%level == ilev) then - -! scan over sides and faces -! - do iside = 1, nsides - do iface = 1, nfaces - -! assign a pointer to the neighbor -! - pneigh => pmeta%neigh(idir,iside,iface)%ptr - -! check if the neighbor is associated -! - if (associated(pneigh)) then - -! check if the neighbor is at the same level -! - if (pneigh%level == pmeta%level) then - -! process only if this block and its neighbor are marked for update -! - if (pmeta%update .and. pneigh%update) then - -! copy blocks only for the first face -! - if (iface == 1) then - -#ifdef MPI -! check if the current meta block and its neighbor belong to the same process -! - if (pmeta%process == pneigh%process) then - -! check if the current meta block belongs to the current process -! - if (pmeta%process == nproc) then -#endif /* MPI */ - -! assign a pointer to the data structure of the current block -! - pdata => pmeta%data - -! update boundaries of the current block -! - select case(idir) - case(1) - if (iside == 1) then - call boundary_copy(pdata & - , pneigh%data%q(:,iel:ie,:,:), idir, iside) - else - call boundary_copy(pdata & - , pneigh%data%q(:,ib:ibu,:,:), idir, iside) - end if - case(2) - if (iside == 1) then - call boundary_copy(pdata & - , pneigh%data%q(:,:,jel:je,:), idir, iside) - else - call boundary_copy(pdata & - , pneigh%data%q(:,:,jb:jbu,:), idir, iside) - end if -#if NDIMS == 3 - case(3) - if (iside == 1) then - call boundary_copy(pdata & - , pneigh%data%q(:,:,:,kel:ke), idir, iside) - else - call boundary_copy(pdata & - , pneigh%data%q(:,:,:,kb:kbu), idir, iside) - end if -#endif /* NDIMS == 3 */ - end select - -#ifdef MPI - end if ! pmeta on the current process - - else ! block and neighbor belong to different processes - -! increase the counter for number of blocks to exchange -! - block_counter(pmeta%process,pneigh%process) = & - block_counter(pmeta%process,pneigh%process) + 1 - -! allocate a new info object -! - allocate(pinfo) - -! fill out its fields -! - pinfo%block => pmeta - pinfo%neigh => pneigh - pinfo%direction = idir - pinfo%side = iside - pinfo%face = iface - pinfo%level_difference = pmeta%level - pneigh%level - -! nullify pointer fields -! - nullify(pinfo%prev) - nullify(pinfo%next) - -! if the list is not empty append the newly created block -! - if (associated(block_array(pmeta%process & - ,pneigh%process)%ptr)) & - pinfo%prev => block_array(pmeta%process & - ,pneigh%process)%ptr - -! point the list to the newly created block -! - block_array(pmeta%process,pneigh%process)%ptr => pinfo - - end if ! block and neighbor belong to different processes -#endif /* MPI */ - - end if ! iface = 1 - - end if ! pmeta and pneigh marked for update - - end if ! neighbor at the same level - - end if ! neighbor associated - - end do ! faces - end do ! sides - - end if ! leaf - -! associate the pointer to the next meta block -! - pmeta => pmeta%next - - end do ! meta blocks - -#ifdef MPI -!! 3. UPDATE VARIABLE BOUNDARIES BETWEEN BLOCKS BELONGING TO DIFFERENT PROCESSES -!! -! iterate over sending and receiving processors -! - do irecv = 0, npmax - do isend = 0, npmax - -! process only pairs which have boundaries to exchange -! - if (block_counter(irecv,isend) > 0) then - -! obtain the number of blocks to exchange -! - nblocks = block_counter(irecv,isend) - -! prepare the tag for communication -! - itag = 10 * (irecv * nprocs + isend + 1) + 4 - -! allocate data buffer for variables to exchange -! - select case(idir) - case(1) - allocate(rbuf(nblocks,nv,ng,jm,km)) - case(2) - allocate(rbuf(nblocks,nv,im,ng,km)) -#if NDIMS == 3 - case(3) - allocate(rbuf(nblocks,nv,im,jm,ng)) -#endif /* NDIMS == 3 */ - end select - -! if isend == nproc we are sending data -! - if (isend == nproc) then - -! reset the block counter -! - l = 0 - -! iterate over exchange blocks along the current direction and fill out -! the data buffer with the block variables -! - select case(idir) - - case(1) - -! associate the pointer with the first block in the exchange list -! - pinfo => block_array(irecv,isend)%ptr - -! scan over all blocks on the block exchange list -! - do while(associated(pinfo)) - -! increase the block counter -! - l = l + 1 - -! fill the buffer with data from the current block (depending on the side) -! - if (pinfo%side == 1) then - rbuf(l,:,:,:,:) = pinfo%neigh%data%q(:,iel:ie,:,:) - else - rbuf(l,:,:,:,:) = pinfo%neigh%data%q(:,ib:ibu,:,:) - end if - -! associate the pointer with the next block -! - pinfo => pinfo%prev - - end do ! %ptr block list - - case(2) - -! associate the pointer with the first block in the exchange list -! - pinfo => block_array(irecv,isend)%ptr - -! scan over all blocks on the block exchange list -! - do while(associated(pinfo)) - -! increase the block counter -! - l = l + 1 - -! fill the buffer with data from the current block (depending on the side) -! - if (pinfo%side == 1) then - rbuf(l,:,:,:,:) = pinfo%neigh%data%q(:,:,jel:je,:) - else - rbuf(l,:,:,:,:) = pinfo%neigh%data%q(:,:,jb:jbu,:) - end if - -! associate the pointer with the next block -! - pinfo => pinfo%prev - - end do ! %ptr block list - -#if NDIMS == 3 - case(3) - -! associate the pointer with the first block in the exchange list -! - pinfo => block_array(irecv,isend)%ptr - -! scan over all blocks on the block exchange list -! - do while(associated(pinfo)) - -! increase the block counter -! - l = l + 1 - -! fill the buffer with data from the current block (depending on the side) -! - if (pinfo%side == 1) then - rbuf(l,:,:,:,:) = pinfo%neigh%data%q(:,:,:,kel:ke) - else - rbuf(l,:,:,:,:) = pinfo%neigh%data%q(:,:,:,kb:kbu) - end if - -! associate the pointer with the next block -! - pinfo => pinfo%prev - - end do ! %ptr block list -#endif /* NDIMS == 3 */ - - end select - -! send the data buffer to another process -! - call send_real_array(size(rbuf), irecv, itag, rbuf(:,:,:,:,:), iret) - - end if ! isend = nproc - -! if irecv == nproc we are receiving data -! - if (irecv == nproc) then - -! receive the data buffer -! - call receive_real_array(size(rbuf(:,:,:,:,:)), isend, itag & - , rbuf(:,:,:,:,:), iret) - -! reset the block counter -! - l = 0 - -! associate the pointer with the first block in the exchange list -! - pinfo => block_array(irecv,isend)%ptr - -! iterate over all received blocks and update boundaries of the corresponding -! data blocks -! - do while(associated(pinfo)) - -! increase the block counter -! - l = l + 1 - -! set the side index -! - iside = pinfo%side - -! assign a pointer to the associated data block -! - pdata => pinfo%block%data - -! update the boundaries of the current block -! - call boundary_copy(pdata, rbuf(l,:,:,:,:), idir, iside) - -! associate the pointer with the next block -! - pinfo => pinfo%prev - - end do ! %ptr block list - - end if ! irecv = nproc - -! deallocate data buffer -! - if (allocated(rbuf)) deallocate(rbuf) - -! associate the pointer with the first block in the exchange list -! - pinfo => block_array(irecv,isend)%ptr - -! scan over all blocks on the exchange block list -! - do while(associated(pinfo)) - -! associate the exchange list pointer -! - block_array(irecv,isend)%ptr => pinfo%prev - -! nullify the pointer fields -! - nullify(pinfo%prev) - nullify(pinfo%next) - nullify(pinfo%block) - nullify(pinfo%neigh) - -! deallocate the object -! - deallocate(pinfo) - -! associate the pointer with the next block -! - pinfo => block_array(irecv,isend)%ptr - - end do ! %ptr block list - - end if ! if block_count > 0 - - end do ! isend - end do ! irecv -#endif /* MPI */ - -#ifdef PROFILE -! stop accounting time for copy boundary update -! - call stop_timer(imc) -#endif /* PROFILE */ - -!------------------------------------------------------------------------------- -! - end subroutine copy_boundaries -! -!=============================================================================== -! -! subroutine RESTRICT_BOUNDARIES: -! ------------------------------ -! -! Subroutine scans over all leaf blocks in order to find neighbors at -! different levels, then updates the boundaries of blocks at lower levels by -! restricting variables from higher level blocks. -! -! Arguments: -! -! ilev - the level to be processed; -! idir - the direction to be processed; -! -!=============================================================================== -! - subroutine restrict_boundaries(ilev, idir) - -! import external procedures and variables -! - use blocks , only : ndims, nsides, nfaces - use blocks , only : block_meta, block_data, list_meta - use blocks , only : block_info, pointer_info - use coordinates , only : toplev - use coordinates , only : ng, nd, nh, im, jm, km - use coordinates , only : ib, jb, kb, ie, je, ke - use coordinates , only : ibu, jbu, kbu, iel, jel, kel -#ifdef MPI - use equations , only : nv -#endif /* MPI */ - use mpitools , only : periodic -#ifdef MPI - use mpitools , only : nproc, nprocs, npmax - use mpitools , only : send_real_array, receive_real_array -#endif /* MPI */ - -! local variables are not implicit by default -! - implicit none - -! subroutine arguments -! - integer, intent(in) :: ilev, idir - -! local pointers -! - type(block_meta), pointer :: pmeta, pneigh - type(block_data), pointer :: pdata -#ifdef MPI - type(block_info), pointer :: pinfo -#endif /* MPI */ - -! local variables -! - integer :: iside, iface, nside, nface, level - integer :: iret - integer :: il, jl, kl, iu, ju, ku -#ifdef MPI - integer :: isend, irecv, nblocks, itag, l - -! local pointer arrays -! - type(pointer_info), dimension(0:npmax,0:npmax) :: block_array - -! local arrays -! - integer , dimension(0:npmax,0:npmax) :: block_counter - real(kind=8), dimension(:,:,:,:,:), allocatable :: rbuf -#endif /* MPI */ -! -!------------------------------------------------------------------------------- -! -#ifdef PROFILE -! start accounting time for restrict boundary update -! - call start_timer(imr) -#endif /* PROFILE */ - -#ifdef MPI -!! 1. PREPARE THE BLOCK EXCHANGE ARRAYS FOR MPI -!! -! reset the exchange block counters -! - block_counter(:,:) = 0 - -! nullify the info pointers -! - do irecv = 0, npmax - do isend = 0, npmax - nullify(block_array(irecv,isend)%ptr) - end do - end do -#endif /* MPI */ - -!! 2. UPDATE VARIABLE BOUNDARIES BETWEEN BLOCKS BELONGING TO THE SAME PROCESS -!! AND PREPARE THE EXCHANGE BLOCK LIST OF BLOCKS WHICH BELONG TO -!! DIFFERENT PROCESSES -!! -! assign the pointer to the first block on the meta block list -! - pmeta => list_meta - -! iterate over all meta blocks -! - do while(associated(pmeta)) - -! process only leafs from the current level -! - if (pmeta%leaf .and. pmeta%level == ilev) then - -! process all sides and faces -! - do iside = 1, nsides - do iface = 1, nfaces - -! assign the pointer to the current neighbor -! - pneigh => pmeta%neigh(idir,iside,iface)%ptr - -! check if the neighbor is associated -! - if (associated(pneigh)) then - -! continue, if the neighbor is at the higher level -! - if (pmeta%level < pneigh%level) then - -! process only if this block and its neighbor are marked for update -! - if (pmeta%update .and. pneigh%update) then - -#ifdef MPI -! check if the current meta block and its neighbor belong to the same process -! - if (pmeta%process == pneigh%process) then - -! check if the current meta block belongs to the current process -! - if (pmeta%process == nproc) then -#endif /* MPI */ - -! process each direction separatelly -! - select case(idir) - - case(1) - -! prepare indices of the neighbor slices used for the boundary update -! - if (iside == 1) then - il = ie - nd + 1 - iu = ie - else - il = ib - iu = ib + nd - 1 - end if - jl = 1 - ju = jm - kl = 1 - ku = km - - case(2) - -! prepare indices of the neighbor slices used for the boundary update -! - if (iside == 1) then - jl = je - nd + 1 - ju = je - else - jl = jb - ju = jb + nd - 1 - end if - il = 1 - iu = im - kl = 1 - ku = km - -#if NDIMS == 3 - case(3) - -! prepare indices of the neighbor slices used for the boundary update -! - if (iside == 1) then - kl = ke - nd + 1 - ku = ke - else - kl = kb - ku = kb + nd - 1 - end if - il = 1 - iu = im - jl = 1 - ju = jm -#endif /* NDIMS == 3 */ - end select - -! assign a pointer to the associate data block -! - pdata => pmeta%data - -! update boundaries of the current block -! - call boundary_restrict(pdata & - , pneigh%data%q(:,il:iu,jl:ju,kl:ku) & - , idir, iside, iface) - -#ifdef MPI - end if ! block on the current processor - - else ! block and neighbor on different processors - -! increase the counter for number of blocks to exchange -! - block_counter(pmeta%process,pneigh%process) = & - block_counter(pmeta%process,pneigh%process) + 1 - -! allocate a new info object -! - allocate(pinfo) - -! fill out its fields -! - pinfo%block => pmeta - pinfo%neigh => pneigh - pinfo%direction = idir - pinfo%side = iside - pinfo%face = iface - pinfo%level_difference = pmeta%level - pneigh%level - -! nullify pointers -! - nullify(pinfo%prev) - nullify(pinfo%next) - -! if the list is not empty append the created block -! - if (associated(block_array(pmeta%process & - ,pneigh%process)%ptr)) & - pinfo%prev => block_array(pmeta%process & - ,pneigh%process)%ptr - -! point the list to the last created block -! - block_array(pmeta%process,pneigh%process)%ptr => pinfo - - end if ! block and neighbor on different processors -#endif /* MPI */ - - end if ! pmeta and pneigh marked for update - - end if ! block at lower level than neighbor - - end if ! neighbor associated - - end do ! faces - end do ! sides - - end if ! leaf - -! assign the pointer to the next block on the list -! - pmeta => pmeta%next - - end do ! meta blocks - -#ifdef MPI -!! 3. UPDATE VARIABLE BOUNDARIES BETWEEN BLOCKS BELONGING TO DIFFERENT PROCESSES -!! -! iterate over sending and receiving processors -! - do irecv = 0, npmax - do isend = 0, npmax - -! process only pairs which have boundaries to exchange -! - if (block_counter(irecv,isend) > 0) then - -! obtain the number of blocks to exchange -! - nblocks = block_counter(irecv,isend) - -! prepare the tag for communication -! - itag = 10 * (irecv * nprocs + isend + 1) + 2 - -! allocate data buffer for block variable exchange -! - select case(idir) - case(1) - allocate(rbuf(nblocks,nv,nd,jm,km)) - case(2) - allocate(rbuf(nblocks,nv,im,nd,km)) - case(3) - allocate(rbuf(nblocks,nv,im,jm,nd)) - end select - -! if isend == nproc we are sending data -! - if (isend == nproc) then - -! reset the block counter -! - l = 0 - -! process each direction separately -! - select case(idir) - - case(1) - -! associate the pointer with the first block in the exchange list -! - pinfo => block_array(irecv,isend)%ptr - -! iterate over exchange blocks and fill out the data buffer with the block -! variables -! - do while(associated(pinfo)) - -! increase the block counter -! - l = l + 1 - -! prepare slice indices depending on the side -! - if (pinfo%side == 1) then - il = ie - nd + 1 - iu = ie - else - il = ib - iu = ib + nd - 1 - end if - -! fill the data buffer with the current block variable slices -! - rbuf(l,:,:,:,:) = pinfo%neigh%data%q(:,il:iu,:,:) - -! associate the pointer with the next block -! - pinfo => pinfo%prev - - end do ! %ptr block list - - case(2) - -! associate the pointer with the first block in the exchange list -! - pinfo => block_array(irecv,isend)%ptr - -! iterate over exchange blocks and fill out the data buffer with the block -! variables -! - do while(associated(pinfo)) - -! increase the block counter -! - l = l + 1 - -! prepare slice indices depending on the side -! - if (pinfo%side == 1) then - jl = je - nd + 1 - ju = je - else - jl = jb - ju = jb + nd - 1 - end if - -! fill the data buffer with the current block variable slices -! - rbuf(l,:,:,:,:) = pinfo%neigh%data%q(:,:,jl:ju,:) - -! associate the pointer with the next block -! - pinfo => pinfo%prev - - end do ! %ptr block list - -#if NDIMS == 3 - case(3) - -! associate the pointer with the first block in the exchange list -! - pinfo => block_array(irecv,isend)%ptr - -! iterate over exchange blocks and fill out the data buffer with the block -! variables -! - do while(associated(pinfo)) - -! increase the block counter -! - l = l + 1 - -! prepare slice indices depending on the side -! - if (pinfo%side == 1) then - kl = ke - nd + 1 - ku = ke - else - kl = kb - ku = kb + nd - 1 - end if - -! fill the data buffer with the current block variable slices -! - rbuf(l,:,:,:,:) = pinfo%neigh%data%q(:,:,:,kl:ku) - -! associate the pointer with the next block -! - pinfo => pinfo%prev - - end do ! %ptr block list -#endif /* NDIMS == 3 */ - - end select - -! send the data buffer to another process -! - call send_real_array(size(rbuf), irecv, itag, rbuf(:,:,:,:,:), iret) - - end if ! irecv = nproc - -! if irecv == nproc we are receiving data -! - if (irecv == nproc) then - -! receive the data buffer -! - call receive_real_array(size(rbuf(:,:,:,:,:)), isend, itag & - , rbuf(:,:,:,:,:), iret) - -! reset the block counter -! - l = 0 - -! associate the pointer with the first block in the exchange list -! - pinfo => block_array(irecv,isend)%ptr - -! iterate over all received blocks and update boundaries of the corresponding -! data blocks -! - do while(associated(pinfo)) - -! increase the block counter -! - l = l + 1 - -! set side and face indices -! - iside = pinfo%side - iface = pinfo%face - -! assign a pointer to the associated data block -! - pdata => pinfo%block%data - -! update the boundaries of the current block -! - call boundary_restrict(pdata, rbuf(l,:,:,:,:), idir, iside, iface) - -! associate the pointer with the next block -! - pinfo => pinfo%prev - - end do ! %ptr block list - - end if ! irecv = nproc - -! deallocate data buffer -! - if (allocated(rbuf)) deallocate(rbuf) - -! associate the pointer with the first block in the exchange list -! - pinfo => block_array(irecv,isend)%ptr - -! scan over all blocks on the exchange block list -! - do while(associated(pinfo)) - -! associate the exchange list pointer -! - block_array(irecv,isend)%ptr => pinfo%prev - -! nullify the pointer fields -! - nullify(pinfo%prev) - nullify(pinfo%next) - nullify(pinfo%block) - nullify(pinfo%neigh) - -! deallocate the object -! - deallocate(pinfo) - -! associate the pointer with the next block -! - pinfo => block_array(irecv,isend)%ptr - - end do ! %ptr block list - - end if ! if block_count > 0 - - end do ! isend - end do ! irecv -#endif /* MPI */ - -#ifdef PROFILE -! stop accounting time for restrict boundary update -! - call stop_timer(imr) -#endif /* PROFILE */ - -!------------------------------------------------------------------------------- -! - end subroutine restrict_boundaries -! -!=============================================================================== -! -! subroutine PROLONG_BOUNDARIES: -! ----------------------------- -! -! Subroutine scans over all leaf blocks and updates the variable boundaries -! from neighbor blocks laying at lower levels. -! -! Arguments: -! -! ilev - the level to be processed; -! idir - the direction to be processed; -! -!=============================================================================== -! - subroutine prolong_boundaries(ilev, idir) - -! import external procedures and variables -! - use blocks , only : ndims, nsides, nfaces - use blocks , only : block_meta, block_data, list_meta - use blocks , only : block_info, pointer_info - use coordinates , only : toplev - use coordinates , only : ng, nd, nh, im, jm, km - use coordinates , only : ib, jb, kb, ie, je, ke - use coordinates , only : ibu, jbu, kbu, iel, jel, kel -#ifdef MPI - use equations , only : nv - use mpitools , only : nproc, nprocs, npmax - use mpitools , only : send_real_array, receive_real_array -#endif /* MPI */ - -! local variables are not implicit by default -! - implicit none - -! subroutine arguments -! - integer, intent(in) :: ilev, idir - -! local pointers -! - type(block_meta), pointer :: pmeta, pneigh - type(block_data), pointer :: pdata -#ifdef MPI - type(block_info), pointer :: pinfo -#endif /* MPI */ - -! local variables -! - integer :: iside, iface, nside, nface - integer :: iret - integer :: il, jl, kl, iu, ju, ku -#ifdef MPI - integer :: isend, irecv, nblocks, itag, l - -! local pointer arrays -! - type(pointer_info), dimension(0:npmax,0:npmax) :: block_array - -! local arrays -! - integer , dimension(0:npmax,0:npmax) :: block_counter - real(kind=8), dimension(:,:,:,:,:), allocatable :: rbuf -#endif /* MPI */ -! -!------------------------------------------------------------------------------- -! -#ifdef PROFILE -! start accounting time for prolong boundary update -! - call start_timer(imp) -#endif /* PROFILE */ - -#ifdef MPI -!! 1. PREPARE THE BLOCK EXCHANGE ARRAYS FOR MPI -!! -! reset the exchange block counters -! - block_counter(:,:) = 0 - -! nullify the info pointers -! - do irecv = 0, npmax - do isend = 0, npmax - nullify(block_array(irecv,isend)%ptr) - end do - end do -#endif /* MPI */ - -!! 2. UPDATE VARIABLE BOUNDARIES BETWEEN BLOCKS BELONGING TO THE SAME PROCESS -!! AND PREPARE THE EXCHANGE BLOCK LIST OF BLOCKS WHICH BELONG TO -!! DIFFERENT PROCESSES -!! -! assign the pointer to the first block on the meta block list -! - pmeta => list_meta - -! iterate over all meta blocks -! - do while(associated(pmeta)) - -! check if the block is the leaf at level ilev -! - if (pmeta%leaf .and. pmeta%level == ilev) then - -! iterate over sides and faces -! - do iside = 1, nsides - do iface = 1, nfaces - -! assign a pointer to the current neighbor -! - pneigh => pmeta%neigh(idir,iside,iface)%ptr - -! check if the neighbor is associated -! - if (associated(pneigh)) then - -! check if the neighbor lays at lower level -! - if (pneigh%level < pmeta%level) then - -! process only if this block and its neighbor are marked for update -! - if (pmeta%update .and. pneigh%update) then - -! perform update only for the first face, since all faces point the same block -! - if (iface == 1) then - -#ifdef MPI -! check if the current meta block and its neighbor belong to the same process -! - if (pmeta%process == pneigh%process) then - -! check if the current meta block belong to the current process -! - if (pmeta%process == nproc) then -#endif /* MPI */ - -! find the neighbor side and face pointing to the current block -! - nside = 3 - iside - nface = 1 - do while(pmeta%id /= & - pneigh%neigh(idir,nside,nface)%ptr%id) - nface = nface + 1 - end do - -! prepare indices of the neighbor slices used for the boundary update -! - il = 1 - iu = im - jl = 1 - ju = jm - kl = 1 - ku = km - - select case(idir) - case(1) - if (iside == 1) then - il = ie - nh - iu = ie + 1 - else - il = ib - 1 - iu = ib + nh - end if - case(2) - if (iside == 1) then - jl = je - nh - ju = je + 1 - else - jl = jb - 1 - ju = jb + nh - end if - case(3) - if (iside == 1) then - kl = ke - nh - ku = ke + 1 - else - kl = kb - 1 - ku = kb + nh - end if - end select - -! assign a pointer to the associated data block -! - pdata => pmeta%data - -! update boundaries of the current block from its neighbor -! - call boundary_prolong(pdata & - , pneigh%data%q(:,il:iu,jl:ju,kl:ku) & - , idir, iside, nface) - -#ifdef MPI - end if ! pmeta on the current process - - else ! block and neighbor belong to different processes - -! increase the counter for the number of blocks to exchange -! - block_counter(pmeta%process,pneigh%process) = & - block_counter(pmeta%process,pneigh%process) + 1 - -! allocate a new info object -! - allocate(pinfo) - -! fill out its fields -! - pinfo%block => pmeta - pinfo%neigh => pneigh - pinfo%direction = idir - pinfo%side = iside - pinfo%face = iface - pinfo%level_difference = pmeta%level - pneigh%level - -! nullify pointers -! - nullify(pinfo%prev) - nullify(pinfo%next) - -! if the list is not empty append the newly created info object to it -! - if (associated(block_array(pmeta%process & - ,pneigh%process)%ptr)) & - pinfo%prev => block_array(pmeta%process & - ,pneigh%process)%ptr - -! point the list to the newly created info object -! - block_array(pmeta%process,pneigh%process)%ptr => pinfo - - end if ! block and neighbor belong to different processes -#endif /* MPI */ - - end if ! iface = 1 - - end if ! pmeta and pneigh marked for update - - end if ! neighbor belongs to lower level - - end if ! neighbor is associated - - end do ! faces - end do ! sides - - end if ! leaf at level ilev - -! associate the pointer with the next meta block -! - pmeta => pmeta%next - - end do ! meta blocks - -#ifdef MPI -!! 3. UPDATE VARIABLE BOUNDARIES BETWEEN BLOCKS BELONGING TO DIFFERENT PROCESSES -!! -! iterate over sending and receiving processes -! - do irecv = 0, npmax - do isend = 0, npmax - -! process only pairs which have anything to exchange -! - if (block_counter(irecv,isend) > 0) then - -! obtain the number of blocks to exchange -! - nblocks = block_counter(irecv,isend) - -! prepare the tag for communication -! - itag = 10 * (irecv * nprocs + isend + 1) + 3 - -! allocate data buffer for block variable exchange -! - select case(idir) - case(1) - allocate(rbuf(nblocks,nv,nh+2,jm,km)) - case(2) - allocate(rbuf(nblocks,nv,im,nh+2,km)) - case(3) - allocate(rbuf(nblocks,nv,im,jm,nh+2)) - end select - -! if isend == nproc we are sending data -! - if (isend == nproc) then - -! reset the block counter -! - l = 0 - -! process each direction separately -! - select case(idir) - - case(1) - -! associate the pointer with the first block in the exchange list -! - pinfo => block_array(irecv,isend)%ptr - -! iterate over exchange blocks and fill out the data buffer with the block -! variables -! - do while(associated(pinfo)) - -! increase the block counter -! - l = l + 1 - -! prepare slice indices depending on the side -! - if (pinfo%side == 1) then - il = ie - nh - iu = ie + 1 - else - il = ib - 1 - iu = ib + nh - end if - -! fill the data buffer with the current block variable slices -! - rbuf(l,:,:,:,:) = pinfo%neigh%data%q(:,il:iu,:,:) - -! associate the pointer with the next block -! - pinfo => pinfo%prev - - end do ! %ptr block list - - case(2) - -! associate the pointer with the first block in the exchange list -! - pinfo => block_array(irecv,isend)%ptr - -! iterate over exchange blocks and fill out the data buffer with the block -! variables -! - do while(associated(pinfo)) - -! increase the block counter -! - l = l + 1 - -! prepare slice indices depending on the side -! - if (pinfo%side == 1) then - jl = je - nh - ju = je + 1 - else - jl = jb - 1 - ju = jb + nh - end if - -! fill the data buffer with the current block variable slices -! - rbuf(l,:,:,:,:) = pinfo%neigh%data%q(:,:,jl:ju,:) - -! associate the pointer with the next block -! - pinfo => pinfo%prev - - end do ! %ptr block list - -#if NDIMS == 3 - case(3) - -! associate the pointer with the first block in the exchange list -! - pinfo => block_array(irecv,isend)%ptr - -! iterate over exchange blocks and fill out the data buffer with the block -! variables -! - do while(associated(pinfo)) - -! increase the block counter -! - l = l + 1 - -! prepare slice indices depending on the side -! - if (pinfo%side == 1) then - kl = ke - nh - ku = ke + 1 - else - kl = kb - 1 - ku = kb + nh - end if - -! fill the data buffer with the current block variable slices -! - rbuf(l,:,:,:,:) = pinfo%neigh%data%q(:,:,:,kl:ku) - -! associate the pointer with the next block -! - pinfo => pinfo%prev - - end do ! %ptr block list -#endif /* NDIMS == 3 */ - - end select - -! send the data buffer to another process -! - call send_real_array(size(rbuf), irecv, itag, rbuf(:,:,:,:,:), iret) - - end if ! irecv = nproc - -! if irecv == nproc we are receiving data -! - if (irecv == nproc) then - -! receive the data buffer -! - call receive_real_array(size(rbuf(:,:,:,:,:)), isend, itag & - , rbuf(:,:,:,:,:), iret) - -! reset the block counter -! - l = 0 - -! associate the pointer with the first block in the exchange list -! - pinfo => block_array(irecv,isend)%ptr - -! iterate over all received blocks and update boundaries of the corresponding -! data blocks -! - do while(associated(pinfo)) - -! increase the block counter -! - l = l + 1 - -! set side and face indices -! - iside = pinfo%side - iface = pinfo%face - -! assign pointers to the meta, data and neighbor blocks -! - pmeta => pinfo%block - pdata => pinfo%block%data - pneigh => pmeta%neigh(idir,iside,iface)%ptr - -! find the neighbor side and face pointing to the current block -! - nside = 3 - iside - nface = 1 - do while(pmeta%id /= pneigh%neigh(idir,nside,nface)%ptr%id) - nface = nface + 1 - end do - -! update the boundaries of the current block -! - call boundary_prolong(pdata, rbuf(l,:,:,:,:) & - , idir, iside, nface) - -! associate the pointer with the next block -! - pinfo => pinfo%prev - - end do ! %ptr block list - - end if ! irecv = nproc - -! deallocate the data buffer -! - if (allocated(rbuf)) deallocate(rbuf) - -! associate the pointer with the first block in the exchange list -! - pinfo => block_array(irecv,isend)%ptr - -! iterate over all objects on the exchange list -! - do while(associated(pinfo)) - -! associate the exchange list pointer -! - block_array(irecv,isend)%ptr => pinfo%prev - -! nullify the pointer fields -! - nullify(pinfo%prev) - nullify(pinfo%next) - nullify(pinfo%block) - nullify(pinfo%neigh) - -! deallocate the object -! - deallocate(pinfo) - -! associate the pointer with the next block -! - pinfo => block_array(irecv,isend)%ptr - - end do ! %ptr block list - - end if ! if block_count > 0 - - end do ! isend - end do ! irecv -#endif /* MPI */ - -#ifdef PROFILE -! stop accounting time for prolong boundary update -! - call stop_timer(imp) -#endif /* PROFILE */ - -!------------------------------------------------------------------------------- -! - end subroutine prolong_boundaries ! !=============================================================================== ! @@ -3070,6 +1193,8 @@ module boundaries ! !=============================================================================== ! +!=============================================================================== +! ! subroutine BOUNDARIES_FACE_COPY: ! ------------------------------- ! @@ -4745,6 +2870,8 @@ module boundaries ! !=============================================================================== ! +!=============================================================================== +! ! subroutine BOUNDARIES_EDGE_COPY: ! ------------------------------- ! @@ -6497,6 +4624,8 @@ module boundaries ! !=============================================================================== ! +!=============================================================================== +! ! subroutine BOUNDARIES_CORNER_COPY: ! --------------------------------- ! @@ -7878,28 +6007,29 @@ module boundaries ! !=============================================================================== ! -! BLOCK BOUNDARY UPDATE SUBROUTINES +! BLOCK SPECIFIC BOUNDARY SUBROUTINES ! !=============================================================================== ! -! subroutine BOUNDARY_SPECIFIC: -! ---------------------------- +!=============================================================================== +! +! subroutine BLOCK_BOUNDARY_SPECIFIC: +! ---------------------------------- ! ! Subroutine applies specific boundary conditions to the pointed data block. ! ! Arguments: ! -! pdata - the pointer to modified data block; -! idir - the direction to be processed; -! iside - the side to be processed; +! nc - the edge direction; +! ic, jc, kc - the corner position; +! qn - the variable array; ! !=============================================================================== ! - subroutine boundary_specific(pdata, idir, iside) + subroutine block_boundary_specific(ic, jc, kc, nc, qn) ! import external procedures and variables ! - use blocks , only : block_data use coordinates , only : im , jm , km , ng use coordinates , only : ib , jb , kb , ie , je , ke use coordinates , only : ibl, jbl, kbl, ieu, jeu, keu @@ -7913,739 +6043,259 @@ module boundaries ! subroutine arguments ! - type(block_data), pointer, intent(inout) :: pdata - integer , intent(in) :: idir, iside + integer , intent(in) :: ic, jc, kc + integer , intent(in) :: nc + real(kind=8), dimension(1:nv,1:im,1:jm,1:km), intent(inout) :: qn ! local variables ! - integer :: ii, i, j, k, it, jt, kt, is, js, ks + integer :: i , j , k + integer :: il, jl, kl + integer :: iu, ju, ku + integer :: is, js, ks + integer :: it, jt, kt ! !------------------------------------------------------------------------------- ! -! prepare a direction/side index +! apply specific boundaries depending on the direction ! - ii = 10 * idir + iside + select case(nc) + case(1) -! perform update depending on the direction/side flag +! prepare indices for the boundaries ! - select case(ii) - -! left side along the X direction -! - case(11) + if (jc == 1) then + jl = 1 + ju = jm / 2 - 1 + else + jl = jm / 2 + ju = jm + end if +#if NDIMS == 3 + if (kc == 1) then + kl = 1 + ku = km / 2 - 1 + else + kl = km / 2 + ku = km + end if +#else /* NDIMS == 3 */ + kl = 1 + ku = km +#endif /* NDIMS == 3 */ ! apply selected boundary condition ! - select case(bnd_type(idir,iside)) + select case(bnd_type(nc,ic)) ! "open" boundary conditions ! case(bnd_open) - do i = 1, ng - pdata%q( :,i,:,:) = pdata%q(:,ib,:,:) - end do + if (ic == 1) then + do i = ibl, 1, -1 + qn(1:nv,i,jl:ju,kl:ku) = qn(1:nv,ib,jl:ju,kl:ku) + end do + else + do i = ieu, im + qn(1:nv,i,jl:ju,kl:ku) = qn(1:nv,ie,jl:ju,kl:ku) + end do + end if ! "reflective" boundary conditions ! case(bnd_reflective) - do i = 1, ng + if (ic == 1) then + do i = 1, ng + it = ib - i + is = ibl + i - it = ib - i - is = ibl + i + qn(1:nv,it,jl:ju,kl:ku) = qn(1:nv,is,jl:ju,kl:ku) + qn(ivx ,it,jl:ju,kl:ku) = - qn(ivx ,is,jl:ju,kl:ku) + end do + else + do i = 1, ng + it = ie + i + is = ieu - i - pdata%q( :,it,:,:) = pdata%q( :,is,:,:) - pdata%q(ivx,it,:,:) = - pdata%q(ivx,is,:,:) - - end do + qn(1:nv,it,jl:ju,kl:ku) = qn(1:nv,is,jl:ju,kl:ku) + qn(ivx ,it,jl:ju,kl:ku) = - qn(ivx ,is,jl:ju,kl:ku) + end do + end if ! wrong boundary conditions ! case default - call print_error("boundaries:boundary_specific()" & + if (ic == 1) then + call print_error("boundaries:boundary_specific()" & , "Wrong left X boundary type!") + else + call print_error("boundaries:boundary_specific()" & + , "Wrong right X boundary type!") + end if end select -! right side along the X direction + case(2) + +! prepare indices for the boundaries ! - case(12) + if (ic == 1) then + il = 1 + iu = im / 2 - 1 + else + il = im / 2 + iu = im + end if +#if NDIMS == 3 + if (kc == 1) then + kl = 1 + ku = km / 2 - 1 + else + kl = km / 2 + ku = km + end if +#else /* NDIMS == 3 */ + kl = 1 + ku = km +#endif /* NDIMS == 3 */ ! apply selected boundary condition ! - select case(bnd_type(idir,iside)) + select case(bnd_type(nc,jc)) ! "open" boundary conditions ! case(bnd_open) - do i = ieu, im - pdata%q( :,i ,:,:) = pdata%q( :,ie,:,:) - end do + if (jc == 1) then + do j = jbl, 1, -1 + qn(1:nv,il:iu,j,kl:ku) = qn(1:nv,il:iu,jb,kl:ku) + end do + else + do j = jeu, jm + qn(1:nv,il:iu,j,kl:ku) = qn(1:nv,il:iu,je,kl:ku) + end do + end if ! "reflective" boundary conditions ! case(bnd_reflective) - do i = 1, ng - it = ie + i - is = ieu - i + if (jc == 1) then + do j = 1, ng + jt = jb - j + js = jbl + j - pdata%q( :,it,:,:) = pdata%q( :,is,:,:) - pdata%q(ivx,it,:,:) = - pdata%q(ivx,is,:,:) - end do + qn(1:nv,il:iu,jt,kl:ku) = qn(1:nv,il:iu,js,kl:ku) + qn(ivy ,il:iu,jt,kl:ku) = - qn(ivy ,il:iu,js,kl:ku) + end do + else + do j = 1, ng + jt = je + j + js = jeu - j + + qn(1:nv,il:iu,jt,kl:ku) = qn(1:nv,il:iu,js,kl:ku) + qn(ivy ,il:iu,jt,kl:ku) = - qn(ivy ,il:iu,js,kl:ku) + end do + end if ! wrong boundary conditions ! case default - call print_error("boundaries:boundary_specific()" & - , "Wrong right X boundary type!") - - end select - -! left side along the Y direction -! - case(21) - -! apply selected boundary condition -! - select case(bnd_type(idir,iside)) - -! "open" boundary conditions -! - case(bnd_open) - - do j = 1, ng - pdata%q( :,:,j ,:) = pdata%q( :,:,jb,:) - end do - -! "reflective" boundary conditions -! - case(bnd_reflective) - - do j = 1, ng - jt = jb - j - js = jbl + j - - pdata%q( :,:,jt,:) = pdata%q( :,:,js,:) - pdata%q(ivy,:,jt,:) = - pdata%q(ivy,:,js,:) - end do - -! wrong boundary conditions -! - case default - - call print_error("boundaries:boundary_specific()" & + if (jc == 1) then + call print_error("boundaries:boundary_specific()" & , "Wrong left Y boundary type!") - - end select - -! right side along the Y direction -! - case(22) - -! apply selected boundary condition -! - select case(bnd_type(idir,iside)) - -! "open" boundary conditions -! - case(bnd_open) - - do j = jeu, jm - pdata%q( :,:,j ,:) = pdata%q( :,:,je,:) - end do - -! "reflective" boundary conditions -! - case(bnd_reflective) - - do j = 1, ng - jt = je + j - js = jeu - j - - pdata%q( :,:,jt,:) = pdata%q( :,:,js,:) - pdata%q(ivy,:,jt,:) = - pdata%q(ivy,:,js,:) - end do - -! wrong boundary conditions -! - case default - - call print_error("boundaries:boundary_specific()" & - , "Wrong right Y boundary type!") + else + call print_error("boundaries:boundary_specific()" & + , "Wrong right Y boundary type!") + end if end select #if NDIMS == 3 -! left side along the Z direction + case(3) + +! prepare indices for the boundaries ! - case(31) + if (ic == 1) then + il = 1 + iu = im / 2 - 1 + else + il = im / 2 + iu = im + end if + if (jc == 1) then + jl = 1 + ju = jm / 2 - 1 + else + jl = jm / 2 + ju = jm + end if ! apply selected boundary condition ! - select case(bnd_type(idir,iside)) + select case(bnd_type(nc,kc)) ! "open" boundary conditions ! case(bnd_open) - do k = 1, ng - pdata%q( :,:,:,k ) = pdata%q( :,:,:,kb) - end do + if (kc == 1) then + do k = kbl, 1, -1 + qn(1:nv,il:iu,jl:ju,k) = qn(1:nv,il:iu,jl:ju,kb) + end do + else + do k = keu, km + qn(1:nv,il:iu,jl:ju,k) = qn(1:nv,il:iu,jl:ju,ke) + end do + end if ! "reflective" boundary conditions ! case(bnd_reflective) - do k = 1, ng - kt = kb - k - ks = kbl + k + if (kc == 1) then + do k = 1, ng + kt = kb - k + ks = kbl + k - pdata%q( :,:,:,kt) = pdata%q( :,:,:,ks) - pdata%q(ivz,:,:,kt) = - pdata%q(ivz,:,:,ks) - end do + qn(1:nv,il:iu,jl:ju,kt) = qn(1:nv,il:iu,jl:ju,ks) + qn(ivz ,il:iu,jl:ju,kt) = - qn(ivz ,il:iu,jl:ju,ks) + end do + else + do k = 1, ng + kt = ke + k + ks = keu - k + + qn(1:nv,il:iu,jl:ju,kt) = qn(1:nv,il:iu,jl:ju,ks) + qn(ivz ,il:iu,jl:ju,kt) = - qn(ivz ,il:iu,jl:ju,ks) + end do + end if ! wrong boundary conditions ! case default - call print_error("boundaries:boundary_specific()" & + if (kc == 1) then + call print_error("boundaries:boundary_specific()" & , "Wrong left Z boundary type!") + else + call print_error("boundaries:boundary_specific()" & + , "Wrong right Z boundary type!") + end if end select -! right side along the Z direction -! - case(32) - -! apply selected boundary condition -! - select case(bnd_type(idir,iside)) - -! "open" boundary conditions -! - case(bnd_open) - - do k = keu, km - pdata%q( :,:,:,k ) = pdata%q( :,:,:,ke) - end do - -! "reflective" boundary conditions -! - case(bnd_reflective) - - do k = 1, ng - kt = ke + k - ks = keu - k - - pdata%q( :,:,:,kt) = pdata%q( :,:,:,ks) - pdata%q(ivz,:,:,kt) = - pdata%q(ivz,:,:,ks) - end do - -! wrong boundary conditions -! - case default - - call print_error("boundaries:boundary_specific()" & - , "Wrong right Z boundary type!") - - end select #endif /* NDIMS == 3 */ - - case default - -! print error if the direction/side flag is wrong -! - call print_warning("boundaries::boundary_specific" & - , "Wrong direction or side of the boundary condition!") - end select !------------------------------------------------------------------------------- ! - end subroutine boundary_specific -! -!=============================================================================== -! -! subroutine BOUNDARY_COPY: -! ------------------------ -! -! Subroutine updates boundaries by copying them from the provided array. -! -! Arguments: -! -! pdata - the pointer to modified data block; -! q - the variable array from which boundaries are updated; -! idir - the direction to be processed; -! iside - the side to be processed; -! -!=============================================================================== -! - subroutine boundary_copy(pdata, q, idir, iside) - -! import external procedures and variables -! - use blocks , only : block_data - use coordinates , only : ng, im, jm, km, ibl, ieu, jbl, jeu, kbl, keu - use equations , only : nv - -! local variables are not implicit by default -! - implicit none - -! subroutine arguments -! - type(block_data), pointer , intent(inout) :: pdata - real , dimension(:,:,:,:), intent(in) :: q - integer , intent(in) :: idir, iside -! -!------------------------------------------------------------------------------- -! -! update boundaries depending on the direction -! - select case(idir) - - case(1) - - if (iside == 1) then - pdata%q(1:nv, 1:ibl,1:jm,1:km) = q(1:nv,1:ng,1:jm,1:km) - else - pdata%q(1:nv,ieu:im ,1:jm,1:km) = q(1:nv,1:ng,1:jm,1:km) - end if - - case(2) - - if (iside == 1) then - pdata%q(1:nv,1:im, 1:jbl,1:km) = q(1:nv,1:im,1:ng,1:km) - else - pdata%q(1:nv,1:im,jeu:jm ,1:km) = q(1:nv,1:im,1:ng,1:km) - end if - -#if NDIMS == 3 - case(3) - - if (iside == 1) then - pdata%q(1:nv,1:im,1:jm, 1:kbl) = q(1:nv,1:im,1:jm,1:ng) - else - pdata%q(1:nv,1:im,1:jm,keu:km ) = q(1:nv,1:im,1:jm,1:ng) - end if -#endif /* NDIMS == 3 */ - - end select - -!------------------------------------------------------------------------------- -! - end subroutine boundary_copy -! -!=============================================================================== -! -! subroutine BOUNDARY_RESTRICT: -! ---------------------------- -! -! Subroutine updates the data block boundaries by restricting the data from -! the provided variable array. The process of data restriction conserves -! stored variables. -! -! Arguments: -! -! pdata - the input data block; -! q - the variable array from which boundaries are updated; -! idir, iside, iface - the positions of the neighbor block; -! -!=============================================================================== -! - subroutine boundary_restrict(pdata, q, idir, iside, iface) - -! import external procedures and variables -! - use blocks , only : block_data - use coordinates , only : ng, im, ih, ib, ie, ieu & - , nd, jm, jh, jb, je, jeu & - , nh, km, kh, kb, ke, keu - use equations , only : nv - -! local variables are not implicit by default -! - implicit none - -! subroutine arguments -! - type(block_data) , pointer, intent(inout) :: pdata - real(kind=8) , dimension(:,:,:,:), intent(in) :: q - integer , intent(in) :: idir, iside, iface - -! local variables -! - integer :: ic, jc, kc, ip, jp, kp - integer :: il, jl, kl, iu, ju, ku - integer :: is, js, ks, it, jt, kt -! -!------------------------------------------------------------------------------- -! -! prepare indices -! - select case(idir) - - case(1) - -! X indices -! - if (iside == 1) then - is = 1 - it = ng - else - is = ieu - it = im - end if - - il = 1 - iu = nd - ip = il + 1 - -! Y indices -! - jc = mod(iface - 1, 2) - - js = jb - nh + (jh - nh) * jc - jt = jh + (jh - nh) * jc - - jl = 1 + ng * jc - ju = je + ng * jc - jp = jl + 1 - -#if NDIMS == 3 -! Z indices -! - kc = (iface - 1) / 2 - - ks = kb - nh + (kh - nh) * kc - kt = kh + (kh - nh) * kc - - kl = 1 + ng * kc - ku = ke + ng * kc - kp = kl + 1 -#endif /* NDIMS == 3 */ - - case(2) - -! X indices -! - ic = mod(iface - 1, 2) - - is = ib - nh + (ih - nh) * ic - it = ih + (ih - nh) * ic - - il = 1 + ng * ic - iu = ie + ng * ic - ip = il + 1 - -! Y indices -! - if (iside == 1) then - js = 1 - jt = ng - else - js = jeu - jt = jm - end if - - jl = 1 - ju = nd - jp = jl + 1 - -#if NDIMS == 3 -! Z indices -! - kc = (iface - 1) / 2 - - ks = kb - nh + (kh - nh) * kc - kt = kh + (kh - nh) * kc - - kl = 1 + ng * kc - ku = ke + ng * kc - kp = kl + 1 -#endif /* NDIMS == 3 */ - -#if NDIMS == 3 - case(3) - -! X indices -! - ic = mod(iface - 1, 2) - - is = ib - nh + (ih - nh) * ic - it = ih + (ih - nh) * ic - - il = 1 + ng * ic - iu = ie + ng * ic - ip = il + 1 - -! Y indices -! - jc = (iface - 1) / 2 - - js = jb - nh + (jh - nh) * jc - jt = jh + (jh - nh) * jc - - jl = 1 + ng * jc - ju = je + ng * jc - jp = jl + 1 - -! Z indices -! - if (iside == 1) then - ks = 1 - kt = ng - else - ks = keu - kt = km - end if - - kl = 1 - ku = nd - kp = kl + 1 -#endif /* NDIMS == 3 */ - - end select - -! update boundaries of the conserved variables -! -#if NDIMS == 2 - pdata%q(:,is:it,js:jt, 1 ) = & - 2.50d-01 * ((q(1:nv,il:iu:2,jl:ju:2, 1 ) & - + q(1:nv,ip:iu:2,jp:ju:2, 1 )) & - + (q(1:nv,il:iu:2,jp:ju:2, 1 ) & - + q(1:nv,ip:iu:2,jl:ju:2, 1 ))) -#endif /* NDIMS == 2 */ -#if NDIMS == 3 - pdata%q(:,is:it,js:jt,ks:kt) = & - 1.25d-01 * (((q(1:nv,il:iu:2,jl:ju:2,kl:ku:2) & - + q(1:nv,ip:iu:2,jp:ju:2,kp:ku:2)) & - + (q(1:nv,il:iu:2,jl:ju:2,kp:ku:2) & - + q(1:nv,ip:iu:2,jp:ju:2,kl:ku:2))) & - + ((q(1:nv,il:iu:2,jp:ju:2,kp:ku:2) & - + q(1:nv,ip:iu:2,jl:ju:2,kl:ku:2)) & - + (q(1:nv,il:iu:2,jp:ju:2,kl:ku:2) & - + q(1:nv,ip:iu:2,jl:ju:2,kp:ku:2)))) -#endif /* NDIMS == 3 */ - -!------------------------------------------------------------------------------- -! - end subroutine boundary_restrict -! -!=============================================================================== -! -! subroutine BOUNDARY_PROLONG: -! --------------------------- -! -! Subroutine updates the data block boundaries by prolonging the data from -! the provided variable array. The process of data restriction conserves -! stored variables. -! -! Arguments: -! -! pdata - the input data block; -! q - the variable array from which boundaries are updated; -! idir, iside, iface - the positions of the neighbor block; -! -!=============================================================================== -! - subroutine boundary_prolong(pdata, q, idir, iside, iface) - -! import external procedures and variables -! - use blocks , only : block_data - use coordinates , only : ng, im, ih, ib, ie, ieu & - , nd, jm, jh, jb, je, jeu & - , nh, km, kh, kb, ke, keu - use equations , only : nv - use interpolations , only : limiter - -! local variables are not implicit by default -! - implicit none - -! subroutine arguments -! - type(block_data), pointer , intent(inout) :: pdata - real , dimension(:,:,:,:), intent(in) :: q - integer , intent(in) :: idir, iside, iface - -! local variables -! - integer :: i, j, k, p - integer :: ic, jc, kc, ip, jp, kp - integer :: il, jl, kl, iu, ju, ku - integer :: is, js, ks, it, jt, kt - real :: dql, dqr, dqx, dqy, dqz, dq1, dq2, dq3, dq4 -! -!------------------------------------------------------------------------------- -! -! prepare indices depending on the direction -! - select case(idir) - - case(1) - -! X indices -! - if (iside == 1) then - is = 1 - else - is = ieu - end if - - il = 2 - iu = 1 + nh - -! Y indices -! - jc = mod(iface - 1, 2) - js = jb - jl = jb + (jh - ng) * jc - ju = jh + (jh - ng) * jc - -#if NDIMS == 3 -! Z indices -! - kc = (iface - 1) / 2 - ks = kb - kl = kb + (kh - ng) * kc - ku = kh + (kh - ng) * kc -#endif /* NDIMS == 3 */ - - case(2) - -! X indices -! - ic = mod(iface - 1, 2) - is = ib - il = ib + (ih - ng) * ic - iu = ih + (ih - ng) * ic - -! Y indices -! - if (iside == 1) then - js = 1 - else - js = jeu - end if - - jl = 2 - ju = 1 + nh - -#if NDIMS == 3 -! Z indices -! - kc = (iface - 1) / 2 - ks = kb - kl = kb + (kh - ng) * kc - ku = kh + (kh - ng) * kc -#endif /* NDIMS == 3 */ - -#if NDIMS == 3 - case(3) - -! X indices -! - ic = mod(iface - 1, 2) - is = ib - il = ib + (ih - ng) * ic - iu = ih + (ih - ng) * ic - -! Y indices -! - jc = (iface - 1) / 2 - js = jb - jl = jb + (jh - ng) * jc - ju = jh + (jh - ng) * jc - -! Z indices -! - if (iside == 1) then - ks = 1 - else - ks = keu - end if - - kl = 2 - ku = 1 + nh -#endif /* NDIMS == 3 */ - - end select - -! update variable boundaries with the linear interpolation -! -#if NDIMS == 2 - do k = 1, km - kt = 1 -#endif /* NDIMS == 2 */ -#if NDIMS == 3 - do k = kl, ku - kt = 2 * (k - kl) + ks - kp = kt + 1 -#endif /* NDIMS == 3 */ - do j = jl, ju - jt = 2 * (j - jl) + js - jp = jt + 1 - do i = il, iu - it = 2 * (i - il) + is - ip = it + 1 - -! iterate over all variables -! - do p = 1, nv - - dql = q(p,i ,j,k) - q(p,i-1,j,k) - dqr = q(p,i+1,j,k) - q(p,i ,j,k) - dqx = limiter(0.25d+00, dql, dqr) - - dql = q(p,i,j ,k) - q(p,i,j-1,k) - dqr = q(p,i,j+1,k) - q(p,i,j ,k) - dqy = limiter(0.25d+00, dql, dqr) - -#if NDIMS == 3 - dql = q(p,i,j,k ) - q(p,i,j,k-1) - dqr = q(p,i,j,k+1) - q(p,i,j,k ) - dqz = limiter(0.25d+00, dql, dqr) -#endif /* NDIMS == 3 */ - -#if NDIMS == 2 - dq1 = dqx + dqy - dq2 = dqx - dqy - pdata%q(p,it,jt,kt) = q(p,i,j,k) - dq1 - pdata%q(p,ip,jt,kt) = q(p,i,j,k) + dq2 - pdata%q(p,it,jp,kt) = q(p,i,j,k) - dq2 - pdata%q(p,ip,jp,kt) = q(p,i,j,k) + dq1 -#endif /* NDIMS == 2 */ -#if NDIMS == 3 - dq1 = dqx + dqy + dqz - dq2 = dqx - dqy - dqz - dq3 = dqx - dqy + dqz - dq4 = dqx + dqy - dqz - pdata%q(p,it,jt,kt) = q(p,i,j,k) - dq1 - pdata%q(p,ip,jt,kt) = q(p,i,j,k) + dq2 - pdata%q(p,it,jp,kt) = q(p,i,j,k) - dq3 - pdata%q(p,ip,jp,kt) = q(p,i,j,k) + dq4 - pdata%q(p,it,jt,kp) = q(p,i,j,k) - dq4 - pdata%q(p,ip,jt,kp) = q(p,i,j,k) + dq3 - pdata%q(p,it,jp,kp) = q(p,i,j,k) - dq2 - pdata%q(p,ip,jp,kp) = q(p,i,j,k) + dq1 -#endif /* NDIMS == 3 */ - - end do ! q - 1, nv - - end do ! i = il, iu - end do ! j = jl, ju - end do ! k = kl, ku - -!------------------------------------------------------------------------------- -! - end subroutine boundary_prolong + end subroutine block_boundary_specific #if NDIMS == 3 ! !=============================================================================== @@ -8654,6 +6304,8 @@ module boundaries ! !=============================================================================== ! +!=============================================================================== +! ! subroutine BLOCK_FACE_COPY: ! -------------------------- ! @@ -9207,6 +6859,8 @@ module boundaries ! !=============================================================================== ! +!=============================================================================== +! ! subroutine BLOCK_EDGE_COPY: ! -------------------------- ! @@ -9837,6 +7491,8 @@ module boundaries ! !=============================================================================== ! +!=============================================================================== +! ! subroutine BLOCK_CORNER_COPY: ! ---------------------------- ! @@ -10202,296 +7858,12 @@ module boundaries ! !=============================================================================== ! -! subroutine BLOCK_BOUNDARY_SPECIFIC: -! ---------------------------------- -! -! Subroutine applies specific boundary conditions to the pointed data block. -! -! Arguments: -! -! nc - the edge direction; -! ic, jc, kc - the corner position; -! qn - the variable array; -! -!=============================================================================== -! - subroutine block_boundary_specific(ic, jc, kc, nc, qn) - -! import external procedures and variables -! - use coordinates , only : im , jm , km , ng - use coordinates , only : ib , jb , kb , ie , je , ke - use coordinates , only : ibl, jbl, kbl, ieu, jeu, keu - use equations , only : nv - use equations , only : idn, ivx, ivy, ivz, ibx, iby, ibz, ibp - use error , only : print_error, print_warning - -! local variables are not implicit by default -! - implicit none - -! subroutine arguments -! - integer , intent(in) :: ic, jc, kc - integer , intent(in) :: nc - real(kind=8), dimension(1:nv,1:im,1:jm,1:km), intent(inout) :: qn - -! local variables -! - integer :: i , j , k - integer :: il, jl, kl - integer :: iu, ju, ku - integer :: is, js, ks - integer :: it, jt, kt -! -!------------------------------------------------------------------------------- -! -! apply specific boundaries depending on the direction -! - select case(nc) - case(1) - -! prepare indices for the boundaries -! - if (jc == 1) then - jl = 1 - ju = jm / 2 - 1 - else - jl = jm / 2 - ju = jm - end if -#if NDIMS == 3 - if (kc == 1) then - kl = 1 - ku = km / 2 - 1 - else - kl = km / 2 - ku = km - end if -#else /* NDIMS == 3 */ - kl = 1 - ku = km -#endif /* NDIMS == 3 */ - -! apply selected boundary condition -! - select case(bnd_type(nc,ic)) - -! "open" boundary conditions -! - case(bnd_open) - - if (ic == 1) then - do i = ibl, 1, -1 - qn(1:nv,i,jl:ju,kl:ku) = qn(1:nv,ib,jl:ju,kl:ku) - end do - else - do i = ieu, im - qn(1:nv,i,jl:ju,kl:ku) = qn(1:nv,ie,jl:ju,kl:ku) - end do - end if - -! "reflective" boundary conditions -! - case(bnd_reflective) - - if (ic == 1) then - do i = 1, ng - it = ib - i - is = ibl + i - - qn(1:nv,it,jl:ju,kl:ku) = qn(1:nv,is,jl:ju,kl:ku) - qn(ivx ,it,jl:ju,kl:ku) = - qn(ivx ,is,jl:ju,kl:ku) - end do - else - do i = 1, ng - it = ie + i - is = ieu - i - - qn(1:nv,it,jl:ju,kl:ku) = qn(1:nv,is,jl:ju,kl:ku) - qn(ivx ,it,jl:ju,kl:ku) = - qn(ivx ,is,jl:ju,kl:ku) - end do - end if - -! wrong boundary conditions -! - case default - - if (ic == 1) then - call print_error("boundaries:boundary_specific()" & - , "Wrong left X boundary type!") - else - call print_error("boundaries:boundary_specific()" & - , "Wrong right X boundary type!") - end if - - end select - - case(2) - -! prepare indices for the boundaries -! - if (ic == 1) then - il = 1 - iu = im / 2 - 1 - else - il = im / 2 - iu = im - end if -#if NDIMS == 3 - if (kc == 1) then - kl = 1 - ku = km / 2 - 1 - else - kl = km / 2 - ku = km - end if -#else /* NDIMS == 3 */ - kl = 1 - ku = km -#endif /* NDIMS == 3 */ - -! apply selected boundary condition -! - select case(bnd_type(nc,jc)) - -! "open" boundary conditions -! - case(bnd_open) - - if (jc == 1) then - do j = jbl, 1, -1 - qn(1:nv,il:iu,j,kl:ku) = qn(1:nv,il:iu,jb,kl:ku) - end do - else - do j = jeu, jm - qn(1:nv,il:iu,j,kl:ku) = qn(1:nv,il:iu,je,kl:ku) - end do - end if - -! "reflective" boundary conditions -! - case(bnd_reflective) - - if (jc == 1) then - do j = 1, ng - jt = jb - j - js = jbl + j - - qn(1:nv,il:iu,jt,kl:ku) = qn(1:nv,il:iu,js,kl:ku) - qn(ivy ,il:iu,jt,kl:ku) = - qn(ivy ,il:iu,js,kl:ku) - end do - else - do j = 1, ng - jt = je + j - js = jeu - j - - qn(1:nv,il:iu,jt,kl:ku) = qn(1:nv,il:iu,js,kl:ku) - qn(ivy ,il:iu,jt,kl:ku) = - qn(ivy ,il:iu,js,kl:ku) - end do - end if - -! wrong boundary conditions -! - case default - - if (jc == 1) then - call print_error("boundaries:boundary_specific()" & - , "Wrong left Y boundary type!") - else - call print_error("boundaries:boundary_specific()" & - , "Wrong right Y boundary type!") - end if - - end select - -#if NDIMS == 3 - case(3) - -! prepare indices for the boundaries -! - if (ic == 1) then - il = 1 - iu = im / 2 - 1 - else - il = im / 2 - iu = im - end if - if (jc == 1) then - jl = 1 - ju = jm / 2 - 1 - else - jl = jm / 2 - ju = jm - end if - -! apply selected boundary condition -! - select case(bnd_type(nc,kc)) - -! "open" boundary conditions -! - case(bnd_open) - - if (kc == 1) then - do k = kbl, 1, -1 - qn(1:nv,il:iu,jl:ju,k) = qn(1:nv,il:iu,jl:ju,kb) - end do - else - do k = keu, km - qn(1:nv,il:iu,jl:ju,k) = qn(1:nv,il:iu,jl:ju,ke) - end do - end if - -! "reflective" boundary conditions -! - case(bnd_reflective) - - if (kc == 1) then - do k = 1, ng - kt = kb - k - ks = kbl + k - - qn(1:nv,il:iu,jl:ju,kt) = qn(1:nv,il:iu,jl:ju,ks) - qn(ivz ,il:iu,jl:ju,kt) = - qn(ivz ,il:iu,jl:ju,ks) - end do - else - do k = 1, ng - kt = ke + k - ks = keu - k - - qn(1:nv,il:iu,jl:ju,kt) = qn(1:nv,il:iu,jl:ju,ks) - qn(ivz ,il:iu,jl:ju,kt) = - qn(ivz ,il:iu,jl:ju,ks) - end do - end if - -! wrong boundary conditions -! - case default - - if (kc == 1) then - call print_error("boundaries:boundary_specific()" & - , "Wrong left Z boundary type!") - else - call print_error("boundaries:boundary_specific()" & - , "Wrong right Z boundary type!") - end if - - end select - -#endif /* NDIMS == 3 */ - end select - -!------------------------------------------------------------------------------- -! - end subroutine block_boundary_specific -! -!=============================================================================== -! ! BLOCK FLUX UPDATE SUBROUTINES ! !=============================================================================== ! +!=============================================================================== +! ! subroutine BLOCK_UPDATE_FLUX: ! ---------------------------- ! @@ -10582,6 +7954,116 @@ module boundaries !------------------------------------------------------------------------------- ! end subroutine block_update_flux +! +!=============================================================================== +! +! OTHER BOUNDARY SUBROUTINES +! +!=============================================================================== +! +!=============================================================================== +! +! subroutine UPDATE_GHOST_CELLS: +! ----------------------------- +! +! Subroutine updates conservative variables in all ghost cells from +! already updated primitive variables. +! +! +!=============================================================================== +! + subroutine update_ghost_cells() + +! include external variables +! + use blocks , only : block_data, list_data + use coordinates , only : im , jm , km , in , jn , kn + use coordinates , only : ib , jb , kb , ie , je , ke + use coordinates , only : ibl, jbl, kbl, ieu, jeu, keu + use equations , only : nv + use equations , only : prim2cons + +! local variables are not implicit by default +! + implicit none + +! local variables +! + integer :: i, j, k + +! local pointers +! + type(block_data), pointer :: pdata +! +!------------------------------------------------------------------------------- +! +! assign the pointer to the first block on the list +! + pdata => list_data + +! scan all data blocks until the last is reached +! + do while(associated(pdata)) + +! update the X and Y boundary ghost cells +! + do k = 1, km + +! update lower layers of the Y boundary +! + do j = 1, jbl + call prim2cons(im, pdata%q(1:nv,1:im,j,k), pdata%u(1:nv,1:im,j,k)) + end do ! j = 1, jbl + +! update upper layers of the Y boundary +! + do j = jeu, jm + call prim2cons(im, pdata%q(1:nv,1:im,j,k), pdata%u(1:nv,1:im,j,k)) + end do ! j = jeu, jm + +! update remaining left layers of the X boundary +! + do i = 1, ibl + call prim2cons(jn, pdata%q(1:nv,i,jb:je,k), pdata%u(1:nv,i,jb:je,k)) + end do ! i = 1, ibl + +! update remaining right layers of the X boundary +! + do i = ieu, im + call prim2cons(jn, pdata%q(1:nv,i,jb:je,k), pdata%u(1:nv,i,jb:je,k)) + end do ! i = 1, ibl + + end do ! k = 1, km + +#if NDIMS == 3 +! update the Z boundary ghost cells +! + do j = jb, je + +! update the remaining front layers of the Z boundary +! + do k = 1, kbl + call prim2cons(in, pdata%q(1:nv,ib:ie,j,k), pdata%u(1:nv,ib:ie,j,k)) + end do ! k = 1, kbl + +! update the remaining back layers of the Z boundary +! + do k = keu, km + call prim2cons(in, pdata%q(1:nv,ib:ie,j,k), pdata%u(1:nv,ib:ie,j,k)) + end do ! k = keu, km + + end do ! j = jb, je +#endif /* NDIMS == 3 */ + +! assign the pointer to the next block on the list +! + pdata => pdata%next + + end do ! data blocks + +!------------------------------------------------------------------------------- +! + end subroutine update_ghost_cells !=============================================================================== ! From 49b3469ede3029e8363eb1199ee615f43b335faf Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Wed, 23 Jul 2014 23:11:27 -0300 Subject: [PATCH 87/91] IO: Do not store/restore %neigh pointers anymore. These pointers won't be used anymore, and have been replaced by %faces, %edges, and %corners. Signed-off-by: Grzegorz Kowal --- src/io.F90 | 44 ++------------------------------------------ 1 file changed, 2 insertions(+), 42 deletions(-) diff --git a/src/io.F90 b/src/io.F90 index 9517359..c52902d 100644 --- a/src/io.F90 +++ b/src/io.F90 @@ -1435,7 +1435,7 @@ module io ! import procedures and variables from other modules ! use blocks , only : block_meta, list_meta - use blocks , only : ndims, nchildren, nsides, nfaces + use blocks , only : ndims, nchildren, nsides use blocks , only : get_last_id, get_mblocks use error , only : print_error use hdf5 , only : hid_t, hsize_t @@ -1456,7 +1456,6 @@ module io integer :: iret integer(hsize_t), dimension(1) :: am, cm integer(hsize_t), dimension(2) :: dm, pm - integer(hsize_t), dimension(4) :: qm #if NDIMS == 2 integer(hsize_t), dimension(4) :: nm #endif /* NDIMS == 2 */ @@ -1471,7 +1470,6 @@ module io integer(kind=4), dimension(:) , allocatable :: id, cpu, lev, cfg, ref, lea real (kind=8), dimension(:) , allocatable :: xmn, xmx, ymn, ymx, zmn, zmx integer(kind=4), dimension(:,:), allocatable :: chl, pos, cor - integer(kind=4), dimension(:,:,:,:), allocatable :: ngh #if NDIMS == 2 integer(kind=4), dimension(:,:,:,:) , allocatable :: edges integer(kind=4), dimension(:,:,:) , allocatable :: corners @@ -1508,10 +1506,6 @@ module io dm(2) = nchildren pm(1) = get_mblocks() pm(2) = NDIMS - qm(1) = get_mblocks() - qm(2) = NDIMS - qm(3) = nsides - qm(4) = nfaces nm(1) = get_mblocks() nm(2) = nsides nm(3) = nsides @@ -1547,7 +1541,6 @@ module io allocate(chl(dm(1),dm(2))) allocate(pos(pm(1),pm(2))) allocate(cor(pm(1),pm(2))) - allocate(ngh(qm(1),qm(2),qm(3),qm(4))) #if NDIMS == 2 allocate(edges (nm(1),nm(2),nm(3),nm(4))) allocate(corners(nm(1),nm(2),nm(3))) @@ -1565,7 +1558,6 @@ module io dat(:) = -1 lea(:) = -1 chl(:,:) = -1 - ngh(:,:,:,:) = -1 #if NDIMS == 2 edges(:,:,:,:) = -1 corners(:,:,:) = -1 @@ -1620,15 +1612,6 @@ module io if (associated(pmeta%child(p)%ptr)) chl(l,p) = pmeta%child(p)%ptr%id end do - do i = 1, NDIMS - do j = 1, nsides - do k = 1, nfaces - if (associated(pmeta%neigh(i,j,k)%ptr)) & - ngh(l,i,j,k) = pmeta%neigh(i,j,k)%ptr%id - end do - end do - end do - ! store face, edge and corner neighbor pointers ! #if NDIMS == 2 @@ -1686,7 +1669,6 @@ module io call write_array(gid, 'child' , dm(:) , chl(:,:)) call write_array(gid, 'pos' , pm(:) , pos(:,:)) call write_array(gid, 'coord' , pm(:) , cor(:,:)) - call write_array(gid, 'neigh' , qm(:) , ngh(:,:,:,:)) #if NDIMS == 2 call write_array(gid, 'edges' , nm(1:4), edges(:,:,:,:)) call write_array(gid, 'corners', nm(1:3), corners(:,:,:)) @@ -1716,7 +1698,6 @@ module io if (allocated(zmx)) deallocate(zmx) if (allocated(chl)) deallocate(chl) if (allocated(cor)) deallocate(cor) - if (allocated(ngh)) deallocate(ngh) #if NDIMS == 3 if (allocated(faces)) deallocate(faces) #endif /* NDIMS == 3 */ @@ -1770,7 +1751,7 @@ module io ! import procedures and variables from other modules ! use blocks , only : block_meta, list_meta - use blocks , only : ndims, nchildren, nsides, nfaces + use blocks , only : ndims, nchildren, nsides use blocks , only : get_mblocks use blocks , only : metablock_set_id, metablock_set_process use blocks , only : metablock_set_refinement @@ -1798,7 +1779,6 @@ module io integer :: err integer(hsize_t), dimension(1) :: am integer(hsize_t), dimension(2) :: dm, pm - integer(hsize_t), dimension(4) :: qm #if NDIMS == 2 integer(hsize_t), dimension(4) :: nm #endif /* NDIMS == 2 */ @@ -1813,7 +1793,6 @@ module io integer(kind=4), dimension(:) , allocatable :: id, cpu, lev, cfg, ref, lea real (kind=8), dimension(:) , allocatable :: xmn, xmx, ymn, ymx, zmn, zmx integer(kind=4), dimension(:,:), allocatable :: chl, pos, cor - integer(kind=4), dimension(:,:,:,:), allocatable :: ngh #if NDIMS == 2 integer(kind=4), dimension(:,:,:,:) , allocatable :: edges integer(kind=4), dimension(:,:,:) , allocatable :: corners @@ -1853,10 +1832,6 @@ module io dm(2) = nchildren pm(1) = get_mblocks() pm(2) = NDIMS - qm(1) = get_mblocks() - qm(2) = NDIMS - qm(3) = nsides - qm(4) = nfaces nm(1) = get_mblocks() nm(2) = nsides nm(3) = nsides @@ -1887,7 +1862,6 @@ module io allocate(chl(dm(1),dm(2))) allocate(pos(pm(1),pm(2))) allocate(cor(pm(1),pm(2))) - allocate(ngh(qm(1),qm(2),qm(3),qm(4))) #if NDIMS == 2 allocate(edges (nm(1),nm(2),nm(3),nm(4))) allocate(corners(nm(1),nm(2),nm(3))) @@ -1904,7 +1878,6 @@ module io dat(:) = -1 lea(:) = -1 chl(:,:) = -1 - ngh(:,:,:,:) = -1 #if NDIMS == 2 edges(:,:,:,:) = -1 corners(:,:,:) = -1 @@ -1933,7 +1906,6 @@ module io call read_array(gid, 'pos' , pm(:), pos(:,:)) call read_array(gid, 'coord' , pm(:), cor(:,:)) call read_array(gid, 'child' , dm(:), chl(:,:)) - call read_array(gid, 'neigh' , qm(:), ngh(:,:,:,:)) #if NDIMS == 2 call read_array(gid, 'edges' , nm(1:4), edges(:,:,:,:)) call read_array(gid, 'corners', nm(1:3), corners(:,:,:)) @@ -2019,17 +1991,6 @@ module io end if end do ! p = 1, nchildren -! restore %neigh pointers -! - do i = 1, ndims - do j = 1, nsides - do k = 1, nfaces - if (ngh(l,i,j,k) > 0) & - pmeta%neigh(i,j,k)%ptr => block_array(ngh(l,i,j,k))%ptr - end do ! k = 1, nfaces - end do ! j = 1, nsides - end do ! i = 1, ndims - ! restore %faces, %edges and %corners neighbor pointers ! #if NDIMS == 2 @@ -2085,7 +2046,6 @@ module io if (allocated(zmx)) deallocate(zmx) if (allocated(chl)) deallocate(chl) if (allocated(cor)) deallocate(cor) - if (allocated(ngh)) deallocate(ngh) #if NDIMS == 3 if (allocated(faces)) deallocate(faces) #endif /* NDIMS == 3 */ From 943d2d19eda129a9343391ea845c02bceee10bb0 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Wed, 23 Jul 2014 23:39:53 -0300 Subject: [PATCH 88/91] BLOCKS: Rewrite iterate_over_neighbors() and remove iterate_over_face(). We can point all neighbors directly now, so it is enough to loop over all of them. Signed-off-by: Grzegorz Kowal --- src/blocks.F90 | 429 +++++-------------------------------------------- 1 file changed, 41 insertions(+), 388 deletions(-) diff --git a/src/blocks.F90 b/src/blocks.F90 index de98b2b..58578fe 100644 --- a/src/blocks.F90 +++ b/src/blocks.F90 @@ -4553,437 +4553,90 @@ module blocks type(block_meta) , pointer, intent(inout) :: pmeta procedure(reset_neighbors_update), pointer, intent(in) :: pprocedure -! local saved variables +! local pointers ! - logical, save :: first = .true. - -! local saved arrays -! - integer, dimension(mfaces,3) , save :: fidx - integer, dimension(mfaces,2,3), save :: eidx - integer, dimension(mfaces,2,3), save :: cidx + type(block_meta), pointer :: pneigh ! local variables ! - integer :: l + integer :: i, j, k, n ! !------------------------------------------------------------------------------- ! -! prepare indices +! return if pmeta not associated ! - if (first) then + if (.not. associated(pmeta)) return -! inicialize indices -! - fidx(: ,:) = 0 - eidx(:,:,:) = 0 - cidx(:,:,:) = 0 - -! prepare indices to get proper face, edge and corner neighbors -! #if NDIMS == 2 -! around (0,0,0) corner +! iterate over edges and corners ! -! [1,1,1]:X:(1,2,1) <- Y = [2,1,2] -! - fidx( 1, :) = (/ 1, 1, 1 /) - eidx( 1,1,:) = (/ 2, 1, 2 /) + do j = 1, nsides + do i = 1, nsides + do n = 1, ndims -! [2,1,1]:Y:(2,2,1) <- X = [1,1,2] +! associate pneigh with the face neighbor ! - fidx( 2, :) = (/ 2, 1, 1 /) - eidx( 2,1,:) = (/ 1, 1, 2 /) + pneigh => pmeta%edges(i,j,n)%ptr -! around (0,1,0) corner +! call the procedure for the face neighbor ! -! [1,1,2]:X:(1,2,2) -> Y = [2,2,2] -! - fidx( 3, :) = (/ 1, 1, 2 /) - eidx( 3,1,:) = (/ 2, 2, 2 /) + if (associated(pneigh)) call pprocedure(pmeta, pneigh) -! [2,2,1]:Y:(2,1,2) <- X = [1,1,1] -! - fidx( 4, :) = (/ 2, 2, 1 /) - eidx( 4,1,:) = (/ 1, 1, 1 /) + end do ! n = 1, ndims -! around (1,1,0) corner +! associate pneigh with the face neighbor ! -! [1,2,2]:X:(1,1,2) -> Y = [2,2,1] -! - fidx( 5, :) = (/ 1, 2, 2 /) - eidx( 5,1,:) = (/ 2, 2, 1 /) + pneigh => pmeta%corners(i,j)%ptr -! [2,2,2]:Y:(2,1,2) -> X = [1,2,1] +! call the procedure for the face neighbor ! - fidx( 6, :) = (/ 2, 2, 2 /) - eidx( 6,1,:) = (/ 1, 2, 1 /) + if (associated(pneigh)) call pprocedure(pmeta, pneigh) -! around (1,0,0) corner -! -! [1,2,1]:X:(1,1,1) <- Y = [2,1,1] -! - fidx( 7, :) = (/ 1, 2, 1 /) - eidx( 7,1,:) = (/ 2, 1, 1 /) - -! [2,1,2]:Y:(2,2,2) -> X = [1,2,2] -! - fidx( 8, :) = (/ 2, 1, 2 /) - eidx( 8,1,:) = (/ 1, 2, 2 /) + end do ! i = 1, nsides + end do ! j = 1, nsides #endif /* NDIMS == 2 */ #if NDIMS == 3 -! around (0,0,0) corner +! iterate over faces, edges, and corners ! -! [1,1,1]:X:(1,2,1) <- Y = [2,1,2] <- Z = [3,1,4] -! [1,1,1]:X:(1,2,1) <- Z = [3,1,2] <- Y = [2,1,4] -! - fidx( 1, :) = (/ 1, 1, 1 /) - eidx( 1,1,:) = (/ 2, 1, 2 /) - eidx( 1,2,:) = (/ 3, 1, 2 /) - cidx( 1,1,:) = (/ 3, 1, 4 /) - cidx( 1,2,:) = (/ 2, 1, 4 /) + do k = 1, nsides + do j = 1, nsides + do i = 1, nsides + do n = 1, ndims -! [2,1,1]:Y:(2,2,1) <- Z = [3,1,3] <- X = [1,1,4] -! [2,1,1]:Y:(2,2,1) <- X = [1,1,2] <- Z = [3,1,4] +! associate pneigh with the face neighbor ! - fidx( 2, :) = (/ 2, 1, 1 /) - eidx( 2,1,:) = (/ 3, 1, 3 /) - eidx( 2,2,:) = (/ 1, 1, 2 /) - cidx( 2,1,:) = (/ 1, 1, 4 /) - cidx( 2,2,:) = (/ 3, 1, 4 /) + pneigh => pmeta%faces(i,j,k,n)%ptr -! [3,1,1]:Z:(3,2,1) <- X = [1,1,3] <- Y = [2,1,4] -! [3,1,1]:Z:(3,2,1) <- Y = [2,1,3] <- X = [1,1,4] +! call the procedure for the face neighbor ! - fidx( 3, :) = (/ 3, 1, 1 /) - eidx( 3,1,:) = (/ 1, 1, 3 /) - eidx( 3,2,:) = (/ 2, 1, 3 /) - cidx( 3,1,:) = (/ 2, 1, 4 /) - cidx( 3,2,:) = (/ 1, 1, 4 /) + if (associated(pneigh)) call pprocedure(pmeta, pneigh) -! around (0,1,0) corner +! associate pneigh with the face neighbor ! -! [1,1,2]:X:(1,2,2) -> Y = [2,2,2] <- Z = [3,1,2] -! [1,1,2]:X:(1,2,2) <- Z = [3,1,4] -> Y = [2,2,4] -! - fidx( 4, :) = (/ 1, 1, 2 /) - eidx( 4,1,:) = (/ 2, 2, 2 /) - eidx( 4,2,:) = (/ 3, 1, 4 /) - cidx( 4,1,:) = (/ 3, 1, 2 /) - cidx( 4,2,:) = (/ 2, 2, 4 /) + pneigh => pmeta%edges(i,j,k,n)%ptr -! [2,2,1]:Y:(2,1,2) <- Z = [3,1,1] <- X = [1,1,3] -! [2,2,1]:Y:(2,1,2) <- X = [1,1,1] <- Z = [3,1,2] +! call the procedure for the face neighbor ! - fidx( 5, :) = (/ 2, 2, 1 /) - eidx( 5,1,:) = (/ 3, 1, 1 /) - eidx( 5,2,:) = (/ 1, 1, 1 /) - cidx( 5,1,:) = (/ 1, 1, 3 /) - cidx( 5,2,:) = (/ 3, 1, 2 /) + if (associated(pneigh)) call pprocedure(pmeta, pneigh) -! [3,1,3]:Z:(3,2,3) <- X = [1,1,4] -> Y = [2,2,4] -! [3,1,3]:Z:(3,2,3) -> Y = [2,2,3] <- X = [1,1,3] -! - fidx( 6, :) = (/ 3, 1, 3 /) - eidx( 6,1,:) = (/ 1, 1, 4 /) - eidx( 6,2,:) = (/ 2, 2, 3 /) - cidx( 6,1,:) = (/ 2, 2, 4 /) - cidx( 6,2,:) = (/ 1, 1, 3 /) + end do ! n = 1, ndims -! around (1,1,0) corner +! associate pneigh with the face neighbor ! -! [1,2,2]:X:(1,1,2) -> Y = [2,2,1] <- Z = [3,1,1] -! [1,2,2]:X:(1,1,2) <- Z = [3,1,3] -> Y = [2,2,3] -! - fidx( 7, :) = (/ 1, 2, 2 /) - eidx( 7,1,:) = (/ 2, 2, 1 /) - eidx( 7,2,:) = (/ 3, 1, 3 /) - cidx( 7,1,:) = (/ 3, 1, 1 /) - cidx( 7,2,:) = (/ 2, 2, 3 /) + pneigh => pmeta%corners(i,j,k)%ptr -! [2,2,2]:Y:(2,1,2) <- Z = [3,1,2] -> X = [1,2,3] -! [2,2,2]:Y:(2,1,2) -> X = [1,2,1] <- Z = [3,1,1] +! call the procedure for the face neighbor ! - fidx( 8, :) = (/ 2, 2, 2 /) - eidx( 8,1,:) = (/ 3, 1, 2 /) - eidx( 8,2,:) = (/ 1, 2, 1 /) - cidx( 8,1,:) = (/ 1, 2, 3 /) - cidx( 8,2,:) = (/ 3, 1, 1 /) + if (associated(pneigh)) call pprocedure(pmeta, pneigh) -! [3,1,4]:Z:(3,2,4) -> X = [1,2,4] -> Y = [2,2,3] -! [3,1,4]:Z:(3,2,4) -> Y = [2,2,4] -> X = [1,2,3] -! - fidx( 9, :) = (/ 3, 1, 4 /) - eidx( 9,1,:) = (/ 1, 2, 4 /) - eidx( 9,2,:) = (/ 2, 2, 4 /) - cidx( 9,1,:) = (/ 2, 2, 3 /) - cidx( 9,2,:) = (/ 1, 2, 3 /) - -! around (1,0,0) corner -! -! [1,2,1]:X:(1,1,1) <- Y = [2,1,1] <- Z = [3,1,3] -! [1,2,1]:X:(1,1,1) <- Z = [3,1,1] <- Y = [2,1,3] -! - fidx(10, :) = (/ 1, 2, 1 /) - eidx(10,1,:) = (/ 2, 1, 1 /) - eidx(10,2,:) = (/ 3, 1, 1 /) - cidx(10,1,:) = (/ 3, 1, 3 /) - cidx(10,2,:) = (/ 2, 1, 3 /) - -! [2,1,2]:Y:(2,2,2) <- Z = [3,1,4] -> X = [1,2,4] -! [2,1,2]:Y:(2,2,2) -> X = [1,2,2] <- Z = [3,1,3] -! - fidx(11, :) = (/ 2, 1, 2 /) - eidx(11,1,:) = (/ 3, 1, 4 /) - eidx(11,2,:) = (/ 1, 2, 2 /) - cidx(11,1,:) = (/ 1, 2, 4 /) - cidx(11,2,:) = (/ 3, 1, 3 /) - -! [3,1,2]:Z:(3,2,2) -> X = [1,2,3] <- Y = [2,1,3] -! [3,1,2]:Z:(3,2,2) <- Y = [2,1,4] -> X = [1,2,4] -! - fidx(12, :) = (/ 3, 1, 2 /) - eidx(12,1,:) = (/ 1, 2, 3 /) - eidx(12,2,:) = (/ 2, 1, 4 /) - cidx(12,1,:) = (/ 2, 1, 3 /) - cidx(12,2,:) = (/ 1, 2, 4 /) - -! around (0,0,1) corner -! -! [1,1,3]:X:(1,2,3) <- Y = [2,1,4] -> Z = [3,2,4] -! [1,1,3]:X:(1,2,3) -> Z = [3,2,2] <- Y = [2,1,2] -! - fidx(13, :) = (/ 1, 1, 3 /) - eidx(13,1,:) = (/ 2, 1, 4 /) - eidx(13,2,:) = (/ 3, 2, 2 /) - cidx(13,1,:) = (/ 3, 2, 4 /) - cidx(13,2,:) = (/ 2, 1, 2 /) - -! [2,1,3]:Y:(2,2,3) -> Z = [3,2,3] <- X = [1,1,2] -! [2,1,3]:Y:(2,2,3) <- X = [1,1,4] -> Z = [3,2,1] -! - fidx(14, :) = (/ 2, 1, 3 /) - eidx(14,1,:) = (/ 3, 2, 3 /) - eidx(14,2,:) = (/ 1, 1, 4 /) - cidx(14,1,:) = (/ 1, 1, 2 /) - cidx(14,2,:) = (/ 3, 2, 1 /) - -! [3,2,1]:Z:(3,1,1) <- X = [1,1,1] <- Y = [2,1,2] -! [3,2,1]:Z:(3,1,1) <- Y = [2,1,1] <- X = [1,1,2] -! - fidx(15, :) = (/ 3, 2, 1 /) - eidx(15,1,:) = (/ 1, 1, 1 /) - eidx(15,2,:) = (/ 2, 1, 1 /) - cidx(15,1,:) = (/ 2, 1, 2 /) - cidx(15,2,:) = (/ 1, 1, 2 /) - -! around (0,1,1) corner -! -! [1,1,4]:X:(1,2,4) -> Y = [2,2,4] -> Z = [3,2,2] -! [1,1,4]:X:(1,2,4) -> Z = [3,2,4] -> Y = [2,2,2] -! - fidx(16, :) = (/ 1, 1, 4 /) - eidx(16,1,:) = (/ 2, 2, 4 /) - eidx(16,2,:) = (/ 3, 2, 4 /) - cidx(16,1,:) = (/ 3, 2, 2 /) - cidx(16,2,:) = (/ 2, 2, 2 /) - -! [2,2,3]:Y:(2,1,3) -> Z = [3,2,1] <- X = [1,1,1] -! [2,2,3]:Y:(2,1,3) <- X = [1,1,3] -> Z = [3,2,2] -! - fidx(17, :) = (/ 2, 2, 3 /) - eidx(17,1,:) = (/ 3, 2, 1 /) - eidx(17,2,:) = (/ 1, 1, 3 /) - cidx(17,1,:) = (/ 1, 1, 1 /) - cidx(17,2,:) = (/ 3, 2, 2 /) - -! [3,2,3]:Z:(3,1,3) <- X = [1,1,2] -> Y = [2,2,2] -! [3,2,3]:Z:(3,1,3) -> Y = [2,2,1] <- X = [1,1,1] -! - fidx(18, :) = (/ 3, 2, 3 /) - eidx(18,1,:) = (/ 1, 1, 2 /) - eidx(18,2,:) = (/ 2, 2, 1 /) - cidx(18,1,:) = (/ 2, 2, 2 /) - cidx(18,2,:) = (/ 1, 1, 1 /) - -! around (1,1,1) corner -! -! [1,2,4]:X:(1,1,4) -> Y = [2,2,3] -> Z = [3,2,1] -! [1,2,4]:X:(1,1,4) -> Z = [3,2,3] -> Y = [2,2,1] -! - fidx(19, :) = (/ 1, 2, 4 /) - eidx(19,1,:) = (/ 2, 2, 3 /) - eidx(19,2,:) = (/ 3, 2, 3 /) - cidx(19,1,:) = (/ 3, 2, 1 /) - cidx(19,2,:) = (/ 2, 2, 1 /) - -! [2,2,4]:Y:(2,1,4) -> Z = [3,2,2] -> X = [1,2,1] -! [2,2,4]:Y:(2,1,4) -> X = [1,2,3] -> Z = [3,2,1] -! - fidx(20, :) = (/ 2, 2, 4 /) - eidx(20,1,:) = (/ 3, 2, 2 /) - eidx(20,2,:) = (/ 1, 2, 3 /) - cidx(20,1,:) = (/ 1, 2, 1 /) - cidx(20,2,:) = (/ 3, 2, 1 /) - -! [3,2,4]:Z:(3,1,4) -> X = [1,2,2] -> Y = [2,2,1] -! [3,2,4]:Z:(3,1,4) -> Y = [2,2,2] -> X = [1,2,1] -! - fidx(21, :) = (/ 3, 2, 4 /) - eidx(21,1,:) = (/ 1, 2, 2 /) - eidx(21,2,:) = (/ 2, 2, 2 /) - cidx(21,1,:) = (/ 2, 2, 1 /) - cidx(21,2,:) = (/ 1, 2, 1 /) - -! around (1,0,1) corner -! -! [1,2,3]:X:(1,1,3) <- Y = [2,1,3] -> Z = [3,2,3] -! [1,2,3]:X:(1,1,3) -> Z = [3,2,1] <- Y = [2,1,1] -! - fidx(22, :) = (/ 1, 2, 3 /) - eidx(22,1,:) = (/ 2, 1, 3 /) - eidx(22,2,:) = (/ 3, 2, 1 /) - cidx(22,1,:) = (/ 3, 2, 3 /) - cidx(22,2,:) = (/ 2, 1, 1 /) - -! [2,1,4]:Y:(2,2,4) -> Z = [3,2,4] -> X = [1,2,2] -! [2,1,4]:Y:(2,2,4) -> X = [1,2,4] -> Z = [3,2,3] -! - fidx(23, :) = (/ 2, 1, 4 /) - eidx(23,1,:) = (/ 3, 2, 4 /) - eidx(23,2,:) = (/ 1, 2, 4 /) - cidx(23,1,:) = (/ 1, 2, 2 /) - cidx(23,2,:) = (/ 3, 2, 3 /) - -! [3,2,2]:Z:(3,1,2) -> X = [1,2,1] <- Y = [2,1,3] -! [3,2,2]:Z:(3,1,2) <- Y = [2,1,2] -> X = [1,2,4] -! - fidx(24, :) = (/ 3, 2, 2 /) - eidx(24,1,:) = (/ 1, 2, 1 /) - eidx(24,2,:) = (/ 2, 1, 2 /) - cidx(24,1,:) = (/ 2, 1, 3 /) - cidx(24,2,:) = (/ 1, 2, 3 /) + end do ! i = 1, nsides + end do ! j = 1, nsides + end do ! k = 1, nsides #endif /* NDIMS == 3 */ -! reset the first time execution flag -! - first = .false. - - end if - -! iterate over all block faces (or edges in the 2D case) -! - do l = 1, mfaces - call iterate_over_face(pmeta, pprocedure & - , fidx(l,:), eidx(l,:,:), cidx(l,:,:)) - end do - !------------------------------------------------------------------------------- ! end subroutine iterate_over_neighbors -! -!=============================================================================== -! -! subroutine ITERATE_OVER_FACE: -! ---------------------------- -! -! Subroutine iterates over all neighbors, edges and corners linked to -! the input meta block and executes a subroutine provided by the pointer. -! -! Arguments: -! -! pmeta - a pointer to the meta block which neighbors are iterated over; -! pproc - a pointer to the subroutine called with each pair (pmeta, pneigh); -! fidx - the index of face to process; -! eidx - the indices of faces connected with edges; -! cidx - the indices of faces connected with corners; -! -!=============================================================================== -! - subroutine iterate_over_face(pmeta, pprocedure, fidx, eidx, cidx) - -! local variables are not implicit by default -! - implicit none - -! subroutine arguments -! - type(block_meta) , pointer, intent(inout) :: pmeta - procedure(reset_neighbors_update), pointer, intent(in) :: pprocedure - integer, dimension(3) , intent(in) :: fidx - integer, dimension(2,3) , intent(in) :: eidx - integer, dimension(2,3) , intent(in) :: cidx - -! local pointers -! - type(block_meta), pointer :: pneigh, pedge, pcorner -! -!------------------------------------------------------------------------------- -! -! associate a pointer with the neighbor -! - pneigh => pmeta%neigh(fidx(1),fidx(2),fidx(3))%ptr - -! check if the neighbors is associated -! - if (associated(pneigh)) then - -! call the procedure for the face neighbor -! - call pprocedure(pmeta, pneigh) - -! associate a pointer with the first edge -! - pedge => pneigh%neigh(eidx(1,1),eidx(1,2),eidx(1,3))%ptr - -! check if the edge pointer is associated -! - if (associated(pedge)) then - -! call the procedure for the edge neighbor -! - call pprocedure(pmeta, pedge) - -#if NDIMS == 3 -! associate a pointer with the first corner -! - pcorner => pedge%neigh(cidx(1,1),cidx(1,2),cidx(1,3))%ptr - -! call the procedure for the corner neighbor if it is associated -! - if (associated(pcorner)) call pprocedure(pmeta, pcorner) -#endif /* NDIMS == 3 */ - - end if ! pedge associated - -#if NDIMS == 3 -! associate a pointer with the second edge -! - pedge => pneigh%neigh(eidx(2,1),eidx(2,2),eidx(2,3))%ptr - -! check if the edge pointer is associated -! - if (associated(pedge)) then - -! call the procedure for the edge neighbor -! - call pprocedure(pmeta, pedge) - -! associate a pointer with the second corner -! - pcorner => pedge%neigh(cidx(2,1),cidx(2,2),cidx(2,3))%ptr - -! call the procedure for the corner neighbor if it is associated -! - if (associated(pcorner)) call pprocedure(pmeta, pcorner) - - end if ! pedge associated -#endif /* NDIMS == 3 */ - - end if ! pneigh associated - -!------------------------------------------------------------------------------- -! - end subroutine iterate_over_face #ifdef DEBUG ! !=============================================================================== From c1e5721fd4fa9eacba948b13542505d3ce279bb7 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Wed, 23 Jul 2014 23:43:53 -0300 Subject: [PATCH 89/91] DOMAINS: Remove initializarion of %neigh in setup_domain_default(). Signed-off-by: Grzegorz Kowal --- src/domains.F90 | 142 +----------------------------------------------- 1 file changed, 1 insertion(+), 141 deletions(-) diff --git a/src/domains.F90 b/src/domains.F90 index 6cf43b4..733ccb3 100644 --- a/src/domains.F90 +++ b/src/domains.F90 @@ -142,7 +142,7 @@ module domains use blocks , only : metablock_set_leaf, metablock_set_level use blocks , only : metablock_set_configuration use blocks , only : metablock_set_coordinates, metablock_set_bounds - use blocks , only : nsides, nfaces + use blocks , only : nsides use boundaries , only : bnd_type, bnd_periodic use coordinates , only : xmin, ymin, zmin, xlen, ylen, zlen use coordinates , only : ir, jr, kr @@ -323,146 +323,6 @@ module domains !! ASSIGN THE BLOCK NEIGHBORS !! -! assign boundaries along the X direction -! - do k = 1, kr - do j = 1, jr - do i = 1, ir - 1 - -! assign a pointer -! - pmeta => block_array(i ,j,k)%ptr - -! assign neighbor -! - pnext => block_array(i+1,j,k)%ptr - -! assign their neighbor pointers -! - do p = 1, nfaces - pmeta%neigh(1,2,p)%ptr => pnext - pnext%neigh(1,1,p)%ptr => pmeta - end do - - end do - end do - end do - -! if periodic boundary conditions set edge block neighbors -! - if (bnd_type(1,1) == bnd_periodic .and. bnd_type(1,2) == bnd_periodic) then - do k = 1, kr - do j = 1, jr - -! assign pointers -! - pmeta => block_array( 1,j,k)%ptr - pnext => block_array(ir,j,k)%ptr - -! assign their neighbor pointers -! - do p = 1, nfaces - pmeta%neigh(1,1,p)%ptr => pnext - pnext%neigh(1,2,p)%ptr => pmeta - end do - end do - end do - end if - -! assign boundaries along the Y direction -! - do k = 1, kr - do j = 1, jr - 1 - do i = 1, ir - -! assign a pointer -! - pmeta => block_array(i,j ,k)%ptr - -! assign neighbor -! - pnext => block_array(i,j+1,k)%ptr - -! assign their neighbor pointers -! - do p = 1, nfaces - pmeta%neigh(2,2,p)%ptr => pnext - pnext%neigh(2,1,p)%ptr => pmeta - end do - - end do - end do - end do - -! if periodic boundary conditions set edge block neighbors -! - if (bnd_type(2,1) == bnd_periodic .and. bnd_type(2,2) == bnd_periodic) then - do k = 1, kr - do i = 1, ir - -! assign pointers -! - pmeta => block_array(i, 1,k)%ptr - pnext => block_array(i,jr,k)%ptr - -! assign their neighbor pointers -! - do p = 1, nfaces - pmeta%neigh(2,1,p)%ptr => pnext - pnext%neigh(2,2,p)%ptr => pmeta - end do - end do - end do - end if - -#if NDIMS == 3 -! assign boundaries along the Z direction -! - do k = 1, kr - 1 - do j = 1, jr - do i = 1, ir - -! assign a pointer -! - pmeta => block_array(i,j,k )%ptr - -! assign neighbor -! - pnext => block_array(i,j,k+1)%ptr - -! assign their neighbor pointers -! - do p = 1, nfaces - pmeta%neigh(3,2,p)%ptr => pnext - pnext%neigh(3,1,p)%ptr => pmeta - end do - - end do - end do - end do - -! if periodic boundary conditions set edge block neighbors -! - if (bnd_type(3,1) == bnd_periodic .and. bnd_type(3,2) == bnd_periodic) then - do j = 1, jr - do i = 1, ir - -! assign pointers -! - pmeta => block_array(i,j, 1)%ptr - pnext => block_array(i,j,kr)%ptr - -! assign their neighbor pointers -! - do p = 1, nfaces - pmeta%neigh(3,1,p)%ptr => pnext - pnext%neigh(3,2,p)%ptr => pmeta - end do - end do - end do - end if -#endif /* NDIMS == 3 */ - ! allocate indices ! allocate(im(ir), ip(ir)) From 7a93ac16e0405285b79ce680a31103399be976ec Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Thu, 24 Jul 2014 12:20:49 -0300 Subject: [PATCH 90/91] BLOCKS: Rewrite check_block_neighbors(). This debuggin fuctions checks face, edge, and corner pointers and check the corresponding pointers of the pointed neighbors, if they are consistent, i.e. if they point to each other. Signed-off-by: Grzegorz Kowal --- src/blocks.F90 | 1045 ++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 960 insertions(+), 85 deletions(-) diff --git a/src/blocks.F90 b/src/blocks.F90 index 58578fe..2d0606d 100644 --- a/src/blocks.F90 +++ b/src/blocks.F90 @@ -4670,11 +4670,19 @@ module blocks ! local pointers ! - type(block_meta), pointer :: pneigh, pnneigh + type(block_meta), pointer :: pneigh, pself ! local variables ! - integer :: i, j, k, l, m + integer :: ip, ir, ic + integer :: jp, jr, jc +#if NDIMS == 3 + integer :: kp, kr, kc +#endif /* NDIMS == 2 */ + +! subroutine name string +! + character(len=*), parameter :: fname = "blocks::check_block_neighbors" ! !------------------------------------------------------------------------------- ! @@ -4682,114 +4690,981 @@ module blocks ! if (.not. pmeta%leaf) return -! iterate over all face neighbors +#if NDIMS == 2 +! iterate over all corners ! - do i = 1, ndims - do j = 1, nsides - m = 3 - j - do k = 1, nfaces + do jp = 1, nsides + jr = 3 - jp + do ip = 1, nsides + ir = 3 - ip -! assign pointer with the neighbor +!--- check edges --- ! - pneigh => pmeta%neigh(i,j,k)%ptr +! along X direction +! +! associate pneigh with the current corner +! + pneigh => pmeta%edges(ip,jp,1)%ptr + +! check if pneigh is associated +! + if (associated(pneigh)) then + +! if pneigh is on the same level +! + if (pneigh%level == pmeta%level) then + +! assiociate pself to the corresponding edge of the neighbor +! + pself => pneigh%edges(ip,jr,1)%ptr + +! check if pself is associated +! + if (associated(pself)) then + +! check if pself is the same as pmeta +! + if (pmeta%id /= pself%id) then + +! print warning, since the blocks differ +! + call print_warning(fname & + , "Inconsistent same level neighbor edges!") + write(*,"(a6,' id: ',i8,' [ ',3(i2,','),' ]')") & + 'meta ', pmeta%id , ip, jp, 1 + write(*,"(a6,' id: ',i8,' [ ',3(i2,','),' ]')") & + 'neigh', pneigh%id, ip, jr, 1 + write(*,"(a6,' id: ',i8)") 'self ', pself%id + + end if ! %id fields don't match + + else ! pself associated + +! print warning, since the pointer should be associated +! + call print_warning(fname & + , "Same level neighbor's edge not associated!") + write(*,"(a6,' id: ',i8,' [ ',3(i2,','),' ]')") & + 'meta ', pmeta%id , ip, jp, 1 + write(*,"(a6,' id: ',i8,' [ ',3(i2,','),' ]')") & + 'neigh', pneigh%id, ip, jr, 1 + + end if ! pself associated + + end if ! pneigh and pmeta on the same level + +! if pneigh is on the higher level level +! + if (pneigh%level > pmeta%level) then + +! iterate over all edges in the given direction and Y side +! + do ic = 1, nsides + +! assiociate pself to the corresponding edge of the neighbor +! + pself => pneigh%edges(ic,jr,1)%ptr + +! check if pself is associated +! + if (associated(pself)) then + +! check if pself is the same as pmeta +! + if (pmeta%id /= pself%id) then + +! print warning, since the blocks differ +! + call print_warning(fname & + , "Inconsistent higher level neighbor edge!") + write(*,"(a6,' id: ',i8,' [ ',3(i2,','),' ]')") & + 'meta ', pmeta%id, ip, jp, 1 + write(*,"(a6,' id: ',i8,' [ ',3(i2,','),' ]')") & + 'neigh', pneigh%id, ip, jr, 1 + write(*,"(a6,' id: ',i8,' [ ',3(i2,','),' ]')") & + 'self ', pself%id, ic, jr, 1 + + end if ! %id fields don't match + + else ! pself associated + +! print warning, since the pointer should be associated +! + call print_warning(fname & + , "Higher level neighbor's edge not associated!") + write(*,"(a6,' id: ',i8,' [ ',3(i2,','),' ]')") & + 'meta ', pmeta%id, ip, jp, 1 + write(*,"(a6,' id: ',i8,' [ ',3(i2,','),' ]')") & + 'neigh', pneigh%id, ic, jr, 1 + + end if ! pself associated + + end do ! ic = 1, nsides + + end if ! pneigh on higher level + + end if ! pneigh associated + +! along Y direction +! +! associate pneigh with the current corner +! + pneigh => pmeta%edges(ip,jp,2)%ptr + +! check if pneigh is associated +! + if (associated(pneigh)) then + +! if pneigh is on the same level +! + if (pneigh%level == pmeta%level) then + +! assiociate pself to the corresponding edge of the neighbor +! + pself => pneigh%edges(ir,jp,2)%ptr + +! check if pself is associated +! + if (associated(pself)) then + +! check if pself is the same as pmeta +! + if (pmeta%id /= pself%id) then + +! print warning, since the blocks differ +! + call print_warning(fname & + , "Inconsistent same level neighbor edge!") + write(*,"(a6,' id: ',i8,' [ ',3(i2,','),' ]')") & + 'meta ', pmeta%id, ip, jp, 2 + write(*,"(a6,' id: ',i8,' [ ',3(i2,','),' ]')") & + 'neigh', pneigh%id, ir, jp, 2 + write(*,"(a6,' id: ',i8)") 'self ', pself%id + + end if ! %id fields don't match + + else ! pself associated + +! print warning, since the pointer should be associated +! + call print_warning(fname & + , "Same level neighbor's edge not associated!") + write(*,"(a6,' id: ',i8,' [ ',3(i2,','),' ]')") & + 'meta ', pmeta%id , ip, jp, 2 + write(*,"(a6,' id: ',i8,' [ ',3(i2,','),' ]')") & + 'neigh', pneigh%id, ir, jp, 2 + + end if ! pself associated + + end if ! pneigh and pmeta on the same level + +! if pneigh is on the higher level level +! + if (pneigh%level > pmeta%level) then + +! iterate over all edges in the given direction and Y side +! + do jc = 1, nsides + +! assiociate pself to the corresponding edge of the neighbor +! + pself => pneigh%edges(ir,jc,2)%ptr + +! check if pself is associated +! + if (associated(pself)) then + +! check if pself is the same as pmeta +! + if (pmeta%id /= pself%id) then + +! print warning, since the blocks differ +! + call print_warning(fname & + , "Inconsistent higher level neighbor edge!") + write(*,"(a6,' id: ',i8,' [ ',3(i2,','),' ]')") & + 'meta ', pmeta%id, ip, jp, 2 + write(*,"(a6,' id: ',i8,' [ ',3(i2,','),' ]')") & + 'neigh', pneigh%id, ir, jp, 2 + write(*,"(a6,' id: ',i8,' [ ',3(i2,','),' ]')") & + 'self ', pself%id, ir, jc, 2 + + end if ! %id fields don't match + + else ! pself associated + +! print warning, since the pointer should be associated +! + call print_warning(fname & + , "Higher level neighbor's edge not associated!") + write(*,"(a6,' id: ',i8,' [ ',3(i2,','),' ]')") & + 'meta ', pmeta%id, ip, jp, 2 + write(*,"(a6,' id: ',i8,' [ ',3(i2,','),' ]')") & + 'neigh', pneigh%id, ir, jc, 2 + + end if ! pself associated + + end do ! jc = 1, nsides + + end if ! pneigh on higher level + + end if ! pneigh associated + +!--- check corners --- +! +! associate pneigh with the current corner +! + pneigh => pmeta%corners(ip,jp)%ptr + +! check if the neighbor is associated +! + if (associated(pneigh)) then + +! assiociate pself to the corresponding corner of the neighbor +! + pself => pneigh%corners(ir,jr)%ptr + +! check if pself is associated +! + if (associated(pself)) then + +! check if pself is the same as pmeta +! + if (pmeta%id /= pself%id) then + +! print warning, since the blocks differ +! + call print_warning(fname & + , "Inconsistent neighbor corners!") + write(*,"(a6,' id: ',i8,' [ ',2(i2,','),' ]')") & + 'meta ', pmeta%id, ip, jp + write(*,"(a6,' id: ',i8,' [ ',2(i2,','),' ]')") & + 'neigh', pneigh%id, ir, jr + write(*,"(a6,' id: ',i8)") 'self ', pself%id + + end if ! %id fields don't match + + else ! pself associated + +! print warning, since the pointer should be associated +! + call print_warning(fname & + , "Neighbor's corner not associated!") + write(*,"(a6,' id: ',i8,' [ ',2(i2,','),' ]')") & + 'meta ', pmeta%id, ip, jp + write(*,"(a6,' id: ',i8,' [ ',2(i2,','),' ]')") & + 'neigh', pneigh%id, ir, jr + + end if ! pself associated + + end if ! pneigh associated + + end do ! ip = 1, nsides + end do ! jp = 1, nsides +#endif /* NDIMS == 2 */ +#if NDIMS == 3 +! iterate over all corners +! + do kp = 1, nsides + kr = 3 - kp + do jp = 1, nsides + jr = 3 - jp + do ip = 1, nsides + ir = 3 - ip + +!--- check faces --- +! +! along X direction +! +! associate pneigh with the current face +! + pneigh => pmeta%faces(ip,jp,kp,1)%ptr + +! check if pneigh is associated +! + if (associated(pneigh)) then + +! if pneigh is on the same level +! + if (pneigh%level == pmeta%level) then + +! assiociate pself to the corresponding face of the neighbor +! + pself => pneigh%faces(ir,jp,kp,1)%ptr + +! check if pself is associated +! + if (associated(pself)) then + +! check if pself is the same as pmeta +! + if (pmeta%id /= pself%id) then + +! print warning, since the blocks differ +! + call print_warning(fname & + , "Inconsistent same level neighbor faces!") + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'meta ', pmeta%id , ip, jp, kp, 1 + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'neigh', pneigh%id, ir, jp, kp, 1 + write(*,"(a6,' id: ',i8)") 'self ', pself%id + + end if ! %id fields don't match + + else ! pself associated + +! print warning, since the pointer should be associated +! + call print_warning(fname & + , "Same level neighbor's face not associated!") + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'meta ', pmeta%id , ip, jp, kp, 1 + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'neigh', pneigh%id, ir, jp, kp, 1 + + end if ! pself associated + + end if ! pneigh and pmeta on the same level + +! if pneigh is on higher level +! + if (pneigh%level > pmeta%level) then + +! iterate over all neighbor faces +! + do kc = 1, nsides + do jc = 1, nsides + +! assiociate pself to the corresponding face of the neighbor +! + pself => pneigh%faces(ir,jc,kc,1)%ptr + +! check if pself is associated +! + if (associated(pself)) then + +! check if pself is the same as pmeta +! + if (pmeta%id /= pself%id) then + +! print warning, since the blocks differ +! + call print_warning(fname & + , "Inconsistent higher level neighbor face!") + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'meta ', pmeta%id , ip, jp, kp, 1 + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'neigh', pneigh%id, ir, jp, kp, 1 + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'self ', pself%id, ir, jc, kc, 1 + + end if ! %id fields don't match + + else ! pself associated + +! print warning, since the pointer should be associated +! + call print_warning(fname & + , "Higher level neighbor's face not associated!") + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'meta ', pmeta%id , ip, jp, kp, 1 + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'neigh', pneigh%id, ir, jc, kc, 1 + + end if ! pself associated + + end do ! jc = 1, nsides + end do ! kc = 1, nsides + + end if ! pneigh on higher level + + end if ! pneigh associated + +! along Y direction +! +! associate pneigh with the current face +! + pneigh => pmeta%faces(ip,jp,kp,2)%ptr + +! check if pneigh is associated +! + if (associated(pneigh)) then + +! if pneigh is on the same level +! + if (pneigh%level == pmeta%level) then + +! assiociate pself to the corresponding face of the neighbor +! + pself => pneigh%faces(ip,jr,kp,2)%ptr + +! check if pself is associated +! + if (associated(pself)) then + +! check if pself is the same as pmeta +! + if (pmeta%id /= pself%id) then + +! print warning, since the blocks differ +! + call print_warning(fname & + , "Inconsistent same level neighbor faces!") + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'meta ', pmeta%id , ip, jp, kp, 2 + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'neigh', pneigh%id, ip, jr, kp, 2 + write(*,"(a6,' id: ',i8)") 'self ', pself%id + + end if ! %id fields don't match + + else ! pself associated + +! print warning, since the pointer should be associated +! + call print_warning(fname & + , "Same level neighbor's face not associated!") + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'meta ', pmeta%id , ip, jp, kp, 2 + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'neigh', pneigh%id, ip, jr, kp, 2 + + end if ! pself associated + + end if ! pneigh and pmeta on the same level + +! if pneigh is on higher level +! + if (pneigh%level > pmeta%level) then + +! iterate over all neighbor faces +! + do kc = 1, nsides + do ic = 1, nsides + +! assiociate pself to the corresponding face of the neighbor +! + pself => pneigh%faces(ic,jr,kc,2)%ptr + +! check if pself is associated +! + if (associated(pself)) then + +! check if pself is the same as pmeta +! + if (pmeta%id /= pself%id) then + +! print warning, since the blocks differ +! + call print_warning(fname & + , "Inconsistent higher level neighbor face!") + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'meta ', pmeta%id , ip, jp, kp, 2 + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'neigh', pneigh%id, ip, jr, kp, 2 + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'self ', pself%id, ic, jr, kc, 2 + + end if ! %id fields don't match + + else ! pself associated + +! print warning, since the pointer should be associated +! + call print_warning(fname & + , "Higher level neighbor's face not associated!") + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'meta ', pmeta%id , ip, jp, kp, 2 + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'neigh', pneigh%id, ic, jr, kc, 2 + + end if ! pself associated + + end do ! ic = 1, nsides + end do ! kc = 1, nsides + + end if ! pneigh on higher level + + end if ! pneigh associated + +! along Z direction +! +! associate pneigh with the current face +! + pneigh => pmeta%faces(ip,jp,kp,3)%ptr + +! check if pneigh is associated +! + if (associated(pneigh)) then + +! if pneigh is on the same level +! + if (pneigh%level == pmeta%level) then + +! assiociate pself to the corresponding face of the neighbor +! + pself => pneigh%faces(ip,jp,kr,3)%ptr + +! check if pself is associated +! + if (associated(pself)) then + +! check if pself is the same as pmeta +! + if (pmeta%id /= pself%id) then + +! print warning, since the blocks differ +! + call print_warning(fname & + , "Inconsistent same level neighbor faces!") + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'meta ', pmeta%id , ip, jp, kp, 3 + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'neigh', pneigh%id, ip, jp, kr, 3 + write(*,"(a6,' id: ',i8)") 'self ', pself%id + + end if ! %id fields don't match + + else ! pself associated + +! print warning, since the pointer should be associated +! + call print_warning(fname & + , "Same level neighbor's face not associated!") + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'meta ', pmeta%id , ip, jp, kp, 3 + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'neigh', pneigh%id, ip, jp, kr, 3 + + end if ! pself associated + + end if ! pneigh and pmeta on the same level + +! if pneigh is on higher level +! + if (pneigh%level > pmeta%level) then + +! iterate over all neighbor faces +! + do jc = 1, nsides + do ic = 1, nsides + +! assiociate pself to the corresponding face of the neighbor +! + pself => pneigh%faces(ic,jc,kr,3)%ptr + +! check if pself is associated +! + if (associated(pself)) then + +! check if pself is the same as pmeta +! + if (pmeta%id /= pself%id) then + +! print warning, since the blocks differ +! + call print_warning(fname & + , "Inconsistent higher level neighbor face!") + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'meta ', pmeta%id , ip, jp, kp, 3 + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'neigh', pneigh%id, ip, jp, kr, 3 + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'self ', pself%id, ic, jc, kr, 3 + + end if ! %id fields don't match + + else ! pself associated + +! print warning, since the pointer should be associated +! + call print_warning(fname & + , "Higher level neighbor's face not associated!") + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'meta ', pmeta%id , ip, jp, kp, 3 + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'neigh', pneigh%id, ic, jc, kr, 3 + + end if ! pself associated + + end do ! ic = 1, nsides + end do ! jc = 1, nsides + + end if ! pneigh on higher level + + end if ! pneigh associated + +!--- check edges --- +! +! along X direction +! +! associate pneigh with the current edge +! + pneigh => pmeta%edges(ip,jp,kp,1)%ptr + +! check if pneigh is associated +! + if (associated(pneigh)) then + +! if pneigh is on the same level +! + if (pneigh%level == pmeta%level) then + +! assiociate pself to the corresponding edge of the neighbor +! + pself => pneigh%edges(ip,jr,kr,1)%ptr + +! check if pself is associated +! + if (associated(pself)) then + +! check if pself is the same as pmeta +! + if (pmeta%id /= pself%id) then + +! print warning, since the blocks differ +! + call print_warning(fname & + , "Inconsistent same level neighbor edges!") + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'meta ', pmeta%id , ip, jp, kp, 1 + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'neigh', pneigh%id, ip, jr, kr, 1 + write(*,"(a6,' id: ',i8)") 'self ', pself%id + + end if ! %id fields don't match + + else ! pself associated + +! print warning, since the pointer should be associated +! + call print_warning(fname & + , "Same level neighbor's edge not associated!") + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'meta ', pmeta%id , ip, jp, kp, 1 + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'neigh', pneigh%id, ip, jr, kr, 1 + + end if ! pself associated + + end if ! pneigh and pmeta on the same level + +! if pneigh is on higher level +! + if (pneigh%level > pmeta%level) then + +! iterate over all neighbor edges +! + do ic = 1, nsides + +! assiociate pself to the corresponding face of the neighbor +! + pself => pneigh%edges(ic,jr,kr,1)%ptr + +! check if pself is associated +! + if (associated(pself)) then + +! check if pself is the same as pmeta +! + if (pmeta%id /= pself%id) then + +! print warning, since the blocks differ +! + call print_warning(fname & + , "Inconsistent higher level neighbor edge!") + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'meta ', pmeta%id , ip, jp, kp, 1 + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'neigh', pneigh%id, ip, jr, kr, 1 + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'self ', pself%id, ic, jr, kr, 1 + + end if ! %id fields don't match + + else ! pself associated + +! print warning, since the pointer should be associated +! + call print_warning(fname & + , "Higher level neighbor's edge not associated!") + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'meta ', pmeta%id , ip, jp, kp, 1 + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'neigh', pneigh%id, ic, jr, kr, 1 + + end if ! pself associated + + end do ! ic = 1, nsides + + end if ! pneigh on higher level + + end if ! pneigh associated + +! along Y direction +! +! associate pneigh with the current edge +! + pneigh => pmeta%edges(ip,jp,kp,2)%ptr + +! check if pneigh is associated +! + if (associated(pneigh)) then + +! if pneigh is on the same level +! + if (pneigh%level == pmeta%level) then + +! assiociate pself to the corresponding edge of the neighbor +! + pself => pneigh%edges(ir,jp,kr,2)%ptr + +! check if pself is associated +! + if (associated(pself)) then + +! check if pself is the same as pmeta +! + if (pmeta%id /= pself%id) then + +! print warning, since the blocks differ +! + call print_warning(fname & + , "Inconsistent same level neighbor edges!") + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'meta ', pmeta%id , ip, jp, kp, 2 + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'neigh', pneigh%id, ir, jp, kr, 2 + write(*,"(a6,' id: ',i8)") 'self ', pself%id + + end if ! %id fields don't match + + else ! pself associated + +! print warning, since the pointer should be associated +! + call print_warning(fname & + , "Same level neighbor's edge not associated!") + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'meta ', pmeta%id , ip, jp, kp, 2 + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'neigh', pneigh%id, ir, jp, kr, 2 + + end if ! pself associated + + end if ! pneigh and pmeta on the same level + +! if pneigh is on higher level +! + if (pneigh%level > pmeta%level) then + +! iterate over all neighbor edges +! + do jc = 1, nsides + +! assiociate pself to the corresponding face of the neighbor +! + pself => pneigh%edges(ir,jc,kr,2)%ptr + +! check if pself is associated +! + if (associated(pself)) then + +! check if pself is the same as pmeta +! + if (pmeta%id /= pself%id) then + +! print warning, since the blocks differ +! + call print_warning(fname & + , "Inconsistent higher level neighbor edge!") + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'meta ', pmeta%id , ip, jp, kp, 2 + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'neigh', pneigh%id, ir, jp, kr, 2 + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'self ', pself%id, ir, jc, kr, 2 + + end if ! %id fields don't match + + else ! pself associated + +! print warning, since the pointer should be associated +! + call print_warning(fname & + , "Higher level neighbor's edge not associated!") + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'meta ', pmeta%id , ip, jp, kp, 2 + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'neigh', pneigh%id, ir, jc, kr, 2 + + end if ! pself associated + + end do ! jc = 1, nsides + + end if ! pneigh on higher level + + end if ! pneigh associated + +! along Z direction +! +! associate pneigh with the current edge +! + pneigh => pmeta%edges(ip,jp,kp,3)%ptr + +! check if pneigh is associated +! + if (associated(pneigh)) then + +! if pneigh is on the same level +! + if (pneigh%level == pmeta%level) then + +! assiociate pself to the corresponding edge of the neighbor +! + pself => pneigh%edges(ir,jr,kp,3)%ptr + +! check if pself is associated +! + if (associated(pself)) then + +! check if pself is the same as pmeta +! + if (pmeta%id /= pself%id) then + +! print warning, since the blocks differ +! + call print_warning(fname & + , "Inconsistent same level neighbor edges!") + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'meta ', pmeta%id , ip, jp, kp, 3 + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'neigh', pneigh%id, ir, jr, kp, 3 + write(*,"(a6,' id: ',i8)") 'self ', pself%id + + end if ! %id fields don't match + + else ! pself associated + +! print warning, since the pointer should be associated +! + call print_warning(fname & + , "Same level neighbor's edge not associated!") + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'meta ', pmeta%id , ip, jp, kp, 3 + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'neigh', pneigh%id, ir, jr, kp, 3 + + end if ! pself associated + + end if ! pneigh and pmeta on the same level + +! if pneigh is on higher level +! + if (pneigh%level > pmeta%level) then + +! iterate over all neighbor edges +! + do kc = 1, nsides + +! assiociate pself to the corresponding face of the neighbor +! + pself => pneigh%edges(ir,jr,kc,3)%ptr + +! check if pself is associated +! + if (associated(pself)) then + +! check if pself is the same as pmeta +! + if (pmeta%id /= pself%id) then + +! print warning, since the blocks differ +! + call print_warning(fname & + , "Inconsistent higher level neighbor edge!") + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'meta ', pmeta%id , ip, jp, kp, 3 + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'neigh', pneigh%id, ir, jr, kp, 3 + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'self ', pself%id, ir, jr, kc, 3 + + end if ! %id fields don't match + + else ! pself associated + +! print warning, since the pointer should be associated +! + call print_warning(fname & + , "Higher level neighbor's edge not associated!") + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'meta ', pmeta%id , ip, jp, kp, 3 + write(*,"(a6,' id: ',i8,' [ ',4(i2,','),' ]')") & + 'neigh', pneigh%id, ir, jr, kc, 3 + + end if ! pself associated + + end do ! kc = 1, nsides + + end if ! pneigh on higher level + + end if ! pneigh associated + +!--- check corners --- +! +! associate pneigh with the current corner +! + pneigh => pmeta%corners(ip,jp,kp)%ptr ! check if the neighbor is associated ! if (associated(pneigh)) then -! check neighbors on the same levels +! assiociate pself to the corresponding corner of the neighbor ! - if (pmeta%level == pneigh%level) then + pself => pneigh%corners(ir,jr,kr)%ptr -! assign pointer to the neighbor of the neighbor pointing to the current meta -! block +! check if pself is associated ! - pnneigh => pneigh%neigh(i,m,k)%ptr + if (associated(pself)) then -! check if it is associated +! check if pself is the same as pmeta ! - if (associated(pnneigh)) then - -! check if the pointer of the neighbor points to the current meta block -! - if (pmeta%id /= pnneigh%id) then + if (pmeta%id /= pself%id) then ! print warning, since the blocks differ ! - call print_warning("blocks::check_block_neighbors" & - , "Inconsistent same level neighbors!") - print *, 'metablock: ', pmeta%id, pnneigh%id - print *, 'neighbor : ', pneigh%id - print *, 'index : ', i, j, k + call print_warning(fname & + , "Inconsistent neighbor corners!") + write(*,"(a6,' id: ',i8,' [ ',3(i2,','),' ]')") & + 'meta ', pmeta%id, ip, jp, kp + write(*,"(a6,' id: ',i8,' [ ',3(i2,','),' ]')") & + 'neigh', pneigh%id, ir, jr, kr + write(*,"(a6,' id: ',i8)") 'self ', pself%id - end if + end if ! %id fields don't match - else ! pnneigh associated + else ! pself associated ! print warning, since the pointer should be associated ! - call print_warning("blocks::check_block_neighbors" & - , "Same level neighbor not associated!") - print *, 'metablock: ', pmeta%id, pnneigh%id - print *, 'neighbor : ', pneigh%id - print *, 'index : ', i, j, k + call print_warning(fname & + , "Neighbor's corner not associated!") + write(*,"(a6,' id: ',i8,' [ ',3(i2,','),' ]')") & + 'meta ', pmeta%id, ip, jp, kp + write(*,"(a6,' id: ',i8,' [ ',3(i2,','),' ]')") & + 'neigh', pneigh%id, ir, jr, kr - end if ! pnneigh associated - - end if ! the same levels - -! check neighbors on the level higher than the meta block's level; it also -! covers the other way around, since we iterate over all neighbor faces -! - if (pmeta%level < pneigh%level) then - -! iterate over whole face of the corresponding neighbor -! - do l = 1, nfaces - -! assign pointer to the corresponding neighbor of the neighbor -! - pnneigh => pneigh%neigh(i,m,l)%ptr - -! check if it is associated -! - if (associated(pnneigh)) then - -! check if the pointer of the neighbor points to the current meta block -! - if (pmeta%id /= pnneigh%id) then - -! print warning, since the blocks differ -! - call print_warning("blocks::check_block_neighbors" & - , "Inconsistent different level neighbors!") - print *, 'metablock: ', pmeta%id, pnneigh%id - print *, 'neighbor : ', pneigh%id - print *, 'index : ', i, j, k, l - - end if - - else ! pnneigh associated - -! print warning, since the pointer should be associated -! - call print_warning("blocks::check_block_neighbors" & - , "Different level neighbor not associated!") - print *, 'metablock: ', pmeta%id, pnneigh%id - print *, 'neighbor : ', pneigh%id - print *, 'index : ', i, j, k, l - - end if ! pnneigh associated - - end do ! l = 1, nfaces - - end if ! pmeta's level < pneigh's level + end if ! pself associated end if ! pneigh associated - end do ! nfaces - end do ! nsides - end do ! ndims + end do ! ip = 1, nsides + end do ! jp = 1, nsides + end do ! kp = 1, nsides +#endif /* NDIMS == 3 */ !------------------------------------------------------------------------------- ! From 1395712472ceefdad467a4b67081529088d0df22 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Thu, 24 Jul 2014 12:39:40 -0300 Subject: [PATCH 91/91] BLOCKS: Remove all remainings after old %neigh pointers. Signed-off-by: Grzegorz Kowal --- src/blocks.F90 | 377 +------------------------------------------------ src/mesh.F90 | 2 +- 2 files changed, 2 insertions(+), 377 deletions(-) diff --git a/src/blocks.F90 b/src/blocks.F90 index 2d0606d..4dc0708 100644 --- a/src/blocks.F90 +++ b/src/blocks.F90 @@ -55,15 +55,11 @@ module blocks ! ! ndims - the number of dimensions (2 or 3); ! nsides - the number of sides along each direction (2); -! nfaces - the number of faces at each side (2 for 2D, 4 for 3D); ! nchildren - the number of child blocks for each block (4 for 2D, 8 for 3D); -! mfaces - the number of faces in block (8 for 2D, 24 for 3D); ! integer(kind=4), parameter :: ndims = NDIMS integer(kind=4), parameter :: nsides = 2 - integer(kind=4), parameter :: nfaces = 2**(ndims - 1) integer(kind=4), parameter :: nchildren = 2**ndims - integer(kind=4), parameter :: mfaces = nsides * nfaces * ndims ! MODULE VARIABLES: ! ================ @@ -175,10 +171,6 @@ module blocks type(pointer_meta) :: corners(nsides,nsides,nsides) #endif /* NDIMS == 3 */ - ! pointers to neighbor meta blocks - ! - type(pointer_meta) :: neigh(ndims,nsides,nfaces) - ! a pointer to the associated data block ! type(block_data) , pointer :: data @@ -321,7 +313,7 @@ module blocks public :: pointer_meta, pointer_info public :: block_meta, block_data, block_info public :: list_meta, list_data - public :: ndims, nsides, nfaces, nchildren + public :: ndims, nsides, nchildren ! declare public subroutines ! @@ -909,16 +901,6 @@ module blocks end do ! nsides #endif /* NDIMS == 3 */ -! nullify fields pointing to neighbors -! - do i = 1, ndims - do j = 1, nsides - do k = 1, nfaces - nullify(pmeta%neigh(i,j,k)%ptr) - end do - end do - end do - ! nullify the field pointing to the associated data block ! nullify(pmeta%data) @@ -1050,16 +1032,6 @@ module blocks end do ! nsides #endif /* NDIMS == 3 */ -! nullify fields pointing to neighbors -! - do i = 1, ndims - do j = 1, nsides - do k = 1, nfaces - nullify(pmeta%neigh(i,j,k)%ptr) - end do - end do - end do - ! if there is a data block is associated, remove it ! if (associated(pmeta%data)) call remove_datablock(pmeta%data) @@ -1379,7 +1351,6 @@ module blocks ! integer, dimension(0:79,nchildren) , save :: order integer, dimension(0:79,nchildren) , save :: config - integer, dimension(ndims,nsides,nfaces), save :: set ! !------------------------------------------------------------------------------- ! @@ -1447,23 +1418,6 @@ module blocks config(78,:) = (/ 75, 73, 73, 12, 12, 48, 48, 68 /) #endif /* NDIMS == 3 */ -! prepare set array -! -#if NDIMS == 2 - set(1,1,:) = (/ 1, 3 /) - set(1,2,:) = (/ 2, 4 /) - set(2,1,:) = (/ 1, 2 /) - set(2,2,:) = (/ 3, 4 /) -#endif /* NDIMS == 2 */ -#if NDIMS == 3 - set(1,1,:) = (/ 1, 3, 5, 7 /) - set(1,2,:) = (/ 2, 4, 6, 8 /) - set(2,1,:) = (/ 1, 2, 5, 6 /) - set(2,2,:) = (/ 3, 4, 7, 8 /) - set(3,1,:) = (/ 1, 2, 3, 4 /) - set(3,2,:) = (/ 5, 6, 7, 8 /) -#endif /* NDIMS == 3 */ - ! reset the first execution flag ! first = .false. @@ -2377,258 +2331,6 @@ module blocks end do ! kp = 1, nsides #endif /* NDIMS == 3 */ -!! ASSIGN PROPER NEIGHBORS FOR THE CHILDREN IN THE INTERIOR OF THE PARENT BLOCK -!! -! iterate over faces and update the interior of the block -! - do p = 1, nfaces - -! X direction (left side) -! - pmeta%child(2)%ptr%neigh(1,1,p)%ptr => pmeta%child(1)%ptr - pmeta%child(4)%ptr%neigh(1,1,p)%ptr => pmeta%child(3)%ptr -#if NDIMS == 3 - pmeta%child(6)%ptr%neigh(1,1,p)%ptr => pmeta%child(5)%ptr - pmeta%child(8)%ptr%neigh(1,1,p)%ptr => pmeta%child(7)%ptr -#endif /* NDIMS == 3 */ - -! associate pneigh with a neighbor -! - pneigh => pmeta%neigh(1,1,1)%ptr - -! if neighbor and associated and points to parent block, it corresponds to -! periodic boundaries at the lowest level -! - if (associated(pneigh)) then - - if (pneigh%id == pmeta%id) then - - pmeta%child(1)%ptr%neigh(1,1,p)%ptr => pmeta%child(2)%ptr - pmeta%child(3)%ptr%neigh(1,1,p)%ptr => pmeta%child(4)%ptr -#if NDIMS == 3 - pmeta%child(5)%ptr%neigh(1,1,p)%ptr => pmeta%child(6)%ptr - pmeta%child(7)%ptr%neigh(1,1,p)%ptr => pmeta%child(8)%ptr -#endif /* NDIMS == 3 */ - - end if - - end if - -! X direction (right side) -! - pmeta%child(1)%ptr%neigh(1,2,p)%ptr => pmeta%child(2)%ptr - pmeta%child(3)%ptr%neigh(1,2,p)%ptr => pmeta%child(4)%ptr -#if NDIMS == 3 - pmeta%child(5)%ptr%neigh(1,2,p)%ptr => pmeta%child(6)%ptr - pmeta%child(7)%ptr%neigh(1,2,p)%ptr => pmeta%child(8)%ptr -#endif /* NDIMS == 3 */ - -! associate pneigh with a neighbor -! - pneigh => pmeta%neigh(1,2,1)%ptr - -! if neighbor and associated and points to parent block, it corresponds to -! periodic boundaries at the lowest level -! - if (associated(pneigh)) then - - if (pneigh%id == pmeta%id) then - - pmeta%child(2)%ptr%neigh(1,2,p)%ptr => pmeta%child(1)%ptr - pmeta%child(4)%ptr%neigh(1,2,p)%ptr => pmeta%child(3)%ptr -#if NDIMS == 3 - pmeta%child(6)%ptr%neigh(1,2,p)%ptr => pmeta%child(5)%ptr - pmeta%child(8)%ptr%neigh(1,2,p)%ptr => pmeta%child(7)%ptr -#endif /* NDIMS == 3 */ - - end if - - end if - -! Y direction (left side) -! - pmeta%child(3)%ptr%neigh(2,1,p)%ptr => pmeta%child(1)%ptr - pmeta%child(4)%ptr%neigh(2,1,p)%ptr => pmeta%child(2)%ptr -#if NDIMS == 3 - pmeta%child(7)%ptr%neigh(2,1,p)%ptr => pmeta%child(5)%ptr - pmeta%child(8)%ptr%neigh(2,1,p)%ptr => pmeta%child(6)%ptr -#endif /* NDIMS == 3 */ - -! associate pneigh with a neighbor -! - pneigh => pmeta%neigh(2,1,1)%ptr - -! if neighbor and associated and points to parent block, it corresponds to -! periodic boundaries at the lowest level -! - if (associated(pneigh)) then - - if (pneigh%id == pmeta%id) then - - pmeta%child(1)%ptr%neigh(2,1,p)%ptr => pmeta%child(3)%ptr - pmeta%child(2)%ptr%neigh(2,1,p)%ptr => pmeta%child(4)%ptr -#if NDIMS == 3 - pmeta%child(5)%ptr%neigh(2,1,p)%ptr => pmeta%child(7)%ptr - pmeta%child(6)%ptr%neigh(2,1,p)%ptr => pmeta%child(8)%ptr -#endif /* NDIMS == 3 */ - - end if - - end if - -! Y direction (right side) -! - pmeta%child(1)%ptr%neigh(2,2,p)%ptr => pmeta%child(3)%ptr - pmeta%child(2)%ptr%neigh(2,2,p)%ptr => pmeta%child(4)%ptr -#if NDIMS == 3 - pmeta%child(5)%ptr%neigh(2,2,p)%ptr => pmeta%child(7)%ptr - pmeta%child(6)%ptr%neigh(2,2,p)%ptr => pmeta%child(8)%ptr -#endif /* NDIMS == 3 */ - -! associate pneigh with a neighbor -! - pneigh => pmeta%neigh(2,2,1)%ptr - -! if neighbor and associated and points to parent block, it corresponds to -! periodic boundaries at the lowest level -! - if (associated(pneigh)) then - - if (pneigh%id == pmeta%id) then - - pmeta%child(3)%ptr%neigh(2,2,p)%ptr => pmeta%child(1)%ptr - pmeta%child(4)%ptr%neigh(2,2,p)%ptr => pmeta%child(2)%ptr -#if NDIMS == 3 - pmeta%child(7)%ptr%neigh(2,2,p)%ptr => pmeta%child(5)%ptr - pmeta%child(8)%ptr%neigh(2,2,p)%ptr => pmeta%child(6)%ptr -#endif /* NDIMS == 3 */ - - end if - - end if - -#if NDIMS == 3 -! Z direction (left side) -! - pmeta%child(5)%ptr%neigh(3,1,p)%ptr => pmeta%child(1)%ptr - pmeta%child(6)%ptr%neigh(3,1,p)%ptr => pmeta%child(2)%ptr - pmeta%child(7)%ptr%neigh(3,1,p)%ptr => pmeta%child(3)%ptr - pmeta%child(8)%ptr%neigh(3,1,p)%ptr => pmeta%child(4)%ptr - -! associate pneigh with a neighbor -! - pneigh => pmeta%neigh(3,1,1)%ptr - -! if neighbor and associated and points to parent block, it corresponds to -! periodic boundaries at the lowest level -! - if (associated(pneigh)) then - - if (pneigh%id == pmeta%id) then - - pmeta%child(1)%ptr%neigh(3,1,p)%ptr => pmeta%child(5)%ptr - pmeta%child(2)%ptr%neigh(3,1,p)%ptr => pmeta%child(6)%ptr - pmeta%child(3)%ptr%neigh(3,1,p)%ptr => pmeta%child(7)%ptr - pmeta%child(4)%ptr%neigh(3,1,p)%ptr => pmeta%child(8)%ptr - - end if - - end if - -! Z direction (right side) -! - pmeta%child(1)%ptr%neigh(3,2,p)%ptr => pmeta%child(5)%ptr - pmeta%child(2)%ptr%neigh(3,2,p)%ptr => pmeta%child(6)%ptr - pmeta%child(3)%ptr%neigh(3,2,p)%ptr => pmeta%child(7)%ptr - pmeta%child(4)%ptr%neigh(3,2,p)%ptr => pmeta%child(8)%ptr - -! associate pneigh with a neighbor -! - pneigh => pmeta%neigh(3,2,1)%ptr - -! if neighbor and associated and points to parent block, it corresponds to -! periodic boundaries at the lowest level -! - if (associated(pneigh)) then - - if (pneigh%id == pmeta%id) then - - pmeta%child(5)%ptr%neigh(3,2,p)%ptr => pmeta%child(1)%ptr - pmeta%child(6)%ptr%neigh(3,2,p)%ptr => pmeta%child(2)%ptr - pmeta%child(7)%ptr%neigh(3,2,p)%ptr => pmeta%child(3)%ptr - pmeta%child(8)%ptr%neigh(3,2,p)%ptr => pmeta%child(4)%ptr - - end if - - end if -#endif /* NDIMS == 3 */ - - end do ! nfaces - -!! UPDATE NEIGHBORS AND EXTERNAL NEIGHBORS OF CHILDREN -!! -! set pointers to neighbors and update neighbors' pointers -! - do i = 1, ndims - do j = 1, nsides - -! prepare reverse side index -! - q = 3 - j - -! iterate over all faces -! - do k = 1, nfaces - -! associate pointers with the neighbor and child -! - pneigh => pmeta%neigh(i,j,k)%ptr - pchild => pmeta%child(set(i,j,k))%ptr - -! check if neighbor is associated -! - if (associated(pneigh)) then - -! check if the parent block does not point to itself (periodic boundaries) -! - if (pneigh%id /= pmeta%id) then - -! point the child neigh field to the right neighbor -! - do p = 1, nfaces - pchild%neigh(i,j,p)%ptr => pneigh - end do - -! update neighbor pointer if it is at the same level -! - if (pneigh%level == pmeta%level) then - pneigh%neigh(i,q,k)%ptr => pchild - end if - -! update neighbor pointer if it is at higher level -! - if (pneigh%level > pmeta%level) then - do p = 1, nfaces - pneigh%neigh(i,q,p)%ptr => pchild - end do - end if - -! if neighbor has lower level than parent, something is wrong, since lower -! levels should be already refined -! - if (pneigh%level < pmeta%level) then - call print_error("blocks::refine_block" & - , "Neighbor found at lower level!") - end if - - end if ! pmeta and pneigh point to different blocks - - end if ! pneigh is associated - - end do ! nfaces - end do ! nsides - end do ! ndims - ! mark all neighbors to be updated as well ! call set_neighbors_update(pmeta) @@ -2669,16 +2371,6 @@ module blocks ! call metablock_set_refinement(pmeta, 0) -! nullify the parent's neighbor pointers -! - do i = 1, ndims - do j = 1, nsides - do k = 1, nfaces - nullify(pmeta%neigh(i,j,k)%ptr) - end do - end do - end do - ! restore the pointer to the current block ! if (associated(pnext)) then @@ -2741,14 +2433,6 @@ module blocks integer :: i , j , k integer :: ip, jp, kp integer :: ir, jr, kr - -! local saved variables -! - logical, save :: first = .true. - -! local arrays -! - integer, dimension(ndims, nsides, nfaces), save :: arr ! !------------------------------------------------------------------------------- ! @@ -2758,32 +2442,6 @@ module blocks call start_timer(imd) #endif /* PROFILE */ -! prepare saved variables at the first execution -! - if (first) then - -! prepare reference array -! -#if NDIMS == 3 - arr(1,1,:) = (/ 1, 3, 5, 7 /) - arr(1,2,:) = (/ 2, 4, 6, 8 /) - arr(2,1,:) = (/ 1, 2, 5, 6 /) - arr(2,2,:) = (/ 3, 4, 7, 8 /) - arr(3,1,:) = (/ 1, 2, 3, 4 /) - arr(3,2,:) = (/ 5, 6, 7, 8 /) -#else /* NDIMS == 3 */ - arr(1,1,:) = (/ 1, 3 /) - arr(1,2,:) = (/ 2, 4 /) - arr(2,1,:) = (/ 1, 2 /) - arr(2,2,:) = (/ 3, 4 /) -#endif /* NDIMS == 3 */ - -! reset the first execution flag -! - first = .false. - - end if - ! update neighbor pointers of the parent block ! #if NDIMS == 2 @@ -3225,39 +2883,6 @@ module blocks end do ! kp = 1, nsides #endif /* NDIMS == 3 */ -! iterate over dimensions, sides, and faces -! - do i = 1, ndims - do j = 1, nsides - do k = 1, nfaces - -! get the current child index -! - p = arr(i,j,k) - -! associate a pointer with the neighbor -! - pneigh => pmeta%child(p)%ptr%neigh(i,j,k)%ptr - -! update the parent neighbor field -! - pmeta%neigh(i,j,k)%ptr => pneigh - -! update the neigh field of the neighbor -! - if (associated(pneigh)) then - - l = 3 - j - do p = 1, nfaces - pneigh%neigh(i,l,p)%ptr => pmeta - end do - - end if ! pneigh is associated - - end do ! nfaces - end do ! nsides - end do ! ndims - ! iterate over children ! do p = 1, nchildren diff --git a/src/mesh.F90 b/src/mesh.F90 index 5f7a3e2..08fb6ef 100644 --- a/src/mesh.F90 +++ b/src/mesh.F90 @@ -456,7 +456,7 @@ module mesh ! import external procedures and variables ! use blocks , only : block_meta, block_data, list_meta, list_data - use blocks , only : ndims, nchildren, nsides, nfaces + use blocks , only : ndims, nchildren, nsides use blocks , only : allocate_datablock, deallocate_datablock use blocks , only : append_datablock use blocks , only : link_blocks, unlink_blocks, refine_block