diff options
| author | Erik Schnetter <schnetter@cct.lsu.edu> | 2007-01-12 20:58:00 +0000 |
|---|---|---|
| committer | Erik Schnetter <schnetter@cct.lsu.edu> | 2007-01-12 20:58:00 +0000 |
| commit | c23315efb5b4fea80c92f747173e47a7d29d644d (patch) | |
| tree | d56de98cca60845ae083fe3d397843dda6102160 | |
| parent | 3c4993dd3e36426d62cbf8e574cba9ec6cf2ec89 (diff) | |
CarpetLib: Reorganise prolongation and restriction operators
Reorganise prolongation and restriction operators. This is a major
implementation change.
Most operators are now written as C++ templates instead of as Fortran
77 code. This simplifies the code, since C++ routines can be called
more easily, and they also have access to CarpetLib's high-level data
structures.
Previously, the operators combined temporal and spatial interpolation.
Now, time interpolation and space interpolation are handled
separately. This may be less efficient, but simplifies the code
significantly, since there are now N+M instead of N*M routines, for N
time interpolation and M space interpolation methods.
Remove the minmod prolongation operator, which was previously
disabled.
Add support for cell centering, using a method described by Simon
Hern, and suggested for Carpet by Ian Hawke.
darcs-hash:20070112205812-dae7b-5329795aa698e7bbc3671b1504134885dd830238.gz
59 files changed, 3753 insertions, 18206 deletions
diff --git a/Carpet/CarpetLib/param.ccl b/Carpet/CarpetLib/param.ccl index 8d736ed3f..a3000fe74 100644 --- a/Carpet/CarpetLib/param.ccl +++ b/Carpet/CarpetLib/param.ccl @@ -6,10 +6,6 @@ BOOLEAN verbose "Print info to the screen" STEERABLE=always { } "no" -BOOLEAN check_array_accesses "Check all array accesses in Fortran" STEERABLE=always -{ -} "no" - BOOLEAN barriers "Insert barriers at strategic places for debugging purposes (slows down execution)" STEERABLE=always { } "no" diff --git a/Carpet/CarpetLib/src/checkindex.c b/Carpet/CarpetLib/src/checkindex.c deleted file mode 100644 index 8127251f9..000000000 --- a/Carpet/CarpetLib/src/checkindex.c +++ /dev/null @@ -1,32 +0,0 @@ -#include <assert.h> -#include <string.h> - -#include <cctk.h> - - - -void -CCTK_FCALL -CCTK_FNAME(checkindex) (int const * restrict const i, - int const * restrict const j, - int const * restrict const k, - int const * restrict const di, - int const * restrict const dj, - int const * restrict const dk, - int const * restrict const imax, - int const * restrict const jmax, - int const * restrict const kmax, - ONE_FORTSTRING_ARG) -{ - if (*i < 1 || *i+*di-1 > *imax || - *j < 1 || *j+*dj-1 > *jmax || - *k < 1 || *k+*dk-1 > *kmax) - { - ONE_FORTSTRING_CREATE (where); - CCTK_VWarn (1, __LINE__, __FILE__, CCTK_THORNSTRING, - "%s array index out of bounds: shape is (%d,%d,%d), index is (%d,%d,%d), extent is (%d,%d,%d)", - where, *imax,*jmax,*kmax, *i,*j,*k, *di,*dj,*dk); - assert (0); - free (where); - } -} diff --git a/Carpet/CarpetLib/src/copy_3d.cc b/Carpet/CarpetLib/src/copy_3d.cc new file mode 100644 index 000000000..3fa7dd872 --- /dev/null +++ b/Carpet/CarpetLib/src/copy_3d.cc @@ -0,0 +1,176 @@ +#include <algorithm> +#include <cassert> +#include <cmath> +#include <cstdlib> + +#include <cctk.h> +#include <cctk_Parameters.h> + +#include "operator_prototypes.hh" +#include "typeprops.hh" + +using namespace std; + + + +namespace CarpetLib { + + + +#define SRCIND3(i,j,k) \ + index3 (srcioff + (i), srcjoff + (j), srckoff + (k), \ + srciext, srcjext, srckext) +#define DSTIND3(i,j,k) \ + index3 (dstioff + (i), dstjoff + (j), dstkoff + (k), \ + dstiext, dstjext, dstkext) + + + + template <typename T> + void + copy_3d (T const * restrict const src, + ivect3 const & srcext, + T * restrict const dst, + ivect3 const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox) + { +#if 0 + // This is already guaranteed by bbox + if (any (srcbbox.stride() == 0 or + dstbbox.stride() == 0 or + regbbox.stride() == 0)) + { + CCTK_WARN (0, "Internal error: stride is zero"); + } +#endif + + if (any (srcbbox.stride() != regbbox.stride() or + dstbbox.stride() != regbbox.stride())) + { + CCTK_WARN (0, "Internal error: strides disagree"); + } + + if (any (srcbbox.stride() != dstbbox.stride())) { + CCTK_WARN (0, "Internal error: strides disagree"); + } + +#if 0 + // This needs to be allowed for cell centring + if (any (srcbbox.lower() % srcbbox.stride() != 0 or + dstbbox.lower() % dstbbox.stride() != 0 or + regbbox.lower() % regbbox.stride() != 0)) + { + CCTK_WARN (0, "Internal error: array origins are not integer multiples of the strides"); + } +#endif + + // This could be handled, but is likely to point to an error + // elsewhere + if (regbbox.empty()) { + CCTK_WARN (0, "Internal error: region extent is empty"); + } + +#if 0 + // This is already guaranteed by bbox + if (any ((srcbbox.upper() - srcbbox.lower()) % srcbbox.stride() != 0 or + (dstbbox.upper() - dstbbox.lower()) % dstbbox.stride() != 0 or + (regbbox.upper() - regbbox.lower()) % regbbox.stride() != 0)) + { + CCTK_WARN (0, "Internal error: array extents are not integer multiples of the strides"); + } +#endif + + if (not regbbox.is_contained_in(srcbbox) or + not regbbox.is_contained_in(dstbbox)) + { + CCTK_WARN (0, "Internal error: region extent is not contained in array extent"); + } + + if (any (srcext != srcbbox.shape() / srcbbox.stride() or + dstext != dstbbox.shape() / dstbbox.stride())) + { + CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes"); + } + + + + ivect3 const regext = regbbox.shape() / regbbox.stride(); + assert (all ((regbbox.lower() - srcbbox.lower()) % srcbbox.stride() == 0)); + ivect3 const srcoff = (regbbox.lower() - srcbbox.lower()) / srcbbox.stride(); + assert (all ((regbbox.lower() - dstbbox.lower()) % dstbbox.stride() == 0)); + ivect3 const dstoff = (regbbox.lower() - dstbbox.lower()) / dstbbox.stride(); + + + + size_t const srciext = srcext[0]; + size_t const srcjext = srcext[1]; + size_t const srckext = srcext[2]; + + size_t const dstiext = dstext[0]; + size_t const dstjext = dstext[1]; + size_t const dstkext = dstext[2]; + + size_t const regiext = regext[0]; + size_t const regjext = regext[1]; + size_t const regkext = regext[2]; + + size_t const srcioff = srcoff[0]; + size_t const srcjoff = srcoff[1]; + size_t const srckoff = srcoff[2]; + + size_t const dstioff = dstoff[0]; + size_t const dstjoff = dstoff[1]; + size_t const dstkoff = dstoff[2]; + + + + // Loop over region + for (size_t k=0; k<regkext; ++k) { + for (size_t j=0; j<regjext; ++j) { + for (size_t i=0; i<regiext; ++i) { + + dst [DSTIND3(i, j, k)] = src [SRCIND3(i, j, k)]; + + } + } + } + + } + + + + template + void + copy_3d (CCTK_INT const * restrict const src, + ivect3 const & srcext, + CCTK_INT * restrict const dst, + ivect3 const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox); + + template + void + copy_3d (CCTK_REAL const * restrict const src, + ivect3 const & srcext, + CCTK_REAL * restrict const dst, + ivect3 const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox); + + template + void + copy_3d (CCTK_COMPLEX const * restrict const src, + ivect3 const & srcext, + CCTK_COMPLEX * restrict const dst, + ivect3 const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox); + + + +} // namespace CarpetLib diff --git a/Carpet/CarpetLib/src/copy_3d_complex16.F77 b/Carpet/CarpetLib/src/copy_3d_complex16.F77 deleted file mode 100644 index 0372b4579..000000000 --- a/Carpet/CarpetLib/src/copy_3d_complex16.F77 +++ /dev/null @@ -1,113 +0,0 @@ -c -*-Fortran-*- - -#include "cctk.h" -#include "cctk_Parameters.h" - - - - subroutine copy_3d_complex16 ( - $ src, srciext, srcjext, srckext, - $ dst, dstiext, dstjext, dstkext, - $ srcbbox, dstbbox, regbbox) - - implicit none - - DECLARE_CCTK_PARAMETERS - - integer srciext, srcjext, srckext - CCTK_COMPLEX16 src(srciext,srcjext,srckext) - integer dstiext, dstjext, dstkext - CCTK_COMPLEX16 dst(dstiext,dstjext,dstkext) -c bbox(:,1) is lower boundary (inclusive) -c bbox(:,2) is upper boundary (inclusive) -c bbox(:,3) is stride - integer srcbbox(3,3), dstbbox(3,3), regbbox(3,3) - - integer regiext, regjext, regkext - - integer srcioff, srcjoff, srckoff - integer dstioff, dstjoff, dstkoff - - integer i, j, k - integer d - - - - do d=1,3 - if (srcbbox(d,3).eq.0 .or. dstbbox(d,3).eq.0 - $ .or. regbbox(d,3).eq.0) then - call CCTK_WARN (0, "Internal error: stride is zero") - end if - if (srcbbox(d,3).ne.regbbox(d,3) - $ .or. dstbbox(d,3).ne.regbbox(d,3)) then - call CCTK_WARN (0, "Internal error: strides disagree") - end if - if (mod(srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array origins are not integer multiples of the strides") - end if - if (regbbox(d,1).gt.regbbox(d,2)) then -c This could be handled, but is likely to point to an error elsewhere - call CCTK_WARN (0, "Internal error: region extent is empty") - end if - if (mod(srcbbox(d,2) - srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,2) - dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,2) - regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array extents are not integer multiples of the strides") - end if - if (regbbox(d,1).lt.srcbbox(d,1) - $ .or. regbbox(d,1).lt.dstbbox(d,1) - $ .or. regbbox(d,2).gt.srcbbox(d,2) - $ .or. regbbox(d,2).gt.dstbbox(d,2)) then - call CCTK_WARN (0, "Internal error: region extent is not contained in array extent") - end if - end do - - if (srciext.ne.(srcbbox(1,2)-srcbbox(1,1))/srcbbox(1,3)+1 - $ .or. srcjext.ne.(srcbbox(2,2)-srcbbox(2,1))/srcbbox(2,3)+1 - $ .or. srckext.ne.(srcbbox(3,2)-srcbbox(3,1))/srcbbox(3,3)+1 - $ .or. dstiext.ne.(dstbbox(1,2)-dstbbox(1,1))/dstbbox(1,3)+1 - $ .or. dstjext.ne.(dstbbox(2,2)-dstbbox(2,1))/dstbbox(2,3)+1 - $ .or. dstkext.ne.(dstbbox(3,2)-dstbbox(3,1))/dstbbox(3,3)+1) then - call CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes") - end if - - - - regiext = (regbbox(1,2) - regbbox(1,1)) / regbbox(1,3) + 1 - regjext = (regbbox(2,2) - regbbox(2,1)) / regbbox(2,3) + 1 - regkext = (regbbox(3,2) - regbbox(3,1)) / regbbox(3,3) + 1 - - srcioff = (regbbox(1,1) - srcbbox(1,1)) / srcbbox(1,3) - srcjoff = (regbbox(2,1) - srcbbox(2,1)) / srcbbox(2,3) - srckoff = (regbbox(3,1) - srcbbox(3,1)) / srcbbox(3,3) - - dstioff = (regbbox(1,1) - dstbbox(1,1)) / dstbbox(1,3) - dstjoff = (regbbox(2,1) - dstbbox(2,1)) / dstbbox(2,3) - dstkoff = (regbbox(3,1) - dstbbox(3,1)) / dstbbox(3,3) - - - -c Loop over region - do k = 1, regkext - do j = 1, regjext - do i = 1, regiext - - if (check_array_accesses.ne.0) then - call checkindex (srcioff+i, srcjoff+j, srckoff+k, 1,1,1, - $ srciext, srcjext, srckext, - $ "source") - call checkindex (dstioff+i, dstjoff+j, dstkoff+k, 1,1,1, - $ dstiext, dstjext, dstkext, - $ "destination") - end if - - dst (dstioff+i, dstjoff+j, dstkoff+k) - $ = src (srcioff+i, srcjoff+j, srckoff+k) - - end do - end do - end do - - end diff --git a/Carpet/CarpetLib/src/copy_3d_int4.F77 b/Carpet/CarpetLib/src/copy_3d_int4.F77 deleted file mode 100644 index e91ef93a9..000000000 --- a/Carpet/CarpetLib/src/copy_3d_int4.F77 +++ /dev/null @@ -1,113 +0,0 @@ -c -*-Fortran-*- - -#include "cctk.h" -#include "cctk_Parameters.h" - - - - subroutine copy_3d_int4 ( - $ src, srciext, srcjext, srckext, - $ dst, dstiext, dstjext, dstkext, - $ srcbbox, dstbbox, regbbox) - - implicit none - - DECLARE_CCTK_PARAMETERS - - integer srciext, srcjext, srckext - CCTK_INT4 src(srciext,srcjext,srckext) - integer dstiext, dstjext, dstkext - CCTK_INT4 dst(dstiext,dstjext,dstkext) -c bbox(:,1) is lower boundary (inclusive) -c bbox(:,2) is upper boundary (inclusive) -c bbox(:,3) is stride - integer srcbbox(3,3), dstbbox(3,3), regbbox(3,3) - - integer regiext, regjext, regkext - - integer srcioff, srcjoff, srckoff - integer dstioff, dstjoff, dstkoff - - integer i, j, k - integer d - - - - do d=1,3 - if (srcbbox(d,3).eq.0 .or. dstbbox(d,3).eq.0 - $ .or. regbbox(d,3).eq.0) then - call CCTK_WARN (0, "Internal error: stride is zero") - end if - if (srcbbox(d,3).ne.regbbox(d,3) - $ .or. dstbbox(d,3).ne.regbbox(d,3)) then - call CCTK_WARN (0, "Internal error: strides disagree") - end if - if (mod(srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array origins are not integer multiples of the strides") - end if - if (regbbox(d,1).gt.regbbox(d,2)) then -c This could be handled, but is likely to point to an error elsewhere - call CCTK_WARN (0, "Internal error: region extent is empty") - end if - if (mod(srcbbox(d,2) - srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,2) - dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,2) - regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array extents are not integer multiples of the strides") - end if - if (regbbox(d,1).lt.srcbbox(d,1) - $ .or. regbbox(d,1).lt.dstbbox(d,1) - $ .or. regbbox(d,2).gt.srcbbox(d,2) - $ .or. regbbox(d,2).gt.dstbbox(d,2)) then - call CCTK_WARN (0, "Internal error: region extent is not contained in array extent") - end if - end do - - if (srciext.ne.(srcbbox(1,2)-srcbbox(1,1))/srcbbox(1,3)+1 - $ .or. srcjext.ne.(srcbbox(2,2)-srcbbox(2,1))/srcbbox(2,3)+1 - $ .or. srckext.ne.(srcbbox(3,2)-srcbbox(3,1))/srcbbox(3,3)+1 - $ .or. dstiext.ne.(dstbbox(1,2)-dstbbox(1,1))/dstbbox(1,3)+1 - $ .or. dstjext.ne.(dstbbox(2,2)-dstbbox(2,1))/dstbbox(2,3)+1 - $ .or. dstkext.ne.(dstbbox(3,2)-dstbbox(3,1))/dstbbox(3,3)+1) then - call CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes") - end if - - - - regiext = (regbbox(1,2) - regbbox(1,1)) / regbbox(1,3) + 1 - regjext = (regbbox(2,2) - regbbox(2,1)) / regbbox(2,3) + 1 - regkext = (regbbox(3,2) - regbbox(3,1)) / regbbox(3,3) + 1 - - srcioff = (regbbox(1,1) - srcbbox(1,1)) / srcbbox(1,3) - srcjoff = (regbbox(2,1) - srcbbox(2,1)) / srcbbox(2,3) - srckoff = (regbbox(3,1) - srcbbox(3,1)) / srcbbox(3,3) - - dstioff = (regbbox(1,1) - dstbbox(1,1)) / dstbbox(1,3) - dstjoff = (regbbox(2,1) - dstbbox(2,1)) / dstbbox(2,3) - dstkoff = (regbbox(3,1) - dstbbox(3,1)) / dstbbox(3,3) - - - -c Loop over region - do k = 1, regkext - do j = 1, regjext - do i = 1, regiext - - if (check_array_accesses.ne.0) then - call checkindex (srcioff+i, srcjoff+j, srckoff+k, 1,1,1, - $ srciext, srcjext, srckext, - $ "source") - call checkindex (dstioff+i, dstjoff+j, dstkoff+k, 1,1,1, - $ dstiext, dstjext, dstkext, - $ "destination") - end if - - dst (dstioff+i, dstjoff+j, dstkoff+k) - $ = src (srcioff+i, srcjoff+j, srckoff+k) - - end do - end do - end do - - end diff --git a/Carpet/CarpetLib/src/copy_3d_real8.F77 b/Carpet/CarpetLib/src/copy_3d_real8.F77 deleted file mode 100644 index 535c1aab9..000000000 --- a/Carpet/CarpetLib/src/copy_3d_real8.F77 +++ /dev/null @@ -1,140 +0,0 @@ -/** - * @file copy_3d_real8.F77 - * @brief Copy a region of a CCTK_REAL8 array - * - * copy, bla, bla - */ - -/* -*-Fortran-*- */ - -#include "cctk.h" -#include "cctk_Parameters.h" - - - -/** Copy a region of a CCTK_REAL8 array - * - * copy, bla, bla, long description. - */ -#ifdef FOR_DOXYGEN_ONLY -subroutine copy_3d_real8 (CCTK_REAL8 src(srciext,srcjext,srckext), - integer srciext, - integer srcjext, - integer srckext, - CCTK_REAL8 dst(dstiext,dstjext,dstkext), - integer dstiext, - integer dstjext, - integer dstkext, - integer srcbbox, - integer dstbbox, - integer regbbox) -{ -} -#else - subroutine copy_3d_real8 ( - $ src, srciext, srcjext, srckext, - $ dst, dstiext, dstjext, dstkext, - $ srcbbox, dstbbox, regbbox) - - implicit none - - DECLARE_CCTK_PARAMETERS - - integer srciext, srcjext, srckext - CCTK_REAL8 src(srciext,srcjext,srckext) - integer dstiext, dstjext, dstkext - CCTK_REAL8 dst(dstiext,dstjext,dstkext) -c bbox(:,1) is lower boundary (inclusive) -c bbox(:,2) is upper boundary (inclusive) -c bbox(:,3) is stride - integer srcbbox(3,3), dstbbox(3,3), regbbox(3,3) - - integer regiext, regjext, regkext - - integer srcioff, srcjoff, srckoff - integer dstioff, dstjoff, dstkoff - - integer i, j, k - integer d - - - - do d=1,3 - if (srcbbox(d,3).eq.0 .or. dstbbox(d,3).eq.0 - $ .or. regbbox(d,3).eq.0) then - call CCTK_WARN (0, "Internal error: stride is zero") - end if - if (srcbbox(d,3).ne.regbbox(d,3) - $ .or. dstbbox(d,3).ne.regbbox(d,3)) then - call CCTK_WARN (0, "Internal error: strides disagree") - end if - if (mod(srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array origins are not integer multiples of the strides") - end if - if (regbbox(d,1).gt.regbbox(d,2)) then -c This could be handled, but is likely to point to an error elsewhere - call CCTK_WARN (0, "Internal error: region extent is empty") - end if - if (mod(srcbbox(d,2) - srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,2) - dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,2) - regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array extents are not integer multiples of the strides") - end if - if (regbbox(d,1).lt.srcbbox(d,1) - $ .or. regbbox(d,1).lt.dstbbox(d,1) - $ .or. regbbox(d,2).gt.srcbbox(d,2) - $ .or. regbbox(d,2).gt.dstbbox(d,2)) then - call CCTK_WARN (0, "Internal error: region extent is not contained in array extent") - end if - end do - - if (srciext.ne.(srcbbox(1,2)-srcbbox(1,1))/srcbbox(1,3)+1 - $ .or. srcjext.ne.(srcbbox(2,2)-srcbbox(2,1))/srcbbox(2,3)+1 - $ .or. srckext.ne.(srcbbox(3,2)-srcbbox(3,1))/srcbbox(3,3)+1 - $ .or. dstiext.ne.(dstbbox(1,2)-dstbbox(1,1))/dstbbox(1,3)+1 - $ .or. dstjext.ne.(dstbbox(2,2)-dstbbox(2,1))/dstbbox(2,3)+1 - $ .or. dstkext.ne.(dstbbox(3,2)-dstbbox(3,1))/dstbbox(3,3)+1) then - call CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes") - end if - - - - regiext = (regbbox(1,2) - regbbox(1,1)) / regbbox(1,3) + 1 - regjext = (regbbox(2,2) - regbbox(2,1)) / regbbox(2,3) + 1 - regkext = (regbbox(3,2) - regbbox(3,1)) / regbbox(3,3) + 1 - - srcioff = (regbbox(1,1) - srcbbox(1,1)) / srcbbox(1,3) - srcjoff = (regbbox(2,1) - srcbbox(2,1)) / srcbbox(2,3) - srckoff = (regbbox(3,1) - srcbbox(3,1)) / srcbbox(3,3) - - dstioff = (regbbox(1,1) - dstbbox(1,1)) / dstbbox(1,3) - dstjoff = (regbbox(2,1) - dstbbox(2,1)) / dstbbox(2,3) - dstkoff = (regbbox(3,1) - dstbbox(3,1)) / dstbbox(3,3) - - - -c Loop over region - do k = 1, regkext - do j = 1, regjext - do i = 1, regiext - - if (check_array_accesses.ne.0) then - call checkindex (srcioff+i, srcjoff+j, srckoff+k, 1,1,1, - $ srciext, srcjext, srckext, - $ "source") - call checkindex (dstioff+i, dstjoff+j, dstkoff+k, 1,1,1, - $ dstiext, dstjext, dstkext, - $ "destination") - end if - - dst (dstioff+i, dstjoff+j, dstkoff+k) - $ = src (srcioff+i, srcjoff+j, srckoff+k) - - end do - end do - end do - - end -#endif diff --git a/Carpet/CarpetLib/src/data.cc b/Carpet/CarpetLib/src/data.cc index 9c7724263..9067d2942 100644 --- a/Carpet/CarpetLib/src/data.cc +++ b/Carpet/CarpetLib/src/data.cc @@ -21,20 +21,122 @@ #include "vect.hh" #include "data.hh" +#include "operator_prototypes.hh" using namespace std; +using namespace CarpetLib; + + + +// Fortran wrappers + +template <typename T> +void +prolongate_3d_eno (T const * restrict const src, + ivect3 const & srcext, + T * restrict const dst, + ivect3 const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox) +{ + CCTK_WARN (0, "Data type not supported"); +} + +#ifndef OMIT_F90 +extern "C" +void +CCTK_FCALL CCTK_FNAME(prolongate_3d_real8_eno) + (const CCTK_REAL8* src, + const int& srciext, const int& srcjext, const int& srckext, + CCTK_REAL8* dst, + const int& dstiext, const int& dstjext, const int& dstkext, + const int srcbbox[3][3], + const int dstbbox[3][3], + const int regbbox[3][3]); + +template <> +void +prolongate_3d_eno (CCTK_REAL8 const * restrict const src, + ivect3 const & srcext, + CCTK_REAL8 * restrict const dst, + ivect3 const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox) +{ + CCTK_FNAME(prolongate_3d_real8_eno) + (src, + srcext[0], srcext[1], srcext[2], + dst, + dstext[0], dstext[1], dstext[2], + reinterpret_cast <int const (*) [3]> (& srcbbox), + reinterpret_cast <int const (*) [3]> (& dstbbox), + reinterpret_cast <int const (*) [3]> (& regbbox)); +} +#endif + + + +template <typename T> +void +prolongate_3d_weno (T const * restrict const src, + ivect3 const & srcext, + T * restrict const dst, + ivect3 const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox) +{ + CCTK_WARN (0, "Data type not supported"); +} + +#ifndef OMIT_F90 +extern "C" +void +CCTK_FCALL CCTK_FNAME(prolongate_3d_real8_weno) + (const CCTK_REAL8* src, + const int& srciext, const int& srcjext, const int& srckext, + CCTK_REAL8* dst, + const int& dstiext, const int& dstjext, const int& dstkext, + const int srcbbox[3][3], + const int dstbbox[3][3], + const int regbbox[3][3]); + +template <> +void +prolongate_3d_weno (CCTK_REAL8 const * restrict const src, + ivect3 const & srcext, + CCTK_REAL8 * restrict const dst, + ivect3 const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox) +{ + CCTK_FNAME(prolongate_3d_real8_weno) + (src, + srcext[0], srcext[1], srcext[2], + dst, + dstext[0], dstext[1], dstext[2], + reinterpret_cast <int const (*) [3]> (& srcbbox), + reinterpret_cast <int const (*) [3]> (& dstbbox), + reinterpret_cast <int const (*) [3]> (& regbbox)); +} +#endif + static const CCTK_REAL eps = 1.0e-10; // Constructors template<typename T> -data<T>::data (const int varindex_, const operator_type transport_operator_, +data<T>::data (const int varindex_, + const centering cent_, const operator_type transport_operator_, const int vectorlength_, const int vectorindex_, data* const vectorleader_, const int tag_) - : gdata(varindex_, transport_operator_, tag_), + : gdata(varindex_, cent_, transport_operator_, tag_), _memory(NULL), vectorlength(vectorlength_), vectorindex(vectorindex_), vectorleader(vectorleader_) @@ -46,11 +148,12 @@ data<T>::data (const int varindex_, const operator_type transport_operator_, } template<typename T> -data<T>::data (const int varindex_, const operator_type transport_operator_, +data<T>::data (const int varindex_, + const centering cent_, const operator_type transport_operator_, const int vectorlength_, const int vectorindex_, data* const vectorleader_, const ibbox& extent_, const int proc_) - : gdata(varindex_, transport_operator_), + : gdata(varindex_, cent_, transport_operator_), _memory(NULL), vectorlength(vectorlength_), vectorindex(vectorindex_), vectorleader(vectorleader_) @@ -72,11 +175,12 @@ data<T>::~data () // Pseudo constructors template<typename T> data<T>* data<T>::make_typed (const int varindex_, + const centering cent_, const operator_type transport_operator_, const int tag_) const { - return new data(varindex_, transport_operator_, 1, 0, NULL, tag_); + return new data(varindex_, cent_, transport_operator_, 1, 0, NULL, tag_); } @@ -300,188 +404,6 @@ void data<T>::change_processor_wait (comm_state& state, wtime_changeproc_wait.stop(); } -#if 0 -template<typename T> -void -data<T>::copy_from_recv_inner (comm_state& state, - const gdata* gsrc, const ibbox& box) -{ - DECLARE_CCTK_PARAMETERS; - - wtime_copyfrom_recvinner_allocate.start(); - comm_state::commbuf<T> * b = new comm_state::commbuf<T>; - b->am_receiver = true; - b->am_sender = false; - b->data.resize (prod (box.shape() / box.stride())); - wtime_copyfrom_recvinner_allocate.stop(); - - wtime_copyfrom_recvinner_recv.start(); - assert (dist::rank() == proc()); - T dummy; - MPI_Irecv (&b->data.front(), b->data.size(), - dist::datatype(dummy), gsrc->proc(), - tag, dist::comm(), &b->request); - wtime_copyfrom_recvinner_recv.stop(); - if (use_waitall) { - state.requests.push_back (b->request); - } - state.recvbufs.push (b); -} -#endif - - -#if 0 -template<typename T> -void -data<T>::copy_from_send_inner (comm_state& state, - const gdata* gsrc, const ibbox& box) -{ - DECLARE_CCTK_PARAMETERS; - - wtime_copyfrom_sendinner_allocate.start(); - comm_state::gcommbuf * b = gsrc->make_typed_commbuf (box); - b->am_receiver = false; - b->am_sender = true; - wtime_copyfrom_sendinner_allocate.stop(); - - wtime_copyfrom_sendinner_copy.start(); - const data<T> * src = dynamic_cast<const data<T> *> (gsrc); - assert (src->_has_storage); - assert (dist::rank() == src->proc()); - // copy src to b -#if 0 - { - T * restrict p = & b->data.front(); - T const * restrict const q = src->_storage; - ivect const imin = box.lower() / box.stride(); - ivect const imax = (box.upper() + box.stride()) / box.stride(); - ivect const lbnd = src->extent().lower() / src->extent().stride(); - ivect const lsh = src->extent().shape() / src->extent().stride(); - for (int k=imin[2]; k<imax[2]; ++k) { - for (int j=imin[1]; j<imax[1]; ++j) { - for (int i=imin[0]; i<imax[0]; ++i) { - * p ++ = q [i - lbnd[0] + lsh[0] * (j - lbnd[1] + lsh[1] * (k - lbnd[2]))]; - } - } - } - } -#endif - { - data<T> * tmp = src->make_typed (varindex, transport_operator, tag); - tmp->allocate (box, src->proc(), &b->data.front()); - tmp->copy_from_innerloop (src, box); - delete tmp; - } - wtime_copyfrom_sendinner_copy.stop(); - - wtime_copyfrom_sendinner_send.start(); - assert (dist::rank() == src->proc()); - T dummy; - MPI_Isend (b->pointer(), b->size(), b->datatype(), proc(), - tag, dist::comm(), &b->request); - wtime_copyfrom_sendinner_send.stop(); - if (use_waitall) { - state.requests.push_back (b->request); - } - state.sendbufs.push (b); -} -#endif - - - -#if 0 -template<typename T> -void -data<T>::copy_from_recv_wait_inner (comm_state& state, - const gdata* gsrc, const ibbox& box) -{ - DECLARE_CCTK_PARAMETERS; - - comm_state::commbuf<T> * b - = (comm_state::commbuf<T> *) state.recvbufs.front(); - state.recvbufs.pop(); - assert (b->am_receiver); - assert (not b->am_sender); - - wtime_copyfrom_recvwaitinner_wait.start(); - if (use_waitall) { - if (not state.requests.empty()) { - // wait for all requests at once - MPI_Waitall - (state.requests.size(), &state.requests.front(), MPI_STATUSES_IGNORE); - state.requests.clear(); - } - } - - if (not use_waitall) { - MPI_Wait (&b->request, MPI_STATUS_IGNORE); - } - wtime_copyfrom_recvwaitinner_wait.stop(); - - wtime_copyfrom_recvwaitinner_copy.start(); - assert (_has_storage); - assert (dist::rank() == proc()); - // copy b to this - { - T * restrict const p = _storage; - T const * restrict q = & b->data.front(); - ivect const imin = box.lower() / box.stride(); - ivect const imax = (box.upper() + box.stride()) / box.stride(); - ivect const lbnd = extent().lower() / extent().stride(); - ivect const lsh = extent().shape() / extent().stride(); - for (int k=imin[2]; k<imax[2]; ++k) { - for (int j=imin[1]; j<imax[1]; ++j) { - for (int i=imin[0]; i<imax[0]; ++i) { - p [i - lbnd[0] + lsh[0] * (j - lbnd[1] + lsh[1] * (k - lbnd[2]))] = * q ++; - } - } - } - } - wtime_copyfrom_recvwaitinner_copy.stop(); - - wtime_copyfrom_recvwaitinner_delete.start(); - delete b; - wtime_copyfrom_recvwaitinner_delete.stop(); -} -#endif - - - -#if 0 -template<typename T> -void -data<T>::copy_from_send_wait_inner (comm_state& state, - const gdata* gsrc, const ibbox& box) -{ - DECLARE_CCTK_PARAMETERS; - - comm_state::commbuf<T> * b - = (comm_state::commbuf<T> *) state.sendbufs.front(); - state.sendbufs.pop(); - assert (not b->am_receiver); - assert (b->am_sender); - - wtime_copyfrom_sendwaitinner_wait.start(); - if (use_waitall) { - if (not state.requests.empty()) { - // wait for all requests at once - MPI_Waitall - (state.requests.size(), &state.requests.front(), MPI_STATUSES_IGNORE); - state.requests.clear(); - } - } - - if (not use_waitall) { - MPI_Wait (&b->request, MPI_STATUS_IGNORE); - } - wtime_copyfrom_sendwaitinner_wait.stop(); - - wtime_copyfrom_sendwaitinner_delete.start(); - delete b; - wtime_copyfrom_sendwaitinner_delete.stop(); -} -#endif - // Data manipulators @@ -496,1209 +418,344 @@ make_typed_commbuf (const ibbox & box) -template<typename T> -void data<T> -::copy_from_innerloop (const gdata* gsrc, const ibbox& box) +template <typename T> +void data <T> +::copy_from_innerloop (gdata const * const gsrc, + ibbox const & box) { - const data* src = (const data*)gsrc; - assert (has_storage() && src->has_storage()); - assert (all(box.lower()>=extent().lower() - && box.lower()>=src->extent().lower())); - assert (all(box.upper()<=extent().upper() - && box.upper()<=src->extent().upper())); - assert (all(box.stride()==extent().stride() - && box.stride()==src->extent().stride())); - assert (all((box.lower()-extent().lower())%box.stride() == 0 - && (box.lower()-src->extent().lower())%box.stride() == 0)); + data const * const src = dynamic_cast <data const *> (gsrc); + assert (has_storage() and src->has_storage()); assert (proc() == src->proc()); - - const int groupindex = CCTK_GroupIndexFromVarI(varindex); - const int group_tags_table = CCTK_GroupTagsTableI(groupindex); - assert (group_tags_table >= 0); - - // Disallow this. - T Tdummy; - CCTK_VWarn (0, __LINE__, __FILE__, CCTK_THORNSTRING, - "There is no copy operator available for the variable type %s", - typestring(Tdummy)); - assert (dist::rank() == proc()); - for (typename ibbox::iterator it=box.begin(); it!=box.end(); ++it) { - const ivect index = *it; - (*this)[index] = (*src)[index]; - } - + copy_3d (static_cast <T const *> (src->storage()), + src->shape(), + static_cast <T *> (this->storage()), + this->shape(), + src->extent(), + this->extent(), + box); } -static void fill_bbox_arrays (int srcshp[dim], - int dstshp[dim], - int srcbbox[dim][dim], - int dstbbox[dim][dim], - int regbbox[dim][dim], - const ibbox & box, - const ibbox & sext, - const ibbox & dext) -{ - for (int d=0; d<dim; ++d) { - srcshp[d] = (sext.shape() / sext.stride())[d]; - dstshp[d] = (dext.shape() / dext.stride())[d]; - - srcbbox[0][d] = sext.lower()[d]; - srcbbox[1][d] = sext.upper()[d]; - srcbbox[2][d] = sext.stride()[d]; - - dstbbox[0][d] = dext.lower()[d]; - dstbbox[1][d] = dext.upper()[d]; - dstbbox[2][d] = dext.stride()[d]; - - regbbox[0][d] = box.lower()[d]; - regbbox[1][d] = box.upper()[d]; - regbbox[2][d] = box.stride()[d]; - } -} - -template<typename T> -void data<T> -::interpolate_from_innerloop (const vector<const gdata*> gsrcs, - const vector<CCTK_REAL> times, - const ibbox& box, const CCTK_REAL time, - const int order_space, - const int order_time) +template <typename T> +void data <T> +::interpolate_from_innerloop (vector <gdata const *> const & gsrcs, + vector <CCTK_REAL> const & times, + ibbox const & box, + CCTK_REAL const time, + int const order_space, + int const order_time) { assert (has_storage()); - assert (all(box.lower()>=extent().lower())); - assert (all(box.upper()<=extent().upper())); - assert (all(box.stride()==extent().stride())); - assert (all((box.lower()-extent().lower())%box.stride() == 0)); - vector<const data*> srcs(gsrcs.size()); - for (int t=0; t<(int)srcs.size(); ++t) srcs[t] = (const data*)gsrcs[t]; - assert (srcs.size() == times.size() && srcs.size()>0); - for (int t=0; t<(int)srcs.size(); ++t) { - assert (srcs[t]->has_storage()); - assert (all(box.lower()>=srcs[t]->extent().lower())); - assert (all(box.upper()<=srcs[t]->extent().upper())); - assert (proc() == srcs[t]->proc()); + + vector <data const *> srcs (gsrcs.size()); + for (size_t t=0; t<srcs.size(); ++t) { + srcs.at(t) = dynamic_cast <data const *> (gsrcs.at(t)); + } + assert (srcs.size() == times.size() and srcs.size() > 0); + + for (size_t t=0; t<srcs.size(); ++t) { + assert (srcs.at(t)->has_storage()); + assert (proc() == srcs.at(t)->proc()); } - assert (order_space >= 0); - assert (order_time >= 0); assert (dist::rank() == proc()); - assert (varindex >= 0); - const int groupindex = CCTK_GroupIndexFromVarI (varindex); - assert (groupindex >= 0); - char* groupname = CCTK_GroupName(groupindex); - T Tdummy; - CCTK_VWarn (0, __LINE__, __FILE__, CCTK_THORNSTRING, - "There is no interpolator available for the group \"%s\" with variable type %s, spatial interpolation order %d, temporal interpolation order %d", - groupname, typestring(Tdummy), order_space, order_time); - ::free (groupname); + interpolate_time (srcs, times, box, time, order_space, order_time); } -extern "C" { - void CCTK_FCALL CCTK_FNAME(copy_3d_int4) - (const CCTK_INT4* src, - const int& srciext, const int& srcjext, const int& srckext, - CCTK_INT4* dst, - const int& dstiext, const int& dstjext, const int& dstkext, - const int srcbbox[3][3], - const int dstbbox[3][3], - const int regbbox[3][3]); - void CCTK_FCALL CCTK_FNAME(copy_3d_real8) - (const CCTK_REAL8* src, - const int& srciext, const int& srcjext, const int& srckext, - CCTK_REAL8* dst, - const int& dstiext, const int& dstjext, const int& dstkext, - const int srcbbox[3][3], - const int dstbbox[3][3], - const int regbbox[3][3]); - void CCTK_FCALL CCTK_FNAME(copy_3d_complex16) - (const CCTK_COMPLEX16* src, - const int& srciext, const int& srcjext, const int& srckext, - CCTK_COMPLEX16* dst, - const int& dstiext, const int& dstjext, const int& dstkext, - const int srcbbox[3][3], - const int dstbbox[3][3], - const int regbbox[3][3]); -} - -template<> -void data<CCTK_INT4> -::copy_from_innerloop (const gdata* gsrc, const ibbox& box) +template <typename T> +void data <T> +::interpolate_time (vector <data const *> const & srcs, + vector <CCTK_REAL> const & times, + ibbox const & box, + CCTK_REAL const time, + int const order_space, + int const order_time) { - const data* src = (const data*)gsrc; - assert (has_storage() && src->has_storage()); - assert (all(box.lower()>=extent().lower() - && box.lower()>=src->extent().lower())); - assert (all(box.upper()<=extent().upper() - && box.upper()<=src->extent().upper())); - assert (all(box.stride()==extent().stride() - && box.stride()==src->extent().stride())); - assert (all((box.lower()-extent().lower())%box.stride() == 0 - && (box.lower()-src->extent().lower())%box.stride() == 0)); - - assert (proc() == src->proc()); - - assert (dist::rank() == proc()); - - const ibbox& sext = src->extent(); - const ibbox& dext = extent(); + // Ensure that the times are consistent + assert (times.size() > 0); + CCTK_REAL const min_time = * min_element (times.begin(), times.end()); + CCTK_REAL const max_time = * max_element (times.begin(), times.end()); + if (transport_operator != op_copy) { + if (time < min_time - eps or time > max_time + eps) { + ostringstream buf; + buf << "Internal error: extrapolation in time." + << " time=" << time + << " times=" << times; + CCTK_WARN (0, buf.str().c_str()); + } + } - int srcshp[3], dstshp[3]; - int srcbbox[3][3], dstbbox[3][3], regbbox[3][3]; + // Use this timelevel, or interpolate in time if set to -1 + int timelevel = -1; - fill_bbox_arrays( srcshp, dstshp, srcbbox, dstbbox, regbbox, - box, sext, dext ); + // Try to avoid time interpolation if possible + if (timelevel == -1) { + if (times.size() == 1) { + timelevel = 0; + } + } + if (timelevel == -1) { + if (transport_operator == op_copy) { + timelevel = 0; + } + } + if (timelevel == -1) { + for (size_t tl=0; tl<times.size(); ++tl) { + if (abs (times.at(tl) - time) < eps) { + timelevel = tl; + break; + } + } + } - assert (all(dext.stride() == box.stride())); - if (all(sext.stride() == dext.stride())) { - CCTK_FNAME(copy_3d_int4) ((const CCTK_INT4*)src->storage(), - srcshp[0], srcshp[1], srcshp[2], - (CCTK_INT4*)storage(), - dstshp[0], dstshp[1], dstshp[2], - srcbbox, - dstbbox, - regbbox); + if (timelevel == -1) { + // Time interpolation is necessary + + vector <data *> tmps (times.size()); + + for (size_t tl=0; tl<times.size(); ++tl) { + + tmps.at(tl) = + new data (this->varindex, this->cent, this->transport_operator); + tmps.at(tl)->allocate (box, this->proc()); + + tmps.at(tl)->interpolate_p_r (srcs.at(tl), box, order_space); + + } + + time_interpolate (tmps, box, times, time, order_time); + + for (size_t tl=0; tl<times.size(); ++tl) { + delete tmps.at(tl); + } } else { - assert (0); - } + // No time interpolation + + interpolate_p_r (srcs.at(timelevel), box, order_space); + + } // if } -template<> -void data<CCTK_REAL8> -::copy_from_innerloop (const gdata* gsrc, const ibbox& box) + + +template <typename T> +void data <T> +::interpolate_p_r (data const * const src, + ibbox const & box, + int const order_space) { - const data* src = (const data*)gsrc; - assert (has_storage() && src->has_storage()); - assert (all(box.lower()>=extent().lower() - && box.lower()>=src->extent().lower())); - assert (all(box.upper()<=extent().upper() - && box.upper()<=src->extent().upper())); - assert (all(box.stride()==extent().stride() - && box.stride()==src->extent().stride())); - assert (all((box.lower()-extent().lower())%box.stride() == 0 - && (box.lower()-src->extent().lower())%box.stride() == 0)); - - assert (proc() == src->proc()); - - assert (dist::rank() == proc()); - - const ibbox& sext = src->extent(); - const ibbox& dext = extent(); - - int srcshp[3], dstshp[3]; - int srcbbox[3][3], dstbbox[3][3], regbbox[3][3]; - - fill_bbox_arrays( srcshp, dstshp, srcbbox, dstbbox, regbbox, - box, sext, dext ); - - assert (all(dext.stride() == box.stride())); - if (all(sext.stride() == dext.stride())) { - CCTK_FNAME(copy_3d_real8) ((const CCTK_REAL8*)src->storage(), - srcshp[0], srcshp[1], srcshp[2], - (CCTK_REAL8*)storage(), - dstshp[0], dstshp[1], dstshp[2], - srcbbox, - dstbbox, - regbbox); - + if (all (src->extent().stride() > this->extent().stride())) { + // Prolongate + interpolate_p_vc_cc (src, box, order_space); + } else if (all (src->extent().stride() < this->extent().stride())) { + // Restrict + interpolate_restrict (src, box, order_space); } else { assert (0); } } -template<> -void data<CCTK_COMPLEX16> -::copy_from_innerloop (const gdata* gsrc, const ibbox& box) + + +template <typename T> +void data <T> +::interpolate_p_vc_cc (data const * const src, + ibbox const & box, + int const order_space) { - const data* src = (const data*)gsrc; - assert (has_storage() && src->has_storage()); - assert (all(box.lower()>=extent().lower() - && box.lower()>=src->extent().lower())); - assert (all(box.upper()<=extent().upper() - && box.upper()<=src->extent().upper())); - assert (all(box.stride()==extent().stride() - && box.stride()==src->extent().stride())); - assert (all((box.lower()-extent().lower())%box.stride() == 0 - && (box.lower()-src->extent().lower())%box.stride() == 0)); - - assert (proc() == src->proc()); - - assert (dist::rank() == proc()); - - const ibbox& sext = src->extent(); - const ibbox& dext = extent(); - - int srcshp[3], dstshp[3]; - int srcbbox[3][3], dstbbox[3][3], regbbox[3][3]; - - fill_bbox_arrays( srcshp, dstshp, srcbbox, dstbbox, regbbox, - box, sext, dext ); - - assert (all(dext.stride() == box.stride())); - if (all(sext.stride() == dext.stride())) { - CCTK_FNAME(copy_3d_complex16) ((const CCTK_COMPLEX16*)src->storage(), - srcshp[0], srcshp[1], srcshp[2], - (CCTK_COMPLEX16*)storage(), - dstshp[0], dstshp[1], dstshp[2], - srcbbox, - dstbbox, - regbbox); + if (cent == vertex_centered) { + // Vertex centred + + interpolate_prolongate (src, box, order_space); + + } else if (cent == cell_centered) { + // Cell centred + + // Destination region + assert (all (box.stride() % 2 == 0)); + ibbox const newdstbox (box.lower() - box.stride() / 2, + box.upper() + box.stride() / 2, + box.stride()); + + // Source region + ibbox const & srcbox = src->extent(); + + assert (all (srcbox.stride() % 2 == 0)); + ibbox const tmpsrcbox (srcbox.lower() - srcbox.stride() / 2, + srcbox.upper() + srcbox.stride() / 2, + srcbox.stride()); + + assert (all (srcbox.stride() % box.stride() == 0)); + ivect const reffact = srcbox.stride() / box.stride(); + + ivect const regext = newdstbox.shape() / newdstbox.stride(); + assert (all ((newdstbox.lower() - srcbox.lower()) % box.stride() == 0)); + ivect const srcoff = (newdstbox.lower() - srcbox.lower()) / box.stride(); + + bvect const needoffsetlo = + srcoff % reffact != 0 or regext > 1; + bvect const needoffsethi = + (srcoff + regext - 1) % reffact != 0 or regext > 1; + + assert (order_space % 2 == 1); + int const stencil_size = (order_space + 1) / 2; + + ivect const offsetlo = either (needoffsetlo, stencil_size, 0); + ivect const offsethi = either (needoffsethi, stencil_size, 0); + + ibbox const newsrcbox = + newdstbox .contracted_for (tmpsrcbox) .expand (offsetlo, offsethi); + + // Allocate temporary storage + data * const newsrc = + new data (src->varindex, vertex_centered, src->transport_operator); + newsrc->allocate (newsrcbox, src->proc()); + + data * const newdst = + new data (this->varindex, vertex_centered, this->transport_operator); + newdst->allocate (newdstbox, this->proc()); + + // Convert source to primitive representation + prolongate_3d_cc_rf2_std2prim + (static_cast <T const *> (src->storage()), + src->shape(), + static_cast <T *> (newsrc->storage()), + newsrc->shape(), + src->extent(), + newsrc->extent(), + newsrc->extent()); + + // Interpolate + newdst->interpolate_prolongate (newsrc, newdstbox, order_space); + + // Convert destination to standard representation + prolongate_3d_cc_rf2_prim2std + (static_cast <T const *> (newdst->storage()), + newdst->shape(), + static_cast <T *> (this->storage()), + this->shape(), + newdst->extent(), + this->extent(), + box); + + delete newsrc; + delete newdst; } else { assert (0); } } - - -extern "C" { - - void CCTK_FCALL CCTK_FNAME(restrict_3d_real8) - (const CCTK_REAL8* src, - const int& srciext, const int& srcjext, const int& srckext, - CCTK_REAL8* dst, - const int& dstiext, const int& dstjext, const int& dstkext, - const int srcbbox[3][3], - const int dstbbox[3][3], - const int regbbox[3][3]); - void CCTK_FCALL CCTK_FNAME(restrict_3d_real8_rf2) - (const CCTK_REAL8* src, - const int& srciext, const int& srcjext, const int& srckext, - CCTK_REAL8* dst, - const int& dstiext, const int& dstjext, const int& dstkext, - const int srcbbox[3][3], - const int dstbbox[3][3], - const int regbbox[3][3]); - - - - void CCTK_FCALL CCTK_FNAME(prolongate_3d_real8) - (const CCTK_REAL8* src, - const int& srciext, const int& srcjext, const int& srckext, - CCTK_REAL8* dst, - const int& dstiext, const int& dstjext, const int& dstkext, - const int srcbbox[3][3], - const int dstbbox[3][3], - const int regbbox[3][3]); - void CCTK_FCALL CCTK_FNAME(prolongate_3d_real8_rf2) - (const CCTK_REAL8* src, - const int& srciext, const int& srcjext, const int& srckext, - CCTK_REAL8* dst, - const int& dstiext, const int& dstjext, const int& dstkext, - const int srcbbox[3][3], - const int dstbbox[3][3], - const int regbbox[3][3]); - void CCTK_FCALL CCTK_FNAME(prolongate_3d_real8_o3) - (const CCTK_REAL8* src, - const int& srciext, const int& srcjext, const int& srckext, - CCTK_REAL8* dst, - const int& dstiext, const int& dstjext, const int& dstkext, - const int srcbbox[3][3], - const int dstbbox[3][3], - const int regbbox[3][3]); - void CCTK_FCALL CCTK_FNAME(prolongate_3d_real8_o3_rf2) - (const CCTK_REAL8* src, - const int& srciext, const int& srcjext, const int& srckext, - CCTK_REAL8* dst, - const int& dstiext, const int& dstjext, const int& dstkext, - const int srcbbox[3][3], - const int dstbbox[3][3], - const int regbbox[3][3]); - void CCTK_FCALL CCTK_FNAME(prolongate_3d_real8_minmod) - (const CCTK_REAL8* src, - const int& srciext, const int& srcjext, const int& srckext, - CCTK_REAL8* dst, - const int& dstiext, const int& dstjext, const int& dstkext, - const int srcbbox[3][3], - const int dstbbox[3][3], - const int regbbox[3][3]); -#ifndef OMIT_F90 - void CCTK_FCALL CCTK_FNAME(prolongate_3d_real8_eno) - (const CCTK_REAL8* src, - const int& srciext, const int& srcjext, const int& srckext, - CCTK_REAL8* dst, - const int& dstiext, const int& dstjext, const int& dstkext, - const int srcbbox[3][3], - const int dstbbox[3][3], - const int regbbox[3][3]); - void CCTK_FCALL CCTK_FNAME(prolongate_3d_real8_weno) - (const CCTK_REAL8* src, - const int& srciext, const int& srcjext, const int& srckext, - CCTK_REAL8* dst, - const int& dstiext, const int& dstjext, const int& dstkext, - const int srcbbox[3][3], - const int dstbbox[3][3], - const int regbbox[3][3]); -#endif // #ifndef OMIT_F90 - void CCTK_FCALL CCTK_FNAME(prolongate_3d_real8_o5) - (const CCTK_REAL8* src, - const int& srciext, const int& srcjext, const int& srckext, - CCTK_REAL8* dst, - const int& dstiext, const int& dstjext, const int& dstkext, - const int srcbbox[3][3], - const int dstbbox[3][3], - const int regbbox[3][3]); - void CCTK_FCALL CCTK_FNAME(prolongate_3d_real8_o5_rf2) - (const CCTK_REAL8* src, - const int& srciext, const int& srcjext, const int& srckext, - CCTK_REAL8* dst, - const int& dstiext, const int& dstjext, const int& dstkext, - const int srcbbox[3][3], - const int dstbbox[3][3], - const int regbbox[3][3]); - void CCTK_FCALL CCTK_FNAME(prolongate_3d_real8_o7_rf2) - (const CCTK_REAL8* src, - const int& srciext, const int& srcjext, const int& srckext, - CCTK_REAL8* dst, - const int& dstiext, const int& dstjext, const int& dstkext, - const int srcbbox[3][3], - const int dstbbox[3][3], - const int regbbox[3][3]); - - void CCTK_FCALL CCTK_FNAME(prolongate_3d_real8_2tl) - (const CCTK_REAL8* src1, const CCTK_REAL8& t1, - const CCTK_REAL8* src2, const CCTK_REAL8& t2, - const int& srciext, const int& srcjext, const int& srckext, - CCTK_REAL8* dst, const CCTK_REAL8& t, - const int& dstiext, const int& dstjext, const int& dstkext, - const int srcbbox[3][3], - const int dstbbox[3][3], - const int regbbox[3][3]); - void CCTK_FCALL CCTK_FNAME(prolongate_3d_real8_2tl_rf2) - (const CCTK_REAL8* src1, const CCTK_REAL8& t1, - const CCTK_REAL8* src2, const CCTK_REAL8& t2, - const int& srciext, const int& srcjext, const int& srckext, - CCTK_REAL8* dst, const CCTK_REAL8& t, - const int& dstiext, const int& dstjext, const int& dstkext, - const int srcbbox[3][3], - const int dstbbox[3][3], - const int regbbox[3][3]); - void CCTK_FCALL CCTK_FNAME(prolongate_3d_real8_2tl_o3) - (const CCTK_REAL8* src1, const CCTK_REAL8& t1, - const CCTK_REAL8* src2, const CCTK_REAL8& t2, - const int& srciext, const int& srcjext, const int& srckext, - CCTK_REAL8* dst, const CCTK_REAL8& t, - const int& dstiext, const int& dstjext, const int& dstkext, - const int srcbbox[3][3], - const int dstbbox[3][3], - const int regbbox[3][3]); - void CCTK_FCALL CCTK_FNAME(prolongate_3d_real8_2tl_o3_rf2) - (const CCTK_REAL8* src1, const CCTK_REAL8& t1, - const CCTK_REAL8* src2, const CCTK_REAL8& t2, - const int& srciext, const int& srcjext, const int& srckext, - CCTK_REAL8* dst, const CCTK_REAL8& t, - const int& dstiext, const int& dstjext, const int& dstkext, - const int srcbbox[3][3], - const int dstbbox[3][3], - const int regbbox[3][3]); - void CCTK_FCALL CCTK_FNAME(prolongate_3d_real8_2tl_minmod) - (const CCTK_REAL8* src1, const CCTK_REAL8& t1, - const CCTK_REAL8* src2, const CCTK_REAL8& t2, - const int& srciext, const int& srcjext, const int& srckext, - CCTK_REAL8* dst, const CCTK_REAL8& t, - const int& dstiext, const int& dstjext, const int& dstkext, - const int srcbbox[3][3], - const int dstbbox[3][3], - const int regbbox[3][3]); -#ifndef OMIT_F90 - void CCTK_FCALL CCTK_FNAME(prolongate_3d_real8_2tl_eno) - (const CCTK_REAL8* src1, const CCTK_REAL8& t1, - const CCTK_REAL8* src2, const CCTK_REAL8& t2, - const int& srciext, const int& srcjext, const int& srckext, - CCTK_REAL8* dst, const CCTK_REAL8& t, - const int& dstiext, const int& dstjext, const int& dstkext, - const int srcbbox[3][3], - const int dstbbox[3][3], - const int regbbox[3][3]); - void CCTK_FCALL CCTK_FNAME(prolongate_3d_real8_2tl_weno) - (const CCTK_REAL8* src1, const CCTK_REAL8& t1, - const CCTK_REAL8* src2, const CCTK_REAL8& t2, - const int& srciext, const int& srcjext, const int& srckext, - CCTK_REAL8* dst, const CCTK_REAL8& t, - const int& dstiext, const int& dstjext, const int& dstkext, - const int srcbbox[3][3], - const int dstbbox[3][3], - const int regbbox[3][3]); -#endif // #ifndef OMIT_F90 - void CCTK_FCALL CCTK_FNAME(prolongate_3d_real8_2tl_o5) - (const CCTK_REAL8* src1, const CCTK_REAL8& t1, - const CCTK_REAL8* src2, const CCTK_REAL8& t2, - const int& srciext, const int& srcjext, const int& srckext, - CCTK_REAL8* dst, const CCTK_REAL8& t, - const int& dstiext, const int& dstjext, const int& dstkext, - const int srcbbox[3][3], - const int dstbbox[3][3], - const int regbbox[3][3]); - void CCTK_FCALL CCTK_FNAME(prolongate_3d_real8_2tl_o5_rf2) - (const CCTK_REAL8* src1, const CCTK_REAL8& t1, - const CCTK_REAL8* src2, const CCTK_REAL8& t2, - const int& srciext, const int& srcjext, const int& srckext, - CCTK_REAL8* dst, const CCTK_REAL8& t, - const int& dstiext, const int& dstjext, const int& dstkext, - const int srcbbox[3][3], - const int dstbbox[3][3], - const int regbbox[3][3]); - void CCTK_FCALL CCTK_FNAME(prolongate_3d_real8_2tl_o7_rf2) - (const CCTK_REAL8* src1, const CCTK_REAL8& t1, - const CCTK_REAL8* src2, const CCTK_REAL8& t2, - const int& srciext, const int& srcjext, const int& srckext, - CCTK_REAL8* dst, const CCTK_REAL8& t, - const int& dstiext, const int& dstjext, const int& dstkext, - const int srcbbox[3][3], - const int dstbbox[3][3], - const int regbbox[3][3]); - - void CCTK_FCALL CCTK_FNAME(prolongate_3d_real8_3tl) - (const CCTK_REAL8* src1, const CCTK_REAL8& t1, - const CCTK_REAL8* src2, const CCTK_REAL8& t2, - const CCTK_REAL8* src3, const CCTK_REAL8& t3, - const int& srciext, const int& srcjext, const int& srckext, - CCTK_REAL8* dst, const CCTK_REAL8& t, - const int& dstiext, const int& dstjext, const int& dstkext, - const int srcbbox[3][3], - const int dstbbox[3][3], - const int regbbox[3][3]); - void CCTK_FCALL CCTK_FNAME(prolongate_3d_real8_3tl_rf2) - (const CCTK_REAL8* src1, const CCTK_REAL8& t1, - const CCTK_REAL8* src2, const CCTK_REAL8& t2, - const CCTK_REAL8* src3, const CCTK_REAL8& t3, - const int& srciext, const int& srcjext, const int& srckext, - CCTK_REAL8* dst, const CCTK_REAL8& t, - const int& dstiext, const int& dstjext, const int& dstkext, - const int srcbbox[3][3], - const int dstbbox[3][3], - const int regbbox[3][3]); - void CCTK_FCALL CCTK_FNAME(prolongate_3d_real8_3tl_o3) - (const CCTK_REAL8* src1, const CCTK_REAL8& t1, - const CCTK_REAL8* src2, const CCTK_REAL8& t2, - const CCTK_REAL8* src3, const CCTK_REAL8& t3, - const int& srciext, const int& srcjext, const int& srckext, - CCTK_REAL8* dst, const CCTK_REAL8& t, - const int& dstiext, const int& dstjext, const int& dstkext, - const int srcbbox[3][3], - const int dstbbox[3][3], - const int regbbox[3][3]); - void CCTK_FCALL CCTK_FNAME(prolongate_3d_real8_3tl_o3_rf2) - (const CCTK_REAL8* src1, const CCTK_REAL8& t1, - const CCTK_REAL8* src2, const CCTK_REAL8& t2, - const CCTK_REAL8* src3, const CCTK_REAL8& t3, - const int& srciext, const int& srcjext, const int& srckext, - CCTK_REAL8* dst, const CCTK_REAL8& t, - const int& dstiext, const int& dstjext, const int& dstkext, - const int srcbbox[3][3], - const int dstbbox[3][3], - const int regbbox[3][3]); - void CCTK_FCALL CCTK_FNAME(prolongate_3d_real8_3tl_minmod) - (const CCTK_REAL8* src1, const CCTK_REAL8& t1, - const CCTK_REAL8* src2, const CCTK_REAL8& t2, - const CCTK_REAL8* src3, const CCTK_REAL8& t3, - const int& srciext, const int& srcjext, const int& srckext, - CCTK_REAL8* dst, const CCTK_REAL8& t, - const int& dstiext, const int& dstjext, const int& dstkext, - const int srcbbox[3][3], - const int dstbbox[3][3], - const int regbbox[3][3]); -#ifndef OMIT_F90 - void CCTK_FCALL CCTK_FNAME(prolongate_3d_real8_3tl_eno) - (const CCTK_REAL8* src1, const CCTK_REAL8& t1, - const CCTK_REAL8* src2, const CCTK_REAL8& t2, - const CCTK_REAL8* src3, const CCTK_REAL8& t3, - const int& srciext, const int& srcjext, const int& srckext, - CCTK_REAL8* dst, const CCTK_REAL8& t, - const int& dstiext, const int& dstjext, const int& dstkext, - const int srcbbox[3][3], - const int dstbbox[3][3], - const int regbbox[3][3]); - void CCTK_FCALL CCTK_FNAME(prolongate_3d_real8_3tl_weno) - (const CCTK_REAL8* src1, const CCTK_REAL8& t1, - const CCTK_REAL8* src2, const CCTK_REAL8& t2, - const CCTK_REAL8* src3, const CCTK_REAL8& t3, - const int& srciext, const int& srcjext, const int& srckext, - CCTK_REAL8* dst, const CCTK_REAL8& t, - const int& dstiext, const int& dstjext, const int& dstkext, - const int srcbbox[3][3], - const int dstbbox[3][3], - const int regbbox[3][3]); -#endif // #ifndef OMIT_F90 - void CCTK_FCALL CCTK_FNAME(prolongate_3d_real8_3tl_o5) - (const CCTK_REAL8* src1, const CCTK_REAL8& t1, - const CCTK_REAL8* src2, const CCTK_REAL8& t2, - const CCTK_REAL8* src3, const CCTK_REAL8& t3, - const int& srciext, const int& srcjext, const int& srckext, - CCTK_REAL8* dst, const CCTK_REAL8& t, - const int& dstiext, const int& dstjext, const int& dstkext, - const int srcbbox[3][3], - const int dstbbox[3][3], - const int regbbox[3][3]); - void CCTK_FCALL CCTK_FNAME(prolongate_3d_real8_3tl_o5_rf2) - (const CCTK_REAL8* src1, const CCTK_REAL8& t1, - const CCTK_REAL8* src2, const CCTK_REAL8& t2, - const CCTK_REAL8* src3, const CCTK_REAL8& t3, - const int& srciext, const int& srcjext, const int& srckext, - CCTK_REAL8* dst, const CCTK_REAL8& t, - const int& dstiext, const int& dstjext, const int& dstkext, - const int srcbbox[3][3], - const int dstbbox[3][3], - const int regbbox[3][3]); - void CCTK_FCALL CCTK_FNAME(prolongate_3d_real8_3tl_o7_rf2) - (const CCTK_REAL8* src1, const CCTK_REAL8& t1, - const CCTK_REAL8* src2, const CCTK_REAL8& t2, - const CCTK_REAL8* src3, const CCTK_REAL8& t3, - const int& srciext, const int& srcjext, const int& srckext, - CCTK_REAL8* dst, const CCTK_REAL8& t, - const int& dstiext, const int& dstjext, const int& dstkext, - const int srcbbox[3][3], - const int dstbbox[3][3], - const int regbbox[3][3]); -} - -template<typename T> -void data<T> -::interpolate_restrict (const vector<const data<T>*> & srcs, - const vector<CCTK_REAL> & times, - const ibbox& box) +template <> +void data <CCTK_INT> +::interpolate_p_vc_cc (data const * const src, + ibbox const & box, + int const order_space) { - const ibbox& sext = srcs[0]->extent(); - const ibbox& dext = extent(); - - wtime_restrict.start(); - - int srcshp[3], dstshp[3]; - int srcbbox[3][3], dstbbox[3][3], regbbox[3][3]; - - fill_bbox_arrays (srcshp, dstshp, srcbbox, dstbbox, regbbox, - box, sext, dext ); - - switch (transport_operator) { - - case op_copy: - case op_Lagrange: - case op_TVD: - case op_ENO: - case op_WENO: - assert (srcs.size() == 1); - if (all (dext.stride() == sext.stride() * 2)) { - CCTK_FNAME(restrict_3d_real8_rf2) - ((const CCTK_REAL8*)srcs[0]->storage(), - srcshp[0], srcshp[1], srcshp[2], - (CCTK_REAL8*)storage(), - dstshp[0], dstshp[1], dstshp[2], - srcbbox, dstbbox, regbbox); - } else { - CCTK_FNAME(restrict_3d_real8) - ((const CCTK_REAL8*)srcs[0]->storage(), - srcshp[0], srcshp[1], srcshp[2], - (CCTK_REAL8*)storage(), - dstshp[0], dstshp[1], dstshp[2], - srcbbox, dstbbox, regbbox); - } - break; - - default: - assert (0); - } - - wtime_restrict.stop(); + CCTK_WARN (0, "Data type not supported"); } -template<typename T> -void data<T> -::interpolate_prolongate (const vector<const data<T>*> & srcs, - const vector<CCTK_REAL> & times, - const ibbox& box, const CCTK_REAL time, - const int order_space, - const int order_time) + + +template <typename T> +void data <T> +::interpolate_prolongate (data const * const src, + ibbox const & box, + int const order_space) { - const ibbox& sext = srcs[0]->extent(); - const ibbox& dext = extent(); - wtime_prolongate.start(); - int srcshp[dim], dstshp[dim]; - int srcbbox[dim][dim], dstbbox[dim][dim], regbbox[dim][dim]; - - fill_bbox_arrays (srcshp, dstshp, srcbbox, dstbbox, regbbox, - box, sext, dext); switch (transport_operator) { case op_copy: - wtime_prolongate_copy.start(); - assert (times.size() == 1); - assert (srcs.size()>=1); + case op_Lagrange: + wtime_prolongate_Lagrange.start(); switch (order_space) { case 1: - if (all (sext.stride() == dext.stride() * 2)) { - CCTK_FNAME(prolongate_3d_real8_rf2) - ((const CCTK_REAL8*)srcs[0]->storage(), - srcshp[0], srcshp[1], srcshp[2], - (CCTK_REAL8*)storage(), - dstshp[0], dstshp[1], dstshp[2], - srcbbox, dstbbox, regbbox); - } else { - CCTK_FNAME(prolongate_3d_real8) - ((const CCTK_REAL8*)srcs[0]->storage(), - srcshp[0], srcshp[1], srcshp[2], - (CCTK_REAL8*)storage(), - dstshp[0], dstshp[1], dstshp[2], - srcbbox, dstbbox, regbbox); - } + prolongate_3d_o1_rf2 (static_cast <T const *> (src->storage()), + src->shape(), + static_cast <T *> (this->storage()), + this->shape(), + src->extent(), + this->extent(), + box); break; case 3: - if (all (sext.stride() == dext.stride() * 2)) { - CCTK_FNAME(prolongate_3d_real8_o3_rf2) - ((const CCTK_REAL8*)srcs[0]->storage(), - srcshp[0], srcshp[1], srcshp[2], - (CCTK_REAL8*)storage(), - dstshp[0], dstshp[1], dstshp[2], - srcbbox, dstbbox, regbbox); - } else { - CCTK_FNAME(prolongate_3d_real8_o3) - ((const CCTK_REAL8*)srcs[0]->storage(), - srcshp[0], srcshp[1], srcshp[2], - (CCTK_REAL8*)storage(), - dstshp[0], dstshp[1], dstshp[2], - srcbbox, dstbbox, regbbox); - } + prolongate_3d_o3_rf2 (static_cast <T const *> (src->storage()), + src->shape(), + static_cast <T *> (this->storage()), + this->shape(), + src->extent(), + this->extent(), + box); break; case 5: - if (all (sext.stride() == dext.stride() * 2)) { - CCTK_FNAME(prolongate_3d_real8_o5_rf2) - ((const CCTK_REAL8*)srcs[0]->storage(), - srcshp[0], srcshp[1], srcshp[2], - (CCTK_REAL8*)storage(), - dstshp[0], dstshp[1], dstshp[2], - srcbbox, dstbbox, regbbox); - } else { - CCTK_FNAME(prolongate_3d_real8_o5) - ((const CCTK_REAL8*)srcs[0]->storage(), - srcshp[0], srcshp[1], srcshp[2], - (CCTK_REAL8*)storage(), - dstshp[0], dstshp[1], dstshp[2], - srcbbox, dstbbox, regbbox); - } - break; - case 7: - if (all (sext.stride() == dext.stride() * 2)) { - CCTK_FNAME(prolongate_3d_real8_o7_rf2) - ((const CCTK_REAL8*)srcs[0]->storage(), - srcshp[0], srcshp[1], srcshp[2], - (CCTK_REAL8*)storage(), - dstshp[0], dstshp[1], dstshp[2], - srcbbox, dstbbox, regbbox); - } else { - assert (0); - } + prolongate_3d_o5_rf2 (static_cast <T const *> (src->storage()), + src->shape(), + static_cast <T *> (this->storage()), + this->shape(), + src->extent(), + this->extent(), + box); break; default: assert (0); } - wtime_prolongate_copy.stop(); + wtime_prolongate_Lagrange.stop(); break; - case op_Lagrange: - switch (order_time) { - - case 0: - wtime_prolongate_Lagrange_0.start(); - assert (times.size() == 1); - assert (abs(times[0] - time) < eps); - assert (srcs.size()>=1); - switch (order_space) { - case 1: - if (all (sext.stride() == dext.stride() * 2)) { - CCTK_FNAME(prolongate_3d_real8_rf2) - ((const CCTK_REAL8*)srcs[0]->storage(), - srcshp[0], srcshp[1], srcshp[2], - (CCTK_REAL8*)storage(), - dstshp[0], dstshp[1], dstshp[2], - srcbbox, dstbbox, regbbox); - } else { - CCTK_FNAME(prolongate_3d_real8) - ((const CCTK_REAL8*)srcs[0]->storage(), - srcshp[0], srcshp[1], srcshp[2], - (CCTK_REAL8*)storage(), - dstshp[0], dstshp[1], dstshp[2], - srcbbox, dstbbox, regbbox); - } - break; - case 3: - if (all (sext.stride() == dext.stride() * 2)) { - CCTK_FNAME(prolongate_3d_real8_o3_rf2) - ((const CCTK_REAL8*)srcs[0]->storage(), - srcshp[0], srcshp[1], srcshp[2], - (CCTK_REAL8*)storage(), - dstshp[0], dstshp[1], dstshp[2], - srcbbox, dstbbox, regbbox); - } else { - CCTK_FNAME(prolongate_3d_real8_o3) - ((const CCTK_REAL8*)srcs[0]->storage(), - srcshp[0], srcshp[1], srcshp[2], - (CCTK_REAL8*)storage(), - dstshp[0], dstshp[1], dstshp[2], - srcbbox, dstbbox, regbbox); - } - break; - case 5: - if (all (sext.stride() == dext.stride() * 2)) { - CCTK_FNAME(prolongate_3d_real8_o5_rf2) - ((const CCTK_REAL8*)srcs[0]->storage(), - srcshp[0], srcshp[1], srcshp[2], - (CCTK_REAL8*)storage(), - dstshp[0], dstshp[1], dstshp[2], - srcbbox, dstbbox, regbbox); - } else { - CCTK_FNAME(prolongate_3d_real8_o5) - ((const CCTK_REAL8*)srcs[0]->storage(), - srcshp[0], srcshp[1], srcshp[2], - (CCTK_REAL8*)storage(), - dstshp[0], dstshp[1], dstshp[2], - srcbbox, dstbbox, regbbox); - } - break; - case 7: - if (all (sext.stride() == dext.stride() * 2)) { - CCTK_FNAME(prolongate_3d_real8_o7_rf2) - ((const CCTK_REAL8*)srcs[0]->storage(), - srcshp[0], srcshp[1], srcshp[2], - (CCTK_REAL8*)storage(), - dstshp[0], dstshp[1], dstshp[2], - srcbbox, dstbbox, regbbox); - } else { - assert (0); - } - break; - default: - assert (0); - } - wtime_prolongate_Lagrange_0.stop(); - break; - - case 1: - wtime_prolongate_Lagrange_1.start(); - assert (srcs.size()>=2); - switch (order_space) { - case 1: - if (all (sext.stride() == dext.stride() * 2)) { - CCTK_FNAME(prolongate_3d_real8_2tl_rf2) - ((const CCTK_REAL8*)srcs[0]->storage(), times[0], - (const CCTK_REAL8*)srcs[1]->storage(), times[1], - srcshp[0], srcshp[1], srcshp[2], - (CCTK_REAL8*)storage(), time, - dstshp[0], dstshp[1], dstshp[2], - srcbbox, dstbbox, regbbox); - } else { - CCTK_FNAME(prolongate_3d_real8_2tl) - ((const CCTK_REAL8*)srcs[0]->storage(), times[0], - (const CCTK_REAL8*)srcs[1]->storage(), times[1], - srcshp[0], srcshp[1], srcshp[2], - (CCTK_REAL8*)storage(), time, - dstshp[0], dstshp[1], dstshp[2], - srcbbox, dstbbox, regbbox); - } - break; - case 3: - if (all (sext.stride() == dext.stride() * 2)) { - CCTK_FNAME(prolongate_3d_real8_2tl_o3_rf2) - ((const CCTK_REAL8*)srcs[0]->storage(), times[0], - (const CCTK_REAL8*)srcs[1]->storage(), times[1], - srcshp[0], srcshp[1], srcshp[2], - (CCTK_REAL8*)storage(), time, - dstshp[0], dstshp[1], dstshp[2], - srcbbox, dstbbox, regbbox); - } else { - CCTK_FNAME(prolongate_3d_real8_2tl_o3) - ((const CCTK_REAL8*)srcs[0]->storage(), times[0], - (const CCTK_REAL8*)srcs[1]->storage(), times[1], - srcshp[0], srcshp[1], srcshp[2], - (CCTK_REAL8*)storage(), time, - dstshp[0], dstshp[1], dstshp[2], - srcbbox, dstbbox, regbbox); - } - break; - case 5: - if (all (sext.stride() == dext.stride() * 2)) { - CCTK_FNAME(prolongate_3d_real8_2tl_o5_rf2) - ((const CCTK_REAL8*)srcs[0]->storage(), times[0], - (const CCTK_REAL8*)srcs[1]->storage(), times[1], - srcshp[0], srcshp[1], srcshp[2], - (CCTK_REAL8*)storage(), time, - dstshp[0], dstshp[1], dstshp[2], - srcbbox, dstbbox, regbbox); - } else { - CCTK_FNAME(prolongate_3d_real8_2tl_o5) - ((const CCTK_REAL8*)srcs[0]->storage(), times[0], - (const CCTK_REAL8*)srcs[1]->storage(), times[1], - srcshp[0], srcshp[1], srcshp[2], - (CCTK_REAL8*)storage(), time, - dstshp[0], dstshp[1], dstshp[2], - srcbbox, dstbbox, regbbox); - } - break; - case 7: - if (all (sext.stride() == dext.stride() * 2)) { - CCTK_FNAME(prolongate_3d_real8_2tl_o7_rf2) - ((const CCTK_REAL8*)srcs[0]->storage(), times[0], - (const CCTK_REAL8*)srcs[1]->storage(), times[1], - srcshp[0], srcshp[1], srcshp[2], - (CCTK_REAL8*)storage(), time, - dstshp[0], dstshp[1], dstshp[2], - srcbbox, dstbbox, regbbox); - } else { - assert (0); - } - break; - default: - assert (0); - } - wtime_prolongate_Lagrange_1.stop(); - break; - - case 2: - wtime_prolongate_Lagrange_2.start(); - assert (srcs.size()>=3); - switch (order_space) { - case 1: - if (all (sext.stride() == dext.stride() * 2)) { - CCTK_FNAME(prolongate_3d_real8_3tl_rf2) - ((const CCTK_REAL8*)srcs[0]->storage(), times[0], - (const CCTK_REAL8*)srcs[1]->storage(), times[1], - (const CCTK_REAL8*)srcs[2]->storage(), times[2], - srcshp[0], srcshp[1], srcshp[2], - (CCTK_REAL8*)storage(), time, - dstshp[0], dstshp[1], dstshp[2], - srcbbox, dstbbox, regbbox); - } else { - CCTK_FNAME(prolongate_3d_real8_3tl) - ((const CCTK_REAL8*)srcs[0]->storage(), times[0], - (const CCTK_REAL8*)srcs[1]->storage(), times[1], - (const CCTK_REAL8*)srcs[2]->storage(), times[2], - srcshp[0], srcshp[1], srcshp[2], - (CCTK_REAL8*)storage(), time, - dstshp[0], dstshp[1], dstshp[2], - srcbbox, dstbbox, regbbox); - } - break; - case 3: - if (all (sext.stride() == dext.stride() * 2)) { - CCTK_FNAME(prolongate_3d_real8_3tl_o3_rf2) - ((const CCTK_REAL8*)srcs[0]->storage(), times[0], - (const CCTK_REAL8*)srcs[1]->storage(), times[1], - (const CCTK_REAL8*)srcs[2]->storage(), times[2], - srcshp[0], srcshp[1], srcshp[2], - (CCTK_REAL8*)storage(), time, - dstshp[0], dstshp[1], dstshp[2], - srcbbox, dstbbox, regbbox); - } else { - CCTK_FNAME(prolongate_3d_real8_3tl_o3) - ((const CCTK_REAL8*)srcs[0]->storage(), times[0], - (const CCTK_REAL8*)srcs[1]->storage(), times[1], - (const CCTK_REAL8*)srcs[2]->storage(), times[2], - srcshp[0], srcshp[1], srcshp[2], - (CCTK_REAL8*)storage(), time, - dstshp[0], dstshp[1], dstshp[2], - srcbbox, dstbbox, regbbox); - } - break; - case 5: - if (all (sext.stride() == dext.stride() * 2)) { - CCTK_FNAME(prolongate_3d_real8_3tl_o5_rf2) - ((const CCTK_REAL8*)srcs[0]->storage(), times[0], - (const CCTK_REAL8*)srcs[1]->storage(), times[1], - (const CCTK_REAL8*)srcs[2]->storage(), times[2], - srcshp[0], srcshp[1], srcshp[2], - (CCTK_REAL8*)storage(), time, - dstshp[0], dstshp[1], dstshp[2], - srcbbox, dstbbox, regbbox); - } else { - CCTK_FNAME(prolongate_3d_real8_3tl_o5) - ((const CCTK_REAL8*)srcs[0]->storage(), times[0], - (const CCTK_REAL8*)srcs[1]->storage(), times[1], - (const CCTK_REAL8*)srcs[2]->storage(), times[2], - srcshp[0], srcshp[1], srcshp[2], - (CCTK_REAL8*)storage(), time, - dstshp[0], dstshp[1], dstshp[2], - srcbbox, dstbbox, regbbox); - } - break; - case 7: - if (all (sext.stride() == dext.stride() * 2)) { - CCTK_FNAME(prolongate_3d_real8_3tl_o7_rf2) - ((const CCTK_REAL8*)srcs[0]->storage(), times[0], - (const CCTK_REAL8*)srcs[1]->storage(), times[1], - (const CCTK_REAL8*)srcs[2]->storage(), times[2], - srcshp[0], srcshp[1], srcshp[2], - (CCTK_REAL8*)storage(), time, - dstshp[0], dstshp[1], dstshp[2], - srcbbox, dstbbox, regbbox); - } else { - assert (0); - } - break; - default: - assert (0); - } - wtime_prolongate_Lagrange_2.stop(); - break; - - default: - assert (0); - } // switch (order_time) - break; - - case op_TVD: - switch (order_time) { - case 0: - wtime_prolongate_TVD_0.start(); - assert (times.size() == 1); - assert (abs(times[0] - time) < eps); - switch (order_space) { - case 0: - case 1: - CCTK_WARN (0, "There is no stencil for op=\"TVD\" with order_space=1"); - break; - case 2: - case 3: - CCTK_FNAME(prolongate_3d_real8_rf2) - ((const CCTK_REAL8*)srcs[0]->storage(), - srcshp[0], srcshp[1], srcshp[2], - (CCTK_REAL8*)storage(), - dstshp[0], dstshp[1], dstshp[2], - srcbbox, dstbbox, regbbox); -// CCTK_FNAME(prolongate_3d_real8_minmod) -// ((const CCTK_REAL8*)srcs[0]->storage(), -// srcshp[0], srcshp[1], srcshp[2], -// (CCTK_REAL8*)storage(), -// dstshp[0], dstshp[1], dstshp[2], -// srcbbox, dstbbox, regbbox); - break; - default: - assert (0); - } - wtime_prolongate_TVD_0.stop(); - break; - case 1: - wtime_prolongate_TVD_1.start(); - switch (order_space) { - case 1: - CCTK_WARN (0, "There is no stencil for op=\"TVD\" with order_space=1"); - break; - case 3: - CCTK_FNAME(prolongate_3d_real8_2tl_rf2) - ((const CCTK_REAL8*)srcs[0]->storage(), times[0], - (const CCTK_REAL8*)srcs[1]->storage(), times[1], - srcshp[0], srcshp[1], srcshp[2], - (CCTK_REAL8*)storage(), time, - dstshp[0], dstshp[1], dstshp[2], - srcbbox, dstbbox, regbbox); -// CCTK_FNAME(prolongate_3d_real8_2tl_minmod) -// ((const CCTK_REAL8*)srcs[0]->storage(), times[0], -// (const CCTK_REAL8*)srcs[1]->storage(), times[1], -// srcshp[0], srcshp[1], srcshp[2], -// (CCTK_REAL8*)storage(), time, -// dstshp[0], dstshp[1], dstshp[2], -// srcbbox, dstbbox, regbbox); - break; - default: - assert (0); - } - wtime_prolongate_TVD_1.stop(); - break; - case 2: - wtime_prolongate_TVD_2.start(); - switch (order_space) { - case 1: - CCTK_WARN (0, "There is no stencil for op=\"TVD\" with order_space=1"); - break; - case 3: - CCTK_FNAME(prolongate_3d_real8_3tl_rf2) - ((const CCTK_REAL8*)srcs[0]->storage(), times[0], - (const CCTK_REAL8*)srcs[1]->storage(), times[1], - (const CCTK_REAL8*)srcs[2]->storage(), times[2], - srcshp[0], srcshp[1], srcshp[2], - (CCTK_REAL8*)storage(), time, - dstshp[0], dstshp[1], dstshp[2], - srcbbox, dstbbox, regbbox); -// CCTK_FNAME(prolongate_3d_real8_3tl_minmod) -// ((const CCTK_REAL8*)srcs[0]->storage(), times[0], -// (const CCTK_REAL8*)srcs[1]->storage(), times[1], -// (const CCTK_REAL8*)srcs[2]->storage(), times[2], -// srcshp[0], srcshp[1], srcshp[2], -// (CCTK_REAL8*)storage(), time, -// dstshp[0], dstshp[1], dstshp[2], -// srcbbox, dstbbox, regbbox); - break; - default: - assert (0); - } - wtime_prolongate_TVD_2.stop(); - break; - default: - assert (0); - } // switch (order_time) - break; - -#ifndef OMIT_F90 case op_ENO: - switch (order_time) { - case 0: - wtime_prolongate_ENO_0.start(); - assert (times.size() == 1); - assert (abs(times[0] - time) < eps); - switch (order_space) { - case 1: - CCTK_WARN (0, "There is no stencil for op=\"ENO\" with order_space=1"); - break; - case 3: - CCTK_FNAME(prolongate_3d_real8_eno) - ((const CCTK_REAL8*)srcs[0]->storage(), - srcshp[0], srcshp[1], srcshp[2], - (CCTK_REAL8*)storage(), - dstshp[0], dstshp[1], dstshp[2], - srcbbox, dstbbox, regbbox); - break; - default: - assert (0); - } - wtime_prolongate_ENO_0.stop(); - break; + wtime_prolongate_ENO.start(); + switch (order_space) { case 1: - wtime_prolongate_ENO_1.start(); - switch (order_space) { - case 1: - CCTK_WARN (0, "There is no stencil for op=\"ENO\" with order_space=1"); - break; - case 3: - CCTK_FNAME(prolongate_3d_real8_2tl_eno) - ((const CCTK_REAL8*)srcs[0]->storage(), times[0], - (const CCTK_REAL8*)srcs[1]->storage(), times[1], - srcshp[0], srcshp[1], srcshp[2], - (CCTK_REAL8*)storage(), time, - dstshp[0], dstshp[1], dstshp[2], - srcbbox, dstbbox, regbbox); - break; - default: - assert (0); - } - wtime_prolongate_ENO_1.stop(); + CCTK_WARN (0, "There is no stencil for op=\"ENO\" with order_space=1"); break; - case 2: - wtime_prolongate_ENO_2.start(); - switch (order_space) { - case 1: - CCTK_WARN (0, "There is no stencil for op=\"ENO\" with order_space=1"); - break; - case 3: - CCTK_FNAME(prolongate_3d_real8_3tl_eno) - ((const CCTK_REAL8*)srcs[0]->storage(), times[0], - (const CCTK_REAL8*)srcs[1]->storage(), times[1], - (const CCTK_REAL8*)srcs[2]->storage(), times[2], - srcshp[0], srcshp[1], srcshp[2], - (CCTK_REAL8*)storage(), time, - dstshp[0], dstshp[1], dstshp[2], - srcbbox, dstbbox, regbbox); - break; - default: - assert (0); - } - wtime_prolongate_ENO_2.stop(); + case 3: + prolongate_3d_eno (static_cast <T const *> (src->storage()), + src->shape(), + static_cast <T *> (this->storage()), + this->shape(), + src->extent(), + this->extent(), + box); break; default: assert (0); - } // switch (order_time) + } + wtime_prolongate_ENO.stop(); break; -#else // #ifdef OMIT_F90 - CCTK_WARN (0, "ENO stencils are not supported in this configuration. Remove the option OMIT_F90 to use them."); -#endif // #ifdef OMIT_F90 -#ifndef OMIT_F90 case op_WENO: - switch (order_time) { - case 0: - wtime_prolongate_WENO_0.start(); - assert (times.size() == 1); - assert (abs(times[0] - time) < eps); - switch (order_space) { - case 1: - CCTK_WARN (0, "There is no stencil for op=\"WENO\" with order_space=1"); - break; - case 3: - CCTK_WARN (0, "There is no stencil for op=\"WENO\" with order_space=3"); - break; - case 5: - CCTK_FNAME(prolongate_3d_real8_weno) - ((const CCTK_REAL8*)srcs[0]->storage(), - srcshp[0], srcshp[1], srcshp[2], - (CCTK_REAL8*)storage(), - dstshp[0], dstshp[1], dstshp[2], - srcbbox, dstbbox, regbbox); - break; - default: - assert (0); - } - wtime_prolongate_WENO_0.stop(); - break; + wtime_prolongate_WENO.start(); + switch (order_space) { case 1: - wtime_prolongate_WENO_1.start(); - switch (order_space) { - case 1: - CCTK_WARN (0, "There is no stencil for op=\"WENO\" with order_space=1"); - break; - case 3: - CCTK_WARN (0, "There is no stencil for op=\"WENO\" with order_space=3"); - break; - case 5: - CCTK_FNAME(prolongate_3d_real8_2tl_weno) - ((const CCTK_REAL8*)srcs[0]->storage(), times[0], - (const CCTK_REAL8*)srcs[1]->storage(), times[1], - srcshp[0], srcshp[1], srcshp[2], - (CCTK_REAL8*)storage(), time, - dstshp[0], dstshp[1], dstshp[2], - srcbbox, dstbbox, regbbox); - break; - default: - assert (0); - } - wtime_prolongate_WENO_1.stop(); + CCTK_WARN (0, "There is no stencil for op=\"WENO\" with order_space=1"); break; - case 2: - wtime_prolongate_WENO_2.start(); - switch (order_space) { - case 1: - CCTK_WARN (0, "There is no stencil for op=\"WENO\" with order_space=1"); - break; - case 3: - CCTK_WARN (0, "There is no stencil for op=\"WENO\" with order_space=3"); - break; - case 5: - CCTK_FNAME(prolongate_3d_real8_3tl_weno) - ((const CCTK_REAL8*)srcs[0]->storage(), times[0], - (const CCTK_REAL8*)srcs[1]->storage(), times[1], - (const CCTK_REAL8*)srcs[2]->storage(), times[2], - srcshp[0], srcshp[1], srcshp[2], - (CCTK_REAL8*)storage(), time, - dstshp[0], dstshp[1], dstshp[2], - srcbbox, dstbbox, regbbox); - break; - default: - assert (0); - } - wtime_prolongate_WENO_2.stop(); + case 3: + CCTK_WARN (0, "There is no stencil for op=\"WENO\" with order_space=3"); + break; + case 5: + prolongate_3d_eno (static_cast <T const *> (src->storage()), + src->shape(), + static_cast <T *> (this->storage()), + this->shape(), + src->extent(), + this->extent(), + box); break; default: assert (0); - } // switch (order_time) + } + wtime_prolongate_WENO.stop(); break; -#else // #ifdef OMIT_F90 - CCTK_WARN (0, "ENO stencils are not supported in this configuration. Remove the option OMIT_F90 to use them."); -#endif // #ifdef OMIT_F90 default: assert(0); @@ -1707,138 +764,138 @@ void data<T> wtime_prolongate.stop(); } -template<> -void data<CCTK_REAL8> -::Check_that_the_times_are_consistent (const vector<CCTK_REAL> & times, - const CCTK_REAL time) +template <> +void data <CCTK_INT> +::interpolate_prolongate (data const * const src, + ibbox const & box, + int const order_space) { - assert (times.size() > 0); - CCTK_REAL min_time = times[0]; - CCTK_REAL max_time = times[0]; - for (size_t tl=1; tl<times.size(); ++tl) { - min_time = min(min_time, times[tl]); - max_time = max(max_time, times[tl]); - } - if (transport_operator != op_copy) { - if (time < min_time - eps || time > max_time + eps) { - ostringstream buf; - buf << "Internal error: extrapolation in time." - << " time=" << time - << " times=" << times; - CCTK_WARN (0, buf.str().c_str()); - } -#if 0 - // We cannot check because we do not know delta_time - } else { - if (delta_time > 0) { - if (time > max_time + eps) { - ostringstream buf; - buf << "Internal error: extrapolation into the future." - << " time=" << time - << " times=" << times; - CCTK_WARN (0, buf.str().c_str()); - } - } else { - if (time < min_time - eps) { - ostringstream buf; - buf << "Internal error: extrapolation into the past." - << " time=" << time - << " times=" << times; - CCTK_WARN (0, buf.str().c_str()); - } - } -#endif - } + CCTK_WARN (0, "Data type not supported"); } -template<> -bool data<CCTK_REAL8> -::try_without_time_interpolation (const vector<const gdata*> & gsrcs, - const vector<CCTK_REAL> & times, - const ibbox& box, const CCTK_REAL time, - const int order_space, - const int order_time) + + +template <typename T> +void data <T> +::interpolate_restrict (data const * const src, + ibbox const & box, + int const order_space) { - for (size_t tl=0; tl<times.size(); ++tl) { - if (abs(times[tl] - time) < eps) { - vector<const gdata*> my_gsrcs(1); - vector<CCTK_REAL> my_times(1); - my_gsrcs[0] = gsrcs[tl]; - my_times[0] = times[tl]; - const int my_order_time = 0; - interpolate_from_innerloop - (my_gsrcs, my_times, box, time, order_space, my_order_time); - return true; + wtime_restrict.start(); + + switch (transport_operator) { + + case op_copy: + case op_Lagrange: + case op_ENO: + case op_WENO: + // enum centering { vertex_centered, cell_centered }; + switch (cent) { + case vertex_centered: + restrict_3d_rf2 (static_cast <T const *> (src->storage()), + src->shape(), + static_cast <T *> (this->storage()), + this->shape(), + src->extent(), + this->extent(), + box); + break; + case cell_centered: + restrict_3d_cc_rf2 (static_cast <T const *> (src->storage()), + src->shape(), + static_cast <T *> (this->storage()), + this->shape(), + src->extent(), + this->extent(), + box); + break; + default: + assert (0); } + break; + + default: + assert(0); } - return false; + + wtime_restrict.stop(); } -template<> -void data<CCTK_REAL8> -::interpolate_from_innerloop (const vector<const gdata*> gsrcs, - const vector<CCTK_REAL> times, - const ibbox& box, const CCTK_REAL time, - const int order_space, - const int order_time) +template <> +void data <CCTK_INT> +::interpolate_restrict (data const * const src, + ibbox const & box, + int const order_space) { - assert (has_storage()); - assert (all(box.lower()>=extent().lower())); - assert (all(box.upper()<=extent().upper())); - assert (all(box.stride()==extent().stride())); - assert (all((box.lower()-extent().lower())%box.stride() == 0)); - - vector<const data*> srcs(gsrcs.size()); - - for (int t=0; t<(int)srcs.size(); ++t) - srcs[t] = (const data*)gsrcs[t]; - - assert (srcs.size() == times.size() && srcs.size()>0); - - for (int t=0; t<(int)srcs.size(); ++t) { - assert (srcs[t]->has_storage()); - assert (all(box.lower()>=srcs[t]->extent().lower())); - assert (all(box.upper()<=srcs[t]->extent().upper())); - } - - assert (proc() == srcs[0]->proc()); - - assert (dist::rank() == proc()); - - Check_that_the_times_are_consistent (times, time); + CCTK_WARN (0, "Data type not supported"); +} - bool did_time_interpolation = false; - if (times.size() > 1) { - // try to avoid time interpolation if possible - did_time_interpolation = - try_without_time_interpolation - (gsrcs, times, box, time, order_space, order_time); - } - - if (not did_time_interpolation) { - const ibbox& sext = srcs[0]->extent(); - const ibbox& dext = extent(); - - assert (all(dext.stride() == box.stride())); - if (all(sext.stride() < dext.stride())) { +template <typename T> +void data <T> +::time_interpolate (vector <data *> const & srcs, + ibbox const & box, + vector <CCTK_REAL> const & times, + CCTK_REAL const time, + int const order_time) +{ + switch (order_time) { - assert (times.size() == 1); - assert (abs(times[0] - time) < eps); - - interpolate_restrict (srcs, times, box); + case 0: + // We could handle this, but this points to an inefficiency + assert (0); - } else if (all(sext.stride() > dext.stride())) { + case 1: + assert (times.size() >= 2); + interpolate_3d_2tl (static_cast <T const *> (srcs.at(0)->storage()), + times.at(0), + static_cast <T const *> (srcs.at(1)->storage()), + times.at(1), + srcs.at(0)->shape(), + static_cast <T *> (this->storage()), + time, + this->shape(), + srcs.at(0)->extent(), + this->extent(), + box); + break; - interpolate_prolongate (srcs, times, box, time, order_space, order_time); + case 2: + assert (times.size() >= 3); + interpolate_3d_3tl (static_cast <T const *> (srcs.at(0)->storage()), + times.at(0), + static_cast <T const *> (srcs.at(1)->storage()), + times.at(1), + static_cast <T const *> (srcs.at(2)->storage()), + times.at(2), + srcs.at(0)->shape(), + static_cast <T *> (this->storage()), + time, + this->shape(), + srcs.at(0)->extent(), + this->extent(), + box); + break; - } else { - assert (0); - } + default: + assert (0); } } +template <> +void data <CCTK_INT> +::time_interpolate (vector <data *> const & srcs, + ibbox const & box, + vector <CCTK_REAL> const & times, + CCTK_REAL const time, + int const order_time) +{ + CCTK_WARN (0, "Data type not supported"); +} + + + // Output template<typename T> ostream& data<T>::output (ostream& os) const diff --git a/Carpet/CarpetLib/src/data.hh b/Carpet/CarpetLib/src/data.hh index c1c1934be..415345c06 100644 --- a/Carpet/CarpetLib/src/data.hh +++ b/Carpet/CarpetLib/src/data.hh @@ -45,11 +45,13 @@ public: // Constructors data (const int varindex = -1, + const centering cent = error_centered, const operator_type transport_operator = op_error, const int vectorlength = 1, const int vectorindex = 0, data* const vectorleader = NULL, const int tag = -1); - data (const int varindex, const operator_type transport_operator, + data (const int varindex, + const centering cent, const operator_type transport_operator, const int vectorlength, const int vectorindex, data* const vectorleader, const ibbox& extent, const int proc); @@ -59,6 +61,7 @@ public: // Pseudo constructors virtual data* make_typed (const int varindex, + const centering cent, const operator_type transport_operator, const int tag) const; @@ -147,47 +150,43 @@ private: public: void copy_from_innerloop (const gdata* gsrc, const ibbox& box); - void interpolate_from_innerloop (const vector<const gdata*> gsrcs, - const vector<CCTK_REAL> times, + void interpolate_from_innerloop (const vector<const gdata*>& gsrcs, + const vector<CCTK_REAL>& times, const ibbox& box, const CCTK_REAL time, const int order_space, const int order_time); +private: + void interpolate_time (vector <data const *> const & srcs, + vector <CCTK_REAL> const & times, + ibbox const & box, + CCTK_REAL const time, + int const order_space, + int const order_time); + void interpolate_p_r (data const * const src, + ibbox const & box, + int const order_space); + void interpolate_p_vc_cc (data const * const src, + ibbox const & box, + int const order_space); + void interpolate_prolongate (data const * src, + ibbox const & box, + int order_space); + void interpolate_restrict (data const * src, + ibbox const & box, + int order_space); + void time_interpolate (vector <data *> const & srcs, + ibbox const & box, + vector <CCTK_REAL> const & times, + CCTK_REAL time, + int order_time); public: // Output ostream& output (ostream& os) const; -private: - bool try_without_time_interpolation (const vector<const gdata*> & gsrcs, - const vector<CCTK_REAL> & times, - const ibbox& box, const CCTK_REAL time, - const int order_space, - const int order_time); - void interpolate_restrict (const vector<const data<T>*> & gsrcs, - const vector<CCTK_REAL> & times, - const ibbox& box); - void interpolate_prolongate (const vector<const data<T>*> & gsrcs, - const vector<CCTK_REAL> & times, - const ibbox& box, const CCTK_REAL time, - const int order_space, - const int order_time); - void Check_that_the_times_are_consistent ( const vector<CCTK_REAL> & times, - const CCTK_REAL time ); friend ostream & operator << <T> ( ostream & os, const data<T> & d ); }; - - -// Declare a specialisation -template<> -void data<CCTK_REAL8> -::interpolate_from_innerloop (const vector<const gdata*> gsrcs, - const vector<CCTK_REAL> times, - const ibbox& box, const CCTK_REAL time, - const int order_space, - const int order_time); - - #endif // DATA_HH diff --git a/Carpet/CarpetLib/src/defs.hh b/Carpet/CarpetLib/src/defs.hh index 21272b58e..3e2bc1734 100644 --- a/Carpet/CarpetLib/src/defs.hh +++ b/Carpet/CarpetLib/src/defs.hh @@ -53,7 +53,7 @@ typedef vect<vect<int,dim>,2> i2vect; // A general type -enum centering { vertex_centered, cell_centered }; +enum centering { error_centered, vertex_centered, cell_centered }; diff --git a/Carpet/CarpetLib/src/gdata.cc b/Carpet/CarpetLib/src/gdata.cc index f275ef02a..207cc2624 100644 --- a/Carpet/CarpetLib/src/gdata.cc +++ b/Carpet/CarpetLib/src/gdata.cc @@ -38,9 +38,11 @@ static int nexttag () // Constructors gdata::gdata (const int varindex_, + const centering cent_, const operator_type transport_operator_, const int tag_) : varindex(varindex_), + cent(cent_), transport_operator(transport_operator_), _has_storage(false), comm_active(false), @@ -483,7 +485,7 @@ void gdata int typesize; MPI_Type_size (b->datatype(), & typesize); - gdata * tmp = src->make_typed (varindex, transport_operator, tag); + gdata * tmp = src->make_typed (varindex, cent, transport_operator, tag); tmp->allocate (box, src->proc(), b->pointer()); tmp->interpolate_from_innerloop (srcs, times, box, time, order_space, order_time); @@ -531,7 +533,7 @@ void gdata assert (fillstate <= (int)procbuf.sendbufsize * datatypesize); // interpolate this processor's data into the send buffer - gdata* tmp = src->make_typed (varindex, transport_operator, tag); + gdata* tmp = src->make_typed (varindex, cent, transport_operator, tag); tmp->allocate (box, src->proc(), procbuf.sendbuf); tmp->interpolate_from_innerloop (srcs, times, box, time, order_space, order_time); diff --git a/Carpet/CarpetLib/src/gdata.hh b/Carpet/CarpetLib/src/gdata.hh index 7845d8fd9..b97a3e010 100644 --- a/Carpet/CarpetLib/src/gdata.hh +++ b/Carpet/CarpetLib/src/gdata.hh @@ -30,6 +30,7 @@ protected: // should be readonly // Fields const int varindex; // Cactus variable index, or -1 + centering cent; operator_type transport_operator; bool _has_storage; // has storage associated (on some processor) @@ -55,6 +56,7 @@ public: // Constructors gdata (const int varindex, + const centering cent = error_centered, const operator_type transport_operator = op_error, const int tag = -1); @@ -64,6 +66,7 @@ public: // Pseudo constructors virtual gdata* make_typed (const int varindex, + const centering cent = error_centered, const operator_type transport_operator = op_error, const int tag = -1) const = 0; @@ -193,8 +196,8 @@ private: virtual void copy_from_innerloop (const gdata* src, const ibbox& box) = 0; virtual void - interpolate_from_innerloop (const vector<const gdata*> srcs, - const vector<CCTK_REAL> times, + interpolate_from_innerloop (const vector<const gdata*>& srcs, + const vector<CCTK_REAL>& times, const ibbox& box, const CCTK_REAL time, const int order_space, diff --git a/Carpet/CarpetLib/src/gf.hh b/Carpet/CarpetLib/src/gf.hh index 36891b86d..b4f2e211d 100644 --- a/Carpet/CarpetLib/src/gf.hh +++ b/Carpet/CarpetLib/src/gf.hh @@ -50,7 +50,8 @@ protected: virtual gdata* typed_data (int tl, int rl, int c, int ml) { - return new data<T>(this->varindex, this->transport_operator, + return new data<T>(this->varindex, + h.refcent, this->transport_operator, this->vectorlength, this->vectorindex, this->vectorleader ? (data<T>*)(*this->vectorleader)(tl,rl,c,ml) diff --git a/Carpet/CarpetLib/src/interpolate_3d_2tl.cc b/Carpet/CarpetLib/src/interpolate_3d_2tl.cc new file mode 100644 index 000000000..27b290733 --- /dev/null +++ b/Carpet/CarpetLib/src/interpolate_3d_2tl.cc @@ -0,0 +1,199 @@ +#include <algorithm> +#include <cassert> +#include <cmath> +#include <cstdlib> + +#include <cctk.h> +#include <cctk_Parameters.h> + +#include "operator_prototypes.hh" +#include "typeprops.hh" + +using namespace std; + + + +namespace CarpetLib { + + + +#define SRCIND3(i,j,k) \ + index3 (srcioff + (i), srcjoff + (j), srckoff + (k), \ + srciext, srcjext, srckext) +#define DSTIND3(i,j,k) \ + index3 (dstioff + (i), dstjoff + (j), dstkoff + (k), \ + dstiext, dstjext, dstkext) + + + + template <typename T> + void + interpolate_3d_2tl (T const * restrict const src1, + CCTK_REAL const t1, + T const * restrict const src2, + CCTK_REAL const t2, + ivect3 const & srcext, + T * restrict const dst, + CCTK_REAL const t, + ivect3 const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox) + { + typedef typename typeprops<T>::real RT; + + + +#if 0 + // This is already guaranteed by bbox + if (any (srcbbox.stride() == 0 or + dstbbox.stride() == 0 or + regbbox.stride() == 0)) + { + CCTK_WARN (0, "Internal error: stride is zero"); + } +#endif + + if (any (srcbbox.stride() != regbbox.stride() or + dstbbox.stride() != regbbox.stride())) + { + CCTK_WARN (0, "Internal error: strides disagree"); + } + + if (any (srcbbox.stride() != dstbbox.stride())) { + CCTK_WARN (0, "Internal error: strides disagree"); + } + +#if 0 + // This needs to be allowed for cell centring + if (any (srcbbox.lower() % srcbbox.stride() != 0 or + dstbbox.lower() % dstbbox.stride() != 0 or + regbbox.lower() % regbbox.stride() != 0)) + { + CCTK_WARN (0, "Internal error: array origins are not integer multiples of the strides"); + } +#endif + + // This could be handled, but is likely to point to an error + // elsewhere + if (regbbox.empty()) { + CCTK_WARN (0, "Internal error: region extent is empty"); + } + +#if 0 + // This is already guaranteed by bbox + if (any ((srcbbox.upper() - srcbbox.lower()) % srcbbox.stride() != 0 or + (dstbbox.upper() - dstbbox.lower()) % dstbbox.stride() != 0 or + (regbbox.upper() - regbbox.lower()) % regbbox.stride() != 0)) + { + CCTK_WARN (0, "Internal error: array extents are not integer multiples of the strides"); + } +#endif + + if (not regbbox.is_contained_in(srcbbox) or + not regbbox.is_contained_in(dstbbox)) + { + CCTK_WARN (0, "Internal error: region extent is not contained in array extent"); + } + + if (any (srcext != srcbbox.shape() / srcbbox.stride() or + dstext != dstbbox.shape() / dstbbox.stride())) + { + CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes"); + } + + + + ivect3 const regext = regbbox.shape() / regbbox.stride(); + assert (all ((regbbox.lower() - srcbbox.lower()) % srcbbox.stride() == 0)); + ivect3 const srcoff = (regbbox.lower() - srcbbox.lower()) / srcbbox.stride(); + assert (all ((regbbox.lower() - dstbbox.lower()) % dstbbox.stride() == 0)); + ivect3 const dstoff = (regbbox.lower() - dstbbox.lower()) / dstbbox.stride(); + + + + size_t const srciext = srcext[0]; + size_t const srcjext = srcext[1]; + size_t const srckext = srcext[2]; + + size_t const dstiext = dstext[0]; + size_t const dstjext = dstext[1]; + size_t const dstkext = dstext[2]; + + size_t const regiext = regext[0]; + size_t const regjext = regext[1]; + size_t const regkext = regext[2]; + + size_t const srcioff = srcoff[0]; + size_t const srcjoff = srcoff[1]; + size_t const srckoff = srcoff[2]; + + size_t const dstioff = dstoff[0]; + size_t const dstjoff = dstoff[1]; + size_t const dstkoff = dstoff[2]; + + + + // Linear (first order) interpolation + + RT const eps = 1.0e-10; + if (abs (t1 - t2) < eps) { + CCTK_WARN (0, "Internal error: arrays have same time"); + } + if (t < min (t1, t2) - eps or t > max (t1, t2) + eps) { + CCTK_WARN (0, "Internal error: extrapolation in time"); + } + + RT const s1fac = (t - t2) / (t1 - t2); + RT const s2fac = (t - t1) / (t2 - t1); + + + + // Loop over region + for (size_t k=0; k<regkext; ++k) { + for (size_t j=0; j<regjext; ++j) { + for (size_t i=0; i<regiext; ++i) { + + dst [DSTIND3(i, j, k)] = + + s1fac * src1 [SRCIND3(i, j, k)] + + s2fac * src2 [SRCIND3(i, j, k)]; + + } + } + } + + } + + + + template + void + interpolate_3d_2tl (CCTK_REAL const * restrict const src1, + CCTK_REAL const t1, + CCTK_REAL const * restrict const src2, + CCTK_REAL const t2, + ivect3 const & srcext, + CCTK_REAL * restrict const dst, + CCTK_REAL const t, + ivect3 const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox); + + template + void + interpolate_3d_2tl (CCTK_COMPLEX const * restrict const src1, + CCTK_REAL const t1, + CCTK_COMPLEX const * restrict const src2, + CCTK_REAL const t2, + ivect3 const & srcext, + CCTK_COMPLEX * restrict const dst, + CCTK_REAL const t, + ivect3 const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox); + + + +} // namespace CarpetLib diff --git a/Carpet/CarpetLib/src/interpolate_3d_3tl.cc b/Carpet/CarpetLib/src/interpolate_3d_3tl.cc new file mode 100644 index 000000000..04d0e1e94 --- /dev/null +++ b/Carpet/CarpetLib/src/interpolate_3d_3tl.cc @@ -0,0 +1,208 @@ +#include <algorithm> +#include <cassert> +#include <cmath> +#include <cstdlib> + +#include <cctk.h> +#include <cctk_Parameters.h> + +#include "operator_prototypes.hh" +#include "typeprops.hh" + +using namespace std; + + + +namespace CarpetLib { + + + +#define SRCIND3(i,j,k) \ + index3 (srcioff + (i), srcjoff + (j), srckoff + (k), \ + srciext, srcjext, srckext) +#define DSTIND3(i,j,k) \ + index3 (dstioff + (i), dstjoff + (j), dstkoff + (k), \ + dstiext, dstjext, dstkext) + + + + template <typename T> + void + interpolate_3d_3tl (T const * restrict const src1, + CCTK_REAL const t1, + T const * restrict const src2, + CCTK_REAL const t2, + T const * restrict const src3, + CCTK_REAL const t3, + ivect3 const & srcext, + T * restrict const dst, + CCTK_REAL const t, + ivect3 const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox) + { + typedef typename typeprops<T>::real RT; + + + +#if 0 + // This is already guaranteed by bbox + if (any (srcbbox.stride() == 0 or + dstbbox.stride() == 0 or + regbbox.stride() == 0)) + { + CCTK_WARN (0, "Internal error: stride is zero"); + } +#endif + + if (any (srcbbox.stride() != regbbox.stride() or + dstbbox.stride() != regbbox.stride())) + { + CCTK_WARN (0, "Internal error: strides disagree"); + } + + if (any (srcbbox.stride() != dstbbox.stride())) { + CCTK_WARN (0, "Internal error: strides disagree"); + } + +#if 0 + // This needs to be allowed for cell centring + if (any (srcbbox.lower() % srcbbox.stride() != 0 or + dstbbox.lower() % dstbbox.stride() != 0 or + regbbox.lower() % regbbox.stride() != 0)) + { + CCTK_WARN (0, "Internal error: array origins are not integer multiples of the strides"); + } +#endif + + // This could be handled, but is likely to point to an error + // elsewhere + if (regbbox.empty()) { + CCTK_WARN (0, "Internal error: region extent is empty"); + } + +#if 0 + // This is already guaranteed by bbox + if (any ((srcbbox.upper() - srcbbox.lower()) % srcbbox.stride() != 0 or + (dstbbox.upper() - dstbbox.lower()) % dstbbox.stride() != 0 or + (regbbox.upper() - regbbox.lower()) % regbbox.stride() != 0)) + { + CCTK_WARN (0, "Internal error: array extents are not integer multiples of the strides"); + } +#endif + + if (not regbbox.is_contained_in(srcbbox) or + not regbbox.is_contained_in(dstbbox)) + { + CCTK_WARN (0, "Internal error: region extent is not contained in array extent"); + } + + if (any (srcext != srcbbox.shape() / srcbbox.stride() or + dstext != dstbbox.shape() / dstbbox.stride())) + { + CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes"); + } + + + + ivect3 const regext = regbbox.shape() / regbbox.stride(); + assert (all ((regbbox.lower() - srcbbox.lower()) % srcbbox.stride() == 0)); + ivect3 const srcoff = (regbbox.lower() - srcbbox.lower()) / srcbbox.stride(); + assert (all ((regbbox.lower() - dstbbox.lower()) % dstbbox.stride() == 0)); + ivect3 const dstoff = (regbbox.lower() - dstbbox.lower()) / dstbbox.stride(); + + + + size_t const srciext = srcext[0]; + size_t const srcjext = srcext[1]; + size_t const srckext = srcext[2]; + + size_t const dstiext = dstext[0]; + size_t const dstjext = dstext[1]; + size_t const dstkext = dstext[2]; + + size_t const regiext = regext[0]; + size_t const regjext = regext[1]; + size_t const regkext = regext[2]; + + size_t const srcioff = srcoff[0]; + size_t const srcjoff = srcoff[1]; + size_t const srckoff = srcoff[2]; + + size_t const dstioff = dstoff[0]; + size_t const dstjoff = dstoff[1]; + size_t const dstkoff = dstoff[2]; + + + + // Quadratic (second order) interpolation + + RT const eps = 1.0e-10; + + if (abs (t1 - t2) < eps or abs (t1 - t3) < eps or abs (t2 - t3) < eps) { + CCTK_WARN (0, "Internal error: arrays have same time"); + } + if (t < min (min (t1, t2), t3) - eps or t > max (max (t1, t2), t3) + eps) { + CCTK_WARN (0, "Internal error: extrapolation in time"); + } + + RT const s1fac = (t - t2) * (t - t3) / ((t1 - t2) * (t1 - t3)); + RT const s2fac = (t - t1) * (t - t3) / ((t2 - t1) * (t2 - t3)); + RT const s3fac = (t - t1) * (t - t2) / ((t3 - t1) * (t3 - t2)); + + + + // Loop over region + for (size_t k=0; k<regkext; ++k) { + for (size_t j=0; j<regjext; ++j) { + for (size_t i=0; i<regiext; ++i) { + + dst [DSTIND3(i, j, k)] = + + s1fac * src1 [SRCIND3(i, j, k)] + + s2fac * src2 [SRCIND3(i, j, k)] + + s3fac * src3 [SRCIND3(i, j, k)]; + + } + } + } + + } + + + + template + void + interpolate_3d_3tl (CCTK_REAL const * restrict const src1, + CCTK_REAL const t1, + CCTK_REAL const * restrict const src2, + CCTK_REAL const t2, + CCTK_REAL const * restrict const src3, + CCTK_REAL const t3, + ivect3 const & srcext, + CCTK_REAL * restrict const dst, + CCTK_REAL const t, + ivect3 const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox); + + template + void + interpolate_3d_3tl (CCTK_COMPLEX const * restrict const src1, + CCTK_REAL const t1, + CCTK_COMPLEX const * restrict const src2, + CCTK_REAL const t2, + CCTK_COMPLEX const * restrict const src3, + CCTK_REAL const t3, + ivect3 const & srcext, + CCTK_COMPLEX * restrict const dst, + CCTK_REAL const t, + ivect3 const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox); + + + +} // namespace CarpetLib diff --git a/Carpet/CarpetLib/src/make.code.defn b/Carpet/CarpetLib/src/make.code.defn index 6c85dc167..3b47c6016 100644 --- a/Carpet/CarpetLib/src/make.code.defn +++ b/Carpet/CarpetLib/src/make.code.defn @@ -15,45 +15,19 @@ SRCS = bbox.cc \ mem.cc \ region.cc \ th.cc \ + timestat.cc \ vect.cc \ - checkindex.c \ - copy_3d_complex16.F77 \ - copy_3d_int4.F77 \ - copy_3d_real8.F77 \ - prolongate_3d_real8.F77 \ - prolongate_3d_real8_rf2.F77 \ - prolongate_3d_real8_o3.F77 \ - prolongate_3d_real8_o3_rf2.F77 \ - prolongate_3d_real8_o5.F77 \ - prolongate_3d_real8_o5_rf2.F77 \ - prolongate_3d_real8_o7.F77 \ - prolongate_3d_real8_o7_rf2.F77 \ - prolongate_3d_real8_2tl.F77 \ - prolongate_3d_real8_2tl_rf2.F77 \ - prolongate_3d_real8_2tl_o3.F77 \ - prolongate_3d_real8_2tl_o3_rf2.F77 \ - prolongate_3d_real8_2tl_o5.F77 \ - prolongate_3d_real8_2tl_o5_rf2.F77 \ - prolongate_3d_real8_2tl_o7_rf2.F77 \ - prolongate_3d_real8_3tl.F77 \ - prolongate_3d_real8_3tl_rf2.F77 \ - prolongate_3d_real8_3tl_o3.F77 \ - prolongate_3d_real8_3tl_o3_rf2.F77 \ - prolongate_3d_real8_3tl_o5.F77 \ - prolongate_3d_real8_3tl_o5_rf2.F77 \ - prolongate_3d_real8_3tl_o7_rf2.F77 \ - prolongate_3d_real8_minmod.F77 \ - prolongate_3d_real8_2tl_minmod.F77 \ - prolongate_3d_real8_3tl_minmod.F77 \ + copy_3d.cc \ + interpolate_3d_2tl.cc \ + interpolate_3d_3tl.cc \ + restrict_3d_cc_rf2.cc \ + restrict_3d_rf2.cc \ + prolongate_3d_cc_rf2.cc \ + prolongate_3d_o1_rf2.cc \ + prolongate_3d_o3_rf2.cc \ + prolongate_3d_o5_rf2.cc \ prolongate_3d_real8_eno.F90 \ - prolongate_3d_real8_2tl_eno.F90 \ - prolongate_3d_real8_3tl_eno.F90 \ - prolongate_3d_real8_weno.F90 \ - prolongate_3d_real8_2tl_weno.F90 \ - prolongate_3d_real8_3tl_weno.F90 \ - restrict_3d_real8.F77 \ - restrict_3d_real8_rf2.F77 \ - timestat.cc + prolongate_3d_real8_weno.F90 # Subdirectories containing source files SUBDIRS = diff --git a/Carpet/CarpetLib/src/operator_prototypes.hh b/Carpet/CarpetLib/src/operator_prototypes.hh new file mode 100644 index 000000000..05079ff22 --- /dev/null +++ b/Carpet/CarpetLib/src/operator_prototypes.hh @@ -0,0 +1,171 @@ +#ifndef OPERATOR_PROTOTYPES +#define OPERATOR_PROTOTYPES + +#include <cstdlib> + +#include <cctk.h> + +#include <vect.hh> +#include <bbox.hh> + + + +namespace CarpetLib { + + using namespace std; + + + + static inline + size_t + index3 (size_t const i, size_t const j, size_t const k, + size_t const exti, size_t const extj, size_t const extk) + { +#ifndef CARPET_OPTIMISE + assert (static_cast <ptrdiff_t> (i) >= 0 and i < exti); + assert (static_cast <ptrdiff_t> (j) >= 0 and j < extj); + assert (static_cast <ptrdiff_t> (k) >= 0 and k < extk); +#endif + + return i + exti * (j + extj * k); + } + + + + static int const dim3 = 3; + + typedef vect <bool, dim3> bvect3; + typedef vect <int, dim3> ivect3; + typedef bbox <int, dim3> ibbox3; + + static int const reffact2 = 2; + + + + template <typename T> + void + copy_3d (T const * restrict const src, + ivect3 const & srcext, + T * restrict const dst, + ivect3 const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox); + + + + template <typename T> + void + prolongate_3d_o1_rf2 (T const * restrict const src, + ivect3 const & srcext, + T * restrict const dst, + ivect3 const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox); + + template <typename T> + void + prolongate_3d_o3_rf2 (T const * restrict const src, + ivect3 const & srcext, + T * restrict const dst, + ivect3 const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox); + + template <typename T> + void + prolongate_3d_o5_rf2 (T const * restrict const src, + ivect3 const & srcext, + T * restrict const dst, + ivect3 const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox); + + + + template <typename T> + void + restrict_3d_rf2 (T const * restrict const src, + ivect3 const & srcext, + T * restrict const dst, + ivect3 const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox); + + + + template <typename T> + void + interpolate_3d_2tl (T const * restrict const src1, + CCTK_REAL const t1, + T const * restrict const src2, + CCTK_REAL const t2, + ivect3 const & srcext, + T * restrict const dst, + CCTK_REAL const t, + ivect3 const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox); + + template <typename T> + void + interpolate_3d_3tl (T const * restrict const src1, + CCTK_REAL const t1, + T const * restrict const src2, + CCTK_REAL const t2, + T const * restrict const src3, + CCTK_REAL const t3, + ivect3 const & srcext, + T * restrict const dst, + CCTK_REAL const t, + ivect3 const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox); + + + + template <typename T> + void + prolongate_3d_cc_rf2_std2prim (T const * restrict const src, + ivect3 const & srcext, + T * restrict const dst, + ivect3 const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox); + + template <typename T> + void + prolongate_3d_cc_rf2_prim2std (T const * restrict const src, + ivect3 const & srcext, + T * restrict const dst, + ivect3 const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox); + + + + template <typename T> + void + restrict_3d_cc_rf2 (T const * restrict const src, + ivect3 const & srcext, + T * restrict const dst, + ivect3 const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox); + + + +} // namespace CarpetLib + + + +#endif // #ifndef OPERATOR_PROTOTYPES diff --git a/Carpet/CarpetLib/src/operators.hh b/Carpet/CarpetLib/src/operators.hh index 0a7828866..2efb06217 100644 --- a/Carpet/CarpetLib/src/operators.hh +++ b/Carpet/CarpetLib/src/operators.hh @@ -10,7 +10,6 @@ enum operator_type op_copy, // use simple copying for prolongation // (needs only one time level) op_Lagrange, // Lagrange interpolation (standard) - op_TVD, // use TVD stencils (for hydro) op_ENO, // use ENO stencils (for hydro) op_WENO // use WENO stencils (for hydro) }; diff --git a/Carpet/CarpetLib/src/prolongate_3d_cc_rf2.cc b/Carpet/CarpetLib/src/prolongate_3d_cc_rf2.cc new file mode 100644 index 000000000..e0748ea56 --- /dev/null +++ b/Carpet/CarpetLib/src/prolongate_3d_cc_rf2.cc @@ -0,0 +1,441 @@ +// See also Hern, "Numerical Relativity and Inhomogeneous +// Cosmologies", gr-qc/0004036, section 3.2, pp. 29 ff.; especially +// the last equation on page 37. + + + +#include <algorithm> +#include <cassert> +#include <cmath> + +#include <cctk.h> +#include <cctk_Parameters.h> + +#include "operator_prototypes.hh" +#include "typeprops.hh" + +using namespace std; + + + +namespace CarpetLib { + + + +#define SRCIND3(i,j,k) \ + index3 (srcioff + (i), srcjoff + (j), srckoff + (k), \ + srciext, srcjext, srckext) +#define DSTIND3(i,j,k) \ + index3 (dstioff + (i), dstjoff + (j), dstkoff + (k), \ + dstiext, dstjext, dstkext) + + + + // Convert from the "standard" form of the grid function to the + // "primitive" version, i.e., the antiderivative + + template <typename T> + void + prolongate_3d_cc_rf2_std2prim (T const * restrict const src, + ivect3 const & srcext, + T * restrict const dst, + ivect3 const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox) + { + DECLARE_CCTK_PARAMETERS; + + typedef typename typeprops<T>::real RT; + T (* const fromreal) (RT) = typeprops<T>::fromreal; + + + + if (any (srcbbox.stride() != regbbox.stride() or + dstbbox.stride() != regbbox.stride())) + { + CCTK_WARN (0, "Internal error: strides disagree"); + } + + if (any (srcbbox.stride() != dstbbox.stride())) { + CCTK_WARN (0, "Internal error: strides disagree"); + } + + // This could be handled, but is likely to point to an error + // elsewhere + if (regbbox.empty()) { + CCTK_WARN (0, "Internal error: region extent is empty"); + } + + if (not regbbox.is_contained_in(srcbbox) or + not regbbox.is_contained_in(dstbbox)) + { + CCTK_WARN (0, "Internal error: region extent is not contained in array extent"); + } + + if (any (srcext != srcbbox.shape() / srcbbox.stride() or + dstext != dstbbox.shape() / dstbbox.stride())) + { + CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes"); + } + + + + ivect3 const regext = regbbox.shape() / regbbox.stride(); + assert (all (regbbox.stride() % 2 == 0)); + assert (all ((regbbox.lower() - srcbbox.lower() + regbbox.stride() / 2) % + regbbox.stride() == 0)); + ivect3 const srcoff = + (regbbox.lower() - srcbbox.lower() + regbbox.stride() / 2) / + regbbox.stride(); + assert (all ((regbbox.lower() - dstbbox.lower()) % regbbox.stride() == 0)); + ivect3 const dstoff = + (regbbox.lower() - dstbbox.lower()) / regbbox.stride(); + + + + int const srciext = srcext[0]; + int const srcjext = srcext[1]; + int const srckext = srcext[2]; + + int const dstiext = dstext[0]; + int const dstjext = dstext[1]; + int const dstkext = dstext[2]; + + int const regiext = regext[0]; + int const regjext = regext[1]; + int const regkext = regext[2]; + + int const srcioff = srcoff[0]; + int const srcjoff = srcoff[1]; + int const srckoff = srcoff[2]; + + int const dstioff = dstoff[0]; + int const dstjoff = dstoff[1]; + int const dstkoff = dstoff[2]; + + + + T const zero = fromreal (0); + + + +#if 0 + // Original version + + // Initialize the corner + + dst [DSTIND3(0, 0, 0)] = + zero; + + // Compute the axis lines + + for (int i=1; i<regiext; ++i) { + dst [DSTIND3(i, 0, 0)] = + + dst [DSTIND3(i-1, 0, 0)] + + src [SRCIND3(i-1, 0, 0)]; + } + + for (int j=1; j<regjext; ++j) { + dst [DSTIND3(0, j, 0)] = + + dst [DSTIND3(0, j-1, 0)] + + src [SRCIND3(0, j-1, 0)]; + } + + for (int k=1; k<regkext; ++k) { + dst [DSTIND3(0, 0, k)] = + + dst [DSTIND3(0, 0, k-1)] + + src [SRCIND3(0, 0, k-1)]; + } + + // Compute the planes + + for (int j=1; j<regjext; ++j) { + for (int i=1; i<regiext; ++i) { + dst [DSTIND3(i, j, 0)] = + + dst [DSTIND3(i-1, j, 0)] + + dst [DSTIND3(i, j-1, 0)] + - dst [DSTIND3(i-1, j-1, 0)] + + src [SRCIND3(i-1, j-1, 0)]; + } + } + + for (int k=1; k<regkext; ++k) { + for (int i=1; i<regiext; ++i) { + dst [DSTIND3(i, 0, k)] = + + dst [DSTIND3(i-1, 0, k)] + + dst [DSTIND3(i, 0, k-1)] + - dst [DSTIND3(i-1, 0, k-1)] + + src [SRCIND3(i-1, 0, k-1)]; + } + } + + for (int k=1; k<regkext; ++k) { + for (int j=1; j<regjext; ++j) { + dst [DSTIND3(0, j, k)] = + + dst [DSTIND3(0, j-1, k)] + + dst [DSTIND3(0, j, k-1)] + - dst [DSTIND3(0, j-1, k-1)] + + src [SRCIND3(0, j-1, k-1)]; + } + } + + // Compute the interior + + for (int k=1; k<regkext; ++k) { + for (int j=1; j<regjext; ++j) { + for (int i=1; i<regiext; ++i) { + dst [DSTIND3(i, j, k)] = + + dst [DSTIND3(i-1, j, k)] + + dst [DSTIND3(i, j-1, k)] + + dst [DSTIND3(i, j, k-1)] + - 2 * dst [DSTIND3(i-1, j-1, k-1)] + + src [SRCIND3(i-1, j-1, k-1)]; + } + } + } + +#endif + +#if 1 + + for (int k=0; k<regkext; ++k) { + for (int j=0; j<regjext; ++j) { + for (int i=0; i<regiext; ++i) { + if (i==0 or j==0 or k==0) { + dst [DSTIND3(i, j, k)] = zero; + } else { + // // 1D + // dst [DSTIND1(i)] = + // + dst [DSTIND1(i-1)] + // + src [SRCIND1(i-1)]; + // // 2D + // dst [DSTIND2(i, j, k)] = + // + dst [DSTIND2(i-1, j)] + // + dst [DSTIND2(i, j-1)] + // - dst [DSTIND2(i-1, j-1)] + // + src [SRCIND2(i-1, j-1)]; + // 3D + dst [DSTIND3(i, j, k)] = + + dst [DSTIND3(i-1, j, k)] + + dst [DSTIND3(i, j-1, k)] + + dst [DSTIND3(i, j, k-1)] + - dst [DSTIND3(i, j-1, k-1)] + - dst [DSTIND3(i-1, j, k-1)] + - dst [DSTIND3(i-1, j-1, k)] + + dst [DSTIND3(i-1, j-1, k-1)] + + src [SRCIND3(i-1, j-1, k-1)]; + } + } + } + } + +#endif + +#if 0 + // For testing + +#warning "TODO" + for (int k=0; k<regkext; ++k) { + for (int j=0; j<regjext; ++j) { + for (int i=0; i<regiext; ++i) { + if (i==0 or j==0 or k==0) { + dst [DSTIND3(i, j, k)] = zero; + } else { + dst [DSTIND3(i, j, k)] = src [SRCIND3(i-1, j-1, k-1)]; + } + } + } + } + +#endif + + } + + + + template + void + prolongate_3d_cc_rf2_std2prim (CCTK_REAL const * restrict const src, + ivect3 const & srcext, + CCTK_REAL * restrict const dst, + ivect3 const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox); + + template + void + prolongate_3d_cc_rf2_std2prim (CCTK_COMPLEX const * restrict const src, + ivect3 const & srcext, + CCTK_COMPLEX * restrict const dst, + ivect3 const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox); + + + + // Convert from the "primitive" form of the grid function to the + // "standard" version + + template <typename T> + void + prolongate_3d_cc_rf2_prim2std (T const * restrict const src, + ivect const & srcext, + T * restrict const dst, + ivect const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox) + { + DECLARE_CCTK_PARAMETERS; + + + + if (any (srcbbox.stride() != regbbox.stride() or + dstbbox.stride() != regbbox.stride())) + { + CCTK_WARN (0, "Internal error: strides disagree"); + } + + if (any (srcbbox.stride() != dstbbox.stride())) { + CCTK_WARN (0, "Internal error: strides disagree"); + } + + // This could be handled, but is likely to point to an error + // elsewhere + if (regbbox.empty()) { + CCTK_WARN (0, "Internal error: region extent is empty"); + } + + if (not regbbox.is_contained_in(srcbbox) or + not regbbox.is_contained_in(dstbbox)) + { + CCTK_WARN (0, "Internal error: region extent is not contained in array extent"); + } + + if (any (srcext != srcbbox.shape() / srcbbox.stride() or + dstext != dstbbox.shape() / dstbbox.stride())) + { + CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes"); + } + + + + ivect3 const regext = regbbox.shape() / regbbox.stride(); + assert (all (regbbox.stride() % 2 == 0)); + assert (all ((regbbox.lower() - srcbbox.lower() - regbbox.stride() / 2) % + regbbox.stride() == 0)); + ivect3 const srcoff = + (regbbox.lower() - srcbbox.lower() - regbbox.stride() / 2) / + regbbox.stride(); + assert (all ((regbbox.lower() - dstbbox.lower()) % regbbox.stride() == 0)); + ivect3 const dstoff = + (regbbox.lower() - dstbbox.lower()) / regbbox.stride(); + + + + int const srciext = srcext[0]; + int const srcjext = srcext[1]; + int const srckext = srcext[2]; + + int const dstiext = dstext[0]; + int const dstjext = dstext[1]; + int const dstkext = dstext[2]; + + int const regiext = regext[0]; + int const regjext = regext[1]; + int const regkext = regext[2]; + + int const srcioff = srcoff[0]; + int const srcjoff = srcoff[1]; + int const srckoff = srcoff[2]; + + int const dstioff = dstoff[0]; + int const dstjoff = dstoff[1]; + int const dstkoff = dstoff[2]; + + + +#if 0 + // Original version + + // Compute the interior + + for (int k=0; k<regkext; ++k) { + for (int j=0; j<regjext; ++j) { + for (int i=0; i<regiext; ++i) { + dst [DSTIND3(i, j, k)] = + + src [SRCIND3(i+1, j+1, k+1)] + - src [SRCIND3(i, j+1, k+1)] + - src [SRCIND3(i+1, j, k+1)] + - src [SRCIND3(i+1, j+1, k)] + + 2 * src [SRCIND3(i-1, j-1, k-1)]; + } + } + } + +#endif + +#if 1 + + for (int k=0; k<regkext; ++k) { + for (int j=0; j<regjext; ++j) { + for (int i=0; i<regiext; ++i) { + dst [DSTIND3(i, j, k)] = reffact2 * + (- src [SRCIND3(i, j+1, k+1)] + - src [SRCIND3(i+1, j, k+1)] + - src [SRCIND3(i+1, j+1, k)] + + src [SRCIND3(i+1, j, k)] + + src [SRCIND3(i, j+1, k)] + + src [SRCIND3(i, j, k+1)] + - src [SRCIND3(i, j, k)] + + src [SRCIND3(i+1, j+1, k+1)]); + } + } + } + +#endif + +#if 0 + // For testing + +#warning "TODO" + for (int k=0; k<regkext; ++k) { + for (int j=0; j<regjext; ++j) { + for (int i=0; i<regiext; ++i) { + dst [DSTIND3(i, j, k)] = src [SRCIND3(i+1, j+1, k+1)]; + } + } + } + +#endif + + } + + + + template + void + prolongate_3d_cc_rf2_prim2std (CCTK_REAL const * restrict const src, + ivect const & srcext, + CCTK_REAL * restrict const dst, + ivect const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox); + + template + void + prolongate_3d_cc_rf2_prim2std (CCTK_COMPLEX const * restrict const src, + ivect const & srcext, + CCTK_COMPLEX * restrict const dst, + ivect const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox); + + + +} // namespace CarpetLib diff --git a/Carpet/CarpetLib/src/prolongate_3d_o1_rf2.cc b/Carpet/CarpetLib/src/prolongate_3d_o1_rf2.cc new file mode 100644 index 000000000..89bdb86a6 --- /dev/null +++ b/Carpet/CarpetLib/src/prolongate_3d_o1_rf2.cc @@ -0,0 +1,391 @@ +#include <algorithm> +#include <cassert> +#include <cmath> +#include <cstdlib> + +#include <cctk.h> +#include <cctk_Parameters.h> + +#include "operator_prototypes.hh" +#include "typeprops.hh" + +using namespace std; + + + +namespace CarpetLib { + + + +#define SRCIND3(i,j,k) \ + index3 (i, j, k, \ + srciext, srcjext, srckext) +#define DSTIND3(i,j,k) \ + index3 (i, j, k, \ + dstiext, dstjext, dstkext) + + + + template <typename T> + void + prolongate_3d_o1_rf2 (T const * restrict const src, + ivect3 const & srcext, + T * restrict const dst, + ivect3 const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox) + { + typedef typename typeprops<T>::real RT; + + + +#if 0 + // This is already guaranteed by bbox + if (any (srcbbox.stride() == 0 or + dstbbox.stride() == 0 or + regbbox.stride() == 0)) + { + CCTK_WARN (0, "Internal error: stride is zero"); + } +#endif + + if (any (srcbbox.stride() <= regbbox.stride() or + dstbbox.stride() != regbbox.stride())) + { + CCTK_WARN (0, "Internal error: strides disagree"); + } + + if (any (srcbbox.stride() != reffact2 * dstbbox.stride())) { + CCTK_WARN (0, "Internal error: source strides are not twice the destination strides"); + } + +#if 0 + // This needs to be allowed for cell centring + if (any (srcbbox.lower() % srcbbox.stride() != 0 or + dstbbox.lower() % dstbbox.stride() != 0 or + regbbox.lower() % regbbox.stride() != 0)) + { + CCTK_WARN (0, "Internal error: array origins are not integer multiples of the strides"); + } +#endif + + // This could be handled, but is likely to point to an error + // elsewhere + if (regbbox.empty()) { + CCTK_WARN (0, "Internal error: region extent is empty"); + } + +#if 0 + // This is already guaranteed by bbox + if (any ((srcbbox.upper() - srcbbox.lower()) % srcbbox.stride() != 0 or + (dstbbox.upper() - dstbbox.lower()) % dstbbox.stride() != 0 or + (regbbox.upper() - regbbox.lower()) % regbbox.stride() != 0)) + { + CCTK_WARN (0, "Internal error: array extents are not integer multiples of the strides"); + } +#endif + + + + ivect3 const regext = regbbox.shape() / regbbox.stride(); + assert (all ((regbbox.lower() - srcbbox.lower()) % regbbox.stride() == 0)); + ivect3 const srcoff = (regbbox.lower() - srcbbox.lower()) / regbbox.stride(); + assert (all ((regbbox.lower() - dstbbox.lower()) % regbbox.stride() == 0)); + ivect3 const dstoff = (regbbox.lower() - dstbbox.lower()) / regbbox.stride(); + + + + bvect3 const needoffsetlo = srcoff % reffact2 != 0 or regext > 1; + bvect3 const needoffsethi = (srcoff + regext - 1) % reffact2 != 0 or regext > 1; + ivect3 const offsetlo = either (needoffsetlo, 1, 0); + ivect3 const offsethi = either (needoffsethi, 1, 0); + + + + if (not regbbox.expand(offsetlo, offsethi).is_contained_in(srcbbox) or + not regbbox .is_contained_in(dstbbox)) + { + CCTK_WARN (0, "Internal error: region extent is not contained in array extent"); + } + + if (any (srcext != srcbbox.shape() / srcbbox.stride() or + dstext != dstbbox.shape() / dstbbox.stride())) + { + CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes"); + } + + + + size_t const srciext = srcext[0]; + size_t const srcjext = srcext[1]; + size_t const srckext = srcext[2]; + + size_t const dstiext = dstext[0]; + size_t const dstjext = dstext[1]; + size_t const dstkext = dstext[2]; + + size_t const regiext = regext[0]; + size_t const regjext = regext[1]; + size_t const regkext = regext[2]; + + size_t const srcioff = srcoff[0]; + size_t const srcjoff = srcoff[1]; + size_t const srckoff = srcoff[2]; + + size_t const dstioff = dstoff[0]; + size_t const dstjoff = dstoff[1]; + size_t const dstkoff = dstoff[2]; + + + + size_t const fi = srcioff % 2; + size_t const fj = srcjoff % 2; + size_t const fk = srckoff % 2; + + size_t const i0 = srcioff / 2; + size_t const j0 = srcjoff / 2; + size_t const k0 = srckoff / 2; + + RT const one = 1; + + RT const f1 = one/2; + RT const f2 = one/2; + + + + // Loop over fine region + // Label scheme: l 8 fk fj fi + + size_t is, js, ks; + size_t id, jd, kd; + size_t i, j, k; + + // begin k loop + k = 0; + ks = k0; + kd = dstkoff; + if (fk == 0) goto l80; + goto l81; + + // begin j loop + l80: + j = 0; + js = j0; + jd = dstjoff; + if (fj == 0) goto l800; + goto l801; + + // begin i loop + l800: + i = 0; + is = i0; + id = dstioff; + if (fi == 0) goto l8000; + goto l8001; + + // kernel + l8000: + dst[DSTIND3(id,jd,kd)] = src[SRCIND3(is,js,ks)]; + i = i+1; + id = id+1; + if (i < regiext) goto l8001; + goto l900; + + // kernel + l8001: + dst[DSTIND3(id,jd,kd)] = + + f1 * src[SRCIND3(is ,js,ks)] + + f2 * src[SRCIND3(is+1,js,ks)]; + i = i+1; + id = id+1; + is = is+1; + if (i < regiext) goto l8000; + goto l900; + + // end i loop + l900: + j = j+1; + jd = jd+1; + if (j < regjext) goto l801; + goto l90; + + // begin i loop + l801: + i = 0; + is = i0; + id = dstioff; + if (fi == 0) goto l8010; + goto l8011; + + // kernel + l8010: + dst[DSTIND3(id,jd,kd)] = + + f1 * src[SRCIND3(is,js ,ks)] + + f2 * src[SRCIND3(is,js+1,ks)]; + i = i+1; + id = id+1; + if (i < regiext) goto l8011; + goto l901; + + // kernel + l8011: + dst[DSTIND3(id,jd,kd)] = + + f1*f1 * src[SRCIND3(is ,js ,ks)] + + f2*f1 * src[SRCIND3(is+1,js ,ks)] + + f1*f2 * src[SRCIND3(is ,js+1,ks)] + + f2*f2 * src[SRCIND3(is+1,js+1,ks)]; + i = i+1; + id = id+1; + is = is+1; + if (i < regiext) goto l8010; + goto l901; + + // end i loop + l901: + j = j+1; + jd = jd+1; + js = js+1; + if (j < regjext) goto l800; + goto l90; + + // end j loop + l90: + k = k+1; + kd = kd+1; + if (k < regkext) goto l81; + goto l9; + + // begin j loop + l81: + j = 0; + js = j0; + jd = dstjoff; + if (fj == 0) goto l810; + goto l811; + + // begin i loop + l810: + i = 0; + is = i0; + id = dstioff; + if (fi == 0) goto l8100; + goto l8101; + + // kernel + l8100: + dst[DSTIND3(id,jd,kd)] = + + f1 * src[SRCIND3(is,js,ks )] + + f2 * src[SRCIND3(is,js,ks+1)]; + i = i+1; + id = id+1; + if (i < regiext) goto l8101; + goto l910; + + // kernel + l8101: + dst[DSTIND3(id,jd,kd)] = + + f1*f1 * src[SRCIND3(is ,js,ks )] + + f2*f1 * src[SRCIND3(is+1,js,ks )] + + f1*f2 * src[SRCIND3(is ,js,ks+1)] + + f2*f2 * src[SRCIND3(is+1,js,ks+1)]; + i = i+1; + id = id+1; + is = is+1; + if (i < regiext) goto l8100; + goto l910; + + // end i loop + l910: + j = j+1; + jd = jd+1; + if (j < regjext) goto l811; + goto l91; + + // begin i loop + l811: + i = 0; + is = i0; + id = dstioff; + if (fi == 0) goto l8110; + goto l8111; + + // kernel + l8110: + dst[DSTIND3(id,jd,kd)] = + + f1*f1 * src[SRCIND3(is,js ,ks )] + + f2*f1 * src[SRCIND3(is,js+1,ks )] + + f1*f2 * src[SRCIND3(is,js ,ks+1)] + + f2*f2 * src[SRCIND3(is,js+1,ks+1)]; + i = i+1; + id = id+1; + if (i < regiext) goto l8111; + goto l911; + + // kernel + l8111: + { + T const res1 = + + f1*f1*f1 * src[SRCIND3(is ,js ,ks )] + + f2*f1*f1 * src[SRCIND3(is+1,js ,ks )] + + f1*f2*f1 * src[SRCIND3(is ,js+1,ks )] + + f2*f2*f1 * src[SRCIND3(is+1,js+1,ks )]; + T const res2 = + + f1*f1*f2 * src[SRCIND3(is ,js ,ks+1)] + + f2*f1*f2 * src[SRCIND3(is+1,js ,ks+1)] + + f1*f2*f2 * src[SRCIND3(is ,js+1,ks+1)] + + f2*f2*f2 * src[SRCIND3(is+1,js+1,ks+1)]; + dst[DSTIND3(id,jd,kd)] = res1 + res2; + } + i = i+1; + id = id+1; + is = is+1; + if (i < regiext) goto l8110; + goto l911; + + // end i loop + l911: + j = j+1; + jd = jd+1; + js = js+1; + if (j < regjext) goto l810; + goto l91; + + // end j loop + l91: + k = k+1; + kd = kd+1; + ks = ks+1; + if (k < regkext) goto l80; + goto l9; + + // end k loop + l9:; + + } + + + + template + void + prolongate_3d_o1_rf2 (CCTK_REAL const * restrict const src, + ivect3 const & srcext, + CCTK_REAL * restrict const dst, + ivect3 const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox); + + template + void + prolongate_3d_o1_rf2 (CCTK_COMPLEX const * restrict const src, + ivect3 const & srcext, + CCTK_COMPLEX * restrict const dst, + ivect3 const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox); + + + +} // CarpetLib diff --git a/Carpet/CarpetLib/src/prolongate_3d_o3_rf2.cc b/Carpet/CarpetLib/src/prolongate_3d_o3_rf2.cc new file mode 100644 index 000000000..30a41c000 --- /dev/null +++ b/Carpet/CarpetLib/src/prolongate_3d_o3_rf2.cc @@ -0,0 +1,495 @@ +#include <algorithm> +#include <cassert> +#include <cmath> +#include <cstdlib> + +#include <cctk.h> +#include <cctk_Parameters.h> + +#include "operator_prototypes.hh" +#include "typeprops.hh" + +using namespace std; + + + +namespace CarpetLib { + + + +#define SRCIND3(i,j,k) \ + index3 (i, j, k, \ + srciext, srcjext, srckext) +#define DSTIND3(i,j,k) \ + index3 (i, j, k, \ + dstiext, dstjext, dstkext) + + + + template <typename T> + void + prolongate_3d_o3_rf2 (T const * restrict const src, + ivect3 const & srcext, + T * restrict const dst, + ivect const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox) + { + DECLARE_CCTK_PARAMETERS; + + typedef typename typeprops<T>::real RT; + + + +#if 0 + // This is already guaranteed by bbox + if (any (srcbbox.stride() == 0 or + dstbbox.stride() == 0 or + regbbox.stride() == 0)) + { + CCTK_WARN (0, "Internal error: stride is zero"); + } +#endif + + if (any (srcbbox.stride() <= regbbox.stride() or + dstbbox.stride() != regbbox.stride())) + { + CCTK_WARN (0, "Internal error: strides disagree"); + } + + if (any (srcbbox.stride() != reffact2 * dstbbox.stride())) { + CCTK_WARN (0, "Internal error: source strides are not twice the destination strides"); + } + +#if 0 + // This needs to be allowed for cell centring + if (any (srcbbox.lower() % srcbbox.stride() != 0 or + dstbbox.lower() % dstbbox.stride() != 0 or + regbbox.lower() % regbbox.stride() != 0)) + { + CCTK_WARN (0, "Internal error: array origins are not integer multiples of the strides"); + } +#endif + + // This could be handled, but is likely to point to an error + // elsewhere + if (regbbox.empty()) { + CCTK_WARN (0, "Internal error: region extent is empty"); + } + +#if 0 + // This is already guaranteed by bbox + if (any ((srcbbox.upper() - srcbbox.lower()) % srcbbox.stride() != 0 or + (dstbbox.upper() - dstbbox.lower()) % dstbbox.stride() != 0 or + (regbbox.upper() - regbbox.lower()) % regbbox.stride() != 0)) + { + CCTK_WARN (0, "Internal error: array extents are not integer multiples of the strides"); + } +#endif + + + + ivect3 const regext = regbbox.shape() / regbbox.stride(); + assert (all ((regbbox.lower() - srcbbox.lower()) % regbbox.stride() == 0)); + ivect3 const srcoff = (regbbox.lower() - srcbbox.lower()) / regbbox.stride(); + assert (all ((regbbox.lower() - dstbbox.lower()) % regbbox.stride() == 0)); + ivect3 const dstoff = (regbbox.lower() - dstbbox.lower()) / regbbox.stride(); + + + + bvect3 const needoffsetlo = srcoff % reffact2 != 0 or regext > 1; + bvect3 const needoffsethi = (srcoff + regext - 1) % reffact2 != 0 or regext > 1; + ivect3 const offsetlo = either (needoffsetlo, 2 /* 1 */, 0); + ivect3 const offsethi = either (needoffsethi, 2 /* 1 */, 0); + + + + if (not regbbox.expand(offsetlo, offsethi).is_contained_in(srcbbox) or + not regbbox .is_contained_in(dstbbox)) + { + CCTK_WARN (0, "Internal error: region extent is not contained in array extent"); + } + + if (any (srcext != srcbbox.shape() / srcbbox.stride() or + dstext != dstbbox.shape() / dstbbox.stride())) + { + CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes"); + } + + + + size_t const srciext = srcext[0]; + size_t const srcjext = srcext[1]; + size_t const srckext = srcext[2]; + + size_t const dstiext = dstext[0]; + size_t const dstjext = dstext[1]; + size_t const dstkext = dstext[2]; + + size_t const regiext = regext[0]; + size_t const regjext = regext[1]; + size_t const regkext = regext[2]; + + size_t const srcioff = srcoff[0]; + size_t const srcjoff = srcoff[1]; + size_t const srckoff = srcoff[2]; + + size_t const dstioff = dstoff[0]; + size_t const dstjoff = dstoff[1]; + size_t const dstkoff = dstoff[2]; + + + + size_t const fi = srcioff % 2; + size_t const fj = srcjoff % 2; + size_t const fk = srckoff % 2; + + size_t const i0 = srcioff / 2; + size_t const j0 = srcjoff / 2; + size_t const k0 = srckoff / 2; + + RT const one = 1; + + RT const f1 = - one/16; + RT const f2 = 9*one/16; + RT const f3 = 9*one/16; + RT const f4 = - one/16; + + + + // Loop over fine region + // Label scheme: l 8 fk fj fi + + size_t is, js, ks; + size_t id, jd, kd; + size_t i, j, k; + + // begin k loop + k = 0; + ks = k0; + kd = dstkoff; + if (fk == 0) goto l80; + goto l81; + + // begin j loop + l80: + j = 0; + js = j0; + jd = dstjoff; + if (fj == 0) goto l800; + goto l801; + + // begin i loop + l800: + i = 0; + is = i0; + id = dstioff; + if (fi == 0) goto l8000; + goto l8001; + + // kernel + l8000: + dst[DSTIND3(id,jd,kd)] = src[SRCIND3(is,js,ks)]; + i = i+1; + id = id+1; + if (i < regiext) goto l8001; + goto l900; + + // kernel + l8001: + dst[DSTIND3(id,jd,kd)] = + + f1 * src[SRCIND3(is-1,js,ks)] + + f2 * src[SRCIND3(is ,js,ks)] + + f3 * src[SRCIND3(is+1,js,ks)] + + f4 * src[SRCIND3(is+2,js,ks)]; + i = i+1; + id = id+1; + is = is+1; + if (i < regiext) goto l8000; + goto l900; + + // end i loop + l900: + j = j+1; + jd = jd+1; + if (j < regjext) goto l801; + goto l90; + + // begin i loop + l801: + i = 0; + is = i0; + id = dstioff; + if (fi == 0) goto l8010; + goto l8011; + + // kernel + l8010: + dst[DSTIND3(id,jd,kd)] = + + f1 * src[SRCIND3(is,js-1,ks)] + + f2 * src[SRCIND3(is,js ,ks)] + + f3 * src[SRCIND3(is,js+1,ks)] + + f4 * src[SRCIND3(is,js+2,ks)]; + i = i+1; + id = id+1; + if (i < regiext) goto l8011; + goto l901; + + // kernel + l8011: + dst[DSTIND3(id,jd,kd)] = + + f1*f1 * src[SRCIND3(is-1,js-1,ks)] + + f2*f1 * src[SRCIND3(is ,js-1,ks)] + + f3*f1 * src[SRCIND3(is+1,js-1,ks)] + + f4*f1 * src[SRCIND3(is+2,js-1,ks)] + + f1*f2 * src[SRCIND3(is-1,js ,ks)] + + f2*f2 * src[SRCIND3(is ,js ,ks)] + + f3*f2 * src[SRCIND3(is+1,js ,ks)] + + f4*f2 * src[SRCIND3(is+2,js ,ks)] + + f1*f3 * src[SRCIND3(is-1,js+1,ks)] + + f2*f3 * src[SRCIND3(is ,js+1,ks)] + + f3*f3 * src[SRCIND3(is+1,js+1,ks)] + + f4*f3 * src[SRCIND3(is+2,js+1,ks)] + + f1*f4 * src[SRCIND3(is-1,js+2,ks)] + + f2*f4 * src[SRCIND3(is ,js+2,ks)] + + f3*f4 * src[SRCIND3(is+1,js+2,ks)] + + f4*f4 * src[SRCIND3(is+2,js+2,ks)]; + i = i+1; + id = id+1; + is = is+1; + if (i < regiext) goto l8010; + goto l901; + + // end i loop + l901: + j = j+1; + jd = jd+1; + js = js+1; + if (j < regjext) goto l800; + goto l90; + + // end j loop + l90: + k = k+1; + kd = kd+1; + if (k < regkext) goto l81; + goto l9; + + // begin j loop + l81: + j = 0; + js = j0; + jd = dstjoff; + if (fj == 0) goto l810; + goto l811; + + // begin i loop + l810: + i = 0; + is = i0; + id = dstioff; + if (fi == 0) goto l8100; + goto l8101; + + // kernel + l8100: + dst[DSTIND3(id,jd,kd)] = + + f1 * src[SRCIND3(is,js,ks-1)] + + f2 * src[SRCIND3(is,js,ks )] + + f3 * src[SRCIND3(is,js,ks+1)] + + f4 * src[SRCIND3(is,js,ks+2)]; + i = i+1; + id = id+1; + if (i < regiext) goto l8101; + goto l910; + + // kernel + l8101: + dst[DSTIND3(id,jd,kd)] = + + f1*f1 * src[SRCIND3(is-1,js,ks-1)] + + f2*f1 * src[SRCIND3(is ,js,ks-1)] + + f3*f1 * src[SRCIND3(is+1,js,ks-1)] + + f4*f1 * src[SRCIND3(is+2,js,ks-1)] + + f1*f2 * src[SRCIND3(is-1,js,ks )] + + f2*f2 * src[SRCIND3(is ,js,ks )] + + f3*f2 * src[SRCIND3(is+1,js,ks )] + + f4*f2 * src[SRCIND3(is+2,js,ks )] + + f1*f3 * src[SRCIND3(is-1,js,ks+1)] + + f2*f3 * src[SRCIND3(is ,js,ks+1)] + + f3*f3 * src[SRCIND3(is+1,js,ks+1)] + + f4*f3 * src[SRCIND3(is+2,js,ks+1)] + + f1*f4 * src[SRCIND3(is-1,js,ks+2)] + + f2*f4 * src[SRCIND3(is ,js,ks+2)] + + f3*f4 * src[SRCIND3(is+1,js,ks+2)] + + f4*f4 * src[SRCIND3(is+2,js,ks+2)]; + i = i+1; + id = id+1; + is = is+1; + if (i < regiext) goto l8100; + goto l910; + + // end i loop + l910: + j = j+1; + jd = jd+1; + if (j < regjext) goto l811; + goto l91; + + // begin i loop + l811: + i = 0; + is = i0; + id = dstioff; + if (fi == 0) goto l8110; + goto l8111; + + // kernel + l8110: + dst[DSTIND3(id,jd,kd)] = + + f1*f1 * src[SRCIND3(is,js-1,ks-1)] + + f2*f1 * src[SRCIND3(is,js ,ks-1)] + + f3*f1 * src[SRCIND3(is,js+1,ks-1)] + + f4*f1 * src[SRCIND3(is,js+2,ks-1)] + + f1*f2 * src[SRCIND3(is,js-1,ks )] + + f2*f2 * src[SRCIND3(is,js ,ks )] + + f3*f2 * src[SRCIND3(is,js+1,ks )] + + f4*f2 * src[SRCIND3(is,js+2,ks )] + + f1*f3 * src[SRCIND3(is,js-1,ks+1)] + + f2*f3 * src[SRCIND3(is,js ,ks+1)] + + f3*f3 * src[SRCIND3(is,js+1,ks+1)] + + f4*f3 * src[SRCIND3(is,js+2,ks+1)] + + f1*f4 * src[SRCIND3(is,js-1,ks+2)] + + f2*f4 * src[SRCIND3(is,js ,ks+2)] + + f3*f4 * src[SRCIND3(is,js+1,ks+2)] + + f4*f4 * src[SRCIND3(is,js+2,ks+2)]; + i = i+1; + id = id+1; + if (i < regiext) goto l8111; + goto l911; + + // kernel + l8111: + { + T const res1 = + + f1*f1*f1 * src[SRCIND3(is-1,js-1,ks-1)] + + f2*f1*f1 * src[SRCIND3(is ,js-1,ks-1)] + + f3*f1*f1 * src[SRCIND3(is+1,js-1,ks-1)] + + f4*f1*f1 * src[SRCIND3(is+2,js-1,ks-1)] + + f1*f2*f1 * src[SRCIND3(is-1,js ,ks-1)] + + f2*f2*f1 * src[SRCIND3(is ,js ,ks-1)] + + f3*f2*f1 * src[SRCIND3(is+1,js ,ks-1)] + + f4*f2*f1 * src[SRCIND3(is+2,js ,ks-1)] + + f1*f3*f1 * src[SRCIND3(is-1,js+1,ks-1)] + + f2*f3*f1 * src[SRCIND3(is ,js+1,ks-1)] + + f3*f3*f1 * src[SRCIND3(is+1,js+1,ks-1)] + + f4*f3*f1 * src[SRCIND3(is+2,js+1,ks-1)] + + f1*f4*f1 * src[SRCIND3(is-1,js+2,ks-1)] + + f2*f4*f1 * src[SRCIND3(is ,js+2,ks-1)] + + f3*f4*f1 * src[SRCIND3(is+1,js+2,ks-1)] + + f4*f4*f1 * src[SRCIND3(is+2,js+2,ks-1)]; + T const res2 = + + f1*f1*f2 * src[SRCIND3(is-1,js-1,ks )] + + f2*f1*f2 * src[SRCIND3(is ,js-1,ks )] + + f3*f1*f2 * src[SRCIND3(is+1,js-1,ks )] + + f4*f1*f2 * src[SRCIND3(is+2,js-1,ks )] + + f1*f2*f2 * src[SRCIND3(is-1,js ,ks )] + + f2*f2*f2 * src[SRCIND3(is ,js ,ks )] + + f3*f2*f2 * src[SRCIND3(is+1,js ,ks )] + + f4*f2*f2 * src[SRCIND3(is+2,js ,ks )] + + f1*f3*f2 * src[SRCIND3(is-1,js+1,ks )] + + f2*f3*f2 * src[SRCIND3(is ,js+1,ks )] + + f3*f3*f2 * src[SRCIND3(is+1,js+1,ks )] + + f4*f3*f2 * src[SRCIND3(is+2,js+1,ks )] + + f1*f4*f2 * src[SRCIND3(is-1,js+2,ks )] + + f2*f4*f2 * src[SRCIND3(is ,js+2,ks )] + + f3*f4*f2 * src[SRCIND3(is+1,js+2,ks )] + + f4*f4*f2 * src[SRCIND3(is+2,js+2,ks )]; + T const res3 = + + f1*f1*f3 * src[SRCIND3(is-1,js-1,ks+1)] + + f2*f1*f3 * src[SRCIND3(is ,js-1,ks+1)] + + f3*f1*f3 * src[SRCIND3(is+1,js-1,ks+1)] + + f4*f1*f3 * src[SRCIND3(is+2,js-1,ks+1)] + + f1*f2*f3 * src[SRCIND3(is-1,js ,ks+1)] + + f2*f2*f3 * src[SRCIND3(is ,js ,ks+1)] + + f3*f2*f3 * src[SRCIND3(is+1,js ,ks+1)] + + f4*f2*f3 * src[SRCIND3(is+2,js ,ks+1)] + + f1*f3*f3 * src[SRCIND3(is-1,js+1,ks+1)] + + f2*f3*f3 * src[SRCIND3(is ,js+1,ks+1)] + + f3*f3*f3 * src[SRCIND3(is+1,js+1,ks+1)] + + f4*f3*f3 * src[SRCIND3(is+2,js+1,ks+1)] + + f1*f4*f3 * src[SRCIND3(is-1,js+2,ks+1)] + + f2*f4*f3 * src[SRCIND3(is ,js+2,ks+1)] + + f3*f4*f3 * src[SRCIND3(is+1,js+2,ks+1)] + + f4*f4*f3 * src[SRCIND3(is+2,js+2,ks+1)]; + T const res4 = + + f1*f1*f4 * src[SRCIND3(is-1,js-1,ks+2)] + + f2*f1*f4 * src[SRCIND3(is ,js-1,ks+2)] + + f3*f1*f4 * src[SRCIND3(is+1,js-1,ks+2)] + + f4*f1*f4 * src[SRCIND3(is+2,js-1,ks+2)] + + f1*f2*f4 * src[SRCIND3(is-1,js ,ks+2)] + + f2*f2*f4 * src[SRCIND3(is ,js ,ks+2)] + + f3*f2*f4 * src[SRCIND3(is+1,js ,ks+2)] + + f4*f2*f4 * src[SRCIND3(is+2,js ,ks+2)] + + f1*f3*f4 * src[SRCIND3(is-1,js+1,ks+2)] + + f2*f3*f4 * src[SRCIND3(is ,js+1,ks+2)] + + f3*f3*f4 * src[SRCIND3(is+1,js+1,ks+2)] + + f4*f3*f4 * src[SRCIND3(is+2,js+1,ks+2)] + + f1*f4*f4 * src[SRCIND3(is-1,js+2,ks+2)] + + f2*f4*f4 * src[SRCIND3(is ,js+2,ks+2)] + + f3*f4*f4 * src[SRCIND3(is+1,js+2,ks+2)] + + f4*f4*f4 * src[SRCIND3(is+2,js+2,ks+2)]; + dst[DSTIND3(id,jd,kd)] = res1 + res2 + res3 + res4; + } + i = i+1; + id = id+1; + is = is+1; + if (i < regiext) goto l8110; + goto l911; + + // end i loop + l911: + j = j+1; + jd = jd+1; + js = js+1; + if (j < regjext) goto l810; + goto l91; + + // end j loop + l91: + k = k+1; + kd = kd+1; + ks = ks+1; + if (k < regkext) goto l80; + goto l9; + + // end k loop + l9:; + + } + + + + template + void + prolongate_3d_o3_rf2 (CCTK_REAL const * restrict const src, + ivect3 const & srcext, + CCTK_REAL * restrict const dst, + ivect3 const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox); + + template + void + prolongate_3d_o3_rf2 (CCTK_COMPLEX const * restrict const src, + ivect3 const & srcext, + CCTK_COMPLEX * restrict const dst, + ivect3 const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox); + + + +} // namespace CarpetLib diff --git a/Carpet/CarpetLib/src/prolongate_3d_o5_rf2.cc b/Carpet/CarpetLib/src/prolongate_3d_o5_rf2.cc new file mode 100644 index 000000000..749de2f2a --- /dev/null +++ b/Carpet/CarpetLib/src/prolongate_3d_o5_rf2.cc @@ -0,0 +1,715 @@ +#include <algorithm> +#include <cassert> +#include <cmath> +#include <cstdlib> + +#include <cctk.h> +#include <cctk_Parameters.h> + +#include "operator_prototypes.hh" +#include "typeprops.hh" + +using namespace std; + + + +namespace CarpetLib { + + + +#define SRCIND3(i,j,k) \ + index3 (i, j, k, \ + srciext, srcjext, srckext) +#define DSTIND3(i,j,k) \ + index3 (i, j, k, \ + dstiext, dstjext, dstkext) + + + + template <typename T> + void + prolongate_3d_o5_rf2 (T const * restrict const src, + ivect3 const & srcext, + T * restrict const dst, + ivect3 const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox) + { + typedef typename typeprops<T>::real RT; + + + +#if 0 + // This is already guaranteed by bbox + if (any (srcbbox.stride() == 0 or + dstbbox.stride() == 0 or + regbbox.stride() == 0)) + { + CCTK_WARN (0, "Internal error: stride is zero"); + } +#endif + + if (any (srcbbox.stride() <= regbbox.stride() or + dstbbox.stride() != regbbox.stride())) + { + CCTK_WARN (0, "Internal error: strides disagree"); + } + + if (any (srcbbox.stride() != reffact2 * dstbbox.stride())) { + CCTK_WARN (0, "Internal error: source strides are not twice the destination strides"); + } + +#if 0 + // This needs to be allowed for cell centring + if (any (srcbbox.lower() % srcbbox.stride() != 0 or + dstbbox.lower() % dstbbox.stride() != 0 or + regbbox.lower() % regbbox.stride() != 0)) + { + CCTK_WARN (0, "Internal error: array origins are not integer multiples of the strides"); + } +#endif + + // This could be handled, but is likely to point to an error + // elsewhere + if (regbbox.empty()) { + CCTK_WARN (0, "Internal error: region extent is empty"); + } + +#if 0 + // This is already guaranteed by bbox + if (any ((srcbbox.upper() - srcbbox.lower()) % srcbbox.stride() != 0 or + (dstbbox.upper() - dstbbox.lower()) % dstbbox.stride() != 0 or + (regbbox.upper() - regbbox.lower()) % regbbox.stride() != 0)) + { + CCTK_WARN (0, "Internal error: array extents are not integer multiples of the strides"); + } +#endif + + + + ivect3 const regext = regbbox.shape() / regbbox.stride(); + assert (all ((regbbox.lower() - srcbbox.lower()) % regbbox.stride() == 0)); + ivect3 const srcoff = (regbbox.lower() - srcbbox.lower()) / regbbox.stride(); + assert (all ((regbbox.lower() - dstbbox.lower()) % regbbox.stride() == 0)); + ivect3 const dstoff = (regbbox.lower() - dstbbox.lower()) / regbbox.stride(); + + + + bvect3 const needoffsetlo = srcoff % reffact2 != 0 or regext > 1; + bvect3 const needoffsethi = (srcoff + regext - 1) % reffact2 != 0 or regext > 1; + ivect3 const offsetlo = either (needoffsetlo, 2 /* 1 */, 0); + ivect3 const offsethi = either (needoffsethi, 2 /* 1 */, 0); + + + + if (not regbbox.expand(offsetlo, offsethi).is_contained_in(srcbbox) or + not regbbox .is_contained_in(dstbbox)) + { + CCTK_WARN (0, "Internal error: region extent is not contained in array extent"); + } + + if (any (srcext != srcbbox.shape() / srcbbox.stride() or + dstext != dstbbox.shape() / dstbbox.stride())) + { + CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes"); + } + + + + size_t const srciext = srcext[0]; + size_t const srcjext = srcext[1]; + size_t const srckext = srcext[2]; + + size_t const dstiext = dstext[0]; + size_t const dstjext = dstext[1]; + size_t const dstkext = dstext[2]; + + size_t const regiext = regext[0]; + size_t const regjext = regext[1]; + size_t const regkext = regext[2]; + + size_t const srcioff = srcoff[0]; + size_t const srcjoff = srcoff[1]; + size_t const srckoff = srcoff[2]; + + size_t const dstioff = dstoff[0]; + size_t const dstjoff = dstoff[1]; + size_t const dstkoff = dstoff[2]; + + + + size_t const fi = srcioff % 2; + size_t const fj = srcjoff % 2; + size_t const fk = srckoff % 2; + + size_t const i0 = srcioff / 2; + size_t const j0 = srcjoff / 2; + size_t const k0 = srckoff / 2; + + RT const one = 1; + + RT const f1 = 3*one/256; + RT const f2 = - 25*one/256; + RT const f3 = 150*one/256; + RT const f4 = 150*one/256; + RT const f5 = - 25*one/256; + RT const f6 = 3*one/256; + + + + // Loop over fine region + // Label scheme: l 8 fk fj fi + + size_t is, js, ks; + size_t id, jd, kd; + size_t i, j, k; + + // begin k loop + k = 0; + ks = k0; + kd = dstkoff; + if (fk == 0) goto l80; + goto l81; + + // begin j loop + l80: + j = 0; + js = j0; + jd = dstjoff; + if (fj == 0) goto l800; + goto l801; + + // begin i loop + l800: + i = 0; + is = i0; + id = dstioff; + if (fi == 0) goto l8000; + goto l8001; + + // kernel + l8000: + dst[DSTIND3(id,jd,kd)] = src[SRCIND3(is,js,ks)]; + i = i+1; + id = id+1; + if (i < regiext) goto l8001; + goto l900; + + // kernel + l8001: + dst[DSTIND3(id,jd,kd)] = + + f1 * src[SRCIND3(is-2,js,ks)] + + f2 * src[SRCIND3(is-1,js,ks)] + + f3 * src[SRCIND3(is ,js,ks)] + + f4 * src[SRCIND3(is+1,js,ks)] + + f5 * src[SRCIND3(is+2,js,ks)] + + f6 * src[SRCIND3(is+3,js,ks)]; + i = i+1; + id = id+1; + is = is+1; + if (i < regiext) goto l8000; + goto l900; + + // end i loop + l900: + j = j+1; + jd = jd+1; + if (j < regjext) goto l801; + goto l90; + + // begin i loop + l801: + i = 0; + is = i0; + id = dstioff; + if (fi == 0) goto l8010; + goto l8011; + + // kernel + l8010: + dst[DSTIND3(id,jd,kd)] = + + f1 * src[SRCIND3(is,js-2,ks)] + + f2 * src[SRCIND3(is,js-1,ks)] + + f3 * src[SRCIND3(is,js ,ks)] + + f4 * src[SRCIND3(is,js+1,ks)] + + f5 * src[SRCIND3(is,js+2,ks)] + + f6 * src[SRCIND3(is,js+3,ks)]; + i = i+1; + id = id+1; + if (i < regiext) goto l8011; + goto l901; + + // kernel + l8011: + dst[DSTIND3(id,jd,kd)] = + + f1*f1 * src[SRCIND3(is-2,js-2,ks)] + + f2*f1 * src[SRCIND3(is-1,js-2,ks)] + + f3*f1 * src[SRCIND3(is ,js-2,ks)] + + f4*f1 * src[SRCIND3(is+1,js-2,ks)] + + f5*f1 * src[SRCIND3(is+2,js-2,ks)] + + f6*f1 * src[SRCIND3(is+3,js-2,ks)] + + f1*f2 * src[SRCIND3(is-2,js-1,ks)] + + f2*f2 * src[SRCIND3(is-1,js-1,ks)] + + f3*f2 * src[SRCIND3(is ,js-1,ks)] + + f4*f2 * src[SRCIND3(is+1,js-1,ks)] + + f5*f2 * src[SRCIND3(is+2,js-1,ks)] + + f6*f2 * src[SRCIND3(is+3,js-1,ks)] + + f1*f3 * src[SRCIND3(is-2,js ,ks)] + + f2*f3 * src[SRCIND3(is-1,js ,ks)] + + f3*f3 * src[SRCIND3(is ,js ,ks)] + + f4*f3 * src[SRCIND3(is+1,js ,ks)] + + f5*f3 * src[SRCIND3(is+2,js ,ks)] + + f6*f3 * src[SRCIND3(is+3,js ,ks)] + + f1*f4 * src[SRCIND3(is-2,js+1,ks)] + + f2*f4 * src[SRCIND3(is-1,js+1,ks)] + + f3*f4 * src[SRCIND3(is ,js+1,ks)] + + f4*f4 * src[SRCIND3(is+1,js+1,ks)] + + f5*f4 * src[SRCIND3(is+2,js+1,ks)] + + f6*f4 * src[SRCIND3(is+3,js+1,ks)] + + f1*f5 * src[SRCIND3(is-2,js+2,ks)] + + f2*f5 * src[SRCIND3(is-1,js+2,ks)] + + f3*f5 * src[SRCIND3(is ,js+2,ks)] + + f4*f5 * src[SRCIND3(is+1,js+2,ks)] + + f5*f5 * src[SRCIND3(is+2,js+2,ks)] + + f6*f5 * src[SRCIND3(is+3,js+2,ks)] + + f1*f6 * src[SRCIND3(is-2,js+3,ks)] + + f2*f6 * src[SRCIND3(is-1,js+3,ks)] + + f3*f6 * src[SRCIND3(is ,js+3,ks)] + + f4*f6 * src[SRCIND3(is+1,js+3,ks)] + + f5*f6 * src[SRCIND3(is+2,js+3,ks)] + + f6*f6 * src[SRCIND3(is+3,js+3,ks)]; + i = i+1; + id = id+1; + is = is+1; + if (i < regiext) goto l8010; + goto l901; + + // end i loop + l901: + j = j+1; + jd = jd+1; + js = js+1; + if (j < regjext) goto l800; + goto l90; + + // end j loop + l90: + k = k+1; + kd = kd+1; + if (k < regkext) goto l81; + goto l9; + + // begin j loop + l81: + j = 0; + js = j0; + jd = dstjoff; + if (fj == 0) goto l810; + goto l811; + + // begin i loop + l810: + i = 0; + is = i0; + id = dstioff; + if (fi == 0) goto l8100; + goto l8101; + + // kernel + l8100: + dst[DSTIND3(id,jd,kd)] = + + f1 * src[SRCIND3(is,js,ks-2)] + + f2 * src[SRCIND3(is,js,ks-1)] + + f3 * src[SRCIND3(is,js,ks )] + + f4 * src[SRCIND3(is,js,ks+1)] + + f5 * src[SRCIND3(is,js,ks+2)] + + f6 * src[SRCIND3(is,js,ks+3)]; + i = i+1; + id = id+1; + if (i < regiext) goto l8101; + goto l910; + + // kernel + l8101: + dst[DSTIND3(id,jd,kd)] = + + f1*f1 * src[SRCIND3(is-2,js,ks-2)] + + f2*f1 * src[SRCIND3(is-1,js,ks-2)] + + f3*f1 * src[SRCIND3(is ,js,ks-2)] + + f4*f1 * src[SRCIND3(is+1,js,ks-2)] + + f5*f1 * src[SRCIND3(is+2,js,ks-2)] + + f6*f1 * src[SRCIND3(is+3,js,ks-2)] + + f1*f2 * src[SRCIND3(is-2,js,ks-1)] + + f2*f2 * src[SRCIND3(is-1,js,ks-1)] + + f3*f2 * src[SRCIND3(is ,js,ks-1)] + + f4*f2 * src[SRCIND3(is+1,js,ks-1)] + + f5*f2 * src[SRCIND3(is+2,js,ks-1)] + + f6*f2 * src[SRCIND3(is+3,js,ks-1)] + + f1*f3 * src[SRCIND3(is-2,js,ks )] + + f2*f3 * src[SRCIND3(is-1,js,ks )] + + f3*f3 * src[SRCIND3(is ,js,ks )] + + f4*f3 * src[SRCIND3(is+1,js,ks )] + + f5*f3 * src[SRCIND3(is+2,js,ks )] + + f6*f3 * src[SRCIND3(is+3,js,ks )] + + f1*f4 * src[SRCIND3(is-2,js,ks+1)] + + f2*f4 * src[SRCIND3(is-1,js,ks+1)] + + f3*f4 * src[SRCIND3(is ,js,ks+1)] + + f4*f4 * src[SRCIND3(is+1,js,ks+1)] + + f5*f4 * src[SRCIND3(is+2,js,ks+1)] + + f6*f4 * src[SRCIND3(is+3,js,ks+1)] + + f1*f5 * src[SRCIND3(is-2,js,ks+2)] + + f2*f5 * src[SRCIND3(is-1,js,ks+2)] + + f3*f5 * src[SRCIND3(is ,js,ks+2)] + + f4*f5 * src[SRCIND3(is+1,js,ks+2)] + + f5*f5 * src[SRCIND3(is+2,js,ks+2)] + + f6*f5 * src[SRCIND3(is+3,js,ks+2)] + + f1*f6 * src[SRCIND3(is-2,js,ks+3)] + + f2*f6 * src[SRCIND3(is-1,js,ks+3)] + + f3*f6 * src[SRCIND3(is ,js,ks+3)] + + f4*f6 * src[SRCIND3(is+1,js,ks+3)] + + f5*f6 * src[SRCIND3(is+2,js,ks+3)] + + f6*f6 * src[SRCIND3(is+3,js,ks+3)]; + i = i+1; + id = id+1; + is = is+1; + if (i < regiext) goto l8100; + goto l910; + + // end i loop + l910: + j = j+1; + jd = jd+1; + if (j < regjext) goto l811; + goto l91; + + // begin i loop + l811: + i = 0; + is = i0; + id = dstioff; + if (fi == 0) goto l8110; + goto l8111; + + // kernel + l8110: + dst[DSTIND3(id,jd,kd)] = + + f1*f1 * src[SRCIND3(is,js-2,ks-2)] + + f2*f1 * src[SRCIND3(is,js-1,ks-2)] + + f3*f1 * src[SRCIND3(is,js ,ks-2)] + + f4*f1 * src[SRCIND3(is,js+1,ks-2)] + + f5*f1 * src[SRCIND3(is,js+2,ks-2)] + + f6*f1 * src[SRCIND3(is,js+3,ks-2)] + + f1*f2 * src[SRCIND3(is,js-2,ks-1)] + + f2*f2 * src[SRCIND3(is,js-1,ks-1)] + + f3*f2 * src[SRCIND3(is,js ,ks-1)] + + f4*f2 * src[SRCIND3(is,js+1,ks-1)] + + f5*f2 * src[SRCIND3(is,js+2,ks-1)] + + f6*f2 * src[SRCIND3(is,js+3,ks-1)] + + f1*f3 * src[SRCIND3(is,js-2,ks )] + + f2*f3 * src[SRCIND3(is,js-1,ks )] + + f3*f3 * src[SRCIND3(is,js ,ks )] + + f4*f3 * src[SRCIND3(is,js+1,ks )] + + f5*f3 * src[SRCIND3(is,js+2,ks )] + + f6*f3 * src[SRCIND3(is,js+3,ks )] + + f1*f4 * src[SRCIND3(is,js-2,ks+1)] + + f2*f4 * src[SRCIND3(is,js-1,ks+1)] + + f3*f4 * src[SRCIND3(is,js ,ks+1)] + + f4*f4 * src[SRCIND3(is,js+1,ks+1)] + + f5*f4 * src[SRCIND3(is,js+2,ks+1)] + + f6*f4 * src[SRCIND3(is,js+3,ks+1)] + + f1*f5 * src[SRCIND3(is,js-2,ks+2)] + + f2*f5 * src[SRCIND3(is,js-1,ks+2)] + + f3*f5 * src[SRCIND3(is,js ,ks+2)] + + f4*f5 * src[SRCIND3(is,js+1,ks+2)] + + f5*f5 * src[SRCIND3(is,js+2,ks+2)] + + f6*f5 * src[SRCIND3(is,js+3,ks+2)] + + f1*f6 * src[SRCIND3(is,js-2,ks+3)] + + f2*f6 * src[SRCIND3(is,js-1,ks+3)] + + f3*f6 * src[SRCIND3(is,js ,ks+3)] + + f4*f6 * src[SRCIND3(is,js+1,ks+3)] + + f5*f6 * src[SRCIND3(is,js+2,ks+3)] + + f6*f6 * src[SRCIND3(is,js+3,ks+3)]; + i = i+1; + id = id+1; + if (i < regiext) goto l8111; + goto l911; + + // kernel + l8111: + { + T const res1 = + + f1*f1*f1 * src[SRCIND3(is-2,js-2,ks-2)] + + f2*f1*f1 * src[SRCIND3(is-1,js-2,ks-2)] + + f3*f1*f1 * src[SRCIND3(is ,js-2,ks-2)] + + f4*f1*f1 * src[SRCIND3(is+1,js-2,ks-2)] + + f5*f1*f1 * src[SRCIND3(is+2,js-2,ks-2)] + + f6*f1*f1 * src[SRCIND3(is+3,js-2,ks-2)] + + f1*f2*f1 * src[SRCIND3(is-2,js-1,ks-2)] + + f2*f2*f1 * src[SRCIND3(is-1,js-1,ks-2)] + + f3*f2*f1 * src[SRCIND3(is ,js-1,ks-2)] + + f4*f2*f1 * src[SRCIND3(is+1,js-1,ks-2)] + + f5*f2*f1 * src[SRCIND3(is+2,js-1,ks-2)] + + f6*f2*f1 * src[SRCIND3(is+3,js-1,ks-2)] + + f1*f3*f1 * src[SRCIND3(is-2,js ,ks-2)] + + f2*f3*f1 * src[SRCIND3(is-1,js ,ks-2)] + + f3*f3*f1 * src[SRCIND3(is ,js ,ks-2)] + + f4*f3*f1 * src[SRCIND3(is+1,js ,ks-2)] + + f5*f3*f1 * src[SRCIND3(is+2,js ,ks-2)] + + f6*f3*f1 * src[SRCIND3(is+3,js ,ks-2)] + + f1*f4*f1 * src[SRCIND3(is-2,js+1,ks-2)] + + f2*f4*f1 * src[SRCIND3(is-1,js+1,ks-2)] + + f3*f4*f1 * src[SRCIND3(is ,js+1,ks-2)] + + f4*f4*f1 * src[SRCIND3(is+1,js+1,ks-2)] + + f5*f4*f1 * src[SRCIND3(is+2,js+1,ks-2)] + + f6*f4*f1 * src[SRCIND3(is+3,js+1,ks-2)] + + f1*f5*f1 * src[SRCIND3(is-2,js+2,ks-2)] + + f2*f5*f1 * src[SRCIND3(is-1,js+2,ks-2)] + + f3*f5*f1 * src[SRCIND3(is ,js+2,ks-2)] + + f4*f5*f1 * src[SRCIND3(is+1,js+2,ks-2)] + + f5*f5*f1 * src[SRCIND3(is+2,js+2,ks-2)] + + f6*f5*f1 * src[SRCIND3(is+3,js+2,ks-2)] + + f1*f6*f1 * src[SRCIND3(is-2,js+3,ks-2)] + + f2*f6*f1 * src[SRCIND3(is-1,js+3,ks-2)] + + f3*f6*f1 * src[SRCIND3(is ,js+3,ks-2)] + + f4*f6*f1 * src[SRCIND3(is+1,js+3,ks-2)] + + f5*f6*f1 * src[SRCIND3(is+2,js+3,ks-2)] + + f6*f6*f1 * src[SRCIND3(is+3,js+3,ks-2)]; + T const res2 = + + f1*f1*f2 * src[SRCIND3(is-2,js-2,ks-1)] + + f2*f1*f2 * src[SRCIND3(is-1,js-2,ks-1)] + + f3*f1*f2 * src[SRCIND3(is ,js-2,ks-1)] + + f4*f1*f2 * src[SRCIND3(is+1,js-2,ks-1)] + + f5*f1*f2 * src[SRCIND3(is+2,js-2,ks-1)] + + f6*f1*f2 * src[SRCIND3(is+3,js-2,ks-1)] + + f1*f2*f2 * src[SRCIND3(is-2,js-1,ks-1)] + + f2*f2*f2 * src[SRCIND3(is-1,js-1,ks-1)] + + f3*f2*f2 * src[SRCIND3(is ,js-1,ks-1)] + + f4*f2*f2 * src[SRCIND3(is+1,js-1,ks-1)] + + f5*f2*f2 * src[SRCIND3(is+2,js-1,ks-1)] + + f6*f2*f2 * src[SRCIND3(is+3,js-1,ks-1)] + + f1*f3*f2 * src[SRCIND3(is-2,js ,ks-1)] + + f2*f3*f2 * src[SRCIND3(is-1,js ,ks-1)] + + f3*f3*f2 * src[SRCIND3(is ,js ,ks-1)] + + f4*f3*f2 * src[SRCIND3(is+1,js ,ks-1)] + + f5*f3*f2 * src[SRCIND3(is+2,js ,ks-1)] + + f6*f3*f2 * src[SRCIND3(is+3,js ,ks-1)] + + f1*f4*f2 * src[SRCIND3(is-2,js+1,ks-1)] + + f2*f4*f2 * src[SRCIND3(is-1,js+1,ks-1)] + + f3*f4*f2 * src[SRCIND3(is ,js+1,ks-1)] + + f4*f4*f2 * src[SRCIND3(is+1,js+1,ks-1)] + + f5*f4*f2 * src[SRCIND3(is+2,js+1,ks-1)] + + f6*f4*f2 * src[SRCIND3(is+3,js+1,ks-1)] + + f1*f5*f2 * src[SRCIND3(is-2,js+2,ks-1)] + + f2*f5*f2 * src[SRCIND3(is-1,js+2,ks-1)] + + f3*f5*f2 * src[SRCIND3(is ,js+2,ks-1)] + + f4*f5*f2 * src[SRCIND3(is+1,js+2,ks-1)] + + f5*f5*f2 * src[SRCIND3(is+2,js+2,ks-1)] + + f6*f5*f2 * src[SRCIND3(is+3,js+2,ks-1)] + + f1*f6*f2 * src[SRCIND3(is-2,js+3,ks-1)] + + f2*f6*f2 * src[SRCIND3(is-1,js+3,ks-1)] + + f3*f6*f2 * src[SRCIND3(is ,js+3,ks-1)] + + f4*f6*f2 * src[SRCIND3(is+1,js+3,ks-1)] + + f5*f6*f2 * src[SRCIND3(is+2,js+3,ks-1)] + + f6*f6*f2 * src[SRCIND3(is+3,js+3,ks-1)]; + T const res3 = + + f1*f1*f3 * src[SRCIND3(is-2,js-2,ks )] + + f2*f1*f3 * src[SRCIND3(is-1,js-2,ks )] + + f3*f1*f3 * src[SRCIND3(is ,js-2,ks )] + + f4*f1*f3 * src[SRCIND3(is+1,js-2,ks )] + + f5*f1*f3 * src[SRCIND3(is+2,js-2,ks )] + + f6*f1*f3 * src[SRCIND3(is+3,js-2,ks )] + + f1*f2*f3 * src[SRCIND3(is-2,js-1,ks )] + + f2*f2*f3 * src[SRCIND3(is-1,js-1,ks )] + + f3*f2*f3 * src[SRCIND3(is ,js-1,ks )] + + f4*f2*f3 * src[SRCIND3(is+1,js-1,ks )] + + f5*f2*f3 * src[SRCIND3(is+2,js-1,ks )] + + f6*f2*f3 * src[SRCIND3(is+3,js-1,ks )] + + f1*f3*f3 * src[SRCIND3(is-2,js ,ks )] + + f2*f3*f3 * src[SRCIND3(is-1,js ,ks )] + + f3*f3*f3 * src[SRCIND3(is ,js ,ks )] + + f4*f3*f3 * src[SRCIND3(is+1,js ,ks )] + + f5*f3*f3 * src[SRCIND3(is+2,js ,ks )] + + f6*f3*f3 * src[SRCIND3(is+3,js ,ks )] + + f1*f4*f3 * src[SRCIND3(is-2,js+1,ks )] + + f2*f4*f3 * src[SRCIND3(is-1,js+1,ks )] + + f3*f4*f3 * src[SRCIND3(is ,js+1,ks )] + + f4*f4*f3 * src[SRCIND3(is+1,js+1,ks )] + + f5*f4*f3 * src[SRCIND3(is+2,js+1,ks )] + + f6*f4*f3 * src[SRCIND3(is+3,js+1,ks )] + + f1*f5*f3 * src[SRCIND3(is-2,js+2,ks )] + + f2*f5*f3 * src[SRCIND3(is-1,js+2,ks )] + + f3*f5*f3 * src[SRCIND3(is ,js+2,ks )] + + f4*f5*f3 * src[SRCIND3(is+1,js+2,ks )] + + f5*f5*f3 * src[SRCIND3(is+2,js+2,ks )] + + f6*f5*f3 * src[SRCIND3(is+3,js+2,ks )] + + f1*f6*f3 * src[SRCIND3(is-2,js+3,ks )] + + f2*f6*f3 * src[SRCIND3(is-1,js+3,ks )] + + f3*f6*f3 * src[SRCIND3(is ,js+3,ks )] + + f4*f6*f3 * src[SRCIND3(is+1,js+3,ks )] + + f5*f6*f3 * src[SRCIND3(is+2,js+3,ks )] + + f6*f6*f3 * src[SRCIND3(is+3,js+3,ks )]; + T const res4 = + + f1*f1*f4 * src[SRCIND3(is-2,js-2,ks+1)] + + f2*f1*f4 * src[SRCIND3(is-1,js-2,ks+1)] + + f3*f1*f4 * src[SRCIND3(is ,js-2,ks+1)] + + f4*f1*f4 * src[SRCIND3(is+1,js-2,ks+1)] + + f5*f1*f4 * src[SRCIND3(is+2,js-2,ks+1)] + + f6*f1*f4 * src[SRCIND3(is+3,js-2,ks+1)] + + f1*f2*f4 * src[SRCIND3(is-2,js-1,ks+1)] + + f2*f2*f4 * src[SRCIND3(is-1,js-1,ks+1)] + + f3*f2*f4 * src[SRCIND3(is ,js-1,ks+1)] + + f4*f2*f4 * src[SRCIND3(is+1,js-1,ks+1)] + + f5*f2*f4 * src[SRCIND3(is+2,js-1,ks+1)] + + f6*f2*f4 * src[SRCIND3(is+3,js-1,ks+1)] + + f1*f3*f4 * src[SRCIND3(is-2,js ,ks+1)] + + f2*f3*f4 * src[SRCIND3(is-1,js ,ks+1)] + + f3*f3*f4 * src[SRCIND3(is ,js ,ks+1)] + + f4*f3*f4 * src[SRCIND3(is+1,js ,ks+1)] + + f5*f3*f4 * src[SRCIND3(is+2,js ,ks+1)] + + f6*f3*f4 * src[SRCIND3(is+3,js ,ks+1)] + + f1*f4*f4 * src[SRCIND3(is-2,js+1,ks+1)] + + f2*f4*f4 * src[SRCIND3(is-1,js+1,ks+1)] + + f3*f4*f4 * src[SRCIND3(is ,js+1,ks+1)] + + f4*f4*f4 * src[SRCIND3(is+1,js+1,ks+1)] + + f5*f4*f4 * src[SRCIND3(is+2,js+1,ks+1)] + + f6*f4*f4 * src[SRCIND3(is+3,js+1,ks+1)] + + f1*f5*f4 * src[SRCIND3(is-2,js+2,ks+1)] + + f2*f5*f4 * src[SRCIND3(is-1,js+2,ks+1)] + + f3*f5*f4 * src[SRCIND3(is ,js+2,ks+1)] + + f4*f5*f4 * src[SRCIND3(is+1,js+2,ks+1)] + + f5*f5*f4 * src[SRCIND3(is+2,js+2,ks+1)] + + f6*f5*f4 * src[SRCIND3(is+3,js+2,ks+1)] + + f1*f6*f4 * src[SRCIND3(is-2,js+3,ks+1)] + + f2*f6*f4 * src[SRCIND3(is-1,js+3,ks+1)] + + f3*f6*f4 * src[SRCIND3(is ,js+3,ks+1)] + + f4*f6*f4 * src[SRCIND3(is+1,js+3,ks+1)] + + f5*f6*f4 * src[SRCIND3(is+2,js+3,ks+1)] + + f6*f6*f4 * src[SRCIND3(is+3,js+3,ks+1)]; + T const res5 = + + f1*f1*f5 * src[SRCIND3(is-2,js-2,ks+2)] + + f2*f1*f5 * src[SRCIND3(is-1,js-2,ks+2)] + + f3*f1*f5 * src[SRCIND3(is ,js-2,ks+2)] + + f4*f1*f5 * src[SRCIND3(is+1,js-2,ks+2)] + + f5*f1*f5 * src[SRCIND3(is+2,js-2,ks+2)] + + f6*f1*f5 * src[SRCIND3(is+3,js-2,ks+2)] + + f1*f2*f5 * src[SRCIND3(is-2,js-1,ks+2)] + + f2*f2*f5 * src[SRCIND3(is-1,js-1,ks+2)] + + f3*f2*f5 * src[SRCIND3(is ,js-1,ks+2)] + + f4*f2*f5 * src[SRCIND3(is+1,js-1,ks+2)] + + f5*f2*f5 * src[SRCIND3(is+2,js-1,ks+2)] + + f6*f2*f5 * src[SRCIND3(is+3,js-1,ks+2)] + + f1*f3*f5 * src[SRCIND3(is-2,js ,ks+2)] + + f2*f3*f5 * src[SRCIND3(is-1,js ,ks+2)] + + f3*f3*f5 * src[SRCIND3(is ,js ,ks+2)] + + f4*f3*f5 * src[SRCIND3(is+1,js ,ks+2)] + + f5*f3*f5 * src[SRCIND3(is+2,js ,ks+2)] + + f6*f3*f5 * src[SRCIND3(is+3,js ,ks+2)] + + f1*f4*f5 * src[SRCIND3(is-2,js+1,ks+2)] + + f2*f4*f5 * src[SRCIND3(is-1,js+1,ks+2)] + + f3*f4*f5 * src[SRCIND3(is ,js+1,ks+2)] + + f4*f4*f5 * src[SRCIND3(is+1,js+1,ks+2)] + + f5*f4*f5 * src[SRCIND3(is+2,js+1,ks+2)] + + f6*f4*f5 * src[SRCIND3(is+3,js+1,ks+2)] + + f1*f5*f5 * src[SRCIND3(is-2,js+2,ks+2)] + + f2*f5*f5 * src[SRCIND3(is-1,js+2,ks+2)] + + f3*f5*f5 * src[SRCIND3(is ,js+2,ks+2)] + + f4*f5*f5 * src[SRCIND3(is+1,js+2,ks+2)] + + f5*f5*f5 * src[SRCIND3(is+2,js+2,ks+2)] + + f6*f5*f5 * src[SRCIND3(is+3,js+2,ks+2)] + + f1*f6*f5 * src[SRCIND3(is-2,js+3,ks+2)] + + f2*f6*f5 * src[SRCIND3(is-1,js+3,ks+2)] + + f3*f6*f5 * src[SRCIND3(is ,js+3,ks+2)] + + f4*f6*f5 * src[SRCIND3(is+1,js+3,ks+2)] + + f5*f6*f5 * src[SRCIND3(is+2,js+3,ks+2)] + + f6*f6*f5 * src[SRCIND3(is+3,js+3,ks+2)]; + T const res6 = + + f1*f1*f6 * src[SRCIND3(is-2,js-2,ks+3)] + + f2*f1*f6 * src[SRCIND3(is-1,js-2,ks+3)] + + f3*f1*f6 * src[SRCIND3(is ,js-2,ks+3)] + + f4*f1*f6 * src[SRCIND3(is+1,js-2,ks+3)] + + f5*f1*f6 * src[SRCIND3(is+2,js-2,ks+3)] + + f6*f1*f6 * src[SRCIND3(is+3,js-2,ks+3)] + + f1*f2*f6 * src[SRCIND3(is-2,js-1,ks+3)] + + f2*f2*f6 * src[SRCIND3(is-1,js-1,ks+3)] + + f3*f2*f6 * src[SRCIND3(is ,js-1,ks+3)] + + f4*f2*f6 * src[SRCIND3(is+1,js-1,ks+3)] + + f5*f2*f6 * src[SRCIND3(is+2,js-1,ks+3)] + + f6*f2*f6 * src[SRCIND3(is+3,js-1,ks+3)] + + f1*f3*f6 * src[SRCIND3(is-2,js ,ks+3)] + + f2*f3*f6 * src[SRCIND3(is-1,js ,ks+3)] + + f3*f3*f6 * src[SRCIND3(is ,js ,ks+3)] + + f4*f3*f6 * src[SRCIND3(is+1,js ,ks+3)] + + f5*f3*f6 * src[SRCIND3(is+2,js ,ks+3)] + + f6*f3*f6 * src[SRCIND3(is+3,js ,ks+3)] + + f1*f4*f6 * src[SRCIND3(is-2,js+1,ks+3)] + + f2*f4*f6 * src[SRCIND3(is-1,js+1,ks+3)] + + f3*f4*f6 * src[SRCIND3(is ,js+1,ks+3)] + + f4*f4*f6 * src[SRCIND3(is+1,js+1,ks+3)] + + f5*f4*f6 * src[SRCIND3(is+2,js+1,ks+3)] + + f6*f4*f6 * src[SRCIND3(is+3,js+1,ks+3)] + + f1*f5*f6 * src[SRCIND3(is-2,js+2,ks+3)] + + f2*f5*f6 * src[SRCIND3(is-1,js+2,ks+3)] + + f3*f5*f6 * src[SRCIND3(is ,js+2,ks+3)] + + f4*f5*f6 * src[SRCIND3(is+1,js+2,ks+3)] + + f5*f5*f6 * src[SRCIND3(is+2,js+2,ks+3)] + + f6*f5*f6 * src[SRCIND3(is+3,js+2,ks+3)] + + f1*f6*f6 * src[SRCIND3(is-2,js+3,ks+3)] + + f2*f6*f6 * src[SRCIND3(is-1,js+3,ks+3)] + + f3*f6*f6 * src[SRCIND3(is ,js+3,ks+3)] + + f4*f6*f6 * src[SRCIND3(is+1,js+3,ks+3)] + + f5*f6*f6 * src[SRCIND3(is+2,js+3,ks+3)] + + f6*f6*f6 * src[SRCIND3(is+3,js+3,ks+3)]; + dst[DSTIND3(id,jd,kd)] = res1 + res2 + res3 + res4 + res5 + res6; + } + i = i+1; + id = id+1; + is = is+1; + if (i < regiext) goto l8110; + goto l911; + + // end i loop + l911: + j = j+1; + jd = jd+1; + js = js+1; + if (j < regjext) goto l810; + goto l91; + + // end j loop + l91: + k = k+1; + kd = kd+1; + ks = ks+1; + if (k < regkext) goto l80; + goto l9; + + // end k loop + l9:; + + } + + + + template + void + prolongate_3d_o5_rf2 (CCTK_REAL const * restrict const src, + ivect3 const & srcext, + CCTK_REAL * restrict const dst, + ivect3 const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox); + + template + void + prolongate_3d_o5_rf2 (CCTK_COMPLEX const * restrict const src, + ivect3 const & srcext, + CCTK_COMPLEX * restrict const dst, + ivect3 const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox); + + + +} // namespace CarpetLib diff --git a/Carpet/CarpetLib/src/prolongate_3d_real8.F77 b/Carpet/CarpetLib/src/prolongate_3d_real8.F77 deleted file mode 100644 index 4383fe0c9..000000000 --- a/Carpet/CarpetLib/src/prolongate_3d_real8.F77 +++ /dev/null @@ -1,184 +0,0 @@ -c -*-Fortran-*- - -#include "cctk.h" -#include "cctk_Parameters.h" - - - - subroutine prolongate_3d_real8 ( - $ src, srciext, srcjext, srckext, - $ dst, dstiext, dstjext, dstkext, - $ srcbbox, dstbbox, regbbox) - - implicit none - - DECLARE_CCTK_PARAMETERS - - CCTK_REAL8 one - parameter (one = 1) - - integer srciext, srcjext, srckext - CCTK_REAL8 src(srciext,srcjext,srckext) - integer dstiext, dstjext, dstkext - CCTK_REAL8 dst(dstiext,dstjext,dstkext) -c bbox(:,1) is lower boundary (inclusive) -c bbox(:,2) is upper boundary (inclusive) -c bbox(:,3) is stride - integer srcbbox(3,3), dstbbox(3,3), regbbox(3,3) - - integer regiext, regjext, regkext - - integer dstifac, dstjfac, dstkfac - - integer srcioff, srcjoff, srckoff - integer dstioff, dstjoff, dstkoff - - CCTK_REAL8 dstdiv - integer i, j, k - integer i0, j0, k0 - integer fi, fj, fk - integer ifac(2), jfac(2), kfac(2) - integer ii, jj, kk - integer fac - CCTK_REAL8 res - integer d - - - - do d=1,3 - if (srcbbox(d,3).eq.0 .or. dstbbox(d,3).eq.0 - $ .or. regbbox(d,3).eq.0) then - call CCTK_WARN (0, "Internal error: stride is zero") - end if - if (srcbbox(d,3).le.regbbox(d,3) - $ .or. dstbbox(d,3).ne.regbbox(d,3)) then - call CCTK_WARN (0, "Internal error: strides disagree") - end if - if (mod(srcbbox(d,3), dstbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: destination strides are not integer multiples of the source strides") - end if - if (mod(srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array origins are not integer multiples of the strides") - end if - if (regbbox(d,1).gt.regbbox(d,2)) then -c This could be handled, but is likely to point to an error elsewhere - call CCTK_WARN (0, "Internal error: region extent is empty") - end if - if (mod(srcbbox(d,2) - srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,2) - dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,2) - regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array extents are not integer multiples of the strides") - end if - if (regbbox(d,1).lt.srcbbox(d,1) - $ .or. regbbox(d,1).lt.dstbbox(d,1) - $ .or. regbbox(d,2).gt.srcbbox(d,2) - $ .or. regbbox(d,2).gt.dstbbox(d,2)) then - call CCTK_WARN (0, "Internal error: region extent is not contained in array extent") - end if - end do - - if (srciext.ne.(srcbbox(1,2)-srcbbox(1,1))/srcbbox(1,3)+1 - $ .or. srcjext.ne.(srcbbox(2,2)-srcbbox(2,1))/srcbbox(2,3)+1 - $ .or. srckext.ne.(srcbbox(3,2)-srcbbox(3,1))/srcbbox(3,3)+1 - $ .or. dstiext.ne.(dstbbox(1,2)-dstbbox(1,1))/dstbbox(1,3)+1 - $ .or. dstjext.ne.(dstbbox(2,2)-dstbbox(2,1))/dstbbox(2,3)+1 - $ .or. dstkext.ne.(dstbbox(3,2)-dstbbox(3,1))/dstbbox(3,3)+1) then - call CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes") - end if - - - - regiext = (regbbox(1,2) - regbbox(1,1)) / regbbox(1,3) + 1 - regjext = (regbbox(2,2) - regbbox(2,1)) / regbbox(2,3) + 1 - regkext = (regbbox(3,2) - regbbox(3,1)) / regbbox(3,3) + 1 - - dstifac = srcbbox(1,3) / dstbbox(1,3) - dstjfac = srcbbox(2,3) / dstbbox(2,3) - dstkfac = srcbbox(3,3) / dstbbox(3,3) - - srcioff = (regbbox(1,1) - srcbbox(1,1)) / dstbbox(1,3) - srcjoff = (regbbox(2,1) - srcbbox(2,1)) / dstbbox(2,3) - srckoff = (regbbox(3,1) - srcbbox(3,1)) / dstbbox(3,3) - - dstioff = (regbbox(1,1) - dstbbox(1,1)) / dstbbox(1,3) - dstjoff = (regbbox(2,1) - dstbbox(2,1)) / dstbbox(2,3) - dstkoff = (regbbox(3,1) - dstbbox(3,1)) / dstbbox(3,3) - - - -c Loop over fine region - dstdiv = one / (dstifac * dstjfac * dstkfac) - - do k = 0, regkext-1 - k0 = (srckoff + k) / dstkfac - fk = mod(srckoff + k, dstkfac) - kfac(1) = (fk-dstkfac) * (-1) - kfac(2) = (fk ) * 1 - - do j = 0, regjext-1 - j0 = (srcjoff + j) / dstjfac - fj = mod(srcjoff + j, dstjfac) - jfac(1) = (fj-dstjfac) * (-1) - jfac(2) = (fj ) * 1 - - do i = 0, regiext-1 - i0 = (srcioff + i) / dstifac - fi = mod(srcioff + i, dstifac) - ifac(1) = (fi-dstifac) * (-1) - ifac(2) = (fi ) * 1 - - res = 0 - - do kk=1,2 - do jj=1,2 - do ii=1,2 - - fac = ifac(ii) * jfac(jj) * kfac(kk) - - if (fac.ne.0) then - if (check_array_accesses.ne.0) then - call checkindex (i0+ii, j0+jj, k0+kk, 1,1,1, srciext,srcjext,srckext, "source") - end if - res = res + fac * src(i0+ii, j0+jj, k0+kk) - end if - - end do - end do - end do - -c$$$ fac = ifac(1) * jfac(1) * kfac(1) -c$$$ if (fac.ne.0) res = res + fac * src(i0+1, j0+1, k0+1) -c$$$ -c$$$ fac = ifac(2) * jfac(1) * kfac(1) -c$$$ if (fac.ne.0) res = res + fac * src(i0+2, j0+1, k0+1) -c$$$ -c$$$ fac = ifac(1) * jfac(2) * kfac(1) -c$$$ if (fac.ne.0) res = res + fac * src(i0+1, j0+2, k0+1) -c$$$ -c$$$ fac = ifac(2) * jfac(2) * kfac(1) -c$$$ if (fac.ne.0) res = res + fac * src(i0+2, j0+2, k0+1) -c$$$ -c$$$ fac = ifac(1) * jfac(1) * kfac(2) -c$$$ if (fac.ne.0) res = res + fac * src(i0+1, j0+1, k0+2) -c$$$ -c$$$ fac = ifac(2) * jfac(1) * kfac(2) -c$$$ if (fac.ne.0) res = res + fac * src(i0+2, j0+1, k0+2) -c$$$ -c$$$ fac = ifac(1) * jfac(2) * kfac(2) -c$$$ if (fac.ne.0) res = res + fac * src(i0+1, j0+2, k0+2) -c$$$ -c$$$ fac = ifac(2) * jfac(2) * kfac(2) -c$$$ if (fac.ne.0) res = res + fac * src(i0+2, j0+2, k0+2) - - if (check_array_accesses.ne.0) then - call checkindex (dstioff+i+1, dstjoff+j+1, dstkoff+k+1, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst (dstioff+i+1, dstjoff+j+1, dstkoff+k+1) = dstdiv * res - - end do - end do - end do - - end diff --git a/Carpet/CarpetLib/src/prolongate_3d_real8_2tl.F77 b/Carpet/CarpetLib/src/prolongate_3d_real8_2tl.F77 deleted file mode 100644 index 0bf91a371..000000000 --- a/Carpet/CarpetLib/src/prolongate_3d_real8_2tl.F77 +++ /dev/null @@ -1,184 +0,0 @@ -c -*-Fortran-*- - -#include "cctk.h" -#include "cctk_Parameters.h" - - - - subroutine prolongate_3d_real8_2tl ( - $ src1, t1, src2, t2, srciext, srcjext, srckext, - $ dst, t, dstiext, dstjext, dstkext, - $ srcbbox, dstbbox, regbbox) - - implicit none - - DECLARE_CCTK_PARAMETERS - - CCTK_REAL8 one - parameter (one = 1) - - CCTK_REAL8 eps - parameter (eps = 1.0d-10) - - integer srciext, srcjext, srckext - CCTK_REAL8 src1(srciext,srcjext,srckext) - CCTK_REAL8 t1 - CCTK_REAL8 src2(srciext,srcjext,srckext) - CCTK_REAL8 t2 - integer dstiext, dstjext, dstkext - CCTK_REAL8 dst(dstiext,dstjext,dstkext) - CCTK_REAL8 t -c bbox(:,1) is lower boundary (inclusive) -c bbox(:,2) is upper boundary (inclusive) -c bbox(:,3) is stride - integer srcbbox(3,3), dstbbox(3,3), regbbox(3,3) - - integer regiext, regjext, regkext - - integer dstifac, dstjfac, dstkfac - - integer srcioff, srcjoff, srckoff - integer dstioff, dstjoff, dstkoff - - CCTK_REAL8 s1fac, s2fac - - CCTK_REAL8 dstdiv - integer i, j, k - integer i0, j0, k0 - integer fi, fj, fk - integer ifac(2), jfac(2), kfac(2) - integer ii, jj, kk - integer fac - CCTK_REAL8 res - integer d - - - - do d=1,3 - if (srcbbox(d,3).eq.0 .or. dstbbox(d,3).eq.0 - $ .or. regbbox(d,3).eq.0) then - call CCTK_WARN (0, "Internal error: stride is zero") - end if - if (srcbbox(d,3).le.regbbox(d,3) - $ .or. dstbbox(d,3).ne.regbbox(d,3)) then - call CCTK_WARN (0, "Internal error: strides disagree") - end if - if (mod(srcbbox(d,3), dstbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: destination strides are not integer multiples of the source strides") - end if - if (mod(srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array origins are not integer multiples of the strides") - end if - if (regbbox(d,1).gt.regbbox(d,2)) then -c This could be handled, but is likely to point to an error elsewhere - call CCTK_WARN (0, "Internal error: region extent is empty") - end if - if (mod(srcbbox(d,2) - srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,2) - dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,2) - regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array extents are not integer multiples of the strides") - end if - if (regbbox(d,1).lt.srcbbox(d,1) - $ .or. regbbox(d,1).lt.dstbbox(d,1) - $ .or. regbbox(d,2).gt.srcbbox(d,2) - $ .or. regbbox(d,2).gt.dstbbox(d,2)) then - call CCTK_WARN (0, "Internal error: region extent is not contained in array extent") - end if - end do - - if (srciext.ne.(srcbbox(1,2)-srcbbox(1,1))/srcbbox(1,3)+1 - $ .or. srcjext.ne.(srcbbox(2,2)-srcbbox(2,1))/srcbbox(2,3)+1 - $ .or. srckext.ne.(srcbbox(3,2)-srcbbox(3,1))/srcbbox(3,3)+1 - $ .or. dstiext.ne.(dstbbox(1,2)-dstbbox(1,1))/dstbbox(1,3)+1 - $ .or. dstjext.ne.(dstbbox(2,2)-dstbbox(2,1))/dstbbox(2,3)+1 - $ .or. dstkext.ne.(dstbbox(3,2)-dstbbox(3,1))/dstbbox(3,3)+1) then - call CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes") - end if - - - - regiext = (regbbox(1,2) - regbbox(1,1)) / regbbox(1,3) + 1 - regjext = (regbbox(2,2) - regbbox(2,1)) / regbbox(2,3) + 1 - regkext = (regbbox(3,2) - regbbox(3,1)) / regbbox(3,3) + 1 - - dstifac = srcbbox(1,3) / dstbbox(1,3) - dstjfac = srcbbox(2,3) / dstbbox(2,3) - dstkfac = srcbbox(3,3) / dstbbox(3,3) - - srcioff = (regbbox(1,1) - srcbbox(1,1)) / dstbbox(1,3) - srcjoff = (regbbox(2,1) - srcbbox(2,1)) / dstbbox(2,3) - srckoff = (regbbox(3,1) - srcbbox(3,1)) / dstbbox(3,3) - - dstioff = (regbbox(1,1) - dstbbox(1,1)) / dstbbox(1,3) - dstjoff = (regbbox(2,1) - dstbbox(2,1)) / dstbbox(2,3) - dstkoff = (regbbox(3,1) - dstbbox(3,1)) / dstbbox(3,3) - - - -c Linear (first order) interpolation - if (t1.eq.t2) then - call CCTK_WARN (0, "Internal error: arrays have same time") - end if - if (t.lt.min(t1,t2)-eps .or. t.gt.max(t1,t2)+eps) then - call CCTK_WARN (0, "Internal error: extrapolation in time") - end if - - s1fac = (t - t2) / (t1 - t2) - s2fac = (t - t1) / (t2 - t1) - - - -c Loop over fine region - dstdiv = one / (dstifac * dstjfac * dstkfac) - - do k = 0, regkext-1 - k0 = (srckoff + k) / dstkfac - fk = mod(srckoff + k, dstkfac) - kfac(1) = (fk-dstkfac) * (-1) - kfac(2) = (fk ) * 1 - - do j = 0, regjext-1 - j0 = (srcjoff + j) / dstjfac - fj = mod(srcjoff + j, dstjfac) - jfac(1) = (fj-dstjfac) * (-1) - jfac(2) = (fj ) * 1 - - do i = 0, regiext-1 - i0 = (srcioff + i) / dstifac - fi = mod(srcioff + i, dstifac) - ifac(1) = (fi-dstifac) * (-1) - ifac(2) = (fi ) * 1 - - res = 0 - - do kk=1,2 - do jj=1,2 - do ii=1,2 - - fac = ifac(ii) * jfac(jj) * kfac(kk) - - if (fac.ne.0) then - if (check_array_accesses.ne.0) then - call checkindex (i0+ii, j0+jj, k0+kk, 1,1,1, srciext,srcjext,srckext, "source") - end if - res = res - $ + fac * s1fac * src1(i0+ii, j0+jj, k0+kk) - $ + fac * s2fac * src2(i0+ii, j0+jj, k0+kk) - end if - - end do - end do - end do - - if (check_array_accesses.ne.0) then - call checkindex (dstioff+i+1, dstjoff+j+1, dstkoff+k+1, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst (dstioff+i+1, dstjoff+j+1, dstkoff+k+1) = dstdiv * res - - end do - end do - end do - - end diff --git a/Carpet/CarpetLib/src/prolongate_3d_real8_2tl_eno.F90 b/Carpet/CarpetLib/src/prolongate_3d_real8_2tl_eno.F90 deleted file mode 100644 index 6fefb965a..000000000 --- a/Carpet/CarpetLib/src/prolongate_3d_real8_2tl_eno.F90 +++ /dev/null @@ -1,298 +0,0 @@ -#ifndef OMIT_F90 -!!$ -*-Fortran-*- - -#include "cctk.h" - - -!!$ This routine performs "ENO" prolongation. It is intended to be used -!!$ with GFs that are not expected to be smooth, particularly those -!!$ that must also obey certain constraints. The obvious example is the -!!$ density in hydrodynamics, which may be discontinuous yet must be -!!$ strictly positive. -!!$ -!!$ To ensure that this prolongation method is used you should add the -!!$ tag -!!$ -!!$ tags='Prolongation="ENO"' -!!$ -!!$ to the interface.ccl on the appropriate group. -!!$ -!!$ This applies ENO2 type limiting to the slope, checking over the -!!$ entire coarse grid cell for the least oscillatory quadratic in each -!!$ direction. If the slope changes sign over the extrema, linear -!!$ interpolation is used instead. -!!$ -!!$ The actual eno1d function is defined in the routine -!!$ -!!$ prolongate_3d_real8_eno.F77 - - -#define CHKIDX(i,j,k, imax,jmax,kmax, where) \ -if ((i).lt.1 .or. (i).gt.(imax) \ - .or. (j).lt.1 .or. (j).gt.(jmax) \ - .or. (k).lt.1 .or. (k).gt.(kmax)) then &&\ - write (msg, '(a, " array index out of bounds: shape is (",i4,",",i4,",",i4,"), index is (",i4,",",i4,",",i4,")")') \ - (where), (imax), (jmax), (kmax), (i), (j), (k) &&\ - call CCTK_WARN (0, msg(1:len_trim(msg))) &&\ -end if - -subroutine prolongate_3d_real8_2tl_eno (src1, t1, src2, t2, & - srciext, srcjext, srckext, dst, t, dstiext, dstjext, dstkext, & - srcbbox, dstbbox, regbbox) - - implicit none - - CCTK_REAL8 one - parameter (one = 1) - - CCTK_REAL8 eps - parameter (eps = 1.0d-10) - - integer srciext, srcjext, srckext - CCTK_REAL8 src1(srciext,srcjext,srckext) - CCTK_REAL8 t1 - CCTK_REAL8 src2(srciext,srcjext,srckext) - CCTK_REAL8 t2 - integer dstiext, dstjext, dstkext - CCTK_REAL8 dst(dstiext,dstjext,dstkext) - CCTK_REAL8 t - -!!$ bbox(:,1) is lower boundary (inclusive) -!!$ bbox(:,2) is upper boundary (inclusive) -!!$ bbox(:,3) is stride - integer srcbbox(3,3), dstbbox(3,3), regbbox(3,3) - - integer offsetlo, offsethi - - integer regiext, regjext, regkext - - integer dstifac, dstjfac, dstkfac - - integer srcioff, srcjoff, srckoff - integer dstioff, dstjoff, dstkoff - - CCTK_REAL8 s1fac, s2fac - - integer i, j, k - integer i0, j0, k0 - integer fi, fj, fk - integer ii, jj, kk - integer d - - CCTK_REAL8, dimension(0:3,0:3) :: tmp1 - CCTK_REAL8, dimension(0:3) :: tmp2 - CCTK_REAL8 :: dsttmp1, dsttmp2 - - external eno1d - CCTK_REAL8 eno1d - - CCTK_REAL8 half, zero - parameter (half = 0.5) - parameter (zero = 0) - - do d=1,3 - if (srcbbox(d,3).eq.0 .or. dstbbox(d,3).eq.0 & - .or. regbbox(d,3).eq.0) then - call CCTK_WARN (0, "Internal error: stride is zero") - end if - if (srcbbox(d,3).le.regbbox(d,3) & - .or. dstbbox(d,3).ne.regbbox(d,3)) then - call CCTK_WARN (0, "Internal error: strides disagree") - end if - if (mod(srcbbox(d,3), dstbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: destination strides are not integer multiples of the source strides") - end if - if (mod(srcbbox(d,1), srcbbox(d,3)).ne.0 & - .or. mod(dstbbox(d,1), dstbbox(d,3)).ne.0 & - .or. mod(regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array origins are not integer multiples of the strides") - end if - if (regbbox(d,1).gt.regbbox(d,2)) then -!!$ This could be handled, but is likely to point to an error elsewhere - call CCTK_WARN (0, "Internal error: region extent is empty") - end if - regkext = (regbbox(d,2) - regbbox(d,1)) / regbbox(d,3) + 1 - dstkfac = srcbbox(d,3) / dstbbox(d,3) - srckoff = (regbbox(d,1) - srcbbox(d,1)) / dstbbox(d,3) - offsetlo = regbbox(d,3) - if (mod(srckoff + 0, dstkfac).eq.0) then - offsetlo = 0 - if (regkext.gt.1) then - offsetlo = regbbox(d,3) - end if - end if - offsethi = regbbox(d,3) - if (mod(srckoff + regkext-1, dstkfac).eq.0) then - offsethi = 0 - if (regkext.gt.1) then - offsethi = regbbox(d,3) - end if - end if - if (regbbox(d,1)-offsetlo.lt.srcbbox(d,1) & - .or. regbbox(d,2)+offsethi.gt.srcbbox(d,2) & - .or. regbbox(d,1).lt.dstbbox(d,1) & - .or. regbbox(d,2).gt.dstbbox(d,2)) then - call CCTK_WARN (0, "Internal error: region extent is not contained in array extent") - end if - end do - - if (srciext.ne.(srcbbox(1,2)-srcbbox(1,1))/srcbbox(1,3)+1 & - .or. srcjext.ne.(srcbbox(2,2)-srcbbox(2,1))/srcbbox(2,3)+1 & - .or. srckext.ne.(srcbbox(3,2)-srcbbox(3,1))/srcbbox(3,3)+1 & - .or. dstiext.ne.(dstbbox(1,2)-dstbbox(1,1))/dstbbox(1,3)+1 & - .or. dstjext.ne.(dstbbox(2,2)-dstbbox(2,1))/dstbbox(2,3)+1 & - .or. dstkext.ne.(dstbbox(3,2)-dstbbox(3,1))/dstbbox(3,3)+1) then - call CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes") - end if - - regiext = (regbbox(1,2) - regbbox(1,1)) / regbbox(1,3) + 1 - regjext = (regbbox(2,2) - regbbox(2,1)) / regbbox(2,3) + 1 - regkext = (regbbox(3,2) - regbbox(3,1)) / regbbox(3,3) + 1 - - dstifac = srcbbox(1,3) / dstbbox(1,3) - dstjfac = srcbbox(2,3) / dstbbox(2,3) - dstkfac = srcbbox(3,3) / dstbbox(3,3) - - srcioff = (regbbox(1,1) - srcbbox(1,1)) / dstbbox(1,3) - srcjoff = (regbbox(2,1) - srcbbox(2,1)) / dstbbox(2,3) - srckoff = (regbbox(3,1) - srcbbox(3,1)) / dstbbox(3,3) - - dstioff = (regbbox(1,1) - dstbbox(1,1)) / dstbbox(1,3) - dstjoff = (regbbox(2,1) - dstbbox(2,1)) / dstbbox(2,3) - dstkoff = (regbbox(3,1) - dstbbox(3,1)) / dstbbox(3,3) - -!!$ Linear (first order) interpolation - if (t1.eq.t2) then - call CCTK_WARN (0, "Internal error: arrays have same time") - end if - if (t.lt.min(t1,t2)-eps .or. t.gt.max(t1,t2)+eps) then - call CCTK_WARN (0, "Internal error: extrapolation in time") - end if - - s1fac = (t - t2) / (t1 - t2) - s2fac = (t - t1) / (t2 - t1) - -!!$ Loop over fine region - - do k = 0, regkext-1 - k0 = (srckoff + k) / dstkfac - fk = mod(srckoff + k, dstkfac) - - do j = 0, regjext-1 - j0 = (srcjoff + j) / dstjfac - fj = mod(srcjoff + j, dstjfac) - - do i = 0, regiext-1 - i0 = (srcioff + i) / dstifac - fi = mod(srcioff + i, dstifac) - -!!$ Where is the fine grid point w.r.t the coarse grid? - - select case (fi + 10*fj + 100*fk) - case (0) -!!$ On a coarse grid point exactly! - - dsttmp1 = src1(i0+1,j0+1,k0+1) - dsttmp2 = src2(i0+1,j0+1,k0+1) - - case (1) -!!$ Interpolate only in x - - dsttmp1 = eno1d(src1(i0:i0+3,j0+1,k0+1)) - dsttmp2 = eno1d(src2(i0:i0+3,j0+1,k0+1)) - - case (10) -!!$ Interpolate only in y - - dsttmp1 = eno1d(src1(i0+1,j0:j0+3,k0+1)) - dsttmp2 = eno1d(src2(i0+1,j0:j0+3,k0+1)) - - case (11) -!!$ Interpolate only in x and y - - do jj = 0, 3 - tmp2(jj) = eno1d(src1(i0:i0+3,j0+jj,k0+1)) - end do - - dsttmp1 = eno1d(tmp2(0:3)) - - do jj = 0, 3 - tmp2(jj) = eno1d(src2(i0:i0+3,j0+jj,k0+1)) - end do - - dsttmp2 = eno1d(tmp2(0:3)) - - case (100) -!!$ Interpolate only in z - - dsttmp1 = eno1d(src1(i0+1,j0+1,k0:k0+3)) - dsttmp2 = eno1d(src2(i0+1,j0+1,k0:k0+3)) - - case (101) -!!$ Interpolate only in x and z - - do kk = 0, 3 - tmp2(kk) = eno1d(src1(i0:i0+3,j0+1,k0+kk)) - end do - - dsttmp1 = eno1d(tmp2(0:3)) - - do kk = 0, 3 - tmp2(kk) = eno1d(src2(i0:i0+3,j0+1,k0+kk)) - end do - - dsttmp2 = eno1d(tmp2(0:3)) - - case (110) -!!$ Interpolate only in y and z - - do kk = 0, 3 - tmp2(kk) = eno1d(src1(i0+1,j0:j0+3,k0+kk)) - end do - - dsttmp1 = eno1d(tmp2(0:3)) - - do kk = 0, 3 - tmp2(kk) = eno1d(src2(i0+1,j0:j0+3,k0+kk)) - end do - - dsttmp2 = eno1d(tmp2(0:3)) - - case (111) -!!$ Interpolate in all of x, y, and z - - do jj = 0, 3 - do kk = 0, 3 - tmp1(jj,kk) = eno1d(src1(i0:i0+3,j0+jj,k0+kk)) - end do - end do - do ii = 0, 3 - tmp2(ii) = eno1d(tmp1(0:3,ii)) - end do - - dsttmp1 = eno1d(tmp2(0:3)) - - do jj = 0, 3 - do kk = 0, 3 - tmp1(jj,kk) = eno1d(src2(i0:i0+3,j0+jj,k0+kk)) - end do - end do - do ii = 0, 3 - tmp2(ii) = eno1d(tmp1(0:3,ii)) - end do - - dsttmp2 = eno1d(tmp2(0:3)) - - case default - call CCTK_WARN(0, "Internal error in ENO prolongation. Should only be used with refinement factor 2!") - end select - - dst (dstioff+i+1, dstjoff+j+1, dstkoff+k+1) = & - s1fac * dsttmp1 + s2fac * dsttmp2 - - end do - end do - end do - -end subroutine prolongate_3d_real8_2tl_eno -#endif /* !OMIT_F90 */ diff --git a/Carpet/CarpetLib/src/prolongate_3d_real8_2tl_minmod.F77 b/Carpet/CarpetLib/src/prolongate_3d_real8_2tl_minmod.F77 deleted file mode 100644 index ab086faf7..000000000 --- a/Carpet/CarpetLib/src/prolongate_3d_real8_2tl_minmod.F77 +++ /dev/null @@ -1,313 +0,0 @@ -c -*-Fortran-*- - -#include "cctk.h" -#include "cctk_Parameters.h" - -c$$$ This routine performs "TVD" prolongation. It is intended to be used -c$$$ with GFs that are not expected to be smooth, particularly those -c$$$ that must also obey certain constraints. The obvious example is the -c$$$ density in hydrodynamics, which may be discontinuous yet must be -c$$$ strictly positive. -c$$$ -c$$$ To ensure that this prolongation method is used you should add the -c$$$ tag -c$$$ -c$$$ tags='Prolongation="TVD"' -c$$$ -c$$$ to the interface.ccl on the appropriate group. -c$$$ -c$$$ This applies minmod type limiting to the slope, checking over the -c$$$ entire coarse grid cell for the minimum modulus in each direction. -c$$$ -c$$$ The actual minmod function is defined in the routine -c$$$ -c$$$ prolongate_3d_real8_minmod.F77 - - - - subroutine prolongate_3d_real8_2tl_minmod ( - $ src1, t1, src2, t2, srciext, srcjext, srckext, - $ dst, t, dstiext, dstjext, dstkext, - $ srcbbox, dstbbox, regbbox) - - implicit none - - DECLARE_CCTK_PARAMETERS - - CCTK_REAL8 one - parameter (one = 1) - - CCTK_REAL8 eps - parameter (eps = 1.0d-10) - - integer srciext, srcjext, srckext - CCTK_REAL8 src1(srciext,srcjext,srckext) - CCTK_REAL8 t1 - CCTK_REAL8 src2(srciext,srcjext,srckext) - CCTK_REAL8 t2 - integer dstiext, dstjext, dstkext - CCTK_REAL8 dst(dstiext,dstjext,dstkext) - CCTK_REAL8 t -c bbox(:,1) is lower boundary (inclusive) -c bbox(:,2) is upper boundary (inclusive) -c bbox(:,3) is stride - integer srcbbox(3,3), dstbbox(3,3), regbbox(3,3) - - integer offsetlo, offsethi - - integer regiext, regjext, regkext - - integer dstifac, dstjfac, dstkfac - - integer srcioff, srcjoff, srckoff - integer dstioff, dstjoff, dstkoff - - CCTK_REAL8 s1fac, s2fac - - integer i, j, k - integer i0, j0, k0 - integer fi, fj, fk - integer ii, jj, kk - integer d - - - external minmod - CCTK_REAL8 minmod - - CCTK_REAL8 half, zero - parameter (half = 0.5) - parameter (zero = 0) - CCTK_REAL8 dupw, dloc, slopex(2), slopey(2), slopez(2) - - logical firstloop - - - do d=1,3 - if (srcbbox(d,3).eq.0 .or. dstbbox(d,3).eq.0 - $ .or. regbbox(d,3).eq.0) then - call CCTK_WARN (0, "Internal error: stride is zero") - end if - if (srcbbox(d,3).le.regbbox(d,3) - $ .or. dstbbox(d,3).ne.regbbox(d,3)) then - call CCTK_WARN (0, "Internal error: strides disagree") - end if - if (mod(srcbbox(d,3), dstbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: destination strides are not integer multiples of the source strides") - end if - if (mod(srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array origins are not integer multiples of the strides") - end if - if (regbbox(d,1).gt.regbbox(d,2)) then -c This could be handled, but is likely to point to an error elsewhere - call CCTK_WARN (0, "Internal error: region extent is empty") - end if - if (mod(srcbbox(d,2) - srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,2) - dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,2) - regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array extents are not integer multiples of the strides") - end if - regkext = (regbbox(d,2) - regbbox(d,1)) / regbbox(d,3) + 1 - dstkfac = srcbbox(d,3) / dstbbox(d,3) - srckoff = (regbbox(d,1) - srcbbox(d,1)) / dstbbox(d,3) - offsetlo = regbbox(d,3) - if (mod(srckoff + 0, dstkfac).eq.0) then - offsetlo = 0 - if (regkext.gt.1) then - offsetlo = regbbox(d,3) - end if - end if - offsethi = regbbox(d,3) - if (mod(srckoff + regkext-1, dstkfac).eq.0) then - offsethi = 0 - if (regkext.gt.1) then - offsethi = regbbox(d,3) - end if - end if - if (regbbox(d,1)-offsetlo.lt.srcbbox(d,1) - $ .or. regbbox(d,2)+offsethi.gt.srcbbox(d,2) - $ .or. regbbox(d,1).lt.dstbbox(d,1) - $ .or. regbbox(d,2).gt.dstbbox(d,2)) then - call CCTK_WARN (0, "Internal error: region extent is not contained in array extent") - end if - end do - - if (srciext.ne.(srcbbox(1,2)-srcbbox(1,1))/srcbbox(1,3)+1 - $ .or. srcjext.ne.(srcbbox(2,2)-srcbbox(2,1))/srcbbox(2,3)+1 - $ .or. srckext.ne.(srcbbox(3,2)-srcbbox(3,1))/srcbbox(3,3)+1 - $ .or. dstiext.ne.(dstbbox(1,2)-dstbbox(1,1))/dstbbox(1,3)+1 - $ .or. dstjext.ne.(dstbbox(2,2)-dstbbox(2,1))/dstbbox(2,3)+1 - $ .or. dstkext.ne.(dstbbox(3,2)-dstbbox(3,1))/dstbbox(3,3)+1) then - call CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes") - end if - - - - regiext = (regbbox(1,2) - regbbox(1,1)) / regbbox(1,3) + 1 - regjext = (regbbox(2,2) - regbbox(2,1)) / regbbox(2,3) + 1 - regkext = (regbbox(3,2) - regbbox(3,1)) / regbbox(3,3) + 1 - - dstifac = srcbbox(1,3) / dstbbox(1,3) - dstjfac = srcbbox(2,3) / dstbbox(2,3) - dstkfac = srcbbox(3,3) / dstbbox(3,3) - - srcioff = (regbbox(1,1) - srcbbox(1,1)) / dstbbox(1,3) - srcjoff = (regbbox(2,1) - srcbbox(2,1)) / dstbbox(2,3) - srckoff = (regbbox(3,1) - srcbbox(3,1)) / dstbbox(3,3) - - dstioff = (regbbox(1,1) - dstbbox(1,1)) / dstbbox(1,3) - dstjoff = (regbbox(2,1) - dstbbox(2,1)) / dstbbox(2,3) - dstkoff = (regbbox(3,1) - dstbbox(3,1)) / dstbbox(3,3) - - - -c Linear (first order) interpolation - if (t1.eq.t2) then - call CCTK_WARN (0, "Internal error: arrays have same time") - end if - if (t.lt.min(t1,t2)-eps .or. t.gt.max(t1,t2)+eps) then - call CCTK_WARN (0, "Internal error: extrapolation in time") - end if - - s1fac = (t - t2) / (t1 - t2) - s2fac = (t - t1) / (t2 - t1) - - - -c Loop over fine region - - do k = 0, regkext-1 - k0 = (srckoff + k) / dstkfac - fk = mod(srckoff + k, dstkfac) - - do j = 0, regjext-1 - j0 = (srcjoff + j) / dstjfac - fj = mod(srcjoff + j, dstjfac) - - do i = 0, regiext-1 - i0 = (srcioff + i) / dstifac - fi = mod(srcioff + i, dstifac) - - slopex(1) = zero - slopey(1) = zero - slopez(1) = zero - - firstloop = .true. - - do kk = 1, 2 - do jj = 1, 2 - - dupw = src1(i0+1 ,j0+jj,k0+kk) - src1(i0+0 ,j0+jj,k0+kk) - dloc = src1(i0+2 ,j0+jj,k0+kk) - src1(i0+1 ,j0+kk,k0+kk) - if (firstloop) then - slopex(1) = half * dble(fi) * minmod(dupw,dloc) - firstloop = .false. - else - slopex(1) = - $ minmod(slopex(1), half * dble(fi) * minmod(dupw,dloc)) - end if - end do - end do - - firstloop = .true. - - do kk = 1, 2 - do ii = 1, 2 - - dupw = src1(i0+ii,j0+1 ,k0+kk) - src1(i0+ii,j0+0 ,k0+kk) - dloc = src1(i0+ii,j0+2 ,k0+kk) - src1(i0+ii,j0+1 ,k0+kk) - if (firstloop) then - slopey(1) = half * dble(fj) * minmod(dupw,dloc) - firstloop = .false. - else - slopey(1) = - $ minmod(slopey(1), half * dble(fj) * minmod(dupw,dloc)) - end if - end do - end do - - firstloop = .true. - - do jj = 1, 2 - do ii = 1, 2 - - dupw = src1(i0+ii,j0+jj,k0+1 ) - src1(i0+ii,j0+jj,k0+0 ) - dloc = src1(i0+ii,j0+jj,k0+2 ) - src1(i0+ii,j0+jj,k0+1 ) - if (firstloop) then - slopez(1) = half * dble(fk) * minmod(dupw,dloc) - firstloop = .false. - else - slopez(1) = - $ minmod(slopez(1), half * dble(fk) * minmod(dupw,dloc)) - end if - end do - end do - - slopex(2) = zero - slopey(2) = zero - slopez(2) = zero - - firstloop = .true. - - do kk = 1, 2 - do jj = 1, 2 - - dupw = src2(i0+1 ,j0+jj,k0+kk) - src2(i0+0 ,j0+jj,k0+kk) - dloc = src2(i0+2 ,j0+jj,k0+kk) - src2(i0+1 ,j0+kk,k0+kk) - if (firstloop) then - slopex(2) = half * dble(fi) * minmod(dupw,dloc) - firstloop = .false. - else - slopex(2) = - $ minmod(slopex(2), half * dble(fi) * minmod(dupw,dloc)) - end if - end do - end do - - do kk = 1, 2 - do ii = 1, 2 - - dupw = src2(i0+ii,j0+1 ,k0+kk) - src2(i0+ii,j0+0 ,k0+kk) - dloc = src2(i0+ii,j0+2 ,k0+kk) - src2(i0+ii,j0+1 ,k0+kk) - if (firstloop) then - slopey(2) = half * dble(fj) * minmod(dupw,dloc) - firstloop = .false. - else - slopey(2) = - $ minmod(slopey(2), half * dble(fj) * minmod(dupw,dloc)) - end if - end do - end do - - firstloop = .true. - - do jj = 1, 2 - do ii = 1, 2 - - dupw = src2(i0+ii,j0+jj,k0+1 ) - src2(i0+ii,j0+jj,k0+0 ) - dloc = src2(i0+ii,j0+jj,k0+2 ) - src2(i0+ii,j0+jj,k0+1 ) - if (firstloop) then - slopez(2) = half * dble(fk) * minmod(dupw,dloc) - firstloop = .false. - else - slopez(2) = - $ minmod(slopez(2), half * dble(fk) * minmod(dupw,dloc)) - end if - end do - end do - - if (check_array_accesses.ne.0) then - call checkindex (dstioff+i+1, dstjoff+j+1, dstkoff+k+1, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst (dstioff+i+1, dstjoff+j+1, dstkoff+k+1) = - $ s1fac * (src1(i0+1,j0+1,k0+1) + - $ slopex(1) + slopey(1) + slopez(1)) + - $ s2fac * (src2(i0+1,j0+1,k0+1) + - $ slopex(2) + slopey(2) + slopez(2)) - - end do - end do - end do - - end diff --git a/Carpet/CarpetLib/src/prolongate_3d_real8_2tl_o3.F77 b/Carpet/CarpetLib/src/prolongate_3d_real8_2tl_o3.F77 deleted file mode 100644 index 4a0d55901..000000000 --- a/Carpet/CarpetLib/src/prolongate_3d_real8_2tl_o3.F77 +++ /dev/null @@ -1,209 +0,0 @@ -c -*-Fortran-*- - -#include "cctk.h" -#include "cctk_Parameters.h" - - - - subroutine prolongate_3d_real8_2tl_o3 ( - $ src1, t1, src2, t2, srciext, srcjext, srckext, - $ dst, t, dstiext, dstjext, dstkext, - $ srcbbox, dstbbox, regbbox) - - implicit none - - DECLARE_CCTK_PARAMETERS - - CCTK_REAL8 one - parameter (one = 1) - - CCTK_REAL8 eps - parameter (eps = 1.0d-10) - - integer srciext, srcjext, srckext - CCTK_REAL8 src1(srciext,srcjext,srckext) - CCTK_REAL8 t1 - CCTK_REAL8 src2(srciext,srcjext,srckext) - CCTK_REAL8 t2 - integer dstiext, dstjext, dstkext - CCTK_REAL8 dst(dstiext,dstjext,dstkext) - CCTK_REAL8 t -c bbox(:,1) is lower boundary (inclusive) -c bbox(:,2) is upper boundary (inclusive) -c bbox(:,3) is stride - integer srcbbox(3,3), dstbbox(3,3), regbbox(3,3) - - integer offsetlo, offsethi - - integer regiext, regjext, regkext - - integer dstifac, dstjfac, dstkfac - - integer srcioff, srcjoff, srckoff - integer dstioff, dstjoff, dstkoff - - CCTK_REAL8 s1fac, s2fac - - CCTK_REAL8 dstdiv - integer i, j, k - integer i0, j0, k0 - integer fi, fj, fk - integer ifac(4), jfac(4), kfac(4) - integer ii, jj, kk - integer fac - CCTK_REAL8 res - integer d - - - - do d=1,3 - if (srcbbox(d,3).eq.0 .or. dstbbox(d,3).eq.0 - $ .or. regbbox(d,3).eq.0) then - call CCTK_WARN (0, "Internal error: stride is zero") - end if - if (srcbbox(d,3).le.regbbox(d,3) - $ .or. dstbbox(d,3).ne.regbbox(d,3)) then - call CCTK_WARN (0, "Internal error: strides disagree") - end if - if (mod(srcbbox(d,3), dstbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: destination strides are not integer multiples of the source strides") - end if - if (mod(srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array origins are not integer multiples of the strides") - end if - if (regbbox(d,1).gt.regbbox(d,2)) then -c This could be handled, but is likely to point to an error elsewhere - call CCTK_WARN (0, "Internal error: region extent is empty") - end if - if (mod(srcbbox(d,2) - srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,2) - dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,2) - regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array extents are not integer multiples of the strides") - end if - regkext = (regbbox(d,2) - regbbox(d,1)) / regbbox(d,3) + 1 - dstkfac = srcbbox(d,3) / dstbbox(d,3) - srckoff = (regbbox(d,1) - srcbbox(d,1)) / dstbbox(d,3) - offsetlo = regbbox(d,3) - if (mod(srckoff + 0, dstkfac).eq.0) then - offsetlo = 0 - if (regkext.gt.1) then - offsetlo = regbbox(d,3) - end if - end if - offsethi = regbbox(d,3) - if (mod(srckoff + regkext-1, dstkfac).eq.0) then - offsethi = 0 - if (regkext.gt.1) then - offsethi = regbbox(d,3) - end if - end if - if (regbbox(d,1)-offsetlo.lt.srcbbox(d,1) - $ .or. regbbox(d,2)+offsethi.gt.srcbbox(d,2) - $ .or. regbbox(d,1).lt.dstbbox(d,1) - $ .or. regbbox(d,2).gt.dstbbox(d,2)) then - call CCTK_WARN (0, "Internal error: region extent is not contained in array extent") - end if - end do - - if (srciext.ne.(srcbbox(1,2)-srcbbox(1,1))/srcbbox(1,3)+1 - $ .or. srcjext.ne.(srcbbox(2,2)-srcbbox(2,1))/srcbbox(2,3)+1 - $ .or. srckext.ne.(srcbbox(3,2)-srcbbox(3,1))/srcbbox(3,3)+1 - $ .or. dstiext.ne.(dstbbox(1,2)-dstbbox(1,1))/dstbbox(1,3)+1 - $ .or. dstjext.ne.(dstbbox(2,2)-dstbbox(2,1))/dstbbox(2,3)+1 - $ .or. dstkext.ne.(dstbbox(3,2)-dstbbox(3,1))/dstbbox(3,3)+1) then - call CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes") - end if - - - - regiext = (regbbox(1,2) - regbbox(1,1)) / regbbox(1,3) + 1 - regjext = (regbbox(2,2) - regbbox(2,1)) / regbbox(2,3) + 1 - regkext = (regbbox(3,2) - regbbox(3,1)) / regbbox(3,3) + 1 - - dstifac = srcbbox(1,3) / dstbbox(1,3) - dstjfac = srcbbox(2,3) / dstbbox(2,3) - dstkfac = srcbbox(3,3) / dstbbox(3,3) - - srcioff = (regbbox(1,1) - srcbbox(1,1)) / dstbbox(1,3) - srcjoff = (regbbox(2,1) - srcbbox(2,1)) / dstbbox(2,3) - srckoff = (regbbox(3,1) - srcbbox(3,1)) / dstbbox(3,3) - - dstioff = (regbbox(1,1) - dstbbox(1,1)) / dstbbox(1,3) - dstjoff = (regbbox(2,1) - dstbbox(2,1)) / dstbbox(2,3) - dstkoff = (regbbox(3,1) - dstbbox(3,1)) / dstbbox(3,3) - - - -c Linear (first order) interpolation - if (t1.eq.t2) then - call CCTK_WARN (0, "Internal error: arrays have same time") - end if - if (t.lt.min(t1,t2)-eps .or. t.gt.max(t1,t2)+eps) then - call CCTK_WARN (0, "Internal error: extrapolation in time") - end if - - s1fac = (t - t2) / (t1 - t2) - s2fac = (t - t1) / (t2 - t1) - - - -c Loop over fine region - dstdiv = one / (6*dstifac**3 * 6*dstjfac**3 * 6*dstkfac**3) - - do k = 0, regkext-1 - k0 = (srckoff + k) / dstkfac - fk = mod(srckoff + k, dstkfac) - kfac(1) = (fk ) * (fk-dstkfac) * (fk-2*dstkfac) * (-1) - kfac(2) = (fk+dstkfac) * (fk-dstkfac) * (fk-2*dstkfac) * 3 - kfac(3) = (fk+dstkfac) * (fk ) * (fk-2*dstkfac) * (-3) - kfac(4) = (fk+dstkfac) * (fk ) * (fk- dstkfac) * 1 - - do j = 0, regjext-1 - j0 = (srcjoff + j) / dstjfac - fj = mod(srcjoff + j, dstjfac) - jfac(1) = (fj ) * (fj-dstjfac) * (fj-2*dstjfac) * (-1) - jfac(2) = (fj+dstjfac) * (fj-dstjfac) * (fj-2*dstjfac) * 3 - jfac(3) = (fj+dstjfac) * (fj ) * (fj-2*dstjfac) * (-3) - jfac(4) = (fj+dstjfac) * (fj ) * (fj- dstjfac) * 1 - - do i = 0, regiext-1 - i0 = (srcioff + i) / dstifac - fi = mod(srcioff + i, dstifac) - ifac(1) = (fi ) * (fi-dstifac) * (fi-2*dstifac) * (-1) - ifac(2) = (fi+dstifac) * (fi-dstifac) * (fi-2*dstifac) * 3 - ifac(3) = (fi+dstifac) * (fi ) * (fi-2*dstifac) * (-3) - ifac(4) = (fi+dstifac) * (fi ) * (fi- dstifac) * 1 - - res = 0 - - do kk=1,4 - do jj=1,4 - do ii=1,4 - - fac = ifac(ii) * jfac(jj) * kfac(kk) - - if (fac.ne.0) then - if (check_array_accesses.ne.0) then - call checkindex (i0+ii-1, j0+jj-1, k0+kk-1, 1,1,1, srciext,srcjext,srckext, "source") - end if - res = res - $ + fac * s1fac * src1(i0+ii-1, j0+jj-1, k0+kk-1) - $ + fac * s2fac * src2(i0+ii-1, j0+jj-1, k0+kk-1) - end if - - end do - end do - end do - - if (check_array_accesses.ne.0) then - call checkindex (dstioff+i+1, dstjoff+j+1, dstkoff+k+1, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst (dstioff+i+1, dstjoff+j+1, dstkoff+k+1) = dstdiv * res - - end do - end do - end do - - end diff --git a/Carpet/CarpetLib/src/prolongate_3d_real8_2tl_o3_rf2.F77 b/Carpet/CarpetLib/src/prolongate_3d_real8_2tl_o3_rf2.F77 deleted file mode 100644 index 8bfdb4778..000000000 --- a/Carpet/CarpetLib/src/prolongate_3d_real8_2tl_o3_rf2.F77 +++ /dev/null @@ -1,627 +0,0 @@ -c -*-Fortran-*- - -#include "cctk.h" -#include "cctk_Parameters.h" - - - - subroutine prolongate_3d_real8_2tl_o3_rf2 ( - $ src1, t1, src2, t2, srciext, srcjext, srckext, - $ dst, t, dstiext, dstjext, dstkext, - $ srcbbox, dstbbox, regbbox) - - implicit none - - DECLARE_CCTK_PARAMETERS - - CCTK_REAL8 eps - parameter (eps = 1.0d-10) - - CCTK_REAL8 one, half, fourth, eighth, sixteenth - parameter (one = 1) - parameter (half = one/2) - parameter (fourth = one/4) - parameter (eighth = one/8) - parameter (sixteenth = one/16) - CCTK_REAL8 f1, f2, f3, f4 - parameter (f1 = - sixteenth) - parameter (f2 = 9*sixteenth) - parameter (f3 = 9*sixteenth) - parameter (f4 = - sixteenth) - - integer srciext, srcjext, srckext - CCTK_REAL8 src1(srciext,srcjext,srckext) - CCTK_REAL8 t1 - CCTK_REAL8 src2(srciext,srcjext,srckext) - CCTK_REAL8 t2 - integer dstiext, dstjext, dstkext - CCTK_REAL8 dst(dstiext,dstjext,dstkext) - CCTK_REAL8 t -c bbox(:,1) is lower boundary (inclusive) -c bbox(:,2) is upper boundary (inclusive) -c bbox(:,3) is stride - integer srcbbox(3,3), dstbbox(3,3), regbbox(3,3) - - integer regiext, regjext, regkext - - integer srcioff, srcjoff, srckoff - integer dstioff, dstjoff, dstkoff - - integer offsetlo, offsethi - - CCTK_REAL8 s1fac, s2fac - - integer i0, j0, k0 - integer fi, fj, fk - integer is, js, ks - integer id, jd, kd - integer i, j, k - - CCTK_REAL8 res1, res2 - - integer d - - - - do d=1,3 - if (srcbbox(d,3).eq.0 .or. dstbbox(d,3).eq.0 - $ .or. regbbox(d,3).eq.0) then - call CCTK_WARN (0, "Internal error: stride is zero") - end if - if (srcbbox(d,3).le.regbbox(d,3) - $ .or. dstbbox(d,3).ne.regbbox(d,3)) then - call CCTK_WARN (0, "Internal error: strides disagree") - end if - if (srcbbox(d,3).ne.dstbbox(d,3)*2) then - call CCTK_WARN (0, "Internal error: source strides are not twice the destination strides") - end if - if (mod(srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array origins are not integer multiples of the strides") - end if - if (regbbox(d,1).gt.regbbox(d,2)) then -c This could be handled, but is likely to point to an error elsewhere - call CCTK_WARN (0, "Internal error: region extent is empty") - end if - if (mod(srcbbox(d,2) - srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,2) - dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,2) - regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array extents are not integer multiples of the strides") - end if - regkext = (regbbox(d,2) - regbbox(d,1)) / regbbox(d,3) + 1 - srckoff = (regbbox(d,1) - srcbbox(d,1)) / dstbbox(d,3) - offsetlo = regbbox(d,3) - if (mod(srckoff, 2).eq.0) then - offsetlo = 0 - if (regkext.gt.1) then - offsetlo = regbbox(d,3) - end if - end if - offsethi = regbbox(d,3) - if (mod(srckoff + regkext-1, 2).eq.0) then - offsethi = 0 - if (regkext.gt.1) then - offsethi = regbbox(d,3) - end if - end if - if (regbbox(d,1)-offsetlo.lt.srcbbox(d,1) - $ .or. regbbox(d,2)+offsethi.gt.srcbbox(d,2) - $ .or. regbbox(d,1).lt.dstbbox(d,1) - $ .or. regbbox(d,2).gt.dstbbox(d,2)) then - call CCTK_WARN (0, "Internal error: region extent is not contained in array extent") - end if - end do - - if (srciext.ne.(srcbbox(1,2)-srcbbox(1,1))/srcbbox(1,3)+1 - $ .or. srcjext.ne.(srcbbox(2,2)-srcbbox(2,1))/srcbbox(2,3)+1 - $ .or. srckext.ne.(srcbbox(3,2)-srcbbox(3,1))/srcbbox(3,3)+1 - $ .or. dstiext.ne.(dstbbox(1,2)-dstbbox(1,1))/dstbbox(1,3)+1 - $ .or. dstjext.ne.(dstbbox(2,2)-dstbbox(2,1))/dstbbox(2,3)+1 - $ .or. dstkext.ne.(dstbbox(3,2)-dstbbox(3,1))/dstbbox(3,3)+1) then - call CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes") - end if - - - - regiext = (regbbox(1,2) - regbbox(1,1)) / regbbox(1,3) + 1 - regjext = (regbbox(2,2) - regbbox(2,1)) / regbbox(2,3) + 1 - regkext = (regbbox(3,2) - regbbox(3,1)) / regbbox(3,3) + 1 - - srcioff = (regbbox(1,1) - srcbbox(1,1)) / dstbbox(1,3) - srcjoff = (regbbox(2,1) - srcbbox(2,1)) / dstbbox(2,3) - srckoff = (regbbox(3,1) - srcbbox(3,1)) / dstbbox(3,3) - - dstioff = (regbbox(1,1) - dstbbox(1,1)) / dstbbox(1,3) - dstjoff = (regbbox(2,1) - dstbbox(2,1)) / dstbbox(2,3) - dstkoff = (regbbox(3,1) - dstbbox(3,1)) / dstbbox(3,3) - - - -c Quadratic (second order) time interpolation - if (t1.eq.t2) then - call CCTK_WARN (0, "Internal error: arrays have same time") - end if - if (t.lt.min(t1,t2)-eps .or. t.gt.max(t1,t2)+eps) then - call CCTK_WARN (0, "Internal error: extrapolation in time in time") - end if - - s1fac = (t - t2) / (t1 - t2) - s2fac = (t - t1) / (t2 - t1) - - - - fi = mod(srcioff, 2) - fj = mod(srcjoff, 2) - fk = mod(srckoff, 2) - - i0 = srcioff / 2 - j0 = srcjoff / 2 - k0 = srckoff / 2 - - - -c Loop over fine region -c Label scheme: 8 fk fj fi - -c begin k loop - 8 continue - k = 0 - ks = k0+1 - kd = dstkoff+1 - if (fk.eq.0) goto 80 - if (fk.eq.1) goto 81 - stop - -c begin j loop - 80 continue - j = 0 - js = j0+1 - jd = dstjoff+1 - if (fj.eq.0) goto 800 - if (fj.eq.1) goto 801 - stop - -c begin i loop - 800 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8000 - if (fi.eq.1) goto 8001 - stop - -c kernel - 8000 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js,ks, 1,1,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + s1fac * src1(is,js,ks) - $ + s2fac * src2(is,js,ks) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8001 - goto 900 - -c kernel - 8001 continue - if (check_array_accesses.ne.0) then - call checkindex (is-1,js,ks, 4,1,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + f1 * s1fac * src1(is-1,js,ks) + f2 * s1fac * src1(is ,js,ks) - $ + f3 * s1fac * src1(is+1,js,ks) + f4 * s1fac * src1(is+2,js,ks) - $ + f1 * s2fac * src2(is-1,js,ks) + f2 * s2fac * src2(is ,js,ks) - $ + f3 * s2fac * src2(is+1,js,ks) + f4 * s2fac * src2(is+2,js,ks) - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8000 - goto 900 - -c end i loop - 900 continue - j = j+1 - jd = jd+1 - if (j.lt.regjext) goto 801 - goto 90 - -c begin i loop - 801 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8010 - if (fi.eq.1) goto 8011 - stop - -c kernel - 8010 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js-1,ks, 1,4,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + f1 * s1fac * src1(is,js-1,ks) + f2 * s1fac * src1(is,js ,ks) - $ + f3 * s1fac * src1(is,js+1,ks) + f4 * s1fac * src1(is,js+2,ks) - $ + f1 * s2fac * src2(is,js-1,ks) + f2 * s2fac * src2(is,js ,ks) - $ + f3 * s2fac * src2(is,js+1,ks) + f4 * s2fac * src2(is,js+2,ks) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8011 - goto 901 - -c kernel - 8011 continue - if (check_array_accesses.ne.0) then - call checkindex (is-1,js-1,ks, 4,4,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + f1*f1 * s1fac * src1(is-1,js-1,ks) - $ + f2*f1 * s1fac * src1(is ,js-1,ks) - $ + f3*f1 * s1fac * src1(is+1,js-1,ks) - $ + f4*f1 * s1fac * src1(is+2,js-1,ks) - $ + f1*f2 * s1fac * src1(is-1,js ,ks) - $ + f2*f2 * s1fac * src1(is ,js ,ks) - $ + f3*f2 * s1fac * src1(is+1,js ,ks) - $ + f4*f2 * s1fac * src1(is+2,js ,ks) - $ + f1*f3 * s1fac * src1(is-1,js+1,ks) - $ + f2*f3 * s1fac * src1(is ,js+1,ks) - $ + f3*f3 * s1fac * src1(is+1,js+1,ks) - $ + f4*f3 * s1fac * src1(is+2,js+1,ks) - $ + f1*f4 * s1fac * src1(is-1,js+2,ks) - $ + f2*f4 * s1fac * src1(is ,js+2,ks) - $ + f3*f4 * s1fac * src1(is+1,js+2,ks) - $ + f4*f4 * s1fac * src1(is+2,js+2,ks) - $ - $ + f1*f1 * s2fac * src2(is-1,js-1,ks) - $ + f2*f1 * s2fac * src2(is ,js-1,ks) - $ + f3*f1 * s2fac * src2(is+1,js-1,ks) - $ + f4*f1 * s2fac * src2(is+2,js-1,ks) - $ + f1*f2 * s2fac * src2(is-1,js ,ks) - $ + f2*f2 * s2fac * src2(is ,js ,ks) - $ + f3*f2 * s2fac * src2(is+1,js ,ks) - $ + f4*f2 * s2fac * src2(is+2,js ,ks) - $ + f1*f3 * s2fac * src2(is-1,js+1,ks) - $ + f2*f3 * s2fac * src2(is ,js+1,ks) - $ + f3*f3 * s2fac * src2(is+1,js+1,ks) - $ + f4*f3 * s2fac * src2(is+2,js+1,ks) - $ + f1*f4 * s2fac * src2(is-1,js+2,ks) - $ + f2*f4 * s2fac * src2(is ,js+2,ks) - $ + f3*f4 * s2fac * src2(is+1,js+2,ks) - $ + f4*f4 * s2fac * src2(is+2,js+2,ks) - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8010 - goto 901 - -c end i loop - 901 continue - j = j+1 - jd = jd+1 - js = js+1 - if (j.lt.regjext) goto 800 - goto 90 - -c end j loop - 90 continue - k = k+1 - kd = kd+1 - if (k.lt.regkext) goto 81 - goto 9 - -c begin j loop - 81 continue - j = 0 - js = j0+1 - jd = dstjoff+1 - if (fj.eq.0) goto 810 - if (fj.eq.1) goto 811 - stop - -c begin i loop - 810 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8100 - if (fi.eq.1) goto 8101 - stop - -c kernel - 8100 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js,ks-1, 1,1,4, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + f1 * s1fac * src1(is,js,ks-1) + f2 * s1fac * src1(is,js,ks ) - $ + f3 * s1fac * src1(is,js,ks+1) + f4 * s1fac * src1(is,js,ks+2) - $ + f1 * s2fac * src2(is,js,ks-1) + f2 * s2fac * src2(is,js,ks ) - $ + f3 * s2fac * src2(is,js,ks+1) + f4 * s2fac * src2(is,js,ks+2) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8101 - goto 910 - -c kernel - 8101 continue - if (check_array_accesses.ne.0) then - call checkindex (is-1,js,ks-1, 4,1,4, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + f1*f1 * s1fac * src1(is-1,js,ks-1) - $ + f2*f1 * s1fac * src1(is ,js,ks-1) - $ + f3*f1 * s1fac * src1(is+1,js,ks-1) - $ + f4*f1 * s1fac * src1(is+2,js,ks-1) - $ + f1*f2 * s1fac * src1(is-1,js,ks ) - $ + f2*f2 * s1fac * src1(is ,js,ks ) - $ + f3*f2 * s1fac * src1(is+1,js,ks ) - $ + f4*f2 * s1fac * src1(is+2,js,ks ) - $ + f1*f3 * s1fac * src1(is-1,js,ks+1) - $ + f2*f3 * s1fac * src1(is ,js,ks+1) - $ + f3*f3 * s1fac * src1(is+1,js,ks+1) - $ + f4*f3 * s1fac * src1(is+2,js,ks+1) - $ + f1*f4 * s1fac * src1(is-1,js,ks+2) - $ + f2*f4 * s1fac * src1(is ,js,ks+2) - $ + f3*f4 * s1fac * src1(is+1,js,ks+2) - $ + f4*f4 * s1fac * src1(is+2,js,ks+2) - $ - $ + f1*f1 * s2fac * src2(is-1,js,ks-1) - $ + f2*f1 * s2fac * src2(is ,js,ks-1) - $ + f3*f1 * s2fac * src2(is+1,js,ks-1) - $ + f4*f1 * s2fac * src2(is+2,js,ks-1) - $ + f1*f2 * s2fac * src2(is-1,js,ks ) - $ + f2*f2 * s2fac * src2(is ,js,ks ) - $ + f3*f2 * s2fac * src2(is+1,js,ks ) - $ + f4*f2 * s2fac * src2(is+2,js,ks ) - $ + f1*f3 * s2fac * src2(is-1,js,ks+1) - $ + f2*f3 * s2fac * src2(is ,js,ks+1) - $ + f3*f3 * s2fac * src2(is+1,js,ks+1) - $ + f4*f3 * s2fac * src2(is+2,js,ks+1) - $ + f1*f4 * s2fac * src2(is-1,js,ks+2) - $ + f2*f4 * s2fac * src2(is ,js,ks+2) - $ + f3*f4 * s2fac * src2(is+1,js,ks+2) - $ + f4*f4 * s2fac * src2(is+2,js,ks+2) - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8100 - goto 910 - -c end i loop - 910 continue - j = j+1 - jd = jd+1 - if (j.lt.regjext) goto 811 - goto 91 - -c begin i loop - 811 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8110 - if (fi.eq.1) goto 8111 - stop - -c kernel - 8110 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js-1,ks-1, 1,4,4, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + f1*f1 * s1fac * src1(is,js-1,ks-1) - $ + f2*f1 * s1fac * src1(is,js ,ks-1) - $ + f3*f1 * s1fac * src1(is,js+1,ks-1) - $ + f4*f1 * s1fac * src1(is,js+2,ks-1) - $ + f1*f2 * s1fac * src1(is,js-1,ks ) - $ + f2*f2 * s1fac * src1(is,js ,ks ) - $ + f3*f2 * s1fac * src1(is,js+1,ks ) - $ + f4*f2 * s1fac * src1(is,js+2,ks ) - $ + f1*f3 * s1fac * src1(is,js-1,ks+1) - $ + f2*f3 * s1fac * src1(is,js ,ks+1) - $ + f3*f3 * s1fac * src1(is,js+1,ks+1) - $ + f4*f3 * s1fac * src1(is,js+2,ks+1) - $ + f1*f4 * s1fac * src1(is,js-1,ks+2) - $ + f2*f4 * s1fac * src1(is,js ,ks+2) - $ + f3*f4 * s1fac * src1(is,js+1,ks+2) - $ + f4*f4 * s1fac * src1(is,js+2,ks+2) - $ - $ + f1*f1 * s2fac * src2(is,js-1,ks-1) - $ + f2*f1 * s2fac * src2(is,js ,ks-1) - $ + f3*f1 * s2fac * src2(is,js+1,ks-1) - $ + f4*f1 * s2fac * src2(is,js+2,ks-1) - $ + f1*f2 * s2fac * src2(is,js-1,ks ) - $ + f2*f2 * s2fac * src2(is,js ,ks ) - $ + f3*f2 * s2fac * src2(is,js+1,ks ) - $ + f4*f2 * s2fac * src2(is,js+2,ks ) - $ + f1*f3 * s2fac * src2(is,js-1,ks+1) - $ + f2*f3 * s2fac * src2(is,js ,ks+1) - $ + f3*f3 * s2fac * src2(is,js+1,ks+1) - $ + f4*f3 * s2fac * src2(is,js+2,ks+1) - $ + f1*f4 * s2fac * src2(is,js-1,ks+2) - $ + f2*f4 * s2fac * src2(is,js ,ks+2) - $ + f3*f4 * s2fac * src2(is,js+1,ks+2) - $ + f4*f4 * s2fac * src2(is,js+2,ks+2) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8111 - goto 911 - -c kernel - 8111 continue - if (check_array_accesses.ne.0) then - call checkindex (is-1,js-1,ks-1, 4,4,4, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - res1 = - $ + f1*f1*f1 * s1fac * src1(is-1,js-1,ks-1) - $ + f2*f1*f1 * s1fac * src1(is ,js-1,ks-1) - $ + f3*f1*f1 * s1fac * src1(is+1,js-1,ks-1) - $ + f4*f1*f1 * s1fac * src1(is+2,js-1,ks-1) - $ + f1*f2*f1 * s1fac * src1(is-1,js ,ks-1) - $ + f2*f2*f1 * s1fac * src1(is ,js ,ks-1) - $ + f3*f2*f1 * s1fac * src1(is+1,js ,ks-1) - $ + f4*f2*f1 * s1fac * src1(is+2,js ,ks-1) - $ + f1*f3*f1 * s1fac * src1(is-1,js+1,ks-1) - $ + f2*f3*f1 * s1fac * src1(is ,js+1,ks-1) - $ + f3*f3*f1 * s1fac * src1(is+1,js+1,ks-1) - $ + f4*f3*f1 * s1fac * src1(is+2,js+1,ks-1) - $ + f1*f4*f1 * s1fac * src1(is-1,js+2,ks-1) - $ + f2*f4*f1 * s1fac * src1(is ,js+2,ks-1) - $ + f3*f4*f1 * s1fac * src1(is+1,js+2,ks-1) - $ + f4*f4*f1 * s1fac * src1(is+2,js+2,ks-1) - $ - $ + f1*f1*f2 * s1fac * src1(is-1,js-1,ks ) - $ + f2*f1*f2 * s1fac * src1(is ,js-1,ks ) - $ + f3*f1*f2 * s1fac * src1(is+1,js-1,ks ) - $ + f4*f1*f2 * s1fac * src1(is+2,js-1,ks ) - $ + f1*f2*f2 * s1fac * src1(is-1,js ,ks ) - $ + f2*f2*f2 * s1fac * src1(is ,js ,ks ) - $ + f3*f2*f2 * s1fac * src1(is+1,js ,ks ) - $ + f4*f2*f2 * s1fac * src1(is+2,js ,ks ) - $ + f1*f3*f2 * s1fac * src1(is-1,js+1,ks ) - $ + f2*f3*f2 * s1fac * src1(is ,js+1,ks ) - $ + f3*f3*f2 * s1fac * src1(is+1,js+1,ks ) - $ + f4*f3*f2 * s1fac * src1(is+2,js+1,ks ) - $ + f1*f4*f2 * s1fac * src1(is-1,js+2,ks ) - $ + f2*f4*f2 * s1fac * src1(is ,js+2,ks ) - $ + f3*f4*f2 * s1fac * src1(is+1,js+2,ks ) - $ + f4*f4*f2 * s1fac * src1(is+2,js+2,ks ) - $ - $ + f1*f1*f3 * s1fac * src1(is-1,js-1,ks+1) - $ + f2*f1*f3 * s1fac * src1(is ,js-1,ks+1) - $ + f3*f1*f3 * s1fac * src1(is+1,js-1,ks+1) - $ + f4*f1*f3 * s1fac * src1(is+2,js-1,ks+1) - $ + f1*f2*f3 * s1fac * src1(is-1,js ,ks+1) - $ + f2*f2*f3 * s1fac * src1(is ,js ,ks+1) - $ + f3*f2*f3 * s1fac * src1(is+1,js ,ks+1) - $ + f4*f2*f3 * s1fac * src1(is+2,js ,ks+1) - $ + f1*f3*f3 * s1fac * src1(is-1,js+1,ks+1) - $ + f2*f3*f3 * s1fac * src1(is ,js+1,ks+1) - $ + f3*f3*f3 * s1fac * src1(is+1,js+1,ks+1) - $ + f4*f3*f3 * s1fac * src1(is+2,js+1,ks+1) - $ + f1*f4*f3 * s1fac * src1(is-1,js+2,ks+1) - $ + f2*f4*f3 * s1fac * src1(is ,js+2,ks+1) - $ + f3*f4*f3 * s1fac * src1(is+1,js+2,ks+1) - $ + f4*f4*f3 * s1fac * src1(is+2,js+2,ks+1) - $ - $ + f1*f1*f4 * s1fac * src1(is-1,js-1,ks+2) - $ + f2*f1*f4 * s1fac * src1(is ,js-1,ks+2) - $ + f3*f1*f4 * s1fac * src1(is+1,js-1,ks+2) - $ + f4*f1*f4 * s1fac * src1(is+2,js-1,ks+2) - $ + f1*f2*f4 * s1fac * src1(is-1,js ,ks+2) - $ + f2*f2*f4 * s1fac * src1(is ,js ,ks+2) - $ + f3*f2*f4 * s1fac * src1(is+1,js ,ks+2) - $ + f4*f2*f4 * s1fac * src1(is+2,js ,ks+2) - $ + f1*f3*f4 * s1fac * src1(is-1,js+1,ks+2) - $ + f2*f3*f4 * s1fac * src1(is ,js+1,ks+2) - $ + f3*f3*f4 * s1fac * src1(is+1,js+1,ks+2) - $ + f4*f3*f4 * s1fac * src1(is+2,js+1,ks+2) - $ + f1*f4*f4 * s1fac * src1(is-1,js+2,ks+2) - $ + f2*f4*f4 * s1fac * src1(is ,js+2,ks+2) - $ + f3*f4*f4 * s1fac * src1(is+1,js+2,ks+2) - $ + f4*f4*f4 * s1fac * src1(is+2,js+2,ks+2) - res2 = - $ + f1*f1*f1 * s2fac * src2(is-1,js-1,ks-1) - $ + f2*f1*f1 * s2fac * src2(is ,js-1,ks-1) - $ + f3*f1*f1 * s2fac * src2(is+1,js-1,ks-1) - $ + f4*f1*f1 * s2fac * src2(is+2,js-1,ks-1) - $ + f1*f2*f1 * s2fac * src2(is-1,js ,ks-1) - $ + f2*f2*f1 * s2fac * src2(is ,js ,ks-1) - $ + f3*f2*f1 * s2fac * src2(is+1,js ,ks-1) - $ + f4*f2*f1 * s2fac * src2(is+2,js ,ks-1) - $ + f1*f3*f1 * s2fac * src2(is-1,js+1,ks-1) - $ + f2*f3*f1 * s2fac * src2(is ,js+1,ks-1) - $ + f3*f3*f1 * s2fac * src2(is+1,js+1,ks-1) - $ + f4*f3*f1 * s2fac * src2(is+2,js+1,ks-1) - $ + f1*f4*f1 * s2fac * src2(is-1,js+2,ks-1) - $ + f2*f4*f1 * s2fac * src2(is ,js+2,ks-1) - $ + f3*f4*f1 * s2fac * src2(is+1,js+2,ks-1) - $ + f4*f4*f1 * s2fac * src2(is+2,js+2,ks-1) - $ - $ + f1*f1*f2 * s2fac * src2(is-1,js-1,ks ) - $ + f2*f1*f2 * s2fac * src2(is ,js-1,ks ) - $ + f3*f1*f2 * s2fac * src2(is+1,js-1,ks ) - $ + f4*f1*f2 * s2fac * src2(is+2,js-1,ks ) - $ + f1*f2*f2 * s2fac * src2(is-1,js ,ks ) - $ + f2*f2*f2 * s2fac * src2(is ,js ,ks ) - $ + f3*f2*f2 * s2fac * src2(is+1,js ,ks ) - $ + f4*f2*f2 * s2fac * src2(is+2,js ,ks ) - $ + f1*f3*f2 * s2fac * src2(is-1,js+1,ks ) - $ + f2*f3*f2 * s2fac * src2(is ,js+1,ks ) - $ + f3*f3*f2 * s2fac * src2(is+1,js+1,ks ) - $ + f4*f3*f2 * s2fac * src2(is+2,js+1,ks ) - $ + f1*f4*f2 * s2fac * src2(is-1,js+2,ks ) - $ + f2*f4*f2 * s2fac * src2(is ,js+2,ks ) - $ + f3*f4*f2 * s2fac * src2(is+1,js+2,ks ) - $ + f4*f4*f2 * s2fac * src2(is+2,js+2,ks ) - $ - $ + f1*f1*f3 * s2fac * src2(is-1,js-1,ks+1) - $ + f2*f1*f3 * s2fac * src2(is ,js-1,ks+1) - $ + f3*f1*f3 * s2fac * src2(is+1,js-1,ks+1) - $ + f4*f1*f3 * s2fac * src2(is+2,js-1,ks+1) - $ + f1*f2*f3 * s2fac * src2(is-1,js ,ks+1) - $ + f2*f2*f3 * s2fac * src2(is ,js ,ks+1) - $ + f3*f2*f3 * s2fac * src2(is+1,js ,ks+1) - $ + f4*f2*f3 * s2fac * src2(is+2,js ,ks+1) - $ + f1*f3*f3 * s2fac * src2(is-1,js+1,ks+1) - $ + f2*f3*f3 * s2fac * src2(is ,js+1,ks+1) - $ + f3*f3*f3 * s2fac * src2(is+1,js+1,ks+1) - $ + f4*f3*f3 * s2fac * src2(is+2,js+1,ks+1) - $ + f1*f4*f3 * s2fac * src2(is-1,js+2,ks+1) - $ + f2*f4*f3 * s2fac * src2(is ,js+2,ks+1) - $ + f3*f4*f3 * s2fac * src2(is+1,js+2,ks+1) - $ + f4*f4*f3 * s2fac * src2(is+2,js+2,ks+1) - $ - $ + f1*f1*f4 * s2fac * src2(is-1,js-1,ks+2) - $ + f2*f1*f4 * s2fac * src2(is ,js-1,ks+2) - $ + f3*f1*f4 * s2fac * src2(is+1,js-1,ks+2) - $ + f4*f1*f4 * s2fac * src2(is+2,js-1,ks+2) - $ + f1*f2*f4 * s2fac * src2(is-1,js ,ks+2) - $ + f2*f2*f4 * s2fac * src2(is ,js ,ks+2) - $ + f3*f2*f4 * s2fac * src2(is+1,js ,ks+2) - $ + f4*f2*f4 * s2fac * src2(is+2,js ,ks+2) - $ + f1*f3*f4 * s2fac * src2(is-1,js+1,ks+2) - $ + f2*f3*f4 * s2fac * src2(is ,js+1,ks+2) - $ + f3*f3*f4 * s2fac * src2(is+1,js+1,ks+2) - $ + f4*f3*f4 * s2fac * src2(is+2,js+1,ks+2) - $ + f1*f4*f4 * s2fac * src2(is-1,js+2,ks+2) - $ + f2*f4*f4 * s2fac * src2(is ,js+2,ks+2) - $ + f3*f4*f4 * s2fac * src2(is+1,js+2,ks+2) - $ + f4*f4*f4 * s2fac * src2(is+2,js+2,ks+2) - dst(id,jd,kd) = res1 + res2 - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8110 - goto 911 - -c end i loop - 911 continue - j = j+1 - jd = jd+1 - js = js+1 - if (j.lt.regjext) goto 810 - goto 91 - -c end j loop - 91 continue - k = k+1 - kd = kd+1 - ks = ks+1 - if (k.lt.regkext) goto 80 - goto 9 - -c end k loop - 9 continue - - end diff --git a/Carpet/CarpetLib/src/prolongate_3d_real8_2tl_o5.F77 b/Carpet/CarpetLib/src/prolongate_3d_real8_2tl_o5.F77 deleted file mode 100644 index ae8f488ae..000000000 --- a/Carpet/CarpetLib/src/prolongate_3d_real8_2tl_o5.F77 +++ /dev/null @@ -1,217 +0,0 @@ -c -*-Fortran-*- - -#include "cctk.h" -#include "cctk_Parameters.h" - - - - subroutine prolongate_3d_real8_2tl_o5 ( - $ src1, t1, src2, t2, srciext, srcjext, srckext, - $ dst, t, dstiext, dstjext, dstkext, - $ srcbbox, dstbbox, regbbox) - - implicit none - - DECLARE_CCTK_PARAMETERS - - CCTK_REAL8 one - parameter (one = 1) - - CCTK_REAL8 eps - parameter (eps = 1.0d-10) - - integer srciext, srcjext, srckext - CCTK_REAL8 src1(srciext,srcjext,srckext) - CCTK_REAL8 t1 - CCTK_REAL8 src2(srciext,srcjext,srckext) - CCTK_REAL8 t2 - integer dstiext, dstjext, dstkext - CCTK_REAL8 dst(dstiext,dstjext,dstkext) - CCTK_REAL8 t -c bbox(:,1) is lower boundary (inclusive) -c bbox(:,2) is upper boundary (inclusive) -c bbox(:,3) is stride - integer srcbbox(3,3), dstbbox(3,3), regbbox(3,3) - - integer offsetlo, offsethi - - integer regiext, regjext, regkext - - integer dstifac, dstjfac, dstkfac - - integer srcioff, srcjoff, srckoff - integer dstioff, dstjoff, dstkoff - - CCTK_REAL8 s1fac, s2fac - - CCTK_REAL8 dstdiv - integer i, j, k - integer i0, j0, k0 - integer fi, fj, fk - integer ifac(6), jfac(6), kfac(6) - integer ii, jj, kk - CCTK_REAL8 fac - CCTK_REAL8 res - integer d - - - - do d=1,3 - if (srcbbox(d,3).eq.0 .or. dstbbox(d,3).eq.0 - $ .or. regbbox(d,3).eq.0) then - call CCTK_WARN (0, "Internal error: stride is zero") - end if - if (srcbbox(d,3).le.regbbox(d,3) - $ .or. dstbbox(d,3).ne.regbbox(d,3)) then - call CCTK_WARN (0, "Internal error: strides disagree") - end if - if (mod(srcbbox(d,3), dstbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: destination strides are not integer multiples of the source strides") - end if - if (mod(srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array origins are not integer multiples of the strides") - end if - if (regbbox(d,1).gt.regbbox(d,2)) then -c This could be handled, but is likely to point to an error elsewhere - call CCTK_WARN (0, "Internal error: region extent is empty") - end if - if (mod(srcbbox(d,2) - srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,2) - dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,2) - regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array extents are not integer multiples of the strides") - end if - regkext = (regbbox(d,2) - regbbox(d,1)) / regbbox(d,3) + 1 - dstkfac = srcbbox(d,3) / dstbbox(d,3) - srckoff = (regbbox(d,1) - srcbbox(d,1)) / dstbbox(d,3) - offsetlo = regbbox(d,3) - if (mod(srckoff + 0, dstkfac).eq.0) then - offsetlo = 0 - if (regkext.gt.1) then - offsetlo = regbbox(d,3) - end if - end if - offsethi = regbbox(d,3) - if (mod(srckoff + regkext-1, dstkfac).eq.0) then - offsethi = 0 - if (regkext.gt.1) then - offsethi = regbbox(d,3) - end if - end if - if (regbbox(d,1)-offsetlo.lt.srcbbox(d,1) - $ .or. regbbox(d,2)+offsethi.gt.srcbbox(d,2) - $ .or. regbbox(d,1).lt.dstbbox(d,1) - $ .or. regbbox(d,2).gt.dstbbox(d,2)) then - call CCTK_WARN (0, "Internal error: region extent is not contained in array extent") - end if - end do - - if (srciext.ne.(srcbbox(1,2)-srcbbox(1,1))/srcbbox(1,3)+1 - $ .or. srcjext.ne.(srcbbox(2,2)-srcbbox(2,1))/srcbbox(2,3)+1 - $ .or. srckext.ne.(srcbbox(3,2)-srcbbox(3,1))/srcbbox(3,3)+1 - $ .or. dstiext.ne.(dstbbox(1,2)-dstbbox(1,1))/dstbbox(1,3)+1 - $ .or. dstjext.ne.(dstbbox(2,2)-dstbbox(2,1))/dstbbox(2,3)+1 - $ .or. dstkext.ne.(dstbbox(3,2)-dstbbox(3,1))/dstbbox(3,3)+1) then - call CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes") - end if - - - - regiext = (regbbox(1,2) - regbbox(1,1)) / regbbox(1,3) + 1 - regjext = (regbbox(2,2) - regbbox(2,1)) / regbbox(2,3) + 1 - regkext = (regbbox(3,2) - regbbox(3,1)) / regbbox(3,3) + 1 - - dstifac = srcbbox(1,3) / dstbbox(1,3) - dstjfac = srcbbox(2,3) / dstbbox(2,3) - dstkfac = srcbbox(3,3) / dstbbox(3,3) - - srcioff = (regbbox(1,1) - srcbbox(1,1)) / dstbbox(1,3) - srcjoff = (regbbox(2,1) - srcbbox(2,1)) / dstbbox(2,3) - srckoff = (regbbox(3,1) - srcbbox(3,1)) / dstbbox(3,3) - - dstioff = (regbbox(1,1) - dstbbox(1,1)) / dstbbox(1,3) - dstjoff = (regbbox(2,1) - dstbbox(2,1)) / dstbbox(2,3) - dstkoff = (regbbox(3,1) - dstbbox(3,1)) / dstbbox(3,3) - - - -c Linear (first order) interpolation - if (t1.eq.t2) then - call CCTK_WARN (0, "Internal error: arrays have same time") - end if - if (t.lt.min(t1,t2)-eps .or. t.gt.max(t1,t2)+eps) then - call CCTK_WARN (0, "Internal error: extrapolation in time") - end if - - s1fac = (t - t2) / (t1 - t2) - s2fac = (t - t1) / (t2 - t1) - - - -c Loop over fine region -c (This expression cannot be evaluated as integer) - dstdiv = one / (120*dstifac**5) / (120*dstjfac**5) / (120*dstkfac**5) - - do k = 0, regkext-1 - k0 = (srckoff + k) / dstkfac - fk = mod(srckoff + k, dstkfac) - kfac(1) = (fk+ dstkfac) * (fk ) * (fk-dstkfac) * (fk-2*dstkfac) * (fk-3*dstkfac) * (- 1) - kfac(2) = (fk+2*dstkfac) * (fk ) * (fk-dstkfac) * (fk-2*dstkfac) * (fk-3*dstkfac) * ( 5) - kfac(3) = (fk+2*dstkfac) * (fk+dstkfac) * (fk-dstkfac) * (fk-2*dstkfac) * (fk-3*dstkfac) * (-10) - kfac(4) = (fk+2*dstkfac) * (fk+dstkfac) * (fk ) * (fk-2*dstkfac) * (fk-3*dstkfac) * ( 10) - kfac(5) = (fk+2*dstkfac) * (fk+dstkfac) * (fk ) * (fk- dstkfac) * (fk-3*dstkfac) * (- 5) - kfac(6) = (fk+2*dstkfac) * (fk+dstkfac) * (fk ) * (fk- dstkfac) * (fk-2*dstkfac) * ( 1) - - do j = 0, regjext-1 - j0 = (srcjoff + j) / dstjfac - fj = mod(srcjoff + j, dstjfac) - jfac(1) = (fj+ dstjfac) * (fj ) * (fj-dstjfac) * (fj-2*dstjfac) * (fj-3*dstjfac) * (- 1) - jfac(2) = (fj+2*dstjfac) * (fj ) * (fj-dstjfac) * (fj-2*dstjfac) * (fj-3*dstjfac) * ( 5) - jfac(3) = (fj+2*dstjfac) * (fj+dstjfac) * (fj-dstjfac) * (fj-2*dstjfac) * (fj-3*dstjfac) * (-10) - jfac(4) = (fj+2*dstjfac) * (fj+dstjfac) * (fj ) * (fj-2*dstjfac) * (fj-3*dstjfac) * ( 10) - jfac(5) = (fj+2*dstjfac) * (fj+dstjfac) * (fj ) * (fj- dstjfac) * (fj-3*dstjfac) * (- 5) - jfac(6) = (fj+2*dstjfac) * (fj+dstjfac) * (fj ) * (fj- dstjfac) * (fj-2*dstjfac) * ( 1) - - do i = 0, regiext-1 - i0 = (srcioff + i) / dstifac - fi = mod(srcioff + i, dstifac) - ifac(1) = (fi+ dstifac) * (fi ) * (fi-dstifac) * (fi-2*dstifac) * (fi-3*dstifac) * (- 1) - ifac(2) = (fi+2*dstifac) * (fi ) * (fi-dstifac) * (fi-2*dstifac) * (fi-3*dstifac) * ( 5) - ifac(3) = (fi+2*dstifac) * (fi+dstifac) * (fi-dstifac) * (fi-2*dstifac) * (fi-3*dstifac) * (-10) - ifac(4) = (fi+2*dstifac) * (fi+dstifac) * (fi ) * (fi-2*dstifac) * (fi-3*dstifac) * ( 10) - ifac(5) = (fi+2*dstifac) * (fi+dstifac) * (fi ) * (fi- dstifac) * (fi-3*dstifac) * (- 5) - ifac(6) = (fi+2*dstifac) * (fi+dstifac) * (fi ) * (fi- dstifac) * (fi-2*dstifac) * ( 1) - - res = 0 - - do kk=1,6 - do jj=1,6 - do ii=1,6 - - if (ifac(ii).ne.0 .and. jfac(jj).ne.0 .and. kfac(kk).ne.0) then -c (This expression cannot be evaluated as integer) - fac = one * ifac(ii) * jfac(jj) * kfac(kk) - - if (check_array_accesses.ne.0) then - call checkindex (i0+ii-2, j0+jj-2, k0+kk-2, 1,1,1, srciext,srcjext,srckext, "source") - end if - res = res - $ + fac * s1fac * src1(i0+ii-2, j0+jj-2, k0+kk-2) - $ + fac * s2fac * src2(i0+ii-2, j0+jj-2, k0+kk-2) - end if - - end do - end do - end do - - if (check_array_accesses.ne.0) then - call checkindex (dstioff+i+1, dstjoff+j+1, dstkoff+k+1, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst (dstioff+i+1, dstjoff+j+1, dstkoff+k+1) = dstdiv * res - - end do - end do - end do - - end diff --git a/Carpet/CarpetLib/src/prolongate_3d_real8_2tl_o5_rf2.F77 b/Carpet/CarpetLib/src/prolongate_3d_real8_2tl_o5_rf2.F77 deleted file mode 100644 index 6d251ca6b..000000000 --- a/Carpet/CarpetLib/src/prolongate_3d_real8_2tl_o5_rf2.F77 +++ /dev/null @@ -1,1084 +0,0 @@ -c -*-Fortran-*- - -#include "cctk.h" -#include "cctk_Parameters.h" - - - - subroutine prolongate_3d_real8_2tl_o5_rf2 ( - $ src1, t1, src2, t2, srciext, srcjext, srckext, - $ dst, t, dstiext, dstjext, dstkext, - $ srcbbox, dstbbox, regbbox) - - implicit none - - DECLARE_CCTK_PARAMETERS - - CCTK_REAL8 eps - parameter (eps = 1.0d-10) - - CCTK_REAL8 one - parameter (one = 1) - CCTK_REAL8 f1, f2, f3, f4, f5, f6 - parameter (f1 = 3*one/256) - parameter (f2 = - 25*one/256) - parameter (f3 = 150*one/256) - parameter (f4 = 150*one/256) - parameter (f5 = - 25*one/256) - parameter (f6 = 3*one/256) - - integer srciext, srcjext, srckext - CCTK_REAL8 src1(srciext,srcjext,srckext) - CCTK_REAL8 t1 - CCTK_REAL8 src2(srciext,srcjext,srckext) - CCTK_REAL8 t2 - integer dstiext, dstjext, dstkext - CCTK_REAL8 dst(dstiext,dstjext,dstkext) - CCTK_REAL8 t -c bbox(:,1) is lower boundary (inclusive) -c bbox(:,2) is upper boundary (inclusive) -c bbox(:,3) is stride - integer srcbbox(3,3), dstbbox(3,3), regbbox(3,3) - - integer regiext, regjext, regkext - - integer srcioff, srcjoff, srckoff - integer dstioff, dstjoff, dstkoff - - integer offsetlo, offsethi - - CCTK_REAL8 s1fac, s2fac - - integer i0, j0, k0 - integer fi, fj, fk - integer is, js, ks - integer id, jd, kd - integer i, j, k - - CCTK_REAL8 res1, res2 - CCTK_REAL8 res11, res12, res13, res14, res15, res16 - CCTK_REAL8 res21, res22, res23, res24, res25, res26 - - integer d - - - - do d=1,3 - if (srcbbox(d,3).eq.0 .or. dstbbox(d,3).eq.0 - $ .or. regbbox(d,3).eq.0) then - call CCTK_WARN (0, "Internal error: stride is zero") - end if - if (srcbbox(d,3).le.regbbox(d,3) - $ .or. dstbbox(d,3).ne.regbbox(d,3)) then - call CCTK_WARN (0, "Internal error: strides disagree") - end if - if (srcbbox(d,3).ne.dstbbox(d,3)*2) then - call CCTK_WARN (0, "Internal error: source strides are not twice the destination strides") - end if - if (mod(srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array origins are not integer multiples of the strides") - end if - if (regbbox(d,1).gt.regbbox(d,2)) then -c This could be handled, but is likely to point to an error elsewhere - call CCTK_WARN (0, "Internal error: region extent is empty") - end if - if (mod(srcbbox(d,2) - srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,2) - dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,2) - regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array extents are not integer multiples of the strides") - end if - regkext = (regbbox(d,2) - regbbox(d,1)) / regbbox(d,3) + 1 - srckoff = (regbbox(d,1) - srcbbox(d,1)) / dstbbox(d,3) - offsetlo = regbbox(d,3) - if (mod(srckoff, 2).eq.0) then - offsetlo = 0 - if (regkext.gt.1) then - offsetlo = regbbox(d,3) - end if - end if - offsethi = regbbox(d,3) - if (mod(srckoff + regkext-1, 2).eq.0) then - offsethi = 0 - if (regkext.gt.1) then - offsethi = regbbox(d,3) - end if - end if - if (regbbox(d,1)-offsetlo.lt.srcbbox(d,1) - $ .or. regbbox(d,2)+offsethi.gt.srcbbox(d,2) - $ .or. regbbox(d,1).lt.dstbbox(d,1) - $ .or. regbbox(d,2).gt.dstbbox(d,2)) then - call CCTK_WARN (0, "Internal error: region extent is not contained in array extent") - end if - end do - - if (srciext.ne.(srcbbox(1,2)-srcbbox(1,1))/srcbbox(1,3)+1 - $ .or. srcjext.ne.(srcbbox(2,2)-srcbbox(2,1))/srcbbox(2,3)+1 - $ .or. srckext.ne.(srcbbox(3,2)-srcbbox(3,1))/srcbbox(3,3)+1 - $ .or. dstiext.ne.(dstbbox(1,2)-dstbbox(1,1))/dstbbox(1,3)+1 - $ .or. dstjext.ne.(dstbbox(2,2)-dstbbox(2,1))/dstbbox(2,3)+1 - $ .or. dstkext.ne.(dstbbox(3,2)-dstbbox(3,1))/dstbbox(3,3)+1) then - call CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes") - end if - - - - regiext = (regbbox(1,2) - regbbox(1,1)) / regbbox(1,3) + 1 - regjext = (regbbox(2,2) - regbbox(2,1)) / regbbox(2,3) + 1 - regkext = (regbbox(3,2) - regbbox(3,1)) / regbbox(3,3) + 1 - - srcioff = (regbbox(1,1) - srcbbox(1,1)) / dstbbox(1,3) - srcjoff = (regbbox(2,1) - srcbbox(2,1)) / dstbbox(2,3) - srckoff = (regbbox(3,1) - srcbbox(3,1)) / dstbbox(3,3) - - dstioff = (regbbox(1,1) - dstbbox(1,1)) / dstbbox(1,3) - dstjoff = (regbbox(2,1) - dstbbox(2,1)) / dstbbox(2,3) - dstkoff = (regbbox(3,1) - dstbbox(3,1)) / dstbbox(3,3) - - - -c Quadratic (second order) time interpolation - if (t1.eq.t2) then - call CCTK_WARN (0, "Internal error: arrays have same time") - end if - if (t.lt.min(t1,t2)-eps .or. t.gt.max(t1,t2)+eps) then - call CCTK_WARN (0, "Internal error: extrapolation in time in time") - end if - - s1fac = (t - t2) / (t1 - t2) - s2fac = (t - t1) / (t2 - t1) - - - - fi = mod(srcioff, 2) - fj = mod(srcjoff, 2) - fk = mod(srckoff, 2) - - i0 = srcioff / 2 - j0 = srcjoff / 2 - k0 = srckoff / 2 - - - -c Loop over fine region -c Label scheme: 8 fk fj fi - -c begin k loop - 8 continue - k = 0 - ks = k0+1 - kd = dstkoff+1 - if (fk.eq.0) goto 80 - if (fk.eq.1) goto 81 - stop - -c begin j loop - 80 continue - j = 0 - js = j0+1 - jd = dstjoff+1 - if (fj.eq.0) goto 800 - if (fj.eq.1) goto 801 - stop - -c begin i loop - 800 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8000 - if (fi.eq.1) goto 8001 - stop - -c kernel - 8000 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js,ks, 1,1,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + s1fac * src1(is,js,ks) - $ + s2fac * src2(is,js,ks) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8001 - goto 900 - -c kernel - 8001 continue - if (check_array_accesses.ne.0) then - call checkindex (is-2,js,ks, 6,1,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + f1 * s1fac * src1(is-2,js,ks) - $ + f2 * s1fac * src1(is-1,js,ks) - $ + f3 * s1fac * src1(is ,js,ks) - $ + f4 * s1fac * src1(is+1,js,ks) - $ + f5 * s1fac * src1(is+2,js,ks) - $ + f6 * s1fac * src1(is+3,js,ks) - $ + f1 * s2fac * src2(is-2,js,ks) - $ + f2 * s2fac * src2(is-1,js,ks) - $ + f3 * s2fac * src2(is ,js,ks) - $ + f4 * s2fac * src2(is+1,js,ks) - $ + f5 * s2fac * src2(is+2,js,ks) - $ + f6 * s2fac * src2(is+3,js,ks) - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8000 - goto 900 - -c end i loop - 900 continue - j = j+1 - jd = jd+1 - if (j.lt.regjext) goto 801 - goto 90 - -c begin i loop - 801 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8010 - if (fi.eq.1) goto 8011 - stop - -c kernel - 8010 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js-2,ks, 1,6,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + f1 * s1fac * src1(is,js-2,ks) - $ + f2 * s1fac * src1(is,js-1,ks) - $ + f3 * s1fac * src1(is,js ,ks) - $ + f4 * s1fac * src1(is,js+1,ks) - $ + f5 * s1fac * src1(is,js+2,ks) - $ + f6 * s1fac * src1(is,js+3,ks) - $ + f1 * s2fac * src2(is,js-2,ks) - $ + f2 * s2fac * src2(is,js-1,ks) - $ + f3 * s2fac * src2(is,js ,ks) - $ + f4 * s2fac * src2(is,js+1,ks) - $ + f5 * s2fac * src2(is,js+2,ks) - $ + f6 * s2fac * src2(is,js+3,ks) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8011 - goto 901 - -c kernel - 8011 continue - if (check_array_accesses.ne.0) then - call checkindex (is-2,js-2,ks, 6,6,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - res1 = - $ + f1*f1 * src1(is-2,js-2,ks) - $ + f2*f1 * src1(is-1,js-2,ks) - $ + f3*f1 * src1(is ,js-2,ks) - $ + f4*f1 * src1(is+1,js-2,ks) - $ + f5*f1 * src1(is+2,js-2,ks) - $ + f6*f1 * src1(is+3,js-2,ks) - $ + f1*f2 * src1(is-2,js-1,ks) - $ + f2*f2 * src1(is-1,js-1,ks) - $ + f3*f2 * src1(is ,js-1,ks) - $ + f4*f2 * src1(is+1,js-1,ks) - $ + f5*f2 * src1(is+2,js-1,ks) - $ + f6*f2 * src1(is+3,js-1,ks) - $ + f1*f3 * src1(is-2,js ,ks) - $ + f2*f3 * src1(is-1,js ,ks) - $ + f3*f3 * src1(is ,js ,ks) - $ + f4*f3 * src1(is+1,js ,ks) - $ + f5*f3 * src1(is+2,js ,ks) - $ + f6*f3 * src1(is+3,js ,ks) - $ + f1*f4 * src1(is-2,js+1,ks) - $ + f2*f4 * src1(is-1,js+1,ks) - $ + f3*f4 * src1(is ,js+1,ks) - $ + f4*f4 * src1(is+1,js+1,ks) - $ + f5*f4 * src1(is+2,js+1,ks) - $ + f6*f4 * src1(is+3,js+1,ks) - $ + f1*f5 * src1(is-2,js+2,ks) - $ + f2*f5 * src1(is-1,js+2,ks) - $ + f3*f5 * src1(is ,js+2,ks) - $ + f4*f5 * src1(is+1,js+2,ks) - $ + f5*f5 * src1(is+2,js+2,ks) - $ + f6*f5 * src1(is+3,js+2,ks) - $ + f1*f6 * src1(is-2,js+3,ks) - $ + f2*f6 * src1(is-1,js+3,ks) - $ + f3*f6 * src1(is ,js+3,ks) - $ + f4*f6 * src1(is+1,js+3,ks) - $ + f5*f6 * src1(is+2,js+3,ks) - $ + f6*f6 * src1(is+3,js+3,ks) - res2 = - $ + f1*f1 * src2(is-2,js-2,ks) - $ + f2*f1 * src2(is-1,js-2,ks) - $ + f3*f1 * src2(is ,js-2,ks) - $ + f4*f1 * src2(is+1,js-2,ks) - $ + f5*f1 * src2(is+2,js-2,ks) - $ + f6*f1 * src2(is+3,js-2,ks) - $ + f1*f2 * src2(is-2,js-1,ks) - $ + f2*f2 * src2(is-1,js-1,ks) - $ + f3*f2 * src2(is ,js-1,ks) - $ + f4*f2 * src2(is+1,js-1,ks) - $ + f5*f2 * src2(is+2,js-1,ks) - $ + f6*f2 * src2(is+3,js-1,ks) - $ + f1*f3 * src2(is-2,js ,ks) - $ + f2*f3 * src2(is-1,js ,ks) - $ + f3*f3 * src2(is ,js ,ks) - $ + f4*f3 * src2(is+1,js ,ks) - $ + f5*f3 * src2(is+2,js ,ks) - $ + f6*f3 * src2(is+3,js ,ks) - $ + f1*f4 * src2(is-2,js+1,ks) - $ + f2*f4 * src2(is-1,js+1,ks) - $ + f3*f4 * src2(is ,js+1,ks) - $ + f4*f4 * src2(is+1,js+1,ks) - $ + f5*f4 * src2(is+2,js+1,ks) - $ + f6*f4 * src2(is+3,js+1,ks) - $ + f1*f5 * src2(is-2,js+2,ks) - $ + f2*f5 * src2(is-1,js+2,ks) - $ + f3*f5 * src2(is ,js+2,ks) - $ + f4*f5 * src2(is+1,js+2,ks) - $ + f5*f5 * src2(is+2,js+2,ks) - $ + f6*f5 * src2(is+3,js+2,ks) - $ + f1*f6 * src2(is-2,js+3,ks) - $ + f2*f6 * src2(is-1,js+3,ks) - $ + f3*f6 * src2(is ,js+3,ks) - $ + f4*f6 * src2(is+1,js+3,ks) - $ + f5*f6 * src2(is+2,js+3,ks) - $ + f6*f6 * src2(is+3,js+3,ks) - dst(id,jd,kd) = s1fac * res1 + s2fac * res2 - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8010 - goto 901 - -c end i loop - 901 continue - j = j+1 - jd = jd+1 - js = js+1 - if (j.lt.regjext) goto 800 - goto 90 - -c end j loop - 90 continue - k = k+1 - kd = kd+1 - if (k.lt.regkext) goto 81 - goto 9 - -c begin j loop - 81 continue - j = 0 - js = j0+1 - jd = dstjoff+1 - if (fj.eq.0) goto 810 - if (fj.eq.1) goto 811 - stop - -c begin i loop - 810 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8100 - if (fi.eq.1) goto 8101 - stop - -c kernel - 8100 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js,ks-2, 1,1,6, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + f1 * s1fac * src1(is,js,ks-2) - $ + f2 * s1fac * src1(is,js,ks-1) - $ + f3 * s1fac * src1(is,js,ks ) - $ + f4 * s1fac * src1(is,js,ks+1) - $ + f5 * s1fac * src1(is,js,ks+2) - $ + f6 * s1fac * src1(is,js,ks+3) - $ + f1 * s2fac * src2(is,js,ks-2) - $ + f2 * s2fac * src2(is,js,ks-1) - $ + f3 * s2fac * src2(is,js,ks ) - $ + f4 * s2fac * src2(is,js,ks+1) - $ + f5 * s2fac * src2(is,js,ks+2) - $ + f6 * s2fac * src2(is,js,ks+3) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8101 - goto 910 - -c kernel - 8101 continue - if (check_array_accesses.ne.0) then - call checkindex (is-2,js,ks-2, 6,1,6, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - res1 = - $ + f1*f1 * src1(is-2,js,ks-2) - $ + f2*f1 * src1(is-1,js,ks-2) - $ + f3*f1 * src1(is ,js,ks-2) - $ + f4*f1 * src1(is+1,js,ks-2) - $ + f5*f1 * src1(is+2,js,ks-2) - $ + f6*f1 * src1(is+3,js,ks-2) - $ + f1*f2 * src1(is-2,js,ks-1) - $ + f2*f2 * src1(is-1,js,ks-1) - $ + f3*f2 * src1(is ,js,ks-1) - $ + f4*f2 * src1(is+1,js,ks-1) - $ + f5*f2 * src1(is+2,js,ks-1) - $ + f6*f2 * src1(is+3,js,ks-1) - $ + f1*f3 * src1(is-2,js,ks ) - $ + f2*f3 * src1(is-1,js,ks ) - $ + f3*f3 * src1(is ,js,ks ) - $ + f4*f3 * src1(is+1,js,ks ) - $ + f5*f3 * src1(is+2,js,ks ) - $ + f6*f3 * src1(is+3,js,ks ) - $ + f1*f4 * src1(is-2,js,ks+1) - $ + f2*f4 * src1(is-1,js,ks+1) - $ + f3*f4 * src1(is ,js,ks+1) - $ + f4*f4 * src1(is+1,js,ks+1) - $ + f5*f4 * src1(is+2,js,ks+1) - $ + f6*f4 * src1(is+3,js,ks+1) - $ + f1*f5 * src1(is-2,js,ks+2) - $ + f2*f5 * src1(is-1,js,ks+2) - $ + f3*f5 * src1(is ,js,ks+2) - $ + f4*f5 * src1(is+1,js,ks+2) - $ + f5*f5 * src1(is+2,js,ks+2) - $ + f6*f5 * src1(is+3,js,ks+2) - $ + f1*f6 * src1(is-2,js,ks+3) - $ + f2*f6 * src1(is-1,js,ks+3) - $ + f3*f6 * src1(is ,js,ks+3) - $ + f4*f6 * src1(is+1,js,ks+3) - $ + f5*f6 * src1(is+2,js,ks+3) - $ + f6*f6 * src1(is+3,js,ks+3) - res2 = - $ + f1*f1 * src2(is-2,js,ks-2) - $ + f2*f1 * src2(is-1,js,ks-2) - $ + f3*f1 * src2(is ,js,ks-2) - $ + f4*f1 * src2(is+1,js,ks-2) - $ + f5*f1 * src2(is+2,js,ks-2) - $ + f6*f1 * src2(is+3,js,ks-2) - $ + f1*f2 * src2(is-2,js,ks-1) - $ + f2*f2 * src2(is-1,js,ks-1) - $ + f3*f2 * src2(is ,js,ks-1) - $ + f4*f2 * src2(is+1,js,ks-1) - $ + f5*f2 * src2(is+2,js,ks-1) - $ + f6*f2 * src2(is+3,js,ks-1) - $ + f1*f3 * src2(is-2,js,ks ) - $ + f2*f3 * src2(is-1,js,ks ) - $ + f3*f3 * src2(is ,js,ks ) - $ + f4*f3 * src2(is+1,js,ks ) - $ + f5*f3 * src2(is+2,js,ks ) - $ + f6*f3 * src2(is+3,js,ks ) - $ + f1*f4 * src2(is-2,js,ks+1) - $ + f2*f4 * src2(is-1,js,ks+1) - $ + f3*f4 * src2(is ,js,ks+1) - $ + f4*f4 * src2(is+1,js,ks+1) - $ + f5*f4 * src2(is+2,js,ks+1) - $ + f6*f4 * src2(is+3,js,ks+1) - $ + f1*f5 * src2(is-2,js,ks+2) - $ + f2*f5 * src2(is-1,js,ks+2) - $ + f3*f5 * src2(is ,js,ks+2) - $ + f4*f5 * src2(is+1,js,ks+2) - $ + f5*f5 * src2(is+2,js,ks+2) - $ + f6*f5 * src2(is+3,js,ks+2) - $ + f1*f6 * src2(is-2,js,ks+3) - $ + f2*f6 * src2(is-1,js,ks+3) - $ + f3*f6 * src2(is ,js,ks+3) - $ + f4*f6 * src2(is+1,js,ks+3) - $ + f5*f6 * src2(is+2,js,ks+3) - $ + f6*f6 * src2(is+3,js,ks+3) - dst(id,jd,kd) = s1fac * res1 + s2fac * res2 - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8100 - goto 910 - -c end i loop - 910 continue - j = j+1 - jd = jd+1 - if (j.lt.regjext) goto 811 - goto 91 - -c begin i loop - 811 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8110 - if (fi.eq.1) goto 8111 - stop - -c kernel - 8110 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js-2,ks-2, 1,6,6, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - res1 = - $ + f1*f1 * src1(is,js-2,ks-2) - $ + f2*f1 * src1(is,js-1,ks-2) - $ + f3*f1 * src1(is,js ,ks-2) - $ + f4*f1 * src1(is,js+1,ks-2) - $ + f5*f1 * src1(is,js+2,ks-2) - $ + f6*f1 * src1(is,js+3,ks-2) - $ + f1*f2 * src1(is,js-2,ks-1) - $ + f2*f2 * src1(is,js-1,ks-1) - $ + f3*f2 * src1(is,js ,ks-1) - $ + f4*f2 * src1(is,js+1,ks-1) - $ + f5*f2 * src1(is,js+2,ks-1) - $ + f6*f2 * src1(is,js+3,ks-1) - $ + f1*f3 * src1(is,js-2,ks ) - $ + f2*f3 * src1(is,js-1,ks ) - $ + f3*f3 * src1(is,js ,ks ) - $ + f4*f3 * src1(is,js+1,ks ) - $ + f5*f3 * src1(is,js+2,ks ) - $ + f6*f3 * src1(is,js+3,ks ) - $ + f1*f4 * src1(is,js-2,ks+1) - $ + f2*f4 * src1(is,js-1,ks+1) - $ + f3*f4 * src1(is,js ,ks+1) - $ + f4*f4 * src1(is,js+1,ks+1) - $ + f5*f4 * src1(is,js+2,ks+1) - $ + f6*f4 * src1(is,js+3,ks+1) - $ + f1*f5 * src1(is,js-2,ks+2) - $ + f2*f5 * src1(is,js-1,ks+2) - $ + f3*f5 * src1(is,js ,ks+2) - $ + f4*f5 * src1(is,js+1,ks+2) - $ + f5*f5 * src1(is,js+2,ks+2) - $ + f6*f5 * src1(is,js+3,ks+2) - $ + f1*f6 * src1(is,js-2,ks+3) - $ + f2*f6 * src1(is,js-1,ks+3) - $ + f3*f6 * src1(is,js ,ks+3) - $ + f4*f6 * src1(is,js+1,ks+3) - $ + f5*f6 * src1(is,js+2,ks+3) - $ + f6*f6 * src1(is,js+3,ks+3) - res2 = - $ + f1*f1 * src2(is,js-2,ks-2) - $ + f2*f1 * src2(is,js-1,ks-2) - $ + f3*f1 * src2(is,js ,ks-2) - $ + f4*f1 * src2(is,js+1,ks-2) - $ + f5*f1 * src2(is,js+2,ks-2) - $ + f6*f1 * src2(is,js+3,ks-2) - $ + f1*f2 * src2(is,js-2,ks-1) - $ + f2*f2 * src2(is,js-1,ks-1) - $ + f3*f2 * src2(is,js ,ks-1) - $ + f4*f2 * src2(is,js+1,ks-1) - $ + f5*f2 * src2(is,js+2,ks-1) - $ + f6*f2 * src2(is,js+3,ks-1) - $ + f1*f3 * src2(is,js-2,ks ) - $ + f2*f3 * src2(is,js-1,ks ) - $ + f3*f3 * src2(is,js ,ks ) - $ + f4*f3 * src2(is,js+1,ks ) - $ + f5*f3 * src2(is,js+2,ks ) - $ + f6*f3 * src2(is,js+3,ks ) - $ + f1*f4 * src2(is,js-2,ks+1) - $ + f2*f4 * src2(is,js-1,ks+1) - $ + f3*f4 * src2(is,js ,ks+1) - $ + f4*f4 * src2(is,js+1,ks+1) - $ + f5*f4 * src2(is,js+2,ks+1) - $ + f6*f4 * src2(is,js+3,ks+1) - $ + f1*f5 * src2(is,js-2,ks+2) - $ + f2*f5 * src2(is,js-1,ks+2) - $ + f3*f5 * src2(is,js ,ks+2) - $ + f4*f5 * src2(is,js+1,ks+2) - $ + f5*f5 * src2(is,js+2,ks+2) - $ + f6*f5 * src2(is,js+3,ks+2) - $ + f1*f6 * src2(is,js-2,ks+3) - $ + f2*f6 * src2(is,js-1,ks+3) - $ + f3*f6 * src2(is,js ,ks+3) - $ + f4*f6 * src2(is,js+1,ks+3) - $ + f5*f6 * src2(is,js+2,ks+3) - $ + f6*f6 * src2(is,js+3,ks+3) - dst(id,jd,kd) = s1fac * res1 + s2fac * res2 - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8111 - goto 911 - -c kernel - 8111 continue - if (check_array_accesses.ne.0) then - call checkindex (is-2,js-2,ks-2, 6,6,6, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - res11 = - $ + f1*f1*f1 * src1(is-2,js-2,ks-2) - $ + f2*f1*f1 * src1(is-1,js-2,ks-2) - $ + f3*f1*f1 * src1(is ,js-2,ks-2) - $ + f4*f1*f1 * src1(is+1,js-2,ks-2) - $ + f5*f1*f1 * src1(is+2,js-2,ks-2) - $ + f6*f1*f1 * src1(is+3,js-2,ks-2) - $ + f1*f2*f1 * src1(is-2,js-1,ks-2) - $ + f2*f2*f1 * src1(is-1,js-1,ks-2) - $ + f3*f2*f1 * src1(is ,js-1,ks-2) - $ + f4*f2*f1 * src1(is+1,js-1,ks-2) - $ + f5*f2*f1 * src1(is+2,js-1,ks-2) - $ + f6*f2*f1 * src1(is+3,js-1,ks-2) - $ + f1*f3*f1 * src1(is-2,js ,ks-2) - $ + f2*f3*f1 * src1(is-1,js ,ks-2) - $ + f3*f3*f1 * src1(is ,js ,ks-2) - $ + f4*f3*f1 * src1(is+1,js ,ks-2) - $ + f5*f3*f1 * src1(is+2,js ,ks-2) - $ + f6*f3*f1 * src1(is+3,js ,ks-2) - $ + f1*f4*f1 * src1(is-2,js+1,ks-2) - $ + f2*f4*f1 * src1(is-1,js+1,ks-2) - $ + f3*f4*f1 * src1(is ,js+1,ks-2) - $ + f4*f4*f1 * src1(is+1,js+1,ks-2) - $ + f5*f4*f1 * src1(is+2,js+1,ks-2) - $ + f6*f4*f1 * src1(is+3,js+1,ks-2) - $ + f1*f5*f1 * src1(is-2,js+2,ks-2) - $ + f2*f5*f1 * src1(is-1,js+2,ks-2) - $ + f3*f5*f1 * src1(is ,js+2,ks-2) - $ + f4*f5*f1 * src1(is+1,js+2,ks-2) - $ + f5*f5*f1 * src1(is+2,js+2,ks-2) - $ + f6*f5*f1 * src1(is+3,js+2,ks-2) - $ + f1*f6*f1 * src1(is-2,js+3,ks-2) - $ + f2*f6*f1 * src1(is-1,js+3,ks-2) - $ + f3*f6*f1 * src1(is ,js+3,ks-2) - $ + f4*f6*f1 * src1(is+1,js+3,ks-2) - $ + f5*f6*f1 * src1(is+2,js+3,ks-2) - $ + f6*f6*f1 * src1(is+3,js+3,ks-2) - res12 = - $ + f1*f1*f2 * src1(is-2,js-2,ks-1) - $ + f2*f1*f2 * src1(is-1,js-2,ks-1) - $ + f3*f1*f2 * src1(is ,js-2,ks-1) - $ + f4*f1*f2 * src1(is+1,js-2,ks-1) - $ + f5*f1*f2 * src1(is+2,js-2,ks-1) - $ + f6*f1*f2 * src1(is+3,js-2,ks-1) - $ + f1*f2*f2 * src1(is-2,js-1,ks-1) - $ + f2*f2*f2 * src1(is-1,js-1,ks-1) - $ + f3*f2*f2 * src1(is ,js-1,ks-1) - $ + f4*f2*f2 * src1(is+1,js-1,ks-1) - $ + f5*f2*f2 * src1(is+2,js-1,ks-1) - $ + f6*f2*f2 * src1(is+3,js-1,ks-1) - $ + f1*f3*f2 * src1(is-2,js ,ks-1) - $ + f2*f3*f2 * src1(is-1,js ,ks-1) - $ + f3*f3*f2 * src1(is ,js ,ks-1) - $ + f4*f3*f2 * src1(is+1,js ,ks-1) - $ + f5*f3*f2 * src1(is+2,js ,ks-1) - $ + f6*f3*f2 * src1(is+3,js ,ks-1) - $ + f1*f4*f2 * src1(is-2,js+1,ks-1) - $ + f2*f4*f2 * src1(is-1,js+1,ks-1) - $ + f3*f4*f2 * src1(is ,js+1,ks-1) - $ + f4*f4*f2 * src1(is+1,js+1,ks-1) - $ + f5*f4*f2 * src1(is+2,js+1,ks-1) - $ + f6*f4*f2 * src1(is+3,js+1,ks-1) - $ + f1*f5*f2 * src1(is-2,js+2,ks-1) - $ + f2*f5*f2 * src1(is-1,js+2,ks-1) - $ + f3*f5*f2 * src1(is ,js+2,ks-1) - $ + f4*f5*f2 * src1(is+1,js+2,ks-1) - $ + f5*f5*f2 * src1(is+2,js+2,ks-1) - $ + f6*f5*f2 * src1(is+3,js+2,ks-1) - $ + f1*f6*f2 * src1(is-2,js+3,ks-1) - $ + f2*f6*f2 * src1(is-1,js+3,ks-1) - $ + f3*f6*f2 * src1(is ,js+3,ks-1) - $ + f4*f6*f2 * src1(is+1,js+3,ks-1) - $ + f5*f6*f2 * src1(is+2,js+3,ks-1) - $ + f6*f6*f2 * src1(is+3,js+3,ks-1) - res13 = - $ + f1*f1*f3 * src1(is-2,js-2,ks ) - $ + f2*f1*f3 * src1(is-1,js-2,ks ) - $ + f3*f1*f3 * src1(is ,js-2,ks ) - $ + f4*f1*f3 * src1(is+1,js-2,ks ) - $ + f5*f1*f3 * src1(is+2,js-2,ks ) - $ + f6*f1*f3 * src1(is+3,js-2,ks ) - $ + f1*f2*f3 * src1(is-2,js-1,ks ) - $ + f2*f2*f3 * src1(is-1,js-1,ks ) - $ + f3*f2*f3 * src1(is ,js-1,ks ) - $ + f4*f2*f3 * src1(is+1,js-1,ks ) - $ + f5*f2*f3 * src1(is+2,js-1,ks ) - $ + f6*f2*f3 * src1(is+3,js-1,ks ) - $ + f1*f3*f3 * src1(is-2,js ,ks ) - $ + f2*f3*f3 * src1(is-1,js ,ks ) - $ + f3*f3*f3 * src1(is ,js ,ks ) - $ + f4*f3*f3 * src1(is+1,js ,ks ) - $ + f5*f3*f3 * src1(is+2,js ,ks ) - $ + f6*f3*f3 * src1(is+3,js ,ks ) - $ + f1*f4*f3 * src1(is-2,js+1,ks ) - $ + f2*f4*f3 * src1(is-1,js+1,ks ) - $ + f3*f4*f3 * src1(is ,js+1,ks ) - $ + f4*f4*f3 * src1(is+1,js+1,ks ) - $ + f5*f4*f3 * src1(is+2,js+1,ks ) - $ + f6*f4*f3 * src1(is+3,js+1,ks ) - $ + f1*f5*f3 * src1(is-2,js+2,ks ) - $ + f2*f5*f3 * src1(is-1,js+2,ks ) - $ + f3*f5*f3 * src1(is ,js+2,ks ) - $ + f4*f5*f3 * src1(is+1,js+2,ks ) - $ + f5*f5*f3 * src1(is+2,js+2,ks ) - $ + f6*f5*f3 * src1(is+3,js+2,ks ) - $ + f1*f6*f3 * src1(is-2,js+3,ks ) - $ + f2*f6*f3 * src1(is-1,js+3,ks ) - $ + f3*f6*f3 * src1(is ,js+3,ks ) - $ + f4*f6*f3 * src1(is+1,js+3,ks ) - $ + f5*f6*f3 * src1(is+2,js+3,ks ) - $ + f6*f6*f3 * src1(is+3,js+3,ks ) - res14 = - $ + f1*f1*f4 * src1(is-2,js-2,ks+1) - $ + f2*f1*f4 * src1(is-1,js-2,ks+1) - $ + f3*f1*f4 * src1(is ,js-2,ks+1) - $ + f4*f1*f4 * src1(is+1,js-2,ks+1) - $ + f5*f1*f4 * src1(is+2,js-2,ks+1) - $ + f6*f1*f4 * src1(is+3,js-2,ks+1) - $ + f1*f2*f4 * src1(is-2,js-1,ks+1) - $ + f2*f2*f4 * src1(is-1,js-1,ks+1) - $ + f3*f2*f4 * src1(is ,js-1,ks+1) - $ + f4*f2*f4 * src1(is+1,js-1,ks+1) - $ + f5*f2*f4 * src1(is+2,js-1,ks+1) - $ + f6*f2*f4 * src1(is+3,js-1,ks+1) - $ + f1*f3*f4 * src1(is-2,js ,ks+1) - $ + f2*f3*f4 * src1(is-1,js ,ks+1) - $ + f3*f3*f4 * src1(is ,js ,ks+1) - $ + f4*f3*f4 * src1(is+1,js ,ks+1) - $ + f5*f3*f4 * src1(is+2,js ,ks+1) - $ + f6*f3*f4 * src1(is+3,js ,ks+1) - $ + f1*f4*f4 * src1(is-2,js+1,ks+1) - $ + f2*f4*f4 * src1(is-1,js+1,ks+1) - $ + f3*f4*f4 * src1(is ,js+1,ks+1) - $ + f4*f4*f4 * src1(is+1,js+1,ks+1) - $ + f5*f4*f4 * src1(is+2,js+1,ks+1) - $ + f6*f4*f4 * src1(is+3,js+1,ks+1) - $ + f1*f5*f4 * src1(is-2,js+2,ks+1) - $ + f2*f5*f4 * src1(is-1,js+2,ks+1) - $ + f3*f5*f4 * src1(is ,js+2,ks+1) - $ + f4*f5*f4 * src1(is+1,js+2,ks+1) - $ + f5*f5*f4 * src1(is+2,js+2,ks+1) - $ + f6*f5*f4 * src1(is+3,js+2,ks+1) - $ + f1*f6*f4 * src1(is-2,js+3,ks+1) - $ + f2*f6*f4 * src1(is-1,js+3,ks+1) - $ + f3*f6*f4 * src1(is ,js+3,ks+1) - $ + f4*f6*f4 * src1(is+1,js+3,ks+1) - $ + f5*f6*f4 * src1(is+2,js+3,ks+1) - $ + f6*f6*f4 * src1(is+3,js+3,ks+1) - res15 = - $ + f1*f1*f5 * src1(is-2,js-2,ks+2) - $ + f2*f1*f5 * src1(is-1,js-2,ks+2) - $ + f3*f1*f5 * src1(is ,js-2,ks+2) - $ + f4*f1*f5 * src1(is+1,js-2,ks+2) - $ + f5*f1*f5 * src1(is+2,js-2,ks+2) - $ + f6*f1*f5 * src1(is+3,js-2,ks+2) - $ + f1*f2*f5 * src1(is-2,js-1,ks+2) - $ + f2*f2*f5 * src1(is-1,js-1,ks+2) - $ + f3*f2*f5 * src1(is ,js-1,ks+2) - $ + f4*f2*f5 * src1(is+1,js-1,ks+2) - $ + f5*f2*f5 * src1(is+2,js-1,ks+2) - $ + f6*f2*f5 * src1(is+3,js-1,ks+2) - $ + f1*f3*f5 * src1(is-2,js ,ks+2) - $ + f2*f3*f5 * src1(is-1,js ,ks+2) - $ + f3*f3*f5 * src1(is ,js ,ks+2) - $ + f4*f3*f5 * src1(is+1,js ,ks+2) - $ + f5*f3*f5 * src1(is+2,js ,ks+2) - $ + f6*f3*f5 * src1(is+3,js ,ks+2) - $ + f1*f4*f5 * src1(is-2,js+1,ks+2) - $ + f2*f4*f5 * src1(is-1,js+1,ks+2) - $ + f3*f4*f5 * src1(is ,js+1,ks+2) - $ + f4*f4*f5 * src1(is+1,js+1,ks+2) - $ + f5*f4*f5 * src1(is+2,js+1,ks+2) - $ + f6*f4*f5 * src1(is+3,js+1,ks+2) - $ + f1*f5*f5 * src1(is-2,js+2,ks+2) - $ + f2*f5*f5 * src1(is-1,js+2,ks+2) - $ + f3*f5*f5 * src1(is ,js+2,ks+2) - $ + f4*f5*f5 * src1(is+1,js+2,ks+2) - $ + f5*f5*f5 * src1(is+2,js+2,ks+2) - $ + f6*f5*f5 * src1(is+3,js+2,ks+2) - $ + f1*f6*f5 * src1(is-2,js+3,ks+2) - $ + f2*f6*f5 * src1(is-1,js+3,ks+2) - $ + f3*f6*f5 * src1(is ,js+3,ks+2) - $ + f4*f6*f5 * src1(is+1,js+3,ks+2) - $ + f5*f6*f5 * src1(is+2,js+3,ks+2) - $ + f6*f6*f5 * src1(is+3,js+3,ks+2) - res16 = - $ + f1*f1*f6 * src1(is-2,js-2,ks+3) - $ + f2*f1*f6 * src1(is-1,js-2,ks+3) - $ + f3*f1*f6 * src1(is ,js-2,ks+3) - $ + f4*f1*f6 * src1(is+1,js-2,ks+3) - $ + f5*f1*f6 * src1(is+2,js-2,ks+3) - $ + f6*f1*f6 * src1(is+3,js-2,ks+3) - $ + f1*f2*f6 * src1(is-2,js-1,ks+3) - $ + f2*f2*f6 * src1(is-1,js-1,ks+3) - $ + f3*f2*f6 * src1(is ,js-1,ks+3) - $ + f4*f2*f6 * src1(is+1,js-1,ks+3) - $ + f5*f2*f6 * src1(is+2,js-1,ks+3) - $ + f6*f2*f6 * src1(is+3,js-1,ks+3) - $ + f1*f3*f6 * src1(is-2,js ,ks+3) - $ + f2*f3*f6 * src1(is-1,js ,ks+3) - $ + f3*f3*f6 * src1(is ,js ,ks+3) - $ + f4*f3*f6 * src1(is+1,js ,ks+3) - $ + f5*f3*f6 * src1(is+2,js ,ks+3) - $ + f6*f3*f6 * src1(is+3,js ,ks+3) - $ + f1*f4*f6 * src1(is-2,js+1,ks+3) - $ + f2*f4*f6 * src1(is-1,js+1,ks+3) - $ + f3*f4*f6 * src1(is ,js+1,ks+3) - $ + f4*f4*f6 * src1(is+1,js+1,ks+3) - $ + f5*f4*f6 * src1(is+2,js+1,ks+3) - $ + f6*f4*f6 * src1(is+3,js+1,ks+3) - $ + f1*f5*f6 * src1(is-2,js+2,ks+3) - $ + f2*f5*f6 * src1(is-1,js+2,ks+3) - $ + f3*f5*f6 * src1(is ,js+2,ks+3) - $ + f4*f5*f6 * src1(is+1,js+2,ks+3) - $ + f5*f5*f6 * src1(is+2,js+2,ks+3) - $ + f6*f5*f6 * src1(is+3,js+2,ks+3) - $ + f1*f6*f6 * src1(is-2,js+3,ks+3) - $ + f2*f6*f6 * src1(is-1,js+3,ks+3) - $ + f3*f6*f6 * src1(is ,js+3,ks+3) - $ + f4*f6*f6 * src1(is+1,js+3,ks+3) - $ + f5*f6*f6 * src1(is+2,js+3,ks+3) - $ + f6*f6*f6 * src1(is+3,js+3,ks+3) - res21 = - $ + f1*f1*f1 * src2(is-2,js-2,ks-2) - $ + f2*f1*f1 * src2(is-1,js-2,ks-2) - $ + f3*f1*f1 * src2(is ,js-2,ks-2) - $ + f4*f1*f1 * src2(is+1,js-2,ks-2) - $ + f5*f1*f1 * src2(is+2,js-2,ks-2) - $ + f6*f1*f1 * src2(is+3,js-2,ks-2) - $ + f1*f2*f1 * src2(is-2,js-1,ks-2) - $ + f2*f2*f1 * src2(is-1,js-1,ks-2) - $ + f3*f2*f1 * src2(is ,js-1,ks-2) - $ + f4*f2*f1 * src2(is+1,js-1,ks-2) - $ + f5*f2*f1 * src2(is+2,js-1,ks-2) - $ + f6*f2*f1 * src2(is+3,js-1,ks-2) - $ + f1*f3*f1 * src2(is-2,js ,ks-2) - $ + f2*f3*f1 * src2(is-1,js ,ks-2) - $ + f3*f3*f1 * src2(is ,js ,ks-2) - $ + f4*f3*f1 * src2(is+1,js ,ks-2) - $ + f5*f3*f1 * src2(is+2,js ,ks-2) - $ + f6*f3*f1 * src2(is+3,js ,ks-2) - $ + f1*f4*f1 * src2(is-2,js+1,ks-2) - $ + f2*f4*f1 * src2(is-1,js+1,ks-2) - $ + f3*f4*f1 * src2(is ,js+1,ks-2) - $ + f4*f4*f1 * src2(is+1,js+1,ks-2) - $ + f5*f4*f1 * src2(is+2,js+1,ks-2) - $ + f6*f4*f1 * src2(is+3,js+1,ks-2) - $ + f1*f5*f1 * src2(is-2,js+2,ks-2) - $ + f2*f5*f1 * src2(is-1,js+2,ks-2) - $ + f3*f5*f1 * src2(is ,js+2,ks-2) - $ + f4*f5*f1 * src2(is+1,js+2,ks-2) - $ + f5*f5*f1 * src2(is+2,js+2,ks-2) - $ + f6*f5*f1 * src2(is+3,js+2,ks-2) - $ + f1*f6*f1 * src2(is-2,js+3,ks-2) - $ + f2*f6*f1 * src2(is-1,js+3,ks-2) - $ + f3*f6*f1 * src2(is ,js+3,ks-2) - $ + f4*f6*f1 * src2(is+1,js+3,ks-2) - $ + f5*f6*f1 * src2(is+2,js+3,ks-2) - $ + f6*f6*f1 * src2(is+3,js+3,ks-2) - res22 = - $ + f1*f1*f2 * src2(is-2,js-2,ks-1) - $ + f2*f1*f2 * src2(is-1,js-2,ks-1) - $ + f3*f1*f2 * src2(is ,js-2,ks-1) - $ + f4*f1*f2 * src2(is+1,js-2,ks-1) - $ + f5*f1*f2 * src2(is+2,js-2,ks-1) - $ + f6*f1*f2 * src2(is+3,js-2,ks-1) - $ + f1*f2*f2 * src2(is-2,js-1,ks-1) - $ + f2*f2*f2 * src2(is-1,js-1,ks-1) - $ + f3*f2*f2 * src2(is ,js-1,ks-1) - $ + f4*f2*f2 * src2(is+1,js-1,ks-1) - $ + f5*f2*f2 * src2(is+2,js-1,ks-1) - $ + f6*f2*f2 * src2(is+3,js-1,ks-1) - $ + f1*f3*f2 * src2(is-2,js ,ks-1) - $ + f2*f3*f2 * src2(is-1,js ,ks-1) - $ + f3*f3*f2 * src2(is ,js ,ks-1) - $ + f4*f3*f2 * src2(is+1,js ,ks-1) - $ + f5*f3*f2 * src2(is+2,js ,ks-1) - $ + f6*f3*f2 * src2(is+3,js ,ks-1) - $ + f1*f4*f2 * src2(is-2,js+1,ks-1) - $ + f2*f4*f2 * src2(is-1,js+1,ks-1) - $ + f3*f4*f2 * src2(is ,js+1,ks-1) - $ + f4*f4*f2 * src2(is+1,js+1,ks-1) - $ + f5*f4*f2 * src2(is+2,js+1,ks-1) - $ + f6*f4*f2 * src2(is+3,js+1,ks-1) - $ + f1*f5*f2 * src2(is-2,js+2,ks-1) - $ + f2*f5*f2 * src2(is-1,js+2,ks-1) - $ + f3*f5*f2 * src2(is ,js+2,ks-1) - $ + f4*f5*f2 * src2(is+1,js+2,ks-1) - $ + f5*f5*f2 * src2(is+2,js+2,ks-1) - $ + f6*f5*f2 * src2(is+3,js+2,ks-1) - $ + f1*f6*f2 * src2(is-2,js+3,ks-1) - $ + f2*f6*f2 * src2(is-1,js+3,ks-1) - $ + f3*f6*f2 * src2(is ,js+3,ks-1) - $ + f4*f6*f2 * src2(is+1,js+3,ks-1) - $ + f5*f6*f2 * src2(is+2,js+3,ks-1) - $ + f6*f6*f2 * src2(is+3,js+3,ks-1) - res23 = - $ + f1*f1*f3 * src2(is-2,js-2,ks ) - $ + f2*f1*f3 * src2(is-1,js-2,ks ) - $ + f3*f1*f3 * src2(is ,js-2,ks ) - $ + f4*f1*f3 * src2(is+1,js-2,ks ) - $ + f5*f1*f3 * src2(is+2,js-2,ks ) - $ + f6*f1*f3 * src2(is+3,js-2,ks ) - $ + f1*f2*f3 * src2(is-2,js-1,ks ) - $ + f2*f2*f3 * src2(is-1,js-1,ks ) - $ + f3*f2*f3 * src2(is ,js-1,ks ) - $ + f4*f2*f3 * src2(is+1,js-1,ks ) - $ + f5*f2*f3 * src2(is+2,js-1,ks ) - $ + f6*f2*f3 * src2(is+3,js-1,ks ) - $ + f1*f3*f3 * src2(is-2,js ,ks ) - $ + f2*f3*f3 * src2(is-1,js ,ks ) - $ + f3*f3*f3 * src2(is ,js ,ks ) - $ + f4*f3*f3 * src2(is+1,js ,ks ) - $ + f5*f3*f3 * src2(is+2,js ,ks ) - $ + f6*f3*f3 * src2(is+3,js ,ks ) - $ + f1*f4*f3 * src2(is-2,js+1,ks ) - $ + f2*f4*f3 * src2(is-1,js+1,ks ) - $ + f3*f4*f3 * src2(is ,js+1,ks ) - $ + f4*f4*f3 * src2(is+1,js+1,ks ) - $ + f5*f4*f3 * src2(is+2,js+1,ks ) - $ + f6*f4*f3 * src2(is+3,js+1,ks ) - $ + f1*f5*f3 * src2(is-2,js+2,ks ) - $ + f2*f5*f3 * src2(is-1,js+2,ks ) - $ + f3*f5*f3 * src2(is ,js+2,ks ) - $ + f4*f5*f3 * src2(is+1,js+2,ks ) - $ + f5*f5*f3 * src2(is+2,js+2,ks ) - $ + f6*f5*f3 * src2(is+3,js+2,ks ) - $ + f1*f6*f3 * src2(is-2,js+3,ks ) - $ + f2*f6*f3 * src2(is-1,js+3,ks ) - $ + f3*f6*f3 * src2(is ,js+3,ks ) - $ + f4*f6*f3 * src2(is+1,js+3,ks ) - $ + f5*f6*f3 * src2(is+2,js+3,ks ) - $ + f6*f6*f3 * src2(is+3,js+3,ks ) - res24 = - $ + f1*f1*f4 * src2(is-2,js-2,ks+1) - $ + f2*f1*f4 * src2(is-1,js-2,ks+1) - $ + f3*f1*f4 * src2(is ,js-2,ks+1) - $ + f4*f1*f4 * src2(is+1,js-2,ks+1) - $ + f5*f1*f4 * src2(is+2,js-2,ks+1) - $ + f6*f1*f4 * src2(is+3,js-2,ks+1) - $ + f1*f2*f4 * src2(is-2,js-1,ks+1) - $ + f2*f2*f4 * src2(is-1,js-1,ks+1) - $ + f3*f2*f4 * src2(is ,js-1,ks+1) - $ + f4*f2*f4 * src2(is+1,js-1,ks+1) - $ + f5*f2*f4 * src2(is+2,js-1,ks+1) - $ + f6*f2*f4 * src2(is+3,js-1,ks+1) - $ + f1*f3*f4 * src2(is-2,js ,ks+1) - $ + f2*f3*f4 * src2(is-1,js ,ks+1) - $ + f3*f3*f4 * src2(is ,js ,ks+1) - $ + f4*f3*f4 * src2(is+1,js ,ks+1) - $ + f5*f3*f4 * src2(is+2,js ,ks+1) - $ + f6*f3*f4 * src2(is+3,js ,ks+1) - $ + f1*f4*f4 * src2(is-2,js+1,ks+1) - $ + f2*f4*f4 * src2(is-1,js+1,ks+1) - $ + f3*f4*f4 * src2(is ,js+1,ks+1) - $ + f4*f4*f4 * src2(is+1,js+1,ks+1) - $ + f5*f4*f4 * src2(is+2,js+1,ks+1) - $ + f6*f4*f4 * src2(is+3,js+1,ks+1) - $ + f1*f5*f4 * src2(is-2,js+2,ks+1) - $ + f2*f5*f4 * src2(is-1,js+2,ks+1) - $ + f3*f5*f4 * src2(is ,js+2,ks+1) - $ + f4*f5*f4 * src2(is+1,js+2,ks+1) - $ + f5*f5*f4 * src2(is+2,js+2,ks+1) - $ + f6*f5*f4 * src2(is+3,js+2,ks+1) - $ + f1*f6*f4 * src2(is-2,js+3,ks+1) - $ + f2*f6*f4 * src2(is-1,js+3,ks+1) - $ + f3*f6*f4 * src2(is ,js+3,ks+1) - $ + f4*f6*f4 * src2(is+1,js+3,ks+1) - $ + f5*f6*f4 * src2(is+2,js+3,ks+1) - $ + f6*f6*f4 * src2(is+3,js+3,ks+1) - res25 = - $ + f1*f1*f5 * src2(is-2,js-2,ks+2) - $ + f2*f1*f5 * src2(is-1,js-2,ks+2) - $ + f3*f1*f5 * src2(is ,js-2,ks+2) - $ + f4*f1*f5 * src2(is+1,js-2,ks+2) - $ + f5*f1*f5 * src2(is+2,js-2,ks+2) - $ + f6*f1*f5 * src2(is+3,js-2,ks+2) - $ + f1*f2*f5 * src2(is-2,js-1,ks+2) - $ + f2*f2*f5 * src2(is-1,js-1,ks+2) - $ + f3*f2*f5 * src2(is ,js-1,ks+2) - $ + f4*f2*f5 * src2(is+1,js-1,ks+2) - $ + f5*f2*f5 * src2(is+2,js-1,ks+2) - $ + f6*f2*f5 * src2(is+3,js-1,ks+2) - $ + f1*f3*f5 * src2(is-2,js ,ks+2) - $ + f2*f3*f5 * src2(is-1,js ,ks+2) - $ + f3*f3*f5 * src2(is ,js ,ks+2) - $ + f4*f3*f5 * src2(is+1,js ,ks+2) - $ + f5*f3*f5 * src2(is+2,js ,ks+2) - $ + f6*f3*f5 * src2(is+3,js ,ks+2) - $ + f1*f4*f5 * src2(is-2,js+1,ks+2) - $ + f2*f4*f5 * src2(is-1,js+1,ks+2) - $ + f3*f4*f5 * src2(is ,js+1,ks+2) - $ + f4*f4*f5 * src2(is+1,js+1,ks+2) - $ + f5*f4*f5 * src2(is+2,js+1,ks+2) - $ + f6*f4*f5 * src2(is+3,js+1,ks+2) - $ + f1*f5*f5 * src2(is-2,js+2,ks+2) - $ + f2*f5*f5 * src2(is-1,js+2,ks+2) - $ + f3*f5*f5 * src2(is ,js+2,ks+2) - $ + f4*f5*f5 * src2(is+1,js+2,ks+2) - $ + f5*f5*f5 * src2(is+2,js+2,ks+2) - $ + f6*f5*f5 * src2(is+3,js+2,ks+2) - $ + f1*f6*f5 * src2(is-2,js+3,ks+2) - $ + f2*f6*f5 * src2(is-1,js+3,ks+2) - $ + f3*f6*f5 * src2(is ,js+3,ks+2) - $ + f4*f6*f5 * src2(is+1,js+3,ks+2) - $ + f5*f6*f5 * src2(is+2,js+3,ks+2) - $ + f6*f6*f5 * src2(is+3,js+3,ks+2) - res26 = - $ + f1*f1*f6 * src2(is-2,js-2,ks+3) - $ + f2*f1*f6 * src2(is-1,js-2,ks+3) - $ + f3*f1*f6 * src2(is ,js-2,ks+3) - $ + f4*f1*f6 * src2(is+1,js-2,ks+3) - $ + f5*f1*f6 * src2(is+2,js-2,ks+3) - $ + f6*f1*f6 * src2(is+3,js-2,ks+3) - $ + f1*f2*f6 * src2(is-2,js-1,ks+3) - $ + f2*f2*f6 * src2(is-1,js-1,ks+3) - $ + f3*f2*f6 * src2(is ,js-1,ks+3) - $ + f4*f2*f6 * src2(is+1,js-1,ks+3) - $ + f5*f2*f6 * src2(is+2,js-1,ks+3) - $ + f6*f2*f6 * src2(is+3,js-1,ks+3) - $ + f1*f3*f6 * src2(is-2,js ,ks+3) - $ + f2*f3*f6 * src2(is-1,js ,ks+3) - $ + f3*f3*f6 * src2(is ,js ,ks+3) - $ + f4*f3*f6 * src2(is+1,js ,ks+3) - $ + f5*f3*f6 * src2(is+2,js ,ks+3) - $ + f6*f3*f6 * src2(is+3,js ,ks+3) - $ + f1*f4*f6 * src2(is-2,js+1,ks+3) - $ + f2*f4*f6 * src2(is-1,js+1,ks+3) - $ + f3*f4*f6 * src2(is ,js+1,ks+3) - $ + f4*f4*f6 * src2(is+1,js+1,ks+3) - $ + f5*f4*f6 * src2(is+2,js+1,ks+3) - $ + f6*f4*f6 * src2(is+3,js+1,ks+3) - $ + f1*f5*f6 * src2(is-2,js+2,ks+3) - $ + f2*f5*f6 * src2(is-1,js+2,ks+3) - $ + f3*f5*f6 * src2(is ,js+2,ks+3) - $ + f4*f5*f6 * src2(is+1,js+2,ks+3) - $ + f5*f5*f6 * src2(is+2,js+2,ks+3) - $ + f6*f5*f6 * src2(is+3,js+2,ks+3) - $ + f1*f6*f6 * src2(is-2,js+3,ks+3) - $ + f2*f6*f6 * src2(is-1,js+3,ks+3) - $ + f3*f6*f6 * src2(is ,js+3,ks+3) - $ + f4*f6*f6 * src2(is+1,js+3,ks+3) - $ + f5*f6*f6 * src2(is+2,js+3,ks+3) - $ + f6*f6*f6 * src2(is+3,js+3,ks+3) - dst(id,jd,kd) = - $ + s1fac * (res11 + res12 + res13 + res14 + res15 + res16) - $ + s2fac * (res21 + res22 + res23 + res24 + res25 + res26) - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8110 - goto 911 - -c end i loop - 911 continue - j = j+1 - jd = jd+1 - js = js+1 - if (j.lt.regjext) goto 810 - goto 91 - -c end j loop - 91 continue - k = k+1 - kd = kd+1 - ks = ks+1 - if (k.lt.regkext) goto 80 - goto 9 - -c end k loop - 9 continue - - end diff --git a/Carpet/CarpetLib/src/prolongate_3d_real8_2tl_o7_rf2.F77 b/Carpet/CarpetLib/src/prolongate_3d_real8_2tl_o7_rf2.F77 deleted file mode 100644 index 6b4919864..000000000 --- a/Carpet/CarpetLib/src/prolongate_3d_real8_2tl_o7_rf2.F77 +++ /dev/null @@ -1,1862 +0,0 @@ -c -*-Fortran-*- - -#include "cctk.h" -#include "cctk_Parameters.h" - - - - subroutine prolongate_3d_real8_2tl_o7_rf2 ( - $ src1, t1, src2, t2, srciext, srcjext, srckext, - $ dst, t, dstiext, dstjext, dstkext, - $ srcbbox, dstbbox, regbbox) - - implicit none - - DECLARE_CCTK_PARAMETERS - - CCTK_REAL8 eps - parameter (eps = 1.0d-10) - - CCTK_REAL8 one - parameter (one = 1) - CCTK_REAL8 f1, f2, f3, f4, f5, f6, f7, f8 - parameter (f1 = - 5*one/2048) - parameter (f2 = 49*one/2048) - parameter (f3 = - 245*one/2048) - parameter (f4 = 1225*one/2048) - parameter (f5 = 1225*one/2048) - parameter (f6 = - 245*one/2048) - parameter (f7 = 49*one/2048) - parameter (f8 = - 5*one/2048) - - integer srciext, srcjext, srckext - CCTK_REAL8 src1(srciext,srcjext,srckext) - CCTK_REAL8 t1 - CCTK_REAL8 src2(srciext,srcjext,srckext) - CCTK_REAL8 t2 - integer dstiext, dstjext, dstkext - CCTK_REAL8 dst(dstiext,dstjext,dstkext) - CCTK_REAL8 t -c bbox(:,1) is lower boundary (inclusive) -c bbox(:,2) is upper boundary (inclusive) -c bbox(:,3) is stride - integer srcbbox(3,3), dstbbox(3,3), regbbox(3,3) - - integer regiext, regjext, regkext - - integer srcioff, srcjoff, srckoff - integer dstioff, dstjoff, dstkoff - - integer offsetlo, offsethi - - CCTK_REAL8 s1fac, s2fac - - integer i0, j0, k0 - integer fi, fj, fk - integer is, js, ks - integer id, jd, kd - integer i, j, k - - CCTK_REAL8 res1, res2 - CCTK_REAL8 res11, res12, res13, res14, res15, res16, res17, res18 - CCTK_REAL8 res21, res22, res23, res24, res25, res26, res27, res28 - - integer d - - - - do d=1,3 - if (srcbbox(d,3).eq.0 .or. dstbbox(d,3).eq.0 - $ .or. regbbox(d,3).eq.0) then - call CCTK_WARN (0, "Internal error: stride is zero") - end if - if (srcbbox(d,3).le.regbbox(d,3) - $ .or. dstbbox(d,3).ne.regbbox(d,3)) then - call CCTK_WARN (0, "Internal error: strides disagree") - end if - if (srcbbox(d,3).ne.dstbbox(d,3)*2) then - call CCTK_WARN (0, "Internal error: source strides are not twice the destination strides") - end if - if (mod(srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array origins are not integer multiples of the strides") - end if - if (regbbox(d,1).gt.regbbox(d,2)) then -c This could be handled, but is likely to point to an error elsewhere - call CCTK_WARN (0, "Internal error: region extent is empty") - end if - if (mod(srcbbox(d,2) - srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,2) - dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,2) - regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array extents are not integer multiples of the strides") - end if - regkext = (regbbox(d,2) - regbbox(d,1)) / regbbox(d,3) + 1 - srckoff = (regbbox(d,1) - srcbbox(d,1)) / dstbbox(d,3) - offsetlo = regbbox(d,3) - if (mod(srckoff, 2).eq.0) then - offsetlo = 0 - if (regkext.gt.1) then - offsetlo = regbbox(d,3) - end if - end if - offsethi = regbbox(d,3) - if (mod(srckoff + regkext-1, 2).eq.0) then - offsethi = 0 - if (regkext.gt.1) then - offsethi = regbbox(d,3) - end if - end if - if (regbbox(d,1)-offsetlo.lt.srcbbox(d,1) - $ .or. regbbox(d,2)+offsethi.gt.srcbbox(d,2) - $ .or. regbbox(d,1).lt.dstbbox(d,1) - $ .or. regbbox(d,2).gt.dstbbox(d,2)) then - call CCTK_WARN (0, "Internal error: region extent is not contained in array extent") - end if - end do - - if (srciext.ne.(srcbbox(1,2)-srcbbox(1,1))/srcbbox(1,3)+1 - $ .or. srcjext.ne.(srcbbox(2,2)-srcbbox(2,1))/srcbbox(2,3)+1 - $ .or. srckext.ne.(srcbbox(3,2)-srcbbox(3,1))/srcbbox(3,3)+1 - $ .or. dstiext.ne.(dstbbox(1,2)-dstbbox(1,1))/dstbbox(1,3)+1 - $ .or. dstjext.ne.(dstbbox(2,2)-dstbbox(2,1))/dstbbox(2,3)+1 - $ .or. dstkext.ne.(dstbbox(3,2)-dstbbox(3,1))/dstbbox(3,3)+1) then - call CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes") - end if - - - - regiext = (regbbox(1,2) - regbbox(1,1)) / regbbox(1,3) + 1 - regjext = (regbbox(2,2) - regbbox(2,1)) / regbbox(2,3) + 1 - regkext = (regbbox(3,2) - regbbox(3,1)) / regbbox(3,3) + 1 - - srcioff = (regbbox(1,1) - srcbbox(1,1)) / dstbbox(1,3) - srcjoff = (regbbox(2,1) - srcbbox(2,1)) / dstbbox(2,3) - srckoff = (regbbox(3,1) - srcbbox(3,1)) / dstbbox(3,3) - - dstioff = (regbbox(1,1) - dstbbox(1,1)) / dstbbox(1,3) - dstjoff = (regbbox(2,1) - dstbbox(2,1)) / dstbbox(2,3) - dstkoff = (regbbox(3,1) - dstbbox(3,1)) / dstbbox(3,3) - - - -c Quadratic (second order) time interpolation - if (t1.eq.t2) then - call CCTK_WARN (0, "Internal error: arrays have same time") - end if - if (t.lt.min(t1,t2)-eps .or. t.gt.max(t1,t2)+eps) then - call CCTK_WARN (0, "Internal error: extrapolation in time in time") - end if - - s1fac = (t - t2) / (t1 - t2) - s2fac = (t - t1) / (t2 - t1) - - - - fi = mod(srcioff, 2) - fj = mod(srcjoff, 2) - fk = mod(srckoff, 2) - - i0 = srcioff / 2 - j0 = srcjoff / 2 - k0 = srckoff / 2 - - - -c Loop over fine region -c Label scheme: 8 fk fj fi - -c begin k loop - 8 continue - k = 0 - ks = k0+1 - kd = dstkoff+1 - if (fk.eq.0) goto 80 - if (fk.eq.1) goto 81 - stop - -c begin j loop - 80 continue - j = 0 - js = j0+1 - jd = dstjoff+1 - if (fj.eq.0) goto 800 - if (fj.eq.1) goto 801 - stop - -c begin i loop - 800 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8000 - if (fi.eq.1) goto 8001 - stop - -c kernel - 8000 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js,ks, 1,1,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + s1fac * src1(is,js,ks) - $ + s2fac * src2(is,js,ks) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8001 - goto 900 - -c kernel - 8001 continue - if (check_array_accesses.ne.0) then - call checkindex (is-3,js,ks, 8,1,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + f1 * s1fac * src1(is-3,js,ks) - $ + f2 * s1fac * src1(is-2,js,ks) - $ + f3 * s1fac * src1(is-1,js,ks) - $ + f4 * s1fac * src1(is ,js,ks) - $ + f5 * s1fac * src1(is+1,js,ks) - $ + f6 * s1fac * src1(is+2,js,ks) - $ + f7 * s1fac * src1(is+3,js,ks) - $ + f8 * s1fac * src1(is+4,js,ks) - $ + f1 * s2fac * src2(is-3,js,ks) - $ + f2 * s2fac * src2(is-2,js,ks) - $ + f3 * s2fac * src2(is-1,js,ks) - $ + f4 * s2fac * src2(is ,js,ks) - $ + f5 * s2fac * src2(is+1,js,ks) - $ + f6 * s2fac * src2(is+2,js,ks) - $ + f7 * s2fac * src2(is+3,js,ks) - $ + f8 * s2fac * src2(is+4,js,ks) - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8000 - goto 900 - -c end i loop - 900 continue - j = j+1 - jd = jd+1 - if (j.lt.regjext) goto 801 - goto 90 - -c begin i loop - 801 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8010 - if (fi.eq.1) goto 8011 - stop - -c kernel - 8010 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js-3,ks, 1,8,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + f1 * s1fac * src1(is,js-3,ks) - $ + f2 * s1fac * src1(is,js-2,ks) - $ + f3 * s1fac * src1(is,js-1,ks) - $ + f4 * s1fac * src1(is,js ,ks) - $ + f5 * s1fac * src1(is,js+1,ks) - $ + f6 * s1fac * src1(is,js+2,ks) - $ + f7 * s1fac * src1(is,js+3,ks) - $ + f8 * s1fac * src1(is,js+4,ks) - $ + f1 * s2fac * src2(is,js-3,ks) - $ + f2 * s2fac * src2(is,js-2,ks) - $ + f3 * s2fac * src2(is,js-1,ks) - $ + f4 * s2fac * src2(is,js ,ks) - $ + f5 * s2fac * src2(is,js+1,ks) - $ + f6 * s2fac * src2(is,js+2,ks) - $ + f7 * s2fac * src2(is,js+3,ks) - $ + f8 * s2fac * src2(is,js+4,ks) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8011 - goto 901 - -c kernel - 8011 continue - if (check_array_accesses.ne.0) then - call checkindex (is-3,js-3,ks, 8,8,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - res1 = - $ + f1*f1 * src1(is-3,js-3,ks) - $ + f2*f1 * src1(is-2,js-3,ks) - $ + f3*f1 * src1(is-1,js-3,ks) - $ + f4*f1 * src1(is ,js-3,ks) - $ + f5*f1 * src1(is+1,js-3,ks) - $ + f6*f1 * src1(is+2,js-3,ks) - $ + f7*f1 * src1(is+3,js-3,ks) - $ + f8*f1 * src1(is+4,js-3,ks) - $ + f1*f2 * src1(is-3,js-2,ks) - $ + f2*f2 * src1(is-2,js-2,ks) - $ + f3*f2 * src1(is-1,js-2,ks) - $ + f4*f2 * src1(is ,js-2,ks) - $ + f5*f2 * src1(is+1,js-2,ks) - $ + f6*f2 * src1(is+2,js-2,ks) - $ + f7*f2 * src1(is+3,js-2,ks) - $ + f8*f2 * src1(is+4,js-2,ks) - $ + f1*f3 * src1(is-3,js-1,ks) - $ + f2*f3 * src1(is-2,js-1,ks) - $ + f3*f3 * src1(is-1,js-1,ks) - $ + f4*f3 * src1(is ,js-1,ks) - $ + f5*f3 * src1(is+1,js-1,ks) - $ + f6*f3 * src1(is+2,js-1,ks) - $ + f7*f3 * src1(is+3,js-1,ks) - $ + f8*f3 * src1(is+4,js-1,ks) - $ + f1*f4 * src1(is-3,js ,ks) - $ + f2*f4 * src1(is-2,js ,ks) - $ + f3*f4 * src1(is-1,js ,ks) - $ + f4*f4 * src1(is ,js ,ks) - $ + f5*f4 * src1(is+1,js ,ks) - $ + f6*f4 * src1(is+2,js ,ks) - $ + f7*f4 * src1(is+3,js ,ks) - $ + f8*f4 * src1(is+4,js ,ks) - $ + f1*f5 * src1(is-3,js+1,ks) - $ + f2*f5 * src1(is-2,js+1,ks) - $ + f3*f5 * src1(is-1,js+1,ks) - $ + f4*f5 * src1(is ,js+1,ks) - $ + f5*f5 * src1(is+1,js+1,ks) - $ + f6*f5 * src1(is+2,js+1,ks) - $ + f7*f5 * src1(is+3,js+1,ks) - $ + f8*f5 * src1(is+4,js+1,ks) - $ + f1*f6 * src1(is-3,js+2,ks) - $ + f2*f6 * src1(is-2,js+2,ks) - $ + f3*f6 * src1(is-1,js+2,ks) - $ + f4*f6 * src1(is ,js+2,ks) - $ + f5*f6 * src1(is+1,js+2,ks) - $ + f6*f6 * src1(is+2,js+2,ks) - $ + f7*f6 * src1(is+3,js+2,ks) - $ + f8*f6 * src1(is+4,js+2,ks) - $ + f1*f7 * src1(is-3,js+3,ks) - $ + f2*f7 * src1(is-2,js+3,ks) - $ + f3*f7 * src1(is-1,js+3,ks) - $ + f4*f7 * src1(is ,js+3,ks) - $ + f5*f7 * src1(is+1,js+3,ks) - $ + f6*f7 * src1(is+2,js+3,ks) - $ + f7*f7 * src1(is+3,js+3,ks) - $ + f8*f7 * src1(is+4,js+3,ks) - $ + f1*f8 * src1(is-3,js+4,ks) - $ + f2*f8 * src1(is-2,js+4,ks) - $ + f3*f8 * src1(is-1,js+4,ks) - $ + f4*f8 * src1(is ,js+4,ks) - $ + f5*f8 * src1(is+1,js+4,ks) - $ + f6*f8 * src1(is+2,js+4,ks) - $ + f7*f8 * src1(is+3,js+4,ks) - $ + f8*f8 * src1(is+4,js+4,ks) - res2 = - $ + f1*f1 * src2(is-3,js-3,ks) - $ + f2*f1 * src2(is-2,js-3,ks) - $ + f3*f1 * src2(is-1,js-3,ks) - $ + f4*f1 * src2(is ,js-3,ks) - $ + f5*f1 * src2(is+1,js-3,ks) - $ + f6*f1 * src2(is+2,js-3,ks) - $ + f7*f1 * src2(is+3,js-3,ks) - $ + f8*f1 * src2(is+4,js-3,ks) - $ + f1*f2 * src2(is-3,js-2,ks) - $ + f2*f2 * src2(is-2,js-2,ks) - $ + f3*f2 * src2(is-1,js-2,ks) - $ + f4*f2 * src2(is ,js-2,ks) - $ + f5*f2 * src2(is+1,js-2,ks) - $ + f6*f2 * src2(is+2,js-2,ks) - $ + f7*f2 * src2(is+3,js-2,ks) - $ + f8*f2 * src2(is+4,js-2,ks) - $ + f1*f3 * src2(is-3,js-1,ks) - $ + f2*f3 * src2(is-2,js-1,ks) - $ + f3*f3 * src2(is-1,js-1,ks) - $ + f4*f3 * src2(is ,js-1,ks) - $ + f5*f3 * src2(is+1,js-1,ks) - $ + f6*f3 * src2(is+2,js-1,ks) - $ + f7*f3 * src2(is+3,js-1,ks) - $ + f8*f3 * src2(is+4,js-1,ks) - $ + f1*f4 * src2(is-3,js ,ks) - $ + f2*f4 * src2(is-2,js ,ks) - $ + f3*f4 * src2(is-1,js ,ks) - $ + f4*f4 * src2(is ,js ,ks) - $ + f5*f4 * src2(is+1,js ,ks) - $ + f6*f4 * src2(is+2,js ,ks) - $ + f7*f4 * src2(is+3,js ,ks) - $ + f8*f4 * src2(is+4,js ,ks) - $ + f1*f5 * src2(is-3,js+1,ks) - $ + f2*f5 * src2(is-2,js+1,ks) - $ + f3*f5 * src2(is-1,js+1,ks) - $ + f4*f5 * src2(is ,js+1,ks) - $ + f5*f5 * src2(is+1,js+1,ks) - $ + f6*f5 * src2(is+2,js+1,ks) - $ + f7*f5 * src2(is+3,js+1,ks) - $ + f8*f5 * src2(is+4,js+1,ks) - $ + f1*f6 * src2(is-3,js+2,ks) - $ + f2*f6 * src2(is-2,js+2,ks) - $ + f3*f6 * src2(is-1,js+2,ks) - $ + f4*f6 * src2(is ,js+2,ks) - $ + f5*f6 * src2(is+1,js+2,ks) - $ + f6*f6 * src2(is+2,js+2,ks) - $ + f7*f6 * src2(is+3,js+2,ks) - $ + f8*f6 * src2(is+4,js+2,ks) - $ + f1*f7 * src2(is-3,js+3,ks) - $ + f2*f7 * src2(is-2,js+3,ks) - $ + f3*f7 * src2(is-1,js+3,ks) - $ + f4*f7 * src2(is ,js+3,ks) - $ + f5*f7 * src2(is+1,js+3,ks) - $ + f6*f7 * src2(is+2,js+3,ks) - $ + f7*f7 * src2(is+3,js+3,ks) - $ + f8*f7 * src2(is+4,js+3,ks) - $ + f1*f8 * src2(is-3,js+4,ks) - $ + f2*f8 * src2(is-2,js+4,ks) - $ + f3*f8 * src2(is-1,js+4,ks) - $ + f4*f8 * src2(is ,js+4,ks) - $ + f5*f8 * src2(is+1,js+4,ks) - $ + f6*f8 * src2(is+2,js+4,ks) - $ + f7*f8 * src2(is+3,js+4,ks) - $ + f8*f8 * src2(is+4,js+4,ks) - dst(id,jd,kd) = s1fac * res1 + s2fac * res2 - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8010 - goto 901 - -c end i loop - 901 continue - j = j+1 - jd = jd+1 - js = js+1 - if (j.lt.regjext) goto 800 - goto 90 - -c end j loop - 90 continue - k = k+1 - kd = kd+1 - if (k.lt.regkext) goto 81 - goto 9 - -c begin j loop - 81 continue - j = 0 - js = j0+1 - jd = dstjoff+1 - if (fj.eq.0) goto 810 - if (fj.eq.1) goto 811 - stop - -c begin i loop - 810 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8100 - if (fi.eq.1) goto 8101 - stop - -c kernel - 8100 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js,ks-3, 1,1,8, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + f1 * s1fac * src1(is,js,ks-3) - $ + f2 * s1fac * src1(is,js,ks-2) - $ + f3 * s1fac * src1(is,js,ks-1) - $ + f4 * s1fac * src1(is,js,ks ) - $ + f5 * s1fac * src1(is,js,ks+1) - $ + f6 * s1fac * src1(is,js,ks+2) - $ + f7 * s1fac * src1(is,js,ks+3) - $ + f8 * s1fac * src1(is,js,ks+4) - $ + f1 * s2fac * src2(is,js,ks-3) - $ + f2 * s2fac * src2(is,js,ks-2) - $ + f3 * s2fac * src2(is,js,ks-1) - $ + f4 * s2fac * src2(is,js,ks ) - $ + f5 * s2fac * src2(is,js,ks+1) - $ + f6 * s2fac * src2(is,js,ks+2) - $ + f7 * s2fac * src2(is,js,ks+3) - $ + f8 * s2fac * src2(is,js,ks+4) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8101 - goto 910 - -c kernel - 8101 continue - if (check_array_accesses.ne.0) then - call checkindex (is-3,js,ks-3, 8,1,8, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - res1 = - $ + f1*f1 * src1(is-3,js,ks-3) - $ + f2*f1 * src1(is-2,js,ks-3) - $ + f3*f1 * src1(is-1,js,ks-3) - $ + f4*f1 * src1(is ,js,ks-3) - $ + f5*f1 * src1(is+1,js,ks-3) - $ + f6*f1 * src1(is+2,js,ks-3) - $ + f7*f1 * src1(is+3,js,ks-3) - $ + f8*f1 * src1(is+4,js,ks-3) - $ + f1*f2 * src1(is-3,js,ks-2) - $ + f2*f2 * src1(is-2,js,ks-2) - $ + f3*f2 * src1(is-1,js,ks-2) - $ + f4*f2 * src1(is ,js,ks-2) - $ + f5*f2 * src1(is+1,js,ks-2) - $ + f6*f2 * src1(is+2,js,ks-2) - $ + f7*f2 * src1(is+3,js,ks-2) - $ + f8*f2 * src1(is+4,js,ks-2) - $ + f1*f3 * src1(is-3,js,ks-1) - $ + f2*f3 * src1(is-2,js,ks-1) - $ + f3*f3 * src1(is-1,js,ks-1) - $ + f4*f3 * src1(is ,js,ks-1) - $ + f5*f3 * src1(is+1,js,ks-1) - $ + f6*f3 * src1(is+2,js,ks-1) - $ + f7*f3 * src1(is+3,js,ks-1) - $ + f8*f3 * src1(is+4,js,ks-1) - $ + f1*f4 * src1(is-3,js,ks ) - $ + f2*f4 * src1(is-2,js,ks ) - $ + f3*f4 * src1(is-1,js,ks ) - $ + f4*f4 * src1(is ,js,ks ) - $ + f5*f4 * src1(is+1,js,ks ) - $ + f6*f4 * src1(is+2,js,ks ) - $ + f7*f4 * src1(is+3,js,ks ) - $ + f8*f4 * src1(is+4,js,ks ) - $ + f1*f5 * src1(is-3,js,ks+1) - $ + f2*f5 * src1(is-2,js,ks+1) - $ + f3*f5 * src1(is-1,js,ks+1) - $ + f4*f5 * src1(is ,js,ks+1) - $ + f5*f5 * src1(is+1,js,ks+1) - $ + f6*f5 * src1(is+2,js,ks+1) - $ + f7*f5 * src1(is+3,js,ks+1) - $ + f8*f5 * src1(is+4,js,ks+1) - $ + f1*f6 * src1(is-3,js,ks+2) - $ + f2*f6 * src1(is-2,js,ks+2) - $ + f3*f6 * src1(is-1,js,ks+2) - $ + f4*f6 * src1(is ,js,ks+2) - $ + f5*f6 * src1(is+1,js,ks+2) - $ + f6*f6 * src1(is+2,js,ks+2) - $ + f7*f6 * src1(is+3,js,ks+2) - $ + f8*f6 * src1(is+4,js,ks+2) - $ + f1*f7 * src1(is-3,js,ks+3) - $ + f2*f7 * src1(is-2,js,ks+3) - $ + f3*f7 * src1(is-1,js,ks+3) - $ + f4*f7 * src1(is ,js,ks+3) - $ + f5*f7 * src1(is+1,js,ks+3) - $ + f6*f7 * src1(is+2,js,ks+3) - $ + f7*f7 * src1(is+3,js,ks+3) - $ + f8*f7 * src1(is+4,js,ks+3) - $ + f1*f8 * src1(is-3,js,ks+4) - $ + f2*f8 * src1(is-2,js,ks+4) - $ + f3*f8 * src1(is-1,js,ks+4) - $ + f4*f8 * src1(is ,js,ks+4) - $ + f5*f8 * src1(is+1,js,ks+4) - $ + f6*f8 * src1(is+2,js,ks+4) - $ + f7*f8 * src1(is+3,js,ks+4) - $ + f8*f8 * src1(is+4,js,ks+4) - res2 = - $ + f1*f1 * src2(is-3,js,ks-3) - $ + f2*f1 * src2(is-2,js,ks-3) - $ + f3*f1 * src2(is-1,js,ks-3) - $ + f4*f1 * src2(is ,js,ks-3) - $ + f5*f1 * src2(is+1,js,ks-3) - $ + f6*f1 * src2(is+2,js,ks-3) - $ + f7*f1 * src2(is+3,js,ks-3) - $ + f8*f1 * src2(is+4,js,ks-3) - $ + f1*f2 * src2(is-3,js,ks-2) - $ + f2*f2 * src2(is-2,js,ks-2) - $ + f3*f2 * src2(is-1,js,ks-2) - $ + f4*f2 * src2(is ,js,ks-2) - $ + f5*f2 * src2(is+1,js,ks-2) - $ + f6*f2 * src2(is+2,js,ks-2) - $ + f7*f2 * src2(is+3,js,ks-2) - $ + f8*f2 * src2(is+4,js,ks-2) - $ + f1*f3 * src2(is-3,js,ks-1) - $ + f2*f3 * src2(is-2,js,ks-1) - $ + f3*f3 * src2(is-1,js,ks-1) - $ + f4*f3 * src2(is ,js,ks-1) - $ + f5*f3 * src2(is+1,js,ks-1) - $ + f6*f3 * src2(is+2,js,ks-1) - $ + f7*f3 * src2(is+3,js,ks-1) - $ + f8*f3 * src2(is+4,js,ks-1) - $ + f1*f4 * src2(is-3,js,ks ) - $ + f2*f4 * src2(is-2,js,ks ) - $ + f3*f4 * src2(is-1,js,ks ) - $ + f4*f4 * src2(is ,js,ks ) - $ + f5*f4 * src2(is+1,js,ks ) - $ + f6*f4 * src2(is+2,js,ks ) - $ + f7*f4 * src2(is+3,js,ks ) - $ + f8*f4 * src2(is+4,js,ks ) - $ + f1*f5 * src2(is-3,js,ks+1) - $ + f2*f5 * src2(is-2,js,ks+1) - $ + f3*f5 * src2(is-1,js,ks+1) - $ + f4*f5 * src2(is ,js,ks+1) - $ + f5*f5 * src2(is+1,js,ks+1) - $ + f6*f5 * src2(is+2,js,ks+1) - $ + f7*f5 * src2(is+3,js,ks+1) - $ + f8*f5 * src2(is+4,js,ks+1) - $ + f1*f6 * src2(is-3,js,ks+2) - $ + f2*f6 * src2(is-2,js,ks+2) - $ + f3*f6 * src2(is-1,js,ks+2) - $ + f4*f6 * src2(is ,js,ks+2) - $ + f5*f6 * src2(is+1,js,ks+2) - $ + f6*f6 * src2(is+2,js,ks+2) - $ + f7*f6 * src2(is+3,js,ks+2) - $ + f8*f6 * src2(is+4,js,ks+2) - $ + f1*f7 * src2(is-3,js,ks+3) - $ + f2*f7 * src2(is-2,js,ks+3) - $ + f3*f7 * src2(is-1,js,ks+3) - $ + f4*f7 * src2(is ,js,ks+3) - $ + f5*f7 * src2(is+1,js,ks+3) - $ + f6*f7 * src2(is+2,js,ks+3) - $ + f7*f7 * src2(is+3,js,ks+3) - $ + f8*f7 * src2(is+4,js,ks+3) - $ + f1*f8 * src2(is-3,js,ks+4) - $ + f2*f8 * src2(is-2,js,ks+4) - $ + f3*f8 * src2(is-1,js,ks+4) - $ + f4*f8 * src2(is ,js,ks+4) - $ + f5*f8 * src2(is+1,js,ks+4) - $ + f6*f8 * src2(is+2,js,ks+4) - $ + f7*f8 * src2(is+3,js,ks+4) - $ + f8*f8 * src2(is+4,js,ks+4) - dst(id,jd,kd) = s1fac * res1 + s2fac * res2 - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8100 - goto 910 - -c end i loop - 910 continue - j = j+1 - jd = jd+1 - if (j.lt.regjext) goto 811 - goto 91 - -c begin i loop - 811 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8110 - if (fi.eq.1) goto 8111 - stop - -c kernel - 8110 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js-3,ks-3, 1,8,8, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - res1 = - $ + f1*f1 * src1(is,js-3,ks-3) - $ + f2*f1 * src1(is,js-2,ks-3) - $ + f3*f1 * src1(is,js-1,ks-3) - $ + f4*f1 * src1(is,js ,ks-3) - $ + f5*f1 * src1(is,js+1,ks-3) - $ + f6*f1 * src1(is,js+2,ks-3) - $ + f7*f1 * src1(is,js+3,ks-3) - $ + f8*f1 * src1(is,js+4,ks-3) - $ + f1*f2 * src1(is,js-3,ks-2) - $ + f2*f2 * src1(is,js-2,ks-2) - $ + f3*f2 * src1(is,js-1,ks-2) - $ + f4*f2 * src1(is,js ,ks-2) - $ + f5*f2 * src1(is,js+1,ks-2) - $ + f6*f2 * src1(is,js+2,ks-2) - $ + f7*f2 * src1(is,js+3,ks-2) - $ + f8*f2 * src1(is,js+4,ks-2) - $ + f1*f3 * src1(is,js-3,ks-1) - $ + f2*f3 * src1(is,js-2,ks-1) - $ + f3*f3 * src1(is,js-1,ks-1) - $ + f4*f3 * src1(is,js ,ks-1) - $ + f5*f3 * src1(is,js+1,ks-1) - $ + f6*f3 * src1(is,js+2,ks-1) - $ + f7*f3 * src1(is,js+3,ks-1) - $ + f8*f3 * src1(is,js+4,ks-1) - $ + f1*f4 * src1(is,js-3,ks ) - $ + f2*f4 * src1(is,js-2,ks ) - $ + f3*f4 * src1(is,js-1,ks ) - $ + f4*f4 * src1(is,js ,ks ) - $ + f5*f4 * src1(is,js+1,ks ) - $ + f6*f4 * src1(is,js+2,ks ) - $ + f7*f4 * src1(is,js+3,ks ) - $ + f8*f4 * src1(is,js+4,ks ) - $ + f1*f5 * src1(is,js-3,ks+1) - $ + f2*f5 * src1(is,js-2,ks+1) - $ + f3*f5 * src1(is,js-1,ks+1) - $ + f4*f5 * src1(is,js ,ks+1) - $ + f5*f5 * src1(is,js+1,ks+1) - $ + f6*f5 * src1(is,js+2,ks+1) - $ + f7*f5 * src1(is,js+3,ks+1) - $ + f8*f5 * src1(is,js+4,ks+1) - $ + f1*f6 * src1(is,js-3,ks+2) - $ + f2*f6 * src1(is,js-2,ks+2) - $ + f3*f6 * src1(is,js-1,ks+2) - $ + f4*f6 * src1(is,js ,ks+2) - $ + f5*f6 * src1(is,js+1,ks+2) - $ + f6*f6 * src1(is,js+2,ks+2) - $ + f7*f6 * src1(is,js+3,ks+2) - $ + f8*f6 * src1(is,js+4,ks+2) - $ + f1*f7 * src1(is,js-3,ks+3) - $ + f2*f7 * src1(is,js-2,ks+3) - $ + f3*f7 * src1(is,js-1,ks+3) - $ + f4*f7 * src1(is,js ,ks+3) - $ + f5*f7 * src1(is,js+1,ks+3) - $ + f6*f7 * src1(is,js+2,ks+3) - $ + f7*f7 * src1(is,js+3,ks+3) - $ + f8*f7 * src1(is,js+4,ks+3) - $ + f1*f8 * src1(is,js-3,ks+4) - $ + f2*f8 * src1(is,js-2,ks+4) - $ + f3*f8 * src1(is,js-1,ks+4) - $ + f4*f8 * src1(is,js ,ks+4) - $ + f5*f8 * src1(is,js+1,ks+4) - $ + f6*f8 * src1(is,js+2,ks+4) - $ + f7*f8 * src1(is,js+3,ks+4) - $ + f8*f8 * src1(is,js+4,ks+4) - res2 = - $ + f1*f1 * src2(is,js-3,ks-3) - $ + f2*f1 * src2(is,js-2,ks-3) - $ + f3*f1 * src2(is,js-1,ks-3) - $ + f4*f1 * src2(is,js ,ks-3) - $ + f5*f1 * src2(is,js+1,ks-3) - $ + f6*f1 * src2(is,js+2,ks-3) - $ + f7*f1 * src2(is,js+3,ks-3) - $ + f8*f1 * src2(is,js+4,ks-3) - $ + f1*f2 * src2(is,js-3,ks-2) - $ + f2*f2 * src2(is,js-2,ks-2) - $ + f3*f2 * src2(is,js-1,ks-2) - $ + f4*f2 * src2(is,js ,ks-2) - $ + f5*f2 * src2(is,js+1,ks-2) - $ + f6*f2 * src2(is,js+2,ks-2) - $ + f7*f2 * src2(is,js+3,ks-2) - $ + f8*f2 * src2(is,js+4,ks-2) - $ + f1*f3 * src2(is,js-3,ks-1) - $ + f2*f3 * src2(is,js-2,ks-1) - $ + f3*f3 * src2(is,js-1,ks-1) - $ + f4*f3 * src2(is,js ,ks-1) - $ + f5*f3 * src2(is,js+1,ks-1) - $ + f6*f3 * src2(is,js+2,ks-1) - $ + f7*f3 * src2(is,js+3,ks-1) - $ + f8*f3 * src2(is,js+4,ks-1) - $ + f1*f4 * src2(is,js-3,ks ) - $ + f2*f4 * src2(is,js-2,ks ) - $ + f3*f4 * src2(is,js-1,ks ) - $ + f4*f4 * src2(is,js ,ks ) - $ + f5*f4 * src2(is,js+1,ks ) - $ + f6*f4 * src2(is,js+2,ks ) - $ + f7*f4 * src2(is,js+3,ks ) - $ + f8*f4 * src2(is,js+4,ks ) - $ + f1*f5 * src2(is,js-3,ks+1) - $ + f2*f5 * src2(is,js-2,ks+1) - $ + f3*f5 * src2(is,js-1,ks+1) - $ + f4*f5 * src2(is,js ,ks+1) - $ + f5*f5 * src2(is,js+1,ks+1) - $ + f6*f5 * src2(is,js+2,ks+1) - $ + f7*f5 * src2(is,js+3,ks+1) - $ + f8*f5 * src2(is,js+4,ks+1) - $ + f1*f6 * src2(is,js-3,ks+2) - $ + f2*f6 * src2(is,js-2,ks+2) - $ + f3*f6 * src2(is,js-1,ks+2) - $ + f4*f6 * src2(is,js ,ks+2) - $ + f5*f6 * src2(is,js+1,ks+2) - $ + f6*f6 * src2(is,js+2,ks+2) - $ + f7*f6 * src2(is,js+3,ks+2) - $ + f8*f6 * src2(is,js+4,ks+2) - $ + f1*f7 * src2(is,js-3,ks+3) - $ + f2*f7 * src2(is,js-2,ks+3) - $ + f3*f7 * src2(is,js-1,ks+3) - $ + f4*f7 * src2(is,js ,ks+3) - $ + f5*f7 * src2(is,js+1,ks+3) - $ + f6*f7 * src2(is,js+2,ks+3) - $ + f7*f7 * src2(is,js+3,ks+3) - $ + f8*f7 * src2(is,js+4,ks+3) - $ + f1*f8 * src2(is,js-3,ks+4) - $ + f2*f8 * src2(is,js-2,ks+4) - $ + f3*f8 * src2(is,js-1,ks+4) - $ + f4*f8 * src2(is,js ,ks+4) - $ + f5*f8 * src2(is,js+1,ks+4) - $ + f6*f8 * src2(is,js+2,ks+4) - $ + f7*f8 * src2(is,js+3,ks+4) - $ + f8*f8 * src2(is,js+4,ks+4) - dst(id,jd,kd) = s1fac * res1 + s2fac * res2 - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8111 - goto 911 - -c kernel - 8111 continue - if (check_array_accesses.ne.0) then - call checkindex (is-3,js-3,ks-3, 8,8,8, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - res11 = - $ + f1*f1*f1 * src1(is-3,js-3,ks-3) - $ + f2*f1*f1 * src1(is-2,js-3,ks-3) - $ + f3*f1*f1 * src1(is-1,js-3,ks-3) - $ + f4*f1*f1 * src1(is ,js-3,ks-3) - $ + f5*f1*f1 * src1(is+1,js-3,ks-3) - $ + f6*f1*f1 * src1(is+2,js-3,ks-3) - $ + f7*f1*f1 * src1(is+3,js-3,ks-3) - $ + f8*f1*f1 * src1(is+4,js-3,ks-3) - $ + f1*f2*f1 * src1(is-3,js-2,ks-3) - $ + f2*f2*f1 * src1(is-2,js-2,ks-3) - $ + f3*f2*f1 * src1(is-1,js-2,ks-3) - $ + f4*f2*f1 * src1(is ,js-2,ks-3) - $ + f5*f2*f1 * src1(is+1,js-2,ks-3) - $ + f6*f2*f1 * src1(is+2,js-2,ks-3) - $ + f7*f2*f1 * src1(is+3,js-2,ks-3) - $ + f8*f2*f1 * src1(is+4,js-2,ks-3) - $ + f1*f3*f1 * src1(is-3,js-1,ks-3) - $ + f2*f3*f1 * src1(is-2,js-1,ks-3) - $ + f3*f3*f1 * src1(is-1,js-1,ks-3) - $ + f4*f3*f1 * src1(is ,js-1,ks-3) - $ + f5*f3*f1 * src1(is+1,js-1,ks-3) - $ + f6*f3*f1 * src1(is+2,js-1,ks-3) - $ + f7*f3*f1 * src1(is+3,js-1,ks-3) - $ + f8*f3*f1 * src1(is+4,js-1,ks-3) - $ + f1*f4*f1 * src1(is-3,js ,ks-3) - $ + f2*f4*f1 * src1(is-2,js ,ks-3) - $ + f3*f4*f1 * src1(is-1,js ,ks-3) - $ + f4*f4*f1 * src1(is ,js ,ks-3) - $ + f5*f4*f1 * src1(is+1,js ,ks-3) - $ + f6*f4*f1 * src1(is+2,js ,ks-3) - $ + f7*f4*f1 * src1(is+3,js ,ks-3) - $ + f8*f4*f1 * src1(is+4,js ,ks-3) - $ + f1*f5*f1 * src1(is-3,js+1,ks-3) - $ + f2*f5*f1 * src1(is-2,js+1,ks-3) - $ + f3*f5*f1 * src1(is-1,js+1,ks-3) - $ + f4*f5*f1 * src1(is ,js+1,ks-3) - $ + f5*f5*f1 * src1(is+1,js+1,ks-3) - $ + f6*f5*f1 * src1(is+2,js+1,ks-3) - $ + f7*f5*f1 * src1(is+3,js+1,ks-3) - $ + f8*f5*f1 * src1(is+4,js+1,ks-3) - $ + f1*f6*f1 * src1(is-3,js+2,ks-3) - $ + f2*f6*f1 * src1(is-2,js+2,ks-3) - $ + f3*f6*f1 * src1(is-1,js+2,ks-3) - $ + f4*f6*f1 * src1(is ,js+2,ks-3) - $ + f5*f6*f1 * src1(is+1,js+2,ks-3) - $ + f6*f6*f1 * src1(is+2,js+2,ks-3) - $ + f7*f6*f1 * src1(is+3,js+2,ks-3) - $ + f8*f6*f1 * src1(is+4,js+2,ks-3) - $ + f1*f7*f1 * src1(is-3,js+3,ks-3) - $ + f2*f7*f1 * src1(is-2,js+3,ks-3) - $ + f3*f7*f1 * src1(is-1,js+3,ks-3) - $ + f4*f7*f1 * src1(is ,js+3,ks-3) - $ + f5*f7*f1 * src1(is+1,js+3,ks-3) - $ + f6*f7*f1 * src1(is+2,js+3,ks-3) - $ + f7*f7*f1 * src1(is+3,js+3,ks-3) - $ + f8*f7*f1 * src1(is+4,js+3,ks-3) - $ + f1*f8*f1 * src1(is-3,js+4,ks-3) - $ + f2*f8*f1 * src1(is-2,js+4,ks-3) - $ + f3*f8*f1 * src1(is-1,js+4,ks-3) - $ + f4*f8*f1 * src1(is ,js+4,ks-3) - $ + f5*f8*f1 * src1(is+1,js+4,ks-3) - $ + f6*f8*f1 * src1(is+2,js+4,ks-3) - $ + f7*f8*f1 * src1(is+3,js+4,ks-3) - $ + f8*f8*f1 * src1(is+4,js+4,ks-3) - res12 = - $ + f1*f1*f2 * src1(is-3,js-3,ks-2) - $ + f2*f1*f2 * src1(is-2,js-3,ks-2) - $ + f3*f1*f2 * src1(is-1,js-3,ks-2) - $ + f4*f1*f2 * src1(is ,js-3,ks-2) - $ + f5*f1*f2 * src1(is+1,js-3,ks-2) - $ + f6*f1*f2 * src1(is+2,js-3,ks-2) - $ + f7*f1*f2 * src1(is+3,js-3,ks-2) - $ + f8*f1*f2 * src1(is+4,js-3,ks-2) - $ + f1*f2*f2 * src1(is-3,js-2,ks-2) - $ + f2*f2*f2 * src1(is-2,js-2,ks-2) - $ + f3*f2*f2 * src1(is-1,js-2,ks-2) - $ + f4*f2*f2 * src1(is ,js-2,ks-2) - $ + f5*f2*f2 * src1(is+1,js-2,ks-2) - $ + f6*f2*f2 * src1(is+2,js-2,ks-2) - $ + f7*f2*f2 * src1(is+3,js-2,ks-2) - $ + f8*f2*f2 * src1(is+4,js-2,ks-2) - $ + f1*f3*f2 * src1(is-3,js-1,ks-2) - $ + f2*f3*f2 * src1(is-2,js-1,ks-2) - $ + f3*f3*f2 * src1(is-1,js-1,ks-2) - $ + f4*f3*f2 * src1(is ,js-1,ks-2) - $ + f5*f3*f2 * src1(is+1,js-1,ks-2) - $ + f6*f3*f2 * src1(is+2,js-1,ks-2) - $ + f7*f3*f2 * src1(is+3,js-1,ks-2) - $ + f8*f3*f2 * src1(is+4,js-1,ks-2) - $ + f1*f4*f2 * src1(is-3,js ,ks-2) - $ + f2*f4*f2 * src1(is-2,js ,ks-2) - $ + f3*f4*f2 * src1(is-1,js ,ks-2) - $ + f4*f4*f2 * src1(is ,js ,ks-2) - $ + f5*f4*f2 * src1(is+1,js ,ks-2) - $ + f6*f4*f2 * src1(is+2,js ,ks-2) - $ + f7*f4*f2 * src1(is+3,js ,ks-2) - $ + f8*f4*f2 * src1(is+4,js ,ks-2) - $ + f1*f5*f2 * src1(is-3,js+1,ks-2) - $ + f2*f5*f2 * src1(is-2,js+1,ks-2) - $ + f3*f5*f2 * src1(is-1,js+1,ks-2) - $ + f4*f5*f2 * src1(is ,js+1,ks-2) - $ + f5*f5*f2 * src1(is+1,js+1,ks-2) - $ + f6*f5*f2 * src1(is+2,js+1,ks-2) - $ + f7*f5*f2 * src1(is+3,js+1,ks-2) - $ + f8*f5*f2 * src1(is+4,js+1,ks-2) - $ + f1*f6*f2 * src1(is-3,js+2,ks-2) - $ + f2*f6*f2 * src1(is-2,js+2,ks-2) - $ + f3*f6*f2 * src1(is-1,js+2,ks-2) - $ + f4*f6*f2 * src1(is ,js+2,ks-2) - $ + f5*f6*f2 * src1(is+1,js+2,ks-2) - $ + f6*f6*f2 * src1(is+2,js+2,ks-2) - $ + f7*f6*f2 * src1(is+3,js+2,ks-2) - $ + f8*f6*f2 * src1(is+4,js+2,ks-2) - $ + f1*f7*f2 * src1(is-3,js+3,ks-2) - $ + f2*f7*f2 * src1(is-2,js+3,ks-2) - $ + f3*f7*f2 * src1(is-1,js+3,ks-2) - $ + f4*f7*f2 * src1(is ,js+3,ks-2) - $ + f5*f7*f2 * src1(is+1,js+3,ks-2) - $ + f6*f7*f2 * src1(is+2,js+3,ks-2) - $ + f7*f7*f2 * src1(is+3,js+3,ks-2) - $ + f8*f7*f2 * src1(is+4,js+3,ks-2) - $ + f1*f8*f2 * src1(is-3,js+4,ks-2) - $ + f2*f8*f2 * src1(is-2,js+4,ks-2) - $ + f3*f8*f2 * src1(is-1,js+4,ks-2) - $ + f4*f8*f2 * src1(is ,js+4,ks-2) - $ + f5*f8*f2 * src1(is+1,js+4,ks-2) - $ + f6*f8*f2 * src1(is+2,js+4,ks-2) - $ + f7*f8*f2 * src1(is+3,js+4,ks-2) - $ + f8*f8*f2 * src1(is+4,js+4,ks-2) - res13 = - $ + f1*f1*f3 * src1(is-3,js-3,ks-1) - $ + f2*f1*f3 * src1(is-2,js-3,ks-1) - $ + f3*f1*f3 * src1(is-1,js-3,ks-1) - $ + f4*f1*f3 * src1(is ,js-3,ks-1) - $ + f5*f1*f3 * src1(is+1,js-3,ks-1) - $ + f6*f1*f3 * src1(is+2,js-3,ks-1) - $ + f7*f1*f3 * src1(is+3,js-3,ks-1) - $ + f8*f1*f3 * src1(is+4,js-3,ks-1) - $ + f1*f2*f3 * src1(is-3,js-2,ks-1) - $ + f2*f2*f3 * src1(is-2,js-2,ks-1) - $ + f3*f2*f3 * src1(is-1,js-2,ks-1) - $ + f4*f2*f3 * src1(is ,js-2,ks-1) - $ + f5*f2*f3 * src1(is+1,js-2,ks-1) - $ + f6*f2*f3 * src1(is+2,js-2,ks-1) - $ + f7*f2*f3 * src1(is+3,js-2,ks-1) - $ + f8*f2*f3 * src1(is+4,js-2,ks-1) - $ + f1*f3*f3 * src1(is-3,js-1,ks-1) - $ + f2*f3*f3 * src1(is-2,js-1,ks-1) - $ + f3*f3*f3 * src1(is-1,js-1,ks-1) - $ + f4*f3*f3 * src1(is ,js-1,ks-1) - $ + f5*f3*f3 * src1(is+1,js-1,ks-1) - $ + f6*f3*f3 * src1(is+2,js-1,ks-1) - $ + f7*f3*f3 * src1(is+3,js-1,ks-1) - $ + f8*f3*f3 * src1(is+4,js-1,ks-1) - $ + f1*f4*f3 * src1(is-3,js ,ks-1) - $ + f2*f4*f3 * src1(is-2,js ,ks-1) - $ + f3*f4*f3 * src1(is-1,js ,ks-1) - $ + f4*f4*f3 * src1(is ,js ,ks-1) - $ + f5*f4*f3 * src1(is+1,js ,ks-1) - $ + f6*f4*f3 * src1(is+2,js ,ks-1) - $ + f7*f4*f3 * src1(is+3,js ,ks-1) - $ + f8*f4*f3 * src1(is+4,js ,ks-1) - $ + f1*f5*f3 * src1(is-3,js+1,ks-1) - $ + f2*f5*f3 * src1(is-2,js+1,ks-1) - $ + f3*f5*f3 * src1(is-1,js+1,ks-1) - $ + f4*f5*f3 * src1(is ,js+1,ks-1) - $ + f5*f5*f3 * src1(is+1,js+1,ks-1) - $ + f6*f5*f3 * src1(is+2,js+1,ks-1) - $ + f7*f5*f3 * src1(is+3,js+1,ks-1) - $ + f8*f5*f3 * src1(is+4,js+1,ks-1) - $ + f1*f6*f3 * src1(is-3,js+2,ks-1) - $ + f2*f6*f3 * src1(is-2,js+2,ks-1) - $ + f3*f6*f3 * src1(is-1,js+2,ks-1) - $ + f4*f6*f3 * src1(is ,js+2,ks-1) - $ + f5*f6*f3 * src1(is+1,js+2,ks-1) - $ + f6*f6*f3 * src1(is+2,js+2,ks-1) - $ + f7*f6*f3 * src1(is+3,js+2,ks-1) - $ + f8*f6*f3 * src1(is+4,js+2,ks-1) - $ + f1*f7*f3 * src1(is-3,js+3,ks-1) - $ + f2*f7*f3 * src1(is-2,js+3,ks-1) - $ + f3*f7*f3 * src1(is-1,js+3,ks-1) - $ + f4*f7*f3 * src1(is ,js+3,ks-1) - $ + f5*f7*f3 * src1(is+1,js+3,ks-1) - $ + f6*f7*f3 * src1(is+2,js+3,ks-1) - $ + f7*f7*f3 * src1(is+3,js+3,ks-1) - $ + f8*f7*f3 * src1(is+4,js+3,ks-1) - $ + f1*f8*f3 * src1(is-3,js+4,ks-1) - $ + f2*f8*f3 * src1(is-2,js+4,ks-1) - $ + f3*f8*f3 * src1(is-1,js+4,ks-1) - $ + f4*f8*f3 * src1(is ,js+4,ks-1) - $ + f5*f8*f3 * src1(is+1,js+4,ks-1) - $ + f6*f8*f3 * src1(is+2,js+4,ks-1) - $ + f7*f8*f3 * src1(is+3,js+4,ks-1) - $ + f8*f8*f3 * src1(is+4,js+4,ks-1) - res14 = - $ + f1*f1*f4 * src1(is-3,js-3,ks ) - $ + f2*f1*f4 * src1(is-2,js-3,ks ) - $ + f3*f1*f4 * src1(is-1,js-3,ks ) - $ + f4*f1*f4 * src1(is ,js-3,ks ) - $ + f5*f1*f4 * src1(is+1,js-3,ks ) - $ + f6*f1*f4 * src1(is+2,js-3,ks ) - $ + f7*f1*f4 * src1(is+3,js-3,ks ) - $ + f8*f1*f4 * src1(is+4,js-3,ks ) - $ + f1*f2*f4 * src1(is-3,js-2,ks ) - $ + f2*f2*f4 * src1(is-2,js-2,ks ) - $ + f3*f2*f4 * src1(is-1,js-2,ks ) - $ + f4*f2*f4 * src1(is ,js-2,ks ) - $ + f5*f2*f4 * src1(is+1,js-2,ks ) - $ + f6*f2*f4 * src1(is+2,js-2,ks ) - $ + f7*f2*f4 * src1(is+3,js-2,ks ) - $ + f8*f2*f4 * src1(is+4,js-2,ks ) - $ + f1*f3*f4 * src1(is-3,js-1,ks ) - $ + f2*f3*f4 * src1(is-2,js-1,ks ) - $ + f3*f3*f4 * src1(is-1,js-1,ks ) - $ + f4*f3*f4 * src1(is ,js-1,ks ) - $ + f5*f3*f4 * src1(is+1,js-1,ks ) - $ + f6*f3*f4 * src1(is+2,js-1,ks ) - $ + f7*f3*f4 * src1(is+3,js-1,ks ) - $ + f8*f3*f4 * src1(is+4,js-1,ks ) - $ + f1*f4*f4 * src1(is-3,js ,ks ) - $ + f2*f4*f4 * src1(is-2,js ,ks ) - $ + f3*f4*f4 * src1(is-1,js ,ks ) - $ + f4*f4*f4 * src1(is ,js ,ks ) - $ + f5*f4*f4 * src1(is+1,js ,ks ) - $ + f6*f4*f4 * src1(is+2,js ,ks ) - $ + f7*f4*f4 * src1(is+3,js ,ks ) - $ + f8*f4*f4 * src1(is+4,js ,ks ) - $ + f1*f5*f4 * src1(is-3,js+1,ks ) - $ + f2*f5*f4 * src1(is-2,js+1,ks ) - $ + f3*f5*f4 * src1(is-1,js+1,ks ) - $ + f4*f5*f4 * src1(is ,js+1,ks ) - $ + f5*f5*f4 * src1(is+1,js+1,ks ) - $ + f6*f5*f4 * src1(is+2,js+1,ks ) - $ + f7*f5*f4 * src1(is+3,js+1,ks ) - $ + f8*f5*f4 * src1(is+4,js+1,ks ) - $ + f1*f6*f4 * src1(is-3,js+2,ks ) - $ + f2*f6*f4 * src1(is-2,js+2,ks ) - $ + f3*f6*f4 * src1(is-1,js+2,ks ) - $ + f4*f6*f4 * src1(is ,js+2,ks ) - $ + f5*f6*f4 * src1(is+1,js+2,ks ) - $ + f6*f6*f4 * src1(is+2,js+2,ks ) - $ + f7*f6*f4 * src1(is+3,js+2,ks ) - $ + f8*f6*f4 * src1(is+4,js+2,ks ) - $ + f1*f7*f4 * src1(is-3,js+3,ks ) - $ + f2*f7*f4 * src1(is-2,js+3,ks ) - $ + f3*f7*f4 * src1(is-1,js+3,ks ) - $ + f4*f7*f4 * src1(is ,js+3,ks ) - $ + f5*f7*f4 * src1(is+1,js+3,ks ) - $ + f6*f7*f4 * src1(is+2,js+3,ks ) - $ + f7*f7*f4 * src1(is+3,js+3,ks ) - $ + f8*f7*f4 * src1(is+4,js+3,ks ) - $ + f1*f8*f4 * src1(is-3,js+4,ks ) - $ + f2*f8*f4 * src1(is-2,js+4,ks ) - $ + f3*f8*f4 * src1(is-1,js+4,ks ) - $ + f4*f8*f4 * src1(is ,js+4,ks ) - $ + f5*f8*f4 * src1(is+1,js+4,ks ) - $ + f6*f8*f4 * src1(is+2,js+4,ks ) - $ + f7*f8*f4 * src1(is+3,js+4,ks ) - $ + f8*f8*f4 * src1(is+4,js+4,ks ) - res15 = - $ + f1*f1*f5 * src1(is-3,js-3,ks+1) - $ + f2*f1*f5 * src1(is-2,js-3,ks+1) - $ + f3*f1*f5 * src1(is-1,js-3,ks+1) - $ + f4*f1*f5 * src1(is ,js-3,ks+1) - $ + f5*f1*f5 * src1(is+1,js-3,ks+1) - $ + f6*f1*f5 * src1(is+2,js-3,ks+1) - $ + f7*f1*f5 * src1(is+3,js-3,ks+1) - $ + f8*f1*f5 * src1(is+4,js-3,ks+1) - $ + f1*f2*f5 * src1(is-3,js-2,ks+1) - $ + f2*f2*f5 * src1(is-2,js-2,ks+1) - $ + f3*f2*f5 * src1(is-1,js-2,ks+1) - $ + f4*f2*f5 * src1(is ,js-2,ks+1) - $ + f5*f2*f5 * src1(is+1,js-2,ks+1) - $ + f6*f2*f5 * src1(is+2,js-2,ks+1) - $ + f7*f2*f5 * src1(is+3,js-2,ks+1) - $ + f8*f2*f5 * src1(is+4,js-2,ks+1) - $ + f1*f3*f5 * src1(is-3,js-1,ks+1) - $ + f2*f3*f5 * src1(is-2,js-1,ks+1) - $ + f3*f3*f5 * src1(is-1,js-1,ks+1) - $ + f4*f3*f5 * src1(is ,js-1,ks+1) - $ + f5*f3*f5 * src1(is+1,js-1,ks+1) - $ + f6*f3*f5 * src1(is+2,js-1,ks+1) - $ + f7*f3*f5 * src1(is+3,js-1,ks+1) - $ + f8*f3*f5 * src1(is+4,js-1,ks+1) - $ + f1*f4*f5 * src1(is-3,js ,ks+1) - $ + f2*f4*f5 * src1(is-2,js ,ks+1) - $ + f3*f4*f5 * src1(is-1,js ,ks+1) - $ + f4*f4*f5 * src1(is ,js ,ks+1) - $ + f5*f4*f5 * src1(is+1,js ,ks+1) - $ + f6*f4*f5 * src1(is+2,js ,ks+1) - $ + f7*f4*f5 * src1(is+3,js ,ks+1) - $ + f8*f4*f5 * src1(is+4,js ,ks+1) - $ + f1*f5*f5 * src1(is-3,js+1,ks+1) - $ + f2*f5*f5 * src1(is-2,js+1,ks+1) - $ + f3*f5*f5 * src1(is-1,js+1,ks+1) - $ + f4*f5*f5 * src1(is ,js+1,ks+1) - $ + f5*f5*f5 * src1(is+1,js+1,ks+1) - $ + f6*f5*f5 * src1(is+2,js+1,ks+1) - $ + f7*f5*f5 * src1(is+3,js+1,ks+1) - $ + f8*f5*f5 * src1(is+4,js+1,ks+1) - $ + f1*f6*f5 * src1(is-3,js+2,ks+1) - $ + f2*f6*f5 * src1(is-2,js+2,ks+1) - $ + f3*f6*f5 * src1(is-1,js+2,ks+1) - $ + f4*f6*f5 * src1(is ,js+2,ks+1) - $ + f5*f6*f5 * src1(is+1,js+2,ks+1) - $ + f6*f6*f5 * src1(is+2,js+2,ks+1) - $ + f7*f6*f5 * src1(is+3,js+2,ks+1) - $ + f8*f6*f5 * src1(is+4,js+2,ks+1) - $ + f1*f7*f5 * src1(is-3,js+3,ks+1) - $ + f2*f7*f5 * src1(is-2,js+3,ks+1) - $ + f3*f7*f5 * src1(is-1,js+3,ks+1) - $ + f4*f7*f5 * src1(is ,js+3,ks+1) - $ + f5*f7*f5 * src1(is+1,js+3,ks+1) - $ + f6*f7*f5 * src1(is+2,js+3,ks+1) - $ + f7*f7*f5 * src1(is+3,js+3,ks+1) - $ + f8*f7*f5 * src1(is+4,js+3,ks+1) - $ + f1*f8*f5 * src1(is-3,js+4,ks+1) - $ + f2*f8*f5 * src1(is-2,js+4,ks+1) - $ + f3*f8*f5 * src1(is-1,js+4,ks+1) - $ + f4*f8*f5 * src1(is ,js+4,ks+1) - $ + f5*f8*f5 * src1(is+1,js+4,ks+1) - $ + f6*f8*f5 * src1(is+2,js+4,ks+1) - $ + f7*f8*f5 * src1(is+3,js+4,ks+1) - $ + f8*f8*f5 * src1(is+4,js+4,ks+1) - res16 = - $ + f1*f1*f6 * src1(is-3,js-3,ks+2) - $ + f2*f1*f6 * src1(is-2,js-3,ks+2) - $ + f3*f1*f6 * src1(is-1,js-3,ks+2) - $ + f4*f1*f6 * src1(is ,js-3,ks+2) - $ + f5*f1*f6 * src1(is+1,js-3,ks+2) - $ + f6*f1*f6 * src1(is+2,js-3,ks+2) - $ + f7*f1*f6 * src1(is+3,js-3,ks+2) - $ + f8*f1*f6 * src1(is+4,js-3,ks+2) - $ + f1*f2*f6 * src1(is-3,js-2,ks+2) - $ + f2*f2*f6 * src1(is-2,js-2,ks+2) - $ + f3*f2*f6 * src1(is-1,js-2,ks+2) - $ + f4*f2*f6 * src1(is ,js-2,ks+2) - $ + f5*f2*f6 * src1(is+1,js-2,ks+2) - $ + f6*f2*f6 * src1(is+2,js-2,ks+2) - $ + f7*f2*f6 * src1(is+3,js-2,ks+2) - $ + f8*f2*f6 * src1(is+4,js-2,ks+2) - $ + f1*f3*f6 * src1(is-3,js-1,ks+2) - $ + f2*f3*f6 * src1(is-2,js-1,ks+2) - $ + f3*f3*f6 * src1(is-1,js-1,ks+2) - $ + f4*f3*f6 * src1(is ,js-1,ks+2) - $ + f5*f3*f6 * src1(is+1,js-1,ks+2) - $ + f6*f3*f6 * src1(is+2,js-1,ks+2) - $ + f7*f3*f6 * src1(is+3,js-1,ks+2) - $ + f8*f3*f6 * src1(is+4,js-1,ks+2) - $ + f1*f4*f6 * src1(is-3,js ,ks+2) - $ + f2*f4*f6 * src1(is-2,js ,ks+2) - $ + f3*f4*f6 * src1(is-1,js ,ks+2) - $ + f4*f4*f6 * src1(is ,js ,ks+2) - $ + f5*f4*f6 * src1(is+1,js ,ks+2) - $ + f6*f4*f6 * src1(is+2,js ,ks+2) - $ + f7*f4*f6 * src1(is+3,js ,ks+2) - $ + f8*f4*f6 * src1(is+4,js ,ks+2) - $ + f1*f5*f6 * src1(is-3,js+1,ks+2) - $ + f2*f5*f6 * src1(is-2,js+1,ks+2) - $ + f3*f5*f6 * src1(is-1,js+1,ks+2) - $ + f4*f5*f6 * src1(is ,js+1,ks+2) - $ + f5*f5*f6 * src1(is+1,js+1,ks+2) - $ + f6*f5*f6 * src1(is+2,js+1,ks+2) - $ + f7*f5*f6 * src1(is+3,js+1,ks+2) - $ + f8*f5*f6 * src1(is+4,js+1,ks+2) - $ + f1*f6*f6 * src1(is-3,js+2,ks+2) - $ + f2*f6*f6 * src1(is-2,js+2,ks+2) - $ + f3*f6*f6 * src1(is-1,js+2,ks+2) - $ + f4*f6*f6 * src1(is ,js+2,ks+2) - $ + f5*f6*f6 * src1(is+1,js+2,ks+2) - $ + f6*f6*f6 * src1(is+2,js+2,ks+2) - $ + f7*f6*f6 * src1(is+3,js+2,ks+2) - $ + f8*f6*f6 * src1(is+4,js+2,ks+2) - $ + f1*f7*f6 * src1(is-3,js+3,ks+2) - $ + f2*f7*f6 * src1(is-2,js+3,ks+2) - $ + f3*f7*f6 * src1(is-1,js+3,ks+2) - $ + f4*f7*f6 * src1(is ,js+3,ks+2) - $ + f5*f7*f6 * src1(is+1,js+3,ks+2) - $ + f6*f7*f6 * src1(is+2,js+3,ks+2) - $ + f7*f7*f6 * src1(is+3,js+3,ks+2) - $ + f8*f7*f6 * src1(is+4,js+3,ks+2) - $ + f1*f8*f6 * src1(is-3,js+4,ks+2) - $ + f2*f8*f6 * src1(is-2,js+4,ks+2) - $ + f3*f8*f6 * src1(is-1,js+4,ks+2) - $ + f4*f8*f6 * src1(is ,js+4,ks+2) - $ + f5*f8*f6 * src1(is+1,js+4,ks+2) - $ + f6*f8*f6 * src1(is+2,js+4,ks+2) - $ + f7*f8*f6 * src1(is+3,js+4,ks+2) - $ + f8*f8*f6 * src1(is+4,js+4,ks+2) - res17 = - $ + f1*f1*f7 * src1(is-3,js-3,ks+3) - $ + f2*f1*f7 * src1(is-2,js-3,ks+3) - $ + f3*f1*f7 * src1(is-1,js-3,ks+3) - $ + f4*f1*f7 * src1(is ,js-3,ks+3) - $ + f5*f1*f7 * src1(is+1,js-3,ks+3) - $ + f6*f1*f7 * src1(is+2,js-3,ks+3) - $ + f7*f1*f7 * src1(is+3,js-3,ks+3) - $ + f8*f1*f7 * src1(is+4,js-3,ks+3) - $ + f1*f2*f7 * src1(is-3,js-2,ks+3) - $ + f2*f2*f7 * src1(is-2,js-2,ks+3) - $ + f3*f2*f7 * src1(is-1,js-2,ks+3) - $ + f4*f2*f7 * src1(is ,js-2,ks+3) - $ + f5*f2*f7 * src1(is+1,js-2,ks+3) - $ + f6*f2*f7 * src1(is+2,js-2,ks+3) - $ + f7*f2*f7 * src1(is+3,js-2,ks+3) - $ + f8*f2*f7 * src1(is+4,js-2,ks+3) - $ + f1*f3*f7 * src1(is-3,js-1,ks+3) - $ + f2*f3*f7 * src1(is-2,js-1,ks+3) - $ + f3*f3*f7 * src1(is-1,js-1,ks+3) - $ + f4*f3*f7 * src1(is ,js-1,ks+3) - $ + f5*f3*f7 * src1(is+1,js-1,ks+3) - $ + f6*f3*f7 * src1(is+2,js-1,ks+3) - $ + f7*f3*f7 * src1(is+3,js-1,ks+3) - $ + f8*f3*f7 * src1(is+4,js-1,ks+3) - $ + f1*f4*f7 * src1(is-3,js ,ks+3) - $ + f2*f4*f7 * src1(is-2,js ,ks+3) - $ + f3*f4*f7 * src1(is-1,js ,ks+3) - $ + f4*f4*f7 * src1(is ,js ,ks+3) - $ + f5*f4*f7 * src1(is+1,js ,ks+3) - $ + f6*f4*f7 * src1(is+2,js ,ks+3) - $ + f7*f4*f7 * src1(is+3,js ,ks+3) - $ + f8*f4*f7 * src1(is+4,js ,ks+3) - $ + f1*f5*f7 * src1(is-3,js+1,ks+3) - $ + f2*f5*f7 * src1(is-2,js+1,ks+3) - $ + f3*f5*f7 * src1(is-1,js+1,ks+3) - $ + f4*f5*f7 * src1(is ,js+1,ks+3) - $ + f5*f5*f7 * src1(is+1,js+1,ks+3) - $ + f6*f5*f7 * src1(is+2,js+1,ks+3) - $ + f7*f5*f7 * src1(is+3,js+1,ks+3) - $ + f8*f5*f7 * src1(is+4,js+1,ks+3) - $ + f1*f6*f7 * src1(is-3,js+2,ks+3) - $ + f2*f6*f7 * src1(is-2,js+2,ks+3) - $ + f3*f6*f7 * src1(is-1,js+2,ks+3) - $ + f4*f6*f7 * src1(is ,js+2,ks+3) - $ + f5*f6*f7 * src1(is+1,js+2,ks+3) - $ + f6*f6*f7 * src1(is+2,js+2,ks+3) - $ + f7*f6*f7 * src1(is+3,js+2,ks+3) - $ + f8*f6*f7 * src1(is+4,js+2,ks+3) - $ + f1*f7*f7 * src1(is-3,js+3,ks+3) - $ + f2*f7*f7 * src1(is-2,js+3,ks+3) - $ + f3*f7*f7 * src1(is-1,js+3,ks+3) - $ + f4*f7*f7 * src1(is ,js+3,ks+3) - $ + f5*f7*f7 * src1(is+1,js+3,ks+3) - $ + f6*f7*f7 * src1(is+2,js+3,ks+3) - $ + f7*f7*f7 * src1(is+3,js+3,ks+3) - $ + f8*f7*f7 * src1(is+4,js+3,ks+3) - $ + f1*f8*f7 * src1(is-3,js+4,ks+3) - $ + f2*f8*f7 * src1(is-2,js+4,ks+3) - $ + f3*f8*f7 * src1(is-1,js+4,ks+3) - $ + f4*f8*f7 * src1(is ,js+4,ks+3) - $ + f5*f8*f7 * src1(is+1,js+4,ks+3) - $ + f6*f8*f7 * src1(is+2,js+4,ks+3) - $ + f7*f8*f7 * src1(is+3,js+4,ks+3) - $ + f8*f8*f7 * src1(is+4,js+4,ks+3) - res18 = - $ + f1*f1*f8 * src1(is-3,js-3,ks+4) - $ + f2*f1*f8 * src1(is-2,js-3,ks+4) - $ + f3*f1*f8 * src1(is-1,js-3,ks+4) - $ + f4*f1*f8 * src1(is ,js-3,ks+4) - $ + f5*f1*f8 * src1(is+1,js-3,ks+4) - $ + f6*f1*f8 * src1(is+2,js-3,ks+4) - $ + f7*f1*f8 * src1(is+3,js-3,ks+4) - $ + f8*f1*f8 * src1(is+4,js-3,ks+4) - $ + f1*f2*f8 * src1(is-3,js-2,ks+4) - $ + f2*f2*f8 * src1(is-2,js-2,ks+4) - $ + f3*f2*f8 * src1(is-1,js-2,ks+4) - $ + f4*f2*f8 * src1(is ,js-2,ks+4) - $ + f5*f2*f8 * src1(is+1,js-2,ks+4) - $ + f6*f2*f8 * src1(is+2,js-2,ks+4) - $ + f7*f2*f8 * src1(is+3,js-2,ks+4) - $ + f8*f2*f8 * src1(is+4,js-2,ks+4) - $ + f1*f3*f8 * src1(is-3,js-1,ks+4) - $ + f2*f3*f8 * src1(is-2,js-1,ks+4) - $ + f3*f3*f8 * src1(is-1,js-1,ks+4) - $ + f4*f3*f8 * src1(is ,js-1,ks+4) - $ + f5*f3*f8 * src1(is+1,js-1,ks+4) - $ + f6*f3*f8 * src1(is+2,js-1,ks+4) - $ + f7*f3*f8 * src1(is+3,js-1,ks+4) - $ + f8*f3*f8 * src1(is+4,js-1,ks+4) - $ + f1*f4*f8 * src1(is-3,js ,ks+4) - $ + f2*f4*f8 * src1(is-2,js ,ks+4) - $ + f3*f4*f8 * src1(is-1,js ,ks+4) - $ + f4*f4*f8 * src1(is ,js ,ks+4) - $ + f5*f4*f8 * src1(is+1,js ,ks+4) - $ + f6*f4*f8 * src1(is+2,js ,ks+4) - $ + f7*f4*f8 * src1(is+3,js ,ks+4) - $ + f8*f4*f8 * src1(is+4,js ,ks+4) - $ + f1*f5*f8 * src1(is-3,js+1,ks+4) - $ + f2*f5*f8 * src1(is-2,js+1,ks+4) - $ + f3*f5*f8 * src1(is-1,js+1,ks+4) - $ + f4*f5*f8 * src1(is ,js+1,ks+4) - $ + f5*f5*f8 * src1(is+1,js+1,ks+4) - $ + f6*f5*f8 * src1(is+2,js+1,ks+4) - $ + f7*f5*f8 * src1(is+3,js+1,ks+4) - $ + f8*f5*f8 * src1(is+4,js+1,ks+4) - $ + f1*f6*f8 * src1(is-3,js+2,ks+4) - $ + f2*f6*f8 * src1(is-2,js+2,ks+4) - $ + f3*f6*f8 * src1(is-1,js+2,ks+4) - $ + f4*f6*f8 * src1(is ,js+2,ks+4) - $ + f5*f6*f8 * src1(is+1,js+2,ks+4) - $ + f6*f6*f8 * src1(is+2,js+2,ks+4) - $ + f7*f6*f8 * src1(is+3,js+2,ks+4) - $ + f8*f6*f8 * src1(is+4,js+2,ks+4) - $ + f1*f7*f8 * src1(is-3,js+3,ks+4) - $ + f2*f7*f8 * src1(is-2,js+3,ks+4) - $ + f3*f7*f8 * src1(is-1,js+3,ks+4) - $ + f4*f7*f8 * src1(is ,js+3,ks+4) - $ + f5*f7*f8 * src1(is+1,js+3,ks+4) - $ + f6*f7*f8 * src1(is+2,js+3,ks+4) - $ + f7*f7*f8 * src1(is+3,js+3,ks+4) - $ + f8*f7*f8 * src1(is+4,js+3,ks+4) - $ + f1*f8*f8 * src1(is-3,js+4,ks+4) - $ + f2*f8*f8 * src1(is-2,js+4,ks+4) - $ + f3*f8*f8 * src1(is-1,js+4,ks+4) - $ + f4*f8*f8 * src1(is ,js+4,ks+4) - $ + f5*f8*f8 * src1(is+1,js+4,ks+4) - $ + f6*f8*f8 * src1(is+2,js+4,ks+4) - $ + f7*f8*f8 * src1(is+3,js+4,ks+4) - $ + f8*f8*f8 * src1(is+4,js+4,ks+4) - res21 = - $ + f1*f1*f1 * src2(is-3,js-3,ks-3) - $ + f2*f1*f1 * src2(is-2,js-3,ks-3) - $ + f3*f1*f1 * src2(is-1,js-3,ks-3) - $ + f4*f1*f1 * src2(is ,js-3,ks-3) - $ + f5*f1*f1 * src2(is+1,js-3,ks-3) - $ + f6*f1*f1 * src2(is+2,js-3,ks-3) - $ + f7*f1*f1 * src2(is+3,js-3,ks-3) - $ + f8*f1*f1 * src2(is+4,js-3,ks-3) - $ + f1*f2*f1 * src2(is-3,js-2,ks-3) - $ + f2*f2*f1 * src2(is-2,js-2,ks-3) - $ + f3*f2*f1 * src2(is-1,js-2,ks-3) - $ + f4*f2*f1 * src2(is ,js-2,ks-3) - $ + f5*f2*f1 * src2(is+1,js-2,ks-3) - $ + f6*f2*f1 * src2(is+2,js-2,ks-3) - $ + f7*f2*f1 * src2(is+3,js-2,ks-3) - $ + f8*f2*f1 * src2(is+4,js-2,ks-3) - $ + f1*f3*f1 * src2(is-3,js-1,ks-3) - $ + f2*f3*f1 * src2(is-2,js-1,ks-3) - $ + f3*f3*f1 * src2(is-1,js-1,ks-3) - $ + f4*f3*f1 * src2(is ,js-1,ks-3) - $ + f5*f3*f1 * src2(is+1,js-1,ks-3) - $ + f6*f3*f1 * src2(is+2,js-1,ks-3) - $ + f7*f3*f1 * src2(is+3,js-1,ks-3) - $ + f8*f3*f1 * src2(is+4,js-1,ks-3) - $ + f1*f4*f1 * src2(is-3,js ,ks-3) - $ + f2*f4*f1 * src2(is-2,js ,ks-3) - $ + f3*f4*f1 * src2(is-1,js ,ks-3) - $ + f4*f4*f1 * src2(is ,js ,ks-3) - $ + f5*f4*f1 * src2(is+1,js ,ks-3) - $ + f6*f4*f1 * src2(is+2,js ,ks-3) - $ + f7*f4*f1 * src2(is+3,js ,ks-3) - $ + f8*f4*f1 * src2(is+4,js ,ks-3) - $ + f1*f5*f1 * src2(is-3,js+1,ks-3) - $ + f2*f5*f1 * src2(is-2,js+1,ks-3) - $ + f3*f5*f1 * src2(is-1,js+1,ks-3) - $ + f4*f5*f1 * src2(is ,js+1,ks-3) - $ + f5*f5*f1 * src2(is+1,js+1,ks-3) - $ + f6*f5*f1 * src2(is+2,js+1,ks-3) - $ + f7*f5*f1 * src2(is+3,js+1,ks-3) - $ + f8*f5*f1 * src2(is+4,js+1,ks-3) - $ + f1*f6*f1 * src2(is-3,js+2,ks-3) - $ + f2*f6*f1 * src2(is-2,js+2,ks-3) - $ + f3*f6*f1 * src2(is-1,js+2,ks-3) - $ + f4*f6*f1 * src2(is ,js+2,ks-3) - $ + f5*f6*f1 * src2(is+1,js+2,ks-3) - $ + f6*f6*f1 * src2(is+2,js+2,ks-3) - $ + f7*f6*f1 * src2(is+3,js+2,ks-3) - $ + f8*f6*f1 * src2(is+4,js+2,ks-3) - $ + f1*f7*f1 * src2(is-3,js+3,ks-3) - $ + f2*f7*f1 * src2(is-2,js+3,ks-3) - $ + f3*f7*f1 * src2(is-1,js+3,ks-3) - $ + f4*f7*f1 * src2(is ,js+3,ks-3) - $ + f5*f7*f1 * src2(is+1,js+3,ks-3) - $ + f6*f7*f1 * src2(is+2,js+3,ks-3) - $ + f7*f7*f1 * src2(is+3,js+3,ks-3) - $ + f8*f7*f1 * src2(is+4,js+3,ks-3) - $ + f1*f8*f1 * src2(is-3,js+4,ks-3) - $ + f2*f8*f1 * src2(is-2,js+4,ks-3) - $ + f3*f8*f1 * src2(is-1,js+4,ks-3) - $ + f4*f8*f1 * src2(is ,js+4,ks-3) - $ + f5*f8*f1 * src2(is+1,js+4,ks-3) - $ + f6*f8*f1 * src2(is+2,js+4,ks-3) - $ + f7*f8*f1 * src2(is+3,js+4,ks-3) - $ + f8*f8*f1 * src2(is+4,js+4,ks-3) - res22 = - $ + f1*f1*f2 * src2(is-3,js-3,ks-2) - $ + f2*f1*f2 * src2(is-2,js-3,ks-2) - $ + f3*f1*f2 * src2(is-1,js-3,ks-2) - $ + f4*f1*f2 * src2(is ,js-3,ks-2) - $ + f5*f1*f2 * src2(is+1,js-3,ks-2) - $ + f6*f1*f2 * src2(is+2,js-3,ks-2) - $ + f7*f1*f2 * src2(is+3,js-3,ks-2) - $ + f8*f1*f2 * src2(is+4,js-3,ks-2) - $ + f1*f2*f2 * src2(is-3,js-2,ks-2) - $ + f2*f2*f2 * src2(is-2,js-2,ks-2) - $ + f3*f2*f2 * src2(is-1,js-2,ks-2) - $ + f4*f2*f2 * src2(is ,js-2,ks-2) - $ + f5*f2*f2 * src2(is+1,js-2,ks-2) - $ + f6*f2*f2 * src2(is+2,js-2,ks-2) - $ + f7*f2*f2 * src2(is+3,js-2,ks-2) - $ + f8*f2*f2 * src2(is+4,js-2,ks-2) - $ + f1*f3*f2 * src2(is-3,js-1,ks-2) - $ + f2*f3*f2 * src2(is-2,js-1,ks-2) - $ + f3*f3*f2 * src2(is-1,js-1,ks-2) - $ + f4*f3*f2 * src2(is ,js-1,ks-2) - $ + f5*f3*f2 * src2(is+1,js-1,ks-2) - $ + f6*f3*f2 * src2(is+2,js-1,ks-2) - $ + f7*f3*f2 * src2(is+3,js-1,ks-2) - $ + f8*f3*f2 * src2(is+4,js-1,ks-2) - $ + f1*f4*f2 * src2(is-3,js ,ks-2) - $ + f2*f4*f2 * src2(is-2,js ,ks-2) - $ + f3*f4*f2 * src2(is-1,js ,ks-2) - $ + f4*f4*f2 * src2(is ,js ,ks-2) - $ + f5*f4*f2 * src2(is+1,js ,ks-2) - $ + f6*f4*f2 * src2(is+2,js ,ks-2) - $ + f7*f4*f2 * src2(is+3,js ,ks-2) - $ + f8*f4*f2 * src2(is+4,js ,ks-2) - $ + f1*f5*f2 * src2(is-3,js+1,ks-2) - $ + f2*f5*f2 * src2(is-2,js+1,ks-2) - $ + f3*f5*f2 * src2(is-1,js+1,ks-2) - $ + f4*f5*f2 * src2(is ,js+1,ks-2) - $ + f5*f5*f2 * src2(is+1,js+1,ks-2) - $ + f6*f5*f2 * src2(is+2,js+1,ks-2) - $ + f7*f5*f2 * src2(is+3,js+1,ks-2) - $ + f8*f5*f2 * src2(is+4,js+1,ks-2) - $ + f1*f6*f2 * src2(is-3,js+2,ks-2) - $ + f2*f6*f2 * src2(is-2,js+2,ks-2) - $ + f3*f6*f2 * src2(is-1,js+2,ks-2) - $ + f4*f6*f2 * src2(is ,js+2,ks-2) - $ + f5*f6*f2 * src2(is+1,js+2,ks-2) - $ + f6*f6*f2 * src2(is+2,js+2,ks-2) - $ + f7*f6*f2 * src2(is+3,js+2,ks-2) - $ + f8*f6*f2 * src2(is+4,js+2,ks-2) - $ + f1*f7*f2 * src2(is-3,js+3,ks-2) - $ + f2*f7*f2 * src2(is-2,js+3,ks-2) - $ + f3*f7*f2 * src2(is-1,js+3,ks-2) - $ + f4*f7*f2 * src2(is ,js+3,ks-2) - $ + f5*f7*f2 * src2(is+1,js+3,ks-2) - $ + f6*f7*f2 * src2(is+2,js+3,ks-2) - $ + f7*f7*f2 * src2(is+3,js+3,ks-2) - $ + f8*f7*f2 * src2(is+4,js+3,ks-2) - $ + f1*f8*f2 * src2(is-3,js+4,ks-2) - $ + f2*f8*f2 * src2(is-2,js+4,ks-2) - $ + f3*f8*f2 * src2(is-1,js+4,ks-2) - $ + f4*f8*f2 * src2(is ,js+4,ks-2) - $ + f5*f8*f2 * src2(is+1,js+4,ks-2) - $ + f6*f8*f2 * src2(is+2,js+4,ks-2) - $ + f7*f8*f2 * src2(is+3,js+4,ks-2) - $ + f8*f8*f2 * src2(is+4,js+4,ks-2) - res23 = - $ + f1*f1*f3 * src2(is-3,js-3,ks-1) - $ + f2*f1*f3 * src2(is-2,js-3,ks-1) - $ + f3*f1*f3 * src2(is-1,js-3,ks-1) - $ + f4*f1*f3 * src2(is ,js-3,ks-1) - $ + f5*f1*f3 * src2(is+1,js-3,ks-1) - $ + f6*f1*f3 * src2(is+2,js-3,ks-1) - $ + f7*f1*f3 * src2(is+3,js-3,ks-1) - $ + f8*f1*f3 * src2(is+4,js-3,ks-1) - $ + f1*f2*f3 * src2(is-3,js-2,ks-1) - $ + f2*f2*f3 * src2(is-2,js-2,ks-1) - $ + f3*f2*f3 * src2(is-1,js-2,ks-1) - $ + f4*f2*f3 * src2(is ,js-2,ks-1) - $ + f5*f2*f3 * src2(is+1,js-2,ks-1) - $ + f6*f2*f3 * src2(is+2,js-2,ks-1) - $ + f7*f2*f3 * src2(is+3,js-2,ks-1) - $ + f8*f2*f3 * src2(is+4,js-2,ks-1) - $ + f1*f3*f3 * src2(is-3,js-1,ks-1) - $ + f2*f3*f3 * src2(is-2,js-1,ks-1) - $ + f3*f3*f3 * src2(is-1,js-1,ks-1) - $ + f4*f3*f3 * src2(is ,js-1,ks-1) - $ + f5*f3*f3 * src2(is+1,js-1,ks-1) - $ + f6*f3*f3 * src2(is+2,js-1,ks-1) - $ + f7*f3*f3 * src2(is+3,js-1,ks-1) - $ + f8*f3*f3 * src2(is+4,js-1,ks-1) - $ + f1*f4*f3 * src2(is-3,js ,ks-1) - $ + f2*f4*f3 * src2(is-2,js ,ks-1) - $ + f3*f4*f3 * src2(is-1,js ,ks-1) - $ + f4*f4*f3 * src2(is ,js ,ks-1) - $ + f5*f4*f3 * src2(is+1,js ,ks-1) - $ + f6*f4*f3 * src2(is+2,js ,ks-1) - $ + f7*f4*f3 * src2(is+3,js ,ks-1) - $ + f8*f4*f3 * src2(is+4,js ,ks-1) - $ + f1*f5*f3 * src2(is-3,js+1,ks-1) - $ + f2*f5*f3 * src2(is-2,js+1,ks-1) - $ + f3*f5*f3 * src2(is-1,js+1,ks-1) - $ + f4*f5*f3 * src2(is ,js+1,ks-1) - $ + f5*f5*f3 * src2(is+1,js+1,ks-1) - $ + f6*f5*f3 * src2(is+2,js+1,ks-1) - $ + f7*f5*f3 * src2(is+3,js+1,ks-1) - $ + f8*f5*f3 * src2(is+4,js+1,ks-1) - $ + f1*f6*f3 * src2(is-3,js+2,ks-1) - $ + f2*f6*f3 * src2(is-2,js+2,ks-1) - $ + f3*f6*f3 * src2(is-1,js+2,ks-1) - $ + f4*f6*f3 * src2(is ,js+2,ks-1) - $ + f5*f6*f3 * src2(is+1,js+2,ks-1) - $ + f6*f6*f3 * src2(is+2,js+2,ks-1) - $ + f7*f6*f3 * src2(is+3,js+2,ks-1) - $ + f8*f6*f3 * src2(is+4,js+2,ks-1) - $ + f1*f7*f3 * src2(is-3,js+3,ks-1) - $ + f2*f7*f3 * src2(is-2,js+3,ks-1) - $ + f3*f7*f3 * src2(is-1,js+3,ks-1) - $ + f4*f7*f3 * src2(is ,js+3,ks-1) - $ + f5*f7*f3 * src2(is+1,js+3,ks-1) - $ + f6*f7*f3 * src2(is+2,js+3,ks-1) - $ + f7*f7*f3 * src2(is+3,js+3,ks-1) - $ + f8*f7*f3 * src2(is+4,js+3,ks-1) - $ + f1*f8*f3 * src2(is-3,js+4,ks-1) - $ + f2*f8*f3 * src2(is-2,js+4,ks-1) - $ + f3*f8*f3 * src2(is-1,js+4,ks-1) - $ + f4*f8*f3 * src2(is ,js+4,ks-1) - $ + f5*f8*f3 * src2(is+1,js+4,ks-1) - $ + f6*f8*f3 * src2(is+2,js+4,ks-1) - $ + f7*f8*f3 * src2(is+3,js+4,ks-1) - $ + f8*f8*f3 * src2(is+4,js+4,ks-1) - res24 = - $ + f1*f1*f4 * src2(is-3,js-3,ks ) - $ + f2*f1*f4 * src2(is-2,js-3,ks ) - $ + f3*f1*f4 * src2(is-1,js-3,ks ) - $ + f4*f1*f4 * src2(is ,js-3,ks ) - $ + f5*f1*f4 * src2(is+1,js-3,ks ) - $ + f6*f1*f4 * src2(is+2,js-3,ks ) - $ + f7*f1*f4 * src2(is+3,js-3,ks ) - $ + f8*f1*f4 * src2(is+4,js-3,ks ) - $ + f1*f2*f4 * src2(is-3,js-2,ks ) - $ + f2*f2*f4 * src2(is-2,js-2,ks ) - $ + f3*f2*f4 * src2(is-1,js-2,ks ) - $ + f4*f2*f4 * src2(is ,js-2,ks ) - $ + f5*f2*f4 * src2(is+1,js-2,ks ) - $ + f6*f2*f4 * src2(is+2,js-2,ks ) - $ + f7*f2*f4 * src2(is+3,js-2,ks ) - $ + f8*f2*f4 * src2(is+4,js-2,ks ) - $ + f1*f3*f4 * src2(is-3,js-1,ks ) - $ + f2*f3*f4 * src2(is-2,js-1,ks ) - $ + f3*f3*f4 * src2(is-1,js-1,ks ) - $ + f4*f3*f4 * src2(is ,js-1,ks ) - $ + f5*f3*f4 * src2(is+1,js-1,ks ) - $ + f6*f3*f4 * src2(is+2,js-1,ks ) - $ + f7*f3*f4 * src2(is+3,js-1,ks ) - $ + f8*f3*f4 * src2(is+4,js-1,ks ) - $ + f1*f4*f4 * src2(is-3,js ,ks ) - $ + f2*f4*f4 * src2(is-2,js ,ks ) - $ + f3*f4*f4 * src2(is-1,js ,ks ) - $ + f4*f4*f4 * src2(is ,js ,ks ) - $ + f5*f4*f4 * src2(is+1,js ,ks ) - $ + f6*f4*f4 * src2(is+2,js ,ks ) - $ + f7*f4*f4 * src2(is+3,js ,ks ) - $ + f8*f4*f4 * src2(is+4,js ,ks ) - $ + f1*f5*f4 * src2(is-3,js+1,ks ) - $ + f2*f5*f4 * src2(is-2,js+1,ks ) - $ + f3*f5*f4 * src2(is-1,js+1,ks ) - $ + f4*f5*f4 * src2(is ,js+1,ks ) - $ + f5*f5*f4 * src2(is+1,js+1,ks ) - $ + f6*f5*f4 * src2(is+2,js+1,ks ) - $ + f7*f5*f4 * src2(is+3,js+1,ks ) - $ + f8*f5*f4 * src2(is+4,js+1,ks ) - $ + f1*f6*f4 * src2(is-3,js+2,ks ) - $ + f2*f6*f4 * src2(is-2,js+2,ks ) - $ + f3*f6*f4 * src2(is-1,js+2,ks ) - $ + f4*f6*f4 * src2(is ,js+2,ks ) - $ + f5*f6*f4 * src2(is+1,js+2,ks ) - $ + f6*f6*f4 * src2(is+2,js+2,ks ) - $ + f7*f6*f4 * src2(is+3,js+2,ks ) - $ + f8*f6*f4 * src2(is+4,js+2,ks ) - $ + f1*f7*f4 * src2(is-3,js+3,ks ) - $ + f2*f7*f4 * src2(is-2,js+3,ks ) - $ + f3*f7*f4 * src2(is-1,js+3,ks ) - $ + f4*f7*f4 * src2(is ,js+3,ks ) - $ + f5*f7*f4 * src2(is+1,js+3,ks ) - $ + f6*f7*f4 * src2(is+2,js+3,ks ) - $ + f7*f7*f4 * src2(is+3,js+3,ks ) - $ + f8*f7*f4 * src2(is+4,js+3,ks ) - $ + f1*f8*f4 * src2(is-3,js+4,ks ) - $ + f2*f8*f4 * src2(is-2,js+4,ks ) - $ + f3*f8*f4 * src2(is-1,js+4,ks ) - $ + f4*f8*f4 * src2(is ,js+4,ks ) - $ + f5*f8*f4 * src2(is+1,js+4,ks ) - $ + f6*f8*f4 * src2(is+2,js+4,ks ) - $ + f7*f8*f4 * src2(is+3,js+4,ks ) - $ + f8*f8*f4 * src2(is+4,js+4,ks ) - res25 = - $ + f1*f1*f5 * src2(is-3,js-3,ks+1) - $ + f2*f1*f5 * src2(is-2,js-3,ks+1) - $ + f3*f1*f5 * src2(is-1,js-3,ks+1) - $ + f4*f1*f5 * src2(is ,js-3,ks+1) - $ + f5*f1*f5 * src2(is+1,js-3,ks+1) - $ + f6*f1*f5 * src2(is+2,js-3,ks+1) - $ + f7*f1*f5 * src2(is+3,js-3,ks+1) - $ + f8*f1*f5 * src2(is+4,js-3,ks+1) - $ + f1*f2*f5 * src2(is-3,js-2,ks+1) - $ + f2*f2*f5 * src2(is-2,js-2,ks+1) - $ + f3*f2*f5 * src2(is-1,js-2,ks+1) - $ + f4*f2*f5 * src2(is ,js-2,ks+1) - $ + f5*f2*f5 * src2(is+1,js-2,ks+1) - $ + f6*f2*f5 * src2(is+2,js-2,ks+1) - $ + f7*f2*f5 * src2(is+3,js-2,ks+1) - $ + f8*f2*f5 * src2(is+4,js-2,ks+1) - $ + f1*f3*f5 * src2(is-3,js-1,ks+1) - $ + f2*f3*f5 * src2(is-2,js-1,ks+1) - $ + f3*f3*f5 * src2(is-1,js-1,ks+1) - $ + f4*f3*f5 * src2(is ,js-1,ks+1) - $ + f5*f3*f5 * src2(is+1,js-1,ks+1) - $ + f6*f3*f5 * src2(is+2,js-1,ks+1) - $ + f7*f3*f5 * src2(is+3,js-1,ks+1) - $ + f8*f3*f5 * src2(is+4,js-1,ks+1) - $ + f1*f4*f5 * src2(is-3,js ,ks+1) - $ + f2*f4*f5 * src2(is-2,js ,ks+1) - $ + f3*f4*f5 * src2(is-1,js ,ks+1) - $ + f4*f4*f5 * src2(is ,js ,ks+1) - $ + f5*f4*f5 * src2(is+1,js ,ks+1) - $ + f6*f4*f5 * src2(is+2,js ,ks+1) - $ + f7*f4*f5 * src2(is+3,js ,ks+1) - $ + f8*f4*f5 * src2(is+4,js ,ks+1) - $ + f1*f5*f5 * src2(is-3,js+1,ks+1) - $ + f2*f5*f5 * src2(is-2,js+1,ks+1) - $ + f3*f5*f5 * src2(is-1,js+1,ks+1) - $ + f4*f5*f5 * src2(is ,js+1,ks+1) - $ + f5*f5*f5 * src2(is+1,js+1,ks+1) - $ + f6*f5*f5 * src2(is+2,js+1,ks+1) - $ + f7*f5*f5 * src2(is+3,js+1,ks+1) - $ + f8*f5*f5 * src2(is+4,js+1,ks+1) - $ + f1*f6*f5 * src2(is-3,js+2,ks+1) - $ + f2*f6*f5 * src2(is-2,js+2,ks+1) - $ + f3*f6*f5 * src2(is-1,js+2,ks+1) - $ + f4*f6*f5 * src2(is ,js+2,ks+1) - $ + f5*f6*f5 * src2(is+1,js+2,ks+1) - $ + f6*f6*f5 * src2(is+2,js+2,ks+1) - $ + f7*f6*f5 * src2(is+3,js+2,ks+1) - $ + f8*f6*f5 * src2(is+4,js+2,ks+1) - $ + f1*f7*f5 * src2(is-3,js+3,ks+1) - $ + f2*f7*f5 * src2(is-2,js+3,ks+1) - $ + f3*f7*f5 * src2(is-1,js+3,ks+1) - $ + f4*f7*f5 * src2(is ,js+3,ks+1) - $ + f5*f7*f5 * src2(is+1,js+3,ks+1) - $ + f6*f7*f5 * src2(is+2,js+3,ks+1) - $ + f7*f7*f5 * src2(is+3,js+3,ks+1) - $ + f8*f7*f5 * src2(is+4,js+3,ks+1) - $ + f1*f8*f5 * src2(is-3,js+4,ks+1) - $ + f2*f8*f5 * src2(is-2,js+4,ks+1) - $ + f3*f8*f5 * src2(is-1,js+4,ks+1) - $ + f4*f8*f5 * src2(is ,js+4,ks+1) - $ + f5*f8*f5 * src2(is+1,js+4,ks+1) - $ + f6*f8*f5 * src2(is+2,js+4,ks+1) - $ + f7*f8*f5 * src2(is+3,js+4,ks+1) - $ + f8*f8*f5 * src2(is+4,js+4,ks+1) - res26 = - $ + f1*f1*f6 * src2(is-3,js-3,ks+2) - $ + f2*f1*f6 * src2(is-2,js-3,ks+2) - $ + f3*f1*f6 * src2(is-1,js-3,ks+2) - $ + f4*f1*f6 * src2(is ,js-3,ks+2) - $ + f5*f1*f6 * src2(is+1,js-3,ks+2) - $ + f6*f1*f6 * src2(is+2,js-3,ks+2) - $ + f7*f1*f6 * src2(is+3,js-3,ks+2) - $ + f8*f1*f6 * src2(is+4,js-3,ks+2) - $ + f1*f2*f6 * src2(is-3,js-2,ks+2) - $ + f2*f2*f6 * src2(is-2,js-2,ks+2) - $ + f3*f2*f6 * src2(is-1,js-2,ks+2) - $ + f4*f2*f6 * src2(is ,js-2,ks+2) - $ + f5*f2*f6 * src2(is+1,js-2,ks+2) - $ + f6*f2*f6 * src2(is+2,js-2,ks+2) - $ + f7*f2*f6 * src2(is+3,js-2,ks+2) - $ + f8*f2*f6 * src2(is+4,js-2,ks+2) - $ + f1*f3*f6 * src2(is-3,js-1,ks+2) - $ + f2*f3*f6 * src2(is-2,js-1,ks+2) - $ + f3*f3*f6 * src2(is-1,js-1,ks+2) - $ + f4*f3*f6 * src2(is ,js-1,ks+2) - $ + f5*f3*f6 * src2(is+1,js-1,ks+2) - $ + f6*f3*f6 * src2(is+2,js-1,ks+2) - $ + f7*f3*f6 * src2(is+3,js-1,ks+2) - $ + f8*f3*f6 * src2(is+4,js-1,ks+2) - $ + f1*f4*f6 * src2(is-3,js ,ks+2) - $ + f2*f4*f6 * src2(is-2,js ,ks+2) - $ + f3*f4*f6 * src2(is-1,js ,ks+2) - $ + f4*f4*f6 * src2(is ,js ,ks+2) - $ + f5*f4*f6 * src2(is+1,js ,ks+2) - $ + f6*f4*f6 * src2(is+2,js ,ks+2) - $ + f7*f4*f6 * src2(is+3,js ,ks+2) - $ + f8*f4*f6 * src2(is+4,js ,ks+2) - $ + f1*f5*f6 * src2(is-3,js+1,ks+2) - $ + f2*f5*f6 * src2(is-2,js+1,ks+2) - $ + f3*f5*f6 * src2(is-1,js+1,ks+2) - $ + f4*f5*f6 * src2(is ,js+1,ks+2) - $ + f5*f5*f6 * src2(is+1,js+1,ks+2) - $ + f6*f5*f6 * src2(is+2,js+1,ks+2) - $ + f7*f5*f6 * src2(is+3,js+1,ks+2) - $ + f8*f5*f6 * src2(is+4,js+1,ks+2) - $ + f1*f6*f6 * src2(is-3,js+2,ks+2) - $ + f2*f6*f6 * src2(is-2,js+2,ks+2) - $ + f3*f6*f6 * src2(is-1,js+2,ks+2) - $ + f4*f6*f6 * src2(is ,js+2,ks+2) - $ + f5*f6*f6 * src2(is+1,js+2,ks+2) - $ + f6*f6*f6 * src2(is+2,js+2,ks+2) - $ + f7*f6*f6 * src2(is+3,js+2,ks+2) - $ + f8*f6*f6 * src2(is+4,js+2,ks+2) - $ + f1*f7*f6 * src2(is-3,js+3,ks+2) - $ + f2*f7*f6 * src2(is-2,js+3,ks+2) - $ + f3*f7*f6 * src2(is-1,js+3,ks+2) - $ + f4*f7*f6 * src2(is ,js+3,ks+2) - $ + f5*f7*f6 * src2(is+1,js+3,ks+2) - $ + f6*f7*f6 * src2(is+2,js+3,ks+2) - $ + f7*f7*f6 * src2(is+3,js+3,ks+2) - $ + f8*f7*f6 * src2(is+4,js+3,ks+2) - $ + f1*f8*f6 * src2(is-3,js+4,ks+2) - $ + f2*f8*f6 * src2(is-2,js+4,ks+2) - $ + f3*f8*f6 * src2(is-1,js+4,ks+2) - $ + f4*f8*f6 * src2(is ,js+4,ks+2) - $ + f5*f8*f6 * src2(is+1,js+4,ks+2) - $ + f6*f8*f6 * src2(is+2,js+4,ks+2) - $ + f7*f8*f6 * src2(is+3,js+4,ks+2) - $ + f8*f8*f6 * src2(is+4,js+4,ks+2) - res27 = - $ + f1*f1*f7 * src2(is-3,js-3,ks+3) - $ + f2*f1*f7 * src2(is-2,js-3,ks+3) - $ + f3*f1*f7 * src2(is-1,js-3,ks+3) - $ + f4*f1*f7 * src2(is ,js-3,ks+3) - $ + f5*f1*f7 * src2(is+1,js-3,ks+3) - $ + f6*f1*f7 * src2(is+2,js-3,ks+3) - $ + f7*f1*f7 * src2(is+3,js-3,ks+3) - $ + f8*f1*f7 * src2(is+4,js-3,ks+3) - $ + f1*f2*f7 * src2(is-3,js-2,ks+3) - $ + f2*f2*f7 * src2(is-2,js-2,ks+3) - $ + f3*f2*f7 * src2(is-1,js-2,ks+3) - $ + f4*f2*f7 * src2(is ,js-2,ks+3) - $ + f5*f2*f7 * src2(is+1,js-2,ks+3) - $ + f6*f2*f7 * src2(is+2,js-2,ks+3) - $ + f7*f2*f7 * src2(is+3,js-2,ks+3) - $ + f8*f2*f7 * src2(is+4,js-2,ks+3) - $ + f1*f3*f7 * src2(is-3,js-1,ks+3) - $ + f2*f3*f7 * src2(is-2,js-1,ks+3) - $ + f3*f3*f7 * src2(is-1,js-1,ks+3) - $ + f4*f3*f7 * src2(is ,js-1,ks+3) - $ + f5*f3*f7 * src2(is+1,js-1,ks+3) - $ + f6*f3*f7 * src2(is+2,js-1,ks+3) - $ + f7*f3*f7 * src2(is+3,js-1,ks+3) - $ + f8*f3*f7 * src2(is+4,js-1,ks+3) - $ + f1*f4*f7 * src2(is-3,js ,ks+3) - $ + f2*f4*f7 * src2(is-2,js ,ks+3) - $ + f3*f4*f7 * src2(is-1,js ,ks+3) - $ + f4*f4*f7 * src2(is ,js ,ks+3) - $ + f5*f4*f7 * src2(is+1,js ,ks+3) - $ + f6*f4*f7 * src2(is+2,js ,ks+3) - $ + f7*f4*f7 * src2(is+3,js ,ks+3) - $ + f8*f4*f7 * src2(is+4,js ,ks+3) - $ + f1*f5*f7 * src2(is-3,js+1,ks+3) - $ + f2*f5*f7 * src2(is-2,js+1,ks+3) - $ + f3*f5*f7 * src2(is-1,js+1,ks+3) - $ + f4*f5*f7 * src2(is ,js+1,ks+3) - $ + f5*f5*f7 * src2(is+1,js+1,ks+3) - $ + f6*f5*f7 * src2(is+2,js+1,ks+3) - $ + f7*f5*f7 * src2(is+3,js+1,ks+3) - $ + f8*f5*f7 * src2(is+4,js+1,ks+3) - $ + f1*f6*f7 * src2(is-3,js+2,ks+3) - $ + f2*f6*f7 * src2(is-2,js+2,ks+3) - $ + f3*f6*f7 * src2(is-1,js+2,ks+3) - $ + f4*f6*f7 * src2(is ,js+2,ks+3) - $ + f5*f6*f7 * src2(is+1,js+2,ks+3) - $ + f6*f6*f7 * src2(is+2,js+2,ks+3) - $ + f7*f6*f7 * src2(is+3,js+2,ks+3) - $ + f8*f6*f7 * src2(is+4,js+2,ks+3) - $ + f1*f7*f7 * src2(is-3,js+3,ks+3) - $ + f2*f7*f7 * src2(is-2,js+3,ks+3) - $ + f3*f7*f7 * src2(is-1,js+3,ks+3) - $ + f4*f7*f7 * src2(is ,js+3,ks+3) - $ + f5*f7*f7 * src2(is+1,js+3,ks+3) - $ + f6*f7*f7 * src2(is+2,js+3,ks+3) - $ + f7*f7*f7 * src2(is+3,js+3,ks+3) - $ + f8*f7*f7 * src2(is+4,js+3,ks+3) - $ + f1*f8*f7 * src2(is-3,js+4,ks+3) - $ + f2*f8*f7 * src2(is-2,js+4,ks+3) - $ + f3*f8*f7 * src2(is-1,js+4,ks+3) - $ + f4*f8*f7 * src2(is ,js+4,ks+3) - $ + f5*f8*f7 * src2(is+1,js+4,ks+3) - $ + f6*f8*f7 * src2(is+2,js+4,ks+3) - $ + f7*f8*f7 * src2(is+3,js+4,ks+3) - $ + f8*f8*f7 * src2(is+4,js+4,ks+3) - res28 = - $ + f1*f1*f8 * src2(is-3,js-3,ks+4) - $ + f2*f1*f8 * src2(is-2,js-3,ks+4) - $ + f3*f1*f8 * src2(is-1,js-3,ks+4) - $ + f4*f1*f8 * src2(is ,js-3,ks+4) - $ + f5*f1*f8 * src2(is+1,js-3,ks+4) - $ + f6*f1*f8 * src2(is+2,js-3,ks+4) - $ + f7*f1*f8 * src2(is+3,js-3,ks+4) - $ + f8*f1*f8 * src2(is+4,js-3,ks+4) - $ + f1*f2*f8 * src2(is-3,js-2,ks+4) - $ + f2*f2*f8 * src2(is-2,js-2,ks+4) - $ + f3*f2*f8 * src2(is-1,js-2,ks+4) - $ + f4*f2*f8 * src2(is ,js-2,ks+4) - $ + f5*f2*f8 * src2(is+1,js-2,ks+4) - $ + f6*f2*f8 * src2(is+2,js-2,ks+4) - $ + f7*f2*f8 * src2(is+3,js-2,ks+4) - $ + f8*f2*f8 * src2(is+4,js-2,ks+4) - $ + f1*f3*f8 * src2(is-3,js-1,ks+4) - $ + f2*f3*f8 * src2(is-2,js-1,ks+4) - $ + f3*f3*f8 * src2(is-1,js-1,ks+4) - $ + f4*f3*f8 * src2(is ,js-1,ks+4) - $ + f5*f3*f8 * src2(is+1,js-1,ks+4) - $ + f6*f3*f8 * src2(is+2,js-1,ks+4) - $ + f7*f3*f8 * src2(is+3,js-1,ks+4) - $ + f8*f3*f8 * src2(is+4,js-1,ks+4) - $ + f1*f4*f8 * src2(is-3,js ,ks+4) - $ + f2*f4*f8 * src2(is-2,js ,ks+4) - $ + f3*f4*f8 * src2(is-1,js ,ks+4) - $ + f4*f4*f8 * src2(is ,js ,ks+4) - $ + f5*f4*f8 * src2(is+1,js ,ks+4) - $ + f6*f4*f8 * src2(is+2,js ,ks+4) - $ + f7*f4*f8 * src2(is+3,js ,ks+4) - $ + f8*f4*f8 * src2(is+4,js ,ks+4) - $ + f1*f5*f8 * src2(is-3,js+1,ks+4) - $ + f2*f5*f8 * src2(is-2,js+1,ks+4) - $ + f3*f5*f8 * src2(is-1,js+1,ks+4) - $ + f4*f5*f8 * src2(is ,js+1,ks+4) - $ + f5*f5*f8 * src2(is+1,js+1,ks+4) - $ + f6*f5*f8 * src2(is+2,js+1,ks+4) - $ + f7*f5*f8 * src2(is+3,js+1,ks+4) - $ + f8*f5*f8 * src2(is+4,js+1,ks+4) - $ + f1*f6*f8 * src2(is-3,js+2,ks+4) - $ + f2*f6*f8 * src2(is-2,js+2,ks+4) - $ + f3*f6*f8 * src2(is-1,js+2,ks+4) - $ + f4*f6*f8 * src2(is ,js+2,ks+4) - $ + f5*f6*f8 * src2(is+1,js+2,ks+4) - $ + f6*f6*f8 * src2(is+2,js+2,ks+4) - $ + f7*f6*f8 * src2(is+3,js+2,ks+4) - $ + f8*f6*f8 * src2(is+4,js+2,ks+4) - $ + f1*f7*f8 * src2(is-3,js+3,ks+4) - $ + f2*f7*f8 * src2(is-2,js+3,ks+4) - $ + f3*f7*f8 * src2(is-1,js+3,ks+4) - $ + f4*f7*f8 * src2(is ,js+3,ks+4) - $ + f5*f7*f8 * src2(is+1,js+3,ks+4) - $ + f6*f7*f8 * src2(is+2,js+3,ks+4) - $ + f7*f7*f8 * src2(is+3,js+3,ks+4) - $ + f8*f7*f8 * src2(is+4,js+3,ks+4) - $ + f1*f8*f8 * src2(is-3,js+4,ks+4) - $ + f2*f8*f8 * src2(is-2,js+4,ks+4) - $ + f3*f8*f8 * src2(is-1,js+4,ks+4) - $ + f4*f8*f8 * src2(is ,js+4,ks+4) - $ + f5*f8*f8 * src2(is+1,js+4,ks+4) - $ + f6*f8*f8 * src2(is+2,js+4,ks+4) - $ + f7*f8*f8 * src2(is+3,js+4,ks+4) - $ + f8*f8*f8 * src2(is+4,js+4,ks+4) - dst(id,jd,kd) = - $ + s1fac * (res11 + res12 + res13 + res14 + res15 + res16 + res17 + res18) - $ + s2fac * (res21 + res22 + res23 + res24 + res25 + res26 + res27 + res28) - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8110 - goto 911 - -c end i loop - 911 continue - j = j+1 - jd = jd+1 - js = js+1 - if (j.lt.regjext) goto 810 - goto 91 - -c end j loop - 91 continue - k = k+1 - kd = kd+1 - ks = ks+1 - if (k.lt.regkext) goto 80 - goto 9 - -c end k loop - 9 continue - - end diff --git a/Carpet/CarpetLib/src/prolongate_3d_real8_2tl_rf2.F77 b/Carpet/CarpetLib/src/prolongate_3d_real8_2tl_rf2.F77 deleted file mode 100644 index 5ad32e67e..000000000 --- a/Carpet/CarpetLib/src/prolongate_3d_real8_2tl_rf2.F77 +++ /dev/null @@ -1,401 +0,0 @@ -c -*-Fortran-*- - -#include "cctk.h" -#include "cctk_Parameters.h" - - - - subroutine prolongate_3d_real8_2tl_rf2 ( - $ src1, t1, src2, t2, srciext, srcjext, srckext, - $ dst, t, dstiext, dstjext, dstkext, - $ srcbbox, dstbbox, regbbox) - - implicit none - - DECLARE_CCTK_PARAMETERS - - CCTK_REAL8 eps - parameter (eps = 1.0d-10) - - CCTK_REAL8 one, half, fourth, eighth - parameter (one = 1) - parameter (half = one/2) - parameter (fourth = one/4) - parameter (eighth = one/8) - - integer srciext, srcjext, srckext - CCTK_REAL8 src1(srciext,srcjext,srckext) - CCTK_REAL8 t1 - CCTK_REAL8 src2(srciext,srcjext,srckext) - CCTK_REAL8 t2 - integer dstiext, dstjext, dstkext - CCTK_REAL8 dst(dstiext,dstjext,dstkext) - CCTK_REAL8 t -c bbox(:,1) is lower boundary (inclusive) -c bbox(:,2) is upper boundary (inclusive) -c bbox(:,3) is stride - integer srcbbox(3,3), dstbbox(3,3), regbbox(3,3) - - integer regiext, regjext, regkext - - integer srcioff, srcjoff, srckoff - integer dstioff, dstjoff, dstkoff - - CCTK_REAL8 s1fac, s2fac - - integer i0, j0, k0 - integer fi, fj, fk - integer is, js, ks - integer id, jd, kd - integer i, j, k - - integer d - - - - do d=1,3 - if (srcbbox(d,3).eq.0 .or. dstbbox(d,3).eq.0 - $ .or. regbbox(d,3).eq.0) then - call CCTK_WARN (0, "Internal error: stride is zero") - end if - if (srcbbox(d,3).le.regbbox(d,3) - $ .or. dstbbox(d,3).ne.regbbox(d,3)) then - call CCTK_WARN (0, "Internal error: strides disagree") - end if - if (srcbbox(d,3).ne.dstbbox(d,3)*2) then - call CCTK_WARN (0, "Internal error: source strides are not twice the destination strides") - end if - if (mod(srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array origins are not integer multiples of the strides") - end if - if (regbbox(d,1).gt.regbbox(d,2)) then -c This could be handled, but is likely to point to an error elsewhere - call CCTK_WARN (0, "Internal error: region extent is empty") - end if - if (mod(srcbbox(d,2) - srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,2) - dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,2) - regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array extents are not integer multiples of the strides") - end if - if (regbbox(d,1).lt.srcbbox(d,1) - $ .or. regbbox(d,1).lt.dstbbox(d,1) - $ .or. regbbox(d,2).gt.srcbbox(d,2) - $ .or. regbbox(d,2).gt.dstbbox(d,2)) then - call CCTK_WARN (0, "Internal error: region extent is not contained in array extent") - end if - end do - - if (srciext.ne.(srcbbox(1,2)-srcbbox(1,1))/srcbbox(1,3)+1 - $ .or. srcjext.ne.(srcbbox(2,2)-srcbbox(2,1))/srcbbox(2,3)+1 - $ .or. srckext.ne.(srcbbox(3,2)-srcbbox(3,1))/srcbbox(3,3)+1 - $ .or. dstiext.ne.(dstbbox(1,2)-dstbbox(1,1))/dstbbox(1,3)+1 - $ .or. dstjext.ne.(dstbbox(2,2)-dstbbox(2,1))/dstbbox(2,3)+1 - $ .or. dstkext.ne.(dstbbox(3,2)-dstbbox(3,1))/dstbbox(3,3)+1) then - call CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes") - end if - - - - regiext = (regbbox(1,2) - regbbox(1,1)) / regbbox(1,3) + 1 - regjext = (regbbox(2,2) - regbbox(2,1)) / regbbox(2,3) + 1 - regkext = (regbbox(3,2) - regbbox(3,1)) / regbbox(3,3) + 1 - - srcioff = (regbbox(1,1) - srcbbox(1,1)) / dstbbox(1,3) - srcjoff = (regbbox(2,1) - srcbbox(2,1)) / dstbbox(2,3) - srckoff = (regbbox(3,1) - srcbbox(3,1)) / dstbbox(3,3) - - dstioff = (regbbox(1,1) - dstbbox(1,1)) / dstbbox(1,3) - dstjoff = (regbbox(2,1) - dstbbox(2,1)) / dstbbox(2,3) - dstkoff = (regbbox(3,1) - dstbbox(3,1)) / dstbbox(3,3) - - - -c Quadratic (second order) time interpolation - if (t1.eq.t2) then - call CCTK_WARN (0, "Internal error: arrays have same time") - end if - if (t.lt.min(t1,t2)-eps .or. t.gt.max(t1,t2)+eps) then - call CCTK_WARN (0, "Internal error: extrapolation in time") - end if - - s1fac = (t - t2) / (t1 - t2) - s2fac = (t - t1) / (t2 - t1) - - - - fi = mod(srcioff, 2) - fj = mod(srcjoff, 2) - fk = mod(srckoff, 2) - - i0 = srcioff / 2 - j0 = srcjoff / 2 - k0 = srckoff / 2 - - - -c Loop over fine region -c Label scheme: 8 fk fj fi - -c begin k loop - 8 continue - k = 0 - ks = k0+1 - kd = dstkoff+1 - if (fk.eq.0) goto 80 - if (fk.eq.1) goto 81 - stop - -c begin j loop - 80 continue - j = 0 - js = j0+1 - jd = dstjoff+1 - if (fj.eq.0) goto 800 - if (fj.eq.1) goto 801 - stop - -c begin i loop - 800 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8000 - if (fi.eq.1) goto 8001 - stop - -c kernel - 8000 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js,ks, 1,1,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + s1fac * src1(is,js,ks) - $ + s2fac * src2(is,js,ks) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8001 - goto 900 - -c kernel - 8001 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js,ks, 2,1,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + half * s1fac * src1(is,js,ks) + half * s1fac * src1(is+1,js,ks) - $ + half * s2fac * src2(is,js,ks) + half * s2fac * src2(is+1,js,ks) - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8000 - goto 900 - -c end i loop - 900 continue - j = j+1 - jd = jd+1 - if (j.lt.regjext) goto 801 - goto 90 - -c begin i loop - 801 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8010 - if (fi.eq.1) goto 8011 - stop - -c kernel - 8010 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js,ks, 1,2,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + half * s1fac * src1(is,js,ks) + half * s1fac * src1(is,js+1,ks) - $ + half * s2fac * src2(is,js,ks) + half * s2fac * src2(is,js+1,ks) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8011 - goto 901 - -c kernel - 8011 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js,ks, 2,2,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + fourth * s1fac * src1(is,js,ks) - $ + fourth * s1fac * src1(is+1,js,ks) - $ + fourth * s1fac * src1(is,js+1,ks) - $ + fourth * s1fac * src1(is+1,js+1,ks) - $ + fourth * s2fac * src2(is,js,ks) - $ + fourth * s2fac * src2(is+1,js,ks) - $ + fourth * s2fac * src2(is,js+1,ks) - $ + fourth * s2fac * src2(is+1,js+1,ks) - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8010 - goto 901 - -c end i loop - 901 continue - j = j+1 - jd = jd+1 - js = js+1 - if (j.lt.regjext) goto 800 - goto 90 - -c end j loop - 90 continue - k = k+1 - kd = kd+1 - if (k.lt.regkext) goto 81 - goto 9 - -c begin j loop - 81 continue - j = 0 - js = j0+1 - jd = dstjoff+1 - if (fj.eq.0) goto 810 - if (fj.eq.1) goto 811 - stop - -c begin i loop - 810 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8100 - if (fi.eq.1) goto 8101 - stop - -c kernel - 8100 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js,ks, 1,1,2, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + half * s1fac * src1(is,js,ks) + half * s1fac * src1(is,js,ks+1) - $ + half * s2fac * src2(is,js,ks) + half * s2fac * src2(is,js,ks+1) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8101 - goto 910 - -c kernel - 8101 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js,ks, 2,1,2, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + fourth * s1fac * src1(is,js,ks) - $ + fourth * s1fac * src1(is+1,js,ks) - $ + fourth * s1fac * src1(is,js,ks+1) - $ + fourth * s1fac * src1(is+1,js,ks+1) - $ + fourth * s2fac * src1(is,js,ks) - $ + fourth * s2fac * src2(is+1,js,ks) - $ + fourth * s2fac * src2(is,js,ks+1) - $ + fourth * s2fac * src2(is+1,js,ks+1) - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8100 - goto 910 - -c end i loop - 910 continue - j = j+1 - jd = jd+1 - if (j.lt.regjext) goto 811 - goto 91 - -c begin i loop - 811 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8110 - if (fi.eq.1) goto 8111 - stop - -c kernel - 8110 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js,ks, 1,2,2, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + fourth * s1fac * src1(is,js,ks) - $ + fourth * s1fac * src1(is,js+1,ks) - $ + fourth * s1fac * src1(is,js,ks+1) - $ + fourth * s1fac * src1(is,js+1,ks+1) - $ + fourth * s2fac * src2(is,js,ks) - $ + fourth * s2fac * src2(is,js+1,ks) - $ + fourth * s2fac * src2(is,js,ks+1) - $ + fourth * s2fac * src2(is,js+1,ks+1) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8111 - goto 911 - -c kernel - 8111 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js,ks, 2,2,2, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + eighth * s1fac * src1(is,js,ks) - $ + eighth * s1fac * src1(is+1,js,ks) - $ + eighth * s1fac * src1(is,js+1,ks) - $ + eighth * s1fac * src1(is+1,js+1,ks) - $ + eighth * s1fac * src1(is,js,ks+1) - $ + eighth * s1fac * src1(is+1,js,ks+1) - $ + eighth * s1fac * src1(is,js+1,ks+1) - $ + eighth * s1fac * src1(is+1,js+1,ks+1) - $ - $ + eighth * s2fac * src2(is,js,ks) - $ + eighth * s2fac * src2(is+1,js,ks) - $ + eighth * s2fac * src2(is,js+1,ks) - $ + eighth * s2fac * src2(is+1,js+1,ks) - $ + eighth * s2fac * src2(is,js,ks+1) - $ + eighth * s2fac * src2(is+1,js,ks+1) - $ + eighth * s2fac * src2(is,js+1,ks+1) - $ + eighth * s2fac * src2(is+1,js+1,ks+1) - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8110 - goto 911 - -c end i loop - 911 continue - j = j+1 - jd = jd+1 - js = js+1 - if (j.lt.regjext) goto 810 - goto 91 - -c end j loop - 91 continue - k = k+1 - kd = kd+1 - ks = ks+1 - if (k.lt.regkext) goto 80 - goto 9 - -c end k loop - 9 continue - - end diff --git a/Carpet/CarpetLib/src/prolongate_3d_real8_2tl_weno.F90 b/Carpet/CarpetLib/src/prolongate_3d_real8_2tl_weno.F90 deleted file mode 100644 index 724a94b4b..000000000 --- a/Carpet/CarpetLib/src/prolongate_3d_real8_2tl_weno.F90 +++ /dev/null @@ -1,298 +0,0 @@ -#ifndef OMIT_F90 -!!$ -*-Fortran-*- - -#include "cctk.h" - - -!!$ This routine performs "WENO" prolongation. It is intended to be used -!!$ with GFs that are not expected to be smooth, particularly those -!!$ that must also obey certain constraints. The obvious example is the -!!$ density in hydrodynamics, which may be discontinuous yet must be -!!$ strictly positive. -!!$ -!!$ To ensure that this prolongation method is used you should add the -!!$ tag -!!$ -!!$ tags='Prolongation="WENO"' -!!$ -!!$ to the interface.ccl on the appropriate group. -!!$ -!!$ This applies WENO3 type limiting to the slope, checking over the -!!$ entire coarse grid cell for the least oscillatory quadratic in each -!!$ direction. If the slope changes sign over the extrema, linear -!!$ interpolation is used instead. -!!$ -!!$ The actual weno1d function is defined in the routine -!!$ -!!$ prolongate_3d_real8_weno.F77 - - -#define CHKIDX(i,j,k, imax,jmax,kmax, where) \ -if ((i).lt.1 .or. (i).gt.(imax) \ - .or. (j).lt.1 .or. (j).gt.(jmax) \ - .or. (k).lt.1 .or. (k).gt.(kmax)) then &&\ - write (msg, '(a, " array index out of bounds: shape is (",i4,",",i4,",",i4,"), index is (",i4,",",i4,",",i4,")")') \ - (where), (imax), (jmax), (kmax), (i), (j), (k) &&\ - call CCTK_WARN (0, msg(1:len_trim(msg))) &&\ -end if - -subroutine prolongate_3d_real8_2tl_weno (src1, t1, src2, t2, & - srciext, srcjext, srckext, dst, t, dstiext, dstjext, dstkext, & - srcbbox, dstbbox, regbbox) - - implicit none - - CCTK_REAL8 one - parameter (one = 1) - - CCTK_REAL8 eps - parameter (eps = 1.0d-10) - - integer srciext, srcjext, srckext - CCTK_REAL8 src1(srciext,srcjext,srckext) - CCTK_REAL8 t1 - CCTK_REAL8 src2(srciext,srcjext,srckext) - CCTK_REAL8 t2 - integer dstiext, dstjext, dstkext - CCTK_REAL8 dst(dstiext,dstjext,dstkext) - CCTK_REAL8 t - -!!$ bbox(:,1) is lower boundary (inclusive) -!!$ bbox(:,2) is upper boundary (inclusive) -!!$ bbox(:,3) is stride - integer srcbbox(3,3), dstbbox(3,3), regbbox(3,3) - - integer offsetlo, offsethi - - integer regiext, regjext, regkext - - integer dstifac, dstjfac, dstkfac - - integer srcioff, srcjoff, srckoff - integer dstioff, dstjoff, dstkoff - - CCTK_REAL8 s1fac, s2fac - - integer i, j, k - integer i0, j0, k0 - integer fi, fj, fk - integer ii, jj, kk - integer d - - CCTK_REAL8, dimension(0:4,0:4) :: tmp1 - CCTK_REAL8, dimension(0:4) :: tmp2 - CCTK_REAL8 :: dsttmp1, dsttmp2 - - external weno1d - CCTK_REAL8 weno1d - - CCTK_REAL8 half, zero - parameter (half = 0.5) - parameter (zero = 0) - - do d=1,3 - if (srcbbox(d,3).eq.0 .or. dstbbox(d,3).eq.0 & - .or. regbbox(d,3).eq.0) then - call CCTK_WARN (0, "Internal error: stride is zero") - end if - if (srcbbox(d,3).le.regbbox(d,3) & - .or. dstbbox(d,3).ne.regbbox(d,3)) then - call CCTK_WARN (0, "Internal error: strides disagree") - end if - if (mod(srcbbox(d,3), dstbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: destination strides are not integer multiples of the source strides") - end if - if (mod(srcbbox(d,1), srcbbox(d,3)).ne.0 & - .or. mod(dstbbox(d,1), dstbbox(d,3)).ne.0 & - .or. mod(regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array origins are not integer multiples of the strides") - end if - if (regbbox(d,1).gt.regbbox(d,2)) then -!!$ This could be handled, but is likely to point to an error elsewhere - call CCTK_WARN (0, "Internal error: region extent is empty") - end if - regkext = (regbbox(d,2) - regbbox(d,1)) / regbbox(d,3) + 1 - dstkfac = srcbbox(d,3) / dstbbox(d,3) - srckoff = (regbbox(d,1) - srcbbox(d,1)) / dstbbox(d,3) - offsetlo = regbbox(d,3) - if (mod(srckoff + 0, dstkfac).eq.0) then - offsetlo = 0 - if (regkext.gt.1) then - offsetlo = regbbox(d,3) - end if - end if - offsethi = regbbox(d,3) - if (mod(srckoff + regkext-1, dstkfac).eq.0) then - offsethi = 0 - if (regkext.gt.1) then - offsethi = regbbox(d,3) - end if - end if - if (regbbox(d,1)-offsetlo.lt.srcbbox(d,1) & - .or. regbbox(d,2)+offsethi.gt.srcbbox(d,2) & - .or. regbbox(d,1).lt.dstbbox(d,1) & - .or. regbbox(d,2).gt.dstbbox(d,2)) then - call CCTK_WARN (0, "Internal error: region extent is not contained in array extent") - end if - end do - - if (srciext.ne.(srcbbox(1,2)-srcbbox(1,1))/srcbbox(1,3)+1 & - .or. srcjext.ne.(srcbbox(2,2)-srcbbox(2,1))/srcbbox(2,3)+1 & - .or. srckext.ne.(srcbbox(3,2)-srcbbox(3,1))/srcbbox(3,3)+1 & - .or. dstiext.ne.(dstbbox(1,2)-dstbbox(1,1))/dstbbox(1,3)+1 & - .or. dstjext.ne.(dstbbox(2,2)-dstbbox(2,1))/dstbbox(2,3)+1 & - .or. dstkext.ne.(dstbbox(3,2)-dstbbox(3,1))/dstbbox(3,3)+1) then - call CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes") - end if - - regiext = (regbbox(1,2) - regbbox(1,1)) / regbbox(1,3) + 1 - regjext = (regbbox(2,2) - regbbox(2,1)) / regbbox(2,3) + 1 - regkext = (regbbox(3,2) - regbbox(3,1)) / regbbox(3,3) + 1 - - dstifac = srcbbox(1,3) / dstbbox(1,3) - dstjfac = srcbbox(2,3) / dstbbox(2,3) - dstkfac = srcbbox(3,3) / dstbbox(3,3) - - srcioff = (regbbox(1,1) - srcbbox(1,1)) / dstbbox(1,3) - srcjoff = (regbbox(2,1) - srcbbox(2,1)) / dstbbox(2,3) - srckoff = (regbbox(3,1) - srcbbox(3,1)) / dstbbox(3,3) - - dstioff = (regbbox(1,1) - dstbbox(1,1)) / dstbbox(1,3) - dstjoff = (regbbox(2,1) - dstbbox(2,1)) / dstbbox(2,3) - dstkoff = (regbbox(3,1) - dstbbox(3,1)) / dstbbox(3,3) - -!!$ Linear (first order) interpolation - if (t1.eq.t2) then - call CCTK_WARN (0, "Internal error: arrays have same time") - end if - if (t.lt.min(t1,t2)-eps .or. t.gt.max(t1,t2)+eps) then - call CCTK_WARN (0, "Internal error: extrapolation in time") - end if - - s1fac = (t - t2) / (t1 - t2) - s2fac = (t - t1) / (t2 - t1) - -!!$ Loop over fine region - - do k = 0, regkext-1 - k0 = (srckoff + k) / dstkfac - fk = mod(srckoff + k, dstkfac) - - do j = 0, regjext-1 - j0 = (srcjoff + j) / dstjfac - fj = mod(srcjoff + j, dstjfac) - - do i = 0, regiext-1 - i0 = (srcioff + i) / dstifac - fi = mod(srcioff + i, dstifac) - -!!$ Where is the fine grid point w.r.t the coarse grid? - - select case (fi + 10*fj + 100*fk) - case (0) -!!$ On a coarse grid point exactly! - - dsttmp1 = src1(i0+1,j0+1,k0+1) - dsttmp2 = src2(i0+1,j0+1,k0+1) - - case (1) -!!$ Interpolate only in x - - dsttmp1 = weno1d(src1(i0-1:i0+3,j0+1,k0+1)) - dsttmp2 = weno1d(src2(i0-1:i0+3,j0+1,k0+1)) - - case (10) -!!$ Interpolate only in y - - dsttmp1 = weno1d(src1(i0+1,j0-1:j0+3,k0+1)) - dsttmp2 = weno1d(src2(i0+1,j0-1:j0+3,k0+1)) - - case (11) -!!$ Interpolate only in x and y - - do jj = 0, 4 - tmp2(jj) = weno1d(src1(i0-1:i0+3,j0+jj-1,k0+1)) - end do - - dsttmp1 = weno1d(tmp2(0:4)) - - do jj = 0, 4 - tmp2(jj) = weno1d(src2(i0-1:i0+3,j0+jj-1,k0+1)) - end do - - dsttmp2 = weno1d(tmp2(0:4)) - - case (100) -!!$ Interpolate only in z - - dsttmp1 = weno1d(src1(i0+1,j0+1,k0-1:k0+3)) - dsttmp2 = weno1d(src2(i0+1,j0+1,k0-1:k0+3)) - - case (101) -!!$ Interpolate only in x and z - - do kk = 0, 4 - tmp2(kk) = weno1d(src1(i0-1:i0+3,j0+1,k0+kk-1)) - end do - - dsttmp1 = weno1d(tmp2(0:3)) - - do kk = 0, 4 - tmp2(kk) = weno1d(src2(i0-1:i0+3,j0+1,k0+kk-1)) - end do - - dsttmp2 = weno1d(tmp2(0:4)) - - case (110) -!!$ Interpolate only in y and z - - do kk = 0, 4 - tmp2(kk) = weno1d(src1(i0+1,j0-1:j0+3,k0+kk-1)) - end do - - dsttmp1 = weno1d(tmp2(0:4)) - - do kk = 0, 4 - tmp2(kk) = weno1d(src2(i0+1,j0-1:j0+3,k0+kk-1)) - end do - - dsttmp2 = weno1d(tmp2(0:4)) - - case (111) -!!$ Interpolate in all of x, y, and z - - do jj = 0, 4 - do kk = 0, 4 - tmp1(jj,kk) = weno1d(src1(i0-1:i0+3,j0+jj-1,k0+kk-1)) - end do - end do - do ii = 0, 4 - tmp2(ii) = weno1d(tmp1(0:4,ii)) - end do - - dsttmp1 = weno1d(tmp2(0:4)) - - do jj = 0, 4 - do kk = 0, 4 - tmp1(jj,kk) = weno1d(src2(i0-1:i0+3,j0+jj-1,k0+kk-1)) - end do - end do - do ii = 0, 4 - tmp2(ii) = weno1d(tmp1(0:4,ii)) - end do - - dsttmp2 = weno1d(tmp2(0:4)) - - case default - call CCTK_WARN(0, "Internal error in WENO prolongation. Should only be used with refinement factor 2!") - end select - - dst (dstioff+i+1, dstjoff+j+1, dstkoff+k+1) = & - s1fac * dsttmp1 + s2fac * dsttmp2 - - end do - end do - end do - -end subroutine prolongate_3d_real8_2tl_weno -#endif /* !OMIT_F90 */ diff --git a/Carpet/CarpetLib/src/prolongate_3d_real8_3tl.F77 b/Carpet/CarpetLib/src/prolongate_3d_real8_3tl.F77 deleted file mode 100644 index 6cb09a6b8..000000000 --- a/Carpet/CarpetLib/src/prolongate_3d_real8_3tl.F77 +++ /dev/null @@ -1,188 +0,0 @@ -c -*-Fortran-*- - -#include "cctk.h" -#include "cctk_Parameters.h" - - - - subroutine prolongate_3d_real8_3tl ( - $ src1, t1, src2, t2, src3, t3, srciext, srcjext, srckext, - $ dst, t, dstiext, dstjext, dstkext, - $ srcbbox, dstbbox, regbbox) - - implicit none - - DECLARE_CCTK_PARAMETERS - - CCTK_REAL8 one - parameter (one = 1) - - CCTK_REAL8 eps - parameter (eps = 1.0d-10) - - integer srciext, srcjext, srckext - CCTK_REAL8 src1(srciext,srcjext,srckext) - CCTK_REAL8 t1 - CCTK_REAL8 src2(srciext,srcjext,srckext) - CCTK_REAL8 t2 - CCTK_REAL8 src3(srciext,srcjext,srckext) - CCTK_REAL8 t3 - integer dstiext, dstjext, dstkext - CCTK_REAL8 dst(dstiext,dstjext,dstkext) - CCTK_REAL8 t -c bbox(:,1) is lower boundary (inclusive) -c bbox(:,2) is upper boundary (inclusive) -c bbox(:,3) is stride - integer srcbbox(3,3), dstbbox(3,3), regbbox(3,3) - - integer regiext, regjext, regkext - - integer dstifac, dstjfac, dstkfac - - integer srcioff, srcjoff, srckoff - integer dstioff, dstjoff, dstkoff - - CCTK_REAL8 s1fac, s2fac, s3fac - - CCTK_REAL8 dstdiv - integer i, j, k - integer i0, j0, k0 - integer fi, fj, fk - integer ifac(2), jfac(2), kfac(2) - integer ii, jj, kk - integer fac - CCTK_REAL8 res - integer d - - - - do d=1,3 - if (srcbbox(d,3).eq.0 .or. dstbbox(d,3).eq.0 - $ .or. regbbox(d,3).eq.0) then - call CCTK_WARN (0, "Internal error: stride is zero") - end if - if (srcbbox(d,3).le.regbbox(d,3) - $ .or. dstbbox(d,3).ne.regbbox(d,3)) then - call CCTK_WARN (0, "Internal error: strides disagree") - end if - if (mod(srcbbox(d,3), dstbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: destination strides are not integer multiples of the source strides") - end if - if (mod(srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array origins are not integer multiples of the strides") - end if - if (regbbox(d,1).gt.regbbox(d,2)) then -c This could be handled, but is likely to point to an error elsewhere - call CCTK_WARN (0, "Internal error: region extent is empty") - end if - if (mod(srcbbox(d,2) - srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,2) - dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,2) - regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array extents are not integer multiples of the strides") - end if - if (regbbox(d,1).lt.srcbbox(d,1) - $ .or. regbbox(d,1).lt.dstbbox(d,1) - $ .or. regbbox(d,2).gt.srcbbox(d,2) - $ .or. regbbox(d,2).gt.dstbbox(d,2)) then - call CCTK_WARN (0, "Internal error: region extent is not contained in array extent") - end if - end do - - if (srciext.ne.(srcbbox(1,2)-srcbbox(1,1))/srcbbox(1,3)+1 - $ .or. srcjext.ne.(srcbbox(2,2)-srcbbox(2,1))/srcbbox(2,3)+1 - $ .or. srckext.ne.(srcbbox(3,2)-srcbbox(3,1))/srcbbox(3,3)+1 - $ .or. dstiext.ne.(dstbbox(1,2)-dstbbox(1,1))/dstbbox(1,3)+1 - $ .or. dstjext.ne.(dstbbox(2,2)-dstbbox(2,1))/dstbbox(2,3)+1 - $ .or. dstkext.ne.(dstbbox(3,2)-dstbbox(3,1))/dstbbox(3,3)+1) then - call CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes") - end if - - - - regiext = (regbbox(1,2) - regbbox(1,1)) / regbbox(1,3) + 1 - regjext = (regbbox(2,2) - regbbox(2,1)) / regbbox(2,3) + 1 - regkext = (regbbox(3,2) - regbbox(3,1)) / regbbox(3,3) + 1 - - dstifac = srcbbox(1,3) / dstbbox(1,3) - dstjfac = srcbbox(2,3) / dstbbox(2,3) - dstkfac = srcbbox(3,3) / dstbbox(3,3) - - srcioff = (regbbox(1,1) - srcbbox(1,1)) / dstbbox(1,3) - srcjoff = (regbbox(2,1) - srcbbox(2,1)) / dstbbox(2,3) - srckoff = (regbbox(3,1) - srcbbox(3,1)) / dstbbox(3,3) - - dstioff = (regbbox(1,1) - dstbbox(1,1)) / dstbbox(1,3) - dstjoff = (regbbox(2,1) - dstbbox(2,1)) / dstbbox(2,3) - dstkoff = (regbbox(3,1) - dstbbox(3,1)) / dstbbox(3,3) - - - -c Quadratic (second order) interpolation - if (t1.eq.t2 .or. t1.eq.t3 .or. t2.eq.t3) then - call CCTK_WARN (0, "Internal error: arrays have same time") - end if - if (t.lt.min(t1,t2,t3)-eps .or. t.gt.max(t1,t2,t3)+eps) then - call CCTK_WARN (0, "Internal error: extrapolation in time") - end if - - s1fac = (t - t2) * (t - t3) / ((t1 - t2) * (t1 - t3)) - s2fac = (t - t1) * (t - t3) / ((t2 - t1) * (t2 - t3)) - s3fac = (t - t1) * (t - t2) / ((t3 - t1) * (t3 - t2)) - - - -c Loop over fine region - dstdiv = one / (dstifac * dstjfac * dstkfac) - - do k = 0, regkext-1 - k0 = (srckoff + k) / dstkfac - fk = mod(srckoff + k, dstkfac) - kfac(1) = (fk-dstkfac) * (-1) - kfac(2) = (fk ) * 1 - - do j = 0, regjext-1 - j0 = (srcjoff + j) / dstjfac - fj = mod(srcjoff + j, dstjfac) - jfac(1) = (fj-dstjfac) * (-1) - jfac(2) = (fj ) * 1 - - do i = 0, regiext-1 - i0 = (srcioff + i) / dstifac - fi = mod(srcioff + i, dstifac) - ifac(1) = (fi-dstifac) * (-1) - ifac(2) = (fi ) * 1 - - res = 0 - - do kk=1,2 - do jj=1,2 - do ii=1,2 - - fac = ifac(ii) * jfac(jj) * kfac(kk) - - if (fac.ne.0) then - if (check_array_accesses.ne.0) then - call checkindex (i0+ii, j0+jj, k0+kk, 1,1,1, srciext,srcjext,srckext, "source") - end if - res = res - $ + fac * s1fac * src1(i0+ii, j0+jj, k0+kk) - $ + fac * s2fac * src2(i0+ii, j0+jj, k0+kk) - $ + fac * s3fac * src3(i0+ii, j0+jj, k0+kk) - end if - - end do - end do - end do - - if (check_array_accesses.ne.0) then - call checkindex (dstioff+i+1, dstjoff+j+1, dstkoff+k+1, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst (dstioff+i+1, dstjoff+j+1, dstkoff+k+1) = dstdiv * res - - end do - end do - end do - - end diff --git a/Carpet/CarpetLib/src/prolongate_3d_real8_3tl_eno.F90 b/Carpet/CarpetLib/src/prolongate_3d_real8_3tl_eno.F90 deleted file mode 100644 index 316c72999..000000000 --- a/Carpet/CarpetLib/src/prolongate_3d_real8_3tl_eno.F90 +++ /dev/null @@ -1,365 +0,0 @@ -#ifndef OMIT_F90 -#include "cctk.h" - - -!!$ This routine performs "ENO" prolongation. It is intended to be used -!!$ with GFs that are not expected to be smooth, particularly those -!!$ that must also obey certain constraints. The obvious example is the -!!$ density in hydrodynamics, which may be discontinuous yet must be -!!$ strictly positive. -!!$ -!!$ To ensure that this prolongation method is used you should add the -!!$ tag -!!$ -!!$ tags='Prolongation="ENO"' -!!$ -!!$ to the interface.ccl on the appropriate group. -!!$ -!!$ This applies ENO2 type limiting to the slope, checking over the -!!$ entire coarse grid cell for the least oscillatory quadratic in each -!!$ direction. If the slope changes sign over the extrema, linear -!!$ interpolation is used instead. -!!$ -!!$ The actual eno1d function is defined in the routine -!!$ -!!$ prolongate_3d_real8_eno.F77 - - -#define CHKIDX(i,j,k, imax,jmax,kmax, where) \ -if ((i).lt.1 .or. (i).gt.(imax) \ - .or. (j).lt.1 .or. (j).gt.(jmax) \ - .or. (k).lt.1 .or. (k).gt.(kmax)) then &&\ - write (msg, '(a, " array index out of bounds: shape is (",i4,",",i4,",",i4,"), index is (",i4,",",i4,",",i4,")")') \ - (where), (imax), (jmax), (kmax), (i), (j), (k) &&\ - call CCTK_WARN (0, msg(1:len_trim(msg))) &&\ -end if - -subroutine prolongate_3d_real8_3tl_eno (src1, t1, src2, t2, & - src3, t3, srciext, srcjext, srckext, dst, t, dstiext, & - dstjext, dstkext, srcbbox, dstbbox, regbbox) - - implicit none - - CCTK_REAL8 one - parameter (one = 1) - - CCTK_REAL8 eps - parameter (eps = 1.0d-10) - - integer srciext, srcjext, srckext - CCTK_REAL8 src1(srciext,srcjext,srckext) - CCTK_REAL8 t1 - CCTK_REAL8 src2(srciext,srcjext,srckext) - CCTK_REAL8 t2 - CCTK_REAL8 src3(srciext,srcjext,srckext) - CCTK_REAL8 t3 - integer dstiext, dstjext, dstkext - CCTK_REAL8 dst(dstiext,dstjext,dstkext) - CCTK_REAL8 t -!!$ bbox(:,1) is lower boundary (inclusive) -!!$ bbox(:,2) is upper boundary (inclusive) -!!$ bbox(:,3) is stride - integer srcbbox(3,3), dstbbox(3,3), regbbox(3,3) - - integer offsetlo, offsethi - - integer regiext, regjext, regkext - - integer dstifac, dstjfac, dstkfac - - integer srcioff, srcjoff, srckoff - integer dstioff, dstjoff, dstkoff - - CCTK_REAL8 s1fac, s2fac, s3fac, tmps1fac, tmps2fac, tmps3fac - - integer i, j, k - integer i0, j0, k0 - integer fi, fj, fk - integer ii, jj, kk - integer d - - CCTK_REAL8, dimension(0:3,0:3) :: tmp1 - CCTK_REAL8, dimension(0:3) :: tmp2 - CCTK_REAL8 :: dsttmp1, dsttmp2, dsttmp3 - - external eno1d - CCTK_REAL8 eno1d - - CCTK_REAL8 half, zero - parameter (half = 0.5) - parameter (zero = 0) - - do d=1,3 - if (srcbbox(d,3).eq.0 .or. dstbbox(d,3).eq.0 & - .or. regbbox(d,3).eq.0) then - call CCTK_WARN (0, "Internal error: stride is zero") - end if - if (srcbbox(d,3).le.regbbox(d,3) & - .or. dstbbox(d,3).ne.regbbox(d,3)) then - call CCTK_WARN (0, "Internal error: strides disagree") - end if - if (mod(srcbbox(d,3), dstbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: destination strides are not integer multiples of the source strides") - end if - if (mod(srcbbox(d,1), srcbbox(d,3)).ne.0 & - .or. mod(dstbbox(d,1), dstbbox(d,3)).ne.0 & - .or. mod(regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array origins are not integer multiples of the strides") - end if - if (regbbox(d,1).gt.regbbox(d,2)) then -!!$ This could be handled, but is likely to point to an error elsewhere - call CCTK_WARN (0, "Internal error: region extent is empty") - end if - regkext = (regbbox(d,2) - regbbox(d,1)) / regbbox(d,3) + 1 - dstkfac = srcbbox(d,3) / dstbbox(d,3) - srckoff = (regbbox(d,1) - srcbbox(d,1)) / dstbbox(d,3) - offsetlo = regbbox(d,3) - if (mod(srckoff + 0, dstkfac).eq.0) then - offsetlo = 0 - if (regkext.gt.1) then - offsetlo = regbbox(d,3) - end if - end if - offsethi = regbbox(d,3) - if (mod(srckoff + regkext-1, dstkfac).eq.0) then - offsethi = 0 - if (regkext.gt.1) then - offsethi = regbbox(d,3) - end if - end if - if (regbbox(d,1)-offsetlo.lt.srcbbox(d,1) & - .or. regbbox(d,2)+offsethi.gt.srcbbox(d,2) & - .or. regbbox(d,1).lt.dstbbox(d,1) & - .or. regbbox(d,2).gt.dstbbox(d,2)) then - call CCTK_WARN (0, "Internal error: region extent is not contained in array extent") - end if - end do - - if (srciext.ne.(srcbbox(1,2)-srcbbox(1,1))/srcbbox(1,3)+1 & - .or. srcjext.ne.(srcbbox(2,2)-srcbbox(2,1))/srcbbox(2,3)+1 & - .or. srckext.ne.(srcbbox(3,2)-srcbbox(3,1))/srcbbox(3,3)+1 & - .or. dstiext.ne.(dstbbox(1,2)-dstbbox(1,1))/dstbbox(1,3)+1 & - .or. dstjext.ne.(dstbbox(2,2)-dstbbox(2,1))/dstbbox(2,3)+1 & - .or. dstkext.ne.(dstbbox(3,2)-dstbbox(3,1))/dstbbox(3,3)+1) then - call CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes") - end if - - regiext = (regbbox(1,2) - regbbox(1,1)) / regbbox(1,3) + 1 - regjext = (regbbox(2,2) - regbbox(2,1)) / regbbox(2,3) + 1 - regkext = (regbbox(3,2) - regbbox(3,1)) / regbbox(3,3) + 1 - - dstifac = srcbbox(1,3) / dstbbox(1,3) - dstjfac = srcbbox(2,3) / dstbbox(2,3) - dstkfac = srcbbox(3,3) / dstbbox(3,3) - - srcioff = (regbbox(1,1) - srcbbox(1,1)) / dstbbox(1,3) - srcjoff = (regbbox(2,1) - srcbbox(2,1)) / dstbbox(2,3) - srckoff = (regbbox(3,1) - srcbbox(3,1)) / dstbbox(3,3) - - dstioff = (regbbox(1,1) - dstbbox(1,1)) / dstbbox(1,3) - dstjoff = (regbbox(2,1) - dstbbox(2,1)) / dstbbox(2,3) - dstkoff = (regbbox(3,1) - dstbbox(3,1)) / dstbbox(3,3) - -!!$ Quadratic (second order) interpolation - if (t1.eq.t2 .or. t1.eq.t3 .or. t2.eq.t3) then - call CCTK_WARN (0, "Internal error: arrays have same time") - end if - if (t.lt.min(t1,t2,t3)-eps .or. t.gt.max(t1,t2,t3)+eps) then - call CCTK_WARN (0, "Internal error: extrapolation in time") - end if - - s1fac = (t - t2) * (t - t3) / ((t1 - t2) * (t1 - t3)) - s2fac = (t - t1) * (t - t3) / ((t2 - t1) * (t2 - t3)) - s3fac = (t - t1) * (t - t2) / ((t3 - t1) * (t3 - t2)) - -!!$ Loop over fine region - - do k = 0, regkext-1 - k0 = (srckoff + k) / dstkfac - fk = mod(srckoff + k, dstkfac) - - do j = 0, regjext-1 - j0 = (srcjoff + j) / dstjfac - fj = mod(srcjoff + j, dstjfac) - - do i = 0, regiext-1 - i0 = (srcioff + i) / dstifac - fi = mod(srcioff + i, dstifac) - -!!$ Where is the fine grid point w.r.t the coarse grid? - -!!$ write(*,*) i,j,k,fi,fj,fk - - select case (fi + 10*fj + 100*fk) - case (0) -!!$ On a coarse grid point exactly! - - dsttmp1 = src1(i0+1,j0+1,k0+1) - dsttmp2 = src2(i0+1,j0+1,k0+1) - dsttmp3 = src3(i0+1,j0+1,k0+1) - - case (1) -!!$ Interpolate only in x - - dsttmp1 = eno1d(src1(i0:i0+3,j0+1,k0+1)) - dsttmp2 = eno1d(src2(i0:i0+3,j0+1,k0+1)) - dsttmp3 = eno1d(src3(i0:i0+3,j0+1,k0+1)) - - case (10) -!!$ Interpolate only in y - - dsttmp1 = eno1d(src1(i0+1,j0:j0+3,k0+1)) - dsttmp2 = eno1d(src2(i0+1,j0:j0+3,k0+1)) - dsttmp3 = eno1d(src3(i0+1,j0:j0+3,k0+1)) - - case (11) -!!$ Interpolate only in x and y - - do jj = 0, 3 - tmp2(jj) = eno1d(src1(i0:i0+3,j0+jj,k0+1)) - end do - - dsttmp1 = eno1d(tmp2(0:3)) - - do jj = 0, 3 - tmp2(jj) = eno1d(src2(i0:i0+3,j0+jj,k0+1)) - end do - - dsttmp2 = eno1d(tmp2(0:3)) - - do jj = 0, 3 - tmp2(jj) = eno1d(src3(i0:i0+3,j0+jj,k0+1)) - end do - - dsttmp3 = eno1d(tmp2(0:3)) - - case (100) -!!$ Interpolate only in z - - dsttmp1 = eno1d(src1(i0+1,j0+1,k0:k0+3)) - dsttmp2 = eno1d(src2(i0+1,j0+1,k0:k0+3)) - dsttmp3 = eno1d(src3(i0+1,j0+1,k0:k0+3)) - - case (101) -!!$ Interpolate only in x and z - - do kk = 0, 3 - tmp2(kk) = eno1d(src1(i0:i0+3,j0+1,k0+kk)) - end do - - dsttmp1 = eno1d(tmp2(0:3)) - - do kk = 0, 3 - tmp2(kk) = eno1d(src2(i0:i0+3,j0+1,k0+kk)) - end do - - dsttmp2 = eno1d(tmp2(0:3)) - - do kk = 0, 3 - tmp2(kk) = eno1d(src3(i0:i0+3,j0+1,k0+kk)) - end do - - dsttmp3 = eno1d(tmp2(0:3)) - - case (110) -!!$ Interpolate only in y and z - - do kk = 0, 3 - tmp2(kk) = eno1d(src1(i0+1,j0:j0+3,k0+kk)) - end do - - dsttmp1 = eno1d(tmp2(0:3)) - - do kk = 0, 3 - tmp2(kk) = eno1d(src2(i0+1,j0:j0+3,k0+kk)) - end do - - dsttmp2 = eno1d(tmp2(0:3)) - - do kk = 0, 3 - tmp2(kk) = eno1d(src3(i0+1,j0:j0+3,k0+kk)) - end do - - dsttmp3 = eno1d(tmp2(0:3)) - - case (111) -!!$ Interpolate in all of x, y, and z - - do jj = 0, 3 - do kk = 0, 3 - tmp1(jj,kk) = eno1d(src1(i0:i0+3,j0+jj,k0+kk)) - end do - end do - do ii = 0, 3 - tmp2(ii) = eno1d(tmp1(0:3,ii)) - end do - - dsttmp1 = eno1d(tmp2(0:3)) - - do jj = 0, 3 - do kk = 0, 3 - tmp1(jj,kk) = eno1d(src2(i0:i0+3,j0+jj,k0+kk)) - end do - end do - do ii = 0, 3 - tmp2(ii) = eno1d(tmp1(0:3,ii)) - end do - - dsttmp2 = eno1d(tmp2(0:3)) - - do jj = 0, 3 - do kk = 0, 3 - tmp1(jj,kk) = eno1d(src3(i0:i0+3,j0+jj,k0+kk)) - end do - end do - do ii = 0, 3 - tmp2(ii) = eno1d(tmp1(0:3,ii)) - end do - - dsttmp3 = eno1d(tmp2(0:3)) - - case default - call CCTK_WARN(0, "Internal error in ENO prolongation. Should only be used with refinement factor 2!") - end select - - dst (dstioff+i+1, dstjoff+j+1, dstkoff+k+1) = & - s1fac * dsttmp1 + s2fac * dsttmp2 + s3fac * dsttmp3 - -!!$ write(*,*) i,j,k,dst (dstioff+i+1, dstjoff+j+1, dstkoff+k+1),& -!!$ s1fac,s2fac,s3fac,dsttmp1,dsttmp2,dsttmp3 - - if ( (dst(dstioff+i+1, dstjoff+j+1, dstkoff+k+1) - & - max(dsttmp1, dsttmp2, dsttmp3)) * & - (dst(dstioff+i+1, dstjoff+j+1, dstkoff+k+1) - & - min(dsttmp1, dsttmp2, dsttmp3)) .lt. 0 ) then - -!!$ Do linear interpolation in time instead - -!!$ write(*,*) t,t1,t2,t3 - - if (t < t2) then - - tmps2fac = (t - t3) / (t2 - t3) - tmps3fac = (t - t2) / (t3 - t2) - - dst (dstioff+i+1, dstjoff+j+1, dstkoff+k+1) = & - tmps2fac * dsttmp2 + tmps3fac * dsttmp3 - - else - - tmps1fac = (t - t2) / (t1 - t2) - tmps2fac = (t - t1) / (t2 - t1) - - dst (dstioff+i+1, dstjoff+j+1, dstkoff+k+1) = & - tmps1fac * dsttmp1 + tmps2fac * dsttmp2 - - end if - - end if - - end do - end do - end do - -end subroutine prolongate_3d_real8_3tl_eno -#endif /* !OMIT_F90 */ diff --git a/Carpet/CarpetLib/src/prolongate_3d_real8_3tl_minmod.F77 b/Carpet/CarpetLib/src/prolongate_3d_real8_3tl_minmod.F77 deleted file mode 100644 index 2dad7f5eb..000000000 --- a/Carpet/CarpetLib/src/prolongate_3d_real8_3tl_minmod.F77 +++ /dev/null @@ -1,374 +0,0 @@ -c -*-Fortran-*- - -#include "cctk.h" -#include "cctk_Parameters.h" - - -c$$$ This routine performs "TVD" prolongation. It is intended to be used -c$$$ with GFs that are not expected to be smooth, particularly those -c$$$ that must also obey certain constraints. The obvious example is the -c$$$ density in hydrodynamics, which may be discontinuous yet must be -c$$$ strictly positive. -c$$$ -c$$$ To ensure that this prolongation method is used you should add the -c$$$ tag -c$$$ -c$$$ tags='Prolongation="TVD"' -c$$$ -c$$$ to the interface.ccl on the appropriate group. -c$$$ -c$$$ This applies minmod type limiting to the slope, checking over the -c$$$ entire coarse grid cell for the minimum modulus in each direction. -c$$$ -c$$$ The actual minmod function is defined in the routine -c$$$ -c$$$ prolongate_3d_real8_minmod.F77 - - - subroutine prolongate_3d_real8_3tl_minmod ( - $ src1, t1, src2, t2, src3, t3, srciext, srcjext, srckext, - $ dst, t, dstiext, dstjext, dstkext, - $ srcbbox, dstbbox, regbbox) - - implicit none - - DECLARE_CCTK_PARAMETERS - - CCTK_REAL8 one - parameter (one = 1) - - CCTK_REAL8 eps - parameter (eps = 1.0d-10) - - integer srciext, srcjext, srckext - CCTK_REAL8 src1(srciext,srcjext,srckext) - CCTK_REAL8 t1 - CCTK_REAL8 src2(srciext,srcjext,srckext) - CCTK_REAL8 t2 - CCTK_REAL8 src3(srciext,srcjext,srckext) - CCTK_REAL8 t3 - integer dstiext, dstjext, dstkext - CCTK_REAL8 dst(dstiext,dstjext,dstkext) - CCTK_REAL8 t -c bbox(:,1) is lower boundary (inclusive) -c bbox(:,2) is upper boundary (inclusive) -c bbox(:,3) is stride - integer srcbbox(3,3), dstbbox(3,3), regbbox(3,3) - - integer offsetlo, offsethi - - integer regiext, regjext, regkext - - integer dstifac, dstjfac, dstkfac - - integer srcioff, srcjoff, srckoff - integer dstioff, dstjoff, dstkoff - - CCTK_REAL8 s1fac, s2fac, s3fac - - integer i, j, k - integer i0, j0, k0 - integer fi, fj, fk - integer ii, jj, kk - integer d - - external minmod - CCTK_REAL8 minmod - - CCTK_REAL8 half, zero - parameter (half = 0.5) - parameter (zero = 0) - CCTK_REAL8 dupw, dloc, slopex(3), slopey(3), slopez(3) - logical firstloop - - - do d=1,3 - if (srcbbox(d,3).eq.0 .or. dstbbox(d,3).eq.0 - $ .or. regbbox(d,3).eq.0) then - call CCTK_WARN (0, "Internal error: stride is zero") - end if - if (srcbbox(d,3).le.regbbox(d,3) - $ .or. dstbbox(d,3).ne.regbbox(d,3)) then - call CCTK_WARN (0, "Internal error: strides disagree") - end if - if (mod(srcbbox(d,3), dstbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: destination strides are not integer multiples of the source strides") - end if - if (mod(srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array origins are not integer multiples of the strides") - end if - if (regbbox(d,1).gt.regbbox(d,2)) then -c This could be handled, but is likely to point to an error elsewhere - call CCTK_WARN (0, "Internal error: region extent is empty") - end if - if (mod(srcbbox(d,2) - srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,2) - dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,2) - regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array extents are not integer multiples of the strides") - end if - regkext = (regbbox(d,2) - regbbox(d,1)) / regbbox(d,3) + 1 - dstkfac = srcbbox(d,3) / dstbbox(d,3) - srckoff = (regbbox(d,1) - srcbbox(d,1)) / dstbbox(d,3) - offsetlo = regbbox(d,3) - if (mod(srckoff + 0, dstkfac).eq.0) then - offsetlo = 0 - if (regkext.gt.1) then - offsetlo = regbbox(d,3) - end if - end if - offsethi = regbbox(d,3) - if (mod(srckoff + regkext-1, dstkfac).eq.0) then - offsethi = 0 - if (regkext.gt.1) then - offsethi = regbbox(d,3) - end if - end if - if (regbbox(d,1)-offsetlo.lt.srcbbox(d,1) - $ .or. regbbox(d,2)+offsethi.gt.srcbbox(d,2) - $ .or. regbbox(d,1).lt.dstbbox(d,1) - $ .or. regbbox(d,2).gt.dstbbox(d,2)) then - call CCTK_WARN (0, "Internal error: region extent is not contained in array extent") - end if - end do - - if (srciext.ne.(srcbbox(1,2)-srcbbox(1,1))/srcbbox(1,3)+1 - $ .or. srcjext.ne.(srcbbox(2,2)-srcbbox(2,1))/srcbbox(2,3)+1 - $ .or. srckext.ne.(srcbbox(3,2)-srcbbox(3,1))/srcbbox(3,3)+1 - $ .or. dstiext.ne.(dstbbox(1,2)-dstbbox(1,1))/dstbbox(1,3)+1 - $ .or. dstjext.ne.(dstbbox(2,2)-dstbbox(2,1))/dstbbox(2,3)+1 - $ .or. dstkext.ne.(dstbbox(3,2)-dstbbox(3,1))/dstbbox(3,3)+1) then - call CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes") - end if - - - - regiext = (regbbox(1,2) - regbbox(1,1)) / regbbox(1,3) + 1 - regjext = (regbbox(2,2) - regbbox(2,1)) / regbbox(2,3) + 1 - regkext = (regbbox(3,2) - regbbox(3,1)) / regbbox(3,3) + 1 - - dstifac = srcbbox(1,3) / dstbbox(1,3) - dstjfac = srcbbox(2,3) / dstbbox(2,3) - dstkfac = srcbbox(3,3) / dstbbox(3,3) - - srcioff = (regbbox(1,1) - srcbbox(1,1)) / dstbbox(1,3) - srcjoff = (regbbox(2,1) - srcbbox(2,1)) / dstbbox(2,3) - srckoff = (regbbox(3,1) - srcbbox(3,1)) / dstbbox(3,3) - - dstioff = (regbbox(1,1) - dstbbox(1,1)) / dstbbox(1,3) - dstjoff = (regbbox(2,1) - dstbbox(2,1)) / dstbbox(2,3) - dstkoff = (regbbox(3,1) - dstbbox(3,1)) / dstbbox(3,3) - - - -c Quadratic (second order) interpolation - if (t1.eq.t2 .or. t1.eq.t3 .or. t2.eq.t3) then - call CCTK_WARN (0, "Internal error: arrays have same time") - end if - if (t.lt.min(t1,t2,t3)-eps .or. t.gt.max(t1,t2,t3)+eps) then - call CCTK_WARN (0, "Internal error: extrapolation in time") - end if - - s1fac = (t - t2) * (t - t3) / ((t1 - t2) * (t1 - t3)) - s2fac = (t - t1) * (t - t3) / ((t2 - t1) * (t2 - t3)) - s3fac = (t - t1) * (t - t2) / ((t3 - t1) * (t3 - t2)) - - - -c Loop over fine region - - do k = 0, regkext-1 - k0 = (srckoff + k) / dstkfac - fk = mod(srckoff + k, dstkfac) - - do j = 0, regjext-1 - j0 = (srcjoff + j) / dstjfac - fj = mod(srcjoff + j, dstjfac) - - do i = 0, regiext-1 - i0 = (srcioff + i) / dstifac - fi = mod(srcioff + i, dstifac) - - - slopex(1) = zero - slopey(1) = zero - slopez(1) = zero - - firstloop = .true. - - do kk = 1, 2 - do jj = 1, 2 - - dupw = src1(i0+1 ,j0+jj,k0+kk) - src1(i0+0 ,j0+jj,k0+kk) - dloc = src1(i0+2 ,j0+jj,k0+kk) - src1(i0+1 ,j0+kk,k0+kk) - if (firstloop) then - slopex(1) = half * dble(fi) * minmod(dupw,dloc) - firstloop = .false. - else - slopex(1) = - $ minmod(slopex(1), half * dble(fi) * minmod(dupw,dloc)) - end if - end do - end do - - firstloop = .true. - - do kk = 1, 2 - do ii = 1, 2 - - dupw = src1(i0+ii,j0+1 ,k0+kk) - src1(i0+ii,j0+0 ,k0+kk) - dloc = src1(i0+ii,j0+2 ,k0+kk) - src1(i0+ii,j0+1 ,k0+kk) - if (firstloop) then - slopey(1) = half * dble(fj) * minmod(dupw,dloc) - firstloop = .false. - else - slopey(1) = - $ minmod(slopey(1), half * dble(fj) * minmod(dupw,dloc)) - end if - end do - end do - - firstloop = .true. - - do jj = 1, 2 - do ii = 1, 2 - dupw = src1(i0+ii,j0+jj,k0+1 ) - src1(i0+ii,j0+jj,k0+0 ) - dloc = src1(i0+ii,j0+jj,k0+2 ) - src1(i0+ii,j0+jj,k0+1 ) - if (firstloop) then - slopez(1) = half * dble(fk) * minmod(dupw,dloc) - firstloop = .false. - else - slopez(1) = - $ minmod(slopez(1), half * dble(fk) * minmod(dupw,dloc)) - end if - - end do - end do - - slopex(2) = zero - slopey(2) = zero - slopez(2) = zero - - firstloop = .true. - - do kk = 1, 2 - do jj = 1, 2 - - dupw = src2(i0+1 ,j0+jj,k0+kk) - src2(i0+0 ,j0+jj,k0+kk) - dloc = src2(i0+2 ,j0+jj,k0+kk) - src2(i0+1 ,j0+kk,k0+kk) - if (firstloop) then - slopex(2) = half * dble(fi) * minmod(dupw,dloc) - firstloop = .false. - else - slopex(2) = - $ minmod(slopex(2), half * dble(fi) * minmod(dupw,dloc)) - end if - end do - end do - - firstloop = .true. - - do kk = 1, 2 - do ii = 1, 2 - - dupw = src2(i0+ii,j0+1 ,k0+kk) - src2(i0+ii,j0+0 ,k0+kk) - dloc = src2(i0+ii,j0+2 ,k0+kk) - src2(i0+ii,j0+1 ,k0+kk) - if (firstloop) then - slopey(2) = half * dble(fj) * minmod(dupw,dloc) - firstloop = .false. - else - slopey(2) = - $ minmod(slopey(2), half * dble(fj) * minmod(dupw,dloc)) - end if - end do - end do - - firstloop = .true. - - do jj = 1, 2 - do ii = 1, 2 - - dupw = src2(i0+ii,j0+jj,k0+1 ) - src2(i0+ii,j0+jj,k0+0 ) - dloc = src2(i0+ii,j0+jj,k0+2 ) - src2(i0+ii,j0+jj,k0+1 ) - if (firstloop) then - slopez(2) = half * dble(fk) * minmod(dupw,dloc) - firstloop = .false. - else - slopez(2) = - $ minmod(slopez(2), half * dble(fk) * minmod(dupw,dloc)) - end if - end do - end do - - firstloop = .true. - - slopex(3) = zero - slopey(3) = zero - slopez(3) = zero - - do kk = 1, 2 - do jj = 1, 2 - - dupw = src3(i0+1 ,j0+jj,k0+kk) - src3(i0+0 ,j0+jj,k0+kk) - dloc = src3(i0+2 ,j0+jj,k0+kk) - src3(i0+1 ,j0+kk,k0+kk) - if (firstloop) then - slopex(3) = half * dble(fi) * minmod(dupw,dloc) - firstloop = .false. - else - slopex(3) = - $ minmod(slopex(3), half * dble(fi) * minmod(dupw,dloc)) - end if - end do - end do - - firstloop = .true. - - do kk = 1, 2 - do ii = 1, 2 - - dupw = src3(i0+ii,j0+1 ,k0+kk) - src3(i0+ii,j0+0 ,k0+kk) - dloc = src3(i0+ii,j0+2 ,k0+kk) - src3(i0+ii,j0+1 ,k0+kk) - if (firstloop) then - slopey(3) = half * dble(fj) * minmod(dupw,dloc) - firstloop = .false. - else - slopey(3) = - $ minmod(slopey(3), half * dble(fj) * minmod(dupw,dloc)) - end if - end do - end do - - firstloop = .true. - - do jj = 1, 2 - do ii = 1, 2 - - dupw = src3(i0+ii,j0+jj,k0+1 ) - src3(i0+ii,j0+jj,k0+0 ) - dloc = src3(i0+ii,j0+jj,k0+2 ) - src3(i0+ii,j0+jj,k0+1 ) - if (firstloop) then - slopez(3) = half * dble(fk) * minmod(dupw,dloc) - firstloop = .false. - else - slopez(3) = - $ minmod(slopez(3), half * dble(fk) * minmod(dupw,dloc)) - end if - end do - end do - - if (check_array_accesses.ne.0) then - call checkindex (dstioff+i+1, dstjoff+j+1, dstkoff+k+1, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst (dstioff+i+1, dstjoff+j+1, dstkoff+k+1) = - $ s1fac * (src1(i0+1,j0+1,k0+1) + - $ slopex(1) + slopey(1) + slopez(1)) + - $ s2fac * (src2(i0+1,j0+1,k0+1) + - $ slopex(2) + slopey(2) + slopez(2)) + - $ s3fac * (src3(i0+1,j0+1,k0+1) + - $ slopex(3) + slopey(3) + slopez(3)) - - end do - end do - end do - - end diff --git a/Carpet/CarpetLib/src/prolongate_3d_real8_3tl_o3.F77 b/Carpet/CarpetLib/src/prolongate_3d_real8_3tl_o3.F77 deleted file mode 100644 index 2271a4eb0..000000000 --- a/Carpet/CarpetLib/src/prolongate_3d_real8_3tl_o3.F77 +++ /dev/null @@ -1,213 +0,0 @@ -c -*-Fortran-*- - -#include "cctk.h" -#include "cctk_Parameters.h" - - - - subroutine prolongate_3d_real8_3tl_o3 ( - $ src1, t1, src2, t2, src3, t3, srciext, srcjext, srckext, - $ dst, t, dstiext, dstjext, dstkext, - $ srcbbox, dstbbox, regbbox) - - implicit none - - DECLARE_CCTK_PARAMETERS - - CCTK_REAL8 one - parameter (one = 1) - - CCTK_REAL8 eps - parameter (eps = 1.0d-10) - - integer srciext, srcjext, srckext - CCTK_REAL8 src1(srciext,srcjext,srckext) - CCTK_REAL8 t1 - CCTK_REAL8 src2(srciext,srcjext,srckext) - CCTK_REAL8 t2 - CCTK_REAL8 src3(srciext,srcjext,srckext) - CCTK_REAL8 t3 - integer dstiext, dstjext, dstkext - CCTK_REAL8 dst(dstiext,dstjext,dstkext) - CCTK_REAL8 t -c bbox(:,1) is lower boundary (inclusive) -c bbox(:,2) is upper boundary (inclusive) -c bbox(:,3) is stride - integer srcbbox(3,3), dstbbox(3,3), regbbox(3,3) - - integer offsetlo, offsethi - - integer regiext, regjext, regkext - - integer dstifac, dstjfac, dstkfac - - integer srcioff, srcjoff, srckoff - integer dstioff, dstjoff, dstkoff - - CCTK_REAL8 s1fac, s2fac, s3fac - - CCTK_REAL8 dstdiv - integer i, j, k - integer i0, j0, k0 - integer fi, fj, fk - integer ifac(4), jfac(4), kfac(4) - integer ii, jj, kk - integer fac - CCTK_REAL8 res - integer d - - - - do d=1,3 - if (srcbbox(d,3).eq.0 .or. dstbbox(d,3).eq.0 - $ .or. regbbox(d,3).eq.0) then - call CCTK_WARN (0, "Internal error: stride is zero") - end if - if (srcbbox(d,3).le.regbbox(d,3) - $ .or. dstbbox(d,3).ne.regbbox(d,3)) then - call CCTK_WARN (0, "Internal error: strides disagree") - end if - if (mod(srcbbox(d,3), dstbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: destination strides are not integer multiples of the source strides") - end if - if (mod(srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array origins are not integer multiples of the strides") - end if - if (regbbox(d,1).gt.regbbox(d,2)) then -c This could be handled, but is likely to point to an error elsewhere - call CCTK_WARN (0, "Internal error: region extent is empty") - end if - if (mod(srcbbox(d,2) - srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,2) - dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,2) - regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array extents are not integer multiples of the strides") - end if - regkext = (regbbox(d,2) - regbbox(d,1)) / regbbox(d,3) + 1 - dstkfac = srcbbox(d,3) / dstbbox(d,3) - srckoff = (regbbox(d,1) - srcbbox(d,1)) / dstbbox(d,3) - offsetlo = regbbox(d,3) - if (mod(srckoff + 0, dstkfac).eq.0) then - offsetlo = 0 - if (regkext.gt.1) then - offsetlo = regbbox(d,3) - end if - end if - offsethi = regbbox(d,3) - if (mod(srckoff + regkext-1, dstkfac).eq.0) then - offsethi = 0 - if (regkext.gt.1) then - offsethi = regbbox(d,3) - end if - end if - if (regbbox(d,1)-offsetlo.lt.srcbbox(d,1) - $ .or. regbbox(d,2)+offsethi.gt.srcbbox(d,2) - $ .or. regbbox(d,1).lt.dstbbox(d,1) - $ .or. regbbox(d,2).gt.dstbbox(d,2)) then - call CCTK_WARN (0, "Internal error: region extent is not contained in array extent") - end if - end do - - if (srciext.ne.(srcbbox(1,2)-srcbbox(1,1))/srcbbox(1,3)+1 - $ .or. srcjext.ne.(srcbbox(2,2)-srcbbox(2,1))/srcbbox(2,3)+1 - $ .or. srckext.ne.(srcbbox(3,2)-srcbbox(3,1))/srcbbox(3,3)+1 - $ .or. dstiext.ne.(dstbbox(1,2)-dstbbox(1,1))/dstbbox(1,3)+1 - $ .or. dstjext.ne.(dstbbox(2,2)-dstbbox(2,1))/dstbbox(2,3)+1 - $ .or. dstkext.ne.(dstbbox(3,2)-dstbbox(3,1))/dstbbox(3,3)+1) then - call CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes") - end if - - - - regiext = (regbbox(1,2) - regbbox(1,1)) / regbbox(1,3) + 1 - regjext = (regbbox(2,2) - regbbox(2,1)) / regbbox(2,3) + 1 - regkext = (regbbox(3,2) - regbbox(3,1)) / regbbox(3,3) + 1 - - dstifac = srcbbox(1,3) / dstbbox(1,3) - dstjfac = srcbbox(2,3) / dstbbox(2,3) - dstkfac = srcbbox(3,3) / dstbbox(3,3) - - srcioff = (regbbox(1,1) - srcbbox(1,1)) / dstbbox(1,3) - srcjoff = (regbbox(2,1) - srcbbox(2,1)) / dstbbox(2,3) - srckoff = (regbbox(3,1) - srcbbox(3,1)) / dstbbox(3,3) - - dstioff = (regbbox(1,1) - dstbbox(1,1)) / dstbbox(1,3) - dstjoff = (regbbox(2,1) - dstbbox(2,1)) / dstbbox(2,3) - dstkoff = (regbbox(3,1) - dstbbox(3,1)) / dstbbox(3,3) - - - -c Quadratic (second order) interpolation - if (t1.eq.t2 .or. t1.eq.t3 .or. t2.eq.t3) then - call CCTK_WARN (0, "Internal error: arrays have same time") - end if - if (t.lt.min(t1,t2,t3)-eps .or. t.gt.max(t1,t2,t3)+eps) then - call CCTK_WARN (0, "Internal error: extrapolation in time") - end if - - s1fac = (t - t2) * (t - t3) / ((t1 - t2) * (t1 - t3)) - s2fac = (t - t1) * (t - t3) / ((t2 - t1) * (t2 - t3)) - s3fac = (t - t1) * (t - t2) / ((t3 - t1) * (t3 - t2)) - - - -c Loop over fine region - dstdiv = one / (6*dstifac**3 * 6*dstjfac**3 * 6*dstkfac**3) - - do k = 0, regkext-1 - k0 = (srckoff + k) / dstkfac - fk = mod(srckoff + k, dstkfac) - kfac(1) = (fk ) * (fk-dstkfac) * (fk-2*dstkfac) * (-1) - kfac(2) = (fk+dstkfac) * (fk-dstkfac) * (fk-2*dstkfac) * 3 - kfac(3) = (fk+dstkfac) * (fk ) * (fk-2*dstkfac) * (-3) - kfac(4) = (fk+dstkfac) * (fk ) * (fk- dstkfac) * 1 - - do j = 0, regjext-1 - j0 = (srcjoff + j) / dstjfac - fj = mod(srcjoff + j, dstjfac) - jfac(1) = (fj ) * (fj-dstjfac) * (fj-2*dstjfac) * (-1) - jfac(2) = (fj+dstjfac) * (fj-dstjfac) * (fj-2*dstjfac) * 3 - jfac(3) = (fj+dstjfac) * (fj ) * (fj-2*dstjfac) * (-3) - jfac(4) = (fj+dstjfac) * (fj ) * (fj- dstjfac) * 1 - - do i = 0, regiext-1 - i0 = (srcioff + i) / dstifac - fi = mod(srcioff + i, dstifac) - ifac(1) = (fi ) * (fi-dstifac) * (fi-2*dstifac) * (-1) - ifac(2) = (fi+dstifac) * (fi-dstifac) * (fi-2*dstifac) * 3 - ifac(3) = (fi+dstifac) * (fi ) * (fi-2*dstifac) * (-3) - ifac(4) = (fi+dstifac) * (fi ) * (fi- dstifac) * 1 - - res = 0 - - do kk=1,4 - do jj=1,4 - do ii=1,4 - - fac = ifac(ii) * jfac(jj) * kfac(kk) - - if (fac.ne.0) then - if (check_array_accesses.ne.0) then - call checkindex (i0+ii-1, j0+jj-1, k0+kk-1, 1,1,1, srciext,srcjext,srckext, "source") - end if - res = res - $ + fac * s1fac * src1(i0+ii-1, j0+jj-1, k0+kk-1) - $ + fac * s2fac * src2(i0+ii-1, j0+jj-1, k0+kk-1) - $ + fac * s3fac * src3(i0+ii-1, j0+jj-1, k0+kk-1) - end if - - end do - end do - end do - - if (check_array_accesses.ne.0) then - call checkindex (dstioff+i+1, dstjoff+j+1, dstkoff+k+1, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst (dstioff+i+1, dstjoff+j+1, dstkoff+k+1) = dstdiv * res - - end do - end do - end do - - end diff --git a/Carpet/CarpetLib/src/prolongate_3d_real8_3tl_o3_rf2.F77 b/Carpet/CarpetLib/src/prolongate_3d_real8_3tl_o3_rf2.F77 deleted file mode 100644 index c36b69cbe..000000000 --- a/Carpet/CarpetLib/src/prolongate_3d_real8_3tl_o3_rf2.F77 +++ /dev/null @@ -1,756 +0,0 @@ -c -*-Fortran-*- - -#include "cctk.h" -#include "cctk_Parameters.h" - - - - subroutine prolongate_3d_real8_3tl_o3_rf2 ( - $ src1, t1, src2, t2, src3, t3, srciext, srcjext, srckext, - $ dst, t, dstiext, dstjext, dstkext, - $ srcbbox, dstbbox, regbbox) - - implicit none - - DECLARE_CCTK_PARAMETERS - - CCTK_REAL8 eps - parameter (eps = 1.0d-10) - - CCTK_REAL8 one, half, fourth, eighth, sixteenth - parameter (one = 1) - parameter (half = one/2) - parameter (fourth = one/4) - parameter (eighth = one/8) - parameter (sixteenth = one/16) - CCTK_REAL8 f1, f2, f3, f4 - parameter (f1 = - sixteenth) - parameter (f2 = 9*sixteenth) - parameter (f3 = 9*sixteenth) - parameter (f4 = - sixteenth) - - integer srciext, srcjext, srckext - CCTK_REAL8 src1(srciext,srcjext,srckext) - CCTK_REAL8 t1 - CCTK_REAL8 src2(srciext,srcjext,srckext) - CCTK_REAL8 t2 - CCTK_REAL8 src3(srciext,srcjext,srckext) - CCTK_REAL8 t3 - integer dstiext, dstjext, dstkext - CCTK_REAL8 dst(dstiext,dstjext,dstkext) - CCTK_REAL8 t -c bbox(:,1) is lower boundary (inclusive) -c bbox(:,2) is upper boundary (inclusive) -c bbox(:,3) is stride - integer srcbbox(3,3), dstbbox(3,3), regbbox(3,3) - - integer regiext, regjext, regkext - - integer srcioff, srcjoff, srckoff - integer dstioff, dstjoff, dstkoff - - integer offsetlo, offsethi - - CCTK_REAL8 s1fac, s2fac, s3fac - - integer i0, j0, k0 - integer fi, fj, fk - integer is, js, ks - integer id, jd, kd - integer i, j, k - - CCTK_REAL8 res1, res2, res3 - - integer d - - - - do d=1,3 - if (srcbbox(d,3).eq.0 .or. dstbbox(d,3).eq.0 - $ .or. regbbox(d,3).eq.0) then - call CCTK_WARN (0, "Internal error: stride is zero") - end if - if (srcbbox(d,3).le.regbbox(d,3) - $ .or. dstbbox(d,3).ne.regbbox(d,3)) then - call CCTK_WARN (0, "Internal error: strides disagree") - end if - if (srcbbox(d,3).ne.dstbbox(d,3)*2) then - call CCTK_WARN (0, "Internal error: source strides are not twice the destination strides") - end if - if (mod(srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array origins are not integer multiples of the strides") - end if - if (regbbox(d,1).gt.regbbox(d,2)) then -c This could be handled, but is likely to point to an error elsewhere - call CCTK_WARN (0, "Internal error: region extent is empty") - end if - if (mod(srcbbox(d,2) - srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,2) - dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,2) - regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array extents are not integer multiples of the strides") - end if - regkext = (regbbox(d,2) - regbbox(d,1)) / regbbox(d,3) + 1 - srckoff = (regbbox(d,1) - srcbbox(d,1)) / dstbbox(d,3) - offsetlo = regbbox(d,3) - if (mod(srckoff, 2).eq.0) then - offsetlo = 0 - if (regkext.gt.1) then - offsetlo = regbbox(d,3) - end if - end if - offsethi = regbbox(d,3) - if (mod(srckoff + regkext-1, 2).eq.0) then - offsethi = 0 - if (regkext.gt.1) then - offsethi = regbbox(d,3) - end if - end if - if (regbbox(d,1)-offsetlo.lt.srcbbox(d,1) - $ .or. regbbox(d,2)+offsethi.gt.srcbbox(d,2) - $ .or. regbbox(d,1).lt.dstbbox(d,1) - $ .or. regbbox(d,2).gt.dstbbox(d,2)) then - call CCTK_WARN (0, "Internal error: region extent is not contained in array extent") - end if - end do - - if (srciext.ne.(srcbbox(1,2)-srcbbox(1,1))/srcbbox(1,3)+1 - $ .or. srcjext.ne.(srcbbox(2,2)-srcbbox(2,1))/srcbbox(2,3)+1 - $ .or. srckext.ne.(srcbbox(3,2)-srcbbox(3,1))/srcbbox(3,3)+1 - $ .or. dstiext.ne.(dstbbox(1,2)-dstbbox(1,1))/dstbbox(1,3)+1 - $ .or. dstjext.ne.(dstbbox(2,2)-dstbbox(2,1))/dstbbox(2,3)+1 - $ .or. dstkext.ne.(dstbbox(3,2)-dstbbox(3,1))/dstbbox(3,3)+1) then - call CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes") - end if - - - - regiext = (regbbox(1,2) - regbbox(1,1)) / regbbox(1,3) + 1 - regjext = (regbbox(2,2) - regbbox(2,1)) / regbbox(2,3) + 1 - regkext = (regbbox(3,2) - regbbox(3,1)) / regbbox(3,3) + 1 - - srcioff = (regbbox(1,1) - srcbbox(1,1)) / dstbbox(1,3) - srcjoff = (regbbox(2,1) - srcbbox(2,1)) / dstbbox(2,3) - srckoff = (regbbox(3,1) - srcbbox(3,1)) / dstbbox(3,3) - - dstioff = (regbbox(1,1) - dstbbox(1,1)) / dstbbox(1,3) - dstjoff = (regbbox(2,1) - dstbbox(2,1)) / dstbbox(2,3) - dstkoff = (regbbox(3,1) - dstbbox(3,1)) / dstbbox(3,3) - - - -c Quadratic (second order) time interpolation - if (t1.eq.t2 .or. t1.eq.t3 .or. t2.eq.t3) then - call CCTK_WARN (0, "Internal error: arrays have same time") - end if - if (t.lt.min(t1,t2,t3)-eps .or. t.gt.max(t1,t2,t3)+eps) then - call CCTK_WARN (0, "Internal error: extrapolation in time in time") - end if - - s1fac = (t - t2) * (t - t3) / ((t1 - t2) * (t1 - t3)) - s2fac = (t - t1) * (t - t3) / ((t2 - t1) * (t2 - t3)) - s3fac = (t - t1) * (t - t2) / ((t3 - t1) * (t3 - t2)) - - - - fi = mod(srcioff, 2) - fj = mod(srcjoff, 2) - fk = mod(srckoff, 2) - - i0 = srcioff / 2 - j0 = srcjoff / 2 - k0 = srckoff / 2 - - - -c Loop over fine region -c Label scheme: 8 fk fj fi - -c begin k loop - 8 continue - k = 0 - ks = k0+1 - kd = dstkoff+1 - if (fk.eq.0) goto 80 - if (fk.eq.1) goto 81 - stop - -c begin j loop - 80 continue - j = 0 - js = j0+1 - jd = dstjoff+1 - if (fj.eq.0) goto 800 - if (fj.eq.1) goto 801 - stop - -c begin i loop - 800 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8000 - if (fi.eq.1) goto 8001 - stop - -c kernel - 8000 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js,ks, 1,1,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + s1fac * src1(is,js,ks) - $ + s2fac * src2(is,js,ks) - $ + s3fac * src3(is,js,ks) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8001 - goto 900 - -c kernel - 8001 continue - if (check_array_accesses.ne.0) then - call checkindex (is-1,js,ks, 4,1,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + f1 * s1fac * src1(is-1,js,ks) + f2 * s1fac * src1(is ,js,ks) - $ + f3 * s1fac * src1(is+1,js,ks) + f4 * s1fac * src1(is+2,js,ks) - $ + f1 * s2fac * src2(is-1,js,ks) + f2 * s2fac * src2(is ,js,ks) - $ + f3 * s2fac * src2(is+1,js,ks) + f4 * s2fac * src2(is+2,js,ks) - $ + f1 * s3fac * src3(is-1,js,ks) + f2 * s3fac * src3(is ,js,ks) - $ + f3 * s3fac * src3(is+1,js,ks) + f4 * s3fac * src3(is+2,js,ks) - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8000 - goto 900 - -c end i loop - 900 continue - j = j+1 - jd = jd+1 - if (j.lt.regjext) goto 801 - goto 90 - -c begin i loop - 801 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8010 - if (fi.eq.1) goto 8011 - stop - -c kernel - 8010 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js-1,ks, 1,4,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + f1 * s1fac * src1(is,js-1,ks) + f2 * s1fac * src1(is,js ,ks) - $ + f3 * s1fac * src1(is,js+1,ks) + f4 * s1fac * src1(is,js+2,ks) - $ + f1 * s2fac * src2(is,js-1,ks) + f2 * s2fac * src2(is,js ,ks) - $ + f3 * s2fac * src2(is,js+1,ks) + f4 * s2fac * src2(is,js+2,ks) - $ + f1 * s3fac * src3(is,js-1,ks) + f2 * s3fac * src3(is,js ,ks) - $ + f3 * s3fac * src3(is,js+1,ks) + f4 * s3fac * src3(is,js+2,ks) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8011 - goto 901 - -c kernel - 8011 continue - if (check_array_accesses.ne.0) then - call checkindex (is-1,js-1,ks, 4,4,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + f1*f1 * s1fac * src1(is-1,js-1,ks) - $ + f2*f1 * s1fac * src1(is ,js-1,ks) - $ + f3*f1 * s1fac * src1(is+1,js-1,ks) - $ + f4*f1 * s1fac * src1(is+2,js-1,ks) - $ + f1*f2 * s1fac * src1(is-1,js ,ks) - $ + f2*f2 * s1fac * src1(is ,js ,ks) - $ + f3*f2 * s1fac * src1(is+1,js ,ks) - $ + f4*f2 * s1fac * src1(is+2,js ,ks) - $ + f1*f3 * s1fac * src1(is-1,js+1,ks) - $ + f2*f3 * s1fac * src1(is ,js+1,ks) - $ + f3*f3 * s1fac * src1(is+1,js+1,ks) - $ + f4*f3 * s1fac * src1(is+2,js+1,ks) - $ + f1*f4 * s1fac * src1(is-1,js+2,ks) - $ + f2*f4 * s1fac * src1(is ,js+2,ks) - $ + f3*f4 * s1fac * src1(is+1,js+2,ks) - $ + f4*f4 * s1fac * src1(is+2,js+2,ks) - $ - $ + f1*f1 * s2fac * src2(is-1,js-1,ks) - $ + f2*f1 * s2fac * src2(is ,js-1,ks) - $ + f3*f1 * s2fac * src2(is+1,js-1,ks) - $ + f4*f1 * s2fac * src2(is+2,js-1,ks) - $ + f1*f2 * s2fac * src2(is-1,js ,ks) - $ + f2*f2 * s2fac * src2(is ,js ,ks) - $ + f3*f2 * s2fac * src2(is+1,js ,ks) - $ + f4*f2 * s2fac * src2(is+2,js ,ks) - $ + f1*f3 * s2fac * src2(is-1,js+1,ks) - $ + f2*f3 * s2fac * src2(is ,js+1,ks) - $ + f3*f3 * s2fac * src2(is+1,js+1,ks) - $ + f4*f3 * s2fac * src2(is+2,js+1,ks) - $ + f1*f4 * s2fac * src2(is-1,js+2,ks) - $ + f2*f4 * s2fac * src2(is ,js+2,ks) - $ + f3*f4 * s2fac * src2(is+1,js+2,ks) - $ + f4*f4 * s2fac * src2(is+2,js+2,ks) - $ - $ + f1*f1 * s3fac * src3(is-1,js-1,ks) - $ + f2*f1 * s3fac * src3(is ,js-1,ks) - $ + f3*f1 * s3fac * src3(is+1,js-1,ks) - $ + f4*f1 * s3fac * src3(is+2,js-1,ks) - $ + f1*f2 * s3fac * src3(is-1,js ,ks) - $ + f2*f2 * s3fac * src3(is ,js ,ks) - $ + f3*f2 * s3fac * src3(is+1,js ,ks) - $ + f4*f2 * s3fac * src3(is+2,js ,ks) - $ + f1*f3 * s3fac * src3(is-1,js+1,ks) - $ + f2*f3 * s3fac * src3(is ,js+1,ks) - $ + f3*f3 * s3fac * src3(is+1,js+1,ks) - $ + f4*f3 * s3fac * src3(is+2,js+1,ks) - $ + f1*f4 * s3fac * src3(is-1,js+2,ks) - $ + f2*f4 * s3fac * src3(is ,js+2,ks) - $ + f3*f4 * s3fac * src3(is+1,js+2,ks) - $ + f4*f4 * s3fac * src3(is+2,js+2,ks) - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8010 - goto 901 - -c end i loop - 901 continue - j = j+1 - jd = jd+1 - js = js+1 - if (j.lt.regjext) goto 800 - goto 90 - -c end j loop - 90 continue - k = k+1 - kd = kd+1 - if (k.lt.regkext) goto 81 - goto 9 - -c begin j loop - 81 continue - j = 0 - js = j0+1 - jd = dstjoff+1 - if (fj.eq.0) goto 810 - if (fj.eq.1) goto 811 - stop - -c begin i loop - 810 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8100 - if (fi.eq.1) goto 8101 - stop - -c kernel - 8100 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js,ks-1, 1,1,4, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + f1 * s1fac * src1(is,js,ks-1) + f2 * s1fac * src1(is,js,ks ) - $ + f3 * s1fac * src1(is,js,ks+1) + f4 * s1fac * src1(is,js,ks+2) - $ + f1 * s2fac * src2(is,js,ks-1) + f2 * s2fac * src2(is,js,ks ) - $ + f3 * s2fac * src2(is,js,ks+1) + f4 * s2fac * src2(is,js,ks+2) - $ + f1 * s3fac * src3(is,js,ks-1) + f2 * s3fac * src3(is,js,ks ) - $ + f3 * s3fac * src3(is,js,ks+1) + f4 * s3fac * src3(is,js,ks+2) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8101 - goto 910 - -c kernel - 8101 continue - if (check_array_accesses.ne.0) then - call checkindex (is-1,js,ks-1, 4,1,4, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + f1*f1 * s1fac * src1(is-1,js,ks-1) - $ + f2*f1 * s1fac * src1(is ,js,ks-1) - $ + f3*f1 * s1fac * src1(is+1,js,ks-1) - $ + f4*f1 * s1fac * src1(is+2,js,ks-1) - $ + f1*f2 * s1fac * src1(is-1,js,ks ) - $ + f2*f2 * s1fac * src1(is ,js,ks ) - $ + f3*f2 * s1fac * src1(is+1,js,ks ) - $ + f4*f2 * s1fac * src1(is+2,js,ks ) - $ + f1*f3 * s1fac * src1(is-1,js,ks+1) - $ + f2*f3 * s1fac * src1(is ,js,ks+1) - $ + f3*f3 * s1fac * src1(is+1,js,ks+1) - $ + f4*f3 * s1fac * src1(is+2,js,ks+1) - $ + f1*f4 * s1fac * src1(is-1,js,ks+2) - $ + f2*f4 * s1fac * src1(is ,js,ks+2) - $ + f3*f4 * s1fac * src1(is+1,js,ks+2) - $ + f4*f4 * s1fac * src1(is+2,js,ks+2) - $ - $ + f1*f1 * s2fac * src2(is-1,js,ks-1) - $ + f2*f1 * s2fac * src2(is ,js,ks-1) - $ + f3*f1 * s2fac * src2(is+1,js,ks-1) - $ + f4*f1 * s2fac * src2(is+2,js,ks-1) - $ + f1*f2 * s2fac * src2(is-1,js,ks ) - $ + f2*f2 * s2fac * src2(is ,js,ks ) - $ + f3*f2 * s2fac * src2(is+1,js,ks ) - $ + f4*f2 * s2fac * src2(is+2,js,ks ) - $ + f1*f3 * s2fac * src2(is-1,js,ks+1) - $ + f2*f3 * s2fac * src2(is ,js,ks+1) - $ + f3*f3 * s2fac * src2(is+1,js,ks+1) - $ + f4*f3 * s2fac * src2(is+2,js,ks+1) - $ + f1*f4 * s2fac * src2(is-1,js,ks+2) - $ + f2*f4 * s2fac * src2(is ,js,ks+2) - $ + f3*f4 * s2fac * src2(is+1,js,ks+2) - $ + f4*f4 * s2fac * src2(is+2,js,ks+2) - $ - $ + f1*f1 * s3fac * src3(is-1,js,ks-1) - $ + f2*f1 * s3fac * src3(is ,js,ks-1) - $ + f3*f1 * s3fac * src3(is+1,js,ks-1) - $ + f4*f1 * s3fac * src3(is+2,js,ks-1) - $ + f1*f2 * s3fac * src3(is-1,js,ks ) - $ + f2*f2 * s3fac * src3(is ,js,ks ) - $ + f3*f2 * s3fac * src3(is+1,js,ks ) - $ + f4*f2 * s3fac * src3(is+2,js,ks ) - $ + f1*f3 * s3fac * src3(is-1,js,ks+1) - $ + f2*f3 * s3fac * src3(is ,js,ks+1) - $ + f3*f3 * s3fac * src3(is+1,js,ks+1) - $ + f4*f3 * s3fac * src3(is+2,js,ks+1) - $ + f1*f4 * s3fac * src3(is-1,js,ks+2) - $ + f2*f4 * s3fac * src3(is ,js,ks+2) - $ + f3*f4 * s3fac * src3(is+1,js,ks+2) - $ + f4*f4 * s3fac * src3(is+2,js,ks+2) - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8100 - goto 910 - -c end i loop - 910 continue - j = j+1 - jd = jd+1 - if (j.lt.regjext) goto 811 - goto 91 - -c begin i loop - 811 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8110 - if (fi.eq.1) goto 8111 - stop - -c kernel - 8110 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js-1,ks-1, 1,4,4, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + f1*f1 * s1fac * src1(is,js-1,ks-1) - $ + f2*f1 * s1fac * src1(is,js ,ks-1) - $ + f3*f1 * s1fac * src1(is,js+1,ks-1) - $ + f4*f1 * s1fac * src1(is,js+2,ks-1) - $ + f1*f2 * s1fac * src1(is,js-1,ks ) - $ + f2*f2 * s1fac * src1(is,js ,ks ) - $ + f3*f2 * s1fac * src1(is,js+1,ks ) - $ + f4*f2 * s1fac * src1(is,js+2,ks ) - $ + f1*f3 * s1fac * src1(is,js-1,ks+1) - $ + f2*f3 * s1fac * src1(is,js ,ks+1) - $ + f3*f3 * s1fac * src1(is,js+1,ks+1) - $ + f4*f3 * s1fac * src1(is,js+2,ks+1) - $ + f1*f4 * s1fac * src1(is,js-1,ks+2) - $ + f2*f4 * s1fac * src1(is,js ,ks+2) - $ + f3*f4 * s1fac * src1(is,js+1,ks+2) - $ + f4*f4 * s1fac * src1(is,js+2,ks+2) - $ - $ + f1*f1 * s2fac * src2(is,js-1,ks-1) - $ + f2*f1 * s2fac * src2(is,js ,ks-1) - $ + f3*f1 * s2fac * src2(is,js+1,ks-1) - $ + f4*f1 * s2fac * src2(is,js+2,ks-1) - $ + f1*f2 * s2fac * src2(is,js-1,ks ) - $ + f2*f2 * s2fac * src2(is,js ,ks ) - $ + f3*f2 * s2fac * src2(is,js+1,ks ) - $ + f4*f2 * s2fac * src2(is,js+2,ks ) - $ + f1*f3 * s2fac * src2(is,js-1,ks+1) - $ + f2*f3 * s2fac * src2(is,js ,ks+1) - $ + f3*f3 * s2fac * src2(is,js+1,ks+1) - $ + f4*f3 * s2fac * src2(is,js+2,ks+1) - $ + f1*f4 * s2fac * src2(is,js-1,ks+2) - $ + f2*f4 * s2fac * src2(is,js ,ks+2) - $ + f3*f4 * s2fac * src2(is,js+1,ks+2) - $ + f4*f4 * s2fac * src2(is,js+2,ks+2) - $ - $ + f1*f1 * s3fac * src3(is,js-1,ks-1) - $ + f2*f1 * s3fac * src3(is,js ,ks-1) - $ + f3*f1 * s3fac * src3(is,js+1,ks-1) - $ + f4*f1 * s3fac * src3(is,js+2,ks-1) - $ + f1*f2 * s3fac * src3(is,js-1,ks ) - $ + f2*f2 * s3fac * src3(is,js ,ks ) - $ + f3*f2 * s3fac * src3(is,js+1,ks ) - $ + f4*f2 * s3fac * src3(is,js+2,ks ) - $ + f1*f3 * s3fac * src3(is,js-1,ks+1) - $ + f2*f3 * s3fac * src3(is,js ,ks+1) - $ + f3*f3 * s3fac * src3(is,js+1,ks+1) - $ + f4*f3 * s3fac * src3(is,js+2,ks+1) - $ + f1*f4 * s3fac * src3(is,js-1,ks+2) - $ + f2*f4 * s3fac * src3(is,js ,ks+2) - $ + f3*f4 * s3fac * src3(is,js+1,ks+2) - $ + f4*f4 * s3fac * src3(is,js+2,ks+2) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8111 - goto 911 - -c kernel - 8111 continue - if (check_array_accesses.ne.0) then - call checkindex (is-1,js-1,ks-1, 4,4,4, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - res1 = - $ + f1*f1*f1 * s1fac * src1(is-1,js-1,ks-1) - $ + f2*f1*f1 * s1fac * src1(is ,js-1,ks-1) - $ + f3*f1*f1 * s1fac * src1(is+1,js-1,ks-1) - $ + f4*f1*f1 * s1fac * src1(is+2,js-1,ks-1) - $ + f1*f2*f1 * s1fac * src1(is-1,js ,ks-1) - $ + f2*f2*f1 * s1fac * src1(is ,js ,ks-1) - $ + f3*f2*f1 * s1fac * src1(is+1,js ,ks-1) - $ + f4*f2*f1 * s1fac * src1(is+2,js ,ks-1) - $ + f1*f3*f1 * s1fac * src1(is-1,js+1,ks-1) - $ + f2*f3*f1 * s1fac * src1(is ,js+1,ks-1) - $ + f3*f3*f1 * s1fac * src1(is+1,js+1,ks-1) - $ + f4*f3*f1 * s1fac * src1(is+2,js+1,ks-1) - $ + f1*f4*f1 * s1fac * src1(is-1,js+2,ks-1) - $ + f2*f4*f1 * s1fac * src1(is ,js+2,ks-1) - $ + f3*f4*f1 * s1fac * src1(is+1,js+2,ks-1) - $ + f4*f4*f1 * s1fac * src1(is+2,js+2,ks-1) - $ - $ + f1*f1*f2 * s1fac * src1(is-1,js-1,ks ) - $ + f2*f1*f2 * s1fac * src1(is ,js-1,ks ) - $ + f3*f1*f2 * s1fac * src1(is+1,js-1,ks ) - $ + f4*f1*f2 * s1fac * src1(is+2,js-1,ks ) - $ + f1*f2*f2 * s1fac * src1(is-1,js ,ks ) - $ + f2*f2*f2 * s1fac * src1(is ,js ,ks ) - $ + f3*f2*f2 * s1fac * src1(is+1,js ,ks ) - $ + f4*f2*f2 * s1fac * src1(is+2,js ,ks ) - $ + f1*f3*f2 * s1fac * src1(is-1,js+1,ks ) - $ + f2*f3*f2 * s1fac * src1(is ,js+1,ks ) - $ + f3*f3*f2 * s1fac * src1(is+1,js+1,ks ) - $ + f4*f3*f2 * s1fac * src1(is+2,js+1,ks ) - $ + f1*f4*f2 * s1fac * src1(is-1,js+2,ks ) - $ + f2*f4*f2 * s1fac * src1(is ,js+2,ks ) - $ + f3*f4*f2 * s1fac * src1(is+1,js+2,ks ) - $ + f4*f4*f2 * s1fac * src1(is+2,js+2,ks ) - $ - $ + f1*f1*f3 * s1fac * src1(is-1,js-1,ks+1) - $ + f2*f1*f3 * s1fac * src1(is ,js-1,ks+1) - $ + f3*f1*f3 * s1fac * src1(is+1,js-1,ks+1) - $ + f4*f1*f3 * s1fac * src1(is+2,js-1,ks+1) - $ + f1*f2*f3 * s1fac * src1(is-1,js ,ks+1) - $ + f2*f2*f3 * s1fac * src1(is ,js ,ks+1) - $ + f3*f2*f3 * s1fac * src1(is+1,js ,ks+1) - $ + f4*f2*f3 * s1fac * src1(is+2,js ,ks+1) - $ + f1*f3*f3 * s1fac * src1(is-1,js+1,ks+1) - $ + f2*f3*f3 * s1fac * src1(is ,js+1,ks+1) - $ + f3*f3*f3 * s1fac * src1(is+1,js+1,ks+1) - $ + f4*f3*f3 * s1fac * src1(is+2,js+1,ks+1) - $ + f1*f4*f3 * s1fac * src1(is-1,js+2,ks+1) - $ + f2*f4*f3 * s1fac * src1(is ,js+2,ks+1) - $ + f3*f4*f3 * s1fac * src1(is+1,js+2,ks+1) - $ + f4*f4*f3 * s1fac * src1(is+2,js+2,ks+1) - $ - $ + f1*f1*f4 * s1fac * src1(is-1,js-1,ks+2) - $ + f2*f1*f4 * s1fac * src1(is ,js-1,ks+2) - $ + f3*f1*f4 * s1fac * src1(is+1,js-1,ks+2) - $ + f4*f1*f4 * s1fac * src1(is+2,js-1,ks+2) - $ + f1*f2*f4 * s1fac * src1(is-1,js ,ks+2) - $ + f2*f2*f4 * s1fac * src1(is ,js ,ks+2) - $ + f3*f2*f4 * s1fac * src1(is+1,js ,ks+2) - $ + f4*f2*f4 * s1fac * src1(is+2,js ,ks+2) - $ + f1*f3*f4 * s1fac * src1(is-1,js+1,ks+2) - $ + f2*f3*f4 * s1fac * src1(is ,js+1,ks+2) - $ + f3*f3*f4 * s1fac * src1(is+1,js+1,ks+2) - $ + f4*f3*f4 * s1fac * src1(is+2,js+1,ks+2) - $ + f1*f4*f4 * s1fac * src1(is-1,js+2,ks+2) - $ + f2*f4*f4 * s1fac * src1(is ,js+2,ks+2) - $ + f3*f4*f4 * s1fac * src1(is+1,js+2,ks+2) - $ + f4*f4*f4 * s1fac * src1(is+2,js+2,ks+2) - res2 = - $ + f1*f1*f1 * s2fac * src2(is-1,js-1,ks-1) - $ + f2*f1*f1 * s2fac * src2(is ,js-1,ks-1) - $ + f3*f1*f1 * s2fac * src2(is+1,js-1,ks-1) - $ + f4*f1*f1 * s2fac * src2(is+2,js-1,ks-1) - $ + f1*f2*f1 * s2fac * src2(is-1,js ,ks-1) - $ + f2*f2*f1 * s2fac * src2(is ,js ,ks-1) - $ + f3*f2*f1 * s2fac * src2(is+1,js ,ks-1) - $ + f4*f2*f1 * s2fac * src2(is+2,js ,ks-1) - $ + f1*f3*f1 * s2fac * src2(is-1,js+1,ks-1) - $ + f2*f3*f1 * s2fac * src2(is ,js+1,ks-1) - $ + f3*f3*f1 * s2fac * src2(is+1,js+1,ks-1) - $ + f4*f3*f1 * s2fac * src2(is+2,js+1,ks-1) - $ + f1*f4*f1 * s2fac * src2(is-1,js+2,ks-1) - $ + f2*f4*f1 * s2fac * src2(is ,js+2,ks-1) - $ + f3*f4*f1 * s2fac * src2(is+1,js+2,ks-1) - $ + f4*f4*f1 * s2fac * src2(is+2,js+2,ks-1) - $ - $ + f1*f1*f2 * s2fac * src2(is-1,js-1,ks ) - $ + f2*f1*f2 * s2fac * src2(is ,js-1,ks ) - $ + f3*f1*f2 * s2fac * src2(is+1,js-1,ks ) - $ + f4*f1*f2 * s2fac * src2(is+2,js-1,ks ) - $ + f1*f2*f2 * s2fac * src2(is-1,js ,ks ) - $ + f2*f2*f2 * s2fac * src2(is ,js ,ks ) - $ + f3*f2*f2 * s2fac * src2(is+1,js ,ks ) - $ + f4*f2*f2 * s2fac * src2(is+2,js ,ks ) - $ + f1*f3*f2 * s2fac * src2(is-1,js+1,ks ) - $ + f2*f3*f2 * s2fac * src2(is ,js+1,ks ) - $ + f3*f3*f2 * s2fac * src2(is+1,js+1,ks ) - $ + f4*f3*f2 * s2fac * src2(is+2,js+1,ks ) - $ + f1*f4*f2 * s2fac * src2(is-1,js+2,ks ) - $ + f2*f4*f2 * s2fac * src2(is ,js+2,ks ) - $ + f3*f4*f2 * s2fac * src2(is+1,js+2,ks ) - $ + f4*f4*f2 * s2fac * src2(is+2,js+2,ks ) - $ - $ + f1*f1*f3 * s2fac * src2(is-1,js-1,ks+1) - $ + f2*f1*f3 * s2fac * src2(is ,js-1,ks+1) - $ + f3*f1*f3 * s2fac * src2(is+1,js-1,ks+1) - $ + f4*f1*f3 * s2fac * src2(is+2,js-1,ks+1) - $ + f1*f2*f3 * s2fac * src2(is-1,js ,ks+1) - $ + f2*f2*f3 * s2fac * src2(is ,js ,ks+1) - $ + f3*f2*f3 * s2fac * src2(is+1,js ,ks+1) - $ + f4*f2*f3 * s2fac * src2(is+2,js ,ks+1) - $ + f1*f3*f3 * s2fac * src2(is-1,js+1,ks+1) - $ + f2*f3*f3 * s2fac * src2(is ,js+1,ks+1) - $ + f3*f3*f3 * s2fac * src2(is+1,js+1,ks+1) - $ + f4*f3*f3 * s2fac * src2(is+2,js+1,ks+1) - $ + f1*f4*f3 * s2fac * src2(is-1,js+2,ks+1) - $ + f2*f4*f3 * s2fac * src2(is ,js+2,ks+1) - $ + f3*f4*f3 * s2fac * src2(is+1,js+2,ks+1) - $ + f4*f4*f3 * s2fac * src2(is+2,js+2,ks+1) - $ - $ + f1*f1*f4 * s2fac * src2(is-1,js-1,ks+2) - $ + f2*f1*f4 * s2fac * src2(is ,js-1,ks+2) - $ + f3*f1*f4 * s2fac * src2(is+1,js-1,ks+2) - $ + f4*f1*f4 * s2fac * src2(is+2,js-1,ks+2) - $ + f1*f2*f4 * s2fac * src2(is-1,js ,ks+2) - $ + f2*f2*f4 * s2fac * src2(is ,js ,ks+2) - $ + f3*f2*f4 * s2fac * src2(is+1,js ,ks+2) - $ + f4*f2*f4 * s2fac * src2(is+2,js ,ks+2) - $ + f1*f3*f4 * s2fac * src2(is-1,js+1,ks+2) - $ + f2*f3*f4 * s2fac * src2(is ,js+1,ks+2) - $ + f3*f3*f4 * s2fac * src2(is+1,js+1,ks+2) - $ + f4*f3*f4 * s2fac * src2(is+2,js+1,ks+2) - $ + f1*f4*f4 * s2fac * src2(is-1,js+2,ks+2) - $ + f2*f4*f4 * s2fac * src2(is ,js+2,ks+2) - $ + f3*f4*f4 * s2fac * src2(is+1,js+2,ks+2) - $ + f4*f4*f4 * s2fac * src2(is+2,js+2,ks+2) - res3 = - $ + f1*f1*f1 * s3fac * src3(is-1,js-1,ks-1) - $ + f2*f1*f1 * s3fac * src3(is ,js-1,ks-1) - $ + f3*f1*f1 * s3fac * src3(is+1,js-1,ks-1) - $ + f4*f1*f1 * s3fac * src3(is+2,js-1,ks-1) - $ + f1*f2*f1 * s3fac * src3(is-1,js ,ks-1) - $ + f2*f2*f1 * s3fac * src3(is ,js ,ks-1) - $ + f3*f2*f1 * s3fac * src3(is+1,js ,ks-1) - $ + f4*f2*f1 * s3fac * src3(is+2,js ,ks-1) - $ + f1*f3*f1 * s3fac * src3(is-1,js+1,ks-1) - $ + f2*f3*f1 * s3fac * src3(is ,js+1,ks-1) - $ + f3*f3*f1 * s3fac * src3(is+1,js+1,ks-1) - $ + f4*f3*f1 * s3fac * src3(is+2,js+1,ks-1) - $ + f1*f4*f1 * s3fac * src3(is-1,js+2,ks-1) - $ + f2*f4*f1 * s3fac * src3(is ,js+2,ks-1) - $ + f3*f4*f1 * s3fac * src3(is+1,js+2,ks-1) - $ + f4*f4*f1 * s3fac * src3(is+2,js+2,ks-1) - $ - $ + f1*f1*f2 * s3fac * src3(is-1,js-1,ks ) - $ + f2*f1*f2 * s3fac * src3(is ,js-1,ks ) - $ + f3*f1*f2 * s3fac * src3(is+1,js-1,ks ) - $ + f4*f1*f2 * s3fac * src3(is+2,js-1,ks ) - $ + f1*f2*f2 * s3fac * src3(is-1,js ,ks ) - $ + f2*f2*f2 * s3fac * src3(is ,js ,ks ) - $ + f3*f2*f2 * s3fac * src3(is+1,js ,ks ) - $ + f4*f2*f2 * s3fac * src3(is+2,js ,ks ) - $ + f1*f3*f2 * s3fac * src3(is-1,js+1,ks ) - $ + f2*f3*f2 * s3fac * src3(is ,js+1,ks ) - $ + f3*f3*f2 * s3fac * src3(is+1,js+1,ks ) - $ + f4*f3*f2 * s3fac * src3(is+2,js+1,ks ) - $ + f1*f4*f2 * s3fac * src3(is-1,js+2,ks ) - $ + f2*f4*f2 * s3fac * src3(is ,js+2,ks ) - $ + f3*f4*f2 * s3fac * src3(is+1,js+2,ks ) - $ + f4*f4*f2 * s3fac * src3(is+2,js+2,ks ) - $ - $ + f1*f1*f3 * s3fac * src3(is-1,js-1,ks+1) - $ + f2*f1*f3 * s3fac * src3(is ,js-1,ks+1) - $ + f3*f1*f3 * s3fac * src3(is+1,js-1,ks+1) - $ + f4*f1*f3 * s3fac * src3(is+2,js-1,ks+1) - $ + f1*f2*f3 * s3fac * src3(is-1,js ,ks+1) - $ + f2*f2*f3 * s3fac * src3(is ,js ,ks+1) - $ + f3*f2*f3 * s3fac * src3(is+1,js ,ks+1) - $ + f4*f2*f3 * s3fac * src3(is+2,js ,ks+1) - $ + f1*f3*f3 * s3fac * src3(is-1,js+1,ks+1) - $ + f2*f3*f3 * s3fac * src3(is ,js+1,ks+1) - $ + f3*f3*f3 * s3fac * src3(is+1,js+1,ks+1) - $ + f4*f3*f3 * s3fac * src3(is+2,js+1,ks+1) - $ + f1*f4*f3 * s3fac * src3(is-1,js+2,ks+1) - $ + f2*f4*f3 * s3fac * src3(is ,js+2,ks+1) - $ + f3*f4*f3 * s3fac * src3(is+1,js+2,ks+1) - $ + f4*f4*f3 * s3fac * src3(is+2,js+2,ks+1) - $ - $ + f1*f1*f4 * s3fac * src3(is-1,js-1,ks+2) - $ + f2*f1*f4 * s3fac * src3(is ,js-1,ks+2) - $ + f3*f1*f4 * s3fac * src3(is+1,js-1,ks+2) - $ + f4*f1*f4 * s3fac * src3(is+2,js-1,ks+2) - $ + f1*f2*f4 * s3fac * src3(is-1,js ,ks+2) - $ + f2*f2*f4 * s3fac * src3(is ,js ,ks+2) - $ + f3*f2*f4 * s3fac * src3(is+1,js ,ks+2) - $ + f4*f2*f4 * s3fac * src3(is+2,js ,ks+2) - $ + f1*f3*f4 * s3fac * src3(is-1,js+1,ks+2) - $ + f2*f3*f4 * s3fac * src3(is ,js+1,ks+2) - $ + f3*f3*f4 * s3fac * src3(is+1,js+1,ks+2) - $ + f4*f3*f4 * s3fac * src3(is+2,js+1,ks+2) - $ + f1*f4*f4 * s3fac * src3(is-1,js+2,ks+2) - $ + f2*f4*f4 * s3fac * src3(is ,js+2,ks+2) - $ + f3*f4*f4 * s3fac * src3(is+1,js+2,ks+2) - $ + f4*f4*f4 * s3fac * src3(is+2,js+2,ks+2) - dst(id,jd,kd) = res1 + res2 + res3 - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8110 - goto 911 - -c end i loop - 911 continue - j = j+1 - jd = jd+1 - js = js+1 - if (j.lt.regjext) goto 810 - goto 91 - -c end j loop - 91 continue - k = k+1 - kd = kd+1 - ks = ks+1 - if (k.lt.regkext) goto 80 - goto 9 - -c end k loop - 9 continue - - end diff --git a/Carpet/CarpetLib/src/prolongate_3d_real8_3tl_o5.F77 b/Carpet/CarpetLib/src/prolongate_3d_real8_3tl_o5.F77 deleted file mode 100644 index 53f2642f5..000000000 --- a/Carpet/CarpetLib/src/prolongate_3d_real8_3tl_o5.F77 +++ /dev/null @@ -1,221 +0,0 @@ -c -*-Fortran-*- - -#include "cctk.h" -#include "cctk_Parameters.h" - - - - subroutine prolongate_3d_real8_3tl_o5 ( - $ src1, t1, src2, t2, src3, t3, srciext, srcjext, srckext, - $ dst, t, dstiext, dstjext, dstkext, - $ srcbbox, dstbbox, regbbox) - - implicit none - - DECLARE_CCTK_PARAMETERS - - CCTK_REAL8 one - parameter (one = 1) - - CCTK_REAL8 eps - parameter (eps = 1.0d-10) - - integer srciext, srcjext, srckext - CCTK_REAL8 src1(srciext,srcjext,srckext) - CCTK_REAL8 t1 - CCTK_REAL8 src2(srciext,srcjext,srckext) - CCTK_REAL8 t2 - CCTK_REAL8 src3(srciext,srcjext,srckext) - CCTK_REAL8 t3 - integer dstiext, dstjext, dstkext - CCTK_REAL8 dst(dstiext,dstjext,dstkext) - CCTK_REAL8 t -c bbox(:,1) is lower boundary (inclusive) -c bbox(:,2) is upper boundary (inclusive) -c bbox(:,3) is stride - integer srcbbox(3,3), dstbbox(3,3), regbbox(3,3) - - integer offsetlo, offsethi - - integer regiext, regjext, regkext - - integer dstifac, dstjfac, dstkfac - - integer srcioff, srcjoff, srckoff - integer dstioff, dstjoff, dstkoff - - CCTK_REAL8 s1fac, s2fac, s3fac - - CCTK_REAL8 dstdiv - integer i, j, k - integer i0, j0, k0 - integer fi, fj, fk - integer ifac(6), jfac(6), kfac(6) - integer ii, jj, kk - CCTK_REAL8 fac - CCTK_REAL8 res - integer d - - - - do d=1,3 - if (srcbbox(d,3).eq.0 .or. dstbbox(d,3).eq.0 - $ .or. regbbox(d,3).eq.0) then - call CCTK_WARN (0, "Internal error: stride is zero") - end if - if (srcbbox(d,3).le.regbbox(d,3) - $ .or. dstbbox(d,3).ne.regbbox(d,3)) then - call CCTK_WARN (0, "Internal error: strides disagree") - end if - if (mod(srcbbox(d,3), dstbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: destination strides are not integer multiples of the source strides") - end if - if (mod(srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array origins are not integer multiples of the strides") - end if - if (regbbox(d,1).gt.regbbox(d,2)) then -c This could be handled, but is likely to point to an error elsewhere - call CCTK_WARN (0, "Internal error: region extent is empty") - end if - if (mod(srcbbox(d,2) - srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,2) - dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,2) - regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array extents are not integer multiples of the strides") - end if - regkext = (regbbox(d,2) - regbbox(d,1)) / regbbox(d,3) + 1 - dstkfac = srcbbox(d,3) / dstbbox(d,3) - srckoff = (regbbox(d,1) - srcbbox(d,1)) / dstbbox(d,3) - offsetlo = regbbox(d,3) - if (mod(srckoff + 0, dstkfac).eq.0) then - offsetlo = 0 - if (regkext.gt.1) then - offsetlo = regbbox(d,3) - end if - end if - offsethi = regbbox(d,3) - if (mod(srckoff + regkext-1, dstkfac).eq.0) then - offsethi = 0 - if (regkext.gt.1) then - offsethi = regbbox(d,3) - end if - end if - if (regbbox(d,1)-offsetlo.lt.srcbbox(d,1) - $ .or. regbbox(d,2)+offsethi.gt.srcbbox(d,2) - $ .or. regbbox(d,1).lt.dstbbox(d,1) - $ .or. regbbox(d,2).gt.dstbbox(d,2)) then - call CCTK_WARN (0, "Internal error: region extent is not contained in array extent") - end if - end do - - if (srciext.ne.(srcbbox(1,2)-srcbbox(1,1))/srcbbox(1,3)+1 - $ .or. srcjext.ne.(srcbbox(2,2)-srcbbox(2,1))/srcbbox(2,3)+1 - $ .or. srckext.ne.(srcbbox(3,2)-srcbbox(3,1))/srcbbox(3,3)+1 - $ .or. dstiext.ne.(dstbbox(1,2)-dstbbox(1,1))/dstbbox(1,3)+1 - $ .or. dstjext.ne.(dstbbox(2,2)-dstbbox(2,1))/dstbbox(2,3)+1 - $ .or. dstkext.ne.(dstbbox(3,2)-dstbbox(3,1))/dstbbox(3,3)+1) then - call CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes") - end if - - - - regiext = (regbbox(1,2) - regbbox(1,1)) / regbbox(1,3) + 1 - regjext = (regbbox(2,2) - regbbox(2,1)) / regbbox(2,3) + 1 - regkext = (regbbox(3,2) - regbbox(3,1)) / regbbox(3,3) + 1 - - dstifac = srcbbox(1,3) / dstbbox(1,3) - dstjfac = srcbbox(2,3) / dstbbox(2,3) - dstkfac = srcbbox(3,3) / dstbbox(3,3) - - srcioff = (regbbox(1,1) - srcbbox(1,1)) / dstbbox(1,3) - srcjoff = (regbbox(2,1) - srcbbox(2,1)) / dstbbox(2,3) - srckoff = (regbbox(3,1) - srcbbox(3,1)) / dstbbox(3,3) - - dstioff = (regbbox(1,1) - dstbbox(1,1)) / dstbbox(1,3) - dstjoff = (regbbox(2,1) - dstbbox(2,1)) / dstbbox(2,3) - dstkoff = (regbbox(3,1) - dstbbox(3,1)) / dstbbox(3,3) - - - -c Quadratic (second order) interpolation - if (t1.eq.t2 .or. t1.eq.t3 .or. t2.eq.t3) then - call CCTK_WARN (0, "Internal error: arrays have same time") - end if - if (t.lt.min(t1,t2,t3)-eps .or. t.gt.max(t1,t2,t3)+eps) then - call CCTK_WARN (0, "Internal error: extrapolation in time") - end if - - s1fac = (t - t2) * (t - t3) / ((t1 - t2) * (t1 - t3)) - s2fac = (t - t1) * (t - t3) / ((t2 - t1) * (t2 - t3)) - s3fac = (t - t1) * (t - t2) / ((t3 - t1) * (t3 - t2)) - - - -c Loop over fine region -c (This expression cannot be evaluated as integer) - dstdiv = one / (120*dstifac**5) / (120*dstjfac**5) / (120*dstkfac**5) - - do k = 0, regkext-1 - k0 = (srckoff + k) / dstkfac - fk = mod(srckoff + k, dstkfac) - kfac(1) = (fk+ dstkfac) * (fk ) * (fk-dstkfac) * (fk-2*dstkfac) * (fk-3*dstkfac) * (- 1) - kfac(2) = (fk+2*dstkfac) * (fk ) * (fk-dstkfac) * (fk-2*dstkfac) * (fk-3*dstkfac) * ( 5) - kfac(3) = (fk+2*dstkfac) * (fk+dstkfac) * (fk-dstkfac) * (fk-2*dstkfac) * (fk-3*dstkfac) * (-10) - kfac(4) = (fk+2*dstkfac) * (fk+dstkfac) * (fk ) * (fk-2*dstkfac) * (fk-3*dstkfac) * ( 10) - kfac(5) = (fk+2*dstkfac) * (fk+dstkfac) * (fk ) * (fk- dstkfac) * (fk-3*dstkfac) * (- 5) - kfac(6) = (fk+2*dstkfac) * (fk+dstkfac) * (fk ) * (fk- dstkfac) * (fk-2*dstkfac) * ( 1) - - do j = 0, regjext-1 - j0 = (srcjoff + j) / dstjfac - fj = mod(srcjoff + j, dstjfac) - jfac(1) = (fj+ dstjfac) * (fj ) * (fj-dstjfac) * (fj-2*dstjfac) * (fj-3*dstjfac) * (- 1) - jfac(2) = (fj+2*dstjfac) * (fj ) * (fj-dstjfac) * (fj-2*dstjfac) * (fj-3*dstjfac) * ( 5) - jfac(3) = (fj+2*dstjfac) * (fj+dstjfac) * (fj-dstjfac) * (fj-2*dstjfac) * (fj-3*dstjfac) * (-10) - jfac(4) = (fj+2*dstjfac) * (fj+dstjfac) * (fj ) * (fj-2*dstjfac) * (fj-3*dstjfac) * ( 10) - jfac(5) = (fj+2*dstjfac) * (fj+dstjfac) * (fj ) * (fj- dstjfac) * (fj-3*dstjfac) * (- 5) - jfac(6) = (fj+2*dstjfac) * (fj+dstjfac) * (fj ) * (fj- dstjfac) * (fj-2*dstjfac) * ( 1) - - do i = 0, regiext-1 - i0 = (srcioff + i) / dstifac - fi = mod(srcioff + i, dstifac) - ifac(1) = (fi+ dstifac) * (fi ) * (fi-dstifac) * (fi-2*dstifac) * (fi-3*dstifac) * (- 1) - ifac(2) = (fi+2*dstifac) * (fi ) * (fi-dstifac) * (fi-2*dstifac) * (fi-3*dstifac) * ( 5) - ifac(3) = (fi+2*dstifac) * (fi+dstifac) * (fi-dstifac) * (fi-2*dstifac) * (fi-3*dstifac) * (-10) - ifac(4) = (fi+2*dstifac) * (fi+dstifac) * (fi ) * (fi-2*dstifac) * (fi-3*dstifac) * ( 10) - ifac(5) = (fi+2*dstifac) * (fi+dstifac) * (fi ) * (fi- dstifac) * (fi-3*dstifac) * (- 5) - ifac(6) = (fi+2*dstifac) * (fi+dstifac) * (fi ) * (fi- dstifac) * (fi-2*dstifac) * ( 1) - - res = 0 - - do kk=1,6 - do jj=1,6 - do ii=1,6 - - if (ifac(ii).ne.0 .and. jfac(jj).ne.0 .and. kfac(kk).ne.0) then -c (This expression cannot be evaluated as integer) - fac = one * ifac(ii) * jfac(jj) * kfac(kk) - - if (check_array_accesses.ne.0) then - call checkindex (i0+ii-2, j0+jj-2, k0+kk-2, 1,1,1, srciext,srcjext,srckext, "source") - end if - res = res - $ + fac * s1fac * src1(i0+ii-2, j0+jj-2, k0+kk-2) - $ + fac * s2fac * src2(i0+ii-2, j0+jj-2, k0+kk-2) - $ + fac * s3fac * src3(i0+ii-2, j0+jj-2, k0+kk-2) - end if - - end do - end do - end do - - if (check_array_accesses.ne.0) then - call checkindex (dstioff+i+1, dstjoff+j+1, dstkoff+k+1, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst (dstioff+i+1, dstjoff+j+1, dstkoff+k+1) = dstdiv * res - - end do - end do - end do - - end diff --git a/Carpet/CarpetLib/src/prolongate_3d_real8_3tl_o5_rf2.F77 b/Carpet/CarpetLib/src/prolongate_3d_real8_3tl_o5_rf2.F77 deleted file mode 100644 index e7e5afadb..000000000 --- a/Carpet/CarpetLib/src/prolongate_3d_real8_3tl_o5_rf2.F77 +++ /dev/null @@ -1,1441 +0,0 @@ -c -*-Fortran-*- - -#include "cctk.h" -#include "cctk_Parameters.h" - - - - subroutine prolongate_3d_real8_3tl_o5_rf2 ( - $ src1, t1, src2, t2, src3, t3, srciext, srcjext, srckext, - $ dst, t, dstiext, dstjext, dstkext, - $ srcbbox, dstbbox, regbbox) - - implicit none - - DECLARE_CCTK_PARAMETERS - - CCTK_REAL8 eps - parameter (eps = 1.0d-10) - - CCTK_REAL8 one - parameter (one = 1) - CCTK_REAL8 f1, f2, f3, f4, f5, f6 - parameter (f1 = 3*one/256) - parameter (f2 = - 25*one/256) - parameter (f3 = 150*one/256) - parameter (f4 = 150*one/256) - parameter (f5 = - 25*one/256) - parameter (f6 = 3*one/256) - - integer srciext, srcjext, srckext - CCTK_REAL8 src1(srciext,srcjext,srckext) - CCTK_REAL8 t1 - CCTK_REAL8 src2(srciext,srcjext,srckext) - CCTK_REAL8 t2 - CCTK_REAL8 src3(srciext,srcjext,srckext) - CCTK_REAL8 t3 - integer dstiext, dstjext, dstkext - CCTK_REAL8 dst(dstiext,dstjext,dstkext) - CCTK_REAL8 t -c bbox(:,1) is lower boundary (inclusive) -c bbox(:,2) is upper boundary (inclusive) -c bbox(:,3) is stride - integer srcbbox(3,3), dstbbox(3,3), regbbox(3,3) - - integer regiext, regjext, regkext - - integer srcioff, srcjoff, srckoff - integer dstioff, dstjoff, dstkoff - - integer offsetlo, offsethi - - CCTK_REAL8 s1fac, s2fac, s3fac - - integer i0, j0, k0 - integer fi, fj, fk - integer is, js, ks - integer id, jd, kd - integer i, j, k - - CCTK_REAL8 res1, res2, res3 - CCTK_REAL8 res11, res12, res13, res14, res15, res16 - CCTK_REAL8 res21, res22, res23, res24, res25, res26 - CCTK_REAL8 res31, res32, res33, res34, res35, res36 - - integer d - - - - do d=1,3 - if (srcbbox(d,3).eq.0 .or. dstbbox(d,3).eq.0 - $ .or. regbbox(d,3).eq.0) then - call CCTK_WARN (0, "Internal error: stride is zero") - end if - if (srcbbox(d,3).le.regbbox(d,3) - $ .or. dstbbox(d,3).ne.regbbox(d,3)) then - call CCTK_WARN (0, "Internal error: strides disagree") - end if - if (srcbbox(d,3).ne.dstbbox(d,3)*2) then - call CCTK_WARN (0, "Internal error: source strides are not twice the destination strides") - end if - if (mod(srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array origins are not integer multiples of the strides") - end if - if (regbbox(d,1).gt.regbbox(d,2)) then -c This could be handled, but is likely to point to an error elsewhere - call CCTK_WARN (0, "Internal error: region extent is empty") - end if - if (mod(srcbbox(d,2) - srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,2) - dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,2) - regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array extents are not integer multiples of the strides") - end if - regkext = (regbbox(d,2) - regbbox(d,1)) / regbbox(d,3) + 1 - srckoff = (regbbox(d,1) - srcbbox(d,1)) / dstbbox(d,3) - offsetlo = regbbox(d,3) - if (mod(srckoff, 2).eq.0) then - offsetlo = 0 - if (regkext.gt.1) then - offsetlo = regbbox(d,3) - end if - end if - offsethi = regbbox(d,3) - if (mod(srckoff + regkext-1, 2).eq.0) then - offsethi = 0 - if (regkext.gt.1) then - offsethi = regbbox(d,3) - end if - end if - if (regbbox(d,1)-offsetlo.lt.srcbbox(d,1) - $ .or. regbbox(d,2)+offsethi.gt.srcbbox(d,2) - $ .or. regbbox(d,1).lt.dstbbox(d,1) - $ .or. regbbox(d,2).gt.dstbbox(d,2)) then - call CCTK_WARN (0, "Internal error: region extent is not contained in array extent") - end if - end do - - if (srciext.ne.(srcbbox(1,2)-srcbbox(1,1))/srcbbox(1,3)+1 - $ .or. srcjext.ne.(srcbbox(2,2)-srcbbox(2,1))/srcbbox(2,3)+1 - $ .or. srckext.ne.(srcbbox(3,2)-srcbbox(3,1))/srcbbox(3,3)+1 - $ .or. dstiext.ne.(dstbbox(1,2)-dstbbox(1,1))/dstbbox(1,3)+1 - $ .or. dstjext.ne.(dstbbox(2,2)-dstbbox(2,1))/dstbbox(2,3)+1 - $ .or. dstkext.ne.(dstbbox(3,2)-dstbbox(3,1))/dstbbox(3,3)+1) then - call CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes") - end if - - - - regiext = (regbbox(1,2) - regbbox(1,1)) / regbbox(1,3) + 1 - regjext = (regbbox(2,2) - regbbox(2,1)) / regbbox(2,3) + 1 - regkext = (regbbox(3,2) - regbbox(3,1)) / regbbox(3,3) + 1 - - srcioff = (regbbox(1,1) - srcbbox(1,1)) / dstbbox(1,3) - srcjoff = (regbbox(2,1) - srcbbox(2,1)) / dstbbox(2,3) - srckoff = (regbbox(3,1) - srcbbox(3,1)) / dstbbox(3,3) - - dstioff = (regbbox(1,1) - dstbbox(1,1)) / dstbbox(1,3) - dstjoff = (regbbox(2,1) - dstbbox(2,1)) / dstbbox(2,3) - dstkoff = (regbbox(3,1) - dstbbox(3,1)) / dstbbox(3,3) - - - -c Quadratic (second order) time interpolation - if (t1.eq.t2 .or. t1.eq.t3 .or. t2.eq.t3) then - call CCTK_WARN (0, "Internal error: arrays have same time") - end if - if (t.lt.min(t1,t2,t3)-eps .or. t.gt.max(t1,t2,t3)+eps) then - call CCTK_WARN (0, "Internal error: extrapolation in time in time") - end if - - s1fac = (t - t2) * (t - t3) / ((t1 - t2) * (t1 - t3)) - s2fac = (t - t1) * (t - t3) / ((t2 - t1) * (t2 - t3)) - s3fac = (t - t1) * (t - t2) / ((t3 - t1) * (t3 - t2)) - - - - fi = mod(srcioff, 2) - fj = mod(srcjoff, 2) - fk = mod(srckoff, 2) - - i0 = srcioff / 2 - j0 = srcjoff / 2 - k0 = srckoff / 2 - - - -c Loop over fine region -c Label scheme: 8 fk fj fi - -c begin k loop - 8 continue - k = 0 - ks = k0+1 - kd = dstkoff+1 - if (fk.eq.0) goto 80 - if (fk.eq.1) goto 81 - stop - -c begin j loop - 80 continue - j = 0 - js = j0+1 - jd = dstjoff+1 - if (fj.eq.0) goto 800 - if (fj.eq.1) goto 801 - stop - -c begin i loop - 800 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8000 - if (fi.eq.1) goto 8001 - stop - -c kernel - 8000 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js,ks, 1,1,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + s1fac * src1(is,js,ks) - $ + s2fac * src2(is,js,ks) - $ + s3fac * src3(is,js,ks) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8001 - goto 900 - -c kernel - 8001 continue - if (check_array_accesses.ne.0) then - call checkindex (is-2,js,ks, 6,1,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + f1 * s1fac * src1(is-2,js,ks) - $ + f2 * s1fac * src1(is-1,js,ks) - $ + f3 * s1fac * src1(is ,js,ks) - $ + f4 * s1fac * src1(is+1,js,ks) - $ + f5 * s1fac * src1(is+2,js,ks) - $ + f6 * s1fac * src1(is+3,js,ks) - $ + f1 * s2fac * src2(is-2,js,ks) - $ + f2 * s2fac * src2(is-1,js,ks) - $ + f3 * s2fac * src2(is ,js,ks) - $ + f4 * s2fac * src2(is+1,js,ks) - $ + f5 * s2fac * src2(is+2,js,ks) - $ + f6 * s2fac * src2(is+3,js,ks) - $ + f1 * s3fac * src3(is-2,js,ks) - $ + f2 * s3fac * src3(is-1,js,ks) - $ + f3 * s3fac * src3(is ,js,ks) - $ + f4 * s3fac * src3(is+1,js,ks) - $ + f5 * s3fac * src3(is+2,js,ks) - $ + f6 * s3fac * src3(is+3,js,ks) - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8000 - goto 900 - -c end i loop - 900 continue - j = j+1 - jd = jd+1 - if (j.lt.regjext) goto 801 - goto 90 - -c begin i loop - 801 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8010 - if (fi.eq.1) goto 8011 - stop - -c kernel - 8010 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js-2,ks, 1,6,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + f1 * s1fac * src1(is,js-2,ks) - $ + f2 * s1fac * src1(is,js-1,ks) - $ + f3 * s1fac * src1(is,js ,ks) - $ + f4 * s1fac * src1(is,js+1,ks) - $ + f5 * s1fac * src1(is,js+2,ks) - $ + f6 * s1fac * src1(is,js+3,ks) - $ + f1 * s2fac * src2(is,js-2,ks) - $ + f2 * s2fac * src2(is,js-1,ks) - $ + f3 * s2fac * src2(is,js ,ks) - $ + f4 * s2fac * src2(is,js+1,ks) - $ + f5 * s2fac * src2(is,js+2,ks) - $ + f6 * s2fac * src2(is,js+3,ks) - $ + f1 * s3fac * src3(is,js-2,ks) - $ + f2 * s3fac * src3(is,js-1,ks) - $ + f3 * s3fac * src3(is,js ,ks) - $ + f4 * s3fac * src3(is,js+1,ks) - $ + f5 * s3fac * src3(is,js+2,ks) - $ + f6 * s3fac * src3(is,js+3,ks) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8011 - goto 901 - -c kernel - 8011 continue - if (check_array_accesses.ne.0) then - call checkindex (is-2,js-2,ks, 6,6,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - res1 = - $ + f1*f1 * src1(is-2,js-2,ks) - $ + f2*f1 * src1(is-1,js-2,ks) - $ + f3*f1 * src1(is ,js-2,ks) - $ + f4*f1 * src1(is+1,js-2,ks) - $ + f5*f1 * src1(is+2,js-2,ks) - $ + f6*f1 * src1(is+3,js-2,ks) - $ + f1*f2 * src1(is-2,js-1,ks) - $ + f2*f2 * src1(is-1,js-1,ks) - $ + f3*f2 * src1(is ,js-1,ks) - $ + f4*f2 * src1(is+1,js-1,ks) - $ + f5*f2 * src1(is+2,js-1,ks) - $ + f6*f2 * src1(is+3,js-1,ks) - $ + f1*f3 * src1(is-2,js ,ks) - $ + f2*f3 * src1(is-1,js ,ks) - $ + f3*f3 * src1(is ,js ,ks) - $ + f4*f3 * src1(is+1,js ,ks) - $ + f5*f3 * src1(is+2,js ,ks) - $ + f6*f3 * src1(is+3,js ,ks) - $ + f1*f4 * src1(is-2,js+1,ks) - $ + f2*f4 * src1(is-1,js+1,ks) - $ + f3*f4 * src1(is ,js+1,ks) - $ + f4*f4 * src1(is+1,js+1,ks) - $ + f5*f4 * src1(is+2,js+1,ks) - $ + f6*f4 * src1(is+3,js+1,ks) - $ + f1*f5 * src1(is-2,js+2,ks) - $ + f2*f5 * src1(is-1,js+2,ks) - $ + f3*f5 * src1(is ,js+2,ks) - $ + f4*f5 * src1(is+1,js+2,ks) - $ + f5*f5 * src1(is+2,js+2,ks) - $ + f6*f5 * src1(is+3,js+2,ks) - $ + f1*f6 * src1(is-2,js+3,ks) - $ + f2*f6 * src1(is-1,js+3,ks) - $ + f3*f6 * src1(is ,js+3,ks) - $ + f4*f6 * src1(is+1,js+3,ks) - $ + f5*f6 * src1(is+2,js+3,ks) - $ + f6*f6 * src1(is+3,js+3,ks) - res2 = - $ + f1*f1 * src2(is-2,js-2,ks) - $ + f2*f1 * src2(is-1,js-2,ks) - $ + f3*f1 * src2(is ,js-2,ks) - $ + f4*f1 * src2(is+1,js-2,ks) - $ + f5*f1 * src2(is+2,js-2,ks) - $ + f6*f1 * src2(is+3,js-2,ks) - $ + f1*f2 * src2(is-2,js-1,ks) - $ + f2*f2 * src2(is-1,js-1,ks) - $ + f3*f2 * src2(is ,js-1,ks) - $ + f4*f2 * src2(is+1,js-1,ks) - $ + f5*f2 * src2(is+2,js-1,ks) - $ + f6*f2 * src2(is+3,js-1,ks) - $ + f1*f3 * src2(is-2,js ,ks) - $ + f2*f3 * src2(is-1,js ,ks) - $ + f3*f3 * src2(is ,js ,ks) - $ + f4*f3 * src2(is+1,js ,ks) - $ + f5*f3 * src2(is+2,js ,ks) - $ + f6*f3 * src2(is+3,js ,ks) - $ + f1*f4 * src2(is-2,js+1,ks) - $ + f2*f4 * src2(is-1,js+1,ks) - $ + f3*f4 * src2(is ,js+1,ks) - $ + f4*f4 * src2(is+1,js+1,ks) - $ + f5*f4 * src2(is+2,js+1,ks) - $ + f6*f4 * src2(is+3,js+1,ks) - $ + f1*f5 * src2(is-2,js+2,ks) - $ + f2*f5 * src2(is-1,js+2,ks) - $ + f3*f5 * src2(is ,js+2,ks) - $ + f4*f5 * src2(is+1,js+2,ks) - $ + f5*f5 * src2(is+2,js+2,ks) - $ + f6*f5 * src2(is+3,js+2,ks) - $ + f1*f6 * src2(is-2,js+3,ks) - $ + f2*f6 * src2(is-1,js+3,ks) - $ + f3*f6 * src2(is ,js+3,ks) - $ + f4*f6 * src2(is+1,js+3,ks) - $ + f5*f6 * src2(is+2,js+3,ks) - $ + f6*f6 * src2(is+3,js+3,ks) - res3 = - $ + f1*f1 * src3(is-2,js-2,ks) - $ + f2*f1 * src3(is-1,js-2,ks) - $ + f3*f1 * src3(is ,js-2,ks) - $ + f4*f1 * src3(is+1,js-2,ks) - $ + f5*f1 * src3(is+2,js-2,ks) - $ + f6*f1 * src3(is+3,js-2,ks) - $ + f1*f2 * src3(is-2,js-1,ks) - $ + f2*f2 * src3(is-1,js-1,ks) - $ + f3*f2 * src3(is ,js-1,ks) - $ + f4*f2 * src3(is+1,js-1,ks) - $ + f5*f2 * src3(is+2,js-1,ks) - $ + f6*f2 * src3(is+3,js-1,ks) - $ + f1*f3 * src3(is-2,js ,ks) - $ + f2*f3 * src3(is-1,js ,ks) - $ + f3*f3 * src3(is ,js ,ks) - $ + f4*f3 * src3(is+1,js ,ks) - $ + f5*f3 * src3(is+2,js ,ks) - $ + f6*f3 * src3(is+3,js ,ks) - $ + f1*f4 * src3(is-2,js+1,ks) - $ + f2*f4 * src3(is-1,js+1,ks) - $ + f3*f4 * src3(is ,js+1,ks) - $ + f4*f4 * src3(is+1,js+1,ks) - $ + f5*f4 * src3(is+2,js+1,ks) - $ + f6*f4 * src3(is+3,js+1,ks) - $ + f1*f5 * src3(is-2,js+2,ks) - $ + f2*f5 * src3(is-1,js+2,ks) - $ + f3*f5 * src3(is ,js+2,ks) - $ + f4*f5 * src3(is+1,js+2,ks) - $ + f5*f5 * src3(is+2,js+2,ks) - $ + f6*f5 * src3(is+3,js+2,ks) - $ + f1*f6 * src3(is-2,js+3,ks) - $ + f2*f6 * src3(is-1,js+3,ks) - $ + f3*f6 * src3(is ,js+3,ks) - $ + f4*f6 * src3(is+1,js+3,ks) - $ + f5*f6 * src3(is+2,js+3,ks) - $ + f6*f6 * src3(is+3,js+3,ks) - dst(id,jd,kd) = s1fac * res1 + s2fac * res2 + s3fac * res3 - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8010 - goto 901 - -c end i loop - 901 continue - j = j+1 - jd = jd+1 - js = js+1 - if (j.lt.regjext) goto 800 - goto 90 - -c end j loop - 90 continue - k = k+1 - kd = kd+1 - if (k.lt.regkext) goto 81 - goto 9 - -c begin j loop - 81 continue - j = 0 - js = j0+1 - jd = dstjoff+1 - if (fj.eq.0) goto 810 - if (fj.eq.1) goto 811 - stop - -c begin i loop - 810 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8100 - if (fi.eq.1) goto 8101 - stop - -c kernel - 8100 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js,ks-2, 1,1,6, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + f1 * s1fac * src1(is,js,ks-2) - $ + f2 * s1fac * src1(is,js,ks-1) - $ + f3 * s1fac * src1(is,js,ks ) - $ + f4 * s1fac * src1(is,js,ks+1) - $ + f5 * s1fac * src1(is,js,ks+2) - $ + f6 * s1fac * src1(is,js,ks+3) - $ + f1 * s2fac * src2(is,js,ks-2) - $ + f2 * s2fac * src2(is,js,ks-1) - $ + f3 * s2fac * src2(is,js,ks ) - $ + f4 * s2fac * src2(is,js,ks+1) - $ + f5 * s2fac * src2(is,js,ks+2) - $ + f6 * s2fac * src2(is,js,ks+3) - $ + f1 * s3fac * src3(is,js,ks-2) - $ + f2 * s3fac * src3(is,js,ks-1) - $ + f3 * s3fac * src3(is,js,ks ) - $ + f4 * s3fac * src3(is,js,ks+1) - $ + f5 * s3fac * src3(is,js,ks+2) - $ + f6 * s3fac * src3(is,js,ks+3) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8101 - goto 910 - -c kernel - 8101 continue - if (check_array_accesses.ne.0) then - call checkindex (is-2,js,ks-2, 6,1,6, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - res1 = - $ + f1*f1 * src1(is-2,js,ks-2) - $ + f2*f1 * src1(is-1,js,ks-2) - $ + f3*f1 * src1(is ,js,ks-2) - $ + f4*f1 * src1(is+1,js,ks-2) - $ + f5*f1 * src1(is+2,js,ks-2) - $ + f6*f1 * src1(is+3,js,ks-2) - $ + f1*f2 * src1(is-2,js,ks-1) - $ + f2*f2 * src1(is-1,js,ks-1) - $ + f3*f2 * src1(is ,js,ks-1) - $ + f4*f2 * src1(is+1,js,ks-1) - $ + f5*f2 * src1(is+2,js,ks-1) - $ + f6*f2 * src1(is+3,js,ks-1) - $ + f1*f3 * src1(is-2,js,ks ) - $ + f2*f3 * src1(is-1,js,ks ) - $ + f3*f3 * src1(is ,js,ks ) - $ + f4*f3 * src1(is+1,js,ks ) - $ + f5*f3 * src1(is+2,js,ks ) - $ + f6*f3 * src1(is+3,js,ks ) - $ + f1*f4 * src1(is-2,js,ks+1) - $ + f2*f4 * src1(is-1,js,ks+1) - $ + f3*f4 * src1(is ,js,ks+1) - $ + f4*f4 * src1(is+1,js,ks+1) - $ + f5*f4 * src1(is+2,js,ks+1) - $ + f6*f4 * src1(is+3,js,ks+1) - $ + f1*f5 * src1(is-2,js,ks+2) - $ + f2*f5 * src1(is-1,js,ks+2) - $ + f3*f5 * src1(is ,js,ks+2) - $ + f4*f5 * src1(is+1,js,ks+2) - $ + f5*f5 * src1(is+2,js,ks+2) - $ + f6*f5 * src1(is+3,js,ks+2) - $ + f1*f6 * src1(is-2,js,ks+3) - $ + f2*f6 * src1(is-1,js,ks+3) - $ + f3*f6 * src1(is ,js,ks+3) - $ + f4*f6 * src1(is+1,js,ks+3) - $ + f5*f6 * src1(is+2,js,ks+3) - $ + f6*f6 * src1(is+3,js,ks+3) - res2 = - $ + f1*f1 * src2(is-2,js,ks-2) - $ + f2*f1 * src2(is-1,js,ks-2) - $ + f3*f1 * src2(is ,js,ks-2) - $ + f4*f1 * src2(is+1,js,ks-2) - $ + f5*f1 * src2(is+2,js,ks-2) - $ + f6*f1 * src2(is+3,js,ks-2) - $ + f1*f2 * src2(is-2,js,ks-1) - $ + f2*f2 * src2(is-1,js,ks-1) - $ + f3*f2 * src2(is ,js,ks-1) - $ + f4*f2 * src2(is+1,js,ks-1) - $ + f5*f2 * src2(is+2,js,ks-1) - $ + f6*f2 * src2(is+3,js,ks-1) - $ + f1*f3 * src2(is-2,js,ks ) - $ + f2*f3 * src2(is-1,js,ks ) - $ + f3*f3 * src2(is ,js,ks ) - $ + f4*f3 * src2(is+1,js,ks ) - $ + f5*f3 * src2(is+2,js,ks ) - $ + f6*f3 * src2(is+3,js,ks ) - $ + f1*f4 * src2(is-2,js,ks+1) - $ + f2*f4 * src2(is-1,js,ks+1) - $ + f3*f4 * src2(is ,js,ks+1) - $ + f4*f4 * src2(is+1,js,ks+1) - $ + f5*f4 * src2(is+2,js,ks+1) - $ + f6*f4 * src2(is+3,js,ks+1) - $ + f1*f5 * src2(is-2,js,ks+2) - $ + f2*f5 * src2(is-1,js,ks+2) - $ + f3*f5 * src2(is ,js,ks+2) - $ + f4*f5 * src2(is+1,js,ks+2) - $ + f5*f5 * src2(is+2,js,ks+2) - $ + f6*f5 * src2(is+3,js,ks+2) - $ + f1*f6 * src2(is-2,js,ks+3) - $ + f2*f6 * src2(is-1,js,ks+3) - $ + f3*f6 * src2(is ,js,ks+3) - $ + f4*f6 * src2(is+1,js,ks+3) - $ + f5*f6 * src2(is+2,js,ks+3) - $ + f6*f6 * src2(is+3,js,ks+3) - res3 = - $ + f1*f1 * src3(is-2,js,ks-2) - $ + f2*f1 * src3(is-1,js,ks-2) - $ + f3*f1 * src3(is ,js,ks-2) - $ + f4*f1 * src3(is+1,js,ks-2) - $ + f5*f1 * src3(is+2,js,ks-2) - $ + f6*f1 * src3(is+3,js,ks-2) - $ + f1*f2 * src3(is-2,js,ks-1) - $ + f2*f2 * src3(is-1,js,ks-1) - $ + f3*f2 * src3(is ,js,ks-1) - $ + f4*f2 * src3(is+1,js,ks-1) - $ + f5*f2 * src3(is+2,js,ks-1) - $ + f6*f2 * src3(is+3,js,ks-1) - $ + f1*f3 * src3(is-2,js,ks ) - $ + f2*f3 * src3(is-1,js,ks ) - $ + f3*f3 * src3(is ,js,ks ) - $ + f4*f3 * src3(is+1,js,ks ) - $ + f5*f3 * src3(is+2,js,ks ) - $ + f6*f3 * src3(is+3,js,ks ) - $ + f1*f4 * src3(is-2,js,ks+1) - $ + f2*f4 * src3(is-1,js,ks+1) - $ + f3*f4 * src3(is ,js,ks+1) - $ + f4*f4 * src3(is+1,js,ks+1) - $ + f5*f4 * src3(is+2,js,ks+1) - $ + f6*f4 * src3(is+3,js,ks+1) - $ + f1*f5 * src3(is-2,js,ks+2) - $ + f2*f5 * src3(is-1,js,ks+2) - $ + f3*f5 * src3(is ,js,ks+2) - $ + f4*f5 * src3(is+1,js,ks+2) - $ + f5*f5 * src3(is+2,js,ks+2) - $ + f6*f5 * src3(is+3,js,ks+2) - $ + f1*f6 * src3(is-2,js,ks+3) - $ + f2*f6 * src3(is-1,js,ks+3) - $ + f3*f6 * src3(is ,js,ks+3) - $ + f4*f6 * src3(is+1,js,ks+3) - $ + f5*f6 * src3(is+2,js,ks+3) - $ + f6*f6 * src3(is+3,js,ks+3) - dst(id,jd,kd) = s1fac * res1 + s2fac * res2 + s3fac * res3 - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8100 - goto 910 - -c end i loop - 910 continue - j = j+1 - jd = jd+1 - if (j.lt.regjext) goto 811 - goto 91 - -c begin i loop - 811 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8110 - if (fi.eq.1) goto 8111 - stop - -c kernel - 8110 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js-2,ks-2, 1,6,6, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - res1 = - $ + f1*f1 * src1(is,js-2,ks-2) - $ + f2*f1 * src1(is,js-1,ks-2) - $ + f3*f1 * src1(is,js ,ks-2) - $ + f4*f1 * src1(is,js+1,ks-2) - $ + f5*f1 * src1(is,js+2,ks-2) - $ + f6*f1 * src1(is,js+3,ks-2) - $ + f1*f2 * src1(is,js-2,ks-1) - $ + f2*f2 * src1(is,js-1,ks-1) - $ + f3*f2 * src1(is,js ,ks-1) - $ + f4*f2 * src1(is,js+1,ks-1) - $ + f5*f2 * src1(is,js+2,ks-1) - $ + f6*f2 * src1(is,js+3,ks-1) - $ + f1*f3 * src1(is,js-2,ks ) - $ + f2*f3 * src1(is,js-1,ks ) - $ + f3*f3 * src1(is,js ,ks ) - $ + f4*f3 * src1(is,js+1,ks ) - $ + f5*f3 * src1(is,js+2,ks ) - $ + f6*f3 * src1(is,js+3,ks ) - $ + f1*f4 * src1(is,js-2,ks+1) - $ + f2*f4 * src1(is,js-1,ks+1) - $ + f3*f4 * src1(is,js ,ks+1) - $ + f4*f4 * src1(is,js+1,ks+1) - $ + f5*f4 * src1(is,js+2,ks+1) - $ + f6*f4 * src1(is,js+3,ks+1) - $ + f1*f5 * src1(is,js-2,ks+2) - $ + f2*f5 * src1(is,js-1,ks+2) - $ + f3*f5 * src1(is,js ,ks+2) - $ + f4*f5 * src1(is,js+1,ks+2) - $ + f5*f5 * src1(is,js+2,ks+2) - $ + f6*f5 * src1(is,js+3,ks+2) - $ + f1*f6 * src1(is,js-2,ks+3) - $ + f2*f6 * src1(is,js-1,ks+3) - $ + f3*f6 * src1(is,js ,ks+3) - $ + f4*f6 * src1(is,js+1,ks+3) - $ + f5*f6 * src1(is,js+2,ks+3) - $ + f6*f6 * src1(is,js+3,ks+3) - res2 = - $ + f1*f1 * src2(is,js-2,ks-2) - $ + f2*f1 * src2(is,js-1,ks-2) - $ + f3*f1 * src2(is,js ,ks-2) - $ + f4*f1 * src2(is,js+1,ks-2) - $ + f5*f1 * src2(is,js+2,ks-2) - $ + f6*f1 * src2(is,js+3,ks-2) - $ + f1*f2 * src2(is,js-2,ks-1) - $ + f2*f2 * src2(is,js-1,ks-1) - $ + f3*f2 * src2(is,js ,ks-1) - $ + f4*f2 * src2(is,js+1,ks-1) - $ + f5*f2 * src2(is,js+2,ks-1) - $ + f6*f2 * src2(is,js+3,ks-1) - $ + f1*f3 * src2(is,js-2,ks ) - $ + f2*f3 * src2(is,js-1,ks ) - $ + f3*f3 * src2(is,js ,ks ) - $ + f4*f3 * src2(is,js+1,ks ) - $ + f5*f3 * src2(is,js+2,ks ) - $ + f6*f3 * src2(is,js+3,ks ) - $ + f1*f4 * src2(is,js-2,ks+1) - $ + f2*f4 * src2(is,js-1,ks+1) - $ + f3*f4 * src2(is,js ,ks+1) - $ + f4*f4 * src2(is,js+1,ks+1) - $ + f5*f4 * src2(is,js+2,ks+1) - $ + f6*f4 * src2(is,js+3,ks+1) - $ + f1*f5 * src2(is,js-2,ks+2) - $ + f2*f5 * src2(is,js-1,ks+2) - $ + f3*f5 * src2(is,js ,ks+2) - $ + f4*f5 * src2(is,js+1,ks+2) - $ + f5*f5 * src2(is,js+2,ks+2) - $ + f6*f5 * src2(is,js+3,ks+2) - $ + f1*f6 * src2(is,js-2,ks+3) - $ + f2*f6 * src2(is,js-1,ks+3) - $ + f3*f6 * src2(is,js ,ks+3) - $ + f4*f6 * src2(is,js+1,ks+3) - $ + f5*f6 * src2(is,js+2,ks+3) - $ + f6*f6 * src2(is,js+3,ks+3) - res3 = - $ + f1*f1 * src3(is,js-2,ks-2) - $ + f2*f1 * src3(is,js-1,ks-2) - $ + f3*f1 * src3(is,js ,ks-2) - $ + f4*f1 * src3(is,js+1,ks-2) - $ + f5*f1 * src3(is,js+2,ks-2) - $ + f6*f1 * src3(is,js+3,ks-2) - $ + f1*f2 * src3(is,js-2,ks-1) - $ + f2*f2 * src3(is,js-1,ks-1) - $ + f3*f2 * src3(is,js ,ks-1) - $ + f4*f2 * src3(is,js+1,ks-1) - $ + f5*f2 * src3(is,js+2,ks-1) - $ + f6*f2 * src3(is,js+3,ks-1) - $ + f1*f3 * src3(is,js-2,ks ) - $ + f2*f3 * src3(is,js-1,ks ) - $ + f3*f3 * src3(is,js ,ks ) - $ + f4*f3 * src3(is,js+1,ks ) - $ + f5*f3 * src3(is,js+2,ks ) - $ + f6*f3 * src3(is,js+3,ks ) - $ + f1*f4 * src3(is,js-2,ks+1) - $ + f2*f4 * src3(is,js-1,ks+1) - $ + f3*f4 * src3(is,js ,ks+1) - $ + f4*f4 * src3(is,js+1,ks+1) - $ + f5*f4 * src3(is,js+2,ks+1) - $ + f6*f4 * src3(is,js+3,ks+1) - $ + f1*f5 * src3(is,js-2,ks+2) - $ + f2*f5 * src3(is,js-1,ks+2) - $ + f3*f5 * src3(is,js ,ks+2) - $ + f4*f5 * src3(is,js+1,ks+2) - $ + f5*f5 * src3(is,js+2,ks+2) - $ + f6*f5 * src3(is,js+3,ks+2) - $ + f1*f6 * src3(is,js-2,ks+3) - $ + f2*f6 * src3(is,js-1,ks+3) - $ + f3*f6 * src3(is,js ,ks+3) - $ + f4*f6 * src3(is,js+1,ks+3) - $ + f5*f6 * src3(is,js+2,ks+3) - $ + f6*f6 * src3(is,js+3,ks+3) - dst(id,jd,kd) = s1fac * res1 + s2fac * res2 + s3fac * res3 - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8111 - goto 911 - -c kernel - 8111 continue - if (check_array_accesses.ne.0) then - call checkindex (is-2,js-2,ks-2, 6,6,6, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - res11 = - $ + f1*f1*f1 * src1(is-2,js-2,ks-2) - $ + f2*f1*f1 * src1(is-1,js-2,ks-2) - $ + f3*f1*f1 * src1(is ,js-2,ks-2) - $ + f4*f1*f1 * src1(is+1,js-2,ks-2) - $ + f5*f1*f1 * src1(is+2,js-2,ks-2) - $ + f6*f1*f1 * src1(is+3,js-2,ks-2) - $ + f1*f2*f1 * src1(is-2,js-1,ks-2) - $ + f2*f2*f1 * src1(is-1,js-1,ks-2) - $ + f3*f2*f1 * src1(is ,js-1,ks-2) - $ + f4*f2*f1 * src1(is+1,js-1,ks-2) - $ + f5*f2*f1 * src1(is+2,js-1,ks-2) - $ + f6*f2*f1 * src1(is+3,js-1,ks-2) - $ + f1*f3*f1 * src1(is-2,js ,ks-2) - $ + f2*f3*f1 * src1(is-1,js ,ks-2) - $ + f3*f3*f1 * src1(is ,js ,ks-2) - $ + f4*f3*f1 * src1(is+1,js ,ks-2) - $ + f5*f3*f1 * src1(is+2,js ,ks-2) - $ + f6*f3*f1 * src1(is+3,js ,ks-2) - $ + f1*f4*f1 * src1(is-2,js+1,ks-2) - $ + f2*f4*f1 * src1(is-1,js+1,ks-2) - $ + f3*f4*f1 * src1(is ,js+1,ks-2) - $ + f4*f4*f1 * src1(is+1,js+1,ks-2) - $ + f5*f4*f1 * src1(is+2,js+1,ks-2) - $ + f6*f4*f1 * src1(is+3,js+1,ks-2) - $ + f1*f5*f1 * src1(is-2,js+2,ks-2) - $ + f2*f5*f1 * src1(is-1,js+2,ks-2) - $ + f3*f5*f1 * src1(is ,js+2,ks-2) - $ + f4*f5*f1 * src1(is+1,js+2,ks-2) - $ + f5*f5*f1 * src1(is+2,js+2,ks-2) - $ + f6*f5*f1 * src1(is+3,js+2,ks-2) - $ + f1*f6*f1 * src1(is-2,js+3,ks-2) - $ + f2*f6*f1 * src1(is-1,js+3,ks-2) - $ + f3*f6*f1 * src1(is ,js+3,ks-2) - $ + f4*f6*f1 * src1(is+1,js+3,ks-2) - $ + f5*f6*f1 * src1(is+2,js+3,ks-2) - $ + f6*f6*f1 * src1(is+3,js+3,ks-2) - res12 = - $ + f1*f1*f2 * src1(is-2,js-2,ks-1) - $ + f2*f1*f2 * src1(is-1,js-2,ks-1) - $ + f3*f1*f2 * src1(is ,js-2,ks-1) - $ + f4*f1*f2 * src1(is+1,js-2,ks-1) - $ + f5*f1*f2 * src1(is+2,js-2,ks-1) - $ + f6*f1*f2 * src1(is+3,js-2,ks-1) - $ + f1*f2*f2 * src1(is-2,js-1,ks-1) - $ + f2*f2*f2 * src1(is-1,js-1,ks-1) - $ + f3*f2*f2 * src1(is ,js-1,ks-1) - $ + f4*f2*f2 * src1(is+1,js-1,ks-1) - $ + f5*f2*f2 * src1(is+2,js-1,ks-1) - $ + f6*f2*f2 * src1(is+3,js-1,ks-1) - $ + f1*f3*f2 * src1(is-2,js ,ks-1) - $ + f2*f3*f2 * src1(is-1,js ,ks-1) - $ + f3*f3*f2 * src1(is ,js ,ks-1) - $ + f4*f3*f2 * src1(is+1,js ,ks-1) - $ + f5*f3*f2 * src1(is+2,js ,ks-1) - $ + f6*f3*f2 * src1(is+3,js ,ks-1) - $ + f1*f4*f2 * src1(is-2,js+1,ks-1) - $ + f2*f4*f2 * src1(is-1,js+1,ks-1) - $ + f3*f4*f2 * src1(is ,js+1,ks-1) - $ + f4*f4*f2 * src1(is+1,js+1,ks-1) - $ + f5*f4*f2 * src1(is+2,js+1,ks-1) - $ + f6*f4*f2 * src1(is+3,js+1,ks-1) - $ + f1*f5*f2 * src1(is-2,js+2,ks-1) - $ + f2*f5*f2 * src1(is-1,js+2,ks-1) - $ + f3*f5*f2 * src1(is ,js+2,ks-1) - $ + f4*f5*f2 * src1(is+1,js+2,ks-1) - $ + f5*f5*f2 * src1(is+2,js+2,ks-1) - $ + f6*f5*f2 * src1(is+3,js+2,ks-1) - $ + f1*f6*f2 * src1(is-2,js+3,ks-1) - $ + f2*f6*f2 * src1(is-1,js+3,ks-1) - $ + f3*f6*f2 * src1(is ,js+3,ks-1) - $ + f4*f6*f2 * src1(is+1,js+3,ks-1) - $ + f5*f6*f2 * src1(is+2,js+3,ks-1) - $ + f6*f6*f2 * src1(is+3,js+3,ks-1) - res13 = - $ + f1*f1*f3 * src1(is-2,js-2,ks ) - $ + f2*f1*f3 * src1(is-1,js-2,ks ) - $ + f3*f1*f3 * src1(is ,js-2,ks ) - $ + f4*f1*f3 * src1(is+1,js-2,ks ) - $ + f5*f1*f3 * src1(is+2,js-2,ks ) - $ + f6*f1*f3 * src1(is+3,js-2,ks ) - $ + f1*f2*f3 * src1(is-2,js-1,ks ) - $ + f2*f2*f3 * src1(is-1,js-1,ks ) - $ + f3*f2*f3 * src1(is ,js-1,ks ) - $ + f4*f2*f3 * src1(is+1,js-1,ks ) - $ + f5*f2*f3 * src1(is+2,js-1,ks ) - $ + f6*f2*f3 * src1(is+3,js-1,ks ) - $ + f1*f3*f3 * src1(is-2,js ,ks ) - $ + f2*f3*f3 * src1(is-1,js ,ks ) - $ + f3*f3*f3 * src1(is ,js ,ks ) - $ + f4*f3*f3 * src1(is+1,js ,ks ) - $ + f5*f3*f3 * src1(is+2,js ,ks ) - $ + f6*f3*f3 * src1(is+3,js ,ks ) - $ + f1*f4*f3 * src1(is-2,js+1,ks ) - $ + f2*f4*f3 * src1(is-1,js+1,ks ) - $ + f3*f4*f3 * src1(is ,js+1,ks ) - $ + f4*f4*f3 * src1(is+1,js+1,ks ) - $ + f5*f4*f3 * src1(is+2,js+1,ks ) - $ + f6*f4*f3 * src1(is+3,js+1,ks ) - $ + f1*f5*f3 * src1(is-2,js+2,ks ) - $ + f2*f5*f3 * src1(is-1,js+2,ks ) - $ + f3*f5*f3 * src1(is ,js+2,ks ) - $ + f4*f5*f3 * src1(is+1,js+2,ks ) - $ + f5*f5*f3 * src1(is+2,js+2,ks ) - $ + f6*f5*f3 * src1(is+3,js+2,ks ) - $ + f1*f6*f3 * src1(is-2,js+3,ks ) - $ + f2*f6*f3 * src1(is-1,js+3,ks ) - $ + f3*f6*f3 * src1(is ,js+3,ks ) - $ + f4*f6*f3 * src1(is+1,js+3,ks ) - $ + f5*f6*f3 * src1(is+2,js+3,ks ) - $ + f6*f6*f3 * src1(is+3,js+3,ks ) - res14 = - $ + f1*f1*f4 * src1(is-2,js-2,ks+1) - $ + f2*f1*f4 * src1(is-1,js-2,ks+1) - $ + f3*f1*f4 * src1(is ,js-2,ks+1) - $ + f4*f1*f4 * src1(is+1,js-2,ks+1) - $ + f5*f1*f4 * src1(is+2,js-2,ks+1) - $ + f6*f1*f4 * src1(is+3,js-2,ks+1) - $ + f1*f2*f4 * src1(is-2,js-1,ks+1) - $ + f2*f2*f4 * src1(is-1,js-1,ks+1) - $ + f3*f2*f4 * src1(is ,js-1,ks+1) - $ + f4*f2*f4 * src1(is+1,js-1,ks+1) - $ + f5*f2*f4 * src1(is+2,js-1,ks+1) - $ + f6*f2*f4 * src1(is+3,js-1,ks+1) - $ + f1*f3*f4 * src1(is-2,js ,ks+1) - $ + f2*f3*f4 * src1(is-1,js ,ks+1) - $ + f3*f3*f4 * src1(is ,js ,ks+1) - $ + f4*f3*f4 * src1(is+1,js ,ks+1) - $ + f5*f3*f4 * src1(is+2,js ,ks+1) - $ + f6*f3*f4 * src1(is+3,js ,ks+1) - $ + f1*f4*f4 * src1(is-2,js+1,ks+1) - $ + f2*f4*f4 * src1(is-1,js+1,ks+1) - $ + f3*f4*f4 * src1(is ,js+1,ks+1) - $ + f4*f4*f4 * src1(is+1,js+1,ks+1) - $ + f5*f4*f4 * src1(is+2,js+1,ks+1) - $ + f6*f4*f4 * src1(is+3,js+1,ks+1) - $ + f1*f5*f4 * src1(is-2,js+2,ks+1) - $ + f2*f5*f4 * src1(is-1,js+2,ks+1) - $ + f3*f5*f4 * src1(is ,js+2,ks+1) - $ + f4*f5*f4 * src1(is+1,js+2,ks+1) - $ + f5*f5*f4 * src1(is+2,js+2,ks+1) - $ + f6*f5*f4 * src1(is+3,js+2,ks+1) - $ + f1*f6*f4 * src1(is-2,js+3,ks+1) - $ + f2*f6*f4 * src1(is-1,js+3,ks+1) - $ + f3*f6*f4 * src1(is ,js+3,ks+1) - $ + f4*f6*f4 * src1(is+1,js+3,ks+1) - $ + f5*f6*f4 * src1(is+2,js+3,ks+1) - $ + f6*f6*f4 * src1(is+3,js+3,ks+1) - res15 = - $ + f1*f1*f5 * src1(is-2,js-2,ks+2) - $ + f2*f1*f5 * src1(is-1,js-2,ks+2) - $ + f3*f1*f5 * src1(is ,js-2,ks+2) - $ + f4*f1*f5 * src1(is+1,js-2,ks+2) - $ + f5*f1*f5 * src1(is+2,js-2,ks+2) - $ + f6*f1*f5 * src1(is+3,js-2,ks+2) - $ + f1*f2*f5 * src1(is-2,js-1,ks+2) - $ + f2*f2*f5 * src1(is-1,js-1,ks+2) - $ + f3*f2*f5 * src1(is ,js-1,ks+2) - $ + f4*f2*f5 * src1(is+1,js-1,ks+2) - $ + f5*f2*f5 * src1(is+2,js-1,ks+2) - $ + f6*f2*f5 * src1(is+3,js-1,ks+2) - $ + f1*f3*f5 * src1(is-2,js ,ks+2) - $ + f2*f3*f5 * src1(is-1,js ,ks+2) - $ + f3*f3*f5 * src1(is ,js ,ks+2) - $ + f4*f3*f5 * src1(is+1,js ,ks+2) - $ + f5*f3*f5 * src1(is+2,js ,ks+2) - $ + f6*f3*f5 * src1(is+3,js ,ks+2) - $ + f1*f4*f5 * src1(is-2,js+1,ks+2) - $ + f2*f4*f5 * src1(is-1,js+1,ks+2) - $ + f3*f4*f5 * src1(is ,js+1,ks+2) - $ + f4*f4*f5 * src1(is+1,js+1,ks+2) - $ + f5*f4*f5 * src1(is+2,js+1,ks+2) - $ + f6*f4*f5 * src1(is+3,js+1,ks+2) - $ + f1*f5*f5 * src1(is-2,js+2,ks+2) - $ + f2*f5*f5 * src1(is-1,js+2,ks+2) - $ + f3*f5*f5 * src1(is ,js+2,ks+2) - $ + f4*f5*f5 * src1(is+1,js+2,ks+2) - $ + f5*f5*f5 * src1(is+2,js+2,ks+2) - $ + f6*f5*f5 * src1(is+3,js+2,ks+2) - $ + f1*f6*f5 * src1(is-2,js+3,ks+2) - $ + f2*f6*f5 * src1(is-1,js+3,ks+2) - $ + f3*f6*f5 * src1(is ,js+3,ks+2) - $ + f4*f6*f5 * src1(is+1,js+3,ks+2) - $ + f5*f6*f5 * src1(is+2,js+3,ks+2) - $ + f6*f6*f5 * src1(is+3,js+3,ks+2) - res16 = - $ + f1*f1*f6 * src1(is-2,js-2,ks+3) - $ + f2*f1*f6 * src1(is-1,js-2,ks+3) - $ + f3*f1*f6 * src1(is ,js-2,ks+3) - $ + f4*f1*f6 * src1(is+1,js-2,ks+3) - $ + f5*f1*f6 * src1(is+2,js-2,ks+3) - $ + f6*f1*f6 * src1(is+3,js-2,ks+3) - $ + f1*f2*f6 * src1(is-2,js-1,ks+3) - $ + f2*f2*f6 * src1(is-1,js-1,ks+3) - $ + f3*f2*f6 * src1(is ,js-1,ks+3) - $ + f4*f2*f6 * src1(is+1,js-1,ks+3) - $ + f5*f2*f6 * src1(is+2,js-1,ks+3) - $ + f6*f2*f6 * src1(is+3,js-1,ks+3) - $ + f1*f3*f6 * src1(is-2,js ,ks+3) - $ + f2*f3*f6 * src1(is-1,js ,ks+3) - $ + f3*f3*f6 * src1(is ,js ,ks+3) - $ + f4*f3*f6 * src1(is+1,js ,ks+3) - $ + f5*f3*f6 * src1(is+2,js ,ks+3) - $ + f6*f3*f6 * src1(is+3,js ,ks+3) - $ + f1*f4*f6 * src1(is-2,js+1,ks+3) - $ + f2*f4*f6 * src1(is-1,js+1,ks+3) - $ + f3*f4*f6 * src1(is ,js+1,ks+3) - $ + f4*f4*f6 * src1(is+1,js+1,ks+3) - $ + f5*f4*f6 * src1(is+2,js+1,ks+3) - $ + f6*f4*f6 * src1(is+3,js+1,ks+3) - $ + f1*f5*f6 * src1(is-2,js+2,ks+3) - $ + f2*f5*f6 * src1(is-1,js+2,ks+3) - $ + f3*f5*f6 * src1(is ,js+2,ks+3) - $ + f4*f5*f6 * src1(is+1,js+2,ks+3) - $ + f5*f5*f6 * src1(is+2,js+2,ks+3) - $ + f6*f5*f6 * src1(is+3,js+2,ks+3) - $ + f1*f6*f6 * src1(is-2,js+3,ks+3) - $ + f2*f6*f6 * src1(is-1,js+3,ks+3) - $ + f3*f6*f6 * src1(is ,js+3,ks+3) - $ + f4*f6*f6 * src1(is+1,js+3,ks+3) - $ + f5*f6*f6 * src1(is+2,js+3,ks+3) - $ + f6*f6*f6 * src1(is+3,js+3,ks+3) - res21 = - $ + f1*f1*f1 * src2(is-2,js-2,ks-2) - $ + f2*f1*f1 * src2(is-1,js-2,ks-2) - $ + f3*f1*f1 * src2(is ,js-2,ks-2) - $ + f4*f1*f1 * src2(is+1,js-2,ks-2) - $ + f5*f1*f1 * src2(is+2,js-2,ks-2) - $ + f6*f1*f1 * src2(is+3,js-2,ks-2) - $ + f1*f2*f1 * src2(is-2,js-1,ks-2) - $ + f2*f2*f1 * src2(is-1,js-1,ks-2) - $ + f3*f2*f1 * src2(is ,js-1,ks-2) - $ + f4*f2*f1 * src2(is+1,js-1,ks-2) - $ + f5*f2*f1 * src2(is+2,js-1,ks-2) - $ + f6*f2*f1 * src2(is+3,js-1,ks-2) - $ + f1*f3*f1 * src2(is-2,js ,ks-2) - $ + f2*f3*f1 * src2(is-1,js ,ks-2) - $ + f3*f3*f1 * src2(is ,js ,ks-2) - $ + f4*f3*f1 * src2(is+1,js ,ks-2) - $ + f5*f3*f1 * src2(is+2,js ,ks-2) - $ + f6*f3*f1 * src2(is+3,js ,ks-2) - $ + f1*f4*f1 * src2(is-2,js+1,ks-2) - $ + f2*f4*f1 * src2(is-1,js+1,ks-2) - $ + f3*f4*f1 * src2(is ,js+1,ks-2) - $ + f4*f4*f1 * src2(is+1,js+1,ks-2) - $ + f5*f4*f1 * src2(is+2,js+1,ks-2) - $ + f6*f4*f1 * src2(is+3,js+1,ks-2) - $ + f1*f5*f1 * src2(is-2,js+2,ks-2) - $ + f2*f5*f1 * src2(is-1,js+2,ks-2) - $ + f3*f5*f1 * src2(is ,js+2,ks-2) - $ + f4*f5*f1 * src2(is+1,js+2,ks-2) - $ + f5*f5*f1 * src2(is+2,js+2,ks-2) - $ + f6*f5*f1 * src2(is+3,js+2,ks-2) - $ + f1*f6*f1 * src2(is-2,js+3,ks-2) - $ + f2*f6*f1 * src2(is-1,js+3,ks-2) - $ + f3*f6*f1 * src2(is ,js+3,ks-2) - $ + f4*f6*f1 * src2(is+1,js+3,ks-2) - $ + f5*f6*f1 * src2(is+2,js+3,ks-2) - $ + f6*f6*f1 * src2(is+3,js+3,ks-2) - res22 = - $ + f1*f1*f2 * src2(is-2,js-2,ks-1) - $ + f2*f1*f2 * src2(is-1,js-2,ks-1) - $ + f3*f1*f2 * src2(is ,js-2,ks-1) - $ + f4*f1*f2 * src2(is+1,js-2,ks-1) - $ + f5*f1*f2 * src2(is+2,js-2,ks-1) - $ + f6*f1*f2 * src2(is+3,js-2,ks-1) - $ + f1*f2*f2 * src2(is-2,js-1,ks-1) - $ + f2*f2*f2 * src2(is-1,js-1,ks-1) - $ + f3*f2*f2 * src2(is ,js-1,ks-1) - $ + f4*f2*f2 * src2(is+1,js-1,ks-1) - $ + f5*f2*f2 * src2(is+2,js-1,ks-1) - $ + f6*f2*f2 * src2(is+3,js-1,ks-1) - $ + f1*f3*f2 * src2(is-2,js ,ks-1) - $ + f2*f3*f2 * src2(is-1,js ,ks-1) - $ + f3*f3*f2 * src2(is ,js ,ks-1) - $ + f4*f3*f2 * src2(is+1,js ,ks-1) - $ + f5*f3*f2 * src2(is+2,js ,ks-1) - $ + f6*f3*f2 * src2(is+3,js ,ks-1) - $ + f1*f4*f2 * src2(is-2,js+1,ks-1) - $ + f2*f4*f2 * src2(is-1,js+1,ks-1) - $ + f3*f4*f2 * src2(is ,js+1,ks-1) - $ + f4*f4*f2 * src2(is+1,js+1,ks-1) - $ + f5*f4*f2 * src2(is+2,js+1,ks-1) - $ + f6*f4*f2 * src2(is+3,js+1,ks-1) - $ + f1*f5*f2 * src2(is-2,js+2,ks-1) - $ + f2*f5*f2 * src2(is-1,js+2,ks-1) - $ + f3*f5*f2 * src2(is ,js+2,ks-1) - $ + f4*f5*f2 * src2(is+1,js+2,ks-1) - $ + f5*f5*f2 * src2(is+2,js+2,ks-1) - $ + f6*f5*f2 * src2(is+3,js+2,ks-1) - $ + f1*f6*f2 * src2(is-2,js+3,ks-1) - $ + f2*f6*f2 * src2(is-1,js+3,ks-1) - $ + f3*f6*f2 * src2(is ,js+3,ks-1) - $ + f4*f6*f2 * src2(is+1,js+3,ks-1) - $ + f5*f6*f2 * src2(is+2,js+3,ks-1) - $ + f6*f6*f2 * src2(is+3,js+3,ks-1) - res23 = - $ + f1*f1*f3 * src2(is-2,js-2,ks ) - $ + f2*f1*f3 * src2(is-1,js-2,ks ) - $ + f3*f1*f3 * src2(is ,js-2,ks ) - $ + f4*f1*f3 * src2(is+1,js-2,ks ) - $ + f5*f1*f3 * src2(is+2,js-2,ks ) - $ + f6*f1*f3 * src2(is+3,js-2,ks ) - $ + f1*f2*f3 * src2(is-2,js-1,ks ) - $ + f2*f2*f3 * src2(is-1,js-1,ks ) - $ + f3*f2*f3 * src2(is ,js-1,ks ) - $ + f4*f2*f3 * src2(is+1,js-1,ks ) - $ + f5*f2*f3 * src2(is+2,js-1,ks ) - $ + f6*f2*f3 * src2(is+3,js-1,ks ) - $ + f1*f3*f3 * src2(is-2,js ,ks ) - $ + f2*f3*f3 * src2(is-1,js ,ks ) - $ + f3*f3*f3 * src2(is ,js ,ks ) - $ + f4*f3*f3 * src2(is+1,js ,ks ) - $ + f5*f3*f3 * src2(is+2,js ,ks ) - $ + f6*f3*f3 * src2(is+3,js ,ks ) - $ + f1*f4*f3 * src2(is-2,js+1,ks ) - $ + f2*f4*f3 * src2(is-1,js+1,ks ) - $ + f3*f4*f3 * src2(is ,js+1,ks ) - $ + f4*f4*f3 * src2(is+1,js+1,ks ) - $ + f5*f4*f3 * src2(is+2,js+1,ks ) - $ + f6*f4*f3 * src2(is+3,js+1,ks ) - $ + f1*f5*f3 * src2(is-2,js+2,ks ) - $ + f2*f5*f3 * src2(is-1,js+2,ks ) - $ + f3*f5*f3 * src2(is ,js+2,ks ) - $ + f4*f5*f3 * src2(is+1,js+2,ks ) - $ + f5*f5*f3 * src2(is+2,js+2,ks ) - $ + f6*f5*f3 * src2(is+3,js+2,ks ) - $ + f1*f6*f3 * src2(is-2,js+3,ks ) - $ + f2*f6*f3 * src2(is-1,js+3,ks ) - $ + f3*f6*f3 * src2(is ,js+3,ks ) - $ + f4*f6*f3 * src2(is+1,js+3,ks ) - $ + f5*f6*f3 * src2(is+2,js+3,ks ) - $ + f6*f6*f3 * src2(is+3,js+3,ks ) - res24 = - $ + f1*f1*f4 * src2(is-2,js-2,ks+1) - $ + f2*f1*f4 * src2(is-1,js-2,ks+1) - $ + f3*f1*f4 * src2(is ,js-2,ks+1) - $ + f4*f1*f4 * src2(is+1,js-2,ks+1) - $ + f5*f1*f4 * src2(is+2,js-2,ks+1) - $ + f6*f1*f4 * src2(is+3,js-2,ks+1) - $ + f1*f2*f4 * src2(is-2,js-1,ks+1) - $ + f2*f2*f4 * src2(is-1,js-1,ks+1) - $ + f3*f2*f4 * src2(is ,js-1,ks+1) - $ + f4*f2*f4 * src2(is+1,js-1,ks+1) - $ + f5*f2*f4 * src2(is+2,js-1,ks+1) - $ + f6*f2*f4 * src2(is+3,js-1,ks+1) - $ + f1*f3*f4 * src2(is-2,js ,ks+1) - $ + f2*f3*f4 * src2(is-1,js ,ks+1) - $ + f3*f3*f4 * src2(is ,js ,ks+1) - $ + f4*f3*f4 * src2(is+1,js ,ks+1) - $ + f5*f3*f4 * src2(is+2,js ,ks+1) - $ + f6*f3*f4 * src2(is+3,js ,ks+1) - $ + f1*f4*f4 * src2(is-2,js+1,ks+1) - $ + f2*f4*f4 * src2(is-1,js+1,ks+1) - $ + f3*f4*f4 * src2(is ,js+1,ks+1) - $ + f4*f4*f4 * src2(is+1,js+1,ks+1) - $ + f5*f4*f4 * src2(is+2,js+1,ks+1) - $ + f6*f4*f4 * src2(is+3,js+1,ks+1) - $ + f1*f5*f4 * src2(is-2,js+2,ks+1) - $ + f2*f5*f4 * src2(is-1,js+2,ks+1) - $ + f3*f5*f4 * src2(is ,js+2,ks+1) - $ + f4*f5*f4 * src2(is+1,js+2,ks+1) - $ + f5*f5*f4 * src2(is+2,js+2,ks+1) - $ + f6*f5*f4 * src2(is+3,js+2,ks+1) - $ + f1*f6*f4 * src2(is-2,js+3,ks+1) - $ + f2*f6*f4 * src2(is-1,js+3,ks+1) - $ + f3*f6*f4 * src2(is ,js+3,ks+1) - $ + f4*f6*f4 * src2(is+1,js+3,ks+1) - $ + f5*f6*f4 * src2(is+2,js+3,ks+1) - $ + f6*f6*f4 * src2(is+3,js+3,ks+1) - res25 = - $ + f1*f1*f5 * src2(is-2,js-2,ks+2) - $ + f2*f1*f5 * src2(is-1,js-2,ks+2) - $ + f3*f1*f5 * src2(is ,js-2,ks+2) - $ + f4*f1*f5 * src2(is+1,js-2,ks+2) - $ + f5*f1*f5 * src2(is+2,js-2,ks+2) - $ + f6*f1*f5 * src2(is+3,js-2,ks+2) - $ + f1*f2*f5 * src2(is-2,js-1,ks+2) - $ + f2*f2*f5 * src2(is-1,js-1,ks+2) - $ + f3*f2*f5 * src2(is ,js-1,ks+2) - $ + f4*f2*f5 * src2(is+1,js-1,ks+2) - $ + f5*f2*f5 * src2(is+2,js-1,ks+2) - $ + f6*f2*f5 * src2(is+3,js-1,ks+2) - $ + f1*f3*f5 * src2(is-2,js ,ks+2) - $ + f2*f3*f5 * src2(is-1,js ,ks+2) - $ + f3*f3*f5 * src2(is ,js ,ks+2) - $ + f4*f3*f5 * src2(is+1,js ,ks+2) - $ + f5*f3*f5 * src2(is+2,js ,ks+2) - $ + f6*f3*f5 * src2(is+3,js ,ks+2) - $ + f1*f4*f5 * src2(is-2,js+1,ks+2) - $ + f2*f4*f5 * src2(is-1,js+1,ks+2) - $ + f3*f4*f5 * src2(is ,js+1,ks+2) - $ + f4*f4*f5 * src2(is+1,js+1,ks+2) - $ + f5*f4*f5 * src2(is+2,js+1,ks+2) - $ + f6*f4*f5 * src2(is+3,js+1,ks+2) - $ + f1*f5*f5 * src2(is-2,js+2,ks+2) - $ + f2*f5*f5 * src2(is-1,js+2,ks+2) - $ + f3*f5*f5 * src2(is ,js+2,ks+2) - $ + f4*f5*f5 * src2(is+1,js+2,ks+2) - $ + f5*f5*f5 * src2(is+2,js+2,ks+2) - $ + f6*f5*f5 * src2(is+3,js+2,ks+2) - $ + f1*f6*f5 * src2(is-2,js+3,ks+2) - $ + f2*f6*f5 * src2(is-1,js+3,ks+2) - $ + f3*f6*f5 * src2(is ,js+3,ks+2) - $ + f4*f6*f5 * src2(is+1,js+3,ks+2) - $ + f5*f6*f5 * src2(is+2,js+3,ks+2) - $ + f6*f6*f5 * src2(is+3,js+3,ks+2) - res26 = - $ + f1*f1*f6 * src2(is-2,js-2,ks+3) - $ + f2*f1*f6 * src2(is-1,js-2,ks+3) - $ + f3*f1*f6 * src2(is ,js-2,ks+3) - $ + f4*f1*f6 * src2(is+1,js-2,ks+3) - $ + f5*f1*f6 * src2(is+2,js-2,ks+3) - $ + f6*f1*f6 * src2(is+3,js-2,ks+3) - $ + f1*f2*f6 * src2(is-2,js-1,ks+3) - $ + f2*f2*f6 * src2(is-1,js-1,ks+3) - $ + f3*f2*f6 * src2(is ,js-1,ks+3) - $ + f4*f2*f6 * src2(is+1,js-1,ks+3) - $ + f5*f2*f6 * src2(is+2,js-1,ks+3) - $ + f6*f2*f6 * src2(is+3,js-1,ks+3) - $ + f1*f3*f6 * src2(is-2,js ,ks+3) - $ + f2*f3*f6 * src2(is-1,js ,ks+3) - $ + f3*f3*f6 * src2(is ,js ,ks+3) - $ + f4*f3*f6 * src2(is+1,js ,ks+3) - $ + f5*f3*f6 * src2(is+2,js ,ks+3) - $ + f6*f3*f6 * src2(is+3,js ,ks+3) - $ + f1*f4*f6 * src2(is-2,js+1,ks+3) - $ + f2*f4*f6 * src2(is-1,js+1,ks+3) - $ + f3*f4*f6 * src2(is ,js+1,ks+3) - $ + f4*f4*f6 * src2(is+1,js+1,ks+3) - $ + f5*f4*f6 * src2(is+2,js+1,ks+3) - $ + f6*f4*f6 * src2(is+3,js+1,ks+3) - $ + f1*f5*f6 * src2(is-2,js+2,ks+3) - $ + f2*f5*f6 * src2(is-1,js+2,ks+3) - $ + f3*f5*f6 * src2(is ,js+2,ks+3) - $ + f4*f5*f6 * src2(is+1,js+2,ks+3) - $ + f5*f5*f6 * src2(is+2,js+2,ks+3) - $ + f6*f5*f6 * src2(is+3,js+2,ks+3) - $ + f1*f6*f6 * src2(is-2,js+3,ks+3) - $ + f2*f6*f6 * src2(is-1,js+3,ks+3) - $ + f3*f6*f6 * src2(is ,js+3,ks+3) - $ + f4*f6*f6 * src2(is+1,js+3,ks+3) - $ + f5*f6*f6 * src2(is+2,js+3,ks+3) - $ + f6*f6*f6 * src2(is+3,js+3,ks+3) - res31 = - $ + f1*f1*f1 * src3(is-2,js-2,ks-2) - $ + f2*f1*f1 * src3(is-1,js-2,ks-2) - $ + f3*f1*f1 * src3(is ,js-2,ks-2) - $ + f4*f1*f1 * src3(is+1,js-2,ks-2) - $ + f5*f1*f1 * src3(is+2,js-2,ks-2) - $ + f6*f1*f1 * src3(is+3,js-2,ks-2) - $ + f1*f2*f1 * src3(is-2,js-1,ks-2) - $ + f2*f2*f1 * src3(is-1,js-1,ks-2) - $ + f3*f2*f1 * src3(is ,js-1,ks-2) - $ + f4*f2*f1 * src3(is+1,js-1,ks-2) - $ + f5*f2*f1 * src3(is+2,js-1,ks-2) - $ + f6*f2*f1 * src3(is+3,js-1,ks-2) - $ + f1*f3*f1 * src3(is-2,js ,ks-2) - $ + f2*f3*f1 * src3(is-1,js ,ks-2) - $ + f3*f3*f1 * src3(is ,js ,ks-2) - $ + f4*f3*f1 * src3(is+1,js ,ks-2) - $ + f5*f3*f1 * src3(is+2,js ,ks-2) - $ + f6*f3*f1 * src3(is+3,js ,ks-2) - $ + f1*f4*f1 * src3(is-2,js+1,ks-2) - $ + f2*f4*f1 * src3(is-1,js+1,ks-2) - $ + f3*f4*f1 * src3(is ,js+1,ks-2) - $ + f4*f4*f1 * src3(is+1,js+1,ks-2) - $ + f5*f4*f1 * src3(is+2,js+1,ks-2) - $ + f6*f4*f1 * src3(is+3,js+1,ks-2) - $ + f1*f5*f1 * src3(is-2,js+2,ks-2) - $ + f2*f5*f1 * src3(is-1,js+2,ks-2) - $ + f3*f5*f1 * src3(is ,js+2,ks-2) - $ + f4*f5*f1 * src3(is+1,js+2,ks-2) - $ + f5*f5*f1 * src3(is+2,js+2,ks-2) - $ + f6*f5*f1 * src3(is+3,js+2,ks-2) - $ + f1*f6*f1 * src3(is-2,js+3,ks-2) - $ + f2*f6*f1 * src3(is-1,js+3,ks-2) - $ + f3*f6*f1 * src3(is ,js+3,ks-2) - $ + f4*f6*f1 * src3(is+1,js+3,ks-2) - $ + f5*f6*f1 * src3(is+2,js+3,ks-2) - $ + f6*f6*f1 * src3(is+3,js+3,ks-2) - res32 = - $ + f1*f1*f2 * src3(is-2,js-2,ks-1) - $ + f2*f1*f2 * src3(is-1,js-2,ks-1) - $ + f3*f1*f2 * src3(is ,js-2,ks-1) - $ + f4*f1*f2 * src3(is+1,js-2,ks-1) - $ + f5*f1*f2 * src3(is+2,js-2,ks-1) - $ + f6*f1*f2 * src3(is+3,js-2,ks-1) - $ + f1*f2*f2 * src3(is-2,js-1,ks-1) - $ + f2*f2*f2 * src3(is-1,js-1,ks-1) - $ + f3*f2*f2 * src3(is ,js-1,ks-1) - $ + f4*f2*f2 * src3(is+1,js-1,ks-1) - $ + f5*f2*f2 * src3(is+2,js-1,ks-1) - $ + f6*f2*f2 * src3(is+3,js-1,ks-1) - $ + f1*f3*f2 * src3(is-2,js ,ks-1) - $ + f2*f3*f2 * src3(is-1,js ,ks-1) - $ + f3*f3*f2 * src3(is ,js ,ks-1) - $ + f4*f3*f2 * src3(is+1,js ,ks-1) - $ + f5*f3*f2 * src3(is+2,js ,ks-1) - $ + f6*f3*f2 * src3(is+3,js ,ks-1) - $ + f1*f4*f2 * src3(is-2,js+1,ks-1) - $ + f2*f4*f2 * src3(is-1,js+1,ks-1) - $ + f3*f4*f2 * src3(is ,js+1,ks-1) - $ + f4*f4*f2 * src3(is+1,js+1,ks-1) - $ + f5*f4*f2 * src3(is+2,js+1,ks-1) - $ + f6*f4*f2 * src3(is+3,js+1,ks-1) - $ + f1*f5*f2 * src3(is-2,js+2,ks-1) - $ + f2*f5*f2 * src3(is-1,js+2,ks-1) - $ + f3*f5*f2 * src3(is ,js+2,ks-1) - $ + f4*f5*f2 * src3(is+1,js+2,ks-1) - $ + f5*f5*f2 * src3(is+2,js+2,ks-1) - $ + f6*f5*f2 * src3(is+3,js+2,ks-1) - $ + f1*f6*f2 * src3(is-2,js+3,ks-1) - $ + f2*f6*f2 * src3(is-1,js+3,ks-1) - $ + f3*f6*f2 * src3(is ,js+3,ks-1) - $ + f4*f6*f2 * src3(is+1,js+3,ks-1) - $ + f5*f6*f2 * src3(is+2,js+3,ks-1) - $ + f6*f6*f2 * src3(is+3,js+3,ks-1) - res33 = - $ + f1*f1*f3 * src3(is-2,js-2,ks ) - $ + f2*f1*f3 * src3(is-1,js-2,ks ) - $ + f3*f1*f3 * src3(is ,js-2,ks ) - $ + f4*f1*f3 * src3(is+1,js-2,ks ) - $ + f5*f1*f3 * src3(is+2,js-2,ks ) - $ + f6*f1*f3 * src3(is+3,js-2,ks ) - $ + f1*f2*f3 * src3(is-2,js-1,ks ) - $ + f2*f2*f3 * src3(is-1,js-1,ks ) - $ + f3*f2*f3 * src3(is ,js-1,ks ) - $ + f4*f2*f3 * src3(is+1,js-1,ks ) - $ + f5*f2*f3 * src3(is+2,js-1,ks ) - $ + f6*f2*f3 * src3(is+3,js-1,ks ) - $ + f1*f3*f3 * src3(is-2,js ,ks ) - $ + f2*f3*f3 * src3(is-1,js ,ks ) - $ + f3*f3*f3 * src3(is ,js ,ks ) - $ + f4*f3*f3 * src3(is+1,js ,ks ) - $ + f5*f3*f3 * src3(is+2,js ,ks ) - $ + f6*f3*f3 * src3(is+3,js ,ks ) - $ + f1*f4*f3 * src3(is-2,js+1,ks ) - $ + f2*f4*f3 * src3(is-1,js+1,ks ) - $ + f3*f4*f3 * src3(is ,js+1,ks ) - $ + f4*f4*f3 * src3(is+1,js+1,ks ) - $ + f5*f4*f3 * src3(is+2,js+1,ks ) - $ + f6*f4*f3 * src3(is+3,js+1,ks ) - $ + f1*f5*f3 * src3(is-2,js+2,ks ) - $ + f2*f5*f3 * src3(is-1,js+2,ks ) - $ + f3*f5*f3 * src3(is ,js+2,ks ) - $ + f4*f5*f3 * src3(is+1,js+2,ks ) - $ + f5*f5*f3 * src3(is+2,js+2,ks ) - $ + f6*f5*f3 * src3(is+3,js+2,ks ) - $ + f1*f6*f3 * src3(is-2,js+3,ks ) - $ + f2*f6*f3 * src3(is-1,js+3,ks ) - $ + f3*f6*f3 * src3(is ,js+3,ks ) - $ + f4*f6*f3 * src3(is+1,js+3,ks ) - $ + f5*f6*f3 * src3(is+2,js+3,ks ) - $ + f6*f6*f3 * src3(is+3,js+3,ks ) - res34 = - $ + f1*f1*f4 * src3(is-2,js-2,ks+1) - $ + f2*f1*f4 * src3(is-1,js-2,ks+1) - $ + f3*f1*f4 * src3(is ,js-2,ks+1) - $ + f4*f1*f4 * src3(is+1,js-2,ks+1) - $ + f5*f1*f4 * src3(is+2,js-2,ks+1) - $ + f6*f1*f4 * src3(is+3,js-2,ks+1) - $ + f1*f2*f4 * src3(is-2,js-1,ks+1) - $ + f2*f2*f4 * src3(is-1,js-1,ks+1) - $ + f3*f2*f4 * src3(is ,js-1,ks+1) - $ + f4*f2*f4 * src3(is+1,js-1,ks+1) - $ + f5*f2*f4 * src3(is+2,js-1,ks+1) - $ + f6*f2*f4 * src3(is+3,js-1,ks+1) - $ + f1*f3*f4 * src3(is-2,js ,ks+1) - $ + f2*f3*f4 * src3(is-1,js ,ks+1) - $ + f3*f3*f4 * src3(is ,js ,ks+1) - $ + f4*f3*f4 * src3(is+1,js ,ks+1) - $ + f5*f3*f4 * src3(is+2,js ,ks+1) - $ + f6*f3*f4 * src3(is+3,js ,ks+1) - $ + f1*f4*f4 * src3(is-2,js+1,ks+1) - $ + f2*f4*f4 * src3(is-1,js+1,ks+1) - $ + f3*f4*f4 * src3(is ,js+1,ks+1) - $ + f4*f4*f4 * src3(is+1,js+1,ks+1) - $ + f5*f4*f4 * src3(is+2,js+1,ks+1) - $ + f6*f4*f4 * src3(is+3,js+1,ks+1) - $ + f1*f5*f4 * src3(is-2,js+2,ks+1) - $ + f2*f5*f4 * src3(is-1,js+2,ks+1) - $ + f3*f5*f4 * src3(is ,js+2,ks+1) - $ + f4*f5*f4 * src3(is+1,js+2,ks+1) - $ + f5*f5*f4 * src3(is+2,js+2,ks+1) - $ + f6*f5*f4 * src3(is+3,js+2,ks+1) - $ + f1*f6*f4 * src3(is-2,js+3,ks+1) - $ + f2*f6*f4 * src3(is-1,js+3,ks+1) - $ + f3*f6*f4 * src3(is ,js+3,ks+1) - $ + f4*f6*f4 * src3(is+1,js+3,ks+1) - $ + f5*f6*f4 * src3(is+2,js+3,ks+1) - $ + f6*f6*f4 * src3(is+3,js+3,ks+1) - res35 = - $ + f1*f1*f5 * src3(is-2,js-2,ks+2) - $ + f2*f1*f5 * src3(is-1,js-2,ks+2) - $ + f3*f1*f5 * src3(is ,js-2,ks+2) - $ + f4*f1*f5 * src3(is+1,js-2,ks+2) - $ + f5*f1*f5 * src3(is+2,js-2,ks+2) - $ + f6*f1*f5 * src3(is+3,js-2,ks+2) - $ + f1*f2*f5 * src3(is-2,js-1,ks+2) - $ + f2*f2*f5 * src3(is-1,js-1,ks+2) - $ + f3*f2*f5 * src3(is ,js-1,ks+2) - $ + f4*f2*f5 * src3(is+1,js-1,ks+2) - $ + f5*f2*f5 * src3(is+2,js-1,ks+2) - $ + f6*f2*f5 * src3(is+3,js-1,ks+2) - $ + f1*f3*f5 * src3(is-2,js ,ks+2) - $ + f2*f3*f5 * src3(is-1,js ,ks+2) - $ + f3*f3*f5 * src3(is ,js ,ks+2) - $ + f4*f3*f5 * src3(is+1,js ,ks+2) - $ + f5*f3*f5 * src3(is+2,js ,ks+2) - $ + f6*f3*f5 * src3(is+3,js ,ks+2) - $ + f1*f4*f5 * src3(is-2,js+1,ks+2) - $ + f2*f4*f5 * src3(is-1,js+1,ks+2) - $ + f3*f4*f5 * src3(is ,js+1,ks+2) - $ + f4*f4*f5 * src3(is+1,js+1,ks+2) - $ + f5*f4*f5 * src3(is+2,js+1,ks+2) - $ + f6*f4*f5 * src3(is+3,js+1,ks+2) - $ + f1*f5*f5 * src3(is-2,js+2,ks+2) - $ + f2*f5*f5 * src3(is-1,js+2,ks+2) - $ + f3*f5*f5 * src3(is ,js+2,ks+2) - $ + f4*f5*f5 * src3(is+1,js+2,ks+2) - $ + f5*f5*f5 * src3(is+2,js+2,ks+2) - $ + f6*f5*f5 * src3(is+3,js+2,ks+2) - $ + f1*f6*f5 * src3(is-2,js+3,ks+2) - $ + f2*f6*f5 * src3(is-1,js+3,ks+2) - $ + f3*f6*f5 * src3(is ,js+3,ks+2) - $ + f4*f6*f5 * src3(is+1,js+3,ks+2) - $ + f5*f6*f5 * src3(is+2,js+3,ks+2) - $ + f6*f6*f5 * src3(is+3,js+3,ks+2) - res36 = - $ + f1*f1*f6 * src3(is-2,js-2,ks+3) - $ + f2*f1*f6 * src3(is-1,js-2,ks+3) - $ + f3*f1*f6 * src3(is ,js-2,ks+3) - $ + f4*f1*f6 * src3(is+1,js-2,ks+3) - $ + f5*f1*f6 * src3(is+2,js-2,ks+3) - $ + f6*f1*f6 * src3(is+3,js-2,ks+3) - $ + f1*f2*f6 * src3(is-2,js-1,ks+3) - $ + f2*f2*f6 * src3(is-1,js-1,ks+3) - $ + f3*f2*f6 * src3(is ,js-1,ks+3) - $ + f4*f2*f6 * src3(is+1,js-1,ks+3) - $ + f5*f2*f6 * src3(is+2,js-1,ks+3) - $ + f6*f2*f6 * src3(is+3,js-1,ks+3) - $ + f1*f3*f6 * src3(is-2,js ,ks+3) - $ + f2*f3*f6 * src3(is-1,js ,ks+3) - $ + f3*f3*f6 * src3(is ,js ,ks+3) - $ + f4*f3*f6 * src3(is+1,js ,ks+3) - $ + f5*f3*f6 * src3(is+2,js ,ks+3) - $ + f6*f3*f6 * src3(is+3,js ,ks+3) - $ + f1*f4*f6 * src3(is-2,js+1,ks+3) - $ + f2*f4*f6 * src3(is-1,js+1,ks+3) - $ + f3*f4*f6 * src3(is ,js+1,ks+3) - $ + f4*f4*f6 * src3(is+1,js+1,ks+3) - $ + f5*f4*f6 * src3(is+2,js+1,ks+3) - $ + f6*f4*f6 * src3(is+3,js+1,ks+3) - $ + f1*f5*f6 * src3(is-2,js+2,ks+3) - $ + f2*f5*f6 * src3(is-1,js+2,ks+3) - $ + f3*f5*f6 * src3(is ,js+2,ks+3) - $ + f4*f5*f6 * src3(is+1,js+2,ks+3) - $ + f5*f5*f6 * src3(is+2,js+2,ks+3) - $ + f6*f5*f6 * src3(is+3,js+2,ks+3) - $ + f1*f6*f6 * src3(is-2,js+3,ks+3) - $ + f2*f6*f6 * src3(is-1,js+3,ks+3) - $ + f3*f6*f6 * src3(is ,js+3,ks+3) - $ + f4*f6*f6 * src3(is+1,js+3,ks+3) - $ + f5*f6*f6 * src3(is+2,js+3,ks+3) - $ + f6*f6*f6 * src3(is+3,js+3,ks+3) - dst(id,jd,kd) = - $ + s1fac * (res11 + res12 + res13 + res14 + res15 + res16) - $ + s2fac * (res21 + res22 + res23 + res24 + res25 + res26) - $ + s3fac * (res31 + res32 + res33 + res34 + res35 + res36) - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8110 - goto 911 - -c end i loop - 911 continue - j = j+1 - jd = jd+1 - js = js+1 - if (j.lt.regjext) goto 810 - goto 91 - -c end j loop - 91 continue - k = k+1 - kd = kd+1 - ks = ks+1 - if (k.lt.regkext) goto 80 - goto 9 - -c end k loop - 9 continue - - end diff --git a/Carpet/CarpetLib/src/prolongate_3d_real8_3tl_o7_rf2.F77 b/Carpet/CarpetLib/src/prolongate_3d_real8_3tl_o7_rf2.F77 deleted file mode 100644 index e997e4238..000000000 --- a/Carpet/CarpetLib/src/prolongate_3d_real8_3tl_o7_rf2.F77 +++ /dev/null @@ -1,2607 +0,0 @@ -c -*-Fortran-*- - -#include "cctk.h" -#include "cctk_Parameters.h" - - - - subroutine prolongate_3d_real8_3tl_o7_rf2 ( - $ src1, t1, src2, t2, src3, t3, srciext, srcjext, srckext, - $ dst, t, dstiext, dstjext, dstkext, - $ srcbbox, dstbbox, regbbox) - - implicit none - - DECLARE_CCTK_PARAMETERS - - CCTK_REAL8 eps - parameter (eps = 1.0d-10) - - CCTK_REAL8 one - parameter (one = 1) - CCTK_REAL8 f1, f2, f3, f4, f5, f6, f7, f8 - parameter (f1 = - 5*one/2048) - parameter (f2 = 49*one/2048) - parameter (f3 = - 245*one/2048) - parameter (f4 = 1225*one/2048) - parameter (f5 = 1225*one/2048) - parameter (f6 = - 245*one/2048) - parameter (f7 = 49*one/2048) - parameter (f8 = - 5*one/2048) - - integer srciext, srcjext, srckext - CCTK_REAL8 src1(srciext,srcjext,srckext) - CCTK_REAL8 t1 - CCTK_REAL8 src2(srciext,srcjext,srckext) - CCTK_REAL8 t2 - CCTK_REAL8 src3(srciext,srcjext,srckext) - CCTK_REAL8 t3 - integer dstiext, dstjext, dstkext - CCTK_REAL8 dst(dstiext,dstjext,dstkext) - CCTK_REAL8 t -c bbox(:,1) is lower boundary (inclusive) -c bbox(:,2) is upper boundary (inclusive) -c bbox(:,3) is stride - integer srcbbox(3,3), dstbbox(3,3), regbbox(3,3) - - integer regiext, regjext, regkext - - integer srcioff, srcjoff, srckoff - integer dstioff, dstjoff, dstkoff - - integer offsetlo, offsethi - - CCTK_REAL8 s1fac, s2fac, s3fac - - integer i0, j0, k0 - integer fi, fj, fk - integer is, js, ks - integer id, jd, kd - integer i, j, k - - CCTK_REAL8 res1, res2, res3 - CCTK_REAL8 res11, res12, res13, res14, res15, res16, res17, res18 - CCTK_REAL8 res21, res22, res23, res24, res25, res26, res27, res28 - CCTK_REAL8 res31, res32, res33, res34, res35, res36, res37, res38 - - integer d - - - - do d=1,3 - if (srcbbox(d,3).eq.0 .or. dstbbox(d,3).eq.0 - $ .or. regbbox(d,3).eq.0) then - call CCTK_WARN (0, "Internal error: stride is zero") - end if - if (srcbbox(d,3).le.regbbox(d,3) - $ .or. dstbbox(d,3).ne.regbbox(d,3)) then - call CCTK_WARN (0, "Internal error: strides disagree") - end if - if (srcbbox(d,3).ne.dstbbox(d,3)*2) then - call CCTK_WARN (0, "Internal error: source strides are not twice the destination strides") - end if - if (mod(srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array origins are not integer multiples of the strides") - end if - if (regbbox(d,1).gt.regbbox(d,2)) then -c This could be handled, but is likely to point to an error elsewhere - call CCTK_WARN (0, "Internal error: region extent is empty") - end if - if (mod(srcbbox(d,2) - srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,2) - dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,2) - regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array extents are not integer multiples of the strides") - end if - regkext = (regbbox(d,2) - regbbox(d,1)) / regbbox(d,3) + 1 - srckoff = (regbbox(d,1) - srcbbox(d,1)) / dstbbox(d,3) - offsetlo = regbbox(d,3) - if (mod(srckoff, 2).eq.0) then - offsetlo = 0 - if (regkext.gt.1) then - offsetlo = regbbox(d,3) - end if - end if - offsethi = regbbox(d,3) - if (mod(srckoff + regkext-1, 2).eq.0) then - offsethi = 0 - if (regkext.gt.1) then - offsethi = regbbox(d,3) - end if - end if - if (regbbox(d,1)-offsetlo.lt.srcbbox(d,1) - $ .or. regbbox(d,2)+offsethi.gt.srcbbox(d,2) - $ .or. regbbox(d,1).lt.dstbbox(d,1) - $ .or. regbbox(d,2).gt.dstbbox(d,2)) then - call CCTK_WARN (0, "Internal error: region extent is not contained in array extent") - end if - end do - - if (srciext.ne.(srcbbox(1,2)-srcbbox(1,1))/srcbbox(1,3)+1 - $ .or. srcjext.ne.(srcbbox(2,2)-srcbbox(2,1))/srcbbox(2,3)+1 - $ .or. srckext.ne.(srcbbox(3,2)-srcbbox(3,1))/srcbbox(3,3)+1 - $ .or. dstiext.ne.(dstbbox(1,2)-dstbbox(1,1))/dstbbox(1,3)+1 - $ .or. dstjext.ne.(dstbbox(2,2)-dstbbox(2,1))/dstbbox(2,3)+1 - $ .or. dstkext.ne.(dstbbox(3,2)-dstbbox(3,1))/dstbbox(3,3)+1) then - call CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes") - end if - - - - regiext = (regbbox(1,2) - regbbox(1,1)) / regbbox(1,3) + 1 - regjext = (regbbox(2,2) - regbbox(2,1)) / regbbox(2,3) + 1 - regkext = (regbbox(3,2) - regbbox(3,1)) / regbbox(3,3) + 1 - - srcioff = (regbbox(1,1) - srcbbox(1,1)) / dstbbox(1,3) - srcjoff = (regbbox(2,1) - srcbbox(2,1)) / dstbbox(2,3) - srckoff = (regbbox(3,1) - srcbbox(3,1)) / dstbbox(3,3) - - dstioff = (regbbox(1,1) - dstbbox(1,1)) / dstbbox(1,3) - dstjoff = (regbbox(2,1) - dstbbox(2,1)) / dstbbox(2,3) - dstkoff = (regbbox(3,1) - dstbbox(3,1)) / dstbbox(3,3) - - - -c Quadratic (second order) time interpolation - if (t1.eq.t2 .or. t1.eq.t3 .or. t2.eq.t3) then - call CCTK_WARN (0, "Internal error: arrays have same time") - end if - if (t.lt.min(t1,t2,t3)-eps .or. t.gt.max(t1,t2,t3)+eps) then - call CCTK_WARN (0, "Internal error: extrapolation in time in time") - end if - - s1fac = (t - t2) * (t - t3) / ((t1 - t2) * (t1 - t3)) - s2fac = (t - t1) * (t - t3) / ((t2 - t1) * (t2 - t3)) - s3fac = (t - t1) * (t - t2) / ((t3 - t1) * (t3 - t2)) - - - - fi = mod(srcioff, 2) - fj = mod(srcjoff, 2) - fk = mod(srckoff, 2) - - i0 = srcioff / 2 - j0 = srcjoff / 2 - k0 = srckoff / 2 - - - -c Loop over fine region -c Label scheme: 8 fk fj fi - -c begin k loop - 8 continue - k = 0 - ks = k0+1 - kd = dstkoff+1 - if (fk.eq.0) goto 80 - if (fk.eq.1) goto 81 - stop - -c begin j loop - 80 continue - j = 0 - js = j0+1 - jd = dstjoff+1 - if (fj.eq.0) goto 800 - if (fj.eq.1) goto 801 - stop - -c begin i loop - 800 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8000 - if (fi.eq.1) goto 8001 - stop - -c kernel - 8000 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js,ks, 1,1,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + s1fac * src1(is,js,ks) - $ + s2fac * src2(is,js,ks) - $ + s3fac * src3(is,js,ks) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8001 - goto 900 - -c kernel - 8001 continue - if (check_array_accesses.ne.0) then - call checkindex (is-3,js,ks, 8,1,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + f1 * s1fac * src1(is-3,js,ks) - $ + f2 * s1fac * src1(is-2,js,ks) - $ + f3 * s1fac * src1(is-1,js,ks) - $ + f4 * s1fac * src1(is ,js,ks) - $ + f5 * s1fac * src1(is+1,js,ks) - $ + f6 * s1fac * src1(is+2,js,ks) - $ + f7 * s1fac * src1(is+3,js,ks) - $ + f8 * s1fac * src1(is+4,js,ks) - $ + f1 * s2fac * src2(is-3,js,ks) - $ + f2 * s2fac * src2(is-2,js,ks) - $ + f3 * s2fac * src2(is-1,js,ks) - $ + f4 * s2fac * src2(is ,js,ks) - $ + f5 * s2fac * src2(is+1,js,ks) - $ + f6 * s2fac * src2(is+2,js,ks) - $ + f7 * s2fac * src2(is+3,js,ks) - $ + f8 * s2fac * src2(is+4,js,ks) - $ + f1 * s3fac * src3(is-3,js,ks) - $ + f2 * s3fac * src3(is-2,js,ks) - $ + f3 * s3fac * src3(is-1,js,ks) - $ + f4 * s3fac * src3(is ,js,ks) - $ + f5 * s3fac * src3(is+1,js,ks) - $ + f6 * s3fac * src3(is+2,js,ks) - $ + f7 * s3fac * src3(is+3,js,ks) - $ + f8 * s3fac * src3(is+4,js,ks) - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8000 - goto 900 - -c end i loop - 900 continue - j = j+1 - jd = jd+1 - if (j.lt.regjext) goto 801 - goto 90 - -c begin i loop - 801 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8010 - if (fi.eq.1) goto 8011 - stop - -c kernel - 8010 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js-3,ks, 1,8,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + f1 * s1fac * src1(is,js-3,ks) - $ + f2 * s1fac * src1(is,js-2,ks) - $ + f3 * s1fac * src1(is,js-1,ks) - $ + f4 * s1fac * src1(is,js ,ks) - $ + f5 * s1fac * src1(is,js+1,ks) - $ + f6 * s1fac * src1(is,js+2,ks) - $ + f7 * s1fac * src1(is,js+3,ks) - $ + f8 * s1fac * src1(is,js+4,ks) - $ + f1 * s2fac * src2(is,js-3,ks) - $ + f2 * s2fac * src2(is,js-2,ks) - $ + f3 * s2fac * src2(is,js-1,ks) - $ + f4 * s2fac * src2(is,js ,ks) - $ + f5 * s2fac * src2(is,js+1,ks) - $ + f6 * s2fac * src2(is,js+2,ks) - $ + f7 * s2fac * src2(is,js+3,ks) - $ + f8 * s2fac * src2(is,js+4,ks) - $ + f1 * s3fac * src3(is,js-3,ks) - $ + f2 * s3fac * src3(is,js-2,ks) - $ + f3 * s3fac * src3(is,js-1,ks) - $ + f4 * s3fac * src3(is,js ,ks) - $ + f5 * s3fac * src3(is,js+1,ks) - $ + f6 * s3fac * src3(is,js+2,ks) - $ + f7 * s3fac * src3(is,js+3,ks) - $ + f8 * s3fac * src3(is,js+4,ks) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8011 - goto 901 - -c kernel - 8011 continue - if (check_array_accesses.ne.0) then - call checkindex (is-3,js-3,ks, 8,8,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - res1 = - $ + f1*f1 * src1(is-3,js-3,ks) - $ + f2*f1 * src1(is-2,js-3,ks) - $ + f3*f1 * src1(is-1,js-3,ks) - $ + f4*f1 * src1(is ,js-3,ks) - $ + f5*f1 * src1(is+1,js-3,ks) - $ + f6*f1 * src1(is+2,js-3,ks) - $ + f7*f1 * src1(is+3,js-3,ks) - $ + f8*f1 * src1(is+4,js-3,ks) - $ + f1*f2 * src1(is-3,js-2,ks) - $ + f2*f2 * src1(is-2,js-2,ks) - $ + f3*f2 * src1(is-1,js-2,ks) - $ + f4*f2 * src1(is ,js-2,ks) - $ + f5*f2 * src1(is+1,js-2,ks) - $ + f6*f2 * src1(is+2,js-2,ks) - $ + f7*f2 * src1(is+3,js-2,ks) - $ + f8*f2 * src1(is+4,js-2,ks) - $ + f1*f3 * src1(is-3,js-1,ks) - $ + f2*f3 * src1(is-2,js-1,ks) - $ + f3*f3 * src1(is-1,js-1,ks) - $ + f4*f3 * src1(is ,js-1,ks) - $ + f5*f3 * src1(is+1,js-1,ks) - $ + f6*f3 * src1(is+2,js-1,ks) - $ + f7*f3 * src1(is+3,js-1,ks) - $ + f8*f3 * src1(is+4,js-1,ks) - $ + f1*f4 * src1(is-3,js ,ks) - $ + f2*f4 * src1(is-2,js ,ks) - $ + f3*f4 * src1(is-1,js ,ks) - $ + f4*f4 * src1(is ,js ,ks) - $ + f5*f4 * src1(is+1,js ,ks) - $ + f6*f4 * src1(is+2,js ,ks) - $ + f7*f4 * src1(is+3,js ,ks) - $ + f8*f4 * src1(is+4,js ,ks) - $ + f1*f5 * src1(is-3,js+1,ks) - $ + f2*f5 * src1(is-2,js+1,ks) - $ + f3*f5 * src1(is-1,js+1,ks) - $ + f4*f5 * src1(is ,js+1,ks) - $ + f5*f5 * src1(is+1,js+1,ks) - $ + f6*f5 * src1(is+2,js+1,ks) - $ + f7*f5 * src1(is+3,js+1,ks) - $ + f8*f5 * src1(is+4,js+1,ks) - $ + f1*f6 * src1(is-3,js+2,ks) - $ + f2*f6 * src1(is-2,js+2,ks) - $ + f3*f6 * src1(is-1,js+2,ks) - $ + f4*f6 * src1(is ,js+2,ks) - $ + f5*f6 * src1(is+1,js+2,ks) - $ + f6*f6 * src1(is+2,js+2,ks) - $ + f7*f6 * src1(is+3,js+2,ks) - $ + f8*f6 * src1(is+4,js+2,ks) - $ + f1*f7 * src1(is-3,js+3,ks) - $ + f2*f7 * src1(is-2,js+3,ks) - $ + f3*f7 * src1(is-1,js+3,ks) - $ + f4*f7 * src1(is ,js+3,ks) - $ + f5*f7 * src1(is+1,js+3,ks) - $ + f6*f7 * src1(is+2,js+3,ks) - $ + f7*f7 * src1(is+3,js+3,ks) - $ + f8*f7 * src1(is+4,js+3,ks) - $ + f1*f8 * src1(is-3,js+4,ks) - $ + f2*f8 * src1(is-2,js+4,ks) - $ + f3*f8 * src1(is-1,js+4,ks) - $ + f4*f8 * src1(is ,js+4,ks) - $ + f5*f8 * src1(is+1,js+4,ks) - $ + f6*f8 * src1(is+2,js+4,ks) - $ + f7*f8 * src1(is+3,js+4,ks) - $ + f8*f8 * src1(is+4,js+4,ks) - res2 = - $ + f1*f1 * src2(is-3,js-3,ks) - $ + f2*f1 * src2(is-2,js-3,ks) - $ + f3*f1 * src2(is-1,js-3,ks) - $ + f4*f1 * src2(is ,js-3,ks) - $ + f5*f1 * src2(is+1,js-3,ks) - $ + f6*f1 * src2(is+2,js-3,ks) - $ + f7*f1 * src2(is+3,js-3,ks) - $ + f8*f1 * src2(is+4,js-3,ks) - $ + f1*f2 * src2(is-3,js-2,ks) - $ + f2*f2 * src2(is-2,js-2,ks) - $ + f3*f2 * src2(is-1,js-2,ks) - $ + f4*f2 * src2(is ,js-2,ks) - $ + f5*f2 * src2(is+1,js-2,ks) - $ + f6*f2 * src2(is+2,js-2,ks) - $ + f7*f2 * src2(is+3,js-2,ks) - $ + f8*f2 * src2(is+4,js-2,ks) - $ + f1*f3 * src2(is-3,js-1,ks) - $ + f2*f3 * src2(is-2,js-1,ks) - $ + f3*f3 * src2(is-1,js-1,ks) - $ + f4*f3 * src2(is ,js-1,ks) - $ + f5*f3 * src2(is+1,js-1,ks) - $ + f6*f3 * src2(is+2,js-1,ks) - $ + f7*f3 * src2(is+3,js-1,ks) - $ + f8*f3 * src2(is+4,js-1,ks) - $ + f1*f4 * src2(is-3,js ,ks) - $ + f2*f4 * src2(is-2,js ,ks) - $ + f3*f4 * src2(is-1,js ,ks) - $ + f4*f4 * src2(is ,js ,ks) - $ + f5*f4 * src2(is+1,js ,ks) - $ + f6*f4 * src2(is+2,js ,ks) - $ + f7*f4 * src2(is+3,js ,ks) - $ + f8*f4 * src2(is+4,js ,ks) - $ + f1*f5 * src2(is-3,js+1,ks) - $ + f2*f5 * src2(is-2,js+1,ks) - $ + f3*f5 * src2(is-1,js+1,ks) - $ + f4*f5 * src2(is ,js+1,ks) - $ + f5*f5 * src2(is+1,js+1,ks) - $ + f6*f5 * src2(is+2,js+1,ks) - $ + f7*f5 * src2(is+3,js+1,ks) - $ + f8*f5 * src2(is+4,js+1,ks) - $ + f1*f6 * src2(is-3,js+2,ks) - $ + f2*f6 * src2(is-2,js+2,ks) - $ + f3*f6 * src2(is-1,js+2,ks) - $ + f4*f6 * src2(is ,js+2,ks) - $ + f5*f6 * src2(is+1,js+2,ks) - $ + f6*f6 * src2(is+2,js+2,ks) - $ + f7*f6 * src2(is+3,js+2,ks) - $ + f8*f6 * src2(is+4,js+2,ks) - $ + f1*f7 * src2(is-3,js+3,ks) - $ + f2*f7 * src2(is-2,js+3,ks) - $ + f3*f7 * src2(is-1,js+3,ks) - $ + f4*f7 * src2(is ,js+3,ks) - $ + f5*f7 * src2(is+1,js+3,ks) - $ + f6*f7 * src2(is+2,js+3,ks) - $ + f7*f7 * src2(is+3,js+3,ks) - $ + f8*f7 * src2(is+4,js+3,ks) - $ + f1*f8 * src2(is-3,js+4,ks) - $ + f2*f8 * src2(is-2,js+4,ks) - $ + f3*f8 * src2(is-1,js+4,ks) - $ + f4*f8 * src2(is ,js+4,ks) - $ + f5*f8 * src2(is+1,js+4,ks) - $ + f6*f8 * src2(is+2,js+4,ks) - $ + f7*f8 * src2(is+3,js+4,ks) - $ + f8*f8 * src2(is+4,js+4,ks) - res3 = - $ + f1*f1 * src3(is-3,js-3,ks) - $ + f2*f1 * src3(is-2,js-3,ks) - $ + f3*f1 * src3(is-1,js-3,ks) - $ + f4*f1 * src3(is ,js-3,ks) - $ + f5*f1 * src3(is+1,js-3,ks) - $ + f6*f1 * src3(is+2,js-3,ks) - $ + f7*f1 * src3(is+3,js-3,ks) - $ + f8*f1 * src3(is+4,js-3,ks) - $ + f1*f2 * src3(is-3,js-2,ks) - $ + f2*f2 * src3(is-2,js-2,ks) - $ + f3*f2 * src3(is-1,js-2,ks) - $ + f4*f2 * src3(is ,js-2,ks) - $ + f5*f2 * src3(is+1,js-2,ks) - $ + f6*f2 * src3(is+2,js-2,ks) - $ + f7*f2 * src3(is+3,js-2,ks) - $ + f8*f2 * src3(is+4,js-2,ks) - $ + f1*f3 * src3(is-3,js-1,ks) - $ + f2*f3 * src3(is-2,js-1,ks) - $ + f3*f3 * src3(is-1,js-1,ks) - $ + f4*f3 * src3(is ,js-1,ks) - $ + f5*f3 * src3(is+1,js-1,ks) - $ + f6*f3 * src3(is+2,js-1,ks) - $ + f7*f3 * src3(is+3,js-1,ks) - $ + f8*f3 * src3(is+4,js-1,ks) - $ + f1*f4 * src3(is-3,js ,ks) - $ + f2*f4 * src3(is-2,js ,ks) - $ + f3*f4 * src3(is-1,js ,ks) - $ + f4*f4 * src3(is ,js ,ks) - $ + f5*f4 * src3(is+1,js ,ks) - $ + f6*f4 * src3(is+2,js ,ks) - $ + f7*f4 * src3(is+3,js ,ks) - $ + f8*f4 * src3(is+4,js ,ks) - $ + f1*f5 * src3(is-3,js+1,ks) - $ + f2*f5 * src3(is-2,js+1,ks) - $ + f3*f5 * src3(is-1,js+1,ks) - $ + f4*f5 * src3(is ,js+1,ks) - $ + f5*f5 * src3(is+1,js+1,ks) - $ + f6*f5 * src3(is+2,js+1,ks) - $ + f7*f5 * src3(is+3,js+1,ks) - $ + f8*f5 * src3(is+4,js+1,ks) - $ + f1*f6 * src3(is-3,js+2,ks) - $ + f2*f6 * src3(is-2,js+2,ks) - $ + f3*f6 * src3(is-1,js+2,ks) - $ + f4*f6 * src3(is ,js+2,ks) - $ + f5*f6 * src3(is+1,js+2,ks) - $ + f6*f6 * src3(is+2,js+2,ks) - $ + f7*f6 * src3(is+3,js+2,ks) - $ + f8*f6 * src3(is+4,js+2,ks) - $ + f1*f7 * src3(is-3,js+3,ks) - $ + f2*f7 * src3(is-2,js+3,ks) - $ + f3*f7 * src3(is-1,js+3,ks) - $ + f4*f7 * src3(is ,js+3,ks) - $ + f5*f7 * src3(is+1,js+3,ks) - $ + f6*f7 * src3(is+2,js+3,ks) - $ + f7*f7 * src3(is+3,js+3,ks) - $ + f8*f7 * src3(is+4,js+3,ks) - $ + f1*f8 * src3(is-3,js+4,ks) - $ + f2*f8 * src3(is-2,js+4,ks) - $ + f3*f8 * src3(is-1,js+4,ks) - $ + f4*f8 * src3(is ,js+4,ks) - $ + f5*f8 * src3(is+1,js+4,ks) - $ + f6*f8 * src3(is+2,js+4,ks) - $ + f7*f8 * src3(is+3,js+4,ks) - $ + f8*f8 * src3(is+4,js+4,ks) - dst(id,jd,kd) = s1fac * res1 + s2fac * res2 + s3fac * res3 - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8010 - goto 901 - -c end i loop - 901 continue - j = j+1 - jd = jd+1 - js = js+1 - if (j.lt.regjext) goto 800 - goto 90 - -c end j loop - 90 continue - k = k+1 - kd = kd+1 - if (k.lt.regkext) goto 81 - goto 9 - -c begin j loop - 81 continue - j = 0 - js = j0+1 - jd = dstjoff+1 - if (fj.eq.0) goto 810 - if (fj.eq.1) goto 811 - stop - -c begin i loop - 810 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8100 - if (fi.eq.1) goto 8101 - stop - -c kernel - 8100 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js,ks-3, 1,1,8, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + f1 * s1fac * src1(is,js,ks-3) - $ + f2 * s1fac * src1(is,js,ks-2) - $ + f3 * s1fac * src1(is,js,ks-1) - $ + f4 * s1fac * src1(is,js,ks ) - $ + f5 * s1fac * src1(is,js,ks+1) - $ + f6 * s1fac * src1(is,js,ks+2) - $ + f7 * s1fac * src1(is,js,ks+3) - $ + f8 * s1fac * src1(is,js,ks+4) - $ + f1 * s2fac * src2(is,js,ks-3) - $ + f2 * s2fac * src2(is,js,ks-2) - $ + f3 * s2fac * src2(is,js,ks-1) - $ + f4 * s2fac * src2(is,js,ks ) - $ + f5 * s2fac * src2(is,js,ks+1) - $ + f6 * s2fac * src2(is,js,ks+2) - $ + f7 * s2fac * src2(is,js,ks+3) - $ + f8 * s2fac * src2(is,js,ks+4) - $ + f1 * s3fac * src3(is,js,ks-3) - $ + f2 * s3fac * src3(is,js,ks-2) - $ + f3 * s3fac * src3(is,js,ks-1) - $ + f4 * s3fac * src3(is,js,ks ) - $ + f5 * s3fac * src3(is,js,ks+1) - $ + f6 * s3fac * src3(is,js,ks+2) - $ + f7 * s3fac * src3(is,js,ks+3) - $ + f8 * s3fac * src3(is,js,ks+4) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8101 - goto 910 - -c kernel - 8101 continue - if (check_array_accesses.ne.0) then - call checkindex (is-3,js,ks-3, 8,1,8, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - res1 = - $ + f1*f1 * src1(is-3,js,ks-3) - $ + f2*f1 * src1(is-2,js,ks-3) - $ + f3*f1 * src1(is-1,js,ks-3) - $ + f4*f1 * src1(is ,js,ks-3) - $ + f5*f1 * src1(is+1,js,ks-3) - $ + f6*f1 * src1(is+2,js,ks-3) - $ + f7*f1 * src1(is+3,js,ks-3) - $ + f8*f1 * src1(is+4,js,ks-3) - $ + f1*f2 * src1(is-3,js,ks-2) - $ + f2*f2 * src1(is-2,js,ks-2) - $ + f3*f2 * src1(is-1,js,ks-2) - $ + f4*f2 * src1(is ,js,ks-2) - $ + f5*f2 * src1(is+1,js,ks-2) - $ + f6*f2 * src1(is+2,js,ks-2) - $ + f7*f2 * src1(is+3,js,ks-2) - $ + f8*f2 * src1(is+4,js,ks-2) - $ + f1*f3 * src1(is-3,js,ks-1) - $ + f2*f3 * src1(is-2,js,ks-1) - $ + f3*f3 * src1(is-1,js,ks-1) - $ + f4*f3 * src1(is ,js,ks-1) - $ + f5*f3 * src1(is+1,js,ks-1) - $ + f6*f3 * src1(is+2,js,ks-1) - $ + f7*f3 * src1(is+3,js,ks-1) - $ + f8*f3 * src1(is+4,js,ks-1) - $ + f1*f4 * src1(is-3,js,ks ) - $ + f2*f4 * src1(is-2,js,ks ) - $ + f3*f4 * src1(is-1,js,ks ) - $ + f4*f4 * src1(is ,js,ks ) - $ + f5*f4 * src1(is+1,js,ks ) - $ + f6*f4 * src1(is+2,js,ks ) - $ + f7*f4 * src1(is+3,js,ks ) - $ + f8*f4 * src1(is+4,js,ks ) - $ + f1*f5 * src1(is-3,js,ks+1) - $ + f2*f5 * src1(is-2,js,ks+1) - $ + f3*f5 * src1(is-1,js,ks+1) - $ + f4*f5 * src1(is ,js,ks+1) - $ + f5*f5 * src1(is+1,js,ks+1) - $ + f6*f5 * src1(is+2,js,ks+1) - $ + f7*f5 * src1(is+3,js,ks+1) - $ + f8*f5 * src1(is+4,js,ks+1) - $ + f1*f6 * src1(is-3,js,ks+2) - $ + f2*f6 * src1(is-2,js,ks+2) - $ + f3*f6 * src1(is-1,js,ks+2) - $ + f4*f6 * src1(is ,js,ks+2) - $ + f5*f6 * src1(is+1,js,ks+2) - $ + f6*f6 * src1(is+2,js,ks+2) - $ + f7*f6 * src1(is+3,js,ks+2) - $ + f8*f6 * src1(is+4,js,ks+2) - $ + f1*f7 * src1(is-3,js,ks+3) - $ + f2*f7 * src1(is-2,js,ks+3) - $ + f3*f7 * src1(is-1,js,ks+3) - $ + f4*f7 * src1(is ,js,ks+3) - $ + f5*f7 * src1(is+1,js,ks+3) - $ + f6*f7 * src1(is+2,js,ks+3) - $ + f7*f7 * src1(is+3,js,ks+3) - $ + f8*f7 * src1(is+4,js,ks+3) - $ + f1*f8 * src1(is-3,js,ks+4) - $ + f2*f8 * src1(is-2,js,ks+4) - $ + f3*f8 * src1(is-1,js,ks+4) - $ + f4*f8 * src1(is ,js,ks+4) - $ + f5*f8 * src1(is+1,js,ks+4) - $ + f6*f8 * src1(is+2,js,ks+4) - $ + f7*f8 * src1(is+3,js,ks+4) - $ + f8*f8 * src1(is+4,js,ks+4) - res2 = - $ + f1*f1 * src2(is-3,js,ks-3) - $ + f2*f1 * src2(is-2,js,ks-3) - $ + f3*f1 * src2(is-1,js,ks-3) - $ + f4*f1 * src2(is ,js,ks-3) - $ + f5*f1 * src2(is+1,js,ks-3) - $ + f6*f1 * src2(is+2,js,ks-3) - $ + f7*f1 * src2(is+3,js,ks-3) - $ + f8*f1 * src2(is+4,js,ks-3) - $ + f1*f2 * src2(is-3,js,ks-2) - $ + f2*f2 * src2(is-2,js,ks-2) - $ + f3*f2 * src2(is-1,js,ks-2) - $ + f4*f2 * src2(is ,js,ks-2) - $ + f5*f2 * src2(is+1,js,ks-2) - $ + f6*f2 * src2(is+2,js,ks-2) - $ + f7*f2 * src2(is+3,js,ks-2) - $ + f8*f2 * src2(is+4,js,ks-2) - $ + f1*f3 * src2(is-3,js,ks-1) - $ + f2*f3 * src2(is-2,js,ks-1) - $ + f3*f3 * src2(is-1,js,ks-1) - $ + f4*f3 * src2(is ,js,ks-1) - $ + f5*f3 * src2(is+1,js,ks-1) - $ + f6*f3 * src2(is+2,js,ks-1) - $ + f7*f3 * src2(is+3,js,ks-1) - $ + f8*f3 * src2(is+4,js,ks-1) - $ + f1*f4 * src2(is-3,js,ks ) - $ + f2*f4 * src2(is-2,js,ks ) - $ + f3*f4 * src2(is-1,js,ks ) - $ + f4*f4 * src2(is ,js,ks ) - $ + f5*f4 * src2(is+1,js,ks ) - $ + f6*f4 * src2(is+2,js,ks ) - $ + f7*f4 * src2(is+3,js,ks ) - $ + f8*f4 * src2(is+4,js,ks ) - $ + f1*f5 * src2(is-3,js,ks+1) - $ + f2*f5 * src2(is-2,js,ks+1) - $ + f3*f5 * src2(is-1,js,ks+1) - $ + f4*f5 * src2(is ,js,ks+1) - $ + f5*f5 * src2(is+1,js,ks+1) - $ + f6*f5 * src2(is+2,js,ks+1) - $ + f7*f5 * src2(is+3,js,ks+1) - $ + f8*f5 * src2(is+4,js,ks+1) - $ + f1*f6 * src2(is-3,js,ks+2) - $ + f2*f6 * src2(is-2,js,ks+2) - $ + f3*f6 * src2(is-1,js,ks+2) - $ + f4*f6 * src2(is ,js,ks+2) - $ + f5*f6 * src2(is+1,js,ks+2) - $ + f6*f6 * src2(is+2,js,ks+2) - $ + f7*f6 * src2(is+3,js,ks+2) - $ + f8*f6 * src2(is+4,js,ks+2) - $ + f1*f7 * src2(is-3,js,ks+3) - $ + f2*f7 * src2(is-2,js,ks+3) - $ + f3*f7 * src2(is-1,js,ks+3) - $ + f4*f7 * src2(is ,js,ks+3) - $ + f5*f7 * src2(is+1,js,ks+3) - $ + f6*f7 * src2(is+2,js,ks+3) - $ + f7*f7 * src2(is+3,js,ks+3) - $ + f8*f7 * src2(is+4,js,ks+3) - $ + f1*f8 * src2(is-3,js,ks+4) - $ + f2*f8 * src2(is-2,js,ks+4) - $ + f3*f8 * src2(is-1,js,ks+4) - $ + f4*f8 * src2(is ,js,ks+4) - $ + f5*f8 * src2(is+1,js,ks+4) - $ + f6*f8 * src2(is+2,js,ks+4) - $ + f7*f8 * src2(is+3,js,ks+4) - $ + f8*f8 * src2(is+4,js,ks+4) - res3 = - $ + f1*f1 * src3(is-3,js,ks-3) - $ + f2*f1 * src3(is-2,js,ks-3) - $ + f3*f1 * src3(is-1,js,ks-3) - $ + f4*f1 * src3(is ,js,ks-3) - $ + f5*f1 * src3(is+1,js,ks-3) - $ + f6*f1 * src3(is+2,js,ks-3) - $ + f7*f1 * src3(is+3,js,ks-3) - $ + f8*f1 * src3(is+4,js,ks-3) - $ + f1*f2 * src3(is-3,js,ks-2) - $ + f2*f2 * src3(is-2,js,ks-2) - $ + f3*f2 * src3(is-1,js,ks-2) - $ + f4*f2 * src3(is ,js,ks-2) - $ + f5*f2 * src3(is+1,js,ks-2) - $ + f6*f2 * src3(is+2,js,ks-2) - $ + f7*f2 * src3(is+3,js,ks-2) - $ + f8*f2 * src3(is+4,js,ks-2) - $ + f1*f3 * src3(is-3,js,ks-1) - $ + f2*f3 * src3(is-2,js,ks-1) - $ + f3*f3 * src3(is-1,js,ks-1) - $ + f4*f3 * src3(is ,js,ks-1) - $ + f5*f3 * src3(is+1,js,ks-1) - $ + f6*f3 * src3(is+2,js,ks-1) - $ + f7*f3 * src3(is+3,js,ks-1) - $ + f8*f3 * src3(is+4,js,ks-1) - $ + f1*f4 * src3(is-3,js,ks ) - $ + f2*f4 * src3(is-2,js,ks ) - $ + f3*f4 * src3(is-1,js,ks ) - $ + f4*f4 * src3(is ,js,ks ) - $ + f5*f4 * src3(is+1,js,ks ) - $ + f6*f4 * src3(is+2,js,ks ) - $ + f7*f4 * src3(is+3,js,ks ) - $ + f8*f4 * src3(is+4,js,ks ) - $ + f1*f5 * src3(is-3,js,ks+1) - $ + f2*f5 * src3(is-2,js,ks+1) - $ + f3*f5 * src3(is-1,js,ks+1) - $ + f4*f5 * src3(is ,js,ks+1) - $ + f5*f5 * src3(is+1,js,ks+1) - $ + f6*f5 * src3(is+2,js,ks+1) - $ + f7*f5 * src3(is+3,js,ks+1) - $ + f8*f5 * src3(is+4,js,ks+1) - $ + f1*f6 * src3(is-3,js,ks+2) - $ + f2*f6 * src3(is-2,js,ks+2) - $ + f3*f6 * src3(is-1,js,ks+2) - $ + f4*f6 * src3(is ,js,ks+2) - $ + f5*f6 * src3(is+1,js,ks+2) - $ + f6*f6 * src3(is+2,js,ks+2) - $ + f7*f6 * src3(is+3,js,ks+2) - $ + f8*f6 * src3(is+4,js,ks+2) - $ + f1*f7 * src3(is-3,js,ks+3) - $ + f2*f7 * src3(is-2,js,ks+3) - $ + f3*f7 * src3(is-1,js,ks+3) - $ + f4*f7 * src3(is ,js,ks+3) - $ + f5*f7 * src3(is+1,js,ks+3) - $ + f6*f7 * src3(is+2,js,ks+3) - $ + f7*f7 * src3(is+3,js,ks+3) - $ + f8*f7 * src3(is+4,js,ks+3) - $ + f1*f8 * src3(is-3,js,ks+4) - $ + f2*f8 * src3(is-2,js,ks+4) - $ + f3*f8 * src3(is-1,js,ks+4) - $ + f4*f8 * src3(is ,js,ks+4) - $ + f5*f8 * src3(is+1,js,ks+4) - $ + f6*f8 * src3(is+2,js,ks+4) - $ + f7*f8 * src3(is+3,js,ks+4) - $ + f8*f8 * src3(is+4,js,ks+4) - dst(id,jd,kd) = s1fac * res1 + s2fac * res2 + s3fac * res3 - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8100 - goto 910 - -c end i loop - 910 continue - j = j+1 - jd = jd+1 - if (j.lt.regjext) goto 811 - goto 91 - -c begin i loop - 811 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8110 - if (fi.eq.1) goto 8111 - stop - -c kernel - 8110 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js-3,ks-3, 1,8,8, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - res1 = - $ + f1*f1 * src1(is,js-3,ks-3) - $ + f2*f1 * src1(is,js-2,ks-3) - $ + f3*f1 * src1(is,js-1,ks-3) - $ + f4*f1 * src1(is,js ,ks-3) - $ + f5*f1 * src1(is,js+1,ks-3) - $ + f6*f1 * src1(is,js+2,ks-3) - $ + f7*f1 * src1(is,js+3,ks-3) - $ + f8*f1 * src1(is,js+4,ks-3) - $ + f1*f2 * src1(is,js-3,ks-2) - $ + f2*f2 * src1(is,js-2,ks-2) - $ + f3*f2 * src1(is,js-1,ks-2) - $ + f4*f2 * src1(is,js ,ks-2) - $ + f5*f2 * src1(is,js+1,ks-2) - $ + f6*f2 * src1(is,js+2,ks-2) - $ + f7*f2 * src1(is,js+3,ks-2) - $ + f8*f2 * src1(is,js+4,ks-2) - $ + f1*f3 * src1(is,js-3,ks-1) - $ + f2*f3 * src1(is,js-2,ks-1) - $ + f3*f3 * src1(is,js-1,ks-1) - $ + f4*f3 * src1(is,js ,ks-1) - $ + f5*f3 * src1(is,js+1,ks-1) - $ + f6*f3 * src1(is,js+2,ks-1) - $ + f7*f3 * src1(is,js+3,ks-1) - $ + f8*f3 * src1(is,js+4,ks-1) - $ + f1*f4 * src1(is,js-3,ks ) - $ + f2*f4 * src1(is,js-2,ks ) - $ + f3*f4 * src1(is,js-1,ks ) - $ + f4*f4 * src1(is,js ,ks ) - $ + f5*f4 * src1(is,js+1,ks ) - $ + f6*f4 * src1(is,js+2,ks ) - $ + f7*f4 * src1(is,js+3,ks ) - $ + f8*f4 * src1(is,js+4,ks ) - $ + f1*f5 * src1(is,js-3,ks+1) - $ + f2*f5 * src1(is,js-2,ks+1) - $ + f3*f5 * src1(is,js-1,ks+1) - $ + f4*f5 * src1(is,js ,ks+1) - $ + f5*f5 * src1(is,js+1,ks+1) - $ + f6*f5 * src1(is,js+2,ks+1) - $ + f7*f5 * src1(is,js+3,ks+1) - $ + f8*f5 * src1(is,js+4,ks+1) - $ + f1*f6 * src1(is,js-3,ks+2) - $ + f2*f6 * src1(is,js-2,ks+2) - $ + f3*f6 * src1(is,js-1,ks+2) - $ + f4*f6 * src1(is,js ,ks+2) - $ + f5*f6 * src1(is,js+1,ks+2) - $ + f6*f6 * src1(is,js+2,ks+2) - $ + f7*f6 * src1(is,js+3,ks+2) - $ + f8*f6 * src1(is,js+4,ks+2) - $ + f1*f7 * src1(is,js-3,ks+3) - $ + f2*f7 * src1(is,js-2,ks+3) - $ + f3*f7 * src1(is,js-1,ks+3) - $ + f4*f7 * src1(is,js ,ks+3) - $ + f5*f7 * src1(is,js+1,ks+3) - $ + f6*f7 * src1(is,js+2,ks+3) - $ + f7*f7 * src1(is,js+3,ks+3) - $ + f8*f7 * src1(is,js+4,ks+3) - $ + f1*f8 * src1(is,js-3,ks+4) - $ + f2*f8 * src1(is,js-2,ks+4) - $ + f3*f8 * src1(is,js-1,ks+4) - $ + f4*f8 * src1(is,js ,ks+4) - $ + f5*f8 * src1(is,js+1,ks+4) - $ + f6*f8 * src1(is,js+2,ks+4) - $ + f7*f8 * src1(is,js+3,ks+4) - $ + f8*f8 * src1(is,js+4,ks+4) - res2 = - $ + f1*f1 * src2(is,js-3,ks-3) - $ + f2*f1 * src2(is,js-2,ks-3) - $ + f3*f1 * src2(is,js-1,ks-3) - $ + f4*f1 * src2(is,js ,ks-3) - $ + f5*f1 * src2(is,js+1,ks-3) - $ + f6*f1 * src2(is,js+2,ks-3) - $ + f7*f1 * src2(is,js+3,ks-3) - $ + f8*f1 * src2(is,js+4,ks-3) - $ + f1*f2 * src2(is,js-3,ks-2) - $ + f2*f2 * src2(is,js-2,ks-2) - $ + f3*f2 * src2(is,js-1,ks-2) - $ + f4*f2 * src2(is,js ,ks-2) - $ + f5*f2 * src2(is,js+1,ks-2) - $ + f6*f2 * src2(is,js+2,ks-2) - $ + f7*f2 * src2(is,js+3,ks-2) - $ + f8*f2 * src2(is,js+4,ks-2) - $ + f1*f3 * src2(is,js-3,ks-1) - $ + f2*f3 * src2(is,js-2,ks-1) - $ + f3*f3 * src2(is,js-1,ks-1) - $ + f4*f3 * src2(is,js ,ks-1) - $ + f5*f3 * src2(is,js+1,ks-1) - $ + f6*f3 * src2(is,js+2,ks-1) - $ + f7*f3 * src2(is,js+3,ks-1) - $ + f8*f3 * src2(is,js+4,ks-1) - $ + f1*f4 * src2(is,js-3,ks ) - $ + f2*f4 * src2(is,js-2,ks ) - $ + f3*f4 * src2(is,js-1,ks ) - $ + f4*f4 * src2(is,js ,ks ) - $ + f5*f4 * src2(is,js+1,ks ) - $ + f6*f4 * src2(is,js+2,ks ) - $ + f7*f4 * src2(is,js+3,ks ) - $ + f8*f4 * src2(is,js+4,ks ) - $ + f1*f5 * src2(is,js-3,ks+1) - $ + f2*f5 * src2(is,js-2,ks+1) - $ + f3*f5 * src2(is,js-1,ks+1) - $ + f4*f5 * src2(is,js ,ks+1) - $ + f5*f5 * src2(is,js+1,ks+1) - $ + f6*f5 * src2(is,js+2,ks+1) - $ + f7*f5 * src2(is,js+3,ks+1) - $ + f8*f5 * src2(is,js+4,ks+1) - $ + f1*f6 * src2(is,js-3,ks+2) - $ + f2*f6 * src2(is,js-2,ks+2) - $ + f3*f6 * src2(is,js-1,ks+2) - $ + f4*f6 * src2(is,js ,ks+2) - $ + f5*f6 * src2(is,js+1,ks+2) - $ + f6*f6 * src2(is,js+2,ks+2) - $ + f7*f6 * src2(is,js+3,ks+2) - $ + f8*f6 * src2(is,js+4,ks+2) - $ + f1*f7 * src2(is,js-3,ks+3) - $ + f2*f7 * src2(is,js-2,ks+3) - $ + f3*f7 * src2(is,js-1,ks+3) - $ + f4*f7 * src2(is,js ,ks+3) - $ + f5*f7 * src2(is,js+1,ks+3) - $ + f6*f7 * src2(is,js+2,ks+3) - $ + f7*f7 * src2(is,js+3,ks+3) - $ + f8*f7 * src2(is,js+4,ks+3) - $ + f1*f8 * src2(is,js-3,ks+4) - $ + f2*f8 * src2(is,js-2,ks+4) - $ + f3*f8 * src2(is,js-1,ks+4) - $ + f4*f8 * src2(is,js ,ks+4) - $ + f5*f8 * src2(is,js+1,ks+4) - $ + f6*f8 * src2(is,js+2,ks+4) - $ + f7*f8 * src2(is,js+3,ks+4) - $ + f8*f8 * src2(is,js+4,ks+4) - res3 = - $ + f1*f1 * src3(is,js-3,ks-3) - $ + f2*f1 * src3(is,js-2,ks-3) - $ + f3*f1 * src3(is,js-1,ks-3) - $ + f4*f1 * src3(is,js ,ks-3) - $ + f5*f1 * src3(is,js+1,ks-3) - $ + f6*f1 * src3(is,js+2,ks-3) - $ + f7*f1 * src3(is,js+3,ks-3) - $ + f8*f1 * src3(is,js+4,ks-3) - $ + f1*f2 * src3(is,js-3,ks-2) - $ + f2*f2 * src3(is,js-2,ks-2) - $ + f3*f2 * src3(is,js-1,ks-2) - $ + f4*f2 * src3(is,js ,ks-2) - $ + f5*f2 * src3(is,js+1,ks-2) - $ + f6*f2 * src3(is,js+2,ks-2) - $ + f7*f2 * src3(is,js+3,ks-2) - $ + f8*f2 * src3(is,js+4,ks-2) - $ + f1*f3 * src3(is,js-3,ks-1) - $ + f2*f3 * src3(is,js-2,ks-1) - $ + f3*f3 * src3(is,js-1,ks-1) - $ + f4*f3 * src3(is,js ,ks-1) - $ + f5*f3 * src3(is,js+1,ks-1) - $ + f6*f3 * src3(is,js+2,ks-1) - $ + f7*f3 * src3(is,js+3,ks-1) - $ + f8*f3 * src3(is,js+4,ks-1) - $ + f1*f4 * src3(is,js-3,ks ) - $ + f2*f4 * src3(is,js-2,ks ) - $ + f3*f4 * src3(is,js-1,ks ) - $ + f4*f4 * src3(is,js ,ks ) - $ + f5*f4 * src3(is,js+1,ks ) - $ + f6*f4 * src3(is,js+2,ks ) - $ + f7*f4 * src3(is,js+3,ks ) - $ + f8*f4 * src3(is,js+4,ks ) - $ + f1*f5 * src3(is,js-3,ks+1) - $ + f2*f5 * src3(is,js-2,ks+1) - $ + f3*f5 * src3(is,js-1,ks+1) - $ + f4*f5 * src3(is,js ,ks+1) - $ + f5*f5 * src3(is,js+1,ks+1) - $ + f6*f5 * src3(is,js+2,ks+1) - $ + f7*f5 * src3(is,js+3,ks+1) - $ + f8*f5 * src3(is,js+4,ks+1) - $ + f1*f6 * src3(is,js-3,ks+2) - $ + f2*f6 * src3(is,js-2,ks+2) - $ + f3*f6 * src3(is,js-1,ks+2) - $ + f4*f6 * src3(is,js ,ks+2) - $ + f5*f6 * src3(is,js+1,ks+2) - $ + f6*f6 * src3(is,js+2,ks+2) - $ + f7*f6 * src3(is,js+3,ks+2) - $ + f8*f6 * src3(is,js+4,ks+2) - $ + f1*f7 * src3(is,js-3,ks+3) - $ + f2*f7 * src3(is,js-2,ks+3) - $ + f3*f7 * src3(is,js-1,ks+3) - $ + f4*f7 * src3(is,js ,ks+3) - $ + f5*f7 * src3(is,js+1,ks+3) - $ + f6*f7 * src3(is,js+2,ks+3) - $ + f7*f7 * src3(is,js+3,ks+3) - $ + f8*f7 * src3(is,js+4,ks+3) - $ + f1*f8 * src3(is,js-3,ks+4) - $ + f2*f8 * src3(is,js-2,ks+4) - $ + f3*f8 * src3(is,js-1,ks+4) - $ + f4*f8 * src3(is,js ,ks+4) - $ + f5*f8 * src3(is,js+1,ks+4) - $ + f6*f8 * src3(is,js+2,ks+4) - $ + f7*f8 * src3(is,js+3,ks+4) - $ + f8*f8 * src3(is,js+4,ks+4) - dst(id,jd,kd) = s1fac * res1 + s2fac * res2 + s3fac * res3 - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8111 - goto 911 - -c kernel - 8111 continue - if (check_array_accesses.ne.0) then - call checkindex (is-3,js-3,ks-3, 8,8,8, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - res11 = - $ + f1*f1*f1 * src1(is-3,js-3,ks-3) - $ + f2*f1*f1 * src1(is-2,js-3,ks-3) - $ + f3*f1*f1 * src1(is-1,js-3,ks-3) - $ + f4*f1*f1 * src1(is ,js-3,ks-3) - $ + f5*f1*f1 * src1(is+1,js-3,ks-3) - $ + f6*f1*f1 * src1(is+2,js-3,ks-3) - $ + f7*f1*f1 * src1(is+3,js-3,ks-3) - $ + f8*f1*f1 * src1(is+4,js-3,ks-3) - $ + f1*f2*f1 * src1(is-3,js-2,ks-3) - $ + f2*f2*f1 * src1(is-2,js-2,ks-3) - $ + f3*f2*f1 * src1(is-1,js-2,ks-3) - $ + f4*f2*f1 * src1(is ,js-2,ks-3) - $ + f5*f2*f1 * src1(is+1,js-2,ks-3) - $ + f6*f2*f1 * src1(is+2,js-2,ks-3) - $ + f7*f2*f1 * src1(is+3,js-2,ks-3) - $ + f8*f2*f1 * src1(is+4,js-2,ks-3) - $ + f1*f3*f1 * src1(is-3,js-1,ks-3) - $ + f2*f3*f1 * src1(is-2,js-1,ks-3) - $ + f3*f3*f1 * src1(is-1,js-1,ks-3) - $ + f4*f3*f1 * src1(is ,js-1,ks-3) - $ + f5*f3*f1 * src1(is+1,js-1,ks-3) - $ + f6*f3*f1 * src1(is+2,js-1,ks-3) - $ + f7*f3*f1 * src1(is+3,js-1,ks-3) - $ + f8*f3*f1 * src1(is+4,js-1,ks-3) - $ + f1*f4*f1 * src1(is-3,js ,ks-3) - $ + f2*f4*f1 * src1(is-2,js ,ks-3) - $ + f3*f4*f1 * src1(is-1,js ,ks-3) - $ + f4*f4*f1 * src1(is ,js ,ks-3) - $ + f5*f4*f1 * src1(is+1,js ,ks-3) - $ + f6*f4*f1 * src1(is+2,js ,ks-3) - $ + f7*f4*f1 * src1(is+3,js ,ks-3) - $ + f8*f4*f1 * src1(is+4,js ,ks-3) - $ + f1*f5*f1 * src1(is-3,js+1,ks-3) - $ + f2*f5*f1 * src1(is-2,js+1,ks-3) - $ + f3*f5*f1 * src1(is-1,js+1,ks-3) - $ + f4*f5*f1 * src1(is ,js+1,ks-3) - $ + f5*f5*f1 * src1(is+1,js+1,ks-3) - $ + f6*f5*f1 * src1(is+2,js+1,ks-3) - $ + f7*f5*f1 * src1(is+3,js+1,ks-3) - $ + f8*f5*f1 * src1(is+4,js+1,ks-3) - $ + f1*f6*f1 * src1(is-3,js+2,ks-3) - $ + f2*f6*f1 * src1(is-2,js+2,ks-3) - $ + f3*f6*f1 * src1(is-1,js+2,ks-3) - $ + f4*f6*f1 * src1(is ,js+2,ks-3) - $ + f5*f6*f1 * src1(is+1,js+2,ks-3) - $ + f6*f6*f1 * src1(is+2,js+2,ks-3) - $ + f7*f6*f1 * src1(is+3,js+2,ks-3) - $ + f8*f6*f1 * src1(is+4,js+2,ks-3) - $ + f1*f7*f1 * src1(is-3,js+3,ks-3) - $ + f2*f7*f1 * src1(is-2,js+3,ks-3) - $ + f3*f7*f1 * src1(is-1,js+3,ks-3) - $ + f4*f7*f1 * src1(is ,js+3,ks-3) - $ + f5*f7*f1 * src1(is+1,js+3,ks-3) - $ + f6*f7*f1 * src1(is+2,js+3,ks-3) - $ + f7*f7*f1 * src1(is+3,js+3,ks-3) - $ + f8*f7*f1 * src1(is+4,js+3,ks-3) - $ + f1*f8*f1 * src1(is-3,js+4,ks-3) - $ + f2*f8*f1 * src1(is-2,js+4,ks-3) - $ + f3*f8*f1 * src1(is-1,js+4,ks-3) - $ + f4*f8*f1 * src1(is ,js+4,ks-3) - $ + f5*f8*f1 * src1(is+1,js+4,ks-3) - $ + f6*f8*f1 * src1(is+2,js+4,ks-3) - $ + f7*f8*f1 * src1(is+3,js+4,ks-3) - $ + f8*f8*f1 * src1(is+4,js+4,ks-3) - res12 = - $ + f1*f1*f2 * src1(is-3,js-3,ks-2) - $ + f2*f1*f2 * src1(is-2,js-3,ks-2) - $ + f3*f1*f2 * src1(is-1,js-3,ks-2) - $ + f4*f1*f2 * src1(is ,js-3,ks-2) - $ + f5*f1*f2 * src1(is+1,js-3,ks-2) - $ + f6*f1*f2 * src1(is+2,js-3,ks-2) - $ + f7*f1*f2 * src1(is+3,js-3,ks-2) - $ + f8*f1*f2 * src1(is+4,js-3,ks-2) - $ + f1*f2*f2 * src1(is-3,js-2,ks-2) - $ + f2*f2*f2 * src1(is-2,js-2,ks-2) - $ + f3*f2*f2 * src1(is-1,js-2,ks-2) - $ + f4*f2*f2 * src1(is ,js-2,ks-2) - $ + f5*f2*f2 * src1(is+1,js-2,ks-2) - $ + f6*f2*f2 * src1(is+2,js-2,ks-2) - $ + f7*f2*f2 * src1(is+3,js-2,ks-2) - $ + f8*f2*f2 * src1(is+4,js-2,ks-2) - $ + f1*f3*f2 * src1(is-3,js-1,ks-2) - $ + f2*f3*f2 * src1(is-2,js-1,ks-2) - $ + f3*f3*f2 * src1(is-1,js-1,ks-2) - $ + f4*f3*f2 * src1(is ,js-1,ks-2) - $ + f5*f3*f2 * src1(is+1,js-1,ks-2) - $ + f6*f3*f2 * src1(is+2,js-1,ks-2) - $ + f7*f3*f2 * src1(is+3,js-1,ks-2) - $ + f8*f3*f2 * src1(is+4,js-1,ks-2) - $ + f1*f4*f2 * src1(is-3,js ,ks-2) - $ + f2*f4*f2 * src1(is-2,js ,ks-2) - $ + f3*f4*f2 * src1(is-1,js ,ks-2) - $ + f4*f4*f2 * src1(is ,js ,ks-2) - $ + f5*f4*f2 * src1(is+1,js ,ks-2) - $ + f6*f4*f2 * src1(is+2,js ,ks-2) - $ + f7*f4*f2 * src1(is+3,js ,ks-2) - $ + f8*f4*f2 * src1(is+4,js ,ks-2) - $ + f1*f5*f2 * src1(is-3,js+1,ks-2) - $ + f2*f5*f2 * src1(is-2,js+1,ks-2) - $ + f3*f5*f2 * src1(is-1,js+1,ks-2) - $ + f4*f5*f2 * src1(is ,js+1,ks-2) - $ + f5*f5*f2 * src1(is+1,js+1,ks-2) - $ + f6*f5*f2 * src1(is+2,js+1,ks-2) - $ + f7*f5*f2 * src1(is+3,js+1,ks-2) - $ + f8*f5*f2 * src1(is+4,js+1,ks-2) - $ + f1*f6*f2 * src1(is-3,js+2,ks-2) - $ + f2*f6*f2 * src1(is-2,js+2,ks-2) - $ + f3*f6*f2 * src1(is-1,js+2,ks-2) - $ + f4*f6*f2 * src1(is ,js+2,ks-2) - $ + f5*f6*f2 * src1(is+1,js+2,ks-2) - $ + f6*f6*f2 * src1(is+2,js+2,ks-2) - $ + f7*f6*f2 * src1(is+3,js+2,ks-2) - $ + f8*f6*f2 * src1(is+4,js+2,ks-2) - $ + f1*f7*f2 * src1(is-3,js+3,ks-2) - $ + f2*f7*f2 * src1(is-2,js+3,ks-2) - $ + f3*f7*f2 * src1(is-1,js+3,ks-2) - $ + f4*f7*f2 * src1(is ,js+3,ks-2) - $ + f5*f7*f2 * src1(is+1,js+3,ks-2) - $ + f6*f7*f2 * src1(is+2,js+3,ks-2) - $ + f7*f7*f2 * src1(is+3,js+3,ks-2) - $ + f8*f7*f2 * src1(is+4,js+3,ks-2) - $ + f1*f8*f2 * src1(is-3,js+4,ks-2) - $ + f2*f8*f2 * src1(is-2,js+4,ks-2) - $ + f3*f8*f2 * src1(is-1,js+4,ks-2) - $ + f4*f8*f2 * src1(is ,js+4,ks-2) - $ + f5*f8*f2 * src1(is+1,js+4,ks-2) - $ + f6*f8*f2 * src1(is+2,js+4,ks-2) - $ + f7*f8*f2 * src1(is+3,js+4,ks-2) - $ + f8*f8*f2 * src1(is+4,js+4,ks-2) - res13 = - $ + f1*f1*f3 * src1(is-3,js-3,ks-1) - $ + f2*f1*f3 * src1(is-2,js-3,ks-1) - $ + f3*f1*f3 * src1(is-1,js-3,ks-1) - $ + f4*f1*f3 * src1(is ,js-3,ks-1) - $ + f5*f1*f3 * src1(is+1,js-3,ks-1) - $ + f6*f1*f3 * src1(is+2,js-3,ks-1) - $ + f7*f1*f3 * src1(is+3,js-3,ks-1) - $ + f8*f1*f3 * src1(is+4,js-3,ks-1) - $ + f1*f2*f3 * src1(is-3,js-2,ks-1) - $ + f2*f2*f3 * src1(is-2,js-2,ks-1) - $ + f3*f2*f3 * src1(is-1,js-2,ks-1) - $ + f4*f2*f3 * src1(is ,js-2,ks-1) - $ + f5*f2*f3 * src1(is+1,js-2,ks-1) - $ + f6*f2*f3 * src1(is+2,js-2,ks-1) - $ + f7*f2*f3 * src1(is+3,js-2,ks-1) - $ + f8*f2*f3 * src1(is+4,js-2,ks-1) - $ + f1*f3*f3 * src1(is-3,js-1,ks-1) - $ + f2*f3*f3 * src1(is-2,js-1,ks-1) - $ + f3*f3*f3 * src1(is-1,js-1,ks-1) - $ + f4*f3*f3 * src1(is ,js-1,ks-1) - $ + f5*f3*f3 * src1(is+1,js-1,ks-1) - $ + f6*f3*f3 * src1(is+2,js-1,ks-1) - $ + f7*f3*f3 * src1(is+3,js-1,ks-1) - $ + f8*f3*f3 * src1(is+4,js-1,ks-1) - $ + f1*f4*f3 * src1(is-3,js ,ks-1) - $ + f2*f4*f3 * src1(is-2,js ,ks-1) - $ + f3*f4*f3 * src1(is-1,js ,ks-1) - $ + f4*f4*f3 * src1(is ,js ,ks-1) - $ + f5*f4*f3 * src1(is+1,js ,ks-1) - $ + f6*f4*f3 * src1(is+2,js ,ks-1) - $ + f7*f4*f3 * src1(is+3,js ,ks-1) - $ + f8*f4*f3 * src1(is+4,js ,ks-1) - $ + f1*f5*f3 * src1(is-3,js+1,ks-1) - $ + f2*f5*f3 * src1(is-2,js+1,ks-1) - $ + f3*f5*f3 * src1(is-1,js+1,ks-1) - $ + f4*f5*f3 * src1(is ,js+1,ks-1) - $ + f5*f5*f3 * src1(is+1,js+1,ks-1) - $ + f6*f5*f3 * src1(is+2,js+1,ks-1) - $ + f7*f5*f3 * src1(is+3,js+1,ks-1) - $ + f8*f5*f3 * src1(is+4,js+1,ks-1) - $ + f1*f6*f3 * src1(is-3,js+2,ks-1) - $ + f2*f6*f3 * src1(is-2,js+2,ks-1) - $ + f3*f6*f3 * src1(is-1,js+2,ks-1) - $ + f4*f6*f3 * src1(is ,js+2,ks-1) - $ + f5*f6*f3 * src1(is+1,js+2,ks-1) - $ + f6*f6*f3 * src1(is+2,js+2,ks-1) - $ + f7*f6*f3 * src1(is+3,js+2,ks-1) - $ + f8*f6*f3 * src1(is+4,js+2,ks-1) - $ + f1*f7*f3 * src1(is-3,js+3,ks-1) - $ + f2*f7*f3 * src1(is-2,js+3,ks-1) - $ + f3*f7*f3 * src1(is-1,js+3,ks-1) - $ + f4*f7*f3 * src1(is ,js+3,ks-1) - $ + f5*f7*f3 * src1(is+1,js+3,ks-1) - $ + f6*f7*f3 * src1(is+2,js+3,ks-1) - $ + f7*f7*f3 * src1(is+3,js+3,ks-1) - $ + f8*f7*f3 * src1(is+4,js+3,ks-1) - $ + f1*f8*f3 * src1(is-3,js+4,ks-1) - $ + f2*f8*f3 * src1(is-2,js+4,ks-1) - $ + f3*f8*f3 * src1(is-1,js+4,ks-1) - $ + f4*f8*f3 * src1(is ,js+4,ks-1) - $ + f5*f8*f3 * src1(is+1,js+4,ks-1) - $ + f6*f8*f3 * src1(is+2,js+4,ks-1) - $ + f7*f8*f3 * src1(is+3,js+4,ks-1) - $ + f8*f8*f3 * src1(is+4,js+4,ks-1) - res14 = - $ + f1*f1*f4 * src1(is-3,js-3,ks ) - $ + f2*f1*f4 * src1(is-2,js-3,ks ) - $ + f3*f1*f4 * src1(is-1,js-3,ks ) - $ + f4*f1*f4 * src1(is ,js-3,ks ) - $ + f5*f1*f4 * src1(is+1,js-3,ks ) - $ + f6*f1*f4 * src1(is+2,js-3,ks ) - $ + f7*f1*f4 * src1(is+3,js-3,ks ) - $ + f8*f1*f4 * src1(is+4,js-3,ks ) - $ + f1*f2*f4 * src1(is-3,js-2,ks ) - $ + f2*f2*f4 * src1(is-2,js-2,ks ) - $ + f3*f2*f4 * src1(is-1,js-2,ks ) - $ + f4*f2*f4 * src1(is ,js-2,ks ) - $ + f5*f2*f4 * src1(is+1,js-2,ks ) - $ + f6*f2*f4 * src1(is+2,js-2,ks ) - $ + f7*f2*f4 * src1(is+3,js-2,ks ) - $ + f8*f2*f4 * src1(is+4,js-2,ks ) - $ + f1*f3*f4 * src1(is-3,js-1,ks ) - $ + f2*f3*f4 * src1(is-2,js-1,ks ) - $ + f3*f3*f4 * src1(is-1,js-1,ks ) - $ + f4*f3*f4 * src1(is ,js-1,ks ) - $ + f5*f3*f4 * src1(is+1,js-1,ks ) - $ + f6*f3*f4 * src1(is+2,js-1,ks ) - $ + f7*f3*f4 * src1(is+3,js-1,ks ) - $ + f8*f3*f4 * src1(is+4,js-1,ks ) - $ + f1*f4*f4 * src1(is-3,js ,ks ) - $ + f2*f4*f4 * src1(is-2,js ,ks ) - $ + f3*f4*f4 * src1(is-1,js ,ks ) - $ + f4*f4*f4 * src1(is ,js ,ks ) - $ + f5*f4*f4 * src1(is+1,js ,ks ) - $ + f6*f4*f4 * src1(is+2,js ,ks ) - $ + f7*f4*f4 * src1(is+3,js ,ks ) - $ + f8*f4*f4 * src1(is+4,js ,ks ) - $ + f1*f5*f4 * src1(is-3,js+1,ks ) - $ + f2*f5*f4 * src1(is-2,js+1,ks ) - $ + f3*f5*f4 * src1(is-1,js+1,ks ) - $ + f4*f5*f4 * src1(is ,js+1,ks ) - $ + f5*f5*f4 * src1(is+1,js+1,ks ) - $ + f6*f5*f4 * src1(is+2,js+1,ks ) - $ + f7*f5*f4 * src1(is+3,js+1,ks ) - $ + f8*f5*f4 * src1(is+4,js+1,ks ) - $ + f1*f6*f4 * src1(is-3,js+2,ks ) - $ + f2*f6*f4 * src1(is-2,js+2,ks ) - $ + f3*f6*f4 * src1(is-1,js+2,ks ) - $ + f4*f6*f4 * src1(is ,js+2,ks ) - $ + f5*f6*f4 * src1(is+1,js+2,ks ) - $ + f6*f6*f4 * src1(is+2,js+2,ks ) - $ + f7*f6*f4 * src1(is+3,js+2,ks ) - $ + f8*f6*f4 * src1(is+4,js+2,ks ) - $ + f1*f7*f4 * src1(is-3,js+3,ks ) - $ + f2*f7*f4 * src1(is-2,js+3,ks ) - $ + f3*f7*f4 * src1(is-1,js+3,ks ) - $ + f4*f7*f4 * src1(is ,js+3,ks ) - $ + f5*f7*f4 * src1(is+1,js+3,ks ) - $ + f6*f7*f4 * src1(is+2,js+3,ks ) - $ + f7*f7*f4 * src1(is+3,js+3,ks ) - $ + f8*f7*f4 * src1(is+4,js+3,ks ) - $ + f1*f8*f4 * src1(is-3,js+4,ks ) - $ + f2*f8*f4 * src1(is-2,js+4,ks ) - $ + f3*f8*f4 * src1(is-1,js+4,ks ) - $ + f4*f8*f4 * src1(is ,js+4,ks ) - $ + f5*f8*f4 * src1(is+1,js+4,ks ) - $ + f6*f8*f4 * src1(is+2,js+4,ks ) - $ + f7*f8*f4 * src1(is+3,js+4,ks ) - $ + f8*f8*f4 * src1(is+4,js+4,ks ) - res15 = - $ + f1*f1*f5 * src1(is-3,js-3,ks+1) - $ + f2*f1*f5 * src1(is-2,js-3,ks+1) - $ + f3*f1*f5 * src1(is-1,js-3,ks+1) - $ + f4*f1*f5 * src1(is ,js-3,ks+1) - $ + f5*f1*f5 * src1(is+1,js-3,ks+1) - $ + f6*f1*f5 * src1(is+2,js-3,ks+1) - $ + f7*f1*f5 * src1(is+3,js-3,ks+1) - $ + f8*f1*f5 * src1(is+4,js-3,ks+1) - $ + f1*f2*f5 * src1(is-3,js-2,ks+1) - $ + f2*f2*f5 * src1(is-2,js-2,ks+1) - $ + f3*f2*f5 * src1(is-1,js-2,ks+1) - $ + f4*f2*f5 * src1(is ,js-2,ks+1) - $ + f5*f2*f5 * src1(is+1,js-2,ks+1) - $ + f6*f2*f5 * src1(is+2,js-2,ks+1) - $ + f7*f2*f5 * src1(is+3,js-2,ks+1) - $ + f8*f2*f5 * src1(is+4,js-2,ks+1) - $ + f1*f3*f5 * src1(is-3,js-1,ks+1) - $ + f2*f3*f5 * src1(is-2,js-1,ks+1) - $ + f3*f3*f5 * src1(is-1,js-1,ks+1) - $ + f4*f3*f5 * src1(is ,js-1,ks+1) - $ + f5*f3*f5 * src1(is+1,js-1,ks+1) - $ + f6*f3*f5 * src1(is+2,js-1,ks+1) - $ + f7*f3*f5 * src1(is+3,js-1,ks+1) - $ + f8*f3*f5 * src1(is+4,js-1,ks+1) - $ + f1*f4*f5 * src1(is-3,js ,ks+1) - $ + f2*f4*f5 * src1(is-2,js ,ks+1) - $ + f3*f4*f5 * src1(is-1,js ,ks+1) - $ + f4*f4*f5 * src1(is ,js ,ks+1) - $ + f5*f4*f5 * src1(is+1,js ,ks+1) - $ + f6*f4*f5 * src1(is+2,js ,ks+1) - $ + f7*f4*f5 * src1(is+3,js ,ks+1) - $ + f8*f4*f5 * src1(is+4,js ,ks+1) - $ + f1*f5*f5 * src1(is-3,js+1,ks+1) - $ + f2*f5*f5 * src1(is-2,js+1,ks+1) - $ + f3*f5*f5 * src1(is-1,js+1,ks+1) - $ + f4*f5*f5 * src1(is ,js+1,ks+1) - $ + f5*f5*f5 * src1(is+1,js+1,ks+1) - $ + f6*f5*f5 * src1(is+2,js+1,ks+1) - $ + f7*f5*f5 * src1(is+3,js+1,ks+1) - $ + f8*f5*f5 * src1(is+4,js+1,ks+1) - $ + f1*f6*f5 * src1(is-3,js+2,ks+1) - $ + f2*f6*f5 * src1(is-2,js+2,ks+1) - $ + f3*f6*f5 * src1(is-1,js+2,ks+1) - $ + f4*f6*f5 * src1(is ,js+2,ks+1) - $ + f5*f6*f5 * src1(is+1,js+2,ks+1) - $ + f6*f6*f5 * src1(is+2,js+2,ks+1) - $ + f7*f6*f5 * src1(is+3,js+2,ks+1) - $ + f8*f6*f5 * src1(is+4,js+2,ks+1) - $ + f1*f7*f5 * src1(is-3,js+3,ks+1) - $ + f2*f7*f5 * src1(is-2,js+3,ks+1) - $ + f3*f7*f5 * src1(is-1,js+3,ks+1) - $ + f4*f7*f5 * src1(is ,js+3,ks+1) - $ + f5*f7*f5 * src1(is+1,js+3,ks+1) - $ + f6*f7*f5 * src1(is+2,js+3,ks+1) - $ + f7*f7*f5 * src1(is+3,js+3,ks+1) - $ + f8*f7*f5 * src1(is+4,js+3,ks+1) - $ + f1*f8*f5 * src1(is-3,js+4,ks+1) - $ + f2*f8*f5 * src1(is-2,js+4,ks+1) - $ + f3*f8*f5 * src1(is-1,js+4,ks+1) - $ + f4*f8*f5 * src1(is ,js+4,ks+1) - $ + f5*f8*f5 * src1(is+1,js+4,ks+1) - $ + f6*f8*f5 * src1(is+2,js+4,ks+1) - $ + f7*f8*f5 * src1(is+3,js+4,ks+1) - $ + f8*f8*f5 * src1(is+4,js+4,ks+1) - res16 = - $ + f1*f1*f6 * src1(is-3,js-3,ks+2) - $ + f2*f1*f6 * src1(is-2,js-3,ks+2) - $ + f3*f1*f6 * src1(is-1,js-3,ks+2) - $ + f4*f1*f6 * src1(is ,js-3,ks+2) - $ + f5*f1*f6 * src1(is+1,js-3,ks+2) - $ + f6*f1*f6 * src1(is+2,js-3,ks+2) - $ + f7*f1*f6 * src1(is+3,js-3,ks+2) - $ + f8*f1*f6 * src1(is+4,js-3,ks+2) - $ + f1*f2*f6 * src1(is-3,js-2,ks+2) - $ + f2*f2*f6 * src1(is-2,js-2,ks+2) - $ + f3*f2*f6 * src1(is-1,js-2,ks+2) - $ + f4*f2*f6 * src1(is ,js-2,ks+2) - $ + f5*f2*f6 * src1(is+1,js-2,ks+2) - $ + f6*f2*f6 * src1(is+2,js-2,ks+2) - $ + f7*f2*f6 * src1(is+3,js-2,ks+2) - $ + f8*f2*f6 * src1(is+4,js-2,ks+2) - $ + f1*f3*f6 * src1(is-3,js-1,ks+2) - $ + f2*f3*f6 * src1(is-2,js-1,ks+2) - $ + f3*f3*f6 * src1(is-1,js-1,ks+2) - $ + f4*f3*f6 * src1(is ,js-1,ks+2) - $ + f5*f3*f6 * src1(is+1,js-1,ks+2) - $ + f6*f3*f6 * src1(is+2,js-1,ks+2) - $ + f7*f3*f6 * src1(is+3,js-1,ks+2) - $ + f8*f3*f6 * src1(is+4,js-1,ks+2) - $ + f1*f4*f6 * src1(is-3,js ,ks+2) - $ + f2*f4*f6 * src1(is-2,js ,ks+2) - $ + f3*f4*f6 * src1(is-1,js ,ks+2) - $ + f4*f4*f6 * src1(is ,js ,ks+2) - $ + f5*f4*f6 * src1(is+1,js ,ks+2) - $ + f6*f4*f6 * src1(is+2,js ,ks+2) - $ + f7*f4*f6 * src1(is+3,js ,ks+2) - $ + f8*f4*f6 * src1(is+4,js ,ks+2) - $ + f1*f5*f6 * src1(is-3,js+1,ks+2) - $ + f2*f5*f6 * src1(is-2,js+1,ks+2) - $ + f3*f5*f6 * src1(is-1,js+1,ks+2) - $ + f4*f5*f6 * src1(is ,js+1,ks+2) - $ + f5*f5*f6 * src1(is+1,js+1,ks+2) - $ + f6*f5*f6 * src1(is+2,js+1,ks+2) - $ + f7*f5*f6 * src1(is+3,js+1,ks+2) - $ + f8*f5*f6 * src1(is+4,js+1,ks+2) - $ + f1*f6*f6 * src1(is-3,js+2,ks+2) - $ + f2*f6*f6 * src1(is-2,js+2,ks+2) - $ + f3*f6*f6 * src1(is-1,js+2,ks+2) - $ + f4*f6*f6 * src1(is ,js+2,ks+2) - $ + f5*f6*f6 * src1(is+1,js+2,ks+2) - $ + f6*f6*f6 * src1(is+2,js+2,ks+2) - $ + f7*f6*f6 * src1(is+3,js+2,ks+2) - $ + f8*f6*f6 * src1(is+4,js+2,ks+2) - $ + f1*f7*f6 * src1(is-3,js+3,ks+2) - $ + f2*f7*f6 * src1(is-2,js+3,ks+2) - $ + f3*f7*f6 * src1(is-1,js+3,ks+2) - $ + f4*f7*f6 * src1(is ,js+3,ks+2) - $ + f5*f7*f6 * src1(is+1,js+3,ks+2) - $ + f6*f7*f6 * src1(is+2,js+3,ks+2) - $ + f7*f7*f6 * src1(is+3,js+3,ks+2) - $ + f8*f7*f6 * src1(is+4,js+3,ks+2) - $ + f1*f8*f6 * src1(is-3,js+4,ks+2) - $ + f2*f8*f6 * src1(is-2,js+4,ks+2) - $ + f3*f8*f6 * src1(is-1,js+4,ks+2) - $ + f4*f8*f6 * src1(is ,js+4,ks+2) - $ + f5*f8*f6 * src1(is+1,js+4,ks+2) - $ + f6*f8*f6 * src1(is+2,js+4,ks+2) - $ + f7*f8*f6 * src1(is+3,js+4,ks+2) - $ + f8*f8*f6 * src1(is+4,js+4,ks+2) - res17 = - $ + f1*f1*f7 * src1(is-3,js-3,ks+3) - $ + f2*f1*f7 * src1(is-2,js-3,ks+3) - $ + f3*f1*f7 * src1(is-1,js-3,ks+3) - $ + f4*f1*f7 * src1(is ,js-3,ks+3) - $ + f5*f1*f7 * src1(is+1,js-3,ks+3) - $ + f6*f1*f7 * src1(is+2,js-3,ks+3) - $ + f7*f1*f7 * src1(is+3,js-3,ks+3) - $ + f8*f1*f7 * src1(is+4,js-3,ks+3) - $ + f1*f2*f7 * src1(is-3,js-2,ks+3) - $ + f2*f2*f7 * src1(is-2,js-2,ks+3) - $ + f3*f2*f7 * src1(is-1,js-2,ks+3) - $ + f4*f2*f7 * src1(is ,js-2,ks+3) - $ + f5*f2*f7 * src1(is+1,js-2,ks+3) - $ + f6*f2*f7 * src1(is+2,js-2,ks+3) - $ + f7*f2*f7 * src1(is+3,js-2,ks+3) - $ + f8*f2*f7 * src1(is+4,js-2,ks+3) - $ + f1*f3*f7 * src1(is-3,js-1,ks+3) - $ + f2*f3*f7 * src1(is-2,js-1,ks+3) - $ + f3*f3*f7 * src1(is-1,js-1,ks+3) - $ + f4*f3*f7 * src1(is ,js-1,ks+3) - $ + f5*f3*f7 * src1(is+1,js-1,ks+3) - $ + f6*f3*f7 * src1(is+2,js-1,ks+3) - $ + f7*f3*f7 * src1(is+3,js-1,ks+3) - $ + f8*f3*f7 * src1(is+4,js-1,ks+3) - $ + f1*f4*f7 * src1(is-3,js ,ks+3) - $ + f2*f4*f7 * src1(is-2,js ,ks+3) - $ + f3*f4*f7 * src1(is-1,js ,ks+3) - $ + f4*f4*f7 * src1(is ,js ,ks+3) - $ + f5*f4*f7 * src1(is+1,js ,ks+3) - $ + f6*f4*f7 * src1(is+2,js ,ks+3) - $ + f7*f4*f7 * src1(is+3,js ,ks+3) - $ + f8*f4*f7 * src1(is+4,js ,ks+3) - $ + f1*f5*f7 * src1(is-3,js+1,ks+3) - $ + f2*f5*f7 * src1(is-2,js+1,ks+3) - $ + f3*f5*f7 * src1(is-1,js+1,ks+3) - $ + f4*f5*f7 * src1(is ,js+1,ks+3) - $ + f5*f5*f7 * src1(is+1,js+1,ks+3) - $ + f6*f5*f7 * src1(is+2,js+1,ks+3) - $ + f7*f5*f7 * src1(is+3,js+1,ks+3) - $ + f8*f5*f7 * src1(is+4,js+1,ks+3) - $ + f1*f6*f7 * src1(is-3,js+2,ks+3) - $ + f2*f6*f7 * src1(is-2,js+2,ks+3) - $ + f3*f6*f7 * src1(is-1,js+2,ks+3) - $ + f4*f6*f7 * src1(is ,js+2,ks+3) - $ + f5*f6*f7 * src1(is+1,js+2,ks+3) - $ + f6*f6*f7 * src1(is+2,js+2,ks+3) - $ + f7*f6*f7 * src1(is+3,js+2,ks+3) - $ + f8*f6*f7 * src1(is+4,js+2,ks+3) - $ + f1*f7*f7 * src1(is-3,js+3,ks+3) - $ + f2*f7*f7 * src1(is-2,js+3,ks+3) - $ + f3*f7*f7 * src1(is-1,js+3,ks+3) - $ + f4*f7*f7 * src1(is ,js+3,ks+3) - $ + f5*f7*f7 * src1(is+1,js+3,ks+3) - $ + f6*f7*f7 * src1(is+2,js+3,ks+3) - $ + f7*f7*f7 * src1(is+3,js+3,ks+3) - $ + f8*f7*f7 * src1(is+4,js+3,ks+3) - $ + f1*f8*f7 * src1(is-3,js+4,ks+3) - $ + f2*f8*f7 * src1(is-2,js+4,ks+3) - $ + f3*f8*f7 * src1(is-1,js+4,ks+3) - $ + f4*f8*f7 * src1(is ,js+4,ks+3) - $ + f5*f8*f7 * src1(is+1,js+4,ks+3) - $ + f6*f8*f7 * src1(is+2,js+4,ks+3) - $ + f7*f8*f7 * src1(is+3,js+4,ks+3) - $ + f8*f8*f7 * src1(is+4,js+4,ks+3) - res18 = - $ + f1*f1*f8 * src1(is-3,js-3,ks+4) - $ + f2*f1*f8 * src1(is-2,js-3,ks+4) - $ + f3*f1*f8 * src1(is-1,js-3,ks+4) - $ + f4*f1*f8 * src1(is ,js-3,ks+4) - $ + f5*f1*f8 * src1(is+1,js-3,ks+4) - $ + f6*f1*f8 * src1(is+2,js-3,ks+4) - $ + f7*f1*f8 * src1(is+3,js-3,ks+4) - $ + f8*f1*f8 * src1(is+4,js-3,ks+4) - $ + f1*f2*f8 * src1(is-3,js-2,ks+4) - $ + f2*f2*f8 * src1(is-2,js-2,ks+4) - $ + f3*f2*f8 * src1(is-1,js-2,ks+4) - $ + f4*f2*f8 * src1(is ,js-2,ks+4) - $ + f5*f2*f8 * src1(is+1,js-2,ks+4) - $ + f6*f2*f8 * src1(is+2,js-2,ks+4) - $ + f7*f2*f8 * src1(is+3,js-2,ks+4) - $ + f8*f2*f8 * src1(is+4,js-2,ks+4) - $ + f1*f3*f8 * src1(is-3,js-1,ks+4) - $ + f2*f3*f8 * src1(is-2,js-1,ks+4) - $ + f3*f3*f8 * src1(is-1,js-1,ks+4) - $ + f4*f3*f8 * src1(is ,js-1,ks+4) - $ + f5*f3*f8 * src1(is+1,js-1,ks+4) - $ + f6*f3*f8 * src1(is+2,js-1,ks+4) - $ + f7*f3*f8 * src1(is+3,js-1,ks+4) - $ + f8*f3*f8 * src1(is+4,js-1,ks+4) - $ + f1*f4*f8 * src1(is-3,js ,ks+4) - $ + f2*f4*f8 * src1(is-2,js ,ks+4) - $ + f3*f4*f8 * src1(is-1,js ,ks+4) - $ + f4*f4*f8 * src1(is ,js ,ks+4) - $ + f5*f4*f8 * src1(is+1,js ,ks+4) - $ + f6*f4*f8 * src1(is+2,js ,ks+4) - $ + f7*f4*f8 * src1(is+3,js ,ks+4) - $ + f8*f4*f8 * src1(is+4,js ,ks+4) - $ + f1*f5*f8 * src1(is-3,js+1,ks+4) - $ + f2*f5*f8 * src1(is-2,js+1,ks+4) - $ + f3*f5*f8 * src1(is-1,js+1,ks+4) - $ + f4*f5*f8 * src1(is ,js+1,ks+4) - $ + f5*f5*f8 * src1(is+1,js+1,ks+4) - $ + f6*f5*f8 * src1(is+2,js+1,ks+4) - $ + f7*f5*f8 * src1(is+3,js+1,ks+4) - $ + f8*f5*f8 * src1(is+4,js+1,ks+4) - $ + f1*f6*f8 * src1(is-3,js+2,ks+4) - $ + f2*f6*f8 * src1(is-2,js+2,ks+4) - $ + f3*f6*f8 * src1(is-1,js+2,ks+4) - $ + f4*f6*f8 * src1(is ,js+2,ks+4) - $ + f5*f6*f8 * src1(is+1,js+2,ks+4) - $ + f6*f6*f8 * src1(is+2,js+2,ks+4) - $ + f7*f6*f8 * src1(is+3,js+2,ks+4) - $ + f8*f6*f8 * src1(is+4,js+2,ks+4) - $ + f1*f7*f8 * src1(is-3,js+3,ks+4) - $ + f2*f7*f8 * src1(is-2,js+3,ks+4) - $ + f3*f7*f8 * src1(is-1,js+3,ks+4) - $ + f4*f7*f8 * src1(is ,js+3,ks+4) - $ + f5*f7*f8 * src1(is+1,js+3,ks+4) - $ + f6*f7*f8 * src1(is+2,js+3,ks+4) - $ + f7*f7*f8 * src1(is+3,js+3,ks+4) - $ + f8*f7*f8 * src1(is+4,js+3,ks+4) - $ + f1*f8*f8 * src1(is-3,js+4,ks+4) - $ + f2*f8*f8 * src1(is-2,js+4,ks+4) - $ + f3*f8*f8 * src1(is-1,js+4,ks+4) - $ + f4*f8*f8 * src1(is ,js+4,ks+4) - $ + f5*f8*f8 * src1(is+1,js+4,ks+4) - $ + f6*f8*f8 * src1(is+2,js+4,ks+4) - $ + f7*f8*f8 * src1(is+3,js+4,ks+4) - $ + f8*f8*f8 * src1(is+4,js+4,ks+4) - res21 = - $ + f1*f1*f1 * src2(is-3,js-3,ks-3) - $ + f2*f1*f1 * src2(is-2,js-3,ks-3) - $ + f3*f1*f1 * src2(is-1,js-3,ks-3) - $ + f4*f1*f1 * src2(is ,js-3,ks-3) - $ + f5*f1*f1 * src2(is+1,js-3,ks-3) - $ + f6*f1*f1 * src2(is+2,js-3,ks-3) - $ + f7*f1*f1 * src2(is+3,js-3,ks-3) - $ + f8*f1*f1 * src2(is+4,js-3,ks-3) - $ + f1*f2*f1 * src2(is-3,js-2,ks-3) - $ + f2*f2*f1 * src2(is-2,js-2,ks-3) - $ + f3*f2*f1 * src2(is-1,js-2,ks-3) - $ + f4*f2*f1 * src2(is ,js-2,ks-3) - $ + f5*f2*f1 * src2(is+1,js-2,ks-3) - $ + f6*f2*f1 * src2(is+2,js-2,ks-3) - $ + f7*f2*f1 * src2(is+3,js-2,ks-3) - $ + f8*f2*f1 * src2(is+4,js-2,ks-3) - $ + f1*f3*f1 * src2(is-3,js-1,ks-3) - $ + f2*f3*f1 * src2(is-2,js-1,ks-3) - $ + f3*f3*f1 * src2(is-1,js-1,ks-3) - $ + f4*f3*f1 * src2(is ,js-1,ks-3) - $ + f5*f3*f1 * src2(is+1,js-1,ks-3) - $ + f6*f3*f1 * src2(is+2,js-1,ks-3) - $ + f7*f3*f1 * src2(is+3,js-1,ks-3) - $ + f8*f3*f1 * src2(is+4,js-1,ks-3) - $ + f1*f4*f1 * src2(is-3,js ,ks-3) - $ + f2*f4*f1 * src2(is-2,js ,ks-3) - $ + f3*f4*f1 * src2(is-1,js ,ks-3) - $ + f4*f4*f1 * src2(is ,js ,ks-3) - $ + f5*f4*f1 * src2(is+1,js ,ks-3) - $ + f6*f4*f1 * src2(is+2,js ,ks-3) - $ + f7*f4*f1 * src2(is+3,js ,ks-3) - $ + f8*f4*f1 * src2(is+4,js ,ks-3) - $ + f1*f5*f1 * src2(is-3,js+1,ks-3) - $ + f2*f5*f1 * src2(is-2,js+1,ks-3) - $ + f3*f5*f1 * src2(is-1,js+1,ks-3) - $ + f4*f5*f1 * src2(is ,js+1,ks-3) - $ + f5*f5*f1 * src2(is+1,js+1,ks-3) - $ + f6*f5*f1 * src2(is+2,js+1,ks-3) - $ + f7*f5*f1 * src2(is+3,js+1,ks-3) - $ + f8*f5*f1 * src2(is+4,js+1,ks-3) - $ + f1*f6*f1 * src2(is-3,js+2,ks-3) - $ + f2*f6*f1 * src2(is-2,js+2,ks-3) - $ + f3*f6*f1 * src2(is-1,js+2,ks-3) - $ + f4*f6*f1 * src2(is ,js+2,ks-3) - $ + f5*f6*f1 * src2(is+1,js+2,ks-3) - $ + f6*f6*f1 * src2(is+2,js+2,ks-3) - $ + f7*f6*f1 * src2(is+3,js+2,ks-3) - $ + f8*f6*f1 * src2(is+4,js+2,ks-3) - $ + f1*f7*f1 * src2(is-3,js+3,ks-3) - $ + f2*f7*f1 * src2(is-2,js+3,ks-3) - $ + f3*f7*f1 * src2(is-1,js+3,ks-3) - $ + f4*f7*f1 * src2(is ,js+3,ks-3) - $ + f5*f7*f1 * src2(is+1,js+3,ks-3) - $ + f6*f7*f1 * src2(is+2,js+3,ks-3) - $ + f7*f7*f1 * src2(is+3,js+3,ks-3) - $ + f8*f7*f1 * src2(is+4,js+3,ks-3) - $ + f1*f8*f1 * src2(is-3,js+4,ks-3) - $ + f2*f8*f1 * src2(is-2,js+4,ks-3) - $ + f3*f8*f1 * src2(is-1,js+4,ks-3) - $ + f4*f8*f1 * src2(is ,js+4,ks-3) - $ + f5*f8*f1 * src2(is+1,js+4,ks-3) - $ + f6*f8*f1 * src2(is+2,js+4,ks-3) - $ + f7*f8*f1 * src2(is+3,js+4,ks-3) - $ + f8*f8*f1 * src2(is+4,js+4,ks-3) - res22 = - $ + f1*f1*f2 * src2(is-3,js-3,ks-2) - $ + f2*f1*f2 * src2(is-2,js-3,ks-2) - $ + f3*f1*f2 * src2(is-1,js-3,ks-2) - $ + f4*f1*f2 * src2(is ,js-3,ks-2) - $ + f5*f1*f2 * src2(is+1,js-3,ks-2) - $ + f6*f1*f2 * src2(is+2,js-3,ks-2) - $ + f7*f1*f2 * src2(is+3,js-3,ks-2) - $ + f8*f1*f2 * src2(is+4,js-3,ks-2) - $ + f1*f2*f2 * src2(is-3,js-2,ks-2) - $ + f2*f2*f2 * src2(is-2,js-2,ks-2) - $ + f3*f2*f2 * src2(is-1,js-2,ks-2) - $ + f4*f2*f2 * src2(is ,js-2,ks-2) - $ + f5*f2*f2 * src2(is+1,js-2,ks-2) - $ + f6*f2*f2 * src2(is+2,js-2,ks-2) - $ + f7*f2*f2 * src2(is+3,js-2,ks-2) - $ + f8*f2*f2 * src2(is+4,js-2,ks-2) - $ + f1*f3*f2 * src2(is-3,js-1,ks-2) - $ + f2*f3*f2 * src2(is-2,js-1,ks-2) - $ + f3*f3*f2 * src2(is-1,js-1,ks-2) - $ + f4*f3*f2 * src2(is ,js-1,ks-2) - $ + f5*f3*f2 * src2(is+1,js-1,ks-2) - $ + f6*f3*f2 * src2(is+2,js-1,ks-2) - $ + f7*f3*f2 * src2(is+3,js-1,ks-2) - $ + f8*f3*f2 * src2(is+4,js-1,ks-2) - $ + f1*f4*f2 * src2(is-3,js ,ks-2) - $ + f2*f4*f2 * src2(is-2,js ,ks-2) - $ + f3*f4*f2 * src2(is-1,js ,ks-2) - $ + f4*f4*f2 * src2(is ,js ,ks-2) - $ + f5*f4*f2 * src2(is+1,js ,ks-2) - $ + f6*f4*f2 * src2(is+2,js ,ks-2) - $ + f7*f4*f2 * src2(is+3,js ,ks-2) - $ + f8*f4*f2 * src2(is+4,js ,ks-2) - $ + f1*f5*f2 * src2(is-3,js+1,ks-2) - $ + f2*f5*f2 * src2(is-2,js+1,ks-2) - $ + f3*f5*f2 * src2(is-1,js+1,ks-2) - $ + f4*f5*f2 * src2(is ,js+1,ks-2) - $ + f5*f5*f2 * src2(is+1,js+1,ks-2) - $ + f6*f5*f2 * src2(is+2,js+1,ks-2) - $ + f7*f5*f2 * src2(is+3,js+1,ks-2) - $ + f8*f5*f2 * src2(is+4,js+1,ks-2) - $ + f1*f6*f2 * src2(is-3,js+2,ks-2) - $ + f2*f6*f2 * src2(is-2,js+2,ks-2) - $ + f3*f6*f2 * src2(is-1,js+2,ks-2) - $ + f4*f6*f2 * src2(is ,js+2,ks-2) - $ + f5*f6*f2 * src2(is+1,js+2,ks-2) - $ + f6*f6*f2 * src2(is+2,js+2,ks-2) - $ + f7*f6*f2 * src2(is+3,js+2,ks-2) - $ + f8*f6*f2 * src2(is+4,js+2,ks-2) - $ + f1*f7*f2 * src2(is-3,js+3,ks-2) - $ + f2*f7*f2 * src2(is-2,js+3,ks-2) - $ + f3*f7*f2 * src2(is-1,js+3,ks-2) - $ + f4*f7*f2 * src2(is ,js+3,ks-2) - $ + f5*f7*f2 * src2(is+1,js+3,ks-2) - $ + f6*f7*f2 * src2(is+2,js+3,ks-2) - $ + f7*f7*f2 * src2(is+3,js+3,ks-2) - $ + f8*f7*f2 * src2(is+4,js+3,ks-2) - $ + f1*f8*f2 * src2(is-3,js+4,ks-2) - $ + f2*f8*f2 * src2(is-2,js+4,ks-2) - $ + f3*f8*f2 * src2(is-1,js+4,ks-2) - $ + f4*f8*f2 * src2(is ,js+4,ks-2) - $ + f5*f8*f2 * src2(is+1,js+4,ks-2) - $ + f6*f8*f2 * src2(is+2,js+4,ks-2) - $ + f7*f8*f2 * src2(is+3,js+4,ks-2) - $ + f8*f8*f2 * src2(is+4,js+4,ks-2) - res23 = - $ + f1*f1*f3 * src2(is-3,js-3,ks-1) - $ + f2*f1*f3 * src2(is-2,js-3,ks-1) - $ + f3*f1*f3 * src2(is-1,js-3,ks-1) - $ + f4*f1*f3 * src2(is ,js-3,ks-1) - $ + f5*f1*f3 * src2(is+1,js-3,ks-1) - $ + f6*f1*f3 * src2(is+2,js-3,ks-1) - $ + f7*f1*f3 * src2(is+3,js-3,ks-1) - $ + f8*f1*f3 * src2(is+4,js-3,ks-1) - $ + f1*f2*f3 * src2(is-3,js-2,ks-1) - $ + f2*f2*f3 * src2(is-2,js-2,ks-1) - $ + f3*f2*f3 * src2(is-1,js-2,ks-1) - $ + f4*f2*f3 * src2(is ,js-2,ks-1) - $ + f5*f2*f3 * src2(is+1,js-2,ks-1) - $ + f6*f2*f3 * src2(is+2,js-2,ks-1) - $ + f7*f2*f3 * src2(is+3,js-2,ks-1) - $ + f8*f2*f3 * src2(is+4,js-2,ks-1) - $ + f1*f3*f3 * src2(is-3,js-1,ks-1) - $ + f2*f3*f3 * src2(is-2,js-1,ks-1) - $ + f3*f3*f3 * src2(is-1,js-1,ks-1) - $ + f4*f3*f3 * src2(is ,js-1,ks-1) - $ + f5*f3*f3 * src2(is+1,js-1,ks-1) - $ + f6*f3*f3 * src2(is+2,js-1,ks-1) - $ + f7*f3*f3 * src2(is+3,js-1,ks-1) - $ + f8*f3*f3 * src2(is+4,js-1,ks-1) - $ + f1*f4*f3 * src2(is-3,js ,ks-1) - $ + f2*f4*f3 * src2(is-2,js ,ks-1) - $ + f3*f4*f3 * src2(is-1,js ,ks-1) - $ + f4*f4*f3 * src2(is ,js ,ks-1) - $ + f5*f4*f3 * src2(is+1,js ,ks-1) - $ + f6*f4*f3 * src2(is+2,js ,ks-1) - $ + f7*f4*f3 * src2(is+3,js ,ks-1) - $ + f8*f4*f3 * src2(is+4,js ,ks-1) - $ + f1*f5*f3 * src2(is-3,js+1,ks-1) - $ + f2*f5*f3 * src2(is-2,js+1,ks-1) - $ + f3*f5*f3 * src2(is-1,js+1,ks-1) - $ + f4*f5*f3 * src2(is ,js+1,ks-1) - $ + f5*f5*f3 * src2(is+1,js+1,ks-1) - $ + f6*f5*f3 * src2(is+2,js+1,ks-1) - $ + f7*f5*f3 * src2(is+3,js+1,ks-1) - $ + f8*f5*f3 * src2(is+4,js+1,ks-1) - $ + f1*f6*f3 * src2(is-3,js+2,ks-1) - $ + f2*f6*f3 * src2(is-2,js+2,ks-1) - $ + f3*f6*f3 * src2(is-1,js+2,ks-1) - $ + f4*f6*f3 * src2(is ,js+2,ks-1) - $ + f5*f6*f3 * src2(is+1,js+2,ks-1) - $ + f6*f6*f3 * src2(is+2,js+2,ks-1) - $ + f7*f6*f3 * src2(is+3,js+2,ks-1) - $ + f8*f6*f3 * src2(is+4,js+2,ks-1) - $ + f1*f7*f3 * src2(is-3,js+3,ks-1) - $ + f2*f7*f3 * src2(is-2,js+3,ks-1) - $ + f3*f7*f3 * src2(is-1,js+3,ks-1) - $ + f4*f7*f3 * src2(is ,js+3,ks-1) - $ + f5*f7*f3 * src2(is+1,js+3,ks-1) - $ + f6*f7*f3 * src2(is+2,js+3,ks-1) - $ + f7*f7*f3 * src2(is+3,js+3,ks-1) - $ + f8*f7*f3 * src2(is+4,js+3,ks-1) - $ + f1*f8*f3 * src2(is-3,js+4,ks-1) - $ + f2*f8*f3 * src2(is-2,js+4,ks-1) - $ + f3*f8*f3 * src2(is-1,js+4,ks-1) - $ + f4*f8*f3 * src2(is ,js+4,ks-1) - $ + f5*f8*f3 * src2(is+1,js+4,ks-1) - $ + f6*f8*f3 * src2(is+2,js+4,ks-1) - $ + f7*f8*f3 * src2(is+3,js+4,ks-1) - $ + f8*f8*f3 * src2(is+4,js+4,ks-1) - res24 = - $ + f1*f1*f4 * src2(is-3,js-3,ks ) - $ + f2*f1*f4 * src2(is-2,js-3,ks ) - $ + f3*f1*f4 * src2(is-1,js-3,ks ) - $ + f4*f1*f4 * src2(is ,js-3,ks ) - $ + f5*f1*f4 * src2(is+1,js-3,ks ) - $ + f6*f1*f4 * src2(is+2,js-3,ks ) - $ + f7*f1*f4 * src2(is+3,js-3,ks ) - $ + f8*f1*f4 * src2(is+4,js-3,ks ) - $ + f1*f2*f4 * src2(is-3,js-2,ks ) - $ + f2*f2*f4 * src2(is-2,js-2,ks ) - $ + f3*f2*f4 * src2(is-1,js-2,ks ) - $ + f4*f2*f4 * src2(is ,js-2,ks ) - $ + f5*f2*f4 * src2(is+1,js-2,ks ) - $ + f6*f2*f4 * src2(is+2,js-2,ks ) - $ + f7*f2*f4 * src2(is+3,js-2,ks ) - $ + f8*f2*f4 * src2(is+4,js-2,ks ) - $ + f1*f3*f4 * src2(is-3,js-1,ks ) - $ + f2*f3*f4 * src2(is-2,js-1,ks ) - $ + f3*f3*f4 * src2(is-1,js-1,ks ) - $ + f4*f3*f4 * src2(is ,js-1,ks ) - $ + f5*f3*f4 * src2(is+1,js-1,ks ) - $ + f6*f3*f4 * src2(is+2,js-1,ks ) - $ + f7*f3*f4 * src2(is+3,js-1,ks ) - $ + f8*f3*f4 * src2(is+4,js-1,ks ) - $ + f1*f4*f4 * src2(is-3,js ,ks ) - $ + f2*f4*f4 * src2(is-2,js ,ks ) - $ + f3*f4*f4 * src2(is-1,js ,ks ) - $ + f4*f4*f4 * src2(is ,js ,ks ) - $ + f5*f4*f4 * src2(is+1,js ,ks ) - $ + f6*f4*f4 * src2(is+2,js ,ks ) - $ + f7*f4*f4 * src2(is+3,js ,ks ) - $ + f8*f4*f4 * src2(is+4,js ,ks ) - $ + f1*f5*f4 * src2(is-3,js+1,ks ) - $ + f2*f5*f4 * src2(is-2,js+1,ks ) - $ + f3*f5*f4 * src2(is-1,js+1,ks ) - $ + f4*f5*f4 * src2(is ,js+1,ks ) - $ + f5*f5*f4 * src2(is+1,js+1,ks ) - $ + f6*f5*f4 * src2(is+2,js+1,ks ) - $ + f7*f5*f4 * src2(is+3,js+1,ks ) - $ + f8*f5*f4 * src2(is+4,js+1,ks ) - $ + f1*f6*f4 * src2(is-3,js+2,ks ) - $ + f2*f6*f4 * src2(is-2,js+2,ks ) - $ + f3*f6*f4 * src2(is-1,js+2,ks ) - $ + f4*f6*f4 * src2(is ,js+2,ks ) - $ + f5*f6*f4 * src2(is+1,js+2,ks ) - $ + f6*f6*f4 * src2(is+2,js+2,ks ) - $ + f7*f6*f4 * src2(is+3,js+2,ks ) - $ + f8*f6*f4 * src2(is+4,js+2,ks ) - $ + f1*f7*f4 * src2(is-3,js+3,ks ) - $ + f2*f7*f4 * src2(is-2,js+3,ks ) - $ + f3*f7*f4 * src2(is-1,js+3,ks ) - $ + f4*f7*f4 * src2(is ,js+3,ks ) - $ + f5*f7*f4 * src2(is+1,js+3,ks ) - $ + f6*f7*f4 * src2(is+2,js+3,ks ) - $ + f7*f7*f4 * src2(is+3,js+3,ks ) - $ + f8*f7*f4 * src2(is+4,js+3,ks ) - $ + f1*f8*f4 * src2(is-3,js+4,ks ) - $ + f2*f8*f4 * src2(is-2,js+4,ks ) - $ + f3*f8*f4 * src2(is-1,js+4,ks ) - $ + f4*f8*f4 * src2(is ,js+4,ks ) - $ + f5*f8*f4 * src2(is+1,js+4,ks ) - $ + f6*f8*f4 * src2(is+2,js+4,ks ) - $ + f7*f8*f4 * src2(is+3,js+4,ks ) - $ + f8*f8*f4 * src2(is+4,js+4,ks ) - res25 = - $ + f1*f1*f5 * src2(is-3,js-3,ks+1) - $ + f2*f1*f5 * src2(is-2,js-3,ks+1) - $ + f3*f1*f5 * src2(is-1,js-3,ks+1) - $ + f4*f1*f5 * src2(is ,js-3,ks+1) - $ + f5*f1*f5 * src2(is+1,js-3,ks+1) - $ + f6*f1*f5 * src2(is+2,js-3,ks+1) - $ + f7*f1*f5 * src2(is+3,js-3,ks+1) - $ + f8*f1*f5 * src2(is+4,js-3,ks+1) - $ + f1*f2*f5 * src2(is-3,js-2,ks+1) - $ + f2*f2*f5 * src2(is-2,js-2,ks+1) - $ + f3*f2*f5 * src2(is-1,js-2,ks+1) - $ + f4*f2*f5 * src2(is ,js-2,ks+1) - $ + f5*f2*f5 * src2(is+1,js-2,ks+1) - $ + f6*f2*f5 * src2(is+2,js-2,ks+1) - $ + f7*f2*f5 * src2(is+3,js-2,ks+1) - $ + f8*f2*f5 * src2(is+4,js-2,ks+1) - $ + f1*f3*f5 * src2(is-3,js-1,ks+1) - $ + f2*f3*f5 * src2(is-2,js-1,ks+1) - $ + f3*f3*f5 * src2(is-1,js-1,ks+1) - $ + f4*f3*f5 * src2(is ,js-1,ks+1) - $ + f5*f3*f5 * src2(is+1,js-1,ks+1) - $ + f6*f3*f5 * src2(is+2,js-1,ks+1) - $ + f7*f3*f5 * src2(is+3,js-1,ks+1) - $ + f8*f3*f5 * src2(is+4,js-1,ks+1) - $ + f1*f4*f5 * src2(is-3,js ,ks+1) - $ + f2*f4*f5 * src2(is-2,js ,ks+1) - $ + f3*f4*f5 * src2(is-1,js ,ks+1) - $ + f4*f4*f5 * src2(is ,js ,ks+1) - $ + f5*f4*f5 * src2(is+1,js ,ks+1) - $ + f6*f4*f5 * src2(is+2,js ,ks+1) - $ + f7*f4*f5 * src2(is+3,js ,ks+1) - $ + f8*f4*f5 * src2(is+4,js ,ks+1) - $ + f1*f5*f5 * src2(is-3,js+1,ks+1) - $ + f2*f5*f5 * src2(is-2,js+1,ks+1) - $ + f3*f5*f5 * src2(is-1,js+1,ks+1) - $ + f4*f5*f5 * src2(is ,js+1,ks+1) - $ + f5*f5*f5 * src2(is+1,js+1,ks+1) - $ + f6*f5*f5 * src2(is+2,js+1,ks+1) - $ + f7*f5*f5 * src2(is+3,js+1,ks+1) - $ + f8*f5*f5 * src2(is+4,js+1,ks+1) - $ + f1*f6*f5 * src2(is-3,js+2,ks+1) - $ + f2*f6*f5 * src2(is-2,js+2,ks+1) - $ + f3*f6*f5 * src2(is-1,js+2,ks+1) - $ + f4*f6*f5 * src2(is ,js+2,ks+1) - $ + f5*f6*f5 * src2(is+1,js+2,ks+1) - $ + f6*f6*f5 * src2(is+2,js+2,ks+1) - $ + f7*f6*f5 * src2(is+3,js+2,ks+1) - $ + f8*f6*f5 * src2(is+4,js+2,ks+1) - $ + f1*f7*f5 * src2(is-3,js+3,ks+1) - $ + f2*f7*f5 * src2(is-2,js+3,ks+1) - $ + f3*f7*f5 * src2(is-1,js+3,ks+1) - $ + f4*f7*f5 * src2(is ,js+3,ks+1) - $ + f5*f7*f5 * src2(is+1,js+3,ks+1) - $ + f6*f7*f5 * src2(is+2,js+3,ks+1) - $ + f7*f7*f5 * src2(is+3,js+3,ks+1) - $ + f8*f7*f5 * src2(is+4,js+3,ks+1) - $ + f1*f8*f5 * src2(is-3,js+4,ks+1) - $ + f2*f8*f5 * src2(is-2,js+4,ks+1) - $ + f3*f8*f5 * src2(is-1,js+4,ks+1) - $ + f4*f8*f5 * src2(is ,js+4,ks+1) - $ + f5*f8*f5 * src2(is+1,js+4,ks+1) - $ + f6*f8*f5 * src2(is+2,js+4,ks+1) - $ + f7*f8*f5 * src2(is+3,js+4,ks+1) - $ + f8*f8*f5 * src2(is+4,js+4,ks+1) - res26 = - $ + f1*f1*f6 * src2(is-3,js-3,ks+2) - $ + f2*f1*f6 * src2(is-2,js-3,ks+2) - $ + f3*f1*f6 * src2(is-1,js-3,ks+2) - $ + f4*f1*f6 * src2(is ,js-3,ks+2) - $ + f5*f1*f6 * src2(is+1,js-3,ks+2) - $ + f6*f1*f6 * src2(is+2,js-3,ks+2) - $ + f7*f1*f6 * src2(is+3,js-3,ks+2) - $ + f8*f1*f6 * src2(is+4,js-3,ks+2) - $ + f1*f2*f6 * src2(is-3,js-2,ks+2) - $ + f2*f2*f6 * src2(is-2,js-2,ks+2) - $ + f3*f2*f6 * src2(is-1,js-2,ks+2) - $ + f4*f2*f6 * src2(is ,js-2,ks+2) - $ + f5*f2*f6 * src2(is+1,js-2,ks+2) - $ + f6*f2*f6 * src2(is+2,js-2,ks+2) - $ + f7*f2*f6 * src2(is+3,js-2,ks+2) - $ + f8*f2*f6 * src2(is+4,js-2,ks+2) - $ + f1*f3*f6 * src2(is-3,js-1,ks+2) - $ + f2*f3*f6 * src2(is-2,js-1,ks+2) - $ + f3*f3*f6 * src2(is-1,js-1,ks+2) - $ + f4*f3*f6 * src2(is ,js-1,ks+2) - $ + f5*f3*f6 * src2(is+1,js-1,ks+2) - $ + f6*f3*f6 * src2(is+2,js-1,ks+2) - $ + f7*f3*f6 * src2(is+3,js-1,ks+2) - $ + f8*f3*f6 * src2(is+4,js-1,ks+2) - $ + f1*f4*f6 * src2(is-3,js ,ks+2) - $ + f2*f4*f6 * src2(is-2,js ,ks+2) - $ + f3*f4*f6 * src2(is-1,js ,ks+2) - $ + f4*f4*f6 * src2(is ,js ,ks+2) - $ + f5*f4*f6 * src2(is+1,js ,ks+2) - $ + f6*f4*f6 * src2(is+2,js ,ks+2) - $ + f7*f4*f6 * src2(is+3,js ,ks+2) - $ + f8*f4*f6 * src2(is+4,js ,ks+2) - $ + f1*f5*f6 * src2(is-3,js+1,ks+2) - $ + f2*f5*f6 * src2(is-2,js+1,ks+2) - $ + f3*f5*f6 * src2(is-1,js+1,ks+2) - $ + f4*f5*f6 * src2(is ,js+1,ks+2) - $ + f5*f5*f6 * src2(is+1,js+1,ks+2) - $ + f6*f5*f6 * src2(is+2,js+1,ks+2) - $ + f7*f5*f6 * src2(is+3,js+1,ks+2) - $ + f8*f5*f6 * src2(is+4,js+1,ks+2) - $ + f1*f6*f6 * src2(is-3,js+2,ks+2) - $ + f2*f6*f6 * src2(is-2,js+2,ks+2) - $ + f3*f6*f6 * src2(is-1,js+2,ks+2) - $ + f4*f6*f6 * src2(is ,js+2,ks+2) - $ + f5*f6*f6 * src2(is+1,js+2,ks+2) - $ + f6*f6*f6 * src2(is+2,js+2,ks+2) - $ + f7*f6*f6 * src2(is+3,js+2,ks+2) - $ + f8*f6*f6 * src2(is+4,js+2,ks+2) - $ + f1*f7*f6 * src2(is-3,js+3,ks+2) - $ + f2*f7*f6 * src2(is-2,js+3,ks+2) - $ + f3*f7*f6 * src2(is-1,js+3,ks+2) - $ + f4*f7*f6 * src2(is ,js+3,ks+2) - $ + f5*f7*f6 * src2(is+1,js+3,ks+2) - $ + f6*f7*f6 * src2(is+2,js+3,ks+2) - $ + f7*f7*f6 * src2(is+3,js+3,ks+2) - $ + f8*f7*f6 * src2(is+4,js+3,ks+2) - $ + f1*f8*f6 * src2(is-3,js+4,ks+2) - $ + f2*f8*f6 * src2(is-2,js+4,ks+2) - $ + f3*f8*f6 * src2(is-1,js+4,ks+2) - $ + f4*f8*f6 * src2(is ,js+4,ks+2) - $ + f5*f8*f6 * src2(is+1,js+4,ks+2) - $ + f6*f8*f6 * src2(is+2,js+4,ks+2) - $ + f7*f8*f6 * src2(is+3,js+4,ks+2) - $ + f8*f8*f6 * src2(is+4,js+4,ks+2) - res27 = - $ + f1*f1*f7 * src2(is-3,js-3,ks+3) - $ + f2*f1*f7 * src2(is-2,js-3,ks+3) - $ + f3*f1*f7 * src2(is-1,js-3,ks+3) - $ + f4*f1*f7 * src2(is ,js-3,ks+3) - $ + f5*f1*f7 * src2(is+1,js-3,ks+3) - $ + f6*f1*f7 * src2(is+2,js-3,ks+3) - $ + f7*f1*f7 * src2(is+3,js-3,ks+3) - $ + f8*f1*f7 * src2(is+4,js-3,ks+3) - $ + f1*f2*f7 * src2(is-3,js-2,ks+3) - $ + f2*f2*f7 * src2(is-2,js-2,ks+3) - $ + f3*f2*f7 * src2(is-1,js-2,ks+3) - $ + f4*f2*f7 * src2(is ,js-2,ks+3) - $ + f5*f2*f7 * src2(is+1,js-2,ks+3) - $ + f6*f2*f7 * src2(is+2,js-2,ks+3) - $ + f7*f2*f7 * src2(is+3,js-2,ks+3) - $ + f8*f2*f7 * src2(is+4,js-2,ks+3) - $ + f1*f3*f7 * src2(is-3,js-1,ks+3) - $ + f2*f3*f7 * src2(is-2,js-1,ks+3) - $ + f3*f3*f7 * src2(is-1,js-1,ks+3) - $ + f4*f3*f7 * src2(is ,js-1,ks+3) - $ + f5*f3*f7 * src2(is+1,js-1,ks+3) - $ + f6*f3*f7 * src2(is+2,js-1,ks+3) - $ + f7*f3*f7 * src2(is+3,js-1,ks+3) - $ + f8*f3*f7 * src2(is+4,js-1,ks+3) - $ + f1*f4*f7 * src2(is-3,js ,ks+3) - $ + f2*f4*f7 * src2(is-2,js ,ks+3) - $ + f3*f4*f7 * src2(is-1,js ,ks+3) - $ + f4*f4*f7 * src2(is ,js ,ks+3) - $ + f5*f4*f7 * src2(is+1,js ,ks+3) - $ + f6*f4*f7 * src2(is+2,js ,ks+3) - $ + f7*f4*f7 * src2(is+3,js ,ks+3) - $ + f8*f4*f7 * src2(is+4,js ,ks+3) - $ + f1*f5*f7 * src2(is-3,js+1,ks+3) - $ + f2*f5*f7 * src2(is-2,js+1,ks+3) - $ + f3*f5*f7 * src2(is-1,js+1,ks+3) - $ + f4*f5*f7 * src2(is ,js+1,ks+3) - $ + f5*f5*f7 * src2(is+1,js+1,ks+3) - $ + f6*f5*f7 * src2(is+2,js+1,ks+3) - $ + f7*f5*f7 * src2(is+3,js+1,ks+3) - $ + f8*f5*f7 * src2(is+4,js+1,ks+3) - $ + f1*f6*f7 * src2(is-3,js+2,ks+3) - $ + f2*f6*f7 * src2(is-2,js+2,ks+3) - $ + f3*f6*f7 * src2(is-1,js+2,ks+3) - $ + f4*f6*f7 * src2(is ,js+2,ks+3) - $ + f5*f6*f7 * src2(is+1,js+2,ks+3) - $ + f6*f6*f7 * src2(is+2,js+2,ks+3) - $ + f7*f6*f7 * src2(is+3,js+2,ks+3) - $ + f8*f6*f7 * src2(is+4,js+2,ks+3) - $ + f1*f7*f7 * src2(is-3,js+3,ks+3) - $ + f2*f7*f7 * src2(is-2,js+3,ks+3) - $ + f3*f7*f7 * src2(is-1,js+3,ks+3) - $ + f4*f7*f7 * src2(is ,js+3,ks+3) - $ + f5*f7*f7 * src2(is+1,js+3,ks+3) - $ + f6*f7*f7 * src2(is+2,js+3,ks+3) - $ + f7*f7*f7 * src2(is+3,js+3,ks+3) - $ + f8*f7*f7 * src2(is+4,js+3,ks+3) - $ + f1*f8*f7 * src2(is-3,js+4,ks+3) - $ + f2*f8*f7 * src2(is-2,js+4,ks+3) - $ + f3*f8*f7 * src2(is-1,js+4,ks+3) - $ + f4*f8*f7 * src2(is ,js+4,ks+3) - $ + f5*f8*f7 * src2(is+1,js+4,ks+3) - $ + f6*f8*f7 * src2(is+2,js+4,ks+3) - $ + f7*f8*f7 * src2(is+3,js+4,ks+3) - $ + f8*f8*f7 * src2(is+4,js+4,ks+3) - res28 = - $ + f1*f1*f8 * src2(is-3,js-3,ks+4) - $ + f2*f1*f8 * src2(is-2,js-3,ks+4) - $ + f3*f1*f8 * src2(is-1,js-3,ks+4) - $ + f4*f1*f8 * src2(is ,js-3,ks+4) - $ + f5*f1*f8 * src2(is+1,js-3,ks+4) - $ + f6*f1*f8 * src2(is+2,js-3,ks+4) - $ + f7*f1*f8 * src2(is+3,js-3,ks+4) - $ + f8*f1*f8 * src2(is+4,js-3,ks+4) - $ + f1*f2*f8 * src2(is-3,js-2,ks+4) - $ + f2*f2*f8 * src2(is-2,js-2,ks+4) - $ + f3*f2*f8 * src2(is-1,js-2,ks+4) - $ + f4*f2*f8 * src2(is ,js-2,ks+4) - $ + f5*f2*f8 * src2(is+1,js-2,ks+4) - $ + f6*f2*f8 * src2(is+2,js-2,ks+4) - $ + f7*f2*f8 * src2(is+3,js-2,ks+4) - $ + f8*f2*f8 * src2(is+4,js-2,ks+4) - $ + f1*f3*f8 * src2(is-3,js-1,ks+4) - $ + f2*f3*f8 * src2(is-2,js-1,ks+4) - $ + f3*f3*f8 * src2(is-1,js-1,ks+4) - $ + f4*f3*f8 * src2(is ,js-1,ks+4) - $ + f5*f3*f8 * src2(is+1,js-1,ks+4) - $ + f6*f3*f8 * src2(is+2,js-1,ks+4) - $ + f7*f3*f8 * src2(is+3,js-1,ks+4) - $ + f8*f3*f8 * src2(is+4,js-1,ks+4) - $ + f1*f4*f8 * src2(is-3,js ,ks+4) - $ + f2*f4*f8 * src2(is-2,js ,ks+4) - $ + f3*f4*f8 * src2(is-1,js ,ks+4) - $ + f4*f4*f8 * src2(is ,js ,ks+4) - $ + f5*f4*f8 * src2(is+1,js ,ks+4) - $ + f6*f4*f8 * src2(is+2,js ,ks+4) - $ + f7*f4*f8 * src2(is+3,js ,ks+4) - $ + f8*f4*f8 * src2(is+4,js ,ks+4) - $ + f1*f5*f8 * src2(is-3,js+1,ks+4) - $ + f2*f5*f8 * src2(is-2,js+1,ks+4) - $ + f3*f5*f8 * src2(is-1,js+1,ks+4) - $ + f4*f5*f8 * src2(is ,js+1,ks+4) - $ + f5*f5*f8 * src2(is+1,js+1,ks+4) - $ + f6*f5*f8 * src2(is+2,js+1,ks+4) - $ + f7*f5*f8 * src2(is+3,js+1,ks+4) - $ + f8*f5*f8 * src2(is+4,js+1,ks+4) - $ + f1*f6*f8 * src2(is-3,js+2,ks+4) - $ + f2*f6*f8 * src2(is-2,js+2,ks+4) - $ + f3*f6*f8 * src2(is-1,js+2,ks+4) - $ + f4*f6*f8 * src2(is ,js+2,ks+4) - $ + f5*f6*f8 * src2(is+1,js+2,ks+4) - $ + f6*f6*f8 * src2(is+2,js+2,ks+4) - $ + f7*f6*f8 * src2(is+3,js+2,ks+4) - $ + f8*f6*f8 * src2(is+4,js+2,ks+4) - $ + f1*f7*f8 * src2(is-3,js+3,ks+4) - $ + f2*f7*f8 * src2(is-2,js+3,ks+4) - $ + f3*f7*f8 * src2(is-1,js+3,ks+4) - $ + f4*f7*f8 * src2(is ,js+3,ks+4) - $ + f5*f7*f8 * src2(is+1,js+3,ks+4) - $ + f6*f7*f8 * src2(is+2,js+3,ks+4) - $ + f7*f7*f8 * src2(is+3,js+3,ks+4) - $ + f8*f7*f8 * src2(is+4,js+3,ks+4) - $ + f1*f8*f8 * src2(is-3,js+4,ks+4) - $ + f2*f8*f8 * src2(is-2,js+4,ks+4) - $ + f3*f8*f8 * src2(is-1,js+4,ks+4) - $ + f4*f8*f8 * src2(is ,js+4,ks+4) - $ + f5*f8*f8 * src2(is+1,js+4,ks+4) - $ + f6*f8*f8 * src2(is+2,js+4,ks+4) - $ + f7*f8*f8 * src2(is+3,js+4,ks+4) - $ + f8*f8*f8 * src2(is+4,js+4,ks+4) - res31 = - $ + f1*f1*f1 * src3(is-3,js-3,ks-3) - $ + f2*f1*f1 * src3(is-2,js-3,ks-3) - $ + f3*f1*f1 * src3(is-1,js-3,ks-3) - $ + f4*f1*f1 * src3(is ,js-3,ks-3) - $ + f5*f1*f1 * src3(is+1,js-3,ks-3) - $ + f6*f1*f1 * src3(is+2,js-3,ks-3) - $ + f7*f1*f1 * src3(is+3,js-3,ks-3) - $ + f8*f1*f1 * src3(is+4,js-3,ks-3) - $ + f1*f2*f1 * src3(is-3,js-2,ks-3) - $ + f2*f2*f1 * src3(is-2,js-2,ks-3) - $ + f3*f2*f1 * src3(is-1,js-2,ks-3) - $ + f4*f2*f1 * src3(is ,js-2,ks-3) - $ + f5*f2*f1 * src3(is+1,js-2,ks-3) - $ + f6*f2*f1 * src3(is+2,js-2,ks-3) - $ + f7*f2*f1 * src3(is+3,js-2,ks-3) - $ + f8*f2*f1 * src3(is+4,js-2,ks-3) - $ + f1*f3*f1 * src3(is-3,js-1,ks-3) - $ + f2*f3*f1 * src3(is-2,js-1,ks-3) - $ + f3*f3*f1 * src3(is-1,js-1,ks-3) - $ + f4*f3*f1 * src3(is ,js-1,ks-3) - $ + f5*f3*f1 * src3(is+1,js-1,ks-3) - $ + f6*f3*f1 * src3(is+2,js-1,ks-3) - $ + f7*f3*f1 * src3(is+3,js-1,ks-3) - $ + f8*f3*f1 * src3(is+4,js-1,ks-3) - $ + f1*f4*f1 * src3(is-3,js ,ks-3) - $ + f2*f4*f1 * src3(is-2,js ,ks-3) - $ + f3*f4*f1 * src3(is-1,js ,ks-3) - $ + f4*f4*f1 * src3(is ,js ,ks-3) - $ + f5*f4*f1 * src3(is+1,js ,ks-3) - $ + f6*f4*f1 * src3(is+2,js ,ks-3) - $ + f7*f4*f1 * src3(is+3,js ,ks-3) - $ + f8*f4*f1 * src3(is+4,js ,ks-3) - $ + f1*f5*f1 * src3(is-3,js+1,ks-3) - $ + f2*f5*f1 * src3(is-2,js+1,ks-3) - $ + f3*f5*f1 * src3(is-1,js+1,ks-3) - $ + f4*f5*f1 * src3(is ,js+1,ks-3) - $ + f5*f5*f1 * src3(is+1,js+1,ks-3) - $ + f6*f5*f1 * src3(is+2,js+1,ks-3) - $ + f7*f5*f1 * src3(is+3,js+1,ks-3) - $ + f8*f5*f1 * src3(is+4,js+1,ks-3) - $ + f1*f6*f1 * src3(is-3,js+2,ks-3) - $ + f2*f6*f1 * src3(is-2,js+2,ks-3) - $ + f3*f6*f1 * src3(is-1,js+2,ks-3) - $ + f4*f6*f1 * src3(is ,js+2,ks-3) - $ + f5*f6*f1 * src3(is+1,js+2,ks-3) - $ + f6*f6*f1 * src3(is+2,js+2,ks-3) - $ + f7*f6*f1 * src3(is+3,js+2,ks-3) - $ + f8*f6*f1 * src3(is+4,js+2,ks-3) - $ + f1*f7*f1 * src3(is-3,js+3,ks-3) - $ + f2*f7*f1 * src3(is-2,js+3,ks-3) - $ + f3*f7*f1 * src3(is-1,js+3,ks-3) - $ + f4*f7*f1 * src3(is ,js+3,ks-3) - $ + f5*f7*f1 * src3(is+1,js+3,ks-3) - $ + f6*f7*f1 * src3(is+2,js+3,ks-3) - $ + f7*f7*f1 * src3(is+3,js+3,ks-3) - $ + f8*f7*f1 * src3(is+4,js+3,ks-3) - $ + f1*f8*f1 * src3(is-3,js+4,ks-3) - $ + f2*f8*f1 * src3(is-2,js+4,ks-3) - $ + f3*f8*f1 * src3(is-1,js+4,ks-3) - $ + f4*f8*f1 * src3(is ,js+4,ks-3) - $ + f5*f8*f1 * src3(is+1,js+4,ks-3) - $ + f6*f8*f1 * src3(is+2,js+4,ks-3) - $ + f7*f8*f1 * src3(is+3,js+4,ks-3) - $ + f8*f8*f1 * src3(is+4,js+4,ks-3) - res32 = - $ + f1*f1*f2 * src3(is-3,js-3,ks-2) - $ + f2*f1*f2 * src3(is-2,js-3,ks-2) - $ + f3*f1*f2 * src3(is-1,js-3,ks-2) - $ + f4*f1*f2 * src3(is ,js-3,ks-2) - $ + f5*f1*f2 * src3(is+1,js-3,ks-2) - $ + f6*f1*f2 * src3(is+2,js-3,ks-2) - $ + f7*f1*f2 * src3(is+3,js-3,ks-2) - $ + f8*f1*f2 * src3(is+4,js-3,ks-2) - $ + f1*f2*f2 * src3(is-3,js-2,ks-2) - $ + f2*f2*f2 * src3(is-2,js-2,ks-2) - $ + f3*f2*f2 * src3(is-1,js-2,ks-2) - $ + f4*f2*f2 * src3(is ,js-2,ks-2) - $ + f5*f2*f2 * src3(is+1,js-2,ks-2) - $ + f6*f2*f2 * src3(is+2,js-2,ks-2) - $ + f7*f2*f2 * src3(is+3,js-2,ks-2) - $ + f8*f2*f2 * src3(is+4,js-2,ks-2) - $ + f1*f3*f2 * src3(is-3,js-1,ks-2) - $ + f2*f3*f2 * src3(is-2,js-1,ks-2) - $ + f3*f3*f2 * src3(is-1,js-1,ks-2) - $ + f4*f3*f2 * src3(is ,js-1,ks-2) - $ + f5*f3*f2 * src3(is+1,js-1,ks-2) - $ + f6*f3*f2 * src3(is+2,js-1,ks-2) - $ + f7*f3*f2 * src3(is+3,js-1,ks-2) - $ + f8*f3*f2 * src3(is+4,js-1,ks-2) - $ + f1*f4*f2 * src3(is-3,js ,ks-2) - $ + f2*f4*f2 * src3(is-2,js ,ks-2) - $ + f3*f4*f2 * src3(is-1,js ,ks-2) - $ + f4*f4*f2 * src3(is ,js ,ks-2) - $ + f5*f4*f2 * src3(is+1,js ,ks-2) - $ + f6*f4*f2 * src3(is+2,js ,ks-2) - $ + f7*f4*f2 * src3(is+3,js ,ks-2) - $ + f8*f4*f2 * src3(is+4,js ,ks-2) - $ + f1*f5*f2 * src3(is-3,js+1,ks-2) - $ + f2*f5*f2 * src3(is-2,js+1,ks-2) - $ + f3*f5*f2 * src3(is-1,js+1,ks-2) - $ + f4*f5*f2 * src3(is ,js+1,ks-2) - $ + f5*f5*f2 * src3(is+1,js+1,ks-2) - $ + f6*f5*f2 * src3(is+2,js+1,ks-2) - $ + f7*f5*f2 * src3(is+3,js+1,ks-2) - $ + f8*f5*f2 * src3(is+4,js+1,ks-2) - $ + f1*f6*f2 * src3(is-3,js+2,ks-2) - $ + f2*f6*f2 * src3(is-2,js+2,ks-2) - $ + f3*f6*f2 * src3(is-1,js+2,ks-2) - $ + f4*f6*f2 * src3(is ,js+2,ks-2) - $ + f5*f6*f2 * src3(is+1,js+2,ks-2) - $ + f6*f6*f2 * src3(is+2,js+2,ks-2) - $ + f7*f6*f2 * src3(is+3,js+2,ks-2) - $ + f8*f6*f2 * src3(is+4,js+2,ks-2) - $ + f1*f7*f2 * src3(is-3,js+3,ks-2) - $ + f2*f7*f2 * src3(is-2,js+3,ks-2) - $ + f3*f7*f2 * src3(is-1,js+3,ks-2) - $ + f4*f7*f2 * src3(is ,js+3,ks-2) - $ + f5*f7*f2 * src3(is+1,js+3,ks-2) - $ + f6*f7*f2 * src3(is+2,js+3,ks-2) - $ + f7*f7*f2 * src3(is+3,js+3,ks-2) - $ + f8*f7*f2 * src3(is+4,js+3,ks-2) - $ + f1*f8*f2 * src3(is-3,js+4,ks-2) - $ + f2*f8*f2 * src3(is-2,js+4,ks-2) - $ + f3*f8*f2 * src3(is-1,js+4,ks-2) - $ + f4*f8*f2 * src3(is ,js+4,ks-2) - $ + f5*f8*f2 * src3(is+1,js+4,ks-2) - $ + f6*f8*f2 * src3(is+2,js+4,ks-2) - $ + f7*f8*f2 * src3(is+3,js+4,ks-2) - $ + f8*f8*f2 * src3(is+4,js+4,ks-2) - res33 = - $ + f1*f1*f3 * src3(is-3,js-3,ks-1) - $ + f2*f1*f3 * src3(is-2,js-3,ks-1) - $ + f3*f1*f3 * src3(is-1,js-3,ks-1) - $ + f4*f1*f3 * src3(is ,js-3,ks-1) - $ + f5*f1*f3 * src3(is+1,js-3,ks-1) - $ + f6*f1*f3 * src3(is+2,js-3,ks-1) - $ + f7*f1*f3 * src3(is+3,js-3,ks-1) - $ + f8*f1*f3 * src3(is+4,js-3,ks-1) - $ + f1*f2*f3 * src3(is-3,js-2,ks-1) - $ + f2*f2*f3 * src3(is-2,js-2,ks-1) - $ + f3*f2*f3 * src3(is-1,js-2,ks-1) - $ + f4*f2*f3 * src3(is ,js-2,ks-1) - $ + f5*f2*f3 * src3(is+1,js-2,ks-1) - $ + f6*f2*f3 * src3(is+2,js-2,ks-1) - $ + f7*f2*f3 * src3(is+3,js-2,ks-1) - $ + f8*f2*f3 * src3(is+4,js-2,ks-1) - $ + f1*f3*f3 * src3(is-3,js-1,ks-1) - $ + f2*f3*f3 * src3(is-2,js-1,ks-1) - $ + f3*f3*f3 * src3(is-1,js-1,ks-1) - $ + f4*f3*f3 * src3(is ,js-1,ks-1) - $ + f5*f3*f3 * src3(is+1,js-1,ks-1) - $ + f6*f3*f3 * src3(is+2,js-1,ks-1) - $ + f7*f3*f3 * src3(is+3,js-1,ks-1) - $ + f8*f3*f3 * src3(is+4,js-1,ks-1) - $ + f1*f4*f3 * src3(is-3,js ,ks-1) - $ + f2*f4*f3 * src3(is-2,js ,ks-1) - $ + f3*f4*f3 * src3(is-1,js ,ks-1) - $ + f4*f4*f3 * src3(is ,js ,ks-1) - $ + f5*f4*f3 * src3(is+1,js ,ks-1) - $ + f6*f4*f3 * src3(is+2,js ,ks-1) - $ + f7*f4*f3 * src3(is+3,js ,ks-1) - $ + f8*f4*f3 * src3(is+4,js ,ks-1) - $ + f1*f5*f3 * src3(is-3,js+1,ks-1) - $ + f2*f5*f3 * src3(is-2,js+1,ks-1) - $ + f3*f5*f3 * src3(is-1,js+1,ks-1) - $ + f4*f5*f3 * src3(is ,js+1,ks-1) - $ + f5*f5*f3 * src3(is+1,js+1,ks-1) - $ + f6*f5*f3 * src3(is+2,js+1,ks-1) - $ + f7*f5*f3 * src3(is+3,js+1,ks-1) - $ + f8*f5*f3 * src3(is+4,js+1,ks-1) - $ + f1*f6*f3 * src3(is-3,js+2,ks-1) - $ + f2*f6*f3 * src3(is-2,js+2,ks-1) - $ + f3*f6*f3 * src3(is-1,js+2,ks-1) - $ + f4*f6*f3 * src3(is ,js+2,ks-1) - $ + f5*f6*f3 * src3(is+1,js+2,ks-1) - $ + f6*f6*f3 * src3(is+2,js+2,ks-1) - $ + f7*f6*f3 * src3(is+3,js+2,ks-1) - $ + f8*f6*f3 * src3(is+4,js+2,ks-1) - $ + f1*f7*f3 * src3(is-3,js+3,ks-1) - $ + f2*f7*f3 * src3(is-2,js+3,ks-1) - $ + f3*f7*f3 * src3(is-1,js+3,ks-1) - $ + f4*f7*f3 * src3(is ,js+3,ks-1) - $ + f5*f7*f3 * src3(is+1,js+3,ks-1) - $ + f6*f7*f3 * src3(is+2,js+3,ks-1) - $ + f7*f7*f3 * src3(is+3,js+3,ks-1) - $ + f8*f7*f3 * src3(is+4,js+3,ks-1) - $ + f1*f8*f3 * src3(is-3,js+4,ks-1) - $ + f2*f8*f3 * src3(is-2,js+4,ks-1) - $ + f3*f8*f3 * src3(is-1,js+4,ks-1) - $ + f4*f8*f3 * src3(is ,js+4,ks-1) - $ + f5*f8*f3 * src3(is+1,js+4,ks-1) - $ + f6*f8*f3 * src3(is+2,js+4,ks-1) - $ + f7*f8*f3 * src3(is+3,js+4,ks-1) - $ + f8*f8*f3 * src3(is+4,js+4,ks-1) - res34 = - $ + f1*f1*f4 * src3(is-3,js-3,ks ) - $ + f2*f1*f4 * src3(is-2,js-3,ks ) - $ + f3*f1*f4 * src3(is-1,js-3,ks ) - $ + f4*f1*f4 * src3(is ,js-3,ks ) - $ + f5*f1*f4 * src3(is+1,js-3,ks ) - $ + f6*f1*f4 * src3(is+2,js-3,ks ) - $ + f7*f1*f4 * src3(is+3,js-3,ks ) - $ + f8*f1*f4 * src3(is+4,js-3,ks ) - $ + f1*f2*f4 * src3(is-3,js-2,ks ) - $ + f2*f2*f4 * src3(is-2,js-2,ks ) - $ + f3*f2*f4 * src3(is-1,js-2,ks ) - $ + f4*f2*f4 * src3(is ,js-2,ks ) - $ + f5*f2*f4 * src3(is+1,js-2,ks ) - $ + f6*f2*f4 * src3(is+2,js-2,ks ) - $ + f7*f2*f4 * src3(is+3,js-2,ks ) - $ + f8*f2*f4 * src3(is+4,js-2,ks ) - $ + f1*f3*f4 * src3(is-3,js-1,ks ) - $ + f2*f3*f4 * src3(is-2,js-1,ks ) - $ + f3*f3*f4 * src3(is-1,js-1,ks ) - $ + f4*f3*f4 * src3(is ,js-1,ks ) - $ + f5*f3*f4 * src3(is+1,js-1,ks ) - $ + f6*f3*f4 * src3(is+2,js-1,ks ) - $ + f7*f3*f4 * src3(is+3,js-1,ks ) - $ + f8*f3*f4 * src3(is+4,js-1,ks ) - $ + f1*f4*f4 * src3(is-3,js ,ks ) - $ + f2*f4*f4 * src3(is-2,js ,ks ) - $ + f3*f4*f4 * src3(is-1,js ,ks ) - $ + f4*f4*f4 * src3(is ,js ,ks ) - $ + f5*f4*f4 * src3(is+1,js ,ks ) - $ + f6*f4*f4 * src3(is+2,js ,ks ) - $ + f7*f4*f4 * src3(is+3,js ,ks ) - $ + f8*f4*f4 * src3(is+4,js ,ks ) - $ + f1*f5*f4 * src3(is-3,js+1,ks ) - $ + f2*f5*f4 * src3(is-2,js+1,ks ) - $ + f3*f5*f4 * src3(is-1,js+1,ks ) - $ + f4*f5*f4 * src3(is ,js+1,ks ) - $ + f5*f5*f4 * src3(is+1,js+1,ks ) - $ + f6*f5*f4 * src3(is+2,js+1,ks ) - $ + f7*f5*f4 * src3(is+3,js+1,ks ) - $ + f8*f5*f4 * src3(is+4,js+1,ks ) - $ + f1*f6*f4 * src3(is-3,js+2,ks ) - $ + f2*f6*f4 * src3(is-2,js+2,ks ) - $ + f3*f6*f4 * src3(is-1,js+2,ks ) - $ + f4*f6*f4 * src3(is ,js+2,ks ) - $ + f5*f6*f4 * src3(is+1,js+2,ks ) - $ + f6*f6*f4 * src3(is+2,js+2,ks ) - $ + f7*f6*f4 * src3(is+3,js+2,ks ) - $ + f8*f6*f4 * src3(is+4,js+2,ks ) - $ + f1*f7*f4 * src3(is-3,js+3,ks ) - $ + f2*f7*f4 * src3(is-2,js+3,ks ) - $ + f3*f7*f4 * src3(is-1,js+3,ks ) - $ + f4*f7*f4 * src3(is ,js+3,ks ) - $ + f5*f7*f4 * src3(is+1,js+3,ks ) - $ + f6*f7*f4 * src3(is+2,js+3,ks ) - $ + f7*f7*f4 * src3(is+3,js+3,ks ) - $ + f8*f7*f4 * src3(is+4,js+3,ks ) - $ + f1*f8*f4 * src3(is-3,js+4,ks ) - $ + f2*f8*f4 * src3(is-2,js+4,ks ) - $ + f3*f8*f4 * src3(is-1,js+4,ks ) - $ + f4*f8*f4 * src3(is ,js+4,ks ) - $ + f5*f8*f4 * src3(is+1,js+4,ks ) - $ + f6*f8*f4 * src3(is+2,js+4,ks ) - $ + f7*f8*f4 * src3(is+3,js+4,ks ) - $ + f8*f8*f4 * src3(is+4,js+4,ks ) - res35 = - $ + f1*f1*f5 * src3(is-3,js-3,ks+1) - $ + f2*f1*f5 * src3(is-2,js-3,ks+1) - $ + f3*f1*f5 * src3(is-1,js-3,ks+1) - $ + f4*f1*f5 * src3(is ,js-3,ks+1) - $ + f5*f1*f5 * src3(is+1,js-3,ks+1) - $ + f6*f1*f5 * src3(is+2,js-3,ks+1) - $ + f7*f1*f5 * src3(is+3,js-3,ks+1) - $ + f8*f1*f5 * src3(is+4,js-3,ks+1) - $ + f1*f2*f5 * src3(is-3,js-2,ks+1) - $ + f2*f2*f5 * src3(is-2,js-2,ks+1) - $ + f3*f2*f5 * src3(is-1,js-2,ks+1) - $ + f4*f2*f5 * src3(is ,js-2,ks+1) - $ + f5*f2*f5 * src3(is+1,js-2,ks+1) - $ + f6*f2*f5 * src3(is+2,js-2,ks+1) - $ + f7*f2*f5 * src3(is+3,js-2,ks+1) - $ + f8*f2*f5 * src3(is+4,js-2,ks+1) - $ + f1*f3*f5 * src3(is-3,js-1,ks+1) - $ + f2*f3*f5 * src3(is-2,js-1,ks+1) - $ + f3*f3*f5 * src3(is-1,js-1,ks+1) - $ + f4*f3*f5 * src3(is ,js-1,ks+1) - $ + f5*f3*f5 * src3(is+1,js-1,ks+1) - $ + f6*f3*f5 * src3(is+2,js-1,ks+1) - $ + f7*f3*f5 * src3(is+3,js-1,ks+1) - $ + f8*f3*f5 * src3(is+4,js-1,ks+1) - $ + f1*f4*f5 * src3(is-3,js ,ks+1) - $ + f2*f4*f5 * src3(is-2,js ,ks+1) - $ + f3*f4*f5 * src3(is-1,js ,ks+1) - $ + f4*f4*f5 * src3(is ,js ,ks+1) - $ + f5*f4*f5 * src3(is+1,js ,ks+1) - $ + f6*f4*f5 * src3(is+2,js ,ks+1) - $ + f7*f4*f5 * src3(is+3,js ,ks+1) - $ + f8*f4*f5 * src3(is+4,js ,ks+1) - $ + f1*f5*f5 * src3(is-3,js+1,ks+1) - $ + f2*f5*f5 * src3(is-2,js+1,ks+1) - $ + f3*f5*f5 * src3(is-1,js+1,ks+1) - $ + f4*f5*f5 * src3(is ,js+1,ks+1) - $ + f5*f5*f5 * src3(is+1,js+1,ks+1) - $ + f6*f5*f5 * src3(is+2,js+1,ks+1) - $ + f7*f5*f5 * src3(is+3,js+1,ks+1) - $ + f8*f5*f5 * src3(is+4,js+1,ks+1) - $ + f1*f6*f5 * src3(is-3,js+2,ks+1) - $ + f2*f6*f5 * src3(is-2,js+2,ks+1) - $ + f3*f6*f5 * src3(is-1,js+2,ks+1) - $ + f4*f6*f5 * src3(is ,js+2,ks+1) - $ + f5*f6*f5 * src3(is+1,js+2,ks+1) - $ + f6*f6*f5 * src3(is+2,js+2,ks+1) - $ + f7*f6*f5 * src3(is+3,js+2,ks+1) - $ + f8*f6*f5 * src3(is+4,js+2,ks+1) - $ + f1*f7*f5 * src3(is-3,js+3,ks+1) - $ + f2*f7*f5 * src3(is-2,js+3,ks+1) - $ + f3*f7*f5 * src3(is-1,js+3,ks+1) - $ + f4*f7*f5 * src3(is ,js+3,ks+1) - $ + f5*f7*f5 * src3(is+1,js+3,ks+1) - $ + f6*f7*f5 * src3(is+2,js+3,ks+1) - $ + f7*f7*f5 * src3(is+3,js+3,ks+1) - $ + f8*f7*f5 * src3(is+4,js+3,ks+1) - $ + f1*f8*f5 * src3(is-3,js+4,ks+1) - $ + f2*f8*f5 * src3(is-2,js+4,ks+1) - $ + f3*f8*f5 * src3(is-1,js+4,ks+1) - $ + f4*f8*f5 * src3(is ,js+4,ks+1) - $ + f5*f8*f5 * src3(is+1,js+4,ks+1) - $ + f6*f8*f5 * src3(is+2,js+4,ks+1) - $ + f7*f8*f5 * src3(is+3,js+4,ks+1) - $ + f8*f8*f5 * src3(is+4,js+4,ks+1) - res36 = - $ + f1*f1*f6 * src3(is-3,js-3,ks+2) - $ + f2*f1*f6 * src3(is-2,js-3,ks+2) - $ + f3*f1*f6 * src3(is-1,js-3,ks+2) - $ + f4*f1*f6 * src3(is ,js-3,ks+2) - $ + f5*f1*f6 * src3(is+1,js-3,ks+2) - $ + f6*f1*f6 * src3(is+2,js-3,ks+2) - $ + f7*f1*f6 * src3(is+3,js-3,ks+2) - $ + f8*f1*f6 * src3(is+4,js-3,ks+2) - $ + f1*f2*f6 * src3(is-3,js-2,ks+2) - $ + f2*f2*f6 * src3(is-2,js-2,ks+2) - $ + f3*f2*f6 * src3(is-1,js-2,ks+2) - $ + f4*f2*f6 * src3(is ,js-2,ks+2) - $ + f5*f2*f6 * src3(is+1,js-2,ks+2) - $ + f6*f2*f6 * src3(is+2,js-2,ks+2) - $ + f7*f2*f6 * src3(is+3,js-2,ks+2) - $ + f8*f2*f6 * src3(is+4,js-2,ks+2) - $ + f1*f3*f6 * src3(is-3,js-1,ks+2) - $ + f2*f3*f6 * src3(is-2,js-1,ks+2) - $ + f3*f3*f6 * src3(is-1,js-1,ks+2) - $ + f4*f3*f6 * src3(is ,js-1,ks+2) - $ + f5*f3*f6 * src3(is+1,js-1,ks+2) - $ + f6*f3*f6 * src3(is+2,js-1,ks+2) - $ + f7*f3*f6 * src3(is+3,js-1,ks+2) - $ + f8*f3*f6 * src3(is+4,js-1,ks+2) - $ + f1*f4*f6 * src3(is-3,js ,ks+2) - $ + f2*f4*f6 * src3(is-2,js ,ks+2) - $ + f3*f4*f6 * src3(is-1,js ,ks+2) - $ + f4*f4*f6 * src3(is ,js ,ks+2) - $ + f5*f4*f6 * src3(is+1,js ,ks+2) - $ + f6*f4*f6 * src3(is+2,js ,ks+2) - $ + f7*f4*f6 * src3(is+3,js ,ks+2) - $ + f8*f4*f6 * src3(is+4,js ,ks+2) - $ + f1*f5*f6 * src3(is-3,js+1,ks+2) - $ + f2*f5*f6 * src3(is-2,js+1,ks+2) - $ + f3*f5*f6 * src3(is-1,js+1,ks+2) - $ + f4*f5*f6 * src3(is ,js+1,ks+2) - $ + f5*f5*f6 * src3(is+1,js+1,ks+2) - $ + f6*f5*f6 * src3(is+2,js+1,ks+2) - $ + f7*f5*f6 * src3(is+3,js+1,ks+2) - $ + f8*f5*f6 * src3(is+4,js+1,ks+2) - $ + f1*f6*f6 * src3(is-3,js+2,ks+2) - $ + f2*f6*f6 * src3(is-2,js+2,ks+2) - $ + f3*f6*f6 * src3(is-1,js+2,ks+2) - $ + f4*f6*f6 * src3(is ,js+2,ks+2) - $ + f5*f6*f6 * src3(is+1,js+2,ks+2) - $ + f6*f6*f6 * src3(is+2,js+2,ks+2) - $ + f7*f6*f6 * src3(is+3,js+2,ks+2) - $ + f8*f6*f6 * src3(is+4,js+2,ks+2) - $ + f1*f7*f6 * src3(is-3,js+3,ks+2) - $ + f2*f7*f6 * src3(is-2,js+3,ks+2) - $ + f3*f7*f6 * src3(is-1,js+3,ks+2) - $ + f4*f7*f6 * src3(is ,js+3,ks+2) - $ + f5*f7*f6 * src3(is+1,js+3,ks+2) - $ + f6*f7*f6 * src3(is+2,js+3,ks+2) - $ + f7*f7*f6 * src3(is+3,js+3,ks+2) - $ + f8*f7*f6 * src3(is+4,js+3,ks+2) - $ + f1*f8*f6 * src3(is-3,js+4,ks+2) - $ + f2*f8*f6 * src3(is-2,js+4,ks+2) - $ + f3*f8*f6 * src3(is-1,js+4,ks+2) - $ + f4*f8*f6 * src3(is ,js+4,ks+2) - $ + f5*f8*f6 * src3(is+1,js+4,ks+2) - $ + f6*f8*f6 * src3(is+2,js+4,ks+2) - $ + f7*f8*f6 * src3(is+3,js+4,ks+2) - $ + f8*f8*f6 * src3(is+4,js+4,ks+2) - res37 = - $ + f1*f1*f7 * src3(is-3,js-3,ks+3) - $ + f2*f1*f7 * src3(is-2,js-3,ks+3) - $ + f3*f1*f7 * src3(is-1,js-3,ks+3) - $ + f4*f1*f7 * src3(is ,js-3,ks+3) - $ + f5*f1*f7 * src3(is+1,js-3,ks+3) - $ + f6*f1*f7 * src3(is+2,js-3,ks+3) - $ + f7*f1*f7 * src3(is+3,js-3,ks+3) - $ + f8*f1*f7 * src3(is+4,js-3,ks+3) - $ + f1*f2*f7 * src3(is-3,js-2,ks+3) - $ + f2*f2*f7 * src3(is-2,js-2,ks+3) - $ + f3*f2*f7 * src3(is-1,js-2,ks+3) - $ + f4*f2*f7 * src3(is ,js-2,ks+3) - $ + f5*f2*f7 * src3(is+1,js-2,ks+3) - $ + f6*f2*f7 * src3(is+2,js-2,ks+3) - $ + f7*f2*f7 * src3(is+3,js-2,ks+3) - $ + f8*f2*f7 * src3(is+4,js-2,ks+3) - $ + f1*f3*f7 * src3(is-3,js-1,ks+3) - $ + f2*f3*f7 * src3(is-2,js-1,ks+3) - $ + f3*f3*f7 * src3(is-1,js-1,ks+3) - $ + f4*f3*f7 * src3(is ,js-1,ks+3) - $ + f5*f3*f7 * src3(is+1,js-1,ks+3) - $ + f6*f3*f7 * src3(is+2,js-1,ks+3) - $ + f7*f3*f7 * src3(is+3,js-1,ks+3) - $ + f8*f3*f7 * src3(is+4,js-1,ks+3) - $ + f1*f4*f7 * src3(is-3,js ,ks+3) - $ + f2*f4*f7 * src3(is-2,js ,ks+3) - $ + f3*f4*f7 * src3(is-1,js ,ks+3) - $ + f4*f4*f7 * src3(is ,js ,ks+3) - $ + f5*f4*f7 * src3(is+1,js ,ks+3) - $ + f6*f4*f7 * src3(is+2,js ,ks+3) - $ + f7*f4*f7 * src3(is+3,js ,ks+3) - $ + f8*f4*f7 * src3(is+4,js ,ks+3) - $ + f1*f5*f7 * src3(is-3,js+1,ks+3) - $ + f2*f5*f7 * src3(is-2,js+1,ks+3) - $ + f3*f5*f7 * src3(is-1,js+1,ks+3) - $ + f4*f5*f7 * src3(is ,js+1,ks+3) - $ + f5*f5*f7 * src3(is+1,js+1,ks+3) - $ + f6*f5*f7 * src3(is+2,js+1,ks+3) - $ + f7*f5*f7 * src3(is+3,js+1,ks+3) - $ + f8*f5*f7 * src3(is+4,js+1,ks+3) - $ + f1*f6*f7 * src3(is-3,js+2,ks+3) - $ + f2*f6*f7 * src3(is-2,js+2,ks+3) - $ + f3*f6*f7 * src3(is-1,js+2,ks+3) - $ + f4*f6*f7 * src3(is ,js+2,ks+3) - $ + f5*f6*f7 * src3(is+1,js+2,ks+3) - $ + f6*f6*f7 * src3(is+2,js+2,ks+3) - $ + f7*f6*f7 * src3(is+3,js+2,ks+3) - $ + f8*f6*f7 * src3(is+4,js+2,ks+3) - $ + f1*f7*f7 * src3(is-3,js+3,ks+3) - $ + f2*f7*f7 * src3(is-2,js+3,ks+3) - $ + f3*f7*f7 * src3(is-1,js+3,ks+3) - $ + f4*f7*f7 * src3(is ,js+3,ks+3) - $ + f5*f7*f7 * src3(is+1,js+3,ks+3) - $ + f6*f7*f7 * src3(is+2,js+3,ks+3) - $ + f7*f7*f7 * src3(is+3,js+3,ks+3) - $ + f8*f7*f7 * src3(is+4,js+3,ks+3) - $ + f1*f8*f7 * src3(is-3,js+4,ks+3) - $ + f2*f8*f7 * src3(is-2,js+4,ks+3) - $ + f3*f8*f7 * src3(is-1,js+4,ks+3) - $ + f4*f8*f7 * src3(is ,js+4,ks+3) - $ + f5*f8*f7 * src3(is+1,js+4,ks+3) - $ + f6*f8*f7 * src3(is+2,js+4,ks+3) - $ + f7*f8*f7 * src3(is+3,js+4,ks+3) - $ + f8*f8*f7 * src3(is+4,js+4,ks+3) - res38 = - $ + f1*f1*f8 * src3(is-3,js-3,ks+4) - $ + f2*f1*f8 * src3(is-2,js-3,ks+4) - $ + f3*f1*f8 * src3(is-1,js-3,ks+4) - $ + f4*f1*f8 * src3(is ,js-3,ks+4) - $ + f5*f1*f8 * src3(is+1,js-3,ks+4) - $ + f6*f1*f8 * src3(is+2,js-3,ks+4) - $ + f7*f1*f8 * src3(is+3,js-3,ks+4) - $ + f8*f1*f8 * src3(is+4,js-3,ks+4) - $ + f1*f2*f8 * src3(is-3,js-2,ks+4) - $ + f2*f2*f8 * src3(is-2,js-2,ks+4) - $ + f3*f2*f8 * src3(is-1,js-2,ks+4) - $ + f4*f2*f8 * src3(is ,js-2,ks+4) - $ + f5*f2*f8 * src3(is+1,js-2,ks+4) - $ + f6*f2*f8 * src3(is+2,js-2,ks+4) - $ + f7*f2*f8 * src3(is+3,js-2,ks+4) - $ + f8*f2*f8 * src3(is+4,js-2,ks+4) - $ + f1*f3*f8 * src3(is-3,js-1,ks+4) - $ + f2*f3*f8 * src3(is-2,js-1,ks+4) - $ + f3*f3*f8 * src3(is-1,js-1,ks+4) - $ + f4*f3*f8 * src3(is ,js-1,ks+4) - $ + f5*f3*f8 * src3(is+1,js-1,ks+4) - $ + f6*f3*f8 * src3(is+2,js-1,ks+4) - $ + f7*f3*f8 * src3(is+3,js-1,ks+4) - $ + f8*f3*f8 * src3(is+4,js-1,ks+4) - $ + f1*f4*f8 * src3(is-3,js ,ks+4) - $ + f2*f4*f8 * src3(is-2,js ,ks+4) - $ + f3*f4*f8 * src3(is-1,js ,ks+4) - $ + f4*f4*f8 * src3(is ,js ,ks+4) - $ + f5*f4*f8 * src3(is+1,js ,ks+4) - $ + f6*f4*f8 * src3(is+2,js ,ks+4) - $ + f7*f4*f8 * src3(is+3,js ,ks+4) - $ + f8*f4*f8 * src3(is+4,js ,ks+4) - $ + f1*f5*f8 * src3(is-3,js+1,ks+4) - $ + f2*f5*f8 * src3(is-2,js+1,ks+4) - $ + f3*f5*f8 * src3(is-1,js+1,ks+4) - $ + f4*f5*f8 * src3(is ,js+1,ks+4) - $ + f5*f5*f8 * src3(is+1,js+1,ks+4) - $ + f6*f5*f8 * src3(is+2,js+1,ks+4) - $ + f7*f5*f8 * src3(is+3,js+1,ks+4) - $ + f8*f5*f8 * src3(is+4,js+1,ks+4) - $ + f1*f6*f8 * src3(is-3,js+2,ks+4) - $ + f2*f6*f8 * src3(is-2,js+2,ks+4) - $ + f3*f6*f8 * src3(is-1,js+2,ks+4) - $ + f4*f6*f8 * src3(is ,js+2,ks+4) - $ + f5*f6*f8 * src3(is+1,js+2,ks+4) - $ + f6*f6*f8 * src3(is+2,js+2,ks+4) - $ + f7*f6*f8 * src3(is+3,js+2,ks+4) - $ + f8*f6*f8 * src3(is+4,js+2,ks+4) - $ + f1*f7*f8 * src3(is-3,js+3,ks+4) - $ + f2*f7*f8 * src3(is-2,js+3,ks+4) - $ + f3*f7*f8 * src3(is-1,js+3,ks+4) - $ + f4*f7*f8 * src3(is ,js+3,ks+4) - $ + f5*f7*f8 * src3(is+1,js+3,ks+4) - $ + f6*f7*f8 * src3(is+2,js+3,ks+4) - $ + f7*f7*f8 * src3(is+3,js+3,ks+4) - $ + f8*f7*f8 * src3(is+4,js+3,ks+4) - $ + f1*f8*f8 * src3(is-3,js+4,ks+4) - $ + f2*f8*f8 * src3(is-2,js+4,ks+4) - $ + f3*f8*f8 * src3(is-1,js+4,ks+4) - $ + f4*f8*f8 * src3(is ,js+4,ks+4) - $ + f5*f8*f8 * src3(is+1,js+4,ks+4) - $ + f6*f8*f8 * src3(is+2,js+4,ks+4) - $ + f7*f8*f8 * src3(is+3,js+4,ks+4) - $ + f8*f8*f8 * src3(is+4,js+4,ks+4) - dst(id,jd,kd) = - $ + s1fac * (res11 + res12 + res13 + res14 + res15 + res16) - $ + s2fac * (res21 + res22 + res23 + res24 + res25 + res26) - $ + s3fac * (res31 + res32 + res33 + res34 + res35 + res36) - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8110 - goto 911 - -c end i loop - 911 continue - j = j+1 - jd = jd+1 - js = js+1 - if (j.lt.regjext) goto 810 - goto 91 - -c end j loop - 91 continue - k = k+1 - kd = kd+1 - ks = ks+1 - if (k.lt.regkext) goto 80 - goto 9 - -c end k loop - 9 continue - - end diff --git a/Carpet/CarpetLib/src/prolongate_3d_real8_3tl_rf2.F77 b/Carpet/CarpetLib/src/prolongate_3d_real8_3tl_rf2.F77 deleted file mode 100644 index 30d2e9686..000000000 --- a/Carpet/CarpetLib/src/prolongate_3d_real8_3tl_rf2.F77 +++ /dev/null @@ -1,429 +0,0 @@ -c -*-Fortran-*- - -#include "cctk.h" -#include "cctk_Parameters.h" - - - - subroutine prolongate_3d_real8_3tl_rf2 ( - $ src1, t1, src2, t2, src3, t3, srciext, srcjext, srckext, - $ dst, t, dstiext, dstjext, dstkext, - $ srcbbox, dstbbox, regbbox) - - implicit none - - DECLARE_CCTK_PARAMETERS - - CCTK_REAL8 eps - parameter (eps = 1.0d-10) - - CCTK_REAL8 one, half, fourth, eighth - parameter (one = 1) - parameter (half = one/2) - parameter (fourth = one/4) - parameter (eighth = one/8) - - integer srciext, srcjext, srckext - CCTK_REAL8 src1(srciext,srcjext,srckext) - CCTK_REAL8 t1 - CCTK_REAL8 src2(srciext,srcjext,srckext) - CCTK_REAL8 t2 - CCTK_REAL8 src3(srciext,srcjext,srckext) - CCTK_REAL8 t3 - integer dstiext, dstjext, dstkext - CCTK_REAL8 dst(dstiext,dstjext,dstkext) - CCTK_REAL8 t -c bbox(:,1) is lower boundary (inclusive) -c bbox(:,2) is upper boundary (inclusive) -c bbox(:,3) is stride - integer srcbbox(3,3), dstbbox(3,3), regbbox(3,3) - - integer regiext, regjext, regkext - - integer srcioff, srcjoff, srckoff - integer dstioff, dstjoff, dstkoff - - CCTK_REAL8 s1fac, s2fac, s3fac - - integer i0, j0, k0 - integer fi, fj, fk - integer is, js, ks - integer id, jd, kd - integer i, j, k - - integer d - - - - do d=1,3 - if (srcbbox(d,3).eq.0 .or. dstbbox(d,3).eq.0 - $ .or. regbbox(d,3).eq.0) then - call CCTK_WARN (0, "Internal error: stride is zero") - end if - if (srcbbox(d,3).le.regbbox(d,3) - $ .or. dstbbox(d,3).ne.regbbox(d,3)) then - call CCTK_WARN (0, "Internal error: strides disagree") - end if - if (srcbbox(d,3).ne.dstbbox(d,3)*2) then - call CCTK_WARN (0, "Internal error: source strides are not twice the destination strides") - end if - if (mod(srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array origins are not integer multiples of the strides") - end if - if (regbbox(d,1).gt.regbbox(d,2)) then -c This could be handled, but is likely to point to an error elsewhere - call CCTK_WARN (0, "Internal error: region extent is empty") - end if - if (mod(srcbbox(d,2) - srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,2) - dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,2) - regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array extents are not integer multiples of the strides") - end if - if (regbbox(d,1).lt.srcbbox(d,1) - $ .or. regbbox(d,1).lt.dstbbox(d,1) - $ .or. regbbox(d,2).gt.srcbbox(d,2) - $ .or. regbbox(d,2).gt.dstbbox(d,2)) then - call CCTK_WARN (0, "Internal error: region extent is not contained in array extent") - end if - end do - - if (srciext.ne.(srcbbox(1,2)-srcbbox(1,1))/srcbbox(1,3)+1 - $ .or. srcjext.ne.(srcbbox(2,2)-srcbbox(2,1))/srcbbox(2,3)+1 - $ .or. srckext.ne.(srcbbox(3,2)-srcbbox(3,1))/srcbbox(3,3)+1 - $ .or. dstiext.ne.(dstbbox(1,2)-dstbbox(1,1))/dstbbox(1,3)+1 - $ .or. dstjext.ne.(dstbbox(2,2)-dstbbox(2,1))/dstbbox(2,3)+1 - $ .or. dstkext.ne.(dstbbox(3,2)-dstbbox(3,1))/dstbbox(3,3)+1) then - call CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes") - end if - - - - regiext = (regbbox(1,2) - regbbox(1,1)) / regbbox(1,3) + 1 - regjext = (regbbox(2,2) - regbbox(2,1)) / regbbox(2,3) + 1 - regkext = (regbbox(3,2) - regbbox(3,1)) / regbbox(3,3) + 1 - - srcioff = (regbbox(1,1) - srcbbox(1,1)) / dstbbox(1,3) - srcjoff = (regbbox(2,1) - srcbbox(2,1)) / dstbbox(2,3) - srckoff = (regbbox(3,1) - srcbbox(3,1)) / dstbbox(3,3) - - dstioff = (regbbox(1,1) - dstbbox(1,1)) / dstbbox(1,3) - dstjoff = (regbbox(2,1) - dstbbox(2,1)) / dstbbox(2,3) - dstkoff = (regbbox(3,1) - dstbbox(3,1)) / dstbbox(3,3) - - - -c Quadratic (second order) time interpolation - if (t1.eq.t2 .or. t1.eq.t3 .or. t2.eq.t3) then - call CCTK_WARN (0, "Internal error: arrays have same time") - end if - if (t.lt.min(t1,t2,t3)-eps .or. t.gt.max(t1,t2,t3)+eps) then - call CCTK_WARN (0, "Internal error: extrapolation in time") - end if - - s1fac = (t - t2) * (t - t3) / ((t1 - t2) * (t1 - t3)) - s2fac = (t - t1) * (t - t3) / ((t2 - t1) * (t2 - t3)) - s3fac = (t - t1) * (t - t2) / ((t3 - t1) * (t3 - t2)) - - - - fi = mod(srcioff, 2) - fj = mod(srcjoff, 2) - fk = mod(srckoff, 2) - - i0 = srcioff / 2 - j0 = srcjoff / 2 - k0 = srckoff / 2 - - - -c Loop over fine region -c Label scheme: 8 fk fj fi - -c begin k loop - 8 continue - k = 0 - ks = k0+1 - kd = dstkoff+1 - if (fk.eq.0) goto 80 - if (fk.eq.1) goto 81 - stop - -c begin j loop - 80 continue - j = 0 - js = j0+1 - jd = dstjoff+1 - if (fj.eq.0) goto 800 - if (fj.eq.1) goto 801 - stop - -c begin i loop - 800 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8000 - if (fi.eq.1) goto 8001 - stop - -c kernel - 8000 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js,ks, 1,1,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + s1fac * src1(is,js,ks) - $ + s2fac * src2(is,js,ks) - $ + s3fac * src3(is,js,ks) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8001 - goto 900 - -c kernel - 8001 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js,ks, 2,1,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + half * s1fac * src1(is,js,ks) + half * s1fac * src1(is+1,js,ks) - $ + half * s2fac * src2(is,js,ks) + half * s2fac * src2(is+1,js,ks) - $ + half * s3fac * src3(is,js,ks) + half * s3fac * src3(is+1,js,ks) - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8000 - goto 900 - -c end i loop - 900 continue - j = j+1 - jd = jd+1 - if (j.lt.regjext) goto 801 - goto 90 - -c begin i loop - 801 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8010 - if (fi.eq.1) goto 8011 - stop - -c kernel - 8010 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js,ks, 1,2,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + half * s1fac * src1(is,js,ks) + half * s1fac * src1(is,js+1,ks) - $ + half * s2fac * src2(is,js,ks) + half * s2fac * src2(is,js+1,ks) - $ + half * s3fac * src3(is,js,ks) + half * s3fac * src3(is,js+1,ks) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8011 - goto 901 - -c kernel - 8011 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js,ks, 2,2,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + fourth * s1fac * src1(is,js,ks) - $ + fourth * s1fac * src1(is+1,js,ks) - $ + fourth * s1fac * src1(is,js+1,ks) - $ + fourth * s1fac * src1(is+1,js+1,ks) - $ + fourth * s2fac * src2(is,js,ks) - $ + fourth * s2fac * src2(is+1,js,ks) - $ + fourth * s2fac * src2(is,js+1,ks) - $ + fourth * s2fac * src2(is+1,js+1,ks) - $ + fourth * s3fac * src3(is,js,ks) - $ + fourth * s3fac * src3(is+1,js,ks) - $ + fourth * s3fac * src3(is,js+1,ks) - $ + fourth * s3fac * src3(is+1,js+1,ks) - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8010 - goto 901 - -c end i loop - 901 continue - j = j+1 - jd = jd+1 - js = js+1 - if (j.lt.regjext) goto 800 - goto 90 - -c end j loop - 90 continue - k = k+1 - kd = kd+1 - if (k.lt.regkext) goto 81 - goto 9 - -c begin j loop - 81 continue - j = 0 - js = j0+1 - jd = dstjoff+1 - if (fj.eq.0) goto 810 - if (fj.eq.1) goto 811 - stop - -c begin i loop - 810 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8100 - if (fi.eq.1) goto 8101 - stop - -c kernel - 8100 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js,ks, 1,1,2, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + half * s1fac * src1(is,js,ks) + half * s1fac * src1(is,js,ks+1) - $ + half * s2fac * src2(is,js,ks) + half * s2fac * src2(is,js,ks+1) - $ + half * s3fac * src3(is,js,ks) + half * s3fac * src3(is,js,ks+1) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8101 - goto 910 - -c kernel - 8101 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js,ks, 2,1,2, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + fourth * s1fac * src1(is,js,ks) - $ + fourth * s1fac * src1(is+1,js,ks) - $ + fourth * s1fac * src1(is,js,ks+1) - $ + fourth * s1fac * src1(is+1,js,ks+1) - $ + fourth * s2fac * src1(is,js,ks) - $ + fourth * s2fac * src2(is+1,js,ks) - $ + fourth * s2fac * src2(is,js,ks+1) - $ + fourth * s2fac * src2(is+1,js,ks+1) - $ + fourth * s3fac * src3(is,js,ks) - $ + fourth * s3fac * src3(is+1,js,ks) - $ + fourth * s3fac * src3(is,js,ks+1) - $ + fourth * s3fac * src3(is+1,js,ks+1) - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8100 - goto 910 - -c end i loop - 910 continue - j = j+1 - jd = jd+1 - if (j.lt.regjext) goto 811 - goto 91 - -c begin i loop - 811 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8110 - if (fi.eq.1) goto 8111 - stop - -c kernel - 8110 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js,ks, 1,2,2, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + fourth * s1fac * src1(is,js,ks) - $ + fourth * s1fac * src1(is,js+1,ks) - $ + fourth * s1fac * src1(is,js,ks+1) - $ + fourth * s1fac * src1(is,js+1,ks+1) - $ + fourth * s2fac * src2(is,js,ks) - $ + fourth * s2fac * src2(is,js+1,ks) - $ + fourth * s2fac * src2(is,js,ks+1) - $ + fourth * s2fac * src2(is,js+1,ks+1) - $ + fourth * s3fac * src3(is,js,ks) - $ + fourth * s3fac * src3(is,js+1,ks) - $ + fourth * s3fac * src3(is,js,ks+1) - $ + fourth * s3fac * src3(is,js+1,ks+1) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8111 - goto 911 - -c kernel - 8111 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js,ks, 2,2,2, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + eighth * s1fac * src1(is,js,ks) - $ + eighth * s1fac * src1(is+1,js,ks) - $ + eighth * s1fac * src1(is,js+1,ks) - $ + eighth * s1fac * src1(is+1,js+1,ks) - $ + eighth * s1fac * src1(is,js,ks+1) - $ + eighth * s1fac * src1(is+1,js,ks+1) - $ + eighth * s1fac * src1(is,js+1,ks+1) - $ + eighth * s1fac * src1(is+1,js+1,ks+1) - $ - $ + eighth * s2fac * src2(is,js,ks) - $ + eighth * s2fac * src2(is+1,js,ks) - $ + eighth * s2fac * src2(is,js+1,ks) - $ + eighth * s2fac * src2(is+1,js+1,ks) - $ + eighth * s2fac * src2(is,js,ks+1) - $ + eighth * s2fac * src2(is+1,js,ks+1) - $ + eighth * s2fac * src2(is,js+1,ks+1) - $ + eighth * s2fac * src2(is+1,js+1,ks+1) - $ - $ + eighth * s3fac * src3(is,js,ks) - $ + eighth * s3fac * src3(is+1,js,ks) - $ + eighth * s3fac * src3(is,js+1,ks) - $ + eighth * s3fac * src3(is+1,js+1,ks) - $ + eighth * s3fac * src3(is,js,ks+1) - $ + eighth * s3fac * src3(is+1,js,ks+1) - $ + eighth * s3fac * src3(is,js+1,ks+1) - $ + eighth * s3fac * src3(is+1,js+1,ks+1) - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8110 - goto 911 - -c end i loop - 911 continue - j = j+1 - jd = jd+1 - js = js+1 - if (j.lt.regjext) goto 810 - goto 91 - -c end j loop - 91 continue - k = k+1 - kd = kd+1 - ks = ks+1 - if (k.lt.regkext) goto 80 - goto 9 - -c end k loop - 9 continue - - end diff --git a/Carpet/CarpetLib/src/prolongate_3d_real8_3tl_weno.F90 b/Carpet/CarpetLib/src/prolongate_3d_real8_3tl_weno.F90 deleted file mode 100644 index e7f2839bc..000000000 --- a/Carpet/CarpetLib/src/prolongate_3d_real8_3tl_weno.F90 +++ /dev/null @@ -1,365 +0,0 @@ -#ifndef OMIT_F90 -#include "cctk.h" - - -!!$ This routine performs "WENO" prolongation. It is intended to be used -!!$ with GFs that are not expected to be smooth, particularly those -!!$ that must also obey certain constraints. The obvious example is the -!!$ density in hydrodynamics, which may be discontinuous yet must be -!!$ strictly positive. -!!$ -!!$ To ensure that this prolongation method is used you should add the -!!$ tag -!!$ -!!$ tags='Prolongation="WENO"' -!!$ -!!$ to the interface.ccl on the appropriate group. -!!$ -!!$ This applies WENO2 type limiting to the slope, checking over the -!!$ entire coarse grid cell for the least oscillatory quadratic in each -!!$ direction. If the slope changes sign over the extrema, linear -!!$ interpolation is used instead. -!!$ -!!$ The actual weno1d function is defined in the routine -!!$ -!!$ prolongate_3d_real8_weno.F77 - - -#define CHKIDX(i,j,k, imax,jmax,kmax, where) \ -if ((i).lt.1 .or. (i).gt.(imax) \ - .or. (j).lt.1 .or. (j).gt.(jmax) \ - .or. (k).lt.1 .or. (k).gt.(kmax)) then &&\ - write (msg, '(a, " array index out of bounds: shape is (",i4,",",i4,",",i4,"), index is (",i4,",",i4,",",i4,")")') \ - (where), (imax), (jmax), (kmax), (i), (j), (k) &&\ - call CCTK_WARN (0, msg(1:len_trim(msg))) &&\ -end if - -subroutine prolongate_3d_real8_3tl_weno (src1, t1, src2, t2, & - src3, t3, srciext, srcjext, srckext, dst, t, dstiext, & - dstjext, dstkext, srcbbox, dstbbox, regbbox) - - implicit none - - CCTK_REAL8 one - parameter (one = 1) - - CCTK_REAL8 eps - parameter (eps = 1.0d-10) - - integer srciext, srcjext, srckext - CCTK_REAL8 src1(srciext,srcjext,srckext) - CCTK_REAL8 t1 - CCTK_REAL8 src2(srciext,srcjext,srckext) - CCTK_REAL8 t2 - CCTK_REAL8 src3(srciext,srcjext,srckext) - CCTK_REAL8 t3 - integer dstiext, dstjext, dstkext - CCTK_REAL8 dst(dstiext,dstjext,dstkext) - CCTK_REAL8 t -!!$ bbox(:,1) is lower boundary (inclusive) -!!$ bbox(:,2) is upper boundary (inclusive) -!!$ bbox(:,3) is stride - integer srcbbox(3,3), dstbbox(3,3), regbbox(3,3) - - integer offsetlo, offsethi - - integer regiext, regjext, regkext - - integer dstifac, dstjfac, dstkfac - - integer srcioff, srcjoff, srckoff - integer dstioff, dstjoff, dstkoff - - CCTK_REAL8 s1fac, s2fac, s3fac, tmps1fac, tmps2fac, tmps3fac - - integer i, j, k - integer i0, j0, k0 - integer fi, fj, fk - integer ii, jj, kk - integer d - - CCTK_REAL8, dimension(0:4,0:4) :: tmp1 - CCTK_REAL8, dimension(0:4) :: tmp2 - CCTK_REAL8 :: dsttmp1, dsttmp2, dsttmp3 - - external weno1d - CCTK_REAL8 weno1d - - CCTK_REAL8 half, zero - parameter (half = 0.5) - parameter (zero = 0) - - do d=1,3 - if (srcbbox(d,3).eq.0 .or. dstbbox(d,3).eq.0 & - .or. regbbox(d,3).eq.0) then - call CCTK_WARN (0, "Internal error: stride is zero") - end if - if (srcbbox(d,3).le.regbbox(d,3) & - .or. dstbbox(d,3).ne.regbbox(d,3)) then - call CCTK_WARN (0, "Internal error: strides disagree") - end if - if (mod(srcbbox(d,3), dstbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: destination strides are not integer multiples of the source strides") - end if - if (mod(srcbbox(d,1), srcbbox(d,3)).ne.0 & - .or. mod(dstbbox(d,1), dstbbox(d,3)).ne.0 & - .or. mod(regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array origins are not integer multiples of the strides") - end if - if (regbbox(d,1).gt.regbbox(d,2)) then -!!$ This could be handled, but is likely to point to an error elsewhere - call CCTK_WARN (0, "Internal error: region extent is empty") - end if - regkext = (regbbox(d,2) - regbbox(d,1)) / regbbox(d,3) + 1 - dstkfac = srcbbox(d,3) / dstbbox(d,3) - srckoff = (regbbox(d,1) - srcbbox(d,1)) / dstbbox(d,3) - offsetlo = regbbox(d,3) - if (mod(srckoff + 0, dstkfac).eq.0) then - offsetlo = 0 - if (regkext.gt.1) then - offsetlo = regbbox(d,3) - end if - end if - offsethi = regbbox(d,3) - if (mod(srckoff + regkext-1, dstkfac).eq.0) then - offsethi = 0 - if (regkext.gt.1) then - offsethi = regbbox(d,3) - end if - end if - if (regbbox(d,1)-offsetlo.lt.srcbbox(d,1) & - .or. regbbox(d,2)+offsethi.gt.srcbbox(d,2) & - .or. regbbox(d,1).lt.dstbbox(d,1) & - .or. regbbox(d,2).gt.dstbbox(d,2)) then - call CCTK_WARN (0, "Internal error: region extent is not contained in array extent") - end if - end do - - if (srciext.ne.(srcbbox(1,2)-srcbbox(1,1))/srcbbox(1,3)+1 & - .or. srcjext.ne.(srcbbox(2,2)-srcbbox(2,1))/srcbbox(2,3)+1 & - .or. srckext.ne.(srcbbox(3,2)-srcbbox(3,1))/srcbbox(3,3)+1 & - .or. dstiext.ne.(dstbbox(1,2)-dstbbox(1,1))/dstbbox(1,3)+1 & - .or. dstjext.ne.(dstbbox(2,2)-dstbbox(2,1))/dstbbox(2,3)+1 & - .or. dstkext.ne.(dstbbox(3,2)-dstbbox(3,1))/dstbbox(3,3)+1) then - call CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes") - end if - - regiext = (regbbox(1,2) - regbbox(1,1)) / regbbox(1,3) + 1 - regjext = (regbbox(2,2) - regbbox(2,1)) / regbbox(2,3) + 1 - regkext = (regbbox(3,2) - regbbox(3,1)) / regbbox(3,3) + 1 - - dstifac = srcbbox(1,3) / dstbbox(1,3) - dstjfac = srcbbox(2,3) / dstbbox(2,3) - dstkfac = srcbbox(3,3) / dstbbox(3,3) - - srcioff = (regbbox(1,1) - srcbbox(1,1)) / dstbbox(1,3) - srcjoff = (regbbox(2,1) - srcbbox(2,1)) / dstbbox(2,3) - srckoff = (regbbox(3,1) - srcbbox(3,1)) / dstbbox(3,3) - - dstioff = (regbbox(1,1) - dstbbox(1,1)) / dstbbox(1,3) - dstjoff = (regbbox(2,1) - dstbbox(2,1)) / dstbbox(2,3) - dstkoff = (regbbox(3,1) - dstbbox(3,1)) / dstbbox(3,3) - -!!$ Quadratic (second order) interpolation - if (t1.eq.t2 .or. t1.eq.t3 .or. t2.eq.t3) then - call CCTK_WARN (0, "Internal error: arrays have same time") - end if - if (t.lt.min(t1,t2,t3)-eps .or. t.gt.max(t1,t2,t3)+eps) then - call CCTK_WARN (0, "Internal error: extrapolation in time") - end if - - s1fac = (t - t2) * (t - t3) / ((t1 - t2) * (t1 - t3)) - s2fac = (t - t1) * (t - t3) / ((t2 - t1) * (t2 - t3)) - s3fac = (t - t1) * (t - t2) / ((t3 - t1) * (t3 - t2)) - -!!$ Loop over fine region - - do k = 0, regkext-1 - k0 = (srckoff + k) / dstkfac - fk = mod(srckoff + k, dstkfac) - - do j = 0, regjext-1 - j0 = (srcjoff + j) / dstjfac - fj = mod(srcjoff + j, dstjfac) - - do i = 0, regiext-1 - i0 = (srcioff + i) / dstifac - fi = mod(srcioff + i, dstifac) - -!!$ Where is the fine grid point w.r.t the coarse grid? - -!!$ write(*,*) i,j,k,fi,fj,fk - - select case (fi + 10*fj + 100*fk) - case (0) -!!$ On a coarse grid point exactly! - - dsttmp1 = src1(i0+1,j0+1,k0+1) - dsttmp2 = src2(i0+1,j0+1,k0+1) - dsttmp3 = src3(i0+1,j0+1,k0+1) - - case (1) -!!$ Interpolate only in x - - dsttmp1 = weno1d(src1(i0-1:i0+3,j0+1,k0+1)) - dsttmp2 = weno1d(src2(i0-1:i0+3,j0+1,k0+1)) - dsttmp3 = weno1d(src3(i0-1:i0+3,j0+1,k0+1)) - - case (10) -!!$ Interpolate only in y - - dsttmp1 = weno1d(src1(i0+1,j0-1:j0+3,k0+1)) - dsttmp2 = weno1d(src2(i0+1,j0-1:j0+3,k0+1)) - dsttmp3 = weno1d(src3(i0+1,j0-1:j0+3,k0+1)) - - case (11) -!!$ Interpolate only in x and y - - do jj = 0, 4 - tmp2(jj) = weno1d(src1(i0-1:i0+3,j0+jj-1,k0+1)) - end do - - dsttmp1 = weno1d(tmp2(0:4)) - - do jj = 0, 4 - tmp2(jj) = weno1d(src2(i0-1:i0+3,j0+jj-1,k0+1)) - end do - - dsttmp2 = weno1d(tmp2(0:4)) - - do jj = 0, 4 - tmp2(jj) = weno1d(src3(i0-1:i0+3,j0+jj-1,k0+1)) - end do - - dsttmp3 = weno1d(tmp2(0:4)) - - case (100) -!!$ Interpolate only in z - - dsttmp1 = weno1d(src1(i0+1,j0+1,k0-1:k0+3)) - dsttmp2 = weno1d(src2(i0+1,j0+1,k0-1:k0+3)) - dsttmp3 = weno1d(src3(i0+1,j0+1,k0-1:k0+3)) - - case (101) -!!$ Interpolate only in x and z - - do kk = 0, 4 - tmp2(kk) = weno1d(src1(i0-1:i0+3,j0+1,k0+kk-1)) - end do - - dsttmp1 = weno1d(tmp2(0:4)) - - do kk = 0, 4 - tmp2(kk) = weno1d(src2(i0-1:i0+3,j0+1,k0+kk-1)) - end do - - dsttmp2 = weno1d(tmp2(0:4)) - - do kk = 0, 4 - tmp2(kk) = weno1d(src3(i0-1:i0+3,j0+1,k0+kk-1)) - end do - - dsttmp3 = weno1d(tmp2(0:4)) - - case (110) -!!$ Interpolate only in y and z - - do kk = 0, 4 - tmp2(kk) = weno1d(src1(i0+1,j0-1:j0+3,k0+kk-1)) - end do - - dsttmp1 = weno1d(tmp2(0:4)) - - do kk = 0, 4 - tmp2(kk) = weno1d(src2(i0+1,j0-1:j0+3,k0+kk-1)) - end do - - dsttmp2 = weno1d(tmp2(0:4)) - - do kk = 0, 4 - tmp2(kk) = weno1d(src3(i0+1,j0-1:j0+3,k0+kk-1)) - end do - - dsttmp3 = weno1d(tmp2(0:4)) - - case (111) -!!$ Interpolate in all of x, y, and z - - do jj = 0, 4 - do kk = 0, 4 - tmp1(jj,kk) = weno1d(src1(i0-1:i0+3,j0+jj-1,k0+kk-1)) - end do - end do - do ii = 0, 4 - tmp2(ii) = weno1d(tmp1(0:4,ii)) - end do - - dsttmp1 = weno1d(tmp2(0:4)) - - do jj = 0, 4 - do kk = 0, 4 - tmp1(jj,kk) = weno1d(src2(i0-1:i0+3,j0+jj-1,k0+kk-1)) - end do - end do - do ii = 0, 4 - tmp2(ii) = weno1d(tmp1(0:4,ii)) - end do - - dsttmp2 = weno1d(tmp2(0:4)) - - do jj = 0, 4 - do kk = 0, 4 - tmp1(jj,kk) = weno1d(src3(i0-1:i0+3,j0+jj-1,k0+kk-1)) - end do - end do - do ii = 0, 4 - tmp2(ii) = weno1d(tmp1(0:4,ii)) - end do - - dsttmp3 = weno1d(tmp2(0:4)) - - case default - call CCTK_WARN(0, "Internal error in WENO prolongation. Should only be used with refinement factor 2!") - end select - - dst (dstioff+i+1, dstjoff+j+1, dstkoff+k+1) = & - s1fac * dsttmp1 + s2fac * dsttmp2 + s3fac * dsttmp3 - -!!$ write(*,*) i,j,k,dst (dstioff+i+1, dstjoff+j+1, dstkoff+k+1),& -!!$ s1fac,s2fac,s3fac,dsttmp1,dsttmp2,dsttmp3 - - if ( (dst(dstioff+i+1, dstjoff+j+1, dstkoff+k+1) - & - max(dsttmp1, dsttmp2, dsttmp3)) * & - (dst(dstioff+i+1, dstjoff+j+1, dstkoff+k+1) - & - min(dsttmp1, dsttmp2, dsttmp3)) .gt. 0 ) then - -!!$ Do linear interpolation in time instead - -!!$ write(*,*) t,t1,t2,t3 - - if (t < t2) then - - tmps2fac = (t - t3) / (t2 - t3) - tmps3fac = (t - t2) / (t3 - t2) - - dst (dstioff+i+1, dstjoff+j+1, dstkoff+k+1) = & - tmps2fac * dsttmp2 + tmps3fac * dsttmp3 - - else - - tmps1fac = (t - t2) / (t1 - t2) - tmps2fac = (t - t1) / (t2 - t1) - - dst (dstioff+i+1, dstjoff+j+1, dstkoff+k+1) = & - tmps1fac * dsttmp1 + tmps2fac * dsttmp2 - - end if - - end if - - end do - end do - end do - -end subroutine prolongate_3d_real8_3tl_weno -#endif /* !OMIT_F90 */ diff --git a/Carpet/CarpetLib/src/prolongate_3d_real8_eno.F90 b/Carpet/CarpetLib/src/prolongate_3d_real8_eno.F90 index 105b06148..52bca8fa5 100644 --- a/Carpet/CarpetLib/src/prolongate_3d_real8_eno.F90 +++ b/Carpet/CarpetLib/src/prolongate_3d_real8_eno.F90 @@ -27,15 +27,6 @@ !!$ prolongate_3d_real8_eno.F77 -#define CHKIDX(i,j,k, imax,jmax,kmax, where) \ -if ((i).lt.1 .or. (i).gt.(imax) \ - .or. (j).lt.1 .or. (j).gt.(jmax) \ - .or. (k).lt.1 .or. (k).gt.(kmax)) then &&\ - write (msg, '(a, " array index out of bounds: shape is (",i4,",",i4,",",i4,"), index is (",i4,",",i4,",",i4,")")') \ - (where), (imax), (jmax), (kmax), (i), (j), (k) &&\ - call CCTK_WARN (0, msg(1:len_trim(msg))) &&\ -end if - function eno1d(q) implicit none diff --git a/Carpet/CarpetLib/src/prolongate_3d_real8_minmod.F77 b/Carpet/CarpetLib/src/prolongate_3d_real8_minmod.F77 deleted file mode 100644 index 32c3e6227..000000000 --- a/Carpet/CarpetLib/src/prolongate_3d_real8_minmod.F77 +++ /dev/null @@ -1,253 +0,0 @@ -c -*-Fortran-*- - -#include "cctk.h" -#include "cctk_Parameters.h" - - -c$$$ This routine performs "TVD" prolongation. It is intended to be used -c$$$ with GFs that are not expected to be smooth, particularly those -c$$$ that must also obey certain constraints. The obvious example is the -c$$$ density in hydrodynamics, which may be discontinuous yet must be -c$$$ strictly positive. -c$$$ -c$$$ To ensure that this prolongation method is used you should add the -c$$$ tag -c$$$ -c$$$ tags='Prolongation="TVD"' -c$$$ -c$$$ to the interface.ccl on the appropriate group. -c$$$ -c$$$ This applies minmod type limiting to the slope, checking over the -c$$$ entire coarse grid cell for the minimum modulus in each direction. -c$$$ -c$$$ The actual minmod function is defined in the routine -c$$$ -c$$$ prolongate_3d_real8_minmod.F77 - - - function minmod(a, b) - - implicit none - - CCTK_REAL8 minmod - CCTK_REAL8 a, b - CCTK_REAL8 zero - parameter (zero = 0) - - if (a * b .lt. zero) then - minmod = zero - else if (abs(a) .lt. abs(b)) then - minmod = a - else - minmod = b - end if - - end - - subroutine prolongate_3d_real8_minmod ( - $ src, srciext, srcjext, srckext, - $ dst, dstiext, dstjext, dstkext, - $ srcbbox, dstbbox, regbbox) - - implicit none - - DECLARE_CCTK_PARAMETERS - - CCTK_REAL8 one - parameter (one = 1) - - integer srciext, srcjext, srckext - CCTK_REAL8 src(srciext,srcjext,srckext) - integer dstiext, dstjext, dstkext - CCTK_REAL8 dst(dstiext,dstjext,dstkext) -c bbox(:,1) is lower boundary (inclusive) -c bbox(:,2) is upper boundary (inclusive) -c bbox(:,3) is stride - integer srcbbox(3,3), dstbbox(3,3), regbbox(3,3) - - integer offsetlo, offsethi - - integer regiext, regjext, regkext - - integer dstifac, dstjfac, dstkfac - - integer srcioff, srcjoff, srckoff - integer dstioff, dstjoff, dstkoff - - integer i, j, k - integer i0, j0, k0 - integer fi, fj, fk - integer ii, jj, kk - integer d - - external minmod - CCTK_REAL8 minmod - - CCTK_REAL8 half, zero - parameter (half = 0.5) - parameter (zero = 0) - CCTK_REAL8 dupw, dloc, slopex, slopey, slopez - logical firstloop - - - do d=1,3 - if (srcbbox(d,3).eq.0 .or. dstbbox(d,3).eq.0 - $ .or. regbbox(d,3).eq.0) then - call CCTK_WARN (0, "Internal error: stride is zero") - end if - if (srcbbox(d,3).le.regbbox(d,3) - $ .or. dstbbox(d,3).ne.regbbox(d,3)) then - call CCTK_WARN (0, "Internal error: strides disagree") - end if - if (mod(srcbbox(d,3), dstbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: destination strides are not integer multiples of the source strides") - end if - if (mod(srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array origins are not integer multiples of the strides") - end if - if (regbbox(d,1).gt.regbbox(d,2)) then -c This could be handled, but is likely to point to an error elsewhere - call CCTK_WARN (0, "Internal error: region extent is empty") - end if - if (mod(srcbbox(d,2) - srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,2) - dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,2) - regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array extents are not integer multiples of the strides") - end if - regkext = (regbbox(d,2) - regbbox(d,1)) / regbbox(d,3) + 1 - dstkfac = srcbbox(d,3) / dstbbox(d,3) - srckoff = (regbbox(d,1) - srcbbox(d,1)) / dstbbox(d,3) - offsetlo = regbbox(d,3) - if (mod(srckoff + 0, dstkfac).eq.0) then - offsetlo = 0 - if (regkext.gt.1) then - offsetlo = regbbox(d,3) - end if - end if - offsethi = regbbox(d,3) - if (mod(srckoff + regkext-1, dstkfac).eq.0) then - offsethi = 0 - if (regkext.gt.1) then - offsethi = regbbox(d,3) - end if - end if - if (regbbox(d,1)-offsetlo.lt.srcbbox(d,1) - $ .or. regbbox(d,2)+offsethi.gt.srcbbox(d,2) - $ .or. regbbox(d,1).lt.dstbbox(d,1) - $ .or. regbbox(d,2).gt.dstbbox(d,2)) then - call CCTK_WARN (0, "Internal error: region extent is not contained in array extent") - end if - end do - - if (srciext.ne.(srcbbox(1,2)-srcbbox(1,1))/srcbbox(1,3)+1 - $ .or. srcjext.ne.(srcbbox(2,2)-srcbbox(2,1))/srcbbox(2,3)+1 - $ .or. srckext.ne.(srcbbox(3,2)-srcbbox(3,1))/srcbbox(3,3)+1 - $ .or. dstiext.ne.(dstbbox(1,2)-dstbbox(1,1))/dstbbox(1,3)+1 - $ .or. dstjext.ne.(dstbbox(2,2)-dstbbox(2,1))/dstbbox(2,3)+1 - $ .or. dstkext.ne.(dstbbox(3,2)-dstbbox(3,1))/dstbbox(3,3)+1) then - call CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes") - end if - - - - regiext = (regbbox(1,2) - regbbox(1,1)) / regbbox(1,3) + 1 - regjext = (regbbox(2,2) - regbbox(2,1)) / regbbox(2,3) + 1 - regkext = (regbbox(3,2) - regbbox(3,1)) / regbbox(3,3) + 1 - - dstifac = srcbbox(1,3) / dstbbox(1,3) - dstjfac = srcbbox(2,3) / dstbbox(2,3) - dstkfac = srcbbox(3,3) / dstbbox(3,3) - - srcioff = (regbbox(1,1) - srcbbox(1,1)) / dstbbox(1,3) - srcjoff = (regbbox(2,1) - srcbbox(2,1)) / dstbbox(2,3) - srckoff = (regbbox(3,1) - srcbbox(3,1)) / dstbbox(3,3) - - dstioff = (regbbox(1,1) - dstbbox(1,1)) / dstbbox(1,3) - dstjoff = (regbbox(2,1) - dstbbox(2,1)) / dstbbox(2,3) - dstkoff = (regbbox(3,1) - dstbbox(3,1)) / dstbbox(3,3) - - - -c Loop over fine region - - do k = 0, regkext-1 - k0 = (srckoff + k) / dstkfac - fk = mod(srckoff + k, dstkfac) - - do j = 0, regjext-1 - j0 = (srcjoff + j) / dstjfac - fj = mod(srcjoff + j, dstjfac) - - do i = 0, regiext-1 - i0 = (srcioff + i) / dstifac - fi = mod(srcioff + i, dstifac) - - slopex = zero - slopey = zero - slopez = zero - - firstloop = .true. - - do kk = 1, 2 - do jj = 1, 2 - - dupw = src(i0+1 ,j0+jj,k0+kk) - src(i0+0 ,j0+jj,k0+kk) - dloc = src(i0+2 ,j0+jj,k0+kk) - src(i0+1 ,j0+kk,k0+kk) - if (firstloop) then - slopex = half * dble(fi) * minmod(dupw,dloc) - firstloop = .false. - else - slopex = - $ minmod(slopex, half * dble(fi) * minmod(dupw,dloc)) - end if - end do - end do - - firstloop = .true. - - do kk = 1, 2 - do ii = 1, 2 - - dupw = src(i0+ii,j0+1 ,k0+kk) - src(i0+ii,j0+0 ,k0+kk) - dloc = src(i0+ii,j0+2 ,k0+kk) - src(i0+ii,j0+1 ,k0+kk) - if (firstloop) then - slopey = half * dble(fj) * minmod(dupw,dloc) - firstloop = .false. - else - slopey = - $ minmod(slopey, half * dble(fj) * minmod(dupw,dloc)) - end if - end do - end do - - firstloop = .true. - - do jj = 1, 2 - do ii = 1, 2 - - dupw = src(i0+ii,j0+jj,k0+1 ) - src(i0+ii,j0+jj,k0+0 ) - dloc = src(i0+ii,j0+jj,k0+2 ) - src(i0+ii,j0+jj,k0+1 ) - if (firstloop) then - slopez = half * dble(fk) * minmod(dupw,dloc) - firstloop = .false. - else - slopez = - $ minmod(slopez, half * dble(fk) * minmod(dupw,dloc)) - end if - end do - end do - - if (check_array_accesses.ne.0) then - call checkinde (dstioff+i+1, dstjoff+j+1, dstkoff+k+1, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst (dstioff+i+1, dstjoff+j+1, dstkoff+k+1) = - . src(i0+1,j0+1,k0+1) + slopex + slopey + slopez - - - end do - end do - end do - - end diff --git a/Carpet/CarpetLib/src/prolongate_3d_real8_o3.F77 b/Carpet/CarpetLib/src/prolongate_3d_real8_o3.F77 deleted file mode 100644 index 98b1cb62a..000000000 --- a/Carpet/CarpetLib/src/prolongate_3d_real8_o3.F77 +++ /dev/null @@ -1,185 +0,0 @@ -c -*-Fortran-*- - -#include "cctk.h" -#include "cctk_Parameters.h" - - - - subroutine prolongate_3d_real8_o3 ( - $ src, srciext, srcjext, srckext, - $ dst, dstiext, dstjext, dstkext, - $ srcbbox, dstbbox, regbbox) - - implicit none - - DECLARE_CCTK_PARAMETERS - - CCTK_REAL8 one - parameter (one = 1) - - integer srciext, srcjext, srckext - CCTK_REAL8 src(srciext,srcjext,srckext) - integer dstiext, dstjext, dstkext - CCTK_REAL8 dst(dstiext,dstjext,dstkext) -c bbox(:,1) is lower boundary (inclusive) -c bbox(:,2) is upper boundary (inclusive) -c bbox(:,3) is stride - integer srcbbox(3,3), dstbbox(3,3), regbbox(3,3) - - integer offsetlo, offsethi - - integer regiext, regjext, regkext - - integer dstifac, dstjfac, dstkfac - - integer srcioff, srcjoff, srckoff - integer dstioff, dstjoff, dstkoff - - CCTK_REAL8 dstdiv - integer i, j, k - integer i0, j0, k0 - integer fi, fj, fk - integer ifac(4), jfac(4), kfac(4) - integer ii, jj, kk - integer fac - CCTK_REAL8 res - integer d - - - - do d=1,3 - if (srcbbox(d,3).eq.0 .or. dstbbox(d,3).eq.0 - $ .or. regbbox(d,3).eq.0) then - call CCTK_WARN (0, "Internal error: stride is zero") - end if - if (srcbbox(d,3).le.regbbox(d,3) - $ .or. dstbbox(d,3).ne.regbbox(d,3)) then - call CCTK_WARN (0, "Internal error: strides disagree") - end if - if (mod(srcbbox(d,3), dstbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: destination strides are not integer multiples of the source strides") - end if - if (mod(srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array origins are not integer multiples of the strides") - end if - if (regbbox(d,1).gt.regbbox(d,2)) then -c This could be handled, but is likely to point to an error elsewhere - call CCTK_WARN (0, "Internal error: region extent is empty") - end if - if (mod(srcbbox(d,2) - srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,2) - dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,2) - regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array extents are not integer multiples of the strides") - end if - regkext = (regbbox(d,2) - regbbox(d,1)) / regbbox(d,3) + 1 - dstkfac = srcbbox(d,3) / dstbbox(d,3) - srckoff = (regbbox(d,1) - srcbbox(d,1)) / dstbbox(d,3) - offsetlo = regbbox(d,3) - if (mod(srckoff + 0, dstkfac).eq.0) then - offsetlo = 0 - if (regkext.gt.1) then - offsetlo = regbbox(d,3) - end if - end if - offsethi = regbbox(d,3) - if (mod(srckoff + regkext-1, dstkfac).eq.0) then - offsethi = 0 - if (regkext.gt.1) then - offsethi = regbbox(d,3) - end if - end if - if (regbbox(d,1)-offsetlo.lt.srcbbox(d,1) - $ .or. regbbox(d,2)+offsethi.gt.srcbbox(d,2) - $ .or. regbbox(d,1).lt.dstbbox(d,1) - $ .or. regbbox(d,2).gt.dstbbox(d,2)) then - call CCTK_WARN (0, "Internal error: region extent is not contained in array extent") - end if - end do - - if (srciext.ne.(srcbbox(1,2)-srcbbox(1,1))/srcbbox(1,3)+1 - $ .or. srcjext.ne.(srcbbox(2,2)-srcbbox(2,1))/srcbbox(2,3)+1 - $ .or. srckext.ne.(srcbbox(3,2)-srcbbox(3,1))/srcbbox(3,3)+1 - $ .or. dstiext.ne.(dstbbox(1,2)-dstbbox(1,1))/dstbbox(1,3)+1 - $ .or. dstjext.ne.(dstbbox(2,2)-dstbbox(2,1))/dstbbox(2,3)+1 - $ .or. dstkext.ne.(dstbbox(3,2)-dstbbox(3,1))/dstbbox(3,3)+1) then - call CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes") - end if - - - - regiext = (regbbox(1,2) - regbbox(1,1)) / regbbox(1,3) + 1 - regjext = (regbbox(2,2) - regbbox(2,1)) / regbbox(2,3) + 1 - regkext = (regbbox(3,2) - regbbox(3,1)) / regbbox(3,3) + 1 - - dstifac = srcbbox(1,3) / dstbbox(1,3) - dstjfac = srcbbox(2,3) / dstbbox(2,3) - dstkfac = srcbbox(3,3) / dstbbox(3,3) - - srcioff = (regbbox(1,1) - srcbbox(1,1)) / dstbbox(1,3) - srcjoff = (regbbox(2,1) - srcbbox(2,1)) / dstbbox(2,3) - srckoff = (regbbox(3,1) - srcbbox(3,1)) / dstbbox(3,3) - - dstioff = (regbbox(1,1) - dstbbox(1,1)) / dstbbox(1,3) - dstjoff = (regbbox(2,1) - dstbbox(2,1)) / dstbbox(2,3) - dstkoff = (regbbox(3,1) - dstbbox(3,1)) / dstbbox(3,3) - - - -c Loop over fine region - dstdiv = one / (6*dstifac**3 * 6*dstjfac**3 * 6*dstkfac**3) - - do k = 0, regkext-1 - k0 = (srckoff + k) / dstkfac - fk = mod(srckoff + k, dstkfac) - kfac(1) = (fk ) * (fk-dstkfac) * (fk-2*dstkfac) * (-1) - kfac(2) = (fk+dstkfac) * (fk-dstkfac) * (fk-2*dstkfac) * 3 - kfac(3) = (fk+dstkfac) * (fk ) * (fk-2*dstkfac) * (-3) - kfac(4) = (fk+dstkfac) * (fk ) * (fk- dstkfac) * 1 - - do j = 0, regjext-1 - j0 = (srcjoff + j) / dstjfac - fj = mod(srcjoff + j, dstjfac) - jfac(1) = (fj ) * (fj-dstjfac) * (fj-2*dstjfac) * (-1) - jfac(2) = (fj+dstjfac) * (fj-dstjfac) * (fj-2*dstjfac) * 3 - jfac(3) = (fj+dstjfac) * (fj ) * (fj-2*dstjfac) * (-3) - jfac(4) = (fj+dstjfac) * (fj ) * (fj- dstjfac) * 1 - - do i = 0, regiext-1 - i0 = (srcioff + i) / dstifac - fi = mod(srcioff + i, dstifac) - ifac(1) = (fi ) * (fi-dstifac) * (fi-2*dstifac) * (-1) - ifac(2) = (fi+dstifac) * (fi-dstifac) * (fi-2*dstifac) * 3 - ifac(3) = (fi+dstifac) * (fi ) * (fi-2*dstifac) * (-3) - ifac(4) = (fi+dstifac) * (fi ) * (fi- dstifac) * 1 - - res = 0 - - do kk=1,4 - do jj=1,4 - do ii=1,4 - - fac = ifac(ii) * jfac(jj) * kfac(kk) - - if (fac.ne.0) then - if (check_array_accesses.ne.0) then - call checkindex (i0+ii-1, j0+jj-1, k0+kk-1, 1,1,1, srciext,srcjext,srckext, "source") - end if - res = res + fac * src(i0+ii-1, j0+jj-1, k0+kk-1) - end if - - end do - end do - end do - - if (check_array_accesses.ne.0) then - call checkindex (dstioff+i+1, dstjoff+j+1, dstkoff+k+1, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst (dstioff+i+1, dstjoff+j+1, dstkoff+k+1) = dstdiv * res - - end do - end do - end do - - end diff --git a/Carpet/CarpetLib/src/prolongate_3d_real8_o3_rf2.F77 b/Carpet/CarpetLib/src/prolongate_3d_real8_o3_rf2.F77 deleted file mode 100644 index b7ff22f38..000000000 --- a/Carpet/CarpetLib/src/prolongate_3d_real8_o3_rf2.F77 +++ /dev/null @@ -1,419 +0,0 @@ -c -*-Fortran-*- - -#include "cctk.h" -#include "cctk_Parameters.h" - - - - subroutine prolongate_3d_real8_o3_rf2 ( - $ src, srciext, srcjext, srckext, - $ dst, dstiext, dstjext, dstkext, - $ srcbbox, dstbbox, regbbox) - - implicit none - - DECLARE_CCTK_PARAMETERS - - CCTK_REAL8 one, half, fourth, eighth, sixteenth - parameter (one = 1) - parameter (half = one/2) - parameter (fourth = one/4) - parameter (eighth = one/8) - parameter (sixteenth = one/16) - CCTK_REAL8 f1, f2, f3, f4 - parameter (f1 = - sixteenth) - parameter (f2 = 9*sixteenth) - parameter (f3 = 9*sixteenth) - parameter (f4 = - sixteenth) - - integer srciext, srcjext, srckext - CCTK_REAL8 src(srciext,srcjext,srckext) - integer dstiext, dstjext, dstkext - CCTK_REAL8 dst(dstiext,dstjext,dstkext) -c bbox(:,1) is lower boundary (inclusive) -c bbox(:,2) is upper boundary (inclusive) -c bbox(:,3) is stride - integer srcbbox(3,3), dstbbox(3,3), regbbox(3,3) - - integer regiext, regjext, regkext - - integer srcioff, srcjoff, srckoff - integer dstioff, dstjoff, dstkoff - - integer offsetlo, offsethi - - integer i0, j0, k0 - integer fi, fj, fk - integer is, js, ks - integer id, jd, kd - integer i, j, k - - integer d - - - - do d=1,3 - if (srcbbox(d,3).eq.0 .or. dstbbox(d,3).eq.0 - $ .or. regbbox(d,3).eq.0) then - call CCTK_WARN (0, "Internal error: stride is zero") - end if - if (srcbbox(d,3).le.regbbox(d,3) - $ .or. dstbbox(d,3).ne.regbbox(d,3)) then - call CCTK_WARN (0, "Internal error: strides disagree") - end if - if (srcbbox(d,3).ne.dstbbox(d,3)*2) then - call CCTK_WARN (0, "Internal error: source strides are not twice the destination strides") - end if - if (mod(srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array origins are not integer multiples of the strides") - end if - if (regbbox(d,1).gt.regbbox(d,2)) then -c This could be handled, but is likely to point to an error elsewhere - call CCTK_WARN (0, "Internal error: region extent is empty") - end if - if (mod(srcbbox(d,2) - srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,2) - dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,2) - regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array extents are not integer multiples of the strides") - end if - regkext = (regbbox(d,2) - regbbox(d,1)) / regbbox(d,3) + 1 - srckoff = (regbbox(d,1) - srcbbox(d,1)) / dstbbox(d,3) - offsetlo = regbbox(d,3) - if (mod(srckoff, 2).eq.0) then - offsetlo = 0 - if (regkext.gt.1) then - offsetlo = regbbox(d,3) - end if - end if - offsethi = regbbox(d,3) - if (mod(srckoff + regkext-1, 2).eq.0) then - offsethi = 0 - if (regkext.gt.1) then - offsethi = regbbox(d,3) - end if - end if - if (regbbox(d,1)-offsetlo.lt.srcbbox(d,1) - $ .or. regbbox(d,2)+offsethi.gt.srcbbox(d,2) - $ .or. regbbox(d,1).lt.dstbbox(d,1) - $ .or. regbbox(d,2).gt.dstbbox(d,2)) then - call CCTK_WARN (0, "Internal error: region extent is not contained in array extent") - end if - end do - - if (srciext.ne.(srcbbox(1,2)-srcbbox(1,1))/srcbbox(1,3)+1 - $ .or. srcjext.ne.(srcbbox(2,2)-srcbbox(2,1))/srcbbox(2,3)+1 - $ .or. srckext.ne.(srcbbox(3,2)-srcbbox(3,1))/srcbbox(3,3)+1 - $ .or. dstiext.ne.(dstbbox(1,2)-dstbbox(1,1))/dstbbox(1,3)+1 - $ .or. dstjext.ne.(dstbbox(2,2)-dstbbox(2,1))/dstbbox(2,3)+1 - $ .or. dstkext.ne.(dstbbox(3,2)-dstbbox(3,1))/dstbbox(3,3)+1) then - call CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes") - end if - - - - regiext = (regbbox(1,2) - regbbox(1,1)) / regbbox(1,3) + 1 - regjext = (regbbox(2,2) - regbbox(2,1)) / regbbox(2,3) + 1 - regkext = (regbbox(3,2) - regbbox(3,1)) / regbbox(3,3) + 1 - - srcioff = (regbbox(1,1) - srcbbox(1,1)) / dstbbox(1,3) - srcjoff = (regbbox(2,1) - srcbbox(2,1)) / dstbbox(2,3) - srckoff = (regbbox(3,1) - srcbbox(3,1)) / dstbbox(3,3) - - dstioff = (regbbox(1,1) - dstbbox(1,1)) / dstbbox(1,3) - dstjoff = (regbbox(2,1) - dstbbox(2,1)) / dstbbox(2,3) - dstkoff = (regbbox(3,1) - dstbbox(3,1)) / dstbbox(3,3) - - - - fi = mod(srcioff, 2) - fj = mod(srcjoff, 2) - fk = mod(srckoff, 2) - - i0 = srcioff / 2 - j0 = srcjoff / 2 - k0 = srckoff / 2 - - - -c Loop over fine region -c Label scheme: 8 fk fj fi - -c begin k loop - 8 continue - k = 0 - ks = k0+1 - kd = dstkoff+1 - if (fk.eq.0) goto 80 - if (fk.eq.1) goto 81 - stop - -c begin j loop - 80 continue - j = 0 - js = j0+1 - jd = dstjoff+1 - if (fj.eq.0) goto 800 - if (fj.eq.1) goto 801 - stop - -c begin i loop - 800 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8000 - if (fi.eq.1) goto 8001 - stop - -c kernel - 8000 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js,ks, 1,1,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = src(is,js,ks) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8001 - goto 900 - -c kernel - 8001 continue - if (check_array_accesses.ne.0) then - call checkindex (is-1,js,ks, 4,1,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + f1 * src(is-1,js,ks) + f2 * src(is ,js,ks) - $ + f3 * src(is+1,js,ks) + f4 * src(is+2,js,ks) - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8000 - goto 900 - -c end i loop - 900 continue - j = j+1 - jd = jd+1 - if (j.lt.regjext) goto 801 - goto 90 - -c begin i loop - 801 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8010 - if (fi.eq.1) goto 8011 - stop - -c kernel - 8010 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js-1,ks, 1,4,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + f1 * src(is,js-1,ks) + f2 * src(is,js ,ks) - $ + f3 * src(is,js+1,ks) + f4 * src(is,js+2,ks) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8011 - goto 901 - -c kernel - 8011 continue - if (check_array_accesses.ne.0) then - call checkindex (is-1,js-1,ks, 4,4,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + f1*f1 * src(is-1,js-1,ks) + f2*f1 * src(is ,js-1,ks) - $ + f3*f1 * src(is+1,js-1,ks) + f4*f1 * src(is+2,js-1,ks) - $ + f1*f2 * src(is-1,js ,ks) + f2*f2 * src(is ,js ,ks) - $ + f3*f2 * src(is+1,js ,ks) + f4*f2 * src(is+2,js ,ks) - $ + f1*f3 * src(is-1,js+1,ks) + f2*f3 * src(is ,js+1,ks) - $ + f3*f3 * src(is+1,js+1,ks) + f4*f3 * src(is+2,js+1,ks) - $ + f1*f4 * src(is-1,js+2,ks) + f2*f4 * src(is ,js+2,ks) - $ + f3*f4 * src(is+1,js+2,ks) + f4*f4 * src(is+2,js+2,ks) - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8010 - goto 901 - -c end i loop - 901 continue - j = j+1 - jd = jd+1 - js = js+1 - if (j.lt.regjext) goto 800 - goto 90 - -c end j loop - 90 continue - k = k+1 - kd = kd+1 - if (k.lt.regkext) goto 81 - goto 9 - -c begin j loop - 81 continue - j = 0 - js = j0+1 - jd = dstjoff+1 - if (fj.eq.0) goto 810 - if (fj.eq.1) goto 811 - stop - -c begin i loop - 810 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8100 - if (fi.eq.1) goto 8101 - stop - -c kernel - 8100 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js,ks-1, 1,1,4, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + f1 * src(is,js,ks-1) + f2 * src(is,js,ks ) - $ + f3 * src(is,js,ks+1) + f4 * src(is,js,ks+2) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8101 - goto 910 - -c kernel - 8101 continue - if (check_array_accesses.ne.0) then - call checkindex (is-1,js,ks-1, 4,1,4, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + f1*f1 * src(is-1,js,ks-1) + f2*f1 * src(is ,js,ks-1) - $ + f3*f1 * src(is+1,js,ks-1) + f4*f1 * src(is+2,js,ks-1) - $ + f1*f2 * src(is-1,js,ks ) + f2*f2 * src(is ,js,ks ) - $ + f3*f2 * src(is+1,js,ks ) + f4*f2 * src(is+2,js,ks ) - $ + f1*f3 * src(is-1,js,ks+1) + f2*f3 * src(is ,js,ks+1) - $ + f3*f3 * src(is+1,js,ks+1) + f4*f3 * src(is+2,js,ks+1) - $ + f1*f4 * src(is-1,js,ks+2) + f2*f4 * src(is ,js,ks+2) - $ + f3*f4 * src(is+1,js,ks+2) + f4*f4 * src(is+2,js,ks+2) - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8100 - goto 910 - -c end i loop - 910 continue - j = j+1 - jd = jd+1 - if (j.lt.regjext) goto 811 - goto 91 - -c begin i loop - 811 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8110 - if (fi.eq.1) goto 8111 - stop - -c kernel - 8110 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js-1,ks-1, 1,4,4, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + f1*f1 * src(is,js-1,ks-1) + f2*f1 * src(is,js ,ks-1) - $ + f3*f1 * src(is,js+1,ks-1) + f4*f1 * src(is,js+2,ks-1) - $ + f1*f2 * src(is,js-1,ks ) + f2*f2 * src(is,js ,ks ) - $ + f3*f2 * src(is,js+1,ks ) + f4*f2 * src(is,js+2,ks ) - $ + f1*f3 * src(is,js-1,ks+1) + f2*f3 * src(is,js ,ks+1) - $ + f3*f3 * src(is,js+1,ks+1) + f4*f3 * src(is,js+2,ks+1) - $ + f1*f4 * src(is,js-1,ks+2) + f2*f4 * src(is,js ,ks+2) - $ + f3*f4 * src(is,js+1,ks+2) + f4*f4 * src(is,js+2,ks+2) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8111 - goto 911 - -c kernel - 8111 continue - if (check_array_accesses.ne.0) then - call checkindex (is-1,js-1,ks-1, 4,4,4, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + f1*f1*f1 * src(is-1,js-1,ks-1) + f2*f1*f1 * src(is ,js-1,ks-1) - $ + f3*f1*f1 * src(is+1,js-1,ks-1) + f4*f1*f1 * src(is+2,js-1,ks-1) - $ + f1*f2*f1 * src(is-1,js ,ks-1) + f2*f2*f1 * src(is ,js ,ks-1) - $ + f3*f2*f1 * src(is+1,js ,ks-1) + f4*f2*f1 * src(is+2,js ,ks-1) - $ + f1*f3*f1 * src(is-1,js+1,ks-1) + f2*f3*f1 * src(is ,js+1,ks-1) - $ + f3*f3*f1 * src(is+1,js+1,ks-1) + f4*f3*f1 * src(is+2,js+1,ks-1) - $ + f1*f4*f1 * src(is-1,js+2,ks-1) + f2*f4*f1 * src(is ,js+2,ks-1) - $ + f3*f4*f1 * src(is+1,js+2,ks-1) + f4*f4*f1 * src(is+2,js+2,ks-1) - $ - $ + f1*f1*f2 * src(is-1,js-1,ks ) + f2*f1*f2 * src(is ,js-1,ks ) - $ + f3*f1*f2 * src(is+1,js-1,ks ) + f4*f1*f2 * src(is+2,js-1,ks ) - $ + f1*f2*f2 * src(is-1,js ,ks ) + f2*f2*f2 * src(is ,js ,ks ) - $ + f3*f2*f2 * src(is+1,js ,ks ) + f4*f2*f2 * src(is+2,js ,ks ) - $ + f1*f3*f2 * src(is-1,js+1,ks ) + f2*f3*f2 * src(is ,js+1,ks ) - $ + f3*f3*f2 * src(is+1,js+1,ks ) + f4*f3*f2 * src(is+2,js+1,ks ) - $ + f1*f4*f2 * src(is-1,js+2,ks ) + f2*f4*f2 * src(is ,js+2,ks ) - $ + f3*f4*f2 * src(is+1,js+2,ks ) + f4*f4*f2 * src(is+2,js+2,ks ) - $ - $ + f1*f1*f3 * src(is-1,js-1,ks+1) + f2*f1*f3 * src(is ,js-1,ks+1) - $ + f3*f1*f3 * src(is+1,js-1,ks+1) + f4*f1*f3 * src(is+2,js-1,ks+1) - $ + f1*f2*f3 * src(is-1,js ,ks+1) + f2*f2*f3 * src(is ,js ,ks+1) - $ + f3*f2*f3 * src(is+1,js ,ks+1) + f4*f2*f3 * src(is+2,js ,ks+1) - $ + f1*f3*f3 * src(is-1,js+1,ks+1) + f2*f3*f3 * src(is ,js+1,ks+1) - $ + f3*f3*f3 * src(is+1,js+1,ks+1) + f4*f3*f3 * src(is+2,js+1,ks+1) - $ + f1*f4*f3 * src(is-1,js+2,ks+1) + f2*f4*f3 * src(is ,js+2,ks+1) - $ + f3*f4*f3 * src(is+1,js+2,ks+1) + f4*f4*f3 * src(is+2,js+2,ks+1) - $ - $ + f1*f1*f4 * src(is-1,js-1,ks+2) + f2*f1*f4 * src(is ,js-1,ks+2) - $ + f3*f1*f4 * src(is+1,js-1,ks+2) + f4*f1*f4 * src(is+2,js-1,ks+2) - $ + f1*f2*f4 * src(is-1,js ,ks+2) + f2*f2*f4 * src(is ,js ,ks+2) - $ + f3*f2*f4 * src(is+1,js ,ks+2) + f4*f2*f4 * src(is+2,js ,ks+2) - $ + f1*f3*f4 * src(is-1,js+1,ks+2) + f2*f3*f4 * src(is ,js+1,ks+2) - $ + f3*f3*f4 * src(is+1,js+1,ks+2) + f4*f3*f4 * src(is+2,js+1,ks+2) - $ + f1*f4*f4 * src(is-1,js+2,ks+2) + f2*f4*f4 * src(is ,js+2,ks+2) - $ + f3*f4*f4 * src(is+1,js+2,ks+2) + f4*f4*f4 * src(is+2,js+2,ks+2) - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8110 - goto 911 - -c end i loop - 911 continue - j = j+1 - jd = jd+1 - js = js+1 - if (j.lt.regjext) goto 810 - goto 91 - -c end j loop - 91 continue - k = k+1 - kd = kd+1 - ks = ks+1 - if (k.lt.regkext) goto 80 - goto 9 - -c end k loop - 9 continue - - end diff --git a/Carpet/CarpetLib/src/prolongate_3d_real8_o5.F77 b/Carpet/CarpetLib/src/prolongate_3d_real8_o5.F77 deleted file mode 100644 index a1a633c82..000000000 --- a/Carpet/CarpetLib/src/prolongate_3d_real8_o5.F77 +++ /dev/null @@ -1,193 +0,0 @@ -c -*-Fortran-*- - -#include "cctk.h" -#include "cctk_Parameters.h" - - - - subroutine prolongate_3d_real8_o5 ( - $ src, srciext, srcjext, srckext, - $ dst, dstiext, dstjext, dstkext, - $ srcbbox, dstbbox, regbbox) - - implicit none - - DECLARE_CCTK_PARAMETERS - - CCTK_REAL8 one - parameter (one = 1) - - integer srciext, srcjext, srckext - CCTK_REAL8 src(srciext,srcjext,srckext) - integer dstiext, dstjext, dstkext - CCTK_REAL8 dst(dstiext,dstjext,dstkext) -c bbox(:,1) is lower boundary (inclusive) -c bbox(:,2) is upper boundary (inclusive) -c bbox(:,3) is stride - integer srcbbox(3,3), dstbbox(3,3), regbbox(3,3) - - integer offsetlo, offsethi - - integer regiext, regjext, regkext - - integer dstifac, dstjfac, dstkfac - - integer srcioff, srcjoff, srckoff - integer dstioff, dstjoff, dstkoff - - CCTK_REAL8 dstdiv - integer i, j, k - integer i0, j0, k0 - integer fi, fj, fk - integer ifac(6), jfac(6), kfac(6) - integer ii, jj, kk - CCTK_REAL8 fac - CCTK_REAL8 res - integer d - - - - do d=1,3 - if (srcbbox(d,3).eq.0 .or. dstbbox(d,3).eq.0 - $ .or. regbbox(d,3).eq.0) then - call CCTK_WARN (0, "Internal error: stride is zero") - end if - if (srcbbox(d,3).le.regbbox(d,3) - $ .or. dstbbox(d,3).ne.regbbox(d,3)) then - call CCTK_WARN (0, "Internal error: strides disagree") - end if - if (mod(srcbbox(d,3), dstbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: destination strides are not integer multiples of the source strides") - end if - if (mod(srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array origins are not integer multiples of the strides") - end if - if (regbbox(d,1).gt.regbbox(d,2)) then -c This could be handled, but is likely to point to an error elsewhere - call CCTK_WARN (0, "Internal error: region extent is empty") - end if - if (mod(srcbbox(d,2) - srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,2) - dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,2) - regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array extents are not integer multiples of the strides") - end if - regkext = (regbbox(d,2) - regbbox(d,1)) / regbbox(d,3) + 1 - dstkfac = srcbbox(d,3) / dstbbox(d,3) - srckoff = (regbbox(d,1) - srcbbox(d,1)) / dstbbox(d,3) - offsetlo = regbbox(d,3) - if (mod(srckoff + 0, dstkfac).eq.0) then - offsetlo = 0 - if (regkext.gt.1) then - offsetlo = regbbox(d,3) - end if - end if - offsethi = regbbox(d,3) - if (mod(srckoff + regkext-1, dstkfac).eq.0) then - offsethi = 0 - if (regkext.gt.1) then - offsethi = regbbox(d,3) - end if - end if - if (regbbox(d,1)-offsetlo.lt.srcbbox(d,1) - $ .or. regbbox(d,2)+offsethi.gt.srcbbox(d,2) - $ .or. regbbox(d,1).lt.dstbbox(d,1) - $ .or. regbbox(d,2).gt.dstbbox(d,2)) then - call CCTK_WARN (0, "Internal error: region extent is not contained in array extent") - end if - end do - - if (srciext.ne.(srcbbox(1,2)-srcbbox(1,1))/srcbbox(1,3)+1 - $ .or. srcjext.ne.(srcbbox(2,2)-srcbbox(2,1))/srcbbox(2,3)+1 - $ .or. srckext.ne.(srcbbox(3,2)-srcbbox(3,1))/srcbbox(3,3)+1 - $ .or. dstiext.ne.(dstbbox(1,2)-dstbbox(1,1))/dstbbox(1,3)+1 - $ .or. dstjext.ne.(dstbbox(2,2)-dstbbox(2,1))/dstbbox(2,3)+1 - $ .or. dstkext.ne.(dstbbox(3,2)-dstbbox(3,1))/dstbbox(3,3)+1) then - call CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes") - end if - - - - regiext = (regbbox(1,2) - regbbox(1,1)) / regbbox(1,3) + 1 - regjext = (regbbox(2,2) - regbbox(2,1)) / regbbox(2,3) + 1 - regkext = (regbbox(3,2) - regbbox(3,1)) / regbbox(3,3) + 1 - - dstifac = srcbbox(1,3) / dstbbox(1,3) - dstjfac = srcbbox(2,3) / dstbbox(2,3) - dstkfac = srcbbox(3,3) / dstbbox(3,3) - - srcioff = (regbbox(1,1) - srcbbox(1,1)) / dstbbox(1,3) - srcjoff = (regbbox(2,1) - srcbbox(2,1)) / dstbbox(2,3) - srckoff = (regbbox(3,1) - srcbbox(3,1)) / dstbbox(3,3) - - dstioff = (regbbox(1,1) - dstbbox(1,1)) / dstbbox(1,3) - dstjoff = (regbbox(2,1) - dstbbox(2,1)) / dstbbox(2,3) - dstkoff = (regbbox(3,1) - dstbbox(3,1)) / dstbbox(3,3) - - - -c Loop over fine region -c (This expression cannot be evaluated as integer) - dstdiv = one / (120*dstifac**5) / (120*dstjfac**5) / (120*dstkfac**5) - - do k = 0, regkext-1 - k0 = (srckoff + k) / dstkfac - fk = mod(srckoff + k, dstkfac) - kfac(1) = (fk+ dstkfac) * (fk ) * (fk-dstkfac) * (fk-2*dstkfac) * (fk-3*dstkfac) * (- 1) - kfac(2) = (fk+2*dstkfac) * (fk ) * (fk-dstkfac) * (fk-2*dstkfac) * (fk-3*dstkfac) * ( 5) - kfac(3) = (fk+2*dstkfac) * (fk+dstkfac) * (fk-dstkfac) * (fk-2*dstkfac) * (fk-3*dstkfac) * (-10) - kfac(4) = (fk+2*dstkfac) * (fk+dstkfac) * (fk ) * (fk-2*dstkfac) * (fk-3*dstkfac) * ( 10) - kfac(5) = (fk+2*dstkfac) * (fk+dstkfac) * (fk ) * (fk- dstkfac) * (fk-3*dstkfac) * (- 5) - kfac(6) = (fk+2*dstkfac) * (fk+dstkfac) * (fk ) * (fk- dstkfac) * (fk-2*dstkfac) * ( 1) - - do j = 0, regjext-1 - j0 = (srcjoff + j) / dstjfac - fj = mod(srcjoff + j, dstjfac) - jfac(1) = (fj+ dstjfac) * (fj ) * (fj-dstjfac) * (fj-2*dstjfac) * (fj-3*dstjfac) * (- 1) - jfac(2) = (fj+2*dstjfac) * (fj ) * (fj-dstjfac) * (fj-2*dstjfac) * (fj-3*dstjfac) * ( 5) - jfac(3) = (fj+2*dstjfac) * (fj+dstjfac) * (fj-dstjfac) * (fj-2*dstjfac) * (fj-3*dstjfac) * (-10) - jfac(4) = (fj+2*dstjfac) * (fj+dstjfac) * (fj ) * (fj-2*dstjfac) * (fj-3*dstjfac) * ( 10) - jfac(5) = (fj+2*dstjfac) * (fj+dstjfac) * (fj ) * (fj- dstjfac) * (fj-3*dstjfac) * (- 5) - jfac(6) = (fj+2*dstjfac) * (fj+dstjfac) * (fj ) * (fj- dstjfac) * (fj-2*dstjfac) * ( 1) - - do i = 0, regiext-1 - i0 = (srcioff + i) / dstifac - fi = mod(srcioff + i, dstifac) - ifac(1) = (fi+ dstifac) * (fi ) * (fi-dstifac) * (fi-2*dstifac) * (fi-3*dstifac) * (- 1) - ifac(2) = (fi+2*dstifac) * (fi ) * (fi-dstifac) * (fi-2*dstifac) * (fi-3*dstifac) * ( 5) - ifac(3) = (fi+2*dstifac) * (fi+dstifac) * (fi-dstifac) * (fi-2*dstifac) * (fi-3*dstifac) * (-10) - ifac(4) = (fi+2*dstifac) * (fi+dstifac) * (fi ) * (fi-2*dstifac) * (fi-3*dstifac) * ( 10) - ifac(5) = (fi+2*dstifac) * (fi+dstifac) * (fi ) * (fi- dstifac) * (fi-3*dstifac) * (- 5) - ifac(6) = (fi+2*dstifac) * (fi+dstifac) * (fi ) * (fi- dstifac) * (fi-2*dstifac) * ( 1) - - res = 0 - - do kk=1,6 - do jj=1,6 - do ii=1,6 - - if (ifac(ii).ne.0 .and. jfac(jj).ne.0 .and. kfac(kk).ne.0) then -c (This expression cannot be evaluated as integer) - fac = one * ifac(ii) * jfac(jj) * kfac(kk) - - if (check_array_accesses.ne.0) then - call checkindex (i0+ii-2, j0+jj-2, k0+kk-2, 1,1,1, srciext,srcjext,srckext, "source") - end if - res = res + fac * src(i0+ii-2, j0+jj-2, k0+kk-2) - end if - - end do - end do - end do - - if (check_array_accesses.ne.0) then - call checkindex (dstioff+i+1, dstjoff+j+1, dstkoff+k+1, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst (dstioff+i+1, dstjoff+j+1, dstkoff+k+1) = dstdiv * res - - end do - end do - end do - - end diff --git a/Carpet/CarpetLib/src/prolongate_3d_real8_o5_rf2.F77 b/Carpet/CarpetLib/src/prolongate_3d_real8_o5_rf2.F77 deleted file mode 100644 index 2ae669aef..000000000 --- a/Carpet/CarpetLib/src/prolongate_3d_real8_o5_rf2.F77 +++ /dev/null @@ -1,702 +0,0 @@ -c -*-Fortran-*- - -#include "cctk.h" -#include "cctk_Parameters.h" - - - - subroutine prolongate_3d_real8_o5_rf2 ( - $ src, srciext, srcjext, srckext, - $ dst, dstiext, dstjext, dstkext, - $ srcbbox, dstbbox, regbbox) - - implicit none - - DECLARE_CCTK_PARAMETERS - - CCTK_REAL8 one - parameter (one = 1) - CCTK_REAL8 f1, f2, f3, f4, f5, f6 - parameter (f1 = 3*one/256) - parameter (f2 = - 25*one/256) - parameter (f3 = 150*one/256) - parameter (f4 = 150*one/256) - parameter (f5 = - 25*one/256) - parameter (f6 = 3*one/256) - - integer srciext, srcjext, srckext - CCTK_REAL8 src(srciext,srcjext,srckext) - integer dstiext, dstjext, dstkext - CCTK_REAL8 dst(dstiext,dstjext,dstkext) -c bbox(:,1) is lower boundary (inclusive) -c bbox(:,2) is upper boundary (inclusive) -c bbox(:,3) is stride - integer srcbbox(3,3), dstbbox(3,3), regbbox(3,3) - - integer regiext, regjext, regkext - - integer srcioff, srcjoff, srckoff - integer dstioff, dstjoff, dstkoff - - integer offsetlo, offsethi - - integer i0, j0, k0 - integer fi, fj, fk - integer is, js, ks - integer id, jd, kd - integer i, j, k - - CCTK_REAL8 res1, res2, res3, res4, res5, res6 - - integer d - - - - do d=1,3 - if (srcbbox(d,3).eq.0 .or. dstbbox(d,3).eq.0 - $ .or. regbbox(d,3).eq.0) then - call CCTK_WARN (0, "Internal error: stride is zero") - end if - if (srcbbox(d,3).le.regbbox(d,3) - $ .or. dstbbox(d,3).ne.regbbox(d,3)) then - call CCTK_WARN (0, "Internal error: strides disagree") - end if - if (srcbbox(d,3).ne.dstbbox(d,3)*2) then - call CCTK_WARN (0, "Internal error: source strides are not twice the destination strides") - end if - if (mod(srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array origins are not integer multiples of the strides") - end if - if (regbbox(d,1).gt.regbbox(d,2)) then -c This could be handled, but is likely to point to an error elsewhere - call CCTK_WARN (0, "Internal error: region extent is empty") - end if - if (mod(srcbbox(d,2) - srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,2) - dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,2) - regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array extents are not integer multiples of the strides") - end if - regkext = (regbbox(d,2) - regbbox(d,1)) / regbbox(d,3) + 1 - srckoff = (regbbox(d,1) - srcbbox(d,1)) / dstbbox(d,3) - offsetlo = regbbox(d,3) - if (mod(srckoff, 2).eq.0) then - offsetlo = 0 - if (regkext.gt.1) then - offsetlo = regbbox(d,3) - end if - end if - offsethi = regbbox(d,3) - if (mod(srckoff + regkext-1, 2).eq.0) then - offsethi = 0 - if (regkext.gt.1) then - offsethi = regbbox(d,3) - end if - end if - if (regbbox(d,1)-offsetlo.lt.srcbbox(d,1) - $ .or. regbbox(d,2)+offsethi.gt.srcbbox(d,2) - $ .or. regbbox(d,1).lt.dstbbox(d,1) - $ .or. regbbox(d,2).gt.dstbbox(d,2)) then - call CCTK_WARN (0, "Internal error: region extent is not contained in array extent") - end if - end do - - if (srciext.ne.(srcbbox(1,2)-srcbbox(1,1))/srcbbox(1,3)+1 - $ .or. srcjext.ne.(srcbbox(2,2)-srcbbox(2,1))/srcbbox(2,3)+1 - $ .or. srckext.ne.(srcbbox(3,2)-srcbbox(3,1))/srcbbox(3,3)+1 - $ .or. dstiext.ne.(dstbbox(1,2)-dstbbox(1,1))/dstbbox(1,3)+1 - $ .or. dstjext.ne.(dstbbox(2,2)-dstbbox(2,1))/dstbbox(2,3)+1 - $ .or. dstkext.ne.(dstbbox(3,2)-dstbbox(3,1))/dstbbox(3,3)+1) then - call CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes") - end if - - - - regiext = (regbbox(1,2) - regbbox(1,1)) / regbbox(1,3) + 1 - regjext = (regbbox(2,2) - regbbox(2,1)) / regbbox(2,3) + 1 - regkext = (regbbox(3,2) - regbbox(3,1)) / regbbox(3,3) + 1 - - srcioff = (regbbox(1,1) - srcbbox(1,1)) / dstbbox(1,3) - srcjoff = (regbbox(2,1) - srcbbox(2,1)) / dstbbox(2,3) - srckoff = (regbbox(3,1) - srcbbox(3,1)) / dstbbox(3,3) - - dstioff = (regbbox(1,1) - dstbbox(1,1)) / dstbbox(1,3) - dstjoff = (regbbox(2,1) - dstbbox(2,1)) / dstbbox(2,3) - dstkoff = (regbbox(3,1) - dstbbox(3,1)) / dstbbox(3,3) - - - - fi = mod(srcioff, 2) - fj = mod(srcjoff, 2) - fk = mod(srckoff, 2) - - i0 = srcioff / 2 - j0 = srcjoff / 2 - k0 = srckoff / 2 - - - -c Loop over fine region -c Label scheme: 8 fk fj fi - -c begin k loop - 8 continue - k = 0 - ks = k0+1 - kd = dstkoff+1 - if (fk.eq.0) goto 80 - if (fk.eq.1) goto 81 - stop - -c begin j loop - 80 continue - j = 0 - js = j0+1 - jd = dstjoff+1 - if (fj.eq.0) goto 800 - if (fj.eq.1) goto 801 - stop - -c begin i loop - 800 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8000 - if (fi.eq.1) goto 8001 - stop - -c kernel - 8000 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js,ks, 1,1,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = src(is,js,ks) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8001 - goto 900 - -c kernel - 8001 continue - if (check_array_accesses.ne.0) then - call checkindex (is-2,js,ks, 6,1,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + f1 * src(is-2,js,ks) - $ + f2 * src(is-1,js,ks) - $ + f3 * src(is ,js,ks) - $ + f4 * src(is+1,js,ks) - $ + f5 * src(is+2,js,ks) - $ + f6 * src(is+3,js,ks) - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8000 - goto 900 - -c end i loop - 900 continue - j = j+1 - jd = jd+1 - if (j.lt.regjext) goto 801 - goto 90 - -c begin i loop - 801 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8010 - if (fi.eq.1) goto 8011 - stop - -c kernel - 8010 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js-2,ks, 1,6,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + f1 * src(is,js-2,ks) - $ + f2 * src(is,js-1,ks) - $ + f3 * src(is,js ,ks) - $ + f4 * src(is,js+1,ks) - $ + f5 * src(is,js+2,ks) - $ + f6 * src(is,js+3,ks) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8011 - goto 901 - -c kernel - 8011 continue - if (check_array_accesses.ne.0) then - call checkindex (is-2,js-2,ks, 6,6,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + f1*f1 * src(is-2,js-2,ks) - $ + f2*f1 * src(is-1,js-2,ks) - $ + f3*f1 * src(is ,js-2,ks) - $ + f4*f1 * src(is+1,js-2,ks) - $ + f5*f1 * src(is+2,js-2,ks) - $ + f6*f1 * src(is+3,js-2,ks) - $ + f1*f2 * src(is-2,js-1,ks) - $ + f2*f2 * src(is-1,js-1,ks) - $ + f3*f2 * src(is ,js-1,ks) - $ + f4*f2 * src(is+1,js-1,ks) - $ + f5*f2 * src(is+2,js-1,ks) - $ + f6*f2 * src(is+3,js-1,ks) - $ + f1*f3 * src(is-2,js ,ks) - $ + f2*f3 * src(is-1,js ,ks) - $ + f3*f3 * src(is ,js ,ks) - $ + f4*f3 * src(is+1,js ,ks) - $ + f5*f3 * src(is+2,js ,ks) - $ + f6*f3 * src(is+3,js ,ks) - $ + f1*f4 * src(is-2,js+1,ks) - $ + f2*f4 * src(is-1,js+1,ks) - $ + f3*f4 * src(is ,js+1,ks) - $ + f4*f4 * src(is+1,js+1,ks) - $ + f5*f4 * src(is+2,js+1,ks) - $ + f6*f4 * src(is+3,js+1,ks) - $ + f1*f5 * src(is-2,js+2,ks) - $ + f2*f5 * src(is-1,js+2,ks) - $ + f3*f5 * src(is ,js+2,ks) - $ + f4*f5 * src(is+1,js+2,ks) - $ + f5*f5 * src(is+2,js+2,ks) - $ + f6*f5 * src(is+3,js+2,ks) - $ + f1*f6 * src(is-2,js+3,ks) - $ + f2*f6 * src(is-1,js+3,ks) - $ + f3*f6 * src(is ,js+3,ks) - $ + f4*f6 * src(is+1,js+3,ks) - $ + f5*f6 * src(is+2,js+3,ks) - $ + f6*f6 * src(is+3,js+3,ks) - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8010 - goto 901 - -c end i loop - 901 continue - j = j+1 - jd = jd+1 - js = js+1 - if (j.lt.regjext) goto 800 - goto 90 - -c end j loop - 90 continue - k = k+1 - kd = kd+1 - if (k.lt.regkext) goto 81 - goto 9 - -c begin j loop - 81 continue - j = 0 - js = j0+1 - jd = dstjoff+1 - if (fj.eq.0) goto 810 - if (fj.eq.1) goto 811 - stop - -c begin i loop - 810 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8100 - if (fi.eq.1) goto 8101 - stop - -c kernel - 8100 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js,ks-2, 1,1,6, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + f1 * src(is,js,ks-2) - $ + f2 * src(is,js,ks-1) - $ + f3 * src(is,js,ks ) - $ + f4 * src(is,js,ks+1) - $ + f5 * src(is,js,ks+2) - $ + f6 * src(is,js,ks+3) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8101 - goto 910 - -c kernel - 8101 continue - if (check_array_accesses.ne.0) then - call checkindex (is-2,js,ks-2, 6,1,6, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + f1*f1 * src(is-2,js,ks-2) - $ + f2*f1 * src(is-1,js,ks-2) - $ + f3*f1 * src(is ,js,ks-2) - $ + f4*f1 * src(is+1,js,ks-2) - $ + f5*f1 * src(is+2,js,ks-2) - $ + f6*f1 * src(is+3,js,ks-2) - $ + f1*f2 * src(is-2,js,ks-1) - $ + f2*f2 * src(is-1,js,ks-1) - $ + f3*f2 * src(is ,js,ks-1) - $ + f4*f2 * src(is+1,js,ks-1) - $ + f5*f2 * src(is+2,js,ks-1) - $ + f6*f2 * src(is+3,js,ks-1) - $ + f1*f3 * src(is-2,js,ks ) - $ + f2*f3 * src(is-1,js,ks ) - $ + f3*f3 * src(is ,js,ks ) - $ + f4*f3 * src(is+1,js,ks ) - $ + f5*f3 * src(is+2,js,ks ) - $ + f6*f3 * src(is+3,js,ks ) - $ + f1*f4 * src(is-2,js,ks+1) - $ + f2*f4 * src(is-1,js,ks+1) - $ + f3*f4 * src(is ,js,ks+1) - $ + f4*f4 * src(is+1,js,ks+1) - $ + f5*f4 * src(is+2,js,ks+1) - $ + f6*f4 * src(is+3,js,ks+1) - $ + f1*f5 * src(is-2,js,ks+2) - $ + f2*f5 * src(is-1,js,ks+2) - $ + f3*f5 * src(is ,js,ks+2) - $ + f4*f5 * src(is+1,js,ks+2) - $ + f5*f5 * src(is+2,js,ks+2) - $ + f6*f5 * src(is+3,js,ks+2) - $ + f1*f6 * src(is-2,js,ks+3) - $ + f2*f6 * src(is-1,js,ks+3) - $ + f3*f6 * src(is ,js,ks+3) - $ + f4*f6 * src(is+1,js,ks+3) - $ + f5*f6 * src(is+2,js,ks+3) - $ + f6*f6 * src(is+3,js,ks+3) - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8100 - goto 910 - -c end i loop - 910 continue - j = j+1 - jd = jd+1 - if (j.lt.regjext) goto 811 - goto 91 - -c begin i loop - 811 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8110 - if (fi.eq.1) goto 8111 - stop - -c kernel - 8110 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js-2,ks-2, 1,6,6, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + f1*f1 * src(is,js-2,ks-2) - $ + f2*f1 * src(is,js-1,ks-2) - $ + f3*f1 * src(is,js ,ks-2) - $ + f4*f1 * src(is,js+1,ks-2) - $ + f5*f1 * src(is,js+2,ks-2) - $ + f6*f1 * src(is,js+3,ks-2) - $ + f1*f2 * src(is,js-2,ks-1) - $ + f2*f2 * src(is,js-1,ks-1) - $ + f3*f2 * src(is,js ,ks-1) - $ + f4*f2 * src(is,js+1,ks-1) - $ + f5*f2 * src(is,js+2,ks-1) - $ + f6*f2 * src(is,js+3,ks-1) - $ + f1*f3 * src(is,js-2,ks ) - $ + f2*f3 * src(is,js-1,ks ) - $ + f3*f3 * src(is,js ,ks ) - $ + f4*f3 * src(is,js+1,ks ) - $ + f5*f3 * src(is,js+2,ks ) - $ + f6*f3 * src(is,js+3,ks ) - $ + f1*f4 * src(is,js-2,ks+1) - $ + f2*f4 * src(is,js-1,ks+1) - $ + f3*f4 * src(is,js ,ks+1) - $ + f4*f4 * src(is,js+1,ks+1) - $ + f5*f4 * src(is,js+2,ks+1) - $ + f6*f4 * src(is,js+3,ks+1) - $ + f1*f5 * src(is,js-2,ks+2) - $ + f2*f5 * src(is,js-1,ks+2) - $ + f3*f5 * src(is,js ,ks+2) - $ + f4*f5 * src(is,js+1,ks+2) - $ + f5*f5 * src(is,js+2,ks+2) - $ + f6*f5 * src(is,js+3,ks+2) - $ + f1*f6 * src(is,js-2,ks+3) - $ + f2*f6 * src(is,js-1,ks+3) - $ + f3*f6 * src(is,js ,ks+3) - $ + f4*f6 * src(is,js+1,ks+3) - $ + f5*f6 * src(is,js+2,ks+3) - $ + f6*f6 * src(is,js+3,ks+3) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8111 - goto 911 - -c kernel - 8111 continue - if (check_array_accesses.ne.0) then - call checkindex (is-2,js-2,ks-2, 6,6,6, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - res1 = - $ + f1*f1*f1 * src(is-2,js-2,ks-2) - $ + f2*f1*f1 * src(is-1,js-2,ks-2) - $ + f3*f1*f1 * src(is ,js-2,ks-2) - $ + f4*f1*f1 * src(is+1,js-2,ks-2) - $ + f5*f1*f1 * src(is+2,js-2,ks-2) - $ + f6*f1*f1 * src(is+3,js-2,ks-2) - $ + f1*f2*f1 * src(is-2,js-1,ks-2) - $ + f2*f2*f1 * src(is-1,js-1,ks-2) - $ + f3*f2*f1 * src(is ,js-1,ks-2) - $ + f4*f2*f1 * src(is+1,js-1,ks-2) - $ + f5*f2*f1 * src(is+2,js-1,ks-2) - $ + f6*f2*f1 * src(is+3,js-1,ks-2) - $ + f1*f3*f1 * src(is-2,js ,ks-2) - $ + f2*f3*f1 * src(is-1,js ,ks-2) - $ + f3*f3*f1 * src(is ,js ,ks-2) - $ + f4*f3*f1 * src(is+1,js ,ks-2) - $ + f5*f3*f1 * src(is+2,js ,ks-2) - $ + f6*f3*f1 * src(is+3,js ,ks-2) - $ + f1*f4*f1 * src(is-2,js+1,ks-2) - $ + f2*f4*f1 * src(is-1,js+1,ks-2) - $ + f3*f4*f1 * src(is ,js+1,ks-2) - $ + f4*f4*f1 * src(is+1,js+1,ks-2) - $ + f5*f4*f1 * src(is+2,js+1,ks-2) - $ + f6*f4*f1 * src(is+3,js+1,ks-2) - $ + f1*f5*f1 * src(is-2,js+2,ks-2) - $ + f2*f5*f1 * src(is-1,js+2,ks-2) - $ + f3*f5*f1 * src(is ,js+2,ks-2) - $ + f4*f5*f1 * src(is+1,js+2,ks-2) - $ + f5*f5*f1 * src(is+2,js+2,ks-2) - $ + f6*f5*f1 * src(is+3,js+2,ks-2) - $ + f1*f6*f1 * src(is-2,js+3,ks-2) - $ + f2*f6*f1 * src(is-1,js+3,ks-2) - $ + f3*f6*f1 * src(is ,js+3,ks-2) - $ + f4*f6*f1 * src(is+1,js+3,ks-2) - $ + f5*f6*f1 * src(is+2,js+3,ks-2) - $ + f6*f6*f1 * src(is+3,js+3,ks-2) - res2 = - $ + f1*f1*f2 * src(is-2,js-2,ks-1) - $ + f2*f1*f2 * src(is-1,js-2,ks-1) - $ + f3*f1*f2 * src(is ,js-2,ks-1) - $ + f4*f1*f2 * src(is+1,js-2,ks-1) - $ + f5*f1*f2 * src(is+2,js-2,ks-1) - $ + f6*f1*f2 * src(is+3,js-2,ks-1) - $ + f1*f2*f2 * src(is-2,js-1,ks-1) - $ + f2*f2*f2 * src(is-1,js-1,ks-1) - $ + f3*f2*f2 * src(is ,js-1,ks-1) - $ + f4*f2*f2 * src(is+1,js-1,ks-1) - $ + f5*f2*f2 * src(is+2,js-1,ks-1) - $ + f6*f2*f2 * src(is+3,js-1,ks-1) - $ + f1*f3*f2 * src(is-2,js ,ks-1) - $ + f2*f3*f2 * src(is-1,js ,ks-1) - $ + f3*f3*f2 * src(is ,js ,ks-1) - $ + f4*f3*f2 * src(is+1,js ,ks-1) - $ + f5*f3*f2 * src(is+2,js ,ks-1) - $ + f6*f3*f2 * src(is+3,js ,ks-1) - $ + f1*f4*f2 * src(is-2,js+1,ks-1) - $ + f2*f4*f2 * src(is-1,js+1,ks-1) - $ + f3*f4*f2 * src(is ,js+1,ks-1) - $ + f4*f4*f2 * src(is+1,js+1,ks-1) - $ + f5*f4*f2 * src(is+2,js+1,ks-1) - $ + f6*f4*f2 * src(is+3,js+1,ks-1) - $ + f1*f5*f2 * src(is-2,js+2,ks-1) - $ + f2*f5*f2 * src(is-1,js+2,ks-1) - $ + f3*f5*f2 * src(is ,js+2,ks-1) - $ + f4*f5*f2 * src(is+1,js+2,ks-1) - $ + f5*f5*f2 * src(is+2,js+2,ks-1) - $ + f6*f5*f2 * src(is+3,js+2,ks-1) - $ + f1*f6*f2 * src(is-2,js+3,ks-1) - $ + f2*f6*f2 * src(is-1,js+3,ks-1) - $ + f3*f6*f2 * src(is ,js+3,ks-1) - $ + f4*f6*f2 * src(is+1,js+3,ks-1) - $ + f5*f6*f2 * src(is+2,js+3,ks-1) - $ + f6*f6*f2 * src(is+3,js+3,ks-1) - res3 = - $ + f1*f1*f3 * src(is-2,js-2,ks ) - $ + f2*f1*f3 * src(is-1,js-2,ks ) - $ + f3*f1*f3 * src(is ,js-2,ks ) - $ + f4*f1*f3 * src(is+1,js-2,ks ) - $ + f5*f1*f3 * src(is+2,js-2,ks ) - $ + f6*f1*f3 * src(is+3,js-2,ks ) - $ + f1*f2*f3 * src(is-2,js-1,ks ) - $ + f2*f2*f3 * src(is-1,js-1,ks ) - $ + f3*f2*f3 * src(is ,js-1,ks ) - $ + f4*f2*f3 * src(is+1,js-1,ks ) - $ + f5*f2*f3 * src(is+2,js-1,ks ) - $ + f6*f2*f3 * src(is+3,js-1,ks ) - $ + f1*f3*f3 * src(is-2,js ,ks ) - $ + f2*f3*f3 * src(is-1,js ,ks ) - $ + f3*f3*f3 * src(is ,js ,ks ) - $ + f4*f3*f3 * src(is+1,js ,ks ) - $ + f5*f3*f3 * src(is+2,js ,ks ) - $ + f6*f3*f3 * src(is+3,js ,ks ) - $ + f1*f4*f3 * src(is-2,js+1,ks ) - $ + f2*f4*f3 * src(is-1,js+1,ks ) - $ + f3*f4*f3 * src(is ,js+1,ks ) - $ + f4*f4*f3 * src(is+1,js+1,ks ) - $ + f5*f4*f3 * src(is+2,js+1,ks ) - $ + f6*f4*f3 * src(is+3,js+1,ks ) - $ + f1*f5*f3 * src(is-2,js+2,ks ) - $ + f2*f5*f3 * src(is-1,js+2,ks ) - $ + f3*f5*f3 * src(is ,js+2,ks ) - $ + f4*f5*f3 * src(is+1,js+2,ks ) - $ + f5*f5*f3 * src(is+2,js+2,ks ) - $ + f6*f5*f3 * src(is+3,js+2,ks ) - $ + f1*f6*f3 * src(is-2,js+3,ks ) - $ + f2*f6*f3 * src(is-1,js+3,ks ) - $ + f3*f6*f3 * src(is ,js+3,ks ) - $ + f4*f6*f3 * src(is+1,js+3,ks ) - $ + f5*f6*f3 * src(is+2,js+3,ks ) - $ + f6*f6*f3 * src(is+3,js+3,ks ) - res4 = - $ + f1*f1*f4 * src(is-2,js-2,ks+1) - $ + f2*f1*f4 * src(is-1,js-2,ks+1) - $ + f3*f1*f4 * src(is ,js-2,ks+1) - $ + f4*f1*f4 * src(is+1,js-2,ks+1) - $ + f5*f1*f4 * src(is+2,js-2,ks+1) - $ + f6*f1*f4 * src(is+3,js-2,ks+1) - $ + f1*f2*f4 * src(is-2,js-1,ks+1) - $ + f2*f2*f4 * src(is-1,js-1,ks+1) - $ + f3*f2*f4 * src(is ,js-1,ks+1) - $ + f4*f2*f4 * src(is+1,js-1,ks+1) - $ + f5*f2*f4 * src(is+2,js-1,ks+1) - $ + f6*f2*f4 * src(is+3,js-1,ks+1) - $ + f1*f3*f4 * src(is-2,js ,ks+1) - $ + f2*f3*f4 * src(is-1,js ,ks+1) - $ + f3*f3*f4 * src(is ,js ,ks+1) - $ + f4*f3*f4 * src(is+1,js ,ks+1) - $ + f5*f3*f4 * src(is+2,js ,ks+1) - $ + f6*f3*f4 * src(is+3,js ,ks+1) - $ + f1*f4*f4 * src(is-2,js+1,ks+1) - $ + f2*f4*f4 * src(is-1,js+1,ks+1) - $ + f3*f4*f4 * src(is ,js+1,ks+1) - $ + f4*f4*f4 * src(is+1,js+1,ks+1) - $ + f5*f4*f4 * src(is+2,js+1,ks+1) - $ + f6*f4*f4 * src(is+3,js+1,ks+1) - $ + f1*f5*f4 * src(is-2,js+2,ks+1) - $ + f2*f5*f4 * src(is-1,js+2,ks+1) - $ + f3*f5*f4 * src(is ,js+2,ks+1) - $ + f4*f5*f4 * src(is+1,js+2,ks+1) - $ + f5*f5*f4 * src(is+2,js+2,ks+1) - $ + f6*f5*f4 * src(is+3,js+2,ks+1) - $ + f1*f6*f4 * src(is-2,js+3,ks+1) - $ + f2*f6*f4 * src(is-1,js+3,ks+1) - $ + f3*f6*f4 * src(is ,js+3,ks+1) - $ + f4*f6*f4 * src(is+1,js+3,ks+1) - $ + f5*f6*f4 * src(is+2,js+3,ks+1) - $ + f6*f6*f4 * src(is+3,js+3,ks+1) - res5 = - $ + f1*f1*f5 * src(is-2,js-2,ks+2) - $ + f2*f1*f5 * src(is-1,js-2,ks+2) - $ + f3*f1*f5 * src(is ,js-2,ks+2) - $ + f4*f1*f5 * src(is+1,js-2,ks+2) - $ + f5*f1*f5 * src(is+2,js-2,ks+2) - $ + f6*f1*f5 * src(is+3,js-2,ks+2) - $ + f1*f2*f5 * src(is-2,js-1,ks+2) - $ + f2*f2*f5 * src(is-1,js-1,ks+2) - $ + f3*f2*f5 * src(is ,js-1,ks+2) - $ + f4*f2*f5 * src(is+1,js-1,ks+2) - $ + f5*f2*f5 * src(is+2,js-1,ks+2) - $ + f6*f2*f5 * src(is+3,js-1,ks+2) - $ + f1*f3*f5 * src(is-2,js ,ks+2) - $ + f2*f3*f5 * src(is-1,js ,ks+2) - $ + f3*f3*f5 * src(is ,js ,ks+2) - $ + f4*f3*f5 * src(is+1,js ,ks+2) - $ + f5*f3*f5 * src(is+2,js ,ks+2) - $ + f6*f3*f5 * src(is+3,js ,ks+2) - $ + f1*f4*f5 * src(is-2,js+1,ks+2) - $ + f2*f4*f5 * src(is-1,js+1,ks+2) - $ + f3*f4*f5 * src(is ,js+1,ks+2) - $ + f4*f4*f5 * src(is+1,js+1,ks+2) - $ + f5*f4*f5 * src(is+2,js+1,ks+2) - $ + f6*f4*f5 * src(is+3,js+1,ks+2) - $ + f1*f5*f5 * src(is-2,js+2,ks+2) - $ + f2*f5*f5 * src(is-1,js+2,ks+2) - $ + f3*f5*f5 * src(is ,js+2,ks+2) - $ + f4*f5*f5 * src(is+1,js+2,ks+2) - $ + f5*f5*f5 * src(is+2,js+2,ks+2) - $ + f6*f5*f5 * src(is+3,js+2,ks+2) - $ + f1*f6*f5 * src(is-2,js+3,ks+2) - $ + f2*f6*f5 * src(is-1,js+3,ks+2) - $ + f3*f6*f5 * src(is ,js+3,ks+2) - $ + f4*f6*f5 * src(is+1,js+3,ks+2) - $ + f5*f6*f5 * src(is+2,js+3,ks+2) - $ + f6*f6*f5 * src(is+3,js+3,ks+2) - res6 = - $ + f1*f1*f6 * src(is-2,js-2,ks+3) - $ + f2*f1*f6 * src(is-1,js-2,ks+3) - $ + f3*f1*f6 * src(is ,js-2,ks+3) - $ + f4*f1*f6 * src(is+1,js-2,ks+3) - $ + f5*f1*f6 * src(is+2,js-2,ks+3) - $ + f6*f1*f6 * src(is+3,js-2,ks+3) - $ + f1*f2*f6 * src(is-2,js-1,ks+3) - $ + f2*f2*f6 * src(is-1,js-1,ks+3) - $ + f3*f2*f6 * src(is ,js-1,ks+3) - $ + f4*f2*f6 * src(is+1,js-1,ks+3) - $ + f5*f2*f6 * src(is+2,js-1,ks+3) - $ + f6*f2*f6 * src(is+3,js-1,ks+3) - $ + f1*f3*f6 * src(is-2,js ,ks+3) - $ + f2*f3*f6 * src(is-1,js ,ks+3) - $ + f3*f3*f6 * src(is ,js ,ks+3) - $ + f4*f3*f6 * src(is+1,js ,ks+3) - $ + f5*f3*f6 * src(is+2,js ,ks+3) - $ + f6*f3*f6 * src(is+3,js ,ks+3) - $ + f1*f4*f6 * src(is-2,js+1,ks+3) - $ + f2*f4*f6 * src(is-1,js+1,ks+3) - $ + f3*f4*f6 * src(is ,js+1,ks+3) - $ + f4*f4*f6 * src(is+1,js+1,ks+3) - $ + f5*f4*f6 * src(is+2,js+1,ks+3) - $ + f6*f4*f6 * src(is+3,js+1,ks+3) - $ + f1*f5*f6 * src(is-2,js+2,ks+3) - $ + f2*f5*f6 * src(is-1,js+2,ks+3) - $ + f3*f5*f6 * src(is ,js+2,ks+3) - $ + f4*f5*f6 * src(is+1,js+2,ks+3) - $ + f5*f5*f6 * src(is+2,js+2,ks+3) - $ + f6*f5*f6 * src(is+3,js+2,ks+3) - $ + f1*f6*f6 * src(is-2,js+3,ks+3) - $ + f2*f6*f6 * src(is-1,js+3,ks+3) - $ + f3*f6*f6 * src(is ,js+3,ks+3) - $ + f4*f6*f6 * src(is+1,js+3,ks+3) - $ + f5*f6*f6 * src(is+2,js+3,ks+3) - $ + f6*f6*f6 * src(is+3,js+3,ks+3) - dst(id,jd,kd) = res1 + res2 + res3 + res4 + res5 + res6 - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8110 - goto 911 - -c end i loop - 911 continue - j = j+1 - jd = jd+1 - js = js+1 - if (j.lt.regjext) goto 810 - goto 91 - -c end j loop - 91 continue - k = k+1 - kd = kd+1 - ks = ks+1 - if (k.lt.regkext) goto 80 - goto 9 - -c end k loop - 9 continue - - end diff --git a/Carpet/CarpetLib/src/prolongate_3d_real8_o7.F77 b/Carpet/CarpetLib/src/prolongate_3d_real8_o7.F77 deleted file mode 100644 index bcafca46a..000000000 --- a/Carpet/CarpetLib/src/prolongate_3d_real8_o7.F77 +++ /dev/null @@ -1,199 +0,0 @@ -c -*-Fortran-*- - -#include "cctk.h" -#include "cctk_Parameters.h" - - - - subroutine prolongate_3d_real8_o7 ( - $ src, srciext, srcjext, srckext, - $ dst, dstiext, dstjext, dstkext, - $ srcbbox, dstbbox, regbbox) - - implicit none - - DECLARE_CCTK_PARAMETERS - - CCTK_REAL8 one - parameter (one = 1) - - integer srciext, srcjext, srckext - CCTK_REAL8 src(srciext,srcjext,srckext) - integer dstiext, dstjext, dstkext - CCTK_REAL8 dst(dstiext,dstjext,dstkext) -c bbox(:,1) is lower boundary (inclusive) -c bbox(:,2) is upper boundary (inclusive) -c bbox(:,3) is stride - integer srcbbox(3,3), dstbbox(3,3), regbbox(3,3) - - integer offsetlo, offsethi - - integer regiext, regjext, regkext - - integer dstifac, dstjfac, dstkfac - - integer srcioff, srcjoff, srckoff - integer dstioff, dstjoff, dstkoff - - CCTK_REAL8 dstdiv - integer i, j, k - integer i0, j0, k0 - integer fi, fj, fk - integer ifac(8), jfac(8), kfac(8) - integer ii, jj, kk - CCTK_REAL8 fac - CCTK_REAL8 res - integer d - - - - do d=1,3 - if (srcbbox(d,3).eq.0 .or. dstbbox(d,3).eq.0 - $ .or. regbbox(d,3).eq.0) then - call CCTK_WARN (0, "Internal error: stride is zero") - end if - if (srcbbox(d,3).le.regbbox(d,3) - $ .or. dstbbox(d,3).ne.regbbox(d,3)) then - call CCTK_WARN (0, "Internal error: strides disagree") - end if - if (mod(srcbbox(d,3), dstbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: destination strides are not integer multiples of the source strides") - end if - if (mod(srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array origins are not integer multiples of the strides") - end if - if (regbbox(d,1).gt.regbbox(d,2)) then -c This could be handled, but is likely to point to an error elsewhere - call CCTK_WARN (0, "Internal error: region extent is empty") - end if - if (mod(srcbbox(d,2) - srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,2) - dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,2) - regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array extents are not integer multiples of the strides") - end if - regkext = (regbbox(d,2) - regbbox(d,1)) / regbbox(d,3) + 1 - dstkfac = srcbbox(d,3) / dstbbox(d,3) - srckoff = (regbbox(d,1) - srcbbox(d,1)) / dstbbox(d,3) - offsetlo = regbbox(d,3) - if (mod(srckoff + 0, dstkfac).eq.0) then - offsetlo = 0 - if (regkext.gt.1) then - offsetlo = regbbox(d,3) - end if - end if - offsethi = regbbox(d,3) - if (mod(srckoff + regkext-1, dstkfac).eq.0) then - offsethi = 0 - if (regkext.gt.1) then - offsethi = regbbox(d,3) - end if - end if - if (regbbox(d,1)-offsetlo.lt.srcbbox(d,1) - $ .or. regbbox(d,2)+offsethi.gt.srcbbox(d,2) - $ .or. regbbox(d,1).lt.dstbbox(d,1) - $ .or. regbbox(d,2).gt.dstbbox(d,2)) then - call CCTK_WARN (0, "Internal error: region extent is not contained in array extent") - end if - end do - - if (srciext.ne.(srcbbox(1,2)-srcbbox(1,1))/srcbbox(1,3)+1 - $ .or. srcjext.ne.(srcbbox(2,2)-srcbbox(2,1))/srcbbox(2,3)+1 - $ .or. srckext.ne.(srcbbox(3,2)-srcbbox(3,1))/srcbbox(3,3)+1 - $ .or. dstiext.ne.(dstbbox(1,2)-dstbbox(1,1))/dstbbox(1,3)+1 - $ .or. dstjext.ne.(dstbbox(2,2)-dstbbox(2,1))/dstbbox(2,3)+1 - $ .or. dstkext.ne.(dstbbox(3,2)-dstbbox(3,1))/dstbbox(3,3)+1) then - call CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes") - end if - - - - regiext = (regbbox(1,2) - regbbox(1,1)) / regbbox(1,3) + 1 - regjext = (regbbox(2,2) - regbbox(2,1)) / regbbox(2,3) + 1 - regkext = (regbbox(3,2) - regbbox(3,1)) / regbbox(3,3) + 1 - - dstifac = srcbbox(1,3) / dstbbox(1,3) - dstjfac = srcbbox(2,3) / dstbbox(2,3) - dstkfac = srcbbox(3,3) / dstbbox(3,3) - - srcioff = (regbbox(1,1) - srcbbox(1,1)) / dstbbox(1,3) - srcjoff = (regbbox(2,1) - srcbbox(2,1)) / dstbbox(2,3) - srckoff = (regbbox(3,1) - srcbbox(3,1)) / dstbbox(3,3) - - dstioff = (regbbox(1,1) - dstbbox(1,1)) / dstbbox(1,3) - dstjoff = (regbbox(2,1) - dstbbox(2,1)) / dstbbox(2,3) - dstkoff = (regbbox(3,1) - dstbbox(3,1)) / dstbbox(3,3) - - - -c Loop over fine region -c (This expression cannot be evaluated as integer) - dstdiv = one / (5040*dstifac**7) / (5040*dstjfac**7) / (5040*dstkfac**7) - - do k = 0, regkext-1 - k0 = (srckoff + k) / dstkfac - fk = mod(srckoff + k, dstkfac) - kfac(1) = (fk+2*dstkfac) * (fk+ dstkfac) * (fk ) * (fk-dstkfac) * (fk-2*dstkfac) * (fk-3*dstkfac) * (fk-4*dstkfac) * (- 1) - kfac(2) = (fk+3*dstkfac) * (fk+ dstkfac) * (fk ) * (fk-dstkfac) * (fk-2*dstkfac) * (fk-3*dstkfac) * (fk-4*dstkfac) * ( 7) - kfac(3) = (fk+3*dstkfac) * (fk+2*dstkfac) * (fk ) * (fk-dstkfac) * (fk-2*dstkfac) * (fk-3*dstkfac) * (fk-4*dstkfac) * (-21) - kfac(4) = (fk+3*dstkfac) * (fk+2*dstkfac) * (fk+dstkfac) * (fk-dstkfac) * (fk-2*dstkfac) * (fk-3*dstkfac) * (fk-4*dstkfac) * ( 35) - kfac(5) = (fk+3*dstkfac) * (fk+2*dstkfac) * (fk+dstkfac) * (fk ) * (fk-2*dstkfac) * (fk-3*dstkfac) * (fk-4*dstkfac) * (-35) - kfac(6) = (fk+3*dstkfac) * (fk+2*dstkfac) * (fk+dstkfac) * (fk ) * (fk- dstkfac) * (fk-3*dstkfac) * (fk-4*dstkfac) * ( 21) - kfac(7) = (fk+3*dstkfac) * (fk+2*dstkfac) * (fk+dstkfac) * (fk ) * (fk- dstkfac) * (fk-2*dstkfac) * (fk-4*dstkfac) * (- 7) - kfac(8) = (fk+3*dstkfac) * (fk+2*dstkfac) * (fk+dstkfac) * (fk ) * (fk- dstkfac) * (fk-2*dstkfac) * (fk-3*dstkfac) * ( 1) - - do j = 0, regjext-1 - j0 = (srcjoff + j) / dstjfac - fj = mod(srcjoff + j, dstjfac) - jfac(1) = (fj+2*dstjfac) * (fj+ dstjfac) * (fj ) * (fj-dstjfac) * (fj-2*dstjfac) * (fj-3*dstjfac) * (fj-4*dstjfac) * (- 1) - jfac(2) = (fj+3*dstjfac) * (fj+ dstjfac) * (fj ) * (fj-dstjfac) * (fj-2*dstjfac) * (fj-3*dstjfac) * (fj-4*dstjfac) * ( 7) - jfac(3) = (fj+3*dstjfac) * (fj+2*dstjfac) * (fj ) * (fj-dstjfac) * (fj-2*dstjfac) * (fj-3*dstjfac) * (fj-4*dstjfac) * (-21) - jfac(4) = (fj+3*dstjfac) * (fj+2*dstjfac) * (fj+dstjfac) * (fj-dstjfac) * (fj-2*dstjfac) * (fj-3*dstjfac) * (fj-4*dstjfac) * ( 35) - jfac(5) = (fj+3*dstjfac) * (fj+2*dstjfac) * (fj+dstjfac) * (fj ) * (fj-2*dstjfac) * (fj-3*dstjfac) * (fj-4*dstjfac) * (-35) - jfac(6) = (fj+3*dstjfac) * (fj+2*dstjfac) * (fj+dstjfac) * (fj ) * (fj- dstjfac) * (fj-3*dstjfac) * (fj-4*dstjfac) * ( 21) - jfac(7) = (fj+3*dstjfac) * (fj+2*dstjfac) * (fj+dstjfac) * (fj ) * (fj- dstjfac) * (fj-2*dstjfac) * (fj-4*dstjfac) * (- 7) - jfac(8) = (fj+3*dstjfac) * (fj+2*dstjfac) * (fj+dstjfac) * (fj ) * (fj- dstjfac) * (fj-2*dstjfac) * (fj-3*dstjfac) * ( 1) - - do i = 0, regiext-1 - i0 = (srcioff + i) / dstifac - fi = mod(srcioff + i, dstifac) - ifac(1) = (fi+2*dstifac) * (fi+ dstifac) * (fi ) * (fi-dstifac) * (fi-2*dstifac) * (fi-3*dstifac) * (fi-4*dstifac) * (- 1) - ifac(2) = (fi+3*dstifac) * (fi+ dstifac) * (fi ) * (fi-dstifac) * (fi-2*dstifac) * (fi-3*dstifac) * (fi-4*dstifac) * ( 7) - ifac(3) = (fi+3*dstifac) * (fi+2*dstifac) * (fi ) * (fi-dstifac) * (fi-2*dstifac) * (fi-3*dstifac) * (fi-4*dstifac) * (-21) - ifac(4) = (fi+3*dstifac) * (fi+2*dstifac) * (fi+dstifac) * (fi-dstifac) * (fi-2*dstifac) * (fi-3*dstifac) * (fi-4*dstifac) * ( 35) - ifac(5) = (fi+3*dstifac) * (fi+2*dstifac) * (fi+dstifac) * (fi ) * (fi-2*dstifac) * (fi-3*dstifac) * (fi-4*dstifac) * (-35) - ifac(6) = (fi+3*dstifac) * (fi+2*dstifac) * (fi+dstifac) * (fi ) * (fi- dstifac) * (fi-3*dstifac) * (fi-4*dstifac) * ( 21) - ifac(7) = (fi+3*dstifac) * (fi+2*dstifac) * (fi+dstifac) * (fi ) * (fi- dstifac) * (fi-2*dstifac) * (fi-4*dstifac) * (- 7) - ifac(8) = (fi+3*dstifac) * (fi+2*dstifac) * (fi+dstifac) * (fi ) * (fi- dstifac) * (fi-2*dstifac) * (fi-3*dstifac) * ( 1) - - res = 0 - - do kk=1,8 - do jj=1,8 - do ii=1,8 - - if (ifac(ii).ne.0 .and. jfac(jj).ne.0 .and. kfac(kk).ne.0) then -c (This expression cannot be evaluated as integer) - fac = one * ifac(ii) * jfac(jj) * kfac(kk) - - if (check_array_accesses.ne.0) then - call checkindex (i0+ii-3, j0+jj-3, k0+kk-3, 1,1,1, srciext,srcjext,srckext, "source") - end if - res = res + fac * src(i0+ii-3, j0+jj-3, k0+kk-3) - end if - - end do - end do - end do - - if (check_array_accesses.ne.0) then - call checkindex (dstioff+i+1, dstjoff+j+1, dstkoff+k+1, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst (dstioff+i+1, dstjoff+j+1, dstkoff+k+1) = dstdiv * res - - end do - end do - end do - - end diff --git a/Carpet/CarpetLib/src/prolongate_3d_real8_o7_rf2.F77 b/Carpet/CarpetLib/src/prolongate_3d_real8_o7_rf2.F77 deleted file mode 100644 index 6f0ec6ce5..000000000 --- a/Carpet/CarpetLib/src/prolongate_3d_real8_o7_rf2.F77 +++ /dev/null @@ -1,1092 +0,0 @@ -c -*-Fortran-*- - -#include "cctk.h" -#include "cctk_Parameters.h" - - - - subroutine prolongate_3d_real8_o7_rf2 ( - $ src, srciext, srcjext, srckext, - $ dst, dstiext, dstjext, dstkext, - $ srcbbox, dstbbox, regbbox) - - implicit none - - DECLARE_CCTK_PARAMETERS - - CCTK_REAL8 one - parameter (one = 1) - CCTK_REAL8 f1, f2, f3, f4, f5, f6, f7, f8 - parameter (f1 = - 5*one/2048) - parameter (f2 = 49*one/2048) - parameter (f3 = - 245*one/2048) - parameter (f4 = 1225*one/2048) - parameter (f5 = 1225*one/2048) - parameter (f6 = - 245*one/2048) - parameter (f7 = 49*one/2048) - parameter (f8 = - 5*one/2048) - - integer srciext, srcjext, srckext - CCTK_REAL8 src(srciext,srcjext,srckext) - integer dstiext, dstjext, dstkext - CCTK_REAL8 dst(dstiext,dstjext,dstkext) -c bbox(:,1) is lower boundary (inclusive) -c bbox(:,2) is upper boundary (inclusive) -c bbox(:,3) is stride - integer srcbbox(3,3), dstbbox(3,3), regbbox(3,3) - - integer regiext, regjext, regkext - - integer srcioff, srcjoff, srckoff - integer dstioff, dstjoff, dstkoff - - integer offsetlo, offsethi - - integer i0, j0, k0 - integer fi, fj, fk - integer is, js, ks - integer id, jd, kd - integer i, j, k - - CCTK_REAL8 res1, res2, res3, res4, res5, res6, res7, res8 - - integer d - - - - do d=1,3 - if (srcbbox(d,3).eq.0 .or. dstbbox(d,3).eq.0 - $ .or. regbbox(d,3).eq.0) then - call CCTK_WARN (0, "Internal error: stride is zero") - end if - if (srcbbox(d,3).le.regbbox(d,3) - $ .or. dstbbox(d,3).ne.regbbox(d,3)) then - call CCTK_WARN (0, "Internal error: strides disagree") - end if - if (srcbbox(d,3).ne.dstbbox(d,3)*2) then - call CCTK_WARN (0, "Internal error: source strides are not twice the destination strides") - end if - if (mod(srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array origins are not integer multiples of the strides") - end if - if (regbbox(d,1).gt.regbbox(d,2)) then -c This could be handled, but is likely to point to an error elsewhere - call CCTK_WARN (0, "Internal error: region extent is empty") - end if - if (mod(srcbbox(d,2) - srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,2) - dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,2) - regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array extents are not integer multiples of the strides") - end if - regkext = (regbbox(d,2) - regbbox(d,1)) / regbbox(d,3) + 1 - srckoff = (regbbox(d,1) - srcbbox(d,1)) / dstbbox(d,3) - offsetlo = regbbox(d,3) - if (mod(srckoff, 2).eq.0) then - offsetlo = 0 - if (regkext.gt.1) then - offsetlo = regbbox(d,3) - end if - end if - offsethi = regbbox(d,3) - if (mod(srckoff + regkext-1, 2).eq.0) then - offsethi = 0 - if (regkext.gt.1) then - offsethi = regbbox(d,3) - end if - end if - if (regbbox(d,1)-offsetlo.lt.srcbbox(d,1) - $ .or. regbbox(d,2)+offsethi.gt.srcbbox(d,2) - $ .or. regbbox(d,1).lt.dstbbox(d,1) - $ .or. regbbox(d,2).gt.dstbbox(d,2)) then - call CCTK_WARN (0, "Internal error: region extent is not contained in array extent") - end if - end do - - if (srciext.ne.(srcbbox(1,2)-srcbbox(1,1))/srcbbox(1,3)+1 - $ .or. srcjext.ne.(srcbbox(2,2)-srcbbox(2,1))/srcbbox(2,3)+1 - $ .or. srckext.ne.(srcbbox(3,2)-srcbbox(3,1))/srcbbox(3,3)+1 - $ .or. dstiext.ne.(dstbbox(1,2)-dstbbox(1,1))/dstbbox(1,3)+1 - $ .or. dstjext.ne.(dstbbox(2,2)-dstbbox(2,1))/dstbbox(2,3)+1 - $ .or. dstkext.ne.(dstbbox(3,2)-dstbbox(3,1))/dstbbox(3,3)+1) then - call CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes") - end if - - - - regiext = (regbbox(1,2) - regbbox(1,1)) / regbbox(1,3) + 1 - regjext = (regbbox(2,2) - regbbox(2,1)) / regbbox(2,3) + 1 - regkext = (regbbox(3,2) - regbbox(3,1)) / regbbox(3,3) + 1 - - srcioff = (regbbox(1,1) - srcbbox(1,1)) / dstbbox(1,3) - srcjoff = (regbbox(2,1) - srcbbox(2,1)) / dstbbox(2,3) - srckoff = (regbbox(3,1) - srcbbox(3,1)) / dstbbox(3,3) - - dstioff = (regbbox(1,1) - dstbbox(1,1)) / dstbbox(1,3) - dstjoff = (regbbox(2,1) - dstbbox(2,1)) / dstbbox(2,3) - dstkoff = (regbbox(3,1) - dstbbox(3,1)) / dstbbox(3,3) - - - - fi = mod(srcioff, 2) - fj = mod(srcjoff, 2) - fk = mod(srckoff, 2) - - i0 = srcioff / 2 - j0 = srcjoff / 2 - k0 = srckoff / 2 - - - -c Loop over fine region -c Label scheme: 8 fk fj fi - -c begin k loop - 8 continue - k = 0 - ks = k0+1 - kd = dstkoff+1 - if (fk.eq.0) goto 80 - if (fk.eq.1) goto 81 - stop - -c begin j loop - 80 continue - j = 0 - js = j0+1 - jd = dstjoff+1 - if (fj.eq.0) goto 800 - if (fj.eq.1) goto 801 - stop - -c begin i loop - 800 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8000 - if (fi.eq.1) goto 8001 - stop - -c kernel - 8000 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js,ks, 1,1,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = src(is,js,ks) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8001 - goto 900 - -c kernel - 8001 continue - if (check_array_accesses.ne.0) then - call checkindex (is-3,js,ks, 8,1,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + f1 * src(is-3,js,ks) - $ + f2 * src(is-2,js,ks) - $ + f3 * src(is-1,js,ks) - $ + f4 * src(is ,js,ks) - $ + f5 * src(is+1,js,ks) - $ + f6 * src(is+2,js,ks) - $ + f7 * src(is+3,js,ks) - $ + f8 * src(is+4,js,ks) - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8000 - goto 900 - -c end i loop - 900 continue - j = j+1 - jd = jd+1 - if (j.lt.regjext) goto 801 - goto 90 - -c begin i loop - 801 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8010 - if (fi.eq.1) goto 8011 - stop - -c kernel - 8010 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js-3,ks, 1,8,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + f1 * src(is,js-3,ks) - $ + f2 * src(is,js-2,ks) - $ + f3 * src(is,js-1,ks) - $ + f4 * src(is,js ,ks) - $ + f5 * src(is,js+1,ks) - $ + f6 * src(is,js+2,ks) - $ + f7 * src(is,js+3,ks) - $ + f8 * src(is,js+4,ks) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8011 - goto 901 - -c kernel - 8011 continue - if (check_array_accesses.ne.0) then - call checkindex (is-3,js-3,ks, 8,8,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + f1*f1 * src(is-3,js-3,ks) - $ + f2*f1 * src(is-2,js-3,ks) - $ + f3*f1 * src(is-1,js-3,ks) - $ + f4*f1 * src(is ,js-3,ks) - $ + f5*f1 * src(is+1,js-3,ks) - $ + f6*f1 * src(is+2,js-3,ks) - $ + f7*f1 * src(is+3,js-3,ks) - $ + f8*f1 * src(is+4,js-3,ks) - $ + f1*f2 * src(is-3,js-2,ks) - $ + f2*f2 * src(is-2,js-2,ks) - $ + f3*f2 * src(is-1,js-2,ks) - $ + f4*f2 * src(is ,js-2,ks) - $ + f5*f2 * src(is+1,js-2,ks) - $ + f6*f2 * src(is+2,js-2,ks) - $ + f7*f2 * src(is+3,js-2,ks) - $ + f8*f2 * src(is+4,js-2,ks) - $ + f1*f3 * src(is-3,js-1,ks) - $ + f2*f3 * src(is-2,js-1,ks) - $ + f3*f3 * src(is-1,js-1,ks) - $ + f4*f3 * src(is ,js-1,ks) - $ + f5*f3 * src(is+1,js-1,ks) - $ + f6*f3 * src(is+2,js-1,ks) - $ + f7*f3 * src(is+3,js-1,ks) - $ + f8*f3 * src(is+4,js-1,ks) - $ + f1*f4 * src(is-3,js ,ks) - $ + f2*f4 * src(is-2,js ,ks) - $ + f3*f4 * src(is-1,js ,ks) - $ + f4*f4 * src(is ,js ,ks) - $ + f5*f4 * src(is+1,js ,ks) - $ + f6*f4 * src(is+2,js ,ks) - $ + f7*f4 * src(is+3,js ,ks) - $ + f8*f4 * src(is+4,js ,ks) - $ + f1*f5 * src(is-3,js+1,ks) - $ + f2*f5 * src(is-2,js+1,ks) - $ + f3*f5 * src(is-1,js+1,ks) - $ + f4*f5 * src(is ,js+1,ks) - $ + f5*f5 * src(is+1,js+1,ks) - $ + f6*f5 * src(is+2,js+1,ks) - $ + f7*f5 * src(is+3,js+1,ks) - $ + f8*f5 * src(is+4,js+1,ks) - $ + f1*f6 * src(is-3,js+2,ks) - $ + f2*f6 * src(is-2,js+2,ks) - $ + f3*f6 * src(is-1,js+2,ks) - $ + f4*f6 * src(is ,js+2,ks) - $ + f5*f6 * src(is+1,js+2,ks) - $ + f6*f6 * src(is+2,js+2,ks) - $ + f7*f6 * src(is+3,js+2,ks) - $ + f8*f6 * src(is+4,js+2,ks) - $ + f1*f7 * src(is-3,js+3,ks) - $ + f2*f7 * src(is-2,js+3,ks) - $ + f3*f7 * src(is-1,js+3,ks) - $ + f4*f7 * src(is ,js+3,ks) - $ + f5*f7 * src(is+1,js+3,ks) - $ + f6*f7 * src(is+2,js+3,ks) - $ + f7*f7 * src(is+3,js+3,ks) - $ + f8*f7 * src(is+4,js+3,ks) - $ + f1*f8 * src(is-3,js+4,ks) - $ + f2*f8 * src(is-2,js+4,ks) - $ + f3*f8 * src(is-1,js+4,ks) - $ + f4*f8 * src(is ,js+4,ks) - $ + f5*f8 * src(is+1,js+4,ks) - $ + f6*f8 * src(is+2,js+4,ks) - $ + f7*f8 * src(is+3,js+4,ks) - $ + f8*f8 * src(is+4,js+4,ks) - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8010 - goto 901 - -c end i loop - 901 continue - j = j+1 - jd = jd+1 - js = js+1 - if (j.lt.regjext) goto 800 - goto 90 - -c end j loop - 90 continue - k = k+1 - kd = kd+1 - if (k.lt.regkext) goto 81 - goto 9 - -c begin j loop - 81 continue - j = 0 - js = j0+1 - jd = dstjoff+1 - if (fj.eq.0) goto 810 - if (fj.eq.1) goto 811 - stop - -c begin i loop - 810 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8100 - if (fi.eq.1) goto 8101 - stop - -c kernel - 8100 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js,ks-3, 1,1,8, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + f1 * src(is,js,ks-3) - $ + f2 * src(is,js,ks-2) - $ + f3 * src(is,js,ks-1) - $ + f4 * src(is,js,ks ) - $ + f5 * src(is,js,ks+1) - $ + f6 * src(is,js,ks+2) - $ + f7 * src(is,js,ks+3) - $ + f8 * src(is,js,ks+4) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8101 - goto 910 - -c kernel - 8101 continue - if (check_array_accesses.ne.0) then - call checkindex (is-3,js,ks-3, 8,1,8, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + f1*f1 * src(is-3,js,ks-3) - $ + f2*f1 * src(is-2,js,ks-3) - $ + f3*f1 * src(is-1,js,ks-3) - $ + f4*f1 * src(is ,js,ks-3) - $ + f5*f1 * src(is+1,js,ks-3) - $ + f6*f1 * src(is+2,js,ks-3) - $ + f7*f1 * src(is+3,js,ks-3) - $ + f8*f1 * src(is+4,js,ks-3) - $ + f1*f2 * src(is-3,js,ks-2) - $ + f2*f2 * src(is-2,js,ks-2) - $ + f3*f2 * src(is-1,js,ks-2) - $ + f4*f2 * src(is ,js,ks-2) - $ + f5*f2 * src(is+1,js,ks-2) - $ + f6*f2 * src(is+2,js,ks-2) - $ + f7*f2 * src(is+3,js,ks-2) - $ + f8*f2 * src(is+4,js,ks-2) - $ + f1*f3 * src(is-3,js,ks-1) - $ + f2*f3 * src(is-2,js,ks-1) - $ + f3*f3 * src(is-1,js,ks-1) - $ + f4*f3 * src(is ,js,ks-1) - $ + f5*f3 * src(is+1,js,ks-1) - $ + f6*f3 * src(is+2,js,ks-1) - $ + f7*f3 * src(is+3,js,ks-1) - $ + f8*f3 * src(is+4,js,ks-1) - $ + f1*f4 * src(is-3,js,ks ) - $ + f2*f4 * src(is-2,js,ks ) - $ + f3*f4 * src(is-1,js,ks ) - $ + f4*f4 * src(is ,js,ks ) - $ + f5*f4 * src(is+1,js,ks ) - $ + f6*f4 * src(is+2,js,ks ) - $ + f7*f4 * src(is+3,js,ks ) - $ + f8*f4 * src(is+4,js,ks ) - $ + f1*f5 * src(is-3,js,ks+1) - $ + f2*f5 * src(is-2,js,ks+1) - $ + f3*f5 * src(is-1,js,ks+1) - $ + f4*f5 * src(is ,js,ks+1) - $ + f5*f5 * src(is+1,js,ks+1) - $ + f6*f5 * src(is+2,js,ks+1) - $ + f7*f5 * src(is+3,js,ks+1) - $ + f8*f5 * src(is+4,js,ks+1) - $ + f1*f6 * src(is-3,js,ks+2) - $ + f2*f6 * src(is-2,js,ks+2) - $ + f3*f6 * src(is-1,js,ks+2) - $ + f4*f6 * src(is ,js,ks+2) - $ + f5*f6 * src(is+1,js,ks+2) - $ + f6*f6 * src(is+2,js,ks+2) - $ + f7*f6 * src(is+3,js,ks+2) - $ + f8*f6 * src(is+4,js,ks+2) - $ + f1*f7 * src(is-3,js,ks+3) - $ + f2*f7 * src(is-2,js,ks+3) - $ + f3*f7 * src(is-1,js,ks+3) - $ + f4*f7 * src(is ,js,ks+3) - $ + f5*f7 * src(is+1,js,ks+3) - $ + f6*f7 * src(is+2,js,ks+3) - $ + f7*f7 * src(is+3,js,ks+3) - $ + f8*f7 * src(is+4,js,ks+3) - $ + f1*f8 * src(is-3,js,ks+4) - $ + f2*f8 * src(is-2,js,ks+4) - $ + f3*f8 * src(is-1,js,ks+4) - $ + f4*f8 * src(is ,js,ks+4) - $ + f5*f8 * src(is+1,js,ks+4) - $ + f6*f8 * src(is+2,js,ks+4) - $ + f7*f8 * src(is+3,js,ks+4) - $ + f8*f8 * src(is+4,js,ks+4) - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8100 - goto 910 - -c end i loop - 910 continue - j = j+1 - jd = jd+1 - if (j.lt.regjext) goto 811 - goto 91 - -c begin i loop - 811 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8110 - if (fi.eq.1) goto 8111 - stop - -c kernel - 8110 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js-3,ks-3, 1,8,8, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + f1*f1 * src(is,js-3,ks-3) - $ + f2*f1 * src(is,js-2,ks-3) - $ + f3*f1 * src(is,js-1,ks-3) - $ + f4*f1 * src(is,js ,ks-3) - $ + f5*f1 * src(is,js+1,ks-3) - $ + f6*f1 * src(is,js+2,ks-3) - $ + f7*f1 * src(is,js+3,ks-3) - $ + f8*f1 * src(is,js+4,ks-3) - $ + f1*f2 * src(is,js-3,ks-2) - $ + f2*f2 * src(is,js-2,ks-2) - $ + f3*f2 * src(is,js-1,ks-2) - $ + f4*f2 * src(is,js ,ks-2) - $ + f5*f2 * src(is,js+1,ks-2) - $ + f6*f2 * src(is,js+2,ks-2) - $ + f7*f2 * src(is,js+3,ks-2) - $ + f8*f2 * src(is,js+4,ks-2) - $ + f1*f3 * src(is,js-3,ks-1) - $ + f2*f3 * src(is,js-2,ks-1) - $ + f3*f3 * src(is,js-1,ks-1) - $ + f4*f3 * src(is,js ,ks-1) - $ + f5*f3 * src(is,js+1,ks-1) - $ + f6*f3 * src(is,js+2,ks-1) - $ + f7*f3 * src(is,js+3,ks-1) - $ + f8*f3 * src(is,js+4,ks-1) - $ + f1*f4 * src(is,js-3,ks ) - $ + f2*f4 * src(is,js-2,ks ) - $ + f3*f4 * src(is,js-1,ks ) - $ + f4*f4 * src(is,js ,ks ) - $ + f5*f4 * src(is,js+1,ks ) - $ + f6*f4 * src(is,js+2,ks ) - $ + f7*f4 * src(is,js+3,ks ) - $ + f8*f4 * src(is,js+4,ks ) - $ + f1*f5 * src(is,js-3,ks+1) - $ + f2*f5 * src(is,js-2,ks+1) - $ + f3*f5 * src(is,js-1,ks+1) - $ + f4*f5 * src(is,js ,ks+1) - $ + f5*f5 * src(is,js+1,ks+1) - $ + f6*f5 * src(is,js+2,ks+1) - $ + f7*f5 * src(is,js+3,ks+1) - $ + f8*f5 * src(is,js+4,ks+1) - $ + f1*f6 * src(is,js-3,ks+2) - $ + f2*f6 * src(is,js-2,ks+2) - $ + f3*f6 * src(is,js-1,ks+2) - $ + f4*f6 * src(is,js ,ks+2) - $ + f5*f6 * src(is,js+1,ks+2) - $ + f6*f6 * src(is,js+2,ks+2) - $ + f7*f6 * src(is,js+3,ks+2) - $ + f8*f6 * src(is,js+4,ks+2) - $ + f1*f7 * src(is,js-3,ks+3) - $ + f2*f7 * src(is,js-2,ks+3) - $ + f3*f7 * src(is,js-1,ks+3) - $ + f4*f7 * src(is,js ,ks+3) - $ + f5*f7 * src(is,js+1,ks+3) - $ + f6*f7 * src(is,js+2,ks+3) - $ + f7*f7 * src(is,js+3,ks+3) - $ + f8*f7 * src(is,js+4,ks+3) - $ + f1*f8 * src(is,js-3,ks+4) - $ + f2*f8 * src(is,js-2,ks+4) - $ + f3*f8 * src(is,js-1,ks+4) - $ + f4*f8 * src(is,js ,ks+4) - $ + f5*f8 * src(is,js+1,ks+4) - $ + f6*f8 * src(is,js+2,ks+4) - $ + f7*f8 * src(is,js+3,ks+4) - $ + f8*f8 * src(is,js+4,ks+4) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8111 - goto 911 - -c kernel - 8111 continue - if (check_array_accesses.ne.0) then - call checkindex (is-3,js-3,ks-3, 8,8,8, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - res1 = - $ + f1*f1*f1 * src(is-3,js-3,ks-3) - $ + f2*f1*f1 * src(is-2,js-3,ks-3) - $ + f3*f1*f1 * src(is-1,js-3,ks-3) - $ + f4*f1*f1 * src(is ,js-3,ks-3) - $ + f5*f1*f1 * src(is+1,js-3,ks-3) - $ + f6*f1*f1 * src(is+2,js-3,ks-3) - $ + f7*f1*f1 * src(is+3,js-3,ks-3) - $ + f8*f1*f1 * src(is+4,js-3,ks-3) - $ + f1*f2*f1 * src(is-3,js-2,ks-3) - $ + f2*f2*f1 * src(is-2,js-2,ks-3) - $ + f3*f2*f1 * src(is-1,js-2,ks-3) - $ + f4*f2*f1 * src(is ,js-2,ks-3) - $ + f5*f2*f1 * src(is+1,js-2,ks-3) - $ + f6*f2*f1 * src(is+2,js-2,ks-3) - $ + f7*f2*f1 * src(is+3,js-2,ks-3) - $ + f8*f2*f1 * src(is+4,js-2,ks-3) - $ + f1*f3*f1 * src(is-3,js-1,ks-3) - $ + f2*f3*f1 * src(is-2,js-1,ks-3) - $ + f3*f3*f1 * src(is-1,js-1,ks-3) - $ + f4*f3*f1 * src(is ,js-1,ks-3) - $ + f5*f3*f1 * src(is+1,js-1,ks-3) - $ + f6*f3*f1 * src(is+2,js-1,ks-3) - $ + f7*f3*f1 * src(is+3,js-1,ks-3) - $ + f8*f3*f1 * src(is+4,js-1,ks-3) - $ + f1*f4*f1 * src(is-3,js ,ks-3) - $ + f2*f4*f1 * src(is-2,js ,ks-3) - $ + f3*f4*f1 * src(is-1,js ,ks-3) - $ + f4*f4*f1 * src(is ,js ,ks-3) - $ + f5*f4*f1 * src(is+1,js ,ks-3) - $ + f6*f4*f1 * src(is+2,js ,ks-3) - $ + f7*f4*f1 * src(is+3,js ,ks-3) - $ + f8*f4*f1 * src(is+4,js ,ks-3) - $ + f1*f5*f1 * src(is-3,js+1,ks-3) - $ + f2*f5*f1 * src(is-2,js+1,ks-3) - $ + f3*f5*f1 * src(is-1,js+1,ks-3) - $ + f4*f5*f1 * src(is ,js+1,ks-3) - $ + f5*f5*f1 * src(is+1,js+1,ks-3) - $ + f6*f5*f1 * src(is+2,js+1,ks-3) - $ + f7*f5*f1 * src(is+3,js+1,ks-3) - $ + f8*f5*f1 * src(is+4,js+1,ks-3) - $ + f1*f6*f1 * src(is-3,js+2,ks-3) - $ + f2*f6*f1 * src(is-2,js+2,ks-3) - $ + f3*f6*f1 * src(is-1,js+2,ks-3) - $ + f4*f6*f1 * src(is ,js+2,ks-3) - $ + f5*f6*f1 * src(is+1,js+2,ks-3) - $ + f6*f6*f1 * src(is+2,js+2,ks-3) - $ + f7*f6*f1 * src(is+3,js+2,ks-3) - $ + f8*f6*f1 * src(is+4,js+2,ks-3) - $ + f1*f7*f1 * src(is-3,js+3,ks-3) - $ + f2*f7*f1 * src(is-2,js+3,ks-3) - $ + f3*f7*f1 * src(is-1,js+3,ks-3) - $ + f4*f7*f1 * src(is ,js+3,ks-3) - $ + f5*f7*f1 * src(is+1,js+3,ks-3) - $ + f6*f7*f1 * src(is+2,js+3,ks-3) - $ + f7*f7*f1 * src(is+3,js+3,ks-3) - $ + f8*f7*f1 * src(is+4,js+3,ks-3) - $ + f1*f8*f1 * src(is-3,js+4,ks-3) - $ + f2*f8*f1 * src(is-2,js+4,ks-3) - $ + f3*f8*f1 * src(is-1,js+4,ks-3) - $ + f4*f8*f1 * src(is ,js+4,ks-3) - $ + f5*f8*f1 * src(is+1,js+4,ks-3) - $ + f6*f8*f1 * src(is+2,js+4,ks-3) - $ + f7*f8*f1 * src(is+3,js+4,ks-3) - $ + f8*f8*f1 * src(is+4,js+4,ks-3) - res1 = - $ + f1*f1*f2 * src(is-3,js-3,ks-2) - $ + f2*f1*f2 * src(is-2,js-3,ks-2) - $ + f3*f1*f2 * src(is-1,js-3,ks-2) - $ + f4*f1*f2 * src(is ,js-3,ks-2) - $ + f5*f1*f2 * src(is+1,js-3,ks-2) - $ + f6*f1*f2 * src(is+2,js-3,ks-2) - $ + f7*f1*f2 * src(is+3,js-3,ks-2) - $ + f8*f1*f2 * src(is+4,js-3,ks-2) - $ + f1*f2*f2 * src(is-3,js-2,ks-2) - $ + f2*f2*f2 * src(is-2,js-2,ks-2) - $ + f3*f2*f2 * src(is-1,js-2,ks-2) - $ + f4*f2*f2 * src(is ,js-2,ks-2) - $ + f5*f2*f2 * src(is+1,js-2,ks-2) - $ + f6*f2*f2 * src(is+2,js-2,ks-2) - $ + f7*f2*f2 * src(is+3,js-2,ks-2) - $ + f8*f2*f2 * src(is+4,js-2,ks-2) - $ + f1*f3*f2 * src(is-3,js-1,ks-2) - $ + f2*f3*f2 * src(is-2,js-1,ks-2) - $ + f3*f3*f2 * src(is-1,js-1,ks-2) - $ + f4*f3*f2 * src(is ,js-1,ks-2) - $ + f5*f3*f2 * src(is+1,js-1,ks-2) - $ + f6*f3*f2 * src(is+2,js-1,ks-2) - $ + f7*f3*f2 * src(is+3,js-1,ks-2) - $ + f8*f3*f2 * src(is+4,js-1,ks-2) - $ + f1*f4*f2 * src(is-3,js ,ks-2) - $ + f2*f4*f2 * src(is-2,js ,ks-2) - $ + f3*f4*f2 * src(is-1,js ,ks-2) - $ + f4*f4*f2 * src(is ,js ,ks-2) - $ + f5*f4*f2 * src(is+1,js ,ks-2) - $ + f6*f4*f2 * src(is+2,js ,ks-2) - $ + f7*f4*f2 * src(is+3,js ,ks-2) - $ + f8*f4*f2 * src(is+4,js ,ks-2) - $ + f1*f5*f2 * src(is-3,js+1,ks-2) - $ + f2*f5*f2 * src(is-2,js+1,ks-2) - $ + f3*f5*f2 * src(is-1,js+1,ks-2) - $ + f4*f5*f2 * src(is ,js+1,ks-2) - $ + f5*f5*f2 * src(is+1,js+1,ks-2) - $ + f6*f5*f2 * src(is+2,js+1,ks-2) - $ + f7*f5*f2 * src(is+3,js+1,ks-2) - $ + f8*f5*f2 * src(is+4,js+1,ks-2) - $ + f1*f6*f2 * src(is-3,js+2,ks-2) - $ + f2*f6*f2 * src(is-2,js+2,ks-2) - $ + f3*f6*f2 * src(is-1,js+2,ks-2) - $ + f4*f6*f2 * src(is ,js+2,ks-2) - $ + f5*f6*f2 * src(is+1,js+2,ks-2) - $ + f6*f6*f2 * src(is+2,js+2,ks-2) - $ + f7*f6*f2 * src(is+3,js+2,ks-2) - $ + f8*f6*f2 * src(is+4,js+2,ks-2) - $ + f1*f7*f2 * src(is-3,js+3,ks-2) - $ + f2*f7*f2 * src(is-2,js+3,ks-2) - $ + f3*f7*f2 * src(is-1,js+3,ks-2) - $ + f4*f7*f2 * src(is ,js+3,ks-2) - $ + f5*f7*f2 * src(is+1,js+3,ks-2) - $ + f6*f7*f2 * src(is+2,js+3,ks-2) - $ + f7*f7*f2 * src(is+3,js+3,ks-2) - $ + f8*f7*f2 * src(is+4,js+3,ks-2) - $ + f1*f8*f2 * src(is-3,js+4,ks-2) - $ + f2*f8*f2 * src(is-2,js+4,ks-2) - $ + f3*f8*f2 * src(is-1,js+4,ks-2) - $ + f4*f8*f2 * src(is ,js+4,ks-2) - $ + f5*f8*f2 * src(is+1,js+4,ks-2) - $ + f6*f8*f2 * src(is+2,js+4,ks-2) - $ + f7*f8*f2 * src(is+3,js+4,ks-2) - $ + f8*f8*f2 * src(is+4,js+4,ks-2) - res3 = - $ + f1*f1*f3 * src(is-3,js-3,ks-1) - $ + f2*f1*f3 * src(is-2,js-3,ks-1) - $ + f3*f1*f3 * src(is-1,js-3,ks-1) - $ + f4*f1*f3 * src(is ,js-3,ks-1) - $ + f5*f1*f3 * src(is+1,js-3,ks-1) - $ + f6*f1*f3 * src(is+2,js-3,ks-1) - $ + f7*f1*f3 * src(is+3,js-3,ks-1) - $ + f8*f1*f3 * src(is+4,js-3,ks-1) - $ + f1*f2*f3 * src(is-3,js-2,ks-1) - $ + f2*f2*f3 * src(is-2,js-2,ks-1) - $ + f3*f2*f3 * src(is-1,js-2,ks-1) - $ + f4*f2*f3 * src(is ,js-2,ks-1) - $ + f5*f2*f3 * src(is+1,js-2,ks-1) - $ + f6*f2*f3 * src(is+2,js-2,ks-1) - $ + f7*f2*f3 * src(is+3,js-2,ks-1) - $ + f8*f2*f3 * src(is+4,js-2,ks-1) - $ + f1*f3*f3 * src(is-3,js-1,ks-1) - $ + f2*f3*f3 * src(is-2,js-1,ks-1) - $ + f3*f3*f3 * src(is-1,js-1,ks-1) - $ + f4*f3*f3 * src(is ,js-1,ks-1) - $ + f5*f3*f3 * src(is+1,js-1,ks-1) - $ + f6*f3*f3 * src(is+2,js-1,ks-1) - $ + f7*f3*f3 * src(is+3,js-1,ks-1) - $ + f8*f3*f3 * src(is+4,js-1,ks-1) - $ + f1*f4*f3 * src(is-3,js ,ks-1) - $ + f2*f4*f3 * src(is-2,js ,ks-1) - $ + f3*f4*f3 * src(is-1,js ,ks-1) - $ + f4*f4*f3 * src(is ,js ,ks-1) - $ + f5*f4*f3 * src(is+1,js ,ks-1) - $ + f6*f4*f3 * src(is+2,js ,ks-1) - $ + f7*f4*f3 * src(is+3,js ,ks-1) - $ + f8*f4*f3 * src(is+4,js ,ks-1) - $ + f1*f5*f3 * src(is-3,js+1,ks-1) - $ + f2*f5*f3 * src(is-2,js+1,ks-1) - $ + f3*f5*f3 * src(is-1,js+1,ks-1) - $ + f4*f5*f3 * src(is ,js+1,ks-1) - $ + f5*f5*f3 * src(is+1,js+1,ks-1) - $ + f6*f5*f3 * src(is+2,js+1,ks-1) - $ + f7*f5*f3 * src(is+3,js+1,ks-1) - $ + f8*f5*f3 * src(is+4,js+1,ks-1) - $ + f1*f6*f3 * src(is-3,js+2,ks-1) - $ + f2*f6*f3 * src(is-2,js+2,ks-1) - $ + f3*f6*f3 * src(is-1,js+2,ks-1) - $ + f4*f6*f3 * src(is ,js+2,ks-1) - $ + f5*f6*f3 * src(is+1,js+2,ks-1) - $ + f6*f6*f3 * src(is+2,js+2,ks-1) - $ + f7*f6*f3 * src(is+3,js+2,ks-1) - $ + f8*f6*f3 * src(is+4,js+2,ks-1) - $ + f1*f7*f3 * src(is-3,js+3,ks-1) - $ + f2*f7*f3 * src(is-2,js+3,ks-1) - $ + f3*f7*f3 * src(is-1,js+3,ks-1) - $ + f4*f7*f3 * src(is ,js+3,ks-1) - $ + f5*f7*f3 * src(is+1,js+3,ks-1) - $ + f6*f7*f3 * src(is+2,js+3,ks-1) - $ + f7*f7*f3 * src(is+3,js+3,ks-1) - $ + f8*f7*f3 * src(is+4,js+3,ks-1) - $ + f1*f8*f3 * src(is-3,js+4,ks-1) - $ + f2*f8*f3 * src(is-2,js+4,ks-1) - $ + f3*f8*f3 * src(is-1,js+4,ks-1) - $ + f4*f8*f3 * src(is ,js+4,ks-1) - $ + f5*f8*f3 * src(is+1,js+4,ks-1) - $ + f6*f8*f3 * src(is+2,js+4,ks-1) - $ + f7*f8*f3 * src(is+3,js+4,ks-1) - $ + f8*f8*f3 * src(is+4,js+4,ks-1) - res4 = - $ + f1*f1*f4 * src(is-3,js-3,ks ) - $ + f2*f1*f4 * src(is-2,js-3,ks ) - $ + f3*f1*f4 * src(is-1,js-3,ks ) - $ + f4*f1*f4 * src(is ,js-3,ks ) - $ + f5*f1*f4 * src(is+1,js-3,ks ) - $ + f6*f1*f4 * src(is+2,js-3,ks ) - $ + f7*f1*f4 * src(is+3,js-3,ks ) - $ + f8*f1*f4 * src(is+4,js-3,ks ) - $ + f1*f2*f4 * src(is-3,js-2,ks ) - $ + f2*f2*f4 * src(is-2,js-2,ks ) - $ + f3*f2*f4 * src(is-1,js-2,ks ) - $ + f4*f2*f4 * src(is ,js-2,ks ) - $ + f5*f2*f4 * src(is+1,js-2,ks ) - $ + f6*f2*f4 * src(is+2,js-2,ks ) - $ + f7*f2*f4 * src(is+3,js-2,ks ) - $ + f8*f2*f4 * src(is+4,js-2,ks ) - $ + f1*f3*f4 * src(is-3,js-1,ks ) - $ + f2*f3*f4 * src(is-2,js-1,ks ) - $ + f3*f3*f4 * src(is-1,js-1,ks ) - $ + f4*f3*f4 * src(is ,js-1,ks ) - $ + f5*f3*f4 * src(is+1,js-1,ks ) - $ + f6*f3*f4 * src(is+2,js-1,ks ) - $ + f7*f3*f4 * src(is+3,js-1,ks ) - $ + f8*f3*f4 * src(is+4,js-1,ks ) - $ + f1*f4*f4 * src(is-3,js ,ks ) - $ + f2*f4*f4 * src(is-2,js ,ks ) - $ + f3*f4*f4 * src(is-1,js ,ks ) - $ + f4*f4*f4 * src(is ,js ,ks ) - $ + f5*f4*f4 * src(is+1,js ,ks ) - $ + f6*f4*f4 * src(is+2,js ,ks ) - $ + f7*f4*f4 * src(is+3,js ,ks ) - $ + f8*f4*f4 * src(is+4,js ,ks ) - $ + f1*f5*f4 * src(is-3,js+1,ks ) - $ + f2*f5*f4 * src(is-2,js+1,ks ) - $ + f3*f5*f4 * src(is-1,js+1,ks ) - $ + f4*f5*f4 * src(is ,js+1,ks ) - $ + f5*f5*f4 * src(is+1,js+1,ks ) - $ + f6*f5*f4 * src(is+2,js+1,ks ) - $ + f7*f5*f4 * src(is+3,js+1,ks ) - $ + f8*f5*f4 * src(is+4,js+1,ks ) - $ + f1*f6*f4 * src(is-3,js+2,ks ) - $ + f2*f6*f4 * src(is-2,js+2,ks ) - $ + f3*f6*f4 * src(is-1,js+2,ks ) - $ + f4*f6*f4 * src(is ,js+2,ks ) - $ + f5*f6*f4 * src(is+1,js+2,ks ) - $ + f6*f6*f4 * src(is+2,js+2,ks ) - $ + f7*f6*f4 * src(is+3,js+2,ks ) - $ + f8*f6*f4 * src(is+4,js+2,ks ) - $ + f1*f7*f4 * src(is-3,js+3,ks ) - $ + f2*f7*f4 * src(is-2,js+3,ks ) - $ + f3*f7*f4 * src(is-1,js+3,ks ) - $ + f4*f7*f4 * src(is ,js+3,ks ) - $ + f5*f7*f4 * src(is+1,js+3,ks ) - $ + f6*f7*f4 * src(is+2,js+3,ks ) - $ + f7*f7*f4 * src(is+3,js+3,ks ) - $ + f8*f7*f4 * src(is+4,js+3,ks ) - $ + f1*f8*f4 * src(is-3,js+4,ks ) - $ + f2*f8*f4 * src(is-2,js+4,ks ) - $ + f3*f8*f4 * src(is-1,js+4,ks ) - $ + f4*f8*f4 * src(is ,js+4,ks ) - $ + f5*f8*f4 * src(is+1,js+4,ks ) - $ + f6*f8*f4 * src(is+2,js+4,ks ) - $ + f7*f8*f4 * src(is+3,js+4,ks ) - $ + f8*f8*f4 * src(is+4,js+4,ks ) - res5 = - $ + f1*f1*f5 * src(is-3,js-3,ks+1) - $ + f2*f1*f5 * src(is-2,js-3,ks+1) - $ + f3*f1*f5 * src(is-1,js-3,ks+1) - $ + f4*f1*f5 * src(is ,js-3,ks+1) - $ + f5*f1*f5 * src(is+1,js-3,ks+1) - $ + f6*f1*f5 * src(is+2,js-3,ks+1) - $ + f7*f1*f5 * src(is+3,js-3,ks+1) - $ + f8*f1*f5 * src(is+4,js-3,ks+1) - $ + f1*f2*f5 * src(is-3,js-2,ks+1) - $ + f2*f2*f5 * src(is-2,js-2,ks+1) - $ + f3*f2*f5 * src(is-1,js-2,ks+1) - $ + f4*f2*f5 * src(is ,js-2,ks+1) - $ + f5*f2*f5 * src(is+1,js-2,ks+1) - $ + f6*f2*f5 * src(is+2,js-2,ks+1) - $ + f7*f2*f5 * src(is+3,js-2,ks+1) - $ + f8*f2*f5 * src(is+4,js-2,ks+1) - $ + f1*f3*f5 * src(is-3,js-1,ks+1) - $ + f2*f3*f5 * src(is-2,js-1,ks+1) - $ + f3*f3*f5 * src(is-1,js-1,ks+1) - $ + f4*f3*f5 * src(is ,js-1,ks+1) - $ + f5*f3*f5 * src(is+1,js-1,ks+1) - $ + f6*f3*f5 * src(is+2,js-1,ks+1) - $ + f7*f3*f5 * src(is+3,js-1,ks+1) - $ + f8*f3*f5 * src(is+4,js-1,ks+1) - $ + f1*f4*f5 * src(is-3,js ,ks+1) - $ + f2*f4*f5 * src(is-2,js ,ks+1) - $ + f3*f4*f5 * src(is-1,js ,ks+1) - $ + f4*f4*f5 * src(is ,js ,ks+1) - $ + f5*f4*f5 * src(is+1,js ,ks+1) - $ + f6*f4*f5 * src(is+2,js ,ks+1) - $ + f7*f4*f5 * src(is+3,js ,ks+1) - $ + f8*f4*f5 * src(is+4,js ,ks+1) - $ + f1*f5*f5 * src(is-3,js+1,ks+1) - $ + f2*f5*f5 * src(is-2,js+1,ks+1) - $ + f3*f5*f5 * src(is-1,js+1,ks+1) - $ + f4*f5*f5 * src(is ,js+1,ks+1) - $ + f5*f5*f5 * src(is+1,js+1,ks+1) - $ + f6*f5*f5 * src(is+2,js+1,ks+1) - $ + f7*f5*f5 * src(is+3,js+1,ks+1) - $ + f8*f5*f5 * src(is+4,js+1,ks+1) - $ + f1*f6*f5 * src(is-3,js+2,ks+1) - $ + f2*f6*f5 * src(is-2,js+2,ks+1) - $ + f3*f6*f5 * src(is-1,js+2,ks+1) - $ + f4*f6*f5 * src(is ,js+2,ks+1) - $ + f5*f6*f5 * src(is+1,js+2,ks+1) - $ + f6*f6*f5 * src(is+2,js+2,ks+1) - $ + f7*f6*f5 * src(is+3,js+2,ks+1) - $ + f8*f6*f5 * src(is+4,js+2,ks+1) - $ + f1*f7*f5 * src(is-3,js+3,ks+1) - $ + f2*f7*f5 * src(is-2,js+3,ks+1) - $ + f3*f7*f5 * src(is-1,js+3,ks+1) - $ + f4*f7*f5 * src(is ,js+3,ks+1) - $ + f5*f7*f5 * src(is+1,js+3,ks+1) - $ + f6*f7*f5 * src(is+2,js+3,ks+1) - $ + f7*f7*f5 * src(is+3,js+3,ks+1) - $ + f8*f7*f5 * src(is+4,js+3,ks+1) - $ + f1*f8*f5 * src(is-3,js+4,ks+1) - $ + f2*f8*f5 * src(is-2,js+4,ks+1) - $ + f3*f8*f5 * src(is-1,js+4,ks+1) - $ + f4*f8*f5 * src(is ,js+4,ks+1) - $ + f5*f8*f5 * src(is+1,js+4,ks+1) - $ + f6*f8*f5 * src(is+2,js+4,ks+1) - $ + f7*f8*f5 * src(is+3,js+4,ks+1) - $ + f8*f8*f5 * src(is+4,js+4,ks+1) - res6 = - $ + f1*f1*f6 * src(is-3,js-3,ks+2) - $ + f2*f1*f6 * src(is-2,js-3,ks+2) - $ + f3*f1*f6 * src(is-1,js-3,ks+2) - $ + f4*f1*f6 * src(is ,js-3,ks+2) - $ + f5*f1*f6 * src(is+1,js-3,ks+2) - $ + f6*f1*f6 * src(is+2,js-3,ks+2) - $ + f7*f1*f6 * src(is+3,js-3,ks+2) - $ + f8*f1*f6 * src(is+4,js-3,ks+2) - $ + f1*f2*f6 * src(is-3,js-2,ks+2) - $ + f2*f2*f6 * src(is-2,js-2,ks+2) - $ + f3*f2*f6 * src(is-1,js-2,ks+2) - $ + f4*f2*f6 * src(is ,js-2,ks+2) - $ + f5*f2*f6 * src(is+1,js-2,ks+2) - $ + f6*f2*f6 * src(is+2,js-2,ks+2) - $ + f7*f2*f6 * src(is+3,js-2,ks+2) - $ + f8*f2*f6 * src(is+4,js-2,ks+2) - $ + f1*f3*f6 * src(is-3,js-1,ks+2) - $ + f2*f3*f6 * src(is-2,js-1,ks+2) - $ + f3*f3*f6 * src(is-1,js-1,ks+2) - $ + f4*f3*f6 * src(is ,js-1,ks+2) - $ + f5*f3*f6 * src(is+1,js-1,ks+2) - $ + f6*f3*f6 * src(is+2,js-1,ks+2) - $ + f7*f3*f6 * src(is+3,js-1,ks+2) - $ + f8*f3*f6 * src(is+4,js-1,ks+2) - $ + f1*f4*f6 * src(is-3,js ,ks+2) - $ + f2*f4*f6 * src(is-2,js ,ks+2) - $ + f3*f4*f6 * src(is-1,js ,ks+2) - $ + f4*f4*f6 * src(is ,js ,ks+2) - $ + f5*f4*f6 * src(is+1,js ,ks+2) - $ + f6*f4*f6 * src(is+2,js ,ks+2) - $ + f7*f4*f6 * src(is+3,js ,ks+2) - $ + f8*f4*f6 * src(is+4,js ,ks+2) - $ + f1*f5*f6 * src(is-3,js+1,ks+2) - $ + f2*f5*f6 * src(is-2,js+1,ks+2) - $ + f3*f5*f6 * src(is-1,js+1,ks+2) - $ + f4*f5*f6 * src(is ,js+1,ks+2) - $ + f5*f5*f6 * src(is+1,js+1,ks+2) - $ + f6*f5*f6 * src(is+2,js+1,ks+2) - $ + f7*f5*f6 * src(is+3,js+1,ks+2) - $ + f8*f5*f6 * src(is+4,js+1,ks+2) - $ + f1*f6*f6 * src(is-3,js+2,ks+2) - $ + f2*f6*f6 * src(is-2,js+2,ks+2) - $ + f3*f6*f6 * src(is-1,js+2,ks+2) - $ + f4*f6*f6 * src(is ,js+2,ks+2) - $ + f5*f6*f6 * src(is+1,js+2,ks+2) - $ + f6*f6*f6 * src(is+2,js+2,ks+2) - $ + f7*f6*f6 * src(is+3,js+2,ks+2) - $ + f8*f6*f6 * src(is+4,js+2,ks+2) - $ + f1*f7*f6 * src(is-3,js+3,ks+2) - $ + f2*f7*f6 * src(is-2,js+3,ks+2) - $ + f3*f7*f6 * src(is-1,js+3,ks+2) - $ + f4*f7*f6 * src(is ,js+3,ks+2) - $ + f5*f7*f6 * src(is+1,js+3,ks+2) - $ + f6*f7*f6 * src(is+2,js+3,ks+2) - $ + f7*f7*f6 * src(is+3,js+3,ks+2) - $ + f8*f7*f6 * src(is+4,js+3,ks+2) - $ + f1*f8*f6 * src(is-3,js+4,ks+2) - $ + f2*f8*f6 * src(is-2,js+4,ks+2) - $ + f3*f8*f6 * src(is-1,js+4,ks+2) - $ + f4*f8*f6 * src(is ,js+4,ks+2) - $ + f5*f8*f6 * src(is+1,js+4,ks+2) - $ + f6*f8*f6 * src(is+2,js+4,ks+2) - $ + f7*f8*f6 * src(is+3,js+4,ks+2) - $ + f8*f8*f6 * src(is+4,js+4,ks+2) - res7 = - $ + f1*f1*f7 * src(is-3,js-3,ks+3) - $ + f2*f1*f7 * src(is-2,js-3,ks+3) - $ + f3*f1*f7 * src(is-1,js-3,ks+3) - $ + f4*f1*f7 * src(is ,js-3,ks+3) - $ + f5*f1*f7 * src(is+1,js-3,ks+3) - $ + f6*f1*f7 * src(is+2,js-3,ks+3) - $ + f7*f1*f7 * src(is+3,js-3,ks+3) - $ + f8*f1*f7 * src(is+4,js-3,ks+3) - $ + f1*f2*f7 * src(is-3,js-2,ks+3) - $ + f2*f2*f7 * src(is-2,js-2,ks+3) - $ + f3*f2*f7 * src(is-1,js-2,ks+3) - $ + f4*f2*f7 * src(is ,js-2,ks+3) - $ + f5*f2*f7 * src(is+1,js-2,ks+3) - $ + f6*f2*f7 * src(is+2,js-2,ks+3) - $ + f7*f2*f7 * src(is+3,js-2,ks+3) - $ + f8*f2*f7 * src(is+4,js-2,ks+3) - $ + f1*f3*f7 * src(is-3,js-1,ks+3) - $ + f2*f3*f7 * src(is-2,js-1,ks+3) - $ + f3*f3*f7 * src(is-1,js-1,ks+3) - $ + f4*f3*f7 * src(is ,js-1,ks+3) - $ + f5*f3*f7 * src(is+1,js-1,ks+3) - $ + f6*f3*f7 * src(is+2,js-1,ks+3) - $ + f7*f3*f7 * src(is+3,js-1,ks+3) - $ + f8*f3*f7 * src(is+4,js-1,ks+3) - $ + f1*f4*f7 * src(is-3,js ,ks+3) - $ + f2*f4*f7 * src(is-2,js ,ks+3) - $ + f3*f4*f7 * src(is-1,js ,ks+3) - $ + f4*f4*f7 * src(is ,js ,ks+3) - $ + f5*f4*f7 * src(is+1,js ,ks+3) - $ + f6*f4*f7 * src(is+2,js ,ks+3) - $ + f7*f4*f7 * src(is+3,js ,ks+3) - $ + f8*f4*f7 * src(is+4,js ,ks+3) - $ + f1*f5*f7 * src(is-3,js+1,ks+3) - $ + f2*f5*f7 * src(is-2,js+1,ks+3) - $ + f3*f5*f7 * src(is-1,js+1,ks+3) - $ + f4*f5*f7 * src(is ,js+1,ks+3) - $ + f5*f5*f7 * src(is+1,js+1,ks+3) - $ + f6*f5*f7 * src(is+2,js+1,ks+3) - $ + f7*f5*f7 * src(is+3,js+1,ks+3) - $ + f8*f5*f7 * src(is+4,js+1,ks+3) - $ + f1*f6*f7 * src(is-3,js+2,ks+3) - $ + f2*f6*f7 * src(is-2,js+2,ks+3) - $ + f3*f6*f7 * src(is-1,js+2,ks+3) - $ + f4*f6*f7 * src(is ,js+2,ks+3) - $ + f5*f6*f7 * src(is+1,js+2,ks+3) - $ + f6*f6*f7 * src(is+2,js+2,ks+3) - $ + f7*f6*f7 * src(is+3,js+2,ks+3) - $ + f8*f6*f7 * src(is+4,js+2,ks+3) - $ + f1*f7*f7 * src(is-3,js+3,ks+3) - $ + f2*f7*f7 * src(is-2,js+3,ks+3) - $ + f3*f7*f7 * src(is-1,js+3,ks+3) - $ + f4*f7*f7 * src(is ,js+3,ks+3) - $ + f5*f7*f7 * src(is+1,js+3,ks+3) - $ + f6*f7*f7 * src(is+2,js+3,ks+3) - $ + f7*f7*f7 * src(is+3,js+3,ks+3) - $ + f8*f7*f7 * src(is+4,js+3,ks+3) - $ + f1*f8*f7 * src(is-3,js+4,ks+3) - $ + f2*f8*f7 * src(is-2,js+4,ks+3) - $ + f3*f8*f7 * src(is-1,js+4,ks+3) - $ + f4*f8*f7 * src(is ,js+4,ks+3) - $ + f5*f8*f7 * src(is+1,js+4,ks+3) - $ + f6*f8*f7 * src(is+2,js+4,ks+3) - $ + f7*f8*f7 * src(is+3,js+4,ks+3) - $ + f8*f8*f7 * src(is+4,js+4,ks+3) - res8 = - $ + f1*f1*f8 * src(is-3,js-3,ks+4) - $ + f2*f1*f8 * src(is-2,js-3,ks+4) - $ + f3*f1*f8 * src(is-1,js-3,ks+4) - $ + f4*f1*f8 * src(is ,js-3,ks+4) - $ + f5*f1*f8 * src(is+1,js-3,ks+4) - $ + f6*f1*f8 * src(is+2,js-3,ks+4) - $ + f7*f1*f8 * src(is+3,js-3,ks+4) - $ + f8*f1*f8 * src(is+4,js-3,ks+4) - $ + f1*f2*f8 * src(is-3,js-2,ks+4) - $ + f2*f2*f8 * src(is-2,js-2,ks+4) - $ + f3*f2*f8 * src(is-1,js-2,ks+4) - $ + f4*f2*f8 * src(is ,js-2,ks+4) - $ + f5*f2*f8 * src(is+1,js-2,ks+4) - $ + f6*f2*f8 * src(is+2,js-2,ks+4) - $ + f7*f2*f8 * src(is+3,js-2,ks+4) - $ + f8*f2*f8 * src(is+4,js-2,ks+4) - $ + f1*f3*f8 * src(is-3,js-1,ks+4) - $ + f2*f3*f8 * src(is-2,js-1,ks+4) - $ + f3*f3*f8 * src(is-1,js-1,ks+4) - $ + f4*f3*f8 * src(is ,js-1,ks+4) - $ + f5*f3*f8 * src(is+1,js-1,ks+4) - $ + f6*f3*f8 * src(is+2,js-1,ks+4) - $ + f7*f3*f8 * src(is+3,js-1,ks+4) - $ + f8*f3*f8 * src(is+4,js-1,ks+4) - $ + f1*f4*f8 * src(is-3,js ,ks+4) - $ + f2*f4*f8 * src(is-2,js ,ks+4) - $ + f3*f4*f8 * src(is-1,js ,ks+4) - $ + f4*f4*f8 * src(is ,js ,ks+4) - $ + f5*f4*f8 * src(is+1,js ,ks+4) - $ + f6*f4*f8 * src(is+2,js ,ks+4) - $ + f7*f4*f8 * src(is+3,js ,ks+4) - $ + f8*f4*f8 * src(is+4,js ,ks+4) - $ + f1*f5*f8 * src(is-3,js+1,ks+4) - $ + f2*f5*f8 * src(is-2,js+1,ks+4) - $ + f3*f5*f8 * src(is-1,js+1,ks+4) - $ + f4*f5*f8 * src(is ,js+1,ks+4) - $ + f5*f5*f8 * src(is+1,js+1,ks+4) - $ + f6*f5*f8 * src(is+2,js+1,ks+4) - $ + f7*f5*f8 * src(is+3,js+1,ks+4) - $ + f8*f5*f8 * src(is+4,js+1,ks+4) - $ + f1*f6*f8 * src(is-3,js+2,ks+4) - $ + f2*f6*f8 * src(is-2,js+2,ks+4) - $ + f3*f6*f8 * src(is-1,js+2,ks+4) - $ + f4*f6*f8 * src(is ,js+2,ks+4) - $ + f5*f6*f8 * src(is+1,js+2,ks+4) - $ + f6*f6*f8 * src(is+2,js+2,ks+4) - $ + f7*f6*f8 * src(is+3,js+2,ks+4) - $ + f8*f6*f8 * src(is+4,js+2,ks+4) - $ + f1*f7*f8 * src(is-3,js+3,ks+4) - $ + f2*f7*f8 * src(is-2,js+3,ks+4) - $ + f3*f7*f8 * src(is-1,js+3,ks+4) - $ + f4*f7*f8 * src(is ,js+3,ks+4) - $ + f5*f7*f8 * src(is+1,js+3,ks+4) - $ + f6*f7*f8 * src(is+2,js+3,ks+4) - $ + f7*f7*f8 * src(is+3,js+3,ks+4) - $ + f8*f7*f8 * src(is+4,js+3,ks+4) - $ + f1*f8*f8 * src(is-3,js+4,ks+4) - $ + f2*f8*f8 * src(is-2,js+4,ks+4) - $ + f3*f8*f8 * src(is-1,js+4,ks+4) - $ + f4*f8*f8 * src(is ,js+4,ks+4) - $ + f5*f8*f8 * src(is+1,js+4,ks+4) - $ + f6*f8*f8 * src(is+2,js+4,ks+4) - $ + f7*f8*f8 * src(is+3,js+4,ks+4) - $ + f8*f8*f8 * src(is+4,js+4,ks+4) - dst(id,jd,kd) = res1 + res2 + res3 + res4 + res5 + res6 + res7 + res8 - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8110 - goto 911 - -c end i loop - 911 continue - j = j+1 - jd = jd+1 - js = js+1 - if (j.lt.regjext) goto 810 - goto 91 - -c end j loop - 91 continue - k = k+1 - kd = kd+1 - ks = ks+1 - if (k.lt.regkext) goto 80 - goto 9 - -c end k loop - 9 continue - - end diff --git a/Carpet/CarpetLib/src/prolongate_3d_real8_rf2.F77 b/Carpet/CarpetLib/src/prolongate_3d_real8_rf2.F77 deleted file mode 100644 index 524a2d31f..000000000 --- a/Carpet/CarpetLib/src/prolongate_3d_real8_rf2.F77 +++ /dev/null @@ -1,340 +0,0 @@ -c -*-Fortran-*- - -#include "cctk.h" -#include "cctk_Parameters.h" - - - - subroutine prolongate_3d_real8_rf2 ( - $ src, srciext, srcjext, srckext, - $ dst, dstiext, dstjext, dstkext, - $ srcbbox, dstbbox, regbbox) - - implicit none - - DECLARE_CCTK_PARAMETERS - - CCTK_REAL8 one, half, fourth, eighth - parameter (one = 1) - parameter (half = one/2) - parameter (fourth = one/4) - parameter (eighth = one/8) - - integer srciext, srcjext, srckext - CCTK_REAL8 src(srciext,srcjext,srckext) - integer dstiext, dstjext, dstkext - CCTK_REAL8 dst(dstiext,dstjext,dstkext) -c bbox(:,1) is lower boundary (inclusive) -c bbox(:,2) is upper boundary (inclusive) -c bbox(:,3) is stride - integer srcbbox(3,3), dstbbox(3,3), regbbox(3,3) - - integer regiext, regjext, regkext - - integer srcioff, srcjoff, srckoff - integer dstioff, dstjoff, dstkoff - - integer i0, j0, k0 - integer fi, fj, fk - integer is, js, ks - integer id, jd, kd - integer i, j, k - - integer d - - - - do d=1,3 - if (srcbbox(d,3).eq.0 .or. dstbbox(d,3).eq.0 - $ .or. regbbox(d,3).eq.0) then - call CCTK_WARN (0, "Internal error: stride is zero") - end if - if (srcbbox(d,3).le.regbbox(d,3) - $ .or. dstbbox(d,3).ne.regbbox(d,3)) then - call CCTK_WARN (0, "Internal error: strides disagree") - end if - if (srcbbox(d,3).ne.dstbbox(d,3)*2) then - call CCTK_WARN (0, "Internal error: source strides are not twice the destination strides") - end if - if (mod(srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array origins are not integer multiples of the strides") - end if - if (regbbox(d,1).gt.regbbox(d,2)) then -c This could be handled, but is likely to point to an error elsewhere - call CCTK_WARN (0, "Internal error: region extent is empty") - end if - if (mod(srcbbox(d,2) - srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,2) - dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,2) - regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array extents are not integer multiples of the strides") - end if - if (regbbox(d,1).lt.srcbbox(d,1) - $ .or. regbbox(d,1).lt.dstbbox(d,1) - $ .or. regbbox(d,2).gt.srcbbox(d,2) - $ .or. regbbox(d,2).gt.dstbbox(d,2)) then - call CCTK_WARN (0, "Internal error: region extent is not contained in array extent") - end if - end do - - if (srciext.ne.(srcbbox(1,2)-srcbbox(1,1))/srcbbox(1,3)+1 - $ .or. srcjext.ne.(srcbbox(2,2)-srcbbox(2,1))/srcbbox(2,3)+1 - $ .or. srckext.ne.(srcbbox(3,2)-srcbbox(3,1))/srcbbox(3,3)+1 - $ .or. dstiext.ne.(dstbbox(1,2)-dstbbox(1,1))/dstbbox(1,3)+1 - $ .or. dstjext.ne.(dstbbox(2,2)-dstbbox(2,1))/dstbbox(2,3)+1 - $ .or. dstkext.ne.(dstbbox(3,2)-dstbbox(3,1))/dstbbox(3,3)+1) then - call CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes") - end if - - - - regiext = (regbbox(1,2) - regbbox(1,1)) / regbbox(1,3) + 1 - regjext = (regbbox(2,2) - regbbox(2,1)) / regbbox(2,3) + 1 - regkext = (regbbox(3,2) - regbbox(3,1)) / regbbox(3,3) + 1 - - srcioff = (regbbox(1,1) - srcbbox(1,1)) / dstbbox(1,3) - srcjoff = (regbbox(2,1) - srcbbox(2,1)) / dstbbox(2,3) - srckoff = (regbbox(3,1) - srcbbox(3,1)) / dstbbox(3,3) - - dstioff = (regbbox(1,1) - dstbbox(1,1)) / dstbbox(1,3) - dstjoff = (regbbox(2,1) - dstbbox(2,1)) / dstbbox(2,3) - dstkoff = (regbbox(3,1) - dstbbox(3,1)) / dstbbox(3,3) - - - - fi = mod(srcioff, 2) - fj = mod(srcjoff, 2) - fk = mod(srckoff, 2) - - i0 = srcioff / 2 - j0 = srcjoff / 2 - k0 = srckoff / 2 - - - -c Loop over fine region -c Label scheme: 8 fk fj fi - -c begin k loop - 8 continue - k = 0 - ks = k0+1 - kd = dstkoff+1 - if (fk.eq.0) goto 80 - if (fk.eq.1) goto 81 - stop - -c begin j loop - 80 continue - j = 0 - js = j0+1 - jd = dstjoff+1 - if (fj.eq.0) goto 800 - if (fj.eq.1) goto 801 - stop - -c begin i loop - 800 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8000 - if (fi.eq.1) goto 8001 - stop - -c kernel - 8000 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js,ks, 1,1,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = src(is,js,ks) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8001 - goto 900 - -c kernel - 8001 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js,ks, 2,1,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = half * src(is,js,ks) + half * src(is+1,js,ks) - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8000 - goto 900 - -c end i loop - 900 continue - j = j+1 - jd = jd+1 - if (j.lt.regjext) goto 801 - goto 90 - -c begin i loop - 801 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8010 - if (fi.eq.1) goto 8011 - stop - -c kernel - 8010 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js,ks, 1,2,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = half * src(is,js,ks) + half * src(is,js+1,ks) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8011 - goto 901 - -c kernel - 8011 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js,ks, 2,2,1, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + fourth * src(is,js,ks) + fourth * src(is+1,js,ks) - $ + fourth * src(is,js+1,ks) + fourth * src(is+1,js+1,ks) - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8010 - goto 901 - -c end i loop - 901 continue - j = j+1 - jd = jd+1 - js = js+1 - if (j.lt.regjext) goto 800 - goto 90 - -c end j loop - 90 continue - k = k+1 - kd = kd+1 - if (k.lt.regkext) goto 81 - goto 9 - -c begin j loop - 81 continue - j = 0 - js = j0+1 - jd = dstjoff+1 - if (fj.eq.0) goto 810 - if (fj.eq.1) goto 811 - stop - -c begin i loop - 810 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8100 - if (fi.eq.1) goto 8101 - stop - -c kernel - 8100 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js,ks, 1,1,2, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = half * src(is,js,ks) + half * src(is,js,ks+1) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8101 - goto 910 - -c kernel - 8101 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js,ks, 2,1,2, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + fourth * src(is,js,ks) + fourth * src(is+1,js,ks) - $ + fourth * src(is,js,ks+1) + fourth * src(is+1,js,ks+1) - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8100 - goto 910 - -c end i loop - 910 continue - j = j+1 - jd = jd+1 - if (j.lt.regjext) goto 811 - goto 91 - -c begin i loop - 811 continue - i = 0 - is = i0+1 - id = dstioff+1 - if (fi.eq.0) goto 8110 - if (fi.eq.1) goto 8111 - stop - -c kernel - 8110 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js,ks, 1,2,2, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + fourth * src(is,js,ks) + fourth * src(is,js+1,ks) - $ + fourth * src(is,js,ks+1) + fourth * src(is,js+1,ks+1) - i = i+1 - id = id+1 - if (i.lt.regiext) goto 8111 - goto 911 - -c kernel - 8111 continue - if (check_array_accesses.ne.0) then - call checkindex (is,js,ks, 2,2,2, srciext,srcjext,srckext, "source") - call checkindex (id,jd,kd, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(id,jd,kd) = - $ + eighth * src(is,js,ks) + eighth * src(is+1,js,ks) - $ + eighth * src(is,js+1,ks) + eighth * src(is+1,js+1,ks) - $ + eighth * src(is,js,ks+1) + eighth * src(is+1,js,ks+1) - $ + eighth * src(is,js+1,ks+1) + eighth * src(is+1,js+1,ks+1) - i = i+1 - id = id+1 - is = is+1 - if (i.lt.regiext) goto 8110 - goto 911 - -c end i loop - 911 continue - j = j+1 - jd = jd+1 - js = js+1 - if (j.lt.regjext) goto 810 - goto 91 - -c end j loop - 91 continue - k = k+1 - kd = kd+1 - ks = ks+1 - if (k.lt.regkext) goto 80 - goto 9 - -c end k loop - 9 continue - - end diff --git a/Carpet/CarpetLib/src/prolongate_3d_real8_weno.F90 b/Carpet/CarpetLib/src/prolongate_3d_real8_weno.F90 index 1924f30c6..5c5d4cb87 100644 --- a/Carpet/CarpetLib/src/prolongate_3d_real8_weno.F90 +++ b/Carpet/CarpetLib/src/prolongate_3d_real8_weno.F90 @@ -27,15 +27,6 @@ !!$ prolongate_3d_real8_weno.F77 -#define CHKIDX(i,j,k, imax,jmax,kmax, where) \ -if ((i).lt.1 .or. (i).gt.(imax) \ - .or. (j).lt.1 .or. (j).gt.(jmax) \ - .or. (k).lt.1 .or. (k).gt.(kmax)) then &&\ - write (msg, '(a, " array index out of bounds: shape is (",i4,",",i4,",",i4,"), index is (",i4,",",i4,",",i4,")")') \ - (where), (imax), (jmax), (kmax), (i), (j), (k) &&\ - call CCTK_WARN (0, msg(1:len_trim(msg))) &&\ -end if - function weno1d(q) implicit none diff --git a/Carpet/CarpetLib/src/restrict_3d_cc_rf2.cc b/Carpet/CarpetLib/src/restrict_3d_cc_rf2.cc new file mode 100644 index 000000000..9c0fbccb0 --- /dev/null +++ b/Carpet/CarpetLib/src/restrict_3d_cc_rf2.cc @@ -0,0 +1,191 @@ +#include <algorithm> +#include <cassert> +#include <cmath> + +#include <cctk.h> +#include <cctk_Parameters.h> + +#include "operator_prototypes.hh" +#include "typeprops.hh" + +using namespace std; + + + +namespace CarpetLib { + + + +#define SRCIND3(i,j,k) \ + index3 (srcioff + (i), srcjoff + (j), srckoff + (k), \ + srciext, srcjext, srckext) +#define DSTIND3(i,j,k) \ + index3 (dstioff + (i), dstjoff + (j), dstkoff + (k), \ + dstiext, dstjext, dstkext) + + + + template <typename T> + void + restrict_3d_cc_rf2 (T const * restrict const src, + ivect3 const & srcext, + T * restrict const dst, + ivect3 const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox) + { + DECLARE_CCTK_PARAMETERS; + + typedef typename typeprops<T>::real RT; + + + +#if 0 + // This is already guaranteed by bbox + if (any (srcbbox.stride() == 0 or + dstbbox.stride() == 0 or + regbbox.stride() == 0)) + { + CCTK_WARN (0, "Internal error: stride is zero"); + } +#endif + + if (any (srcbbox.stride() >= regbbox.stride() or + dstbbox.stride() != regbbox.stride())) + { + CCTK_WARN (0, "Internal error: strides disagree"); + } + + if (any (reffact2 * srcbbox.stride() != dstbbox.stride())) { + CCTK_WARN (0, "Internal error: destination strides are not twice the source strides"); + } + +#if 0 + // This needs to be allowed for cell centring + if (any (srcbbox.lower() % srcbbox.stride() != 0 or + dstbbox.lower() % dstbbox.stride() != 0 or + regbbox.lower() % regbbox.stride() != 0)) + { + CCTK_WARN (0, "Internal error: array origins are not integer multiples of the strides"); + } +#endif + + // This could be handled, but is likely to point to an error + // elsewhere + if (regbbox.empty()) { + CCTK_WARN (0, "Internal error: region extent is empty"); + } + +#if 0 + // This is already guaranteed by bbox + if (any ((srcbbox.upper() - srcbbox.lower()) % srcbbox.stride() != 0 or + (dstbbox.upper() - dstbbox.lower()) % dstbbox.stride() != 0 or + (regbbox.upper() - regbbox.lower()) % regbbox.stride() != 0)) + { + CCTK_WARN (0, "Internal error: array extents are not integer multiples of the strides"); + } +#endif + + if (not regbbox.expanded_for(srcbbox).is_contained_in(srcbbox) or + not regbbox.is_contained_in(dstbbox)) + { + CCTK_WARN (0, "Internal error: region extent is not contained in array extent"); + } + + if (any (srcext != srcbbox.shape() / srcbbox.stride() or + dstext != dstbbox.shape() / dstbbox.stride())) + { + CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes"); + } + + + + ivect3 const regext = regbbox.shape() / regbbox.stride(); + assert (all (srcbbox.stride() % 2 == 0)); + assert (all ((regbbox.lower() - srcbbox.lower() - srcbbox.stride() / 2) % + srcbbox.stride() == 0)); + ivect3 const srcoff = + (regbbox.lower() - srcbbox.lower() - srcbbox.stride() / 2) / + srcbbox.stride(); + assert (all ((regbbox.lower() - dstbbox.lower()) % dstbbox.stride() == 0)); + ivect3 const dstoff = + (regbbox.lower() - dstbbox.lower()) / dstbbox.stride(); + + + + int const srciext = srcext[0]; + int const srcjext = srcext[1]; + int const srckext = srcext[2]; + + int const dstiext = dstext[0]; + int const dstjext = dstext[1]; + int const dstkext = dstext[2]; + + int const regiext = regext[0]; + int const regjext = regext[1]; + int const regkext = regext[2]; + + int const srcioff = srcoff[0]; + int const srcjoff = srcoff[1]; + int const srckoff = srcoff[2]; + + int const dstioff = dstoff[0]; + int const dstjoff = dstoff[1]; + int const dstkoff = dstoff[2]; + + + + RT const one = 1; + + RT const f1 = one/2; + RT const f2 = one/2; + + + + // Loop over coarse region + for (int k=0; k<regkext; ++k) { + for (int j=0; j<regjext; ++j) { + for (int i=0; i<regiext; ++i) { + + dst [DSTIND3(i, j, k)] = + + f1*f1*f1 * src [SRCIND3(2*i , 2*j , 2*k )] + + f2*f1*f1 * src [SRCIND3(2*i+1, 2*j , 2*k )] + + f1*f2*f1 * src [SRCIND3(2*i , 2*j+1, 2*k )] + + f2*f2*f1 * src [SRCIND3(2*i+1, 2*j+1, 2*k )] + + f1*f1*f2 * src [SRCIND3(2*i , 2*j , 2*k+1)] + + f2*f1*f2 * src [SRCIND3(2*i+1, 2*j , 2*k+1)] + + f1*f2*f2 * src [SRCIND3(2*i , 2*j+1, 2*k+1)] + + f2*f2*f2 * src [SRCIND3(2*i+1, 2*j+1, 2*k+1)]; + + } + } + } + + } + + + + template + void + restrict_3d_cc_rf2 (CCTK_REAL const * restrict const src, + ivect3 const & srcext, + CCTK_REAL * restrict const dst, + ivect3 const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox); + + template + void + restrict_3d_cc_rf2 (CCTK_COMPLEX const * restrict const src, + ivect3 const & srcext, + CCTK_COMPLEX * restrict const dst, + ivect3 const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox); + + + +} // namespace CarpetLib diff --git a/Carpet/CarpetLib/src/restrict_3d_real8.F77 b/Carpet/CarpetLib/src/restrict_3d_real8.F77 deleted file mode 100644 index 05ca2776d..000000000 --- a/Carpet/CarpetLib/src/restrict_3d_real8.F77 +++ /dev/null @@ -1,117 +0,0 @@ -c -*-Fortran-*- - -#include "cctk.h" -#include "cctk_Parameters.h" - - - - subroutine restrict_3d_real8 ( - $ src, srciext, srcjext, srckext, - $ dst, dstiext, dstjext, dstkext, - $ srcbbox, dstbbox, regbbox) - - implicit none - - DECLARE_CCTK_PARAMETERS - - integer srciext, srcjext, srckext - CCTK_REAL8 src(srciext,srcjext,srckext) - integer dstiext, dstjext, dstkext - CCTK_REAL8 dst(dstiext,dstjext,dstkext) -c bbox(:,1) is lower boundary (inclusive) -c bbox(:,2) is upper boundary (inclusive) -c bbox(:,3) is stride - integer srcbbox(3,3), dstbbox(3,3), regbbox(3,3) - - integer regiext, regjext, regkext - - integer srcifac, srcjfac, srckfac - - integer srcioff, srcjoff, srckoff - integer dstioff, dstjoff, dstkoff - - integer i, j, k - integer d - - - - do d=1,3 - if (srcbbox(d,3).eq.0 .or. dstbbox(d,3).eq.0 - $ .or. regbbox(d,3).eq.0) then - call CCTK_WARN (0, "Internal error: stride is zero") - end if - if (srcbbox(d,3).ge.regbbox(d,3) - $ .or. dstbbox(d,3).ne.regbbox(d,3)) then - call CCTK_WARN (0, "Internal error: strides disagree") - end if - if (mod(dstbbox(d,3), srcbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: source strides are not integer multiples of the destination strides") - end if - if (mod(srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array origins are not integer multiples of the strides") - end if - if (regbbox(d,1).gt.regbbox(d,2)) then -c This could be handled, but is likely to point to an error elsewhere - call CCTK_WARN (0, "Internal error: region extent is empty") - end if - if (mod(srcbbox(d,2) - srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,2) - dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,2) - regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array extents are not integer multiples of the strides") - end if - if (regbbox(d,1).lt.srcbbox(d,1) - $ .or. regbbox(d,1).lt.dstbbox(d,1) - $ .or. regbbox(d,2).gt.srcbbox(d,2) - $ .or. regbbox(d,2).gt.dstbbox(d,2)) then - call CCTK_WARN (0, "Internal error: region extent is not contained in array extent") - end if - end do - - if (srciext.ne.(srcbbox(1,2)-srcbbox(1,1))/srcbbox(1,3)+1 - $ .or. srcjext.ne.(srcbbox(2,2)-srcbbox(2,1))/srcbbox(2,3)+1 - $ .or. srckext.ne.(srcbbox(3,2)-srcbbox(3,1))/srcbbox(3,3)+1 - $ .or. dstiext.ne.(dstbbox(1,2)-dstbbox(1,1))/dstbbox(1,3)+1 - $ .or. dstjext.ne.(dstbbox(2,2)-dstbbox(2,1))/dstbbox(2,3)+1 - $ .or. dstkext.ne.(dstbbox(3,2)-dstbbox(3,1))/dstbbox(3,3)+1) then - call CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes") - end if - - - - regiext = (regbbox(1,2) - regbbox(1,1)) / regbbox(1,3) + 1 - regjext = (regbbox(2,2) - regbbox(2,1)) / regbbox(2,3) + 1 - regkext = (regbbox(3,2) - regbbox(3,1)) / regbbox(3,3) + 1 - - srcifac = dstbbox(1,3) / srcbbox(1,3) - srcjfac = dstbbox(2,3) / srcbbox(2,3) - srckfac = dstbbox(3,3) / srcbbox(3,3) - - srcioff = (regbbox(1,1) - srcbbox(1,1)) / srcbbox(1,3) - srcjoff = (regbbox(2,1) - srcbbox(2,1)) / srcbbox(2,3) - srckoff = (regbbox(3,1) - srcbbox(3,1)) / srcbbox(3,3) - - dstioff = (regbbox(1,1) - dstbbox(1,1)) / dstbbox(1,3) - dstjoff = (regbbox(2,1) - dstbbox(2,1)) / dstbbox(2,3) - dstkoff = (regbbox(3,1) - dstbbox(3,1)) / dstbbox(3,3) - - - -c Loop over coarse region - do k = 0, regkext-1 - do j = 0, regjext-1 - do i = 0, regiext-1 - - if (check_array_accesses.ne.0) then - call checkindex (srcioff+srcifac*i+1, srcjoff+srcjfac*j+1, srckoff+srckfac*k+1, 1,1,1, srciext,srcjext,srckext, "source") - call checkindex (dstioff+i+1, dstjoff+j+1, dstkoff+k+1, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst (dstioff+i+1, dstjoff+j+1, dstkoff+k+1) - $ = src (srcioff+srcifac*i+1, srcjoff+srcjfac*j+1, srckoff+srckfac*k+1) - - end do - end do - end do - - end diff --git a/Carpet/CarpetLib/src/restrict_3d_real8_rf2.F77 b/Carpet/CarpetLib/src/restrict_3d_real8_rf2.F77 deleted file mode 100644 index 1e4f04021..000000000 --- a/Carpet/CarpetLib/src/restrict_3d_real8_rf2.F77 +++ /dev/null @@ -1,110 +0,0 @@ -c -*-Fortran-*- - -#include "cctk.h" -#include "cctk_Parameters.h" - - - - subroutine restrict_3d_real8_rf2 ( - $ src, srciext, srcjext, srckext, - $ dst, dstiext, dstjext, dstkext, - $ srcbbox, dstbbox, regbbox) - - implicit none - - DECLARE_CCTK_PARAMETERS - - integer srciext, srcjext, srckext - CCTK_REAL8 src(srciext,srcjext,srckext) - integer dstiext, dstjext, dstkext - CCTK_REAL8 dst(dstiext,dstjext,dstkext) -c bbox(:,1) is lower boundary (inclusive) -c bbox(:,2) is upper boundary (inclusive) -c bbox(:,3) is stride - integer srcbbox(3,3), dstbbox(3,3), regbbox(3,3) - - integer regiext, regjext, regkext - integer srcioff, srcjoff, srckoff - integer dstioff, dstjoff, dstkoff - - integer i, j, k - integer d - - - - do d=1,3 - if (srcbbox(d,3).eq.0 .or. dstbbox(d,3).eq.0 - $ .or. regbbox(d,3).eq.0) then - call CCTK_WARN (0, "Internal error: stride is zero") - end if - if (srcbbox(d,3).ge.regbbox(d,3) - $ .or. dstbbox(d,3).ne.regbbox(d,3)) then - call CCTK_WARN (0, "Internal error: strides disagree") - end if - if (dstbbox(d,3).ne.srcbbox(d,3)*2) then - call CCTK_WARN (0, "Internal error: destination strides are not twice the source strides") - end if - if (mod(srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array origins are not integer multiples of the strides") - end if - if (regbbox(d,1).gt.regbbox(d,2)) then -c This could be handled, but is likely to point to an error elsewhere - call CCTK_WARN (0, "Internal error: region extent is empty") - end if - if (mod(srcbbox(d,2) - srcbbox(d,1), srcbbox(d,3)).ne.0 - $ .or. mod(dstbbox(d,2) - dstbbox(d,1), dstbbox(d,3)).ne.0 - $ .or. mod(regbbox(d,2) - regbbox(d,1), regbbox(d,3)).ne.0) then - call CCTK_WARN (0, "Internal error: array extents are not integer multiples of the strides") - end if - if (regbbox(d,1).lt.srcbbox(d,1) - $ .or. regbbox(d,1).lt.dstbbox(d,1) - $ .or. regbbox(d,2).gt.srcbbox(d,2) - $ .or. regbbox(d,2).gt.dstbbox(d,2)) then - call CCTK_WARN (0, "Internal error: region extent is not contained in array extent") - end if - end do - - if (srciext.ne.(srcbbox(1,2)-srcbbox(1,1))/srcbbox(1,3)+1 - $ .or. srcjext.ne.(srcbbox(2,2)-srcbbox(2,1))/srcbbox(2,3)+1 - $ .or. srckext.ne.(srcbbox(3,2)-srcbbox(3,1))/srcbbox(3,3)+1 - $ .or. dstiext.ne.(dstbbox(1,2)-dstbbox(1,1))/dstbbox(1,3)+1 - $ .or. dstjext.ne.(dstbbox(2,2)-dstbbox(2,1))/dstbbox(2,3)+1 - $ .or. dstkext.ne.(dstbbox(3,2)-dstbbox(3,1))/dstbbox(3,3)+1) then - call CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes") - end if - - - - regiext = (regbbox(1,2) - regbbox(1,1)) / regbbox(1,3) + 1 - regjext = (regbbox(2,2) - regbbox(2,1)) / regbbox(2,3) + 1 - regkext = (regbbox(3,2) - regbbox(3,1)) / regbbox(3,3) + 1 - - srcioff = (regbbox(1,1) - srcbbox(1,1)) / srcbbox(1,3) - srcjoff = (regbbox(2,1) - srcbbox(2,1)) / srcbbox(2,3) - srckoff = (regbbox(3,1) - srcbbox(3,1)) / srcbbox(3,3) - - dstioff = (regbbox(1,1) - dstbbox(1,1)) / dstbbox(1,3) - dstjoff = (regbbox(2,1) - dstbbox(2,1)) / dstbbox(2,3) - dstkoff = (regbbox(3,1) - dstbbox(3,1)) / dstbbox(3,3) - - - -c Loop over coarse region - do k = 0, regkext-1 - do j = 0, regjext-1 - do i = 0, regiext-1 - - if (check_array_accesses.ne.0) then - call checkindex (srcioff+2*i+1, srcjoff+2*j+1, srckoff+2*k+1, 1,1,1, srciext,srcjext,srckext, "source") - call checkindex (dstioff+i+1, dstjoff+j+1, dstkoff+k+1, 1,1,1, dstiext,dstjext,dstkext, "destination") - end if - dst(dstioff+i+1, dstjoff+j+1, dstkoff+k+1) = - $ src(srcioff+2*i+1, srcjoff+2*j+1, srckoff+2*k+1) - - end do - end do - end do - - end diff --git a/Carpet/CarpetLib/src/restrict_3d_rf2.cc b/Carpet/CarpetLib/src/restrict_3d_rf2.cc new file mode 100644 index 000000000..efda2a13a --- /dev/null +++ b/Carpet/CarpetLib/src/restrict_3d_rf2.cc @@ -0,0 +1,176 @@ +#include <algorithm> +#include <cassert> +#include <cmath> +#include <cstdlib> + +#include <cctk.h> +#include <cctk_Parameters.h> + +#include "operator_prototypes.hh" +#include "typeprops.hh" + +using namespace std; + + + +namespace CarpetLib { + + + +#define SRCIND3(i,j,k) \ + index3 (srcioff + (i), srcjoff + (j), srckoff + (k), \ + srciext, srcjext, srckext) +#define DSTIND3(i,j,k) \ + index3 (dstioff + (i), dstjoff + (j), dstkoff + (k), \ + dstiext, dstjext, dstkext) + + + + template <typename T> + void + restrict_3d_rf2 (T const * restrict const src, + ivect3 const & srcext, + T * restrict const dst, + ivect3 const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox) + { +#if 0 + // This is already guaranteed by bbox + if (any (srcbbox.stride() == 0 or + dstbbox.stride() == 0 or + regbbox.stride() == 0)) + { + CCTK_WARN (0, "Internal error: stride is zero"); + } +#endif + + if (any (srcbbox.stride() >= regbbox.stride() or + dstbbox.stride() != regbbox.stride())) + { + CCTK_WARN (0, "Internal error: strides disagree"); + } + + if (any (reffact2 * srcbbox.stride() != dstbbox.stride())) { + CCTK_WARN (0, "Internal error: destination strides are not twice the source strides"); + } + +#if 0 + // This needs to be allowed for cell centring + if (any (srcbbox.lower() % srcbbox.stride() != 0 or + dstbbox.lower() % dstbbox.stride() != 0 or + regbbox.lower() % regbbox.stride() != 0)) + { + CCTK_WARN (0, "Internal error: array origins are not integer multiples of the strides"); + } +#endif + + // This could be handled, but is likely to point to an error + // elsewhere + if (regbbox.empty()) { + CCTK_WARN (0, "Internal error: region extent is empty"); + } + +#if 0 + // This is already guaranteed by bbox + if (any ((srcbbox.upper() - srcbbox.lower()) % srcbbox.stride() != 0 or + (dstbbox.upper() - dstbbox.lower()) % dstbbox.stride() != 0 or + (regbbox.upper() - regbbox.lower()) % regbbox.stride() != 0)) + { + CCTK_WARN (0, "Internal error: array extents are not integer multiples of the strides"); + } +#endif + + if (not regbbox.is_contained_in(srcbbox) or + not regbbox.is_contained_in(dstbbox)) + { + CCTK_WARN (0, "Internal error: region extent is not contained in array extent"); + } + + if (any (srcext != srcbbox.shape() / srcbbox.stride() or + dstext != dstbbox.shape() / dstbbox.stride())) + { + CCTK_WARN (0, "Internal error: array sizes don't agree with bounding boxes"); + } + + + + ivect3 const regext = regbbox.shape() / regbbox.stride(); + assert (all ((regbbox.lower() - srcbbox.lower()) % srcbbox.stride() == 0)); + ivect3 const srcoff = (regbbox.lower() - srcbbox.lower()) / srcbbox.stride(); + assert (all ((regbbox.lower() - dstbbox.lower()) % dstbbox.stride() == 0)); + ivect3 const dstoff = (regbbox.lower() - dstbbox.lower()) / dstbbox.stride(); + + + + size_t const srciext = srcext[0]; + size_t const srcjext = srcext[1]; + size_t const srckext = srcext[2]; + + size_t const dstiext = dstext[0]; + size_t const dstjext = dstext[1]; + size_t const dstkext = dstext[2]; + + size_t const regiext = regext[0]; + size_t const regjext = regext[1]; + size_t const regkext = regext[2]; + + size_t const srcioff = srcoff[0]; + size_t const srcjoff = srcoff[1]; + size_t const srckoff = srcoff[2]; + + size_t const dstioff = dstoff[0]; + size_t const dstjoff = dstoff[1]; + size_t const dstkoff = dstoff[2]; + + + + // Loop over coarse region + for (size_t k=0; k<regkext; ++k) { + for (size_t j=0; j<regjext; ++j) { + for (size_t i=0; i<regiext; ++i) { + + dst [DSTIND3(i, j, k)] = src [SRCIND3(2*i, 2*j, 2*k)]; + + } + } + } + + } + + + + template + void + restrict_3d_rf2 (CCTK_INT const * restrict const src, + ivect3 const & srcext, + CCTK_INT * restrict const dst, + ivect3 const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox); + + template + void + restrict_3d_rf2 (CCTK_REAL const * restrict const src, + ivect3 const & srcext, + CCTK_REAL * restrict const dst, + ivect3 const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox); + + template + void + restrict_3d_rf2 (CCTK_COMPLEX const * restrict const src, + ivect3 const & srcext, + CCTK_COMPLEX * restrict const dst, + ivect3 const & dstext, + ibbox3 const & srcbbox, + ibbox3 const & dstbbox, + ibbox3 const & regbbox); + + + +} // namespace CarpetLib diff --git a/Carpet/CarpetLib/src/timestat.cc b/Carpet/CarpetLib/src/timestat.cc index 893c5664d..addd1540d 100644 --- a/Carpet/CarpetLib/src/timestat.cc +++ b/Carpet/CarpetLib/src/timestat.cc @@ -143,18 +143,9 @@ timestat wtime_commstate_interpolate_to_isend; timestat wtime_restrict; timestat wtime_prolongate; timestat wtime_prolongate_copy; -timestat wtime_prolongate_Lagrange_0; -timestat wtime_prolongate_Lagrange_1; -timestat wtime_prolongate_Lagrange_2; -timestat wtime_prolongate_TVD_0; -timestat wtime_prolongate_TVD_1; -timestat wtime_prolongate_TVD_2; -timestat wtime_prolongate_ENO_0; -timestat wtime_prolongate_ENO_1; -timestat wtime_prolongate_ENO_2; -timestat wtime_prolongate_WENO_0; -timestat wtime_prolongate_WENO_1; -timestat wtime_prolongate_WENO_2; +timestat wtime_prolongate_Lagrange; +timestat wtime_prolongate_ENO; +timestat wtime_prolongate_WENO; @@ -255,19 +246,9 @@ void CarpetLib_printtimestats (CCTK_ARGUMENTS) << endl << " wtime_restrict: " << wtime_restrict << endl << " wtime_prolongate: " << wtime_prolongate << endl - << " wtime_prolongate_copy: " << wtime_prolongate_copy << endl - << " wtime_prolongate_Lagrange_0: " << wtime_prolongate_Lagrange_0 << endl - << " wtime_prolongate_Lagrange_1: " << wtime_prolongate_Lagrange_1 << endl - << " wtime_prolongate_Lagrange_2: " << wtime_prolongate_Lagrange_2 << endl - << " wtime_prolongate_TVD_0: " << wtime_prolongate_TVD_0 << endl - << " wtime_prolongate_TVD_1: " << wtime_prolongate_TVD_1 << endl - << " wtime_prolongate_TVD_2: " << wtime_prolongate_TVD_2 << endl - << " wtime_prolongate_ENO_0: " << wtime_prolongate_ENO_0 << endl - << " wtime_prolongate_ENO_1: " << wtime_prolongate_ENO_1 << endl - << " wtime_prolongate_ENO_2: " << wtime_prolongate_ENO_2 << endl - << " wtime_prolongate_WENO_0: " << wtime_prolongate_WENO_0 << endl - << " wtime_prolongate_WENO_1: " << wtime_prolongate_WENO_1 << endl - << " wtime_prolongate_WENO_2: " << wtime_prolongate_WENO_2 << endl + << " wtime_prolongate_Lagrange: " << wtime_prolongate_Lagrange << endl + << " wtime_prolongate_ENO: " << wtime_prolongate_ENO << endl + << " wtime_prolongate_WENO: " << wtime_prolongate_WENO << endl << endl; } } diff --git a/Carpet/CarpetLib/src/timestat.hh b/Carpet/CarpetLib/src/timestat.hh index a262c4dbf..811369306 100644 --- a/Carpet/CarpetLib/src/timestat.hh +++ b/Carpet/CarpetLib/src/timestat.hh @@ -92,18 +92,8 @@ extern timestat wtime_commstate_interpolate_to_isend; extern timestat wtime_restrict; extern timestat wtime_prolongate; -extern timestat wtime_prolongate_copy; -extern timestat wtime_prolongate_Lagrange_0; -extern timestat wtime_prolongate_Lagrange_1; -extern timestat wtime_prolongate_Lagrange_2; -extern timestat wtime_prolongate_TVD_0; -extern timestat wtime_prolongate_TVD_1; -extern timestat wtime_prolongate_TVD_2; -extern timestat wtime_prolongate_ENO_0; -extern timestat wtime_prolongate_ENO_1; -extern timestat wtime_prolongate_ENO_2; -extern timestat wtime_prolongate_WENO_0; -extern timestat wtime_prolongate_WENO_1; -extern timestat wtime_prolongate_WENO_2; +extern timestat wtime_prolongate_Lagrange; +extern timestat wtime_prolongate_ENO; +extern timestat wtime_prolongate_WENO; #endif // TIMESTAT_HH diff --git a/Carpet/CarpetLib/src/typeprops.hh b/Carpet/CarpetLib/src/typeprops.hh new file mode 100644 index 000000000..e8a1ec342 --- /dev/null +++ b/Carpet/CarpetLib/src/typeprops.hh @@ -0,0 +1,44 @@ +#ifndef TYPEPROPS_HH +#define TYPEPROPS_HH + +#include <cctk.h> + + + +template <typename T> +struct typeprops { + typedef T complex; + typedef T real; + static inline complex fromreal (real const x) { return x; } +}; + +#ifdef HAVE_CCTK_COMPLEX8 +template <> +struct typeprops <CCTK_COMPLEX8> { + typedef CCTK_COMPLEX8 complex; + typedef CCTK_REAL4 real; + static inline complex fromreal (real const x) { return CCTK_Cmplx8 (x, 0); } +}; +#endif + +#ifdef HAVE_CCTK_COMPLEX16 +template <> +struct typeprops <CCTK_COMPLEX16> { + typedef CCTK_COMPLEX16 complex; + typedef CCTK_REAL8 real; + static inline complex fromreal (real const x) { return CCTK_Cmplx16 (x, 0); } +}; +#endif + +#ifdef HAVE_CCTK_COMPLEX32 +template <> +struct typeprops <CCTK_COMPLEX32> { + typedef CCTK_COMPLEX32 complex; + typedef CCTK_REAL16 real; + static inline complex fromreal (real const x) { return CCTK_Cmplx32 (x, 0); } +}; +#endif + + + +#endif // #ifndef TYPEPROPS_HH |