#! /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 <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#		"End of shell archive."
# Contents:  READ.ME makefile map.h workspace.h code.f problem_01.f
#   problem_AB.f problem_Bul.f problem_Fun.f problem_Id.f
#   problem_N11.f problem_RR.f problem_Sec.f problem_g.f problem_ig.f
#   problem_l.f problem_sg1.f problem_wg.f
# Wrapped by michela@aurora on Fri Jul  2 18:11:21 1999
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'READ.ME' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'READ.ME'\"
else
echo shar: Extracting \"'READ.ME'\" \(7983 characters\)
sed "s/^X//" >'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