C 26/2/87. C EXPERIMENTAL VERSION BUG FIX ON LINE 2860 OR SO NFILTR IS ONLY C CALCULATED IF NCNT IS ZERO 26/2/87 C 3/3/87 C ARRAY EWT INTRODUCED INTO INITDA ALONG WITH PROPER TEST FOR C CONVERGENCE. C VARIABLE NCOFIL INTRODUCED AT THE END OF INITDA. C 12/3/87 C CALL TO DASSL INTERPOLATION ROUTINE INTRODUCED INTO INTDY. C INITDB ROUTINE INTRODUCED 13TH APRIL 1987. C 17/6/87 LABEL 580 REMOVED - THE RESIDUAL IS NO LONGER PUT INTO C YDOT ARRAY WHEN MAX NO OF STEPS EXCEEDED. C C 17/3/88 MAJOR REVISION OF INITDB ROUTINE, NEW COMMON BLOCK SLSZ06 C NEW OPTIONAL PARAMETER VALUE FOR INFORM(14) TO SWITCH ON THE FILTER. C THE FILTER IS ALSO AN OPTION IN INITDA ROUTINE. C C /4/88 MAJOR REVISION OF NON-LINEAR EQUATIONS SOLVER C TO CHANGE THE RESULT OF A BACK SUBSTITUTION BY NOT DIVIDING IT BY C H * EL0. THIS MEANS THAT SOME GEAR VARIANTS MAY NOT WORK. C C /8/88 NEW C1 INTERPOLATION ROUTINES SPTINT FOR STHETA AND STHETB C SPGINT FOR SPGEAR C SPBINT FOR SBLEND C SPDINT FOR SPDASL C ALL THESE ROUTINES ARE NOW CALLED FROM THE DRIVER ROUTINE C INTDY. THE SBLEND ROUTINE IS THE ORIGINAL LSODI ROUTINE. C C /8/88 FIX TO CHECK IF A RESTART TAKES THE CODE PAST THE NEXT C OUTPUT POINT. CHECK IS ON LINE 1537 C C 11/88 BUG FIXED IN INTDY CALL TO SPDINT HAD UNDEFINED PARAMETERS C AND FIRST TWO PARAMETERS IN WROMG ORDER. COMMON BLOCKS C LSTATS AND LSIZES INTRODUCED TO PASS TN AND NQU TO SPDINT. C C 2/89 INLN = 6 UPDATE SECTION IN NLSLVR CHANGED TO BE CONSISTENT C WITH OTHER INLN OPTIONS. C 5/89 VARIABLE DDUM NOT DECLARED AS DOUBLE PRECISION IN INTDY C MEANS THAT DASSL INTERPOLANT DOES NOT WORK. C SUBROUTINE SPRINT( NEQ, T, TOUT, Y, YDOTI, RWORK, NRW, RTOL, ATOL 1 ,ITOL, INFORM, SNORM, RESID, WKRES, NWKRES, STEP, YSAVE, NEQMAX 2 , JACFRM, WKJAC, NWKJAC, JACPVT, JAC, BACKSB, MONITR, WKMON, 3 NWKMON) C********************************************************************** C THIS IS THE MARK 3.0 DRIVING ROUTINE FOR THE SPRINT INTEGRATION C PACKAGE DATED 10/7/89.THIS CODE IS BASED ON THE LSODI DRIVER OF C A.C. HINDMARSH AND J.F. PAINTER AND IS WRITTEN IN DOUBLE PRECISION. C C AUTHOR: M. BERZINS , DEPT OF COMPUTER STUDIES ,THE UNIVERSITY LEEDS C C THIS SOFTWARE WAS FUNDED BY SHELL RESEARCH LTD AND IS DISTRIBUTED C AS A NON-COMMERCIAL EXPERIMENTAL SOFTWARE PACKAGE. NEITHER SHELL C RESEARCH NOR THE AUTHOR ACCEPT ANY RESPONSIBILITY FOR THE CORRECTNESS C OF THE SOFTWARE OR FOR THE NUMERICAL RESULTS CALCULATED BY USING IT. C C REFERENCE C M.BERZINS, P.M.DEW AND R.M. FURZELAND . C REPORTS NO 180, 202 AND 204 , SCHOOL OF COMPUTER STUDIES , C THE UNIVERSITY , LEEDS LS2 9JT. C C THE SPRINT PACKAGE IS DESIGNED TO SOLVE SYSTEMS OF FIRST ORDER C DIFFERENTIAL ALGEBRAIC EQUATIONS OF THE FORM GIVEN BY. C A(T,Y) * DY/DT = G(T,Y) , WHERE A(T,Y) IS A SQUARE MATRIX, C OR, IN COMPONENT FORM, C ( A * ( DY / DT )) + ... + ( A * ( DY / DT )) = C I,1 1 I,NEQ NEQ C C = G ( T, Y , Y ,..., Y ) ( I = 1,...,NEQ ) C I 1 2 NEQ C C IF A IS SINGULAR, THIS IS A DIFFERENTIAL-ALGEBRAIC SYSTEM. C SYSTEMS OF THIS TYPE ARISE ALSO FROM THE METHOD OF LINES C TREATMENT OF PARABOLIC OR ELLIPTIC PARABOLIC PARTIAL DIFFERENTIAL C EQUATIONS , WITH OR WITHOUT COUPLED ORDINARY DIFFERENTIAL AND/OR C ALGEBRAIC EQUATIONS. C********************************************************************** INTEGER NEQ(1), NRW, ITOL, INFORM(14+NEQMAX), NEQMAX, NWKJAC, 1 JACPVT(1), NWKRES, NWKMON DOUBLE PRECISION Y(1), YDOTI(1), RTOL(1), ATOL(1), RWORK(NRW), 1 YSAVE(NEQMAX,1), WKJAC(NWKJAC), T, TOUT, WKRES(NWKRES), 2 WKMON(NWKMON) CHARACTER*6 SNORM EXTERNAL RESID, STEP, JAC, JACFRM, BACKSB, MONITR C---------------------------------------------------------------------- C C DESCRIPTION OF THE SPRINT USER INTERFACE C ***************************************** C PAGE C (1) SHORT FORM OF SPRINT CALL SEQUENCE. 2 C C (2) HOW TO WRITE THE RESID ROUTINE WHICH DEFINES THE C DIFFERENTIAL EQUATION BEING SOLVED. 6 C C (3) A FULL DESCRIPTION OF THE CALLING SEQUENCE TO SPRINT. 7 C C (4) A DESCRIPTION OF OPTIONAL INPUTS. 14 C C (5) A DESCRIPTION OF OPTIONAL OUTPUTS (IN THE WORK ARRAYS). 15 C C (6) THE MONITR ROUTINE - A BRIEF INTRODUCTION. 16 C C (7) ANALYTIC JACOBIAN MATRICES. 18 C C (8) OTHER ROUTINES CALLABLE AND MACHINE DEPENDENT FEATURES. 20 C----------------------------------------------------------------------- C C 1.0 SHORT FORM OF SPRINT CALL SEQUENCE. C *************************************** C C INPUT ONLY PARAMETERS C --------------------- C NEQ, TOUT, ITOL, RTOL, ATOL, NRW, NWKJAC, SNORM, NEQMAX C C INPUT AND OUTPUT PARAMETERS C --------------------------- C Y, T, INFORM, YDOTI, YSAVE C C WORKSPACE ARRAYS C ---------------- C THE PARAMETERS WKRES ,NR AND WKMON , NWKMON MAY BE USED TO PASS C INFORMATION TO THE RESID AND MONITR ROUTINES . THE ARRAYS WKJAC C AND JACPVT ARE USED BY THE LINEAR ALGEBRA ROUTINES IN SPRINT. C THE WORK ARRAY RWORK IS ALSO USED TO PASS CONDITIONAL AND C OPTIONAL INPUTS AND OPTIONAL OUTPUTS WHICH ARE OF REAL TYPE. C THE INTEGER ARRAY INFORM ,WHICH HOLDS THE INTEGER INTEGRATION C FLAGS, IS ALSO USED TO PASS CONDITIONAL AND OPTIONAL INPUTS AND C OUTPUTS. C C EXTERNAL DECLARATIONS IN USERS PROGRAM C -------------------------------------- C THE NAMES OF THE ROUTINES THAT ARE PASSED ACROSS AS RESID , MONITR C JAC,JACFRM, BACKSB, AND STEP TO SPRINT MUST BE DECLARED AS EXTERNAL C IN THE USERS CALLING PROGRAM. C C C THE DESCRIPTIONS OF THE CALL ARGUMENTS ARE AS FOLLOWS. C C NEQ = THE SIZE OF THE SYSTEM (NUMBER OF FIRST ORDER ORDINARY C DIFFERENTIAL EQUATIONS OR SCALAR ALGEBRAIC EQUATIONS). C C T = THE INDEPENDENT VARIABLE. ON INPUT, T IS USED ONLY ON THE C FIRST CALL, AS THE INITIAL POINT OF THE INTEGRATION. C ON OUTPUT, AFTER EACH CALL, T IS THE VALUE AT WHICH A C COMPUTED SOLUTION Y IS RETURNED (USUALLY TOUT). C C TOUT = THE NEXT VALUE OF T AT WHICH A COMPUTED SOLUTION IS DESIRED. C USED ONLY FOR INPUT. TOUT MUST NOT EQUAL T ON ENTRY TO SPRINT C C Y = A DOUBLE PRECISION ARRAY,LENGTH NEQ, FOR THE DEPENDENT C VARIABLES . ON THE FIRST CALL Y MUST CONTAIN THE VECTOR OF C INITIAL VALUES. ON OUTPUT, Y CONTAINS THE COMPUTED SOLUTION C VECTOR, EVALUATED AT T. C C YDOTI = A DOUBLE PRECISION ARRAY , LENGTH NEQ , FOR THE TIME C DERIVATIVES DY/DT OF THE ARRAY Y. ON INPUT SPRINT WILL C COMPUTE THE INITIAL VALUES OF DY/DT. C N.B. IF Y AND YDOTI ARE BOTH ZERO AT THE BEGINING OF C INTEGRATION IT MAY BE NECESSARY TO SET INFORM(14) = 1 C (SEE THE SECTION ON OPTIONAL INPUTS ) C C RWORK = A REAL WORKING ARRAY (DOUBLE PRECISION), OF LENGTH AT LEAST C 21 + 3*NEQ . THE FIRST 21 WORDS OF RWORK ARE RESERVED FOR C CONDITIONAL AND OPTIONAL INPUTS AND OPTIONAL OUTPUTS. C C NRW = THE LENGTH OF THE ARRAY RWORK, AS DECLARED BY THE USER. C C RTOL = A SCALAR RELATIVE ERROR TOLERANCE PARAMETER, INPUT ONLY. C C ATOL = A SCALAR ABSOLUTE ERROR TOLERANCE PARAMETER, INPUT ONLY. C C ITOL = AN INDICATOR FOR THE TYPE OF ERROR CONTROL. INPUT ONLY. C ITOL = 1 ONLY IS DESCRIBED HERE SEE THE FULL DESCRIPTION FOR C OTHER VALUES OF ITOL RTOL AND ATOL. C THE INPUT PARAMETERS ITOL, RTOL, AND ATOL DETERMINE C THE ERROR CONTROL PERFORMED BY THE SOLVER. THE SOLVER WILL C CONTROL THE VECTOR E = (E(I)) OF ESTIMATED LOCAL ERRORS C IN Y, ACCORDING TO AN INEQUALITY OF THE FORM C NORM OF ( E(I)/EWT(I) ) .LE. 1, C WHERE EWT(I) = RTOL*ABS(Y(I)) + ATOL, C AND THE NORM USED HERE IS THAT DEFINED BY THE PARAMETER SNORM C AS DEFINED BELOW. HERE EWT = (EWT(I)) IS A VECTOR OF POSITIVE C WEIGHTS AND RTOL AND ATOL SHOULD BE NON-NEGATIVE. C C INFORM THIS ARRAY OF LENGTH 14 + NEQMAX IS USED TO HOLD THE CONTROL C ****** PARAMETERS FOR THE INTERGRATION AND THE OPTIONAL INPUTS AND C OUTPUTS. INFORM(15) TO INFORM(14+NEQMAX) IS A WORKSPACE. C THE FIRST THREE LOCATIONS OF INFORM ARE REFERRED TO AS ISTATE C ,ITASK AND IOPT IN SPRINT AND HAVE THE MEANINGS GIVEN BELOW. C C ISTATE = INFORM(1);AN INDEX USED FOR INPUT AND OUTPUT TO SPECIFY THE C STATE OF THE CALCULATION. THE INPUT VALUES OF ISTATE ARE. C 0 MEANS THIS IS THE FIRST CALL FOR THE PROBLEM, AND C SPRINT IS TO COMPUTE THE INITIAL VALUE OF DY/DT. C 1 MEANS THIS IS THE FIRST CALL FOR THE PROBLEM, AND C THE INITIAL VALUE OF DY/DT HAS BEEN SUPPLIED IN YDOTI. C 2 MEANS THIS IS NOT THE FIRST CALL, AND THE CALCULATION C IS TO CONTINUE NORMALLY, WITH NO CHANGE IN ANY INPUT C PARAMETERS EXCEPT POSSIBLY TOUT AND ITASK. C C OUTPUT VALUES OF ISTATE. C 0 OR 1 MEANS NOTHING WAS DONE, AS TOUT WAS EQUAL TO T WITH C ISTATE = 0 OR 1 ON INPUT. C 2 MEANS THAT THE INTEGRATION WAS PERFORMED SUCCESSFULLY. C 3, 4 ERROR RETURNS SIGNALLED BY EITHER THE RESID ROUTINE OR C BY THE MONITR ROUTINE. SEE FULL CALLING SEQUENCE. C -1 TOO MANY INTEGRATION STEPS WERE TAKEN , BUT SPRINT C REACHED TIME T BEFORE THIS HAPPENED. C -2 MEANS TOO MUCH ACCURACY WAS REQUESTED BUT SPRINT REACHED C TIME T BEFORE THIS HAPPENED. C -3 MEANS ILLEGAL INPUT WAS DETECTED, BEFORE TAKING ANY C INTEGRATION STEPS. SEE WRITTEN MESSAGE FOR DETAILS. C -4 MEANS THERE WERE REPEATED ERROR TEST FAILURES ON ONE C STEP, BUT THE INTEGRATION WAS SUCCESSFUL AS FAR AS T. C -5 MEANS THERE WERE REPEATED CONVERGENCE TEST FAILURES ON C ONE STEP, BUT THE INTEGRATION WAS SUCCESSFUL AS FAR AS T. C -6 MEANS EWT(I) BECAME ZERO FOR SOME I DURING THE C INTEGRATION. PURE RELATIVE ERROR CONTROL (ATOL=0.0) C WAS REQUESTED ON A VARIABLE WHICH HAS NOW VANISHED. C THE INTEGRATION WAS SUCCESSFUL AS FAR AS T. C -7 MEANS THAT THE USER-SUPPLIED ROUTINE RESID KEPT SETTING C ITS ERROR FLAG (IRES=3) DESPITE REPEATED TRIES BY SPRINT. C -8 MEANS THAT ISTATE WAS 0 ON INPUT BUT SPRINT WAS UNABLE C TO COMPUTE THE INITIAL VALUE OF DY/DT. C -9 MEANS THAT A FATAL ERROR OCCURRED IN JACOBIAN FORMULAT- C ION OR BACKSUBSTITUTION. C NOTE.. SINCE THE NORMAL OUTPUT VALUE OF ISTATE IS 2, C IT DOES NOT NEED TO BE RESET FOR NORMAL CONTINUATION. C C ITASK = INFORM(2) IS AN INDEX SPECIFYING THE TASK TO BE PERFORMED, C INPUT ONLY. ITASK HAS THE FOLLOWING VALUES AND MEANINGS. C 1 MEANS NORMAL COMPUTATION OF OUTPUT VALUES OF Y(T) AT C T = TOUT (BY OVERSHOOTING AND INTERPOLATING). C ITASK CAN ALSO BE GIVEN THE VALUES 2,3,4,5,6 SEE THE FULL C DESCRIPTION OF THE CALL TO SPRINT. C C IOPT = INFORM(3) IS AN INTEGER FLAG TO SPECIFY WHETHER OR NOT ANY C OPTIONAL INPUTS ARE BEING USED ON THIS CALL. INPUT ONLY. C THE OPTIONAL INPUTS ARE LISTED SEPARATELY BELOW. C IOPT = 0 MEANS NO OPTIONAL INPUTS ARE BEING USED. C DEFAULT VALUES WILL BE USED IN ALL CASES. C IOPT = 1 MEANS ONE OR MORE OPTIONAL INPUTS ARE BEING USED. C INFORM(J) , J = 15,..., 14+NEQ USED IN SPRINT AS AN INTEGER WORKSPACE C ARRAY OF LENGTH NEQ. C C SNORM CHARACTER*6 PARAMETER SPECIFYING THE TYPE OF NORM USED C BY SPRINT . THE BEST ALL ROUND OPTION IS PROBABLY. C 'L2NORM' L2 NORM. C THIS IS A WEIGHTED VECTOR NORM OF THE VECTOR V OF LENGTH NEQ C WITH WEIGHTS IN THE ARRAY EWT OF LENGTH NEQ. LET VNORM BE THE C NORM OF V THEN FOR THE L2 NORM C VNORM = SQRT( SUM( V(I)/EWT(I) )**2 ) C I C THE WEIGHTS EWT ARE DEFINED BY RTOL ATOL AND ITOL-SEE ABOVE. C OTHER OPTIONS FOR SNORM ARE DESCRIBED IN TH FULL DESCRIPTION. C C RESID = THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH SUPPLIES C THE RESIDUAL VECTOR FOR THE ODE SYSTEM, DEFINED BY C R = G(T,Y) - A(T,Y) * S C SEE THE SECTION BELOW ON WRITING THE RESID ROUTINE. C C WKRES A DOUBLE PRECISION WORKSPACE OF SIZE NWKRES WHICH MAY BE USED C AS REQUIRED BY THE USER INSIDE THE RESID ROUTINE.SEE BELOW. C C NWKRES AN INTEGER THAT SPECIFIES THE SIZE OF THE ARRAY WKRES. C C STEP = THE NAME OF THE O.D.E. STEP INTEGRATION MODULE WHICH IS USED C TO ADVANCE THE SOLUTION FROM TIME T TO TIME T+H WHERE THE STE C STEPSIZE H IS DETERMINED BY USER CONSTRAINTS AND BY THE STEP C MODULE. CURRENT OPTIONS WHICH MAY BE USED ARE C STHETA -- THETA METHOD WITH THETA = 0.55 C N.B. THE SETUP ROUTINE THESET MUST BE CORRECTLY C CALLED BEFORE THE SPRINT PACKAGE IS ENTERED. C SPGEAR -- GEAR/ADAMS METHOD BASED UPON LSODI C N.B. THE SETUP ROUTINE BDFSET MUST BE CALLED WHEN C THIS OPTION IS USED BEFORE THE CALL TO SPRINT. C SBLEND -- BLENDED LINEAR MULTISTEP METHOD SUITABLE FOR C PROBLEMS IN WHICH THE RATIO OF THE IMAGINARY TO C REAL PARTS OF THE EIGENVALUES IS LARGE. C N.B. THE SETUP MODULE BLSET MUST HAVE BEEN CALLED C BEFORE THE CALL TO SPRINT WHEN THIS OPTION IS USED. C STHETB -- MORE SOPHISTICATED VERSION OF STHETA - THE SETUP C ROUTINE THBSET MUST BE CALLED BEFORE SPRINT IS C ENTERED IF THIS ROUTINE IS TO BE USED. C C YSAVE A REAL ARRAY OF DIMENSION (NEQMAX,NY2DIM) WHERE NEQMAX >=NEQ C AND NY2DIM >= 2. YSAVE(*,1) HOLDS THE SAVED SOLUTION VALUES C FROM THE PREVIOUS TIMESTEP AND YSAVE(*,2) HOLDS THE PREVIOUS C VALUES OF THE TIME DERIVATIVE MULTIPLIED BY THE STEP SIZE. C THE REMAINDER OF THE YSAVE ARRAY IS USED AS A WORKSPACE BY C THE STEP ROUTINE. FOR EACH OF THE STEP MODULES , NY2DIM IS C SPGEAR NY2DIM = MAXORD + 1 C SPDASL NY2DIM = MAXORD + 1 C STHETA NY2DIM = 4 C STHETB NY2DIM = 4 C SBLEND NY2DIM = MAXORD + 3 C N.B. NY2DIM IS CHECKED BY THE RESPECTIVE SETUP ROUTINE. C IN SPGEAR AND SBLEND THIS ARRAY HOLDS THE NORDSIECK VECTOR. C IN SBLEND THE LAST TWO COMPONENTS ARE EXTRA ARRAYS NEEDED BY C THE BLENDED MULTISTEP METHOD. C NEQMAX SEE DESCRIPTION FOR YSAVE. C C JACFRM THE NAME OF THE MODULE WHICH FORMS THE JACOBIAN MATRIX OF C THE NON-LINEAR SYSTEM OF EQUATIONS GENERATED BY NLSLVR. C CURRENT OPTIONS ARE : C PREPJB - BANDED JACOBIAN - LINPACK ROUTINES C PREPJF - FULL JACOBIAN - LINPACK ROUTINES C PREPJS - SPARSE JACOBIAN - YALESMP ROUTINES C WHICH EVER OF THESE ROUTINES IS USED MUST BE DECLARED AS C EXTERNAL IN THE USERS CALLING PROGRAM. C IF BANDED OR FULL ROUTINES ARE USED THE SETUP ROUTINE C MATSET MUST BE CALLED PRIOR TO THE ENTRY TO SPRINT C IF THE SPARSE OPTION IS USED THE SETUP ROUTINE C SMTSET MUST BE CALLED PRIOR TO THE FIRST CALL OF SPRINT C C WKJAC A REAL WORKSPACE OF LENGTH NWKJAC THAT IS USED FOR STORING C THE JACOBIAN MATRIX AND ITS DECOMPOSED FORM. C THE DIMENSION OF THIS ARRAY IS GIVEN BY NWKJAC WHERE C THE ACTUAL SIZE OF NWKJAC IS GIVEN BY THE APPROPRIATE C SETUP ROUTINE FOR THE LINEAR ALGEBRA MODULE. C E.G. FOR SPARSE MATRICES SEE THE DOCUMENTATION AT THE HEAD C OF SUBROUTINE SMTSET AND FOR FULL OR BANDED MATRICES C SEE THE DOCUMENTATION AT THE HEAD OF ROUTINE MATSET. C C JACPVT = AN INTEGER ARRAY OF LENGTH NEQ WHICH IS USED TO HOLD THE C PIVOTS OF THE DECOMPOSED JACOBIAN MATRIX. C C JAC = THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH SUPPLIES C THE JACOBIAN MATRIX. IN THE CASE WHEN AN ANALYTIC C JACOBIAN IS NOT REQUIRED THE SPRINT DUMMY ROUTINE SPJDUM MAY C BE PASSED INSTEAD. THIS IS RECOMMENDED. SPJDUM SHOULD BE C AS EXTERNAL IN THE CALLING PROGRAM. OTHERWISE FOR DETAILS OF C HOW THE ROUTINE JAC SHOULD BE WRITTEN SEE THE SECTION7.0 C BELOW ENTITLED ' ANALYTIC JACOBIAN MATRICES' . C C BACKSB = THE MODULE WHICH BACKSUBSTITUTES USING THE FACTORED FORM C OF THE JACOBIAN MATRIX GENERATED BY JACFRM. C CURRENT OPTIONS ARE : C SOLSB - BANDED JACOBIAN - LINPACK ROUTINES. C SOLSF - FULL JACOBIAN - LINPACK ROUTINES. C SOLSS - SPARSE JACOBIAN - YALE SMP ROUTINES. C WHICH EVER OF THESE OPTIONS IS USED MUST BE DECLARED AS C EXTERNAL IN THE CALLING PROGRAM. C C MONITR = NAME OF THE USER SUPPLIED MONITOR ROUTINE WHICH CAN BE USED C TO PERFORM ANY TASKS WHICH ARE NEEDED AT THE END OF EVERY C TIMESTEP. FOR FIRST USE OF SPRINT THE SYSTEM PROVIDED MONITR C SPRMON SHOULD BE USED . SPRMON MUST BE DECLARED AS EXTERNAL C IN THE USERS CALLING PROGRAM. C----------------------------------------------------------------------- C C 2.0 HOW TO WRITE THE RESID ROUTINE. C************************************** C C THE USER-SUPPLIED RESID ROUTINE DEFINES THE SYSTEM OF ALGEBRAIC- C DIFFERENTIAL EQUATIONS BEING SOLVED. THE SPRINT PACKAGE SUPPLIES C AN APPROXIMATE SOLUTION VECTOR Y(NEQ) AND ITS APPROXIMATE TIME C DERIVATIVE VECTOR YDOT(NEQ). THE MAIN PURPOSE OF THE RESID ROUTINE C IS TO COMPUTE THE RESIDUAL VECTOR R(NEQ) WHICH IS OBTAINED BY C SUBSTITUTING THE VECTORS Y AND YDOT INTO THE DIFFERENTIAL - C ALGEBRAIC EQUATION THAT IS BEING SOLVED. I.E. FOR THE EQUATION C DEFINED AT THE VERY TOP OF THIS DOCUMENTATION C R = G( Y, T) - A( Y ,T) * YDOT (1) C - - - - ---- C SPRINT ALSO REQUIRES THAT THE PARTS OF THIS RESIDUAL THAT CONTAIN C A DEPENDENCY ON YDOT CAN ALSO BE COMPUTED BY CALLING RESID. I.E. C R = - A( Y ,T) * YDOT (2) C - - ---- C WHICH OF THESE TWO FORMS IS NEEDED DEPENDS ON THE VALUE OF IRES C THAT IS SUPPLIED BY SPRINT TO THE RESID ROUTINE. WHEN IRES = 1 C THE FORM OF THE VECTOR R GIVEN BY EQUATION (1) MUST BE GIVEN AND C WHEN IRES = -1 THE FORM OF THE VECTOR R MUST BE SUPPLIED. C THE RESID ROUTINE MUST THEREFORE HAVE THE FORM C C SUBROUTINE RESID( NEQ, T, Y, YDOT, R, IRES, WKRES, NWKRES ) C INTEGER NEQ, NWKRES, IRES C DOUBLE PRECISION T, Y(NEQ), YDOT(NEQ), R(NEQ), WKRES(NWKRES) C IF(IRES .EQ. -1)THEN C ... PUT THE PARTS OF THE RESIDUAL THAT DEPEND ON YDOT INTO C ... THE ARRAY R - SEE EQUATION (2) ABOVE C ELSE C ... PUT THE FULL RESIDUAL INTO THE ARRAY R, SEE EQUATION (1). C END IF C RETURN C END C C NOTE THE RESID ROUTINE MUST NOT ALTER THE VALUES OF THE C **** ARRAYS Y AND YDOT OR THE SCALARS T AND NEQ . C THIS IS CHECKED FOR BY THE CODE. C C C THE INPUT VALUES OF IRES ARE -1 OR 1 AND THE OUTPUT VALUES OF C IRES CAN BE SET AS FOLLOWS TO INDICATE CERTAIN CONDITIONS TO THE C SPRINT PACKAGE. C IRES = -1 OR IRES = 1 , IS A NORMAL RETURN I.E. IRES IS NOT C CHANGED BY RESID AND INTEGRATION CONTINUES. C IRES = 2 TELLS SPRINT THAT CONTROL SHOULD BE IMMEDIATELY PASSED C BACK TO THE USER'S CALLING PROGRAM WITH INFORM(2) = 3. C IRES = 3 TELLS SPRINT THAT AN ERROR CONDITION HAS OCCURRED IN C THE SOLUTION VECTOR , ITS TIME DERIVATIVE OR IN THE C VALUE OF T. SPRINT WILL USE A SMALLER TIME STEP TO TRY C AND AVOID THIS CONDITION . SHOULD THIS NOT BE POSSIBLE C SPRINT RETURNS TO THE USER'S CALLING PROGRAM WITH C INFORM(2) = -7. C IRES = 4 TELLS SPRINT TO STOP WHATEVER IT IS DOING AND TO ENTER C THE MONITR ROUTINE TO TAKE APPROPRIATE ACTION. C N.B. THE RESID ROUTINE MUST BE DECLARED AS EXTERNAL IN THE USER'S C CALLING PROGRAM. C IN THE CASE WHEN A LARGE AND COMPLICATED PROBLEM IS BEING SOLVED C IT IS OFTEN USEFUL TO PASS PROBLEM DEPENDENT INFORMATION FROM C THE USERS CALLING PROGRAM TO THE RESID ROUTINE. C WKRES A DOUBLE PRECISION WORKSPACE OF LENGTH NWKRES THAT CAN BE C USED TO PASS INFORMATION TO RESID. C NWKRES AN INTEGER THAT CONTAINS THE DIMENSION OF WKRES. C----------------------------------------------------------------------- C C 3.0 A FULL DESCRIPTION OF THE CALLING SEQUENCE TO SPRINT C ********************************************************** C C MORE COMPLETE DESCRIPTIONS OF THE CALL ARGUMENTS ARE AS FOLLOWS. C C NEQ = THE SIZE OF THE SYSTEM (NUMBER OF FIRST ORDER ORDINARY C DIFFERENTIAL EQUATIONS OR SCALAR ALGEBRAIC EQUATIONS). C USED ONLY FOR INPUT. C NEQ MAY BE CHANGED DURING THE PROBLEM. C IF NEQ IS DECREASED (WITH ISTATE = 3 ON INPUT), THE C REMAINING COMPONENTS OF Y SHOULD BE LEFT UNDISTURBED, IF C THESE ARE TO BE ACCESSED IN RESID OR JAC. C IF NEQ IS INCREASED THEN GREAT CARE MUST BE TAKEN WITH THE C SIZE OF ALL THE WORKSPACES , ALL THOSE DEPENDING ON NEQ MUST C BE AT LEAST AS LARGE AS THE MAXIMUM POSSIBLE VALUE OF NEQ. C IT MAY ALSO BE NECESSARY TO RECALL THE SETUP ROUTINES FOR C THE LINEAR ALGEBRA ROUTINES. THE PARAMETER NEQMAX MUST C ALSO BE GREATER THAN THE LARGEST POSSIBLE VALUE OF NEQ. C ***THIS OPTION IS NOT RECOMMENDED*************************** C NORMALLY, NEQ IS A SCALAR, AND IT IS GENERALLY REFERRED TO C AS SUCH . HOWEVER, NEQ MAY BE AN ARRAY,WITH NEQ(1) SET TO C THE SYSTEM SIZE (SPRINT ACCESSES ONLY NEQ(1)).EITHER WAY C THIS PARAMETER IS PASSED AS THE NEQ ARGUMENT IN ALL CALLS C TO RESID AND JAC. HENCE, IF IT IS AN ARRAY, C LOCATIONS NEQ(2),... MAY BE USED TO STORE OTHER INTEGER DATA C AND PASS IT TO RESID OR JAC. EACH SUCH SUBROUTINE C MUST INCLUDE NEQ IN A DIMENSION STATEMENT IN THAT CASE. C T = THE INDEPENDENT VARIABLE. ON INPUT, T IS USED ONLY ON THE C FIRST CALL, AS THE INITIAL POINT OF THE INTEGRATION. C ON OUTPUT, AFTER EACH CALL, T IS THE VALUE AT WHICH A C COMPUTED SOLUTION Y IS EVALUATED (USUALLY THE SAME AS TOUT). C ON AN ERROR RETURN, T IS THE FARTHEST POINT REACHED. C C TOUT = THE NEXT VALUE OF T AT WHICH A COMPUTED SOLUTION IS DESIRED. C USED ONLY FOR INPUT. C WHEN ENTERING SPRINT TOUT MUST BENOT EQUAL TO T. C FOR THE INITIAL T, AN INPUT VALUE OF TOUT .NE. T IS C USED IN ORDER TO DETERMINE THE DIRECTION OF THE INTEGRATION C (I.E. THE ALGEBRAIC SIGN OF THE STEP SIZES) AND THE ROUGH C SCALE OF THE PROBLEM. INTEGRATION IN EITHER DIRECTION C (FORWARD OR BACKWARD IN T) IS PERMITTED. C C IF ITASK = 2 OR 5 (ONE-STEP MODES), TOUT IS IGNORED AFTER C THE FIRST CALL (I.E. THE FIRST CALL WITH TOUT .NE. T). C OTHERWISE, TOUT IS REQUIRED ON EVERY CALL. C C IF ITASK = 1, 3, OR 4, THE VALUES OF TOUT NEED NOT BE C MONOTONE, BUT A VALUE OF TOUT WHICH BACKS UP IS LIMITED C TO THE CURRENT INTERNAL T INTERVAL, WHOSE ENDPOINTS ARE C TCUR - HU AND TCUR (SEE OPTIONAL OUTPUTS, BELOW, FOR C TCUR AND HU). C C Y = A REAL ARRAY FOR THE VECTOR OF DEPENDENT VARIABLES, OF C LENGTH NEQ OR MORE. USED FOR BOTH INPUT AND OUTPUT ON THE C FIRST CALL (ISTATE = 0 OR 1), AND ONLY FOR OUTPUT ON OTHER C CALLS. ON THE FIRST CALL, Y MUST CONTAIN THE VECTOR OF C INITIAL VALUES. ON OUTPUT, Y CONTAINS THE COMPUTED SOLUTION C VECTOR, EVALUATED AT T. C C YDOTI = A REAL ARRAY FOR THE INITIAL VALUE OF THE VECTOR C DY/DT AND FOR WORK SPACE, OF DIMENSION AT LEAST NEQ. C ON INPUT... C IF INFORM(1)=0 THEN SPRINT WILL COMPUTE THE INITIAL VALUE C OF DY/DT. C IF INFORM(1)=1 THEN YDOTI MUST CONTAIN THE INITIAL VALUE C OF DY/DT OR AN INITIAL GUESS. C IF INFORM(1)=2 OR 3 (CONTINUATION CALLS) THEN YDOTI C MAY HAVE ANY VALUE. C N.B. IF Y AND YDOTI ARE BOTH ZERO AT THE BEGINING OF C INTEGRATION IT MAY BE NECESSARY TO SET INFORM(14) = 1 C (SEE THE SECTION ON OPTIONAL INPUTS ) C C RWORK = A REAL WORKING ARRAY (DOUBLE PRECISION). C THE LENGTH OF RWORK MUST BE AT LEAST C 21 + 3*NEQ OR IF THE DAE SYSTEM IS TO BE CHANGED C IN MID INTEGRATION ... C 21 + 3*NEQMAX IF NEQMAX IS AN UPPER BOUND ON POSSIBLE NEQ C THE FIRST 21 WORDS OF RWORK ARE RESERVED FOR CONDITIONAL C AND OPTIONAL INPUTS AND OPTIONAL OUTPUTS. C C THE FOLLOWING WORD IN RWORK IS A CONDITIONAL INPUT.. C RWORK(1) = TCRIT = CRITICAL VALUE OF T WHICH THE SOLVER C IS NOT TO OVERSHOOT. REQUIRED IF ITASK IS C 4 OR 5, AND IGNORED OTHERWISE. (SEE ITASK.) C C NRW = THE LENGTH OF THE ARRAY RWORK, AS DECLARED BY THE USER. C (THIS WILL BE CHECKED BY THE SOLVER.) C C RTOL = A RELATIVE ERROR TOLERANCE PARAMETER, EITHER A SCALAR OR C AN ARRAY OF LENGTH NEQ. SEE DESCRIPTION BELOW UNDER ATOL. C INPUT ONLY - MUST BE DOUBLE PRECISION. C C ATOL = AN ABSOLUTE ERROR TOLERANCE PARAMETER, EITHER A SCALAR OR C AN ARRAY OF LENGTH NEQ. INPUT ONLY-MUST BE DOUBLE PRECISION. C C ITOL = AN INDICATOR FOR THE TYPE OF ERROR CONTROL. INPUT ONLY. C THE INPUT PARAMETERS ITOL, RTOL, AND ATOL DETERMINE C THE ERROR CONTROL PERFORMED BY THE SOLVER. THE SOLVER WILL C CONTROL THE VECTOR E = (E(I)) OF ESTIMATED LOCAL ERRORS C IN Y, ACCORDING TO AN INEQUALITY OF THE FORM C NORM OF ( E(I)/EWT(I) ) .LE. 1, C WHERE EWT(I) = RTOL(I)*ABS(Y(I)) + ATOL(I), C AND THE NORM USED HERE IS THAT DEFINED BY THE PARAMETER C SNORM AS DEFINED BELOW . HERE EWT = (EWT(I)) C IS A VECTOR OF POSITIVE WEIGHTS, AND C THE VALUES OF RTOL AND ATOL SHOULD ALL BE NON-NEGATIVE. C THE FOLLOWING TABLE GIVES THE TYPES (SCALAR/ARRAY) OF C RTOL AND ATOL, AND THE CORRESPONDING FORM OF EWT(I). C C ITOL RTOL ATOL EWT(I) C 1 SCALAR SCALAR RTOL*ABS(Y(I)) + ATOL C 2 SCALAR ARRAY RTOL*ABS(Y(I)) + ATOL(I) C 3 ARRAY SCALAR RTOL(I)*ABS(Y(I)) + ATOL C 4 ARRAY ARRAY RTOL(I)*ABS(Y(I)) + ATOL(I) C C WHEN EITHER OF THESE PARAMETERS IS A SCALAR, IT NEED NOT C BE DIMENSIONED IN THE USER-S CALLING PROGRAM. C IF NONE OF THE ABOVE CHOICES (WITH ITOL, RTOL, AND ATOL C FIXED THROUGHOUT THE PROBLEM) IS SUITABLE, MORE GENERAL C ERROR CONTROLS CAN BE OBTAINED BY SUBSTITUTING C USER-SUPPLIED ROUTINES FOR THE SETTING OF EWT AND/OR FOR C THE NORM CALCULATION. SEE ROUTINES EWSET AND SNORM BELOW. C C IF GLOBAL ERRORS ARE TO BE ESTIMATED BY MAKING A SECOND C RUN ON THE SAME PROBLEM WITH TIGHTER TOLERANCES, THEN ALL C COMPONENTS OF RTOL AND ATOL SHOULD BE UNIFORMLY SCALED DOWN. C C INFORM THIS ARRAY OF LENGTH 14 + NEQMAX IS USED TO HOLD THE CONTROL C ****** PARAMETERS FOR THE INTERGRATION AND THE OPTIONAL INPUTS AND C OUTPUTS. INFORM(15) TO INFORM(14+NEQMAX) HOLDS INFORMATION C ABOUT THE PRECISE FORM OF THE EQUATIONS BEING SOLVED. C THE FIRST THREE LOCATIONS OF THIS ARRAY C ARE REFERRED TO AS ISTATE ,ITASK AND IOPT IN THE DRIVER. C THESE LOCATIONS HAVE THE MEANINGS GIVEN BELOW. C C ISTATE = INFORM(1);AN INDEX USED FOR INPUT AND OUTPUT TO SPECIFY THE C STATE OF THE CALCULATION. C C ON INPUT, THE VALUES OF ISTATE ARE AS FOLLOWS. C 0 MEANS THIS IS THE FIRST CALL FOR THE PROBLEM, AND C SPRINT IS TO COMPUTE THE INITIAL VALUE OF DY/DT C (WHILE DOING OTHER INITIALIZATIONS). SEE NOTE BELOW. C 1 MEANS THIS IS THE FIRST CALL FOR THE PROBLEM, AND C THE INITIAL VALUE OF DY/DT HAS BEEN SUPPLIED IN C YDOTI SEE NOTE BELOW. C 2 MEANS THIS IS NOT THE FIRST CALL, AND THE CALCULATION C IS TO CONTINUE NORMALLY, WITH NO CHANGE IN ANY INPUT C PARAMETERS EXCEPT POSSIBLY TOUT AND ITASK. C (IF ITOL, RTOL, AND/OR ATOL ARE CHANGED BETWEEN CALLS C WITH ISTATE = 2, THE NEW VALUES WILL BE USED BUT NOT C TESTED FOR LEGALITY.) C 3 MEANS THIS IS NOT THE FIRST CALL, AND THE C CALCULATION IS TO CONTINUE NORMALLY, BUT WITH C A CHANGE IN INPUT PARAMETERS OTHER THAN C TOUT AND ITASK. CHANGES ARE ALLOWED IN C NEQ, ITOL, RTOL, ATOL, IOPT, NRW C AND ANY OF THE OPTIONAL INPUTS EXCEPT H0. C C ON OUTPUT, ISTATE HAS THE FOLLOWING VALUES AND MEANINGS. C 0 OR 1 MEANS NOTHING WAS DONE, AS TOUT WAS EQUAL TO T WITH C ISTATE = 0 OR 1 ON INPUT. (HOWEVER, AN INTERNAL COUNTER C WAS SET TO DETECT AND PREVENT REPEATED CALLS OF THIS C TYPE. ) C 2 MEANS THAT THE INTEGRATION WAS PERFORMED SUCCESSFULLY. C 3 MEANS THAT THE USER-SUPPLIED SUBROUTINE RESID SIGNALLED C SPRINT TO HALT THE INTEGRATION AND RETURN (IRES=2). C INTEGRATION AS FAR AS T WAS ACHIEVED WITH NO OCCURRENCE C OF IRES=2, BUT THIS FLAG WAS SET ON ATTEMPTING THE NEXT C STEP. C 4 MEANS THAT THE MONITR ROUTINE SET IMON = -2 AND SO C FORCED A RETURN BUT THAT THE INTEGRATION WAS SUCCESSFULL C AS FAR AS TIME T. C -1 MEANS AN EXCESSIVE AMOUNT OF WORK (MORE THAN MXSTEP C STEPS) WAS DONE ON THIS CALL, BEFORE COMPLETING THE C REQUESTED TASK, BUT THE INTEGRATION WAS OTHERWISE C SUCCESSFUL AS FAR AS T. (MXSTEP IS AN OPTIONAL INPUT C -DEFAULT VALUE =500.) TO CONTINUE, THE USER MAY C SIMPLY RESET ISTATE TO A VALUE .GT. 1 AND CALL AGAIN C (THE EXCESS WORK STEP COUNTER WILL BE RESET TO 0). C IN ADDITION, THE USER MAY INCREASE MXSTEP TO AVOID C THIS ERROR RETURN (SEE BELOW ON OPTIONAL INPUTS). C -2 MEANS TOO MUCH ACCURACY WAS REQUESTED FOR THE PRECISION C OF THE MACHINE BEING USED. THIS WAS DETECTED BEFORE C COMPLETING THE REQUESTED TASK, BUT THE INTEGRATION C WAS SUCCESSFUL AS FAR AS T. TO CONTINUE, THE TOLERANCE C PARAMETERS MUST BE RESET, AND ISTATE MUST BE SET C TO 3. THE OPTIONAL OUTPUT TOLSF MAY BE USED FOR THIS C PURPOSE. (NOTE.. IF THIS CONDITION IS DETECTED BEFORE C TAKING ANY STEPS, THEN AN ILLEGAL INPUT RETURN C (ISTATE = -3) OCCURS INSTEAD.) C -3 MEANS ILLEGAL INPUT WAS DETECTED, BEFORE TAKING ANY C INTEGRATION STEPS. SEE WRITTEN MESSAGE FOR DETAILS. C NOTE.. IF THE SOLVER DETECTS AN INFINITE LOOP OF CALLS C TO THE SOLVER WITH ILLEGAL INPUT, IT WILL CAUSE C THE RUN TO STOP. C -4 MEANS THERE WERE REPEATED ERROR TEST FAILURES ON C ONE ATTEMPTED STEP, BEFORE COMPLETING THE REQUESTED C TASK, BUT THE INTEGRATION WAS SUCCESSFUL AS FAR AS T. C THE PROBLEM MAY HAVE A SINGULARITY, OR THE INPUT C MAY BE INAPPROPRIATE. C -5 MEANS THERE WERE REPEATED CONVERGENCE TEST FAILURES ON C ONE ATTEMPTED STEP, BEFORE COMPLETING THE REQUESTED C TASK, BUT THE INTEGRATION WAS SUCCESSFUL AS FAR AS T. C THIS MAY BE CAUSED BY AN INACCURATE JACOBIAN MATRIX. C -6 MEANS EWT(I) BECAME ZERO FOR SOME I DURING THE C INTEGRATION. PURE RELATIVE ERROR CONTROL (ATOL(I)=0.0) C WAS REQUESTED ON A VARIABLE WHICH HAS NOW VANISHED. C THE INTEGRATION WAS SUCCESSFUL AS FAR AS T. C -7 MEANS THAT THE USER-SUPPLIED SUBROUTINE RESID SET C ITS ERROR FLAG (IRES=3) DESPITE REPEATED TRIES BY SPRINT C TO AVOID THAT CONDITION. C -8 MEANS THAT ISTATE WAS 0 ON INPUT BUT SPRINT WAS UNABLE C TO COMPUTE THE INITIAL VALUE OF DY/DT. SEE THE C PRINTED MESSAGE FOR DETAILS. C -9 MEANS THAT A FATAL ERROR OCCURRED IN JACOBIAN FORMULAT- C ION OR BACKSUBSTITUTION. C -10 MEANS THAT AN IMPOSSIBLE ERROR OCCURRED IN THE LINEAR C ALGEBRA ROUTINES WHEN TRYING TO FORM THE JACOBIAN MATRIX C AN EXAMPLE OF SUCH AN ERROR IS THAT NOT ENOUGH WORKSPACE C WAS SUPPLIED TO THE SPARSE MATRIX ROUTINES. C C NOTE.. SINCE THE NORMAL OUTPUT VALUE OF ISTATE IS 2, C IT DOES NOT NEED TO BE RESET FOR NORMAL CONTINUATION. C SIMILARLY, ISTATE NEED NOT BE RESET IF RESID TOLD SPRINT TO C RETURN BECAUSE THE CALLING PROGRAM MUST CHANGE THE PROBLEM. C ALSO, SINCE A NEGATIVE INPUT VALUE OF ISTATE IS ILLEGAL, A C NEGATIVE OUTPUT VALUE MUST BE CHANGED BEFORE RECALLING SPRINT C C ITASK = INFORM(2) IS AN INDEX SPECIFYING THE TASK TO BE PERFORMED, C INPUT ONLY. ITASK HAS THE FOLLOWING VALUES AND MEANINGS. C 1 MEANS NORMAL COMPUTATION OF OUTPUT VALUES OF Y(T) AT C T = TOUT (BY OVERSHOOTING AND INTERPOLATING). C 2 MEANS TAKE ONE STEP ONLY AND RETURN. C 3 MEANS STOP AT THE FIRST INTERNAL MESH POINT AT OR C BEYOND T = TOUT AND RETURN. C 4 MEANS NORMAL COMPUTATION OF OUTPUT VALUES OF Y(T) AT C T = TOUT BUT WITHOUT OVERSHOOTING T = TCRIT. C TCRIT MUST BE INPUT AS RWORK(1). TCRIT MAY BE EQUAL TO C OR BEYOND TOUT, BUT NOT BEFORE IT IN THE DIRECTION OF C INTEGRATION. THIS OPTION IS USEFUL IF THE PROBLEM C HAS A SINGULARITY AT OR BEYOND T = TCRIT. C 5 MEANS TAKE ONE STEP, WITHOUT PASSING TCRIT, AND RETURN. C TCRIT MUST BE INPUT AS RWORK(1). C 6 MEANS SOLVE FOR THE INITIAL VALUES OF Y AND YDOT ONLY C AND THEN RETURN TO THE CALLING PROGRAM WITHOUT CALLING C THE STEP INTEGRATOR. THIS OPTION CAN BE USED TO CHECK THE C INITIAL VALUES OF Y AND YDOT. SPRINT WILL EITHER USE C FUNCTIONAL ITERATION OR A 'SMALL' BACKWARD EULER STEP C IN CONJUNCTION WITH A DAMPED NEWTON ITERATION TO CALCULATE C THESE VALUES.NOTE- IF A BACKWARD EULER STEP IS USED C THEN THE VALUE OF T WILL HAVE BEEN ADVANCED. C NOTE.. IF ITASK = 4 OR 5 AND THE SOLVER REACHES TCRIT C (WITHIN ROUNDOFF), IT WILL RETURN T = TCRIT (EXACTLY) TO C INDICATE THIS (UNLESS ITASK = 4 AND TOUT COMES BEFORE TCRIT, C IN WHICH CASE ANSWERS AT T = TOUT ARE RETURNED FIRST). C C IOPT = INFORM(3) IS AN INTEGER FLAG TO SPECIFY WHETHER OR NOT ANY C OPTIONAL INPUTS ARE BEING USED ON THIS CALL. INPUT ONLY. C THE OPTIONAL INPUTS ARE LISTED SEPARATELY BELOW. C IOPT = 0 MEANS NO OPTIONAL INPUTS ARE BEING USED. C DEFAULT VALUES WILL BE USED IN ALL CASES. C IOPT = 1 MEANS ONE OR MORE OPTIONAL INPUTS ARE BEING USED. C INFORM(J) , J = 15,..., 14+NEQMAX USED IN SPRINT AS AN INTEGER C ARRAY OF LENGTH NEQ(1) WHICH IS USED TO DESCRIBE C WHETHER OR NOT THE NEQ(1) EQUATIONS ARE DIFFERENTIAL OR C ALGEBRAIC. C INFORM(14+J) = 0 MEANS THAT JTH EQUATION IS ALGEBRAIC C INFORM(14+J) = 1 MEANS THAT JTH EQUATION IS DIFFERENTIAL C THE SAME COMMENT AS FOR JACPVT APPLIES TO THE DIMENSION OF C THIS ARRAY. I.E. NEQMAX = MAX POSSIBLE NEQ(1) FOR THE PROBLEM C C SNORM CHARACTER*6 PARAMETER SPECIFYING THE TYPE OF NORM USED C BY SPRINT . THREE OPTIONS ARE ALLOWED. C 'MAXMUM' MAXIMUM NORM. C 'L2NORM' L2 NORM. C 'AVERL2' AVERAGED L2NORM, LESS RELIABLE THAN L2 NORM. C 'MODMAX' MODIFIED MAXIMUM NORM - A MORE STRINGENT NORM C THAN THE OTHERS. C ALL THREE NORMS ARE WEIGHTED VECTOR NORMS OF THE C VECTOR OF LENGTH N CONTAINED IN THE ARRAY V, WITH WEIGHTS C CONTAINED IN THE ARRAY W OF LENGTH N. LET VNORM = THE NORM OF C V THEN FOR THE AVERAGED L2 NORM C VNORM = SQRT( (1/M) * SUM( V(I)*W(I) )**2 ) WHERE M = N C WHILE FOR THE L2 NORM M = 1 AND FOR THE MAX NORM M IS ALSO 1 C VNORM = MAX | V(I)*W(I) | * M . C I C WHEREAS M = N FOR THE MODIFIED MAX NORM C THE WEIGHTS W(I) ARE DEFINED BY RTOL ATOL AND ITOL-SEE ABOVE. C C RESID = THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH SUPPLIES C THE RESIDUAL VECTOR FOR THE ODE SYSTEM, DEFINED BY C R = G(T,Y) - A(T,Y) * S C SEE SECTION 2.0 ABOVE FOR THE DETAILS OF HOW TO WRITE RESID. C C WKRES A DOUBLE PRECISION WORKSPACE OF SIZE NWKRES WHICH MAY BE USED C AS REQUIRED BY THE USER INSIDE THE RESID ROUTINE.SEE ABOVE. C C NWKRES AN INTEGER THAT SPECIFIES THE SIZE OF THE ARRAY WKRES. C C STEP = THE NAME OF THE O.D.E. STEP INTEGRATION MODULE WHICH IS USED C TO ADVANCE THE SOLUTION FROM TIME T TO TIME T+H WHERE THE STE C STEPSIZE H IS DETERMINED BY USER CONSTRAINTS AND BY THE STEP C MODULE. CURRENT OPTIONS WHICH MAY BE USED ARE C STHETA -- THETA METHOD WITH THETA = 0.55 C N.B. THE SETUP ROUTINE THESET MUST BE CORRECTLY C CALLED BEFORE THE SPRINT PACKAGE IS ENTERED. C SPGEAR -- GEAR/ADAMS METHOD BASED UPON LSODI C N.B. THE SETUP ROUTINE BDFSET MUST BE CALLED WHEN C THIS OPTION IS USED BEFORE THE CALL TO SPRINT. C SBLEND -- BLENDED LINEAR MULTISTEP METHOD SUITABLE FOR C PROBLEMS IN WHICH THE RATIO OF THE IMAGINARY TO C REAL PARTS OF THE EIGENVALUES IS LARGE. C N.B. THE SETUP MODULE BLSET MUST HAVE BEEN CALLED C BEFORE THE CALL TO SPRINT WHEN THIS OPTION IS USED. C STHETB -- MORE SOPHISTICATED VERSION OF STHETA WITH A FEW C IMPORTANT ADDITIONAL FACILITIES. N.B. THE SETUP C ROUTINE THBSET MUST HAVE BEEN CORRECTLY CALLED C BEFORE THE CALL TO SPRINT WHEN THIS OPTION IS USED. C C YSAVE A REAL ARRAY OF DIMENSION (NEQMAX, NY2DIM) WHERE NEQMAX >=NEQ C AND NY2DIM >= 2. YSAVE(*,1) HOLDS THE SAVED SOLUTION VALUES C FROM THE PREVIOUS TIMESTEP AND YSAVE(*,2) HOLDS THE PREVIOUS C VALUES OF THE TIME DERIVATIVE MULTIPLIED BY THE STEP SIZE. C THE REMAINDER OF THE YSAVE ARRAY IS USED AS A WORKSPACE BY C THE STEP ROUTINE. FOR EACH OF THE STEP MODULES , NY2DIM IS C SPGEAR NY2DIM = MAXORD + 1 C STHETA NY2DIM = 4 C SBLEND NY2DIM = MAXORD + 3 C N.B. NY2DIM IS CHECKED BY THE RESPECTIVE SETUP ROUTINE. C IN SPGEAR AND SBLEND THIS ARRAY HOLDS THE NORDSIECK VECTOR. C IN SBLEND THE LAST TWO COMPONENTS ARE EXTRA ARRAYS NEEDED BY C THE BLENDED MULTISTEP METHOD. C NEQMAX-- SEE DESCRIPTION FOR YSAVE. C IMPORTANT C --------- IF THE MONITR ROUTINE IS TO CHANGE THE SIZE OF C THE DAE SYSTEM BEING INTEGRATED THEN NEQMAX MUST C BE THE MAXIMUM POSSIBLE SIZE OF THE DAE SYSTEM. C THIS OPTION CAN BE USED TO IMPLEMENT MESH MODIFICATION FOR C P.D.E. PROBLEMS. NOTE THAT ALL OF THE WORKSPACES SUPPLIED TO C SPRINT MUST ALSO BE LARGE ENOUGH TO HANDLE THE DAE SYSTEM OF C SIZE NEQMAX EQUATIONS. C IN THE CASE WHEN THE DAE SYSTEM IS OF FIXED SIZE THEN SET C NEQMAX = NEQ(1) AND DIMENSION YSAVE ACCORDINGLY. C C JACFRM THE NAME OF THE MODULE WHICH FORMS THE JACOBIAN MATRIX OF C THE NON-LINEAR SYSTEM OF EQUATIONS GENERATED BY NLSLVR. C CURRENT OPTIONS ARE : C PREPJB - BANDED JACOBIAN - LINPACK ROUTINES C PREPJF - FULL JACOBIAN - LINPACK ROUTINES C PREPJS - SPARSE JACOBIAN - YALESMP ROUTINES C WHICH EVER OF THESE ROUTINES IS USED MUST BE DECLARED AS C EXTERNAL IN THE USER'S CALLING PROGRAM. C IF BANDED OR FULL ROUTINES ARE USED THE SETUP ROUTINE C MATSET MUST BE CALLED PRIOR TO THE ENTRY TO SPRINT C IF THE SPARSE OPTION IS USED THE SETUP ROUTINE C SMTSET MUST BE CALLED PRIOR TO THE FIRST CALL OF SPRINT C C WKJAC A REAL WORKSPACE OF LENGTH NWKJAC THAT IS USED FOR STORING C THE JACOBIAN MATRIX AND ITS DECOMPOSED FORM. C THE DIMENSION OF THIS ARRAY IS GIVEN BY NWKJAC WHERE C THE ACTUAL SIZE OF NWKJAC IS GIVEN BY THE APPROPRIATE C SETUP ROUTINE FOR THE LINEAR ALGEBRA MODULE. C E.G. FOR SPARSE MATRICES SEE THE DOCUMENTATION AT THE HEAD C OF SUBROUTINE SMTSET AND FOR FULL OR BANDED MATRICES C SEE THE DOCUMENTATION AT THE HEAD OF ROUTINE MATSET. C NOTE FOR SPARSE MATRICES THE SIZE OF NWKJAC CANNOT BE C DETERMINED PRECISELY IN ADVANCE AND SOME C EXPERIMENTATION MAY BE NECESSARY -SEE ROUTINE SMTSET. C C JACPVT = AN INTEGER ARRAY OF LENGTH NEQ(1) WHICH IS USED TO HOLD THE C PIVOTS OF THE DECOMPOSED JACOBIAN MATRIX. IF THE SIZE OF C NEQ MAY CHANGE IN MID INTEGRATION THIS ARRAY SHOULD BE OF C DIMENSION NEQMAX (= MAX POSSIBLE NEQ ). NOTE THAT IF THE C SPARSE MATRIX OPTION IS USED THEN THIS ARRAY MAY BE A C DUMMY ARRAY . SEE THE SPARSE MATRIX SETUP ROUTINE SMTSET C FOR FURTHER DETAILS. C C JAC = THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH SUPPLIES C THE JACOBIAN MATRIX. IN THE CASE WHEN AN ANALYTIC C JACOBIAN IS NOT REQUIRED A DUMMY ROUTINE NAME MAY BE PASSED C INSTEAD. THIS SUBROUTINE IS TO HAVE THE FORM REQUIRED BY THE C LINEAR ALGEBRA ROUTINES USED TO DECOMPOSE THE JACOBIAN .FOR C DETAILS OF HOW THIS ROUTINE SHOULD BE WRITTEN SEE THE SECTION C BELOW ENTITLED ' ANALYTIC JACOBIAN MATRICES' . AS SUPPLYING C ANALYTIC JACOBIANS MAY BE A COMPLEX AND ERROR PRONE TASK YOU C ARE ADVISED TO GET A PROBLEM WORKING WITH FINITE DIFFERENCE C APPROXIMATIONS TO THE JACOBIAN GENERATED BY SPRINT FIRST. C N.B. JAC MUST BE DECLARED EXTERNAL IN THE CALLING PROGRAM. C ---- C C BACKSB = THE MODULE WHICH BACKSUBSTITUTES USING THE FACTORED FORM C OF THE JACOBIAN MATRIX GENERATED BY JACFRM. C CURRENT OPTIONS ARE : C SOLSB - BANDED JACOBIAN - LINPACK ROUTINES. C SOLSF - FULL JACOBIAN - LINPACK ROUTINES. C SOLSS - SPARSE JACOBIAN - YALE SMP ROUTINES. C WHICH EVER OF THESE ROUTINES IS USE MUST BE DECLARED AS C EXTERNAL IN THE USER'S CALLING PROGRAM C N.B. THE BACKSUBSTITUTION AND JACOBIAN FORMING ROUTINES C MUST MATCH. THIS IS CHECKED FOR BY THE PROGRAM. C C MONITR = NAME OF THE USER SUPPLIED MONITOR ROUTINE WHICH CAN BE USED C TO PERFORM ANY TASKS WHICH ARE NEEDED ATE THE END OF EVERY C TIMESTEP. THIS SUBROUTINE MUST BE DECLARED AS EXTERNAL IN THE C USERS CALLING PROGRAM AND HAS THE FORM GIVEN IN SECTION 6.0. C ---------------------------------------------------------------------- C C 4.0 OPTIONAL INPUTS. C ******************** C C THE FOLLOWING IS A LIST OF THE OPTIONAL INPUTS PROVIDED FOR IN THE C CALL SEQUENCE. (SEE ALSO PART II.) FOR EACH SUCH INPUT VARIABLE, C THIS TABLE LISTS ITS NAME AS USED IN THIS DOCUMENTATION, ITS C LOCATION IN THE CALL SEQUENCE, ITS MEANING, AND THE DEFAULT VALUE. C THE USE OF ANY OF THESE INPUTS REQUIRES IOPT = 1, AND IN THAT C CASE ALL OF THESE INPUTS ARE EXAMINED. A VALUE OF ZERO FOR ANY C OF THESE OPTIONAL INPUTS WILL CAUSE THE DEFAULT VALUE TO BE USED. C THUS TO USE A SUBSET OF THE OPTIONAL INPUTS, SIMPLY PRELOAD C LOCATIONS 5 TO 10 IN RWORK AND LOCATIONS 4 TO 12 IN INFORM TO 0.0D0 C AND 0 RESPECTIVELY AND THEN TO SET THOSE OF INTEREST TO NONZERO VALUES C C NAME LOCATION MEANING AND DEFAULT VALUE C C H0 RWORK(5) THE STEP SIZE TO BE ATTEMPTED ON THE FIRST STEP. C THE DEFAULT VALUE IS DETERMINED BY THE SOLVER. C C HMAX RWORK(6) THE MAXIMUM ABSOLUTE STEP SIZE ALLOWED. C THE DEFAULT VALUE IS INFINITE. C C HMIN RWORK(7) THE MINIMUM ABSOLUTE STEP SIZE ALLOWED. C THE DEFAULT VALUE IS 0. (THIS LOWER BOUND IS NOT C ENFORCED ON THE FINAL STEP BEFORE REACHING TCRIT C WHEN ITASK = 4 OR 5.) C C MXSTEP INFORM(4) MAXIMUM NUMBER OF (INTERNALLY DEFINED) STEPS C ALLOWED DURING ONE CALL TO THE SOLVER. C THE DEFAULT VALUE IS 500. C C MXHNIL INFORM(5) MAXIMUM NUMBER OF MESSAGES PRINTED (PER PROBLEM) C WARNING THAT T + H = T ON A STEP (H = STEP SIZE). C THIS MUST BE POSITIVE TO RESULT IN A NON-DEFAULT C VALUE. THE DEFAULT VALUE IS 10. C C IODE INFORM(14) IF THE SYSTEM OF DIFFERENTIAL EQUATIONS IS KNOWN TO C BE IMPLICIT THEN THE INTEGRATOR CAN BE TOLD OF THIS C BY PUTTING INFORM(14) = 1. FURTHERMORE IF BOTH THE C SOLUTION VECTOR AND ITS TIME DERIVATIVE ARE ZERO C THEN IT MAY ALSO HELP TO SET INFORM(14) = 1 AS THIS C WILL ENSURE THAT A MODIFIED NEWTON METHOD IS USED TO C CALCULATE THE INITIAL VALUES OF THE DERIVATIVES. C IN THE CASE WHEN INEXACT VALUES ARE SUPPLIED FOR C DIFFERENTIAL- ALGEBRAIC EQUATIONS INFORM(14) MAY BE C SET = 2 TO FORCE THE USE OF A FILTER WHICH WILL C ATTEMPT TO REDUCE THE SIZE OF SPURIOUSLY LARGE TIME C DERIVATIVES. C OTHERWISE SET INFORM(14) = 0. C----------------------------------------------------------------------- C C 5.0 OPTIONAL OUTPUTS. C ********************* C C AS OPTIONAL ADDITIONAL OUTPUT FROM SPRINT, THE VARIABLES LISTED C BELOW ARE QUANTITIES RELATED TO THE PERFORMANCE OF SPRINT C WHICH ARE AVAILABLE TO THE USER. THESE ARE COMMUNICATED BY WAY OF C THE WORK ARRAYS, BUT ALSO HAVE INTERNAL MNEMONIC NAMES AS SHOWN. C EXCEPT WHERE STATED OTHERWISE, ALL OF THESE OUTPUTS ARE DEFINED C ON ANY SUCCESSFUL RETURN FROM SPRINT AND ON ANY RETURN WITH C ISTATE = -1, -2, -4, -5, -6, OR -7. ON A RETURN WITH -3 (ILLEGAL C INPUT) OR -8, THEY WILL BE UNCHANGED FROM THEIR EXISTING VALUES C (IF ANY), EXCEPT POSSIBLY FOR TOLSF, LENRW. . C ON ANY ERROR RETURN, OUTPUTS RELEVANT TO THE ERROR WILL BE DEFINED, C AS NOTED BELOW. C C NAME LOCATION MEANING C C HU RWORK(11) THE STEP SIZE IN T LAST USED (SUCCESSFULLY). C C HCUR RWORK(12) THE STEP SIZE TO BE ATTEMPTED ON THE NEXT STEP. C C TCUR RWORK(13) THE CURRENT VALUE OF THE INDEPENDENT VARIABLE C WHICH THE SOLVER HAS ACTUALLY REACHED, I.E. THE C CURRENT INTERNAL MESH POINT IN T. ON OUTPUT, TCUR C WILL ALWAYS BE AT LEAST AS FAR AS THE ARGUMENT C T, BUT MAY BE FARTHER (IF INTERPOLATION WAS DONE). C C TOLSF RWORK(14) A TOLERANCE SCALE FACTOR, GREATER THAN 1.0, C COMPUTED WHEN A REQUEST FOR TOO MUCH ACCURACY WAS C DETECTED (ISTATE = -3 IF DETECTED AT THE START OF C THE PROBLEM, ISTATE = -2 OTHERWISE). IF ITOL IS C LEFT UNALTERED BUT RTOL AND ATOL ARE UNIFORMLY C SCALED UP BY A FACTOR OF TOLSF FOR THE NEXT CALL, C THEN THE SOLVER IS DEEMED LIKELY TO SUCCEED. C (THE USER MAY ALSO IGNORE TOLSF AND ALTER THE C TOLERANCE PARAMETERS IN ANY OTHER WAY APPROPRIATE.) C C NST INFORM(6) THE NUMBER OF STEPS TAKEN FOR THE PROBLEM SO FAR. C C NRE INFORM(7) THE NUMBER OF RESIDUAL EVALUATIONS (RES CALLS) C FOR THE PROBLEM SO FAR. C C NJE INFORM(8) THE NUMBER OF JACOBIAN EVALUATIONS USED SO FAR. C THIS EQUALS THE NUMBER OF MATRIX L-U DECOMPOSITIONS. C C NQU INFORM(9) THE METHOD ORDER LAST USED (SUCCESSFULLY). C C NQCUR INFORM(10) THE ORDER TO BE ATTEMPTED ON THE NEXT STEP. C C IMXER INFORM(13) THE INDEX OF THE COMPONENT OF LARGEST MAGNITUDE IN C THE WEIGHTED LOCAL ERROR VECTOR ( E(I)/EWT(I) ), C ON AN ERROR RETURN WITH ISTATE = -4 OR -5. C C NITER INFORM(11) THE NUMBER OF ITERATIONS PERFORMED BY THE NONLINEAR C EQUATIONS SOLVER USING THE L-U DECOMPOSED FORM OF C THE JACOBIAN MATRIX. C C LENRW INFORM(12) THE SIZE OF THE REAL WORKSPACE REQUIRED BY THE STEP C ROUTINE C C IODE INFORM(14) INDICATOR DESCRIBING WHICH TYPE OF DIFFERENTIAL C EQUATION IS BEING SOLVED. PERMITTED VALUES OF IODE ARE C = 0 - MEANS THAT THE DIFFERENTIAL EQUATION HAS THE C FORM DY/DT = F(Y,T) WITH POSSIBLY COUPLED C ALGEBRAIC EQUATIONS. C = 1 - APPLIES TO ALL OTHER CASES C C----------------------------------------------------------------------- C C 6.0 THE MONITR ROUTINE C ********************** C C THIS ROUTINE CAN BE USED TO PERFORM ANY TASKS THAT MUST BE DONE AT THE C END OF EVERY TIMESTEP. THE USER CAN WRITE HIS OWN ROUTINE OR USE A C SPRINT LIBRARY MONITR ROUTINE . C THE FORM OF THIS ROUTINE IS GIVEN BY: C C SUBROUTINE MONITR(NEQ,T,HLAST,HNEXT,Y,YDOTI,YSAVE,NEQMAX,R,ACOR, C 1 WKRES,NWKRES,WKMON,NWKMON,IMON,INLN,HMIN,HMAX) C INTEGER NEQ, NWKRES, NWKMON, IMON, INLN C DOUBLE PRECISION T, HLAST, HNEXT, Y(1), YDOTI(1), YSAVE(NEQMAX,1), C 1 R(1), ACOR(NEQMAX,1), WKRES(NWKRES), WKMON(NWKMON), HMIN, HMAX C C C THE PARAMETERS NEQ,T,Y,YDOTI,YSAVE,NEQMAX,WKRES,NWKRES,WKMON,NWKMON C ARE DESCRIBED UNDER SUBROUTINE SPRINT (SEE ABOVE). THE OTHER C PARAMETERS ARE C C HLAST : THE LAST TIMESTEP SUCCESSFULLY USED BY THE INTEGRATOR C C HNEXT : THE TIME STEP THAT THE INTEGRATOR PROPOSES TO TAKE ON THE C NEXT INTEGRATION STEP C C R(NEQ) : ARRAY THAT CAN BE USED TO HOLD THE RESIDUAL ARRAY WHEN AN C EXIT IS MADE WITH INLN=3 AND IMON=0 C ACOR(NEQMAX,2) ; CONTAINS ERROR WEIGHTS AND LOCAL ERROR ESTIMATES C WHEN THE ROUTINE IS ENTERED WITH IMON=1 (SEE BELOW) C ACOR(I,1) CONTAINS THE ERROR WEIGHT USED IN ERROR NORM C FORMATION FOR THE ITH EQUATION C ACOR(I,2) CONTAINS THE LOCAL ERROR COMPONENT FOR EQUATION I C NOTE THAT THE SCALED LOCAL ERROR AT THE END OF A C STEP MAY BE ACCESSED BY CALLING THE SPRINT DOUBLE C PRECISION FUNCTION VNORM . C ERRLOC = VNORM( N, ACOR(1,1) , ACOR(1,2)) C WHERE BOTH ERRLOC AND VNORM MUST BE DECLARED AS C DOUBLE PRECISION. C IMON : PARAMETER TO DETERMINE THE ACTION TAKEN ON ENTRY TO OR EXIT C FROM THE MONITOR C ON ENTRY =-1 THE CURRENT STEP FAILED . IF NO ACTION IS TO BE C TAKEN LEAVE IMON AS -1 AND RETURN. C =0 RETURN FROM REVERSE COMMUNICATION CALL TO NON-LINEAR C EQN. SOLVER C =1 NORMAL ENTRY FROM STEP C =-2 ENTRY FROM STEP AFTER IRES=4(SET IN RESID) CAUSED C AN EARLY TERMINATION FROM THE STEP ROUTINE C E.G. CAN BE USED TO LOCATE DISCONTINUITIES C ON EXIT : =-1 NO ACTION TAKEN AFTER AN ENTRY WITH IMON = -1 C SPRINT WILL TRY AND DO UP TO 3 RESTARTS UNLESS C IMON IS SET TO -2 ON EXIT. C =-2 INTEGRATION TO BE HALTED AND A RETURN MADE TO THE C CALLING PROGRAM. C =0 REVERSE COMMUNICATION EXIT TO NON-LINEAR EQN.SOLVER C THE ACTION TO BE TAKEN IS DETERMINED BY THE VALUE C OF INLN - SEE BELOW FOR AN EXAMPLE. C =1 NORMAL EXIT TO STEP TO CONTINUE INTEGRATION C =2 RESTART THE INTEGRATION AT THE CURRENT TIME LEVEL C BY CALLING THE INITIALISATION MODULE AND BY SOLVING C RESTART FOR NEW VALUES OF Y AND YDOTI BY USING THE ESTIMATES C MODE. PROVIDED BY MONITR AS THE INITIAL GUESSES. THE ODE C INTEGRATOR WILL RESTART FROM ORDER ONE WHEN THIS C RETURN IS USED. C =3 RESTART THE INTEGRATION AT THE CURRENT TIME LEVEL C BUT USING THE NEW YSAVE MEMORY VALUESAND BY C FLYING GOING DIRECTLY BACK INTO THE STEP MODULE TO TRY C RESTART AND CONTINUE WITH THE SAME STEPSIZE AND ORDER AS WAS C MODE. TO BE USED BEFORE THE CALL TO MONITR. CHANGES MAY ALSO C BE MADE IN TO HMIN AND HMAX IF REQUIRED. C THIS OPTION WHEN USED WITH A CAREFULLY MODIFIED YSAVE C MAY BE USED TO CONTINUE WITH A MODIFIED FORM OF THE C ORIGINAL ODE PROBLEM BUT WITHOUT THE OVERHEAD OF A C THE COMPLETE RESTART ORDERED BY IMON = 2. C =4 CONTINUE THE INTEGRATION BUT USING NEW STEPSIZE H OR C NEW VALUES OF HMIN AND HMAX. C C HMAX : THE MAXIMUM STEPSIZE TO BE TAKEN ON THE NEXT STEP. IF THIS IS C SET TO ZERO A LIMIT OF INFINITY IS ASSUMED. IF THIS VALUE IS C CHANGED BY MONITR THEN IMON SHOULD BE SET TO 4 ON EXIT. C (BOTH HMAX AND HMIN MAY BE CHANGED BY MONITR) C C HMIN : THE MINIMUM STEPSIZE TO BE TAKEN ON THE NEXT STEP C IF THIS VALUE IS CHANGED BY MONITR THEN IMON SHOULD BE SET C TO 4 ON EXIT. THIS FORCES THE CURRENT STEP SIZE TO BE CHECKED C AGAINST THE NEW HMIN AND HMAX. C C INLN : PARAMETER TO GOVERN THE ACTION TAKEN BY THE NON-LINEAR EQN. C SOLVER AND IS DESCRIBED IN THE DOCUMENTATION TO NLSLVR. IT C CAN BE USED FOR INSTANCE TO DO A RESIDUAL EVALUATION ONLY C BY SETTING INLN=3 AND RETURNING TO THE SPRINT DRIVER. THE C TASK THAT SPRINT WILL PERFORM BEFORE THE NEXT ENTRY TO THE C MONITR ROUTINE IS TO PLACE THE O.D.E. RESIDUAL ,COMPUTED C USING T, Y AND YDOT IN THE ARRAY R. C C C WKMON = USER DECLARED ARRAY OF LENGTH NWKMON WHICH IS PASSED INTO C THE MONITOR ROUTINE FOR THE USER TO EMPLOY AS HE WISHES. C C NWKMON = THE LENGTH OF THE ARRAY WKMON. C C NOTE.. THE WORK ARRAYS MUST NOT BE ALTERED BETWEEN CALLS TO SPRINT C FOR THE SAME PROBLEM, EXCEPT POSSIBLY FOR THE CONDITIONAL AND C OPTIONAL INPUTS . C----------------------------------------------------------------------- C C 7.0 ANALYTIC JACOBIAN MATRICES C ****************************** C C THE SYSTEM OF NONLINEAR EQUATIONS SOLVED BY SPRINT IS DEFINED C AS FOLLOWS. THE TIME DERIVATIVE SUPPLIED TO THE JACOBIAN C FORMING ROUTINE , YDOT , HAS THE FORM C YDOT = (Y - Z ) / (H * D) C WHERE H IS THE CURRENT TIME STEP AND D IS A PARAMETER THAT C DEPENDS ON THE O.D.E. TIME INTEGRATION METHOD IN USE. THE C VECTOR Y IS THE CURRENT SOLUTION AND THE VECTOR Z DEPENDS ON C INFORMATION FROM PREVIOUS TIME STEPS. THIS MEANS THAT C D /DYDOT (.) = 1.0 / (H*D) * D/DY (.) C THE SYSTEM OF NONLINEAR EQUATIONS THAT IS SOLVED HAS THE FORM C A(Y,T) * YDOT - G(Y,T) = 0 C BUT IS SOLVED IN THE FORM C R(Y,T) = 0 C WHERE THE FUNCTION R IS DEFINED BY C R(Y,T) = H*D * ( A(Y,T) * (Y-Z)/(H*D) - G(Y,T) ) C THE I,J TH COMPONENT OF THE JACOBIAN MATRIX J , DENOTED HERE C BY J(I,J) IS DEFINED BY DR / DY C I J C IT IS THIS MATRIX THAT THE USER MUST SUPPLY IN THE ROUTINE JAC C C EXAMPLES (1) CONSIDER THE SYSTEM OF O.D.E.S GIVEN BY C -------- C YDOT - G(Y,T) = 0 WHERE Y,YDOT AND G ARE VECTOR C FUNCTIONS C THEN J(I,J) = 1 - H*D * DG / DY IF I = J C I J C J(I,J) = - H*D * DG / DY OTHERWISE. C I J C (2) CONSIDER THE SYSTEM OF D.A.E. S GIVEN BY C C A(Y,T)*YDOT - G(Y,T) = 0 WHERE A(Y,T) IS A C SQUARE MATRIX OF DIMENSION C NEQ BY NEQ THEN C NEQ C J(I,J)= A(Y,T) + H*D *( SUM YDOT * D A (Y,T)) - D G (Y,T) C I,J K=1 K - I,K - I C DY DY C J J C THE PRECISE INTERFACE TO THE ROUTINE WHOSE NAME IS PASSED C ACROSS AS JAC DEPENDS ON THE TYPE OF LINEAR ALGEBRA ROUTINES C THAT ARE BEING USED. THE FIRST SIX PARAMETERS OF THIS ROUTINE C ARE ALWAYS THE SAME. I. E. C SUBROUTINE JAC ( NEQ, T, Y, YDOT, H, D,.............. ) C THESE ARE ALL INPUT PARAMETERS THAT SHOULD NOT BE ALTERED. C T ; CURRENT TIME . C NEQ(1) THE DIMENSION OF THE O.D.E. SYSTEM. C Y(1) THE CURRENT SOLUTION C YDOT(1) THE TIME DERIV OF THE CURRENT SOLUTION. C H,D THE PARAMETERS USED IN FORMING YDOT AS DESCRIBED AT THE C BEGINING OF THIS SECTION. C FULL OR BANDED MATRICES C ----------------------- C IN THE CASE OF FULL OR BANDED MATRICES THE FORM OF JAC IS C SUBROUTINE JAC ( NEQ, T, Y, YDOT, H, D, ML, MU, P, NROWP) C INTEGER NEQ(1), ML, MU, NROWP C DOUBLE PRECISION T, Y(1), YDOT(1), H, D, P(NROWP,1) C WHERE NEQ, T, Y, YDOT, H, D, ML, MU, AND NROWP ARE INPUT C AND P IS OUTPUT. Y AND YDOT ARE ARRAYS OF LENGTH NEQ, AND C THE MATRIX P IS STORED IN AN NROWP BY NEQ ARRAY. P IS TO BE C LOADED WITH ELEMENTS OF THE JACOBIAN MATRIX ON OUTPUT. C IN THE FULL MATRIX CASE ML AND MU C ARE IGNORED AND THE JACOBIAN IS TO BE LOADED INTO P C BY COLUMNS- I.E., DR(I)/DY(J) IS LOADED INTO P(I,J). C IN THE BAND MATRIX CASE , THE ELEMENTS WITHIN THE C BAND ARE TO BE LOADED INTO P BY COLUMNS, C WITH DIAGONAL LINES OF DR/DY LOADED INTO C THE ROWS OF P. THUS DR(I)/DY(J) IS TO BE LOADED C INTO P(I-J+MU+1,J). THE LOCATIONS IN P IN THE TWO C TRIANGULAR AREAS WHICH CORRESPOND TO NONEXISTENT MATRIX C ELEMENTS CAN BE IGNORED OR LOADED ARBITRARILY, AS THEY C THEY ARE OVERWRITTEN BY SPRINT. ML AND MU ARE THE HALF- C BANDWIDTH PARAMETERS ( SEE BANDED MATRIX ROUTINES). C IN EITHER CASE, P IS PRESET TO ZERO BY THE SOLVER, C SO THAT ONLY THE NONZERO ELEMENTS NEED BE LOADED BY JAC. C SPARSE MATRIX ROUTINES C ---------------------- C IN THE CASE WHEN THE SPARSE MATRIX ROUTINES ARE USED THE C ROUTINES TO SUPPLY THE ANALYTIC JACOBIAN TAKES THE FORM C GIVEN BY: C SUBROUTINE JAC( NEQ, T, Y, YDOT, H, D, J, IAN, JAN, PDJ) C INTEGER NEQ(1), J, IAN((1), JAN(1) C DOUBLE PRECISION T, Y(1), YDOT(1), H, D, PDJ(1) C WHERE NEQ, T, Y, YDOT, J, IAN ,JAN ARE INPUT AND PDJ ,OF C LENGTH NEQ(1), IS TO BE LOADED WITH COLUMN J OF THE JACOBIAN C MATRIX ON OUTPUT. NONE OF THE INPUT PARAMETERS SHOULD BE C CHANGED ON OUTPUT. THE PARAMETER J IS A COLUMN INDEX WITH C VALUE 1 TO NEQ(1). THE ARRAYS IAN AND JAN ARE UNDEFINED IN C CALLS TO JAC FOR SPARSITY PATTERN DETERMINATION. OTHERWISE C IAN AND JAN ARE SPARSITY DESCRIPTORS - SEE THE PREAMBLE TO C THE SETUP ROUTINE , SMTSET, FOR THE SPARSE MATRIX MODULE FOR C FURTHER DETAILS. C NOTE IN ALL THE TYPE STATEMENTS ABOVE THE ARRAYS THAT ARE C ---- GIVEN THE DUMMY DIMENSION 1 MAY BE GIVEN ANY VALUE. C FURTHERMORE IN THE CALL TO SETUP THE LINEAR ALGEBRA C ROUTINES THE OPTION THAT SPECIFIES ANALYTIC JACOBIANS C MUST BE SPECIFIED.(SEE THE APROPRIATE DOCUMENTATION FOR C THESE ROUTINES. C---------------------------------------------------------------------- C C 8.0 OTHER ROUTINES CALLABLE AND MACHINE DEPENDENT FEATURES. C *********************************************************** C C THE FOLLOWING ARE OPTIONAL CALLS WHICH THE USER MAY MAKE TO C GAIN ADDITIONAL CAPABILITIES IN CONJUNCTION WITH SPRINT. C CALL INTDY PROVIDES DERIVATIVES OF Y , OF VARIOUS C ( SEE DOCUMENTATION ORDERS, AT A SPECIFIED POINT T, IF C IN THE ROUTINE ) DESIRED. IT MAY BE CALLED ONLY AFTER C A SUCCESSFUL RETURN FROM THE PACKAGE. C C IN ADDITION TO SUBROUTINE SPRINT AND THE OPTIONAL ROUTINES THAT ARE C SPECIFIED BY THE CALL TO SPRINT THIS PACKAGE INCLUDES THE C FOLLOWING SUBROUTINES AND FUNCTION ROUTINES.. C INTDY COMPUTES AN INTERPOLATED VALUE OF THE Y VECTOR AT T = TOUT. C USING A NORDSIECK VECTOR FORM OF THE MEMORY ARRAY. C INITDA INITIALISATION MODULE FOR D.A.E. SYSTEMS. C THE INITIAL VALUES OF Y AND YDOT ARE FORMED EITHER C BY FUNCTIONAL ITERATION OR BY A DAMPED NEWTON METHOD. C EWSET SETS THE ERROR WEIGHT VECTOR EWT BEFORE EACH STEP. C VNORM COMPUTES THE WEIGHTED NORM OF A VECTOR. C NLSLVR A DRIVING PROGRAM WHICH CONTROLS THE SOLUTION OF THE C LINEAR AND NONLINEAR EQUATIONS THAT ARE SOLVED BY SPRINT. C SERROR, HANDLES THE PRINTING OF ALL ERROR C MESSAGES AND WARNINGS. C ITSTEP - ESTIMATES THE SIZE OF THE INITIAL TIME STEP C C NOTE.. VNORM IS A FUNCTION . ALL THE OTHERS ARE SUBROUTINES. C C THE INTRINSIC AND EXTERNAL ROUTINES USED BY THE DOUBLE PRECISION C VERSION OF SPRINT ARE C DABS, DMAX1, DMIN1, IABS, MAX0, MIN0, MOD, DSIGN AND DQSRT. C C THE ONLY MACHINE DEPENDENT FEATURES ARE THE CPU TIMING ROUTINE C AND A BLOCK DATA SUBPROGRAM. THE BLOCK DATA IS USED C FOR LOADING THE MACHINE DEPENDENT CONSTANTS AND INITIALISING C SOME OF THE VARIABLES USED IN THE INTERNAL COMMON BLOCKS C---------------------------------------------------------------------- C DECLARATIONS OF LOCAL VARIABLES USED BY SPRINT. C INTEGER INIT, LEWT, LACOR, LSAVR, MXSTEP, MXHNIL, NSLAST, NHNIL INTEGER NQ, NQU, NST, NRE, NJE, NITER, IFN, IDACHK, NFSTEP INTEGER IRES, IFUNC, IFJ, ISTEP, IEWSET, N, K, NORDER, NSTEPS INTEGER I,IER, IFLAG, IMXER, J, KGO, LENRW, MXHNL0, MXSTP0,MAXIT, 1 ISTATE, IOPT, ITASK, IRETUR, IDACNT, IDAOLD, INITL, IODE INTEGER IOVFLO, ITRACE, IDEV, INORM, NINTER, ICRASH, INLN, IMON DOUBLE PRECISION UROUND, DUNFLO, TTAKEN DOUBLE PRECISION EL0, H, HMIN, HMXI, HU, TN, TEM, DSQU DOUBLE PRECISION ATOLI, BIG, EWTI, H0, HMAX, HMX, RH, RTOLI, 1 TCRIT, TNEXT, TOLSF, TP, RJNORM, SIZE, VNORM, DAMP, CRATE, 2 ELS, ELC, WB, TS, ELOLD, YDNORM LOGICAL IHIT, SFILTR CHARACTER *200 ERRMSG C----------------------------------------------------------------------- C THE FOLLOWING INTERNAL COMMON BLOCKS ARE DEFINED AS FOLLOWS; C TRACE; CONTAINS TRACE LEVEL AND CHANNEL FOR DEBUGGING C LSTATS;CONTAINS THE INTEGRATION STATISTICS PARAMETERS SUCH C NUMBER OF JACOBIAN EVALUATIONS AND STEPS. THE PARAMETER C NINTER CONTAINS THE EFFECTIVE SIZE OF THE MEMORY ARRAY C YH(NEQMAX,NINTER) IF INTERPOLATION IS TO BE USED ON IT. C LSIZES;CONTAINS THE VARIABLES USED IN THE TIME MANAGEMENT C SCHEME AND THE WORKSPACE POINTERS. C LSI004;CONTAINS THE COMMUNICATION POINTERS USED IN REVERSE C COMMUNICATION BETWEEN THE TIME MANAGEMENT SCHEME AND C THE MODULES CALLED BY IT. C LSI005; CONTAINS THE VALUE OF EL0 USED WHEN THE JACOBIAN WAS C FORMED. C C SCONS1; CONTAINS THE IFIP TRANSPORTABLE NUMERICAL SOFTWARE C PARAMETERS WHICH ARE INITIALISED IN THE BLOCK DATA . C SSOLVR; CONTAINS INFORMATION USED BY THE NONLINEAR EQUATIONS C SOLVER CAN BE USED BY THE STEP MODULE TO IMPLEMENT C A DAMPED NEWTON METHOD OR TO GOVERN THE NUMBER OF C ITERATIONS PERFORMED. C SSNORM; PASSES THE TYPE OF NORM TO BE USED TO THE FUNCTION VNORM. C C SORDER; DIAGNOSTIC INFO ON THE NUMBER OF STEPS TAKEN AND STEP C LENGTH AT A GIVEN ORDER. C C SLSZ06; CONTAINS YDOT FILTER INFORMATION .I.E. WHETHER TO USE C THE FILTER AND WHAT THE NORM OF THE YDOTS IS. C C IMPORTANT C --------- C THE RESIDUAL, STEP, NONLINEAR EQUATIONS AND LINEAR ALGEBRA C MODULES ALL COMMUNICATE BY USING REVERSE COMMUNICATION THROUGH C THE TIME MANAGEMENT SCHEME IN SPRINT. ACCESS TO THESE MODULES IS C ONLY THROUGH THE PARAMETER LIST USED IN SPRINT. INTERNAL C COMMUNICATION BETWEEN THE GROUPS OF ROUTINES WHICH MAKE UP A C MODULE IS BY COMMON BLOCKS. FOR EXAMPLE THERE ARE THREE ROUTINES C IN THE B.D.F./ ADAMS METHOD TIME INTEGRATION MODULE :BDFSET, SPGEAR C AND INTDY. INTERCOMMUNICATION BETWEEN THESE ROUTINES IS VIA COMMON C BLOCKS. C----------------------------------------------------------------------- COMMON /SDEV2/ ITRACE,IDEV COMMON /LSTATS/ NQ, NQU, NST, NRE, NJE, NITER, NINTER COMMON /LSIZES/ INIT, LEWT, LACOR, LSAVR, MXSTEP, MXHNIL, NHNIL, 1 NSLAST, H, EL0, TN, HU, HMIN, HMXI, DSQU, ELS, WB, ELC, TS COMMON /LSI004/ IFUNC, IRES, ISTEP, IER, IEWSET, IOPT, ITASK, 1 ISTATE, IRETUR, IDACNT, IDAOLD, INITL, IODE,ICRASH 2 , IFN, IDACHK COMMON /LSI005/ ELOLD COMMON /SORDER/ NORDER(15),NSTEPS(15),TTAKEN(15), NFSTEP COMMON /SCONS1/ DUNFLO, UROUND, IOVFLO COMMON /SSOLVR/ DAMP, RJNORM, CRATE, MAXIT COMMON /SSNORM/ INORM COMMON /SLSZ06/ YDNORM, SFILTR SAVE /LSTATS/, /LSIZES/, /LSI004/, /SCONS1/, /SSOLVR/, 1 /SSNORM/, /SLSZ06/ DATA MXSTP0/500/, MXHNL0/10/ C----------------------------------------------------------------------- C BLOCK A. C THIS CODE BLOCK IS EXECUTED ON EVERY CALL. C IT TESTS ISTATE AND ITASK FOR LEGALITY AND BRANCHES APPROPIATELY. C IF ISTATE .GT. 1 BUT THE FLAG INIT SHOWS THAT INITIALIZATION HAS C NOT YET BEEN DONE, AN ERROR RETURN OCCURS. C IF ISTATE = 0 OR 1 AND TOUT = T RETURN IMMEDIATELY. C----------------------------------------------------------------------- C COPY THE CONTROL PARAMETERS FROM THE INFORM ARRAY C ISTATE = INFORM(1) ITASK = INFORM(2) IOPT = INFORM(3) C SFILTR = .FALSE. IF(INFORM(14) .EQ. 2)THEN IODE = 1 SFILTR = .TRUE. ELSE IF(INFORM(14) .EQ. 1)THEN IODE = 1 ELSE IODE = 0 END IF IF(SNORM .EQ. 'MAXMUM') THEN INORM = 1 ELSE IF(SNORM .EQ. 'L2NORM') THEN INORM = 2 ELSE IF(SNORM .EQ. 'AVERL2') THEN INORM = 3 ELSE IF(SNORM .EQ. 'MODMAX') THEN INORM = 4 ELSE GOTO 630 END IF IF (ISTATE .LT. 0 .OR. ISTATE .GT. 3) GO TO 601 IF (ITASK .LT. 1 .OR. ITASK .GT. 6) GO TO 602 IF (ISTATE .LE. 1) GO TO 10 IF (INIT .EQ. 0) GO TO 603 IF (ISTATE .EQ. 2) GO TO 200 GO TO 20 10 INIT = 0 IF (TOUT .EQ. T) GOTO 622 C ABORT THE RUN 20 CONTINUE C----------------------------------------------------------------------- C BLOCK B. C THE NEXT CODE BLOCK IS EXECUTED FOR THE INITIAL CALL (ISTATE = 0 OR 1) C OR FOR A CONTINUATION CALL WITH PARAMETER CHANGES (ISTATE = 3). C IT CONTAINS CHECKING OF ALL INPUTS AND VARIOUS INITIALIZATIONS. C C FIRST CHECK LEGALITY OF THE NON-OPTIONAL INPUTS NEQ, ITOL AND IOPT. C----------------------------------------------------------------------- IF (NEQ(1) .LE. 0) GO TO 604 IF (ISTATE .LE. 1) GO TO 25 IF (NEQ(1) .GT. NEQMAX) GO TO 605 25 N = NEQ(1) IF (ITOL .LT. 1 .OR. ITOL .GT. 4) GO TO 606 IF (IOPT .LT. 0 .OR. IOPT .GT. 1) GO TO 607 30 ICRASH = 0 C ICRASH COUNTS THE NUMBER OF STEP ERROR TEST OR CONVERGENCE FAILURES--- C NEXT PROCESS AND CHECK THE OPTIONAL INPUTS. -------------------------- DO 35 I = 1,15 NORDER(I) = 0 NSTEPS(I) = 0 35 TTAKEN(I) = 0.0D0 NFSTEP = 0 IF (IOPT .EQ. 1) GO TO 40 MXSTEP = MXSTP0 MXHNIL = MXHNL0 IF (ISTATE .LE. 1) H0 = 0.0D0 HMXI = 0.0D0 C FOLLOWING MOD RESTRICTS MAX STEP SIZE ON FIRST CALL IF(ISTATE .LE. 1) HMXI = 0.1D0 / (TOUT - T) HMIN = 0.0D0 GO TO 60 40 MXSTEP = INFORM(4) IF (MXSTEP .LT. 0) GO TO 612 IF (MXSTEP .EQ. 0) MXSTEP = MXSTP0 MXHNIL = INFORM(5) IF (MXHNIL .LT. 0) GO TO 613 IF (MXHNIL .EQ. 0) MXHNIL = MXHNL0 IF (ISTATE .GT. 1) GO TO 50 H0 = RWORK(5) IF ((TOUT - T)*H0 .LT. 0.0D0) GO TO 614 50 HMAX = RWORK(6) IF (HMAX .LT. 0.0D0) GO TO 615 HMXI = 0.0D0 IF (HMAX .GT. 0.0D0) HMXI = 1.0D0/HMAX HMIN = RWORK(7) IF (HMIN .LT. 0.0D0) GO TO 616 C----------------------------------------------------------------------- C SET WORK ARRAY POINTERS . C POINTERS TO SEGMENTS OF RWORK ARE NAMED BY PREFIXING L TO C THE NAME OF THE SEGMENT. E.G. THE SEGMENT EWT STARTS AT RWORK(LEWT). C SEGMENTS OF RWORK (IN ORDER) ARE DENOTED EWT, ACOR, SAVR. C----------------------------------------------------------------------- 60 LEWT = 21 LACOR = LEWT + NEQMAX LSAVR = LACOR + NEQMAX LENRW = LSAVR + NEQMAX - 1 INFORM(12) = LENRW IF (LENRW .GT. NRW) GO TO 617 C C CHECK RTOL AND ATOL FOR LEGALITY. C RTOLI = RTOL(1) ATOLI = ATOL(1) DO 70 I = 1,N IEWSET = -I IF (ITOL .GE. 3) RTOLI = RTOL(I) IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) IF (RTOLI .LT. 0.0D0) GO TO 619 IF (ATOLI .LT. 0.0D0) GO TO 620 70 IEWSET = 0 DSQU = DSQRT(UROUND) IF (ISTATE .LE. 1) GO TO 100 C C IF ISTATE = 3, SET FLAG TO SIGNAL PARAMETER CHANGES TO STEP MODULE.--- C ISTEP = 2 GO TO 200 C----------------------------------------------------------------------- C BLOCK C. INITIALISATION BLOCK C THE NEXT BLOCK IS FOR THE INITIAL CALL ONLY (ISTATE = 0 OR 1) OR FOR C A RESTART FORCED BY THE MONITOR ROUTINE. IN THE LATTER CASE THE ENTRY C POINT TO THIS BLOCK IS AT LABEL 109 . C IT CONTAINS ALL REMAINING INITIALIZATIONS AND CALLS TO THE NONLINEAR C SOLVER AND THE CALCULATION OF THE INITIAL STEP SIZE. C THE ERROR WEIGHTS IN EWT ARE INVERTED AFTER BEING LOADED. C----------------------------------------------------------------------- 100 TN = T HU = 0.0D0 IF (ITASK .EQ. 4 .OR. ITASK .EQ. 5) THEN TCRIT = RWORK(1) IF ((TCRIT - TOUT)*(TOUT - T) .LT. 0.0D0) GO TO 625 IF (H0 .NE. 0.0D0 .AND. (T + H0 - TCRIT)*H0 .GT. 0.0D0) 1 H0 = TCRIT - T HMAX = MAX( ABS(TCRIT-T), UROUND) HMXI = MAX( 1.D0/HMAX, HMXI) END IF 105 ISTEP = -1 NHNIL = 0 NST = 0 IFN = 0 NRE = 1 NJE = 0 NSLAST = 0 HU = 0.0D0 NQU = 0 NITER = 0 IF( ISTATE .EQ. 0)THEN C SET YDOTI TO 0 TO PREVENTY UNDEFINED REFERENCES. DO 1051 I = 1,N 1051 YDOTI(I) = 0.0D0 END IF INITL = 1 IF(ISTATE .EQ. 1)INITL = 2 H = H0 C----------------------------------------------------------------------- C CHECK IF THE USER HAS CORRECTLY SPECIFIED THE RESID ROUTINE C WHEN IT IS CALLED WITH IRES = -1 C NOTE; THIS TEST WILL NOT WORK FOR D.A.ES OF THE FORM C A YDOT = C(T) F(Y) WHERE C(0) = 0 OR F(Y(0)) = 0 C BECAUSE AT T= 0 THE ROUTINE IS CORRECT. C ALSO CHECK IF THE USER OVERWRITES Y AND/OR YDOT IN RESID. C THIS TEST COULD BE IMPROVED BY PERTURBING Y AND T SO THAT ANY C ALGEBRAIC EQUATIONS ARE NOT THEN SATISFIED . C---------------------------------------------------------------------- DO 107 I = 1,N RWORK(LSAVR+I-1) = 1.0D0/UROUND YSAVE(I,1) = Y(I) RWORK(LACOR+I-1) = YDOTI(I) 107 YDOTI(I) = 0.0D0 CALL EWSET (N, ITOL, RTOL, ATOL, Y, RWORK(LEWT), IEWSET) IRES = -1 CALL RESID( NEQ, TN, Y, YDOTI, RWORK(LSAVR), IRES, WKRES, NWKRES) K = 0 J = 0 DO 108 I = 1,N IF( DABS( RWORK(LSAVR+I-1)) .GT. DUNFLO ) J=I RWORK(LSAVR+I-1) = DABS( YSAVE(I,1) - Y(I)) + DABS(YDOTI(I)) IF( DABS( RWORK(LSAVR+I-1)) .GT. DUNFLO ) K=I YDOTI(I) = RWORK(LACOR+I-1) Y(I) = YSAVE(I,1) 108 CONTINUE IF( IEWSET.LT. 0) GOTO 621 IF( J .GT. 0) GOTO 628 IF( K .GT. 0)THEN CALL SERROR(' SPRINT - ERROR -THE RESID ROUTINE APPEARS TO 1 OVERWRITE THE Y AND/OR YDOT VECTORS WHEN CALLED. 2 INTEGRATION WILL NOT BE ATTEMPTED .', 1, 0, 3 0, 0, 0, 0.0D0, 0.0D0) GOTO 700 END IF IF( (IRES.GT.1) .OR. (IRES .EQ.0) .OR. (IRES .LT. -1))THEN CALL SERROR(' SPRINT - RESID ROUTINE SET IRES TO (=I1) WHEN 1 CALLED FOR TESTING WITH IRES = -1 AND ZERO YDOT 2 AT TIME T (= R1) . 3 INTEGRATION WILL CONTINUE UNLESS IRES = 2 ', 1, 1, 4 IRES , 0, 1, TN, 0.0D0) IF(IRES .EQ. 2)THEN ISTATE = 3 GOTO 700 END IF END IF C C EXTRA TEST TO ENSURE THAT ALGEBRAIC EQNS ARE O.K. C TEM = T + (TOUT-T) * DSQU DO 1085 I = 1,N YDOTI(I) = 0.0D0 Y(I) = Y(I) + (1.0D0 + DABS(Y(I)))* DSQU*(N+I) / N 1085 CONTINUE IRES = -1 CALL RESID( NEQ, TN, Y, YDOTI, RWORK(LSAVR), IRES, WKRES, NWKRES) J = 0 DO 1086 I = 1,N IF( DABS( RWORK(LSAVR+I-1)) .GT. DUNFLO ) J=I YDOTI(I) = RWORK(LACOR+I-1) Y(I) = YSAVE(I,1) 1086 CONTINUE IF( J .GT. 0) GOTO 628 C END OF TESTING SECTION. 109 NQ = 1 EL0 = 1.0D0 C----------------------------------------------------------------------- C LOAD AND INVERT THE EWT ARRAY AND THEN CALL THE INITIALISATION MODULE C---------------------------------------------------------------------- CALL EWSET (N, ITOL, RTOL, ATOL, Y, RWORK(LEWT), IEWSET) IF(IEWSET.LT.0)GOTO 621 INLN = 0 CALL ITSTEP(NEQ, TN, TOUT, H, Y, YDOTI, RWORK(LEWT), 1 RTOL, ATOL, ITOL) C FOUR NEW LINES 8/88 IF( ITASK .EQ. 4 .OR. ITASK .EQ. 5)THEN HMAX = MAX( ABS(TCRIT-TN), UROUND) HMXI = MAX( 1.D0/HMAX, HMXI) END IF RH = DABS(H)*HMXI*100 IF(RH .GT. 1.0D0)H = H/RH IF(INITL .EQ. 1)THEN TEM = DSQU * 100.0D0 H = DMIN1(DABS(H),TEM) * DSIGN(1.0D0,H) END IF RH = HMIN/DABS(H) IF(RH .GT. 1.0D0)H = H * RH 111 CALL INITDB(N,Y,YDOTI,YSAVE,NEQMAX,RWORK(LSAVR),RWORK(LACOR), 1 INFORM(15), TN, H, INITL, INLN, IODE, HMIN, RWORK(LEWT)) IF(INITL .EQ. 0)THEN IRETUR = 1 GOTO 292 ELSE C TRAP FOR RESID THEN ENTER MONITOR PATH IF(INLN .EQ. -4)THEN IMON = -2 GOTO 305 END IF IF(INITL .EQ. -1)GOTO 560 END IF MAXIT = 3 DAMP = 1.0D0 HU = H INFORM(14) = IODE IF( ITASK .EQ. 6)THEN C RETURN TO THE CALLING PROGRAM WITH CALCULATED INITIAL VALUES. T = TN TOUT= TN ISTATE = 2 GOTO 600 END IF 130 CALL ITSTEP(NEQ, TN, TOUT, H0, Y, YDOTI, RWORK(LEWT), 1 RTOL, ATOL, ITOL) C TO COMPUTE THE INITIAL STEPSIZE H0 , ADJUST IT ON C RETURN TO MEET HMAX BOUND AND LOAD H0 INTO H. C 180 CONTINUE IF( ITASK .EQ. 4 .OR. ITASK .EQ. 5)THEN HMAX = MAX( ABS(TCRIT-TN), UROUND) HMXI = MAX( 1.D0/HMAX, HMXI) END IF RH = DABS(H0)*HMXI H = H0 IF (RH .GT. 1.0D0) H = H0/RH IF (DABS(H) .LT. HMIN)H = HMIN * DSIGN(1.0D0,H0) IF(ITRACE .GE. 1)WRITE(IDEV,181)H 181 FORMAT(' INITIAL STEP SIZE IS ',D12.4) H0 = 0.0D0 INITL = 1 C CHECK TO SEE IF OUTPUT POINT HAS ALREADY BEEN PASSED. IF ((TN - TOUT)*H .GE. 0.0D0) GO TO 200 GOTO 270 C----------------------------------------------------------------------- C BLOCK D. C THE NEXT CODE BLOCK IS FOR CONTINUATION CALLS ONLY (ISTATE = 2 OR 3) C AND IS TO CHECK STOP CONDITIONS BEFORE TAKING A STEP. C----------------------------------------------------------------------- 200 NSLAST = NST GO TO (210, 250, 220, 230, 240), ITASK 210 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 CALL INTDY (TOUT, 0, YSAVE, NEQMAX, Y, IFLAG, NEQ, H) IF (IFLAG .NE. 0) GO TO 627 T = TOUT GO TO 420 220 TP = TN - HU*(1.0D0 + 100.0D0*UROUND) IF ((TP - TOUT)*H .GT. 0.0D0) GO TO 623 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 T = TN GO TO 400 230 TCRIT = RWORK(1) IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 IF ((TCRIT - TOUT)*H .LT. 0.0D0) GO TO 625 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 245 CALL INTDY (TOUT, 0, YSAVE, NEQMAX, Y, IFLAG, NEQ, H) IF (IFLAG .NE. 0) GO TO 627 T = TOUT GO TO 420 240 TCRIT = RWORK(1) IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 245 HMX = DABS(TN) + DABS(H) IHIT = DABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX IF (IHIT) GO TO 360 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) IF (ISTATE .EQ. 2) ISTEP = 3 C----------------------------------------------------------------------- C BLOCK E. C THE NEXT BLOCK IS NORMALLY EXECUTED FOR ALL CALLS AND CONTAINS C THE CALL TO THE STEP CORE INTEGRATOR. C C THIS IS A LOOPING POINT FOR THE INTEGRATION STEPS. C C FIRST CHECK FOR TOO MANY STEPS BEING TAKEN, UPDATE EWT (IF NOT AT C START OF PROBLEM), CHECK FOR TOO MUCH ACCURACY BEING REQUESTED, AND C CHECK FOR H BELOW THE ROUNDOFF LEVEL IN T. C----------------------------------------------------------------------- 250 CONTINUE IF ((NST-NSLAST) .GE. MXSTEP) GO TO 500 CALL EWSET (N, ITOL, RTOL, ATOL, Y, RWORK(LEWT), IEWSET) IF(IEWSET.LT.0)GOTO 510 270 TOLSF = UROUND*VNORM (N, Y, RWORK(LEWT)) IF (TOLSF .LE. 1.0D0) GO TO 280 TOLSF = TOLSF*2.0D0 IF (NST .EQ. 0) GO TO 626 GO TO 520 280 IF ((TN + H) .NE. TN) GO TO 290 NHNIL = NHNIL + 1 IF (NHNIL .GT. MXHNIL) GO TO 290 CALL SERROR(' SPRINT- WARNING..INTERNAL T (=R1) AND H (=R2) ARE 1 SUCH THAT T + H = T ON THE NEXT STEP -SOLVER WILL 2 CONTINUE', 1, 0, 0, 0, 2, TN, H) IF (NHNIL .LT. MXHNIL) GO TO 290 CALL SERROR(' SPRINT- ABOVE WARNING HAS NOW BEEN ISSUED I1 TIMES 1 AND WILL NOT BE USED AGAIN ',1, 1, MXHNIL, 0, 2 0, 0.0D0, 0.0D0) 290 INLN = 0 TS = TN 291 CONTINUE CALL STEP(NEQ, Y, YSAVE, NEQMAX, RWORK(LEWT), YDOTI, RWORK(LSAVR), 1 RWORK(LACOR), INLN, ISTEP, EL0, H, TN, HMIN, HMXI,INFORM(15)) C IRETUR = 0 IF(INLN.GT.0)THEN C REVERSE COMMUNICATIONS CALL TO NLSLVR IN PROGRESS SET THE C RETURN FLAG AND CALL THE SOLVER. IRETUR = 2 GOTO 292 ELSE C FIND THE LARGEST LOCAL ERROR COMPONENT BIG = 0.0D0 DO 260 I = 1,N SIZE = DABS(RWORK(I+LACOR-1)*RWORK(LEWT+I-1)) IF(BIG .LE. SIZE)THEN BIG = SIZE IMXER = I END IF 260 CONTINUE GOTO 299 END IF C----------------------------------------------------------------------- C BLOCK F C ------- CALL TO NONLINEAR EQUATIONS SOLVER PART OF PACKAGE C ************************************************** C C INLN = 1 : SOLVE THE NONLINEAR SYSTEM OF EQUATIONS C AFTER FORMING A NEW JACOBIAN MATRIX. C INLN = 2 : AS FOR INLN = 1 BUT USING THE OLD JACOBIAN. C INLN = 3 : FORM THE RESIDUAL OF THE D.A.E. STARTING C THE VALUES AT RWORK(LSAVR). C INLN = 4 PERFORM ONE BACKSUBSTITUTION ONLY ON THE VECTOR C WHICH STARTS AT RWORK(LSAVR) USING THE ALREADY C FACTORED JACOBIAN MATRIX . C INLN = 5 PETZOLD LOCAL ERROR ESTIMATE- PREMULTIPLY C USUAL LOCAL ERROR ESTIMATE BY DF/DYDOT AND THEN C BY THE INVERSE OF THE JACOBIAN. C INLN = 6 SOLVE THE NONLINEAR SYSTEM OF EQUATIONS USING C FUNCTIONAL ITERATION. C INLN = 7 SOLVE FOR THE INITIAL VALUES OF THE ALGEBRAIC EQNS C AND FOR THE INITIAL DERIVATIVES USING FUNCTIONAL C ITERATION . THIS ASSUMES THAT BOTH THE ALGEBRAIC C AND DIFFERENTIAL PARTS ARE WRITTEN IN NORMAL FORM. C INLN = 8 AS FOR INLN = 3 BUT WITH IRES = -1 C C C----------------------------------------------------------------------- 292 IDACHK = 0 IF((INLN .GT. 2 .AND. INLN .LT. 6) .OR. INLN .EQ.8)THEN C AVOID THE CALL TO NLSLVR IFUNC = INLN IF(IFUNC.EQ.4)GOTO 296 GOTO 2921 ELSE IF (INLN .EQ. 6)THEN IFN = IFN + 1 IF(MOD(IFN,9) .EQ. 8)IDACHK = 1 C CHECK O.D.E./D.A.E. SPLIT FOR F/ITER ELSE IF (INLN .EQ. 1)THEN IF(MOD(NJE,9) .EQ. 8)IDACHK = 1 C CHECK O.D.E./D.A.E. SPLIT FOR NEWTON END IF 2920 CALL NLSLVR (NEQ, Y, YDOTI, YSAVE, NEQMAX, RWORK(LSAVR), 1 RWORK(LACOR), RWORK(LEWT), IFUNC, INLN, H, EL0, INFORM(15)) C C IF IFUNC = 0 RETURN TO CALLING POINT AS SOLVER HAS FINISHED C IF(IFUNC.EQ.0)GOTO 297 2921 CONTINUE IF(IFUNC .EQ. 5)THEN C RESID EVAL WITH DIFFERENT PARAMETER LIST FOR PETZOLD ERR EST DO 2923 I = 1,N 2923 RWORK(LSAVR+I-1) = 0.0D0 IRES = -1 CALL RESID(NEQ,TN, Y, RWORK(LACOR), RWORK(LSAVR), IRES, 1 WKRES, NWKRES) ELSE IF(IDACHK .EQ. 1)THEN C PERIODICALLY CHECK ALGEBRAIC - DIFF. EQN SPLIT CALL DAECHK( NEQ, TN, Y, YDOTI, YSAVE, NEQMAX, RWORK(LSAVR), 1 RWORK(LACOR), RWORK(LEWT), H, EL0, INFORM(15), RESID, 2 IRES, WKRES, NWKRES) I = IRES * IRES IF( I .NE. 1)GOTO 2965 IDACHK = 0 END IF DO 2922 I = 1,N 2922 RWORK(LSAVR+I-1) = 0.0D0 C ORDINARY RESIDUAL EVALUATION TO PUT SAVR TO WHAT IT SHOULD BE IRES = 1 IF(IFUNC .EQ. 8)IRES = -1 CALL RESID (NEQ,TN,Y,YDOTI,RWORK(LSAVR),IRES,WKRES,NWKRES) END IF NRE = NRE + 1 I = IRES * IRES IF(I .NE. 1)GOTO 2965 GOTO (2935, 296, 297, 2920, 296, 2920, 2920, 297),IFUNC C C JACOBIAN EVALUATION 2935 IFJ = 0 NJE = NJE + 1 ELS = H * EL0 ELOLD = EL0 294 CALL JACFRM ( NEQ, Y, YSAVE, NEQMAX, RWORK(LEWT), RWORK(LACOR), 1 RWORK(LSAVR), YDOTI, WKJAC, JACPVT, IFJ, H, EL0, 2 TN, IFUNC, JAC, INFORM(15)) C IF(IFJ.GT.0)THEN C DIFFERENCING IS BEING USED TO FORM THE JACOBIAN. IRES = 1 CALL RESID(NEQ,TN,Y,YDOTI,RWORK(LACOR),IRES,WKRES,NWKRES) NRE = NRE + 1 I = IRES * IRES IF(I .NE. 1)GOTO 2965 GOTO 294 ELSE IF(IFJ.EQ.-1)THEN INLN = -1 GOTO 297 ELSE IF(IFJ .LE. -2)THEN INLN = -5 GOTO 297 END IF C C BACKSUBSTITUTION FOLLOWED BY A RETURN TO NLSLVR 296 NITER = NITER + 1 C SCALE THE RESIDUAL VECTOR BY THE RELAX FACTOR ELC = EL0* H WB = ELC * ELS * 2.0D0 / (ELC + ELS) - 1 DO 295 I = 1,N 295 RWORK(LSAVR+I-1) = RWORK(LSAVR+I-1) * (INFORM(14+I)*WB + 1) J = 0 CALL BACKSB( WKJAC, JACPVT, RWORK(LSAVR), NEQ, J) IF(J .NE. 0)INLN = -5 IF(INLN .EQ. 0)GOTO 2920 GOTO 297 C C ERROR IN RESIDUAL FORMATION 2965 INLN = - IRES IF( (IRES.GT.4) .OR. (IRES.EQ.0) .OR. (IRES.LT.-2))THEN ERRMSG=' SPRINT-ERROR THE USER-SUPPLIED RESID ROUTINE HAS 1 ILLEGALLY SET IRES (=I1) . IRES HAS BEEN RESET 3 TO TRY 2 AND CONTINUE THE INTEGRATION ' CALL SERROR( ERRMSG, 1, 1, IRES, 0, 0, 0.0D0, 0.0D0) IRES = 3 INLN = -3 END IF C C RETURN TO THE PROGRAM SEGMENT WHICH CALLED THE SOLVER 297 IFUNC = 0 GOTO (111, 291, 305), IRETUR C C----------------------------------------------------------------------- C BLOCK G C EXIT FROM THE STEP MODULE- CHECK IF MONITR IS TO BE CALLED C----------------------------------------------------------------------- 299 CONTINUE IF(IRES .EQ. 4)THEN IMON = -2 GOTO 305 ELSE IF(ISTEP .EQ. -1 .OR. ISTEP .EQ. -2)THEN IMON = -1 ENDIF KGO = 2 - ISTEP GO TO (300, 292, 305, 305, 400, 530, 530, 700, 650), KGO C 1 2 3 4 5 6 7 8 9 C KGO = 1,SUCCESS. 2, CALL TO NLSLVR. 3,ERROR TEST FAILURE. C 4, CONVERGENCE FAILURE. 5,RES ORDERED RETURN. C 6, RES RETURNED ERROR. , 7 SINGULAR JACOBIAN MATRIX . C 8, NO CALL TO INIT MODULE,9, IMPOSS ERR IN LINEAR ALGEBRA . 300 INIT = 1 HU = TN - TS NST = NST + 1 IMON = 1 305 CALL MONITR(NEQ, TN, HU, H, Y, YDOTI, YSAVE, NEQMAX, RWORK(LSAVR), 1 RWORK(LEWT), WKRES, NWKRES, WKMON, NWKMON, IMON, INLN, 2 HMIN, HMAX) IF(HMAX .LT. 0.0D0)THEN GOTO 615 ELSE HMXI = 0.0D0 IF(IOPT .EQ. 1 .AND. RWORK(6) .GT. 0.0D0)HMXI=1.D0/RWORK(6) IF(HMAX .GT. 0.0D0)HMXI = 1.0D0/HMAX END IF IF(NEQ(1) .NE. N)THEN C THE DIMENSION OF THE O.D.E. SYSTEM HAS CHANGED. IF(NEQ(1) .GT. NEQMAX)GOTO 629 IF(NEQ(1) .LT. 1)GOTO 604 N = NEQ(1) END IF IF(IMON .EQ. 0)IRETUR = 3 IF(IMON .EQ. 2)THEN ISTATE = 1 ISTEP = -1 H0 = H END IF IF(IMON .EQ. 3 .OR. IMON .EQ. 4) THEN I = ISTEP ISTEP = IMON - 1 IF(I.LT.0)GOTO 290 END IF IF(IMON .EQ. -1 .AND. ISTEP .LT. 0)IMON = -3 I = IMON + 4 C -3 -2 -1 0 1 2 3 4 IMON GOTO ( 450, 400, 565, 292, 306, 109, 306, 306), I C RESTART ERROR NON- RE- NORMAL CONTINUE C RETURNS LIN SOLVER START GOTO 565 C----------------------------------------------------------------------- C BLOCK H :HANDLES A SUCCESSFUL RETURN FROM THE CORE INTEGRATOR,ISTEP=1. C THE TEST FOR STOP CONDITIONS IS MADE ,ON FAILURE WE JUMP TO LABEL 250. C IF THESTOP CONDITIONS ARE SATISFIED AND ITASK .NE. 1 ,Y IS LOADED FROM C YH AND T IS SET ACCORDINGLY. THE RETURN IS MADE USING LABEL 600 . C----------------------------------------------------------------------- 306 IF(ITRACE.GE.1)WRITE(IDEV,301)TN,HU,NQU,IMXER NORDER(NQU) = NQU NSTEPS(NQU) = NSTEPS(NQU)+1 TTAKEN(NQU) = TTAKEN(NQU) + HU 301 FORMAT(' TIME=',D11.3,' STEP H=',D11.3,' ORDER K=',I5, 1 ' MAX. ERR. COMP=',I6) TEM = - TOUT * 10.0D0 * H * UROUND ICRASH = 0 GO TO (310, 335, 330, 340, 350), ITASK C C ITASK = 1. IF TOUT HAS BEEN REACHED, INTERPOLATE. C 310 IF ((TN - TOUT)*H .LT. TEM) GO TO 250 CALL INTDY (TOUT, 0, YSAVE, NEQMAX, Y, IFLAG, NEQ, H) T = TOUT GO TO 420 C C ITASK =2,3. JUMP TO EXIT IF TOUT WAS REACHED. C 330 IF ((TN - TOUT)*H .LT. TEM) GO TO 250 335 T = TN GO TO 400 C C ITASK = 4. SEE IF TOUT OR TCRIT WAS REACHED AND ADJUST H. C 340 IF ((TN - TOUT)*H .LT. TEM) THEN HMX = DABS(TN) + DABS(H) IHIT = DABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX IF (IHIT) GO TO 360 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) IF ((TNEXT - TCRIT)*H .GT. 0.0D0) THEN H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) ISTEP = 3 END IF HMAX = MIN( ABS(TCRIT-TN), ABS(TOUT-TN)) HMAX = MAX( HMAX, UROUND) HMXI = MAX( 1.D0/HMAX, HMXI) GO TO 250 ELSE CALL INTDY ( TOUT,0, YSAVE, NEQMAX, Y, IFLAG, NEQ, H) T = TOUT GO TO 420 END IF C C ITASK = 5. SEE IF TCRIT WAS REACHED AND JUMP TO EXIT. C 350 HMX = DABS(TN) + DABS(H) IHIT = DABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX 360 IF(IHIT) T = TCRIT C . C A SUCCESSFUL RETURN FROM SPRINT. SET Y FROM YH AND JUMP TO LABEL 600 C 400 DO 410 I = 1,N 410 Y(I) = YSAVE(I,1) 420 ISTATE = 2 IF ( ISTEP .EQ. -3 ) ISTATE = 3 IF ( IMON .EQ. -2 ) THEN ISTATE = 4 GOTO 595 END IF GOTO 600 C----------------------------------------------------------------------- C BLOCK I C THIS BLOCK ENTERED AFTER ERROR TEST OR CONVERGENCE FAILURES AND C PROVIDING THAT THE MONITR ROUTINE HAS NOT SET IMON = -2 C ICRASH COUNTS THE FAILURES AND ALLOWS A MAXIMUM OF THREE PER STEP. C----------------------------------------------------------------------- 450 ICRASH = ICRASH + 1 IF(ICRASH .EQ. 3)GOTO 530 C ELSE RESTART MODE IF(ITRACE .GE. 1)WRITE(IDEV,451)TN 451 FORMAT(' RESTART IN PROGRESS AT TIME ',D11.3) DO 460 I = 1,N 460 YDOTI(I) = 0.0D0 H = H * 0.1D0 H0 = H ISTEP = -1 INITL = 1 GOTO 109 C----------------------------------------------------------------------- C BLOCK J. C THE FOLLOWING BLOCK HANDLES ALL RETURNS OTHER THAN THOSE FOR ILLEGAL C INPUT. IN THE CASE OF INTEGRATOR FAILURE THE ERROR MESSAGE ROUTINE IS C CALLED Y IS LOADED FROM YH AND T IS SET TO TN. IN EITHER CASE THE . C OPTIONAL OUTPUTS ARE LOADED INTO THE WORK ARRAYS BEFORE RETURNING. C----------------------------------------------------------------------- C THE MAXIMUM NUMBER OF STEPS WAS TAKEN BEFORE REACHING TOUT. C 500 CALL SERROR(' SPRINT- AT CURRENT TIME (=R1), MAX NO OF ALLOWED 1STEPS (=I1) ON THIS CALL WAS TAKEN BEFORE REACHING THE NEXT 2OUTPUT POINT TOUT (=R2) ', 1, 1, MXSTEP, 0, 2, TN, TOUT) ISTATE = -1 GO TO 590 C EWT(I) .LE. 0.0 FOR SOME I (NOT AT START OF PROBLEM). ---------------- 510 EWTI = RWORK(LEWT+I-1) I =-IEWSET CALL SERROR(' SPRINT- AT T (=R1), THE ERROR TEST WEIGHT COMPONENT 1 EWT(I1) HAS BECOME R2 .LE. 0. CHECK THE VALUES OF ATOL RTOL AND 1 ITOL SUPPLIED ( ATOL(I1) AND RTOL(I1) IF ARRAYS ARE BEING USED).' 1 ,1, 1, I, 0, 2, TN, EWTI) ISTATE = -6 GO TO 590 C TOO MUCH ACCURACY REQUESTED FOR MACHINE PRECISION. ------------------- 520 CALL SERROR(' SPRINT- AT T (=R1), TOO MUCH ACCURACY REQUESTED 1FOR PRECISION OF MACHINE . SEE OPTIONAL OUTPUT RWORK(14) (=R2)', 2 1, 0, 0, 0, 2, TN, TOLSF) RWORK(14) = TOLSF ISTATE = -2 GO TO 590 C C ERROR RETURNS FOR VALUES OF ISTEP = -1, -2 OR -4 C 530 IF(ISTEP .EQ. -4) THEN ISTATE = -7 GOTO 590 ELSE ISTATE = ISTEP -3 IF(ISTATE .EQ. -8)ISTATE = -9 GOTO 570 ENDIF C C INITIALISATION FAILED IN INITAL C 560 CALL SERROR(' SPRINT- ATTEMPT TO INITIALIZE DY/DT AND Y FAILED IN 1 THE ROUTINE INITAL.', 1, 0, 0, 0, 0, 0.0D0, 0.0D0) ISTATE = -8 GOTO 800 565 CALL SERROR(' SPRINT - MONITR ROUTINE ERROR- ILLEGAL VALUE OF IMON 1 (=I1) RETURNED TO SPRINT', 1, 1, IMON, 0, 0, 0.0D0, 0.0D0) ISTATE = -3 GOTO 800 C C COMPUTE IMXER IF RELEVANT. ------------------------------------------- C 570 BIG = 0.0D0 IMXER = 1 DO 575 I = 1,N SIZE = DABS(RWORK(I+LACOR-1)*RWORK(I+LEWT-1)) IF (BIG .LT. SIZE) THEN BIG = SIZE IMXER = I END IF 575 CONTINUE C C SET Y VECTOR AND T C 590 DO 592 I = 1,N 592 Y(I) = YSAVE(I,1) 595 T = TN C*********************************************************************** C EXIT POINT FOR SUCCESSFUL RUNS OR FOR RUN TIME FAILURES. * C LOAD ISTATE AND THE OPTIONAL OUTPUTS * C*********************************************************************** 600 RWORK(11) = HU RWORK(12) = H RWORK(13) = TN INFORM(1) = ISTATE INFORM(6) = NST INFORM(7) = NRE INFORM(8) = NJE INFORM(9) = NQU INFORM(12) = NQ INFORM(11) = NITER INFORM(12) = LENRW INFORM(13) = IMXER RETURN C----------------------------------------------------------------------- C BLOCK K. C THE FOLLOWING BLOCK HANDLES ALL ERROR RETURNS DUE TO ILLEGAL INPUT C (ISTATE = -3), AS DETECTED BEFORE CALLING THE CORE INTEGRATOR. C FIRST THE ERROR MESSAGE ROUTINE IS CALLED AND THEN THE RUN IS HALTED. C----------------------------------------------------------------------- C 601 ERRMSG = ' SPRINT- THE INPUT VALUE OF INFORM(1) (CALLED 1 ISTATE IN SPRINT) HAS ILLEGAL VALUE (=I1)' CALL SERROR( ERRMSG, 1, 1, ISTATE, 0,0, 0.0D0, 0.0D0) GO TO 700 602 ERRMSG = ' SPRINT- THE INPUT VALUE OF INFORM(2) (CALLED ITASK 1 IN SPRINT ) HAS ILLEGAL VALUE (=I1) ' CALL SERROR( ERRMSG, 1, 1, ITASK, 0, 0, 0.0D0, 0.0D0) GO TO 700 603 ERRMSG = ' SPRINT- THE INPUT VALUE OF INFORM(1) (CALLED ISTATE 1 IN SPRINT) IS .GT. 1 BUT SPRINT HAS NOT BEEN INITIALIZED ' CALL SERROR( ERRMSG, 1, 0, 0, 0, 0, 0.0D0, 0.0D0) GO TO 700 604 ERRMSG = ' SPRINT- NEQ THE NUMBER OF DIFFERENTIAL EQUATIONS 1 HAS ILLEGAL VALUE (=I1) .LT. 1' CALL SERROR( ERRMSG, 1, 1, NEQ(1), 0, 0,0.0D0, 0.0D0) GO TO 700 605 ERRMSG = ' SPRINT- INFORM(1) (CALLED ISTATE IN SPRINT ) HAS 1 BEEN SET=3 AND NEQ (=I1) .GT. NEQMAX (=I2)' CALL SERROR( ERRMSG, 1, 2, NEQ(1), NEQMAX, 0, 0.0D0, 0.0D0) GO TO 700 606 ERRMSG = ' SPRINT- ITOL (=I1) ILLEGAL' CALL SERROR(ERRMSG, 1, 1, ITOL, 0, 0,0.0D0, 0.0D0) GO TO 700 607 ERRMSG = ' SPRINT- THE VALUE OF INFORM(3) (CALLED IOPT IN 1 SPRINT ) IS (=I1) WHICH IS ILLEGAL' CALL SERROR( ERRMSG, 1, 1, IOPT, 0, 0,0.0D0, 0.0D0) GO TO 700 612 ERRMSG = ' SPRINT- THE OPTIONAL INPUT INFORM(4) (CALLED 1 MXSTEP IN SPRINT ) HAS ILLEGAL VALUE (=I1) .LT. 0 ' CALL SERROR(ERRMSG, 1, 1, MXSTEP, 0, 0, 0.0D0, 0.0D0) GO TO 700 613 ERRMSG = ' SPRINT- THE OPTIONAL INPUT INFORM(5) (CALLED 1 MXHNIL IN SPRINT ) HAS ILLEGAL VALUE (=I1) .LT. 0 ' CALL SERROR(ERRMSG, 1, 1, MXNHIL, 0, 0, 0.0D0, 0.0D0) GO TO 700 614 ERRMSG = ' SPRINT- TOUT (=R1) BEHIND T (=R2) ' CALL SERROR(ERRMSG, 1, 0 ,0, 0, 2, TOUT, T) ERRMSG = ' INTEGRATION DIRECTION IS GIVEN BY THE OPTIONAL 1 INPUT RWORK(5) (CALLED H0 IN SPRINT) (=R1) ' CALL SERROR( ERRMSG, 1, 0, 0, 0, 1, H0, 0.0D0) GO TO 700 615 ERRMSG = ' SPRINT- THE OPTIONAL INPUT RWORK(6) HAS PROVIDED AN 1 ILLEGAL MAX. STEPSIZE (=R1) .LT. 0.0 ' CALL SERROR( ERRMSG, 1, 0, 0, 0, 1, HMAX, 0.0D0) GO TO 700 616 ERRMSG = ' SPRINT- THE OPTIONAL INPUT RWORK(7) HAS PROVIDED AN 1 ILLEGAL MIN. STEPSIZE (=R1) .LT. 0.0 ' CALL SERROR(ERRMSG, 1, 0, 0, 0, 1, HMIN,0.0D0) GO TO 700 617 ERRMSG = ' SPRINT- RWORK LENGTH NEEDED, LENRW (=I1), EXCEEDS 1 NRW (=I2)' CALL SERROR( ERRMSG, 1, 2, LENRW, NRW, 0, 0.0D0, 0.0D0) GO TO 700 619 ERRMSG = ' SPRINT- THE ERROR TEST WEIGHT COMPONENT RTOL(=I1) 1 IS R1 .LE. 0. CHECK THE VALUE OF RTOL SUPPLIED (RTOL(I1) IF 1 IF AN ARRAY IS BEING USED).' I =-IEWSET CALL SERROR( ERRMSG, 1, 1, I, 0, 1, RTOLI, 0.0D0) GO TO 700 620 ERRMSG = ' SPRINT- THE ERROR TEST WEIGHT COMPONENT ATOL(=I1) 1 IS R1 .LE. 0. CHECK THE VALUE OF ATOL SUPPLIED (ATOL(I1) IF 1 IF AN ARRAY IS BEING USED).' I =-IEWSET CALL SERROR(ERRMSG, 1, 1, I, 0, 1,ATOLI, 0.0D0) GO TO 700 621 EWTI = RWORK(LEWT+I-1) ERRMSG = ' SPRINT- EWT(=I1) IS R1 .LE. 0.0 ' CALL SERROR( ERRMSG, 1, 1, I, 0, 1,EWTI, 0.0D0) GO TO 700 622 ERRMSG = 1 ' SPRINT- TOUT (=R1) TOO CLOSE TO T(=R2) TO START INTEGRATION' CALL SERROR( ERRMSG, 1, 0, 0, 0, 2, TOUT, T) GO TO 700 623 ERRMSG = ' SPRINT THE VALUE OF INFORM(2) (CALLED ITASK IN 1 SPRINT) IS (=I1) AND TOUT (=R1) BEHIND TCUR - HU (= R2) ' CALL SERROR( ERRMSG, 1, 1, ITASK, 0, 2, TOUT, TP) GO TO 700 624 ERRMSG = ' SPRINT THE VALUE OF INFORM(2) (CALLED ITASK IN 1 SPRINT) IS = 4 OR 5 AND THE OPTIONAL INPUT RWORK(1) (NAMED 1 TCRIT) (=R1) IS BEHIND CURRENT TIME (=R2) ' CALL SERROR( ERRMSG, 1, 0, 0, 0, 2, TCRIT, TN) GO TO 700 625 ERRMSG = ' SPRINT THE INPUT INFORM(2) (NAME IN SPRINT -ITASK) 1 HAS BEEN SET TO 4 OR 5 AND THE OPTIONAL INPUT RWORK(1) (NAME 2 TCRIT) HAS VALUE (=R1) BEHIND TOUT (=R2) ' CALL SERROR( ERRMSG, 1, 0, 0, 0, 2, TCRIT, TOUT) GO TO 700 626 ERRMSG = ' SPRINT- AT START OF PROBLEM, TOO MUCH ACCURACY' CALL SERROR( ERRMSG, 1, 0, 0, 0, 0, 0.0D0, 0.0D0) ERRMSG = 1 ' REQUESTED FOR PRECISION OF MACHINE. SEE TOLSF (=R1) AND THE 2 DOCUMENTATION ON OPTIONAL OUTPUTS FOR THE MEANING OF THIS 3 VALUE (OUTPUT AS RWORK(14)) ' CALL SERROR( ERRMSG, 1, 0, 0, 0, 1, TOLSF, 0.0D0) RWORK(14) = TOLSF GO TO 700 627 ERRMSG = ' SPRINT- TROUBLE FROM INTERNAL TIME INTERPOLATION 1 ROUTINE INTDY WHEN INFORM(2) (ITASK) =I1, AND TOUT = R1' CALL SERROR( ERRMSG, 1, 1, ITASK, 0, 1, TOUT, 0.0D0) GO TO 700 628 ERRMSG = ' SPRINT- ERROR THE USER SUPPLIED ROUTINE THAT FORMS 1 THE RESIDUAL OF THE O.D.E. SYSTEM HAS NOT BEEN 2 WRITTEN TO HANDLE THE CASE IRES = -1 CORRECTLY.' CALL SERROR( ERRMSG, 1, 0, 0, 0, 0, 0.0D0, 0.0D0) ERRMSG = ' SPRINT- NOTE THAT WHEN THIS ROUTINE IS ENTERED 1 WITH IRES = -1 THE RESIDUALS OF ANY ALGEBRAIC EQUATIONS 2 MUST BE SET TO ZERO.' CALL SERROR( ERRMSG, 1, 0, 0, 0, 0, 0.0D0, 0.0D0) ERRMSG = ' SPRINT CALLED THE RESIDUAL ROUTINE WITH IRES=-1 AND 1 WITH A ZERO YDOT VECTOR - THE RESIDUAL OF O.D.E. 2 EQUATION (=I1) WAS NOT SET TO ZERO AS EXPECTED . ' CALL SERROR( ERRMSG, 1, 1, J, 0, 0, 0.0D0, 0.0D0) GO TO 700 629 ERRMSG = ' SPRINT- MONITOR ERROR-SIZE OF O.D.E. SYSTEM WAS 1 ILLEGALLY INCREASED TO (=I1), IS GREATER THAN NEQMAX (=I2)' CALL SERROR( ERRMSG, 1, 2,NEQ(1), NEQMAX, 0, 0.0D0, 0.0D0) GOTO 700 630 ERRMSG = ' SPRINT- SNORM IS NOT MAXMUM OR L2NORM OR AVERL2 1 OR MODMAX' CALL SERROR( ERRMSG, 1, 0, 0, 0, 0, 0.0D0, 0.0D0) GOTO 700 650 ERRMSG = ' SPRINT RUN ABORTED AS WORKSPACE ERROR OCCURED IN THE 1 LINEAR ALGEBRA ROUTINES -CHECK ARRAY SIZES ' CALL SERROR( ERRMSG, 1, 0, 0, 0, 0, 0.0D0, 0.0D0) ISTATE = -10 GOTO 800 C 700 ERRMSG = ' SPRINT- RUN ABORTED BECAUSE OF ILLEGAL INPUT ' CALL SERROR( ERRMSG, 1, 0, 0, 0, 0, 0.0D0, 0.0D0) 800 ERRMSG = ' SPRINT- RUN ABORTED.' CALL SERROR( ERRMSG, 1, 0, 0, 0, 0, 0.0D0, 0.0D0) C*********************************************************************** C OUTPUT POINT FOR ILLEGAL INPUTS * C COPY BACK ISTATE PARAMETER * C*********************************************************************** INFORM(1) = ISTATE RETURN C----------------------- END OF SUBROUTINE SPRINT----------------------- END SUBROUTINE INTDY (T, K, YH, NYH, DKY, IFLAG, NEQ, H) C----------------------------------------------------------------------- C DRIVER FOR DIFFERENT TIME INTERPOLATION ROUTINES C---------------------------------------------------------------------- INTEGER K, NYH, IFLAG, NEQ(1) , NIDUM, NQU, NQN, NDUM DOUBLE PRECISION T, YH, DKY, H , DDUM, DDUM2, TN CHARACTER*6 ODCODE DIMENSION YH(NYH,1), DKY(1) COMMON /ODECHK/ ODCODE COMMON /LSIZES/ NIDUM(8), DDUM(2), TN, DDUM2(8) COMMON /LSTATS/ NQN, NQU, NDUM(5) SAVE /ODECHK/ , /LSTATS/, /LSIZES/ C----------------------------------------------------------------------- C INTDY COMPUTES INTERPOLATED VALUES OF THE K-TH DERIVATIVE OF THE C DEPENDENT VARIABLE VECTOR Y, AND STORES IT IN DKY. THIS ROUTINE C IS CALLED WITHIN THE PACKAGE WITH K = 0 AND T = TOUT, BUT MAY C ALSO BE CALLED BY THE USER FOR ANY K UP TO THE CURRENT ORDER. C THE INPUT PARAMETERS ARE.. C C T = VALUE OF INDEPENDENT VARIABLE WHERE ANSWERS ARE DESIRED C (NORMALLY THE SAME AS THE T LAST RETURNED BY SPRINT). C FOR VALID RESULTS, T MUST LIE BETWEEN TCUR - HU AND TCUR. C (SEE OPTIONAL OUTPUTS FOR TCUR AND HU.) C K = INTEGER ORDER OF THE DERIVATIVE DESIRED. K MUST SATISFY C 0 .LE. K .LE. INTER, WHERE INTER IS THE CURRENT ORDER C FOR THE SPGEAR AND SBLEND CODES AND INTER IS 1 FOR THE C SPDASL CODE AND 2 FOR THE STHETA OR STHETB CODES C YH = THE HISTORY ARRAY YH C NYH = COLUMN LENGTH OF YH, EQUAL TO THE INITIAL VALUE OF NEQ. C NEQ(1) = THE NUMBER OF ORDINARY DIFFERENTIAL EQUATIONS C H = CURRENT STEPSIZE. C C THE OUTPUT PARAMETERS ARE.. C C DKY = A REAL ARRAY OF LENGTH NEQ CONTAINING THE COMPUTED VALUE C OF THE K-TH DERIVATIVE OF Y(T). C IFLAG = INTEGER FLAG, RETURNED AS 0 IF K AND T WERE LEGAL, C -1 IF K WAS ILLEGAL, AND -2 IF T WAS ILLEGAL. C----------------------------------------------------------------------- IF( ODCODE .EQ. 'SPGEAR')THEN CALL SPGINT(T, K, YH, NYH, DKY, IFLAG, NEQ, H) ELSE IF( ODCODE .EQ. 'STHETA' .OR. ODCODE .EQ. 'STHETB')THEN CALL SPTINT(T, K, YH, NYH, DKY, IFLAG, NEQ, H) ELSE IF( ODCODE .EQ. 'SBLEND')THEN CALL SPBINT(T, K, YH, NYH, DKY, IFLAG, NEQ, H) ELSE IF( ODCODE .EQ. 'SPDASL')THEN IF(K .GT. 1)THEN CALL SERROR(' SPRINT INTERNAL TIME INTERPOLATION 1 ROUTINE INTDY ERROR THE ORDER K(=I1) IS ILLEGAL WITH 2 THE SPDASL INTEGRATOR.',1,1,K,0,0,0.0D0,0.0D0) IFLAG = -1 ELSE CALL SPDINT( TN, T, DKY, NEQ, NQU, YH, NYH, K) END IF END IF RETURN C----------------------- END OF SUBROUTINE INTDY ----------------------- END SUBROUTINE DAECHK( NEQ, T, Y, YDOTI, YH, NYH, SAVR, ACOR, EWT, 1 H, EL0, IDAE, RESID, IRES, WKRES, NWKRES) C----------------------------------------------------------------------- C ROUTINE TO CHECK THE SPLIT BETWEEN ALGEBRAIC AND DIFFERENTIAL EQNS. C THIS ROUTINE IS CALLED EVERY 5 JACOBIAN EVALUATIONS OR SO. C INPUT PARAMETERS C----------------- C NEQ : NUMBER OF ORDINARY DIFFERENTIAL EQUATIONS. C T CURRENT TIME LEVEL. C Y(N) PREDICTED SOLUTION FOR THE SYSTEM OF NONLINEAR C EQUATIONS. C YDOTI(N) PREDICTED TIME DERIVATIVE FOR THE SYSTEM OF EQNS C YH(NYH,N) NORSIECK VECTOR CONTAINING OLD VALUES OF C SOLUTION AND TIME DERIVATIVES. C ACOR (N) USED TO HOLD ACCUMULATED CORRECCTION VALUES. C SAVR (N) ARRAY WHICH HOLD THE RESULT OF CURRENT RESIDUAL C EVAL USING Y AND YDOTI. C EWT (N) ERROR WEIGHTS USED IN NORM FORMATION C H, EL0 STEPSIZE AND ORDER COEFFICIENT C IDAE(N) INDICATOR ARRAY THAT IS TO BE UPDATED BY THIS C ROUTINE. IDAE(I) = 1 STATES THAT EQUATION I C DEPENDS ON THE VECTOR YDOTI. IDAE(I) = 0 STATES C THAT EQUATION (I) DOES NOT DEPEND ON YDOTI C RESID NAME OF THE ROUTINE USED TO EVALUATE THE RESIDUAL C OF THE SYSTEM OF DIFFERENTIAL EQUATIONS. C IRES INDICATOR RETURNED FROM RESID ROUTINE , IF THIS C IS NOT SET TO 1 THE DAE CHECKING PROCESS IS C TERMINATED C WKRES THE WORKSPACE FOR THE RESIDUAL ROUTINE C NWKRES THE SIZE OF THE WORKSPACE WKRES. C C----------------------------------------------------------------------- INTEGER NYH, IDAE(1), IRES, NEQ(1), NWKRES DOUBLE PRECISION Y(1),YDOTI(1),SAVR(1),ACOR(1),EWT(1),YH(NYH,1), 1 WKRES(NWKRES), T INTEGER I, ITRACE, IDEV, IOVFLO, N, ICOUNT, JCOUNT INTEGER NQ, NQU, NST, NRE, NJE, NITER, NINTER DOUBLE PRECISION EL0, H, UROUND, DREL DOUBLE PRECISION EL1H, VNORM, SRUR, FAC, R0, YI, TEM, R COMMON /SCONS1/ DREL, UROUND, IOVFLO COMMON /LSTATS/ NQ, NQU, NST, NRE, NJE, NITER, NINTER COMMON /SDEV2/ ITRACE, IDEV IF(ITRACE .GE. 2)WRITE(IDEV,1999) 1999 FORMAT(' CHECK THE ODE/DAE SPLIT ') C C EVALUATE THE PART OF THE O.D.E.S THAT DEPENDS ONLY ON YDOTI C N = NEQ(1) DO 10 I = 1,N 10 SAVR(I) = 0.0D0 IRES = -1 CALL RESID ( NEQ, T, Y, YDOTI, SAVR, IRES, WKRES, NWKRES) NRE = NRE + 1 IF(IRES .NE. -1)RETURN C C CONSTS USED IN FORMING INCREMENTS FOR YDOTI C N = NEQ(1) EL1H = H*EL0 SRUR = DSQRT(UROUND) FAC = VNORM (N, SAVR, EWT) R0 = 1000.0D0*DABS(H)*UROUND*FAC*N ICOUNT = 0 IF (R0 .EQ. 0.0D0) R0 = 1.0D0 DO 100 I = 1,N IF(IDAE(I) .LT. 0 .OR. IDAE(I) .GT.1)THEN CALL SERROR(' USER WORKSPACE SIZE ERROR FOUND IN DAECHK. 1 THE INDICATOR ARRAY ELEMENT IDAE(=I1) WAS NOT 0 OR 1 BUT 2 HAD VALUE (=I2). INTEGRATION WILL BE CONTINUED.', 1, 2, 3 I, IDAE(I), 0 , 0.0D0, 0.0D0) END IF ICOUNT = ICOUNT + IDAE(I) C GENERATE THE INCREMENTS FOR YDOTI YI = Y(I) R = DMAX1(SRUR*DABS(YI),R0/EWT(I)) R = DMAX1(R,UROUND) * (N+I) / N YDOTI(I) = YH(I,2)/H + R/EL1H ACOR(I) = 0.0D0 100 CONTINUE IRES = -1 CALL RESID ( NEQ, T, Y, YDOTI, ACOR, IRES, WKRES, NWKRES) NRE = NRE + 1 IF(IRES .NE. -1)RETURN JCOUNT = 0 DO 200 I = 1,N C RE-GENERATE THE INCREMENTS FOR YDOTI IDAE(I) = 1 YDOTI(I) = YH(I,2) / H YI = Y(I) R = DMAX1(SRUR*DABS(YI),R0/EWT(I)) R = DMAX1(R,UROUND) * (N+I) / N FAC = EL1H / R TEM = DABS((SAVR(I) - ACOR(I)) * FAC) C IF(ITRACE .GE. 1)WRITE(IDEV,140)R, FAC, TEM C140 FORMAT(' R=',D12.4,' INC = ',D12.4,' DERIV = ',D12.4) SAVR(I) = 0.0D0 ACOR(I) = 0.0D0 IF( TEM .LT. UROUND)IDAE(I) = 0 JCOUNT = JCOUNT + IDAE(I) 200 CONTINUE IF( ICOUNT .NE. JCOUNT .AND. ITRACE .GE. 1)THEN WRITE(IDEV,2999) T, ICOUNT, JCOUNT 2999 FORMAT(/' **************************************************' 1 /' SPRINT WARNING - AT TIME =',D12.4/' THE NUMBER OF 2 DIFFERENTIAL EQUATIONS '/' HAS CHANGED FROM ',I7,' TO ',I7/ 3 ' **************************************************'/) END IF RETURN END SUBROUTINE EWSET (N, ITOL, RTOL, ATOL, YCUR, EWT, IEWSET) C----------------------------------------------------------------------- C THIS SUBROUTINE SETS THE ERROR WEIGHT VECTOR EWT ACCORDING TO C EWT(I) = 1.0 / ( RTOL(I)*ABS(YCUR(I)) + ATOL(I) ), I = 1,...,N, C WITH THE SUBSCRIPT ON RTOL AND/OR ATOL POSSIBLY REPLACED BY 1 ABOVE, C DEPENDING ON THE VALUE OF ITOL. THE ERROR WEIGHTS ARE FIRST FORMED C AND THEN INVERTED . IN THE CASE WHEN A ZERO WEIGHT IS FORMED THE C ROUTINE RETURNS WITH IEWSET = -I , OTHERWISE IEWSET =1. C WHERE I IS NUMBER OF THE FIRST ZERO WEIGHT COMPONENT . C----------------------------------------------------------------------- INTEGER N, ITOL, IEWSET INTEGER I, IOVFLO DOUBLE PRECISION RTOL, ATOL, YCUR, EWT DOUBLE PRECISION ATOLI, RTOLI, DUNFLO, DRELPR DIMENSION RTOL(1), ATOL(1), YCUR(N), EWT(N) C COMMON /SCONS1/ DUNFLO, DRELPR, IOVFLO SAVE /SCONS1/ C IEWSET = -1 RTOLI = RTOL(1) ATOLI = ATOL(1) DO 10 I = 1,N IF (ITOL .GE. 3) RTOLI = RTOL(I) IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) EWT(I) = RTOLI*DABS(YCUR(I)) + ATOLI IF(EWT(I) .LT. DUNFLO) THEN IEWSET = - I GOTO 100 END IF 10 CONTINUE C IEWSET = 1 C C INVERT THE NON-ZERO ERROR WEIGHTS C DO 20 I = 1,N EWT(I) = 1.0D0/EWT(I) 20 CONTINUE 100 CONTINUE C RETURN C----------------------- END OF SUBROUTINE EWSET ----------------------- END DOUBLE PRECISION FUNCTION VNORM (N, V, W) C----------------------------------------------------------------------- C THIS FUNCTION ROUTINE COMPUTES THE VECTOR NORM USED BY SPRINT. C INORM = 1 MAXIMUM NORM C = 2 EUCLIDEAN OR L2 NORM C = 3 AVERAGE L2 NORM C THE CHOICE OF NORM IS DEFINED BY THE USER ON ENTRY TO SPRINT AND C PASSED TO THIS FUNCTION BY THE COMMON BLOCK /SSNORM/. C C ALL THREE NORMS ARE WEIGHTED VECTOR NORMS OF C OF THE VECTOR OF LENGTH N CONTAINED IN THE ARRAY V, WITH WEIGHTS C CONTAINED IN THE ARRAY W OF LENGTH N.. C E.G. FOR THE AVERAGED L2 NORM C VNORM = SQRT( (1/M) * SUM( V(I)*W(I) )**2 ) WHERE M = N C WHILE FOR THE L2 NORM M = 1. C FOR THE MAX NORM C VNORM = MAX | V(I)*W(I) | . C I C----------------------------------------------------------------------- INTEGER N, M, I, INORM DOUBLE PRECISION V, W, SUM DIMENSION V(N), W(N) COMMON /SSNORM/ INORM SAVE /SSNORM/ SUM = 0.0D0 M = N GOTO (20, 60, 90, 30), INORM 20 M = 1 30 DO 40 I = 1,N 40 SUM = DMAX1(SUM, DABS(V(I)*W(I))) VNORM = SUM * M RETURN 60 M = 1 90 DO 100 I = 1,N 100 SUM = SUM + (V(I)*W(I))**2 VNORM = DSQRT(SUM/M) RETURN C----------------------- END OF FUNCTION VNORM ------------------------- END SUBROUTINE NLSLVR(N,Y,YDOTI,YH,NYH,SAVR, ACOR, EWT, IFUNC, INLN, 1 H, EL0, IDAE) C----------------------------------------------------------------------- C C DRIVER ROUTINE FOR SYSTEMS OF NONLINEAR EQUATIONS. C C PARAMETERS C----------- C N : NUMBER OF ORDINARY DIFFERENTIAL EQUATIONS. C Y(N) PREDICTED SOLUTION FOR THE SYSTEM OF NONLINEAR C EQUATIONS. C YDOTI(N) PREDICTED TIME DERIVATIVE FOR THE SYSTEM OF EQNS C YH(NYH,N) NORSIECK VECTOR CONTAINING OLD VALUES OF C SOLUTION AND TIME DERIVATIVES. C ACOR (N) USED TO HOLD ACCUMULATED CORRECCTION VALUES. C SAVR (N) ARRAY USED TO HOLD THE RESULT OF BACK SUBSTITUTION C EWT (N) ERROR WEIGHTS USED IN NORM FORMATION C H, EL0 STEPSIZE AND ORDER COEFFICIENT C INDICATORS C----------- C C INLN : INDICATOR FROM CALLING SEGMENT C ON ENTRY = 0 : REVERSE COMMUNICATION ENTRY LOOK AT C THE IFUNC INDICATOR. C = 1 : SOLVE THE NONLINEAR SYSTEM WITH A N C NEW JACOBIAN MATRIX. C = 2 : SOLVE THE NONLINEAR SYSTEM BUT USIN C USING THE OLD JACOBIAN MATRIX C = 3 ; PERFORM A RESIDUAL EVALUATION ONLY C = 4 : PERFORM A BACK SUBSTITUTION ON THE C CONTENTS OF THE RESIDUAL VECTOR. C = 5 : PERFORM A RESIDUAL EVALUTAION AND C BACK SUB FOR THE PETZOLD ERROR EST. C = 6 SOLVE THE NONLINEAR SYSTEM USING C FUNCTIONAL ITERATION C = 7 SOLVE FOR THE INITIAL VALUES OF C THE SOLUTION AND ITS TIME DERIVS C USING FUNCTIONAL ITERATION C = 8 AS FOR INLN =3 BUT WITH IRES = -1 C C ON EXIT = -1 : RETURN TO CALLING SEGMENT-ERROR C FORMING THE JACOBIAN C = -2 : RETURN BECAUSE ERROR IN RESIDUAL C = -3, -4 AS FOR INLN=-2 WITH OTHER IRES. C = -5 WORKSPACE ERROR IN JAC FORMING. C = 0 : REVERSE COMMUNICATION EXIT LOOK C AT IFUNC FOR OPERATION C = 1 : NONLINEAR SYSTEM SOLVED RETURN TO C CALLING SEGMENT C = 2 : ITERATION FAILED TO CONVERGE IN THE C SOLUTION OF THE NONLINEAR SYSTEM C RETURN TO CALLING SEGMENT. C = 3,4,5,8 AS FOR IFUNC = 3,4,5 ON EXIT C BUT RETURN DIRECTLY TO THE CALLING C SEGMENT WITHOUT RE-ENTERING HERE. C = 6,7 TASKS WITH THESE VALUES ON C ENTRY SUCCESSFULLY PERFORMED. C C IFUNC ON ENTRY = 1 : JACOBIAN HAS BEEN FORMED AND FIRST C ITERATION PERFORMED. C = 2 : RESIDUAL EVAL AND BACKSUB DONE C = 3 : SUCCESSFUL RESID EVAL C = 4 : BACKSUB ON SAVR PERFORMED. C = 5 ; PETZOLD ERROR ESTIMATE SUPPLIED C IN THE ARRAY SAVR. C = 6 ; SUCCESSFUL RESIDUAL EVALUATION IN C FUNCTIONAL ITERATION PROCESS C = 7 ; AS FOR = 6 C = 8 ; AS FOR = 3 C C ON EXIT = 0 : RETURN TO STEP WITH INLN SET C = 1 : FORM NEW JACOBIAN MATRIX. C = 2 : EVALUATE THE RESIDUAL AND DO A C BACKSUBSTITUTION. C = 3 : RESIDUAL EVALUATION ONLY C = 4 : PERFORM A BACKSUBSTITUTION ON THE C RESIDUAL VECTOR. C = 5 : PERFORM A RESIDUAL EVALUATION C AND BACKSUBSTITUTION FOR THE C PETZOLD ERROR ESTIMATE. C = 6,7 PERFORM A RESIDUAL EVALUATION FOR C USE IN FUNCTIONAL ITERATION C = 8 AS FOR 3 WITH IRES = -1 C----------------------------------------------------------------------- INTEGER IFUNC, INLN, IZ, NYH, IDAE(N), MAXIT DOUBLE PRECISION Y(N),YDOTI(N),SAVR(N),ACOR(N),EWT(N),YH(NYH,N) INTEGER I, M, NQ, NDUM, N, MAXCOR, ISAVE, ITRACE, IDEV, IOVFLO DOUBLE PRECISION CRATE, EL0, H, DAMP, DUNFLO, D1, D2 DOUBLE PRECISION DCON, DEL, DELP, EL1H, VNORM, DREL, RJNORM, RT COMMON /SCONS1/ DUNFLO, DREL, IOVFLO COMMON /LSTATS/ NQ, NDUM(6) COMMON /SDEV2/ ITRACE, IDEV COMMON /SSOLVR/ DAMP, RJNORM, CRATE, MAXIT C C EXTRA BLOCK FOR REVERSE COMMUNICATION C COMMON /NLSAVE/ DCON, DEL, DELP, D1, D2,EL1H,MAXCOR,ISAVE,M,IZ,I SAVE /SCONS1/, /LSTATS/, /SSOLVR/, /NLSAVE/ C----------------------------------------------------------------------- C IF(ITRACE.GE.2 .AND.INLN .NE. 0)WRITE(IDEV,90)INLN 90 FORMAT(' NON-LINEAR EQN. DRIVER ROUTINE ENTERED WITH INLN=',I4) IZ = INLN +1 GOTO(100,240,240, 915, 500, 920, 240, 240, 925), IZ GOTO 900 100 CONTINUE IF(IFUNC .GT. 2 .AND. IFUNC .LT. 6)INLN = IFUNC IF(IFUNC .EQ. 8) INLN = IFUNC GOTO( 250, 250, 910, 910 , 910, 250, 250, 910), IFUNC GOTO 900 C----------------------------------------------------------------------- C IF INDICATED, THE MATRIX P = A - H*EL(1)*DG/DY IS REEVALUATED AND C PREPROCESSED BEFORE STARTING THE CORRECTOR ITERATION. C----------------------------------------------------------------------- 240 DAMP = DABS(DAMP) IF(DAMP .LT. DREL)DAMP = 1.0D0 IF(MAXIT .LT. 0)MAXIT = 3 MAXCOR = MAXIT M = 0 DELP = 0.0D0 D1 = (1.D0 + VNORM( N, Y, EWT) ) IF(INLN .EQ. 6)D1 = D1 * ABS( EL0*H) D2 = D1 / DREL D1 = D1 * DREL C C RETURN FOR A JACOBIAN EVALUATION OR START ITERATING WITH OLD C JACOBIAN MATRIX IF(INLN .EQ. 1)THEN IF(ITRACE .GE. 1)WRITE(IDEV,241) 241 FORMAT(' JACOBIAN EVALUATION ') CRATE = 0.70D0 END IF IFUNC = INLN INLN = 0 RETURN C----------------------------------------------------------------------- C JAC RETURN AND RESIDUAL + BACKSUB RETURN POINT (INLN = 1,2,6,7) C----------------------------------------------------------------------- 250 CONTINUE IF(M .EQ. 0)THEN IF(IFUNC.EQ.6 .OR. IFUNC .EQ. 7)CRATE = 0.0D0 DO 260 I = 1,N 260 ACOR(I) = 0.0D0 EL1H = EL0 * H END IF IF(MAXIT .EQ. 0)GOTO 450 C C CALCULATE NORM OF CURRENT SOLUTION INCREMENT C DEL = VNORM (N, SAVR, EWT) IF(ITRACE.GE.2 )THEN I = M + 1 WRITE(IDEV,3688)I,DEL 3688 FORMAT(' ITER',I3,' INCREMENTS ARE (SCALED NORM =',D11.3,')') WRITE(IDEV,369)(SAVR(I), I = 1,N) 369 FORMAT(2X,5D11.3) END IF IF(DEL .GT. D2 )GOTO 410 IF (M .GE. 1 .AND. DEL .GT. MAX( D1, 0.9D0*DELP) ) THEN C 2.0 IN LSODX CODES IF(ITRACE .GE. 2)WRITE(IDEV,379)DEL 379 FORMAT(' NORM OF CURRENT INCREMENTS IS ',D11.3) GO TO 409 END IF IF(IFUNC .LT. 6)THEN C ORDINARY NEWTON ITERATION DO 380 I = 1,N ACOR(I) = ACOR(I) + SAVR(I) * DAMP YDOTI(I) =(ACOR(I)/EL0 + YH(I,2)) /H 380 Y(I) = YH(I,1) + ACOR(I) ELSE IF(IFUNC .EQ. 6)THEN C RELAXED FUNCTIONAL ITERATION FOR Y AND YDOT VALUES. C CHANGED 15/2/89 RT = 0.9D0 DO 381 I = 1,N ACOR(I)=ACOR(I)+SAVR(I)*((1-IDAE(I))*RT+IDAE(I)*EL1H) YDOTI(I) = (YH(I,2) + ACOR(I)/EL0) / H 381 Y(I) = YH(I,1) + ACOR(I) ELSE IF(IFUNC .EQ. 7)THEN C FUNCTIONAL ITERATION FOR INITIAL VALUES ONLY DO 382 I = 1,N ACOR(I) = ACOR(I) + SAVR(I) * EL1H YDOTI(I) = (ACOR(I)/EL0 *IDAE(I) + YH(I,2)) / H 382 Y(I) = YH(I,1) + ACOR(I)*(1 - IDAE(I)) END IF IF(ITRACE.GE.2 )THEN WRITE(IDEV,368) 368 FORMAT(' CALCULATED SOLUTION IS ') WRITE(IDEV,369)(Y(I),I=1,N) END IF C----------------------------------------------------------------------- C TEST FOR CONVERGENCE. IF M.GT.0, AN ESTIMATE OF THE CONVERGENCE C RATE CONSTANT IS STORED IN CRATE, AND THIS IS USED IN THE TEST. C AT LEAST TWO ITERATIONS ARE DONE UNLESS THE RATE OF CONVERGENCE HAS C PREVIOUSLY BEEN ESTIMATED USING THE SAME JACOBIAN MATRIX. C----------------------------------------------------------------------- IF (M .NE. 0) THEN DCON = DMAX1(DEL,1.0D0) DELP = DMAX1(DELP,DUNFLO*DCON) CRATE = DMAX1(0.2D0*CRATE,DEL/DELP) ELSE RJNORM = DMAX1( DEL , DREL ) END IF DCON = DEL*DMIN1(1.0D0,1.5D0*CRATE) * 2.5D0 IF(IFUNC .EQ. 6)THEN DCON = DCON * EL1H DEL = DEL * EL1H END IF IF(ITRACE .GE. 2)WRITE(IDEV,390)DCON,CRATE,EL1H,DEL 390 FORMAT(' SCALED TEST=',D11.3,' CONVERGENCE RATE =',D11.3/ 1 ' GAMMA * H =',D11.3,' NORM OF LAST INCREMENTS =',D11.3) IF (DCON .LE. 0.10D0 .AND. IFUNC .EQ. 6) GO TO 450 IF(M .EQ. 0 .AND. IFUNC .NE. 2 .AND. DEL .GT. D1)GOTO 391 C TO DO TWO OR MORE ITERATIONS AS RATE OF CONVERGENCE UNKNOWN IF (DCON .LE. 1.0D0) GO TO 450 391 M = M + 1 IF (M .EQ. MAXCOR) GO TO 410 DELP = DEL C REVERSE COMMUNICATION RETURN FOR A RESID EVALUATION AND BACKSUB IF(IFUNC .LT. 6)IFUNC = 2 INLN = 0 RETURN C---------------------------------------------------------------------- C CORRECTOR ITERATION IS DIVERGING- IF DAMPED NEWTON IN USE THEN TRY C USING SMALLER DAMPING PARMETER C---------------------------------------------------------------------- 409 IF(DAMP .GT. 0.99D0)GOTO 410 IF(DAMP .GT. 0.05D0)THEN DAMP = DAMP* 0.5D0 IF(ITRACE .GE. 1)WRITE(IDEV,4099)DAMP 4099 FORMAT(' DAMPING FACTOR REDUCED TO ',D12.4) INLN = 2 GOTO 240 END IF C----------------------------------------------------------------------- C THE CORRECTOR ITERATION FAILED TO CONVERGE IN MAXCOR TRIES. C RETURN TO THE CALLING MODULE TO HANDLE THIS C----------------------------------------------------------------------- 410 INLN = 2 IF(ITRACE .GE.1)WRITE(IDEV,411) 411 FORMAT(' COVERGENCE FAILURE OCCURRED ') IFUNC = 0 RETURN C---------------------------------------------------------------------- C CORRECTOR ITERATION HAS CONVERGED RETURN WITH THE C SUM OF THE CORRECTIONS IN ACOR(N) SAVE THE LAST VALUE OF DEL?? C---------------------------------------------------------------------- 450 IFUNC = 0 C DELP = DEL WHAT TO DO HERE ???? DELP = DEL INLN = 1 RETURN C----------------------------------------------------------------------- C RETURN FOR A BACKSUBSTITUTION BUT INLN LEFT AT 4 SO NO RENTRY HERE C----------------------------------------------------------------------- 500 INLN = 4 IFUNC = 4 RETURN C---------------------------------------------------------------------- C ILLEGAL VALUES OF REVERSE COMMUNICATION PARAMETERS ON ENTRY C---------------------------------------------------------------------- 900 CALL SERROR(' NLSLVR-ILLEGAL VALUES OF INLN(=I1) AND IFUNC(=I2) 1 ON ENTRY TO NONLINEAR EQUATIONS DRIVER ' 2 ,1, 2, INLN, IFUNC, 0 , 0.0D0, 0.0D0) INLN = -1 910 IFUNC = 0 RETURN 915 INLN = 3 IFUNC = 3 RETURN 925 INLN = 8 IFUNC = 8 RETURN C---------------------------------------------------------------------- C PETZOLD ERROR ESTIMATE (INLN LEFT AT 5 SO NO RENTRY NEEDED. C--------------------------------------------------------------------- 920 INLN = 5 IFUNC = 5 RETURN C-----------------------END OF ROUTINE NLSLVR---------------------- END SUBROUTINE ITSTEP( NEQ, T, TOUT, H0, Y, YDOTI, EWT, RTOL, 1 ATOL, ITOL) INTEGER NEQ, ITOL INTEGER I INTEGER IOVFLO, ITRACE, IDEV, INORM DOUBLE PRECISION T, TOUT, H0, Y(NEQ), YDOTI(NEQ), EWT(NEQ), 1 RTOL(1), ATOL(1) DOUBLE PRECISION TOL, W0, SUM, TDIST, ATOLI, AYI DOUBLE PRECISION UROUND, DUNFLO, VNORM, YDNORM LOGICAL SFILTR COMMON /SCONS1/ DUNFLO, UROUND, IOVFLO COMMON /SLSZ06/ YDNORM, SFILTR COMMON /SDEV2/ITRACE,IDEV COMMON /SSNORM/ INORM SAVE /SSNORM/, /SCONS1/, /SLSZ06/ C----------------------------------------------------------------------- C THE CODING BELOW COMPUTES THE STEP SIZE, H0, TO BE ATTEMPTED ON THE C FIRST STEP, UNLESS THE USER HAS SUPPLIED A VALUE FOR THIS. C FIRST CHECK THAT TOUT - T DIFFERS SIGNIFICANTLY FROM ZERO. C A SCALAR TOLERANCE QUANTITY TOL IS COMPUTED, AS MAX(RTOL(I)) C IF THIS IS POSITIVE, OR MAX(ATOL(I)/ABS(Y(I))) OTHERWISE, ADJUSTED C SO AS TO BE BETWEEN 100*UROUND AND 1.0E-3. C THEN THE COMPUTED VALUE H0 IS GIVEN BY.. C C H0**2 = TOL / ( W0**-2 + || YDOT / YWT || **2 ) C C WHERE W0 = MAX ( ABS(T), ABS(TOUT) ), C YDOT(I) = I-TH COMPONENT OF INITIAL VALUE OF DY/DT, C YWT(I) = EWT(I)/TOL (A WEIGHT FOR Y(I)). C AND THE NORM USED || . || IS THAT CHOSEN BY THE USER. C THE SIGN OF H0 IS INFERRED FROM THE INITIAL VALUES OF TOUT AND T. C----------------------------------------------------------------------- IF (H0 .NE. 0.0D0) GO TO 170 TDIST = DABS(TOUT - T) W0 = DMAX1(DABS(T),DABS(TOUT)) IF (TDIST .LT. 2.0D0*UROUND*W0) THEN CALL SERROR(' ISTEP-- TOUT (=R1) TOO CLOSE TO T (=R2) TO START 1 INTEGRATION', 1, 0 , 0, 0, 2, TOUT, T) GOTO 170 END IF TOL = RTOL(1) IF (ITOL .LE. 2) GO TO 145 DO 140 I = 1,NEQ 140 TOL = DMAX1(TOL,RTOL(I)) 145 IF (TOL .GT. 0.0D0) GO TO 160 ATOLI = ATOL(1) DO 150 I = 1,NEQ IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) AYI = DABS(Y(I)) IF (AYI .NE. 0.0D0) TOL = DMAX1(TOL,ATOLI/AYI) 150 CONTINUE 160 TOL = DMAX1(TOL,100.0D0*UROUND) TOL = DMIN1(TOL,0.001D0) CMBYY SUM = VNORM (NEQ, YDOTI, EWT) SUM = YDNORM SUM = 1.0D0/(TOL*W0*W0) + TOL*SUM**2 H0 = 1.0D0/DSQRT(SUM) H0 = DMIN1(H0,TDIST) H0 = DSIGN(H0,TOUT-T) 170 CONTINUE RETURN C--------------------------END OF ISTEP-------------------------------- END SUBROUTINE SERROR (MSG, IERT, NI, I1, I2, NR, R1, R2) C----------------------------------------------------------------------- C ERROR HANDLING ROUTINE FOR THE SPRINT INTEGRATION PACKAGE. THIS C ROUTINE IS A FORTRAN77 IMPROVED VERSION OF THE ROUTINE USED IN LSODI C AND MAKES USE OF CHARACTER HANDLING FACILITIES. C----------------------------------------------------------------------- INTEGER IERT, NI, I1, I2, NR INTEGER I, J, IL, IT, K, KP1, LWORD INTEGER NERR, ITRACE DOUBLE PRECISION R1, R2 CHARACTER *(*) MSG CHARACTER *(240) MSG1 CHARACTER *(60) MSGOUT(5) COMMON/SDEV2/ ITRACE, NERR C----------------------------------------------------------------------- C C ALL ARGUMENTS ARE INPUT ARGUMENTS. C C MSG = THE MESSAGE IN CHARACTER FORMAT C IERT = THE ERROR TYPE.. C 1 MEANS RECOVERABLE (CONTROL RETURNS TO CALLER). C 2 MEANS FATAL (RUN IS ABORTED--SEE NOTE BELOW). C NI = NUMBER OF INTEGERS (0, 1, OR 2) TO BE PRINTED WITH MESSAGE. C I1,I2 = INTEGERS TO BE PRINTED, DEPENDING ON NI. C NR = NUMBER OF REALS (0, 1, OR 2) TO BE PRINTED WITH MESSAGE. C R1,R2 = REALS TO BE PRINTED, DEPENDING ON NR. C----------------------------------------------------------------------- IL = LEN(MSG) C C SET MSG1 BLANK AND GET RID OF UNNECESSARY SPACES IN ERROR MESSAGE C J = 1 IT = MIN0(IL,240) DO 240 I = 1,10 MSG1(J:) = ' ' J = J + 24 240 CONTINUE K = 0 J = 0 DO 91 I = 1,IT IF(MSG(I:I) .EQ. ' ')THEN K = K + 1 IF(K .GT. 2)GOTO 91 ELSE K = 0 END IF J = J + 1 MSG1(J:J) = MSG(I:I) 91 CONTINUE IL = J C C FORMAT THE MESSAGE NOW STORED IN MSG1 C I = 1 LWORD = 60 J = 0 100 J = J + 1 IF(J .GT. 1)LWORD = 51 K = I + LWORD -1 KP1 = K + 1 110 IF(MSG1(K:K) .NE. ' ' .AND. MSG1(KP1:KP1) .NE. ' ')THEN K = K - 1 IF(K .EQ. I)THEN K = I + LWORD -1 GOTO 12 END IF GOTO 110 END IF 12 IF(J .EQ. 1)THEN MSGOUT(J) = MSG1(I:K) ELSE MSGOUT(J) = ' '//MSG1(I:K) END IF I = K + 1 IF(K .LT. IL .AND. J .LT. 5)GOTO 100 C C OUTPUT THE ERROR MESSAGE C WRITE(NERR,18)(MSGOUT(I),I = 1,J) 18 FORMAT(1X,A60) C C PRINT THE INTEGERS AND REALS IN THE ERROR MESSAGE (IF ANY) C IF (NI .EQ. 1) WRITE(NERR,20) I1 20 FORMAT(9X,' IN ABOVE MESSAGE I1 =',I10) IF (NI. EQ. 2) WRITE(NERR,30) I1,I2 30 FORMAT(9X,' IN ABOVE MESSAGE I1 =',I10,' I2 =',I10) IF (NR. EQ. 1) WRITE(NERR,40) R1 40 FORMAT(9X,' IN ABOVE MESSAGE R1 =',D21.13) IF (NR .EQ. 2) WRITE (NERR, 50) R1,R2 50 FORMAT(9X,15HIN ABOVE, R1 =,D21.13,3X,4HR2 =,D21.13) C ABORT THE RUN IF IERT = 2. ------------------------------------------- IF (IERT .NE. 2) RETURN STOP C----------------------- END OF SUBROUTINE SERROR ---------------------- END BLOCK DATA C----------------------------------------------------------------------- C THIS DATA SUBPROGRAM LOADS VARIABLES INTO THE INTERNAL COMMON C BLOCKS USED BY THE SPRINT PACKAGE. C THE FOLLOWING PARAMETERS ARE THE I.F.I.P. PARAMETERS FOR MACHINE C TRANSPORTABLE NUMERICAL SOFTWARE . THESE ARE USED THROUGHOUT THE C PACKAGE. THEY CAN BE SPLIT INTO TWO - MACHINE ARITHMETIC CONSTS C AND INPUT/OUTPUT DEVICE UNIT NUMBERS. C REFERENCE -- PORTABILITY OF NUMERICAL SOFTWARE ,OAK BROOK ,1976, C SPRINGER-VERLAG LECTURE NOTES IN COMPUTER SCIENCE C NO 57, PP 85-90. C C DRADIX : THE BASE OF THE COMPUTERS FLOATING POINT NUMBER SYSTEM. C DDIGIT : THE NUMBER OF DIGITS OF THIS BASE USED IN THE MANTISSA. C DRELPR : THE SMALLEST REAL NUMBER SUCH THAT 1.0-X < 1.0 < 1.0+X C DOVFLO : THE LARGEST REAL NUMBER WHICH CAN BE STORED . C IOVFLO : : : INTEGER : : : : : C DUNFLO : THE SMALLEST REAL NUMBER WHICH CAN BE STORED . C DRANGE : THE RANGE OF REAL NUMBERS IN WHICH ARITHMETIC OPERATIONS C ARE CORRECTLY PERFORMED PROVIDING THAT OVERFLOW AND C UNDERFLOW DO NOT OCCUR. C IRANGE : THE INTEGER EQUIVALENT OF DRANGE. C LRATIO : RATIO OF REAL/INTEGER STORAGE LOCATIONS C = 1 IF SINGLE PRECISION IS USED C = 2 IF DOUBLE PRECISION IS USED. C THIS PARAMETER IS USED ONLY BY THE SPARSE MATRIX ROUTINES C WHERE REAL AND INTEGER ARRAY ARE EQUIVALENCED. C C N.B. IF ANY OF THE COMMON BLOCKS THAT HOLD THESE VARIABLES ARE C PASSED ACROSS INTO OTHER SUBROUTINES THEN THESE COMMON C BLOCKS SHOULD BE HELD BY A SAVE STATEMENT IN THE ROUTINES C WHICH THEY ARE PASSED INTO. C----------------------------------------------------------------------- C INTEGER NIN,NOUT,NERR, ITRACE, IOVFLO, IRANGE, LRATIO DOUBLE PRECISION DRADIX, DDIGIT, DRELPR, DUNFLO, DRANGE COMMON /SDEV1/ NIN, NOUT COMMON /SDEV2/ ITRACE, NERR COMMON /SCONS1/ DUNFLO, DRELPR, IOVFLO COMMON /SCONS2/ DRADIX, DDIGIT, DRANGE, IRANGE COMMON /SPRECN/ LRATIO SAVE /SCONS1/, /SCONS2/, /SPRECN/ DATA NIN/5/, NOUT/6/, NERR/6/, IOVFLO/2147483640/, 1 IRANGE/2147483620/, LRATIO/2/ DATA DRADIX/1.0D+01/, DDIGIT/1.4D+01/, DRELPR/1.0D-15/, 1 DRANGE/1.0D+74/, DUNFLO/1.0D-78/ C C----------------------- END OF BLOCK DATA ----------------------------- END SUBROUTINE SPRMON( N, T, HLAST, H, Y, YDOT, YSAVE, NYH, R, ACOR, 1 RESWK, NRESWK, WKMON, NWKMON, IMON, INLN, HMIN, HMXI) C********************************************************************** C DUMMY EXAMPLE MONITOR FOR SPRINT . C********************************************************************** INTEGER N, NYH, NRESWK, NWKMON, IMON, INLN, ITRACE, IDEV DOUBLE PRECISION T, HLAST, H, Y(1), YDOT(1), YSAVE(NYH,1), R(1), 1 ACOR(1), RESWK(NRESWK), WKMON(NWKMON), HMIN, HMXI COMMON /SDEV2/ ITRACE, IDEV RETURN END SUBROUTINE SPRJAC C********************************************************************** C DUMMY JACOBIAN ROUTINE. C********************************************************************** RETURN END C SUBROUTINE TIMER(DA, IMODE) C DOUBLE PRECISION DA, TSAVE C*********************************************************************** C TIMING ROUTINE FOR USE WITH SPRINT C WHEN IMODE = 1 THE CLOCK SHOULD BE SET TO ZERO C WHEN IMODE = 2 THE ELAPSED C.P.U. TIME SINCE THE CALL WITH C IMODE = 1 SHOULD BE PUT IN DA. C********************************************************************** C INTEGER IBUFR(10), IMODE C REAL VTIME C COMMON /STIMER/ TSAVE C SAVE /STIMER/ C CALL PTIMER(IBUFR) C DA=IBUFR(10)/1000000.0D0 C BELOW LINE FOR USE ON LEEDS UNIVERSITY AMDAHL ONLY. C DA = VTIME(TSAVE) C IF(IMODE.EQ.1)THEN C TSAVE = DA C DA = 0.0D0 C ELSE C DA = DA - TSAVE C END IF C NEXT SECTION IS FOR USE WITH APOLLO TIMER SUBROUTINE TIMER(DA, IMODE) DOUBLE PRECISION DA C*********************************************************************** C TIMING ROUTINE FOR USE WITH SPRINT C WHEN IMODE = 1 THE CLOCK SHOULD BE SET TO ZERO C WHEN IMODE = 2 THE ELAPSED C.P.U. TIME SINCE THE CALL WITH C IMODE = 1 SHOULD BE PUT IN DA. C********************************************************************** INTEGER IMODE REAL TREL,TDIF DA = TIME(TREL,TDIF) IF(IMODE.EQ.1)THEN DA = 0.0D0 ELSE DA = TDIF END IF C NEXT SECTION IS FOR USE WITH IBM TIMER C SUBROUTINE TIMER(TTIME ,ISET) C C INTEGER IDEV,IDEVI,ITRACE,IDEVS, I, J(8) C DOUBLE PRECISION TSTORE, TTEMP, TTIME C COMMON/SDEV2/ITRACE,IDEV C COMMON/TIMSAV/ TSTORE C SAVE C CALL CTIMER(J) C DO 13 I = 1,8 C3 IF(J(I).LT.0)J(I) = J(I) + 2**32 C IDEVI=5 C WRITE(6,11)J(8) C IF(ISET .EQ. 1)THEN C TSTORE = J(8) C IF(TSTORE. LT. 0)TSTORE = TSTORE + (2.D0**32 ) C TSTORE = J(8) * 1.0D-6 C IF(J(7) .GT. 0 ) TSTORE = TSTORE + J(7) * 2.D0**33*1.0D-6 C TTIME = 0.0D0 C ELSE C TTEMP = J(8) C IF(TTEMP . LT. 0)TTEMP = TTEMP + (2.D0**32 ) C TTEMP = J(8) * 1.0D-6 C IF(J(7) .GT. 0 ) TTEMP = TTEMP + J(7) * 2.D0**33*1.0D-6 C TTIME = TTEMP - TSTORE C END IF C11 FORMAT(' J =',I12) RETURN END SUBROUTINE SPATEV C********************************************************************** C ROUTINE WHICH WHEN CALLED FORCES THE SPARSITY PATTERN OF THE C JACOBIAN TO BE RE-EVALUATED ON THE NEXT CALL. C********************************************************************** INTEGER IJCNT, N, IDUMMY LOGICAL COPYPT, SETINF COMMON /SPJSVE/ IDUMMY(4), SETINF COMMON /RWB008/ COPYPT COMMON /SPJCNT/ IJCNT, N SAVE /SPJCNT/, /RWB008/ SETINF = .TRUE. COPYPT = .TRUE. IJCNT = 0 RETURN END SUBROUTINE INITDB( N, Y, YDOTI, YSAVE, NYH, RES, ACOR, IDAE, 1 T, H, INIT, INLN, IODE, HMIN, EWT) C C*********************************************************************** C GENERAL INITIALISATION MODULE FOR ALGEBRAIC-DIFFERENTIAL EQNS C PARAMETER LIST C ************** C N; THE NUMBER OF DIFFERENTIAL ALGEBRAIC EQUATIONS. C Y(N) CONTAINS THE INITIAL SOLUTION VALUES (OR ESTIMATES FOR THE C ALGEBRAIC EQUATIONS. C YDOTI(N) ARRAY CONTAINING THE USER SUPPLIED ESTIMATES OF THE TIME C DERIVATIVE IF INIT = 0 OTHERWISE EMPTY. C YSAVE(NYH,2) MEMORY ARRAY USED TO SAVE THE THE INITIAL VALUES OF THE C SOLUTION AND ITS TIME DERIVATIVE WHILE THE FINAL VALUES ARE C BEING COMPUTED. C NYH SEE ABOVE. C RES(N) ON RETURN FROM A REVERSE COMMUNICATION CALL WITH INLN = 3 C THIS ARRAY CONTAINS THE RESIDUAL OF THE D.A.E. SYSTEM WITH C THE CURRENT VALUES OF Y AND YDOTI. C ACOR(N) WORK ARRAY USED INTERNALLY IN THIS ROUTINE. C IDAE(N) INTEGER INDICATOR ARRAY WHICH IS EMPTY ON ENTRY AND ON EXIT C IF IDAE(I) = 0 THE ITH DAE IS ALGEBRAIC ELSE C IF IDAE(I) = 1 THE ITH DAE IS DIFFERENTIAL. C T THE CURRENT TIME AT WHICH THE INITIALISATION ROUTINE IS C CALLED. C H THE CURRENT STEPSIZE (SET TO A DUMMY VALUE OF 1.0 IF C INTEGRATION HAS NOT YET STARTED). C INIT INDICATOR FOR THIS ROUTINE C ON ENTRY IF INIT = 1 THEN THE INITIAL VALUES OF THE TIME C DERIVATIVE HAVE NOT BEEN SUPPLIED. C = 2 OTHERWISE THE USER HAS SUPPLIED THEM C ON EXIT IF INIT = 1 EVERYTHING WAS O.K. C = 0 REVERSE COMMUNICATION EXIT TASK TO BE C PERFORMED IS SPECIFIED BY INLN (BELOW). C =-1 ERROR OCURRED IN THIS ROUTINE. C INLN REVERSE COMMUNICATION INDICATOR FOR THE NONLINEAR EQUATIONS C PART OF THE PACKAGE. THE VALUES USED HERE ARE ,ON EXIT, C = 0 MEANS NORMAL EXIT FROM THIS ROUTINE SPECIFIED BY INIT C = 3 RETURN THE VALUES OF THE DAE. RESIDUAL USING THE ARRAYS C Y AND YDOTI IN THE ARRAY RES. C = 4 SOLVE FOR THE INITIAL VALUES OF THE TIME DERIVATIVES FOR C THE ALGEBRAIC EQUATIONS AND FOR THE INITIAL VALUES OF THE C ALGEBRAIC EQUATIONS. C ON ENTRY C = 0 NORMAL RETURN FROM NONLINEAR SOLVER OR NORMAL ENTRY C < 0 NONLINEAR EQUATIONS FAILED TO CONVERGE. C = -5 WORKSPACE ERROR IN LINEAR ALGEBRA. C IODE USER SUPPLIED PARAMETER INDICATING THE TYPE OF DIFFERENTIAL C BEING SOLVED C = 0 IMPLIES EXPLICIT O.D.E. SYSTEM ,POSSIBLY WITH EXTRA C COUPLED EXPLICIT ALGEBRAIC EQUATIONS. C = 1 IMPLIES IMPLICIT O.D.E./ DAE SYSTEM C THIS PARAMETER IS CHECKED HERE AND POSSIBLY MODIFIED IF C FOUND TO BE INCORRECT. C C HMIN ABSOLUTE VALUE OF THE MINIMUM STEP - SIZE THAT THE SOLVER C IS ALLOWED TO TAKE. C EWT ARRAY OF WEIGHTS USED IN WEIGHTED VECTOR NORM C C*********************************************************************** INTEGER N, NYH, IDAE(N), INIT, INLN, IOVFLO, INSAVE, J, 1 ITRACE, IDEV, I, IC, IODE, JCON, JACNT, IERCNT, IDACNT, 2 IREVAL, NFILTR, NCNT, IDAOLD, JCOUNT, MAXIT, M, MAXCOR DOUBLE PRECISION Y(1), YSAVE(NYH,1), YDOTI(1), RES(1), ACOR(1), 1 SRUR,T,H,UROUND,DUNFLO,TEMP,HFAC,TSAVE,HSAVE,TEM, HMIN,ACTEMP, 2 DAMP, RJNORM, CRATE, FMAX, VNORM, EWT(1), DCON, DEL, DELP, D, 3 D1, D2, YDNORM LOGICAL IMPLCT, JACNEW, VALUES, SFILTR C COMMON /IMSAVR/ DCON, DEL, DELP, MAXCOR, M COMMON /SDEV2/ ITRACE, IDEV COMMON /SCONS1/ DUNFLO, UROUND, IOVFLO COMMON /SSOLVR/ DAMP, RJNORM, CRATE, MAXIT COMMON /SLSZ06/ YDNORM, SFILTR COMMON /INSAVS/ TSAVE, HFAC, HSAVE, D, FMAX, JACNT, JCON, IERCNT, 1 IMODE,IDACNT, IREVAL, NFILTR, NCNT, IDAOLD, INSAVE, JACNEW, 2 VALUES, I SAVE /INSAVS/, /SCONS1/, /SSOLVR/, /IMSAVR/, /SLSZ06/ C IF(INIT .EQ. 0)THEN C RETURN TO THE PART THAT CALLED THE NONLINEAR SOLVER IF(INLN .LE. -4)GOTO 90 IF((INSAVE. NE. 3 .AND. INSAVE.NE.4).AND.INLN .LT.-1)THEN C RESID ROUTINE HAS RETURNED ILLEGAL VALUES WHILE CHECKING I = -INLN CALL SERROR(' SPRINT WAS CHECKING THE O.D.E. PROBLEM 1 DEFINITION FOR CONSISTENCY WHEN THE RESID ROUTINE SET 2 IRES (=I1) AT TIME (=R1) ', 1, 1, I, 0, 1, T, 0.0D0) CALL SERROR(' PLEASE MODIFY DEFINITION OF ILLEGAL YDOT IN 1 RESID ROUTINE TO AVOID THIS', 1, 0, 0, 0, 0, 0.0D0, 0.0D0) GOTO 90 END IF GOTO(25,35,60,77,42,40,775,779,781,650,665,670,47),INSAVE C 1 2 3 4 5 6 7 8 9 10 11 12 13 ENDIF SRUR = DSQRT(UROUND) IERCNT = 0 TSAVE = T C********************************************************************** C STAGE 1 C DETERMINE WHICH EQUATIONS ARE DIFFERENTIAL AND WHICH ARE NOT C********************************************************************** 8 IF(INIT .EQ. 2)THEN VALUES = .TRUE. DO 10 I = 1,N YSAVE(I,1) = Y(I) YSAVE(I,3) = YDOTI(I) 10 YSAVE(I,2) = YDOTI(I)*H ELSE VALUES = .FALSE. DO 20 I =1,N YSAVE(I,1) = Y(I) YSAVE(I,3) = 0.0D0 20 YSAVE(I,2) = 0.0D0 END IF NCNT = 0 21 CONTINUE C CHECKING PROCEDURE FOR ALGEBRAIC EQUATIONS IF(NCNT .EQ. 1)THEN IDAOLD = IDACNT DO 211 I = 1,N J = 1 IF(YSAVE(I,1) .LT. 0.0D0)J = -1 211 Y(I) = (YSAVE(I,1) + J*SRUR) * (N+I)/N END IF DO 30 I = 1,N IDAE(I) = 1 Y(I) = YSAVE(I,1) * (1-NCNT) + Y(I) * NCNT 30 YDOTI(I) = 0.0D0 INIT = 0 INSAVE = 2 INLN = 3 RETURN C FOR A RESIDUAL EVALUATION FROM THE NONLINEAR SOLVER. 35 IMPLCT = .FALSE. IF(ITRACE .GE. 1 .AND. NCNT .EQ. 0 )THEN WRITE(IDEV,36) 36 FORMAT(' INITIAL VALUES OF RESIDUAL WITH ZERO YDOT ARE:') WRITE(IDEV,37)(RES(I),I = 1,N) 37 FORMAT(1X,5D11.3) END IF DO 22 I = 1,N ACOR(I) = RES(I) C POSSIBLE CHANGE BUT NEED TO SORT OUT THE EFFECT LOWER DOWN C J = 1 AND TO TEST EXTENSIVELY I.E. SIMON' PROBLEM C IF(YSAVE(I,2) .LT. 0.0D0)J = -1 C22 YDOTI(I) = (YSAVE(I,2) + J*SRUR) * (N+I)/N 22 YDOTI(I) = I * I INIT = 0 INSAVE = 1 INLN = 3 RETURN C FOR A RESIDUAL EVALUATION FROM THE NONLINEAR SOLVER. 25 CONTINUE TEM = SQRT(UROUND) IF(NCNT .EQ. 0)NFILTR = 0 DO 26 I =1,N ACTEMP = DABS(RES(I) - ACOR(I)) IF(ACTEMP .LE. TEM) THEN C ALGEBRAIC EQUATION TEST IF SATISFIED BY INITIAL CONDITIONS IDAE(I) = 0 IF(DABS(RES(I)) .GT. TEM.AND.NCNT.EQ.0)NFILTR = NFILTR + 1 ELSE TEMP = DABS(ACTEMP - I*I )/ (I*I) IF(TEMP .GT. TEM)THEN IMPLCT = .TRUE. IF(IODE .EQ. 0 .AND. IMPLCT)CALL SERROR(' INIT MODULE 1 WARNING EQUATION (=I1) AND POSSIBLY OTHER EQUATIONS ARE 2 IMPLICIT AND IN CALCULATING THE INIT VALUES THE EQNS 3 WILL BE TREATED AS IMPLICIT', 1, 1, I, 0, 0,0.0D0,0.0D0) IODE = 1 END IF END IF 26 CONTINUE C C EXIT FOR ANOTHER RESID EVALUATION WITH BETTER YDOT VALUES. C FMAX = 1.0D0 DO 28 I = 1,N FMAX = DMAX1(FMAX, DABS(ACOR(I)) ) J = 1 IF(YSAVE(I,2) .LT. 0.0D0)J = -1 28 YDOTI(I) = (YSAVE(I,2) + J*SRUR)*(N+I)/N INSAVE= 6 INLN = 3 RETURN C C EXIT FOR FINAL CONSISTENCY CHECK ON IRES = -1 OPTION C 40 INSAVE = 5 INLN = 8 DO 41 I = 1,N 41 ACOR(I) = RES(I) - ACOR(I) RETURN C C RE-ENTRY POINT AFTER INLN = 8 SUCCESSFULLY CALLED. C 42 CONTINUE JCOUNT = 0 TEM = DSQRT(UROUND) DO 43 I = 1,N C IF(ITRACE .GE. 1)WRITE(IDEV,4091)ACOR(I), RES(I) C4091 FORMAT(' ACOR= ',D12.5,' RESID = ',D12.5) ACOR(I) = DABS(ACOR(I)-RES(I)) RES(I) = DABS(RES(I)) RES(I) = DMAX1( RES(I), FMAX ) * 10000.0 * UROUND * N C IF(ITRACE .GE. 1)WRITE(IDEV,409)ACOR(I), RES(I) C409 FORMAT(' ACOR= ',D12.5,' WEIGHT = ',D12.5) IF(ACOR(I) .GT. RES(I))THEN C EQUATION I IN PROBLEM DEFINITION IS INCONSISTENT. JCOUNT = JCOUNT + 1 CALL SERROR(' SPRINT CHECK ON RESID ROUTINE - THE (=I1)TH 1 EQUATION APPEARS TO BE TO BE INCONSISTENTLY SPECIFIED', 1, 2 1, I, 0, 0, 0.0D0, 0.0D0) END IF 43 CONTINUE IF(JCOUNT .GT. 0)THEN CALL SERROR(' SPRINT- THE USER DEFINED PROBLEM ROUTINE RESID 1 HAS ONE OR MORE INCONSISTENCIES BETWEEN THE IRES = 1 AND 2 IRES = -1 PARTS. INTEGRATION WILL NOT BE ATTEMPTED', 1, 0, 0, 3 0, 0, 0.0D0, 0.0D0) GOTO 95 END IF C IF(IMPLCT)IODE = 1 C---------------------------------------------------------------------- C COUNT THE NUMBERS OF DIFFERENTIAL AND ALGEBRAIC EQUATIONS. | C---------------------------------------------------------------------- IC = 0 DO 45 I = 1,N 45 IC = IC + IDAE(I) IDACNT = N - IC IF(IDACNT .GT. 0 .AND. NCNT .EQ. 0)THEN C CHECK THE ALGEBRAIC EQUATIONS NCNT = 1 GOTO 21 END IF IF(NCNT .EQ. 1)THEN IF(IDAOLD .NE. IDACNT)THEN CALL SERROR(' INIT MODULE IN SPRINT IS HAVING DIFFICULTY 1 ISOLATING THE ALGEBRAIC EQUATIONS - POSSIBLY DUE TO ZERO 2 SOLUTION COMPONENTS.', 1, 0, 0, 0, 0, 0.0D0, 0.0D0) END IF DO 44 I = 1,N 44 Y(I) = YSAVE(I,1) END IF IF(IC .EQ. 0) CALL SERROR(' INIT MODULE-WARNING ZERO DIFFERENTIAL 1 EQUATIONS HAVE BEEN DETECTED AT TIME (=R1)', 1, 0, 2 0, 0, 1, T, 0.0D0) IF(ITRACE.GE.1)WRITE(IDEV,46)IC,IDACNT 46 FORMAT(2X,I6,' DIFFERENTIAL EQUATION(S) AND ',I6, 1 ' ALGEBRAIC EQUATION(S)'/9X,'HAVE BEEN DETECTED') DO 50 I = 1,N YDOTI(I) = YSAVE(I,2)/H C SAVE ORIGINAL SOLUTION YSAVE(I,3) = Y(I) YSAVE(I,4) = YDOTI(I) 50 CONTINUE C C CHECK IF USER-SUPPLIED INITIAL VALUES ARE CORRECT. C IF(VALUES)THEN C CALCULATE RESIDUAL INSAVE = 13 INLN = 3 RETURN ELSE GOTO 501 END IF 47 CONTINUE TEM = SQRT(UROUND) * 1000.D0 IF( VNORM(N, RES, EWT) .LT. TEM )THEN C INITIAL VALUES ARE O.K. IF(ITRACE .GE. 1)THEN WRITE(IDEV,470) WRITE(IDEV,71)(Y(I), I = 1,N) 470 FORMAT(' INITIAL Y VALUES ARE') WRITE(IDEV,472) 472 FORMAT(' INITIAL VALUES OF YDOT ARE ') WRITE(IDEV,721)(YDOTI(I), I = 1,N) END IF INIT = 1 INSAVE = 0 RETURN END IF 501 IMODE = 0 C********************************************************************* C STAGE 2 C COMPUTE INITIAL DY/DT BY CALLING THE NONLINEAR EQUATIONS SOLVER C (WITH THE DUMMY VALUES OF H ,EL0 AND NQ SET UP ABOVE) C********************************************************************* JACNT = 0 IREVAL = 0 D1 = ( 1.D0 + VNORM( N , YSAVE(1,1), EWT) ) D2 = D1 /(UROUND * SRUR) D1 = D1 * UROUND IF(IODE .EQ. 0 )THEN INLN = 7 MAXIT= 5 MAXCOR = 5 IMODE = 1 HSAVE = H DO 51 I = 1,N Y(I) = YSAVE(I,1) 51 YSAVE(I,2) = YSAVE(I,2)/H H = 1.0D0 INSAVE=3 INIT=0 RETURN END IF C PREDICT THE NEW SOLUTION FOR THE BACKWARD EULER STEP 54 DO 55 I = 1,N YSAVE(I,1) = YSAVE(I,1) + YSAVE(I,2) 55 Y(I) = YSAVE(I,1) C----------------------------------------------------------------------- C THE JACOBIAN MATRIX P = A - H*DG/DY IS REEVALUATED AND C PREPROCESSED BEFORE STARTING THE CORRECTOR ITERATION. C----------------------------------------------------------------------- 59 DAMP = 1.00D0 CRATE = 0.70D0 T = TSAVE + H 595 CONTINUE M = 0 DELP = 0.0D0 596 MAXCOR = 8 INLN = 1 JACNT = JACNT + 1 HSAVE = H MAXIT = 0 JACNEW = .TRUE. INIT = 0 INSAVE = 10 RETURN C----------------------------------------------------------------------- C JAC RETURN POINT C----------------------------------------------------------------------- 650 CONTINUE IF(M .EQ. 0)THEN DO 660 I = 1,N 660 ACOR(I) = 0.0D0 GOTO 670 END IF C RETURN FOR RESID EVAL AND BACKSUB INLN = 3 INIT = 0 INSAVE = 11 RETURN 665 INLN = 4 INIT = 0 INSAVE = 12 RETURN C----------------------------------------------------------------------- C RETURN POINT AFTER EACH ITERATION OF DAMPED NEWTON METHOD. C----------------------------------------------------------------------- 670 IF(INLN .LT. 0) GOTO 60 C C CALCULATE NORM OF CURRENT SOLUTION INCREMENT C DEL = VNORM (N, RES, EWT) * DAMP M = M + 1 IF(ITRACE.GE.2 )THEN WRITE(IDEV,6688)M 6688 FORMAT(' ITER',I3,' INCREMENTS ARE ') WRITE(IDEV,669)(RES(I), I = 1,N) END IF IF ( DEL .GE. D2)GOTO 609 IF (M .GT. 1 .AND. DEL .GT. MAX (DELP, D1)) GO TO 609 C ORDINARY NEWTON ITERATION DO 680 I = 1,N ACOR(I) = ACOR(I) + RES(I) * DAMP Y(I) = YSAVE(I,1) + ACOR(I) YDOTI(I) =(YSAVE(I,2) + ACOR(I)) / H 680 CONTINUE IF(ITRACE.GE.2 )THEN WRITE(IDEV,668) 668 FORMAT(' CALCULATED SOLUTION IS ') WRITE(IDEV,669)(Y(I),I=1,N) 669 FORMAT(2X,5D11.3) END IF C C----------------------------------------------------------------------- C TEST FOR CONVERGENCE. IF M.GT.1, AN ESTIMATE OF THE CONVERGENCE C RATE CONSTANT IS STORED IN CRATE, AND THIS IS USED IN THE TEST. C AT LEAST TWO ITERATIONS ARE DONE . C----------------------------------------------------------------------- IF (M .GT. 1) THEN DCON = DMAX1(DEL,1.0D0) DELP = DMAX1(DELP,DUNFLO*DCON) CRATE = DMAX1(0.2D0*CRATE,DEL/DELP, UROUND) IF(CRATE .LT. 0.99D0)THEN J = (DLOG( 0.4D0/DCON ) / DLOG( CRATE ) ) + 1 ELSE J = 10 * MAXCOR END IF ELSE J = 0 IF(DEL .LT. D1) GO TO 69 END IF DCON = DEL * 5.0D0 * (1.D0 + IMODE) IF(ITRACE .GE. 1)WRITE(IDEV,690)DCON,CRATE,H 690 FORMAT(' SCALED TEST =',D11.3,' CONV.RATE =',D11.3,' H=',D11.3) IF(ITRACE .GE. 1 .AND. M .GE. MAXCOR)WRITE(IDEV,691)J 691 FORMAT(' SPRINT ESTIMATES CONV. AFTER',I6,' EXTRA ITERATIONS ') IF (M .GT. 1 .AND. DCON .LE. 1.0D0) GOTO 69 IF (M .GE. MAXCOR .AND. J .GE. (2*MAXCOR-M))GOTO 60 DELP = DEL JACNEW = .FALSE. C REVERSE COMMUNICATION RETURN FOR A RESID EVALUATION AND BACKSUB GOTO 650 C---------------------------------------------------------------------- C CORRECTOR ITERATION IS DIVERGING- TRY SMALLER DAMPING PARAMETER C---------------------------------------------------------------------- 609 IF(DAMP .GT. 0.05D0)THEN IF(JACNEW)THEN IF( DAMP .GT. 0.99D0)THEN DAMP = 0.75D0 ELSE IF(DAMP .GT. 0.55D0)THEN DAMP = 0.5D0 ELSE DAMP = DAMP* 0.5D0 END IF IF(ITRACE .GE. 1)WRITE(IDEV,6099)M,DAMP,DEL,DELP 6099 FORMAT(' ITER NO',I3,' DAMPING FACTOR REDUCED TO ',D12.4/ 1 ' DELY NORM=',D11.3,' OLD DELY NORM=',D11.3) GOTO 650 ELSE C TRY CONTINUING THE ITERATION WITH NEW JACOBIAN BASED ON C CURRENT VALUES OF SOLUTION DO 6010 I = 1,N ACOR(I) = 0.0D0 YSAVE(I,1) = Y(I) 6010 YSAVE(I,2) = YDOTI(I) * H GOTO 596 END IF END IF C--------------------------------------------------------------------- C CONVERGENCE FAILURE OR SINGULAR JACOBIAN. C--------------------------------------------------------------------- 60 H=HSAVE IF(INLN .EQ. 1)GOTO 69 IF(INLN .EQ. 2)GOTO 80 IF(M .GE. MAXCOR)THEN IF(ITRACE .GE. 1)CALL SERROR(' INITAL- ITERATION FAILURE 1 WITH DAMPING FACTOR (=R1) AND CONVERGENCE RATE (=R2)', 2 1, 0, 0, 0, 2, DAMP, CRATE) IF(IODE .EQ. 0 .AND.JACNT .EQ. 0)GOTO 80 C C ITERATION FAILED TO CONVERGE IF THE RATE OF C CONVERGENCE WAS O.K. TRY UPDATING THE CURRENT VALUES AND RE- C EVALUATING THE JACOBIAN, IREVAL COUNTS NO OF TRIES. IF(IREVAL .LT. 2)THEN INLN = 1 IREVAL = IREVAL + 1 DO 62 I = 1,N YSAVE(I,1) = Y(I) 62 YSAVE(I,2) = YDOTI(I)*H IF(CRATE.LT. 1.0D0 .AND. DAMP. GT. 0.02D0)GOTO 595 END IF ELSE IF(INLN .LT. 0)THEN CALL SERROR(' INITAL- SINGULAR JACOBIAN MATRIX FOUND 1 WHEN TRYING TO CALCULATE THE INITIAL VALUES.', 1, 0, 0, 0, 0, 2 0.0D0, 0.0D0) END IF IF(JACNT .GE. 3)GOTO 80 HFAC = 0.25 C---------------------------------------------------------------------- C REFORM JACOBIAN WITH SMALLER H AFTER RETRACTING SOLUTION C----------------------------------------------------------------------- H = H*HFAC DO 61 I = 1,N YSAVE(I,1) = YSAVE(I,1) - (1.0D0 -HFAC)*YSAVE(I,2) YSAVE(I,2) = YSAVE(I,2)*HFAC Y(I) = YSAVE(I,1) YDOTI(I) = YSAVE(I,2) / H 61 CONTINUE IF(DABS(H) .LT. HMIN)THEN CALL SERROR(' INITAL - ATTEMPT WAS MADE TO REDUCE STEPSIZE TO 1 BELOW THE MINIMUM STEPSIZE (=R1) DURING THE CALCULATION OF 2 INITIAL VALUES', 1, 0, 0, 0, 1, HMIN, 0.0D0) GOTO 95 END IF GOTO 59 C---------------------------------------------------------------------- C ITERATION FOR CURRENT VALUES HAS CONVERGED. C---------------------------------------------------------------------- 69 DO 68 I = 1,N YSAVE(I,1) = 0.0D0 YSAVE(I,2) = 0.0D0 68 CONTINUE H = HSAVE IF(ITRACE .GE. 1)THEN WRITE(IDEV,70) WRITE(IDEV,71)(Y(I), I = 1,N) 70 FORMAT(' INITIAL Y VALUES AFTER YDOT CALCULATED ARE') 71 FORMAT(1X,5D11.3) WRITE(IDEV,72) 72 FORMAT(' CALCULATED VALUES OF YDOT ARE ') WRITE(IDEV,721)(YDOTI(I), I = 1,N) 721 FORMAT(1X,5D11.3) END IF YDNORM = VNORM( N, YDOTI, EWT) IF(IMODE .EQ. 0 .AND. NFILTR .GT. 0)THEN TSAVE = T JACNT = 0 C SECOND BACKWARD EULER STEP IMODE = 1 J = 0 C IF(VALUES)J = 1 DO 799 I = 1,N YSAVE(I,1) = Y(I) YSAVE(I,4) = YDOTI(I)*H YDOTI(I) = YSAVE(I,3)*J YSAVE(I,2) = YDOTI(I)*H 799 CONTINUE GOTO 59 END IF YDNORM = VNORM( N, YDOTI, EWT) C---------------------------------------------------------------------- C IF FUNCTIONAL ITERATION WAS BEING USED OR THERE ARE NO C ALGEBRAIC EQUATIONS THEN RETURN. HOWEVER IN THE CASE WHEN C A NEWTON METHOD HAS BEEN USED TO SOLVE FOR THE INITIAL C VALUES FILTER OUT THE TIME DERIVS OF THE ALGEBRAIC COMPONENTS C BUT ONLY IF THE ALGEBRAIC EQUATIONS WERE NOT SATISFIED BY THE C CONDITIONS. C--------------------------------------------------------------------- I = IDACNT * JACNT D = DMAX1( SRUR * ABS(T), SRUR , 0.0005D0) IF(I .EQ. 0 .OR. NFILTR .EQ. 0)THEN INIT = 1 INSAVE = 0 RETURN ENDIF C C IF OPTIONAL FILTER IS NOT BEING USED THEN EXIT TO EVALUATE NORM C OF FILTERED YDOTS FOR USE IN CHOICE OF INITIAL STEPSIZE. IF( .NOT. SFILTR)THEN DO 759 I = 1,N 759 ACOR(I) = YDOTI(I) INLN = 5 INSAVE = 4 RETURN END IF NCOFIL = 0 INIT = 0 INSAVE = 4 INLN = 3 T = T - H * D C RETURN TO EVALUATE F(YDOT, Y ,T-H) RETURN 77 CONTINUE IF(.NOT. SFILTR)THEN YDNORM = VNORM( N, RES, EWT) / H GOTO 797 END IF T = T+H * D DO 771 I = 1,N YSAVE(I,3) = YDOTI(I) 771 ACOR(I) = RES(I) INLN = 3 INSAVE = 7 C RETURN TO EVALUATE F(YDOT, Y , T) RETURN C FORM PARTIAL F / PARTIAL T IN ACOR ARRAY 775 CONTINUE DO 777 I = 1,N 777 ACOR(I) = ( RES(I) - ACOR(I) ) /( D*H) INLN = 8 INSAVE = 8 C RETURN TO PUT A(Y,T) YDOT IN RES ARRAY RETURN 779 DO 780 I = 1,N 780 RES(I) = - RES(I)*IDAE(I) + ACOR(I) * H INLN = 4 INSAVE = 9 C RETURN FOR A BACK SUBSTITUTION ON CONTENTS OF RES(I) C TO CALCULATE THE NEW DERIVS. RETURN 781 CONTINUE DO 782 I = 1,N 782 YDOTI(I) = RES(I) / H YDNORM = VNORM( N, YDOTI, EWT) IF(ITRACE .GE. 1)THEN WRITE(IDEV,783) 783 FORMAT(' SUPPLIED INITIAL VALUES DID NOT SATISFY THE '/ 1 ' ALGEBRAIC EQUATIONS PERHAPS RESULTING IN THE CALCULATED'/ 2 ' VALUES FOR SOME YDOT BEING TOO LARGE . SPRINT TRIED TO '/ 3 ' FILTER OUT THESE VALUES. NEW VALUES ARE:') IF(ITRACE .GE. 1)WRITE(IDEV,721)(YDOTI(I), I = 1,N) END IF C C LOCAL ERROR TEST ON THE CORRECTED VALUES OF YDOT 797 TEM = YDNORM * H * 0.1D0 IF( TEM .GT. 1.0D0)THEN D = DMAX1( H , HMIN) D = H * 0.5 / TEM CALL SERROR(' SPRINT INITDB-THE LOCAL ERROR IN THE STEP TO 1 COMPUTE THE INITIAL VALUES MAY BE A FACTOR OF (=R1) TOO 2 LARGE. A POSSIBLY BETTER STEP SIZE COULD HAVE BEEN OF 3 SIZE (H = R2) ', 1, 0, 0, 0, 2, TEM, D) END IF INIT = 1 RETURN C----------------------------------------------------------------------- C FAILURE POINT - IF F/ITER WAS BEING USED SWITCH TO NEWTON METH C----------------------------------------------------------------------- 80 IF(IODE .EQ. 1 .OR. JACNT .GT. 0)THEN CALL SERROR(' INITAL- NONLINEAR SOLVER FAILED TO CONVERGE 1 USING A DAMPED NEWTON METHOD (DAMPING FACTOR =R1) TO 2 SOLVE FOR INITIAL VALUES. CONVERGENCE RATE WAS (=R2).' 3 , 1, 0, 0, 0, 2, DAMP, CRATE) ELSE CALL SERROR(' INITAL- NONLINEAR EQUATIONS SOLVER FAILED TO 1 CONVERGE ON THE INITIAL VALUES USING FUNCTIONAL ITERATION 2 A NEWTON METHOD WILL BE TRIED NOW',1,0,0,0,0,0.0D0,0.0D0) NFILTR = 1 DO 85 I = 1,N Y(I) = YSAVE(I,1) YDOTI(I) = YSAVE(I,2) YSAVE(I,2) = YSAVE(I,2) * HSAVE 85 CONTINUE INLN = 0 NFILTR = 1 H = HSAVE IMODE = 0 GOTO 54 ENDIF GOTO 95 90 IF( INLN .EQ. -3 .AND. IERCNT. LE. 3)THEN H = H * 0.5D0 IERCNT = IERCNT + 1 GOTO 8 ELSE IF (INLN .EQ. -5)THEN CALL SERROR(' INITAL - WORKSPACE ERROR OCCURRED WHEN 1 TRYING TO FORM THE JACOBIAN MATRIX IN CALCULATING THE 2 INITIAL VALUES OF THE SOLUTION AND ITS TIME DERIV.', 3 1, 0, 0, 0, 0, 0.0D0, 0.0D0) ELSE CALL SERROR(' INITAL- RESIDUAL ROUTINE RETURNED ERROR ', 1, 0, 1 0, 0, 0, 0.0D0, 0.0D0) END IF 95 INIT = -1 T = TSAVE RETURN C********************************************************************** END SUBROUTINE SPDINT(X,XOUT,YOUT,NEQ,KOLD,PHI,NYH, ND) C----------------------------------------------------------------------- C THE METHODS IN SUBROUTINE SPDASL USE POLYNOMIALS C TO APPROXIMATE THE SOLUTION. SPDINT 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 dastep, 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 OR C 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 DASSL PHI STARTS AT PHI(1,3) PLEASE NOTE C ND SOLUTION DERIVE REQUIRED MUST BE EITHER 0 OR 1 C C C VIA COMMON.... C psi array of past stepsize history C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) DIMENSION YOUT(1) DIMENSION PHI(NYH,1) COMMON /DDA002/ PSI(7),DUMMY(28) KOLDP1=KOLD+1 TEMP1=XOUT-X DO 10 I=1,NEQ YOUT(I)=PHI(I,1) * (1-ND) 10 CONTINUE 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*(1-ND) + D*ND) * PHI(I,J) 20 CONTINUE 30 CONTINUE RETURN C------END OF SUBROUTINE SPDINT------ END SUBROUTINE SPGINT(T, K, YH, NYH, DKY, IFLAG, NEQ, H) C----------------------------------------------------------------------- C SPRINT TIME INTERPOLATION ROUTINE FOR B.D.F / ADAMS METHODS BASED ON C NORDSIECK VECTOR IMPLEMENTATIONS. THIS ROUTINE IMPLEMENTS THE C1 C CONTINUOUS INTERPOLANT OF BERZINS PP 109-118 APPLIED NUM. MATHS. C VOL 2 (1986). C THE INTERPOLANT IS C0 CONTINUOUS UNLESS THE USER SUPPLIES ONE EXTRA C COMPONENT OF WORKSPACE YSAVE( NEQMAX, NY2DIM) C I.E. NY2DIM IS MAXORD + 2 INSTEAD OF JUST MAXORD + 1 C---------------------------------------------------------------------- INTEGER K, NYH, IFLAG, NEQ(1), NQ, - IOVFLO, NDUM, NIDUM, IDUMMY, LMAX, IDUMY, LMAXP1, - I, J, JJ, JJ1, JP1, N, L, KP1 DOUBLE PRECISION YH(NYH, 1), DKY(1), - T, H, HU, TN, HHUSED, C1, C2, C3, TEM, HRAT, - UROUND, DUNFLO, DDUM, DDUM2, RDUM1, RD, EL, - C, DD, R, S, TP, TESCO, RDUM3, D(15), ELCO LOGICAL PETZLD, FNITER, C1INTR CHARACTER*6 ODCODE COMMON /ODECHK/ ODCODE COMMON /SCONS1/ DUNFLO, UROUND, IOVFLO COMMON /LS0001/ RDUM1(2), EL(13), ELCO(13,12),RD(2), TESCO(3,12), - RDUM3(2), IDUMMY(2), LMAX, IDUMY(11) COMMON /LSIZES/ NIDUM(8), DDUM(2), TN, HU, DDUM2(7) COMMON /LSTATS/ NQN,NQ, NDUM(5) COMMON /LS001A/ PETZLD, FNITER, HHUSED, C1INTR SAVE /SCONS1/, /LSTATS/, /LSIZES/ ,/LS001A/, /ODECHK/ C----------------------------------------------------------------------- C INTDY COMPUTES INTERPOLATED VALUES OF THE K-TH DERIVATIVE OF THE C DEPENDENT VARIABLE VECTOR Y, AND STORES IT IN DKY. THIS ROUTINE C IS CALLED WITHIN THE PACKAGE WITH K = 0 AND T = TOUT, BUT MAY C ALSO BE CALLED BY THE USER FOR ANY K UP TO THE CURRENT ORDER. C THE INPUT PARAMETERS ARE.. C C T = VALUE OF INDEPENDENT VARIABLE WHERE ANSWERS ARE DESIRED C (NORMALLY THE SAME AS THE T LAST RETURNED BY SPRINT). C FOR VALID RESULTS, T MUST LIE BETWEEN TCUR - HU AND TCUR. C (SEE OPTIONAL OUTPUTS FOR TCUR AND HU.) C K = INTEGER ORDER OF THE DERIVATIVE DESIRED. K MUST SATISFY C 0 .LE. K .LE. NQCUR, WHERE NQCUR IS THE CURRENT ORDER C (SEE OPTIONAL OUTPUTS). THE CAPABILITY CORRESPONDING C TO K = 0, I.E. COMPUTING Y(T), IS ALREADY PROVIDED C BY SPRINT DIRECTLY. SINCE NQCUR .GE. 1, THE FIRST C DERIVATIVE DY/DT IS ALWAYS AVAILABLE WITH INTDY. C YH = THE HISTORY ARRAY YH (NORDSIECK VECTOR). C NYH = COLUMN LENGTH OF YH, EQUAL TO THE INITIAL VALUE OF NEQMAX C IN THE CALL TO SPRINT C NEQ(1) = THE NUMBER OF ORDINARY DIFFERENTIAL EQUATIONS C C THE NEXT FOUR PARAMETERS ARE PASSED ACROSS BY COMMON BLOCKS. C H = STEPSIZE PROPOSED * C FOR THE NEXT STEP * C HU = LAST STEPSIZE USED. * THESE ARE PASSED ACROSS BY C TN = THE LAST TIME LEVEL.* THE COMMON BLOCKS LSTATS AND LSIZES C NQ = THE ORDER USED. * C C THE OUTPUT PARAMETERS ARE.. C C DKY = A REAL ARRAY OF LENGTH NEQ CONTAINING THE COMPUTED VALUE C OF THE K-TH DERIVATIVE OF Y(T). C IFLAG = INTEGER FLAG, RETURNED AS 0 IF K AND T WERE LEGAL, C -1 IF K WAS ILLEGAL, AND -2 IF T WAS ILLEGAL. C ON AN ERROR RETURN, A MESSAGE IS ALSO WRITTEN. C----------------------------------------------------------------------- C THE COMPUTED VALUES IN DKY ARE GOTTEN BY INTERPOLATION USING THE C NORDSIECK HISTORY ARRAY YH. THIS ARRAY CORRESPONDS UNIQUELY TO A C VECTOR-VALUED POLYNOMIAL OF DEGREE NQCUR OR LESS, AND DKY IS SET C TO THE K-TH DERIVATIVE OF THIS POLYNOMIAL AT T. C IN THE CASE WHEN THE C0 INTERP IS USED THE FORMULA FOR DKY IS.. C Q C DKY(I) = SUM C(J,K) * (T - TN)**(J-K) * H**(-J) * YH(I,J+1) C J=K C WHERE C(J,K) = J*(J-1)*...*(J-K+1), Q = NQCUR, TN = TCUR, H = HCUR. C THE QUANTITIES NQ = NQCUR, L = NQ+1, N = NEQ, TN, AND H ARE C COMMUNICATED BY COMMON. THE ABOVE SUM IS DONE IN REVERSE ORDER. C IN THE CASE WHEN THE C1 INTERPOLANT IS USED AN EXTENDED NORDSIECK C VECTOR IS USED, SEE THE REFERENCE FOR DETAILS. C IFLAG IS RETURNED NEGATIVE IF EITHER K OR T IS OUT OF BOUNDS. C----------------------------------------------------------------------- IFLAG = 0 N = NEQ(1) L = NQ + 1 IF (K .LT. 0 .OR. K .GT. NQ) GO TO 80 IF(ODCODE .NE. 'SPGEAR' )GOTO 100 TP = TN - HU*(1.0D0 + 100.0D0*UROUND) IF ( (DABS(T-TN)) .LE.( DABS(T*UROUND)*100.0D0).OR. T.EQ.TN )THEN S = 0.0D0 GOTO 8 END IF IF ((T-TP)*(T-TN) .GT. 0.0D0) GO TO 90 S = (T - TN) / H C C SET UP D(I) COEFFS FOR C 1 INTERPOLANT (IF REQUESTED BY USER) C 8 D(1) = 0.0D0 D(2) = 0.0D0 HRAT = H / HU TEM = HRAT * HRAT IF( C1INTR )THEN J = 1 LMAXP1 = LMAX + 1 ELSE J = 0 LMAXP1 = 1 END IF DO 9 I = 1 , L D(I+2) = -ELCO(I,NQ) * J * TEM TEM = TEM * HRAT 9 CONTINUE C C1 = 1.0D0 C2 = 1.0D0 C3 = 1.0D0 JJ1 = NQ+1 - K DO 10 JJ = JJ1,NQ C2 = C2*(JJ+1) C3 = C3*(JJ+2) 10 C1 = C1* JJ DD = D(L)*C1 + S * (D(L+1)*C2 + C3*D(L+2)*S) DO 20 I = 1,N 20 DKY(I) = C1*YH(I,L) + YH(I,LMAXP1)*DD KP1 = K + 1 DO 50 J = NQ, KP1,-1 C = 1.0D0 DO 30 JJ = 1,K 30 C = C*(JJ+J-KP1) DO 40 I = 1,N 40 DKY(I) = C*(YH(I,J)+ YH(I,LMAXP1)*D(J)) + S*DKY(I) 50 CONTINUE IF (K .EQ. 0) RETURN IF (K .EQ. 1) THEN DO 58 I = 1,N 58 DKY(I) = DKY(I) / H ELSE R = H **(-K) DO 60 I = 1,N 60 DKY(I) = R*DKY(I) END IF RETURN C 80 CALL SERROR(' SPRINT INTERNAL TIME INTERPOLATION ROUTINE SPGINT 1 ERROR THE ORDER K (=I1) IS ILLEGAL',1,1,K,0,0,0.0D0,0.0D0) IFLAG = -1 RETURN 90 CALL SERROR(' SPRINT INTERNAL TIME INTERPOLATION ROUTINE SPGINT 1 ENTERED WITH T (=R1) ILLEGAL', 1, 0, 0, 0, 1, T, 0.0D0) CALL SERROR(' T NOT IN INTERVAL TCUR - HU (= R1) TO TCUR (=R2)', 1 1, 0, 0, 0, 2, TP, TN) IFLAG = -2 RETURN 100 CALL SERROR(' SPRINT INTERNAL TIME INTERPOLATION ROUTINE SPGINT 1 ENTERED WITH AN ILLEGAL INTEGRATOR.', 2 1, 0, 0, 0, 0,0.0D0,0.0D0) IFLAG = -3 RETURN C----------------------- END OF SUBROUTINE SPGINT ---------------------- END SUBROUTINE SPTINT (T, K, YH, NYH, DKY, IFLAG, NEQ, H) C----------------------------------------------------------------------- C SPRINT TIME INTERPOLATION ROUTINE FOR STHETA/ STHETB METHODS. C THIS ROUTINE IMPLEMENTS A C1 CONTINUOUS INTERPOLANT BASED ON A C HERMITE CUBIC INTERPOLATING POLYNOMIAL. C---------------------------------------------------------------------- INTEGER K, NYH, IFLAG, NEQ(1), I, N, IOVFLO, NIDUM, NDUM, IDUMMY DOUBLE PRECISION YH(NYH,4), DKY(1), D1, D2, S, TP, DUMMY, THETA, - T, H, HU, TN, C1, C2, C3, C4, HRAT, THETB, - UROUND, DUNFLO, DDUM, DDUM2, SSQ, OVTH CHARACTER*6 ODCODE COMMON /ODECHK/ ODCODE COMMON /SCONS1/ DUNFLO, UROUND, IOVFLO COMMON /LSIZES/ NIDUM(8), DDUM(2), TN, HU, DDUM2(7) COMMON /ST001A/ THETB, DUMMY(1), IDUMMY(2) SAVE /SCONS1/, /LSIZES/, /ODECHK/ C----------------------------------------------------------------------- C SPTINT COMPUTES INTERPOLATED VALUES OF THE K-TH DERIVATIVE OF THE C DEPENDENT VARIABLE VECTOR Y, AND STORES IT IN DKY. THIS ROUTINE C IS CALLED WITHIN THE PACKAGE WITH K = 0 AND T = TOUT, BUT MAY C ALSO BE CALLED BY THE USER FOR ANY K UP TO TWO. C THE INPUT PARAMETERS ARE.. C C T = VALUE OF INDEPENDENT VARIABLE WHERE ANSWERS ARE DESIRED C (NORMALLY THE SAME AS THE T LAST RETURNED BY SPRINT). C FOR VALID RESULTS, T MUST LIE BETWEEN TCUR - HU AND TCUR. C (SEE OPTIONAL OUTPUTS FOR TCUR AND HU.) C K = INTEGER ORDER OF THE DERIVATIVE DESIRED. K MUST SATISFY C 0 .LE. K .LE. TWO . THE CAPABILITY CORRESPONDING C TO K = 0, I.E. COMPUTING Y(T), IS ALREADY PROVIDED C BY SPRINT DIRECTLY. THE FIRST DERIVATIVE DY/DT IS C ALWAYS AVAILABLE WITH SPTINT. C YH = THE HISTORY ARRAY YH. C YH(I,1) CONTAINS SOLUTION AT TN C YH(I,2) CONTAINS DY/DT*H AT TN C YH(I,4) CONTAINS Y(TN+1) - Y(TN) C C NYH = COLUMN LENGTH OF YH, EQUAL TO THE INITIAL VALUE OF NEQMAX C IN THE CALL TO SPRINT C NEQ(1) = THE NUMBER OF ORDINARY DIFFERENTIAL EQUATIONS C C THE NEXT THREE PARAMETERS ARE PASSED ACROSS BY COMMON BLOCKS. C H = STEPSIZE PROPOSED * C FOR THE NEXT STEP * C HU = LAST STEPSIZE USED. * THESE ARE PASSED ACROSS BY C TN = THE LAST TIME LEVEL.* THE COMMON BLOCKS LSTATS AND LSIZES C C THE OUTPUT PARAMETERS ARE.. C C DKY = A REAL ARRAY OF LENGTH NEQ CONTAINING THE COMPUTED VALUE C OF THE K-TH DERIVATIVE OF Y(T). C IFLAG = INTEGER FLAG, RETURNED AS 0 IF K AND T WERE LEGAL, C -1 IF K WAS ILLEGAL, AND -2 IF T WAS ILLEGAL. C ON AN ERROR RETURN, A MESSAGE IS ALSO WRITTEN. C----------------------------------------------------------------------- C THE COMPUTED VALUES IN DKY ARE COMPUTED BY INTERPOLATION USING THE C HISTORY ARRAY YH AND A CUBIC HERMITE POLYNOMIAL. DKY IS SET C TO THE K-TH DERIVATIVE OF THIS POLYNOMIAL AT T. C IFLAG IS RETURNED NEGATIVE IF EITHER K OR T IS OUT OF BOUNDS. C----------------------------------------------------------------------- IFLAG = 0 N = NEQ(1) IF (K .LT. 0 .OR. K .GT. 2) GO TO 700 IF(ODCODE .NE. 'STHETA' .AND. ODCODE .NE.'STHETB')GOTO 900 TP = TN - HU*(1.0D0 + 100.0D0*UROUND) IF ( (DABS(T-TN)) .LE.( DABS(T*UROUND)*100.0D0).OR. T.EQ.TN )THEN S = 0.0D0 GOTO 8 END IF IF ((T-TP)*(T-TN) .GT. 0.0D0) GO TO 800 S = (T - TN) / HU SSQ = S * S C S MUST BE IN THE RANGE (-1 , 0) C C SET UP THE C AND D COEFFS FOR THE INTERPOLANT C 8 HRAT = HU / H THETA= 0.55D0 IF( ODCODE .EQ. 'STHETB')THETA = THETB OVTH = 1.0D0 / (1.D0 - THETA) C1 =-3.D0 + OVTH C2 =-2.D0 + OVTH C4 = HRAT * (1.0D0 - THETA * OVTH ) C3 = C4 + HRAT C C SET UP THE INTERPOLATION COEFFICIENTS. C IF (K .EQ. 0)THEN D1 = (C1 + C2*S) * SSQ D2 = (C3 + C4*S) * SSQ ELSE IF (K .EQ. 1)THEN D1 = (2.0D0 * C1 + 3.0D0 * C2*S) * S / HU D2 = (2.0D0 * C3 + 3.0D0 * C4*S) * S / HU ELSE IF (K .EQ. 2)THEN D1 = (2.0D0 * C1 + 6.0D0 * C2*S) /HU**2 D2 = (2.0D0 * C3 + 6.0D0 * C4*S) /HU**2 END IF C C NOW PERFORM THE INTERPOLATION C IF( K .EQ. 0)THEN DO 100 I = 1,N DKY(I) = YH(I,1) + YH(I,2) * (S*HRAT+D2) + YH(I,4)*D1 100 CONTINUE ELSE IF( K .EQ. 1)THEN DO 200 I = 1,N DKY(I) = YH(I,2) * (1.D0/H+D2) + YH(I,4)*D1 200 CONTINUE ELSE IF( K .EQ. 2)THEN DO 300 I = 1,N DKY(I) = YH(I,2) * ( +D2) + YH(I,4)*D1 300 CONTINUE END IF RETURN C 700 CALL SERROR(' SPRINT INTERNAL TIME INTERPOLATION ROUTINE SPTINT 1 ERROR THE ORDER K (=I1) IS ILLEGAL',1,1,K,0,0,0.0D0,0.0D0) IFLAG = -1 RETURN 800 CALL SERROR(' SPRINT INTERNAL TIME INTERPOLATION ROUTINE SPTINT 1 ENTERED WITH T (=R1) ILLEGAL', 1, 0, 0, 0, 1, T, 0.0D0) CALL SERROR(' T NOT IN INTERVAL TCUR - HU (= R1) TO TCUR (=R2)', 1 1, 0, 0, 0, 2, TP, TN) IFLAG = -2 RETURN 900 CALL SERROR(' SPRINT INTERNAL TIME INTERPOLATION ROUTINE SPTINT 1 CALLED WHEN THE INTEGRATOR WAS NOT STHETA OR STHETB', 3 1, 0, 0, 0, 0,0.0D0,0.0D0) IFLAG = -3 RETURN C----------------------- END OF SUBROUTINE SPTINT ---------------------- END SUBROUTINE SPBINT (T, K, YH, NYH, DKY, IFLAG, NEQ, H) C----------------------------------------------------------------------- C TIME INTERPOLATION ROUTINE FOR BLEND MULTISTEP METHODS BASED UPON C NORDSIECK VECTOR IMPLEMENTATION. C---------------------------------------------------------------------- INTEGER K, NYH, IFLAG, NEQ(1), NQ, NQN INTEGER IOVFLO, NDUM, NIDUM INTEGER I, IC, J, JB, JB2, JJ, JJ1, JP1, N, L DOUBLE PRECISION T, YH, DKY, H, HU, TN DOUBLE PRECISION UROUND, DUNFLO, DDUM, DDUM2 DOUBLE PRECISION C, R, S, TP DIMENSION YH(NYH,1), DKY(1) COMMON /SCONS1/ DUNFLO, UROUND, IOVFLO COMMON /LSIZES/ NIDUM(8), DDUM(2), TN, HU, DDUM2(7) COMMON /LSTATS/ NQN, NQ, NDUM(5) SAVE /SCONS1/, /LSTATS/, /LSIZES/ C----------------------------------------------------------------------- C SPBINT COMPUTES INTERPOLATED VALUES OF THE K-TH DERIVATIVE OF THE C DEPENDENT VARIABLE VECTOR Y, AND STORES IT IN DKY. THIS ROUTINE C IS CALLED WITHIN THE PACKAGE WITH K = 0 AND T = TOUT, BUT MAY C ALSO BE CALLED BY THE USER FOR ANY K UP TO THE CURRENT ORDER. C THE INPUT PARAMETERS ARE.. C C T = VALUE OF INDEPENDENT VARIABLE WHERE ANSWERS ARE DESIRED C (NORMALLY THE SAME AS THE T LAST RETURNED BY SPRINT). C FOR VALID RESULTS, T MUST LIE BETWEEN TCUR - HU AND TCUR. C (SEE OPTIONAL OUTPUTS FOR TCUR AND HU.) C K = INTEGER ORDER OF THE DERIVATIVE DESIRED. K MUST SATISFY C 0 .LE. K .LE. NQCUR, WHERE NQCUR IS THE CURRENT ORDER C (SEE OPTIONAL OUTPUTS). THE CAPABILITY CORRESPONDING C TO K = 0, I.E. COMPUTING Y(T), IS ALREADY PROVIDED C BY SPRINT DIRECTLY. SINCE NQCUR .GE. 1, THE FIRST C DERIVATIVE DY/DT IS ALWAYS AVAILABLE WITH SPBINT C YH = THE HISTORY ARRAY YH (NORDSIECK VECTOR). C NYH = COLUMN LENGTH OF YH, EQUAL TO THE INITIAL VALUE OF NEQ. C NEQ(1) = THE NUMBER OF ORDINARY DIFFERENTIAL EQUATIONS C H = CURRENT STEPSIZE. C HU = LAST STEPSIZE USED. @ THESE ARE PASSED ACROSS BY C TN = THE LAST TIME LEVEL.@ THE COMMON BLOCKS LSTATS AND LSIZES C NQ = THE ORDER USED. @ C C THE OUTPUT PARAMETERS ARE.. C C DKY = A REAL ARRAY OF LENGTH NEQ CONTAINING THE COMPUTED VALUE C OF THE K-TH DERIVATIVE OF Y(T). C IFLAG = INTEGER FLAG, RETURNED AS 0 IF K AND T WERE LEGAL, C -1 IF K WAS ILLEGAL, AND -2 IF T WAS ILLEGAL. C ON AN ERROR RETURN, A MESSAGE IS ALSO WRITTEN. C----------------------------------------------------------------------- C THE COMPUTED VALUES IN DKY ARE GOTTEN BY INTERPOLATION USING THE C NORDSIECK HISTORY ARRAY YH. THIS ARRAY CORRESPONDS UNIQUELY TO A C VECTOR-VALUED POLYNOMIAL OF DEGREE NQCUR OR LESS, AND DKY IS SET C TO THE K-TH DERIVATIVE OF THIS POLYNOMIAL AT T. C THE FORMULA FOR DKY IS.. C Q C DKY(I) = SUM C(J,K) * (T - TN)**(J-K) * H**(-J) * YH(I,J+1) C J=K C WHERE C(J,K) = J*(J-1)*...*(J-K+1), Q = NQCUR, TN = TCUR, H = HCUR. C THE QUANTITIES NQ = NQCUR, L = NQ+1, N = NEQ, TN, AND H ARE C COMMUNICATED BY COMMON. THE ABOVE SUM IS DONE IN REVERSE ORDER. C IFLAG IS RETURNED NEGATIVE IF EITHER K OR T IS OUT OF BOUNDS. C----------------------------------------------------------------------- IFLAG = 0 N = NEQ(1) L = NQ + 1 IF (K .LT. 0 .OR. K .GT. NQ) GO TO 80 TP = TN - HU*(1.0D0 + 100.0D0*UROUND) IF ( (DABS(T-TN)) .LE.( DABS(T*UROUND)*100.0D0).OR. T.EQ.TN )THEN S = 0.0D0 GOTO 9 END IF IF ((T-TP)*(T-TN) .GT. 0.0D0) GO TO 90 9 S = (T - TN)/H IC = 1 IF (K .EQ. 0) GO TO 15 JJ1 = L - K DO 10 JJ = JJ1,NQ 10 IC = IC*JJ 15 C = IC DO 20 I = 1,N 20 DKY(I) = C*YH(I,L) IF (K .EQ. NQ) GO TO 55 JB2 = NQ - K DO 50 JB = 1,JB2 J = NQ - JB JP1 = J + 1 IC = 1 IF (K .EQ. 0) GO TO 35 JJ1 = JP1 - K DO 30 JJ = JJ1,J 30 IC = IC*JJ 35 C = IC DO 40 I = 1,N 40 DKY(I) = C*YH(I,JP1) + S*DKY(I) 50 CONTINUE IF (K .EQ. 0) RETURN 55 R = H**(-K) DO 60 I = 1,N 60 DKY(I) = R*DKY(I) RETURN C 80 CALL SERROR(' SPRINT INTERNAL TIME INTERPOLATION ROUTINE SPBINT 1 ERROR THE ORDER K (=I1) IS ILLEGAL',1,1,K,0,0,0.0D0,0.0D0) IFLAG = -1 RETURN 90 CALL SERROR(' SPRINT INTERNAL TIME INTERPOLATION ROUTINE SPBINT 1 ENTERED WITH T (=R1) ILLEGAL', 1, 0, 0, 0, 1, T, 0.0D0) CALL SERROR(' T NOT IN INTERVAL TCUR - HU (= R1) TO TCUR (=R2)', 1 1, 0, 0, 0, 2, TP, TN) IFLAG = -2 RETURN C----------------------- END OF SUBROUTINE SPBINT ---------------------- END SUBROUTINE BLDSET( NY2DIM, IRET, MAXORD) INTEGER NY2DIM, MAXORD, IRET C---------------------------------------------------------------------- C THIS ROUTINE INITIALISES THE LSODI IMPLENTATION OF ADAMS/B.D.F C BLEND METHOD AS USED IN TH SPRINT INTEGRATION PACKAGE C THE INPUT PARAMETERS ARE: C NY2DIM , THE SECOND DIMENSION OF THE ARRAY YSAVE(NYH,NY2DIM) C THIS VALUE MUST BE SET TO MAXORD + 3, UNLESS MAXORD = 0 C (SEE BELOW ). C MAXORD THE MAXIMUM ORDER TO BE USED BY THE BLEND METHOD. C THIS VALUE MUST BE POSITIVE AND LESS THAN 12 FOR BLEND. C IF MAXORD IS ZERO THE DEFAULT VALUE OF 11 IS USED, AND C NY2DIM MUST BE LARGE ENOUGH. C OUTPUT PARAMETER; C IRET INTEGER FLAG SET TO ZERO IF ALL INPUTS ARE O.K. C OTHERWISE SET TO -1 TO INDICATE AN ERROR EXIT C---------------------------------------------------------------------- C INTEGER IOWNS, NMETH, NMXORD, IDM, I DOUBLE PRECISION ROWNS,CCMAX CHARACTER*6 ODCODE C COMMON /ODECHK/ ODCODE COMMON /BL0001/ ROWNS(355), IOWNS(8), NMETH, NMXORD, IDM(3) COMMON /SPCCMX/ CCMAX SAVE /ODECHK/, /BL0001/, /SPCCMX/ IRET = 0 NMETH = 2 CCMAX = 0.3D0 C IDM(2) CONTAINS THE PARAMETER WHICH SPECIFIES HOW MANY C CONVERGENCE FAILURES ARE ALLOWED. C IDM(2) = 5 IF (MAXORD.LT.0)THEN CALL SERROR(' BLDSET NEGTIVE VALUE OF MAXORD (=I1) IS ILLEGAL' 1 , 1, 1, MAXORD, 0, 0, 0.0D0, 0.0D0) IRET = -1 END IF IF ( MAXORD.EQ.0)THEN MAXORD = 11 ELSE IF(MAXORD .GT. 11)THEN CALL SERROR(' BLDSET WARNING USER SUPPLIED MAXORD (=I1) IS 1 GREATER THAN ALLOWED (=I2) AND IS RESET TO THE ALLOWED MAX', 2 1, 2, MAXORD, 11, 0, 0.0D0, 0.0D0) END IF MAXORD = MIN0(MAXORD, 11) END IF NMXORD = MAXORD IF( NY2DIM .LT. (MAXORD+3))THEN I = MAXORD + 3 CALL SERROR(' BLDSET - ERROR SECOND DIMENSION OF YSAVE ARRAY 1 ,NY2DIM (=I1) IS SMALLER THAN REQUIRED (=I2), 2 INCREASE THE ARRAY DIMENSION ', 1, 2, NY2DIM, 3 I, 0 , 0.0D0, 0.0D0) IRET = -1 ELSE ODCODE = 'SBLEND' END IF RETURN C------END-OF-ROUTINE-BLDSET------------------------------------------- END SUBROUTINE SBLEND(NEQ, Y, YH, NYH, EWT, YDOT, SAVR, ACOR, INLN, 1 ISTEP, EL0, H, TN, HMIN, HMXI, IDAE) INTEGER NEQ, NYH, INLN, ISTEP, IDAE(1) INTEGER IALTH, IPUP, LMAX, MEO, NSLP, ICF, JCUR, 1 L, METH, MAXORD, MSBP, MXNCF, N, IOVFLO, 2 NQ, NST, NRE, NJE, NQU, NITER, JSTART, KFLAG INTEGER I,JC,IREDO, IRET, J, JB, KGO, NCF, NEWQ,ITRACE,IDEV,IZ INTEGER MAXIT, NT, NINTER, IOMEGA, IOMEGB, M, MAXCOR, IFLAG DOUBLE PRECISION Y, YH, EWT, YDOT, SAVR, ACOR, EL0, H, TN, HMXI, 1 HMIN, ROWND, DUN, U DOUBLE PRECISION CONIT, AL, ALCO, HOLD, RMAX, TESCO, CCMAX, RC DOUBLE PRECISION DDN, DUP, DSN, BL, BLCO, BLJH, 1 ALJH, EXDN, EXSM, EXUP, C, GAMMA, 2 R, RH, RHDN, RHSM, RHUP, TOLD, VNORM, WB, RMWB DOUBLE PRECISION DAMP, RJNORM, CCMX1 DOUBLE PRECISION ELSAVE, DEL, DELP, CRATE, EL1H, EL, DCON, BND CHARACTER*6 ODCODE DIMENSION NEQ(1),Y(1),YH(NYH,1),EWT(1),YDOT(1),SAVR(1),ACOR(1) COMMON /BL0001/ ROWND, CONIT, AL(13), ALCO(13,12), BL(12), 1 BLCO(12,11), HOLD, RMAX, TESCO(3,12), CCMAX, RC, 2 IALTH, IPUP, LMAX, MEO, NSLP, 3 ICF, JCUR, L, METH, MAXORD, MSBP, MXNCF, N COMMON /ODECHK/ ODCODE COMMON /SCONS1/ DUN, U, IOVFLO COMMON /LSTATS/ NQ, NQU, NST, NRE, NJE, NITER, NINTER COMMON /SSOLVR/ DAMP, RJNORM, CRATE, MAXIT COMMON /SPCCMX/ CCMX1 C C EXTRA COMMON BLOCK FOR REVERSE COMMUNICATION C COMMON /BLSAVE/ DDN, DSN, DUP, ALJH, BLJH, ELSAVE, DEL, 1 DELP, EL1H, EL, DCON, C(11), GAMMA(11), RMWB, WB, BND, 2 EXDN, EXSM, EXUP, R, RH, RHDN, RHSM, RHUP, TOLD, 3 I, JC, IREDO, IRET, J, JB, KGO, NCF, IZ, JSTART, KFLAG, 4 IOMEGA, IOMEGB, M ,MAXCOR, IFLAG, NT COMMON /SDEV2/ ITRACE,IDEV SAVE /BLSAVE/, /ODECHK/, /LSTATS/, /SSOLVR/, /BL0001/, 1 /SCONS1/, /SPCCMX/ C----------------------------------------------------------------------- C SBLEND PERFORMS ONE STEP OF THE INTEGRATION OF AN INITIAL VALUE C PROBLEM FOR A SYSTEM OF ORDINARY DIFFERENTIAL EQUATIONS. C NOTE..SBLEND IS INDEPENDENT C OF THE TYPE OF CHORD METHOD USED, OR THE JACOBIAN STRUCTURE. C COMMUNICATION WITH SBLEND IS DONE WITH THE FOLLOWING VARIABLES.. C C NEQ = INTEGER ARRAY CONTAINING PROBLEM SIZE IN NEQ(1), AND C NOT USED EXCEPT TO INITIALISE THE COMMON BLOCK VARIABLE N C Y = AN ARRAY OF LENGTH .GE. N USED AS THE Y ARGUMENT IN C ALL CALLS TO RES, JAC, AND ADDA. ON THE FIRST CALL THIS C ARRAY IS ASSUMED TO CONTAIN THE INITIAL SOLUTION VALUES. C YH = AN NYH BY LMAX ARRAY CONTAINING THE DEPENDENT VARIABLES C AND THEIR APPROXIMATE SCALED DERIVATIVES, WHERE C LMAX = MAXORD + 3. YH(I,J+1) CONTAINS THE APPROXIMATE C J-TH DERIVATIVE OF Y(I), SCALED BY H**J/FACTORIAL(J) C (J = 0,1,...,NQ). YH(I,LMAX+2) AND YH(I,LMAX+3) ARE WORK C ARRAYS USED IN SOLVING THE NONLINEAR SYSTEM OF EQUATIONS. C NYH = A CONSTANT INTEGER .GE. N, THE FIRST DIMENSION OF YH. C EWT = AN ARRAY OF LENGTH N CONTAINING MULTIPLICATIVE WEIGHTS C FOR LOCAL ERROR MEASUREMENTS. LOCAL ERRORS IN Y(I) ARE C COMPARED TO 1.0/EWT(I) IN VARIOUS ERROR TESTS. C YDOT = AN ARRAY OF WORKING STORAGE, OF LENGTH N. ALSO USED FOR C INPUT OF YH(*,MAXORD+2) WHEN JSTART = -1 AND MAXORD IS LESS C THAN THE CURRENT ORDER NQ. ON THE FIRST CALL THIS ARRAY IS C ASSUMED TO HOLD THE INITIAL VALUES OF THE TIME DERIVATIVE. C SAVR = AN ARRAY OF WORKING STORAGE, OF LENGTH N. C THIS ARRAY IS NOT USED IN THE PRESENT IMPLEMENTATION. C ACOR = A WORK ARRAY OF LENGTH N USED FOR THE ACCUMULATED C CORRECTIONS. ON A SUCCESFUL RETURN, ACOR(I) CONTAINS C THE ESTIMATED ONE-STEP LOCAL ERROR IN Y(I). C CCMAX = MAXIMUM RELATIVE CHANGE IN H*EL0 BEFORE PJAC IS CALLED. C H = THE STEP SIZE TO BE ATTEMPTED ON THE NEXT STEP. C H IS ALTERED BY THE ERROR CONTROL ALGORITHM DURING THE C PROBLEM. H CAN BE EITHER POSITIVE OR NEGATIVE, BUT ITS C SIGN MUST REMAIN CONSTANT THROUGHOUT THE PROBLEM. C HMIN = THE MINIMUM ABSOLUTE VALUE OF THE STEP SIZE H TO BE USED. C HMXI = INVERSE OF THE MAXIMUM ABSOLUTE VALUE OF H TO BE USED. C HMXI = 0.0 IS ALLOWED AND CORRESPONDS TO AN INFINITE HMAX. C HMIN AND HMXI MAY BE CHANGED AT ANY TIME, BUT WILL NOT C TAKE EFFECT UNTIL THE NEXT CHANGE OF H IS CONSIDERED. C IDAE = INDICATOR ARRAY OF DIMENSION NEQ(1). IDAE(J) = 0 IF THE JTH C EQUTAION IS ALGEBRAIC AND 1 OTHERWISE. C TN = THE INDEPENDENT VARIABLE. TN IS UPDATED ON EACH STEP TAKEN. C ISTEP : INPUT AND OUTPUT ERROR INDICATOR C ON INPUT ITS VALUES ARE TRANSFERRED INTO JSTART C ON OUTPUT IT TAKES THE VALUES OF KFLAG . IN BOTH CASES C THE ACTUAL VALUES ARE MODIFIED SO AS TO CORRESSPOND TO C THE SPRINT INTERFACE. C INPUT: -1 PERFORM THE FIRST STEP (JSTART = 0). C 0 REVERSE COMMUNICATION RETURN FROM NLSLVR ROUTINE. C 1 TAKE A NEW STEP CONTINUING FROM THE LAST (JSTART=1) C 2 TAKE THE NEXT STEP WITH A NEW VALUE OF H, MAXORD, C N, METH, (JSTART = -1). C 3 TAKE THE NEXT STEP WITH A NEW VALUE OF H, C BUT WITH OTHER INPUTS UNCHANGED (JSTART = -2) C ON RETURN, ISTEP IS SET TO 1 TO FACILITATE CONTINUATION. C OUTPUT: 1 THE STEP WAS SUCCESSFUL , KFLAG = 0. C 0 REVERSE COMMUNICATION RETURN - CHECK INLN. C -1 THE REQUESTED ERROR COULD NOT BE ACHIEVED. C -2 CORRECTOR CONVERGENCE COULD NOT BE ACHIEVED. C -3 RES ORDERED IMMEDIATE RETURN. C -4 ERROR CONDITION FROM RES COULD NOT BE AVOIDED. C -5 FATAL ERROR IN JACOBIAN FORMING OR BACKSUBSTITUTION. C -6 INIT MODULE LSET WAS NOT CALLED PRIOR TO FIRST ENTRY. C -7 WORKSPACE ERROR OCCURED IN THE NONLINEAR SOLVER . C APART FROM WHEN ISTEP = 0 OR 1 , ISTEP = KFLAG ON OUTPUT. C A RETURN WITH ISTEP = -1, -2, OR -4 MEANS EITHER C ABS(H) = HMIN OR 10 CONSECUTIVE FAILURES OCCURRED. C ON A RETURN WITH ISTEP NEGATIVE, THE VALUES OF TN AND C THE YH ARRAY ARE AS OF THE BEGINNING OF THE LAST C STEP, AND H IS THE LAST STEP SIZE ATTEMPTED. C MAXORD = THE MAXIMUM ORDER OF INTEGRATION METHOD TO BE ALLOWED. C MSBP = MAXIMUM NUMBER OF STEPS BETWEEN PJAC CALLS. C MXNCF = MAXIMUM NUMBER OF CONVERGENCE FAILURES ALLOWED. C METH = THE METHOD FLAG. SEE DESCRIPTION IN ROUTINE BLSET. C N = THE NUMBER OF FIRST-ORDER DIFFERENTIAL EQUATIONS. C C INLN = REVERSE COMMUNICATION INDICATOR C C ON ENTRY INLN = 0 : NORMAL ENTRY C = -1 : ERROR IN JACOBIAN FORMATION C = -2 : RESID ORDERED RETURN TO USER C = -3 : RESID FOUND ILLEGAL T, Y, OR YDOTI. C = -4 : RESID ORDERED ENTRY TO MONITR. C = -5 : WORKSPACE ERROR IN LINEAR ALGEBRA. C = 1 : NONLINEAR SYSTEM SOLVED C = 2 : ITERATION FAILED TO CONVERGE IN C SOLUTION OF NONLINEAR SYSTEM C = 3,4 NOT USED IN THIS MODULE C = 5 RETURN TO FORM THE PETZOLD ERROR EST C I.E. J INVERSE * DF/DYDOT * ACOR C C ON EXIT INLN = 0 : NORMAL EXIT C = 1 : FORM JACOBIAN AND SOLVE NONLINEAR SYSTEM C = 2 : AS FOR INLN = 1 BUT USING OLD JACOBIAN C = 3,4 NOT USED HERE. C = 5 FORM PETZOLD ERROR ESTIMATE. C = 6,7 NOT USED HERE. C----------------------------------------------------------------------- C C JUMP IF IT IS REVERSE COMMUNICATION C IZ = INLN + 5 INLN = 0 GOTO ( 430, 430, 430, 430, 10, 232, 410, 240, 245, 247),IZ GOTO 435 10 KFLAG = 0 IF(ODCODE .NE. 'SBLEND')THEN CALL SERROR(' SBLEND- SETUP MODULE LSET WAS NOT CALLED PRIOR TO 1 ENTRY TO SPRINT- ERROR', 1, 0, 0, 0, 0, 0.0D0, 0.0D0) ISTEP = -6 RETURN END IF TOLD = TN NCF = 0 JCUR = 0 ICF = 0 IF(ISTEP .EQ. 1)THEN JSTART = 1 GOTO 200 ELSE IF(ISTEP .EQ. 2)THEN JSTART = -1 GOTO 100 ELSE IF(ISTEP .EQ. 3)THEN JSTART = -2 GOTO 160 END IF JSTART = 0 C----------------------------------------------------------------------- C ON THE FIRST CALL, THE ORDER IS SET TO 1, AND OTHER VARIABLES ARE C INITIALIZED. RMAX IS THE MAXIMUM RATIO BY WHICH H CAN BE INCREASED C IN A SINGLE STEP. IT IS INITIALLY 1.E4 TO COMPENSATE FOR THE SMALL C INITIAL H, BUT THEN IS NORMALLY EQUAL TO 10. IF A FAILURE C OCCURS (IN CORRECTOR CONVERGENCE OR ERROR TEST), RMAX IS SET AT 2 C FOR THE NEXT INCREASE. C----------------------------------------------------------------------- LMAX = MAXORD + 1 NINTER = LMAX IOMEGA = LMAX + 1 IOMEGB = LMAX + 2 N = NEQ(1) NQ = 1 L = 2 IALTH = 2 RMAX = 10000.0D0 RC = 0.0D0 EL0 = 1.0D0 MSBP = 20 CCMAX = 0.3D0 HOLD = H MEO = METH NSLP = 0 IPUP = 1 IRET = 3 C C LOAD THE INITIAL VALUES OF Y AND YDOT INTO THE NORDSIECK VECTOR. C DO 20 I = 1,N YH(I,1) = Y(I) YH(I,2) = YDOT(I)*H 20 CONTINUE GO TO 140 C----------------------------------------------------------------------- C THE FOLLOWING BLOCK HANDLES PRELIMINARIES NEEDED WHEN JSTART = -1. C IPUP IS SET TO 1 TO FORCE A MATRIX UPDATE. C IF AN ORDER INCREASE IS ABOUT TO BE CONSIDERED (IALTH = 1), C IALTH IS RESET TO 2 TO POSTPONE CONSIDERATION ONE MORE STEP. C IF THE CALLER HAS CHANGED METH, CFODE IS CALLED TO RESET C THE COEFFICIENTS OF THE METHOD. C IF THE CALLER HAS CHANGED MAXORD TO A VALUE LESS THAN THE CURRENT C ORDER NQ, NQ IS REDUCED TO MAXORD, AND A NEW H CHOSEN ACCORDINGLY. C IF H IS TO BE CHANGED, YH MUST BE RESCALED. C IF H OR METH IS BEING CHANGED, IALTH IS RESET TO L = NQ + 1 C TO PREVENT FURTHER CHANGES IN H FOR THAT MANY STEPS. C----------------------------------------------------------------------- 100 IPUP = 1 LMAX = MAXORD + 1 NINTER = LMAX IOMEGA = LMAX + 1 IOMEGB = LMAX + 2 IF(NEQ(1) .LT. N)THEN C NUMBER OF O.D.E.S HAS BEEN REDUCED- ZERO PART OF MEMORY VECTOR J = NEQ(1) + 1 DO 105 I = J,N DO 105 JB = 1,NQ+1 YH(I,JB) = 0.0D0 105 CONTINUE ELSE IF(NEQ(1) .GT. N .AND. ITRACE .GE. 1) THEN CALL SERROR(' SBLEND- VALUE OF NEQ(1) (=I1) GT N(=I2)', 1, 1 2, NEQ(1), N, 0, 0.0D0, 0.0D0) END IF N = NEQ(1) IF (IALTH .EQ. 1) IALTH = 2 IF (METH .EQ. MEO) GO TO 110 CALL CFODE (METH, ALCO, BLCO, TESCO, GAMMA, C) MEO = METH IF (NQ .GT. MAXORD) GO TO 120 IALTH = L IRET = 1 GO TO 150 110 IF (NQ .LE. MAXORD) GO TO 160 120 NQ = MAXORD C C MAXORD HAS BEEN REDUCED TO BELOW NQ C J = MAXORD + 2 L = LMAX DO 125 I = 1,L BL(I) = BLCO(I,NQ) 125 AL(I) = ALCO(I,NQ) RC = RC*C(NQ)/EL0 EL0 = C(NQ) CONIT = 0.5D0/DBLE(NQ+2) DDN = VNORM (N, YH(1,J), EWT)/TESCO(1,L) EXDN = 1.0D0/DBLE(L) RHDN = 1.0D0/(1.3D0*DDN**EXDN + 0.0000013D0) RH = DMIN1(RHDN,1.0D0) IREDO = 3 IF (H .EQ. HOLD) GO TO 170 RH = DMIN1(RH,DABS(H/HOLD)) H = HOLD GO TO 175 C----------------------------------------------------------------------- C CFODE IS CALLED TO GET ALL THE INTEGRATION COEFFICIENTS FOR THE C CURRENT METH. THEN THE EL VECTOR AND RELATED CONSTANTS ARE RESET C WHENEVER THE ORDER NQ IS CHANGED, OR AT THE START OF THE PROBLEM. C----------------------------------------------------------------------- 140 CALL CFODE (METH, ALCO, BLCO, TESCO, GAMMA, C) 150 DO 155 I = 1,L BL(I) = BLCO(I,NQ) AL(I) = ALCO(I,NQ) 155 CONTINUE RC = RC*C(NQ)/EL0 EL0 = C(NQ) CONIT = 0.5D0/DBLE(NQ+2) GO TO (160, 170, 200), IRET C----------------------------------------------------------------------- C IF H IS BEING CHANGED, THE H RATIO RH IS CHECKED AGAINST C RMAX, HMIN, AND HMXI, AND THE YH ARRAY RESCALED. IALTH IS SET TO C L = NQ + 1 TO PREVENT A CHANGE OF H FOR THAT MANY STEPS, UNLESS C FORCED BY A CONVERGENCE OR ERROR TEST FAILURE. C----------------------------------------------------------------------- 160 IF (H .EQ. HOLD) GO TO 200 RH = H/HOLD H = HOLD IREDO = 3 GO TO 175 170 RH = DMAX1(RH,HMIN/DABS(H)) 175 RH = DMIN1(RH,RMAX) RH = RH/DMAX1(1.0D0,DABS(H)*HMXI*RH) R = 1.0D0 DO 180 J = 2,L R = R*RH DO 180 I = 1,N 180 YH(I,J) = YH(I,J)*R H = H*RH RC = RC*RH IALTH = L IF (IREDO .EQ. 0) GO TO 690 C----------------------------------------------------------------------- C THIS SECTION COMPUTES THE PREDICTED VALUES BY EFFECTIVELY C MULTIPLYING THE YH ARRAY BY THE PASCAL TRIANGLE MATRIX. C RC IS THE RATIO OF NEW TO OLD VALUES OF THE COEFFICIENT H*EL(1). C WHEN RC DIFFERS FROM 1 BY MORE THAN CCMAX, IPUP IS SET TO 1 C TO FORCE PJAC TO BE CALLED. C IN ANY CASE, PJAC IS CALLED AT LEAST EVERY MSBP STEPS. C----------------------------------------------------------------------- 200 IF(DABS(RC-1.0D0) .GT. CCMX1 .OR. NST .GE. (NSLP+MSBP)) IPUP = 1 TN = TN + H DO 215 JB = NQ,1,-1 DO 215 JC = JB,NQ DO 210 I = 1,N 210 YH(I,JC) = YH(I,JC) + YH(I,JC+1) 215 CONTINUE C----------------------------------------------------------------------- C UP TO MAXCOR CORRECTOR ITERATIONS ARE TAKEN. A CONVERGENCE TEST IS C MADE ON THE R.M.S. NORM OF EACH CORRECTION, WEIGHTED BY H AND THE C ERROR WEIGHT VECTOR EWT. THE SUM OF THE CORRECTIONS IS ACCUMULATED C IN ACOR(I). THE YH ARRAY IS NOT ALTERED IN THE CORRECTOR LOOP. C----------------------------------------------------------------------- 220 DO 230 I = 1,N YDOT(I) = YH(I,2) / H Y(I) = YH(I,1) 230 CONTINUE M = 0 C BND = 0.5D0/(14 * N) BND = 0.5D0/((NQ+2)*N) C C TUNING NOTE .... THE PARAMETER 14 ABOVE AND IN DEFN OF DCON C COULD PROB BE IMPROVED UPON....... ALJH = AL(2)/H BLJH = BL(2)/H IF (IPUP .LE. 0) GOTO 232 C C EXIT TO FORM A NEW JACOBIAN WITHOUT PERFORMING ITERATIONS C IPUP = 0 ELSAVE = H * EL0 MAXCOR = MAXIT MAXIT = 0 CRATE = 0.7D0 RC = 1.0D0 NSLP = NST INLN = 1 JCUR = 1 ISTEP = 0 RETURN 232 INLN = 3 MAXIT = MAXCOR C---------------------------------------------------------------------- C EXIT FOR A FUNCTION CALL, ITERATION LOOPING POINT. C---------------------------------------------------------------------- ISTEP = 0 RETURN 240 INLN = 4 ISTEP = 0 C C EXIT FOR A BACKSUBSTITUTION ONLY. C RETURN 245 CONTINUE DO 246 I = 1,N 246 ACOR(I) = -SAVR(I)/ EL0 C C EXIT FOR A FUNCTION CALL AND A BACKSUBSTITUTION C INLN = 5 ISTEP = 0 IFLAG = 1 RETURN C C START ITERATING WITH JACOBIAN MATRIX C 247 CONTINUE IF(M .EQ. 0)THEN DO 260 I = 1,N YH(I,IOMEGA) = 0.0D0 260 YH(I,IOMEGB) = 0.0D0 END IF NT = N DO 248 I = 1,N SAVR(I) = SAVR(I) / (EL0 * H) ACOR(I) = GAMMA(NQ)*H * (ACOR(I) + SAVR(I))/ELSAVE YH(I,IOMEGA) = YH(I,IOMEGA) - SAVR(I) YH(I,IOMEGB) = YH(I,IOMEGB) + ACOR(I) YDOT(I) = YH(I,2)/H + ALJH *YH(I,IOMEGA) + BLJH *YH(I,IOMEGB) Y(I) = YH(I,1) + AL(1)*YH(I,IOMEGA) + BL(1)*YH(I,IOMEGB) SAVR(I) = ACOR(I) - SAVR(I) C ORIGINAL GEAR-TYPE CONVERGENCE TEST IF(DABS(SAVR(I)*EWT(I)) .LT. BND)NT = NT -1 248 CONTINUE IF(ITRACE .GE. 2)WRITE(IDEV,2481)(SAVR(I), I = 1,N) 2481 FORMAT(' SAVR=', 5D11.3) IF(NT .EQ. 0) GOTO 450 DEL = VNORM (N, SAVR, EWT) * (NQ+2) / 0.5D0 C----------------------------------------------------------------------- C TEST FOR CONVERGENCE. IF M.GT.0, AN ESTIMATE OF THE CONVERGENCE C RATE CONSTANT IS STORED IN CRATE, AND THIS IS USED IN THE TEST. C----------------------------------------------------------------------- IF (M .GE. 1)THEN CRATE = DEL/DELP DCON = DEL*DMIN1(1.0D0,1.5D0*CRATE) IF(ITRACE.GE.2)WRITE(IDEV,390) DCON, CRATE, EL1H, DEL 390 FORMAT(' DCON=',D11.3,' CRTE=',D11.3,' EL0H=',D11.3,' DEL=',D11.3) IF (DCON .LE. 1.0D0) GO TO 450 IF (M .GE. MAXCOR .OR. DEL .GT. 0.9D0*DELP) GO TO 410 END IF M = M + 1 DELP = DEL C REVERSE COMMUNICATION RETURN FOR ANOTHER ITERATION GOTO 232 C----------------------------------------------------------------------- C THE CORRECTOR ITERATION FAILED TO CONVERGE IN MAXCOR TRIES, OR ELSE C RES HAS RETURNED ABNORMALLY. IF INLN = -3 OR -4, RETRACT THE YH ARRAY C TO ITS VALUES BEFORE PREDICTION AND RETURN. OTHERWISE-- C IF THE JACOBIAN IS OUT OF DATE, PJAC IS CALLED FOR C THE NEXT TRY. OTHERWISE THE YH ARRAY IS RETRACTED TO ITS VALUES C BEFORE PREDICTION, AND H IS REDUCED, IF POSSIBLE. IF H CANNOT BE C REDUCED OR MXNCF FAILURES HAVE OCCURRED, EXIT WITH KFLAG = -2 OR -4. C----------------------------------------------------------------------- 410 ICF = 1 IF (JCUR .EQ. 1) GO TO 430 IPUP = 1 GO TO 220 430 ICF = 2 MAXIT = MAXCOR NCF = NCF + 1 RMAX = 2.0D0 435 TN = TOLD DO 445 JB = NQ,1,-1 DO 445 JC = JB,NQ DO 440 I = 1,N 440 YH(I,JC) = YH(I,JC) - YH(I,JC+1) 445 CONTINUE IF (IZ .EQ. 1 .OR. IZ .EQ. 3) THEN KFLAG = -3 GOTO 720 ELSE IF(IZ .EQ. 0)THEN KFLAG = -7 C WORKSPACE ERROR IN LINEAR ALGEBRA GOTO 720 END IF IF (DABS(H) .LE. HMIN*1.00001D0) GO TO 675 IF (NCF .EQ. MXNCF)THEN IF (IZ .EQ. 2)THEN KFLAG = -4 GOTO 680 ELSE IF(IZ .EQ. 4)THEN GOTO 685 ELSE GOTO 670 END IF END IF RH = 0.25D0 IPUP = 1 IREDO = 1 GO TO 170 C----------------------------------------------------------------------- C THE CORRECTOR HAS CONVERGED. JCUR IS SET TO 0 C TO SIGNAL THAT THE JACOBIAN INVOLVED MAY NEED UPDATING LATER. C THE LOCAL ERROR TEST IS MADE AND CONTROL PASSES TO STATEMENT 500 C IF IT FAILS. C----------------------------------------------------------------------- 450 JCUR = 0 DO 4502 I = 1,N 4502 ACOR(I) = YH(I,IOMEGA) + YH(I,IOMEGB) DSN = VNORM (N, ACOR, EWT)/TESCO(2,NQ) IF(ITRACE .GE.1)WRITE(IDEV,9502)DSN 9502 FORMAT(' SCALED LOCAL ERROR ESTIMATE =',D11.3) IF(DSN .GT. 1.0D0) GO TO 500 C C----------------------------------------------------------------------- C AFTER A SUCCESSFUL STEP, UPDATE THE YH ARRAY. C CONSIDER CHANGING H IF IALTH = 1. OTHERWISE DECREASE IALTH BY 1. C IF IALTH IS THEN 1 AND NQ .LT. MAXORD, THEN ACOR IS SAVED FOR C USE IN A POSSIBLE ORDER INCREASE ON THE NEXT STEP. C IF A CHANGE IN H IS CONSIDERED, AN INCREASE OR DECREASE IN ORDER C BY ONE IS CONSIDERED ALSO. A CHANGE IN H IS MADE ONLY IF IT IS BY A C FACTOR OF AT LEAST 1.1. IF NOT, IALTH IS SET TO 3 TO PREVENT C TESTING FOR THAT MANY STEPS. C----------------------------------------------------------------------- IF(RMAX .EQ. 1.0D+4)THEN C FIRST STEP - SEE IF INIT STEP WAS TOO SMALL EXSM = 1.0D0/DBLE(L) RHSM = 1.0D0/(1.2D0*DSN**EXSM + 0.0000012D0) IF(RHSM .GE. RMAX .AND. (H*HMXI) .LT. (1.D0-8.D0*U) )THEN C RETAKE THE STEP AS THE INITIAL STEP WAS FAR TOO SMALL RH = RMAX TN = TOLD DO 460 JB = NQ , 1 ,-1 DO 460 JC = JB,NQ DO 455 I = 1,N 455 YH(I,JC) = YH(I,JC) - YH(I,JC+1) 460 CONTINUE IREDO = 3 GOTO 170 END IF END IF KFLAG = 0 IREDO = 0 NQU = NQ NCF = 0 DO 470 J = 1,L ALJH = AL(J) BLJH = BL(J) DO 470 I = 1,N 470 YH(I,J) = YH(I,J) + ALJH*YH(I,IOMEGA) + BLJH*YH(I,IOMEGB) IALTH = IALTH - 1 IF (IALTH .EQ. 0) GO TO 520 IF (IALTH .GT. 1) GO TO 700 IF (L .EQ. LMAX) GO TO 700 DO 490 I = 1,N 490 YH(I,LMAX) = ACOR(I) GO TO 700 C----------------------------------------------------------------------- C THE ERROR TEST FAILED. KFLAG KEEPS TRACK OF MULTIPLE FAILURES. C RESTORE TN AND THE YH ARRAY TO THEIR PREVIOUS VALUES, AND PREPARE C TO TRY THE STEP AGAIN. COMPUTE THE OPTIMUM STEP SIZE FOR THIS OR C ONE LOWER ORDER. AFTER 2 OR MORE FAILURES, H IS FORCED TO DECREASE C BY A FACTOR OF 0.2 OR LESS. C----------------------------------------------------------------------- 500 KFLAG = KFLAG - 1 TN = TOLD DO 515 JB = NQ , 1 ,-1 DO 515 JC = JB,NQ DO 510 I = 1,N 510 YH(I,JC) = YH(I,JC) - YH(I,JC+1) 515 CONTINUE RMAX = 2.0D0 IF (DABS(H) .LE. HMIN*1.00001D0) GO TO 650 IF (KFLAG .LE. -4) GO TO 660 IREDO = 2 RHUP = 0.0D0 GO TO 540 C----------------------------------------------------------------------- C REGARDLESS OF THE SUCCESS OR FAILURE OF THE STEP, FACTORS C RHDN, RHSM, AND RHUP ARE COMPUTED, BY WHICH H COULD BE MULTIPLIED C AT ORDER NQ - 1, ORDER NQ, OR ORDER NQ + 1, RESPECTIVELY. C IN THE CASE OF FAILURE, RHUP = 0.0 TO AVOID AN ORDER INCREASE. C THE LARGEST OF THESE IS DETERMINED AND THE NEW ORDER CHOSEN C ACCORDINGLY. IF THE ORDER IS TO BE INCREASED, WE COMPUTE ONE C ADDITIONAL SCALED DERIVATIVE. C----------------------------------------------------------------------- 520 RHUP = 0.0D0 IF (L .EQ. LMAX) GO TO 540 DO 530 I = 1,N 530 YDOT(I) = ACOR(I) - YH(I,LMAX) DUP = VNORM (N, YDOT, EWT)/TESCO(3,NQ) EXUP = 1.0D0/DBLE(L+1) RHUP = 1.0D0/(1.4D0*DUP**EXUP + 0.0000014D0) 540 EXSM = 1.0D0/DBLE(L) RHSM = 1.0D0/(1.2D0*DSN**EXSM + 0.0000012D0) RHDN = 0.0D0 IF (NQ .EQ. 1) GO TO 560 DDN = VNORM (N, YH(1,L), EWT)/TESCO(1,NQ) EXDN = 1.0D0/DBLE(NQ) RHDN = 1.0D0/(1.3D0*DDN**EXDN + 0.0000013D0) C560 IF(ITRACE .GE. 1)THEN C WRITE(IDEV,561)RHDN,RHSM,RHUP C561 FORMAT(' DOWN',D11.3,' SAME',D11.3,' UP',D11.3) C END IF 560 IF (RHSM .GE. RHUP) GO TO 570 IF (RHUP .GT. RHDN) GO TO 590 GO TO 580 570 IF (RHSM .LT. RHDN) GO TO 580 NEWQ = NQ RH = RHSM GO TO 620 580 NEWQ = NQ - 1 RH = RHDN IF (KFLAG .LT. 0 .AND. RH .GT. 1.0D0) RH = 1.0D0 GO TO 620 590 NEWQ = L RH = RHUP IF (RH .LT. 1.1D0) GO TO 610 R = AL(L)/DBLE(L) DO 600 I = 1,N 600 YH(I,NEWQ+1) = ACOR(I)*R GO TO 630 610 IALTH = 3 GO TO 700 620 IF ((KFLAG .EQ. 0) .AND. (RH .LT. 1.1D0)) GO TO 610 IF (KFLAG .LE. -2) RH = DMIN1(RH,0.2D0) C----------------------------------------------------------------------- C IF THERE IS A CHANGE OF ORDER, RESET NQ, L, AND THE COEFFICIENTS. C IN ANY CASE H IS RESET ACCORDING TO RH AND THE YH ARRAY IS RESCALED. C THEN EXIT FROM 690 IF THE STEP WAS OK, OR REDO THE STEP OTHERWISE. C----------------------------------------------------------------------- IF (NEWQ .EQ. NQ) GO TO 170 630 NQ = NEWQ L = NQ + 1 IRET = 2 GO TO 150 C----------------------------------------------------------------------- C ALL RETURNS ARE MADE THROUGH THIS SECTION. H IS SAVED IN HOLD C TO ALLOW THE CALLER TO CHANGE H ON THE NEXT STEP. C----------------------------------------------------------------------- C C KFLAG = -1 ; ERROR TEST FAILED REPEATEDLY WITH ABS(H) = HMIN C 650 KFLAG = -1 CALL SERROR(' SBLEND- AT T=(R1) AND STEP SIZE H =(R2) THE ERROR 1 TEST FAILED REPEATEDLY WITH ABS(H) = HMIN', 1, 0, 0, 0, 2, TN ,H) GO TO 720 C C KFLAG = -1 ; ERROR TEST FAILED REPEATEDLY C 660 KFLAG = -1 CALL SERROR(' SBLEND- AT T=(R1) AND STEP SIZE H =(R2) THE ERROR 1 TEST FAILED REPEATEDLY ', 1, 0, 0, 0, 2, TN, H) GO TO 720 C C KFLAG = -2 CONVERGANCE FAILURE C 670 KFLAG = -2 CALL SERROR(' SBLEND- AT T=(R1) AND STEP SIZE H=(R2) THE CORRECTOR 1 CONVERGENCE FAILED REPEATEDLY ', 1, 0, 0, 0, 2, TN, H) GO TO 720 C C KFLAG = -2 CONVERGANCE FAILURE WITH MINIMUM STEPSIZE. C 675 KFLAG = -2 CALL SERROR(' SBLEND- AT T=(R1) AND STEP SIZE H=(R2) THE CORRECTOR 1 CONVERGENCE FAILED REPEATEDLY WITH H = HMIN', 1, 0, 0, 0, 2,TN,H) GO TO 720 C C KFLAG = -4 RES ORDERED RETURN C 680 CALL SERROR(' SBLEND- AT T=(R1) RESIDUAL ROUTINE RETURNED IRES 1 =3 REPEATEDLY', 1, 0, 0, 0, 1, TN, 0.0D0) GO TO 720 685 KFLAG = -5 CALL SERROR(' SBLEND - AT T= (R1) A SINGULAR JACOBIAN MATRIX WAS 1 REPEATEDLY ENCOUNTERED', 1, 0, 0, 0, 1, TN, 0.0D0) GO TO 720 690 RMAX = 10.0D0 720 CONTINUE 700 R = 1.0D0/TESCO(2,NQU) IF(KFLAG .LT. 0)THEN C THE STEP HAS FAILED AND BEEN RETRACTED - INDICATE THAT LOCAL C ERROR HAS BEEN LOST CALL SERROR(' SPGEAR-CURRENT STEP FAILURE MEANS THAT OLD LOCAL 1 ERROR ESTIMATE CANNOT BE RETRIEVED AND SO ACOR IS SET TO ZERO', 2 1, 0, 0, 0, 0, 0.0D0, 0.0D0) DO 702 I = 1,N 702 ACOR(I) = 0.0D0 END IF DO 710 I = 1,N C RESET YDOT AND SCALE ACOR SO THAT IT IS LOCAL ERROR ESTIMATE. Y (I) = YH(I,1) YDOT(I) = YH(I,2)/H 710 ACOR(I) = ACOR(I)*R HOLD = H ISTEP = KFLAG IF(ISTEP .EQ. 0)ISTEP = 1 RETURN C----------------------- END OF SUBROUTINE SBLEND ---------------------- END SUBROUTINE CFODE (METH, A, B, TESCO, GAMMA, C) INTEGER METH, I, J DOUBLE PRECISION A, TESCO, B, GAMMA, C DIMENSION A(13,12), TESCO(3,12), B(12,11), GAMMA(11), C(11) C----------------------------------------------------------------------- C CFODE IS CALLED BY THE INTEGRATOR ROUTINE TO SET COEFFICIENTS C NEEDED THERE. THE COEFFICIENTS FOR THE CURRENT METHOD, AS C GIVEN BY THE VALUE OF METH, ARE SET FOR ALL ORDERS AND SAVED. C THE MAXIMUM ORDER ASSUMED HERE IS 12 IF METH = 1 AND 11 IF METH = 2. C (A SMALLER VALUE OF THE MAXIMUM ORDER IS ALSO ALLOWED.) C CFODE IS CALLED ONCE AT THE BEGINNING OF THE PROBLEM, C AND IS NOT CALLED AGAIN UNLESS AND UNTIL METH IS CHANGED. C C THE A ARRAY CONTAINS THE BASIC METHOD COEFFICIENTS. C THE COEFFICIENTS AL(I), 1 .LE. I .LE. NQ+1, FOR THE METHOD OF C ORDER NQ ARE STORED IN A(I,NQ). THE SAME APPLIES TO THE ARRAY B. C C THE TESCO ARRAY CONTAINS TEST CONSTANTS USED FOR THE C LOCAL ERROR TEST AND THE SELECTION OF STEP SIZE AND/OR ORDER. C AT ORDER NQ, TESCO(K,NQ) IS USED FOR THE SELECTION OF STEP C SIZE AT ORDER NQ - 1 IF K = 1, AT ORDER NQ IF K = 2, AND AT ORDER C NQ + 1 IF K = 3. C----------------------------------------------------------------------- DO 10 I = 1,12 A(2,I) = -1.0D0 A(1,I) = 0.0D0 DO 10 J = 3,13 A(J,I) = 0.0D0 10 CONTINUE A(1,1) = - .5D0 C A(1,2) = - .4166666666666667D0 A(3,2) = - .5D0 C A(1,3) = - .375D0 A(3,3) = - .75D0 A(4,3) = - .1666666666666667D0 C A(1,4) = - .3486111111111111D0 A(3,4) = - .9166666666666667D0 A(4,4) = - .3333333333333333D0 A(5,4) = - .04166666666666667D0 C A(1,5) = - .3298611111111111D0 A(3,5) = - 1.041666666666667D0 A(4,5) = - .4861111111111111D0 A(5,5) = - .1041666666666667D0 A(6,5) = - .008333333333333333D0 C A(1,6) = - .3155919312169312D0 A(3,6) = - 1.141666666666667D0 A(4,6) = - .625D0 A(5,6) = - .1770833333333333D0 A(6,6) = - .025D0 A(7,6) = - .001388888888888889D0 C A(1,7) = - .3042245370370370D0 A(3,7) = - 1.225D0 A(4,7) = - .7518518518518519D0 A(5,7) = - .2552083333333333D0 A(6,7) = - .04861111111111111D0 A(7,7) = - .004861111111111111D0 A(8,7) = - .0001984126984126984D0 C A(1,8) = - .2948680004409171D0 A(3,8) = - 1.296428571428485D0 A(4,8) = - .8685185185185185D0 A(5,8) = - .3357638888888888D0 A(6,8) = - .07777777777777777D0 A(7,8) = - .01064814814814815D0 A(8,8) = - .0007936507936507937D0 A(9,8) = - .0000248015873015873D0 C A(1,9) = - .2869754464285714D0 A(3,9) = - 1.35892857142857D0 A(4,9) = - .976554232804233D0 A(5,9) = - .4171875D0 A(6,9) = - .1113541666666667D0 A(7,9) = - .01875D0 A(8,9) = - .001934523809523809D0 A(9,9) = - .000111607142857143D0 A(10,9) = - .00000275573192239859D0 C A(1,10) = - .280189564439367D0 A(3,10) = - 1.41448412698413D0 A(4,10) = - 1.07721560846561D0 A(5,10) = - .498567019400353D0 A(6,10) = - .1484375D0 A(7,10) = - .0290605709876543D0 A(8,10) = - .0037202380952381D0 A(9,10) = - .000299685846560847D0 A(10,10) = - .0000137786596119929D0 A(11,10) = - .00000027557319223986D0 C A(1,11) = - .274265540031599D0 A(3,11) = - 1.46448412698413D0 A(4,11) = - 1.17151455026455D0 A(5,11) = - .579358190035273D0 A(6,11) = - .188322861552028D0 A(7,11) = - .0414303626543210D0 A(8,11) = - .0062111447989418D0 A(9,11) = - .000625206679894180D0 A(10,11) = - .0000404174015285126D0 A(11,11) = - .00000151565255731922D0 A(12,11) = - .0000000250521083854417D0 C A(1,12) = - .2690288467736492D0 A(3,12) = - 1.50993867243867D0 A(4,12) = - 1.26027116402116D0 A(5,12) = - .659234182098765D0 A(6,12) = - .230458002645503D0 A(7,12) = - .0556972461052322D0 A(8,12) = - .00943948412698413D0 A(9,12) = - .00111927496693122D0 A(10,12) = - .0000909391534391534D0 A(11,12) = - .00000482253086419753D0 A(12,12) = - .000000150312650312650D0 A(13,12) = - .00000000208767569878681D0 DO 200 I = 1,11 B(1,I) = -1.0D0 DO 200 J = 2,12 200 B(J,I) = 0.0D0 B(2,1) = - 1.D0 C B(2,2) = - 1.5D0 B(3,2) = - .5D0 C B(2,3) = - 1.833333333333333D0 B(3,3) = - 1.D0 B(4,3) = - .1666666666666667D0 C B(2,4) = - 2.083333333333333D0 B(3,4) = - 1.458333333333333D0 B(4,4) = - .4166666666666667D0 B(5,4) = - .04166666666666667D0 C B(2,5) = - 2.283333333333333D0 B(3,5) = - 1.875D0 B(4,5) = - .7083333333333333D0 B(5,5) = - .125D0 B(6,5) = - .008333333333333333D0 C B(2,6) = - 2.45D0 B(3,6) = - 2.255555555555556D0 B(4,6) = - 1.020833333333333D0 B(5,6) = - .2430555555555556D0 B(6,6) = - .02916666666666667D0 B(7,6) = - .001388888888888889D0 C B(2,7) = - 2.59285714285714D0 B(3,7) = - 2.605555555555556D0 B(4,7) = - 1.343055555555556D0 B(5,7) = - .3888888888888889D0 B(6,7) = - .06388888888888889D0 B(7,7) = - .005555555555555556D0 B(8,7) = - .000198412698412698D0 C B(2,8) = - 2.71785714285714D0 B(3,8) = - 2.92966269841270D0 B(4,8) = - 1.66875D0 B(5,8) = - .5567708333333333D0 B(6,8) = - .1125D0 B(7,8) = - .01354166666666667D0 B(8,8) = - .000892857142857143D0 B(9,8) = - .0000248015873015873D0 C B(2,9) = - 2.82896825396825D0 B(3,9) = - 3.23164682539683D0 B(4,9) = - 1.99426807760141D0 B(5,9) = - .7421875D0 B(6,9) = - .174363425925926D0 B(7,9) = - .02604166666666667D0 B(8,9) = - .00239748677248677D0 B(9,9) = - .000124007936507937D0 B(10,9) = - .00000275573192239859D0 C B(2,10) = - 2.92896825396825D0 B(3,10) = - 3.51454365079365D0 B(4,10) = - 2.31743276014109D0 B(5,10) = - .941614307760141D0 B(6,10) = - .248582175925926D0 B(7,10) = - .0434780092592593D0 B(8,10) = - .00500165343915344D0 B(9,10) = - .000363756613756614D0 B(10,10) = - .0000151565255731922D0 B(11,10) = - .000000275573192239859D0 C B(2,11) = - 3.01987734487735D0 B(3,11) = - 3.78081349206349D0 B(4,11) = - 2.63693672839506D0 B(5,11) = - 1.15229001322751D0 B(6,11) = - .334183476631393D0 B(7,11) = - .06607638888888889D0 B(8,11) = - .00895419973544974D0 B(9,11) = - .000818452380952381D0 B(10,11) = - .0000482253086419753D0 B(11,11) = - .00000165343915343915D0 B(12,11) = - .0000000250521083854417D0 C C DEFINE THE C AND GAMMA ARRAYS C GAMMA(1) = 0.08578644D0 GAMMA(2) = 0.1250D0 GAMMA(3) = 0.121890D0 GAMMA(4) = 0.12849970D0 GAMMA(5) = 0.10872640D0 GAMMA(6) = 0.096259610D0 GAMMA(7) = 0.08754865D0 GAMMA(8) = 0.08105623D0 GAMMA(9) = 0.07599874D0 GAMMA(10) = 0.07192936D0 GAMMA(11) = 0.06857227D0 C(1) = 0.29289320D0 C(2) = 0.3374973D0 C(3) = 0.3335427D0 C(4) = 0.34273290D0 C(5) = 0.31690580D0 C(6) = 0.29929710D0 C(7) = 0.28623920D0 C(8) = 0.2760327D0 C(9) = 0.2677630D0 C(10) =0.26088340D0 C(11) =0.25504260D0 DO 300 J = 1,12 TESCO(2,J) = J+1.0D0 TESCO(3,J) = J+2.0D0 300 CONTINUE TESCO(1,1) = 1.0D0 TESCO(1,2) = 1.0D0 TESCO(1,3) = 0.5D0 TESCO(1,4) = 0.1667D0 TESCO(1,5) = 0.4167D-1 TESCO(1,6) = 0.8333D-2 TESCO(1,7) = 0.1389D-2 TESCO(1,8) = 0.1984D-3 TESCO(1,9) = 0.248D-4 TESCO(1,10) = 0.2756D-5 TESCO(1,11) = 0.2756D-6 TESCO(1,12) = 0.2505D-7 RETURN END C ONE LINE CHANGED 3/3/87 C RHSM RECALCULATED TO TAKE ACCOUNT OF PETZ. ERR EST C WHEN ORDER STAYS THE SAME. C LINES CHANGED 13/3/87 C ON THIRD ERROR TEST FAILURE THE ORDER IS DROPPED TO ONE AND C THE STEPSIZE REDUCED BY A FACTOR OF 0.2 C C LINE CHANGES TO TAKE ACCOUNT OF REVISED BACKSUB PROCEDURE C APRIL 88. C C C1 INTERPOLATION INTRODUCED IN JULY 1988. C SUBROUTINE BDFSET( NY2DIM, IRET, MAXORD, METH, PETZLD) INTEGER METH, MAXORD, IRET, NY2DIM LOGICAL PETZLD C---------------------------------------------------------------------- C THIS ROUTINE INITIALISES THE LSODI IMPLENTATION OF ADAMS/B.D.F C METHODS AS USED IN THE SPRINT INTEGRATION PACKAGE C THE INPUT PARAMETERS ARE: C NY2DIM THE SECOND DIMENSION OF THE YSAVE ARRAY , IT SHOULD BE C SET TO MAXORD + 1, UNLESS MAXORD IS ZERO ,SEE BELOW. C N.B. IN THE CASE WHEN NY2DIM IS SET TO MAXORD + 2 THEN C C1 INTERPOLATION WILL BE USED TO CALCULATE SOLUTION C VALUES AT NON-MESH POINTS. C C MAXORD THE MAXIMUM ORDER TO BE USED. THIS SHOULD BE POSITIVE AND C FOR THE ADAMS METHODS LESS THAN 12 ; FOR THE B.D.F. C METHODS THIS SHOULD BE LESS THAN 6 . WHEN MAXORD IS SET C TO ZERO THE DEFAULT VALUES OF 11 (ADAMS) AND 5 (B.D.F.) C WILL BE USED BY THE CODE (NY2DIM MUST BE LARGE ENOUGH C FOR THESE DEFAULT VALUES). C C N.B. THE SIZE OF THE YSAVE ARRAY PASSED INTO SPRINT MUST BE C YSAVE(NYH, MAXORD + 1). WHERE NYH IS THE NUMBER OF C DIFFERENTIAL ALGEBRAIC EQUATIONS OR AN UPPER BOUND ON C THIS NUMBER . C METH METH INDICATES THE BASIC LINEAR MULTISTEP METHOD.. C METH = 1 MEANS THE ADAMS MOULTON METHOD. C METH = 2 MEANS THE METHOD BASED ON BACKWARD C DIFFERENTIATION FORMULAS (BDF-S). C THE BDF METHOD IS STRONGLY PREFERRED FOR STIFF PROB- C LEMS, WHILE THE ADAMS METHOD IS PREFERRED WHEN THE PROB- C LEM IS NOT STIFF. IF THE MATRIX A(T,Y) IS NONSINGULAR, C STIFFNESS HERE CAN BE TAKEN TO MEAN THAT OF THE EXPLICIT C ODE SYSTEM DY/DT = A**(-1) * G. IF A IS SINGULAR, THE C CONCEPT OF STIFFNESS IS NOT WELL DEFINED. C IF MAXIMUM EFFICIENCY IS IMPORTANT, SOME EXPERIMENTATION C WITH METH MAY BE NECESSARY. C C METH = 10 , AS FOR METH = 1 BUT USING FUNCTIONAL C ITERATION TO SOLVE THE SYSTEMS OF NONLINEAR EQUATIONS C C METH = 20 , AS FOR METH = 2 BUT USING FUNCTIONAL C ITERATION TO SOLVE THE SYSTEM OF NONLINEAR EQUATIONS. C C NOTE : THE OPTIONS METH = 10 AND METH = 20 SHOULD BE USED C WITH GREAT CARE , PARTICULARLY IF THE PROBLEM C CONSISTS OF BOTH ALGEBRAIC AND DIFFERENTIAL EQNS. C SPRINT ITSELF MUST BE CALLED WITH FULL BANDED OR C SPARSE LINEAR ALGEBRA ROUTINES AS SPGEAR WILL USE C A NEWTON METHOD IF IT ENCOUNTERS CONVERGENCE C DIFFICULTIES WHEN USING METH = 10 OR 20. C IN ORDER TO CHANGE THE VALUES OF METH SIMPLY RECALL THIS C ROUTINE , EVEN IN MID-INTEGRATION. C C PETZLD LOGICAL INDICATOR TO DEFINE WHETHER OR NOT THE PETZOLD C FORM OF THE LOCAL ERROR TESTB IS USED . THIS TEST IS MORE C EXPENSIVE BUT MORE STABLE FOR DIFFERENTIAL ALGEBRAIC EQNS C THIS PARAMETER MUST BE SET BY THE USER. C = .TRUE. MEANS THAT THE TEST IS USED C = .FALSE. MEANS THAT THE TEST IS NOT USED . C THIS INDICATOR CANNOT BE SET = .TRUE. IF METH = 10 OR 20 C IS USED ABOVE. C C OUTPUT PARAMETER C IRET INTEGER FLAG SET TO ZERO IF ALL INPUTS ARE O.K. C OTHERWISE SET TO -1 TO INDICATE AN ERROR EXIT. C---------------------------------------------------------------------- INTEGER IOWNS, NMETH, NMITER, NMXORD, IDM, I, MORD(2) LOGICAL TRUPTZ, FNITER, C1INTR DOUBLE PRECISION ROWNS, HHUSED, CCMAX CHARACTER*6 ODCODE COMMON /ODECHK/ ODCODE COMMON /LS0001/ ROWNS(211), IOWNS(8), NMETH, NMITER,NMXORD, IDM(3) COMMON /LS001A/ TRUPTZ, FNITER, HHUSED, C1INTR COMMON /SPCCMX/ CCMAX SAVE /LS001A/, /LS0001/, /ODECHK/, /SPCCMX/ DATA MORD(1),MORD(2)/12,5/ C IRET = 0 IF(METH .EQ. 10 .OR. METH .EQ. 20)THEN FNITER = .TRUE. NMETH = METH / 10 IF(PETZLD)THEN CALL SERROR(' BDFSET ERROR - THE LOGICAL PARAMETER PETZLD 1 HAS BEEN ILEGALLY SET TO .TRUE. WHEN THE ROUTINE HAS BEEN 2 CALLED WITH METH = 10 OR METH = 20 AND HAS BEEN SET TO 3 FALSE ', 1, 0, 0, 0, 0, 0.0D0, 0.0D0) TRUPTZ = .FALSE. END IF ELSE IF(METH.NE.1.AND.METH.NE.2.) THEN CALL SERROR(' BDFSET- VALUE OF METH (=I1) IS ILLEGAL AND HAS 1 BEEN INTERNALLY RESET TO 1 ', 1, 1, METH, 2 0, 0, 0.0D0, 0.0D0) NMETH = 1 ELSE NMETH = METH END IF TRUPTZ = PETZLD FNITER = .FALSE. END IF NMITER = 2 CCMAX = 0.3D0 C C IDM(2) CONTAINS THE PARAMETER WHICH SPECIFIES HOW MANY C CONVERGENCE FAILURES ARE ALLOWED. C IDM(2) = 5 IF (MAXORD.LT.0)THEN CALL SERROR(' BDFSET - NEG VALUE OF MAXORD (=I1) IS ILLEGAL' 1 , 1, 1, MAXORD, 0, 0, 0.0D0, 0.0D0) IRET = -1 END IF IF ( MAXORD.EQ.0)THEN MAXORD = MORD(METH) ELSE IF(MAXORD .GT. MORD(METH))THEN CALL SERROR(' BDFSET WARNING USER SUPPLIED MAXORD (=I1) IS 1 GREATER THAN ALLOWED (=I2) AND IS RESET TO THE ALLOWED MAX', 2 1, 2, MAXORD, MORD(METH), 0, 0.0D0, 0.0D0) END IF MAXORD = MIN0(MAXORD,MORD(METH)) END IF IF(NY2DIM .LT. (MAXORD+1)) THEN I = MAXORD + 1 CALL SERROR(' BDFSET - ERROR USER DEFINED VALUE OF NY2DIM 1 (=I1) IS SMALLER THAN THE REQUIRED VALUE (=I2) 2 INCREASE THE SECOND DIMENSION TO THIS VALUE ', 1 3 ,2 , NY2DIM, I, 0, 0.0D0, 0.0D0) IRET = -1 ELSE ODCODE ='SPGEAR' C1INTR =.FALSE. IF( NY2DIM .GE. (MAXORD+2))C1INTR = .TRUE. END IF NMXORD = MAXORD RETURN C------END-OF-ROUTINE-BDFSET------------------------------------------- END SUBROUTINE SPGEAR (NEQ, Y, YH, NYH, EWT, YDOT, SAVR, ACOR, INLN, 1 ISTEP, EL0, H, TN, HMIN, HMXI, IDAE) INTEGER NEQ, NYH, INLN, ISTEP, IDAE(1) INTEGER IALTH, IPUP, LMAX, MEO, NSLP, ICF, JCUR, 1 L, METH, MITER, MAXORD, MSBP, MXNCF, N, 2 NQ, NST, NRE, NJE, NQU, NITER, JSTART, KFLAG, NINTER, IOVFLO INTEGER I,JC,IREDO, IRET, J, JB, KGO, NCF, NEWQ,ITRACE,IDEV,IZ LOGICAL PETZLD, RAISE, FNITER, C1INTR DOUBLE PRECISION Y, YH, EWT, YDOT, SAVR, ACOR, EL0, H, TN, HMXI, 1 HMIN, ROWND DOUBLE PRECISION CONIT, EL, ELCO, HOLD, RMAX, TESCO, CCMAX, RC DOUBLE PRECISION DDN, DSM, DUP, DSN, TERK, TERKM1, TERKM2, DDN1, 1 ELJH, EXDN, EXSM, EXUP, TERKP1, CCMX1, 2 R, RH, RHDN, RHSM, RHUP, TOLD, VNORM, HHUSED, DUN, U CHARACTER*6 ODCODE DIMENSION NEQ(1),Y(1),YH(NYH,1),EWT(1),YDOT(1),SAVR(1),ACOR(1) COMMON /LS0001/ ROWND, CONIT, EL(13), ELCO(13,12), 1 HOLD, RMAX, TESCO(3,12), CCMAX, RC, 2 IALTH, IPUP, LMAX, MEO, NSLP, 3 ICF, JCUR, L, METH, MITER, MAXORD, MSBP, MXNCF, N COMMON /ODECHK/ ODCODE COMMON /LS001A/ PETZLD, FNITER, HHUSED, C1INTR COMMON /LSTATS/ NQ, NQU, NST, NRE, NJE, NITER, NINTER COMMON /SPCCMX/ CCMX1 C C EXTRA COMMON BLOCK FOR REVERSE COMMUNICATION C COMMON /LSSAVE/ DDN, DSM, DUP, ELJH, TERK, TERKM1, TERKP1, 1 EXDN, EXSM, EXUP, R, RH, RHDN, RHSM, RHUP, TOLD, TERKM2, DDN1, 2 I, JC, IREDO, IRET, J, JB, KGO, NCF, IZ, JSTART, KFLAG, RAISE COMMON/SDEV2/ITRACE,IDEV COMMON /SCONS1/ DUN, U, IOVFLO SAVE /LSSAVE/, /LSTATS/, /LS001A/, /ODECHK/, /LS0001/, /SCONS1/ 1 ,/SPCCMX/ C----------------------------------------------------------------------- C SPGEAR PERFORMS ONE STEP OF THE INTEGRATION OF AN INITIAL VALUE C PROBLEM FOR A SYSTEM OF ORDINARY DIFFERENTIAL EQUATIONS. C NOTE.. SPGEAR IS INDEPENDENT OF THE VALUE OF THE ITERATION METHOD C INDICATOR MITER, AND HENCE IS INDEPENDENT C OF THE TYPE OF CHORD METHOD USED, OR THE JACOBIAN STRUCTURE. C COMMUNICATION WITH SPGEAR IS DONE WITH THE FOLLOWING VARIABLES.. C C NEQ = INTEGER ARRAY CONTAINING PROBLEM SIZE IN NEQ(1), AND C NOT USED EXCEPT TO INITIALISE THE COMMON BLOCK VARIABLE N C Y = AN ARRAY OF LENGTH .GE. N USED AS THE Y ARGUMENT IN C ALL CALLS TO RES, JAC, AND ADDA. ON THE FIRST CALL THIS C ARRAY IS ASSUMED TO CONTAIN THE INITIAL SOLUTION VALUES. C YH = AN NYH BY LMAX ARRAY CONTAINING THE DEPENDENT VARIABLES C AND THEIR APPROXIMATE SCALED DERIVATIVES, WHERE C LMAX = MAXORD + 1. YH(I,J+1) CONTAINS THE APPROXIMATE C J-TH DERIVATIVE OF Y(I), SCALED BY H**J/FACTORIAL(J) C (J = 0,1,...,NQ). ON ENTRY FOR THE FIRST STEP, THE FIRST C TWO COLUMNS OF YH MUST BE SET FROM THE INITIAL VALUES. C NYH = A CONSTANT INTEGER .GE. N, THE FIRST DIMENSION OF YH. C EWT = AN ARRAY OF LENGTH N CONTAINING MULTIPLICATIVE WEIGHTS C FOR LOCAL ERROR MEASUREMENTS. LOCAL ERRORS IN Y(I) ARE C COMPARED TO 1.0/EWT(I) IN VARIOUS ERROR TESTS. C YDOT = AN ARRAY OF WORKING STORAGE, OF LENGTH N. ALSO USED FOR C INPUT OF YH(*,MAXORD+2) WHEN JSTART = -1 AND MAXORD IS LESS C THAN THE CURRENT ORDER NQ. ON THE FIRST CALL THIS ARRAY IS C ASSUMED TO HOLD THE INITIAL VALUES OF THE TIME DERIVATIVE. C SAVR = AN ARRAY OF WORKING STORAGE, OF LENGTH N. C THIS ARRAY IS NOT USED IN THE PRESENT IMPLEMENTATION. C ACOR = A WORK ARRAY OF LENGTH N USED FOR THE ACCUMULATED C CORRECTIONS. ON A SUCCESFUL RETURN, ACOR(I) CONTAINS C THE ESTIMATED ONE-STEP LOCAL ERROR IN Y(I). C CCMAX = MAXIMUM RELATIVE CHANGE IN H*EL0 BEFORE PJAC IS CALLED. C H = THE STEP SIZE TO BE ATTEMPTED ON THE NEXT STEP. C H IS ALTERED BY THE ERROR CONTROL ALGORITHM DURING THE C PROBLEM. H CAN BE EITHER POSITIVE OR NEGATIVE, BUT ITS C SIGN MUST REMAIN CONSTANT THROUGHOUT THE PROBLEM. C HMIN = THE MINIMUM ABSOLUTE VALUE OF THE STEP SIZE H TO BE USED. C HMXI = INVERSE OF THE MAXIMUM ABSOLUTE VALUE OF H TO BE USED. C HMXI = 0.0 IS ALLOWED AND CORRESPONDS TO AN INFINITE HMAX. C HMIN AND HMXI MAY BE CHANGED AT ANY TIME, BUT WILL NOT C TAKE EFFECT UNTIL THE NEXT CHANGE OF H IS CONSIDERED. C IDAE INDICATOR ARRAY OF DIMENSION NEQ(1) NOT USED IN THIS C MODULE. C TN = THE INDEPENDENT VARIABLE. TN IS UPDATED ON EACH STEP TAKEN. C ISTEP : INPUT AND OUTPUT ERROR INDICATOR C ON INPUT ITS VALUES ARE TRANSFERRED INTO JSTART C ON OUTPUT IT TAKES THE VALUES OF KFLAG . IN BOTH CASES C THE ACTUAL VALUES ARE MODIFIED SO AS TO CORRESSPOND TO C THE SPRINT INTERFACE. C INPUT: -1 PERFORM THE FIRST STEP (JSTART = 0). C 0 REVERSE COMMUNICATION RETURN FROM NLSLVR ROUTINE. C 1 TAKE A NEW STEP CONTINUING FROM THE LAST (JSTART=1) C 2 TAKE THE NEXT STEP WITH A NEW VALUE OF H, MAXORD, C N, METH, (JSTART = -1). C 3 TAKE THE NEXT STEP WITH A NEW VALUE OF H, C BUT WITH OTHER INPUTS UNCHANGED (JSTART = -2) C ON RETURN, ISTEP IS SET TO 1 TO FACILITATE CONTINUATION. C OUTPUT: 1 THE STEP WAS SUCCESSFUL , KFLAG = 0. C 0 REVERSE COMMUNICATION RETURN - CHECK INLN. C -1 THE REQUESTED ERROR COULD NOT BE ACHIEVED. C -2 CORRECTOR CONVERGENCE COULD NOT BE ACHIEVED. C -3 RES ORDERED IMMEDIATE RETURN. C -4 ERROR CONDITION FROM RES COULD NOT BE AVOIDED. C -5 FATAL ERROR IN JACOBIAN FORMING OR BACKSUBSTITUTION. C -6 INIT MODULE LSET WAS NOT CALLED PRIOR TO FIRST ENTRY. C -7 WORKSPACE ERROR IN LINEAR ALGEBRA SECTION . C APART FROM WHEN ISTEP = 0 OR 1 , ISTEP = KFLAG ON OUTPUT. C A RETURN WITH ISTEP = -1, -2, OR -4 MEANS EITHER C ABS(H) = HMIN OR 10 CONSECUTIVE FAILURES OCCURRED. C ON A RETURN WITH ISTEP NEGATIVE, THE VALUES OF TN AND C THE YH ARRAY ARE AS OF THE BEGINNING OF THE LAST C STEP, AND H IS THE LAST STEP SIZE ATTEMPTED. C MAXORD = THE MAXIMUM ORDER OF INTEGRATION METHOD TO BE ALLOWED. C MSBP = MAXIMUM NUMBER OF STEPS BETWEEN PJAC CALLS. C MXNCF = MAXIMUM NUMBER OF CONVERGENCE FAILURES ALLOWED. C METH/MITER = THE METHOD FLAGS. SEE DESCRIPTION IN ROUTINE LSET. C N = THE NUMBER OF FIRST-ORDER DIFFERENTIAL EQUATIONS. C C PETZLD IN COMMON /LS001A/ SET TRUE IF PETZOLD ERROR TEST IS USED . C OTHERWISE SET TO FALSE, INITIALISE IN LSET ROUTINE. C C INLN = REVERSE COMMUNICATION INDICATOR C C ON ENTRY INLN = 0 : NORMAL ENTRY C = -1 : ERROR IN JACOBIAN FORMATION C = -2 : RESID ORDERED RETURN TO CALLING PROG. C = -3 : RESID DETECTED ILLEGAL T, Y OR YDOTI. C = -4 : RESID ORDERED ENTRY TO MONITR. C = -5 ; WORKSPACE ERROR IN NONLINEAR SOLVER. C = 1 : NONLINEAR SYSTEM SOLVED C = 2 : ITERATION FAILED TO CONVERGE IN C SOLUTION OF NONLINEAR SYSTEM C = 3,4 NOT USED IN THIS MODULE C = 5 RETURN TO FORM THE PETZOLD ERROR EST C I.E. J INVERSE * DF/DYDOT * ACOR C = 6 NONLINEAR SYSTEM OF EQUATIONS SOLVED C USING FUNCTIONAL ITERATION. C C C ON EXIT INLN = 0 : NORMAL EXIT C = 1 : FORM JACOBIAN AND SOLVE NONLINEAR SYSTEM C = 2 : AS FOR INLN = 1 BUT USING OLD JACOBIAN C = 3,4 NOT USED HERE. C = 5 FORM PETZOLD ERROR ESTIMATE. C = 6 SOLVE SYSTEM OF NONLINEAR EQUATIONS C USING FUNCTIONAL ITERATION. C = 7 NOT USED HERE C C C----------------------------------------------------------------------- C C JUMP IF IT IS REVERSE COMMUNICATION C IZ = INLN + 5 INLN = 0 GOTO ( 430, 430, 430, 430, 10, 450, 410, 10, 10, 4501, 450),IZ GOTO 435 10 KFLAG = 0 IF(ODCODE .NE. 'SPGEAR')THEN CALL SERROR(' SPGEAR-SETUP MODULE BDFSET WAS NOT CALLED BEFORE 1 ENTRY TO SPRINT- ERROR', 1, 0, 0, 0, 0, 0.0D0, 0.0D0) ISTEP = -6 RETURN END IF TOLD = TN NCF = 0 JCUR = 0 ICF = 0 IF(ISTEP .EQ. 1)THEN JSTART = 1 GOTO 200 ELSE IF(ISTEP .EQ. 2)THEN JSTART = -1 GOTO 100 ELSE IF(ISTEP .EQ. 3)THEN JSTART = -2 GOTO 160 END IF JSTART = 0 C C----------------------------------------------------------------------- C ON THE FIRST CALL, THE ORDER IS SET TO 1, AND OTHER VARIABLES ARE C INITIALIZED. RMAX IS THE MAXIMUM RATIO BY WHICH H CAN BE INCREASED C IN A SINGLE STEP. IT IS INITIALLY 1.E4 TO COMPENSATE FOR THE SMALL C INITIAL H, BUT THEN IS NORMALLY EQUAL TO 10. IF A FAILURE C OCCURS (IN CORRECTOR CONVERGENCE OR ERROR TEST), RMAX IS SET AT 2 C FOR THE NEXT INCREASE. C----------------------------------------------------------------------- LMAX = MAXORD + 1 NINTER = LMAX N = NEQ(1) NQ = 1 NQU = 0 L = 2 IALTH = 2 RMAX = 10000.0D0 RC = 0.0D0 HHUSED = 0.0D0 EL0 = 1.0D0 MSBP = 20 CCMAX = CCMX1 HOLD = H MEO = METH NSLP = 0 IPUP = MITER IRET = 3 C C LOAD THE INITIAL VALUES OF THE SOLUTION AND THE TIME DERIVATIVE C INTO THE NORDSIECK VECTOR. C DO 20 I = 1,N YH(I,1) = Y(I) YH(I,2) = YDOT(I)*H 20 CONTINUE GO TO 140 C----------------------------------------------------------------------- C THE FOLLOWING BLOCK HANDLES PRELIMINARIES NEEDED WHEN JSTART = -1. C IPUP IS SET TO MITER TO FORCE A MATRIX UPDATE. C IF AN ORDER INCREASE IS ABOUT TO BE CONSIDERED (IALTH = 1), C IALTH IS RESET TO 2 TO POSTPONE CONSIDERATION ONE MORE STEP. C IF THE CALLER HAS CHANGED METH, DFODE IS CALLED TO RESET C THE COEFFICIENTS OF THE METHOD. C IF THE CALLER HAS CHANGED MAXORD TO A VALUE LESS THAN THE CURRENT C ORDER NQ, NQ IS REDUCED TO MAXORD, AND A NEW H CHOSEN ACCORDINGLY. C IF H IS TO BE CHANGED, YH MUST BE RESCALED. C IF H OR METH IS BEING CHANGED, IALTH IS RESET TO L = NQ + 1 C TO PREVENT FURTHER CHANGES IN H FOR THAT MANY STEPS. C----------------------------------------------------------------------- C100 IPUP = MITER 100 LMAX = MAXORD + 1 IF( NEQ(1) .NE. N)IPUP = MITER NINTER = LMAX IF( C1INTR ) NINTER = NINTER + 1 IF(NEQ(1) .LT. N)THEN C NUMBER OF O.D.E.S HAS BEEN REDUCED- ZERO PART OF MEMORY VECTOR J = NEQ(1) + 1 DO 105 I = J,N DO 105 JB = 1,NQ+1 YH(I,JB) = 0.0D0 105 CONTINUE ELSE IF(NEQ(1) .GT. N .AND. ITRACE.GE. 1)THEN CALL SERROR(' SPGEAR-VALUE OF NEQ(1) (=I1) GT N(=I2)', 1, 1 2, NEQ(1), N, 0, 0.0D0, 0.0D0) END IF N = NEQ(1) IF (IALTH .EQ. 1) IALTH = 2 IF (METH .EQ. MEO) GO TO 110 CALL DFODE (METH, ELCO, TESCO) MEO = METH IF (NQ .GT. MAXORD) GO TO 120 IALTH = L IRET = 1 GO TO 150 110 IF (NQ .LE. MAXORD) GO TO 160 120 NQ = MAXORD C C MAXORD HAS BEEN REDUCED TO BELOW NQ C J = MAXORD + 2 L = LMAX DO 125 I = 1,L 125 EL(I) = ELCO(I,NQ) RC = RC*EL(1)/EL0 EL0 = EL(1) CONIT = 0.5D0/DBLE(NQ+2) DDN = VNORM (N, YH(1,J), EWT)/TESCO(1,L) EXDN = 1.0D0/DBLE(L) RHDN = 1.0D0/(1.3D0*DDN**EXDN + 0.0000013D0) RH = DMIN1(RHDN,1.0D0) IREDO = 3 IF (H .EQ. HOLD) GO TO 170 RH = DMIN1(RH,DABS(H/HOLD)) H = HOLD GO TO 175 C----------------------------------------------------------------------- C DFODE IS CALLED TO GET ALL THE INTEGRATION COEFFICIENTS FOR THE C CURRENT METH. THEN THE EL VECTOR AND RELATED CONSTANTS ARE RESET C WHENEVER THE ORDER NQ IS CHANGED, OR AT THE START OF THE PROBLEM. C----------------------------------------------------------------------- 140 CALL DFODE (METH, ELCO, TESCO) 150 DO 155 I = 1,L 155 EL(I) = ELCO(I,NQ) RC = RC*EL(1)/EL0 EL0 = EL(1) CONIT = 0.5D0/DBLE(NQ+2) GO TO (160, 170, 200), IRET C----------------------------------------------------------------------- C IF H IS BEING CHANGED, THE H RATIO RH IS CHECKED AGAINST C RMAX, HMIN, AND HMXI, AND THE YH ARRAY RESCALED. IALTH IS SET TO C L = NQ + 1 TO PREVENT A CHANGE OF H FOR THAT MANY STEPS, UNLESS C FORCED BY A CONVERGENCE OR ERROR TEST FAILURE. C----------------------------------------------------------------------- 160 IF (H .EQ. HOLD) GO TO 200 RH = H/HOLD H = HOLD IREDO = 3 GO TO 175 170 RH = DMAX1(RH,HMIN/DABS(H)) 175 RH = DMIN1(RH,RMAX) RH = RH/DMAX1(1.0D0,DABS(H)*HMXI*RH) R = 1.0D0 C SCALE THE NORDSIECK VECTOR INCLUDING THOSE COMPONENTS USED IN INTERP JB = L IF(NQU .GT. NQ)JB = NQU + 1 DO 180 J = 2,JB R = R*RH DO 180 I = 1,N 180 YH(I,J) = YH(I,J)*R H = H*RH RC = RC*RH IALTH = L IF (IREDO .EQ. 0) GO TO 690 C----------------------------------------------------------------------- C THIS SECTION COMPUTES THE PREDICTED VALUES BY EFFECTIVELY C MULTIPLYING THE YH ARRAY BY THE PASCAL TRIANGLE MATRIX. C RC IS THE RATIO OF NEW TO OLD VALUES OF THE COEFFICIENT H*EL(1). C WHEN RC DIFFERS FROM 1 BY MORE THAN CCMAX, IPUP IS SET TO MITER C TO FORCE PJAC TO BE CALLED. C IN ANY CASE, PJAC IS CALLED AT LEAST EVERY MSBP STEPS. C----------------------------------------------------------------------- 200 IF (DABS(RC-1.0D0) .GT. CCMX1) IPUP = MITER IF (NST .GE. NSLP+MSBP) IPUP = MITER TN = TN + H DO 215 JB = NQ,1,-1 DO 215 JC = JB,NQ DO 210 I = 1,N 210 YH(I,JC) = YH(I,JC) + YH(I,JC+1) 215 CONTINUE C----------------------------------------------------------------------- C UP TO MAXCOR CORRECTOR ITERATIONS ARE TAKEN. A CONVERGENCE TEST IS C MADE ON THE R.M.S. NORM OF EACH CORRECTION, WEIGHTED BY H AND THE C ERROR WEIGHT VECTOR EWT. THE SUM OF THE CORRECTIONS IS ACCUMULATED C IN ACOR(I). THE YH ARRAY IS NOT ALTERED IN THE CORRECTOR LOOP. C----------------------------------------------------------------------- 220 DO 230 I = 1,N YDOT(I) = YH(I,2) / H Y(I) = YH(I,1) 230 CONTINUE IF (IPUP .LE. 0) GO TO 232 C C EXIT TO FORM JACOBIAN AND TO SOLVE THE NONLINEAR SYSTEM C UNLESS FNITER = .TRUE. AND THEN USE FUNCTIONAL ITERATION. C IPUP = 0 RC = 1.0D0 NSLP = NST INLN = 1 IF( FNITER ) INLN = 6 JCUR = 1 ISTEP = 0 RETURN 232 INLN = 2 C C EXIT TO SOLVE NONLINEAR SYSTEM USING OLD JACOBIAN C UNLESS FNITER = .TRUE. AND THEN USE FUNCTIONAL ITERATION. C IF( FNITER ) INLN = 6 ISTEP = 0 RETURN C----------------------------------------------------------------------- C THE CORRECTOR ITERATION FAILED TO CONVERGE IN MAXCOR TRIES, OR ELSE C RES HAS RETURNED ABNORMALLY. IF INLN = -3 OR -4, RETRACT THE YH ARRAY C TO ITS VALUES BEFORE PREDICTION AND RETURN. OTHERWISE-- C IF THE JACOBIAN IS OUT OF DATE, PJAC IS CALLED FOR C THE NEXT TRY. OTHERWISE THE YH ARRAY IS RETRACTED TO ITS VALUES C BEFORE PREDICTION, AND H IS REDUCED, IF POSSIBLE. IF H CANNOT BE C REDUCED OR MXNCF FAILURES HAVE OCCURRED, EXIT WITH KFLAG = -2 OR -4. C----------------------------------------------------------------------- 410 ICF = 1 IF (JCUR .EQ. 1) GO TO 430 IPUP = MITER GO TO 220 430 ICF = 2 NCF = NCF + 1 RMAX = 2.0D0 435 TN = TOLD DO 445 JB = NQ,1,-1 DO 445 JC = JB,NQ DO 440 I = 1,N 440 YH(I,JC) = YH(I,JC) - YH(I,JC+1) 445 CONTINUE IF (IZ .EQ. 1 .OR. IZ .EQ. 3) THEN KFLAG = -3 GOTO 720 ELSE IF(IZ .EQ. 0)THEN KFLAG = -7 C WORKSPACE ERROR IN LINEAR ALGEBRA PART GOTO 720 END IF IF (DABS(H) .LE. HMIN*1.00001D0) GO TO 675 IF (NCF .EQ. MXNCF)THEN IF (IZ .EQ. 2)THEN KFLAG = -4 GOTO 680 ELSE IF( IZ .EQ. 4)THEN GOTO 685 ELSE GOTO 670 END IF END IF RH = 0.25D0 IPUP = MITER IREDO = 1 GO TO 170 C----------------------------------------------------------------------- C THE CORRECTOR HAS CONVERGED. JCUR IS SET TO 0 C TO SIGNAL THAT THE JACOBIAN INVOLVED MAY NEED UPDATING LATER. C THE LOCAL ERROR TEST IS MADE AND CONTROL PASSES TO STATEMENT 500 C IF IT FAILS. C----------------------------------------------------------------------- 450 JCUR = 0 IF(PETZLD)THEN C RETURN FOR PETZOLD TYPE ERROR ESTIMATE. ISTEP = 0 INLN = 5 RETURN END IF 4501 DSN = VNORM (N, ACOR, EWT)/(TESCO(2,NQ)*EL0) IF(PETZLD)THEN DSM = VNORM (N, SAVR, EWT)/(TESCO(2,NQ)*EL0*EL0*ABS(H)) ELSE DSM = DSN END IF IF(ITRACE .GE. 1)WRITE(IDEV,451)DSM 451 FORMAT(' SCALED LOCAL ERROR ESTIMATE =',D11.3) IF(DSM .GT. 1.0D0) GO TO 500 C C----------------------------------------------------------------------- C AFTER A SUCCESSFUL STEP, UPDATE THE YH ARRAY. C CONSIDER CHANGING H IF IALTH = 1. OTHERWISE DECREASE IALTH BY 1. C IF IALTH IS THEN 1 AND NQ .LT. MAXORD, THEN ACOR IS SAVED FOR C USE IN A POSSIBLE ORDER INCREASE ON THE NEXT STEP. C IF A CHANGE IN H IS CONSIDERED, AN INCREASE OR DECREASE IN ORDER C BY ONE IS CONSIDERED ALSO. A CHANGE IN H IS MADE ONLY IF IT IS BY A C FACTOR OF AT LEAST 1.1. IF NOT, IALTH IS SET TO 3 TO PREVENT C TESTING FOR THAT MANY STEPS. C----------------------------------------------------------------------- IF(RMAX .EQ. 1.0D+4)THEN C FIRST STEP - SEE IF INIT STEP WAS TOO SMALL EXSM = 1.0D0/DBLE(L) RHSM = 1.0D0/(1.2D0*DSN**EXSM + 0.0000012D0) IF(RHSM .GE. RMAX .AND. (H*HMXI) .LT. (1.0D0-U*8.D0)) THEN C RETAKE THE STEP AS THE INITIAL STEP WAS FAR TOO SMALL RH = RMAX TN = TOLD DO 460 JB = NQ , 1 ,-1 DO 460 JC = JB,NQ DO 455 I = 1,N 455 YH(I,JC) = YH(I,JC) - YH(I,JC+1) 460 CONTINUE IREDO = 3 GOTO 170 END IF END IF C OTHERWISE UPDATE THE SOLUTION AND CONTINUE KFLAG = 0 IREDO = 0 NQU = NQ NCF = 0 HHUSED = H DO 469 I = 1,N YH(I,1) = YH(I,1) + ACOR(I) 469 YH(I,2) = YH(I,2) + ACOR(I)/EL0 DO 470 J = 3,L ELJH = EL(J)/EL0 DO 470 I = 1,N 470 YH(I,J) = YH(I,J) + ELJH*ACOR(I) IF ( C1INTR ) THEN J = LMAX + 1 DO 472 I = 1,N 472 YH(I,J) = ACOR(I) /EL0 END IF IALTH = IALTH - 1 IF (IALTH .EQ. 0) GO TO 520 IF (IALTH .GT. 1 .OR. L .EQ. LMAX) THEN RAISE = .FALSE. GOTO 540 END IF C ELSE THE ORDER MAY BE RAISED ON THE NEXT STEP DO 490 I = 1,N 490 YH(I,LMAX) = ACOR(I)/(H*EL0) GO TO 700 C----------------------------------------------------------------------- C THE ERROR TEST FAILED. KFLAG KEEPS TRACK OF MULTIPLE FAILURES. C RESTORE TN AND THE YH ARRAY TO THEIR PREVIOUS VALUES, AND PREPARE C TO TRY THE STEP AGAIN. COMPUTE THE OPTIMUM STEP SIZE FOR THIS OR C ONE LOWER ORDER. AFTER 2 OR MORE FAILURES, H IS FORCED TO DECREASE C BY A FACTOR OF 0.2 OR LESS. C----------------------------------------------------------------------- 500 KFLAG = KFLAG - 1 TN = TOLD DO 515 JB = NQ , 1 ,-1 DO 515 JC = JB,NQ DO 510 I = 1,N 510 YH(I,JC) = YH(I,JC) - YH(I,JC+1) 515 CONTINUE RMAX = 2.0D0 IF (DABS(H) .LE. HMIN*1.00001D0) GO TO 650 IF (KFLAG .LE. -4) GO TO 660 IREDO = 2 RAISE = .FALSE. GO TO 540 C----------------------------------------------------------------------- C REGARDLESS OF THE SUCCESS OR FAILURE OF THE STEP, FACTORS C RHDN, RHSM, AND RHUP ARE COMPUTED, BY WHICH H COULD BE MULTIPLIED C AT ORDER NQ - 1, ORDER NQ, OR ORDER NQ + 1, RESPECTIVELY. C IN THE CASE OF FAILURE, RHUP = 0.0 TO AVOID AN ORDER INCREASE. C THE LARGEST OF THESE IS DETERMINED AND THE NEW ORDER CHOSEN C ACCORDINGLY. IF THE ORDER IS TO BE INCREASED, WE COMPUTE ONE C ADDITIONAL SCALED DERIVATIVE. C----------------------------------------------------------------------- 520 RAISE = .FALSE. IF (L .LT. LMAX) THEN RAISE = .TRUE. DO 530 I = 1,N 530 YDOT(I) = ACOR(I) - YH(I,LMAX)*H*EL0 DUP = VNORM (N, YDOT, EWT)/(TESCO(3,NQ)*EL0) EXUP = 1.0D0/DBLE(L+1) RHUP = 1.0D0/(1.4D0*DUP**EXUP + 0.0000014D0) TERKP1 = DUP * DBLE(NQ + 2) END IF 540 EXSM = 1.0D0/DBLE(L) RHSM = 1.0D0/(1.2D0*DSN**EXSM + 0.0000012D0) TERK = DSN * DBLE(NQ+1) C DSN OR DSM IN THE LINES ABOVE ???? IF (NQ .GT. 1) THEN DDN = VNORM (N, YH(1,L), EWT)/TESCO(1,NQ) EXDN = 1.0D0/DBLE(NQ) RHDN = 1.0D0/(1.3D0*DDN**EXDN + 0.0000013D0) TERKM1 = DDN * DBLE(NQ) IF(ITRACE .GE. 1)WRITE(IDEV,3333)TERKM1, TERK, TERKP1 3333 FORMAT(' BELOW SAME AND ABOVE = ',3D11.3) C C DECIDE WHETHER TO LOWER THE ORDER C IF(.NOT. RAISE) TERKP1 = TERK IF(TERKM1 .LT. TERK )THEN C LOWER THE ORDER NEWQ = NQ - 1 RH = RHDN IF (KFLAG.LT.0 .OR. IALTH.GT.0) RH = DMIN1(RH,1.0D0) IF (KFLAG .LE. -2) RH = DMIN1(RH,0.2D0) C DROP ORDER TO 1 ON THIRD ERROR TEST FAILURE. IF (KFLAG .LE. -3) NEWQ = 1 GO TO 630 ELSE IF(IALTH .GT. 0 .AND. KFLAG .EQ. 0)THEN GO TO 700 C AS STEPSIZE AND ORDER UNCHANGED FOR NEXT STEP END IF END IF C C DECIDE WHETHER TO RAISE THE ORDER C IF(RAISE) THEN RAISE = .FALSE. IF(NQ .EQ. 1)THEN IF(TERKP1 .LT. (0.5D0 * TERK) ) RAISE = .TRUE. ELSE IF(NQ .EQ. 2) THEN TERKM2 = TERKM1 ELSE DDN1 = VNORM(N,YH(1,L-1),EWT)/TESCO(1,NQ-1) TERKM2 = DDN1 * DBLE(NQ-1) END IF TERKM1 = DMAX1 (TERKM1 , TERKM2 ) IF( TERKP1 .LT. TERK .AND. TERK .LT. TERKM1) RAISE = .TRUE. END IF C LINE TO STOP UNNESS RAISING OF THE ORDER IF( RHSM .GE. RHUP .AND. RHUP .LT. 2.D0) RAISE = .FALSE. END IF IF(RAISE)THEN C RAISE THE ORDER NEWQ = L RH = RHUP IF (RH .LT. 1.1D0) THEN IALTH = 3 GO TO 700 END IF R = EL(L)/(DBLE(L)*EL0) DO 600 I = 1,N 600 YH(I,NEWQ+1) = ACOR(I)*R ELSE C LEAVE THE ORDER AS IT IS NEWQ = NQ RHSM = 1.0D0 / (1.2D0 * DSM **EXSM + 0.0000012D0) RH = RHSM IF ((KFLAG .EQ. 0) .AND. (RH .LT. 1.1D0)) THEN IALTH = 3 GO TO 700 C AS IT IS NOT WORTH CHANGING THE STEPSIZE END IF IF (KFLAG .LE. -2) RH = DMIN1(RH,0.2D0) IF (KFLAG .LE. -3) THEN NEWQ = 1 GOTO 630 END IF GO TO 170 END IF C----------------------------------------------------------------------- C IF THERE IS A CHANGE OF ORDER, RESET NQ, L, AND THE COEFFICIENTS. C IN ANY CASE H IS RESET ACCORDING TO RH AND THE YH ARRAY IS RESCALED. C THEN EXIT FROM 690 IF THE STEP WAS OK, OR REDO THE STEP OTHERWISE. C----------------------------------------------------------------------- 630 NQ = NEWQ L = NQ + 1 IRET = 2 GO TO 150 C----------------------------------------------------------------------- C ALL RETURNS ARE MADE THROUGH THIS SECTION. H IS SAVED IN HOLD C TO ALLOW THE CALLER TO CHANGE H ON THE NEXT STEP. C----------------------------------------------------------------------- C C KFLAG = -1 ; ERROR TEST FAILED REPEATEDLY WITH ABS(H) = HMIN C 650 KFLAG = -1 CALL SERROR(' SPGEAR-AT T=(R1) AND STEP SIZE H =(R2) THE ERROR 1 TEST FAILED REPEATEDLY WITH ABS(H) = HMIN', 1, 0, 0, 0, 2, TN, H) GO TO 720 C C KLAG = -1 ; ERROR TEST REPEATEDLY FAILED. C 660 KFLAG = -1 CALL SERROR(' SPGEAR-AT T=(R1) AND STEP SIZE H =(R2) THE ERROR 1 TEST FAILED REPEATEDLY', 1, 0, 0, 0, 2, TN, H) C C KFLAG = -2 CONVERGANCE FAILURE C 670 KFLAG = -2 CALL SERROR(' SPGEAR-AT T=(R1) AND STEP SIZE H=(R2) THE CORRECTOR 1 CONVERGENCE FAILED REPEATEDLY ', 1, 0, 0, 0, 2, TN, H) IF( FNITER ) THEN CALL SERROR (' THE SPGEAR MODULE WAS BEING USED WITH 1 FUNCTIONAL ITERATION A SWITCH HAS BEEN MADE TO A 2 NEWTON METHOD TO TRY AND IMPROVE CONVERGENCE.', 3 1, 0, 0, 0, 0, 0.0D0, 0.0D0) FNITER = .FALSE. END IF GO TO 720 C C KLAG = -2 CONVERGENCE FAILURE AT MINIMUM STEP SIZE C 675 KFLAG = -2 CALL SERROR(' SPGEAR-AT T=(R1) AND STEP SIZE H=(R2) THE CORRECTOR 1 CONVERGENCE FAILED REPEATEDLY WITH ABS(H) = HMIN', 1, 0, 0, 2 0, 2, TN, H) IF( FNITER ) THEN CALL SERROR (' THE SPGEAR MODULE WAS BEING USED WITH 1 FUNCTIONAL ITERATION.A SWITCH HAS BEEN MADE TO A 2 NEWTON METHOD TO TRY AND IMPROVE CONVERGENCE.', 3 1, 0, 0, 0, 0, 0.0D0, 0.0D0) FNITER = .FALSE. END IF GO TO 720 C KFLAG = -4 RES ORDERED RETURN C 680 CALL SERROR(' SPGEAR-AT T=(R1) RESIDUAL ROUTINE RETURNED IRES 1 =3 REPEATEDLY', 1, 0, 0, 0, 1, TN, 0.0D0) GO TO 720 685 KFLAG = -5 CALL SERROR(' SPGEAR-AT T = (R1) A SINGULAR JACOBIAN MATRIX WAS 1 REPEATEDLY ENCOUNTERED' , 1, 0, 0, 0, 1, TN, 0.0D0) GO TO 720 690 RMAX = 10.0D0 720 CONTINUE 700 R = 1.D0 /(TESCO(2,NQU) *EL0) IF(KFLAG .LT. 0)THEN C THE STEP HAS FAILED AND BEEN RETRACTED - INDICATE THAT LOCAL C ERROR HAS BEEN LOST CALL SERROR(' SPGEAR-CURRENT STEP FAILURE MEANS THAT OLD LOCAL 1 ERROR ESTIMATE CANNOT BE RETRIEVED AND SO ACOR IS SET TO ZERO', 2 1, 0, 0, 0, 0, 0.0D0, 0.0D0) DO 702 I = 1,N 702 ACOR(I) = 0.0D0 END IF DO 710 I = 1,N C RESET YDOT AND SCALE ACOR SO THAT IT IS LOCAL ERROR ESTIMATE. Y(I) = YH(I,1) YDOT(I) = YH(I,2)/H 710 ACOR(I) = -ACOR(I)*R HOLD = H ISTEP = KFLAG IF(ISTEP .EQ. 0)ISTEP = 1 RETURN C----------------------- END OF SUBROUTINE SPGEAR----------------------- END SUBROUTINE DFODE (METH, ELCO, TESCO) INTEGER METH INTEGER I, IB, NQ, NQM1, NQP1 DOUBLE PRECISION ELCO, TESCO DOUBLE PRECISION AGAMQ, FNQ, FNQM1, PC, PINT, RAGQ, 1 RQFAC, RQ1FAC, TSIGN, XPIN DIMENSION ELCO(13,12), TESCO(3,12) C----------------------------------------------------------------------- C DFODE IS CALLED BY THE INTEGRATOR ROUTINE TO SET COEFFICIENTS C NEEDED THERE. THE COEFFICIENTS FOR THE CURRENT METHOD, AS C GIVEN BY THE VALUE OF METH, ARE SET FOR ALL ORDERS AND SAVED. C THE MAXIMUM ORDER ASSUMED HERE IS 12 IF METH = 1 AND 5 IF METH = 2. C (A SMALLER VALUE OF THE MAXIMUM ORDER IS ALSO ALLOWED.) C DFODE IS CALLED ONCE AT THE BEGINNING OF THE PROBLEM, C AND IS NOT CALLED AGAIN UNLESS AND UNTIL METH IS CHANGED. C C THE ELCO ARRAY CONTAINS THE BASIC METHOD COEFFICIENTS. C THE COEFFICIENTS EL(I), 1 .LE. I .LE. NQ+1, FOR THE METHOD OF C ORDER NQ ARE STORED IN ELCO(I,NQ). THEY ARE GIVEN BY A GENETRATING C POLYNOMIAL, I.E., C L(X) = EL(1) + EL(2)*X + ... + EL(NQ+1)*X**NQ. C FOR THE IMPLICIT ADAMS METHODS, L(X) IS GIVEN BY C DL/DX = (X+1)*(X+2)*...*(X+NQ-1)/FACTORIAL(NQ-1), L(-1) = 0. C FOR THE BDF METHODS, L(X) IS GIVEN BY C L(X) = (X+1)*(X+2)* ... *(X+NQ)/K, C WHERE K = FACTORIAL(NQ)*(1 + 1/2 + ... + 1/NQ). C C THE TESCO ARRAY CONTAINS TEST CONSTANTS USED FOR THE C LOCAL ERROR TEST AND THE SELECTION OF STEP SIZE AND/OR ORDER. C AT ORDER NQ, TESCO(K,NQ) IS USED FOR THE SELECTION OF STEP C SIZE AT ORDER NQ - 1 IF K = 1, AT ORDER NQ IF K = 2, AND AT ORDER C NQ + 1 IF K = 3. C----------------------------------------------------------------------- DIMENSION PC(12) C GO TO (100, 200), METH C 100 ELCO(1,1) = 1.0D0 ELCO(2,1) = 1.0D0 TESCO(1,1) = 0.0D0 TESCO(2,1) = 2.0D0 TESCO(1,2) = 1.0D0 TESCO(3,12) = 0.0D0 PC(1) = 1.0D0 RQFAC = 1.0D0 DO 140 NQ = 2,12 C----------------------------------------------------------------------- C THE PC ARRAY WILL CONTAIN THE COEFFICIENTS OF THE POLYNOMIAL C P(X) = (X+1)*(X+2)*...*(X+NQ-1). C INITIALLY, P(X) = 1. C----------------------------------------------------------------------- RQ1FAC = RQFAC RQFAC = RQFAC/DBLE(NQ) NQM1 = NQ - 1 FNQM1 = DBLE(NQM1) NQP1 = NQ + 1 C FORM COEFFICIENTS OF P(X)*(X+NQ-1). ---------------------------------- PC(NQ) = 0.0D0 DO 110 IB = 1,NQM1 I = NQP1 - IB 110 PC(I) = PC(I-1) + FNQM1*PC(I) PC(1) = FNQM1*PC(1) C COMPUTE INTEGRAL, -1 TO 0, OF P(X) AND X*P(X). ----------------------- PINT = PC(1) XPIN = PC(1)/2.0D0 TSIGN = 1.0D0 DO 120 I = 2,NQ TSIGN = -TSIGN PINT = PINT + TSIGN*PC(I)/DBLE(I) 120 XPIN = XPIN + TSIGN*PC(I)/DBLE(I+1) C STORE COEFFICIENTS IN ELCO AND TESCO. -------------------------------- ELCO(1,NQ) = PINT*RQ1FAC ELCO(2,NQ) = 1.0D0 DO 130 I = 2,NQ 130 ELCO(I+1,NQ) = RQ1FAC*PC(I)/DBLE(I) AGAMQ = RQFAC*XPIN RAGQ = 1.0D0/AGAMQ TESCO(2,NQ) = RAGQ IF (NQ .LT. 12) TESCO(1,NQP1) = RAGQ*RQFAC/DBLE(NQP1) TESCO(3,NQM1) = RAGQ 140 CONTINUE RETURN C 200 PC(1) = 1.0D0 RQ1FAC = 1.0D0 DO 230 NQ = 1,5 C----------------------------------------------------------------------- C THE PC ARRAY WILL CONTAIN THE COEFFICIENTS OF THE POLYNOMIAL C P(X) = (X+1)*(X+2)*...*(X+NQ). C INITIALLY, P(X) = 1. C----------------------------------------------------------------------- FNQ = DBLE(NQ) NQP1 = NQ + 1 C FORM COEFFICIENTS OF P(X)*(X+NQ). ------------------------------------ PC(NQP1) = 0.0D0 DO 210 IB = 1,NQ I = NQ + 2 - IB 210 PC(I) = PC(I-1) + FNQ*PC(I) PC(1) = FNQ*PC(1) C STORE COEFFICIENTS IN ELCO AND TESCO. -------------------------------- DO 220 I = 1,NQP1 220 ELCO(I,NQ) = PC(I)/PC(2) ELCO(2,NQ) = 1.0D0 TESCO(1,NQ) = RQ1FAC TESCO(2,NQ) = DBLE(NQP1)/ELCO(1,NQ) TESCO(3,NQ) = DBLE(NQ+2)/ELCO(1,NQ) RQ1FAC = RQ1FAC/FNQ 230 CONTINUE RETURN C----------------------- END OF SUBROUTINE DFODE ----------------------- END C JULY 1987 CHANGES. C (1) THE VARIABLE K IS SET TO 1 ON THE FIRST STEP C (2) K IS THEN SET TO 2 AT THE END OF A SUCCESSFUL STEP. C C APRIL 1988 CHANGES ACOR DIVIDED BY (H*THETA) IN DO 1025 LOOP C SO AS TO TAKE ACCOUNT OF CHANGED BACKSUB C SUBROUTINE THESET( NY2DIM, IRET) INTEGER NY2DIM, IRET C********************************************************************** C SETUP ROUTINE FOR THE THETA METHOD INTEGRATOR STHETA C THIS ROUTINE MUST BE CORRECTLY CALLED BT THE USER BEFOPRE THE C MAIN SPRINT PACKAGE IS ENTERED WITH STHETA AS THE STEP (CORE) C INTERGRATOR. C C INPUT PARAMETER C NY2DIM : THE SECOND DIMENSION OF THE WORK ARRAY YSAVE USED BY C STHETA - YSAVE(NEQ, NY2DIM); NY2DIM MUST BE >= 4 C (NEQ IS THE NUMBER OF ORDINARY DIFFERENTIAL/ALGEBRAIC C EQUATIONS BEING SOLVED) C C OUTPUT PARAMETER C IRET ; SET TO -1 IF NY2DIM IS TOO SMALL , SET TO ZERO OTHER- C WISE. C*********************************************************************** CHARACTER*6 ODCODE COMMON /ODECHK/ ODCODE SAVE /ODECHK/ C IF(NY2DIM .LT. 4)THEN CALL SERROR(' SETUP ROUTINE FOR STHETA - PARAM NY2DIM (=I1) 1 SHOULD BE (=I2)', 1, 2, NY2DIM, 4, 0, 0.0D0,0.0D0) IRET = -1 ELSE IRET = 0 ODCODE = 'STHETA' END IF RETURN END C======================================================================= C C INTEGRATOR STHETA ;THETA METHOD FOR SPRINT PACKAGE. C C======================================================================= SUBROUTINE STHETA( NEQN, Y, W, NY, WT, DY, DEL, ACOR, INLN, ISTEP, 1 THETA, H, T, HMIN, HMXI, IDAE) C******************************************************************** C C THIS ROUTINE SOLVES THE SYSTEM OF DIFFERENTIAL/ALGEBRAIC EQUATIONS C OF THE FORM C E Y' = F(Y, T) (1) C WHERE E IS A SINGULAR MATRIX WHEN THERE ARE ALGEBRAIC EQUATIONS C PRESENT IN THE SYSTEM. C THE INTEGRATION METHOD USED IS: C E*Y(N+1) = E*Y(N) + H(THETA*F(Y,T(N+1)) + (1-THETA)*F(Y,T(N))) (2) C WITH LOCAL ERROR CONTROL. C C THE ITERATION MATRIX G IS GIVEN BY: C G = E - H*THETA*DF/DY (3) C C----------------------------------------------------------------------- C DIFFERENCES FROM THE CHUA AND DEW CODE. C---------------------------------------- C THERE ARE TWO MAIN DIFFERENCES FROM T.S. CHUA'S CODE. C FIRSTLY AS THE SYSTEM OF NONLINEAR EQUATIONS IS SOLVED BY THE C ROUTINE NLSLVR THE CHUA STRATEGY OF RE-EVALUATING THE JACOBIAN MATRIX C IN MID-ITERATION IS NONLONGER USED. IN ANY CASE AS RELAXATION IS USED C TO CORRECTLY SCALE THE ALGABRAIC COMPONENTS IT IS NO-LONGER SO C IMPORTANT TO AVOID REDUCING THE STEPSIZE AND RE-EVALUATING THE C JACOBIAN MATRIX. C SECONDLY , A MAXIMUM OF THREE ITERATIONS C IS ALLOWED IN THE SOLUTION OF THE NONLINEAR EQUATIONS. THIS COULD BE C CHANGED BY INCLUDING THE SPRINT SYSTEM COMMON BLOCK /SSOLVR/ AND BY C SETTING MAXIT TO 5 C----------------------------------------------------------------------- C C THE VARIABLES USED HAVE THE FOLLOWING MEANINGS: C *NEQN--NUMBER OF EQUATIONS TO BE SOLVED; BOTH DIFFERENTIAL AND C ALGEBRAIC. C *T --THE INDEPENDENT VARIABLE. ON FIRST CALL IT SHOULD BE SET C TO THE INITIAL CONDITION. ON RETURN IT CONTAINS THE VALUE C OF T FOR WHICH Y IS THE SOLUTION. C *H --PROPOSED STEPSIZE FOR THE STEP. ON FIRST CALL, IT SHOULD C CONTAIN THE INITIAL ESTIMATE OF THE STEPSIZE . C *Y --THE DEPENDENT VARIABLE. ON FIRST CALL SHOULD BE SET TO C THE INITIAL CONDITIONS. ON RETURN IT CONTAINS THE SOLUTION C AT T. DIMENSIONED AS Y(NEQN). C *DY --AN ARRAY RETURNS THE QUANTITY H*DY/DT AT THE NEW TIME LEVEL. C ON FIRST ENTRY, IT SHOULD CONTAIN THE DERIVATIVES DY/DT AT C TIME T. DIMENSIONED AS DY(NEQN). C *DEL --RETURNS THE RESULT OF A BACK-SUBSTITUTION (SEE INLN = 5) C DIMENSIONED AS DEL(NEQN). C *ACOR--WORKSPACE ON A CALL TO THE NONLINEAR EQUATIONS SOLVER C WITH INLN = 5 IT CONTAINS THE VECTOR WHICH IS PREMULTIPLIED BY C THE MATRIX E AND THEN FED TO THE BACKSUBSTITUTION ROUTINE. C DIMENSIONED AS ACOR(NEQN) C ISTEP -INDICATOR FOR THE INTEGRATOR C ON EXIT >0 FOR SUCCESSFUL CALL C <0 FOR STEP FAILURE. C ON ENTRY, IT HAS THE FOLLOWING MEANINGS: C =-1 INITIAL STEP. C = 0 REVERSE COMMUNICATION ENTRY. C = 1 TAKE A NEW STEP , CONTINUING FROM THE PREVIOUS STEP. C = 2 TAKE A CONTINUATION STEP BUT WITH NEW VALUES OF H OR NEQN C = 3 TAKE A NEW STEP WITH A NEW VALUE OF H C ON EXIT, IT HAS THE FOLLOWING MEANINGS: C = 1 SUCCESSFUL STEP. C = 0 REVERSE COMMUNICATION EXIT. C =-1 REQUESTED ERROR COULD NOT BE ACHIEVED. C =-2 CORRECTOR CONVERGENCE COULD NOT BE ACHIEVED. C =-3 RESIDUAL FORMING ROUTINE ORDERED A RETURN TO THE DRIVER. C =-4 ERROR CONDITION IN RESIDUAL ROUTINE COULD NOT BE AVOIDED. C =-5 ERROR IN FORMING THE JACOBIAN. SINGULAR MATRIX C =-6 NOT USED HERE C =-7 IMPOSSIBLE ERROR OCCURED IN LINEAR ALGEBRA ROUTINES. C INLN -POINTER TO INFORM THE CALLING PROGRAM ABOUT THE TYPE OF C PROBLEM DEPENDENT INFORMATION REQUIRED BY THE INTEGRATOR. C ON EXIT..... C = 0 INTEGRATION HAS FINISHED, CHECK ISTEP FOR POSSIBLE C ERROR. C = 1 TO COMPUTE THE SOLUTION OF NON-LINEAR SYSTEM OF EQUATIONS C GIVEN BY (2). THE INITIAL PREDICTION FOR Y(N+1) IS GIVEN C IN VECTOR Y; THE VALUES OF Y AND H*Y' AT TIME TN ARE C STORED IN THE WORKSPACE W(.,1) AND W(.,2) RESPECTIVELY. C IF A SOLUTION CANNOT BE FOUND BECAUSE THE ITERATION DOES C NOT CONVERGE, THEN SET IND(2)=-1 TO REDUCE THE STEPSIZE. C OTHERWISE SET IND(2)=-2 TO TERMINATE THE INTEGRATION. C = 5 TO COMPUTE THE SOLUTION OF G*DEL = DYY, IE A BACK- C SUBSTITUTION. C = 3 EVALUATE A NEW RIGHT-HAND FUNCTION F(Y,T) IN EQN.(1) AND C AND RETURN THE RESULTS IN VECTOR DEL. C ON ENTRY..... C = 0 NORMAL ENTRY - ACTION TO BE TAKEN IS GOVERNED BY ISTEP. C = 1 THE NONLINEAR SYSTEM OF EQUATIONS HAS BEEN SOLVED. C = 2 CONVERGENCE FAILURE OCCURED IN THE NONLINEAR EQUATIONS C SOLVER. C = 3, 5 THE TASKS SET BY EXIT VALUES OF ISAVE = 3 OR 5 WERE C SUCCESSFULLY PERFORMED. C = 4,6,7 NOT USED HERE AT PRESENT. C = -1 SINGULAR JACOBIAN MATRIX WAS FOUND . C = -2 ERROR IN RESIDUAL ROUTINE FORCES AN IMMEDIATE RETURN. C = -3 ILLEGAL VALUES ENCOUNTERED IN THE RESIDUAL ROUTINE. C REDUCE THE STEP SIZE BY A FACTOR OF TWO AND TRY AGAIN. C = -4 CONDITION ENCOUNTERED IN THE RESIDUAL ROUTINE FORCES C THE STEP TO BE FAILED AND A RETURN TO BE MADE TO THE C MONITOR ROUTINE. C = -5 IMPOSSIBLE ERROR OCCURED IN LINEAR ALGEBRA . C C ISAVE -INTERNAL INDICATOR TO INFORM THE INTEGRATOR THE EXACT POINT C TO RETURN TO. C *WT --VECTOR OF WEIGHTS FOR ERROR CRITERION. C DIMENSIONED AS WT(NEQN) C *W --ARRAY USED AS WORKSPACE. DIMENSIONED AS W(NEQN,4), WHERE : C W(J,1) HOLDS THE VALUES OF Y AT PREVIOUS TIME LEVEL. IE. Y(N). C W(J,2) HOLDS THE VALUES OF H*DY AT PREVIOUS TIME LEVEL. C W(J,3) HOLDS BETA(N) FROM THE PREVIOUS TIME LEVEL. C W(J,4) CONTAINS THE VALUES OF Y(N)-Y(N-1). C HMXI : 1.0D0/HMAX WHERE HMAX IS C THE MAXIMUM STEPSIZE THE INTEGRATOR IS ALLOWED TO TAKE C IN THE CASE WHEN THIS IS ZERO THE POSSIBLE STEPSIZE IS C RESTRICTED TO 1.0D0/TWOU WHERE TWOU IS THE UNIT ROUNDOFF ERR. C HMIN : THE MINUMUM STEPSIZE THE INTEGRATOR IS ALLOWED TO USE. C T : THE CURRENT VALUE OF THE INDEPENDENT VARIABLE. C H : THE CURRENT VALUE OF THE STEP SIZE. C RESERR - LOGICAL PARAMETER THAT WHEN TRUE INDICATES THAT AN ERROR C HAS BEEN RETURNED FROM THE RESIDUAL ROUTINE. C C======================================================================= C C NOTE--WHEN THE ROUTINE IS FIRST CALLED, C ISTEP , INLN MUST BE SET TO -1 AND 0 RESPECTIVELY. C C*********************************************************************** LOGICAL RESERR CHARACTER*6 ODCODE DOUBLE PRECISION T,H,FAC,FACTOR,HALF,ONE,ZERO,THETA,ERRL,COEF, * TWOU,TENP,DIF,FAC2,COEF1,COEF2,SUM DOUBLE PRECISION Y(NEQN),DY(NEQN),DEL(NEQN),W(NY,4),ACOR(NEQN), * R,WT(NEQN), HMIN,HMXI, VNORM INTEGER ISTEP, INLN, ISAVE, IOVFLO, K, NRE, NJE, NITER, JK, NEQN, 1 JKOLD, N, I, J, IDAE(1), NINTER, JSTEP, NHALF, JCUR, MSBP, 2 ITRACE, IDEV, NST, NY, IJ COMMON /ODECHK/ ODCODE COMMON /SCONS1/ TENP, TWOU, IOVFLO COMMON /SDEV2/ ITRACE, IDEV COMMON /LSTATS/ JK,JKOLD, NST,NRE,NJE,NITER , NINTER COMMON /STHESV/ COEF1, COEF2, DIF, FAC, FACTOR, FAC2, ONE , SUM, 1 ZERO, HALF, R(4), COEF(3), ERRL, ISAVE, JSTEP, 2 NHALF, I,J, JCUR, MSBP, N, RESERR SAVE /ODECHK/, /STHESV/, /SCONS1/, /LSTATS/ C C********************************************************************** C C THE COMMON BLOCKS USED ARE: C /STHESV/-CONTAINS THE STATISTICS REQUIRED AT THE END OF THE SOLUTION C *R(4)-VECTOR USED AS A WORKSPACE. C @@ (1)-HOLDS THE OLD STEPSIZE. C @@ (2)-HOLDS THE OLD VALUE OF TIME ,T, USED IN RESTARTING. C @@ (3)-HOLDS THE MAXIMUM (INTEGRATOR DEPENDENT) STEPSIZE. C @@ (4)-HODS THE TIME AT WHICH A RESTART PHASE IS INITIATED. C *NHALF -COUNTS THE NO. OF STEP REDUCTIONS IN A STEP. ONLY C 3 STEP REDUCTIONS IS ALLOWED. C *COEF(3)-WORKSPACE USED FOR STORING THE COEFFICIENTS REQUIRED C IN THE ERROR ESTIMATION. C *JSTEP -THE NUMBER OF STEPS TO BE PERFORMED BEFORE STEPSIZE C CHANGES IS CONSIDERED. A MIN OF 4 STEPS IS NEEDED FOR C A PREVIOUS STEPSIZE INCREMENT AND A MIN OF K+1 STEPS C IS REQUIRED FOR A PREVIOUS STEPSIZE REDUCTION. C *ERRL -HOLDS THE WEIGHTED LOCAL ERROR NORM. C /SDEV2/-TO TRACE THE INTEGRATOR FOR DEBUGGING PURPOSES: C *IDEVO -OUTPUT DEVICE NUMBER. C *ITRACE-TRACE LEVEL REQUIRED. C =0 FOR NO TRACE C =1 TO OUTPUT INTERMEDIATE RESULTS AT APPROPRIATE C POINTS. C********************************************************************** C NINTER SPECIFIES HOW MUCH OF THE MEMORY VECTOR IS TO BE USED IF C ITERPOLATION IS USED E.G. IN P.D.E. REMESHING. C ZERO=0.0D+0 HALF=0.5D+0 ONE=1.0D+0 THETA = 0.55D0 JK = 1 JKOLD = 1 IF(DABS(HMXI) .LE. TWOU)THEN R(3) = 1.0D0 / TWOU ELSE R(3) = 1.0D0/HMXI END IF C C SET UP THE STRATEGY PARAMETERS FOR THE INITIAL STEP C IF (ISTEP .LT. 0) THEN IF(ODCODE .NE. 'STHETA')THEN CALL SERROR(' STHETA THE SETUP ROUTINE WAS NOT CALLED FOR 1 THIS ROUTINE BEFORE SPRINT WAS ENTERED', 1, 0, 0, 0, 0, 2 0.0D0, 0.0D0) ISTEP = -6 RETURN END IF NINTER = 4 COEF(1)=HALF - THETA COEF(2)=THETA*THETA - THETA + ONE/6.0D+0 COEF(3)=2.0D+0*THETA R(1)=H N = NEQN NHALF = 0 MSBP = 0 K = 1 JCUR = 0 ISAVE = -1 JSTEP = 0 RESERR = .FALSE. FAC = 1.0D0 END IF C C********************************************************************** C C STAGE--1 C C*********************************************************************** C C IF INLN >0 JUMP TO THE APPROPRIATE POINTS IN THE INTEGRATOR C OTHERWISE EITHER IT IS A FRESH CALL FOR THE PRESENT TIME LEVEL C OR AN ERROR IN THE NON-LINEAR EQUATIONS SOLVER HAS BEEN FOUND C I=INLN + 5 INLN = 0 GO TO ( 9, 9, 9, 9, 14, 40, 9, 9, 9, 70), I C INLN= -4 -3 -2 -1 0 1 2 3 4 5 9 CONTINUE IF(I .EQ. 1 .OR. I .EQ. 3)THEN ISTEP = -3 ELSE IF(I .EQ. 4)THEN ISTEP = -5 ELSE IF(I.EQ. 7 .AND. JCUR .EQ. 2)THEN C FORM THE JACOBIAN FOR THE FIRST TIME ON THIS STEP JCUR = 0 GOTO 30 ELSE IF(I.EQ. 0)THEN ISTEP = -7 END IF C----------------------------------------------------------------------- C RETRACT THE SOLUTION TO THAT AT THE PREVIOUS TIME STEP AND RETURN. C----------------------------------------------------------------------- IF(K .EQ.1)THEN DO 11 J = 1,NEQN W(J,1) = W(J,1) - W(J,2) Y(J) = W(J,1) W(J,2) = W(J,2)/FAC DY(J) = W(J,2) / R(1) 11 CONTINUE ELSE FAC = H/R(1) DIF = ONE + THETA * (FAC - ONE) FAC2 = -(ONE -THETA)*FAC DO 12 J = 1,NEQN W(J,1) = W(J,1) - (DIF* W(J,3) + W(J,4))*FAC Y(J) = W(J,1) W(J,2) = (W(J,2)*THETA - (DIF*W(J,3)+ W(J,4))*FAC)/FAC2 DY(J) = W(J,2)/R(1) 12 CONTINUE END IF IF(I .EQ. 2)THEN C RESIDUAL ROUTINE HAS RETURNED IRES = INLN = 3 RESERR = .TRUE. GOTO 80 ELSE IF (I .EQ. 7)THEN C CONVERGENCE FAILURE IN NONLINEAR SOLVER WITH A NEW C JACOBIAN FOR THIS STEP - TRY REDUCING STEPSIZE A C MAXIMUM OF THREE TIMES. GOTO 80 END IF H = R(1) T = R(2) RETURN 14 RESERR = .FALSE. C C CHECK IF NEQN HAS CHANGED , POSSIBLY ON A RESTART WITH ISTEP = 1 C IF(ISTEP .EQ. 1)GOTO 20 IF(ISTEP .EQ. -1)THEN C PUT INITIAL Y AND YDOT INTO MEMORY VECTOR DO 142 I = 1,NEQN W(I,1) = Y(I) 142 W(I,2) = DY(I)*H END IF IF(ISTEP .EQ. 2 .AND. FAC .GT. 1.0D0)FAC = 1.0D0 IF(R(1) .NE. H)THEN IF(DABS(H) .GT. R(3))H = R(3) * DSIGN(1.0D0,H) IF(DABS(H) .LT. HMIN) H = HMIN* DSIGN(1.0D0,H) JCUR = 0 FAC = H/R(1) H = R(1) END IF IF(ISTEP .NE. 2) GOTO 20 JSTEP= 3 C JCUR = 0 CZ TO FORCE A JACOBIAN EVALUATION AS MEMORY MAY HAVE CHANGED. IF(N .NE. NEQN)THEN C NEQN HAS BEEN CHANGED BY MONITR OR BY THE USER. FLAG AN C INCREASE AND IF A DECREASE ZERO UNUSED PARTS OF WORKSPACES IJ = N - NEQN IF(IJ .LT. 0)THEN CALL SERROR('STHETA - THE VALUE OF NEQN HAS BEEN INCREASED 1 FROM(=I1) TO (=I2) ', 1, 2, N, NEQN, 0, 0.0D0, 0.0D0) END IF DO 141 I = NEQN+1,N DO 141 J = 1,4 141 W(I,J) = 0.0D0 N = NEQN END IF C*********************************************************************** C C STAGE--2 PREDICT THE SOLUTION PRESERVING OLD T VALUE IN R(2). C C*********************************************************************** 20 R(2)=T H=H*FAC T=T+H FAC=H/R(1) IF (ISTEP .EQ. -1 .OR. ISTEP .EQ. 2 .OR. K .EQ. 1)THEN C INITIAL STEP OR RESTART FROM ORDER 1 K=1 IF(ISTEP.EQ. -1)ISTEP = 1 C STORE THE INITIAL VALUES OF Y & DY IN W(1,J) &W(2,J) DO 1000 J=1,NEQN W(J,2)= W(J,2) * FAC W(J,1)= W(J,1) + W(J,2) 1000 CONTINUE ELSE C NON-INITIAL STEP, PREDICT THE SOLUTION TO 2ND ORDER ACCURACY K=2 DIF = ONE + THETA * (FAC - ONE) DO 1010 J=1,NEQN W(J,1) = W(J,1) + (DIF * W(J,3) + W(J,4)) * FAC W(J,2) = (W(J,2)+(DIF*W(J,3)+W(J,4)-W(J,2))/THETA)*FAC 1010 CONTINUE END IF NHALF=0 C*********************************************************************** C C STAGE--3 NON-LINEAR EQUATIONS SOLVER C C*********************************************************************** 30 CONTINUE C C SET Y AND YDOT TO PREDICTED VALUES AND DECIDE WHETHER TO UPDATE JAC. C DO 35 I = 1, NEQN Y(I) = W(I,1) DY(I) = W(I,2)/H 35 CONTINUE IF(JCUR .EQ. 0) THEN JCUR = 1 INLN = 1 MSBP = 0 ELSE JCUR = 2 INLN = 2 END IF C C EXIT TO SOLVE THE NON-LINEAR EQUATIONS; RETURN TO LABEL 40 IF SUCCESS C RETURN C*********************************************************************** C C STAGE--4 ERROR ESTIMATION C C*********************************************************************** C A SOLUTION OF THE NON-LINEAR EQUATIONS HAS BEEN FOUND CHECK THE C NEW DERIVS Y' IN VECTOR DY ANDEXIT TO COMPUTE BETA(N+1) TO BE C USED IN THE LOCAL ERROR ESTIMATION. RETRACT MEMORY VECTOR FOR C ESTIMATING BETA(N+1) AND W(J,4) 40 FAC = H/R(1) IF(K .EQ. 1)THEN DO 1023 J = 1,NEQN W(J,1) = W(J,1) - W(J,2) 1023 W(J,2) = W(J,2)/FAC ELSE FAC2 = THETA - ONE DIF = ONE + THETA*(FAC - ONE) DO 1024 J = 1,NEQN W(J,1) = W(J,1) - (DIF*W(J,3)+W(J,4))*FAC 1024 W(J,2) =(W(J,2)/FAC*THETA - (DIF*W(J,3) + W(J,4)))/FAC2 END IF DO 1025 J=1,NEQN DEL (J)= DY(J)*H - W(J,2)*FAC ACOR(J)=(-DY(J)*H + W(J,2)*FAC) / ( H *THETA) 1025 CONTINUE INLN = 5 ISAVE = 2 RETURN 70 CONTINUE C C EVALUATE THE LOCAL ERROR CORRECTIONS - HOPKIN'S ERROR ESTIMATE C IF (K . EQ. 1) THEN C 1ST ORDER METHOD DO 1030 J=1,NEQN ACOR(J)=COEF(1)*DEL(J) 1030 CONTINUE ELSE C 2ND ORDER METHOD FAC=H/R(1) FAC2=FAC*FAC DIF=FAC*COEF(2)/(ONE + COEF(3)*(FAC-ONE)) COEF1=COEF(1) + DIF COEF2=FAC2*DIF DO 1040 J=1,NEQN ACOR(J)=COEF1*DEL(J) - COEF2*W(J,3) 1040 CONTINUE END IF ERRL = VNORM( NEQN, WT, ACOR) IF(ITRACE .GE. 1)WRITE(IDEV,8005)ERRL IF (ERRL.LE.ONE) GO TO 90 8005 FORMAT(/' SCALED LOCAL ERROR IS =',D15.6) C*********************************************************************** C C STAGE--5 REDUCE H BY FACTOR AND RETURN TO THE PREDICTION STAGE C AS THE SOLUTION DOES NOT SATISFY THE LOCAL ERROR TOLERANCE C C*********************************************************************** 80 FAC=HALF JSTEP=3 C SHOULD POSSIBLY BE K + 1 ?? NHALF=NHALF+1 IF(ERRL.GT.2.0D0)FAC=FAC*2.0D0/DMIN1(100.0D0,ERRL) JCUR = 0 T = R(2) IF (NHALF . GT. 3 .OR. (DABS(H)*FAC) .LT. HMIN) THEN C ERROR-- TOO MANY STEP REDUCTIONS ISTEP = -1 H = R(1) IF(RESERR)ISTEP = -4 CALL SERROR(' STHETA - FAILED DUE TO REPEATED ERROR TEST OR 1 CONVERGENCE FAILURES ON THE CURRENT STEP (H=R1) AT TIME (=R2)' 2 , 1, 0, 0, 0, 2, H, T) RETURN END IF GOTO 20 C*********************************************************************** C C STAGE--6 SUCCESSFUL STEP C C*********************************************************************** 90 MSBP = MSBP + 1 IF(MSBP .EQ. 21)JCUR = 0 ISTEP = 1 K = 2 C C UPDATE THE MEMORISED VALUES AND PUT THE LOCAL ERROR IN ACOR C DO 1070 J=1,NEQN W(J,4)=Y(J) - W(J,1) W(J,3)=DEL(J) W(J,1)=Y(J) W(J,2)=DY(J)* H 1070 CONTINUE JSTEP=JSTEP-1 FAC=ONE R(1)=H C IF (DABS(H).LT.R(3).AND.ERRL.LT.0.15D+0.AND.JSTEP.LE.0)THEN IF (DABS(H).LT.R(3).AND.ERRL.LT.0.25D+0.AND.JSTEP.LE.0)THEN C DOUBLE THE STEPSIZE TO BE USED NEXT STEP JCUR = 0 FAC=2.0D+0 C C MORE THAN DOUBLE THE STEP IF ERRL IS VERY SMALL C DO 1077 I = 1,4 IF(ERRL .LE. 0.5* 10.0D0**(-I))FAC = FAC * 2.0 1077 CONTINUE JSTEP=K+1 IF (DABS(H)*FAC.GT.R(3)) FAC=R(3)/DABS(H) END IF NHALF = 0 RETURN C END OF SUBROUTINE RTHETA END C THIS FILE CONTAINS THE BANDED AND FULL MATRIX ROUTINES USED BY THE C SPRINT PACKAGE. C THE ROUTINES CALLED TO FORM THE JACOBIAN MATRIX ARE C FULL CASE PREPJF ; BANDED CASE PREPJB. C THE ROUTINES CALLED TO BACKSUBSTITUTE USING ITS FACTORED FORM ARE C FULL CASE SOLSF ; BANDED CASE SOLSB C C IMPORTANT BEFORE THE MAIN SPRINT PACKAGE IS USED WITH THESE C ROUTINES THE SETUP ROUTINE MATSET (........) MUST BE CALLED. C SUBROUTINE MATSET( LINALG, N, MU, ML, NWKJAC, NIWJAC, ISET) INTEGER LINALG, N, MU, ML, NWKJAC, NIWJAC, ISET C********************************************************************** C ROUTINE TO INITIALISE THE FULL AND BANDED MATRIX ROUTINES USED C BY THE SPRINT PACKAGE. C PARAMETER LIST C ---------------- C LINALG = 2 ; FULL MATRIX ROUTINES ARE BEING USED C = 1 ; BANDED MATRIX ROUTINES ARE IN USE. IN THIS CASE C ML IS THE LOWER HALF BANDWIDTH OF THE D.A.E. SYSTEM AND C MU IS THE UPPER HALF BANDWIDTH OF THE SYSTEM . BOTH C THESE PARAMETERS MUST BE SUPPLIED BY THE USER. C C N THE NUMBER OF ORDINARY DIFFERENTIAL AND /OR ALGEBRAIC C EQUATIONS BEING SOLVED. C NOTE IN THE CASE WHEN THIS NUMBER MAY CHANGE IN C ---- MID-INTEGRATION THIS SHOULD BE THE MAX NUMBER OF EQNS. C I.E. N = NMAX = MAX ( NEQ ). C NWKJAC ; THE SIZE OF THE REAL WORKSPACE SUPPLIED BY THE USER FOR C THE LINEAR ALGEBRA ROUTINES. C IN THE CASE WHEN THE BANDED OPTION IS USED ,LINALG = 1, C NWKJAC = (2*ML + MU + 1) * NMAX + 2 C IN THE CASE WHEN THE FULL MATRIX OPTION IS USED. C NWKJAC = NMAX * NMAX + 2 C WHERE NMAX IS THE LARGEST SIZE OF THE O.D.E. PROBLEM C DIMENSION (IF THIS MAY CHANGE IN MID-INTEGRATION) OTHER- C WISE NMAX = NEQ WHERE NEQ IS THE NUMBER OF ORDINARY C DIFFERENTIAL AND /OR ALGEBRAIC EQUATIONS. C NOTE IF THE O.D.E. PROBLEM DOES CHANGE IN MID-INTEGRATION AND C ---- THE BANDED OPTION IS BEING USED AND EITHER OR BOTH OF C THE UPPER AND LOWER BANDWIDTHS CHANGE THEN THIS SETUP C ROUTINE MUST BE RECALLED BEFORE INTEGRATION IS C RECOMMENCED. (THIS CALL CAN BE MADE FROM INSIDE A C MONITOR ROUTINE IF NEED BE.) C NIWJAC ; THE SIZE OF THE INTEGER WORKSPACE SUPPLIED BY THE USER C FOR THE LINEAR ALGEBRA ROUTINES. MUST BE OF SIZE >= NMAX C SEE ABOVE. C C ISET : ON ENTRY; ISET = 0 IMPLIES THAT THE JACOBIAN MATRIX IS TO BE C CALCULATED BY FINITE DIFFERENCING. C ISET = 1 IMPLIES THAT THE USER SUPPLIED FORM OF THE C JACOBIAN IS TO BE USED. C C OUTPUT PARAMETER; C ISET ON EXIT . ON EXIT IF ISET < 0 THEN EITHER ISET WAS 1 OR ONE C OF NIWJAC , NWKJAC IS TOO SMALL - AN ERROR MESSAGE IS C OUTPUT VIA THE ERROR HANDLING ROUTINE SERROR C********************************************************************** INTEGER MU1, ML1, I, ICALL CHARACTER*6 ALCODE, SINGLR COMMON /ALGCHK/ ALCODE,SINGLR COMMON /PASJB1/ MU1, ML1, ICALL SAVE /ALGCHK/, /PASJB1/ C ICALL = ISET SINGLR = 'SINGLR' IF(LINALG .EQ. 1) THEN MU1 = MU ALCODE = 'LPBAND' ML1 = ML I = (2*ML + MU + 1)*N + 2 IF(ML.LT.0.OR.ML.GT.N) ISET= -1 IF(MU.LT.0.OR.MU.GT.N) ISET= -1 IF(ISET .EQ.-1)THEN CALL SERROR(' MATSET- BANDWIDTHS MU (= I1) AND ML (=I2) ARE NOT 1 IN THE RANGE 0 TO N', 1, 2, MU, ML, 0, 0.0D0, 0.0D0) RETURN END IF ELSE IF (LINALG .EQ. 2) THEN I = N*N + 2 ALCODE = 'LPFULL' ELSE CALL SERROR(' SETUP ROUTINES FOR LINPACK FULL OR BAND 1 MATRICES- ILLEGAL VALUE OF LINALG (=I1)', 1, 1, LINALG, 2 0, 0, 0.0D0, 0.0D0) ISET = -1 END IF IF(I .GT. NWKJAC)THEN CALL SERROR(' SETUP ROUTINES FOR FULL OR BANDED MATRICES THE 1 REAL USER WORKSPACE OF LENGTH (=I1) IS SMALLER THAN NEEDED=I2' 2 , 1, 2, NWKJAC, I, 0, 0.0D0, 0.0D0) ISET = -1 END IF IF( NIWJAC .LT. N)THEN CALL SERROR(' SETUP ROUTINES FOR FULL OR BANDED MATRICES THE 1 INTEGER USER WORKSPACE OF LENGTH (=I1) IS SMALLER THAN NEEDED 2 (=I2)', 1, 2, NIWJAC, N, 0, 0.0D0, 0.0D0) ISET = -1 END IF RETURN END SUBROUTINE PREPJB (NEQ, Y, YH, NYH, EWT, RTEM, SAVR, YDOT, WM, 1 IWM, IFJ, H, EL0, TN, IFUNC, JAC, IDAE) C********************************************************************** INTEGER NEQ, NYH, IWM, IFJ, IFUNC, IDAE(1) INTEGER I, I1, I2, IER, II, J, J1, JJ, LENP, ICALL, 1 MBA, MBAND, MEB1, MEBAND, ML, ML3, MU, N, JZ INTEGER IOVFLO, ITRACE, IDEV DOUBLE PRECISION Y, YH, EWT, RTEM, SAVR, YDOT, WM, H, EL0, TN DOUBLE PRECISION DUNFLO, UROUND DOUBLE PRECISION CON, DI, FAC, HL0, R, R0, SRUR, YI, YJ, YJJ, 1 VNORM, FAC1 CHARACTER*6 ALCODE,SINGLR DIMENSION NEQ(1), Y(1), YH(NYH,1), EWT(1), RTEM(1), 1 YDOT(1), SAVR(1), WM(1), IWM(1) EXTERNAL JAC COMMON /SDEV2/ ITRACE,IDEV COMMON /ALGCHK/ ALCODE, SINGLR COMMON /SCONS1/ DUNFLO, UROUND, IOVFLO COMMON /PASJB1/ MU,ML, ICALL C C EXTRA COMMON BLOCK FOR REVERSE COMMUNICATION C COMMON /JBSAVE/ CON, DI, FAC, HL0, R, R0, SRUR, YI, YJ, YJJ, 1 I, I1, I2, IER, II, J, J1, JJ, LENP, MBA, MBAND, MEB1, 2 MEBAND, ML3, N SAVE /JBSAVE/, /ALGCHK/, /SCONS1/, /PASJB1/ C----------------------------------------------------------------------- C PREPJI IS CALLED BY SPRINT TO COMPUTE AND PROCESS THE JACOBIAN MATRIX C P = A - H*EL(1)*J. C HERE P IS COMPUTED BY DIFFERENCING OR BY A USER SUPPLIED ROUTINE. C P IS STORED IN WM, AND RESCALED. C P IS THEN SUBJECTED TO LU DECOMPOSITION IN PREPARATION C FOR LATER SOLUTION OF LINEAR SYSTEMS WITH P AS COEFFICIENT C MATRIX. THIS IS DONE BY THE LINPACK ROUTINE DGBFA C C IN ADDITION TO VARIABLES DESCRIBED PREVIOUSLY, COMMUNICATION C WITH PREPJI USES THE FOLLOWING.. C Y = ARRAY CONTAINING PREDICTED VALUES ON ENTRY. C RTEM = WORK ARRAY OF LENGTH N (ACOR IN SPRINT). C SAVR = ARRAY USED FOR OUTPUT ONLY. ON OUTPUT IT CONTAINS THE C RESIDUAL EVALUATED AT CURRENT VALUES OF T AND Y. C YDOT = ARRAY CONTAINING PREDICTED VALUES OF DY/DT . C WM = REAL WORK SPACE FOR MATRICES. ON OUTPUT IT CONTAINS THE C LU DECOMPOSITION OF P. C IWM = INTEGER WORK SPACE CONTAINING PIVOT INFORMATION. C H = CURRENT TIMESTEP . C TN = CURRENT TIME LEVEL. C EL0 = EL(1) (INPUT). C IFJ = OUTPUT ERROR FLAG C < 0 IF THE P MATRIX IS SINGULAR C = 0 IF THIS ROUTINE HAS SUCCESSFULLY FORMED THE JACOBIAN C > 0 IF THE EXIT FROM THIS ROUTINE IS A REVERSE COMMUNICATION C EXIT FOR A FUNCTION CALL TO RESID. C IFUNC INDICATOR TO DETERMINE MODE OF OPERATION OF THE ROUTINE. C = 1 EVALUATE THE JACOBIAN MATRIX NORMALLY C = 0 REVERSE COMMUNICATION ENTRY C C THIS ROUTINE ALSO USES THE COMMON VARIABLE UROUND. C----------------------------------------------------------------------- N = NEQ(1) C IF(IFJ.GT.0)GOTO 10 C C CHECK FOR ERRORS IN THE BANDWIDTHS C IF(ALCODE .NE. 'LPBAND')THEN CALL SERROR(' PREPJB-ERROR SETUP MODULE MATSET WAS NOT CALLED 1 PRIOR TO SPRINT BEING ENTERED', 1, 0, 0, 0, 0, 0.0D0, 0.0D0) IFJ = -2 RETURN END IF IF(ML.LT.0.OR.ML.GT.N) IFJ = -1 IF(MU.LT.0.OR.MU.GT.N) IFJ = -1 IF(IFJ .EQ.-1)THEN CALL SERROR(' PREPJB- BANDWIDTHS MU (= I1) AND ML (=I2) ARE NOT 1 IN THE RANGE 0 TO NEQ', 1, 2, MU, ML, 0, 0.0D0, 0.0D0) RETURN END IF C C INITIALISATION OF COMMON VARIABLES FOR THIS ROUTINE C ML3 = ML + 1 MBAND = ML + MU + 1 MEBAND = MBAND + ML HL0 = H*EL0 IF(ICALL .EQ. 1) THEN C ZERO MATRIX AND CALL ANALYTIC JAC ROUTINE. DO 8 I = 1,N Y(I) = YH(I,1) 8 YDOT(I) = YH(I,2)/H J = MEBAND * N DO 9 I = 1,J 9 WM(I) = 0.0D0 CALL JAC( NEQ, TN, Y, YDOT, H, EL0, ML, MU, WM(ML3), MEBAND) CALL BANDSC( WM(ML3), MEBAND, N, ML, MU, IDAE, H, EL0) IF(ITRACE .GE. 3)THEN WRITE(IDEV,91) 91 FORMAT(' DUMP OF ANAYTIC JACOBIAN (SCALED BY THE SYSTEM) ') MBA = MIN0( MBAND, N) DO 95 J = 1,MBA DO 95 JJ = J,N,MBAND I1 = MAX0(JJ-MU,1) I2 = MIN0(JJ+ML,N) II = JJ*MEB1 - ML DO 95 I = I1,I2 JZ = II + I IF(ABS(WM(JZ)) .GE. SRUR)WRITE(IDEV,93)I,JJ,WM(JZ) 93 FORMAT(' ROW',I3,' COL',I3,' OF JAC. IS',D11.3) 95 CONTINUE END IF GOTO 560 END IF SRUR = DSQRT(UROUND) C MAKE ML + MU + 2 CALLS TO RES TO APPROXIMATE J. -------- 10 MBA = MIN0(MBAND,N) C REVERSE COMMUNICATION JUMPS IF(IFJ.GT.0)GOTO 535 MEB1 = MEBAND - 1 FAC = VNORM (N, SAVR, EWT) R0 = 1000.0D0*DABS(H)*UROUND*N*FAC IF (R0 .EQ. 0.0D0) R0 = 1.0D0 IF(ITRACE .GE. 3)WRITE(IDEV,592) 592 FORMAT(' DUMP OF BANDED JACOBIAN MATRIX ') IFJ = 1 520 J = IFJ C DO 530 I = J,N,MBAND YI = YH(I,1) R = DMAX1(SRUR*DABS(YI),R0/EWT(I)) C THE FOLLOWING LINE BY M.BERZINS 3/12/83.REMOVE FOR HINDMARSH CODE. R = DMAX1(R,UROUND) Y(I) = YH(I,1) + R 530 YDOT(I) = YH(I,2)/H + R/HL0 RETURN C C REVERSE COMMUNICATION EXIT TO TIME MANAGEMENT SCHEME C 535 CONTINUE DO 550 JJ = J,N,MBAND YDOT(JJ) = YH(JJ,2)/H Y(JJ) = YH(JJ,1) YJJ = Y(JJ) R = DMAX1(SRUR*DABS(YJJ),R0/EWT(JJ)) C THE FOLLOWING LINE BY M. BERZINS 3/12/83. REMOVE FOR HINDMARSH CODE R = DMAX1(R, UROUND) FAC = -HL0/R FAC1 =-1.0D0/R I1 = MAX0(JJ-MU,1) I2 = MIN0(JJ+ML,N) II = JJ*MEB1 - ML DO 540 I = I1,I2 WM(II+I) = (RTEM(I)-SAVR(I))*(FAC*IDAE(I)+FAC1*(1-IDAE(I))) 540 CONTINUE 550 CONTINUE IF(ITRACE .GE. 3)THEN DO 555 JJ = J,N,MBAND I1 = MAX0(JJ-MU,1) I2 = MIN0(JJ+ML,N) II = JJ*MEB1 - ML DO 555 I = I1,I2 JZ = II + I IF( ABS(WM(JZ)) .GE. SRUR)WRITE(IDEV,539)I,JJ,WM(JZ) 539 FORMAT(' ROW',I3,' COL',I3,' OF JAC. IS',D11.3) 555 CONTINUE END IF IFJ = IFJ + 1 IF(IFJ.LE.MBA)GOTO 520 560 IFJ = 0 C C DO LU DECOMPOSITION OF P. -------------------------------------------- C SINGLR = 'NSING1' CALL DGBFA (WM, MEBAND, N, ML, MU, IWM, IER) IF (IER .NE. 0) THEN IFJ = -1 SINGLR = 'SINGLR' END IF RETURN C----------------------- END OF SUBROUTINE PREPJB ---------------------- END SUBROUTINE SOLSB (WM, IWM, X, N, IER) INTEGER IWM(1), N, IER INTEGER MEBAND, ML, MU, ICALL DOUBLE PRECISION WM(1), X(1) CHARACTER*6 ALCODE, SINGLR COMMON /ALGCHK/ ALCODE, SINGLR COMMON /PASJB1/ MU, ML, ICALL SAVE /PASJB1/, /ALGCHK/ C----------------------------------------------------------------------- C THIS ROUTINE MANAGES THE SOLUTION OF THE BANDED LINEAR SYSTEM ARISING C FROM A CHORD ITERATION . IT CALLS TH LINPACK ROUTINE DGBSL TO PERFORM C THE BACK SUBSTITUTION . C COMMUNICATION WITH SOLSY USES THE FOLLOWING VARIABLES.. C WM = REAL WORK SPACE CONTAINING LU DECOMPOSITION OF THE MATRIX C STORAGE OF MATRIX ELEMENTS STARTS AT WM(3). C WM ALSO CONTAINS THE FOLLOWING MATRIX-RELATED DATA.. C WM(1) = SQRT(UROUND) (NOT USED HERE), C WM(2) = HL0, THE PREVIOUS VALUE OF H*EL0, USED IF MITER = 3. C IWM = INTEGER WORK SPACE CONTAINING PIVOT INFORMATION, STARTING AT C IWM(21), IWM ALSO CONTAINS BAND PARAMETERS C ML = IWM(1) AND MU = IWM(2) . C X = THE RIGHT-HAND SIDE VECTOR ON INPUT, AND THE SOLUTION VECTOR C ON OUTPUT, OF LENGTH N. C IER = OUTPUT FLAG . IER = 0 IF NO TROUBLE OCCURRED. C IER = -1 OTHERWISE. C----------------------------------------------------------------------- IER = 0 IF(ALCODE .NE. 'LPBAND')THEN CALL SERROR(' SOLSB - ERROR ROUTINE MATSET WAS NOT CALLED PRIOR 1 TO SPRINT ENTRY', 1, 0, 0,0, 0, 0.0D0, 0.0D0) IER = -2 RETURN ELSE IF(SINGLR .NE. 'NSING1')THEN CALL SERROR(' SOLSB - ERROR- ROUTINE SOLSB CALLED TO BACK SUB 1 WITH SINGULAR JACOBIAN OR BEFORE JACOBIAN HAS BEEN 2 FORMED OR WHEN THE BANDED JACOBIAN ROUTINE PREPJB 3 WAS NOT SUPPLIED TO SPRINT', 1, 0, 0, 0, 0, 0.0D0, 4 0.0D0 ) IER = -2 RETURN END IF MEBAND = 2*ML + MU + 1 CALL DGBSL (WM, MEBAND, N, ML, MU, IWM, X, 0) RETURN C----------------------- END OF SUBROUTINE SOLSB ----------------------- END SUBROUTINE BANDSC( ABD, LDA, N, ML, MU, IDAE, H, EL0) C*********************************************************************** C ROUTINE TO SCALE THE ROWS OF THE MATRIX IN ABD BY 1/(H*EL0) C WHERE H* EL0 IS A FACTOR C*********************************************************************** INTEGER LDA, N, ML, MU, IDAE(1), I1, I2, I, J, K, M DOUBLE PRECISION ABD(LDA,1), H, EL0, EL0H EL0H = 1.0D0 / (EL0*H) M = ML + MU + 1 DO 20 J = 1, N I1 = MAX0(1, J-MU) I2 = MIN0(N, J+ML) DO 10 I = I1,I2 K = I-J+M 10 ABD(K,J) = -ABD(K,J) * (IDAE(I) + (1-IDAE(I))*EL0H ) 20 CONTINUE RETURN END SUBROUTINE PREPJF (NEQ, Y, YH, NYH, EWT, RTEM, SAVR, YDOT, WM, 1 IWM, IFJ, H, EL0, TN, IFUNC, JAC, IDAE) C*********************************************************************** INTEGER NEQ, NYH, IWM, IFJ, IFUNC, IDAE(1) INTEGER I, IER, II, J, J1, JJ, N, MU, ML, ICALL INTEGER IOVFLO, ITRACE, IDEV DOUBLE PRECISION Y, YH, EWT, RTEM, SAVR, YDOT, WM, H, EL0, TN DOUBLE PRECISION DUNFLO, UROUND DOUBLE PRECISION CON, DI, FAC, HL0, R, R0, SRUR, YI, YJ, YJJ, 1 VNORM, FAC1 CHARACTER*6 ALCODE, SINGLR DIMENSION NEQ(1), Y(1), YH(NYH,1), EWT(1), RTEM(1), 1 YDOT(1), SAVR(1), WM(1), IWM(1) EXTERNAL JAC COMMON /ALGCHK/ ALCODE, SINGLR COMMON /PASJB1/ MU, ML, ICALL COMMON /SDEV2/ ITRACE,IDEV COMMON /SCONS1/ DUNFLO, UROUND, IOVFLO C C EXTRA COMMON BLOCK FOR REVERSE COMMUNICATION C COMMON /JFSAVE/ CON, DI, FAC, HL0, R, R0, SRUR, YI, YJ, YJJ, 1 I, IER, II, J, J1, JJ, N SAVE /JFSAVE/, /SCONS1/, /ALGCHK/, /PASJB1/ C----------------------------------------------------------------------- C PREPJI IS CALLED BY SPRINT TO COMPUTE AND PROCESS THE MATRIX C P = A - H*EL(1)*J , WHERE J IS AN APPROXIMATION TO THE JACOBIAN DR/DY, C WHERE R = G(T,Y) - A(T,Y)*S. HERE J IS COMPUTED BY DIFFERENCING. C J IS STORED IN WM, AND RESCALED. C P IS THEN SUBJECTED TO LU DECOMPOSITION IN PREPARATION C FOR LATER SOLUTION OF LINEAR SYSTEMS WITH P AS COEFFICIENT C MATRIX. THIS IS DONE BY THE LINPACK ROUTINE DGEFA C C IN ADDITION TO VARIABLES DESCRIBED PREVIOUSLY, COMMUNICATION C WITH PREPJI USES THE FOLLOWING.. C Y = ARRAY CONTAINING PREDICTED VALUES ON ENTRY. C RTEM = WORK ARRAY OF LENGTH N (ACOR IN SPRINT). C SAVR = ARRAY USED FOR OUTPUT ONLY. ON OUTPUT IT CONTAINS THE C RESIDUAL EVALUATED AT CURRENT VALUES OF T AND Y. C YDOT = ARRAY CONTAINING PREDICTED VALUES OF DY/DT . C WM = REAL WORK SPACE FOR MATRICES. ON OUTPUT IT CONTAINS THE C LU DECOMPOSITION OF P. C IWM = INTEGER WORK SPACE CONTAINING PIVOT INFORMATION. C H = CURRENT TIMESTEP . C TN = CURRENT TIME LEVEL. C EL0 = EL(1) (INPUT). C IFJ = OUTPUT ERROR FLAG C < 0 IF THE P MATRIX IS SINGULAR C = 0 IF THIS ROUTINE HAS SUCCESSFULLY FORMED THE JACOBIAN C > 0 IF THE EXIT FROM THIS ROUTINE IS A REVERSE COMMUNICATION C EXIT FOR A FUNCTION CALL TO RESID. C IFUNC INDICATOR TO DETERMINE MODE OF OPERATION OF THE ROUTINE. C = 1 EVALUATE THE JACOBIAN MATRIX NORMALLY C = 0 REVERSE COMMUNICATION EXIT AND ENTRY. C THIS ROUTINE ALSO USES THE COMMON VARIABLE UROUND. C----------------------------------------------------------------------- N = NEQ(1) IF(IFJ.GT.0)GOTO 535 IF(ALCODE .NE. 'LPFULL')THEN CALL SERROR(' PREPJF ERROR- SETUP MODULE MATSET WAS NOT CALLED 1 PRIOR TO THE SPRINT ENTRY', 1, 0, 0, 0, 0, 0.0D0, 0.0D0) IFJ = -2 RETURN END IF C C INITIALISATION OF COMMON VARIABLES FOR THIS ROUTINE C HL0 = H*EL0 SRUR = DSQRT(UROUND) IF(ICALL .EQ. 1) THEN C ZERO THE MATRIX AND CALL THE ANALYTIC JAC ROUTINE DO 8 I = 1,N Y(I) = YH(I,1) 8 YDOT(I) = YH(I,2)/H J = N * N DO 9 I = 1,J 9 WM(I) = 0.0D0 CALL JAC( NEQ, TN, Y, YDOT, H, EL0, ML, MU, WM, N) CALL FULLSC( WM, N, N, IDAE, H, EL0) C IF(ITRACE .GE. 3)THEN WRITE(IDEV,92) 92 FORMAT(' DUMP OF ANALYTIC JACOBIAN (SCALED BY THE SYSTEM)') DO 94 J = 1,N DO 94 I = 1,N J1 = (J-1) * N + I R = DABS(WM(J1)) IF(R .GT. UROUND)WRITE(IDEV,93)I,J,WM(J1) 93 FORMAT(' ROW ',I4,' COL',I4,' OF JAC = ',D11.3) 94 CONTINUE END IF GOTO 550 END IF C MAKE N CALLS TO RES TO APPROXIMATE J. -------- FAC = VNORM (N, SAVR, EWT) R0 = 1000.0D0*DABS(H)*UROUND*N*FAC IF (R0 .EQ. 0.0D0) R0 = 1.0D0 II = 0 IF(ITRACE .GE. 3)WRITE(IDEV,592) 592 FORMAT(' DUMP OF FULL JACOBIAN MATRIX (SCALED BY THE SYSTEM)') IFJ = 1 520 I = IFJ YI = Y(I) R = DMAX1(SRUR*DABS(YI),R0/EWT(I)) C THE FOLLOWING LINE BY M.BERZINS 2/12/83. REMOVE FOR HINDMARSH CODE. R = DMAX1(R,UROUND) Y(I) = YH(I,1) + R YDOT(I) = YH(I,2)/H + R/HL0 RETURN C C REVERSE COMMUNICATION EXIT TO TIME MANAGEMENT SCHEME C 535 JJ = IFJ YDOT(JJ) = YH(JJ,2)/H Y(JJ) = YH(JJ,1) YJJ = Y(JJ) R = DMAX1(SRUR*DABS(YJJ),R0/EWT(JJ)) C THE FOLLOWING LINE BY M.BERZINS 3/12/83. REMOVE FOR HINDMARSH CODE. R = DMAX1( R, UROUND) FAC = -HL0/R FAC1= -1.0D0/R DO 540 I = 1,N WM(II+I) = (RTEM(I)-SAVR(I))*(FAC*IDAE(I)+FAC1*(1-IDAE(I))) 540 CONTINUE IF(ITRACE .GE. 3)THEN DO 545 I = 1,N J1 = II + I R = DABS(WM(J1)) IF(R .GT. UROUND)WRITE(IDEV,539)I,IFJ,WM(J1) 539 FORMAT(' ROW ',I4,' COL',I4,' OF JAC = ',D11.3) 545 CONTINUE END IF II = II + N IFJ = IFJ + 1 IF(IFJ .LE. N)GOTO 520 550 IFJ = 0 C C DO LU DECOMPOSITION OF P. -------------------------------------------- C SINGLR = 'NSING2' CALL DGEFA (WM, N, N, IWM, IER) IF (IER .NE. 0) THEN IFJ = -1 IF(ITRACE .GE. 1)WRITE(IDEV,999)IER 999 FORMAT(' PIVOT ON ROW AND COL ',I5,' IS ZERO ') SINGLR = 'SINGLR' END IF RETURN C----------------------- END OF SUBROUTINE PREPJB ---------------------- END SUBROUTINE SOLSF (WM, IWM, X, N, IER) INTEGER IWM(1), N, IER DOUBLE PRECISION WM(1), X(1) CHARACTER*6 ALCODE, SINGLR COMMON /ALGCHK/ ALCODE, SINGLR SAVE /ALGCHK/ C----------------------------------------------------------------------- C THIS ROUTINE MANAGES THE SOLUTION OF THE BANDED LINEAR SYSTEM ARISING C FROM A CHORD ITERATION . IT CALLS THE LINPACK ROUTINE DGESL TO PERFORM C THE BACK SUBSTITUTION . C COMMUNICATION WITH SOLSY USES THE FOLLOWING VARIABLES.. C WM = REAL WORK SPACE CONTAINING LU DECOMPOSITION OF THE MATRIX C STORAGE OF MATRIX ELEMENTS STARTS AT WM(3). C IWM = INTEGER WORK SPACE CONTAINING PIVOT INFORMATION, STARTING AT C IWM(1). C X = THE RIGHT-HAND SIDE VECTOR ON INPUT, AND THE SOLUTION VECTOR C ON OUTPUT, OF LENGTH N. C IER = OUTPUT FLAG . IER = 0 IF NO TROUBLE OCCURRED. C IER = -1 OTHERWISE. C----------------------------------------------------------------------- IF(ALCODE .NE. 'LPFULL')THEN CALL SERROR(' SOLSF - ERROR MATSET SETUP ROUTINE WAS NOT CALLED 1 PRIOR TO THE SPRINT ENTRY', 1, 0, 0, 0, 0, 0.0D0, 0.0D0) IER = -2 RETURN ELSE IF( SINGLR .NE. 'NSING2')THEN CALL SERROR(' SOLSF - ERROR-BACK SUBSTITUTION TRIED WITH EITHER 1 SINGULAR MATRIX OR WHEN THE JACOBIAN HAS NOT BEEN 2 FORMED OR WHEN SPRINT WAS NOT CALLED WITH THE 3 JACOBIAN FORMING ROUTINE PREPJF', 1, 0, 0, 0, 0, 4 0.0D0, 0.0D0) IER = -2 RETURN END IF IER = 0 CALL DGESL (WM, N, N, IWM, X, 0) RETURN C----------------------- END OF SUBROUTINE SOLSB ----------------------- END SUBROUTINE FULLSC( A, LDA, N, IDAE, H, EL0) C*********************************************************************** C ROUTINE TO SCALE THE FULL MATRIX A(LDA,N) BY THE FACTOR C (H*EL0)**(-1) WHERE POSSIBLE C*********************************************************************** INTEGER LDA, N, IDAE(1), I, J DOUBLE PRECISION A(LDA,1), H, EL0, EL0H EL0H = 1.0D0 / (EL0* H) DO 100 J = 1,N DO 100 I = 1,N 100 A(I,J) = -A(I,J) * (IDAE(I) + (1-IDAE(I)) * EL0H ) RETURN END SUBROUTINE DGEFA(A,LDA,N,IPVT,INFO) INTEGER LDA,N,IPVT(1),INFO DOUBLE PRECISION A(LDA,1) C C DGEFA FACTORS A DOUBLE PRECISION MATRIX BY GAUSSIAN ELIMINATION. C C DGEFA IS USUALLY CALLED BY DGECO, BUT IT CAN BE CALLED C DIRECTLY WITH A SAVING IN TIME IF RCOND IS NOT NEEDED. C (TIME FOR DGECO) = (1 + 9/N)*(TIME FOR DGEFA) . C C ON ENTRY C C A DOUBLE PRECISION(LDA, N) C THE MATRIX TO BE FACTORED. C C LDA INTEGER C THE LEADING DIMENSION OF THE ARRAY A . C C N INTEGER C THE ORDER OF THE MATRIX A . C C ON RETURN C C A AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS C 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 DGESL OR DGEDI WILL DIVIDE BY ZERO C IF CALLED. USE RCOND IN DGECO FOR A RELIABLE C INDICATION OF SINGULARITY. 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 C INTERNAL VARIABLES C DOUBLE PRECISION T INTEGER IDAMAX,J,K,KP1,L,NM1 C C C GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING C INFO = 0 NM1 = N - 1 IF (NM1 .LT. 1) GO TO 70 DO 60 K = 1, NM1 KP1 = K + 1 C C FIND L = PIVOT INDEX C L = IDAMAX(N-K+1,A(K,K),1) + K - 1 IPVT(K) = L C C ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED C IF (A(L,K) .EQ. 0.0D0) GO TO 40 C C INTERCHANGE IF NECESSARY C IF (L .EQ. K) GO TO 10 T = A(L,K) A(L,K) = A(K,K) A(K,K) = T 10 CONTINUE C C COMPUTE MULTIPLIERS C T = -1.0D0/A(K,K) CALL DSCAL(N-K,T,A(K+1,K),1) C C ROW ELIMINATION WITH COLUMN INDEXING C DO 30 J = KP1, N T = A(L,J) IF (L .EQ. K) GO TO 20 A(L,J) = A(K,J) A(K,J) = T 20 CONTINUE CALL DAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1) 30 CONTINUE GO TO 50 40 CONTINUE INFO = K 50 CONTINUE 60 CONTINUE 70 CONTINUE IPVT(N) = N IF (A(N,N) .EQ. 0.0D0) INFO = N RETURN END SUBROUTINE DGESL(A,LDA,N,IPVT,B,JOB) INTEGER LDA,N,IPVT(1),JOB DOUBLE PRECISION A(LDA,1),B(1) C C DGESL SOLVES THE DOUBLE PRECISION SYSTEM C A * X = B OR TRANS(A) * X = B C USING THE FACTORS COMPUTED BY DGECO OR DGEFA. C C ON ENTRY C C A DOUBLE PRECISION(LDA, N) C THE OUTPUT FROM DGECO OR DGEFA. C C LDA INTEGER C THE LEADING DIMENSION OF THE ARRAY A . C C N INTEGER C THE ORDER OF THE MATRIX A . C C IPVT INTEGER(N) C THE PIVOT VECTOR FROM DGECO OR DGEFA. 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 DGECO HAS SET RCOND .GT. 0.0 C OR DGEFA HAS SET INFO .EQ. 0 . C C TO COMPUTE INVERSE(A) * C WHERE C IS A MATRIX C WITH P COLUMNS C CALL DGECO(A,LDA,N,IPVT,RCOND,Z) C IF (RCOND IS TOO SMALL) GO TO ... C DO 10 J = 1, P C CALL DGESL(A,LDA,N,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 C INTERNAL VARIABLES C DOUBLE PRECISION DDOT,T INTEGER K,KB,L,NM1 C 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 (NM1 .LT. 1) GO TO 30 DO 20 K = 1, NM1 L = IPVT(K) T = B(L) IF (L .EQ. K) GO TO 10 B(L) = B(K) B(K) = T 10 CONTINUE CALL DAXPY(N-K,T,A(K+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)/A(K,K) T = -B(K) CALL DAXPY(K-1,T,A(1,K),1,B(1),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 T = DDOT(K-1,A(1,K),1,B(1),1) B(K) = (B(K) - T)/A(K,K) 60 CONTINUE C C NOW SOLVE TRANS(L)*X = Y C IF (NM1 .LT. 1) GO TO 90 DO 80 KB = 1, NM1 K = N - KB B(K) = B(K) + DDOT(N-K,A(K+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 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 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 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 DOUBLE PRECISION DA,DX(1) INTEGER I,INCX,M,MP1,N,NINCX C IF(N.LE.0)RETURN IF(INCX.EQ.1)GO TO 20 C C CODE FOR INCREMENT NOT EQUAL TO 1 C NINCX = N*INCX DO 10 I = 1,NINCX,INCX DX(I) = DA*DX(I) 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 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 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 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 DMAX = DABS(DX(1)) 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