C ALGORITHM 824, COLLECTED ALGORITHMS FROM ACM.
C THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE,
C VOL. 29,NO. 3, September, 2003, P. 287--296.
#! /bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #! /bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
# Doc/
# Doc/framework_abstract
# Doc/index.html
# Doc/simplex_abstract
# Fortran90/
# Fortran90/Drivers/
# Fortran90/Drivers/Makefile
# Fortran90/Drivers/details.f90
# Fortran90/Drivers/details.out
# Fortran90/Drivers/ex_cutet.f90
# Fortran90/Drivers/ex_cutet.out
# Fortran90/Drivers/ex_decuhr2d.f90
# Fortran90/Drivers/ex_decuhr2d.out
# Fortran90/Drivers/ex_decuhr3d.f90
# Fortran90/Drivers/ex_decuhr3d.out
# Fortran90/Drivers/ex_qag.f90
# Fortran90/Drivers/ex_qag.out
# Fortran90/Drivers/ex_qags.f90
# Fortran90/Drivers/ex_qags.out
# Fortran90/Drivers/ex_triex.f90
# Fortran90/Drivers/ex_triex.out
# Fortran90/Drivers/simplexpapertest.f90
# Fortran90/Drivers/simplexpapertest.out
# Fortran90/Src/
# Fortran90/Src/Makefile
# Fortran90/Src/buckley.f90
# Fortran90/Src/check.f90
# Fortran90/Src/cui.f90
# Fortran90/Src/divide.f90
# Fortran90/Src/ds_routines.f90
# Fortran90/Src/error_handling.f90
# Fortran90/Src/global_all.f90
# Fortran90/Src/internal_types.f90
# Fortran90/Src/region_processor.f90
# Fortran90/Src/rule_1.f90
# Fortran90/Src/rule_c2.f90
# Fortran90/Src/rule_c3.f90
# Fortran90/Src/rule_cn.f90
# Fortran90/Src/rule_general.f90
# Fortran90/Src/rule_t2.f90
# Fortran90/Src/rule_t3.f90
# Fortran90/Src/rule_tn.f90
# Fortran90/Src/volume.f90
# This archive created: Fri Oct 24 17:54:24 2003
export PATH; PATH=/bin:$PATH
if test ! -d 'Doc'
then
mkdir 'Doc'
fi
cd 'Doc'
if test -f 'framework_abstract'
then
echo shar: will not over-write existing file "'framework_abstract'"
else
cat << "SHAR_EOF" > 'framework_abstract'
Algorithm 8xx:
CUBPACK: a package for automatic cubature; framework description
Ronald Cools and Ann Haegemans
Abstract:
CUBPACK aims to offer a collection of re-usable code for automatic
n-dimensional (n >= 1) numerical integration of functions over a
collection of regions, i.e., quadrature and cubature. The current
version allows this region to consist of a union of n-simplices and
n-parellellepids. The framework of CUBPACK is described as well as
its user interface. The functionality of several well known routines
is embedded. New features include integration algorithms using the
epsilon-algorithm for extrapolation for regions other than triangles
and the implementation of a new type of subdivision for 3-cubes.
SHAR_EOF
fi # end of overwriting check
if test -f 'index.html'
then
echo shar: will not over-write existing file "'index.html'"
else
cat << "SHAR_EOF" > 'index.html'
CUBPACK documentation page
CUBPACK documentation page
Structure of the files
You will see 3 directories:
- CUBPACK: This contains the source code
- Examples: Some example programs
- Doc: The directory where you found this file
Installation (Unix/Linux)
- Place yourself in the subdirectory CUBPACK and open the
file Makefile
in an editor.
- Assign the name of your Fortran (at least 90) compiler
to the variable FC.
- Assign your favorite compiler options
to the variable CFLAGS.
- Assign the suffix of modules
to the variable MSUFF.
(This is not very important.)
- Execute the command
'make'.
You should not get any error messages...
- Remove redundant files by executing
'make clean'.
Using CUBPACK - try some of the examples first
- Place yourself in the subdirectory Examples and open
the file Makefile in an editor.
- Make the same changes you made to the previous Makefile.
Pay special attention to the variable CFLAGS.
It is here also used to tell the compiler where to look
for CUBPACK modules.
The file you received uses
'-I../CUBPACK'
for this. This works for NAGWare f95.
For SUN's f95 use
'-M../CUBPACK'.
Consult the manual page of your compiler otherwise.
- You will see some example programs mentioned in this Makefile.
Select one and assign its name (no suffixes!) to the
variable MAIN.
- Execute the command
'make'.
You should not get any error messages...
- You will now have an executable with a name equal to what
you selected. Enjoy.
- You can clean up all created files using
'make clean'.
First you might want to know more about the version you installed.
The package contains a subroutine which you can call by
CALL CUBPACK_INFO()
that prints such details. A
sample program and its
output
(obtained on
the platform that produced all sample output) are included.
Here follows a brief description of the examples included.
- 1-dimensional examples
Observe that this uses the reduced calling sequence for scalar
functions and single regions.
- ex_qag:
Simulates QAG from QUADPACK and uses the same test examples.
Look here for the output.
- ex_qags
Simulates QAGS from QUADPACK and uses the same test examples.
Look here for the output.
- 2-dimensional examples
- ex_triex:
Uses the test examples presented in the ACM TOMS paper
describing TRIEX. It uses the same strategy as TRIEX but a
different integration rule and error estimator.
Look here for the output.
- ex_decuhr2d:
Uses a test example presented in the Numerical Algorithms paper
describing DECUHR for the square. It demonstrates the restart
feature with the default integration routine.
Look here for the output.
- 3-dimensional example
- ex_cutet:
Uses one of the test programs included in the distribtion of DCUTET.
It forces the routine to subdivide a tetrahedron in 8 congruent
subregions.
Look here for the output.
- ex_decuhr3d:
Uses the two test examples presented in the Numerical Algorithms paper
describing DECUHR for the 3-dimensional cube.
It demonstrates the use of different integration strategies
(global adaptive with subdivision in 2 (JOB=12) and with a dynamic
subdivision in 2,4 or 8 (JOB=1). This exploits the RESTART feature.
It also uses the extrapolation strategy previously only available
for finite intervals (QAGS) and triangles (TRIEX).
In addition it demonstrates the use of the default (KEY=0) and other
available integration rules. (Clearly showing that the default is
the best available.)
Look here for the output.
- 5-dimensional examples
- simplexpapertest:
This is the test program given in the appendix of the paper
describing a new subdivision strategy for simplices, as part
of CUBPACK.
Look here for the output.
Using CUBPACK - do it yourself
Only one subroutine name is available to the users:
CUBATR.
The most general interface is presented first.
Another interface is provided for those who need to compute an integral
of a scalar function over a single basic region.
A third way to call CUBATR is provided to clear all memory saved by
the previous call.
Index
Full calling sequence
CALL CUBATR &
(DIMENS,NumFun,Integrand,NumRgn,Vertices,RgType,Value,AbsErr, &
! and optional parameters
IFAIL,Neval,EpsAbs,EpsRel,Restart,MinPts,MaxPts,Key,Job,Tune)
!-----------------------------------------------------------------------
! Input parameters
! ----------------
!
! DIMENS Integer.
! The dimension of the region of integration.
!
! NumFun Integer.
! Number of components of the integrand.
!
! Integrand
! Externally declared function for computing all components
! of the integrand at the given evaluation point.
! It must have input parameter X:
! X(1) The x-coordinate of the evaluation point.
! X(2) The y-coordinate of the evaluation point.
! ...
! X(DIMENS) The z-coordinate of the evaluation point.
! and NumFun, the number of components of the integrand.
! It must be compatible with the following interface:
! INTERFACE
! FUNCTION Integrand(NUMFUN,X) RESULT(Value)
! USE Precision_Model
! INTEGER, INTENT(IN) :: NUMFUN
! REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: X
! REAL(kind=stnd), DIMENSION(NUMFUN) :: Value
! END FUNCTION Integrand
! END INTERFACE
!
! NumRgn Integer.
! The number of given regions.
!
! Vertices
! Real array of dimension (DIMENS,DIMENS+1,NumRgn).
! Vertices(1:DIMENS,K,L) are the x, y, ... coordinates
! respectively of vertex K of region L, where
! K = 1,...,DIMENS+1 and L = 1,...,NumRgn.
!
! RgType Integer array of dimension (NumRgn).
! RgType(L) describes the type of region L.
!
! Value Real array of dimension NumFun.
! Approximations to all components of the integral if
! the procedure is restarted.
!
! AbsErr Real array of dimension NumFun.
! Estimates of absolute errors if the procedure is restarted.
!
! IFAIL Optional integer argument.
! This follows the NAG convention:
! IFAIL = 1 : soft silent error
! Control returned to calling program.
! IFAIL = -1: soft noisy error
! Error message is printed.
! Control returned to calling program.
! IFAIL = 0 : hard noisy error
! Error message is printed and program is stopped.
! Default IFAIL = -1.
!
! EpsAbs Optional real argument.
! Requested absolute error.
! Default EpsAbs = 0.
!
! EpsRel Optional real argument.
! Requested relative error.
! Default EpsRel = sqrt(machine precision).
!
! Restart Optional boolean argument.
! If Restart = FALSE, this is the first attempt to compute
! the integral.
! If Restart = TRUE, then we restart a previous attempt.
! In this case the only parameters for CUBATR that may
! be changed (with respect to the previous call of CUBATR)
! are MinPts, MaxPts, EpsAbs, EpsRel, Key and Restart.
! Default Restart = FALSE.
!
! MinPts Optional integer argument.
! The minimum allowed number of integrand evaluations.
! Default MinPts = 0.
!
! MaxPts Optional integer argument.
! The maximum allowed number of integrand evaluations.
! Default MaxPts = enough to do 500 subdivisions.
!
! Key Optional integer argument.
! Can be used by Rule_General to choose between several
! local integration rules.
! Default Key = 2 if Dimension=1 and extrapolation is used
! (This corresponds to QAGS)
! Default Key = 0 otherwise
!
! Job Optional integer argument.
! If |Job| = 0, then nothing will be done except freeing all
! allocated memory.
! This is usefull after a call of CUBATR if no
! Restart will be done later and memory usage
! might become an issue later.
! Equivalently, one can call CUBATR()
! without any arguments.
! = 1, the global adaptive algorithm is called
! = 2, extrapolation using the epsilon algorithm is used.
! = 11, a region will be divided in 2**DIMENS subregions
! and the global adaptive algorithm is called.
! In combination with Key=0, this resembles DUCTRI and DCUTET.
! = 12, a region will be divided in 2 subregions
! and the global adaptive algorithm is called.
! In combination with Key=3 or 4, this resembles DCUHRE.
! If Job < 0, then an overview of the Region Collection is dumped.
! This will create the files tmp_integerstore and tmp_realstore.
! Default Job = 1.
!
! Tune Optional real argument.
! Can be used by Global_Adapt or the local error estimators
! to influence the reliability. 0 <= Tune <= 1.
! Tune = 1 is the most reliable available.
! Default Tune = 1.
! Note that this is an experimental and controversial parameter.
! In this version, only Tune = 1 is supported for all regions.
!
! Output parameters
! -----------------
!
! Value Real array of dimension NumFun.
! Approximations to all components of the integral
!
! AbsErr Real array of dimension NumFun.
! Estimates of absolute errors.
!
! NEval Optional Integer.
! Number of integrand evaluations used by CUBATR for this call.
!
! IFAIL Optional Integer.
! IFAIL = 0 for normal exit.
!
! AbsErr(K) <= EpsAbs or
! AbsErr(K) <= ABS(Value(K))*EpsRel with MaxPts or less
! function evaluations for all values of K,
! 1 <= K <= NumFun .
!
! IFAIL = 1 if MaxPts was too small to obtain the required
! accuracy. In this case Global_Adapt returns values of
! Value with estimated absolute errors AbsErr.
!
! IFAIL > 1 in more serious case of trouble.
!-----------------------------------------------------------------------
Calling sequence for scalar functions and single regions
CALL CUBATR &
(DIMENS,Integrand,SVertices,SRgType,SValue,SAbsErr, &
! and optional parameters &
IFAIL,Neval,EpsAbs,EpsRel,Restart,MaxPts,Key,Job)
!-----------------------------------------------------------------------
! Input parameters
! ----------------
!
! DIMENS Integer.
! The dimension of the region of integration.
!
! Integrand
! Externally declared function for computing all components
! of the integrand at the given evaluation point.
! It must have input parameter X:
! X(1) The x-coordinate of the evaluation point.
! X(2) The y-coordinate of the evaluation point.
! ...
! X(DIMENS) The z-coordinate of the evaluation point.
! and NumFun, the number of components of the integrand.
! It must be compatible with the following interface:
! INTERFACE
! FUNCTION Integrand(NUMFUN,X) RESULT(Value)
! USE Precision_Model
! INTEGER, INTENT(IN) :: NUMFUN
! REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: X
! REAL(kind=stnd), DIMENSION(NUMFUN) :: Value
! END FUNCTION Integrand
! END INTERFACE
!
! SVertices
! Real array of dimension (DIMENS,DIMENS+1).
! Vertices(1:DIMENS,K) are the x, y, ... coordinates
! respectively of vertex K of the region, where
! K = 1,...,DIMENS+1.
!
! SRgType Integer.
! RgType describes the type of region L.
!
! SValue Real.
! Approximation to the integral if the procedure is restarted.
!
! SAbsErr Real.
! Estimate of the absolute error if the procedure is restarted.
!
! IFAIL Optional integer argument.
! This follows the NAG convention:
! IFAIL = 1 : soft silent error
! Control returned to calling program.
! IFAIL = -1: soft noisy error
! Error message is printed.
! Control returned to calling program.
! IFAIL = 0 : hard noisy error
! Error message is printed and program is stopped.
! Default IFAIL = -1.
!
! EpsAbs Optional real argument.
! Requested absolute error.
! Default EpsAbs = 0.
!
! EpsRel Optional real argument.
! Requested relative error.
! Default EpsRel = sqrt(machine precision).
!
! Restart Optional boolean argument.
! If Restart = FALSE, this is the first attempt to compute
! the integral.
! If Restart = TRUE, then we restart a previous attempt.
! In this case the only parameters for CUBATR that may
! be changed (with respect to the previous call of CUBATR)
! are MinPts, MaxPts, EpsAbs, EpsRel, Key and Restart.
! Default Restart = FALSE.
!
! MaxPts Optional integer argument.
! The maximum allowed number of integrand evaluations.
! Default MaxPts = enough to do 500 subdivisions.
!
! Key Optional integer argument.
! Can be used by Rule_General to choose between several
! local integration rules.
! Default Key = 2 if Dimension=1 and extrapolation is used
! (This corresponds to QAGS)
! Default Key = 0 otherwise
!
! Job Optional integer argument.
! If |Job| = 0, then nothing will be done except freeing all
! allocated memory.
! This is usefull after a call of CUBATR if no
! Restart will be done later and memory usage
! might become an issue later.
! Equivalently, one can call CUBATR()
! without any arguments.
! = 1, the global adaptive algorithm is called
! = 2, extrapolation using the epsilon algorithm is used.
! = 11, a region will be divided in 2**DIMENS subregions
! and the global adaptive algorithm is called.
! In combination with Key=0, this resembles DUCTRI and DCUTET.
! = 12, a region will be divided in 2 subregions
! and the global adaptive algorithm is called.
! In combination with Key=3 or 4, this resembles DCUHRE.
! If Job < 0, then an overview of the Region Collection is dumped.
! This will create the files tmp_integerstore and tmp_realstore.
! Default Job = 1.
!
! Output parameters
! -----------------
!
! SValue Real.
! Approximation to the integral
!
! AbsErr Real.
! Estimate of the absolute error.
!
! NEval Optional Integer.
! Number of integrand evaluations used by CUBATR for this call.
!
! IFAIL Optional Integer.
! IFAIL = 0 for normal exit.
!
! AbsErr(K) <= EpsAbs or
! AbsErr(K) <= ABS(Value(K))*EpsRel with MaxPts or less
! function evaluations for all values of K,
! 1 <= K <= NumFun .
!
! IFAIL = 1 if MaxPts was too small to obtain the required
! accuracy. In this case Global_Adapt returns values of
! Value with estimated absolute errors AbsErr.
!
! IFAIL > 1 in more serious case of trouble.
!-----------------------------------------------------------------------
Clearing saved memory
Because CUBPACK has a restart feature, information is saved by
the module. To clean this up explicitely, use an additional
CALL CUBATR()
This is equivalent, but much more convenient, than using the general
calling sequence with JOB=0.
This file is maintained by
Ronald Cools.
This page was last modified on Friday 19 July 2002, 10:38:48 CEST.
CUBPACK's home is
here.
SHAR_EOF
fi # end of overwriting check
if test -f 'simplex_abstract'
then
echo shar: will not over-write existing file "'simplex_abstract'"
else
cat << "SHAR_EOF" > 'simplex_abstract'
An Adaptive Numerical Cubature Algorithm for Simplices
Alan Genz and Ronald Cools
Abstract:
A globally adaptive algorithm for numerical cubature of a vector of
functions over a collection of n-dimensional simplices is described.
The algorithm is based on a subdivision strategy that chooses for
subdivision at each stage the subregion (of the input simplices) with
the largest estimated error. This subregion is divided into two, three
or four equal volume subregions by cutting selected edges. These edges
are selected using information about the smoothness of the integrands
in the edge directions. The algorithm allows a choice from several
embedded cubature rule sequences for approximate integration and error
estimation. A Fortran 95 implementation as a part of CUBPACK is also
discussed. Testing of the algorithm is described.
SHAR_EOF
fi # end of overwriting check
cd ..
if test ! -d 'Fortran90'
then
mkdir 'Fortran90'
fi
cd 'Fortran90'
if test ! -d 'Drivers'
then
mkdir 'Drivers'
fi
cd 'Drivers'
if test -f 'Makefile'
then
echo shar: will not over-write existing file "'Makefile'"
else
cat << "SHAR_EOF" > 'Makefile'
# Suffix for Fortran 90 programs
.SUFFIXES:
.SUFFIXES : .f90 $(SUFFIXES)
#-----------------------------------------------------------------------
# Name of Fortran 90 compiler
FC = f95
# Select your compiler flags
# Example for SUN's f95
#CFLAGS = -M../Src -fast
# Example for NAGWare f95
CFLAGS = -ieee=full -nan -C=all -I../Src
#CFLAGS = -I../Src
# Suffix for Modules (created by compiler)
MSUFF = mod
#-----------------------------------------------------------------------
# Select main program (do not give a suffix!)
# With this distribution the following test programs are distributed:
EXAMPLES= details ex_qag ex_qags ex_triex ex_decuhr2d ex_cutet ex_decuhr3d simplexpapertest
# details : prints info on current distribution
# ex_qag : 1-dimensional integration, tests of QAG from QUADPACK
# ex_qags : 1-dimensional integration, tests of QAGS from QUADPACK
# ex_triex : 2-dimensional integration (triangle), tests of TRIEX
# ex_decuhr2d: 2-dimensional integration (square), test of DECUHR
# ex_cutet : 3-dimensional integration (tetrahedron), test of DCUTET
# ex_decuhr3d: 3-dimensional integration (cube), tests of DECUHR
# simplexpapertest : 5-dimension integration (simplex)
MAIN = simplexpapertest
#-----------------------------------------------------------------------
# The target (executable) will have the same name as the main
# program, without suffix.
TARGET = $(MAIN)
#-----------------------------------------------------------------------
.f90.o:
$(FC) -c $(CFLAGS) $<
#-----------------------------------------------------------------------
all: $(MAIN).o
$(FC) -o $(TARGET) $(MAIN).o $(libcui)
#-----------------------------------------------------------------------
# Place library in current directory (or change the -L../Src)
libcui = -L../Src -lcubpack
clean:
/bin/rm -f *.o *.$(MSUFF) $(EXAMPLES)
SHAR_EOF
fi # end of overwriting check
if test -f 'details.f90'
then
echo shar: will not over-write existing file "'details.f90'"
else
cat << "SHAR_EOF" > 'details.f90'
! This routine only prints details on the current distribtion.
!
PROGRAM Details
USE Precision_Model
USE CUI ! Cubpack User Interface
CALL CUBPACK_INFO()
STOP
END PROGRAM Details
SHAR_EOF
fi # end of overwriting check
if test -f 'details.out'
then
echo shar: will not over-write existing file "'details.out'"
else
cat << "SHAR_EOF" > 'details.out'
---------------------------------------------------------------
CUBPACK information
-------------------
The model for real numbers in the current installed version,
obtained with the declaration REAL(KIND=stnd), has the
following characteristics:
base = 2
digits in this base = 53
This implies:
machine epsilon = 2.2204460492503131E-16
largest real number = 1.7976931348623157E+308
smallest normalized number = 2.2250738585072014E-308
The lowest relative error that may be obtained with this
version is about 0.11E-13
Asking for lower error will push the routine to use the
maximal number of function evaluations it is allowed.
This version accepts a collection of hyper-rectangles
(and parallelepipeds) and simplices as integration regions.
Extrapolation using the epsilon-algorithm is available
for dimensions 1, 2 and 3.
The following values of KEY give different integration rules:
- finite interval: KEY = 1, 2, 3, 4, 5.
KEY < 1 defaults to 1; KEY > 5 defaults to 5.
- n-cube: KEY = 3, 4 uses rule of degree 2*KEY+1
otherwise, uses for a square a rule of degree 13
3-cube a rule of degree 11
a rule of degree 7
- n-simplex: KEY = 1, 2, 3, 4 uses rule of degree 2*KEY+1
otherwise, uses for a triangle a rule of degree 13
tetrahedron a rule of degree 8
a rule of degree 7
KEY = 0 corresponds to our preferred choice.
---------------------------------------------------------------
SHAR_EOF
fi # end of overwriting check
if test -f 'ex_cutet.f90'
then
echo shar: will not over-write existing file "'ex_cutet.f90'"
else
cat << "SHAR_EOF" > 'ex_cutet.f90'
! This file contains the first test program of DCUTET,
! a routine for integration over tetrahedrons.
! See Berntsen, Cools & Espelid, ACM TOMS Vol 19, 1993.
!
MODULE Integrand
IMPLICIT NONE
PUBLIC :: F
CONTAINS
FUNCTION F(NUMFUN,X) RESULT(Value)
USE Precision_Model
INTEGER, INTENT(IN) :: NUMFUN
REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: X
REAL(kind=stnd), DIMENSION(NUMFUN) :: Value
Value(1) = EXP(X(1)*X(1)+X(2)*X(2)+X(3)*X(3))
RETURN
END FUNCTION F
END MODULE Integrand
PROGRAM Example_CUTET
USE Precision_Model
USE CUI ! Cubpack User Interface
USE Integrand
IMPLICIT NONE
INTEGER, PARAMETER :: n=3, & ! the dimension
m=1, & ! the number of simple regions
l=1, & ! the length of the integrand vector
Tetrahedron = 1, &
Parallelogram = 2
INTEGER, DIMENSION(1:m) :: RgType
INTEGER :: NEval
REAL(kind=stnd), DIMENSION(1:n,0:n,1:m) :: Vertices
REAL(kind=stnd), DIMENSION(1:l) :: IntegralValue, AbsErr
REAL(kind=stnd) :: epsrel
RgType(1) = Tetrahedron
Vertices(1:n,0,1) = (/0 , 0, 0 /)
Vertices(1:n,1,1) = (/1 , 0, 0 /)
Vertices(1:n,2,1) = (/0 , 1, 0 /)
Vertices(1:n,3,1) = (/0 , 0, 1 /)
WRITE(unit=*,fmt=*) "Simulation of DCUTET:"
epsrel = 1.0e-5_stnd
WRITE(unit=*,fmt=*) " CUBATR will now be called with epsrel = ",epsrel
CALL CUBATR(n,l,F,m,Vertices,RgType,IntegralValue,AbsErr,Epsrel=epsrel,NEval=NEval,JOB=11)
WRITE(unit=*,fmt=*) " Integral = ",IntegralValue
WRITE(unit=*,fmt=*) " with estimated error < ",AbsErr
WRITE(unit=*,fmt=*) " The number of integrand evaluations used = ",NEval
epsrel = 1.0e-8_stnd
WRITE(unit=*,fmt=*) " CUBATR will now be called with epsrel = ",epsrel
CALL CUBATR(n,l,F,m,Vertices,RgType,IntegralValue,AbsErr,Epsrel=epsrel,NEval=NEval,Restart=.true.,JOB=11)
WRITE(unit=*,fmt=*) " Integral = ",IntegralValue
WRITE(unit=*,fmt=*) " with estimated error < ",AbsErr
WRITE(unit=*,fmt=*) " The number of additional integrand evaluations used = ",NEval
STOP
END PROGRAM Example_CUTET
SHAR_EOF
fi # end of overwriting check
if test -f 'ex_cutet.out'
then
echo shar: will not over-write existing file "'ex_cutet.out'"
else
cat << "SHAR_EOF" > 'ex_cutet.out'
Simulation of DCUTET:
CUBATR will now be called with epsrel = 1.0000000000000001E-05
Integral = 0.2277999969898576
with estimated error < 1.9752829160297815E-06
The number of integrand evaluations used = 43
CUBATR will now be called with epsrel = 1.0000000000000000E-08
Integral = 0.2277998982512967
with estimated error < 2.1808179040984215E-09
The number of additional integrand evaluations used = 688
SHAR_EOF
fi # end of overwriting check
if test -f 'ex_decuhr2d.f90'
then
echo shar: will not over-write existing file "'ex_decuhr2d.f90'"
else
cat << "SHAR_EOF" > 'ex_decuhr2d.f90'
! This file contains a test example for the square
! that appears in the DECUHR paper:
! Espelid & Genz, Numerical Algorithms Vol 8, 1994.
! The restart feature is used with the default integration routine.
MODULE Integrand
IMPLICIT NONE
PUBLIC :: F
PRIVATE
CONTAINS
FUNCTION F(NUMFUN,X) RESULT(Value)
USE Precision_Model
INTEGER, INTENT(IN) :: NUMFUN
REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: X
REAL(kind=stnd), DIMENSION(1:NUMFUN) :: Value
! The integrand is scaled so that the exact result is 1.
Value(1) = exp(2*x(1)+x(2)*(1-x(1))) * (1-x(1)) / sqrt(x(1))
Value(1) = Value(1)/3.22289153891637_stnd
RETURN
END FUNCTION F
END MODULE Integrand
PROGRAM Example2D
USE Precision_Model
USE CUI ! Cubpack User Interface
USE Integrand
INTEGER, PARAMETER :: n=2, & ! the dimension
m=1, & ! the number of simple regions
l=1, & ! the length of the integrand vector
Cube=2
INTEGER, DIMENSION(1:m) :: RgType
INTEGER :: NEval, j
REAL(kind=stnd), DIMENSION(1:n,0:n,1:m) :: Vertices
REAL(kind=stnd), DIMENSION(1:l) :: IntegralValue, AbsErr
REAL(kind=stnd) :: EpsRel
LOGICAL :: Restart
RgType(1) = Cube
Vertices(1:n,0,1) = (/0 , 0 /)
Vertices(1:n,1,1) = (/1 , 0 /)
Vertices(1:n,2,1) = (/0 , 1 /)
epsrel = 0.01_stnd
Restart= .false.
do j = 1,4
Print *,"Request relative accuracy = ",epsrel
CALL CUBATR(n,l,F,m,Vertices(:,:,1:m),RgType,IntegralValue,AbsErr, &
NEval=NEval,EpsRel=epsrel,Restart=Restart)
Print *,"-> Integral approximation = ",IntegralValue
Print *,"-> with estimated error < ",AbsErr
Print *,"-> The number of integrand evaluations used = ",NEval
Print *,""
epsrel=epsrel*0.01_stnd
Restart = .true.
end do
STOP
END PROGRAM Example2D
SHAR_EOF
fi # end of overwriting check
if test -f 'ex_decuhr2d.out'
then
echo shar: will not over-write existing file "'ex_decuhr2d.out'"
else
cat << "SHAR_EOF" > 'ex_decuhr2d.out'
Request relative accuracy = 1.0000000000000000E-02
-> Integral approximation = 0.9997541078696911
-> with estimated error < 9.7141400501658589E-03
-> The number of integrand evaluations used = 1073
Request relative accuracy = 1.0000000000000000E-04
-> Integral approximation = 0.9999980789642501
-> with estimated error < 7.5892903270461572E-05
-> The number of integrand evaluations used = 1036
Request relative accuracy = 1.0000000000000002E-06
-> Integral approximation = 0.9999999787718864
-> with estimated error < 8.3967209823977500E-07
-> The number of integrand evaluations used = 962
Request relative accuracy = 1.0000000000000002E-08
-> Integral approximation = 0.9999999998306773
-> with estimated error < 7.7298122812463085E-09
-> The number of integrand evaluations used = 1036
SHAR_EOF
fi # end of overwriting check
if test -f 'ex_decuhr3d.f90'
then
echo shar: will not over-write existing file "'ex_decuhr3d.f90'"
else
cat << "SHAR_EOF" > 'ex_decuhr3d.f90'
! This file contains the test examples for the 3-dimensional cube
! that appear in the DECUHR paper:
! Espelid & Genz, Numerical Algorithms Vol 8, 1994.
!
MODULE Integrand
IMPLICIT NONE
PUBLIC :: F, INIT
PRIVATE
INTEGER, PRIVATE :: Fnr
CONTAINS
FUNCTION F(NUMFUN,X) RESULT(Value)
USE Precision_Model
INTEGER, INTENT(IN) :: NUMFUN
REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: X
REAL(kind=stnd), DIMENSION(1:NUMFUN) :: Value
REAL(kind=stnd) :: r
SELECT CASE (Fnr)
CASE(1)
Value(1) = exp(x(1)+x(1)*x(2)+x(3)/3) /(sqrt(x(1)+x(2))*2.7878925361_stnd)
CASE(2)
r = sqrt(x(1)*x(1)+x(2)*x(2)+x(3)*x(3))
Value(1) = -log(r)*exp(x(1)*x(2)+x(3))/(sqrt(r)*0.1176364548_stnd)
END SELECT
RETURN
END FUNCTION F
SUBROUTINE INIT (invoer)
INTEGER, INTENT(IN) :: invoer
Fnr = invoer
RETURN
END SUBROUTINE INIT
END MODULE Integrand
PROGRAM Example3D
USE Precision_Model
USE CUI ! Cubpack User Interface
USE Integrand
INTEGER, PARAMETER :: n=3, & ! the dimension
m=1, & ! the number of simple regions
l=1, & ! the length of the integrand vector
Simplex = 1, &
Cube=2
INTEGER, DIMENSION(1:m) :: RgType
INTEGER :: NEval, i,j,k, testfunction, Job, Key
INTEGER, DIMENSION(1:3) :: jobtypes = (/ 1,12,2 /)
INTEGER, DIMENSION(1:3) :: keytypes = (/ 0,3,4 /)
REAL(kind=stnd), DIMENSION(1:n,0:n,1:m) :: Vertices
REAL(kind=stnd), DIMENSION(1:l) :: IntegralValue, AbsErr
REAL(kind=stnd) :: EpsRel
LOGICAL :: RESTART
RgType(1) = Cube
Vertices(1:n,0,1) = (/0 , 0 , 0 /)
Vertices(1:n,1,1) = (/1 , 0 , 0 /)
Vertices(1:n,2,1) = (/0 , 1 , 0 /)
Vertices(1:n,3,1) = (/0 , 0 , 1 /)
do testfunction = 1,2
Print *,"Testfunction ",testfunction
Print *,"==============="
CALL INIT(testfunction)
do i = 1,size(jobtypes)
Job = jobtypes(i)
do k = 1,size(keytypes)
Key = keytypes(k)
Print *,"JOB = ",Job," and Key=",Key
Print *," Err Req Integral Error est Cost"
epsrel = 0.1_stnd
RESTART= .false.
do j = 1,4
CALL CUBATR(n,l,F,m,Vertices(:,:,1:m),RgType,IntegralValue,&
AbsErr,NEval=NEval,EpsRel=epsrel, &
JOB=Job,KEY=Key,Restart=RESTART,MaxPTS=100000)
Print '(E10.3,F22.15,E10.3,I8)',EpsRel, IntegralValue, AbsErr, NEval
epsrel=epsrel*0.01_stnd
if (Job /= 2) then
RESTART = .true.
end if
end do
CALL CUBATR()
Print *,""
end do
Print *,"----------------------------------------------------------"
end do
end do
STOP
END PROGRAM Example3D
SHAR_EOF
fi # end of overwriting check
if test -f 'ex_decuhr3d.out'
then
echo shar: will not over-write existing file "'ex_decuhr3d.out'"
else
cat << "SHAR_EOF" > 'ex_decuhr3d.out'
Testfunction 1
===============
JOB = 1 and Key= 0
Err Req Integral Error est Cost
0.100E+00 1.001163725242669 0.108E-01 89
0.100E-02 1.000051697523749 0.484E-03 1068
0.100E-04 1.000000810182230 0.768E-05 1424
0.100E-06 1.000000005542309 0.979E-07 2492
JOB = 1 and Key= 3
Err Req Integral Error est Cost
0.100E+00 1.000985711929658 0.652E-01 195
0.100E-02 1.000002133902706 0.993E-03 1482
0.100E-04 1.000000022023047 0.922E-05 2028
0.100E-06 0.999999999727435 0.973E-07 5148
JOB = 1 and Key= 4
Err Req Integral Error est Cost
0.100E+00 1.001940586463901 0.196E-01 77
0.100E-02 1.000123252414042 0.656E-03 924
0.100E-04 1.000000279816102 0.892E-05 3542
0.100E-06 1.000000012150892 0.863E-07 5236
----------------------------------------------------------
JOB = 12 and Key= 0
Err Req Integral Error est Cost
0.100E+00 1.001163725242669 0.108E-01 89
0.100E-02 1.000068703503122 0.745E-03 890
0.100E-04 1.000000816891973 0.791E-05 1602
0.100E-06 1.000000002954057 0.941E-07 2848
JOB = 12 and Key= 3
Err Req Integral Error est Cost
0.100E+00 1.000985711929658 0.652E-01 195
0.100E-02 1.000002133902706 0.993E-03 1482
0.100E-04 1.000000022023047 0.922E-05 2028
0.100E-06 0.999999999727435 0.973E-07 5148
JOB = 12 and Key= 4
Err Req Integral Error est Cost
0.100E+00 1.001940586463901 0.196E-01 77
0.100E-02 1.000123252414042 0.656E-03 924
0.100E-04 1.000000279816102 0.892E-05 3542
0.100E-06 1.000000012150892 0.863E-07 5236
----------------------------------------------------------
JOB = 2 and Key= 0
Err Req Integral Error est Cost
0.100E+00 1.001163725242669 0.108E-01 89
0.100E-02 0.999998761741008 0.415E-03 2225
0.100E-04 0.999999837660737 0.117E-05 5073
0.100E-06 0.999999999775124 0.125E-07 34265
JOB = 2 and Key= 3
Err Req Integral Error est Cost
0.100E+00 0.999993132571583 0.101E-02 975
0.100E-02 0.999999250124814 0.137E-04 4719
0.100E-04 0.999999135849675 0.721E-05 6279
0.100E-06 0.999999997856459 0.213E-07 86463
JOB = 2 and Key= 4
Err Req Integral Error est Cost
0.100E+00 1.001940586463901 0.196E-01 77
0.100E-02 0.999999525248721 0.689E-03 3157
0.100E-04 0.999999823055542 0.324E-06 10549
0.100E-06 1.000000002448551 0.807E-07 56133
----------------------------------------------------------
Testfunction 2
===============
JOB = 1 and Key= 0
Err Req Integral Error est Cost
0.100E+00 1.001219527452425 0.500E-01 801
0.100E-02 1.000009844244836 0.392E-03 2136
0.100E-04 1.000000513199047 0.323E-05 2136
0.100E-06 1.000000344478394 0.926E-07 2848
JOB = 1 and Key= 3
Err Req Integral Error est Cost
0.100E+00 0.999939124769939 0.988E-01 5577
0.100E-02 0.999999121249005 0.986E-03 30420
0.100E-04 0.999999961128279 0.998E-05 81042
-> Allowed number of function evaluations reached.
0.100E-06 0.999999991528949 0.569E-06 99996
JOB = 1 and Key= 4
Err Req Integral Error est Cost
0.100E+00 1.013854234672262 0.921E-01 693
0.100E-02 1.000003579641635 0.989E-03 19250
-> Allowed number of function evaluations reached.
0.100E-04 1.000000025953699 0.316E-04 99946
-> Allowed number of function evaluations reached.
0.100E-06 1.000000002122953 0.546E-05 99946
----------------------------------------------------------
JOB = 12 and Key= 0
Err Req Integral Error est Cost
0.100E+00 0.995926356362354 0.756E-01 445
0.100E-02 0.999987084932052 0.879E-03 1602
0.100E-04 0.999999961038715 0.610E-05 3382
0.100E-06 1.000000206555651 0.982E-07 5696
JOB = 12 and Key= 3
Err Req Integral Error est Cost
0.100E+00 0.999939124769939 0.988E-01 5577
0.100E-02 0.999999121249005 0.986E-03 30420
0.100E-04 0.999999961128279 0.998E-05 81042
-> Allowed number of function evaluations reached.
0.100E-06 0.999999991528949 0.569E-06 99996
JOB = 12 and Key= 4
Err Req Integral Error est Cost
0.100E+00 1.013854234672262 0.921E-01 693
0.100E-02 1.000003579641635 0.989E-03 19250
-> Allowed number of function evaluations reached.
0.100E-04 1.000000025953699 0.316E-04 99946
-> Allowed number of function evaluations reached.
0.100E-06 1.000000002122953 0.546E-05 99946
----------------------------------------------------------
JOB = 2 and Key= 0
Err Req Integral Error est Cost
0.100E+00 1.000021050889802 0.120E-02 1513
0.100E-02 1.000001617541351 0.198E-04 2225
0.100E-04 1.000000369271170 0.167E-05 2937
0.100E-06 0.999999996279877 0.545E-07 11481
JOB = 2 and Key= 3
Err Req Integral Error est Cost
0.100E+00 1.000143707726010 0.633E-02 2847
0.100E-02 1.000010592078562 0.134E-03 15015
-> Allowed number of function evaluations reached.
0.100E-04 0.999999640754199 0.118E-04 99879
-> Allowed number of function evaluations reached.
0.100E-06 1.000010575989407 0.133E-03 99879
JOB = 2 and Key= 4
Err Req Integral Error est Cost
0.100E+00 1.006357416426450 0.206E-01 4389
0.100E-02 0.999984668237667 0.125E-03 24101
-> Allowed number of function evaluations reached.
0.100E-04 0.999984729148196 0.321E-04 99869
-> Allowed number of function evaluations reached.
0.100E-06 0.999984729091079 0.317E-04 99869
----------------------------------------------------------
SHAR_EOF
fi # end of overwriting check
if test -f 'ex_qag.f90'
then
echo shar: will not over-write existing file "'ex_qag.f90'"
else
cat << "SHAR_EOF" > 'ex_qag.f90'
MODULE Integrand
PRIVATE
PUBLIC :: F
CONTAINS
FUNCTION F(NUMFUN,X) RESULT(Value)
USE Precision_Model
INTEGER, INTENT(IN) :: NUMFUN
REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: X
REAL(kind=stnd), DIMENSION(NUMFUN) :: Value
Value(1) = (abs(x(1)-1.0_stnd/3.0_stnd))**(0.8_stnd)
RETURN
END FUNCTION F
END MODULE Integrand
PROGRAM Example_QAG
!
! This is equivalent to the test program for QAG from QUADPACK
! The output is identical to the orginal Fortran 77 programs.
! 25 May 1999
USE Precision_Model
USE CUI ! Cubpack User Interface
USE Integrand
IMPLICIT NONE
INTEGER, PARAMETER :: n=1, & ! the dimension
Finite_interval = 1
INTEGER :: RgType, NEval, j, key
REAL(kind=stnd), DIMENSION(1:n,0:n) :: Vertices
REAL(kind=stnd) :: IntegralValue, AbsErr, epsrel
epsrel = 0.1_stnd
do j=1,10
epsrel = epsrel*0.1_stnd
do key = 1,6
RgType = Finite_interval
Vertices(1,:) = (/ 0 , 1 /)
CALL CUBATR(n,F,Vertices,RgType,IntegralValue,AbsErr, &
MAXPTS=50000,EpsRel=epsrel,Key=key,NEval=NEval,JOB=1)
write(unit=*,fmt="( "" Results for key = "",I3 )") KEY
write(unit=*,fmt="( "" Results for epsrel = "",es9.2 )") EPSREL
write(unit=*,fmt="( "" INTEGRAL APPROXIMATION = "",es15.8 )") IntegralValue
write(unit=*,fmt="( "" ESTIMATE OF ABSOLUTE ERROR = "",es9.2 )") ABSERR
write(unit=*,fmt="( "" NUMBER OF FUNCTION EVALATIONS = "",i5 )") NEVAL
end do
end do
STOP
END PROGRAM Example_QAG
SHAR_EOF
fi # end of overwriting check
if test -f 'ex_qag.out'
then
echo shar: will not over-write existing file "'ex_qag.out'"
else
cat << "SHAR_EOF" > 'ex_qag.out'
Results for key = 1
Results for epsrel = 1.00E-02
INTEGRAL APPROXIMATION = 3.44676993E-01
ESTIMATE OF ABSOLUTE ERROR = 1.08E-03
NUMBER OF FUNCTION EVALATIONS = 135
Results for key = 2
Results for epsrel = 1.00E-02
INTEGRAL APPROXIMATION = 3.44670156E-01
ESTIMATE OF ABSOLUTE ERROR = 1.10E-03
NUMBER OF FUNCTION EVALATIONS = 189
Results for key = 3
Results for epsrel = 1.00E-02
INTEGRAL APPROXIMATION = 3.44675548E-01
ESTIMATE OF ABSOLUTE ERROR = 3.05E-03
NUMBER OF FUNCTION EVALATIONS = 217
Results for key = 4
Results for epsrel = 1.00E-02
INTEGRAL APPROXIMATION = 3.44688417E-01
ESTIMATE OF ABSOLUTE ERROR = 1.56E-03
NUMBER OF FUNCTION EVALATIONS = 205
Results for key = 5
Results for epsrel = 1.00E-02
INTEGRAL APPROXIMATION = 3.44845059E-01
ESTIMATE OF ABSOLUTE ERROR = 6.05E-04
NUMBER OF FUNCTION EVALATIONS = 51
Results for key = 6
Results for epsrel = 1.00E-02
INTEGRAL APPROXIMATION = 3.44700813E-01
ESTIMATE OF ABSOLUTE ERROR = 2.75E-03
NUMBER OF FUNCTION EVALATIONS = 183
Results for key = 1
Results for epsrel = 1.00E-03
INTEGRAL APPROXIMATION = 3.44670425E-01
ESTIMATE OF ABSOLUTE ERROR = 3.10E-04
NUMBER OF FUNCTION EVALATIONS = 165
Results for key = 2
Results for epsrel = 1.00E-03
INTEGRAL APPROXIMATION = 3.44668462E-01
ESTIMATE OF ABSOLUTE ERROR = 3.16E-04
NUMBER OF FUNCTION EVALATIONS = 231
Results for key = 3
Results for epsrel = 1.00E-03
INTEGRAL APPROXIMATION = 3.44668420E-01
ESTIMATE OF ABSOLUTE ERROR = 2.51E-04
NUMBER OF FUNCTION EVALATIONS = 341
Results for key = 4
Results for epsrel = 1.00E-03
INTEGRAL APPROXIMATION = 3.44669481E-01
ESTIMATE OF ABSOLUTE ERROR = 1.29E-04
NUMBER OF FUNCTION EVALATIONS = 369
Results for key = 5
Results for epsrel = 1.00E-03
INTEGRAL APPROXIMATION = 3.44718690E-01
ESTIMATE OF ABSOLUTE ERROR = 1.74E-04
NUMBER OF FUNCTION EVALATIONS = 153
Results for key = 6
Results for epsrel = 1.00E-03
INTEGRAL APPROXIMATION = 3.44670504E-01
ESTIMATE OF ABSOLUTE ERROR = 2.27E-04
NUMBER OF FUNCTION EVALATIONS = 427
Results for key = 1
Results for epsrel = 1.00E-04
INTEGRAL APPROXIMATION = 3.44667997E-01
ESTIMATE OF ABSOLUTE ERROR = 2.56E-05
NUMBER OF FUNCTION EVALATIONS = 225
Results for key = 2
Results for epsrel = 1.00E-04
INTEGRAL APPROXIMATION = 3.44667836E-01
ESTIMATE OF ABSOLUTE ERROR = 2.60E-05
NUMBER OF FUNCTION EVALATIONS = 315
Results for key = 3
Results for epsrel = 1.00E-04
INTEGRAL APPROXIMATION = 3.44667832E-01
ESTIMATE OF ABSOLUTE ERROR = 2.07E-05
NUMBER OF FUNCTION EVALATIONS = 465
Results for key = 4
Results for epsrel = 1.00E-04
INTEGRAL APPROXIMATION = 3.44667920E-01
ESTIMATE OF ABSOLUTE ERROR = 1.06E-05
NUMBER OF FUNCTION EVALATIONS = 533
Results for key = 5
Results for epsrel = 1.00E-04
INTEGRAL APPROXIMATION = 3.44671978E-01
ESTIMATE OF ABSOLUTE ERROR = 1.43E-05
NUMBER OF FUNCTION EVALATIONS = 357
Results for key = 6
Results for epsrel = 1.00E-04
INTEGRAL APPROXIMATION = 3.44668004E-01
ESTIMATE OF ABSOLUTE ERROR = 1.87E-05
NUMBER OF FUNCTION EVALATIONS = 671
Results for key = 1
Results for epsrel = 1.00E-05
INTEGRAL APPROXIMATION = 3.44667797E-01
ESTIMATE OF ABSOLUTE ERROR = 2.11E-06
NUMBER OF FUNCTION EVALATIONS = 285
Results for key = 2
Results for epsrel = 1.00E-05
INTEGRAL APPROXIMATION = 3.44667784E-01
ESTIMATE OF ABSOLUTE ERROR = 2.15E-06
NUMBER OF FUNCTION EVALATIONS = 399
Results for key = 3
Results for epsrel = 1.00E-05
INTEGRAL APPROXIMATION = 3.44667784E-01
ESTIMATE OF ABSOLUTE ERROR = 1.71E-06
NUMBER OF FUNCTION EVALATIONS = 589
Results for key = 4
Results for epsrel = 1.00E-05
INTEGRAL APPROXIMATION = 3.44667820E-01
ESTIMATE OF ABSOLUTE ERROR = 3.06E-06
NUMBER OF FUNCTION EVALATIONS = 615
Results for key = 5
Results for epsrel = 1.00E-05
INTEGRAL APPROXIMATION = 3.44668126E-01
ESTIMATE OF ABSOLUTE ERROR = 1.18E-06
NUMBER OF FUNCTION EVALATIONS = 561
Results for key = 6
Results for epsrel = 1.00E-05
INTEGRAL APPROXIMATION = 3.44667798E-01
ESTIMATE OF ABSOLUTE ERROR = 1.54E-06
NUMBER OF FUNCTION EVALATIONS = 915
Results for key = 1
Results for epsrel = 1.00E-06
INTEGRAL APPROXIMATION = 3.44667781E-01
ESTIMATE OF ABSOLUTE ERROR = 1.74E-07
NUMBER OF FUNCTION EVALATIONS = 345
Results for key = 2
Results for epsrel = 1.00E-06
INTEGRAL APPROXIMATION = 3.44667780E-01
ESTIMATE OF ABSOLUTE ERROR = 1.77E-07
NUMBER OF FUNCTION EVALATIONS = 483
Results for key = 3
Results for epsrel = 1.00E-06
INTEGRAL APPROXIMATION = 3.44667780E-01
ESTIMATE OF ABSOLUTE ERROR = 1.41E-07
NUMBER OF FUNCTION EVALATIONS = 713
Results for key = 4
Results for epsrel = 1.00E-06
INTEGRAL APPROXIMATION = 3.44667783E-01
ESTIMATE OF ABSOLUTE ERROR = 2.52E-07
NUMBER OF FUNCTION EVALATIONS = 779
Results for key = 5
Results for epsrel = 1.00E-06
INTEGRAL APPROXIMATION = 3.44667879E-01
ESTIMATE OF ABSOLUTE ERROR = 3.39E-07
NUMBER OF FUNCTION EVALATIONS = 663
Results for key = 6
Results for epsrel = 1.00E-06
INTEGRAL APPROXIMATION = 3.44667781E-01
ESTIMATE OF ABSOLUTE ERROR = 1.27E-07
NUMBER OF FUNCTION EVALATIONS = 1159
Results for key = 1
Results for epsrel = 1.00E-07
INTEGRAL APPROXIMATION = 3.44667779E-01
ESTIMATE OF ABSOLUTE ERROR = 1.44E-08
NUMBER OF FUNCTION EVALATIONS = 405
Results for key = 2
Results for epsrel = 1.00E-07
INTEGRAL APPROXIMATION = 3.44667779E-01
ESTIMATE OF ABSOLUTE ERROR = 1.46E-08
NUMBER OF FUNCTION EVALATIONS = 567
Results for key = 3
Results for epsrel = 1.00E-07
INTEGRAL APPROXIMATION = 3.44667779E-01
ESTIMATE OF ABSOLUTE ERROR = 1.16E-08
NUMBER OF FUNCTION EVALATIONS = 837
Results for key = 4
Results for epsrel = 1.00E-07
INTEGRAL APPROXIMATION = 3.44667780E-01
ESTIMATE OF ABSOLUTE ERROR = 2.08E-08
NUMBER OF FUNCTION EVALATIONS = 943
Results for key = 5
Results for epsrel = 1.00E-07
INTEGRAL APPROXIMATION = 3.44667787E-01
ESTIMATE OF ABSOLUTE ERROR = 2.80E-08
NUMBER OF FUNCTION EVALATIONS = 867
Results for key = 6
Results for epsrel = 1.00E-07
INTEGRAL APPROXIMATION = 3.44667779E-01
ESTIMATE OF ABSOLUTE ERROR = 1.05E-08
NUMBER OF FUNCTION EVALATIONS = 1403
Results for key = 1
Results for epsrel = 1.00E-08
INTEGRAL APPROXIMATION = 3.44667779E-01
ESTIMATE OF ABSOLUTE ERROR = 1.20E-09
NUMBER OF FUNCTION EVALATIONS = 465
Results for key = 2
Results for epsrel = 1.00E-08
INTEGRAL APPROXIMATION = 3.44667779E-01
ESTIMATE OF ABSOLUTE ERROR = 1.20E-09
NUMBER OF FUNCTION EVALATIONS = 651
Results for key = 3
Results for epsrel = 1.00E-08
INTEGRAL APPROXIMATION = 3.44667779E-01
ESTIMATE OF ABSOLUTE ERROR = 3.34E-09
NUMBER OF FUNCTION EVALATIONS = 899
Results for key = 4
Results for epsrel = 1.00E-08
INTEGRAL APPROXIMATION = 3.44667779E-01
ESTIMATE OF ABSOLUTE ERROR = 1.71E-09
NUMBER OF FUNCTION EVALATIONS = 1107
Results for key = 5
Results for epsrel = 1.00E-08
INTEGRAL APPROXIMATION = 3.44667780E-01
ESTIMATE OF ABSOLUTE ERROR = 2.31E-09
NUMBER OF FUNCTION EVALATIONS = 1071
Results for key = 6
Results for epsrel = 1.00E-08
INTEGRAL APPROXIMATION = 3.44667779E-01
ESTIMATE OF ABSOLUTE ERROR = 3.02E-09
NUMBER OF FUNCTION EVALATIONS = 1525
Results for key = 1
Results for epsrel = 1.00E-09
INTEGRAL APPROXIMATION = 3.44667779E-01
ESTIMATE OF ABSOLUTE ERROR = 1.13E-10
NUMBER OF FUNCTION EVALATIONS = 525
Results for key = 2
Results for epsrel = 1.00E-09
INTEGRAL APPROXIMATION = 3.44667779E-01
ESTIMATE OF ABSOLUTE ERROR = 9.93E-11
NUMBER OF FUNCTION EVALATIONS = 735
Results for key = 3
Results for epsrel = 1.00E-09
INTEGRAL APPROXIMATION = 3.44667779E-01
ESTIMATE OF ABSOLUTE ERROR = 2.75E-10
NUMBER OF FUNCTION EVALATIONS = 1023
Results for key = 4
Results for epsrel = 1.00E-09
INTEGRAL APPROXIMATION = 3.44667779E-01
ESTIMATE OF ABSOLUTE ERROR = 1.41E-10
NUMBER OF FUNCTION EVALATIONS = 1271
Results for key = 5
Results for epsrel = 1.00E-09
INTEGRAL APPROXIMATION = 3.44667779E-01
ESTIMATE OF ABSOLUTE ERROR = 1.90E-10
NUMBER OF FUNCTION EVALATIONS = 1275
Results for key = 6
Results for epsrel = 1.00E-09
INTEGRAL APPROXIMATION = 3.44667779E-01
ESTIMATE OF ABSOLUTE ERROR = 2.49E-10
NUMBER OF FUNCTION EVALATIONS = 1769
Results for key = 1
Results for epsrel = 1.00E-10
INTEGRAL APPROXIMATION = 3.44667779E-01
ESTIMATE OF ABSOLUTE ERROR = 2.34E-11
NUMBER OF FUNCTION EVALATIONS = 585
Results for key = 2
Results for epsrel = 1.00E-10
INTEGRAL APPROXIMATION = 3.44667779E-01
ESTIMATE OF ABSOLUTE ERROR = 2.85E-11
NUMBER OF FUNCTION EVALATIONS = 777
Results for key = 3
Results for epsrel = 1.00E-10
INTEGRAL APPROXIMATION = 3.44667779E-01
ESTIMATE OF ABSOLUTE ERROR = 2.27E-11
NUMBER OF FUNCTION EVALATIONS = 1147
Results for key = 4
Results for epsrel = 1.00E-10
INTEGRAL APPROXIMATION = 3.44667779E-01
ESTIMATE OF ABSOLUTE ERROR = 1.17E-11
NUMBER OF FUNCTION EVALATIONS = 1435
Results for key = 5
Results for epsrel = 1.00E-10
INTEGRAL APPROXIMATION = 3.44667779E-01
ESTIMATE OF ABSOLUTE ERROR = 1.57E-11
NUMBER OF FUNCTION EVALATIONS = 1479
Results for key = 6
Results for epsrel = 1.00E-10
INTEGRAL APPROXIMATION = 3.44667779E-01
ESTIMATE OF ABSOLUTE ERROR = 2.05E-11
NUMBER OF FUNCTION EVALATIONS = 2013
Results for key = 1
Results for epsrel = 1.00E-11
INTEGRAL APPROXIMATION = 3.44667779E-01
ESTIMATE OF ABSOLUTE ERROR = 1.93E-12
NUMBER OF FUNCTION EVALATIONS = 705
Results for key = 2
Results for epsrel = 1.00E-11
INTEGRAL APPROXIMATION = 3.44667779E-01
ESTIMATE OF ABSOLUTE ERROR = 2.35E-12
NUMBER OF FUNCTION EVALATIONS = 861
Results for key = 3
Results for epsrel = 1.00E-11
INTEGRAL APPROXIMATION = 3.44667779E-01
ESTIMATE OF ABSOLUTE ERROR = 1.88E-12
NUMBER OF FUNCTION EVALATIONS = 1271
Results for key = 4
Results for epsrel = 1.00E-11
INTEGRAL APPROXIMATION = 3.44667779E-01
ESTIMATE OF ABSOLUTE ERROR = 3.35E-12
NUMBER OF FUNCTION EVALATIONS = 1517
Results for key = 5
Results for epsrel = 1.00E-11
INTEGRAL APPROXIMATION = 3.44667779E-01
ESTIMATE OF ABSOLUTE ERROR = 1.30E-12
NUMBER OF FUNCTION EVALATIONS = 1683
Results for key = 6
Results for epsrel = 1.00E-11
INTEGRAL APPROXIMATION = 3.44667779E-01
ESTIMATE OF ABSOLUTE ERROR = 1.70E-12
NUMBER OF FUNCTION EVALATIONS = 2257
SHAR_EOF
fi # end of overwriting check
if test -f 'ex_qags.f90'
then
echo shar: will not over-write existing file "'ex_qags.f90'"
else
cat << "SHAR_EOF" > 'ex_qags.f90'
MODULE Integrand
PRIVATE
PUBLIC :: F
CONTAINS
FUNCTION F(NUMFUN,X) RESULT(Value)
USE Precision_Model
INTEGER, INTENT(IN) :: NUMFUN
REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: X
REAL(kind=stnd), DIMENSION(NUMFUN) :: Value
Value(1) = log(x(1))*(x(1)**0.2_stnd)
RETURN
END FUNCTION F
END MODULE Integrand
PROGRAM Example_QAGS
!
! This is equivalent to the test program for QAGS from QUADPACK
! The output is identical to the orginal Fortran 77 programs
! (at least on Linux using NAGWare f95 and f77).
! Minor differences for small numbers possible on e.g. Sun.
USE Precision_Model
USE CUI ! Cubpack User Interface
USE Integrand
INTEGER, PARAMETER :: n=1, & ! the dimension
Finite_interval = 1
INTEGER :: RgType, NEval, j, key
REAL(kind=stnd):: IntegralValue, AbsErr, epsrel
REAL(kind=stnd), DIMENSION(1:n,0:n) :: Vertices
epsrel = 0.1_stnd
do j=1,10
epsrel = epsrel*0.1_stnd
RgType = Finite_interval
Vertices(1,:) = (/ 0 , 1 /)
CALL CUBATR(n,F,Vertices,RgType,IntegralValue,AbsErr, &
EpsRel=epsrel,NEval=NEval,JOB=2)
! EpsRel=epsrel,Key=2,NEval=NEval,JOB=2)
! ^^/^^ ^^^/^
! QAGS uses dqk21 only ---------/ /
! (Key=2 is therefore made default.) /
! uses extrapolation ------------------------/
!
! write(unit=*,fmt="( "" Results for key = "",I3 )") KEY
write(unit=*,fmt="( "" Resuls for epsrel = "",es9.2 )") EPSREL
write(unit=*,fmt="( "" INTEGRAL APPROXIMATION = "",es15.8 )") IntegralValue
write(unit=*,fmt="( "" ESTIMATE OF ABSOLUTE ERROR = "",es9.2 )") ABSERR
write(unit=*,fmt="( "" NUMBER OF FUNCTION EVALATIONS = "",i5 )") NEVAL
write(unit=*,fmt="( "" ERROR CODE = 0"" )") ! IER
end do
STOP
END PROGRAM Example_QAGS
SHAR_EOF
fi # end of overwriting check
if test -f 'ex_qags.out'
then
echo shar: will not over-write existing file "'ex_qags.out'"
else
cat << "SHAR_EOF" > 'ex_qags.out'
Resuls for epsrel = 1.00E-02
INTEGRAL APPROXIMATION = -6.94451546E-01
ESTIMATE OF ABSOLUTE ERROR = 4.30E-03
NUMBER OF FUNCTION EVALATIONS = 189
ERROR CODE = 0
Resuls for epsrel = 1.00E-03
INTEGRAL APPROXIMATION = -6.94444444E-01
ESTIMATE OF ABSOLUTE ERROR = 4.20E-06
NUMBER OF FUNCTION EVALATIONS = 231
ERROR CODE = 0
Resuls for epsrel = 1.00E-04
INTEGRAL APPROXIMATION = -6.94444444E-01
ESTIMATE OF ABSOLUTE ERROR = 4.20E-06
NUMBER OF FUNCTION EVALATIONS = 231
ERROR CODE = 0
Resuls for epsrel = 1.00E-05
INTEGRAL APPROXIMATION = -6.94444444E-01
ESTIMATE OF ABSOLUTE ERROR = 4.20E-06
NUMBER OF FUNCTION EVALATIONS = 231
ERROR CODE = 0
Resuls for epsrel = 1.00E-06
INTEGRAL APPROXIMATION = -6.94444444E-01
ESTIMATE OF ABSOLUTE ERROR = 8.84E-15
NUMBER OF FUNCTION EVALATIONS = 315
ERROR CODE = 0
Resuls for epsrel = 1.00E-07
INTEGRAL APPROXIMATION = -6.94444444E-01
ESTIMATE OF ABSOLUTE ERROR = 8.84E-15
NUMBER OF FUNCTION EVALATIONS = 315
ERROR CODE = 0
Resuls for epsrel = 1.00E-08
INTEGRAL APPROXIMATION = -6.94444444E-01
ESTIMATE OF ABSOLUTE ERROR = 8.84E-15
NUMBER OF FUNCTION EVALATIONS = 315
ERROR CODE = 0
Resuls for epsrel = 1.00E-09
INTEGRAL APPROXIMATION = -6.94444444E-01
ESTIMATE OF ABSOLUTE ERROR = 8.84E-15
NUMBER OF FUNCTION EVALATIONS = 315
ERROR CODE = 0
Resuls for epsrel = 1.00E-10
INTEGRAL APPROXIMATION = -6.94444444E-01
ESTIMATE OF ABSOLUTE ERROR = 8.84E-15
NUMBER OF FUNCTION EVALATIONS = 315
ERROR CODE = 0
Resuls for epsrel = 1.00E-11
INTEGRAL APPROXIMATION = -6.94444444E-01
ESTIMATE OF ABSOLUTE ERROR = 8.84E-15
NUMBER OF FUNCTION EVALATIONS = 315
ERROR CODE = 0
SHAR_EOF
fi # end of overwriting check
if test -f 'ex_triex.f90'
then
echo shar: will not over-write existing file "'ex_triex.f90'"
else
cat << "SHAR_EOF" > 'ex_triex.f90'
!
! This file is equivalent to the tests mentioned in the TRIEX paper.
! The results are NOT fully identical because CUBPACK uses another
! integration rule and error estimator for a triangle.
!
MODULE Integrand
IMPLICIT NONE
PUBLIC :: F, INIT
PRIVATE
INTEGER, PRIVATE :: Fnr
CONTAINS
FUNCTION F(NUMFUN,X) RESULT(Value)
USE Precision_Model
INTEGER, INTENT(IN) :: NUMFUN
REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: X
REAL(kind=stnd), DIMENSION(NUMFUN) :: Value
INTEGER, DIMENSION(1:10), PARAMETER :: &
P = (/ 1,0,1,1,0,0,1,1,1,1 /), &
Q = (/ 0,0,0,0,0,0,1,1,1,0 /), &
R = (/ 0,1,0,0,1,1,0,1,0,1 /)
REAL(kind=stnd), DIMENSION(1:10), PARAMETER :: &
A=(/0.0_stnd,0.0_stnd,0.5_stnd,1.0/3.0_stnd,0.0_stnd,0.0_stnd,1.0_stnd,0.0_stnd,0.5_stnd,0.0_stnd /), &
B = 0, &
C = (/0.0_stnd,1.0_stnd,0.0_stnd,0.0_stnd,0.5_stnd,1.0/3.0_stnd,0.0_stnd,0.0_stnd,0.0_stnd,1.0/3.0_stnd/)
SELECT CASE (Fnr)
CASE (1:10)
Value(1) = p(Fnr)*sqrt(abs(x(1)-a(Fnr)))+q(Fnr)*sqrt(abs(x(2)-b(Fnr))) &
+ r(Fnr)*sqrt(abs(x(1)+x(2)-c(Fnr)))
CASE(11)
Value(1) = log(x(1)+x(2))
CASE (12)
Value(1) = 1/sqrt(x(1)*x(1)+x(2)*x(2))
CASE (13)
Value(1) = log(sqrt(x(1)*x(1)+x(2)*x(2)))/sqrt(x(1)*x(1)+x(2)*x(2))
CASE (14)
Value(1) = sin(x(1)) * cos(5*x(2))
CASE (15)
! I guess there is a typo in the triex paper and t must be 1.
Value(1) = sin(11*x(1)) * cos(x(2))
CASE (16)
Value(1) = x(1)**(-0.2_stnd)*9.0_stnd/6.25_stnd
CASE (17)
Value(1) = 1.0_stnd/sqrt(x(1)) + 1.0_stnd/sqrt(x(2)) &
+ 1.0_stnd/sqrt(x(1) + x(2))
Value(1) = Value(1)*3.0_stnd/10.0_stnd
CASE (18)
Value(1) = 3.0_stnd/(sqrt(1 - x(1) - x(2))*4.0_stnd)
CASE (19)
Value(1) = (x(1)*x(2))**(-0.2_stnd)/0.9481026454955768_stnd
CASE (20)
Value(1) = -2.0_stnd * log(x(1)*x(2))/ 3.0_stnd
CASE (21)
Value(1) = (1.0_stnd/sqrt(abs(x(1)-0.25_stnd)) + &
1.0_stnd/sqrt(abs(x(2) - 0.5_stnd)))/3.11357229949_stnd
END SELECT
RETURN
END FUNCTION F
SUBROUTINE INIT (invoer)
INTEGER, INTENT(IN) :: invoer
Fnr = invoer
RETURN
END SUBROUTINE INIT
END MODULE Integrand
! ---- Now follows the main program ---
PROGRAM Example_Triex
USE Precision_Model
USE CUI ! Cubpack User Interface
USE Integrand
IMPLICIT NONE
INTEGER, PARAMETER :: n=2, & ! the dimension
m=1, & ! the number of simple regions
l=1, & ! the length of the integrand vector
Triangle = 1, & ! increase readability
Parallelogram = 2
INTEGER, DIMENSION(1:n) :: RgType
INTEGER :: NEval,i
REAL(kind=stnd), DIMENSION(1:n,0:n,1:m) :: Vertices
REAL(kind=stnd), DIMENSION(1:l) :: IntegralValue, AbsErr
REAL(kind=stnd) :: epsrel
RgType(1) = Triangle
Vertices(1:n,0,1) = (/0 , 0 /)
Vertices(1:n,1,1) = (/1 , 0 /)
Vertices(1:n,2,1) = (/0 , 1 /)
epsrel = 1.0e-6_stnd
do i = 1,21
WRITE(unit=*,fmt=*)
WRITE(unit=*,fmt=*) "Testfunction ",i
CALL INIT(i)
WRITE(unit=*,fmt=*) "CUBATR will now be called with epsrel = ",real(epsrel)
CALL CUBATR(n,l,F,m,Vertices(:,:,1:m),RgType,IntegralValue, &
AbsErr,Epsrel=epsrel,NEval=NEval,JOB=2,MaxPts=100000)
WRITE(unit=*,fmt=*) "Integral = ",IntegralValue
WRITE(unit=*,fmt=*) "with estimated error < ",real(AbsErr)
WRITE(unit=*,fmt=*) "The number of integrand evaluations used = ",NEval
CALL CUBATR()
end do
STOP
END PROGRAM Example_Triex
SHAR_EOF
fi # end of overwriting check
if test -f 'ex_triex.out'
then
echo shar: will not over-write existing file "'ex_triex.out'"
else
cat << "SHAR_EOF" > 'ex_triex.out'
Testfunction 1
CUBATR will now be called with epsrel = 1.0000000E-06
Integral = 0.2666666176679433
with estimated error < 2.3370785E-07
The number of integrand evaluations used = 1665
Testfunction 2
CUBATR will now be called with epsrel = 1.0000000E-06
Integral = 0.2666666176679433
with estimated error < 2.3370785E-07
The number of integrand evaluations used = 1665
Testfunction 3
CUBATR will now be called with epsrel = 1.0000000E-06
Integral = 0.2357022998775372
with estimated error < 5.8716449E-08
The number of integrand evaluations used = 4181
Testfunction 4
CUBATR will now be called with epsrel = 1.0000000E-06
Integral = 0.2079633504260309
with estimated error < 4.4174242E-10
The number of integrand evaluations used = 12469
Testfunction 5
CUBATR will now be called with epsrel = 1.0000000E-06
Integral = 0.2357022998775372
with estimated error < 5.8716449E-08
The number of integrand evaluations used = 4181
Testfunction 6
CUBATR will now be called with epsrel = 1.0000000E-06
Integral = 0.2832240788968500
with estimated error < 4.4854476E-10
The number of integrand evaluations used = 12617
Testfunction 7
CUBATR will now be called with epsrel = 1.0000000E-06
Integral = 0.6666666666666838
with estimated error < 8.2636426E-14
The number of integrand evaluations used = 1665
Testfunction 8
CUBATR will now be called with epsrel = 1.0000000E-06
Integral = 0.9333332848090127
with estimated error < 2.2865441E-07
The number of integrand evaluations used = 2553
Testfunction 9
CUBATR will now be called with epsrel = 1.0000000E-06
Integral = 0.5023689976522531
with estimated error < 1.5647734E-07
The number of integrand evaluations used = 6105
Testfunction 10
CUBATR will now be called with epsrel = 1.0000000E-06
Integral = 0.5498908051048528
with estimated error < 6.5724684E-08
The number of integrand evaluations used = 32005
Testfunction 11
CUBATR will now be called with epsrel = 1.0000000E-06
Integral = -0.2499999999997612
with estimated error < 1.9270631E-12
The number of integrand evaluations used = 481
Testfunction 12
CUBATR will now be called with epsrel = 1.0000000E-06
Integral = 1.2464504802856151
with estimated error < 8.6946741E-08
The number of integrand evaluations used = 1369
Testfunction 13
CUBATR will now be called with epsrel = 1.0000000E-06
Integral = -1.5280234547382086
with estimated error < 2.9076742E-07
The number of integrand evaluations used = 2405
Testfunction 14
CUBATR will now be called with epsrel = 1.0000000E-06
Integral = 4.3052326655855164E-02
with estimated error < 4.1217030E-15
The number of integrand evaluations used = 777
Testfunction 15
CUBATR will now be called with epsrel = 1.0000000E-06
Integral = 8.5468091995326595E-02
with estimated error < 1.5776196E-10
The number of integrand evaluations used = 777
Testfunction 16
CUBATR will now be called with epsrel = 1.0000000E-06
Integral = 0.9999999999997983
with estimated error < 1.6637984E-12
The number of integrand evaluations used = 8473
Testfunction 17
CUBATR will now be called with epsrel = 1.0000000E-06
Integral = 0.9999999999994391
with estimated error < 4.7042812E-12
The number of integrand evaluations used = 15577
Testfunction 18
CUBATR will now be called with epsrel = 1.0000000E-06
Integral = 0.9999999999988229
with estimated error < 8.9261949E-12
The number of integrand evaluations used = 8473
Testfunction 19
CUBATR will now be called with epsrel = 1.0000000E-06
Integral = 0.9999997392694022
with estimated error < 4.2480073E-07
The number of integrand evaluations used = 71077
Testfunction 20
CUBATR will now be called with epsrel = 1.0000000E-06
Integral = 0.9999999999997948
with estimated error < 1.3740056E-12
The number of integrand evaluations used = 15577
Testfunction 21
CUBATR will now be called with epsrel = 1.0000000E-06
Integral = 0.9999999999992429
with estimated error < 5.0617345E-12
The number of integrand evaluations used = 18093
SHAR_EOF
fi # end of overwriting check
if test -f 'simplexpapertest.f90'
then
echo shar: will not over-write existing file "'simplexpapertest.f90'"
else
cat << "SHAR_EOF" > 'simplexpapertest.f90'
! This file contains the full example of the paper
! A. Genz & R. Cools
! An adaptive numerical cubature algorithm for simplices
!
MODULE INTEGRAND
USE PRECISION_MODEL
IMPLICIT NONE
PRIVATE
PUBLIC :: F
CONTAINS
FUNCTION F( L, X ) RESULT(FUN)
INTEGER, INTENT(IN) :: L
REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: X
REAL(kind=stnd), DIMENSION(0:L-1) :: FUN
!
REAL(kind=stnd) :: S
INTEGER :: I
INTEGER, PARAMETER :: N = 5
S = 0
DO I = 1, N
S = S + ( I*X(I) )**2
END DO
FUN(0) = EXP(-S)
FUN(1:N) = X(1:N)*FUN(0)
END FUNCTION F
!
END MODULE INTEGRAND
!
PROGRAM Simplex_Example
USE Precision_Model
USE CUI ! Cubpack User Interface
USE INTEGRAND
INTEGER, PARAMETER :: n = 5, & ! the dimension
nf = n + 1 ! number of integrand functions
INTEGER :: NEval, i, Inform
REAL(kind=stnd), DIMENSION(n,0:n,1) :: Simplex
REAL(kind=stnd), DIMENSION(n,0:n,2) :: TwoSimplices
REAL(kind=stnd), DIMENSION(0:n) :: Value, AbsErr
Inform = -1 ! Soft noisy errors
Simplex = 0 ! Build the unit simplex
DO i = 1, n
Simplex(i,i,1) = 1
END DO
TwoSimplices(:,:,1:1) = Simplex ! Split it into 2 parts.
TwoSimplices(1,0,1) = 0.5_stnd ! Therefore one has to change one
TwoSimplices(:,:,2:2) = Simplex ! coordinate of the unit simplex.
TwoSimplices(1,1,2) = 0.5_stnd
! The two subregions | are simplices | |
! v v v
CALL CUBATR( n, nf, F, 2, TwoSimplices, (/1,1/), Value, AbsErr, &
Inform, NEval, EpsRel=5.0e-4_stnd, MaxPts=200000 )
Print "(""Expected values are "" /5F12.8)", Value(1:n)/Value(0)
Print "(""with estimated errors < ""/5F12.8)", AbsErr(1:n)/Value(0)
Print *,"The number of integrand evaluations used was ", NEval
Inform = -1 ! Soft noisy errors
! The single region | is a simplex |
! v v
CALL CUBATR( n, nf, F, 1, Simplex, (/1/), Value, AbsErr, &
Inform, NEval, EpsRel=5.0e-4_stnd, MaxPts=200000 )
Print "(""Expected values are "" /5F12.8)", Value(1:n)/Value(0)
Print "(""with estimated errors < ""/5F12.8)", AbsErr(1:n)/Value(0)
Print *,"The number of integrand evaluations used was ", NEval
END PROGRAM Simplex_Example
SHAR_EOF
fi # end of overwriting check
if test -f 'simplexpapertest.out'
then
echo shar: will not over-write existing file "'simplexpapertest.out'"
else
cat << "SHAR_EOF" > 'simplexpapertest.out'
Expected values are
0.22419120 0.17813751 0.14013325 0.11372875 0.09523524
with estimated errors <
0.00009069 0.00006152 0.00006977 0.00005160 0.00004529
The number of integrand evaluations used was 178627
Expected values are
0.22419087 0.17813878 0.14013454 0.11372938 0.09523551
with estimated errors <
0.00006262 0.00006472 0.00006016 0.00005668 0.00004474
The number of integrand evaluations used was 76735
SHAR_EOF
fi # end of overwriting check
cd ..
if test ! -d 'Src'
then
mkdir 'Src'
fi
cd 'Src'
if test -f 'Makefile'
then
echo shar: will not over-write existing file "'Makefile'"
else
cat << "SHAR_EOF" > 'Makefile'
# Suffix for Fortran 90 programs
.SUFFIXES:
.SUFFIXES : .f90 $(SUFFIXES)
#-----------------------------------------------------------------------
# The following are platform dependent
# Name of Fortran 90 (or 95) compiler
FC = f95
# Select your compiler flags
CFLAGS = -ieee=full -nan -C=all -gline
#CFLAGS = -nan -gline
#CFLAGS = -fast
# Suffix for Modules (created by the Fortran compiler)
MSUFF = mod
AR= ar
#-----------------------------------------------------------------------
.f90.o:
$(FC) -c $(CFLAGS) $<
#-----------------------------------------------------------------------
OBJS1= internal_types.o ds_routines.o divide.o \
rule_tn.o rule_t3.o rule_t2.o rule_c2.o rule_c3.o rule_cn.o \
rule_general.o rule_1.o region_processor.o volume.o \
check.o global_all.o error_handling.o
OBJS2=buckley.o cui.o
MOD1= internal_types.$(MSUFF) ds_routines.$(MSUFF) divide.$(MSUFF) \
rule_t3.$(MSUFF) rule_t2.$(MSUFF) rule_c2.$(MSUFF) rule_c3.$(MSUFF) \
rule_general.$(MSUFF) rule_1.$(MSUFF) region_processor.$(MSUFF) volume.$(MSUFF) \
check.$(MSUFF) global_all.$(MSUFF) error_handling.$(MSUFF)
SRC=cui.f90 check.f90 global_all.f90 error_handling.f90 \
buckley.f90 internal_types.f90 ds_routines.f90 divide.f90 \
rule_tn.f90 rule_t3.f90 rule_t2.f90 rule_c2.f90 rule_c3.f90 rule_cn.f90 \
rule_general.f90 rule_1.f90 region_processor.f90 volume.f90
#-----------------------------------------------------------------------
all: libcubpack.a
#-----------------------------------------------------------------------
# dependencies
rule_1.o: buckley.o
rule_c2.o: buckley.o
rule_t2.o: buckley.o
rule_c3.o: buckley.o
rule_t3.o: buckley.o
rule_tn.o: buckley.o
rule_cn.o: buckley.o
volume.o: buckley.o
divide.o: buckley.o internal_types.o
rule_general.o: rule_t3.o rule_t2.o rule_c2.o rule_c3.o rule_1.o \
internal_types.o
region_processor.o : divide.o rule_general.o
global_all.o: region_processor.o volume.o ds_routines.o internal_types.o
cui.o: global_all.o check.o error_handling.o ds_routines.o internal_types.o
internal_types.o: buckley.o
#-----------------------------------------------------------------------
libcubpack.a: $(OBJS1) $(OBJS2)
$(AR) rvu libcubpack.a $(OBJS1) $(OBJS2)
veryclean:
/bin/rm -f $(OBJS1) $(OBJS2) *.$(MSUFF) libcubpack.a
clean:
/bin/rm -f $(OBJS1)
SHAR_EOF
fi # end of overwriting check
if test -f 'buckley.f90'
then
echo shar: will not over-write existing file "'buckley.f90'"
else
cat << "SHAR_EOF" > 'buckley.f90'
! This file is F-compatible, except for upper/lower case conventions.
!--------------------------------------------------------------------
MODULE Extended ! precision specification for real computations
! This requests the processor to use a real implementation 'stnd'
! which provides at least 20 decimal digits of precision and an
! exponent range of at least 10 ^ +- 80. It is expected that this
! precision may not be available on all machines.
! In July 2002, we found this available on
! SUN (Solaris) with f95
! IBM (AIX) with xlf90
! DEC alpha with f90
IMPLICIT NONE
Integer, PUBLIC, PARAMETER :: stnd = Selected_Real_Kind ( 20, 80 )
!-------------------------
! A few computations are preferably done in higher precision 'extd'. The
! numbers chosen here should be such that the underlying hardware will
! select a higher precision for kind 'extd' than for kind 'stnd', if
! this is feasible. If a higher precision is not readily available,
! the same values may be used as are given above for 'stnd'. It is
! anticipated that on many machines, such an even higher precision may
! not be available.
Integer, PUBLIC, PARAMETER :: extd = Selected_Real_Kind ( 30, 80 )
!-------------------------
end Module Extended
MODULE Integers ! precision specification for integer computations
! This is provided for those machines where using short integers
! has some advantage. The range here is from -999 to +999. Note that
! 999 = 10^3 -1. No harm will be done if short integers are made
! the same as long integers.
IMPLICIT NONE
Integer, PUBLIC, PARAMETER :: short = Selected_Int_Kind ( 3 )
!-------------------------
! The range here is at least from -9 999 999 to +9 999 999. Note
! that 10^7 - 1 = 9,999,999. This may limit the largest possible value
! of the dimension n of problems which can be solved. If n is to
! be larger, the 7 should be replaced with a number k so that
! n is considerably less than 10^k.
Integer, PUBLIC, PARAMETER :: long = Selected_Int_Kind ( 7 )
!-------------------------
end Module Integers
MODULE Low ! precision specification for real computations
! This requests the processor to use a real implementation 'stnd'
! which provides at least 6 decimal digits of precision and an
! exponent range of at least 10 ^ +- 35. This would be suitable for
! low accuracy computations. It is expected that this precision will
! be available on all machines.
IMPLICIT NONE
Integer, PUBLIC, PARAMETER :: stnd = Selected_Real_Kind ( 6, 35 )
!-------------------------
! A few computations are preferably done in higher precision 'extd'. The
! numbers chosen here should be such that the underlying hardware will
! select a higher precision for kind 'extd' than for kind 'stnd', if
! this is feasible. If a higher precision is not readily available,
! the same values may be used as are given above for 'stnd'. It is
! anticipated that on most machines this higher precision will also
! be available.
Integer, PUBLIC, PARAMETER :: extd = Selected_Real_Kind ( 12, 35 )
!-------------------------
end Module Low
MODULE Normal ! precision specification for real computations
! This requests the processor to use a real implementation 'stnd'
! which provides at least 12 decimal digits of precision and an
! exponent range of at least 10 ^ +- 50. It is expected that this
! precision will be available on all machines.
IMPLICIT NONE
Integer, PUBLIC, PARAMETER :: stnd = Selected_Real_Kind ( 12, 50 )
!-------------------------
! A few computations are preferably done in higher precision 'extd'. The
! numbers chosen here should be such that the underlying hardware will
! select a higher precision for kind 'extd' than for kind 'stnd', if
! this is feasible. If a higher precision is not readily available,
! the same values may be used as are given above for 'stnd'. It is
! anticipated that on many machines this higher precision may
! not be available.
!Integer, PUBLIC, PARAMETER :: extd = Selected_Real_Kind ( 20, 50 ) ! preferred
Integer, PUBLIC, PARAMETER :: extd = Selected_Real_Kind ( 12, 50 ) ! NAG f95
!-------------------------
end Module Normal
MODULE Precision_Model
! This provides a convenient way of selecting the precision
! required for a computation. By simply ensuring that a leading '!'
! appears on all but exactly one of the following USE statements,
! and then recompiling all routines, the precision of an entire
! computation can be altered.
! USE Low
USE Normal
! USE Extended
USE Integers
! This is the original F90 code
! PRIVATE
! PUBLIC :: stnd, extd, short, long
! This is the F code
PUBLIC
end Module Precision_Model
SHAR_EOF
fi # end of overwriting check
if test -f 'check.f90'
then
echo shar: will not over-write existing file "'check.f90'"
else
cat << "SHAR_EOF" > 'check.f90'
! This file is F-compatible, except for upper/lower case conventions.
!--------------------------------------------------------------------
Module Check_Input
USE Precision_Model, ONLY: stnd
USE internal_types
Implicit NONE
PRIVATE
PUBLIC :: CHECK
PRIVATE :: CHECK_RESTART, CHECK_NORESTART
INTERFACE CHECK
MODULE PROCEDURE CHECK_RESTART, CHECK_NORESTART
END INTERFACE
CONTAINS
SUBROUTINE CHECK_RESTART(DIMENS,NUMFUN,BOTTRH,BOTTIH,&
ISTORE,INFORM,JOB,IFAIL,EPSABS,EPSREL, &
MINPTS,MAXPTS,TUNE)
!***BEGIN PROLOGUE CHECK_RESTART
!***REVISION DATE 950503 (YYMMDD)
!***REVISION DATE 980407 (YYMMDD)
!***REVISION DATE 990531 (YYMMDD)
!***REVISION DATE 990624 (YYMMDD)
!***REVISION DATE 010719 (YYMMDD)
!***AUTHOR
! Ronald Cools, Dept. of Computer Science,
! Katholieke Universiteit Leuven, Celestijnenlaan 200A,
! B-3001 Heverlee, Belgium
! Email: Ronald.Cools@cs.kuleuven.ac.be
!***PURPOSE CHECK_RESTART checks the validity of the
! input parameters to CUBATR on restart.
!***DESCRIPTION
!
!
! ON ENTRY
!
! DIMENS Integer.
! Number of variables.
! NUMFUN Integer.
! Number of components of the integral.
! NUMRGN Integer.
! NUMRGN should contain the initial number of regions.
! MINPTS Integer.
! Minimum number of FUNSUB calls.
! MAXPTS Integer.
! Maximum number of FUNSUB calls.
! TUNE Real.
! Requested reliability.
! JOB Integer.
! Describes what algorithm CUBATR must use.
! EPSABS Real.
! Requested absolute accuracy.
! EPSREL Real.
! Requested relative accuracy.
! BOTTRH Integer.
! Defines the length of the real array containing
! the region collection.
! BOTTIH Integer.
! Defines the length of the integer array containing
! the region collection.
! RGTYPE Integer array of dimension (NUMRGN).
! RGTYPE(L) describes the type of region L.
!
! ON RETURN
!
! IFAIL Integer.
! If IFAIL has an illegal value on entry, it is reset to 0.
!
! INFORM Integer.
! INFORM = 0 for normal exit.
! INFORM = 8 if DIMENS <= 1 ( RESTART = FALSE )
! DIMENS used inconsistently ( RESTAR = TRUE ).
! INFORM = 16 if NUMFUN < 1. ( RESTART = FALSE )
! NUMFUN used inconsistently ( RESTART = TRUE ).
! INFORM = 32 if NUMRGN < 1. ( RESTART = FALSE )
! BOTTIH used inconsistently ( RESTART = TRUE ).
! INFORM = 64 if there is no support for this region (RESTART = FALSE )
! BOTTRH used inconsistently ( RESTART = TRUE ).
! INFORM = 128 if ISTORE is strangely small (RESTART = TRUE)
! INFORM = 256 if MAXPTS <1 or MINPTS > MAXPTS.
! INFORM = 512 if TUNE > 1 OR TUNE < 0.
! INFORM = 1024 if EPSABS < 0 or EPSREL < 0
! INFORM = 2048 if IFAIL not in {-1,0,1}
! INFORM = 4096 if ABS(JOB) not in {0,1,2,11,12}
! If more than one input parameter is wrong,
! then INFORM is set to the sum of the values mentioned above.
! If errors occured during a restart, INFORM = INFORM + 8192.
!
!***END PROLOGUE CHECK_RESTART
!
! Global variables.
!
INTEGER, INTENT(IN) :: DIMENS,NUMFUN,BOTTRH,BOTTIH,JOB
INTEGER, INTENT(OUT) :: INFORM
INTEGER, DIMENSION(:), INTENT(IN) :: ISTORE
INTEGER, OPTIONAL, INTENT(IN OUT) :: IFAIL
INTEGER, OPTIONAL, INTENT(IN) :: MINPTS,MAXPTS
REAL(kind=stnd), OPTIONAL, INTENT(IN) :: EPSABS,EPSREL,TUNE
!
!***FIRST EXECUTABLE STATEMENT CHECK_RESTART
!
INFORM = 0
IF ( SIZE(ISTORE) <= 15) THEN
INFORM = 128
ELSE
! We assume that istore is present and that BOTTIH and
! BORTRH have the right values.
!
! Check valid DIMENS.
!
IF (DIMENS /= ISTORE(1)) THEN
INFORM = 8
END IF
!
! Check positive NUMFUN.
!
IF (NUMFUN /= ISTORE(5)) THEN
INFORM = INFORM + 16
END IF
!
! Check workspace.
!
IF ((BOTTIH /= ISTORE(7)) .OR. (SIZE(ISTORE) /= BOTTIH)) THEN
INFORM = INFORM + 32
END IF
IF (BOTTRH /= ISTORE(8)) THEN
INFORM = INFORM + 64
END IF
END IF
IF (INFORM /= 0) THEN
INFORM = INFORM + 8192
END IF
!
! Check valid limits on allowed number of function evaluations.
!
IF (PRESENT(MAXPTS)) THEN
IF (PRESENT(MINPTS)) THEN
IF (MINPTS > MAXPTS) THEN
INFORM = INFORM + 256
END IF
ELSE
IF (MAXPTS < 1) THEN
INFORM = INFORM + 256
END IF
END IF
END IF
!
! Check valid requested reliablitiy.
!
IF (PRESENT(TUNE)) THEN
IF ((TUNE < 0) .OR. (TUNE > 1)) THEN
INFORM = INFORM + 512
END IF
END IF
!
! Check valid accuracy requests.
!
IF (PRESENT(EPSABS)) THEN
IF (EPSABS < 0) THEN
INFORM = INFORM + 1024
END IF
ELSE IF (PRESENT(EPSREL)) THEN
IF (EPSREL < 0) THEN
INFORM = INFORM + 1024
END IF
END IF
!
! Check valid IFAIL
!
IF (PRESENT(IFAIL)) THEN
IF ((IFAIL < -1) .OR. (IFAIL > 1)) THEN
INFORM = INFORM + 2048
IFAIL = 0
END IF
END IF
!
! Check valid JOB. JOB = 0 cannot occur at this stage
!
IF ((ABS(JOB) /= 1) .AND. (ABS(JOB) /= 2) .AND. (ABS(JOB) /= 11) .AND. (ABS(JOB) /= 12)) THEN
INFORM = INFORM + 4096
END IF
!
RETURN
END SUBROUTINE CHECK_RESTART
SUBROUTINE CHECK_NORESTART(DIMENS,NUMFUN,NUMRGN,RGTYPE, &
INFORM,JOB,IFAIL,EPSABS,EPSREL, &
MINPTS,MAXPTS,TUNE)
!***BEGIN PROLOGUE CHECK_NORESTART
!***REVISION DATE 950503 (YYMMDD)
!***REVISION DATE 980407 (YYMMDD)
!***REVISION DATE 990531 (YYMMDD)
!***AUTHOR
! Ronald Cools, Dept. of Computer Science,
! Katholieke Universiteit Leuven, Celestijnenlaan 200A,
! B-3001 Heverlee, Belgium
! Email: Ronald.Cools@cs.kuleuven.ac.be
!***PURPOSE CHECK_NORESTART checks the validity of the
! input parameters to CUBATR.
!***DESCRIPTION
!
!
! ON ENTRY
!
! DIMENS Integer.
! Number of variables.
! NUMFUN Integer.
! Number of components of the integral.
! NUMRGN Integer.
! NUMRGN should contain the initial number of regions.
! MINPTS Integer.
! Minimum number of FUNSUB calls.
! MAXPTS Integer.
! Maximum number of FUNSUB calls.
! TUNE Real.
! Requested reliability.
! JOB Integer.
! Describes what algorithm CUBATR must use.
! EPSABS Real.
! Requested absolute accuracy.
! EPSREL Real.
! Requested relative accuracy.
! BOTTRH Integer.
! Defines the length of the real array containing
! the region collection.
! BOTTIH Integer.
! Defines the length of the integer array containing
! the region collection.
! RGTYPE Integer array of dimension (NUMRGN).
! RGTYPE(L) describes the type of region L.
!
! ON RETURN
!
! IFAIL Integer.
! If IFAIL has an illegal value on entry, it is reset to 0.
!
! INFORM Integer.
! INFORM = 0 for normal exit.
! INFORM = 8 if DIMENS <= 1 ( RESTART = FALSE )
! DIMENS used inconsistently ( RESTAR = TRUE ).
! INFORM = 16 if NUMFUN < 1. ( RESTART = FALSE )
! NUMFUN used inconsistently ( RESTART = TRUE ).
! INFORM = 32 if NUMRGN < 1. ( RESTART = FALSE )
! BOTTIH used inconsistently ( RESTART = TRUE ).
! INFORM = 64 if there is no support for this region (RESTART = FALSE )
! BOTTRH used inconsistently ( RESTART = TRUE ).
! INFORM = 128 if JOB={2,11} and DIMENS > 3
! INFORM = 256 if MAXPTS <1 or MINPTS > MAXPTS.
! INFORM = 512 if TUNE > 1 OR TUNE < 0.
! INFORM = 1024 if EPSABS < 0 or EPSREL < 0
! INFORM = 2048 if IFAIL not in {-1,0,1}
! INFORM = 4096 if ABS(JOB) not in {0,1,2,11,12}
! If more than one input parameter is wrong,
! then INFORM is set to the sum of the values mentioned above.
! If errors occured during a restart, INFORM = INFORM + 8192.
!
!***END PROLOGUE CHECK_NORESTART
!
! Global variables.
!
INTEGER, INTENT(IN) :: DIMENS,NUMFUN,NUMRGN,JOB
INTEGER, INTENT(OUT) :: INFORM
INTEGER, DIMENSION(:), INTENT(IN) :: RGTYPE
INTEGER, OPTIONAL, INTENT(IN OUT) :: IFAIL
INTEGER, OPTIONAL, INTENT(IN) :: MINPTS,MAXPTS
REAL(kind=stnd), OPTIONAL, INTENT(IN) :: EPSABS,EPSREL,TUNE
!
! Local variables
!
INTEGER :: I
!
!***FIRST EXECUTABLE STATEMENT CHECK_NORESTART
!
INFORM = 0
!
! Check valid DIMENS.
!
IF (DIMENS <= 0) THEN
INFORM = 8
END IF
!
! Check positive NUMFUN.
!
IF (NUMFUN < 1) THEN
INFORM = INFORM + 16
END IF
!
! Check valid NUMRGN.
!
IF (NUMRGN <= 0) THEN
INFORM = INFORM + 32
END IF
!
! Check valid region type
!
DO I = 1,NUMRGN
IF ((RGTYPE(I) /= Simplex) .and. (RGTYPE(I) /= Hyperrectangle)) THEN
INFORM = INFORM + 64
EXIT
END IF
END DO
!
! Check if DIMENS and JOB or in agreement for special values of JOB
!
IF ( ((JOB == 2) .OR. (JOB == 11)) .AND. (DIMENS > 3)) THEN
INFORM = INFORM + 128
END IF
!
! Check valid limits on allowed number of function evaluations.
!
IF (PRESENT(MAXPTS)) THEN
IF (PRESENT(MINPTS)) THEN
IF (MINPTS > MAXPTS) THEN
INFORM = INFORM + 256
END IF
ELSE
IF (MAXPTS < 1) THEN
INFORM = INFORM + 256
END IF
END IF
END IF
!
! Check valid requested reliablitiy.
!
IF (PRESENT(TUNE)) THEN
IF ((TUNE < 0) .OR. (TUNE > 1)) THEN
INFORM = INFORM + 512
END IF
END IF
!
! Check valid accuracy requests.
!
IF (PRESENT(EPSABS)) THEN
IF (EPSABS < 0) THEN
INFORM = INFORM + 1024
END IF
ELSE IF (PRESENT(EPSREL)) THEN
IF (EPSREL < 0) THEN
INFORM = INFORM + 1024
END IF
END IF
!
! Check valid IFAIL
!
IF (PRESENT(IFAIL)) THEN
IF ((IFAIL < -1) .OR. (IFAIL > 1)) THEN
INFORM = INFORM + 2048
IFAIL = 0
END IF
END IF
!
! Check valid JOB. JOB = 0 cannot occur at this stage
!
IF ((ABS(JOB) /= 1) .AND. (ABS(JOB) /= 2) .AND. (ABS(JOB) /= 11) .AND. (ABS(JOB) /= 12)) THEN
INFORM = INFORM + 4096
END IF
!
RETURN
END SUBROUTINE CHECK_NORESTART
END MODULE Check_Input
SHAR_EOF
fi # end of overwriting check
if test -f 'cui.f90'
then
echo shar: will not over-write existing file "'cui.f90'"
else
cat << "SHAR_EOF" > 'cui.f90'
!------------------------!
! Cubpack User Interface !
!------------------------!
Module CUI
USE Precision_Model
USE internal_types
Implicit NONE
PRIVATE
PUBLIC :: CUBATR, CUBPACK_INFO
!-----------------------------------------------------------------------
!***BEGIN PROLOGUE CUBATR
!***DATE WRITTEN 901114 (YYMMDD)
!***REVISION DATE 970620 (YYMMDD)
!***REVISION DATE 980406 (YYMMDD) (MDIV removed)
!***REVISION DATE 000809 (YYMMDD)
!***REVISION DATE 010719 (YYMMDD)
!***REVISION DATE 020715 (YYMMDD) (CUBPACK_INFO added)
!***AUTHOR
! Ronald Cools, Dept. of Computer Science,
! Katholieke Universiteit Leuven, Celestijnenlaan 200A,
! B-3001 Heverlee, Belgium
! Email: Ronald.Cools@cs.kuleuven.ac.be
!
!***PURPOSE Computation of integrals over a collection of regions.
!
!***DESCRIPTION
! CUBATR is the driver routine for CUBPACK and the only
! routine that a user has to deal with (at the moment).
!
!-----------------------------------------------------------------------
PRIVATE :: CUBATR_X, CUBATR_1, CUBATR_CLEAR
!
! Module variables
!
INTEGER, SAVE, PRIVATE :: PreJob=0
INTEGER, PRIVATE :: BOTTIH,BOTTRH
INTEGER, DIMENSION(:), PRIVATE, ALLOCATABLE :: IWork
REAL(kind=stnd), DIMENSION(:), PRIVATE, ALLOCATABLE :: RWork
TYPE(EPSALG_MEM), PRIVATE :: M
INTERFACE CUBATR
MODULE PROCEDURE CUBATR_X, CUBATR_1, CUBATR_CLEAR
END INTERFACE
CONTAINS
SUBROUTINE CUBATR_X &
(DIMENS,NumFun,Integrand,NumRgn,Vertices,RgType,Value,AbsErr, &
! and optional parameters
IFAIL,Neval,EpsAbs,EpsRel,Restart,MinPts,MaxPts,Key,Job,Tune)
!-----------------------------------------------------------------------
! Input parameters
! ----------------
!
! DIMENS Integer.
! The dimension of the region of integration.
!
! NumFun Integer.
! Number of components of the integrand.
!
! Integrand
! Externally declared function for computing all components
! of the integrand at the given evaluation point.
! It must have input parameter X:
! X(1) The x-coordinate of the evaluation point.
! X(2) The y-coordinate of the evaluation point.
! ...
! X(DIMENS) The z-coordinate of the evaluation point.
! and NumFun, the number of components of the integrand.
! It must be compatible with the following interface:
! INTERFACE
! FUNCTION Integrand(NUMFUN,X) RESULT(Value)
! USE Precision_Model
! INTEGER, INTENT(IN) :: NUMFUN
! REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: X
! REAL(kind=stnd), DIMENSION(NUMFUN) :: Value
! END FUNCTION Integrand
! END INTERFACE
!
! NumRgn Integer.
! The number of given regions.
!
! Vertices
! Real array of dimension (DIMENS,DIMENS+1,NumRgn).
! Vertices(1:DIMENS,K,L) are the x, y, ... coordinates
! respectively of vertex K of region L, where
! K = 1,...,DIMENS+1 and L = 1,...,NumRgn.
!
! RgType Integer array of dimension (NumRgn).
! RgType(L) describes the type of region L.
!
! Value Real array of dimension NumFun.
! Approximations to all components of the integral if
! the procedure is restarted.
!
! AbsErr Real array of dimension NumFun.
! Estimates of absolute errors if the procedure is restarted.
!
! IFAIL Optional integer argument.
! This follows the NAG convention:
! IFAIL = 1 : soft silent error
! Control returned to calling program.
! IFAIL = -1: soft noisy error
! Error message is printed.
! Control returned to calling program.
! IFAIL = 0 : hard noisy error
! Error message is printed and program is stopped.
! Default IFAIL = -1.
!
! EpsAbs Optional real argument.
! Requested absolute error.
! Default EpsAbs = 0.
!
! EpsRel Optional real argument.
! Requested relative error.
! Default EpsRel = sqrt(machine precision).
!
! Restart Optional boolean argument.
! If Restart = FALSE, this is the first attempt to compute
! the integral.
! If Restart = TRUE, then we restart a previous attempt.
! In this case the only parameters for CUBATR that may
! be changed (with respect to the previous call of CUBATR)
! are MinPts, MaxPts, EpsAbs, EpsRel, Key and Restart.
! Default Restart = FALSE.
!
! MinPts Optional integer argument.
! The minimum allowed number of integrand evaluations.
! Default MinPts = 0.
!
! MaxPts Optional integer argument.
! The maximum allowed number of integrand evaluations.
! Default MaxPts = enough to do 500 subdivisions.
!
! Key Optional integer argument.
! Can be used by Rule_General to choose between several
! local integration rules.
! Default Key = 2 if Dimension=1 and extrapolation is used
! (This corresponds to QAGS)
! Default Key = 0 otherwise
!
! Job Optional integer argument.
! If |Job| = 0, then nothing will be done except freeing all
! allocated memory.
! This is usefull after a call of CUBATR if no
! Restart will be done later and memory usage
! might become an issue later.
! Equivalently, one can call CUBATR()
! without any arguments.
! = 1, the global adaptive algorithm is called
! = 2, extrapolation using the epsilon algorithm is used.
! = 11, a region will be divided in 2**DIMENS subregions
! and the global adaptive algorithm is called.
! In combination with Key=0, this resembles DUCTRI and DCUTET.
! = 12, a region will be divided in 2 subregions
! and the global adaptive algorithm is called.
! In combination with Key=3 or 4, this resembles DCUHRE.
! If Job < 0, then an overview of the Region Collection is dumped.
! This will create the files tmp_integerstore and tmp_realstore.
! Default Job = 1.
!
! Tune Optional real argument.
! Can be used by Global_Adapt or the local error estimators
! to influence the reliability. 0 <= Tune <= 1.
! Tune = 1 is the most reliable available.
! Default Tune = 1.
! Note that this is an experimental and controversial parameter.
! In this version, only Tune = 1 is supported for all regions.
!
! Output parameters
! -----------------
!
! Value Real array of dimension NumFun.
! Approximations to all components of the integral
!
! AbsErr Real array of dimension NumFun.
! Estimates of absolute errors.
!
! NEval Optional Integer.
! Number of integrand evaluations used by CUBATR for this call.
!
! IFAIL Optional Integer.
! IFAIL = 0 for normal exit.
!
! AbsErr(K) <= EpsAbs or
! AbsErr(K) <= ABS(Value(K))*EpsRel with MaxPts or less
! function evaluations for all values of K,
! 1 <= K <= NumFun .
!
! IFAIL = 1 if MaxPts was too small to obtain the required
! accuracy. In this case Global_Adapt returns values of
! Value with estimated absolute errors AbsErr.
!
! IFAIL > 1 in more serious case of trouble.
!-----------------------------------------------------------------------
! MODULES USED
USE Check_Input
USE Error_Handling
USE DS_ROUTINES, ONLY: DSCOPY, DSINIT, DSUSED, DSSTAT, DSSUM, DSPINT
USE CubatureRule_General, ONLY: Rule_Cost
USE Global_Adaptive_Algorithm
!***END PROLOGUE CUBATR
!-----------------------------------------------------------------------
!
! Global variables
!
INTERFACE
FUNCTION Integrand(NUMFUN,X) RESULT(Value)
USE Precision_Model
INTEGER, INTENT(IN) :: NUMFUN
REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: X
REAL(kind=stnd), DIMENSION(NUMFUN) :: Value
END FUNCTION Integrand
END INTERFACE
INTEGER, INTENT(IN) :: DIMENS,NumFun,NumRgn
INTEGER, DIMENSION(:), INTENT(IN) :: RgType
LOGICAL, INTENT(IN), OPTIONAL :: Restart
INTEGER, INTENT(OUT), OPTIONAL :: NEval
INTEGER, INTENT(IN), OPTIONAL :: Job,Key,MaxPts,MinPts
INTEGER, INTENT(IN OUT), OPTIONAL :: IFAIL
REAL(kind=stnd), INTENT(IN), OPTIONAL :: Tune,EpsAbs,EpsRel
REAL(kind=stnd), INTENT(IN), DIMENSION(:,:,:) :: Vertices
REAL(kind=stnd), INTENT(IN OUT), DIMENSION(:) :: AbsErr, Value
!
! Named constants
!
INTEGER, PARAMETER :: NRINFO=1, NIINFO=5
!
! Local variables
!
INTEGER :: BLOCK,i,Inform,Leval,LJob,LMaxPts,LMinPts,MinCost, &
NRVERT,NrSub,NRVACA,MAXRGN,RULCLS,STATUS,Tmp
LOGICAL :: EpsAlg,LRestart
REAL(kind=stnd) :: LEpsAbs, LEpsRel
REAL(kind=stnd), DIMENSION(:), ALLOCATABLE :: TmpRWork
INTEGER, DIMENSION(:), ALLOCATABLE :: TmpIWork
TYPE(INTEGRATOR_INFO) :: CINFO
TYPE(USER_INFO) :: UINFO
!-----------------------------------------------------------------------
!
! Check array sizes
! Array size mismatch results in hard error.
Inform = 0
IF (size(rgtype) < numrgn) THEN
write(unit=*,fmt=*) "Error: size(rgtype) < numrgn"
Inform = Inform + 1
END IF
IF (size(abserr) < numfun) THEN
write(unit=*,fmt=*) "Error: size(abserr) < numfun"
Inform = Inform + 1
END IF
IF (size(Value) < numfun) THEN
write(unit=*,fmt=*) "Error: size(Value) < numfun"
Inform = Inform + 1
END IF
IF ((size(vertices,1) /= dimens) .or. (size(vertices,2) /= dimens+1) &
.or. (size(vertices,3) < numrgn)) THEN
Inform = Inform + 1
write(unit=*,fmt=*)"Error: size(vertices) /= (/dimens,dimens+1,numrgn/)"
END IF
IF (Inform /= 0) THEN
WRITE(unit=*,fmt=*) "Array size mismatch results in hard error."
STOP ! "Array size mismatch results in hard error."
END IF
!-----------------------------------------------------------------------
IF (PRESENT(NEval)) THEN
NEval = 0
END IF
!-----------------------------------------------------------------------
IF (PRESENT(Job)) THEN
LJob = Job
IF (Job == 0) THEN
CALL CUBATR_CLEAR()
RETURN
END IF
ELSE
LJob = 1
END IF
!-----------------------------------------------------------------------
!
! Set optional arguments
!
IF ( PRESENT(Restart)) THEN
LRestart = Restart
ELSE
LRestart = .FALSE.
END IF
IF ( PRESENT(Key)) THEN
CINFO%Key = Key
ELSE
IF ((ABS(LJob) == 2) .AND. (DIMENS == 1)) THEN
CINFO%Key = 2 ! simulate QAGS
ELSE
CINFO%Key = 0
END IF
END IF
!-----------------------------------------------------------------------
!
! Check input parameters
!
IF ( .NOT. LRestart) THEN
CALL CHECK(DIMENS,NumFun,NumRgn,RgType,Inform, &
LJob,IFAIL,EpsAbs,EpsRel,MinPts,MaxPts,Tune)
ELSE IF ( ALLOCATED(IWork) ) THEN
CALL CHECK(DIMENS,NumFun,BOTTRH,BOTTIH,IWork, &
Inform,LJob,IFAIL,EpsAbs,EpsRel,MinPts,MaxPts,Tune)
ELSE
Inform = 4096 ! There is nothing to restart from
END IF
IF (Inform /= 0) THEN
CALL Handle_Error(Inform,IFAIL)
RETURN
END IF
!-----------------------------------------------------------------------
RULCLS = Rule_Cost( DIMENS, RgType(1), CINFO%Key )
MinCost = RULCLS
DO i = 2,NumRgn
Tmp = Rule_Cost( DIMENS, RgType(i), CINFO%Key)
RULCLS = max(RULCLS,Tmp)
MinCost = MinCost + Tmp
END DO
!-----------------------------------------------------------------------
!
! Set optional arguments
!
IF ( PRESENT(MinPts)) THEN
LMinPts = MinPts
ELSE
LMinPts = 0
END IF
IF ( PRESENT(MaxPts)) THEN
LMaxPts = MaxPts
ELSE
LMaxPts = 500*RULCLS
END IF
IF ( PRESENT(Tune)) THEN
CINFO%Tune = Tune
ELSE
CINFO%Tune = 1
END IF
IF ( PRESENT(EpsAbs)) THEN
LEpsAbs = EpsAbs
ELSE
LEpsAbs = 0
END IF
IF ( PRESENT(EpsRel)) THEN
LEpsRel = EpsRel
ELSE
LEpsRel = SQRT(EPSILON(LEpsRel))
END IF
!-----------------------------------------------------------------------
!
! Set other parameters of the Global Adaptive algorithm
!
!
! NrSub is an upper limit for the number of subregions after subdivision.
! This influence memory managment, so don't exagerate here.
IF (DIMENS <= 3) THEN
NrSub = 2**DIMENS
ELSE
NrSub = 4
END IF
!
EpsAlg = ( ABS(LJob) == 2 )
CINFO%UNIFORM_SUBDIV = EpsAlg
CINFO%NrSub = NrSub
IF (( ABS(LJob) == 11) .AND. (DIMENS <= 3)) THEN
! simulate dcutri and dcutet ; NrSub = 2**DIMENS ; EpsAlg = .FALSE.
CINFO%UNIFORM_SUBDIV = .TRUE.
END IF
IF ( ABS(LJob) == 12 ) THEN
! simulate dcuhre; NrSub = 2 ; EpsAlg = .FALSE.
CINFO%NrSub = 2
END IF
NRVERT = DIMENS + 1 ! Only cubes and simplices are implemented here.
UINFO%NumFun = NumFun
UINFO%NumRgn = NumRgn
UINFO%MinPts = LMinPts
UINFO%MaxPts = LMaxPts
UINFO%EpsAbs = LEpsAbs
UINFO%EpsRel = LEpsRel
!-----------------------------------------------------------------------
IF (LRestart) THEN
! This requires allocating larger arrays and copying
! the region collection.
ALLOCATE(TmpRWork(SIZE(RWork)),STAT=status)
IF (status /= 0) THEN
WRITE(unit=*,fmt=*) "Problem allocating real workspace."
STOP ! "Problem allocating real workspace."
END IF
ALLOCATE(TmpIWork(SIZE(IWork)),STAT=status)
IF (status /= 0) THEN
WRITE(unit=*,fmt=*) "Problem allocating integer workspace."
STOP ! "Problem allocating integer workspace."
END IF
MAXRGN = DSUSED(IWork)
CALL DSCOPY(IWork,RWork,TmpIWork,TmpRWork)
ELSE
MAXRGN = NumRgn
END IF
!-----------------------------------------------------------------------
! NRVACA is the number of regions the global adaptive algorithm
! removes from the data structure for further processing.
! In some routines for shared memory parallel machines
! this is the variable MDIV
NRVACA = 1
! MAXRGN depends on the number of function evalutions
MAXRGN = MAXRGN + 1 + (NrSub-1)*(LMaxPts - RULCLS*NumRgn)/(RULCLS*NrSub)
!
! Compute length of workspace needed.
!
BOTTIH = MAXRGN*(1+NIINFO) + 15 + NRVACA
BLOCK = NRINFO+NRVERT*DIMENS+2*NumFun
IF (NumFun > 1) THEN
BLOCK = BLOCK + 1
END IF
BOTTRH = MAXRGN*BLOCK
!
! Allocate space for the region collection
!
IF (ALLOCATED(RWork)) THEN
DEALLOCATE(RWork)
END IF
ALLOCATE(RWork(BOTTRH),STAT=status)
IF (status /= 0) THEN
WRITE(unit=*,fmt=*) "Problem allocating real workspace."
STOP ! "Problem allocating real workspace."
END IF
IF (ALLOCATED(IWork)) THEN
DEALLOCATE(IWork)
END IF
ALLOCATE(IWork(BOTTIH),STAT=status)
IF (status /= 0) THEN
WRITE(unit=*,fmt=*) "Problem allocating integer workspace."
STOP ! "Problem allocating integer workspace."
END IF
!
! Initialise region collection
!
IF ( LRestart) THEN
CALL DSCOPY(TmpIWork,TmpRWork,IWork,RWork)
DEALLOCATE(TmpIWork,TmpRWork)
ELSE
IF ( MinCost > LMaxPts ) THEN
Inform = 128 ! Dit nummer werd al gebruikt !
ELSE
CALL DSINIT(DIMENS,NRVERT,NIINFO,NRINFO,NumFun,NRVACA, &
BOTTIH,BOTTRH,IWork,Inform)
END IF
IF (Inform /= 0) THEN
CALL Handle_Error(Inform,IFAIL)
RETURN
END IF
END IF
!-----------------------------------------------------------------------
!
! Call integration routine
!
If (EpsAlg) THEN
IF ( LRestart .AND. (PreJob /= ABS(LJob))) THEN
Inform = 3
ELSE
! Observe that only relevant array sections are passed !
CALL Global_Adapt_Extrap(DIMENS,CINFO,UINFO,NRVERT,NIINFO, &
NRINFO, Vertices(1:DIMENS,1:NRVERT,1:NUMRGN), &
RgType(1:NUMRGN),Integrand,LRestart, &
Value(1:NUMFUN),AbsErr(1:NUMFUN),LEval,Inform, &
RWork,IWork,M)
END IF
ELSE
IF ( LRestart .AND. (PreJob /= LJob)) THEN
IF ( ASSOCIATED(M%RESLA)) THEN
DEALLOCATE(M%RESLA,M%ERLARG,M%RESULT1,M%ABSERR1,M%RCOPY)
END IF
CALL DSPINT(IWork,RWork)
CALL DSSUM(Value,Abserr,IWork,RWork,Inform)
END IF
! Observe that only relevant array sections are passed !
CALL Global_Adapt(DIMENS,CINFO,UINFO,NRVERT,NIINFO,NRINFO, &
Vertices(1:DIMENS,1:NRVERT,1:NUMRGN), &
RgType(1:NUMRGN),Integrand,LRestart, &
Value(1:NUMFUN),AbsErr(1:NUMFUN),LEval,Inform, &
RWork,IWork)
END IF
IF (PRESENT(NEval)) THEN
NEval = LEval
END IF
!-----------------------------------------------------------------------
IF (LJob < 0) THEN
WRITE(unit=*,fmt=*) "Debug mode: dumping region collection overview."
CALL DSSTAT(IWork(:),RWork(:)) ! For debugging.
END IF
!-----------------------------------------------------------------------
! IF ((Inform >= 8) .or. (Inform == 3)) THEN
! Something went wrong but the data structure remains untouched
! and so this call can be ignored.
IF ((Inform < 8) .AND. (Inform /= 3)) THEN
PreJob = ABS(LJob)
END IF
CALL Handle_Error(Inform,IFAIL)
RETURN
END SUBROUTINE CUBATR_X
SUBROUTINE CUBATR_1 &
(DIMENS,Integrand,SVertices,SRgType,SValue,SAbsErr, &
! and optional parameters &
IFAIL,Neval,EpsAbs,EpsRel,Restart,MaxPts,Key,Job)
!-----------------------------------------------------------------------
! Input parameters
! ----------------
!
! DIMENS Integer.
! The dimension of the region of integration.
!
! Integrand
! Externally declared function for computing all components
! of the integrand at the given evaluation point.
! It must have input parameter X:
! X(1) The x-coordinate of the evaluation point.
! X(2) The y-coordinate of the evaluation point.
! ...
! X(DIMENS) The z-coordinate of the evaluation point.
! and NumFun, the number of components of the integrand.
! It must be compatible with the following interface:
! INTERFACE
! FUNCTION Integrand(NUMFUN,X) RESULT(Value)
! USE Precision_Model
! INTEGER, INTENT(IN) :: NUMFUN
! REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: X
! REAL(kind=stnd), DIMENSION(NUMFUN) :: Value
! END FUNCTION Integrand
! END INTERFACE
!
! SVertices
! Real array of dimension (DIMENS,DIMENS+1).
! Vertices(1:DIMENS,K) are the x, y, ... coordinates
! respectively of vertex K of the region, where
! K = 1,...,DIMENS+1.
!
! SRgType Integer.
! RgType describes the type of region L.
!
! SValue Real.
! Approximation to the integral if the procedure is restarted.
!
! SAbsErr Real.
! Estimate of the absolute error if the procedure is restarted.
!
! IFAIL Optional integer argument.
! This follows the NAG convention:
! IFAIL = 1 : soft silent error
! Control returned to calling program.
! IFAIL = -1: soft noisy error
! Error message is printed.
! Control returned to calling program.
! IFAIL = 0 : hard noisy error
! Error message is printed and program is stopped.
! Default IFAIL = -1.
!
! EpsAbs Optional real argument.
! Requested absolute error.
! Default EpsAbs = 0.
!
! EpsRel Optional real argument.
! Requested relative error.
! Default EpsRel = sqrt(machine precision).
!
! Restart Optional boolean argument.
! If Restart = FALSE, this is the first attempt to compute
! the integral.
! If Restart = TRUE, then we restart a previous attempt.
! In this case the only parameters for CUBATR that may
! be changed (with respect to the previous call of CUBATR)
! are MinPts, MaxPts, EpsAbs, EpsRel, Key and Restart.
! Default Restart = FALSE.
!
! MaxPts Optional integer argument.
! The maximum allowed number of integrand evaluations.
! Default MaxPts = enough to do 500 subdivisions.
!
! Key Optional integer argument.
! Can be used by Rule_General to choose between several
! local integration rules.
! Default Key = 2 if Dimension=1 and extrapolation is used
! (This corresponds to QAGS)
! Default Key = 0 otherwise
!
! Job Optional integer argument.
! If |Job| = 0, then nothing will be done except freeing all
! allocated memory.
! This is usefull after a call of CUBATR if no
! Restart will be done later and memory usage
! might become an issue later.
! Equivalently, one can call CUBATR()
! without any arguments.
! = 1, the global adaptive algorithm is called
! = 2, extrapolation using the epsilon algorithm is used.
! = 11, a region will be divided in 2**DIMENS subregions
! and the global adaptive algorithm is called.
! In combination with Key=0, this resembles DUCTRI and DCUTET.
! = 12, a region will be divided in 2 subregions
! and the global adaptive algorithm is called.
! In combination with Key=3 or 4, this resembles DCUHRE.
! If Job < 0, then an overview of the Region Collection is dumped.
! This will create the files tmp_integerstore and tmp_realstore.
! Default Job = 1.
!
! Output parameters
! -----------------
!
! SValue Real.
! Approximation to the integral
!
! AbsErr Real.
! Estimate of the absolute error.
!
! NEval Optional Integer.
! Number of integrand evaluations used by CUBATR for this call.
!
! IFAIL Optional Integer.
! IFAIL = 0 for normal exit.
!
! AbsErr(K) <= EpsAbs or
! AbsErr(K) <= ABS(Value(K))*EpsRel with MaxPts or less
! function evaluations for all values of K,
! 1 <= K <= NumFun .
!
! IFAIL = 1 if MaxPts was too small to obtain the required
! accuracy. In this case Global_Adapt returns values of
! Value with estimated absolute errors AbsErr.
!
! IFAIL > 1 in more serious case of trouble.
!-----------------------------------------------------------------------
!
! Global variables
!
INTERFACE
FUNCTION Integrand(NUMFUN,X) RESULT(Value)
USE Precision_Model
INTEGER, INTENT(IN) :: NUMFUN
REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: X
REAL(kind=stnd), DIMENSION(NUMFUN) :: Value
END FUNCTION Integrand
END INTERFACE
LOGICAL, OPTIONAL, INTENT(IN) :: Restart
INTEGER, INTENT(IN) :: DIMENS,SRgType
INTEGER, INTENT(OUT), OPTIONAL :: NEval
INTEGER, INTENT(IN), OPTIONAL :: Key,MaxPts,Job
INTEGER, INTENT(IN OUT), OPTIONAL :: IFAIL
REAL(kind=stnd), INTENT(IN), OPTIONAL :: EpsAbs,EpsRel
REAL(kind=stnd), DIMENSION(:,:), INTENT(IN) :: SVertices
REAL(kind=stnd), INTENT(IN OUT) :: SValue,SAbsErr
!
! Local variables
!
INTEGER, DIMENSION(1) :: RgType
REAL(kind=stnd), DIMENSION(1) :: Value, AbsErr
REAL(kind=stnd), DIMENSION(DIMENS,DIMENS+1,1) :: Vertices
!-------------------
RgType(1) = SRgType
Vertices(:,:,1) = SVertices
IF (PRESENT(Restart)) THEN
IF ( Restart ) THEN
Value(1) = SValue
AbsErr(1) = SAbsErr
END IF
END IF
CALL CUBATR &
(DIMENS,1,Integrand,1,Vertices,RgType,Value,AbsErr, &
! and optional parameters &
ifail=IFAIL,neval=Neval,epsabs=EpsAbs,epsrel=EpsRel, &
restart=Restart,maxpts=MaxPts,key=key,job=Job)
SValue = Value(1)
SAbsErr = AbsErr(1)
RETURN
END SUBROUTINE CUBATR_1
SUBROUTINE CUBATR_CLEAR()
IF ( ALLOCATED(Iwork) ) THEN
DEALLOCATE(RWork,IWork)
END IF
IF ( ASSOCIATED(M%RESLA)) THEN
DEALLOCATE(M%RESLA,M%ERLARG,M%RESULT1,M%ABSERR1,M%RCOPY)
END IF
PreJob = 0
RETURN
END SUBROUTINE CUBATR_CLEAR
SUBROUTINE CUBPACK_INFO()
REAL(kind=stnd) :: x=1.0e-30 ! lowest accuracy of cubature formula constants
print *," ---------------------------------------------------------------"
print *," CUBPACK information"
print *," -------------------"
print *," The model for real numbers in the current installed version,"
print *," obtained with the declaration REAL(KIND=stnd), has the"
print *," following characteristics:"
print *," base = ",radix(x)
print *," digits in this base = ", digits(x)
! print *," highest exponent = ", maxexponent(x)
! print *," lowest exponent = "minexponent(x), "(normalized numbers)
print *," This implies:"
print *," machine epsilon = ",epsilon(x)
print *," largest real number = ", huge(x)
print *," smallest normalized number = ", tiny(x)
print *
print *," The lowest relative error that may be obtained with this"
print "("" version is about "",G8.2)",max(50*epsilon(x),x)
print *," Asking for lower error will push the routine to use the"
print *," maximal number of function evaluations it is allowed."
print *
print *
print *," This version accepts a collection of hyper-rectangles"
print *," (and parallelepipeds) and simplices as integration regions."
print *," Extrapolation using the epsilon-algorithm is available"
print *," for dimensions 1, 2 and 3."
print *," The following values of KEY give different integration rules:"
print *," - finite interval: KEY = 1, 2, 3, 4, 5."
print *," KEY < 1 defaults to 1; KEY > 5 defaults to 5."
print *," - n-cube: KEY = 3, 4 uses rule of degree 2*KEY+1"
print *," otherwise, uses for a square a rule of degree 13"
print *," 3-cube a rule of degree 11"
print *," a rule of degree 7"
print *," - n-simplex: KEY = 1, 2, 3, 4 uses rule of degree 2*KEY+1"
print *," otherwise, uses for a triangle a rule of degree 13"
print *," tetrahedron a rule of degree 8"
print *," a rule of degree 7"
print *," KEY = 0 corresponds to our preferred choice."
print *," ---------------------------------------------------------------"
RETURN
END SUBROUTINE CUBPACK_INFO
END Module CUI
SHAR_EOF
fi # end of overwriting check
if test -f 'divide.f90'
then
echo shar: will not over-write existing file "'divide.f90'"
else
cat << "SHAR_EOF" > 'divide.f90'
! This file is F-compatible, except for upper/lower case conventions.
!--------------------------------------------------------------------
MODULE Subdivisions
USE Precision_Model, ONLY: stnd
USE internal_types
Implicit NONE
PRIVATE
PUBLIC :: DIVIDE
PRIVATE :: DIVSMP
CONTAINS
SUBROUTINE DIVIDE(DIMENS,NRVERT,MAXSUB,UNIFORM_SUBDIV,NUMFUN,VEROLD, &
INFOLD,RINFOL,Integrand,OUTSUB,NUM,VERNEW,INFNEW,RINFNE,IFAIL)
!***BEGIN PROLOGUE DIVIDE
!***DATE WRITTEN 900615 (YYMMDD)
!***REVISION DATE 910506 (YYMMDD)
!***REVISION DATE 970401 (YYMMDD) (subdivision modifications)
!***REVISION DATE 980331 (YYMMDD) (1D added)
!***REVISION DATE 980406 (YYMMDD) (2div for nCube added)
!***REVISION DATE 980408 (YYMMDD) (F conversion)
!***REVISION DATE 990525 (YYMMDD) (re-organising)
!***REVISION DATE 990602 (YYMMDD) (2/4-division for T2 activated)
!***REVISION DATE 990624 (YYMMDD) (2/4/8-division for C3 activated)
!***REVISION DATE 010919 (YYMMDD) (infold(4) code changed elsewhere)
!***REVISION DATE 020716 (YYMMDD) (replace MOD intrinsic by MODULO)
!***AUTHOR
! Ronald Cools, Dept. of Computer Science,
! Katholieke Universiteit Leuven, Celestijnenlaan 200A,
! B-3001 Heverlee, Belgium
! Email: Ronald.Cools@cs.kuleuven.ac.be
!
! Alan Genz
! Department of Mathematics
! Washington State University
! Pullman, WA 99164-3113, USA
! Email: AlanGenz@wsu.edu
!
!***PURPOSE To divide a given region in OUTSUB subregions
! with equal volume.
!
!***DESCRIPTION
! Input parameters
! ----------------
! DIMENS Integer, dimension of the regions
! NRVERT Integer, number of vertices that describe a region
! MAXSUB Integer.
! The given region is divided in at most MAXSUB subregions
! UNIFORM_SUBDIV Logical.
! If true, this routine does a 2**dim subdivision.
! If false, this routine may decide to divide into less than
! MAXSUB regions
! NUMFUN Integer, number of components of the integral.
! VEROLD Real array of dimension (dimens,nrvert)
! Contains the vertices of the given region
! INFOLD
! RINFOL
! Integrand
! Externally declared function for computing all components
! of the integrand at the given evaluation point.
! It must have input parameter X:
! X(1) The x-coordinate of the evaluation point.
! X(2) The y-coordinate of the evaluation point.
! ...
! X(DIMENS) The z-coordinate of the evaluation point.
! and NumFun, the number of components of the integrand.
! It must be compatible with the following interface:
! INTERFACE
! FUNCTION Integrand(NumFun,X)
! USE Precision_Model
! INTEGER :: NumFun
! REAL(kind=stnd) :: X(:)
! REAL(kind=stnd) :: Integrand(NumFun)
! END
! END INTERFACE
!
! Output parameters
! -----------------
! NUM : Integer number of integrand values used to decide subdivision.
! OUTSUB : Integer number of subregions the given region was divided into.
! VERNEW : Real array of dimension (dimens,nrvert,MAXSUB)
! Contains the vertices of the subregions.
! INFNEW : Integer array of dimension (:,MAXSUM)
! Contains additional information for each subregion.
! RINFNE : Real array of dimension (:,MAXSUM)
! Contains additional information for each subregion.
! IFAIL : integer to indicate success or failure
! IFAIL = 0 on normal exit
! IFAIL = 7 if the desired subdivision is not implemented
! for this type of region
! IFAIL = 6 if no subdivsions are implemented for this type
! of region
!
!***ROUTINES CALLED DIVSMP
!***END PROLOGUE DIVIDE
!
! Global variables
INTEGER, INTENT(IN) :: DIMENS,NRVERT,MAXSUB,NUMFUN
INTEGER, DIMENSION(:), INTENT(IN) :: INFOLD
LOGICAL, INTENT(IN) :: UNIFORM_SUBDIV
REAL(kind=stnd), DIMENSION(:,:), INTENT(IN) :: VEROLD
REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: RINFOL
INTEGER, INTENT(OUT) :: NUM,OUTSUB,IFAIL
INTEGER, DIMENSION(:,:), INTENT(OUT) :: INFNEW
REAL(kind=stnd), DIMENSION(:,:,:), INTENT(OUT):: VERNEW
REAL(kind=stnd), DIMENSION(:,:), INTENT(OUT) :: RINFNE
INTERFACE
FUNCTION Integrand(NUMFUN,X) RESULT(Value)
USE Precision_Model
INTEGER, INTENT(IN) :: NUMFUN
REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: X
REAL(kind=stnd), DIMENSION(NUMFUN) :: Value
END FUNCTION Integrand
END INTERFACE
!
! Local variables
!
! GEOMETRY : specifies the type of region
!
INTEGER :: I,J,GEOMETRY
REAL(kind=stnd) :: VOLUME
REAL(kind=stnd), DIMENSION(3) :: HALF_HEIGHT, HEIGHT
!
!***FIRST EXEUTABLE STATEMENT
IF (MAXSUB == 1) THEN
VERNEW(:,:,1) = VEROLD
INFNEW(:,1) = INFOLD
RINFNE(:,1) = RINFOL
OUTSUB = 1
NUM = 0
IFAIL = 0
RETURN
END IF
!
GEOMETRY = INFOLD(1)
SELECT CASE (GEOMETRY)
CASE (Simplex)
IF (DIMENS == 1 ) THEN
VERNEW(:,:,1) = VEROLD
VERNEW(:,:,2) = VEROLD
VERNEW(:,2,1) = (VEROLD(1,1)+VEROLD(1,2))/2
VERNEW(:,1,2) = VERNEW(:,2,1)
OUTSUB = 2
NUM = 0
!
ELSE IF ((DIMENS == 2) .AND. UNIFORM_SUBDIV ) THEN
VERNEW(:,:,1) = VEROLD
VERNEW(:,:,2) = VEROLD
VERNEW(:,:,3) = VEROLD
VERNEW(:,:,4) = VEROLD
VERNEW(:,2,1) = ( VEROLD(:,1) + VEROLD(:,2) )/2
VERNEW(:,3,1) = ( VEROLD(:,1) + VEROLD(:,3) )/2
VERNEW(:,1,2) = VERNEW(:,2,1)
VERNEW(:,3,2) = ( VEROLD(:,2) + VEROLD(:,3) )/2
VERNEW(:,1,3) = VERNEW(:,3,1)
VERNEW(:,2,3) = VERNEW(:,3,2)
VERNEW(:,1,4) = VERNEW(:,3,2)
VERNEW(:,2,4) = VERNEW(:,2,1)
VERNEW(:,3,4) = VERNEW(:,3,1)
OUTSUB = 4
NUM = 0
!
ELSE IF ((DIMENS == 3) .AND. UNIFORM_SUBDIV ) THEN
VERNEW(:,1,1) = ( VEROLD(:,1) + VEROLD(:,4) )/2
VERNEW(:,2,1) = ( VEROLD(:,1) + VEROLD(:,3) )/2
VERNEW(:,3,1) = ( VEROLD(:,1) + VEROLD(:,2) )/2
VERNEW(:,4,1) = VEROLD(:,1)
VERNEW(:,:,2) = VERNEW(:,:,1)
VERNEW(:,4,2) = ( VEROLD(:,2) + VEROLD(:,4) )/2
VERNEW(:,:,3) = VERNEW(:,:,2)
VERNEW(:,3,3) = ( VEROLD(:,3) + VEROLD(:,4) )/2
VERNEW(:,:,4) = VERNEW(:,:,2)
VERNEW(:,1,4) = ( VEROLD(:,2) + VEROLD(:,3) )/2
VERNEW(:,:,5) = VERNEW(:,:,3)
VERNEW(:,2,5) = VEROLD(:,4)
VERNEW(:,:,6) = VERNEW(:,:,4)
VERNEW(:,3,6) = VERNEW(:,3,3)
VERNEW(:,:,7) = VERNEW(:,:,6)
VERNEW(:,4,7) = VEROLD(:,3)
VERNEW(:,:,8) = VERNEW(:,:,4)
VERNEW(:,2,8) = VEROLD(:,2)
OUTSUB = 8
NUM = 0
!
ELSE IF (.NOT. UNIFORM_SUBDIV ) THEN
CALL DIVSMP( DIMENS, NUMFUN, MAXSUB, VEROLD, Integrand, &
NUM, OUTSUB, VERNEW )
ELSE
IFAIL = 7
RETURN
END IF
!
CASE (Hyperrectangle)
SELECT CASE (DIMENS)
CASE (1)
VERNEW(:,:,1) = VEROLD
VERNEW(:,:,2) = VEROLD
VERNEW(:,2,1) = (VEROLD(1,1)+VEROLD(1,2))/2
VERNEW(:,1,2) = VERNEW(:,2,1)
OUTSUB = 2
NUM = 0
CASE (2)
IF ((MAXSUB == 4) .OR. UNIFORM_SUBDIV) THEN
!
! Divide a parallellogram in 4.
!
VERNEW(:,1,1) = VEROLD(:,1)
VERNEW(:,2,1) = ( VEROLD(:,1) + VEROLD(:,2) )/2
VERNEW(:,3,1) = ( VEROLD(:,1) + VEROLD(:,3) )/2
VERNEW(:,1,2) = ( VEROLD(:,2) + VEROLD(:,3) )/2
VERNEW(:,2,2) = VEROLD(:,2) + ( VEROLD(:,3) - VEROLD(:,1) )/2
VERNEW(:,3,2) = VEROLD(:,3) + ( VEROLD(:,2) - VEROLD(:,1) )/2
VERNEW(:,1,3) = VERNEW(:,2,1)
VERNEW(:,2,3) = VEROLD(:,2)
VERNEW(:,3,3) = VERNEW(:,1,2)
VERNEW(:,1,4) = VERNEW(:,3,1)
VERNEW(:,2,4) = VERNEW(:,1,2)
VERNEW(:,3,4) = VEROLD(:,3)
OUTSUB = 4
NUM = 0
ELSE IF (MAXSUB == 2) THEN
!
! Divide a parallellogram in 2.
!
IF ( INFOLD(4) == 2 ) THEN
! Cut orthogonal to the line through vertices 1-3
VERNEW(:,1,1) = VEROLD(:,1)
VERNEW(:,2,1) = VEROLD(:,2)
VERNEW(:,3,1) = ( VEROLD(:,1) + VEROLD(:,3) )/2
VERNEW(:,1,2) = VERNEW(:,3,1)
VERNEW(:,2,2) = VEROLD(:,2)+( VEROLD(:,3) - VEROLD(:,1) )/2
VERNEW(:,3,2) = VEROLD(:,3)
ELSE
! Cut orthogonal to the line through vertices 1-2
VERNEW(:,1,1) = VEROLD(:,1)
VERNEW(:,2,1) = ( VEROLD(:,1)+VEROLD(:,2) )/2
VERNEW(:,3,1) = VEROLD(:,3)
VERNEW(:,1,2) = VERNEW(:,2,1)
VERNEW(:,3,2) = VEROLD(:,2)
VERNEW(:,2,2) = VEROLD(:,3)+( VEROLD(:,2) - VEROLD(:,1) )/2
END IF
OUTSUB = 2
NUM = 0
ELSE
IFAIL = 7
RETURN
END IF
!
CASE (3)
IF ((MAXSUB == 8) .OR. UNIFORM_SUBDIV) THEN
!
! Divide a 3D-Cube in 8.
!
HALF_HEIGHT = (verold(1:3,4)-verold(1:3,1))/2
vernew(1:3,1,1) = verold(1:3,1)
vernew(1:3,2,1) = (verold(1:3,1)+verold(1:3,2))/2
vernew(1:3,3,1) = (verold(1:3,1)+verold(1:3,3))/2
vernew(1:3,4,1) = (verold(1:3,1)+verold(1:3,4))/2
vernew(1:3,1,2) = vernew(1:3,2,1)
vernew(1:3,2,2) = verold(1:3,2)
vernew(1:3,3,2) = (verold(1:3,2)+verold(1:3,3))/2
vernew(1:3,4,2) = (verold(1:3,2)+verold(1:3,4))/2
vernew(1:3,1,3) = vernew(1:3,3,1)
vernew(1:3,2,3) = vernew(1:3,3,2)
vernew(1:3,3,3) = verold(1:3,3)
vernew(1:3,4,3) = (verold(1:3,3)+verold(1:3,4))/2
vernew(1:3,1,4) = vernew(1:3,3,2)
vernew(1:3,2,4) = verold(1:3,2) + &
(verold(1:3,3)-verold(1:3,1))/2
vernew(1:3,3,4) = verold(1:3,3) + &
(verold(1:3,2)-verold(1:3,1))/2
vernew(1:3,4,4) = vernew(1:3,3,2) + HALF_HEIGHT
vernew(1:3,1,5) = vernew(1:3,4,1)
vernew(1:3,2,5) = vernew(1:3,4,2)
vernew(1:3,3,5) = vernew(1:3,4,3)
vernew(1:3,4,5) = verold(1:3,4)
vernew(1:3,1,6) = vernew(1:3,4,2)
vernew(1:3,2,6) = verold(1:3,2) + HALF_HEIGHT
vernew(1:3,3,6) = vernew(1:3,4,4)
vernew(1:3,4,6) = vernew(1:3,4,2) + HALF_HEIGHT
vernew(1:3,1,7) = vernew(1:3,4,3)
vernew(1:3,2,7) = vernew(1:3,4,4)
vernew(1:3,3,7) = verold(1:3,3) + HALF_HEIGHT
vernew(1:3,4,7) = vernew(1:3,4,3) + HALF_HEIGHT
vernew(1:3,1,8) = vernew(1:3,4,4)
vernew(1:3,2,8) = vernew(1:3,2,4) + HALF_HEIGHT
vernew(1:3,3,8) = vernew(1:3,3,4) + HALF_HEIGHT
vernew(1:3,4,8) = vernew(1:3,4,4) + HALF_HEIGHT
OUTSUB = 8
NUM = 0
ELSE IF (maxsub == 4) THEN
!
! Divide a 3D-Cube in 4.
!
IF (infold(4)/10 == -2) THEN
! Cut orthogonal to the line through vertices 1-2 and vertices 1-3
HEIGHT = (verold(1:3,4) - verold(1:3,1))
vernew(1:3,1,1) = verold(1:3,1)
vernew(1:3,2,1) = (verold(1:3,1)+verold(1:3,2))/2
vernew(1:3,3,1) = (verold(1:3,1)+verold(1:3,3))/2
vernew(1:3,4,1) = verold(1:3,4)
vernew(1:3,1,2) = vernew(1:3,2,1)
vernew(1:3,2,2) = verold(1:3,2)
vernew(1:3,3,2) = (verold(1:3,2)+verold(1:3,3))/2
vernew(1:3,4,2) = vernew(1:3,2,1) + HEIGHT
vernew(1:3,1,3) = vernew(1:3,3,1)
vernew(1:3,2,3) = vernew(1:3,3,2)
vernew(1:3,3,3) = verold(1:3,3)
vernew(1:3,4,3) = vernew(1:3,3,1) + HEIGHT
vernew(1:3,1,4) = vernew(1:3,3,2)
vernew(1:3,2,4) = vernew(1:3,3,1) + &
(verold(1:3,2) - verold(1:3,1))
vernew(1:3,3,4) = vernew(1:3,2,1) + &
(verold(1:3,3) - verold(1:3,1))
vernew(1:3,4,4) = vernew(1:3,3,2) + HEIGHT
ELSE IF (infold(4)/10 == -3) THEN
! Cut orthogonal to the line through vertices 1-3 and vertices 1-4
HEIGHT = (verold(1:3,2) - verold(1:3,1))
HALF_HEIGHT = (verold(1:3,4) - verold(1:3,1))/2
vernew(1:3,1,1) = verold(1:3,1)
vernew(1:3,2,1) = verold(1:3,2)
vernew(1:3,3,1) = (verold(1:3,1)+ verold(1:3,3))/2
vernew(1:3,4,1) = verold(1:3,1) + HALF_HEIGHT
vernew(1:3,1,2) = vernew(1:3,3,1)
vernew(1:3,2,2) = vernew(1:3,3,1) + HEIGHT
vernew(1:3,3,2) = verold(1:3,3)
vernew(1:3,4,2) = vernew(1:3,3,1) + HALF_HEIGHT
vernew(1:3,1,3) = vernew(1:3,4,1)
vernew(1:3,2,3) = vernew(1:3,4,1) + HEIGHT
vernew(1:3,3,3) = vernew(1:3,4,2)
vernew(1:3,4,3) = verold(1:3,4)
vernew(1:3,1,4) = vernew(1:3,4,2)
vernew(1:3,2,4) = vernew(1:3,4,2) + HEIGHT
vernew(1:3,3,4) = verold(1:3,3) + HALF_HEIGHT
vernew(1:3,4,4) = vernew(1:3,4,2) + HALF_HEIGHT
ELSE
! Cut orthogonal to the line through vertices 1-2 and vertices 1-4
HALF_HEIGHT = (verold(1:3,4) - verold(1:3,1))/2
vernew(1:3,1,1) = verold(1:3,1)
vernew(1:3,2,1) = (verold(1:3,2) + verold(1:3,1))/2
vernew(1:3,3,1) = verold(1:3,3)
vernew(1:3,4,1) = verold(1:3,1) + HALF_HEIGHT
vernew(1:3,1,2) = vernew(1:3,2,1)
vernew(1:3,2,2) = verold(1:3,2)
vernew(1:3,3,2) = verold(1:3,3) + &
(verold(1:3,2) - verold(1:3,1))/2
vernew(1:3,4,2) = vernew(1:3,2,1) + HALF_HEIGHT
vernew(1:3,1,3) = vernew(1:3,4,1)
vernew(1:3,2,3) = (verold(1:3,2) + verold(1:3,4))/2
vernew(1:3,3,3) = verold(1:3,3) + HALF_HEIGHT
vernew(1:3,4,3) = verold(1:3,4)
vernew(1:3,1,4) = vernew(1:3,4,2)
vernew(1:3,2,4) = verold(1:3,2) + HALF_HEIGHT
vernew(1:3,3,4) = vernew(1:3,3,2) + HALF_HEIGHT
vernew(1:3,4,4) = vernew(1:3,4,2) + HALF_HEIGHT
END IF
OUTSUB = 4
NUM = 0
ELSE IF (maxsub == 2) THEN
!
! Divide a 3D-Cube in 2.
!
IF (modulo(abs(infold(4)),10) == 2) THEN
! Cut orthogonal to the line through vertices 1-3
vernew(1:3,1,1) = verold(1:3,1)
vernew(1:3,2,1) = verold(1:3,2)
vernew(1:3,3,1) = (verold(1:3,1)+verold(1:3,3))/2
vernew(1:3,4,1) = verold(1:3,4)
vernew(1:3,1,2) = vernew(1:3,3,1)
vernew(1:3,2,2) = vernew(1:3,3,1) + &
(verold(1:3,2) - verold(1:3,1))
vernew(1:3,3,2) = verold(1:3,3)
vernew(1:3,4,2) = vernew(1:3,3,1) + &
(verold(1:3,4) - verold(1:3,1))
ELSE IF (modulo(abs(infold(4)),10) == 3) THEN
! Cut orthogonal to the line through vertices 1-4
vernew(1:3,1,1) = verold(1:3,1)
vernew(1:3,2,1) = verold(1:3,2)
vernew(1:3,3,1) = verold(1:3,3)
vernew(1:3,4,1) = (verold(1:3,1)+verold(1:3,4))/2
vernew(1:3,1,2) = vernew(1:3,4,1)
vernew(1:3,2,2) = vernew(1:3,4,1) + &
(verold(1:3,2) - verold(1:3,1))
vernew(1:3,3,2) = vernew(1:3,4,1) + &
(verold(1:3,3) - verold(1:3,1))
vernew(1:3,4,2) = verold(1:3,4)
ELSE
! Cut orthogonal to the line through vertices 1-2
vernew(1:3,1,1) = verold(1:3,1)
vernew(1:3,2,1) = (verold(1:3,1)+verold(1:3,2))/2
vernew(1:3,3,1) = verold(1:3,3)
vernew(1:3,4,1) = verold(1:3,4)
vernew(1:3,1,2) = vernew(1:3,2,1)
vernew(1:3,2,2) = verold(1:3,2)
vernew(1:3,3,2) = vernew(1:3,2,1) + &
(verold(1:3,3) - verold(1:3,1))
vernew(1:3,4,2) = vernew(1:3,2,1) + &
(verold(1:3,4) - verold(1:3,1))
END IF
OUTSUB = 2
NUM = 0
ELSE
IFAIL = 7
RETURN
END IF
CASE DEFAULT
!
! IF DIMENS > 3, then divide in 2 according to infold(4).
!
J = INFOLD(4)
IF ( J == 0 ) THEN
J = 1
END IF
DO I = 1,NRVERT
IF ( J == I-1 ) THEN
VERNEW(:,I,1) = (VEROLD(:,1) + VEROLD(:,I))/2
ELSE
VERNEW(:,I,1) = VEROLD(:,I)
END IF
END DO
HALF_HEIGHT(1) = (VEROLD(J,J+1) - VEROLD(J,1))/2
DO I = 1,NRVERT
IF ( J == I-1 ) THEN
VERNEW(:,I,2) = VEROLD(:,I)
ELSE
VERNEW(:,I,2) = VERNEW(:,I,1)
VERNEW(J,I,2) = VERNEW(J,I,2) + HALF_HEIGHT(1)
END IF
END DO
OUTSUB = 2
NUM = 0
END SELECT
CASE DEFAULT
IFAIL = 6
RETURN
END SELECT
VOLUME = RINFOL(1)/OUTSUB
!
! Update/copy information record
!
INFNEW(1,1:OUTSUB) = GEOMETRY
INFNEW(2,1:OUTSUB) = INFOLD(2) + 1
INFNEW(3,1:OUTSUB) = INFOLD(3)
INFNEW(4:5,1:OUTSUB) = 0
RINFNE(1,1:OUTSUB) = VOLUME
DO I = 1,OUTSUB
INFNEW(6:,I) = INFOLD(6:)
RINFNE(2:,I) = RINFOL(2:)
END DO
IFAIL = 0
RETURN
END SUBROUTINE DIVIDE
SUBROUTINE DIVSMP( DIMENS, NF, MAXSUB, VEROLD, Integrand, &
FUNCLS, OUTSUB, VERNEW )
!***BEGIN PROLOGUE DIVSMP
!***PURPOSE To compute new subregions
!***AUTHOR
!
! Alan Genz
! Department of Mathematics
! Washington State University
! Pullman, WA 99164-3113, USA
! AlanGenz@wsu.edu
!
! Ronald Cools, Dept. of Computer Science,
! Katholieke Universiteit Leuven, Celestijnenlaan 200A,
! B-3001 Heverlee, Belgium
! Email: Ronald.Cools@cs.kuleuven.ac.be
!
!
!***LAST MODIFICATION 97-03
!***DESCRIPTION DIVSMP computes fourth differences along each edge
! direction. It uses these differences to determine a
! subdivision of the orginal subregion into two new subregions.
!
! ON ENTRY
!
! DIMENS Integer number of variables.
! NF Integer number of components for the vector integrand.
! MAXSUB Integer.
! The given region is divided into at most MAXSUB subregions.
! VEROLD Real array of dimension (N,0:N), orginal subregion vertices.
! Integrand Real vector function of length NF for computing components of
! the integrand at Z.
! It must have parameters ( NF, Z ). See interface below.
! Input parameters:
! Z Real array of length DIMENS, the evaluation point.
! NF Integer number of components of Integrand.
!
! ON RETURN
!
! OUTSUB Integer number of subregions the given region was divided into.
! FUNCLS Integer number of Integrand calls used by DIVSMP.
! VERNEW Real array of dimension (N,0:N,MAXSUB).
! The vertices of the MAXSUB new subegions.
!
!***ROUTINES CALLED: Integrand
!***END PROLOGUE DIVSMP
INTERFACE
FUNCTION Integrand( NF, Z ) RESULT(Value)
USE Precision_Model
INTEGER, INTENT(IN) :: NF
REAL(kind=STND), DIMENSION(:), INTENT(IN) :: Z
REAL(kind=STND), DIMENSION(NF) :: Value
END FUNCTION Integrand
END INTERFACE
INTEGER, INTENT(IN) :: DIMENS, NF, MAXSUB
INTEGER, INTENT(OUT) :: OUTSUB, FUNCLS
REAL(kind=STND), INTENT(IN), DIMENSION(1:,0:) :: VEROLD
REAL(kind=STND), INTENT(OUT), DIMENSION(1:,0:,1:) :: VERNEW
!
! Local Arrays
! X Real work array of length DIMENS.
! H Real work array of length DIMENS.
! CENTER Real work array of length DIMENS.
! WORK Real work array of dimension (NF,5).
! FRTHDF Real work array of dimension (0:DIMENS,0:DIMENS).
! EWIDTH Real work array of dimension (0:DIMENS,0:DIMENS).
!
REAL(kind=STND), DIMENSION(5), PARAMETER :: DIFCON = (/ 1, -4, 6, -4, 1 /)
REAL(kind=STND), DIMENSION(DIMENS) :: X, H, CENTER
REAL(kind=STND), DIMENSION(NF,5) :: WORK
REAL(kind=STND), DIMENSION(0:DIMENS,0:DIMENS) :: FRTHDF, EWIDTH
REAL(kind=STND) :: DIFMID, DIFMAX, DIFMIN
INTEGER :: J, K, L, IMX, JMX, KMX, LMX, LTMP
INTEGER, DIMENSION(2) :: INDX
!
!***FIRST PROCESSING STATEMENT DIVSMP
!
!
! Compute the differences.
!
CENTER = MATMUL( VEROLD, SPREAD( 1, 1, DIMENS+1 ) )/(DIMENS+1)
WORK(:,3) = Integrand( NF, CENTER )
FRTHDF = 0
EWIDTH = 0
DO L = 0, DIMENS-1
DO K = L+1, DIMENS
H = VEROLD(:,K) - VEROLD(:,L)
EWIDTH(L,K) = SUM( ABS( H ) )
H = 2*H/( 5*( DIMENS + 1 ) )
X = CENTER - 3*H
DO J = 1, 5
X = X + H
IF ( J /= 3 ) THEN
WORK(:,J) = Integrand( NF, X )
END IF
END DO
DIFMID = SUM( ABS( MATMUL( WORK(:,:), DIFCON ) ) )
!
! Ignore differences below roundoff
!
IF ( SUM( ABS(WORK(:,3)) ) + DIFMID/8 > SUM( ABS(WORK(:,3)) ) ) THEN
FRTHDF(L,K) = DIFMID
END IF
END DO
END DO
FRTHDF = FRTHDF*EWIDTH
IF ( MAXVAL( FRTHDF ) == 0 ) THEN
FRTHDF = EWIDTH
END IF
INDX(1:2) = MAXLOC( FRTHDF ) - 1
LMX = INDX(1)
KMX = INDX(2)
VERNEW(:,:,1) = VEROLD
VERNEW(:,:,2) = VEROLD
!
IF ((DIMENS == 2) .AND. (MAXSUB >=4)) THEN
DIFMAX = FRTHDF(LMX,KMX)
DIFMIN = MIN(frthdf(0,1),frthdf(0,2),frthdf(1,2))
IF ( (DIFMAX > 0.001*ewidth(lmx,kmx)) .AND. ( DIFMIN <= 0.45_stnd*DIFMAX )) THEN ! 2-division
VERNEW(:,LMX,2) = ( VEROLD(:,KMX) + VEROLD(:,LMX) )/2
VERNEW(:,KMX,1) = VERNEW(:,LMX,2)
OUTSUB = 2
ELSE ! 4-division
! VERNEW(:,:,1) = VEROLD ; VERNEW(:,:,2) = VEROLD
VERNEW(:,:,3) = VEROLD
VERNEW(:,:,4) = VEROLD
VERNEW(:,1,1) = ( VEROLD(:,0) + VEROLD(:,1) )/2
VERNEW(:,2,1) = ( VEROLD(:,0) + VEROLD(:,2) )/2
VERNEW(:,0,2) = VERNEW(:,1,1)
VERNEW(:,2,2) = ( VEROLD(:,1) + VEROLD(:,2) )/2
VERNEW(:,0,3) = VERNEW(:,2,1)
VERNEW(:,1,3) = VERNEW(:,2,2)
VERNEW(:,0,4) = VERNEW(:,2,2)
VERNEW(:,1,4) = VERNEW(:,1,1)
VERNEW(:,2,4) = VERNEW(:,2,1)
OUTSUB = 4
END IF
ELSE IF ( MAXSUB == 2 ) THEN
!
! Compute two new subregions.
!
VERNEW(:,LMX,2) = ( VEROLD(:,KMX) + VEROLD(:,LMX) )/2
VERNEW(:,KMX,1) = VERNEW(:,LMX,2)
OUTSUB = 2
ELSE
DIFMAX = FRTHDF(LMX,KMX)
!
FRTHDF(LMX,KMX) = 0
INDX(1:2) = MAXLOC( FRTHDF ) - 1
JMX = INDX(1)
IMX = INDX(2)
!
FRTHDF(JMX,IMX) = 0
INDX(1:2) = MAXLOC( FRTHDF ) - 1
JMX = INDX(1)
IMX = INDX(2)
!
DIFMID = FRTHDF(JMX,IMX)
IF ( DIFMAX > 2*DIFMID .OR. MAXSUB == 3 ) THEN
! Tobedone ^^ tune this parameter RC
!
! Compute three new subregions.
!
VERNEW(:,:,3) = VEROLD
WHERE ( FRTHDF == 0 )
FRTHDF = TRANSPOSE( FRTHDF )
END WHERE
INDX(1:1) = MAXLOC( FRTHDF(LMX,:) + FRTHDF(KMX,:) ) - 1
JMX = INDX(1)
IF ( FRTHDF(LMX,JMX) > FRTHDF(KMX,JMX) ) THEN
LTMP = KMX
KMX = LMX
LMX = LTMP
END IF
DIFMID = FRTHDF(KMX,JMX)
VERNEW(:,KMX,1) = ( 2*VEROLD(:,LMX) + VEROLD(:,KMX) )/3
VERNEW(:,LMX,2) = VERNEW(:,KMX,1)
VERNEW(:,KMX,2) = VEROLD(:,JMX)
IF ( DIFMID > DIFMAX/8 ) THEN
! Tobedone ^^ tune this parameter RC
VERNEW(:,JMX,2) = ( VEROLD(:,KMX) + VEROLD(:,JMX) )/2
VERNEW(:,JMX,3) = VERNEW(:,LMX,2)
ELSE
VERNEW(:,JMX,2) = ( VEROLD(:,LMX) + 2*VEROLD(:,KMX) )/3
VERNEW(:,JMX,3) = VEROLD(:,JMX)
END IF
VERNEW(:,LMX,3) = VERNEW(:,JMX,2)
OUTSUB = 3
ELSE
!
! Compute four new subregions.
!
VERNEW(:,LMX,2) = ( VEROLD(:,KMX) + VEROLD(:,LMX) )/2
VERNEW(:,KMX,1) = VERNEW(:,LMX,2)
VERNEW(:,:,3) = VERNEW(:,:,1)
VERNEW(:,JMX,3) = ( VERNEW(:,IMX,1) + VERNEW(:,JMX,1) )/2
VERNEW(:,IMX,1) = VERNEW(:,JMX,3)
VERNEW(:,:,4) = VERNEW(:,:,2)
VERNEW(:,JMX,4) = ( VERNEW(:,IMX,2) + VERNEW(:,JMX,2) )/2
VERNEW(:,IMX,2) = VERNEW(:,JMX,4)
OUTSUB = 4
END IF
END IF
FUNCLS = 1 + 2*DIMENS*(DIMENS+1)
RETURN
END SUBROUTINE DIVSMP
END MODULE Subdivisions
SHAR_EOF
fi # end of overwriting check
if test -f 'ds_routines.f90'
then
echo shar: will not over-write existing file "'ds_routines.f90'"
else
cat << "SHAR_EOF" > 'ds_routines.f90'
! This file is F-compatible, except for upper/lower case conventions.
!--------------------------------------------------------------------
MODULE DS_ROUTINES
USE Precision_Model, ONLY: stnd
Implicit NONE
private
public :: DSINIT, DSGET, DSSPUT, DSUPUT, DSSTAT, DSPINT, DSCOPY
public :: DSSUM, DSFREE, DSUSED
CONTAINS
!-----------------------------------------------------------------------
SUBROUTINE DSINIT(DIMENS,NRVERT,NIINFO,NRINFO,NRFUNC,NRVACA, &
BOTTIS,BOTTRS,ISTORE,IFAIL)
!***BEGIN PROLOGUE DSINIT
!***DATE WRITTEN 900612 (YYMMDD)
!***REVISION DATE 970612 (YYMMDD)
!***AUTHOR
! Ronald Cools, Dept. of Computer Science,
! Katholieke Universiteit Leuven, Celestijnenlaan 200A,
! B-3001 Heverlee, Belgium
! Email: Ronald.Cools@cs.kuleuven.ac.be
!
!***PURPOSE To initialise a data structure that stores information
! about the subregions in an adaptive integrator.
!***DESCRIPTION
!
! Organization of data structure:
! -------------------------------
!
! For each subregion in the data structure a record with the
! following information is stored:
! - a sortkey ( 1 double precision number )
! - the vertices to describe the subregion
! ( NRVERT*DIMENS double precision numbers )
! - approximation for the integrals over the subregion
! ( NRFUNC double precision numbers )
! - estimates for the errors of the approximations
! ( NRFUNC double precision numbers )
! - additional information about the subregion
! ( NIINFO integers and NRINFO double precision numbers)
!
! These records appear in a partially sorted binary tree
! with the element with the largest sortkey on top or in an
! unsorted pool.
! All information is kept in 2 arrays: one for the integers
! and one for the double precision numbers. The records have
! a fixed place. Only the pointers to these records are
! modified if a new element is added or if the top is removed.
! If the topelement is removed from the tree, the place
! were the record was stored can be reused.
! The pointer to this vacant place is saved. NRVACA integers
! are reserved for this purpose.
!
! The following figure shows how all information is distributed
! over the heaps.
!
! ISTORE RSTORE
! --------------- ---------------
! | 1) DIMENS | | ----------- |
! | 2) NRVERT | | | sortkey | |
! | 3) NIINFO | | | err est | |
! | 4) NRINFO | | | int appr| |
! | 5) NRFUNC | | | vertices| |
! | 6) NRVACA | | | info | |
! | 7) BOTTIS | | ----------- |
! | 8) BOTTRS | | | sortkey | |
! | 9) OFFSET | | | err est | |
! | 10) START | | | int appr| |
! | 11) BLOCK | | | vertices| |
! | 12) INTREE | | | info | |
! | 13) INPOOL | | ----------- |
! | 14) HOLES | | . |
! | 15) LOST | | . |
! |=============| | . |
! | . | | |
! | . | | |
! | ----------- | | |
! | |vacancies| | | |
! offset ->| ----------- | | |
! |=============| | |
! offset + 1 ->| ----------- | | |
! | | pointer | | | |
! | | to tree | | | |
! | ----------- | | |
! | . | | |
! | . | | |
! | . | | |
! | | | |
! | | | |
! | | | |
! | | | |
! | . | | |
! | . | | |
! | . | | |
! | ----------- | | |
! | | pool | | | |
! | ----------- | | |
! |=============| | |
! start ->| . | | |
! | . | | |
! | . | | |
! | ----------- | | |
! | | region | | | |
! | | info | | | |
! bottis ->| ----------- | | |<- bottrs
! --------------- ---------------
!
! The maximum number of subregions that can be stored in this
! data structure is
! min( BOTTRS/BLOCK , (BOTTIS-CONST-NRVACA)/(1+NRINFO) )
!
! Input parameters
! ----------------
!
! DIMENS = dimension of (sub-)regions
! DIMENS > 0
! NRVERT = number of vertices to describe a subregion
! NRVERT > DIMENS
! NIINFO = number of integers used to save additional information
! for each subregion
! NIINFO > 0
! NRINFO = number of double precision numbers used to save additional
! information for each subregion
! NRINFO > 0
! NRFUNC = number of integrand functions for which information must
! be stored
! NRFUNC > 0
! NRVACA = maximum number of pointers to empty spaces in the heap
! that must be stored for later use
! NRVACA >= 0
! BOTTIS = length of integer array ISTORE.
! Needed because this heap is also filled up starting from
! the bottom
! bottis > 0
! BOTTRS = length of the double precision heap
! Only needed for checks
! bottrs > 0
! ISTORE = integer array of dimension (BOTTIS)
! Used to store integer part of records, pointers to
! records and information about the data structure.
!
! Output parameter
! ----------------
!
! IFAIL = integer to indicate success or failure
! IFAIL = 0 for normal exit
! IFAIL = 10001 if DIMENS is less than 1
! IFAIL = 10002 if NRVERT is less than or equal to dimens
! IFAIL = 10003 if NIINFO is less than 1
! IFAIL = 10004 if NRINFO is less than 1
! IFAIL = 10005 if NRFUNC is less than 1
! IFAIL = 10006 if NRVACA is negative
! IFAIL = 10007 if the array of integers cannot contain one record
! IFAIL = 10008 if the array of reals cannot contain one record
! ISTORE = contains initialisation information about the data structure
!
!***LONG DESCRIPTION
!
! Other procedures available to work on this data structure are:
! SUBROUTINE DSGET
! SUBROUTINE DSSPUT
! SUBROUTINE DSUPUT
! SUBROUTINE DSSTAT
! SUBROUTINE DSPINT
! SUBROUTINE DSSUM
! INTEGER FUNCTION DSFREE
! INTEGER FUNCTION DSUSED
!
!***END PROLOGUE DSINIT
!
! Global variables
!
INTEGER, INTENT(IN) :: DIMENS,NRVERT,NIINFO,NRINFO,NRFUNC,NRVACA, &
BOTTIS,BOTTRS
INTEGER, INTENT(OUT) :: IFAIL
INTEGER, DIMENSION(:), INTENT(IN OUT) :: ISTORE
!
! Local variables and constants
!
! CONST = the number of constants and information variables during
! the existence of the data structure
! INTREE = number of subregions in the sorted tree
! INPOOL = number of subregions in the unsorted pool
! HOLES = number of pointers to holes in the heap
! 0 <= HOLES <= NRVACA
! LOST = number of records that cannot be accessed any more
! OFFSET : The first pointer to the tree is stored in ISTORE(OFFSET+1)
! START : The first pointer to the pool is stored in ISTORE(START-1)
! BLOCK = number of double precision numbers in a record
!
INTEGER, PARAMETER :: CONST = 15, INTREE = 0, INPOOL = 0, &
HOLES = 0, LOST = 0
INTEGER :: OFFSET,BLOCK,START
!***FIRST EXECUTABLE STATEMENT
!
! Check input
!
BLOCK = NRINFO + NRVERT*DIMENS + 2*NRFUNC
IF (NRFUNC /= 1) THEN
BLOCK = BLOCK + 1
END IF
IF (DIMENS <= 0) THEN
IFAIL = 10001
ELSE IF (NRVERT <= DIMENS) THEN
IFAIL = 10002
ELSE IF (NIINFO <= 0) THEN
IFAIL = 10003
ELSE IF (NRINFO <= 0) THEN
IFAIL = 10004
ELSE IF (NRFUNC <= 0) THEN
IFAIL = 10005
ELSE IF (NRVACA < 0) THEN
IFAIL = 10006
ELSE IF (BOTTIS-NRVACA-CONST < 1+NIINFO) THEN
IFAIL = 10007
ELSE IF (BOTTRS < BLOCK) THEN
IFAIL = 10008
ELSE
ISTORE(1) = DIMENS
ISTORE(2) = NRVERT
ISTORE(3) = NIINFO
ISTORE(4) = NRINFO
ISTORE(5) = NRFUNC
ISTORE(6) = NRVACA
ISTORE(7) = BOTTIS
ISTORE(8) = BOTTRS
OFFSET = CONST + NRVACA
ISTORE(9) = OFFSET
START = BOTTIS + 1 - ((BOTTIS-NRVACA-CONST)/ (1+NIINFO))*NIINFO
ISTORE(10) = START
ISTORE(11) = BLOCK
ISTORE(12) = INTREE
ISTORE(13) = INPOOL
ISTORE(14) = HOLES
ISTORE(15) = LOST
IFAIL = 0
END IF
!
!***END DSINIT
!
RETURN
END SUBROUTINE DSINIT
!-----------------------------------------------------------------------
SUBROUTINE DSSPUT(VERTIC,INTAPP,ERREST,IRGINF,RRGINF,ISTORE,RSTORE,IFAIL)
!
!***BEGIN PROLOGUE DSSPUT
!***DATE WRITTEN 900612 (YYMMDD)
!***REVISION DATE 970612 (YYMMDD)
!***AUTHOR
! Ronald Cools, Dept. of Computer Science,
! Katholieke Universiteit Leuven, Celestijnenlaan 200A,
! B-3001 Heverlee, Belgium
! Email: Ronald.Cools@cs.kuleuven.ac.be
!
!***PURPOSE To add a record to a data structure that stores information
! about the subregions in an adaptive integrator.
! The record is added to a sorted tree.
!***DESCRIPTION
! See the description of SUBROUTINE DSINIT
!
! Input parameters
! ----------------
!
! VERTIC = double precision array of dimension (DIMENS,NRVERT)
! Contains the vertices that describe a subregion.
! ( VERTIC(1,i),...,VERTIC(DIMENS,i) ) are the coordinates
! of the i-th vertex.
! INTAPP = double precision array of dimension (NRFUNC)
! Contains approximations to the integrals.
! ERREST = double precision array of dimension (NRFUNC)
! Contains error estimates.
! IRGINF = integer array of dimension (NIINFO).
! Contains additional information about the subregion
! RRGINF = double precision array of dimension (NRINFO).
! Contains additional information about the subregion
! ISTORE = integer array of dimension (BOTTIS).
! Contains the integers of the records.
! RSTORE = double precision array of dimension (BOTTRS).
! Contains the double precision numbers of the records.
!
! Output parameters
! -----------------
!
! IFAIL = integer to indicate success or failure
! IFAIL = 0 for normal exit
! IFAIL = 10009 if the integer array ISTORE is full
! IFAIL = 10010 if the double precision array RSTORE is full
! ISTORE = integer array of dimension (BOTTIS).
! Contains the integers of the records.
! RSTORE = double precision array of dimension (BOTTRS).
! Contains the double precision numbers of the records.
!
!***END PROLOGUE DSSPUT
!
! Variables and constants used by DS-procedures only
! --------------------------------------------------
!
! DIMENS = dimension of (sub-)regions
! NRVERT = number of vertices to describe a subregion
! NIINFO = number of integers used to save additional information
! for each subregion
! NRINFO = number of double precision numbers used to save additional
! information for each subregion
! NRFUNC = number of integrand functions for which information must
! be stored
! NRVACA = maximum number of pointers to empty spaces in the heap
! that must be stored for later use
! BOTTIS = length of integer array ISTORE.
! Needed because this heap is also filled up starting from
! the bottom
! BOTTRS = length of the double precision heap
! Only needed for checks
! INTREE = number of subregions in the sorted tree
! INPOOL = number of subregions in the unsorted pool
! HOLES = number of pointers to holes in the heap
! 0 <= HOLES <= NRVACA
! LOST = number of records that cannot be accessed any more
! OFFSET : The first pointer to the tree is stored in ISTORE(OFFSET+1)
! START : The first pointer to the pool is stored in ISTORE(START-1)
! BLOCK = number of double precision numbers in a record
!
! Global variables
!
INTEGER, DIMENSION(:), INTENT(IN) :: IRGINF
INTEGER, DIMENSION(:), INTENT(IN OUT) :: ISTORE
INTEGER, INTENT(OUT) :: IFAIL
REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: INTAPP,ERREST,RRGINF
REAL(kind=stnd), DIMENSION(:), INTENT(IN OUT) :: RSTORE
REAL(kind=stnd), DIMENSION(:,:), INTENT(IN) :: VERTIC
!
! Local variables
!
! SORKEY = sortkey for maintaining the partially sorted tree
! = maximum(errest(1),...,errest(nrfunc))
! SPACE = index to the place were a new record can be
! inserted in the heap
!
INTEGER :: DIMENS,NRVERT,NIINFO,NRINFO,NRFUNC,BOTTIS,BOTTRS, &
INTREE,INPOOL,HOLES,LOST,BLOCK,OFFSET,START
REAL(kind=stnd) :: SORKEY
INTEGER :: I,SPACE,POINT,SUBRGN,SUBTMP
!***FIRST EXECUTABLE STATEMENT
!
! The following initialisation statements are included
! to make the code readable
!
! Initialise data structure constants
DIMENS = ISTORE(1)
NRVERT = ISTORE(2)
NIINFO = ISTORE(3)
NRINFO = ISTORE(4)
NRFUNC = ISTORE(5)
BOTTIS = ISTORE(7)
BOTTRS = ISTORE(8)
OFFSET = ISTORE(9)
START = ISTORE(10)
BLOCK = ISTORE(11)
! Initialise data structure variables
INTREE = ISTORE(12)
INPOOL = ISTORE(13)
HOLES = ISTORE(14)
LOST = ISTORE(15)
!
! Check if enough space is left in the arrays to put in a subregion
!
IF (HOLES <= 0) THEN
IF ((BOTTIS-START+1- (INTREE+INPOOL+LOST)*NIINFO < &
NIINFO) .OR. (START-OFFSET-1-INTREE-INPOOL < 1)) THEN
IFAIL = 10009
RETURN
ELSE IF (BOTTRS- (INTREE+INPOOL+LOST)*BLOCK < BLOCK) THEN
IFAIL = 10010
RETURN
END IF
END IF
INTREE = INTREE + 1
!
! Determine index for new record
!
IF (HOLES <= 0) THEN
SPACE = INTREE + INPOOL + LOST
ELSE
SPACE = ISTORE(OFFSET+1-HOLES)
HOLES = HOLES - 1
END IF
!
! Compute sortkey
!
SORKEY = MAXVAL(ERREST(1:NRFUNC))
!
! Put the new record in the heap
!
POINT = (SPACE-1)*BLOCK
IF (NRFUNC > 1) THEN
POINT = POINT + 1
RSTORE(POINT) = SORKEY
END IF
RSTORE(POINT+1:POINT+NRFUNC) = ERREST(1:NRFUNC)
RSTORE(POINT+NRFUNC+1 : POINT+NRFUNC*2) = INTAPP(1:NRFUNC)
POINT = POINT + NRFUNC*2
DO I = 1,DIMENS
RSTORE(POINT+1:POINT+NRVERT) = VERTIC(I,1:NRVERT)
POINT = POINT + NRVERT
END DO
RSTORE(POINT+1:POINT+NRINFO) = RRGINF(1:NRINFO)
POINT = BOTTIS - NIINFO*SPACE
ISTORE(POINT+1:POINT+NIINFO) = IRGINF(1:NIINFO)
!
! Insert the index in the tree
!
SUBRGN = INTREE
DO
SUBTMP = SUBRGN/2
IF (SUBTMP >= 1) THEN
!
! Compare max. child with parent.
! If parent is max, then done.
!
IF (SORKEY > RSTORE(1+ (ISTORE(OFFSET+SUBTMP)-1)*BLOCK)) THEN
!
! Move the pointer at position subtmp down the heap.
!
ISTORE(OFFSET+SUBRGN) = ISTORE(OFFSET+SUBTMP)
SUBRGN = SUBTMP
CYCLE
END IF
END IF
EXIT
END DO
!
! Set the pointer to the new index in the heap.
!
ISTORE(OFFSET+SUBRGN) = SPACE
!
! Save data structure variables
!
ISTORE(12) = INTREE
ISTORE(14) = HOLES
IFAIL = 0
!
!***END DSSPUT
!
RETURN
END SUBROUTINE DSSPUT
!-----------------------------------------------------------------------
SUBROUTINE DSGET(VERTIC,INTAPP,ERREST,IRGINF,RRGINF,ISTORE,RSTORE,&
IFAIL)
!***BEGIN PROLOGUE DSGET
!***DATE WRITTEN 900612 (YYMMDD)
!***REVISION DATE 961206 (YYMMDD)
!***AUTHOR
! Ronald Cools, Dept. of Computer Science,
! Katholieke Universiteit Leuven, Celestijnenlaan 200A,
! B-3001 Heverlee, Belgium
! Email: Ronald.Cools@cs.kuleuven.ac.be
!
!***PURPOSE To get and delete the record at the root of a sorted tree
! that stores information about the subregions in an
! adaptive integrator.
!***DESCRIPTION
! See the description of SUBROUTINE DSINIT
!
! Output parameters
! -----------------
!
! VERTIC = double precision array of dimension (DIMENS,NRVERT)
! Contains the vertices that describe a subregion.
! ( VERTIC(1,i),...,VERTIC(DIMENS,i) ) are the coordinates
! of the i-th vertex.
! INTAPP = double precision array of dimension (NRFUNC)
! Contains approximations to the integrals.
! ERREST = double precision array of dimension (NRFUNC)
! Contains error estimates.
! IRGINF = integer array of dimension (NIINFO).
! Contains additional information about the subregion
! RRGINF = double precision array of dimension (NRINFO).
! Contains additional information about the subregion
! ISTORE = integer array of dimension (BOTTIS).
! Contains the integers of the records.
! RSTORE = double precision array of dimension (BOTTRS).
! Contains the double precision numbers of the records.
! IFAIL = integer to indicate success or failure
! IFAIL = 0 for normal exit
! IFAIL = 10011 : attempt to get something out of empty tree
! IFAIL = 9999 if a hole is created that cannot be saved.
! This is a warning, not an error !
!
!***END PROLOGUE DSGET
!
! Variables and constants used by DS-procedures only
! --------------------------------------------------
!
! DIMENS = dimension of (sub-)regions
! NRVERT = number of vertices to describe a subregion
! NIINFO = number of integers used to save additional information
! for each subregion
! NRINFO = number of double precision numbers used to save additional
! information for each subregion
! NRFUNC = number of integrand functions for which information must
! be stored
! NRVACA = maximum number of pointers to empty spaces in the heap
! that must be stored for later use
! BOTTIS = length of integer array ISTORE.
! Needed because this heap is also filled up starting from
! the bottom
! INTREE = number of subregions in the sorted tree
! HOLES = number of pointers to holes in the heap
! 0 <= HOLES <= NRVACA
! LOST = number of records that cannot be accessed any more
! OFFSET : The first pointer to the tree is stored in ISTORE(OFFSET+1)
! BLOCK = number of double precision numbers in a record
!
! Global variables
!
INTEGER, INTENT(OUT) :: IFAIL
INTEGER, DIMENSION(:), INTENT(IN OUT) :: ISTORE
INTEGER, DIMENSION(:), INTENT(OUT) :: IRGINF
REAL(kind=stnd), DIMENSION(:), INTENT(OUT) :: INTAPP,ERREST,RRGINF
REAL(kind=stnd), DIMENSION(:), INTENT(IN OUT) :: RSTORE
REAL(kind=stnd), DIMENSION(:,:), INTENT(OUT) :: VERTIC
!
! Local variables
!
! SORKEY = sortkey for maintaining the partially sorted tree
! = maximum(errest(1),...,errest(nrfunc)
! SPACE = index to the place were a new record can be
! inserted in the heap
!
INTEGER :: DIMENS,NRVERT,NIINFO,NRINFO,NRFUNC,NRVACA,BOTTIS,INTREE, &
INPOOL,HOLES,LOST,BLOCK,OFFSET
REAL(kind=stnd):: SORKEY
INTEGER :: SUBRGN,SUBTMP,I,POINT,SPACE
!***FIRST EXECUTABLE STATEMENT
! Initialise data structure constants
DIMENS = ISTORE(1)
NRVERT = ISTORE(2)
NIINFO = ISTORE(3)
NRINFO = ISTORE(4)
NRFUNC = ISTORE(5)
NRVACA = ISTORE(6)
BOTTIS = ISTORE(7)
! bottrs = istore(8)
OFFSET = ISTORE(9)
! start = istore(10)
BLOCK = ISTORE(11)
INTREE = ISTORE(12)
INPOOL = ISTORE(13)
HOLES = ISTORE(14)
LOST = ISTORE(15)
!
! Check if something is in the sorted tree
!
IF (INTREE <= 0) THEN
IFAIL = 10011
ELSE
!
! Get the top-record out of the tree
!
SPACE = ISTORE(OFFSET+1)
IF (NRFUNC == 1) THEN
POINT = (SPACE-1)*BLOCK
ELSE
POINT = (SPACE-1)*BLOCK + 1
END IF
ERREST(1:NRFUNC) = RSTORE(POINT+1 : POINT+NRFUNC)
INTAPP(1:NRFUNC) = RSTORE(POINT+NRFUNC+1 : POINT+NRFUNC*2)
POINT = POINT + 2*NRFUNC
DO I = 1,DIMENS
VERTIC(I,1:NRVERT) = RSTORE(POINT+1:POINT+NRVERT)
POINT = POINT + NRVERT
END DO
RRGINF(1:NRINFO) = RSTORE(POINT+1:POINT+NRINFO)
POINT = BOTTIS - NIINFO*SPACE
IRGINF(1:NIINFO) = ISTORE(POINT+1:POINT+NIINFO)
!
IF (SPACE /= INTREE+HOLES+LOST+INPOOL) THEN
!
! Fill the record with zeros.
!
POINT = (SPACE-1)*BLOCK
RSTORE(POINT + 1 : POINT + BLOCK) = 0
POINT = BOTTIS - NIINFO*SPACE
ISTORE(POINT + 1 : POINT + NIINFO) = 0
!
IF (HOLES == NRVACA) THEN
LOST = LOST + 1
ELSE
!
! Save the place of the hole in the heap
!
ISTORE(OFFSET-HOLES) = SPACE
HOLES = HOLES + 1
END IF
END IF
!
! Rearrange the tree
!
SORKEY = RSTORE(1+BLOCK* (ISTORE(OFFSET+INTREE)-1))
INTREE = INTREE - 1
SUBRGN = 1
DO
SUBTMP = 2*SUBRGN
IF (SUBTMP <= INTREE) THEN
IF (SUBTMP /= SUBRGN) THEN
!
! Find max .of left and right child
!
IF (RSTORE(1+BLOCK* (ISTORE(OFFSET+SUBTMP)-1)) < &
RSTORE(1+BLOCK* (ISTORE(OFFSET+SUBTMP+1)- 1))) THEN
SUBTMP = SUBTMP + 1
END IF
END IF
!
! Compare max .child with parent
! If parent is max., then done
!
IF (SORKEY < RSTORE(1+BLOCK* (ISTORE(OFFSET+SUBTMP)- 1)))&
THEN
!
! Move the pointer at position subtmp up the heap.
!
ISTORE(OFFSET+SUBRGN) = ISTORE(OFFSET+SUBTMP)
SUBRGN = SUBTMP
CYCLE
END IF
END IF
EXIT
END DO
!
! Update the pointer
!
IF (INTREE > 0) THEN
ISTORE(OFFSET+SUBRGN) = ISTORE(OFFSET+INTREE+1)
END IF
!
! Save data structure variables
!
ISTORE(12) = INTREE
ISTORE(14) = HOLES
IF ( ISTORE(15) /= LOST ) THEN
ISTORE(15) = LOST
IFAIL = 9999
ELSE
IFAIL = 0
END IF
!
!***END DSGET
!
END IF
RETURN
END SUBROUTINE DSGET
!-----------------------------------------------------------------------
FUNCTION DSFREE(ISTORE) RESULT(FREE) ! INTEGER RESULT
!***BEGIN PROLOGUE DSFREE
!***DATE WRITTEN 900612 (YYMMDD)
!***REVISION DATE 950829 (YYMMDD)
!***AUTHOR
! Ronald Cools, Dept. of Computer Science,
! Katholieke Universiteit Leuven, Celestijnenlaan 200A,
! B-3001 Heverlee, Belgium
! Email: Ronald.Cools@cs.kuleuven.ac.be
!
!***PURPOSE To return the number of records that may be added to the
! data structure before all space is used.
!***DESCRIPTION
! See the description of SUBROUTINE DSINIT
!
!***END PROLOGUE DSFREE
!
! Variables and constants used by DS-procedures only
! --------------------------------------------------
!
! NIINFO = number of integers used to save additional information
! for each subregion
! BOTTIS = length of integer array ISTORE.
! Needed because this heap is also filled up starting from
! the bottom
! BOTTRS = length of the double precision heap
! Only needed for checks
! INTREE = number of subregions in the sorted tree
! INPOOL = number of subregions in the unsorted pool
! LOST = number of records that cannot be accessed any more
! OFFSET : The first pointer to the tree is stored in ISTORE(OFFSET+1)
! BLOCK = number of double precision numbers in a record
!
! Global variables
!
INTEGER, DIMENSION(:), INTENT(IN) :: ISTORE
!
! Local variables
!
! freerh = number of free records in the double precision heap
! freeih = number of free records in the integer heap
!
INTEGER :: FREE
INTEGER :: NIINFO,BOTTIS,BOTTRS,INTREE,INPOOL,LOST,BLOCK,OFFSET
INTEGER :: FREERS,FREEIS
!***FIRST EXECUTABLE STATEMENT
! Initialise data structure constants
NIINFO = ISTORE(3)
BOTTIS = ISTORE(7)
BOTTRS = ISTORE(8)
OFFSET = ISTORE(9)
BLOCK = ISTORE(11)
! Initialise data structure variables
INTREE = ISTORE(12)
INPOOL = ISTORE(13)
LOST = ISTORE(15)
!
FREERS = BOTTRS/BLOCK - INTREE - INPOOL - LOST
FREEIS = (BOTTIS-OFFSET)/ (NIINFO+1) - INTREE - INPOOL - LOST
FREE = MIN(FREERS,FREEIS)
!
!***END DSFREE
!
RETURN
END FUNCTION DSFREE
!-----------------------------------------------------------------------
FUNCTION DSUSED(ISTORE) RESULT(USED) ! INTEGER RESULT
!***BEGIN PROLOGUE DSUSED
!***DATE WRITTEN 900612 (YYMMDD)
!***REVISION DATE 950829 (YYMMDD)
!***AUTHOR
! Ronald Cools, Dept. of Computer Science,
! Katholieke Universiteit Leuven, Celestijnenlaan 200A,
! B-3001 Heverlee, Belgium
! Email: Ronald.Cools@cs.kuleuven.ac.be
!
!***PURPOSE To return the number of records in the data structure.
!
!***DESCRIPTION
! See the description of SUBROUTINE DSINIT
!
!***END PROLOGUE DSUSED
!
! Variables and constants used by DS-procedures only
! --------------------------------------------------
!
! INTREE = number of subregions in the sorted tree
! INPOOL = number of subregions in the unsorted pool
!
! Global variables
!
INTEGER, DIMENSION(:), INTENT(IN) :: ISTORE
!
! Local variables
!
INTEGER :: USED
INTEGER :: INTREE,INPOOL
!***FIRST EXECUTABLE STATEMENT
! Initialise data structure variables
INTREE = ISTORE(12)
INPOOL = ISTORE(13)
!
USED = INTREE + INPOOL
!
!***END DSUSED
!
RETURN
END FUNCTION DSUSED
!-----------------------------------------------------------------------
SUBROUTINE DSSUM(VALUE,ABSERR,ISTORE,RSTORE,IFAIL)
!***BEGIN PROLOGUE DSSUM
!***DATE WRITTEN 901129 (YYMMDD)
!***REVISION DATE 950829 (YYMMDD)
!***AUTHOR
! Ronald Cools, Dept. of Computer Science,
! Katholieke Universiteit Leuven, Celestijnenlaan 200A,
! B-3001 Heverlee, Belgium
! Email: Ronald.Cools@cs.kuleuven.ac.be
!
!***PURPOSE To compute more accurate values of VALUE and ABSERR.
! This is done to reduce the effect of roundoff on final results.
! Large intermediate sums in the computation may course large,
! unnecessary roundoff errors. Thus recomputing the sums of errors
! and estimates and in addition grouping the sums in three groups
! should remove this problem.
!
!***DESCRIPTION
! See the description of SUBROUTINE DSINIT
!
! Input parameters
! ----------------
!
! ISTORE = integer array of dimension (BOTTIS).
! Contains the integers of the records.
! RSTORE = double precision array of dimension (BOTTRS).
! Contains the double precision numbers of the records.
!
! Output parameters
! -----------------
!
! VALUE = double precision array of dimension (NRFUNC)
! Contains approximations to the integrals.
! ABSERR = double precision array of dimension (NRFUNC)
! Contains error estimates.
! IFAIL = integer to indicate success or failure
! IFAIL = 0 for normal termination.
!old IFAIL = 10012 if HOLES is not equal to zero.
!
!***END PROLOGUE DSSUM
!
! Variables and constants used by DS-procedures only
! --------------------------------------------------
!
! DIMENS = dimension of (sub-)regions
! NRVERT = number of vertices to describe a subregion
! NIINFO = number of integers used to save additional information
! for each subregion
! NRINFO = number of double precision numbers used to save additional
! information for each subregion
! NRFUNC = number of integrand functions for which information must
! be stored
! NRVACA = maximum number of pointers to empty spaces in the heap
! that must be stored for later use
! BOTTIS = length of integer array ISTORE.
! Needed because this heap is also filled up starting from
! the bottom
! BOTTRS = length of the double precision heap
! Only needed for checks
! INTREE = number of subregions in the sorted tree
! INPOOL = number of subregions in the unsorted pool
! HOLES = number of pointers to holes in the heap
! 0 <= HOLES <= NRVACA
! LOST = number of records that cannot be accessed any more
! OFFSET : The first pointer to the tree is stored in ISTORE(OFFSET+1)
! START : The first pointer to the pool is stored in ISTORE(START-1)
! BLOCK = number of double precision numbers in a record
!
! Global variables
!
INTEGER, INTENT(OUT) :: IFAIL
INTEGER, DIMENSION(:), INTENT(IN) :: ISTORE
REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: RSTORE
REAL(kind=stnd), DIMENSION(:), INTENT(OUT) :: ABSERR,VALUE
!
! Local variables
!
!
INTEGER :: NRFUNC,INTREE,INPOOL,HOLES,LOST,BLOCK
REAL(kind=stnd), DIMENSION(2) :: SUMVAL, SUMERR
INTEGER :: SBRGNS,I,J,POINT,I1,I2,GROUP,LEFT
!***FIRST EXECUTABLE STATEMENT
! Initialise data structure constants
NRFUNC = ISTORE(5)
BLOCK = ISTORE(11)
! Initialise data structure variables
INTREE = ISTORE(12)
INPOOL = ISTORE(13)
HOLES = ISTORE(14)
LOST = ISTORE(15)
!
! Assume there are no holes
!
! IF (HOLES /= 0) THEN
! IFAIL = 10012
! RETURN
! END IF
SBRGNS = INTREE + INPOOL + LOST + HOLES
DO J = 1,NRFUNC
IF (NRFUNC == 1) THEN
POINT = 1
ELSE
POINT = J + 1
END IF
VALUE(J) = 0
ABSERR(J) = 0
GROUP = SBRGNS**(1.0/3.0) ! This is accurate enough
IF (GROUP**3 /= SBRGNS) THEN
GROUP = GROUP + 1
END IF
LEFT = SBRGNS
DO I2 = 0,SBRGNS - 1,GROUP**2
SUMVAL(2) = 0
SUMERR(2) = 0
DO I1 = 0,MIN(LEFT,GROUP**2) - 1,GROUP
SUMVAL(1) = 0
SUMERR(1) = 0
DO I = 1 + I1 + I2,MIN(LEFT,GROUP) + I1 + I2
SUMVAL(1) = SUMVAL(1) + RSTORE(POINT+NRFUNC)
SUMERR(1) = SUMERR(1) + RSTORE(POINT)
POINT = POINT + BLOCK
END DO
LEFT = LEFT - MIN(LEFT,GROUP)
SUMVAL(2) = SUMVAL(2) + SUMVAL(1)
SUMERR(2) = SUMERR(2) + SUMERR(1)
END DO
VALUE(J) = VALUE(J) + SUMVAL(2)
ABSERR(J) = ABSERR(J) + SUMERR(2)
END DO
END DO
IFAIL = 0
!
!***END DSSUM
!
RETURN
END SUBROUTINE DSSUM
!-----------------------------------------------------------------------
SUBROUTINE DSSTAT(ISTORE,RSTORE)
!***DATE WRITTEN 901129 (YYMMDD)
!***REVISION DATE 970320 (YYMMDD)
!
! Global variables
!
INTEGER, DIMENSION(:), INTENT(IN) :: ISTORE
REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: RSTORE
!
! Global functions
!
! INTEGER :: DSFREE,DSUSED
!
! Local variables
INTEGER :: I,J,POINT,NIINFO,START
INTEGER, DIMENSION(15) :: HIST
!
write(unit=*,fmt=*) "DATA STRUCTURE CONSTANTS:"
write(unit=*,fmt=*) "DIMENS = ",ISTORE(1)
write(unit=*,fmt=*) "NRVERT = ",ISTORE(2)
write(unit=*,fmt=*) "NRFUNC = ",ISTORE(5)
write(unit=*,fmt=*) "NIINFO = ",ISTORE(3)
write(unit=*,fmt=*) "NRINFO = ",ISTORE(4)
write(unit=*,fmt=*) "NRVACA = ",ISTORE(6)
write(unit=*,fmt=*) "BLOCK = ",ISTORE(11)
write(unit=*,fmt=*) "BOTTIS = ",ISTORE(7)
write(unit=*,fmt=*) "BOTTRS = ",ISTORE(8)
write(unit=*,fmt=*) "OFFSET = ",ISTORE(9)
write(unit=*,fmt=*) "START = ",ISTORE(10)
!
write(unit=*,fmt=*) "DATA STRUCTURE VARIABLES:"
write(unit=*,fmt=*) "INTREE = ",ISTORE(12)
write(unit=*,fmt=*) "INPOOL = ",ISTORE(13)
write(unit=*,fmt=*) "HOLES = ",ISTORE(14)
write(unit=*,fmt=*) "LOST = ",ISTORE(15)
write(unit=*,fmt=*) "FREE = ",DSFREE(ISTORE)
!
DO I = 1,15
HIST(I) = 0
END DO
NIINFO = ISTORE(3)
START = ISTORE(7) - niinfo + 2
DO I = START,START - (DSUSED(ISTORE)-1)*NIINFO,-NIINFO
IF (ISTORE(I) < 15) THEN
HIST(ISTORE(I)) = HIST(ISTORE(I)) + 1
ELSE
HIST(15) = HIST(15) + 1
END IF
END DO
write(unit=*,fmt=*) "SUBDIVISION INFORMATION:"
DO I = 1,14
write(unit=*,fmt=*) "RATIO = ",I," -> ",HIST(I)," REGIONS"
END DO
write(unit=*,fmt=*) "RATIO > 14 -> ",HIST(15)," REGIONS"
!
! dump RSTORE to fort.1
!
open (unit=1,status="replace",action="write",file="tmp_realstore")
point = 1
do i=1,istore(12)+istore(13)+istore(14)+istore(15)
write (unit=1,fmt="( "" :"",i3,"":"",30(""-"") )") i
do j = 1,istore(11)
write(unit=1,fmt="(4x,i3,"" -> "",es24.16)") j,rstore(point)
point = point+1
end do
end do
!
! dump ISTORE to fort.2
!
open (unit=2,status="replace",action="write",file="tmp_integerstore")
point = istore(7)
do i=1,istore(12)+istore(13)+istore(14)+istore(15)
write(unit=2,fmt="("" :"",i3,"":"",30(""-""))") i
do j = 1,istore(3)
write(unit=2,fmt="(4x,i3,"" -> "",i10)") j,istore(point)
point = point-1
end do
end do
write(unit=2,fmt=*) "The pointers in the TREE:"
do i = istore(9)+1,istore(9)+istore(12)
write(unit=2,fmt=*) istore(i)
end do
write(unit=2,fmt=*) "The pointers in the POOL:"
do i = istore(10)-1,istore(10)-istore(13),-1
write(unit=2,fmt=*) istore(i)
end do
close(unit=1)
write(unit=*,fmt=*) "Real part of data structure is dumped in file tmp_realstore."
write(unit=*,fmt=*) "Integer part of data structure is dumped in file tmp_integerstore."
close(unit=2)
!
RETURN
END SUBROUTINE DSSTAT
!-----------------------------------------------------------------------
SUBROUTINE DSCOPY(ISTOREIN,RSTOREIN,ISTOREOUT,RSTOREOUT)
!***BEGIN PROLOGUE DSINIT
!***DATE WRITTEN 950612 (YYMMDD)
!***REVISION DATE 990607 (YYMMDD) (bug fix)
!***AUTHOR
! Ronald Cools, Dept. of Computer Science,
! Katholieke Universiteit Leuven, Celestijnenlaan 200A,
! B-3001 Heverlee, Belgium
! Email: Ronald.Cools@cs.kuleuven.ac.be
!
!***PURPOSE To copy one region collection into the other.
INTEGER, DIMENSION(:), INTENT(IN) :: ISTOREIN
INTEGER, DIMENSION(:), INTENT(OUT) :: ISTOREOUT
REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: RSTOREIN
REAL(kind=stnd), DIMENSION(:), INTENT(OUT) :: RSTOREOUT
INTEGER :: RECORDS, NIINFO, NRVACA, BOTTISIN, OFFSET, STARTIN, &
BLOCK, INTREE, INPOOL, HOLES,LOST,BOTTISOUT,BOTTRSOUT,&
STARTOUT
INTEGER, PARAMETER :: CONST=15
! Constants of incoming data structure
NIINFO = ISTOREIN(3)
NRVACA = ISTOREIN(6)
BOTTISIN = ISTOREIN(7)
OFFSET = ISTOREIN(9)
STARTIN = ISTOREIN(10)
BLOCK = ISTOREIN(11)
INTREE = ISTOREIN(12)
INPOOL = ISTOREIN(13)
HOLES = ISTOREIN(14)
LOST = ISTOREIN(15)
RECORDS = INTREE + INPOOL + HOLES + LOST
! Constants of outcoming data structure
BOTTISOUT = size(ISTOREOUT)
BOTTRSOUT = size(RSTOREOUT)
STARTOUT = BOTTISOUT + 1 - ((BOTTISOUT-NRVACA-CONST)/ (1+NIINFO))*NIINFO
! Copy integer part of data structure
ISTOREOUT(1:CONST) = ISTOREIN(1:CONST)
ISTOREOUT(7) = BOTTISOUT
ISTOREOUT(8) = BOTTRSOUT
ISTOREOUT(10) = STARTOUT
ISTOREOUT(OFFSET-HOLES+1:OFFSET) = ISTOREIN(OFFSET-HOLES+1:OFFSET)
ISTOREOUT(OFFSET+1:OFFSET+INTREE) = ISTOREIN(OFFSET+1:OFFSET+INTREE)
ISTOREOUT(STARTOUT-INPOOL:STARTOUT-1) = ISTOREIN(STARTIN-INPOOL:STARTIN-1)
ISTOREOUT(BOTTISOUT-records*niinfo:BOTTISOUT) = ISTOREIN(BOTTISIN-records*niinfo:BOTTISIN)
! Copy real part of data structure
RSTOREOUT(1:BLOCK*records) = rstorein(1:BLOCK*records)
return
end subroutine dscopy
!-----------------------------------------------------------------------
SUBROUTINE DSUPUT(VERTIC,INTAPP,ERREST,IRGINF,RRGINF,ISTORE,RSTORE,IFAIL)
!***BEGIN PROLOGUE DSUPUT
!***DATE WRITTEN 901126 (YYMMDD)
!***REVISION DATE 961206 (YYMMDD)
!***AUTHOR
! Ronald Cools, Dept. of Computer Science,
! Katholieke Universiteit Leuven, Celestijnenlaan 200A,
! B-3001 Heverlee, Belgium
! Email: Ronald.Cools@cs.kuleuven.ac.be
!
!***PURPOSE To add a record to a data structure that stores information
! about the subregions in an adaptive integrator.
! The record is added to an unsorted pool.
!***DESCRIPTION
! See the description of SUBROUTINE DSINIT
!
! Input parameters
! ----------------
!
! VERTIC = double precision array of dimension (DIMENS,NRVERT)
! Contains the vertices that describe a subregion.
! ( VERTIC(1,i),...,VERTIC(DIMENS,i) ) are the coordinates
! of the i-th vertex.
! INTAPP = double precision array of dimension (NRFUNC)
! Contains approximations to the integrals.
! ERREST = double precision array of dimension (NRFUNC)
! Contains error estimates.
! IRGINF = integer array of dimension (NIINFO).
! Contains additional information about the subregion
! RRGINF = double precision array of dimension (NRINFO).
! Contains additional information about the subregion
! ISTORE = integer array of dimension (BOTTIS).
! Contains the integers of the records.
! RSTORE = double precision array of dimension (BOTTRS).
! Contains the double precision numbers of the records.
!
! Output parameters
! -----------------
!
! IFAIL = integer to indicate success or failure
! IFAIL = 0 for normal exit
! IFAIL = 10009 if the integer array ISTORE is full
! IFAIL = 10010 if the double precision array RSTORE is full
! ISTORE = integer array of dimension (BOTTIS).
! Contains the integers of the records.
! RSTORE = double precision array of dimension (BOTTRS).
! Contains the double precision numbers of the records.
!
!***END PROLOGUE DSUPUT
!
! Variables and constants used by DS-procedures only
! --------------------------------------------------
!
! DIMENS = dimension of (sub-)regions
! NRVERT = number of vertices to describe a subregion
! NIINFO = number of integers used to save additional information
! for each subregion
! NRINFO = number of double precision numbers used to save additional
! information for each subregion
! NRFUNC = number of integrand functions for which information must
! be stored
! NRVACA = maximum number of pointers to empty spaces in the heap
! that must be stored for later use
! BOTTIS = length of integer array ISTORE.
! Needed because this heap is also filled up starting from
! the bottom
! BOTTRS = length of the double precision heap
! Only needed for checks
! INTREE = number of subregions in the sorted tree
! INPOOL = number of subregions in the unsorted pool
! HOLES = number of pointers to holes in the heap
! 0 <= HOLES <= NRVACA
! LOST = number of records that cannot be accessed any more
! OFFSET : The first pointer to the tree is stored in ISTORE(OFFSET+1)
! START : The first pointer to the pool is stored in ISTORE(START-1)
! BLOCK = number of double precision numbers in a record
!
! Global variables
!
INTEGER, INTENT(OUT) :: IFAIL
INTEGER, DIMENSION(:), INTENT(IN OUT) :: ISTORE
INTEGER, DIMENSION(:), INTENT(IN) :: IRGINF
REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: INTAPP,ERREST,RRGINF
REAL(kind=stnd), DIMENSION(:), INTENT(IN OUT) :: RSTORE
REAL(kind=stnd), DIMENSION(:,:), INTENT(IN) :: VERTIC
!
! Local variables
!
! SORKEY = sortkey for maintaining the partially sorted tree
! = maximum(errest(1),...,errest(nrfunc)
! SPACE = index to the place were a new record can be
! inserted in the heap
!
INTEGER :: DIMENS,NRVERT,NIINFO,NRINFO,NRFUNC,BOTTIS,BOTTRS,INTREE, &
INPOOL,HOLES,LOST,BLOCK,OFFSET,START
REAL(kind=stnd):: SORKEY
INTEGER :: I,SPACE,POINT
!***FIRST EXECUTABLE STATEMENT
!
! The following initialisation statements are included
! to make the code readable
!
! Initialise data structure constants
DIMENS = ISTORE(1)
NRVERT = ISTORE(2)
NIINFO = ISTORE(3)
NRINFO = ISTORE(4)
NRFUNC = ISTORE(5)
BOTTIS = ISTORE(7)
BOTTRS = ISTORE(8)
OFFSET = ISTORE(9)
START = ISTORE(10)
BLOCK = ISTORE(11)
! Initialise data structure variables
INTREE = ISTORE(12)
INPOOL = ISTORE(13)
HOLES = ISTORE(14)
LOST = ISTORE(15)
!
! Check if enough space is left in the arrays to put in a subregion
!
IF (HOLES <= 0) THEN
IF ((BOTTIS-START+1- (INTREE+INPOOL+LOST)*NIINFO < &
NIINFO) .OR. (START-OFFSET-1-INTREE-INPOOL < 1)) THEN
IFAIL = 10009
ELSE IF (BOTTRS- (INTREE+INPOOL+LOST)*BLOCK < BLOCK) THEN
IFAIL = 10010
RETURN
END IF
END IF
INPOOL = INPOOL + 1
!
! Determine index for new record
!
IF (HOLES <= 0) THEN
SPACE = INTREE + INPOOL + LOST
ELSE
SPACE = ISTORE(OFFSET+1-HOLES)
HOLES = HOLES - 1
END IF
!
! Compute sortkey (in case this record has to be sorted later)
!
SORKEY = MAXVAL(ERREST(1:NRFUNC))
!
! Put the new record in the heap
!
POINT = (SPACE-1)*BLOCK
IF (NRFUNC > 1) THEN
POINT = POINT + 1
RSTORE(POINT) = SORKEY
END IF
RSTORE(POINT+1:POINT+NRFUNC) = ERREST(1:NRFUNC)
RSTORE(POINT+NRFUNC+1 : POINT+NRFUNC*2) = INTAPP(1:NRFUNC)
POINT = POINT + NRFUNC * 2
DO I = 1,DIMENS
RSTORE(POINT+1:POINT+NRVERT) = VERTIC(I,1:NRVERT)
POINT = POINT + NRVERT
END DO
RSTORE(POINT+1:POINT+NRINFO) = RRGINF(1:NRINFO)
POINT = BOTTIS - NIINFO*SPACE
ISTORE(POINT+1:POINT+NIINFO) = IRGINF(1:NIINFO)
!
! Insert the index in the pool
!
ISTORE(START-INPOOL) = SPACE
!
! Save data structure variables
!
ISTORE(13) = INPOOL
ISTORE(14) = HOLES
IFAIL = 0
!
!***END DSUPUT
!
RETURN
END SUBROUTINE DSUPUT
!---------------------------------------------------------------------------
SUBROUTINE DSPINT(ISTORE,RSTORE)
!***BEGIN PROLOGUE DSPINT
!***DATE WRITTEN 901129 (YYMMDD)
!***REVISION DATE 961206 (YYMMDD)
!***AUTHOR
! Ronald Cools, Dept. of Computer Science,
! Katholieke Universiteit Leuven, Celestijnenlaan 200A,
! B-3001 Heverlee, Belgium
! Email: Ronald.Cools@cs.kuleuven.ac.be
!
!***PURPOSE All records in the unsorted part of the data structure
! are put in the sorted part of the data structure.
!
!***DESCRIPTION
! See the description of SUBROUTINE DSINIT
!
! Input parameters
! ----------------
!
! ISTORE = integer array of dimension (BOTTIS).
! Contains the integers of the records.
! RSTORE = double precision array of dimension (BOTTRS).
! Contains the double precision numbers of the records.
!
! Output parameters
! -----------------
!
! ISTORE = integer array of dimension (BOTTIS).
! Contains the integers of the records.
! RSTORE = double precision array of dimension (BOTTRS).
! Contains the double precision numbers of the records.
!
!***END PROLOGUE DSPINT
!
! Variables and constants used by DS-procedures only
! --------------------------------------------------
!
! INTREE = number of subregions in the sorted tree
! INPOOL = number of subregions in the unsorted pool
! OFFSET : The first pointer to the tree is stored in ISTORE(OFFSET+1)
! START : The first pointer to the pool is stored in ISTORE(START-1)
! BLOCK = number of double precision numbers in a record
!
! Global variables
!
INTEGER, DIMENSION(:), INTENT(IN OUT) :: ISTORE
REAL(kind=stnd), DIMENSION(:), INTENT(IN OUT) :: RSTORE
!
! Local variables
!
! SORKEY = sortkey for maintaining the partially sorted tree
! = maximum(errest(1),...,errest(nrfunc)
! SPACE = index to the place were a new record can be
! inserted in the heap
!
INTEGER :: INTREE,INPOOL,BLOCK,OFFSET,START
REAL(kind=stnd):: SORKEY
INTEGER :: SPACE,SUBRGN,SUBTMP,NR
!***FIRST EXECUTABLE STATEMENT
!
! The following initialisation statements are included
! to make the code readable
!
! Initialise data structure constants
OFFSET = ISTORE(9)
START = ISTORE(10)
BLOCK = ISTORE(11)
! Initialise data structure variables
INTREE = ISTORE(12)
INPOOL = ISTORE(13)
!
!
!
DO NR = INPOOL,1,-1
INTREE = INTREE + 1
!
! extract sortkey
!
SPACE = ISTORE(START-NR)
SORKEY = RSTORE((SPACE-1)*BLOCK+1)
!
! Insert the index in the tree
!
SUBRGN = INTREE
DO
SUBTMP = SUBRGN/2
IF (SUBTMP >= 1) THEN
!
! Compare max. child with parent.
! If parent is max, then done.
!
IF (SORKEY > RSTORE(1+ (ISTORE(OFFSET+SUBTMP)-1)*BLOCK)) THEN
!
! Move the pointer at position subtmp down the heap.
!
ISTORE(OFFSET+SUBRGN) = ISTORE(OFFSET+SUBTMP)
SUBRGN = SUBTMP
CYCLE
END IF
END IF
EXIT
END DO
!
! Set the pointer to the new index in the heap.
!
ISTORE(OFFSET+SUBRGN) = SPACE
END DO
INPOOL = 0
!
! Save data structure variables
!
ISTORE(12) = INTREE
ISTORE(13) = INPOOL
!
!***END DSPINT
!
RETURN
END SUBROUTINE DSPINT
!----------------------------------------------------------------------------
END MODULE DS_ROUTINES
SHAR_EOF
fi # end of overwriting check
if test -f 'error_handling.f90'
then
echo shar: will not over-write existing file "'error_handling.f90'"
else
cat << "SHAR_EOF" > 'error_handling.f90'
! This file is F-compatible, except for upper/lower case conventions.
!--------------------------------------------------------------------
MODULE Error_Handling
Implicit NONE
PUBLIC :: Print_Error, Handle_Error
PRIVATE :: Message
INTEGER, PRIVATE, PARAMETER :: English = 1, &
MESSAGE_LENGHT = 51
CONTAINS
FUNCTION Message( LANGUAGE, NUMBER )RESULT(text)
INTEGER, INTENT(IN) :: NUMBER, LANGUAGE
CHARACTER (LEN=MESSAGE_LENGHT) :: text
SELECT CASE (LANGUAGE)
CASE(English)
SELECT CASE (NUMBER)
!
! Error messages from the Check_Input Module
!
CASE (1) ! 7 < INFORM < 16384
text = "Wrong input parameters for CUBATR. "
CASE (2) ! INFORM >= 8192
text = "- This happend during a restart. "
CASE (3) ! INFORM = 8192 (should never occur)
text = "-> There is nothing to restart from. "
CASE (8) ! INFORM = 256
text = "-> Wrong limits on the number of evaluations. "
CASE (9) ! INFORM = 512
text = "-> Reliability parameter TUNE > 1 or < 0. "
CASE (10) ! INFORM = 1024
text = "-> Requested accuracy must be nonnegative. "
CASE (11) ! INFORM = 2048
text = "-> On entry, IFAIL must be -1, 0 or 1. "
CASE (12) ! INFORM = 4096
text = "-> On entry, |JOB| must be 0, 1, 2 or 11. "
!
! Error messages when RESTART = false
!
CASE (13) ! INFORM = 8
text = "-> The DIMension must be at least 1 "
CASE (14) ! INFORM = 16
text = "-> The NUM of FUNctions must be positive. "
CASE (15) ! INFORM = 32
text = "-> The NUMber of ReGioNs must be positive. "
CASE (16) ! INFORM = 64
text = "-> No support for this type of region. "
CASE (17) ! INFORM = 128
text = "-> For DIMension > 3, only JOB = 1 is implemented "
!
! Error messages when RESTART = true
!
CASE (18) ! INFORM = 8
text = "-> The DIMension may not change for a restart. "
CASE (19) ! INFORM = 16
text = "-> The NUM of FUNctions may not be changed. "
CASE (20) ! INFORM = 32
text = "-> The length of the integer workspace was changed."
CASE (21) ! INFORM = 64
text = "-> The length of the real workspace was changed. "
CASE (22) ! INFORM = 128
text = "-> Unbelievable low length of integer workspace. "
!
! Error messages from Global_Adapt
!
CASE (23) ! INFORM = 1
text = " -> Allowed number of function evaluations reached."
CASE (24) ! INFORM = 2
text = " -> Work space is full. "
CASE (25) ! INFORM = 3
text = " -> Can't restart with extrapolation after JOB/=2. "
CASE (26) ! INFORM = 4
text = " -> fail = 4 , no meaning allocated. "
CASE (27) ! INFORM = 5
text = " -> Rule_: No support for this type of region. "
CASE (28) ! INFORM = 6
text = " -> Divide: No support for this type of region. "
CASE (29) ! INFORM = 7
text = " -> Divide: No support for this subdivision. "
CASE (30) ! INFORM >= 16384
text = " -> DS_Routines: Internal Error => Consult experts."
CASE DEFAULT
text = " -> Error_Handling: Error => Consult experts. "
END SELECT
END SELECT
RETURN
END FUNCTION Message
!---------------------------------------------------------------------------
SUBROUTINE Print_Error(INFO)
INTEGER, INTENT(IN) :: INFO
INTEGER, PARAMETER :: MAXERR=12
INTEGER :: I,ERRNUM,MESNR,OFSET,Inform,Language
!
Language = English
Inform = INFO
! IF (NAME == "CUBATR") THEN
IF (Inform < 2**(MAXERR+1)) THEN
IF (Inform >= 8) THEN
write(unit=*,fmt=*) Message(Language,1)
IF (Inform >= 2** (MAXERR+1)) THEN
write(unit=*,fmt=*) Message(Language,2)
Inform = Inform - 2** (MAXERR+1)
IF (Inform == 0) THEN
write(unit=*,fmt=*) Message(Language,3)
END IF
OFSET = 15
ELSE
OFSET = 10
END IF
!
! Wrong input parameters
!
ERRNUM = 2**MAXERR
DO I = MAXERR,3,-1
IF (Inform >= ERRNUM) THEN
Inform = Inform - ERRNUM
IF (I >= 8) THEN
MESNR = I
ELSE
MESNR = OFSET + I
END IF
write(unit=*,fmt=*) Message(Language,MESNR)
END IF
ERRNUM = ERRNUM/2
END DO
END IF
!
! Errors from integration procedure
!
IF (Inform > 0) THEN
write(unit=*,fmt=*) Message(Language,Inform+22)
END IF
ELSE
!
! Errors from DS_routines
!
write(unit=*,fmt=*) Message(Language,30)
write(unit=*,fmt=*) " Internal error with code ", Inform
END IF
RETURN
END SUBROUTINE Print_Error
!---------------------------------------------------------------------------
SUBROUTINE Handle_Error(Inform,IFAIL)
INTEGER, INTENT(IN) :: Inform
INTEGER, INTENT(IN OUT), OPTIONAL :: IFAIL
IF (Inform /= 0) THEN
IF (PRESENT(IFAIL)) THEN
SELECT CASE (IFAIL)
CASE (1)
! Soft silent error: do nothing
IFAIL = Inform
RETURN
CASE (-1)
! Soft noisy error
CALL Print_Error(Inform)
IFAIL = Inform
RETURN
CASE (0)
! Hard noisy error
CALL Print_Error(Inform)
write(unit=*,fmt=*) "Hard error: program terminated"
STOP ! "Hard error: program terminated"
END SELECT
ELSE
! Soft noisy error
CALL Print_Error(Inform)
RETURN
END IF
ELSE
IF (PRESENT(IFAIL)) THEN
IFAIL = 0
END IF
END IF
RETURN
END SUBROUTINE Handle_Error
END MODULE Error_Handling
SHAR_EOF
fi # end of overwriting check
if test -f 'global_all.f90'
then
echo shar: will not over-write existing file "'global_all.f90'"
else
cat << "SHAR_EOF" > 'global_all.f90'
MODULE Global_Adaptive_Algorithm
USE Precision_Model
USE internal_types
USE Volume_Computation
USE Region_Processor
Implicit NONE
PRIVATE
PUBLIC :: Global_Adapt, Global_Adapt_Extrap
PRIVATE :: Epsalg
CONTAINS
SUBROUTINE Global_Adapt(DIMENS,CINFO,UINFO,NRVERT,NIINFO,NRINFO, &
VERTIC,RGTYPE,Integrand,RESTART,VALUE, &
ABSERR,NEVAL,IFAIL,RSTORE,ISTORE)
USE DS_ROUTINES, ONLY: DSGET, DSSPUT, DSSUM, DSFREE
!***BEGIN PROLOGUE Global_Adapt
!***DATE WRITTEN 901114 (YYMMDD)
!***REVISION DATE 910503 (YYMMDD)
!***REVISION DATE 950503 (YYMMDD) (Fortran90 transformation)
!***REVISION DATE 970611 (YYMMDD) (more Fortran90)
!***REVISION DATE 980324 (YYMMDD) (MDIV removed)
!***AUTHOR
! Ronald Cools, Dept. of Computer Science,
! Katholieke Universiteit Leuven, Celestijnenlaan 200A,
! B-3001 Heverlee, Belgium
! Email: Ronald.Cools@cs.kuleuven.ac.be
!
!***PURPOSE Computation of integrals over a collection of regions.
!
!***DESCRIPTION
! Global_Adapt repeatedly
! subdivides the region with greatest estimated error
! and estimates the integrals and the errors over the
! new sub-regions until the error request is met or
! MAXPTS function evaluations have been used.
!
! Input parameters
! ----------------
!
! DIMENS Integer.
! The dimension of the region of integration.
! NRVERT Integer.
! The number of vertices to determine a region.
! NRSUB Integer.
! A region is divided into NRSUB subregions.
! NUMFUN Integer.
! Number of components of the integral.
! NIINFO Integer.
! The number of integers used to save information about
! the region.
! Conventions for info-record:
! info-record(5) = 1 if there was asymptotic behaviour when the
! region was processed before.
! = 0 otherwise
! info-record(4) = information on best direction for future division
! info-record(3) = number of the original region where this
! region is a part of
! info-record(2) = (volume of orinal region)/
! (volume of this region)
! info-record(1) = type of region
! NRINFO Integer.
! The number of reals used to save information about
! the region.
! VERTIC Real array of dimension (DIMENS,NRVERT,NUMRGN).
! VER(1,K,L), VER(2,K,L),..., VER(DIMENS,K,L) are the x, y, ...
! coordinates respectively of vertex K of region L, where
! K = 1,...,NRVERT and L = 1,...,NUMRGN.
! RGTYPE Integer array of dimension (NUMRGN).
! RGTYPE(L) describes the type of region L.
! NUMRGN Integer.
! The number of given regions.
! MINPTS Integer.
! The minimum allowed number of function evaluations.
! MAXPTS Integer.
! The maximum allowed number of function evaluations.
! Integrand Externally declared function for computing
! all components of the integrand at the given
! evaluation point.
! It must be compatible with the following interface:
! INTERFACE
! FUNCTION Integrand(NUMFUN,X)
! USE Precision_Model
! INTEGER NUMFUN
! REAL(stnd) X(:)
! REAL(stnd) Integrand(NUMFUN)
! END
! END INTERFACE
! Input parameters:
! X(1) The x-coordinate of the evaluation point.
! X(2) The y-coordinate of the evaluation point.
! ...
! X(DIMENS) The z-coordinate of the evaluation point.
! NUMFUN Integer that defines the number of
! components of I.
!
! EPSABS Real.
! Requested absolute error.
! EPSREL Real.
! Requested relative error.
!
! RESTART Boolean.
! If RESTART = FALSE, this is the first attempt to compute
! the integral.
! If RESTART = TRUE,
! then we restart a previous attempt.
! In this case the only parameters for Global_Adapt that may
! be changed (with respect to the previous call of Global_Adapt)
! are MINPTS, MAXPTS, EPSABS, EPSREL and RESTART.
! MINPTS Integer.
! Minimum number of integrand function evaluations.
! MAXPTS Integer.
! Maximum number of integrand function evaluations.
!
! Output parameters
! -----------------
!
! VALUE Real array of dimension NUMFUN.
! Approximations to all components of the integral.
! (It is an input parameter if RESTART=.true.)
! ABSERR Real array of dimension NUMFUN.
! Estimates of absolute errors.
! (It is an input parameter if RESTART=.true.)
! NEVAL Integer.
! Number of function evaluations used by Global_Adapt.
! IFAIL Integer.
! IFAIL = 0 for normal exit.
!
! ABSERR(K) <= EPSABS or
! ABSERR(K) <= ABS(VALUE (K))*EPSREL with MAXPTS or less
! function evaluations for all values of K,
! 1 <= K <= NUMFUN .
!
! IFAIL = 1 if MAXPTS was too small for Global_Adapt
! to obtain the required accuracy. In this case Global_Adapt
! returns values of VALUE with estimated absolute
! errors ABSERR.
!
! IFAIL = 2 if the region collection was not large enough
! to obtain the required accuracy. In this case Global_Adapt
! returns values of VALUE with estimated absolute
! errors ABSERR.
!
! IFAIL > 10000 : Failure of the heap-maintaining routines.
! This should never happen !
! If IFAIL = 1000X this is IFAIL = X of DSINIT.
!
!***ROUTINES CALLED Process_Region,DSSPUT,DSGET,DSFREE
!***END PROLOGUE Global_Adapt
!
!
! Global variables
!
INTERFACE
FUNCTION Integrand(NUMFUN,X) RESULT(Value)
USE Precision_Model
INTEGER, INTENT(IN) :: NUMFUN
REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: X
REAL(kind=stnd), DIMENSION(NUMFUN) :: Value
END FUNCTION Integrand
END INTERFACE
TYPE(integrator_info), INTENT(IN) :: CINFO
TYPE(user_info), INTENT(IN) :: UINFO
LOGICAL, INTENT(IN) :: RESTART
INTEGER, INTENT(IN) :: DIMENS,NRVERT,NIINFO,NRINFO
INTEGER, DIMENSION(:), INTENT(IN) :: RGTYPE
INTEGER, INTENT(OUT) :: NEVAL,IFAIL
INTEGER, DIMENSION(:), INTENT(IN OUT) :: ISTORE
REAL(kind=stnd), DIMENSION(:,:,:), INTENT(IN) :: VERTIC
REAL(kind=stnd), DIMENSION(:), INTENT(IN OUT):: VALUE ,ABSERR
REAL(kind=stnd), DIMENSION(:), INTENT(IN OUT):: RSTORE
!
! Local automatic variables.
!
INTEGER, DIMENSION(NIINFO) :: INFOLD
INTEGER, DIMENSION(NIINFO,CINFO%NRSUB) :: INFNEW
REAL(kind=stnd), DIMENSION(DIMENS,NRVERT) :: VEROLD
REAL(kind=stnd), DIMENSION(DIMENS,NRVERT,CINFO%NRSUB) :: VERNEW
REAL(kind=stnd), DIMENSION(UINFO%NUMFUN) :: VALOLD, ERROLD
REAL(kind=stnd), DIMENSION(UINFO%NUMFUN,CINFO%NRSUB) :: VALNEW, ERRNEW
REAL(kind=stnd), DIMENSION(NRINFO) :: RINFOL
REAL(kind=stnd), DIMENSION(NRINFO,CINFO%NRSUB) :: RINFNE
!
! Local variables
!
! NUM Integer.
! The number of points used by the basic rule in DRLGIN.
! MAXSUB Integer.
! The maximum number of regions that Process_Region may return
! OUTSUB Integer
! The number of regions returned by Process_Region
!
INTEGER :: I,INFORM,L,NUM,MAXSUB,OUTSUB,NUMFUN
!
!***FIRST EXECUTABLE STATEMENT
!
NUMFUN = UINFO%NUMFUN
NEVAL = 0
IF (.NOT.RESTART) THEN
!
! Initialize the set of given regions.
! Compute estimates for integrals and errors for these regions.
!
VALUE = 0
ABSERR = 0
DO I = 1,UINFO%NUMRGN
!
! Initialise a region record
!
RINFOL(1) = VOLUME(DIMENS,RGTYPE(I),VERTIC(:,:,I))
RINFOL(2:NRINFO) = 0 ! assignment to zero-sized array is legal
INFOLD(1) = RGTYPE(I)
INFOLD(2) = 1
INFOLD(3) = I
INFOLD(4:NIINFO) = 0
!
! Apply the basic rule to each given region.
!
CALL Process_Region(DIMENS,CINFO,NRVERT,1,NUMFUN,Integrand, &
VERTIC(:,:,I),INFOLD,RINFOL, &
UINFO%MAXPTS-NEVAL,OUTSUB,VERNEW, &
INFNEW,RINFNE,VALNEW,ERRNEW,NUM,INFORM)
IF (INFORM /= 0) THEN
IFAIL = INFORM
RETURN
END IF
NEVAL = NEVAL + NUM
!
! Adjust VALUE and ABSERR.
!
VALUE = VALUE + VALNEW(:,1)
ABSERR = ABSERR + ERRNEW(:,1)
!
! Store the results.
!
CALL DSSPUT(VERTIC(:,:,I),VALNEW(:,1),ERRNEW(:,1), &
INFNEW(:,1),RINFNE(:,1),ISTORE,RSTORE,IFAIL)
IF (IFAIL /= 0) THEN
RETURN
END IF
END DO
END IF
!
! Check for termination:
! IF the number of points used is smaller than a user suplied minimum
! OR
! IF the estimated error of one of the approximations is too large,
! THEN continue the proces.
!
DO
IF (NEVAL >= UINFO%MINPTS) THEN
IF ( ALL( ABSERR < MAX(UINFO%EPSREL*ABS(VALUE),UINFO%EPSABS) ) ) THEN
IFAIL = 0
IF ( .NOT. RESTART ) THEN
CALL DSSUM(VALUE ,ABSERR,ISTORE,RSTORE,IFAIL)
END IF
RETURN
END IF
END IF
!
! If there is enough space to do further subdivisions
! and it is allowed to do more function evaluations ...
! Determine the maximum number of subregions after subdivsion
! It should be o.k. to use dsfree()+1 but this is safer.
MAXSUB = MIN(DSFREE(ISTORE),cinfo%NRSUB)
IF ((MAXSUB >= 1) .AND. (UINFO%MAXPTS > NEVAL)) THEN
!
! ... then prepare to apply the basic rule over each subregion
! produced by dividing the region with greatest error.
!
!
! Pick the region from the collection.
!
CALL DSGET(VEROLD,VALOLD,ERROLD,INFOLD,RINFOL,ISTORE,RSTORE,IFAIL)
IF (IFAIL > 0) THEN
RETURN
END IF
!
! Process the region
!
CALL Process_Region(DIMENS,CINFO,NRVERT,MAXSUB,NUMFUN,Integrand,&
VEROLD,INFOLD,RINFOL,UINFO%MAXPTS-NEVAL,OUTSUB, &
VERNEW,INFNEW,RINFNE,VALNEW,ERRNEW,NUM,INFORM)
NEVAL = NEVAL + NUM
IF (INFORM /= 0) THEN
!
! Restore data structure
!
CALL DSSPUT(VEROLD,VALOLD,ERROLD,INFOLD,RINFOL,ISTORE, &
RSTORE,IFAIL)
CALL DSSUM(VALUE ,ABSERR,ISTORE,RSTORE,IFAIL)
IFAIL = INFORM
RETURN
END IF
!
! Adjust VALUE and ABSERR
!
VALUE = VALUE - VALOLD + SUM( VALNEW(:,1:OUTSUB), 2 )
ABSERR = ABSERR - ERROLD + SUM( ERRNEW(:,1:OUTSUB), 2 )
!
! Store the results.
!
DO L = 1,OUTSUB
CALL DSSPUT(VERNEW(:,:,L),VALNEW(:,L),ERRNEW(:,L), &
INFNEW(:,L),RINFNE(:,L),ISTORE,RSTORE,IFAIL)
IF (IFAIL /= 0) THEN
RETURN
END IF
END DO
ELSE
!
! ... else there was not enough space available to reach the
! requested accuracy or the maximum number of points
! allowed is reached.
!
CALL DSSUM(VALUE ,ABSERR,ISTORE,RSTORE,IFAIL)
IF (UINFO%MAXPTS <= NEVAL) THEN
IFAIL = 1
ELSE
IFAIL = 2
END IF
RETURN
END IF
END DO ! Check for termination
RETURN
END SUBROUTINE Global_Adapt
SUBROUTINE Global_Adapt_Extrap(DIMENS,CINFO,UINFO,NRVERT,NIINFO,NRINFO,&
VERTIC,RGTYPE,Integrand,RESTART,VALUE, &
ABSERR,NEVAL,IFAIL,RSTORE,ISTORE,MEM)
USE DS_ROUTINES, ONLY: DSGET, DSSPUT, DSSUM, DSFREE, DSUPUT, DSPINT
!***BEGIN PROLOGUE Global_Adapt_Extrap
!***DATE WRITTEN 9xxxxx (YYMMDD)
!***REVISION DATE 970613 (YYMMDD)
!***REVISION DATE 980324 (YYMMDD)
!***REVISION DATE 990609 (YYMMDD)
!***AUTHOR
! Ronald Cools, Dept. of Computer Science,
! Katholieke Universiteit Leuven, Celestijnenlaan 200A,
! B-3001 Heverlee, Belgium
! Email: Ronald.Cools@cs.kuleuven.ac.be
!
!***PURPOSE Computation of integrals over a collection of regions.
!
!***DESCRIPTION
! Global_Adapt_Extrap repeatedly subdivides the large
! region with greatest estimated error, estimates the
! integrals and the errors over the new sub-regions
! and sometimes employs the epsilon algorithm to speed
! up convergence, until the error request is met or
! MAXPTS function evaluations have been used.
!
! Input parameters
! ----------------
!
! DIMENS Integer.
! The dimension of the region of integration.
! NRVERT Integer.
! The number of vertices to determine a region.
! NRSUB Integer.
! A region is divided into NRSUB subregions.
! NUMFUN Integer.
! Number of components of the integral.
! NIINFO Integer.
! The number of integers used to save information about
! the region.
! Conventions for info-record:
! info-record(5) = 1 if there was asymptotic behaviour when the
! region was processed before.
! = 0 otherwise
! info-record(4) = information on best direction for future division
! info-record(3) = number of the original region where this
! region is a part of
! info-record(2) = (volume of original region)/
! (volume of this region)
! info-record(1) = type of region
! NRINFO Integer.
! The number of reals used to save information about
! the region.
! VERTIC Real array of dimension (DIMENS,NRVERT,NUMRGN).
! VER(1,K,L), VER(2,K,L),..., VER(DIMENS,K,L) are the x, y, ...
! coordinates respectively of vertex K of region L, where
! K = 1,...,NRVERT and L = 1,...,NUMRGN.
! RGTYPE Integer array of dimension (NUMRGN).
! RGTYPE(L) describes the type of region L.
! NUMRGN Integer.
! The number of given regions.
! MINPTS Integer.
! The minimum allowed number of function evaluations.
! MAXPTS Integer.
! The maximum allowed number of function evaluations.
! Integrand Externally declared function for computing
! all components of the integrand at the given
! evaluation point.
! It must be compatible with the following interface:
! INTERFACE
! FUNCTION Integrand(NUMFUN,X)
! USE Precision_Model
! INTEGER NUMFUN
! REAL(kind=stnd) X(:)
! REAL(kind=stnd) Integrand(NUMFUN)
! END
! END INTERFACE
! Input parameters:
! X(1) The x-coordinate of the evaluation point.
! X(2) The y-coordinate of the evaluation point.
! ...
! X(DIMENS) The z-coordinate of the evaluation point.
! NUMFUN Integer that defines the number of
! components of I.
!
! EPSABS Real.
! Requested absolute error.
! EPSREL Real.
! Requested relative error.
!
! RESTART Boolean.
! If RESTART = FALSE, this is the first attempt to compute
! the integral.
! If RESTART = TRUE,
! then we restart a previous attempt.
! In this case the only parameters for Global_Adapt_Extrap that may
! be changed (with respect to the previous call of Global_Adapt_Extrap)
! are MINPTS, MAXPTS, EPSABS, EPSREL and RESTART.
! MINPTS Integer.
! Minimum number of integrand function evaluations.
! MAXPTS Integer.
! Maximum number of integrand function evaluations.
!
! Output parameters
! -----------------
!
! VALUE Real array of dimension NUMFUN.
! Approximations to all components of the integral.
! (It is an input parameter if RESTART=.true.)
! ABSERR Real array of dimension NUMFUN.
! Estimates of absolute errors.
! (It is an input parameter if RESTART=.true.)
! NEVAL Integer.
! Number of function evaluations used by Global_Adapt_Extrap.
! IFAIL Integer.
! IFAIL = 0 for normal exit.
!
! ABSERR(K) <= EPSABS or
! ABSERR(K) <= ABS(VALUE (K))*EPSREL with MAXPTS or less
! function evaluations for all values of K,
! 1 <= K <= NUMFUN .
!
! IFAIL = 1 if MAXPTS was too small for Global_Adapt_Extrap
! to obtain the required accuracy. In this case Global_Adapt_Extrap
! returns values of VALUE with estimated absolute
! errors ABSERR.
!
! IFAIL = 2 if the region collection was not large enough
! to obtain the required accuracy. In this case Global_Adapt_Extrap
! returns values of VALUE with estimated absolute
! errors ABSERR.
!
! IFAIL > 10000 : Failure of the heap-maintaining routines.
! This should never happen !
! If IFAIL = 1000X this is IFAIL = X of DSINIT.
!
!***ROUTINES CALLED Process_Region,DSSPUT,DSGET,DSFREE
!***END PROLOGUE Global_Adapt_Extrap
!
!
! Global variables
!
INTERFACE
FUNCTION Integrand(NUMFUN,X) RESULT(Value)
USE Precision_Model
INTEGER, INTENT(IN) :: NUMFUN
REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: X
REAL(kind=stnd), DIMENSION(NUMFUN) :: Value
END FUNCTION Integrand
END INTERFACE
TYPE(integrator_info), INTENT(IN) :: CINFO
TYPE(user_info), INTENT(IN) :: UINFO
TYPE(epsalg_mem), INTENT(IN OUT) :: MEM
LOGICAL, INTENT(IN) :: RESTART
INTEGER, INTENT(IN) :: DIMENS,NRVERT,NIINFO,NRINFO
INTEGER, DIMENSION(:), INTENT(IN) :: RGTYPE
INTEGER, INTENT(OUT) :: NEVAL,IFAIL
INTEGER, DIMENSION(:), INTENT(IN OUT) :: ISTORE
REAL(kind=stnd), DIMENSION(:,:,:), INTENT(IN) :: VERTIC
REAL(kind=stnd), DIMENSION(:), INTENT(IN OUT):: VALUE , ABSERR
REAL(kind=stnd), DIMENSION(:), INTENT(IN OUT):: RSTORE
!
! Local automatic variables.
!
INTEGER, DIMENSION(NIINFO) :: INFOLD
INTEGER, DIMENSION(NIINFO,CINFO%NRSUB) :: INFNEW
REAL(kind=stnd), DIMENSION(DIMENS,NRVERT) :: VEROLD
REAL(kind=stnd), DIMENSION(DIMENS,NRVERT,CINFO%NRSUB) :: VERNEW
REAL(kind=stnd), DIMENSION(UINFO%NUMFUN) :: VALOLD, ERROLD, &
BNDEC, ERLAST, ERRO4, ERRBND
REAL(kind=stnd), DIMENSION(UINFO%NUMFUN,CINFO%NRSUB) :: VALNEW,ERRNEW
REAL(kind=stnd), DIMENSION(NRINFO) :: RINFOL
REAL(kind=stnd), DIMENSION(NRINFO,CINFO%NRSUB) :: RINFNE
!
! Local variables
!
! NUM Integer.
! The number of points used by the basic rule in DRLGIN.
! MAXSUB Integer.
! The maximum number of regions that Process_Region may return
! OUTSUB Integer
! The number of regions returned by Process_Region
! NRRCOPY Integer array.
! Number of elements in RCOPY
! ERLARG Real array
! The sum of the error-estimates of the 'big' regions
! MAXERRORPOOL Real
! The maximum error over a 'small' region
!
INTEGER :: I,INFORM,J,L,OUTSUB,STATUS
INTEGER :: NUM,MAXSUB,NUMFUN,NRES
LOGICAL :: ready2extrap
REAL(kind=stnd) :: MAXHELP
REAL(kind=stnd), PARAMETER :: EPRN = 5.0_stnd*EPSILON(MAXHELP)
!
!***FIRST EXECUTABLE STATEMENT
!
NUMFUN = UINFO%NUMFUN
NEVAL = 0
NRES = 0
IF (.NOT.RESTART) THEN
!
! Initialize the set of given regions.
! Compute estimates for integrals and errors for these regions.
!
IF ( ASSOCIATED(MEM%RCOPY) ) THEN
DEALLOCATE( MEM%RCOPY,MEM%NRRCOPY,MEM%RESLA,MEM%ERLARG, &
MEM%RESULT1,MEM%ABSERR1 )
END IF
VALUE = 0
ABSERR = 0
DO I = 1,UINFO%NUMRGN
!
! Initialise a region record
!
RINFOL(1) = VOLUME(DIMENS,RGTYPE(I),VERTIC(:,:,I))
RINFOL(2:NRINFO) = 0
INFOLD(1) = RGTYPE(I)
INFOLD(2) = 1
INFOLD(3) = I
INFOLD(4:NIINFO) = 0
!
! Apply the basic rule to each given region.
!
CALL Process_Region(DIMENS,CINFO,NRVERT,1,NUMFUN,Integrand, &
VERTIC(:,:,I),INFOLD,RINFOL,UINFO%MAXPTS-NEVAL, &
OUTSUB,VERNEW,INFNEW,RINFNE,VALNEW,ERRNEW,NUM,INFORM)
IF (INFORM /= 0) THEN
IFAIL = INFORM
RETURN
END IF
NEVAL = NEVAL + NUM
!
! Adjust VALUE and ABSERR.
!
VALUE = VALUE + VALNEW(:,1)
ABSERR = ABSERR + ERRNEW(:,1)
!
! Store the results.
!
CALL DSSPUT(VERTIC(:,:,I),VALNEW(:,1),ERRNEW(:,1), &
INFNEW(:,1),RINFNE(:,1),ISTORE,RSTORE,IFAIL)
IF (IFAIL /= 0) THEN
write(unit=*,fmt=*) "DSSPUT error 4"
STOP
END IF
END DO
END IF
IF (NEVAL >= UINFO%MINPTS) THEN
IF ( ALL( ABSERR < MAX(UINFO%EPSREL*ABS(VALUE),UINFO%EPSABS) ) ) THEN
IFAIL = 0
IF ( .NOT. RESTART ) THEN
CALL DSSUM(VALUE,ABSERR,ISTORE,RSTORE,IFAIL)
END IF
RETURN
END IF
END IF
IF ( ( .NOT. RESTART ) .OR. ( RESTART .AND. ( .NOT. ASSOCIATED(MEM%RCOPY) ) ) ) THEN
ALLOCATE( MEM%RCOPY(EPSTABLENGHT,UINFO%NUMFUN),MEM%RESLA(UINFO%NUMFUN,3), &
MEM%ERLARG(UINFO%NUMFUN), MEM%NRRCOPY(UINFO%NUMFUN), &
MEM%RESULT1(UINFO%NUMFUN),MEM%ABSERR1(UINFO%NUMFUN), &
STAT=status )
IF (status /= 0) THEN
write(unit=*,fmt=*) "Problem allocating real workspace."
STOP
END IF
MEM%RESLA = 0 ! RC 23-7-2001
MEM%NRRCOPY = 1
MEM%DIVLEVEL = 2
MEM%ERRORMAXPOOL = 0
MEM%RCOPY (1,:) = VALUE
MEM%ERLARG = ABSERR
MEM%HEURISTIC_USED = .FALSE.
MEM%EPSABS = UINFO%EPSABS
MEM%EPSREL = UINFO%EPSREL
ELSE
CALL DSSUM(VALUE,ABSERR,ISTORE,RSTORE,IFAIL)
IF ( ((UINFO%EPSABS < MEM%EPSABS) .OR. (UINFO%EPSREL < MEM%EPSREL)) &
.AND. MEM%HEURISTIC_USED ) THEN
!
! Restarting with higher precision requests might confuse
! the heuristic. Hence a new extrapolation table is started!
! This is reliable, but usually very expensive.
! The advice is NOT to use this!
!
MEM%NRRCOPY = 1
MEM%DIVLEVEL = 2
MEM%ERRORMAXPOOL = 0 ! This is redundant
MEM%RCOPY (1,:) = VALUE
MEM%ERLARG = ABSERR
MEM%HEURISTIC_USED = .FALSE.
MEM%EPSABS = UINFO%EPSABS
MEM%EPSREL = UINFO%EPSREL
END IF
END IF
!
! End of preparation. Now we can really start
!
CALL DSGET(VEROLD,VALOLD,ERROLD,INFOLD,RINFOL,ISTORE,RSTORE,IFAIL)
ready2extrap = .false.
DO
!
! If there is enough space to do further subdivisions
! and it is allowed to do more function evaluations ...
! Determine the maximum number of subregions after subdivsion
! It should be o.k. to use dsfree()+1 but this is safer.
!
MAXSUB = MIN(DSFREE(ISTORE),cinfo%NRSUB)
IF ( (CINFO%UNIFORM_SUBDIV .AND. (MAXSUB /= cinfo%NRSUB)) .OR. &
( MAXSUB < 2) .OR. (UINFO%MAXPTS <= NEVAL)) THEN
!
! ... there was not enough space available to reach the
! requested accuracy or the maximum number of points
! allowed is reached.
!
CALL DSSPUT(VEROLD,VALOLD,ERROLD,INFOLD,RINFOL,ISTORE,RSTORE,IFAIL)
CALL DSSUM(VALUE,ABSERR,ISTORE,RSTORE,IFAIL)
IF ( ALL(MEM%NRRCOPY > 3) ) THEN ! Why 3 in this statement ?
IF ( ALL(MEM%ABSERR1 < ABSERR) ) THEN ! Refine
ABSERR = MEM%ABSERR1
VALUE = MEM%RESULT1
END IF
END IF
IFAIL = 1
RETURN
ELSE
! ... then prepare to apply the basic rule over each subregion
! produced by dividing the region with greatest errors.
!
I = 1 ! While no parallel computing is implemented yet
IF ( .NOT. ready2extrap ) THEN
IF (MAXVAL(ABS(ERROLD)) < MEM%ERRORMAXPOOL ) THEN
!
! Process the region
!
DO J = 1, UINFO%NUMFUN
ERRBND(J) = MAX(UINFO%EPSABS,UINFO%EPSREL*ABS(VALUE(J)),EPRN*ABS(VALUE(J)))
BNDEC(J) = MAX( EPRN*(ABS(VALUE(J))), &
MIN(0.1_stnd*ERRBND(J),0.001_stnd*ABS(VALUE(J))))
END DO
! The following test is the reason why restarting is so difficult.
ready2extrap = ALL(MEM%ERLARG < BNDEC)
IF ( ready2extrap ) THEN
!
! Ready for an extrapolation step. Restore first.
!
MEM%HEURISTIC_USED = .TRUE.
CALL DSSPUT(VEROLD,VALOLD,ERROLD, &
INFOLD,RINFOL,ISTORE,RSTORE,IFAIL)
IF ( IFAIL /= 0 ) THEN
write(unit=*,fmt=*) "DSSPUT-1 error ",ifail
STOP
END IF
END IF
END IF
IF ( .NOT. ready2extrap ) THEN
CALL Process_Region(DIMENS,CINFO,NRVERT,MAXSUB,NUMFUN, &
Integrand,VEROLD,INFOLD, &
RINFOL,UINFO%MAXPTS-NEVAL,OUTSUB, &
VERNEW,INFNEW,RINFNE,VALNEW,ERRNEW,NUM,INFORM)
IF (INFORM /= 0) THEN
!
! Restore data structure
!
CALL DSSPUT(VEROLD,VALOLD,ERROLD,INFOLD,RINFOL, &
ISTORE,RSTORE,IFAIL)
IF (IFAIL /= 0) THEN
write(unit=*,fmt=*) "DSSPUT error 2"
STOP
END IF
CALL DSSUM(VALUE,ABSERR,ISTORE,RSTORE,IFAIL)
IF (((ALL(MEM%NRRCOPY > 3)) .AND. (DIMENS > 1) ) .OR. &
((ALL(MEM%NRRCOPY > 5)) .AND. (DIMENS == 1))) THEN
IF ( ALL(MEM%ABSERR1 < ABSERR) ) THEN ! Refine
ABSERR = MEM%ABSERR1
VALUE = MEM%RESULT1
END IF
END IF
IFAIL = INFORM
RETURN
END IF
NEVAL = NEVAL + NUM
ERRO4 = 0
DO J = 1, OUTSUB
ERRO4 = ERRO4 + ERRNEW(:,J)
END DO
ERLAST = ERROLD
MEM%ERLARG = MEM%ERLARG - ERLAST
IF (INFNEW(2,1) < MEM%DIVLEVEL) THEN
MEM%ERLARG = MEM%ERLARG + ERRO4
END IF
!
! Adjust VALUE and ABSERR
!
VALUE = VALUE - VALOLD
ABSERR = ABSERR - ERROLD
DO L = 1,OUTSUB
VALUE = VALUE + VALNEW(:,L)
ABSERR = ABSERR + ERRNEW(:,L)
END DO
!
! Store the results.
!
DO L = 1,OUTSUB
IF ( INFNEW(2,1) >= MEM%DIVLEVEL ) THEN
MAXHELP = MAXVAL(ERRNEW(:,L))
MEM%ERRORMAXPOOL = MAX(MEM%ERRORMAXPOOL,MAXHELP)
CALL DSUPUT(VERNEW(:,:,L),VALNEW(:,L), &
ERRNEW(:,L),INFNEW(:,L), &
RINFNE(:,L),ISTORE,RSTORE,IFAIL)
IF (IFAIL /= 0) THEN
WRITE(unit=*,fmt=*) "DSUPUT-1 error ", ifail
STOP
END IF
ELSE
CALL DSSPUT(VERNEW(:,:,L),VALNEW(:,L), &
ERRNEW(:,L),INFNEW(:,L), &
RINFNE(:,L),ISTORE,RSTORE,IFAIL)
IF (IFAIL /= 0) THEN
WRITE(unit=*,fmt=*) "DSSPUT error 3"
STOP
END IF
END IF
END DO
! HIER EVENTUEEL OOK OP TERMINATIE TESTEN
CALL DSGET(VEROLD,VALOLD,ERROLD, &
INFOLD,RINFOL,ISTORE,RSTORE,IFAIL)
ready2extrap = (IFAIL /= 0) ! sorted list is empty
END IF
END IF
IF ( ready2extrap ) THEN
MEM%NRRCOPY = MEM%NRRCOPY + 1
DO J = 1,NUMFUN
MEM%RCOPY (MEM%NRRCOPY(J),J) = VALUE(J)
END DO
CALL DSPINT(ISTORE,RSTORE)
MEM%ERRORMAXPOOL = 0
MEM%DIVLEVEL = MEM%DIVLEVEL + 1
IF (ALL(MEM%NRRCOPY == 2)) THEN !Dit is niet echt juist
MEM%RESLA(:,3) = VALUE
MEM%ERLARG = ABSERR
ELSE
DO J = 1,NUMFUN
CALL EPSALG(MEM%NRRCOPY(J),MEM%RCOPY(:,J),MEM%RESULT1(J), &
MEM%ABSERR1(J),MEM%RESLA(J,:),NRES,DIMENS)
END DO
MEM%ABSERR1 = MEM%ABSERR1 + MEM%ERLARG
MEM%ERLARG = ABSERR
IF ( .NOT. ALL( (ABSERR-MEM%ABSERR1) > 0 )) THEN
IF (ALL((UINFO%EPSREL*ABS(VALUE)-ABSERR) > 0) .OR. &
(ALL((UINFO%EPSABS-ABSERR) > 0 )) ) THEN
IFAIL = 0
RETURN
END IF
ELSE
IF (ALL((UINFO%EPSREL*ABS(MEM%RESULT1)-MEM%ABSERR1)>0) &
.OR. (ALL((UINFO%EPSABS-MEM%ABSERR1)>0))) THEN
ABSERR = MEM%ABSERR1
VALUE = MEM%RESULT1
IFAIL = 0
RETURN
END IF
END IF
END IF
CALL DSGET(VEROLD,VALOLD,ERROLD,INFOLD,RINFOL,ISTORE,RSTORE,IFAIL)
ready2extrap = (IFAIL /= 0) ! sorted list is empty
END IF
END IF
END DO
RETURN
END SUBROUTINE Global_Adapt_Extrap
!-----------------------------------------------------------------------
SUBROUTINE Epsalg(n, epstab, value, abserr, res3last, nres, dimens)
!
!-----------------------------------------------------------------------
!***DATE WRITTEN 961024 (YYMMDD)
!***REVISION DATE 990610 (YYMMDD) (Init. value added)
!***AUTHOR
!***BEGIN PROLOGUE epsalg
!***PURPOSE
! The routine transforms a given sequence of approximations
! using the epsilon algorithm of P. Wynn.
! An estimate of the absolute error is also given.
! the condensed epsilon table is computed. Only those
! elements needed for the computation of the next diagonal
! are preserved.
!***DESCRIPTION
! ON ENTRY
! N integer
! epstab(n) contains the new element in the
! first column of the epsilon table.
!
! EPSTAB real ( stnd ) one dimensional array of dimension epstablenght
! containing the elements of two lower diagonals of the
! triangular epsilon table. the elements are numbered
! starting at the right-hand corner of the triangle.
! the dimension should be at least (limexp+2).
!
! RES3LAST real ( stnd ) one dimensional array
! previous result
!
! NRES integer ( only used if DIMENS==1 )
! number of calls to the routine
! (should be zero at first call)
!
! DIMENS integer
! the dimension of the integration problem
!
! ON RETURN
!
! VALUE real ( stnd )
! resulting approximation to the integral
!
! ABSERR real ( stnd )
! estimate of the absolute error
!
!***REFERENCES
! Algorithm 612 TRIEX:
! Integration over a triangle using nonlinear extrapolation,
! E. de Doncker, ACM TOMS, Vol 10, No. 1, March 1984, Pages 17-22
!***ROUTINES CALLED
!***END PROLOGUE Epsalg
!-----------------------------------------------------------------------
!
! EPMACH the largest relative space
! OFLOW the largest positive magnitude
integer, intent( in ) :: dimens
integer, intent( in out ) :: n
! Changing n will give problems if NUMFUN > 1
integer, intent( in out ) :: nres
real (kind=stnd ), dimension(:), intent( in out ) :: res3last
real (kind=stnd ), intent( out ) :: value, abserr
real (kind=stnd ), dimension (:), intent( in out ) :: epstab
real (kind=stnd ), parameter :: one = 1.0_stnd
real (kind=stnd ), parameter :: epmach = EPSILON ( one ), &
oflow = HUGE ( one ), &
five = 5.0_stnd
! The following constant is derived from one defined in
! module internal_types:
integer, parameter :: limexp = EPSTABLENGHT - 2
real (kind=stnd ) :: delta1, delta2, delta3, epsinf, error, &
err1, err2, err3, e0, e1, e2, e3, e1abs, res, ss, tol1, &
tol2, tol3
integer :: i, ib, ib2, k1, newelm, num
!
! limexp is the maximum number of elements the epsilon
! table can contain. if this number is reached, the upper
! diagonal of the epsilon table is deleted.
! ( epstab is of dimension (limexp+2) at least.)
!
! list of major variables
! -----------------------
!
! E0 the 4 elements on which the
! E1 computation of a new element in
! E2 the epsilon table is based
! E3 E0
! E3 E1 NEW
! E2
! NEWELM number of elements to be computed in the new
! diagonal
! ERROR error = abs(e0-e1)+abs(e1-e2)+abs(e2-new)
! VALUE the element in the new diagonal with least error
! NUM a copy of the original value of N
!
!***FIRST EXECUTABLE STATEMENT
abserr = oflow
value = epstab(n)
IF ( dimens == 1 ) THEN
!
! Since our implementation of epsalg is taken from Triex, for dimens==1
! some modifications have to be made to simulate dqelg from
! quadpack/dqags
!
nres = nres + 1
IF ( n < 3 ) THEN
abserr = max(abserr, five*epmach*abs(value))
return
END IF
END IF
epstab( n + 2 ) = epstab( n )
epstab( n ) = oflow
newelm = ( n - 1 ) / 2
num = n
k1 = n
do i = 1, newelm
res = epstab( k1 + 2 )
e2 = res
e1 = epstab( k1 - 1 )
e0 = epstab( k1 - 2 )
e1abs = abs( e1 )
delta2 = e2 - e1
err2 = abs( delta2 )
tol2 = max( abs( e2 ), e1abs ) * epmach
delta3 = e1 - e0
err3 = abs( delta3 )
tol3 = max( e1abs, abs( e0 ) ) * epmach
if ( .NOT. (err2 > tol2 .OR. err3 > tol3 ) ) then
!
! if e0, e1 and e2 are equal to within machine
! accuracy, convergence is assumed.
! value = e2
! abserr = abs(e1-e0)+abs(e2-e1)
!
value = res
abserr = err2 + err3
abserr = max ( abserr, five * epmach * abs ( value ) )
return
else
e3 = epstab( k1 )
epstab( k1 ) = e1
delta1 = e1 - e3
err1 = abs( delta1 )
tol1 = max( e1abs, abs( e3 ) ) * epmach
!
! if two elements are very close to each other, omit
! a part of the table by adjusting the value of n.
!
if ( err1 <= tol1 .OR. err2 <= tol2 .OR. err3 <= tol3 ) then
n = i + i - 1
exit
else
ss = one / delta1 + one / delta2 - one / delta3
epsinf = abs( ss * e1 )
!
! test to detect irregular behaviour in the table, and
! eventually omit a part of the table adjusting the value
! of n.
!
if ( epsinf > 0.1e-03_stnd ) then
!
! compute a new element and eventually adjust
! the value of value
!
res = e1 + one / ss
epstab( k1 ) = res
k1 = k1 - 2
error = err2 + abs( res - e2 ) + err3
if ( .NOT. ( error > abserr ) )then
abserr = error
value = res
end if
else
n = i + i - 1
exit
end if
end if
end if
end do
!
! shift the table
!
if (n == limexp) then
n = 2 * ( limexp / 2 ) - 1
end if
if ( modulo(num,2) == 0 ) then
ib = 2
else
ib = 1
end if
do i = 1, newelm + 1
ib2 = ib + 2
epstab ( ib ) = epstab ( ib2 )
ib = ib2
end do
if ( num /= n ) then
epstab(1:n) = epstab(num-n+1:num)
end if
SELECT CASE (DIMENS)
CASE (1)
if ( nres < 4 ) then
res3last(nres) = value
abserr = oflow
abserr = max( abserr, five*epmach*abs(value) )
RETURN
end if
!
! compute error estimate
!
abserr = abs(value-res3last(3))+abs(value-res3last(2))+abs(value-res3last(1))
CASE DEFAULT
!
! compute error estimate
!
abserr = abs ( value - res3last(3) )
END SELECT
abserr = max ( abserr, five * epmach * abs ( value ) )
res3last(1:2) = res3last(2:3)
res3last(3) = value
RETURN
END SUBROUTINE Epsalg
END MODULE Global_Adaptive_Algorithm
SHAR_EOF
fi # end of overwriting check
if test -f 'internal_types.f90'
then
echo shar: will not over-write existing file "'internal_types.f90'"
else
cat << "SHAR_EOF" > 'internal_types.f90'
! This file is F-compatible, except for upper/lower case conventions.
!--------------------------------------------------------------------
Module internal_types
USE Precision_Model
IMPLICIT NONE
private
!
! Named constants, to enhance readability
!
INTEGER, public, PARAMETER :: &
Simplex = 1 , &
Hyperrectangle = 2, &
EPSTABLENGHT = 52
!
! The following record stores information that determines the
! behaviour of the global adaptive integration procedure.
! This information is passed to the region processor.
!
type, public :: integrator_info
integer :: key, nrsub
REAL(kind=stnd) :: tune
logical :: uniform_subdiv
end type integrator_info
!
! The following record stores information that is specific
! for the region collection and other data structures.
!
type, public :: collection_info
integer :: dimens, nrvert, niinfo, nrinfo
end type collection_info
!
! The following record stores scalar information supplied by the user
! or meant for the user related to the integration procedure.
!
type, public :: user_info
! Input
integer :: numfun,numrgn,minpts,maxpts
REAL(kind=stnd) :: epsabs,epsrel
logical :: restart
! Output
integer :: neval,ifail
end type user_info
type, public :: epsalg_mem
LOGICAL :: HEURISTIC_USED
INTEGER :: DIVLEVEL
INTEGER, POINTER, DIMENSION(:) :: NRRCOPY
REAL(kind=stnd) :: ERRORMAXPOOL, EPSABS, EPSREL
REAL(kind=stnd), POINTER, DIMENSION(:) :: ERLARG, &
RESULT1, &
ABSERR1
REAL(kind=stnd), POINTER, DIMENSION(:,:) :: RCOPY, &
RESLA
end type epsalg_mem
end module internal_types
SHAR_EOF
fi # end of overwriting check
if test -f 'region_processor.f90'
then
echo shar: will not over-write existing file "'region_processor.f90'"
else
cat << "SHAR_EOF" > 'region_processor.f90'
! This file is F-compatible, except for upper/lower case conventions.
!--------------------------------------------------------------------
Module Region_Processor
USE Precision_Model, ONLY: stnd
USE internal_types
USE Subdivisions
USE CubatureRule_General
Implicit NONE
PRIVATE
PUBLIC :: Process_Region
CONTAINS
SUBROUTINE Process_Region(DIMENS,CINFO,NRVERT,MAXSUB,NUMFUN, &
Integrand,VEROLD,INFOLD,RINFOL, &
MAXPTS,OUTSUB,VERNEW,INFNEW,RINFNE, &
VALNEW,ERRNEW,NREVAL,IFAIL)
!***BEGIN PROLOGUE Process_Region
!***DATE WRITTEN 910507 (YYMMDD)
!***REVISION DATE 970605 (YYMMDD)
!***REVISION DATE 990527 (YYMMDD) (F conversion)
!***REVISION DATE 990624 (YYMMDD) (2/4/8 division of C3 activated)
!***REVISION DATE 010919 (YYMMDD) (and now this can be switched off)
!***AUTHOR
! Ronald Cools, Dept. of Computer Science,
! Katholieke Universiteit Leuven, Celestijnenlaan 200A,
! B-3001 Heverlee, Belgium
! Email: Ronald.Cools@cs.kuleuven.ac.be
!
!***PURPOSE Improve the estimate of an integral over a region.
!
!***DESCRIPTION
!
! Input parameters
! ----------------
!
! DIMENS Integer.
! The dimension of the region of integration.
! NRVERT Integer.
! The number of vertices to determine a region.
! MAXSUB Integer.
! A region is divided into at most MAXSUB subregions.
! NUMFUN Integer.
! Number of components of the integral.
! NIINFO Integer = size(INFOLD)
! The number of integers used to save information about
! the region.
! Conventions for info-record:
! info-record(5) = 1 if there was asymptotic behaviour when the
! region was processed before.
! = 0 otherwise
! info-record(4) = suggestions for subdivision
! info-record(3) = number of the original region where this
! region is a part of
! info-record(2) = (volume of orinal region)/
! (volume of this region)
! info-record(1) = type of region
! NRINFO Integer = size(RINFOL)
! The number of reals used to save information about
! the region.
! Conventions for info-record:
! info-record(1) = volume
!
! MAXPTS Integer.
! The maximum number of function evaluations that Process_Region
! may use.
! Integrand Externally declared subroutine for computing
! all components of the integrand at the given
! evaluation point.
! It must have parameters (X,NUMFUN,FUNVLS)
! Input parameters:
! X(1) The x-coordinate of the evaluation point.
! X(2) The y-coordinate of the evaluation point.
! ...
! X(DIMENS) The z-coordinate of the evaluation point.
! NUMFUN Integer that defines the number of
! components of I.
! Output parameter:
! FUNVLS Real array of dimension NUMFUN
! that defines NUMFUN components of the integrand.
!
!
! Output parameters
! -----------------
!
! OUTSUB Integer.
! The number of regions returned by this routine.
! NREVAL Integer.
! Number of function evaluations used by Process_Region.
! IFAIL Integer.
! IFAIL = 0 for normal exit.
! IFAIL = 1 if nothing was done because nothing can be
! done with MAXPTS function evaluations.
! IFAIL = 6 if an unsupported type of region is given.
! IFAIL = 7 or 6 if DIVIDE returns with an error
! If IFAIL not equal to 0 then OUTSUB = 0
!
!***ROUTINES CALLED Rule_General,DIVIDE
!***END PROLOGUE Process_Region
! Global variables
!
INTERFACE
FUNCTION Integrand(NUMFUN,X) RESULT(Value)
USE Precision_Model
INTEGER, INTENT(IN) :: NUMFUN
REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: X
REAL(kind=stnd), DIMENSION(NUMFUN) :: Value
END FUNCTION Integrand
END INTERFACE
INTEGER, INTENT(IN) :: DIMENS,NRVERT,MAXSUB,NUMFUN,MAXPTS
INTEGER, DIMENSION(:), INTENT(IN) :: INFOLD
INTEGER, INTENT(OUT):: NREVAL,IFAIL,OUTSUB
INTEGER, DIMENSION(:,:), INTENT(OUT):: INFNEW
REAL(kind=stnd), DIMENSION(:,:), INTENT(IN) :: VEROLD
REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: RINFOL
REAL(kind=stnd), DIMENSION(:,:), INTENT(OUT):: RINFNE,VALNEW,ERRNEW
REAL(kind=stnd), DIMENSION(:,:,:), INTENT(OUT):: VERNEW
TYPE(integrator_info), INTENT(IN) :: CINFO
!
! Local variables
!
INTEGER :: L,NUM,REQSUB
!
NREVAL = 0
REQSUB = MAXSUB
IF ( (.NOT. CINFO%UNIFORM_SUBDIV) .AND. (INFOLD(4) /= 0) ) THEN
! INFOLD(4) is set by Rule_C* ; not by Rule_T*
IF (INFOLD(4) < 0) THEN
! Rule_C3 can return negative numbers if 4-division is
! suggested.
REQSUB = MIN(REQSUB,4)
ELSE IF (INFOLD(4) < 90) THEN
! Rule_Cn and Rule_C2 can only returns positive numbers
! and this suggests 2-division.
! Rule_C3 returns a number >90 if uniform subdivision is
! recommended.
REQSUB = MIN(REQSUB,2)
END IF
END IF
!
! Divide the region in (at most) REQSUB subregions.
!
DO
CALL DIVIDE(DIMENS,NRVERT,REQSUB,CINFO%UNIFORM_SUBDIV,NUMFUN,VEROLD,INFOLD, &
RINFOL,Integrand,OUTSUB,NUM,VERNEW,INFNEW,RINFNE,IFAIL)
NREVAL = NREVAL + NUM
IF (IFAIL == 0) THEN
EXIT
END IF
IF ( CINFO%UNIFORM_SUBDIV .OR. REQSUB == 2) THEN
! Now IFAIL /= 0 and we have no alternative
OUTSUB = 0
RETURN
END IF
REQSUB = 2 ! Retry, asking for a 2-division
END DO
!
! Apply the basic rule to each subregion.
!
NUM = 0
DO L = 1,OUTSUB
NUM = NUM + Rule_Cost( DIMENS, INFNEW(1,L), CINFO%Key)
END DO
IF ( NREVAL + NUM > MAXPTS ) THEN
IFAIL = 1
OUTSUB = 0
RETURN
END IF
DO L = 1,OUTSUB
CALL Rule_General(DIMENS,CINFO,VERNEW(:,:,L),INFNEW(:,L), &
RINFNE(:,L),NUMFUN,Integrand,VALNEW(:,L),&
ERRNEW(:,L),NUM,IFAIL)
NREVAL = NREVAL + NUM
IF (IFAIL /= 0) THEN
OUTSUB = 0
RETURN
END IF
END DO
!
RETURN
END SUBROUTINE Process_Region
END MODULE Region_Processor
SHAR_EOF
fi # end of overwriting check
if test -f 'rule_1.f90'
then
echo shar: will not over-write existing file "'rule_1.f90'"
else
cat << "SHAR_EOF" > 'rule_1.f90'
! This file is F-compatible, except for upper/lower case conventions.
!--------------------------------------------------------------------
Module QuadratureRule
USE Precision_Model, ONLY: stnd
Implicit NONE
PRIVATE
PUBLIC :: Dqk_drv
PRIVATE :: Dqknn
CONTAINS
SUBROUTINE Dqk_drv(KEY,VER,NUMFUN,Integrand,BASVAL,RGNERR,NUM)
!***
! Driver routine voor Dqknn. This routine selects the appropriate data
! for subroutine Dqknn, according to the value of key, i.e. the
! desired integration rule and error estimatation routine.
!
!***
! For the meaning of the parameters, see Dqknn
!
INTEGER, INTENT(IN) :: NUMFUN,KEY
INTEGER, INTENT(OUT) :: NUM
REAL(kind=stnd), DIMENSION(:,:),INTENT(IN) :: VER
REAL(kind=stnd), DIMENSION(:),INTENT(OUT) :: BASVAL, RGNERR
INTERFACE
FUNCTION Integrand(NUMFUN,X) RESULT(Value)
USE Precision_Model
INTEGER, INTENT(IN) :: NUMFUN
REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: X
REAL(kind=stnd), DIMENSION(NUMFUN) :: Value
END FUNCTION Integrand
END INTERFACE
!
REAL(kind=stnd), DIMENSION(1:15) :: wg
REAL(kind=stnd), DIMENSION(1:31) :: xgk, wgk
!
!***first executable statement dqk_drv
!
SELECT CASE (key)
CASE(:1)
wg(1:4) = (/ 0.129484966168869693270611432679082_stnd, &
0.279705391489276667901467771423780_stnd, &
0.381830050505118944950369775488975_stnd, &
0.417959183673469387755102040816327_stnd /)
xgk(1:8) = (/ 0.991455371120812639206854697526329_stnd, &
0.949107912342758524526189684047851_stnd, &
0.864864423359769072789712788640926_stnd, &
0.741531185599394439863864773280788_stnd, &
0.586087235467691130294144838258730_stnd, &
0.405845151377397166906606412076961_stnd, &
0.207784955007898467600689403773245_stnd, &
0.000000000000000000000000000000000_stnd /)
wgk(1:8) = (/ 0.022935322010529224963732008058970_stnd, &
0.063092092629978553290700663189204_stnd, &
0.104790010322250183839876322541518_stnd, &
0.140653259715525918745189590510238_stnd, &
0.169004726639267902826583426598550_stnd, &
0.190350578064785409913256402421014_stnd, &
0.204432940075298892414161999234649_stnd, &
0.209482141084727828012999174891714_stnd /)
NUM = 15
call Dqknn(KEY,VER,NUMFUN,Integrand,BASVAL,RGNERR, &
wg(1:4),xgk(1:8),wgk(1:8))
CASE (2)
wg(1:5) = (/ 0.066671344308688137593568809893332_stnd, &
0.149451349150580593145776339657697_stnd, &
0.219086362515982043995534934228163_stnd, &
0.269266719309996355091226921569469_stnd, &
0.295524224714752870173892994651338_stnd /)
xgk(1:11) = (/ 0.995657163025808080735527280689003_stnd, &
0.973906528517171720077964012084452_stnd, &
0.930157491355708226001207180059508_stnd, &
0.865063366688984510732096688423493_stnd, &
0.780817726586416897063717578345042_stnd, &
0.679409568299024406234327365114874_stnd, &
0.562757134668604683339000099272694_stnd, &
0.433395394129247190799265943165784_stnd, &
0.294392862701460198131126603103866_stnd, &
0.148874338981631210884826001129720_stnd, &
0.000000000000000000000000000000000_stnd /)
wgk(1:11) = (/ 0.011694638867371874278064396062192_stnd, &
0.032558162307964727478818972459390_stnd, &
0.054755896574351996031381300244580_stnd, &
0.075039674810919952767043140916190_stnd, &
0.093125454583697605535065465083366_stnd, &
0.109387158802297641899210590325805_stnd, &
0.123491976262065851077958109831074_stnd, &
0.134709217311473325928054001771707_stnd, &
0.142775938577060080797094273138717_stnd, &
0.147739104901338491374841515972068_stnd, &
0.149445554002916905664936468389821_stnd /)
NUM = 21
call Dqknn(KEY,VER,NUMFUN,Integrand,BASVAL,RGNERR, &
wg(1:5),xgk(1:11),wgk(1:11))
CASE (3)
wg(1:8) = (/ 0.030753241996117268354628393577204_stnd, &
0.070366047488108124709267416450667_stnd, &
0.107159220467171935011869546685869_stnd, &
0.139570677926154314447804794511028_stnd, &
0.166269205816993933553200860481209_stnd, &
0.186161000015562211026800561866423_stnd, &
0.198431485327111576456118326443839_stnd, &
0.202578241925561272880620199967519_stnd /)
xgk(1:16) = (/ 0.998002298693397060285172840152271_stnd, &
0.987992518020485428489565718586613_stnd, &
0.967739075679139134257347978784337_stnd, &
0.937273392400705904307758947710209_stnd, &
0.897264532344081900882509656454496_stnd, &
0.848206583410427216200648320774217_stnd, &
0.790418501442465932967649294817947_stnd, &
0.724417731360170047416186054613938_stnd, &
0.650996741297416970533735895313275_stnd, &
0.570972172608538847537226737253911_stnd, &
0.485081863640239680693655740232351_stnd, &
0.394151347077563369897207370981045_stnd, &
0.299180007153168812166780024266389_stnd, &
0.201194093997434522300628303394596_stnd, &
0.101142066918717499027074231447392_stnd, &
0.000000000000000000000000000000000_stnd /)
wgk(1:16) = (/ 0.005377479872923348987792051430128_stnd, &
0.015007947329316122538374763075807_stnd, &
0.025460847326715320186874001019653_stnd, &
0.035346360791375846222037948478360_stnd, &
0.044589751324764876608227299373280_stnd, &
0.053481524690928087265343147239430_stnd, &
0.062009567800670640285139230960803_stnd, &
0.069854121318728258709520077099147_stnd, &
0.076849680757720378894432777482659_stnd, &
0.083080502823133021038289247286104_stnd, &
0.088564443056211770647275443693774_stnd, &
0.093126598170825321225486872747346_stnd, &
0.096642726983623678505179907627589_stnd, &
0.099173598721791959332393173484603_stnd, &
0.100769845523875595044946662617570_stnd, &
0.101330007014791549017374792767493_stnd /)
NUM = 31
call Dqknn(KEY,VER,NUMFUN,Integrand,BASVAL,RGNERR, &
wg(1:8),xgk(1:16),wgk(1:16))
CASE (4)
wg(1:10) = (/ 0.017614007139152118311861962351853_stnd, &
0.040601429800386941331039952274932_stnd, &
0.062672048334109063569506535187042_stnd, &
0.083276741576704748724758143222046_stnd, &
0.101930119817240435036750135480350_stnd, &
0.118194531961518417312377377711382_stnd, &
0.131688638449176626898494499748163_stnd, &
0.142096109318382051329298325067165_stnd, &
0.149172986472603746787828737001969_stnd, &
0.152753387130725850698084331955098_stnd /)
xgk(1:21) = (/ 0.998859031588277663838315576545863_stnd, &
0.993128599185094924786122388471320_stnd, &
0.981507877450250259193342994720217_stnd, &
0.963971927277913791267666131197277_stnd, &
0.940822633831754753519982722212443_stnd, &
0.912234428251325905867752441203298_stnd, &
0.878276811252281976077442995113078_stnd, &
0.839116971822218823394529061701521_stnd, &
0.795041428837551198350638833272788_stnd, &
0.746331906460150792614305070355642_stnd, &
0.693237656334751384805490711845932_stnd, &
0.636053680726515025452836696226286_stnd, &
0.575140446819710315342946036586425_stnd, &
0.510867001950827098004364050955251_stnd, &
0.443593175238725103199992213492640_stnd, &
0.373706088715419560672548177024927_stnd, &
0.301627868114913004320555356858592_stnd, &
0.227785851141645078080496195368575_stnd, &
0.152605465240922675505220241022678_stnd, &
0.076526521133497333754640409398838_stnd, &
0.000000000000000000000000000000000_stnd /)
wgk(1:21) = (/ 0.003073583718520531501218293246031_stnd, &
0.008600269855642942198661787950102_stnd, &
0.014626169256971252983787960308868_stnd, &
0.020388373461266523598010231432755_stnd, &
0.025882133604951158834505067096153_stnd, &
0.031287306777032798958543119323801_stnd, &
0.036600169758200798030557240707211_stnd, &
0.041668873327973686263788305936895_stnd, &
0.046434821867497674720231880926108_stnd, &
0.050944573923728691932707670050345_stnd, &
0.055195105348285994744832372419777_stnd, &
0.059111400880639572374967220648594_stnd, &
0.062653237554781168025870122174255_stnd, &
0.065834597133618422111563556969398_stnd, &
0.068648672928521619345623411885368_stnd, &
0.071054423553444068305790361723210_stnd, &
0.073030690332786667495189417658913_stnd, &
0.074582875400499188986581418362488_stnd, &
0.075704497684556674659542775376617_stnd, &
0.076377867672080736705502835038061_stnd, &
0.076600711917999656445049901530102_stnd /)
NUM = 41
call Dqknn(KEY,VER,NUMFUN,Integrand,BASVAL,RGNERR, &
wg(1:10),xgk(1:21),wgk(1:21))
CASE (5)
wg(1:13) = (/ 0.011393798501026287947902964113235_stnd, &
0.026354986615032137261901815295299_stnd, &
0.040939156701306312655623487711646_stnd, &
0.054904695975835191925936891540473_stnd, &
0.068038333812356917207187185656708_stnd, &
0.080140700335001018013234959669111_stnd, &
0.091028261982963649811497220702892_stnd, &
0.100535949067050644202206890392686_stnd, &
0.108519624474263653116093957050117_stnd, &
0.114858259145711648339325545869556_stnd, &
0.119455763535784772228178126512901_stnd, &
0.122242442990310041688959518945852_stnd, &
0.123176053726715451203902873079050_stnd /)
xgk(1:26) = (/ 0.999262104992609834193457486540341_stnd, &
0.995556969790498097908784946893902_stnd, &
0.988035794534077247637331014577406_stnd, &
0.976663921459517511498315386479594_stnd, &
0.961614986425842512418130033660167_stnd, &
0.942974571228974339414011169658471_stnd, &
0.920747115281701561746346084546331_stnd, &
0.894991997878275368851042006782805_stnd, &
0.865847065293275595448996969588340_stnd, &
0.833442628760834001421021108693570_stnd, &
0.797873797998500059410410904994307_stnd, &
0.759259263037357630577282865204361_stnd, &
0.717766406813084388186654079773298_stnd, &
0.673566368473468364485120633247622_stnd, &
0.626810099010317412788122681624518_stnd, &
0.577662930241222967723689841612654_stnd, &
0.526325284334719182599623778158010_stnd, &
0.473002731445714960522182115009192_stnd, &
0.417885382193037748851814394594572_stnd, &
0.361172305809387837735821730127641_stnd, &
0.303089538931107830167478909980339_stnd, &
0.243866883720988432045190362797452_stnd, &
0.183718939421048892015969888759528_stnd, &
0.122864692610710396387359818808037_stnd, &
0.061544483005685078886546392366797_stnd, &
0.000000000000000000000000000000000_stnd /)
wgk(1:26) = (/ 0.001987383892330315926507851882843_stnd, &
0.005561932135356713758040236901066_stnd, &
0.009473973386174151607207710523655_stnd, &
0.013236229195571674813656405846976_stnd, &
0.016847817709128298231516667536336_stnd, &
0.020435371145882835456568292235939_stnd, &
0.024009945606953216220092489164881_stnd, &
0.027475317587851737802948455517811_stnd, &
0.030792300167387488891109020215229_stnd, &
0.034002130274329337836748795229551_stnd, &
0.037116271483415543560330625367620_stnd, &
0.040083825504032382074839284467076_stnd, &
0.042872845020170049476895792439495_stnd, &
0.045502913049921788909870584752660_stnd, &
0.047982537138836713906392255756915_stnd, &
0.050277679080715671963325259433440_stnd, &
0.052362885806407475864366712137873_stnd, &
0.054251129888545490144543370459876_stnd, &
0.055950811220412317308240686382747_stnd, &
0.057437116361567832853582693939506_stnd, &
0.058689680022394207961974175856788_stnd, &
0.059720340324174059979099291932562_stnd, &
0.060539455376045862945360267517565_stnd, &
0.061128509717053048305859030416293_stnd, &
0.061471189871425316661544131965264_stnd, &
! note: wgk (26) was calculated from the values of wgk(1..25)
0.061580818067832935078759824240066_stnd /)
NUM = 51
call Dqknn(KEY,VER,NUMFUN,Integrand,BASVAL,RGNERR, &
wg(1:13),xgk(1:26),wgk(1:26))
CASE (6:)
wg(1:15) = (/ 0.007968192496166605615465883474674_stnd, &
0.018466468311090959142302131912047_stnd, &
0.028784707883323369349719179611292_stnd, &
0.038799192569627049596801936446348_stnd, &
0.048402672830594052902938140422808_stnd, &
0.057493156217619066481721689402056_stnd, &
0.065974229882180495128128515115962_stnd, &
0.073755974737705206268243850022191_stnd, &
0.080755895229420215354694938460530_stnd, &
0.086899787201082979802387530715126_stnd, &
0.092122522237786128717632707087619_stnd, &
0.096368737174644259639468626351810_stnd, &
0.099593420586795267062780282103569_stnd, &
0.101762389748405504596428952168554_stnd, &
0.102852652893558840341285636705415_stnd /)
xgk(1:31) = (/ 0.999484410050490637571325895705811_stnd, &
0.996893484074649540271630050918695_stnd, &
0.991630996870404594858628366109486_stnd, &
0.983668123279747209970032581605663_stnd, &
0.973116322501126268374693868423707_stnd, &
0.960021864968307512216871025581798_stnd, &
0.944374444748559979415831324037439_stnd, &
0.926200047429274325879324277080474_stnd, &
0.905573307699907798546522558925958_stnd, &
0.882560535792052681543116462530226_stnd, &
0.857205233546061098958658510658944_stnd, &
0.829565762382768397442898119732502_stnd, &
0.799727835821839083013668942322683_stnd, &
0.767777432104826194917977340974503_stnd, &
0.733790062453226804726171131369528_stnd, &
0.697850494793315796932292388026640_stnd, &
0.660061064126626961370053668149271_stnd, &
0.620526182989242861140477556431189_stnd, &
0.579345235826361691756024932172540_stnd, &
0.536624148142019899264169793311073_stnd, &
0.492480467861778574993693061207709_stnd, &
0.447033769538089176780609900322854_stnd, &
0.400401254830394392535476211542661_stnd, &
0.352704725530878113471037207089374_stnd, &
0.304073202273625077372677107199257_stnd, &
0.254636926167889846439805129817805_stnd, &
0.204525116682309891438957671002025_stnd, &
0.153869913608583546963794672743256_stnd, &
0.102806937966737030147096751318001_stnd, &
0.051471842555317695833025213166723_stnd, &
0.000000000000000000000000000000000_stnd /)
wgk(1:31) = (/ 0.001389013698677007624551591226760_stnd, &
0.003890461127099884051267201844516_stnd, &
0.006630703915931292173319826369750_stnd, &
0.009273279659517763428441146892024_stnd, &
0.011823015253496341742232898853251_stnd, &
0.014369729507045804812451432443580_stnd, &
0.016920889189053272627572289420322_stnd, &
0.019414141193942381173408951050128_stnd, &
0.021828035821609192297167485738339_stnd, &
0.024191162078080601365686370725232_stnd, &
0.026509954882333101610601709335075_stnd, &
0.028754048765041292843978785354334_stnd, &
0.030907257562387762472884252943092_stnd, &
0.032981447057483726031814191016854_stnd, &
0.034979338028060024137499670731468_stnd, &
0.036882364651821229223911065617136_stnd, &
0.038678945624727592950348651532281_stnd, &
0.040374538951535959111995279752468_stnd, &
0.041969810215164246147147541285970_stnd, &
0.043452539701356069316831728117073_stnd, &
0.044814800133162663192355551616723_stnd, &
0.046059238271006988116271735559374_stnd, &
0.047185546569299153945261478181099_stnd, &
0.048185861757087129140779492298305_stnd, &
0.049055434555029778887528165367238_stnd, &
0.049795683427074206357811569379942_stnd, &
0.050405921402782346840893085653585_stnd, &
0.050881795898749606492297473049805_stnd, &
0.051221547849258772170656282604944_stnd, &
0.051426128537459025933862879215781_stnd, &
0.051494729429451567558340433647099_stnd /)
NUM = 61
call Dqknn(KEY,VER,NUMFUN,Integrand,BASVAL,RGNERR, &
wg(1:15),xgk(1:31),wgk(1:31))
END SELECT
RETURN
END SUBROUTINE Dqk_drv
!------------------------------------------------------------------------
SUBROUTINE Dqknn(KEY,VER,NUMFUN,Integrand,BASVAL,RGNERR, &
wg,xgk,wgk)
!***begin prologue dqk15
!***date written 800101 (yymmdd)
!***revision date 830518 (yymmdd)
!***revision date 980326 (yymmdd) (Integration in Cubpack)
!***revision date 990525 (yymmdd) (F conversion)
!***category no. h2a1a2
!***keywords 15-point gauss-kronrod rules
!***author piessens,robert,appl. math. & progr. div. - k.u.leuven
! de doncker,elise,appl. math. & progr. div - k.u.leuven
!***purpose to compute i = integral of f over (a,b), with error
! estimate
!***description
!
! integration rules
! standard fortran subroutine
! double precision version
!
! parameters
! ON ENTRY
!
! Integrand Externally declared subroutine for computing
! all components of the integrand at the given
! evaluation point.
! It must have parameters (DIMENS,X,NUMFUN,FUNVLS)
! Input parameters:
! DIMENS = 1
! X(1) The coordinate of the evaluation point.
! NUMFUN Integer that defines the number of
! components of I.
! Output parameter:
! FUNVLS Real array of dimension NUMFUN
! that defines NUMFUN components of the integrand.
! VER Real array of dimension (1,2).
! The coordinates of the vertices of the interval.
! KEY Integer
! key for choice of local integration rule
! a gauss-kronrod pair is used with
! 7 - 15 points if key < 2,
! 10 - 21 points if key = 2,
! 15 - 31 points if key = 3,
! 20 - 41 points if key = 4,
! 25 - 51 points if key = 5,
! 30 - 61 points if key > 5.
!
! ON RETURN
!
! BASVAL Real array of dimension NUMFUN.
! The values for the basic rule for each component
! of the integrand.
! RGNERR Real array of dimension NUMFUN.
! The error estimates for each component of the integrand.
!
!***references (none)
!***routines called Integrand
!***end prologue dqknn
!
REAL(kind=stnd), DIMENSION(:,:), INTENT(IN) :: VER
REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: wg,xgk,wgk
INTEGER, INTENT(IN) :: NUMFUN,KEY
REAL(kind=stnd), DIMENSION(:), INTENT(OUT) :: BASVAL,RGNERR
INTERFACE
FUNCTION Integrand(NUMFUN,X) RESULT(Value)
USE Precision_Model
INTEGER, INTENT(IN) :: NUMFUN
REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: X
REAL(kind=stnd), DIMENSION(NUMFUN) :: Value
END FUNCTION Integrand
END INTERFACE
REAL(kind=stnd):: absc,centr,dhlgth,hlgth,resasc, reskh
REAL(kind=stnd), DIMENSION(NUMFUN) :: fc, fsum,fval1,fval2, &
resabs, resg, resk
REAL(kind=stnd), DIMENSION(size(xgk)-1,NUMFUN) :: fv1,fv2
INTEGER :: j,jtw,jtwm1,m,upper,dummy
!
! the abscissae and weights are given for the interval (-1,1).
! because of symmetry only the positive abscissae and their
! corresponding weights are given.
!
! xgk - abscissae of the 15-point kronrod rule
! xgk(2), xgk(4), ... abscissae of the 7-point
! gauss rule
! xgk(1), xgk(3), ... abscissae which are optimally
! added to the 7-point gauss rule
!
! wgk - weights of the 15-point kronrod rule
!
! wg - weights of the 7-point gauss rule
!
!
! gauss quadrature weights and kronron quadrature abscissae and weights
! as evaluated with 80 decimal digit arithmetic by l. w. fullerton,
! bell labs, nov. 1981.
!
! list of major variables
! -----------------------
!
! centr - mid point of the interval
! hlgth - half-length of the interval
! absc - abscissa
! fval* - function value
! resg - result of the 7-point gauss formula
! resk - result of the 15-point kronrod formula
! reskh - approximation to the mean value of f over (a,b),
! i.e. to i/(b-a)
!
!***first executable statement dqk15
!
centr = 0.5_stnd*(ver(1,1)+ver(1,2))
hlgth = 0.5_stnd*(ver(1,2)-ver(1,1))
dhlgth = abs(hlgth)
!
! compute the 15-point kronrod approximation to
! the integral, and estimate the absolute error.
!
upper = size(wgk)
fc = Integrand(NUMFUN,(/centr/))
DO m=1,NUMFUN
SELECT CASE (key)
CASE (:1,3,5)
resg(m) = fc(m)*wg(size(wg))
CASE (2,4,6:)
resg(m) = 0.0_stnd
END SELECT
resk(m) = fc(m)*wgk(upper)
resabs(m) = abs(resk(m))
END DO
dummy = (upper - 1)/2
DO j=1,dummy
jtw = j*2
absc = hlgth*xgk(jtw)
fval1 = Integrand(NUMFUN,(/centr-absc/))
fval2 = Integrand(NUMFUN,(/centr+absc/))
fv1(jtw,:) = fval1
fv2(jtw,:) = fval2
fsum = fval1+fval2
DO m=1,NUMFUN
resg(m) = resg(m)+wg(j)*fsum(m)
resk(m) = resk(m)+wgk(jtw)*fsum(m)
resabs(m) = resabs(m)+wgk(jtw)*(abs(fval1(m))+abs(fval2(m)))
END DO
END DO
dummy = size(wg)
DO j = 1,dummy
jtwm1 = j*2-1
absc = hlgth*xgk(jtwm1)
fval1 = Integrand(NUMFUN,(/centr-absc/))
fval2 = Integrand(NUMFUN,(/centr+absc/))
fv1(jtwm1,:) = fval1
fv2(jtwm1,:) = fval2
fsum = fval1+fval2
DO m=1,NUMFUN
resk(m) = resk(m)+wgk(jtwm1)*fsum(m)
resabs(m) = resabs(m)+wgk(jtwm1)*(abs(fval1(m))+abs(fval2(m)))
END DO
END DO
DO m=1,NUMFUN
reskh = resk(m)*0.5_stnd
resasc = wgk(upper)*abs(fc(m)-reskh)
DO j=1,upper-1
resasc = resasc+wgk(j)*(abs(fv1(j,m)-reskh)+abs(fv2(j,m)-reskh))
END DO
BASVAL(m) = resk(m)*hlgth
resabs(m) = resabs(m)*dhlgth
resasc = resasc*dhlgth
RGNERR(m) = abs((resk(m)-resg(m))*hlgth)
IF (resasc /= 0.0_stnd .AND. RGNERR(m) /= 0.0_stnd) THEN
RGNERR(m) = resasc*min(1.0_stnd,(200.0_stnd*RGNERR(m)/resasc)**1.5_stnd)
END IF
IF (resabs(m) > TINY(RGNERR(m))/(50.0_stnd*EPSILON(RGNERR(m))))&
THEN
RGNERR(m) = max((EPSILON(RGNERR(m))*50.0_stnd)*resabs(m),RGNERR(m))
END IF
END DO
RETURN
END SUBROUTINE Dqknn
END Module QuadratureRule
SHAR_EOF
fi # end of overwriting check
if test -f 'rule_c2.f90'
then
echo shar: will not over-write existing file "'rule_c2.f90'"
else
cat << "SHAR_EOF" > 'rule_c2.f90'
! This file is F-compatible, except for upper/lower case conventions.
!--------------------------------------------------------------------
Module CubatureRule_C2
USE Precision_Model, ONLY: stnd
Implicit NONE
PRIVATE
PUBLIC :: Rule_C2a
CONTAINS
SUBROUTINE Rule_C2a(VER,INFOLD,AREA,NUMFUN,Integrand,BASVAL,RGNERR,NUM)
!
!***BEGIN PROLOGUE Rule_C2a
!***PURPOSE To compute basic integration rule values and
! corresponding error estimates.
! ***REVISION DATE 950531 (YYMMDD) (Fortran90 transformation)
! ***REVISION DATE 990527 (YYMMDD) (F transformation)
! ***AUTHOR
! Ronald Cools, Dept. of Computer Science,
! Katholieke Universiteit Leuven, Celestijnenlaan 200A,
! B-3001 Heverlee, Belgium
! Email: ronald@cs.kuleuven.ac.be
!
! ***REFERENCES
! The cubature formula of degree 13 with 37 points is from
! Rabinowitz & Richter. The tuning of the error estimator
! is described in:
! R. Cools.
! "The subdivision strategy and reliablity in adaptive
! integration revisited."
! Report TW 213, Dept. of Computer Science, K.U.Leuven, 1994.
!
!***DESCRIPTION Rule_C2a computes basic integration rule values
! for a vector of integrands over a rectangular region.
! Rule_C2a also computes estimates for the errors by
! using several null rule approximations.
! ON ENTRY
!
! VER Real array of dimension (2,3).
! The coordinates of the vertices of the parallellogram.
! NUMFUN Integer.
! Number of components of the vector integrand.
! INFOLD Integer array
! Integrand Externally declared subroutine for computing
! all components of the integrand at the given
! evaluation point.
! It must have parameters (DIM,X,NUMFUN,FUNVLS)
! Input parameters:
! DIM = 2
! X(1) The x-coordinate of the evaluation point.
! X(2) The y-coordinate of the evaluation point.
! NUMFUN Integer that defines the number of
! components of I.
! Output parameter:
! FUNVLS Real array of dimension NUMFUN
! that defines NUMFUN components of the integrand.
!
! ON RETURN
!
! BASVAL Real array of dimension NUMFUN.
! The values for the basic rule for each component
! of the integrand.
! RGNERR Real array of dimension NUMFUN.
! The error estimates for each component of the integrand.
! NUM Integer
! The number of function evaluations used.
! INFOLD Integer array
!
!***ROUTINES CALLED Integrand
!***END PROLOGUE Rule_C2a
!
! Global variables.
!
INTERFACE
FUNCTION Integrand(NUMFUN,X) RESULT(Value)
USE Precision_Model
INTEGER, INTENT(IN) :: NUMFUN
REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: X
REAL(kind=stnd), DIMENSION(NUMFUN) :: Value
END FUNCTION Integrand
END INTERFACE
INTEGER, INTENT(IN) :: NUMFUN
INTEGER, INTENT(OUT) :: NUM
INTEGER, DIMENSION(:), INTENT(IN OUT) :: INFOLD
REAL(kind=stnd), INTENT(IN) :: AREA
REAL(kind=stnd), DIMENSION(:,:), INTENT(IN) :: VER
REAL(kind=stnd), DIMENSION(:), INTENT(OUT) :: BASVAL, RGNERR
!
! Parameters
!
INTEGER, DIMENSION(0:3), PARAMETER :: &
K = (/1,2,3,2/) ! Rule structure parameters
INTEGER, PARAMETER :: &
ORBITS = 8 ! Number of orbits in rule
REAL(kind=stnd), PARAMETER :: &
HALF = 0.5_stnd, &
FOUR = 4.0_stnd, &
CRIVAL = 0.4_stnd, &
FACMED = 8.0_stnd, &
FACOPT = FACMED/CRIVAL**2, &
TRES = 50*EPSILON(HALF), &
CUTOFF = 1.0E-4_stnd , &
DFCLEV = 0.55_stnd
REAL(kind=stnd), DIMENSION(0:2), PARAMETER :: &
DFC = (/2.97397430397053625382_stnd, &
1.0_stnd, &
-2.48698715198526812691_stnd /)
!
! Cubature formula of degree 13 with 37 points (Rabinowitz & Richter)
!
!
! Information for the generators
!
INTEGER :: I
REAL(kind=stnd), DIMENSION(1:2), PARAMETER :: &
TYPE1 = (/ 0.9909890363004326469792722978603_stnd, &
0.6283940712305315063814483471116_stnd /)
REAL(kind=stnd), DIMENSION(1:3), PARAMETER :: &
TYPE2 = (/ 0.9194861553393073086142137772149_stnd, &
0.6973201917871173078084506730937_stnd, &
0.3805687186904854497424188074662_stnd /)
REAL(kind=stnd), DIMENSION(1:2,1:2), PARAMETER :: &
TYPE3 = RESHAPE( SOURCE= &
(/ 0.9708504361720225062147290554088_stnd, &
0.6390348393207252159077623446225_stnd, &
0.8623637916722781475018696425693_stnd, &
0.3162277660168700033875075593701_stnd /),&
SHAPE=(/2,2/) )
! The weights of the basic rule and the null rules.
! WEIGHT(1,1),...,WEIGHT(1,ORBITS) are weights for the basic rule.
! WEIGHT(I,1),...,WEIGHT(I,ORBITS) for I>1 are null rule weights.
!
!
! Weights of the cubature formula.
!
REAL(kind=stnd), DIMENSION(ORBITS), PARAMETER :: &
W1 = (/ &
2.995235559387052215463143056692E-1_stnd , &
3.311006686692356205977471655046E-2_stnd , &
1.802214941550624038355347399683E-1_stnd , &
3.916727896035153300761243260674E-2_stnd , &
1.387748348777288706306435595057E-1_stnd , &
2.268881207335707037147066705814E-1_stnd , &
3.657395765508995601240002438981E-2_stnd , &
1.169047000557533546701746277951E-1_stnd /)
!
! Weights of the rules of degree 7, 7, 5 , 5 , 3 , 3 and 1.
!
REAL(kind=stnd), DIMENSION(ORBITS), PARAMETER :: &
W2 = (/ &
7.610781847149629154716409791983E-2_stnd , &
1.486101247399760261471935168346E-1_stnd , &
-2.077685631717747007172983323970E-1_stnd , &
6.850758313011924198538315395405E-2_stnd , &
2.024205813317813585572881715385E-1_stnd , &
1.108627473745508429879249169864E-1_stnd , &
-1.187411393304862640859204217487E-1_stnd , &
-5.208857468077715683772080394959E-2_stnd /)
!
REAL(kind=stnd), DIMENSION(ORBITS), PARAMETER :: &
W3 = (/ &
4.016494861405949747097510013162E-2_stnd , &
-1.093132962444079541048635452881E-1_stnd , &
-2.270251673633777452624380129694E-1_stnd , &
1.231674163356097016086203579325E-2_stnd , &
-1.420402526499201540699111172200E-1_stnd , &
1.189080551229557928776504129312E-1_stnd , &
-4.482039658150474743804189300793E-3_stnd , &
1.730383808319875827592824151609E-1_stnd /)
!
REAL(kind=stnd), DIMENSION(ORBITS), PARAMETER :: &
W4 = (/ &
-5.643905795781771973971259866415E-1_stnd , &
2.878418073676293225652331648545E-2_stnd , &
1.159354231997583294689565314470E-1_stnd , &
1.376081498690624477894043101438E-1_stnd , &
-7.909780225340130915490382973570E-2_stnd , &
1.174335441429478112778176601234E-1_stnd , &
-1.107251942334134124782600707843E-1_stnd , &
2.094226883312045633400182488252E-2_stnd /)
!
REAL(kind=stnd), DIMENSION(ORBITS), PARAMETER :: &
W5 = (/ &
-2.269001713589584730602581694579E-1_stnd , &
2.976190892690301120078774620049E-2_stnd , &
-7.440193483272787588251423144751E-2_stnd , &
-1.224665989043784131260454301280E-1_stnd , &
-4.857910454732976198562745578156E-2_stnd , &
2.228157325962656425537280474671E-1_stnd , &
1.459764751457503859063666414952E-1_stnd , &
-1.211789553452468781539987084682E-1_stnd /)
!
REAL(kind=stnd), DIMENSION(ORBITS), PARAMETER :: &
W6 = (/ &
-3.326760468009974589269134283992E-1_stnd , &
1.796655319904795478676993902115E-1_stnd , &
-4.389976396805911868560791966472E-2_stnd , &
-2.295841771339316497310760908889E-1_stnd , &
6.182618387692816082856552878852E-2_stnd , &
-1.202703885325137746461829140891E-1_stnd , &
5.109536580363550180208564374234E-3_stnd , &
1.126062761533095493689566169969E-1_stnd /)
!
REAL(kind=stnd), DIMENSION(ORBITS), PARAMETER :: &
W7 = (/ &
2.290638530086106512999345512401E-1_stnd , &
2.702070398116919449911037051753E-1_stnd , &
-9.078047988731123605988441792069E-3_stnd , &
4.618480310858703283999169489655E-2_stnd , &
-2.598231009547631799096616255056E-1_stnd , &
-2.518433931146441037986247681820E-2_stnd , &
-1.257796993152456033984707367389E-2_stnd , &
-2.720818902721190304043617320910E-2_stnd /)
!
REAL(kind=stnd), DIMENSION(ORBITS), PARAMETER :: &
W8 = (/ &
2.746908885094872977794932213372E-1_stnd , &
-1.149427039769738298032807785523E-2_stnd , &
1.596178537820019535731955591283E-1_stnd , &
-2.180626972663360443142752377527E-1_stnd , &
-8.711748038292630173597899697063E-3_stnd , &
1.902786182960269617633915869710E-1_stnd , &
-1.189840649092108827784089292890E-1_stnd , &
2.883382565767354162177931122471E-2_stnd /)
REAL(kind=stnd), DIMENSION(1:8,1:ORBITS), PARAMETER :: &
WEIGHT = RESHAPE( SOURCE= (/ W1,W2,W3,W4,W5,W6,W7,W8 /),&
SHAPE=(/8,ORBITS/), ORDER=(/2,1/) )
!
! Local variables.
!
INTEGER :: J,NUMBER,GENTYPE,NR,P
REAL(kind=stnd):: R1,R2,R3,R,NOISE,DEG7,DEG5,DEG3,DEG1, &
DIFFX,DIFFY,Z1,Z2
REAL(kind=stnd), DIMENSION(2,8) :: X
REAL(kind=stnd), DIMENSION(NUMFUN,7) :: NullRule
REAL(kind=stnd), DIMENSION(NUMFUN) :: SUMVAL
!
!***FIRST EXECUTABLE STATEMENT Rule_C2a
!
! The number of points used by the cubature formula is
! NUM = K(0) + 4*K(1) + 4*K(2) + 8*K(3)
NUM = 37
!
!
! Initialise BASVAL and NullRule
!
BASVAL = 0
NullRule = 0
P = 1
!
! Compute contributions from orbits with 1, 4 and 8 points
!
DO GENTYPE = 0,3
DO NR = 1,K(GENTYPE)
SELECT CASE (GENTYPE)
CASE (0) ! Generator ( 0 , 0 )
NUMBER = 1
X(:,1) = (VER(:,2)+VER(:,3))*HALF
CASE (1) ! Generator ( z1 , 0 )
Z1 = TYPE1(NR)
NUMBER = 4
Z1 = Z1*HALF
X(:,1) = -VER(:,1)*Z1 + VER(:,2)*HALF + &
VER(:,3)* (Z1+HALF)
X(:,2) = VER(:,1)*Z1 + VER(:,2)*HALF + &
VER(:,3)* (-Z1+HALF)
X(:,3) = VER(:,1)*Z1 + VER(:,2)* (-Z1+HALF) + &
VER(:,3)*HALF
X(:,4) = -VER(:,1)*Z1 + VER(:,2)* (Z1+HALF) + &
VER(:,3)*HALF
CASE (2) ! Generator ( z(1) , z(1) )
Z1 = TYPE2(NR)
NUMBER = 4
Z1 = Z1*HALF
X(:,1) = -2*VER(:,1)*Z1 + VER(:,2)* (HALF+Z1) +&
VER(:,3)* (Z1+HALF)
X(:,2) = VER(:,2)* (HALF+Z1) + VER(:,3)* (-Z1+HALF)
X(:,3) = VER(:,2)* (HALF-Z1) + VER(:,3)* (Z1+HALF)
X(:,4) = 2*VER(:,1)*Z1 + VER(:,2)* (HALF-Z1) + &
VER(:,3)* (-Z1+HALF)
CASE (3) ! Generator ( z(1) , z(2) )
Z1 = TYPE3(1,NR)*HALF
Z2 = TYPE3(2,NR)*HALF
NUMBER = 8
X(:,1) = VER(:,1)* (-Z1-Z2) + &
VER(:,2)* (HALF+Z2) + VER(:,3)* (HALF+Z1)
X(:,2) = VER(:,1)* (+Z1-Z2) + &
VER(:,2)* (HALF+Z2) + VER(:,3)* (HALF-Z1)
X(:,3) = VER(:,1)* (-Z1+Z2) + &
VER(:,2)* (HALF-Z2) + VER(:,3)* (HALF+Z1)
X(:,4) = VER(:,1)* (+Z1+Z2) + &
VER(:,2)* (HALF-Z2) + VER(:,3)* (HALF-Z1)
X(:,5) = VER(:,1)* (-Z1-Z2) + &
VER(:,2)* (HALF+Z1) + VER(:,3)* (HALF+Z2)
X(:,6) = VER(:,1)* (+Z2-Z1) + &
VER(:,2)* (HALF+Z1) + VER(:,3)* (HALF-Z2)
X(:,7) = VER(:,1)* (-Z2+Z1) + &
VER(:,2)* (HALF-Z1) + VER(:,3)* (HALF+Z2)
X(:,8) = VER(:,1)* (+Z1+Z2) + &
VER(:,2)* (HALF-Z1) + VER(:,3)* (HALF-Z2)
END SELECT
! CALL Integrand(2,X(1,1),NUMFUN,SUMVAL)
SUMVAL = Integrand(NUMFUN,X(:,1))
SELECT CASE (GENTYPE)
CASE (0)
DIFFy = SUMVAL(1)*DFC(0)
DIFFx = DIFFy
CASE (1)
DIFFy = DIFFy + SUMVAL(1)*DFC(NR)
END SELECT
DO J = 2,NUMBER
RGNERR = Integrand(NUMFUN,X(:,J))
! CALL Integrand(2,X(1,J),NUMFUN,RGNERR)
IF (GENTYPE == 1) THEN
IF (J <= 2) THEN
DIFFy = DIFFy + RGNERR(1)*DFC(NR)
ELSE
DIFFx = DIFFx + RGNERR(1)*DFC(NR)
END IF
END IF
DO I = 1,NUMFUN
SUMVAL(I) = SUMVAL(I) + RGNERR(I)
END DO
END DO
DO J = 1,NUMFUN
BASVAL(J) = BASVAL(J) + WEIGHT(1,P)*SUMVAL(J)
DO I = 1,7
NullRule(J,I) = NullRule(J,I) + WEIGHT(I+1,P)*SUMVAL(J)
END DO
END DO
P = P + 1
END DO
END DO
!
! Decide on future subdivision direction
!
DIFFy = ABS(DIFFy)
DIFFx = ABS(DIFFx)
IF (MAX(DIFFy,DIFFx) < CUTOFF) THEN
INFOLD(4) = 0
ELSE IF (DIFFy < DFCLEV*DIFFx) THEN
INFOLD(4) = 1
ELSE IF (DIFFx < DFCLEV*DIFFy) THEN
INFOLD(4) = 2
ELSE
INFOLD(4) = 0
END IF
!
! Compute errors.
!
DO J = 1,NUMFUN
NOISE = ABS(BASVAL(J))*TRES
DEG7 = SQRT(NullRule(J,1)**2+NullRule(J,2)**2)
IF (DEG7 <= NOISE) THEN
RGNERR(J) = NOISE
ELSE
DEG5 = SQRT(NullRule(J,3)**2+NullRule(J,4)**2)
DEG3 = SQRT(NullRule(J,5)**2+NullRule(J,6)**2)
DEG1 = SQRT(NullRule(J,7)**2+NullRule(J,6)**2)
IF (DEG5 /= 0) THEN
R1 = DEG7/DEG5
ELSE
R1 = 1
END IF
IF (DEG3 /= 0) THEN
R2 = DEG5/DEG3
ELSE
R2 = 1
END IF
IF (DEG1 /= 0) THEN
R3 = DEG3/DEG1
ELSE
R3 = 1
END IF
R = MAX(R1,R2,R3)
IF (R >= 1) THEN
INFOLD(5) = 0
RGNERR(J) = FACMED*DEG7
ELSE IF (R >= CRIVAL) THEN
INFOLD(5) = 0
RGNERR(J) = FACMED*DEG7*R
ELSE
INFOLD(5) = 1
RGNERR(J) = FACOPT* (R**3)*DEG7
END IF
RGNERR(J) = MAX(NOISE,RGNERR(J))
END IF
RGNERR(J) = AREA*RGNERR(J)/FOUR
BASVAL(J) = AREA*BASVAL(J)/FOUR
END DO
RETURN
END SUBROUTINE Rule_C2a
END Module CubatureRule_C2
SHAR_EOF
fi # end of overwriting check
if test -f 'rule_c3.f90'
then
echo shar: will not over-write existing file "'rule_c3.f90'"
else
cat << "SHAR_EOF" > 'rule_c3.f90'
! This file is F-compatible, except for upper/lower case conventions.
!--------------------------------------------------------------------
Module CubatureRule_C3
USE Precision_Model, ONLY: stnd
Implicit NONE
PRIVATE
PUBLIC :: Rule_C3a
CONTAINS
SUBROUTINE Rule_C3a(VER,INFOLD,VOLUME,NUMFUN,Integrand,BASVAL,RGNERR,NUM)
!
!***BEGIN PROLOGUE Rule_C3a
!***DATE WRITTEN 970430 (YYMMDD)
!***REVISION DATE 990528 (YYMMDD) (F conversion)
!***REVISION DATE 990604 (YYMMDD) (divisions removed)
!***REVISION DATE 010919 (YYMMDD) (subdivision information changed)
!***AUTHOR
! Erwin Goor & Ronald Cools
!***PURPOSE To compute basic integration rule values and
! corresponding error estimates.
!***DESCRIPTION Rule_C3a computes basic integration rule values
! for a vector of integrands over a cube.
! Rule_C3a also computes estimates for the errors by
! using several null rule approximations.
! ON ENTRY
!
! VER Real array of dimension (3,4).
! The coordinates of the vertices of the cube.
! vertex i -> ( ver(1,i),ver(2,i),ver(3,i) )
! NUMFUN Integer.
! Number of components of the vector integrand.
! Integrand Externally declared subroutine for computing
! all components of the integrand at the given
! evaluation point.
! It must have parameters (X)
! Input parameters:
! X(1) The x-coordinate of the evaluation point.
! X(2) The y-coordinate of the evaluation point.
! X(3) The z-coordinate of the evaluation point.
!
! ON RETURN
!
! BASVAL Real array of dimension NUMFUN.
! The values for the basic rule for each component
! of the integrand.
! RGNERR Real array of dimension NUMFUN.
! The error estimates for each component of the integrand.
! NUM Integer
! The number of function evaluations used.
! INFOLD(4) contains useful information for future subdivisions.
! This is a 2 digit number.
! The least significant digit contains info for 2-division.
! The most significant digit contains info for 2/4/8-division.
!
!***REFERENCES Terje O. Espelid,
! On the construction of good fully symmetric integration rules
! SIAM J. NUMER. ANAL., Vol 24, No 4, August 1987.
!***ROUTINES CALLED
! OrbC3_Sum,Integrand
!***END PROLOGUE Rule_C3a
!
! Parameters
!
! ORBITS Integer
! The number of orbits of the cubature formula and null rules
! CRIVAL Real
! The decision to choose the optimistic part of the error
! estimator is based on CRIVAL
! FACMED Real
! FACMED is the safety coefficient used in the non-optimistic
! part of the error estimator. FACMED is related to CRIVAL
! and FACOPT.
! FACOPT Real
! FACOPT is the safety coefficient used in the optimistic part
! of the error estimator.
! K Integer array of dimension (0:4) that contains the structure
! parameters. K(I) = number of orbits of type I.
! TYPE0 Real array of dimension (K(0)).
! Contains the first homogeneous coordinate of the generators
! of type 0
! TYPE1 Real array of dimension (K(1)).
! Contains the first homogeneous coordinate of the generators
! of type 1
! TYPE2 Real array of dimension (K(2)).
! Contains the first homogeneous coordinate of the generators
! of type 2
! TYPE3 Real array of dimension (K(3)).
! Contains the first homogeneous coordinate of the generators
! of type 3
! TYPE4 Real array of dimension (2,K(4)).
! Contains the first two homogeneous coordinates of
! the generators of type 4.
! WEIGHT Real array of dimension (8,ORBITS).
! The weights of the cubature formula and the null rules.
! WEIGHT(1,1) ,..., WEIGHT(1,ORBITS) are the weights of the
! cubature formula
! WEIGHT(I,1) ,..., WEIGHT(I,ORBITS) for I > 1, are the weights
! of the null rules
!
!
! Global variables.
!
INTEGER, INTENT(IN) :: NUMFUN
INTEGER, INTENT(OUT) :: NUM
INTEGER, DIMENSION(:), INTENT(IN OUT) :: INFOLD
REAL(kind=stnd), DIMENSION(:,:), INTENT(IN) :: VER
REAL(kind=stnd), DIMENSION(:), INTENT(OUT) :: BASVAL, RGNERR
REAL(kind=stnd), INTENT(IN) :: VOLUME
INTERFACE
FUNCTION Integrand(NUMFUN,X) RESULT(Value)
USE Precision_Model
INTEGER, INTENT(IN) :: NUMFUN
REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: X
REAL(kind=stnd), DIMENSION(NUMFUN) :: Value
END FUNCTION Integrand
END INTERFACE
!
! Constants
!
INTEGER, PARAMETER :: ORBITS = 8
REAL(kind=stnd), PARAMETER:: HALF=0.5_stnd, &
TRES=50*EPSILON(HALF), &
EIGHT=8.0_stnd, &
CRIVAL=0.5_stnd, &
FACMED=16.0_stnd, &
FACOPT=FACMED/CRIVAL, &
CUTOFF=0.0001_stnd, &
BOUND1=0.55_stnd, &
BOUND2=0.1_stnd
REAL(kind=stnd),DIMENSION(0:2),PARAMETER :: &
DFC = (/-1.888242615950863158_stnd, &
1.0_stnd, &
-0.055878692024568421_stnd/)
!
! Cubature formula of degree 11 with 89 points
!
INTEGER, DIMENSION(0:4), PARAMETER :: &
K = (/1,2,1,2,2/) ! Rule structure parameters
!
! Information for the generators
!
INTEGER :: I
REAL(kind=stnd), DIMENSION(1:2), PARAMETER :: &
TYPE1 = (/ 0.18052075573249470822058794973169_stnd, &
0.76366700531389881917491285487593_stnd/)
REAL(kind=stnd), DIMENSION(1:1), PARAMETER :: &
TYPE2 = (/ 0.78830647250493547382701809890320_stnd/)
REAL(kind=stnd), DIMENSION(1:2), PARAMETER :: &
TYPE3 = (/ 0.52144095618907883093466563244662_stnd, &
0.82617221731829521680258049987187_stnd/)
REAL(kind=stnd), DIMENSION(1:2,1:2), PARAMETER :: &
TYPE4 = RESHAPE( SOURCE= (/ &
0.97242481190902569341735290339642_stnd, &
0.42110799536126494561573004212340_stnd, &
0.46744847718063717386066856549398_stnd, &
0.95930890177116312068682678508629_stnd/),&
SHAPE=(/2,2/), ORDER=(/2,1/) )
!
! Weights of the cubature formula
!
REAL(kind=stnd), DIMENSION(1:ORBITS), PARAMETER :: &
W1 = (/ &
-3.8953757160532611282600158759761_stnd, &
0.81856660649734492124488620848997_stnd, &
0.21531990811243713389570303707084_stnd, &
0.13294125786605972133694036186057_stnd, &
0.20860736817139167236507600668966_stnd, &
0.58773830247770211247176280672459E-1_stnd, &
0.14162520571796920029532663140195E-1_stnd, &
0.67408810538559624656933076917621E-1_stnd /)
!
! Weights of the null rule of degree 7
!
REAL(kind=stnd), DIMENSION(1:ORBITS), PARAMETER :: &
W2 = (/ &
-4.09716713830698487528731726354974_stnd, &
0.74677969141515975595448607337805_stnd, &
-0.46417363966526945568711797402935E-1_stnd, &
0.17727896857214604523364317327611E-1_stnd, &
-0.52470267108342327292624832196503E-1_stnd, &
0.11664449246716569286439872549707E-1_stnd, &
-0.53791657604525012052256857235844E-2_stnd, &
0.57418721863532854861331639295054E-2_stnd /)
!
! Weights of null rule of degree 5
!
REAL(kind=stnd), DIMENSION(1:ORBITS), PARAMETER :: &
W3 = (/ &
-0.38418257346076321180942534161643E-1_stnd, &
-0.13809393819461658172313782493931_stnd, &
-0.36966067391537395134033779422780_stnd, &
-0.84000216250042784132468820210803_stnd, &
0.98945444020489415899976989198423_stnd, &
-0.41711084444475038186621253136889_stnd, &
0.16359771673332304281428383670012_stnd, &
0.19416157968042709878528265453063_stnd /)
!
! Weights of first null rule of degree 5
!
REAL(kind=stnd), DIMENSION(1:ORBITS), PARAMETER :: &
W4 = (/ &
-0.14339024357997965865651041863131_stnd, &
-0.66574999845489902738481549374176_stnd, &
1.41839687939449181019382815244241_stnd, &
-0.38081150117982085429476186080312E-1_stnd, &
0.34239475207312939941374219725925_stnd, &
-0.23914717080898300739086398648709_stnd, &
0.17286429544022414400537142491791_stnd, &
-0.37042670755501427522315796603400_stnd/)
!
! Weights of second null rule of degree 5
!
REAL(kind=stnd), DIMENSION(1:ORBITS), PARAMETER :: &
W5 = (/ &
0.22799738734760429615753528373102E-2_stnd, &
0.11905590372687096358500385350270E-1_stnd, &
0.33061061773693696525589383114487_stnd, &
-0.85087326218125136673746262977113_stnd, &
-0.36662650042420411259687111438947_stnd, &
0.67323896068825610599714357264483_stnd, &
-0.21824874793205523689197441637244_stnd, &
0.45575717466252940526695071801422_stnd/)
!
! Weights of null rule of degree 3
!
REAL(kind=stnd), DIMENSION(1:ORBITS), PARAMETER :: &
W6 = (/ &
0.90256803909235587533523794574584E-1_stnd, &
0.48637869392568312594620915328833_stnd, &
0.22605864607138151215790621639873_stnd, &
-0.39733053275758221554551132969977_stnd, &
-0.70260525791346956325766210839408_stnd, &
-0.99463956560911321939850485360746_stnd, &
0.40396337255003509831702095024785_stnd, &
0.17858013317413262800119803474017_stnd/)
!
! Weights of null rule of degree 3
!
REAL(kind=stnd), DIMENSION(1:ORBITS), PARAMETER :: &
W7 = (/ &
-0.14921225605249988383647637370117_stnd, &
-0.85591937094309731035699238944552_stnd, &
-0.19099496525254529541694749463933_stnd, &
0.19040522291618896750255618030982_stnd, &
-0.27115051668249444743700654045145_stnd, &
-0.35979905900549990374887346342547_stnd, &
-0.30255473948150702142743236951006_stnd, &
0.68561441463717546800811910057288_stnd/)
!
! Weights of null rule of degree 1
!
REAL(kind=stnd), DIMENSION(1:ORBITS), PARAMETER :: &
W8 = (/ &
-0.08621714823499486708026259436068_stnd, &
-0.50649036609789532778219912403455_stnd, &
-0.32380295374003822370848233043689_stnd, &
-0.20985459608863301976909856362672_stnd, &
-0.32887361592661612467795805597359_stnd, &
0.21614962128074085470205806229955_stnd, &
0.73079630784536188048918935662702_stnd, &
-0.37712863378314543994499210520609_stnd/)
!
REAL(kind=stnd), DIMENSION(1:8,1:ORBITS), PARAMETER :: &
WEIGHT = RESHAPE( SOURCE= (/ W1,W2,W3,W4,W5,W6,W7,W8/), &
SHAPE=(/8,ORBITS/), ORDER=(/2,1/) )
!
! Local variables.
!
INTEGER :: J,NR,P,REGTYPE,NUMBER
INTEGER, DIMENSION(1:3) :: DIFFINDEX
REAL(kind=stnd):: NOISE,DEG7,DEG5,DEG3,DEG1,R3,R2,R1,R, &
Z1,Z2
REAL(kind=stnd), DIMENSION(NUMFUN,7) :: NullRule
REAL(kind=stnd), DIMENSION(NUMFUN) :: SUMVAL
REAL(kind=stnd), DIMENSION(1:3) :: DIFF
REAL(kind=stnd), DIMENSION(3,24) :: X
!
!***FIRST EXECUTABLE STATEMENT Rule_C3a
!
! The number of points used by the cubature formula is
! NUM = 1*K(0) + 6*K(1) + 12*K(2) + 8*K(3) +24*K(4) = 89
NUM = 89
!
! Initialise BASVAL and NullRule
!
BASVAL = 0
NullRule = 0
!
! Compute contributions from orbits with 1, 6, 12, 8 and 24 points
!
P = 1
DO REGTYPE = 0,4
DO NR = 1,K(REGTYPE)
SELECT CASE (REGTYPE)
CASE (0) ! Generator ( 0, 0, 0 )
NUMBER = 1
X(:,1) = (VER(:,2) + VER(:,3))*HALF + &
( VER(:,4) - VER(:,1) )*HALF
CASE (1) ! Generator ( z1 , 0, 0 )
Z1 = TYPE1(NR)*HALF
NUMBER = 6
X(:,1) = -VER(:,1)*(z1+HALF) + VER(:,2)*HALF + &
VER(:,3)*HALF + VER(:,4)*(Z1+HALF)
X(:,2) = VER(:,1)*(z1-HALF) + VER(:,2)*HALF + &
VER(:,3)*HALF + VER(:,4)*(-Z1+HALF)
X(:,3) = -VER(:,1)*(z1+HALF) + VER(:,2)*HALF + &
VER(:,4)*HALF + VER(:,3)*(Z1+HALF)
X(:,4) = VER(:,1)*(z1-HALF) + VER(:,2)*HALF + &
VER(:,4)*HALF + VER(:,3)*(-Z1+HALF)
X(:,5) = -VER(:,1)*(z1+HALF) + VER(:,4)*HALF + &
VER(:,3)*HALF + VER(:,2)*(Z1+HALF)
X(:,6) = VER(:,1)*(z1-HALF) + VER(:,4)*HALF + &
VER(:,3)*HALF + VER(:,2)*(-Z1+HALF)
CASE (2) ! Generator ( z1 , z1, 0 )
Z1 = TYPE2(NR)*HALF
NUMBER = 12
X(:,1) = -VER(:,1)*(2*z1+HALF) + VER(:,4)*HALF + &
(VER(:,2) + VER(:,3))*(Z1+HALF)
X(:,2) = VER(:,1)*(2*z1-HALF) + VER(:,4)*HALF + &
(VER(:,2) + VER(:,3))*(-Z1+HALF)
X(:,3) = -VER(:,1)*(HALF) + VER(:,4)*HALF + &
VER(:,2)*(-z1+HALF) + VER(:,3)*(z1+HALF)
X(:,4) = -VER(:,1)*(HALF) + VER(:,4)*HALF + &
VER(:,3)*(-z1+HALF) + VER(:,2)*(z1+HALF)
X(:,5) = -VER(:,1)*(2*z1+HALF) + VER(:,3)*HALF + &
(VER(:,2) + VER(:,4))*(Z1+HALF)
X(:,6) = VER(:,1)*(2*z1-HALF) + VER(:,3)*HALF + &
(VER(:,2) + VER(:,4))*(-Z1+HALF)
X(:,7) = -VER(:,1)*(HALF) + VER(:,3)*HALF + &
VER(:,2)*(-z1+HALF) + VER(:,4)*(z1+HALF)
X(:,8) = -VER(:,1)*(HALF) + VER(:,3)*HALF + &
VER(:,4)*(-z1+HALF) + VER(:,2)*(z1+HALF)
X(:,9) = -VER(:,1)*(2*z1+HALF) + VER(:,2)*HALF + &
(VER(:,4) + VER(:,3))*(Z1+HALF)
X(:,10) = VER(:,1)*(2*z1-HALF) + VER(:,2)*HALF + &
(VER(:,4) + VER(:,3))*(-Z1+HALF)
X(:,11) = -VER(:,1)*(HALF) + VER(:,2)*HALF + &
VER(:,4)*(-z1+HALF) + VER(:,3)*(z1+HALF)
X(:,12) = -VER(:,1)*(HALF) + VER(:,2)*HALF + &
VER(:,3)*(-z1+HALF) + VER(:,4)*(z1+HALF)
CASE (3) ! Generator ( z1 , z1, z1 )
Z1 = TYPE3(NR)*HALF
NUMBER = 8
X(:,1) = -VER(:,1)*(3*z1 + HALF) + VER(:,2)*(HALF + z1) + &
VER(:,3)*(HALF + z1) + VER(:,4)*(HALF + z1)
X(:,2) = -VER(:,1)*(z1 + HALF) + VER(:,2)*(HALF - z1) + &
VER(:,3)*(HALF + z1) + VER(:,4)*(HALF + z1)
X(:,3) = -VER(:,1)*(z1 + HALF) + VER(:,2)*(HALF + z1) + &
VER(:,3)*(HALF - z1) + VER(:,4)*(HALF + z1)
X(:,4) = -VER(:,1)*(z1 + HALF) + VER(:,2)*(HALF + z1) + &
VER(:,3)*(HALF + z1) + VER(:,4)*(HALF - z1)
X(:,5) = -VER(:,1)*(-z1 + HALF) + VER(:,2)*(HALF - z1) + &
VER(:,3)*(HALF - z1) + VER(:,4)*(HALF + z1)
X(:,6) = -VER(:,1)*(-z1 + HALF) + VER(:,2)*(HALF - z1) + &
VER(:,3)*(HALF + z1) + VER(:,4)*(HALF - z1)
X(:,7) = -VER(:,1)*(-z1 + HALF) + VER(:,2)*(HALF + z1) + &
VER(:,3)*(HALF - z1) + VER(:,4)*(HALF - z1)
X(:,8) = VER(:,1)*(3*z1 - HALF) + VER(:,2)*(HALF - z1) + &
VER(:,3)*(HALF - z1) + VER(:,4)*(HALF - z1)
CASE (4) ! Generator ( z1 , z1, z2 )
Z1 = TYPE4(1,NR)*HALF
Z2 = TYPE4(2,NR)*HALF
NUMBER = 24
X(:,1) = -VER(:,1)*(2*z1+z2+HALF) + VER(:,4)*(HALF + z2) + &
VER(:,2)*(HALF + z1)+ VER(:,3)*(HALF + z1)
X(:,2) = -VER(:,1)*(2*z1-z2+HALF) + VER(:,4)*(HALF - z2) + &
VER(:,2)*(HALF + z1)+ VER(:,3)*(HALF + z1)
X(:,3) = -VER(:,1)*(z2+HALF) + VER(:,4)*(HALF + z2) + &
VER(:,2)*(HALF - z1)+ VER(:,3)*(HALF + z1)
X(:,4) = -VER(:,1)*(z2+HALF) + VER(:,4)*(HALF + z2) + &
VER(:,2)*(HALF + z1)+ VER(:,3)*(HALF - z1)
X(:,5) = -VER(:,1)*(-2*z1+z2+HALF) + VER(:,4)*(HALF + z2) + &
VER(:,2)*(HALF - z1)+ VER(:,3)*(HALF - z1)
X(:,6) = -VER(:,1)*(-z2+HALF) + VER(:,4)*(HALF - z2) + &
VER(:,2)*(HALF + z1)+ VER(:,3)*(HALF - z1)
X(:,7) = -VER(:,1)*(-z2+HALF) + VER(:,4)*(HALF - z2) + &
VER(:,2)*(HALF - z1)+ VER(:,3)*(HALF + z1)
X(:,8) = -VER(:,1)*(-2*z1-z2+HALF) + VER(:,4)*(HALF - z2) + &
VER(:,2)*(HALF - z1)+ VER(:,3)*(HALF - z1)
X(:,9) = -VER(:,1)*(2*z1+z2+HALF) + VER(:,2)*(HALF + z2) + &
VER(:,4)*(HALF + z1)+ VER(:,3)*(HALF + z1)
X(:,10) = -VER(:,1)*(2*z1-z2+HALF) + VER(:,2)*(HALF - z2) + &
VER(:,4)*(HALF + z1)+ VER(:,3)*(HALF + z1)
X(:,11) = -VER(:,1)*(z2+HALF) + VER(:,2)*(HALF + z2) + &
VER(:,4)*(HALF - z1)+ VER(:,3)*(HALF + z1)
X(:,12) = -VER(:,1)*(z2+HALF) + VER(:,2)*(HALF + z2) + &
VER(:,4)*(HALF + z1)+ VER(:,3)*(HALF - z1)
X(:,13) = -VER(:,1)*(-2*z1+z2+HALF) + VER(:,2)*(HALF + z2) + &
VER(:,4)*(HALF - z1)+ VER(:,3)*(HALF - z1)
X(:,14) = -VER(:,1)*(-z2+HALF) + VER(:,2)*(HALF - z2) + &
VER(:,4)*(HALF + z1)+ VER(:,3)*(HALF - z1)
X(:,15) = -VER(:,1)*(-z2+HALF) + VER(:,2)*(HALF - z2) + &
VER(:,4)*(HALF - z1)+ VER(:,3)*(HALF + z1)
X(:,16) = -VER(:,1)*(-2*z1-z2+HALF) + VER(:,2)*(HALF - z2) + &
VER(:,4)*(HALF - z1)+ VER(:,3)*(HALF - z1)
X(:,17) = -VER(:,1)*(2*z1+z2+HALF) + VER(:,3)*(HALF + z2) + &
VER(:,2)*(HALF + z1)+ VER(:,4)*(HALF + z1)
X(:,18) = -VER(:,1)*(2*z1-z2+HALF) + VER(:,3)*(HALF - z2) + &
VER(:,2)*(HALF + z1)+ VER(:,4)*(HALF + z1)
X(:,19) = -VER(:,1)*(z2+HALF) + VER(:,3)*(HALF + z2) + &
VER(:,2)*(HALF - z1)+ VER(:,4)*(HALF + z1)
X(:,20) = -VER(:,1)*(z2+HALF) + VER(:,3)*(HALF + z2) + &
VER(:,2)*(HALF + z1)+ VER(:,4)*(HALF - z1)
X(:,21) = -VER(:,1)*(-2*z1+z2+HALF) + VER(:,3)*(HALF + z2) + &
VER(:,2)*(HALF - z1)+ VER(:,4)*(HALF - z1)
X(:,22) = -VER(:,1)*(-z2+HALF) + VER(:,3)*(HALF - z2) + &
VER(:,2)*(HALF + z1)+ VER(:,4)*(HALF - z1)
X(:,23) = -VER(:,1)*(-z2+HALF) + VER(:,3)*(HALF - z2) + &
VER(:,2)*(HALF - z1)+ VER(:,4)*(HALF + z1)
X(:,24) = -VER(:,1)*(-2*z1-z2+HALF) + VER(:,3)*(HALF - z2) + &
VER(:,2)*(HALF - z1)+ VER(:,4)*(HALF - z1)
END SELECT
SUMVAL = Integrand(NUMFUN,X(:,1))
SELECT CASE (REGTYPE)
CASE (0)
DIFF(2) = SUMVAL(1)*DFC(0)
DIFF(1) = DIFF(2)
DIFF(3) = DIFF(2)
CASE (1)
DIFF(3) = DIFF(3) + SUMVAL(1)*DFC(NR)
END SELECT
DO J = 2,NUMBER
RGNERR = Integrand(NUMFUN,X(:,J))
IF ( REGTYPE == 1 ) THEN
IF ( J <= 2 ) THEN
DIFF(3) = DIFF(3) + RGNERR(1)*DFC(NR)
ELSE IF ( (J == 3) .OR. (J == 4) ) THEN
DIFF(2) = DIFF(2) + RGNERR(1)*DFC(NR)
ELSE
DIFF(1) = DIFF(1) + RGNERR(1)*DFC(NR)
END IF
END IF
SUMVAL(1:NUMFUN) = SUMVAL(1:NUMFUN) + RGNERR(1:NUMFUN)
END DO
DO J = 1,NUMFUN
BASVAL(J) = BASVAL(J) + WEIGHT(1,P)*SUMVAL(J)
DO I = 1,7
NullRule(J,I) = NullRule(J,I) + WEIGHT(I+1,P)*SUMVAL(J)
END DO
END DO
P = P + 1
END DO
END DO
!
! Decide on future subdivision direction
!
DIFF = ABS(DIFF)
! Sort the fourth differences
DIFFINDEX = (/ 1,2,3 /)
DO I = 1,2
DO J = 1,(3-I)
IF ( DIFF(J+1) > DIFF(J) ) THEN
R = DIFF(J) ! dummy
DIFF(J) = DIFF(J+1)
DIFF(J+1) = R
P = DIFFINDEX(J) ! dummy
DIFFINDEX(J) = DIFFINDEX(J+1)
DIFFINDEX(J+1) = P
END IF
END DO
END DO
if ( diff(1) < cutoff ) then ! recommend uniform division
!! infold(4) = 0
infold(4) = 90+diffindex(1)
else
if ( diff(2) > bound1*diff(1) ) then
if ( diff(3) > bound2*diff(2) ) then
! recommend uniform division
!! infold(4) = 0
infold(4) = 90+diffindex(1)
else
! recommend division in 4
select case (diffindex(3))
case(1)
infold(4) = -3
case(2)
infold(4) = -1
case(3)
infold(4) = -2
end select
infold(4) = 10*infold(4) - diffindex(1)
end if
else
! recommend division in 2
infold(4) = diffindex(1)
end if
end if
!
! Compute error estimates
!
DO J = 1,NUMFUN
NOISE = ABS(BASVAL(J))*TRES
DEG7 = ABS( NullRule(J,1) )
IF (DEG7 <= NOISE) THEN
RGNERR(J) = NOISE
ELSE
DEG5 = SQRT(NullRule(J,2)**2+NullRule(J,3)**2)
DEG3 = SQRT(NullRule(J,4)**2+NullRule(J,5)**2)
DEG1 = SQRT(NullRule(J,6)**2+NullRule(J,7)**2)
IF (DEG5 /= 0) THEN
R1 = DEG7/DEG5
ELSE
R1 = 1
END IF
IF (DEG3 /= 0) THEN
R2 = DEG5/DEG3
ELSE
R2 = 1
END IF
IF (DEG1 /= 0) THEN
R3 = DEG3/DEG1
ELSE
R3 = 1
END IF
R = MAX(R1,R2,R3)
IF (R >= 1) THEN
INFOLD(5) = 0
RGNERR(J) = FACMED*DEG7
ELSE IF (R >= CRIVAL) THEN
INFOLD(5) = 0
RGNERR(J) = FACMED*R*DEG7
ELSE
INFOLD(5) = 1
RGNERR(J) = FACOPT*(R**2)*DEG7
END IF
RGNERR(J) = MAX(NOISE,RGNERR(J))
END IF
RGNERR(J) = VOLUME*RGNERR(J)/EIGHT
BASVAL(J) = VOLUME*BASVAL(J)/EIGHT
END DO
RETURN
END SUBROUTINE Rule_C3a
END Module CubatureRule_C3
SHAR_EOF
fi # end of overwriting check
if test -f 'rule_cn.f90'
then
echo shar: will not over-write existing file "'rule_cn.f90'"
else
cat << "SHAR_EOF" > 'rule_cn.f90'
! This file is F-compatible, except for upper/lower case conventions.
!--------------------------------------------------------------------
Module CubatureRule_Cn
USE Precision_Model, ONLY: stnd
Implicit NONE
PRIVATE
PUBLIC :: Rule_Cn
PRIVATE :: Rule_Deg7, Rule_Deg9, SymCub_Sum
CONTAINS
SUBROUTINE Rule_Cn(KEY,N,VERTEX,INFOLD,VOLUME,NF,Integrand,BASVAL,RGNERR,NUM)
!
!***BEGIN PROLOGUE Rule_Cn
!***DATE WRITTEN 990701 (YYMMDD)
!***REVISION DATE 000814 (Handling of KEY now similar to Tn; changed by RC)
!***AUTHOR
!
! Alan Genz
! Department of Mathematics
! Washington State University
! Pullman, WA 99164-3113, USA
!
!
!***PURPOSE To compute basic integration rule values and
! corresponding error estimates.
!***DESCRIPTION Rule_Cn7computes basic integration rule values
! for a vector of integrands over a dim hyperrectangle
! Rule_Cn7 also computes estimates for the errors by
! using several null rule approximations.
! We use a degree 7 integration rule,
! two degree 5 null rules, one degree 3 null rule and one
! degree 1 null rule for the hypercube.
! RESTRICTION : this routine will only give correct results
! for dim > 2.
! ON ENTRY
!
! KEY Integer.
! If Key > 2 and Key < 5 then a rule of degree 2*Key + 1
! is used; otherwise a default rule of degree 7 is used.
! N Integer, dimension of the integration problem
! VERTEX Real array of dimension (N,0:N).
! The coordinates of the vertices of the parallelepiped.
! vertex i -> ( vertex(1,i),vertex(2,i),...,vertex(N,i) )
! NF Integer, number of components of the vector integrand.
! Integrand Real vector function of length NF for computing components of
! the integrand at X.
! It must have parameters ( NF, X ); see interface below
! Input parameters:
! X Real array of length N, the evaluation point.
! NF Integer number of components of Integrand.
!
! ON RETURN
!
! BASVAL Real array of dimension NF.
! The values for the basic rule for each component
! of the integrand.
! RGNERR Real array of dimension NF.
! The error estimates for each component of the integrand.
! NUM Integer, number of function evaluations used.
!
!***REFERENCES A. Genz and A. Malik,
! "An Imbedded Family of Fully Symmetric Numerical
! Integration Rules",
! SIAM J Numer. Anal. 20 (1983), pp. 580-588.
!***ROUTINES CALLED
! Integrand, SymCub_Sum, Rule_Deg7, Rule_Deg9
!***END PROLOGUE Rule_Cn
!
INTEGER, INTENT(IN) :: KEY, N, NF
INTEGER, INTENT(OUT) :: NUM
INTEGER, DIMENSION(:), INTENT(INOUT) :: INFOLD
REAL(KIND=STND), DIMENSION(:,0:), INTENT(IN) :: VERTEX
REAL(KIND=STND), DIMENSION(:), INTENT(OUT) :: RGNERR, BASVAL
REAL(KIND=STND), INTENT(IN) :: VOLUME
INTERFACE
FUNCTION INTEGRAND(NF,X) RESULT(VALUE)
USE PRECISION_MODEL
INTEGER, INTENT(IN) :: NF
REAL(KIND=STND), DIMENSION(:), INTENT(IN) :: X
REAL(KIND=STND), DIMENSION(NF) :: VALUE
END FUNCTION INTEGRAND
END INTERFACE
!
INTEGER, PARAMETER :: MXW = 9, MXG = 4, RLS = 5
REAL(KIND=STND), DIMENSION(MXW,RLS), SAVE :: W
REAL(KIND=STND), DIMENSION(MXG,MXW), SAVE :: G
INTEGER, SAVE :: OLDKEY = -1, OLDN = 0
INTEGER, SAVE :: WTS, NUMR
!
INTEGER :: I, DIVAXN
REAL(KIND=STND), PARAMETER :: ONE = 1
REAL(KIND=STND), PARAMETER :: SMALL = 100*EPSILON(ONE)
REAL(KIND=STND), DIMENSION(N) :: CENTER, DFS, GTEMP
REAL(KIND=STND), DIMENSION(N,N) :: VERDIF
REAL(KIND=STND), DIMENSION(NF,RLS) :: RULE
REAL(KIND=STND), DIMENSION(NF,3) :: TEMP
REAL(KIND=STND), DIMENSION(NF) :: FRTHDF
REAL(KIND=STND) :: RATIO
!
IF ( KEY /= OLDKEY .OR. OLDKEY == -1 .OR. N /= OLDN ) THEN
OLDKEY = KEY
OLDN = N
SELECT CASE ( KEY )
CASE (4)
CALL Rule_Deg9( N, W, G, WTS, NUMR )
CASE DEFAULT
CALL Rule_Deg7( N, W, G, WTS, NUMR )
END SELECT
END IF
NUM = NUMR
VERDIF = ( VERTEX(:,1:N) - SPREAD( VERTEX(:,0), 2, N ) )/2
CENTER = VERTEX(:,0) + SUM( VERDIF, 2 )
DIVAXN = SUM( MAXLOC( SUM( ABS( VERDIF ), 1 ) ) )
TEMP(:,1) = INTEGRAND( NF, CENTER )
RULE = MATMUL( TEMP(:,1:1), W(1:1,1:RLS) )
RATIO = ( G(1,3)/G(1,2) )**2
DO I = 1, N
TEMP(:,2) = INTEGRAND( NF, CENTER - G(1,2)*VERDIF(:,I) ) &
+ INTEGRAND( NF, CENTER + G(1,2)*VERDIF(:,I) )
TEMP(:,3) = INTEGRAND( NF, CENTER - G(1,3)*VERDIF(:,I) ) &
+ INTEGRAND( NF, CENTER + G(1,3)*VERDIF(:,I) )
RULE = RULE + MATMUL( TEMP(:,2:3), W(2:3,1:RLS) )
FRTHDF = ABS( 2*(1-RATIO)*TEMP(:,1) + RATIO*TEMP(:,2) - TEMP(:,3) )/4
DFS(I) = SUM( FRTHDF, MASK = ABS(TEMP(:,1)) + FRTHDF > ABS(TEMP(:,1)) )
END DO
IF ( MAXVAL( DFS ) > 0 ) THEN
DIVAXN = SUM( MAXLOC( DFS ) )
END IF
INFOLD(4) = DIVAXN
!
! Finish computing the rule values.
!
DO I = 4, WTS
GTEMP( 1 : MIN(N,MXG-1) ) = G( 1 : MIN(N,MXG-1) , I )
IF ( N >= MXG ) THEN
GTEMP(MXG:N) = G(MXG,I)
END IF
TEMP(:,1) = SymCub_Sum( N, VERTEX, GTEMP, NF, INTEGRAND )
RULE = RULE + MATMUL( TEMP(:,1:1), W(I:I,1:RLS) )
END DO
!
! Compute errors.
!
RULE(:,2:5) = ABS( RULE(:,2:5) )
RULE(:,3) = MAX( RULE(:,2), RULE(:,3) )
RULE(:,2) = ABS( RULE(:,1) )
DO I = 3, 5
WHERE ( RULE(:,2) + RULE(:,I)/NUM <= RULE(:,2) )
RULE(:,I) = 0
END WHERE
END DO
RATIO = 5 + 8*KEY
WHERE ( RATIO*RULE(:,3) <= RULE(:,4) .AND. RATIO*RULE(:,4) <= RULE(:,5) )
RGNERR = VOLUME*RULE(:,3)/2
ELSEWHERE
RGNERR = VOLUME*MAXVAL( RULE(:,3:5), 2 )
END WHERE
BASVAL = VOLUME*RULE(:,1)
!
END SUBROUTINE Rule_Cn
!
SUBROUTINE Rule_Deg7( N, W, G, WTSR, NUMR )
!
!***BEGIN PROLOGUE Rule_Deg7
!***KEYWORDS basic integration rule, degree 7
!***PURPOSE To initialize a degree 7 basic rule, and null rules.
!***AUTHOR
!
! Alan Genz
! Department of Mathematics
! Washington State University
! Pullman, WA 99164-3113, USA
!
!***DATE WRITTEN 990701 (YYMMDD)
!***DESCRIPTION Rule_Deg7 initializes a degree 7 integration rule,
! two degree 5 null rules, one degree 3 null rule and one
! degree 1 null rule for the hypercube [-1,1]**N.
!
! ON ENTRY
!
! N Integer, number of variables.
!
! ON RETURN
! W Real array of dimension (WTS,5).
! The weights for the basic and null rules.
! W(1,1),...,W(WTS,1) are weights for the basic rule.
! W(I,1),...,W(WTS,I), for I > 1 are null rule weights.
! G Real array of dimension (N, WTS).
! The fully symmetric sum generators for the rules.
! G(1, J), ..., G(N, J) are the are the generators for the
! points associated with the Jth weights.
! WTSR Integer, WTS
! NUMR Integer, number of points for Rule_Deg7
!
!***REFERENCES A. Genz and A. Malik,
! "An Imbedded Family of Fully Symmetric Numerical
! Integration Rules",
! SIAM J Numer. Anal. 20 (1983), pp. 580-588.
!***ROUTINES CALLED-NONE
!***END PROLOGUE Rule_Deg7
!
! Global variables
!
! WTS Integer, PARAMETER.
! The number of weights in each of the rules : 6
!
INTEGER, INTENT(IN) :: N
REAL(KIND=STND), DIMENSION(:,:), INTENT(OUT) :: W, G
INTEGER, INTENT(OUT) :: WTSR, NUMR
!
! Constant, the size of RULPTS
!
INTEGER, PARAMETER :: WTS = 6
!
! Local Variables
!
INTEGER :: K
REAL(KIND=STND) :: TEMP, LAM0, LAM1, LAM2, LAMP, TWONDM
REAL(KIND=STND), DIMENSION(WTS) :: RULPTS
REAL(KIND=STND), DIMENSION(3) :: ALPHA
!
! Initialize generators, weights and RULPTS
!
G = 0
W = 0
TWONDM = 2**N
RULPTS(1) = 1
RULPTS(2:WTS-2) = 2*N
RULPTS(WTS-1) = 2*N*(N-1)
RULPTS(WTS) = TWONDM
!
! Compute squared generator parameters
!
LAM0 = 0.4707_STND
LAMP = 0.5625_STND
LAM1 = 4/( 15 - 5/LAM0 )
TEMP = (1 - LAM1/LAM0 )/27
LAM2 = ( 5 - 7*LAM1 - 35*TEMP )/( 7 - 35*LAM1/3 - 35*TEMP/LAM0 )
!
! Compute degree 7 rule weights
!
W(6,1) = 1/(3*LAM0)**3/TWONDM
W(5,1) = ( 1 - 5*LAM0/3 )/( 60*(LAM1-LAM0)*LAM1**2 )
W(3,1) = ( 1 - 5*LAM2/3 - 5*TWONDM*W(6,1)*LAM0*(LAM0-LAM2) ) &
/( 10*LAM1*(LAM1-LAM2) ) - 2*(N-1)*W(5,1)
W(2,1) = ( 1 - 5*LAM1/3 - 5*TWONDM*W(6,1)*LAM0*(LAM0-LAM1) ) &
/( 10*LAM2*(LAM2-LAM1) )
!
! Compute weights for 2 degree 5, 1 degree 3 and 1 degree 1 rules
!
W(6,2) = 1/( 36*LAM0**3 )/TWONDM
W(5,2) = ( 1 - 9*TWONDM*W(6,2)*LAM0**2 )/( 36*LAM1**2 )
W(3,2) = ( 1 - 5*LAM2/3 - 5*TWONDM*W(6,2)*LAM0*(LAM0-LAM2) ) &
/( 10*LAM1* (LAM1-LAM2) ) - 2* (N-1)*W(5,2)
W(2,2) = ( 1 - 5*LAM1/3 - 5*TWONDM*W(6,2)*LAM0*(LAM0-LAM1) ) &
/( 10*LAM2* (LAM2-LAM1) )
W(6,3) = 5/(108*LAM0**3)/TWONDM
W(5,3) = ( 1 - 9*TWONDM*W(6,3)*LAM0**2 )/( 36*LAM1**2 )
W(4,3) = ( 1 - 5*LAM1/3 - 5*TWONDM*W(6,3)*LAM0*(LAM0-LAM1) ) &
/( 10*LAMP*(LAMP-LAM1) )
W(3,3) = ( 1 - 5*LAMP/3 - 5*TWONDM*W(6,3)*LAM0* (LAM0-LAMP) ) &
/( 10*LAM1*(LAM1-LAMP) ) - 2*(N-1)*W(5,3)
W(6,4) = 1/( 54*LAM0**3 )/TWONDM
W(5,4) = ( 1 - 18*TWONDM*W(6,4)*LAM0**2 )/( 72*LAM1**2 )
W(3,4) = ( 1 - 10*LAM2/3 - 10*TWONDM*W(6,4)*LAM0*(LAM0-LAM2) ) &
/( 20*LAM1*(LAM1-LAM2) ) - 2*(N-1)*W(5,4)
W(2,4) = ( 1 - 10*LAM1/3 - 10*TWONDM*W(6,4)*LAM0*(LAM0-LAM1) ) &
/( 20*LAM2*(LAM2-LAM1) )
!
! Set generator values
!
LAM0 = SQRT(LAM0)
LAM1 = SQRT(LAM1)
LAM2 = SQRT(LAM2)
LAMP = SQRT(LAMP)
G( :,6) = LAM0
G(1:2,5) = LAM1
G( 1,2) = LAM2
G( 1,3) = LAM1
G( 1,4) = LAMP
!
! Compute constant weight values.
!
W(1,1:5) = 1 - MATMUL( RULPTS(2:WTS), W(2:WTS,1:5) )
!
! Compute final weight values; null rule weights are computed as
! differences between weights from highest degree and lower degree rules.
!
W(1:WTS,2:5) = W(1:WTS,2:5) - SPREAD( W(1:WTS,1), 2, 4 )
!
! Orthogonalize and normalize null rules.
!
TEMP = SUM( RULPTS*W(1:WTS,1)*W(1:WTS,1) )
W(1:WTS,2) = W(1:WTS,2)*SQRT( TEMP/SUM( RULPTS*W(1:WTS,2)*W(1:WTS,2) ) )
DO K = 3, 5
ALPHA(1:K-2) = -MATMUL( TRANSPOSE(W(1:WTS,2:K-1)), RULPTS*W(1:WTS,K) )
W(1:WTS,K) = W(1:WTS,K) + MATMUL( W(1:WTS,2:K-1), ALPHA(1:K-2) )/TEMP
W(1:WTS,K) = W(1:WTS,K)*SQRT(TEMP/SUM(RULPTS*W(1:WTS,K)*W(1:WTS,K)))
END DO
WTSR = WTS
NUMR = SUM( RULPTS )
!
END SUBROUTINE Rule_Deg7
!
SUBROUTINE Rule_Deg9( N, W, G, WTSR, NUMR )
!***BEGIN PROLOGUE Rule_Deg9
!***KEYWORDS basic integration rule, degree 9
!***PURPOSE To initialize a degree 9 basic rule and null rules.
!***AUTHOR
!
! Alan Genz
! Department of Mathematics
! Washington State University
! Pullman, WA 99164-3113, USA
!
!***DATE WRITTEN 990701 (YYMMDD)
!***DESCRIPTION Rule_Deg9 initializes a degree 9 integration rule,
! two degree 7 null rules, one degree 5 null rule and one
! degree 3 null rule for the hypercube [-1,1]**N.
!
! ON ENTRY
!
! N Integer, number of variables.
!
! ON RETURN
! W Real array of dimension (WTS,5).
! The weights for the basic and null rules.
! W(1,1),...,W(WTS,1) are weights for the basic rule.
! W(I,1),...,W(WTS,I), for I > 1 are null rule weights.
! G Real array of dimension (N, WTS).
! The fully symmetric sum generators for the rules.
! G(1, J), ..., G(N, J) are the are the generators for the
! points associated with the Jth weights.
! WTSR Integer, WTS
! NUMR Integer, number of points for Rule_Deg7
!
!***REFERENCES A. Genz and A. Malik,
! "An Imbedded Family of Fully Symmetric Numerical
! Integration Rules",
! SIAM J Numer. Anal. 20 (1983), pp. 580-588.
!***ROUTINES CALLED-NONE
!***END PROLOGUE Rule_Deg9
!
! Global variables
!
INTEGER, INTENT(IN) :: N
REAL(KIND=STND), DIMENSION(:,:), INTENT(OUT) :: W, G
INTEGER, INTENT(OUT) :: WTSR, NUMR
!
INTEGER, PARAMETER :: WTS = 9
!
! Local Variables
!
INTEGER :: K
REAL(KIND=STND), DIMENSION(WTS) :: RULPTS
REAL(KIND=STND), DIMENSION(3) :: ALPHA
REAL(KIND=STND) :: TEMP, LAM0,LAM1,LAM2,LAM3,LAMP, TWONDM
!
!***FIRST EXECUTABLE STATEMENT Rule_Deg9
!
! Initialize generators, weights and RULPTS
!
G = 0
W = 0
TWONDM = 2**N
RULPTS(1) = 1
RULPTS(2:5) = 2*N
RULPTS(6) = 2*N*(N-1)
RULPTS(7) = 4*N*(N-1)
RULPTS(8) = (4*N*(N-1)*(N-2))/3
RULPTS(9) = TWONDM
!
! Compute squared generator parameters
!
LAM0 = 0.4707_STND
LAMP = 0.0625_STND
LAM1 = 4/( 15 - 5/LAM0 )
TEMP = ( 1 - LAM1/LAM0 )/27
LAM2 = ( 5 - 7*LAM1 - 35*TEMP )/( 7 - 35*LAM1/3 - 35*TEMP/LAM0 )
TEMP = TEMP*( 1 - LAM2/LAM0 )/3
LAM3 = ( 7 - 9*(LAM2+LAM1) + 63*LAM2*LAM1/5 - 63*TEMP ) &
/( 9 - 63*(LAM2+LAM1)/5 + 21*LAM2*LAM1 - 63*TEMP/LAM0 )
!
! Compute degree 9 rule weights
!
W(9,1) = 1/(3*LAM0)**4/TWONDM
W(8,1) = ( 1 - 1/(3*LAM0) )/(6*LAM1)**3
W(7,1) = ( 1 - 7*(LAM0+LAM1)/5 + 7*LAM0*LAM1/3 ) &
/( 84*LAM1*LAM2*(LAM2-LAM0)*(LAM2-LAM1) )
W(6,1) = ( 1 - 7*(LAM0+LAM2)/5 + 7*LAM0*LAM2/3 ) &
/( 84*LAM1*LAM1*(LAM1-LAM0)*(LAM1-LAM2) ) &
- W(7,1)*LAM2/LAM1 - 2*(N-2)*W(8,1)
W(4,1) = ( 1 - 9*( (LAM0+LAM1+LAM2)/7 &
- (LAM0*LAM1+LAM0*LAM2+LAM1*LAM2)/5 ) &
- 3*LAM0*LAM1*LAM2 ) &
/( 18*LAM3*(LAM3-LAM0)*(LAM3-LAM1)*(LAM3-LAM2) )
W(3,1) = ( 1 - 9*( (LAM0+LAM1+LAM3)/7 &
- (LAM0*LAM1+LAM0*LAM3+LAM1*LAM3)/5 ) &
-3*LAM0*LAM1*LAM3 ) &
/( 18*LAM2*(LAM2-LAM0)*(LAM2-LAM1)*(LAM2-LAM3) ) &
- 2*(N-1)*W(7,1)
W(2,1) = ( 1 - 9*( (LAM0+LAM2+LAM3)/7 &
- (LAM0*LAM2+LAM0*LAM3+LAM2*LAM3)/5 ) &
- 3*LAM0*LAM2*LAM3 ) &
/( 18*LAM1*(LAM1-LAM0)*(LAM1-LAM2)*(LAM1-LAM3) ) &
- 2*(N-1)*( W(6,1) + W(7,1) + (N-2)*W(8,1) )
!
! Compute weights for 2 degree 7, 1 degree 5 and 1 degree 3 rules
!
W(9,2) = 1/( 108*LAM0**4 )/TWONDM
W(8,2) = ( 1 - 27*TWONDM*W(9,2)*LAM0**3 )/(6*LAM1)**3
W(7,2) = ( 1 - 5*LAM1/3 - 15*TWONDM*W(9,2)*LAM0**2*(LAM0-LAM1) ) &
/( 60*LAM1*LAM2*(LAM2-LAM1) )
W(6,2) = ( 1 - 9*( 8*LAM1*LAM2*W(7,2) + TWONDM*W(9,2)*LAM0**2 ) ) &
/(36*LAM1*LAM1) - 2*W(8,2)*(N-2)
W(4,2) = ( 1 - 7*( (LAM1+LAM2)/5 - LAM1*LAM2/3 &
+ TWONDM*W(9,2)*LAM0*(LAM0-LAM1)*(LAM0-LAM2) ) ) &
/( 14*LAM3*(LAM3-LAM1)*(LAM3-LAM2) )
W(3,2) = ( 1 - 7*( (LAM1+LAM3)/5 - LAM1*LAM3/3 &
+ TWONDM*W(9,2)*LAM0*(LAM0-LAM1)*(LAM0-LAM3) ) ) &
/( 14*LAM2*(LAM2-LAM1)*(LAM2-LAM3) ) - 2*(N-1)*W(7,2)
W(2,2) = ( 1 - 7*( (LAM2+LAM3)/5 - LAM2*LAM3/3 &
+ TWONDM*W(9,2)*LAM0*(LAM0-LAM2)*(LAM0-LAM3) ) ) &
/( 14*LAM1*(LAM1-LAM2)*(LAM1-LAM3) ) &
- 2*(N-1)*( W(6,2) + W(7,2) + (N-2)*W(8,2) )
W(9,3) = 5/( 324*LAM0**4 )/TWONDM
W(8,3) = ( 1 - 27*TWONDM*W(9,3)*LAM0**3 )/(6*LAM1)**3
W(7,3) = ( 1 - 5*LAM1/3 - 15*TWONDM*W(9,3)*LAM0**2*(LAM0-LAM1) ) &
/( 60*LAM1*LAM2* (LAM2-LAM1) )
W(6,3) = ( 1 - 9*( 8*LAM1*LAM2*W(7,3) + TWONDM*W(9,3)*LAM0**2 ) ) &
/( 36*LAM1*LAM1) - 2*W(8,3)*(N-2)
W(5,3) = ( 1 - 7*( (LAM1+LAM2)/5 - LAM1*LAM2/3 &
+ TWONDM*W(9,3)*LAM0*(LAM0-LAM1)*(LAM0-LAM2) ) ) &
/( 14*LAMP* (LAMP-LAM1)*(LAMP-LAM2) )
W(3,3) = ( 1 - 7*( (LAM1+LAMP)/5 - LAM1*LAMP/3 &
+ TWONDM*W(9,3)*LAM0*(LAM0-LAM1)*(LAM0-LAMP) ) ) &
/( 14*LAM2*(LAM2-LAM1)*(LAM2-LAMP) ) - 2*(N-1)*W(7,3)
W(2,3) = ( 1 - 7*( (LAM2+LAMP)/5 - LAM2*LAMP/3 &
+ TWONDM*W(9,3)*LAM0*(LAM0-LAM2)*(LAM0-LAMP) ) ) &
/( 14*LAM1*(LAM1-LAM2)*(LAM1-LAMP) ) &
- 2*(N-1)*( W(6,3) + W(7,3) + (N-2)*W(8,3) )
W(9,4) = 2/( 81*LAM0**4 )/TWONDM
W(8,4) = ( 2 - 27*TWONDM*W(9,4)*LAM0**3)/(6*LAM1)**3
W(7,4) = ( 2 - 15*LAM1/9-15*TWONDM*W(9,4)*LAM0*(LAM0-LAM1) ) &
/( 60*LAM1*LAM2*(LAM2-LAM1) )
W(6,4) = ( 1 - 9*( 8*LAM1*LAM2*W(7,4) + TWONDM*W(9,4)*LAM0**2 ) ) &
/( 36*LAM1*LAM1 ) - 2*W(8,4)*(N-2)
W(4,4) = ( 2 - 7*( (LAM1+LAM2)/5 - LAM1*LAM2/3 &
+ TWONDM*W(9,4)*LAM0*(LAM0-LAM1)*(LAM0-LAM2) ) ) &
/( 14*LAM3*(LAM3-LAM1)*(LAM3-LAM2) )
W(3,4) = ( 2 - 7*( (LAM1+LAM3)/5 - LAM1*LAM3/3 &
+ TWONDM*W(9,4)*LAM0*(LAM0-LAM1)*(LAM0-LAM3) ) ) &
/( 14*LAM2*(LAM2-LAM1)*(LAM2-LAM3) ) - 2*(N-1)*W(7,4)
W(2,4) = ( 2 - 7*( (LAM2+LAM3)/5 - LAM2*LAM3/3 &
+ TWONDM*W(9,4)*LAM0*(LAM0-LAM2)*(LAM0-LAM3) ) ) &
/( 14*LAM1*(LAM1-LAM2)*(LAM1-LAM3) ) &
- 2*(N-1)*( W(6,4) + W(7,4) + (N-2)*W(8,4) )
W(2,5) = 1/( 6*LAM1 )
!
! Set generator values
!
LAM0 = SQRT(LAM0)
LAM1 = SQRT(LAM1)
LAM2 = SQRT(LAM2)
LAM3 = SQRT(LAM3)
LAMP = SQRT(LAMP)
G( :,9) = LAM0
G(1:3,8) = LAM1
G( 1,7) = LAM1
G( 2,7) = LAM2
G(1:2,6) = LAM1
G( 1,5) = LAMP
G( 1,4) = LAM3
G( 1,3) = LAM2
G( 1,2) = LAM1
!
! Compute constant weight values.
!
W(1,1:5) = 1 - MATMUL( RULPTS(2:WTS), W(2:WTS,1:5) )
!
! Compute final weight values; null rule weights are computed as
! differences between weights from highest degree and lower degree rules.
!
W(1:WTS,2:5) = W(1:WTS,2:5) - SPREAD( W(1:WTS,1), 2, 4 )
!
! Orthogonalize and normalize null rules.
!
TEMP = SUM( RULPTS*W(1:WTS,1)*W(1:WTS,1) )
W(1:WTS,2) = W(1:WTS,2)*SQRT( TEMP/SUM( RULPTS*W(1:WTS,2)*W(1:WTS,2) ) )
DO K = 3, 5
ALPHA(1:K-2) = -MATMUL( TRANSPOSE(W(1:WTS,2:K-1)), RULPTS*W(1:WTS,K) )
W(1:WTS,K) = W(1:WTS,K) + MATMUL( W(1:WTS,2:K-1), ALPHA(1:K-2) )/TEMP
W(1:WTS,K) = W(1:WTS,K)*SQRT(TEMP/SUM(RULPTS*W(1:WTS,K)*W(1:WTS,K)))
END DO
WTSR = WTS
NUMR = SUM( RULPTS )
!
END SUBROUTINE Rule_Deg9
!
!
FUNCTION SymCub_Sum( N, VERTEX, GIN, NF, Integrand ) RESULT(SymCubSum)
!
!***BEGIN PROLOGUE SymCub_Sum
!***KEYWORDS fully symmetric sum
!***PURPOSE To compute fully symmetric basic rule sums
!***AUTHOR
!
! Alan Genz
! Department of Mathematics
! Washington State University
! Pullman, WA 99164-3113, USA
!
!***LAST MODIFICATION 99-06
!***DESCRIPTION SymCub_Sum computes a fully symmetric sum for a vector of
! integrand values over a parallelepiped. The sum is taken over all
! sign combinations and permutations of the generators for the sum.
!
! ON ENTRY
!
! N Integer, number of variables.
! VERTEX Real array of dimension (N,0:N)
! The vertices of the simplex, one vertex per column.
! NF Integer, number of components for the vector integrand.
! Integrand Real vector function of length NF for computing components of
! the integrand at Z.
! It must have parameters ( NF, Z ); see interface below
! Input parameters:
! Z Real array of length N, the evaluation point.
! NF Integer number of components of Integrand.
! GIN Real Array of dimension (1:N).
! The generators for the fully symmetric sum.
!
! ON RETURN
!
! SymCub_Sum Real array of length NF, the values for the fully symmetric
! sums for each component of the integrand.
!
!***ROUTINES CALLED: Integrand
!
!***END PROLOGUE SymCub_Sum
!
! Global variables.
!
INTEGER, INTENT(IN) :: N, NF
INTERFACE
FUNCTION Integrand(NF,Z) RESULT(Value)
USE Precision_Model
INTEGER, INTENT(IN) :: NF
REAL(KIND=STND), DIMENSION(:), INTENT(IN) :: Z
REAL(KIND=STND), DIMENSION(NF) :: Value
END FUNCTION Integrand
END INTERFACE
REAL(KIND=STND), DIMENSION(:,0:), INTENT(IN) :: VERTEX
REAL(KIND=STND), DIMENSION(:), INTENT(IN) :: GIN
REAL(KIND=STND), DIMENSION(NF) :: SymCubSum
!
! Local variables.
!
INTEGER :: IX, JX, I, J
REAL(KIND=STND), DIMENSION(N,N) :: VERDIF
REAL(KIND=STND), DIMENSION(N) :: CENTER, G
REAL(KIND=STND) :: GI, GJ
!
!***FIRST PROCESSING STATEMENT SymCub_Sum
!
SymCubSum = 0
G = ABS( GIN )
!
! Sort input generators if necessary
!
DO I = 2, N
IF ( G(I) > G(I-1) ) THEN
GI = G(I)
DO J = I-1, 1, -1
IF ( GI <= G(J) ) THEN
EXIT
END IF
G(J+1) = G(J)
END DO
G(J+1) = GI
END IF
END DO
VERDIF = ( VERTEX(:,1:N) - SPREAD( VERTEX(:,0), 2, N ) )/2
CENTER = VERTEX(:,0) + SUM( VERDIF, 2 )
!
! Compute integrand values for sign changes and permutations of G
!
DO
DO
SymCubSum = SymCubSum + Integrand( NF, CENTER + MATMUL(VERDIF,G) )
DO I = 1, N
G(I) = - G(I)
IF ( G(I) < 0 ) THEN
EXIT
END IF
END DO
IF ( I > N ) THEN
EXIT
END IF
END DO
!
! Find next distinct permuation of G and loop back for value.
! Permutations are generated in reverse lexicographic order.
!
DO I = 2, N
IF ( G(I-1) > G(I) ) THEN
GI = G(I)
IX = I - 1
DO J = 1, (I-1)/2
GJ = G(J)
G(J) = G(I-J)
G(I-J) = GJ
IF ( GJ <= GI ) THEN
IX = IX - 1
END IF
IF ( G(J) > GI ) THEN
JX = J
END IF
END DO
IF ( G(IX) <= GI ) THEN
IX = JX
END IF
G(I) = G(IX)
G(IX) = GI
EXIT
END IF
END DO
IF ( I > N ) THEN
EXIT
END IF
END DO
!
END Function SymCub_Sum
!
END Module CubatureRule_Cn
SHAR_EOF
fi # end of overwriting check
if test -f 'rule_general.f90'
then
echo shar: will not over-write existing file "'rule_general.f90'"
else
cat << "SHAR_EOF" > 'rule_general.f90'
Module CubatureRule_General
USE Precision_Model, ONLY: stnd
USE internal_types
USE QuadratureRule
USE CubatureRule_T2
USE CubatureRule_T3
USE CubatureRule_Tn
USE CubatureRule_C2
USE CubatureRule_C3
USE CubatureRule_Cn
Implicit NONE
PRIVATE
PUBLIC :: Rule_General, Rule_Cost
CONTAINS
SUBROUTINE Rule_General(DIMENS,CINFO,VER,IINFO,RINFO,NUMFUN,Integrand, &
BASVAL,RGNERR,NUM,IFAIL)
!***BEGIN PROLOGUE Rule_General
!***DATE WRITTEN 901114 (YYMMDD)
!***REVISION DATE 970507 (YYMMDD)
!***REVISION DATE 980330 (YYMMDD) (1D added)
!***REVISION DATE 980406 (YYMMDD) (dcuhre added)
!***REVISION DATE 990527 (YYMMDD) (F conversion)
!***REVISION DATE 000814 (YYMMDD) (rule selection for Cn changed)
!***REVISION DATE 010829 (YYMMDD) (init IFAIL)
!***REVISION DATE 020716 (YYMMDD) (rule selection for Cn changed))
!***AUTHOR
! Ronald Cools, Dept. of Computer Science,
! Katholieke Universiteit Leuven, Celestijnenlaan 200A,
! B-3001 Heverlee, Belgium
! Email: Ronald.Cools@cs.kuleuven.ac.be
!
!***PURPOSE To compute basic integration rule values and
! corresponding error estimates.
!***DESCRIPTION Rule_General selects a basic integration rule
! suitable for the given region.
!
! Input parameters
! ----------------
!
! DIMENS Integer
! The dimension of the region
! VER Real array of dimension (DIMENS,NRVERT).
! The coordinates of the vertices of the region.
! NUMFUN Integer
! Number of components of the vector integrand.
! CINFO Type integrator_info
! Paramaters to select proper integration rule.
! IINFO Integer array
! RINFO Real array
! The 2 arrays contain additional information about the
! subregion. See MODULE Global_Adaptive_Algorithm
! for details.
! Integrand Externally declared subroutine for computing
! all components of the integrand at the given
! evaluation point.
! It must have parameters (X,NUMFUN,FUNVLS)
! Input parameters:
! X(1) The x-coordinate of the evaluation point.
! X(2) The y-coordinate of the evaluation point.
! NUMFUN Integer that defines the number of
! components of I.
! Output parameter:
! FUNVLS Real array of dimension NUMFUN
! that defines NUMFUN components of the integrand.
!
!
! Output parameters
! -----------------
!
! BASVAL Real array of dimension NUMFUN.
! The values for the basic rule for each component
! of the integrand.
! RGNERR Real array of dimension NUMFUN.
! The error estimates for each component of the integrand.
! NUM Integer.
! The number of function evaluations used.
! IFAIL Integer.
! IFAIL = 0 on normal exit.
! IFAIL = 5 if a given type of region is not supported.
! IINFO Integer array.
! RINFO Real array.
! The 2 arrays contain additional information about the
! subregion. See MODULE Global_Adaptive_Algorithm
! for details.
!
!***ROUTINES CALLED Integrand
!***END PROLOGUE Rule_General
!
! Global variables.
!
INTERFACE
FUNCTION Integrand(NUMFUN,X) RESULT(Value)
USE Precision_Model
INTEGER, INTENT(IN) :: NUMFUN
REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: X
REAL(kind=stnd), DIMENSION(NUMFUN) :: Value
END FUNCTION Integrand
END INTERFACE
INTEGER, INTENT(IN) :: NUMFUN,DIMENS
INTEGER, INTENT(OUT) :: NUM,IFAIL
INTEGER, DIMENSION(:), INTENT(IN OUT) :: IINFO
REAL(kind=STND), DIMENSION(:,:), INTENT(IN) :: VER
REAL(kind=STND), DIMENSION(:), INTENT(OUT) :: BASVAL, RGNERR
REAL(kind=STND), DIMENSION(:), INTENT(IN OUT) :: RINFO
TYPE(integrator_info), INTENT(IN) :: cinfo
!
! Local variables
!
! KEY Integer.
! Rule selection parameter for DREPRO
! TUNE Real.
! Requested reliability of DREPRO: 0 <= TUNE <= 1
! RGTYPE Integer
! Indicates the type of region:
! RGTYPE = 1 => the region is a simplex
! RGTYPE = 2 => the region is a hyperrectangle
! RGTYPE = 3 => the region is an octahedron
! Note: If DIMENS=1 then RGTYPE=1 and RGTYPE=2 are equivalent
!
INTEGER :: RGTYPE,KEY
REAL(kind=STND) :: TUNE
!
KEY = CINFO%KEY
TUNE = CINFO%TUNE
RGTYPE = IINFO(1)
IFAIL = 0
SELECT CASE (RGTYPE)
CASE (Simplex)
IF (DIMENS == 1) THEN
CALL Dqk_drv(KEY,VER,NUMFUN,Integrand,BASVAL,RGNERR,NUM)
ELSE IF (DIMENS > 3) THEN
CALL Rule_Tn(TUNE,DIMENS,VER,RINFO(1),NUMFUN,Integrand,KEY,BASVAL,RGNERR,NUM)
ELSE IF ((KEY >= 1) .AND. (KEY <= 4)) THEN
CALL Rule_Tn(TUNE,DIMENS,VER,RINFO(1),NUMFUN,Integrand,KEY,BASVAL,RGNERR,NUM)
ELSE IF (DIMENS == 2) THEN
CALL Rule_T2a(VER,RINFO(1),NUMFUN,Integrand,BASVAL,RGNERR,NUM)
ELSE ! IF (DIMENS == 3) THEN
CALL Rule_T3a(VER,RINFO(1),NUMFUN,Integrand,BASVAL,RGNERR,NUM)
END IF
CASE (Hyperrectangle)
IF (DIMENS == 1) THEN
CALL Dqk_drv(KEY,VER,NUMFUN,Integrand,BASVAL,RGNERR,NUM)
ELSE IF (DIMENS > 3) THEN
CALL Rule_Cn(KEY,DIMENS,VER,IINFO,RINFO(1),NUMFUN,Integrand,BASVAL,RGNERR,NUM)
ELSE IF ((KEY >= 3) .AND. (KEY <= 4)) THEN
CALL Rule_Cn(KEY,DIMENS,VER,IINFO,RINFO(1),NUMFUN,Integrand,BASVAL,RGNERR,NUM)
ELSE IF (DIMENS == 2) THEN
CALL Rule_C2a(VER,IINFO,RINFO(1),NUMFUN,Integrand,BASVAL,RGNERR,NUM)
ELSE ! IF (DIMENS == 3) THEN
CALL Rule_C3a(VER,IINFO,RINFO(1),NUMFUN,Integrand,BASVAL,RGNERR,NUM)
END IF
CASE DEFAULT
IFAIL = 5
NUM = 0
END SELECT
RETURN
END SUBROUTINE Rule_General
FUNCTION Rule_Cost( DIMENS, RGTYPE, KEY ) RESULT(RULCLS)
!
! Integer function for computing the number of function values
! needed by the local integration rule.
! Input parameters are NOT checked!
!
! Global variables
!
! DIMENS Integer number of dimensions.
! RGTYPE Integer type of integration region.
! KEY Integer type of integration rule.
!
INTEGER, INTENT(IN) :: DIMENS, RGTYPE, KEY
INTEGER :: RULCLS
!
! Local Variables
!
INTEGER :: NKEY
SELECT CASE (RGTYPE)
CASE (Simplex)
IF ( DIMENS == 1 ) THEN
SELECT CASE (KEY)
CASE(:1)
RULCLS = 15
CASE(2)
RULCLS = 21
CASE(3)
RULCLS = 31
CASE(4)
RULCLS = 41
CASE(5)
RULCLS = 51
CASE(6:)
RULCLS = 61
END SELECT
ELSE IF ( (DIMENS > 3) .OR. ((KEY >= 1) .AND. (KEY <= 4)) ) THEN
!
! Compute RULCLS for DIMENS-simplex rules.
!
IF ( KEY == 0 ) THEN
NKEY = 3
ELSE
NKEY = KEY
END IF
! First count the Grundmann and Moller points.
RULCLS = DIMENS + 2
IF ( NKEY > 1 ) THEN
RULCLS = ( DIMENS + 3 )*RULCLS/2
END IF
IF ( NKEY > 2 ) THEN
RULCLS = ( DIMENS + 4 )*RULCLS/3
END IF
IF ( NKEY > 3 ) THEN
RULCLS = ( DIMENS + 5 )*RULCLS/4
END IF
! Add those from the degree 5 Stroud rule.
RULCLS = RULCLS + DIMENS + 1
IF ( NKEY > 1 ) THEN
RULCLS = RULCLS + DIMENS + 1
END IF
IF ( NKEY > 2 ) THEN
RULCLS = RULCLS + ( DIMENS + 1 )*DIMENS
END IF
! Add those of the degree 7 Mysovskikh rule.
IF ( NKEY > 3 ) THEN
RULCLS = RULCLS + 3*( DIMENS + 1 )*( DIMENS + 2 )/2
END IF
! subtract a generator if DIMENS == 3
IF ((DIMENS == 3) .AND. (NKEY > 2)) THEN
RULCLS = RULCLS - ((DIMENS+1)*DIMENS)/2
END IF
ELSE IF ( DIMENS == 2 ) THEN
RULCLS = 37
ELSE ! IF ( DIMENS == 3 ) THEN
RULCLS = 43
END IF
CASE (Hyperrectangle)
!
! Compute RULCLS for DIMENS-hyperrectangle rules.
!
IF ( DIMENS == 1) THEN
SELECT CASE( KEY )
CASE(:1)
RULCLS = 15
CASE(2)
RULCLS = 21
CASE(3)
RULCLS = 31
CASE(4)
RULCLS = 41
CASE(5)
RULCLS = 51
CASE(6:)
RULCLS = 61
END SELECT
ELSE IF ((DIMENS > 3) .OR. (KEY == 3) .OR. (KEY == 4)) THEN
IF ( KEY == 4 ) THEN
RULCLS = 1 + 4*2*DIMENS + 2*DIMENS* (DIMENS-1) + 4*DIMENS* (DIMENS-1) + &
4*DIMENS* (DIMENS-1)* (DIMENS-2)/3 + 2**DIMENS
ELSE
RULCLS = 1 + 3*2*DIMENS + 2*DIMENS* (DIMENS-1) + 2**DIMENS
END IF
ELSE IF (DIMENS == 2) THEN
RULCLS = 37
ELSE ! IF (DIMENS == 3) THEN
RULCLS = 89
END IF
END SELECT
RETURN
END FUNCTION Rule_Cost
END MODULE CubatureRule_General
SHAR_EOF
fi # end of overwriting check
if test -f 'rule_t2.f90'
then
echo shar: will not over-write existing file "'rule_t2.f90'"
else
cat << "SHAR_EOF" > 'rule_t2.f90'
! This file is F-compatible, except for upper/lower case conventions.
!--------------------------------------------------------------------
Module CubatureRule_T2
USE Precision_Model, ONLY: stnd
Implicit NONE
PRIVATE
PUBLIC :: Rule_T2a
CONTAINS
SUBROUTINE Rule_T2a(VER,AREA,NUMFUN,Integrand,BASVAL,RGNERR,NUM)
!***BEGIN PROLOGUE Rule_T2a
!***PURPOSE To compute basic integration rule values and
! corresponding error estimates.
!***REFER TO Module CubatureRule_General
! This subroutine is based on DRLTRI, part of DCUTRI. See below.
!***REVISION DATE 950823 (YYMMDD)
!***REVISION DATE 990527 (YYMMDD) (F conversion)
!***AUTHOR
! Original version
! Jarle Berntsen, The Computing Centre,
! University of Bergen, Thormohlens gt. 55,
! N-5008 Bergen, NORWAY
! Email: jarle@eik.ii.uib.no
! Terje O. Espelid, Department of Informatics,
! University of Bergen, Thormohlens gt. 55,
! N-5008 Bergen, NORWAY
! Email: terje@eik.ii.uib.no
! Translation and modification by
! Ronald Cools, Dept. of Computer Science,
! Katholieke Universiteit Leuven, Celestijnenlaan 200A,
! B-3001 Heverlee, Belgium
! Email: ronald@cs.kuleuven.ac.be
!
!***REFERENCES
! J.Berntsen and T.O.Espelid
! Algorithm 706: DCUTRI: An algorithm for adaptive cubature over a
! collection of triangles
! ACM. Trans. Math. Software, Vol. 18 (1992), pp 329-342.
!
!***DESCRIPTION Rule_T2a computes basic integration rule values
! for a vector of integrands over a triangular region.
! Rule_T2a also computes estimates for the errors by
! using several null rule approximations.
!
! ON ENTRY
!
! VER Real array of dimension (2,3).
! The coordinates of the vertices of the triangle.
! AREA Real.
! The area of the given region.
! NUMFUN Integer.
! Number of components of the vector integrand.
! Integrand Externally declared subroutine for computing
! all components of the integrand at the given
! evaluation point.
! It must have parameters X
! Input parameters:
! X(1) The x-coordinate of the evaluation point.
! X(2) The y-coordinate of the evaluation point.
!
! ON RETURN
!
! BASVAL Real array of dimension NUMFUN.
! The values for the basic rule for each component
! of the integrand.
! RGNERR Real array of dimension NUMFUN.
! The error estimates for each component of the integrand.
! NUM Integer
! The number of function evaluations used.
!
!***REFERENCES Berntsen,J. and Espelid,T.O., Degree 13 Symmetric
! Quadrature Rules for the Triangle, Report
!***ROUTINES CALLED Integrand
!***END PROLOGUE Rule_T2a
!
! Global variables.
!
INTERFACE
FUNCTION Integrand(NUMFUN,X) RESULT(Value)
USE Precision_Model
INTEGER, INTENT(IN) :: NUMFUN
REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: X
REAL(kind=stnd), DIMENSION(NUMFUN) :: Value
END FUNCTION Integrand
END INTERFACE
INTEGER, INTENT(IN) :: NUMFUN
INTEGER, INTENT(OUT) :: NUM
REAL(kind=stnd), INTENT(IN) :: AREA
REAL(kind=stnd), DIMENSION(:,:), INTENT(IN) :: VER
REAL(kind=stnd), DIMENSION(:), INTENT(OUT) :: BASVAL, RGNERR
!
! Constants
!
! G Real array of dimension (2,ORBITS).
! The homogeneous coordinates for the generators of
! the evaluation points.
! The integration rule is using symmetric evaluation
! points and has the structure (1,6,3). That is,
! 1 point of multiplicity 1,
! 6 sets of points of multiplicity 3 and
! 3 sets of points of multiplicity 6.
! This gives totally 37 evaluation points.
! In order to reduce the number of loops in Rule_T2a,
! the 3 loops for the sets of multiplicity 6 are split
! into 6 loops and added to the loops for the sets of
! multiplicity 3.
! The number of weights we have to give with
! this splitting is 13(ORBITS).
!
! W Real array of dimension (9,ORBITS).
! The weights of the basic rule and the null rules.
! W(1,1),...,W(1,ORBITS) are weights for the basic rule.
! W(I,1),...,W(I,ORBITS) for I>1 are null rule weights.
!
INTEGER, PARAMETER :: ORBITS=13 ! The number of orbits in the Cf.
REAL(kind=stnd), PARAMETER :: CRIVAL=0.5_stnd, &
TRES=50*EPSILON(crival), &
FACMED = 10, &
FACOPT = FACMED/(CRIVAL**2)
!
! The abscissas are given in homogeneous coordinates.
!
REAL(kind=stnd), DIMENSION(ORBITS), PARAMETER :: &
G1 = (/ &
0.333333333333333333333333333333_stnd, &
0.950275662924105565450352089520_stnd, &
0.171614914923835347556304795551_stnd, &
0.539412243677190440263092985511_stnd, &
0.772160036676532561750285570113_stnd, &
0.009085399949835353883572964740_stnd, &
0.062277290305886993497083640527_stnd, &
0.022076289653624405142446876931_stnd, &
0.018620522802520968955913511549_stnd, &
0.096506481292159228736516560903_stnd, &
0.851306504174348550389457672223_stnd, &
0.689441970728591295496647976487_stnd, &
0.635867859433872768286976979827_stnd/)
REAL(kind=stnd), DIMENSION(ORBITS), PARAMETER :: &
G2 = (/ &
0.333333333333333333333333333333_stnd, &
0.024862168537947217274823955239_stnd, &
0.414192542538082326221847602214_stnd, &
0.230293878161404779868453507244_stnd, &
0.113919981661733719124857214943_stnd, &
0.495457300025082323058213517632_stnd, &
0.468861354847056503251458179727_stnd, &
0.851306504174348550389457672223_stnd, &
0.689441970728591295496647976487_stnd, &
0.635867859433872768286976979827_stnd, &
0.022076289653624405142446876931_stnd, &
0.018620522802520968955913511549_stnd, &
0.096506481292159228736516560903_stnd/)
REAL(kind=stnd), DIMENSION(2,ORBITS), PARAMETER :: &
G = RESHAPE( SOURCE= (/ G1 , G2 /), SHAPE=(/2,ORBITS/), ORDER=(/2,1/) )
!
! Weights of the degree 13 quadrature rule.
!
REAL(kind=stnd), DIMENSION(ORBITS), PARAMETER :: &
W1 = (/ &
0.051739766065744133555179145422_stnd, &
0.008007799555564801597804123460_stnd, &
0.046868898981821644823226732071_stnd, &
0.046590940183976487960361770070_stnd, &
0.031016943313796381407646220131_stnd, &
0.010791612736631273623178240136_stnd, &
0.032195534242431618819414482205_stnd, &
0.015445834210701583817692900053_stnd, &
0.017822989923178661888748319485_stnd, &
0.037038683681384627918546472190_stnd, &
0.015445834210701583817692900053_stnd, &
0.017822989923178661888748319485_stnd, &
0.037038683681384627918546472190_stnd/)
!
! Weights of the first null rule of degree 7.
!
REAL(kind=stnd), DIMENSION(ORBITS), PARAMETER :: &
W2 = (/ &
-0.077738051051462052051304462750_stnd, &
0.001640389740236881582083124927_stnd, &
0.078124083459915167386776552733_stnd, &
-0.030706528522391137165581298102_stnd, &
0.010246307817678312345028512621_stnd, &
0.012586300774453821540476193059_stnd, &
-0.043630506151410607808929481439_stnd, &
-0.004567055157220063810223671248_stnd, &
0.003393373439889186878847613140_stnd, &
0.0_stnd, &
-0.004567055157220063810223671248_stnd, &
0.003393373439889186878847613140_stnd, &
0.0_stnd/)
!
! Weights of the second null rule of degree 7.
!
REAL(kind=stnd), DIMENSION(ORBITS), PARAMETER :: &
W3 = (/ &
-0.064293709240668260928898888457_stnd, &
0.003134665264639380635175608661_stnd, &
0.007822550509742830478456728602_stnd, &
0.048653051907689492781049400973_stnd, &
0.032883327334384971735434067029_stnd, &
-0.017019508374229390108580829589_stnd, &
0.025973557893399824586684707198_stnd, &
-0.010716753326806275930657622320_stnd, &
0.018315629578968063765722278290_stnd, &
-0.047607080313197299401024682666_stnd, &
-0.010716753326806275930657622320_stnd, &
0.018315629578968063765722278290_stnd, &
-0.047607080313197299401024682666_stnd/)
!
! Weights of the first degree 5 null rule.
!
!
REAL(kind=stnd), DIMENSION(ORBITS), PARAMETER :: &
W4 = (/ &
0.021363205584741860993131879186_stnd, &
0.022716410154120323440432428315_stnd, &
-0.026366191271182090678117381002_stnd, &
0.029627021479068212693155637482_stnd, &
0.004782834546596399307634111034_stnd, &
0.004178667433984132052378990240_stnd, &
-0.065398996748953861618846710897_stnd, &
-0.033589813176131630980793760168_stnd, &
0.033018320112481615757912576257_stnd, &
0.012241086002709814125707333127_stnd, &
-0.033589813176131630980793760168_stnd, &
0.033018320112481615757912576257_stnd, &
0.012241086002709814125707333127_stnd/)
!
! Weights of the second degree 5 null rule.
!
REAL(kind=stnd), DIMENSION(ORBITS), PARAMETER :: &
W5 = (/ &
-0.046058756832790538620830792345_stnd, &
0.005284159186732627192774759959_stnd, &
0.009325799301158899112648198129_stnd, &
-0.006101110360950124560783393745_stnd, &
-0.056223328794664871336486737231_stnd, &
-0.062516479198185693171971930698_stnd, &
0.022428226812039547178810743269_stnd, &
-0.000026014926110604563130107142_stnd, &
0.032882099937471182365626663487_stnd, &
0.018721740987705986426812755881_stnd, &
-0.000026014926110604563130107142_stnd, &
0.032882099937471182365626663487_stnd, &
0.018721740987705986426812755881_stnd/)
!
! Weights of first degree 3 null rule.
!
REAL(kind=stnd), DIMENSION(ORBITS), PARAMETER :: &
W6 = (/ &
0.080867117677405246540283712799_stnd, &
-0.033915806661511608094988607349_stnd, &
0.014813362053697845461526433401_stnd, &
0.001442315416337389214102507204_stnd, &
-0.024309696484708683486455879210_stnd, &
-0.005135085639122398522835391664_stnd, &
-0.034649417896235909885490654650_stnd, &
0.035748423431577326597742956780_stnd, &
0.024548155266816447583155562333_stnd, &
-0.032897267038856299280541675107_stnd, &
0.035748423431577326597742956780_stnd, &
0.024548155266816447583155562333_stnd, &
-0.032897267038856299280541675107_stnd/)
!
! Weights of second degree 3 null rule.
!
REAL(kind=stnd), DIMENSION(ORBITS), PARAMETER :: &
W7 = (/ &
-0.038457863913548248582247346193_stnd, &
-0.055143631258696406147982448269_stnd, &
-0.021536994314510083845999131455_stnd, &
0.001547467894857008228010564582_stnd, &
0.057409361764652373776043522086_stnd, &
-0.040636938884669694118908764512_stnd, &
-0.020801144746964801777584428369_stnd, &
0.019490770404993674256256421103_stnd, &
0.002606109985826399625043764771_stnd, &
0.023893703367437102825618048130_stnd, &
0.019490770404993674256256421103_stnd, &
0.002606109985826399625043764771_stnd, &
0.023893703367437102825618048130_stnd/)
!
! Weights of first degree 1 null rule.
!
REAL(kind=stnd), DIMENSION(ORBITS), PARAMETER :: &
W8 = (/ &
0.074839568911184074117081012527_stnd, &
-0.004270103034833742737299816615_stnd, &
0.049352639555084484177095781183_stnd, &
0.048832124609719176627453278550_stnd, &
0.001042698696559292759051590242_stnd, &
-0.044445273029113458906055765365_stnd, &
-0.004670751812662861209726508477_stnd, &
-0.015613390485814379318605247424_stnd, &
-0.030581651696100000521074498679_stnd, &
0.010801113204340588798240297593_stnd, &
-0.015613390485814379318605247424_stnd, &
-0.030581651696100000521074498679_stnd, &
0.010801113204340588798240297593_stnd/)
!
! Weights of second degree 1 null rule.
!
REAL(kind=stnd), DIMENSION(ORBITS), PARAMETER :: &
W9 = (/ &
0.009373028261842556370231264134_stnd, &
-0.074249368848508554545399978725_stnd, &
0.014709707700258308001897299938_stnd, &
0.009538502545163567494354463302_stnd, &
-0.014268362488069444905870465047_stnd, &
0.040126396495352694403045023109_stnd, &
0.028737181842214741174950928350_stnd, &
-0.031618075834734607275229608099_stnd, &
0.016879961075872039084307382161_stnd, &
0.010878914758683152984395046434_stnd, &
-0.031618075834734607275229608099_stnd, &
0.016879961075872039084307382161_stnd, &
0.010878914758683152984395046434_stnd/)
REAL(kind=stnd), DIMENSION(9,ORBITS), PARAMETER :: &
W = RESHAPE( SOURCE= (/ W1,W2,W3,W4,W5,W6,W7,W8,W9 /),&
SHAPE=(/9,ORBITS/), ORDER=(/2,1/) )
!
! Local variables
!
!
! NullRule Real array of dimension (NUMFUN,8).
! A work array.
!
INTEGER :: I,J,L
REAL(kind=stnd):: Z1,Z2,Z3,R1,R2,R3,R,DEG7,DEG5,DEG3,DEG1,NOISE
REAL(kind=stnd), DIMENSION(NUMFUN,8) :: NullRule
REAL(kind=stnd), DIMENSION(2,3) :: X
!
!***FIRST EXECUTABLE STATEMENT Rule_T2a
!
! Compute contributions from the center of the triangle.
!
X(1:2,1) = (VER(1:2,1)+VER(1:2,2)+VER(1:2,3))/3
RGNERR=Integrand(NUMFUN,X(:,1))
BASVAL(1:NUMFUN) = W(1,1)*RGNERR(1:NUMFUN)
DO J = 1,NUMFUN
NullRule(J,1:8) = W(2:9,1)*RGNERR(J)
END DO
!
! Compute contributions from points with
! multiplicity 3.
!
DO I = 2,ORBITS
Z1 = G(1,I)
Z2 = G(2,I)
Z3 = 1 - Z1 - Z2
X(1:2,1) = Z1*VER(1:2,1) + Z2*VER(1:2,2) + Z3*VER(1:2,3)
X(1:2,2) = Z2*VER(1:2,1) + Z3*VER(1:2,2) + Z1*VER(1:2,3)
X(1:2,3) = Z3*VER(1:2,1) + Z1*VER(1:2,2) + Z2*VER(1:2,3)
DO L = 1,3
RGNERR=Integrand(NUMFUN,X(:,L))
BASVAL(1:NUMFUN) = BASVAL(1:NUMFUN) + W(1,I)*RGNERR(1:NUMFUN)
DO J = 1,NUMFUN
NullRule(J,1:8) = NullRule(J,1:8) + W(2:9,I)*RGNERR(J)
END DO
END DO
END DO
!
! Compute errors.
!
DO J = 1,NUMFUN
NOISE = ABS(BASVAL(J))*TRES
DEG7 = SQRT(NullRule(J,1)**2+NullRule(J,2)**2)
IF ( DEG7 <= NOISE) THEN
RGNERR(J) = NOISE
ELSE
DEG5 = SQRT(NullRule(J,3)**2+NullRule(J,4)**2)
DEG3 = SQRT(NullRule(J,5)**2+NullRule(J,6)**2)
DEG1 = SQRT(NullRule(J,7)**2+NullRule(J,8)**2)
IF (DEG5 /= 0) THEN
R1 = DEG7/DEG5
ELSE
R1 = 1
END IF
IF (DEG3 /= 0) THEN
R2 = DEG5/DEG3
ELSE
R2 = 1
END IF
IF (DEG1 /= 0) THEN
R3 = DEG3/DEG1
ELSE
R3 = 1
END IF
R = MAX(R1,R2,R3)
IF (R >= 1) THEN
RGNERR(J) = 10*MAX(DEG1,DEG3,DEG5,DEG7)
ELSE IF (R >= CRIVAL) THEN
RGNERR(J) = facmed*R*DEG7
ELSE
RGNERR(J) = facopt* (R**3)*DEG7
END IF
RGNERR(J) = MAX(NOISE,RGNERR(J))
END IF
RGNERR(J) = AREA*RGNERR(J)
BASVAL(J) = AREA*BASVAL(J)
RGNERR(J) = MIN(ABS(BASVAL(J)),RGNERR(J))
END DO
NUM = 37
RETURN
END SUBROUTINE Rule_T2a
END MODULE CubatureRule_T2
SHAR_EOF
fi # end of overwriting check
if test -f 'rule_t3.f90'
then
echo shar: will not over-write existing file "'rule_t3.f90'"
else
cat << "SHAR_EOF" > 'rule_t3.f90'
! This file is F-compatible, except for upper/lower case conventions.
!--------------------------------------------------------------------
Module CubatureRule_T3
USE Precision_Model, ONLY: stnd
Implicit NONE
PRIVATE
PUBLIC :: Rule_T3a
PRIVATE :: OrbT3_Sum
CONTAINS
SUBROUTINE Rule_T3a(VER,VOLUME,NUMFUN,Integrand,BASVAL,RGNERR,NUM)
!
!***BEGIN PROLOGUE Rule_T3a
!***REFER TO DCUTET
!***REVISION DATE 970324 (YYMMDD)
!***REVISION DATE 990528 (YYMMDD) (F conversion)
!***PURPOSE To compute basic integration rule values and
! corresponding error estimates.
!***DESCRIPTION Rule_T3a computes basic integration rule values
! for a vector of integrands over a tetrahedron.
! Rule_T3a also computes estimates for the errors by
! using several null rule approximations.
! ON ENTRY
!
! VER Real array of dimension (3,4).
! The coordinates of the vertices of the tetrahedron.
! vertex i -> ( ver(1,i),ver(2,i),ver(3,i) )
! NUMFUN Integer.
! Number of components of the vector integrand.
! Integrand Externally declared subroutine for computing
! all components of the integrand at the given
! evaluation point.
! It must have parameters (X)
! Input parameters:
! X(1) The x-coordinate of the evaluation point.
! X(2) The y-coordinate of the evaluation point.
! X(3) The z-coordinate of the evaluation point.
!
! ON RETURN
!
! BASVAL Real array of dimension NUMFUN.
! The values for the basic rule for each component
! of the integrand.
! RGNERR Real array of dimension NUMFUN.
! The error estimates for each component of the integrand.
! NUM Integer
! The number of function evaluations used.
!
!***REFERENCES M. Beckers and A. Haegemans,
! The construction of cubature formula for the tetrahedron
! Report TW128, K.U. Leuven (1990).
!***ROUTINES CALLED
! OrbT3_Sum,Integrand
!***END PROLOGUE Rule_T3a
!
! Parameters
!
! ORBITS Integer
! The number of orbits of the cubature formula and null rules
! CRIVAL Real
! The decision to choose the optimistic part of the error
! estimator is based on CRIVAL
! FACMED Real
! FACMED is the safety coefficient used in the non-optimistic
! part of the error estimator. FACMED is related to CRIVAL
! and FACOPT.
! FACOPT Real
! FACOPT is the safety coefficient used in the optimistic part
! of the error estimator.
! K Integer array of dimension (0:3) that contains the structure
! parameters. K(I) = number of orbits of type I.
! TYPE1 Real array of dimension (K(1)).
! Contains the first homogeneous coordinate of the generators
! of type 1
! TYPE2 Real array of dimension (K(2)).
! Contains the first homogeneous coordinate of the generators
! of type 2
! TYPE3 Real array of dimension (2,K(2)).
! Contains the first two homogeneous coordinates of
! the generators of type 3.
! WEIGHT Real array of dimension (9,ORBITS).
! The weights of the cubature formula and the null rules.
! WEIGHT(1,1) ,..., WEIGHT(1,ORBITS) are the weights of the
! cubature formula
! WEIGHT(I,1) ,..., WEIGHT(I,ORBITS) for I > 1, are the weights
! of the null rules
!
!
! Global variables.
!
INTEGER, INTENT(IN) :: NUMFUN
INTEGER, INTENT(OUT) :: NUM
REAL(kind=stnd), INTENT(IN) :: VOLUME
REAL(kind=stnd), DIMENSION(:,:), INTENT(IN) :: VER
REAL(kind=stnd), DIMENSION(:), INTENT(OUT) :: BASVAL, RGNERR
INTERFACE
FUNCTION Integrand(NUMFUN,X) RESULT(Value)
USE Precision_Model
INTEGER, INTENT(IN) :: NUMFUN
REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: X
REAL(kind=stnd), DIMENSION(NUMFUN) :: Value
END FUNCTION Integrand
END INTERFACE
!
! Constants
!
INTEGER, PARAMETER :: ORBITS = 7
REAL(kind=stnd), PARAMETER:: CRIVAL=0.5_stnd, &
FACMED=5, &
FACOPT=FACMED/CRIVAL, &
TRES=50*EPSILON(crival)
!
! Cubature formula of degree 8 with 43 points
!
INTEGER, DIMENSION(0:3), PARAMETER :: &
K = (/1,3,1,2/) ! Rule structure parameters
!
! Information for the generators
!
REAL(kind=stnd), DIMENSION(1:3), PARAMETER :: &
TYPE1 = (/ 0.379510205167980387748057300876_stnd, &
0.753689235068359830728182577696_stnd, &
0.982654148484406008240470085259_stnd/)
REAL(kind=stnd), DIMENSION(1:1), PARAMETER :: &
TYPE2 = (/ 0.449467259981105775574375471447_stnd/)
REAL(kind=stnd), DIMENSION(1:2,1:2), PARAMETER :: &
TYPE3 = RESHAPE( SOURCE= &
(/ 0.506227344977843677082264893876_stnd, &
0.356395827885340437169173969841E-1_stnd, &
0.736298458958971696943019005441_stnd, &
0.190486041934633455699433285302_stnd/), &
SHAPE=(/2,2/), ORDER=(/1,2/) )
!
! Weights of the cubature formula
!
REAL(kind=stnd), DIMENSION(1:ORBITS), PARAMETER :: &
W1 = (/ &
-0.123001131951839495043519102752_stnd, &
0.855018349372014074906384482699E-1_stnd, &
0.118021998788034059253768205083E-1_stnd, &
0.101900465455732427902646736855E-2_stnd, &
0.274781029468036908044610867719E-1_stnd, &
0.342269148520915110408153517904E-1_stnd, &
0.128431148469725555789001180031E-1_stnd/)
!
! Weights of the null rule of degree 5
!
REAL(kind=stnd), DIMENSION(1:ORBITS), PARAMETER :: &
W2 = (/ &
0.211921237628032658308230999090_stnd, &
-0.660207516445726284649283745987E-1_stnd, &
0.225058824086711710443385047042E-1_stnd, &
-0.375962972067425589765730699401E-3_stnd, &
0.710066020561055159657284834784E-2_stnd, &
0.156515256061747694921427149028E-2_stnd, &
-0.814530839643584660306807872526E-2_stnd/)
!
! Weights of null rule of degree 4
!
REAL(kind=stnd), DIMENSION(1:ORBITS), PARAMETER :: &
W3 = (/ &
-0.508105488137100551376844924797E-1_stnd, &
0.104596681151665328209751420525E-1_stnd, &
0.927471438532788763594989973184E-1_stnd, &
0.210489990008917994323967321174E-2_stnd, &
0.379184172251962722213408547663E-1_stnd, &
-0.111747242913563605790923001557E-1_stnd, &
-0.386541758762774673113423570465E-1_stnd/)
!
! Weights of first null rule of degree 3
!
REAL(kind=stnd), DIMENSION(1:ORBITS), PARAMETER :: &
W4 = (/ &
-0.775992773232808462404390159802E-1_stnd, &
-0.527453289659022924847298408064E-1_stnd, &
0.145876238555932704488677626554E-1_stnd, &
0.739374873393616192857532718429E-2_stnd, &
-0.374618791364332892611678523428E-1_stnd, &
0.538502846550653076078817013885E-1_stnd, &
-0.183980865177843057548322735665E-1_stnd/)
!
! Weights of second null rule of degree 3
!
REAL(kind=stnd), DIMENSION(1:ORBITS), PARAMETER :: &
W5 = (/ &
0.181767621501470154602720474731E-1_stnd, &
0.179938831310058580533178529022E-1_stnd, &
0.713210362750414891598257378898E-1_stnd, &
-0.443935688958258805893448212636E-1_stnd, &
-0.657639036547720234169662790056E-1_stnd, &
-0.101551807522541414699808460583E-1_stnd, &
0.265486188970540796821750584204E-1_stnd/)
!
! Weights of null rule of degree 2
!
REAL(kind=stnd), DIMENSION(1:ORBITS), PARAMETER :: &
W6 = (/ &
-0.867629853722843888927184699428E-1_stnd, &
-0.715881271235661902772072127812E-1_stnd, &
0.886720767790426261677273459523E-2_stnd, &
-0.577885573028655167063092577589E-1_stnd, &
0.430310167581202031805055255554E-1_stnd, &
-0.606467834856775537069463817445E-2_stnd, &
0.319492443333738343104163265406E-1_stnd/)
!
! Weights of null rule of degree 1
!
REAL(kind=stnd), DIMENSION(1:ORBITS), PARAMETER :: &
W7 = (/ &
0.510374015624925451319499382594E-1_stnd, &
0.463998830432033721597269299429E-1_stnd, &
-0.191086148397852799983451475821E-1_stnd, &
-0.973768821003670776204287367278E-1_stnd, &
0.180352562073914141268335496511E-1_stnd, &
0.277129527093489643801598303110E-1_stnd, &
-0.176218263109360550515567818653E-1_stnd/)
!
REAL(kind=stnd), DIMENSION(1:7,1:ORBITS), PARAMETER :: &
WEIGHT = RESHAPE( SOURCE= (/ W1,W2,W3,W4,W5,W6,W7/), &
SHAPE=(/7,ORBITS/), ORDER=(/2,1/) )
!
! Local variables.
!
INTEGER :: J,NR,P,GENTYPE
REAL(kind=stnd):: NOISE,DEG4,DEG3,DEG1,R2,R1,R
REAL(kind=stnd), DIMENSION(NUMFUN) :: SUMVAL
REAL(kind=stnd), DIMENSION(NUMFUN,6) :: NullRule
REAL(kind=stnd), DIMENSION(3) :: Z
!
!***FIRST EXECUTABLE STATEMENT Rule_T3a
!
! The number of points used by the cubature formula is
! NUM = K(0) + 4*K(1) + 6*K(2) + 12*K(3) = 43
NUM = 43
!
! Initialise BASVAL and NullRule
!
BASVAL = 0
NullRule = 0
!
! Compute contributions from orbits with 1, 4, 6 and 12 points
!
P = 1
DO GENTYPE = 0,3
DO NR = 1,K(GENTYPE)
SELECT CASE (GENTYPE)
CASE (1) ! Generator ( z(1) , z(2), z(2) , z(2) )
Z(1) = TYPE1(NR)
Z(2) = (1-Z(1))/3
CASE (2) ! Generator ( z(1) , z(1), z(2) , z(2) )
Z(1) = TYPE2(NR)
Z(2) = (1-2*Z(1))/2
CASE (3) ! Generator ( z(1) , z(2), z(3) , z(3) )
Z(1:2) = TYPE3(1:2,NR)
Z(3) = (1-Z(1)-Z(2))/2
END SELECT
CALL OrbT3_Sum(GENTYPE,Z,VER,NUMFUN,Integrand,SUMVAL)
BASVAL = BASVAL + WEIGHT(1,P)*SUMVAL
DO J = 1,NUMFUN
NullRule(J,1:6) = NullRule(J,1:6) + WEIGHT(2:7,P)*SUMVAL(J)
END DO
P = P + 1
END DO
END DO
!
! Compute error estimates
!
DO J = 1,NUMFUN
NOISE = ABS(BASVAL(J))*TRES
DEG4 = SQRT(NullRule(J,1)**2+NullRule(J,2)**2)
DEG3 = SQRT(NullRule(J,3)**2+NullRule(J,4)**2)
IF (DEG4 <= NOISE) THEN
RGNERR(J) = NOISE
ELSE
DEG1 = SQRT(NullRule(J,5)**2+NullRule(J,6)**2)
IF (DEG3 /= 0) THEN
R1 = (DEG4/DEG3)**2
ELSE
R1 = 1
END IF
IF (DEG1 /= 0) THEN
R2 = DEG3/DEG1
ELSE
R2 = 1
END IF
R = MAX(R1,R2)
IF (R >= CRIVAL) THEN
RGNERR(J) = FACMED*R*DEG4
ELSE
RGNERR(J) = FACOPT*(R**2)*DEG4
END IF
RGNERR(J) = MAX(NOISE,RGNERR(J))
END IF
RGNERR(J) = VOLUME*RGNERR(J)
BASVAL(J) = VOLUME*BASVAL(J)
END DO
RETURN
END SUBROUTINE Rule_T3a
SUBROUTINE OrbT3_Sum(GENTYPE,GENER,VER,NUMFUN,Integrand,SUMVAL)
!***BEGIN PROLOGUE OrbT3_Sum
!***PURPOSE To compute the sum of function values over all points
! of an orbit.
!***DESCRIPTION
! ON ENTRY
!
! GENTYPE Integer
! The type of the orbit.
! GENER Integer array of dimension (3).
! The generator for the orbit in homogeneous coordinates.
! VER Real array of dimension (3,4).
! The coordinates of the vertices of the tetrahedron.
! vertex i -> ( ver(1,i),ver(2,i),ver(3,i) )
! NUMFUN Integer.
! Number of components of the vector integrand.
! Integrand Externally declared subroutine for computing
! all components of the integrand at the given
! evaluation point.
! It must have parameters (DIM,X,NUMFUN,FUNVLS)
! Input parameters:
! DIM = 3
! X(1) The x-coordinate of the evaluation point.
! X(2) The y-coordinate of the evaluation point.
! X(3) The z-coordinate of the evaluation point.
! NUMFUN Integer that defines the number of
! components of the vector integrand.
! Output parameter:
! FUNVLS Real array of dimension NUMFUN
! that defines NUMFUN components of the integrand.
! ON RETURN
!
! SUMVAL Real array of dimension (NUMFUN).
! The sum of function values over all points
! of the given orbit.
!
!***END PROLOGUE OrbT3_Sum
!
! Global variables
!
INTEGER, INTENT(IN) :: NUMFUN,GENTYPE
REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: GENER
REAL(kind=stnd), DIMENSION(:), INTENT(OUT) :: SUMVAL
REAL(kind=stnd), DIMENSION(:,:), INTENT(IN) :: VER
INTERFACE
FUNCTION Integrand(NUMFUN,X) RESULT(Value)
USE Precision_Model
INTEGER, INTENT(IN) :: NUMFUN
REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: X
REAL(kind=stnd), DIMENSION(NUMFUN) :: Value
END FUNCTION Integrand
END INTERFACE
!
! Local variables
!
INTEGER :: J,NUMBER
REAL(kind=stnd):: Z1,Z2,Z3
REAL(kind=stnd), DIMENSION(3,12) :: X
REAL(kind=stnd), DIMENSION(NUMFUN) :: WORK
!***FIRST EXECUTABLE STATEMENT OrbT3_Sum
SELECT CASE (GENTYPE)
!
! Generator with homogeneous coordinates (1/4,1/4,1/4,1/4)
!
CASE (0)
NUMBER = 1
X(:,1) = SUM( VER, DIM=2 )/4
!
! Generator with homogeneous coordinates (z1,z2,z2,z2)
!
CASE (1)
NUMBER = 4
Z1 = GENER(1)
Z2 = GENER(2)
X(:,1) = Z1*VER(:,1) + Z2* (VER(:,2)+VER(:,3)+VER(:,4))
X(:,2) = Z1*VER(:,2) + Z2* (VER(:,1)+VER(:,3)+VER(:,4))
X(:,3) = Z1*VER(:,3) + Z2* (VER(:,2)+VER(:,1)+VER(:,4))
X(:,4) = Z1*VER(:,4) + Z2* (VER(:,2)+VER(:,3)+VER(:,1))
!
! Generator with homogeneous coordinates (z1,z1,z2,z2)
!
CASE (2)
NUMBER = 6
Z1 = GENER(1)
Z2 = GENER(2)
X(:,1) = Z1* (VER(:,1)+VER(:,2)) + Z2* (VER(:,3)+VER(:,4))
X(:,2) = Z1* (VER(:,1)+VER(:,3)) + Z2* (VER(:,2)+VER(:,4))
X(:,3) = Z1* (VER(:,1)+VER(:,4)) + Z2* (VER(:,3)+VER(:,2))
X(:,4) = Z1* (VER(:,2)+VER(:,3)) + Z2* (VER(:,1)+VER(:,4))
X(:,5) = Z1* (VER(:,2)+VER(:,4)) + Z2* (VER(:,1)+VER(:,3))
X(:,6) = Z1* (VER(:,3)+VER(:,4)) + Z2* (VER(:,1)+VER(:,2))
!
! Generator with homogeneous coordinates (z1,z2,z3,z3)
!
CASE (3)
NUMBER = 12
Z1 = GENER(1)
Z2 = GENER(2)
Z3 = GENER(3)
X(:,1) = Z1*VER(:,1) + Z2*VER(:,2) + Z3* (VER(:,3)+VER(:,4))
X(:,2) = Z1*VER(:,1) + Z2*VER(:,3) + Z3* (VER(:,2)+VER(:,4))
X(:,3) = Z1*VER(:,1) + Z2*VER(:,4) + Z3* (VER(:,2)+VER(:,3))
X(:,4) = Z1*VER(:,2) + Z2*VER(:,1) + Z3* (VER(:,3)+VER(:,4))
X(:,5) = Z1*VER(:,2) + Z2*VER(:,3) + Z3* (VER(:,1)+VER(:,4))
X(:,6) = Z1*VER(:,2) + Z2*VER(:,4) + Z3* (VER(:,1)+VER(:,3))
X(:,7) = Z1*VER(:,3) + Z2*VER(:,1) + Z3* (VER(:,2)+VER(:,4))
X(:,8) = Z1*VER(:,3) + Z2*VER(:,2) + Z3* (VER(:,1)+VER(:,4))
X(:,9) = Z1*VER(:,3) + Z2*VER(:,4) + Z3* (VER(:,1)+VER(:,2))
X(:,10) = Z1*VER(:,4) + Z2*VER(:,1) + Z3* (VER(:,2)+VER(:,3))
X(:,11) = Z1*VER(:,4) + Z2*VER(:,2) + Z3* (VER(:,1)+VER(:,3))
X(:,12) = Z1*VER(:,4) + Z2*VER(:,3) + Z3* (VER(:,1)+VER(:,2))
END SELECT
SUMVAL = Integrand(NUMFUN,X(:,1))
DO J = 2,NUMBER
WORK = Integrand(NUMFUN,X(:,J))
SUMVAL(1:NUMFUN) = SUMVAL(1:NUMFUN) + WORK(1:NUMFUN)
END DO
RETURN
END SUBROUTINE OrbT3_Sum
END MODULE CubatureRule_T3
SHAR_EOF
fi # end of overwriting check
if test -f 'rule_tn.f90'
then
echo shar: will not over-write existing file "'rule_tn.f90'"
else
cat << "SHAR_EOF" > 'rule_tn.f90'
! This file is F-compatible, except for upper/lower case conventions.
!--------------------------------------------------------------------
MODULE CubatureRule_Tn
USE Precision_Model
IMPLICIT NONE
PRIVATE
PUBLIC :: Rule_Tn
PRIVATE :: RuleParms_Tn, SymSmp_Sum
CONTAINS
SUBROUTINE Rule_Tn( TUNE, NDIM, VERTEX, VOLUME, NF, Integrand, &
INKEY, BASVAL, RGNERR, FVALT )
!***BEGIN PROLOGUE Rule_Tn
!***KEYWORDS basic numerical integration rule
!***PURPOSE To compute basic integration rule values.
!***AUTHOR
!
! Alan Genz
! Department of Mathematics
! Washington State University
! Pullman, WA 99164-3113, USA
! AlanGenz@wsu.edu
!
!***LAST MODIFICATION 02-07-09
!***DESCRIPTION Rule_Tn computes basic integration rule values for a
! vector of integrands over a hyper-rectangular region.
! These are estimates for the integrals. Rule_Tn also computes
! estimates for the errors.
!
! ON ENTRY
!
! TUNE Real, tuning parameter.
! NDIM Integer, number of variables.
! VERTEX Real array of dimension (NDIM,0:NDIM).
! The simplex vertices; vertex J must have components
! VERTEX(I,J), I = 1, 2, ..., NDIM.
! VOLUME Real, volume of simplex.
! NF Integer, number of components for the vector integrand.
! Integrand Real vector function of length NF for computing components of
! the integrand at Z.
! It must have parameters ( NF, Z ); see interface below
! Input parameters:
! Z Real array of length NDIM, the evaluation point.
! NF Integer number of components of Integrand.
! INKEY Integer rule parameter.
! If INKEY > 0 and INKEY < 5 then a rule of degree 2*INKEY + 1
! is used; otherwise a default rule of degree 7 is used.
!
! ON RETURN
!
! BASVAL Real array of length NF, values for the basic rule for
! each component of the integrand.
! RGNERR Real array of length NF, error estimates for BASVAL.
! FVALT Integer, number of integrand values USEd by Rule_Tn.
!
!
!***ROUTINES CALLED: RuleParms_Tn, SymSmp_Sum
!
!***END PROLOGUE Rule_Tn
!
! Global variables.
!
INTEGER, INTENT(IN) :: NF, NDIM, INKEY
INTEGER, INTENT(OUT) :: FVALT
INTERFACE
FUNCTION Integrand(NF,X) RESULT(Value)
USE Precision_Model
INTEGER, INTENT(IN) :: NF
REAL(KIND=STND), DIMENSION(:), INTENT(IN) :: X
REAL(KIND=STND), DIMENSION(NF) :: Value
END FUNCTION Integrand
END INTERFACE
REAL(KIND=STND), DIMENSION(:,0:), INTENT(IN) :: VERTEX
REAL(KIND=STND), INTENT(IN) :: VOLUME, TUNE
REAL(KIND=STND), DIMENSION(:), INTENT(OUT) :: BASVAL, RGNERR
!
! Local variables.
!
! WTS Integer number of weights in the integration rules.
! W Real array of dimension (WTS,RLS).
! The weights for the basic and null rules.
! W(1,1),...,W(WTS,1) are weights for the basic rule.
! W(1,I),...,W(WTS,I), for I > 1 are null rule weights.
! G Real array of dimension (0:NDIM, WTS).
! The fully symmetric sum generators for the rules.
! G(0, J), ..., G(NDIM, J) are the are the generators for the
! points associated with the Jth weights.
! X Real work array of length NDIM.
! GT Real work array of length 0:NDIM.
! RULE Real work array of dimension (NF,MXRLS).
! ERROR Real work array of length NF.
! RATIO Real work array of length NF.
!
INTEGER, PARAMETER :: MXW = 21, MXRLS = 7, MXG = 4
REAL(KIND=STND), PARAMETER :: ONE = 1
REAL(KIND=STND), PARAMETER :: SMALL = 100*EPSILON(ONE)
INTEGER, SAVE :: OLDKEY = -1, OLDN = 0
INTEGER, SAVE :: RLS, WTS, KEY, FVALS
INTEGER, DIMENSION(MXW), SAVE :: PTS
REAL(KIND=STND), DIMENSION(MXW,MXRLS), SAVE :: W
REAL(KIND=STND), DIMENSION(0:MXG,MXW), SAVE :: G
REAL(KIND=STND), DIMENSION(NF,MXRLS) :: RULE
REAL(KIND=STND), DIMENSION(MXRLS) :: ALPHA
REAL(KIND=STND), DIMENSION(0:NDIM) :: GTEMP
REAL(KIND=STND), DIMENSION(NF) :: RATIO
REAL(KIND=STND) :: NORMCF, NORMNL, ERRCOF
INTEGER :: K
!
!***FIRST PROCESSING STATEMENT Rule_Tn
!
IF ( OLDKEY /= INKEY .OR. OLDN /= NDIM ) THEN
OLDN = NDIM
OLDKEY = INKEY
IF ( INKEY > 0 .AND. INKEY < 5 ) THEN
KEY = INKEY
ELSE
KEY = 3
END IF
!
! Compute WTS, RLS, weights, generators, ERRCOF and PTS.
!
CALL RuleParms_Tn( NDIM, KEY, W, G, WTS, RLS, PTS )
!
! Orthogonalize and normalize null rules.
!
NORMCF = DOT_PRODUCT( PTS(1:WTS)*W(1:WTS,1), W(1:WTS,1) )
DO K = 2, RLS
ALPHA(2:K-1) = -MATMUL( TRANSPOSE(W(:,2:K-1)), PTS*W(:,K) )
W(:,K) = W(:,K) + MATMUL( W(:,2:K-1), ALPHA(2:K-1) )/NORMCF
NORMNL = DOT_PRODUCT( PTS*W(:,K), W(:,K) )
W(:,K) = W(:,K)*SQRT( NORMCF/NORMNL )
END DO
FVALS = SUM( PTS(1:WTS) )
END IF
!
! Compute the rule values.
!
RULE = 0
DO K = 1, WTS
IF ( PTS(K) > 0 ) THEN
GTEMP( 0: MIN(NDIM,MXG-1) ) = G( 0: MIN(NDIM,MXG-1) , K )
IF ( NDIM >= MXG ) THEN
GTEMP(MXG:NDIM) = G(MXG,K)
END IF
BASVAL = SymSmp_Sum( NDIM, VERTEX, NF, Integrand, GTEMP )
RULE = RULE + MATMUL( RESHAPE( BASVAL, (/ NF, 1 /) ), W(K:K,:) )
END IF
END DO
BASVAL = RULE(:,1)
!
! Scale integral values and compute the error estimates.
!
ERRCOF = 7*TUNE + 1
RATIO = 0
RULE(:,RLS) = MAX ( ABS(RULE(:,RLS)) , ABS(RULE(:,RLS-1)) )
RGNERR = RULE(:,RLS)
IF ( KEY > 1 ) THEN
DO K = RLS-2, 3, -2
RULE(:,K) = MAX( ABS(RULE(:,K )) , ABS(RULE(:,K-1)) )
WHERE ( ABS(BASVAL) + RULE(:,K)/(100*KEY) > ABS(BASVAL) )
RATIO = MAX( RULE(:,K)/RULE(:,K+2), RATIO )
END WHERE
RGNERR = MAX( RULE(:,K), RGNERR )
END DO
RATIO = MAX( ONE/10, RATIO )
WHERE ( RATIO >= 1 )
RGNERR = TUNE*RGNERR + ( 1 - TUNE )*RULE(:,3)
ELSEWHERE
RGNERR = RATIO*RULE(:,3)
END WHERE
END IF
RGNERR = VOLUME*MAX( ERRCOF*RGNERR, SMALL*ABS( BASVAL ) )
BASVAL = VOLUME*BASVAL
FVALT = FVALS
RETURN
!
!***END Rule_Tn
!
END Subroutine Rule_Tn
!
SUBROUTINE RuleParms_Tn( NDIM, KEY, W, G, WTS, RLS, PTS )
!
!***BEGIN PROLOGUE RuleParms_Tn
!***KEYWORDS basic integration rule, degree 2*KEY+1
!***PURPOSE To initialize a degree 2*KEY+1 basic rule and null rules.
!***AUTHOR
!
! Alan Genz
! Department of Mathematics
! Washington State University
! Pullman, WA 99164-3113, USA
! AlanGenz@wsu.edu
!
! Ronald Cools, Dept. of Computer Science,
! Katholieke Universiteit Leuven, Celestijnenlaan 200A,
! B-3001 Heverlee, Belgium
! Email: Ronald.Cools@cs.kuleuven.ac.be
!
!***LAST MODIFICATION by Alan 99-05
!***LAST MODIFICATION by Ronald 01-07-19 (cleaning code)
!***DESCRIPTION RuleParms_Tn initializes a degree 2*KEY+1 rule, and
! and max(2*KEY,2) lower degree null rules.
!
! ON ENTRY
!
! NDIM Integer, number of variables.
! KEY Integer, < 5 and >= 0, rule parameter.
! If KEY > 0 a degree 2*KEY+1 rule is initialized.
! If KEY = 0 a degree 7 rule is initialized.
!
! ON RETURN
! RLS Integer, total number of rules.
! WTS Integer, total number of weights in each of the rules.
! W Real array of dimension (MXW,*).
! The weights for the basic and null rules.
! W(1,1),...,W(WTS,1) are weights for the basic rule.
! W(I,1),...,W(WTS,I) for I > 1 are null rule weights.
! G Real array of dimension (0:MXG,MXW).
! The fully symmetric sum generators for the rules.
! G(0,J), ..., G(MXG,J) are the generators for the
! points associated with the Jth weights.
! PTS Integer array of length (MXW). PTS(J) is the number of integrand
! values needed for generator J.
!
!***REFERENCES
!
! Axel Grundmann and H. M. Moller
! "Invariant Integration Formulas for the n-Simplex by Combinatorial Methods",
! SIAM J Numer. Anal. 15(1978), 282--290,
! and
! A. H. Stroud
! "A Fifth Degree Integration Formula for the n-Simplex
! SIAM J Numer. Anal. 6(1969), 90--98,
! and
! I. P. Mysovskikh
! "On a cubature formula for the simplex"
! Vopros. Vycisl. i Prikl. Mat., Tashkent 51(1978), 74--90.
!
!
!***ROUTINES CALLED NONE
!***END PROLOGUE RuleParms_Tn
!
! Global variables
!
INTEGER, INTENT(IN) :: NDIM, KEY
INTEGER, INTENT(OUT) :: WTS, RLS
INTEGER, DIMENSION(:), INTENT(OUT) :: PTS
REAL(KIND=STND), DIMENSION(:,:), INTENT(OUT) :: W
REAL(KIND=STND), DIMENSION(0:,:), INTENT(OUT) :: G
!
! Local Variables
!
REAL(KIND=STND), PARAMETER :: ONE = 1, FFTEEN = 15
REAL(KIND=STND) :: DR, DR2, DR4, DR6, DR8
REAL(KIND=STND) :: R1, S1, R2, S2, U1, V1, U2, V2, L1, L2, D1, D2
REAL(KIND=STND) :: A1, A2, A3, P0, P1, P2, P3, U5, U6, U7, SG
REAL(KIND=STND) :: R, A, P, Q, TH, TP
INTEGER :: IW, GMS
!
!***FIRST PROCESSING STATEMENT RuleParms_Tn
!
!
! Initialize RLS and GMS.
!
IF ( KEY == 1 ) THEN
RLS = 3
GMS = 2
WTS = 3
ELSE IF ( KEY == 2 ) THEN
RLS = 5
GMS = 4
WTS = 6
ELSE IF ( KEY == 3 .OR. KEY == 0 ) THEN
RLS = 7
GMS = 7
WTS = 11
ELSE IF ( KEY == 4 ) THEN
RLS = 7
IF ( NDIM == 2 ) THEN
GMS = 11
WTS = 20
ELSE
GMS = 12
WTS = 21
END IF
END IF
!
! Initialize generators, weights and PTS.
!
W(:,1:RLS) = 0
PTS = 0
!
! Compute generator, PTS and weight values for all rules.
!
DR = NDIM
DR2 = ( DR + 1 )*( DR + 2 )
DR4 = DR2*( DR + 3 )*( DR + 4 )
DR6 = DR4*( DR + 5 )*( DR + 6 )
DR8 = DR6*( DR + 7 )*( DR + 8 )
G(0:,1) = 1/( DR + 1 )
PTS(1) = 1
R1 = ( DR + 4 - SQRT(FFTEEN) )/( DR*DR + 8*DR + 1 )
S1 = 1 - DR*R1
L1 = S1 - R1
G(0 ,GMS+1) = S1
G(1:,GMS+1) = R1
PTS(GMS+1) = NDIM + 1
IW = RLS
IF ( KEY < 4 ) THEN
!
! Compute weights for special degree 1 rule.
!
W(1,IW) = 1
IW = IW - 1
W(GMS+1,IW) = 1/( DR + 1 )
IW = IW - 1
END IF
!
! Compute weights, generators and PTS for degree 3 rule.
!
G(0 ,2) = 3/( DR + 3 )
G(1:,2) = 1/( DR + 3 )
PTS(2) = NDIM + 1
W(2,IW) = ( DR + 3 )**3/( 4*DR2*( DR + 3 ) )
IF ( KEY > 1 ) THEN
IW = IW - 1
!
! Compute weights, generators and PTS for degree 3 and degree 5 rules.
!
IF ( NDIM == 2 ) THEN
!
! Special degree 3 rule.
!
L2 = 0.6205464826720063258904603436171006977619_STND
L1 = -SQRT( ONE/2 - L2**2 )
R1 = ( 1 - L1 )/3
S1 = 1 - 2*R1
G(0 ,GMS+1) = S1
G(1:,GMS+1) = R1
PTS(GMS+1) = 3
W(GMS+1,IW) = ONE/6
R2 = ( 1 - L2 )/3
S2 = 1 - 2*R2
G(0 ,GMS+2) = S2
G(1:,GMS+2) = R2
PTS(GMS+2) = 3
W(GMS+2,IW) = ONE/6
ELSE
!
! Degree 3 rule using Stroud points.
!
R2 = ( DR + 4 + SQRT(FFTEEN) )/( DR*DR + 8*DR + 1 )
S2 = 1 - DR*R2
L2 = S2 - R2
G(0 ,GMS+2) = S2
G(1:,GMS+2) = R2
PTS(GMS+2) = NDIM + 1
W(GMS+2,IW) = ( 2/(DR+3) - L1 )/(DR+1)/(DR+2)/(L2-L1)/L2**2
W(GMS+1,IW) = ( 2/(DR+3) - L2 )/(DR+1)/(DR+2)/(L1-L2)/L1**2
END IF
IW = IW - 1
!
! Grundmann-Moller degree 5 rule.
!
G(0 ,3) = 5/( DR + 5 )
G(1:,3) = 1/( DR + 5 )
PTS(3) = NDIM + 1
G(0:1 ,4) = 3/( DR + 5 )
G(2:,4) = 1/( DR + 5 )
PTS(4) = ( ( NDIM + 1 )*NDIM )/2
W(2, IW) = -( DR + 3 )**5/( 16*DR4 )
W(3:4,IW) = ( DR + 5 )**5/( 16*DR4*( DR + 5 ) )
END IF
IF ( KEY > 2 ) THEN
IW = IW - 1
!
! Compute weights, generators and PTS for degree 5 and degree 7 rules.
!
!
! Stroud degree 5 rule.
!
U1 = ( DR + 7 + 2*SQRT(FFTEEN) )/( DR*DR + 14*DR - 11 )
V1 = ( 1 - ( DR - 1 )*U1 )/2
D1 = V1 - U1
G(0:1 ,GMS+3) = V1
G(2:,GMS+3) = U1
PTS(GMS+3) = ( ( NDIM + 1 )*NDIM )/2
U2 = ( DR + 7 - 2*SQRT(FFTEEN) )/( DR*DR + 14*DR - 11 )
V2 = ( 1 - ( DR - 1 )*U2 )/2
D2 = V2 - U2
G(0:1 ,GMS+4) = V2
G(2:,GMS+4) = U2
PTS(GMS+4) = ( ( NDIM + 1 )*NDIM )/2
IF ( NDIM == 2 ) THEN
W(GMS+3,IW) = ( 155 - SQRT(FFTEEN) )/1200
W(GMS+4,IW) = ( 155 + SQRT(FFTEEN) )/1200
W(1, IW) = 1 - 3*( W(GMS+3,IW) + W(GMS+4,IW) )
ELSE IF ( NDIM == 3 ) THEN
W(GMS+1,IW) = ( 2665 + 14*SQRT(FFTEEN) )/37800
W(GMS+2,IW) = ( 2665 - 14*SQRT(FFTEEN) )/37800
W(GMS+3,IW) = 2*FFTEEN/567
PTS(GMS+4) = 0
ELSE
W(GMS+1,IW) = ( 2*(27-DR)/(DR+5)-L2*(13-DR) )/L1**4/(L1-L2)/DR4
W(GMS+2,IW) = ( 2*(27-DR)/(DR+5)-L1*(13-DR) )/L2**4/(L2-L1)/DR4
W(GMS+3,IW)=( 2/( DR + 5 ) - D2 )/( DR4*( D1 - D2 )*D1**4 )
W(GMS+4,IW)=( 2/( DR + 5 ) - D1 )/( DR4*( D2 - D1 )*D2**4 )
END IF
IW = IW - 1
!
! Grundmann-Moller degree 7 rule.
!
G(0 ,5) = 7/( DR + 7 )
G(1:,5) = 1/( DR + 7 )
PTS(5) = NDIM + 1
G(0 ,6) = 5/( DR + 7 )
G(1 ,6) = 3/( DR + 7 )
G(2:,6) = 1/( DR + 7 )
PTS(6) = ( NDIM + 1 )*NDIM
G(0:2 ,7) = 3/( DR + 7 )
G(3:,7) = 1/( DR + 7 )
PTS(7) = ( ( NDIM + 1 )*NDIM*( NDIM - 1 ) )/6
W(2, IW) = ( DR + 3 )**7/( 2*64*DR4*( DR + 5 ) )
W(3:4,IW) = -( DR + 5 )**7/( 64*DR6 )
W(5:7,IW) = ( DR + 7 )**7/( 64*DR6*( DR + 7 ) )
END IF
IF ( KEY == 4 ) THEN
IW = IW - 1
!
! Compute weights, generators and PTS for degree 7 and degree 9 rules.
!
! Mysovskikh degree 7 rule.
!
SG = 1/( 23328*DR6 )
U5 = -6**3*SG*( 52212 - DR*( 6353 + DR*( 1934 - DR*27 ) ) )
U6 = 6**4*SG*( 7884 - DR*( 1541 - DR*9 ) )
U7 = -6**5*SG*( 8292 - DR*( 1139 - DR*3 ) )/( DR + 7 )
P0 = -144*( 142528 + DR*( 23073 - DR*115 ) )
P1 = -12*( 6690556 + DR*( 2641189 + DR*( 245378 - DR*1495 ) ) )
P2 = -16*(6503401 + DR*( 4020794+DR*(787281+DR*(47323-DR*385)) ) )
P3 = -(6386660+DR*(4411997+DR*(951821+DR*(61659-DR*665))))*(DR+7)
!---------------------------------------------------------------------------
! Compute 3 zeros by 4 Newton iterations (good for about 30 digits)
! A1 = -2/( DR + 3 )
! A1 = A1 - ( P0+A1*(P1+A1*(P2+A1*P3)) )/( P1+A1*(2*P2+A1*3*P3) )
! A1 = A1 - ( P0+A1*(P1+A1*(P2+A1*P3)) )/( P1+A1*(2*P2+A1*3*P3) )
! A1 = A1 - ( P0+A1*(P1+A1*(P2+A1*P3)) )/( P1+A1*(2*P2+A1*3*P3) )
! A1 = A1 - ( P0+A1*(P1+A1*(P2+A1*P3)) )/( P1+A1*(2*P2+A1*3*P3) )
! G(0 ,GMS+5) = ( 1 - DR*A1 )/( DR + 1 )
! G(1:,GMS+5) = ( 1 + A1 )/( DR + 1 )
! PTS(GMS+5) = NDIM + 1
! P2 = P2 + A1*P3
! P1 = P1 + A1*P2
! A2 = ( -P2 - SQRT( P2**2 - 4*P1*P3 ) )/( 2*P3 )
! G(0 ,GMS+6) = ( 1 - DR*A2 )/( DR + 1 )
! G(1:,GMS+6) = ( 1 + A2 )/( DR + 1 )
! PTS(GMS+6) = NDIM + 1
! A3 = ( -P2 + SQRT( P2**2 - 4*P1*P3 ) )/( 2*P3 )
!---------------------------------------------------------------------------
! Compute 3 zeros by closed formula due to Cardan/Tartaglia
A = P2/( 3*P3 )
P = A*( P1/P2 - A )
Q = A*( 2*A*A - P1/P3 ) + P0/P3
R = SQRT( -P**3 )
TH = ACOS( -Q/( 2*R ) )/3
R = 2*R**( ONE/3 )
TP = 2*ACOS(-ONE)/3
A1 = -A + R*COS( TH )
G(0 ,GMS+5) = ( 1 - DR*A1 )/( DR + 1 )
G(1:,GMS+5) = ( 1 + A1 )/( DR + 1 )
PTS(GMS+5) = NDIM + 1
A2 = -A + R*COS( TH + TP + TP )
G(0 ,GMS+6) = ( 1 - DR*A2 )/( DR + 1 )
G(1:,GMS+6) = ( 1 + A2 )/( DR + 1 )
PTS(GMS+6) = NDIM + 1
A3 = -A + R*COS( TH + TP )
!---------------------------------------------------------------------------
G(0 ,GMS+7) = ( 1 - DR*A3 )/( DR + 1 )
G(1:,GMS+7) = ( 1 + A3 )/( DR + 1 )
PTS(GMS+7) = NDIM + 1
W(GMS+5,IW) = &
( U7-(A2+A3)*U6+A2*A3*U5 )/( A1**2-(A2+A3)*A1+A2*A3 )/A1**5
W(GMS+6,IW) = &
( U7-(A1+A3)*U6+A1*A3*U5 )/( A2**2-(A1+A3)*A2+A1*A3 )/A2**5
W(GMS+7,IW) = &
( U7-(A2+A1)*U6+A2*A1*U5 )/( A3**2-(A2+A1)*A3+A2*A1 )/A3**5
G(0:1 ,GMS+8) = 4/( DR + 7 )
G(2:,GMS+8) = 1/( DR + 7 )
PTS(GMS+8) = ( ( NDIM + 1 )*NDIM )/2
W(GMS+8,IW) = 10*(DR+7)**6/( 729*DR6 )
G(0 ,GMS+9) = 11/( DR + 7 )/2
G(1 ,GMS+9) = 5/( DR + 7 )/2
G(2:,GMS+9) = 1/( DR + 7 )
PTS(GMS+9) = ( ( NDIM + 1 )*NDIM )
W(GMS+9,IW) = 64*(DR+7)**6/( 6561*DR6 )
W( 4,IW) = W(4,IW+1)
W( 7,IW) = W(7,IW+1)
IW = IW - 1
!
! Grundmann-Moller degree 9 rule.
!
G(0 ,8) = 9/( DR + 9 )
G(1:,8) = 1/( DR + 9 )
PTS(8) = NDIM + 1
G(0 ,9) = 7/( DR + 9 )
G(1 ,9) = 3/( DR + 9 )
G(2:,9) = 1/( DR + 9 )
PTS(9) = ( NDIM + 1 )*NDIM
G(0:1 ,10) = 5/( DR + 9 )
G(2:,10) = 1/( DR + 9 )
PTS(10) = ( ( NDIM + 1 )*NDIM )/2
G(0 ,11) = 5/( DR + 9 )
G(1:2 ,11) = 3/( DR + 9 )
G(3:,11) = 1/( DR + 9 )
PTS(11) = ( ( NDIM + 1 )*NDIM*( NDIM - 1 ) )/2
W(2 ,IW) = -( DR + 3 )**9/( 6*256*DR6 )
W(3:4 ,IW) = ( DR + 5 )**9/( 2*256*DR6*(DR+7) )
W(5:7 ,IW) = -( DR + 7 )**9/( 256*DR8 )
W(8:11,IW) = ( DR + 9 )**9/( 256*DR8*(DR+9) )
IF ( NDIM > 2 ) THEN
G(0:3 ,12) = 3/( DR + 9 )
G(4:,12) = 1/( DR + 9 )
PTS(12) = ( ( NDIM + 1 )*NDIM*( NDIM - 1 )*( NDIM - 2 ) )/24
W(12,IW) = W(8,IW)
END IF
END IF
!
! Compute constant weight values.
!
W(1,1:RLS) = 1 - MATMUL( PTS(2:WTS), W(2:WTS,1:RLS) )
!
! Compute final weight values; null rule weights are computed as
! differences between weights from highest degree and lower degree rules.
!
W(:,2:RLS) = W(:,2:RLS) - SPREAD( W(:,1), 2, RLS-1 )
!
RETURN
END Subroutine RuleParms_Tn
!
FUNCTION SymSmp_Sum( N, VERTEX, NF, Integrand, GIN ) RESULT(SymSmpSum)
!
!***BEGIN PROLOGUE SymSmp_Sum
!***KEYWORDS fully symmetric sum
!***PURPOSE To compute fully symmetric basic rule sums
!***AUTHOR
!
! Alan Genz
! Department of Mathematics
! Washington State University
! Pullman, WA 99164-3113, USA
!
!***LAST MODIFICATION 99-05
!***DESCRIPTION SymSmp_Sum computes a fully symmetric sum for a vector
! of integrand values over a simplex. The sum is taken over
! all permutations of the generators for the sum.
!
! ON ENTRY
!
! N Integer, number of variables.
! VERTEX Real array of dimension (N,0:N)
! The vertices of the simplex, one vertex per column.
! NF Integer, number of components for the vector integrand.
! Integrand Real vector function of length NF for computing components of
! the integrand at Z.
! It must have parameters ( NF, Z ); see interface below
! Input parameters:
! Z Real array of length N, the evaluation point.
! NF Integer number of components of Integrand.
! GIN Real Array of dimension (0:N).
! The generators for the fully symmetric sum.
!
! ON RETURN
!
! SymSmp_Sum Real array of length NF, the values for the fully symmetric
! sums for each component of the integrand.
!
!***ROUTINES CALLED: Integrand
!
!***END PROLOGUE SymSmp_Sum
!
! Global variables.
!
INTEGER, INTENT(IN) :: N, NF
INTERFACE
FUNCTION Integrand(NF,Z) RESULT(Value)
USE Precision_Model
INTEGER, INTENT(IN) :: NF
REAL(KIND=STND), DIMENSION(:), INTENT(IN) :: Z
REAL(KIND=STND), DIMENSION(NF) :: Value
END FUNCTION Integrand
END INTERFACE
REAL(KIND=STND), DIMENSION(:,0:), INTENT(IN) :: VERTEX
REAL(KIND=STND), DIMENSION(0:), INTENT(IN) :: GIN
REAL(KIND=STND), DIMENSION(NF) :: SymSmpSum
!
! Local variables.
!
INTEGER :: IX, LX, I, J, K, L
REAL(KIND=STND), DIMENSION(0:N) :: G
REAL(KIND=STND) :: GL, GI
!
!***FIRST PROCESSING STATEMENT SymSmp_Sum
!
SymSmpSum = 0
G = GIN
!
! Sort input generators if necessary
!
K = 0
DO I = 1, N
IF ( G(I) > G(I-1) ) THEN
K = 1
END IF
END DO
IF ( K > 0 ) THEN
DO I = 1, N
K = I - 1
DO J = I, N
IF ( G(J) > G(K) ) THEN
K = J
END IF
END DO
IF ( K >= I ) THEN
GI = G(I-1)
G(I-1) = G(K)
G(K) = GI
END IF
END DO
END IF
!
! Compute integrand value for permutations of G
!
DO
SymSmpSum = SymSmpSum + Integrand( NF, MATMUL( VERTEX, G ) )
!
! Find next distinct permuation of G and loop back for value.
! Permutations are generated in reverse lexicographic order.
!
DO I = 1, N
IF ( G(I-1) > G(I) ) THEN
GI = G(I)
IX = I - 1
DO L = 0, I/2-1
GL = G(L)
G(L) = G(I-L-1)
G(I-L-1) = GL
IF ( GL <= GI ) THEN
IX = IX - 1
END IF
IF ( G(L) > GI ) THEN
LX = L
END IF
END DO
IF ( G(IX) <= GI ) THEN
IX = LX
END IF
G(I) = G(IX)
G(IX) = GI
EXIT
END IF
END DO
IF ( I == N+1 ) THEN
EXIT
END IF
END DO
!
RETURN
END Function SymSmp_Sum
!
END MODULE CubatureRule_Tn
SHAR_EOF
fi # end of overwriting check
if test -f 'volume.f90'
then
echo shar: will not over-write existing file "'volume.f90'"
else
cat << "SHAR_EOF" > 'volume.f90'
! This file is F-compatible, except for upper/lower case conventions.
!--------------------------------------------------------------------
Module Volume_Computation
USE Precision_Model, ONLY: stnd
Implicit NONE
PRIVATE
PUBLIC :: VOLUME
CONTAINS
FUNCTION VOLUME(DIMENS,GEOMETRY,VERTIC) RESULT(Value)
!***BEGIN PROLOGUE VOLUME
!***PURPOSE To compute the volume of a polytope
!***AUTHORS
! Ronald Cools Alan Genz
! Dept. of Computer Science Computer Science Department
! Katholieke Universiteit Leuven Washington State University
! Celestijnenlaan 200A Pullman, WA 99164-2752
! B-3001 Heverlee, Belgium USA
!
!***REVISION DATE 950419 (YYMMDD) (Fortran90 transformation)
!***REVISION DATE 980408 (YYMMDD) (F transformation)
!***DESCRIPTION VOLUME
!
! GEOMETRY = 1 : the VERTICes specify a simplex
! GEOMETRY = 2 : the VERTICes specify a cube
! GEOMETRY = 3 : the VERTICes specify an octahedron
!
! WARNING: If a region of an unsupported shape is presented,
! then this function returns 0.
! This is the only indication of a failure !
!
! Global variables.
!
INTEGER, INTENT(IN) :: DIMENS,GEOMETRY
REAL(kind=stnd), DIMENSION(:,:), INTENT(IN) :: VERTIC
REAL(kind=stnd) :: Value
!
! Local variables.
!
INTEGER :: I,J,K,PIVPOS,FACDIM
REAL(kind=stnd) :: MULT,VOL
REAL(kind=stnd), DIMENSION(DIMENS) :: TMP
REAL(kind=stnd), DIMENSION(DIMENS,DIMENS) :: WORK
IF ((GEOMETRY == 1) .OR. (GEOMETRY == 2) .OR. (GEOMETRY == 3)) THEN
SELECT CASE (DIMENS)
CASE (1) ! Compute length of an interval
Value = ABS(VERTIC(1,2)-VERTIC(1,1))
CASE (2) ! Compute area of a rectangle.
Value = ABS((VERTIC(1,2)-VERTIC(1,1))* &
(VERTIC(2,3)-VERTIC(2,1))- &
(VERTIC(2,2)-VERTIC(2,1))* &
(VERTIC(1,3)-VERTIC(1,1)))
CASE (3) ! Compute the volume of a cube.
Value = ABS((VERTIC(1,2)-VERTIC(1,1))* &
((VERTIC(2,3)-VERTIC(2,1))* (VERTIC(3, &
4)-VERTIC(3,1))- (VERTIC(2,4)-VERTIC(2, &
1))* (VERTIC(3,3)-VERTIC(3,1)))- &
(VERTIC(2,2)-VERTIC(2,1))* &
((VERTIC(1,3)-VERTIC(1,1))* (VERTIC(3, &
4)-VERTIC(3,1))- (VERTIC(1,4)-VERTIC(1, &
1))* (VERTIC(3,3)-VERTIC(3,1)))+ &
(VERTIC(3,2)-VERTIC(3,1))* &
((VERTIC(1,3)-VERTIC(1,1))* (VERTIC(2, &
4)-VERTIC(2,1))- (VERTIC(1,4)-VERTIC(1, &
1))* (VERTIC(2,3)-VERTIC(2,1))))
CASE DEFAULT ! Compute the volume of a DIMENS-dimensional cube
DO J = 1,DIMENS
WORK(1:DIMENS,J) = VERTIC(1:DIMENS,J+1) - VERTIC(1:DIMENS,1)
END DO
VOL = 1
DO K = 1,DIMENS
PIVPOS = K
DO J = K + 1,DIMENS
IF (ABS(WORK(K,J)) > ABS(WORK(K,PIVPOS))) THEN
PIVPOS = J
END IF
END DO
TMP(K:DIMENS) = WORK(K:DIMENS,K)
WORK(K:DIMENS,K) = WORK(K:DIMENS,PIVPOS)
WORK(K:DIMENS,PIVPOS) = TMP(K:DIMENS)
VOL = VOL*WORK(K,K)
DO J = K + 1,DIMENS
MULT = WORK(K,J)/WORK(K,K)
WORK(K+1:DIMENS,J) = WORK(K+1:DIMENS,J) - MULT*WORK(K+1:DIMENS,K)
END DO
END DO
Value = ABS(VOL)
END SELECT
IF ((GEOMETRY == 1) .OR. (GEOMETRY == 3)) THEN
!
! The volume of an DIMENS-dimensional simplex is the
! DIMENS! part of the volume of the cube.
!
FACDIM = DIMENS
DO I = 2,DIMENS - 1
FACDIM = FACDIM*I
END DO
Value = Value/FACDIM
END IF
IF (GEOMETRY == 3) THEN
!
! The volume of an DIMENS-dimensional octahedron is
! 2**(DIMENS-1) times the volume of the simplex.
!
Value = Value*2**(DIMENS-1)
END IF
ELSE
Value = 0
END IF
RETURN
END FUNCTION VOLUME
END MODULE Volume_Computation
SHAR_EOF
fi # end of overwriting check
cd ..
cd ..
# End of shell archive
exit 0