From cd0161515cee9120536735766d96ce7a861c3dbe Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 18 Nov 2014 19:08:50 -0200 Subject: [PATCH 01/19] SOURCES: Implement full viscous stress tensor. The viscous source term can be expressed as the laplacian only in the incompressible case (div V = 0) with uniform viscosity. If we have compressibility or non-uniform viscosity, we need to use the full viscous stress tensor. This patch implements it. Signed-off-by: Grzegorz Kowal --- src/sources.F90 | 200 +++++++++++++++++++++++------------------------- 1 file changed, 95 insertions(+), 105 deletions(-) diff --git a/src/sources.F90 b/src/sources.F90 index bcd9b7e..118be30 100644 --- a/src/sources.F90 +++ b/src/sources.F90 @@ -238,7 +238,7 @@ module sources ! use blocks , only : block_data use coordinates , only : im, jm, km - use coordinates , only : ax, ay, az, adx, ady, adz, adxi, adyi, adzi + use coordinates , only : ax, ay, az, adx, ady, adz use equations , only : nv, inx, iny, inz use equations , only : idn, ivx, ivy, ivz, imx, imy, imz, ien use equations , only : ibx, iby, ibz, ibp @@ -256,10 +256,12 @@ module sources ! local variables ! integer :: i , j , k - integer :: im1, jm1, km1 - integer :: ip1, jp1, kp1 - real(kind=8) :: r2, r3, gc, gx, gy, gz - real(kind=8) :: dxi2, dyi2, dzi2, dvx, dvy, dvz, dbx, dby, dbz, dvv + real(kind=8) :: fc, gc + real(kind=8) :: r2, r3, gx, gy, gz + real(kind=8) :: dbx, dby, dbz + real(kind=8) :: dvxdx, dvxdy, dvxdz, divv + real(kind=8) :: dvydx, dvydy, dvydz + real(kind=8) :: dvzdx, dvzdy, dvzdz ! local arrays ! @@ -267,8 +269,9 @@ module sources real(kind=8), dimension(im) :: x real(kind=8), dimension(jm) :: y real(kind=8), dimension(km) :: z - real(kind=8), dimension(im,jm,km) :: db - real(kind=8), dimension(3,im,jm,km) :: jc + real(kind=8), dimension(im,jm,km) :: db + real(kind=8), dimension(3,im,jm,km) :: jc + real(kind=8), dimension(3,3,im,jm,km) :: tmp ! !------------------------------------------------------------------------------- ! @@ -351,120 +354,107 @@ module sources ! prepare coordinate increments ! - dxi2 = viscosity * adxi(pdata%meta%level)**2 - dyi2 = viscosity * adyi(pdata%meta%level)**2 -#if NDIMS == 3 - dzi2 = viscosity * adzi(pdata%meta%level)**2 -#endif /* NDIMS == 3 */ + dh(1) = adx(pdata%meta%level) + dh(2) = ady(pdata%meta%level) + dh(3) = adz(pdata%meta%level) -! iterate over all positions in the YZ plane +! calculate the velocity Jacobian +! + call gradient(dh(:), pdata%q(ivx,1:im,1:jm,1:km) & + , tmp(inx,inx:inz,1:im,1:jm,1:km)) + call gradient(dh(:), pdata%q(ivy,1:im,1:jm,1:km) & + , tmp(iny,inx:inz,1:im,1:jm,1:km)) + call gradient(dh(:), pdata%q(ivz,1:im,1:jm,1:km) & + , tmp(inz,inx:inz,1:im,1:jm,1:km)) + +! iterate over all cells ! do k = 1, km -#if NDIMS == 3 - km1 = max( 1, k - 1) - kp1 = min(km, k + 1) -#endif /* NDIMS == 3 */ do j = 1, jm - jm1 = max( 1, j - 1) - jp1 = min(jm, j + 1) do i = 1, jm - im1 = max( 1, i - 1) - ip1 = min(im, i + 1) -! calculate second order derivatives of Vx +! prepare the νρ factor ! - dvx = (pdata%q(ivx,ip1,j,k) + pdata%q(ivx,im1,j,k)) & - - 2.0d+00 * pdata%q(ivx,i,j,k) - dvy = (pdata%q(ivx,i,jp1,k) + pdata%q(ivx,i,jm1,k)) & - - 2.0d+00 * pdata%q(ivx,i,j,k) -#if NDIMS == 3 - dvz = (pdata%q(ivx,i,j,kp1) + pdata%q(ivx,i,j,km1)) & - - 2.0d+00 * pdata%q(ivx,i,j,k) -#endif /* NDIMS == 3 */ + gc = viscosity * pdata%q(idn,i,j,k) + fc = 2.0d+00 * gc -! calculate the source term for Vx +! get the velocity Jacobian elements ! -#if NDIMS == 2 - dvv = pdata%q(idn,i,j,k) * (dxi2 * dvx + dyi2 * dvy) -#endif /* NDIMS == 2 */ -#if NDIMS == 3 - dvv = pdata%q(idn,i,j,k) * (dxi2 * dvx + dyi2 * dvy + dzi2 * dvz) -#endif /* NDIMS == 3 */ + dvxdx = tmp(inx,inx,i,j,k) + dvxdy = tmp(inx,iny,i,j,k) + dvxdz = tmp(inx,inz,i,j,k) + dvydx = tmp(iny,inx,i,j,k) + dvydy = tmp(iny,iny,i,j,k) + dvydz = tmp(iny,inz,i,j,k) + dvzdx = tmp(inz,inx,i,j,k) + dvzdy = tmp(inz,iny,i,j,k) + dvzdz = tmp(inz,inz,i,j,k) + divv = (dvxdx + dvydy + dvzdz) / 3.0d+00 -! add viscous source terms to X-momentum equation +! calculate elements of the viscous stress tensor ! - du(imx,i,j,k) = du(imx,i,j,k) + dvv - -! add viscous source term to total energy equation -! - if (ien > 0) then - du(ien,i,j,k) = du(ien,i,j,k) + pdata%q(ivx,i,j,k) * dvv - end if - -! calculate second order derivatives of Vy -! - dvx = (pdata%q(ivy,ip1,j,k) + pdata%q(ivy,im1,j,k)) & - - 2.0d+00 * pdata%q(ivy,i,j,k) - dvy = (pdata%q(ivy,i,jp1,k) + pdata%q(ivy,i,jm1,k)) & - - 2.0d+00 * pdata%q(ivy,i,j,k) -#if NDIMS == 3 - dvz = (pdata%q(ivy,i,j,kp1) + pdata%q(ivy,i,j,km1)) & - - 2.0d+00 * pdata%q(ivy,i,j,k) -#endif /* NDIMS == 3 */ - -! calculate the source term for Vy -! -#if NDIMS == 2 - dvv = pdata%q(idn,i,j,k) * (dxi2 * dvx + dyi2 * dvy) -#endif /* NDIMS == 2 */ -#if NDIMS == 3 - dvv = pdata%q(idn,i,j,k) * (dxi2 * dvx + dyi2 * dvy + dzi2 * dvz) -#endif /* NDIMS == 3 */ - -! add viscous source terms to Y-momentum equation -! - du(imy,i,j,k) = du(imy,i,j,k) + dvv - -! add viscous source term to total energy equation -! - if (ien > 0) then - du(ien,i,j,k) = du(ien,i,j,k) + pdata%q(ivy,i,j,k) * dvv - end if - -! calculate second order derivatives of Vz -! - dvx = (pdata%q(ivz,ip1,j,k) + pdata%q(ivz,im1,j,k)) & - - 2.0d+00 * pdata%q(ivz,i,j,k) - dvy = (pdata%q(ivz,i,jp1,k) + pdata%q(ivz,i,jm1,k)) & - - 2.0d+00 * pdata%q(ivz,i,j,k) -#if NDIMS == 3 - dvz = (pdata%q(ivz,i,j,kp1) + pdata%q(ivz,i,j,km1)) & - - 2.0d+00 * pdata%q(ivz,i,j,k) -#endif /* NDIMS == 3 */ - -! calculate the source term for Vz -! -#if NDIMS == 2 - dvv = pdata%q(idn,i,j,k) * (dxi2 * dvx + dyi2 * dvy) -#endif /* NDIMS == 2 */ -#if NDIMS == 3 - dvv = pdata%q(idn,i,j,k) * (dxi2 * dvx + dyi2 * dvy + dzi2 * dvz) -#endif /* NDIMS == 3 */ - -! add viscous source terms to Y-momentum equation -! - du(imz,i,j,k) = du(imz,i,j,k) + dvv - -! add viscous source term to total energy equation -! - if (ien > 0) then - du(ien,i,j,k) = du(ien,i,j,k) + pdata%q(ivz,i,j,k) * dvv - end if + tmp(inx,inx,i,j,k) = fc * (dvxdx - divv) + tmp(iny,iny,i,j,k) = fc * (dvydy - divv) + tmp(inz,inz,i,j,k) = fc * (dvzdz - divv) + tmp(inx,iny,i,j,k) = gc * (dvxdy + dvydx) + tmp(inx,inz,i,j,k) = gc * (dvxdz + dvzdx) + tmp(iny,inz,i,j,k) = gc * (dvydz + dvzdy) + tmp(iny,inx,i,j,k) = tmp(inx,iny,i,j,k) + tmp(inz,inx,i,j,k) = tmp(inx,inz,i,j,k) + tmp(inz,iny,i,j,k) = tmp(iny,inz,i,j,k) end do ! i = 1, im end do ! j = 1, jm end do ! k = 1, km +! calculate the divergence of the first tensor row +! + call divergence(dh(:), tmp(inx,inx:inz,1:im,1:jm,1:km) & + , db(1:im,1:jm,1:km)) + +! add viscous source terms to the X momentum equation +! + du(imx,1:im,1:jm,1:km) = du(imx,1:im,1:jm,1:km) + db(1:im,1:jm,1:km) + +! add viscous source term to total energy equation +! + if (ien > 0) then + du(ien,1:im,1:jm,1:km) = du(ien,1:im,1:jm,1:km) & + + pdata%q(ivx,1:im,1:jm,1:km) * db(1:im,1:jm,1:km) + end if + +! calculate the divergence of the second tensor row +! + call divergence(dh(:), tmp(iny,inx:inz,1:im,1:jm,1:km) & + , db(1:im,1:jm,1:km)) + +! add viscous source terms to the Y momentum equation +! + du(imy,1:im,1:jm,1:km) = du(imy,1:im,1:jm,1:km) + db(1:im,1:jm,1:km) + +! add viscous source term to total energy equation +! + if (ien > 0) then + du(ien,1:im,1:jm,1:km) = du(ien,1:im,1:jm,1:km) & + + pdata%q(ivy,1:im,1:jm,1:km) * db(1:im,1:jm,1:km) + end if + +! calculate the divergence of the third tensor row +! + call divergence(dh(:), tmp(inz,inx:inz,1:im,1:jm,1:km) & + , db(1:im,1:jm,1:km)) + +! add viscous source terms to the Z momentum equation +! + du(imz,1:im,1:jm,1:km) = du(imz,1:im,1:jm,1:km) + db(1:im,1:jm,1:km) + +! add viscous source term to total energy equation +! + if (ien > 0) then + du(ien,1:im,1:jm,1:km) = du(ien,1:im,1:jm,1:km) & + + pdata%q(ivz,1:im,1:jm,1:km) * db(1:im,1:jm,1:km) + end if + end if ! viscosity is not zero !=== add magnetic field related source terms === From ded726db798a2a5e8235752129869290c899e728 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 18 Nov 2014 20:38:37 -0200 Subject: [PATCH 02/19] SOURCES: Correct the energy term for viscous stress. The energy term which corresponds to the viscous stress tensor was incorrect. This patch implements the correct term. Signed-off-by: Grzegorz Kowal --- src/sources.F90 | 56 ++++++++++++++++++++++++++++++++++--------------- 1 file changed, 39 insertions(+), 17 deletions(-) diff --git a/src/sources.F90 b/src/sources.F90 index 118be30..21004a2 100644 --- a/src/sources.F90 +++ b/src/sources.F90 @@ -416,13 +416,6 @@ module sources ! du(imx,1:im,1:jm,1:km) = du(imx,1:im,1:jm,1:km) + db(1:im,1:jm,1:km) -! add viscous source term to total energy equation -! - if (ien > 0) then - du(ien,1:im,1:jm,1:km) = du(ien,1:im,1:jm,1:km) & - + pdata%q(ivx,1:im,1:jm,1:km) * db(1:im,1:jm,1:km) - end if - ! calculate the divergence of the second tensor row ! call divergence(dh(:), tmp(iny,inx:inz,1:im,1:jm,1:km) & @@ -432,13 +425,6 @@ module sources ! du(imy,1:im,1:jm,1:km) = du(imy,1:im,1:jm,1:km) + db(1:im,1:jm,1:km) -! add viscous source term to total energy equation -! - if (ien > 0) then - du(ien,1:im,1:jm,1:km) = du(ien,1:im,1:jm,1:km) & - + pdata%q(ivy,1:im,1:jm,1:km) * db(1:im,1:jm,1:km) - end if - ! calculate the divergence of the third tensor row ! call divergence(dh(:), tmp(inz,inx:inz,1:im,1:jm,1:km) & @@ -451,9 +437,45 @@ module sources ! add viscous source term to total energy equation ! if (ien > 0) then - du(ien,1:im,1:jm,1:km) = du(ien,1:im,1:jm,1:km) & - + pdata%q(ivz,1:im,1:jm,1:km) * db(1:im,1:jm,1:km) - end if + +! iterate over all cells +! + do k = 1, km + do j = 1, jm + do i = 1, jm + +! calculate scalar product of v and viscous stress tensor τ +! + gx = pdata%q(ivx,i,j,k) * tmp(inx,inx,i,j,k) & + + pdata%q(ivy,i,j,k) * tmp(inx,iny,i,j,k) & + + pdata%q(ivz,i,j,k) * tmp(inx,inz,i,j,k) + gy = pdata%q(ivx,i,j,k) * tmp(iny,inx,i,j,k) & + + pdata%q(ivy,i,j,k) * tmp(iny,iny,i,j,k) & + + pdata%q(ivz,i,j,k) * tmp(iny,inz,i,j,k) + gz = pdata%q(ivx,i,j,k) * tmp(inz,inx,i,j,k) & + + pdata%q(ivy,i,j,k) * tmp(inz,iny,i,j,k) & + + pdata%q(ivz,i,j,k) * tmp(inz,inz,i,j,k) + +! update (v.τ), use the first row of the tensor tmp +! + tmp(inx,inx,i,j,k) = gx + tmp(inx,iny,i,j,k) = gy + tmp(inx,inz,i,j,k) = gz + + end do ! i = 1, im + end do ! j = 1, jm + end do ! k = 1, km + +! calculate the divergence of (v.τ) +! + call divergence(dh(:), tmp(inx,inx:inz,1:im,1:jm,1:km) & + , db(1:im,1:jm,1:km)) + +! update the energy increment +! + du(ien,1:im,1:jm,1:km) = du(ien,1:im,1:jm,1:km) + db(1:im,1:jm,1:km) + + end if ! ien > 0 end if ! viscosity is not zero From 34f2871b350b207bfc9a4c1cb872da7d85a47040 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Wed, 19 Nov 2014 18:29:24 -0200 Subject: [PATCH 03/19] SOURCES: Rewrite resistive source terms. The resistive source terms are calculated without assumption about the uniform resistivity coefficient. Signed-off-by: Grzegorz Kowal --- src/sources.F90 | 55 ++++++++++++++++++++++++++++++++----------------- 1 file changed, 36 insertions(+), 19 deletions(-) diff --git a/src/sources.F90 b/src/sources.F90 index 21004a2..5f97a2a 100644 --- a/src/sources.F90 +++ b/src/sources.F90 @@ -555,39 +555,56 @@ module sources ! if (resistivity > 0.0d+00) then -! calculate the Laplace operator of B, i.e. Δ(B) +! calculate the current density J = ∇ x B ! - call laplace(dh(:), pdata%q(ibx,:,:,:), jc(inx,:,:,:)) - call laplace(dh(:), pdata%q(iby,:,:,:), jc(iny,:,:,:)) - call laplace(dh(:), pdata%q(ibz,:,:,:), jc(inz,:,:,:)) + call curl(dh(:), pdata%q(ibx:ibz,1:im,1:jm,1:km) & + , tmp(inx,inx:inz,1:im,1:jm,1:km)) + +! multiply the current density by the resistivity +! + tmp(iny,inx:inz,1:im,1:jm,1:km) = & + resistivity * tmp(inx,inx:inz,1:im,1:jm,1:km) + +! calculate the curl of ηJ +! + call curl(dh(:), tmp(iny,inx:inz,1:im,1:jm,1:km) & + , tmp(inz,inx:inz,1:im,1:jm,1:km)) ! update magnetic field component increments +! d/dt B + ∇.F = - ∇ x (ηJ) ! - du(ibx,:,:,:) = du(ibx,:,:,:) + resistivity * jc(inx,:,:,:) - du(iby,:,:,:) = du(iby,:,:,:) + resistivity * jc(iny,:,:,:) - du(ibz,:,:,:) = du(ibz,:,:,:) + resistivity * jc(inz,:,:,:) + du(ibx,1:im,1:jm,1:km) = du(ibx,1:im,1:jm,1:km) & + - tmp(inz,inx,1:im,1:jm,1:km) + du(iby,1:im,1:jm,1:km) = du(iby,1:im,1:jm,1:km) & + - tmp(inz,iny,1:im,1:jm,1:km) + du(ibz,1:im,1:jm,1:km) = du(ibz,1:im,1:jm,1:km) & + - tmp(inz,inz,1:im,1:jm,1:km) ! update energy equation ! if (ien > 0) then -! add the first resistive source term to the energy equation, i.e. -! d/dt E + ∇.F = η B.[Δ(B)] +! calculate the cross product B x (ηJ) ! - du(ien,:,:,:) = du(ien,:,:,:) & - + resistivity * (pdata%q(ibx,:,:,:) * jc(inx,:,:,:) & - + pdata%q(iby,:,:,:) * jc(iny,:,:,:) & - + pdata%q(ibz,:,:,:) * jc(inz,:,:,:)) + tmp(inx,inx,1:im,1:jm,1:km) = & + pdata%q(iby,1:im,1:jm,1:km) * tmp(iny,inz,1:im,1:jm,1:km) & + - pdata%q(ibz,1:im,1:jm,1:km) * tmp(iny,iny,1:im,1:jm,1:km) + tmp(inx,iny,1:im,1:jm,1:km) = & + pdata%q(ibz,1:im,1:jm,1:km) * tmp(iny,inx,1:im,1:jm,1:km) & + - pdata%q(ibx,1:im,1:jm,1:km) * tmp(iny,inz,1:im,1:jm,1:km) + tmp(inx,inz,1:im,1:jm,1:km) = & + pdata%q(ibx,1:im,1:jm,1:km) * tmp(iny,iny,1:im,1:jm,1:km) & + - pdata%q(iby,1:im,1:jm,1:km) * tmp(iny,inx,1:im,1:jm,1:km) -! calculate current density J = ∇xB +! calculate divergence of [B x (ηJ)] ! - call curl(dh(:), pdata%q(ibx:ibz,:,:,:), jc(inx:inz,:,:,:)) + call divergence(dh(:), tmp(inx,inx:inz,1:im,1:jm,1:km) & + , db(1:im,1:jm,1:km)) -! add the second resistive source term to the energy equation, i.e. -! d/dt E + ∇.F = η J² +! add the resistive source term to the energy equation, i.e. +! d/dt E + ∇.F = ∇.[B x (ηJ)] ! - du(ien,:,:,:) = du(ien,:,:,:) & - + resistivity * sum(jc(:,:,:,:) * jc(:,:,:,:), 1) + du(ien,1:im,1:jm,1:km) = du(ien,1:im,1:jm,1:km) + db(1:im,1:jm,1:km) end if ! energy equation present From e2fd3a6b2d79f20a239e241fb88f267d00e8f265 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Wed, 19 Nov 2014 19:14:24 -0200 Subject: [PATCH 04/19] Revert "SOURCES: Rewrite resistive source terms." This reverts commit 34f2871b350b207bfc9a4c1cb872da7d85a47040. The new implementation based on curl produces numerical oscillation at small scales. --- src/sources.F90 | 55 +++++++++++++++++-------------------------------- 1 file changed, 19 insertions(+), 36 deletions(-) diff --git a/src/sources.F90 b/src/sources.F90 index 5f97a2a..21004a2 100644 --- a/src/sources.F90 +++ b/src/sources.F90 @@ -555,56 +555,39 @@ module sources ! if (resistivity > 0.0d+00) then -! calculate the current density J = ∇ x B +! calculate the Laplace operator of B, i.e. Δ(B) ! - call curl(dh(:), pdata%q(ibx:ibz,1:im,1:jm,1:km) & - , tmp(inx,inx:inz,1:im,1:jm,1:km)) - -! multiply the current density by the resistivity -! - tmp(iny,inx:inz,1:im,1:jm,1:km) = & - resistivity * tmp(inx,inx:inz,1:im,1:jm,1:km) - -! calculate the curl of ηJ -! - call curl(dh(:), tmp(iny,inx:inz,1:im,1:jm,1:km) & - , tmp(inz,inx:inz,1:im,1:jm,1:km)) + call laplace(dh(:), pdata%q(ibx,:,:,:), jc(inx,:,:,:)) + call laplace(dh(:), pdata%q(iby,:,:,:), jc(iny,:,:,:)) + call laplace(dh(:), pdata%q(ibz,:,:,:), jc(inz,:,:,:)) ! update magnetic field component increments -! d/dt B + ∇.F = - ∇ x (ηJ) ! - du(ibx,1:im,1:jm,1:km) = du(ibx,1:im,1:jm,1:km) & - - tmp(inz,inx,1:im,1:jm,1:km) - du(iby,1:im,1:jm,1:km) = du(iby,1:im,1:jm,1:km) & - - tmp(inz,iny,1:im,1:jm,1:km) - du(ibz,1:im,1:jm,1:km) = du(ibz,1:im,1:jm,1:km) & - - tmp(inz,inz,1:im,1:jm,1:km) + du(ibx,:,:,:) = du(ibx,:,:,:) + resistivity * jc(inx,:,:,:) + du(iby,:,:,:) = du(iby,:,:,:) + resistivity * jc(iny,:,:,:) + du(ibz,:,:,:) = du(ibz,:,:,:) + resistivity * jc(inz,:,:,:) ! update energy equation ! if (ien > 0) then -! calculate the cross product B x (ηJ) +! add the first resistive source term to the energy equation, i.e. +! d/dt E + ∇.F = η B.[Δ(B)] ! - tmp(inx,inx,1:im,1:jm,1:km) = & - pdata%q(iby,1:im,1:jm,1:km) * tmp(iny,inz,1:im,1:jm,1:km) & - - pdata%q(ibz,1:im,1:jm,1:km) * tmp(iny,iny,1:im,1:jm,1:km) - tmp(inx,iny,1:im,1:jm,1:km) = & - pdata%q(ibz,1:im,1:jm,1:km) * tmp(iny,inx,1:im,1:jm,1:km) & - - pdata%q(ibx,1:im,1:jm,1:km) * tmp(iny,inz,1:im,1:jm,1:km) - tmp(inx,inz,1:im,1:jm,1:km) = & - pdata%q(ibx,1:im,1:jm,1:km) * tmp(iny,iny,1:im,1:jm,1:km) & - - pdata%q(iby,1:im,1:jm,1:km) * tmp(iny,inx,1:im,1:jm,1:km) + du(ien,:,:,:) = du(ien,:,:,:) & + + resistivity * (pdata%q(ibx,:,:,:) * jc(inx,:,:,:) & + + pdata%q(iby,:,:,:) * jc(iny,:,:,:) & + + pdata%q(ibz,:,:,:) * jc(inz,:,:,:)) -! calculate divergence of [B x (ηJ)] +! calculate current density J = ∇xB ! - call divergence(dh(:), tmp(inx,inx:inz,1:im,1:jm,1:km) & - , db(1:im,1:jm,1:km)) + call curl(dh(:), pdata%q(ibx:ibz,:,:,:), jc(inx:inz,:,:,:)) -! add the resistive source term to the energy equation, i.e. -! d/dt E + ∇.F = ∇.[B x (ηJ)] +! add the second resistive source term to the energy equation, i.e. +! d/dt E + ∇.F = η J² ! - du(ien,1:im,1:jm,1:km) = du(ien,1:im,1:jm,1:km) + db(1:im,1:jm,1:km) + du(ien,:,:,:) = du(ien,:,:,:) & + + resistivity * sum(jc(:,:,:,:) * jc(:,:,:,:), 1) end if ! energy equation present From d0808436b61dacaa9d5c51fd3f5d0766b8ab61ab Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Wed, 19 Nov 2014 20:19:08 -0200 Subject: [PATCH 05/19] SOURCES: Rewrite resistive source terms. Signed-off-by: Grzegorz Kowal --- src/sources.F90 | 38 +++++++++++++++++++++++++------------- 1 file changed, 25 insertions(+), 13 deletions(-) diff --git a/src/sources.F90 b/src/sources.F90 index 21004a2..0bb8db7 100644 --- a/src/sources.F90 +++ b/src/sources.F90 @@ -557,15 +557,26 @@ module sources ! calculate the Laplace operator of B, i.e. Δ(B) ! - call laplace(dh(:), pdata%q(ibx,:,:,:), jc(inx,:,:,:)) - call laplace(dh(:), pdata%q(iby,:,:,:), jc(iny,:,:,:)) - call laplace(dh(:), pdata%q(ibz,:,:,:), jc(inz,:,:,:)) + call laplace(dh(:), pdata%q(ibx,1:im,1:jm,1:km) & + , tmp(inx,inx,1:im,1:jm,1:km)) + call laplace(dh(:), pdata%q(iby,1:im,1:jm,1:km) & + , tmp(inx,iny,1:im,1:jm,1:km)) + call laplace(dh(:), pdata%q(ibz,1:im,1:jm,1:km) & + , tmp(inx,inz,1:im,1:jm,1:km)) + +! multiply by the resistivity coefficient +! + tmp(iny,inx:inz,1:im,1:jm,1:km) = & + resistivity * tmp(inx,inx:inz,1:im,1:jm,1:km) ! update magnetic field component increments ! - du(ibx,:,:,:) = du(ibx,:,:,:) + resistivity * jc(inx,:,:,:) - du(iby,:,:,:) = du(iby,:,:,:) + resistivity * jc(iny,:,:,:) - du(ibz,:,:,:) = du(ibz,:,:,:) + resistivity * jc(inz,:,:,:) + du(ibx,1:im,1:jm,1:km) = du(ibx,1:im,1:jm,1:km) & + + tmp(iny,inx,1:im,1:jm,1:km) + du(iby,1:im,1:jm,1:km) = du(iby,1:im,1:jm,1:km) & + + tmp(iny,iny,1:im,1:jm,1:km) + du(ibz,1:im,1:jm,1:km) = du(ibz,1:im,1:jm,1:km) & + + tmp(iny,inz,1:im,1:jm,1:km) ! update energy equation ! @@ -574,20 +585,21 @@ module sources ! add the first resistive source term to the energy equation, i.e. ! d/dt E + ∇.F = η B.[Δ(B)] ! - du(ien,:,:,:) = du(ien,:,:,:) & - + resistivity * (pdata%q(ibx,:,:,:) * jc(inx,:,:,:) & - + pdata%q(iby,:,:,:) * jc(iny,:,:,:) & - + pdata%q(ibz,:,:,:) * jc(inz,:,:,:)) + du(ien,1:im,1:jm,1:km) = du(ien,1:im,1:jm,1:km) & + + (pdata%q(ibx,1:im,1:jm,1:km) * tmp(iny,inx,1:im,1:jm,1:km) & + + pdata%q(iby,1:im,1:jm,1:km) * tmp(iny,iny,1:im,1:jm,1:km) & + + pdata%q(ibz,1:im,1:jm,1:km) * tmp(iny,inz,1:im,1:jm,1:km)) ! calculate current density J = ∇xB ! - call curl(dh(:), pdata%q(ibx:ibz,:,:,:), jc(inx:inz,:,:,:)) + call curl(dh(:), pdata%q(ibx:ibz,1:im,1:jm,1:km) & + , tmp(inz,inx:inz,1:im,1:jm,1:km)) ! add the second resistive source term to the energy equation, i.e. ! d/dt E + ∇.F = η J² ! - du(ien,:,:,:) = du(ien,:,:,:) & - + resistivity * sum(jc(:,:,:,:) * jc(:,:,:,:), 1) + du(ien,1:im,1:jm,1:km) = du(ien,1:im,1:jm,1:km) & + + resistivity * sum(tmp(inz,inx:inz,1:im,1:jm,1:km)**2, 2) end if ! energy equation present From 70ad8c92e55eaa681e5dae60d4321bbd471b7356 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Fri, 28 Nov 2014 08:02:20 -0200 Subject: [PATCH 06/19] SOURCES: Use temporary array tmp(:,:,:,:,:) instead of jc(:,:,:,:). In this way adday jc(:,:,:,:) can be removed. Signed-off-by: Grzegorz Kowal --- src/sources.F90 | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/src/sources.F90 b/src/sources.F90 index 0bb8db7..2e6d09a 100644 --- a/src/sources.F90 +++ b/src/sources.F90 @@ -270,7 +270,6 @@ module sources real(kind=8), dimension(jm) :: y real(kind=8), dimension(km) :: z real(kind=8), dimension(im,jm,km) :: db - real(kind=8), dimension(3,im,jm,km) :: jc real(kind=8), dimension(3,3,im,jm,km) :: tmp ! !------------------------------------------------------------------------------- @@ -510,13 +509,13 @@ module sources ! calculate the gradient of divergence potential ! - call gradient(dh(:), pdata%q(ibp,:,:,:), jc(inx:inz,:,:,:)) + call gradient(dh(:), pdata%q(ibp,:,:,:), tmp(inx:inz,inx,:,:,:)) ! add the divergence potential source term to the energy equation, i.e. ! d/dt E + ∇.F = - B.(∇ψ) ! du(ien,:,:,:) = du(ien,:,:,:) & - - sum(pdata%q(ibx:ibz,:,:,:) * jc(inx:inz,:,:,:), 1) + - sum(pdata%q(ibx:ibz,:,:,:) * tmp(inx:inz,inx,:,:,:), 1) end if ! ien > 0 @@ -537,13 +536,13 @@ module sources ! calculate scalar product of velocity and magnetic field ! - jc(inx,:,:,:) = sum(pdata%q(ivx:ivz,:,:,:) & + tmp(inx,inx,:,:,:) = sum(pdata%q(ivx:ivz,:,:,:) & * pdata%q(ibx:ibz,:,:,:), 1) ! add the divergence potential source term to the energy equation, i.e. ! d/dt E + ∇.F = - (∇.B) (v.B) ! - du(ien,:,:,:) = du(ien,:,:,:) - db(:,:,:) * jc(inx,:,:,:) + du(ien,:,:,:) = du(ien,:,:,:) - db(:,:,:) * tmp(inx,inx,:,:,:) end if ! ien > 0 From fa1488dfc9592ac5704ec4e6879ddc4826303dfe Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Sun, 30 Nov 2014 13:45:18 -0200 Subject: [PATCH 07/19] MPITOOLS: Generate processor pairs in round-robin order. The list of processor pairs in round-robin order should guarantee the optimal MPI exchange between processors, i.e. that all processors will be involved in the data exchange in the same time. Signed-off-by: Grzegorz Kowal --- src/mpitools.F90 | 78 ++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 76 insertions(+), 2 deletions(-) diff --git a/src/mpitools.F90 b/src/mpitools.F90 index d2b3ad2..e5522c2 100644 --- a/src/mpitools.F90 +++ b/src/mpitools.F90 @@ -49,12 +49,16 @@ module mpitools ! MPI global variables ! integer(kind=4), save :: comm3d - integer(kind=4), save :: nproc, nprocs, npmax + integer(kind=4), save :: nproc, nprocs, npmax, npairs integer(kind=4), save, dimension(3) :: pdims, pcoords, pparity integer(kind=4), save, dimension(3,2) :: pneighs logical , save, dimension(3) :: periodic logical , save :: master = .true. +! allocatable array for processor pairs +! + integer(kind=4), dimension(:,:), allocatable, save :: pairs + ! by default everything is public ! public @@ -92,7 +96,11 @@ module mpitools ! local variables ! #ifdef MPI - integer :: iret + integer :: mprocs, i, j, l, n, iret + +! allocatable array for processors order +! + integer(kind=4), dimension(:), allocatable :: procs #endif /* MPI */ ! !------------------------------------------------------------------------------- @@ -170,6 +178,68 @@ module mpitools ! npmax = nprocs - 1 +! roung up the number of processors to even number +! + mprocs = nprocs + mod(nprocs, 2) + +! calculate the number of processor pairs for data exchange +! + npairs = mprocs * (mprocs - 1) / 2 + +! allocate space for all processor pairs +! + allocate(pairs(npairs, 2)) + +! allocate space for the processor order +! + allocate(procs(mprocs)) + +! fill the processor order array +! + procs(:) = (/(l, l = 0, mprocs - 1)/) + +! generate processor pairs +! + n = 0 + +! iterate over turns +! + do l = 1, mprocs - 1 + +! generate pairs for a given turn +! + do i = 1, mprocs / 2 + +! calculate the pair for the current processor +! + j = mprocs - i + 1 + +! continue, if the process number is correct (for odd nprocs case) +! + if (procs(i) < nprocs .and. procs(j) < nprocs) then + +! increase the pair number +! + n = n + 1 + +! substitute the processor numbers for the current pair +! + pairs(n,1:2) = (/ procs(i), procs(j) /) + + end if ! max(procs(i), procs(j)) < nprocs + + end do ! i = 1, mprocs / 2 + +! shift elements in the processor order array +! + procs(2:mprocs) = cshift(procs(2:mprocs), -1) + + end do ! l = 1, mprocs - 1 + +! allocate space for the processor order +! + deallocate(procs) + ! store the MPI pool handles ! comm3d = mpi_comm_world @@ -232,6 +302,10 @@ module mpitools stop end if +! deallocate space used for processor pairs +! + if (allocated(pairs)) deallocate(pairs) + ! stop time accounting for the MPI initialization ! call stop_timer(imi) From 3919669b7ff8738697d6d6949c6adc812ed5bcd6 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Sun, 30 Nov 2014 13:59:46 -0200 Subject: [PATCH 08/19] MPITOOLS: Generate pairs for cases when order is important. Signed-off-by: Grzegorz Kowal --- src/mpitools.F90 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/mpitools.F90 b/src/mpitools.F90 index e5522c2..85f286b 100644 --- a/src/mpitools.F90 +++ b/src/mpitools.F90 @@ -184,7 +184,7 @@ module mpitools ! calculate the number of processor pairs for data exchange ! - npairs = mprocs * (mprocs - 1) / 2 + npairs = nprocs * npmax ! allocate space for all processor pairs ! @@ -236,6 +236,10 @@ module mpitools end do ! l = 1, mprocs - 1 +! fill out the remaining pairs (swapped) +! + pairs(npairs/2+1:npairs,1:2) = pairs(1:npairs/2,2:1:-1) + ! allocate space for the processor order ! deallocate(procs) From 0349f2aa0fb1c365233c121e1b94a86c9b56922a Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Sun, 30 Nov 2014 18:08:27 -0200 Subject: [PATCH 09/19] BOUNDARIES: Utilize optimized process pairs to boundary exchange. Signed-off-by: Grzegorz Kowal --- src/boundaries.F90 | 175 ++++++++++++++++++++++++++++----------------- 1 file changed, 110 insertions(+), 65 deletions(-) diff --git a/src/boundaries.F90 b/src/boundaries.F90 index be2f7d2..43feff5 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -417,6 +417,7 @@ module boundaries use equations , only : nv #ifdef MPI use mpitools , only : nprocs, nproc, npmax + use mpitools , only : npairs, pairs use mpitools , only : send_real_array, receive_real_array #endif /* MPI */ @@ -437,18 +438,14 @@ module boundaries 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 */ + integer :: irecv, isend, nblocks, itag, iret + integer :: l, p -#ifdef MPI ! local pointer arrays ! type(pointer_info), dimension(0:nprocs-1,0:nprocs-1) :: block_array -#endif /* MPI */ -#ifdef MPI ! local arrays ! integer , dimension(0:nprocs-1,0:nprocs-1) :: block_counter @@ -728,10 +725,14 @@ module boundaries end do ! meta blocks #ifdef MPI -! iterate over sending and receiving processes +! iterate over all processor pairs ! - do irecv = 0, npmax - do isend = 0, npmax + do p = 1, npairs + +! get sending and receiving processor identifiers +! + isend = pairs(p,1) + irecv = pairs(p,2) ! process only pairs which have anything to exchange ! @@ -1026,8 +1027,7 @@ module boundaries end if ! if block_count > 0 - end do ! isend - end do ! irecv + end do ! p = 1, npairs #endif /* MPI */ #ifdef PROFILE @@ -1244,6 +1244,7 @@ module boundaries use equations , only : nv use mpitools , only : nproc, nprocs, npmax #ifdef MPI + use mpitools , only : npairs, pairs use mpitools , only : send_real_array, receive_real_array #endif /* MPI */ @@ -1270,7 +1271,8 @@ module boundaries integer :: iu, ju, ku integer :: iret #ifdef MPI - integer :: isend, irecv, nblocks, itag, l + integer :: isend, irecv, nblocks, itag + integer :: l, p ! local pointer arrays ! @@ -1501,10 +1503,14 @@ module boundaries #ifdef MPI !! 3. UPDATE VARIABLE BOUNDARIES BETWEEN BLOCKS BELONGING TO DIFFERENT PROCESSES !! -! iterate over sending and receiving processors +! iterate over all processor pairs ! - do irecv = 0, npmax - do isend = 0, npmax + do p = 1, npairs + +! get sending and receiving processor identifiers +! + isend = pairs(p,1) + irecv = pairs(p,2) ! process only pairs which have anything to exchange ! @@ -1745,8 +1751,7 @@ module boundaries end if ! if block_count > 0 - end do ! isend - end do ! irecv + end do ! p = 1, npairs #endif /* MPI */ #ifdef PROFILE @@ -1792,6 +1797,7 @@ module boundaries use equations , only : nv use mpitools , only : nproc, nprocs, npmax #ifdef MPI + use mpitools , only : npairs, pairs use mpitools , only : send_real_array, receive_real_array #endif /* MPI */ @@ -1818,7 +1824,8 @@ module boundaries integer :: iu, ju, ku integer :: iret #ifdef MPI - integer :: isend, irecv, nblocks, itag, l + integer :: isend, irecv, nblocks, itag + integer :: l, p ! local pointer arrays ! @@ -2049,10 +2056,14 @@ module boundaries #ifdef MPI !! 3. UPDATE VARIABLE BOUNDARIES BETWEEN BLOCKS BELONGING TO DIFFERENT PROCESSES !! -! iterate over sending and receiving processors +! iterate over all processor pairs ! - do irecv = 0, npmax - do isend = 0, npmax + do p = 1, npairs + +! get sending and receiving processor identifiers +! + isend = pairs(p,1) + irecv = pairs(p,2) ! process only pairs which have something to exchange ! @@ -2293,8 +2304,7 @@ module boundaries end if ! if block_count > 0 - end do ! isend - end do ! irecv + end do ! p = 1, npairs #endif /* MPI */ #ifdef PROFILE @@ -2340,6 +2350,7 @@ module boundaries use equations , only : nv use mpitools , only : nproc, nprocs, npmax #ifdef MPI + use mpitools , only : npairs, pairs use mpitools , only : send_real_array, receive_real_array #endif /* MPI */ @@ -2367,7 +2378,8 @@ module boundaries integer :: iu, ju, ku integer :: iret #ifdef MPI - integer :: isend, irecv, nblocks, itag, l + integer :: isend, irecv, nblocks, itag + integer :: l, p ! local pointer arrays ! @@ -2610,10 +2622,14 @@ module boundaries #ifdef MPI !! 3. UPDATE VARIABLE BOUNDARIES BETWEEN BLOCKS BELONGING TO DIFFERENT PROCESSES !! -! iterate over sending and receiving processors +! iterate over all processor pairs ! - do irecv = 0, npmax - do isend = 0, npmax + do p = 1, npairs + +! get sending and receiving processor identifiers +! + isend = pairs(p,1) + irecv = pairs(p,2) ! process only pairs which have something to exchange ! @@ -2861,8 +2877,7 @@ module boundaries end if ! if block_count > 0 - end do ! isend - end do ! irecv + end do ! p = 1, npairs #endif /* MPI */ #ifdef PROFILE @@ -2915,6 +2930,7 @@ module boundaries use equations , only : nv use mpitools , only : nproc, nprocs, npmax #ifdef MPI + use mpitools , only : npairs, pairs use mpitools , only : send_real_array, receive_real_array #endif /* MPI */ @@ -2941,7 +2957,8 @@ module boundaries integer :: iu, ju, ku integer :: iret #ifdef MPI - integer :: isend, irecv, nblocks, itag, l + integer :: isend, irecv, nblocks, itag + integer :: l, p ! local pointer arrays ! @@ -3175,10 +3192,14 @@ module boundaries #ifdef MPI !! 3. UPDATE VARIABLE BOUNDARIES BETWEEN BLOCKS BELONGING TO DIFFERENT PROCESSES !! -! iterate over sending and receiving processors +! iterate over all processor pairs ! - do irecv = 0, npmax - do isend = 0, npmax + do p = 1, npairs + +! get sending and receiving processor identifiers +! + isend = pairs(p,1) + irecv = pairs(p,2) ! process only pairs which have something to exchange ! @@ -3445,8 +3466,7 @@ module boundaries end if ! if block_count > 0 - end do ! isend - end do ! irecv + end do ! p = 1, npairs #endif /* MPI */ #ifdef PROFILE @@ -3492,6 +3512,7 @@ module boundaries use equations , only : nv use mpitools , only : nproc, nprocs, npmax #ifdef MPI + use mpitools , only : npairs, pairs use mpitools , only : send_real_array, receive_real_array #endif /* MPI */ @@ -3518,7 +3539,8 @@ module boundaries integer :: iu, ju, ku integer :: iret #ifdef MPI - integer :: isend, irecv, nblocks, itag, l + integer :: isend, irecv, nblocks, itag + integer :: l, p ! local pointer arrays ! @@ -3752,10 +3774,14 @@ module boundaries #ifdef MPI !! 3. UPDATE VARIABLE BOUNDARIES BETWEEN BLOCKS BELONGING TO DIFFERENT PROCESSES !! -! iterate over sending and receiving processors +! iterate over all processor pairs ! - do irecv = 0, npmax - do isend = 0, npmax + do p = 1, npairs + +! get sending and receiving processor identifiers +! + isend = pairs(p,1) + irecv = pairs(p,2) ! process only pairs which have something to exchange ! @@ -4022,8 +4048,7 @@ module boundaries end if ! if block_count > 0 - end do ! isend - end do ! irecv + end do ! p = 1, npairs #endif /* MPI */ #ifdef PROFILE @@ -4069,6 +4094,7 @@ module boundaries use equations , only : nv use mpitools , only : nproc, nprocs, npmax #ifdef MPI + use mpitools , only : npairs, pairs use mpitools , only : send_real_array, receive_real_array #endif /* MPI */ @@ -4096,7 +4122,8 @@ module boundaries integer :: iu, ju, ku integer :: iret #ifdef MPI - integer :: isend, irecv, nblocks, itag, l + integer :: isend, irecv, nblocks, itag + integer :: l, p ! local pointer arrays ! @@ -4336,10 +4363,14 @@ module boundaries #ifdef MPI !! 3. UPDATE VARIABLE BOUNDARIES BETWEEN BLOCKS BELONGING TO DIFFERENT PROCESSES !! -! iterate over sending and receiving processors +! iterate over all processor pairs ! - do irecv = 0, npmax - do isend = 0, npmax + do p = 1, npairs + +! get sending and receiving processor identifiers +! + isend = pairs(p,1) + irecv = pairs(p,2) ! process only pairs which have something to exchange ! @@ -4610,8 +4641,7 @@ module boundaries end if ! if block_count > 0 - end do ! isend - end do ! irecv + end do ! p = 1, npairs #endif /* MPI */ #ifdef PROFILE @@ -4657,6 +4687,7 @@ module boundaries use equations , only : nv use mpitools , only : nproc, nprocs, npmax #ifdef MPI + use mpitools , only : npairs, pairs use mpitools , only : send_real_array, receive_real_array #endif /* MPI */ @@ -4678,7 +4709,8 @@ module boundaries integer :: iu, ju, ku integer :: iret #ifdef MPI - integer :: isend, irecv, nblocks, itag, l + integer :: isend, irecv, nblocks, itag + integer :: l, p ! local pointer arrays ! @@ -4875,10 +4907,14 @@ module boundaries #ifdef MPI !! 3. UPDATE VARIABLE BOUNDARIES BETWEEN BLOCKS BELONGING TO DIFFERENT PROCESSES !! -! iterate over sending and receiving processors +! iterate over all processor pairs ! - do irecv = 0, npmax - do isend = 0, npmax + do p = 1, npairs + +! get sending and receiving processor identifiers +! + isend = pairs(p,1) + irecv = pairs(p,2) ! process only pairs which have something to exchange ! @@ -5075,8 +5111,7 @@ module boundaries end if ! if block_count > 0 - end do ! isend - end do ! irecv + end do ! p = 1, npairs #endif /* MPI */ #ifdef PROFILE @@ -5116,6 +5151,7 @@ module boundaries use equations , only : nv use mpitools , only : nproc, nprocs, npmax #ifdef MPI + use mpitools , only : npairs, pairs use mpitools , only : send_real_array, receive_real_array #endif /* MPI */ @@ -5137,7 +5173,8 @@ module boundaries integer :: iu, ju, ku integer :: iret #ifdef MPI - integer :: isend, irecv, nblocks, itag, l + integer :: isend, irecv, nblocks, itag + integer :: l, p ! local pointer arrays ! @@ -5333,10 +5370,14 @@ module boundaries #ifdef MPI !! 3. UPDATE VARIABLE BOUNDARIES BETWEEN BLOCKS BELONGING TO DIFFERENT PROCESSES !! -! iterate over sending and receiving processors +! iterate over all processor pairs ! - do irecv = 0, npmax - do isend = 0, npmax + do p = 1, npairs + +! get sending and receiving processor identifiers +! + isend = pairs(p,1) + irecv = pairs(p,2) ! process only pairs which have something to exchange ! @@ -5533,8 +5574,7 @@ module boundaries end if ! if block_count > 0 - end do ! isend - end do ! irecv + end do ! p = 1, npairs #endif /* MPI */ #ifdef PROFILE @@ -5574,6 +5614,7 @@ module boundaries use equations , only : nv use mpitools , only : nproc, nprocs, npmax #ifdef MPI + use mpitools , only : npairs, pairs use mpitools , only : send_real_array, receive_real_array #endif /* MPI */ @@ -5595,7 +5636,8 @@ module boundaries integer :: iu, ju, ku integer :: iret #ifdef MPI - integer :: isend, irecv, nblocks, itag, l + integer :: isend, irecv, nblocks, itag + integer :: l, p ! local pointer arrays ! @@ -5791,10 +5833,14 @@ module boundaries #ifdef MPI !! 3. UPDATE VARIABLE BOUNDARIES BETWEEN BLOCKS BELONGING TO DIFFERENT PROCESSES !! -! iterate over sending and receiving processors +! iterate over all processor pairs ! - do irecv = 0, npmax - do isend = 0, npmax + do p = 1, npairs + +! get sending and receiving processor identifiers +! + isend = pairs(p,1) + irecv = pairs(p,2) ! process only pairs which have something to exchange ! @@ -5991,8 +6037,7 @@ module boundaries end if ! if block_count > 0 - end do ! isend - end do ! irecv + end do ! p = 1, npairs #endif /* MPI */ #ifdef PROFILE From d55ffb605fae97f13124feb75977e07d19440ddc Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Sun, 30 Nov 2014 18:19:24 -0200 Subject: [PATCH 10/19] BOUNDARIES: Fix line alignment in boundary_fluxes(). Signed-off-by: Grzegorz Kowal --- src/boundaries.F90 | 516 ++++++++++++++++++++++----------------------- 1 file changed, 258 insertions(+), 258 deletions(-) diff --git a/src/boundaries.F90 b/src/boundaries.F90 index 43feff5..bc5c670 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -725,307 +725,307 @@ module boundaries end do ! meta blocks #ifdef MPI -! iterate over all processor pairs +! iterate over all process pairs ! do p = 1, npairs -! get sending and receiving processor identifiers +! get sending and receiving process identifiers ! isend = pairs(p,1) irecv = pairs(p,2) ! process only pairs which have anything to exchange ! - if (block_counter(isend,irecv) > 0) then + if (block_counter(isend,irecv) > 0) then ! obtain the number of blocks to exchange ! - nblocks = block_counter(isend,irecv) + nblocks = block_counter(isend,irecv) ! prepare the tag for communication ! - itag = 16 * (irecv * nprocs + isend) + 1 + itag = 16 * (irecv * nprocs + isend) + 1 ! allocate the buffer for variable exchange ! - allocate(rbuf(nblocks,nv,ih,kh)) + 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 - -! associate pinfo with the first block in the exchange list -! - pinfo => block_array(isend,irecv)%ptr - -! scan all blocks on the list -! - do while(associated(pinfo)) - -! increase the block count -! - l = l + 1 - -! associate pneigh pointer -! - 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 - -! 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) & - , rbuf(l,1:nv,1:jh,1:kh)) - - case(2) - -! prepare the boundary layer index depending on the side -! - if (j == 1) then - js = je - else - js = jbl - 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,js,kb:ke) & - , rbuf(l,1:nv,1:ih,1:kh)) - -#if NDIMS == 3 - case(3) - -! prepare the boundary layer index depending on the side -! - if (k == 1) then - ks = ke - else - ks = kbl - 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) & - , 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 - -! 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 - -! scan all blocks on the list -! - do while(associated(pinfo)) - -! increase the block count -! - l = l + 1 - -! associate pmeta pointer -! - pmeta => pinfo%block - -! get neighbor direction and corner indices -! - 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 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) + l = 0 ! associate pinfo with the first block in the exchange list ! pinfo => block_array(isend,irecv)%ptr -! scan all blocks on the exchange list +! scan all blocks on the list ! do while(associated(pinfo)) -! associate the exchange list pointer +! increase the block count ! - block_array(isend,irecv)%ptr => pinfo%prev + l = l + 1 -! nullify pointer fields +! associate pneigh pointer ! - nullify(pinfo%prev) - nullify(pinfo%next) - nullify(pinfo%block) - nullify(pinfo%neigh) + pneigh => pinfo%neigh -! deallocate info block +! get neighbor direction and corner coordinates ! - deallocate(pinfo) + 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 + +! 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) & + , rbuf(l,1:nv,1:jh,1:kh)) + + case(2) + +! prepare the boundary layer index depending on the side +! + if (j == 1) then + js = je + else + js = jbl + 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,js,kb:ke) & + , rbuf(l,1:nv,1:ih,1:kh)) + +#if NDIMS == 3 + case(3) + +! prepare the boundary layer index depending on the side +! + if (k == 1) then + ks = ke + else + ks = kbl + 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) & + , rbuf(l,1:nv,1:ih,1:jh)) +#endif /* NDIMS == 3 */ + + end select ! associate pinfo with the next block ! - pinfo => block_array(isend,irecv)%ptr + pinfo => pinfo%prev end do ! %ptr blocks - end if ! if block_count > 0 +! 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 + +! scan all blocks on the list +! + do while(associated(pinfo)) + +! increase the block count +! + l = l + 1 + +! associate pmeta pointer +! + pmeta => pinfo%block + +! get neighbor direction and corner indices +! + 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 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) + +! associate pinfo with the first block in the exchange list +! + pinfo => block_array(isend,irecv)%ptr + +! scan all blocks on the exchange list +! + do while(associated(pinfo)) + +! associate the exchange list pointer +! + block_array(isend,irecv)%ptr => pinfo%prev + +! nullify pointer fields +! + nullify(pinfo%prev) + nullify(pinfo%next) + nullify(pinfo%block) + nullify(pinfo%neigh) + +! deallocate info block +! + deallocate(pinfo) + +! associate pinfo with the next block +! + pinfo => block_array(isend,irecv)%ptr + + end do ! %ptr blocks + + end if ! if block_count > 0 end do ! p = 1, npairs #endif /* MPI */ From dace7d29b63e655528481f987e4ba0bf5431cfb3 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Sun, 30 Nov 2014 18:24:24 -0200 Subject: [PATCH 11/19] BOUNDARIES: Fix line alignment in boundary_face_copy(). Signed-off-by: Grzegorz Kowal --- src/boundaries.F90 | 408 ++++++++++++++++++++++----------------------- 1 file changed, 204 insertions(+), 204 deletions(-) diff --git a/src/boundaries.F90 b/src/boundaries.F90 index bc5c670..56c6ed9 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -1503,253 +1503,253 @@ module boundaries #ifdef MPI !! 3. UPDATE VARIABLE BOUNDARIES BETWEEN BLOCKS BELONGING TO DIFFERENT PROCESSES !! -! iterate over all processor pairs +! iterate over all process pairs ! do p = 1, npairs -! get sending and receiving processor identifiers +! get sending and receiving process identifiers ! isend = pairs(p,1) irecv = pairs(p,2) ! process only pairs which have anything to exchange ! - if (block_counter(isend,irecv) > 0) then + if (block_counter(isend,irecv) > 0) then ! obtain the number of blocks to exchange ! - nblocks = block_counter(isend,irecv) + nblocks = block_counter(isend,irecv) ! prepare the tag for communication ! - itag = 16 * (irecv * nprocs + isend) + 2 + itag = 16 * (irecv * nprocs + isend) + 2 ! 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 + 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 + 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) + l = 0 ! 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 +! scan over all blocks on the block exchange list ! do while(associated(pinfo)) -! associate the exchange list pointer with the previous block on the list +! increase the block counter ! - block_array(isend,irecv)%ptr => pinfo%prev + l = l + 1 -! nullify the current pointer fields +! associate pneigh with pinfo%neigh ! - nullify(pinfo%prev) - nullify(pinfo%next) - nullify(pinfo%block) - nullify(pinfo%neigh) + pneigh => pinfo%neigh -! deallocate the object +! get the corner coordinates ! - deallocate(pinfo) + 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 => block_array(isend,irecv)%ptr + pinfo => pinfo%prev end do ! %ptr block list - end if ! if block_count > 0 +! 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 ! p = 1, npairs #endif /* MPI */ From 1658ce5625be7fee027829bddb456f27f1d0897e Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Sun, 30 Nov 2014 18:28:14 -0200 Subject: [PATCH 12/19] BOUNDARIES: Fix line alignment in boundary_face_restrict(). Signed-off-by: Grzegorz Kowal --- src/boundaries.F90 | 408 ++++++++++++++++++++++----------------------- 1 file changed, 204 insertions(+), 204 deletions(-) diff --git a/src/boundaries.F90 b/src/boundaries.F90 index 56c6ed9..97e2c15 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -2056,253 +2056,253 @@ module boundaries #ifdef MPI !! 3. UPDATE VARIABLE BOUNDARIES BETWEEN BLOCKS BELONGING TO DIFFERENT PROCESSES !! -! iterate over all processor pairs +! iterate over all process pairs ! do p = 1, npairs -! get sending and receiving processor identifiers +! get sending and receiving process identifiers ! isend = pairs(p,1) irecv = pairs(p,2) ! process only pairs which have something to exchange ! - if (block_counter(isend,irecv) > 0) then + if (block_counter(isend,irecv) > 0) then ! obtain the number of blocks to exchange ! - nblocks = block_counter(isend,irecv) + nblocks = block_counter(isend,irecv) ! prepare the tag for communication ! - itag = 16 * (irecv * nprocs + isend) + 3 + itag = 16 * (irecv * nprocs + isend) + 3 ! 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 + 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 + 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) + l = 0 ! 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 +! scan over all blocks on the block exchange list ! do while(associated(pinfo)) -! associate the exchange list pointer with the previous block +! increase the block counter ! - block_array(isend,irecv)%ptr => pinfo%prev + l = l + 1 -! nullify the pointer fields +! associate pneigh with pinfo%neigh ! - nullify(pinfo%prev) - nullify(pinfo%next) - nullify(pinfo%block) - nullify(pinfo%neigh) + pneigh => pinfo%neigh -! deallocate the object +! get the corner coordinates ! - deallocate(pinfo) + 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 => block_array(isend,irecv)%ptr + pinfo => pinfo%prev end do ! %ptr block list - end if ! if block_count > 0 +! 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 ! p = 1, npairs #endif /* MPI */ From 654de23d149067b033b30ee4c09552ba677a8584 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Sun, 30 Nov 2014 18:31:27 -0200 Subject: [PATCH 13/19] BOUNDARIES: Fix line alignment in boundary_face_prolong(). Signed-off-by: Grzegorz Kowal --- src/boundaries.F90 | 422 ++++++++++++++++++++++----------------------- 1 file changed, 211 insertions(+), 211 deletions(-) diff --git a/src/boundaries.F90 b/src/boundaries.F90 index 97e2c15..476d6ac 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -2622,260 +2622,260 @@ module boundaries #ifdef MPI !! 3. UPDATE VARIABLE BOUNDARIES BETWEEN BLOCKS BELONGING TO DIFFERENT PROCESSES !! -! iterate over all processor pairs +! iterate over all process pairs ! do p = 1, npairs -! get sending and receiving processor identifiers +! get sending and receiving process identifiers ! isend = pairs(p,1) irecv = pairs(p,2) ! process only pairs which have something to exchange ! - if (block_counter(isend,irecv) > 0) then + if (block_counter(isend,irecv) > 0) then ! obtain the number of blocks to exchange ! - nblocks = block_counter(isend,irecv) + nblocks = block_counter(isend,irecv) ! prepare the tag for communication ! - itag = 16 * (irecv * nprocs + isend) + 4 + itag = 16 * (irecv * nprocs + isend) + 4 ! 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 + 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 + 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) + l = 0 ! 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 +! scan over all blocks on the block exchange list ! do while(associated(pinfo)) -! associate the exchange list pointer +! increase the block counter ! - block_array(isend,irecv)%ptr => pinfo%prev + l = l + 1 -! nullify the pointer fields +! prepare pointer for updated meta block and its neighbor ! - nullify(pinfo%prev) - nullify(pinfo%next) - nullify(pinfo%block) - nullify(pinfo%neigh) + pmeta => pinfo%block + pneigh => pinfo%neigh -! deallocate the object +! get the corner coordinates ! - deallocate(pinfo) + 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 => block_array(isend,irecv)%ptr + pinfo => pinfo%prev end do ! %ptr block list - end if ! if block_count > 0 +! 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 ! p = 1, npairs #endif /* MPI */ From 0dad5bcf1e6f361b54ab955eb1d6d5940645e3c1 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Sun, 30 Nov 2014 18:34:54 -0200 Subject: [PATCH 14/19] BOUNDARIES: Fix line alignment in boundary_edge_copy(). Signed-off-by: Grzegorz Kowal --- src/boundaries.F90 | 452 ++++++++++++++++++++++----------------------- 1 file changed, 226 insertions(+), 226 deletions(-) diff --git a/src/boundaries.F90 b/src/boundaries.F90 index 476d6ac..65e87cf 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -3192,279 +3192,279 @@ module boundaries #ifdef MPI !! 3. UPDATE VARIABLE BOUNDARIES BETWEEN BLOCKS BELONGING TO DIFFERENT PROCESSES !! -! iterate over all processor pairs +! iterate over all process pairs ! do p = 1, npairs -! get sending and receiving processor identifiers +! get sending and receiving process identifiers ! isend = pairs(p,1) irecv = pairs(p,2) ! process only pairs which have something to exchange ! - if (block_counter(isend,irecv) > 0) then + if (block_counter(isend,irecv) > 0) then ! obtain the number of blocks to exchange ! - nblocks = block_counter(isend,irecv) + nblocks = block_counter(isend,irecv) ! prepare the tag for communication ! - itag = 16 * (irecv * nprocs + isend) + 5 + itag = 16 * (irecv * nprocs + isend) + 5 ! allocate data buffer for variables to exchange ! - select case(idir) + select case(idir) #if NDIMS == 2 - case(1) - allocate(rbuf(nblocks,nv,ih,ng,km)) - case(2) - allocate(rbuf(nblocks,nv,ng,jh,km)) + 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)) + 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 + end select ! if isend == nproc we are sending data from the neighbor block ! - if (isend == nproc) then + 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) + 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 exchange block list +! scan over all blocks on the block exchange list ! do while(associated(pinfo)) -! associate the exchange list pointer +! increase the block counter ! - block_array(isend,irecv)%ptr => pinfo%prev + l = l + 1 -! nullify the pointer fields +! assign pneigh to the associated neighbor block ! - nullify(pinfo%prev) - nullify(pinfo%next) - nullify(pinfo%block) - nullify(pinfo%neigh) + pneigh => pinfo%neigh -! deallocate the object +! get the corner coordinates ! - deallocate(pinfo) + 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 => block_array(isend,irecv)%ptr + pinfo => pinfo%prev end do ! %ptr block list - end if ! if block_count > 0 +! 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 ! p = 1, npairs #endif /* MPI */ From 96c3cda82bc696611fbe459d3abadb3f51559298 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Sun, 30 Nov 2014 18:38:16 -0200 Subject: [PATCH 15/19] BOUNDARIES: Fix line alignment in boundary_edge_restrict(). Signed-off-by: Grzegorz Kowal --- src/boundaries.F90 | 452 ++++++++++++++++++++++----------------------- 1 file changed, 226 insertions(+), 226 deletions(-) diff --git a/src/boundaries.F90 b/src/boundaries.F90 index 65e87cf..0831d8e 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -3774,279 +3774,279 @@ module boundaries #ifdef MPI !! 3. UPDATE VARIABLE BOUNDARIES BETWEEN BLOCKS BELONGING TO DIFFERENT PROCESSES !! -! iterate over all processor pairs +! iterate over all process pairs ! do p = 1, npairs -! get sending and receiving processor identifiers +! get sending and receiving process identifiers ! isend = pairs(p,1) irecv = pairs(p,2) ! process only pairs which have something to exchange ! - if (block_counter(isend,irecv) > 0) then + if (block_counter(isend,irecv) > 0) then ! obtain the number of blocks to exchange ! - nblocks = block_counter(isend,irecv) + nblocks = block_counter(isend,irecv) ! prepare the tag for communication ! - itag = 16 * (irecv * nprocs + isend) + 6 + itag = 16 * (irecv * nprocs + isend) + 6 ! allocate data buffer for variables to exchange ! - select case(idir) + select case(idir) #if NDIMS == 2 - case(1) - allocate(rbuf(nblocks,nv,ih,ng,km)) - case(2) - allocate(rbuf(nblocks,nv,ng,jh,km)) + 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)) + 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 + end select ! if isend == nproc we are sending data from the neighbor block ! - if (isend == nproc) then + 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) + 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 exchange block list +! scan over all blocks on the block exchange list ! do while(associated(pinfo)) -! associate the exchange list pointer +! increase the block counter ! - block_array(isend,irecv)%ptr => pinfo%prev + l = l + 1 -! nullify the pointer fields +! assign pneigh to the associated neighbor block ! - nullify(pinfo%prev) - nullify(pinfo%next) - nullify(pinfo%block) - nullify(pinfo%neigh) + pneigh => pinfo%neigh -! deallocate the object +! get the corner coordinates ! - deallocate(pinfo) + 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 => block_array(isend,irecv)%ptr + pinfo => pinfo%prev end do ! %ptr block list - end if ! if block_count > 0 +! 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 ! p = 1, npairs #endif /* MPI */ From 59540cc3bd1c181ebd95c8e2ea108a69e6c8dd51 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Sun, 30 Nov 2014 18:41:37 -0200 Subject: [PATCH 16/19] BOUNDARIES: Fix line alignment in boundary_edge_prolong(). Signed-off-by: Grzegorz Kowal --- src/boundaries.F90 | 460 ++++++++++++++++++++++----------------------- 1 file changed, 230 insertions(+), 230 deletions(-) diff --git a/src/boundaries.F90 b/src/boundaries.F90 index 0831d8e..8158e10 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -4363,283 +4363,283 @@ module boundaries #ifdef MPI !! 3. UPDATE VARIABLE BOUNDARIES BETWEEN BLOCKS BELONGING TO DIFFERENT PROCESSES !! -! iterate over all processor pairs +! iterate over all process pairs ! do p = 1, npairs -! get sending and receiving processor identifiers +! get sending and receiving process identifiers ! isend = pairs(p,1) irecv = pairs(p,2) ! process only pairs which have something to exchange ! - if (block_counter(isend,irecv) > 0) then + if (block_counter(isend,irecv) > 0) then ! obtain the number of blocks to exchange ! - nblocks = block_counter(isend,irecv) + nblocks = block_counter(isend,irecv) ! prepare the tag for communication ! - itag = 16 * (irecv * nprocs + isend) + 7 + itag = 16 * (irecv * nprocs + isend) + 7 ! allocate data buffer for variables to exchange ! - select case(idir) + select case(idir) #if NDIMS == 2 - case(1) - allocate(rbuf(nblocks,nv,ih,ng,km)) - case(2) - allocate(rbuf(nblocks,nv,ng,jh,km)) + 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)) + 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 + end select ! if isend == nproc we are sending data from the neighbor block ! - if (isend == nproc) then + 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) + 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 exchange block list +! scan over all blocks on the block exchange list ! do while(associated(pinfo)) -! associate the exchange list pointer +! increase the block counter ! - block_array(isend,irecv)%ptr => pinfo%prev + l = l + 1 -! nullify the pointer fields +! assign pmeta and pneigh to the associated blocks ! - nullify(pinfo%prev) - nullify(pinfo%next) - nullify(pinfo%block) - nullify(pinfo%neigh) + pmeta => pinfo%block + pneigh => pinfo%neigh -! deallocate the object +! get the corner coordinates ! - deallocate(pinfo) + 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 => block_array(isend,irecv)%ptr + pinfo => pinfo%prev end do ! %ptr block list - end if ! if block_count > 0 +! 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 ! p = 1, npairs #endif /* MPI */ From 89dc5971502ef2782855e04694015263e85397b4 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Sun, 30 Nov 2014 18:44:04 -0200 Subject: [PATCH 17/19] BOUNDARIES: Fix line alignment in boundary_corner_copy(). Signed-off-by: Grzegorz Kowal --- src/boundaries.F90 | 218 ++++++++++++++++++++++----------------------- 1 file changed, 109 insertions(+), 109 deletions(-) diff --git a/src/boundaries.F90 b/src/boundaries.F90 index 8158e10..1b9891a 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -4907,209 +4907,209 @@ module boundaries #ifdef MPI !! 3. UPDATE VARIABLE BOUNDARIES BETWEEN BLOCKS BELONGING TO DIFFERENT PROCESSES !! -! iterate over all processor pairs +! iterate over all process pairs ! do p = 1, npairs -! get sending and receiving processor identifiers +! get sending and receiving process identifiers ! isend = pairs(p,1) irecv = pairs(p,2) ! process only pairs which have something to exchange ! - if (block_counter(isend,irecv) > 0) then + if (block_counter(isend,irecv) > 0) then ! obtain the number of blocks to exchange ! - nblocks = block_counter(isend,irecv) + nblocks = block_counter(isend,irecv) ! prepare the tag for communication ! - itag = 16 * (irecv * nprocs + isend) + 8 + itag = 16 * (irecv * nprocs + isend) + 8 ! allocate data buffer for variables to exchange ! #if NDIMS == 2 - allocate(rbuf(nblocks,nv,ng,ng,km)) + allocate(rbuf(nblocks,nv,ng,ng,km)) #endif /* NDIMS == 2 */ #if NDIMS == 3 - allocate(rbuf(nblocks,nv,ng,ng,ng)) + 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 + if (isend == nproc) then ! reset the block counter ! - l = 0 + l = 0 ! associate the pointer with the first block in the exchange list ! - pinfo => block_array(isend,irecv)%ptr + pinfo => block_array(isend,irecv)%ptr ! scan over all blocks on the block exchange list ! - do while(associated(pinfo)) + do while(associated(pinfo)) ! increase the block counter ! - l = l + 1 + l = l + 1 ! assign pneigh to the associated neighbor block ! - pneigh => pinfo%neigh + pneigh => pinfo%neigh ! get the corner coordinates ! - i = pinfo%corner(1) - j = pinfo%corner(2) + i = pinfo%corner(1) + j = pinfo%corner(2) #if NDIMS == 3 - k = pinfo%corner(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 & + 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 & + 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 + pinfo => pinfo%prev - end do ! %ptr block list + end do ! %ptr block list ! send the data buffer to another process ! - call send_real_array(size(rbuf), irecv, itag, rbuf(:,:,:,:,:), iret) + call send_real_array(size(rbuf), irecv, itag, rbuf(:,:,:,:,:), iret) - end if ! isend = nproc + end if ! isend = nproc ! if irecv == nproc we are receiving data from the neighbor block ! - if (irecv == nproc) then + if (irecv == nproc) then ! receive the data buffer ! - call receive_real_array(size(rbuf(:,:,:,:,:)), isend, itag & + 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) + 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 exchange block list +! iterate over all received blocks and update boundaries of the corresponding +! data blocks ! do while(associated(pinfo)) -! associate the exchange list pointer +! increase the block counter ! - block_array(isend,irecv)%ptr => pinfo%prev + l = l + 1 -! nullify the pointer fields +! assign a pointer to the associated data block ! - nullify(pinfo%prev) - nullify(pinfo%next) - nullify(pinfo%block) - nullify(pinfo%neigh) + pmeta => pinfo%block -! deallocate the object +! get the corner coordinates ! - deallocate(pinfo) + 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 => block_array(isend,irecv)%ptr + pinfo => pinfo%prev end do ! %ptr block list - end if ! if block_count > 0 + 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 ! p = 1, npairs #endif /* MPI */ From fde758acb04a29d1cf85ec530cc23c07fc311b2a Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Sun, 30 Nov 2014 18:46:11 -0200 Subject: [PATCH 18/19] BOUNDARIES: Fix line alignment in boundary_corner_restrict(). Signed-off-by: Grzegorz Kowal --- src/boundaries.F90 | 218 ++++++++++++++++++++++----------------------- 1 file changed, 109 insertions(+), 109 deletions(-) diff --git a/src/boundaries.F90 b/src/boundaries.F90 index 1b9891a..de7624f 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -5370,209 +5370,209 @@ module boundaries #ifdef MPI !! 3. UPDATE VARIABLE BOUNDARIES BETWEEN BLOCKS BELONGING TO DIFFERENT PROCESSES !! -! iterate over all processor pairs +! iterate over all process pairs ! do p = 1, npairs -! get sending and receiving processor identifiers +! get sending and receiving process identifiers ! isend = pairs(p,1) irecv = pairs(p,2) ! process only pairs which have something to exchange ! - if (block_counter(isend,irecv) > 0) then + if (block_counter(isend,irecv) > 0) then ! obtain the number of blocks to exchange ! - nblocks = block_counter(isend,irecv) + nblocks = block_counter(isend,irecv) ! prepare the tag for communication ! - itag = 16 * (irecv * nprocs + isend) + 9 + itag = 16 * (irecv * nprocs + isend) + 9 ! allocate data buffer for variables to exchange ! #if NDIMS == 2 - allocate(rbuf(nblocks,nv,ng,ng,km)) + allocate(rbuf(nblocks,nv,ng,ng,km)) #endif /* NDIMS == 2 */ #if NDIMS == 3 - allocate(rbuf(nblocks,nv,ng,ng,ng)) + 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 + if (isend == nproc) then ! reset the block counter ! - l = 0 + l = 0 ! associate the pointer with the first block in the exchange list ! - pinfo => block_array(isend,irecv)%ptr + pinfo => block_array(isend,irecv)%ptr ! scan over all blocks on the block exchange list ! - do while(associated(pinfo)) + do while(associated(pinfo)) ! increase the block counter ! - l = l + 1 + l = l + 1 ! assign pneigh to the associated neighbor block ! - pneigh => pinfo%neigh + pneigh => pinfo%neigh ! get the corner coordinates ! - i = pinfo%corner(1) - j = pinfo%corner(2) + i = pinfo%corner(1) + j = pinfo%corner(2) #if NDIMS == 3 - k = pinfo%corner(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 & + 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 & + 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 + pinfo => pinfo%prev - end do ! %ptr block list + end do ! %ptr block list ! send the data buffer to another process ! - call send_real_array(size(rbuf), irecv, itag, rbuf(:,:,:,:,:), iret) + call send_real_array(size(rbuf), irecv, itag, rbuf(:,:,:,:,:), iret) - end if ! isend = nproc + end if ! isend = nproc ! if irecv == nproc we are receiving data from the neighbor block ! - if (irecv == nproc) then + if (irecv == nproc) then ! receive the data buffer ! - call receive_real_array(size(rbuf(:,:,:,:,:)), isend, itag & + 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) + 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 exchange block list +! iterate over all received blocks and update boundaries of the corresponding +! data blocks ! do while(associated(pinfo)) -! associate the exchange list pointer +! increase the block counter ! - block_array(isend,irecv)%ptr => pinfo%prev + l = l + 1 -! nullify the pointer fields +! assign a pointer to the associated data block ! - nullify(pinfo%prev) - nullify(pinfo%next) - nullify(pinfo%block) - nullify(pinfo%neigh) + pmeta => pinfo%block -! deallocate the object +! get the corner coordinates ! - deallocate(pinfo) + 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 => block_array(isend,irecv)%ptr + pinfo => pinfo%prev end do ! %ptr block list - end if ! if block_count > 0 + 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 ! p = 1, npairs #endif /* MPI */ From 53abe5d5f3c9a44e03b8e5a2b87ff22d99253152 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Sun, 30 Nov 2014 18:48:45 -0200 Subject: [PATCH 19/19] BOUNDARIES: Fix line alignment in boundary_corner_prolong(). Signed-off-by: Grzegorz Kowal --- src/boundaries.F90 | 218 ++++++++++++++++++++++----------------------- 1 file changed, 109 insertions(+), 109 deletions(-) diff --git a/src/boundaries.F90 b/src/boundaries.F90 index de7624f..1ae5807 100644 --- a/src/boundaries.F90 +++ b/src/boundaries.F90 @@ -5833,209 +5833,209 @@ module boundaries #ifdef MPI !! 3. UPDATE VARIABLE BOUNDARIES BETWEEN BLOCKS BELONGING TO DIFFERENT PROCESSES !! -! iterate over all processor pairs +! iterate over all process pairs ! do p = 1, npairs -! get sending and receiving processor identifiers +! get sending and receiving process identifiers ! isend = pairs(p,1) irecv = pairs(p,2) ! process only pairs which have something to exchange ! - if (block_counter(isend,irecv) > 0) then + if (block_counter(isend,irecv) > 0) then ! obtain the number of blocks to exchange ! - nblocks = block_counter(isend,irecv) + nblocks = block_counter(isend,irecv) ! prepare the tag for communication ! - itag = 16 * (irecv * nprocs + isend) + 10 + itag = 16 * (irecv * nprocs + isend) + 10 ! allocate data buffer for variables to exchange ! #if NDIMS == 2 - allocate(rbuf(nblocks,nv,ng,ng,km)) + allocate(rbuf(nblocks,nv,ng,ng,km)) #endif /* NDIMS == 2 */ #if NDIMS == 3 - allocate(rbuf(nblocks,nv,ng,ng,ng)) + 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 + if (isend == nproc) then ! reset the block counter ! - l = 0 + l = 0 ! associate the pointer with the first block in the exchange list ! - pinfo => block_array(isend,irecv)%ptr + pinfo => block_array(isend,irecv)%ptr ! scan over all blocks on the block exchange list ! - do while(associated(pinfo)) + do while(associated(pinfo)) ! increase the block counter ! - l = l + 1 + l = l + 1 ! assign pneigh to the associated neighbor block ! - pneigh => pinfo%neigh + pneigh => pinfo%neigh ! get the corner coordinates ! - i = pinfo%corner(1) - j = pinfo%corner(2) + i = pinfo%corner(1) + j = pinfo%corner(2) #if NDIMS == 3 - k = pinfo%corner(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 & + 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 & + 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 + pinfo => pinfo%prev - end do ! %ptr block list + end do ! %ptr block list ! send the data buffer to another process ! - call send_real_array(size(rbuf), irecv, itag, rbuf(:,:,:,:,:), iret) + call send_real_array(size(rbuf), irecv, itag, rbuf(:,:,:,:,:), iret) - end if ! isend = nproc + end if ! isend = nproc ! if irecv == nproc we are receiving data from the neighbor block ! - if (irecv == nproc) then + if (irecv == nproc) then ! receive the data buffer ! - call receive_real_array(size(rbuf(:,:,:,:,:)), isend, itag & + 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) + 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 exchange block list +! iterate over all received blocks and update boundaries of the corresponding +! data blocks ! do while(associated(pinfo)) -! associate the exchange list pointer +! increase the block counter ! - block_array(isend,irecv)%ptr => pinfo%prev + l = l + 1 -! nullify the pointer fields +! assign a pointer to the associated data block ! - nullify(pinfo%prev) - nullify(pinfo%next) - nullify(pinfo%block) - nullify(pinfo%neigh) + pmeta => pinfo%block -! deallocate the object +! get the corner coordinates ! - deallocate(pinfo) + 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 => block_array(isend,irecv)%ptr + pinfo => pinfo%prev end do ! %ptr block list - end if ! if block_count > 0 + 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 ! p = 1, npairs #endif /* MPI */