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 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 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 diff --git a/src/blocks.F90 b/src/blocks.F90 index 7222a0b..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: ! ================ @@ -72,7 +68,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 @@ -122,9 +119,57 @@ module blocks ! type(pointer_meta) :: child(nchildren) - ! pointers to neighbor meta blocks +#if NDIMS == 2 + ! pointers to edge neighbor meta blocks with + ! indices: + ! 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) :: neigh(ndims,nsides,nfaces) + type(pointer_meta) :: edges(nsides,nsides,ndims) + + ! pointers to corner neighbor meta blocks with + ! indices: + ! 1 - the X corner coordinate + ! 2 - the Y corner 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 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(nsides,nsides,nsides,ndims) + + ! pointers to edge neighbor meta blocks with + ! indices: + ! 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(nsides,nsides,nsides,ndims) + + ! pointers to corner neighbor meta blocks with + ! indices: + ! 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) +#endif /* NDIMS == 3 */ ! a pointer to the associated data block ! @@ -238,6 +283,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 ! @@ -262,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 ! @@ -549,6 +600,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 @@ -601,6 +656,14 @@ 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 + ! deallocate memory used by the meta block ! call deallocate_metablock(pmeta) @@ -668,6 +731,10 @@ module blocks ! last_data => pdata +! increase the number of data blocks in the list +! + dblocks = dblocks + 1 + !------------------------------------------------------------------------------- ! end subroutine append_datablock @@ -733,6 +800,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) @@ -775,7 +846,7 @@ module blocks ! local variables ! - integer :: i, j, k + integer :: n, i, j, k ! !------------------------------------------------------------------------------- ! @@ -804,15 +875,31 @@ module blocks nullify(pmeta%child(i)%ptr) end do -! nullify fields pointing to neighbors +! nullify fields pointing to face, edge, and corner neighbors ! - do i = 1, ndims +#if NDIMS == 2 + do i = 1, nsides do j = 1, nsides - do k = 1, nfaces - nullify(pmeta%neigh(i,j,k)%ptr) - end do - end do - end do + do n = 1, ndims + nullify(pmeta%edges(i,j,n)%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(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 + end do ! nsides + end do ! nsides +#endif /* NDIMS == 3 */ ! nullify the field pointing to the associated data block ! @@ -849,10 +936,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 ! @@ -894,7 +977,7 @@ module blocks ! local variables ! - integer :: i, j, k + integer :: n, i, j, k ! !------------------------------------------------------------------------------- ! @@ -908,14 +991,6 @@ module blocks ! if (associated(pmeta)) then -! decrease the number of leafs -! - 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) @@ -931,15 +1006,31 @@ module blocks nullify(pmeta%child(i)%ptr) end do -! nullify fields pointing to neighbors +! nullify fields pointing to face, edge, and corner neighbors ! - do i = 1, ndims +#if NDIMS == 2 + do i = 1, nsides do j = 1, nsides - do k = 1, nfaces - nullify(pmeta%neigh(i,j,k)%ptr) - end do - end do - end do + do n = 1, ndims + nullify(pmeta%edges(i,j,n)%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(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 + end do ! nsides + end do ! nsides +#endif /* NDIMS == 3 */ ! if there is a data block is associated, remove it ! @@ -1036,10 +1127,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 +1178,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) @@ -1258,14 +1341,16 @@ 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 ! local arrays ! integer, dimension(0:79,nchildren) , save :: order integer, dimension(0:79,nchildren) , save :: config - integer, dimension(ndims,nsides,nfaces), save :: set ! !------------------------------------------------------------------------------- ! @@ -1333,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. @@ -1368,7 +1436,7 @@ module blocks !! ! set corresponding configuration of the new blocks ! - cf = pmeta%conf + q = pmeta%conf ! calculate sizes of the child blocks ! @@ -1394,12 +1462,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 @@ -1440,10 +1508,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 @@ -1462,7 +1530,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 ! @@ -1470,257 +1538,798 @@ module blocks end do ! nchildren -!! ASSIGN PROPER NEIGHBORS FOR THE CHILDREN IN THE INTERIOR OF THE PARENT BLOCK -!! -! iterate over faces and update the interior of the block +! update neighbor pointers of the parent block ! - do p = 1, nfaces +#if NDIMS == 2 + do jp = 1, nsides + jr = 3 - jp + do ip = 1, nsides + ir = 3 - ip -! X direction (left side) +! calculate the child index ! - 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 + p = 2 * (jp - 1) + ip + +! associate pchild with the proper child +! + pchild => pmeta%child(p)%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 + +! 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 + +! 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 + +! 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 + +!--- update corner neighbor pointers --- +! +! calculate the index of opposite child +! + q = 2 * (jr - 1) + ir + +! 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 */ #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 */ + do kp = 1, nsides + kr = 3 - kp + do jp = 1, nsides + jr = 3 - jp + do ip = 1, nsides + ir = 3 - ip -! associate pneigh with a neighbor +! calculate the child index ! - pneigh => pmeta%neigh(1,1,1)%ptr + p = 4 * (kp - 1) + 2 * (jp - 1) + ip -! if neighbor and associated and points to parent block, it corresponds to -! periodic boundaries at the lowest level +! associate pchild with the proper child ! - if (associated(pneigh)) then + pchild => pmeta%child(p)%ptr - 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) +!--- update face neighbor pointers --- ! - 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 +! prepare the index of neighbor child for X-faces ! - pneigh => pmeta%neigh(1,2,1)%ptr + q = 4 * (kp - 1) + 2 * (jp - 1) + ir -! if neighbor and associated and points to parent block, it corresponds to -! periodic boundaries at the lowest level +! set the internal side neighbor pointer ! - if (associated(pneigh)) then + 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 - 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) +! associate pneigh with the X-face neighbor ! - 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 */ + pneigh => pmeta%faces(ip,jp,kp,1)%ptr -! 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 +! 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 -! check if the parent block does not point to itself (periodic boundaries) +! prepare the index of neighbor child for Y-faces ! - if (pneigh%id /= pmeta%id) then + q = 4 * (kp - 1) + 2 * (jr - 1) + ip -! point the child neigh field to the right neighbor +! set the internal side neighbor pointer ! - do p = 1, nfaces - pchild%neigh(i,j,p)%ptr => pneigh - end do + 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 -! update neighbor pointer if it is at the same level +! associate pneigh with the Y-face neighbor ! - if (pneigh%level == pmeta%level) then - pneigh%neigh(i,q,k)%ptr => pchild - end if + pneigh => pmeta%faces(ip,jp,kp,2)%ptr -! update neighbor pointer if it is at higher level +! 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 - do p = 1, nfaces - pneigh%neigh(i,q,p)%ptr => pchild - end do + pchild%edges(ip,jr,kp,3)%ptr => pneigh + pchild%edges(ip,jr,kr,3)%ptr => pneigh end if + end if + end if ! pneigh associated -! if neighbor has lower level than parent, something is wrong, since lower -! levels should be already refined +! along Y-edge ! - if (pneigh%level < pmeta%level) then - call print_error("blocks::refine_block" & - , "Neighbor found at lower level!") + 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 - end if ! pmeta and pneigh point to different blocks +! 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 - end if ! pneigh is 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 - end do ! nfaces - end do ! nsides - end do ! ndims +! 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 +! +#if NDIMS == 2 + do jp = 1, nsides + jr = 3 - jp + do ip = 1, nsides + ir = 3 - ip + +! calculate the child index +! + p = 2 * (jp - 1) + ip + +! associate pchild with the proper child +! + pchild => pmeta%child(p)%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 + +! 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 + +!--- 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 + +! 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 + +! 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 + + 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 */ ! mark all neighbors to be updated as well ! @@ -1762,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 @@ -1830,15 +2429,10 @@ module blocks ! local variables ! - integer :: i, j, k, l, p - -! local saved variables -! - logical, save :: first = .true. - -! local arrays -! - integer, dimension(ndims, nsides, nfaces), save :: arr + integer :: l , p , q + integer :: i , j , k + integer :: ip, jp, kp + integer :: ir, jr, kr ! !------------------------------------------------------------------------------- ! @@ -1848,64 +2442,446 @@ module blocks call start_timer(imd) #endif /* PROFILE */ -! prepare saved variables at the first execution +! update neighbor pointers of the parent block ! - if (first) then +#if NDIMS == 2 + do jp = 1, nsides + jr = 3 - jp + do ip = 1, nsides + ir = 3 - ip -! prepare reference array +! calculate the child index ! + p = 2 * (jp - 1) + ip + +! associate pchild with the proper child +! + pchild => pmeta%child(p)%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 + +! 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 + +!--- 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 + + end do ! ip = 1, nsides + end do ! jp = 1, nsides +#endif /* NDIMS == 2 */ #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 */ + do kp = 1, nsides + kr = 3 - kp + do jp = 1, nsides + jr = 3 - jp + do ip = 1, nsides + ir = 3 - ip -! reset the first execution flag +! calculate the child index ! - first = .false. + p = 4 * (kp - 1) + 2 * (jp - 1) + ip - end if - -! iterate over dimensions, sides, and faces +! associate pchild with the proper child ! - do i = 1, ndims - do j = 1, nsides - do k = 1, nfaces + pchild => pmeta%child(p)%ptr -! get the current child index +!--- update face neighbor pointers --- ! - p = arr(i,j,k) - -! associate a pointer with the neighbor +! assign pneigh to the X-face neighbor ! - pneigh => pmeta%child(p)%ptr%neigh(i,j,k)%ptr + pneigh => pchild%faces(ip,jp,kp,1)%ptr -! update the parent neighbor field +! set the corresponding neighbor face pointers ! - pmeta%neigh(i,j,k)%ptr => pneigh + 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 -! update the neigh field of the neighbor +! 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 - l = 3 - j - do p = 1, nfaces - pneigh%neigh(i,l,p)%ptr => pmeta - end do +! calculate the index of the opposite child +! + q = 4 * (kr - 1) + 2 * (jr - 1) + ir - end if ! pneigh is associated + 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 ! 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 */ + +! update neighbor pointers of the neighbor blocks +! +#if NDIMS == 2 + do jp = 1, nsides + jr = 3 - jp + do ip = 1, nsides + ir = 3 - ip + +!--- update neighbor's edge pointers --- +! +! 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 + +! 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 + +!--- 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 + +! 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 + +! 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 + + 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 children ! @@ -2564,6 +3540,10 @@ module blocks ! !------------------------------------------------------------------------------- ! +! return, if it is a leaf already +! + if (pmeta%leaf) return + ! set the block's leaf flag ! pmeta%leaf = .true. @@ -2601,6 +3581,10 @@ module blocks ! !------------------------------------------------------------------------------- ! +! return, if is not a leaf +! + if (.not. pmeta%leaf) return + ! unset the block's leaf flag ! pmeta%leaf = .false. @@ -2878,6 +3862,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 @@ -2973,6 +3961,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 @@ -3186,437 +4178,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 ! !=============================================================================== @@ -3650,11 +4295,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" ! !------------------------------------------------------------------------------- ! @@ -3662,114 +4315,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 */ !------------------------------------------------------------------------------- ! diff --git a/src/boundaries.F90 b/src/boundaries.F90 index 0a3f837..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,51 +298,67 @@ module boundaries call start_timer(imv) #endif /* PROFILE */ -! step down from the top level +! update specific boundaries ! - do ilev = toplev, 1, -1 + call boundaries_specific() -! iterate over all directions +#if NDIMS == 3 +! update face boundaries between blocks at the same levels ! - do idir = 1, ndims + do idir = 1, ndims + call boundaries_face_copy(idir) + end do ! idir +#endif /* NDIMS == 3 */ -! update boundaries which don't have neighbors and which are not periodic +! update edge boundaries between blocks at the same levels ! - if (.not. periodic(idir)) call specific_boundaries(ilev, idir) + do idir = 1, ndims + call boundaries_edge_copy(idir) + end do ! idir -! copy boundaries between blocks at the same levels +! update corner boundaries between blocks at the same levels ! - call copy_boundaries(ilev, idir) + call boundaries_corner_copy() - end do ! directions - -! restrict blocks from higher level neighbors +#if NDIMS == 3 +! restrict face boundaries from higher level blocks ! - do idir = 1, ndims + do idir = 1, ndims + call boundaries_face_restrict(idir) + end do ! idir +#endif /* NDIMS == 3 */ - call restrict_boundaries(ilev - 1, idir) - - end do ! directions - - end do ! levels - -! step up from the first level +! restricts edge boundaries from block at higher level ! - do ilev = 1, toplev + do idir = 1, ndims + call boundaries_edge_restrict(idir) + end do ! idir -! prolong boundaries from lower level neighbors +! restricts corner boundaries from blocks at higher levels ! - do idir = 1, ndims + call boundaries_corner_restrict() - call prolong_boundaries(ilev, idir) - - end do ! boundaries - - end do ! levels - -! finally, update the corners +#if NDIMS == 3 +! prolong face boundaries from lower level blocks ! - call update_corners() + 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 + call boundaries_edge_prolong(idir) + end do ! idir + +! prolong corner boundaries from blocks at lower levels +! + call boundaries_corner_prolong() + +! update specific boundaries +! + call boundaries_specific() ! convert updated primitive variables to conservative ones in all ghost cells ! @@ -365,7 +379,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. ! ! !=============================================================================== @@ -378,12 +395,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 @@ -403,8 +420,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 */ @@ -412,21 +432,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 @@ -439,22 +472,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 @@ -462,144 +493,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 @@ -610,143 +719,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 ! @@ -768,155 +850,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 */ @@ -939,109 +1035,6931 @@ module boundaries ! !=============================================================================== ! -! subroutine UPDATE_CORNERS: -! ------------------------- +! DOMAIN SPECIFIC BOUNDARY SUBROUTINES ! -! 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. +!=============================================================================== +! +!=============================================================================== +! +! subroutine BOUNDARIES_SPECIFIC: +! ------------------------------ +! +! Subroutine scans over all leaf blocks in order to find blocks without +! neighbors, then updates its boundaries for selected type. ! ! !=============================================================================== ! - subroutine update_corners() + subroutine boundaries_specific() -! include external variables +! import external procedures and 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 + 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 */ + use mpitools , only : periodic ! local variables are not implicit by default ! implicit none +! local pointers +! + type(block_meta), pointer :: pmeta, pneigh + ! local variables ! - integer :: i, j, k, p + 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 directions +! + 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 +! + 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 ! 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 directions +! + 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 +! + 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 ! 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 + 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 +! +!=============================================================================== +! +! 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_data), pointer :: pdata + 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 */ ! !------------------------------------------------------------------------------- ! -! assign the pointer to the first block on the list +#ifdef PROFILE +! start accounting time for copy boundary update ! - pdata => list_data + call start_timer(imc) +#endif /* PROFILE */ -! scan all data blocks until the last is reached +! calculate half sizes ! - do while(associated(pdata)) + ih = in / 2 + jh = jn / 2 + kh = kn / 2 -! iterate over all variables +#ifdef MPI +!! 1. PREPARE THE BLOCK EXCHANGE ARRAYS FOR MPI +!! +! reset the exchange block counters ! - do p = 1, nv + block_counter(:,:) = 0 -! edges +! nullify the info pointers ! -#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 */ - + 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 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 (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 +! +!=============================================================================== +! +! 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 them 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 +! +!=============================================================================== +! +! 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 lower 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 */ +! +!=============================================================================== +! +! DOMAIN EDGE BOUNDARY UPDATE SUBROUTINES +! +!=============================================================================== +! +!=============================================================================== +! +! subroutine BOUNDARIES_EDGE_COPY: +! ------------------------------- +! +! 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: +! +! 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 EDGE 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 +! +#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,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 + +! 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 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_EDGE_RESTRICT: +! ----------------------------------- +! +! 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: +! +! 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 +!! +! 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 +! +#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 + +! 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 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_EDGE_PROLONG: +! ---------------------------------- +! +! 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: +! +! 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 +!! +! 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 +! +#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 + +! 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 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) + 23 + +! 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 +! +!=============================================================================== +! +! DOMAIN CORNER 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 +!! +! 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 +! +#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) + 31 + +! 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 +! +!=============================================================================== +! +! subroutine BOUNDARIES_CORNER_RESTRICT: +! ------------------------------------- +! +! 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. +! +! +!=============================================================================== +! + 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 +!! +! 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 +! +#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 ! - pdata => pdata%next + pmeta => pmeta%next - end do ! data blocks + 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) + 32 + +! 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 update_corners + end subroutine boundaries_corner_restrict +! +!=============================================================================== +! +! 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 +!! +! 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 +! +#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 + +#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 ! 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) + 33 + +! 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 SPECIFIC BOUNDARY SUBROUTINES +! +!=============================================================================== +! +!=============================================================================== +! +! 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 +#if NDIMS == 3 +! +!=============================================================================== +! +! BLOCK FACE UPDATE SUBROUTINES +! +!=============================================================================== +! +!=============================================================================== +! +! subroutine BLOCK_FACE_COPY: +! -------------------------- +! +! Subroutine returns the face boundary region copied 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 +! +!=============================================================================== +! +! 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 +! +!=============================================================================== +! +! 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 + +! 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 + 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 */ +! +!=============================================================================== +! +! 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 edge 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 :: ih, jh, kh + integer :: il, jl, kl + integer :: iu, ju, ku +! +!------------------------------------------------------------------------------- +! +! process depending on the direction +! + select case(nc) + case(1) + +! calculate half size +! + ih = in / 2 + +! prepare indices for the edge 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 NDIMS == 3 + if (kc == 1) then + kl = kel + ku = ke + else + kl = kb + ku = kbu + end if +#endif /* NDIMS == 3 */ + +! 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) +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + 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 indices for the edge 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 NDIMS == 3 + if (kc == 1) then + kl = kb + ku = kbu + else + kl = kel + ku = ke + end if +#endif /* NDIMS == 3 */ + +! 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) +#endif /* NDIMS == 2 */ +#if NDIMS == 3 + 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 edge 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 (kc == 1) then + kl = kb + ku = kb + kh - 1 + else + kl = ke - kh + 1 + ku = ke + end if + +! 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 */ + + end select + +!------------------------------------------------------------------------------- +! + end subroutine block_edge_copy +! +!=============================================================================== +! +! 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 +! +!------------------------------------------------------------------------------- +! +! process depending on the direction +! + select case(nc) + case(1) + +! calculate half size +! + ih = in / 2 + +! prepare indices for the edge 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 +#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 */ + +! restrict the edge region to 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 indices for the edge 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 +#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 */ + +! restrict the edge region to 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 indices for the edge 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 + 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 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) & + + 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 +! +!=============================================================================== +! +! 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 +! +!------------------------------------------------------------------------------- +! +! process depending on the direction +! + select case(nc) + case(1) + +! calculate half size +! + ih = in / 2 + +! prepare indices for the edge 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 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 indices for the edge 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 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 indices for the edge region +! + 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 + +! iterate over all edge region cells +! +#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 + +! 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) + +#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 +! 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 + 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 +! +!=============================================================================== +! +!=============================================================================== +! +! 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 indices for the corner region +! + 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 */ + +! 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) +#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 +! +!=============================================================================== +! +! 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 indices for the corner 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 + 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 */ + +! restrict the corner region to 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 +! +!=============================================================================== +! +! 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 indices for the corner region +! + 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 */ + +! iterate over all corner region cells +! +#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 + +! 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) + +#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 +! 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 + 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 +! +!=============================================================================== +! +!=============================================================================== +! +! subroutine BLOCK_UPDATE_FLUX: +! ---------------------------- +! +! Subroutine updates the boundary flux from the provided flux array. +! +! Arguments: +! +! nc - the edge direction; +! ic, jc, kc - the corner position; +! fn - the correcting flux array; +! fb - the corrected flux array; +! +!=============================================================================== +! + subroutine block_update_flux(nc, ic, jc, kc, fn, fb) + +! import external procedures and variables +! + use blocks , only : block_data + use coordinates , only : in, jn, kn + use equations , only : nv + +! 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(:,:,:), intent(in) :: fn + real(kind=8), dimension(:,:,:), intent(inout) :: fb +! +!------------------------------------------------------------------------------- +! +! update fluxes for each direction separately +! + select case(nc) + +! X direction +! + case(1) + +#if NDIMS == 2 +! 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 +! 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 */ + +! Y direction +! + case(2) + +#if NDIMS == 2 +! 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 +! 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 */ + +#if NDIMS == 3 +! Z direction +! + case(3) + +! average fluxes from higher level neighbor +! + 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 block_update_flux +! +!=============================================================================== +! +! OTHER BOUNDARY SUBROUTINES +! +!=============================================================================== ! !=============================================================================== ! @@ -1146,2588 +8064,6 @@ module boundaries !------------------------------------------------------------------------------- ! 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 -! -!=============================================================================== -! -! subroutine 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 boundary_specific(pdata, idir, iside) - -! 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 - 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 -! - type(block_data), pointer, intent(inout) :: pdata - integer , intent(in) :: idir, iside - -! local variables -! - integer :: ii, i, j, k, it, jt, kt, is, js, ks -! -!------------------------------------------------------------------------------- -! -! prepare a direction/side index -! - ii = 10 * idir + iside - -! perform update depending on the direction/side flag -! - select case(ii) - -! left side along the X direction -! - case(11) - -! apply selected boundary condition -! - select case(bnd_type(idir,iside)) - -! "open" boundary conditions -! - case(bnd_open) - - do i = 1, ng - pdata%q( :,i,:,:) = pdata%q(:,ib,:,:) - end do - -! "reflective" boundary conditions -! - case(bnd_reflective) - - do i = 1, ng - - it = ib - i - is = ibl + i - - pdata%q( :,it,:,:) = pdata%q( :,is,:,:) - pdata%q(ivx,it,:,:) = - pdata%q(ivx,is,:,:) - - end do - -! wrong boundary conditions -! - case default - - call print_error("boundaries:boundary_specific()" & - , "Wrong left X boundary type!") - - end select - -! right side along the X direction -! - case(12) - -! apply selected boundary condition -! - select case(bnd_type(idir,iside)) - -! "open" boundary conditions -! - case(bnd_open) - - do i = ieu, im - pdata%q( :,i ,:,:) = pdata%q( :,ie,:,:) - end do - -! "reflective" boundary conditions -! - case(bnd_reflective) - - 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 - -! 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()" & - , "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!") - - end select - -#if NDIMS == 3 -! left side along the Z direction -! - case(31) - -! apply selected boundary condition -! - select case(bnd_type(idir,iside)) - -! "open" boundary conditions -! - case(bnd_open) - - do k = 1, ng - pdata%q( :,:,:,k ) = pdata%q( :,:,:,kb) - end do - -! "reflective" boundary conditions -! - case(bnd_reflective) - - 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 - -! wrong boundary conditions -! - case default - - call print_error("boundaries:boundary_specific()" & - , "Wrong left Z boundary type!") - - 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 -! -!=============================================================================== -! -! subroutine CORRECT_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; -! -!=============================================================================== -! - subroutine correct_flux(pdata, f, idir, iside, iface) - -! 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 - -! local variables are not implicit by default -! - implicit none - -! 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 */ -! -!------------------------------------------------------------------------------- -! -! update fluxes for each direction separately -! - select case(idir) - -! 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,:)) -#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 -#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,:)) -#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 -#endif /* NDIMS == 3 */ - end do - -#if NDIMS == 3 -! Z direction -! - case(3) - -! index of the slice which will be updated -! - 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 -#endif /* NDIMS == 3 */ - - end select - -!------------------------------------------------------------------------------- -! - end subroutine correct_flux !=============================================================================== ! 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) diff --git a/src/domains.F90 b/src/domains.F90 index 8c3eda3..733ccb3 100644 --- a/src/domains.F90 +++ b/src/domains.F90 @@ -142,9 +142,9 @@ 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, 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 @@ -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 ! @@ -257,9 +259,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 ! @@ -321,144 +323,208 @@ module domains !! ASSIGN THE BLOCK NEIGHBORS !! -! assign boundaries along the X direction +! 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 - 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 +! assign pmeta with the current block ! - 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 + pmeta => block_array(i,j,k)%ptr #if NDIMS == 3 -! assign boundaries along the Z direction +! assign face neighbor pointers ! - do k = 1, kr - 1 - do j = 1, jr - do i = 1, ir + 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 -! assign a pointer + 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 ! - pmeta => block_array(i,j,k )%ptr +#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 -! assign neighbor + 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 ! - pnext => block_array(i,j,k+1)%ptr +#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 -! assign their neighbor pointers +! deallocate indices ! - 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 + deallocate(im, ip) + deallocate(jm, jp) +#if NDIMS == 3 + deallocate(km, kp) #endif /* NDIMS == 3 */ ! deallocate the block pointer array 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) 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 */ !=============================================================================== ! diff --git a/src/integrals.F90 b/src/integrals.F90 index 50752a6..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 @@ -93,7 +95,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 +110,6 @@ module integrals ! local variables ! character(len=32) :: fname - logical :: lex, lop ! !------------------------------------------------------------------------------- ! @@ -136,35 +136,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 @@ -174,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 @@ -214,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 @@ -244,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 @@ -272,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) ! !------------------------------------------------------------------------------- ! @@ -288,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 ! @@ -305,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 @@ -340,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 diff --git a/src/io.F90 b/src/io.F90 index d9948c3..c52902d 100644 --- a/src/io.F90 +++ b/src/io.F90 @@ -41,6 +41,53 @@ module io ! implicit none +! 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 + 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 + 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 + #ifdef PROFILE ! timer indices ! @@ -1102,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 ! @@ -1149,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 ! @@ -1246,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 ! @@ -1324,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 ! @@ -1370,617 +1417,51 @@ module io end subroutine read_attributes_h5 ! !=============================================================================== -!! -!!--- ATTRIBUTE SUBROUTINES -------------------------------------------------- -!! -!=============================================================================== ! -!=============================================================================== +! subroutine WRITE_METABLOCKS_H5: +! ------------------------------ ! -! 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. +! Subroutine stores all meta blocks with their complete fields in 'metablock' +! group in a provided file identifier. ! ! 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 -! -!=============================================================================== -! -! write_metablocks_h5: subroutine writes metablocks in the HDF5 format connected -! to the provided identifier -! -! info: this subroutine stores only the metablocks -! -! arguments: -! fid - the HDF5 file identifier +! 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 + 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 ! @@ -1989,21 +1470,33 @@ 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 +#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 ! @@ -2013,16 +1506,22 @@ 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 +#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))) @@ -2042,23 +1541,51 @@ 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))) +#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 +#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 @@ -2085,75 +1612,111 @@ module io if (associated(pmeta%child(p)%ptr)) chl(l,p) = pmeta%child(p)%ptr%id end do - do i = 1, NDIMS +! store face, edge and corner neighbor pointers +! +#if NDIMS == 2 + do i = 1, nsides 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 + 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 */ - l = l + 1 +! associate pmeta with the next block on the list +! pmeta => pmeta%next - end do -! 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) + 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(:,:)) +#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 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 @@ -2161,7 +1724,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 @@ -2171,49 +1734,57 @@ 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 + 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 ! @@ -2222,11 +1793,23 @@ 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 +#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" ! !------------------------------------------------------------------------------- ! @@ -2240,7 +1823,7 @@ module io ! check if the group has been opened successfuly ! - if (err .ge. 0) then + if (err >= 0) then ! prepate dimensions ! @@ -2249,12 +1832,18 @@ 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 +#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))) @@ -2273,35 +1862,59 @@ 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))) +#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 +#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 ! - 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(:,:)) +#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 ! @@ -2312,12 +1925,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)) @@ -2328,61 +1953,104 @@ 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 %faces, %edges and %corners neighbor pointers +! +#if NDIMS == 2 + do i = 1, nsides 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 + 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 */ - l = l + 1 +! 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 NDIMS == 3 + if (allocated(faces)) deallocate(faces) +#endif /* NDIMS == 3 */ + if (allocated(edges)) deallocate(edges) + if (allocated(corners)) deallocate(corners) ! close the group ! @@ -2390,12 +2058,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 @@ -2403,7 +2070,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 @@ -2559,9 +2226,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 ! @@ -2660,7 +2327,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" & @@ -2697,9 +2364,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 ! @@ -2862,13 +2529,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 +2706,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 +2878,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,455 +2918,3328 @@ 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 +! WRITE_ATTRIBUTE SUBROUTINES ! !=============================================================================== ! - subroutine write_vector_integer_h5(gid, name, length, data) - -! references to other modules +! subroutine WRITE_SCALAR_ATTRIBUTE_INTEGER_H5: +! -------------------------------------------- ! - 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 +! 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) -! declare variables +! 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 -! input variables +! subroutine arguments ! - integer(hid_t) , intent(in) :: gid - character(len=*) , intent(in) :: name - integer(hsize_t) , intent(in) :: length - integer(kind=4) , dimension(:), intent(in) :: data + integer(hid_t) , intent(in) :: gid + character(len=*), intent(in) :: aname + integer(kind=4) , intent(in) :: avalue ! local variables ! - integer(hid_t) :: sid, did - integer(hsize_t), dimension(1) :: am - integer :: err + 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" ! !------------------------------------------------------------------------------- ! -! prepare the vector dimensions +! create space for the attribute value ! - am(1) = length + 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 space for the vector +! create the attribute in the given group ! - call h5screate_simple_f(1, am, sid, err) + call h5acreate_f(gid, aname, H5T_NATIVE_INTEGER, sid, aid, ierr) + if (ierr == 0) then -! check if the space has been created successfuly +! write the attribute data ! - 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)) - + 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, 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)) - + 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_integer_h5 + end subroutine write_scalar_attribute_integer_h5 ! !=============================================================================== ! -! read_vector_integer_h5: subroutine reads a 1D integer vector +! subroutine WRITE_SCALAR_ATTRIBUTE_DOUBLE_H5: +! ------------------------------------------- ! -! arguments: -! gid - the HDF5 group identifier -! name - the string name representing the dataset -! length - the vector length -! value - the data +! 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 read_vector_integer_h5(gid, name, dm, data) + subroutine write_scalar_attribute_double_h5(gid, aname, avalue) -! references to other modules +! 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 : h5dopen_f, h5dread_f, h5dclose_f + 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 -! declare variables +! local variables are not implicit by default ! implicit none -! input variables +! attribute 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) :: data + integer(hid_t) , intent(in) :: gid + character(len=*), intent(in) :: aname + real(kind=8) , intent(in) :: avalue ! local variables ! - integer(hid_t) :: did - integer :: err + 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" ! !------------------------------------------------------------------------------- ! -! open the dataset +! create space for the attribute value ! - call h5dopen_f(gid, name, did, err) + 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 -! check if the dataset has been opened successfuly +! create the attribute in the given group ! - if (err .ge. 0) then + call h5acreate_f(gid, aname, H5T_NATIVE_DOUBLE, sid, aid, ierr) + if (ierr == 0) then -! read the dataset data +! write the attribute data ! - call h5dread_f(did, H5T_NATIVE_INTEGER, data(:), dm(:), err) + 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 -! check if the dataset has been read successfuly +! close the attribute ! - if (err .gt. 0) then + call h5aclose_f(aid, ierr) + if (ierr /= 0) then + call print_error(fname, "Cannot close attribute :" // trim(aname)) + end if -! print error about the problem with reading the dataset + else + call print_error(fname, "Cannot create attribute :" // trim(aname)) + end if + +! release the space ! - call print_error("io::read_vector_integer_h5" & - , "Cannot read dataset: " // trim(name)) + 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 +! +!=============================================================================== +! +! 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 +#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 + 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 + +! 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" +! +!------------------------------------------------------------------------------- +! +! 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_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: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, err) + call h5dclose_f(did, iret) ! 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 dataset ! - call print_error("io::read_vector_integer_h5" & - , "Cannot close dataset: " // trim(name)) + call print_error(fname, "Cannot close dataset: " // trim(name)) end if else -! print error about the problem with opening the dataset +! print error about the problem with creating the dataset ! - call print_error("io::read_vector_integer_h5" & - , "Cannot open 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 read_vector_integer_h5 + end subroutine write_1d_array_integer_h5 ! !=============================================================================== ! -! write_array2_integer_h5: subroutine stores a 2D integer array in a group +! subroutine WRITE_2D_ARRAY_INTEGER_H5: +! ------------------------------------ ! -! arguments: -! gid - the HDF5 group identifier -! name - the string name representing the dataset -! dm - the data dimensions -! value - the data +! 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_array2_integer_h5(gid, name, dm, var) + subroutine write_2d_array_integer_h5(gid, name, dm, var) -! references to other modules +! 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 & - , h5dcreate_f, h5dwrite_f, h5dclose_f + 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(2) , intent(in) :: dm 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 + +! procedure return value +! + integer :: iret + +! subroutine name string +! + character(len=*), parameter :: fname = "io::write_2d_array_integer_h5" ! !------------------------------------------------------------------------------- ! -! create space for the vector +! create a space for the array ! - call h5screate_simple_f(2, dm, sid, err) + call h5screate_simple_f(2, dm(1:2), sid, iret) -! check if the space has been created successfuly +! check if the space has been created successfuly, if not quit ! - if (err .ge. 0) then + 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, 2, dm, err) + call h5pset_chunk_f(pid, 2, dm(1:2), 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_array4_integer_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 (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 (err .gt. 0) then + if (iret > 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!") + 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_INTEGER, 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_INTEGER, 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_INTEGER, var(:,:), dm, err, sid) + call h5dwrite_f(did, H5T_NATIVE_INTEGER, var(:,:), dm(1:2), 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_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)) + call print_error(fname, "Cannot write dataset: " // trim(name)) end if -! release 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_array2_integer_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_array2_integer_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_array2_integer_h5 + end subroutine write_2d_array_integer_h5 ! !=============================================================================== ! -! read_array2_integer_h5: subroutine reads a 2D integer array +! subroutine WRITE_3D_ARRAY_INTEGER_H5: +! ------------------------------------ ! -! arguments: -! gid - the HDF5 group identifier -! name - the string name representing the dataset -! dm - the data dimensions -! value - the data +! 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 read_array2_integer_h5(gid, name, dm, var) + subroutine write_3d_array_integer_h5(gid, name, dm, var) -! references to other modules +! 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 : h5dopen_f, h5dread_f, h5dclose_f + 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 */ -! 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(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 + +!=============================================================================== +! +! 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 @@ -3709,296 +6249,193 @@ module io ! local variables ! integer(hid_t) :: did - integer :: err + integer :: iret + +! subroutine name string +! + character(len=*), parameter :: fname = "io::read_2d_array_integer_h5" ! !------------------------------------------------------------------------------- ! ! open the dataset ! - call h5dopen_f(gid, name, did, err) + call h5dopen_f(gid, name, did, iret) ! check if the dataset has been opened successfuly ! - if (err .ge. 0) then + 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(:), err) + call h5dread_f(did, H5T_NATIVE_INTEGER, var(:,:), dm(1:2), iret) ! check if the dataset has been read successfuly ! - if (err .gt. 0) then + if (iret > 0) then ! print error about the problem with reading the dataset ! - call print_error("io::read_array2_integer_h5" & - , "Cannot read dataset: " // trim(name)) + call print_error(fname, "Cannot read dataset: " // trim(name)) - end if + end if ! close the dataset ! - call h5dclose_f(did, err) + call h5dclose_f(did, iret) ! 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 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)) + call print_error(fname, "Cannot close dataset: " // trim(name)) end if !------------------------------------------------------------------------------- ! - end subroutine read_array2_integer_h5 + end subroutine read_2d_array_integer_h5 ! !=============================================================================== ! -! write_array4_integer_h5: subroutine stores a 4D integer array in a group +! subroutine READ_3D_ARRAY_INTEGER_H5: +! ----------------------------------- ! -! arguments: -! gid - the HDF5 group identifier -! name - the string name representing the dataset -! dm - the data dimensions -! value - the data +! 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 write_array4_integer_h5(gid, name, dm, var) + subroutine read_3d_array_integer_h5(gid, name, dm, var) -! references to other modules +! 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 & - , 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 */ + 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 -! 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(4) , intent(in) :: dm - integer(kind=4) , dimension(:,:,:,:), intent(in) :: var + 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) :: sid, pid, did - integer :: err -#ifdef COMPRESS - logical :: compress = .false. -#endif /* COMPRESS */ + integer(hid_t) :: did + integer :: iret + +! subroutine name string +! + character(len=*), parameter :: fname = "io::read_3d_array_integer_h5" ! !------------------------------------------------------------------------------- ! -! create space for the vector +! open the dataset ! - call h5screate_simple_f(4, dm, sid, err) + call h5dopen_f(gid, name, did, iret) -! check if the space has been created successfuly +! check if the dataset has been opened successfuly ! - if (err .ge. 0) then + if (iret < 0) then -#ifdef COMPRESS -! prepare compression +! print error about the problem with opening the data space ! - call h5pcreate_f(H5P_DATASET_CREATE_F, pid, err) + call print_error(fname, "Cannot open dataset: " // trim(name)) -! check if the properties have been created properly +! quit the subroutine ! - if (err .ge. 0) then + return -! so far ok, so turn on the compression + end if + +! read dataset data ! - compress = .true. + call h5dread_f(did, H5T_NATIVE_INTEGER, var(:,:,:), dm(1:3), iret) -! set the chunk size +! check if the dataset has been read successfuly ! - call h5pset_chunk_f(pid, 4, dm, err) + if (iret > 0) then -! check if the chunk size has been set properly +! print error about the problem with reading the dataset ! - if (err .gt. 0) then + call print_error(fname, "Cannot read dataset: " // trim(name)) -! 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 + end if ! close the dataset ! - call h5dclose_f(did, err) + call h5dclose_f(did, iret) ! 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 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)) + call print_error(fname, "Cannot close dataset: " // trim(name)) end if !------------------------------------------------------------------------------- ! - end subroutine write_array4_integer_h5 + end subroutine read_3d_array_integer_h5 ! !=============================================================================== ! -! read_array4_integer_h5: subroutine reads a 4D integer array +! subroutine READ_4D_ARRAY_INTEGER_H5: +! ----------------------------------- ! -! arguments: -! gid - the HDF5 group identifier -! name - the string name representing the dataset -! dm - the data dimensions -! value - the data +! 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_array4_integer_h5(gid, name, dm, var) + subroutine read_4d_array_integer_h5(gid, name, dm, var) -! references to other modules +! 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 : h5dopen_f, h5dread_f, h5dclose_f + 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 -! 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 @@ -4008,1084 +6445,585 @@ module io ! local variables ! integer(hid_t) :: did - integer :: err + integer :: iret + +! subroutine name string +! + character(len=*), parameter :: fname = "io::read_4d_array_integer_h5" ! !------------------------------------------------------------------------------- ! ! open the dataset ! - call h5dopen_f(gid, name, did, err) + call h5dopen_f(gid, name, did, iret) ! check if the dataset has been opened successfuly ! - if (err .ge. 0) then + 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(:), err) + call h5dread_f(did, H5T_NATIVE_INTEGER, var(:,:,:,:), dm(1:4), iret) ! check if the dataset has been read successfuly ! - if (err .gt. 0) then + if (iret > 0) then ! print error about the problem with reading the dataset ! - call print_error("io::read_array4_integer_h5" & - , "Cannot read dataset: " // trim(name)) + call print_error(fname, "Cannot read dataset: " // trim(name)) - end if + end if ! close the dataset ! - call h5dclose_f(did, err) + call h5dclose_f(did, iret) ! 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 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)) + call print_error(fname, "Cannot close dataset: " // trim(name)) end if !------------------------------------------------------------------------------- ! - end subroutine read_array4_integer_h5 + end subroutine read_4d_array_integer_h5 ! !=============================================================================== ! -! write_vector_double_h5: subroutine stores a 1D double precision vector in -! a group +! subroutine READ_5D_ARRAY_INTEGER_H5: +! ----------------------------------- ! -! arguments: -! gid - the HDF5 group identifier +! 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 write_vector_double_h5(gid, name, length, data) + subroutine read_5d_array_integer_h5(gid, name, dm, var) -! references to other modules +! import procedures and variables from 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 + 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 -! 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) , intent(in) :: length - real(kind=8) , dimension(:), intent(in) :: data + 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) :: sid, did - integer(hsize_t), dimension(1) :: am - integer :: err + integer(hid_t) :: did + integer :: iret + +! subroutine name string +! + character(len=*), parameter :: fname = "io::read_5d_array_integer_h5" ! !------------------------------------------------------------------------------- ! -! prepare the vector dimensions +! open the dataset ! - am(1) = length + call h5dopen_f(gid, name, did, iret) -! create space for the vector +! check if the dataset has been opened successfuly ! - call h5screate_simple_f(1, am, sid, err) + if (iret < 0) then -! check if the space has been created successfuly +! print error about the problem with opening the data space ! - if (err .ge. 0) then + call print_error(fname, "Cannot open dataset: " // trim(name)) -! create the dataset +! quit the subroutine ! - call h5dcreate_f(gid, name, H5T_NATIVE_DOUBLE, sid, did, err) + return -! check if the dataset has been created successfuly + end if + +! read dataset data ! - if (err .ge. 0) then + call h5dread_f(did, H5T_NATIVE_INTEGER, var(:,:,:,:,:), dm(1:5), iret) -! write the dataset data +! check if the dataset has been read successfuly ! - call h5dwrite_f(did, H5T_NATIVE_DOUBLE, data(:), am, err, sid) + if (iret > 0) then -! check if the dataset has been written successfuly +! print error about the problem with reading the dataset ! - if (err .gt. 0) then + call print_error(fname, "Cannot read dataset: " // trim(name)) -! 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 + end if ! close the dataset ! - call h5dclose_f(did, err) + call h5dclose_f(did, iret) ! 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 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)) + call print_error(fname, "Cannot close dataset: " // trim(name)) end if !------------------------------------------------------------------------------- ! - end subroutine write_vector_double_h5 + end subroutine read_5d_array_integer_h5 ! !=============================================================================== ! -! read_vector_double_h5: subroutine reads a 1D double precision vector +! subroutine READ_1D_ARRAY_DOUBLE_H5: +! ---------------------------------- ! -! arguments: -! gid - the HDF5 group identifier -! name - the string name representing the dataset -! dm - the vector dimensions -! value - the data +! 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_vector_double_h5(gid, name, dm, data) + subroutine read_1d_array_double_h5(gid, name, dm, var) -! references to other modules +! import procedures and variables from 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 + 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 -! 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(1), intent(inout) :: dm - real(kind=8) , dimension(:), intent(inout) :: data + real(kind=8) , dimension(:), intent(inout) :: var ! local variables ! - integer(hid_t) :: did - integer :: err + 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, err) + call h5dopen_f(gid, name, did, iret) ! check if the dataset has been opened successfuly ! - if (err .ge. 0) then + if (iret < 0) then -! read the dataset data +! print error about the problem with opening the data space ! - call h5dread_f(did, H5T_NATIVE_DOUBLE, data(:), dm(:), err) + 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 (err .gt. 0) then + if (iret > 0) then ! print error about the problem with reading the dataset ! - call print_error("io::read_vector_double_h5" & - , "Cannot read dataset: " // trim(name)) + call print_error(fname, "Cannot read dataset: " // trim(name)) - end if + end if ! close the dataset ! - call h5dclose_f(did, err) + call h5dclose_f(did, iret) ! 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 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)) + call print_error(fname, "Cannot close dataset: " // trim(name)) end if !------------------------------------------------------------------------------- ! - end subroutine read_vector_double_h5 + end subroutine read_1d_array_double_h5 ! !=============================================================================== ! -! write_array4_float_h5: subroutine stores a 4D single precision array +! subroutine READ_2D_ARRAY_DOUBLE_H5: +! ----------------------------------- ! -! 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 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 write_array4_float_h5(gid, name, dm, var) + subroutine read_2d_array_double_h5(gid, name, dm, var) -! references to other modules +! import procedures and variables from 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 */ + 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 -! define default 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(4) , intent(in) :: dm - real(kind=4) , dimension(:,:,:,:), intent(in) :: var + 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) :: sid, pid, did - integer :: err + integer(hid_t) :: did + integer :: iret + +! subroutine name string +! + character(len=*), parameter :: fname = "io::read_2d_array_double_h5" ! !------------------------------------------------------------------------------- ! -! create a space for the dataset dimensions +! open the dataset ! - call h5screate_simple_f(4, dm(:), sid, err) + call h5dopen_f(gid, name, did, iret) -! print an error, if the space for dimensions couldn't be created +! check if the dataset has been opened successfuly ! - if (err .eq. -1) call print_error("io::write_array4_float_h5" & - , "Cannot create a space for the dataset: " // trim(name)) + if (iret < 0) then -! prepare the compression properties +! print error about the problem with opening the data space ! - call h5pcreate_f(H5P_DATASET_CREATE_F, pid, err) + call print_error(fname, "Cannot open dataset: " // trim(name)) -! if the compression properties could be created properly, set the compression -! algorithm and strength +! quit the subroutine ! - 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!") + return end if -! create the dataset +! read dataset data ! - call h5dcreate_f(gid, name, H5T_NATIVE_REAL, sid, did, err, pid) + call h5dread_f(did, H5T_NATIVE_DOUBLE, var(:,:), dm(1:2), iret) -! print an error, if the dataset couldn't be created +! check if the dataset has been read successfuly ! - if (err .eq. -1) call print_error("io::write_array4_float_h5" & - , "Cannot create the dataset: " // trim(name)) + if (iret > 0) then -! write the dataset values +! print error about the problem with reading the dataset ! - 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!") + call print_error(fname, "Cannot read dataset: " // trim(name)) 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) + call h5dclose_f(did, iret) ! 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 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)) + call print_error(fname, "Cannot close dataset: " // trim(name)) end if !------------------------------------------------------------------------------- ! - end subroutine write_array3_double_h5 + end subroutine read_2d_array_double_h5 ! !=============================================================================== ! -! write_array4_double_h5: subroutine stores a 4D double precision array +! subroutine READ_3D_ARRAY_DOUBLE_H5: +! ----------------------------------- ! -! arguments: -! gid - the HDF5 group identifier -! name - the string name representing the dataset -! dm - the data dimensions -! value - the data +! 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 write_array4_double_h5(gid, name, dm, var) + subroutine read_3d_array_double_h5(gid, name, dm, var) -! references to other modules +! import procedures and variables from 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 */ + 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 -! 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(4) , intent(in) :: dm - real(kind=8) , dimension(:,:,:,:), intent(in) :: var + 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) :: sid, pid, did - integer :: err -#ifdef COMPRESS - logical :: compress = .false. -#endif /* COMPRESS */ + integer(hid_t) :: did + integer :: iret + +! subroutine name string +! + character(len=*), parameter :: fname = "io::read_3d_array_double_h5" ! !------------------------------------------------------------------------------- ! -! create space for the vector +! open the dataset ! - call h5screate_simple_f(4, dm, sid, err) + call h5dopen_f(gid, name, did, iret) -! check if the space has been created successfuly +! check if the dataset has been opened successfuly ! - if (err .ge. 0) then + if (iret < 0) then -#ifdef COMPRESS -! prepare compression +! print error about the problem with opening the data space ! - call h5pcreate_f(H5P_DATASET_CREATE_F, pid, err) + call print_error(fname, "Cannot open dataset: " // trim(name)) -! check if the properties have been created properly +! quit the subroutine ! - if (err .ge. 0) then + return -! so far ok, so turn on the compression + end if + +! read dataset data ! - compress = .true. + call h5dread_f(did, H5T_NATIVE_DOUBLE, var(:,:,:), dm(1:3), iret) -! set the chunk size +! check if the dataset has been read successfuly ! - call h5pset_chunk_f(pid, 4, dm, err) + if (iret > 0) then -! check if the chunk size has been set properly +! print error about the problem with reading the dataset ! - if (err .gt. 0) then + call print_error(fname, "Cannot read dataset: " // trim(name)) -! 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 + end if ! close the dataset ! - call h5dclose_f(did, err) + call h5dclose_f(did, iret) ! 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 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)) + call print_error(fname, "Cannot close dataset: " // trim(name)) end if !------------------------------------------------------------------------------- ! - end subroutine write_array4_double_h5 + end subroutine read_3d_array_double_h5 ! !=============================================================================== ! -! write_array5_double_h5: subroutine stores a 5D double precision array +! subroutine READ_4D_ARRAY_DOUBLE_H5: +! ----------------------------------- ! -! arguments: -! gid - the HDF5 group identifier -! name - the string name representing the dataset -! dm - the data dimensions -! value - the data +! 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 write_array5_double_h5(gid, name, dm, var) + subroutine read_4d_array_double_h5(gid, name, dm, var) -! references to other modules +! import procedures and variables from 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 */ + 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 -! 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(5) , intent(in) :: dm - real(kind=8) , dimension(:,:,:,:,:), intent(in) :: var + 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) :: sid, pid, did - integer :: err -#ifdef COMPRESS - logical :: compress = .false. -#endif /* COMPRESS */ + integer(hid_t) :: did + integer :: iret + +! subroutine name string +! + character(len=*), parameter :: fname = "io::read_4d_array_double_h5" ! !------------------------------------------------------------------------------- ! -! create space for the vector +! open the dataset ! - call h5screate_simple_f(5, dm, sid, err) + call h5dopen_f(gid, name, did, iret) -! check if the space has been created successfuly +! check if the dataset has been opened successfuly ! - if (err .ge. 0) then + if (iret < 0) then -#ifdef COMPRESS -! prepare compression +! print error about the problem with opening the data space ! - call h5pcreate_f(H5P_DATASET_CREATE_F, pid, err) + call print_error(fname, "Cannot open dataset: " // trim(name)) -! check if the properties have been created properly +! quit the subroutine ! - if (err .ge. 0) then + return -! so far ok, so turn on the compression + end if + +! read dataset data ! - compress = .true. + call h5dread_f(did, H5T_NATIVE_DOUBLE, var(:,:,:,:), dm(1:4), iret) -! set the chunk size +! check if the dataset has been read successfuly ! - call h5pset_chunk_f(pid, 5, dm, err) + if (iret > 0) then -! check if the chunk size has been set properly +! print error about the problem with reading the dataset ! - if (err .gt. 0) then + call print_error(fname, "Cannot read dataset: " // trim(name)) -! 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 + end if ! close the dataset ! - call h5dclose_f(did, err) + call h5dclose_f(did, iret) ! 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 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)) + call print_error(fname, "Cannot close dataset: " // trim(name)) end if !------------------------------------------------------------------------------- ! - end subroutine write_array5_double_h5 + end subroutine read_4d_array_double_h5 ! !=============================================================================== ! -! read_array5_double_h5: subroutine reads a 5D double precision array +! subroutine READ_5D_ARRAY_DOUBLE_H5: +! ----------------------------------- ! -! arguments: -! gid - the HDF5 group identifier -! name - the string name representing the dataset -! dm - the data dimensions -! value - the data +! 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_array5_double_h5(gid, name, dm, var) + subroutine read_5d_array_double_h5(gid, name, dm, var) -! references to other modules +! import procedures and variables from 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 + 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 -! 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 @@ -5095,270 +7033,63 @@ module io ! local variables ! integer(hid_t) :: did - integer :: err + integer :: iret + +! subroutine name string +! + character(len=*), parameter :: fname = "io::read_5d_array_double_h5" ! !------------------------------------------------------------------------------- ! ! open the dataset ! - call h5dopen_f(gid, name, did, err) + call h5dopen_f(gid, name, did, iret) ! check if the dataset has been opened successfuly ! - if (err .ge. 0) then + if (iret < 0) then -! read dataset +! print error about the problem with opening the data space ! - call h5dread_f(did, H5T_NATIVE_DOUBLE, var(:,:,:,:,:), dm(:), err) + 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 (err .gt. 0) then + if (iret > 0) then ! print error about the problem with reading the dataset ! - call print_error("io::read_array5_double_h5" & - , "Cannot read dataset: " // trim(name)) + call print_error(fname, "Cannot read dataset: " // trim(name)) - end if + end if ! close the dataset ! - call h5dclose_f(did, err) + call h5dclose_f(did, iret) ! 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 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)) + call print_error(fname, "Cannot close dataset: " // trim(name)) end if !------------------------------------------------------------------------------- ! - 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 -#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(6) , 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(6, 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, 6, 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_array6_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_array6_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_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)) - - end if - -! close 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_array6_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_array6_double_h5" & - , "Cannot create space for dataset: " // trim(name)) - - end if - -!------------------------------------------------------------------------------- -! - end subroutine write_array6_double_h5 + end subroutine read_5d_array_double_h5 #endif /* HDF5 */ !=============================================================================== diff --git a/src/mesh.F90 b/src/mesh.F90 index baa8ac2..08fb6ef 100644 --- a/src/mesh.F90 +++ b/src/mesh.F90 @@ -456,9 +456,9 @@ 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, 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 @@ -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. ! ! !=============================================================================== @@ -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 @@ -831,437 +787,25 @@ 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 + call check_data_block_refinement() -! iterate over all blocks in the data block list +! update neighbor refinement flags, if they need to be refined as well ! - do while (associated(pdata)) + call update_neighbor_refinement() -! assign a pointer to the meta block associated with the current data block +! prepare siblings of blocks marked for restriction ! - pmeta => pdata%meta + call prepare_sibling_derefinement() -! continue if the current data block has a meta block associated +! restrict selected blocks ! - if (associated(pmeta)) then + call derefine_selected_blocks() -! if the associated meta block is a leaf +! prolong selected blocks ! - 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 */ - -!! SELECT NEIGHBORS OF REFINED BLOCKS TO BE REFINED IF NECESSARY -!! -! 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 -! - 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 */ - -!! DEREFINE SELECTED BLOCKS -!! -! perform the actual derefinement -! - 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 - -!! REFINE SELECTED BLOCKS -!! -! perform the actual refinement starting from the lowest level -! - 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 @@ -1826,6 +1370,820 @@ 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 +! +!=============================================================================== +! +! 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 +! +!=============================================================================== +! +! 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. +! +! 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. +! +!=============================================================================== +! + 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 + + 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 +! +!=============================================================================== +! +! subroutine DEREFINE_SELECTED_BLOCKS: +! ----------------------------------- +! +! Subroutine scans over all blocks and restrict those selected. +! +! Note: This subroutine resets the flag %refine 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 + +!------------------------------------------------------------------------------- +! +! iterate over levels and restrict the blocks selected for restriction +! + 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 the mesh derefinement +! + call derefine_block(pmeta) + +! reset the refinement flag of the current block +! + pmeta%refine = 0 + + end if ! non-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 +! +!=============================================================================== +! +! subroutine REFINE_SELECTED_BLOCKS: +! --------------------------------- +! +! Subroutine scans over all blocks and prolongates those selected. +! +! +!=============================================================================== +! + 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 !=============================================================================== ! diff --git a/src/problems.F90 b/src/problems.F90 index f75233f..4da9976 100644 --- a/src/problems.F90 +++ b/src/problems.F90 @@ -232,12 +232,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 ! @@ -249,12 +249,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 ! @@ -265,10 +268,19 @@ 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 - real(kind=8) :: xb, yb, xt, yt - real(kind=8) :: dx, dy, dz, dxh, dyh, dzh, daxy +#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 + 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, dvol real(kind=8) :: fc_amb, fc_ovr ! local arrays @@ -277,6 +289,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 */ ! !------------------------------------------------------------------------------- ! @@ -299,6 +318,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 @@ -346,7 +375,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 ! @@ -439,41 +494,122 @@ 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 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 = 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 @@ -483,7 +619,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 @@ -504,6 +639,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 !