diff options
Diffstat (limited to 'Carpet')
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 |