C ALGORITHM 731, COLLECTED ALGORITHMS FROM ACM. C THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, C VOL. 20, NO. 2, JUNE, 1994, PP. 194-214. C####################################################################### C C Text material TOMS submission `A Moving-Grid Interface for Systems of C One-Dimensional Time-Dependent Partial Differential Equations' by C J.G. Blom and P.A. Zegeling. C C Contains, separated by a C######## line, the following files: C ------------------------------------------------------------ C SRCFIL : description of contents of source code file C DRVDOC : documentation of the test program which shows the use C of the moving-grid interface in a DASSL environment. C MIFDOC : software documentation of the moving-grid interface itself. C RESBAK : RESULT file from single precision version C for the first example problem C RUNBAK : RUNINF file from single precision version C for the first example problem C RESCYL : RESULT file from single precision version C for the second example problem C RUNCYL : RUNINF file from single precision version C for the second example problem C RESDSH : RESULT file from single precision version !!!!!!!!!!!!!!!!!! C for the third example problem !!! TAU = 1E-3 !!! C RUNDSH : RUNINF file from single precision version !!! in driver !!! C for the third example problem !!!!!!!!!!!!!!!!!! C RESBAK : RESULT file from double precision version C for the first example problem C RUNBAK : RUNINF file from double precision version C for the first example problem C RESCYL : RESULT file from double precision version C for the second example problem C RUNCYL : RUNINF file from double precision version C for the second example problem C RESDSH : RESULT file from double precision version !!!!!!!!!!!!!!!!!! C for the third example problem !!! TAU = 1E-3 !!! C RUNDSH : RUNINF file from double precision version !!! in driver !!! C for the third example problem !!!!!!!!!!!!!!!!!! C C NB. The single precision results were obtained on a Cray Y-MP and C the double precision results on an SGI Indigo. C####################################################################### C C SRCFIL : description of contents of source code file C C####################################################################### C C*********************************************************************** C C Single Precision files C C*********************************************************************** C C PRBBAK : problem dependent routines for first example problem C PRBCYL : problem dependent routines for second example problem C PRBDSH : problem dependent routines for third example problem C (Burgers' equation) C DRIVER : test program to use the moving-grid interface in a DASSL C environment C SPMDIF : moving-grid interface routines C MACHAR : MACHAR routine from W.J. Cody C (available from Netlib: send machar from elefunt) C SDASSL : DASSL DAE integrator from L.R. Petzold C (available from Netlib: send sdassl from ode) C NB. DASSL needs the following files: C DASUSE : contains the routine C I1MACH to get the standard error message unit (6). C (also available from Netlib: send i1mach from core) C R1MACH to determine machine precision, uses value determined C by MACHAR C (also available from Netlib: send r1mach from core) C and the dummies for the routines SGEFA and SGESL from LINPACK C (available from Netlib: send sgefa/sgesl from linpack) C DASLIP : LINPACK routines needed by DASSL C (available from Netlib: send sgbfa/sgbsl from linpack) C C*********************************************************************** C C Double Precision files C C*********************************************************************** C C PRBBAK : problem dependent routines for first example problem C PRBCYL : problem dependent routines for second example problem C PRBDSH : problem dependent routines for third example problem C (Burgers' equation) C DRIVER : test program to use the moving-grid interface in a DASSL C environment C SPMDIF : moving-grid interface routines C MACHAR : MACHAR routine from W.J. Cody C (available from Netlib: send machar from elefunt) C DDASSL : DASSL DAE integrator from L.R. Petzold C (available from Netlib: send ddassl from ode) C NB. DASSL needs the following files: C DASUSE : contains the routine C I1MACH to get the standard error message unit (6). C (also available from Netlib: send i1mach from core) C D1MACH to determine machine precision, uses value determined C by MACHAR C (also available from Netlib: send d1mach from core) C and the dummies for the routines DGEFA and DGESL from LINPACK C (available from Netlib: send dgefa/dgesl from linpack) C DASLIP : LINPACK routines needed by DASSL C (available from Netlib: send dgbfa/dgbsl from linpack) C C####################################################################### C C DRVDOC : documentation of the test program which shows the use C of the moving-grid interface in a DASSL environment. C C####################################################################### C C Description of DRIVER: C --------------------- C Main program MoL adaptive grid interface for DASSL C Calls problem initializer, C Initializes DASSL parameters + grid/solution C Put semi-discrete PDE system + Dorfi&Drury grid equation in DASSL C Write grid and solution at specific steps (TPRINT) to outputfile C C Problem choice by loading the specific problem file with the modules: C C SUBROUTINE INIPRB (TEXT) C CHARACTER TEXT*80 C Initialize /PROBLM/ C C SUBROUTINE UINIT (NPDE, NPTS, Y) C INTEGER NPDE, NPTS C REAL Y(NPDE+1,NPTS) C Initial solution; optionnally redefinition of (uniform) grid C C SUBROUTINE SPDEF (T,X,NPDE, U, DUDX, C, Q, R, IRES) C INTEGER NPDE, IRES C REAL T, X C REAL U(NPDE), DUDX(NPDE), C(NPDE,NPDE), Q(NPDE), R(NPDE) C PDE defining functions C, Q, R C C SUBROUTINE BNDR (T, BETA, GAMMA, U, UX, NPDE, LEFT, IRES) C INTEGER NPDE, IRES C LOGICAL LEFT C REAL T C REAL BETA(NPDE), GAMMA(NPDE), U(NPDE), UX(NPDE) C Boundary function C C SUBROUTINE UEXACT (X, T, U) C REAL X, T C REAL U(NPDE) C Exact solution (only called if SOLAV=TRUE) C How to use the interface in a DASSL environment: ----------------------------------------------- Compile and link the files DRIVER SPMDIF MACHAR SDASSL DASUSE DASLIP and one of the problem dependent routines PRB... NB. If PRBDSH is used the TAU parameter in DRIVER should be set to == TAU = 1E-3 since the initial grid is not consistent with the DAE system. The results and integration information can be found in the corresponding files RES... RUN... C C####################################################################### C C MIFDOC : software documentation of the moving-grid interface itself. C C####################################################################### C C----------------------------------------------------------------------- C C Moving grid discretization module SPMDIF C ---------------------------------------- C This module discretizes systems of partial differential equations C in one space variable on a moving grid. The class of equations that C can be handled is given by C C NPDE k -m m C sum C (x,t, u, u ) u + Q (x,t, u, u ) = x (x R (x,t, u, u )) C k=1 j,k - -x t j - -x j - -x x C C where 1 NPDE T C u = ( u , ... , u ) , j = 1,... , NPDE, C - C k C and u is the partial derivative wrt time of the k-th component of u. C t C C The functions C, Q, and R are assumed to be continuous w.r.t. the C space variable. C C The independent variables x and t satisfy x < x < x with x and x C L R L R C fixed and t > t . C 0 C The boundary conditions have the form C C BETA(x,t).R(x,t,u,u ) = GAMMA(x,t,u,u ) at x = x , x , C - -x - -x L R C C where not all of the functions BETA and GAMMA are set to zero. C C The initial conditions are given by C 0 C u (x,t ) = u (x) for x <= x <= x . C - 0 - L R C The discretization method for the PDE in Lagrangian formulation C used by this module is based on a lumped Galerkin / Petrov-Galerkin C method and evaluates the PDE functions in a point between C the (moving) grid points. C C References: C Fixed-grid spatial discretization C Skeel R.D. and Berzins M. C A Method for the Spatial Discretisation of Parabolic C Equations in one Space Variable. C Leeds Report no 217, C Dept. of Computer Studies, The University. C Grid movement C Verwer J.G., Blom J.G., Furzeland R.M. and Zegeling P.A. C A Moving-Grid Method for One-Dimensional PDEs based on C the Method of Lines. C Report NM-R8818, C Centre for Mathematics and Computer Science, Amsterdam. C Interface C Blom J.G. and Zegeling P.A. C A Moving-Grid Interface for Systems of One-Dimensional C Time-Dependent Partial Differential Equations. C Report NM-R8904, C Centre for Mathematics and Computer Science, Amsterdam. C (ACM TOMS algorithm) C C---------------------------------------------------------------------- C C How to use this module C ---------------------- C 1. Set NPDE = # PDEs to be solved. C Set NPTS = # mesh points to be used. C (NC=NPTS-2 is # internal points) C Set M for space coordinate type C = 0 for Cartesian, = 1 for cylindrical, = 2 for spherical. C Specify a workspace of size at least (NPDE+1)*NPTS+(6+NPDE)*NPDE C for use by the routine SKMRES which defines the DAE system being C solved by the integrator. C C Call the initialization routine SETSKM, see the documentation at C the head of this routine for the precise details of the call. C C Set TS and TOUT for start and end integration times. C Initialize data as required for time integration, C - see documentation of DAE solver. C Call the DAE solver with as residual routine SKMRES or an C enveloping routine to satisfy the header requirements. C C 2. Provide a set of routines which describe the precise form of the C PDEs to be solved. Three routines must be provided and the names C of these routines are fixed. These routines are: C SPDEF forms the functions C, Q and R of the PDE in a C given x-point. C BNDR forms the functions BETA and GAMMA associated with the C boundary conditions for the PDE. C UINIT supplies the initial values of the PDE part. C An initial uniform grid is generated by SETSKM and C provided in Y(NPDE+1,I), I=1,NPTS. If required, a user C can redefine the mesh in a nonuniform way. C The headers of these routines are: C C SUBROUTINE SPDEF (T, X, NPDE, U, DUDX, C, Q, R, IRES) C INTEGER NPDE, IRES C REAL T, X C REAL U(NPDE), DUDX(NPDE), C(NPDE,NPDE), Q(NPDE), R(NPDE) C C SUBROUTINE BNDR (T, BETA, GAMMA, U, DUDX, NPDE, LEFT, IRES) C INTEGER NPDE, IRES C LOGICAL LEFT C REAL T C REAL BETA(NPDE), GAMMA(NPDE), U(NPDE), DUDX(NPDE) C C SUBROUTINE UINIT (NPDE, NPTS, Y) C INTEGER NPDE, NPTS C REAL Y(NPDE+1,NPTS) C C C Example problem C --------------- C The easiest way to describe how the problem description routines C should be written is by a simple example. Consider the following C problem from electrodynamics C u = eps.p.u - g(u-v) C t xx C and (so m = 0 and NPDE = 2) C v = p.v + g(u-v) C t xx C with C g(z) = exp(eta.z/3) - exp(-2.eta.z/3) , C 0 <= x <= 1 and 0 <= t <= 4; C eps = 0.143, p = 0.1743, and eta = 17.19. C C The left boundary condition (LEFT = .TRUE.) is given by C u = 0 and v = 0 at x = 0, C x C the right boundary condition (LEFT = .FALSE.) is C u = 0 and v = 0 at x = 1, C x C and the initial conditions are C u = 1 and v = 0 at t = 0. C C The routines UINIT, SPDEF and BNDR are listed below. C The component u of the PDE at the i-th grid point is held as Y(1,i) C in the package, the component v as Y(2,i); the i-th grid point C itself is stored in Y(3,i). C C C C SUBROUTINE UINIT (NPDE, NPTS, Y) C C Routine for PDE initial values. C Entry: C Y(NPDE+1,i) = x_i; uniform mesh, generated by package C Exit: C Y(NPDE+1,i) = x_i; mesh, optionally changed by user C Y( k,i) = u_k(x_i,t0); initial value of k-th component C i = 1,.., NPTS C C INTEGER NPDE, NPTS C REAL Y(NPDE+1,NPTS) C C INTEGER I C C DO 10 I = 1, NPTS C Y(1,I) = 1.0 C Y(2,I) = 0.0 C 10 CONTINUE C C RETURN C END C C C C SUBROUTINE SPDEF (T, X, NPDE, U, DUDX, C, Q, R, IRES) C C Routine to describe the body of the PDE system. C The PDE is written as C NPDE k -m m C sum C (x,t,u,u ) u + Q (x,t,u,u ) = x (x R (x,t,u,u ) ) . C k=1 jk x t j x j x x C The functions C, Q and R must be defined in this routine. C C INTEGER NPDE, IRES C REAL T, X C REAL U(NPDE), DUDX(NPDE), C(NPDE,NPDE), Q(NPDE), R(NPDE) C C INTEGER J, K C REAL EPS, ETA, GZ, P, Z C DATA EPS /0.143/, ETA /17.19/, P /0.1743/ C C DO 10 K = 1, NPDE C DO 20 J = 1, NPDE C C(J,K) = 0.0 C 20 CONTINUE C C(K,K) = 1.0 C 10 CONTINUE C C Z = U(1) - U(2) C GZ = EXP(ETA*Z/3) - EXP(-2*ETA*Z/3) C Q(1) = GZ C Q(2) = -GZ C C R(1) = EPS*P * DUDX(1) C R(2) = P * DUDX(2) C C RETURN C END C C C C SUBROUTINE BNDR (T, BETA, GAMMA, U, DUDX, NPDE, LEFT, IRES) C C Boundary conditions routine C The boundary conditions are written as C BETA (x,t) R (x,t,u,u ) = GAMMA (x,t,u,u ) C j j x j x C The functions BETA and GAMMA should be defined in this routine. C C INTEGER NPDE, IRES C LOGICAL LEFT C REAL T C REAL BETA(NPDE), GAMMA(NPDE), U(NPDE), DUDX(NPDE) C C IF (LEFT) THEN C BETA (1) = 1.0 C GAMMA(1) = 0.0 C BETA (2) = 0.0 C GAMMA(2) = U(2) C ELSE C BETA (1) = 0.0 C GAMMA(1) = U(1) - 1.0 C BETA (2) = 1.0 C GAMMA(2) = 0.0 C ENDIF C C RETURN C END C C C####################################################################### C C RESBAK : RESULT file from single precision version C for the first example problem C C####################################################################### C Bakker, Electrodynamics problem; EPS=0.143, P=0.1743, ETA=17.19 MoL, PDE+D&D int.face; DAE int.: DASSL; ID:ACM-TOMS, Ex.I NPTS= 21; RTOL=.100E-02, ATOL=.100E-02 TAU=.000E+00, KAPPA=.200E+01, ALPHA=.100E-01 -T= 0.00000E+00 X(S,TN): 0.00000000000000E+00 0.50000000000000E-01 0.10000000000000E+00 0.15000000000000E+00 0.20000000000000E+00 0.25000000000000E+00 0.30000000000000E+00 0.35000000000000E+00 0.40000000000000E+00 0.45000000000000E+00 0.50000000000000E+00 0.55000000000000E+00 0.60000000000000E+00 0.65000000000000E+00 0.70000000000000E+00 0.75000000000000E+00 0.80000000000000E+00 0.85000000000000E+00 0.90000000000000E+00 0.95000000000000E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP:1 0.10000000000000E+01 0.10000000000000E+01 0.10000000000000E+01 0.10000000000000E+01 0.10000000000000E+01 0.10000000000000E+01 0.10000000000000E+01 0.10000000000000E+01 0.10000000000000E+01 0.10000000000000E+01 0.10000000000000E+01 0.10000000000000E+01 0.10000000000000E+01 0.10000000000000E+01 0.10000000000000E+01 0.10000000000000E+01 0.10000000000000E+01 0.10000000000000E+01 0.10000000000000E+01 0.10000000000000E+01 0.10000000000000E+01 U(X(S,TN),TN), COMP:2 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 -T= 0.10000E-03 X(S,TN): -0.45929255914759E-19 0.25040640290220E-01 0.56481182704547E-01 0.95013746311533E-01 0.14035701231943E+00 0.19172997170988E+00 0.24805286040399E+00 0.30815425177574E+00 0.37092073056414E+00 0.43536105966516E+00 0.50059965537049E+00 0.56582746970413E+00 0.63023451172673E+00 0.69294260800311E+00 0.75295709500441E+00 0.80916185657288E+00 0.86038575610616E+00 0.90555452167634E+00 0.94389834759477E+00 0.97514972312581E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP:1 0.97256278203386E+00 0.97297329460978E+00 0.97347359747748E+00 0.97362279769018E+00 0.97365968612859E+00 0.97366795251495E+00 0.97366993754457E+00 0.97367061718684E+00 0.97367094665945E+00 0.97367111097203E+00 0.97367116090931E+00 0.97367110995003E+00 0.97367094675137E+00 0.97367066002049E+00 0.97367048643146E+00 0.97367279232644E+00 0.97369354243553E+00 0.97382236618489E+00 0.97451336969171E+00 0.97805479165282E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP:2 0.10158626506619E-16 0.21863836925754E-01 0.25474655206463E-01 0.26176978370070E-01 0.26306690064825E-01 0.26327294436488E-01 0.26329526698004E-01 0.26329338707842E-01 0.26329051464071E-01 0.26328889377324E-01 0.26328839457234E-01 0.26328890549432E-01 0.26329056717380E-01 0.26329390760117E-01 0.26330088342959E-01 0.26332151381840E-01 0.26340710279631E-01 0.26378419427779E-01 0.26528830856401E-01 0.27025637008333E-01 0.27429641024853E-01 Statistics: FNS, JACS:25, 9 STEPS, ETF, CTF:14, 0, 0 -T= 0.10000E-02 X(S,TN): 0.10096741302168E-15 0.12035719074328E-01 0.27659128209353E-01 0.49865220895497E-01 0.81605103543717E-01 0.12602462914175E+00 0.18619247847968E+00 0.26401810016408E+00 0.35861164907025E+00 0.46490893940724E+00 0.57403954521281E+00 0.67610235632744E+00 0.76369477884377E+00 0.83368267073946E+00 0.88661980899191E+00 0.92509600342961E+00 0.95229367331208E+00 0.97117431687522E+00 0.98419344028329E+00 0.99327637270227E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP:1 0.84124639415634E+00 0.85198008579324E+00 0.86417805594088E+00 0.86767855237370E+00 0.86870605053580E+00 0.86901606826152E+00 0.86910499154684E+00 0.86912953917044E+00 0.86913887899673E+00 0.86914157341817E+00 0.86913640670443E+00 0.86912565320049E+00 0.86912013781261E+00 0.86915098186856E+00 0.86930686492989E+00 0.86979879062790E+00 0.87108032245948E+00 0.87416884320602E+00 0.88202791044688E+00 0.90698269192593E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP:2 0.12906845854695E-14 0.85805240030432E-01 0.11962492264781E+00 0.12841936270931E+00 0.13028720055180E+00 0.13074916685063E+00 0.13085454382600E+00 0.13086676156911E+00 0.13086128635510E+00 0.13085860201449E+00 0.13086418709539E+00 0.13087854363622E+00 0.13090461500711E+00 0.13096181033273E+00 0.13110840596252E+00 0.13150473184524E+00 0.13256554012321E+00 0.13517998806772E+00 0.14028780604146E+00 0.14665928624041E+00 0.14940963004855E+00 Statistics: FNS, JACS:61, 13 STEPS, ETF, CTF:33, 0, 0 -T= 0.10000E-01 X(S,TN): 0.12321694707397E-15 0.16259046659784E-01 0.34383535895571E-01 0.56835836175499E-01 0.87041130186527E-01 0.12957612320856E+00 0.18909463247710E+00 0.26896987480346E+00 0.36926606771224E+00 0.48381928143333E+00 0.60023366312207E+00 0.70518181363670E+00 0.79064082999200E+00 0.85527719537961E+00 0.90186409643097E+00 0.93448369137719E+00 0.95706820877491E+00 0.97276825821681E+00 0.98401711038015E+00 0.99265720180072E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP:1 0.55402306951480E+00 0.58108910541637E+00 0.63225213431880E+00 0.66627322477729E+00 0.68085414520969E+00 0.68521098036305E+00 0.68607431016619E+00 0.68618613358218E+00 0.68620358427590E+00 0.68620857279386E+00 0.68620575805936E+00 0.68620193948851E+00 0.68622622321513E+00 0.68640895842475E+00 0.68722049724873E+00 0.68983177811135E+00 0.69843379361656E+00 0.72636152222943E+00 0.78483376221049E+00 0.87331914958560E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP:2 -0.14423510781113E-15 0.10434572933473E+00 0.18773200936252E+00 0.25316318733207E+00 0.29495829171579E+00 0.31083861716651E+00 0.31358221957824E+00 0.31379496379115E+00 0.31379634997062E+00 0.31379210702118E+00 0.31379639822638E+00 0.31381263466474E+00 0.31387638022552E+00 0.31432301373424E+00 0.31681082856067E+00 0.32390520899290E+00 0.33490016491657E+00 0.34648401666759E+00 0.35618494627395E+00 0.36293229887844E+00 0.36542563003615E+00 Statistics: FNS, JACS:87, 16 STEPS, ETF, CTF:50, 0, 0 -T= 0.10000E+00 X(S,TN): 0.14331098239068E-15 0.27509483466300E-01 0.55993853613377E-01 0.86797397243380E-01 0.12184131719335E+00 0.16382468916371E+00 0.21644008503414E+00 0.28414150959066E+00 0.37020737682426E+00 0.47234901909983E+00 0.58046996527423E+00 0.68113151533455E+00 0.76479022471584E+00 0.82907726170566E+00 0.87662281502272E+00 0.91151541453917E+00 0.93755459576611E+00 0.95766091089810E+00 0.97387210855655E+00 0.98760829949711E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP:1 0.21974534394379E+00 0.24082376269937E+00 0.29058114641601E+00 0.34867167626356E+00 0.40416712783431E+00 0.44973781796411E+00 0.48125524138903E+00 0.49908680544002E+00 0.50698569979986E+00 0.50962245266198E+00 0.51055292014141E+00 0.51203188913654E+00 0.51609479116237E+00 0.52517648903438E+00 0.54436694256418E+00 0.58048272381257E+00 0.63431426634869E+00 0.70289964791332E+00 0.78413731636754E+00 0.87974885845813E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP:2 -0.18368361340501E-14 0.88797802893640E-01 0.16833570592607E+00 0.24183227161984E+00 0.31039168545408E+00 0.37292535255351E+00 0.42566498790975E+00 0.46296747411637E+00 0.48196669098422E+00 0.48823941471498E+00 0.49030543486261E+00 0.49378948087089E+00 0.50305406913238E+00 0.51960809965608E+00 0.54068676663276E+00 0.56194272044633E+00 0.58032800498320E+00 0.59478225700266E+00 0.60534675177147E+00 0.61217120657784E+00 0.61461802433752E+00 Statistics: FNS, JACS:109, 18 STEPS, ETF, CTF:67, 0, 0 -T= 0.25000E+00 X(S,TN): 0.12725037865343E-15 0.35291254425231E-01 0.71018499650379E-01 0.10814727313561E+00 0.14806484107473E+00 0.19254359390664E+00 0.24383356497859E+00 0.30463589317156E+00 0.37745877336233E+00 0.46262763941150E+00 0.55547608492964E+00 0.64660341650348E+00 0.72720823654849E+00 0.79352530583887E+00 0.84616098410961E+00 0.88743116331616E+00 0.91981720922314E+00 0.94553081719465E+00 0.96644700465101E+00 0.98413122687172E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP:1 0.10805691125032E+00 0.12867780638170E+00 0.17698893961420E+00 0.23411712654762E+00 0.29233041000358E+00 0.34784124009268E+00 0.39770932046008E+00 0.43884543498730E+00 0.46883295790019E+00 0.48788841142235E+00 0.50012006547364E+00 0.51181131222257E+00 0.52821187130139E+00 0.55126970203934E+00 0.58088153128989E+00 0.61789323477408E+00 0.66469191726619E+00 0.72340650173389E+00 0.79551790787835E+00 0.88411328778420E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP:2 0.32113325487618E-14 0.74015549627789E-01 0.14091574007736E+00 0.20354615192433E+00 0.26322295556401E+00 0.32010382632822E+00 0.37315587636328E+00 0.41999805889254E+00 0.45728004537205E+00 0.48295016505953E+00 0.50002278877089E+00 0.51592872114635E+00 0.53662059145540E+00 0.56286195944614E+00 0.59169029042505E+00 0.61938021532653E+00 0.64316739171925E+00 0.66177161083460E+00 0.67509344374135E+00 0.68341946465375E+00 0.68632734130789E+00 Statistics: FNS, JACS:117, 19 STEPS, ETF, CTF:74, 0, 0 -T= 0.50000E+00 X(S,TN): 0.14309716753197E-15 0.44439184054847E-01 0.88805154702960E-01 0.13392003828239E+00 0.18087866430320E+00 0.23083518694143E+00 0.28495809726599E+00 0.34430991038575E+00 0.40951532593247E+00 0.48017618529946E+00 0.55428281061888E+00 0.62829230260064E+00 0.69829246288909E+00 0.76140048913084E+00 0.81625745109764E+00 0.86267957209169E+00 0.90118663330737E+00 0.93275317065160E+00 0.95869695796909E+00 0.98054839125876E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP:1 0.61705872700837E-01 0.83571830093333E-01 0.13215150721409E+00 0.18633482340289E+00 0.24042708729016E+00 0.29267592896158E+00 0.34206223729876E+00 0.38753962103392E+00 0.42811975474081E+00 0.46346837107444E+00 0.49467327599739E+00 0.52422241421676E+00 0.55451688142558E+00 0.58639607641640E+00 0.61954782368977E+00 0.65442523020765E+00 0.69380864711304E+00 0.74236191663913E+00 0.80489381307507E+00 0.88669439366782E+00 0.99999999999999E+00 U(X(S,TN),TN), COMP:2 0.29357275824825E-14 0.63742469167286E-01 0.12163927031717E+00 0.17672723402117E+00 0.22997910286532E+00 0.28151552181222E+00 0.33094496061509E+00 0.37748421738985E+00 0.42020712674656E+00 0.45860618995472E+00 0.49330124460705E+00 0.52612422735900E+00 0.55894416347117E+00 0.59231651008286E+00 0.62533800603176E+00 0.65630895899070E+00 0.68338628129423E+00 0.70513609405918E+00 0.72093103881909E+00 0.73076722895464E+00 0.73416672114764E+00 Statistics: FNS, JACS:125, 20 STEPS, ETF, CTF:80, 0, 0 -T= 0.10000E+01 X(S,TN): 0.15579464091624E-15 0.54377796631882E-01 0.10808499702755E+00 0.16166534113479E+00 0.21573577426543E+00 0.27077941894134E+00 0.32712512028561E+00 0.38491631485438E+00 0.44407755115856E+00 0.50430143165554E+00 0.56502076662724E+00 0.62539846087767E+00 0.68439978007837E+00 0.74088134783070E+00 0.79366740937016E+00 0.84166569394911E+00 0.88403012922474E+00 0.92037830480956E+00 0.95100855908446E+00 0.97697228843874E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP:1 0.41855939535181E-01 0.64374251707875E-01 0.11186576987393E+00 0.16204980866788E+00 0.21164682386363E+00 0.26020607448425E+00 0.30762778791832E+00 0.35384089867530E+00 0.39881014785837E+00 0.44257057790027E+00 0.48519340782749E+00 0.52670743080367E+00 0.56703180609075E+00 0.60593798951026E+00 0.64314500553159E+00 0.67890444579687E+00 0.71527246918554E+00 0.75721065734866E+00 0.81192653120524E+00 0.88782968033196E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP:2 -0.29428837436846E-14 0.57131864288686E-01 0.10922404384575E+00 0.15955951890530E+00 0.20880629258781E+00 0.25712185005723E+00 0.30452055106568E+00 0.35095994941793E+00 0.39640073540404E+00 0.44081243225129E+00 0.48416051562390E+00 0.52638421227051E+00 0.56733409386149E+00 0.60668419317797E+00 0.64387198669139E+00 0.67806789646732E+00 0.70817472279515E+00 0.73294873042647E+00 0.75138144575774E+00 0.76298926846214E+00 0.76699655461490E+00 Statistics: FNS, JACS:134, 22 STEPS, ETF, CTF:87, 0, 0 -T= 0.20000E+01 X(S,TN): 0.29409680181596E-15 0.60053312578581E-01 0.11903677672934E+00 0.17727611123687E+00 0.23511706509967E+00 0.29279165598505E+00 0.35043595339502E+00 0.40810238795770E+00 0.46575791994838E+00 0.52327779388177E+00 0.58042955175588E+00 0.63684463711884E+00 0.69199400983232E+00 0.74516472209928E+00 0.79546441287016E+00 0.84188932882871E+00 0.88349316596151E+00 0.91966692030223E+00 0.95044811298548E+00 0.97668380211812E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP:1 0.35153306610654E-01 0.57866835981245E-01 0.10462817309598E+00 0.15300641642817E+00 0.20100810899407E+00 0.24855287024443E+00 0.29567823589677E+00 0.34238440863736E+00 0.38862216690770E+00 0.43429254093055E+00 0.47923385334969E+00 0.52319895985026E+00 0.56583652449281E+00 0.60670223125468E+00 0.64540338585039E+00 0.68213406960155E+00 0.71883586428744E+00 0.76036192060918E+00 0.81407465320883E+00 0.88880160013576E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP:2 0.83672220273541E-14 0.54320856370252E-01 0.10405126664540E+00 0.15262122839213E+00 0.20056433684308E+00 0.24804132895257E+00 0.29511679638358E+00 0.34179518052582E+00 0.38802979007883E+00 0.43372020420521E+00 0.47869659580729E+00 0.52270542162762E+00 0.56538312543830E+00 0.60622865018382E+00 0.64459146390332E+00 0.67964650343230E+00 0.71036886968219E+00 0.73560345360282E+00 0.75438217175095E+00 0.76620774946117E+00 0.77028755821621E+00 Statistics: FNS, JACS:141, 23 STEPS, ETF, CTF:92, 0, 0 -T= 0.30000E+01 X(S,TN): 0.28573248148445E-15 0.61545078541541E-01 0.12195028465348E+00 0.18152001114298E+00 0.24056090084449E+00 0.29926758441615E+00 0.35774357225620E+00 0.41601581266998E+00 0.47403676436145E+00 0.53167582403960E+00 0.58870138247998E+00 0.64475520163642E+00 0.69932378731912E+00 0.75171728897627E+00 0.80107736495090E+00 0.84644881821691E+00 0.88695344395276E+00 0.92206692122934E+00 0.95190595527069E+00 0.97735239318904E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP:1 0.33958724409891E-01 0.56829997983521E-01 0.10362924441254E+00 0.15176444318814E+00 0.19952056487269E+00 0.24686675541916E+00 0.29384675605411E+00 0.34046027313350E+00 0.38665455929641E+00 0.43231818382776E+00 0.47726846727143E+00 0.52123386881998E+00 0.56383965630444E+00 0.60463095475969E+00 0.64324849097419E+00 0.68001327241054E+00 0.71707805635342E+00 0.75938810677969E+00 0.81403088298383E+00 0.88929997660461E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP:2 -0.19060764564055E-14 0.53908575476223E-01 0.10328102875282E+00 0.15158885010453E+00 0.19932380863160E+00 0.24663694326002E+00 0.29358882170883E+00 0.34018116733100E+00 0.38636162646034E+00 0.43201868525592E+00 0.47696902789347E+00 0.52093896719268E+00 0.56354233961505E+00 0.60425935917571E+00 0.64241850304921E+00 0.67717428866561E+00 0.70749185143344E+00 0.73224719410853E+00 0.75056556132342E+00 0.76205903957098E+00 0.76602026680388E+00 Statistics: FNS, JACS:146, 24 STEPS, ETF, CTF:95, 0, 0 -T= 0.40000E+01 X(S,TN): -0.85468233905893E-16 0.62278089651929E-01 0.12338589600318E+00 0.18362097106100E+00 0.24327343518029E+00 0.30252134231709E+00 0.36145307371032E+00 0.42008210677703E+00 0.47834931144713E+00 0.53611463939805E+00 0.59313955698469E+00 0.64906209169345E+00 0.70336918356199E+00 0.75537733328420E+00 0.80424320252131E+00 0.84903886446402E+00 0.88892831962760E+00 0.92344078672753E+00 0.95274240063757E+00 0.97773675557374E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP:1 0.33421631420763E-01 0.56380094159363E-01 0.10321815438402E+00 0.15125338833211E+00 0.19890283667247E+00 0.24615552130313E+00 0.29305621644875E+00 0.33960294650938E+00 0.38574020556715E+00 0.43135247048215E+00 0.47625139131189E+00 0.52015834994579E+00 0.56269167606630E+00 0.60339604193638E+00 0.64193674077807E+00 0.67871347153285E+00 0.71600107567396E+00 0.75878543377197E+00 0.81398050494738E+00 0.88957192118291E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP:2 -0.57131982845478E-15 0.53737185559809E-01 0.10295746219314E+00 0.15115351828478E+00 0.19879595065330E+00 0.24603024097559E+00 0.29291446209511E+00 0.33944809845995E+00 0.38557597776079E+00 0.43118267915336E+00 0.47607961326666E+00 0.51998620953497E+00 0.56250800482608E+00 0.60311585136995E+00 0.64112759825094E+00 0.67568618264273E+00 0.70575090826504E+00 0.73021685319163E+00 0.74826369867698E+00 0.75956434986654E+00 0.76345718816966E+00 Statistics: FNS, JACS:147, 24 STEPS, ETF, CTF:96, 0, 0 C C####################################################################### C C RUNBAK : RUNINF file from single precision version C for the first example problem C C####################################################################### C Bakker, Electrodynamics problem; EPS=0.143, P=0.1743, ETA=17.19 MoL, PDE+D&D int.face; DAE int.: DASSL; ID:ACM-TOMS, Ex.I NPTS= 21; RTOL=.100E-02, ATOL=.100E-02 TAU=.000E+00, KAPPA=.200E+01, ALPHA=.100E-01 Time= 0.20000E-06; H= 0.10000E-06; Order= 1 Time= 0.40000E-06; H= 0.20000E-06; Order= 2 Time= 0.80000E-06; H= 0.40000E-06; Order= 1 Time= 0.16000E-05; H= 0.80000E-06; Order= 1 Time= 0.32000E-05; H= 0.16000E-05; Order= 1 Time= 0.64000E-05; H= 0.32000E-05; Order= 1 Time= 0.12800E-04; H= 0.64000E-05; Order= 1 Time= 0.19200E-04; H= 0.64000E-05; Order= 1 Time= 0.25600E-04; H= 0.64000E-05; Order= 1 Time= 0.38400E-04; H= 0.12800E-04; Order= 2 Time= 0.51200E-04; H= 0.12800E-04; Order= 2 Time= 0.64000E-04; H= 0.12800E-04; Order= 2 Time= 0.76800E-04; H= 0.12800E-04; Order= 2 Time= 0.10240E-03; H= 0.25600E-04; Order= 2 Time= 0.12800E-03; H= 0.25600E-04; Order= 1 Time= 0.15104E-03; H= 0.23040E-04; Order= 1 Time= 0.17408E-03; H= 0.23040E-04; Order= 1 Time= 0.19712E-03; H= 0.23040E-04; Order= 1 Time= 0.24320E-03; H= 0.46080E-04; Order= 2 Time= 0.28928E-03; H= 0.46080E-04; Order= 2 Time= 0.33536E-03; H= 0.46080E-04; Order= 2 Time= 0.38144E-03; H= 0.46080E-04; Order= 2 Time= 0.42752E-03; H= 0.46080E-04; Order= 2 Time= 0.47360E-03; H= 0.46080E-04; Order= 3 Time= 0.51968E-03; H= 0.46080E-04; Order= 2 Time= 0.56576E-03; H= 0.46080E-04; Order= 2 Time= 0.61184E-03; H= 0.46080E-04; Order= 2 Time= 0.65792E-03; H= 0.46080E-04; Order= 2 Time= 0.70400E-03; H= 0.46080E-04; Order= 1 Time= 0.75008E-03; H= 0.46080E-04; Order= 1 Time= 0.84224E-03; H= 0.92160E-04; Order= 1 Time= 0.93440E-03; H= 0.92160E-04; Order= 1 Time= 0.10266E-02; H= 0.92160E-04; Order= 1 Time= 0.12109E-02; H= 0.18432E-03; Order= 2 Time= 0.13952E-02; H= 0.18432E-03; Order= 2 Time= 0.17638E-02; H= 0.36864E-03; Order= 2 Time= 0.20956E-02; H= 0.33178E-03; Order= 2 Time= 0.24274E-02; H= 0.33178E-03; Order= 2 Time= 0.27592E-02; H= 0.33178E-03; Order= 2 Time= 0.30909E-02; H= 0.33178E-03; Order= 2 Time= 0.34227E-02; H= 0.33178E-03; Order= 3 Time= 0.40863E-02; H= 0.66355E-03; Order= 3 Time= 0.47498E-02; H= 0.66355E-03; Order= 3 Time= 0.54134E-02; H= 0.66355E-03; Order= 3 Time= 0.60769E-02; H= 0.66355E-03; Order= 3 Time= 0.67405E-02; H= 0.66355E-03; Order= 2 Time= 0.74040E-02; H= 0.66355E-03; Order= 2 Time= 0.80676E-02; H= 0.66355E-03; Order= 2 Time= 0.87311E-02; H= 0.66355E-03; Order= 2 Time= 0.10058E-01; H= 0.13271E-02; Order= 2 Time= 0.11385E-01; H= 0.13271E-02; Order= 2 Time= 0.12712E-01; H= 0.13271E-02; Order= 2 Time= 0.15367E-01; H= 0.26542E-02; Order= 2 Time= 0.18021E-01; H= 0.26542E-02; Order= 2 Time= 0.20675E-01; H= 0.26542E-02; Order= 2 Time= 0.23329E-01; H= 0.26542E-02; Order= 2 Time= 0.28638E-01; H= 0.53084E-02; Order= 3 Time= 0.33946E-01; H= 0.53084E-02; Order= 3 Time= 0.39255E-01; H= 0.53084E-02; Order= 3 Time= 0.44563E-01; H= 0.53084E-02; Order= 3 Time= 0.49871E-01; H= 0.53084E-02; Order= 3 Time= 0.60488E-01; H= 0.10617E-01; Order= 2 Time= 0.70043E-01; H= 0.95551E-02; Order= 2 Time= 0.79598E-01; H= 0.95551E-02; Order= 2 Time= 0.89154E-01; H= 0.95551E-02; Order= 2 Time= 0.98709E-01; H= 0.95551E-02; Order= 2 Time= 0.11782E+00; H= 0.19110E-01; Order= 3 Time= 0.13693E+00; H= 0.19110E-01; Order= 3 Time= 0.15604E+00; H= 0.19110E-01; Order= 3 Time= 0.17515E+00; H= 0.19110E-01; Order= 3 Time= 0.19426E+00; H= 0.19110E-01; Order= 3 Time= 0.21337E+00; H= 0.19110E-01; Order= 2 Time= 0.23248E+00; H= 0.19110E-01; Order= 2 Time= 0.25159E+00; H= 0.19110E-01; Order= 2 Time= 0.27070E+00; H= 0.19110E-01; Order= 2 Time= 0.30892E+00; H= 0.38221E-01; Order= 2 Time= 0.34714E+00; H= 0.38221E-01; Order= 2 Time= 0.38536E+00; H= 0.38221E-01; Order= 2 Time= 0.42358E+00; H= 0.38221E-01; Order= 2 Time= 0.50003E+00; H= 0.76441E-01; Order= 3 Time= 0.57647E+00; H= 0.76441E-01; Order= 3 Time= 0.65291E+00; H= 0.76441E-01; Order= 3 Time= 0.72935E+00; H= 0.76441E-01; Order= 3 Time= 0.80579E+00; H= 0.76441E-01; Order= 2 Time= 0.88223E+00; H= 0.76441E-01; Order= 2 Time= 0.95867E+00; H= 0.76441E-01; Order= 2 Time= 0.11116E+01; H= 0.15288E+00; Order= 2 Time= 0.12644E+01; H= 0.15288E+00; Order= 2 Time= 0.14173E+01; H= 0.15288E+00; Order= 2 Time= 0.15702E+01; H= 0.15288E+00; Order= 2 Time= 0.18760E+01; H= 0.30576E+00; Order= 3 Time= 0.21817E+01; H= 0.30576E+00; Order= 2 Time= 0.24875E+01; H= 0.30576E+00; Order= 1 Time= 0.27933E+01; H= 0.30576E+00; Order= 1 Time= 0.34048E+01; H= 0.61153E+00; Order= 1 C C####################################################################### C C RESCYL : RESULT file from single precision version C for the second example problem C C####################################################################### C Reaction-diffusion prob. in cyl. coord.; pars: 1.00000 0.00010 1.00000 0.10000 MoL, PDE+D&D int.face; DAE int.: DASSL; ID:ACM-TOMS, Ex.I NPTS= 21; RTOL=.100E-02, ATOL=.100E-02 TAU=.000E+00, KAPPA=.200E+01, ALPHA=.100E-01 -T= 0.00000E+00 X(S,TN): 0.00000000000000E+00 0.50000000000000E-01 0.10000000000000E+00 0.15000000000000E+00 0.20000000000000E+00 0.25000000000000E+00 0.30000000000000E+00 0.35000000000000E+00 0.40000000000000E+00 0.45000000000000E+00 0.50000000000000E+00 0.55000000000000E+00 0.60000000000000E+00 0.65000000000000E+00 0.70000000000000E+00 0.75000000000000E+00 0.80000000000000E+00 0.85000000000000E+00 0.90000000000000E+00 0.95000000000000E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP:1 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 -T= 0.10000E+00 X(S,TN): 0.17639148112380E-13 0.14518591720821E+00 0.28623494020569E+00 0.41908322853390E+00 0.53995112401876E+00 0.64574669552204E+00 0.73456039093228E+00 0.80600852725463E+00 0.86120333572151E+00 0.90233799155354E+00 0.93209672542039E+00 0.95314513173228E+00 0.96780024888720E+00 0.97792439515230E+00 0.98491408768422E+00 0.98976154174569E+00 0.99315738692336E+00 0.99558121156001E+00 0.99737371803429E+00 0.99878320185078E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP:1 0.10541348790610E+00 0.10543381958359E+00 0.10542847038094E+00 0.10542698561245E+00 0.10541941978923E+00 0.10539932404643E+00 0.10534688430917E+00 0.10522617224345E+00 0.10497842123410E+00 0.10451684160996E+00 0.10371988734721E+00 0.10243217794020E+00 0.10051941919686E+00 0.97874678559643E-01 0.94308534012330E-01 0.89498381115413E-01 0.82617079787539E-01 0.71960844347622E-01 0.55520642130282E-01 0.32050097751653E-01 0.00000000000000E+00 Statistics: FNS, JACS:71, 14 STEPS, ETF, CTF:34, 1, 0 -T= 0.20000E+00 X(S,TN): 0.20148591518961E-13 0.18674340180469E+00 0.36161731116823E+00 0.51532438837841E+00 0.64273542221454E+00 0.74303051546301E+00 0.81863893632480E+00 0.87370917883180E+00 0.91278857212731E+00 0.94000368973643E+00 0.95871221473832E+00 0.97147405730986E+00 0.98015664892324E+00 0.98607530283489E+00 0.99014066752644E+00 0.99298520768168E+00 0.99504836858055E+00 0.99662402836551E+00 0.99789913025558E+00 0.99899465059233E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP:1 0.22303662617181E+00 0.22309304027603E+00 0.22307433305738E+00 0.22305843255700E+00 0.22301924865414E+00 0.22293473648429E+00 0.22275310329416E+00 0.22239755183779E+00 0.22175950703551E+00 0.22069641796987E+00 0.21903533515918E+00 0.21658489570770E+00 0.21305474068454E+00 0.20760619886524E+00 0.19806933569841E+00 0.18136162840480E+00 0.15640109612775E+00 0.12479284080450E+00 0.88216927894771E-01 0.47050672011424E-01 0.00000000000000E+00 Statistics: FNS, JACS:80, 15 STEPS, ETF, CTF:40, 1, 0 -T= 0.30000E+00 X(S,TN): 0.53661140544489E-13 0.20596987672642E+00 0.39457337922663E+00 0.55404366042406E+00 0.68026638445410E+00 0.77520770909444E+00 0.84399862769418E+00 0.89253997394126E+00 0.92617272732337E+00 0.94919191822873E+00 0.96482593746435E+00 0.97540703067471E+00 0.98257233151908E+00 0.98745437274742E+00 0.99084192915820E+00 0.99328247630039E+00 0.99513367305359E+00 0.99661547342145E+00 0.99786366560713E+00 0.99896844131509E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP:1 0.35555856393790E+00 0.35564179498772E+00 0.35561290333202E+00 0.35558216590891E+00 0.35551283442850E+00 0.35537111488340E+00 0.35508524839620E+00 0.35455436764313E+00 0.35364048125503E+00 0.35216510754008E+00 0.34989533767351E+00 0.34641973140339E+00 0.34044163235663E+00 0.32826224149205E+00 0.30487105733613E+00 0.26953320481898E+00 0.22564359591173E+00 0.17619233914351E+00 0.12247986317158E+00 0.64325923644970E-01 0.00000000000000E+00 Statistics: FNS, JACS:88, 16 STEPS, ETF, CTF:43, 1, 0 -T= 0.40000E+00 X(S,TN): 0.46828264956288E-13 0.21713138426698E+00 0.41308519312985E+00 0.57485266622599E+00 0.69952364253330E+00 0.79102371564955E+00 0.85599655379241E+00 0.90113656859135E+00 0.93205310200147E+00 0.95303866124057E+00 0.96721478928629E+00 0.97677836965145E+00 0.98324993850289E+00 0.98768568982783E+00 0.99082228899445E+00 0.99314935067457E+00 0.99496964590112E+00 0.99646616424957E+00 0.99775359126552E+00 0.99891044855880E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP:1 0.50696401125843E+00 0.50710652721560E+00 0.50705877632246E+00 0.50699933199617E+00 0.50688770090103E+00 0.50667977952298E+00 0.50628448935737E+00 0.50557685210792E+00 0.50439029727777E+00 0.50250323286334E+00 0.49954347494264E+00 0.49438836707380E+00 0.48309753422479E+00 0.45826240765102E+00 0.41653890291630E+00 0.36194743277390E+00 0.29941381028357E+00 0.23177460801213E+00 0.15995654915335E+00 0.83410646792825E-01 0.00000000000000E+00 Statistics: FNS, JACS:92, 16 STEPS, ETF, CTF:46, 1, 0 -T= 0.50000E+00 X(S,TN): 0.40235442704946E-13 0.22455567004220E+00 0.42509797066697E+00 0.58791547997105E+00 0.71119366706334E+00 0.80028631885819E+00 0.86279267828944E+00 0.90583768172143E+00 0.93513171670697E+00 0.95492538616216E+00 0.96825745122155E+00 0.97723861568980E+00 0.98332548194889E+00 0.98753804036679E+00 0.99057496690401E+00 0.99288156839457E+00 0.99472620632395E+00 0.99627079519095E+00 0.99761843803344E+00 0.99884154065797E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP:1 0.68251799340384E+00 0.68285017206474E+00 0.68275190528803E+00 0.68261318517223E+00 0.68240496603779E+00 0.68207759388020E+00 0.68151970244396E+00 0.68057848929921E+00 0.67905606584379E+00 0.67666875194884E+00 0.67273603469895E+00 0.66454508603979E+00 0.64400721976741E+00 0.60204511243175E+00 0.53992249003457E+00 0.46476299302818E+00 0.38198113027309E+00 0.29423570618217E+00 0.20218521673193E+00 0.10496198255497E+00 0.00000000000000E+00 Statistics: FNS, JACS:97, 17 STEPS, ETF, CTF:48, 1, 0 -T= 0.60000E+00 X(S,TN): 0.34921448494076E-13 0.22981439531097E+00 0.43346055130872E+00 0.59680570662002E+00 0.71893789946941E+00 0.80625675496545E+00 0.86701301185096E+00 0.90860671815138E+00 0.93680826662235E+00 0.95582461227373E+00 0.96861832147465E+00 0.97723715723382E+00 0.98309967448576E+00 0.98720152062877E+00 0.99021283166830E+00 0.99254432472928E+00 0.99444027065991E+00 0.99604950748049E+00 0.99746839647591E+00 0.99876586731933E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP:1 0.88960252996354E+00 0.88999280132192E+00 0.88987395954277E+00 0.88968476961142E+00 0.88940790618994E+00 0.88898096654283E+00 0.88826891352185E+00 0.88708760048559E+00 0.88519170173226E+00 0.88216156906403E+00 0.87661606889136E+00 0.86287741230203E+00 0.82815828170659E+00 0.76514531515533E+00 0.68019050045773E+00 0.58211293088298E+00 0.47650032477986E+00 0.36587357891849E+00 0.25067036034383E+00 0.12971934592329E+00 0.00000000000000E+00 Statistics: FNS, JACS:99, 17 STEPS, ETF, CTF:50, 1, 0 -T= 0.70000E+00 X(S,TN): 0.39581058538728E-13 0.23377905361721E+00 0.43967186810861E+00 0.60328029580792E+00 0.72445454104991E+00 0.81040079391770E+00 0.86983970276644E+00 0.91035607986792E+00 0.93774942912838E+00 0.95618759355780E+00 0.96858195358542E+00 0.97693769342118E+00 0.98265523524132E+00 0.98671713234524E+00 0.98975044632721E+00 0.99213740355916E+00 0.99410577335986E+00 0.99579544804295E+00 0.99729814093372E+00 0.99868058138925E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP:1 0.11405410367218E+01 0.11409879181167E+01 0.11408486427610E+01 0.11405938278885E+01 0.11402253729408E+01 0.11396651889401E+01 0.11387476237349E+01 0.11372454294993E+01 0.11348389554149E+01 0.11308433409514E+01 0.11225206803137E+01 0.10998127682288E+01 0.10462626728674E+01 0.95835064038583E+00 0.84668338522179E+00 0.72153621317234E+00 0.58878963322130E+00 0.45092145719213E+00 0.30818413233869E+00 0.15907043748619E+00 0.00000000000000E+00 Statistics: FNS, JACS:102, 17 STEPS, ETF, CTF:53, 1, 0 -T= 0.80000E+00 X(S,TN): 0.37954569523527E-13 0.23687844733439E+00 0.44446898274482E+00 0.60820018939986E+00 0.72856993752118E+00 0.81342756023689E+00 0.87184797249918E+00 0.91154257347161E+00 0.93832208815600E+00 0.95632472656709E+00 0.96842106795060E+00 0.97659284180957E+00 0.98222153825977E+00 0.98625636877570E+00 0.98931197841330E+00 0.99174981122935E+00 0.99378501575304E+00 0.99555008203255E+00 0.99713268566197E+00 0.99859734992527E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP:1 0.14552451152882E+01 0.14557792622974E+01 0.14556099550085E+01 0.14552524126281E+01 0.14547403822998E+01 0.14539769354975E+01 0.14527543759338E+01 0.14507815423442E+01 0.14476047573307E+01 0.14420032892952E+01 0.14287290500702E+01 0.13914372555694E+01 0.13111127078253E+01 0.11907322842023E+01 0.10453858234411E+01 0.88684252484787E+00 0.72121918233434E+00 0.55080997935232E+00 0.37550634732565E+00 0.19331669648157E+00 0.00000000000000E+00 Statistics: FNS, JACS:107, 17 STEPS, ETF, CTF:55, 1, 0 -T= 0.90000E+00 X(S,TN): 0.47004986274091E-13 0.23938161877579E+00 0.44826364294621E+00 0.61195878884688E+00 0.73154602184655E+00 0.81542300544926E+00 0.87295424776024E+00 0.91194368711058E+00 0.93820195338006E+00 0.95583979314809E+00 0.96769734821645E+00 0.97572783224168E+00 0.98132261250638E+00 0.98543524699746E+00 0.98860502588807E+00 0.99116537947456E+00 0.99332334416035E+00 0.99520850016990E+00 0.99690765758174E+00 0.99848576494487E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP:1 0.18699204923934E+01 0.18704670015640E+01 0.18702963036556E+01 0.18698193959790E+01 0.18691087247082E+01 0.18680405971782E+01 0.18663435879801E+01 0.18636221340725E+01 0.18591754243072E+01 0.18507388165997E+01 0.18289784636922E+01 0.17703324307399E+01 0.16558224901983E+01 0.14935810549739E+01 0.13037290227298E+01 0.11008273301685E+01 0.89171884784704E+00 0.67870517463195E+00 0.46132327789948E+00 0.23687936558172E+00 0.00000000000000E+00 Statistics: FNS, JACS:115, 18 STEPS, ETF, CTF:57, 1, 0 -T= 0.10000E+01 X(S,TN): 0.45801647286645E-13 0.24147668399788E+00 0.45139715052561E+00 0.61499570378881E+00 0.73386821331645E+00 0.81688088048752E+00 0.87363738806035E+00 0.91201890854393E+00 0.93783685860958E+00 0.95517539904788E+00 0.96684642682713E+00 0.97479298625964E+00 0.98038079875103E+00 0.98452195512474E+00 0.98776520396021E+00 0.99043419357391E+00 0.99272230921026E+00 0.99475033009665E+00 0.99659953020852E+00 0.99833113953327E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP:1 0.24595012097713E+01 0.24600911156977E+01 0.24598879793067E+01 0.24591931750024E+01 0.24581205619298E+01 0.24564996299339E+01 0.24539415830210E+01 0.24498486518006E+01 0.24430018339040E+01 0.24290830349629E+01 0.23920605128629E+01 0.22990009497997E+01 0.21327889917527E+01 0.19119343062940E+01 0.16620837886650E+01 0.13994675928117E+01 0.11313861319206E+01 0.85984062228872E+00 0.58369866513344E+00 0.29933711963228E+00 0.00000000000000E+00 Statistics: FNS, JACS:123, 18 STEPS, ETF, CTF:60, 1, 0 C C####################################################################### C C RUNCYL : RUNINF file from single precision version C for the second example problem C C####################################################################### C Reaction-diffusion prob. in cyl. coord.; pars: 1.00000 0.00010 1.00000 0.10000 MoL, PDE+D&D int.face; DAE int.: DASSL; ID:ACM-TOMS, Ex.I NPTS= 21; RTOL=.100E-02, ATOL=.100E-02 TAU=.000E+00, KAPPA=.200E+01, ALPHA=.100E-01 Time= 0.20000E-03; H= 0.10000E-03; Order= 1 Time= 0.40000E-03; H= 0.20000E-03; Order= 2 Time= 0.80000E-03; H= 0.40000E-03; Order= 1 Time= 0.16000E-02; H= 0.80000E-03; Order= 1 Time= 0.32000E-02; H= 0.16000E-02; Order= 1 Time= 0.48000E-02; H= 0.16000E-02; Order= 1 Time= 0.64000E-02; H= 0.16000E-02; Order= 1 Time= 0.96000E-02; H= 0.32000E-02; Order= 2 Time= 0.12480E-01; H= 0.28800E-02; Order= 2 Time= 0.15360E-01; H= 0.28800E-02; Order= 2 Time= 0.18240E-01; H= 0.28800E-02; Order= 2 Time= 0.21120E-01; H= 0.28800E-02; Order= 2 Time= 0.24000E-01; H= 0.28800E-02; Order= 1 Time= 0.26410E-01; H= 0.24103E-02; Order= 1 Time= 0.28821E-01; H= 0.24103E-02; Order= 1 Time= 0.31231E-01; H= 0.24103E-02; Order= 1 Time= 0.33641E-01; H= 0.24103E-02; Order= 1 Time= 0.35810E-01; H= 0.21693E-02; Order= 1 Time= 0.37586E-01; H= 0.17755E-02; Order= 1 Time= 0.39361E-01; H= 0.17755E-02; Order= 1 Time= 0.41137E-01; H= 0.17755E-02; Order= 1 Time= 0.44688E-01; H= 0.35509E-02; Order= 1 Time= 0.48239E-01; H= 0.35509E-02; Order= 1 Time= 0.51790E-01; H= 0.35509E-02; Order= 1 Time= 0.55341E-01; H= 0.35509E-02; Order= 2 Time= 0.58892E-01; H= 0.35509E-02; Order= 2 Time= 0.65993E-01; H= 0.71019E-02; Order= 2 Time= 0.73095E-01; H= 0.71019E-02; Order= 2 Time= 0.80197E-01; H= 0.71019E-02; Order= 2 Time= 0.87299E-01; H= 0.71019E-02; Order= 2 Time= 0.91368E-01; H= 0.40692E-02; Order= 1 Time= 0.95031E-01; H= 0.36623E-02; Order= 1 Time= 0.98693E-01; H= 0.36623E-02; Order= 1 Time= 0.10602E+00; H= 0.73246E-02; Order= 1 Time= 0.11334E+00; H= 0.73246E-02; Order= 1 Time= 0.12067E+00; H= 0.73246E-02; Order= 1 Time= 0.13532E+00; H= 0.14649E-01; Order= 2 Time= 0.14997E+00; H= 0.14649E-01; Order= 2 Time= 0.17926E+00; H= 0.29299E-01; Order= 2 Time= 0.20363E+00; H= 0.24371E-01; Order= 2 Time= 0.22801E+00; H= 0.24371E-01; Order= 2 Time= 0.25238E+00; H= 0.24371E-01; Order= 2 Time= 0.30112E+00; H= 0.48741E-01; Order= 2 Time= 0.34498E+00; H= 0.43867E-01; Order= 2 Time= 0.38885E+00; H= 0.43867E-01; Order= 2 Time= 0.43272E+00; H= 0.43867E-01; Order= 2 Time= 0.47659E+00; H= 0.43867E-01; Order= 2 Time= 0.52045E+00; H= 0.43867E-01; Order= 3 Time= 0.56432E+00; H= 0.43867E-01; Order= 3 Time= 0.60819E+00; H= 0.43867E-01; Order= 3 Time= 0.65205E+00; H= 0.43867E-01; Order= 3 Time= 0.69592E+00; H= 0.43867E-01; Order= 3 Time= 0.73979E+00; H= 0.43867E-01; Order= 3 Time= 0.78365E+00; H= 0.43867E-01; Order= 4 Time= 0.82752E+00; H= 0.43867E-01; Order= 4 Time= 0.87139E+00; H= 0.43867E-01; Order= 3 Time= 0.91526E+00; H= 0.43867E-01; Order= 3 Time= 0.95912E+00; H= 0.43867E-01; Order= 3 Time= 0.99734E+00; H= 0.38219E-01; Order= 3 C C####################################################################### C C RESDSH : RESULT file from single precision version !!! TAU = 1E-3 !!! C for the third example problem !!! in driver !!! C C####################################################################### C Burgers, double wave, eps=0.00100 MoL, PDE+D&D int.face; DAE int.: DASSL; ID:ACM-TOMS, Ex.I NPTS= 21; RTOL=.100E-02, ATOL=.100E-02 TAU=.100E-02, KAPPA=.200E+01, ALPHA=.100E-01 -T= 0.00000E+00 X(S,TN): 0.00000000000000E+00 0.50000000000000E-01 0.10000000000000E+00 0.15000000000000E+00 0.20000000000000E+00 0.25000000000000E+00 0.30000000000000E+00 0.35000000000000E+00 0.40000000000000E+00 0.45000000000000E+00 0.50000000000000E+00 0.55000000000000E+00 0.60000000000000E+00 0.65000000000000E+00 0.70000000000000E+00 0.75000000000000E+00 0.80000000000000E+00 0.85000000000000E+00 0.90000000000000E+00 0.95000000000000E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP:1 0.10000000000000E+01 0.10000000000000E+01 0.10000000000000E+01 0.99999999999306E+00 0.99999813668036E+00 0.75000000000000E+00 0.50000186331964E+00 0.50000000000691E+00 0.49999999917554E+00 0.49998184085253E+00 0.30000000000008E+00 0.10001815914748E+00 0.10000000082447E+00 0.10000000000003E+00 0.10000000000001E+00 0.10000000000000E+00 0.10000000000000E+00 0.10000000000000E+00 0.10000000000000E+00 0.10000000000000E+00 0.10000000000000E+00 ERR_U: 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 MAX. NORM:0. TWO NORM:0. -T= 0.25000E+00 X(S,TN): -0.37891601176756E-15 0.10848055509164E+00 0.20332174224602E+00 0.27818788926894E+00 0.33366992698232E+00 0.37291449236776E+00 0.40083269943473E+00 0.42007773647351E+00 0.43538172016705E+00 0.45161440303086E+00 0.47211390316070E+00 0.49609018968139E+00 0.52169029066663E+00 0.54552369889280E+00 0.56985721764227E+00 0.60028585176896E+00 0.64240073633294E+00 0.70136740651490E+00 0.78157681490121E+00 0.88350477445082E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP:1 0.10000000000000E+01 0.99716090200240E+00 0.10053914380846E+01 0.99398224508314E+00 0.99342161276444E+00 0.10192371570112E+01 0.10241375073556E+01 0.91800355662522E+00 0.70721621975003E+00 0.55195732913796E+00 0.52757264468458E+00 0.55692444902700E+00 0.54507000553550E+00 0.41902703094050E+00 0.24891573805615E+00 0.15397698065475E+00 0.12084620954434E+00 0.10668399852427E+00 0.10148885109538E+00 0.10021053851896E+00 0.10000000000000E+00 ERR_U: 0.00000000000000E+00 -0.28390979976081E-02 0.53914380846081E-02 -0.60177549168685E-02 -0.65783872328993E-02 0.19237205616918E-01 0.24189725696601E-01 -0.75660183208942E-01 -0.10747518323472E+00 0.37702670997412E-01 0.27485400773003E-01 0.56924287427126E-01 0.45079372751633E-01 -0.79875007156359E-01 -0.14573863875942E+00 0.51447659838765E-01 0.20845650165781E-01 0.66839985200429E-02 0.14888510953797E-02 0.21053851895525E-03 -0.57731597280508E-14 MAX. NORM:0.1457386387594 TWO NORM:3.6673013640631E-2 Statistics: FNS, JACS:122, 25 STEPS, ETF, CTF:54, 2, 0 -T= 0.55000E+00 X(S,TN): -0.27790329873557E-15 0.16055128031105E+00 0.30094085435990E+00 0.41131262906257E+00 0.49221934507321E+00 0.54917312062871E+00 0.58840106248221E+00 0.61518844446592E+00 0.63348452026696E+00 0.64623977482739E+00 0.65504882834307E+00 0.66207961766384E+00 0.66932004779528E+00 0.67862290146947E+00 0.69196938700943E+00 0.71174600462994E+00 0.74073205670176E+00 0.78232068363145E+00 0.83987666567841E+00 0.91417604522829E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP:1 0.10000000000000E+01 0.99404747348641E+00 0.99946722007484E+00 0.10044685471444E+01 0.99915580428724E+00 0.99347717408065E+00 0.98419486010519E+00 0.99821262941603E+00 0.10343658159498E+01 0.10197795330447E+01 0.85462754390147E+00 0.55618180739419E+00 0.28636978345933E+00 0.14920826026947E+00 0.10792619259334E+00 0.10886929643692E+00 0.10812607952673E+00 0.10260598194636E+00 0.10090699464095E+00 0.10023516467595E+00 0.10000000000000E+00 ERR_U: 0.00000000000000E+00 -0.59525265135889E-02 -0.53277992516598E-03 0.44685471444339E-02 -0.84419571276584E-03 -0.65228259191130E-02 -0.15805135388920E-01 -0.17837212230880E-02 0.34720445840037E-01 0.28568673809389E-01 -0.63165151554877E-01 -0.68370543165546E-01 0.27808787742817E-01 0.23637133557707E-01 0.61141218951626E-02 0.88344851387885E-02 0.81259738311004E-02 0.26059819205542E-02 0.90699464095145E-03 0.23516467594931E-03 0.00000000000000E+00 MAX. NORM:6.8370543165546E-2 TWO NORM:1.1319532422608E-2 Statistics: FNS, JACS:183, 35 STEPS, ETF, CTF:77, 3, 0 -T= 0.10000E+01 X(S,TN): -0.58445754991170E-15 0.21706569079431E+00 0.40780040570791E+00 0.55894047714684E+00 0.67056722424815E+00 0.74955212777111E+00 0.80409863830369E+00 0.84125722184744E+00 0.86641102981316E+00 0.88337104837509E+00 0.89477422199390E+00 0.90242422560976E+00 0.90755227028564E+00 0.91150486084567E+00 0.91550801896004E+00 0.92077445074001E+00 0.92854361287370E+00 0.93980818553739E+00 0.95555600033186E+00 0.97609859264019E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP:1 0.99999999999999E+00 0.99915167486587E+00 0.99407749143252E+00 0.99698475698242E+00 0.99847110322787E+00 0.10013005332587E+01 0.10042199615836E+01 0.99925106158264E+00 0.10035485428128E+01 0.10001426793997E+01 0.10025714765328E+01 0.10012085019586E+01 0.85186413971121E+00 0.54287600370401E+00 0.24225328706092E+00 0.10800863019187E+00 0.10040224796535E+00 0.10039561113376E+00 0.10035992330620E+00 0.10017137784193E+00 0.10000000000000E+00 ERR_U: -0.71054273576010E-14 -0.84832513412891E-03 -0.59225085674797E-02 -0.30152430175789E-02 -0.15288967721290E-02 0.13005332586502E-02 0.42199615836367E-02 -0.74893841734891E-03 0.35485444662910E-02 0.14609078360905E-03 0.31485147989585E-02 0.18906229345177E-01 0.28617238632087E-02 0.32639187076953E-01 0.32932764414708E-01 -0.34764476103528E-02 0.49719108810020E-04 0.39339344797318E-03 0.35992145152353E-03 0.17137784174270E-03 0.00000000000000E+00 MAX. NORM:3.2932764414708E-2 TWO NORM:4.5316570225481E-3 Statistics: FNS, JACS:291, 64 STEPS, ETF, CTF:120, 10, 4 C C####################################################################### C C RUNDSH : RUNINF file from single precision version !!! TAU = 1E-3 !!! C for the third example problem !!! in driver !!! C C####################################################################### C Burgers, double wave, eps=0.00100 MoL, PDE+D&D int.face; DAE int.: DASSL; ID:ACM-TOMS, Ex.I NPTS= 21; RTOL=.100E-02, ATOL=.100E-02 TAU=.100E-02, KAPPA=.200E+01, ALPHA=.100E-01 Time= 0.65287E-05; H= 0.32643E-05; Order= 1 Time= 0.13057E-04; H= 0.65287E-05; Order= 2 Time= 0.26115E-04; H= 0.13057E-04; Order= 1 Time= 0.52229E-04; H= 0.26115E-04; Order= 1 Time= 0.78344E-04; H= 0.26115E-04; Order= 1 Time= 0.13057E-03; H= 0.52229E-04; Order= 1 Time= 0.17717E-03; H= 0.46598E-04; Order= 1 Time= 0.22377E-03; H= 0.46598E-04; Order= 1 Time= 0.27037E-03; H= 0.46598E-04; Order= 1 Time= 0.31696E-03; H= 0.46598E-04; Order= 1 Time= 0.36356E-03; H= 0.46598E-04; Order= 1 Time= 0.40310E-03; H= 0.39538E-04; Order= 1 Time= 0.44264E-03; H= 0.39538E-04; Order= 1 Time= 0.48218E-03; H= 0.39538E-04; Order= 1 Time= 0.56125E-03; H= 0.79076E-04; Order= 2 Time= 0.64033E-03; H= 0.79076E-04; Order= 2 Time= 0.79848E-03; H= 0.15815E-03; Order= 2 Time= 0.93806E-03; H= 0.13958E-03; Order= 2 Time= 0.10776E-02; H= 0.13958E-03; Order= 2 Time= 0.12172E-02; H= 0.13958E-03; Order= 2 Time= 0.13303E-02; H= 0.11307E-03; Order= 2 Time= 0.14320E-02; H= 0.10176E-03; Order= 2 Time= 0.15338E-02; H= 0.10176E-03; Order= 2 Time= 0.16356E-02; H= 0.10176E-03; Order= 2 Time= 0.17373E-02; H= 0.10176E-03; Order= 1 Time= 0.18391E-02; H= 0.10176E-03; Order= 1 Time= 0.20426E-02; H= 0.20352E-03; Order= 1 Time= 0.22461E-02; H= 0.20352E-03; Order= 1 Time= 0.24497E-02; H= 0.20352E-03; Order= 1 Time= 0.28567E-02; H= 0.40704E-03; Order= 2 Time= 0.32637E-02; H= 0.40704E-03; Order= 2 Time= 0.39268E-02; H= 0.66305E-03; Order= 1 Time= 0.45145E-02; H= 0.58773E-03; Order= 1 Time= 0.56900E-02; H= 0.11755E-02; Order= 1 Time= 0.68654E-02; H= 0.11755E-02; Order= 1 Time= 0.92164E-02; H= 0.23509E-02; Order= 1 Time= 0.11567E-01; H= 0.23509E-02; Order= 1 Time= 0.16269E-01; H= 0.47018E-02; Order= 1 Time= 0.25673E-01; H= 0.94037E-02; Order= 1 Time= 0.35076E-01; H= 0.94037E-02; Order= 1 Time= 0.44480E-01; H= 0.94037E-02; Order= 1 Time= 0.63287E-01; H= 0.18807E-01; Order= 1 Time= 0.80214E-01; H= 0.16927E-01; Order= 1 Time= 0.95352E-01; H= 0.15138E-01; Order= 1 Time= 0.11049E+00; H= 0.15138E-01; Order= 1 Time= 0.12563E+00; H= 0.15138E-01; Order= 1 Time= 0.13973E+00; H= 0.14103E-01; Order= 1 Time= 0.15110E+00; H= 0.11366E-01; Order= 1 Time= 0.16246E+00; H= 0.11366E-01; Order= 1 Time= 0.17383E+00; H= 0.11366E-01; Order= 1 Time= 0.18519E+00; H= 0.11366E-01; Order= 1 Time= 0.20792E+00; H= 0.22732E-01; Order= 2 Time= 0.23066E+00; H= 0.22732E-01; Order= 1 Time= 0.25339E+00; H= 0.22732E-01; Order= 1 Time= 0.26519E+00; H= 0.11805E-01; Order= 1 Time= 0.27452E+00; H= 0.93318E-02; Order= 1 Time= 0.28386E+00; H= 0.93318E-02; Order= 1 Time= 0.29319E+00; H= 0.93318E-02; Order= 1 Time= 0.30252E+00; H= 0.93318E-02; Order= 2 Time= 0.31185E+00; H= 0.93318E-02; Order= 2 Time= 0.32118E+00; H= 0.93318E-02; Order= 1 Time= 0.33985E+00; H= 0.18664E-01; Order= 1 Time= 0.35851E+00; H= 0.18664E-01; Order= 1 Time= 0.37405E+00; H= 0.15540E-01; Order= 1 Time= 0.38959E+00; H= 0.15540E-01; Order= 1 Time= 0.40513E+00; H= 0.15540E-01; Order= 1 Time= 0.41912E+00; H= 0.13986E-01; Order= 1 Time= 0.43310E+00; H= 0.13986E-01; Order= 1 Time= 0.44709E+00; H= 0.13986E-01; Order= 1 Time= 0.46107E+00; H= 0.13986E-01; Order= 2 Time= 0.47506E+00; H= 0.13986E-01; Order= 2 Time= 0.48905E+00; H= 0.13986E-01; Order= 2 Time= 0.50303E+00; H= 0.13986E-01; Order= 2 Time= 0.51702E+00; H= 0.13986E-01; Order= 3 Time= 0.53100E+00; H= 0.13986E-01; Order= 3 Time= 0.54499E+00; H= 0.13986E-01; Order= 2 Time= 0.55758E+00; H= 0.12587E-01; Order= 2 Time= 0.57017E+00; H= 0.12587E-01; Order= 2 Time= 0.58082E+00; H= 0.10654E-01; Order= 2 Time= 0.59147E+00; H= 0.10654E-01; Order= 2 Time= 0.60213E+00; H= 0.10654E-01; Order= 2 Time= 0.61732E+00; H= 0.15190E-01; Order= 2 Time= 0.62745E+00; H= 0.10137E-01; Order= 1 Time= 0.63658E+00; H= 0.91232E-02; Order= 1 Time= 0.64570E+00; H= 0.91232E-02; Order= 1 Time= 0.65482E+00; H= 0.91232E-02; Order= 1 Time= 0.66395E+00; H= 0.91232E-02; Order= 1 Time= 0.68219E+00; H= 0.18246E-01; Order= 2 Time= 0.70044E+00; H= 0.18246E-01; Order= 2 Time= 0.71869E+00; H= 0.18246E-01; Order= 2 Time= 0.71966E+00; H= 0.97011E-03; Order= 2 Time= 0.72160E+00; H= 0.19402E-02; Order= 2 Time= 0.72257E+00; H= 0.97011E-03; Order= 2 Time= 0.72451E+00; H= 0.19402E-02; Order= 2 Time= 0.72839E+00; H= 0.38804E-02; Order= 1 Time= 0.73615E+00; H= 0.77609E-02; Order= 1 Time= 0.74391E+00; H= 0.77609E-02; Order= 1 Time= 0.75943E+00; H= 0.15522E-01; Order= 1 Time= 0.77495E+00; H= 0.15522E-01; Order= 1 Time= 0.79047E+00; H= 0.15522E-01; Order= 1 Time= 0.82152E+00; H= 0.31043E-01; Order= 1 Time= 0.83966E+00; H= 0.18145E-01; Order= 1 Time= 0.85781E+00; H= 0.18145E-01; Order= 1 Time= 0.87595E+00; H= 0.18145E-01; Order= 1 Time= 0.89410E+00; H= 0.18145E-01; Order= 2 Time= 0.91224E+00; H= 0.18145E-01; Order= 2 Time= 0.93039E+00; H= 0.18145E-01; Order= 2 Time= 0.94853E+00; H= 0.18145E-01; Order= 2 Time= 0.96668E+00; H= 0.18145E-01; Order= 2 Time= 0.96693E+00; H= 0.25517E-03; Order= 1 Time= 0.96714E+00; H= 0.20321E-03; Order= 1 Time= 0.96732E+00; H= 0.18289E-03; Order= 1 Time= 0.96750E+00; H= 0.18289E-03; Order= 1 Time= 0.96787E+00; H= 0.36577E-03; Order= 1 Time= 0.96860E+00; H= 0.73154E-03; Order= 1 Time= 0.97006E+00; H= 0.14631E-02; Order= 1 Time= 0.97299E+00; H= 0.29262E-02; Order= 1 Time= 0.97884E+00; H= 0.58524E-02; Order= 1 Time= 0.99055E+00; H= 0.11705E-01; Order= 1 C C####################################################################### C C RESBAK : RESULT file from double precision version C for the first example problem C C####################################################################### C Bakker, Electrodynamics problem; EPS=0.143, P=0.1743, ETA=17.19 MoL, PDE+D&D int.face; DAE int.: DASSL; ID:ACM-TOMS, Ex.I NPTS= 21; RTOL=.100E-02, ATOL=.100E-02 TAU=.000E+00, KAPPA=.200E+01, ALPHA=.100E-01 -T= 0.00000E+00 X(S,TN): 0.00000000000000E+00 0.50000000000000E-01 0.10000000000000E+00 0.15000000000000E+00 0.20000000000000E+00 0.25000000000000E+00 0.30000000000000E+00 0.35000000000000E+00 0.40000000000000E+00 0.45000000000000E+00 0.50000000000000E+00 0.55000000000000E+00 0.60000000000000E+00 0.65000000000000E+00 0.70000000000000E+00 0.75000000000000E+00 0.80000000000000E+00 0.85000000000000E+00 0.90000000000000E+00 0.95000000000000E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP: 1 0.10000000000000E+01 0.10000000000000E+01 0.10000000000000E+01 0.10000000000000E+01 0.10000000000000E+01 0.10000000000000E+01 0.10000000000000E+01 0.10000000000000E+01 0.10000000000000E+01 0.10000000000000E+01 0.10000000000000E+01 0.10000000000000E+01 0.10000000000000E+01 0.10000000000000E+01 0.10000000000000E+01 0.10000000000000E+01 0.10000000000000E+01 0.10000000000000E+01 0.10000000000000E+01 0.10000000000000E+01 0.10000000000000E+01 U(X(S,TN),TN), COMP: 2 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 -T= 0.10000E-03 X(S,TN): 0.12735266044843E-20 0.25040639326087E-01 0.56481180725208E-01 0.95013743451470E-01 0.14035700864980E+00 0.19172996726927E+00 0.24805285524386E+00 0.30815424596408E+00 0.37092072417169E+00 0.43536105277879E+00 0.50059964810099E+00 0.56582746220412E+00 0.63023450420058E+00 0.69294260070383E+00 0.75295708822915E+00 0.80916185063231E+00 0.86038575125554E+00 0.90555451801052E+00 0.94389834500290E+00 0.97514972171545E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP: 1 0.97256278198193E+00 0.97297329463441E+00 0.97347359749868E+00 0.97362279770200E+00 0.97365968616696E+00 0.97366795253582E+00 0.97366993754548E+00 0.97367061722011E+00 0.97367094665865E+00 0.97367111095284E+00 0.97367116090313E+00 0.97367110995316E+00 0.97367094676961E+00 0.97367066001102E+00 0.97367048642589E+00 0.97367279233329E+00 0.97369354245866E+00 0.97382236631722E+00 0.97451337030300E+00 0.97805479283087E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP: 2 -0.11133568923724E-18 0.21863837076523E-01 0.25474655266945E-01 0.26176978367779E-01 0.26306690020029E-01 0.26327294406898E-01 0.26329526685214E-01 0.26329338687379E-01 0.26329051471724E-01 0.26328889401451E-01 0.26328839463709E-01 0.26328890552885E-01 0.26329056710793E-01 0.26329390777144E-01 0.26330088349518E-01 0.26332151383376E-01 0.26340710275091E-01 0.26378419453056E-01 0.26528830914739E-01 0.27025637086854E-01 0.27429641093465E-01 Statistics: FNS, JACS: 25 9 STEPS, ETF, CTF: 14 0 0 -T= 0.10000E-02 X(S,TN): -0.31906882002238E-17 0.12035734678889E-01 0.27659167677363E-01 0.49865296342561E-01 0.81605227784395E-01 0.12602481635131E+00 0.18619274132530E+00 0.26401844342278E+00 0.35861206116750E+00 0.46490938763530E+00 0.57403998234074E+00 0.67610273839132E+00 0.76369508101800E+00 0.83368289032634E+00 0.88661995793678E+00 0.92509609767101E+00 0.95229372726289E+00 0.97117434284798E+00 0.98419344945419E+00 0.99327637429847E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP: 1 0.84124639823106E+00 0.85198010709681E+00 0.86417807430651E+00 0.86767855422229E+00 0.86870605012885E+00 0.86901606864834E+00 0.86910499263221E+00 0.86912954072521E+00 0.86913888040758E+00 0.86914157449020E+00 0.86913640725412E+00 0.86912565320863E+00 0.86912013739702E+00 0.86915098091298E+00 0.86930686281480E+00 0.86979878730867E+00 0.87108032204927E+00 0.87416885665395E+00 0.88202796056816E+00 0.90698278831326E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP: 2 0.27362584056932E-16 0.85805318132295E-01 0.11962496086593E+00 0.12841936075473E+00 0.13028719332919E+00 0.13074916269906E+00 0.13085454149197E+00 0.13086675979615E+00 0.13086128491548E+00 0.13085860096827E+00 0.13086418658332E+00 0.13087854377689E+00 0.13090461599334E+00 0.13096181266530E+00 0.13110841054542E+00 0.13150474101938E+00 0.13256555854283E+00 0.13518001844746E+00 0.14028783863406E+00 0.14665930978927E+00 0.14940965033950E+00 Statistics: FNS, JACS: 61 13 STEPS, ETF, CTF: 33 0 0 -T= 0.10000E-01 X(S,TN): -0.34427396769781E-17 0.16258714721784E-01 0.34382803883098E-01 0.56834581624210E-01 0.87039190267673E-01 0.12957331395931E+00 0.18909073892025E+00 0.26896477224061E+00 0.36925991127282E+00 0.48381263002083E+00 0.60022732075013E+00 0.70517642808932E+00 0.79063665057306E+00 0.85527414673292E+00 0.90186196170236E+00 0.93448224216549E+00 0.95706725596805E+00 0.97276766629829E+00 0.98401678064684E+00 0.99265705857935E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP: 1 0.55402381033045E+00 0.58108980934503E+00 0.63225335776498E+00 0.66627482059999E+00 0.68085510330969E+00 0.68521135327001E+00 0.68607444631980E+00 0.68618620843153E+00 0.68620362725334E+00 0.68620857886650E+00 0.68620572666962E+00 0.68620187972406E+00 0.68622615390488E+00 0.68640891833359E+00 0.68722055551815E+00 0.68983205538279E+00 0.69843451101787E+00 0.72636209309199E+00 0.78483334969053E+00 0.87331834425110E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP: 2 0.95184531308424E-17 0.10434520528725E+00 0.18773166403372E+00 0.25316357939666E+00 0.29495931453764E+00 0.31083912490386E+00 0.31358223737728E+00 0.31379490184334E+00 0.31379630801653E+00 0.31379210106119E+00 0.31379642970886E+00 0.31381269708857E+00 0.31387647556126E+00 0.31432320353576E+00 0.31681119642406E+00 0.32390565438164E+00 0.33490067435648E+00 0.34648469633414E+00 0.35618582547805E+00 0.36293333411257E+00 0.36542672394796E+00 Statistics: FNS, JACS: 87 16 STEPS, ETF, CTF: 50 0 0 -T= 0.10000E+00 X(S,TN): -0.39301477256394E-17 0.27509404552255E-01 0.55993690934573E-01 0.86797140010640E-01 0.12184094937080E+00 0.16382419162279E+00 0.21643943774507E+00 0.28414071410633E+00 0.37020645489382E+00 0.47234803523237E+00 0.58046901407967E+00 0.68113067880431E+00 0.76478953875800E+00 0.82907672511573E+00 0.87662241250314E+00 0.91151512663199E+00 0.93755439912681E+00 0.95766078321055E+00 0.97387203296257E+00 0.98760826479254E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP: 1 0.21974581958237E+00 0.24082420330226E+00 0.29058154205529E+00 0.34867209330565E+00 0.40416761691641E+00 0.44973832739684E+00 0.48125563997830E+00 0.49908703254335E+00 0.50698579099418E+00 0.50962248204921E+00 0.51055295173930E+00 0.51203197391951E+00 0.51609497811219E+00 0.52517682893805E+00 0.54436737672286E+00 0.58048304001242E+00 0.63431439688620E+00 0.70289964811670E+00 0.78413725148810E+00 0.87974878778198E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP: 2 -0.13624965605258E-15 0.88797777761149E-01 0.16833568476902E+00 0.24183227584845E+00 0.31039173924030E+00 0.37292548234698E+00 0.42566520225675E+00 0.46296774306353E+00 0.48196688573240E+00 0.48823949841194E+00 0.49030549079910E+00 0.49378958448182E+00 0.50305423421003E+00 0.51960830875674E+00 0.54068701843747E+00 0.56194301928120E+00 0.58032835184249E+00 0.59478264507916E+00 0.60534717011268E+00 0.61217164379082E+00 0.61461846804860E+00 Statistics: FNS, JACS: 109 18 STEPS, ETF, CTF: 67 0 0 -T= 0.25000E+00 X(S,TN): -0.77394232436680E-17 0.35291221664463E-01 0.71018431022303E-01 0.10814716025685E+00 0.14806467131394E+00 0.19254335127895E+00 0.24383323005932E+00 0.30463544673108E+00 0.37745820613596E+00 0.46262697494835E+00 0.55547537960931E+00 0.64660274647643E+00 0.72720767170189E+00 0.79352487284645E+00 0.84616067038737E+00 0.88743094489920E+00 0.91981706317539E+00 0.94553072421687E+00 0.96644695048773E+00 0.98413120226406E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP: 1 0.10805705916213E+00 0.12867791899390E+00 0.17698900114014E+00 0.23411718404617E+00 0.29233050707449E+00 0.34784140635393E+00 0.39770957980354E+00 0.43884574066553E+00 0.46883323643915E+00 0.48788864682981E+00 0.50012027062367E+00 0.51181152842142E+00 0.52821211043232E+00 0.55126994712413E+00 0.58088175239822E+00 0.61789338302322E+00 0.66469197252236E+00 0.72340648718939E+00 0.79551786106221E+00 0.88411324464246E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP: 2 0.17469927481663E-15 0.74015539998398E-01 0.14091572536753E+00 0.20354613540268E+00 0.26322294010332E+00 0.32010381620710E+00 0.37315588660869E+00 0.41999812692253E+00 0.45728021060632E+00 0.48295040418049E+00 0.50002303997364E+00 0.51592897230737E+00 0.53662083545962E+00 0.56286218700354E+00 0.59169050558857E+00 0.61938043315802E+00 0.64316762431140E+00 0.66177186103287E+00 0.67509370824274E+00 0.68341973830992E+00 0.68632761812349E+00 Statistics: FNS, JACS: 117 19 STEPS, ETF, CTF: 74 0 0 -T= 0.50000E+00 X(S,TN): -0.10401087858425E-16 0.44439151133995E-01 0.88805088552306E-01 0.13391993683124E+00 0.18087852430772E+00 0.23083500485522E+00 0.28495787019539E+00 0.34430963703802E+00 0.40951501036849E+00 0.48017583876915E+00 0.55428244881976E+00 0.62829194501305E+00 0.69829213086099E+00 0.76140020008967E+00 0.81625721438405E+00 0.86267938943143E+00 0.90118650103872E+00 0.93275308192034E+00 0.95869690488395E+00 0.98054836694031E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP: 1 0.61705929604197E-01 0.83571879788228E-01 0.13215155188268E+00 0.18633487608590E+00 0.24042715340552E+00 0.29267601089896E+00 0.34206233746634E+00 0.38753974105531E+00 0.42811989595439E+00 0.46346853064190E+00 0.49467344670541E+00 0.52422258784898E+00 0.55451705126760E+00 0.58639623915570E+00 0.61954797764149E+00 0.65442536646998E+00 0.69380874783919E+00 0.74236196848809E+00 0.80489382030742E+00 0.88669437808147E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP: 2 0.65700895428383E-17 0.63742488280905E-01 0.12163930610606E+00 0.17672728262708E+00 0.22997916299074E+00 0.28151559410249E+00 0.33094504614227E+00 0.37748431817190E+00 0.42020724704906E+00 0.45860632934568E+00 0.49330139885287E+00 0.52612438718385E+00 0.55894431980083E+00 0.59231666089018E+00 0.62533815417105E+00 0.65630911076061E+00 0.68338644478598E+00 0.70513627431929E+00 0.72093123514864E+00 0.73076743644006E+00 0.73416693255123E+00 Statistics: FNS, JACS: 125 20 STEPS, ETF, CTF: 80 0 0 -T= 0.10000E+01 X(S,TN): -0.11406215963647E-16 0.54377770873218E-01 0.10808494545177E+00 0.16166526266715E+00 0.21573566831410E+00 0.27077928634383E+00 0.32712495869159E+00 0.38491610794514E+00 0.44407728911349E+00 0.50430112562059E+00 0.56502043001203E+00 0.62539812132548E+00 0.68439946357148E+00 0.74088106716049E+00 0.79366717370613E+00 0.84166550692797E+00 0.88402998991767E+00 0.92037820941479E+00 0.95100850159024E+00 0.97697226217635E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP: 1 0.41855949411223E-01 0.64374253575332E-01 0.11186576458892E+00 0.16204981001984E+00 0.21164684415231E+00 0.26020612617869E+00 0.30762787512131E+00 0.35384101391037E+00 0.39881029175374E+00 0.44257074787550E+00 0.48519358417400E+00 0.52670759824464E+00 0.56703195717810E+00 0.60593811685108E+00 0.64314510985640E+00 0.67890452838048E+00 0.71527252502504E+00 0.75721067809429E+00 0.81192651738417E+00 0.88782965096200E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP: 2 -0.44578590086900E-16 0.57131871581142E-01 0.10922405912238E+00 0.15955954423639E+00 0.20880633444811E+00 0.25712191626928E+00 0.30452064222066E+00 0.35096005997028E+00 0.39640086415878E+00 0.44081256300659E+00 0.48416065118635E+00 0.52638435236646E+00 0.56733422813828E+00 0.60668431532277E+00 0.64387209625146E+00 0.67806800042322E+00 0.70817483079002E+00 0.73294885035043E+00 0.75138158024705E+00 0.76298941454337E+00 0.76699670502140E+00 Statistics: FNS, JACS: 134 22 STEPS, ETF, CTF: 87 0 0 -T= 0.20000E+01 X(S,TN): -0.10453487080052E-16 0.60053286165933E-01 0.11903672452853E+00 0.17727603349834E+00 0.23511696218743E+00 0.29279152957340E+00 0.35043580843501E+00 0.40810222875161E+00 0.46575775109282E+00 0.52327762269772E+00 0.58042938272098E+00 0.63684447638083E+00 0.69199386223164E+00 0.74516459050855E+00 0.79546429961772E+00 0.84188923579970E+00 0.88349309414755E+00 0.91966686949829E+00 0.95044808153492E+00 0.97668378749828E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP: 1 0.35153327381863E-01 0.57866852450919E-01 0.10462818533458E+00 0.15300642904687E+00 0.20100812276954E+00 0.24855288696498E+00 0.29567825964121E+00 0.34238444016013E+00 0.38862220583891E+00 0.43429258712398E+00 0.47923390467058E+00 0.52319901522740E+00 0.56583658406214E+00 0.60670229517203E+00 0.64540345319058E+00 0.68213413695708E+00 0.71883592384255E+00 0.76036196145162E+00 0.81407466926679E+00 0.88880159770786E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP: 2 0.34573933836692E-18 0.54320861090747E-01 0.10405127525504E+00 0.15262123911497E+00 0.20056434916891E+00 0.24804134438884E+00 0.29511681793596E+00 0.34179520808725E+00 0.38802982418713E+00 0.43372024294874E+00 0.47869664080500E+00 0.52270547185292E+00 0.56538317938318E+00 0.60622870963442E+00 0.64459152942830E+00 0.67964657569350E+00 0.71036894935769E+00 0.73560354154483E+00 0.75438226804794E+00 0.76620785212957E+00 0.77028766323688E+00 Statistics: FNS, JACS: 141 23 STEPS, ETF, CTF: 92 0 0 -T= 0.30000E+01 X(S,TN): -0.13366324572080E-16 0.61545066361672E-01 0.12195026065175E+00 0.18151997567421E+00 0.24056085440098E+00 0.29926752772999E+00 0.35774350631857E+00 0.41601573874462E+00 0.47403668402769E+00 0.53167573923565E+00 0.58870129545288E+00 0.64475511493700E+00 0.69932370370229E+00 0.75171721125178E+00 0.80107729582830E+00 0.84644876003778E+00 0.88695339831125E+00 0.92206688860662E+00 0.95190593494043E+00 0.97735238369153E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP: 1 0.33958735600296E-01 0.56830009133886E-01 0.10362925772185E+00 0.15176446083203E+00 0.19952058657809E+00 0.24686678052552E+00 0.29384678387965E+00 0.34046030294035E+00 0.38665459035630E+00 0.43231821554821E+00 0.47726849921186E+00 0.52123390078984E+00 0.56383968835967E+00 0.60463098717535E+00 0.64324852363152E+00 0.68001330356171E+00 0.71707808141388E+00 0.75938811990011E+00 0.81403088224003E+00 0.88929996809431E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP: 2 0.32393540150085E-16 0.53908581777006E-01 0.10328104059902E+00 0.15158886646974E+00 0.19932382877629E+00 0.24663696648239E+00 0.29358884731443E+00 0.34018119462850E+00 0.38636165480727E+00 0.43201871410969E+00 0.47696905690635E+00 0.52093899626580E+00 0.56354236893223E+00 0.60425938926314E+00 0.64241853481305E+00 0.67717432344575E+00 0.70749189089217E+00 0.73224723964890E+00 0.75056561312875E+00 0.76205909614406E+00 0.76602032515102E+00 Statistics: FNS, JACS: 146 24 STEPS, ETF, CTF: 95 0 0 -T= 0.40000E+01 X(S,TN): -0.30297382444938E-16 0.62278095516011E-01 0.12338590729591E+00 0.18362098710431E+00 0.24327345506977E+00 0.30252136489478E+00 0.36145309760915E+00 0.42008213052454E+00 0.47834933356615E+00 0.53611465838921E+00 0.59313957155571E+00 0.64906210077329E+00 0.70336918646940E+00 0.75537732988776E+00 0.80424319346191E+00 0.84903885130975E+00 0.88892830477937E+00 0.92344077295069E+00 0.95274239030673E+00 0.97773675015179E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP: 1 0.33421637963707E-01 0.56380108309802E-01 0.10321818263640E+00 0.15125342893774E+00 0.19890288798807E+00 0.24615558139679E+00 0.29305628330806E+00 0.33960301773953E+00 0.38574027870982E+00 0.43135254308473E+00 0.47625146113157E+00 0.52015841477004E+00 0.56269173428307E+00 0.60339609249792E+00 0.64193678328880E+00 0.67871350581785E+00 0.71600110078959E+00 0.75878544728673E+00 0.81398050607894E+00 0.88957191502355E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP: 2 -0.16828799093902E-15 0.53737200467624E-01 0.10295749014437E+00 0.15115355821891E+00 0.19879600105626E+00 0.24603030001145E+00 0.29291452768396E+00 0.33944816827416E+00 0.38557604940157E+00 0.43118275023506E+00 0.47607968142906E+00 0.51998627277971E+00 0.56250806145106E+00 0.60311590039048E+00 0.64112763947077E+00 0.67568621693854E+00 0.70575093777841E+00 0.73021688086726E+00 0.74826372716550E+00 0.75956438029934E+00 0.76345721968372E+00 Statistics: FNS, JACS: 147 24 STEPS, ETF, CTF: 96 0 0 C C####################################################################### C C RUNBAK : RUNINF file from double precision version C for the first example problem C C####################################################################### C Bakker, Electrodynamics problem; EPS=0.143, P=0.1743, ETA=17.19 MoL, PDE+D&D int.face; DAE int.: DASSL; ID:ACM-TOMS, Ex.I NPTS= 21; RTOL=.100E-02, ATOL=.100E-02 TAU=.000E+00, KAPPA=.200E+01, ALPHA=.100E-01 Time= 0.20000E-06; H= 0.10000E-06; Order= 1 Time= 0.40000E-06; H= 0.20000E-06; Order= 2 Time= 0.80000E-06; H= 0.40000E-06; Order= 1 Time= 0.16000E-05; H= 0.80000E-06; Order= 1 Time= 0.32000E-05; H= 0.16000E-05; Order= 1 Time= 0.64000E-05; H= 0.32000E-05; Order= 1 Time= 0.12800E-04; H= 0.64000E-05; Order= 1 Time= 0.19200E-04; H= 0.64000E-05; Order= 1 Time= 0.25600E-04; H= 0.64000E-05; Order= 1 Time= 0.38400E-04; H= 0.12800E-04; Order= 2 Time= 0.51200E-04; H= 0.12800E-04; Order= 2 Time= 0.64000E-04; H= 0.12800E-04; Order= 2 Time= 0.76800E-04; H= 0.12800E-04; Order= 2 Time= 0.10240E-03; H= 0.25600E-04; Order= 2 Time= 0.12800E-03; H= 0.25600E-04; Order= 1 Time= 0.15104E-03; H= 0.23040E-04; Order= 1 Time= 0.17408E-03; H= 0.23040E-04; Order= 1 Time= 0.19712E-03; H= 0.23040E-04; Order= 1 Time= 0.24320E-03; H= 0.46080E-04; Order= 2 Time= 0.28928E-03; H= 0.46080E-04; Order= 2 Time= 0.33536E-03; H= 0.46080E-04; Order= 2 Time= 0.38144E-03; H= 0.46080E-04; Order= 2 Time= 0.42752E-03; H= 0.46080E-04; Order= 2 Time= 0.47360E-03; H= 0.46080E-04; Order= 3 Time= 0.51968E-03; H= 0.46080E-04; Order= 2 Time= 0.56576E-03; H= 0.46080E-04; Order= 2 Time= 0.61184E-03; H= 0.46080E-04; Order= 2 Time= 0.65792E-03; H= 0.46080E-04; Order= 2 Time= 0.70400E-03; H= 0.46080E-04; Order= 1 Time= 0.75008E-03; H= 0.46080E-04; Order= 1 Time= 0.84224E-03; H= 0.92160E-04; Order= 1 Time= 0.93440E-03; H= 0.92160E-04; Order= 1 Time= 0.10266E-02; H= 0.92160E-04; Order= 1 Time= 0.12109E-02; H= 0.18432E-03; Order= 2 Time= 0.13952E-02; H= 0.18432E-03; Order= 2 Time= 0.17638E-02; H= 0.36864E-03; Order= 2 Time= 0.20956E-02; H= 0.33178E-03; Order= 2 Time= 0.24274E-02; H= 0.33178E-03; Order= 2 Time= 0.27592E-02; H= 0.33178E-03; Order= 2 Time= 0.30909E-02; H= 0.33178E-03; Order= 2 Time= 0.34227E-02; H= 0.33178E-03; Order= 3 Time= 0.40863E-02; H= 0.66355E-03; Order= 3 Time= 0.47498E-02; H= 0.66355E-03; Order= 3 Time= 0.54134E-02; H= 0.66355E-03; Order= 3 Time= 0.60769E-02; H= 0.66355E-03; Order= 3 Time= 0.67405E-02; H= 0.66355E-03; Order= 2 Time= 0.74040E-02; H= 0.66355E-03; Order= 2 Time= 0.80676E-02; H= 0.66355E-03; Order= 2 Time= 0.87311E-02; H= 0.66355E-03; Order= 2 Time= 0.10058E-01; H= 0.13271E-02; Order= 2 Time= 0.11385E-01; H= 0.13271E-02; Order= 2 Time= 0.12712E-01; H= 0.13271E-02; Order= 2 Time= 0.15367E-01; H= 0.26542E-02; Order= 2 Time= 0.18021E-01; H= 0.26542E-02; Order= 2 Time= 0.20675E-01; H= 0.26542E-02; Order= 2 Time= 0.23329E-01; H= 0.26542E-02; Order= 2 Time= 0.28638E-01; H= 0.53084E-02; Order= 3 Time= 0.33946E-01; H= 0.53084E-02; Order= 3 Time= 0.39255E-01; H= 0.53084E-02; Order= 3 Time= 0.44563E-01; H= 0.53084E-02; Order= 3 Time= 0.49871E-01; H= 0.53084E-02; Order= 3 Time= 0.60488E-01; H= 0.10617E-01; Order= 2 Time= 0.70043E-01; H= 0.95551E-02; Order= 2 Time= 0.79598E-01; H= 0.95551E-02; Order= 2 Time= 0.89154E-01; H= 0.95551E-02; Order= 2 Time= 0.98709E-01; H= 0.95551E-02; Order= 2 Time= 0.11782E+00; H= 0.19110E-01; Order= 3 Time= 0.13693E+00; H= 0.19110E-01; Order= 3 Time= 0.15604E+00; H= 0.19110E-01; Order= 3 Time= 0.17515E+00; H= 0.19110E-01; Order= 3 Time= 0.19426E+00; H= 0.19110E-01; Order= 3 Time= 0.21337E+00; H= 0.19110E-01; Order= 2 Time= 0.23248E+00; H= 0.19110E-01; Order= 2 Time= 0.25159E+00; H= 0.19110E-01; Order= 2 Time= 0.27070E+00; H= 0.19110E-01; Order= 2 Time= 0.30892E+00; H= 0.38221E-01; Order= 2 Time= 0.34714E+00; H= 0.38221E-01; Order= 2 Time= 0.38536E+00; H= 0.38221E-01; Order= 2 Time= 0.42358E+00; H= 0.38221E-01; Order= 2 Time= 0.50003E+00; H= 0.76441E-01; Order= 3 Time= 0.57647E+00; H= 0.76441E-01; Order= 3 Time= 0.65291E+00; H= 0.76441E-01; Order= 3 Time= 0.72935E+00; H= 0.76441E-01; Order= 3 Time= 0.80579E+00; H= 0.76441E-01; Order= 2 Time= 0.88223E+00; H= 0.76441E-01; Order= 2 Time= 0.95867E+00; H= 0.76441E-01; Order= 2 Time= 0.11116E+01; H= 0.15288E+00; Order= 2 Time= 0.12644E+01; H= 0.15288E+00; Order= 2 Time= 0.14173E+01; H= 0.15288E+00; Order= 2 Time= 0.15702E+01; H= 0.15288E+00; Order= 2 Time= 0.18760E+01; H= 0.30576E+00; Order= 3 Time= 0.21817E+01; H= 0.30576E+00; Order= 2 Time= 0.24875E+01; H= 0.30576E+00; Order= 1 Time= 0.27933E+01; H= 0.30576E+00; Order= 1 Time= 0.34048E+01; H= 0.61153E+00; Order= 1 C C####################################################################### C C RESCYL : RESULT file from double precision version C for the second example problem C C####################################################################### C Reaction-diffusion prob. in cyl. coord.; pars: 1.00000 0.00010 1.00000 0.10000 MoL, PDE+D&D int.face; DAE int.: DASSL; ID:ACM-TOMS, Ex.I NPTS= 21; RTOL=.100E-02, ATOL=.100E-02 TAU=.000E+00, KAPPA=.200E+01, ALPHA=.100E-01 -T= 0.00000E+00 X(S,TN): 0.00000000000000E+00 0.50000000000000E-01 0.10000000000000E+00 0.15000000000000E+00 0.20000000000000E+00 0.25000000000000E+00 0.30000000000000E+00 0.35000000000000E+00 0.40000000000000E+00 0.45000000000000E+00 0.50000000000000E+00 0.55000000000000E+00 0.60000000000000E+00 0.65000000000000E+00 0.70000000000000E+00 0.75000000000000E+00 0.80000000000000E+00 0.85000000000000E+00 0.90000000000000E+00 0.95000000000000E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP: 1 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 -T= 0.10000E+00 X(S,TN): 0.29633654800193E-15 0.14518655828625E+00 0.28623613637578E+00 0.41908482419422E+00 0.53995292546954E+00 0.64574851128986E+00 0.73456206846850E+00 0.80600997379943E+00 0.86120451999333E+00 0.90233892710470E+00 0.93209744234193E+00 0.95314566548264E+00 0.96780068468390E+00 0.97792468340331E+00 0.98491427256273E+00 0.98976166077815E+00 0.99315746314550E+00 0.99558125838569E+00 0.99737374380593E+00 0.99878321274549E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP: 1 0.10541347609001E+00 0.10543381112923E+00 0.10542846159353E+00 0.10542697669293E+00 0.10541941101237E+00 0.10539931629053E+00 0.10534688061183E+00 0.10522618072056E+00 0.10497846200468E+00 0.10451695864439E+00 0.10372016041888E+00 0.10243265616718E+00 0.10051987348868E+00 0.97875000660367E-01 0.94308778919243E-01 0.89498639148020E-01 0.82617436086351E-01 0.71961270055454E-01 0.55520963493168E-01 0.32050224112808E-01 0.00000000000000E+00 Statistics: FNS, JACS: 71 14 STEPS, ETF, CTF: 34 1 0 -T= 0.20000E+00 X(S,TN): -0.11792638907364E-15 0.18674250139956E+00 0.36161564535805E+00 0.51532221836835E+00 0.64273309324947E+00 0.74302837364521E+00 0.81863723215575E+00 0.87370797440104E+00 0.91278775931850E+00 0.94000314850915E+00 0.95871185479410E+00 0.97147380412538E+00 0.98015646071269E+00 0.98607515933571E+00 0.99014055601709E+00 0.99298512232870E+00 0.99504830872862E+00 0.99662399106867E+00 0.99789910993335E+00 0.99899464203903E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP: 1 0.22303632049749E+00 0.22309266720346E+00 0.22307397829205E+00 0.22305809941883E+00 0.22301894061950E+00 0.22293445828391E+00 0.22275286764596E+00 0.22239738682208E+00 0.22175946457949E+00 0.22069656329038E+00 0.21903567918989E+00 0.21658529656165E+00 0.21305503122072E+00 0.20760646433304E+00 0.19806940978031E+00 0.18136093968360E+00 0.15639985596911E+00 0.12479179311940E+00 0.88216320484076E-01 0.47050433315259E-01 0.00000000000000E+00 Statistics: FNS, JACS: 80 15 STEPS, ETF, CTF: 40 1 0 -T= 0.30000E+00 X(S,TN): 0.14320554396716E-14 0.20596968998444E+00 0.39457280855472E+00 0.55404257209325E+00 0.68026501628200E+00 0.77520662843622E+00 0.84399823777437E+00 0.89254013062747E+00 0.92617300168885E+00 0.94919203774937E+00 0.96482596838301E+00 0.97540703351966E+00 0.98257232511705E+00 0.98745436043302E+00 0.99084190132803E+00 0.99328242344946E+00 0.99513361215211E+00 0.99661542102899E+00 0.99786362932057E+00 0.99896842313657E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP: 1 0.35555779828961E+00 0.35564085485280E+00 0.35561200548389E+00 0.35558132635160E+00 0.35551206832711E+00 0.35537043764911E+00 0.35508468402543E+00 0.35455395478681E+00 0.35364027460106E+00 0.35216515432253E+00 0.34989560276892E+00 0.34642011011708E+00 0.34044213754871E+00 0.32826236853721E+00 0.30487011125492E+00 0.26953244954386E+00 0.22564377110062E+00 0.17619310916448E+00 0.12248074083887E+00 0.64326526707150E-01 0.00000000000000E+00 Statistics: FNS, JACS: 88 16 STEPS, ETF, CTF: 43 1 0 -T= 0.40000E+00 X(S,TN): 0.17573661222888E-14 0.21714536240210E+00 0.41311648503976E+00 0.57490280278510E+00 0.69958607539812E+00 0.79108933764365E+00 0.85606204614195E+00 0.90120200093970E+00 0.93211312844888E+00 0.95308623239553E+00 0.96725184329120E+00 0.97680747363581E+00 0.98327317844469E+00 0.98770497165375E+00 0.99083765906992E+00 0.99315989881063E+00 0.99497619854938E+00 0.99646998177328E+00 0.99775565086732E+00 0.99891133823822E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP: 1 0.50697530208446E+00 0.50715003288900E+00 0.50709494727959E+00 0.50702558068249E+00 0.50690423986777E+00 0.50668764171967E+00 0.50628342135082E+00 0.50556561168646E+00 0.50436984080349E+00 0.50247956571493E+00 0.49952917267571E+00 0.49441348538268E+00 0.48317911608222E+00 0.45833120911755E+00 0.41655674282601E+00 0.36195417095601E+00 0.29943288273382E+00 0.23180283130867E+00 0.15998075931332E+00 0.83422347369468E-01 0.00000000000000E+00 Statistics: FNS, JACS: 91 16 STEPS, ETF, CTF: 46 1 0 -T= 0.50000E+00 X(S,TN): 0.18445852701699E-14 0.22453039548393E+00 0.42504916702065E+00 0.58784710689971E+00 0.71110879801132E+00 0.80018734147900E+00 0.86268417908266E+00 0.90572840731953E+00 0.93503532905967E+00 0.95485084780955E+00 0.96820343631153E+00 0.97720051578603E+00 0.98329814851021E+00 0.98751582550847E+00 0.99055667647461E+00 0.99286721727617E+00 0.99471537479902E+00 0.99626306865955E+00 0.99761349779020E+00 0.99883914463824E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP: 1 0.68243708640462E+00 0.68277810495631E+00 0.68267873731318E+00 0.68253669913763E+00 0.68232631092308E+00 0.68199779228077E+00 0.68143722816467E+00 0.68048877619805E+00 0.67895569372489E+00 0.67655952419315E+00 0.67260501069311E+00 0.66432549241951E+00 0.64357698297669E+00 0.60148578658400E+00 0.53953838751663E+00 0.46464543953401E+00 0.38206588083428E+00 0.29441901207307E+00 0.20237363383063E+00 0.10508403679625E+00 0.00000000000000E+00 Statistics: FNS, JACS: 96 17 STEPS, ETF, CTF: 48 1 0 -T= 0.60000E+00 X(S,TN): 0.19896455339228E-14 0.22976402276294E+00 0.43337374825586E+00 0.59669864979291E+00 0.71882415309975E+00 0.80614720344578E+00 0.86691611718749E+00 0.90852702796460E+00 0.93674350280112E+00 0.95577029968016E+00 0.96857117148520E+00 0.97719614208978E+00 0.98306587485048E+00 0.98717730441413E+00 0.99019725048412E+00 0.99253472570486E+00 0.99443441614419E+00 0.99604595121440E+00 0.99746635393159E+00 0.99876493793765E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP: 1 0.88950214339158E+00 0.88989698872038E+00 0.88977833151036E+00 0.88958746131439E+00 0.88931080534037E+00 0.88888543558770E+00 0.88817180295746E+00 0.88697659938512E+00 0.88504924113208E+00 0.88196669312571E+00 0.87626925132628E+00 0.86213194539360E+00 0.82693477549876E+00 0.76378695805704E+00 0.67899271247124E+00 0.58116118176215E+00 0.47579308917595E+00 0.36538723369220E+00 0.25037340103839E+00 0.12958244884495E+00 0.00000000000000E+00 Statistics: FNS, JACS: 98 17 STEPS, ETF, CTF: 50 1 0 -T= 0.70000E+00 X(S,TN): 0.19261828521368E-14 0.23377659373911E+00 0.43965276875405E+00 0.60322954622865E+00 0.72436707982107E+00 0.81028614300554E+00 0.86971691780380E+00 0.91023954877469E+00 0.93764119125336E+00 0.95608892373450E+00 0.96849204591115E+00 0.97685680664204E+00 0.98258593401810E+00 0.98666312434109E+00 0.98971246522479E+00 0.99211339722082E+00 0.99409215327768E+00 0.99578855129431E+00 0.99729507715551E+00 0.99867950240365E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP: 1 0.11404669177384E+01 0.11409401761389E+01 0.11407950664162E+01 0.11405304435312E+01 0.11401547215867E+01 0.11395903046279E+01 0.11386658165488E+01 0.11371394869770E+01 0.11346804487025E+01 0.11305978410490E+01 0.11220765449537E+01 0.10990532438480E+01 0.10454763873760E+01 0.95785277553727E+00 0.84631527260672E+00 0.72105095539796E+00 0.58813400082146E+00 0.45020996259660E+00 0.30758753101720E+00 0.15873164955159E+00 0.00000000000000E+00 Statistics: FNS, JACS: 101 17 STEPS, ETF, CTF: 52 1 0 -T= 0.80000E+00 X(S,TN): 0.19489983690457E-14 0.23687484247408E+00 0.44446215799979E+00 0.60818790358613E+00 0.72854965204118E+00 0.81340009981196E+00 0.87181685342508E+00 0.91150890459368E+00 0.93828450007265E+00 0.95628464386745E+00 0.96838244791295E+00 0.97655859879403E+00 0.98219255780115E+00 0.98622833151892E+00 0.98928315863532E+00 0.99172155857119E+00 0.99375914717493E+00 0.99552866915387E+00 0.99711751247974E+00 0.99858952892382E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP: 1 0.14552918110825E+01 0.14558170992759E+01 0.14556539852505E+01 0.14553017251900E+01 0.14547973571279E+01 0.14540405739271E+01 0.14528121711801E+01 0.14507981997373E+01 0.14475251243218E+01 0.14417245515669E+01 0.14279616969269E+01 0.13899339048834E+01 0.13092952664750E+01 0.11892426695586E+01 0.10446088490089E+01 0.88683351366206E+00 0.72182816509103E+00 0.55174921252904E+00 0.37643658786783E+00 0.19392013756469E+00 0.00000000000000E+00 Statistics: FNS, JACS: 109 18 STEPS, ETF, CTF: 54 1 0 -T= 0.90000E+00 X(S,TN): 0.19522004004880E-14 0.23940409202118E+00 0.44830950111163E+00 0.61202518575909E+00 0.73162655965155E+00 0.81551133939449E+00 0.87304550993000E+00 0.91203540705249E+00 0.93829377398775E+00 0.95593275472896E+00 0.96779250259421E+00 0.97583217536967E+00 0.98142304149109E+00 0.98549487874875E+00 0.98862872790646E+00 0.99116713373378E+00 0.99331380665166E+00 0.99519534780138E+00 0.99689620907578E+00 0.99847927530783E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP: 1 0.18703046072040E+01 0.18708707754603E+01 0.18706890057619E+01 0.18702116500391E+01 0.18695124340226E+01 0.18684591699182E+01 0.18667607985324E+01 0.18639914674898E+01 0.18594301761913E+01 0.18507920200978E+01 0.18286960031340E+01 0.17696548106000E+01 0.16548823480591E+01 0.14939893896297E+01 0.13061944743727E+01 0.11048396889746E+01 0.89647985331882E+00 0.68334503881772E+00 0.46501924258866E+00 0.23896237801002E+00 0.00000000000000E+00 Statistics: FNS, JACS: 112 18 STEPS, ETF, CTF: 56 1 0 -T= 0.10000E+01 X(S,TN): 0.19469824500562E-14 0.24148527447510E+00 0.45140991558508E+00 0.61500816141860E+00 0.73387823502942E+00 0.81688810359375E+00 0.87364219573274E+00 0.91202198262112E+00 0.93783931979533E+00 0.95517868798202E+00 0.96685159403756E+00 0.97480014157111E+00 0.98038849859694E+00 0.98453251352016E+00 0.98777877069999E+00 0.99044969249063E+00 0.99273780114691E+00 0.99476373487584E+00 0.99660920760540E+00 0.99833615484976E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP: 1 0.24607685161092E+01 0.24614200363063E+01 0.24611902282900E+01 0.24604728113344E+01 0.24593954922007E+01 0.24577770683979E+01 0.24552004285485E+01 0.24510291540584E+01 0.24440266874217E+01 0.24299089494885E+01 0.23928508777186E+01 0.23004311051512E+01 0.21354741397201E+01 0.19157324556924E+01 0.16663203096580E+01 0.14033722492618E+01 0.11344848770177E+01 0.86199757405020E+00 0.58498494342162E+00 0.29989817369661E+00 0.00000000000000E+00 Statistics: FNS, JACS: 117 18 STEPS, ETF, CTF: 58 1 0 C C####################################################################### C C RUNCYL : RUNINF file from double precision version C for the second example problem C C####################################################################### C Reaction-diffusion prob. in cyl. coord.; pars: 1.00000 0.00010 1.00000 0.10000 MoL, PDE+D&D int.face; DAE int.: DASSL; ID:ACM-TOMS, Ex.I NPTS= 21; RTOL=.100E-02, ATOL=.100E-02 TAU=.000E+00, KAPPA=.200E+01, ALPHA=.100E-01 Time= 0.20000E-03; H= 0.10000E-03; Order= 1 Time= 0.40000E-03; H= 0.20000E-03; Order= 2 Time= 0.80000E-03; H= 0.40000E-03; Order= 1 Time= 0.16000E-02; H= 0.80000E-03; Order= 1 Time= 0.32000E-02; H= 0.16000E-02; Order= 1 Time= 0.48000E-02; H= 0.16000E-02; Order= 1 Time= 0.64000E-02; H= 0.16000E-02; Order= 1 Time= 0.96000E-02; H= 0.32000E-02; Order= 2 Time= 0.12480E-01; H= 0.28800E-02; Order= 2 Time= 0.15360E-01; H= 0.28800E-02; Order= 2 Time= 0.18240E-01; H= 0.28800E-02; Order= 2 Time= 0.21120E-01; H= 0.28800E-02; Order= 2 Time= 0.24000E-01; H= 0.28800E-02; Order= 1 Time= 0.26410E-01; H= 0.24103E-02; Order= 1 Time= 0.28821E-01; H= 0.24103E-02; Order= 1 Time= 0.31231E-01; H= 0.24103E-02; Order= 1 Time= 0.33641E-01; H= 0.24103E-02; Order= 1 Time= 0.35811E-01; H= 0.21693E-02; Order= 1 Time= 0.37586E-01; H= 0.17756E-02; Order= 1 Time= 0.39362E-01; H= 0.17756E-02; Order= 1 Time= 0.41138E-01; H= 0.17756E-02; Order= 1 Time= 0.44689E-01; H= 0.35512E-02; Order= 1 Time= 0.48240E-01; H= 0.35512E-02; Order= 1 Time= 0.51791E-01; H= 0.35512E-02; Order= 1 Time= 0.55342E-01; H= 0.35512E-02; Order= 2 Time= 0.58894E-01; H= 0.35512E-02; Order= 2 Time= 0.65996E-01; H= 0.71025E-02; Order= 2 Time= 0.73099E-01; H= 0.71025E-02; Order= 2 Time= 0.80201E-01; H= 0.71025E-02; Order= 2 Time= 0.87303E-01; H= 0.71025E-02; Order= 2 Time= 0.91370E-01; H= 0.40665E-02; Order= 1 Time= 0.95030E-01; H= 0.36599E-02; Order= 1 Time= 0.98690E-01; H= 0.36599E-02; Order= 1 Time= 0.10601E+00; H= 0.73198E-02; Order= 1 Time= 0.11333E+00; H= 0.73198E-02; Order= 1 Time= 0.12065E+00; H= 0.73198E-02; Order= 1 Time= 0.13529E+00; H= 0.14640E-01; Order= 2 Time= 0.14993E+00; H= 0.14640E-01; Order= 2 Time= 0.17921E+00; H= 0.29279E-01; Order= 2 Time= 0.20355E+00; H= 0.24338E-01; Order= 2 Time= 0.22788E+00; H= 0.24338E-01; Order= 2 Time= 0.25222E+00; H= 0.24338E-01; Order= 2 Time= 0.30090E+00; H= 0.48677E-01; Order= 2 Time= 0.34958E+00; H= 0.48677E-01; Order= 2 Time= 0.39825E+00; H= 0.48677E-01; Order= 2 Time= 0.44693E+00; H= 0.48677E-01; Order= 2 Time= 0.49561E+00; H= 0.48677E-01; Order= 3 Time= 0.54428E+00; H= 0.48677E-01; Order= 3 Time= 0.59296E+00; H= 0.48677E-01; Order= 3 Time= 0.64164E+00; H= 0.48677E-01; Order= 3 Time= 0.69031E+00; H= 0.48677E-01; Order= 3 Time= 0.73899E+00; H= 0.48677E-01; Order= 4 Time= 0.78767E+00; H= 0.48677E-01; Order= 3 Time= 0.83634E+00; H= 0.48677E-01; Order= 3 Time= 0.88015E+00; H= 0.43809E-01; Order= 3 Time= 0.92396E+00; H= 0.43809E-01; Order= 3 Time= 0.96777E+00; H= 0.43809E-01; Order= 3 C C####################################################################### C C RESDSH : RESULT file from double precision version !!! TAU = 1E-3 !!! C for the third example problem !!! in driver !!! C C####################################################################### C Burgers, double wave, eps=0.00100 MoL, PDE+D&D int.face; DAE int.: DASSL; ID:ACM-TOMS, Ex.I NPTS= 21; RTOL=.100E-02, ATOL=.100E-02 TAU=.100E-02, KAPPA=.200E+01, ALPHA=.100E-01 -T= 0.00000E+00 X(S,TN): 0.00000000000000E+00 0.50000000000000E-01 0.10000000000000E+00 0.15000000000000E+00 0.20000000000000E+00 0.25000000000000E+00 0.30000000000000E+00 0.35000000000000E+00 0.40000000000000E+00 0.45000000000000E+00 0.50000000000000E+00 0.55000000000000E+00 0.60000000000000E+00 0.65000000000000E+00 0.70000000000000E+00 0.75000000000000E+00 0.80000000000000E+00 0.85000000000000E+00 0.90000000000000E+00 0.95000000000000E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP: 1 0.10000000000000E+01 0.10000000000000E+01 0.10000000000000E+01 0.99999999999306E+00 0.99999813668036E+00 0.75000000000000E+00 0.50000186331964E+00 0.50000000000691E+00 0.49999999917554E+00 0.49998184085252E+00 0.30000000000000E+00 0.10001815914748E+00 0.10000000082446E+00 0.10000000000004E+00 0.10000000000000E+00 0.10000000000000E+00 0.10000000000000E+00 0.10000000000000E+00 0.10000000000000E+00 0.10000000000000E+00 0.10000000000000E+00 ERR_U: 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 MAX. NORM: 0.0000000000000000E+00 TWO NORM: 0.0000000000000000E+00 -T= 0.25000E+00 X(S,TN): 0.39938631124805E-17 0.10848039902619E+00 0.20332143491505E+00 0.27818744594920E+00 0.33366936812585E+00 0.37291383644095E+00 0.40083196608916E+00 0.42007706567635E+00 0.43538103087761E+00 0.45161358060903E+00 0.47211289543100E+00 0.49608912621524E+00 0.52168938076279E+00 0.54552297753852E+00 0.56985660342795E+00 0.60028529153006E+00 0.64240022494589E+00 0.70136696474965E+00 0.78157647910928E+00 0.88350458954221E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP: 1 0.10000000000000E+01 0.99716089594943E+00 0.10053914674654E+01 0.99398227506464E+00 0.99342130435753E+00 0.10192369473142E+01 0.10241403571050E+01 0.91801071317624E+00 0.70722316658278E+00 0.55195999630692E+00 0.52757210582003E+00 0.55692411740765E+00 0.54507289464643E+00 0.41903177710539E+00 0.24891870363783E+00 0.15397788150532E+00 0.12084641861083E+00 0.10668405272291E+00 0.10148886169492E+00 0.10021053963123E+00 0.10000000000000E+00 ERR_U: 0.22204460492503E-15 -0.28391040505725E-02 0.53914674653861E-02 -0.60177249353576E-02 -0.65786956398048E-02 0.19236995911935E-01 0.24192565874387E-01 -0.75654075692869E-01 -0.10748833391832E+00 0.37702490610937E-01 0.27484839929748E-01 0.56923955738010E-01 0.45082260157957E-01 -0.79870418949233E-01 -0.14574520567546E+00 0.51448279061020E-01 0.20845859175062E-01 0.66840527186798E-02 0.14888616949214E-02 0.21053963123274E-03 0.00000000000000E+00 MAX. NORM: 0.1457452056754566 TWO NORM: 3.6674051387714139E-02 Statistics: FNS, JACS: 122 25 STEPS, ETF, CTF: 54 2 0 -T= 0.55000E+00 X(S,TN): 0.42789669774584E-17 0.16054451804151E+00 0.30092880945903E+00 0.41129713314553E+00 0.49220185168819E+00 0.54915446061045E+00 0.58838172674564E+00 0.61516881937511E+00 0.63346396078613E+00 0.64622568627158E+00 0.65503654061962E+00 0.66206776470849E+00 0.66930854132777E+00 0.67861092376706E+00 0.69195689764799E+00 0.71173453951118E+00 0.74072198769036E+00 0.78231249604778E+00 0.83987086327238E+00 0.91417304003956E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP: 1 0.10000000000000E+01 0.99404766813922E+00 0.99946681627913E+00 0.10044684114696E+01 0.99915737453175E+00 0.99347950474687E+00 0.98418997423471E+00 0.99816960681373E+00 0.10343868913845E+01 0.10199481635346E+01 0.85473686969265E+00 0.55624502985958E+00 0.28655923610120E+00 0.14939763647867E+00 0.10798078391628E+00 0.10887166247564E+00 0.10812640776773E+00 0.10260672751600E+00 0.10090714897772E+00 0.10023518346668E+00 0.10000000000000E+00 ERR_U: 0.00000000000000E+00 -0.59523318607845E-02 -0.53318372086508E-03 0.44684114695528E-02 -0.84262546825287E-03 -0.65204952528811E-02 -0.15810021281136E-01 -0.18267616873753E-02 0.34739699727455E-01 0.28705944538099E-01 -0.63306367878777E-01 -0.69030145673122E-01 0.27645226885963E-01 0.23766155939683E-01 0.61641937601004E-02 0.88367712687488E-02 0.81263018590435E-02 0.26067274901526E-02 0.90714897771901E-03 0.23518346667772E-03 -0.83266726846887E-16 MAX. NORM: 6.9030145673121712E-02 TWO NORM: 1.1360035643140431E-02 Statistics: FNS, JACS: 182 35 STEPS, ETF, CTF: 77 3 0 -T= 0.10000E+01 X(S,TN): 0.65933069367097E-17 0.21712532792970E+00 0.40789355716805E+00 0.55903868093297E+00 0.67065296175650E+00 0.74961920707661E+00 0.80415045798395E+00 0.84129569825018E+00 0.86644124701394E+00 0.88339842283443E+00 0.89479947600615E+00 0.90244623955670E+00 0.90756630387598E+00 0.91151304527626E+00 0.91551636518356E+00 0.92079199808315E+00 0.92855923742497E+00 0.93982088640938E+00 0.95556497937051E+00 0.97610322784590E+00 0.10000000000000E+01 U(X(S,TN),TN), COMP: 1 0.10000000000000E+01 0.99916190570377E+00 0.99405196213500E+00 0.99696282523826E+00 0.99841866007516E+00 0.10014099538875E+01 0.10042543009900E+01 0.99915608628413E+00 0.10036645912492E+01 0.10003563151071E+01 0.10025371199935E+01 0.10011032079500E+01 0.84996071726458E+00 0.53810418710225E+00 0.23683306226127E+00 0.10531371063189E+00 0.10042725788778E+00 0.10040599485127E+00 0.10036314505057E+00 0.10017167622878E+00 0.10000000000000E+00 ERR_U: -0.99920072216264E-15 -0.83809429623427E-03 -0.59480378649983E-02 -0.30371747617424E-02 -0.15813399248433E-02 0.14099538874781E-02 0.42543009900244E-02 -0.84391371584724E-03 0.36645929253346E-02 0.35976877395583E-03 0.31207490251667E-02 0.18973626733526E-01 0.17535496151199E-02 0.28689439130730E-01 0.27872740417935E-01 -0.60821784156097E-02 0.77198024505315E-04 0.40378980423768E-03 0.36314320336787E-03 0.17167622859905E-03 0.83266726846887E-16 MAX. NORM: 2.8689439130729521E-02 TWO NORM: 4.2939725456811341E-03 Statistics: FNS, JACS: 294 62 STEPS, ETF, CTF: 121 4 7 C C####################################################################### C C RUNDSH : RUNINF file from double precision version !!! TAU = 1E-3 !!! C for the third example problem !!! in driver !!! C C####################################################################### C Burgers, double wave, eps=0.00100 MoL, PDE+D&D int.face; DAE int.: DASSL; ID:ACM-TOMS, Ex.I NPTS= 21; RTOL=.100E-02, ATOL=.100E-02 TAU=.100E-02, KAPPA=.200E+01, ALPHA=.100E-01 Time= 0.65287E-05; H= 0.32643E-05; Order= 1 Time= 0.13057E-04; H= 0.65287E-05; Order= 2 Time= 0.26115E-04; H= 0.13057E-04; Order= 1 Time= 0.52229E-04; H= 0.26115E-04; Order= 1 Time= 0.78344E-04; H= 0.26115E-04; Order= 1 Time= 0.13057E-03; H= 0.52229E-04; Order= 1 Time= 0.17717E-03; H= 0.46598E-04; Order= 1 Time= 0.22377E-03; H= 0.46598E-04; Order= 1 Time= 0.27037E-03; H= 0.46598E-04; Order= 1 Time= 0.31696E-03; H= 0.46598E-04; Order= 1 Time= 0.36356E-03; H= 0.46598E-04; Order= 1 Time= 0.40310E-03; H= 0.39538E-04; Order= 1 Time= 0.44264E-03; H= 0.39538E-04; Order= 1 Time= 0.48218E-03; H= 0.39538E-04; Order= 1 Time= 0.56125E-03; H= 0.79077E-04; Order= 2 Time= 0.64033E-03; H= 0.79077E-04; Order= 2 Time= 0.79848E-03; H= 0.15815E-03; Order= 2 Time= 0.93806E-03; H= 0.13958E-03; Order= 2 Time= 0.10776E-02; H= 0.13958E-03; Order= 2 Time= 0.12172E-02; H= 0.13958E-03; Order= 2 Time= 0.13303E-02; H= 0.11307E-03; Order= 2 Time= 0.14320E-02; H= 0.10176E-03; Order= 2 Time= 0.15338E-02; H= 0.10176E-03; Order= 2 Time= 0.16356E-02; H= 0.10176E-03; Order= 2 Time= 0.17373E-02; H= 0.10176E-03; Order= 1 Time= 0.18391E-02; H= 0.10176E-03; Order= 1 Time= 0.20426E-02; H= 0.20353E-03; Order= 1 Time= 0.22462E-02; H= 0.20353E-03; Order= 1 Time= 0.24497E-02; H= 0.20353E-03; Order= 1 Time= 0.28567E-02; H= 0.40705E-03; Order= 2 Time= 0.32638E-02; H= 0.40705E-03; Order= 2 Time= 0.39269E-02; H= 0.66307E-03; Order= 1 Time= 0.45146E-02; H= 0.58775E-03; Order= 1 Time= 0.56901E-02; H= 0.11755E-02; Order= 1 Time= 0.68656E-02; H= 0.11755E-02; Order= 1 Time= 0.92166E-02; H= 0.23510E-02; Order= 1 Time= 0.11568E-01; H= 0.23510E-02; Order= 1 Time= 0.16270E-01; H= 0.47020E-02; Order= 1 Time= 0.25674E-01; H= 0.94040E-02; Order= 1 Time= 0.35078E-01; H= 0.94040E-02; Order= 1 Time= 0.44482E-01; H= 0.94040E-02; Order= 1 Time= 0.63290E-01; H= 0.18808E-01; Order= 1 Time= 0.80217E-01; H= 0.16927E-01; Order= 1 Time= 0.95355E-01; H= 0.15139E-01; Order= 1 Time= 0.11049E+00; H= 0.15139E-01; Order= 1 Time= 0.12563E+00; H= 0.15139E-01; Order= 1 Time= 0.13974E+00; H= 0.14103E-01; Order= 1 Time= 0.15110E+00; H= 0.11364E-01; Order= 1 Time= 0.16247E+00; H= 0.11364E-01; Order= 1 Time= 0.17383E+00; H= 0.11364E-01; Order= 1 Time= 0.18519E+00; H= 0.11364E-01; Order= 1 Time= 0.20792E+00; H= 0.22729E-01; Order= 2 Time= 0.23065E+00; H= 0.22729E-01; Order= 1 Time= 0.25338E+00; H= 0.22729E-01; Order= 1 Time= 0.26519E+00; H= 0.11807E-01; Order= 1 Time= 0.27452E+00; H= 0.93356E-02; Order= 1 Time= 0.28386E+00; H= 0.93356E-02; Order= 1 Time= 0.29319E+00; H= 0.93356E-02; Order= 1 Time= 0.30253E+00; H= 0.93356E-02; Order= 2 Time= 0.31187E+00; H= 0.93356E-02; Order= 2 Time= 0.32120E+00; H= 0.93356E-02; Order= 1 Time= 0.33987E+00; H= 0.18671E-01; Order= 1 Time= 0.35854E+00; H= 0.18671E-01; Order= 1 Time= 0.37410E+00; H= 0.15560E-01; Order= 1 Time= 0.38966E+00; H= 0.15560E-01; Order= 1 Time= 0.40522E+00; H= 0.15560E-01; Order= 1 Time= 0.41923E+00; H= 0.14004E-01; Order= 1 Time= 0.43323E+00; H= 0.14004E-01; Order= 1 Time= 0.44723E+00; H= 0.14004E-01; Order= 1 Time= 0.46124E+00; H= 0.14004E-01; Order= 2 Time= 0.47524E+00; H= 0.14004E-01; Order= 2 Time= 0.48924E+00; H= 0.14004E-01; Order= 2 Time= 0.50325E+00; H= 0.14004E-01; Order= 2 Time= 0.51725E+00; H= 0.14004E-01; Order= 3 Time= 0.53126E+00; H= 0.14004E-01; Order= 3 Time= 0.54526E+00; H= 0.14004E-01; Order= 2 Time= 0.55926E+00; H= 0.14004E-01; Order= 2 Time= 0.57327E+00; H= 0.14004E-01; Order= 2 Time= 0.58515E+00; H= 0.11881E-01; Order= 2 Time= 0.59287E+00; H= 0.77259E-02; Order= 2 Time= 0.60060E+00; H= 0.77259E-02; Order= 2 Time= 0.60832E+00; H= 0.77259E-02; Order= 2 Time= 0.61605E+00; H= 0.77259E-02; Order= 2 Time= 0.61991E+00; H= 0.38629E-02; Order= 2 Time= 0.62378E+00; H= 0.38629E-02; Order= 2 Time= 0.62691E+00; H= 0.31327E-02; Order= 2 Time= 0.63317E+00; H= 0.62655E-02; Order= 1 Time= 0.64571E+00; H= 0.12531E-01; Order= 1 Time= 0.65671E+00; H= 0.11008E-01; Order= 1 Time= 0.66772E+00; H= 0.11008E-01; Order= 1 Time= 0.67873E+00; H= 0.11008E-01; Order= 1 Time= 0.70075E+00; H= 0.22017E-01; Order= 2 Time= 0.72276E+00; H= 0.22017E-01; Order= 2 Time= 0.74478E+00; H= 0.22017E-01; Order= 2 Time= 0.76680E+00; H= 0.22017E-01; Order= 2 Time= 0.78534E+00; H= 0.18547E-01; Order= 1 Time= 0.80389E+00; H= 0.18547E-01; Order= 1 Time= 0.82244E+00; H= 0.18547E-01; Order= 1 Time= 0.84099E+00; H= 0.18547E-01; Order= 1 Time= 0.85953E+00; H= 0.18547E-01; Order= 1 Time= 0.87808E+00; H= 0.18547E-01; Order= 1 Time= 0.87814E+00; H= 0.65204E-04; Order= 1 Time= 0.87827E+00; H= 0.13041E-03; Order= 1 Time= 0.87838E+00; H= 0.10282E-03; Order= 1 Time= 0.87848E+00; H= 0.10282E-03; Order= 1 Time= 0.87869E+00; H= 0.20564E-03; Order= 1 Time= 0.87889E+00; H= 0.20564E-03; Order= 1 Time= 0.87930E+00; H= 0.41127E-03; Order= 1 Time= 0.88013E+00; H= 0.82255E-03; Order= 1 Time= 0.88177E+00; H= 0.16451E-02; Order= 1 Time= 0.88259E+00; H= 0.82255E-03; Order= 1 Time= 0.88424E+00; H= 0.16451E-02; Order= 1 Time= 0.88753E+00; H= 0.32902E-02; Order= 1 Time= 0.89411E+00; H= 0.65804E-02; Order= 1 Time= 0.90727E+00; H= 0.13161E-01; Order= 1 Time= 0.92043E+00; H= 0.13161E-01; Order= 1 Time= 0.93359E+00; H= 0.13161E-01; Order= 1 Time= 0.95991E+00; H= 0.26322E-01; Order= 2 Time= 0.98623E+00; H= 0.26322E-01; Order= 2 Time= 0.99216E+00; H= 0.59224E-02; Order= 2 8<------------------------------------------------------------------------- C####################################################################### C C Source code TOMS submission `A Moving-Grid Interface for Systems of C One-Dimensional Time-Dependent Partial Differential Equations' by C J.G. Blom and P.A. Zegeling. C C First the single precision version then, separated by a C C*********** line, the double precision version C C*********************************************************************** C C Single Precision files C C*********************************************************************** C C Contains, separated by a C######## line, the following files: C ------------------------------------------------------------ C PRBBAK : problem dependent routines for first example problem C PRBCYL : problem dependent routines for second example problem C PRBDSH : problem dependent routines for third example problem C (Burgers' equation) C DRIVER : test program to use the moving-grid interface in a DASSL C environment C SPMDIF : moving-grid interface routines C MACHAR : MACHAR routine from W.J. Cody C (available from Netlib: send machar from elefunt) C SDASSL : DASSL DAE integrator from L.R. Petzold C (available from Netlib: send sdassl from ode) C NB. DASSL needs the following files: C DASUSE : contains the routine C I1MACH to get the standard error message unit (6). C (also available from Netlib: send i1mach from core) C R1MACH to determine machine precision, uses value determined C by MACHAR C (also available from Netlib: send r1mach from core) C and the dummies for the routines SGEFA and SGESL from LINPACK C (available from Netlib: send sgefa/sgesl from linpack) C DASLIP : LINPACK routines needed by DASSL C (available from Netlib: send sgbfa/sgbsl from linpack) C C C Of the next three problem dependent files only one should be loaded C C####################################################################### C C PRBBAK : problem dependent routines for first example problem C C####################################################################### C SUBROUTINE INIPRB (TEXT) CHARACTER TEXT*80 C C Initialize /PROBLM/ C INTEGER NPDE, NPRINT LOGICAL ANAJAC, SOLAV REAL XL, XR, T0, TE REAL DUMPRO(5), TPRINT(10) COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO, + ANAJAC, SOLAV, TPRINT, NPRINT C INTEGER M REAL EPS, P, ETA DATA EPS /0.143/, ETA /17.19/, P /0.1743/ C NPDE = 2 M = 0 XL = 0.0 XR = 1.0 T0 = 0.0 TE = 4.0 ANAJAC = .FALSE. SOLAV = .FALSE. NPRINT = 10 TPRINT(1) = 1.0E-4 TPRINT(2) = 1.0E-3 TPRINT(3) = 1.0E-2 TPRINT(4) = 0.1 TPRINT(5) = 0.25 TPRINT(6) = 0.5 TPRINT(7) = 1.0 TPRINT(8) = 2.0 TPRINT(9) = 3.0 TPRINT(10) = 4.0 TEXT = ' Bakker, Electrodynamics problem' WRITE(TEXT(33:80),'(6H; EPS=,F5.3,4H, P=,F6.4,6H, ETA=,F5.2)') + EPS, P, ETA DUMPRO(1) = M DUMPRO(2) = EPS DUMPRO(3) = P DUMPRO(4) = ETA RETURN END SUBROUTINE UINIT (NPDE, NPTS, Y) C C Routine for PDE initial values. C Entry: C Y(NPDE+1,i) = x_i; uniform mesh, generated by package C Exit: C Y(NPDE+1,i) = x_i; mesh, optionally changed by user C Y( k,i) = u_k(x_i,t0); initial value of k-th component C i = 1,.., NPTS C INTEGER NPDE, NPTS REAL Y(NPDE+1,NPTS) INTEGER I DO 10 I = 1, NPTS Y(1,I) = 1.0 Y(2,I) = 0.0 10 CONTINUE RETURN END SUBROUTINE SPDEF (T, X, NPDE, U, DUDX, C, Q, R, IRES) C C Routine to describe the body of the PDE system. C The PDE is written as C NPDE k -m m C sum C (x,t,u,u ) u + Q (x,t,u,u ) = x (x R (x,t,u,u ) ) C k=1 jk x t j x j x x C the functions C, Q and R must be defined in this routine. C INTEGER NPDE, IRES REAL T, X REAL U(NPDE), DUDX(NPDE), C(NPDE,NPDE), Q(NPDE), R(NPDE) INTEGER J, K REAL EPS, ETA, GZ, P, Z DATA EPS /0.143/, ETA /17.19/, P /0.1743/ DO 10 K = 1, NPDE DO 20 J = 1, NPDE C(J,K) = 0.0 20 CONTINUE C(K,K) = 1.0 10 CONTINUE Z = U(1) - U(2) GZ = EXP(ETA*Z/3) - EXP(-2*ETA*Z/3) Q(1) = GZ Q(2) = -GZ R(1) = EPS*P * DUDX(1) R(2) = P * DUDX(2) RETURN END SUBROUTINE BNDR (T, BETA, GAMMA, U, DUDX, NPDE, LEFT, IRES) C C Boundary conditions routine C The boundary conditions are written as C BETA (x,t) R (x,t,u,u ) = GAMMA (x,t,u,u ) C j j x j x C The functions BETA and GAMMA should be defined in this routine. C INTEGER NPDE, IRES LOGICAL LEFT REAL T REAL BETA(NPDE), GAMMA(NPDE), U(NPDE), DUDX(NPDE) IF (LEFT) THEN BETA (1) = 1.0 GAMMA(1) = 0.0 BETA (2) = 0.0 GAMMA(2) = U(2) ELSE BETA (1) = 0.0 GAMMA(1) = U(1) - 1.0 BETA (2) = 1.0 GAMMA(2) = 0.0 ENDIF RETURN END SUBROUTINE UEXACT (X, T, U) REAL X, T REAL U(*) C RETURN END C C####################################################################### C C PRBCYL : problem dependent routines for second example problem C C####################################################################### C SUBROUTINE INIPRB (TEXT) CHARACTER TEXT*80 C C Initialize /PROBLM/ C INTEGER NPDE, NPRINT LOGICAL ANAJAC, SOLAV REAL XL, XR, T0, TE REAL DUMPRO(5), TPRINT(10) COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO, + ANAJAC, SOLAV, TPRINT, NPRINT C INTEGER I, M REAL ALPHA, BETA, GAMMA, EPS C NPDE = 1 M = 1 XL = 0.0 XR = 1.0 T0 = 0.0 TE = 1.0 ANAJAC = .FALSE. SOLAV = .FALSE. NPRINT = 10 DO 10 I = 1, NPRINT TPRINT(I) = 0.1*I 10 CONTINUE ALPHA = 1.0 BETA = 0.0001 GAMMA = 1.0 EPS = 0.1 TEXT = ' Reaction-diffusion prob. in cyl. coord.; pars:' WRITE(TEXT(48:80),'(4F8.5)') ALPHA, BETA, GAMMA, EPS DUMPRO(1) = M DUMPRO(2) = ALPHA DUMPRO(3) = BETA DUMPRO(4) = GAMMA DUMPRO(5) = EPS RETURN END SUBROUTINE UINIT (NPD, NPTS, Y) C C Routine for PDE initial values. C Entry: C Y(NPDE+1,i) = x_i; uniform mesh, generated by package C Exit: C Y(NPDE+1,i) = x_i; mesh, optionally changed by user C Y( k,i) = u_k(x_i,t0); initial value of k-th component C i = 1,.., NPTS C INTEGER NPD, NPTS REAL Y(NPDE+1,NPTS) C INTEGER NPDE, NPRINT LOGICAL ANAJAC, SOLAV REAL XL, XR, T0, TE REAL DUMPRO(5), TPRINT(10) COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO, + ANAJAC, SOLAV, TPRINT, NPRINT C INTEGER I DO 10 I = 1, NPTS Y(1,I) = 0.0 10 CONTINUE RETURN END SUBROUTINE SPDEF (T,X, NPD, U, DUDX, C, Q, R, IRES) C C Routine to describe the body of the PDE system. C The PDE is written as C NPDE k -m m C sum C (x,t,u,u ) u + Q (x,t,u,u ) = x (x R (x,t,u,u ) ) C k=1 jk x t j x j x x C the functions C, Q and R must be defined in this routine. C INTEGER NPD, IRES REAL T, X REAL U(NPDE), DUDX(NPDE), C(NPDE,NPDE), Q(NPDE), R(NPDE) C INTEGER NPDE, NPRINT LOGICAL ANAJAC, SOLAV REAL XL, XR, T0, TE REAL DUMPRO(5), TPRINT(10) COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO, + ANAJAC, SOLAV, TPRINT, NPRINT REAL ALPHA, BETA, GAMMA, EPS C ALPHA = DUMPRO(2) BETA = DUMPRO(3) GAMMA = DUMPRO(4) EPS = DUMPRO(5) C(1,1) = ALPHA Q(1) = -GAMMA*EXP(U(1)/(1+EPS*U(1))) R(1) = BETA*DUDX(1) RETURN END SUBROUTINE BNDR (T, BETA, GAMMA, U, DUDX, NPD, LEFT, IRES) C C Boundary conditions routine C The boundary conditions are written as C BETA (x,t) R (x,t,u,u ) = GAMMA (x,t,u,u ) C j j x j x C The functions BETA and GAMMA should be defined in this routine. C INTEGER NPD, IRES LOGICAL LEFT REAL T REAL BETA(NPDE), GAMMA(NPDE), U(NPDE), DUDX(NPDE) C INTEGER NPDE, NPRINT LOGICAL ANAJAC, SOLAV REAL XL, XR, T0, TE REAL DUMPRO(5), TPRINT(10) COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO, + ANAJAC, SOLAV, TPRINT, NPRINT C IF (LEFT) THEN BETA(1) = 1.0 GAMMA(1) = 0.0 ELSE BETA(1) = 0.0 GAMMA(1) = U(1) - 0.0 ENDIF RETURN END SUBROUTINE UEXACT (X, T, U) C C Exact solution C REAL X, T REAL U(*) RETURN END C C####################################################################### C C PRBDSH : problem dependent routines for third example problem C (Burgers' equation) C C####################################################################### C SUBROUTINE INIPRB (TEXT) CHARACTER TEXT*80 C C ---------------------------------------------------------------------- C C Burgers' equation C u_t = -u.u_x + eps.u_xx, 0 < x < 1, t > 0 C Dirichlet boundary conditions C Exact solution available (see SUBROUTINE UEXACT) C C ---------------------------------------------------------------------- C C Initialize /PROBLM/ C INTEGER NPDE, NPRINT LOGICAL ANAJAC, SOLAV REAL XL, XR, T0, TE REAL DUMPRO(5), TPRINT(10) COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO, + ANAJAC, SOLAV, TPRINT, NPRINT C INTEGER M REAL EPS C NPDE = 1 M = 0 XL = 0.0 XR = 1.0 T0 = 0.0 TE = 1.0 ANAJAC = .FALSE. SOLAV = .TRUE. NPRINT = 3 TPRINT(1) = 0.25 TPRINT(2) = 0.55 TPRINT(3) = 1.0 EPS = 1E-3 TEXT = ' Burgers, double wave, eps=' WRITE(TEXT(28:80),'(F7.5)') EPS DUMPRO(1) = M DUMPRO(2) = EPS RETURN END SUBROUTINE UINIT (NPD, NPTS, Y) C C Routine for PDE initial values. C Entry: C Y(NPDE+1,i) = x_i; uniform mesh, generated by package C Exit: C Y(NPDE+1,i) = x_i; mesh, optionally changed by user C Y( k,i) = u_k(x_i,t0); initial value of k-th component C i = 1,.., NPTS C INTEGER NPD, NPTS REAL Y(NPDE+1,NPTS) C INTEGER NPDE, NPRINT LOGICAL ANAJAC, SOLAV REAL XL, XR, T0, TE REAL DUMPRO(5), TPRINT(10) COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO, + ANAJAC, SOLAV, TPRINT, NPRINT INTEGER I C DO 10 I = 1, NPTS CALL UEXACT (Y(NPDE+1,I), T0, Y(1,I)) 10 CONTINUE RETURN END SUBROUTINE SPDEF (T,X, NPD, U, DUDX, C, Q, R, IRES) C C Routine to describe the body of the PDE system. C The PDE is written as C NPDE k -m m C sum C (x,t,u,u ) u + Q (x,t,u,u ) = x (x R (x,t,u,u ) ) C k=1 jk x t j x j x x C the functions C, Q and R must be defined in this routine. C INTEGER NPD, IRES REAL T, X REAL U(NPDE), DUDX(NPDE), C(NPDE,NPDE), Q(NPDE), R(NPDE) C INTEGER NPDE, NPRINT LOGICAL ANAJAC, SOLAV REAL XL, XR, T0, TE REAL DUMPRO(5), TPRINT(10) COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO, + ANAJAC, SOLAV, TPRINT, NPRINT REAL EPS EPS = DUMPRO(2) C(1,1) = 1.0 Q(1) = U(1)*DUDX(1) R(1) = EPS*DUDX(1) RETURN END SUBROUTINE BNDR (T, BETA, GAMMA, U, UX, NPD, LEFT, IRES) C C Boundary conditions routine C The boundary conditions are written as C BETA (x,t) R (x,t,u,u ) = GAMMA (x,t,u,u ) C j j x j x C The functions BETA and GAMMA should be defined in this routine. C INTEGER NPD, IRES LOGICAL LEFT REAL T REAL BETA(NPDE), GAMMA(NPDE), U(NPDE), UX(NPDE) C INTEGER NPDE, NPRINT LOGICAL ANAJAC, SOLAV REAL XL, XR, T0, TE REAL DUMPRO(5), TPRINT(10) COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO, + ANAJAC, SOLAV, TPRINT, NPRINT C REAL X IF (LEFT) THEN X = XL ELSE X = XR ENDIF CALL UEXACT (X, T, GAMMA) BETA(1) = 0.0 GAMMA(1) = U(1) - GAMMA(1) RETURN END SUBROUTINE UEXACT (X, T, U) C C Exact solution C REAL X, T REAL U(NPDE) C INTEGER NPDE, NPRINT LOGICAL ANAJAC, SOLAV REAL XL, XR, T0, TE REAL DUMPRO(5), TPRINT(10) COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO, + ANAJAC, SOLAV, TPRINT, NPRINT C REAL EPS, R1, R2, R3, R123 EPS = DUMPRO(2) R1 = EXP(-(X-0.5)/(20*EPS)-99*T/(400*EPS)) R2 = EXP(-(X-0.5)/(4*EPS)-3*T/(16*EPS)) R3 = EXP(-(X-0.375)/(2*EPS)) R123 = R1+R2+R3 U(1) = 1.0 - (0.9*R1 + 0.5*R2) / R123 RETURN END C C####################################################################### C C DRIVER : test program to use the moving-grid interface in a DASSL C environment C C####################################################################### C PROGRAM DRIVER C C ---------------------------------------------------------------------- C C Main program MoL adaptive grid interface for DASSL C Calls problem initializer, C Initializes DASSL parameters + grid/solution C Put semi-discrete PDE system + Dorfi&Drury grid equation in DASSL C Write grid and solution at specific steps (TPRINT) to outputfile C C Problem choice by loading the specific problem file with the modules: C C SUBROUTINE INIPRB (TEXT) C CHARACTER TEXT*80 C Initialize /PROBLM/ C C SUBROUTINE UINIT (NPDE, NPTS, Y) C INTEGER NPDE, NPTS C REAL Y(NPDE+1,NPTS) C Initial solution; optionnally redefinition of (uniform) grid C C SUBROUTINE SPDEF (T,X,NPDE, U, DUDX, C, Q, R, IRES) C INTEGER NPDE, IRES C REAL T, X C REAL U(NPDE), DUDX(NPDE), C(NPDE,NPDE), Q(NPDE), R(NPDE) C PDE defining functions C, Q, R C C SUBROUTINE BNDR (T, BETA, GAMMA, U, UX, NPDE, LEFT, IRES) C INTEGER NPDE, IRES C LOGICAL LEFT C REAL T C REAL BETA(NPDE), GAMMA(NPDE), U(NPDE), UX(NPDE) C Boundary function C C SUBROUTINE UEXACT (X, T, U) C REAL X, T C REAL U(NPDE) C Exact solution (only called if SOLAV=TRUE) C INTEGER MXNPDE, MXNEQ, MXLIW, MXLRW, MXNRWK PARAMETER (MXNPDE = 2, MXNEQ = 303) PARAMETER (MXLIW = 20+MXNEQ, MXLRW = (6*MXNPDE+20)*MXNEQ) PARAMETER (MXNRWK = MXNEQ+(6+MXNPDE)*MXNPDE) INTEGER INFO(15), IWORK(MXLIW), IPAR(1) REAL Y(MXNEQ), YPRIME(MXNEQ), RTOL(1), ATOL(1), RWORK(MXLRW), + RWK(MXNRWK) C C Y : Grid and solution values C YPRIME: Derivative of Y C INFO : Task_communication with DASSL C RTOL : Relative tolerance for DASSL C ATOL : Absolute tolerance for DASSL C RWORK : (Optional) REAL input values for DASSL C IWORK : (Optional) INTEGER input values for DASSL C RWK : Workspace SKMRES C C COMMONs used: C INTEGER NPTS, LUNR, LUNI COMMON /MOLIF/ NPTS, LUNR, LUNI C C NPTS : # grid points (needed in residual routine) C LUNR : log. unit # output file for results C LUNI : log. unit # run information file C INTEGER NPDE, NPRINT LOGICAL ANAJAC, SOLAV REAL XL, XR, T0, TE REAL DUMPRO(5), TPRINT(10) COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO, + ANAJAC, SOLAV, TPRINT, NPRINT C C NPDE # partial differential equations C XL Left boundary C XR Right boundary C T0 Starting time C TE Final time C DUMPRO Storage reserved for problem parameters C DUMPRO(1) = M (space coordinate type) C ANAJAC TRUE, if user specified Jacobian C (SUBROUTINE JAC, see documentation of DAE solver) C SOLAV TRUE, if exact solution is available C (SUBROUTINE UEXACT) C TPRINT NPRINT output times C NPRINT DIMENSION TPRINT C EXTERNAL INIPRB, OUT, RESID, RUNOUT, SETSKM, SDASSL C C --------------------------------------------------------------------- C CHARACTER IDENT*30, TEXT*80 INTEGER I, IBAND, IDID, IPRINT, IRES, LIW, LRW, M, MAXORD, NCTF, + NEQ, NETF, NFCN, NOINV, NRWK, NSTEPS REAL ALPHA, KAPPA, T, TAU, TOUT C C ccc Open files for results and run info LUNR = 4 LUNI = 8 OPEN (UNIT=LUNR, FILE='RESULT') OPEN (UNIT=LUNI, FILE='RUNINF') C C Run identification IDENT = 'ACM-TOMS, Ex.I' C C ccc Initialize /PROBLM/ CALL INIPRB (TEXT) C TEXT: Problem information WRITE(LUNR,'(A80)') TEXT WRITE(LUNI,'(A80)') TEXT C C ccc Initialize method parameters, grid, solution and derivative at T0 C DASSL input C C Method parameters; for Burgers equation (PRBDSH file) TAU = 1E-3 NPTS = 21 M = NINT(DUMPRO(1)) TAU = 0.0 KAPPA = 2.0 ALPHA = 0.01 NRWK = MXNRWK C C Call initialization routine SETSKM; determine initial grid; C store initial values of U in Y CALL SETSKM (NEQ, NPDE, NPTS, XL,XR, TAU, KAPPA, ALPHA, + Y, RWK, NRWK, M, T0, IBAND, IRES) IF (IRES .EQ. -1) THEN STOP 'Error in SETSKM' ENDIF C C Initial Yprime = 0 DO 1 I = 1, NEQ YPRIME(I) = 0.0 1 CONTINUE C C Initialize DASSL input DO 5 I = 1, 15 INFO(I) = 0 5 CONTINUE C Both tolerances are scalars (default) ATOL(1) = 1E-3 RTOL(1) = 1E-3 C Intermediate output mode INFO( 3) = 1 C Analytical Jacobian IF (ANAJAC) INFO(5) = 1 C Banded Jacobian INFO( 6) = 1 IWORK(1) = IBAND IWORK(2) = IBAND C Default maximum integration order MAXORD = 5 C Y, YPRIME probably inconsistent at T0 INFO(11) = 1 C C ccc Check length arrays IF (NEQ .GT. MXNEQ) THEN PRINT *, 'MXNEQ too small, needed:', NEQ STOP 'Workspace too small' ENDIF LIW = 20+NEQ IF (LIW .GT. MXLIW) THEN PRINT *, 'MXLIW too small, needed:', LIW STOP 'Workspace too small' ENDIF LRW = 40+(MAXORD+6+3*IBAND+1)*NEQ + 2*(NEQ/(2*IBAND+1)+1) IF (LRW .GT. MXLRW) THEN PRINT *, 'MXLRW too small, needed:', LRW STOP 'Workspace too small' ENDIF C C ccc Write run header to files TEXT = ' MoL, PDE+D&D int.face; DAE int.: DASSL' I = 40 TEXT(I:80) = '; ID:' WRITE(TEXT(I+6:80),'(A30)') IDENT WRITE(LUNR,'(A80)') TEXT WRITE(LUNI,'(A80)') TEXT I = 1 TEXT(I:80) = ' NPTS=' WRITE(TEXT(I+6:I+8),'(I3)') NPTS I = I+9 TEXT(I:I+6) = '; RTOL=' WRITE(TEXT(I+7:I+14),'(E8.3)') RTOL(1) I = I+15 TEXT(I:I+6) = ', ATOL=' WRITE(TEXT(I+7:I+14),'(E8.3)') ATOL(1) WRITE(LUNR,'(A80)') TEXT WRITE(LUNI,'(A80)') TEXT I = 1 TEXT(I:80) = ' TAU=' WRITE(TEXT(I+5:I+12),'(E8.3)') TAU I = I+13 TEXT(I:I+7) = ', KAPPA=' WRITE(TEXT(I+8:I+15),'(E8.3)') KAPPA I = I+16 TEXT(I:I+7) = ', ALPHA=' WRITE(TEXT(I+8:I+15),'(E8.3)') ALPHA WRITE(LUNR,'(A80)') TEXT WRITE(LUNI,'(A80)') TEXT C C C ccc Write initial grid and solution to output file CALL OUT (T0, Y, RWK(1), RWK(NRWK-NPTS+1)) C C C C ccc DASSL loop C Call DASSL with as residual routine RESID, the enveloping routine C of SKMRES T = T0 DO 10 IPRINT = 1, NPRINT TOUT = TPRINT(IPRINT) 15 CALL SDASSL (RESID, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL, + IDID, RWORK, LRW, IWORK, LIW, RWK, IPAR, JAC) IF (IDID .EQ. 1) THEN C One step in intermediate-output mode C C Write Run info to file CALL RUNOUT(RWORK, IWORK) C GOTO 15 ENDIF C C Write grid and solution to output file CALL OUT(T, Y, RWK(1), RWK(NRWK-NPTS+1)) C C Give run statistics until t = TOUT NSTEPS = IWORK(11) NFCN = IWORK(12) NOINV = IWORK(13) C NOSOLV = NFCN NETF = IWORK(14) NCTF = IWORK(15) WRITE(LUNR,*) 'Statistics:' WRITE(LUNR,*) ' FNS, JACS:', NFCN, NOINV WRITE(LUNR,*) ' STEPS, ETF, CTF:', NSTEPS, NETF, NCTF IF (IDID .LT. 0) GOTO 900 10 CONTINUE CLOSE(LUNR) CLOSE(LUNI) STOP 'Ready' C C ccc Error return 900 CONTINUE WRITE(LUNR,*) 'IDID=', IDID STOP 'DASSL error' END SUBROUTINE RESID (T, Y, YPRIME, DELTA, IRES, RWK, IPAR) INTEGER IRES INTEGER IPAR(*) REAL T REAL Y(*), YPRIME(*), DELTA(*), RWK(*) C C Determine DAE system for DASSL C residual DELTA = A.YPRIME - G C C Entry: C T : Current time C Y : Current grid + solution C YPRIME: Time derivative of Y C Exit: C DELTA : A.YPRIME - G C IRES : -1, if user thinks solution is illegal or ico node crossing C C --------------------------------------------------------------------- C INTEGER NPDE, NPRINT LOGICAL ANAJAC, SOLAV REAL XL, XR, T0, TE REAL DUMPRO(5), TPRINT(10) COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO, + ANAJAC, SOLAV, TPRINT, NPRINT C INTEGER NPTS, LUNR, LUNI COMMON /MOLIF/ NPTS, LUNR, LUNI C SAVE /PROBLM/, /MOLIF/ C C EXTERNAL SKMRES C C --------------------------------------------------------------------- C INTEGER NEQ, NRWK C NEQ = NPTS*(NPDE+1) NRWK = NEQ + (6+NPDE)*NPDE C C ccc Call SKMRES with IRES=0 to compute total residual CALL SKMRES (NEQ, T, Y, YPRIME, DELTA, IRES, RWK, NRWK) IF (IRES .EQ. 2) THEN IRES = -2 RETURN ELSE IF (IRES .EQ. 3) THEN WRITE(LUNI,999) T 999 FORMAT(' Illegal solution at T= ', E12.4) IRES = -1 RETURN ENDIF C RETURN END SUBROUTINE OUT (T, Y, UEX, ERR) REAL T REAL Y(NPDE+1,NPTS), UEX(NPDE,NPTS), ERR(NPTS) C C Write grid, solution and, if possible, error in sol. to output file C C Entry: C T : Current time C Y : Current grid + solution C UEX : Workspace to store exact solution C UERR : Workspace to store error for a component in each gridpoint C C --------------------------------------------------------------------- C INTEGER NPDE, NPRINT LOGICAL ANAJAC, SOLAV REAL XL, XR, T0, TE REAL DUMPRO(5), TPRINT(10) COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO, + ANAJAC, SOLAV, TPRINT, NPRINT C INTEGER NPTS, LUNR, LUNI COMMON /MOLIF/ NPTS, LUNR, LUNI C SAVE /PROBLM/, /MOLIF/ C REAL INFNRM, L2NRM EXTERNAL INFNRM, L2NRM, UEXACT C C ---------------------------------------------------------------------- C INTEGER NPDEMX PARAMETER (NPDEMX = 4) INTEGER IC, J, NPDE1 REAL ERRINF REAL ERRTWO(NPDEMX) C NPDE1 = NPDE+1 IF (SOLAV) THEN DO 1 J = 1, NPTS CALL UEXACT(Y(NPDE1,J),T,UEX(1,J)) 1 CONTINUE ENDIF WRITE(LUNR,'(3H-T=,E13.5)') T WRITE(LUNR,*) 'X(S,TN):' WRITE(LUNR,'(5E23.14)') (Y(NPDE1,J), J=1, NPTS) DO 10 IC = 1, NPDE WRITE(LUNR,*) 'U(X(S,TN),TN), COMP:', IC WRITE(LUNR,'(5E23.14)') (Y(IC,J), J=1, NPTS) IF (SOLAV) THEN DO 20 J = 1, NPTS ERR(J) = Y(IC,J) - UEX(IC,J) 20 CONTINUE ERRINF = INFNRM (ERR, NPTS) ERRTWO(IC) = L2NRM (ERR, Y(NPDE1,1), NPDE1, NPTS) WRITE(LUNR,*) 'ERR_U:' WRITE(LUNR,'(5E23.14)') (ERR(J), J=1, NPTS) WRITE(LUNR,*) 'MAX. NORM:', ERRINF WRITE(LUNR,*) 'TWO NORM:', ERRTWO(IC) ENDIF 10 CONTINUE RETURN END SUBROUTINE RUNOUT (RWORK, IWORK) INTEGER IWORK(*) REAL RWORK(*) C C Write statistics after each successful step to run info file C C Entry: C RWORK: REAL info DASSL C IWORK: INTEGER info DASSL C C --------------------------------------------------------------------- C INTEGER NPTS, LUNR, LUNI COMMON /MOLIF/ NPTS, LUNR, LUNI C SAVE /MOLIF/ C C --------------------------------------------------------------------- C INTEGER IQ REAL H, T C T = RWORK(4) H = RWORK(7) IQ = IWORK(8) WRITE (LUNI,'(6H Time=,E13.5, 4H; H=,E13.5, 8H; Order=,I2)') + T, H, IQ RETURN END REAL FUNCTION INFNRM (V, N) INTEGER N REAL V(N) C C Exit: INFNRM = (J=1,N) MAX !V(J)! C C ---------------------------------------------------------------------- C INTEGER J C INFNRM = 0.0 DO 10 J = 1, N INFNRM = MAX(INFNRM,ABS(V(J))) 10 CONTINUE RETURN END REAL FUNCTION L2NRM (V, X, INCX, N) INTEGER INCX, N REAL V(N), X(INCX,N) C C Exit: L2NRM = SQRT((J=2,N) SUM ((X(J)-X(J-1))/2.(V(J)^2+V(J-1)^2)) C C ---------------------------------------------------------------------- C INTEGER J REAL VJM1S, VJS C L2NRM = 0.0 VJM1S = V(1)*V(1) DO 10 J = 2, N VJS = V(J)*V(J) L2NRM = L2NRM + (X(1,J)-X(1,J-1))/2*(VJS+VJM1S) VJM1S = VJS 10 CONTINUE L2NRM = SQRT(L2NRM) RETURN END C C####################################################################### C C SPMDIF : moving-grid interface routines C C####################################################################### C C----------------------------------------------------------------------- C C Moving grid discretization module SPMDIF C ---------------------------------------- C This module discretizes systems of partial differential equations C in one space variable on a moving grid. The class of equations that C can be handled is given by C C NPDE k -m m C sum C (x,t, u, u ) u + Q (x,t, u, u ) = x (x R (x,t, u, u )) C k=1 j,k - -x t j - -x j - -x x C C where 1 NPDE T C u = ( u , ... , u ) , j = 1,... , NPDE, C - C k C and u is the partial derivative wrt time of the k-th component of u. C t C C The functions C, Q, and R are assumed to be continuous w.r.t. the C space variable. C C The independent variables x and t satisfy x < x < x with x and x C L R L R C fixed and t > t . C 0 C The boundary conditions have the form C C BETA(x,t).R(x,t,u,u ) = GAMMA(x,t,u,u ) at x = x , x , C - -x - -x L R C C where not all of the functions BETA and GAMMA are set to zero. C C The initial conditions are given by C 0 C u (x,t ) = u (x) for x <= x <= x . C - 0 - L R C The discretization method for the PDE in Lagrangian formulation C used by this module is based on a lumped Galerkin / Petrov-Galerkin C method and evaluates the PDE functions in a point between C the (moving) grid points. C C References: C Fixed-grid spatial discretization C Skeel R.D. and Berzins M. C A Method for the Spatial Discretisation of Parabolic C Equations in one Space Variable. C Leeds Report no 217, C Dept. of Computer Studies, The University. C Grid movement C Verwer J.G., Blom J.G., Furzeland R.M. and Zegeling P.A. C A Moving-Grid Method for One-Dimensional PDEs based on C the Method of Lines. C Report NM-R8818, C Centre for Mathematics and Computer Science, Amsterdam. C Interface C Blom J.G. and Zegeling P.A. C A Moving-Grid Interface for Systems of One-Dimensional C Time-Dependent Partial Differential Equations. C Report NM-R8904, C Centre for Mathematics and Computer Science, Amsterdam. C (submitted to ACM TOMS) C C---------------------------------------------------------------------- C C How to use this module C ---------------------- C 1. Set NPDE = # PDEs to be solved. C Set NPTS = # mesh points to be used. C (NC=NPTS-2 is # internal points) C Set M for space coordinate type C = 0 for Cartesian, = 1 for cylindrical, = 2 for spherical. C Specify a workspace of size at least (NPDE+1)*NPTS+(6+NPDE)*NPDE C for use by the routine SKMRES which defines the DAE system being C solved by the integrator. C C Call the initialization routine SETSKM, see the documentation at C the head of this routine for the precise details of the call. C C Set TS and TOUT for start and end integration times. C Initialize data as required for time integration, C - see documentation of DAE solver. C Call the DAE solver with as residual routine SKMRES or an C enveloping routine to satisfy the header requirements. C C 2. Provide a set of routines which describe the precise form of the C PDEs to be solved. Three routines must be provided and the names C of these routines are fixed. These routines are: C SPDEF forms the functions C, Q and R of the PDE in a C given x-point. C BNDR forms the functions BETA and GAMMA associated with the C boundary conditions for the PDE. C UINIT supplies the initial values of the PDE part. C An initial uniform grid is generated by SETSKM and C provided in Y(NPDE+1,I), I=1,NPTS. If required, a user C can redefine the mesh in a nonuniform way. C The headers of these routines are: C C SUBROUTINE SPDEF (T, X, NPDE, U, DUDX, C, Q, R, IRES) C INTEGER NPDE, IRES C REAL T, X C REAL U(NPDE), DUDX(NPDE), C(NPDE,NPDE), Q(NPDE), R(NPDE) C C SUBROUTINE BNDR (T, BETA, GAMMA, U, DUDX, NPDE, LEFT, IRES) C INTEGER NPDE, IRES C LOGICAL LEFT C REAL T C REAL BETA(NPDE), GAMMA(NPDE), U(NPDE), DUDX(NPDE) C C SUBROUTINE UINIT (NPDE, NPTS, Y) C INTEGER NPDE, NPTS C REAL Y(NPDE+1,NPTS) C C C Example problem C --------------- C The easiest way to describe how the problem description routines C should be written is by a simple example. Consider the following C problem from electrodynamics C u = eps.p.u - g(u-v) C t xx C and (so m = 0 and NPDE = 2) C v = p.v + g(u-v) C t xx C with C g(z) = exp(eta.z/3) - exp(-2.eta.z/3) , C 0 <= x <= 1 and 0 <= t <= 4; C eps = 0.143, p = 0.1743, and eta = 17.19. C C The left boundary condition (LEFT = .TRUE.) is given by C u = 0 and v = 0 at x = 0, C x C the right boundary condition (LEFT = .FALSE.) is C u = 0 and v = 0 at x = 1, C x C and the initial conditions are C u = 1 and v = 0 at t = 0. C C The routines UINIT, SPDEF and BNDR are listed below. C The component u of the PDE at the i-th grid point is held as Y(1,i) C in the package, the component v as Y(2,i); the i-th grid point C itself is stored in Y(3,i). C C C C SUBROUTINE UINIT (NPDE, NPTS, Y) C C Routine for PDE initial values. C Entry: C Y(NPDE+1,i) = x_i; uniform mesh, generated by package C Exit: C Y(NPDE+1,i) = x_i; mesh, optionally changed by user C Y( k,i) = u_k(x_i,t0); initial value of k-th component C i = 1,.., NPTS C C INTEGER NPDE, NPTS C REAL Y(NPDE+1,NPTS) C C INTEGER I C C DO 10 I = 1, NPTS C Y(1,I) = 1.0 C Y(2,I) = 0.0 C 10 CONTINUE C C RETURN C END C C C C SUBROUTINE SPDEF (T, X, NPDE, U, DUDX, C, Q, R, IRES) C C Routine to describe the body of the PDE system. C The PDE is written as C NPDE k -m m C sum C (x,t,u,u ) u + Q (x,t,u,u ) = x (x R (x,t,u,u ) ) . C k=1 jk x t j x j x x C The functions C, Q and R must be defined in this routine. C C INTEGER NPDE, IRES C REAL T, X C REAL U(NPDE), DUDX(NPDE), C(NPDE,NPDE), Q(NPDE), R(NPDE) C C INTEGER J, K C REAL EPS, ETA, GZ, P, Z C DATA EPS /0.143/, ETA /17.19/, P /0.1743/ C C DO 10 K = 1, NPDE C DO 20 J = 1, NPDE C C(J,K) = 0.0 C 20 CONTINUE C C(K,K) = 1.0 C 10 CONTINUE C C Z = U(1) - U(2) C GZ = EXP(ETA*Z/3) - EXP(-2*ETA*Z/3) C Q(1) = GZ C Q(2) = -GZ C C R(1) = EPS*P * DUDX(1) C R(2) = P * DUDX(2) C C RETURN C END C C C C SUBROUTINE BNDR (T, BETA, GAMMA, U, DUDX, NPDE, LEFT, IRES) C C Boundary conditions routine C The boundary conditions are written as C BETA (x,t) R (x,t,u,u ) = GAMMA (x,t,u,u ) C j j x j x C The functions BETA and GAMMA should be defined in this routine. C C INTEGER NPDE, IRES C LOGICAL LEFT C REAL T C REAL BETA(NPDE), GAMMA(NPDE), U(NPDE), DUDX(NPDE) C C IF (LEFT) THEN C BETA (1) = 1.0 C GAMMA(1) = 0.0 C BETA (2) = 0.0 C GAMMA(2) = U(2) C ELSE C BETA (1) = 0.0 C GAMMA(1) = U(1) - 1.0 C BETA (2) = 1.0 C GAMMA(2) = 0.0 C ENDIF C C RETURN C END C SUBROUTINE SETSKM (NEQN, NPDE, NPTS, XL, XR, TAU, KAPPA, ALPHA, + Y, RWK, NRWK, M, TS, IBAND, IRES) C C----------------------------------------------------------------------- C Purpose: C ------- C Initializing routine for moving-grid spatial discretization. C C Parameters: C ---------- INTEGER NEQN, NPDE, NPTS, NRWK, M, IBAND, IRES REAL XL, XR, TAU, KAPPA, ALPHA, TS REAL Y(*), RWK(NRWK) C C NEQN Exit: the size of the DAE system generated when the PDE + C the grid equations are discretized. This value is (NPDE+1).NPTS. C NPDE Entry: the number of PDEs. C NPTS Entry: the number of spatial mesh points, including the C boundary points. C XL Entry: left boundary point. C XR Entry: right boundary point. C TAU Entry: time-smoothing parameter. C If the initial grid satisfies the grid equation with TAU=0 at C TS=0, TAU can be chosen equal to zero. If this is not the case C and if the initial grid has to be adapted, or if time-smoothing C is desired a typical value of TAU = 1E-3, but TAU should be C related to the time scale of the problem. C KAPPA Entry: spatial smoothing parameter (REAL). C KAPPA = 2.0 was found to be satisfying for all problems tested. C For less spatial smoothing KAPPA = 1.0 will suffice. C ALPHA Entry: monitor regularizing parameter. C ALPHA = 0.01 is recommended (for a well-scaled system of PDEs) C Y Exit: array of length >= (NPDE+1).NPTS that contains the initial C (uniformly spaced) grid and the corresponding initial PDE C solution values. This array must be passed across as a one- C dimensional array of length NEQN to the DAE solver. This C array is ordered as C PDE comp. : Y((NPDE+1)*l + j) l=0,...,NPTS-1, C j=1,...,NPDE C grid points: Y((NPDE+1)*(l+1)) l=0,...,NPTS-1. C RWK workspace of length NRWK for the residual routine SKMRES which C actually performs the semi-discretization of the PDEs and C defines the grid equations. C NRWK Entry: dimension of workspace RWK. C NRWK must be >= (NPDE+1).NPTS + (6+NPDE).NPDE. C M Entry: integer >= 0 which determines the coordinate system used. C 0: Cartesian coordinates, C 1: cylindrical polar coordinates, C 2: spherical polar coordinates. C TS Entry: the time at which the integration starts. C IBAND Exit: an upper bound on the half bandwidth of the Jacobian C matrix when this module is used. (If the DAE solver is called C with banded matrix routines this parameter should be C supplied to MATSET (SPRINT) or to DASSL (IWORK(1) and IWORK(2)). C IRES Exit: this parameter is set to -1 if an error is found by C this routine. C C----------------------------------------------------------------------- C----------------------------------------------------------------------- C C From here the comments are only meant as aid and assistance to C understand the program. C C Four parameters are passed across from here in C COMMON /SPSKM/ NPDE1, NC, M, SING C C NPDE1 = NPDE+1 the number of PDEs + 1 (for the grid equation). C NC = NPTS-2 the number of internal mesh points. C M = M_user = 0,1,2, if resp., Cartesian, cylindrical or C spherical polar coordinates in use. C SING = .TRUE. if PDE has a polar singularity. C C A common block filled with method parameters is initialized C in this routine C COMMON /METPAR/ RTAU, RKAPPA, ALFA C C RTAU time-smoothing parameter grid equation (= TAU) C RKAPPA spatial smoothing parameter grid equation (= KAPPA) C ALFA monitor constant (= ALPHA) C C A common block filled with machine constants is also initialized C in this routine C COMMON /MACH/ NERR, SRELPR C C NERR logical unit number of error unit C SRELPR machine eps as determined by MACHAR C C C Detailed description of workspace: C --------------------------------- C Size: NRWK must be >= (NPDE+1)*NPTS + (6+NPDE)*NPDE C C RWK( 1:.+(NPDE+1)*NPTS) G(NPDE+1,0:NC+1), part of residual not C dependent on time-derivative. C RWK(IW1:.+ NPDE) UKSI(NPDE), solution values at evaluat. point C RWK(IW2:.+ NPDE) UXKSI(NPDE), space derivs. at evaluat. point C RWK(IW3:.+ NPDE) BETA(NPDE), boundary function BETA C RWK(IW4:.+ NPDE) GAMMA(NPDE), boundary function GAMMA C RWK(IW5:.+ NPDE) RC(NPDE), flux at evaluation point C RWK(IW6:.+ NPDE) QC(NPDE), source term at evaluation point C RWK(IW7:.+ NPDE*NPDE) CC(NPDE,NPDE), udot factor at evaluat. point C C----------------------------------------------------------------------- C CHARACTER*6 PDCODE COMMON /DISCHK/ PDCODE C INTEGER NPDE1, NC, MM LOGICAL SING COMMON /SPSKM/ NPDE1, NC, MM, SING C REAL RTAU, RKAPPA, ALFA COMMON /METPAR/ RTAU, RKAPPA, ALFA C INTEGER NERR REAL SRELPR COMMON /MACH/ NERR, SRELPR C SAVE /DISCHK/, /SPSKM/, /METPAR/, /MACH/ C EXTERNAL MACHAR, YINIT C C----------------------------------------------------------------------- C INTEGER IW1, IW2, IW3, IW4, IW5, IW6, IW7, IWE INTEGER IBETA, IT,IRND, NGRD, MACHEP, NEGEP, IEXP, MINEXP, + MAXEXP REAL EPS, EPSNEG, XMIN, XMAX NPDE1 = NPDE+1 NC = NPTS-2 MM = M SING = M .GE. 1 .AND. ABS(XL) .LE. SRELPR*(XR-XL) RTAU = TAU RKAPPA = KAPPA ALFA = ALPHA NERR = 8 CALL MACHAR (IBETA, IT,IRND, NGRD, MACHEP, NEGEP, IEXP, MINEXP, + MAXEXP, EPS, EPSNEG, XMIN, XMAX) SRELPR = MAX (EPS, EPSNEG) C Fill IBAND; ML = MU=2*NPDE1 IBAND = 2*NPDE1 NEQN = NPDE1*NPTS IW1 = 1 + NEQN IW2 = IW1 + NPDE IW3 = IW2 + NPDE IW4 = IW3 + NPDE IW5 = IW4 + NPDE IW6 = IW5 + NPDE IW7 = IW6 + NPDE IWE = IW7 + NPDE*NPDE - 1 IF (IWE .GT. NRWK) THEN WRITE(NERR,'(38H SETSKM - ERROR REAL WORKSPACE OF SIZE, I10, + 28H, IS SMALLER THAN REQUIRED :, I10)') NRWK, IWE IRES = -1 ENDIF IF (M .LT. 0) THEN WRITE(NERR,'(44H SETSKM - POLAR PARAMETER LESS THAN ZERO, M=, + I10)') M IRES = -1 END IF IF (IRES .EQ. -1) RETURN C C Initialize grid and PDE variables by appropriate calls. C CALL YINIT (NPDE, NPTS, XL, XR, Y) C PDCODE = 'SPSKLM' RETURN END SUBROUTINE YINIT (NPDE, NPTS, XL, XR, Y) INTEGER NPDE, NPTS REAL XL, XR REAL Y(NPDE+1,0:NPTS-1) C INTEGER NPDE1, NC, M LOGICAL SING COMMON /SPSKM/ NPDE1, NC, M, SING SAVE /SPSKM/ C EXTERNAL UINIT C INTEGER I REAL DX, XI C C Equidistant grid DX = (XR-XL)/(NC+1) DO 10 I = 0, NC+1 XI = XL+I*DX Y(NPDE1,I) = XI 10 CONTINUE CALL UINIT (NPDE, NPTS, Y) RETURN END SUBROUTINE SKMRES (NEQN, T, Y, YDOT, RES, IRES, RWK, NRWK) C C----------------------------------------------------------------------- C Purpose: C ------- C Enveloping routine to compute the residual of the PDE and of the grid C equations. SKMRES checks on node-crossing, partitions the workspace C and calls CWRESU for the spatial discretization and the computation C of the residual of the PDE in Lagrangian formulation and CWRESX for C the spatial discretization and the residual computation of the grid C equations. C C Parameters: C ---------- INTEGER NEQN, IRES, NRWK REAL T REAL Y(NEQN), YDOT(NEQN), RES(NEQN), RWK(NRWK) C C NEQN Entry: the size of the DAE system generated when the PDE + C the grid equations are discretized. C T Entry: evaluation time. C Y Entry: array of length NEQN containing the DAE vector consisting C of the spatial mesh and the corresponding initial PDE solution C values at time T. This array is ordered as C PDE comp. : Y((NPDE+1)*l + j) l=0,...,NPTS-1, C j=1,...,NPDE C grid points: Y((NPDE+1)*(l+1)) l=0,...,NPTS-1. C RES Exit: residual vector. C If IRES = -1 RES should contain only the part of the residual C dependent on the time-derivative, if IRES /= -1 RES should C contain the full residual A.ydot - g. C IRES Entry: see above. C Exit: 2, if setup routine SETSKM has not been called. C 3, if one of the DAE solutions in the vector Y is not C acceptable. C RWK working storage of length NRWK. C NRWK Entry: dimension of RWK. Should be >= NEQN + (6+NPDE)*NPDE. C C----------------------------------------------------------------------- C CHARACTER*6 PDCODE COMMON /DISCHK/ PDCODE C INTEGER NPDE1, NC, M LOGICAL SING COMMON /SPSKM/ NPDE1, NC, M, SING C INTEGER NERR REAL SRELPR COMMON /MACH/ NERR, SRELPR C SAVE /DISCHK/, /SPSKM/, /MACH/ C EXTERNAL CWRESU, CWRESX C C----------------------------------------------------------------------- C INTEGER I, IW1, IW2, IW3, IW4, IW5, IW6, IW7, J, NPDE IF (PDCODE .NE. 'SPSKLM') THEN WRITE(NERR,*) ' ERROR IN SKLMRES ROUTINE - THE SETUP ROUTINE'// + ' SETSKM WAS NOT CALLED PRIOR TO SPRINT ENTRY' IRES = 2 RETURN ENDIF NPDE = NPDE1-1 C Check on node-crossing DO 5 I = NPDE1, NEQN-NPDE1, NPDE1 IF (Y(I) .GE. Y(I+NPDE1)) THEN WRITE(NERR,'(30H SKMRES - NON-MONOTONOUS GRID,, + 22H VALUES OF GRID POINTS, I3,1H,,I3, + 4H ARE, E13.5,1H1,E13.5)') + I/NPDE1, I/NPDE1+1, Y(I), Y(I+NPDE1) IRES = 3 ENDIF 5 CONTINUE C Partition workspace IW1 = 1 + NEQN IW2 = IW1 + NPDE IW3 = IW2 + NPDE IW4 = IW3 + NPDE IW5 = IW4 + NPDE IW6 = IW5 + NPDE IW7 = IW6 + NPDE C Calculate A.ydot and g for Lagrangian PDE CALL CWRESU (T, Y, YDOT, NPDE1-1, NC, M, SING, + RWK(IW1), RWK(IW2), RWK(IW3), RWK(IW4), + RWK(IW5), RWK(IW6), RWK(IW7), + RES, RWK(1), IRES) IF (IRES .GE. 3) RETURN C Calculate A.ydot and g for grid equations CALL CWRESX (T, Y, YDOT, NPDE1, NC, RES, RWK(1), IRES) IF (IRES .GE. 3) RETURN IF (IRES .NE. -1) THEN C Full residual needed; RES = A.ydot - g DO 10 J = 1, NEQN RES(J) = RES(J) - RWK(J) 10 CONTINUE ENDIF RETURN END SUBROUTINE CWRESU (T, Y, YDOT, NPDE, NC, M, SING, + UKSI, UXKSI, BETA, GAMMA, RC, QC, CC, + AYDOT, G, IRES) C C----------------------------------------------------------------------- C Purpose: C ------- C Compute PDE part of residual equations A.ydot - g. C Return A.ydot in AYDOT and g in G to satisfy both C SPRINT and DASSL. C C Method: C ------ C The Lagrangian form of the PDE is: C NPDE .k k . C sum C (x,t, u, u ) (u - u x) + Q (x,t, u, u ) C k=1 j,k - -x x j - -x C C -m m C = x (x R (x,t, u, u )) C j - -x x C where 1 NPDE T C u = ( u , ... , u ) , j = 1,... , NPDE, C - C .k . C and u is the total time-derivative of the k-th comp. of u and x C is the derivative wrt to time of x. C C This equation is semi-discretized by a lumped finite-element method C (udot and ux.xdot lumped). C Integration over the l-1_th interval and over the l_th interval C both give an expression for the flux in X . Eliminating this value C l C gives a difference equation for l=1,...,N: C C . . C fR R (ksi ) - fR R (ksi ) = fS1 S (ksi ,U ) + fSl S (ksi ,U ) C l j l l-1 j l-1 l j l -l l-1 j l-1 -l C C with: C C m-mu mu C fR = zeta ksi , mu = -1 if PDE singular otherwise mu = m C l l l C C m+1 m+1 C fS1 = (zeta - X ) / (m+1) C l l l C C m+1 m+1 C fSl = (X - zeta ) / (m+1) C l-1 l l-1 C C . NPDE .p p . C S (ksi ,U ) = sum C (ksi ) [ U (X ) - U (X ) X ] + Q (ksi ) C j k -l p=1 jp k l x l l j k C C R , j_th component of flux evaluated at quadrature point ksi, C j C Q , j_th component of source term evaluated at quadrature point ksi, C j C C , element j,p of matrix multiplying u , evaluated at ksi. C jp t C C Left boundary equation, if non-singular: C C BETA (x ,t) R (x ) = GAMMA (x ,t, U , U (x )) C j L j L j L -0 -x L C C with C m . m C R (x ) = (ksi R (ksi ) - fS1 S (ksi ,U )) / x C j L 0 j 0 0 j 0 -0 L C C if singular: C . C S (ksi ,U )/(m+1) - R (ksi )/ksi = 0 C j 0 -0 j 0 0 C C Right boundary equation: C C BETA (x ,t) R (x ) = GAMMA (x ,t, U , U (x )) C j R j R j R -N+1 -x R C C with C . m C R (x ) = (fR R (ksi ) + fSl S (ksi ,U )) / x C j R N j N N j N -N+1 R C C C Parameters: C ---------- INTEGER NPDE, NC, M, IRES LOGICAL SING REAL T REAL Y(NPDE+1,0:NC+1), YDOT(NPDE+1,0:NC+1), + UKSI(NPDE), UXKSI(NPDE), BETA(NPDE), GAMMA(NPDE), + RC(NPDE), QC(NPDE), CC(NPDE,NPDE), + AYDOT(NPDE+1,0:NC+1), G(NPDE+1,0:NC+1) C C T Entry: evaluation time C Y Entry: solution and grid at time T. C (Y(1:NPDE,L): U_l, Y(NPDE+1,L): X_l) C YDOT Entry: derivative of Y at T. C NPDE Entry: # PDEs. C NC Entry: # internal grid points. C M Entry: coordinate system indicator. C SING Entry: true, if PDE has a polar singularity (M>0, x_L=0). C UKSI workspace to hold the solution value at an evaluation point. C UXKSI workspace to hold the space derivatives at an evaluation point. C BETA workspace to hold the boundary function BETA. C GAMMA workspace to hold the boundary function GAMMA C RC workspace to hold the PDE function R. C QC workspace to hold the PDE function Q. C CC workspace to hold the PDE function C. C AYDOT Exit: A.ydot part of the residual. C G Exit: g part of the residual. C IRES Exit: 3 if some user function indicated that a solution value C is unphysical. C C Local variables: C --------------- INTEGER MU REAL FSCL, FSC1, SCLMQ, SCL1MQ, + DENOMI, KSI, KSIMU, ZETA, ZETAMU, PHIL, PHILX C MU if sing. then -1 else m. C FSCL fS1_l. C FSC1 fSl_l+1. C SCLMQ S(ksi_l,udot_l) - Q(ksi_l). C SCL1MQ S(ksi_l,udot_l+1) - Q(ksi_l). C DENOMI 1 / [ (X_l,X_l+1) int y**(-m) dy ] C KSI quadrature point for l_th interval C KSIMU ksi**mu C ZETA zeta_l ** (m+1); if sing. and l=0 then C zeta = 0.0 C else (X_l,X_l+1) int y dy * denomi C ZETAMU zeta_l ** (m-mu) C PHIL 'left' trial function for l_th interval in eval. point ksi C NB. phi_l+1 = 1 - phil C PHILX deriv. of phi_l wrt x in eval. point ksi C NB. phi_l+1_x = - phil_x C C EXTERNAL BNDR, SPDEF C C ------------------------------------------------------------------- C INTEGER IP, J, L, NPDE1 REAL DENPHI, RCJDOT, RCJG, UXL, UXL1, X0, X0M, XL, XL1, XN1M NPDE1 = NPDE+1 X0 = Y(NPDE1,0) IF (SING) THEN MU = -1 ELSE MU = M ENDIF C C First interval, compute contribution to residual eq. in X_1 and C left boundary equation C L = 0 XL = X0 XL1 = Y(NPDE1,L+1) IF (.NOT. SING) THEN IF (M .EQ. 1) THEN DENOMI = 1/LOG(XL1/XL) ELSE DENOMI = (1-M)/(XL1**(1-M) - XL**(1-M)) ENDIF ENDIF IF (SING) THEN KSI = 2/3. * (XL1**3-XL**3) / (XL1**2-XL**2) KSIMU = 1/KSI ELSE IF (M .EQ. 1) THEN KSI = (XL1-XL) * DENOMI KSIMU = KSI ELSE IF (M .EQ. 2) THEN KSI = LOG(XL1/XL) * DENOMI KSIMU = KSI*KSI ELSE KSI = (XL1**(2-M)-XL**(2-M)) / (2-M) * DENOMI IF (M .EQ. 0) THEN KSIMU = 1.0 ELSE KSIMU = KSI**MU ENDIF ENDIF IF (SING) THEN ZETA = 0.0 ZETAMU = ZETA DENPHI = 1/(XL1*XL1-XL*XL) PHIL = (XL1*XL1-KSI*KSI)*DENPHI PHILX = -2*KSI*DENPHI ELSE ZETA = 0.5*(XL1*XL1-XL*XL) * DENOMI ZETAMU = 1.0 IF (M .EQ. 1) THEN PHIL = LOG(XL1/KSI) * DENOMI PHILX = -1/KSI * DENOMI ELSE IF (M .EQ. 0) THEN PHIL = (XL1 - KSI) * DENOMI PHILX = -DENOMI ELSE PHIL = (XL1**(1-M) - KSI**(1-M)) / (1-M) * DENOMI PHILX = -KSI**(-M) * DENOMI ENDIF ENDIF IF (M .EQ. 0) THEN X0M = 1.0 ELSE X0M = X0**M ENDIF C Get left boundary function values DO 5 J = 1, NPDE UXKSI(J) = (Y(J,1)-Y(J,0)) / (XL1-XL) 5 CONTINUE CALL BNDR (T, BETA, GAMMA, Y(1,0), UXKSI, + NPDE, .TRUE., IRES) IF (IRES .EQ. 3) RETURN C Compute U and Ux in evaluation point DO 10 J = 1, NPDE UKSI(J) = Y(J,L)*PHIL + Y(J,L+1)*(1-PHIL) UXKSI(J) = Y(J,L)*PHILX + Y(J,L+1)*(-PHILX) 10 CONTINUE C Get C, Q and R in evaluation point CALL SPDEF (T, KSI, NPDE, UKSI, UXKSI, CC, QC, RC, IRES) IF (IRES .EQ. 3) RETURN FSCL = (ZETA- XL**(M+1))/(M+1) FSC1 = (XL1**(M+1)-ZETA)/(M+1) DO 20 J = 1, NPDE SCLMQ = 0.0 SCL1MQ = 0.0 DO 30 IP = 1, NPDE UXL1 = (Y(IP,L+2)-Y(IP,L ))/(Y(NPDE1,L+2)-Y(NPDE1,L )) SCLMQ = SCLMQ + + CC(J,IP)*(YDOT(IP,L )) SCL1MQ = SCL1MQ + + CC(J,IP)*(YDOT(IP,L+1)-UXL1*YDOT(NPDE1,L+1)) 30 CONTINUE C Store contribution from l_th interval to residual equation in X_l+1 AYDOT(J,L+1) = FSC1 * SCL1MQ G (J,L+1) = -ZETAMU*KSIMU*RC(J) - FSC1*QC(J) C Compute boundary equations IF (SING) THEN IF (BETA(J) .NE. 0) THEN C Bnd.eq. is contribution from 0_th interval to C difference eq. in x_L AYDOT(J,0) = SCLMQ / (M+1) G (J,0) = RC(J)/KSI - QC(J)/(M+1) ELSE AYDOT(J,0) = 0.0 G (J,0) = GAMMA(J) ENDIF ELSE C Otherwise compute flux in x_L from contribution from 0_th C interval to difference equation in x_L, and substitute in C user's boundary equation. RCJDOT = -FSCL * SCLMQ / X0M RCJG = (KSIMU*RC(J) - FSCL*QC(J)) / X0M AYDOT(J,0) = -BETA(J)*RCJDOT G (J,0) = BETA(J)*RCJG - GAMMA(J) ENDIF 20 CONTINUE DO 100 L = 1, NC-1 C C Evaluate PDE functions in quadrature point in l_th interval. C Add contribution from [X_l,X_l+1] to that of previous interval to C get residual equation in X_l. C Store contribution from l_th interval to residual equation in X_l+1. C XL = XL1 XL1 = Y(NPDE1,L+1) IF (M .EQ. 1) THEN DENOMI = 1/LOG(XL1/XL) ELSE DENOMI = (1-M)/(XL1**(1-M) - XL**(1-M)) ENDIF IF (SING) THEN KSI = 2/3. * (XL1**3-XL**3) / (XL1**2-XL**2) KSIMU = 1/KSI ELSE IF (M .EQ. 1) THEN KSI = (XL1-XL) * DENOMI KSIMU = KSI ELSE IF (M .EQ. 2) THEN KSI = LOG(XL1/XL) * DENOMI KSIMU = KSI*KSI ELSE KSI = (XL1**(2-M)-XL**(2-M)) / (2-M) * DENOMI IF (M .EQ. 0) THEN KSIMU = 1.0 ELSE KSIMU = KSI**MU ENDIF ENDIF ZETA = 0.5*(XL1*XL1-XL*XL) * DENOMI IF (SING) THEN ZETAMU = ZETA DENPHI = 1/(XL1*XL1-XL*XL) PHIL = (XL1*XL1-KSI*KSI)*DENPHI PHILX = -2*KSI*DENPHI ELSE ZETAMU = 1.0 IF (M .EQ. 1) THEN PHIL = LOG(XL1/KSI) * DENOMI PHILX = -1/KSI * DENOMI ELSE IF (M .EQ. 0) THEN PHIL = (XL1 - KSI) * DENOMI PHILX = -DENOMI ELSE PHIL = (XL1**(1-M) - KSI**(1-M)) / (1-M) * DENOMI PHILX = -KSI**(-M) * DENOMI ENDIF ENDIF C Compute U and Ux in evaluation point DO 110 J = 1, NPDE UKSI(J) = Y(J,L)*PHIL + Y(J,L+1)*(1-PHIL) UXKSI(J) = Y(J,L)*PHILX + Y(J,L+1)*(-PHILX) 110 CONTINUE C Get C, Q and R in evaluation point CALL SPDEF (T, KSI, NPDE, UKSI, UXKSI, CC, QC, RC, IRES) IF (IRES .EQ. 3) RETURN FSCL = (ZETA- XL**(M+1))/(M+1) FSC1 = (XL1**(M+1)-ZETA)/(M+1) DO 120 J = 1, NPDE SCLMQ = 0.0 SCL1MQ = 0.0 DO 130 IP = 1, NPDE UXL = (Y(IP,L+1)-Y(IP,L-1))/(Y(NPDE1,L+1)-Y(NPDE1,L-1)) UXL1 = (Y(IP,L+2)-Y(IP,L ))/(Y(NPDE1,L+2)-Y(NPDE1,L )) SCLMQ = SCLMQ + + CC(J,IP)*(YDOT(IP,L )-UXL *YDOT(NPDE1,L )) SCL1MQ = SCL1MQ + + CC(J,IP)*(YDOT(IP,L+1)-UXL1*YDOT(NPDE1,L+1)) 130 CONTINUE C Add contribution over l_th interval to residual equation in X_l AYDOT(J,L) = AYDOT(J,L) + FSCL * SCLMQ G (J,L) = G (J,L) + ZETAMU*KSIMU*RC(J) - FSCL*QC(J) C Store contribution from l_th interval to residual equation in X_l+1 AYDOT(J,L+1) = FSC1 * SCL1MQ G (J,L+1) = -ZETAMU*KSIMU*RC(J) - FSC1*QC(J) 120 CONTINUE 100 CONTINUE L = NC C C Add contribution over N_th interval to residual equation in X_N. C Compute right boundary equation. C XL = XL1 XL1 = Y(NPDE1,L+1) IF (M .EQ. 1) THEN DENOMI = 1/LOG(XL1/XL) ELSE DENOMI = (1-M)/(XL1**(1-M) - XL**(1-M)) ENDIF IF (SING) THEN KSI = 2/3. * (XL1**3-XL**3) / (XL1**2-XL**2) KSIMU = 1/KSI ELSE IF (M .EQ. 1) THEN KSI = (XL1-XL) * DENOMI KSIMU = KSI ELSE IF (M .EQ. 2) THEN KSI = LOG(XL1/XL) * DENOMI KSIMU = KSI*KSI ELSE KSI = (XL1**(2-M)-XL**(2-M)) / (2-M) * DENOMI IF (M .EQ. 0) THEN KSIMU = 1.0 ELSE KSIMU = KSI**MU ENDIF ENDIF ZETA = 0.5*(XL1*XL1-XL*XL) * DENOMI IF (SING) THEN ZETAMU = ZETA DENPHI = 1/(XL1*XL1-XL*XL) PHIL = (XL1*XL1-KSI*KSI)*DENPHI PHILX = -2*KSI*DENPHI ELSE ZETAMU = 1.0 IF (M .EQ. 1) THEN PHIL = LOG(XL1/KSI) * DENOMI PHILX = -1/KSI * DENOMI ELSE IF (M .EQ. 0) THEN PHIL = (XL1 - KSI) * DENOMI PHILX = -DENOMI ELSE PHIL = (XL1**(1-M) - KSI**(1-M)) / (1-M) * DENOMI PHILX = -KSI**(-M) * DENOMI ENDIF ENDIF IF (M .EQ. 0) THEN XN1M = 1.0 ELSE XN1M = XL1**M ENDIF C Get right boundary function values DO 205 J = 1, NPDE UXKSI(J) = (Y(J,NC+1)-Y(J,NC)) / (XL1-XL) 205 CONTINUE CALL BNDR (T, BETA, GAMMA, Y(1,NC+1), UXKSI, + NPDE, .FALSE., IRES) IF (IRES .EQ. 3) RETURN C Compute U and Ux in evaluation point DO 210 J = 1, NPDE UKSI(J) = Y(J,L)*PHIL + Y(J,L+1)*(1-PHIL) UXKSI(J) = Y(J,L)*PHILX + Y(J,L+1)*(-PHILX) 210 CONTINUE C Get C, Q and R in evaluation point CALL SPDEF (T, KSI, NPDE, UKSI, UXKSI, CC, QC, RC, IRES) IF (IRES .EQ. 3) RETURN FSCL = (ZETA- XL**(M+1))/(M+1) FSC1 = (XL1**(M+1)-ZETA)/(M+1) DO 220 J = 1, NPDE SCLMQ = 0.0 SCL1MQ = 0.0 DO 230 IP = 1, NPDE UXL = (Y(IP,L+1)-Y(IP,L-1))/(Y(NPDE1,L+1)-Y(NPDE1,L-1)) SCLMQ = SCLMQ + + CC(J,IP)*(YDOT(IP,L )-UXL *YDOT(NPDE1,L )) SCL1MQ = SCL1MQ + + CC(J,IP)*(YDOT(IP,L+1)) 230 CONTINUE C Add contribution over N_th interval to residual equation in X_N AYDOT(J,L) = AYDOT(J,L) + FSCL * SCLMQ G (J,L) = G (J,L) + ZETAMU*KSIMU*RC(J) - FSCL*QC(J) C Compute flux in x_R and substitute in user's boundary condition RCJDOT = FSC1 * SCL1MQ / XN1M RCJG = (ZETAMU*KSIMU*RC(J) + FSC1*QC(J)) / XN1M AYDOT(J,NC+1) = -BETA(J)*RCJDOT G (J,NC+1) = BETA(J)*RCJG - GAMMA(J) 220 CONTINUE RETURN END SUBROUTINE CWRESX (T, Y, YDOT, NPDE1, NC, AYDOT, G, IRES) C C----------------------------------------------------------------------- C Purpose: C ------- C Define grid part of DAE system in general form, i.e. A.ydot and g C separated to satisfy both SPRINT and DASSL. C The equations for the moving grid are C . . C nt + tau.nt nt + tau.nt C i-1 i-1 i i C ---------------- - ------------ = 0 1 <= i <= N, C M M C i-1 i C C with nt = n - fac.(n - 2.n + n ); fac = rkappa.(rkappa+1) and C i i i+1 i i-1 C C n = 1 / (X - X ), n = n , n = n . C i i+1 i -1 0 N+1 N C C For simplicity reasons x and x are also part of the DAE vector; since C L R C the boundaries are fixed we have used as ODEs for these variables C . . C X = X = 0. C 0 N+1 C C Parameters: C ---------- INTEGER NPDE1, NC, IRES REAL T REAL Y(NPDE1,0:NC+1), YDOT(NPDE1,0:NC+1), + AYDOT(NPDE1,0:NC+1), G(NPDE1,0:NC+1) C C T Entry: evaluation time C Y Entry: solution and grid at time T. C (Y(1:NPDE,L): U_l, Y(NPDE+1,L): X_l) C YDOT Entry: derivative of Y at T. C NPDE1 Entry: # PDEs + 1. C NC Entry: # internal grid points. C AYDOT Exit: A.ydot part of the residual. C G Exit: g part of the residual. C IRES Exit: not used. C C----------------------------------------------------------------------- C REAL TAU, RKAPPA, ALFA COMMON /METPAR/ TAU, RKAPPA, ALFA SAVE /METPAR/ C C----------------------------------------------------------------------- C INTEGER I, NPDE REAL A0, AM, FAC, G0, GM, NIM1, NI, NIP1, NTI, NTDI C NPDE = NPDE1-1 C C ccc Define smoothing factor FAC = RKAPPA*(RKAPPA+1) C C ccc Compute monitor values; store M(I) temp. in G(NPDE1,I), I=0, NC CALL XMNTR (Y, G, NPDE, NC) C C ccc Compute A.xdot and g for grid equations. C Interior equations: C A.xdot (I) = TAU/M(I-1).NTDOT(I-1) - TAU/M(I).NTDOT(I) C g(I) = NT(I)/M(I) - NT(I-1)/M(I-1) C NT(I) = N(I) - FAC.(N(I-1)-2.N(I)+N(I+1)) C N (I) = 1 / (X(I+1)-X(I)) I = 0 NI = 1/(Y(NPDE1,I+1)-Y(NPDE1,I )) NIM1 = NI NIP1 = 1/(Y(NPDE1,I+2)-Y(NPDE1,I+1)) NTI = NI - FAC*(NIM1-2*NI+NIP1) NTDI = - + (1+ FAC)*NI *NI *(YDOT(NPDE1,I+1)-YDOT(NPDE1,I )) + + FAC *NIP1*NIP1*(YDOT(NPDE1,I+2)-YDOT(NPDE1,I+1)) A0 = TAU / G(NPDE1,I) * NTDI G0 = NTI / G(NPDE1,I) DO 10 I = 1, NC-1 NIM1 = NI NI = NIP1 AM = A0 GM = G0 NIP1 = 1/(Y(NPDE1,I+2)-Y(NPDE1,I+1)) NTI = NI - FAC*(NIM1-2*NI+NIP1) NTDI = FAC *NIM1*NIM1*(YDOT(NPDE1,I )-YDOT(NPDE1,I-1)) - + (1+2*FAC)*NI *NI *(YDOT(NPDE1,I+1)-YDOT(NPDE1,I )) + + FAC *NIP1*NIP1*(YDOT(NPDE1,I+2)-YDOT(NPDE1,I+1)) A0 = TAU / G(NPDE1,I) * NTDI G0 = NTI / G(NPDE1,I) AYDOT(NPDE1,I) = AM - A0 G (NPDE1,I) = G0 - GM 10 CONTINUE I = NC NIM1 = NI NI = NIP1 AM = A0 GM = G0 NIP1 = NI NTI = NI - FAC*(NIM1-2*NI+NIP1) NTDI = FAC *NIM1*NIM1*(YDOT(NPDE1,I )-YDOT(NPDE1,I-1)) - + (1+ FAC)*NI *NI *(YDOT(NPDE1,I+1)-YDOT(NPDE1,I )) A0 = TAU / G(NPDE1,I) * NTDI G0 = NTI / G(NPDE1,I) AYDOT(NPDE1,I) = AM - A0 G (NPDE1,I) = G0 - GM C Boundary equations grid. C Fixed endpoints, xdot=0 I=0 AYDOT(NPDE1,I) = YDOT(NPDE1,I) G(NPDE1,I) = 0.0 I=NC+1 AYDOT(NPDE1,I) = YDOT(NPDE1,I) G(NPDE1,I) = 0.0 C RETURN END SUBROUTINE XMNTR (Y, G, NPDE, N) INTEGER NPDE, N REAL Y(NPDE+1,0:N+1), G(NPDE+1,0:N+1) C C----------------------------------------------------------------------- C Purpose: C ------- C Compute monitor for grid equation, C M_i = M(x(i+1/2)) = sqrt(alfa + !!ux!!**2) C C Exit: C G(NPDE+1,i) = M(i) C C----------------------------------------------------------------------- C REAL TAU, RKAPPA, ALFA COMMON /METPAR/ TAU, RKAPPA, ALFA SAVE /METPAR/ C C----------------------------------------------------------------------- C INTEGER I, K, NPDE1 REAL DU, DX, SUX2 C NPDE1 = NPDE+1 DO 10 I = 0, N SUX2 = 0.0 DO 20 K = 1, NPDE DU = Y(K,I+1)-Y(K,I) SUX2 = SUX2 + DU*DU 20 CONTINUE DX = Y(NPDE1,I+1)-Y(NPDE1,I) SUX2 = SUX2 / (DX*DX) G(NPDE1,I) = SQRT(ALFA + SUX2/NPDE) 10 CONTINUE RETURN END C C####################################################################### C C MACHAR : MACHAR routine from W.J. Cody C (available from Netlib: send machar from elefunt) C C####################################################################### C SUBROUTINE MACHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP, 1 MAXEXP,EPS,EPSNEG,XMIN,XMAX) C----------------------------------------------------------------------- C This Fortran 77 subroutine is intended to determine the parameters C of the floating-point arithmetic system specified below. The C determination of the first three uses an extension of an algorithm C due to M. Malcolm, CACM 15 (1972), pp. 949-951, incorporating some, C but not all, of the improvements suggested by M. Gentleman and S. C Marovich, CACM 17 (1974), pp. 276-277. An earlier version of this C program was published in the book Software Manual for the C Elementary Functions by W. J. Cody and W. Waite, Prentice-Hall, C Englewood Cliffs, NJ, 1980. The present version is documented in C W. J. Cody, "MACHAR: A subroutine to dynamically determine machine C parameters," TOMS 14, December, 1988. C C The program as given here must be modified before compiling. If C a single (double) precision version is desired, change all C occurrences of CS (CD) in columns 1 and 2 to blanks. C C Parameter values reported are as follows: C C IBETA - the radix for the floating-point representation C IT - the number of base IBETA digits in the floating-point C significand C IRND - 0 if floating-point addition chops C 1 if floating-point addition rounds, but not in the C IEEE style C 2 if floating-point addition rounds in the IEEE style C 3 if floating-point addition chops, and there is C partial underflow C 4 if floating-point addition rounds, but not in the C IEEE style, and there is partial underflow C 5 if floating-point addition rounds in the IEEE style, C and there is partial underflow C NGRD - the number of guard digits for multiplication with C truncating arithmetic. It is C 0 if floating-point arithmetic rounds, or if it C truncates and only IT base IBETA digits C participate in the post-normalization shift of the C floating-point significand in multiplication; C 1 if floating-point arithmetic truncates and more C than IT base IBETA digits participate in the C post-normalization shift of the floating-point C significand in multiplication. C MACHEP - the largest negative integer such that C 1.0+FLOAT(IBETA)**MACHEP .NE. 1.0, except that C MACHEP is bounded below by -(IT+3) C NEGEPS - the largest negative integer such that C 1.0-FLOAT(IBETA)**NEGEPS .NE. 1.0, except that C NEGEPS is bounded below by -(IT+3) C IEXP - the number of bits (decimal places if IBETA = 10) C reserved for the representation of the exponent C (including the bias or sign) of a floating-point C number C MINEXP - the largest in magnitude negative integer such that C FLOAT(IBETA)**MINEXP is positive and normalized C MAXEXP - the smallest positive power of BETA that overflows C EPS - the smallest positive floating-point number such C that 1.0+EPS .NE. 1.0. In particular, if either C IBETA = 2 or IRND = 0, EPS = FLOAT(IBETA)**MACHEP. C Otherwise, EPS = (FLOAT(IBETA)**MACHEP)/2 C EPSNEG - A small positive floating-point number such that C 1.0-EPSNEG .NE. 1.0. In particular, if IBETA = 2 C or IRND = 0, EPSNEG = FLOAT(IBETA)**NEGEPS. C Otherwise, EPSNEG = (IBETA**NEGEPS)/2. Because C NEGEPS is bounded below by -(IT+3), EPSNEG may not C be the smallest number that can alter 1.0 by C subtraction. C XMIN - the smallest non-vanishing normalized floating-point C power of the radix, i.e., XMIN = FLOAT(IBETA)**MINEXP C XMAX - the largest finite floating-point number. In C particular XMAX = (1.0-EPSNEG)*FLOAT(IBETA)**MAXEXP C Note - on some machines XMAX will be only the C second, or perhaps third, largest number, being C too small by 1 or 2 units in the last digit of C the significand. C C Latest revision - December 4, 1987 C C Author - W. J. Cody C Argonne National Laboratory C C----------------------------------------------------------------------- INTEGER I,IBETA,IEXP,IRND,IT,ITEMP,IZ,J,K,MACHEP,MAXEXP, 1 MINEXP,MX,NEGEP,NGRD,NXRES REAL CD DOUBLE PRECISION 1 A,B,BETA,BETAIN,BETAH,CONV,EPS,EPSNEG,ONE,T,TEMP,TEMPA, 2 TEMP1,TWO,XMAX,XMIN,Y,Z,ZERO C----------------------------------------------------------------------- CONV(I) = REAL(I) CD CONV(I) = DBLE(I) ONE = CONV(1) TWO = ONE + ONE ZERO = ONE - ONE C----------------------------------------------------------------------- C Determine IBETA, BETA ala Malcolm. C----------------------------------------------------------------------- A = ONE 10 A = A + A TEMP = A+ONE TEMP1 = TEMP-A IF (TEMP1-ONE .EQ. ZERO) GO TO 10 B = ONE 20 B = B + B TEMP = A+B ITEMP = INT(TEMP-A) IF (ITEMP .EQ. 0) GO TO 20 IBETA = ITEMP BETA = CONV(IBETA) C----------------------------------------------------------------------- C Determine IT, IRND. C----------------------------------------------------------------------- IT = 0 B = ONE 100 IT = IT + 1 B = B * BETA TEMP = B+ONE TEMP1 = TEMP-B IF (TEMP1-ONE .EQ. ZERO) GO TO 100 IRND = 0 BETAH = BETA / TWO TEMP = A+BETAH IF (TEMP-A .NE. ZERO) IRND = 1 TEMPA = A + BETA TEMP = TEMPA+BETAH IF ((IRND .EQ. 0) .AND. (TEMP-TEMPA .NE. ZERO)) IRND = 2 C----------------------------------------------------------------------- C Determine NEGEP, EPSNEG. C----------------------------------------------------------------------- NEGEP = IT + 3 BETAIN = ONE / BETA A = ONE DO 200 I = 1, NEGEP A = A * BETAIN 200 CONTINUE B = A 210 TEMP = ONE-A IF (TEMP-ONE .NE. ZERO) GO TO 220 A = A * BETA NEGEP = NEGEP - 1 GO TO 210 220 NEGEP = -NEGEP EPSNEG = A C----------------------------------------------------------------------- C Determine MACHEP, EPS. C----------------------------------------------------------------------- MACHEP = -IT - 3 A = B 300 TEMP = ONE+A IF (TEMP-ONE .NE. ZERO) GO TO 320 A = A * BETA MACHEP = MACHEP + 1 GO TO 300 320 EPS = A C----------------------------------------------------------------------- C Determine NGRD. C----------------------------------------------------------------------- NGRD = 0 TEMP = ONE+EPS IF ((IRND .EQ. 0) .AND. (TEMP*ONE-ONE .NE. ZERO)) NGRD = 1 C----------------------------------------------------------------------- C Determine IEXP, MINEXP, XMIN. C C Loop to determine largest I and K = 2**I such that C (1/BETA) ** (2**(I)) C does not underflow. C Exit from loop is signaled by an underflow. C----------------------------------------------------------------------- I = 0 K = 1 Z = BETAIN T = ONE + EPS NXRES = 0 400 Y = Z Z = Y * Y C----------------------------------------------------------------------- C Check for underflow here. C----------------------------------------------------------------------- A = Z * ONE TEMP = Z * T IF ((A+A .EQ. ZERO) .OR. (ABS(Z) .GE. Y)) GO TO 410 TEMP1 = TEMP * BETAIN IF (TEMP1*BETA .EQ. Z) GO TO 410 I = I + 1 K = K + K GO TO 400 410 IF (IBETA .EQ. 10) GO TO 420 IEXP = I + 1 MX = K + K GO TO 450 C----------------------------------------------------------------------- C This segment is for decimal machines only. C----------------------------------------------------------------------- 420 IEXP = 2 IZ = IBETA 430 IF (K .LT. IZ) GO TO 440 IZ = IZ * IBETA IEXP = IEXP + 1 GO TO 430 440 MX = IZ + IZ - 1 C----------------------------------------------------------------------- C Loop to determine MINEXP, XMIN. C Exit from loop is signaled by an underflow. C----------------------------------------------------------------------- 450 XMIN = Y Y = Y * BETAIN C----------------------------------------------------------------------- C Check for underflow here. C----------------------------------------------------------------------- A = Y * ONE TEMP = Y * T IF (((A+A) .EQ. ZERO) .OR. (ABS(Y) .GE. XMIN)) GO TO 460 K = K + 1 TEMP1 = TEMP * BETAIN IF ((TEMP1*BETA .NE. Y) .OR. (TEMP .EQ. Y)) THEN GO TO 450 ELSE NXRES = 3 XMIN = Y END IF 460 MINEXP = -K C----------------------------------------------------------------------- C Determine MAXEXP, XMAX. C----------------------------------------------------------------------- IF ((MX .GT. K+K-3) .OR. (IBETA .EQ. 10)) GO TO 500 MX = MX + MX IEXP = IEXP + 1 500 MAXEXP = MX + MINEXP C----------------------------------------------------------------- C Adjust IRND to reflect partial underflow. C----------------------------------------------------------------- IRND = IRND + NXRES C----------------------------------------------------------------- C Adjust for IEEE-style machines. C----------------------------------------------------------------- IF (IRND .GE. 2) MAXEXP = MAXEXP - 2 C----------------------------------------------------------------- C Adjust for machines with implicit leading bit in binary C significand, and machines with radix point at extreme C right of significand. C----------------------------------------------------------------- I = MAXEXP + MINEXP IF ((IBETA .EQ. 2) .AND. (I .EQ. 0)) MAXEXP = MAXEXP - 1 IF (I .GT. 20) MAXEXP = MAXEXP - 1 IF (A .NE. Y) MAXEXP = MAXEXP - 2 XMAX = ONE - EPSNEG IF (XMAX*ONE .NE. XMAX) XMAX = ONE - BETA * EPSNEG XMAX = XMAX / (BETA * BETA * BETA * XMIN) I = MAXEXP + MINEXP + 3 IF (I .LE. 0) GO TO 520 DO 510 J = 1, I IF (IBETA .EQ. 2) XMAX = XMAX + XMAX IF (IBETA .NE. 2) XMAX = XMAX * BETA 510 CONTINUE 520 RETURN C---------- LAST CARD OF MACHAR ---------- END C C####################################################################### C C Next three files contain sources used to solve the resulting DAE C system with DASSL. C C####################################################################### C C####################################################################### C C SDASSL : DASSL DAE integrator from L.R. Petzold C (available from Netlib: send sdassl from ode) C C####################################################################### C SUBROUTINE SDASSL (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL, + IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC) C***BEGIN PROLOGUE SDASSL C***PURPOSE This code solves a system of differential/algebraic C equations of the form G(T,Y,YPRIME) = 0. C***LIBRARY SLATEC (DASSL) C***CATEGORY I1A2 C***TYPE SINGLE PRECISION (SDASSL-S, DDASSL-D) C***KEYWORDS DIFFERENTIAL/ALGEBRAIC, BACKWARD DIFFERENTIATION FORMULAS, C IMPLICIT DIFFERENTIAL SYSTEMS C***AUTHOR PETZOLD, LINDA R., (LLNL) C COMPUTING AND MATHEMATICS RESEARCH DIVISION C LAWRENCE LIVERMORE NATIONAL LABORATORY C L - 316, P.O. BOX 808, C LIVERMORE, CA. 94550 C***DESCRIPTION C C *Usage: C C EXTERNAL RES, JAC C INTEGER NEQ, INFO(N), IDID, LRW, LIW, IWORK(LIW), IPAR C REAL T, Y(NEQ), YPRIME(NEQ), TOUT, RTOL, ATOL, C * RWORK(LRW), RPAR C C CALL SDASSL (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL, C * IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC) C C C *Arguments: C C RES:EXT This is a subroutine which you provide to define the C differential/algebraic system. C C NEQ:IN This is the number of equations to be solved. C C T:INOUT This is the current value of the independent variable. C C Y(*):INOUT This array contains the solution components at T. C C YPRIME(*):INOUT This array contains the derivatives of the solution C components at T. C C TOUT:IN This is a point at which a solution is desired. C C INFO(N):IN The basic task of the code is to solve the system from T C to TOUT and return an answer at TOUT. INFO is an integer C array which is used to communicate exactly how you want C this task to be carried out. (See below for details.) C N must be greater than or equal to 15. C C RTOL,ATOL:INOUT These quantities represent relative and absolute C error tolerances which you provide to indicate how C accurately you wish the solution to be computed. You C may choose them to be both scalars or else both vectors. C Caution: In Fortran 77, a scalar is not the same as an C array of length 1. Some compilers may object C to using scalars for RTOL,ATOL. C C IDID:OUT This scalar quantity is an indicator reporting what the C code did. You must monitor this integer variable to C decide what action to take next. C C RWORK:WORK A real work array of length LRW which provides the C code with needed storage space. C C LRW:IN The length of RWORK. (See below for required length.) C C IWORK:WORK An integer work array of length LIW which probides the C code with needed storage space. C C LIW:IN The length of IWORK. (See below for required length.) C C RPAR,IPAR:IN These are real and integer parameter arrays which C you can use for communication between your calling C program and the RES subroutine (and the JAC subroutine) C C JAC:EXT This is the name of a subroutine which you may choose C to provide for defining a matrix of partial derivatives C described below. C C Quantities which may be altered by SDASSL are: C T, Y(*), YPRIME(*), INFO(1), RTOL, ATOL, C IDID, RWORK(*) AND IWORK(*) C C *Description C C Subroutine SDASSL uses the backward differentiation formulas of C orders one through five to solve a system of the above form for Y and C YPRIME. Values for Y and YPRIME at the initial time must be given as C input. These values must be consistent, (that is, if T,Y,YPRIME are C the given initial values, they must satisfy G(T,Y,YPRIME) = 0.). The C subroutine solves the system from T to TOUT. It is easy to continue C the solution to get results at additional TOUT. This is the interval C mode of operation. Intermediate results can also be obtained easily C by using the intermediate-output capability. C C The following detailed description is divided into subsections: C 1. Input required for the first call to SDASSL. C 2. Output after any return from SDASSL. C 3. What to do to continue the integration. C 4. Error messages. C C C -------- INPUT -- WHAT TO DO ON THE FIRST CALL TO SDASSL ------------ C C The first call of the code is defined to be the start of each new C problem. Read through the descriptions of all the following items, C provide sufficient storage space for designated arrays, set C appropriate variables for the initialization of the problem, and C give information about how you want the problem to be solved. C C C RES -- Provide a subroutine of the form C SUBROUTINE RES(T,Y,YPRIME,DELTA,IRES,RPAR,IPAR) C to define the system of differential/algebraic C equations which is to be solved. For the given values C of T,Y and YPRIME, the subroutine should C return the residual of the defferential/algebraic C system C DELTA = G(T,Y,YPRIME) C (DELTA(*) is a vector of length NEQ which is C output for RES.) C C Subroutine RES must not alter T,Y or YPRIME. C You must declare the name RES in an external C statement in your program that calls SDASSL. C You must dimension Y,YPRIME and DELTA in RES. C C IRES is an integer flag which is always equal to C zero on input. Subroutine RES should alter IRES C only if it encounters an illegal value of Y or C a stop condition. Set IRES = -1 if an input value C is illegal, and SDASSL will try to solve the problem C without getting IRES = -1. If IRES = -2, SDASSL C will return control to the calling program C with IDID = -11. C C RPAR and IPAR are real and integer parameter arrays which C you can use for communication between your calling program C and subroutine RES. They are not altered by SDASSL. If you C do not need RPAR or IPAR, ignore these parameters by treat- C ing them as dummy arguments. If you do choose to use them, C dimension them in your calling program and in RES as arrays C of appropriate length. C C NEQ -- Set it to the number of differential equations. C (NEQ .GE. 1) C C T -- Set it to the initial point of the integration. C T must be defined as a variable. C C Y(*) -- Set this vector to the initial values of the NEQ solution C components at the initial point. You must dimension Y of C length at least NEQ in your calling program. C C YPRIME(*) -- Set this vector to the initial values of the NEQ C first derivatives of the solution components at the initial C point. You must dimension YPRIME at least NEQ in your C calling program. If you do not know initial values of some C of the solution components, see the explanation of INFO(11). C C TOUT -- Set it to the first point at which a solution C is desired. You can not take TOUT = T. C integration either forward in T (TOUT .GT. T) or C backward in T (TOUT .LT. T) is permitted. C C The code advances the solution from T to TOUT using C step sizes which are automatically selected so as to C achieve the desired accuracy. If you wish, the code will C return with the solution and its derivative at C intermediate steps (intermediate-output mode) so that C you can monitor them, but you still must provide TOUT in C accord with the basic aim of the code. C C The first step taken by the code is a critical one C because it must reflect how fast the solution changes near C the initial point. The code automatically selects an C initial step size which is practically always suitable for C the problem. By using the fact that the code will not step C past TOUT in the first step, you could, if necessary, C restrict the length of the initial step size. C C For some problems it may not be permissible to integrate C past a point TSTOP because a discontinuity occurs there C or the solution or its derivative is not defined beyond C TSTOP. When you have declared a TSTOP point (SEE INFO(4) C and RWORK(1)), you have told the code not to integrate C past TSTOP. In this case any TOUT beyond TSTOP is invalid C input. C C INFO(*) -- Use the INFO array to give the code more details about C how you want your problem solved. This array should be C dimensioned of length 15, though SDASSL uses only the first C eleven entries. You must respond to all of the following C items, which are arranged as questions. The simplest use C of the code corresponds to answering all questions as yes, C i.e. setting all entries of INFO to 0. C C INFO(1) - This parameter enables the code to initialize C itself. You must set it to indicate the start of every C new problem. C C **** Is this the first call for this problem ... C Yes - Set INFO(1) = 0 C No - Not applicable here. C See below for continuation calls. **** C C INFO(2) - How much accuracy you want of your solution C is specified by the error tolerances RTOL and ATOL. C The simplest use is to take them both to be scalars. C To obtain more flexibility, they can both be vectors. C The code must be told your choice. C C **** Are both error tolerances RTOL, ATOL scalars ... C Yes - Set INFO(2) = 0 C and input scalars for both RTOL and ATOL C No - Set INFO(2) = 1 C and input arrays for both RTOL and ATOL **** C C INFO(3) - The code integrates from T in the direction C of TOUT by steps. If you wish, it will return the C computed solution and derivative at the next C intermediate step (the intermediate-output mode) or C TOUT, whichever comes first. This is a good way to C proceed if you want to see the behavior of the solution. C If you must have solutions at a great many specific C TOUT points, this code will compute them efficiently. C C **** Do you want the solution only at C TOUT (and not at the next intermediate step) ... C Yes - Set INFO(3) = 0 C No - Set INFO(3) = 1 **** C C INFO(4) - To handle solutions at a great many specific C values TOUT efficiently, this code may integrate past C TOUT and interpolate to obtain the result at TOUT. C Sometimes it is not possible to integrate beyond some C point TSTOP because the equation changes there or it is C not defined past TSTOP. Then you must tell the code C not to go past. C C **** Can the integration be carried out without any C restrictions on the independent variable T ... C Yes - Set INFO(4)=0 C No - Set INFO(4)=1 C and define the stopping point TSTOP by C setting RWORK(1)=TSTOP **** C C INFO(5) - To solve differential/algebraic problems it is C necessary to use a matrix of partial derivatives of the C system of differential equations. If you do not C provide a subroutine to evaluate it analytically (see C description of the item JAC in the call list), it will C be approximated by numerical differencing in this code. C although it is less trouble for you to have the code C compute partial derivatives by numerical differencing, C the solution will be more reliable if you provide the C derivatives via JAC. Sometimes numerical differencing C is cheaper than evaluating derivatives in JAC and C sometimes it is not - this depends on your problem. C C **** Do you want the code to evaluate the partial C derivatives automatically by numerical differences ... C Yes - Set INFO(5)=0 C No - Set INFO(5)=1 C and provide subroutine JAC for evaluating the C matrix of partial derivatives **** C C INFO(6) - SDASSL will perform much better if the matrix of C partial derivatives, DG/DY + CJ*DG/DYPRIME, C (here CJ is a scalar determined by SDASSL) C is banded and the code is told this. In this C case, the storage needed will be greatly reduced, C numerical differencing will be performed much cheaper, C and a number of important algorithms will execute much C faster. The differential equation is said to have C half-bandwidths ML (lower) and MU (upper) if equation i C involves only unknowns Y(J) with C I-ML .LE. J .LE. I+MU C for all I=1,2,...,NEQ. Thus, ML and MU are the widths C of the lower and upper parts of the band, respectively, C with the main diagonal being excluded. If you do not C indicate that the equation has a banded matrix of partial C derivatives, the code works with a full matrix of NEQ**2 C elements (stored in the conventional way). Computations C with banded matrices cost less time and storage than with C full matrices if 2*ML+MU .LT. NEQ. If you tell the C code that the matrix of partial derivatives has a banded C structure and you want to provide subroutine JAC to C compute the partial derivatives, then you must be careful C to store the elements of the matrix in the special form C indicated in the description of JAC. C C **** Do you want to solve the problem using a full C (dense) matrix (and not a special banded C structure) ... C Yes - Set INFO(6)=0 C No - Set INFO(6)=1 C and provide the lower (ML) and upper (MU) C bandwidths by setting C IWORK(1)=ML C IWORK(2)=MU **** C C C INFO(7) -- You can specify a maximum (absolute value of) C stepsize, so that the code C will avoid passing over very C large regions. C C **** Do you want the code to decide C on its own maximum stepsize? C Yes - Set INFO(7)=0 C No - Set INFO(7)=1 C and define HMAX by setting C RWORK(2)=HMAX **** C C INFO(8) -- Differential/algebraic problems C may occaisionally suffer from C severe scaling difficulties on the C first step. If you know a great deal C about the scaling of your problem, you can C help to alleviate this problem by C specifying an initial stepsize HO. C C **** Do you want the code to define C its own initial stepsize? C Yes - Set INFO(8)=0 C No - Set INFO(8)=1 C and define HO by setting C RWORK(3)=HO **** C C INFO(9) -- If storage is a severe problem, C you can save some locations by C restricting the maximum order MAXORD. C the default value is 5. for each C order decrease below 5, the code C requires NEQ fewer locations, however C it is likely to be slower. In any C case, you must have 1 .LE. MAXORD .LE. 5 C **** Do you want the maximum order to C default to 5? C Yes - Set INFO(9)=0 C No - Set INFO(9)=1 C and define MAXORD by setting C IWORK(3)=MAXORD **** C C INFO(10) --If you know that the solutions to your equations C will always be nonnegative, it may help to set this C parameter. However, it is probably best to C try the code without using this option first, C and only to use this option if that doesn't C work very well. C **** Do you want the code to solve the problem without C invoking any special nonnegativity constraints? C Yes - Set INFO(10)=0 C No - Set INFO(10)=1 C C INFO(11) --SDASSL normally requires the initial T, C Y, and YPRIME to be consistent. That is, C you must have G(T,Y,YPRIME) = 0 at the initial C time. If you do not know the initial C derivative precisely, you can let SDASSL try C to compute it. C **** Are the initialHE INITIAL T, Y, YPRIME consistent? C Yes - Set INFO(11) = 0 C No - Set INFO(11) = 1, C and set YPRIME to an initial approximation C to YPRIME. (If you have no idea what C YPRIME should be, set it to zero. Note C that the initial Y should be such C that there must exist a YPRIME so that C G(T,Y,YPRIME) = 0.) C C RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL C error tolerances to tell the code how accurately you C want the solution to be computed. They must be defined C as variables because the code may change them. You C have two choices -- C Both RTOL and ATOL are scalars. (INFO(2)=0) C Both RTOL and ATOL are vectors. (INFO(2)=1) C in either case all components must be non-negative. C C The tolerances are used by the code in a local error C test at each step which requires roughly that C ABS(LOCAL ERROR) .LE. RTOL*ABS(Y)+ATOL C for each vector component. C (More specifically, a root-mean-square norm is used to C measure the size of vectors, and the error test uses the C magnitude of the solution at the beginning of the step.) C C The true (global) error is the difference between the C true solution of the initial value problem and the C computed approximation. Practically all present day C codes, including this one, control the local error at C each step and do not even attempt to control the global C error directly. C Usually, but not always, the true accuracy of the C computed Y is comparable to the error tolerances. This C code will usually, but not always, deliver a more C accurate solution if you reduce the tolerances and C integrate again. By comparing two such solutions you C can get a fairly reliable idea of the true error in the C solution at the bigger tolerances. C C Setting ATOL=0. results in a pure relative error test on C that component. Setting RTOL=0. results in a pure C absolute error test on that component. A mixed test C with non-zero RTOL and ATOL corresponds roughly to a C relative error test when the solution component is much C bigger than ATOL and to an absolute error test when the C solution component is smaller than the threshhold ATOL. C C The code will not attempt to compute a solution at an C accuracy unreasonable for the machine being used. It will C advise you if you ask for too much accuracy and inform C you as to the maximum accuracy it believes possible. C C RWORK(*) -- Dimension this real work array of length LRW in your C calling program. C C LRW -- Set it to the declared length of the RWORK array. C You must have C LRW .GE. 40+(MAXORD+4)*NEQ+NEQ**2 C for the full (dense) JACOBIAN case (when INFO(6)=0), or C LRW .GE. 40+(MAXORD+4)*NEQ+(2*ML+MU+1)*NEQ C for the banded user-defined JACOBIAN case C (when INFO(5)=1 and INFO(6)=1), or C LRW .GE. 40+(MAXORD+4)*NEQ+(2*ML+MU+1)*NEQ C +2*(NEQ/(ML+MU+1)+1) C for the banded finite-difference-generated JACOBIAN case C (when INFO(5)=0 and INFO(6)=1) C C IWORK(*) -- Dimension this integer work array of length LIW in C your calling program. C C LIW -- Set it to the declared length of the IWORK array. C You must have LIW .GE. 20+NEQ C C RPAR, IPAR -- These are parameter arrays, of real and integer C type, respectively. You can use them for communication C between your program that calls SDASSL and the C RES subroutine (and the JAC subroutine). They are not C altered by SDASSL. If you do not need RPAR or IPAR, C ignore these parameters by treating them as dummy C arguments. If you do choose to use them, dimension C them in your calling program and in RES (and in JAC) C as arrays of appropriate length. C C JAC -- If you have set INFO(5)=0, you can ignore this parameter C by treating it as a dummy argument. Otherwise, you must C provide a subroutine of the form C SUBROUTINE JAC(T,Y,YPRIME,PD,CJ,RPAR,IPAR) C to define the matrix of partial derivatives C PD=DG/DY+CJ*DG/DYPRIME C CJ is a scalar which is input to JAC. C For the given values of T,Y,YPRIME, the C subroutine must evaluate the non-zero partial C derivatives for each equation and each solution C component, and store these values in the C matrix PD. The elements of PD are set to zero C before each call to JAC so only non-zero elements C need to be defined. C C Subroutine JAC must not alter T,Y,(*),YPRIME(*), or CJ. C You must declare the name JAC in an EXTERNAL statement in C your program that calls SDASSL. You must dimension Y, C YPRIME and PD in JAC. C C The way you must store the elements into the PD matrix C depends on the structure of the matrix which you C indicated by INFO(6). C *** INFO(6)=0 -- Full (dense) matrix *** C Give PD a first dimension of NEQ. C When you evaluate the (non-zero) partial derivative C of equation I with respect to variable J, you must C store it in PD according to C PD(I,J) = "DG(I)/DY(J)+CJ*DG(I)/DYPRIME(J)" C *** INFO(6)=1 -- Banded JACOBIAN with ML lower and MU C upper diagonal bands (refer to INFO(6) description C of ML and MU) *** C Give PD a first dimension of 2*ML+MU+1. C when you evaluate the (non-zero) partial derivative C of equation I with respect to variable J, you must C store it in PD according to C IROW = I - J + ML + MU + 1 C PD(IROW,J) = "DG(I)/DY(J)+CJ*DG(I)/DYPRIME(J)" C C RPAR and IPAR are real and integer parameter arrays C which you can use for communication between your calling C program and your JACOBIAN subroutine JAC. They are not C altered by SDASSL. If you do not need RPAR or IPAR, C ignore these parameters by treating them as dummy C arguments. If you do choose to use them, dimension C them in your calling program and in JAC as arrays of C appropriate length. C C C OPTIONALLY REPLACEABLE NORM ROUTINE: C C SDASSL uses a weighted norm SDANRM to measure the size C of vectors such as the estimated error in each step. C A FUNCTION subprogram C REAL FUNCTION SDANRM(NEQ,V,WT,RPAR,IPAR) C DIMENSION V(NEQ),WT(NEQ) C is used to define this norm. Here, V is the vector C whose norm is to be computed, and WT is a vector of C weights. A SDANRM routine has been included with SDASSL C which computes the weighted root-mean-square norm C given by C SDANRM=SQRT((1/NEQ)*SUM(V(I)/WT(I))**2) C this norm is suitable for most problems. In some C special cases, it may be more convenient and/or C efficient to define your own norm by writing a function C subprogram to be called instead of SDANRM. This should, C however, be attempted only after careful thought and C consideration. C C C -------- OUTPUT -- AFTER ANY RETURN FROM SDASSL --------------------- C C The principal aim of the code is to return a computed solution at C TOUT, although it is also possible to obtain intermediate results C along the way. To find out whether the code achieved its goal C or if the integration process was interrupted before the task was C completed, you must check the IDID parameter. C C C T -- The solution was successfully advanced to the C output value of T. C C Y(*) -- Contains the computed solution approximation at T. C C YPRIME(*) -- Contains the computed derivative C approximation at T. C C IDID -- Reports what the code did. C C *** Task completed *** C Reported by positive values of IDID C C IDID = 1 -- A step was successfully taken in the C intermediate-output mode. The code has not C yet reached TOUT. C C IDID = 2 -- The integration to TSTOP was successfully C completed (T=TSTOP) by stepping exactly to TSTOP. C C IDID = 3 -- The integration to TOUT was successfully C completed (T=TOUT) by stepping past TOUT. C Y(*) is obtained by interpolation. C YPRIME(*) is obtained by interpolation. C C *** Task interrupted *** C Reported by negative values of IDID C C IDID = -1 -- A large amount of work has been expended. C (About 500 steps) C C IDID = -2 -- The error tolerances are too stringent. C C IDID = -3 -- The local error test cannot be satisfied C because you specified a zero component in ATOL C and the corresponding computed solution C component is zero. Thus, a pure relative error C test is impossible for this component. C C IDID = -6 -- SDASSL had repeated error test C failures on the last attempted step. C C IDID = -7 -- The corrector could not converge. C C IDID = -8 -- The matrix of partial derivatives C is singular. C C IDID = -9 -- The corrector could not converge. C there were repeated error test failures C in this step. C C IDID =-10 -- The corrector could not converge C because IRES was equal to minus one. C C IDID =-11 -- IRES equal to -2 was encountered C and control is being returned to the C calling program. C C IDID =-12 -- SDASSL failed to compute the initial C YPRIME. C C C C IDID = -13,..,-32 -- Not applicable for this code C C *** Task terminated *** C Reported by the value of IDID=-33 C C IDID = -33 -- The code has encountered trouble from which C it cannot recover. A message is printed C explaining the trouble and control is returned C to the calling program. For example, this occurs C when invalid input is detected. C C RTOL, ATOL -- These quantities remain unchanged except when C IDID = -2. In this case, the error tolerances have been C increased by the code to values which are estimated to C be appropriate for continuing the integration. However, C the reported solution at T was obtained using the input C values of RTOL and ATOL. C C RWORK, IWORK -- Contain information which is usually of no C interest to the user but necessary for subsequent calls. C However, you may find use for C C RWORK(3)--Which contains the step size H to be C attempted on the next step. C C RWORK(4)--Which contains the current value of the C independent variable, i.e., the farthest point C integration has reached. This will be different C from T only when interpolation has been C performed (IDID=3). C C RWORK(7)--Which contains the stepsize used C on the last successful step. C C IWORK(7)--Which contains the order of the method to C be attempted on the next step. C C IWORK(8)--Which contains the order of the method used C on the last step. C C IWORK(11)--Which contains the number of steps taken so C far. C C IWORK(12)--Which contains the number of calls to RES C so far. C C IWORK(13)--Which contains the number of evaluations of C the matrix of partial derivatives needed so C far. C C IWORK(14)--Which contains the total number C of error test failures so far. C C IWORK(15)--Which contains the total number C of convergence test failures so far. C (includes singular iteration matrix C failures.) C C C -------- INPUT -- WHAT TO DO TO CONTINUE THE INTEGRATION ------------ C (CALLS AFTER THE FIRST) C C This code is organized so that subsequent calls to continue the C integration involve little (if any) additional effort on your C part. You must monitor the IDID parameter in order to determine C what to do next. C C Recalling that the principal task of the code is to integrate C from T to TOUT (the interval mode), usually all you will need C to do is specify a new TOUT upon reaching the current TOUT. C C Do not alter any quantity not specifically permitted below, C in particular do not alter NEQ,T,Y(*),YPRIME(*),RWORK(*),IWORK(*) C or the differential equation in subroutine RES. Any such C alteration constitutes a new problem and must be treated as such, C i.e., you must start afresh. C C You cannot change from vector to scalar error control or vice C versa (INFO(2)), but you can change the size of the entries of C RTOL, ATOL. Increasing a tolerance makes the equation easier C to integrate. Decreasing a tolerance will make the equation C harder to integrate and should generally be avoided. C C You can switch from the intermediate-output mode to the C interval mode (INFO(3)) or vice versa at any time. C C If it has been necessary to prevent the integration from going C past a point TSTOP (INFO(4), RWORK(1)), keep in mind that the C code will not integrate to any TOUT beyond the currently C specified TSTOP. Once TSTOP has been reached you must change C the value of TSTOP or set INFO(4)=0. You may change INFO(4) C or TSTOP at any time but you must supply the value of TSTOP in C RWORK(1) whenever you set INFO(4)=1. C C Do not change INFO(5), INFO(6), IWORK(1), or IWORK(2) C unless you are going to restart the code. C C *** Following a completed task *** C If C IDID = 1, call the code again to continue the integration C another step in the direction of TOUT. C C IDID = 2 or 3, define a new TOUT and call the code again. C TOUT must be different from T. You cannot change C the direction of integration without restarting. C C *** Following an interrupted task *** C To show the code that you realize the task was C interrupted and that you want to continue, you C must take appropriate action and set INFO(1) = 1 C If C IDID = -1, The code has taken about 500 steps. C If you want to continue, set INFO(1) = 1 and C call the code again. An additional 500 steps C will be allowed. C C IDID = -2, The error tolerances RTOL, ATOL have been C increased to values the code estimates appropriate C for continuing. You may want to change them C yourself. If you are sure you want to continue C with relaxed error tolerances, set INFO(1)=1 and C call the code again. C C IDID = -3, A solution component is zero and you set the C corresponding component of ATOL to zero. If you C are sure you want to continue, you must first C alter the error criterion to use positive values C for those components of ATOL corresponding to zero C solution components, then set INFO(1)=1 and call C the code again. C C IDID = -4,-5 --- Cannot occur with this code. C C IDID = -6, Repeated error test failures occurred on the C last attempted step in SDASSL. A singularity in the C solution may be present. If you are absolutely C certain you want to continue, you should restart C the integration. (Provide initial values of Y and C YPRIME which are consistent) C C IDID = -7, Repeated convergence test failures occurred C on the last attempted step in SDASSL. An inaccurate C or ill-conditioned JACOBIAN may be the problem. If C you are absolutely certain you want to continue, you C should restart the integration. C C IDID = -8, The matrix of partial derivatives is singular. C Some of your equations may be redundant. C SDASSL cannot solve the problem as stated. C It is possible that the redundant equations C could be removed, and then SDASSL could C solve the problem. It is also possible C that a solution to your problem either C does not exist or is not unique. C C IDID = -9, SDASSL had multiple convergence test C failures, preceeded by multiple error C test failures, on the last attempted step. C It is possible that your problem C is ill-posed, and cannot be solved C using this code. Or, there may be a C discontinuity or a singularity in the C solution. If you are absolutely certain C you want to continue, you should restart C the integration. C C IDID =-10, SDASSL had multiple convergence test failures C because IRES was equal to minus one. C If you are absolutely certain you want C to continue, you should restart the C integration. C C IDID =-11, IRES=-2 was encountered, and control is being C returned to the calling program. C C IDID =-12, SDASSL failed to compute the initial YPRIME. C This could happen because the initial C approximation to YPRIME was not very good, or C if a YPRIME consistent with the initial Y C does not exist. The problem could also be caused C by an inaccurate or singular iteration matrix. C C IDID = -13,..,-32 --- Cannot occur with this code. C C C *** Following a terminated task *** C C If IDID= -33, you cannot continue the solution of this problem. C An attempt to do so will result in your C run being terminated. C C C -------- ERROR MESSAGES --------------------------------------------- C C The SLATEC error print routine XERMSG is called in the event of C unsuccessful completion of a task. Most of these are treated as C "recoverable errors", which means that (unless the user has directed C otherwise) control will be returned to the calling program for C possible action after the message has been printed. C C In the event of a negative value of IDID other than -33, an appro- C priate message is printed and the "error number" printed by XERMSG C is the value of IDID. There are quite a number of illegal input C errors that can lead to a returned value IDID=-33. The conditions C and their printed "error numbers" are as follows: C C Error number Condition C C 1 Some element of INFO vector is not zero or one. C 2 NEQ .le. 0 C 3 MAXORD not in range. C 4 LRW is less than the required length for RWORK. C 5 LIW is less than the required length for IWORK. C 6 Some element of RTOL is .lt. 0 C 7 Some element of ATOL is .lt. 0 C 8 All elements of RTOL and ATOL are zero. C 9 INFO(4)=1 and TSTOP is behind TOUT. C 10 HMAX .lt. 0.0 C 11 TOUT is behind T. C 12 INFO(8)=1 and H0=0.0 C 13 Some element of WT is .le. 0.0 C 14 TOUT is too close to T to start integration. C 15 INFO(4)=1 and TSTOP is behind T. C 16 --( Not used in this version )-- C 17 ML illegal. Either .lt. 0 or .gt. NEQ C 18 MU illegal. Either .lt. 0 or .gt. NEQ C 19 TOUT = T. C C If SDASSL is called again without any action taken to remove the C cause of an unsuccessful return, XERMSG will be called with a fatal C error flag, which will cause unconditional termination of the C program. There are two such fatal errors: C C Error number -998: The last step was terminated with a negative C value of IDID other than -33, and no appropriate action was C taken. C C Error number -999: The previous call was terminated because of C illegal input (IDID=-33) and there is illegal input in the C present call, as well. (Suspect infinite loop.) C C --------------------------------------------------------------------- C C***REFERENCES A DESCRIPTION OF DASSL: A DIFFERENTIAL/ALGEBRAIC C SYSTEM SOLVER, L. R. PETZOLD, SAND82-8637, C SANDIA NATIONAL LABORATORIES, SEPTEMBER 1982. C***ROUTINES CALLED R1MACH, SDAINI, SDANRM, SDASTP, SDATRP, SDAWTS, C XERMSG C***REVISION HISTORY (YYMMDD) C 830315 DATE WRITTEN C 880387 Code changes made. All common statements have been C replaced by a DATA statement, which defines pointers into C RWORK, and PARAMETER statements which define pointers C into IWORK. As well the documentation has gone through C grammatical changes. C 881005 The prologue has been changed to mixed case. C The subordinate routines had revision dates changed to C this date, although the documentation for these routines C is all upper case. No code changes. C 890511 Code changes made. The DATA statement in the declaration C section of SDASSL was replaced with a PARAMETER C statement. Also the statement S = 100.E0 was removed C from the top of the Newton iteration in SDASTP. C The subordinate routines had revision dates changed to C this date. C 890517 The revision date syntax was replaced with the revision C history syntax. Also the "DECK" comment was added to C the top of all subroutines. These changes are consistent C with new SLATEC guidelines. C The subordinate routines had revision dates changed to C this date. No code changes. C 891013 Code changes made. C Removed all occurrances of FLOAT. All operations C are now performed with "mixed-mode" arithmetic. C Also, specific function names were replaced with generic C function names to be consistent with new SLATEC guidelines. C In particular: C Replaced AMIN1 with MIN everywhere. C Replaced MIN0 with MIN everywhere. C Replaced AMAX1 with MAX everywhere. C Replaced MAX0 with MAX everywhere. C Also replaced REVISION DATE with REVISION HISTORY in all C subordinate routines. C 901004 Miscellaneous changes to prologue to complete conversion C to SLATEC 4.0 format. No code changes. (F.N.Fritsch) C 901009 Corrected GAMS classification code and converted subsidiary C routines to 4.0 format. No code changes. (F.N.Fritsch) C 901010 Converted XERRWV calls to XERMSG calls. (R.Clemens,AFWL) C 901019 Code changes made. C Merged SLATEC 4.0 changes with previous changes made C by C. Ulrich. Below is a history of the changes made by C C. Ulrich. (Changes in subsidiary routines are implied C by this history) C 891228 Bug was found and repaired inside the SDASSL C and SDAINI routines. SDAINI was incorrectly C returning the initial T with Y and YPRIME C computed at T+H. The routine now returns T+H C rather than the initial T. C Cosmetic changes made to SDASTP. C 900904 Three modifications were made to fix a bug (inside C SDASSL) re interpolation for continuation calls and C cases where TN is very close to TSTOP: C C 1) In testing for whether H is too large, just C compare H to (TSTOP - TN), rather than C (TSTOP - TN) * (1-4*UROUND), and set H to C TSTOP - TN. This will force SDASTP to step C exactly to TSTOP under certain situations C (i.e. when H returned from SDASTP would otherwise C take TN beyond TSTOP). C C 2) Inside the SDASTP loop, interpolate exactly to C TSTOP if TN is very close to TSTOP (rather than C interpolating to within roundoff of TSTOP). C C 3) Modified IDID description for IDID = 2 to say that C the solution is returned by stepping exactly to C TSTOP, rather than TOUT. (In some cases the C solution is actually obtained by extrapolating C over a distance near unit roundoff to TSTOP, C but this small distance is deemed acceptable in C these circumstances.) C 901026 Added explicit declarations for all variables and minor C cosmetic changes to prologue, removed unreferenced labels, C and improved XERMSG calls. (FNF) C 901030 Added ERROR MESSAGES section and reworked other sections to C be of more uniform format. (FNF) C 910624 Fixed minor bug related to HMAX (five lines ending C in label 526). (LRP) C C***END PROLOGUE SDASSL C C**End C C Declare arguments. C INTEGER NEQ, INFO(15), IDID, LRW, IWORK(*), LIW, IPAR(*) REAL T, Y(*), YPRIME(*), TOUT, RTOL(*), ATOL(*), RWORK(*), * RPAR(*) EXTERNAL RES, JAC C C Declare externals. C EXTERNAL R1MACH, SDAINI, SDANRM, SDASTP, SDATRP, SDAWTS, XERMSG REAL R1MACH, SDANRM C C Declare local variables. C INTEGER I, ITEMP, LALPHA, LBETA, LCJ, LCJOLD, LCTF, LDELTA, * LENIW, LENPD, LENRW, LE, LETF, LGAMMA, LH, LHMAX, LHOLD, LIPVT, * LJCALC, LK, LKOLD, LIWM, LML, LMTYPE, LMU, LMXORD, LNJE, LNPD, * LNRE, LNS, LNST, LNSTL, LPD, LPHASE, LPHI, LPSI, LROUND, LS, * LSIGMA, LTN, LTSTOP, LWM, LWT, MBAND, MSAVE, MXORD, NPD, NTEMP, * NZFLG REAL ATOLI, H, HMAX, HMIN, HO, R, RH, RTOLI, TDIST, TN, TNEXT, * TSTOP, UROUND, YPNORM LOGICAL DONE C Auxiliary variables for conversion of values to be included in C error messages. CHARACTER*8 XERN1, XERN2 CHARACTER*16 XERN3, XERN4 C C SET POINTERS INTO IWORK PARAMETER (LML=1, LMU=2, LMXORD=3, LMTYPE=4, LNST=11, * LNRE=12, LNJE=13, LETF=14, LCTF=15, LNPD=16, * LIPVT=21, LJCALC=5, LPHASE=6, LK=7, LKOLD=8, * LNS=9, LNSTL=10, LIWM=1) C C SET RELATIVE OFFSET INTO RWORK PARAMETER (NPD=1) C C SET POINTERS INTO RWORK PARAMETER (LTSTOP=1, LHMAX=2, LH=3, LTN=4, * LCJ=5, LCJOLD=6, LHOLD=7, LS=8, LROUND=9, * LALPHA=11, LBETA=17, LGAMMA=23, * LPSI=29, LSIGMA=35, LDELTA=41) C C***FIRST EXECUTABLE STATEMENT SDASSL IF(INFO(1).NE.0)GO TO 100 C C----------------------------------------------------------------------- C THIS BLOCK IS EXECUTED FOR THE INITIAL CALL ONLY. C IT CONTAINS CHECKING OF INPUTS AND INITIALIZATIONS. C----------------------------------------------------------------------- C C FIRST CHECK INFO ARRAY TO MAKE SURE ALL ELEMENTS OF INFO C ARE EITHER ZERO OR ONE. DO 10 I=2,11 IF(INFO(I).NE.0.AND.INFO(I).NE.1)GO TO 701 10 CONTINUE C IF(NEQ.LE.0)GO TO 702 C C CHECK AND COMPUTE MAXIMUM ORDER MXORD=5 IF(INFO(9).EQ.0)GO TO 20 MXORD=IWORK(LMXORD) IF(MXORD.LT.1.OR.MXORD.GT.5)GO TO 703 20 IWORK(LMXORD)=MXORD C C COMPUTE MTYPE,LENPD,LENRW.CHECK ML AND MU. IF(INFO(6).NE.0)GO TO 40 LENPD=NEQ**2 LENRW=40+(IWORK(LMXORD)+4)*NEQ+LENPD IF(INFO(5).NE.0)GO TO 30 IWORK(LMTYPE)=2 GO TO 60 30 IWORK(LMTYPE)=1 GO TO 60 40 IF(IWORK(LML).LT.0.OR.IWORK(LML).GE.NEQ)GO TO 717 IF(IWORK(LMU).LT.0.OR.IWORK(LMU).GE.NEQ)GO TO 718 LENPD=(2*IWORK(LML)+IWORK(LMU)+1)*NEQ IF(INFO(5).NE.0)GO TO 50 IWORK(LMTYPE)=5 MBAND=IWORK(LML)+IWORK(LMU)+1 MSAVE=(NEQ/MBAND)+1 LENRW=40+(IWORK(LMXORD)+4)*NEQ+LENPD+2*MSAVE GO TO 60 50 IWORK(LMTYPE)=4 LENRW=40+(IWORK(LMXORD)+4)*NEQ+LENPD C C CHECK LENGTHS OF RWORK AND IWORK 60 LENIW=20+NEQ IWORK(LNPD)=LENPD IF(LRW.LT.LENRW)GO TO 704 IF(LIW.LT.LENIW)GO TO 705 C C CHECK TO SEE THAT TOUT IS DIFFERENT FROM T IF(TOUT .EQ. T)GO TO 719 C C CHECK HMAX IF(INFO(7).EQ.0)GO TO 70 HMAX=RWORK(LHMAX) IF(HMAX.LE.0.0E0)GO TO 710 70 CONTINUE C C INITIALIZE COUNTERS IWORK(LNST)=0 IWORK(LNRE)=0 IWORK(LNJE)=0 C IWORK(LNSTL)=0 IDID=1 GO TO 200 C C----------------------------------------------------------------------- C THIS BLOCK IS FOR CONTINUATION CALLS C ONLY. HERE WE CHECK INFO(1),AND IF THE C LAST STEP WAS INTERRUPTED WE CHECK WHETHER C APPROPRIATE ACTION WAS TAKEN. C----------------------------------------------------------------------- C 100 CONTINUE IF(INFO(1).EQ.1)GO TO 110 IF(INFO(1).NE.-1)GO TO 701 C C IF WE ARE HERE, THE LAST STEP WAS INTERRUPTED C BY AN ERROR CONDITION FROM SDASTP,AND C APPROPRIATE ACTION WAS NOT TAKEN. THIS C IS A FATAL ERROR. WRITE (XERN1, '(I8)') IDID CALL XERMSG ('SLATEC', 'SDASSL', * 'THE LAST STEP TERMINATED WITH A NEGATIVE VALUE OF IDID = ' // * XERN1 // ' AND NO APPROPRIATE ACTION WAS TAKEN. ' // * 'RUN TERMINATED', -998, 2) RETURN 110 CONTINUE IWORK(LNSTL)=IWORK(LNST) C C----------------------------------------------------------------------- C THIS BLOCK IS EXECUTED ON ALL CALLS. C THE ERROR TOLERANCE PARAMETERS ARE C CHECKED, AND THE WORK ARRAY POINTERS C ARE SET. C----------------------------------------------------------------------- C 200 CONTINUE C CHECK RTOL,ATOL NZFLG=0 RTOLI=RTOL(1) ATOLI=ATOL(1) DO 210 I=1,NEQ IF(INFO(2).EQ.1)RTOLI=RTOL(I) IF(INFO(2).EQ.1)ATOLI=ATOL(I) IF(RTOLI.GT.0.0E0.OR.ATOLI.GT.0.0E0)NZFLG=1 IF(RTOLI.LT.0.0E0)GO TO 706 IF(ATOLI.LT.0.0E0)GO TO 707 210 CONTINUE IF(NZFLG.EQ.0)GO TO 708 C C SET UP RWORK STORAGE.IWORK STORAGE IS FIXED C IN DATA STATEMENT. LE=LDELTA+NEQ LWT=LE+NEQ LPHI=LWT+NEQ LPD=LPHI+(IWORK(LMXORD)+1)*NEQ LWM=LPD NTEMP=NPD+IWORK(LNPD) IF(INFO(1).EQ.1)GO TO 400 C C----------------------------------------------------------------------- C THIS BLOCK IS EXECUTED ON THE INITIAL CALL C ONLY. SET THE INITIAL STEP SIZE, AND C THE ERROR WEIGHT VECTOR, AND PHI. C COMPUTE INITIAL YPRIME, IF NECESSARY. C----------------------------------------------------------------------- C TN=T IDID=1 C C SET ERROR WEIGHT VECTOR WT CALL SDAWTS(NEQ,INFO(2),RTOL,ATOL,Y,RWORK(LWT),RPAR,IPAR) DO 305 I = 1,NEQ IF(RWORK(LWT+I-1).LE.0.0E0) GO TO 713 305 CONTINUE C C COMPUTE UNIT ROUNDOFF AND HMIN UROUND = R1MACH(4) RWORK(LROUND) = UROUND HMIN = 4.0E0*UROUND*MAX(ABS(T),ABS(TOUT)) C C CHECK INITIAL INTERVAL TO SEE THAT IT IS LONG ENOUGH TDIST = ABS(TOUT - T) IF(TDIST .LT. HMIN) GO TO 714 C C CHECK HO, IF THIS WAS INPUT IF (INFO(8) .EQ. 0) GO TO 310 HO = RWORK(LH) IF ((TOUT - T)*HO .LT. 0.0E0) GO TO 711 IF (HO .EQ. 0.0E0) GO TO 712 GO TO 320 310 CONTINUE C C COMPUTE INITIAL STEPSIZE, TO BE USED BY EITHER C SDASTP OR SDAINI, DEPENDING ON INFO(11) HO = 0.001E0*TDIST YPNORM = SDANRM(NEQ,YPRIME,RWORK(LWT),RPAR,IPAR) IF (YPNORM .GT. 0.5E0/HO) HO = 0.5E0/YPNORM HO = SIGN(HO,TOUT-T) C ADJUST HO IF NECESSARY TO MEET HMAX BOUND 320 IF (INFO(7) .EQ. 0) GO TO 330 RH = ABS(HO)/RWORK(LHMAX) IF (RH .GT. 1.0E0) HO = HO/RH C COMPUTE TSTOP, IF APPLICABLE 330 IF (INFO(4) .EQ. 0) GO TO 340 TSTOP = RWORK(LTSTOP) IF ((TSTOP - T)*HO .LT. 0.0E0) GO TO 715 IF ((T + HO - TSTOP)*HO .GT. 0.0E0) HO = TSTOP - T IF ((TSTOP - TOUT)*HO .LT. 0.0E0) GO TO 709 C C COMPUTE INITIAL DERIVATIVE, UPDATING TN AND Y, IF APPLICABLE 340 IF (INFO(11) .EQ. 0) GO TO 350 CALL SDAINI(TN,Y,YPRIME,NEQ, * RES,JAC,HO,RWORK(LWT),IDID,RPAR,IPAR, * RWORK(LPHI),RWORK(LDELTA),RWORK(LE), * RWORK(LWM),IWORK(LIWM),HMIN,RWORK(LROUND), * INFO(10),NTEMP) IF (IDID .LT. 0) GO TO 390 C C LOAD H WITH HO. STORE H IN RWORK(LH) 350 H = HO RWORK(LH) = H C C LOAD Y AND H*YPRIME INTO PHI(*,1) AND PHI(*,2) ITEMP = LPHI + NEQ DO 370 I = 1,NEQ RWORK(LPHI + I - 1) = Y(I) 370 RWORK(ITEMP + I - 1) = H*YPRIME(I) C 390 GO TO 500 C C------------------------------------------------------- C THIS BLOCK IS FOR CONTINUATION CALLS ONLY. ITS C PURPOSE IS TO CHECK STOP CONDITIONS BEFORE C TAKING A STEP. C ADJUST H IF NECESSARY TO MEET HMAX BOUND C------------------------------------------------------- C 400 CONTINUE UROUND=RWORK(LROUND) DONE = .FALSE. TN=RWORK(LTN) H=RWORK(LH) IF(INFO(7) .EQ. 0) GO TO 410 RH = ABS(H)/RWORK(LHMAX) IF(RH .GT. 1.0E0) H = H/RH 410 CONTINUE IF(T .EQ. TOUT) GO TO 719 IF((T - TOUT)*H .GT. 0.0E0) GO TO 711 IF(INFO(4) .EQ. 1) GO TO 430 IF(INFO(3) .EQ. 1) GO TO 420 IF((TN-TOUT)*H.LT.0.0E0)GO TO 490 CALL SDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), * RWORK(LPHI),RWORK(LPSI)) T=TOUT IDID = 3 DONE = .TRUE. GO TO 490 420 IF((TN-T)*H .LE. 0.0E0) GO TO 490 IF((TN - TOUT)*H .GT. 0.0E0) GO TO 425 CALL SDATRP(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD), * RWORK(LPHI),RWORK(LPSI)) T = TN IDID = 1 DONE = .TRUE. GO TO 490 425 CONTINUE CALL SDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), * RWORK(LPHI),RWORK(LPSI)) T = TOUT IDID = 3 DONE = .TRUE. GO TO 490 430 IF(INFO(3) .EQ. 1) GO TO 440 TSTOP=RWORK(LTSTOP) IF((TN-TSTOP)*H.GT.0.0E0) GO TO 715 IF((TSTOP-TOUT)*H.LT.0.0E0)GO TO 709 IF((TN-TOUT)*H.LT.0.0E0)GO TO 450 CALL SDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), * RWORK(LPHI),RWORK(LPSI)) T=TOUT IDID = 3 DONE = .TRUE. GO TO 490 440 TSTOP = RWORK(LTSTOP) IF((TN-TSTOP)*H .GT. 0.0E0) GO TO 715 IF((TSTOP-TOUT)*H .LT. 0.0E0) GO TO 709 IF((TN-T)*H .LE. 0.0E0) GO TO 450 IF((TN - TOUT)*H .GT. 0.0E0) GO TO 445 CALL SDATRP(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD), * RWORK(LPHI),RWORK(LPSI)) T = TN IDID = 1 DONE = .TRUE. GO TO 490 445 CONTINUE CALL SDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), * RWORK(LPHI),RWORK(LPSI)) T = TOUT IDID = 3 DONE = .TRUE. GO TO 490 450 CONTINUE C CHECK WHETHER WE ARE WITHIN ROUNDOFF OF TSTOP IF(ABS(TN-TSTOP).GT.100.0E0*UROUND* * (ABS(TN)+ABS(H)))GO TO 460 CALL SDATRP(TN,TSTOP,Y,YPRIME,NEQ,IWORK(LKOLD), * RWORK(LPHI),RWORK(LPSI)) IDID=2 T=TSTOP DONE = .TRUE. GO TO 490 460 TNEXT=TN+H IF((TNEXT-TSTOP)*H.LE.0.0E0)GO TO 490 H=TSTOP-TN RWORK(LH)=H C 490 IF (DONE) GO TO 580 C C------------------------------------------------------- C THE NEXT BLOCK CONTAINS THE CALL TO THE C ONE-STEP INTEGRATOR SDASTP. C THIS IS A LOOPING POINT FOR THE INTEGRATION STEPS. C CHECK FOR TOO MANY STEPS. C UPDATE WT. C CHECK FOR TOO MUCH ACCURACY REQUESTED. C COMPUTE MINIMUM STEPSIZE. C------------------------------------------------------- C 500 CONTINUE C CHECK FOR FAILURE TO COMPUTE INITIAL YPRIME IF (IDID .EQ. -12) GO TO 527 C C CHECK FOR TOO MANY STEPS IF((IWORK(LNST)-IWORK(LNSTL)).LT.500) * GO TO 510 IDID=-1 GO TO 527 C C UPDATE WT 510 CALL SDAWTS(NEQ,INFO(2),RTOL,ATOL,RWORK(LPHI), * RWORK(LWT),RPAR,IPAR) DO 520 I=1,NEQ IF(RWORK(I+LWT-1).GT.0.0E0)GO TO 520 IDID=-3 GO TO 527 520 CONTINUE C C TEST FOR TOO MUCH ACCURACY REQUESTED. R=SDANRM(NEQ,RWORK(LPHI),RWORK(LWT),RPAR,IPAR)* * 100.0E0*UROUND IF(R.LE.1.0E0)GO TO 525 C MULTIPLY RTOL AND ATOL BY R AND RETURN IF(INFO(2).EQ.1)GO TO 523 RTOL(1)=R*RTOL(1) ATOL(1)=R*ATOL(1) IDID=-2 GO TO 527 523 DO 524 I=1,NEQ RTOL(I)=R*RTOL(I) 524 ATOL(I)=R*ATOL(I) IDID=-2 GO TO 527 525 CONTINUE C C COMPUTE MINIMUM STEPSIZE HMIN=4.0E0*UROUND*MAX(ABS(TN),ABS(TOUT)) C C TEST H VS. HMAX IF (INFO(7) .EQ. 0) GO TO 526 RH = ABS(H)/RWORK(LHMAX) IF (RH .GT. 1.0E0) H = H/RH 526 CONTINUE C CALL SDASTP(TN,Y,YPRIME,NEQ, * RES,JAC,H,RWORK(LWT),INFO(1),IDID,RPAR,IPAR, * RWORK(LPHI),RWORK(LDELTA),RWORK(LE), * RWORK(LWM),IWORK(LIWM), * RWORK(LALPHA),RWORK(LBETA),RWORK(LGAMMA), * RWORK(LPSI),RWORK(LSIGMA), * RWORK(LCJ),RWORK(LCJOLD),RWORK(LHOLD), * RWORK(LS),HMIN,RWORK(LROUND), * IWORK(LPHASE),IWORK(LJCALC),IWORK(LK), * IWORK(LKOLD),IWORK(LNS),INFO(10),NTEMP) 527 IF(IDID.LT.0)GO TO 600 C C-------------------------------------------------------- C THIS BLOCK HANDLES THE CASE OF A SUCCESSFUL RETURN C FROM SDASTP (IDID=1). TEST FOR STOP CONDITIONS. C-------------------------------------------------------- C IF(INFO(4).NE.0)GO TO 540 IF(INFO(3).NE.0)GO TO 530 IF((TN-TOUT)*H.LT.0.0E0)GO TO 500 CALL SDATRP(TN,TOUT,Y,YPRIME,NEQ, * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) IDID=3 T=TOUT GO TO 580 530 IF((TN-TOUT)*H.GE.0.0E0)GO TO 535 T=TN IDID=1 GO TO 580 535 CALL SDATRP(TN,TOUT,Y,YPRIME,NEQ, * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) IDID=3 T=TOUT GO TO 580 540 IF(INFO(3).NE.0)GO TO 550 IF((TN-TOUT)*H.LT.0.0E0)GO TO 542 CALL SDATRP(TN,TOUT,Y,YPRIME,NEQ, * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) T=TOUT IDID=3 GO TO 580 542 IF(ABS(TN-TSTOP).LE.100.0E0*UROUND* * (ABS(TN)+ABS(H)))GO TO 545 TNEXT=TN+H IF((TNEXT-TSTOP)*H.LE.0.0E0)GO TO 500 H=TSTOP-TN GO TO 500 545 CALL SDATRP(TN,TSTOP,Y,YPRIME,NEQ, * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) IDID=2 T=TSTOP GO TO 580 550 IF((TN-TOUT)*H.GE.0.0E0)GO TO 555 IF(ABS(TN-TSTOP).LE.100.0E0*UROUND*(ABS(TN)+ABS(H)))GO TO 552 T=TN IDID=1 GO TO 580 552 CALL SDATRP(TN,TSTOP,Y,YPRIME,NEQ, * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) IDID=2 T=TSTOP GO TO 580 555 CALL SDATRP(TN,TOUT,Y,YPRIME,NEQ, * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) T=TOUT IDID=3 GO TO 580 C C-------------------------------------------------------- C ALL SUCCESSFUL RETURNS FROM SDASSL ARE MADE FROM C THIS BLOCK. C-------------------------------------------------------- C 580 CONTINUE RWORK(LTN)=TN RWORK(LH)=H RETURN C C----------------------------------------------------------------------- C THIS BLOCK HANDLES ALL UNSUCCESSFUL C RETURNS OTHER THAN FOR ILLEGAL INPUT. C----------------------------------------------------------------------- C 600 CONTINUE ITEMP=-IDID GO TO (610,620,630,690,690,640,650,660,670,675, * 680,685), ITEMP C C THE MAXIMUM NUMBER OF STEPS WAS TAKEN BEFORE C REACHING TOUT 610 WRITE (XERN3, '(1P,E15.6)') TN CALL XERMSG ('SLATEC', 'SDASSL', * 'AT CURRENT T = ' // XERN3 // ' 500 STEPS TAKEN ON THIS ' // * 'CALL BEFORE REACHING TOUT', IDID, 1) GO TO 690 C C TOO MUCH ACCURACY FOR MACHINE PRECISION 620 WRITE (XERN3, '(1P,E15.6)') TN CALL XERMSG ('SLATEC', 'SDASSL', * 'AT T = ' // XERN3 // ' TOO MUCH ACCURACY REQUESTED FOR ' // * 'PRECISION OF MACHINE. RTOL AND ATOL WERE INCREASED TO ' // * 'APPROPRIATE VALUES', IDID, 1) GO TO 690 C C WT(I) .LE. 0.0 FOR SOME I (NOT AT START OF PROBLEM) 630 WRITE (XERN3, '(1P,E15.6)') TN CALL XERMSG ('SLATEC', 'SDASSL', * 'AT T = ' // XERN3 // ' SOME ELEMENT OF WT HAS BECOME .LE. ' // * '0.0', IDID, 1) GO TO 690 C C ERROR TEST FAILED REPEATEDLY OR WITH H=HMIN 640 WRITE (XERN3, '(1P,E15.6)') TN WRITE (XERN4, '(1P,E15.6)') H CALL XERMSG ('SLATEC', 'SDASSL', * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // * ' THE ERROR TEST FAILED REPEATEDLY OR WITH ABS(H)=HMIN', * IDID, 1) GO TO 690 C C CORRECTOR CONVERGENCE FAILED REPEATEDLY OR WITH H=HMIN 650 WRITE (XERN3, '(1P,E15.6)') TN WRITE (XERN4, '(1P,E15.6)') H CALL XERMSG ('SLATEC', 'SDASSL', * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // * ' THE CORRECTOR FAILED TO CONVERGE REPEATEDLY OR WITH ' // * 'ABS(H)=HMIN', IDID, 1) GO TO 690 C C THE ITERATION MATRIX IS SINGULAR 660 WRITE (XERN3, '(1P,E15.6)') TN WRITE (XERN4, '(1P,E15.6)') H CALL XERMSG ('SLATEC', 'SDASSL', * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // * ' THE ITERATION MATRIX IS SINGULAR', IDID, 1) GO TO 690 C C CORRECTOR FAILURE PRECEEDED BY ERROR TEST FAILURES. 670 WRITE (XERN3, '(1P,E15.6)') TN WRITE (XERN4, '(1P,E15.6)') H CALL XERMSG ('SLATEC', 'SDASSL', * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // * ' THE CORRECTOR COULD NOT CONVERGE. ALSO, THE ERROR TEST ' // * 'FAILED REPEATEDLY.', IDID, 1) GO TO 690 C C CORRECTOR FAILURE BECAUSE IRES = -1 675 WRITE (XERN3, '(1P,E15.6)') TN WRITE (XERN4, '(1P,E15.6)') H CALL XERMSG ('SLATEC', 'SDASSL', * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // * ' THE CORRECTOR COULD NOT CONVERGE BECAUSE IRES WAS EQUAL ' // * 'TO MINUS ONE', IDID, 1) GO TO 690 C C FAILURE BECAUSE IRES = -2 680 WRITE (XERN3, '(1P,E15.6)') TN WRITE (XERN4, '(1P,E15.6)') H CALL XERMSG ('SLATEC', 'SDASSL', * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // * ' IRES WAS EQUAL TO MINUS TWO', IDID, 1) GO TO 690 C C FAILED TO COMPUTE INITIAL YPRIME 685 WRITE (XERN3, '(1P,E15.6)') TN WRITE (XERN4, '(1P,E15.6)') HO CALL XERMSG ('SLATEC', 'SDASSL', * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // * ' THE INITIAL YPRIME COULD NOT BE COMPUTED', IDID, 1) GO TO 690 C 690 CONTINUE INFO(1)=-1 T=TN RWORK(LTN)=TN RWORK(LH)=H RETURN C C----------------------------------------------------------------------- C THIS BLOCK HANDLES ALL ERROR RETURNS DUE C TO ILLEGAL INPUT, AS DETECTED BEFORE CALLING C SDASTP. FIRST THE ERROR MESSAGE ROUTINE IS C CALLED. IF THIS HAPPENS TWICE IN C SUCCESSION, EXECUTION IS TERMINATED C C----------------------------------------------------------------------- 701 CALL XERMSG ('SLATEC', 'SDASSL', * 'SOME ELEMENT OF INFO VECTOR IS NOT ZERO OR ONE', 1, 1) GO TO 750 C 702 WRITE (XERN1, '(I8)') NEQ CALL XERMSG ('SLATEC', 'SDASSL', * 'NEQ = ' // XERN1 // ' .LE. 0', 2, 1) GO TO 750 C 703 WRITE (XERN1, '(I8)') MXORD CALL XERMSG ('SLATEC', 'SDASSL', * 'MAXORD = ' // XERN1 // ' NOT IN RANGE', 3, 1) GO TO 750 C 704 WRITE (XERN1, '(I8)') LENRW WRITE (XERN2, '(I8)') LRW CALL XERMSG ('SLATEC', 'SDASSL', * 'RWORK LENGTH NEEDED, LENRW = ' // XERN1 // * ', EXCEEDS LRW = ' // XERN2, 4, 1) GO TO 750 C 705 WRITE (XERN1, '(I8)') LENIW WRITE (XERN2, '(I8)') LIW CALL XERMSG ('SLATEC', 'SDASSL', * 'IWORK LENGTH NEEDED, LENIW = ' // XERN1 // * ', EXCEEDS LIW = ' // XERN2, 5, 1) GO TO 750 C 706 CALL XERMSG ('SLATEC', 'SDASSL', * 'SOME ELEMENT OF RTOL IS .LT. 0', 6, 1) GO TO 750 C 707 CALL XERMSG ('SLATEC', 'SDASSL', * 'SOME ELEMENT OF ATOL IS .LT. 0', 7, 1) GO TO 750 C 708 CALL XERMSG ('SLATEC', 'SDASSL', * 'ALL ELEMENTS OF RTOL AND ATOL ARE ZERO', 8, 1) GO TO 750 C 709 WRITE (XERN3, '(1P,E15.6)') TSTOP WRITE (XERN4, '(1P,E15.6)') TOUT CALL XERMSG ('SLATEC', 'SDASSL', * 'INFO(4) = 1 AND TSTOP = ' // XERN3 // ' BEHIND TOUT = ' // * XERN4, 9, 1) GO TO 750 C 710 WRITE (XERN3, '(1P,E15.6)') HMAX CALL XERMSG ('SLATEC', 'SDASSL', * 'HMAX = ' // XERN3 // ' .LT. 0.0', 10, 1) GO TO 750 C 711 WRITE (XERN3, '(1P,E15.6)') TOUT WRITE (XERN4, '(1P,E15.6)') T CALL XERMSG ('SLATEC', 'SDASSL', * 'TOUT = ' // XERN3 // ' BEHIND T = ' // XERN4, 11, 1) GO TO 750 C 712 CALL XERMSG ('SLATEC', 'SDASSL', * 'INFO(8)=1 AND H0=0.0', 12, 1) GO TO 750 C 713 CALL XERMSG ('SLATEC', 'SDASSL', * 'SOME ELEMENT OF WT IS .LE. 0.0', 13, 1) GO TO 750 C 714 WRITE (XERN3, '(1P,E15.6)') TOUT WRITE (XERN4, '(1P,E15.6)') T CALL XERMSG ('SLATEC', 'SDASSL', * 'TOUT = ' // XERN3 // ' TOO CLOSE TO T = ' // XERN4 // * ' TO START INTEGRATION', 14, 1) GO TO 750 C 715 WRITE (XERN3, '(1P,E15.6)') TSTOP WRITE (XERN4, '(1P,E15.6)') T CALL XERMSG ('SLATEC', 'SDASSL', * 'INFO(4)=1 AND TSTOP = ' // XERN3 // ' BEHIND T = ' // XERN4, * 15, 1) GO TO 750 C 717 WRITE (XERN1, '(I8)') IWORK(LML) CALL XERMSG ('SLATEC', 'SDASSL', * 'ML = ' // XERN1 // ' ILLEGAL. EITHER .LT. 0 OR .GT. NEQ', * 17, 1) GO TO 750 C 718 WRITE (XERN1, '(I8)') IWORK(LMU) CALL XERMSG ('SLATEC', 'SDASSL', * 'MU = ' // XERN1 // ' ILLEGAL. EITHER .LT. 0 OR .GT. NEQ', * 18, 1) GO TO 750 C 719 WRITE (XERN3, '(1P,E15.6)') TOUT CALL XERMSG ('SLATEC', 'SDASSL', * 'TOUT = T = ' // XERN3, 19, 1) GO TO 750 C 750 IDID=-33 IF(INFO(1).EQ.-1) THEN CALL XERMSG ('SLATEC', 'SDASSL', * 'REPEATED OCCURRENCES OF ILLEGAL INPUT$$' // * 'RUN TERMINATED. APPARENT INFINITE LOOP', -999, 2) ENDIF C INFO(1)=-1 RETURN C-----------END OF SUBROUTINE SDASSL------------------------------------ END SUBROUTINE SDAWTS (NEQ, IWT, RTOL, ATOL, Y, WT, RPAR, IPAR) C***BEGIN PROLOGUE SDAWTS C***SUBSIDIARY C***PURPOSE Set error weight vector for SDASSL. C***LIBRARY SLATEC (DASSL) C***TYPE SINGLE PRECISION (SDAWTS-S, DDAWTS-D) C***AUTHOR PETZOLD, LINDA R., (LLNL) C***DESCRIPTION C----------------------------------------------------------------------- C THIS SUBROUTINE SETS THE ERROR WEIGHT VECTOR C WT ACCORDING TO WT(I)=RTOL(I)*ABS(Y(I))+ATOL(I), C I=1,-,N. C RTOL AND ATOL ARE SCALARS IF IWT = 0, C AND VECTORS IF IWT = 1. C----------------------------------------------------------------------- C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 830315 DATE WRITTEN C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. C 901026 Added explicit declarations for all variables and minor C cosmetic changes to prologue. (FNF) C***END PROLOGUE SDAWTS C INTEGER NEQ, IWT, IPAR(*) REAL RTOL(*), ATOL(*), Y(*), WT(*), RPAR(*) C INTEGER I REAL ATOLI, RTOLI C C***FIRST EXECUTABLE STATEMENT SDAWTS RTOLI=RTOL(1) ATOLI=ATOL(1) DO 20 I=1,NEQ IF (IWT .EQ.0) GO TO 10 RTOLI=RTOL(I) ATOLI=ATOL(I) 10 WT(I)=RTOLI*ABS(Y(I))+ATOLI 20 CONTINUE RETURN C-----------END OF SUBROUTINE SDAWTS------------------------------------ END REAL FUNCTION SDANRM (NEQ, V, WT, RPAR, IPAR) C***BEGIN PROLOGUE SDANRM C***SUBSIDIARY C***PURPOSE Compute vector norm for SDASSL. C***LIBRARY SLATEC (DASSL) C***TYPE SINGLE PRECISION (SDANRM-S, DDANRM-D) C***AUTHOR PETZOLD, LINDA R., (LLNL) C***DESCRIPTION C----------------------------------------------------------------------- C THIS FUNCTION ROUTINE COMPUTES THE WEIGHTED C ROOT-MEAN-SQUARE NORM OF THE VECTOR OF LENGTH C NEQ CONTAINED IN THE ARRAY V,WITH WEIGHTS C CONTAINED IN THE ARRAY WT OF LENGTH NEQ. C SDANRM=SQRT((1/NEQ)*SUM(V(I)/WT(I))**2) C----------------------------------------------------------------------- C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 830315 DATE WRITTEN C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. C 901026 Added explicit declarations for all variables and minor C cosmetic changes to prologue. (FNF) C***END PROLOGUE SDANRM C INTEGER NEQ, IPAR(*) REAL V(NEQ), WT(NEQ), RPAR(*) C INTEGER I REAL SUM, VMAX C C***FIRST EXECUTABLE STATEMENT SDANRM SDANRM = 0.0E0 VMAX = 0.0E0 DO 10 I = 1,NEQ IF(ABS(V(I)/WT(I)) .GT. VMAX) VMAX = ABS(V(I)/WT(I)) 10 CONTINUE IF(VMAX .LE. 0.0E0) GO TO 30 SUM = 0.0E0 DO 20 I = 1,NEQ 20 SUM = SUM + ((V(I)/WT(I))/VMAX)**2 SDANRM = VMAX*SQRT(SUM/NEQ) 30 CONTINUE RETURN C------END OF FUNCTION SDANRM------ END SUBROUTINE SDAINI (X, Y, YPRIME, NEQ, RES, JAC, H, WT, IDID, RPAR, + IPAR, PHI, DELTA, E, WM, IWM, HMIN, UROUND, NONNEG, NTEMP) C***BEGIN PROLOGUE SDAINI C***SUBSIDIARY C***PURPOSE Initialization routine for SDASSL. C***LIBRARY SLATEC (DASSL) C***TYPE SINGLE PRECISION (SDAINI-S, DDAINI-D) C***AUTHOR PETZOLD, LINDA R., (LLNL) C***DESCRIPTION C----------------------------------------------------------------- C SDAINI TAKES ONE STEP OF SIZE H OR SMALLER C WITH THE BACKWARD EULER METHOD, TO C FIND YPRIME. X AND Y ARE UPDATED TO BE CONSISTENT WITH THE C NEW STEP. A MODIFIED DAMPED NEWTON ITERATION IS USED TO C SOLVE THE CORRECTOR ITERATION. C C THE INITIAL GUESS FOR YPRIME IS USED IN THE C PREDICTION, AND IN FORMING THE ITERATION C MATRIX, BUT IS NOT INVOLVED IN THE C ERROR TEST. THIS MAY HAVE TROUBLE C CONVERGING IF THE INITIAL GUESS IS NO C GOOD, OR IF G(X,Y,YPRIME) DEPENDS C NONLINEARLY ON YPRIME. C C THE PARAMETERS REPRESENT: C X -- INDEPENDENT VARIABLE C Y -- SOLUTION VECTOR AT X C YPRIME -- DERIVATIVE OF SOLUTION VECTOR C NEQ -- NUMBER OF EQUATIONS C H -- STEPSIZE. IMDER MAY USE A STEPSIZE C SMALLER THAN H. C WT -- VECTOR OF WEIGHTS FOR ERROR C CRITERION C IDID -- COMPLETION CODE WITH THE FOLLOWING MEANINGS C IDID= 1 -- YPRIME WAS FOUND SUCCESSFULLY C IDID=-12 -- SDAINI FAILED TO FIND YPRIME C RPAR,IPAR -- REAL AND INTEGER PARAMETER ARRAYS C THAT ARE NOT ALTERED BY SDAINI C PHI -- WORK SPACE FOR SDAINI C DELTA,E -- WORK SPACE FOR SDAINI C WM,IWM -- REAL AND INTEGER ARRAYS STORING C MATRIX INFORMATION C C----------------------------------------------------------------- C***ROUTINES CALLED SDAJAC, SDANRM, SDASLV C***REVISION HISTORY (YYMMDD) C 830315 DATE WRITTEN C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. C 901026 Added explicit declarations for all variables and minor C cosmetic changes to prologue. (FNF) C 901030 Minor corrections to declarations. (FNF) C***END PROLOGUE SDAINI C INTEGER NEQ, IDID, IPAR(*), IWM(*), NONNEG, NTEMP REAL X, Y(*), YPRIME(*), H, WT(*), RPAR(*), PHI(NEQ,*), DELTA(*), * E(*), WM(*), HMIN, UROUND EXTERNAL RES, JAC C EXTERNAL SDAJAC, SDANRM, SDASLV REAL SDANRM C INTEGER I, IER, IRES, JCALC, LNJE, LNRE, M, MAXIT, MJAC, NCF, * NEF, NSF REAL CJ, DAMP, DELNRM, ERR, OLDNRM, R, RATE, S, XOLD, YNORM LOGICAL CONVGD C PARAMETER (LNRE=12) PARAMETER (LNJE=13) C DATA MAXIT/10/,MJAC/5/ DATA DAMP/0.75E0/ C C C--------------------------------------------------- C BLOCK 1. C INITIALIZATIONS. C--------------------------------------------------- C C***FIRST EXECUTABLE STATEMENT SDAINI IDID=1 NEF=0 NCF=0 NSF=0 XOLD=X YNORM=SDANRM(NEQ,Y,WT,RPAR,IPAR) C C SAVE Y AND YPRIME IN PHI DO 100 I=1,NEQ PHI(I,1)=Y(I) 100 PHI(I,2)=YPRIME(I) C C C---------------------------------------------------- C BLOCK 2. C DO ONE BACKWARD EULER STEP. C---------------------------------------------------- C C SET UP FOR START OF CORRECTOR ITERATION 200 CJ=1.0E0/H X=X+H C C PREDICT SOLUTION AND DERIVATIVE DO 250 I=1,NEQ 250 Y(I)=Y(I)+H*YPRIME(I) C JCALC=-1 M=0 CONVGD=.TRUE. C C C CORRECTOR LOOP. 300 IWM(LNRE)=IWM(LNRE)+1 IRES=0 C CALL RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR) IF (IRES.LT.0) GO TO 430 C C C EVALUATE THE ITERATION MATRIX IF (JCALC.NE.-1) GO TO 310 IWM(LNJE)=IWM(LNJE)+1 JCALC=0 CALL SDAJAC(NEQ,X,Y,YPRIME,DELTA,CJ,H, * IER,WT,E,WM,IWM,RES,IRES, * UROUND,JAC,RPAR,IPAR,NTEMP) C S=1000000.E0 IF (IRES.LT.0) GO TO 430 IF (IER.NE.0) GO TO 430 NSF=0 C C C C MULTIPLY RESIDUAL BY DAMPING FACTOR 310 CONTINUE DO 320 I=1,NEQ 320 DELTA(I)=DELTA(I)*DAMP C C COMPUTE A NEW ITERATE (BACK SUBSTITUTION) C STORE THE CORRECTION IN DELTA C CALL SDASLV(NEQ,DELTA,WM,IWM) C C UPDATE Y AND YPRIME DO 330 I=1,NEQ Y(I)=Y(I)-DELTA(I) 330 YPRIME(I)=YPRIME(I)-CJ*DELTA(I) C C TEST FOR CONVERGENCE OF THE ITERATION. C DELNRM=SDANRM(NEQ,DELTA,WT,RPAR,IPAR) IF (DELNRM.LE.100.E0*UROUND*YNORM) * GO TO 400 C IF (M.GT.0) GO TO 340 OLDNRM=DELNRM GO TO 350 C 340 RATE=(DELNRM/OLDNRM)**(1.0E0/M) IF (RATE.GT.0.90E0) GO TO 430 S=RATE/(1.0E0-RATE) C 350 IF (S*DELNRM .LE. 0.33E0) GO TO 400 C C C THE CORRECTOR HAS NOT YET CONVERGED. UPDATE C M AND AND TEST WHETHER THE MAXIMUM C NUMBER OF ITERATIONS HAVE BEEN TRIED. C EVERY MJAC ITERATIONS, GET A NEW C ITERATION MATRIX. C M=M+1 IF (M.GE.MAXIT) GO TO 430 C IF ((M/MJAC)*MJAC.EQ.M) JCALC=-1 GO TO 300 C C C THE ITERATION HAS CONVERGED. C CHECK NONNEGATIVITY CONSTRAINTS 400 IF (NONNEG.EQ.0) GO TO 450 DO 410 I=1,NEQ 410 DELTA(I)=MIN(Y(I),0.0E0) C DELNRM=SDANRM(NEQ,DELTA,WT,RPAR,IPAR) IF (DELNRM.GT.0.33E0) GO TO 430 C DO 420 I=1,NEQ Y(I)=Y(I)-DELTA(I) 420 YPRIME(I)=YPRIME(I)-CJ*DELTA(I) GO TO 450 C C C EXITS FROM CORRECTOR LOOP. 430 CONVGD=.FALSE. 450 IF (.NOT.CONVGD) GO TO 600 C C C C----------------------------------------------------- C BLOCK 3. C THE CORRECTOR ITERATION CONVERGED. C DO ERROR TEST. C----------------------------------------------------- C DO 510 I=1,NEQ 510 E(I)=Y(I)-PHI(I,1) ERR=SDANRM(NEQ,E,WT,RPAR,IPAR) C IF (ERR.LE.1.0E0) RETURN C C C C-------------------------------------------------------- C BLOCK 4. C THE BACKWARD EULER STEP FAILED. RESTORE X, Y C AND YPRIME TO THEIR ORIGINAL VALUES. C REDUCE STEPSIZE AND TRY AGAIN, IF C POSSIBLE. C--------------------------------------------------------- C 600 CONTINUE X = XOLD DO 610 I=1,NEQ Y(I)=PHI(I,1) 610 YPRIME(I)=PHI(I,2) C IF (CONVGD) GO TO 640 IF (IER.EQ.0) GO TO 620 NSF=NSF+1 H=H*0.25E0 IF (NSF.LT.3.AND.ABS(H).GE.HMIN) GO TO 690 IDID=-12 RETURN 620 IF (IRES.GT.-2) GO TO 630 IDID=-12 RETURN 630 NCF=NCF+1 H=H*0.25E0 IF (NCF.LT.10.AND.ABS(H).GE.HMIN) GO TO 690 IDID=-12 RETURN C 640 NEF=NEF+1 R=0.90E0/(2.0E0*ERR+0.0001E0) R=MAX(0.1E0,MIN(0.5E0,R)) H=H*R IF (ABS(H).GE.HMIN.AND.NEF.LT.10) GO TO 690 IDID=-12 RETURN 690 GO TO 200 C C-------------END OF SUBROUTINE SDAINI---------------------- END SUBROUTINE SDATRP (X, XOUT, YOUT, YPOUT, NEQ, KOLD, PHI, PSI) C***BEGIN PROLOGUE SDATRP C***SUBSIDIARY C***PURPOSE Interpolation routine for SDASSL. C***LIBRARY SLATEC (DASSL) C***TYPE SINGLE PRECISION (SDATRP-S, DDATRP-D) C***AUTHOR PETZOLD, LINDA R., (LLNL) C***DESCRIPTION C----------------------------------------------------------------------- C THE METHODS IN SUBROUTINE SDASTP USE POLYNOMIALS C TO APPROXIMATE THE SOLUTION. SDATRP APPROXIMATES THE C SOLUTION AND ITS DERIVATIVE AT TIME XOUT BY EVALUATING C ONE OF THESE POLYNOMIALS,AND ITS DERIVATIVE,THERE. C INFORMATION DEFINING THIS POLYNOMIAL IS PASSED FROM C SDASTP, SO SDATRP CANNOT BE USED ALONE. C C THE PARAMETERS ARE: C X THE CURRENT TIME IN THE INTEGRATION. C XOUT THE TIME AT WHICH THE SOLUTION IS DESIRED C YOUT THE INTERPOLATED APPROXIMATION TO Y AT XOUT C (THIS IS OUTPUT) C YPOUT THE INTERPOLATED APPROXIMATION TO YPRIME AT XOUT C (THIS IS OUTPUT) C NEQ NUMBER OF EQUATIONS C KOLD ORDER USED ON LAST SUCCESSFUL STEP C PHI ARRAY OF SCALED DIVIDED DIFFERENCES OF Y C PSI ARRAY OF PAST STEPSIZE HISTORY C----------------------------------------------------------------------- C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 830315 DATE WRITTEN C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. C 901026 Added explicit declarations for all variables and minor C cosmetic changes to prologue. (FNF) C***END PROLOGUE SDATRP C INTEGER NEQ, KOLD REAL X, XOUT, YOUT(*), YPOUT(*), PHI(NEQ,*), PSI(*) C INTEGER I, J, KOLDP1 REAL C, D, GAMMA, TEMP1 C C***FIRST EXECUTABLE STATEMENT SDATRP KOLDP1=KOLD+1 TEMP1=XOUT-X DO 10 I=1,NEQ YOUT(I)=PHI(I,1) 10 YPOUT(I)=0.0E0 C=1.0E0 D=0.0E0 GAMMA=TEMP1/PSI(1) DO 30 J=2,KOLDP1 D=D*GAMMA+C/PSI(J-1) C=C*GAMMA GAMMA=(TEMP1+PSI(J-1))/PSI(J) DO 20 I=1,NEQ YOUT(I)=YOUT(I)+C*PHI(I,J) 20 YPOUT(I)=YPOUT(I)+D*PHI(I,J) 30 CONTINUE RETURN C C------END OF SUBROUTINE SDATRP------ END SUBROUTINE SDASTP (X, Y, YPRIME, NEQ, RES, JAC, H, WT, JSTART, + IDID, RPAR, IPAR, PHI, DELTA, E, WM, IWM, ALPHA, BETA, GAMMA, + PSI, SIGMA, CJ, CJOLD, HOLD, S, HMIN, UROUND, IPHASE, JCALC, + K, KOLD, NS, NONNEG, NTEMP) C***BEGIN PROLOGUE SDASTP C***SUBSIDIARY C***PURPOSE Perform one step of the SDASSL integration. C***LIBRARY SLATEC (DASSL) C***TYPE SINGLE PRECISION (SDASTP-S, DDASTP-D) C***AUTHOR PETZOLD, LINDA R., (LLNL) C***DESCRIPTION C----------------------------------------------------------------------- C SDASTP SOLVES A SYSTEM OF DIFFERENTIAL/ C ALGEBRAIC EQUATIONS OF THE FORM C G(X,Y,YPRIME) = 0, FOR ONE STEP (NORMALLY C FROM X TO X+H). C C THE METHODS USED ARE MODIFIED DIVIDED C DIFFERENCE,FIXED LEADING COEFFICIENT C FORMS OF BACKWARD DIFFERENTIATION C FORMULAS. THE CODE ADJUSTS THE STEPSIZE C AND ORDER TO CONTROL THE LOCAL ERROR PER C STEP. C C C THE PARAMETERS REPRESENT C X -- INDEPENDENT VARIABLE C Y -- SOLUTION VECTOR AT X C YPRIME -- DERIVATIVE OF SOLUTION VECTOR C AFTER SUCCESSFUL STEP C NEQ -- NUMBER OF EQUATIONS TO BE INTEGRATED C RES -- EXTERNAL USER-SUPPLIED SUBROUTINE C TO EVALUATE THE RESIDUAL. THE CALL IS C CALL RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR) C X,Y,YPRIME ARE INPUT. DELTA IS OUTPUT. C ON INPUT, IRES=0. RES SHOULD ALTER IRES ONLY C IF IT ENCOUNTERS AN ILLEGAL VALUE OF Y OR A C STOP CONDITION. SET IRES=-1 IF AN INPUT VALUE C OF Y IS ILLEGAL, AND SDASTP WILL TRY TO SOLVE C THE PROBLEM WITHOUT GETTING IRES = -1. IF C IRES=-2, SDASTP RETURNS CONTROL TO THE CALLING C PROGRAM WITH IDID = -11. C JAC -- EXTERNAL USER-SUPPLIED ROUTINE TO EVALUATE C THE ITERATION MATRIX (THIS IS OPTIONAL) C THE CALL IS OF THE FORM C CALL JAC(X,Y,YPRIME,PD,CJ,RPAR,IPAR) C PD IS THE MATRIX OF PARTIAL DERIVATIVES, C PD=DG/DY+CJ*DG/DYPRIME C H -- APPROPRIATE STEP SIZE FOR NEXT STEP. C NORMALLY DETERMINED BY THE CODE C WT -- VECTOR OF WEIGHTS FOR ERROR CRITERION. C JSTART -- INTEGER VARIABLE SET 0 FOR C FIRST STEP, 1 OTHERWISE. C IDID -- COMPLETION CODE WITH THE FOLLOWING MEANINGS: C IDID= 1 -- THE STEP WAS COMPLETED SUCCESSFULLY C IDID=-6 -- THE ERROR TEST FAILED REPEATEDLY C IDID=-7 -- THE CORRECTOR COULD NOT CONVERGE C IDID=-8 -- THE ITERATION MATRIX IS SINGULAR C IDID=-9 -- THE CORRECTOR COULD NOT CONVERGE. C THERE WERE REPEATED ERROR TEST C FAILURES ON THIS STEP. C IDID=-10-- THE CORRECTOR COULD NOT CONVERGE C BECAUSE IRES WAS EQUAL TO MINUS ONE C IDID=-11-- IRES EQUAL TO -2 WAS ENCOUNTERED, C AND CONTROL IS BEING RETURNED TO C THE CALLING PROGRAM C RPAR,IPAR -- REAL AND INTEGER PARAMETER ARRAYS THAT C ARE USED FOR COMMUNICATION BETWEEN THE C CALLING PROGRAM AND EXTERNAL USER ROUTINES C THEY ARE NOT ALTERED BY SDASTP C PHI -- ARRAY OF DIVIDED DIFFERENCES USED BY C SDASTP. THE LENGTH IS NEQ*(K+1),WHERE C K IS THE MAXIMUM ORDER C DELTA,E -- WORK VECTORS FOR SDASTP OF LENGTH NEQ C WM,IWM -- REAL AND INTEGER ARRAYS STORING C MATRIX INFORMATION SUCH AS THE MATRIX C OF PARTIAL DERIVATIVES,PERMUTATION C VECTOR,AND VARIOUS OTHER INFORMATION. C C THE OTHER PARAMETERS ARE INFORMATION C WHICH IS NEEDED INTERNALLY BY SDASTP TO C CONTINUE FROM STEP TO STEP. C C----------------------------------------------------------------------- C***ROUTINES CALLED SDAJAC, SDANRM, SDASLV, SDATRP C***REVISION HISTORY (YYMMDD) C 830315 DATE WRITTEN C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. C 901026 Added explicit declarations for all variables and minor C cosmetic changes to prologue. (FNF) C***END PROLOGUE SDASTP C INTEGER NEQ, JSTART, IDID, IPAR(*), IWM(*), IPHASE, JCALC, K, * KOLD, NS, NONNEG, NTEMP REAL X, Y(*), YPRIME(*), H, WT(*), RPAR(*), PHI(NEQ,*), DELTA(*), * E(*), WM(*), ALPHA(*), BETA(*), GAMMA(*), PSI(*), SIGMA(*), CJ, * CJOLD, HOLD, S, HMIN, UROUND EXTERNAL RES, JAC C EXTERNAL SDAJAC, SDANRM, SDASLV, SDATRP REAL SDANRM C INTEGER I, IER, IRES, J, J1, KDIFF, KM1, KNEW, KP1, KP2, LCTF, * LETF, LMXORD, LNJE, LNRE, LNST, M, MAXIT, NCF, NEF, NSF, NSP1 REAL ALPHA0, ALPHAS, CJLAST, CK, DELNRM, ENORM, ERK, ERKM1, * ERKM2, ERKP1, ERR, EST, HNEW, OLDNRM, PNORM, R, RATE, TEMP1, * TEMP2, TERK, TERKM1, TERKM2, TERKP1, XOLD, XRATE LOGICAL CONVGD C PARAMETER (LMXORD=3) PARAMETER (LNST=11) PARAMETER (LNRE=12) PARAMETER (LNJE=13) PARAMETER (LETF=14) PARAMETER (LCTF=15) C DATA MAXIT/4/ DATA XRATE/0.25E0/ C C C C C C----------------------------------------------------------------------- C BLOCK 1. C INITIALIZE. ON THE FIRST CALL,SET C THE ORDER TO 1 AND INITIALIZE C OTHER VARIABLES. C----------------------------------------------------------------------- C C INITIALIZATIONS FOR ALL CALLS C***FIRST EXECUTABLE STATEMENT SDASTP IDID=1 XOLD=X NCF=0 NSF=0 NEF=0 IF(JSTART .NE. 0) GO TO 120 C C IF THIS IS THE FIRST STEP,PERFORM C OTHER INITIALIZATIONS IWM(LETF) = 0 IWM(LCTF) = 0 K=1 KOLD=0 HOLD=0.0E0 JSTART=1 PSI(1)=H CJOLD = 1.0E0/H CJ = CJOLD S = 100.E0 JCALC = -1 DELNRM=1.0E0 IPHASE = 0 NS=0 120 CONTINUE C C C C C C----------------------------------------------------------------------- C BLOCK 2 C COMPUTE COEFFICIENTS OF FORMULAS FOR C THIS STEP. C----------------------------------------------------------------------- 200 CONTINUE KP1=K+1 KP2=K+2 KM1=K-1 XOLD=X IF(H.NE.HOLD.OR.K .NE. KOLD) NS = 0 NS=MIN(NS+1,KOLD+2) NSP1=NS+1 IF(KP1 .LT. NS)GO TO 230 C BETA(1)=1.0E0 ALPHA(1)=1.0E0 TEMP1=H GAMMA(1)=0.0E0 SIGMA(1)=1.0E0 DO 210 I=2,KP1 TEMP2=PSI(I-1) PSI(I-1)=TEMP1 BETA(I)=BETA(I-1)*PSI(I-1)/TEMP2 TEMP1=TEMP2+H ALPHA(I)=H/TEMP1 SIGMA(I)=(I-1)*SIGMA(I-1)*ALPHA(I) GAMMA(I)=GAMMA(I-1)+ALPHA(I-1)/H 210 CONTINUE PSI(KP1)=TEMP1 230 CONTINUE C C COMPUTE ALPHAS, ALPHA0 ALPHAS = 0.0E0 ALPHA0 = 0.0E0 DO 240 I = 1,K ALPHAS = ALPHAS - 1.0E0/I ALPHA0 = ALPHA0 - ALPHA(I) 240 CONTINUE C C COMPUTE LEADING COEFFICIENT CJ CJLAST = CJ CJ = -ALPHAS/H C C COMPUTE VARIABLE STEPSIZE ERROR COEFFICIENT CK CK = ABS(ALPHA(KP1) + ALPHAS - ALPHA0) CK = MAX(CK,ALPHA(KP1)) C C DECIDE WHETHER NEW JACOBIAN IS NEEDED TEMP1 = (1.0E0 - XRATE)/(1.0E0 + XRATE) TEMP2 = 1.0E0/TEMP1 IF (CJ/CJOLD .LT. TEMP1 .OR. CJ/CJOLD .GT. TEMP2) JCALC = -1 IF (CJ .NE. CJLAST) S = 100.E0 C C CHANGE PHI TO PHI STAR IF(KP1 .LT. NSP1) GO TO 280 DO 270 J=NSP1,KP1 DO 260 I=1,NEQ 260 PHI(I,J)=BETA(J)*PHI(I,J) 270 CONTINUE 280 CONTINUE C C UPDATE TIME X=X+H C C C C C C----------------------------------------------------------------------- C BLOCK 3 C PREDICT THE SOLUTION AND DERIVATIVE, C AND SOLVE THE CORRECTOR EQUATION C----------------------------------------------------------------------- C C FIRST,PREDICT THE SOLUTION AND DERIVATIVE 300 CONTINUE DO 310 I=1,NEQ Y(I)=PHI(I,1) 310 YPRIME(I)=0.0E0 DO 330 J=2,KP1 DO 320 I=1,NEQ Y(I)=Y(I)+PHI(I,J) 320 YPRIME(I)=YPRIME(I)+GAMMA(J)*PHI(I,J) 330 CONTINUE PNORM = SDANRM (NEQ,Y,WT,RPAR,IPAR) C C C C SOLVE THE CORRECTOR EQUATION USING A C MODIFIED NEWTON SCHEME. CONVGD= .TRUE. M=0 IWM(LNRE)=IWM(LNRE)+1 IRES = 0 CALL RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR) IF (IRES .LT. 0) GO TO 380 C C C IF INDICATED,REEVALUATE THE C ITERATION MATRIX PD = DG/DY + CJ*DG/DYPRIME C (WHERE G(X,Y,YPRIME)=0). SET C JCALC TO 0 AS AN INDICATOR THAT C THIS HAS BEEN DONE. IF(JCALC .NE. -1)GO TO 340 IWM(LNJE)=IWM(LNJE)+1 JCALC=0 CALL SDAJAC(NEQ,X,Y,YPRIME,DELTA,CJ,H, * IER,WT,E,WM,IWM,RES,IRES,UROUND,JAC,RPAR, * IPAR,NTEMP) CJOLD=CJ S = 100.E0 IF (IRES .LT. 0) GO TO 380 IF(IER .NE. 0)GO TO 380 NSF=0 C C C INITIALIZE THE ERROR ACCUMULATION VECTOR E. 340 CONTINUE DO 345 I=1,NEQ 345 E(I)=0.0E0 C C C CORRECTOR LOOP. 350 CONTINUE C C MULTIPLY RESIDUAL BY TEMP1 TO ACCELERATE CONVERGENCE TEMP1 = 2.0E0/(1.0E0 + CJ/CJOLD) DO 355 I = 1,NEQ 355 DELTA(I) = DELTA(I) * TEMP1 C C COMPUTE A NEW ITERATE (BACK-SUBSTITUTION). C STORE THE CORRECTION IN DELTA. CALL SDASLV(NEQ,DELTA,WM,IWM) C C UPDATE Y,E,AND YPRIME DO 360 I=1,NEQ Y(I)=Y(I)-DELTA(I) E(I)=E(I)-DELTA(I) 360 YPRIME(I)=YPRIME(I)-CJ*DELTA(I) C C TEST FOR CONVERGENCE OF THE ITERATION DELNRM=SDANRM(NEQ,DELTA,WT,RPAR,IPAR) IF (DELNRM .LE. 100.E0*UROUND*PNORM) GO TO 375 IF (M .GT. 0) GO TO 365 OLDNRM = DELNRM GO TO 367 365 RATE = (DELNRM/OLDNRM)**(1.0E0/M) IF (RATE .GT. 0.90E0) GO TO 370 S = RATE/(1.0E0 - RATE) 367 IF (S*DELNRM .LE. 0.33E0) GO TO 375 C C THE CORRECTOR HAS NOT YET CONVERGED. C UPDATE M AND TEST WHETHER THE C MAXIMUM NUMBER OF ITERATIONS HAVE C BEEN TRIED. M=M+1 IF(M.GE.MAXIT)GO TO 370 C C EVALUATE THE RESIDUAL C AND GO BACK TO DO ANOTHER ITERATION IWM(LNRE)=IWM(LNRE)+1 IRES = 0 CALL RES(X,Y,YPRIME,DELTA,IRES, * RPAR,IPAR) IF (IRES .LT. 0) GO TO 380 GO TO 350 C C C THE CORRECTOR FAILED TO CONVERGE IN MAXIT C ITERATIONS. IF THE ITERATION MATRIX C IS NOT CURRENT,RE-DO THE STEP WITH C A NEW ITERATION MATRIX. 370 CONTINUE IF(JCALC.EQ.0)GO TO 380 JCALC=-1 GO TO 300 C C C THE ITERATION HAS CONVERGED. IF NONNEGATIVITY OF SOLUTION IS C REQUIRED, SET THE SOLUTION NONNEGATIVE, IF THE PERTURBATION C TO DO IT IS SMALL ENOUGH. IF THE CHANGE IS TOO LARGE, THEN C CONSIDER THE CORRECTOR ITERATION TO HAVE FAILED. 375 IF(NONNEG .EQ. 0) GO TO 390 DO 377 I = 1,NEQ 377 DELTA(I) = MIN(Y(I),0.0E0) DELNRM = SDANRM(NEQ,DELTA,WT,RPAR,IPAR) IF(DELNRM .GT. 0.33E0) GO TO 380 DO 378 I = 1,NEQ 378 E(I) = E(I) - DELTA(I) GO TO 390 C C C EXITS FROM BLOCK 3 C NO CONVERGENCE WITH CURRENT ITERATION C MATRIX,OR SINGULAR ITERATION MATRIX 380 CONVGD= .FALSE. 390 JCALC = 1 IF(.NOT.CONVGD)GO TO 600 C C C C C C----------------------------------------------------------------------- C BLOCK 4 C ESTIMATE THE ERRORS AT ORDERS K,K-1,K-2 C AS IF CONSTANT STEPSIZE WAS USED. ESTIMATE C THE LOCAL ERROR AT ORDER K AND TEST C WHETHER THE CURRENT STEP IS SUCCESSFUL. C----------------------------------------------------------------------- C C ESTIMATE ERRORS AT ORDERS K,K-1,K-2 ENORM = SDANRM(NEQ,E,WT,RPAR,IPAR) ERK = SIGMA(K+1)*ENORM TERK = (K+1)*ERK EST = ERK KNEW=K IF(K .EQ. 1)GO TO 430 DO 405 I = 1,NEQ 405 DELTA(I) = PHI(I,KP1) + E(I) ERKM1=SIGMA(K)*SDANRM(NEQ,DELTA,WT,RPAR,IPAR) TERKM1 = K*ERKM1 IF(K .GT. 2)GO TO 410 IF(TERKM1 .LE. 0.5E0*TERK)GO TO 420 GO TO 430 410 CONTINUE DO 415 I = 1,NEQ 415 DELTA(I) = PHI(I,K) + DELTA(I) ERKM2=SIGMA(K-1)*SDANRM(NEQ,DELTA,WT,RPAR,IPAR) TERKM2 = (K-1)*ERKM2 IF(MAX(TERKM1,TERKM2).GT.TERK)GO TO 430 C LOWER THE ORDER 420 CONTINUE KNEW=K-1 EST = ERKM1 C C C CALCULATE THE LOCAL ERROR FOR THE CURRENT STEP C TO SEE IF THE STEP WAS SUCCESSFUL 430 CONTINUE ERR = CK * ENORM IF(ERR .GT. 1.0E0)GO TO 600 C C C C C C----------------------------------------------------------------------- C BLOCK 5 C THE STEP IS SUCCESSFUL. DETERMINE C THE BEST ORDER AND STEPSIZE FOR C THE NEXT STEP. UPDATE THE DIFFERENCES C FOR THE NEXT STEP. C----------------------------------------------------------------------- IDID=1 IWM(LNST)=IWM(LNST)+1 KDIFF=K-KOLD KOLD=K HOLD=H C C C ESTIMATE THE ERROR AT ORDER K+1 UNLESS: C ALREADY DECIDED TO LOWER ORDER, OR C ALREADY USING MAXIMUM ORDER, OR C STEPSIZE NOT CONSTANT, OR C ORDER RAISED IN PREVIOUS STEP IF(KNEW.EQ.KM1.OR.K.EQ.IWM(LMXORD))IPHASE=1 IF(IPHASE .EQ. 0)GO TO 545 IF(KNEW.EQ.KM1)GO TO 540 IF(K.EQ.IWM(LMXORD)) GO TO 550 IF(KP1.GE.NS.OR.KDIFF.EQ.1)GO TO 550 DO 510 I=1,NEQ 510 DELTA(I)=E(I)-PHI(I,KP2) ERKP1 = (1.0E0/(K+2))*SDANRM(NEQ,DELTA,WT,RPAR,IPAR) TERKP1 = (K+2)*ERKP1 IF(K.GT.1)GO TO 520 IF(TERKP1.GE.0.5E0*TERK)GO TO 550 GO TO 530 520 IF(TERKM1.LE.MIN(TERK,TERKP1))GO TO 540 IF(TERKP1.GE.TERK.OR.K.EQ.IWM(LMXORD))GO TO 550 C C RAISE ORDER 530 K=KP1 EST = ERKP1 GO TO 550 C C LOWER ORDER 540 K=KM1 EST = ERKM1 GO TO 550 C C IF IPHASE = 0, INCREASE ORDER BY ONE AND MULTIPLY STEPSIZE BY C FACTOR TWO 545 K = KP1 HNEW = H*2.0E0 H = HNEW GO TO 575 C C C DETERMINE THE APPROPRIATE STEPSIZE FOR C THE NEXT STEP. 550 HNEW=H TEMP2=K+1 R=(2.0E0*EST+0.0001E0)**(-1.0E0/TEMP2) IF(R .LT. 2.0E0) GO TO 555 HNEW = 2.0E0*H GO TO 560 555 IF(R .GT. 1.0E0) GO TO 560 R = MAX(0.5E0,MIN(0.9E0,R)) HNEW = H*R 560 H=HNEW C C C UPDATE DIFFERENCES FOR NEXT STEP 575 CONTINUE IF(KOLD.EQ.IWM(LMXORD))GO TO 585 DO 580 I=1,NEQ 580 PHI(I,KP2)=E(I) 585 CONTINUE DO 590 I=1,NEQ 590 PHI(I,KP1)=PHI(I,KP1)+E(I) DO 595 J1=2,KP1 J=KP1-J1+1 DO 595 I=1,NEQ 595 PHI(I,J)=PHI(I,J)+PHI(I,J+1) RETURN C C C C C C----------------------------------------------------------------------- C BLOCK 6 C THE STEP IS UNSUCCESSFUL. RESTORE X,PSI,PHI C DETERMINE APPROPRIATE STEPSIZE FOR C CONTINUING THE INTEGRATION, OR EXIT WITH C AN ERROR FLAG IF THERE HAVE BEEN MANY C FAILURES. C----------------------------------------------------------------------- 600 IPHASE = 1 C C RESTORE X,PHI,PSI X=XOLD IF(KP1.LT.NSP1)GO TO 630 DO 620 J=NSP1,KP1 TEMP1=1.0E0/BETA(J) DO 610 I=1,NEQ 610 PHI(I,J)=TEMP1*PHI(I,J) 620 CONTINUE 630 CONTINUE DO 640 I=2,KP1 640 PSI(I-1)=PSI(I)-H C C C TEST WHETHER FAILURE IS DUE TO CORRECTOR ITERATION C OR ERROR TEST IF(CONVGD)GO TO 660 IWM(LCTF)=IWM(LCTF)+1 C C C THE NEWTON ITERATION FAILED TO CONVERGE WITH C A CURRENT ITERATION MATRIX. DETERMINE THE CAUSE C OF THE FAILURE AND TAKE APPROPRIATE ACTION. IF(IER.EQ.0)GO TO 650 C C THE ITERATION MATRIX IS SINGULAR. REDUCE C THE STEPSIZE BY A FACTOR OF 4. IF C THIS HAPPENS THREE TIMES IN A ROW ON C THE SAME STEP, RETURN WITH AN ERROR FLAG NSF=NSF+1 R = 0.25E0 H=H*R IF (NSF .LT. 3 .AND. ABS(H) .GE. HMIN) GO TO 690 IDID=-8 GO TO 675 C C C THE NEWTON ITERATION FAILED TO CONVERGE FOR A REASON C OTHER THAN A SINGULAR ITERATION MATRIX. IF IRES = -2, THEN C RETURN. OTHERWISE, REDUCE THE STEPSIZE AND TRY AGAIN, UNLESS C TOO MANY FAILURES HAVE OCCURED. 650 CONTINUE IF (IRES .GT. -2) GO TO 655 IDID = -11 GO TO 675 655 NCF = NCF + 1 R = 0.25E0 H = H*R IF (NCF .LT. 10 .AND. ABS(H) .GE. HMIN) GO TO 690 IDID = -7 IF (IRES .LT. 0) IDID = -10 IF (NEF .GE. 3) IDID = -9 GO TO 675 C C C THE NEWTON SCHEME CONVERGED,AND THE CAUSE C OF THE FAILURE WAS THE ERROR ESTIMATE C EXCEEDING THE TOLERANCE. 660 NEF=NEF+1 IWM(LETF)=IWM(LETF)+1 IF (NEF .GT. 1) GO TO 665 C C ON FIRST ERROR TEST FAILURE, KEEP CURRENT ORDER OR LOWER C ORDER BY ONE. COMPUTE NEW STEPSIZE BASED ON DIFFERENCES C OF THE SOLUTION. K = KNEW TEMP2 = K + 1 R = 0.90E0*(2.0E0*EST+0.0001E0)**(-1.0E0/TEMP2) R = MAX(0.25E0,MIN(0.9E0,R)) H = H*R IF (ABS(H) .GE. HMIN) GO TO 690 IDID = -6 GO TO 675 C C ON SECOND ERROR TEST FAILURE, USE THE CURRENT ORDER OR C DECREASE ORDER BY ONE. REDUCE THE STEPSIZE BY A FACTOR OF C FOUR. 665 IF (NEF .GT. 2) GO TO 670 K = KNEW H = 0.25E0*H IF (ABS(H) .GE. HMIN) GO TO 690 IDID = -6 GO TO 675 C C ON THIRD AND SUBSEQUENT ERROR TEST FAILURES, SET THE ORDER TO C ONE AND REDUCE THE STEPSIZE BY A FACTOR OF FOUR. 670 K = 1 H = 0.25E0*H IF (ABS(H) .GE. HMIN) GO TO 690 IDID = -6 GO TO 675 C C C C C FOR ALL CRASHES, RESTORE Y TO ITS LAST VALUE, C INTERPOLATE TO FIND YPRIME AT LAST X, AND RETURN 675 CONTINUE CALL SDATRP(X,X,Y,YPRIME,NEQ,K,PHI,PSI) RETURN C C C GO BACK AND TRY THIS STEP AGAIN 690 GO TO 200 C C------END OF SUBROUTINE SDASTP------ END SUBROUTINE SDAJAC (NEQ, X, Y, YPRIME, DELTA, CJ, H, + IER, WT, E, WM, IWM, RES, IRES, UROUND, JAC, RPAR, + IPAR, NTEMP) C***BEGIN PROLOGUE SDAJAC C***SUBSIDIARY C***PURPOSE Compute the iteration matrix for SDASSL and form the C LU-decomposition. C***LIBRARY SLATEC (DASSL) C***TYPE SINGLE PRECISION (SDAJAC-S, DDAJAC-D) C***AUTHOR PETZOLD, LINDA R., (LLNL) C***DESCRIPTION C----------------------------------------------------------------------- C THIS ROUTINE COMPUTES THE ITERATION MATRIX C PD=DG/DY+CJ*DG/DYPRIME (WHERE G(X,Y,YPRIME)=0). C HERE PD IS COMPUTED BY THE USER-SUPPLIED C ROUTINE JAC IF IWM(MTYPE) IS 1 OR 4, AND C IT IS COMPUTED BY NUMERICAL FINITE DIFFERENCING C IF IWM(MTYPE)IS 2 OR 5 C THE PARAMETERS HAVE THE FOLLOWING MEANINGS. C Y = ARRAY CONTAINING PREDICTED VALUES C YPRIME = ARRAY CONTAINING PREDICTED DERIVATIVES C DELTA = RESIDUAL EVALUATED AT (X,Y,YPRIME) C (USED ONLY IF IWM(MTYPE)=2 OR 5) C CJ = SCALAR PARAMETER DEFINING ITERATION MATRIX C H = CURRENT STEPSIZE IN INTEGRATION C IER = VARIABLE WHICH IS .NE. 0 C IF ITERATION MATRIX IS SINGULAR, C AND 0 OTHERWISE. C WT = VECTOR OF WEIGHTS FOR COMPUTING NORMS C E = WORK SPACE (TEMPORARY) OF LENGTH NEQ C WM = REAL WORK SPACE FOR MATRICES. ON C OUTPUT IT CONTAINS THE LU DECOMPOSITION C OF THE ITERATION MATRIX. C IWM = INTEGER WORK SPACE CONTAINING C MATRIX INFORMATION C RES = NAME OF THE EXTERNAL USER-SUPPLIED ROUTINE C TO EVALUATE THE RESIDUAL FUNCTION G(X,Y,YPRIME) C IRES = FLAG WHICH IS EQUAL TO ZERO IF NO ILLEGAL VALUES C IN RES, AND LESS THAN ZERO OTHERWISE. (IF IRES C IS LESS THAN ZERO, THE MATRIX WAS NOT COMPLETED) C IN THIS CASE (IF IRES .LT. 0), THEN IER = 0. C UROUND = THE UNIT ROUNDOFF ERROR OF THE MACHINE BEING USED. C JAC = NAME OF THE EXTERNAL USER-SUPPLIED ROUTINE C TO EVALUATE THE ITERATION MATRIX (THIS ROUTINE C IS ONLY USED IF IWM(MTYPE) IS 1 OR 4) C----------------------------------------------------------------------- C***ROUTINES CALLED SGBFA, SGEFA C***REVISION HISTORY (YYMMDD) C 830315 DATE WRITTEN C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) C 901010 Modified three MAX calls to be all on one line. (FNF) C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. C 901026 Added explicit declarations for all variables and minor C cosmetic changes to prologue. (FNF) C 901101 Corrected PURPOSE. (FNF) C***END PROLOGUE SDAJAC C INTEGER NEQ, IER, IWM(*), IRES, IPAR(*), NTEMP REAL X, Y(*), YPRIME(*), DELTA(*), CJ, H, WT(*), E(*), WM(*), * UROUND, RPAR(*) EXTERNAL RES, JAC C EXTERNAL SGBFA, SGEFA C INTEGER I, I1, I2, II, IPSAVE, ISAVE, J, K, L, LENPD, LIPVT, * LML, LMTYPE, LMU, MBA, MBAND, MEB1, MEBAND, MSAVE, MTYPE, N, * NPD, NPDM1, NROW REAL DEL, DELINV, SQUR, YPSAVE, YSAVE C PARAMETER (NPD=1) PARAMETER (LML=1) PARAMETER (LMU=2) PARAMETER (LMTYPE=4) PARAMETER (LIPVT=21) C C***FIRST EXECUTABLE STATEMENT SDAJAC IER = 0 NPDM1=NPD-1 MTYPE=IWM(LMTYPE) GO TO (100,200,300,400,500),MTYPE C C C DENSE USER-SUPPLIED MATRIX 100 LENPD=NEQ*NEQ DO 110 I=1,LENPD 110 WM(NPDM1+I)=0.0E0 CALL JAC(X,Y,YPRIME,WM(NPD),CJ,RPAR,IPAR) GO TO 230 C C C DENSE FINITE-DIFFERENCE-GENERATED MATRIX 200 IRES=0 NROW=NPDM1 SQUR = SQRT(UROUND) DO 210 I=1,NEQ DEL=SQUR*MAX(ABS(Y(I)),ABS(H*YPRIME(I)),ABS(WT(I))) DEL=SIGN(DEL,H*YPRIME(I)) DEL=(Y(I)+DEL)-Y(I) YSAVE=Y(I) YPSAVE=YPRIME(I) Y(I)=Y(I)+DEL YPRIME(I)=YPRIME(I)+CJ*DEL CALL RES(X,Y,YPRIME,E,IRES,RPAR,IPAR) IF (IRES .LT. 0) RETURN DELINV=1.0E0/DEL DO 220 L=1,NEQ 220 WM(NROW+L)=(E(L)-DELTA(L))*DELINV NROW=NROW+NEQ Y(I)=YSAVE YPRIME(I)=YPSAVE 210 CONTINUE C C C DO DENSE-MATRIX LU DECOMPOSITION ON PD 230 CALL SGEFA(WM(NPD),NEQ,NEQ,IWM(LIPVT),IER) RETURN C C C DUMMY SECTION FOR IWM(MTYPE)=3 300 RETURN C C C BANDED USER-SUPPLIED MATRIX 400 LENPD=(2*IWM(LML)+IWM(LMU)+1)*NEQ DO 410 I=1,LENPD 410 WM(NPDM1+I)=0.0E0 CALL JAC(X,Y,YPRIME,WM(NPD),CJ,RPAR,IPAR) MEBAND=2*IWM(LML)+IWM(LMU)+1 GO TO 550 C C C BANDED FINITE-DIFFERENCE-GENERATED MATRIX 500 MBAND=IWM(LML)+IWM(LMU)+1 MBA=MIN(MBAND,NEQ) MEBAND=MBAND+IWM(LML) MEB1=MEBAND-1 MSAVE=(NEQ/MBAND)+1 ISAVE=NTEMP-1 IPSAVE=ISAVE+MSAVE IRES=0 SQUR=SQRT(UROUND) DO 540 J=1,MBA DO 510 N=J,NEQ,MBAND K= (N-J)/MBAND + 1 WM(ISAVE+K)=Y(N) WM(IPSAVE+K)=YPRIME(N) DEL=SQUR*MAX(ABS(Y(N)),ABS(H*YPRIME(N)),ABS(WT(N))) DEL=SIGN(DEL,H*YPRIME(N)) DEL=(Y(N)+DEL)-Y(N) Y(N)=Y(N)+DEL 510 YPRIME(N)=YPRIME(N)+CJ*DEL CALL RES(X,Y,YPRIME,E,IRES,RPAR,IPAR) IF (IRES .LT. 0) RETURN DO 530 N=J,NEQ,MBAND K= (N-J)/MBAND + 1 Y(N)=WM(ISAVE+K) YPRIME(N)=WM(IPSAVE+K) DEL=SQUR*MAX(ABS(Y(N)),ABS(H*YPRIME(N)),ABS(WT(N))) DEL=SIGN(DEL,H*YPRIME(N)) DEL=(Y(N)+DEL)-Y(N) DELINV=1.0E0/DEL I1=MAX(1,(N-IWM(LMU))) I2=MIN(NEQ,(N+IWM(LML))) II=N*MEB1-IWM(LML)+NPDM1 DO 520 I=I1,I2 520 WM(II+I)=(E(I)-DELTA(I))*DELINV 530 CONTINUE 540 CONTINUE C C C DO LU DECOMPOSITION OF BANDED PD 550 CALL SGBFA(WM(NPD),MEBAND,NEQ, * IWM(LML),IWM(LMU),IWM(LIPVT),IER) RETURN C------END OF SUBROUTINE SDAJAC------ END SUBROUTINE SDASLV (NEQ, DELTA, WM, IWM) C***BEGIN PROLOGUE SDASLV C***SUBSIDIARY C***PURPOSE Linear system solver for SDASSL. C***LIBRARY SLATEC (DASSL) C***TYPE SINGLE PRECISION (SDASLV-S, DDASLV-D) C***AUTHOR PETZOLD, LINDA R., (LLNL) C***DESCRIPTION C----------------------------------------------------------------------- C THIS ROUTINE MANAGES THE SOLUTION OF THE LINEAR C SYSTEM ARISING IN THE NEWTON ITERATION. C MATRICES AND REAL TEMPORARY STORAGE AND C REAL INFORMATION ARE STORED IN THE ARRAY WM. C INTEGER MATRIX INFORMATION IS STORED IN C THE ARRAY IWM. C FOR A DENSE MATRIX, THE LINPACK ROUTINE C SGESL IS CALLED. C FOR A BANDED MATRIX,THE LINPACK ROUTINE C SGBSL IS CALLED. C----------------------------------------------------------------------- C***ROUTINES CALLED SGBSL, SGESL C***REVISION HISTORY (YYMMDD) C 830315 DATE WRITTEN C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. C 901026 Added explicit declarations for all variables and minor C cosmetic changes to prologue. (FNF) C***END PROLOGUE SDASLV C INTEGER NEQ, IWM(*) REAL DELTA(*), WM(*) C EXTERNAL SGBSL, SGESL C INTEGER LIPVT, LML, LMU, LMTYPE, MEBAND, MTYPE, NPD PARAMETER (NPD=1) PARAMETER (LML=1) PARAMETER (LMU=2) PARAMETER (LMTYPE=4) PARAMETER (LIPVT=21) C C***FIRST EXECUTABLE STATEMENT SDASLV MTYPE=IWM(LMTYPE) GO TO(100,100,300,400,400),MTYPE C C DENSE MATRIX 100 CALL SGESL(WM(NPD),NEQ,NEQ,IWM(LIPVT),DELTA,0) RETURN C C DUMMY SECTION FOR MTYPE=3 300 CONTINUE RETURN C C BANDED MATRIX 400 MEBAND=2*IWM(LML)+IWM(LMU)+1 CALL SGBSL(WM(NPD),MEBAND,NEQ,IWM(LML), * IWM(LMU),IWM(LIPVT),DELTA,0) RETURN C------END OF SUBROUTINE SDASLV------ END SUBROUTINE XERMSG (LIBRAR, SUBROU, MESSG, NERR, LEVEL) C***BEGIN PROLOGUE XERMSG C***PURPOSE Processes error messages for SLATEC and other libraries C***LIBRARY SLATEC C***CATEGORY R3C C***TYPE ALL C***KEYWORDS ERROR MESSAGE, XERROR C***AUTHOR FONG, KIRBY, (NMFECC AT LLNL) C Modified by C FRITSCH, F. N., (LLNL) C***DESCRIPTION C C XERMSG processes a diagnostic message in a manner determined by the C value of LEVEL and the current value of the library error control C flag, KONTRL. See subroutine XSETF for details. C (XSETF is inoperable in this version.). C C LIBRAR A character constant (or character variable) with the name C of the library. This will be 'SLATEC' for the SLATEC C Common Math Library. The error handling package is C general enough to be used by many libraries C simultaneously, so it is desirable for the routine that C detects and reports an error to identify the library name C as well as the routine name. C C SUBROU A character constant (or character variable) with the name C of the routine that detected the error. Usually it is the C name of the routine that is calling XERMSG. There are C some instances where a user callable library routine calls C lower level subsidiary routines where the error is C detected. In such cases it may be more informative to C supply the name of the routine the user called rather than C the name of the subsidiary routine that detected the C error. C C MESSG A character constant (or character variable) with the text C of the error or warning message. In the example below, C the message is a character constant that contains a C generic message. C C CALL XERMSG ('SLATEC', 'MMPY', C *'THE ORDER OF THE MATRIX EXCEEDS THE ROW DIMENSION', C *3, 1) C C It is possible (and is sometimes desirable) to generate a C specific message--e.g., one that contains actual numeric C values. Specific numeric values can be converted into C character strings using formatted WRITE statements into C character variables. This is called standard Fortran C internal file I/O and is exemplified in the first three C lines of the following example. You can also catenate C substrings of characters to construct the error message. C Here is an example showing the use of both writing to C an internal file and catenating character strings. C C CHARACTER*5 CHARN, CHARL C WRITE (CHARN,10) N C WRITE (CHARL,10) LDA C 10 FORMAT(I5) C CALL XERMSG ('SLATEC', 'MMPY', 'THE ORDER'//CHARN// C * ' OF THE MATRIX EXCEEDS ITS ROW DIMENSION OF'// C * CHARL, 3, 1) C C There are two subtleties worth mentioning. One is that C the // for character catenation is used to construct the C error message so that no single character constant is C continued to the next line. This avoids confusion as to C whether there are trailing blanks at the end of the line. C The second is that by catenating the parts of the message C as an actual argument rather than encoding the entire C message into one large character variable, we avoid C having to know how long the message will be in order to C declare an adequate length for that large character C variable. XERMSG calls XERPRN to print the message using C multiple lines if necessary. If the message is very long, C XERPRN will break it into pieces of 72 characters (as C requested by XERMSG) for printing on multiple lines. C Also, XERMSG asks XERPRN to prefix each line with ' * ' C so that the total line length could be 76 characters. C Note also that XERPRN scans the error message backwards C to ignore trailing blanks. Another feature is that C the substring '$$' is treated as a new line sentinel C by XERPRN. If you want to construct a multiline C message without having to count out multiples of 72 C characters, just use '$$' as a separator. '$$' C obviously must occur within 72 characters of the C start of each line to have its intended effect since C XERPRN is asked to wrap around at 72 characters in C addition to looking for '$$'. C C NERR An integer value that is chosen by the library routine's C author. It must be in the range -9999999 to 99999999 (8 C printable digits). Each distinct error should have its C own error number. These error numbers should be described C in the machine readable documentation for the routine. C The error numbers need be unique only within each routine, C so it is reasonable for each routine to start enumerating C errors from 1 and proceeding to the next integer. C C LEVEL An integer value in the range 0 to 2 that indicates the C level (severity) of the error. Their meanings are C C -1 A warning message. This is used if it is not clear C that there really is an error, but the user's attention C may be needed. An attempt is made to only print this C message once. C C 0 A warning message. This is used if it is not clear C that there really is an error, but the user's attention C may be needed. C C 1 A recoverable error. This is used even if the error is C so serious that the routine cannot return any useful C answer. If the user has told the error package to C return after recoverable errors, then XERMSG will C return to the Library routine which can then return to C the user's routine. The user may also permit the error C package to terminate the program upon encountering a C recoverable error. C C 2 A fatal error. XERMSG will not return to its caller C after it receives a fatal error. This level should C hardly ever be used; it is much better to allow the C user a chance to recover. An example of one of the few C cases in which it is permissible to declare a level 2 C error is a reverse communication Library routine that C is likely to be called repeatedly until it integrates C across some interval. If there is a serious error in C the input such that another step cannot be taken and C the Library routine is called again without the input C error having been corrected by the caller, the Library C routine will probably be called forever with improper C input. In this case, it is reasonable to declare the C error to be fatal. C C Each of the arguments to XERMSG is input; none will be modified by C XERMSG. A routine may make multiple calls to XERMSG with warning C level messages; however, after a call to XERMSG with a recoverable C error, the routine should return to the user. C C***REFERENCES JONES, RONDALL E. AND KAHANER, DAVID K., "XERROR, THE C SLATEC ERROR-HANDLING PACKAGE", SOFTWARE - PRACTICE C AND EXPERIENCE, VOLUME 13, NO. 3, PP. 251-257, C MARCH, 1983. C***ROUTINES CALLED XERHLT, XERPRN C***REVISION HISTORY (YYMMDD) C 880101 DATE WRITTEN C 880621 REVISED AS DIRECTED AT SLATEC CML MEETING OF FEBRUARY 1988. C THERE ARE TWO BASIC CHANGES. C 1. A NEW ROUTINE, XERPRN, IS USED INSTEAD OF XERPRT TO C PRINT MESSAGES. THIS ROUTINE WILL BREAK LONG MESSAGES C INTO PIECES FOR PRINTING ON MULTIPLE LINES. '$$' IS C ACCEPTED AS A NEW LINE SENTINEL. A PREFIX CAN BE C ADDED TO EACH LINE TO BE PRINTED. XERMSG USES EITHER C ' ***' OR ' * ' AND LONG MESSAGES ARE BROKEN EVERY C 72 CHARACTERS (AT MOST) SO THAT THE MAXIMUM LINE C LENGTH OUTPUT CAN NOW BE AS GREAT AS 76. C 2. THE TEXT OF ALL MESSAGES IS NOW IN UPPER CASE SINCE THE C FORTRAN STANDARD DOCUMENT DOES NOT ADMIT THE EXISTENCE C OF LOWER CASE. C 880708 REVISED AFTER THE SLATEC CML MEETING OF JUNE 29 AND 30. C THE PRINCIPAL CHANGES ARE C 1. CLARIFY COMMENTS IN THE PROLOGUES C 2. RENAME XRPRNT TO XERPRN C 3. REWORK HANDLING OF '$$' IN XERPRN TO HANDLE BLANK LINES C SIMILAR TO THE WAY FORMAT STATEMENTS HANDLE THE / C CHARACTER FOR NEW RECORDS. C 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO C CLEAN UP THE CODING. C 890721 REVISED TO USE NEW FEATURE IN XERPRN TO COUNT CHARACTERS IN C PREFIX. C 891013 REVISED TO CORRECT COMMENTS. C 891214 Prologue converted to Version 4.0 format. (WRB) C 900510 Changed test on NERR to be -9999999 < NERR < 99999999, but C NERR .ne. 0, and on LEVEL to be -2 < LEVEL < 3. Added C LEVEL=-1 logic, changed calls to XERSAV to XERSVE, and C XERCTL to XERCNT. (RWC) C 901011 Removed error saving features to produce a simplified C version for distribution with DASSL and other LLNL codes. C (FNF) C***END PROLOGUE XERMSG CHARACTER*(*) LIBRAR, SUBROU, MESSG CHARACTER*72 TEMP C***FIRST EXECUTABLE STATEMENT XERMSG C C WE PRINT A FATAL ERROR MESSAGE AND TERMINATE FOR AN ERROR IN C CALLING XERMSG. THE ERROR NUMBER SHOULD BE POSITIVE, C AND THE LEVEL SHOULD BE BETWEEN 0 AND 2. C IF (NERR.LT.-9999999 .OR. NERR.GT.99999999 .OR. NERR.EQ.0 .OR. * LEVEL.LT.-1 .OR. LEVEL.GT.2) THEN CALL XERPRN (' ***', -1, 'FATAL ERROR IN...$$ ' // * 'XERMSG -- INVALID ERROR NUMBER OR LEVEL$$ '// * 'JOB ABORT DUE TO FATAL ERROR.', 72) CALL XERHLT (' ***XERMSG -- INVALID INPUT') RETURN ENDIF C C SET DEFAULT VALUES FOR CONTROL PARAMETERS. C LKNTRL = 1 MKNTRL = 1 C C ANNOUNCE THE NAMES OF THE LIBRARY AND SUBROUTINE BY BUILDING A C MESSAGE IN CHARACTER VARIABLE TEMP (NOT EXCEEDING 66 CHARACTERS) C AND SENDING IT OUT VIA XERPRN. PRINT ONLY IF CONTROL FLAG C IS NOT ZERO. C IF (LKNTRL .NE. 0) THEN TEMP(1:21) = 'MESSAGE FROM ROUTINE ' I = MIN(LEN(SUBROU), 16) TEMP(22:21+I) = SUBROU(1:I) TEMP(22+I:33+I) = ' IN LIBRARY ' LTEMP = 33 + I I = MIN(LEN(LIBRAR), 16) TEMP(LTEMP+1:LTEMP+I) = LIBRAR (1:I) TEMP(LTEMP+I+1:LTEMP+I+1) = '.' LTEMP = LTEMP + I + 1 CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72) ENDIF C C IF LKNTRL IS POSITIVE, PRINT AN INTRODUCTORY LINE BEFORE C PRINTING THE MESSAGE. THE INTRODUCTORY LINE TELLS THE CHOICE C FROM EACH OF THE FOLLOWING TWO OPTIONS. C 1. LEVEL OF THE MESSAGE C 'INFORMATIVE MESSAGE' C 'POTENTIALLY RECOVERABLE ERROR' C 'FATAL ERROR' C 2. WHETHER CONTROL FLAG WILL ALLOW PROGRAM TO CONTINUE C 'PROGRAM CONTINUES' C 'PROGRAM ABORTED' C NOTICE THAT THE LINE INCLUDING FOUR PREFIX CHARACTERS WILL NOT C EXCEED 74 CHARACTERS. C WE SKIP THE NEXT BLOCK IF THE INTRODUCTORY LINE IS NOT NEEDED. C IF (LKNTRL .GT. 0) THEN C C THE FIRST PART OF THE MESSAGE TELLS ABOUT THE LEVEL. C IF (LEVEL .LE. 0) THEN TEMP(1:20) = 'INFORMATIVE MESSAGE,' LTEMP = 20 ELSEIF (LEVEL .EQ. 1) THEN TEMP(1:30) = 'POTENTIALLY RECOVERABLE ERROR,' LTEMP = 30 ELSE TEMP(1:12) = 'FATAL ERROR,' LTEMP = 12 ENDIF C C THEN WHETHER THE PROGRAM WILL CONTINUE. C IF ((MKNTRL.EQ.2 .AND. LEVEL.GE.1) .OR. * (MKNTRL.EQ.1 .AND. LEVEL.EQ.2)) THEN TEMP(LTEMP+1:LTEMP+17) = ' PROGRAM ABORTED.' LTEMP = LTEMP + 17 ELSE TEMP(LTEMP+1:LTEMP+19) = ' PROGRAM CONTINUES.' LTEMP = LTEMP + 19 ENDIF C CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72) ENDIF C C NOW SEND OUT THE MESSAGE. C CALL XERPRN (' * ', -1, MESSG, 72) C C IF LKNTRL IS POSITIVE, WRITE THE ERROR NUMBER. C IF (LKNTRL .GT. 0) THEN WRITE (TEMP, '(''ERROR NUMBER = '', I8)') NERR DO 10 I=16,22 IF (TEMP(I:I) .NE. ' ') GO TO 20 10 CONTINUE C 20 CALL XERPRN (' * ', -1, TEMP(1:15) // TEMP(I:23), 72) ENDIF C C IF LKNTRL IS NOT ZERO, PRINT A BLANK LINE AND AN END OF MESSAGE. C IF (LKNTRL .NE. 0) THEN CALL XERPRN (' * ', -1, ' ', 72) CALL XERPRN (' ***', -1, 'END OF MESSAGE', 72) CALL XERPRN (' ', 0, ' ', 72) ENDIF C C IF THE ERROR IS NOT FATAL OR THE ERROR IS RECOVERABLE AND THE C CONTROL FLAG IS SET FOR RECOVERY, THEN RETURN. C 30 IF (LEVEL.LE.0 .OR. (LEVEL.EQ.1 .AND. MKNTRL.LE.1)) RETURN C C THE PROGRAM WILL BE STOPPED DUE TO AN UNRECOVERED ERROR OR A C FATAL ERROR. PRINT THE REASON FOR THE ABORT AND THE ERROR C SUMMARY IF THE CONTROL FLAG AND THE MAXIMUM ERROR COUNT PERMIT. C IF (LKNTRL.GT.0) THEN IF (LEVEL .EQ. 1) THEN CALL XERPRN * (' ***', -1, 'JOB ABORT DUE TO UNRECOVERED ERROR.', 72) ELSE CALL XERPRN(' ***', -1, 'JOB ABORT DUE TO FATAL ERROR.', 72) ENDIF CALL XERHLT (' ') ENDIF RETURN END SUBROUTINE XERHLT (MESSG) C***BEGIN PROLOGUE XERHLT C***SUBSIDIARY C***PURPOSE Abort program execution and print error message. C***LIBRARY SLATEC (XERROR) C***CATEGORY R3C C***TYPE ALL (XERHLT-A) C***KEYWORDS ERROR, XERROR C***AUTHOR JONES, R. E., (SNLA) C***DESCRIPTION C C Abstract C ***Note*** machine dependent routine C XERHLT aborts the execution of the program. C The error message causing the abort is given in the calling C sequence, in case one needs it for printing on a dayfile, C for example. C C Description of Parameters C MESSG is as in XERROR. C C***REFERENCES JONES R.E., KAHANER D.K., 'XERROR, THE SLATEC ERROR- C HANDLING PACKAGE', SAND82-0800, SANDIA LABORATORIES, C 1982. C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 790801 DATE WRITTEN as XERABT C 861211 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900206 Routine changed from user-callable to subsidiary. (WRB) C 900510 Changed calling sequence to delete length of char string C Changed subroutine name from XERABT to XERHLT. (RWC) C***END PROLOGUE XERHLT CHARACTER*(*) MESSG C***FIRST EXECUTABLE STATEMENT XERHLT STOP END C*DECK XERPRN SUBROUTINE XERPRN (PREFIX, NPREF, MESSG, NWRAP) C***BEGIN PROLOGUE XERPRN C***SUBSIDIARY C***PURPOSE This routine is called by XERMSG to print error messages C***LIBRARY SLATEC C***CATEGORY R3C C***TYPE ALL C***KEYWORDS ERROR MESSAGES, PRINTING, XERROR C***AUTHOR FONG, KIRBY, (NMFECC AT LLNL) C***DESCRIPTION C C This routine sends one or more lines to each of the (up to five) C logical units to which error messages are to be sent. This routine C is called several times by XERMSG, sometimes with a single line to C print and sometimes with a (potentially very long) message that may C wrap around into multiple lines. C C PREFIX Input argument of type CHARACTER. This argument contains C characters to be put at the beginning of each line before C the body of the message. No more than 16 characters of C PREFIX will be used. C C NPREF Input argument of type INTEGER. This argument is the number C of characters to use from PREFIX. If it is negative, the C intrinsic function LEN is used to determine its length. If C it is zero, PREFIX is not used. If it exceeds 16 or if C LEN(PREFIX) exceeds 16, only the first 16 characters will be C used. If NPREF is positive and the length of PREFIX is less C than NPREF, a copy of PREFIX extended with blanks to length C NPREF will be used. C C MESSG Input argument of type CHARACTER. This is the text of a C message to be printed. If it is a long message, it will be C broken into pieces for printing on multiple lines. Each line C will start with the appropriate prefix and be followed by a C piece of the message. NWRAP is the number of characters per C piece; that is, after each NWRAP characters, we break and C start a new line. In addition the characters '$$' embedded C in MESSG are a sentinel for a new line. The counting of C characters up to NWRAP starts over for each new line. The C value of NWRAP typically used by XERMSG is 72 since many C older error messages in the SLATEC Library are laid out to C rely on wrap-around every 72 characters. C C NWRAP Input argument of type INTEGER. This gives the maximum size C piece into which to break MESSG for printing on multiple C lines. An embedded '$$' ends a line, and the count restarts C at the following character. If a line break does not occur C on a blank (it would split a word) that word is moved to the C next line. Values of NWRAP less than 16 will be treated as C 16. Values of NWRAP greater than 132 will be treated as 132. C The actual line length will be NPREF + NWRAP after NPREF has C been adjusted to fall between 0 and 16 and NWRAP has been C adjusted to fall between 16 and 132. C C***REFERENCES (NONE) C***ROUTINES CALLED I1MACH, XGETUA C***REVISION HISTORY (YYMMDD) C 880621 DATE WRITTEN C 880708 REVISED AFTER THE SLATEC CML SUBCOMMITTEE MEETING OF C JUNE 29 AND 30 TO CHANGE THE NAME TO XERPRN AND TO REWORK C THE HANDLING OF THE NEW LINE SENTINEL TO BEHAVE LIKE THE C SLASH CHARACTER IN FORMAT STATEMENTS. C 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMMENS TO C STREAMLINE THE CODING AND FIX A BUG THAT CAUSED EXTRA BLANK C LINES TO BE PRINTED. C 890721 REVISED TO ADD A NEW FEATURE. A NEGATIVE VALUE OF NPREF C CAUSES LEN(PREFIX) TO BE USED AS THE LENGTH. C 891013 REVISED TO CORRECT ERROR IN CALCULATING PREFIX LENGTH. C 891214 Prologue converted to Version 4.0 format. (WRB) C 900510 Added code to break messages between words. (RWC) C***END PROLOGUE XERPRN CHARACTER*(*) PREFIX, MESSG INTEGER NPREF, NWRAP CHARACTER*148 CBUFF INTEGER IU(5), NUNIT CHARACTER*2 NEWLIN PARAMETER (NEWLIN = '$$') C***FIRST EXECUTABLE STATEMENT XERPRN CALL XGETUA(IU,NUNIT) C C A ZERO VALUE FOR A LOGICAL UNIT NUMBER MEANS TO USE THE STANDARD C ERROR MESSAGE UNIT INSTEAD. I1MACH(4) RETRIEVES THE STANDARD C ERROR MESSAGE UNIT. C N = I1MACH(4) DO 10 I=1,NUNIT IF (IU(I) .EQ. 0) IU(I) = N 10 CONTINUE C C LPREF IS THE LENGTH OF THE PREFIX. THE PREFIX IS PLACED AT THE C BEGINNING OF CBUFF, THE CHARACTER BUFFER, AND KEPT THERE DURING C THE REST OF THIS ROUTINE. C IF ( NPREF .LT. 0 ) THEN LPREF = LEN(PREFIX) ELSE LPREF = NPREF ENDIF LPREF = MIN(16, LPREF) IF (LPREF .NE. 0) CBUFF(1:LPREF) = PREFIX C C LWRAP IS THE MAXIMUM NUMBER OF CHARACTERS WE WANT TO TAKE AT ONE C TIME FROM MESSG TO PRINT ON ONE LINE. C LWRAP = MAX(16, MIN(132, NWRAP)) C C SET LENMSG TO THE LENGTH OF MESSG, IGNORE ANY TRAILING BLANKS. C LENMSG = LEN(MESSG) N = LENMSG DO 20 I=1,N IF (MESSG(LENMSG:LENMSG) .NE. ' ') GO TO 30 LENMSG = LENMSG - 1 20 CONTINUE 30 CONTINUE C C IF THE MESSAGE IS ALL BLANKS, THEN PRINT ONE BLANK LINE. C IF (LENMSG .EQ. 0) THEN CBUFF(LPREF+1:LPREF+1) = ' ' DO 40 I=1,NUNIT WRITE(IU(I), '(A)') CBUFF(1:LPREF+1) 40 CONTINUE RETURN ENDIF C C SET NEXTC TO THE POSITION IN MESSG WHERE THE NEXT SUBSTRING C STARTS. FROM THIS POSITION WE SCAN FOR THE NEW LINE SENTINEL. C WHEN NEXTC EXCEEDS LENMSG, THERE IS NO MORE TO PRINT. C WE LOOP BACK TO LABEL 50 UNTIL ALL PIECES HAVE BEEN PRINTED. C C WE LOOK FOR THE NEXT OCCURRENCE OF THE NEW LINE SENTINEL. THE C INDEX INTRINSIC FUNCTION RETURNS ZERO IF THERE IS NO OCCURRENCE C OR IF THE LENGTH OF THE FIRST ARGUMENT IS LESS THAN THE LENGTH C OF THE SECOND ARGUMENT. C C THERE ARE SEVERAL CASES WHICH SHOULD BE CHECKED FOR IN THE C FOLLOWING ORDER. WE ARE ATTEMPTING TO SET LPIECE TO THE NUMBER C OF CHARACTERS THAT SHOULD BE TAKEN FROM MESSG STARTING AT C POSITION NEXTC. C C LPIECE .EQ. 0 THE NEW LINE SENTINEL DOES NOT OCCUR IN THE C REMAINDER OF THE CHARACTER STRING. LPIECE C SHOULD BE SET TO LWRAP OR LENMSG+1-NEXTC, C WHICHEVER IS LESS. C C LPIECE .EQ. 1 THE NEW LINE SENTINEL STARTS AT MESSG(NEXTC: C NEXTC). LPIECE IS EFFECTIVELY ZERO, AND WE C PRINT NOTHING TO AVOID PRODUCING UNNECESSARY C BLANK LINES. THIS TAKES CARE OF THE SITUATION C WHERE THE LIBRARY ROUTINE HAS A MESSAGE OF C EXACTLY 72 CHARACTERS FOLLOWED BY A NEW LINE C SENTINEL FOLLOWED BY MORE CHARACTERS. NEXTC C SHOULD BE INCREMENTED BY 2. C C LPIECE .GT. LWRAP+1 REDUCE LPIECE TO LWRAP. C C ELSE THIS LAST CASE MEANS 2 .LE. LPIECE .LE. LWRAP+1 C RESET LPIECE = LPIECE-1. NOTE THAT THIS C PROPERLY HANDLES THE END CASE WHERE LPIECE .EQ. C LWRAP+1. THAT IS, THE SENTINEL FALLS EXACTLY C AT THE END OF A LINE. C NEXTC = 1 50 LPIECE = INDEX(MESSG(NEXTC:LENMSG), NEWLIN) IF (LPIECE .EQ. 0) THEN C C THERE WAS NO NEW LINE SENTINEL FOUND. C IDELTA = 0 LPIECE = MIN(LWRAP, LENMSG+1-NEXTC) IF (LPIECE .LT. LENMSG+1-NEXTC) THEN DO 52 I=LPIECE+1,2,-1 IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN LPIECE = I-1 IDELTA = 1 GOTO 54 ENDIF 52 CONTINUE ENDIF 54 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) NEXTC = NEXTC + LPIECE + IDELTA ELSEIF (LPIECE .EQ. 1) THEN C C WE HAVE A NEW LINE SENTINEL AT MESSG(NEXTC:NEXTC+1). C DON'T PRINT A BLANK LINE. C NEXTC = NEXTC + 2 GO TO 50 ELSEIF (LPIECE .GT. LWRAP+1) THEN C C LPIECE SHOULD BE SET DOWN TO LWRAP. C IDELTA = 0 LPIECE = LWRAP DO 56 I=LPIECE+1,2,-1 IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN LPIECE = I-1 IDELTA = 1 GOTO 58 ENDIF 56 CONTINUE 58 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) NEXTC = NEXTC + LPIECE + IDELTA ELSE C C IF WE ARRIVE HERE, IT MEANS 2 .LE. LPIECE .LE. LWRAP+1. C WE SHOULD DECREMENT LPIECE BY ONE. C LPIECE = LPIECE - 1 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) NEXTC = NEXTC + LPIECE + 2 ENDIF C C PRINT C DO 60 I=1,NUNIT WRITE(IU(I), '(A)') CBUFF(1:LPREF+LPIECE) 60 CONTINUE C IF (NEXTC .LE. LENMSG) GO TO 50 RETURN END C*DECK XGETUA SUBROUTINE XGETUA (IUNITA, N) C***BEGIN PROLOGUE XGETUA C***PURPOSE Return unit number(s) to which error messages are being C sent. C***LIBRARY SLATEC (XERROR) C***CATEGORY R3C C***TYPE ALL (XGETUA-A) C***KEYWORDS ERROR, XERROR C***AUTHOR JONES, R. E., (SNLA) C Modified by C FRITSCH, F. N., (LLNL) C***DESCRIPTION C C Abstract C XGETUA may be called to determine the unit number or numbers C to which error messages are being sent. C These unit numbers may have been set by a call to XSETUN, C or a call to XSETUA, or may be a default value. C C Description of Parameters C --Output-- C IUNIT - an array of one to five unit numbers, depending C on the value of N. A value of zero refers to the C default unit, as defined by the I1MACH machine C constant routine. Only IUNIT(1),...,IUNIT(N) are C defined by XGETUA. The values of IUNIT(N+1),..., C IUNIT(5) are not defined (for N .LT. 5) or altered C in any way by XGETUA. C N - the number of units to which copies of the C error messages are being sent. N will be in the C range from 1 to 5. C C CAUTION: The use of COMMON in this version is not safe for C multiprocessing. C C***REFERENCES JONES R.E., KAHANER D.K., 'XERROR, THE SLATEC ERROR- C HANDLING PACKAGE', SAND82-0800, SANDIA LABORATORIES, C 1982. C***ROUTINES CALLED (NONE) C***COMMON BLOCKS XERUNI C***REVISION HISTORY (YYMMDD) C 790801 DATE WRITTEN C 861211 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 901011 Rewritten to not use J4SAVE. (FNF) C 901012 Corrected initialization problem. (FNF) C***END PROLOGUE XGETUA DIMENSION IUNITA(5) INTEGER NUNIT, IUNIT(5) COMMON /XERUNI/ NUNIT, IUNIT C***FIRST EXECUTABLE STATEMENT XGETUA C Initialize so XERMSG will use standard error unit number if C block has not been set up by a CALL XSETUA. C CAUTION: This assumes uninitialized COMMON tests .LE.0 . IF (NUNIT.LE.0) THEN NUNIT = 1 IUNIT(1) = 0 ENDIF N = NUNIT DO 30 I=1,N IUNITA(I) = IUNIT(I) 30 CONTINUE RETURN END C*DECK XSETUA SUBROUTINE XSETUA (IUNITA, N) C***BEGIN PROLOGUE XSETUA C***PURPOSE Set logical unit numbers (up to 5) to which error C messages are to be sent. C***LIBRARY SLATEC (XERROR) C***CATEGORY R3B C***TYPE ALL (XSETUA-A) C***KEYWORDS ERROR, XERROR C***AUTHOR JONES, R. E., (SNLA) C Modified by C FRITSCH, F. N., (LLNL) C***DESCRIPTION C C Abstract C XSETUA may be called to declare a list of up to five C logical units, each of which is to receive a copy of C each error message processed by this package. C The purpose of XSETUA is to allow simultaneous printing C of each error message on, say, a main output file, C an interactive terminal, and other files such as graphics C communication files. C C Description of Parameters C --Input-- C IUNIT - an array of up to five unit numbers. C Normally these numbers should all be different C (but duplicates are not prohibited.) C N - the number of unit numbers provided in IUNIT C must have 1 .LE. N .LE. 5. C C CAUTION: The use of COMMON in this version is not safe for C multiprocessing. C C***REFERENCES JONES R.E., KAHANER D.K., 'XERROR, THE SLATEC ERROR- C HANDLING PACKAGE', SAND82-0800, SANDIA LABORATORIES, C 1982. C***ROUTINES CALLED XERMSG C***COMMON BLOCKS XERUNI C***REVISION HISTORY (YYMMDD) C 790801 DATE WRITTEN C 861211 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900510 Change call to XERRWV to XERMSG. (RWC) C 901011 Rewritten to not use J4SAVE. (FNF) C***END PROLOGUE XSETUA DIMENSION IUNITA(5) INTEGER NUNIT, IUNIT(5) COMMON /XERUNI/ NUNIT, IUNIT CHARACTER *8 XERN1 C***FIRST EXECUTABLE STATEMENT XSETUA C IF (N.LT.1 .OR. N.GT.5) THEN WRITE (XERN1, '(I8)') N CALL XERMSG ('SLATEC', 'XSETUA', * 'INVALID NUMBER OF UNITS, N = ' // XERN1, 1, 2) RETURN ENDIF C DO 10 I=1,N IUNIT(I) = IUNITA(I) 10 CONTINUE NUNIT = N RETURN END C C####################################################################### C C DASUSE : contains the routine C I1MACH to get the standard error message unit (6). C (also available from Netlib: send i1mach from core) C R1MACH to determine machine precision, uses value determined C by MACHAR C (also available from Netlib: send r1mach from core) C and the dummies for the routines SGEFA and SGESL from LINPACK C (available from Netlib: send sgefa/sgesl from linpack) C C####################################################################### C INTEGER FUNCTION I1MACH(IDUM) INTEGER IDUM C C I/O UNIT NUMBERS. C C I1MACH( 4) = THE STANDARD ERROR MESSAGE UNIT. I1MACH = 6 RETURN C----------------------- END OF FUNCTION I1MACH ------------------------ END REAL FUNCTION R1MACH (IDUM) INTEGER IDUM C----------------------------------------------------------------------- C This routine returns the unit roundoff of the machine in single C precision as computed by MACHAR and stored in SRELPR in the routine C SETSKM. C----------------------------------------------------------------------- INTEGER NERR REAL SRELPR COMMON /MACH/ NERR, SRELPR R1MACH = SRELPR RETURN C----------------------- END OF FUNCTION R1MACH ------------------------ END SUBROUTINE SGEFA RETURN END SUBROUTINE SGESL RETURN END C C####################################################################### C C DASLIP : LINPACK routines needed by DASSL C (available from Netlib: send sgbfa/sgbsl from linpack) C C####################################################################### C subroutine sgbfa(abd,lda,n,ml,mu,ipvt,info) integer lda,n,ml,mu,ipvt(1),info real abd(lda,1) c c sgbfa factors a real band matrix by elimination. c c sgbfa is usually called by sgbco, but it can be called c directly with a saving in time if rcond is not needed. c c on entry c c abd real(lda, n) c contains the matrix in band storage. the columns c of the matrix are stored in the columns of abd and c the diagonals of the matrix are stored in rows c ml+1 through 2*ml+mu+1 of abd . c see the comments below for details. c c lda integer c the leading dimension of the array abd . c lda must be .ge. 2*ml + mu + 1 . c c n integer c the order of the original matrix. c c ml integer c number of diagonals below the main diagonal. c 0 .le. ml .lt. n . c c mu integer c number of diagonals above the main diagonal. c 0 .le. mu .lt. n . c more efficient if ml .le. mu . c on return c c abd an upper triangular matrix in band storage and c the multipliers which were used to obtain it. c the factorization can be written a = l*u where c l is a product of permutation and unit lower c triangular matrices and u is upper triangular. c c ipvt integer(n) c an integer vector of pivot indices. c c info integer c = 0 normal value. c = k if u(k,k) .eq. 0.0 . this is not an error c condition for this subroutine, but it does c indicate that sgbsl will divide by zero if c called. use rcond in sgbco for a reliable c indication of singularity. c c band storage c c if a is a band matrix, the following program segment c will set up the input. c c ml = (band width below the diagonal) c mu = (band width above the diagonal) c m = ml + mu + 1 c do 20 j = 1, n c i1 = max0(1, j-mu) c i2 = min0(n, j+ml) c do 10 i = i1, i2 c k = i - j + m c abd(k,j) = a(i,j) c 10 continue c 20 continue c c this uses rows ml+1 through 2*ml+mu+1 of abd . c in addition, the first ml rows in abd are used for c elements generated during the triangularization. c the total number of rows needed in abd is 2*ml+mu+1 . c the ml+mu by ml+mu upper left triangle and the c ml by ml lower right triangle are not referenced. c c linpack. this version dated 08/14/78 . c cleve moler, university of new mexico, argonne national lab. c c subroutines and functions c c blas saxpy,sscal,isamax c fortran max0,min0 c c internal variables c real t integer i,isamax,i0,j,ju,jz,j0,j1,k,kp1,l,lm,m,mm,nm1 c c m = ml + mu + 1 info = 0 c c zero initial fill-in columns c j0 = mu + 2 j1 = min0(n,m) - 1 if (j1 .lt. j0) go to 30 do 20 jz = j0, j1 i0 = m + 1 - jz do 10 i = i0, ml abd(i,jz) = 0.0e0 10 continue 20 continue 30 continue jz = j1 ju = 0 c c gaussian elimination with partial pivoting c nm1 = n - 1 if (nm1 .lt. 1) go to 130 do 120 k = 1, nm1 kp1 = k + 1 c c zero next fill-in column c jz = jz + 1 if (jz .gt. n) go to 50 if (ml .lt. 1) go to 50 do 40 i = 1, ml abd(i,jz) = 0.0e0 40 continue 50 continue c c find l = pivot index c lm = min0(ml,n-k) l = isamax(lm+1,abd(m,k),1) + m - 1 ipvt(k) = l + k - m c c zero pivot implies this column already triangularized c if (abd(l,k) .eq. 0.0e0) go to 100 c c interchange if necessary c if (l .eq. m) go to 60 t = abd(l,k) abd(l,k) = abd(m,k) abd(m,k) = t 60 continue c c compute multipliers c t = -1.0e0/abd(m,k) call sscal(lm,t,abd(m+1,k),1) c c row elimination with column indexing c ju = min0(max0(ju,mu+ipvt(k)),n) mm = m if (ju .lt. kp1) go to 90 do 80 j = kp1, ju l = l - 1 mm = mm - 1 t = abd(l,j) if (l .eq. mm) go to 70 abd(l,j) = abd(mm,j) abd(mm,j) = t 70 continue call saxpy(lm,t,abd(m+1,k),1,abd(mm+1,j),1) 80 continue 90 continue go to 110 100 continue info = k 110 continue 120 continue 130 continue ipvt(n) = n if (abd(m,n) .eq. 0.0e0) info = n return end subroutine sscal(n,sa,sx,incx) c c scales a vector by a constant. c uses unrolled loops for increment equal to 1. c jack dongarra, linpack, 3/11/78. c modified to correct problem with negative increments, 9/29/88. c real sa,sx(1) integer i,ix,incx,m,mp1,n c if(n.le.0)return if(incx.eq.1)go to 20 c c code for increment not equal to 1 c ix = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 do 10 i = 1,n sx(ix) = sa*sx(ix) ix = ix + incx 10 continue return c c code for increment equal to 1 c c c clean-up loop c 20 m = mod(n,5) if( m .eq. 0 ) go to 40 do 30 i = 1,m sx(i) = sa*sx(i) 30 continue if( n .lt. 5 ) return 40 mp1 = m + 1 do 50 i = mp1,n,5 sx(i) = sa*sx(i) sx(i + 1) = sa*sx(i + 1) sx(i + 2) = sa*sx(i + 2) sx(i + 3) = sa*sx(i + 3) sx(i + 4) = sa*sx(i + 4) 50 continue return end subroutine saxpy(n,sa,sx,incx,sy,incy) c c constant times a vector plus a vector. c uses unrolled loop for increments equal to one. c jack dongarra, linpack, 3/11/78. c real sx(1),sy(1),sa integer i,incx,incy,ix,iy,m,mp1,n c if(n.le.0)return if (sa .eq. 0.0) return if(incx.eq.1.and.incy.eq.1)go to 20 c c code for unequal increments or equal increments c not equal to 1 c ix = 1 iy = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 if(incy.lt.0)iy = (-n+1)*incy + 1 do 10 i = 1,n sy(iy) = sy(iy) + sa*sx(ix) ix = ix + incx iy = iy + incy 10 continue return c c code for both increments equal to 1 c c c clean-up loop c 20 m = mod(n,4) if( m .eq. 0 ) go to 40 do 30 i = 1,m sy(i) = sy(i) + sa*sx(i) 30 continue if( n .lt. 4 ) return 40 mp1 = m + 1 do 50 i = mp1,n,4 sy(i) = sy(i) + sa*sx(i) sy(i + 1) = sy(i + 1) + sa*sx(i + 1) sy(i + 2) = sy(i + 2) + sa*sx(i + 2) sy(i + 3) = sy(i + 3) + sa*sx(i + 3) 50 continue return end subroutine sgbsl(abd,lda,n,ml,mu,ipvt,b,job) integer lda,n,ml,mu,ipvt(1),job real abd(lda,1),b(1) c c sgbsl solves the real band system c a * x = b or trans(a) * x = b c using the factors computed by sgbco or sgbfa. c c on entry c c abd real(lda, n) c the output from sgbco or sgbfa. c c lda integer c the leading dimension of the array abd . c c n integer c the order of the original matrix. c c ml integer c number of diagonals below the main diagonal. c c mu integer c number of diagonals above the main diagonal. c c ipvt integer(n) c the pivot vector from sgbco or sgbfa. c c b real(n) c the right hand side vector. c c job integer c = 0 to solve a*x = b , c = nonzero to solve trans(a)*x = b , where c trans(a) is the transpose. c c on return c c b the solution vector x . c c error condition c c a division by zero will occur if the input factor contains a c zero on the diagonal. technically this indicates singularity c but it is often caused by improper arguments or improper c setting of lda . it will not occur if the subroutines are c called correctly and if sgbco has set rcond .gt. 0.0 c or sgbfa has set info .eq. 0 . c c to compute inverse(a) * c where c is a matrix c with p columns c call sgbco(abd,lda,n,ml,mu,ipvt,rcond,z) c if (rcond is too small) go to ... c do 10 j = 1, p c call sgbsl(abd,lda,n,ml,mu,ipvt,c(1,j),0) c 10 continue c c linpack. this version dated 08/14/78 . c cleve moler, university of new mexico, argonne national lab. c c subroutines and functions c c blas saxpy,sdot c fortran min0 c c internal variables c real sdot,t integer k,kb,l,la,lb,lm,m,nm1 c m = mu + ml + 1 nm1 = n - 1 if (job .ne. 0) go to 50 c c job = 0 , solve a * x = b c first solve l*y = b c if (ml .eq. 0) go to 30 if (nm1 .lt. 1) go to 30 do 20 k = 1, nm1 lm = min0(ml,n-k) l = ipvt(k) t = b(l) if (l .eq. k) go to 10 b(l) = b(k) b(k) = t 10 continue call saxpy(lm,t,abd(m+1,k),1,b(k+1),1) 20 continue 30 continue c c now solve u*x = y c do 40 kb = 1, n k = n + 1 - kb b(k) = b(k)/abd(m,k) lm = min0(k,m) - 1 la = m - lm lb = k - lm t = -b(k) call saxpy(lm,t,abd(la,k),1,b(lb),1) 40 continue go to 100 50 continue c c job = nonzero, solve trans(a) * x = b c first solve trans(u)*y = b c do 60 k = 1, n lm = min0(k,m) - 1 la = m - lm lb = k - lm t = sdot(lm,abd(la,k),1,b(lb),1) b(k) = (b(k) - t)/abd(m,k) 60 continue c c now solve trans(l)*x = y c if (ml .eq. 0) go to 90 if (nm1 .lt. 1) go to 90 do 80 kb = 1, nm1 k = n - kb lm = min0(ml,n-k) b(k) = b(k) + sdot(lm,abd(m+1,k),1,b(k+1),1) l = ipvt(k) if (l .eq. k) go to 70 t = b(l) b(l) = b(k) b(k) = t 70 continue 80 continue 90 continue 100 continue return end real function sdot(n,sx,incx,sy,incy) c c forms the dot product of two vectors. c uses unrolled loops for increments equal to one. c jack dongarra, linpack, 3/11/78. c real sx(1),sy(1),stemp integer i,incx,incy,ix,iy,m,mp1,n c stemp = 0.0e0 sdot = 0.0e0 if(n.le.0)return if(incx.eq.1.and.incy.eq.1)go to 20 c c code for unequal increments or equal increments c not equal to 1 c ix = 1 iy = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 if(incy.lt.0)iy = (-n+1)*incy + 1 do 10 i = 1,n stemp = stemp + sx(ix)*sy(iy) ix = ix + incx iy = iy + incy 10 continue sdot = stemp return c c code for both increments equal to 1 c c c clean-up loop c 20 m = mod(n,5) if( m .eq. 0 ) go to 40 do 30 i = 1,m stemp = stemp + sx(i)*sy(i) 30 continue if( n .lt. 5 ) go to 60 40 mp1 = m + 1 do 50 i = mp1,n,5 stemp = stemp + sx(i)*sy(i) + sx(i + 1)*sy(i + 1) + * sx(i + 2)*sy(i + 2) + sx(i + 3)*sy(i + 3) + sx(i + 4)*sy(i + 4) 50 continue 60 sdot = stemp return end integer function isamax(n,sx,incx) c c finds the index of element having max. absolute value. c jack dongarra, linpack, 3/11/78. c modified to correct problem with negative increments, 9/29/88. c real sx(1),smax integer i,incx,ix,n c isamax = 0 if( n .lt. 1 ) return isamax = 1 if(n.eq.1)return if(incx.eq.1)go to 20 c c code for increment not equal to 1 c ix = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 smax = abs(sx(ix)) ix = ix + incx do 10 i = 2,n if(abs(sx(ix)).le.smax) go to 5 isamax = i smax = abs(sx(ix)) 5 ix = ix + incx 10 continue return c c code for increment equal to 1 c 20 smax = abs(sx(1)) do 30 i = 2,n if(abs(sx(i)).le.smax) go to 30 isamax = i smax = abs(sx(i)) 30 continue return end C*********************************************************************** C C Double Precision files C C*********************************************************************** C C Contains, separated by a C######## line, the following files: C ------------------------------------------------------------ C PRBBAK : problem dependent routines for first example problem C PRBCYL : problem dependent routines for second example problem C PRBDSH : problem dependent routines for third example problem C (Burgers' equation) C DRIVER : test program to use the moving-grid interface in a DASSL C environment C SPMDIF : moving-grid interface routines C MACHAR : MACHAR routine from W.J. Cody C (available from Netlib: send machar from elefunt) C DDASSL : DASSL DAE integrator from L.R. Petzold C (available from Netlib: send ddassl from ode) C NB. DASSL needs the following files: C DASUSE : contains the routine C I1MACH to get the standard error message unit (6). C (also available from Netlib: send i1mach from core) C D1MACH to determine machine precision, uses value determined C by MACHAR C (also available from Netlib: send d1mach from core) C and the dummies for the routines DGEFA and DGESL from LINPACK C (available from Netlib: send dgefa/dgesl from linpack) C DASLIP : LINPACK routines needed by DASSL C (available from Netlib: send dgbfa/dgbsl from linpack) C C C Of the next three problem dependent files only one should be loaded C C####################################################################### C C PRBBAK : problem dependent routines for first example problem C C####################################################################### C SUBROUTINE INIPRB (TEXT) CHARACTER TEXT*80 C C Initialize /PROBLM/ C INTEGER NPDE, NPRINT LOGICAL ANAJAC, SOLAV DOUBLE PRECISION XL, XR, T0, TE DOUBLE PRECISION DUMPRO(5), TPRINT(10) COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO, + ANAJAC, SOLAV, TPRINT, NPRINT C INTEGER M DOUBLE PRECISION EPS, P, ETA DATA EPS /0.143/, ETA /17.19/, P /0.1743/ C NPDE = 2 M = 0 XL = 0.0 XR = 1.0 T0 = 0.0 TE = 4.0 ANAJAC = .FALSE. SOLAV = .FALSE. NPRINT = 10 TPRINT(1) = 1.0E-4 TPRINT(2) = 1.0E-3 TPRINT(3) = 1.0E-2 TPRINT(4) = 0.1 TPRINT(5) = 0.25 TPRINT(6) = 0.5 TPRINT(7) = 1.0 TPRINT(8) = 2.0 TPRINT(9) = 3.0 TPRINT(10) = 4.0 TEXT = ' Bakker, Electrodynamics problem' WRITE(TEXT(33:80),'(6H; EPS=,F5.3,4H, P=,F6.4,6H, ETA=,F5.2)') + EPS, P, ETA DUMPRO(1) = M DUMPRO(2) = EPS DUMPRO(3) = P DUMPRO(4) = ETA RETURN END SUBROUTINE UINIT (NPDE, NPTS, Y) C C Routine for PDE initial values. C Entry: C Y(NPDE+1,i) = x_i; uniform mesh, generated by package C Exit: C Y(NPDE+1,i) = x_i; mesh, optionally changed by user C Y( k,i) = u_k(x_i,t0); initial value of k-th component C i = 1,.., NPTS C INTEGER NPDE, NPTS DOUBLE PRECISION Y(NPDE+1,NPTS) INTEGER I DO 10 I = 1, NPTS Y(1,I) = 1.0 Y(2,I) = 0.0 10 CONTINUE RETURN END SUBROUTINE SPDEF (T, X, NPDE, U, DUDX, C, Q, R, IRES) C C Routine to describe the body of the PDE system. C The PDE is written as C NPDE k -m m C sum C (x,t,u,u ) u + Q (x,t,u,u ) = x (x R (x,t,u,u ) ) C k=1 jk x t j x j x x C the functions C, Q and R must be defined in this routine. C INTEGER NPDE, IRES DOUBLE PRECISION T, X DOUBLE PRECISION U(NPDE), DUDX(NPDE), C(NPDE,NPDE), Q(NPDE), + R(NPDE) INTEGER J, K DOUBLE PRECISION EPS, ETA, GZ, P, Z DATA EPS /0.143/, ETA /17.19/, P /0.1743/ DO 10 K = 1, NPDE DO 20 J = 1, NPDE C(J,K) = 0.0 20 CONTINUE C(K,K) = 1.0 10 CONTINUE Z = U(1) - U(2) GZ = EXP(ETA*Z/3) - EXP(-2*ETA*Z/3) Q(1) = GZ Q(2) = -GZ R(1) = EPS*P * DUDX(1) R(2) = P * DUDX(2) RETURN END SUBROUTINE BNDR (T, BETA, GAMMA, U, DUDX, NPDE, LEFT, IRES) C C Boundary conditions routine C The boundary conditions are written as C BETA (x,t) R (x,t,u,u ) = GAMMA (x,t,u,u ) C j j x j x C The functions BETA and GAMMA should be defined in this routine. C INTEGER NPDE, IRES LOGICAL LEFT DOUBLE PRECISION T DOUBLE PRECISION BETA(NPDE), GAMMA(NPDE), U(NPDE), DUDX(NPDE) IF (LEFT) THEN BETA (1) = 1.0 GAMMA(1) = 0.0 BETA (2) = 0.0 GAMMA(2) = U(2) ELSE BETA (1) = 0.0 GAMMA(1) = U(1) - 1.0 BETA (2) = 1.0 GAMMA(2) = 0.0 ENDIF RETURN END SUBROUTINE UEXACT (X, T, U) DOUBLE PRECISION X, T DOUBLE PRECISION U(*) C RETURN END C C####################################################################### C C PRBCYL : problem dependent routines for second example problem C C####################################################################### C SUBROUTINE INIPRB (TEXT) CHARACTER TEXT*80 C C Initialize /PROBLM/ C INTEGER NPDE, NPRINT LOGICAL ANAJAC, SOLAV DOUBLE PRECISION XL, XR, T0, TE DOUBLE PRECISION DUMPRO(5), TPRINT(10) COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO, + ANAJAC, SOLAV, TPRINT, NPRINT C INTEGER I, M DOUBLE PRECISION ALPHA, BETA, GAMMA, EPS C NPDE = 1 M = 1 XL = 0.0 XR = 1.0 T0 = 0.0 TE = 1.0 ANAJAC = .FALSE. SOLAV = .FALSE. NPRINT = 10 DO 10 I = 1, NPRINT TPRINT(I) = 0.1*I 10 CONTINUE ALPHA = 1.0 BETA = 0.0001 GAMMA = 1.0 EPS = 0.1 TEXT = ' Reaction-diffusion prob. in cyl. coord.; pars:' WRITE(TEXT(48:80),'(4F8.5)') ALPHA, BETA, GAMMA, EPS DUMPRO(1) = M DUMPRO(2) = ALPHA DUMPRO(3) = BETA DUMPRO(4) = GAMMA DUMPRO(5) = EPS RETURN END SUBROUTINE UINIT (NPD, NPTS, Y) C C Routine for PDE initial values. C Entry: C Y(NPDE+1,i) = x_i; uniform mesh, generated by package C Exit: C Y(NPDE+1,i) = x_i; mesh, optionally changed by user C Y( k,i) = u_k(x_i,t0); initial value of k-th component C i = 1,.., NPTS C INTEGER NPD, NPTS DOUBLE PRECISION Y(NPDE+1,NPTS) C INTEGER NPDE, NPRINT LOGICAL ANAJAC, SOLAV DOUBLE PRECISION XL, XR, T0, TE DOUBLE PRECISION DUMPRO(5), TPRINT(10) COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO, + ANAJAC, SOLAV, TPRINT, NPRINT C INTEGER I DO 10 I = 1, NPTS Y(1,I) = 0.0 10 CONTINUE RETURN END SUBROUTINE SPDEF (T,X, NPD, U, DUDX, C, Q, R, IRES) C C Routine to describe the body of the PDE system. C The PDE is written as C NPDE k -m m C sum C (x,t,u,u ) u + Q (x,t,u,u ) = x (x R (x,t,u,u ) ) C k=1 jk x t j x j x x C the functions C, Q and R must be defined in this routine. C INTEGER NPD, IRES DOUBLE PRECISION T, X DOUBLE PRECISION U(NPDE), DUDX(NPDE), C(NPDE,NPDE), Q(NPDE), + R(NPDE) C INTEGER NPDE, NPRINT LOGICAL ANAJAC, SOLAV DOUBLE PRECISION XL, XR, T0, TE DOUBLE PRECISION DUMPRO(5), TPRINT(10) COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO, + ANAJAC, SOLAV, TPRINT, NPRINT DOUBLE PRECISION ALPHA, BETA, GAMMA, EPS C ALPHA = DUMPRO(2) BETA = DUMPRO(3) GAMMA = DUMPRO(4) EPS = DUMPRO(5) C(1,1) = ALPHA Q(1) = -GAMMA*EXP(U(1)/(1+EPS*U(1))) R(1) = BETA*DUDX(1) RETURN END SUBROUTINE BNDR (T, BETA, GAMMA, U, DUDX, NPD, LEFT, IRES) C C Boundary conditions routine C The boundary conditions are written as C BETA (x,t) R (x,t,u,u ) = GAMMA (x,t,u,u ) C j j x j x C The functions BETA and GAMMA should be defined in this routine. C INTEGER NPD, IRES LOGICAL LEFT DOUBLE PRECISION T DOUBLE PRECISION BETA(NPDE), GAMMA(NPDE), U(NPDE), DUDX(NPDE) C INTEGER NPDE, NPRINT LOGICAL ANAJAC, SOLAV DOUBLE PRECISION XL, XR, T0, TE DOUBLE PRECISION DUMPRO(5), TPRINT(10) COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO, + ANAJAC, SOLAV, TPRINT, NPRINT C IF (LEFT) THEN BETA(1) = 1.0 GAMMA(1) = 0.0 ELSE BETA(1) = 0.0 GAMMA(1) = U(1) - 0.0 ENDIF RETURN END SUBROUTINE UEXACT (X, T, U) C C Exact solution C DOUBLE PRECISION X, T DOUBLE PRECISION U(*) RETURN END C C####################################################################### C C PRBDSH : problem dependent routines for third example problem C (Burgers' equation) C C####################################################################### C SUBROUTINE INIPRB (TEXT) CHARACTER TEXT*80 C C ---------------------------------------------------------------------- C C Burgers' equation C u_t = -u.u_x + eps.u_xx, 0 < x < 1, t > 0 C Dirichlet boundary conditions C Exact solution available (see SUBROUTINE UEXACT) C C ---------------------------------------------------------------------- C C Initialize /PROBLM/ C INTEGER NPDE, NPRINT LOGICAL ANAJAC, SOLAV DOUBLE PRECISION XL, XR, T0, TE DOUBLE PRECISION DUMPRO(5), TPRINT(10) COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO, + ANAJAC, SOLAV, TPRINT, NPRINT C INTEGER M DOUBLE PRECISION EPS C NPDE = 1 M = 0 XL = 0.0 XR = 1.0 T0 = 0.0 TE = 1.0 ANAJAC = .FALSE. SOLAV = .TRUE. NPRINT = 3 TPRINT(1) = 0.25 TPRINT(2) = 0.55 TPRINT(3) = 1.0 EPS = 1E-3 TEXT = ' Burgers, double wave, eps=' WRITE(TEXT(28:80),'(F7.5)') EPS DUMPRO(1) = M DUMPRO(2) = EPS RETURN END SUBROUTINE UINIT (NPD, NPTS, Y) C C Routine for PDE initial values. C Entry: C Y(NPDE+1,i) = x_i; uniform mesh, generated by package C Exit: C Y(NPDE+1,i) = x_i; mesh, optionally changed by user C Y( k,i) = u_k(x_i,t0); initial value of k-th component C i = 1,.., NPTS C INTEGER NPD, NPTS DOUBLE PRECISION Y(NPDE+1,NPTS) C INTEGER NPDE, NPRINT LOGICAL ANAJAC, SOLAV DOUBLE PRECISION XL, XR, T0, TE DOUBLE PRECISION DUMPRO(5), TPRINT(10) COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO, + ANAJAC, SOLAV, TPRINT, NPRINT INTEGER I C DO 10 I = 1, NPTS CALL UEXACT (Y(NPDE+1,I), T0, Y(1,I)) 10 CONTINUE RETURN END SUBROUTINE SPDEF (T,X, NPD, U, DUDX, C, Q, R, IRES) C C Routine to describe the body of the PDE system. C The PDE is written as C NPDE k -m m C sum C (x,t,u,u ) u + Q (x,t,u,u ) = x (x R (x,t,u,u ) ) C k=1 jk x t j x j x x C the functions C, Q and R must be defined in this routine. C INTEGER NPD, IRES DOUBLE PRECISION T, X DOUBLE PRECISION U(NPDE), DUDX(NPDE), C(NPDE,NPDE), Q(NPDE), + R(NPDE) C INTEGER NPDE, NPRINT LOGICAL ANAJAC, SOLAV DOUBLE PRECISION XL, XR, T0, TE DOUBLE PRECISION DUMPRO(5), TPRINT(10) COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO, + ANAJAC, SOLAV, TPRINT, NPRINT DOUBLE PRECISION EPS EPS = DUMPRO(2) C(1,1) = 1.0 Q(1) = U(1)*DUDX(1) R(1) = EPS*DUDX(1) RETURN END SUBROUTINE BNDR (T, BETA, GAMMA, U, UX, NPD, LEFT, IRES) C C Boundary conditions routine C The boundary conditions are written as C BETA (x,t) R (x,t,u,u ) = GAMMA (x,t,u,u ) C j j x j x C The functions BETA and GAMMA should be defined in this routine. C INTEGER NPD, IRES LOGICAL LEFT DOUBLE PRECISION T DOUBLE PRECISION BETA(NPDE), GAMMA(NPDE), U(NPDE), UX(NPDE) C INTEGER NPDE, NPRINT LOGICAL ANAJAC, SOLAV DOUBLE PRECISION XL, XR, T0, TE DOUBLE PRECISION DUMPRO(5), TPRINT(10) COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO, + ANAJAC, SOLAV, TPRINT, NPRINT C DOUBLE PRECISION X IF (LEFT) THEN X = XL ELSE X = XR ENDIF CALL UEXACT (X, T, GAMMA) BETA(1) = 0.0 GAMMA(1) = U(1) - GAMMA(1) RETURN END SUBROUTINE UEXACT (X, T, U) C C Exact solution C DOUBLE PRECISION X, T DOUBLE PRECISION U(NPDE) C INTEGER NPDE, NPRINT LOGICAL ANAJAC, SOLAV DOUBLE PRECISION XL, XR, T0, TE DOUBLE PRECISION DUMPRO(5), TPRINT(10) COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO, + ANAJAC, SOLAV, TPRINT, NPRINT C DOUBLE PRECISION EPS, R1, R2, R3, R123 EPS = DUMPRO(2) R1 = EXP(-(X-0.5)/(20*EPS)-99*T/(400*EPS)) R2 = EXP(-(X-0.5)/(4*EPS)-3*T/(16*EPS)) R3 = EXP(-(X-0.375)/(2*EPS)) R123 = R1+R2+R3 U(1) = 1.0 - (0.9*R1 + 0.5*R2) / R123 RETURN END C C####################################################################### C C DRIVER : test program to use the moving-grid interface in a DASSL C environment C C####################################################################### C PROGRAM DRIVER C C ---------------------------------------------------------------------- C C Main program MoL adaptive grid interface for DASSL C Calls problem initializer, C Initializes DASSL parameters + grid/solution C Put semi-discrete PDE system + Dorfi&Drury grid equation in DASSL C Write grid and solution at specific steps (TPRINT) to outputfile C C Problem choice by loading the specific problem file with the modules: C C SUBROUTINE INIPRB (TEXT) C CHARACTER TEXT*80 C Initialize /PROBLM/ C C SUBROUTINE UINIT (NPDE, NPTS, Y) C INTEGER NPDE, NPTS C DOUBLE PRECISION Y(NPDE+1,NPTS) C Initial solution; optionnally redefinition of (uniform) grid C C SUBROUTINE SPDEF (T,X,NPDE, U, DUDX, C, Q, R, IRES) C INTEGER NPDE, IRES C DOUBLE PRECISION T, X C DOUBLE PRECISION U(NPDE), DUDX(NPDE), C(NPDE,NPDE), Q(NPDE), C + R(NPDE) C PDE defining functions C, Q, R C C SUBROUTINE BNDR (T, BETA, GAMMA, U, UX, NPDE, LEFT, IRES) C INTEGER NPDE, IRES C LOGICAL LEFT C DOUBLE PRECISION T C DOUBLE PRECISION BETA(NPDE), GAMMA(NPDE), U(NPDE), UX(NPDE) C Boundary function C C SUBROUTINE UEXACT (X, T, U) C DOUBLE PRECISION X, T C DOUBLE PRECISION U(NPDE) C Exact solution (only called if SOLAV=TRUE) C INTEGER MXNPDE, MXNEQ, MXLIW, MXLRW, MXNRWK PARAMETER (MXNPDE = 2, MXNEQ = 303) PARAMETER (MXLIW = 20+MXNEQ, MXLRW = (6*MXNPDE+20)*MXNEQ) PARAMETER (MXNRWK = MXNEQ+(6+MXNPDE)*MXNPDE) INTEGER INFO(15), IWORK(MXLIW), IPAR(1) DOUBLE PRECISION Y(MXNEQ), YPRIME(MXNEQ), RTOL(1), ATOL(1), + RWORK(MXLRW), RWK(MXNRWK) C C Y : Grid and solution values C YPRIME: Derivative of Y C INFO : Task_communication with DASSL C RTOL : Relative tolerance for DASSL C ATOL : Absolute tolerance for DASSL C RWORK : (Optional) DOUBLE PRECISION input values for DASSL C IWORK : (Optional) INTEGER input values for DASSL C RWK : Workspace SKMRES C C COMMONs used: C INTEGER NPTS, LUNR, LUNI COMMON /MOLIF/ NPTS, LUNR, LUNI C C NPTS : # grid points (needed in residual routine) C LUNR : log. unit # output file for results C LUNI : log. unit # run information file C INTEGER NPDE, NPRINT LOGICAL ANAJAC, SOLAV DOUBLE PRECISION XL, XR, T0, TE DOUBLE PRECISION DUMPRO(5), TPRINT(10) COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO, + ANAJAC, SOLAV, TPRINT, NPRINT C C NPDE # partial differential equations C XL Left boundary C XR Right boundary C T0 Starting time C TE Final time C DUMPRO Storage reserved for problem parameters C DUMPRO(1) = M (space coordinate type) C ANAJAC TRUE, if user specified Jacobian C (SUBROUTINE JAC, see documentation of DAE solver) C SOLAV TRUE, if exact solution is available C (SUBROUTINE UEXACT) C TPRINT NPRINT output times C NPRINT DIMENSION TPRINT C EXTERNAL INIPRB, OUT, RESID, RUNOUT, SETSKM, DDASSL C C --------------------------------------------------------------------- C CHARACTER IDENT*30, TEXT*80 INTEGER I, IBAND, IDID, IPRINT, IRES, LIW, LRW, M, MAXORD, NCTF, + NEQ, NETF, NFCN, NOINV, NRWK, NSTEPS DOUBLE PRECISION ALPHA, KAPPA, T, TAU, TOUT C C ccc Open files for results and run info LUNR = 4 LUNI = 8 OPEN (UNIT=LUNR, FILE='RESULT') OPEN (UNIT=LUNI, FILE='RUNINF') C C Run identification IDENT = 'ACM-TOMS, Ex.I' C C ccc Initialize /PROBLM/ CALL INIPRB (TEXT) C TEXT: Problem information WRITE(LUNR,'(A80)') TEXT WRITE(LUNI,'(A80)') TEXT C C ccc Initialize method parameters, grid, solution and derivative at T0 C DASSL input C C Method parameters; for Burgers equation (PRBDSH file) TAU = 1E-3 NPTS = 21 M = NINT(DUMPRO(1)) TAU = 0.0 KAPPA = 2.0 ALPHA = 0.01 NRWK = MXNRWK C C Call initialization routine SETSKM; determine initial grid; C store initial values of U in Y CALL SETSKM (NEQ, NPDE, NPTS, XL,XR, TAU, KAPPA, ALPHA, + Y, RWK, NRWK, M, T0, IBAND, IRES) IF (IRES .EQ. -1) THEN STOP 'Error in SETSKM' ENDIF C C Initial Yprime = 0 DO 1 I = 1, NEQ YPRIME(I) = 0.0 1 CONTINUE C C Initialize DASSL input DO 5 I = 1, 15 INFO(I) = 0 5 CONTINUE C Both tolerances are scalars (default) ATOL(1) = 1E-3 RTOL(1) = 1E-3 C Intermediate output mode INFO( 3) = 1 C Analytical Jacobian IF (ANAJAC) INFO(5) = 1 C Banded Jacobian INFO( 6) = 1 IWORK(1) = IBAND IWORK(2) = IBAND C Default maximum integration order MAXORD = 5 C Y, YPRIME probably inconsistent at T0 INFO(11) = 1 C C ccc Check length arrays IF (NEQ .GT. MXNEQ) THEN PRINT *, 'MXNEQ too small, needed:', NEQ STOP 'Workspace too small' ENDIF LIW = 20+NEQ IF (LIW .GT. MXLIW) THEN PRINT *, 'MXLIW too small, needed:', LIW STOP 'Workspace too small' ENDIF LRW = 40+(MAXORD+6+3*IBAND+1)*NEQ + 2*(NEQ/(2*IBAND+1)+1) IF (LRW .GT. MXLRW) THEN PRINT *, 'MXLRW too small, needed:', LRW STOP 'Workspace too small' ENDIF C C ccc Write run header to files TEXT = ' MoL, PDE+D&D int.face; DAE int.: DASSL' I = 40 TEXT(I:80) = '; ID:' WRITE(TEXT(I+6:80),'(A30)') IDENT WRITE(LUNR,'(A80)') TEXT WRITE(LUNI,'(A80)') TEXT I = 1 TEXT(I:80) = ' NPTS=' WRITE(TEXT(I+6:I+8),'(I3)') NPTS I = I+9 TEXT(I:I+6) = '; RTOL=' WRITE(TEXT(I+7:I+14),'(E8.3)') RTOL(1) I = I+15 TEXT(I:I+6) = ', ATOL=' WRITE(TEXT(I+7:I+14),'(E8.3)') ATOL(1) WRITE(LUNR,'(A80)') TEXT WRITE(LUNI,'(A80)') TEXT I = 1 TEXT(I:80) = ' TAU=' WRITE(TEXT(I+5:I+12),'(E8.3)') TAU I = I+13 TEXT(I:I+7) = ', KAPPA=' WRITE(TEXT(I+8:I+15),'(E8.3)') KAPPA I = I+16 TEXT(I:I+7) = ', ALPHA=' WRITE(TEXT(I+8:I+15),'(E8.3)') ALPHA WRITE(LUNR,'(A80)') TEXT WRITE(LUNI,'(A80)') TEXT C C C ccc Write initial grid and solution to output file CALL OUT (T0, Y, RWK(1), RWK(NRWK-NPTS+1)) C C C C ccc DASSL loop C Call DASSL with as residual routine RESID, the enveloping routine C of SKMRES T = T0 DO 10 IPRINT = 1, NPRINT TOUT = TPRINT(IPRINT) 15 CALL DDASSL (RESID, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL, + IDID, RWORK, LRW, IWORK, LIW, RWK, IPAR, JAC) IF (IDID .EQ. 1) THEN C One step in intermediate-output mode C C Write Run info to file CALL RUNOUT(RWORK, IWORK) C GOTO 15 ENDIF C C Write grid and solution to output file CALL OUT(T, Y, RWK(1), RWK(NRWK-NPTS+1)) C C Give run statistics until t = TOUT NSTEPS = IWORK(11) NFCN = IWORK(12) NOINV = IWORK(13) C NOSOLV = NFCN NETF = IWORK(14) NCTF = IWORK(15) WRITE(LUNR,*) 'Statistics:' WRITE(LUNR,*) ' FNS, JACS:', NFCN, NOINV WRITE(LUNR,*) ' STEPS, ETF, CTF:', NSTEPS, NETF, NCTF IF (IDID .LT. 0) GOTO 900 10 CONTINUE CLOSE(LUNR) CLOSE(LUNI) STOP 'Ready' C C ccc Error return 900 CONTINUE WRITE(LUNR,*) 'IDID=', IDID STOP 'DASSL error' END SUBROUTINE RESID (T, Y, YPRIME, DELTA, IRES, RWK, IPAR) INTEGER IRES INTEGER IPAR(*) DOUBLE PRECISION T DOUBLE PRECISION Y(*), YPRIME(*), DELTA(*), RWK(*) C C Determine DAE system for DASSL C residual DELTA = A.YPRIME - G C C Entry: C T : Current time C Y : Current grid + solution C YPRIME: Time derivative of Y C Exit: C DELTA : A.YPRIME - G C IRES : -1, if user thinks solution is illegal or ico node crossing C C --------------------------------------------------------------------- C INTEGER NPDE, NPRINT LOGICAL ANAJAC, SOLAV DOUBLE PRECISION XL, XR, T0, TE DOUBLE PRECISION DUMPRO(5), TPRINT(10) COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO, + ANAJAC, SOLAV, TPRINT, NPRINT C INTEGER NPTS, LUNR, LUNI COMMON /MOLIF/ NPTS, LUNR, LUNI C SAVE /PROBLM/, /MOLIF/ C C EXTERNAL SKMRES C C --------------------------------------------------------------------- C INTEGER NEQ, NRWK C NEQ = NPTS*(NPDE+1) NRWK = NEQ + (6+NPDE)*NPDE C C ccc Call SKMRES with IRES=0 to compute total residual CALL SKMRES (NEQ, T, Y, YPRIME, DELTA, IRES, RWK, NRWK) IF (IRES .EQ. 2) THEN IRES = -2 RETURN ELSE IF (IRES .EQ. 3) THEN WRITE(LUNI,999) T 999 FORMAT(' Illegal solution at T= ', E12.4) IRES = -1 RETURN ENDIF C RETURN END SUBROUTINE OUT (T, Y, UEX, ERR) DOUBLE PRECISION T DOUBLE PRECISION Y(NPDE+1,NPTS), UEX(NPDE,NPTS), ERR(NPTS) C C Write grid, solution and, if possible, error in sol. to output file C C Entry: C T : Current time C Y : Current grid + solution C UEX : Workspace to store exact solution C UERR : Workspace to store error for a component in each gridpoint C C --------------------------------------------------------------------- C INTEGER NPDE, NPRINT LOGICAL ANAJAC, SOLAV DOUBLE PRECISION XL, XR, T0, TE DOUBLE PRECISION DUMPRO(5), TPRINT(10) COMMON /PROBLM/ NPDE, XL, XR, T0, TE, DUMPRO, + ANAJAC, SOLAV, TPRINT, NPRINT C INTEGER NPTS, LUNR, LUNI COMMON /MOLIF/ NPTS, LUNR, LUNI C SAVE /PROBLM/, /MOLIF/ C DOUBLE PRECISION INFNRM, L2NRM EXTERNAL INFNRM, L2NRM, UEXACT C C ---------------------------------------------------------------------- C INTEGER NPDEMX PARAMETER (NPDEMX = 4) INTEGER IC, J, NPDE1 DOUBLE PRECISION ERRINF DOUBLE PRECISION ERRTWO(NPDEMX) C NPDE1 = NPDE+1 IF (SOLAV) THEN DO 1 J = 1, NPTS CALL UEXACT(Y(NPDE1,J),T,UEX(1,J)) 1 CONTINUE ENDIF WRITE(LUNR,'(3H-T=,E13.5)') T WRITE(LUNR,*) 'X(S,TN):' WRITE(LUNR,'(5E23.14)') (Y(NPDE1,J), J=1, NPTS) DO 10 IC = 1, NPDE WRITE(LUNR,*) 'U(X(S,TN),TN), COMP:', IC WRITE(LUNR,'(5E23.14)') (Y(IC,J), J=1, NPTS) IF (SOLAV) THEN DO 20 J = 1, NPTS ERR(J) = Y(IC,J) - UEX(IC,J) 20 CONTINUE ERRINF = INFNRM (ERR, NPTS) ERRTWO(IC) = L2NRM (ERR, Y(NPDE1,1), NPDE1, NPTS) WRITE(LUNR,*) 'ERR_U:' WRITE(LUNR,'(5E23.14)') (ERR(J), J=1, NPTS) WRITE(LUNR,*) 'MAX. NORM:', ERRINF WRITE(LUNR,*) 'TWO NORM:', ERRTWO(IC) ENDIF 10 CONTINUE RETURN END SUBROUTINE RUNOUT (RWORK, IWORK) INTEGER IWORK(*) DOUBLE PRECISION RWORK(*) C C Write statistics after each successful step to run info file C C Entry: C RWORK: DOUBLE PRECISION info DASSL C IWORK: INTEGER info DASSL C C --------------------------------------------------------------------- C INTEGER NPTS, LUNR, LUNI COMMON /MOLIF/ NPTS, LUNR, LUNI C SAVE /MOLIF/ C C --------------------------------------------------------------------- C INTEGER IQ DOUBLE PRECISION H, T C T = RWORK(4) H = RWORK(7) IQ = IWORK(8) WRITE (LUNI,'(6H Time=,E13.5, 4H; H=,E13.5, 8H; Order=,I2)') + T, H, IQ RETURN END DOUBLE PRECISION FUNCTION INFNRM (V, N) INTEGER N DOUBLE PRECISION V(N) C C Exit: INFNRM = (J=1,N) MAX !V(J)! C C ---------------------------------------------------------------------- C INTEGER J C INFNRM = 0.0 DO 10 J = 1, N INFNRM = MAX(INFNRM,ABS(V(J))) 10 CONTINUE RETURN END DOUBLE PRECISION FUNCTION L2NRM (V, X, INCX, N) INTEGER INCX, N DOUBLE PRECISION V(N), X(INCX,N) C C Exit: L2NRM = SQRT((J=2,N) SUM ((X(J)-X(J-1))/2.(V(J)^2+V(J-1)^2)) C C ---------------------------------------------------------------------- C INTEGER J DOUBLE PRECISION VJM1S, VJS C L2NRM = 0.0 VJM1S = V(1)*V(1) DO 10 J = 2, N VJS = V(J)*V(J) L2NRM = L2NRM + (X(1,J)-X(1,J-1))/2*(VJS+VJM1S) VJM1S = VJS 10 CONTINUE L2NRM = SQRT(L2NRM) RETURN END C C####################################################################### C C SPMDIF : moving-grid interface routines C C####################################################################### C C----------------------------------------------------------------------- C C Moving grid discretization module SPMDIF C ---------------------------------------- C This module discretizes systems of partial differential equations C in one space variable on a moving grid. The class of equations that C can be handled is given by C C NPDE k -m m C sum C (x,t, u, u ) u + Q (x,t, u, u ) = x (x R (x,t, u, u )) C k=1 j,k - -x t j - -x j - -x x C C where 1 NPDE T C u = ( u , ... , u ) , j = 1,... , NPDE, C - C k C and u is the partial derivative wrt time of the k-th component of u. C t C C The functions C, Q, and R are assumed to be continuous w.r.t. the C space variable. C C The independent variables x and t satisfy x < x < x with x and x C L R L R C fixed and t > t . C 0 C The boundary conditions have the form C C BETA(x,t).R(x,t,u,u ) = GAMMA(x,t,u,u ) at x = x , x , C - -x - -x L R C C where not all of the functions BETA and GAMMA are set to zero. C C The initial conditions are given by C 0 C u (x,t ) = u (x) for x <= x <= x . C - 0 - L R C The discretization method for the PDE in Lagrangian formulation C used by this module is based on a lumped Galerkin / Petrov-Galerkin C method and evaluates the PDE functions in a point between C the (moving) grid points. C C References: C Fixed-grid spatial discretization C Skeel R.D. and Berzins M. C A Method for the Spatial Discretisation of Parabolic C Equations in one Space Variable. C Leeds Report no 217, C Dept. of Computer Studies, The University. C Grid movement C Verwer J.G., Blom J.G., Furzeland R.M. and Zegeling P.A. C A Moving-Grid Method for One-Dimensional PDEs based on C the Method of Lines. C Report NM-R8818, C Centre for Mathematics and Computer Science, Amsterdam. C Interface C Blom J.G. and Zegeling P.A. C A Moving-Grid Interface for Systems of One-Dimensional C Time-Dependent Partial Differential Equations. C Report NM-R8904, C Centre for Mathematics and Computer Science, Amsterdam. C (submitted to ACM TOMS) C C---------------------------------------------------------------------- C C How to use this module C ---------------------- C 1. Set NPDE = # PDEs to be solved. C Set NPTS = # mesh points to be used. C (NC=NPTS-2 is # internal points) C Set M for space coordinate type C = 0 for Cartesian, = 1 for cylindrical, = 2 for spherical. C Specify a workspace of size at least (NPDE+1)*NPTS+(6+NPDE)*NPDE C for use by the routine SKMRES which defines the DAE system being C solved by the integrator. C C Call the initialization routine SETSKM, see the documentation at C the head of this routine for the precise details of the call. C C Set TS and TOUT for start and end integration times. C Initialize data as required for time integration, C - see documentation of DAE solver. C Call the DAE solver with as residual routine SKMRES or an C enveloping routine to satisfy the header requirements. C C 2. Provide a set of routines which describe the precise form of the C PDEs to be solved. Three routines must be provided and the names C of these routines are fixed. These routines are: C SPDEF forms the functions C, Q and R of the PDE in a C given x-point. C BNDR forms the functions BETA and GAMMA associated with the C boundary conditions for the PDE. C UINIT supplies the initial values of the PDE part. C An initial uniform grid is generated by SETSKM and C provided in Y(NPDE+1,I), I=1,NPTS. If required, a user C can redefine the mesh in a nonuniform way. C The headers of these routines are: C C SUBROUTINE SPDEF (T, X, NPDE, U, DUDX, C, Q, R, IRES) C INTEGER NPDE, IRES C DOUBLE PRECISION T, X C DOUBLE PRECISION U(NPDE), DUDX(NPDE), C(NPDE,NPDE), Q(NPDE), C + R(NPDE) C C SUBROUTINE BNDR (T, BETA, GAMMA, U, DUDX, NPDE, LEFT, IRES) C INTEGER NPDE, IRES C LOGICAL LEFT C DOUBLE PRECISION T C DOUBLE PRECISION BETA(NPDE), GAMMA(NPDE), U(NPDE), DUDX(NPDE) C C SUBROUTINE UINIT (NPDE, NPTS, Y) C INTEGER NPDE, NPTS C DOUBLE PRECISION Y(NPDE+1,NPTS) C C C Example problem C --------------- C The easiest way to describe how the problem description routines C should be written is by a simple example. Consider the following C problem from electrodynamics C u = eps.p.u - g(u-v) C t xx C and (so m = 0 and NPDE = 2) C v = p.v + g(u-v) C t xx C with C g(z) = exp(eta.z/3) - exp(-2.eta.z/3) , C 0 <= x <= 1 and 0 <= t <= 4; C eps = 0.143, p = 0.1743, and eta = 17.19. C C The left boundary condition (LEFT = .TRUE.) is given by C u = 0 and v = 0 at x = 0, C x C the right boundary condition (LEFT = .FALSE.) is C u = 0 and v = 0 at x = 1, C x C and the initial conditions are C u = 1 and v = 0 at t = 0. C C The routines UINIT, SPDEF and BNDR are listed below. C The component u of the PDE at the i-th grid point is held as Y(1,i) C in the package, the component v as Y(2,i); the i-th grid point C itself is stored in Y(3,i). C C C C SUBROUTINE UINIT (NPDE, NPTS, Y) C C Routine for PDE initial values. C Entry: C Y(NPDE+1,i) = x_i; uniform mesh, generated by package C Exit: C Y(NPDE+1,i) = x_i; mesh, optionally changed by user C Y( k,i) = u_k(x_i,t0); initial value of k-th component C i = 1,.., NPTS C C INTEGER NPDE, NPTS C DOUBLE PRECISION Y(NPDE+1,NPTS) C C INTEGER I C C DO 10 I = 1, NPTS C Y(1,I) = 1.0 C Y(2,I) = 0.0 C 10 CONTINUE C C RETURN C END C C C C SUBROUTINE SPDEF (T, X, NPDE, U, DUDX, C, Q, R, IRES) C C Routine to describe the body of the PDE system. C The PDE is written as C NPDE k -m m C sum C (x,t,u,u ) u + Q (x,t,u,u ) = x (x R (x,t,u,u ) ) . C k=1 jk x t j x j x x C The functions C, Q and R must be defined in this routine. C C INTEGER NPDE, IRES C DOUBLE PRECISION T, X C DOUBLE PRECISION U(NPDE), DUDX(NPDE), C(NPDE,NPDE), Q(NPDE), C + R(NPDE) C C INTEGER J, K C DOUBLE PRECISION EPS, ETA, GZ, P, Z C DATA EPS /0.143/, ETA /17.19/, P /0.1743/ C C DO 10 K = 1, NPDE C DO 20 J = 1, NPDE C C(J,K) = 0.0 C 20 CONTINUE C C(K,K) = 1.0 C 10 CONTINUE C C Z = U(1) - U(2) C GZ = EXP(ETA*Z/3) - EXP(-2*ETA*Z/3) C Q(1) = GZ C Q(2) = -GZ C C R(1) = EPS*P * DUDX(1) C R(2) = P * DUDX(2) C C RETURN C END C C C C SUBROUTINE BNDR (T, BETA, GAMMA, U, DUDX, NPDE, LEFT, IRES) C C Boundary conditions routine C The boundary conditions are written as C BETA (x,t) R (x,t,u,u ) = GAMMA (x,t,u,u ) C j j x j x C The functions BETA and GAMMA should be defined in this routine. C C INTEGER NPDE, IRES C LOGICAL LEFT C DOUBLE PRECISION T C DOUBLE PRECISION BETA(NPDE), GAMMA(NPDE), U(NPDE), DUDX(NPDE) C C IF (LEFT) THEN C BETA (1) = 1.0 C GAMMA(1) = 0.0 C BETA (2) = 0.0 C GAMMA(2) = U(2) C ELSE C BETA (1) = 0.0 C GAMMA(1) = U(1) - 1.0 C BETA (2) = 1.0 C GAMMA(2) = 0.0 C ENDIF C C RETURN C END C SUBROUTINE SETSKM (NEQN, NPDE, NPTS, XL, XR, TAU, KAPPA, ALPHA, + Y, RWK, NRWK, M, TS, IBAND, IRES) C C----------------------------------------------------------------------- C Purpose: C ------- C Initializing routine for moving-grid spatial discretization. C C Parameters: C ---------- INTEGER NEQN, NPDE, NPTS, NRWK, M, IBAND, IRES DOUBLE PRECISION XL, XR, TAU, KAPPA, ALPHA, TS DOUBLE PRECISION Y(*), RWK(NRWK) C C NEQN Exit: the size of the DAE system generated when the PDE + C the grid equations are discretized. This value is (NPDE+1).NPTS. C NPDE Entry: the number of PDEs. C NPTS Entry: the number of spatial mesh points, including the C boundary points. C XL Entry: left boundary point. C XR Entry: right boundary point. C TAU Entry: time-smoothing parameter. C If the initial grid satisfies the grid equation with TAU=0 at C TS=0, TAU can be chosen equal to zero. If this is not the case C and if the initial grid has to be adapted, or if time-smoothing C is desired a typical value of TAU = 1E-3, but TAU should be C related to the time scale of the problem. C KAPPA Entry: spatial smoothing parameter (DOUBLE PRECISION). C KAPPA = 2.0 was found to be satisfying for all problems tested. C For less spatial smoothing KAPPA = 1.0 will suffice. C ALPHA Entry: monitor regularizing parameter. C ALPHA = 0.01 is recommended (for a well-scaled system of PDEs) C Y Exit: array of length >= (NPDE+1).NPTS that contains the initial C (uniformly spaced) grid and the corresponding initial PDE C solution values. This array must be passed across as a one- C dimensional array of length NEQN to the DAE solver. This C array is ordered as C PDE comp. : Y((NPDE+1)*l + j) l=0,...,NPTS-1, C j=1,...,NPDE C grid points: Y((NPDE+1)*(l+1)) l=0,...,NPTS-1. C RWK workspace of length NRWK for the residual routine SKMRES which C actually performs the semi-discretization of the PDEs and C defines the grid equations. C NRWK Entry: dimension of workspace RWK. C NRWK must be >= (NPDE+1).NPTS + (6+NPDE).NPDE. C M Entry: integer >= 0 which determines the coordinate system used. C 0: Cartesian coordinates, C 1: cylindrical polar coordinates, C 2: spherical polar coordinates. C TS Entry: the time at which the integration starts. C IBAND Exit: an upper bound on the half bandwidth of the Jacobian C matrix when this module is used. (If the DAE solver is called C with banded matrix routines this parameter should be C supplied to MATSET (SPRINT) or to DASSL (IWORK(1) and IWORK(2)). C IRES Exit: this parameter is set to -1 if an error is found by C this routine. C C----------------------------------------------------------------------- C----------------------------------------------------------------------- C C From here the comments are only meant as aid and assistance to C understand the program. C C Four parameters are passed across from here in C COMMON /SPSKM/ NPDE1, NC, M, SING C C NPDE1 = NPDE+1 the number of PDEs + 1 (for the grid equation). C NC = NPTS-2 the number of internal mesh points. C M = M_user = 0,1,2, if resp., Cartesian, cylindrical or C spherical polar coordinates in use. C SING = .TRUE. if PDE has a polar singularity. C C A common block filled with method parameters is initialized C in this routine C COMMON /METPAR/ RTAU, RKAPPA, ALFA C C RTAU time-smoothing parameter grid equation (= TAU) C RKAPPA spatial smoothing parameter grid equation (= KAPPA) C ALFA monitor constant (= ALPHA) C C A common block filled with machine constants is also initialized C in this routine C COMMON /MACH/ NERR, SRELPR C C NERR logical unit number of error unit C SRELPR machine eps as determined by MACHAR C C C Detailed description of workspace: C --------------------------------- C Size: NRWK must be >= (NPDE+1)*NPTS + (6+NPDE)*NPDE C C RWK( 1:.+(NPDE+1)*NPTS) G(NPDE+1,0:NC+1), part of residual not C dependent on time-derivative. C RWK(IW1:.+ NPDE) UKSI(NPDE), solution values at evaluat. point C RWK(IW2:.+ NPDE) UXKSI(NPDE), space derivs. at evaluat. point C RWK(IW3:.+ NPDE) BETA(NPDE), boundary function BETA C RWK(IW4:.+ NPDE) GAMMA(NPDE), boundary function GAMMA C RWK(IW5:.+ NPDE) RC(NPDE), flux at evaluation point C RWK(IW6:.+ NPDE) QC(NPDE), source term at evaluation point C RWK(IW7:.+ NPDE*NPDE) CC(NPDE,NPDE), udot factor at evaluat. point C C----------------------------------------------------------------------- C CHARACTER*6 PDCODE COMMON /DISCHK/ PDCODE C INTEGER NPDE1, NC, MM LOGICAL SING COMMON /SPSKM/ NPDE1, NC, MM, SING C DOUBLE PRECISION RTAU, RKAPPA, ALFA COMMON /METPAR/ RTAU, RKAPPA, ALFA C INTEGER NERR DOUBLE PRECISION SRELPR COMMON /MACH/ NERR, SRELPR C SAVE /DISCHK/, /SPSKM/, /METPAR/, /MACH/ C EXTERNAL MACHAR, YINIT C C----------------------------------------------------------------------- C INTEGER IW1, IW2, IW3, IW4, IW5, IW6, IW7, IWE INTEGER IBETA, IT,IRND, NGRD, MACHEP, NEGEP, IEXP, MINEXP, + MAXEXP DOUBLE PRECISION EPS, EPSNEG, XMIN, XMAX NPDE1 = NPDE+1 NC = NPTS-2 MM = M SING = M .GE. 1 .AND. ABS(XL) .LE. SRELPR*(XR-XL) RTAU = TAU RKAPPA = KAPPA ALFA = ALPHA NERR = 8 CALL MACHAR (IBETA, IT,IRND, NGRD, MACHEP, NEGEP, IEXP, MINEXP, + MAXEXP, EPS, EPSNEG, XMIN, XMAX) SRELPR = MAX (EPS, EPSNEG) C Fill IBAND; ML = MU=2*NPDE1 IBAND = 2*NPDE1 NEQN = NPDE1*NPTS IW1 = 1 + NEQN IW2 = IW1 + NPDE IW3 = IW2 + NPDE IW4 = IW3 + NPDE IW5 = IW4 + NPDE IW6 = IW5 + NPDE IW7 = IW6 + NPDE IWE = IW7 + NPDE*NPDE - 1 IF (IWE .GT. NRWK) THEN WRITE(NERR,'(38H SETSKM - ERROR REAL WORKSPACE OF SIZE, I10, + 28H, IS SMALLER THAN REQUIRED :, I10)') NRWK, IWE IRES = -1 ENDIF IF (M .LT. 0) THEN WRITE(NERR,'(44H SETSKM - POLAR PARAMETER LESS THAN ZERO, M=, + I10)') M IRES = -1 END IF IF (IRES .EQ. -1) RETURN C C Initialize grid and PDE variables by appropriate calls. C CALL YINIT (NPDE, NPTS, XL, XR, Y) C PDCODE = 'SPSKLM' RETURN END SUBROUTINE YINIT (NPDE, NPTS, XL, XR, Y) INTEGER NPDE, NPTS DOUBLE PRECISION XL, XR DOUBLE PRECISION Y(NPDE+1,0:NPTS-1) C INTEGER NPDE1, NC, M LOGICAL SING COMMON /SPSKM/ NPDE1, NC, M, SING SAVE /SPSKM/ C EXTERNAL UINIT C INTEGER I DOUBLE PRECISION DX, XI C C Equidistant grid DX = (XR-XL)/(NC+1) DO 10 I = 0, NC+1 XI = XL+I*DX Y(NPDE1,I) = XI 10 CONTINUE CALL UINIT (NPDE, NPTS, Y) RETURN END SUBROUTINE SKMRES (NEQN, T, Y, YDOT, RES, IRES, RWK, NRWK) C C----------------------------------------------------------------------- C Purpose: C ------- C Enveloping routine to compute the residual of the PDE and of the grid C equations. SKMRES checks on node-crossing, partitions the workspace C and calls CWRESU for the spatial discretization and the computation C of the residual of the PDE in Lagrangian formulation and CWRESX for C the spatial discretization and the residual computation of the grid C equations. C C Parameters: C ---------- INTEGER NEQN, IRES, NRWK DOUBLE PRECISION T DOUBLE PRECISION Y(NEQN), YDOT(NEQN), RES(NEQN), RWK(NRWK) C C NEQN Entry: the size of the DAE system generated when the PDE + C the grid equations are discretized. C T Entry: evaluation time. C Y Entry: array of length NEQN containing the DAE vector consisting C of the spatial mesh and the corresponding initial PDE solution C values at time T. This array is ordered as C PDE comp. : Y((NPDE+1)*l + j) l=0,...,NPTS-1, C j=1,...,NPDE C grid points: Y((NPDE+1)*(l+1)) l=0,...,NPTS-1. C RES Exit: residual vector. C If IRES = -1 RES should contain only the part of the residual C dependent on the time-derivative, if IRES /= -1 RES should C contain the full residual A.ydot - g. C IRES Entry: see above. C Exit: 2, if setup routine SETSKM has not been called. C 3, if one of the DAE solutions in the vector Y is not C acceptable. C RWK working storage of length NRWK. C NRWK Entry: dimension of RWK. Should be >= NEQN + (6+NPDE)*NPDE. C C----------------------------------------------------------------------- C CHARACTER*6 PDCODE COMMON /DISCHK/ PDCODE C INTEGER NPDE1, NC, M LOGICAL SING COMMON /SPSKM/ NPDE1, NC, M, SING C INTEGER NERR DOUBLE PRECISION SRELPR COMMON /MACH/ NERR, SRELPR C SAVE /DISCHK/, /SPSKM/, /MACH/ C EXTERNAL CWRESU, CWRESX C C----------------------------------------------------------------------- C INTEGER I, IW1, IW2, IW3, IW4, IW5, IW6, IW7, J, NPDE IF (PDCODE .NE. 'SPSKLM') THEN WRITE(NERR,*) ' ERROR IN SKLMRES ROUTINE - THE SETUP ROUTINE'// + ' SETSKM WAS NOT CALLED PRIOR TO SPRINT ENTRY' IRES = 2 RETURN ENDIF NPDE = NPDE1-1 C Check on node-crossing DO 5 I = NPDE1, NEQN-NPDE1, NPDE1 IF (Y(I) .GE. Y(I+NPDE1)) THEN WRITE(NERR,'(30H SKMRES - NON-MONOTONOUS GRID,, + 22H VALUES OF GRID POINTS, I3,1H,,I3, + 4H ARE, E13.5,1H1,E13.5)') + I/NPDE1, I/NPDE1+1, Y(I), Y(I+NPDE1) IRES = 3 ENDIF 5 CONTINUE C Partition workspace IW1 = 1 + NEQN IW2 = IW1 + NPDE IW3 = IW2 + NPDE IW4 = IW3 + NPDE IW5 = IW4 + NPDE IW6 = IW5 + NPDE IW7 = IW6 + NPDE C Calculate A.ydot and g for Lagrangian PDE CALL CWRESU (T, Y, YDOT, NPDE1-1, NC, M, SING, + RWK(IW1), RWK(IW2), RWK(IW3), RWK(IW4), + RWK(IW5), RWK(IW6), RWK(IW7), + RES, RWK(1), IRES) IF (IRES .GE. 3) RETURN C Calculate A.ydot and g for grid equations CALL CWRESX (T, Y, YDOT, NPDE1, NC, RES, RWK(1), IRES) IF (IRES .GE. 3) RETURN IF (IRES .NE. -1) THEN C Full residual needed; RES = A.ydot - g DO 10 J = 1, NEQN RES(J) = RES(J) - RWK(J) 10 CONTINUE ENDIF RETURN END SUBROUTINE CWRESU (T, Y, YDOT, NPDE, NC, M, SING, + UKSI, UXKSI, BETA, GAMMA, RC, QC, CC, + AYDOT, G, IRES) C C----------------------------------------------------------------------- C Purpose: C ------- C Compute PDE part of residual equations A.ydot - g. C Return A.ydot in AYDOT and g in G to satisfy both C SPRINT and DASSL. C C Method: C ------ C The Lagrangian form of the PDE is: C NPDE .k k . C sum C (x,t, u, u ) (u - u x) + Q (x,t, u, u ) C k=1 j,k - -x x j - -x C C -m m C = x (x R (x,t, u, u )) C j - -x x C where 1 NPDE T C u = ( u , ... , u ) , j = 1,... , NPDE, C - C .k . C and u is the total time-derivative of the k-th comp. of u and x C is the derivative wrt to time of x. C C This equation is semi-discretized by a lumped finite-element method C (udot and ux.xdot lumped). C Integration over the l-1_th interval and over the l_th interval C both give an expression for the flux in X . Eliminating this value C l C gives a difference equation for l=1,...,N: C C . . C fR R (ksi ) - fR R (ksi ) = fS1 S (ksi ,U ) + fSl S (ksi ,U ) C l j l l-1 j l-1 l j l -l l-1 j l-1 -l C C with: C C m-mu mu C fR = zeta ksi , mu = -1 if PDE singular otherwise mu = m C l l l C C m+1 m+1 C fS1 = (zeta - X ) / (m+1) C l l l C C m+1 m+1 C fSl = (X - zeta ) / (m+1) C l-1 l l-1 C C . NPDE .p p . C S (ksi ,U ) = sum C (ksi ) [ U (X ) - U (X ) X ] + Q (ksi ) C j k -l p=1 jp k l x l l j k C C R , j_th component of flux evaluated at quadrature point ksi, C j C Q , j_th component of source term evaluated at quadrature point ksi, C j C C , element j,p of matrix multiplying u , evaluated at ksi. C jp t C C Left boundary equation, if non-singular: C . C BETA (x ,t) R (x ) = GAMMA (x ,t, U , U (x )) C j L j L j L -0 -x L C C with C m . m C R (x ) = (ksi R (ksi ) - fS1 S (ksi ,U )) / x C j L 0 j 0 0 j 0 -0 L C C if singular: C . C S (ksi ,U )/(m+1) - R (ksi )/ksi = 0 C j 0 -0 j 0 0 C C Right boundary equation: C . C BETA (x ,t) R (x ) = GAMMA (x ,t, U , U (x )) C j R j R j R -N+1 -x R C C with C . m C R (x ) = (fR R (ksi ) + fSl S (ksi ,U )) / x C j R N j N N j N -N+1 R C C C Parameters: C ---------- INTEGER NPDE, NC, M, IRES LOGICAL SING DOUBLE PRECISION T DOUBLE PRECISION Y(NPDE+1,0:NC+1), YDOT(NPDE+1,0:NC+1), + UKSI(NPDE), UXKSI(NPDE), BETA(NPDE), GAMMA(NPDE), + RC(NPDE), QC(NPDE), CC(NPDE,NPDE), + AYDOT(NPDE+1,0:NC+1), G(NPDE+1,0:NC+1) C C T Entry: evaluation time C Y Entry: solution and grid at time T. C (Y(1:NPDE,L): U_l, Y(NPDE+1,L): X_l) C YDOT Entry: derivative of Y at T. C NPDE Entry: # PDEs. C NC Entry: # internal grid points. C M Entry: coordinate system indicator. C SING Entry: true, if PDE has a polar singularity (M>0, x_L=0). C UKSI workspace to hold the solution value at an evaluation point. C UXKSI workspace to hold the space derivatives at an evaluation point. C BETA workspace to hold the boundary function BETA. C GAMMA workspace to hold the boundary function GAMMA C RC workspace to hold the PDE function R. C QC workspace to hold the PDE function Q. C CC workspace to hold the PDE function C. C AYDOT Exit: A.ydot part of the residual. C G Exit: g part of the residual. C IRES Exit: 3 if some user function indicated that a solution value C is unphysical. C C Local variables: C --------------- INTEGER MU DOUBLE PRECISION FSCL, FSC1, SCLMQ, SCL1MQ, + DENOMI, KSI, KSIMU, ZETA, ZETAMU, PHIL, PHILX C MU if sing. then -1 else m. C FSCL fS1_l. C FSC1 fSl_l+1. C SCLMQ S(ksi_l,udot_l) - Q(ksi_l). C SCL1MQ S(ksi_l,udot_l+1) - Q(ksi_l). C DENOMI 1 / [ (X_l,X_l+1) int y**(-m) dy ] C KSI quadrature point for l_th interval C KSIMU ksi**mu C ZETA zeta_l ** (m+1); if sing. and l=0 then C zeta = 0.0 C else (X_l,X_l+1) int y dy * denomi C ZETAMU zeta_l ** (m-mu) C PHIL 'left' trial function for l_th interval in eval. point ksi C NB. phi_l+1 = 1 - phil C PHILX deriv. of phi_l wrt x in eval. point ksi C NB. phi_l+1_x = - phil_x C C EXTERNAL BNDR, SPDEF C C ------------------------------------------------------------------- C INTEGER IP, J, L, NPDE1 DOUBLE PRECISION DENPHI, RCJDOT, RCJG, UXL, UXL1, X0, X0M, XL, + XL1, XN1M NPDE1 = NPDE+1 X0 = Y(NPDE1,0) IF (SING) THEN MU = -1 ELSE MU = M ENDIF C C First interval, compute contribution to residual eq. in X_1 and C left boundary equation C L = 0 XL = X0 XL1 = Y(NPDE1,L+1) IF (.NOT. SING) THEN IF (M .EQ. 1) THEN DENOMI = 1/LOG(XL1/XL) ELSE DENOMI = (1-M)/(XL1**(1-M) - XL**(1-M)) ENDIF ENDIF IF (SING) THEN KSI = 2/3. * (XL1**3-XL**3) / (XL1**2-XL**2) KSIMU = 1/KSI ELSE IF (M .EQ. 1) THEN KSI = (XL1-XL) * DENOMI KSIMU = KSI ELSE IF (M .EQ. 2) THEN KSI = LOG(XL1/XL) * DENOMI KSIMU = KSI*KSI ELSE KSI = (XL1**(2-M)-XL**(2-M)) / (2-M) * DENOMI IF (M .EQ. 0) THEN KSIMU = 1.0 ELSE KSIMU = KSI**MU ENDIF ENDIF IF (SING) THEN ZETA = 0.0 ZETAMU = ZETA DENPHI = 1/(XL1*XL1-XL*XL) PHIL = (XL1*XL1-KSI*KSI)*DENPHI PHILX = -2*KSI*DENPHI ELSE ZETA = 0.5*(XL1*XL1-XL*XL) * DENOMI ZETAMU = 1.0 IF (M .EQ. 1) THEN PHIL = LOG(XL1/KSI) * DENOMI PHILX = -1/KSI * DENOMI ELSE IF (M .EQ. 0) THEN PHIL = (XL1 - KSI) * DENOMI PHILX = -DENOMI ELSE PHIL = (XL1**(1-M) - KSI**(1-M)) / (1-M) * DENOMI PHILX = -KSI**(-M) * DENOMI ENDIF ENDIF IF (M .EQ. 0) THEN X0M = 1.0 ELSE X0M = X0**M ENDIF C Get left boundary function values DO 5 J = 1, NPDE UXKSI(J) = (Y(J,1)-Y(J,0)) / (XL1-XL) 5 CONTINUE CALL BNDR (T, BETA, GAMMA, Y(1,0), UXKSI, + NPDE, .TRUE., IRES) IF (IRES .EQ. 3) RETURN C Compute U and Ux in evaluation point DO 10 J = 1, NPDE UKSI(J) = Y(J,L)*PHIL + Y(J,L+1)*(1-PHIL) UXKSI(J) = Y(J,L)*PHILX + Y(J,L+1)*(-PHILX) 10 CONTINUE C Get C, Q and R in evaluation point CALL SPDEF (T, KSI, NPDE, UKSI, UXKSI, CC, QC, RC, IRES) IF (IRES .EQ. 3) RETURN FSCL = (ZETA- XL**(M+1))/(M+1) FSC1 = (XL1**(M+1)-ZETA)/(M+1) DO 20 J = 1, NPDE SCLMQ = 0.0 SCL1MQ = 0.0 DO 30 IP = 1, NPDE UXL1 = (Y(IP,L+2)-Y(IP,L ))/(Y(NPDE1,L+2)-Y(NPDE1,L )) SCLMQ = SCLMQ + + CC(J,IP)*(YDOT(IP,L )) SCL1MQ = SCL1MQ + + CC(J,IP)*(YDOT(IP,L+1)-UXL1*YDOT(NPDE1,L+1)) 30 CONTINUE C Store contribution from l_th interval to residual equation in X_l+1 AYDOT(J,L+1) = FSC1 * SCL1MQ G (J,L+1) = -ZETAMU*KSIMU*RC(J) - FSC1*QC(J) C Compute boundary equations IF (SING) THEN IF (BETA(J) .NE. 0) THEN C Bnd.eq. is contribution from 0_th interval to C difference eq. in x_L AYDOT(J,0) = SCLMQ / (M+1) G (J,0) = RC(J)/KSI - QC(J)/(M+1) ELSE AYDOT(J,0) = 0.0 G (J,0) = GAMMA(J) ENDIF ELSE C Otherwise compute flux in x_L from contribution from 0_th C interval to difference equation in x_L, and substitute in C user's boundary equation. RCJDOT = -FSCL * SCLMQ / X0M RCJG = (KSIMU*RC(J) - FSCL*QC(J)) / X0M AYDOT(J,0) = -BETA(J)*RCJDOT G (J,0) = BETA(J)*RCJG - GAMMA(J) ENDIF 20 CONTINUE DO 100 L = 1, NC-1 C C Evaluate PDE functions in quadrature point in l_th interval. C Add contribution from [X_l,X_l+1] to that of previous interval to C get residual equation in X_l. C Store contribution from l_th interval to residual equation in X_l+1. C XL = XL1 XL1 = Y(NPDE1,L+1) IF (M .EQ. 1) THEN DENOMI = 1/LOG(XL1/XL) ELSE DENOMI = (1-M)/(XL1**(1-M) - XL**(1-M)) ENDIF IF (SING) THEN KSI = 2/3. * (XL1**3-XL**3) / (XL1**2-XL**2) KSIMU = 1/KSI ELSE IF (M .EQ. 1) THEN KSI = (XL1-XL) * DENOMI KSIMU = KSI ELSE IF (M .EQ. 2) THEN KSI = LOG(XL1/XL) * DENOMI KSIMU = KSI*KSI ELSE KSI = (XL1**(2-M)-XL**(2-M)) / (2-M) * DENOMI IF (M .EQ. 0) THEN KSIMU = 1.0 ELSE KSIMU = KSI**MU ENDIF ENDIF ZETA = 0.5*(XL1*XL1-XL*XL) * DENOMI IF (SING) THEN ZETAMU = ZETA DENPHI = 1/(XL1*XL1-XL*XL) PHIL = (XL1*XL1-KSI*KSI)*DENPHI PHILX = -2*KSI*DENPHI ELSE ZETAMU = 1.0 IF (M .EQ. 1) THEN PHIL = LOG(XL1/KSI) * DENOMI PHILX = -1/KSI * DENOMI ELSE IF (M .EQ. 0) THEN PHIL = (XL1 - KSI) * DENOMI PHILX = -DENOMI ELSE PHIL = (XL1**(1-M) - KSI**(1-M)) / (1-M) * DENOMI PHILX = -KSI**(-M) * DENOMI ENDIF ENDIF C Compute U and Ux in evaluation point DO 110 J = 1, NPDE UKSI(J) = Y(J,L)*PHIL + Y(J,L+1)*(1-PHIL) UXKSI(J) = Y(J,L)*PHILX + Y(J,L+1)*(-PHILX) 110 CONTINUE C Get C, Q and R in evaluation point CALL SPDEF (T, KSI, NPDE, UKSI, UXKSI, CC, QC, RC, IRES) IF (IRES .EQ. 3) RETURN FSCL = (ZETA- XL**(M+1))/(M+1) FSC1 = (XL1**(M+1)-ZETA)/(M+1) DO 120 J = 1, NPDE SCLMQ = 0.0 SCL1MQ = 0.0 DO 130 IP = 1, NPDE UXL = (Y(IP,L+1)-Y(IP,L-1))/(Y(NPDE1,L+1)-Y(NPDE1,L-1)) UXL1 = (Y(IP,L+2)-Y(IP,L ))/(Y(NPDE1,L+2)-Y(NPDE1,L )) SCLMQ = SCLMQ + + CC(J,IP)*(YDOT(IP,L )-UXL *YDOT(NPDE1,L )) SCL1MQ = SCL1MQ + + CC(J,IP)*(YDOT(IP,L+1)-UXL1*YDOT(NPDE1,L+1)) 130 CONTINUE C Add contribution over l_th interval to residual equation in X_l AYDOT(J,L) = AYDOT(J,L) + FSCL * SCLMQ G (J,L) = G (J,L) + ZETAMU*KSIMU*RC(J) - FSCL*QC(J) C Store contribution from l_th interval to residual equation in X_l+1 AYDOT(J,L+1) = FSC1 * SCL1MQ G (J,L+1) = -ZETAMU*KSIMU*RC(J) - FSC1*QC(J) 120 CONTINUE 100 CONTINUE L = NC C C Add contribution over N_th interval to residual equation in X_N. C Compute right boundary equation. C XL = XL1 XL1 = Y(NPDE1,L+1) IF (M .EQ. 1) THEN DENOMI = 1/LOG(XL1/XL) ELSE DENOMI = (1-M)/(XL1**(1-M) - XL**(1-M)) ENDIF IF (SING) THEN KSI = 2/3. * (XL1**3-XL**3) / (XL1**2-XL**2) KSIMU = 1/KSI ELSE IF (M .EQ. 1) THEN KSI = (XL1-XL) * DENOMI KSIMU = KSI ELSE IF (M .EQ. 2) THEN KSI = LOG(XL1/XL) * DENOMI KSIMU = KSI*KSI ELSE KSI = (XL1**(2-M)-XL**(2-M)) / (2-M) * DENOMI IF (M .EQ. 0) THEN KSIMU = 1.0 ELSE KSIMU = KSI**MU ENDIF ENDIF ZETA = 0.5*(XL1*XL1-XL*XL) * DENOMI IF (SING) THEN ZETAMU = ZETA DENPHI = 1/(XL1*XL1-XL*XL) PHIL = (XL1*XL1-KSI*KSI)*DENPHI PHILX = -2*KSI*DENPHI ELSE ZETAMU = 1.0 IF (M .EQ. 1) THEN PHIL = LOG(XL1/KSI) * DENOMI PHILX = -1/KSI * DENOMI ELSE IF (M .EQ. 0) THEN PHIL = (XL1 - KSI) * DENOMI PHILX = -DENOMI ELSE PHIL = (XL1**(1-M) - KSI**(1-M)) / (1-M) * DENOMI PHILX = -KSI**(-M) * DENOMI ENDIF ENDIF IF (M .EQ. 0) THEN XN1M = 1.0 ELSE XN1M = XL1**M ENDIF C Get right boundary function values DO 205 J = 1, NPDE UXKSI(J) = (Y(J,NC+1)-Y(J,NC)) / (XL1-XL) 205 CONTINUE CALL BNDR (T, BETA, GAMMA, Y(1,NC+1), UXKSI, + NPDE, .FALSE., IRES) IF (IRES .EQ. 3) RETURN C Compute U and Ux in evaluation point DO 210 J = 1, NPDE UKSI(J) = Y(J,L)*PHIL + Y(J,L+1)*(1-PHIL) UXKSI(J) = Y(J,L)*PHILX + Y(J,L+1)*(-PHILX) 210 CONTINUE C Get C, Q and R in evaluation point CALL SPDEF (T, KSI, NPDE, UKSI, UXKSI, CC, QC, RC, IRES) IF (IRES .EQ. 3) RETURN FSCL = (ZETA- XL**(M+1))/(M+1) FSC1 = (XL1**(M+1)-ZETA)/(M+1) DO 220 J = 1, NPDE SCLMQ = 0.0 SCL1MQ = 0.0 DO 230 IP = 1, NPDE UXL = (Y(IP,L+1)-Y(IP,L-1))/(Y(NPDE1,L+1)-Y(NPDE1,L-1)) SCLMQ = SCLMQ + + CC(J,IP)*(YDOT(IP,L )-UXL *YDOT(NPDE1,L )) SCL1MQ = SCL1MQ + + CC(J,IP)*(YDOT(IP,L+1)) 230 CONTINUE C Add contribution over N_th interval to residual equation in X_N AYDOT(J,L) = AYDOT(J,L) + FSCL * SCLMQ G (J,L) = G (J,L) + ZETAMU*KSIMU*RC(J) - FSCL*QC(J) C Compute flux in x_R and substitute in user's boundary condition RCJDOT = FSC1 * SCL1MQ / XN1M RCJG = (ZETAMU*KSIMU*RC(J) + FSC1*QC(J)) / XN1M AYDOT(J,NC+1) = -BETA(J)*RCJDOT G (J,NC+1) = BETA(J)*RCJG - GAMMA(J) 220 CONTINUE RETURN END SUBROUTINE CWRESX (T, Y, YDOT, NPDE1, NC, AYDOT, G, IRES) C C----------------------------------------------------------------------- C Purpose: C ------- C Define grid part of DAE system in general form, i.e. A.ydot and g C separated to satisfy both SPRINT and DASSL. C The equations for the moving grid are C . . C nt + tau.nt nt + tau.nt C i-1 i-1 i i C ---------------- - ------------ = 0 1 <= i <= N, C M M C i-1 i C C with nt = n - fac.(n - 2.n + n ); fac = rkappa.(rkappa+1) and C i i i+1 i i-1 C C n = 1 / (X - X ), n = n , n = n . C i i+1 i -1 0 N+1 N C C For simplicity reasons x and x are also part of the DAE vector; since C L R C the boundaries are fixed we have used as ODEs for these variables C . . C X = X = 0. C 0 N+1 C C Parameters: C ---------- INTEGER NPDE1, NC, IRES DOUBLE PRECISION T DOUBLE PRECISION Y(NPDE1,0:NC+1), YDOT(NPDE1,0:NC+1), + AYDOT(NPDE1,0:NC+1), G(NPDE1,0:NC+1) C C T Entry: evaluation time C Y Entry: solution and grid at time T. C (Y(1:NPDE,L): U_l, Y(NPDE+1,L): X_l) C YDOT Entry: derivative of Y at T. C NPDE1 Entry: # PDEs + 1. C NC Entry: # internal grid points. C AYDOT Exit: A.ydot part of the residual. C G Exit: g part of the residual. C IRES Exit: not used. C C----------------------------------------------------------------------- C DOUBLE PRECISION TAU, RKAPPA, ALFA COMMON /METPAR/ TAU, RKAPPA, ALFA SAVE /METPAR/ C C----------------------------------------------------------------------- C INTEGER I, NPDE DOUBLE PRECISION A0, AM, FAC, G0, GM, NIM1, NI, NIP1, NTI, NTDI C NPDE = NPDE1-1 C C ccc Define smoothing factor FAC = RKAPPA*(RKAPPA+1) C C ccc Compute monitor values; store M(I) temp. in G(NPDE1,I), I=0, NC CALL XMNTR (Y, G, NPDE, NC) C C ccc Compute A.xdot and g for grid equations. C Interior equations: C A.xdot (I) = TAU/M(I-1).NTDOT(I-1) - TAU/M(I).NTDOT(I) C g(I) = NT(I)/M(I) - NT(I-1)/M(I-1) C NT(I) = N(I) - FAC.(N(I-1)-2.N(I)+N(I+1)) C N (I) = 1 / (X(I+1)-X(I)) I = 0 NI = 1/(Y(NPDE1,I+1)-Y(NPDE1,I )) NIM1 = NI NIP1 = 1/(Y(NPDE1,I+2)-Y(NPDE1,I+1)) NTI = NI - FAC*(NIM1-2*NI+NIP1) NTDI = - + (1+ FAC)*NI *NI *(YDOT(NPDE1,I+1)-YDOT(NPDE1,I )) + + FAC *NIP1*NIP1*(YDOT(NPDE1,I+2)-YDOT(NPDE1,I+1)) A0 = TAU / G(NPDE1,I) * NTDI G0 = NTI / G(NPDE1,I) DO 10 I = 1, NC-1 NIM1 = NI NI = NIP1 AM = A0 GM = G0 NIP1 = 1/(Y(NPDE1,I+2)-Y(NPDE1,I+1)) NTI = NI - FAC*(NIM1-2*NI+NIP1) NTDI = FAC *NIM1*NIM1*(YDOT(NPDE1,I )-YDOT(NPDE1,I-1)) - + (1+2*FAC)*NI *NI *(YDOT(NPDE1,I+1)-YDOT(NPDE1,I )) + + FAC *NIP1*NIP1*(YDOT(NPDE1,I+2)-YDOT(NPDE1,I+1)) A0 = TAU / G(NPDE1,I) * NTDI G0 = NTI / G(NPDE1,I) AYDOT(NPDE1,I) = AM - A0 G (NPDE1,I) = G0 - GM 10 CONTINUE I = NC NIM1 = NI NI = NIP1 AM = A0 GM = G0 NIP1 = NI NTI = NI - FAC*(NIM1-2*NI+NIP1) NTDI = FAC *NIM1*NIM1*(YDOT(NPDE1,I )-YDOT(NPDE1,I-1)) - + (1+ FAC)*NI *NI *(YDOT(NPDE1,I+1)-YDOT(NPDE1,I )) A0 = TAU / G(NPDE1,I) * NTDI G0 = NTI / G(NPDE1,I) AYDOT(NPDE1,I) = AM - A0 G (NPDE1,I) = G0 - GM C Boundary equations grid. C Fixed endpoints, xdot=0 I=0 AYDOT(NPDE1,I) = YDOT(NPDE1,I) G(NPDE1,I) = 0.0 I=NC+1 AYDOT(NPDE1,I) = YDOT(NPDE1,I) G(NPDE1,I) = 0.0 C RETURN END SUBROUTINE XMNTR (Y, G, NPDE, N) INTEGER NPDE, N DOUBLE PRECISION Y(NPDE+1,0:N+1), G(NPDE+1,0:N+1) C C----------------------------------------------------------------------- C Purpose: C ------- C Compute monitor for grid equation, C M_i = M(x(i+1/2)) = sqrt(alfa + !!ux!!**2) C C Exit: C G(NPDE+1,i) = M(i) C C----------------------------------------------------------------------- C DOUBLE PRECISION TAU, RKAPPA, ALFA COMMON /METPAR/ TAU, RKAPPA, ALFA SAVE /METPAR/ C C----------------------------------------------------------------------- C INTEGER I, K, NPDE1 DOUBLE PRECISION DU, DX, SUX2 C NPDE1 = NPDE+1 DO 10 I = 0, N SUX2 = 0.0 DO 20 K = 1, NPDE DU = Y(K,I+1)-Y(K,I) SUX2 = SUX2 + DU*DU 20 CONTINUE DX = Y(NPDE1,I+1)-Y(NPDE1,I) SUX2 = SUX2 / (DX*DX) G(NPDE1,I) = SQRT(ALFA + SUX2/NPDE) 10 CONTINUE RETURN END C C####################################################################### C C MACHAR : MACHAR routine from W.J. Cody C (available from Netlib: send machar from elefunt) C C####################################################################### C SUBROUTINE MACHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP, 1 MAXEXP,EPS,EPSNEG,XMIN,XMAX) C----------------------------------------------------------------------- C This Fortran 77 subroutine is intended to determine the parameters C of the floating-point arithmetic system specified below. The C determination of the first three uses an extension of an algorithm C due to M. Malcolm, CACM 15 (1972), pp. 949-951, incorporating some, C but not all, of the improvements suggested by M. Gentleman and S. C Marovich, CACM 17 (1974), pp. 276-277. An earlier version of this C program was published in the book Software Manual for the C Elementary Functions by W. J. Cody and W. Waite, Prentice-Hall, C Englewood Cliffs, NJ, 1980. The present version is documented in C W. J. Cody, "MACHAR: A subroutine to dynamically determine machine C parameters," TOMS 14, December, 1988. C C The program as given here must be modified before compiling. If C a single (double) precision version is desired, change all C occurrences of CS (CD) in columns 1 and 2 to blanks. C C Parameter values reported are as follows: C C IBETA - the radix for the floating-point representation C IT - the number of base IBETA digits in the floating-point C significand C IRND - 0 if floating-point addition chops C 1 if floating-point addition rounds, but not in the C IEEE style C 2 if floating-point addition rounds in the IEEE style C 3 if floating-point addition chops, and there is C partial underflow C 4 if floating-point addition rounds, but not in the C IEEE style, and there is partial underflow C 5 if floating-point addition rounds in the IEEE style, C and there is partial underflow C NGRD - the number of guard digits for multiplication with C truncating arithmetic. It is C 0 if floating-point arithmetic rounds, or if it C truncates and only IT base IBETA digits C participate in the post-normalization shift of the C floating-point significand in multiplication; C 1 if floating-point arithmetic truncates and more C than IT base IBETA digits participate in the C post-normalization shift of the floating-point C significand in multiplication. C MACHEP - the largest negative integer such that C 1.0+FLOAT(IBETA)**MACHEP .NE. 1.0, except that C MACHEP is bounded below by -(IT+3) C NEGEPS - the largest negative integer such that C 1.0-FLOAT(IBETA)**NEGEPS .NE. 1.0, except that C NEGEPS is bounded below by -(IT+3) C IEXP - the number of bits (decimal places if IBETA = 10) C reserved for the representation of the exponent C (including the bias or sign) of a floating-point C number C MINEXP - the largest in magnitude negative integer such that C FLOAT(IBETA)**MINEXP is positive and normalized C MAXEXP - the smallest positive power of BETA that overflows C EPS - the smallest positive floating-point number such C that 1.0+EPS .NE. 1.0. In particular, if either C IBETA = 2 or IRND = 0, EPS = FLOAT(IBETA)**MACHEP. C Otherwise, EPS = (FLOAT(IBETA)**MACHEP)/2 C EPSNEG - A small positive floating-point number such that C 1.0-EPSNEG .NE. 1.0. In particular, if IBETA = 2 C or IRND = 0, EPSNEG = FLOAT(IBETA)**NEGEPS. C Otherwise, EPSNEG = (IBETA**NEGEPS)/2. Because C NEGEPS is bounded below by -(IT+3), EPSNEG may not C be the smallest number that can alter 1.0 by C subtraction. C XMIN - the smallest non-vanishing normalized floating-point C power of the radix, i.e., XMIN = FLOAT(IBETA)**MINEXP C XMAX - the largest finite floating-point number. In C particular XMAX = (1.0-EPSNEG)*FLOAT(IBETA)**MAXEXP C Note - on some machines XMAX will be only the C second, or perhaps third, largest number, being C too small by 1 or 2 units in the last digit of C the significand. C C Latest revision - December 4, 1987 C C Author - W. J. Cody C Argonne National Laboratory C C----------------------------------------------------------------------- INTEGER I,IBETA,IEXP,IRND,IT,ITEMP,IZ,J,K,MACHEP,MAXEXP, 1 MINEXP,MX,NEGEP,NGRD,NXRES CS REAL DOUBLE PRECISION 1 A,B,BETA,BETAIN,BETAH,CONV,EPS,EPSNEG,ONE,T,TEMP,TEMPA, 2 TEMP1,TWO,XMAX,XMIN,Y,Z,ZERO C----------------------------------------------------------------------- CS CONV(I) = REAL(I) CONV(I) = DBLE(I) ONE = CONV(1) TWO = ONE + ONE ZERO = ONE - ONE C----------------------------------------------------------------------- C Determine IBETA, BETA ala Malcolm. C----------------------------------------------------------------------- A = ONE 10 A = A + A TEMP = A+ONE TEMP1 = TEMP-A IF (TEMP1-ONE .EQ. ZERO) GO TO 10 B = ONE 20 B = B + B TEMP = A+B ITEMP = INT(TEMP-A) IF (ITEMP .EQ. 0) GO TO 20 IBETA = ITEMP BETA = CONV(IBETA) C----------------------------------------------------------------------- C Determine IT, IRND. C----------------------------------------------------------------------- IT = 0 B = ONE 100 IT = IT + 1 B = B * BETA TEMP = B+ONE TEMP1 = TEMP-B IF (TEMP1-ONE .EQ. ZERO) GO TO 100 IRND = 0 BETAH = BETA / TWO TEMP = A+BETAH IF (TEMP-A .NE. ZERO) IRND = 1 TEMPA = A + BETA TEMP = TEMPA+BETAH IF ((IRND .EQ. 0) .AND. (TEMP-TEMPA .NE. ZERO)) IRND = 2 C----------------------------------------------------------------------- C Determine NEGEP, EPSNEG. C----------------------------------------------------------------------- NEGEP = IT + 3 BETAIN = ONE / BETA A = ONE DO 200 I = 1, NEGEP A = A * BETAIN 200 CONTINUE B = A 210 TEMP = ONE-A IF (TEMP-ONE .NE. ZERO) GO TO 220 A = A * BETA NEGEP = NEGEP - 1 GO TO 210 220 NEGEP = -NEGEP EPSNEG = A C----------------------------------------------------------------------- C Determine MACHEP, EPS. C----------------------------------------------------------------------- MACHEP = -IT - 3 A = B 300 TEMP = ONE+A IF (TEMP-ONE .NE. ZERO) GO TO 320 A = A * BETA MACHEP = MACHEP + 1 GO TO 300 320 EPS = A C----------------------------------------------------------------------- C Determine NGRD. C----------------------------------------------------------------------- NGRD = 0 TEMP = ONE+EPS IF ((IRND .EQ. 0) .AND. (TEMP*ONE-ONE .NE. ZERO)) NGRD = 1 C----------------------------------------------------------------------- C Determine IEXP, MINEXP, XMIN. C C Loop to determine largest I and K = 2**I such that C (1/BETA) ** (2**(I)) C does not underflow. C Exit from loop is signaled by an underflow. C----------------------------------------------------------------------- I = 0 K = 1 Z = BETAIN T = ONE + EPS NXRES = 0 400 Y = Z Z = Y * Y C----------------------------------------------------------------------- C Check for underflow here. C----------------------------------------------------------------------- A = Z * ONE TEMP = Z * T IF ((A+A .EQ. ZERO) .OR. (ABS(Z) .GE. Y)) GO TO 410 TEMP1 = TEMP * BETAIN IF (TEMP1*BETA .EQ. Z) GO TO 410 I = I + 1 K = K + K GO TO 400 410 IF (IBETA .EQ. 10) GO TO 420 IEXP = I + 1 MX = K + K GO TO 450 C----------------------------------------------------------------------- C This segment is for decimal machines only. C----------------------------------------------------------------------- 420 IEXP = 2 IZ = IBETA 430 IF (K .LT. IZ) GO TO 440 IZ = IZ * IBETA IEXP = IEXP + 1 GO TO 430 440 MX = IZ + IZ - 1 C----------------------------------------------------------------------- C Loop to determine MINEXP, XMIN. C Exit from loop is signaled by an underflow. C----------------------------------------------------------------------- 450 XMIN = Y Y = Y * BETAIN C----------------------------------------------------------------------- C Check for underflow here. C----------------------------------------------------------------------- A = Y * ONE TEMP = Y * T IF (((A+A) .EQ. ZERO) .OR. (ABS(Y) .GE. XMIN)) GO TO 460 K = K + 1 TEMP1 = TEMP * BETAIN IF ((TEMP1*BETA .NE. Y) .OR. (TEMP .EQ. Y)) THEN GO TO 450 ELSE NXRES = 3 XMIN = Y END IF 460 MINEXP = -K C----------------------------------------------------------------------- C Determine MAXEXP, XMAX. C----------------------------------------------------------------------- IF ((MX .GT. K+K-3) .OR. (IBETA .EQ. 10)) GO TO 500 MX = MX + MX IEXP = IEXP + 1 500 MAXEXP = MX + MINEXP C----------------------------------------------------------------- C Adjust IRND to reflect partial underflow. C----------------------------------------------------------------- IRND = IRND + NXRES C----------------------------------------------------------------- C Adjust for IEEE-style machines. C----------------------------------------------------------------- IF (IRND .GE. 2) MAXEXP = MAXEXP - 2 C----------------------------------------------------------------- C Adjust for machines with implicit leading bit in binary C significand, and machines with radix point at extreme C right of significand. C----------------------------------------------------------------- I = MAXEXP + MINEXP IF ((IBETA .EQ. 2) .AND. (I .EQ. 0)) MAXEXP = MAXEXP - 1 IF (I .GT. 20) MAXEXP = MAXEXP - 1 IF (A .NE. Y) MAXEXP = MAXEXP - 2 XMAX = ONE - EPSNEG IF (XMAX*ONE .NE. XMAX) XMAX = ONE - BETA * EPSNEG XMAX = XMAX / (BETA * BETA * BETA * XMIN) I = MAXEXP + MINEXP + 3 IF (I .LE. 0) GO TO 520 DO 510 J = 1, I IF (IBETA .EQ. 2) XMAX = XMAX + XMAX IF (IBETA .NE. 2) XMAX = XMAX * BETA 510 CONTINUE 520 RETURN C---------- LAST CARD OF MACHAR ---------- END C C####################################################################### C C Next three files contain sources used to solve the resulting DAE C system with DASSL. C C####################################################################### C C####################################################################### C C DDASSL : DASSL DAE integrator from L.R. Petzold C (available from Netlib: send ddassl from ode) C C####################################################################### C SUBROUTINE DDASSL (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL, + IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC) C***BEGIN PROLOGUE DDASSL C***PURPOSE This code solves a system of differential/algebraic C equations of the form G(T,Y,YPRIME) = 0. C***LIBRARY SLATEC (DASSL) C***CATEGORY I1A2 C***TYPE DOUBLE PRECISION (SDASSL-S, DDASSL-D) C***KEYWORDS DIFFERENTIAL/ALGEBRAIC, BACKWARD DIFFERENTIATION FORMULAS, C IMPLICIT DIFFERENTIAL SYSTEMS C***AUTHOR PETZOLD, LINDA R., (LLNL) C COMPUTING AND MATHEMATICS RESEARCH DIVISION C LAWRENCE LIVERMORE NATIONAL LABORATORY C L - 316, P.O. BOX 808, C LIVERMORE, CA. 94550 C***DESCRIPTION C C *Usage: C C EXTERNAL RES, JAC C INTEGER NEQ, INFO(N), IDID, LRW, LIW, IWORK(LIW), IPAR C DOUBLE PRECISION T, Y(NEQ), YPRIME(NEQ), TOUT, RTOL, ATOL, C * RWORK(LRW), RPAR C C CALL DDASSL (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL, C * IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC) C C C *Arguments: C (In the following, all real arrays should be type DOUBLE PRECISION.) C C RES:EXT This is a subroutine which you provide to define the C differential/algebraic system. C C NEQ:IN This is the number of equations to be solved. C C T:INOUT This is the current value of the independent variable. C C Y(*):INOUT This array contains the solution components at T. C C YPRIME(*):INOUT This array contains the derivatives of the solution C components at T. C C TOUT:IN This is a point at which a solution is desired. C C INFO(N):IN The basic task of the code is to solve the system from T C to TOUT and return an answer at TOUT. INFO is an integer C array which is used to communicate exactly how you want C this task to be carried out. (See below for details.) C N must be greater than or equal to 15. C C RTOL,ATOL:INOUT These quantities represent relative and absolute C error tolerances which you provide to indicate how C accurately you wish the solution to be computed. You C may choose them to be both scalars or else both vectors. C Caution: In Fortran 77, a scalar is not the same as an C array of length 1. Some compilers may object C to using scalars for RTOL,ATOL. C C IDID:OUT This scalar quantity is an indicator reporting what the C code did. You must monitor this integer variable to C decide what action to take next. C C RWORK:WORK A real work array of length LRW which provides the C code with needed storage space. C C LRW:IN The length of RWORK. (See below for required length.) C C IWORK:WORK An integer work array of length LIW which probides the C code with needed storage space. C C LIW:IN The length of IWORK. (See below for required length.) C C RPAR,IPAR:IN These are real and integer parameter arrays which C you can use for communication between your calling C program and the RES subroutine (and the JAC subroutine) C C JAC:EXT This is the name of a subroutine which you may choose C to provide for defining a matrix of partial derivatives C described below. C C Quantities which may be altered by DDASSL are: C T, Y(*), YPRIME(*), INFO(1), RTOL, ATOL, C IDID, RWORK(*) AND IWORK(*) C C *Description C C Subroutine DDASSL uses the backward differentiation formulas of C orders one through five to solve a system of the above form for Y and C YPRIME. Values for Y and YPRIME at the initial time must be given as C input. These values must be consistent, (that is, if T,Y,YPRIME are C the given initial values, they must satisfy G(T,Y,YPRIME) = 0.). The C subroutine solves the system from T to TOUT. It is easy to continue C the solution to get results at additional TOUT. This is the interval C mode of operation. Intermediate results can also be obtained easily C by using the intermediate-output capability. C C The following detailed description is divided into subsections: C 1. Input required for the first call to DDASSL. C 2. Output after any return from DDASSL. C 3. What to do to continue the integration. C 4. Error messages. C C C -------- INPUT -- WHAT TO DO ON THE FIRST CALL TO DDASSL ------------ C C The first call of the code is defined to be the start of each new C problem. Read through the descriptions of all the following items, C provide sufficient storage space for designated arrays, set C appropriate variables for the initialization of the problem, and C give information about how you want the problem to be solved. C C C RES -- Provide a subroutine of the form C SUBROUTINE RES(T,Y,YPRIME,DELTA,IRES,RPAR,IPAR) C to define the system of differential/algebraic C equations which is to be solved. For the given values C of T,Y and YPRIME, the subroutine should C return the residual of the defferential/algebraic C system C DELTA = G(T,Y,YPRIME) C (DELTA(*) is a vector of length NEQ which is C output for RES.) C C Subroutine RES must not alter T,Y or YPRIME. C You must declare the name RES in an external C statement in your program that calls DDASSL. C You must dimension Y,YPRIME and DELTA in RES. C C IRES is an integer flag which is always equal to C zero on input. Subroutine RES should alter IRES C only if it encounters an illegal value of Y or C a stop condition. Set IRES = -1 if an input value C is illegal, and DDASSL will try to solve the problem C without getting IRES = -1. If IRES = -2, DDASSL C will return control to the calling program C with IDID = -11. C C RPAR and IPAR are real and integer parameter arrays which C you can use for communication between your calling program C and subroutine RES. They are not altered by DDASSL. If you C do not need RPAR or IPAR, ignore these parameters by treat- C ing them as dummy arguments. If you do choose to use them, C dimension them in your calling program and in RES as arrays C of appropriate length. C C NEQ -- Set it to the number of differential equations. C (NEQ .GE. 1) C C T -- Set it to the initial point of the integration. C T must be defined as a variable. C C Y(*) -- Set this vector to the initial values of the NEQ solution C components at the initial point. You must dimension Y of C length at least NEQ in your calling program. C C YPRIME(*) -- Set this vector to the initial values of the NEQ C first derivatives of the solution components at the initial C point. You must dimension YPRIME at least NEQ in your C calling program. If you do not know initial values of some C of the solution components, see the explanation of INFO(11). C C TOUT -- Set it to the first point at which a solution C is desired. You can not take TOUT = T. C integration either forward in T (TOUT .GT. T) or C backward in T (TOUT .LT. T) is permitted. C C The code advances the solution from T to TOUT using C step sizes which are automatically selected so as to C achieve the desired accuracy. If you wish, the code will C return with the solution and its derivative at C intermediate steps (intermediate-output mode) so that C you can monitor them, but you still must provide TOUT in C accord with the basic aim of the code. C C The first step taken by the code is a critical one C because it must reflect how fast the solution changes near C the initial point. The code automatically selects an C initial step size which is practically always suitable for C the problem. By using the fact that the code will not step C past TOUT in the first step, you could, if necessary, C restrict the length of the initial step size. C C For some problems it may not be permissible to integrate C past a point TSTOP because a discontinuity occurs there C or the solution or its derivative is not defined beyond C TSTOP. When you have declared a TSTOP point (SEE INFO(4) C and RWORK(1)), you have told the code not to integrate C past TSTOP. In this case any TOUT beyond TSTOP is invalid C input. C C INFO(*) -- Use the INFO array to give the code more details about C how you want your problem solved. This array should be C dimensioned of length 15, though DDASSL uses only the first C eleven entries. You must respond to all of the following C items, which are arranged as questions. The simplest use C of the code corresponds to answering all questions as yes, C i.e. setting all entries of INFO to 0. C C INFO(1) - This parameter enables the code to initialize C itself. You must set it to indicate the start of every C new problem. C C **** Is this the first call for this problem ... C Yes - Set INFO(1) = 0 C No - Not applicable here. C See below for continuation calls. **** C C INFO(2) - How much accuracy you want of your solution C is specified by the error tolerances RTOL and ATOL. C The simplest use is to take them both to be scalars. C To obtain more flexibility, they can both be vectors. C The code must be told your choice. C C **** Are both error tolerances RTOL, ATOL scalars ... C Yes - Set INFO(2) = 0 C and input scalars for both RTOL and ATOL C No - Set INFO(2) = 1 C and input arrays for both RTOL and ATOL **** C C INFO(3) - The code integrates from T in the direction C of TOUT by steps. If you wish, it will return the C computed solution and derivative at the next C intermediate step (the intermediate-output mode) or C TOUT, whichever comes first. This is a good way to C proceed if you want to see the behavior of the solution. C If you must have solutions at a great many specific C TOUT points, this code will compute them efficiently. C C **** Do you want the solution only at C TOUT (and not at the next intermediate step) ... C Yes - Set INFO(3) = 0 C No - Set INFO(3) = 1 **** C C INFO(4) - To handle solutions at a great many specific C values TOUT efficiently, this code may integrate past C TOUT and interpolate to obtain the result at TOUT. C Sometimes it is not possible to integrate beyond some C point TSTOP because the equation changes there or it is C not defined past TSTOP. Then you must tell the code C not to go past. C C **** Can the integration be carried out without any C restrictions on the independent variable T ... C Yes - Set INFO(4)=0 C No - Set INFO(4)=1 C and define the stopping point TSTOP by C setting RWORK(1)=TSTOP **** C C INFO(5) - To solve differential/algebraic problems it is C necessary to use a matrix of partial derivatives of the C system of differential equations. If you do not C provide a subroutine to evaluate it analytically (see C description of the item JAC in the call list), it will C be approximated by numerical differencing in this code. C although it is less trouble for you to have the code C compute partial derivatives by numerical differencing, C the solution will be more reliable if you provide the C derivatives via JAC. Sometimes numerical differencing C is cheaper than evaluating derivatives in JAC and C sometimes it is not - this depends on your problem. C C **** Do you want the code to evaluate the partial C derivatives automatically by numerical differences ... C Yes - Set INFO(5)=0 C No - Set INFO(5)=1 C and provide subroutine JAC for evaluating the C matrix of partial derivatives **** C C INFO(6) - DDASSL will perform much better if the matrix of C partial derivatives, DG/DY + CJ*DG/DYPRIME, C (here CJ is a scalar determined by DDASSL) C is banded and the code is told this. In this C case, the storage needed will be greatly reduced, C numerical differencing will be performed much cheaper, C and a number of important algorithms will execute much C faster. The differential equation is said to have C half-bandwidths ML (lower) and MU (upper) if equation i C involves only unknowns Y(J) with C I-ML .LE. J .LE. I+MU C for all I=1,2,...,NEQ. Thus, ML and MU are the widths C of the lower and upper parts of the band, respectively, C with the main diagonal being excluded. If you do not C indicate that the equation has a banded matrix of partial C derivatives, the code works with a full matrix of NEQ**2 C elements (stored in the conventional way). Computations C with banded matrices cost less time and storage than with C full matrices if 2*ML+MU .LT. NEQ. If you tell the C code that the matrix of partial derivatives has a banded C structure and you want to provide subroutine JAC to C compute the partial derivatives, then you must be careful C to store the elements of the matrix in the special form C indicated in the description of JAC. C C **** Do you want to solve the problem using a full C (dense) matrix (and not a special banded C structure) ... C Yes - Set INFO(6)=0 C No - Set INFO(6)=1 C and provide the lower (ML) and upper (MU) C bandwidths by setting C IWORK(1)=ML C IWORK(2)=MU **** C C C INFO(7) -- You can specify a maximum (absolute value of) C stepsize, so that the code C will avoid passing over very C large regions. C C **** Do you want the code to decide C on its own maximum stepsize? C Yes - Set INFO(7)=0 C No - Set INFO(7)=1 C and define HMAX by setting C RWORK(2)=HMAX **** C C INFO(8) -- Differential/algebraic problems C may occaisionally suffer from C severe scaling difficulties on the C first step. If you know a great deal C about the scaling of your problem, you can C help to alleviate this problem by C specifying an initial stepsize HO. C C **** Do you want the code to define C its own initial stepsize? C Yes - Set INFO(8)=0 C No - Set INFO(8)=1 C and define HO by setting C RWORK(3)=HO **** C C INFO(9) -- If storage is a severe problem, C you can save some locations by C restricting the maximum order MAXORD. C the default value is 5. for each C order decrease below 5, the code C requires NEQ fewer locations, however C it is likely to be slower. In any C case, you must have 1 .LE. MAXORD .LE. 5 C **** Do you want the maximum order to C default to 5? C Yes - Set INFO(9)=0 C No - Set INFO(9)=1 C and define MAXORD by setting C IWORK(3)=MAXORD **** C C INFO(10) --If you know that the solutions to your equations C will always be nonnegative, it may help to set this C parameter. However, it is probably best to C try the code without using this option first, C and only to use this option if that doesn't C work very well. C **** Do you want the code to solve the problem without C invoking any special nonnegativity constraints? C Yes - Set INFO(10)=0 C No - Set INFO(10)=1 C C INFO(11) --DDASSL normally requires the initial T, C Y, and YPRIME to be consistent. That is, C you must have G(T,Y,YPRIME) = 0 at the initial C time. If you do not know the initial C derivative precisely, you can let DDASSL try C to compute it. C **** Are the initialHE INITIAL T, Y, YPRIME consistent? C Yes - Set INFO(11) = 0 C No - Set INFO(11) = 1, C and set YPRIME to an initial approximation C to YPRIME. (If you have no idea what C YPRIME should be, set it to zero. Note C that the initial Y should be such C that there must exist a YPRIME so that C G(T,Y,YPRIME) = 0.) C C RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL C error tolerances to tell the code how accurately you C want the solution to be computed. They must be defined C as variables because the code may change them. You C have two choices -- C Both RTOL and ATOL are scalars. (INFO(2)=0) C Both RTOL and ATOL are vectors. (INFO(2)=1) C in either case all components must be non-negative. C C The tolerances are used by the code in a local error C test at each step which requires roughly that C ABS(LOCAL ERROR) .LE. RTOL*ABS(Y)+ATOL C for each vector component. C (More specifically, a root-mean-square norm is used to C measure the size of vectors, and the error test uses the C magnitude of the solution at the beginning of the step.) C C The true (global) error is the difference between the C true solution of the initial value problem and the C computed approximation. Practically all present day C codes, including this one, control the local error at C each step and do not even attempt to control the global C error directly. C Usually, but not always, the true accuracy of the C computed Y is comparable to the error tolerances. This C code will usually, but not always, deliver a more C accurate solution if you reduce the tolerances and C integrate again. By comparing two such solutions you C can get a fairly reliable idea of the true error in the C solution at the bigger tolerances. C C Setting ATOL=0. results in a pure relative error test on C that component. Setting RTOL=0. results in a pure C absolute error test on that component. A mixed test C with non-zero RTOL and ATOL corresponds roughly to a C relative error test when the solution component is much C bigger than ATOL and to an absolute error test when the C solution component is smaller than the threshhold ATOL. C C The code will not attempt to compute a solution at an C accuracy unreasonable for the machine being used. It will C advise you if you ask for too much accuracy and inform C you as to the maximum accuracy it believes possible. C C RWORK(*) -- Dimension this real work array of length LRW in your C calling program. C C LRW -- Set it to the declared length of the RWORK array. C You must have C LRW .GE. 40+(MAXORD+4)*NEQ+NEQ**2 C for the full (dense) JACOBIAN case (when INFO(6)=0), or C LRW .GE. 40+(MAXORD+4)*NEQ+(2*ML+MU+1)*NEQ C for the banded user-defined JACOBIAN case C (when INFO(5)=1 and INFO(6)=1), or C LRW .GE. 40+(MAXORD+4)*NEQ+(2*ML+MU+1)*NEQ C +2*(NEQ/(ML+MU+1)+1) C for the banded finite-difference-generated JACOBIAN case C (when INFO(5)=0 and INFO(6)=1) C C IWORK(*) -- Dimension this integer work array of length LIW in C your calling program. C C LIW -- Set it to the declared length of the IWORK array. C You must have LIW .GE. 20+NEQ C C RPAR, IPAR -- These are parameter arrays, of real and integer C type, respectively. You can use them for communication C between your program that calls DDASSL and the C RES subroutine (and the JAC subroutine). They are not C altered by DDASSL. If you do not need RPAR or IPAR, C ignore these parameters by treating them as dummy C arguments. If you do choose to use them, dimension C them in your calling program and in RES (and in JAC) C as arrays of appropriate length. C C JAC -- If you have set INFO(5)=0, you can ignore this parameter C by treating it as a dummy argument. Otherwise, you must C provide a subroutine of the form C SUBROUTINE JAC(T,Y,YPRIME,PD,CJ,RPAR,IPAR) C to define the matrix of partial derivatives C PD=DG/DY+CJ*DG/DYPRIME C CJ is a scalar which is input to JAC. C For the given values of T,Y,YPRIME, the C subroutine must evaluate the non-zero partial C derivatives for each equation and each solution C component, and store these values in the C matrix PD. The elements of PD are set to zero C before each call to JAC so only non-zero elements C need to be defined. C C Subroutine JAC must not alter T,Y,(*),YPRIME(*), or CJ. C You must declare the name JAC in an EXTERNAL statement in C your program that calls DDASSL. You must dimension Y, C YPRIME and PD in JAC. C C The way you must store the elements into the PD matrix C depends on the structure of the matrix which you C indicated by INFO(6). C *** INFO(6)=0 -- Full (dense) matrix *** C Give PD a first dimension of NEQ. C When you evaluate the (non-zero) partial derivative C of equation I with respect to variable J, you must C store it in PD according to C PD(I,J) = "DG(I)/DY(J)+CJ*DG(I)/DYPRIME(J)" C *** INFO(6)=1 -- Banded JACOBIAN with ML lower and MU C upper diagonal bands (refer to INFO(6) description C of ML and MU) *** C Give PD a first dimension of 2*ML+MU+1. C when you evaluate the (non-zero) partial derivative C of equation I with respect to variable J, you must C store it in PD according to C IROW = I - J + ML + MU + 1 C PD(IROW,J) = "DG(I)/DY(J)+CJ*DG(I)/DYPRIME(J)" C C RPAR and IPAR are real and integer parameter arrays C which you can use for communication between your calling C program and your JACOBIAN subroutine JAC. They are not C altered by DDASSL. If you do not need RPAR or IPAR, C ignore these parameters by treating them as dummy C arguments. If you do choose to use them, dimension C them in your calling program and in JAC as arrays of C appropriate length. C C C OPTIONALLY REPLACEABLE NORM ROUTINE: C C DDASSL uses a weighted norm DDANRM to measure the size C of vectors such as the estimated error in each step. C A FUNCTION subprogram C DOUBLE PRECISION FUNCTION DDANRM(NEQ,V,WT,RPAR,IPAR) C DIMENSION V(NEQ),WT(NEQ) C is used to define this norm. Here, V is the vector C whose norm is to be computed, and WT is a vector of C weights. A DDANRM routine has been included with DDASSL C which computes the weighted root-mean-square norm C given by C DDANRM=SQRT((1/NEQ)*SUM(V(I)/WT(I))**2) C this norm is suitable for most problems. In some C special cases, it may be more convenient and/or C efficient to define your own norm by writing a function C subprogram to be called instead of DDANRM. This should, C however, be attempted only after careful thought and C consideration. C C C -------- OUTPUT -- AFTER ANY RETURN FROM DDASSL --------------------- C C The principal aim of the code is to return a computed solution at C TOUT, although it is also possible to obtain intermediate results C along the way. To find out whether the code achieved its goal C or if the integration process was interrupted before the task was C completed, you must check the IDID parameter. C C C T -- The solution was successfully advanced to the C output value of T. C C Y(*) -- Contains the computed solution approximation at T. C C YPRIME(*) -- Contains the computed derivative C approximation at T. C C IDID -- Reports what the code did. C C *** Task completed *** C Reported by positive values of IDID C C IDID = 1 -- A step was successfully taken in the C intermediate-output mode. The code has not C yet reached TOUT. C C IDID = 2 -- The integration to TSTOP was successfully C completed (T=TSTOP) by stepping exactly to TSTOP. C C IDID = 3 -- The integration to TOUT was successfully C completed (T=TOUT) by stepping past TOUT. C Y(*) is obtained by interpolation. C YPRIME(*) is obtained by interpolation. C C *** Task interrupted *** C Reported by negative values of IDID C C IDID = -1 -- A large amount of work has been expended. C (About 500 steps) C C IDID = -2 -- The error tolerances are too stringent. C C IDID = -3 -- The local error test cannot be satisfied C because you specified a zero component in ATOL C and the corresponding computed solution C component is zero. Thus, a pure relative error C test is impossible for this component. C C IDID = -6 -- DDASSL had repeated error test C failures on the last attempted step. C C IDID = -7 -- The corrector could not converge. C C IDID = -8 -- The matrix of partial derivatives C is singular. C C IDID = -9 -- The corrector could not converge. C there were repeated error test failures C in this step. C C IDID =-10 -- The corrector could not converge C because IRES was equal to minus one. C C IDID =-11 -- IRES equal to -2 was encountered C and control is being returned to the C calling program. C C IDID =-12 -- DDASSL failed to compute the initial C YPRIME. C C C C IDID = -13,..,-32 -- Not applicable for this code C C *** Task terminated *** C Reported by the value of IDID=-33 C C IDID = -33 -- The code has encountered trouble from which C it cannot recover. A message is printed C explaining the trouble and control is returned C to the calling program. For example, this occurs C when invalid input is detected. C C RTOL, ATOL -- These quantities remain unchanged except when C IDID = -2. In this case, the error tolerances have been C increased by the code to values which are estimated to C be appropriate for continuing the integration. However, C the reported solution at T was obtained using the input C values of RTOL and ATOL. C C RWORK, IWORK -- Contain information which is usually of no C interest to the user but necessary for subsequent calls. C However, you may find use for C C RWORK(3)--Which contains the step size H to be C attempted on the next step. C C RWORK(4)--Which contains the current value of the C independent variable, i.e., the farthest point C integration has reached. This will be different C from T only when interpolation has been C performed (IDID=3). C C RWORK(7)--Which contains the stepsize used C on the last successful step. C C IWORK(7)--Which contains the order of the method to C be attempted on the next step. C C IWORK(8)--Which contains the order of the method used C on the last step. C C IWORK(11)--Which contains the number of steps taken so C far. C C IWORK(12)--Which contains the number of calls to RES C so far. C C IWORK(13)--Which contains the number of evaluations of C the matrix of partial derivatives needed so C far. C C IWORK(14)--Which contains the total number C of error test failures so far. C C IWORK(15)--Which contains the total number C of convergence test failures so far. C (includes singular iteration matrix C failures.) C C C -------- INPUT -- WHAT TO DO TO CONTINUE THE INTEGRATION ------------ C (CALLS AFTER THE FIRST) C C This code is organized so that subsequent calls to continue the C integration involve little (if any) additional effort on your C part. You must monitor the IDID parameter in order to determine C what to do next. C C Recalling that the principal task of the code is to integrate C from T to TOUT (the interval mode), usually all you will need C to do is specify a new TOUT upon reaching the current TOUT. C C Do not alter any quantity not specifically permitted below, C in particular do not alter NEQ,T,Y(*),YPRIME(*),RWORK(*),IWORK(*) C or the differential equation in subroutine RES. Any such C alteration constitutes a new problem and must be treated as such, C i.e., you must start afresh. C C You cannot change from vector to scalar error control or vice C versa (INFO(2)), but you can change the size of the entries of C RTOL, ATOL. Increasing a tolerance makes the equation easier C to integrate. Decreasing a tolerance will make the equation C harder to integrate and should generally be avoided. C C You can switch from the intermediate-output mode to the C interval mode (INFO(3)) or vice versa at any time. C C If it has been necessary to prevent the integration from going C past a point TSTOP (INFO(4), RWORK(1)), keep in mind that the C code will not integrate to any TOUT beyond the currently C specified TSTOP. Once TSTOP has been reached you must change C the value of TSTOP or set INFO(4)=0. You may change INFO(4) C or TSTOP at any time but you must supply the value of TSTOP in C RWORK(1) whenever you set INFO(4)=1. C C Do not change INFO(5), INFO(6), IWORK(1), or IWORK(2) C unless you are going to restart the code. C C *** Following a completed task *** C If C IDID = 1, call the code again to continue the integration C another step in the direction of TOUT. C C IDID = 2 or 3, define a new TOUT and call the code again. C TOUT must be different from T. You cannot change C the direction of integration without restarting. C C *** Following an interrupted task *** C To show the code that you realize the task was C interrupted and that you want to continue, you C must take appropriate action and set INFO(1) = 1 C If C IDID = -1, The code has taken about 500 steps. C If you want to continue, set INFO(1) = 1 and C call the code again. An additional 500 steps C will be allowed. C C IDID = -2, The error tolerances RTOL, ATOL have been C increased to values the code estimates appropriate C for continuing. You may want to change them C yourself. If you are sure you want to continue C with relaxed error tolerances, set INFO(1)=1 and C call the code again. C C IDID = -3, A solution component is zero and you set the C corresponding component of ATOL to zero. If you C are sure you want to continue, you must first C alter the error criterion to use positive values C for those components of ATOL corresponding to zero C solution components, then set INFO(1)=1 and call C the code again. C C IDID = -4,-5 --- Cannot occur with this code. C C IDID = -6, Repeated error test failures occurred on the C last attempted step in DDASSL. A singularity in the C solution may be present. If you are absolutely C certain you want to continue, you should restart C the integration. (Provide initial values of Y and C YPRIME which are consistent) C C IDID = -7, Repeated convergence test failures occurred C on the last attempted step in DDASSL. An inaccurate C or ill-conditioned JACOBIAN may be the problem. If C you are absolutely certain you want to continue, you C should restart the integration. C C IDID = -8, The matrix of partial derivatives is singular. C Some of your equations may be redundant. C DDASSL cannot solve the problem as stated. C It is possible that the redundant equations C could be removed, and then DDASSL could C solve the problem. It is also possible C that a solution to your problem either C does not exist or is not unique. C C IDID = -9, DDASSL had multiple convergence test C failures, preceeded by multiple error C test failures, on the last attempted step. C It is possible that your problem C is ill-posed, and cannot be solved C using this code. Or, there may be a C discontinuity or a singularity in the C solution. If you are absolutely certain C you want to continue, you should restart C the integration. C C IDID =-10, DDASSL had multiple convergence test failures C because IRES was equal to minus one. C If you are absolutely certain you want C to continue, you should restart the C integration. C C IDID =-11, IRES=-2 was encountered, and control is being C returned to the calling program. C C IDID =-12, DDASSL failed to compute the initial YPRIME. C This could happen because the initial C approximation to YPRIME was not very good, or C if a YPRIME consistent with the initial Y C does not exist. The problem could also be caused C by an inaccurate or singular iteration matrix. C C IDID = -13,..,-32 --- Cannot occur with this code. C C C *** Following a terminated task *** C C If IDID= -33, you cannot continue the solution of this problem. C An attempt to do so will result in your C run being terminated. C C C -------- ERROR MESSAGES --------------------------------------------- C C The SLATEC error print routine XERMSG is called in the event of C unsuccessful completion of a task. Most of these are treated as C "recoverable errors", which means that (unless the user has directed C otherwise) control will be returned to the calling program for C possible action after the message has been printed. C C In the event of a negative value of IDID other than -33, an appro- C priate message is printed and the "error number" printed by XERMSG C is the value of IDID. There are quite a number of illegal input C errors that can lead to a returned value IDID=-33. The conditions C and their printed "error numbers" are as follows: C C Error number Condition C C 1 Some element of INFO vector is not zero or one. C 2 NEQ .le. 0 C 3 MAXORD not in range. C 4 LRW is less than the required length for RWORK. C 5 LIW is less than the required length for IWORK. C 6 Some element of RTOL is .lt. 0 C 7 Some element of ATOL is .lt. 0 C 8 All elements of RTOL and ATOL are zero. C 9 INFO(4)=1 and TSTOP is behind TOUT. C 10 HMAX .lt. 0.0 C 11 TOUT is behind T. C 12 INFO(8)=1 and H0=0.0 C 13 Some element of WT is .le. 0.0 C 14 TOUT is too close to T to start integration. C 15 INFO(4)=1 and TSTOP is behind T. C 16 --( Not used in this version )-- C 17 ML illegal. Either .lt. 0 or .gt. NEQ C 18 MU illegal. Either .lt. 0 or .gt. NEQ C 19 TOUT = T. C C If DDASSL is called again without any action taken to remove the C cause of an unsuccessful return, XERMSG will be called with a fatal C error flag, which will cause unconditional termination of the C program. There are two such fatal errors: C C Error number -998: The last step was terminated with a negative C value of IDID other than -33, and no appropriate action was C taken. C C Error number -999: The previous call was terminated because of C illegal input (IDID=-33) and there is illegal input in the C present call, as well. (Suspect infinite loop.) C C --------------------------------------------------------------------- C C***REFERENCES A DESCRIPTION OF DASSL: A DIFFERENTIAL/ALGEBRAIC C SYSTEM SOLVER, L. R. PETZOLD, SAND82-8637, C SANDIA NATIONAL LABORATORIES, SEPTEMBER 1982. C***ROUTINES CALLED D1MACH, DDAINI, DDANRM, DDASTP, DDATRP, DDAWTS, C XERMSG C***REVISION HISTORY (YYMMDD) C 830315 DATE WRITTEN C 880387 Code changes made. All common statements have been C replaced by a DATA statement, which defines pointers into C RWORK, and PARAMETER statements which define pointers C into IWORK. As well the documentation has gone through C grammatical changes. C 881005 The prologue has been changed to mixed case. C The subordinate routines had revision dates changed to C this date, although the documentation for these routines C is all upper case. No code changes. C 890511 Code changes made. The DATA statement in the declaration C section of DDASSL was replaced with a PARAMETER C statement. Also the statement S = 100.D0 was removed C from the top of the Newton iteration in DDASTP. C The subordinate routines had revision dates changed to C this date. C 890517 The revision date syntax was replaced with the revision C history syntax. Also the "DECK" comment was added to C the top of all subroutines. These changes are consistent C with new SLATEC guidelines. C The subordinate routines had revision dates changed to C this date. No code changes. C 891013 Code changes made. C Removed all occurrances of FLOAT or DBLE. All operations C are now performed with "mixed-mode" arithmetic. C Also, specific function names were replaced with generic C function names to be consistent with new SLATEC guidelines. C In particular: C Replaced DSQRT with SQRT everywhere. C Replaced DABS with ABS everywhere. C Replaced DMIN1 with MIN everywhere. C Replaced MIN0 with MIN everywhere. C Replaced DMAX1 with MAX everywhere. C Replaced MAX0 with MAX everywhere. C Replaced DSIGN with SIGN everywhere. C Also replaced REVISION DATE with REVISION HISTORY in all C subordinate routines. C 901004 Miscellaneous changes to prologue to complete conversion C to SLATEC 4.0 format. No code changes. (F.N.Fritsch) C 901009 Corrected GAMS classification code and converted subsidiary C routines to 4.0 format. No code changes. (F.N.Fritsch) C 901010 Converted XERRWV calls to XERMSG calls. (R.Clemens,AFWL) C 901019 Code changes made. C Merged SLATEC 4.0 changes with previous changes made C by C. Ulrich. Below is a history of the changes made by C C. Ulrich. (Changes in subsidiary routines are implied C by this history) C 891228 Bug was found and repaired inside the DDASSL C and DDAINI routines. DDAINI was incorrectly C returning the initial T with Y and YPRIME C computed at T+H. The routine now returns T+H C rather than the initial T. C Cosmetic changes made to DDASTP. C 900904 Three modifications were made to fix a bug (inside C DDASSL) re interpolation for continuation calls and C cases where TN is very close to TSTOP: C C 1) In testing for whether H is too large, just C compare H to (TSTOP - TN), rather than C (TSTOP - TN) * (1-4*UROUND), and set H to C TSTOP - TN. This will force DDASTP to step C exactly to TSTOP under certain situations C (i.e. when H returned from DDASTP would otherwise C take TN beyond TSTOP). C C 2) Inside the DDASTP loop, interpolate exactly to C TSTOP if TN is very close to TSTOP (rather than C interpolating to within roundoff of TSTOP). C C 3) Modified IDID description for IDID = 2 to say that C the solution is returned by stepping exactly to C TSTOP, rather than TOUT. (In some cases the C solution is actually obtained by extrapolating C over a distance near unit roundoff to TSTOP, C but this small distance is deemed acceptable in C these circumstances.) C 901026 Added explicit declarations for all variables and minor C cosmetic changes to prologue, removed unreferenced labels, C and improved XERMSG calls. (FNF) C 901030 Added ERROR MESSAGES section and reworked other sections to C be of more uniform format. (FNF) C 910624 Fixed minor bug related to HMAX (five lines ending in C statement 526 in DDASSL). (LRP) C C***END PROLOGUE DDASSL C C**End C C Declare arguments. C INTEGER NEQ, INFO(15), IDID, LRW, IWORK(*), LIW, IPAR(*) DOUBLE PRECISION * T, Y(*), YPRIME(*), TOUT, RTOL(*), ATOL(*), RWORK(*), * RPAR(*) EXTERNAL RES, JAC C C Declare externals. C EXTERNAL D1MACH, DDAINI, DDANRM, DDASTP, DDATRP, DDAWTS, XERMSG DOUBLE PRECISION D1MACH, DDANRM C C Declare local variables. C INTEGER I, ITEMP, LALPHA, LBETA, LCJ, LCJOLD, LCTF, LDELTA, * LENIW, LENPD, LENRW, LE, LETF, LGAMMA, LH, LHMAX, LHOLD, LIPVT, * LJCALC, LK, LKOLD, LIWM, LML, LMTYPE, LMU, LMXORD, LNJE, LNPD, * LNRE, LNS, LNST, LNSTL, LPD, LPHASE, LPHI, LPSI, LROUND, LS, * LSIGMA, LTN, LTSTOP, LWM, LWT, MBAND, MSAVE, MXORD, NPD, NTEMP, * NZFLG DOUBLE PRECISION * ATOLI, H, HMAX, HMIN, HO, R, RH, RTOLI, TDIST, TN, TNEXT, * TSTOP, UROUND, YPNORM LOGICAL DONE C Auxiliary variables for conversion of values to be included in C error messages. CHARACTER*8 XERN1, XERN2 CHARACTER*16 XERN3, XERN4 C C SET POINTERS INTO IWORK PARAMETER (LML=1, LMU=2, LMXORD=3, LMTYPE=4, LNST=11, * LNRE=12, LNJE=13, LETF=14, LCTF=15, LNPD=16, * LIPVT=21, LJCALC=5, LPHASE=6, LK=7, LKOLD=8, * LNS=9, LNSTL=10, LIWM=1) C C SET RELATIVE OFFSET INTO RWORK PARAMETER (NPD=1) C C SET POINTERS INTO RWORK PARAMETER (LTSTOP=1, LHMAX=2, LH=3, LTN=4, * LCJ=5, LCJOLD=6, LHOLD=7, LS=8, LROUND=9, * LALPHA=11, LBETA=17, LGAMMA=23, * LPSI=29, LSIGMA=35, LDELTA=41) C C***FIRST EXECUTABLE STATEMENT DDASSL IF(INFO(1).NE.0)GO TO 100 C C----------------------------------------------------------------------- C THIS BLOCK IS EXECUTED FOR THE INITIAL CALL ONLY. C IT CONTAINS CHECKING OF INPUTS AND INITIALIZATIONS. C----------------------------------------------------------------------- C C FIRST CHECK INFO ARRAY TO MAKE SURE ALL ELEMENTS OF INFO C ARE EITHER ZERO OR ONE. DO 10 I=2,11 IF(INFO(I).NE.0.AND.INFO(I).NE.1)GO TO 701 10 CONTINUE C IF(NEQ.LE.0)GO TO 702 C C CHECK AND COMPUTE MAXIMUM ORDER MXORD=5 IF(INFO(9).EQ.0)GO TO 20 MXORD=IWORK(LMXORD) IF(MXORD.LT.1.OR.MXORD.GT.5)GO TO 703 20 IWORK(LMXORD)=MXORD C C COMPUTE MTYPE,LENPD,LENRW.CHECK ML AND MU. IF(INFO(6).NE.0)GO TO 40 LENPD=NEQ**2 LENRW=40+(IWORK(LMXORD)+4)*NEQ+LENPD IF(INFO(5).NE.0)GO TO 30 IWORK(LMTYPE)=2 GO TO 60 30 IWORK(LMTYPE)=1 GO TO 60 40 IF(IWORK(LML).LT.0.OR.IWORK(LML).GE.NEQ)GO TO 717 IF(IWORK(LMU).LT.0.OR.IWORK(LMU).GE.NEQ)GO TO 718 LENPD=(2*IWORK(LML)+IWORK(LMU)+1)*NEQ IF(INFO(5).NE.0)GO TO 50 IWORK(LMTYPE)=5 MBAND=IWORK(LML)+IWORK(LMU)+1 MSAVE=(NEQ/MBAND)+1 LENRW=40+(IWORK(LMXORD)+4)*NEQ+LENPD+2*MSAVE GO TO 60 50 IWORK(LMTYPE)=4 LENRW=40+(IWORK(LMXORD)+4)*NEQ+LENPD C C CHECK LENGTHS OF RWORK AND IWORK 60 LENIW=20+NEQ IWORK(LNPD)=LENPD IF(LRW.LT.LENRW)GO TO 704 IF(LIW.LT.LENIW)GO TO 705 C C CHECK TO SEE THAT TOUT IS DIFFERENT FROM T IF(TOUT .EQ. T)GO TO 719 C C CHECK HMAX IF(INFO(7).EQ.0)GO TO 70 HMAX=RWORK(LHMAX) IF(HMAX.LE.0.0D0)GO TO 710 70 CONTINUE C C INITIALIZE COUNTERS IWORK(LNST)=0 IWORK(LNRE)=0 IWORK(LNJE)=0 C IWORK(LNSTL)=0 IDID=1 GO TO 200 C C----------------------------------------------------------------------- C THIS BLOCK IS FOR CONTINUATION CALLS C ONLY. HERE WE CHECK INFO(1),AND IF THE C LAST STEP WAS INTERRUPTED WE CHECK WHETHER C APPROPRIATE ACTION WAS TAKEN. C----------------------------------------------------------------------- C 100 CONTINUE IF(INFO(1).EQ.1)GO TO 110 IF(INFO(1).NE.-1)GO TO 701 C C IF WE ARE HERE, THE LAST STEP WAS INTERRUPTED C BY AN ERROR CONDITION FROM DDASTP,AND C APPROPRIATE ACTION WAS NOT TAKEN. THIS C IS A FATAL ERROR. WRITE (XERN1, '(I8)') IDID CALL XERMSG ('SLATEC', 'DDASSL', * 'THE LAST STEP TERMINATED WITH A NEGATIVE VALUE OF IDID = ' // * XERN1 // ' AND NO APPROPRIATE ACTION WAS TAKEN. ' // * 'RUN TERMINATED', -998, 2) RETURN 110 CONTINUE IWORK(LNSTL)=IWORK(LNST) C C----------------------------------------------------------------------- C THIS BLOCK IS EXECUTED ON ALL CALLS. C THE ERROR TOLERANCE PARAMETERS ARE C CHECKED, AND THE WORK ARRAY POINTERS C ARE SET. C----------------------------------------------------------------------- C 200 CONTINUE C CHECK RTOL,ATOL NZFLG=0 RTOLI=RTOL(1) ATOLI=ATOL(1) DO 210 I=1,NEQ IF(INFO(2).EQ.1)RTOLI=RTOL(I) IF(INFO(2).EQ.1)ATOLI=ATOL(I) IF(RTOLI.GT.0.0D0.OR.ATOLI.GT.0.0D0)NZFLG=1 IF(RTOLI.LT.0.0D0)GO TO 706 IF(ATOLI.LT.0.0D0)GO TO 707 210 CONTINUE IF(NZFLG.EQ.0)GO TO 708 C C SET UP RWORK STORAGE.IWORK STORAGE IS FIXED C IN DATA STATEMENT. LE=LDELTA+NEQ LWT=LE+NEQ LPHI=LWT+NEQ LPD=LPHI+(IWORK(LMXORD)+1)*NEQ LWM=LPD NTEMP=NPD+IWORK(LNPD) IF(INFO(1).EQ.1)GO TO 400 C C----------------------------------------------------------------------- C THIS BLOCK IS EXECUTED ON THE INITIAL CALL C ONLY. SET THE INITIAL STEP SIZE, AND C THE ERROR WEIGHT VECTOR, AND PHI. C COMPUTE INITIAL YPRIME, IF NECESSARY. C----------------------------------------------------------------------- C TN=T IDID=1 C C SET ERROR WEIGHT VECTOR WT CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,Y,RWORK(LWT),RPAR,IPAR) DO 305 I = 1,NEQ IF(RWORK(LWT+I-1).LE.0.0D0) GO TO 713 305 CONTINUE C C COMPUTE UNIT ROUNDOFF AND HMIN UROUND = D1MACH(4) RWORK(LROUND) = UROUND HMIN = 4.0D0*UROUND*MAX(ABS(T),ABS(TOUT)) C C CHECK INITIAL INTERVAL TO SEE THAT IT IS LONG ENOUGH TDIST = ABS(TOUT - T) IF(TDIST .LT. HMIN) GO TO 714 C C CHECK HO, IF THIS WAS INPUT IF (INFO(8) .EQ. 0) GO TO 310 HO = RWORK(LH) IF ((TOUT - T)*HO .LT. 0.0D0) GO TO 711 IF (HO .EQ. 0.0D0) GO TO 712 GO TO 320 310 CONTINUE C C COMPUTE INITIAL STEPSIZE, TO BE USED BY EITHER C DDASTP OR DDAINI, DEPENDING ON INFO(11) HO = 0.001D0*TDIST YPNORM = DDANRM(NEQ,YPRIME,RWORK(LWT),RPAR,IPAR) IF (YPNORM .GT. 0.5D0/HO) HO = 0.5D0/YPNORM HO = SIGN(HO,TOUT-T) C ADJUST HO IF NECESSARY TO MEET HMAX BOUND 320 IF (INFO(7) .EQ. 0) GO TO 330 RH = ABS(HO)/RWORK(LHMAX) IF (RH .GT. 1.0D0) HO = HO/RH C COMPUTE TSTOP, IF APPLICABLE 330 IF (INFO(4) .EQ. 0) GO TO 340 TSTOP = RWORK(LTSTOP) IF ((TSTOP - T)*HO .LT. 0.0D0) GO TO 715 IF ((T + HO - TSTOP)*HO .GT. 0.0D0) HO = TSTOP - T IF ((TSTOP - TOUT)*HO .LT. 0.0D0) GO TO 709 C C COMPUTE INITIAL DERIVATIVE, UPDATING TN AND Y, IF APPLICABLE 340 IF (INFO(11) .EQ. 0) GO TO 350 CALL DDAINI(TN,Y,YPRIME,NEQ, * RES,JAC,HO,RWORK(LWT),IDID,RPAR,IPAR, * RWORK(LPHI),RWORK(LDELTA),RWORK(LE), * RWORK(LWM),IWORK(LIWM),HMIN,RWORK(LROUND), * INFO(10),NTEMP) IF (IDID .LT. 0) GO TO 390 C C LOAD H WITH HO. STORE H IN RWORK(LH) 350 H = HO RWORK(LH) = H C C LOAD Y AND H*YPRIME INTO PHI(*,1) AND PHI(*,2) ITEMP = LPHI + NEQ DO 370 I = 1,NEQ RWORK(LPHI + I - 1) = Y(I) 370 RWORK(ITEMP + I - 1) = H*YPRIME(I) C 390 GO TO 500 C C------------------------------------------------------- C THIS BLOCK IS FOR CONTINUATION CALLS ONLY. ITS C PURPOSE IS TO CHECK STOP CONDITIONS BEFORE C TAKING A STEP. C ADJUST H IF NECESSARY TO MEET HMAX BOUND C------------------------------------------------------- C 400 CONTINUE UROUND=RWORK(LROUND) DONE = .FALSE. TN=RWORK(LTN) H=RWORK(LH) IF(INFO(7) .EQ. 0) GO TO 410 RH = ABS(H)/RWORK(LHMAX) IF(RH .GT. 1.0D0) H = H/RH 410 CONTINUE IF(T .EQ. TOUT) GO TO 719 IF((T - TOUT)*H .GT. 0.0D0) GO TO 711 IF(INFO(4) .EQ. 1) GO TO 430 IF(INFO(3) .EQ. 1) GO TO 420 IF((TN-TOUT)*H.LT.0.0D0)GO TO 490 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), * RWORK(LPHI),RWORK(LPSI)) T=TOUT IDID = 3 DONE = .TRUE. GO TO 490 420 IF((TN-T)*H .LE. 0.0D0) GO TO 490 IF((TN - TOUT)*H .GT. 0.0D0) GO TO 425 CALL DDATRP(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD), * RWORK(LPHI),RWORK(LPSI)) T = TN IDID = 1 DONE = .TRUE. GO TO 490 425 CONTINUE CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), * RWORK(LPHI),RWORK(LPSI)) T = TOUT IDID = 3 DONE = .TRUE. GO TO 490 430 IF(INFO(3) .EQ. 1) GO TO 440 TSTOP=RWORK(LTSTOP) IF((TN-TSTOP)*H.GT.0.0D0) GO TO 715 IF((TSTOP-TOUT)*H.LT.0.0D0)GO TO 709 IF((TN-TOUT)*H.LT.0.0D0)GO TO 450 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), * RWORK(LPHI),RWORK(LPSI)) T=TOUT IDID = 3 DONE = .TRUE. GO TO 490 440 TSTOP = RWORK(LTSTOP) IF((TN-TSTOP)*H .GT. 0.0D0) GO TO 715 IF((TSTOP-TOUT)*H .LT. 0.0D0) GO TO 709 IF((TN-T)*H .LE. 0.0D0) GO TO 450 IF((TN - TOUT)*H .GT. 0.0D0) GO TO 445 CALL DDATRP(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD), * RWORK(LPHI),RWORK(LPSI)) T = TN IDID = 1 DONE = .TRUE. GO TO 490 445 CONTINUE CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), * RWORK(LPHI),RWORK(LPSI)) T = TOUT IDID = 3 DONE = .TRUE. GO TO 490 450 CONTINUE C CHECK WHETHER WE ARE WITHIN ROUNDOFF OF TSTOP IF(ABS(TN-TSTOP).GT.100.0D0*UROUND* * (ABS(TN)+ABS(H)))GO TO 460 CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ,IWORK(LKOLD), * RWORK(LPHI),RWORK(LPSI)) IDID=2 T=TSTOP DONE = .TRUE. GO TO 490 460 TNEXT=TN+H IF((TNEXT-TSTOP)*H.LE.0.0D0)GO TO 490 H=TSTOP-TN RWORK(LH)=H C 490 IF (DONE) GO TO 580 C C------------------------------------------------------- C THE NEXT BLOCK CONTAINS THE CALL TO THE C ONE-STEP INTEGRATOR DDASTP. C THIS IS A LOOPING POINT FOR THE INTEGRATION STEPS. C CHECK FOR TOO MANY STEPS. C UPDATE WT. C CHECK FOR TOO MUCH ACCURACY REQUESTED. C COMPUTE MINIMUM STEPSIZE. C------------------------------------------------------- C 500 CONTINUE C CHECK FOR FAILURE TO COMPUTE INITIAL YPRIME IF (IDID .EQ. -12) GO TO 527 C C CHECK FOR TOO MANY STEPS IF((IWORK(LNST)-IWORK(LNSTL)).LT.500) * GO TO 510 IDID=-1 GO TO 527 C C UPDATE WT 510 CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,RWORK(LPHI), * RWORK(LWT),RPAR,IPAR) DO 520 I=1,NEQ IF(RWORK(I+LWT-1).GT.0.0D0)GO TO 520 IDID=-3 GO TO 527 520 CONTINUE C C TEST FOR TOO MUCH ACCURACY REQUESTED. R=DDANRM(NEQ,RWORK(LPHI),RWORK(LWT),RPAR,IPAR)* * 100.0D0*UROUND IF(R.LE.1.0D0)GO TO 525 C MULTIPLY RTOL AND ATOL BY R AND RETURN IF(INFO(2).EQ.1)GO TO 523 RTOL(1)=R*RTOL(1) ATOL(1)=R*ATOL(1) IDID=-2 GO TO 527 523 DO 524 I=1,NEQ RTOL(I)=R*RTOL(I) 524 ATOL(I)=R*ATOL(I) IDID=-2 GO TO 527 525 CONTINUE C C COMPUTE MINIMUM STEPSIZE HMIN=4.0D0*UROUND*MAX(ABS(TN),ABS(TOUT)) C C TEST H VS. HMAX IF (INFO(7) .EQ. 0) GO TO 526 RH = ABS(H)/RWORK(LHMAX) IF (RH .GT. 1.0D0) H = H/RH 526 CONTINUE C CALL DDASTP(TN,Y,YPRIME,NEQ, * RES,JAC,H,RWORK(LWT),INFO(1),IDID,RPAR,IPAR, * RWORK(LPHI),RWORK(LDELTA),RWORK(LE), * RWORK(LWM),IWORK(LIWM), * RWORK(LALPHA),RWORK(LBETA),RWORK(LGAMMA), * RWORK(LPSI),RWORK(LSIGMA), * RWORK(LCJ),RWORK(LCJOLD),RWORK(LHOLD), * RWORK(LS),HMIN,RWORK(LROUND), * IWORK(LPHASE),IWORK(LJCALC),IWORK(LK), * IWORK(LKOLD),IWORK(LNS),INFO(10),NTEMP) 527 IF(IDID.LT.0)GO TO 600 C C-------------------------------------------------------- C THIS BLOCK HANDLES THE CASE OF A SUCCESSFUL RETURN C FROM DDASTP (IDID=1). TEST FOR STOP CONDITIONS. C-------------------------------------------------------- C IF(INFO(4).NE.0)GO TO 540 IF(INFO(3).NE.0)GO TO 530 IF((TN-TOUT)*H.LT.0.0D0)GO TO 500 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) IDID=3 T=TOUT GO TO 580 530 IF((TN-TOUT)*H.GE.0.0D0)GO TO 535 T=TN IDID=1 GO TO 580 535 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) IDID=3 T=TOUT GO TO 580 540 IF(INFO(3).NE.0)GO TO 550 IF((TN-TOUT)*H.LT.0.0D0)GO TO 542 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) T=TOUT IDID=3 GO TO 580 542 IF(ABS(TN-TSTOP).LE.100.0D0*UROUND* * (ABS(TN)+ABS(H)))GO TO 545 TNEXT=TN+H IF((TNEXT-TSTOP)*H.LE.0.0D0)GO TO 500 H=TSTOP-TN GO TO 500 545 CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ, * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) IDID=2 T=TSTOP GO TO 580 550 IF((TN-TOUT)*H.GE.0.0D0)GO TO 555 IF(ABS(TN-TSTOP).LE.100.0D0*UROUND*(ABS(TN)+ABS(H)))GO TO 552 T=TN IDID=1 GO TO 580 552 CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ, * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) IDID=2 T=TSTOP GO TO 580 555 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) T=TOUT IDID=3 GO TO 580 C C-------------------------------------------------------- C ALL SUCCESSFUL RETURNS FROM DDASSL ARE MADE FROM C THIS BLOCK. C-------------------------------------------------------- C 580 CONTINUE RWORK(LTN)=TN RWORK(LH)=H RETURN C C----------------------------------------------------------------------- C THIS BLOCK HANDLES ALL UNSUCCESSFUL C RETURNS OTHER THAN FOR ILLEGAL INPUT. C----------------------------------------------------------------------- C 600 CONTINUE ITEMP=-IDID GO TO (610,620,630,690,690,640,650,660,670,675, * 680,685), ITEMP C C THE MAXIMUM NUMBER OF STEPS WAS TAKEN BEFORE C REACHING TOUT 610 WRITE (XERN3, '(1P,D15.6)') TN CALL XERMSG ('SLATEC', 'DDASSL', * 'AT CURRENT T = ' // XERN3 // ' 500 STEPS TAKEN ON THIS ' // * 'CALL BEFORE REACHING TOUT', IDID, 1) GO TO 690 C C TOO MUCH ACCURACY FOR MACHINE PRECISION 620 WRITE (XERN3, '(1P,D15.6)') TN CALL XERMSG ('SLATEC', 'DDASSL', * 'AT T = ' // XERN3 // ' TOO MUCH ACCURACY REQUESTED FOR ' // * 'PRECISION OF MACHINE. RTOL AND ATOL WERE INCREASED TO ' // * 'APPROPRIATE VALUES', IDID, 1) GO TO 690 C C WT(I) .LE. 0.0 FOR SOME I (NOT AT START OF PROBLEM) 630 WRITE (XERN3, '(1P,D15.6)') TN CALL XERMSG ('SLATEC', 'DDASSL', * 'AT T = ' // XERN3 // ' SOME ELEMENT OF WT HAS BECOME .LE. ' // * '0.0', IDID, 1) GO TO 690 C C ERROR TEST FAILED REPEATEDLY OR WITH H=HMIN 640 WRITE (XERN3, '(1P,D15.6)') TN WRITE (XERN4, '(1P,D15.6)') H CALL XERMSG ('SLATEC', 'DDASSL', * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // * ' THE ERROR TEST FAILED REPEATEDLY OR WITH ABS(H)=HMIN', * IDID, 1) GO TO 690 C C CORRECTOR CONVERGENCE FAILED REPEATEDLY OR WITH H=HMIN 650 WRITE (XERN3, '(1P,D15.6)') TN WRITE (XERN4, '(1P,D15.6)') H CALL XERMSG ('SLATEC', 'DDASSL', * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // * ' THE CORRECTOR FAILED TO CONVERGE REPEATEDLY OR WITH ' // * 'ABS(H)=HMIN', IDID, 1) GO TO 690 C C THE ITERATION MATRIX IS SINGULAR 660 WRITE (XERN3, '(1P,D15.6)') TN WRITE (XERN4, '(1P,D15.6)') H CALL XERMSG ('SLATEC', 'DDASSL', * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // * ' THE ITERATION MATRIX IS SINGULAR', IDID, 1) GO TO 690 C C CORRECTOR FAILURE PRECEEDED BY ERROR TEST FAILURES. 670 WRITE (XERN3, '(1P,D15.6)') TN WRITE (XERN4, '(1P,D15.6)') H CALL XERMSG ('SLATEC', 'DDASSL', * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // * ' THE CORRECTOR COULD NOT CONVERGE. ALSO, THE ERROR TEST ' // * 'FAILED REPEATEDLY.', IDID, 1) GO TO 690 C C CORRECTOR FAILURE BECAUSE IRES = -1 675 WRITE (XERN3, '(1P,D15.6)') TN WRITE (XERN4, '(1P,D15.6)') H CALL XERMSG ('SLATEC', 'DDASSL', * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // * ' THE CORRECTOR COULD NOT CONVERGE BECAUSE IRES WAS EQUAL ' // * 'TO MINUS ONE', IDID, 1) GO TO 690 C C FAILURE BECAUSE IRES = -2 680 WRITE (XERN3, '(1P,D15.6)') TN WRITE (XERN4, '(1P,D15.6)') H CALL XERMSG ('SLATEC', 'DDASSL', * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // * ' IRES WAS EQUAL TO MINUS TWO', IDID, 1) GO TO 690 C C FAILED TO COMPUTE INITIAL YPRIME 685 WRITE (XERN3, '(1P,D15.6)') TN WRITE (XERN4, '(1P,D15.6)') HO CALL XERMSG ('SLATEC', 'DDASSL', * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // * ' THE INITIAL YPRIME COULD NOT BE COMPUTED', IDID, 1) GO TO 690 C 690 CONTINUE INFO(1)=-1 T=TN RWORK(LTN)=TN RWORK(LH)=H RETURN C C----------------------------------------------------------------------- C THIS BLOCK HANDLES ALL ERROR RETURNS DUE C TO ILLEGAL INPUT, AS DETECTED BEFORE CALLING C DDASTP. FIRST THE ERROR MESSAGE ROUTINE IS C CALLED. IF THIS HAPPENS TWICE IN C SUCCESSION, EXECUTION IS TERMINATED C C----------------------------------------------------------------------- 701 CALL XERMSG ('SLATEC', 'DDASSL', * 'SOME ELEMENT OF INFO VECTOR IS NOT ZERO OR ONE', 1, 1) GO TO 750 C 702 WRITE (XERN1, '(I8)') NEQ CALL XERMSG ('SLATEC', 'DDASSL', * 'NEQ = ' // XERN1 // ' .LE. 0', 2, 1) GO TO 750 C 703 WRITE (XERN1, '(I8)') MXORD CALL XERMSG ('SLATEC', 'DDASSL', * 'MAXORD = ' // XERN1 // ' NOT IN RANGE', 3, 1) GO TO 750 C 704 WRITE (XERN1, '(I8)') LENRW WRITE (XERN2, '(I8)') LRW CALL XERMSG ('SLATEC', 'DDASSL', * 'RWORK LENGTH NEEDED, LENRW = ' // XERN1 // * ', EXCEEDS LRW = ' // XERN2, 4, 1) GO TO 750 C 705 WRITE (XERN1, '(I8)') LENIW WRITE (XERN2, '(I8)') LIW CALL XERMSG ('SLATEC', 'DDASSL', * 'IWORK LENGTH NEEDED, LENIW = ' // XERN1 // * ', EXCEEDS LIW = ' // XERN2, 5, 1) GO TO 750 C 706 CALL XERMSG ('SLATEC', 'DDASSL', * 'SOME ELEMENT OF RTOL IS .LT. 0', 6, 1) GO TO 750 C 707 CALL XERMSG ('SLATEC', 'DDASSL', * 'SOME ELEMENT OF ATOL IS .LT. 0', 7, 1) GO TO 750 C 708 CALL XERMSG ('SLATEC', 'DDASSL', * 'ALL ELEMENTS OF RTOL AND ATOL ARE ZERO', 8, 1) GO TO 750 C 709 WRITE (XERN3, '(1P,D15.6)') TSTOP WRITE (XERN4, '(1P,D15.6)') TOUT CALL XERMSG ('SLATEC', 'DDASSL', * 'INFO(4) = 1 AND TSTOP = ' // XERN3 // ' BEHIND TOUT = ' // * XERN4, 9, 1) GO TO 750 C 710 WRITE (XERN3, '(1P,D15.6)') HMAX CALL XERMSG ('SLATEC', 'DDASSL', * 'HMAX = ' // XERN3 // ' .LT. 0.0', 10, 1) GO TO 750 C 711 WRITE (XERN3, '(1P,D15.6)') TOUT WRITE (XERN4, '(1P,D15.6)') T CALL XERMSG ('SLATEC', 'DDASSL', * 'TOUT = ' // XERN3 // ' BEHIND T = ' // XERN4, 11, 1) GO TO 750 C 712 CALL XERMSG ('SLATEC', 'DDASSL', * 'INFO(8)=1 AND H0=0.0', 12, 1) GO TO 750 C 713 CALL XERMSG ('SLATEC', 'DDASSL', * 'SOME ELEMENT OF WT IS .LE. 0.0', 13, 1) GO TO 750 C 714 WRITE (XERN3, '(1P,D15.6)') TOUT WRITE (XERN4, '(1P,D15.6)') T CALL XERMSG ('SLATEC', 'DDASSL', * 'TOUT = ' // XERN3 // ' TOO CLOSE TO T = ' // XERN4 // * ' TO START INTEGRATION', 14, 1) GO TO 750 C 715 WRITE (XERN3, '(1P,D15.6)') TSTOP WRITE (XERN4, '(1P,D15.6)') T CALL XERMSG ('SLATEC', 'DDASSL', * 'INFO(4)=1 AND TSTOP = ' // XERN3 // ' BEHIND T = ' // XERN4, * 15, 1) GO TO 750 C 717 WRITE (XERN1, '(I8)') IWORK(LML) CALL XERMSG ('SLATEC', 'DDASSL', * 'ML = ' // XERN1 // ' ILLEGAL. EITHER .LT. 0 OR .GT. NEQ', * 17, 1) GO TO 750 C 718 WRITE (XERN1, '(I8)') IWORK(LMU) CALL XERMSG ('SLATEC', 'DDASSL', * 'MU = ' // XERN1 // ' ILLEGAL. EITHER .LT. 0 OR .GT. NEQ', * 18, 1) GO TO 750 C 719 WRITE (XERN3, '(1P,D15.6)') TOUT CALL XERMSG ('SLATEC', 'DDASSL', * 'TOUT = T = ' // XERN3, 19, 1) GO TO 750 C 750 IDID=-33 IF(INFO(1).EQ.-1) THEN CALL XERMSG ('SLATEC', 'DDASSL', * 'REPEATED OCCURRENCES OF ILLEGAL INPUT$$' // * 'RUN TERMINATED. APPARENT INFINITE LOOP', -999, 2) ENDIF C INFO(1)=-1 RETURN C-----------END OF SUBROUTINE DDASSL------------------------------------ END SUBROUTINE DDAWTS (NEQ, IWT, RTOL, ATOL, Y, WT, RPAR, IPAR) C***BEGIN PROLOGUE DDAWTS C***SUBSIDIARY C***PURPOSE Set error weight vector for DDASSL. C***LIBRARY SLATEC (DASSL) C***TYPE DOUBLE PRECISION (SDAWTS-S, DDAWTS-D) C***AUTHOR PETZOLD, LINDA R., (LLNL) C***DESCRIPTION C----------------------------------------------------------------------- C THIS SUBROUTINE SETS THE ERROR WEIGHT VECTOR C WT ACCORDING TO WT(I)=RTOL(I)*ABS(Y(I))+ATOL(I), C I=1,-,N. C RTOL AND ATOL ARE SCALARS IF IWT = 0, C AND VECTORS IF IWT = 1. C----------------------------------------------------------------------- C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 830315 DATE WRITTEN C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. C 901026 Added explicit declarations for all variables and minor C cosmetic changes to prologue. (FNF) C***END PROLOGUE DDAWTS C INTEGER NEQ, IWT, IPAR(*) DOUBLE PRECISION RTOL(*), ATOL(*), Y(*), WT(*), RPAR(*) C INTEGER I DOUBLE PRECISION ATOLI, RTOLI C C***FIRST EXECUTABLE STATEMENT DDAWTS RTOLI=RTOL(1) ATOLI=ATOL(1) DO 20 I=1,NEQ IF (IWT .EQ.0) GO TO 10 RTOLI=RTOL(I) ATOLI=ATOL(I) 10 WT(I)=RTOLI*ABS(Y(I))+ATOLI 20 CONTINUE RETURN C-----------END OF SUBROUTINE DDAWTS------------------------------------ END DOUBLE PRECISION FUNCTION DDANRM (NEQ, V, WT, RPAR, IPAR) C***BEGIN PROLOGUE DDANRM C***SUBSIDIARY C***PURPOSE Compute vector norm for DDASSL. C***LIBRARY SLATEC (DASSL) C***TYPE DOUBLE PRECISION (SDANRM-S, DDANRM-D) C***AUTHOR PETZOLD, LINDA R., (LLNL) C***DESCRIPTION C----------------------------------------------------------------------- C THIS FUNCTION ROUTINE COMPUTES THE WEIGHTED C ROOT-MEAN-SQUARE NORM OF THE VECTOR OF LENGTH C NEQ CONTAINED IN THE ARRAY V,WITH WEIGHTS C CONTAINED IN THE ARRAY WT OF LENGTH NEQ. C DDANRM=SQRT((1/NEQ)*SUM(V(I)/WT(I))**2) C----------------------------------------------------------------------- C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 830315 DATE WRITTEN C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. C 901026 Added explicit declarations for all variables and minor C cosmetic changes to prologue. (FNF) C***END PROLOGUE DDANRM C INTEGER NEQ, IPAR(*) DOUBLE PRECISION V(NEQ), WT(NEQ), RPAR(*) C INTEGER I DOUBLE PRECISION SUM, VMAX C C***FIRST EXECUTABLE STATEMENT DDANRM DDANRM = 0.0D0 VMAX = 0.0D0 DO 10 I = 1,NEQ IF(ABS(V(I)/WT(I)) .GT. VMAX) VMAX = ABS(V(I)/WT(I)) 10 CONTINUE IF(VMAX .LE. 0.0D0) GO TO 30 SUM = 0.0D0 DO 20 I = 1,NEQ 20 SUM = SUM + ((V(I)/WT(I))/VMAX)**2 DDANRM = VMAX*SQRT(SUM/NEQ) 30 CONTINUE RETURN C------END OF FUNCTION DDANRM------ END SUBROUTINE DDAINI (X, Y, YPRIME, NEQ, RES, JAC, H, WT, IDID, RPAR, + IPAR, PHI, DELTA, E, WM, IWM, HMIN, UROUND, NONNEG, NTEMP) C***BEGIN PROLOGUE DDAINI C***SUBSIDIARY C***PURPOSE Initialization routine for DDASSL. C***LIBRARY SLATEC (DASSL) C***TYPE DOUBLE PRECISION (SDAINI-S, DDAINI-D) C***AUTHOR PETZOLD, LINDA R., (LLNL) C***DESCRIPTION C----------------------------------------------------------------- C DDAINI TAKES ONE STEP OF SIZE H OR SMALLER C WITH THE BACKWARD EULER METHOD, TO C FIND YPRIME. X AND Y ARE UPDATED TO BE CONSISTENT WITH THE C NEW STEP. A MODIFIED DAMPED NEWTON ITERATION IS USED TO C SOLVE THE CORRECTOR ITERATION. C C THE INITIAL GUESS FOR YPRIME IS USED IN THE C PREDICTION, AND IN FORMING THE ITERATION C MATRIX, BUT IS NOT INVOLVED IN THE C ERROR TEST. THIS MAY HAVE TROUBLE C CONVERGING IF THE INITIAL GUESS IS NO C GOOD, OR IF G(X,Y,YPRIME) DEPENDS C NONLINEARLY ON YPRIME. C C THE PARAMETERS REPRESENT: C X -- INDEPENDENT VARIABLE C Y -- SOLUTION VECTOR AT X C YPRIME -- DERIVATIVE OF SOLUTION VECTOR C NEQ -- NUMBER OF EQUATIONS C H -- STEPSIZE. IMDER MAY USE A STEPSIZE C SMALLER THAN H. C WT -- VECTOR OF WEIGHTS FOR ERROR C CRITERION C IDID -- COMPLETION CODE WITH THE FOLLOWING MEANINGS C IDID= 1 -- YPRIME WAS FOUND SUCCESSFULLY C IDID=-12 -- DDAINI FAILED TO FIND YPRIME C RPAR,IPAR -- REAL AND INTEGER PARAMETER ARRAYS C THAT ARE NOT ALTERED BY DDAINI C PHI -- WORK SPACE FOR DDAINI C DELTA,E -- WORK SPACE FOR DDAINI C WM,IWM -- REAL AND INTEGER ARRAYS STORING C MATRIX INFORMATION C C----------------------------------------------------------------- C***ROUTINES CALLED DDAJAC, DDANRM, DDASLV C***REVISION HISTORY (YYMMDD) C 830315 DATE WRITTEN C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. C 901026 Added explicit declarations for all variables and minor C cosmetic changes to prologue. (FNF) C 901030 Minor corrections to declarations. (FNF) C***END PROLOGUE DDAINI C INTEGER NEQ, IDID, IPAR(*), IWM(*), NONNEG, NTEMP DOUBLE PRECISION * X, Y(*), YPRIME(*), H, WT(*), RPAR(*), PHI(NEQ,*), DELTA(*), * E(*), WM(*), HMIN, UROUND EXTERNAL RES, JAC C EXTERNAL DDAJAC, DDANRM, DDASLV DOUBLE PRECISION DDANRM C INTEGER I, IER, IRES, JCALC, LNJE, LNRE, M, MAXIT, MJAC, NCF, * NEF, NSF DOUBLE PRECISION * CJ, DAMP, DELNRM, ERR, OLDNRM, R, RATE, S, XOLD, YNORM LOGICAL CONVGD C PARAMETER (LNRE=12) PARAMETER (LNJE=13) C DATA MAXIT/10/,MJAC/5/ DATA DAMP/0.75D0/ C C C--------------------------------------------------- C BLOCK 1. C INITIALIZATIONS. C--------------------------------------------------- C C***FIRST EXECUTABLE STATEMENT DDAINI IDID=1 NEF=0 NCF=0 NSF=0 XOLD=X YNORM=DDANRM(NEQ,Y,WT,RPAR,IPAR) C C SAVE Y AND YPRIME IN PHI DO 100 I=1,NEQ PHI(I,1)=Y(I) 100 PHI(I,2)=YPRIME(I) C C C---------------------------------------------------- C BLOCK 2. C DO ONE BACKWARD EULER STEP. C---------------------------------------------------- C C SET UP FOR START OF CORRECTOR ITERATION 200 CJ=1.0D0/H X=X+H C C PREDICT SOLUTION AND DERIVATIVE DO 250 I=1,NEQ 250 Y(I)=Y(I)+H*YPRIME(I) C JCALC=-1 M=0 CONVGD=.TRUE. C C C CORRECTOR LOOP. 300 IWM(LNRE)=IWM(LNRE)+1 IRES=0 C CALL RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR) IF (IRES.LT.0) GO TO 430 C C C EVALUATE THE ITERATION MATRIX IF (JCALC.NE.-1) GO TO 310 IWM(LNJE)=IWM(LNJE)+1 JCALC=0 CALL DDAJAC(NEQ,X,Y,YPRIME,DELTA,CJ,H, * IER,WT,E,WM,IWM,RES,IRES, * UROUND,JAC,RPAR,IPAR,NTEMP) C S=1000000.D0 IF (IRES.LT.0) GO TO 430 IF (IER.NE.0) GO TO 430 NSF=0 C C C C MULTIPLY RESIDUAL BY DAMPING FACTOR 310 CONTINUE DO 320 I=1,NEQ 320 DELTA(I)=DELTA(I)*DAMP C C COMPUTE A NEW ITERATE (BACK SUBSTITUTION) C STORE THE CORRECTION IN DELTA C CALL DDASLV(NEQ,DELTA,WM,IWM) C C UPDATE Y AND YPRIME DO 330 I=1,NEQ Y(I)=Y(I)-DELTA(I) 330 YPRIME(I)=YPRIME(I)-CJ*DELTA(I) C C TEST FOR CONVERGENCE OF THE ITERATION. C DELNRM=DDANRM(NEQ,DELTA,WT,RPAR,IPAR) IF (DELNRM.LE.100.D0*UROUND*YNORM) * GO TO 400 C IF (M.GT.0) GO TO 340 OLDNRM=DELNRM GO TO 350 C 340 RATE=(DELNRM/OLDNRM)**(1.0D0/M) IF (RATE.GT.0.90D0) GO TO 430 S=RATE/(1.0D0-RATE) C 350 IF (S*DELNRM .LE. 0.33D0) GO TO 400 C C C THE CORRECTOR HAS NOT YET CONVERGED. UPDATE C M AND AND TEST WHETHER THE MAXIMUM C NUMBER OF ITERATIONS HAVE BEEN TRIED. C EVERY MJAC ITERATIONS, GET A NEW C ITERATION MATRIX. C M=M+1 IF (M.GE.MAXIT) GO TO 430 C IF ((M/MJAC)*MJAC.EQ.M) JCALC=-1 GO TO 300 C C C THE ITERATION HAS CONVERGED. C CHECK NONNEGATIVITY CONSTRAINTS 400 IF (NONNEG.EQ.0) GO TO 450 DO 410 I=1,NEQ 410 DELTA(I)=MIN(Y(I),0.0D0) C DELNRM=DDANRM(NEQ,DELTA,WT,RPAR,IPAR) IF (DELNRM.GT.0.33D0) GO TO 430 C DO 420 I=1,NEQ Y(I)=Y(I)-DELTA(I) 420 YPRIME(I)=YPRIME(I)-CJ*DELTA(I) GO TO 450 C C C EXITS FROM CORRECTOR LOOP. 430 CONVGD=.FALSE. 450 IF (.NOT.CONVGD) GO TO 600 C C C C----------------------------------------------------- C BLOCK 3. C THE CORRECTOR ITERATION CONVERGED. C DO ERROR TEST. C----------------------------------------------------- C DO 510 I=1,NEQ 510 E(I)=Y(I)-PHI(I,1) ERR=DDANRM(NEQ,E,WT,RPAR,IPAR) C IF (ERR.LE.1.0D0) RETURN C C C C-------------------------------------------------------- C BLOCK 4. C THE BACKWARD EULER STEP FAILED. RESTORE X, Y C AND YPRIME TO THEIR ORIGINAL VALUES. C REDUCE STEPSIZE AND TRY AGAIN, IF C POSSIBLE. C--------------------------------------------------------- C 600 CONTINUE X = XOLD DO 610 I=1,NEQ Y(I)=PHI(I,1) 610 YPRIME(I)=PHI(I,2) C IF (CONVGD) GO TO 640 IF (IER.EQ.0) GO TO 620 NSF=NSF+1 H=H*0.25D0 IF (NSF.LT.3.AND.ABS(H).GE.HMIN) GO TO 690 IDID=-12 RETURN 620 IF (IRES.GT.-2) GO TO 630 IDID=-12 RETURN 630 NCF=NCF+1 H=H*0.25D0 IF (NCF.LT.10.AND.ABS(H).GE.HMIN) GO TO 690 IDID=-12 RETURN C 640 NEF=NEF+1 R=0.90D0/(2.0D0*ERR+0.0001D0) R=MAX(0.1D0,MIN(0.5D0,R)) H=H*R IF (ABS(H).GE.HMIN.AND.NEF.LT.10) GO TO 690 IDID=-12 RETURN 690 GO TO 200 C C-------------END OF SUBROUTINE DDAINI---------------------- END SUBROUTINE DDATRP (X, XOUT, YOUT, YPOUT, NEQ, KOLD, PHI, PSI) C***BEGIN PROLOGUE DDATRP C***SUBSIDIARY C***PURPOSE Interpolation routine for DDASSL. C***LIBRARY SLATEC (DASSL) C***TYPE DOUBLE PRECISION (SDATRP-S, DDATRP-D) C***AUTHOR PETZOLD, LINDA R., (LLNL) C***DESCRIPTION C----------------------------------------------------------------------- C THE METHODS IN SUBROUTINE DDASTP USE POLYNOMIALS C TO APPROXIMATE THE SOLUTION. DDATRP APPROXIMATES THE C SOLUTION AND ITS DERIVATIVE AT TIME XOUT BY EVALUATING C ONE OF THESE POLYNOMIALS,AND ITS DERIVATIVE,THERE. C INFORMATION DEFINING THIS POLYNOMIAL IS PASSED FROM C DDASTP, SO DDATRP CANNOT BE USED ALONE. C C THE PARAMETERS ARE: C X THE CURRENT TIME IN THE INTEGRATION. C XOUT THE TIME AT WHICH THE SOLUTION IS DESIRED C YOUT THE INTERPOLATED APPROXIMATION TO Y AT XOUT C (THIS IS OUTPUT) C YPOUT THE INTERPOLATED APPROXIMATION TO YPRIME AT XOUT C (THIS IS OUTPUT) C NEQ NUMBER OF EQUATIONS C KOLD ORDER USED ON LAST SUCCESSFUL STEP C PHI ARRAY OF SCALED DIVIDED DIFFERENCES OF Y C PSI ARRAY OF PAST STEPSIZE HISTORY C----------------------------------------------------------------------- C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 830315 DATE WRITTEN C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. C 901026 Added explicit declarations for all variables and minor C cosmetic changes to prologue. (FNF) C***END PROLOGUE DDATRP C INTEGER NEQ, KOLD DOUBLE PRECISION X, XOUT, YOUT(*), YPOUT(*), PHI(NEQ,*), PSI(*) C INTEGER I, J, KOLDP1 DOUBLE PRECISION C, D, GAMMA, TEMP1 C C***FIRST EXECUTABLE STATEMENT DDATRP KOLDP1=KOLD+1 TEMP1=XOUT-X DO 10 I=1,NEQ YOUT(I)=PHI(I,1) 10 YPOUT(I)=0.0D0 C=1.0D0 D=0.0D0 GAMMA=TEMP1/PSI(1) DO 30 J=2,KOLDP1 D=D*GAMMA+C/PSI(J-1) C=C*GAMMA GAMMA=(TEMP1+PSI(J-1))/PSI(J) DO 20 I=1,NEQ YOUT(I)=YOUT(I)+C*PHI(I,J) 20 YPOUT(I)=YPOUT(I)+D*PHI(I,J) 30 CONTINUE RETURN C C------END OF SUBROUTINE DDATRP------ END SUBROUTINE DDASTP (X, Y, YPRIME, NEQ, RES, JAC, H, WT, JSTART, + IDID, RPAR, IPAR, PHI, DELTA, E, WM, IWM, ALPHA, BETA, GAMMA, + PSI, SIGMA, CJ, CJOLD, HOLD, S, HMIN, UROUND, IPHASE, JCALC, + K, KOLD, NS, NONNEG, NTEMP) C***BEGIN PROLOGUE DDASTP C***SUBSIDIARY C***PURPOSE Perform one step of the DDASSL integration. C***LIBRARY SLATEC (DASSL) C***TYPE DOUBLE PRECISION (SDASTP-S, DDASTP-D) C***AUTHOR PETZOLD, LINDA R., (LLNL) C***DESCRIPTION C----------------------------------------------------------------------- C DDASTP SOLVES A SYSTEM OF DIFFERENTIAL/ C ALGEBRAIC EQUATIONS OF THE FORM C G(X,Y,YPRIME) = 0, FOR ONE STEP (NORMALLY C FROM X TO X+H). C C THE METHODS USED ARE MODIFIED DIVIDED C DIFFERENCE,FIXED LEADING COEFFICIENT C FORMS OF BACKWARD DIFFERENTIATION C FORMULAS. THE CODE ADJUSTS THE STEPSIZE C AND ORDER TO CONTROL THE LOCAL ERROR PER C STEP. C C C THE PARAMETERS REPRESENT C X -- INDEPENDENT VARIABLE C Y -- SOLUTION VECTOR AT X C YPRIME -- DERIVATIVE OF SOLUTION VECTOR C AFTER SUCCESSFUL STEP C NEQ -- NUMBER OF EQUATIONS TO BE INTEGRATED C RES -- EXTERNAL USER-SUPPLIED SUBROUTINE C TO EVALUATE THE RESIDUAL. THE CALL IS C CALL RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR) C X,Y,YPRIME ARE INPUT. DELTA IS OUTPUT. C ON INPUT, IRES=0. RES SHOULD ALTER IRES ONLY C IF IT ENCOUNTERS AN ILLEGAL VALUE OF Y OR A C STOP CONDITION. SET IRES=-1 IF AN INPUT VALUE C OF Y IS ILLEGAL, AND DDASTP WILL TRY TO SOLVE C THE PROBLEM WITHOUT GETTING IRES = -1. IF C IRES=-2, DDASTP RETURNS CONTROL TO THE CALLING C PROGRAM WITH IDID = -11. C JAC -- EXTERNAL USER-SUPPLIED ROUTINE TO EVALUATE C THE ITERATION MATRIX (THIS IS OPTIONAL) C THE CALL IS OF THE FORM C CALL JAC(X,Y,YPRIME,PD,CJ,RPAR,IPAR) C PD IS THE MATRIX OF PARTIAL DERIVATIVES, C PD=DG/DY+CJ*DG/DYPRIME C H -- APPROPRIATE STEP SIZE FOR NEXT STEP. C NORMALLY DETERMINED BY THE CODE C WT -- VECTOR OF WEIGHTS FOR ERROR CRITERION. C JSTART -- INTEGER VARIABLE SET 0 FOR C FIRST STEP, 1 OTHERWISE. C IDID -- COMPLETION CODE WITH THE FOLLOWING MEANINGS: C IDID= 1 -- THE STEP WAS COMPLETED SUCCESSFULLY C IDID=-6 -- THE ERROR TEST FAILED REPEATEDLY C IDID=-7 -- THE CORRECTOR COULD NOT CONVERGE C IDID=-8 -- THE ITERATION MATRIX IS SINGULAR C IDID=-9 -- THE CORRECTOR COULD NOT CONVERGE. C THERE WERE REPEATED ERROR TEST C FAILURES ON THIS STEP. C IDID=-10-- THE CORRECTOR COULD NOT CONVERGE C BECAUSE IRES WAS EQUAL TO MINUS ONE C IDID=-11-- IRES EQUAL TO -2 WAS ENCOUNTERED, C AND CONTROL IS BEING RETURNED TO C THE CALLING PROGRAM C RPAR,IPAR -- REAL AND INTEGER PARAMETER ARRAYS THAT C ARE USED FOR COMMUNICATION BETWEEN THE C CALLING PROGRAM AND EXTERNAL USER ROUTINES C THEY ARE NOT ALTERED BY DDASTP C PHI -- ARRAY OF DIVIDED DIFFERENCES USED BY C DDASTP. THE LENGTH IS NEQ*(K+1),WHERE C K IS THE MAXIMUM ORDER C DELTA,E -- WORK VECTORS FOR DDASTP OF LENGTH NEQ C WM,IWM -- REAL AND INTEGER ARRAYS STORING C MATRIX INFORMATION SUCH AS THE MATRIX C OF PARTIAL DERIVATIVES,PERMUTATION C VECTOR,AND VARIOUS OTHER INFORMATION. C C THE OTHER PARAMETERS ARE INFORMATION C WHICH IS NEEDED INTERNALLY BY DDASTP TO C CONTINUE FROM STEP TO STEP. C C----------------------------------------------------------------------- C***ROUTINES CALLED DDAJAC, DDANRM, DDASLV, DDATRP C***REVISION HISTORY (YYMMDD) C 830315 DATE WRITTEN C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. C 901026 Added explicit declarations for all variables and minor C cosmetic changes to prologue. (FNF) C***END PROLOGUE DDASTP C INTEGER NEQ, JSTART, IDID, IPAR(*), IWM(*), IPHASE, JCALC, K, * KOLD, NS, NONNEG, NTEMP DOUBLE PRECISION * X, Y(*), YPRIME(*), H, WT(*), RPAR(*), PHI(NEQ,*), DELTA(*), * E(*), WM(*), ALPHA(*), BETA(*), GAMMA(*), PSI(*), SIGMA(*), CJ, * CJOLD, HOLD, S, HMIN, UROUND EXTERNAL RES, JAC C EXTERNAL DDAJAC, DDANRM, DDASLV, DDATRP DOUBLE PRECISION DDANRM C INTEGER I, IER, IRES, J, J1, KDIFF, KM1, KNEW, KP1, KP2, LCTF, * LETF, LMXORD, LNJE, LNRE, LNST, M, MAXIT, NCF, NEF, NSF, NSP1 DOUBLE PRECISION * ALPHA0, ALPHAS, CJLAST, CK, DELNRM, ENORM, ERK, ERKM1, * ERKM2, ERKP1, ERR, EST, HNEW, OLDNRM, PNORM, R, RATE, TEMP1, * TEMP2, TERK, TERKM1, TERKM2, TERKP1, XOLD, XRATE LOGICAL CONVGD C PARAMETER (LMXORD=3) PARAMETER (LNST=11) PARAMETER (LNRE=12) PARAMETER (LNJE=13) PARAMETER (LETF=14) PARAMETER (LCTF=15) C DATA MAXIT/4/ DATA XRATE/0.25D0/ C C C C C C----------------------------------------------------------------------- C BLOCK 1. C INITIALIZE. ON THE FIRST CALL,SET C THE ORDER TO 1 AND INITIALIZE C OTHER VARIABLES. C----------------------------------------------------------------------- C C INITIALIZATIONS FOR ALL CALLS C***FIRST EXECUTABLE STATEMENT DDASTP IDID=1 XOLD=X NCF=0 NSF=0 NEF=0 IF(JSTART .NE. 0) GO TO 120 C C IF THIS IS THE FIRST STEP,PERFORM C OTHER INITIALIZATIONS IWM(LETF) = 0 IWM(LCTF) = 0 K=1 KOLD=0 HOLD=0.0D0 JSTART=1 PSI(1)=H CJOLD = 1.0D0/H CJ = CJOLD S = 100.D0 JCALC = -1 DELNRM=1.0D0 IPHASE = 0 NS=0 120 CONTINUE C C C C C C----------------------------------------------------------------------- C BLOCK 2 C COMPUTE COEFFICIENTS OF FORMULAS FOR C THIS STEP. C----------------------------------------------------------------------- 200 CONTINUE KP1=K+1 KP2=K+2 KM1=K-1 XOLD=X IF(H.NE.HOLD.OR.K .NE. KOLD) NS = 0 NS=MIN(NS+1,KOLD+2) NSP1=NS+1 IF(KP1 .LT. NS)GO TO 230 C BETA(1)=1.0D0 ALPHA(1)=1.0D0 TEMP1=H GAMMA(1)=0.0D0 SIGMA(1)=1.0D0 DO 210 I=2,KP1 TEMP2=PSI(I-1) PSI(I-1)=TEMP1 BETA(I)=BETA(I-1)*PSI(I-1)/TEMP2 TEMP1=TEMP2+H ALPHA(I)=H/TEMP1 SIGMA(I)=(I-1)*SIGMA(I-1)*ALPHA(I) GAMMA(I)=GAMMA(I-1)+ALPHA(I-1)/H 210 CONTINUE PSI(KP1)=TEMP1 230 CONTINUE C C COMPUTE ALPHAS, ALPHA0 ALPHAS = 0.0D0 ALPHA0 = 0.0D0 DO 240 I = 1,K ALPHAS = ALPHAS - 1.0D0/I ALPHA0 = ALPHA0 - ALPHA(I) 240 CONTINUE C C COMPUTE LEADING COEFFICIENT CJ CJLAST = CJ CJ = -ALPHAS/H C C COMPUTE VARIABLE STEPSIZE ERROR COEFFICIENT CK CK = ABS(ALPHA(KP1) + ALPHAS - ALPHA0) CK = MAX(CK,ALPHA(KP1)) C C DECIDE WHETHER NEW JACOBIAN IS NEEDED TEMP1 = (1.0D0 - XRATE)/(1.0D0 + XRATE) TEMP2 = 1.0D0/TEMP1 IF (CJ/CJOLD .LT. TEMP1 .OR. CJ/CJOLD .GT. TEMP2) JCALC = -1 IF (CJ .NE. CJLAST) S = 100.D0 C C CHANGE PHI TO PHI STAR IF(KP1 .LT. NSP1) GO TO 280 DO 270 J=NSP1,KP1 DO 260 I=1,NEQ 260 PHI(I,J)=BETA(J)*PHI(I,J) 270 CONTINUE 280 CONTINUE C C UPDATE TIME X=X+H C C C C C C----------------------------------------------------------------------- C BLOCK 3 C PREDICT THE SOLUTION AND DERIVATIVE, C AND SOLVE THE CORRECTOR EQUATION C----------------------------------------------------------------------- C C FIRST,PREDICT THE SOLUTION AND DERIVATIVE 300 CONTINUE DO 310 I=1,NEQ Y(I)=PHI(I,1) 310 YPRIME(I)=0.0D0 DO 330 J=2,KP1 DO 320 I=1,NEQ Y(I)=Y(I)+PHI(I,J) 320 YPRIME(I)=YPRIME(I)+GAMMA(J)*PHI(I,J) 330 CONTINUE PNORM = DDANRM (NEQ,Y,WT,RPAR,IPAR) C C C C SOLVE THE CORRECTOR EQUATION USING A C MODIFIED NEWTON SCHEME. CONVGD= .TRUE. M=0 IWM(LNRE)=IWM(LNRE)+1 IRES = 0 CALL RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR) IF (IRES .LT. 0) GO TO 380 C C C IF INDICATED,REEVALUATE THE C ITERATION MATRIX PD = DG/DY + CJ*DG/DYPRIME C (WHERE G(X,Y,YPRIME)=0). SET C JCALC TO 0 AS AN INDICATOR THAT C THIS HAS BEEN DONE. IF(JCALC .NE. -1)GO TO 340 IWM(LNJE)=IWM(LNJE)+1 JCALC=0 CALL DDAJAC(NEQ,X,Y,YPRIME,DELTA,CJ,H, * IER,WT,E,WM,IWM,RES,IRES,UROUND,JAC,RPAR, * IPAR,NTEMP) CJOLD=CJ S = 100.D0 IF (IRES .LT. 0) GO TO 380 IF(IER .NE. 0)GO TO 380 NSF=0 C C C INITIALIZE THE ERROR ACCUMULATION VECTOR E. 340 CONTINUE DO 345 I=1,NEQ 345 E(I)=0.0D0 C C C CORRECTOR LOOP. 350 CONTINUE C C MULTIPLY RESIDUAL BY TEMP1 TO ACCELERATE CONVERGENCE TEMP1 = 2.0D0/(1.0D0 + CJ/CJOLD) DO 355 I = 1,NEQ 355 DELTA(I) = DELTA(I) * TEMP1 C C COMPUTE A NEW ITERATE (BACK-SUBSTITUTION). C STORE THE CORRECTION IN DELTA. CALL DDASLV(NEQ,DELTA,WM,IWM) C C UPDATE Y,E,AND YPRIME DO 360 I=1,NEQ Y(I)=Y(I)-DELTA(I) E(I)=E(I)-DELTA(I) 360 YPRIME(I)=YPRIME(I)-CJ*DELTA(I) C C TEST FOR CONVERGENCE OF THE ITERATION DELNRM=DDANRM(NEQ,DELTA,WT,RPAR,IPAR) IF (DELNRM .LE. 100.D0*UROUND*PNORM) GO TO 375 IF (M .GT. 0) GO TO 365 OLDNRM = DELNRM GO TO 367 365 RATE = (DELNRM/OLDNRM)**(1.0D0/M) IF (RATE .GT. 0.90D0) GO TO 370 S = RATE/(1.0D0 - RATE) 367 IF (S*DELNRM .LE. 0.33D0) GO TO 375 C C THE CORRECTOR HAS NOT YET CONVERGED. C UPDATE M AND TEST WHETHER THE C MAXIMUM NUMBER OF ITERATIONS HAVE C BEEN TRIED. M=M+1 IF(M.GE.MAXIT)GO TO 370 C C EVALUATE THE RESIDUAL C AND GO BACK TO DO ANOTHER ITERATION IWM(LNRE)=IWM(LNRE)+1 IRES = 0 CALL RES(X,Y,YPRIME,DELTA,IRES, * RPAR,IPAR) IF (IRES .LT. 0) GO TO 380 GO TO 350 C C C THE CORRECTOR FAILED TO CONVERGE IN MAXIT C ITERATIONS. IF THE ITERATION MATRIX C IS NOT CURRENT,RE-DO THE STEP WITH C A NEW ITERATION MATRIX. 370 CONTINUE IF(JCALC.EQ.0)GO TO 380 JCALC=-1 GO TO 300 C C C THE ITERATION HAS CONVERGED. IF NONNEGATIVITY OF SOLUTION IS C REQUIRED, SET THE SOLUTION NONNEGATIVE, IF THE PERTURBATION C TO DO IT IS SMALL ENOUGH. IF THE CHANGE IS TOO LARGE, THEN C CONSIDER THE CORRECTOR ITERATION TO HAVE FAILED. 375 IF(NONNEG .EQ. 0) GO TO 390 DO 377 I = 1,NEQ 377 DELTA(I) = MIN(Y(I),0.0D0) DELNRM = DDANRM(NEQ,DELTA,WT,RPAR,IPAR) IF(DELNRM .GT. 0.33D0) GO TO 380 DO 378 I = 1,NEQ 378 E(I) = E(I) - DELTA(I) GO TO 390 C C C EXITS FROM BLOCK 3 C NO CONVERGENCE WITH CURRENT ITERATION C MATRIX,OR SINGULAR ITERATION MATRIX 380 CONVGD= .FALSE. 390 JCALC = 1 IF(.NOT.CONVGD)GO TO 600 C C C C C C----------------------------------------------------------------------- C BLOCK 4 C ESTIMATE THE ERRORS AT ORDERS K,K-1,K-2 C AS IF CONSTANT STEPSIZE WAS USED. ESTIMATE C THE LOCAL ERROR AT ORDER K AND TEST C WHETHER THE CURRENT STEP IS SUCCESSFUL. C----------------------------------------------------------------------- C C ESTIMATE ERRORS AT ORDERS K,K-1,K-2 ENORM = DDANRM(NEQ,E,WT,RPAR,IPAR) ERK = SIGMA(K+1)*ENORM TERK = (K+1)*ERK EST = ERK KNEW=K IF(K .EQ. 1)GO TO 430 DO 405 I = 1,NEQ 405 DELTA(I) = PHI(I,KP1) + E(I) ERKM1=SIGMA(K)*DDANRM(NEQ,DELTA,WT,RPAR,IPAR) TERKM1 = K*ERKM1 IF(K .GT. 2)GO TO 410 IF(TERKM1 .LE. 0.5D0*TERK)GO TO 420 GO TO 430 410 CONTINUE DO 415 I = 1,NEQ 415 DELTA(I) = PHI(I,K) + DELTA(I) ERKM2=SIGMA(K-1)*DDANRM(NEQ,DELTA,WT,RPAR,IPAR) TERKM2 = (K-1)*ERKM2 IF(MAX(TERKM1,TERKM2).GT.TERK)GO TO 430 C LOWER THE ORDER 420 CONTINUE KNEW=K-1 EST = ERKM1 C C C CALCULATE THE LOCAL ERROR FOR THE CURRENT STEP C TO SEE IF THE STEP WAS SUCCESSFUL 430 CONTINUE ERR = CK * ENORM IF(ERR .GT. 1.0D0)GO TO 600 C C C C C C----------------------------------------------------------------------- C BLOCK 5 C THE STEP IS SUCCESSFUL. DETERMINE C THE BEST ORDER AND STEPSIZE FOR C THE NEXT STEP. UPDATE THE DIFFERENCES C FOR THE NEXT STEP. C----------------------------------------------------------------------- IDID=1 IWM(LNST)=IWM(LNST)+1 KDIFF=K-KOLD KOLD=K HOLD=H C C C ESTIMATE THE ERROR AT ORDER K+1 UNLESS: C ALREADY DECIDED TO LOWER ORDER, OR C ALREADY USING MAXIMUM ORDER, OR C STEPSIZE NOT CONSTANT, OR C ORDER RAISED IN PREVIOUS STEP IF(KNEW.EQ.KM1.OR.K.EQ.IWM(LMXORD))IPHASE=1 IF(IPHASE .EQ. 0)GO TO 545 IF(KNEW.EQ.KM1)GO TO 540 IF(K.EQ.IWM(LMXORD)) GO TO 550 IF(KP1.GE.NS.OR.KDIFF.EQ.1)GO TO 550 DO 510 I=1,NEQ 510 DELTA(I)=E(I)-PHI(I,KP2) ERKP1 = (1.0D0/(K+2))*DDANRM(NEQ,DELTA,WT,RPAR,IPAR) TERKP1 = (K+2)*ERKP1 IF(K.GT.1)GO TO 520 IF(TERKP1.GE.0.5D0*TERK)GO TO 550 GO TO 530 520 IF(TERKM1.LE.MIN(TERK,TERKP1))GO TO 540 IF(TERKP1.GE.TERK.OR.K.EQ.IWM(LMXORD))GO TO 550 C C RAISE ORDER 530 K=KP1 EST = ERKP1 GO TO 550 C C LOWER ORDER 540 K=KM1 EST = ERKM1 GO TO 550 C C IF IPHASE = 0, INCREASE ORDER BY ONE AND MULTIPLY STEPSIZE BY C FACTOR TWO 545 K = KP1 HNEW = H*2.0D0 H = HNEW GO TO 575 C C C DETERMINE THE APPROPRIATE STEPSIZE FOR C THE NEXT STEP. 550 HNEW=H TEMP2=K+1 R=(2.0D0*EST+0.0001D0)**(-1.0D0/TEMP2) IF(R .LT. 2.0D0) GO TO 555 HNEW = 2.0D0*H GO TO 560 555 IF(R .GT. 1.0D0) GO TO 560 R = MAX(0.5D0,MIN(0.9D0,R)) HNEW = H*R 560 H=HNEW C C C UPDATE DIFFERENCES FOR NEXT STEP 575 CONTINUE IF(KOLD.EQ.IWM(LMXORD))GO TO 585 DO 580 I=1,NEQ 580 PHI(I,KP2)=E(I) 585 CONTINUE DO 590 I=1,NEQ 590 PHI(I,KP1)=PHI(I,KP1)+E(I) DO 595 J1=2,KP1 J=KP1-J1+1 DO 595 I=1,NEQ 595 PHI(I,J)=PHI(I,J)+PHI(I,J+1) RETURN C C C C C C----------------------------------------------------------------------- C BLOCK 6 C THE STEP IS UNSUCCESSFUL. RESTORE X,PSI,PHI C DETERMINE APPROPRIATE STEPSIZE FOR C CONTINUING THE INTEGRATION, OR EXIT WITH C AN ERROR FLAG IF THERE HAVE BEEN MANY C FAILURES. C----------------------------------------------------------------------- 600 IPHASE = 1 C C RESTORE X,PHI,PSI X=XOLD IF(KP1.LT.NSP1)GO TO 630 DO 620 J=NSP1,KP1 TEMP1=1.0D0/BETA(J) DO 610 I=1,NEQ 610 PHI(I,J)=TEMP1*PHI(I,J) 620 CONTINUE 630 CONTINUE DO 640 I=2,KP1 640 PSI(I-1)=PSI(I)-H C C C TEST WHETHER FAILURE IS DUE TO CORRECTOR ITERATION C OR ERROR TEST IF(CONVGD)GO TO 660 IWM(LCTF)=IWM(LCTF)+1 C C C THE NEWTON ITERATION FAILED TO CONVERGE WITH C A CURRENT ITERATION MATRIX. DETERMINE THE CAUSE C OF THE FAILURE AND TAKE APPROPRIATE ACTION. IF(IER.EQ.0)GO TO 650 C C THE ITERATION MATRIX IS SINGULAR. REDUCE C THE STEPSIZE BY A FACTOR OF 4. IF C THIS HAPPENS THREE TIMES IN A ROW ON C THE SAME STEP, RETURN WITH AN ERROR FLAG NSF=NSF+1 R = 0.25D0 H=H*R IF (NSF .LT. 3 .AND. ABS(H) .GE. HMIN) GO TO 690 IDID=-8 GO TO 675 C C C THE NEWTON ITERATION FAILED TO CONVERGE FOR A REASON C OTHER THAN A SINGULAR ITERATION MATRIX. IF IRES = -2, THEN C RETURN. OTHERWISE, REDUCE THE STEPSIZE AND TRY AGAIN, UNLESS C TOO MANY FAILURES HAVE OCCURED. 650 CONTINUE IF (IRES .GT. -2) GO TO 655 IDID = -11 GO TO 675 655 NCF = NCF + 1 R = 0.25D0 H = H*R IF (NCF .LT. 10 .AND. ABS(H) .GE. HMIN) GO TO 690 IDID = -7 IF (IRES .LT. 0) IDID = -10 IF (NEF .GE. 3) IDID = -9 GO TO 675 C C C THE NEWTON SCHEME CONVERGED,AND THE CAUSE C OF THE FAILURE WAS THE ERROR ESTIMATE C EXCEEDING THE TOLERANCE. 660 NEF=NEF+1 IWM(LETF)=IWM(LETF)+1 IF (NEF .GT. 1) GO TO 665 C C ON FIRST ERROR TEST FAILURE, KEEP CURRENT ORDER OR LOWER C ORDER BY ONE. COMPUTE NEW STEPSIZE BASED ON DIFFERENCES C OF THE SOLUTION. K = KNEW TEMP2 = K + 1 R = 0.90D0*(2.0D0*EST+0.0001D0)**(-1.0D0/TEMP2) R = MAX(0.25D0,MIN(0.9D0,R)) H = H*R IF (ABS(H) .GE. HMIN) GO TO 690 IDID = -6 GO TO 675 C C ON SECOND ERROR TEST FAILURE, USE THE CURRENT ORDER OR C DECREASE ORDER BY ONE. REDUCE THE STEPSIZE BY A FACTOR OF C FOUR. 665 IF (NEF .GT. 2) GO TO 670 K = KNEW H = 0.25D0*H IF (ABS(H) .GE. HMIN) GO TO 690 IDID = -6 GO TO 675 C C ON THIRD AND SUBSEQUENT ERROR TEST FAILURES, SET THE ORDER TO C ONE AND REDUCE THE STEPSIZE BY A FACTOR OF FOUR. 670 K = 1 H = 0.25D0*H IF (ABS(H) .GE. HMIN) GO TO 690 IDID = -6 GO TO 675 C C C C C FOR ALL CRASHES, RESTORE Y TO ITS LAST VALUE, C INTERPOLATE TO FIND YPRIME AT LAST X, AND RETURN 675 CONTINUE CALL DDATRP(X,X,Y,YPRIME,NEQ,K,PHI,PSI) RETURN C C C GO BACK AND TRY THIS STEP AGAIN 690 GO TO 200 C C------END OF SUBROUTINE DDASTP------ END SUBROUTINE DDAJAC (NEQ, X, Y, YPRIME, DELTA, CJ, H, + IER, WT, E, WM, IWM, RES, IRES, UROUND, JAC, RPAR, + IPAR, NTEMP) C***BEGIN PROLOGUE DDAJAC C***SUBSIDIARY C***PURPOSE Compute the iteration matrix for DDASSL and form the C LU-decomposition. C***LIBRARY SLATEC (DASSL) C***TYPE DOUBLE PRECISION (SDAJAC-S, DDAJAC-D) C***AUTHOR PETZOLD, LINDA R., (LLNL) C***DESCRIPTION C----------------------------------------------------------------------- C THIS ROUTINE COMPUTES THE ITERATION MATRIX C PD=DG/DY+CJ*DG/DYPRIME (WHERE G(X,Y,YPRIME)=0). C HERE PD IS COMPUTED BY THE USER-SUPPLIED C ROUTINE JAC IF IWM(MTYPE) IS 1 OR 4, AND C IT IS COMPUTED BY NUMERICAL FINITE DIFFERENCING C IF IWM(MTYPE)IS 2 OR 5 C THE PARAMETERS HAVE THE FOLLOWING MEANINGS. C Y = ARRAY CONTAINING PREDICTED VALUES C YPRIME = ARRAY CONTAINING PREDICTED DERIVATIVES C DELTA = RESIDUAL EVALUATED AT (X,Y,YPRIME) C (USED ONLY IF IWM(MTYPE)=2 OR 5) C CJ = SCALAR PARAMETER DEFINING ITERATION MATRIX C H = CURRENT STEPSIZE IN INTEGRATION C IER = VARIABLE WHICH IS .NE. 0 C IF ITERATION MATRIX IS SINGULAR, C AND 0 OTHERWISE. C WT = VECTOR OF WEIGHTS FOR COMPUTING NORMS C E = WORK SPACE (TEMPORARY) OF LENGTH NEQ C WM = REAL WORK SPACE FOR MATRICES. ON C OUTPUT IT CONTAINS THE LU DECOMPOSITION C OF THE ITERATION MATRIX. C IWM = INTEGER WORK SPACE CONTAINING C MATRIX INFORMATION C RES = NAME OF THE EXTERNAL USER-SUPPLIED ROUTINE C TO EVALUATE THE RESIDUAL FUNCTION G(X,Y,YPRIME) C IRES = FLAG WHICH IS EQUAL TO ZERO IF NO ILLEGAL VALUES C IN RES, AND LESS THAN ZERO OTHERWISE. (IF IRES C IS LESS THAN ZERO, THE MATRIX WAS NOT COMPLETED) C IN THIS CASE (IF IRES .LT. 0), THEN IER = 0. C UROUND = THE UNIT ROUNDOFF ERROR OF THE MACHINE BEING USED. C JAC = NAME OF THE EXTERNAL USER-SUPPLIED ROUTINE C TO EVALUATE THE ITERATION MATRIX (THIS ROUTINE C IS ONLY USED IF IWM(MTYPE) IS 1 OR 4) C----------------------------------------------------------------------- C***ROUTINES CALLED DGBFA, DGEFA C***REVISION HISTORY (YYMMDD) C 830315 DATE WRITTEN C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) C 901010 Modified three MAX calls to be all on one line. (FNF) C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. C 901026 Added explicit declarations for all variables and minor C cosmetic changes to prologue. (FNF) C 901101 Corrected PURPOSE. (FNF) C***END PROLOGUE DDAJAC C INTEGER NEQ, IER, IWM(*), IRES, IPAR(*), NTEMP DOUBLE PRECISION * X, Y(*), YPRIME(*), DELTA(*), CJ, H, WT(*), E(*), WM(*), * UROUND, RPAR(*) EXTERNAL RES, JAC C EXTERNAL DGBFA, DGEFA C INTEGER I, I1, I2, II, IPSAVE, ISAVE, J, K, L, LENPD, LIPVT, * LML, LMTYPE, LMU, MBA, MBAND, MEB1, MEBAND, MSAVE, MTYPE, N, * NPD, NPDM1, NROW DOUBLE PRECISION DEL, DELINV, SQUR, YPSAVE, YSAVE C PARAMETER (NPD=1) PARAMETER (LML=1) PARAMETER (LMU=2) PARAMETER (LMTYPE=4) PARAMETER (LIPVT=21) C C***FIRST EXECUTABLE STATEMENT DDAJAC IER = 0 NPDM1=NPD-1 MTYPE=IWM(LMTYPE) GO TO (100,200,300,400,500),MTYPE C C C DENSE USER-SUPPLIED MATRIX 100 LENPD=NEQ*NEQ DO 110 I=1,LENPD 110 WM(NPDM1+I)=0.0D0 CALL JAC(X,Y,YPRIME,WM(NPD),CJ,RPAR,IPAR) GO TO 230 C C C DENSE FINITE-DIFFERENCE-GENERATED MATRIX 200 IRES=0 NROW=NPDM1 SQUR = SQRT(UROUND) DO 210 I=1,NEQ DEL=SQUR*MAX(ABS(Y(I)),ABS(H*YPRIME(I)),ABS(WT(I))) DEL=SIGN(DEL,H*YPRIME(I)) DEL=(Y(I)+DEL)-Y(I) YSAVE=Y(I) YPSAVE=YPRIME(I) Y(I)=Y(I)+DEL YPRIME(I)=YPRIME(I)+CJ*DEL CALL RES(X,Y,YPRIME,E,IRES,RPAR,IPAR) IF (IRES .LT. 0) RETURN DELINV=1.0D0/DEL DO 220 L=1,NEQ 220 WM(NROW+L)=(E(L)-DELTA(L))*DELINV NROW=NROW+NEQ Y(I)=YSAVE YPRIME(I)=YPSAVE 210 CONTINUE C C C DO DENSE-MATRIX LU DECOMPOSITION ON PD 230 CALL DGEFA(WM(NPD),NEQ,NEQ,IWM(LIPVT),IER) RETURN C C C DUMMY SECTION FOR IWM(MTYPE)=3 300 RETURN C C C BANDED USER-SUPPLIED MATRIX 400 LENPD=(2*IWM(LML)+IWM(LMU)+1)*NEQ DO 410 I=1,LENPD 410 WM(NPDM1+I)=0.0D0 CALL JAC(X,Y,YPRIME,WM(NPD),CJ,RPAR,IPAR) MEBAND=2*IWM(LML)+IWM(LMU)+1 GO TO 550 C C C BANDED FINITE-DIFFERENCE-GENERATED MATRIX 500 MBAND=IWM(LML)+IWM(LMU)+1 MBA=MIN(MBAND,NEQ) MEBAND=MBAND+IWM(LML) MEB1=MEBAND-1 MSAVE=(NEQ/MBAND)+1 ISAVE=NTEMP-1 IPSAVE=ISAVE+MSAVE IRES=0 SQUR=SQRT(UROUND) DO 540 J=1,MBA DO 510 N=J,NEQ,MBAND K= (N-J)/MBAND + 1 WM(ISAVE+K)=Y(N) WM(IPSAVE+K)=YPRIME(N) DEL=SQUR*MAX(ABS(Y(N)),ABS(H*YPRIME(N)),ABS(WT(N))) DEL=SIGN(DEL,H*YPRIME(N)) DEL=(Y(N)+DEL)-Y(N) Y(N)=Y(N)+DEL 510 YPRIME(N)=YPRIME(N)+CJ*DEL CALL RES(X,Y,YPRIME,E,IRES,RPAR,IPAR) IF (IRES .LT. 0) RETURN DO 530 N=J,NEQ,MBAND K= (N-J)/MBAND + 1 Y(N)=WM(ISAVE+K) YPRIME(N)=WM(IPSAVE+K) DEL=SQUR*MAX(ABS(Y(N)),ABS(H*YPRIME(N)),ABS(WT(N))) DEL=SIGN(DEL,H*YPRIME(N)) DEL=(Y(N)+DEL)-Y(N) DELINV=1.0D0/DEL I1=MAX(1,(N-IWM(LMU))) I2=MIN(NEQ,(N+IWM(LML))) II=N*MEB1-IWM(LML)+NPDM1 DO 520 I=I1,I2 520 WM(II+I)=(E(I)-DELTA(I))*DELINV 530 CONTINUE 540 CONTINUE C C C DO LU DECOMPOSITION OF BANDED PD 550 CALL DGBFA(WM(NPD),MEBAND,NEQ, * IWM(LML),IWM(LMU),IWM(LIPVT),IER) RETURN C------END OF SUBROUTINE DDAJAC------ END SUBROUTINE DDASLV (NEQ, DELTA, WM, IWM) C***BEGIN PROLOGUE DDASLV C***SUBSIDIARY C***PURPOSE Linear system solver for DDASSL. C***LIBRARY SLATEC (DASSL) C***TYPE DOUBLE PRECISION (SDASLV-S, DDASLV-D) C***AUTHOR PETZOLD, LINDA R., (LLNL) C***DESCRIPTION C----------------------------------------------------------------------- C THIS ROUTINE MANAGES THE SOLUTION OF THE LINEAR C SYSTEM ARISING IN THE NEWTON ITERATION. C MATRICES AND REAL TEMPORARY STORAGE AND C REAL INFORMATION ARE STORED IN THE ARRAY WM. C INTEGER MATRIX INFORMATION IS STORED IN C THE ARRAY IWM. C FOR A DENSE MATRIX, THE LINPACK ROUTINE C DGESL IS CALLED. C FOR A BANDED MATRIX,THE LINPACK ROUTINE C DGBSL IS CALLED. C----------------------------------------------------------------------- C***ROUTINES CALLED DGBSL, DGESL C***REVISION HISTORY (YYMMDD) C 830315 DATE WRITTEN C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. C 901026 Added explicit declarations for all variables and minor C cosmetic changes to prologue. (FNF) C***END PROLOGUE DDASLV C INTEGER NEQ, IWM(*) DOUBLE PRECISION DELTA(*), WM(*) C EXTERNAL DGBSL, DGESL C INTEGER LIPVT, LML, LMU, LMTYPE, MEBAND, MTYPE, NPD PARAMETER (NPD=1) PARAMETER (LML=1) PARAMETER (LMU=2) PARAMETER (LMTYPE=4) PARAMETER (LIPVT=21) C C***FIRST EXECUTABLE STATEMENT DDASLV MTYPE=IWM(LMTYPE) GO TO(100,100,300,400,400),MTYPE C C DENSE MATRIX 100 CALL DGESL(WM(NPD),NEQ,NEQ,IWM(LIPVT),DELTA,0) RETURN C C DUMMY SECTION FOR MTYPE=3 300 CONTINUE RETURN C C BANDED MATRIX 400 MEBAND=2*IWM(LML)+IWM(LMU)+1 CALL DGBSL(WM(NPD),MEBAND,NEQ,IWM(LML), * IWM(LMU),IWM(LIPVT),DELTA,0) RETURN C------END OF SUBROUTINE DDASLV------ END C*DECK XERMSG SUBROUTINE XERMSG (LIBRAR, SUBROU, MESSG, NERR, LEVEL) C***BEGIN PROLOGUE XERMSG C***PURPOSE Processes error messages for SLATEC and other libraries C***LIBRARY SLATEC C***CATEGORY R3C C***TYPE ALL C***KEYWORDS ERROR MESSAGE, XERROR C***AUTHOR FONG, KIRBY, (NMFECC AT LLNL) C Modified by C FRITSCH, F. N., (LLNL) C***DESCRIPTION C C XERMSG processes a diagnostic message in a manner determined by the C value of LEVEL and the current value of the library error control C flag, KONTRL. See subroutine XSETF for details. C (XSETF is inoperable in this version.). C C LIBRAR A character constant (or character variable) with the name C of the library. This will be 'SLATEC' for the SLATEC C Common Math Library. The error handling package is C general enough to be used by many libraries C simultaneously, so it is desirable for the routine that C detects and reports an error to identify the library name C as well as the routine name. C C SUBROU A character constant (or character variable) with the name C of the routine that detected the error. Usually it is the C name of the routine that is calling XERMSG. There are C some instances where a user callable library routine calls C lower level subsidiary routines where the error is C detected. In such cases it may be more informative to C supply the name of the routine the user called rather than C the name of the subsidiary routine that detected the C error. C C MESSG A character constant (or character variable) with the text C of the error or warning message. In the example below, C the message is a character constant that contains a C generic message. C C CALL XERMSG ('SLATEC', 'MMPY', C *'THE ORDER OF THE MATRIX EXCEEDS THE ROW DIMENSION', C *3, 1) C C It is possible (and is sometimes desirable) to generate a C specific message--e.g., one that contains actual numeric C values. Specific numeric values can be converted into C character strings using formatted WRITE statements into C character variables. This is called standard Fortran C internal file I/O and is exemplified in the first three C lines of the following example. You can also catenate C substrings of characters to construct the error message. C Here is an example showing the use of both writing to C an internal file and catenating character strings. C C CHARACTER*5 CHARN, CHARL C WRITE (CHARN,10) N C WRITE (CHARL,10) LDA C 10 FORMAT(I5) C CALL XERMSG ('SLATEC', 'MMPY', 'THE ORDER'//CHARN// C * ' OF THE MATRIX EXCEEDS ITS ROW DIMENSION OF'// C * CHARL, 3, 1) C C There are two subtleties worth mentioning. One is that C the // for character catenation is used to construct the C error message so that no single character constant is C continued to the next line. This avoids confusion as to C whether there are trailing blanks at the end of the line. C The second is that by catenating the parts of the message C as an actual argument rather than encoding the entire C message into one large character variable, we avoid C having to know how long the message will be in order to C declare an adequate length for that large character C variable. XERMSG calls XERPRN to print the message using C multiple lines if necessary. If the message is very long, C XERPRN will break it into pieces of 72 characters (as C requested by XERMSG) for printing on multiple lines. C Also, XERMSG asks XERPRN to prefix each line with ' * ' C so that the total line length could be 76 characters. C Note also that XERPRN scans the error message backwards C to ignore trailing blanks. Another feature is that C the substring '$$' is treated as a new line sentinel C by XERPRN. If you want to construct a multiline C message without having to count out multiples of 72 C characters, just use '$$' as a separator. '$$' C obviously must occur within 72 characters of the C start of each line to have its intended effect since C XERPRN is asked to wrap around at 72 characters in C addition to looking for '$$'. C C NERR An integer value that is chosen by the library routine's C author. It must be in the range -9999999 to 99999999 (8 C printable digits). Each distinct error should have its C own error number. These error numbers should be described C in the machine readable documentation for the routine. C The error numbers need be unique only within each routine, C so it is reasonable for each routine to start enumerating C errors from 1 and proceeding to the next integer. C C LEVEL An integer value in the range 0 to 2 that indicates the C level (severity) of the error. Their meanings are C C -1 A warning message. This is used if it is not clear C that there really is an error, but the user's attention C may be needed. An attempt is made to only print this C message once. C C 0 A warning message. This is used if it is not clear C that there really is an error, but the user's attention C may be needed. C C 1 A recoverable error. This is used even if the error is C so serious that the routine cannot return any useful C answer. If the user has told the error package to C return after recoverable errors, then XERMSG will C return to the Library routine which can then return to C the user's routine. The user may also permit the error C package to terminate the program upon encountering a C recoverable error. C C 2 A fatal error. XERMSG will not return to its caller C after it receives a fatal error. This level should C hardly ever be used; it is much better to allow the C user a chance to recover. An example of one of the few C cases in which it is permissible to declare a level 2 C error is a reverse communication Library routine that C is likely to be called repeatedly until it integrates C across some interval. If there is a serious error in C the input such that another step cannot be taken and C the Library routine is called again without the input C error having been corrected by the caller, the Library C routine will probably be called forever with improper C input. In this case, it is reasonable to declare the C error to be fatal. C C Each of the arguments to XERMSG is input; none will be modified by C XERMSG. A routine may make multiple calls to XERMSG with warning C level messages; however, after a call to XERMSG with a recoverable C error, the routine should return to the user. C C***REFERENCES JONES, RONDALL E. AND KAHANER, DAVID K., "XERROR, THE C SLATEC ERROR-HANDLING PACKAGE", SOFTWARE - PRACTICE C AND EXPERIENCE, VOLUME 13, NO. 3, PP. 251-257, C MARCH, 1983. C***ROUTINES CALLED XERHLT, XERPRN C***REVISION HISTORY (YYMMDD) C 880101 DATE WRITTEN C 880621 REVISED AS DIRECTED AT SLATEC CML MEETING OF FEBRUARY 1988. C THERE ARE TWO BASIC CHANGES. C 1. A NEW ROUTINE, XERPRN, IS USED INSTEAD OF XERPRT TO C PRINT MESSAGES. THIS ROUTINE WILL BREAK LONG MESSAGES C INTO PIECES FOR PRINTING ON MULTIPLE LINES. '$$' IS C ACCEPTED AS A NEW LINE SENTINEL. A PREFIX CAN BE C ADDED TO EACH LINE TO BE PRINTED. XERMSG USES EITHER C ' ***' OR ' * ' AND LONG MESSAGES ARE BROKEN EVERY C 72 CHARACTERS (AT MOST) SO THAT THE MAXIMUM LINE C LENGTH OUTPUT CAN NOW BE AS GREAT AS 76. C 2. THE TEXT OF ALL MESSAGES IS NOW IN UPPER CASE SINCE THE C FORTRAN STANDARD DOCUMENT DOES NOT ADMIT THE EXISTENCE C OF LOWER CASE. C 880708 REVISED AFTER THE SLATEC CML MEETING OF JUNE 29 AND 30. C THE PRINCIPAL CHANGES ARE C 1. CLARIFY COMMENTS IN THE PROLOGUES C 2. RENAME XRPRNT TO XERPRN C 3. REWORK HANDLING OF '$$' IN XERPRN TO HANDLE BLANK LINES C SIMILAR TO THE WAY FORMAT STATEMENTS HANDLE THE / C CHARACTER FOR NEW RECORDS. C 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO C CLEAN UP THE CODING. C 890721 REVISED TO USE NEW FEATURE IN XERPRN TO COUNT CHARACTERS IN C PREFIX. C 891013 REVISED TO CORRECT COMMENTS. C 891214 Prologue converted to Version 4.0 format. (WRB) C 900510 Changed test on NERR to be -9999999 < NERR < 99999999, but C NERR .ne. 0, and on LEVEL to be -2 < LEVEL < 3. Added C LEVEL=-1 logic, changed calls to XERSAV to XERSVE, and C XERCTL to XERCNT. (RWC) C 901011 Removed error saving features to produce a simplified C version for distribution with DASSL and other LLNL codes. C (FNF) C***END PROLOGUE XERMSG CHARACTER*(*) LIBRAR, SUBROU, MESSG CHARACTER*72 TEMP C***FIRST EXECUTABLE STATEMENT XERMSG C C WE PRINT A FATAL ERROR MESSAGE AND TERMINATE FOR AN ERROR IN C CALLING XERMSG. THE ERROR NUMBER SHOULD BE POSITIVE, C AND THE LEVEL SHOULD BE BETWEEN 0 AND 2. C IF (NERR.LT.-9999999 .OR. NERR.GT.99999999 .OR. NERR.EQ.0 .OR. * LEVEL.LT.-1 .OR. LEVEL.GT.2) THEN CALL XERPRN (' ***', -1, 'FATAL ERROR IN...$$ ' // * 'XERMSG -- INVALID ERROR NUMBER OR LEVEL$$ '// * 'JOB ABORT DUE TO FATAL ERROR.', 72) CALL XERHLT (' ***XERMSG -- INVALID INPUT') RETURN ENDIF C C SET DEFAULT VALUES FOR CONTROL PARAMETERS. C LKNTRL = 1 MKNTRL = 1 C C ANNOUNCE THE NAMES OF THE LIBRARY AND SUBROUTINE BY BUILDING A C MESSAGE IN CHARACTER VARIABLE TEMP (NOT EXCEEDING 66 CHARACTERS) C AND SENDING IT OUT VIA XERPRN. PRINT ONLY IF CONTROL FLAG C IS NOT ZERO. C IF (LKNTRL .NE. 0) THEN TEMP(1:21) = 'MESSAGE FROM ROUTINE ' I = MIN(LEN(SUBROU), 16) TEMP(22:21+I) = SUBROU(1:I) TEMP(22+I:33+I) = ' IN LIBRARY ' LTEMP = 33 + I I = MIN(LEN(LIBRAR), 16) TEMP(LTEMP+1:LTEMP+I) = LIBRAR (1:I) TEMP(LTEMP+I+1:LTEMP+I+1) = '.' LTEMP = LTEMP + I + 1 CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72) ENDIF C C IF LKNTRL IS POSITIVE, PRINT AN INTRODUCTORY LINE BEFORE C PRINTING THE MESSAGE. THE INTRODUCTORY LINE TELLS THE CHOICE C FROM EACH OF THE FOLLOWING TWO OPTIONS. C 1. LEVEL OF THE MESSAGE C 'INFORMATIVE MESSAGE' C 'POTENTIALLY RECOVERABLE ERROR' C 'FATAL ERROR' C 2. WHETHER CONTROL FLAG WILL ALLOW PROGRAM TO CONTINUE C 'PROGRAM CONTINUES' C 'PROGRAM ABORTED' C NOTICE THAT THE LINE INCLUDING FOUR PREFIX CHARACTERS WILL NOT C EXCEED 74 CHARACTERS. C WE SKIP THE NEXT BLOCK IF THE INTRODUCTORY LINE IS NOT NEEDED. C IF (LKNTRL .GT. 0) THEN C C THE FIRST PART OF THE MESSAGE TELLS ABOUT THE LEVEL. C IF (LEVEL .LE. 0) THEN TEMP(1:20) = 'INFORMATIVE MESSAGE,' LTEMP = 20 ELSEIF (LEVEL .EQ. 1) THEN TEMP(1:30) = 'POTENTIALLY RECOVERABLE ERROR,' LTEMP = 30 ELSE TEMP(1:12) = 'FATAL ERROR,' LTEMP = 12 ENDIF C C THEN WHETHER THE PROGRAM WILL CONTINUE. C IF ((MKNTRL.EQ.2 .AND. LEVEL.GE.1) .OR. * (MKNTRL.EQ.1 .AND. LEVEL.EQ.2)) THEN TEMP(LTEMP+1:LTEMP+17) = ' PROGRAM ABORTED.' LTEMP = LTEMP + 17 ELSE TEMP(LTEMP+1:LTEMP+19) = ' PROGRAM CONTINUES.' LTEMP = LTEMP + 19 ENDIF C CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72) ENDIF C C NOW SEND OUT THE MESSAGE. C CALL XERPRN (' * ', -1, MESSG, 72) C C IF LKNTRL IS POSITIVE, WRITE THE ERROR NUMBER. C IF (LKNTRL .GT. 0) THEN WRITE (TEMP, '(''ERROR NUMBER = '', I8)') NERR DO 10 I=16,22 IF (TEMP(I:I) .NE. ' ') GO TO 20 10 CONTINUE C 20 CALL XERPRN (' * ', -1, TEMP(1:15) // TEMP(I:23), 72) ENDIF C C IF LKNTRL IS NOT ZERO, PRINT A BLANK LINE AND AN END OF MESSAGE. C IF (LKNTRL .NE. 0) THEN CALL XERPRN (' * ', -1, ' ', 72) CALL XERPRN (' ***', -1, 'END OF MESSAGE', 72) CALL XERPRN (' ', 0, ' ', 72) ENDIF C C IF THE ERROR IS NOT FATAL OR THE ERROR IS RECOVERABLE AND THE C CONTROL FLAG IS SET FOR RECOVERY, THEN RETURN. C 30 IF (LEVEL.LE.0 .OR. (LEVEL.EQ.1 .AND. MKNTRL.LE.1)) RETURN C C THE PROGRAM WILL BE STOPPED DUE TO AN UNRECOVERED ERROR OR A C FATAL ERROR. PRINT THE REASON FOR THE ABORT AND THE ERROR C SUMMARY IF THE CONTROL FLAG AND THE MAXIMUM ERROR COUNT PERMIT. C IF (LKNTRL.GT.0) THEN IF (LEVEL .EQ. 1) THEN CALL XERPRN * (' ***', -1, 'JOB ABORT DUE TO UNRECOVERED ERROR.', 72) ELSE CALL XERPRN(' ***', -1, 'JOB ABORT DUE TO FATAL ERROR.', 72) ENDIF CALL XERHLT (' ') ENDIF RETURN END SUBROUTINE XERHLT (MESSG) C***BEGIN PROLOGUE XERHLT C***SUBSIDIARY C***PURPOSE Abort program execution and print error message. C***LIBRARY SLATEC (XERROR) C***CATEGORY R3C C***TYPE ALL (XERHLT-A) C***KEYWORDS ERROR, XERROR C***AUTHOR JONES, R. E., (SNLA) C***DESCRIPTION C C Abstract C ***Note*** machine dependent routine C XERHLT aborts the execution of the program. C The error message causing the abort is given in the calling C sequence, in case one needs it for printing on a dayfile, C for example. C C Description of Parameters C MESSG is as in XERROR. C C***REFERENCES JONES R.E., KAHANER D.K., 'XERROR, THE SLATEC ERROR- C HANDLING PACKAGE', SAND82-0800, SANDIA LABORATORIES, C 1982. C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 790801 DATE WRITTEN as XERABT C 861211 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900206 Routine changed from user-callable to subsidiary. (WRB) C 900510 Changed calling sequence to delete length of char string C Changed subroutine name from XERABT to XERHLT. (RWC) C***END PROLOGUE XERHLT CHARACTER*(*) MESSG C***FIRST EXECUTABLE STATEMENT XERHLT STOP END C*DECK XERPRN SUBROUTINE XERPRN (PREFIX, NPREF, MESSG, NWRAP) C***BEGIN PROLOGUE XERPRN C***SUBSIDIARY C***PURPOSE This routine is called by XERMSG to print error messages C***LIBRARY SLATEC C***CATEGORY R3C C***TYPE ALL C***KEYWORDS ERROR MESSAGES, PRINTING, XERROR C***AUTHOR FONG, KIRBY, (NMFECC AT LLNL) C***DESCRIPTION C C This routine sends one or more lines to each of the (up to five) C logical units to which error messages are to be sent. This routine C is called several times by XERMSG, sometimes with a single line to C print and sometimes with a (potentially very long) message that may C wrap around into multiple lines. C C PREFIX Input argument of type CHARACTER. This argument contains C characters to be put at the beginning of each line before C the body of the message. No more than 16 characters of C PREFIX will be used. C C NPREF Input argument of type INTEGER. This argument is the number C of characters to use from PREFIX. If it is negative, the C intrinsic function LEN is used to determine its length. If C it is zero, PREFIX is not used. If it exceeds 16 or if C LEN(PREFIX) exceeds 16, only the first 16 characters will be C used. If NPREF is positive and the length of PREFIX is less C than NPREF, a copy of PREFIX extended with blanks to length C NPREF will be used. C C MESSG Input argument of type CHARACTER. This is the text of a C message to be printed. If it is a long message, it will be C broken into pieces for printing on multiple lines. Each line C will start with the appropriate prefix and be followed by a C piece of the message. NWRAP is the number of characters per C piece; that is, after each NWRAP characters, we break and C start a new line. In addition the characters '$$' embedded C in MESSG are a sentinel for a new line. The counting of C characters up to NWRAP starts over for each new line. The C value of NWRAP typically used by XERMSG is 72 since many C older error messages in the SLATEC Library are laid out to C rely on wrap-around every 72 characters. C C NWRAP Input argument of type INTEGER. This gives the maximum size C piece into which to break MESSG for printing on multiple C lines. An embedded '$$' ends a line, and the count restarts C at the following character. If a line break does not occur C on a blank (it would split a word) that word is moved to the C next line. Values of NWRAP less than 16 will be treated as C 16. Values of NWRAP greater than 132 will be treated as 132. C The actual line length will be NPREF + NWRAP after NPREF has C been adjusted to fall between 0 and 16 and NWRAP has been C adjusted to fall between 16 and 132. C C***REFERENCES (NONE) C***ROUTINES CALLED I1MACH, XGETUA C***REVISION HISTORY (YYMMDD) C 880621 DATE WRITTEN C 880708 REVISED AFTER THE SLATEC CML SUBCOMMITTEE MEETING OF C JUNE 29 AND 30 TO CHANGE THE NAME TO XERPRN AND TO REWORK C THE HANDLING OF THE NEW LINE SENTINEL TO BEHAVE LIKE THE C SLASH CHARACTER IN FORMAT STATEMENTS. C 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMMENS TO C STREAMLINE THE CODING AND FIX A BUG THAT CAUSED EXTRA BLANK C LINES TO BE PRINTED. C 890721 REVISED TO ADD A NEW FEATURE. A NEGATIVE VALUE OF NPREF C CAUSES LEN(PREFIX) TO BE USED AS THE LENGTH. C 891013 REVISED TO CORRECT ERROR IN CALCULATING PREFIX LENGTH. C 891214 Prologue converted to Version 4.0 format. (WRB) C 900510 Added code to break messages between words. (RWC) C***END PROLOGUE XERPRN CHARACTER*(*) PREFIX, MESSG INTEGER NPREF, NWRAP CHARACTER*148 CBUFF INTEGER IU(5), NUNIT CHARACTER*2 NEWLIN PARAMETER (NEWLIN = '$$') C***FIRST EXECUTABLE STATEMENT XERPRN CALL XGETUA(IU,NUNIT) C C A ZERO VALUE FOR A LOGICAL UNIT NUMBER MEANS TO USE THE STANDARD C ERROR MESSAGE UNIT INSTEAD. I1MACH(4) RETRIEVES THE STANDARD C ERROR MESSAGE UNIT. C N = I1MACH(4) DO 10 I=1,NUNIT IF (IU(I) .EQ. 0) IU(I) = N 10 CONTINUE C C LPREF IS THE LENGTH OF THE PREFIX. THE PREFIX IS PLACED AT THE C BEGINNING OF CBUFF, THE CHARACTER BUFFER, AND KEPT THERE DURING C THE REST OF THIS ROUTINE. C IF ( NPREF .LT. 0 ) THEN LPREF = LEN(PREFIX) ELSE LPREF = NPREF ENDIF LPREF = MIN(16, LPREF) IF (LPREF .NE. 0) CBUFF(1:LPREF) = PREFIX C C LWRAP IS THE MAXIMUM NUMBER OF CHARACTERS WE WANT TO TAKE AT ONE C TIME FROM MESSG TO PRINT ON ONE LINE. C LWRAP = MAX(16, MIN(132, NWRAP)) C C SET LENMSG TO THE LENGTH OF MESSG, IGNORE ANY TRAILING BLANKS. C LENMSG = LEN(MESSG) N = LENMSG DO 20 I=1,N IF (MESSG(LENMSG:LENMSG) .NE. ' ') GO TO 30 LENMSG = LENMSG - 1 20 CONTINUE 30 CONTINUE C C IF THE MESSAGE IS ALL BLANKS, THEN PRINT ONE BLANK LINE. C IF (LENMSG .EQ. 0) THEN CBUFF(LPREF+1:LPREF+1) = ' ' DO 40 I=1,NUNIT WRITE(IU(I), '(A)') CBUFF(1:LPREF+1) 40 CONTINUE RETURN ENDIF C C SET NEXTC TO THE POSITION IN MESSG WHERE THE NEXT SUBSTRING C STARTS. FROM THIS POSITION WE SCAN FOR THE NEW LINE SENTINEL. C WHEN NEXTC EXCEEDS LENMSG, THERE IS NO MORE TO PRINT. C WE LOOP BACK TO LABEL 50 UNTIL ALL PIECES HAVE BEEN PRINTED. C C WE LOOK FOR THE NEXT OCCURRENCE OF THE NEW LINE SENTINEL. THE C INDEX INTRINSIC FUNCTION RETURNS ZERO IF THERE IS NO OCCURRENCE C OR IF THE LENGTH OF THE FIRST ARGUMENT IS LESS THAN THE LENGTH C OF THE SECOND ARGUMENT. C C THERE ARE SEVERAL CASES WHICH SHOULD BE CHECKED FOR IN THE C FOLLOWING ORDER. WE ARE ATTEMPTING TO SET LPIECE TO THE NUMBER C OF CHARACTERS THAT SHOULD BE TAKEN FROM MESSG STARTING AT C POSITION NEXTC. C C LPIECE .EQ. 0 THE NEW LINE SENTINEL DOES NOT OCCUR IN THE C REMAINDER OF THE CHARACTER STRING. LPIECE C SHOULD BE SET TO LWRAP OR LENMSG+1-NEXTC, C WHICHEVER IS LESS. C C LPIECE .EQ. 1 THE NEW LINE SENTINEL STARTS AT MESSG(NEXTC: C NEXTC). LPIECE IS EFFECTIVELY ZERO, AND WE C PRINT NOTHING TO AVOID PRODUCING UNNECESSARY C BLANK LINES. THIS TAKES CARE OF THE SITUATION C WHERE THE LIBRARY ROUTINE HAS A MESSAGE OF C EXACTLY 72 CHARACTERS FOLLOWED BY A NEW LINE C SENTINEL FOLLOWED BY MORE CHARACTERS. NEXTC C SHOULD BE INCREMENTED BY 2. C C LPIECE .GT. LWRAP+1 REDUCE LPIECE TO LWRAP. C C ELSE THIS LAST CASE MEANS 2 .LE. LPIECE .LE. LWRAP+1 C RESET LPIECE = LPIECE-1. NOTE THAT THIS C PROPERLY HANDLES THE END CASE WHERE LPIECE .EQ. C LWRAP+1. THAT IS, THE SENTINEL FALLS EXACTLY C AT THE END OF A LINE. C NEXTC = 1 50 LPIECE = INDEX(MESSG(NEXTC:LENMSG), NEWLIN) IF (LPIECE .EQ. 0) THEN C C THERE WAS NO NEW LINE SENTINEL FOUND. C IDELTA = 0 LPIECE = MIN(LWRAP, LENMSG+1-NEXTC) IF (LPIECE .LT. LENMSG+1-NEXTC) THEN DO 52 I=LPIECE+1,2,-1 IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN LPIECE = I-1 IDELTA = 1 GOTO 54 ENDIF 52 CONTINUE ENDIF 54 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) NEXTC = NEXTC + LPIECE + IDELTA ELSEIF (LPIECE .EQ. 1) THEN C C WE HAVE A NEW LINE SENTINEL AT MESSG(NEXTC:NEXTC+1). C DON'T PRINT A BLANK LINE. C NEXTC = NEXTC + 2 GO TO 50 ELSEIF (LPIECE .GT. LWRAP+1) THEN C C LPIECE SHOULD BE SET DOWN TO LWRAP. C IDELTA = 0 LPIECE = LWRAP DO 56 I=LPIECE+1,2,-1 IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN LPIECE = I-1 IDELTA = 1 GOTO 58 ENDIF 56 CONTINUE 58 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) NEXTC = NEXTC + LPIECE + IDELTA ELSE C C IF WE ARRIVE HERE, IT MEANS 2 .LE. LPIECE .LE. LWRAP+1. C WE SHOULD DECREMENT LPIECE BY ONE. C LPIECE = LPIECE - 1 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) NEXTC = NEXTC + LPIECE + 2 ENDIF C C PRINT C DO 60 I=1,NUNIT WRITE(IU(I), '(A)') CBUFF(1:LPREF+LPIECE) 60 CONTINUE C IF (NEXTC .LE. LENMSG) GO TO 50 RETURN END C*DECK XGETUA SUBROUTINE XGETUA (IUNITA, N) C***BEGIN PROLOGUE XGETUA C***PURPOSE Return unit number(s) to which error messages are being C sent. C***LIBRARY SLATEC (XERROR) C***CATEGORY R3C C***TYPE ALL (XGETUA-A) C***KEYWORDS ERROR, XERROR C***AUTHOR JONES, R. E., (SNLA) C Modified by C FRITSCH, F. N., (LLNL) C***DESCRIPTION C C Abstract C XGETUA may be called to determine the unit number or numbers C to which error messages are being sent. C These unit numbers may have been set by a call to XSETUN, C or a call to XSETUA, or may be a default value. C C Description of Parameters C --Output-- C IUNIT - an array of one to five unit numbers, depending C on the value of N. A value of zero refers to the C default unit, as defined by the I1MACH machine C constant routine. Only IUNIT(1),...,IUNIT(N) are C defined by XGETUA. The values of IUNIT(N+1),..., C IUNIT(5) are not defined (for N .LT. 5) or altered C in any way by XGETUA. C N - the number of units to which copies of the C error messages are being sent. N will be in the C range from 1 to 5. C C CAUTION: The use of COMMON in this version is not safe for C multiprocessing. C C***REFERENCES JONES R.E., KAHANER D.K., 'XERROR, THE SLATEC ERROR- C HANDLING PACKAGE', SAND82-0800, SANDIA LABORATORIES, C 1982. C***ROUTINES CALLED (NONE) C***COMMON BLOCKS XERUNI C***REVISION HISTORY (YYMMDD) C 790801 DATE WRITTEN C 861211 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 901011 Rewritten to not use J4SAVE. (FNF) C 901012 Corrected initialization problem. (FNF) C***END PROLOGUE XGETUA DIMENSION IUNITA(5) INTEGER NUNIT, IUNIT(5) COMMON /XERUNI/ NUNIT, IUNIT C***FIRST EXECUTABLE STATEMENT XGETUA C Initialize so XERMSG will use standard error unit number if C block has not been set up by a CALL XSETUA. C CAUTION: This assumes uninitialized COMMON tests .LE.0 . IF (NUNIT.LE.0) THEN NUNIT = 1 IUNIT(1) = 0 ENDIF N = NUNIT DO 30 I=1,N IUNITA(I) = IUNIT(I) 30 CONTINUE RETURN END C*DECK XSETUA SUBROUTINE XSETUA (IUNITA, N) C***BEGIN PROLOGUE XSETUA C***PURPOSE Set logical unit numbers (up to 5) to which error C messages are to be sent. C***LIBRARY SLATEC (XERROR) C***CATEGORY R3B C***TYPE ALL (XSETUA-A) C***KEYWORDS ERROR, XERROR C***AUTHOR JONES, R. E., (SNLA) C Modified by C FRITSCH, F. N., (LLNL) C***DESCRIPTION C C Abstract C XSETUA may be called to declare a list of up to five C logical units, each of which is to receive a copy of C each error message processed by this package. C The purpose of XSETUA is to allow simultaneous printing C of each error message on, say, a main output file, C an interactive terminal, and other files such as graphics C communication files. C C Description of Parameters C --Input-- C IUNIT - an array of up to five unit numbers. C Normally these numbers should all be different C (but duplicates are not prohibited.) C N - the number of unit numbers provided in IUNIT C must have 1 .LE. N .LE. 5. C C CAUTION: The use of COMMON in this version is not safe for C multiprocessing. C C***REFERENCES JONES R.E., KAHANER D.K., 'XERROR, THE SLATEC ERROR- C HANDLING PACKAGE', SAND82-0800, SANDIA LABORATORIES, C 1982. C***ROUTINES CALLED XERMSG C***COMMON BLOCKS XERUNI C***REVISION HISTORY (YYMMDD) C 790801 DATE WRITTEN C 861211 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900510 Change call to XERRWV to XERMSG. (RWC) C 901011 Rewritten to not use J4SAVE. (FNF) C***END PROLOGUE XSETUA DIMENSION IUNITA(5) INTEGER NUNIT, IUNIT(5) COMMON /XERUNI/ NUNIT, IUNIT CHARACTER *8 XERN1 C***FIRST EXECUTABLE STATEMENT XSETUA C IF (N.LT.1 .OR. N.GT.5) THEN WRITE (XERN1, '(I8)') N CALL XERMSG ('SLATEC', 'XSETUA', * 'INVALID NUMBER OF UNITS, N = ' // XERN1, 1, 2) RETURN ENDIF C DO 10 I=1,N IUNIT(I) = IUNITA(I) 10 CONTINUE NUNIT = N RETURN END C C####################################################################### C C DASUSE : contains the routine C I1MACH to get the standard error message unit (6). C (also available from Netlib: send i1mach from core) C D1MACH to determine machine precision, uses value determined C by MACHAR C (also available from Netlib: send r1mach from core) C and the dummies for the routines DGEFA and DGESL from LINPACK C (available from Netlib: send dgefa/dgesl from linpack) C C####################################################################### C INTEGER FUNCTION I1MACH(IDUM) INTEGER IDUM C C I/O UNIT NUMBERS. C C I1MACH( 4) = THE STANDARD ERROR MESSAGE UNIT. I1MACH = 6 RETURN C----------------------- END OF FUNCTION I1MACH ------------------------ END DOUBLE PRECISION FUNCTION D1MACH(IDUM) INTEGER IDUM C----------------------------------------------------------------------- C This routine returns the unit roundoff of the machine in single C precision as computed by MACHAR and stored in SRELPR in the routine C SETSKM. C----------------------------------------------------------------------- INTEGER NERR DOUBLE PRECISION SRELPR COMMON /MACH/ NERR, SRELPR D1MACH = SRELPR RETURN C----------------------- END OF FUNCTION R1MACH ------------------------ END SUBROUTINE DGEFA RETURN END SUBROUTINE DGESL RETURN END C C####################################################################### C C DASLIP : LINPACK routines needed by DASSL C (available from Netlib: send dgbfa/dgbsl from linpack) C C####################################################################### C subroutine dgbfa(abd,lda,n,ml,mu,ipvt,info) integer lda,n,ml,mu,ipvt(1),info double precision abd(lda,1) c c dgbfa factors a double precision band matrix by elimination. c c dgbfa is usually called by dgbco, but it can be called c directly with a saving in time if rcond is not needed. c c on entry c c abd double precision(lda, n) c contains the matrix in band storage. the columns c of the matrix are stored in the columns of abd and c the diagonals of the matrix are stored in rows c ml+1 through 2*ml+mu+1 of abd . c see the comments below for details. c c lda integer c the leading dimension of the array abd . c lda must be .ge. 2*ml + mu + 1 . c c n integer c the order of the original matrix. c c ml integer c number of diagonals below the main diagonal. c 0 .le. ml .lt. n . c c mu integer c number of diagonals above the main diagonal. c 0 .le. mu .lt. n . c more efficient if ml .le. mu . c on return c c abd an upper triangular matrix in band storage and c the multipliers which were used to obtain it. c the factorization can be written a = l*u where c l is a product of permutation and unit lower c triangular matrices and u is upper triangular. c c ipvt integer(n) c an integer vector of pivot indices. c c info integer c = 0 normal value. c = k if u(k,k) .eq. 0.0 . this is not an error c condition for this subroutine, but it does c indicate that dgbsl will divide by zero if c called. use rcond in dgbco for a reliable c indication of singularity. c c band storage c c if a is a band matrix, the following program segment c will set up the input. c c ml = (band width below the diagonal) c mu = (band width above the diagonal) c m = ml + mu + 1 c do 20 j = 1, n c i1 = max0(1, j-mu) c i2 = min0(n, j+ml) c do 10 i = i1, i2 c k = i - j + m c abd(k,j) = a(i,j) c 10 continue c 20 continue c c this uses rows ml+1 through 2*ml+mu+1 of abd . c in addition, the first ml rows in abd are used for c elements generated during the triangularization. c the total number of rows needed in abd is 2*ml+mu+1 . c the ml+mu by ml+mu upper left triangle and the c ml by ml lower right triangle are not referenced. c c linpack. this version dated 08/14/78 . c cleve moler, university of new mexico, argonne national lab. c c subroutines and functions c c blas daxpy,dscal,idamax c fortran max0,min0 c c internal variables c double precision t integer i,idamax,i0,j,ju,jz,j0,j1,k,kp1,l,lm,m,mm,nm1 c c m = ml + mu + 1 info = 0 c c zero initial fill-in columns c j0 = mu + 2 j1 = min0(n,m) - 1 if (j1 .lt. j0) go to 30 do 20 jz = j0, j1 i0 = m + 1 - jz do 10 i = i0, ml abd(i,jz) = 0.0d0 10 continue 20 continue 30 continue jz = j1 ju = 0 c c gaussian elimination with partial pivoting c nm1 = n - 1 if (nm1 .lt. 1) go to 130 do 120 k = 1, nm1 kp1 = k + 1 c c zero next fill-in column c jz = jz + 1 if (jz .gt. n) go to 50 if (ml .lt. 1) go to 50 do 40 i = 1, ml abd(i,jz) = 0.0d0 40 continue 50 continue c c find l = pivot index c lm = min0(ml,n-k) l = idamax(lm+1,abd(m,k),1) + m - 1 ipvt(k) = l + k - m c c zero pivot implies this column already triangularized c if (abd(l,k) .eq. 0.0d0) go to 100 c c interchange if necessary c if (l .eq. m) go to 60 t = abd(l,k) abd(l,k) = abd(m,k) abd(m,k) = t 60 continue c c compute multipliers c t = -1.0d0/abd(m,k) call dscal(lm,t,abd(m+1,k),1) c c row elimination with column indexing c ju = min0(max0(ju,mu+ipvt(k)),n) mm = m if (ju .lt. kp1) go to 90 do 80 j = kp1, ju l = l - 1 mm = mm - 1 t = abd(l,j) if (l .eq. mm) go to 70 abd(l,j) = abd(mm,j) abd(mm,j) = t 70 continue call daxpy(lm,t,abd(m+1,k),1,abd(mm+1,j),1) 80 continue 90 continue go to 110 100 continue info = k 110 continue 120 continue 130 continue ipvt(n) = n if (abd(m,n) .eq. 0.0d0) info = n return end subroutine daxpy(n,da,dx,incx,dy,incy) c c constant times a vector plus a vector. c uses unrolled loops for increments equal to one. c jack dongarra, linpack, 3/11/78. c double precision dx(1),dy(1),da integer i,incx,incy,ix,iy,m,mp1,n c if(n.le.0)return if (da .eq. 0.0d0) return if(incx.eq.1.and.incy.eq.1)go to 20 c c code for unequal increments or equal increments c not equal to 1 c ix = 1 iy = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 if(incy.lt.0)iy = (-n+1)*incy + 1 do 10 i = 1,n dy(iy) = dy(iy) + da*dx(ix) ix = ix + incx iy = iy + incy 10 continue return c c code for both increments equal to 1 c c c clean-up loop c 20 m = mod(n,4) if( m .eq. 0 ) go to 40 do 30 i = 1,m dy(i) = dy(i) + da*dx(i) 30 continue if( n .lt. 4 ) return 40 mp1 = m + 1 do 50 i = mp1,n,4 dy(i) = dy(i) + da*dx(i) dy(i + 1) = dy(i + 1) + da*dx(i + 1) dy(i + 2) = dy(i + 2) + da*dx(i + 2) dy(i + 3) = dy(i + 3) + da*dx(i + 3) 50 continue return end subroutine dscal(n,da,dx,incx) c c scales a vector by a constant. c uses unrolled loops for increment equal to one. c jack dongarra, linpack, 3/11/78. c modified to correct problem with negative increment, 8/21/90. c double precision da,dx(1) integer i,incx,ix,m,mp1,n c if(n.le.0)return if(incx.eq.1)go to 20 c c code for increment not equal to 1 c ix = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 do 10 i = 1,n dx(ix) = da*dx(ix) ix = ix + incx 10 continue return c c code for increment equal to 1 c c c clean-up loop c 20 m = mod(n,5) if( m .eq. 0 ) go to 40 do 30 i = 1,m dx(i) = da*dx(i) 30 continue if( n .lt. 5 ) return 40 mp1 = m + 1 do 50 i = mp1,n,5 dx(i) = da*dx(i) dx(i + 1) = da*dx(i + 1) dx(i + 2) = da*dx(i + 2) dx(i + 3) = da*dx(i + 3) dx(i + 4) = da*dx(i + 4) 50 continue return end integer function idamax(n,dx,incx) c c finds the index of element having max. absolute value. c jack dongarra, linpack, 3/11/78. c modified to correct problem with negative increment, 8/21/90. c double precision dx(1),dmax integer i,incx,ix,n c idamax = 0 if( n .lt. 1 ) return idamax = 1 if(n.eq.1)return if(incx.eq.1)go to 20 c c code for increment not equal to 1 c ix = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 dmax = dabs(dx(ix)) ix = ix + incx do 10 i = 2,n if(dabs(dx(ix)).le.dmax) go to 5 idamax = i dmax = dabs(dx(ix)) 5 ix = ix + incx 10 continue return c c code for increment equal to 1 c 20 dmax = dabs(dx(1)) do 30 i = 2,n if(dabs(dx(i)).le.dmax) go to 30 idamax = i dmax = dabs(dx(i)) 30 continue return end subroutine dgbsl(abd,lda,n,ml,mu,ipvt,b,job) integer lda,n,ml,mu,ipvt(1),job double precision abd(lda,1),b(1) c c dgbsl solves the double precision band system c a * x = b or trans(a) * x = b c using the factors computed by dgbco or dgbfa. c c on entry c c abd double precision(lda, n) c the output from dgbco or dgbfa. c c lda integer c the leading dimension of the array abd . c c n integer c the order of the original matrix. c c ml integer c number of diagonals below the main diagonal. c c mu integer c number of diagonals above the main diagonal. c c ipvt integer(n) c the pivot vector from dgbco or dgbfa. c c b double precision(n) c the right hand side vector. c c job integer c = 0 to solve a*x = b , c = nonzero to solve trans(a)*x = b , where c trans(a) is the transpose. c c on return c c b the solution vector x . c c error condition c c a division by zero will occur if the input factor contains a c zero on the diagonal. technically this indicates singularity c but it is often caused by improper arguments or improper c setting of lda . it will not occur if the subroutines are c called correctly and if dgbco has set rcond .gt. 0.0 c or dgbfa has set info .eq. 0 . c c to compute inverse(a) * c where c is a matrix c with p columns c call dgbco(abd,lda,n,ml,mu,ipvt,rcond,z) c if (rcond is too small) go to ... c do 10 j = 1, p c call dgbsl(abd,lda,n,ml,mu,ipvt,c(1,j),0) c 10 continue c c linpack. this version dated 08/14/78 . c cleve moler, university of new mexico, argonne national lab. c c subroutines and functions c c blas daxpy,ddot c fortran min0 c c internal variables c double precision ddot,t integer k,kb,l,la,lb,lm,m,nm1 c m = mu + ml + 1 nm1 = n - 1 if (job .ne. 0) go to 50 c c job = 0 , solve a * x = b c first solve l*y = b c if (ml .eq. 0) go to 30 if (nm1 .lt. 1) go to 30 do 20 k = 1, nm1 lm = min0(ml,n-k) l = ipvt(k) t = b(l) if (l .eq. k) go to 10 b(l) = b(k) b(k) = t 10 continue call daxpy(lm,t,abd(m+1,k),1,b(k+1),1) 20 continue 30 continue c c now solve u*x = y c do 40 kb = 1, n k = n + 1 - kb b(k) = b(k)/abd(m,k) lm = min0(k,m) - 1 la = m - lm lb = k - lm t = -b(k) call daxpy(lm,t,abd(la,k),1,b(lb),1) 40 continue go to 100 50 continue c c job = nonzero, solve trans(a) * x = b c first solve trans(u)*y = b c do 60 k = 1, n lm = min0(k,m) - 1 la = m - lm lb = k - lm t = ddot(lm,abd(la,k),1,b(lb),1) b(k) = (b(k) - t)/abd(m,k) 60 continue c c now solve trans(l)*x = y c if (ml .eq. 0) go to 90 if (nm1 .lt. 1) go to 90 do 80 kb = 1, nm1 k = n - kb lm = min0(ml,n-k) b(k) = b(k) + ddot(lm,abd(m+1,k),1,b(k+1),1) l = ipvt(k) if (l .eq. k) go to 70 t = b(l) b(l) = b(k) b(k) = t 70 continue 80 continue 90 continue 100 continue return end double precision function ddot(n,dx,incx,dy,incy) c c forms the dot product of two vectors. c uses unrolled loops for increments equal to one. c jack dongarra, linpack, 3/11/78. c double precision dx(1),dy(1),dtemp integer i,incx,incy,ix,iy,m,mp1,n c ddot = 0.0d0 dtemp = 0.0d0 if(n.le.0)return if(incx.eq.1.and.incy.eq.1)go to 20 c c code for unequal increments or equal increments c not equal to 1 c ix = 1 iy = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 if(incy.lt.0)iy = (-n+1)*incy + 1 do 10 i = 1,n dtemp = dtemp + dx(ix)*dy(iy) ix = ix + incx iy = iy + incy 10 continue ddot = dtemp return c c code for both increments equal to 1 c c c clean-up loop c 20 m = mod(n,5) if( m .eq. 0 ) go to 40 do 30 i = 1,m dtemp = dtemp + dx(i)*dy(i) 30 continue if( n .lt. 5 ) go to 60 40 mp1 = m + 1 do 50 i = mp1,n,5 dtemp = dtemp + dx(i)*dy(i) + dx(i + 1)*dy(i + 1) + * dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4) 50 continue 60 ddot = dtemp return end