#! /bin/sh # This is a shell archive. Remove anything before this line, then unpack # it by saving it into a file and typing "sh file". To overwrite existing # files, type "sh file -c". You can also feed this as standard input via # unshar, or by typing "sh 'READ.ME' <<'END_OF_FILE' X *************************************************************************** X * All the software contained in this library is protected by copyright. * X * Permission to use, copy, modify, and distribute this software for any * X * purpose without fee is hereby granted, provided that this entire notice * X * is included in all copies of any software which is or includes a copy * X * or modification of this software and in all copies of the supporting * X * documentation for such software. * X *************************************************************************** X * THIS SOFTWARE IS BEING PROVIDED "AS IS", WITHOUT ANY EXPRESS OR IMPLIED * X * WARRANTY. IN NO EVENT, NEITHER THE AUTHORS, NOR THE PUBLISHER, NOR ANY * X * MEMBER OF THE EDITORIAL BOARD OF THE JOURNAL "NUMERICAL ALGORITHMS", * X * NOR ITS EDITOR-IN-CHIEF, BE LIABLE FOR ANY ERROR IN THE SOFTWARE, ANY * X * MISUSE OF IT OR ANY DAMAGE ARISING OUT OF ITS USE. THE ENTIRE RISK OF * X * USING THE SOFTWARE LIES WITH THE PARTY DOING SO. * X *************************************************************************** X * ANY USE OF THE SOFTWARE CONSTITUTES ACCEPTANCE OF THE TERMS OF THE * X * ABOVE STATEMENT. * X *************************************************************************** X X AUTHORS: X X F. Stenger, B. Keys, M. O'Reilly, K. Parker X University of Utah, Salt Lake City, Utah X X S.-A. Gustafson X Stavanger College, Stavanger, Norway X X X REFERENCE: X X - OPE-IVP-PACK via Sinc indefinite integration and Newton's method X NUMERICAL ALGORITHMS, 20 (1999), PP. 241-268 X X SOFTWARE REVISION DATE: X X MARCH 15, 1999 X X SOFTWARE LANGUAGE: X X FORTRAN 77 X X *************************************************************************** X X XU S I N G T H E P A C K A G E X XPURPOSE XThe package is used to solve numerically an initial-value problem Xfor a system of ordinary differential equations, implementing the Xmethods described in the paper by Stenger et. al., ODE-IVP-PACK Xvia Sinc indefinite integration and Newton's method. X X XCONTENTS XThe package consists of the following items: X This READ.ME file describing how to use the package. See also Section 6 Xin the paper by F. Stenger et. al. X A makefile useful for obtaining the executable code in a Unix system X Files map.h and workspace.h needed to pass the functions associated Xwith the conformal maps and the common block workspace between the fixed Xpart of the package and the file provided by the user, containing the Xproblem to be solved. X File code.f which contains the driver and all the modules that do not need Xbe modified by the user. X 13 further files with extension f, documenting examples in Section 7 Xof the paper which may be run using the package. The name of the files Xand the corresponding problems are given in the table below. XExample 7.1 problem_01.f XExample 7.2 problem_AB.f XExample 7.3 problem_Bul.f XExample 7.4 problem_Fun.f XExample 7.5 problem_Id.f XExample 7.6 problem_N11.f XExample 7.7 problem_RR.f XExample 7.8 problem_Sec.f XExample 7.9 problem_ig.f XExample 7.10 problem_g.f XExample 7.11 problem_sg1.f XExample 7.12 problem_l.f XExample 7.13 problem_wg.f X XSOLVING AN INITIAL-VALUE PROBLEM WITH THE PACKAGE XThe following 5 files are required to produce an executable code: Xmap.h Xworkspace.h Xmakefile Xcode.f Xproblem.f XThe last file defines the example to be solved using the package. XWe will describe below how to write this file X X XSOLVING ON OF THE EXAMPLES IN SECTION 7 OF THE PAPER BY STENGER et. al. XWe discuss first the situation when the user wants to reproduce one of the X13 examples given in Section 7. It will become apparent from what is said Xbelow how to do, if one wants to change one or more of the parameters in Xthese examples. XAssume that the user wants to treat the Problem 7.3 which is contained in Xthe file problem_Bul.f and write the result on the file answer. Then (s)he Xtypes the following commands: X Xcp problem_Bul.f problem.f Xmake Xproblem>answer X XThus the system of ordinary differential equations to be solved is Xspecified on a file which is copied on the file problem.f which Xserves as input for the main program driver. X X In the case of a non-Unix system, the user needs to combine a file Xcontaining source modules, defining the problem to be solved, with the file Xcode.f, then compile, link and run. X X By studying the 13 solved Xexamples the user may get some ideas about how to treat her/his own problem. XThe package may be used either for solving a given problem or for Xverifying that a solution obtained by other means, is correct. X XIn the Examples 7.2, 7.8 and 7.9 not all of the components of the solution Xvector may be expressed as simple functions. In these cases the corresponding Xprograms deliver the observed error only for the simple components. For Xthe others the exact values are replaced by zero and the absolute value Xof the calculated solution appears in the error column of the tables. The Xoutput for these components is not printed in the paper but will be Xdelivered when these programs are run. As well-known many special Xfunctions and families of orthogonal functions are defined as solutions of Xordinary differential equations. See e. g. Examples 7.8 and 7.13 in the paper. XThen this package could be used to tabulate these functions X XSPECIFYING A PROBLEM: XThe user needs to supply the following information in some routines Xcontained in the file problem.f X1. The number of points to use in solving the equation X2. The system of first order differential equations X3. The initial conditions for the system of first order differential equations X4. The Jacobian associated with this system X5. An approximate solution to be used for starting the Newton iterations X6. The conformal map to use X7. The points where the calculated solution should be tabulated X8. The control variable Itest to indicate if the purpose is to verify Xthe correctness of a suggested solution X XIf the system of ordinary differential equations is linear, then the XNewton process converges after one iteration and the starting Xapproximation may be chosen arbitrarily. There is no guarantee that Xthis problem will converge for a nonlinear problem and an error-exit Xhas been provided if an answer is not found after the maximum number of Xiterations indicated by the user X XPROGRAMS NEEDED TO DEFINE A PARTICULAR PROBLEM XThey form the file problem.f and are contained in all of the files Xin the group above. Note that in the sample problems above the X4 subprograms Phi, OneOverPrime, Rho and Psi are defined via Xmap.h XControlVars Xf XJ_ij XPhi XOneOverPhiPrime XRho XPsi XSetXs XSolution XStartAppr XInitCond XAll of these 11 subprogram must be written by the user. X X X XAN EXAMPLE XHere we show how to provide this information for the Example 7.3 Xin Section 7. The corresponding code is in the file problem_Bul.f XIt contains the subprograms: X XSubroutine ControlVars which sets the following variables: X NumEqs, number of equations in the system X SincPts, number of sinc-points X Nxs, number of points in table X MaxIter, maximum number of iterations X Itest, Itest=0, no exact solution known, Itest=1, exact solution known X and is to be verified numerically X XSubroutine F, returns the derivatives of the solution dy(i)/dt X XSubroutine J_ij, returns the derivatives in the Jacobian, dYDOT(i)/dY(k) X XFour functions defining the conformal mapping, namely XPHi, OneOverPhiPrime, Rho and Psi X XFunction Solution which returns the exact solution, if known. Otherwise the Xuser can define its output to be zero X XSubroutine InitCond returns the initial conditions X XSubroutine StartAppr returns the starting approximate solution for the Newton Xprocess. If the system to be solved is linear, the Newton process converges Xafter one iteration for any starting solution. X X X X X X X X X END_OF_FILE if test 7983 -ne `wc -c <'READ.ME'`; then echo shar: \"'READ.ME'\" unpacked with wrong size! fi # end of 'READ.ME' fi if test -f 'makefile' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'makefile'\" else echo shar: Extracting \"'makefile'\" \(572 characters\) sed "s/^X//" >'makefile' <<'END_OF_FILE' X###################################################################### X# f o r t r a n / m a k e f i l e X# X# This is the makefile for the FORTRAN version of the indefinite X# integration package. X# X###################################################################### X X X################################### X# Executables X################################### X Xproblem : problem.o code.o X f77 -o problem problem.o code.o X X################################### X# Object Files X################################### X Xcode.o : code.f workspace.h Xproblem.o : problem.f workspace.h X X END_OF_FILE if test 572 -ne `wc -c <'makefile'`; then echo shar: \"'makefile'\" unpacked with wrong size! fi # end of 'makefile' fi if test -f 'map.h' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'map.h'\" else echo shar: Extracting \"'map.h'\" \(1436 characters\) sed "s/^X//" >'map.h' <<'END_OF_FILE' X* m a p . h X X* This module declares all the necessary functions associated with the X* supplied conformal maps. The functions are defined the section X* named map.f in the file code.f X X* The user may define additional conformal maps by writing code X* defining new functions PHi, OneOverPhiPrime, Psi and Rho. In X* this case the instruction INCLUDE map.h is deleted and the X* user's own functions occur instead of the standard ones. X X* M A P L I S T X X DOUBLE PRECISION Phi01, PhiPriRec01, Psi01, Rho01 X EXTERNAL Phi01, PhiPriRec01, Psi01, Rho01 X X DOUBLE PRECISION PhiN11, PhiPriRecN11, PsiN11, RhoN11 X EXTERNAL PhiN11, PhiPriRecN11, PsiN11, RhoN11 X X DOUBLE PRECISION PhiAB, PhiPriRecAB, PsiAB, RhoAB X EXTERNAL PhiAB, PhiPriRecAB, PsiAB, RhoAB X X DOUBLE PRECISION PhiBul, PhiPriRecBul, PsiBul, RhoBul X EXTERNAL PhiBul, PhiPriRecBul, PsiBul, RhoBul X X DOUBLE PRECISION PhiSec, PhiPriRecSec, PsiSec, RhoSec X EXTERNAL PhiSec, PhiPriRecSec, PsiSec, RhoSec X X DOUBLE PRECISION PhiRR, PhiPriRecRR, PsiRR, RhoRR X EXTERNAL PhiRR, PhiPriRecRR, PsiRR, RhoRR X X DOUBLE PRECISION PhiId, PhiPriRecId, PsiId, RhoId X EXTERNAL PhiId, PhiPriRecId, PsiId, RhoId X X DOUBLE PRECISION PhiFun, PhiPriRecFun, PsiFun, RhoFun X EXTERNAL PhiFun, PhiPriRecFun, PsiFun, RhoFun X X X X X X X X X X X X X X X X X X X X X X X X END_OF_FILE if test 1436 -ne `wc -c <'map.h'`; then echo shar: \"'map.h'\" unpacked with wrong size! fi # end of 'map.h' fi if test -f 'workspace.h' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'workspace.h'\" else echo shar: Extracting \"'workspace.h'\" \(2511 characters\) sed "s/^X//" >'workspace.h' <<'END_OF_FILE' X**** w o r k s p a c e . h X X* The file workspace.h should be included in the following modules X* of the user-supplied file problem.f namely SUBROUTINE F, X* SUBROUTINE J_ij and SUBROUTINE StartAppr X X* This header file defines the common block Workspace which is used to X* define a large number of pointers into the working array. X X* Points to the list of the Psi values at the sinc points. X INTEGER PsiPointer X X* Pointer to the values of One-Over-Phi-Prime at the sinc points. X INTEGER OneOverPhiPrimePointer X X* Pointer into the Sigma array. Note that this points to X* Sigma(0), the sigma array actually goes form -N to N. X INTEGER OffSigma X X* Points to a list of pointers (one per equation) for the OldY value X* at the sinc points. X INTEGER OldYPointerPointer X X* Points to the list of Y values at the sinc points. X INTEGER Y0Pointer X X* Points to a temporary matrix used for the linear algebra X* sub-problem AX = B. The size is ( (2N + 1) NumOfEqua )^2 X INTEGER APointer X X* Points to a temporary matrix used for the linear algebra X* sub-problem AX = B. The size is (2N + 1) NumOfEqua X INTEGER BPointer X X* Points to a temporary matrix used to store the pivot values for the X* L-U decomposition of A. Note that the actual decomposition is X* stored in A. The size is (2N + 1) NumOfEqua X INTEGER APivotPointer X X* Points to the list of pointers (one per equation) for the F(t,Y) values X* at the sinc points. X INTEGER FPointerPointer X X* Points to a list of pointers (one per equation) for the BijX values X* at the sinc points. X INTEGER BijPointerPointer X X* Points to a list of pointers (one per equation) for the Y values at X* the sinc points X INTEGER YPointerPointer X X* Points to the list of Phi(X) values at the interpolation points. X INTEGER PhiPointer X X* Pointer to the list of Rho (i.e., Exp( Phi(X) ) ) values at the X* interpolation points. X INTEGER RhoPointer X X* Exp(KH) for each K in [-N,N] X INTEGER OffExpKH X X* Pointer to the list of the Sinc function evaluated at X* equally spaced points. X INTEGER SincPointer X X********************************************************************** X COMMON /Workspace/ X . APointer, APivotPointer, BPointer, BijPointerPointer, X . FPointerPointer, OffExpKH, OffSigma, OldYPointerPointer, X . OneOverPhiPrimePointer, PhiPointer, PsiPointer, RhoPointer, X . SincPointer, YPointerPointer, Y0Pointer X X X X X X X X END_OF_FILE if test 2511 -ne `wc -c <'workspace.h'`; then echo shar: \"'workspace.h'\" unpacked with wrong size! fi # end of 'workspace.h' fi if test -f 'code.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'code.f'\" else echo shar: Extracting \"'code.f'\" \(174456 characters\) sed "s/^X//" >'code.f' <<'END_OF_FILE' X* d r i v e r .f X X* STRUCTURE OF THIS FILE, code.f X* It contains: X* MAIN program driver. X* Several groups of subprograms namely: X* 1. General subprograms written by the authors for solving a X* general system of ordinary differential equations: X* Interpo X* Init1Work X* Init2Work X* Newton X* SincMNRD X* UpDateA X* 2. Functions defining standard conformal mappings and communicated to X* problem.f via map.h: X* Used by file problem_Fun.f for Example 7.4 X* phifun: X* psifun: X* phiprirecfun: X* rhofun: X X* Used by problem_Id.f in Example 7.5 X* phiid: X* psiid: X* phiprirecid: X* rhoid: X X* Used by problem_01.f in Example 7.1 X* phi01: X* psi01: X* phiprirec01: X* rho01: X X* Used by problem_N11.f in Example 7.6 X* phin11: X* psin11: X* phiprirecn11: X* rhon11: X X* Used by: problem_AB.f in Example 7.2 X* problem_ig.f in Example 7.9 X* problem_sg1.f.f in Example 7.11 X* problem_l.f in Example 7.12 X* problem_wg.f in Example 7.13 X* phiab: X* psiab: X* phiprirecab: X* rhoab: X* X* Used by: problem_RR.f in Example 7.7 X* phirr: X* psirr: X* phiprirecrr: X* rhorr: X X* Used by: problem_Bul.f in Example 7.3 X* phibul: X* psibul: X* phiprirecbul: X* rhobul: X* X* Used by: problem_Sec.f in Example 7.8 X* problem_g.f in Example 7.10 X* phisec: X* psisec: X* phiprirecsec: X* rhosec: X* 3. Subprograms from public domain libraries. Complete documentation is X* found in the source code. X* General numerical routines: X* DGEFA from Linpack X* DAXPY from Linpack X* DSCAL from Linpack X* IDAMAX from Linpack X* DGESL from Linpack X* DDOT from Linpack X* DGECO from Linpack X* DGEFA from Linpack X* DASUM form Linpack X* DGAMI from LANL X* DGAMIT from LANL X* DGAMR from LANL X* DGAMMA from LANL X* DGAMLM from LANL X* DLNGAM from LANL X* D1MACH from LANL X* D9LGMC from LANL X* D9GMIT from LANL X* D9LGIC from LANL X* D9LGIT from LANL X* DCSEVL from LANL X* INITDS from LANL X* DLGAMS from LANL X* Routines for handling error messages from SLATEC: X* J4SAVE X* XGETUA X* XERABT X* XERCTL X* XERPRT X* XERROR X* XERRWV X* XERCLR X* XERSAV X* XGETF X* XSETF X*4. Hardware dependent subprograms X* CALJY0 from Argonne National laboratory X* BESJ0 from Argonne National laboratory X* BESY0 from Argonne National laboratory X* FDUMP from SLATEC X* I1MACH from Bell Labs X* 5. Intrinsic functions: X* abs X* aint X* cos X* dabs X* dble X* dexp X* dfloat X* dint X* dlog X* dmax1 X* dmin1 X* dmod X* dsign X* dsin X* dsinh X* dsqrt X* dtanh X* float X* iabs X* len X* log X* log10 X* max0 X* min X* min0 X* mod X* nint X* sin X* sngl X* sqrt X X* This MAIN program calls the routines to solve the IVP and to interpolate. X* If itest=1 we know the exact solution and compare the interpolated X* solution to the exact solution. X* If itest=0, the exact solution is not known and we estimate the error X* to be of the order of magnitude of number Tol, calculated as a local X* variable inside INTEGER FUNCTION Newton and printed by this subprogram X* The calculation of Tol is discussed in Subsection 6.11 of the paper X* "ODE-IVP-PACK via Sinc indefinite integration and Newton's method" X* by F. Stenger, S.-A. Gustafson, B. Keys, M. O'Reilly and K. Parker, X* March 1999 X* ----+----------------------------------------------------------------+ X X PROGRAM driver X* CALLED BY: X* none X* SUBPROGRAMS CALLED: X* ControlVars X* Interpo X* Init1Work X* InitCond X* StartAppr X* Newton X* SetXs X* Solution X IMPLICIT NONE X X INCLUDE 'workspace.h' X X* The function that evaluates the analytic solution. X DOUBLE PRECISION Solution X EXTERNAL Solution X X* The function that computes the newton iterates. X INTEGER Newton X EXTERNAL Newton X X* This section defines constants that are required by the driver X* program. X INTEGER MaxNxs X PARAMETER ( MaxNxs = 500 ) X X INTEGER MaxSize X PARAMETER ( MaxSize = 160000 ) X X INTEGER MaxNumOfEqua X PARAMETER ( MaxNumOfEqua = 8 ) X X* This section allocates memory for all the arrays. X INTEGER N, NumOfEqua, Nxs X INTEGER i, k, Status, TotalAdd, MaxIter, Itest X X DOUBLE PRECISION H X DOUBLE PRECISION TrueValue, Error X DOUBLE PRECISION InitC(MaxNumOfEqua), X(MaxNxs), Y(MaxNxs) X DOUBLE PRECISION Work(MaxSize) X X* ----+----------------------------------------------------------------+ X* This is the executable code to solve the IVP at the Sinc points. X* ----+----------------------------------------------------------------+ X* Input control parameters. X CALL ControlVars( N, NumOfEqua, Nxs, MaxIter, H ,Itest) X X* Next, Initialize the Work array for the chosen conformal mapping. X CALL Init1Work(N, NumOfEqua, H, Work, TotalAdd) X X* Set the initial conditions for the IVP here. X CALL InitCond(NumOfEqua, InitC) X X* Set the initial values for the dependent variables here. X CALL StartAppr( NumOfEqua, N, Work ) X X* CALL the IVP solver. X Status = Newton(H, N, NumOfEqua, InitC, Work, TotalAdd, MaxIter ) X X IF (Status .NE. 0) THEN X PRINT *,' Newton did not converge --> STOP !' X STOP X END IF X X* ----+----------------------------------------------------------------+ X* This is the executable code to interpolate the solution between the X* Sinc points X* ----+----------------------------------------------------------------+ X X* Set k equal to the function you wish to work with. X DO k = 1, NumOfEqua X X PRINT *,' Equation ', k X PRINT *,' ' X IF(Itest.eq.1) THEN X PRINT *,' ','argument, calc. Y_k, exact Y_k',' error' X ELSE X PRINT *,' ',' ',' ',' ',' argument, Y_k-value ' X ENDIF X* Setup a vector of x-values at which you want the solution interpolated. X CALL SetXs( k, Nxs, X ) X X* Call the interpolation routine. X CALL Interpo(H, N, k, Work, Nxs, X, Y, TotalAdd ) X X* Compare analytic solution and computed solution. X IF(Itest .EQ. 1) THEN X DO i = 1, Nxs X TrueValue = Solution(k, X(i)) X Error = DABS(Y(i) - TrueValue) X X write(*,10) X(I), '&',Y(I) ,'&',TrueValue,'&',Error X 10 format(( x, e11.3, x, a1 ), x, e14.8, x, a1 , X + e14.8,x,a1,( x, e11.3 ) ) X X END DO X ELSE X DO i = 1, Nxs X write(*,20) X(I), '&',Y(I) X 20 format(( x, e11.3, x, a1 ), x, e14.8, x, a1) X END DO X END IF X END DO X STOP X END X X X X X SUBROUTINE Interpo(H, N, EquaNum, Work, Nxs, X, Y, TotalAdd) X* CALLED BY: X* driver X* SUBPROGRAMS CALLED: X* Init2Work X* SincMNRD X* i n t e r p o . f X X* This subroutine assumes that newton has already been called and X* that its results have been placed in the work array. X X* ARGUMENT LIST X X* H - DOUBLE PRECISION - This must be the same value as was used on X* the CALL to Newton in order fo the subroutine to correctly X* interpet the values stored in the work array. X X* N - INTEGER - The `size' of the sinc approximation. The total X* number of terms in the approximation is actually 2N + 1. X X* EquaNum - INTEGER - The number of dependent variables to be X* reported. X X* Work - DOUBLE PRECISION array - Containing all intermediate results. X X* Nxs - INTEGER number of independent variable values (e.g., X* x-values) for which the user would like Interpolated values of the X* solution. X X* X(Nxs) - DOUBLE PRECISION array - The independent variable values X* for which the user wants interpolated values of the solution. X X* Y(NumOfEqua, Nxs) - DOUBLE PRECISION array - The interpolated X* values of the dependent variable corresponding to the values X* in X. X X* TotalAdd - INTEGER - Points to the first available free space X* in the work array. X X* CREDITS: X X* This code was written by Michael O'Reilly, Brian Keyes, and X* Kenneth Parker, at the University of Utah, March 20, 1991. It was X* rewritten by Kenneth Parker, Michael O'Reilly, and Brian Keyes, at X* the University of Utah, July 30, 1992. All work was performed X* under the direction of Frank Stenger X X IMPLICIT NONE X X INCLUDE 'workspace.h' X X* This section defines the argument list. X INTEGER N, EquaNum, Nxs, TotalAdd X X DOUBLE PRECISION H X DOUBLE PRECISION Work(*), X(Nxs), Y(Nxs) X X X* This section defines local variables. X INTEGER i, l, ll, YPointer X X DOUBLE PRECISION Check X X* Start of executable code. X l = 2*N+1 X X X* Interpolate the solution at the points X. The assumption is X* that the work array already contains the solution at the sinc points. X X CALL Init2Work( Nxs, X, Work, TotalAdd) X X YPointer = NINT(Work(YPointerPointer + EquaNum)) X DO i = 1, Nxs X Y(i) = (Work(YPointer + 1) + X . Work(RhoPointer + i) * Work(YPointer + 2*N+1)) / X . (1.0D0 + Work(RhoPointer + i)) X CALL SincMNRD(H, -N, N, Work(PhiPointer + i), Work) X X DO ll = 1, 2*N + 1 X Check = Work(YPointer + ll) - X . (Work(YPointer + 1) + X . Work(OffExpKH + ll)*Work(YPointer + 2*N+1)) / X . (1.0D0 + Work(OffExpKH + ll)) X Y(i) = Y(i) + Check * Work(SincPointer + ll) X END DO X END DO X X RETURN X END X X* ----+----------------------------------------------------------------+ X X* m a p . f X X* ----+----------------------------------------------------------------+ X* Phi, Psi, 1/Phi' and Rho associated with the X* conformal map from the real line to the real line used to X* approximate functions that decay algebraically at negative X* infinity and exponentially at infinity. X* CALLED BY: problem_Fun.f in Example 7.4 X* ----+----------------------------------------------------------------+ X DOUBLE PRECISION FUNCTION PhiFun( z ) X X DOUBLE PRECISION z X X PhiFun = DLOG( DSINH( z + DSQRT( 1.0d0 + z*z ) ) ) X X RETURN X END X* ----+----------------------------------------------------------------+ X DOUBLE PRECISION FUNCTION PsiFun( w ) X X DOUBLE PRECISION w X DOUBLE PRECISION t X X t = dlog( dexp( w ) + dsqrt( 1.0d0 + dexp( 2.0d0 * w ) ) ) X X PsiFun = ( t - 1.0d0/t ) / 2.0d0 X X RETURN X END X* ----+----------------------------------------------------------------+ X DOUBLE PRECISION FUNCTION PhiPriRecFun( z ) X X DOUBLE PRECISION z X DOUBLE PRECISION root X X root = DSQRT( 1.0d0 + z*z ) X X PhiPriRecFun = dtanh( z + root ) * root / ( z + root ) X X RETURN X END X* ----+----------------------------------------------------------------+ X DOUBLE PRECISION FUNCTION RhoFun( z ) X X DOUBLE PRECISION z X X RhoFun = dsinh( z + dsqrt( 1.0d0 + z*z ) ) X X RETURN X END X* ----+----------------------------------------------------------------+ X* Phi, Psi, 1/Phi' and Rho associated with the identity X* conformal map from the real line to the real line used to X* approximate functions that decay exponentially at negative X* infinity and exponentially at infinity. X* CALLED BY: problem_Id.f in Example 7.5 X* ----+----------------------------------------------------------------+ X DOUBLE PRECISION FUNCTION PhiId( z ) X X DOUBLE PRECISION z X X PhiId = z X X RETURN X END X* ----+----------------------------------------------------------------+ X DOUBLE PRECISION FUNCTION PsiId( w ) X X DOUBLE PRECISION w X X PsiId = w X X RETURN X END X* ----+----------------------------------------------------------------+ X DOUBLE PRECISION FUNCTION PhiPriRecId( z ) X X DOUBLE PRECISION z X X PhiPriRecId = 1.0d0 X X RETURN X END X* ----+----------------------------------------------------------------+ X DOUBLE PRECISION FUNCTION RhoId( z ) X X DOUBLE PRECISION z X X RhoId = DEXP( z ) X X RETURN X END X* ----+----------------------------------------------------------------+ X* Phi, Psi, 1/Phi' and Rho associated with the conformal X* map from the interval [0,1] to the real line. X* CALLED BY: problem_01.f in Example 7.1 X* ----+----------------------------------------------------------------+ X DOUBLE PRECISION FUNCTION Phi01( z ) X X DOUBLE PRECISION z X X Phi01 = DLOG( z / ( 1.0D0 - z ) ) X X RETURN X END X* ----+----------------------------------------------------------------+ X DOUBLE PRECISION FUNCTION Psi01( w ) X X DOUBLE PRECISION w X X Psi01 = 1.0D0 / ( 1.0D0 + DEXP( - w ) ) X X RETURN X END X* ----+----------------------------------------------------------------+ X DOUBLE PRECISION FUNCTION PhiPriRec01( z ) X X DOUBLE PRECISION z X X PhiPriRec01 = z * ( 1.0D0 - z ) X X RETURN X END X* ----+----------------------------------------------------------------+ X DOUBLE PRECISION FUNCTION Rho01( z ) X X DOUBLE PRECISION z X X Rho01 = z / ( 1.0D0 - z ) X X RETURN X END X* ----+----------------------------------------------------------------+ X* Phi, Psi, 1/Phi' and Rho associated with the conformal X* map from the interval [-1,1] to the real line. X* CALLED BY: problem_N11.f in Example 7.6 X* ----+----------------------------------------------------------------+ X DOUBLE PRECISION FUNCTION PhiN11( z ) X X DOUBLE PRECISION z X X PhiN11 = DLOG( ( 1.0D0 + z ) / ( 1.0D0 - z ) ) X X RETURN X END X* ----+----------------------------------------------------------------+ X DOUBLE PRECISION FUNCTION PsiN11( w ) X X DOUBLE PRECISION w X X PsiN11 = DTANH( w / 2.0D0 ) X X RETURN X END X* ----+----------------------------------------------------------------+ X DOUBLE PRECISION FUNCTION PhiPriRecN11( z ) X X DOUBLE PRECISION z X X PhiPriRecN11 = ( 1.0d0 - z * z ) / 2.0d0 X X RETURN X END X* ----+----------------------------------------------------------------+ X DOUBLE PRECISION FUNCTION RhoN11( z ) X X DOUBLE PRECISION z X X RhoN11 = ( 1.0d0 + z ) / ( 1.0D0 - z ) X X RETURN X END X* ----+----------------------------------------------------------------+ X* Phi, Psi, 1/Phi' and Rho associated with the conformal X* map from the interval [a,b] to the real line. X* CALLED BY: problem_AB.f in Example 7.2 X* problem_ig.f in Example 7.9 X* problem_sg1.f.f in Example 7.11 X* problem_l.f in Example 7.12 X* problem_wg.f in Example 7.13 X* ----+----------------------------------------------------------------+ X DOUBLE PRECISION FUNCTION PhiAB(z,a,b) X X DOUBLE PRECISION a, b, z X X PhiAB = DLOG( ( z - a ) / ( b - z ) ) X X RETURN X END X* ----+----------------------------------------------------------------+ X DOUBLE PRECISION FUNCTION PsiAB(w, a, b) X X DOUBLE PRECISION a, b, w X X PsiAB = (a + b * DEXP(w)) / (1.0D0 + DEXP(w)) X X RETURN X END X* ----+----------------------------------------------------------------+ X DOUBLE PRECISION FUNCTION PhiPriRecAB(z, a, b ) X X DOUBLE PRECISION a, b, z X X PhiPriRecAB = (z - a) * ( b - z ) / (b - a) X X RETURN X END X* ----+----------------------------------------------------------------+ X DOUBLE PRECISION FUNCTION RhoAB(z, a, b) X X DOUBLE PRECISION a, b, z X X RhoAB = (z - a) / (b - z) X X RETURN X END X* ----+----------------------------------------------------------------+ X* Phi, Psi, 1/Phi' and Rho associated with the X* conformal map from the real line to the real line used to X* approximate functions that decay algebraically at negative X* infinity and algebraically at infinity. X* CALLED BY: problem_RR.f in Example 7.7 X* ----+----------------------------------------------------------------+ X DOUBLE PRECISION FUNCTION PhiRR( z ) X X DOUBLE PRECISION z X X PhiRR = DLOG( z + DSQRT( 1.0D0 + z * z ) ) X X RETURN X END X* ----+----------------------------------------------------------------+ X DOUBLE PRECISION FUNCTION PsiRR( z ) X X DOUBLE PRECISION z X X PsiRR = DSINH( z ) X X RETURN X END X* ----+----------------------------------------------------------------+ X DOUBLE PRECISION FUNCTION PhiPriRecRR( z ) X X DOUBLE PRECISION z X X PhiPriRecRR = DSQRT( 1.0D0 + z * z ) X X RETURN X END X* ----+----------------------------------------------------------------+ X DOUBLE PRECISION FUNCTION RhoRR( z ) X X DOUBLE PRECISION z X X RhoRR = z + DSQRT( 1.0D0 + z * z ) X X RETURN X END X* ----+----------------------------------------------------------------+ X* Phi, Psi, 1/Phi' and Rho associated with the X* conformal map from the positive real line to the real line used to X* approximate functions that decay algebraically at the origin X* and exponentially at infinity. X* CALLED BY: problem_Bul.f in Example 7.3 X* ----+----------------------------------------------------------------+ X DOUBLE PRECISION FUNCTION PhiBul( z ) X X DOUBLE PRECISION z X X PhiBul = DLOG( DSINH(z) ) X X RETURN X END X* ----+----------------------------------------------------------------+ X DOUBLE PRECISION FUNCTION PsiBul( w ) X X DOUBLE PRECISION w X X DOUBLE PRECISION a3 X DOUBLE PRECISION a5 X DOUBLE PRECISION a7 X DOUBLE PRECISION a9 X X DOUBLE PRECISION expw X DOUBLE PRECISION expw2 X X a3 = 0.166666666666667D0 X a5 = 0.075000000000000D0 X a7 = 0.044642857142857D0 X a9 = 0.030381944444444 D0 X X expw = DEXP( w ) X expw2 = expw * expw X X IF ( expw .GT. 0.1D0 ) THEN X PsiBul = DLOG( expw + DSQRT( 1.0D0 + expw*expw ) ) X ELSE X PsiBul = ( ( ( ( a9 * expw2 - a7 ) * expw2 + a5 ) * expw2 X . + a3 ) * expw2 + 1.0D0 ) * expw X END IF X X RETURN X END X* ----+----------------------------------------------------------------+ X DOUBLE PRECISION FUNCTION PhiPriRecBul( z ) X X DOUBLE PRECISION z X X PhiPriRecBul = DTANH(z) X X RETURN X END X* ----+----------------------------------------------------------------+ X DOUBLE PRECISION FUNCTION RhoBul( z ) X X DOUBLE PRECISION z X X RhoBul = DSINH(z) X X RETURN X END X* ----+----------------------------------------------------------------+ X* Phi, Psi, 1/Phi' and Rho associated with the X* conformal map from the positive real line to the real line used to X* approximate functions that decay exponentially at the origin X* and exponentially at infinity. X* CALLED BY: problem_Sec.f in Example 7.8 X* problem_g.f in Example 7.10 X* ----+----------------------------------------------------------------+ X DOUBLE PRECISION FUNCTION PhiSec( z ) X X DOUBLE PRECISION z X X PhiSec = DLOG( z ) X X RETURN X END X* ----+----------------------------------------------------------------+ X DOUBLE PRECISION FUNCTION PsiSec( w ) X X DOUBLE PRECISION w X X PsiSec = DEXP( w ) X X RETURN X END X* ----+----------------------------------------------------------------+ X DOUBLE PRECISION FUNCTION PhiPriRecSec( z ) X X DOUBLE PRECISION z X X PhiPriRecSec = z X X RETURN X END X* ----+----------------------------------------------------------------+ X DOUBLE PRECISION FUNCTION RhoSec( z ) X X DOUBLE PRECISION z X X RhoSec = z X X RETURN X END X* ----+----------------------------------------------------------------+ X SUBROUTINE SincMNRD(H, M, N, X, Work) X IMPLICIT NONE X X INCLUDE 'workspace.h' X X* This section defines arguments. X INTEGER M, N X DOUBLE PRECISION H, X, Work(*) X X* This section defines local constants. X DOUBLE PRECISION Pi X PARAMETER ( Pi = 3.141592653589792D0 ) X X DOUBLE PRECISION a0 X PARAMETER( a0 = 1.0D0 ) X X DOUBLE PRECISION a2 X PARAMETER ( a2 = 0.1666666716337204D0 ) X X DOUBLE PRECISION a4 X PARAMETER ( a4 = 0.0083333337679505D0 ) X X DOUBLE PRECISION a6 X PARAMETER ( a6 = 0.0001984127011383D0 ) X X DOUBLE PRECISION a8 X PARAMETER ( a8 = 0.000002755731922D0 ) X X* This section defines local variables. X INTEGER i, ii X DOUBLE PRECISION ww, ww2, sww X X* This is the start of the executable code. X ww = (Pi/H) * (X - DFLOAT(M) * H) X sww = DSIN(ww) X X ii = 0 X DO i = M, N X ii = ii + 1 X X IF ( DABS( ww ) .LE. 0.1 ) THEN X ww2 = ww * ww X Work(SincPointer + ii) = X . (((a8 * ww2 - a6) * ww2 + a4) * ww2 - a2) * ww2 + a0 X ELSE X Work(SincPointer + ii) = sww / ww X END IF X X ww = ww - Pi X sww = -sww X X END DO X X RETURN X END X X INTEGER FUNCTION Newton(H, N, NumOfEqua, InitC, Work, X . TotalAdd, MaxIter ) X X* n e w t o n . f X X* This procedure implements the sinc indefinite integral algorithm. X* It solves to an initial-value problem (IVP) of the form: X X* / X* | X* y = Y0 + | f( x, y) dx X* | X* / X X* by applying Newton's method to the equation, using sinc X* collocation to approximate the integrals. This code X* handles a vector of simultaneous IVP's. Since any system of X* simultaneous first order differential equations (ODE's) whose X* constraints are specified as initial conditions can be expressed as X* indefinite integral equations and since any higher order ODE may X* be represented as a system of first order ODE's, this software can X* handle a vary large class of problems. X X* The accuracy of a solution is governed by the number of "sinc points" X* used in approximating the solution. in the code below the number X* of sinc points = 2*N+1. The expected accuracy of the solution is: X X* Tol = EXP(-C*DSQRT(N)) X X* where Tol is a bound on absolute error between the approximated X* solution and the actual solution. Practical values for N are X* typically from 20 to 50, etc. Using N = 20, typically One should X* expect to 3 to 5 digits of accuracy (i.e., the absolute error should X* be on the order of 10^(3) to 10^(5) ). Using N = 50, One should X* expect to obtain 5 to 8 digits of accuracy. The program has a X* current limit: N < 201. X X* ARGUMENT LIST: X X* H - DOUBLE PRECISION - This is the step size. In some instances X* picking the optimal H can make a significant difference in the X* accuracy of the result, particularly for small N. However, as X* long H is picked as: X X* H = C / sqrt(N) for some C X X* the algorithm will have the appropriate asymptotic accuracy. X X* N - INTEGER - The size of the sinc approximation. The total X* number of terms in the approximation is actually 2N + 1. X X* NumOfEqua - INTEGER - Number of dependent variables in the system X* (i.e., the number of simultaneous IVP's to be solved). X X* InitC(NumOfEqua) - DOUBLE PRECISION array - The Initial values of X* the dependent variables. X X* Work - DOUBLE PRECISION array - Containing all `dynamically' X* allocated intermediate results. X X* TotalAdd - INTEGER - Indicates the amount of space used in Work. X* Probably this is a vestigial parameter ... but I'm making small X* steps. X X* MaxIter - INTEGER - The maximum number of iterations the procedure X* will use in trying to converge. X X* RESULT X X* IF convergence is achieved during the function returns 0. X* Otherwise the result is -1 and the values contained in the work X* array represent the approximation of the last iteration (typically X* of no value). X X* CREDITS: X X* This code was written by Michael O'Reilly, Brian Keyes, and X* Kenneth Parker, at the University of Utah, March 20, 1991. It was X* rewritten by Kenneth Parker, Michael O'Reilly, and Brian Keyes, at X* the University of Utah, July 30, 1992. All work was performed X* under the direction of Frank Stenger X X X IMPLICIT NONE X X INCLUDE 'workspace.h' X X* This section defines the argument list. X INTEGER N, NumOfEqua, TotalAdd, MaxIter X DOUBLE PRECISION H, InitC(*), Work(*) X X* This section defines local constants. X INTEGER UpDateRate, FortranOrder X DOUBLE PRECISION Zero, Pi X X PARAMETER ( UpDateRate = 1 ) X PARAMETER ( FortranOrder = 0 ) X X PARAMETER ( Zero = 0.D0 ) X PARAMETER ( Pi = 3.1415926535897932D0 ) X X* This section defines local variables. X INTEGER i, J, k, EqNum, IdCount, L, Temp2 X INTEGER FunCount, Error, UpDateCount X INTEGER OldYPointer, FPointer, YPointer X X DOUBLE PRECISION Tol, ErrorNorm, Temp1 X X* Start of executable code. X L = 2*N+1 X X* Set the expected absolute Tolerance of the computed solution. X* This number may not be set arbitrarily; it is a function of the X* value of N. X print*,' Number of Sinc-points ', N X Tol = DSQRT(DBLE(N))*DEXP(-Pi*DSQRT(DBLE(N)/2.0D0)) X X WRITE(*,'(/A/)') ' Newton iteration method' X WRITE(*,'(A,G11.3/)') ' Tolerance = ',Tol X X* Use the starting values for the solution. X DO k = 1, NumOfEqua X Work(Y0Pointer + k) = InitC(k) X END DO X X* Start Newton's iteration. X UpDateCount = 0 X IdCount = 0 X FunCount = 0 X ErrorNorm = 2 * Tol X DO WHILE ((IdCount .LT. MaxIter) .AND. (ErrorNorm .GT. Tol)) X X IdCount = IdCount + 1 X PRINT *,' Iteration #: ', IdCount-1 X X* Call the function. X DO i = 1, L X CALL F(NumOfEqua, i, Work) X END DO X FunCount = FunCount + L X X X* Update the jacobian of F if needed. X* And, of course at the same time, update A and the LU decomposition X* of A. X IF (UpDateCount .GT. 0) THEN X UpDateCount = UpDateCount - 1 X ELSE X UpDateCount = UpDateRate - 1 X DO EqNum = 1,L X CALL J_ij(NumOfEqua, EqNum, Work ) X END DO X CALL UpdateA(NumOfEqua, L, H, Work) X CALL dgefa X . (Work(APointer+1), NumOfEqua*(2*N+1), NumOfEqua*(2*N+1), X . Work(APivotPointer+1), Error) X END IF X X* Switch the pointers between the old and new y-values. X Temp2 = YPointerPointer X YPointerPointer = OldYPointerPointer X OldYPointerPointer = Temp2 X X* Update the y-values X* Y_i = Y0_i + h \sum_j \sigma_{j-i} (f_j/\phi_j) X DO k=1,NumOfEqua X YPointer = NINT(Work(YPointerPointer + k)) X FPointer = NINT(Work(FPointerPointer + k)) X X DO i=1,L X Work(YPointer+i) = Zero X X DO J = 1,L X Work(YPointer + i) = Work(YPointer + i) + X . Work(OffSigma + J-i + L) * X . Work(OneOverPhiPrimePointer + J) * Work(FPointer + J) X END DO X X Work(YPointer + i) = Work(Y0Pointer + k) + X . H*Work(YPointer + i) X X END DO X X END DO X X* Set B_i = Y_i - OldY_i X DO k = 1, NumOfEqua X YPointer = NINT(Work(YPointerPointer + k)) X OldYPointer = NINT(Work(OldYPointerPointer + k)) X X DO i = 1,L X Work(BPointer + (k-1)*L+i) = X . Work(YPointer + i) - Work(OldYPointer + i) X END DO X END DO X X* Compute the step (this is the x which satisfies Big_A x = b); X* store the result in b. X CALL dgesl X . (Work(APointer + 1), NumOfEqua*(2*N+1), NumOfEqua*(2*N+1), X . Work(APivotPointer + 1), Work(BPointer + 1), FortranOrder) X X* Update y, i.e., Y = OldY + B. X DO k = 1, NumOfEqua X YPointer = NINT(Work(YPointerPointer + k)) X OldYPointer = NINT(Work(OldYPointerPointer + k)) X X DO i = 1,L X Work(YPointer + i) = X . Work(BPointer + (k-1)*L + i) + Work(OldYPointer + i) X END DO X END DO X X* Check for convergence using the infinity norm, and report the X* error norm. X ErrorNorm = Zero X DO k=1,NumOfEqua X YPointer = NINT(Work(YPointerPointer + k)) X OldYPointer = NINT(Work(OldYPointerPointer + k)) X X DO i = 1,L X Temp1 = DABS(Work(YPointer + i) - Work(OldYPointer + i)) X IF (Temp1 .GT. ErrorNorm) THEN X ErrorNorm = Temp1 X END IF X END DO X END DO X X PRINT 12, ErrorNorm X 12 format(' ErrorNorm= ',D12.3) X* End Newton iteration. X END DO X X* Check to see if procedure converged. X IF (ErrorNorm .LT. Tol) THEN X PRINT *,' The Newton method converged in ', IdCount-1, X +' iterations' X PRINT *,' using ', FunCount, ' function evaluations' X PRINT *,' ' X Newton = 0 X ELSE X PRINT *,' Newton iteration failed to converge for' X PRINT *,' the current value of N within ', IdCount X PRINT *,' iterations.' X Newton = -1 X END IF X X RETURN X END X X X X* ----+----------------------------------------------------------------+ X X* UpdateA X X* This subroutine computes A ... I - h I^{(-1)} D( 1 / \phi') Bij. X X SUBROUTINE UpdateA(NumOfEqua, L, H, Work) X IMPLICIT NONE X X INCLUDE 'workspace.h' X X* This section defines the argument list X INTEGER NumOfEqua, L X DOUBLE PRECISION H, Work(*) X X* This section defines local variables. X INTEGER i, j, k, SubColumn, SubRow, Pos, BijPointer X X* This is the executable code. X Pos = 0 X DO i = 1, NumOfEqua X X DO SubColumn = 1, L X X k = NumOfEqua * (i - 1) X DO j = 1, NumOfEqua X X k = k + 1 X BijPointer = NINT(Work(BijPointerPointer + k)) X X DO SubRow = 1, L X Pos = Pos + 1 X X Work(APointer + Pos) = X . - Work(OffSigma + SubColumn - SubRow + L)*H* X . Work(OneOverPhiPrimePointer + SubColumn) * X . Work(BijPointer + SubColumn) X X IF ((i .EQ. j) .AND. (SubRow .EQ. SubColumn)) THEN X Work(APointer + Pos) = Work(APointer + Pos) + 1 X END IF X X END DO X END DO X X END DO X END DO X X RETURN X END X X* ----+----------------------------------------------------------------+ X X* ----+----------------------------------------------------------------+ X X* Init2Work X X* Initializes the work array with values needed for the interpolation. X X SUBROUTINE Init2Work(Nxs, X, Work, TotalAdd) X IMPLICIT NONE X X INCLUDE 'workspace.h' X X* Functions called X DOUBLE PRECISION Phi X EXTERNAL Phi X DOUBLE PRECISION Rho X EXTERNAL Rho X X* This section defines the argument list. X INTEGER Nxs, TotalAdd X X DOUBLE PRECISION X(*), Work(*) X X* This section defines local variables X INTEGER i, ii, TADD X X* Start of the executable code. X X* Initialize the needed Heap. X PhiPointer = TotalAdd X TADD = TotalAdd + Nxs X RhoPointer = TADD X X ii = 0 X DO i=1,Nxs X ii = ii + 1 X Work(PhiPointer + ii) = Phi(X(ii)) X Work(RhoPointer + ii) = Rho(X(ii)) X END DO X X PRINT *,' ' X PRINT *,' Loading completed.' X X RETURN X END X X X* ----+----------------------------------------------------------------+ X X* Init1Work X X* Initializes the work array with anything to be used in Newton. X* By keeping intermediate results in a work array, the temptation to X* recompute these results is minimized. X X* NOTE: This routine only uses Phi and OneOverPhiPrime from the X* problem specification. X X SUBROUTINE Init1Work(N, NN, H, Work, TotalAdd) X IMPLICIT NONE X X INCLUDE 'workspace.h' X X* Functions called X DOUBLE PRECISION Psi X EXTERNAL Psi X DOUBLE PRECISION OneOverPhiPrime X EXTERNAL OneOverPhiPrime X X* This section defines the argument list. X INTEGER N, NN, TotalAdd X X DOUBLE PRECISION Work(*) X DOUBLE PRECISION H X X* This section defines local constants. X DOUBLE PRECISION Half X PARAMETER ( Half = 0.5D0 ) X X DOUBLE PRECISION Sigma(201) X X INTEGER i X X DATA (SIGMA(I+1),I=0,37) / XC X . 0.0000000000000000E+00, 0.5894898722360839 , X . 0.4514116667901405 , 0.5330932376182722 , X . 0.4749696698836553 , 0.5201071641913087 , X . 0.4832052174977473 , 0.5144159971233055 , X . 0.4873742250578202 , 0.5112301526369977 , X . 0.4898881711538789 , 0.5091957420082168 , X . 0.4915683516686011 , 0.5077846578125663 , X . 0.4927702093748033 , 0.5067486944720118 , X . 0.4936724151782212 , 0.5059559079171770 , X . 0.4943745528336628 , 0.5053297104401591 , X . 0.4949364995706957 , 0.5048226073041721 , X . 0.4953964150848574 , 0.5044035851980506 , X . 0.4957797661366434 , 0.5040515358439449 , X . 0.4961041974885161 , 0.5037515950319094 , X . 0.4963823201653523 , 0.5034929932779406 , X . 0.4966233866311803 , 0.5032677369477720 , X . 0.4968343388552230 , 0.5030697682021877 , X . 0.4970204870276673 , 0.5028944125557015 , X . 0.4971859623359650 , 0.5027380053824386 / X data (sigma(i+1),i=38,75) / X . 0.4973340269269068 , 0.5025976332159279 , X . 0.4974672909775609 , 0.5024709506908217 , X . 0.4975878678043933 , 0.5023560485249016 , X . 0.4976974867059375 , 0.5022513566773183 , X . 0.4977975763910226 , 0.5021555722141233 , X . 0.4978893275646686 , 0.5020676048274522 , X . 0.4979737405030820 , 0.5019865351657797 , X . 0.4980516616563340 , 0.5019115825934454 , X . 0.4981238121215731 , 0.5018420799807533 , X . 0.4981908100179338 , 0.5017774537988254 , X . 0.4982531882343348 , 0.5017172082611159 , X . 0.4983114086292758 , 0.5016609125833092 , X . 0.4983658734834106 , 0.5016081906689419 , X . 0.4984169348055853 , 0.5015587126985118 , X . 0.4984649019474762 , 0.5015121882244937 , X . 0.4985100478749211 , 0.5014683604668267 , X . 0.4985526143645061 , 0.5014270015722505 , X . 0.4985928163343139 , 0.5013879086527001 , X . 0.4986308454725853 , 0.5013509004573851 / X data (sigma(i+1),i=76,95) / X . 0.4986668732935894 , 0.5013158145633707 , X . 0.4987010537234771 , 0.5012825049928007 , X . 0.4987335252983494 , 0.5012508401830422 , X . 0.4987644130407324 , 0.5012207012502380 , X . 0.4987938300680404 , 0.5011919804979528 , X . 0.4988218789766499 , 0.5011645801314821 , X . 0.4988486530372723 , 0.5011384111454787 , X . 0.4988742372309752 , 0.5011133923582401 , X . 0.4988987091500929 , 0.5010894495705807 , X . 0.4989221397841480 , 0.5010665148309350 / X X DATA (SIGMA(I+1),I=96,133) / X . 0.4989445942075478 , 0.5010445257913609 , X . 0.4989661321830883 , 0.5010234251415910 , X . 0.4989868086930457 , 0.5010031601103150 , X . 0.4990066744077986 , 0.5009836820245585 , X . 0.4990257761003836 , 0.5009649459194093 , X . 0.4990441570141277 , 0.5009469101915090 , X . 0.4990618571894377 , 0.5009295362906861 , X . 0.4990789137549436 , 0.5009127884449231 , X . 0.4990953611874528 , 0.5008966334145260 , X . 0.4991112315445431 , 0.5008810402719440 , X . 0.4991265546730973 , 0.5008659802041686 , X . 0.4991413583966329 , 0.5008514263350565 , X . 0.4991556686839016 , 0.5008373535652727 , X . 0.4991695098009059 , 0.5008237384278461 , X . 0.4991829044482064 , 0.5008105589575910 , X . 0.4991958738851533 , 0.5007977945728658 , X . 0.4992084380424717 , 0.5007854259683299 , X . 0.4992206156244573 , 0.5007734350175222 , X . 0.4992324242018795 , 0.5007618046842314 / X data (sigma(i+1),i=134,171) / X . 0.4992438802965679 , 0.5007505189417415 , X . 0.4992549994585343 , 0.5007395626991506 , X . 0.4992657963363902 , 0.5007289217340515 , X . 0.4992762847417280 , 0.5007185826309395 , X . 0.4992864777080626 , 0.5007085327247896 , X . 0.4992963875448610 , 0.5006987600493020 , X . 0.4993060258871316 , 0.5006892532893728 , X . 0.4993154037409938 , 0.5006800017373920 , X . 0.4993245315256009 , 0.5006709952530141 , X . 0.4993334191117545 , 0.5006622242260842 , X . 0.4993420758575095 , 0.5006536795424343 , X . 0.4993505106410414 , 0.5006453525522925 , X . 0.4993587318910163 , 0.5006372350410781 , X . 0.4993667476146842 , 0.5006293192023715 , X . 0.4993745654238911 , 0.5006215976128758 , X . 0.4993821925591876 , 0.5006140632091974 , X . 0.4993896359121953 , 0.5006067092662964 , X . 0.4993969020463755 , 0.5005995293774664 , X . 0.4994039972163319 , 0.5005925174357194 / X data (sigma(i+1),i=172,191) / X . 0.4994109273857661 , 0.5005856676164615 , X . 0.4994176982441967 , 0.5005789743613571 , X . 0.4994243152225357 , 0.5005724323632864 , X . 0.4994307835076177 , 0.5005660365523119 , X . 0.4994371080557585 , 0.5005597820825741 , X . 0.4994432936054206 , 0.5005536643200484 , X . 0.4994493446890528 , 0.5005476788310940 , X . 0.4994552656441658 , 0.5005418213717391 , X . 0.4994610606237005 , 0.5005360878776455 , X . 0.4994667336057422 , 0.5005304744547047 / X X data (sigma(i+1),i=192,200) / X . 0.4994722884026277D0 , 0.5005249773702170D0 , X . 0.4994777286694879D0 , 0.5005195930446155D0 , X . 0.4994830579122687D0 , 0.5005143180436920D0 , X . 0.4994882794952658D0 , 0.5005091490712937D0 , X . 0.4994933966482060D0 / XC X* This section defines local variables. X INTEGER ii, k, kk, m, l, lV, Add X X DOUBLE PRECISION KH X Xc print*,' N: ', N Xc print*,' NN: ', NN Xc print*,' H: ', H X* Start of executable code. X l = 2*N + 1 X lV = 2*l - 1 X Add = 2*N + 1 X X* Set up the work common block. X TotalAdd = 0 X PsiPointer = TotalAdd X TotalAdd = TotalAdd + Add X X OneOverPhiPrimePointer = TotalAdd X TotalAdd = TotalAdd + Add X X OffExpKH = TotalAdd X TotalAdd = TotalAdd + Add X X SincPointer = TotalAdd X TotalAdd = TotalAdd + Add X X YPointerPointer = TotalAdd Xc print*,' YPointerPointer: ', YPointerPointer X TotalAdd = TotalAdd + NN X X OldYPointerPointer = TotalAdd X TotalAdd = TotalAdd + NN X X FPointerPointer = TotalAdd X TotalAdd = TotalAdd + NN X X BijPointerPointer = TotalAdd X TotalAdd = TotalAdd + NN * NN X X APointer = TotalAdd X TotalAdd = TotalAdd + NN*NN*l*l X X BPointer = TotalAdd X TotalAdd = TotalAdd + NN * Add X X APivotPointer = TotalAdd X TotalAdd = TotalAdd + NN * Add X X* Fill in the pointer lists that are stored within the work array. X DO k = 1, NN X Work(YPointerPointer + k) = DBLE(TotalAdd) X TotalAdd = TotalAdd + Add X END DO X X DO k = 1, NN X Work(OldYPointerPointer + k) = DBLE(TotalAdd) X TotalAdd = TotalAdd + Add X END DO X X DO k = 1, NN X Work(FPointerPointer + k) = DBLE(TotalAdd) X TotalAdd = TotalAdd + Add X END DO X X kk = 0 X DO m = 1, NN X DO k = 1, NN X kk = kk + 1 X Work(BijPointerPointer + kk) = DBLE(TotalAdd) X TotalAdd = TotalAdd + Add X END DO X END DO X X Y0Pointer = TotalAdd X TotalAdd = TotalAdd + NN X X OffSigma = TotalAdd X TotalAdd = TotalAdd + 2*l-1 X X* Initialize values in the work common block. X* Compute exp(k*H). X ii = 0 X DO i = -N, N X ii = ii + 1 X KH = DFLOAT(i) * H X Work( OffExpKH + ii ) = DEXP( KH ) X END DO X X* Compute i^{(-1)} and store in the work array. X Work(OffSigma + l) = Half X DO i = l+1, lV X Work(OffSigma + i) = Half - Sigma(i - l + 1) X END DO X X DO i = l-1, 1, -1 X Work(OffSigma + i) = Half + Sigma(l - i + 1) X END DO X X* Load the appropriate values into the work array. This section X* only uses Psi and PhiPriRec for the list of sinc functions. X PRINT *,' ' X PRINT *,' Loading values for the domain.' X X ii = 0 X DO i = -N, N X ii = ii + 1 X KH = DFLOAT(i) * H X Work(PsiPointer + ii) = Psi(KH) X Work(OneOverPhiPrimePointer + ii) = X . OneOverPhiPrime(Work(PsiPointer + ii)) X END DO X X PRINT *,' ' X PRINT *,' Loading completed.' Xc print*,' YPointerPointer: ', YPointerPointer X X RETURN X END X X* ----+----------------------------------------------------------------+ X X SUBROUTINE DGEFA(A,LDA,N,IPVT,INFO) X INTEGER LDA,N,IPVT(1),INFO X DOUBLE PRECISION A(LDA,1) XC XC DGEFA FACTORS A DOUBLE PRECISION MATRIX BY GAUSSIAN ELIMINATION. XC XC DGEFA IS USUALLY CALLED BY DGECO, BUT IT CAN BE CALLED XC DIRECTLY WITH A SAVING IN TIME IF RCOND IS NOT NEEDED. XC (TIME FOR DGECO) = (1 + 9/N)*(TIME FOR DGEFA) . XC XC ON ENTRY XC XC A DOUBLE PRECISION(LDA, N) XC THE MATRIX TO BE FACTORED. XC XC LDA INTEGER XC THE LEADING DIMENSION OF THE ARRAY A . XC XC N INTEGER XC THE ORDER OF THE MATRIX A . XC XC ON RETURN XC XC A AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS XC WHICH WERE USED TO OBTAIN IT. XC THE FACTORIZATION CAN BE WRITTEN A = L*U WHERE XC L IS A PRODUCT OF PERMUTATION AND UNIT LOWER XC TRIANGULAR MATRICES AND U IS UPPER TRIANGULAR. XC XC IPVT INTEGER(N) XC AN INTEGER VECTOR OF PIVOT INDICES. XC XC INFO INTEGER XC = 0 NORMAL VALUE. XC = K IF U(K,K) .EQ. 0.0 . THIS IS NOT AN ERROR XC CONDITION FOR THIS SUBROUTINE, BUT IT DOES XC INDICATE THAT DGESL OR DGEDI WILL DIVIDE BY ZERO XC IF CALLED. USE RCOND IN DGECO FOR A RELIABLE XC INDICATION OF SINGULARITY. XC XC LINPACK. THIS VERSION DATED 08/14/78 . XC CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. XC XC SUBROUTINES AND FUNCTIONS XC XC BLAS DAXPY,DSCAL,IDAMAX XC XC INTERNAL VARIABLES XC X DOUBLE PRECISION T X INTEGER IDAMAX,J,K,KP1,L,NM1 XC XC XC GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING XC X INFO = 0 X NM1 = N - 1 X IF (NM1 .LT. 1) GO TO 70 X DO 60 K = 1, NM1 X KP1 = K + 1 XC XC FIND L = PIVOT INDEX XC X L = IDAMAX(N-K+1,A(K,K),1) + K - 1 X IPVT(K) = L XC XC ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED XC X IF (A(L,K) .EQ. 0.0D0) GO TO 40 XC XC INTERCHANGE IF NECESSARY XC X IF (L .EQ. K) GO TO 10 X T = A(L,K) X A(L,K) = A(K,K) X A(K,K) = T X 10 CONTINUE XC XC COMPUTE MULTIPLIERS XC X T = -1.0D0/A(K,K) X CALL DSCAL(N-K,T,A(K+1,K),1) XC XC ROW ELIMINATION WITH COLUMN INDEXING XC X DO 30 J = KP1, N X T = A(L,J) X IF (L .EQ. K) GO TO 20 X A(L,J) = A(K,J) X A(K,J) = T X 20 CONTINUE X CALL DAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1) X 30 CONTINUE X GO TO 50 X 40 CONTINUE X INFO = K X 50 CONTINUE X 60 CONTINUE X 70 CONTINUE X IPVT(N) = N X IF (A(N,N) .EQ. 0.0D0) INFO = N X RETURN X END X X SUBROUTINE DGESL(A,LDA,N,IPVT,B,JOB) X INTEGER LDA,N,IPVT(1),JOB X DOUBLE PRECISION A(LDA,1),B(1) XC XC DGESL SOLVES THE DOUBLE PRECISION SYSTEM XC A * X = B OR TRANS(A) * X = B XC USING THE FACTORS COMPUTED BY DGECO OR DGEFA. XC XC ON ENTRY XC XC A DOUBLE PRECISION(LDA, N) XC THE OUTPUT FROM DGECO OR DGEFA. XC XC LDA INTEGER XC THE LEADING DIMENSION OF THE ARRAY A . XC XC N INTEGER XC THE ORDER OF THE MATRIX A . XC XC IPVT INTEGER(N) XC THE PIVOT VECTOR FROM DGECO OR DGEFA. XC XC B DOUBLE PRECISION(N) XC THE RIGHT HAND SIDE VECTOR. XC XC JOB INTEGER XC = 0 TO SOLVE A*X = B , XC = NONZERO TO SOLVE TRANS(A)*X = B WHERE XC TRANS(A) IS THE TRANSPOSE. XC XC ON RETURN XC XC B THE SOLUTION VECTOR X . XC XC ERROR CONDITION XC XC A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A XC ZERO ON THE DIAGONAL. TECHNICALLY THIS INDICATES SINGULARITY XC BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER XC SETTING OF LDA . IT WILL NOT OCCUR IF THE SUBROUTINES ARE XC CALLED CORRECTLY AND IF DGECO HAS SET RCOND .GT. 0.0 XC OR DGEFA HAS SET INFO .EQ. 0 . XC XC TO COMPUTE INVERSE(A) * C WHERE C IS A MATRIX XC WITH P COLUMNS XC CALL DGECO(A,LDA,N,IPVT,RCOND,Z) XC IF (RCOND IS TOO SMALL) GO TO ... XC DO 10 J = 1, P XC CALL DGESL(A,LDA,N,IPVT,C(1,J),0) XC 10 CONTINUE XC XC LINPACK. THIS VERSION DATED 08/14/78 . XC CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. XC XC SUBROUTINES AND FUNCTIONS XC XC BLAS DAXPY,DDOT XC XC INTERNAL VARIABLES XC X DOUBLE PRECISION DDOT,T X INTEGER K,KB,L,NM1 XC X NM1 = N - 1 X IF (JOB .NE. 0) GO TO 50 XC XC JOB = 0 , SOLVE A * X = B XC FIRST SOLVE L*Y = B XC X IF (NM1 .LT. 1) GO TO 30 X DO 20 K = 1, NM1 X L = IPVT(K) X T = B(L) X IF (L .EQ. K) GO TO 10 X B(L) = B(K) X B(K) = T X 10 CONTINUE X CALL DAXPY(N-K,T,A(K+1,K),1,B(K+1),1) X 20 CONTINUE X 30 CONTINUE XC XC NOW SOLVE U*X = Y XC X DO 40 KB = 1, N X K = N + 1 - KB X B(K) = B(K)/A(K,K) X T = -B(K) X CALL DAXPY(K-1,T,A(1,K),1,B(1),1) X 40 CONTINUE X GO TO 100 X 50 CONTINUE XC XC JOB = NONZERO, SOLVE TRANS(A) * X = B XC FIRST SOLVE TRANS(U)*Y = B XC X DO 60 K = 1, N X T = DDOT(K-1,A(1,K),1,B(1),1) X B(K) = (B(K) - T)/A(K,K) X 60 CONTINUE XC XC NOW SOLVE TRANS(L)*X = Y XC X IF (NM1 .LT. 1) GO TO 90 X DO 80 KB = 1, NM1 X K = N - KB X B(K) = B(K) + DDOT(N-K,A(K+1,K),1,B(K+1),1) X L = IPVT(K) X IF (L .EQ. K) GO TO 70 X T = B(L) X B(L) = B(K) X B(K) = T X 70 CONTINUE X 80 CONTINUE X 90 CONTINUE X 100 CONTINUE X RETURN X END X DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) XC XC FORMS THE DOT PRODUCT OF TWO VECTORS. XC USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE. XC JACK DONGARRA, LINPACK, 3/11/78. XC X DOUBLE PRECISION DX(1),DY(1),DTEMP X INTEGER I,INCX,INCY,IX,IY,M,MP1,N XC X DDOT = 0.0D0 X DTEMP = 0.0D0 X IF(N.LE.0)RETURN X IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 XC XC CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS XC NOT EQUAL TO 1 XC X IX = 1 X IY = 1 X IF(INCX.LT.0)IX = (-N+1)*INCX + 1 X IF(INCY.LT.0)IY = (-N+1)*INCY + 1 X DO 10 I = 1,N X DTEMP = DTEMP + DX(IX)*DY(IY) X IX = IX + INCX X IY = IY + INCY X 10 CONTINUE X DDOT = DTEMP X RETURN XC XC CODE FOR BOTH INCREMENTS EQUAL TO 1 XC XC XC CLEAN-UP LOOP XC X 20 M = MOD(N,5) X IF( M .EQ. 0 ) GO TO 40 X DO 30 I = 1,M X DTEMP = DTEMP + DX(I)*DY(I) X 30 CONTINUE X IF( N .LT. 5 ) GO TO 60 X 40 MP1 = M + 1 X DO 50 I = MP1,N,5 X DTEMP = DTEMP + DX(I)*DY(I) + DX(I + 1)*DY(I + 1) + X * DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4) X 50 CONTINUE X 60 DDOT = DTEMP X RETURN X END X SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) XC XC CONSTANT TIMES A VECTOR PLUS A VECTOR. XC USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE. XC JACK DONGARRA, LINPACK, 3/11/78. XC X DOUBLE PRECISION DX(1),DY(1),DA X INTEGER I,IX,IY,INCX,INCY,M,MP1,N XC X IF(N.LE.0)RETURN X IF (DA .EQ. 0.0D0) RETURN X IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 XC XC CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS XC NOT EQUAL TO 1 XC X IX = 1 X IY = 1 X IF(INCX.LT.0)IX = (-N+1)*INCX + 1 X IF(INCY.LT.0)IY = (-N+1)*INCY + 1 X DO 10 I = 1,N X DY(IY) = DY(IY) + DA*DX(IX) X IX = IX + INCX X IY = IY + INCY X 10 CONTINUE X RETURN XC XC CODE FOR BOTH INCREMENTS EQUAL TO 1 XC XC XC CLEAN-UP LOOP XC X 20 M = MOD(N,4) X IF( M .EQ. 0 ) GO TO 40 X DO 30 I = 1,M X DY(I) = DY(I) + DA*DX(I) X 30 CONTINUE X IF( N .LT. 4 ) RETURN X 40 MP1 = M + 1 X DO 50 I = MP1,N,4 X DY(I) = DY(I) + DA*DX(I) X DY(I + 1) = DY(I + 1) + DA*DX(I + 1) X DY(I + 2) = DY(I + 2) + DA*DX(I + 2) X DY(I + 3) = DY(I + 3) + DA*DX(I + 3) X 50 CONTINUE X RETURN X END X SUBROUTINE DSCAL(N,DA,DX,INCX) XC XC SCALES A VECTOR BY A CONSTANT. XC USES UNROLLED LOOPS FOR INCREMENT EQUAL TO ONE. XC JACK DONGARRA, LINPACK, 3/11/78. XC X DOUBLE PRECISION DA,DX(1) X INTEGER I,INCX,M,MP1,N,NINCX XC X IF(N.LE.0)RETURN X IF(INCX.EQ.1)GO TO 20 XC XC CODE FOR INCREMENT NOT EQUAL TO 1 XC X NINCX = N*INCX X DO 10 I = 1,NINCX,INCX X DX(I) = DA*DX(I) X 10 CONTINUE X RETURN XC XC CODE FOR INCREMENT EQUAL TO 1 XC XC XC CLEAN-UP LOOP XC X 20 M = MOD(N,5) X IF( M .EQ. 0 ) GO TO 40 X DO 30 I = 1,M X DX(I) = DA*DX(I) X 30 CONTINUE X IF( N .LT. 5 ) RETURN X 40 MP1 = M + 1 X DO 50 I = MP1,N,5 X DX(I) = DA*DX(I) X DX(I + 1) = DA*DX(I + 1) X DX(I + 2) = DA*DX(I + 2) X DX(I + 3) = DA*DX(I + 3) X DX(I + 4) = DA*DX(I + 4) X 50 CONTINUE X RETURN X END X INTEGER FUNCTION IDAMAX(N,DX,INCX) XC XC FINDS THE INDEX OF ELEMENT HAVING MAX. ABSOLUTE VALUE. XC JACK DONGARRA, LINPACK, 3/11/78. XC X DOUBLE PRECISION DX(1),DMAX X INTEGER I,INCX,IX,N XC X IDAMAX = 0 X IF( N .LT. 1 ) RETURN X IDAMAX = 1 X IF(N.EQ.1)RETURN X IF(INCX.EQ.1)GO TO 20 XC XC CODE FOR INCREMENT NOT EQUAL TO 1 XC X IX = 1 X DMAX = DABS(DX(1)) X IX = IX + INCX X DO 10 I = 2,N X IF(DABS(DX(IX)).LE.DMAX) GO TO 5 X IDAMAX = I X DMAX = DABS(DX(IX)) X 5 IX = IX + INCX X 10 CONTINUE X RETURN XC XC CODE FOR INCREMENT EQUAL TO 1 XC X 20 DMAX = DABS(DX(1)) X DO 30 I = 2,N X IF(DABS(DX(I)).LE.DMAX) GO TO 30 X IDAMAX = I X DMAX = DABS(DX(I)) X 30 CONTINUE X RETURN X END X X SUBROUTINE DGECO(A,LDA,N,IPVT,RCOND,Z) X INTEGER LDA,N,IPVT(1) X DOUBLE PRECISION A(LDA,1),Z(1) X DOUBLE PRECISION RCOND XC XC DGECO FACTORS A DOUBLE PRECISION MATRIX BY GAUSSIAN ELIMINATION XC AND ESTIMATES THE CONDITION OF THE MATRIX. XC XC IF RCOND IS NOT NEEDED, DGEFA IS SLIGHTLY FASTER. XC TO SOLVE A*X = B , FOLLOW DGECO BY DGESL. XC TO COMPUTE INVERSE(A)*C , FOLLOW DGECO BY DGESL. XC TO COMPUTE DETERMINANT(A) , FOLLOW DGECO BY DGEDI. XC TO COMPUTE INVERSE(A) , FOLLOW DGECO BY DGEDI. XC XC ON ENTRY XC XC A DOUBLE PRECISION(LDA, N) XC THE MATRIX TO BE FACTORED. XC XC LDA INTEGER XC THE LEADING DIMENSION OF THE ARRAY A . XC XC N INTEGER XC THE ORDER OF THE MATRIX A . XC XC ON RETURN XC XC A AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS XC WHICH WERE USED TO OBTAIN IT. XC THE FACTORIZATION CAN BE WRITTEN A = L*U WHERE XC L IS A PRODUCT OF PERMUTATION AND UNIT LOWER XC TRIANGULAR MATRICES AND U IS UPPER TRIANGULAR. XC XC IPVT INTEGER(N) XC AN INTEGER VECTOR OF PIVOT INDICES. XC XC RCOND DOUBLE PRECISION XC AN ESTIMATE OF THE RECIPROCAL CONDITION OF A . XC FOR THE SYSTEM A*X = B , RELATIVE PERTURBATIONS XC IN A AND B OF SIZE EPSILON MAY CAUSE XC RELATIVE PERTURBATIONS IN X OF SIZE EPSILON/RCOND . XC IF RCOND IS SO SMALL THAT THE LOGICAL EXPRESSION XC 1.0 + RCOND .EQ. 1.0 XC IS TRUE, THEN A MAY BE SINGULAR TO WORKING XC PRECISION. IN PARTICULAR, RCOND IS ZERO IF XC EXACT SINGULARITY IS DETECTED OR THE ESTIMATE XC UNDERFLOWS. XC XC Z DOUBLE PRECISION(N) XC A WORK VECTOR WHOSE CONTENTS ARE USUALLY UNIMPORTANT. XC IF A IS CLOSE TO A SINGULAR MATRIX, THEN Z IS XC AN APPROXIMATE NULL VECTOR IN THE SENSE THAT XC NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . XC XC LINPACK. THIS VERSION DATED 08/14/78 . XC CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. XC XC SUBROUTINES AND FUNCTIONS XC XC LINPACK DGEFA XC BLAS DAXPY,DDOT,DSCAL,DASUM XC FORTRAN DABS,DMAX1,DSIGN XC XC INTERNAL VARIABLES XC X DOUBLE PRECISION DDOT,EK,T,WK,WKM X DOUBLE PRECISION ANORM,S,DASUM,SM,YNORM X INTEGER INFO,J,K,KB,KP1,L XC XC XC COMPUTE 1-NORM OF A XC X ANORM = 0.0D0 X DO 10 J = 1, N X ANORM = DMAX1(ANORM,DASUM(N,A(1,J),1)) X 10 CONTINUE XC XC FACTOR XC X CALL DGEFA(A,LDA,N,IPVT,INFO) XC XC RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . XC ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND TRANS(A)*Y = E . XC TRANS(A) IS THE TRANSPOSE OF A . THE COMPONENTS OF E ARE XC CHOSEN TO CAUSE MAXIMUM LOCAL GROWTH IN THE ELEMENTS OF W WHERE XC TRANS(U)*W = E . THE VECTORS ARE FREQUENTLY RESCALED TO AVOID XC OVERFLOW. XC XC SOLVE TRANS(U)*W = E XC X EK = 1.0D0 X DO 20 J = 1, N X Z(J) = 0.0D0 X 20 CONTINUE X DO 100 K = 1, N X IF (Z(K) .NE. 0.0D0) EK = DSIGN(EK,-Z(K)) X IF (DABS(EK-Z(K)) .LE. DABS(A(K,K))) GO TO 30 X S = DABS(A(K,K))/DABS(EK-Z(K)) X CALL DSCAL(N,S,Z,1) X EK = S*EK X 30 CONTINUE X WK = EK - Z(K) X WKM = -EK - Z(K) X S = DABS(WK) X SM = DABS(WKM) X IF (A(K,K) .EQ. 0.0D0) GO TO 40 X WK = WK/A(K,K) X WKM = WKM/A(K,K) X GO TO 50 X 40 CONTINUE X WK = 1.0D0 X WKM = 1.0D0 X 50 CONTINUE X KP1 = K + 1 X IF (KP1 .GT. N) GO TO 90 X DO 60 J = KP1, N X SM = SM + DABS(Z(J)+WKM*A(K,J)) X Z(J) = Z(J) + WK*A(K,J) X S = S + DABS(Z(J)) X 60 CONTINUE X IF (S .GE. SM) GO TO 80 X T = WKM - WK X WK = WKM X DO 70 J = KP1, N X Z(J) = Z(J) + T*A(K,J) X 70 CONTINUE X 80 CONTINUE X 90 CONTINUE X Z(K) = WK X 100 CONTINUE X S = 1.0D0/DASUM(N,Z,1) X CALL DSCAL(N,S,Z,1) XC XC SOLVE TRANS(L)*Y = W XC X DO 120 KB = 1, N X K = N + 1 - KB X IF (K .LT. N) Z(K) = Z(K) + DDOT(N-K,A(K+1,K),1,Z(K+1),1) X IF (DABS(Z(K)) .LE. 1.0D0) GO TO 110 X S = 1.0D0/DABS(Z(K)) X CALL DSCAL(N,S,Z,1) X 110 CONTINUE X L = IPVT(K) X T = Z(L) X Z(L) = Z(K) X Z(K) = T X 120 CONTINUE X S = 1.0D0/DASUM(N,Z,1) X CALL DSCAL(N,S,Z,1) XC X YNORM = 1.0D0 XC XC SOLVE L*V = Y XC X DO 140 K = 1, N X L = IPVT(K) X T = Z(L) X Z(L) = Z(K) X Z(K) = T X IF (K .LT. N) CALL DAXPY(N-K,T,A(K+1,K),1,Z(K+1),1) X IF (DABS(Z(K)) .LE. 1.0D0) GO TO 130 X S = 1.0D0/DABS(Z(K)) X CALL DSCAL(N,S,Z,1) X YNORM = S*YNORM X 130 CONTINUE X 140 CONTINUE X S = 1.0D0/DASUM(N,Z,1) X CALL DSCAL(N,S,Z,1) X YNORM = S*YNORM XC XC SOLVE U*Z = V XC X DO 160 KB = 1, N X K = N + 1 - KB X IF (DABS(Z(K)) .LE. DABS(A(K,K))) GO TO 150 X S = DABS(A(K,K))/DABS(Z(K)) X CALL DSCAL(N,S,Z,1) X YNORM = S*YNORM X 150 CONTINUE X IF (A(K,K) .NE. 0.0D0) Z(K) = Z(K)/A(K,K) X IF (A(K,K) .EQ. 0.0D0) Z(K) = 1.0D0 X T = -Z(K) X CALL DAXPY(K-1,T,A(1,K),1,Z(1),1) X 160 CONTINUE XC MAKE ZNORM = 1.0 X S = 1.0D0/DASUM(N,Z,1) X CALL DSCAL(N,S,Z,1) X YNORM = S*YNORM XC X IF (ANORM .NE. 0.0D0) RCOND = YNORM/ANORM X IF (ANORM .EQ. 0.0D0) RCOND = 0.0D0 X RETURN X END X DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX) XC XC TAKES THE SUM OF THE ABSOLUTE VALUES. XC JACK DONGARRA, LINPACK, 3/11/78. XC X DOUBLE PRECISION DX(1),DTEMP X INTEGER I,INCX,M,MP1,N,NINCX XC X DASUM = 0.0D0 X DTEMP = 0.0D0 X IF(N.LE.0)RETURN X IF(INCX.EQ.1)GO TO 20 XC XC CODE FOR INCREMENT NOT EQUAL TO 1 XC X NINCX = N*INCX X DO 10 I = 1,NINCX,INCX X DTEMP = DTEMP + DABS(DX(I)) X 10 CONTINUE X DASUM = DTEMP X RETURN XC XC CODE FOR INCREMENT EQUAL TO 1 XC XC XC CLEAN-UP LOOP XC X 20 M = MOD(N,6) X IF( M .EQ. 0 ) GO TO 40 X DO 30 I = 1,M X DTEMP = DTEMP + DABS(DX(I)) X 30 CONTINUE X IF( N .LT. 6 ) GO TO 60 X 40 MP1 = M + 1 X DO 50 I = MP1,N,6 X DTEMP = DTEMP + DABS(DX(I)) + DABS(DX(I + 1)) + DABS(DX(I + 2)) X * + DABS(DX(I + 3)) + DABS(DX(I + 4)) + DABS(DX(I + 5)) X 50 CONTINUE X 60 DASUM = DTEMP X RETURN X END X SUBROUTINE CALJY0(ARG,RESULT,JINT) XC--------------------------------------------------------------------- XC XC This packet computes zero-order Bessel functions of the first and XC second kind (J0 and Y0), for real arguments X, where 0 < X <= XMAX XC for Y0, and |X| <= XMAX for J0. It contains two function-type XC subprograms, BESJ0 and BESY0, and one subroutine-type XC subprogram, CALJY0. The calling statements for the primary XC entries are: XC XC Y = BESJ0(X) XC and XC Y = BESY0(X), XC XC where the entry points correspond to the functions J0(X) and Y0(X), XC respectively. The routine CALJY0 is intended for internal packet XC use only, all computations within the packet being concentrated in XC this one routine. The function subprograms invoke CALJY0 with XC the statement XC CALL CALJY0(ARG,RESULT,JINT), XC where the parameter usage is as follows: XC XC Function Parameters for CALJY0 XC call ARG RESULT JINT XC XC BESJ0(ARG) |ARG| .LE. XMAX J0(ARG) 0 XC BESY0(ARG) 0 .LT. ARG .LE. XMAX Y0(ARG) 1 XC XC The main computation uses unpublished minimax rational XC approximations for X .LE. 8.0, and an approximation from the XC book Computer Approximations by Hart, et. al., Wiley and Sons, XC New York, 1968, for arguments larger than 8.0 Part of this XC transportable packet is patterned after the machine-dependent XC FUNPACK program BESJ0(X), but cannot match that version for XC efficiency or accuracy. This version uses rational functions XC that are theoretically accurate to at least 18 significant decimal XC digits for X <= 8, and at least 18 decimal places for X > 8. The XC accuracy achieved depends on the arithmetic system, the compiler, XC the intrinsic functions, and proper selection of the machine- XC dependent constants. XC XC******************************************************************* XC XC Explanation of machine-dependent constants XC XC XINF = largest positive machine number XC XMAX = largest acceptable argument. The functions AINT, SIN XC and COS must perform properly for ABS(X) .LE. XMAX. XC We recommend that XMAX be a small integer multiple of XC sqrt(1/eps), where eps is the smallest positive number XC such that 1+eps > 1. XC XSMALL = positive argument such that 1.0-(X/2)**2 = 1.0 XC to machine precision for all ABS(X) .LE. XSMALL. XC We recommend that XSMALL < sqrt(eps)/beta, where beta XC is the floating-point radix (usually 2 or 16). XC XC Approximate values for some important machines are XC XC eps XMAX XSMALL XINF XC XC CDC 7600 (S.P.) 7.11E-15 1.34E+08 2.98E-08 1.26E+322 XC CRAY-1 (S.P.) 7.11E-15 1.34E+08 2.98E-08 5.45E+2465 XC IBM PC (8087) (S.P.) 5.96E-08 8.19E+03 1.22E-04 3.40E+38 XC IBM PC (8087) (D.P.) 1.11D-16 2.68D+08 3.72D-09 1.79D+308 XC IBM 195 (D.P.) 2.22D-16 6.87D+09 9.09D-13 7.23D+75 XC UNIVAC 1108 (D.P.) 1.73D-18 4.30D+09 2.33D-10 8.98D+307 XC VAX 11/780 (D.P.) 1.39D-17 1.07D+09 9.31D-10 1.70D+38 XC XC******************************************************************* XC******************************************************************* XC XC Error Returns XC XC The program returns the value zero for X .GT. XMAX, and returns XC -XINF when BESLY0 is called with a negative or zero argument. XC XC XC Intrinsic functions required are: XC XC ABS, AINT, COS, LOG, SIN, SQRT XC XC XC Latest modification: June 2, 1989 XC XC Author: W. J. Cody XC Mathematics and Computer Science Division XC Argonne National Laboratory XC Argonne, IL 60439 XC XC-------------------------------------------------------------------- X INTEGER I,JINT XCS REAL X DOUBLE PRECISION X 1 ARG,AX,CONS,DOWN,EIGHT,FIVE5,FOUR,ONE,ONEOV8,PI2,PJ0, X 2 PJ1,PLG,PROD,PY0,PY1,PY2,P0,P1,P17,QJ0,QJ1,QLG,QY0,QY1, X 3 QY2,Q0,Q1,RESJ,RESULT,R0,R1,SIXTY4,THREE,TWOPI,TWOPI1, X 4 TWOPI2,TWO56,UP,W,WSQ,XDEN,XINF,XMAX,XNUM,XSMALL,XJ0, X 5 XJ1,XJ01,XJ02,XJ11,XJ12,XY,XY0,XY01,XY02,XY1,XY11,XY12, X 6 XY2,XY21,XY22,Z,ZERO,ZSQ X DIMENSION PJ0(7),PJ1(8),PLG(4),PY0(6),PY1(7),PY2(8),P0(6),P1(6), X 1 QJ0(5),QJ1(7),QLG(4),QY0(5),QY1(6),QY2(7),Q0(5),Q1(5) XC------------------------------------------------------------------- XC Mathematical constants XC CONS = ln(.5) + Euler's gamma XC------------------------------------------------------------------- XCS DATA ZERO,ONE,THREE,FOUR,EIGHT/0.0E0,1.0E0,3.0E0,4.0E0,8.0E0/, XCS 1 FIVE5,SIXTY4,ONEOV8,P17/5.5E0,64.0E0,0.125E0,1.716E-1/, XCS 2 TWO56,CONS/256.0E0,-1.1593151565841244881E-1/, XCS 3 PI2,TWOPI/6.3661977236758134308E-1,6.2831853071795864769E0/, XCS 4 TWOPI1,TWOPI2/6.28125E0,1.9353071795864769253E-3/ X DATA ZERO,ONE,THREE,FOUR,EIGHT/0.0D0,1.0D0,3.0D0,4.0D0,8.0D0/, X 1 FIVE5,SIXTY4,ONEOV8,P17/5.5D0,64.0D0,0.125D0,1.716D-1/, X 2 TWO56,CONS/256.0D0,-1.1593151565841244881D-1/, X 3 PI2,TWOPI/6.3661977236758134308D-1,6.2831853071795864769D0/, X 4 TWOPI1,TWOPI2/6.28125D0,1.9353071795864769253D-3/ XC------------------------------------------------------------------- XC Machine-dependent constants XC------------------------------------------------------------------- XCS DATA XMAX/8.19E+03/,XSMALL/1.22E-09/,XINF/1.7E+38/ X DATA XMAX/1.07D+09/,XSMALL/9.31D-10/,XINF/1.7D+38/ XC------------------------------------------------------------------- XC Zeroes of Bessel functions XC------------------------------------------------------------------- XCS DATA XJ0/2.4048255576957727686E+0/,XJ1/5.5200781102863106496E+0/, XCS 1 XY0/8.9357696627916752158E-1/,XY1/3.9576784193148578684E+0/, XCS 2 XY2/7.0860510603017726976E+0/, XCS 3 XJ01/ 616.0E+0/, XJ02/-1.4244423042272313784E-03/, XCS 4 XJ11/1413.0E+0/, XJ12/ 5.4686028631064959660E-04/, XCS 5 XY01/ 228.0E+0/, XY02/ 2.9519662791675215849E-03/, XCS 6 XY11/1013.0E+0/, XY12/ 6.4716931485786837568E-04/, XCS 7 XY21/1814.0E+0/, XY22/ 1.1356030177269762362E-04/ X DATA XJ0/2.4048255576957727686D+0/,XJ1/5.5200781102863106496D+0/, X 1 XY0/8.9357696627916752158D-1/,XY1/3.9576784193148578684D+0/, X 2 XY2/7.0860510603017726976D+0/, X 3 XJ01/ 616.0D+0/, XJ02/-1.4244423042272313784D-03/, X 4 XJ11/1413.0D+0/, XJ12/ 5.4686028631064959660D-04/, X 5 XY01/ 228.0D+0/, XY02/ 2.9519662791675215849D-03/, X 6 XY11/1013.0D+0/, XY12/ 6.4716931485786837568D-04/, X 7 XY21/1814.0D+0/, XY22/ 1.1356030177269762362D-04/ XC------------------------------------------------------------------- XC Coefficients for rational approximation to ln(x/a) XC-------------------------------------------------------------------- XCS DATA PLG/-2.4562334077563243311E+01,2.3642701335621505212E+02, XCS 1 -5.4989956895857911039E+02,3.5687548468071500413E+02/ XCS DATA QLG/-3.5553900764052419184E+01,1.9400230218539473193E+02, XCS 1 -3.3442903192607538956E+02,1.7843774234035750207E+02/ X DATA PLG/-2.4562334077563243311D+01,2.3642701335621505212D+02, X 1 -5.4989956895857911039D+02,3.5687548468071500413D+02/ X DATA QLG/-3.5553900764052419184D+01,1.9400230218539473193D+02, X 1 -3.3442903192607538956D+02,1.7843774234035750207D+02/ XC------------------------------------------------------------------- XC Coefficients for rational approximation of XC J0(X) / (X**2 - XJ0**2), XSMALL < |X| <= 4.0 XC-------------------------------------------------------------------- XCS DATA PJ0/6.6302997904833794242E+06,-6.2140700423540120665E+08, XCS 1 2.7282507878605942706E+10,-4.1298668500990866786E+11, XCS 2 -1.2117036164593528341E-01, 1.0344222815443188943E+02, XCS 3 -3.6629814655107086448E+04/ XCS DATA QJ0/4.5612696224219938200E+05, 1.3985097372263433271E+08, XCS 1 2.6328198300859648632E+10, 2.3883787996332290397E+12, XCS 2 9.3614022392337710626E+02/ X DATA PJ0/6.6302997904833794242D+06,-6.2140700423540120665D+08, X 1 2.7282507878605942706D+10,-4.1298668500990866786D+11, X 2 -1.2117036164593528341D-01, 1.0344222815443188943D+02, X 3 -3.6629814655107086448D+04/ X DATA QJ0/4.5612696224219938200D+05, 1.3985097372263433271D+08, X 1 2.6328198300859648632D+10, 2.3883787996332290397D+12, X 2 9.3614022392337710626D+02/ XC------------------------------------------------------------------- XC Coefficients for rational approximation of XC J0(X) / (X**2 - XJ1**2), 4.0 < |X| <= 8.0 XC------------------------------------------------------------------- XCS DATA PJ1/4.4176707025325087628E+03, 1.1725046279757103576E+04, XCS 1 1.0341910641583726701E+04,-7.2879702464464618998E+03, XCS 2 -1.2254078161378989535E+04,-1.8319397969392084011E+03, XCS 3 4.8591703355916499363E+01, 7.4321196680624245801E+02/ XCS DATA QJ1/3.3307310774649071172E+02,-2.9458766545509337327E+03, XCS 1 1.8680990008359188352E+04,-8.4055062591169562211E+04, XCS 2 2.4599102262586308984E+05,-3.5783478026152301072E+05, XCS 3 -2.5258076240801555057E+01/ X DATA PJ1/4.4176707025325087628D+03, 1.1725046279757103576D+04, X 1 1.0341910641583726701D+04,-7.2879702464464618998D+03, X 2 -1.2254078161378989535D+04,-1.8319397969392084011D+03, X 3 4.8591703355916499363D+01, 7.4321196680624245801D+02/ X DATA QJ1/3.3307310774649071172D+02,-2.9458766545509337327D+03, X 1 1.8680990008359188352D+04,-8.4055062591169562211D+04, X 2 2.4599102262586308984D+05,-3.5783478026152301072D+05, X 3 -2.5258076240801555057D+01/ XC------------------------------------------------------------------- XC Coefficients for rational approximation of XC (Y0(X) - 2 LN(X/XY0) J0(X)) / (X**2 - XY0**2), XC XSMALL < |X| <= 3.0 XC-------------------------------------------------------------------- XCS DATA PY0/1.0102532948020907590E+04,-2.1287548474401797963E+06, XCS 1 2.0422274357376619816E+08,-8.3716255451260504098E+09, XCS 2 1.0723538782003176831E+11,-1.8402381979244993524E+01/ XCS DATA QY0/6.6475986689240190091E+02, 2.3889393209447253406E+05, XCS 1 5.5662956624278251596E+07, 8.1617187777290363573E+09, XCS 2 5.8873865738997033405E+11/ X DATA PY0/1.0102532948020907590D+04,-2.1287548474401797963D+06, X 1 2.0422274357376619816D+08,-8.3716255451260504098D+09, X 2 1.0723538782003176831D+11,-1.8402381979244993524D+01/ X DATA QY0/6.6475986689240190091D+02, 2.3889393209447253406D+05, X 1 5.5662956624278251596D+07, 8.1617187777290363573D+09, X 2 5.8873865738997033405D+11/ XC------------------------------------------------------------------- XC Coefficients for rational approximation of XC (Y0(X) - 2 LN(X/XY1) J0(X)) / (X**2 - XY1**2), XC 3.0 < |X| <= 5.5 XC-------------------------------------------------------------------- XCS DATA PY1/-1.4566865832663635920E+04, 4.6905288611678631510E+06, XCS 1 -6.9590439394619619534E+08, 4.3600098638603061642E+10, XCS 2 -5.5107435206722644429E+11,-2.2213976967566192242E+13, XCS 3 1.7427031242901594547E+01/ XCS DATA QY1/ 8.3030857612070288823E+02, 4.0669982352539552018E+05, XCS 1 1.3960202770986831075E+08, 3.4015103849971240096E+10, XCS 2 5.4266824419412347550E+12, 4.3386146580707264428E+14/ X DATA PY1/-1.4566865832663635920D+04, 4.6905288611678631510D+06, X 1 -6.9590439394619619534D+08, 4.3600098638603061642D+10, X 2 -5.5107435206722644429D+11,-2.2213976967566192242D+13, X 3 1.7427031242901594547D+01/ X DATA QY1/ 8.3030857612070288823D+02, 4.0669982352539552018D+05, X 1 1.3960202770986831075D+08, 3.4015103849971240096D+10, X 2 5.4266824419412347550D+12, 4.3386146580707264428D+14/ XC------------------------------------------------------------------- XC Coefficients for rational approximation of XC (Y0(X) - 2 LN(X/XY2) J0(X)) / (X**2 - XY2**2), XC 5.5 < |X| <= 8.0 XC-------------------------------------------------------------------- XCS DATA PY2/ 2.1363534169313901632E+04,-1.0085539923498211426E+07, XCS 1 2.1958827170518100757E+09,-1.9363051266772083678E+11, XCS 2 -1.2829912364088687306E+11, 6.7016641869173237784E+14, XCS 3 -8.0728726905150210443E+15,-1.7439661319197499338E+01/ XCS DATA QY2/ 8.7903362168128450017E+02, 5.3924739209768057030E+05, XCS 1 2.4727219475672302327E+08, 8.6926121104209825246E+10, XCS 2 2.2598377924042897629E+13, 3.9272425569640309819E+15, XCS 3 3.4563724628846457519E+17/ X DATA PY2/ 2.1363534169313901632D+04,-1.0085539923498211426D+07, X 1 2.1958827170518100757D+09,-1.9363051266772083678D+11, X 2 -1.2829912364088687306D+11, 6.7016641869173237784D+14, X 3 -8.0728726905150210443D+15,-1.7439661319197499338D+01/ X DATA QY2/ 8.7903362168128450017D+02, 5.3924739209768057030D+05, X 1 2.4727219475672302327D+08, 8.6926121104209825246D+10, X 2 2.2598377924042897629D+13, 3.9272425569640309819D+15, X 3 3.4563724628846457519D+17/ XC------------------------------------------------------------------- XC Coefficients for Hart,s approximation, |X| > 8.0 XC------------------------------------------------------------------- XCS DATA P0/3.4806486443249270347E+03, 2.1170523380864944322E+04, XCS 1 4.1345386639580765797E+04, 2.2779090197304684302E+04, XCS 2 8.8961548424210455236E-01, 1.5376201909008354296E+02/ XCS DATA Q0/3.5028735138235608207E+03, 2.1215350561880115730E+04, XCS 1 4.1370412495510416640E+04, 2.2779090197304684318E+04, XCS 2 1.5711159858080893649E+02/ XCS DATA P1/-2.2300261666214198472E+01,-1.1183429920482737611E+02, XCS 1 -1.8591953644342993800E+02,-8.9226600200800094098E+01, XCS 2 -8.8033303048680751817E-03,-1.2441026745835638459E+00/ XCS DATA Q1/1.4887231232283756582E+03, 7.2642780169211018836E+03, XCS 1 1.1951131543434613647E+04, 5.7105024128512061905E+03, XCS 2 9.0593769594993125859E+01/ X DATA P0/3.4806486443249270347D+03, 2.1170523380864944322D+04, X 1 4.1345386639580765797D+04, 2.2779090197304684302D+04, X 2 8.8961548424210455236D-01, 1.5376201909008354296D+02/ X DATA Q0/3.5028735138235608207D+03, 2.1215350561880115730D+04, X 1 4.1370412495510416640D+04, 2.2779090197304684318D+04, X 2 1.5711159858080893649D+02/ X DATA P1/-2.2300261666214198472D+01,-1.1183429920482737611D+02, X 1 -1.8591953644342993800D+02,-8.9226600200800094098D+01, X 2 -8.8033303048680751817D-03,-1.2441026745835638459D+00/ X DATA Q1/1.4887231232283756582D+03, 7.2642780169211018836D+03, X 1 1.1951131543434613647D+04, 5.7105024128512061905D+03, X 2 9.0593769594993125859D+01/ XC------------------------------------------------------------------- XC Check for error conditions XC------------------------------------------------------------------- X AX = ABS(ARG) X IF ((JINT .EQ. 1) .AND. (ARG .LE. ZERO)) THEN X RESULT = -XINF X GO TO 2000 X ELSE IF (AX .GT. XMAX) THEN X RESULT = ZERO X GO TO 2000 X END IF X IF (AX .GT. EIGHT) GO TO 800 X IF (AX .LE. XSMALL) THEN X IF (JINT .EQ. 0) THEN X RESULT = ONE X ELSE X RESULT = PI2 * (LOG(AX) + CONS) X END IF X GO TO 2000 X END IF XC------------------------------------------------------------------- XC Calculate J0 for appropriate interval, preserving XC accuracy near the zero of J0 XC------------------------------------------------------------------- X ZSQ = AX * AX X IF (AX .LE. FOUR) THEN X XNUM = (PJ0(5) * ZSQ + PJ0(6)) * ZSQ + PJ0(7) X XDEN = ZSQ + QJ0(5) X DO 50 I = 1, 4 X XNUM = XNUM * ZSQ + PJ0(I) X XDEN = XDEN * ZSQ + QJ0(I) X 50 CONTINUE X PROD = ((AX - XJ01/TWO56) - XJ02) * (AX + XJ0) X ELSE X WSQ = ONE - ZSQ / SIXTY4 X XNUM = PJ1(7) * WSQ + PJ1(8) X XDEN = WSQ + QJ1(7) X DO 220 I = 1, 6 X XNUM = XNUM * WSQ + PJ1(I) X XDEN = XDEN * WSQ + QJ1(I) X 220 CONTINUE X PROD = (AX + XJ1) * ((AX - XJ11/TWO56) - XJ12) X END IF X RESULT = PROD * XNUM / XDEN X IF (JINT .EQ. 0) GO TO 2000 XC------------------------------------------------------------------- XC Calculate Y0. First find RESJ = pi/2 ln(x/xn) J0(x), XC where xn is a zero of Y0 XC------------------------------------------------------------------- X IF (AX .LE. THREE) THEN X UP = (AX-XY01/TWO56)-XY02 X XY = XY0 X ELSE IF (AX .LE. FIVE5) THEN X UP = (AX-XY11/TWO56)-XY12 X XY = XY1 X ELSE X UP = (AX-XY21/TWO56)-XY22 X XY = XY2 X END IF X DOWN = AX + XY X IF (ABS(UP) .LT. P17*DOWN) THEN X W = UP/DOWN X WSQ = W*W X XNUM = PLG(1) X XDEN = WSQ + QLG(1) X DO 320 I = 2, 4 X XNUM = XNUM*WSQ + PLG(I) X XDEN = XDEN*WSQ + QLG(I) X 320 CONTINUE X RESJ = PI2 * RESULT * W * XNUM/XDEN X ELSE X RESJ = PI2 * RESULT * LOG(AX/XY) X END IF XC------------------------------------------------------------------- XC Now calculate Y0 for appropriate interval, preserving XC accuracy near the zero of Y0 XC------------------------------------------------------------------- X IF (AX .LE. THREE) THEN X XNUM = PY0(6) * ZSQ + PY0(1) X XDEN = ZSQ + QY0(1) X DO 340 I = 2, 5 X XNUM = XNUM * ZSQ + PY0(I) X XDEN = XDEN * ZSQ + QY0(I) X 340 CONTINUE X ELSE IF (AX .LE. FIVE5) THEN X XNUM = PY1(7) * ZSQ + PY1(1) X XDEN = ZSQ + QY1(1) X DO 360 I = 2, 6 X XNUM = XNUM * ZSQ + PY1(I) X XDEN = XDEN * ZSQ + QY1(I) X 360 CONTINUE X ELSE X XNUM = PY2(8) * ZSQ + PY2(1) X XDEN = ZSQ + QY2(1) X DO 380 I = 2, 7 X XNUM = XNUM * ZSQ + PY2(I) X XDEN = XDEN * ZSQ + QY2(I) X 380 CONTINUE X END IF X RESULT = RESJ + UP * DOWN * XNUM / XDEN X GO TO 2000 XC------------------------------------------------------------------- XC Calculate J0 or Y0 for |ARG| > 8.0 XC------------------------------------------------------------------- X 800 Z = EIGHT / AX X W = AX / TWOPI X W = AINT(W) + ONEOV8 X W = (AX - W * TWOPI1) - W * TWOPI2 X ZSQ = Z * Z X XNUM = P0(5) * ZSQ + P0(6) X XDEN = ZSQ + Q0(5) X UP = P1(5) * ZSQ + P1(6) X DOWN = ZSQ + Q1(5) X DO 850 I = 1, 4 X XNUM = XNUM * ZSQ + P0(I) X XDEN = XDEN * ZSQ + Q0(I) X UP = UP * ZSQ + P1(I) X DOWN = DOWN * ZSQ + Q1(I) X 850 CONTINUE X R0 = XNUM / XDEN X R1 = UP / DOWN X IF (JINT .EQ. 0) THEN X RESULT = SQRT(PI2/AX) * (R0*COS(W) - Z*R1*SIN(W)) X ELSE X RESULT = SQRT(PI2/AX) * (R0*SIN(W) + Z*R1*COS(W)) X END IF X 2000 RETURN XC---------- Last line of CALJY0 ---------- X END X X DOUBLE PRECISION FUNCTION BESJ0(X) XCS REAL FUNCTION BESJ0(X) XC-------------------------------------------------------------------- XC XC This subprogram computes approximate values for Bessel functions XC of the first kind of order zero for arguments |X| <= XMAX XC (see comments heading CALJY0). XC XC-------------------------------------------------------------------- X INTEGER JINT XCS REAL X, RESULT X DOUBLE PRECISION X, RESULT XC-------------------------------------------------------------------- X JINT=0 X CALL CALJY0(X,RESULT,JINT) X BESJ0 = RESULT X RETURN XC---------- Last line of BESJ0 ---------- X END X DOUBLE PRECISION FUNCTION BESY0(X) XCS REAL FUNCTION BESY0(X) XC-------------------------------------------------------------------- XC XC This subprogram computes approximate values for Bessel functions XC of the second kind of order zero for arguments 0 < X <= XMAX XC (see comments heading CALJY0). XC XC-------------------------------------------------------------------- X INTEGER JINT XCS REAL X, RESULT X DOUBLE PRECISION X, RESULT XC-------------------------------------------------------------------- X JINT=1 X CALL CALJY0(X,RESULT,JINT) X BESY0 = RESULT X RETURN XC---------- Last line of BESY0 ---------- X END X X* ====================================================================== X* NIST Guide to Available Math Software. X* Fullsource for module DGAMI from package CMLIB. X* Retrieved from CAMSUN on Tue May 23 18:39:46 1995. X* ====================================================================== X DOUBLE PRECISION FUNCTION DGAMI(A,X) XC***BEGIN PROLOGUE DGAMI XC***DATE WRITTEN 770701 (YYMMDD) XC***REVISION DATE 820801 (YYMMDD) XC***CATEGORY NO. C7E XC***KEYWORDS DOUBLE PRECISION,GAMMA,GAMMA FUNCTION, XC INCOMPLETE GAMMA FUNCTION,SPECIAL FUNCTION XC***AUTHOR FULLERTON, W., (LANL) XC***PURPOSE Calculates the d.p. incomplete Gamma function. XC***DESCRIPTION XC XC Evaluate the incomplete gamma function defined by XC XC DGAMI = integral from T = 0 to X of EXP(-T) * T**(A-1.0) . XC XC DGAMI is evaluated for positive values of A and non-negative values XC of X. A slight deterioration of 2 or 3 digits accuracy will occur XC when DGAMI is very large or very small, because logarithmic variables XC are used. The function and both arguments are double precision. XC***REFERENCES (NONE) XC***ROUTINES CALLED DGAMIT,DLNGAM,XERROR XC***END PROLOGUE DGAMI X DOUBLE PRECISION A, X, FACTOR, DLNGAM, DGAMIT XC***FIRST EXECUTABLE STATEMENT DGAMI X IF (A.LE.0.D0) CALL XERROR ( 'DGAMI A MUST BE GT ZERO', 25, 1,2) X IF (X.LT.0.D0) CALL XERROR ( 'DGAMI X MUST BE GE ZERO', 25, 2,2) XC X DGAMI = 0.D0 X IF (X.EQ.0.0D0) RETURN XC XC THE ONLY ERROR POSSIBLE IN THE EXPRESSION BELOW IS A FATAL OVERFLOW. X FACTOR = DEXP (DLNGAM(A) + A*DLOG(X)) XC X DGAMI = FACTOR * DGAMIT (A, X) XC X RETURN X END X DOUBLE PRECISION FUNCTION DGAMIT(A,X) XC***BEGIN PROLOGUE DGAMIT XC***DATE WRITTEN 770701 (YYMMDD) XC***REVISION DATE 820801 (YYMMDD) XC***CATEGORY NO. C7E XC***KEYWORDS COMPLEMENTARY,COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, XC DOUBLE PRECISION,GAMMA FUNCTION,SPECIAL FUNCTION,TRICOMI XC***AUTHOR FULLERTON, W., (LANL) XC***PURPOSE Calculates Tricomi's form of the incomplete Gamma function. XC***DESCRIPTION XC XC Evaluate Tricomi's incomplete gamma function defined by XC XC DGAMIT = X**(-A)/GAMMA(A) * integral T = 0 to X of EXP(-T) * T**(A-1.) XC XC for A .GT. 0.0 and by analytic XC continuation for A .LE. 0.0. Gamma(X) is the complete XC gamma function of X. DGAMIT is evaluated for arbitrary real values of XC A and for non-negative values of X (even though DGAMIT is defined for XC X .LT. 0.0), except that for X = 0 and A .LE. 0.0, DGAMIT is infinite, XC a fatal error. The function and both arguments are double precision. XC XC A slight deterioration of 2 or 3 digits accuracy will occur when XC DGAMIT is very large or very small in absolute value, because log- XC arithmic variables are used. Also, if the parameter A is very close XC to a negative integer (but not a negative integer), there is a loss XC of accuracy, which is reported if the result is less than half XC machine precision. XC XC Ref. -- W. Gautschi, An Evaluation Procedure for Incomplete Gamma XC Functions, ACM Trans. Math. Software, Vol. 5, No. 4, December 1979. XC***REFERENCES (NONE) XC***ROUTINES CALLED D1MACH,D9GMIT,D9LGIC,D9LGIT,DGAMR,DINT,DLGAMS, XC DLNGAM,XERCLR,XERROR XC***END PROLOGUE DGAMIT X DOUBLE PRECISION A, X, AEPS, AINTA, ALGAP1, ALNEPS, ALNG, ALX, X 1 BOT, H, SGA, SGNGAM, SQEPS, T, D1MACH, DGAMR, D9GMIT, D9LGIT, X 2 DLNGAM, D9LGIC, DINT X DATA ALNEPS, SQEPS, BOT / 3*0.D0 / XC***FIRST EXECUTABLE STATEMENT DGAMIT X IF (ALNEPS.NE.0.D0) GO TO 10 X ALNEPS = -DLOG (D1MACH(3)) X SQEPS = DSQRT (D1MACH(4)) X BOT = DLOG (D1MACH(1)) XC X 10 IF (X.LT.0.D0) CALL XERROR ( 'DGAMIT X IS NEGATIVE', 21, 2, 2) XC X IF (X.NE.0.D0) ALX = DLOG (X) X SGA = 1.0D0 X IF (A.NE.0.D0) SGA = DSIGN (1.0D0, A) X AINTA = DINT (A + 0.5D0*SGA) X AEPS = A - AINTA XC X IF (X.GT.0.D0) GO TO 20 X DGAMIT = 0.0D0 X IF (AINTA.GT.0.D0 .OR. AEPS.NE.0.D0) DGAMIT = DGAMR(A+1.0D0) X RETURN XC X 20 IF (X.GT.1.D0) GO TO 30 X IF (A.GE.(-0.5D0) .OR. AEPS.NE.0.D0) CALL DLGAMS (A+1.0D0, ALGAP1, X 1 SGNGAM) X DGAMIT = D9GMIT (A, X, ALGAP1, SGNGAM, ALX) X RETURN XC X 30 IF (A.LT.X) GO TO 40 X T = D9LGIT (A, X, DLNGAM(A+1.0D0)) X IF (T.LT.BOT) CALL XERCLR X DGAMIT = DEXP (T) X RETURN XC X 40 ALNG = D9LGIC (A, X, ALX) XC XC EVALUATE DGAMIT IN TERMS OF DLOG (DGAMIC (A, X)) XC X H = 1.0D0 X IF (AEPS.EQ.0.D0 .AND. AINTA.LE.0.D0) GO TO 50 XC X CALL DLGAMS (A+1.0D0, ALGAP1, SGNGAM) X T = DLOG (DABS(A)) + ALNG - ALGAP1 X IF (T.GT.ALNEPS) GO TO 60 XC X IF (T.GT.(-ALNEPS)) H = 1.0D0 - SGA * SGNGAM * DEXP(T) X IF (DABS(H).GT.SQEPS) GO TO 50 XC X CALL XERCLR X CALL XERROR ( 'DGAMIT RESULT LT HALF PRECISION', 32, 1, 1) XC X 50 T = -A*ALX + DLOG(DABS(H)) X IF (T.LT.BOT) CALL XERCLR X DGAMIT = DSIGN (DEXP(T), H) X RETURN XC X 60 T = T - A*ALX X IF (T.LT.BOT) CALL XERCLR X DGAMIT = -SGA * SGNGAM * DEXP(T) X RETURN XC X END X DOUBLE PRECISION FUNCTION DGAMR(X) XC***BEGIN PROLOGUE DGAMR XC***DATE WRITTEN 770701 (YYMMDD) XC***REVISION DATE 820801 (YYMMDD) XC***CATEGORY NO. C7A XC***KEYWORDS DOUBLE PRECISION,GAMMA,GAMMA FUNCTION, XC RECIPROCAL GAMMA FUNCTION,SPECIAL FUNCTION XC***AUTHOR FULLERTON, W., (LANL) XC***PURPOSE Calculates d.p. reciprocal Gamma function. XC***DESCRIPTION XC XC DGAMR(X) calculates the double precision reciprocal of the XC complete gamma function for double precision argument X. XC***REFERENCES (NONE) XC***ROUTINES CALLED DGAMMA,DINT,DLGAMS,XERCLR,XGETF,XSETF XC***END PROLOGUE DGAMR X EXTERNAL DGAMMA X INTEGER IROLD X DOUBLE PRECISION X, ALNGX, SGNGX, DGAMMA, DINT XC***FIRST EXECUTABLE STATEMENT DGAMR X DGAMR = 0.0D0 X IF (X.LE.0.0D0 .AND. DINT(X).EQ.X) RETURN XC X CALL XGETF (IROLD) X CALL XSETF (1) X IF (DABS(X).GT.10.0D0) GO TO 10 X DGAMR = 1.0D0/DGAMMA(X) X CALL XERCLR X CALL XSETF (IROLD) X RETURN XC X 10 CALL DLGAMS (X, ALNGX, SGNGX) X CALL XERCLR X CALL XSETF (IROLD) X DGAMR = SGNGX * DEXP(-ALNGX) X RETURN XC X END X SUBROUTINE DLGAMS(X,DLGAM,SGNGAM) XC***BEGIN PROLOGUE DLGAMS XC***DATE WRITTEN 770701 (YYMMDD) XC***REVISION DATE 820801 (YYMMDD) XC***CATEGORY NO. C7A XC***KEYWORDS ABSOLUTE VALUE,DOUBLE PRECISION,GAMMA FUNCTION,LOGARITHM, XC SPECIAL FUNCTION XC***AUTHOR FULLERTON, W., (LANL) XC***PURPOSE Calculates the log of the absolute value of the Gamma XC function XC***DESCRIPTION XC XC DLGAMS(X,DLGAM,SGNGAM) calculates the double precision natural XC logarithm of the absolute value of the gamma function for XC double precision argument X and stores the result in double XC precision argument DLGAM. XC***REFERENCES (NONE) XC***ROUTINES CALLED DINT,DLNGAM XC***END PROLOGUE DLGAMS X DOUBLE PRECISION X, DLGAM, SGNGAM, DINT, DLNGAM, INT XC***FIRST EXECUTABLE STATEMENT DLGAMS X DLGAM = DLNGAM(X) X SGNGAM = 1.0D0 X IF (X.GT.0.D0) RETURN XC X INT = DMOD (-DINT(X), 2.0D0) + 0.1D0 X IF (INT.EQ.0) SGNGAM = -1.0D0 XC X RETURN X END X DOUBLE PRECISION FUNCTION DLNGAM(X) XC***BEGIN PROLOGUE DLNGAM XC***DATE WRITTEN 770601 (YYMMDD) XC***REVISION DATE 820801 (YYMMDD) XC***CATEGORY NO. C7A XC***KEYWORDS ABSOLUTE VALUE,DOUBLE PRECISION,GAMMA FUNCTION,LOGARITHM, XC SPECIAL FUNCTION XC***AUTHOR FULLERTON, W., (LANL) XC***PURPOSE Computes the d.p. logarithm of the absolute value of the XC Gamma function XC***DESCRIPTION XC XC DLNGAM(X) calculates the double precision logarithm of the XC absolute value of the gamma function for double precision XC argument X. XC***REFERENCES (NONE) XC***ROUTINES CALLED D1MACH,D9LGMC,DGAMMA,DINT,XERROR XC***END PROLOGUE DLNGAM X EXTERNAL DGAMMA X DOUBLE PRECISION X, DXREL, PI, SINPIY, SQPI2L, SQ2PIL, XMAX, X 1 Y, DINT, DGAMMA, D9LGMC, D1MACH,TEMP X DATA SQ2PIL / 0.9189385332 0467274178 0329736405 62 D0 / X DATA SQPI2L / +.2257913526 4472743236 3097614947 441 D+0 / X DATA PI / 3.1415926535 8979323846 2643383279 50 D0 / X DATA XMAX, DXREL / 2*0.D0 / XC***FIRST EXECUTABLE STATEMENT DLNGAM X IF (XMAX.NE.0.D0) GO TO 10 X TEMP = 1.0D0/DLOG(D1MACH(2)) X XMAX = TEMP * D1MACH(2) X DXREL = DSQRT (D1MACH(4)) XC X 10 Y = DABS (X) X IF (Y.GT.10.D0) GO TO 20 XC XC DLOG (DABS (DGAMMA(X)) ) FOR DABS(X) .LE. 10.0 XC X DLNGAM = DLOG (DABS (DGAMMA(X)) ) X RETURN XC XC DLOG ( DABS (DGAMMA(X)) ) FOR DABS(X) .GT. 10.0 XC X 20 IF (Y.GT.XMAX) CALL XERROR ( 'DLNGAM DABS(X) SO BIG DLNGAM OVERFL X 1OWS', 39, 2, 2) XC X IF (X.GT.0.D0) DLNGAM = SQ2PIL + (X-0.5D0)*DLOG(X) - X + D9LGMC(Y) X IF (X.GT.0.D0) RETURN XC X SINPIY = DABS (DSIN(PI*Y)) X IF (SINPIY.EQ.0.D0) CALL XERROR ( 'DLNGAM X IS A NEGATIVE INTEGER X 1', 31, 3, 2) XC X IF (DABS ((X-DINT(X-0.5D0))/X).LT.DXREL) CALL XERROR ( 'DLNGAM X 1ANSWER LT HALF PRECISION BECAUSE X TOO NEAR NEGATIVE INTEGER', X 2,68,1, 1) XC X DLNGAM = SQPI2L + (X-0.5D0)*DLOG(Y) - X - DLOG(SINPIY) - D9LGMC(Y) X RETURN XC X END X SUBROUTINE XERCLR XC***BEGIN PROLOGUE XERCLR XC***DATE WRITTEN 790801 (YYMMDD) XC***REVISION DATE 820801 (YYMMDD) XC***CATEGORY NO. R3C XC***KEYWORDS ERROR,XERROR PACKAGE XC***AUTHOR JONES, R. E., (SNLA) XC***PURPOSE Resets current error number to zero. XC***DESCRIPTION XC Abstract XC This routine simply resets the current error number to zero. XC This may be necessary to do in order to determine that XC a certain error has occurred again since the last time XC NUMXER was referenced. XC XC Written by Ron Jones, with SLATEC Common Math Library Subcommittee XC Latest revision --- 7 June 1978 XC***REFERENCES JONES R.E., KAHANER D.K., "XERROR, THE SLATEC ERROR- XC HANDLING PACKAGE", SAND82-0800, SANDIA LABORATORIES, XC 1982. XC***ROUTINES CALLED J4SAVE XC***END PROLOGUE XERCLR XC***FIRST EXECUTABLE STATEMENT XERCLR X INTEGER J4SAVE X INTEGER JUNK X JUNK = J4SAVE(1,0,.TRUE.) X RETURN X END X SUBROUTINE XERROR(MESSG,NMESSG,NERR,LEVEL) XC***BEGIN PROLOGUE XERROR XC***DATE WRITTEN 790801 (YYMMDD) XC***REVISION DATE 820801 (YYMMDD) XC***CATEGORY NO. R3C XC***KEYWORDS ERROR,XERROR PACKAGE XC***AUTHOR JONES, R. E., (SNLA) XC***PURPOSE Processes an error (diagnostic) message. XC***DESCRIPTION XC Abstract XC XERROR processes a diagnostic message, in a manner XC determined by the value of LEVEL and the current value XC of the library error control flag, KONTRL. XC (See subroutine XSETF for details.) XC XC Description of Parameters XC --Input-- XC MESSG - the Hollerith message to be processed, containing XC no more than 72 characters. XC NMESSG- the actual number of characters in MESSG. XC NERR - the error number associated with this message. XC NERR must not be zero. XC LEVEL - error category. XC =2 means this is an unconditionally fatal error. XC =1 means this is a recoverable error. (I.e., it is XC non-fatal if XSETF has been appropriately called.) XC =0 means this is a warning message only. XC =-1 means this is a warning message which is to be XC printed at most once, regardless of how many XC times this call is executed. XC XC Examples XC CALL XERROR('SMOOTH -- NUM WAS ZERO.',23,1,2) XC CALL XERROR('INTEG -- LESS THAN FULL ACCURACY ACHIEVED.', XC 43,2,1) XC CALL XERROR('ROOTER -- ACTUAL ZERO OF F FOUND BEFORE INTERVAL XC 1FULLY COLLAPSED.',65,3,0) XC CALL XERROR('EXP -- UNDERFLOWS BEING SET TO ZERO.',39,1,-1) XC XC Latest revision --- 19 MAR 1980 XC Written by Ron Jones, with SLATEC Common Math Library Subcommittee XC***REFERENCES JONES R.E., KAHANER D.K., "XERROR, THE SLATEC ERROR- XC HANDLING PACKAGE", SAND82-0800, SANDIA LABORATORIES, XC 1982. XC***ROUTINES CALLED XERRWV XC***END PROLOGUE XERROR X CHARACTER*(*) MESSG X INTEGER LEVEL, NERR, NMESSG XC***FIRST EXECUTABLE STATEMENT XERROR X CALL XERRWV(MESSG,NMESSG,NERR,LEVEL,0,0,0,0,0.,0.) X RETURN X END X SUBROUTINE XERRWV(MESSG,NMESSG,NERR,LEVEL,NI,I1,I2,NR,R1,R2) XC***BEGIN PROLOGUE XERRWV XC***DATE WRITTEN 800319 (YYMMDD) XC***REVISION DATE 820801 (YYMMDD) XC***CATEGORY NO. R3C XC***KEYWORDS ERROR,XERROR PACKAGE XC***AUTHOR JONES, R. E., (SNLA) XC***PURPOSE Processes error message allowing 2 integer and two real XC values to be included in the message. XC***DESCRIPTION XC Abstract XC XERRWV processes a diagnostic message, in a manner XC determined by the value of LEVEL and the current value XC of the library error control flag, KONTRL. XC (See subroutine XSETF for details.) XC In addition, up to two integer values and two real XC values may be printed along with the message. XC XC Description of Parameters XC --Input-- XC MESSG - the Hollerith message to be processed. XC NMESSG- the actual number of characters in MESSG. XC NERR - the error number associated with this message. XC NERR must not be zero. XC LEVEL - error category. XC =2 means this is an unconditionally fatal error. XC =1 means this is a recoverable error. (I.e., it is XC non-fatal if XSETF has been appropriately called.) XC =0 means this is a warning message only. XC =-1 means this is a warning message which is to be XC printed at most once, regardless of how many XC times this call is executed. XC NI - number of integer values to be printed. (0 to 2) XC I1 - first integer value. XC I2 - second integer value. XC NR - number of real values to be printed. (0 to 2) XC R1 - first real value. XC R2 - second real value. XC XC Examples XC CALL XERRWV('SMOOTH -- NUM (=I1) WAS ZERO.',29,1,2, XC 1 1,NUM,0,0,0.,0.) XC CALL XERRWV('QUADXY -- REQUESTED ERROR (R1) LESS THAN MINIMUM ( XC 1R2).,54,77,1,0,0,0,2,ERRREQ,ERRMIN) XC XC Latest revision --- 19 MAR 1980 XC Written by Ron Jones, with SLATEC Common Math Library Subcommittee XC***REFERENCES JONES R.E., KAHANER D.K., "XERROR, THE SLATEC ERROR- XC HANDLING PACKAGE", SAND82-0800, SANDIA LABORATORIES, XC 1982. XC***ROUTINES CALLED FDUMP,I1MACH,J4SAVE,XERABT,XERCTL,XERPRT,XERSAV, XC XGETUA XC***END PROLOGUE XERRWV X CHARACTER*(*) MESSG X CHARACTER*20 LFIRST X CHARACTER*37 FORM X INTEGER NMESSG, NERR, NI, I1,I2,NR, LUN X INTEGER J4SAVE, I1MACH X DIMENSION LUN(5) X DOUBLE PRECISION R1, R2 X INTEGER LKNTRL, MAXMES, KDUMMY, JUNK, KOUNT, LMESSG, LERR X INTEGER LLEVEL, MKNTRL,NUNIT, ISIZEI,ISIZEF, KUNIT,IUNIT X INTEGER I, IFATAL, LEVEL XC GET FLAGS XC***FIRST EXECUTABLE STATEMENT XERRWV X LKNTRL = J4SAVE(2,0,.FALSE.) X MAXMES = J4SAVE(4,0,.FALSE.) XC CHECK FOR VALID INPUT X IF ((NMESSG.GT.0).AND.(NERR.NE.0).AND. X 1 (LEVEL.GE.(-1)).AND.(LEVEL.LE.2)) GO TO 10 X IF (LKNTRL.GT.0) CALL XERPRT('FATAL ERROR IN...',17) X CALL XERPRT('XERROR -- INVALID INPUT',23) X IF (LKNTRL.GT.0) CALL FDUMP X IF (LKNTRL.GT.0) CALL XERPRT('JOB ABORT DUE TO FATAL ERROR.', X 1 29) X IF (LKNTRL.GT.0) CALL XERSAV(' ',0,0,0,KDUMMY) X CALL XERABT('XERROR -- INVALID INPUT',23) X RETURN X 10 CONTINUE XC RECORD MESSAGE X JUNK = J4SAVE(1,NERR,.TRUE.) X CALL XERSAV(MESSG,NMESSG,NERR,LEVEL,KOUNT) XC LET USER OVERRIDE X LFIRST = MESSG X LMESSG = NMESSG X LERR = NERR X LLEVEL = LEVEL X CALL XERCTL(LFIRST,LMESSG,LERR,LLEVEL,LKNTRL) XC RESET TO ORIGINAL VALUES X LMESSG = NMESSG X LERR = NERR X LLEVEL = LEVEL X LKNTRL = MAX0(-2,MIN0(2,LKNTRL)) X MKNTRL = IABS(LKNTRL) XC DECIDE WHETHER TO PRINT MESSAGE X IF ((LLEVEL.LT.2).AND.(LKNTRL.EQ.0)) GO TO 100 X IF (((LLEVEL.EQ.(-1)).AND.(KOUNT.GT.MIN0(1,MAXMES))) X 1.OR.((LLEVEL.EQ.0) .AND.(KOUNT.GT.MAXMES)) X 2.OR.((LLEVEL.EQ.1) .AND.(KOUNT.GT.MAXMES).AND.(MKNTRL.EQ.1)) X 3.OR.((LLEVEL.EQ.2) .AND.(KOUNT.GT.MAX0(1,MAXMES)))) GO TO 100 X IF (LKNTRL.LE.0) GO TO 20 X CALL XERPRT(' ',1) XC INTRODUCTION X IF (LLEVEL.EQ.(-1)) CALL XERPRT X 1('WARNING MESSAGE...THIS MESSAGE WILL ONLY BE PRINTED ONCE.',57) X IF (LLEVEL.EQ.0) CALL XERPRT('WARNING IN...',13) X IF (LLEVEL.EQ.1) CALL XERPRT X 1 ('RECOVERABLE ERROR IN...',23) X IF (LLEVEL.EQ.2) CALL XERPRT('FATAL ERROR IN...',17) X 20 CONTINUE XC MESSAGE X CALL XERPRT(MESSG,LMESSG) X CALL XGETUA(LUN,NUNIT) X ISIZEI = LOG10(FLOAT(I1MACH(9))) + 1.0 X ISIZEF = LOG10(FLOAT(I1MACH(10))**I1MACH(11)) + 1.0 X DO 50 KUNIT=1,NUNIT X IUNIT = LUN(KUNIT) X IF (IUNIT.EQ.0) IUNIT = I1MACH(4) X DO 22 I=1,MIN(NI,2) X WRITE (FORM,21) I,ISIZEI X 21 FORMAT ('(11X,21HIN ABOVE MESSAGE, I',I1,'=,I',I2,') ') X IF (I.EQ.1) WRITE (IUNIT,FORM) I1 X IF (I.EQ.2) WRITE (IUNIT,FORM) I2 X 22 CONTINUE X DO 24 I=1,MIN(NR,2) X WRITE (FORM,23) I,ISIZEF+10,ISIZEF X 23 FORMAT ('(11X,21HIN ABOVE MESSAGE, R',I1,'=,E', X 1 I2,'.',I2,')') X IF (I.EQ.1) WRITE (IUNIT,FORM) R1 X IF (I.EQ.2) WRITE (IUNIT,FORM) R2 X 24 CONTINUE X IF (LKNTRL.LE.0) GO TO 40 XC ERROR NUMBER X WRITE (IUNIT,30) LERR X 30 FORMAT (15H ERROR NUMBER =,I10) X 40 CONTINUE X 50 CONTINUE XC TRACE-BACK X IF (LKNTRL.GT.0) CALL FDUMP X 100 CONTINUE X IFATAL = 0 X IF ((LLEVEL.EQ.2).OR.((LLEVEL.EQ.1).AND.(MKNTRL.EQ.2))) X 1IFATAL = 1 XC QUIT HERE IF MESSAGE IS NOT FATAL X IF (IFATAL.LE.0) RETURN X IF ((LKNTRL.LE.0).OR.(KOUNT.GT.MAX0(1,MAXMES))) GO TO 120 XC PRINT REASON FOR ABORT X IF (LLEVEL.EQ.1) CALL XERPRT X 1 ('JOB ABORT DUE TO UNRECOVERED ERROR.',35) X IF (LLEVEL.EQ.2) CALL XERPRT X 1 ('JOB ABORT DUE TO FATAL ERROR.',29) XC PRINT ERROR SUMMARY X CALL XERSAV(' ',-1,0,0,KDUMMY) X 120 CONTINUE XC ABORT X IF ((LLEVEL.EQ.2).AND.(KOUNT.GT.MAX0(1,MAXMES))) LMESSG = 0 X CALL XERABT(MESSG,LMESSG) X RETURN X END X SUBROUTINE XERSAV(MESSG,NMESSG,NERR,LEVEL,ICOUNT) XC***BEGIN PROLOGUE XERSAV XC***DATE WRITTEN 800319 (YYMMDD) XC***REVISION DATE 820801 (YYMMDD) XC***CATEGORY NO. Z XC***KEYWORDS ERROR,XERROR PACKAGE XC***AUTHOR JONES, R. E., (SNLA) XC***PURPOSE Records that an error occurred. XC***DESCRIPTION XC Abstract XC Record that this error occurred. XC XC Description of Parameters XC --Input-- XC MESSG, NMESSG, NERR, LEVEL are as in XERROR, XC except that when NMESSG=0 the tables will be XC dumped and cleared, and when NMESSG is less than zero the XC tables will be dumped and not cleared. XC --Output-- XC ICOUNT will be the number of times this message has XC been seen, or zero if the table has overflowed and XC does not contain this message specifically. XC When NMESSG=0, ICOUNT will not be altered. XC XC Written by Ron Jones, with SLATEC Common Math Library Subcommittee XC Latest revision --- 19 Mar 1980 XC***REFERENCES JONES R.E., KAHANER D.K., "XERROR, THE SLATEC ERROR- XC HANDLING PACKAGE", SAND82-0800, SANDIA LABORATORIES, XC 1982. XC***ROUTINES CALLED I1MACH,XGETUA XC***END PROLOGUE XERSAV X INTEGER I1MACH X INTEGER I, II,ICOUNT, IUNIT, KUNIT, KOUNT, KOUNTX, LEVEL X INTEGER LEVTAB, NERR, NERTAB, NUNIT, NMESSG X INTEGER LUN(5) X CHARACTER*(*) MESSG X CHARACTER*20 MESTAB(10),MES X DIMENSION NERTAB(10),LEVTAB(10),KOUNT(10) X SAVE MESTAB,NERTAB,LEVTAB,KOUNT,KOUNTX XC NEXT TWO DATA STATEMENTS ARE NECESSARY TO PROVIDE A BLANK XC ERROR TABLE INITIALLY X DATA KOUNT(1),KOUNT(2),KOUNT(3),KOUNT(4),KOUNT(5), X 1 KOUNT(6),KOUNT(7),KOUNT(8),KOUNT(9),KOUNT(10) X 2 /0,0,0,0,0,0,0,0,0,0/ X DATA KOUNTX/0/ XC***FIRST EXECUTABLE STATEMENT XERSAV X IF (NMESSG.GT.0) GO TO 80 XC DUMP THE TABLE X IF (KOUNT(1).EQ.0) RETURN XC PRINT TO EACH UNIT X CALL XGETUA(LUN,NUNIT) X DO 60 KUNIT=1,NUNIT X IUNIT = LUN(KUNIT) X IF (IUNIT.EQ.0) IUNIT = I1MACH(4) XC PRINT TABLE HEADER X WRITE (IUNIT,10) X 10 FORMAT (32H0 ERROR MESSAGE SUMMARY/ X 1 51H MESSAGE START NERR LEVEL COUNT) XC PRINT BODY OF TABLE X DO 20 I=1,10 X IF (KOUNT(I).EQ.0) GO TO 30 X WRITE (IUNIT,15) MESTAB(I),NERTAB(I),LEVTAB(I),KOUNT(I) X 15 FORMAT (1X,A20,3I10) X 20 CONTINUE X 30 CONTINUE XC PRINT NUMBER OF OTHER ERRORS X IF (KOUNTX.NE.0) WRITE (IUNIT,40) KOUNTX X 40 FORMAT (41H0OTHER ERRORS NOT INDIVIDUALLY TABULATED=,I10) X WRITE (IUNIT,50) X 50 FORMAT (1X) X 60 CONTINUE X IF (NMESSG.LT.0) RETURN XC CLEAR THE ERROR TABLES X DO 70 I=1,10 X 70 KOUNT(I) = 0 X KOUNTX = 0 X RETURN X 80 CONTINUE XC PROCESS A MESSAGE... XC SEARCH FOR THIS MESSG, OR ELSE AN EMPTY SLOT FOR THIS MESSG, XC OR ELSE DETERMINE THAT THE ERROR TABLE IS FULL. X MES = MESSG X DO 90 I=1,10 X II = I X IF (KOUNT(I).EQ.0) GO TO 110 X IF (MES.NE.MESTAB(I)) GO TO 90 X IF (NERR.NE.NERTAB(I)) GO TO 90 X IF (LEVEL.NE.LEVTAB(I)) GO TO 90 X GO TO 100 X 90 CONTINUE XC THREE POSSIBLE CASES... XC TABLE IS FULL X KOUNTX = KOUNTX+1 X ICOUNT = 1 X RETURN XC MESSAGE FOUND IN TABLE X 100 KOUNT(II) = KOUNT(II) + 1 X ICOUNT = KOUNT(II) X RETURN XC EMPTY SLOT FOUND FOR NEW MESSAGE X 110 MESTAB(II) = MES X NERTAB(II) = NERR X LEVTAB(II) = LEVEL X KOUNT(II) = 1 X ICOUNT = 1 X RETURN X END X SUBROUTINE XGETF(KONTRL) XC***BEGIN PROLOGUE XGETF XC***DATE WRITTEN 790801 (YYMMDD) XC***REVISION DATE 820801 (YYMMDD) XC***CATEGORY NO. R3C XC***KEYWORDS ERROR,XERROR PACKAGE XC***AUTHOR JONES, R. E., (SNLA) XC***PURPOSE Returns current value of error control flag. XC***DESCRIPTION XC Abstract XC XGETF returns the current value of the error control flag XC in KONTRL. See subroutine XSETF for flag value meanings. XC (KONTRL is an output parameter only.) XC XC Written by Ron Jones, with SLATEC Common Math Library Subcommittee XC Latest revision --- 7 June 1978 XC***REFERENCES JONES R.E., KAHANER D.K., "XERROR, THE SLATEC ERROR- XC HANDLING PACKAGE", SAND82-0800, SANDIA LABORATORIES, XC 1982. XC***ROUTINES CALLED J4SAVE XC***END PROLOGUE XGETF XC***FIRST EXECUTABLE STATEMENT XGETF X INTEGER J4SAVE X INTEGER KONTRL X KONTRL = J4SAVE(2,0,.FALSE.) X RETURN X END X SUBROUTINE XGETUA(IUNITA,N) XC***BEGIN PROLOGUE XGETUA XC***DATE WRITTEN 790801 (YYMMDD) XC***REVISION DATE 820801 (YYMMDD) XC***CATEGORY NO. R3C XC***KEYWORDS ERROR,XERROR PACKAGE XC***AUTHOR JONES, R. E., (SNLA) XC***PURPOSE Returns unit number(s) to which error messages are being XC sent. XC***DESCRIPTION XC Abstract XC XGETUA may be called to determine the unit number or numbers XC to which error messages are being sent. XC These unit numbers may have been set by a call to XSETUN, XC or a call to XSETUA, or may be a default value. XC XC Description of Parameters XC --Output-- XC IUNIT - an array of one to five unit numbers, depending XC on the value of N. A value of zero refers to the XC default unit, as defined by the I1MACH machine XC constant routine. Only IUNIT(1),...,IUNIT(N) are XC defined by XGETUA. The values of IUNIT(N+1),..., XC IUNIT(5) are not defined (for N .LT. 5) or altered XC in any way by XGETUA. XC N - the number of units to which copies of the XC error messages are being sent. N will be in the XC range from 1 to 5. XC XC Latest revision --- 19 MAR 1980 XC Written by Ron Jones, with SLATEC Common Math Library Subcommittee XC***REFERENCES JONES R.E., KAHANER D.K., "XERROR, THE SLATEC ERROR- XC HANDLING PACKAGE", SAND82-0800, SANDIA LABORATORIES, XC 1982. XC***ROUTINES CALLED J4SAVE XC***END PROLOGUE XGETUA X INTEGER J4SAVE X INTEGER I, INDEX, IUNITA, N X DIMENSION IUNITA(5) XC***FIRST EXECUTABLE STATEMENT XGETUA X N = J4SAVE(5,0,.FALSE.) X DO 30 I=1,N X INDEX = I+4 X IF (I.EQ.1) INDEX = 3 X IUNITA(I) = J4SAVE(INDEX,0,.FALSE.) X 30 CONTINUE X RETURN X END X SUBROUTINE XSETF(KONTRL) XC***BEGIN PROLOGUE XSETF XC***DATE WRITTEN 790801 (YYMMDD) XC***REVISION DATE 820801 (YYMMDD) XC***CATEGORY NO. R3A XC***KEYWORDS ERROR,XERROR PACKAGE XC***AUTHOR JONES, R. E., (SNLA) XC***PURPOSE Sets the error control flag. XC***DESCRIPTION XC Abstract XC XSETF sets the error control flag value to KONTRL. XC (KONTRL is an input parameter only.) XC The following table shows how each message is treated, XC depending on the values of KONTRL and LEVEL. (See XERROR XC for description of LEVEL.) XC XC If KONTRL is zero or negative, no information other than the XC message itself (including numeric values, if any) will be XC printed. If KONTRL is positive, introductory messages, XC trace-backs, etc., will be printed in addition to the message. XC XC IABS(KONTRL) XC LEVEL 0 1 2 XC value XC 2 fatal fatal fatal XC XC 1 not printed printed fatal XC XC 0 not printed printed printed XC XC -1 not printed printed printed XC only only XC once once XC XC Written by Ron Jones, with SLATEC Common Math Library Subcommittee XC Latest revision --- 19 MAR 1980 XC***REFERENCES JONES R.E., KAHANER D.K., "XERROR, THE SLATEC ERROR- XC HANDLING PACKAGE", SAND82-0800, SANDIA LABORATORIES, XC 1982. XC***ROUTINES CALLED J4SAVE,XERRWV XC***END PROLOGUE XSETF XC***FIRST EXECUTABLE STATEMENT XSETF X INTEGER J4SAVE X INTEGER JUNK, KONTRL X IF ((KONTRL.GE.(-2)).AND.(KONTRL.LE.2)) GO TO 10 X CALL XERRWV('XSETF -- INVALID VALUE OF KONTRL (I1).',33,1,2, X 1 1,KONTRL,0,0,0.,0.) X RETURN X 10 JUNK = J4SAVE(2,KONTRL,.TRUE.) X RETURN X END X DOUBLE PRECISION FUNCTION D1MACH(I) XC***BEGIN PROLOGUE D1MACH XC***DATE WRITTEN 750101 (YYMMDD) XC***REVISION DATE 910131 (YYMMDD) XC***CATEGORY NO. R1 XC***KEYWORDS MACHINE CONSTANTS XC***AUTHOR FOX, P. A., (BELL LABS) XC HALL, A. D., (BELL LABS) XC SCHRYER, N. L., (BELL LABS) XC***PURPOSE Returns double precision machine dependent constants XC***DESCRIPTION XC XC This is the CMLIB version of D1MACH, the double precision machine XC constants subroutine originally developed for the PORT library. XC XC D1MACH can be used to obtain machine-dependent parameters XC for the local machine environment. It is a function XC subprogram with one (input) argument, and can be called XC as follows, for example XC XC D = D1MACH(I) XC XC where I=1,...,5. The (output) value of D above is XC determined by the (input) value of I. The results for XC various values of I are discussed below. XC XC Double-precision machine constants XC D1MACH( 1) = B**(EMIN-1), the smallest positive magnitude. XC D1MACH( 2) = B**EMAX*(1 - B**(-T)), the largest magnitude. XC D1MACH( 3) = B**(-T), the smallest relative spacing. XC D1MACH( 4) = B**(1-T), the largest relative spacing. XC D1MACH( 5) = LOG10(B) XC***REFERENCES FOX P.A., HALL A.D., SCHRYER N.L.,*FRAMEWORK FOR A XC PORTABLE LIBRARY*, ACM TRANSACTIONS ON MATHEMATICAL XC SOFTWARE, VOL. 4, NO. 2, JUNE 1978, PP. 177-188. XC***ROUTINES CALLED XERROR XC***END PROLOGUE D1MACH XC X INTEGER I X INTEGER SMALL(4) X INTEGER LARGE(4) X INTEGER RIGHT(4) X INTEGER DIVER(4) X INTEGER LOG10(4) XC X DOUBLE PRECISION DMACH(5) XC X EQUIVALENCE (DMACH(1),SMALL(1)) X EQUIVALENCE (DMACH(2),LARGE(1)) X EQUIVALENCE (DMACH(3),RIGHT(1)) X EQUIVALENCE (DMACH(4),DIVER(1)) X EQUIVALENCE (DMACH(5),LOG10(1)) XC XC MACHINE CONSTANTS FOR IEEE ARITHMETIC MACHINES, SUCH AS THE AT&T XC 3B SERIES AND MOTOROLA 68000 BASED MACHINES (E.G. SUN 3 AND AT&T XC PC 7300), IN WHICH THE MOST SIGNIFICANT BYTE IS STORED FIRST. XC XC === MACHINE = IEEE.MOST-SIG-BYTE-FIRST XC === MACHINE = SUN XC === MACHINE = 68000 XC === MACHINE = ATT.3B XC === MACHINE = ATT.7300 X DATA SMALL(1),SMALL(2) / 1048576, 0 / X DATA LARGE(1),LARGE(2) / 2146435071, -1 / X DATA RIGHT(1),RIGHT(2) / 1017118720, 0 / X DATA DIVER(1),DIVER(2) / 1018167296, 0 / X DATA LOG10(1),LOG10(2) / 1070810131, 1352628735 / XC XC MACHINE CONSTANTS FOR IEEE ARITHMETIC MACHINES AND 8087-BASED XC MICROS, SUCH AS THE IBM PC AND AT&T 6300, IN WHICH THE LEAST XC SIGNIFICANT BYTE IS STORED FIRST. XC XC === MACHINE = IEEE.LEAST-SIG-BYTE-FIRST XC === MACHINE = 8087 XC === MACHINE = IBM.PC XC === MACHINE = ATT.6300 XC DATA SMALL(1),SMALL(2) / 0, 1048576 / XC DATA LARGE(1),LARGE(2) / -1, 2146435071 / XC DATA RIGHT(1),RIGHT(2) / 0, 1017118720 / XC DATA DIVER(1),DIVER(2) / 0, 1018167296 / XC DATA LOG10(1),LOG10(2) / 1352628735, 1070810131 / XC XC MACHINE CONSTANTS FOR AMDAHL MACHINES. XC XC === MACHINE = AMDAHL XC DATA SMALL(1),SMALL(2) / 1048576, 0 / XC DATA LARGE(1),LARGE(2) / 2147483647, -1 / XC DATA RIGHT(1),RIGHT(2) / 856686592, 0 / XC DATA DIVER(1),DIVER(2) / 873463808, 0 / XC DATA LOG10(1),LOG10(2) / 1091781651, 1352628735 / XC XC MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM. XC XC === MACHINE = BURROUGHS.1700 XC DATA SMALL(1) / ZC00800000 / XC DATA SMALL(2) / Z000000000 / XC DATA LARGE(1) / ZDFFFFFFFF / XC DATA LARGE(2) / ZFFFFFFFFF / XC DATA RIGHT(1) / ZCC5800000 / XC DATA RIGHT(2) / Z000000000 / XC DATA DIVER(1) / ZCC6800000 / XC DATA DIVER(2) / Z000000000 / XC DATA LOG10(1) / ZD00E730E7 / XC DATA LOG10(2) / ZC77800DC0 / XC XC MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM. XC XC === MACHINE = BURROUGHS.5700 XC DATA SMALL(1) / O1771000000000000 / XC DATA SMALL(2) / O0000000000000000 / XC DATA LARGE(1) / O0777777777777777 / XC DATA LARGE(2) / O0007777777777777 / XC DATA RIGHT(1) / O1461000000000000 / XC DATA RIGHT(2) / O0000000000000000 / XC DATA DIVER(1) / O1451000000000000 / XC DATA DIVER(2) / O0000000000000000 / XC DATA LOG10(1) / O1157163034761674 / XC DATA LOG10(2) / O0006677466732724 / XC XC MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS. XC XC === MACHINE = BURROUGHS.6700 XC === MACHINE = BURROUGHS.7700 XC DATA SMALL(1) / O1771000000000000 / XC DATA SMALL(2) / O7770000000000000 / XC DATA LARGE(1) / O0777777777777777 / XC DATA LARGE(2) / O7777777777777777 / XC DATA RIGHT(1) / O1461000000000000 / XC DATA RIGHT(2) / O0000000000000000 / XC DATA DIVER(1) / O1451000000000000 / XC DATA DIVER(2) / O0000000000000000 / XC DATA LOG10(1) / O1157163034761674 / XC DATA LOG10(2) / O0006677466732724 / XC XC MACHINE CONSTANTS FOR THE CONVEX C-120 (NATIVE MODE) XC WITH OR WITHOUT -R8 OPTION XC XC === MACHINE = CONVEX.C1 XC === MACHINE = CONVEX.C1.R8 XC DATA DMACH(1) / 5.562684646268007D-309 / XC DATA DMACH(2) / 8.988465674311577D+307 / XC DATA DMACH(3) / 1.110223024625157D-016 / XC DATA DMACH(4) / 2.220446049250313D-016 / XC DATA DMACH(5) / 3.010299956639812D-001 / XC XC MACHINE CONSTANTS FOR THE CONVEX C-120 (IEEE MODE) XC WITH OR WITHOUT -R8 OPTION XC XC === MACHINE = CONVEX.C1.IEEE XC === MACHINE = CONVEX.C1.IEEE.R8 XC DATA DMACH(1) / 2.225073858507202D-308 / XC DATA DMACH(2) / 1.797693134862315D+308 / XC DATA DMACH(3) / 1.110223024625157D-016 / XC DATA DMACH(4) / 2.220446049250313D-016 / XC DATA DMACH(5) / 3.010299956639812D-001 / XC XC MACHINE CONSTANTS FOR THE CYBER 170/180 SERIES USING NOS (FTN5). XC XC === MACHINE = CYBER.170.NOS XC === MACHINE = CYBER.180.NOS XC DATA SMALL(1) / O"00604000000000000000" / XC DATA SMALL(2) / O"00000000000000000000" / XC DATA LARGE(1) / O"37767777777777777777" / XC DATA LARGE(2) / O"37167777777777777777" / XC DATA RIGHT(1) / O"15604000000000000000" / XC DATA RIGHT(2) / O"15000000000000000000" / XC DATA DIVER(1) / O"15614000000000000000" / XC DATA DIVER(2) / O"15010000000000000000" / XC DATA LOG10(1) / O"17164642023241175717" / XC DATA LOG10(2) / O"16367571421742254654" / XC XC MACHINE CONSTANTS FOR THE CDC 180 SERIES USING NOS/VE XC XC === MACHINE = CYBER.180.NOS/VE XC DATA SMALL(1) / Z"3001800000000000" / XC DATA SMALL(2) / Z"3001000000000000" / XC DATA LARGE(1) / Z"4FFEFFFFFFFFFFFE" / XC DATA LARGE(2) / Z"4FFE000000000000" / XC DATA RIGHT(1) / Z"3FD2800000000000" / XC DATA RIGHT(2) / Z"3FD2000000000000" / XC DATA DIVER(1) / Z"3FD3800000000000" / XC DATA DIVER(2) / Z"3FD3000000000000" / XC DATA LOG10(1) / Z"3FFF9A209A84FBCF" / XC DATA LOG10(2) / Z"3FFFF7988F8959AC" / XC XC MACHINE CONSTANTS FOR THE CYBER 205 XC XC === MACHINE = CYBER.205 XC DATA SMALL(1) / X'9000400000000000' / XC DATA SMALL(2) / X'8FD1000000000000' / XC DATA LARGE(1) / X'6FFF7FFFFFFFFFFF' / XC DATA LARGE(2) / X'6FD07FFFFFFFFFFF' / XC DATA RIGHT(1) / X'FF74400000000000' / XC DATA RIGHT(2) / X'FF45000000000000' / XC DATA DIVER(1) / X'FF75400000000000' / XC DATA DIVER(2) / X'FF46000000000000' / XC DATA LOG10(1) / X'FFD04D104D427DE7' / XC DATA LOG10(2) / X'FFA17DE623E2566A' / XC XC MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES. XC XC === MACHINE = CDC.6000 XC === MACHINE = CDC.7000 XC DATA SMALL(1) / 00604000000000000000B / XC DATA SMALL(2) / 00000000000000000000B / XC DATA LARGE(1) / 37767777777777777777B / XC DATA LARGE(2) / 37167777777777777777B / XC DATA RIGHT(1) / 15604000000000000000B / XC DATA RIGHT(2) / 15000000000000000000B / XC DATA DIVER(1) / 15614000000000000000B / XC DATA DIVER(2) / 15010000000000000000B / XC DATA LOG10(1) / 17164642023241175717B / XC DATA LOG10(2) / 16367571421742254654B / XC XC MACHINE CONSTANTS FOR THE CRAY 1, XMP, 2, AND 3. XC XC === MACHINE = CRAY.46-BIT-INTEGER XC === MACHINE = CRAY.64-BIT-INTEGER XC DATA SMALL(1) / 201354000000000000000B / XC DATA SMALL(2) / 000000000000000000000B / XC DATA LARGE(1) / 577767777777777777777B / XC DATA LARGE(2) / 000007777777777777776B / XC DATA RIGHT(1) / 376434000000000000000B / XC DATA RIGHT(2) / 000000000000000000000B / XC DATA DIVER(1) / 376444000000000000000B / XC DATA DIVER(2) / 000000000000000000000B / XC DATA LOG10(1) / 377774642023241175717B / XC DATA LOG10(2) / 000007571421742254654B / XC XC MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 XC XC NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING LINE - XC STATIC DMACH(5) XC XC === MACHINE = DATA_GENERAL.ECLIPSE.S/200 XC DATA SMALL/20K,3*0/,LARGE/77777K,3*177777K/ XC DATA RIGHT/31420K,3*0/,DIVER/32020K,3*0/ XC DATA LOG10/40423K,42023K,50237K,74776K/ XC XC ELXSI 6400 XC XC === MACHINE = ELSXI.6400 XC DATA SMALL(1), SMALL(2) / '00100000'X,'00000000'X / XC DATA LARGE(1), LARGE(2) / '7FEFFFFF'X,'FFFFFFFF'X / XC DATA RIGHT(1), RIGHT(2) / '3CB00000'X,'00000000'X / XC DATA DIVER(1), DIVER(2) / '3CC00000'X,'00000000'X / XC DATA LOG10(1), DIVER(2) / '3FD34413'X,'509F79FF'X / XC XC MACHINE CONSTANTS FOR THE HARRIS 220 XC MACHINE CONSTANTS FOR THE HARRIS SLASH 6 AND SLASH 7 XC XC === MACHINE = HARRIS.220 XC === MACHINE = HARRIS.SLASH6 XC === MACHINE = HARRIS.SLASH7 XC DATA SMALL(1),SMALL(2) / '20000000, '00000201 / XC DATA LARGE(1),LARGE(2) / '37777777, '37777577 / XC DATA RIGHT(1),RIGHT(2) / '20000000, '00000333 / XC DATA DIVER(1),DIVER(2) / '20000000, '00000334 / XC DATA LOG10(1),LOG10(2) / '23210115, '10237777 / XC XC MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES. XC MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES. XC XC === MACHINE = HONEYWELL.600/6000 XC === MACHINE = HONEYWELL.DPS.8/70 XC DATA SMALL(1),SMALL(2) / O402400000000, O000000000000 / XC DATA LARGE(1),LARGE(2) / O376777777777, O777777777777 / XC DATA RIGHT(1),RIGHT(2) / O604400000000, O000000000000 / XC DATA DIVER(1),DIVER(2) / O606400000000, O000000000000 / XC DATA LOG10(1),LOG10(2) / O776464202324, O117571775714 / XC XC MACHINE CONSTANTS FOR THE HP 2100 XC 3 WORD DOUBLE PRECISION OPTION WITH FTN4 XC XC === MACHINE = HP.2100.3_WORD_DP XC DATA SMALL(1), SMALL(2), SMALL(3) / 40000B, 0, 1 / XC DATA LARGE(1), LARGE(2), LARGE(3) / 77777B, 177777B, 177776B / XC DATA RIGHT(1), RIGHT(2), RIGHT(3) / 40000B, 0, 265B / XC DATA DIVER(1), DIVER(2), DIVER(3) / 40000B, 0, 276B / XC DATA LOG10(1), LOG10(2), LOG10(3) / 46420B, 46502B, 77777B / XC XC MACHINE CONSTANTS FOR THE HP 2100 XC 4 WORD DOUBLE PRECISION OPTION WITH FTN4 XC XC === MACHINE = HP.2100.4_WORD_DP XC DATA SMALL(1), SMALL(2) / 40000B, 0 / XC DATA SMALL(3), SMALL(4) / 0, 1 / XC DATA LARGE(1), LARGE(2) / 77777B, 177777B / XC DATA LARGE(3), LARGE(4) / 177777B, 177776B / XC DATA RIGHT(1), RIGHT(2) / 40000B, 0 / XC DATA RIGHT(3), RIGHT(4) / 0, 225B / XC DATA DIVER(1), DIVER(2) / 40000B, 0 / XC DATA DIVER(3), DIVER(4) / 0, 227B / XC DATA LOG10(1), LOG10(2) / 46420B, 46502B / XC DATA LOG10(3), LOG10(4) / 76747B, 176377B / XC XC HP 9000 XC XC D1MACH(1) = 2.8480954D-306 XC D1MACH(2) = 1.40444776D+306 XC D1MACH(3) = 2.22044605D-16 XC D1MACH(4) = 4.44089210D-16 XC D1MACH(5) = 3.01029996D-1 XC XC === MACHINE = HP.9000 XC DATA SMALL(1), SMALL(2) / 00040000000B, 00000000000B / XC DATA LARGE(1), LARGE(2) / 17737777777B, 37777777777B / XC DATA RIGHT(1), RIGHT(2) / 07454000000B, 00000000000B / XC DATA DIVER(1), DIVER(2) / 07460000000B, 00000000000B / XC DATA LOG10(1), LOG10(2) / 07764642023B, 12047674777B / XC XC MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, XC THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND XC THE INTERDATA 3230 AND INTERDATA 7/32. XC XC === MACHINE = IBM.360 XC === MACHINE = IBM.370 XC === MACHINE = XEROX.SIGMA.5 XC === MACHINE = XEROX.SIGMA.7 XC === MACHINE = XEROX.SIGMA.9 XC === MACHINE = SEL.85 XC === MACHINE = SEL.86 XC === MACHINE = INTERDATA.3230 XC === MACHINE = INTERDATA.7/32 XC DATA SMALL(1),SMALL(2) / Z00100000, Z00000000 / XC DATA LARGE(1),LARGE(2) / Z7FFFFFFF, ZFFFFFFFF / XC DATA RIGHT(1),RIGHT(2) / Z33100000, Z00000000 / XC DATA DIVER(1),DIVER(2) / Z34100000, Z00000000 / XC DATA LOG10(1),LOG10(2) / Z41134413, Z509F79FF / XC XC MACHINE CONSTANTS FOR THE INTERDATA 8/32 XC WITH THE UNIX SYSTEM FORTRAN 77 COMPILER. XC XC FOR THE INTERDATA FORTRAN VII COMPILER REPLACE XC THE Z'S SPECIFYING HEX CONSTANTS WITH Y'S. XC XC === MACHINE = INTERDATA.8/32.UNIX XC DATA SMALL(1),SMALL(2) / Z'00100000', Z'00000000' / XC DATA LARGE(1),LARGE(2) / Z'7EFFFFFF', Z'FFFFFFFF' / XC DATA RIGHT(1),RIGHT(2) / Z'33100000', Z'00000000' / XC DATA DIVER(1),DIVER(2) / Z'34100000', Z'00000000' / XC DATA LOG10(1),LOG10(2) / Z'41134413', Z'509F79FF' / XC XC MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR). XC XC === MACHINE = PDP-10.KA XC DATA SMALL(1),SMALL(2) / "033400000000, "000000000000 / XC DATA LARGE(1),LARGE(2) / "377777777777, "344777777777 / XC DATA RIGHT(1),RIGHT(2) / "113400000000, "000000000000 / XC DATA DIVER(1),DIVER(2) / "114400000000, "000000000000 / XC DATA LOG10(1),LOG10(2) / "177464202324, "144117571776 / XC XC MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR). XC XC === MACHINE = PDP-10.KI XC DATA SMALL(1),SMALL(2) / "000400000000, "000000000000 / XC DATA LARGE(1),LARGE(2) / "377777777777, "377777777777 / XC DATA RIGHT(1),RIGHT(2) / "103400000000, "000000000000 / XC DATA DIVER(1),DIVER(2) / "104400000000, "000000000000 / XC DATA LOG10(1),LOG10(2) / "177464202324, "047674776746 / XC XC MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING XC 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). XC XC === MACHINE = PDP-11.32-BIT XC DATA SMALL(1),SMALL(2) / 8388608, 0 / XC DATA LARGE(1),LARGE(2) / 2147483647, -1 / XC DATA RIGHT(1),RIGHT(2) / 612368384, 0 / XC DATA DIVER(1),DIVER(2) / 620756992, 0 / XC DATA LOG10(1),LOG10(2) / 1067065498, -2063872008 / XC XC DATA SMALL(1),SMALL(2) / O00040000000, O00000000000 / XC DATA LARGE(1),LARGE(2) / O17777777777, O37777777777 / XC DATA RIGHT(1),RIGHT(2) / O04440000000, O00000000000 / XC DATA DIVER(1),DIVER(2) / O04500000000, O00000000000 / XC DATA LOG10(1),LOG10(2) / O07746420232, O20476747770 / XC XC MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING XC 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). XC XC === MACHINE = PDP-11.16-BIT XC DATA SMALL(1),SMALL(2) / 128, 0 / XC DATA SMALL(3),SMALL(4) / 0, 0 / XC DATA LARGE(1),LARGE(2) / 32767, -1 / XC DATA LARGE(3),LARGE(4) / -1, -1 / XC DATA RIGHT(1),RIGHT(2) / 9344, 0 / XC DATA RIGHT(3),RIGHT(4) / 0, 0 / XC DATA DIVER(1),DIVER(2) / 9472, 0 / XC DATA DIVER(3),DIVER(4) / 0, 0 / XC DATA LOG10(1),LOG10(2) / 16282, 8346 / XC DATA LOG10(3),LOG10(4) / -31493, -12296 / XC XC DATA SMALL(1),SMALL(2) / O000200, O000000 / XC DATA SMALL(3),SMALL(4) / O000000, O000000 / XC DATA LARGE(1),LARGE(2) / O077777, O177777 / XC DATA LARGE(3),LARGE(4) / O177777, O177777 / XC DATA RIGHT(1),RIGHT(2) / O022200, O000000 / XC DATA RIGHT(3),RIGHT(4) / O000000, O000000 / XC DATA DIVER(1),DIVER(2) / O022400, O000000 / XC DATA DIVER(3),DIVER(4) / O000000, O000000 / XC DATA LOG10(1),LOG10(2) / O037632, O020232 / XC DATA LOG10(3),LOG10(4) / O102373, O147770 / XC XC MACHINE CONSTANTS FOR THE SEQUENT BALANCE 8000 XC XC === MACHINE = SEQUENT.BALANCE.8000 XC DATA SMALL(1),SMALL(2) / $00000000, $00100000 / XC DATA LARGE(1),LARGE(2) / $FFFFFFFF, $7FEFFFFF / XC DATA RIGHT(1),RIGHT(2) / $00000000, $3CA00000 / XC DATA DIVER(1),DIVER(2) / $00000000, $3CB00000 / XC DATA LOG10(1),LOG10(2) / $509F79FF, $3FD34413 / XC XC MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. FTN COMPILER XC XC === MACHINE = UNIVAC.1100 XC DATA SMALL(1),SMALL(2) / O000040000000, O000000000000 / XC DATA LARGE(1),LARGE(2) / O377777777777, O777777777777 / XC DATA RIGHT(1),RIGHT(2) / O170540000000, O000000000000 / XC DATA DIVER(1),DIVER(2) / O170640000000, O000000000000 / XC DATA LOG10(1),LOG10(2) / O177746420232, O411757177572 / XC XC MACHINE CONSTANTS FOR VAX 11/780 XC (EXPRESSED IN INTEGER AND HEXADECIMAL) XC *** THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS*** XC XC === MACHINE = VAX.11/780 XC DATA SMALL(1), SMALL(2) / 128, 0 / XC DATA LARGE(1), LARGE(2) / -32769, -1 / XC DATA RIGHT(1), RIGHT(2) / 9344, 0 / XC DATA DIVER(1), DIVER(2) / 9472, 0 / XC DATA LOG10(1), LOG10(2) / 546979738, -805796613 / XC XC ***THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSYEMS*** XC DATA SMALL(1), SMALL(2) / Z00000080, Z00000000 / XC DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / XC DATA RIGHT(1), RIGHT(2) / Z00002480, Z00000000 / XC DATA DIVER(1), DIVER(2) / Z00002500, Z00000000 / XC DATA LOG10(1), LOG10(2) / Z209A3F9A, ZCFF884FB / XC XC MACHINE CONSTANTS FOR VAX 11/780 (G-FLOATING) XC (EXPRESSED IN INTEGER AND HEXADECIMAL) XC *** THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS*** XC XC DATA SMALL(1), SMALL(2) / 16, 0 / XC DATA LARGE(1), LARGE(2) / -32769, -1 / XC DATA RIGHT(1), RIGHT(2) / 15552, 0 / XC DATA DIVER(1), DIVER(2) / 15568, 0 / XC DATA LOG10(1), LOG10(2) / 1142112243, 2046775455 / XC XC ***THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSYEMS*** XC DATA SMALL(1), SMALL(2) / Z00000010, Z00000000 / XC DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / XC DATA RIGHT(1), RIGHT(2) / Z00003CC0, Z00000000 / XC DATA DIVER(1), DIVER(2) / Z00003CD0, Z00000000 / XC DATA LOG10(1), LOG10(2) / Z44133FF3, Z79FF509F / XC XC XC***FIRST EXECUTABLE STATEMENT D1MACH X IF (I .LT. 1 .OR. I .GT. 5) X 1 CALL XERROR( 'D1MACH -- I OUT OF BOUNDS',25,1,2) XC X D1MACH = DMACH(I) X RETURN XC X END X DOUBLE PRECISION FUNCTION D9GMIT(A,X,ALGAP1,SGNGAM,ALX) XC***BEGIN PROLOGUE D9GMIT XC***DATE WRITTEN 770701 (YYMMDD) XC***REVISION DATE 820801 (YYMMDD) XC***CATEGORY NO. C7E XC***KEYWORDS COMPLEMENTARY,COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, XC DOUBLE PRECISION,GAMMA,GAMMA FUNCTION,SPECIAL FUNCTION, XC TRICOMI XC***AUTHOR FULLERTON, W., (LANL) XC***PURPOSE Computes d.p. Tricomi-s incomplete Gamma function for XC small X. XC***DESCRIPTION XC XC Compute Tricomi's incomplete gamma function for small X. XC***REFERENCES (NONE) XC***ROUTINES CALLED D1MACH,DLNGAM,XERROR XC***END PROLOGUE D9GMIT X INTEGER K,M, MA X DOUBLE PRECISION A, X, ALGAP1, SGNGAM, ALX, AE, AEPS, ALGS, ALG2, X 1 BOT, EPS, FK, S, SGNG2, T, TE, D1MACH, DLNGAM X DATA EPS, BOT / 2*0.D0 / XC***FIRST EXECUTABLE STATEMENT D9GMIT X IF (EPS.NE.0.D0) GO TO 10 X EPS = 0.5D0*D1MACH(3) X BOT = DLOG (D1MACH(1)) XC X 10 IF (X.LE.0.D0) CALL XERROR ( 'D9GMIT X SHOULD BE GT 0', 24, 1, 2) XC X MA = A + 0.5D0 X IF (A.LT.0.D0) MA = A - 0.5D0 X AEPS = A - DBLE(FLOAT(MA)) XC X AE = A X IF (A.LT.(-0.5D0)) AE = AEPS XC X T = 1.D0 X TE = AE X S = T X DO 20 K=1,200 X FK = K X TE = -X*TE/FK X T = TE/(AE+FK) X S = S + T X IF (DABS(T).LT.EPS*DABS(S)) GO TO 30 X 20 CONTINUE X CALL XERROR ( 'D9GMIT NO CONVERGENCE IN 200 TERMS OF TAYLOR-S X 1SERIES', 54, 2, 2) XC X 30 IF (A.GE.(-0.5D0)) ALGS = -ALGAP1 + DLOG(S) X IF (A.GE.(-0.5D0)) GO TO 60 XC X ALGS = -DLNGAM(1.D0+AEPS) + DLOG(S) X S = 1.0D0 X M = -MA - 1 X IF (M.EQ.0) GO TO 50 X T = 1.0D0 X DO 40 K=1,M X T = X*T/(AEPS-DBLE(FLOAT(M+1-K))) X S = S + T X IF (DABS(T).LT.EPS*DABS(S)) GO TO 50 X 40 CONTINUE XC X 50 D9GMIT = 0.0D0 X ALGS = -DBLE(FLOAT(MA))*DLOG(X) + ALGS X IF (S.EQ.0.D0 .OR. AEPS.EQ.0.D0) GO TO 60 XC X SGNG2 = SGNGAM * DSIGN (1.0D0, S) X ALG2 = -X - ALGAP1 + DLOG(DABS(S)) XC X IF (ALG2.GT.BOT) D9GMIT = SGNG2 * DEXP(ALG2) X IF (ALGS.GT.BOT) D9GMIT = D9GMIT + DEXP(ALGS) X RETURN XC X 60 D9GMIT = DEXP (ALGS) X RETURN XC X END X DOUBLE PRECISION FUNCTION D9LGIC(A,X,ALX) XC***BEGIN PROLOGUE D9LGIC XC***DATE WRITTEN 770701 (YYMMDD) XC***REVISION DATE 820801 (YYMMDD) XC***CATEGORY NO. C7E XC***KEYWORDS DOUBLE PRECISION,GAMMA,INCOMPLETE GAMMA FUNCTION, XC LOGARITHM INCOMPLETE GAMMA FUNCTION,SPECIAL FUNCTION XC***AUTHOR FULLERTON, W., (LANL) XC***PURPOSE Computes the d.p. log incomplete Gamma function for large X XC and for A .LE. X. XC***DESCRIPTION XC XC Compute the log complementary incomplete gamma function for large X XC and for A .LE. X. XC***REFERENCES (NONE) XC***ROUTINES CALLED D1MACH,XERROR XC***END PROLOGUE D9LGIC X INTEGER K X DOUBLE PRECISION A, X, ALX, EPS, FK, P, R, S, T, XMA, XPA, D1MACH X DATA EPS / 0.D0 / XC***FIRST EXECUTABLE STATEMENT D9LGIC X IF (EPS.EQ.0.D0) EPS = 0.5D0*D1MACH(3) XC X XPA = X + 1.0D0 - A X XMA = X - 1.D0 - A XC X R = 0.D0 X P = 1.D0 X S = P X DO 10 K=1,300 X FK = K X T = FK*(A-FK)*(1.D0+R) X R = -T/((XMA+2.D0*FK)*(XPA+2.D0*FK)+T) X P = R*P X S = S + P X IF (DABS(P).LT.EPS*S) GO TO 20 X 10 CONTINUE X CALL XERROR ( 'D9LGIC NO CONVERGENCE IN 300 TERMS OF CONTINUED X 1FRACTION', 57, 1, 2) XC X 20 D9LGIC = A*ALX - X + DLOG(S/XPA) XC X RETURN X END X DOUBLE PRECISION FUNCTION D9LGIT(A,X,ALGAP1) XC***BEGIN PROLOGUE D9LGIT XC***DATE WRITTEN 770701 (YYMMDD) XC***REVISION DATE 820801 (YYMMDD) XC***CATEGORY NO. C7E XC***KEYWORDS DOUBLE PRECISION,GAMMA,INCOMPLETE GAMMA FUNCTION, XC LOGARITHM,SPECIAL FUNCTION,TRICOMI XC***AUTHOR FULLERTON, W., (LANL) XC***PURPOSE Computes the log of Tricomi's incomplete Gamma function XC with Perron's continued fraction for large X and A .GE. X. XC***DESCRIPTION XC XC Compute the log of Tricomi's incomplete gamma function with Perron's XC continued fraction for large X and for A .GE. X. XC***REFERENCES (NONE) XC***ROUTINES CALLED D1MACH,XERROR XC***END PROLOGUE D9LGIT X INTEGER K X DOUBLE PRECISION A, X, ALGAP1, AX, A1X, EPS, FK, HSTAR, P, R, S, X 1 SQEPS, T, D1MACH X DATA EPS, SQEPS / 2*0.D0 / XC***FIRST EXECUTABLE STATEMENT D9LGIT X IF (EPS.NE.0.D0) GO TO 10 X EPS = 0.5D0*D1MACH(3) X SQEPS = DSQRT (D1MACH(4)) XC X 10 IF (X.LE.0.D0 .OR. A.LT.X) CALL XERROR ( 'D9LGIT X SHOULD BE GT 0 X 1.0 AND LE A', 35, 2, 2) XC X AX = A + X X A1X = AX + 1.0D0 X R = 0.D0 X P = 1.D0 X S = P X DO 20 K=1,200 X FK = K X T = (A+FK)*X*(1.D0+R) X R = T/((AX+FK)*(A1X+FK)-T) X P = R*P X S = S + P X IF (DABS(P).LT.EPS*S) GO TO 30 X 20 CONTINUE X CALL XERROR ( 'D9LGIT NO CONVERGENCE IN 200 TERMS OF CONTINUED X 1FRACTION', 57, 3, 2) XC X 30 HSTAR = 1.0D0 - X*S/A1X X IF (HSTAR.LT.SQEPS) CALL XERROR ( 'D9LGIT RESULT LESS THAN HALF X 1PRECISION', 39, 1, 1) XC X D9LGIT = -X - ALGAP1 - DLOG(HSTAR) X RETURN XC X END X DOUBLE PRECISION FUNCTION D9LGMC(X) XC***BEGIN PROLOGUE D9LGMC XC***DATE WRITTEN 770601 (YYMMDD) XC***REVISION DATE 820801 (YYMMDD) XC***CATEGORY NO. C7E XC***KEYWORDS COMPLETE GAMMA FUNCTION,CORRECTION FACTOR, XC DOUBLE PRECISION,GAMMA FUNCTION,LOGARITHM, XC SPECIAL FUNCTION XC***AUTHOR FULLERTON, W., (LANL) XC***PURPOSE Computes the d.p. log Gamma correction factor for XC X .GE. 10. so that DLOG(DGAMMA(X)) = DLOG(DSQRT(2*PI)) + XC (X-5.)*DLOG(X) - X + D9LGMC(X) XC***DESCRIPTION XC XC Compute the log gamma correction factor for X .GE. 10. so that XC DLOG (DGAMMA(X)) = DLOG(DSQRT(2*PI)) + (X-.5)*DLOG(X) - X + D9lGMC(X) XC XC Series for ALGM on the interval 0. to 1.00000E-02 XC with weighted error 1.28E-31 XC log weighted error 30.89 XC significant figures required 29.81 XC decimal places required 31.48 XC***REFERENCES (NONE) XC***ROUTINES CALLED D1MACH,DCSEVL,INITDS,XERROR XC***END PROLOGUE D9LGMC X INTEGER INITDS X INTEGER NALGM X DOUBLE PRECISION X, ALGMCS(15), XBIG, XMAX, DCSEVL X DATA ALGMCS( 1) / +.1666389480 4518632472 0572965082 2 D+0 / X DATA ALGMCS( 2) / -.1384948176 0675638407 3298605913 5 D-4 / X DATA ALGMCS( 3) / +.9810825646 9247294261 5717154748 7 D-8 / X DATA ALGMCS( 4) / -.1809129475 5724941942 6330626671 9 D-10 / X DATA ALGMCS( 5) / +.6221098041 8926052271 2601554341 6 D-13 / X DATA ALGMCS( 6) / -.3399615005 4177219443 0333059966 6 D-15 / X DATA ALGMCS( 7) / +.2683181998 4826987489 5753884666 6 D-17 / X DATA ALGMCS( 8) / -.2868042435 3346432841 4462239999 9 D-19 / X DATA ALGMCS( 9) / +.3962837061 0464348036 7930666666 6 D-21 / X DATA ALGMCS( 10) / -.6831888753 9857668701 1199999999 9 D-23 / X DATA ALGMCS( 11) / +.1429227355 9424981475 7333333333 3 D-24 / X DATA ALGMCS( 12) / -.3547598158 1010705471 9999999999 9 D-26 / X DATA ALGMCS( 13) / +.1025680058 0104709120 0000000000 0 D-27 / X DATA ALGMCS( 14) / -.3401102254 3167487999 9999999999 9 D-29 / X DATA ALGMCS( 15) / +.1276642195 6300629333 3333333333 3 D-30 / X DATA NALGM, XBIG, XMAX / 0, 2*0.D0 / XC***FIRST EXECUTABLE STATEMENT D9LGMC X DOUBLE PRECISION D1MACH X IF (NALGM.NE.0) GO TO 10 X NALGM = INITDS (ALGMCS, 15, SNGL(D1MACH(3)) ) X XBIG = 1.0D0/DSQRT(D1MACH(3)) X XMAX = DEXP (DMIN1(DLOG(D1MACH(2)/12.D0), -DLOG(12.D0*D1MACH(1)))) XC X 10 IF (X.LT.10.D0) CALL XERROR ( 'D9LGMC X MUST BE GE 10', 23, 1, 2) X IF (X.GE.XMAX) GO TO 20 XC X D9LGMC = 1.D0/(12.D0*X) X IF (X.LT.XBIG) D9LGMC = DCSEVL (2.0D0*(10.D0/X)**2-1.D0, ALGMCS, X 1 NALGM) / X X RETURN XC X 20 D9LGMC = 0.D0 X CALL XERROR ( 'D9LGMC X SO BIG D9LGMC UNDERFLOWS', 34, 2, 1) X RETURN XC X END X DOUBLE PRECISION FUNCTION DCSEVL(X,A,N) XC***BEGIN PROLOGUE DCSEVL XC***DATE WRITTEN 770401 (YYMMDD) XC***REVISION DATE 820801 (YYMMDD) XC***CATEGORY NO. C3A2 XC***KEYWORDS CHEBYSHEV,FNLIB,SPECIAL FUNCTION XC***AUTHOR FULLERTON, W., (LANL) XC***PURPOSE Evaluate the double precision N-term Chebyshev series A XC at X. XC***DESCRIPTION XC XC Evaluate the N-term Chebyshev series A at X. Adapted from XC R. Broucke, Algorithm 446, C.A.C.M., 16, 254 (1973). XC W. Fullerton, C-3, Los Alamos Scientific Laboratory. XC XC Input Arguments -- XC X double precision value at which the series is to be evaluated. XC A double precision array of N terms of a Chebyshev series. In XC evaluating A, only half of the first coefficient is summed. XC N number of terms in array A. XC***REFERENCES (NONE) XC***ROUTINES CALLED XERROR XC***END PROLOGUE DCSEVL XC X INTEGER I, N, NI X DOUBLE PRECISION A(N),X,TWOX,B0,B1,B2 XC***FIRST EXECUTABLE STATEMENT DCSEVL X IF(N.LT.1)CALL XERROR( 'DCSEVL NUMBER OF TERMS LE 0', 28, 2,2) X IF(N.GT.1000) CALL XERROR ( 'DCSEVL NUMBER OF TERMS GT 1000', X 1 31, 3, 2) X IF ((X.LT.-1.D0) .OR. (X.GT.1.D0)) CALL XERROR ( 'DCSEVL X OUTSI X 1DE (-1,+1)', 25, 1, 1) XC X TWOX = 2.0D0*X X B1 = 0.D0 X B0=0.D0 X DO 10 I=1,N X B2=B1 X B1=B0 X NI = N - I + 1 X B0 = TWOX*B1 - B2 + A(NI) X 10 CONTINUE XC X DCSEVL = 0.5D0 * (B0-B2) XC X RETURN X END X DOUBLE PRECISION FUNCTION DGAMMA(X) XC***BEGIN PROLOGUE DGAMMA XC***DATE WRITTEN 770601 (YYMMDD) XC***REVISION DATE 820801 (YYMMDD) XC***CATEGORY NO. C7A XC***KEYWORDS COMPLETE GAMMA FUNCTION,DOUBLE PRECISION,GAMMA FUNCTION, XC SPECIAL FUNCTION XC***AUTHOR FULLERTON, W., (LANL) XC***PURPOSE Computes the d.p. complete Gamma function. XC***DESCRIPTION XC XC DGAMMA(X) calculates the double precision complete gamma function XC for double precision argument X. XC XC Series for GAM on the interval 0. to 1.00000E+00 XC with weighted error 5.79E-32 XC log weighted error 31.24 XC significant figures required 30.00 XC decimal places required 32.05 XC***REFERENCES (NONE) XC***ROUTINES CALLED D1MACH,D9LGMC,DCSEVL,DGAMLM,DINT,INITDS,XERROR XC***END PROLOGUE DGAMMA X INTEGER I, N, NGAM X DOUBLE PRECISION X, GAMCS(42), DXREL, PI, SINPIY, SQ2PIL, XMAX, X 1 XMIN, Y, DINT, D9LGMC, DCSEVL, D1MACH XC X DATA GAM CS( 1) / +.8571195590 9893314219 2006239994 2 D-2 / X DATA GAM CS( 2) / +.4415381324 8410067571 9131577165 2 D-2 / X DATA GAM CS( 3) / +.5685043681 5993633786 3266458878 9 D-1 / X DATA GAM CS( 4) / -.4219835396 4185605010 1250018662 4 D-2 / X DATA GAM CS( 5) / +.1326808181 2124602205 8400679635 2 D-2 / X DATA GAM CS( 6) / -.1893024529 7988804325 2394702388 6 D-3 / X DATA GAM CS( 7) / +.3606925327 4412452565 7808221722 5 D-4 / X DATA GAM CS( 8) / -.6056761904 4608642184 8554829036 5 D-5 / X DATA GAM CS( 9) / +.1055829546 3022833447 3182350909 3 D-5 / X DATA GAM CS( 10) / -.1811967365 5423840482 9185589116 6 D-6 / X DATA GAM CS( 11) / +.3117724964 7153222777 9025459316 9 D-7 / X DATA GAM CS( 12) / -.5354219639 0196871408 7408102434 7 D-8 / X DATA GAM CS( 13) / +.9193275519 8595889468 8778682594 0 D-9 / X DATA GAM CS( 14) / -.1577941280 2883397617 6742327395 3 D-9 / X DATA GAM CS( 15) / +.2707980622 9349545432 6654043308 9 D-10 / X DATA GAM CS( 16) / -.4646818653 8257301440 8166105893 3 D-11 / X DATA GAM CS( 17) / +.7973350192 0074196564 6076717535 9 D-12 / X DATA GAM CS( 18) / -.1368078209 8309160257 9949917230 9 D-12 / X DATA GAM CS( 19) / +.2347319486 5638006572 3347177168 8 D-13 / X DATA GAM CS( 20) / -.4027432614 9490669327 6657053469 9 D-14 / X DATA GAM CS( 21) / +.6910051747 3721009121 3833697525 7 D-15 / X DATA GAM CS( 22) / -.1185584500 2219929070 5238712619 2 D-15 / X DATA GAM CS( 23) / +.2034148542 4963739552 0102605193 2 D-16 / X DATA GAM CS( 24) / -.3490054341 7174058492 7401294910 8 D-17 / X DATA GAM CS( 25) / +.5987993856 4853055671 3505106602 6 D-18 / X DATA GAM CS( 26) / -.1027378057 8722280744 9006977843 1 D-18 / X DATA GAM CS( 27) / +.1762702816 0605298249 4275966074 8 D-19 / X DATA GAM CS( 28) / -.3024320653 7353062609 5877211204 2 D-20 / X DATA GAM CS( 29) / +.5188914660 2183978397 1783355050 6 D-21 / X DATA GAM CS( 30) / -.8902770842 4565766924 4925160106 6 D-22 / X DATA GAM CS( 31) / +.1527474068 4933426022 7459689130 6 D-22 / X DATA GAM CS( 32) / -.2620731256 1873629002 5732833279 9 D-23 / X DATA GAM CS( 33) / +.4496464047 8305386703 3104657066 6 D-24 / X DATA GAM CS( 34) / -.7714712731 3368779117 0390152533 3 D-25 / X DATA GAM CS( 35) / +.1323635453 1260440364 8657271466 6 D-25 / X DATA GAM CS( 36) / -.2270999412 9429288167 0231381333 3 D-26 / X DATA GAM CS( 37) / +.3896418998 0039914493 2081663999 9 D-27 / X DATA GAM CS( 38) / -.6685198115 1259533277 9212799999 9 D-28 / X DATA GAM CS( 39) / +.1146998663 1400243843 4761386666 6 D-28 / X DATA GAM CS( 40) / -.1967938586 3451346772 9510399999 9 D-29 / X DATA GAM CS( 41) / +.3376448816 5853380903 3489066666 6 D-30 / X DATA GAM CS( 42) / -.5793070335 7821357846 2549333333 3 D-31 / X DATA PI / 3.1415926535 8979323846 2643383279 50 D0 / X DATA SQ2PIL / 0.9189385332 0467274178 0329736405 62 D0 / X DATA NGAM, XMIN, XMAX, DXREL / 0, 3*0.D0 / XC***FIRST EXECUTABLE STATEMENT DGAMMA X INTEGER INITDS X IF (NGAM.NE.0) GO TO 10 X NGAM = INITDS (GAMCS, 42, 0.1*SNGL(D1MACH(3)) ) XC X CALL DGAMLM (XMIN, XMAX) X DXREL = DSQRT (D1MACH(4)) XC X 10 Y = DABS(X) X IF (Y.GT.10.D0) GO TO 50 XC XC COMPUTE GAMMA(X) FOR -XBND .LE. X .LE. XBND. REDUCE INTERVAL AND FIND XC GAMMA(1+Y) FOR 0.0 .LE. Y .LT. 1.0 FIRST OF ALL. XC X N = X X IF (X.LT.0.D0) N = N - 1 X Y = X - DBLE(FLOAT(N)) X N = N - 1 X DGAMMA = 0.9375D0 + DCSEVL (2.D0*Y-1.D0, GAMCS, NGAM) X IF (N.EQ.0) RETURN XC X IF (N.GT.0) GO TO 30 XC XC COMPUTE GAMMA(X) FOR X .LT. 1.0 XC X N = -N X IF (X.EQ.0.D0) CALL XERROR ( 'DGAMMA X IS 0', 14, 4, 2) X IF (X.LT.0.0 .AND. X+DBLE(FLOAT(N-2)).EQ.0.D0) CALL XERROR ( 'DGAM X 1MA X IS A NEGATIVE INTEGER', 31, 4, 2) X IF (X.LT.(-0.5D0) .AND. DABS((X-DINT(X-0.5D0))/X).LT.DXREL) CALL X 1 XERROR ( 'DGAMMA ANSWER LT HALF PRECISION BECAUSE X TOO NEAR X 2NEGATIVE INTEGER', 68, 1, 1) XC X DO 20 I=1,N X DGAMMA = DGAMMA/(X+DBLE(FLOAT(I-1)) ) X 20 CONTINUE X RETURN XC XC GAMMA(X) FOR X .GE. 2.0 AND X .LE. 10.0 XC X 30 DO 40 I=1,N X DGAMMA = (Y+DBLE(FLOAT(I))) * DGAMMA X 40 CONTINUE X RETURN XC XC GAMMA(X) FOR DABS(X) .GT. 10.0. RECALL Y = DABS(X). XC X 50 IF (X.GT.XMAX) CALL XERROR ( 'DGAMMA X SO BIG GAMMA OVERFLOWS', X 1 32, 3, 2) XC X DGAMMA = 0.D0 X IF (X.LT.XMIN) CALL XERROR ( 'DGAMMA X SO SMALL GAMMA UNDERFLOWS' X 1 , 35, 2, 1) X IF (X.LT.XMIN) RETURN XC X DGAMMA = DEXP ((Y-0.5D0)*DLOG(Y) - Y + SQ2PIL + D9LGMC(Y) ) X IF (X.GT.0.D0) RETURN XC X IF (DABS((X-DINT(X-0.5D0))/X).LT.DXREL) CALL XERROR ( 'DGAMMA ANS X 1WER LT HALF PRECISION, X TOO NEAR NEGATIVE INTEGER' , 61, 1, 1) XC X SINPIY = DSIN (PI*Y) X IF (SINPIY.EQ.0.D0) CALL XERROR ( 'DGAMMA X IS A NEGATIVE INTEGER X 1', 31, 4, 2) XC X DGAMMA = -PI/(Y*SINPIY*DGAMMA) XC X RETURN X END X SUBROUTINE FDUMP XC***BEGIN PROLOGUE FDUMP XC***DATE WRITTEN 790801 (YYMMDD) XC***REVISION DATE 820801 (YYMMDD) XC***CATEGORY NO. Z XC***KEYWORDS ERROR,XERROR PACKAGE XC***AUTHOR JONES, R. E., (SNLA) XC***PURPOSE Symbolic dump (should be locally written). XC***DESCRIPTION XC ***Note*** Machine Dependent Routine XC FDUMP is intended to be replaced by a locally written XC version which produces a symbolic dump. Failing this, XC it should be replaced by a version which prints the XC subprogram nesting list. Note that this dump must be XC printed on each of up to five files, as indicated by the XC XGETUA routine. See XSETUA and XGETUA for details. XC XC Written by Ron Jones, with SLATEC Common Math Library Subcommittee XC Latest revision --- 23 May 1979 XC***ROUTINES CALLED (NONE) XC***END PROLOGUE FDUMP XC***FIRST EXECUTABLE STATEMENT FDUMP X RETURN X END X INTEGER FUNCTION I1MACH(I) XC***BEGIN PROLOGUE I1MACH XC***DATE WRITTEN 750101 (YYMMDD) XC***REVISION DATE 910131 (YYMMDD) XC***CATEGORY NO. R1 XC***KEYWORDS MACHINE CONSTANTS XC***AUTHOR FOX, P. A., (BELL LABS) XC HALL, A. D., (BELL LABS) XC SCHRYER, N. L., (BELL LABS) XC***PURPOSE Returns integer machine dependent constants XC***DESCRIPTION XC XC This is the CMLIB version of I1MACH, the integer machine XC constants subroutine originally developed for the PORT library. XC XC I1MACH can be used to obtain machine-dependent parameters XC for the local machine environment. It is a function XC subroutine with one (input) argument, and can be called XC as follows, for example XC XC K = I1MACH(I) XC XC where I=1,...,16. The (output) value of K above is XC determined by the (input) value of I. The results for XC various values of I are discussed below. XC XC I/O unit numbers. XC I1MACH( 1) = the standard input unit. XC I1MACH( 2) = the standard output unit. XC I1MACH( 3) = the standard punch unit. XC I1MACH( 4) = the standard error message unit. XC XC Words. XC I1MACH( 5) = the number of bits per integer storage unit. XC I1MACH( 6) = the number of characters per integer storage unit. XC XC Integers. XC assume integers are represented in the S-digit, base-A form XC XC sign ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) ) XC XC where 0 .LE. X(I) .LT. A for I=0,...,S-1. XC I1MACH( 7) = A, the base. XC I1MACH( 8) = S, the number of base-A digits. XC I1MACH( 9) = A**S - 1, the largest magnitude. XC XC Floating-Point Numbers. XC Assume floating-point numbers are represented in the T-digit, XC base-B form XC sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) XC XC where 0 .LE. X(I) .LT. B for I=1,...,T, XC 0 .LT. X(1), and EMIN .LE. E .LE. EMAX. XC I1MACH(10) = B, the base. XC XC Single-Precision XC I1MACH(11) = T, the number of base-B digits. XC I1MACH(12) = EMIN, the smallest exponent E. XC I1MACH(13) = EMAX, the largest exponent E. XC XC Double-Precision XC I1MACH(14) = T, the number of base-B digits. XC I1MACH(15) = EMIN, the smallest exponent E. XC I1MACH(16) = EMAX, the largest exponent E. XC XC To alter this function for a particular environment, XC the desired set of DATA statements should be activated by XC removing the C from column 1. Also, the values of XC I1MACH(1) - I1MACH(4) should be checked for consistency XC with the local operating system. XC***REFERENCES FOX P.A., HALL A.D., SCHRYER N.L.,*FRAMEWORK FOR A XC PORTABLE LIBRARY*, ACM TRANSACTIONS ON MATHEMATICAL XC SOFTWARE, VOL. 4, NO. 2, JUNE 1978, PP. 177-188. XC***ROUTINES CALLED (NONE) XC***END PROLOGUE I1MACH XC X INTEGER IMACH(16),OUTPUT, I X EQUIVALENCE (IMACH(4),OUTPUT) XC XC MACHINE CONSTANTS FOR IEEE ARITHMETIC MACHINES, SUCH AS THE AT&T XC 3B SERIES, MOTOROLA 68000 BASED MACHINES (E.G. SUN 3 AND AT&T XC PC 7300), AND 8087 BASED MICROS (E.G. IBM PC AND AT&T 6300). XC XC === MACHINE = IEEE.MOST-SIG-BYTE-FIRST XC === MACHINE = IEEE.LEAST-SIG-BYTE-FIRST XC === MACHINE = SUN XC === MACHINE = 68000 XC === MACHINE = 8087 XC === MACHINE = IBM.PC XC === MACHINE = ATT.3B XC === MACHINE = ATT.7300 XC === MACHINE = ATT.6300 X DATA IMACH( 1) / 5 / X DATA IMACH( 2) / 6 / X DATA IMACH( 3) / 7 / X DATA IMACH( 4) / 6 / X DATA IMACH( 5) / 32 / X DATA IMACH( 6) / 4 / X DATA IMACH( 7) / 2 / X DATA IMACH( 8) / 31 / X DATA IMACH( 9) / 2147483647 / X DATA IMACH(10) / 2 / X DATA IMACH(11) / 24 / X DATA IMACH(12) / -125 / X DATA IMACH(13) / 128 / X DATA IMACH(14) / 53 / X DATA IMACH(15) / -1021 / X DATA IMACH(16) / 1024 / XC XC MACHINE CONSTANTS FOR AMDAHL MACHINES. XC XC === MACHINE = AMDAHL XC DATA IMACH( 1) / 5 / XC DATA IMACH( 2) / 6 / XC DATA IMACH( 3) / 7 / XC DATA IMACH( 4) / 6 / XC DATA IMACH( 5) / 32 / XC DATA IMACH( 6) / 4 / XC DATA IMACH( 7) / 2 / XC DATA IMACH( 8) / 31 / XC DATA IMACH( 9) / 2147483647 / XC DATA IMACH(10) / 16 / XC DATA IMACH(11) / 6 / XC DATA IMACH(12) / -64 / XC DATA IMACH(13) / 63 / XC DATA IMACH(14) / 14 / XC DATA IMACH(15) / -64 / XC DATA IMACH(16) / 63 / XC XC MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM. XC XC === MACHINE = BURROUGHS.1700 XC DATA IMACH( 1) / 7 / XC DATA IMACH( 2) / 2 / XC DATA IMACH( 3) / 2 / XC DATA IMACH( 4) / 2 / XC DATA IMACH( 5) / 36 / XC DATA IMACH( 6) / 4 / XC DATA IMACH( 7) / 2 / XC DATA IMACH( 8) / 33 / XC DATA IMACH( 9) / Z1FFFFFFFF / XC DATA IMACH(10) / 2 / XC DATA IMACH(11) / 24 / XC DATA IMACH(12) / -256 / XC DATA IMACH(13) / 255 / XC DATA IMACH(14) / 60 / XC DATA IMACH(15) / -256 / XC DATA IMACH(16) / 255 / XC XC MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM. XC XC === MACHINE = BURROUGHS.5700 XC DATA IMACH( 1) / 5 / XC DATA IMACH( 2) / 6 / XC DATA IMACH( 3) / 7 / XC DATA IMACH( 4) / 6 / XC DATA IMACH( 5) / 48 / XC DATA IMACH( 6) / 6 / XC DATA IMACH( 7) / 2 / XC DATA IMACH( 8) / 39 / XC DATA IMACH( 9) / O0007777777777777 / XC DATA IMACH(10) / 8 / XC DATA IMACH(11) / 13 / XC DATA IMACH(12) / -50 / XC DATA IMACH(13) / 76 / XC DATA IMACH(14) / 26 / XC DATA IMACH(15) / -50 / XC DATA IMACH(16) / 76 / XC XC MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS. XC XC === MACHINE = BURROUGHS.6700 XC === MACHINE = BURROUGHS.7700 XC DATA IMACH( 1) / 5 / XC DATA IMACH( 2) / 6 / XC DATA IMACH( 3) / 7 / XC DATA IMACH( 4) / 6 / XC DATA IMACH( 5) / 48 / XC DATA IMACH( 6) / 6 / XC DATA IMACH( 7) / 2 / XC DATA IMACH( 8) / 39 / XC DATA IMACH( 9) / O0007777777777777 / XC DATA IMACH(10) / 8 / XC DATA IMACH(11) / 13 / XC DATA IMACH(12) / -50 / XC DATA IMACH(13) / 76 / XC DATA IMACH(14) / 26 / XC DATA IMACH(15) / -32754 / XC DATA IMACH(16) / 32780 / XC XC MACHINE CONSTANTS FOR THE CONVEX C-120 (NATIVE MODE) XC XC === MACHINE = CONVEX.C1 XC DATA IMACH( 1) / 5 / XC DATA IMACH( 2) / 6 / XC DATA IMACH( 3) / 0 / XC DATA IMACH( 4) / 6 / XC DATA IMACH( 5) / 32 / XC DATA IMACH( 6) / 4 / XC DATA IMACH( 7) / 2 / XC DATA IMACH( 8) / 31 / XC DATA IMACH( 9) / 2147483647 / XC DATA IMACH(10) / 2 / XC DATA IMACH(11) / 24 / XC DATA IMACH(12) / -127 / XC DATA IMACH(13) / 127 / XC DATA IMACH(14) / 53 / XC DATA IMACH(15) / -1023 / XC DATA IMACH(16) / 1023 / XC XC MACHINE CONSTANTS FOR THE CONVEX (NATIVE MODE) XC WITH -R8 OPTION XC XC === MACHINE = CONVEX.C1.R8 XC DATA IMACH( 1) / 5 / XC DATA IMACH( 2) / 6 / XC DATA IMACH( 3) / 0 / XC DATA IMACH( 4) / 6 / XC DATA IMACH( 5) / 32 / XC DATA IMACH( 6) / 4 / XC DATA IMACH( 7) / 2 / XC DATA IMACH( 8) / 31 / XC DATA IMACH( 9) / 2147483647 / XC DATA IMACH(10) / 2 / XC DATA IMACH(11) / 53 / XC DATA IMACH(12) / -1023 / XC DATA IMACH(13) / 1023 / XC DATA IMACH(14) / 53 / XC DATA IMACH(15) / -1023 / XC DATA IMACH(16) / 1023 / XC XC MACHINE CONSTANTS FOR THE CONVEX C-120 (IEEE MODE) XC XC === MACHINE = CONVEX.C1.IEEE XC DATA IMACH( 1) / 5 / XC DATA IMACH( 2) / 6 / XC DATA IMACH( 3) / 0 / XC DATA IMACH( 4) / 6 / XC DATA IMACH( 5) / 32 / XC DATA IMACH( 6) / 4 / XC DATA IMACH( 7) / 2 / XC DATA IMACH( 8) / 31 / XC DATA IMACH( 9) / 2147483647 / XC DATA IMACH(10) / 2 / XC DATA IMACH(11) / 24 / XC DATA IMACH(12) / -125 / XC DATA IMACH(13) / 128 / XC DATA IMACH(14) / 53 / XC DATA IMACH(15) / -1021 / XC DATA IMACH(16) / 1024 / XC XC MACHINE CONSTANTS FOR THE CONVEX (IEEE MODE) XC WITH -R8 OPTION XC XC === MACHINE = CONVEX.C1.IEEE.R8 XC DATA IMACH( 1) / 5 / XC DATA IMACH( 2) / 6 / XC DATA IMACH( 3) / 0 / XC DATA IMACH( 4) / 6 / XC DATA IMACH( 5) / 32 / XC DATA IMACH( 6) / 4 / XC DATA IMACH( 7) / 2 / XC DATA IMACH( 8) / 31 / XC DATA IMACH( 9) / 2147483647 / XC DATA IMACH(10) / 2 / XC DATA IMACH(11) / 53 / XC DATA IMACH(12) / -1021 / XC DATA IMACH(13) / 1024 / XC DATA IMACH(14) / 53 / XC DATA IMACH(15) / -1021 / XC DATA IMACH(16) / 1024 / XC XC MACHINE CONSTANTS FOR THE CYBER 170/180 SERIES USING NOS (FTN5). XC XC === MACHINE = CYBER.170.NOS XC === MACHINE = CYBER.180.NOS XC DATA IMACH( 1) / 5 / XC DATA IMACH( 2) / 6 / XC DATA IMACH( 3) / 7 / XC DATA IMACH( 4) / 6 / XC DATA IMACH( 5) / 60 / XC DATA IMACH( 6) / 10 / XC DATA IMACH( 7) / 2 / XC DATA IMACH( 8) / 48 / XC DATA IMACH( 9) / O"00007777777777777777" / XC DATA IMACH(10) / 2 / XC DATA IMACH(11) / 48 / XC DATA IMACH(12) / -974 / XC DATA IMACH(13) / 1070 / XC DATA IMACH(14) / 96 / XC DATA IMACH(15) / -927 / XC DATA IMACH(16) / 1070 / XC XC MACHINE CONSTANTS FOR THE CDC 180 SERIES USING NOS/VE XC XC === MACHINE = CYBER.180.NOS/VE XC DATA IMACH( 1) / 5 / XC DATA IMACH( 2) / 6 / XC DATA IMACH( 3) / 7 / XC DATA IMACH( 4) / 6 / XC DATA IMACH( 5) / 64 / XC DATA IMACH( 6) / 8 / XC DATA IMACH( 7) / 2 / XC DATA IMACH( 8) / 63 / XC DATA IMACH( 9) / 9223372036854775807 / XC DATA IMACH(10) / 2 / XC DATA IMACH(11) / 47 / XC DATA IMACH(12) / -4095 / XC DATA IMACH(13) / 4094 / XC DATA IMACH(14) / 94 / XC DATA IMACH(15) / -4095 / XC DATA IMACH(16) / 4094 / XC XC MACHINE CONSTANTS FOR THE CYBER 205 XC XC === MACHINE = CYBER.205 XC DATA IMACH( 1) / 5 / XC DATA IMACH( 2) / 6 / XC DATA IMACH( 3) / 7 / XC DATA IMACH( 4) / 6 / XC DATA IMACH( 5) / 64 / XC DATA IMACH( 6) / 8 / XC DATA IMACH( 7) / 2 / XC DATA IMACH( 8) / 47 / XC DATA IMACH( 9) / X'00007FFFFFFFFFFF' / XC DATA IMACH(10) / 2 / XC DATA IMACH(11) / 47 / XC DATA IMACH(12) / -28625 / XC DATA IMACH(13) / 28718 / XC DATA IMACH(14) / 94 / XC DATA IMACH(15) / -28625 / XC DATA IMACH(16) / 28718 / XC XC MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES. XC XC === MACHINE = CDC.6000 XC === MACHINE = CDC.7000 XC DATA IMACH( 1) / 5 / XC DATA IMACH( 2) / 6 / XC DATA IMACH( 3) / 7 / XC DATA IMACH( 4) / 6 / XC DATA IMACH( 5) / 60 / XC DATA IMACH( 6) / 10 / XC DATA IMACH( 7) / 2 / XC DATA IMACH( 8) / 48 / XC DATA IMACH( 9) / 00007777777777777777B / XC DATA IMACH(10) / 2 / XC DATA IMACH(11) / 48 / XC DATA IMACH(12) / -974 / XC DATA IMACH(13) / 1070 / XC DATA IMACH(14) / 96 / XC DATA IMACH(15) / -927 / XC DATA IMACH(16) / 1070 / XC XC MACHINE CONSTANTS FOR THE CRAY 1, XMP, 2, AND 3. XC USING THE 46 BIT INTEGER COMPILER OPTION XC XC === MACHINE = CRAY.46-BIT-INTEGER XC DATA IMACH( 1) / 5 / XC DATA IMACH( 2) / 6 / XC DATA IMACH( 3) / 102 / XC DATA IMACH( 4) / 6 / XC DATA IMACH( 5) / 64 / XC DATA IMACH( 6) / 8 / XC DATA IMACH( 7) / 2 / XC DATA IMACH( 8) / 46 / XC DATA IMACH( 9) / 777777777777777777777B / XC DATA IMACH(10) / 2 / XC DATA IMACH(11) / 47 / XC DATA IMACH(12) / -8189 / XC DATA IMACH(13) / 8190 / XC DATA IMACH(14) / 94 / XC DATA IMACH(15) / -8099 / XC DATA IMACH(16) / 8190 / XC XC MACHINE CONSTANTS FOR THE CRAY 1, XMP, 2, AND 3. XC USING THE 64 BIT INTEGER COMPILER OPTION XC XC === MACHINE = CRAY.64-BIT-INTEGER XC DATA IMACH( 1) / 5 / XC DATA IMACH( 2) / 6 / XC DATA IMACH( 3) / 102 / XC DATA IMACH( 4) / 6 / XC DATA IMACH( 5) / 64 / XC DATA IMACH( 6) / 8 / XC DATA IMACH( 7) / 2 / XC DATA IMACH( 8) / 63 / XC DATA IMACH( 9) / 777777777777777777777B / XC DATA IMACH(10) / 2 / XC DATA IMACH(11) / 47 / XC DATA IMACH(12) / -8189 / XC DATA IMACH(13) / 8190 / XC DATA IMACH(14) / 94 / XC DATA IMACH(15) / -8099 / XC DATA IMACH(16) / 8190 /C XC MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 XC XC === MACHINE = DATA_GENERAL.ECLIPSE.S/200 XC DATA IMACH( 1) / 11 / XC DATA IMACH( 2) / 12 / XC DATA IMACH( 3) / 8 / XC DATA IMACH( 4) / 10 / XC DATA IMACH( 5) / 16 / XC DATA IMACH( 6) / 2 / XC DATA IMACH( 7) / 2 / XC DATA IMACH( 8) / 15 / XC DATA IMACH( 9) /32767 / XC DATA IMACH(10) / 16 / XC DATA IMACH(11) / 6 / XC DATA IMACH(12) / -64 / XC DATA IMACH(13) / 63 / XC DATA IMACH(14) / 14 / XC DATA IMACH(15) / -64 / XC DATA IMACH(16) / 63 / XC XC ELXSI 6400 XC XC === MACHINE = ELSXI.6400 XC DATA IMACH( 1) / 5 / XC DATA IMACH( 2) / 6 / XC DATA IMACH( 3) / 6 / XC DATA IMACH( 4) / 6 / XC DATA IMACH( 5) / 32 / XC DATA IMACH( 6) / 4 / XC DATA IMACH( 7) / 2 / XC DATA IMACH( 8) / 32 / XC DATA IMACH( 9) / 2147483647 / XC DATA IMACH(10) / 2 / XC DATA IMACH(11) / 24 / XC DATA IMACH(12) / -126 / XC DATA IMACH(13) / 127 / XC DATA IMACH(14) / 53 / XC DATA IMACH(15) / -1022 / XC DATA IMACH(16) / 1023 / XC XC MACHINE CONSTANTS FOR THE HARRIS 220 XC MACHINE CONSTANTS FOR THE HARRIS SLASH 6 AND SLASH 7 XC XC === MACHINE = HARRIS.220 XC === MACHINE = HARRIS.SLASH6 XC === MACHINE = HARRIS.SLASH7 XC DATA IMACH( 1) / 5 / XC DATA IMACH( 2) / 6 / XC DATA IMACH( 3) / 0 / XC DATA IMACH( 4) / 6 / XC DATA IMACH( 5) / 24 / XC DATA IMACH( 6) / 3 / XC DATA IMACH( 7) / 2 / XC DATA IMACH( 8) / 23 / XC DATA IMACH( 9) / 8388607 / XC DATA IMACH(10) / 2 / XC DATA IMACH(11) / 23 / XC DATA IMACH(12) / -127 / XC DATA IMACH(13) / 127 / XC DATA IMACH(14) / 38 / XC DATA IMACH(15) / -127 / XC DATA IMACH(16) / 127 / XC XC MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES. XC MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES. XC XC === MACHINE = HONEYWELL.600/6000 XC === MACHINE = HONEYWELL.DPS.8/70 XC DATA IMACH( 1) / 5 / XC DATA IMACH( 2) / 6 / XC DATA IMACH( 3) / 43 / XC DATA IMACH( 4) / 6 / XC DATA IMACH( 5) / 36 / XC DATA IMACH( 6) / 4 / XC DATA IMACH( 7) / 2 / XC DATA IMACH( 8) / 35 / XC DATA IMACH( 9) / O377777777777 / XC DATA IMACH(10) / 2 / XC DATA IMACH(11) / 27 / XC DATA IMACH(12) / -127 / XC DATA IMACH(13) / 127 / XC DATA IMACH(14) / 63 / XC DATA IMACH(15) / -127 / XC DATA IMACH(16) / 127 / XC XC MACHINE CONSTANTS FOR THE HP 2100 XC 3 WORD DOUBLE PRECISION OPTION WITH FTN4 XC XC === MACHINE = HP.2100.3_WORD_DP XC DATA IMACH(1) / 5/ XC DATA IMACH(2) / 6 / XC DATA IMACH(3) / 4 / XC DATA IMACH(4) / 1 / XC DATA IMACH(5) / 16 / XC DATA IMACH(6) / 2 / XC DATA IMACH(7) / 2 / XC DATA IMACH(8) / 15 / XC DATA IMACH(9) / 32767 / XC DATA IMACH(10)/ 2 / XC DATA IMACH(11)/ 23 / XC DATA IMACH(12)/ -128 / XC DATA IMACH(13)/ 127 / XC DATA IMACH(14)/ 39 / XC DATA IMACH(15)/ -128 / XC DATA IMACH(16)/ 127 / XC XC MACHINE CONSTANTS FOR THE HP 2100 XC 4 WORD DOUBLE PRECISION OPTION WITH FTN4 XC XC === MACHINE = HP.2100.4_WORD_DP XC DATA IMACH(1) / 5 / XC DATA IMACH(2) / 6 / XC DATA IMACH(3) / 4 / XC DATA IMACH(4) / 1 / XC DATA IMACH(5) / 16 / XC DATA IMACH(6) / 2 / XC DATA IMACH(7) / 2 / XC DATA IMACH(8) / 15 / XC DATA IMACH(9) / 32767 / XC DATA IMACH(10)/ 2 / XC DATA IMACH(11)/ 23 / XC DATA IMACH(12)/ -128 / XC DATA IMACH(13)/ 127 / XC DATA IMACH(14)/ 55 / XC DATA IMACH(15)/ -128 / XC DATA IMACH(16)/ 127 / XC XC HP 9000 XC XC === MACHINE = HP.9000 XC DATA IMACH( 1) / 5 / XC DATA IMACH( 2) / 6 / XC DATA IMACH( 3) / 6 / XC DATA IMACH( 4) / 7 / XC DATA IMACH( 5) / 32 / XC DATA IMACH( 6) / 4 / XC DATA IMACH( 7) / 2 / XC DATA IMACH( 8) / 32 / XC DATA IMACH( 9) / 2147483647 / XC DATA IMACH(10) / 2 / XC DATA IMACH(11) / 24 / XC DATA IMACH(12) / -126 / XC DATA IMACH(13) / 127 / XC DATA IMACH(14) / 53 / XC DATA IMACH(15) / -1015 / XC DATA IMACH(16) / 1017 / XC XC MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, XC THE XEROX SIGMA 5/7/9 AND THE SEL SYSTEMS 85/86 AND XC THE INTERDATA 3230 AND INTERDATA 7/32. XC XC === MACHINE = IBM.360 XC === MACHINE = IBM.370 XC === MACHINE = XEROX.SIGMA.5 XC === MACHINE = XEROX.SIGMA.7 XC === MACHINE = XEROX.SIGMA.9 XC === MACHINE = SEL.85 XC === MACHINE = SEL.86 XC === MACHINE = INTERDATA.3230 XC === MACHINE = INTERDATA.7/32 XC DATA IMACH( 1) / 5 / XC DATA IMACH( 2) / 6 / XC DATA IMACH( 3) / 7 / XC DATA IMACH( 4) / 6 / XC DATA IMACH( 5) / 32 / XC DATA IMACH( 6) / 4 / XC DATA IMACH( 7) / 2 / XC DATA IMACH( 8) / 31 / XC DATA IMACH( 9) / Z7FFFFFFF / XC DATA IMACH(10) / 16 / XC DATA IMACH(11) / 6 / XC DATA IMACH(12) / -64 / XC DATA IMACH(13) / 63 / XC DATA IMACH(14) / 14 / XC DATA IMACH(15) / -64 / XC DATA IMACH(16) / 63 / XC XC MACHINE CONSTANTS FOR THE INTERDATA 8/32 XC WITH THE UNIX SYSTEM FORTRAN 77 COMPILER. XC XC FOR THE INTERDATA FORTRAN VII COMPILER REPLACE XC THE Z'S SPECIFYING HEX CONSTANTS WITH Y'S. XC XC === MACHINE = INTERDATA.8/32.UNIX XC DATA IMACH( 1) / 5 / XC DATA IMACH( 2) / 6 / XC DATA IMACH( 3) / 6 / XC DATA IMACH( 4) / 6 / XC DATA IMACH( 5) / 32 / XC DATA IMACH( 6) / 4 / XC DATA IMACH( 7) / 2 / XC DATA IMACH( 8) / 31 / XC DATA IMACH( 9) / Z'7FFFFFFF' / XC DATA IMACH(10) / 16 / XC DATA IMACH(11) / 6 / XC DATA IMACH(12) / -64 / XC DATA IMACH(13) / 62 / XC DATA IMACH(14) / 14 / XC DATA IMACH(15) / -64 / XC DATA IMACH(16) / 62 / XC XC MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR). XC XC === MACHINE = PDP-10.KA XC DATA IMACH( 1) / 5 / XC DATA IMACH( 2) / 6 / XC DATA IMACH( 3) / 7 / XC DATA IMACH( 4) / 6 / XC DATA IMACH( 5) / 36 / XC DATA IMACH( 6) / 5 / XC DATA IMACH( 7) / 2 / XC DATA IMACH( 8) / 35 / XC DATA IMACH( 9) / "377777777777 / XC DATA IMACH(10) / 2 / XC DATA IMACH(11) / 27 / XC DATA IMACH(12) / -128 / XC DATA IMACH(13) / 127 / XC DATA IMACH(14) / 54 / XC DATA IMACH(15) / -101 / XC DATA IMACH(16) / 127 / XC XC MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR). XC XC === MACHINE = PDP-10.KI XC DATA IMACH( 1) / 5 / XC DATA IMACH( 2) / 6 / XC DATA IMACH( 3) / 7 / XC DATA IMACH( 4) / 6 / XC DATA IMACH( 5) / 36 / XC DATA IMACH( 6) / 5 / XC DATA IMACH( 7) / 2 / XC DATA IMACH( 8) / 35 / XC DATA IMACH( 9) / "377777777777 / XC DATA IMACH(10) / 2 / XC DATA IMACH(11) / 27 / XC DATA IMACH(12) / -128 / XC DATA IMACH(13) / 127 / XC DATA IMACH(14) / 62 / XC DATA IMACH(15) / -128 / XC DATA IMACH(16) / 127 / XC XC MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING XC 32-BIT INTEGER ARITHMETIC. XC XC === MACHINE = PDP-11.32-BIT XC DATA IMACH( 1) / 5 / XC DATA IMACH( 2) / 6 / XC DATA IMACH( 3) / 7 / XC DATA IMACH( 4) / 6 / XC DATA IMACH( 5) / 32 / XC DATA IMACH( 6) / 4 / XC DATA IMACH( 7) / 2 / XC DATA IMACH( 8) / 31 / XC DATA IMACH( 9) / 2147483647 / XC DATA IMACH(10) / 2 / XC DATA IMACH(11) / 24 / XC DATA IMACH(12) / -127 / XC DATA IMACH(13) / 127 / XC DATA IMACH(14) / 56 / XC DATA IMACH(15) / -127 / XC DATA IMACH(16) / 127 / XC XC MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING XC 16-BIT INTEGER ARITHMETIC. XC XC === MACHINE = PDP-11.16-BIT XC DATA IMACH( 1) / 5 / XC DATA IMACH( 2) / 6 / XC DATA IMACH( 3) / 7 / XC DATA IMACH( 4) / 6 / XC DATA IMACH( 5) / 16 / XC DATA IMACH( 6) / 2 / XC DATA IMACH( 7) / 2 / XC DATA IMACH( 8) / 15 / XC DATA IMACH( 9) / 32767 / XC DATA IMACH(10) / 2 / XC DATA IMACH(11) / 24 / XC DATA IMACH(12) / -127 / XC DATA IMACH(13) / 127 / XC DATA IMACH(14) / 56 / XC DATA IMACH(15) / -127 / XC DATA IMACH(16) / 127 / XC XC MACHINE CONSTANTS FOR THE SEQUENT BALANCE 8000. XC XC === MACHINE = SEQUENT.BALANCE.8000 XC DATA IMACH( 1) / 0 / XC DATA IMACH( 2) / 0 / XC DATA IMACH( 3) / 7 / XC DATA IMACH( 4) / 0 / XC DATA IMACH( 5) / 32 / XC DATA IMACH( 6) / 1 / XC DATA IMACH( 7) / 2 / XC DATA IMACH( 8) / 31 / XC DATA IMACH( 9) / 2147483647 / XC DATA IMACH(10) / 2 / XC DATA IMACH(11) / 24 / XC DATA IMACH(12) / -125 / XC DATA IMACH(13) / 128 / XC DATA IMACH(14) / 53 / XC DATA IMACH(15) / -1021 / XC DATA IMACH(16) / 1024 / XC XC MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. FTN COMPILER XC XC === MACHINE = UNIVAC.1100 XC DATA IMACH( 1) / 5 / XC DATA IMACH( 2) / 6 / XC DATA IMACH( 3) / 1 / XC DATA IMACH( 4) / 6 / XC DATA IMACH( 5) / 36 / XC DATA IMACH( 6) / 4 / XC DATA IMACH( 7) / 2 / XC DATA IMACH( 8) / 35 / XC DATA IMACH( 9) / O377777777777 / XC DATA IMACH(10) / 2 / XC DATA IMACH(11) / 27 / XC DATA IMACH(12) / -128 / XC DATA IMACH(13) / 127 / XC DATA IMACH(14) / 60 / XC DATA IMACH(15) /-1024 / XC DATA IMACH(16) / 1023 / XC XC MACHINE CONSTANTS FOR THE VAX 11/780 XC XC === MACHINE = VAX.11/780 XC DATA IMACH(1) / 5 / XC DATA IMACH(2) / 6 / XC DATA IMACH(3) / 5 / XC DATA IMACH(4) / 6 / XC DATA IMACH(5) / 32 / XC DATA IMACH(6) / 4 / XC DATA IMACH(7) / 2 / XC DATA IMACH(8) / 31 / XC DATA IMACH(9) /2147483647 / XC DATA IMACH(10)/ 2 / XC DATA IMACH(11)/ 24 / XC DATA IMACH(12)/ -127 / XC DATA IMACH(13)/ 127 / XC DATA IMACH(14)/ 56 / XC DATA IMACH(15)/ -127 / XC DATA IMACH(16)/ 127 / XC XC XC***FIRST EXECUTABLE STATEMENT I1MACH X IF (I .LT. 1 .OR. I .GT. 16) X 1 CALL XERROR ( 'I1MACH -- I OUT OF BOUNDS',25,1,2) XC X I1MACH=IMACH(I) X RETURN XC X END X INTEGER FUNCTION INITDS(DOS,NOS,ETA) XC***BEGIN PROLOGUE INITDS XC***DATE WRITTEN 770601 (YYMMDD) XC***REVISION DATE 820801 (YYMMDD) XC***CATEGORY NO. C3A2 XC***KEYWORDS CHEBYSHEV,DOUBLE PRECISION,INITIALIZE, XC ORTHOGONAL POLYNOMIAL,SERIES,SPECIAL FUNCTION XC***AUTHOR FULLERTON, W., (LANL) XC***PURPOSE Initializes the d.p. properly normalized orthogonal XC polynomial series to determine the number of terms needed XC for specific accuracy. XC***DESCRIPTION XC XC Initialize the double precision orthogonal series DOS so that INITDS XC is the number of terms needed to insure the error is no larger than XC ETA. Ordinarily ETA will be chosen to be one-tenth machine precision XC XC Input Arguments -- XC DOS dble prec array of NOS coefficients in an orthogonal series. XC NOS number of coefficients in DOS. XC ETA requested accuracy of series. XC***REFERENCES (NONE) XC***ROUTINES CALLED XERROR XC***END PROLOGUE INITDS XC X INTEGER I, II, NOS X DOUBLE PRECISION DOS(NOS),ETA,ERR XC***FIRST EXECUTABLE STATEMENT INITDS X IF (NOS.LT.1) CALL XERROR ( 'INITDS NUMBER OF COEFFICIENTS LT 1', X 1 35, 2, 2) XC X ERR = 0. X DO 10 II=1,NOS X I = NOS + 1 - II X ERR = ERR + ABS(SNGL(DOS(I))) X IF (ERR.GT.ETA) GO TO 20 X 10 CONTINUE XC X 20 IF (I.EQ.NOS) CALL XERROR ( 'INITDS ETA MAY BE TOO SMALL', 28, X 1 1, 2) X INITDS = I XC X RETURN X END X INTEGER FUNCTION J4SAVE(IWHICH,IVALUE,ISET) XC***BEGIN PROLOGUE J4SAVE XC***REFER TO XERROR XC Abstract XC J4SAVE saves and recalls several global variables needed XC by the library error handling routines. XC XC Description of Parameters XC --Input-- XC IWHICH - Index of item desired. XC = 1 Refers to current error number. XC = 2 Refers to current error control flag. XC = 3 Refers to current unit number to which error XC messages are to be sent. (0 means use standard.) XC = 4 Refers to the maximum number of times any XC message is to be printed (as set by XERMAX). XC = 5 Refers to the total number of units to which XC each error message is to be written. XC = 6 Refers to the 2nd unit for error messages XC = 7 Refers to the 3rd unit for error messages XC = 8 Refers to the 4th unit for error messages XC = 9 Refers to the 5th unit for error messages XC IVALUE - The value to be set for the IWHICH-th parameter, XC if ISET is .TRUE. . XC ISET - If ISET=.TRUE., the IWHICH-th parameter will BE XC given the value, IVALUE. If ISET=.FALSE., the XC IWHICH-th parameter will be unchanged, and IVALUE XC is a dummy parameter. XC --Output-- XC The (old) value of the IWHICH-th parameter will be returned XC in the function value, J4SAVE. XC XC Written by Ron Jones, with SLATEC Common Math Library Subcommittee XC Adapted from Bell Laboratories PORT Library Error Handler XC Latest revision --- 23 MAY 1979 XC***REFERENCES JONES R.E., KAHANER D.K., "XERROR, THE SLATEC ERROR- XC HANDLING PACKAGE", SAND82-0800, SANDIA LABORATORIES, XC 1982. XC***ROUTINES CALLED (NONE) XC***END PROLOGUE J4SAVE X LOGICAL ISET X INTEGER IPARAM(9),IWHICH, IVALUE X SAVE IPARAM X DATA IPARAM(1),IPARAM(2),IPARAM(3),IPARAM(4)/0,2,0,10/ X DATA IPARAM(5)/1/ X DATA IPARAM(6),IPARAM(7),IPARAM(8),IPARAM(9)/0,0,0,0/ XC***FIRST EXECUTABLE STATEMENT J4SAVE X J4SAVE = IPARAM(IWHICH) X IF (ISET) IPARAM(IWHICH) = IVALUE X RETURN X END X SUBROUTINE XERABT(MESSG,NMESSG) XC***BEGIN PROLOGUE XERABT XC***DATE WRITTEN 790801 (YYMMDD) XC***REVISION DATE 820801 (YYMMDD) XC***CATEGORY NO. R3C XC***KEYWORDS ERROR,XERROR PACKAGE XC***AUTHOR JONES, R. E., (SNLA) XC***PURPOSE Aborts program execution and prints error message. XC***DESCRIPTION XC Abstract XC ***Note*** machine dependent routine XC XERABT aborts the execution of the program. XC The error message causing the abort is given in the calling XC sequence, in case one needs it for printing on a dayfile, XC for example. XC XC Description of Parameters XC MESSG and NMESSG are as in XERROR, except that NMESSG may XC be zero, in which case no message is being supplied. XC XC Written by Ron Jones, with SLATEC Common Math Library Subcommittee XC Latest revision --- 19 MAR 1980 XC***REFERENCES JONES R.E., KAHANER D.K., "XERROR, THE SLATEC ERROR- XC HANDLING PACKAGE", SAND82-0800, SANDIA LABORATORIES, XC 1982. XC***ROUTINES CALLED (NONE) XC***END PROLOGUE XERABT X INTEGER NMESSG X CHARACTER*(*) MESSG XC***FIRST EXECUTABLE STATEMENT XERABT X STOP X END X SUBROUTINE XERCTL(MESSG1,NMESSG,NERR,LEVEL,KONTRL) XC***BEGIN PROLOGUE XERCTL XC***DATE WRITTEN 790801 (YYMMDD) XC***REVISION DATE 820801 (YYMMDD) XC***CATEGORY NO. R3C XC***KEYWORDS ERROR,XERROR PACKAGE XC***AUTHOR JONES, R. E., (SNLA) XC***PURPOSE Allows user control over handling of individual errors. XC***DESCRIPTION XC Abstract XC Allows user control over handling of individual errors. XC Just after each message is recorded, but before it is XC processed any further (i.e., before it is printed or XC a decision to abort is made), a call is made to XERCTL. XC If the user has provided his own version of XERCTL, he XC can then override the value of KONTROL used in processing XC this message by redefining its value. XC KONTRL may be set to any value from -2 to 2. XC The meanings for KONTRL are the same as in XSETF, except XC that the value of KONTRL changes only for this message. XC If KONTRL is set to a value outside the range from -2 to 2, XC it will be moved back into that range. XC XC Description of Parameters XC XC --Input-- XC MESSG1 - the first word (only) of the error message. XC NMESSG - same as in the call to XERROR or XERRWV. XC NERR - same as in the call to XERROR or XERRWV. XC LEVEL - same as in the call to XERROR or XERRWV. XC KONTRL - the current value of the control flag as set XC by a call to XSETF. XC XC --Output-- XC KONTRL - the new value of KONTRL. If KONTRL is not XC defined, it will remain at its original value. XC This changed value of control affects only XC the current occurrence of the current message. XC***REFERENCES JONES R.E., KAHANER D.K., "XERROR, THE SLATEC ERROR- XC HANDLING PACKAGE", SAND82-0800, SANDIA LABORATORIES, XC 1982. XC***ROUTINES CALLED (NONE) XC***END PROLOGUE XERCTL X INTEGER KONTRL, LEVEL, NERR,NMESSG X CHARACTER*20 MESSG1 XC***FIRST EXECUTABLE STATEMENT XERCTL X RETURN X END X SUBROUTINE XERPRT(MESSG,NMESSG) XC***BEGIN PROLOGUE XERPRT XC***DATE WRITTEN 790801 (YYMMDD) XC***REVISION DATE 820801 (YYMMDD) XC***CATEGORY NO. Z XC***KEYWORDS ERROR,XERROR PACKAGE XC***AUTHOR JONES, R. E., (SNLA) XC***PURPOSE Prints error messages. XC***DESCRIPTION XC Abstract XC Print the Hollerith message in MESSG, of length NMESSG, XC on each file indicated by XGETUA. XC Latest revision --- 19 MAR 1980 XC***REFERENCES JONES R.E., KAHANER D.K., "XERROR, THE SLATEC ERROR- XC HANDLING PACKAGE", SAND82-0800, SANDIA LABORATORIES, XC 1982. XC***ROUTINES CALLED I1MACH,XGETUA XC***END PROLOGUE XERPRT X INTEGER I1MACH X INTEGER ICHAR, IUNIT, KUNIT, LAST, LENMES,NMESSG, NUNIT X INTEGER LUN(5) X CHARACTER*(*) MESSG XC OBTAIN UNIT NUMBERS AND WRITE LINE TO EACH UNIT XC***FIRST EXECUTABLE STATEMENT XERPRT X CALL XGETUA(LUN,NUNIT) X LENMES = LEN(MESSG) X DO 20 KUNIT=1,NUNIT X IUNIT = LUN(KUNIT) X IF (IUNIT.EQ.0) IUNIT = I1MACH(4) X DO 10 ICHAR=1,LENMES,72 X LAST = MIN0(ICHAR+71 , LENMES) X WRITE (IUNIT,'(1X,A)') MESSG(ICHAR:LAST) X 10 CONTINUE X 20 CONTINUE X RETURN X END X SUBROUTINE DGAMLM(XMIN,XMAX) XC***BEGIN PROLOGUE DGAMLM XC***DATE WRITTEN 770601 (YYMMDD) XC***REVISION DATE 820801 (YYMMDD) XC***CATEGORY NO. C7A,R2 XC***KEYWORDS COMPLETE GAMMA FUNCTION,DOUBLE PRECISION,GAMMA FUNCTION, XC LIMITS,SPECIAL FUNCTION XC***AUTHOR FULLERTON, W., (LANL) XC***PURPOSE Computes the d.p. minimum and maximum bounds for X in XC GAMMA(X). XC***DESCRIPTION XC XC Calculate the minimum and maximum legal bounds for X in gamma(X). XC XMIN and XMAX are not the only bounds, but they are the only non- XC trivial ones to calculate. XC XC Output Arguments -- XC XMIN double precision minimum legal value of X in gamma(X). Any XC smaller value of X might result in underflow. XC XMAX double precision maximum legal value of X in gamma(X). Any XC larger value of X might cause overflow. XC***REFERENCES (NONE) XC***ROUTINES CALLED D1MACH,XERROR XC***END PROLOGUE DGAMLM X INTEGER I X DOUBLE PRECISION XMIN, XMAX, ALNBIG, ALNSML, XLN, XOLD, D1MACH XC***FIRST EXECUTABLE STATEMENT DGAMLM X ALNSML = DLOG(D1MACH(1)) X XMIN = -ALNSML X DO 10 I=1,10 X XOLD = XMIN X XLN = DLOG(XMIN) X XMIN = XMIN - XMIN*((XMIN+0.5D0)*XLN - XMIN - 0.2258D0 + ALNSML) X 1 / (XMIN*XLN+0.5D0) X IF (DABS(XMIN-XOLD).LT.0.005D0) GO TO 20 X 10 CONTINUE X CALL XERROR ( 'DGAMLM UNABLE TO FIND XMIN', 27, 1, 2) XC X 20 XMIN = -XMIN + 0.01D0 XC X ALNBIG = DLOG (D1MACH(2)) X XMAX = ALNBIG X DO 30 I=1,10 X XOLD = XMAX X XLN = DLOG(XMAX) X XMAX = XMAX - XMAX*((XMAX-0.5D0)*XLN - XMAX + 0.9189D0 - ALNBIG) X 1 / (XMAX*XLN-0.5D0) X IF (DABS(XMAX-XOLD).LT.0.005D0) GO TO 40 X 30 CONTINUE X CALL XERROR ( 'DGAMLM UNABLE TO FIND XMAX', 27, 2, 2) XC X 40 XMAX = XMAX - 0.01D0 X XMIN = DMAX1 (XMIN, -XMAX+1.D0) XC X RETURN X END END_OF_FILE if test 174456 -ne `wc -c <'code.f'`; then echo shar: \"'code.f'\" unpacked with wrong size! fi # end of 'code.f' fi if test -f 'problem_01.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'problem_01.f'\" else echo shar: Extracting \"'problem_01.f'\" \(11255 characters\) sed "s/^X//" >'problem_01.f' <<'END_OF_FILE' X********************************************************************** X* File problem_01.f X* Example 7.1 X SUBROUTINE ControlVars( SincPts,NumOfEqua,Nxs,MaxIter,H,Itest) X X* The purpose of this SUBROUTINE is to set the controlling X* parameters for the problem. X* X* The parameters in the CALL statement are: X X* SincPts - An INTEGER which controls number of points used in the X* approximation. The solution is computed at y_i( k * H ) with X* k = - SincPts ... SincPts. X X* NumOfEqua - INTEGER - Number of dependent variables in the system X* (i.e., the number of simultaneous IVP's to be solved). X X* Nxs - INTEGER - Number of points at which the solution will be X* approximated. X X* MaxIter - INTEGER - The maximum number of iterations the procedure X* will use in trying to converge. X X* H - DOUBLE PRECISION - This is the step size. In some instances X* picking the optimal H can make a significant difference in the X* accuracy of the result, particularly for small SincPts. However, as X* long H is picked as: X X* H = 1.0d0 /sqrt(C*SincPts) for some C X X* the algorithm will have the appropriate asymptotic accuracy. X* Itest INTEGER: If Itest=0 no exact solution is known and the value X* of double precision function Solution is irrevelant. If itest=1 X* the analytic solution is given by double precision function X* Solution X X IMPLICIT NONE X X DOUBLE PRECISION Pi, C X PARAMETER (Pi = 3.1415926535897932D0 ) X X INTEGER SincPts, NumOfEqua, Nxs, MaxIter,Itest X DOUBLE PRECISION H X X SincPts = 20 X NumOfEqua = 2 X Nxs = 10 X MaxIter = 80 X c=0.90d0 X PRINT *,' Example 7.1 File: problem_01.f' X PRINT *,' Linear problem' X H = Pi / DSQRT( C * DBLE( SincPts ) ) X* If exact solution known, it should be defined by DOUBLE PRECISION X* FUNCTION Solution and we put: X Itest=1 X* If exact solution is not known, then the result of DOUBLE PRECISION X* FUNCTION is irrevelant and we put X* Itest=0 X return X end X X********************************************************************** X X********************************************************************** X SUBROUTINE F(NumOfEqua, Pos, Work) X X* The purpose of this SUBROUTINE is to compute the derivatives: X* X* dy(i)/dt = f ( t, y(i) ) for i=1,..., NumOfEqua X* X* and to store the result within the Work array. X* X* The user is encouraged to modify this SUBROUTINE for his/her own X* problem of interest. The user is passed the entire Work array which X* contains all intermediate results. The user is encouraged not to X* modify any of the elements within the Work array directly but to use X* the temporary arrays defined within this example SUBROUTINE. The X* user will recognize that these temporary arrays are not essential; X* however, they DO simplify the bookkeeping within the SUBROUTINE. X* X* The parameters in the CALL statement are: X* X* NumOfEqua - The number of derivative equations in the system X* X* NumOfPoints - An INTEGER which increments through the elements within X* the Work array. A given INTEGER value of NumOfPoints corresponds to a X* given value of the independent variable. The value of the X* independent variable takes on values at the sinc points, a X* different sinc point for each CALL of SUBROUTINE F. X* X* Work - A Work array that contains the necessary storage for all X* intermediate and finals results at the sinc points. X* X* The user is encouraged to define temporary variables and arrays: X* X* T - Value of the independent variable for the current SUBROUTINE X* CALL. (NOTE: T = Work(PsiPointer+i) ) X* X* Y(NumOfEqua) - An array containing the current values of the dependent X* variables of the system. X* X* YDOT(NumOfEqua) - An array to be computed within the SUBROUTINE that X* contains the values of the derivatives of the dependent variables X* with respect to the independent variable. X X IMPLICIT NONE X X INCLUDE 'workspace.h' X X* Argument list X DOUBLE PRECISION Work(*) X INTEGER Pos, NumOfEqua X X X* local Variables X INTEGER k X* DOUBLE PRECISION Y(NumOfEqua), YDOT(NumOfEqua), T X* The local arrays Y and YDOT must have fixed dimensions equal to X* the number of equations NumOfEqua=2 X X DOUBLE PRECISION Y(2), YDOT(2), T X X* Pull values of the independent and dependent variables out of the X* work array. X X T = Work(PsiPointer + Pos) X X DO k=1,NumOfEqua X Y(k) = Work(NINT(Work(YPointerPointer + k)) + Pos) X END DO X X* Program your derivative equations here. e.g., X X YDOT(1) = Y( 2 ) / ( 1.0d0 - t*t ) X X YDOT(2) = - 6.0d0 * Y( 1 ) X X X* Store the values for YDOT(k) back into the Work array. X X DO k = 1, NumOfEqua X Work(NINT(Work(FPointerPointer + k)) + Pos) = YDOT(k) X END DO X X RETURN X END X X********************************************************************** X SUBROUTINE J_ij (NumOfEqua, Pos, Work) X X* The purpose of this SUBROUTINE is to compute the derivatives X* appearing in the Jacobian. X* X* Bij = dk(i)/dy(j) for i,j=1,..., NumOfEqua X* X* and to store the result within the Work array. X* X* The user is encouraged to modify this SUBROUTINE for his/her own X* problem of interest. The user is passed the entire Work array which X* contains all intermediate results. The user is encouraged not to X* modify any of the elements within the Work array directly but to use X* the temporary arrays defined within this example SUBROUTINE. The X* user will recognize that these temporary arrays are not essential; X* however, they DO simplify the bookkeeping within the SUBROUTINE. X* X* The parameters in the CALL statement are: X X* NumOfEqua - The number of derivative equations in the system X X* Pos - An INTEGER which increments through the elements within X* the Work array. A given INTEGER value of Pos corresponds to a X* given value of the independent variable. The value of the X* independent variable takes on values at the sinc points, a X* different sinc point for each CALL of SUBROUTINE F. X X* Work - A Work array that contains the necessary storage for all X* intermediate and finals results at the sinc points. X X* The user is encouraged to define temporary variables and arrays: X X* T - Value of the independent variable for the current SUBROUTINE X* CALL. (NOTE: T = Work(PsiPointer+i) ) X X* Y(NumOfEqua) - An array containing the current values of the dependent X* variables of the system. X X* Bij(NumOfEqua,NumOfEqua) - An array to be computed within the SUBROUTINE X* that contains the values of the derivatives of the dependent X* variables with respect to the independent variable. X X IMPLICIT none X X INCLUDE 'workspace.h' X X* Definition of parameters. X INTEGER Pos, NumOfEqua X DOUBLE PRECISION Work(*) X X* Local Variables X INTEGER l, k, m X X* Dimension Y() and Bij() to the number of ODE's X* DOUBLE PRECISION Y(NumOfEqua), Bij(NumOfEqua,NumOfEqua), T X* The local arrays Y and Bij must have fixed dimensions X* determined by the number of equations NumOfEqua=2 X DOUBLE PRECISION Y(2), Bij(2,2), T X X* Pull values of the independent and dependent variables out of the X* Work array. X X T = Work(PsiPointer + Pos) X X DO k = 1, NumOfEqua X Y(k) = Work(NINT(Work(YPointerPointer + k)) + Pos) X END DO X X* Program your derivative equations here. e.g., X X Bij( 1, 1 ) = 0.0d0 X Bij( 1, 2 ) = 1.0d0 / ( 1.0d0 - t*t ) X X Bij( 2, 1 ) = - 6.0d0 X Bij( 2, 2 ) = 0.0d0 X X* Store the values for Bij( k ) back into the Work array. X k = 0 X DO l = 1, NumOfEqua X DO m = 1, NumOfEqua X k = k + 1 X Work(NINT(Work(BijPointerPointer + k)) + Pos) = X . Bij(m, l) X END DO X END DO X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION Phi(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X Phi = Phi01( Z ) X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION OneOverPhiPrime(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X OneOverPhiPrime = PhiPriRec01( Z ) X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION Rho(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X Rho = Rho01(Z) X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION Psi(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X Psi = Psi01(Z) X X RETURN X END X X********************************************************************** X SUBROUTINE SetXs( EquaNum, Nxs, X ) X IMPLICIT NONE X X* This routine allows the user to set the values X* of the points at which to view the solution. X X* This section defines the argument list. X INTEGER EquaNum, Nxs X DOUBLE PRECISION X(*) X X INTEGER i X X DO i = 1, Nxs X X(i) = -0.05+0.10D0 * DFLOAT(i) X END DO X X return X end X X********************************************************************** X DOUBLE PRECISION FUNCTION Solution(EquaNum, T) X IMPLICIT NONE X X* This section defines the argument list. X INTEGER EquaNum X DOUBLE PRECISION T X X X* This is the code section. X if ( EquaNum .eq. 1 ) then X Solution = ( 3.0d0 * t * t - 1.0d0 ) / 2.0d0 X else X Solution = 3.0d0 * t * ( 1.0d0 - t*t ) X endif X X RETURN X END X X********************************************************************** X SUBROUTINE StartAppr( NumOfEqua, N, work ) X IMPLICIT NONE X X* This routine allows the user to set the initial values X* and then puts the initial y values into the work array X X* This section defines the argument list. X INTEGER NumOfEqua, N X DOUBLE PRECISION work(*) X X* Local variables X INTEGER YPointer, OldYPointer, j X INTEGER EquaNum, Pos X X* User set initial values for the dependent variable X DOUBLE PRECISION y( 2, 41 ) X data ( y( 1, j ), j=1,41 )/ 41 * 1.0d0 / X data ( y( 2, j ), j=1,41 )/ 41 * 0.0d0 / X X INCLUDE 'workspace.h' X X do EquaNum = 1, 2 X X YPointer = NINT(Work(YPointerPointer + EquaNum )) X OldYPointer = NINT(Work(OldYPointerPointer + EquaNum )) X X do Pos = 1, 41 X X Work(YPointer + Pos) = y( EquaNum, Pos ) X Work(OldYPointer + Pos) = y( EquaNum, Pos ) X X enddo X X enddo X X RETURN X END X********************************************************************** X SUBROUTINE InitCond(NumOfEqua, Value) X IMPLICIT NONE X X* This section defines the argument list. X INTEGER NumOfEqua X DOUBLE PRECISION Value(NumOfEqua + 1) X X* This is the code section. X X Value(1) = -0.5D0 X Value(2) = 0.0D0 X X RETURN X END X END_OF_FILE if test 11255 -ne `wc -c <'problem_01.f'`; then echo shar: \"'problem_01.f'\" unpacked with wrong size! fi # end of 'problem_01.f' fi if test -f 'problem_AB.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'problem_AB.f'\" else echo shar: Extracting \"'problem_AB.f'\" \(11253 characters\) sed "s/^X//" >'problem_AB.f' <<'END_OF_FILE' X X X* File problem_AB.f X* Example 7.2 X SUBROUTINE ControlVars(SincPts,NumOfEqua,Nxs,MaxIter,H,Itest) X* The purpose of this SUBROUTINE is to set the controlling X* parameters for the problem. X* X* The parameters in the CALL statement are: X X* SincPts - An INTEGER which controls number of points used in the X* approximation. The solution is computed at y_i( k * H ) with X* k = - SincPts ... SincPts. X X* NumOfEqua - INTEGER - Number of dependent variables in the system X* (i.e., the number of simultaneous IVP's to be solved). X X* Nxs - INTEGER - Number of points at which the solution will be X* approximated. X X* MaxIter - INTEGER - The maximum number of iterations the procedure X* will use in trying to converge. X X* H - DOUBLE PRECISION - This is the step size. In some instances X* picking the optimal H can make a significant difference in the X* accuracy of the result, particularly for small SincPts. However, as X* long H is picked as: X X* H = 1.0d0 /sqrt(C*SincPts) for some C X X* the algorithm will have the appropriate asymptotic accuracy. X* Itest INTEGER: If Itest=0 no exact solution is known and the value X* of double precision function Solution is irrevelant. If itest=1 X* the analytic solution is given by double precision function X* Solution X X IMPLICIT NONE X X DOUBLE PRECISION Pi, C X PARAMETER (Pi = 3.1415926535897932D0 ) X X INTEGER SincPts, NumOfEqua, Nxs, MaxIter,Itest X DOUBLE PRECISION H X X SincPts = 20 X NumOfEqua = 2 X Nxs = 10 X MaxIter = 80 X C=2.0d0 X PRINT * ,'Example 7.2 File: problem_AB.f' X PRINT * ,'Linear problem' X H = Pi / DSQRT( C * DBLE( SincPts ) ) X* If exact solution known, it should be defined by DOUBLE PRECISION X* FUNCTION Solution and we put: X Itest=1 X* If exact solution is not known, then the result of DOUBLE PRECISION X* FUNCTION is irrevelant and we put X* Itest=0 X return X end X X********************************************************************** X X********************************************************************** X SUBROUTINE F(NumOfEqua, Pos, Work) X X* The purpose of this SUBROUTINE is to compute the derivatives: X* X* dy(i)/dt = f ( t, y(i) ) for i=1,..., NumOfEqua X* X* and to store the result within the Work array. X* X* The user is encouraged to modify this SUBROUTINE for his/her own X* problem of interest. The user is passed the entire Work array which X* contains all intermediate results. The user is encouraged not to X* modify any of the elements within the Work array directly but to use X* the temporary arrays defined within this example SUBROUTINE. The X* user will recognize that these temporary arrays are not essential; X* however, they DO simplify the bookkeeping within the SUBROUTINE. X* X* The parameters in the CALL statement are: X* X* NumOfEqua - The number of derivative equations in the system X* X* NumOfPoints - An INTEGER which increments through the elements within X* the Work array. A given INTEGER value of NumOfPoints corresponds to a X* given value of the independent variable. The value of the X* independent variable takes on values at the sinc points, a X* different sinc point for each CALL of SUBROUTINE F. X* X* Work - A Work array that contains the necessary storage for all X* intermediate and finals results at the sinc points. X* X* The user is encouraged to define temporary variables and arrays: X* X* T - Value of the independent variable for the current SUBROUTINE X* CALL. (NOTE: T = Work(PsiPointer+i) ) X* X* Y(NumOfEqua) - An array containing the current values of the dependent X* variables of the system. X* X* YDOT(NumOfEqua) - An array to be computed within the SUBROUTINE that X* contains the values of the derivatives of the dependent variables X* with respect to the independent variable. X X IMPLICIT NONE X X INCLUDE 'workspace.h' X X* Argument list X DOUBLE PRECISION Work(*) X INTEGER Pos, NumOfEqua X X X X* local Variables X INTEGER k X* DOUBLE PRECISION Y(NumOfEqua), YDOT(NumOfEqua), T X* The local arrays Y and YDOT must have fixed dimensions equal to X* the number of equations NumOfEqua=2 X X DOUBLE PRECISION Y(2), YDOT(2), T X X* Pull values of the independent and dependent variables out of the X* work array. X X T = Work(PsiPointer + Pos) X X DO k=1,NumOfEqua X Y(k) = Work(NINT(Work(YPointerPointer + k)) + Pos) X END DO X X* Program your derivative equations here. e.g., X X YDOT(1) = Y( 2 ) / t X X YDOT(2) = - t * Y( 1 ) X X X* Store the values for YDOT(k) back into the Work array. X X DO k = 1, NumOfEqua X Work(NINT(Work(FPointerPointer + k)) + Pos) = YDOT(k) X END DO X X RETURN X END X X********************************************************************** X SUBROUTINE J_ij (NumOfEqua, Pos, Work) X X* The purpose of this SUBROUTINE is to compute the derivatives X* appearing in the Jacobian. X* X* Bij = dk(i)/dy(j) for i,j=1,..., NumOfEqua X* X* and to store the result within the Work array. X* X* The user is encouraged to modify this SUBROUTINE for his/her own X* problem of interest. The user is passed the entire Work array which X* contains all intermediate results. The user is encouraged not to X* modify any of the elements within the Work array directly but to use X* the temporary arrays defined within this example SUBROUTINE. The X* user will recognize that these temporary arrays are not essential; X* however, they DO simplify the bookkeeping within the SUBROUTINE. X* X* The parameters in the CALL statement are: X X* NumOfEqua - The number of derivative equations in the system X X* Pos - An INTEGER which increments through the elements within X* the Work array. A given INTEGER value of Pos corresponds to a X* given value of the independent variable. The value of the X* independent variable takes on values at the sinc points, a X* different sinc point for each CALL of SUBROUTINE F. X X* Work - A Work array that contains the necessary storage for all X* intermediate and finals results at the sinc points. X X* The user is encouraged to define temporary variables and arrays: X X* T - Value of the independent variable for the current SUBROUTINE X* CALL. (NOTE: T = Work(PsiPointer+i) ) X X* Y(NumOfEqua) - An array containing the current values of the dependent X* variables of the system. X X* Bij(NumOfEqua,NumOfEqua) - An array to be computed within the SUBROUTINE X* that contains the values of the derivatives of the dependent X* variables with respect to the independent variable. X X IMPLICIT none X X INCLUDE 'workspace.h' X X* Definition of parameters. X INTEGER Pos, NumOfEqua X DOUBLE PRECISION Work(*) X X* Local Variables X INTEGER l, k, m X X* Dimension Y() and Bij() to the number of ODE's X X X* DOUBLE PRECISION Y(NumOfEqua), Bij(NumOfEqua,NumOfEqua), T X* The local arrays Y and Bij must have fixed dimensions X* determined by the number of equations NumOfEqua=2 X DOUBLE PRECISION Y(2), Bij(2,2), T X X* Pull values of the independent and dependent variables out of the X* Work array. X X T = Work(PsiPointer + Pos) X X DO k = 1, NumOfEqua X Y(k) = Work(NINT(Work(YPointerPointer + k)) + Pos) X END DO X X* Program your derivative equations here. e.g., X X Bij( 1, 1 ) = 0.0d0 X Bij( 1, 2 ) = 1.0d0 / t X X Bij( 2, 1 ) = - t X Bij( 2, 2 ) = 0.0d0 X X* Store the values for Bij( k ) back into the Work array. X k = 0 X DO l = 1, NumOfEqua X DO m = 1, NumOfEqua X k = k + 1 X Work(NINT(Work(BijPointerPointer + k)) + Pos) = X . Bij(m, l) X END DO X END DO X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION Phi(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X Phi = PhiAB(Z, 0.0d0, 10.0d0) X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION OneOverPhiPrime(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X OneOverPhiPrime = PhiPriRecAB(Z, 0.0d0, 10.0d0) X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION Rho(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X Rho = RhoAB(Z, 0.0d0, 10.0d0) X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION Psi(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X Psi = PsiAB(Z, 0.0d0, 10.0d0) X X RETURN X END X X********************************************************************** X SUBROUTINE SetXs( EquaNum, Nxs, X ) X IMPLICIT NONE X X* This routine allows the user to set the values X* of the points at which to view the solution. X X* This section defines the argument list. X INTEGER EquaNum, Nxs X DOUBLE PRECISION X(*) X X INTEGER i X X DO i = 1, Nxs X X(i) = -0.5d0+1.D0 * DFLOAT(i) X END DO X X return X end X X********************************************************************** X DOUBLE PRECISION FUNCTION Solution(EquaNum, T) X IMPLICIT NONE X X* This section defines the argument list. X INTEGER EquaNum X DOUBLE PRECISION T X X* This section defines local variables needed in the solution X DOUBLE PRECISION besj0 X EXTERNAL besj0 X X* This is the code section. X Solution=0. X IF (EquaNum .EQ. 1) THEN X Solution = besj0( T ) X END IF X RETURN X END X X********************************************************************** X SUBROUTINE StartAppr( NumOfEqua, N, work ) X IMPLICIT NONE X X* This routine allows the user to set the initial values X* and then puts the initial y values into the work array X X* This section defines the argument list. X INTEGER NumOfEqua, N X DOUBLE PRECISION work(*) X X* Local variables X INTEGER YPointer, OldYPointer, j X INTEGER EquaNum, Pos X X* User set initial values for the dependent variable X DOUBLE PRECISION y( 2, 41 ) X data ( y( 1, j ), j=1,41 )/ 41 * 1.0d0 / X data ( y( 2, j ), j=1,41 )/ 41 * 0.0d0 / X X INCLUDE 'workspace.h' X X do EquaNum = 1, 2 X X YPointer = NINT(Work(YPointerPointer + EquaNum )) X OldYPointer = NINT(Work(OldYPointerPointer + EquaNum )) X X do Pos = 1, 41 X X Work(YPointer + Pos) = y( EquaNum, Pos ) X Work(OldYPointer + Pos) = y( EquaNum, Pos ) X X enddo X X enddo X X RETURN X END X********************************************************************** X SUBROUTINE InitCond(NumOfEqua, Value) X IMPLICIT NONE X X* This section defines the argument list. X INTEGER NumOfEqua X DOUBLE PRECISION Value(NumOfEqua + 1) X X* This is the code section. X X Value(1) = 1.0D0 X Value(2) = 0.0D0 X X RETURN X END X END_OF_FILE if test 11253 -ne `wc -c <'problem_AB.f'`; then echo shar: \"'problem_AB.f'\" unpacked with wrong size! fi # end of 'problem_AB.f' fi if test -f 'problem_Bul.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'problem_Bul.f'\" else echo shar: Extracting \"'problem_Bul.f'\" \(12054 characters\) sed "s/^X//" >'problem_Bul.f' <<'END_OF_FILE' X********************************************************************** X* File problem_Bul.f X* Example 7.3 X SUBROUTINE ControlVars(SincPts,NumOfEqua,Nxs,MaxIter,H,Itest) X X* The purpose of this SUBROUTINE is to set the controlling X* parameters for the problem. X* X* The parameters in the CALL statement are: X X* SincPts - An INTEGER which controls number of points used in the X* approximation. The solution is computed at y_i( k * H ) with X* k = - SincPts ... SincPts. X X* NumOfEqua - INTEGER - Number of dependent variables in the system X* (i.e., the number of simultaneous IVP's to be solved). X X* Nxs - INTEGER - Number of points at which the solution will be X* approximated. X X* MaxIter - INTEGER - The maximum number of iterations the procedure X* will use in trying to converge. X X* H - DOUBLE PRECISION - This is the step size. In some instances X* picking the optimal H can make a significant difference in the X* accuracy of the result, particularly for small SincPts. However, as X* long H is picked as: X X* H = 1.0d0 /sqrt(C*SincPts) for some C X X* the algorithm will have the appropriate asymptotic accuracy. X* Itest INTEGER: If Itest=0 no exact solution is known and the value X* of double precision function Solution is irrevelant. If itest=1 X* the analytic solution is given by double precision function X* Solution X X IMPLICIT NONE X X DOUBLE PRECISION Pi, C X PARAMETER (Pi = 3.1415926535897932D0 ) X X INTEGER SincPts, NumOfEqua, Nxs, MaxIter,Itest X DOUBLE PRECISION H X X SincPts = 20 X NumOfEqua=3 X Nxs = 10 X MaxIter = 80 X C=0.9d0 X PRINT * ,'Example 7.3 File: problem_Bul.f' X H = Pi / DSQRT( C * DBLE( SincPts ) ) X* If exact solution known, it should be defined by DOUBLE PRECISION X* FUNCTION Solution and we put: X Itest=1 X* If exact solution is not known, then the result of DOUBLE PRECISION X* FUNCTION is irrevelant and we put X* Itest=0 X return X end X X********************************************************************** X X X X********************************************************************** X SUBROUTINE F(NumOfEqua, Pos, Work) X X* The purpose of this SUBROUTINE is to compute the derivatives: X* X* dy(i)/dt = f ( t, y(i) ) for i=1,..., NumOfEqua X* X* and to store the result within the Work array. X* X* The user is encouraged to modify this SUBROUTINE for his/her own X* problem of interest. The user is passed the entire Work array which X* contains all intermediate results. The user is encouraged not to X* modify any of the elements within the Work array directly but to use X* the temporary arrays defined within this example SUBROUTINE. The X* user will recognize that these temporary arrays are not essential; X* however, they DO simplify the bookkeeping within the SUBROUTINE. X* X* The parameters in the CALL statement are: X* X* NumOfEqua - The number of derivative equations in the system X* X* NumOfPoints - An INTEGER which increments through the elements within X* the Work array. A given INTEGER value of NumOfPoints corresponds to a X* given value of the independent variable. The value of the X* independent variable takes on values at the sinc points, a X* different sinc point for each CALL of SUBROUTINE F. X* X* Work - A Work array that contains the necessary storage for all X* intermediate and finals results at the sinc points. X* X* The user is encouraged to define temporary variables and arrays: X* X* T - Value of the independent variable for the current SUBROUTINE X* CALL. (NOTE: T = Work(PsiPointer+i) ) X* X* Y(NumOfEqua) - An array containing the current values of the dependent X* variables of the system. X* X* YDOT(NumOfEqua) - An array to be computed within the SUBROUTINE that X* contains the values of the derivatives of the dependent variables X* with respect to the independent variable. X X IMPLICIT NONE X X INCLUDE 'workspace.h' X X* Argument list X DOUBLE PRECISION Work(*) X INTEGER Pos, NumOfEqua X X X X* local Variables X INTEGER k X* DOUBLE PRECISION Y(NumOfEqua), YDOT(NumOfEqua), T X* The local arrays Y and YDOT must have fixed dimensions equal to X* the number of equations NumOfEqua=3 X DOUBLE PRECISION Y(3), YDOT(3), T X X DOUBLE PRECISION Beta(3) X DATA ( Beta(k), k=1,3 ) / 1000.0d0, 1.0d0, 0.0001d0 / X X X* Pull values of the independent and dependent variables out of the X* work array. X X T = Work(PsiPointer + Pos) X X DO k=1,NumOfEqua X Y(k) = Work(NINT(Work(YPointerPointer + k)) + Pos) X END DO X X* Program your derivative equations here. e.g., X X YDOT( 1 ) = - beta(1) * y(1) + y(1) * y(1) X YDOT( 2 ) = - beta(2) * y(2) + y(2) * y(2) X YDOT( 3 ) = - beta(3) * y(3) + y(3) * y(3) X X* Store the values for YDOT(k) back into the Work array. X X DO k = 1, NumOfEqua X Work(NINT(Work(FPointerPointer + k)) + Pos) = YDOT(k) X END DO X X RETURN X END X X********************************************************************** X SUBROUTINE J_ij (NumOfEqua, Pos, Work) X X* The purpose of this SUBROUTINE is to compute the derivatives X* appearing in the Jacobian. X* X* Bij = dk(i)/dy(j) for i,j=1,..., NumOfEqua X* X* and to store the result within the Work array. X* X* The user is encouraged to modify this SUBROUTINE for his/her own X* problem of interest. The user is passed the entire Work array which X* contains all intermediate results. The user is encouraged not to X* modify any of the elements within the Work array directly but to use X* the temporary arrays defined within this example SUBROUTINE. The X* user will recognize that these temporary arrays are not essential; X* however, they DO simplify the bookkeeping within the SUBROUTINE. X* X* The parameters in the CALL statement are: X X* NumOfEqua - The number of derivative equations in the system X X* Pos - An INTEGER which increments through the elements within X* the Work array. A given INTEGER value of Pos corresponds to a X* given value of the independent variable. The value of the X* independent variable takes on values at the sinc points, a X* different sinc point for each CALL of SUBROUTINE F. X X* Work - A Work array that contains the necessary storage for all X* intermediate and finals results at the sinc points. X X* The user is encouraged to define temporary variables and arrays: X X* T - Value of the independent variable for the current SUBROUTINE X* CALL. (NOTE: T = Work(PsiPointer+i) ) X X* Y(NumOfEqua) - An array containing the current values of the dependent X* variables of the system. X X* Bij(NumOfEqua,NumOfEqua) - An array to be computed within the SUBROUTINE X* that contains the values of the derivatives of the dependent X* variables with respect to the independent variable. X X IMPLICIT none X X INCLUDE 'workspace.h' X X* Definition of parameters. X INTEGER Pos, NumOfEqua X DOUBLE PRECISION Work(*) X X* Local Variables X INTEGER l, k, m X X DOUBLE PRECISION Beta(3) X DATA ( Beta(k), k=1,3 ) / 1000.0d0, 1.0d0, 0.0001d0 / X X DOUBLE PRECISION C(3) X DATA ( C(k), k=1,3 ) / -1001.0d0, -2.0d0, -1.0001d0 / X X* Dimension Y() and Bij() to the number of ODE's X X* DOUBLE PRECISION Y(NumOfEqua), Bij(NumOfEqua,NumOfEqua), T X* The local arrays Y and Bij must have fixed dimensions X* determined by the number of equations NumOfEqua=3 X DOUBLE PRECISION Y(3), Bij(3,3), T X X* Pull values of the independent and dependent variables out of the X* Work array. X X T = Work(PsiPointer + Pos) X X DO k = 1, NumOfEqua X Y(k) = Work(NINT(Work(YPointerPointer + k)) + Pos) X END DO X X* Program your derivative equations here. e.g., X X Bij( 1, 1 ) = -beta(1) + 2.0d0 * y(1) X Bij( 1, 2 ) = 0.0d0 X Bij( 1, 3 ) = 0.0d0 X X Bij( 2, 1 ) = 0.0d0 X Bij( 2, 2 ) = -beta(2) + 2.0d0 * y(2) X Bij( 2, 3 ) = 0.0d0 X X Bij( 3, 1 ) = 0.0d0 X Bij( 3, 2 ) = 0.0d0 X Bij( 3, 3 ) = -beta(3) + 2.0d0 * y(3) X X* Store the values for Bij( k ) back into the Work array. X k = 0 X DO l = 1, NumOfEqua X DO m = 1, NumOfEqua X k = k + 1 X Work(NINT(Work(BijPointerPointer + k)) + Pos) = X . Bij(m, l) X END DO X END DO X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION Phi(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X Phi = PhiBul(Z) X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION OneOverPhiPrime(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X OneOverPhiPrime = PhiPriRecBul(Z) X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION Rho(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X Rho = RhoBul(Z) X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION Psi(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X Psi = PsiBul(Z) X X RETURN X END X X********************************************************************** X SUBROUTINE SetXs( EquaNum, Nxs, X ) X IMPLICIT NONE X X* This routine allows the user to set the values X* of the points at which to view the solution. X X* This section defines the argument list. X INTEGER EquaNum, Nxs X DOUBLE PRECISION X(*) X X INTEGER i X X if ( EquaNum .eq. 1 ) then X X DO i = 1, Nxs X X(i) = -0.001D0+0.002D0 * DFLOAT(i) X END DO X X else X X DO i = 1, Nxs X X(i) = -0.1D0+0.2D0 * DFLOAT(i) X END DO X X endif X X return X end X X********************************************************************** X DOUBLE PRECISION FUNCTION Solution(EquaNum, T) X IMPLICIT NONE X X* This section defines the argument list. X INTEGER EquaNum X DOUBLE PRECISION T X X* This section defines constants needed in the solution X integer k X X DOUBLE PRECISION Beta(3) X DATA ( Beta(k), k=1,3 ) / 1000.0d0, 1.0d0, 0.0001d0 / X X DOUBLE PRECISION C(3) X DATA ( C(k), k=1,3 ) / -1001.0d0, -2.0d0, -1.0001d0 / X X* This is the code section. X Solution = Beta(EquaNum) / X . (1.0d0 + C(EquaNum) * DEXP(Beta(EquaNum) * T)) X X RETURN X END X X********************************************************************** X SUBROUTINE StartAppr( NumOfEqua, N, work ) X IMPLICIT NONE X X* This routine allows the user to set the initial values X* and then puts the initial y values into the work array X X* This section defines the argument list. X INTEGER NumOfEqua, N X DOUBLE PRECISION work(*) X X* Local variables X INTEGER YPointer, OldYPointer, i, j X INTEGER EquaNum, Pos X X* User set initial values for the dependent variable X DOUBLE PRECISION y( 3, 41 ) X data ( ( y( i, j ), i=1,3 ), j=1,41 )/ 123 * -1.0d0 / X X INCLUDE 'workspace.h' X X do EquaNum = 1, 3 X X YPointer = NINT(Work(YPointerPointer + EquaNum )) X OldYPointer = NINT(Work(OldYPointerPointer + EquaNum )) X X do Pos = 1, 41 X X Work(YPointer + Pos) = y( EquaNum, Pos ) X Work(OldYPointer + Pos) = y( EquaNum, Pos ) X X enddo X X enddo X X RETURN X END X********************************************************************** X SUBROUTINE InitCond( NumOfEqua, Value ) X IMPLICIT NONE X X* This section defines the argument list. X INTEGER NumOfEqua X DOUBLE PRECISION Value(*) X X* This is the code section. X X Value(1) = -1.0D0 X Value(2) = -1.0D0 X Value(3) = -1.0D0 X X RETURN X END X END_OF_FILE if test 12054 -ne `wc -c <'problem_Bul.f'`; then echo shar: \"'problem_Bul.f'\" unpacked with wrong size! fi # end of 'problem_Bul.f' fi if test -f 'problem_Fun.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'problem_Fun.f'\" else echo shar: Extracting \"'problem_Fun.f'\" \(11344 characters\) sed "s/^X//" >'problem_Fun.f' <<'END_OF_FILE' X* File problem_Fun.f X* Example 7.4 X X SUBROUTINE ControlVars(SincPts,NumOfEqua,Nxs,MaxIter,H,Itest) X X* The purpose of this SUBROUTINE is to set the controlling X* parameters for the problem. X* X* The parameters in the CALL statement are: X X* SincPts - An INTEGER which controls number of points used in the X* approximation. The solution is computed at y_i( k * H ) with X* k = - SincPts ... SincPts. X X* NumOfEqua - INTEGER - Number of dependent variables in the system X* (i.e., the number of simultaneous IVP's to be solved). X X* Nxs - INTEGER - Number of points at which the solution will be X* approximated. X X* MaxIter - INTEGER - The maximum number of iterations the procedure X* will use in trying to converge. X X* H - DOUBLE PRECISION - This is the step size. In some instances X* picking the optimal H can make a significant difference in the X* accuracy of the result, particularly for small SincPts. However, as X* long H is picked as: X X* H = 1.0d0 /sqrt(C*SincPts) for some C X X* the algorithm will have the appropriate asymptotic accuracy. X* Itest INTEGER: If Itest=0 no exact solution is known and the value X* of double precision function Solution is irrevelant. If itest=1 X* the analytic solution is given by double precision function X* Solution X X IMPLICIT NONE X X DOUBLE PRECISION Pi, C X PARAMETER (Pi = 3.1415926535897932D0 ) X X INTEGER SincPts, NumOfEqua, Nxs, MaxIter,Itest X DOUBLE PRECISION H X X SincPts = 20 X NumOfEqua = 1 X Nxs = 10 X MaxIter = 80 X C=2.0d0 X PRINT * ,'Example 7.4 File: problem_Fun.f' X PRINT * ,'Linear problem' X H = Pi / DSQRT( C * DBLE( SincPts ) ) X IF(SincPts.GT.70) THEN X print *,'This program does not work for C=2.0 and more than 70 X +sinc-points' X STOP X END IF X* If exact solution known, it should be defined by DOUBLE PRECISION X* FUNCTION Solution and we put: X Itest=1 X* If exact solution is not known, then the result of DOUBLE PRECISION X* FUNCTION is irrevelant and we put X* Itest=0 X return X end X X********************************************************************** X X X********************************************************************** X SUBROUTINE F(NumOfEqua, Pos, Work) X X* The purpose of this SUBROUTINE is to compute the derivatives: X* X* dy(i)/dt = f ( t, y(i) ) for i=1,..., NumOfEqua X* X* and to store the result within the Work array. X* X* The user is encouraged to modify this SUBROUTINE for his/her own X* problem of interest. The user is passed the entire Work array which X* contains all intermediate results. The user is encouraged not to X* modify any of the elements within the Work array directly but to use X* the temporary arrays defined within this example SUBROUTINE. The X* user will recognize that these temporary arrays are not essential; X* however, they DO simplify the bookkeeping within the SUBROUTINE. X* X* The parameters in the CALL statement are: X* X* NumOfEqua - The number of derivative equations in the system X* X* NumOfPoints - An INTEGER which increments through the elements within X* the Work array. A given INTEGER value of NumOfPoints corresponds to a X* given value of the independent variable. The value of the X* independent variable takes on values at the sinc points, a X* different sinc point for each CALL of SUBROUTINE F. X* X* Work - A Work array that contains the necessary storage for all X* intermediate and finals results at the sinc points. X* X* The user is encouraged to define temporary variables and arrays: X* X* T - Value of the independent variable for the current SUBROUTINE X* CALL. (NOTE: T = Work(PsiPointer+i) ) X* X* Y(NumOfEqua) - An array containing the current values of the dependent X* variables of the system. X* X* YDOTNumOfEqua) - An array to be computed within the SUBROUTINE that X* contains the values of the derivatives of the dependent variables X* with respect to the independent variable. X X IMPLICIT NONE X X INCLUDE 'workspace.h' X X* Argument list X DOUBLE PRECISION Work(*) X INTEGER Pos, NumOfEqua X X* local Variables X INTEGER k X* DOUBLE PRECISION Y(NumOfEqua), YDOT(NumOfEqua), T X* The local arrays Y and YDOT must have fixed dimensions equal to X* the number of equations NumOfEqua=1 X DOUBLE PRECISION Y(1), YDOT(1), T X X* Pull values of the independent and dependent variables out of the X* work array. X X T = Work(PsiPointer + Pos) X X DO k=1,NumOfEqua X Y(k) = Work(NINT(Work(YPointerPointer + k)) + Pos) X END DO X X* Program your derivative equations here. e.g., X Xc print*,' f: t: ', t Xc YDOT(1) = -( (dexp(t)+1.0d0)*t*( (1.0d0 +t*t)**(-1.5d0) )- X YDOT(1) = -( (dexp(t)+1.0d0)*t*( (1.0d0 +t*t)**(-1.5d0) )+ X . ( (1.0d0+t*t)**(-0.5d0) )*dexp(t) )/( (1.0d0+dexp(t))**2.0d0) Xc print*,' after: ' X X* Store the values for YDOT(k) back into the Work array. X X DO k = 1, NumOfEqua X Work(NINT(Work(FPointerPointer + k)) + Pos) = YDOT(k) X END DO X X RETURN X END X X********************************************************************** X SUBROUTINE J_ij (NumOfEqua, Pos, Work) X X* The purpose of this SUBROUTINE is to compute the derivatives X* appearing in the Jacobian. X* X* Bij = dk(i)/dy(j) for i,j=1,..., NumOfEqua X* X* and to store the result within the Work array. X* X* The user is encouraged to modify this SUBROUTINE for his/her own X* problem of interest. The user is passed the entire Work array which X* contains all intermediate results. The user is encouraged not to X* modify any of the elements within the Work array directly but to use X* the temporary arrays defined within this example SUBROUTINE. The X* user will recognize that these temporary arrays are not essential; X* however, they DO simplify the bookkeeping within the SUBROUTINE. X* X* The parameters in the CALL statement are: X X* NumOfEqua - The number of derivative equations in the system X X* Pos - An INTEGER which increments through the elements within X* the Work array. A given INTEGER value of Pos corresponds to a X* given value of the independent variable. The value of the X* independent variable takes on values at the sinc points, a X* different sinc point for each CALL of SUBROUTINE F. X X* Work - A Work array that contains the necessary storage for all X* intermediate and finals results at the sinc points. X X* The user is encouraged to define temporary variables and arrays: X X* T - Value of the independent variable for the current SUBROUTINE X* CALL. (NOTE: T = Work(PsiPointer+i) ) X X* Y(NumOfEqua) - An array containing the current values of the dependent X* variables of the system. X X* Bij(NumOfEqua,NumOfEqua) - An array to be computed within the SUBROUTINE X* that contains the values of the derivatives of the dependent X* variables with respect to the independent variable. X X IMPLICIT none X X INCLUDE 'workspace.h' X X* Definition of parameters. X INTEGER Pos, NumOfEqua X DOUBLE PRECISION Work(*) X X* Local Variables X INTEGER l, k, m X X* Dimension Y() and Bij() to the number of ODE's X X* DOUBLE PRECISION Y(NumOfEqua), Bij(NumOfEqua,NumOfEqua), T X* The local arrays Y and Bij must have fixed dimensions X* determined by the number of equations NumOfEqua=1 X DOUBLE PRECISION Y(1), Bij(1,1), T X X* Pull values of the independent and dependent variables out of the X* Work array. X X T = Work(PsiPointer + Pos) X X DO k = 1, NumOfEqua X Y(k) = Work(NINT(Work(YPointerPointer + k)) + Pos) X END DO X X* Program your derivative equations here. e.g., X X Bij( 1, 1 ) = 0.0d0 X X* Store the values for Bij( k ) back into the Work array. X k = 0 X DO l = 1, NumOfEqua X DO m = 1, NumOfEqua X k = k + 1 X Work(NINT(Work(BijPointerPointer + k)) + Pos) = X . Bij(m, l) X END DO X END DO X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION Phi(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X Phi = PhiFun(Z) X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION OneOverPhiPrime(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X OneOverPhiPrime = PhiPriRecFun(Z) X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION Rho(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X Rho = RhoFun(Z) X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION Psi(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X Psi = PsiFun(Z) X X RETURN X END X X********************************************************************** X SUBROUTINE SetXs( EquaNum, Nxs, X ) X IMPLICIT NONE X X* This routine allows the user to set the values X* of the points at which to view the solution. X X* This section defines the argument list. X INTEGER EquaNum, Nxs X DOUBLE PRECISION X(*) X X INTEGER i X X DO i = 1, Nxs X X(i) = -0.1D0+0.2D0 * DFLOAT(i) X END DO X X return X end X X********************************************************************** X DOUBLE PRECISION FUNCTION Solution(EquaNum, T) X IMPLICIT NONE X X* This section defines the argument list. X INTEGER EquaNum X DOUBLE PRECISION T X DOUBLE PRECISION phi X X* This section defines local variables needed in the solution X X* This is the code section. X phi = dlog( t + dsqrt( 1.0d0 + t*t ) ) X X Solution = 1.0d0 / ( dsqrt( 1.0d0 + t*t ) * (dexp(t) + 1.0d0) ) X X RETURN X END X X********************************************************************** X SUBROUTINE StartAppr( NumOfEqua, N, work ) X IMPLICIT NONE X X* This routine allows the user to set the initial values X* and then puts the initial y values into the work array X X* This section defines the argument list. X INTEGER NumOfEqua, N X DOUBLE PRECISION work(*) X X* Local variables X INTEGER YPointer, OldYPointer, j X INTEGER EquaNum, Pos X X* User set initial values for the dependent variable X DOUBLE PRECISION y( 41 ) X data ( y( j ), j=1,41 )/ 41 * 1.0d0 / X X INCLUDE 'workspace.h' X X do EquaNum = 1, 1 X X YPointer = NINT(Work(YPointerPointer + EquaNum )) X OldYPointer = NINT(Work(OldYPointerPointer + EquaNum )) X X do Pos = 1, 41 X X Work(YPointer + Pos) = y( Pos ) X Work(OldYPointer + Pos) = y( Pos ) X X enddo X X enddo X X RETURN X END X********************************************************************** X SUBROUTINE InitCond(NumOfEqua, Value) X IMPLICIT NONE X X* This section defines the argument list. X INTEGER NumOfEqua X DOUBLE PRECISION Value(*) X X* This is the code section. X X Value(1) = 0.0d0 X X RETURN X END X END_OF_FILE if test 11344 -ne `wc -c <'problem_Fun.f'`; then echo shar: \"'problem_Fun.f'\" unpacked with wrong size! fi # end of 'problem_Fun.f' fi if test -f 'problem_Id.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'problem_Id.f'\" else echo shar: Extracting \"'problem_Id.f'\" \(11825 characters\) sed "s/^X//" >'problem_Id.f' <<'END_OF_FILE' X********************************************************************** X* File problem_Id.f X* Example 7.5 X SUBROUTINE ControlVars(SincPts,NumOfEqua,Nxs,MaxIter,H,Itest) X X* The purpose of this SUBROUTINE is to set the controlling X* parameters for the problem. X* X* The parameters in the CALL statement are: X X* SincPts - An INTEGER which controls number of points used in the X* approximation. The solution is computed at y_i( k * H ) with X* k = - SincPts ... SincPts. X X* NumOfEqua - INTEGER - Number of dependent variables in the system X* (i.e., the number of simultaneous IVP's to be solved). X X* Nxs - INTEGER - Number of points at which the solution will be X* approximated. X X* MaxIter - INTEGER - The maximum number of iterations the procedure X* will use in trying to converge. X X* H - DOUBLE PRECISION - This is the step size. In some instances X* picking the optimal H can make a significant difference in the X* accuracy of the result, particularly for small SincPts. However, as X* long H is picked as: X X* H = 1.0d0 /sqrt(C*SincPts) for some C X X* the algorithm will have the appropriate asymptotic accuracy. X* Itest INTEGER: If Itest=0 no exact solution is known and the value X* of double precision function Solution is irrevelant. If itest=1 X* the analytic solution is given by double precision function X* Solution X X IMPLICIT NONE X X DOUBLE PRECISION Pi, C X PARAMETER (Pi = 3.1415926535897932D0 ) X X INTEGER SincPts, NumOfEqua, Nxs, MaxIter,Itest X DOUBLE PRECISION H X X SincPts = 20 X NumOfEqua = 2 X Nxs = 10 X MaxIter = 80 X C=2.0d0 X PRINT * ,'Example 7.5 File: problem_Id.f' X H = Pi / DSQRT( C * DBLE( SincPts ) ) X* If exact solution known, it should be defined by DOUBLE PRECISION X* FUNCTION Solution and we put: X Itest=1 X* If exact solution is not known, then the result of DOUBLE PRECISION X* FUNCTION is irrevelant and we put X* Itest=0 X return X end X X********************************************************************** X X********************************************************************** X SUBROUTINE F(NumOfEqua, Pos, Work) X X* The purpose of this SUBROUTINE is to compute the derivatives: X* X* dy(i)/dt = f ( t, y(i) ) for i=1,..., NumOfEqua X* X* and to store the result within the Work array. X* X* The user is encouraged to modify this SUBROUTINE for his/her own X* problem of interest. The user is passed the entire Work array which X* contains all intermediate results. The user is encouraged not to X* modify any of the elements within the Work array directly but to use X* the temporary arrays defined within this example SUBROUTINE. The X* user will recognize that these temporary arrays are not essential; X* however, they DO simplify the bookkeeping within the SUBROUTINE. X* X* The parameters in the CALL statement are: X* X* NumOfEqua - The number of derivative equations in the system X* X* NumOfPoints - An INTEGER which increments through the elements within X* the Work array. A given INTEGER value of NumOfPoints corresponds to a X* given value of the independent variable. The value of the X* independent variable takes on values at the sinc points, a X* different sinc point for each CALL of SUBROUTINE F. X* X* Work - A Work array that contains the necessary storage for all X* intermediate and finals results at the sinc points. X* X* The user is encouraged to define temporary variables and arrays: X* X* T - Value of the independent variable for the current SUBROUTINE X* CALL. (NOTE: T = Work(PsiPointer+i) ) X* X* Y(NumOfEqua) - An array containing the current values of the dependent X* variables of the system. X* X* YDOT(NumOfEqua) - An array to be computed within the SUBROUTINE that X* contains the values of the derivatives of the dependent variables X* with respect to the independent variable. X X IMPLICIT NONE X X INCLUDE 'workspace.h' X X* Argument list X DOUBLE PRECISION Work(*) X INTEGER Pos, NumOfEqua X X* local Variables X INTEGER k X* DOUBLE PRECISION Y(NumOfEqua), YDOT(NumOfEqua), T X* The local arrays Y and YDOT must have fixed dimensions equal to X* the number of equations NumOfEqua=2 X DOUBLE PRECISION Y(2),YDOT(2),T X X X* Pull values of the independent and dependent variables out of the X* work array. X X T = Work(PsiPointer + Pos) X X DO k=1,NumOfEqua X Y(k) = Work(NINT(Work(YPointerPointer + k)) + Pos) X END DO X X* Program your derivative equations here. e.g., X Xc print*,' f: t: ', t Xc print*,' f: dcosh(t): ', dcosh(t) X X YDOT(1) = Y( 2 ) X Xc if ( dabs(t) .lt. 100.0d0 ) then X Xc print*,' f: in 1: ', t X X YDOT(2) = 2.0d0 * dsinh(t)*dsinh(t)*y(1)*y(1)*y(1) - X . y(1) X Xc else X Xc print*,' f: t in 2: ', t X Xc YDOT(2) = 2.0d0 * dtanh(t)*dtanh(t)*y(1)*y(1)*y(1) X Xc endif X X* Store the values for YDOT(k) back into the Work array. X X DO k = 1, NumOfEqua X Work(NINT(Work(FPointerPointer + k)) + Pos) = YDOT(k) X END DO X X RETURN X END X X********************************************************************** X SUBROUTINE J_ij (NumOfEqua, Pos, Work) X X* The purpose of this SUBROUTINE is to compute the derivatives X* appearing in the Jacobian. X* X* Bij = dk(i)/dy(j) for i,j=1,..., NumOfEqua X* X* and to store the result within the Work array. X* X* The user is encouraged to modify this SUBROUTINE for his/her own X* problem of interest. The user is passed the entire Work array which X* contains all intermediate results. The user is encouraged not to X* modify any of the elements within the Work array directly but to use X* the temporary arrays defined within this example SUBROUTINE. The X* user will recognize that these temporary arrays are not essential; X* however, they DO simplify the bookkeeping within the SUBROUTINE. X* X* The parameters in the CALL statement are: X X* NumOfEqua - The number of derivative equations in the system X X* Pos - An INTEGER which increments through the elements within X* the Work array. A given INTEGER value of Pos corresponds to a X* given value of the independent variable. The value of the X* independent variable takes on values at the sinc points, a X* different sinc point for each CALL of SUBROUTINE F. X X* Work - A Work array that contains the necessary storage for all X* intermediate and finals results at the sinc points. X X* The user is encouraged to define temporary variables and arrays: X X* T - Value of the independent variable for the current SUBROUTINE X* CALL. (NOTE: T = Work(PsiPointer+i) ) X X* Y(NumOfEqua) - An array containing the current values of the dependent X* variables of the system. X X* Bij(NumOfEqua,NumOfEqua) - An array to be computed within the SUBROUTINE X* that contains the values of the derivatives of the dependent X* variables with respect to the independent variable. X X IMPLICIT none X X INCLUDE 'workspace.h' X X* Definition of parameters. X INTEGER Pos, NumOfEqua X DOUBLE PRECISION Work(*) X X* Local Variables X INTEGER l, k, m X X* Dimension Y() and Bij() to the number of ODE's X X X* DOUBLE PRECISION Y(NumOfEqua), Bij(NumOfEqua,NumOfEqua), T X* The local arrays Y and Bij must have fixed dimensions X* determined by the number of equations NumOfEqua=2 X DOUBLE PRECISION Y(2),Bij(2,2),T X X X* Pull values of the independent and dependent variables out of the X* Work array. X X T = Work(PsiPointer + Pos) X X DO k = 1, NumOfEqua X Y(k) = Work(NINT(Work(YPointerPointer + k)) + Pos) X END DO X X* Program your derivative equations here. e.g., X Xc print*,' b: t: ', t Xc print*,' b: dcosh(t): ', dcosh(t) X X Bij( 1, 1 ) = 0.0d0 X Bij( 1, 2 ) = 1.0d0 X Xc if ( dabs(t) .lt. 100.0d0 ) then X X Bij( 2, 1 ) = 6.0d0 * dsinh(t)*dsinh(t)*y(1)*y(1) - X . 1.0d0 X Xc else X Xc Bij( 2, 1 ) = 6.0d0 * tanh(t)*tanh(t)*y(1)*y(1) X Xc endif X X Bij( 2, 2 ) = 0.0d0 X X* Store the values for Bij( k ) back into the Work array. X k = 0 X DO l = 1, NumOfEqua X DO m = 1, NumOfEqua X k = k + 1 X Work(NINT(Work(BijPointerPointer + k)) + Pos) = X . Bij(m, l) X END DO X END DO X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION Phi(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X Phi = PhiId(Z) X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION OneOverPhiPrime(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X OneOverPhiPrime = PhiPriRecId(Z) X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION Rho(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X Rho = RhoId(Z) X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION Psi(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X Psi = PsiId(Z) X X RETURN X END X X********************************************************************** X SUBROUTINE SetXs( EquaNum, Nxs, X ) X IMPLICIT NONE X X* This routine allows the user to set the values X* of the points at which to view the solution. X X* This section defines the argument list. X INTEGER EquaNum, Nxs X DOUBLE PRECISION X(*) X X INTEGER i X X DO i = 1, Nxs X X(i) = 0.2D0 * DFLOAT(i) X END DO X X return X end X X********************************************************************** X DOUBLE PRECISION FUNCTION Solution(EquaNum, T) X IMPLICIT NONE X X* This section defines the argument list. X INTEGER EquaNum X DOUBLE PRECISION T X* Local variables: X DOUBLE PRECISION C,S X* This section defines local variables needed in the solution X X* This is the code section. X C=dcosh(T) X IF (EquaNum .EQ. 1) THEN X Solution = 1.0d0 / dcosh( T ) X ELSE X S=dsinh(T) X Solution=-S/C**2 X END IF X RETURN X END X X********************************************************************** X SUBROUTINE StartAppr(NumOfEqua, N, work ) X IMPLICIT NONE X X* This routine allows the user to set the initial values X* and then puts the initial y values into the work array X X* This section defines the argument list. X INTEGER NumOfEqua, N X DOUBLE PRECISION work(*) X X* Local variables X INTEGER YPointer, OldYPointer, j X INTEGER EquaNum, Pos X X* User set initial values for the dependent variable X DOUBLE PRECISION y( 2, 41 ) X data ( y( 1, j ), j=1,41 )/ 41 * 1.0d0 / X data ( y( 2, j ), j=1,41 )/ 41 * 1.0d0 / X X INCLUDE 'workspace.h' X X do EquaNum = 1, 2 X X YPointer = NINT(Work(YPointerPointer + EquaNum )) X OldYPointer = NINT(Work(OldYPointerPointer + EquaNum )) X X do Pos = 1, 41 X X Work(YPointer + Pos) = y( EquaNum, Pos ) X Work(OldYPointer + Pos) = y( EquaNum, Pos ) X X enddo X X enddo X X RETURN X END X********************************************************************** X SUBROUTINE InitCond(NumOfEqua, Value) X IMPLICIT NONE X X* This section defines the argument list. X INTEGER NumOfEqua X DOUBLE PRECISION Value(NumOfEqua + 1) X X* This is the code section. X X Value(1) = 0.0d0 X Value(2) = 0.0d0 X X RETURN X END X END_OF_FILE if test 11825 -ne `wc -c <'problem_Id.f'`; then echo shar: \"'problem_Id.f'\" unpacked with wrong size! fi # end of 'problem_Id.f' fi if test -f 'problem_N11.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'problem_N11.f'\" else echo shar: Extracting \"'problem_N11.f'\" \(11378 characters\) sed "s/^X//" >'problem_N11.f' <<'END_OF_FILE' X********************************************************************** X* File problem_N11.f X* Example 7.6 X SUBROUTINE ControlVars( SincPts,NumOfEqua,Nxs,MaxIter,H,Itest) X X* The purpose of this SUBROUTINE is to set the controlling X* parameters for the problem. X* X* The parameters in the CALL statement are: X X* SincPts - An INTEGER which controls number of points used in the X* approximation. The solution is computed at y_i( k * H ) with X* k = - SincPts ... SincPts. X X* NumOfEqua - INTEGER - Number of dependent variables in the system X* (i.e., the number of simultaneous IVP's to be solved). X X* Nxs - INTEGER - Number of points at which the solution will be X* approximated. X X* MaxIter - INTEGER - The maximum number of iterations the procedure X* will use in trying to converge. X X* H - DOUBLE PRECISION - This is the step size. In some instances X* picking the optimal H can make a significant difference in the X* accuracy of the result, particularly for small SincPts. However, as X* long H is picked as: X X* H = 1.0d0 /sqrt(C*SincPts) for some C X X* the algorithm will have the appropriate asymptotic accuracy. X* Itest INTEGER: If Itest=0 no exact solution is known and the value X* of double precision function Solution is irrevelant. If itest=1 X* the analytic solution is given by double precision function X* Solution X X IMPLICIT NONE X X DOUBLE PRECISION Pi, C X PARAMETER (Pi = 3.1415926535897932D0 ) X X INTEGER SincPts, NumOfEqua, Nxs, MaxIter,Itest X DOUBLE PRECISION H X X SincPts = 20 X NumOfEqua = 2 X Nxs = 9 X MaxIter = 80 X C=1.0d0 X PRINT * ,'Example 7.6 File: problem_N11.f' X PRINT * ,'Linear problem' X H = Pi / DSQRT( C * DBLE( SincPts ) ) X* If exact solution known, it should be defined by DOUBLE PRECISION X* FUNCTION Solution and we put: X Itest=1 X* If exact solution is not known, then the result of DOUBLE PRECISION X* FUNCTION is irrevelant and we put X* Itest=0 X return X end X X********************************************************************** X X SUBROUTINE F(NumOfEqua, Pos, Work) X X* The purpose of this SUBROUTINE is to compute the derivatives: X* X* dy(i)/dt = f ( t, y(i) ) for i=1,..., NumOfEqua X* X* and to store the result within the Work array. X* X* The user is encouraged to modify this SUBROUTINE for his/her own X* problem of interest. The user is passed the entire Work array which X* contains all intermediate results. The user is encouraged not to X* modify any of the elements within the Work array directly but to use X* the temporary arrays defined within this example SUBROUTINE. The X* user will recognize that these temporary arrays are not essential; X* however, they DO simplify the bookkeeping within the SUBROUTINE. X* X* The parameters in the CALL statement are: X* X* NumOfEqua - The number of derivative equations in the system X* X* NumOfPoints - An INTEGER which increments through the elements within X* the Work array. A given INTEGER value of NumOfPoints corresponds to a X* given value of the independent variable. The value of the X* independent variable takes on values at the sinc points, a X* different sinc point for each CALL of SUBROUTINE F. X* X* Work - A Work array that contains the necessary storage for all X* intermediate and finals results at the sinc points. X* X* The user is encouraged to define temporary variables and arrays: X* X* T - Value of the independent variable for the current SUBROUTINE X* CALL. (NOTE: T = Work(PsiPointer+i) ) X* X* Y(NumOfEqua) - An array containing the current values of the dependent X* variables of the system. X* X* YDOT(NumOfEqua) - An array to be computed within the SUBROUTINE that X* contains the values of the derivatives of the dependent variables X* with respect to the independent variable. X X IMPLICIT NONE X X INCLUDE 'workspace.h' X X* Argument list X DOUBLE PRECISION Work(*) X INTEGER Pos, NumOfEqua X X* local Variables X INTEGER k X* DOUBLE PRECISION Y(NumOfEqua), YDOT(NumOfEqua), T X* The local arrays Y and YDOT must have fixed dimensions equal to X* the number of equations NumOfEqua=2 X DOUBLE PRECISION Y(2),YDOT(2),T X X* Pull values of the independent and dependent variables out of the X* work array. X X T = Work(PsiPointer + Pos) X X DO k=1,NumOfEqua X Y(k) = Work(NINT(Work(YPointerPointer + k)) + Pos) X END DO X X* Program your derivative equations here. e.g., X X YDOT(1) = Y( 2 ) / ( 1.0d0 - t*t ) X X YDOT(2) = - 6.0d0 * Y( 1 ) X X X* Store the values for YDOT(k) back into the Work array. X X DO k = 1, NumOfEqua X Work(NINT(Work(FPointerPointer + k)) + Pos) = YDOT(k) X END DO X X RETURN X END X X********************************************************************** X SUBROUTINE J_ij (NumOfEqua, Pos, Work) X X* The purpose of this SUBROUTINE is to compute the derivatives X* appearing in the Jacobian. X* X* Bij = dk(i)/dy(j) for i,j=1,..., NumOfEqua X* X* and to store the result within the Work array. X* X* The user is encouraged to modify this SUBROUTINE for his/her own X* problem of interest. The user is passed the entire Work array which X* contains all intermediate results. The user is encouraged not to X* modify any of the elements within the Work array directly but to use X* the temporary arrays defined within this example SUBROUTINE. The X* user will recognize that these temporary arrays are not essential; X* however, they DO simplify the bookkeeping within the SUBROUTINE. X* X* The parameters in the CALL statement are: X X* NumOfEqua - The number of derivative equations in the system X X* Pos - An INTEGER which increments through the elements within X* the Work array. A given INTEGER value of Pos corresponds to a X* given value of the independent variable. The value of the X* independent variable takes on values at the sinc points, a X* different sinc point for each CALL of SUBROUTINE F. X X* Work - A Work array that contains the necessary storage for all X* intermediate and finals results at the sinc points. X X* The user is encouraged to define temporary variables and arrays: X X* T - Value of the independent variable for the current SUBROUTINE X* CALL. (NOTE: T = Work(PsiPointer+i) ) X X* Y(NumOfEqua) - An array containing the current values of the dependent X* variables of the system. X X* Bij(NumOfEqua,NumOfEqua) - An array to be computed within the SUBROUTINE X* that contains the values of the derivatives of the dependent X* variables with respect to the independent variable. X X IMPLICIT none X X INCLUDE 'workspace.h' X X* Definition of parameters. X INTEGER Pos, NumOfEqua X DOUBLE PRECISION Work(*) X X* Local Variables X INTEGER l, k, m X X* Dimension Y() and Bij() to the number of ODE's X X* DOUBLE PRECISION Y(NumOfEqua), Bij(NumOfEqua,NumOfEqua), T X* The local arrays Y and Bij must have fixed dimensions X* determined by the number of equations NumOfEqua=2 X DOUBLE PRECISION Y(2),Bij(2,2),T X X* Pull values of the independent and dependent variables out of the X* Work array. X X T = Work(PsiPointer + Pos) X X DO k = 1, NumOfEqua X Y(k) = Work(NINT(Work(YPointerPointer + k)) + Pos) X END DO X X* Program your derivative equations here. e.g., X X Bij( 1, 1 ) = 0.0d0 X Bij( 1, 2 ) = 1.0d0 / ( 1.0d0 - t*t ) X X Bij( 2, 1 ) = - 6.0d0 X Bij( 2, 2 ) = 0.0d0 X X* Store the values for Bij( k ) back into the Work array. X k = 0 X DO l = 1, NumOfEqua X DO m = 1, NumOfEqua X k = k + 1 X Work(NINT(Work(BijPointerPointer + k)) + Pos) = X . Bij(m, l) X END DO X END DO X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION Phi(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X Phi = PhiN11( Z ) X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION OneOverPhiPrime(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X OneOverPhiPrime = PhiPriRecN11( Z ) X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION Rho(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X Rho = RhoN11(Z) X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION Psi(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X Psi = PsiN11(Z) X X RETURN X END X X********************************************************************** X SUBROUTINE SetXs( EquaNum, Nxs, X ) X IMPLICIT NONE X X* This routine allows the user to set the values X* of the points at which to view the solution. X X* This section defines the argument list. X INTEGER EquaNum, Nxs X DOUBLE PRECISION X(*) X X INTEGER i X X DO i = 1, Nxs X X(i) = -1.0d0 + 0.2D0 * DFLOAT(i) X END DO X X return X end X X********************************************************************** X DOUBLE PRECISION FUNCTION Solution(EquaNum, T) X IMPLICIT NONE X X* This section defines the argument list. X INTEGER EquaNum X DOUBLE PRECISION T X X* This section defines local variables needed in the solution X X* This is the code section. X if ( EquaNum .eq. 1 ) then X Solution = ( 3.0d0 * t * t - 1.0d0 ) / 2.0d0 X else X Solution = 3.0d0 * t * ( 1.0d0 - t*t ) X endif X X RETURN X END X X********************************************************************** X SUBROUTINE StartAppr( NumOfEqua, N, work ) X IMPLICIT NONE X X* This routine allows the user to set the initial values X* and then puts the initial y values into the work array X X* This section defines the argument list. X INTEGER NumOfEqua, N X DOUBLE PRECISION work(*) X X* Local variables X INTEGER YPointer, OldYPointer, j X INTEGER EquaNum, Pos X X* User set initial values for the dependent variable X DOUBLE PRECISION y( 2, 41 ) X data ( y( 1, j ), j=1,41 )/ 41 * 1.0d0 / X data ( y( 2, j ), j=1,41 )/ 41 * 0.0d0 / X X INCLUDE 'workspace.h' X X do EquaNum = 1, 2 X X YPointer = NINT(Work(YPointerPointer + EquaNum )) X OldYPointer = NINT(Work(OldYPointerPointer + EquaNum )) X X do Pos = 1, 41 X X Work(YPointer + Pos) = y( EquaNum, Pos ) X Work(OldYPointer + Pos) = y( EquaNum, Pos ) X X enddo X X enddo X X RETURN X END X********************************************************************** X SUBROUTINE InitCond(NumOfEqua, Value) X IMPLICIT NONE X X* This section defines the argument list. X INTEGER NumOfEqua X DOUBLE PRECISION Value(NumOfEqua + 1) X X* This is the code section. X X Value(1) = 1.0D0 X Value(2) = 0.0D0 X X RETURN X END X END_OF_FILE if test 11378 -ne `wc -c <'problem_N11.f'`; then echo shar: \"'problem_N11.f'\" unpacked with wrong size! fi # end of 'problem_N11.f' fi if test -f 'problem_RR.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'problem_RR.f'\" else echo shar: Extracting \"'problem_RR.f'\" \(10969 characters\) sed "s/^X//" >'problem_RR.f' <<'END_OF_FILE' X********************************************************************** X* File problem_RR.f X* Example 7.7 X SUBROUTINE ControlVars( SincPts,NumOfEqua,Nxs,MaxIter,H,Itest) X X* The purpose of this SUBROUTINE is to set the controlling X* parameters for the problem. X* X* The parameters in the CALL statement are: X X* SincPts - An INTEGER which controls number of points used in the X* approximation. The solution is computed at y_i( k * H ) with X* k = - SincPts ... SincPts. X X* NumOfEqua - INTEGER - Number of dependent variables in the system X* (i.e., the number of simultaneous IVP's to be solved). X X* Nxs - INTEGER - Number of points at which the solution will be X* approximated. X X* MaxIter - INTEGER - The maximum number of iterations the procedure X* will use in trying to converge. X X* H - DOUBLE PRECISION - This is the step size. In some instances X* picking the optimal H can make a significant difference in the X* accuracy of the result, particularly for small SincPts. However, as X* long H is picked as: X X* H = 1.0d0 /sqrt(C*SincPts) for some C X X* the algorithm will have the appropriate asymptotic accuracy. X* Itest INTEGER: If Itest=0 no exact solution is known and the value X* of double precision function Solution is irrevelant. If itest=1 X* the analytic solution is given by double precision function X* Solution X X IMPLICIT NONE X X DOUBLE PRECISION Pi, C X PARAMETER (Pi = 3.1415926535897932D0 ) X X INTEGER SincPts, NumOfEqua, Nxs, MaxIter,Itest X DOUBLE PRECISION H X X SincPts = 20 X NumOfEqua = 1 X Nxs = 10 X MaxIter = 80 X C=2.0d0 X PRINT * ,'Example 7.7 File: problem_RR.f' X PRINT * ,'Linear problem' X H = Pi / DSQRT( C * DBLE( SincPts ) ) X* If exact solution known, it should be defined by DOUBLE PRECISION X* FUNCTION Solution and we put: X Itest=1 X* If exact solution is not known, then the result of DOUBLE PRECISION X* FUNCTION is irrevelant and we put X* Itest=0 X return X end X X********************************************************************** X X SUBROUTINE F(NumOfEqua, Pos, Work) X X* The purpose of this SUBROUTINE is to compute the derivatives: X* X* dy(i)/dt = f ( t, y(i) ) for i=1,..., NumOfEqua X* X* and to store the result within the Work array. X* X* The user is encouraged to modify this SUBROUTINE for his/her own X* problem of interest. The user is passed the entire Work array which X* contains all intermediate results. The user is encouraged not to X* modify any of the elements within the Work array directly but to use X* the temporary arrays defined within this example SUBROUTINE. The X* user will recognize that these temporary arrays are not essential; X* however, they DO simplify the bookkeeping within the SUBROUTINE. X* X* The parameters in the CALL statement are: X* X* NumOfEqua - The number of derivative equations in the system X* X* NumOfPoints - An INTEGER which increments through the elements within X* the Work array. A given INTEGER value of NumOfPoints corresponds to a X* given value of the independent variable. The value of the X* independent variable takes on values at the sinc points, a X* different sinc point for each CALL of SUBROUTINE F. X* X* Work - A Work array that contains the necessary storage for all X* intermediate and finals results at the sinc points. X* X* The user is encouraged to define temporary variables and arrays: X* X* T - Value of the independent variable for the current SUBROUTINE X* CALL. (NOTE: T = Work(PsiPointer+i) ) X* X* Y(NumOfEqua) - An array containing the current values of the dependent X* variables of the system. X* X* YDOT(NumOfEqua) - An array to be computed within the SUBROUTINE that X* contains the values of the derivatives of the dependent variables X* with respect to the independent variable. X X IMPLICIT NONE X X INCLUDE 'workspace.h' X X* Argument list X DOUBLE PRECISION Work(*) X INTEGER Pos, NumOfEqua X X X X* local Variables X INTEGER k X* DOUBLE PRECISION Y(NumOfEqua), YDOT(NumOfEqua), T X* The local arrays Y and YDOT must have fixed dimensions equal to X* the number of equations NumOfEqua=1 X DOUBLE PRECISION Y(1), YDOT(1), T X X* Pull values of the independent and dependent variables out of the X* work array. X X T = Work(PsiPointer + Pos) X X DO k=1,NumOfEqua X Y(k) = Work(NINT(Work(YPointerPointer + k)) + Pos) X END DO X X* Program your derivative equations here. e.g., X X YDOT(1) = - t * ( (1.0d0 + t*t)**(-1.5d0 ) ) X X* Store the values for YDOT(k) back into the Work array. X X DO k = 1, NumOfEqua X Work(NINT(Work(FPointerPointer + k)) + Pos) = YDOT(k) X END DO X X RETURN X END X X********************************************************************** X SUBROUTINE J_ij (NumOfEqua, Pos, Work) X X* The purpose of this SUBROUTINE is to compute the derivatives X* appearing in the Jacobian. X* X* Bij = dk(i)/dy(j) for i,j=1,..., NumOfEqua X* X* and to store the result within the Work array. X* X* The user is encouraged to modify this SUBROUTINE for his/her own X* problem of interest. The user is passed the entire Work array which X* contains all intermediate results. The user is encouraged not to X* modify any of the elements within the Work array directly but to use X* the temporary arrays defined within this example SUBROUTINE. The X* user will recognize that these temporary arrays are not essential; X* however, they DO simplify the bookkeeping within the SUBROUTINE. X* X* The parameters in the CALL statement are: X X* NumOfEqua - The number of derivative equations in the system X X* Pos - An INTEGER which increments through the elements within X* the Work array. A given INTEGER value of Pos corresponds to a X* given value of the independent variable. The value of the X* independent variable takes on values at the sinc points, a X* different sinc point for each CALL of SUBROUTINE F. X X* Work - A Work array that contains the necessary storage for all X* intermediate and finals results at the sinc points. X X* The user is encouraged to define temporary variables and arrays: X X* T - Value of the independent variable for the current SUBROUTINE X* CALL. (NOTE: T = Work(PsiPointer+i) ) X X* Y(NumOfEqua) - An array containing the current values of the dependent X* variables of the system. X X* Bij(NumOfEqua,NumOfEqua) - An array to be computed within the SUBROUTINE X* that contains the values of the derivatives of the dependent X* variables with respect to the independent variable. X X IMPLICIT none X X INCLUDE 'workspace.h' X X* Definition of parameters. X INTEGER Pos, NumOfEqua X DOUBLE PRECISION Work(*) X X* Local Variables X INTEGER l, k, m X X* Dimension Y() and Bij() to the number of ODE's X X X* DOUBLE PRECISION Y(NumOfEqua), Bij(NumOfEqua,NumOfEqua), T X* The local arrays Y and Bij must have fixed dimensions X* determined by the number of equations NumOfEqua=1 X DOUBLE PRECISION Y(1), Bij(1,1), T X X* Pull values of the independent and dependent variables out of the X* Work array. X X T = Work(PsiPointer + Pos) X X DO k = 1, NumOfEqua X Y(k) = Work(NINT(Work(YPointerPointer + k)) + Pos) X END DO X X* Program your derivative equations here. e.g., X X Bij( 1, 1 ) = 0.0d0 X X* Store the values for Bij( k ) back into the Work array. X k = 0 X DO l = 1, NumOfEqua X DO m = 1, NumOfEqua X k = k + 1 X Work(NINT(Work(BijPointerPointer + k)) + Pos) = X . Bij(m, l) X END DO X END DO X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION Phi(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X Phi = PhiRR(Z) X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION OneOverPhiPrime(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X OneOverPhiPrime = PhiPriRecRR(Z) X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION Rho(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X Rho = RhoRR(Z) X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION Psi(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X Psi = PsiRR(Z) X X RETURN X END X X********************************************************************** X SUBROUTINE SetXs( EquaNum, Nxs, X ) X IMPLICIT NONE X X* This routine allows the user to set the values X* of the points at which to view the solution. X X* This section defines the argument list. X INTEGER EquaNum, Nxs X DOUBLE PRECISION X(*) X X INTEGER i X X DO i = 1, Nxs X X(i) = -0.1D0+0.2D0 * DFLOAT(i) X END DO X X return X end X X********************************************************************** X DOUBLE PRECISION FUNCTION Solution(EquaNum, T) X IMPLICIT NONE X X* This section defines the argument list. X INTEGER EquaNum X DOUBLE PRECISION T X DOUBLE PRECISION phi X X* This section defines local variables needed in the solution X X* This is the code section. X phi = dlog( t + dsqrt( 1.0d0 + t*t ) ) X X Solution = 1.0d0 / dsqrt( 1.0d0 + t*t ) X X RETURN X END X X********************************************************************** X SUBROUTINE StartAppr( NumOfEqua, N, work ) X IMPLICIT NONE X X* This routine allows the user to set the initial values X* and then puts the initial y values into the work array X X* This section defines the argument list. X integer NumOfEqua, N X DOUBLE PRECISION work(*) X X* Local variables X INTEGER YPointer, OldYPointer, j X INTEGER EquaNum, Pos X X* User set initial values for the dependent variable X DOUBLE PRECISION y( 41 ) X data ( y( j ), j=1,41 )/ 41 * 1.0d0 / X X INCLUDE 'workspace.h' X X do EquaNum = 1, 1 X X YPointer = NINT(Work(YPointerPointer + EquaNum )) X OldYPointer = NINT(Work(OldYPointerPointer + EquaNum )) X X do Pos = 1, 41 X X Work(YPointer + Pos) = y( Pos ) X Work(OldYPointer + Pos) = y( Pos ) X X enddo X X enddo X X RETURN X END X********************************************************************** X SUBROUTINE InitCond(NumOfEqua, Value) X IMPLICIT NONE X X* This section defines the argument list. X INTEGER NumOfEqua X DOUBLE PRECISION Value(*) X X* This is the code section. X X Value(1) = 0.0d0 X X RETURN X END X END_OF_FILE if test 10969 -ne `wc -c <'problem_RR.f'`; then echo shar: \"'problem_RR.f'\" unpacked with wrong size! fi # end of 'problem_RR.f' fi if test -f 'problem_Sec.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'problem_Sec.f'\" else echo shar: Extracting \"'problem_Sec.f'\" \(11956 characters\) sed "s/^X//" >'problem_Sec.f' <<'END_OF_FILE' X********************************************************************** X* File problem_Sec.f X* Example 7.8 X SUBROUTINE ControlVars( SincPts,NumOfEqua,Nxs,MaxIter,H,Itest) X X* The purpose of this SUBROUTINE is to set the controlling X* parameters for the problem. X* X* The parameters in the CALL statement are: X X* SincPts - An INTEGER which controls number of points used in the X* approximation. The solution is computed at y_i( k * H ) with X* k = - SincPts ... SincPts. X X* NumOfEqua - INTEGER - Number of dependent variables in the system X* (i.e., the number of simultaneous IVP's to be solved). X X* Nxs - INTEGER - Number of points at which the solution will be X* approximated. X X* MaxIter - INTEGER - The maximum number of iterations the procedure X* will use in trying to converge. X X* H - DOUBLE PRECISION - This is the step size. In some instances X* picking the optimal H can make a significant difference in the X* accuracy of the result, particularly for small SincPts. However, as X* long H is picked as: X X* H = 1.0d0 /sqrt(C*SincPts) for some C X X* the algorithm will have the appropriate asymptotic accuracy. X* Itest INTEGER: If Itest=0 no exact solution is known and the value X* of double precision function Solution is irrevelant. If itest=1 X* the analytic solution is given by double precision function X* Solution X X IMPLICIT NONE X X DOUBLE PRECISION Pi, C X PARAMETER (Pi = 3.1415926535897932D0 ) X X INTEGER SincPts, NumOfEqua, Nxs, MaxIter,Itest X DOUBLE PRECISION H X X SincPts = 20 X NumOfEqua = 2 X Nxs = 10 X MaxIter = 80 X C=2.0d0 X PRINT * ,'Example 7.8 File: problem_Sec.f' X PRINT * ,'Linear problem' X H = Pi / DSQRT( C * DBLE( SincPts ) ) X* If exact solution known, it should be defined by DOUBLE PRECISION X* FUNCTION Solution and we put: X Itest=1 X* If exact solution is not known, then the result of DOUBLE PRECISION X* FUNCTION is irrevelant and we put X* Itest=0 X return X end X X********************************************************************** X X SUBROUTINE F(NumOfEqua, Pos, Work) X X* The purpose of this SUBROUTINE is to compute the derivatives: X* X* dy(i)/dt = f ( t, y(i) ) for i=1,..., NumOfEqua X* X* and to store the result within the Work array. X* X* The user is encouraged to modify this SUBROUTINE for his/her own X* problem of interest. The user is passed the entire Work array which X* contains all intermediate results. The user is encouraged not to X* modify any of the elements within the Work array directly but to use X* the temporary arrays defined within this example SUBROUTINE. The X* user will recognize that these temporary arrays are not essential; X* however, they DO simplify the bookkeeping within the SUBROUTINE. X* X* The parameters in the CALL statement are: X* X* NumOfEqua - The number of derivative equations in the system X* X* NumOfPoints - An INTEGER which increments through the elements within X* the Work array. A given INTEGER value of NumOfPoints corresponds to a X* given value of the independent variable. The value of the X* independent variable takes on values at the sinc points, a X* different sinc point for each CALL of SUBROUTINE F. X* X* Work - A Work array that contains the necessary storage for all X* intermediate and finals results at the sinc points. X* X* The user is encouraged to define temporary variables and arrays: X* X* T - Value of the independent variable for the current SUBROUTINE X* CALL. (NOTE: T = Work(PsiPointer+i) ) X* X* Y(NumOfEqua) - An array containing the current values of the dependent X* variables of the system. X* X* YDOT(NumOfEqua) - An array to be computed within the SUBROUTINE that X* contains the values of the derivatives of the dependent variables X* with respect to the independent variable. X X IMPLICIT NONE X X INCLUDE 'workspace.h' X X* Argument list X DOUBLE PRECISION Work(*) X INTEGER Pos, NumOfEqua X X X* local Variables X INTEGER k X* DOUBLE PRECISION Y(NumOfEqua), YDOT(NumOfEqua), T X* The local arrays Y and YDOT must have fixed dimensions equal to X* the number of equations NumOfEqua=2 X DOUBLE PRECISION Y(2),YDOT(2),T X X X* Pull values of the independent and dependent variables out of the X* work array. X X T = Work(PsiPointer + Pos) X X DO k=1,NumOfEqua X Y(k) = Work(JIDNNT(Work(YPointerPointer + k)) + Pos) X END DO X X* Program your derivative equations here. e.g., X X YDOT(1) = Y( 2 ) X X YDOT(2) = t * Y( 1 ) X X X* Store the values for YDOT(k) back into the Work array. X X DO k = 1, NumOfEqua X Work(JIDNNT(Work(FPointerPointer + k)) + Pos) = YDOT(k) X END DO X X RETURN X END X X********************************************************************** X SUBROUTINE J_ij (NumOfEqua, Pos, Work) X X* The purpose of this SUBROUTINE is to compute the derivatives X* appearing in the Jacobian. X* X* Bij = dk(i)/dy(j) for i,j=1,..., NumOfEqua X* X* and to store the result within the Work array. X* X* The user is encouraged to modify this SUBROUTINE for his/her own X* problem of interest. The user is passed the entire Work array which X* contains all intermediate results. The user is encouraged not to X* modify any of the elements within the Work array directly but to use X* the temporary arrays defined within this example SUBROUTINE. The X* user will recognize that these temporary arrays are not essential; X* however, they DO simplify the bookkeeping within the SUBROUTINE. X* X* The parameters in the CALL statement are: X X* NumOfEqua - The number of derivative equations in the system X X* Pos - An INTEGER which increments through the elements within X* the Work array. A given INTEGER value of Pos corresponds to a X* given value of the independent variable. The value of the X* independent variable takes on values at the sinc points, a X* different sinc point for each CALL of SUBROUTINE F. X X* Work - A Work array that contains the necessary storage for all X* intermediate and finals results at the sinc points. X X* The user is encouraged to define temporary variables and arrays: X X* T - Value of the independent variable for the current SUBROUTINE X* CALL. (NOTE: T = Work(PsiPointer+i) ) X X* Y(NumOfEqua) - An array containing the current values of the dependent X* variables of the system. X X* Bij(NumOfEqua,NumOfEqua) - An array to be computed within the SUBROUTINE X* that contains the values of the derivatives of the dependent X* variables with respect to the independent variable. X X IMPLICIT none X X INCLUDE 'workspace.h' X X* Definition of parameters. X INTEGER Pos, NumOfEqua X DOUBLE PRECISION Work(*) X X* Local Variables X INTEGER l, k, m X X* Dimension Y() and Bij() to the number of ODE's X X X* DOUBLE PRECISION Y(NumOfEqua), Bij(NumOfEqua,NumOfEqua), T X* The local arrays Y and Bij must have fixed dimensions X* determined by the number of equations NumOfEqua=2 X DOUBLE PRECISION Y(2),Bij(2,2),T X X X* Pull values of the independent and dependent variables out of the X* Work array. X X T = Work(PsiPointer + Pos) X X DO k = 1, NumOfEqua X Y(k) = Work(JIDNNT(Work(YPointerPointer + k)) + Pos) X END DO X X* Program your derivative equations here. e.g., X X Bij( 1, 1 ) = 0.0d0 X Bij( 1, 2 ) = 1.0d0 X X Bij( 2, 1 ) = t X Bij( 2, 2 ) = 0.0d0 X X* Store the values for Bij( k ) back into the Work array. X k = 0 X DO l = 1, NumOfEqua X DO m = 1, NumOfEqua X k = k + 1 X Work(JIDNNT(Work(BijPointerPointer + k)) + Pos) = X . Bij(m, l) X END DO X END DO X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION Phi(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X Phi = PhiSec(Z) X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION OneOverPhiPrime(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X OneOverPhiPrime = PhiPriRecSec(Z) X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION Rho(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X Rho = RhoSec(Z) X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION Psi(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X Psi = PsiSec(Z) X X RETURN X END X X********************************************************************** X SUBROUTINE SetXs( EquaNum, Nxs, X ) X IMPLICIT NONE X X* This routine allows the user to set the values X* of the points at which to view the solution. X X* This section defines the argument list. X INTEGER EquaNum, Nxs X DOUBLE PRECISION X(*) X X INTEGER i X X DO i = 1, Nxs X X(i) = -0.1D0+0.2d0 * DFLOAT(i) X END DO X X return X end X X********************************************************************** X DOUBLE PRECISION FUNCTION Solution(EquaNum, T) X IMPLICIT NONE X X* This section defines the argument list. X INTEGER EquaNum X DOUBLE PRECISION T X X* This section defines local variables needed in the solution X double precision Sol( 20 ) X data Sol(1) / .3292031299d0 / X data Sol(2) / .3037031543d0 / X data Sol(3) / .2788064820d0 / X data Sol(4) / .2547423543d0 / X data Sol(5) / .2316936065 / X data Sol(6) / .2098000617 / X data Sol(7) / .1891624004 / X data Sol(8) / .1698463174 / X data Sol(9) / .1518868036 / X data Sol(10) / .1352924163 / X data Sol(11) / .1200494274 / X data Sol(12) / .1061257623 / X data Sol(13) / .09347466577 / X data Sol(14) / .08203804981 / X data Sol(15) / .07174949701 / X data Sol(16) / .06253690797 / X data Sol(17) / .05432479273 / X data Sol(18) / .04703621687 / X data Sol(19) / .04059442003 / X data Sol(20) / .03492413042 / X X X* This is the code section. X Solution=0.0d0 X IF(EquaNum .EQ.1) THEN X Solution = Sol( NINT( 10.0d0 * T ) ) X END IF X RETURN X END X X********************************************************************** X SUBROUTINE StartAppr( NumOfEqua, N, work ) X IMPLICIT NONE X X* This routine allows the user to set the initial values X* and then puts the initial y values into the work array X X* This section defines the argument list. X INTEGER NumOfEqua, N X DOUBLE PRECISION work(*) X X* Local variables X INTEGER YPointer, OldYPointer, j X INTEGER EquaNum, Pos X X* User set initial values for the dependent variable X DOUBLE PRECISION y( 2, 41 ) X data ( y( 1, j ), j=1,41 )/ 41 * 0.355028053887817D0 / X data ( y( 2, j ), j=1,41 )/ 41 * -0.258819403792807D0 / X X INCLUDE 'workspace.h' X X do EquaNum = 1, 2 X X YPointer = JIDNNT(Work(YPointerPointer + EquaNum )) X OldYPointer = JIDNNT(Work(OldYPointerPointer + EquaNum )) X X do Pos = 1, 41 X X Work(YPointer + Pos) = y( EquaNum, Pos ) X Work(OldYPointer + Pos) = y( EquaNum, Pos ) X X enddo X X enddo X X RETURN X END X********************************************************************** X SUBROUTINE InitCond(NumOfEqua, Value) X IMPLICIT NONE X X* This section defines the argument list. X INTEGER NumOfEqua X DOUBLE PRECISION Value(NumOfEqua + 1) X X* This is the code section. X X Value(1) = 0.355028053887817D0 X Value(2) = -0.258819403792807D0 X X RETURN X END X END_OF_FILE if test 11956 -ne `wc -c <'problem_Sec.f'`; then echo shar: \"'problem_Sec.f'\" unpacked with wrong size! fi # end of 'problem_Sec.f' fi if test -f 'problem_g.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'problem_g.f'\" else echo shar: Extracting \"'problem_g.f'\" \(11341 characters\) sed "s/^X//" >'problem_g.f' <<'END_OF_FILE' X********************************************************************** X* File problem_g.f X* Example 7.10 X SUBROUTINE ControlVars( SincPts,NumOfEqua,Nxs,MaxIter,H,Itest) X X* The purpose of this SUBROUTINE is to set the controlling X* parameters for the problem. X* X* The parameters in the CALL statement are: X X* SincPts - An INTEGER which controls number of points used in the X* approximation. The solution is computed at y_i( k * H ) with X* k = - SincPts ... SincPts. X X* NumOfEqua - INTEGER - Number of dependent variables in the system X* (i.e., the number of simultaneous IVP's to be solved). X X* Nxs - INTEGER - Number of points at which the solution will be X* approximated. X X* MaxIter - INTEGER - The maximum number of iterations the procedure X* will use in trying to converge. X X* H - DOUBLE PRECISION - This is the step size. In some instances X* picking the optimal H can make a significant difference in the X* accuracy of the result, particularly for small SincPts. However, as X* long H is picked as: X X* H = 1.0d0 /sqrt(C*SincPts) for some C X X* the algorithm will have the appropriate asymptotic accuracy. X* Itest INTEGER: If Itest=0 no exact solution is known and the value X* of double precision function Solution is irrevelant. If itest=1 X* the analytic solution is given by double precision function X* Solution X X IMPLICIT NONE X X DOUBLE PRECISION Pi, C X PARAMETER (Pi = 3.1415926535897932D0 ) X X INTEGER SincPts, NumOfEqua, Nxs, MaxIter,Itest X DOUBLE PRECISION H X X SincPts = 20 X NumOfEqua = 2 X Nxs = 10 X MaxIter = 80 X C=2.0d0 X PRINT * ,'Example 7.10 File: problem_g.f' X PRINT * ,'Linear problem' X H = Pi / DSQRT( C * DBLE( SincPts ) ) X* If exact solution known, it should be defined by DOUBLE PRECISION X* FUNCTION Solution and we put: X Itest=1 X* If exact solution is not known, then the result of DOUBLE PRECISION X* FUNCTION is irrevelant and we put X* Itest=0 X return X end X X********************************************************************** X X SUBROUTINE F(NumOfEqua, Pos, Work) X X* The purpose of this SUBROUTINE is to compute the derivatives: X* X* dy(i)/dt = f ( t, y(i) ) for i=1,..., NumOfEqua X* X* and to store the result within the Work array. X* X* The user is encouraged to modify this SUBROUTINE for his/her own X* problem of interest. The user is passed the entire Work array which X* contains all intermediate results. The user is encouraged not to X* modify any of the elements within the Work array directly but to use X* the temporary arrays defined within this example SUBROUTINE. The X* user will recognize that these temporary arrays are not essential; X* however, they DO simplify the bookkeeping within the SUBROUTINE. X* X* The parameters in the CALL statement are: X* X* NumOfEqua - The number of derivative equations in the system X* X* NumOfPoints - An INTEGER which increments through the elements within X* the Work array. A given INTEGER value of NumOfPoints corresponds to a X* given value of the independent variable. The value of the X* independent variable takes on values at the sinc points, a X* different sinc point for each CALL of SUBROUTINE F. X* X* Work - A Work array that contains the necessary storage for all X* intermediate and finals results at the sinc points. X* X* The user is encouraged to define temporary variables and arrays: X* X* T - Value of the independent variable for the current SUBROUTINE X* CALL. (NOTE: T = Work(PsiPointer+i) ) X* X* Y(NumOfEqua) - An array containing the current values of the dependent X* variables of the system. X* X* YDOT(NumOfEqua) - An array to be computed within the SUBROUTINE that X* contains the values of the derivatives of the dependent variables X* with respect to the independent variable. X X IMPLICIT NONE X X INCLUDE 'workspace.h' X X* Argument list X DOUBLE PRECISION Work(*) X INTEGER Pos, NumOfEqua X X X* local Variables X INTEGER k X* DOUBLE PRECISION Y(NumOfEqua), YDOT(NumOfEqua), T X* The local arrays Y and YDOT must have fixed dimensions equal to X* the number of equations NumOfEqua=2 X DOUBLE PRECISION Y(2),YDOT(2),T X X X* Pull values of the independent and dependent variables out of the X* work array. X X T = Work(PsiPointer + Pos) X X DO k=1,NumOfEqua X Y(k) = Work(NINT(Work(YPointerPointer + k)) + Pos) X END DO X X* Program your derivative equations here. e.g., X X YDOT(1) = 998.0d0 * y(1) + 1998.0d0 * y(2) X X YDOT(2) = -999.0d0 * y(1) - 1999.0d0 * y(2) X X X* Store the values for YDOT(k) back into the Work array. X X DO k = 1, NumOfEqua X Work(NINT(Work(FPointerPointer + k)) + Pos) = YDOT(k) X END DO X X RETURN X END X X********************************************************************** X SUBROUTINE J_ij (NumOfEqua, Pos, Work) X X* The purpose of this SUBROUTINE is to compute the derivatives X* appearing in the Jacobian. X* X* Bij = dk(i)/dy(j) for i,j=1,..., NumOfEqua X* X* and to store the result within the Work array. X* X* The user is encouraged to modify this SUBROUTINE for his/her own X* problem of interest. The user is passed the entire Work array which X* contains all intermediate results. The user is encouraged not to X* modify any of the elements within the Work array directly but to use X* the temporary arrays defined within this example SUBROUTINE. The X* user will recognize that these temporary arrays are not essential; X* however, they DO simplify the bookkeeping within the SUBROUTINE. X* X* The parameters in the CALL statement are: X X* NumOfEqua - The number of derivative equations in the system X X* Pos - An INTEGER which increments through the elements within X* the Work array. A given INTEGER value of Pos corresponds to a X* given value of the independent variable. The value of the X* independent variable takes on values at the sinc points, a X* different sinc point for each CALL of SUBROUTINE F. X X* Work - A Work array that contains the necessary storage for all X* intermediate and finals results at the sinc points. X X* The user is encouraged to define temporary variables and arrays: X X* T - Value of the independent variable for the current SUBROUTINE X* CALL. (NOTE: T = Work(PsiPointer+i) ) X X* Y(NumOfEqua) - An array containing the current values of the dependent X* variables of the system. X X* Bij(NumOfEqua,NumOfEqua) - An array to be computed within the SUBROUTINE X* that contains the values of the derivatives of the dependent X* variables with respect to the independent variable. X X IMPLICIT none X X INCLUDE 'workspace.h' X X* Definition of parameters. X INTEGER Pos, NumOfEqua X DOUBLE PRECISION Work(*) X X* Local Variables X INTEGER l, k, m X X* Dimension Y() and Bij() to the number of ODE's X X X* DOUBLE PRECISION Y(NumOfEqua), Bij(NumOfEqua,NumOfEqua), T X* The local arrays Y and Bij must have fixed dimensions X* determined by the number of equations NumOfEqua=2 X DOUBLE PRECISION Y(2),Bij(2,2),T X X X* Pull values of the independent and dependent variables out of the X* Work array. X X T = Work(PsiPointer + Pos) X X DO k = 1, NumOfEqua X Y(k) = Work(NINT(Work(YPointerPointer + k)) + Pos) X END DO X X* Program your derivative equations here. e.g., X X Bij( 1, 1 ) = 998.0d0 X Bij( 1, 2 ) = 1998.0d0 X X Bij( 2, 1 ) = -999.0d0 X Bij( 2, 2 ) = -1999.0d0 X X* Store the values for Bij( k ) back into the Work array. X k = 0 X DO l = 1, NumOfEqua X DO m = 1, NumOfEqua X k = k + 1 X Work(NINT(Work(BijPointerPointer + k)) + Pos) = X . Bij(m, l) X END DO X END DO X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION Phi(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X Phi = PhiSec(Z) X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION OneOverPhiPrime(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X OneOverPhiPrime = PhiPriRecSec(Z) X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION Rho(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X Rho = RhoSec(Z) X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION Psi(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X Psi = PsiSec(Z) X X RETURN X END X X********************************************************************** X SUBROUTINE SetXs( EquaNum, Nxs, X ) X IMPLICIT NONE X X* This routine allows the user to set the values X* of the points at which to view the solution. X X* This section defines the argument list. X INTEGER EquaNum, Nxs X DOUBLE PRECISION X(*) X X INTEGER i X X DO i = 1, Nxs X X(i) = -0.1D0+0.2d0 * DFLOAT(i) X END DO X X return X end X X********************************************************************** X DOUBLE PRECISION FUNCTION Solution(EquaNum, T) X IMPLICIT NONE X X* This section defines the argument list. X INTEGER EquaNum X DOUBLE PRECISION T X X* This section defines local variables needed in the solution X X* This is the code section. X if ( EquaNum .eq. 1 ) then X Solution = 2.0d0 * dexp( -t ) - dexp( - 1000.0d0 * t ) X else if ( EquaNum .eq. 2 ) then X Solution = -dexp( -t ) + dexp( - 1000.0d0 * t ) X endif X X RETURN X END X X********************************************************************** X SUBROUTINE StartAppr( NumOfEqua, N, work ) X IMPLICIT NONE X X* This routine allows the user to set the initial values X* and then puts the initial y values into the work array X X* This section defines the argument list. X INTEGER NumOfEqua, N X DOUBLE PRECISION work(*) X X* Local variables X INTEGER YPointer, OldYPointer, j X INTEGER EquaNum, Pos X X* User set initial values for the dependent variable X DOUBLE PRECISION y( 2, 41 ) X data ( y( 1, j ), j=1,41 )/ 41 * 0.355028053887817D0 / X data ( y( 2, j ), j=1,41 )/ 41 * -0.258819403792807D0 / X X INCLUDE 'workspace.h' X X do EquaNum = 1, 2 X X YPointer = NINT(Work(YPointerPointer + EquaNum )) X OldYPointer = NINT(Work(OldYPointerPointer + EquaNum )) X X do Pos = 1, 41 X X Work(YPointer + Pos) = y( EquaNum, Pos ) X Work(OldYPointer + Pos) = y( EquaNum, Pos ) X X enddo X X enddo X X RETURN X END X********************************************************************** X SUBROUTINE InitCond(NumOfEqua, Value) X IMPLICIT NONE X X* This section defines the argument list. X INTEGER NumOfEqua X DOUBLE PRECISION Value(NumOfEqua + 1) X X* This is the code section. X X Value(1) = 1.0d0 X Value(2) = 0.0d0 X X RETURN X END X END_OF_FILE if test 11341 -ne `wc -c <'problem_g.f'`; then echo shar: \"'problem_g.f'\" unpacked with wrong size! fi # end of 'problem_g.f' fi if test -f 'problem_ig.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'problem_ig.f'\" else echo shar: Extracting \"'problem_ig.f'\" \(11476 characters\) sed "s/^X//" >'problem_ig.f' <<'END_OF_FILE' X********************************************************************** X* File problem_ig.f X* Example 7.9 X X SUBROUTINE ControlVars( SincPts,NumOfEqua,Nxs,MaxIter,H,Itest) X X* The purpose of this SUBROUTINE is to set the controlling X* parameters for the problem. X* X* The parameters in the CALL statement are: X X* SincPts - An INTEGER which controls number of points used in the X* approximation. The solution is computed at y_i( k * H ) with X* k = - SincPts ... SincPts. X X* NumOfEqua - INTEGER - Number of dependent variables in the system X* (i.e., the number of simultaneous IVP's to be solved). X X* Nxs - INTEGER - Number of points at which the solution will be X* approximated. X X* MaxIter - INTEGER - The maximum number of iterations the procedure X* will use in trying to converge. X X* H - DOUBLE PRECISION - This is the step size. In some instances X* picking the optimal H can make a significant difference in the X* accuracy of the result, particularly for small SincPts. However, as X* long H is picked as: X X* H = 1.0d0 /sqrt(C*SincPts) for some C X X* the algorithm will have the appropriate asymptotic accuracy. X* Itest INTEGER: If Itest=0 no exact solution is known and the value X* of double precision function Solution is irrevelant. If itest=1 X* the analytic solution is given by double precision function X* Solution X X IMPLICIT NONE X X DOUBLE PRECISION Pi, C X PARAMETER (Pi = 3.1415926535897932D0 ) X X INTEGER SincPts, NumOfEqua, Nxs, MaxIter,Itest X DOUBLE PRECISION H X X SincPts = 20 X NumOfEqua = 2 X Nxs = 19 X MaxIter = 80 X C=2.0d0 X PRINT * ,'Example 7.9 File: problem_ig.f' X PRINT * ,'Linear problem' X H = Pi / DSQRT( C * DBLE( SincPts ) ) X* If exact solution known, it should be defined by DOUBLE PRECISION X* FUNCTION Solution and we put: X Itest=1 X* If exact solution is not known, then the result of DOUBLE PRECISION X* FUNCTION is irrevelant and we put X* Itest=0 X return X end X X********************************************************************** X X SUBROUTINE F(NumOfEqua, Pos, Work) X X* The purpose of this SUBROUTINE is to compute the derivatives: X* X* dy(i)/dt = f ( t, y(i) ) for i=1,..., NumOfEqua X* X* and to store the result within the Work array. X* X* The user is encouraged to modify this SUBROUTINE for his/her own X* problem of interest. The user is passed the entire Work array which X* contains all intermediate results. The user is encouraged not to X* modify any of the elements within the Work array directly but to use X* the temporary arrays defined within this example SUBROUTINE. The X* user will recognize that these temporary arrays are not essential; X* however, they DO simplify the bookkeeping within the SUBROUTINE. X* X* The parameters in the CALL statement are: X* X* NumOfEqua - The number of derivative equations in the system X* X* NumOfPoints - An INTEGER which increments through the elements within X* the Work array. A given INTEGER value of NumOfPoints corresponds to a X* given value of the independent variable. The value of the X* independent variable takes on values at the sinc points, a X* different sinc point for each CALL of SUBROUTINE F. X* X* Work - A Work array that contains the necessary storage for all X* intermediate and finals results at the sinc points. X* X* The user is encouraged to define temporary variables and arrays: X* X* T - Value of the independent variable for the current SUBROUTINE X* CALL. (NOTE: T = Work(PsiPointer+i) ) X* X* Y(NumOfEqua) - An array containing the current values of the dependent X* variables of the system. X* X* YDOT(NumOfEqua) - An array to be computed within the SUBROUTINE that X* contains the values of the derivatives of the dependent variables X* with respect to the independent variable. X X IMPLICIT NONE X X INCLUDE 'workspace.h' X X* Argument list X DOUBLE PRECISION Work(*) X INTEGER Pos, NumOfEqua X X X* local Variables X INTEGER k X* DOUBLE PRECISION Y(NumOfEqua), YDOT(NumOfEqua), T X* The local arrays Y and YDOT must have fixed dimensions equal to X* the number of equations NumOfEqua=2 X DOUBLE PRECISION Y(2),YDOT(2),T X X X* Pull values of the independent and dependent variables out of the X* work array. X X T = Work(PsiPointer + Pos) X X DO k=1,NumOfEqua X Y(k) = Work(NINT(Work(YPointerPointer + k)) + Pos) X END DO X X* Program your derivative equations here. e.g., X X YDOT(1) = Y( 2 ) X X YDOT(2) = -( 1.0d0 + 0.5d0/t ) * y(2) X X X* Store the values for YDOT(k) back into the Work array. X X DO k = 1, NumOfEqua X Work(NINT(Work(FPointerPointer + k)) + Pos) = YDOT(k) X END DO X X RETURN X END X X********************************************************************** X SUBROUTINE J_ij (NumOfEqua, Pos, Work) X X* The purpose of this SUBROUTINE is to compute the derivatives X* appearing in the Jacobian. X* X* Bij = dk(i)/dy(j) for i,j=1,..., NumOfEqua X* X* and to store the result within the Work array. X* X* The user is encouraged to modify this SUBROUTINE for his/her own X* problem of interest. The user is passed the entire Work array which X* contains all intermediate results. The user is encouraged not to X* modify any of the elements within the Work array directly but to use X* the temporary arrays defined within this example SUBROUTINE. The X* user will recognize that these temporary arrays are not essential; X* however, they DO simplify the bookkeeping within the SUBROUTINE. X* X* The parameters in the CALL statement are: X X* NumOfEqua - The number of derivative equations in the system X X* Pos - An INTEGER which increments through the elements within X* the Work array. A given INTEGER value of Pos corresponds to a X* given value of the independent variable. The value of the X* independent variable takes on values at the sinc points, a X* different sinc point for each CALL of SUBROUTINE F. X X* Work - A Work array that contains the necessary storage for all X* intermediate and finals results at the sinc points. X X* The user is encouraged to define temporary variables and arrays: X X* T - Value of the independent variable for the current SUBROUTINE X* CALL. (NOTE: T = Work(PsiPointer+i) ) X X* Y(NumOfEqua) - An array containing the current values of the dependent X* variables of the system. X X* Bij(NumOfEqua,NumOfEqua) - An array to be computed within the SUBROUTINE X* that contains the values of the derivatives of the dependent X* variables with respect to the independent variable. X X IMPLICIT none X X INCLUDE 'workspace.h' X X* Definition of parameters. X INTEGER Pos, NumOfEqua X DOUBLE PRECISION Work(*) X X* Local Variables X INTEGER l, k, m X X* Dimension Y() and Bij() to the number of ODE's X X* DOUBLE PRECISION Y(NumOfEqua), Bij(NumOfEqua,NumOfEqua), T X* The local arrays Y and Bij must have fixed dimensions X* determined by the number of equations NumOfEqua=2 X DOUBLE PRECISION Y(2),Bij(2,2),T X X X* Pull values of the independent and dependent variables out of the X* Work array. X X T = Work(PsiPointer + Pos) X X DO k = 1, NumOfEqua X Y(k) = Work(NINT(Work(YPointerPointer + k)) + Pos) X END DO X X* Program your derivative equations here. e.g., X X Bij( 1, 1 ) = 0.0d0 X Bij( 1, 2 ) = 1.0d0 X X Bij( 2, 1 ) = 0.0d0 X Bij( 2, 2 ) = -( 1.0d0 + 0.5d0/t ) X X* Store the values for Bij( k ) back into the Work array. X k = 0 X DO l = 1, NumOfEqua X DO m = 1, NumOfEqua X k = k + 1 X Work(NINT(Work(BijPointerPointer + k)) + Pos) = X . Bij(m, l) X END DO X END DO X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION Phi(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X Phi = PhiAB(Z, 1.0d0, 2.0d0) X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION OneOverPhiPrime(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X OneOverPhiPrime = PhiPriRecAB(Z, 1.0d0, 2.0d0) X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION Rho(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X Rho = RhoAB(Z, 1.0d0, 2.0d0) X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION Psi(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X Psi = PsiAB(Z, 1.0d0, 2.0d0) X X RETURN X END X X********************************************************************** X SUBROUTINE SetXs( EquaNum, Nxs, X ) X IMPLICIT NONE X X* This routine allows the user to set the values X* of the points at which to view the solution. X X* This section defines the argument list. X INTEGER EquaNum, Nxs X DOUBLE PRECISION X(*) X X INTEGER i X X DO i = 1, Nxs X X(i) = 1.0d0 + 0.05D0 * DFLOAT(i) X END DO X X return X end X X********************************************************************** X DOUBLE PRECISION FUNCTION Solution(EquaNum, T) X IMPLICIT NONE X X* This section defines the argument list. X INTEGER EquaNum X DOUBLE PRECISION T X X* This section defines local variables needed in the solution X X X DOUBLE PRECISION dgami X EXTERNAL dgami X X* This is the code section. X Solution=0. X* if ( EquaNum .eq. 1 ) then X* a = 0.5d0 X* Solution = dgami( a, t ) - 0.134252D+01 X* else X* Solution = dexp( -t ) / dsqrt( t ) X* endif X if(Equanum . eq. 2) then X Solution= dexp( -t ) / dsqrt( t ) X end if X RETURN X END X X********************************************************************** X SUBROUTINE StartAppr( NumOfEqua, N, work ) X IMPLICIT NONE X X* This routine allows the user to set the initial values X* and then puts the initial y values into the work array X X* This section defines the argument list. X INTEGER NumOfEqua, N X DOUBLE PRECISION work(*) X X* Local variables X INTEGER YPointer, OldYPointer, j X INTEGER EquaNum, Pos X X* User set initial values for the dependent variable X DOUBLE PRECISION y( 2, 41 ) X data ( y( 1, j ), j=1,41 )/ 41 * 1.0d0 / X data ( y( 2, j ), j=1,41 )/ 41 * 0.0d0 / X X INCLUDE 'workspace.h' X X do EquaNum = 1, 2 X X YPointer = NINT(Work(YPointerPointer + EquaNum )) X OldYPointer = NINT(Work(OldYPointerPointer + EquaNum )) X X do Pos = 1, 41 X X Work(YPointer + Pos) = y( EquaNum, Pos ) X Work(OldYPointer + Pos) = y( EquaNum, Pos ) X X enddo X X enddo X X RETURN X END X********************************************************************** X SUBROUTINE InitCond(NumOfEqua, Value) X IMPLICIT NONE X X* This section defines the argument list. X INTEGER NumOfEqua X DOUBLE PRECISION Value(NumOfEqua + 1) X X* This is the code section. X X Value(1) = 0.15113729D0 X Value(2) = 0.367879441D0 X X RETURN X END X END_OF_FILE if test 11476 -ne `wc -c <'problem_ig.f'`; then echo shar: \"'problem_ig.f'\" unpacked with wrong size! fi # end of 'problem_ig.f' fi if test -f 'problem_l.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'problem_l.f'\" else echo shar: Extracting \"'problem_l.f'\" \(11373 characters\) sed "s/^X//" >'problem_l.f' <<'END_OF_FILE' X********************************************************************** X* File problem_l.f X* Example 7.12 X SUBROUTINE ControlVars( SincPts,NumOfEqua,Nxs,MaxIter,H,Itest) X X* The purpose of this SUBROUTINE is to set the controlling X* parameters for the problem. X* X* The parameters in the CALL statement are: X X* SincPts - An INTEGER which controls number of points used in the X* approximation. The solution is computed at y_i( k * H ) with X* k = - SincPts ... SincPts. X X* NumOfEqua - INTEGER - Number of dependent variables in the system X* (i.e., the number of simultaneous IVP's to be solved). X X* Nxs - INTEGER - Number of points at which the solution will be X* approximated. X X* MaxIter - INTEGER - The maximum number of iterations the procedure X* will use in trying to converge. X X* H - DOUBLE PRECISION - This is the step size. In some instances X* picking the optimal H can make a significant difference in the X* accuracy of the result, particularly for small SincPts. However, as X* long H is picked as: X X* H = 1.0d0 /sqrt(C*SincPts) for some C X X* the algorithm will have the appropriate asymptotic accuracy. X* Itest INTEGER: If Itest=0 no exact solution is known and the value X* of double precision function Solution is irrevelant. If itest=1 X* the analytic solution is given by double precision function X* Solution X X IMPLICIT NONE X X DOUBLE PRECISION Pi, C X PARAMETER (Pi = 3.1415926535897932D0 ) X X INTEGER SincPts, NumOfEqua, Nxs, MaxIter,Itest X DOUBLE PRECISION H X X SincPts = 20 X NumOfEqua = 2 X Nxs = 10 X MaxIter = 80 X C=2.0d0 X PRINT * ,'Example 7.12 File: problem_l.f' X PRINT * ,'Linear problem' X H = Pi / DSQRT( C * DBLE( SincPts ) ) X* If exact solution known, it should be defined by DOUBLE PRECISION X* FUNCTION Solution and we put: X Itest=1 X* If exact solution is not known, then the result of DOUBLE PRECISION X* FUNCTION is irrevelant and we put X* Itest=0 X return X end X X********************************************************************** X X SUBROUTINE F(NumOfEqua, Pos, Work) X X* The purpose of this SUBROUTINE is to compute the derivatives: X* X* dy(i)/dt = f ( t, y(i) ) for i=1,..., NumOfEqua X* X* and to store the result within the Work array. X* X* The user is encouraged to modify this SUBROUTINE for his/her own X* problem of interest. The user is passed the entire Work array which X* contains all intermediate results. The user is encouraged not to X* modify any of the elements within the Work array directly but to use X* the temporary arrays defined within this example SUBROUTINE. The X* user will recognize that these temporary arrays are not essential; X* however, they DO simplify the bookkeeping within the SUBROUTINE. X* X* The parameters in the CALL statement are: X* X* NumOfEqua - The number of derivative equations in the system X* X* NumOfPoints - An INTEGER which increments through the elements within X* the Work array. A given INTEGER value of NumOfPoints corresponds to a X* given value of the independent variable. The value of the X* independent variable takes on values at the sinc points, a X* different sinc point for each CALL of SUBROUTINE F. X* X* Work - A Work array that contains the necessary storage for all X* intermediate and finals results at the sinc points. X* X* The user is encouraged to define temporary variables and arrays: X* X* T - Value of the independent variable for the current SUBROUTINE X* CALL. (NOTE: T = Work(PsiPointer+i) ) X* X* Y(NumOfEqua) - An array containing the current values of the dependent X* variables of the system. X* X* YDOT(NumOfEqua) - An array to be computed within the SUBROUTINE that X* contains the values of the derivatives of the dependent variables X* with respect to the independent variable. X X IMPLICIT NONE X X INCLUDE 'workspace.h' X X* Argument list X DOUBLE PRECISION Work(*) X INTEGER Pos, NumOfEqua X X X* local Variables X INTEGER k X* DOUBLE PRECISION Y(NumOfEqua), YDOT(NumOfEqua), T X* The local arrays Y and YDOT must have fixed dimensions equal to X* the number of equations NumOfEqua=2 X DOUBLE PRECISION Y(2),YDOT(2),T X X X* Pull values of the independent and dependent variables out of the X* work array. X X T = Work(PsiPointer + Pos) X X DO k=1,NumOfEqua X Y(k) = Work(NINT(Work(YPointerPointer + k)) + Pos) X END DO X X* Program your derivative equations here. e.g., X X YDOT(1) = -2.0d0 * y(1) + y(2) + 2.0d0 * dsin(t) X X YDOT(2) = 998.0d0 * y(1) - 999.0d0*y(2) + X . 999.0d0*(dcos(t)-dsin(t)) X X X* Store the values for YDOT(k) back into the Work array. X X DO k = 1, NumOfEqua X Work(NINT(Work(FPointerPointer + k)) + Pos) = YDOT(k) X END DO X X RETURN X END X X********************************************************************** X SUBROUTINE J_ij (NumOfEqua, Pos, Work) X X* The purpose of this SUBROUTINE is to compute the derivatives X* appearing in the Jacobian. X* X* Bij = dk(i)/dy(j) for i,j=1,..., NumOfEqua X* X* and to store the result within the Work array. X* X* The user is encouraged to modify this SUBROUTINE for his/her own X* problem of interest. The user is passed the entire Work array which X* contains all intermediate results. The user is encouraged not to X* modify any of the elements within the Work array directly but to use X* the temporary arrays defined within this example SUBROUTINE. The X* user will recognize that these temporary arrays are not essential; X* however, they DO simplify the bookkeeping within the SUBROUTINE. X* X* The parameters in the CALL statement are: X X* NumOfEqua - The number of derivative equations in the system X X* Pos - An INTEGER which increments through the elements within X* the Work array. A given INTEGER value of Pos corresponds to a X* given value of the independent variable. The value of the X* independent variable takes on values at the sinc points, a X* different sinc point for each CALL of SUBROUTINE F. X X* Work - A Work array that contains the necessary storage for all X* intermediate and finals results at the sinc points. X X* The user is encouraged to define temporary variables and arrays: X X* T - Value of the independent variable for the current SUBROUTINE X* CALL. (NOTE: T = Work(PsiPointer+i) ) X X* Y(NumOfEqua) - An array containing the current values of the dependent X* variables of the system. X X* Bij(NumOfEqua,NumOfEqua) - An array to be computed within the SUBROUTINE X* that contains the values of the derivatives of the dependent X* variables with respect to the independent variable. X X IMPLICIT none X X INCLUDE 'workspace.h' X X* Definition of parameters. X INTEGER Pos, NumOfEqua X DOUBLE PRECISION Work(*) X X* Local Variables X INTEGER l, k, m X X* Dimension Y() and Bij() to the number of ODE's X X X* DOUBLE PRECISION Y(NumOfEqua), Bij(NumOfEqua,NumOfEqua), T X* The local arrays Y and Bij must have fixed dimensions X* determined by the number of equations NumOfEqua=2 X DOUBLE PRECISION Y(2),Bij(2,2),T X X X* Pull values of the independent and dependent variables out of the X* Work array. X X T = Work(PsiPointer + Pos) X X DO k = 1, NumOfEqua X Y(k) = Work(NINT(Work(YPointerPointer + k)) + Pos) X END DO X X* Program your derivative equations here. e.g., X X Bij( 1, 1 ) = -2.0d0 X Bij( 1, 2 ) = 1.0d0 X X Bij( 2, 1 ) = 998.0d0 X Bij( 2, 2 ) = -999.0d0 X X* Store the values for Bij( k ) back into the Work array. X k = 0 X DO l = 1, NumOfEqua X DO m = 1, NumOfEqua X k = k + 1 X Work(NINT(Work(BijPointerPointer + k)) + Pos) = X . Bij(m, l) X END DO X END DO X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION Phi(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X Phi = PhiAB(Z, 0.0d0, 2.0d0) X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION OneOverPhiPrime(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X OneOverPhiPrime = PhiPriRecAB(Z, 0.0d0, 2.0d0) X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION Rho(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X Rho = RhoAB(Z, 0.0d0, 2.0d0) X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION Psi(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X Psi = PsiAB(Z, 0.0d0, 2.0d0) X X RETURN X END X X********************************************************************** X SUBROUTINE SetXs( EquaNum, Nxs, X ) X IMPLICIT NONE X X* This routine allows the user to set the values X* of the points at which to view the solution. X X* This section defines the argument list. X INTEGER EquaNum, Nxs X DOUBLE PRECISION X(*) X X INTEGER i X X DO i = 1, Nxs X X(i) = -0.1D0+0.2D0 * DFLOAT(i) X END DO X X return X end X X********************************************************************** X DOUBLE PRECISION FUNCTION Solution(EquaNum, T) X IMPLICIT NONE X X* This section defines the argument list. X INTEGER EquaNum X DOUBLE PRECISION T X X* This section defines local variables needed in the solution X X* This is the code section. X if ( EquaNum .eq. 1 ) then X Solution = dexp(-t) + dexp(-1000.0d0*t) + dsin(t) X else X Solution = dexp(-t) -998.0d0* dexp(-1000.0d0*t) + dcos(t) X endif X X RETURN X END X X********************************************************************** X SUBROUTINE StartAppr( NumOfEqua, N, work ) X IMPLICIT NONE X X* This routine allows the user to set the initial values X* and then puts the initial y values into the work array X X* This section defines the argument list. X INTEGER NumOfEqua, N X DOUBLE PRECISION work(*) X X* Local variables X INTEGER YPointer, OldYPointer, j X INTEGER EquaNum, Pos X X* User set initial values for the dependent variable X DOUBLE PRECISION y( 2, 41 ) X data ( y( 1, j ), j=1,41 )/ 41 * 1.0d0 / X data ( y( 2, j ), j=1,41 )/ 41 * 0.0d0 / X X INCLUDE 'workspace.h' X X do EquaNum = 1, 2 X X YPointer = NINT(Work(YPointerPointer + EquaNum )) X OldYPointer = NINT(Work(OldYPointerPointer + EquaNum )) X X do Pos = 1, 41 X X Work(YPointer + Pos) = y( EquaNum, Pos ) X Work(OldYPointer + Pos) = y( EquaNum, Pos ) X X enddo X X enddo X X RETURN X END X********************************************************************** X SUBROUTINE InitCond(NumOfEqua, Value) X IMPLICIT NONE X X* This section defines the argument list. X INTEGER NumOfEqua X DOUBLE PRECISION Value(NumOfEqua + 1) X X* This is the code section. X X Value(1) = 2.0D0 X Value(2) = -996.0D0 X X RETURN X END X END_OF_FILE if test 11373 -ne `wc -c <'problem_l.f'`; then echo shar: \"'problem_l.f'\" unpacked with wrong size! fi # end of 'problem_l.f' fi if test -f 'problem_sg1.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'problem_sg1.f'\" else echo shar: Extracting \"'problem_sg1.f'\" \(11209 characters\) sed "s/^X//" >'problem_sg1.f' <<'END_OF_FILE' X********************************************************************** X* File problem_sg1.f X* Example 7.11 X SUBROUTINE ControlVars( SincPts,NumOfEqua,Nxs,MaxIter,H,Itest) X X* The purpose of this SUBROUTINE is to set the controlling X* parameters for the problem. X* X* The parameters in the CALL statement are: X X* SincPts - An INTEGER which controls number of points used in the X* approximation. The solution is computed at y_i( k * H ) with X* k = - SincPts ... SincPts. X X* NumOfEqua - INTEGER - Number of dependent variables in the system X* (i.e., the number of simultaneous IVP's to be solved). X X* Nxs - INTEGER - Number of points at which the solution will be X* approximated. X X* MaxIter - INTEGER - The maximum number of iterations the procedure X* will use in trying to converge. X X* H - DOUBLE PRECISION - This is the step size. In some instances X* picking the optimal H can make a significant difference in the X* accuracy of the result, particularly for small SincPts. However, as X* long H is picked as: X X* H = 1.0d0 /sqrt(C*SincPts) for some C X X* the algorithm will have the appropriate asymptotic accuracy. X* Itest INTEGER: If Itest=0 no exact solution is known and the value X* of double precision function Solution is irrevelant. If itest=1 X* the analytic solution is given by double precision function X* Solution X X IMPLICIT NONE X X DOUBLE PRECISION Pi, C X PARAMETER (Pi = 3.1415926535897932D0 ) X X INTEGER SincPts, NumOfEqua, Nxs, MaxIter,Itest X DOUBLE PRECISION H X X SincPts = 20 X NumOfEqua = 2 X Nxs = 10 X MaxIter = 80 X C=2.0d0 X PRINT * ,'Example 7.11 File: problem_sg1.f' X H = Pi / DSQRT( C * DBLE( SincPts ) ) X* If exact solution known, it should be defined by DOUBLE PRECISION X* FUNCTION Solution and we put: X Itest=1 X* If exact solution is not known, then the result of DOUBLE PRECISION X* FUNCTION is irrevelant and we put X* Itest=0 X return X end X X********************************************************************** X X SUBROUTINE F(NumOfEqua, Pos, Work) X X* The purpose of this SUBROUTINE is to compute the derivatives: X* X* dy(i)/dt = f ( t, y(i) ) for i=1,..., NumOfEqua X* X* and to store the result within the Work array. X* X* The user is encouraged to modify this SUBROUTINE for his/her own X* problem of interest. The user is passed the entire Work array which X* contains all intermediate results. The user is encouraged not to X* modify any of the elements within the Work array directly but to use X* the temporary arrays defined within this example SUBROUTINE. The X* user will recognize that these temporary arrays are not essential; X* however, they DO simplify the bookkeeping within the SUBROUTINE. X* X* The parameters in the CALL statement are: X* X* NumOfEqua - The number of derivative equations in the system X* X* NumOfPoints - An INTEGER which increments through the elements within X* the Work array. A given INTEGER value of NumOfPoints corresponds to a X* given value of the independent variable. The value of the X* independent variable takes on values at the sinc points, a X* different sinc point for each CALL of SUBROUTINE F. X* X* Work - A Work array that contains the necessary storage for all X* intermediate and finals results at the sinc points. X* X* The user is encouraged to define temporary variables and arrays: X* X* T - Value of the independent variable for the current SUBROUTINE X* CALL. (NOTE: T = Work(PsiPointer+i) ) X* X* Y(NumOfEqua) - An array containing the current values of the dependent X* variables of the system. X* X* YDOT(NumOfEqua) - An array to be computed within the SUBROUTINE that X* contains the values of the derivatives of the dependent variables X* with respect to the independent variable. X X IMPLICIT NONE X X INCLUDE 'workspace.h' X X* Argument list X DOUBLE PRECISION Work(*) X INTEGER Pos, NumOfEqua X X X* local Variables X INTEGER k X* DOUBLE PRECISION Y(NumOfEqua), YDOT(NumOfEqua), T X* The local arrays Y and YDOT must have fixed dimensions X* determined by the number of equations NumOfEqua=2 X DOUBLE PRECISION Y(2),YDOT(2),T X X X* Pull values of the independent and dependent variables out of the X* work array. X X T = Work(PsiPointer + Pos) X X DO k=1,NumOfEqua X Y(k) = Work(NINT(Work(YPointerPointer + k)) + Pos) X END DO X X* Program your derivative equations here. e.g., X X YDOT(1) = Y(2) X X YDOT(2) = -(2.0/t)*y(2) - y(1)*y(1)*y(1)*y(1)*y(1) X X X* Store the values for YDOT(k) back into the Work array. X X DO k = 1, NumOfEqua X Work(NINT(Work(FPointerPointer + k)) + Pos) = YDOT(k) X END DO X X RETURN X END X X********************************************************************** X SUBROUTINE J_ij (NumOfEqua, Pos, Work) X X* The purpose of this SUBROUTINE is to compute the derivatives X* appearing in the Jacobian. X* X* Bij = dk(i)/dy(j) for i,j=1,..., NumOfEqua X* X* and to store the result within the Work array. X* X* The user is encouraged to modify this SUBROUTINE for his/her own X* problem of interest. The user is passed the entire Work array which X* contains all intermediate results. The user is encouraged not to X* modify any of the elements within the Work array directly but to use X* the temporary arrays defined within this example SUBROUTINE. The X* user will recognize that these temporary arrays are not essential; X* however, they DO simplify the bookkeeping within the SUBROUTINE. X* X* The parameters in the CALL statement are: X X* NumOfEqua - The number of derivative equations in the system X X* Pos - An INTEGER which increments through the elements within X* the Work array. A given INTEGER value of Pos corresponds to a X* given value of the independent variable. The value of the X* independent variable takes on values at the sinc points, a X* different sinc point for each CALL of SUBROUTINE F. X X* Work - A Work array that contains the necessary storage for all X* intermediate and finals results at the sinc points. X X* The user is encouraged to define temporary variables and arrays: X X* T - Value of the independent variable for the current SUBROUTINE X* CALL. (NOTE: T = Work(PsiPointer+i) ) X X* Y(NumOfEqua) - An array containing the current values of the dependent X* variables of the system. X X* Bij(NumOfEqua,NumOfEqua) - An array to be computed within the SUBROUTINE X* that contains the values of the derivatives of the dependent X* variables with respect to the independent variable. X X IMPLICIT none X X INCLUDE 'workspace.h' X X* Definition of parameters. X INTEGER Pos, NumOfEqua X DOUBLE PRECISION Work(*) X X* Local Variables X INTEGER l, k, m X X* Dimension Y() and Bij() to the number of ODE's X X X* DOUBLE PRECISION Y(NumOfEqua), Bij(NumOfEqua,NumOfEqua), T X DOUBLE PRECISION Y(2), Bij(2,2), T X X* Pull values of the independent and dependent variables out of the X* Work array. X X T = Work(PsiPointer + Pos) X X DO k = 1, NumOfEqua X Y(k) = Work(NINT(Work(YPointerPointer + k)) + Pos) X END DO X X* Program your derivative equations here. e.g., X X Bij( 1, 1 ) = 0.0d0 X Bij( 1, 2 ) = 1.0d0 X X Bij( 2, 1 ) = 5.0d0 * y(1)*y(1)*y(1)*y(1) X Bij( 2, 2 ) = -2.0 / t X X* Store the values for Bij( k ) back into the Work array. X k = 0 X DO l = 1, NumOfEqua X DO m = 1, NumOfEqua X k = k + 1 X Work(NINT(Work(BijPointerPointer + k)) + Pos) = X . Bij(m, l) X END DO X END DO X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION Phi(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X Phi = PhiAB(Z, 0.0d0, 1.0d0) X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION OneOverPhiPrime(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X OneOverPhiPrime = PhiPriRecAB(Z, 0.0d0, 1.0d0) X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION Rho(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X Rho = RhoAB(Z, 0.0d0, 1.0d0) X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION Psi(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X Psi = PsiAB(Z, 0.0d0, 1.0d0) X X RETURN X END X X********************************************************************** X SUBROUTINE SetXs( EquaNum, Nxs, X ) X IMPLICIT NONE X X* This routine allows the user to set the values X* of the points at which to view the solution. X X* This section defines the argument list. X INTEGER EquaNum, Nxs X DOUBLE PRECISION X(*) X X INTEGER i X X DO i = 1, Nxs X X(i) = -0.05D0+0.1D0 * DFLOAT(i) X END DO X X return X end X X********************************************************************** X DOUBLE PRECISION FUNCTION Solution(EquaNum, T) X IMPLICIT NONE X X* This section defines the argument list. X INTEGER EquaNum X DOUBLE PRECISION T X X X X* This section defines local variables needed in the solution X DOUBLE PRECISION ROOT X* This is the code section. X ROOT = 1.0d0 / dsqrt( 1.0d0 + t*t/3.0d0 ) X IF(EquaNum .EQ. 1 )THEN X solution=ROOT X ELSE X Solution=(-t)/3*ROOT**3 X END IF X RETURN X END X X********************************************************************** X SUBROUTINE StartAppr( NumOfEqua, N, work ) X IMPLICIT NONE X X* This routine allows the user to set the initial values X* and then puts the initial y values into the work array X X* This section defines the argument list. X INTEGER NumOfEqua, N X DOUBLE PRECISION work(*) X X* Local variables X INTEGER YPointer, OldYPointer, j X INTEGER EquaNum, Pos X X* User set initial values for the dependent variable X DOUBLE PRECISION y( 2, 41 ) X data ( y( 1, j ), j=1,41 )/ 41 * 1.0d0 / X data ( y( 2, j ), j=1,41 )/ 41 * 0.0d0 / X X INCLUDE 'workspace.h' X X do EquaNum = 1, 2 X X YPointer = NINT(Work(YPointerPointer + EquaNum )) X OldYPointer = NINT(Work(OldYPointerPointer + EquaNum )) X X do Pos = 1, 41 X X Work(YPointer + Pos) = y( EquaNum, Pos ) X Work(OldYPointer + Pos) = y( EquaNum, Pos ) X X enddo X X enddo X X RETURN X END X********************************************************************** X SUBROUTINE InitCond(NumOfEqua, Value) X IMPLICIT NONE X X* This section defines the argument list. X INTEGER NumOfEqua X DOUBLE PRECISION Value(NumOfEqua + 1) X X* This is the code section. X X Value(1) = 1.0D0 X Value(2) = 0.0D0 X X RETURN X END X END_OF_FILE if test 11209 -ne `wc -c <'problem_sg1.f'`; then echo shar: \"'problem_sg1.f'\" unpacked with wrong size! fi # end of 'problem_sg1.f' fi if test -f 'problem_wg.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'problem_wg.f'\" else echo shar: Extracting \"'problem_wg.f'\" \(11348 characters\) sed "s/^X//" >'problem_wg.f' <<'END_OF_FILE' X********************************************************************** X* File problem_wg.f X* Example 7.13 X SUBROUTINE ControlVars(SincPts,NumOfEqua,Nxs,MaxIter,H,Itest) X X* The purpose of this SUBROUTINE is to set the controlling X* parameters for the problem. X* X* The parameters in the CALL statement are: X X* SincPts - An INTEGER which controls number of points used in the X* approximation. The solution is computed at y_i( k * H ) with X* k = - SincPts ... SincPts. X X* NumOfEqua - INTEGER - Number of dependent variables in the system X* (i.e., the number of simultaneous IVP's to be solved). X X* Nxs - INTEGER - Number of points at which the solution will be X* approximated. X X* MaxIter - INTEGER - The maximum number of iterations the procedure X* will use in trying to converge. X X* H - DOUBLE PRECISION - This is the step size. In some instances X* picking the optimal H can make a significant difference in the X* accuracy of the result, particularly for small SincPts. However, as X* long H is picked as: X X* H = 1.0d0 /sqrt(C*SincPts) for some C X X* the algorithm will have the appropriate asymptotic accuracy. X* Itest INTEGER: If Itest=0 no exact solution is known and the value X* of double precision function Solution is irrevelant. If itest=1 X* the analytic solution is given by double precision function X* Solution X X IMPLICIT NONE X X DOUBLE PRECISION Pi, C X PARAMETER (Pi = 3.1415926535897932D0 ) X X INTEGER SincPts, NumOfEqua, Nxs, MaxIter,Itest X DOUBLE PRECISION H X X SincPts = 20 X NumOfEqua = 2 X Nxs = 10 X MaxIter = 80 X C=2.0d0 X PRINT * ,'Example 7.13 File: problem_wg.f' X PRINT * ,'Linear problem' X H = Pi / DSQRT( C * DBLE( SincPts ) ) X* If exact solution known, it should be defined by DOUBLE PRECISION X* FUNCTION Solution and we put: X Itest=1 X* If exact solution is not known, then the result of DOUBLE PRECISION X* FUNCTION is irrevelant and we put X* Itest=0 X return X end X X********************************************************************** X X SUBROUTINE F(NumOfEqua, Pos, Work) X X* The purpose of this SUBROUTINE is to compute the derivatives: X* X* dy(i)/dt = f ( t, y(i) ) for i=1,..., NumOfEqua X* X* and to store the result within the Work array. X* X* The user is encouraged to modify this SUBROUTINE for his/her own X* problem of interest. The user is passed the entire Work array which X* contains all intermediate results. The user is encouraged not to X* modify any of the elements within the Work array directly but to use X* the temporary arrays defined within this example SUBROUTINE. The X* user will recognize that these temporary arrays are not essential; X* however, they DO simplify the bookkeeping within the SUBROUTINE. X* X* The parameters in the CALL statement are: X* X* NumOfEqua - The number of derivative equations in the system X* X* NumOfPoints - An INTEGER which increments through the elements within X* the Work array. A given INTEGER value of NumOfPoints corresponds to a X* given value of the independent variable. The value of the X* independent variable takes on values at the sinc points, a X* different sinc point for each CALL of SUBROUTINE F. X* X* Work - A Work array that contains the necessary storage for all X* intermediate and finals results at the sinc points. X* X* The user is encouraged to define temporary variables and arrays: X* X* T - Value of the independent variable for the current SUBROUTINE X* CALL. (NOTE: T = Work(PsiPointer+i) ) X* X* Y(NumOfEqua) - An array containing the current values of the dependent X* variables of the system. X* X* YDOT(NumOfEqua) - An array to be computed within the SUBROUTINE that X* contains the values of the derivatives of the dependent variables X* with respect to the independent variable. X X IMPLICIT NONE X X INCLUDE 'workspace.h' X X* Argument list X DOUBLE PRECISION Work(*) X INTEGER Pos, NumOfEqua X X X* local Variables X INTEGER k X* DOUBLE PRECISION Y(NumOfEqua), YDOT(NumOfEqua), T X* The local arrays Y and YDOT must have fixed dimensions equal to X* the number of equations NumOfEqua=2 X DOUBLE PRECISION Y(2),YDOT(2),T X X X* Pull values of the independent and dependent variables out of the X* work array. X X T = Work(PsiPointer + Pos) X X DO k=1,NumOfEqua X Y(k) = Work(NINT(Work(YPointerPointer + k)) + Pos) X END DO X X* Program your derivative equations here. e.g., X X YDOT(1) = Y( 2 ) X X YDOT(2) = - ( 100.0d0 + 1.0d0 / ( 4.0d0 * t * t ) ) * y(1) X X X* Store the values for YDOT(k) back into the Work array. X X DO k = 1, NumOfEqua X Work(NINT(Work(FPointerPointer + k)) + Pos) = YDOT(k) X END DO X X RETURN X END X X********************************************************************** X SUBROUTINE J_ij (NumOfEqua, Pos, Work) X X* The purpose of this SUBROUTINE is to compute the derivatives X* appearing in the Jacobian. X* X* Bij = dk(i)/dy(j) for i,j=1,..., NumOfEqua X* X* and to store the result within the Work array. X* X* The user is encouraged to modify this SUBROUTINE for his/her own X* problem of interest. The user is passed the entire Work array which X* contains all intermediate results. The user is encouraged not to X* modify any of the elements within the Work array directly but to use X* the temporary arrays defined within this example SUBROUTINE. The X* user will recognize that these temporary arrays are not essential; X* however, they DO simplify the bookkeeping within the SUBROUTINE. X* X* The parameters in the CALL statement are: X X* NumOfEqua - The number of derivative equations in the system X X* Pos - An INTEGER which increments through the elements within X* the Work array. A given INTEGER value of Pos corresponds to a X* given value of the independent variable. The value of the X* independent variable takes on values at the sinc points, a X* different sinc point for each CALL of SUBROUTINE F. X X* Work - A Work array that contains the necessary storage for all X* intermediate and finals results at the sinc points. X X* The user is encouraged to define temporary variables and arrays: X X* T - Value of the independent variable for the current SUBROUTINE X* CALL. (NOTE: T = Work(PsiPointer+i) ) X X* Y(NumOfEqua) - An array containing the current values of the dependent X* variables of the system. X X* Bij(NumOfEqua,NumOfEqua) - An array to be computed within the SUBROUTINE X* that contains the values of the derivatives of the dependent X* variables with respect to the independent variable. X X IMPLICIT none X X INCLUDE 'workspace.h' X X* Definition of parameters. X INTEGER Pos, NumOfEqua X DOUBLE PRECISION Work(*) X X* Local Variables X INTEGER l, k, m X X* Dimension Y() and Bij() to the number of ODE's X X* DOUBLE PRECISION Y(NumOfEqua), Bij(NumOfEqua,NumOfEqua), T X* The local arrays Y and Bij must have fixed dimensions X* determined by the number of equations NumOfEqua=2 X DOUBLE PRECISION Y(2),Bij(2,2),T X X X* Pull values of the independent and dependent variables out of the X* Work array. X X T = Work(PsiPointer + Pos) X X DO k = 1, NumOfEqua X Y(k) = Work(NINT(Work(YPointerPointer + k)) + Pos) X END DO X X* Program your derivative equations here. e.g., X X Bij( 1, 1 ) = 0.0d0 X Bij( 1, 2 ) = 1.0d0 X X Bij( 2, 1 ) = -( 100.0d0 + 1.0d0 / ( 4.0d0*t*t ) ) X Bij( 2, 2 ) = 0.0d0 X X* Store the values for Bij( k ) back into the Work array. X k = 0 X DO l = 1, NumOfEqua X DO m = 1, NumOfEqua X k = k + 1 X Work(NINT(Work(BijPointerPointer + k)) + Pos) = X . Bij(m, l) X END DO X END DO X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION Phi(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X Phi = PhiAB(Z, 1.0d0, 2.0d0) X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION OneOverPhiPrime(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X OneOverPhiPrime = PhiPriRecAB(Z, 1.0d0, 2.0d0) X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION Rho(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X Rho = RhoAB(Z, 1.0d0, 2.0d0) X X RETURN X END X X********************************************************************** X DOUBLE PRECISION FUNCTION Psi(Z) X IMPLICIT NONE X X INCLUDE 'map.h' X X* This section defines the argument list. X DOUBLE PRECISION Z X X* This is the code section. X Psi = PsiAB(Z, 1.0d0, 2.0d0) X X RETURN X END X X********************************************************************** X SUBROUTINE SetXs( EquaNum, Nxs, X ) X IMPLICIT NONE X X* This routine allows the user to set the values X* of the points at which to view the solution. X X* This section defines the argument list. X INTEGER EquaNum, Nxs X DOUBLE PRECISION X(*) X X INTEGER i X X DO i = 1, Nxs X X(i) = 0.95d0 + 0.1D0 * DFLOAT(i) X END DO X X return X end X X********************************************************************** X DOUBLE PRECISION FUNCTION Solution(EquaNum, T) X IMPLICIT NONE X X* This section defines the argument list. X INTEGER EquaNum X DOUBLE PRECISION T X X* This section defines local variables needed in the solution X X DOUBLE PRECISION besj0 X EXTERNAL besj0 X X* This is the code section. X Solution=0.d0 X IF(EquaNum .EQ. 1)THEN X Solution = dsqrt( t ) * besj0( 10.0d0 * T ) X END IF X RETURN X END X X********************************************************************** X SUBROUTINE StartAppr( NumOfEqua, N, work ) X IMPLICIT NONE X X* This routine allows the user to set the initial values X* and then puts the initial y values into the work array X X* This section defines the argument list. X INTEGER NumOfEqua, N X DOUBLE PRECISION work(*) X X* Local variables X INTEGER YPointer, OldYPointer, j X INTEGER EquaNum, Pos X X* User set initial values for the dependent variable X DOUBLE PRECISION y( 2, 41 ) X data ( y( 1, j ), j=1,41 )/ 41 * 1.0d0 / X data ( y( 2, j ), j=1,41 )/ 41 * 1.0d0 / X X INCLUDE 'workspace.h' X X do EquaNum = 1, 2 X X YPointer = NINT(Work(YPointerPointer + EquaNum )) X OldYPointer = NINT(Work(OldYPointerPointer + EquaNum )) X X do Pos = 1, 41 X X Work(YPointer + Pos) = y( EquaNum, Pos ) X Work(OldYPointer + Pos) = y( EquaNum, Pos ) X X enddo X X enddo X X RETURN X END X********************************************************************** X SUBROUTINE InitCond(NumOfEqua, Value) X IMPLICIT NONE X X* This section defines the argument list. X INTEGER NumOfEqua X DOUBLE PRECISION Value(NumOfEqua + 1) X X* This is the code section. X X Value(1) = -.2459357645D0 X Value(2) = -.557695344D0 X X RETURN X END X END_OF_FILE if test 11348 -ne `wc -c <'problem_wg.f'`; then echo shar: \"'problem_wg.f'\" unpacked with wrong size! fi # end of 'problem_wg.f' fi echo shar: End of shell archive. exit 0