C      ALGORITHM 689, COLLECTED ALGORITHMS FROM ACM.
C      THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE,
C      VOL. 17, NO. 2, PP. 167-177.  JUNE, 1991.
 FILE_1: THIS INFO.
 FILE_2: SUBROUTINE COLDOC: DOCUMENTATION OF "COLVI2".
 FILE_3: SUBPROGRAMS OF "COLVI2"; "SOLVING" ROUTINES.
 FILE_4: SUBPROGRAMS OF "COLVI2"; "INITIALIZING" ROUTINES.
 FILE_5: SUBPROGRAMS OF "COLVI2"; "UTILITIES".
 FILE_6: SYSTEM DEPENDENT SUBPROGRAMS OF "COLVI2":
         SAVALL _ SAVE, IN CASE OF ERROR DURING COMPUTATIONAL PROCESS, ALL
                  NEEDED VARIABLES ON A SEQUENTIAL UNFORMATTED FILE "COLSAV".
         RELOAD _ RELOAD VARIABLES WRITTEN BY "SAVALL" TO CONTINUE
                  COMPUTATIONAL PROCESS AFTER ERRATIC EXIT.
         NCPJOB _ MONITOR THE CPU-TIME (CDC CYBER-750 VERSION).
         NCPJOB _                      (VAX VERSION).
         INICMC _ INITIALIZE MACHINE CONSTANTS (CALLS "MACHAR" FROM W.J.CODY).
 FILE_7: ENVIRONMENT DEPENDENT SUBPROGRAMS OF "COLVI2" THAT INVOKE
         IMSL LIBRARY ROUTINES.
         DECLUF _ DECOMPOSE A MATRIX.
         SOLLUF _ SOLVE A LINEAR SYSTEM USING THE MATRIX DECOMPOSED BY DECLUF.
         ZERPOL _ COMPUTE REAL ZEROS OF A POLYNOMIAL.
 FILE_8: SAME AS ABOVE BUT FOR USE ON A MACHINE WITHOUT NUMERICAL LIBRARIES.
         ZERPOL CALLS THE (INCORPORATED) ACM-TOMS ROUTINE "RPOLY".
 FILE_9: MACHAR ROUTINE (REVISION DECEMBER 4, 1987) FROM W.J.CODY TO
         COMPUTE SOME MACHINE CONSTANTS. (MUST BE MODIFIED BEFORE COMPILING).
 FILE10: THREE UTILITY SUBROUTINES USED BY THE DRIVER PROGRAMS.
 FILE11: SUBROUTINES DEFINING THE VIE2 FOR PASS 1 - PASS 10.
         DRIVER PROGRAM PASS 1 - 6.
         DRIVER PROGRAM PASS 7 - 8.
         DRIVER PROGRAM PASS 9.
         DRIVER PROGRAM PASS 10 (RESUMING INTERRUPTED PASS 9).
         DRIVER PROGRAM PASS 11 + PROBLEM ROUTINES.
         DRIVER PROGRAM PASS 12 (RESUMING INTERRUPTED PASS 11).
 FILE12: OUTPUT PASS 1 - 6.
         OUTPUT PASS 7 - 8.
         OUTPUT PASS 9.
         OUTPUT PASS 10.
         OUTPUT PASS 11.
         OUTPUT PASS 12.
         N.B. RESULTS ARE OBTAINED ON A CYBER 750 (MACHINE PRECISION
              APPROXIMATELY 14 DIGITS).

 ------------------------------------------------------------------------

 LIST OF SUBPROGRAM NAMES IN "COLVI2" + PARAMETER LIST
            (IN LEXICOGRAPHICAL ORDER).

       SUBROUTINE ADDABM (A, IA, IO, JO, N, S, B, IB)
       SUBROUTINE ADDABV (V, N, S, W)
       SUBROUTINE ADDV (V, N, S1, W1, S2, W2)
       SUBROUTINE ADJLSV (TN, HN, NEQN, KC, C,W, UN, LAGSAV)
       SUBROUTINE CHKFIL (CNTRL, IERROR)
       SUBROUTINE CHKINI
      +   (NEQN,G, T0,TE, REQTOL, DEFOPT,IOPT,OPT,CNTRL, WKAREA,IW,
      +    TN, HINIT, ZLEESM, IERROR)
       SUBROUTINE CHKOPT (CNTRL, IOPT, OPT, MCDEF, HMINFX, IERROR)
       SUBROUTINE CHKPTO (NEQN, TN, TE, REQTOL, TOLMIN, IERROR)
       SUBROUTINE CHKREC (IOPT, MCDEF, IERROR)
       SUBROUTINE CHKWKA (IW, TN, TE, HFX, IWCONS, IWSTEP, IERROR)
       SUBROUTINE COLCWL (COLPAR, M, C, W, LC, IERROR)
       SUBROUTINE COLDOC
       SUBROUTINE COLVI2
      +   (NEQN, G,KC,DKCDY,LINEAR, T0,TE, REQTOL,
      +    DEFOPT, IOPT,OPT,CNTRL, WKAREA,IW, TNC, UE, GEE, IERROR)
       SUBROUTINE COMPLG (M, C, LCG, WKAREA)
       SUBROUTINE COMPLV (V, M, C, LCV)
       SUBROUTINE COMPUH (T, NEQN, T0, WKAREA, UH)
       SUBROUTINE COMPWL (M, S, L, C, W, LC)
       SUBROUTINE COPYV (V, N, W)
       SUBROUTINE DECLUF (A, N, IA, P, IERROR)
       SUBROUTINE DISWKS
      +   (NEQN, NHC, RENTRY, NEWOPT, ZLEESM, WKAREA, IW, GECO, MAXNCO)
       SUBROUTINE ERRMSG (STRING)
       SUBROUTINE ESCRGS (NEQN, WKAREA,IW, T0,TE, TN, IERROR)
       SUBROUTINE GAUSSC (M, C, P0, P1, IERROR)
       SUBROUTINE GAUSS (M, C, WKAREA, IERROR)
       SUBROUTINE INICMC
       SUBROUTINE INILAG
      +   (TN, NEQN,G,KC, C,W,LC,LOBAT, H, U, WKAREA, LAGSAV)
       SUBROUTINE INILGN (TN, NEQN, G, U, LC1, WKAREA, LAGN)
       SUBROUTINE INIVEC
      +   (IU,IURG,IURL,IURN,ILEESM, NEQN, G, TN, TE, U,UR,URN,LEESUM)
       REAL FUNCTION INTEGL (J, U, M, C, WKAREA)
       SUBROUTINE ITRCOL
      +   (TNP1, NEQN, G, KC, T0, H, C, W, U, WKAREA, LAGNP1, URNP1)
       REAL FUNCTION LAGPOL (J, V, M, C)
       REAL FUNCTION LEEWGT
      +   (TN,HN, NEQN,KC, T0, C,W, CR,WR, UN, URN, WKAREA)
       SUBROUTINE LOBATC (M, C, P0, P1, IERROR)
       SUBROUTINE LOBATO (M, C, WKAREA, IERROR)
       INTEGER FUNCTION NCPJOB ()
       SUBROUTINE RADAUC (M, C, P0, P1, IERROR)
       SUBROUTINE RADAU (M, C, WKAREA, IERROR)
       SUBROUTINE RELOAD
      +   (NSAV, WKAREA,IW, DEFOPT,IOPT,OPT, TE, TN, IERROR)
       SUBROUTINE SAVALL (WKAREA,IW, DEFOPT, IOPT,OPT, TE, TN)
       SUBROUTINE SGEVI2
      +   (NEQN, G,KC,DKCDY,LINEAR, T0, CR,WR,LCR, H, UR, WKAREA,
      +    TN, URN, IERROR)
       SUBROUTINE SLICE2
      +   (TN,HNM1,HN, NEQN,G,KC,DKCDY,LINEAR, C, CB, CR,WR,LCR,LOBATR,
      +    LAGSAV, GLAGR,CORR,DSYS,MW, WKAREA, URN, IERROR)
       SUBROUTINE SLQCE2
      +   (TN, H, NEQN,G,KC,DKCDY,LINEAR, T0, C,W,LC, MM,SS,LL, LOBAT,
      +    TOLCIT, LNP1FL, LAG, GLAG,CORR,DSYS,MW, WKAREA, U, LAGNP1,
      +    IERROR)
       SUBROUTINE SOLLUF (A, N, IA, B, P)
       SUBROUTINE SOLNEW
      +   (TN,HN, NEQN,KC,DKCDY,LINEAR, C,W,LC, MM,SS,LL, TOLCIT,
      +    GLAG, CORR,DSYS,MW, WKAREA, UN, IERROR)
       SUBROUTINE SOLSYS
      +   (TN,HN, NEQN,KC,DKCDY,LINEAR, C,W,LC, MM,SS,LL, TOLCIT,
      +    GLAG, CORR,DSYS,MW, WKAREA, UN, IERROR)
       SUBROUTINE SOLVI2
      +   (NEQN, G,KC,DKCDY,LINEAR, T0,TE, C,W,LC, H, U, CR,WR,LCR, UR,
      +    LAG,  LAGSAV, LEESUM,ESTGEE,LEE, LC1, LC0,LCG,UN2,LAGN,LAGNP1
      +    URN, URNP1, WKAREA, TN, UN, GEE, IERROR)
       REAL FUNCTION UEEWGT
      +   (TN,HN, NEQN,KC, T0,TE, C,W, CR,WR, UN, URN,
      +    LEESUM, ESTGEE, WKAREA, LEE)
       SUBROUTINE UNITM (A, N)
       SUBROUTINE UTILIP (NEQN, UI, LC1, UIP1)
       REAL FUNCTION WMXNRM (ERR, SOL, NDIM)
       SUBROUTINE WRIRES (TN, HN, YNP1, UNP1, NEQN, Y)
       LOGICAL FUNCTION YPOLM
      +   (TN,HN, NEQN,G,KC,DKCDY,LINEAR, C,W,LC, LCG,LC0,
      +    LAGN,LAG,LAGNP1, UN2, NYPOLM, GLAG2,CORR,DSYS,MW, WKAREA,
      +    UN, URN, IERROR)
       SUBROUTINE ZEROV (V, N)
       SUBROUTINE ZERPOL (C, N, S, IERROR)
*
 -----------------------------------------------------------------------
      SUBROUTINE COLDOC
C
C -------------------------------------------------------------------- I
C                                                                      I
C HISTORY: 86/06/20: DATE WRITTEN.                                     I
C =======  88/10/29: REVISION TOMS.                                    I
C                                                                      I
C -------------------------------------------------------------------- I
C -------------------------------------------------------------------- I
C                                                                      I
C                    DOCUMENTATION OF COLVI2                           I
C                                                                      I
C -------------------------------------------------------------------- I
C                                                                      I
C     SUBROUTINE COLVI2                                                I
C    +   (NEQN, G,KC,DKCDY,LINEAR, T0,TE, REQTOL,                      I
C    +    DEFOPT, IOPT,OPT,CNTRL, WKAREA,IW, TNC, UE, GEE, IERROR)     I
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
C     INTEGER NEQN, DEFOPT, IW, IERROR                                 I
C     INTEGER IOPT(*), CNTRL(*)                                        I
C     LOGICAL LINEAR                                                   I
C     REAL T0, TE, REQTOL, TNC                                         I
C     REAL OPT(*), WKAREA(IW), UE(NEQN), GEE(NEQN)                     I
C     EXTERNAL G, KC, DKCDY                                            I
C                                                                      I
C -------------------------------------------------------------------- I
C                                                                      I
C LANGUAGE: FORTRAN 77                                                 I
C ========                                                             I
C -------------------------------------------------------------------- I
C                                                                      I
C PURPOSE:                                                             I
C =======                                                              I
C SOLVE THE (SYSTEM OF) VOLTERRA INTEGRAL EQUATION(S) OF THE SECOND    I
C KIND (VIE2)                                                          I
C                     T                                                I
C      Y(T) = G(T) + INT K(T,S,Y(S)) DS,   T IN [T0,TE].               I
C                     T0                                               I
C                                                                      I
C THE VIE2 IS APPROXIMATED BY A SYSTEM OF DISCRETIZED COLLOCATION      I
C EQUATIONS; THIS SYSTEM IS SOLVED BY AN ITERATION PROCESS THAT IS BY  I
C USER'S CHOICE FUNCTIONAL ITERATION OR NEWTON'S METHOD.               I
C                                                                      I
C IN THE ITERATIVE SOLUTION PROCESS EITHER A FIXED, USER-DEFINED       I
C OR A VARIABLE STEPSIZE IS USED. IN THE LATTER CASE AN ATTEMPT IS     I
C MADE TO KEEP THE GLOBAL ERROR IN "TE" LIMITED TO A PRESCRIBED        I
C TOLERANCE.                                                           I
C FOR INFORMATION ON THE COLLOCATION SCHEMES, THE ERROR ESTIMATION AND I
C STEPSIZE STRATEGY SEE:                                               I
C   BLOM, J.G. AND BRUNNER, H.,                                        I
C   "THE NUMERICAL SOLUTION OF NONLINEAR VOLTERRA INTEGRAL EQUATIONS   I
C   OF THE SECOND KIND BY COLLOCATION AND ITERATED COLLOCATION METHODS"I
C   SIAM J. SCI. STATIST. COMPUT. 8, 806-830 (1987).                   I
C AND                                                                  I
C   "DISCRETIZED COLLOCATION AND ITERATED COLLOCATION FOR NONLINEAR    I
C   VOLTERRA INTEGRAL EQUATIONS OF THE SECOND KIND", REPORT NM-R8618,  I
C   CWI, AMSTERDAM, 1986. (TO APPEAR IN ACM TOMS).                     I
C                                                                      I
C -------------------------------------------------------------------- I
C                                                                      I
C HOW TO USE:                                                          I
C ==========                                                           I
C INVOKE VIA A CALL OF THE SUBROUTINE "COLVI2". THE INPUT PARAMETERS   I
C ARE CHECKED ON LEGITIMACY AND CONSISTENCY; ERROR MESSAGES ARE        I
C WRITTEN TO A FILE (CF. PARAMETER "CNTRL(2)").                        I
C "COLVI2" OFFERS TWO DEFAULT SOLVERS FOR WHICH THE USER NEEDS TO      I
C SPECIFY ONLY THE PROBLEM DEPENDENT FUNCTIONS AND VARIABLES (PARAM-   I
C ETERS "NEQN" TO "TE"), THE REQUIRED TOLERANCE ("REQTOL"), THE PARAM- I
C ETER "DEFOPT" TO SPECIFY THE SOLVER, WORKING STORAGE "WKAREA" OF     I
C SIZE "IW", AND THE OUTPUT PARAMETERS "TNC" TO "IERROR". ("IOPT",     I
C "OPT" AND "CNTRL" CAN BE DUMMY VARIABLES)                            I
C                                                                      I
C PARAMETERS:                                                          I
C ----------                                                           I
C NEQN   DIMENSION OF THE SYSTEM OF VOLTERRA INTEGRAL EQUATIONS.       I
C G      SUBROUTINE G(T,GV); REAL T, GV(NEQN).                         I
C        EVALUATES THE FORCING TERM "G" OF THE VIE2 IN "T". THE SECOND I
C        ARGUMENT OF THE SUBROUTINE IS AN ARRAY IN WHICH THE VALUE OF  I
C        THE VECTOR "G(T)" SHOULD BE STORED.                           I
C        SHOULD BE DECLARED IN AN EXTERNAL STATEMENT IN THE CALLING    I
C        PROGRAM.                                                      I
C KC     SUBROUTINE KC(T,S,Y,KV); REAL T,S, Y(NEQN),KV(NEQN).          I
C        EVALUATES THE KERNEL "K" OF THE VIE2 IN "(T,S,Y)". THE LAST   I
C        ARGUMENT OF THE SUBROUTINE IS AN ARRAY IN WHICH THE VALUE OF  I
C        THE VECTOR "K(T,S,Y)" SHOULD BE STORED.                       I
C        SHOULD BE DECLARED EXTERNAL IN THE CALLING PROGRAM.           I
C DKCDY  SUBROUTINE DKCDY(T,S,Y,DKV); REAL T,S, Y(NEQN),DKV(NEQN,NEQN).I
C        EVALUATES IN THE POINT "(T,S,Y)" THE JACOBIAN OF THE KERNEL   I
C        W.R.T ITS THIRD ARGUMENT. THE LAST ARGUMENT OF THE SUBROUTINE I
C        IS A TWO-DIMENSIONAL ARRAY IN WHICH THE JACOBIAN SHOULD BE    I
C        STORED; I.E., DKV(I,J) = DK_I/DY_J (T,S,Y) .                  I
C        SHOULD BE DECLARED EXTERNAL IN THE CALLING PROGRAM.           I
C        ONLY NEEDED IF NEWTON'S METHOD IS USED TO SOLVE THE SYSTEM OF I
C        COLLOCATION EQUATIONS; IF FUNCTIONAL ITERATION IS USED A      I
C        DUMMY ROUTINE SUFFICES.                                       I
C LINEAR LOGICAL VALUE.                                                I
C        "TRUE" INDICATES THAT THE KERNEL IS A LINEAR FUNCTION W.R.T.  I
C        ITS THIRD ARGUMENT. NOT USED IF FUNCTIONAL ITER. IS EMPLOYED. I
C T0     REAL VALUE.                                                   I
C        LEFT ENDPOINT OF THE INTEGRATION INTERVAL.                    I
C TE     REAL VALUE.                                                   I
C        RIGHT ENDPOINT OF THE INTEGRATION INTERVAL.                   I
C REQTOL REAL VALUE.                                                   I
C        REQUESTED TOLERANCE FOR GLOBAL ERROR (NOT USED IN CASE OF     I
C        CONSTANT STEPSIZES).                                          I
C DEFOPT INTEGER VALUE.                                                I
C         0: USE NO DEFAULT SOLVERS,                                   I
C        ?1: GAUSS 8  +  ITERATED GAUSS COLLOCATION;                   I
C            ESCAPE IN CASE SOLUTION IS A POLYNOMIAL OF DEGREE < 8  TO:I
C            GAUSS 8  +  [GAUSS 9 + (C10=1)]  WITH                     I
C            LOCAL + UNIFORM ERROR CONTROL,                            I
C        ?2: LOBATTO 6  +  LOBATTO 7  WITH                             I
C            GLOBAL AND UNIFORM ERROR CONTROL,                         I
C        WHERE "?" INDICATES THE METHOD OF CORRECTOR ITERATION:        I
C           0: NEWTON'S METHOD; UPDATE JACOBIAN EACH NEWTON ITERATION, I
C           1: NEWTON'S METHOD; EVALUATE JACOBIAN ONCE PER STEP,       I
C           2: FUNCTIONAL ITERATION (NO "DKCDY" NEEDED!).              I
C        IF DEFOPT > 0, THE DEFAULTS FOR "IOPT", "OPT" AND "CNTRL"     I
C        VALUES ARE USED (IN SOFAR NOT CONTRADICTING THE ABOVE).       I
C        IN THIS CASE THESE VECTORS ARE NOT USED SO THERE ARE NO       I
C        RESTRAINTS WITH RESPECT TO THE VALUE OR THE LENGTH OF THESE   I
C        ARRAYS.                                                       I
C IOPT   INTEGER VALUED OPTION VECTOR OF LENGTH AT MOST 9 (TRUE LENGTH I
C        DEPENDENT ON "DEFOPT", RESP. IOPT(2), IOPT(3));               I
C        (0): DEFAULT VALUES.                                          I
C        1. KIND AND NUMBER OF COLLOCATION POINTS.                     I
C           0: 8 POINT GAUSS COLLOCATION (ORDER = 8),                  I
C           OTHER: VALUE WITH DECIMAL EXPANSION "MC",                  I
C              WHERE "C" SPECIFIES THE KIND AND "M" THE # OF           I
C                  COLLOCATION POINTS.                                 I
C              C    COLL. POINTS                M        GLOBAL ORDER  I
C              1        GAUSS                 2<=M            M        I
C              2  (M-1) GAUSS + (CM=1)        3<=M          2M-2       I
C              3       LOBATTO                2<=M          2M-2       I
C              4        RADAU                 2<=M          2M-1       I
C        2. STEPSIZE CHOICE.                                           I
C           0: VARIABLE STEPSIZE,                                      I
C           1: FIXED STEPSIZE.                                         I
C        3. GLOBAL ERROR IN ENDPOINT REQUIRED?                         I
C           0: GLOBAL ERROR ESTIMATION IN "TE",                        I
C           1: NO GLOBAL ERROR ESTIMATION.                             I
C        4. DEFINES ERROR WEIGHTS.                                     I
C           0: MIXED ERROR (1 / MAX(1.0,!SOL!)),                       I
C           1: ABSOLUTE ERROR (1.0),                                   I
C           2: RELATIVE ERROR (1 / !SOL!).                             I
C        5. INDICATES METHOD OF CORRECTOR ITERATION IN THE PROCESS OF  I
C           SOLVING THE SYSTEM OF COLLOCATION EQUATIONS.               I
C           0: NEWTON'S METHOD; UPDATE JACOBIAN EACH NEWTON ITERATION, I
C           1: NEWTON'S METHOD; EVALUATE JACOBIAN ONCE PER STEP,       I
C           2: FUNCTIONAL ITERATION (NO "DKCDY" NEEDED!).              I
C        6. MAXIMUM # KERNEL EVALUATIONS ALLOWED.                      I
C           0: NO MAXIMUM.                                             I
C        7. MAXIMUM # CPU-SECONDS ALLOWED.                             I
C           0: NO MAXIMUM.                                             I
C        8. KIND AND NUMBER OF COLLOCATION POINTS FOR REFERENCE        I
C           SOLUTION. (NEEDS ONLY TO BE SPECIFIED IF IOPT(2)=0 OR      I
C           IOPT(3)=0).                                                I
C           0: 8 POINT ITERATED GAUSS COLLOCATION (ORDER = 16),        I
C           OTHER: VALUE WITH DECIMAL EXPANSION "MC" WHERE "C" AND "M" I
C              CAN HAVE THE VALUES AS SPECIFIED UNDER IOPT(1) WITH THE I
C              EXCEPTION THAT THE VALUE "M1", WITH 2<=M, INDICATES     I
C              M POINT ITERATED GAUSS COLLOCATION (ORDER = 2M).        I
C           NOTE: ITERATED COLLOCATION IS ONLY ALLOWED IN COMBINATION  I
C           ----  WITH GAUSS COLLOCATION.                              I
C        9. STEPSIZE STRATEGY CONTROLLER (NEEDED ONLY IF IOPT(2)=0).   I
C           IF REF.SOL. IS COMPUTED BY ITERATED COLLOC.: A VALUE       I
C              WITH DECIMAL EXPANSION "PT" WHERE "P" CAN HAVE THE      I
C              VALUE 0,1 OR 2 AND "T" 0 OR 1.                          I
C              P=0: CHECK IF SOLUTION IS A POLYNOMIAL OF DEGREE < M,   I
C                   AND IF SO, ESCAPE TO LOCAL + UNIFORM ERROR CONTROL I
C                   WITH COMPUTATION OF THE REFERENCE SOLUTION BY      I
C                      (M+1) GAUSS + (C[M+2]=1).                       I
C                   IF IOPT(3)=0, THE GLOBAL ERROR IN "TE" WILL BE     I
C                   ESTIMATED BY THE SUM OF THE LOCAL ERRORS IN "TE".  I
C              P=1: CHECK IF SOLUTION IS A POLYNOMIAL OF DEGREE < M,   I
C                   IF SO, RETURN TO CALLING PROGRAM.                  I
C              P=2: NO CHECK.                                          I
C              T=0: INCREASE TOLERANCE BY A FACTOR "TOLREL" (SEE BELOW I
C                   UNDER "CONSTANTS USED") IF THE ERROR RESULTING     I
C                   FROM A STEP WITH VALUE "HMIN" IS GREATER THAN THE  I
C                   TOLERANCE.                                         I
C              T=1: RETURN TO CALLING PROGRAM IF TOLERANCE CAN NOT BE  I
C                   SATISFIED.                                         I
C           OTHERWISE: A VALUE WITH DECIMAL EXPANSION "PGUT", WHERE    I
C              "P" AND "T" ARE DESCRIBED ABOVE; "P" IS USED ONLY IF    I
C              THE APPROX. METHOD IS GAUSS COLLOCATION, IF G=0 AND IF  I
C              ORDER REF.SOL. <= ORDER GAUSS QUADR. FORMULA.           I
C              IN CASE P=0 AND IF THE SOLUTION BEHAVES AS A POLYNOMIAL I
C              AN ESCAPE IS MADE TO  LOCAL+UNIFORM ERROR CONTROL WITH  I
C              COMPUTATION OF THE REF.SOL. BY THE SAME METHOD AS       I
C              BEFORE BUT WITH AN ADEQUATE # OF COLLOC. POINTS. IF     I
C              IOPT(3)=0, THE GLOBAL ERROR IN "TE" WILL BE ESTIMATED   I
C              BY THE SUM OF THE LOCAL ERRORS IN "TE".                 I
C              EACH OF THE DIGITS "G" AND "U" HAS THE VALUE 0 OR 1.    I
C              G=0: STEPSIZE CONTROL USING GLOBAL ERROR.               I
C              G=1: STEPSIZE CONTROL USING LOCAL ERROR.                I
C              U=0: MODIFIED STEPSIZE CONTROL; UNIFORM ERROR CONTROL   I
C                   OVER REMAINING INTERVAL.                           I
C              U=1: NO MODIFICATION OF STEPSIZE CONTROL.               I
C              NOTE: TO USE LOCAL OR UNIFORM ERROR CONTROL IN          I
C              ----  COMBINATION WITH AN M-POINT GAUSS QUADRATURE      I
C              FORMULA REQUIRES AN ORDER OF THE REFERENCE SOLUTION OF  I
C              AT LEAST 2M+1.                                          I
C NOTE:  BOTH THE VALUES IOPT(6) AND IOPT(7) CAN BE EXCEEDED BY THE    I
C ----   NUMBER OF KERNEL EVALUATIONS, RESP. CPU-SECONDS NEEDED TO     I
C        SOLVE THE SYSTEM OF COLLOCATION EQUATIONS IN AN INTERVAL.     I
C OPT    REAL VALUED OPTION VECTOR OF LENGTH AT MOST 4 (TRUE LENGTH    I
C        DEPENDENT ON "DEFOPT", RESP. IOPT(2), IOPT(9));               I
C        (0.0): DEFAULT VALUES.                                        I
C        1. INITIAL VALUE FOR STEPSIZE. IF IOPT(2)=1 THIS LENGTH       I
C           WILL REMAIN FIXED THROUGHOUT THE COMPUTATION AND SHOULD    I
C           NOT BE ZERO.                                               I
C           0.0: DEFAULT VALUE. IF FIRST CALL: HINIT = MIN(TE-T0,1.0), I
C                OTHERWISE  HINIT IS SET TO THE GUESS OF THE LENGTH OF I
C                THE NEXT SUBINTERVAL MADE IN THE PREV. CALL OF COLVI2.I
C        2. MINIMUM STEPSIZE. (NEEDED ONLY IF IOPT(2)=0).              I
C           0.0: DEFAULT VALUE  HMIN = MAX(SUNFLO,HINIT*HMINFC),       I
C                WITH HMINFC = 1E-5 (SEE BELOW UNDER "CONSTANTS USED").I
C           MIN. LENGTH OF N-TH SUBINTERVAL IS:                        I
C              HMINN = MAX(HMIN,SRELPR*!TN!)                           I
C                 WITH SUNFLO = SMALLEST F.P. NUMBER AND               I
C                      SRELPR = F.P. MACHINE PRECISION,                I
C                      (SEE UNDER "MACHINE CONSTANTS").                I
C        3. MAXIMUM STEPSIZE. (NEEDED ONLY IF IOPT(2)=0).              I
C           0.0: DEFAULT VALUE  HMAX = 1.0.                            I
C           IF "COLVI2" IS REQUIRED TO CHECK IF THE SOLUTION BEHAVES   I
C           AS A POLYNOMIAL  HMAX SHOULD BE <= 1.0.                    I
C        4. INTERVAL LENGTH HC. (NEEDED ONLY IF UNIFORM ERROR CONTROL  I
C           IS REQUIRED); AT STEP "TN"  LOCAL ERR. CONTR. IS PERFORMED I
C           IN TE, (-HC), TN+HN.                                       I
C           0.0: DEFAULT VALUE  HC = HMAX.                             I
C CNTRL  INTEGER VALUED CONTROL VECTOR OF LENGTH AT MOST 4.            I
C        (IF "DEFOPT">0 "IOPT", "OPT" AND "CNTRL" ARE NOT USED).       I
C        (0): DEFAULT VALUES.                                          I
C        1. RE-ENTRY INDICATOR (CF. "GENERAL COMMENTS" SUB "ENTRY").   I
C           0: FIRST ENTRY,                                            I
C           1: RE-ENTRY, NEW OPTIONS,                                  I
C           2: RE-ENTRY AFTER SAVE, NEW OPTIONS,                       I
C           3: RE-ENTRY, OLD OPTIONS,                                  I
C           4: RE-ENTRY AFTER SAVE, OLD OPTIONS.                       I
C        2. LOGICAL UNIT NUMBER OF FILE FOR ERROR MESSAGES.            I
C           (CF. "GENERAL COMMENTS" SUB "ERROR MESSAGES").             I
C           0: ERROR MESSAGES ARE WRITTEN TO THE STANDARD OUTPUT FILE  I
C              (ADDRESSED BY THE "PRINT" STATEMENT).                   I
C           1 <= CNTRL(2) <= IMXLUN (SEE "MACHINE CONSTANTS").         I
C        3. CONTROL ON WRITING OF RESULTS IN ALL STEP POINTS.          I
C           (CF. "GENERAL COMMENTS" SUB "WRITE ALL").                  I
C           0: NO INTERMEDIATE WRITING.                                I
C           1 <= CNTRL(2) <= IMXLUN : LOG. UNIT # OF FILE.             I
C        4. INDICATOR TO SAVE VARIABLES FOR RE-ENTRY AFTER ERROR.      I
C           (CF. "GENERAL COMMENTS" SUB "SAVE").                       I
C           0: NO SAVE.                                                I
C           1 <= CNTRL(2) <= IMXLUN : LOG. UNIT # OF FILE TO           I
C              SAVE COMMON BLOCKS, WKAREA, IOPT AND OPT FOR RE-ENTRY.  I
C WKAREA REAL WKAREA(IW).                                              I
C        TEMPORARY WORKING STORAGE. THE EXACT AMOUNT NEEDED IS         I
C        SPECIFIED BELOW UNDER "DISTRIBUTION WKAREA" AND "STORAGE      I
C        OCCUPIED". HERE, A FEW SPECIFIC CASES ARE TREATED.            I
C        FIRST AN UPPERBOUND WILL BE GIVEN FOR THE CASE "DEFOPT" > 0.  I
C        LET MAXNC = MAX. # (SUCCESSFUL) STEPS POSSIBLE (THIS NUMBER   I
C                    WILL BE CALCULATED BY "COLVI2" FROM THE USER      I
C                    SUPPLIED INPUT VALUES),                           I
C        THEN AN UPPERBOUND FOR THE DIMENSION OF "WKAREA" IS GIVEN BY: I
C        IF "DEFOPT" = ?1                                              I
C           1456+101.NEQN.NEQN+(61+2.INT(TE-T0)).NEQN+(1+8.NEQN).MAXNC,I
C        IF "DEFOPT" = ?2                                              I
C           429+37.NEQN.NEQN+(23+2.INT(TE-T0)).NEQN+(1+11.NEQN).MAXNC. I
C        NOTE THAT FOR "DEFOPT" = 0, IT IS POSSIBLE TO JUST TAKE SOME  I
C        VALUE FOR "IW", SAY 2000, SET "CNTRL(4) > 0" AND LET THE      I
C        PROGRAM RUN. IF THE CODE LACKS WORKING SPACE IT DUMPS ALL     I
C        NEEDED VARIABLES ON FILE AND AN ERROR EXIT IS TAKEN. THE      I
C        COMPUTATION CAN THEN BE RESTARTED FROM THE LAST REACHED POINT I
C        BY A NEW CALLING PROGRAM WHICH OFFERS MORE WORKING SPACE TO   I
C        "COLVI2".                                                     I
C        NOW SOME EXAMPLES IN WHICH "IW" IS CALCULATED EXACTLY:        I
C        LET M = # COLLOCATION PARAMETERS (SEE IOPT(1)),               I
C            S = # QUADRATURE POINTS (IF IOPT(1)=?2: M-1, OTHERWISE M),I
C            L = 2 IF IOPT(1)=?3, OTHERWISE 1,                         I
C        AND DEFINE ANALOGOUSLY MR, SR, LR FROM IOPT(8).               I
C        LET    X = MAX(M,MR),                                         I
C             NHC = INT((TE-T0)/HC),                                   I
C          NIRVEC = 2.NEQN IF FUNCTIONAL ITERATION IS USED,            I
C                   OTHERWISE: NEQN.(1+NEQN),                          I
C       NWKSYS(N) = DIM.WKAREA SOLVER_FOR_LIN.SYS.OF_DIM.(N.NEQN),     I
C            F(N) = IF FUNCT.IT.: MAX(NIRVEC,2.N-N.NEQN),              I
C                   IF NEWTON'S METHOD IS USED AND THE JACOBIAN IS     I
C                               UPDATED EACH ITERATION:                I
C                               (N.NEQN)**2 + MAX(NIRVEC,NWKSYS(N)),   I
C                   IF NEWTON'S METH. IS USED WITHOUT UPDATING THE JAC.I
C                               (N.NEQN)**2 + NIRVEC+NWKSYS(N),        I
C        THEN THE DIMENSION OF WKAREA SHOULD BE                        I
C        IF DEFOPT = ?1:                                               I
C            625+30.NEQN + (1+8.NEQN).MAXNC +                          I
C            (NO ESCAPE:) F(8)                                         I
C            (ESCAPE:)    831+(20+2.NHC).NEQN+F(10).                   I
C        IF DEFOPT = ?2:                                               I
C            429+(16+2.NHC).NEQN+F(6)+ (1+11.NEQN).MAXNC.              I
C        IN CASE OF CONSTANT STEPSIZES, S=M,L=1, NO ERROR EST. IN "TE":I
C            1+3.M+M.M.M+(1+2.M).NEQN+F(M) + (1+M.NEQN).MAXNC.         I
C        IN CASE OF ITERATED COLLOCATION WITHOUT ESCAPE:               I
C            1+6.M+M.M+M.M.M+(6+3.M).NEQN+F(M) + (1+M.NEQN).MAXNC.     I
C        IN CASE OF LOC.+UNIF.ERR.CONTR.(NO GAUSS, NO ERR.EST.IN "TE"):I
C            1+4.X+2.X.X.X+(4+5.X+2.NHC).NEQN+F(X) +                   I
C                                          (1+(M-L+1).NEQN).MAXNC.     I
C        IN CASE OF GLOBAL + UNIFORM ERROR CONTROL (NO GAUSS):         I
C            1+4.X+2.X.X.X+(4+2.X+2.NHC).NEQN+F(X) +                   I
C                                      (1+(M-L+1+MR-LR+1).NEQN).MAXNC. I
C IW     INTEGER VALUE.                                                I
C        DIMENSION OF "WKAREA" AS DECLARED IN MAIN PROGRAM.            I
C TNC    REAL VALUE.                                                   I
C        EXIT: RIGHT ENDPOINT OF LAST INTERVAL ON WHICH SOLUTION HAS   I
C              BEEN COMPUTED (SHOULD BE EQUAL TO "TE").                I
C UE     REAL UE(NEQN).                                                I
C        EXIT: COMPUTED SOLUTION OF THE VIE2 AT "TE".                  I
C GEE    REAL GEE(NEQN).                                               I
C        EXIT: CONTAINS THE GLOBAL ERROR EST. AT "TE" IF EITHER        I
C              IOPT(3)=0 OR IF GLOBAL OR UNIFORM ERROR CONTROL         I
C              HAS BEEN SPECIFIED.                                     I
C IERROR INTEGER VALUE.                                                I
C        ERROR COMPLETION CODE.                                        I
C        IF AN ERROR HAS BEEN DETECTED, INFO IS WRITTEN TO THE         I
C        ERROR_MESSAGE_FILE (LOG. UNIT # : CNTRL(2)).                  I
C          0: NO ERRORS.                                               I
C          1: "DEFOPT" INCORRECT OR                                    I
C             INITIAL FILE STATUS WRONG OF ERROR_MESSAGE_FILE,         I
C             INFO ON STANDARD OUTPUT FILE.                            I
C          2: INCORRECT INPUT.                                         I
C             INFO ON ERROR_MESSAGE_FILE.                              I
C          3: FAILED TO COMPUTE COLLOCATION PARAMETERS.                I
C         11: FAILURE TO MEET TOLERANCE "REQTOL" WITH STEPSIZE "HMINN".I
C         12: WORKING STORAGE NEEDED EXCEEDS "IW" (VAR. STEPSIZE).     I
C         13: TOTAL # KERNEL EVALUATIONS USED > IOPT(6).               I
C         14: TOTAL # CPU-SECONDS USED > IOPT(7).                      I
C         15: POLYNOMIAL SOLUTION (GAUSS).                             I
C         16: TOLERANCE WOULD BE RELAXED TO A VALUE > 1.0.             I
C         21: CORRECTOR ITER. PROCESS DID NOT CONVERGE WITHIN "MAXFIT" I
C             (FUNCTIONAL ITERATION) OR "MAXNIT" (NEWTON'S METHOD)     I
C             ITERATIONS (CF. "CONSTANTS USED"). (FIXED STEPSIZE).     I
C         31: CORRECTOR ITER. PROCESS DID NOT CONVERGE WITHIN "MAXFIT" I
C             (FUNCTIONAL ITERATION) OR "MAXNIT" (NEWTON'S METHOD)     I
C             ITERATIONS (CF. "CONSTANTS USED"). (WITHIN "YPOLM").     I
C        113: TOTAL # KERNEL EV. USED > IOPT(6) -+  WHILE COMP.        I
C        114: TOTAL # CPU-SEC. USED > IOPT(7) ---+  GLOB. ERR. EST. TE.I
C        OTHER: ERROR COMPLETION CODE FROM ONE OF THE ROUTINES         I
C             "DECLUF", "SOLLUF" OR "ZERPOL".                          I
C                                                                      I
C -------------------------------------------------------------------- I
C                                                                      I
C GENERAL COMMENTS:                                                    I
C ================                                                     I
C                                                                      I
C EXAMPLE PROGRAMS: WITH THE PACKAGE GOES A SET OF DRIVER PROGRAMS TO  I
C ----------------  DEMONSTRATE THE USE OF "COLVI2" AND THREE UTILITY  I
C   ROUTINES USED BY THE DRIVERS. FOR AN ELABORATE DESCRIPTION OF THE  I
C   DRIVERS AND THE VIE2'S THEY SOLVE WE REFER TO THE DOCUMENTATION IN I
C   THE PROGRAMS. A SHORT DESCRIPTION OF THE DRIVERS AND THE UTILITY   I
C   ROUTINES FOLLOWS:                                                  I
C                                                                      I
C   FIRST DRIVER PROGRAM:                                              I
C   PASS 1 - PASS 6: DEMONSTRATE SIMPLE USE OF "COLVI2".               I
C      USE DEFOPT = 21,22, 1,2 OR SMALL CHANGES ON THE DEFAULT VALUES. I
C   SECOND DRIVER PROGRAM:                                             I
C   PASS 7 - PASS 8: DEMONSTRATE RE-ENTRY FACILITY OF "COLVI2".        I
C      WRITE INTERMEDIATE RESULTS TO FILE TO SHOW TRANSITION.          I
C      7: SAME OPTIONS AS PASS 5; DIVIDE INTEGRATION INTERVAL IN TWO   I
C         PARTS.                                                       I
C      8: AS PASS 6 BUT WITHOUT AUTOMATIC ESCAPE; NEEDS MORE WORKING   I
C         SPACE BECAUSE GLOB.ERR.EST. IN "TE" USES SEPARATELY COMPUTED I
C         REF.SOL.                                                     I
C   THIRD DRIVER PROGRAM:                                              I
C   PASS 9: DEMONSTRATE SAVE FACILITY OF "COLVI2".                     I
C      SAME OPTIONS AS PASS 5; WORKING STORAGE DIMINISHED TO FORCE     I
C      AN EXIT BECAUSE OF A LACK OF WORKING STORAGE.                   I
C   FOURTH DRIVER PROGRAM:                                             I
C   PASS 10: DEMONSTRATE RE-ENTRY_AFTER_SAVE FACILITY OF "COLVI2".     I
C      SAME OPTIONS AS PREV. CALL; WORKING STORAGE ENLARGED.           I
C   FIFTH DRIVER PROGRAM:                                              I
C   PASS 11: DEMONSTRATE SAVE FACILITY OF "COLVI2" AFTER ARITHMETIC    I
C      ERROR OTHER PROBLEM, LOOOONG INTEGR. PATH.; USE FUNCTIONAL ITER.I
C      NO DKCDY NEEDED. EMPLOY RADAU INTEGRATION; HMAX = 10.0 AND      I
C      UNIFORM ERROR CONTROL WITH HC=10.0 (=HMAX).                     I
C      FOR THIS DEMONSTRATION WE NEED A SYSTEM ROUTINE THAT ALLOWS     I
C      THE USER TO REGAIN CONTROL AFTER ARITHMETIC MODE ERRORS.        I
C   SIXTH DRIVER PROGRAM:                                              I
C   PASS 12: DEMONSTRATE SAVE FACILITY OF "COLVI2" AFTER ARITHMETIC    I
C      ERROR IN PASS 11; ENLARGE HMAX TO 50., NO UNIFORM ERROR CONTROL.I
C                                                                      I
C   THE THREE UTILITY ROUTINES:                                        I
C   REAL FUNCTION AERE (Y, YA)                                         I
C   REAL Y, YA                                                         I
C      COMPARISON OF THE APPROXIMATED SOLUTION "YA" WITH THE EXACT     I
C      SOLUTION "Y". IF Y > 1.0 THE NUMBER OF CORRECT SIGNIFICANT      I
C      DIGITS IS RETURNED, OTHERWISE THE NUMBER OF CORRECT DIGITS.     I
C   SUBROUTINE SUMARY (NOUT, NEQN, WKAREA, YE, T, UE, GEE, IERROR)     I
C   INTEGER NOUT, NEQN, IERROR                                         I
C   REAL T                                                             I
C   REAL WKAREA(*), YE(NEQN), UE(NEQN), GEE(NEQN)                      I
C      EXTRACT STATISTICS FROM "COLVI2" COMMON BLOCKS AND WRITE SUMMARYI
C      OF RESULTS TO FILE WITH LUN "NOUT".                             I
C   SUBROUTINE ACVSUM (IERROR, WKAREA, TN, T0)                         I
C   INTEGER IERROR                                                     I
C   REAL TN, T0                                                        I
C   REAL WKAREA(*)                                                     I
C   ENTRY SCVSUM                                                       I
C      ACCUMULATE COUNTING VALUES IN "COLVI2" COMMON BLOCK /COLCMI/    I
C      THAT ARE ZEROED WHEN "COLVI2" IS CALLED MORE THAN ONCE.         I
C      ENTRY SCVSUM: STORE ACCUMULATED VALUES IN /COLCMI/.             I
C                                                                      I
C SOLUTION IN ARBITRARY POINT: THE PACKAGE CONTAINS A SUBROUTINE TO    I
C ---------------------------  COMPUTE THE APPROXIMATION "UH" IN AN    I
C   ARBITRARY POINT "T" BETWEEN "T0" AND "TNC" BY LAGRANGE INTERPOL.   I
C   USING THE ARRAY OF APPROXIMATIONS "U" STORED IN "WKAREA".          I
C   THE HEADING OF THIS ROUTINE IS:                                    I
C     SUBROUTINE COMPUH (T, NEQN, T0, WKAREA, UH)                      I
C     INTEGER NEQN                                                     I
C     REAL T, T0                                                       I
C     REAL WKAREA(*), UH(NEQN)                                         I
C   "WKAREA" SHOULD CONTAIN THE ENTIRE, UNALTERED, "WKAREA" ARRAY AS   I
C   RETURNED BY "COLVI2".                                              I
C                                                                      I
C ERROR MESSAGES: ERROR MESSAGES GENERATED BY "COLVI2" ARE WRITTEN     I
C --------------  TO A SEQUENTIAL FORMATTED FILE. IF DEFOPT > 0 OR     I
C   CNTRL(2)=0 THE STANDARD OUTPUT FILE IS USED. OTHERWISE CNTRL(2)    I
C   DEFINES THE LOGICAL UNIT NUMBER OF THE FILE AND THIS FILE SHOULD   I
C   BE OPENED IN THE MAIN PROGRAM.                                     I
C                                                                      I
C THE NEXT THREE PARAGRAPHS ARE IRRELEVANT WHEN "COLVI2" WILL BE CALLEDI
C WITH DEFOPT > 0.                                                     I
C                                                                      I
C SAVE: THE PACKAGE HAS THE OPTION (CNTRL(4)>0) TO SAVE ALL NECESSARY  I
C ----  VARIABLES ON A FILE IN CASE OF AN ERROR DURING THE             I
C   COMPUTATIONAL PROCESS, I.E. AFTER THE CONTROL AND INITIALIZATION   I
C   PHASE.                                                             I
C   THE COMMON BLOCK VARIABLES, WORKING STORAGE AND OPTION VECTORS     I
C   ARE WRITTEN TO A SEQUENTIAL UNFORMATTED FILE NAMED "COLSAV". THE   I
C   LOGICAL UNIT NUMBER USED IS "CNTRL(4)". IF THE FILE "COLSAV"       I
C   ALREADY EXISTS IT WILL BE OVERWRITTEN.                             I
C   THIS FILE SHOULD BE AVAILABLE IF "COLVI2" IS CALLED WITH           I
C   CNTRL(1)=2 OR 4.                                                   I
C   (SEE ALSO UNDER "CONSTANTS USED" AND "OTHER MACHINE DEPENDENCIES") I
C                                                                      I
C ENTRY: "COLVI2" ACKNOWLEDGES A NUMBER OF DIFFERENT ENTRY OPTIONS.    I
C -----  THE FIRST TIME "COLVI2" IS CALLED TO SOLVE A SPECIFIC VIE2    I
C   CNTRL(1) SHOULD BE 0 AND ALL OPTION VECTORS SHOULD HAVE LEGITIMATE I
C   VALUES.                                                            I
C     IT IS POSSIBLE TO CALL "COLVI2" A SECOND TIME IN THE SAME MAIN   I
C   PROGRAM TO CONTINUE THE PROCESS OF SOLVING THE VIE2 AFTER A NORMAL I
C   EXIT OR AFTER "COLVI2" RETURNED WITH "IERROR" >= 10. IN THE LATTER I
C   CASE THE USER SHOULD REACT APPROPRIATELY ON THE GIVEN ERROR.       I
C   THE ARRAY "WKAREA" SHOULD BE UNCHANGED OR COPIED INTO A NEW        I
C   WORKING STORAGE; "TNC" SHOULD BE UNALTERED.                        I
C   CNTRL(1)=1 INDICATES THAT NEW OPTION VECTORS HAVE BEEN DEFINED,    I
C   CNTRL(1)=3 THAT THE OLD OPTIONS SHOULD BE USED.                    I
C     A RE-ENTRY TO CONTINUE IN THE SAME OR A NEW JOB IS ALSO POSSIBLE I
C   AFTER AN ERRATIC EXIT (WITH SAVE CONTROL ON), BOTH WITH NEW OPTION I
C   VECTORS (CNTRL(1)=2) AND WITH THE OLD OPTIONS (CNTRL(1)=4).        I
C   THE FILE "COLSAV" (SEE ABOVE) SHOULD BE AVAILABLE, AND "IW" SHOULD I
C   BE >= DIMENSION ARRAY "WKAREA" IN THE PREVIOUS CALL.               I
C   NOTE: IN CASE OF RE-ENTRY THE NUMBER OF COLLOCATION PARAMETERS AND I
C   ----  THE COLLOCATION METHOD TO APPROXIMATE THE SOLUTION (IOPT(1)) I
C   SHOULD BE THE SAME AS IN THE PREVIOUS CALL OF "COLVI2". IF GLOBAL  I
C   ERROR CONTROL IS USED THIS HOLDS ALSO FOR IOPT(8).                 I
C   IT IS NOT ALLOWED TO ASK FOR GLOBAL ERROR CONTROL IF THIS WAS NOT  I
C   USED IN THE PREVIOUS CALL OF COLVI2 .                              I
C   IT IS NOT POSSIBLE TO RE-ENTER THE PROCESS OF COMPUTING THE GLOBAL I
C   ERROR ESTIMATE IN "TE" (HOWEVER, ONE CAN COPY THE CALL OF "SGEVI2" I
C   FROM "COLVI2").                                                    I
C   IF UNIFORM ERROR CONTROL IS REQUIRED AND IN THE PREVIOUS CALL THIS I
C   EITHER WAS NOT THE CASE, OR THE ENDPOINT "TE" OR THE VALUE OF      I
C   OPT(4) WERE DIFFERENT, THEN AN ESTIMATION OF THE SUM OF THE LOCAL  I
C   ERRORS IS MADE BASED ON THE LOCAL ERRORS IN THE FIRST POINT        I
C   COMPUTED.                                                          I
C                                                                      I
C WRITE ALL: IF CNTRL(3) IS NON-ZERO THE RESULTS IN EACH STEP POINT    I
C ---------  ARE WRITTEN TO A SEQUENTIAL FORMATTED FILE WITH LOGICAL   I
C   UNIT NUMBER CNTRL(3). THIS FILE SHOULD BE OPENED IN THE CALLING    I
C   PROGRAM.                                                           I
C   A SUBROUTINE YEXACT(T,YV) SHOULD EXIST AND DELIVER THE EXACT       I
C   SOLUTIONS AT "T" IN YV(1:NEQN). IF NO SOLUTION IS AVAILABLE        I
C   "YEXACT" STILL HAS TO BE PROVIDED AND SHOULD RETURN LEGITIMATE F.P.I
C   NUMBERS, SAY 0.0, IN YV.                                           I
C                                                                      I
C -------------------------------------------------------------------- I
C                                                                      I
C SUBPROGRAMS:                                                         I
C ===========                                                          I
C                                                                      I
C SOLVING ROUTINES:                                                    I
C ----------------                                                     I
C COLVI2 _ ENVELOPING ROUTINE.                                         I
C          CHECK INPUT, INITIALIZE COMMON AND COLL. VARIABLES,         I
C          DIGEST RESULTS OF "SOLVI2".                                 I
C SOLVI2 _ SUPERVISOR.                                                 I
C          SOLVE VIE2 WITH CHOSEN COLLOCATION METHOD. MONITOR STEPS,   I
C          PERFORM STEP ACCEPTANCE / REJECTANCE.                       I
C SGEVI2 _ COMPUTE REF.SOL. IN "TE" WITH CHOSEN COLL. METHOD AND STEP- I
C          SIZES AS USED IN THE COMPUTATION OF THE APPROXIMATION.      I
C SLQCE2 _ SET UP SYSTEM OF COLLOC. EQUATIONS IN A SUBINTERVAL,        I
C          COMPUTE LAG TERMS WITH QUADRATURE.                          I
C SLICE2 _ SET UP SYSTEM OF COLLOC. EQUATIONS IN A SUBINTERVAL,        I
C          COMPUTE LAG TERMS WITH INTERPOLATION.                       I
C SOLSYS _ SOLVE THE SYSTEM OF COLLOCATION EQUATIONS IN A SUBINTERVAL. I
C SOLNEW _ SOLVE THE SYSTEM OF COLLOCATION EQUATIONS IN A SUBINTERVAL, I
C          CALLED BY "SOLSYS" IF NEWTON ITERATION IS TO BE USED.       I
C                                                                      I
C YPOLM  _ CHECK IF SOLUTION BEHAVES AS A POLYNOMIAL OF DEGREE < M.    I
C                                                                      I
C UTILIP _ COMPUTE COLL. APPR. IN A STEPPOINT WITH LAGR. INTERPOL.     I
C COMPUH _ COMPUTE COLL. APPR. IN AN ARBITRARY POINT WITH LAGR. INTERP.I
C ITRCOL _ COMPUTE THE ITERATED COLL. APPROX. IN A STEPPOINT.          I
C                                                                      I
C INITIALIZING ROUTINES:                                               I
C ---------------------                                                I
C CHKINI _ CHECK INPUT PARAMETERS AND INITIALIZE COMMON BLOCKS.        I
C DISWKS _ DISTRIBUTE WORKING STORAGE.                                 I
C INIVEC _ INITIALIZE VECTORS WITH SOLUTION AND SUM OF LOCAL ERRORS.   I
C ESCRGS _ ALTER COMMON BLOCK VALUES AND RE-DISTRIBUTE WORK SPACE IN   I
C          CASE OF ESCAPE WHEN SOLUTION BEHAVED AS A POLYNOMIAL.       I
C INILAG _ INITIALIZE LAG TERM VECTORS IN CASE LAG TERMS REF. SOL. ARE I
C          COMPUTED BY INTERPOLATION.                                  I
C INILGN _ INITIALIZE LAG TERM VECTOR IN STARTING POINT IN CASE IT HAS I
C          TO BE CHECKED IF SOLUTION IS POLYNOMIAL.                    I
C                                                                      I
C COLCWL _ INITIALIZE THE SET OF COLLOCATION PARAMETERS,               I
C          THE ASSOCIATED WEIGHT FACTORS FOR THE QUADRATURE FORMULA    I
C          AND THE LAGRANGIAN INTERPOLATION COEFFICIENTS NEEDED.       I
C GAUSS  _ COMPUTE GAUSS-LEGENDRE COLL. PARAMETERS (2 <= M).           I
C GAUSSC _ COMPUTE GAUSS-LEGENDRE COLL. PARAMETERS (6 <= M).           I
C LOBATO _ COMPUTE LOBATTO COLL. PARAMETERS (2 <= M).                  I
C LOBATC _ COMPUTE LOBATTO COLL. PARAMETERS (8 <= M).                  I
C RADAU  _ COMPUTE RADAU COLL. PARAMETERS (2 <= M).                    I
C RADAUC _ COMPUTE RADAU COLL. PARAMETERS (4 <= M).                    I
C COMPWL _ COMPUTE WEIGHT FACTORS FOR QUADRATURE FORMULA AND           I
C          LAGRANGIAN INTERPOLATION COEFFICIENTS IN (CI.CJ).           I
C COMPLV _ COMPUTE LAGR. INTERPOL. COEFF. IN A GIVEN POINT.            I
C COMPLG _ GIVEN THE POINTS 0.0, C(1:M), 1.0 COMPUTE THE LAGR. INTERP. I
C          COEFF. IN CJ/2 ("C" ARE THE GAUSS COLL. PAR.).              I
C INTEGL _                U                                            I
C          COMPUTE      INT L_J(V) DV .                                I
C                         0                                            I
C LAGPOL _                          M                                  I
C          COMPUTE      L_J(V) = PROD (V-CI)/(CJ-CI) .                 I
C                                I=1,I/=J                              I
C                                                                      I
C UTILITIES:                                                           I
C ---------                                                            I
C ADJLSV _ ADJUST LAG TERM VECTORS IN CASE REF.SOL. LAGTERMS ARE COMP. I
C          BY INTERPOLATION.                                           I
C                                                                      I
C LEEWGT _ COMPUTE (TN+HN-T0)/HN * LOCAL ERROR IN (TN+HN).             I
C UEEWGT _ COMPUTE MAXIMUM OF GLOBAL ERRORS IN [TN,TE]. THE GLOBAL     I
C          ERROR IS APPROXIMATED BY A SUM OF LOCAL ERRORS ON [T0,TN]   I
C          AND AN ESTIMATION OF THE LOCAL ERRORS ON [TN+HN,TE] BASED   I
C          ON THE LOCAL ERROR IN (TN+HN).                              I
C WMXNRM _ COMPUTE THE MAXIMUM NORM OF A GIVEN ERROR VECTOR, USING     I
C          WEIGHTS AS PRESCRIBED BY IOPT(4).                           I
C                                                                      I
C THE NEXT FOUR SUBROUTINES INSPECT THE STARTING CONDITIONS FOR        I
C "COLVI2". IF THE INITIAL FILE STATUS OF THE ERROR_MESSAGE_FILE IS    I
C WRONG, A MESSAGE IS WRITTEN TO THE STANDARD OUTPUT FILE AND "COLVI2" I
C RETURNS. OTHERWISE EACH SUBROUTINE CHECKS AS MUCH AS POSSIBLE IN ITS I
C FIELD. ALL THE ERRORS FOUND, AS WELL AS THE ERRORS FOUND DURING AN   I
C EVENTUAL RELOAD ARE WRITTEN TO THE ERROR_MESSAGE_FILE.               I
C CHKFIL _ CHECK STATUS OF FILES THAT THE USER SHOULD HAVE OPENED.     I
C CHKPTO _ CHECK DIMENSION, INTEGRATION BOUNDS OF VIE2 AND TOLERANCE   I
C          PARAMETERS, AND THE ORDER OF THE REF.SOL.METHOD.            I
C CHKOPT _ CHECK VALIDITY OF OPTION- AND CONTROL-VECTORS.              I
C CHKREC _ CHECK CONSISTENCY PARAMETERS WITH PREVIOUS CALL OF COLVI2.  I
C CHKWKA _ CHECK (AS FAR AS POSSIBLE) SIZE OF WORKING STORAGE AREA.    I
C                                                                      I
C ERRMSG _ WRITE ERROR MESSAGE TO A FILE WITH LOGICAL UNIT # CNTRL(2). I
C WRIRES _ WRITE INTERMEDIATE RESULTS TO FILE WITH LOGICAL             I
C          UNIT NUMBER CNTRL(3).                                       I
C                                                                      I
C ADDABM _ A = A + B, A AND B MATRICES.                                I
C ADDABV _ V = V+W, V AND W VECTORS.                                   I
C ADDV   _ V = W1+W2, V, W1 AND W2 VECTORS.                            I
C COPYV  _ COPY VECTOR.                                                I
C UNITM  _ INITIALIZE MATRIX ON UNIT MATRIX.                           I
C ZEROV  _ ZERO VECTOR.                                                I
C                                                                      I
C THE NEXT SEVEN ROUTINES ARE SYSTEM OR ENVIRONMENT DEPENDENT. FOR A   I
C DESCRIPTION OF THESE SEE BELOW UNDER "OTHER MACHINE DEPENDENCIES".   I
C SAVALL _ SAVE, IN CASE OF ERROR DURING COMPUTATIONAL PROCESS,        I
C          ALL NEEDED VARIABLES ON A SEQ. UNFORM. FILE "COLSAV".       I
C          (COMMON, WKAREA, DEFOPT, IOPT, OPT, TE, TN).                I
C RELOAD _ RELOAD VARIABLES WRITTEN BY "SAVALL" TO CONTINUE            I
C          COMPUTATIONAL PROCESS AFTER ERRATIC EXIT.                   I
C NCPJOB _ RETURN NUMBER OF CPU SECONDS USED IN THIS JOB.              I
C INICMC _ INITIALIZE THE COMMON BLOCKS WITH MACHINE CONSTANTS.        I
C DECLUF _ DECOMPOSE FULL MATRIX INTO "LU".                            I
C SOLLUF _ SOLVE  LU.X = B .                                           I
C ZERPOL _ COMPUTE REAL ZEROS OF POLYNOMIAL AND SORT THESE.            I
C                                                                      I
C ---------------------------------------------------------------------I
C                                                                      I
C DESCRIPTION OF VARIABLES AND CONSTANTS:                              I
C ======================================                               I
C                                                                      I
C COMMON BLOCKS:                                                       I
C -------------                                                        I
C THROUGHOUT THE PACKAGE TWO NAMED COMMON BLOCKS ARE USED THAT HOLD    I
C MACHINE CONSTANTS,                                                   I
C                                                                      I
C   ONE CONTAINING INTEGER VARIABLES:                                  I
C     COMMON /COLMCI/ IBETA, IOVFLO, NSDEC, IMXLUN                     I
C                                                                      I
C   ONE CONTAINING FLOATING POINT VARIABLES:                           I
C     COMMON /COLMCR/ SRELPR, SOVFLO, SUNFLO                           I
C                                                                      I
C FOUR OTHER NAMED COMMON BLOCKS ARE USED THAT HOLD METHOD PARAMETERS  I
C AND STATISTICS,                                                      I
C                                                                      I
C   ONE CONTAINING INTEGER VARIABLES:                                  I
C     COMMON /COLCMI/ METH, M, S, L, ORDER, ORDERQ,                    I
C    +                METHR, MR, SR, LR, ORDERR,                       I
C    +                ERRWGT, NHFAIL,                                  I
C    +                NERR, NWIR, NSAV,                                I
C    +                MAXNC, MAXKEV, MAXCPS,                           I
C    +                N, NCIT, NKEV, NCPS                              I
C                                                                      I
C   ONE CONTAINING LOGICAL VARIABLES:                                  I
C     COMMON /COLCML/ VS, GSSCKM, ESCGSS, GEC, ULEC, RLXTOL, GEETE,    I
C    +                FUNCIT, NEWTON                                   I
C                                                                      I
C   A THIRD CONTAINING FLOATING POINT VARIABLES:                       I
C     COMMON /COLCMR/ TOLLE, TOLCIA, TOLCIR, HMIN, HMAX, HC            I
C                                                                      I
C   THE FOURTH CONTAINING INDEX VARIABLES FOR THE WORK SPACE "WKAREA"  I
C     COMMON /COLIXW/ IC1,IC2,IC3,IC4,IC5,IC6,IC7,IC8,ICE,             I
C    +               IV1,IV2,IV3,IVE, IL1,IL2,IL3,IL4,IL5,ILAG,IL6,ILE I
C                                                                      I
C COMMON VARIABLES:                                                    I
C ----------------                                                     I
C FOR A DESCRIPTION OF THE VARIABLES IN THE COMMON BLOCKS /COLMCI/ AND I
C /COLMCR/ SEE BELOW UNDER "MACHINE CONSTANTS".                        I
C        INTEGER VALUES:                                               I
C METH   COLLOCATION METHOD FOR APPROXIMATION.                         I
C M      # COLLOCATION PARAMETERS FOR APPROXIMATION.                   I
C S      # QUADRATURE POINTS FOR APPROXIMATION.                        I
C L      LOWER BOUND LOOP; L=2 IF METH -> LOBATTO, L=1 OTHERWISE.      I
C ORDER  GLOBAL ORDER OF COLLOCATION METHOD FOR APPROXIMATION.         I
C ORDERQ ORDER OF QUADRATURE TO COMPUTE LAG TERMS FOR APPROXIMATION.   I
C METHR  +                                                             I
C MR     I                                                             I
C SR     I AS METH, M, S, L, ORDER BUT FOR COLLOCATION METHOD TO       I
C LR     I COMPUTE THE REFERENCE SOLUTION.                             I
C ORDERR +                                                             I
C ERRWGT ERROR WEIGHT INDICATOR (= IOPT(4)+1).                         I
C NHFAIL TOTAL # STEPS FAILED.                                         I
C NERR   LOGICAL UNIT # OF ERROR_MESSAGE_FILE (=CNTRL(2)).             I
C NWIR   LOGICAL UNIT # OF FILE FOR INTERMEDIATE RESULTS (=CNTRL(3)).  I
C NSAV   LOG.UN.# OF FILE FOR SAVING INFO IN CASE OF ERROR (=CNTRL(4)).I
C MAXNC  MAX. # SUBINTERVALS ALLOWED BY SIZE OF WORKING STORAGE.       I
C MAXKEV TOTAL # KERNEL EVALUATIONS ALLOWED.                           I
C MAXCPS TOTAL # CPU-SECONDS ALLOWED.                                  I
C N      # CURRENT SUBINTERVAL (TN,TN+HN].                             I
C        OK_EXIT: # LAST INTERVAL + 1 .                                I
C NCIT   TOTAL # CORRECTOR ITERATIONS USED.                            I
C NKEV   TOTAL # KERNEL EVALUATIONS USED.                              I
C NCPS   # CPU-SECONDS USED WHEN "COLVI2" WAS CALLED.                  I
C        ON EXIT: # CPU-SECONDS USED BY "COLVI2".                      I
C        LOGICAL VALUES:                                               I
C VS     IF TRUE, CONTROL ERROR, OTHERWISE USE FIXED STEPSIZE.         I
C GSSCKM IF TRUE, CHECK IF SOLUTION IS POLYNOMIAL OF DEGREE < M.       I
C ESCGSS IF TRUE, ESCAPE TO OTHER REF.SOL.APPROX. IN CASE SOL. IS POL. I
C GEC    IF TRUE, USE GLOBAL ERROR CONTROL.                            I
C ULEC   IF TRUE, PERFORM UNIFORM ERROR CONTROL.                       I
C RLXTOL IF TRUE, RELAX TOLERANCE IN CASE OF FAILURE WITH MIN.STEPSIZE.I
C GEETE  IF TRUE, PROVIDE GLOBAL ERROR ESTIMATION IN ENDPOINT "TE".    I
C FUNCIT IF TRUE, USE FUNCTIONAL ITERATION AS CORRECTOR ITERATION      I
C        WHILE SOLVING THE COLLOCATION SYSTEM.                         I
C NEWTON IF TRUE, USE NEWTON'S METHOD; UPDATE JACOBIAN EACH ITERATION. I
C        IF FALSE AND IF FUNCIT IS FALSE: USE NEWTON'S METHOD; UPDATE  I
C        JACOBIAN ONLY ONCE PER STEP.                                  I
C        F.P. NUMBERS                                                  I
C TOLLE  REQUESTED TOLERANCE FOR GLOBAL ERROR (=REQTOL).               I
C TOLCIA TOLERANCE FOR ERROR IN CORRECTOR ITERATION PROCESS WHILE      I
C        SOLVING COLLOCATION EQUATIONS TO COMPUTE THE APPROXIMATION.   I
C TOLCIR TOLERANCE FOR ERROR IN CORRECTOR ITERATION PROCESS WHILE      I
C        SOLVING COLLOCATION EQUATIONS TO COMPUTE THE REFERENCE SOL.   I
C HMIN   MIN. STEPSIZE ALLOWED.                                        I
C HMAX   MAX. STEPSIZE ALLOWED.                                        I
C HC     INTERVAL LENGTH FOR UNIFORM ERROR CONTROL (TE,(-HC),TN+HN).   I
C                                                                      I
C FOR A DESCRIPTION OF THE VARIABLES OF COMMON BLOCK "COLIXW"          I
C SEE BELOW UNDER "DISTRIBUTION WKAREA".                               I
C                                                                      I
C                                                                      I
C RECURRING LOCAL VARIABLES:                                           I
C -------------------------                                            I
C VAROUT INTERNAL FILE.                                                I
C        USED TO CONVERT ARITHMETIC VALUES TO CHARACTER FORMAT.        I
C GAUSS  LOGICAL.                                                      I
C        TRUE IF GAUSS COLLOCATION IS USED TO APPROXIMATE SOLUTION.    I
C LEC    LOGICAL.                                                      I
C        TRUE IF LOCAL ERROR CONTROL IS USED.                          I
C LOBAT  LOGICAL.                                                      I
C        TRUE IF LOBATTO COLLOCATION IS USED TO APPROXIMATE SOLUTION.  I
C LOBATR LOGICAL.                                                      I
C        TRUE IF LOBATTO COLLOCATION IS USED TO COMPUTE REF.SOL.       I
C RSITCL LOGICAL.                                                      I
C        TRUE IF ITERATED COLLOCATION IS USED TO COMPUTE REF.SOL.      I
C C      REAL C(M).                                                    I
C        CONTAINS THE COLLOCATION PARAMETERS.                          I
C W      REAL W(S).                                                    I
C        CONTAINS QUADRATURE WEIGHTS.                                  I
C LC     REAL LC(M,L:M,L:S).                                           I
C        LC(I,J,K) = L_I(CJ.CK).                                       I
C IDEM CR, WR AND LCR FOR COLLOCATION METHOD TO COMPUTE REF.SOL.       I
C LC1    REAL LC1(M).                                                  I
C        LC1(I) = L_I(1.0).                                            I
C LC0    REAL LC0(M).                                                  I
C        LC0(I) = L_I(0.0).                                            I
C LCG    REAL LCG(0:M+1,M).                                            I
C        LCG(I,J) = L_I(CJ/2)  (BASED ON   0,CJ,1).                    I
C LAGN   REAL LAGN(NEQN).                                              I
C        CONTAINS  FC_N(TN).                                           I
C LAG    REAL LAG(0:NEQN*(M-L+1)-1).                                   I
C        CONTAINS  FC_N(TN+CJ.HN).                                     I
C LAGNP1 REAL LAGNP1(NEQN).                                            I
C        CONTAINS  FC_N(TNP1).                                         I
C LAGSAV REAL LAGSAV(0:NEQN*(2*M-L+1)-1).                              I
C        CONTAINS  FC_N(TNM1+CJ.HNM1) AND FC_N(TN+CJ.HN).              I
C GLAG   REAL GLAG(0:NEQN*(M-L+1)-1).                                  I
C        CONTAINS  G(TN+CJ.HN) + FC_N(TN+CJ.HN).                       I
C LEE    REAL LEE(NEQN*((TE-T0)/HC+1)).                                I
C        CONTAINS LOCAL ERROR ESTIMATES OVER CURRENT INTERVAL IN       I
C        TI = TE (-HC) T0 .                                            I
C LEESUM REAL LEESUM(NEQN*((TE-T0)/HC+1)).                             I
C        CONTAINS SUM OF LOCAL ERROR ESTIMATES OVER ALL INTERVALS UPTO I
C        THE CURRENT ONE IN  TI = TE (-HC) T0 .                        I
C NYPOLM REAL NYPOLM(NEQN).                                            I
C        CONTAINS # CONSEC. TIMES A COMPONENT OF THE SOL. IS  POLYN.   I
C H      REAL H(0:MAXNC).                                              I
C        CONTAINS SUBINTERVAL LENGTHS.                                 I
C H.     REAL.                                                         I
C        "H." = H(.) .                                                 I
C T.     REAL.        .-1                                              I
C        "T." = T0 + SUM H(I) .                                        I
C                     I=0                                              I
C U      REAL U(-NEQN:NEQN*(M-L+1)*MAXNC-1).                           I
C        CONTAINS APPROXIMATED SOLUTION IN COLLOCATION POINTS.         I
C UR     REAL UR(-NEQN:NEQN*(MR-LR+1)*MAXNC-1).                        I
C        CONTAINS REFERENCE SOLUTION IN COLLOCATION POINTS.            I
C UN2    REAL UN2(0:NEQN*M-1).                                         I
C        U(TN+CJ.HN/2).                                                I
C URN    REAL URN(NEQN).                                               I
C        UR(TN).                                                       I
C URNP1  REAL URNP1(NEQN).                                             I
C        UR(TN+HN).                                                    I
C                                                                      I
C CONSTANTS USED: (OTHER THAN MACHINE CONSTANTS)                       I
C --------------                                                       I
C GSSFAC = 2.0,  FACTOR USED TO RELAX THE ORDER DEMAND IN THE CHECK ON I
C                POLYNOMIAL BEHAVIOR. LET UN2 BE THE SOLUTION COMPUTED I
C                OVER HALF THE N-TH INTERVAL THEN                      I
C                GEE(UN2)/GEE(UN) <= GSSFAC/(2**M) IMPLIES THAT THE    I
C                SOLUTION IS NOT A POLYNOMIAL OF DEGREE < M.           I
C                ("YPOLM").                                            I
C HFAC   = 0.9,  REDUCTION FACTOR TO GET CONSERVATIVE GUESS OF THE     I
C                STEPSIZE ("SOLVI2").                                  I
C HFLFAC = 0.25, PENALTY REDUCTION FACTOR OF STEPSIZE.                 I
C                ("SOLVI2").                                           I
C HMINFC = 1E-5, LIMIT FACTOR STEPSIZE: H(N)>=HINIT.HMINFC.            I
C                ("CHKINI").                                           I
C HRLFAC = 2.0,  FACTOR TO LIMIT HNEW: 1/HRLFAC <= HNEW/HOLD <= HRLFAC.I
C                ("SOLVI2").                                           I
C LSBITS = 128,  7 BITS FOR COMPUTATIONAL LOSS; USED IN TOLERANCE      I
C                MATTERS ("CHKINI","ESCRGS").                          I
C MAXFIT = 15,   MAX. NUMBER OF FUNCTIONAL ITERATIONS.                 I
C                ("SOLSYS").                                           I
C MAXNIT = 10,   MAX. NUMBER OF NEWTON ITERATIONS.                     I
C                ("SOLNEW").                                           I
C NPGESC = 2,    NUMBER OF CONSECUTIVE TIMES IT IS ALLOWED TO FIND     I
C                POLYNOMIAL SOLUTION; IN CASE OF AUTOMATIC ESCAPE THE  I
C                LAST NPGESC+1 STEPS ARE DISCARDED ("ESCRGS", "YPOLM").I
C SAVFIL = 'COLSAV', FILE NAME ASSOCIATED WITH LOGICAL UNIT # CNTRL(4).I
C                ("SAVALL", "RELOAD").                                 I
C TOLFRS = 0.1,  FACTOR BY WHICH THE TOLERANCE FOR THE CORRECTOR ITER. I
C                PROCESS TO SOLVE THE COLLOC.EQ. FOR THE APPROX. IS    I
C                MULTIPLIED TO GET THE TOLERANCE FOR THE CORR.IT.PROC. I
C                TO COMPUTE THE REF.SOL. ("CHKINI","SOLVI2","ESCRGS"). I
C TOLMIN = LSBITS*SRELPR, MINIMUM TOLERANCE POSSIBLE (FOR "SRELPR" SEE I
C                BELOW) ("CHKINI","ESCRGS").                           I
C TOLMAX = 1.0,  MAXIMUM VALUE TO WHICH TOLERANCE MAY BE RELAXED.      I
C                ("SOLVI2").                                           I
C TOLREL = 4.0,  FACTOR TO RELAX THE TOLERANCE IN CASE IT CANNOT BE    I
C                SATISFIED WITH MIN. STEPSIZE ("SOLVI2").              I
C HDR    = ' ERROR COLVI2...', ("CHKINI", "CHKFIL").                   I
C MCDEF  = 81,   ("CHKINI").                                           I
C NCMI   = 23,   # VARIABLES IN COMMON /COLCMI/.  ("SAVALL", "RELOAD").I
C NCML   =  9,   # VARIABLES IN COMMON /COLCML/.  ("SAVALL", "RELOAD").I
C NCMR   =  6,   # VARIABLES IN COMMON /COLCMR/.  ("SAVALL", "RELOAD").I
C NCMIX  = 21,   # VARIABLES IN COMMON /COLIXW/.  ("SAVALL", "RELOAD").I
C                                                                      I
C                                                                      I
C DISTRIBUTION WKAREA:                                                 I
C -------------------                                                  I
C NOTE: (...!...!:...!...!...)   STANDS FOR:                           I
C ----  IF ... THEN ... ELSE IF ... THEN ... ELSE ... ENDIF            I
C GAUSS  = METH .EQ. 1                                                 I
C GAUSS1 = METH .EQ. 2                                                 I
C LEC    = VS .A. .N.GEC                                               I
C LOBAT  = METH .EQ. 3                                                 I
C LOBATR = METHR .EQ. 3                                                I
C IG     = METHR .EQ. 1                                                I
C FUNCIT = TRUE IF FUNCTIONAL IT. IS USED TO SOLVE COLLOC. SYSTEM      I
C NEWTON = TRUE IF NEWTON'S METH. WITH JACOBIAN UPDATING IS USED       I
C                                                                      I
C L      = ( LOBAT! 2! 1 )        ----                                 I
C S      = ( GAUSS1! M-1! M )        I                                 I
C ML     = M-L+1                     I IDEM LR,SR,MRL,SRL              I
C SL     = S-L+1                  ----                                 I
C MW     = MAX(MRL,ML).NEQN                                            I
C MB     = M+ML                                                        I
C NHC    = (TE-T0)/HC                                                  I
C NWKSYS = MW                                                          I
C NIRVEC = ( FUNCIT! 2.NEQN! NEQN.(1+NEQN) )                           I
C                                                                      I
C   1                                C(M)                              I
C IC1=  1+M                          W(S)                              I
C IC2=IC1+S                          LC(M) (C(L:M).C(L:S))             I
C IC3=IC2+M.ML.SL                    (GAUSS! LC(M) (1.0))              I
C                                    ((VS.O.GEETE).A..N.IG             I
C IC4=IC3+(GAUSS!M)                  ! CR(MR)                          I
C IC5=IC4+(VS.O.GEETE.A..N.IG!MR)      WR(SR)                          I
C IC6=IC5+(VS.O.GEETE.A..N.IG!SR)      LCR(MR) (CR(LR:MR).CR(LR:SR))   I
C                                    )                                 I
C                                    (GSSCKM                           I
C IC7=IC6+(VS.O.GEETE.A..N.IG        ! LC(M) (0.0)                     I
C         !MR.MRL.SRL)                                                 I
C IC8=IC7+(GSSCKM!M)                   LCG(0:M+1) (C(M)/2)             I
C                                    )                                 I
C                                                                      I
C ICE=IC8+(GSSCKM!(M+2).M)           (ULEC!LEESUM(NEQN*(NHC+1))        I
C IV1=ICE+(ULEC!NEQN.(NHC+1))        H(0:MAXNC)                        I
C IV2=IV1+MAXNC+1                      U(-NEQN:NEQN*ML*MAXNC-1)        I
C                                    (.N.IG.A.(GEC.O.GEETE)            I
C IV3=IV2+NEQN.(1+ML.MAXNC)          !UR(-NEQN:NEQN*MRL*MAXNC-1)       I
C                                    !:LEC!URN(-NEQN:NEQN*MRL-1)       I
C                                    )                                 I
C                                    (GSSCKM                           I
C IVE=IV3+                           !URN(NEQN)                        I
C     (.N.IG.A.(GEC.O.GEETE)                                           I
C     !NEQN.(1+MRL.MAXNC)                                              I
C     !:LEC!NEQN.(MRL+1))                                              I
C IL1=IVE+(GSSCKM!NEQN)               LAGN(NEQN)                       I
C IL2=IL1+(GSSCKM!NEQN)               LAGNP1(NEQN)                     I
C                                    )                                 I
C IL3=IL2+(GSSCKM!NEQN)              (IG!URNP1(NEQN))                  I
C                                    NOTE: (.NOT.GSSCKM!URNP1->LAGNP1) I
C                                    ----                              I
C IL4=IL3+(IG!NEQN)                  (ULEC!LEE(NEQN*(NHC+1))           I
C IL5=IL4+(ULEC!NEQN.(NHC+1))        (LEC!LAGSAV(0:NEQN*MB-1))         I
C ILAG=IL5+(LEC                      LAG(0:NEQN*ML-1)                  I
C          !NEQN.M)                  NOTE: (LEC!LAG -> SECOND PART     I
C                                    ----        OF LAGSAV)            I
C IL6=IL5+(LEC                       (GSSCKM! UN2(0:NEQN*M-1);         I
C         !NEQN.MB)                  NOTE: (.N.LEC!UN2 -> LAG)         I
C                                    ----                              I
C ILE=IL6+(GSSCKM!M.NEQN)            (GSSCKM!NYPOLM(NEQN))             I
C ITE=ILE+(GSSCKM!NEQN)              GLAG(NEQN*ML),(G)LAGR(NEQN*MRL)   I
C                                    AND (GSSCKM! GLAG(1/2)(NEQN*M) )  I
C IW1=ITE+MW                         CORR(MW) AND (LEC! CB(MB) )       I
C IW2=IW1+MW                         (.N.FUNCIT! DSYS(MW,MW))          I
C                                    (NEWTON                           I
C IW3=IW2+(.N.FUNCIT!MW.MW)          !WKAREA(MAX(NWKSYS,NIRVEC))       I
C                                    !:FUNCIT! WKAREA(NIRVEC)          I
C                                    !WKAREA(NWKSYS+NIRVEC))           I
C                                    (FOR LIN.SYS.SOL. AND TEMP. STOR.)I
C NOTE: (LEC! IW-IW1 SHOULD BE >= MB)                                  I
C ----                                                                 I
C                                                                      I
C U(TI+CJ.HI)(K) -> U(NEQN*ML*I + NEQN*(J-L) + K-1)                    I
C                   I=-1,J=M,K=1:NEQN; I=0:MAXNC-1,J=1:M,K=1:NEQN      I
C                                                                      I
C STORAGE OCCUPIED:                                                    I
C ----------------                                                     I
C M+S+M.ML.SL+1+(1+NEQN.ML).MAXNC+NEQN+MW+MW +                         I
C (GAUSS!                         M) +                                 I
C (VS.O.GEETE.A..N.IG!            MR+SR+MR.MRL.SRL) +                  I
C (GSSCKM!                        M+(M+2).M+NEQN.(4+M)) +              I
C (ULEC!                          2.NEQN.(NHC+1)) +                    I
C (.N.IG.A.(GEC.O.GEETE)!         NEQN.(1+MRL.MAXNC)) +                I
C (LEC.A..N.GEETE!                NEQN.(1+MRL)) +                      I
C (IG!                            NEQN) +                              I
C (LEC!                           NEQN.MB) +                           I
C (FUNCIT.A.LEC!                  MAX(NIRVEC,MB-MW)) +                 I
C (FUNCIT.A..N.LEC!               NIRVEC) +                            I
C (.N.FUNCIT!                     MW.MW) +                             I
C (NEWTON!                        MAX(NWKSYS,NIRVEC) +                 I
C (.N.FUNCIT.A..N.NEWTON!         NWKSYS+NIRVEC))                      I
C                                                                      I
C -------------------------------------------------------------------- I
C                                                                      I
C !!!!!!!! IMPORTANT !!!!!!!!! IMPORTANT !!!!!!!!! IMPORTANT !!!!!!!! !!
C          =========           =========           =========          !!
C MACHINE CONSTANTS:                                                  !!
C -----------------                                                   !!
C THE FOLLOWING MACHINE DEPENDENT CONSTANTS ARE USED IN THE PACKAGE:  !!
C                                                                     !!
C IBETA  RADIX OF THE FLOATING-POINT REPRESENTATION.                  !!
C IOVFLO LARGEST INTEGER VALUE "I"  SUCH THAT ALL INTEGERS IN [-I,+I] !!
C        ARE REPRESENTABLE INTEGER NUMBERS.                           !!
C NSDEC  NUMBER OF SIGNIFICANT DECIMAL DIGITS.                        !!
C IMXLUN LARGEST LOGICAL UNIT NUMBER ALLOWED BY THIS COMPILER.        !!
C        DEFINED AS 999; ANSI STANDARD: IOVFLO.                       !!
C SRELPR SMALLEST REAL VALUE "X" FOR WHICH   1.0-X < 1.0 < 1.0+X .    !!
C        (STORED VALUES).                                             !!
C SOVFLO LARGEST REAL VALUE "X"  SUCH THAT -X AND +X ARE              !!
C        REPRESENTABLE F.P. NUMBERS.                                  !!
C SUNFLO SMALLEST REAL VALUE "X" SUCH THAT -X AND +X ARE              !!
C        REPRESENTABLE F.P. NUMBERS.                                  !!
C                                                                     !!
C THEY ARE STORED IN THE COMMON BLOCKS /COLMCI/ AND /COLMCR/. THESE   !!
C COMMON BLOCKS ARE INITIALIZED BY THE ROUTINE "INICMC" (SEE BELOW).  !!
C                                                                     !!
C OTHER MACHINE DEPENDENCIES:                                         !!
C --------------------------                                          !!
C                                                                     !!
C _ SINCE THE PACKAGE HAS BEEN DEVELOPED ON A MACHINE WITH A RATHER   !!
C   LARGE WORD LENGTH, NO USE HAS BEEN MADE OF TYPE DOUBLE PRECISION  !!
C   TO REPRESENT FLOATING POINT NUMBERS. IF DOUBLE PRECISION IS       !!
C   REQUIRED CHANGE ALL TYPE REAL DECLARATIONS AND SPECIFICATIONS TO  !!
C   TYPE DOUBLE PRECISION. NO UNDECLARED OR UNSPECIFIED VARIABLES ARE !!
C   USED. FOR F.P. INTRINSIC FUNCTIONS THE GENERIC NAMES ARE CHOSEN.  !!
C   THE ROUTINES "DECLUF", "SOLLUF" AND "ZERPOL" SHOULD BE ADJUSTED   !!
C   AND THE DOUBLE PRECISION VERSION OF THE "MACHAR" ROUTINE SHOULD   !!
C   BE USED.                                                          !!
C                                                                     !!
C _ TO SAVE THE NEEDED VARIABLES IN CASE OF A DETECTED ERROR AND IF   !!
C   CNTRL(4)>0 AN EXTERNAL FILE WITH THE NAME "COLSAV" IS USED.       !!
C   IF THIS IS NOT A LEGITIMATE FILE NAME CHANGE THE RELEVANT         !!
C   PARAMETER STATEMENTS IN SUBROUTINES "SAVALL" AND "RELOAD".        !!
C                                                                     !!
C _ IF THE RECORD LENGTH (IN WORDS) OF A FILE OPENED FOR UNFORMATTED  !!
C   I/O AND SEQUENTIAL ACCESS IS SMALLER THAN THE SIZE OF THE WORKING !!
C   STORAGE "WKAREA" + 13 ADDITIONAL WORDS, THEN THE ROUTINES "SAVALL"!!
C   AND "RELOAD" HAVE TO BE ADJUSTED.                                 !!
C                                                                     !!
C _ TO MONITOR THE CPU-TIME USED THE SUBROUTINES "COLVI2", "SOLVI2",  !!
C   "SGEVI2" AND "CHKINI" INVOKE AN                                   !!
C      INTEGER FUNCTION NCPJOB ()                                     !!
C   THAT SHOULD RETURN THE NUMBER OF CPU SECONDS USED SINCE A SPECIFIC!!
C   TIME, E.G. THE START OF THE JOB.                                  !!
C   IN THE PACKAGE TWO VERSIONS OF "NCPJOB" ARE INCORPORATED. ONE FOR !!
C   A CDC CYBER-750 CALLING A REAL FUNCTION "SECOND". THE OTHER FOR A !!
C   VAX CALLING THE SYSTEM ROUTINE "ETIME".                           !!
C                                                                     !!
C _ TO INITIALIZE THE MACHINE CONSTANTS "CHKINI" CALLS A:             !!
C      SUBROUTINE INICMC                                              !!
C   THAT INVOKES THE ROUTINE "MACHAR" OF W.J. CODY TO AUTOMATICALLY   !!
C   DETERMINE SOME OF THE CONSTANTS. BOTH THE SINGLE AND THE DOUBLE   !!
C   PRECISION VERSION OF "MACHAR" ARE INCORPORATED.                   !!
C   "IOVFLO" IS SET TO 2**31-1 (WHICH IS CORRECT FOR 32-BIT INTEGERS; !!
C   AND ACCEPTABLE FOR MACHINES WITH LARGER INTEGERS, SINCE IT IS ONLY!!
C   USED AS "A LARGE VALUE"). "IMXLUN" IS SET TO 999 WHICH IS ALSO    !!
C   ACCEPTABLE FOR MOST OTHER MACHINES.                               !!
C                                                                     !!
C _ TO DECOMPOSE THE JACOBIAN AND TO SOLVE THE SYSTEM OF LINEAR       !!
C   EQUATIONS IN THE NEWTON PROCESS THE SUBROUTINES "DECLUF" AND      !!
C   "SOLLUF" ARE CALLED BY "SOLNEW". THE HEADERS ARE:                 !!
C      SUBROUTINE DECLUF (A, N, IA, WKAREA, IERROR)                   !!
C      INTEGER N, IA, IERROR                                          !!
C      REAL A(IA,*), WKAREA(*)                                        !!
C   AND                                                               !!
C      SUBROUTINE SOLLUF (A, N, IA, B, WKAREA, IERROR)                !!
C      INTEGER N, IA, IERROR                                          !!
C      REAL A(IA,*), B(*), WKAREA(*)                                  !!
C   THERE ARE TWO VERSIONS OF THESE ROUTINES. ONE THAT ASSUMES THE    !!
C   AVAILABILITY OF AN IMSL LIBRARY ("DECLUF" CALLS "LUDATF" AND      !!
C   "SOLLUF" CALLS "LUELMF"). THE OTHER MAKES USE OF A SIMPLE         !!
C   (INCORPORATED) AX=B SOLVER (GAUSS ELIMINATION).                   !!
C   IF ANOTHER SYSTEM SOLVER NEEDS MORE WORK SPACE SOME STATEMENTS    !!
C   HAVE TO BE ALTERED IN ROUTINES "CHKINI" AND "ESCRGS".             !!
C                                                                     !!
C _ TO DETERMINE THE HIGHER ORDER COLLOCATION PARAMETERS THE ROUTINE  !!
C   "ZERPOL" IS CALLED:                                               !!
C      SUBROUTINE ZERPOL (C, N, S, IERROR)                            !!
C      INTEGER N, IERROR                                              !!
C      REAL C(0:N), S(N)                                              !!
C   THAT SHOULD RETURN IN "S" THE SORTED REAL ZEROS OF THE POLYNOMIAL !!
C   C(0).Z**N + C(1).Z**(N-1) +...+ C(N-1).Z + C(N) = 0.              !!
C   ONE VERSION OF "ZERPOL" CALLS THE SUBROUTINE "ZPOLR" OF THE IMSL  !!
C   LIBRARY. THE SECOND VERSION INVOKES THE ACM-TOMS ROUTINE "RPOLY"  !!
C   (ALSO INCORPORATED).                                              !!
C   NB: DUE TO INTERNALLY DECLARED ARRAYS THE MAXIMUM DEGREE OF THE   !!
C   POLYNOMIAL IS 100.                                                !!
C                                                                     !!
C !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!
C                                                                      I
C -------------------------------------------------------------------- I
C
      RETURN
      END
      SUBROUTINE COLVI2
     +   (NEQN, G,KC,DKCDY,LINEAR, T0,TE, REQTOL,
     +    DEFOPT, IOPT,OPT,CNTRL, WKAREA,IW, TNC, UE, GEE, IERROR)
C
C ---------------------------------------------------------------------I
C PURPOSE: SOLVE SYSTEM OF VIE2'S. FOR A DESCRIPTION OF "COLVI2" SEE   I
C -------  SUBROUTINE "COLDOC".                                        I
C                                                                      I
C COMMON VARIABLES:                                                    I
C ----------------                                                     I
      INTEGER METH, M, S, L, ORDER, ORDERQ, METHR, MR, SR, LR, ORDERR,
     +        ERRWGT, NHFAIL, NERR, NWIR, NSAV,
     +        MAXNC, MAXKEV, MAXCPS, N, NCIT, NKEV, NCPS
      COMMON /COLCMI/ METH, M, S, L, ORDER, ORDERQ,
     +                METHR, MR, SR, LR, ORDERR,
     +                ERRWGT, NHFAIL,
     +                NERR, NWIR, NSAV,
     +                MAXNC, MAXKEV, MAXCPS,
     +                N, NCIT, NKEV, NCPS
*
      LOGICAL VS, GSSCKM, ESCGSS, GEC, ULEC, RLXTOL, GEETE,
     +        FUNCIT, NEWTON
      COMMON /COLCML/ VS, GSSCKM, ESCGSS, GEC, ULEC, RLXTOL, GEETE,
     +                FUNCIT, NEWTON
*
      REAL TOLLE, TOLCIA, TOLCIR, HMIN, HMAX, HC
      COMMON /COLCMR/ TOLLE, TOLCIA, TOLCIR, HMIN, HMAX, HC
*
      INTEGER IC1,IC2,IC3,IC4,IC5,IC6,IC7,IC8,ICE, IV1,IV2,IV3,IVE,
     +        IL1,IL2,IL3,IL4,IL5,ILAG,IL6,ILE
      COMMON /COLIXW/ IC1,IC2,IC3,IC4,IC5,IC6,IC7,IC8,ICE,
     +                IV1,IV2,IV3,IVE, IL1,IL2,IL3,IL4,IL5,ILAG,IL6,ILE
*
      SAVE /COLCMI/, /COLCML/, /COLCMR/, /COLIXW/
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER NEQN, DEFOPT, IW, IERROR
      INTEGER IOPT(*), CNTRL(*)
      LOGICAL LINEAR
      REAL T0, TE, REQTOL, TNC
      REAL OPT(*), WKAREA(IW), UE(NEQN), GEE(NEQN)
      EXTERNAL G, KC, DKCDY
C                                                                      I
C INVOKED BY: USER PROGRAM                                             I
C ----------                                                           I
C                                                                      I
C CHANGES IN COMMON VARIABLES:                                         I
C ---------------------------                                          I
C NCPS   # CP SECONDS USED TO SOLVE VIE2                               I
C                                                                      I
C LOCAL VARIABLES:                                                     I
C ---------------                                                      I
      CHARACTER*15 VAROUT
      LOGICAL FENTRY, GAUSS, LEC, RSITCL, ZLEESM
      REAL HINIT
C FENTRY TRUE IF THIS IS THE FIRST CALL OF "COLVI2"                    I
C ZLEESM TRUE IF "LEESUM" PART OF "WKAREA" HAS TO BE ZEROED; I.E.      I
C        IF UNIFORM ERROR CONTROL IS USED AND NO PREVIOUSLY COMPUTED   I
C        RELEVANT SUM OF LOCAL ERRORS IS AVAILABLE.                    I
C HINIT  INITIAL GUESS FOR LENGTH OF FIRST SUBINTERVAL.                I
C                                                                      I
C ---------------------------------------------------------------------I
C
      INTEGER NCPJOB
      EXTERNAL NCPJOB
*
      IERROR = 0
C
C
C CHECK PARAMETERS AND INITIALIZE COMMON; REACT ON RE-ENTRY
C    (RE)DISTRIBUTE WORKING STORAGE
      CALL CHKINI (NEQN, G, T0,TE, REQTOL, DEFOPT,IOPT,OPT,CNTRL,
     +             WKAREA,IW, TNC, HINIT, ZLEESM, IERROR)
C   RETURN IF SOMETHING WAS WRONG
      IF (IERROR .NE. 0) RETURN
C
C
      FENTRY = N .EQ. 0
      GAUSS  = METH .EQ. 1
      LEC    = VS .AND. .NOT. GEC
      RSITCL = METHR .EQ. 1
C
C
C IF FIRST ENTRY, OR IF NEW OPTION VECTORS ARE GIVEN:
C   INITIALIZE COLLOCATION PARAMETERS, WEIGHT FACTORS AND
C   LAGRANGIAN INTERPOLATION COEFFICIENTS.
      IF (DEFOPT .EQ. 0) THEN
C            RE-ENTRY, OLD OPTION VECTIONS
         IF (CNTRL(1) .GT. 2) GOTO 40
C            FIRST CALL OF COLVI2
         IF (FENTRY) GOTO 10
C        RE-ENTRY, NEW OPTION VECTORS
         IF (.NOT. GEC) GOTO 20
         GOTO 30
      ENDIF
*
C      INITIALIZE COLL.PARS. FOR APPROX. OF SOL.
   10 CALL COLCWL (METH, M, WKAREA(1),WKAREA(IC1),WKAREA(IC2), IERROR)
      IF (IERROR .NE. 0) RETURN
C      CALCULATE LAGR.INT.POL. COEFF. U(TN+1)
      IF (GAUSS) CALL COMPLV (1.0, M, WKAREA(1), WKAREA(IC3))
*
   20 IF ((VS .OR. GEETE) .AND. .NOT. RSITCL) THEN
C      ERROR ESTIMATION REQUIRED, NO ITERATED COLLOCATION
C      INITIALIZE COLL.PARS. REF. SOL.
         CALL COLCWL (METHR, MR, WKAREA(IC4), WKAREA(IC5), WKAREA(IC6),
     +                IERROR)
         IF (IERROR .NE. 0) RETURN
      ENDIF
*
   30 IF (GSSCKM) THEN
C      CALCULATE LAGR.INT. COEFF. U(TN)
         CALL COMPLV (0.0, M, WKAREA(1), WKAREA(IC7))
C      CALCULATE LAGR.INT. COEFF. UR(TN)
         CALL COMPLG (M, WKAREA(1), WKAREA(IC8), WKAREA(ILE))
      ENDIF
C
C
C SOLVE VIE2 WITH CHOSEN COLLOCATION METHOD.
C
C   STORE INITIAL STEPSIZE IN H(N)
   40 WKAREA(IV1+N) = HINIT
C
C   INITIALIZE, IF NEEDED, SOLUTION AND REF. SOL. VECTORS, AND
C      THE VECTOR CONTAINING THE SUM OF THE LOCAL ERRORS
      CALL INIVEC (FENTRY,
     +             FENTRY .AND. (.NOT.RSITCL .AND. GEC), LEC,
     +             GSSCKM, ZLEESM, NEQN, G, TNC, TE, WKAREA(IV2),
     +             WKAREA(IV3), WKAREA(IVE), WKAREA(ICE))
C
C   SOLVE VIE2; IF EXIT OK: TNC=TE, UE=U(TE),
C                           GEE=GLOBAL ERROR IN TE, IF (GEC)
      CALL SOLVI2 (NEQN, G,KC,DKCDY,LINEAR, T0,TE,
     +             WKAREA(1),WKAREA(IC1),WKAREA(IC2),
     +             WKAREA(IV1),WKAREA(IV2),
     +             WKAREA(IC4),WKAREA(IC5),WKAREA(IC6),WKAREA(IV3),
     +             WKAREA(ILAG), WKAREA(IL5),
     +             WKAREA(ICE), ZLEESM, WKAREA(IL4),
     +             WKAREA(IC3), WKAREA(IC7), WKAREA(IC8),
     +             WKAREA(IL6), WKAREA(IL1), WKAREA(IL2),
     +             WKAREA(IVE), WKAREA(IL3), WKAREA(ILE),
     +             TNC, UE, GEE, IERROR)
      IF ((IERROR .EQ. 15) .AND. ESCGSS) THEN
C   SOLUTION IS POLYNOMIAL; ESCAPE TO HIGHER ORDER METHOD FOR REF.SOL.
C      AND LOCAL + UNIFORM ERROR CONTROL
         IERROR = 0
         CALL ESCRGS (NEQN, WKAREA,IW, T0, TE, TNC, IERROR)
         IF (IERROR .NE. 0) GOTO 910
C
C   SOLVE VIE2; IF EXIT OK: TNC=TE, UE=U(TE)
         ZLEESM = .TRUE.
         CALL SOLVI2 (NEQN, G,KC,DKCDY,LINEAR, T0,TE,
     +                WKAREA(1),WKAREA(IC1),WKAREA(IC2),
     +                WKAREA(IV1),WKAREA(IV2),
     +                WKAREA(IC4),WKAREA(IC5),WKAREA(IC6), WKAREA(IV3),
     +                WKAREA(ILAG), WKAREA(IL5),
     +                WKAREA(ICE), ZLEESM, WKAREA(IL4),
     +                WKAREA(IC3), WKAREA(IC7), WKAREA(IC8),
     +                WKAREA(IL6), WKAREA(IL1), WKAREA(IL2),
     +                WKAREA(IVE), WKAREA(IL3), WKAREA(ILE),
     +                TNC, UE, GEE, IERROR)
      ENDIF
C
C
C CHECK IF ALL WENT WELL
C
      IF (IERROR .NE. 0) GOTO 910
C
C
C IF GLOBAL ERROR CONTROL HAS BEEN USED "GEE" CONTAINS GLOBAL ERROR
C IN "TE"; OTHERWISE
C IF GLOBAL ERROR EST. IN TE IS REQUIRED PERFORM (ITERATED) COLL. TO
C COMPUTE REFERENCE SOLUTION IN "TE"; IF NOT, STORE IN "GEE"
C SUM OF LOCAL ERRORS IN "TE', IF AVAILABLE.
      IF (.NOT.GEC) THEN
         IF (GEETE) THEN
C          COMPUTE REFERENCE SOLUTION IN TE; ON EXIT: GEE=UR(TE)
            IF (RSITCL) THEN
C             ITERATED COLLOCATION, RESTORE OLD N VALUE
               N = N-1
               CALL ITRCOL (TE, NEQN, G,KC, T0, WKAREA(IV1), WKAREA(1),
     +                      WKAREA(IC1),WKAREA(IV2),WKAREA(ILE),GEE,GEE)
               N = N+1
            ELSE
C             SOLVE VIE2 WITH COL.PARS. FOR REF.SOL. USING THE SAME
C             STEPSIZES AS BEFORE
C
C              STORE Y(T0) IN UR
               CALL COPYV (WKAREA(IV2), NEQN, WKAREA(IV3))
*
               CALL SGEVI2 (NEQN, G,KC,DKCDY,LINEAR, T0,
     +                      WKAREA(IC4), WKAREA(IC5), WKAREA(IC6),
     +                      WKAREA(IV1), WKAREA(IV3),
     +                      WKAREA(ILE), TNC, GEE, IERROR)
               IF (IERROR .NE. 0) GOTO 900
            ENDIF
C         COMPUTE GLOBAL ERROR IN TE
            CALL ADDABV (GEE, NEQN, -1.0, UE)
         ELSE IF (ULEC) THEN
C         STORE SUM OF LOCAL ERRORS IN "TE", LEESUM(0:NEQN-1), IN GEE
            CALL COPYV (WKAREA(ICE), NEQN, GEE)
         ENDIF
      ENDIF
C
C
C COMPUTE NUMBER OF CP-SECONDS USED
      NCPS = NCPJOB() - NCPS
      RETURN
C
C ALAS!
  900 CONTINUE
      CALL ERRMSG ('PROBLEMS WITH COMPUTATION OF GLOBAL ERROR IN "TE"')
  910 CONTINUE
      WRITE(VAROUT,'(E15.5)') TNC
      CALL ERRMSG ('ENDPOINT NOT REACHED, LAST T-VALUE :'//VAROUT)
C
C IF REQUIRED SAVE VARIABLES ON FILE FOR RE-ENTRY
      IF (NSAV .NE. 0) CALL SAVALL (WKAREA,IW, DEFOPT,IOPT,OPT, TE, TNC)
*
C
C COMPUTE NUMBER OF CP-SECONDS USED
      NCPS = NCPJOB() - NCPS
      RETURN
      END
      SUBROUTINE SOLVI2
     +   (NEQN, G,KC,DKCDY,LINEAR, T0,TE, C,W,LC, H, U, CR,WR,LCR, UR,
     +    LAG,  LAGSAV, LEESUM,ESTGEE,LEE, LC1, LC0,LCG,UN2,LAGN,LAGNP1,
     +    URN, URNP1, WKAREA, TN, UN, GEE, IERROR)
C
C ---------------------------------------------------------------------I
C PURPOSE: SUPERVISE PROCESS OF SOLVING VIE2; PERFORM ERROR CONTROL,   I
C -------  MONITOR STEPS, CHECK ON POLYNOMIAL SOLUTION, IF REQUIRED.   I
C                                                                      I
C COMMON VARIABLES:                                                    I
C ----------------                                                     I
      INTEGER METH, M, S, L, ORDER, ORDERQ, METHR, MR, SR, LR, ORDERR,
     +        ERRWGT, NHFAIL, NERR, NWIR, NSAV,
     +        MAXNC, MAXKEV, MAXCPS, N, NCIT, NKEV, NCPS
      COMMON /COLCMI/ METH, M, S, L, ORDER, ORDERQ,
     +                METHR, MR, SR, LR, ORDERR,
     +                ERRWGT, NHFAIL,
     +                NERR, NWIR, NSAV,
     +                MAXNC, MAXKEV, MAXCPS,
     +                N, NCIT, NKEV, NCPS
*
      LOGICAL VS, GSSCKM, ESCGSS, GEC, ULEC, RLXTOL, GEETE,
     +        FUNCIT, NEWTON
      COMMON /COLCML/ VS, GSSCKM, ESCGSS, GEC, ULEC, RLXTOL, GEETE,
     +                FUNCIT, NEWTON
*
      REAL TOLLE, TOLCIA, TOLCIR, HMIN, HMAX, HC
      COMMON /COLCMR/ TOLLE, TOLCIA, TOLCIR, HMIN, HMAX, HC
*
      REAL SRELPR, SOVFLO, SUNFLO
      COMMON /COLMCR/ SRELPR, SOVFLO, SUNFLO
*
      SAVE /COLCMI/, /COLCML/, /COLCMR/, /COLMCR/
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER NEQN, IERROR
      LOGICAL LINEAR, ESTGEE
      REAL T0, TE, TN
      REAL C(M), W(S), LC(M,L:M,L:S),
     +     H(0:MAXNC), U(-NEQN:NEQN*(M-L+1)*MAXNC-1),
     +     CR(*),WR(*),LCR(MR,LR:MR,LR:*), UR(-NEQN:*),
     +     LAG(0:NEQN*(M-L+1)-1), LAGSAV(0:*), LEESUM(*), LEE(*),
     +     LC1(*),LC0(*), LCG(0:M+1,*), UN2(0:*), LAGN(*), LAGNP1(*),
     +     URN(*), URNP1(*),
     +     WKAREA(*), UN(NEQN), GEE(NEQN)
      EXTERNAL G, KC, DKCDY
C C      -   COLL. VARS NEEDED                                         I
C W      I-> TO APPROXIMATE                                            I
C LC     -   SOLUTION.                                                 I
C H      ENTRY: H(0:N-1) SUBINT. LENGTHS OF ALL PREVIOUS STEPS TAKEN   I
C               H(N) INITIAL GUESS FOR STEPSIZE IN N-TH INTERVAL       I
C        EXIT:  H(0:NC-1) SUBINT. LENGTHS OF ALL STEPS TAKEN (TNC = TN)I
C               H(NC) INITIAL GUESS FOR LENGTH NEXT SUBINTERVAL        I
C U      ENTRY: SHOULD CONTAIN U(TI+CJ.HI) I=0:N-1,J=1:M               I
C               NOTE: U(-NEQN:-1) SHOULD CONTAIN Y(T0)                 I
C        EXIT:  CONTAINS U(TI+CJ.HI) I=0:NC-1,J=1:M                    I
C        U(TIJ) -> U(NEQN*((M-L+1)*I+(J-L))+(0:NEQN-1))                I
C CR     -   COLL. VARS FOR REF. SOL (NOT NEEDED IF CONSTANT STEPSIZES I
C WR     I-> WILL BE USED OR IF THE REF. SOL. IS COMPUTED WITH         I
C LCR    -   ITERATED COLLOCATION.                                     I
C UR     IF GLOBAL ERROR CONTROL IS REQUIRED AND THE REF.SOL. METHOD   I
C        IS NOT ITERATED COLLOCATION:                                  I
C           ENTRY: SHOULD CONTAIN UR(TI+CRJ.HI) I=0:N-1,J=1:M          I
C                  NOTE: UR(-NEQN:-1) SHOULD CONTAIN Y(T0)             I
C           EXIT:  CONTAINS UR(TI+CRJ.HI) I=0:NC-1,J=1:MR              I
C           UR(TIJ) -> UR(NEQN*((MR-LR+1)*I+(J-LR))+(0:NEQN-1))        I
C        IF LOCAL ERROR CONTROL HAS BEEN SELECTED:                     I
C           ENTRY: UR(-NEQN:-1) SHOULD CONTAIN UR(TN)                  I
C           EXIT:  UR(-NEQN:-1) CONTAINS UR(TNC)                       I
C                  UR(0:NEQN*(MR-LR+1)-1) CONT. UR(T(NC-1)+CRJ.H(NC-1))I
C                                               J=LR:MR                I
C LAG    WORKING STORAGE FOR LAGTERM FCN(TN+CJ.HN) J=L:M               I
C        FCN(TNJ) -> LAG(NEQN*(J-L)+(0:NEQN-1))                        I
C LAGSAV IN CASE OF LOCAL ERROR CONTROL:                               I
C        WORKING STORAGE FOR LAGTERM FCN(TN-H(N-1)+CJ.H(N-1)) AND      I
C                                    FCN(TN+CJ.HN)  J=1:M              I
C        FCN(TNM1+CJ.HNM1) -> LAGSAV(NEQN*(J-1)+(0:NEQN-1))  J=1:M     I
C        FCN(TNJ)          -> LAGSAV(NEQN*(M+J-L)+(0:NEQN-1)) J=L:M    I
C        NOTE: IN THIS CASE LAG SHARES THE STORAGE LOCATIONS WITH      I
C        ----  LAGSAV(NEQN*M:NEQN*(2*M-L+1)-1)                         I
C LEESUM IF UNIFORM ERROR CONTROL HAS BEEN SELECTED:                   I
C        ENTRY: LEESUM(I*NEQN+(1:NEQN)) SHOULD CONTAIN EITHER 0.0 OR   I
C               (K=0,N-1) SUM LEE_K(I*NEQN+(1:NEQN)) I=0,...           I
C               (LOCAL ERRORS OVER (TK,TK+1) IN TI)  T=TI=TE,(-HC),TN  I
C               (CF. CHKINI)                                           I
C        EXIT:  APPROX.OF (K=0,NC-1) SUM LEE_K(I*NEQN+(1:NEQN)) I=0,...I
C ESTGEE IF UNIFORM ERROR CONTROL HAS BEEN SELECTED:                   I
C        ENTRY: TRUE IF NO ERROR ESTIMATES OVER [T0,TN] ARE AVAILABLE  I
C LEE    IF UNIFORM ERROR CONTROL:                                     I
C        WORKING STORAGE FOR LOCAL ERROR EST. IN T=TI FOR I=0,...      I
C LC1    IF APPROX. METH. IS GAUSS:                                    I
C        COLL. VAR. FOR COMPUT. OF SOL. IN STEPPOINTS                  I
C        -I IF CHECK ON POL. SOL. IS REQUIRED:                         I
C LC0     I LAGR.COEFF.TO COMPUTE SOL. IN TN                           I
C LCG     I LAGR.COEFF.TO COMPUTE FCN(TN+CJ.HN/2)                      I
C UN2     I WORKING STORAGE FOR U(TN+CJ.HN/2) (0:NEQN*M-1)             I
C LAGN    I WORKING STORAGE FOR FCN(TN)                                I
C LAGNP1  I STORAGE FOR FCN(TNP1)                                      I
C URN    -I ENTRY: UR(TN)                                              I
C URNP1  IF REF.SOL. IS COMPUTED WITH ITERATED COLLOCATION:            I
C        WORKING STORAGE FOR UR(TN+HN)                                 I
C WKAREA WORKING STORAGE FOR INTERMEDIATE VECTOR RESULTS AND           I
C        FOR SOLVING THE COLL. SYSTEM (CF. SOLSYS)                     I
C TN     ENTRY: LEFT ENDPOINT OF N-TH SUBINTERVAL                      I
C        EXIT:  RIGHT ENDPOINT OF LAST SUBINTERVAL                     I
C UN     EXIT: APPROX.SOL. IN "TN"                                     I
C GEE    EXIT: IN CASE OF GLOBAL ERROR CONTROL:                        I
C              GLOBAL ERROR ESTIMATE IN "TN"                           I
C IERROR ENTRY: 0                                                      I
C        EXIT:  0: OK                                                  I
C              11: FAILURE WITH MINIMUM STEPSIZE                       I
C              12: SIZE WORKING STORAGE AREA TOO SMALL                 I
C              13: # KERNEL EVAL. > MAX. # KERN. EV. ALLOWED           I
C              14: # CPU-SECONDS > MAX. # CPU-SEC. ALLOWED             I
C              15: POLYNOMIAL SOLUTION                                 I
C              16: TOLERANCE WOULD BE RELAXED TO A VALUE > 1.0         I
C              OTHER: ERRORS FROM "SOLSYS"                             I
C                                                                      I
C INVOKED BY: COLVI2                                                   I
C ----------                                                           I
C                                                                      I
C CHANGES IN COMMON VARIABLES:                                         I
C ---------------------------                                          I
C NHFAIL ADDED 1 AFTER EACH FAILED STEP                                I
C N      ADDED 1 AFTER EACH SUCCESSFUL STEP                            I
C TOLLE  + INCREASED BY A FACTOR TOLREL, IF STEP                       I
C TOLCIA I FAILED WITH MINIMUM STEPSIZE                                I
C TOLCIR +                                                             I
C                                                                      I
C CONSTANTS:                                                           I
C ---------                                                            I
      REAL HFAC, HFLFAC, HRLFAC, TOLFRS, TOLMAX, TOLREL
      PARAMETER (HFAC   = 0.9)
      PARAMETER (HFLFAC = 0.25)
      PARAMETER (HRLFAC = 2.0)
      PARAMETER (TOLFRS = 0.1)
      PARAMETER (TOLMAX = 1.0)
      PARAMETER (TOLREL = 4.0)
C                                                                      I
C LOCAL VARIABLES:                                                     I
C ---------------                                                      I
      CHARACTER*10 VAROUT
      INTEGER IHFAIL, INDEXN, INDXRN, INDRN1, ITE, IW1,IW2,IW3, MW, NC
      LOGICAL GAUSS, LAST, LEC, LOBAT, LOBATR, RSITCL, WRINT
      REAL GELIML,GELIMU, HMINN, HNM1,HN, INVP,INVQ,
     +     LELIML,LELIMU, WGEE, WLEE, WULEE
C IHFAIL # OF STEPS FAILED IN THE CURRENT SUBINTERVAL                  I
C INDEXN POINTER TO SOLUTION IN 1-ST COLLOC.POINT IN N-TH INTERVAL     I
C INDXRN POINTER TO REF.SOL. IN 1-ST COLLOC.POINT IN N-TH INTERVAL     I
C INDRN1 POINTER TO REF.SOL. IN TN+HN                                  I
C ITE, ..., IW3 POINTERS TO WKAREA LOCATIONS (CF. "COLDOC" SUB         I
C        "DISTRIBUTION WKAREA"                                         I
C MW     MAX. DIMENSION COLLOCATION SYSTEM TO BE SOLVED                I
C NC     # STEPS TO BE TAKEN IN CASE OF CONSTANT STEPSIZES             I
C LAST   TRUE, IF TN+HN = TE                                           I
C WRINT  TRUE, IF INTERMEDIATE RESULTS ARE REQUIRED                    I
C GELIML - LIMITS TO ERROR TERM IN GLOBAL ERROR CONTROLLED STEPSIZE    I
C GELIMU / STRATEGY, SO THAT RESULTING FACTOR LIES BETWEEN 0.5 AND 2.0 I
C HMINN  MIN. STEPSIZE FOR CURRENT SUBINTERVAL                         I
C HNM1   LENGTH PREVIOUS SUBINTERVAL                                   I
C HN     GUESS FOR LENGTH CURRENT SUBINTERVAL, STORED IN H(N)          I
C INVP   1/ORDER  - POWERS USED IN                                     I
C INVQ   1/ORDERQ / STEPSIZE STRATEGY                                  I
C LELIML - LIMITS TO ERROR TERM IN LOCAL ERROR CONTROLLED STEPSIZE     I
C LELIMU / STRATEGY, SO THAT RESULTING FACTOR LIES BETWEEN 0.5 AND 2.0 I
C WGEE   WEIGHTED NORM OF GLOBAL ERROR IN TN+HN                        I
C WLEE   WEIGHTED NORM OF LOCAL ERROR IN TN+HN                         I
C WULEE  MAX. OF WEIGHTED NORMS OF ERRORS OVER [TN+HN,TE]              I
C                                                                      I
C ---------------------------------------------------------------------I
C
      INTEGER J, ML, MRL, MWR, MWS, NCPJOB, NL2, NLR2
      LOGICAL ACCEPT, RSFAIL, POLY, YPOLM
      REAL FACH, LEEWGT, R, UEEWGT, WMXNRM
      EXTERNAL LEEWGT, NCPJOB, UEEWGT, WMXNRM, YPOLM
*
      ML     = M-L+1
      MRL    = MR-LR+1
C
C
C DISTRIBUTE WORKING STORAGE "WKAREA" FOR "YPOLM",
C    LAG TERMS AND LINEAR SYSTEM SOLVER
      MWS    = ML*NEQN
      MWR    = MRL*NEQN
      MW     = MAX(MWS, MWR)
      IF (GSSCKM) THEN
         ITE    = 1+NEQN
      ELSE
         ITE    = 1
      ENDIF
      IW1    = ITE + MW
      IW2    = IW1 + MW
      IF (FUNCIT) THEN
         IW3    = IW2
      ELSE
         IW3    = IW2 + MW*MW
      ENDIF
C
C
C INITIALIZE LOOP CONSTANTS AND VARIABLES
      GAUSS  = METH .EQ. 1
      LAST   = .FALSE.
      LEC    = VS .AND. .NOT.GEC
      LOBAT  = L  .EQ. 2
      LOBATR = LR .EQ. 2
      RSITCL = METHR .EQ. 1
      WRINT  = (NWIR .NE. 0)
*
      IHFAIL = 0
      IF (.NOT. VS) THEN
         R      = (TE-TN)/H(N)
         NC     = INT(R)
         IF (R-NC .GT. 0.0) NC = NC+1
         NC     = NC + N
      ENDIF
      INDXRN = NEQN*(1-LR)
      NL2    = NEQN*(L -2)
      NLR2   = NEQN*(LR-2)
*
      GELIML = TOLLE / (HRLFAC**ORDER)
      GELIMU = TOLLE * (HRLFAC**ORDER)
      HN     = H(N)
      IF (LEC) THEN
         IF (N .EQ. 0) THEN
            HNM1   = HN
         ELSE
            HNM1   = H(N-1)
         ENDIF
      ENDIF
      INVP   = 1.0 / ORDER
      INVQ   = 1.0 / ORDERQ
      LELIML = TOLLE / (HRLFAC**ORDERQ)
      LELIMU = TOLLE * (HRLFAC**ORDERQ)
*
      IF (GSSCKM) THEN
C      ZERO NYPOLM (# CONSEC. TIMES SOLUTION BEHAVES AS A POLYNOMIAL)
         CALL ZEROV (WKAREA(1), NEQN)
C      STORE FCN(TN) IN LAGN
         CALL INILGN (TN, NEQN,G, U, LC1, WKAREA(IW3), LAGN)
      ENDIF
*
      IF (LEC)
C      IN CASE OF LOC. ERR. CONTR. COMPUTE FCN(T(N-1)+CJ.HN-1) J=1,...,M
C      AND STORE IN LAGSAV
     +   CALL INILAG (TN, NEQN,G,KC, C,W,LC,LOBAT, H, U,
     +          WKAREA(IW3), LAGSAV)
      GOTO 100
C
C
C LOOP ENTRY IN CASE A FAILURE WITH MINIMUM STEPSIZE OCCURRED.
   90 IF (.NOT.RLXTOL .OR. N .EQ. 0) GOTO 920
*
C      RELAX TOLERANCE; USE H(N-1) AS INITIAL GUESS FOR STEPSIZE
      TOLLE  = TOLLE  * TOLREL
      IF (TOLLE .GT. TOLMAX)
C      TOLERANCE RELAXED UP TO 1; NO USE TO GO ON
     +    GOTO 930
*
      WRITE(VAROUT,'(E10.3)') TN
      CALL ERRMSG ('CANNOT MEET REQTOL, FAILURE WITH MIN. H IN T='//
     +             VAROUT)
      WRITE(VAROUT,'(E10.3)') TOLLE
      CALL ERRMSG ('   REQTOL RELAXED TO '//VAROUT)
      IF (TOLCIR/TOLCIA .LE. TOLFRS) TOLCIR = TOLCIR * TOLREL
      TOLCIA = TOLCIA * TOLREL
      GELIML = TOLLE / (HRLFAC**ORDER)
      GELIMU = TOLLE * (HRLFAC**ORDER)
      LELIML = TOLLE / (HRLFAC**ORDERQ)
      LELIMU = TOLLE * (HRLFAC**ORDERQ)
      HN     = H(N-1)
C
C
C LOOP UNTIL "TE" IS REACHED
  100 CONTINUE
C
C   LIMIT HN
C      COMPUTE MIN. STEPSIZE FOR THIS INTERVAL
      HMINN  = MAX(HMIN,SRELPR*ABS(TN))
      HN     = MAX(HN,HMINN)
      HN     = MIN(HN,HMAX)
      IF (TE-(TN+HN) .LE. ABS(TE)*SRELPR) THEN
         HN     = TE-TN
         LAST   = .TRUE.
      ELSE IF (TE-(TN+1.5*HN) .LE. ABS(TE)*SRELPR) THEN
C      AVOID A VERY SMALL LAST STEPSIZE (ERROR ESTIMATION PROBLEMS)
         HN     = (TE-TN)/1.5
      ENDIF
C
C
C ENTRY LOOP IN CASE OF CONSTANT STEPSIZES
  110 CONTINUE
      IERROR = 0
      INDEXN = NEQN*(1-L+ML*N)
C
C   STORE INITIAL GUESS OF HN
      H(N) = HN
C
C   CHECK # KEV
      IF (NKEV .GT. MAXKEV) GOTO 900
C
C   CHECK CPU-TIME
      IF (NCPJOB()-NCPS .GT. MAXCPS) GOTO 910
C
C
CCCCCCCCCC SOLVE COLLOCATION EQUATIONS ON [TN,TN+HN]
C
C      INITIALIZE U(TN+CJ.HN) ON U(TN)
      DO 200 J = L, M
         CALL COPYV (U(INDEXN+NL2), NEQN, U(INDEXN+NEQN*(J-1)))
  200 CONTINUE
*
      CALL SLQCE2 (TN,H, NEQN, G,KC,DKCDY,LINEAR, T0,
     +       C,W,LC, M,S,L, LOBAT, TOLCIA, .FALSE.,
     +       LAG, WKAREA(ITE),WKAREA(IW1),WKAREA(IW2),MWS,
     +       WKAREA(IW3), U, LAGNP1, IERROR)
C
C CHECK IF ALL WENT WELL
      IF (IERROR .NE. 0) THEN
C   CONTINUE ONLY IF CONVERGENCE PROBLEMS IN VARIABLE STEP SIZE CASE
         IF (.NOT.(VS .AND. IERROR .EQ. 21)) GOTO 980
C    TRY AGAIN
         IHFAIL = IHFAIL + 1
         IF (HN .LE. HMINN) THEN
C      IF FAILED WITH MINIMUM STEPSIZE RELAX TOLERANCE (IF ALLOWED)
            GOTO 90
         ELSE
C      IF NOT, DECREASE STEPSIZE
            HN     = HN*HFLFAC
         ENDIF
         GOTO 100
      ENDIF
C
C
C OK; STORE SOLUTION IN TN+HN IN UN
      IF (GAUSS) THEN
C      COMPUTE COLLOCATION SOLUTION IN TN+HN WITH LAGR. INTERP.
         CALL UTILIP (NEQN, U(INDEXN), LC1, UN)
      ELSE
         CALL COPYV (U(INDEXN+NEQN*(M-1)), NEQN, UN)
      ENDIF
*
*
      IF (.NOT. VS) THEN
C
C
CCCCCCCCCC CONSTANT STEPSIZES; ADJUST LOOPVARIABLES
C
         IF (WRINT) CALL WRIRES (TN, HN, UN, UN, NEQN, WKAREA(ITE))
C   TAKE NEXT STEP
         TN     = TN+HN
         N      = N+1
         IF (N .LT. NC) GOTO 110
      ELSE
C
C
CCCCCCCCCC VARIABLE STEPSIZES, ERROR CONTROL
C
CCCCCCCCCC COMPUTE REFERENCE SOLUTION
C
         RSFAIL = .FALSE.
*
         IF (LEC) THEN
C LOCAL ERROR ESTIMATION
C COMPUTE LAGTERM BY INTERPOLATION
C    INITIALIZE UR(TN+CRJ.HN) ON UR(TN)
            DO 210 J = LR, MR
               CALL COPYV (UR(-NEQN), NEQN, UR(NEQN*(J-LR)))
  210       CONTINUE
*
  220       CALL SLICE2 (TN, HNM1,HN, NEQN, G,KC,DKCDY,LINEAR,
     +                   C, WKAREA(IW1), CR, WR, LCR, LOBATR,
     +                   LAGSAV, WKAREA(ITE), WKAREA(IW1),
     +                   WKAREA(IW2),MWR,WKAREA(IW3), UR(INDXRN),IERROR)
            IF (IERROR .EQ. 21 .AND. .NOT. RSFAIL) THEN
C    CONVERGENCE PROBLEMS, TRY AGAIN WITH BETTER ESTIMATE TO START WITH
               RSFAIL = .TRUE.
               IERROR = 0
               GOTO 220
            ENDIF
         ELSE IF (RSITCL) THEN
C GLOBAL ERROR ESTIMATION
C    COMPUTE REF. SOL. IN TN+HN WITH ITER. COLL.
            CALL ITRCOL (TN+HN, NEQN, G,KC, T0, H, C,W, U, WKAREA(IW3),
     +                LAGNP1, URNP1)
         ELSE
C    COMPUTE REF. SOL. WITH HIGHER ORDER COLLOCATION METHOD
C    COMPUTE LAG TERM WITH QUADRATURE
            INDXRN = NEQN*(1-LR+MRL*N)
C            INITIALIZE UR(TN+CRJ.HN) ON UR(TN)
            DO 230 J = LR, MR
               CALL COPYV (UR(INDXRN+NLR2),NEQN, UR(INDXRN+NEQN*(J-1)))
  230       CONTINUE
*
  240       CALL SLQCE2 (TN,H, NEQN, G,KC,DKCDY,LINEAR, T0, CR,WR,LCR,
     +                   MR,SR,LR,LOBATR, TOLCIR, GSSCKM, WKAREA(ITE),
     +                   WKAREA(ITE),WKAREA(IW1),WKAREA(IW2),MWR,
     +                   WKAREA(IW3), UR, LAGNP1, IERROR)
            IF (IERROR .EQ. 21 .AND. .NOT. RSFAIL) THEN
C    CONVERGENCE PROBLEMS, TRY AGAIN WITH BETTER ESTIMATE TO START WITH
               RSFAIL = .TRUE.
               IERROR = 0
               GOTO 240
            ENDIF
         ENDIF
C    CHECK IF ALL WENT WELL
         IF (IERROR .NE. 0) GOTO 940
*
         INDRN1 = INDXRN+NEQN*(MR-1)
C
C IF REQUIRED, GIVE INFO
         IF (WRINT) THEN
            IF (RSITCL) THEN
               CALL WRIRES (TN, HN, URNP1, UN, NEQN, WKAREA(ITE))
            ELSE
               CALL WRIRES (TN, HN, UR(INDRN1), UN, NEQN, WKAREA(ITE))
            ENDIF
         ENDIF
C
C
CCCCCCCCCC CONTROL ERROR
C
         IF (GEC) THEN
C CONTROL GLOBAL ERROR; GEE = UR(TN+HN)-U(TN+HN)
            IF (RSITCL) THEN
               CALL ADDV (GEE, NEQN, 1.0, URNP1, -1.0, UN)
               WGEE   = WMXNRM (GEE, URNP1, NEQN)
            ELSE
               CALL ADDV (GEE, NEQN, 1.0, UR(INDRN1), -1.0, UN)
               WGEE   = WMXNRM (GEE, UR(INDRN1), NEQN)
            ENDIF
C   ACCEPT STEP IF GLOBAL ERROR <= TOLLE AND
C   IN CASE OF UNIFORM ERROR CONTROL IF ALSO UNIFORM ERROR <= TOLLE
            ACCEPT = WGEE .LE. TOLLE
            IF (ULEC) THEN
               WULEE  = UEEWGT (TN,HN, NEQN,KC, T0,TE, C,W,
     +                          CR,WR, U(INDEXN), UR(INDXRN),
     +                          LEESUM, ESTGEE, WKAREA(IW3), LEE)
               ACCEPT = ACCEPT .AND. WULEE .LE. TOLLE
            ENDIF
         ELSE
C CONTROL LOCAL ERROR; LEE = (TN,TN+HN) INT K(TN+HN,.,.) - SUM ...
            WLEE   = LEEWGT (TN,HN, NEQN,KC, T0, C,W, CR,WR,
     +                       U(INDEXN), UR(INDXRN), WKAREA(IW3))
            IF (ULEC) THEN
C             CONTROL ERROR OVER WHOLE INTERVAL
               WULEE  = UEEWGT (TN,HN, NEQN,KC, T0,TE, C,W,
     +                          CR,WR, U(INDEXN), UR(INDXRN),
     +                          LEESUM, ESTGEE, WKAREA(IW3), LEE)
               WLEE   = MAX(WLEE, WULEE)
            ENDIF
            ACCEPT = WLEE .LE. TOLLE
         ENDIF
*
         IF (ACCEPT) THEN
C
            IF (GSSCKM) THEN
C   CHECK IF SOLUTION BEHAVES AS A POLYNOMIAL OF DEGREE < M
               RSFAIL = .FALSE.
  250          POLY   = YPOLM (TN,HN, NEQN,G,KC,DKCDY,LINEAR, C,W,LC,
     +                         LCG,LC0, LAGN,LAG,LAGNP1, UN2,
     +                         WKAREA(1), WKAREA(ITE), WKAREA(IW1),
     +                         WKAREA(IW2),MWS, WKAREA(IW3),
     +                         U(INDEXN), URN, IERROR)
               IF (IERROR .EQ. 21 .AND. .NOT. RSFAIL) THEN
C    CONVERGENCE PROBLEMS, TRY AGAIN WITH BETTER ESTIMATE TO START WITH
                  RSFAIL = .TRUE.
                  IERROR = 0
                  GOTO 250
               ENDIF
               IF (IERROR .NE. 0) GOTO 950
*
               IF (POLY)
C            SOL. VIE2 FOUND TO BE POLYNOMIAL IN TN "NPGESC"
C            CONSECUTIVE TIMES; IT IS ASSUMED THAT THE SOL. IS A POL. OF
C            DEGREE < M; ESCAPE FROM GAUSS+REFSOL METHOD
     +            GOTO 970
            ENDIF
C
CCCCC STEP ACCEPTED, ADJUST (LOOP) VARIABLES
C         CHECK RESERVE WORKING STORAGE
            IF (N+1 .GE. MAXNC) GOTO 960
C
            NHFAIL = NHFAIL + IHFAIL
            IHFAIL = 0
            IF (GSSCKM) THEN
C            COPY UR(TN+HN) INTO URN
               IF (RSITCL) THEN
                  CALL COPYV (URNP1, NEQN, URN)
               ELSE
                  CALL COPYV (UR(INDRN1), NEQN, URN)
               ENDIF
C            STORE FCN(TN+HN) IN LAGN
               CALL G(TN+HN, WKAREA(IW3))
               CALL ADDV (LAGN, NEQN, 1.0,URN, -1.0,WKAREA(IW3))
            ENDIF
            IF (LEC) THEN
C            ADJUST LAGSAV ARRAY FOR NEXT STEP
               CALL ADJLSV (TN,HN, NEQN,KC, C,W, U(INDEXN),
     +                      LAGSAV)
               HNM1   = HN
C            COPY UR(TN+HN) TO UR(-NEQN:)
               CALL COPYV (UR(INDRN1), NEQN, UR(-NEQN))
            ENDIF
            IF (ULEC) THEN
C            ADD LEE(I) TO SUM OF LOCAL ERRORS IN TI, TI=TE,-HC,TN+HN
               CALL ADDABV (LEESUM, NEQN*INT((TE-TN-HN)/HC+1),1.0, LEE)
               ESTGEE = .FALSE.
            ENDIF
*
            TN     = TN + HN
            N      = N+1
         ELSE
C
CCCCC STEP REJECTED
            IHFAIL = IHFAIL + 1
C      CHECK IF FAILED WITH MIN. STEPSIZE
            IF (HN .LE. HMINN) THEN
C      IF SO, RELAX TOLERANCE IF ALLOWED;
               GOTO 90
            ELSE IF (MOD(IHFAIL,2) .EQ. 0) THEN
C      IF FAILED REPEATEDLY, DECREASE THE STEPSIZE WITH EXTRA FACTOR
               HN = HN*HFLFAC
               GOTO 100
            ENDIF
            LAST = .FALSE.
         ENDIF
C
CCCCCCCCCC COMPUTE NEW STEPSIZE
C
         IF (GEC) THEN
            R      = MAX(GELIML,WGEE)
            R      = MIN(GELIMU,R)
            FACH   = (TOLLE/R) ** INVP
            IF (ULEC) THEN
               R      = MAX(LELIML,WULEE)
               R      = MIN(LELIMU,R)
               FACH   = MIN(FACH, (TOLLE/R) ** INVQ)
            ENDIF
            HN     = HN*HFAC*FACH
         ELSE
            R      = MAX(LELIML,WLEE)
            R      = MIN(LELIMU,R)
            FACH   = (TOLLE/R) ** INVQ
            HN     = HN*HFAC*FACH
         ENDIF
C
C    LOOP IF "TE" NOT REACHED
         IF (.NOT. LAST) GOTO 100
C
C FINISHED
C   STORE GUESS FOR LENGTH NEXT INTERVAL
      H(N) = HN
      ENDIF
      RETURN
C
C
C ERROR RETURNS
C
C NUMBER OF KERNEL EVALUATIONS TOO LARGE
  900 CALL ERRMSG ('NUMBER OF KERNEL EVALUATIONS EXCEEDS IOPT(6)')
      IERROR = 13
      RETURN
C
C TOO MUCH CPU-TIME USED
  910 CALL ERRMSG ('CPU-TIME USED EXCEEDS IOPT(7)')
      IERROR = 14
      RETURN
C
C FAILED TO MEET TOLERANCE WITH MINIMUM STEPSIZE
  920 NHFAIL = NHFAIL + IHFAIL
      CALL ERRMSG ('CANNOT MEET REQTOL, FAILURE WITH MIN. STEPSIZE')
      IERROR = 11
      RETURN
C
C TOLERANCE INCREASED UNACCEPTABLY
  930 NHFAIL = NHFAIL + IHFAIL
      CALL ERRMSG ('RELAXATION WOULD RESULT IN A TOLERANCE > 1.0')
      IERROR = 16
      RETURN
C
C COMPUTATION REFERENCE SOLUTION FAILED
  940 NHFAIL = NHFAIL + IHFAIL
      CALL ERRMSG ('   ERROR OCCURRED WHILE COMPUTING REF.SOL.'//
     +             'TO APPROXIMATE ERROR')
      RETURN
C
C CHECK ON POLYNOMIAL SOLUTION FAILED
  950 NHFAIL = NHFAIL + IHFAIL
      CALL ERRMSG ('   ERROR OCCURRED WHILE CHECKING WHETHER'//
     +             ' SOLUTION IS POLYNOMIAL')
      RETURN
C
C SIZE WORKING STORAGE TOO SMALL
  960 WRITE(VAROUT,'(I10)') N+2
      CALL ERRMSG ('SIZE WORKING STORAGE TOO SMALL FOR'//VAROUT//
     +             ' SUBINTERVALS')
      IERROR = 12
      RETURN
C
C SOLUTION POLYNOMIAL; PROBLEMS IN CASE OF GAUSS COLL. PARS.
  970 IERROR = 15
  980 RETURN
*
      END
      SUBROUTINE SGEVI2
     +   (NEQN, G,KC,DKCDY,LINEAR, T0, CR,WR,LCR, H, UR, WKAREA,
     +    TN, URN, IERROR)
C
C ---------------------------------------------------------------------I
C PURPOSE: COMPUTE REFERENCE SOLUTION BY HIGHER ORDER COLLOCATION      I
C -------  METHOD.  INVOKED TO ESTIMATE THE GLOBAL ERROR IN TN+H(N).   I
C                                                                      I
C COMMON VARIABLES:                                                    I
C ----------------                                                     I
      INTEGER METH, M, S, L, ORDER, ORDERQ, METHR, MR, SR, LR, ORDERR,
     +        ERRWGT, NHFAIL, NERR, NWIR, NSAV,
     +        MAXNC, MAXKEV, MAXCPS, N, NCIT, NKEV, NCPS
      COMMON /COLCMI/ METH, M, S, L, ORDER, ORDERQ,
     +                METHR, MR, SR, LR, ORDERR,
     +                ERRWGT, NHFAIL,
     +                NERR, NWIR, NSAV,
     +                MAXNC, MAXKEV, MAXCPS,
     +                N, NCIT, NKEV, NCPS
*
      LOGICAL VS, GSSCKM, ESCGSS, GEC, ULEC, RLXTOL, GEETE,
     +        FUNCIT, NEWTON
      COMMON /COLCML/ VS, GSSCKM, ESCGSS, GEC, ULEC, RLXTOL, GEETE,
     +                FUNCIT, NEWTON
*
      REAL TOLLE, TOLCIA, TOLCIR, HMIN, HMAX, HC
      COMMON /COLCMR/ TOLLE, TOLCIA, TOLCIR, HMIN, HMAX, HC
*
      SAVE /COLCMI/, /COLCML/, /COLCMR/
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER NEQN, IERROR
      LOGICAL LINEAR
      REAL T0, TN
      REAL CR(MR), WR(SR), LCR(MR,LR:MR,LR:SR), H(0:MAXNC),
     +     UR(-NEQN:NEQN*(MR-LR+1)*MAXNC-1), WKAREA(*), URN(NEQN)
      EXTERNAL G, KC, DKCDY
C H      ENTRY: H(0:N-1) SUBINT. LENGTHS OF STEPS TAKEN IN THE         I
C               COMPUTATION OF THE APPROX. SOL. BY "SOLVI2"            I
C UR     ENTRY: UR(-NEQN:-1) SHOULD CONTAIN G(T0)                      I
C        EXIT:  CONTAINS UR(TI+CRJ.HI) I=0:N-1, J=1:MR                 I
C        UR(TIJ) -> UR(NEQN*((MR-LR+1)*I+(J-LR))+(0:NEQN-1))           I
C WKAREA WORKING STORAGE FOR SOLVING THE COLLOC. SYSTEM (CF.SOLSYS)    I
C        AND FOR STORAGE OF INTERMEDIATE VECTOR RESULTS IN "SLQCE2"    I
C TN     ENTRY: RIGHT ENDPOINT OF LAST SUBINTERVAL                     I
C        EXIT:  AFTER NORMAL EXIT UNCHANGED, OTHERWISE LEFT ENDPOINT   I
C               OF SUBINTERVAL AT WHICH ERROR OCCURRED                 I
C URN    EXIT: REFERENCE SOLUTION IN TN                                I
C IERROR ENTRY: 0                                                      I
C        EXIT:  0: OK                                                  I
C             113: # KERNEL EVAL. > MAX. # KERN. EV. ALLOWED           I
C             114: # CPU-SECONDS > MAX. # CPU-SEC. ALLOWED             I
C              OTHER: ERRORS FROM "SOLSYS"                             I
C                                                                      I
C INVOKED BY: COLVI2                                                   I
C ----------                                                           I
C                                                                      I
C CHANGES IN COMMON VARIABLES:                                         I
C ---------------------------                                          I
C N      USED TO KEEP TRACK OF THE # SUBINTERVALS ON WHICH THE         I
C        INTEGRATION ALREADY HAS BEEN PERFORMED. ON EXIT "N" HAS THE   I
C        SAME VALUE AS ON ENTRY.                                       I
C                                                                      I
C LOCAL VARIABLES:                                                     I
C ---------------                                                      I
      INTEGER INDEXN, IW1,IW2,IW3, MW, NC
      LOGICAL LOBATR
      REAL HN
C INDEXN POINTER TO REF.SOL. IN 1-ST (IF LOBATTO: 2-ND) COLLOC. POINT  I
C        IN N-TH INTERVAL                                              I
C IW1,...,IW3 POINTERS TO WKAREA LOCATIONS (CF. "COLDOC" SUB           I
C        "DISTRIBUTION WKAREA")                                        I
C MW     DIMENSION OF SYSTEM OF COLLOCATION EQUATIONS                  I
C NC     # INTERVALS IN WHICH INTEGRATION INTERVAL HAS BEEN DIVIDED    I
C                                                                      I
C ---------------------------------------------------------------------I
C
      INTEGER J, MRL, NCPJOB
      LOGICAL RSFAIL
      EXTERNAL NCPJOB
*
      MRL    = MR-LR+1
C
C
C DISTRIBUTE WORKING STORAGE "WKAREA" FOR LAGTERMS AND LIN.SYS.SOLVER
      MW     = MRL*NEQN
      IW1    =   1 + MW
      IW2    = IW1 + MW
      IF (FUNCIT) THEN
         IW3    = IW2
      ELSE
         IW3    = IW2 + MW*MW
      ENDIF
C
C
C INITIALIZE LOOP CONSTANTS AND VARIABLES
      LOBATR = LR .EQ. 2
*
      NC     = N
      N      = 0
      TN     = T0
C
C
C LOOP UNTIL "TE" IS REACHED
  100 CONTINUE
      RSFAIL = .FALSE.
      HN     = H(N)
C
C   CHECK # KEV
      IF (NKEV .GT. MAXKEV) GOTO 900
C
C   CHECK CPU-TIME
      IF (NCPJOB()-NCPS .GT. MAXCPS) GOTO 910
C
      INDEXN = NEQN*MRL*N
C
C
C COMPUTE REF. SOL. WITH HIGHER ORDER COLLOCATION METHD
      DO 200 J = LR, MR
         CALL COPYV (UR(INDEXN-NEQN), NEQN, UR(INDEXN+NEQN*(J-LR)))
  200 CONTINUE
*
  210 CALL SLQCE2 (TN,H, NEQN, G,KC,DKCDY,LINEAR, T0,
     +             CR,WR,LCR, MR,SR,LR, LOBATR, TOLCIR, .FALSE.,
     +             WKAREA(1),WKAREA(1),WKAREA(IW1),WKAREA(IW2), MW,
     +             WKAREA(IW3), UR, WKAREA(IW3), IERROR)
      IF (IERROR .EQ. 21 .AND. .NOT. RSFAIL) THEN
C    CONVERGENCE PROBLEMS, TRY AGAIN WITH BETTER ESTIMATE TO START WITH
         RSFAIL = .TRUE.
         IERROR = 0
         GOTO 210
      ELSE IF (IERROR .NE. 0) THEN
         GOTO 920
      ENDIF
C
C    LOOP IF "TE" NOT REACHED
      TN     = TN+HN
      N      = N+1
      IF (N .LT. NC) GOTO 100
C
C FINISHED
      CALL COPYV (UR(NEQN*MRL*N-NEQN), NEQN, URN)
      RETURN
C
C
C ERROR RETURNS
C
C NUMBER OF KERNEL EVALUATIONS TOO LARGE
  900 CALL ERRMSG ('NUMBER OF KERNEL EVALUATIONS EXCEEDS IOPT(6)')
      IERROR = 113
      GOTO 920
C
C TOO MUCH CPU-TIME USED
  910 CALL ERRMSG ('CPU-TIME USED EXCEEDS IOPT(7)')
      IERROR = 114
C
C ERROR WHILE SOLVING COLLOCATION EQUATION
  920 CALL ERRMSG ('ERROR WHILE COMPUTING GLOBAL ERROR IN "TE"')
      N      = NC
*
      RETURN
*
      END
      SUBROUTINE SLQCE2
     +   (TN, H, NEQN,G,KC,DKCDY,LINEAR, T0, C,W,LC, MM,SS,LL, LOBAT,
     +    TOLCIT, LNP1FL, LAG, GLAG,CORR,DSYS,MW, WKAREA, U, LAGNP1,
     +    IERROR)
C
C ---------------------------------------------------------------------I
C PURPOSE: SOLVE SYSTEM OF COLLOC. EQ. FOR (REF) SOL. IN SUBINTERVAL   I
C -------  [TN,TN+HN]. APPROXIMATE LAG TERM WITH QUADRATURE.           I
C NOTE: IT IS POSSIBLE THAT "LAG" AND "GLAG" , AS WELL AS "WKAREA" AND I
C ----  "LAGNP1" SHARE THE SAME MEMORY LOCATIONS.                      I
C                                                                      I
C COMMON VARIABLES:                                                    I
C ----------------                                                     I
      INTEGER METH, M, S, L, ORDER, ORDERQ, METHR, MR, SR, LR, ORDERR,
     +        ERRWGT, NHFAIL, NERR, NWIR, NSAV,
     +        MAXNC, MAXKEV, MAXCPS, N, NCIT, NKEV, NCPS
      COMMON /COLCMI/ METH, M, S, L, ORDER, ORDERQ,
     +                METHR, MR, SR, LR, ORDERR,
     +                ERRWGT, NHFAIL,
     +                NERR, NWIR, NSAV,
     +                MAXNC, MAXKEV, MAXCPS,
     +                N, NCIT, NKEV, NCPS
*
      SAVE /COLCMI/
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER NEQN, MM, SS, LL, MW, IERROR
      LOGICAL LINEAR, LOBAT, LNP1FL
      REAL TN, T0, TOLCIT
      REAL H(0:MAXNC), C(MM), W(SS), LC(MM,LL:MM,LL:SS),
     +     LAG(0:NEQN*(MM-LL+1)-1), GLAG(MW), CORR(MW), DSYS(*),
     +     WKAREA(*), U(-NEQN:NEQN*(MM-LL+1)*MAXNC-1), LAGNP1(*)
      EXTERNAL G, KC, DKCDY
C                                                                      I
C TN     LEFT ENDPOINT OF CURRENT SUBINTERVAL                          I
C H      LENGTH OF SUBINTERVALS [TI,TI+HI] I=0,...,N                   I
C C      -I COLLOC. VARS;                                              I
C W       I EITHER C,W,LC OR CR,WR,LCR                                 I
C LC     -I                                                            I
C MM     -I DIMENSION PARAMETERS FOR COLL. VARS;                       I
C SS      I EITHER M,S,L OR MR,SR,LR                                   I
C LL     -I                                                            I
C LOBAT  TRUE IF COLL. PARAMETERS ARE LOBATTO POINTS                   I
C TOLCIT TOLERANCE FOR CORRECTOR ITERATION PROCESS TO SOLVE COLL. EQ.  I
C        EITHER TOLCIA OR TOLCIR.                                      I
C LNP1FL TRUE IF FCN(TN+HN) HAS TO BE STORED IN LAGNP1                 I
C        TO BE USED FOR CHECK ON POL.SOL. IF APPROX.METH. IS GAUSS     I
C LAG    WORKING STORAGE FOR THE APPROX. OF THE LAG TERM IN TN+CJ.HN,  I
C        FOR J=LL,...,MM                                               I
C        FCN(TNJ) -> LAG(NEQN*(J-LL)+(0:NEQN-1))                       I
C GLAG   WORKING STORAGE FOR G(TNJ)+FCN(TNJ), J=LL,...,MM              I
C        G(TNJ)+FCN(TNJ) -> GLAG(NEQN*(J-LL)+(1:NEQN))                 I
C CORR   WORKING STORAGE FOR THE RIGHT HAND SIDE, OR THE SOLUTION, OF  I
C        THE LINEAR SYSTEM IN THE CORRECTOR ITERATION PROCESS.         I
C DSYS   WORKING STORAGE FOR THE DERIVATIVE OF THE SYSTEM OF LIN. EQ.  I
C        IN THE NEWTON PROCESS.                                        I
C MW     DIMENSION OF LIN. SYSTEM (NEQN.(MM-LL+1))                     I
C WKAREA WORKING STORAGE FOR TEMPORARY VECTORS (2*NEQN)                I
C        ALSO USED AS WORKING STORAGE FOR SOLSYS.                      I
C U      ENTRY: CONTAINS THE APPROXIMATED SOLUTION IN TI+CJ.HI         I
C               FOR I = 0,...,N-1; J=1,...,MM                          I
C               SHOULD CONTAIN AN INITIAL APPROXIMATION OF U(TN+CJ.HN) I
C        EXIT:  APPROX. SOL. OF IN TI+CJ.HI, I=0,...,N, J=1,...,MM     I
C        U(TI+CJ.HI) -> U(NEQN*((MM-LL+1)*I+(J-LL))+(0:NEQN-1))        I
C LAGNP1 EXIT:  CONTAINS APPROX. OF FCN(TN+HN), IF LNP1FL=.TRUE.       I
C                                               OTHERWISE NOT USED     I
C IERROR ERROR COMPLETION CODE                                         I
C        ENTRY: SHOULD CONTAIN 0                                       I
C        EXIT:  0: NO ERRORS                                           I
C               OTHER: ERROR COMPLETION CODE OF SOLSYS                 I
C                                                                      I
C INVOKED BY: SOLVI2, SGEVI2                                           I
C ----------                                                           I
C                                                                      I
C CHANGES IN COMMON VARIABLES:                                         I
C ---------------------------                                          I
C NKEV   ADDED: # KERNEL EVALUATIONS NEEDED TO COMPUTE LAG TERMS IN    I
C        CURRENT SUBINTERVAL                                           I
C                                                                      I
C LOCAL VARIABLES:                                                     I
C ---------------                                                      I
      INTEGER INDEXI
      REAL HI, HN, TI, TNJ
C INDEXI POINTER TO APPROX. IN 1-ST (IF LOBATTO: 2-ND) COLLOC. POINT   I
C        OF I-TH SUBINTERVAL                                           I
C TNJ    TN + C(J).HN                                                  I
C                                                                      I
C ---------------------------------------------------------------------I
C
      INTEGER I, INDEXJ, I1, J, K, MMLL
      REAL CJHN
*
      I1 = NEQN+1
      MMLL = MM-LL+1
C
C                                       TN
C APPROXIMATE LAG TERM     FCN(TNJ) = INT KC(TN+CJ.HN),S,Y(S)) DS BY
C                                       T0
C           N-1     S
C  LAG_J = SUM HI SUM WK.KC(TN+CJ.HN,TI+CK.HI,U_IK)
C           I=0    K=1
C COMPUTE GLAG_J = G(TN+CJ.HN) + LAG_J       J=LL,...,MM
C STORE KERNEL VECTORS IN WKAREA
C NOTE: IT IS POSSIBLE THAT SOME G-FUNCTIONS (E.G. G(TN+HN)) ALREADY
C ----  HAVE BEEN EVALUATED; PITY.
      HN = H(N)
      IF (.NOT. LOBAT) THEN
         DO 10 J = 1, MM
            INDEXJ = NEQN*(J-1)
            CJHN = C(J)*HN
            TNJ = TN + CJHN
*
            CALL ZEROV (LAG(INDEXJ), NEQN)
            TI = T0
            DO 20 I = 0, N-1
               INDEXI = NEQN*MMLL*I
               HI = H(I)
               DO 30 K = 1, SS
                  CALL KC(TNJ,TI+C(K)*HI,U(INDEXI+NEQN*(K-1)),WKAREA)
                  CALL ADDABV (LAG(INDEXJ), NEQN, HI*W(K), WKAREA)
   30          CONTINUE
               TI = TI + HI
   20       CONTINUE
            IF (LNP1FL .AND. J.EQ.MM)
     +         CALL COPYV (LAG(INDEXJ), NEQN, LAGNP1)
            CALL G(TNJ,WKAREA)
            CALL ADDV (GLAG(INDEXJ+1), NEQN, 1.0,WKAREA,1.0,LAG(INDEXJ))
   10    CONTINUE
         NKEV = NKEV + MM*N*SS
*
      ELSE IF (N .GT. 0) THEN
C   LOBATTO, N > 0
         DO 50 J = 2, MM
            INDEXJ = NEQN*(J-2)
            CJHN = C(J)*HN
            TNJ = TN + CJHN
*
            CALL KC(TNJ,T0,U(-NEQN),WKAREA)
            CALL ADDV (LAG(INDEXJ), NEQN, H(0)*W(1),WKAREA, 0.0,WKAREA)
            TI = T0
            DO 60 I = 0, N-2
               INDEXI = NEQN*MMLL*I
               HI = H(I)
               DO 70 K = 2, MM-1
                  CALL KC(TNJ,TI+C(K)*HI,U(INDEXI+NEQN*(K-2)),WKAREA)
                  CALL ADDABV (LAG(INDEXJ), NEQN, HI*W(K), WKAREA)
   70          CONTINUE
               CALL KC(TNJ,TI+HI,U(INDEXI+NEQN*(MM-2)),WKAREA)
               CALL ADDABV (LAG(INDEXJ), NEQN, (HI+H(I+1))*W(MM),WKAREA)
               TI = TI + HI
   60       CONTINUE
            INDEXI = NEQN*MMLL*(N-1)
            HI = H(N-1)
            DO 80 K = 2, MM
               CALL KC(TNJ,TI+C(K)*HI,U(INDEXI+NEQN*(K-2)),WKAREA)
               CALL ADDABV (LAG(INDEXJ), NEQN, HI*W(K), WKAREA)
   80       CONTINUE
C
C   WKAREA(1:NEQN) CONTAINS K(TNJ,TN,U_N1)
            CALL G(TNJ,WKAREA(I1))
            CALL ADDV (GLAG(INDEXJ+1),NEQN, 1.0,WKAREA(I1),
     +                                      1.0,LAG(INDEXJ))
C
C   ADD FIRST TERM OF SUM THAT APPROXIMATES (TN,TN+HN) INT K(TNJ,..)
C       I.E.  CJ.HN.W1.K(TNJ,TN,U(TN))
            CALL ADDABV (GLAG(INDEXJ+1), NEQN, CJHN*W(1), WKAREA)
   50    CONTINUE
         NKEV = NKEV + (MM-1)*(1+N*(MM-1))
      ELSE
C   LOBATTO, FIRST STEP
         DO 90 J = 2, MM
            INDEXJ = NEQN*(J-2)
            CJHN = C(J)*HN
            TNJ = TN + CJHN
*
            CALL ZEROV (LAG(INDEXJ), NEQN)
            CALL KC(TNJ,TN,U(-NEQN),WKAREA)
            CALL G(TNJ,GLAG(INDEXJ+1))
C
C   ADD FIRST TERM OF SUM THAT APPROXIMATES (TN,TN+HN) INT K(TNJ,..)
C       I.E.  CJ.HN.W1.K(TNJ,TN,U(TN))
            CALL ADDABV (GLAG(INDEXJ+1), NEQN, CJHN*W(1), WKAREA)
   90    CONTINUE
         NKEV = NKEV + MM-1
      ENDIF
C
C
C SOLVE, BY FUNCTIONAL OR NEWTON ITER., THE SYSTEM OF COLLOC. EQUATIONS
C   U_NJ - GLAG_J -
C          S
C   - HN.SUM CJ.WK.KC(TN+CJ.HN,TN+CJ.CK.HN,U(TN+CJ.CK.HN)) = 0
C         K=1                                           J=LL,...,MM
C
      CALL SOLSYS (TN,HN, NEQN,KC,DKCDY,LINEAR, C,W,LC, MM,SS,LL,
     +             TOLCIT, GLAG,CORR,DSYS,MW, WKAREA,
     +             U(NEQN*(MMLL*N+(1-LL))), IERROR)
*
      RETURN
      END
      SUBROUTINE SLICE2
     +   (TN,HNM1,HN, NEQN,G,KC,DKCDY,LINEAR, C, CB, CR,WR,LCR,LOBATR,
     +    LAGSAV, GLAGR,CORR,DSYS,MW, WKAREA, URN, IERROR)
C
C ---------------------------------------------------------------------I
C PURPOSE: SOLVE SYSTEM OF COLLOC. EQ. FOR REF.SOL. IN [TN,TN+HN].     I
C -------  COMPUTE LAG TERM IN (TN+CRJ.HN) WITH LAGRANGE INTERPOLATION I
C OVER TWO INTERVALS.                                                  I
C NOTE: CB AND CORR (AND POSS. DSYS AND WKAREA) SHARE MEMORY LOCATIONS I
C ----                                                                 I
C                                                                      I
C COMMON VARIABLES:                                                    I
C ----------------                                                     I
      INTEGER METH, M, S, L, ORDER, ORDERQ, METHR, MR, SR, LR, ORDERR,
     +        ERRWGT, NHFAIL, NERR, NWIR, NSAV,
     +        MAXNC, MAXKEV, MAXCPS, N, NCIT, NKEV, NCPS
      COMMON /COLCMI/ METH, M, S, L, ORDER, ORDERQ,
     +                METHR, MR, SR, LR, ORDERR,
     +                ERRWGT, NHFAIL,
     +                NERR, NWIR, NSAV,
     +                MAXNC, MAXKEV, MAXCPS,
     +                N, NCIT, NKEV, NCPS
*
      REAL TOLLE, TOLCIA, TOLCIR, HMIN, HMAX, HC
      COMMON /COLCMR/ TOLLE, TOLCIA, TOLCIR, HMIN, HMAX, HC
*
      SAVE /COLCMI/, /COLCMR/
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER NEQN, MW, IERROR
      LOGICAL LINEAR, LOBATR
      REAL TN, HNM1, HN
      REAL C(M), CB(2*M-L+1), CR(MR), WR(SR), LCR(MR,LR:MR,LR:SR),
     +     LAGSAV(0:NEQN*(2*M-L+1)-1), GLAGR(MW), CORR(MW),
     +     DSYS(*), WKAREA(*), URN(0:NEQN*MR-1)
      EXTERNAL G, KC, DKCDY
C                                                                      I
C TN     LEFT ENDPOINT OF CURRENT SUBINTERVAL                          I
C HNM1   LENGTH OF SUBINTERVAL [T(N-1),TN]                             I
C HN     LENGTH OF CURRENT SUBINTERVAL                                 I
C CB     WORKING STORAGE FOR COLL.POINTS NEEDED FOR LAG TERM INTERPOL. I
C LAGSAV LAG TERM APPROX. IN THE PREVIOUS AND CURRENT INTERVAL.        I
C        ENTRY:                                                        I
C        FCN(TNM1+CJ.HNM1) -> LAGSAV(NEQN*(J-1):NEQN*J-1)       J=1..M I
C        FCN(TN+CJ.HN) -> LAGSAV(NEQN*(M+J-L):NEQN*(M+J-L+1)-1) J=L..M I
C GLAGR  WORKING STORAGE FOR G(TN+CRJ.HN) + FCN(TN+CRJ.HN)   J=LR..MR  I
C CORR   WORKING STORAGE FOR THE RIGHT HAND SIDE, OR THE SOLUTION, OF  I
C        THE LINEAR SYSTEM IN THE CORRECTOR ITERATION PROCESS.         I
C DSYS   WORKING STORAGE FOR THE DERIVATIVE OF THE SYSTEM OF LIN. EQ.  I
C        IN THE NEWTON PROCESS.                                        I
C MW     DIMENSION OF SYST. OF LIN. EQ. (NEQN*(MR-LR+1))               I
C WKAREA WORKING STORAGE FOR TEMP. VECTORS (NEQN); ALSO USED AS        I
C        WORKING STORAGE FOR "SOLSYS".                                 I
C URN    ENTRY: CONTAINS AN INITIAL APPROX. OF THE REF.SOL. IN THE     I
C               COLL. POINTS  TN+CRJ.HN, FOR J=1,...,MR                I
C        EXIT:  REF. SOL. UR(TN+CRJ.HN), J=1,...,MR                    I
C        UR(TNJ) -> URN(NEQN*(J-1)+(0:NEQN-1))                         I
C IERROR ERROR COMPLETION CODE                                         I
C        ENTRY: SHOULD CONTAIN 0                                       I
C        EXIT:  0: NO ERRORS                                           I
C               OTHER: ERROR COMPLETION CODE OF SOLSYS                 I
C                                                                      I
C INVOKED BY: SOLVI2                                                   I
C ----------                                                           I
C                                                                      I
C CHANGES IN COMMON VARIABLES:                                         I
C ---------------------------                                          I
C NKEV   IF LOBATTO COLLOCATION IS USED FOR THE COMP. OF THE REF.SOL., I
C        ADDED: # KERNEL EVAL. NEEDED FOR THE INVARIANT PART OF THE    I
C               PRESENT TERM (CORRESP. TO U(TN+C1.HN)=U(TN))           I
C                                                                      I
C ---------------------------------------------------------------------I
C
      INTEGER I, INDEXJ, J, K, MB
      REAL CRJHN, D, LCKJ, LAGPOL
      EXTERNAL LAGPOL
*
      MB = 2*M-L+1
C
C COMPUTE LAGTERM WITH LAGRANGE INTERPOLATION OVER TWO INTERVALS
C   FILL "C" VECTOR WITH COLL. ABSCISSAS ON THESE INTERVALS
      D = HNM1 + HN
      DO 10 I = 1, M
         CB(I) = C(I) * HNM1/D
         CB(M-L+I+1) = (HNM1 + C(I)*HN) / D
   10 CONTINUE
C
C   COMPUTE G(TN+CRJ.HN) + FCN(TN+CRJ.HN)
C   NOTE: IT IS POSSIBLE THAT SOME G-FUNCTIONS (E.G. G(TN+HN)) ALREADY
C   ----  HAVE BEEN EVALUATED; TOO MUCH FUSS, EXTRA STORAGE NEEDED.
      DO 20 J = LR, MR
         INDEXJ = NEQN*(J-LR)+1
         CRJHN = CR(J)*HN
*
         CALL G(TN+CRJHN,GLAGR(INDEXJ))
         DO 30 K = 1, MB
            LCKJ = LAGPOL (K, (HNM1+CRJHN)/D, MB, CB)
            CALL ADDABV (GLAGR(INDEXJ), NEQN, LCKJ,LAGSAV(NEQN*(K-1)))
   30    CONTINUE
   20 CONTINUE
*
      IF (LOBATR) THEN
C   ADD FIRST TERM OF SUM THAT APPROX. (TN,TN+HN) INT K(TNJ,..)
C   I.E., CRJ.HN.WR1.K(TNJ,TN,UR_N1)
C   STORE KERNEL VECTOR IN WKAREA
         DO 40 J = 2, MR
            CRJHN = CR(J)*HN
            INDEXJ = NEQN*(J-2)+1
*
            CALL KC(TN+CRJHN,TN,URN,WKAREA)
            CALL ADDABV (GLAGR(INDEXJ), NEQN, CRJHN*WR(1), WKAREA)
   40    CONTINUE
         NKEV = NKEV+MR-1
      ENDIF
*
C SOLVE, BY FUNCTIONAL OR NEWTON ITER., THE SYSTEM OF COLLOC. EQUATIONS
C   UR_NJ - GLAGR_J -
C          SR
C   - HN.SUM CRJ.WRK.KC(TN+CRJ.HN,TN+CRJ.CRK.HN,UR(TN+CRJ.CRK.HN))
C         K=1
      CALL SOLSYS (TN,HN, NEQN,KC,DKCDY,LINEAR, CR,WR,LCR, MR,SR,LR,
     +             TOLCIR, GLAGR,CORR,DSYS,MW,WKAREA, URN, IERROR)
*
      RETURN
      END
      SUBROUTINE SOLSYS
     +   (TN,HN, NEQN,KC,DKCDY,LINEAR, C,W,LC, MM,SS,LL, TOLCIT,
     +    GLAG, CORR,DSYS,MW, WKAREA, UN, IERROR)
C
C ---------------------------------------------------------------------I
C PURPOSE: SOLVE, BY FUNCTIONAL OR NEWTON ITERATION, THE SYSTEM OF     I
C -------  COLLOCATION EQUATIONS                                       I
C   U_NJ - GLAG_J -                                                    I
C          SS                                MM                        I
C   - HN.SUM CJ.WK.KC(TN+CJ.HN,TN+CJ.CK.HN,SUM LC_I(CJ.CK).U_NI) = 0   I
C         K=1                               I=1                        I
C                                                       J=L,...,M      I
C                                                                      I
C COMMON VARIABLES:                                                    I
C ----------------                                                     I
      INTEGER METH, M, S, L, ORDER, ORDERQ, METHR, MR, SR, LR, ORDERR,
     +        ERRWGT, NHFAIL, NERR, NWIR, NSAV,
     +        MAXNC, MAXKEV, MAXCPS, N, NCIT, NKEV, NCPS
      COMMON /COLCMI/ METH, M, S, L, ORDER, ORDERQ,
     +                METHR, MR, SR, LR, ORDERR,
     +                ERRWGT, NHFAIL,
     +                NERR, NWIR, NSAV,
     +                MAXNC, MAXKEV, MAXCPS,
     +                N, NCIT, NKEV, NCPS
*
      LOGICAL VS, GSSCKM, ESCGSS, GEC, ULEC, RLXTOL, GEETE,
     +        FUNCIT, NEWTON
      COMMON /COLCML/ VS, GSSCKM, ESCGSS, GEC, ULEC, RLXTOL, GEETE,
     +                FUNCIT, NEWTON
*
      REAL TOLLE, TOLCIA, TOLCIR, HMIN, HMAX, HC
      COMMON /COLCMR/ TOLLE, TOLCIA, TOLCIR, HMIN, HMAX, HC
*
      SAVE /COLCMI/, /COLCML/, /COLCMR/
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER NEQN, MM, SS, LL, MW, IERROR
      LOGICAL LINEAR
      REAL TN, HN, TOLCIT
      REAL C(MM), W(SS), LC(MM,LL:MM,LL:SS),
     +     GLAG(MW), CORR(MW), DSYS(*), WKAREA(*), UN(0:NEQN*MM-1)
      EXTERNAL KC, DKCDY
C                                                                      I
C TN     LEFT ENDPOINT OF CURRENT SUBINTERVAL                          I
C HN     LENGTH OF CURRENT SUBINTERVAL                                 I
C C      -I COLLOC. VARS;                                              I
C W       I EITHER C,W,LC OR CR,WR,LCR                                 I
C LC     -I                                                            I
C MM     -I DIMENSION PARAMETERS FOR COLL. VARS;                       I
C SS      I EITHER M,S,L OR MR,SR,LR                                   I
C LL     -I                                                            I
C TOLCIT TOLERANCE FOR CORRECTOR ITERATION PROCESS (TOLCIA OR TOLCIR)  I
C GLAG   CONTAINS THE CONSTANT VECTORPART OF THE SYSTEM OF LIN. EQ.    I
C        G(TNJ)+FCN(TNJ) -> GLAG(NEQN*(J-LL)+(1:NEQN))  J=LL,MM        I
C CORR   WORKING STORAGE FOR THE RIGHT HAND SIDE, OR THE SOLUTION, OF  I
C        THE LINEAR SYSTEM IN THE CORRECTOR ITERATION PROCESS.         I
C DSYS   WORKING STORAGE FOR THE DERIVATIVE OF THE SYSTEM OF LIN. EQ.  I
C        IN THE NEWTON PROCESS.                                        I
C MW     DIMENSION OF LINEAR SYSTEM (=NEQN.(MM-LL+1))                  I
C WKAREA WORKING STORAGE NEEDED TO STORE INTERMEDIATE VECTOR RESULTS;  I
C        IF NEWTON'S METHOD IS USED, ALSO WORKING STORAGE FOR "DECLUF" I
C        AND "SOLLUF".                                                 I
C UN     ENTRY: SHOULD CONTAIN AN INITIAL APPR. OF U(TN+CJ.HN)  J=1,MM I
C        EXIT:  APPROX. SOL. OF U(TN+CJ.HN), J=1,MM                    I
C        U(TNJ) -> UN(NEQN*(J-1)+(0:NEQN-1)), J=1,MM                   I
C IERROR ERROR COMPLETION CODE                                         I
C        ENTRY: SHOULD CONTAIN 0                                       I
C        EXIT:  0: NO ERRORS                                           I
C              21: CORRECTOR ITERATION PROCESS DID NOT CONVERGE WITHIN I
C                  "MAXFIT", RESP. "MAXNIT" ITERATIONS.                I
C               OTHER: ERROR COMPLETION CODE OF DECLUF                 I
C                                                                      I
C INVOKED BY: SLQCE2, SLICE2, YPOLM                                    I
C ----------                                                           I
C                                                                      I
C CHANGES IN COMMON VARIABLES:                                         I
C ---------------------------                                          I
C NCIT   ADDED: # CORRECTOR ITERATIONS NEEDED TO SOLVE COLLOC. SYSTEM  I
C        IN CURRENT SUBINTERVAL                                        I
C NKEV   ADDED: # KERNEL EVAL. NEEDED WHILE SOLVING COLLOC. SYSTEM     I
C                                                                      I
C CONSTANTS:                                                           I
C ---------                                                            I
      INTEGER MAXFIT
      PARAMETER (MAXFIT = 15)
C                                                                      I
C LOCAL VARIABLES:                                                     I
C ---------------                                                      I
      CHARACTER*15 VAROUT
      INTEGER IKEV, ICIT
      REAL TNJ, TNJK
C IKEV   # KERNEL EVALUATIONS IN THIS SUBINTERVAL                      I
C ICIT   # FUNCTIONAL ITERATIONS IN THIS SUBINTERVAL                   I
C TNJ    TN + C(J).HN                                                  I
C TNJK   TN + C(J).C(K).HN                                             I
C                                                                      I
C ---------------------------------------------------------------------I
C
      INTEGER I, INDEXJ, I1, ITCORR, J, K, ML, SL
      REAL CJHN, R, WMXNRM
      EXTERNAL WMXNRM
*
C
      IF (FUNCIT) THEN
         I1 = NEQN+1
         ML = MM-LL+1
         SL = SS-LL+1
         IKEV = 0
C
CCCCCCCCCC SOLVE SYSTEM WITH FUNCTIONAL ITERATION UNTIL CONVERGENCE;
C          TOLERANCE: "TOLCIT"
C
C   LOOP AS LONG AS LAST CORRECTION IS TOO LARGE
         DO 10 ITCORR = 1, MAXFIT
C
C      COMPUTE RIGHT-HAND-SIDE OF SYSTEM OF EQUATIONS
            DO 20 J = LL, MM
               INDEXJ = NEQN*(J-LL)+1
               CJHN = C(J)*HN
               TNJ  = TN + CJHN
*
               CALL COPYV (UN(NEQN*(J-1)), NEQN, CORR(INDEXJ))
               CALL ADDABV (CORR(INDEXJ),NEQN,-1.0,GLAG(INDEXJ))
               DO 30 K = LL, SS
                  TNJK = TN + CJHN*C(K)
C
C         COMPUTE U(TN+CJ.CK.HN) USING LAGRANGE INTERPOLATION
C         STORE IN FIRST NEQN LOCATIONS OF WKAREA
                  CALL ZEROV (WKAREA(1),NEQN)
                  DO 40 I = 1, MM
                     CALL ADDABV (WKAREA(1),NEQN,
     +                            LC(I,J,K),UN(NEQN*(I-1)))
   40             CONTINUE
C
C         COMPUTE -HN.CJ.WK.K(TNJ,TNJK,U(TNJK));
C         STORE KERNEL VALUES IN WKAREA(NEQN+1:)
                  R  = CJHN*W(K)
                  CALL KC(TNJ,TNJK,WKAREA(1),WKAREA(I1))
                  CALL ADDABV (CORR(INDEXJ),NEQN,-R,WKAREA(I1))
   30          CONTINUE
   20       CONTINUE
            IKEV = IKEV + ML*SL
C
C      ADJUST U_N WITH CORRECTION VECTOR
            CALL ADDABV (UN(NEQN*(LL-1)),MW,-1.0,CORR)
C
C      CHECK CONVERGENCE OF FUNCTIONAL ITER. PROCESS
            IF (WMXNRM(CORR,UN(NEQN*(LL-1)),MW) .LE. TOLCIT) THEN
C          CONVERGED, NO MORE ITERATIONS NEEDED
               ICIT = ITCORR
               GOTO 990
            ENDIF
   10    CONTINUE
*
         ICIT = MAXFIT
      ELSE
C
CCCCCCCCCC SOLVE SYSTEM WITH NEWTON ITERATION UNTIL CONVERGENCE;
C          TOLERANCE: "TOLCIT"
        CALL SOLNEW (TN,HN, NEQN,KC,DKCDY,LINEAR, C,W,LC, MM,SS,LL,
     +               TOLCIT, GLAG, CORR,DSYS,MW, WKAREA, UN, IERROR)
        RETURN
      ENDIF
C
C (ERROR) RETURNS
C
C CONVERGENCE PROBLEMS IN FUNCTIONAL ITERATION PROCESS
      WRITE(VAROUT,'(E15.5)') TN
      CALL ERRMSG ('MAXIMUM NUMBER OF FUNCTIONAL ITERATIONS EXCEEDED IN'
     +             //VAROUT)
      CALL ERRMSG ('   ONLY HARD ERROR FOR FIXED STEPSIZE CASE')
      IERROR = 21
C
C ADJUST SUMMARY VARIABLES AND RETURN
  990 NKEV = NKEV + IKEV
      NCIT = NCIT + ICIT
      RETURN
      END
      SUBROUTINE SOLNEW
     +   (TN,HN, NEQN,KC,DKCDY,LINEAR, C,W,LC, MM,SS,LL, TOLCIT,
     +    GLAG, CORR,DSYS,MW, WKAREA, UN, IERROR)
C
C ---------------------------------------------------------------------I
C PURPOSE: SOLVE, BY NEWTON ITERATION, THE SYSTEM OF COLLOCATION       I
C -------  EQUATIONS                                                   I
C   U_NJ - GLAG_J -                                                    I
C          SS                                MM                        I
C   - HN.SUM CJ.WK.KC(TN+CJ.HN,TN+CJ.CK.HN,SUM LC_I(CJ.CK).U_NI) = 0   I
C         K=1                               I=1                        I
C                                                       J=L,...,M      I
C                                                                      I
C COMMON VARIABLES:                                                    I
C ----------------                                                     I
      INTEGER METH, M, S, L, ORDER, ORDERQ, METHR, MR, SR, LR, ORDERR,
     +        ERRWGT, NHFAIL, NERR, NWIR, NSAV,
     +        MAXNC, MAXKEV, MAXCPS, N, NCIT, NKEV, NCPS
      COMMON /COLCMI/ METH, M, S, L, ORDER, ORDERQ,
     +                METHR, MR, SR, LR, ORDERR,
     +                ERRWGT, NHFAIL,
     +                NERR, NWIR, NSAV,
     +                MAXNC, MAXKEV, MAXCPS,
     +                N, NCIT, NKEV, NCPS
*
      LOGICAL VS, GSSCKM, ESCGSS, GEC, ULEC, RLXTOL, GEETE,
     +        FUNCIT, NEWTON
      COMMON /COLCML/ VS, GSSCKM, ESCGSS, GEC, ULEC, RLXTOL, GEETE,
     +                FUNCIT, NEWTON
*
      REAL TOLLE, TOLCIA, TOLCIR, HMIN, HMAX, HC
      COMMON /COLCMR/ TOLLE, TOLCIA, TOLCIR, HMIN, HMAX, HC
*
      SAVE /COLCMI/, /COLCML/, /COLCMR/
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER NEQN, MM, SS, LL, MW, IERROR
      LOGICAL LINEAR
      REAL TN, HN, TOLCIT
      REAL C(MM), W(SS), LC(MM,LL:MM,LL:SS),
     +     GLAG(MW), CORR(MW), DSYS(MW,*), WKAREA(*), UN(0:NEQN*MM-1)
      EXTERNAL KC, DKCDY
C                                                                      I
C TN     LEFT ENDPOINT OF CURRENT SUBINTERVAL                          I
C HN     LENGTH OF CURRENT SUBINTERVAL                                 I
C C      -I COLLOC. VARS;                                              I
C W       I EITHER C,W,LC OR CR,WR,LCR                                 I
C LC     -I                                                            I
C MM     -I DIMENSION PARAMETERS FOR COLL. VARS;                       I
C SS      I EITHER M,S,L OR MR,SR,LR                                   I
C LL     -I                                                            I
C TOLCIT TOLERANCE FOR NEWTON ITERATION PROCESS (TOLCIA OR TOLCIR)     I
C GLAG   CONTAINS THE CONSTANT VECTORPART OF THE SYSTEM OF LIN. EQ.    I
C        G(TNJ)+FCN(TNJ) -> GLAG(NEQN*(J-LL)+(1:NEQN))  J=LL,MM        I
C CORR   WORKING STORAGE FOR THE RIGHT HAND SIDE, OR THE SOLUTION, OF  I
C        THE LINEAR SYSTEM IN THE NEWTON ITERATION PROCESS.            I
C DSYS   WORKING STORAGE FOR THE DERIVATIVE OF THE SYSTEM OF LIN. EQ.  I
C        IN THE NEWTON PROCESS.                                        I
C MW     DIMENSION OF LINEAR SYSTEM (=NEQN.(MM-LL+1))                  I
C WKAREA WORKING STORAGE NEEDED TO STORE INTERMEDIATE VECTOR RESULTS;  I
C        ALSO WORKING STORAGE FOR "DECLUF" AND "SOLLUF".               I
C UN     ENTRY: SHOULD CONTAIN AN INITIAL APPR. OF U(TN+CJ.HN)  J=1,MM I
C        EXIT:  APPROX. SOL. OF U(TN+CJ.HN), J=1,MM                    I
C        U(TNJ) -> UN(NEQN*(J-1)+(0:NEQN-1)), J=1,MM                   I
C IERROR ERROR COMPLETION CODE                                         I
C        ENTRY: SHOULD CONTAIN 0                                       I
C        EXIT:  0: NO ERRORS                                           I
C              21: NEWTON ITERATION PROCESS DID NOT CONVERGE WITHIN    I
C                  "MAXNIT" ITERATIONS.                                I
C               OTHER: ERROR COMPLETION CODE OF DECLUF                 I
C                                                                      I
C INVOKED BY: SOLSYS                                                   I
C ----------                                                           I
C                                                                      I
C CHANGES IN COMMON VARIABLES:                                         I
C ---------------------------                                          I
C NCIT   ADDED: # NEWTON ITERATIONS NEEDED TO SOLVE COLLOC. SYSTEM     I
C        IN CURRENT SUBINTERVAL                                        I
C NKEV   ADDED: # KERNEL EVAL. NEEDED WHILE SOLVING COLLOC. SYSTEM     I
C                                                                      I
C CONSTANTS:                                                           I
C ---------                                                            I
      INTEGER MAXNIT
      PARAMETER (MAXNIT = 10)
C                                                                      I
C LOCAL VARIABLES:                                                     I
C ---------------                                                      I
      CHARACTER*15 VAROUT
      INTEGER IKEV, ICIT
      LOGICAL UPDJAC
      REAL TNJ, TNJK
C IKEV   # KERNEL EVALUATIONS IN THIS SUBINTERVAL                      I
C ICIT   # NEWTON ITERATIONS IN THIS SUBINTERVAL                       I
C UPDJAC ALLOWS JACOBIAN TO BE UPDATED ONCE, IF NO CONVERGENCE WITH    I
C        NEWTON'S METHOD WITHOUT UPDATING OF JACOBIAN EACH ITERATION   I
C TNJ    TN + C(J).HN                                                  I
C TNJK   TN + C(J).C(K).HN                                             I
C                                                                      I
C ---------------------------------------------------------------------I
C
      INTEGER I, INDEXJ, I1, I2, ITCORR, J, K, ML, SL
      REAL CJHN, R, WMXNRM
      EXTERNAL WMXNRM
*
      UPDJAC = .TRUE.
*
      I1 = NEQN+1
      IF (.NOT.NEWTON) THEN
         I2 = I1+NEQN*NEQN
      ELSE
         I2 = 1
      ENDIF
      ML = MM-LL+1
      SL = SS-LL+1
      IKEV = 0
C
C
CCCCCCCCCC SOLVE SYSTEM WITH NEWTON ITERATION UNTIL CONVERGENCE;
C          TOLERANCE: "TOLCIT"
   10 CONTINUE
C
C   COMPUTE JACOBIAN AND RIGHT-HAND-SIDE OF SYSTEM OF EQUATIONS
      CALL UNITM (DSYS, MW)
      DO 100 J = LL, MM
         INDEXJ = NEQN*(J-LL)+1
         CJHN = C(J)*HN
         TNJ  = TN + CJHN
*
         CALL COPYV (UN(NEQN*(J-1)), NEQN, CORR(INDEXJ))
         CALL ADDABV (CORR(INDEXJ),NEQN,-1.0,GLAG(INDEXJ))
         DO 110 K = LL, SS
            TNJK = TN + CJHN*C(K)
C
C      COMPUTE U(TN+CJ.CK.HN) USING LAGRANGE INTERPOLATION
C      STORE IN FIRST NEQN LOCATIONS OF WKAREA
            CALL ZEROV (WKAREA(1),NEQN)
            DO 120 I = 1, MM
               CALL ADDABV (WKAREA(1),NEQN,LC(I,J,K),UN(NEQN*(I-1)))
  120       CONTINUE
C
C      COMPUTE -HN.CJ.WK.K(TNJ,TNJK,U(TNJK));
C      STORE KERNEL VALUES IN WKAREA(NEQN+1:)
            R  = CJHN*W(K)
            CALL KC(TNJ,TNJK,WKAREA(1),WKAREA(I1))
            CALL ADDABV (CORR(INDEXJ),NEQN,-R,WKAREA(I1))
C
C      COMPUTE -HN.CJ.WK.D/DY(K(TNJ,TNJK,U(TNJK)));
C      STORE JACOBIAN IN WKAREA(NEQN+1:)
            CALL DKCDY(TNJ,TNJK,WKAREA(1),WKAREA(I1))
            DO 130 I = LL, MM
               CALL ADDABM (DSYS, MW, INDEXJ-1, (I-LL)*NEQN, NEQN,
     +                      -R*LC(I,J,K), WKAREA(I1), NEQN)
  130       CONTINUE
  110    CONTINUE
  100 CONTINUE
      IKEV = IKEV + ML*SL
C
C   SOLVE SYSTEM OF LINEAR EQUATIONS  DSYS(MW,MW).X(MW) = CORR(MW)
      CALL DECLUF (DSYS, MW, MW, WKAREA(I2), IERROR)
      IF (IERROR .NE. 0) GOTO 900
      CALL SOLLUF (DSYS, MW, MW, CORR, WKAREA(I2))
C
C   ADJUST U_N WITH CORRECTION VECTOR
      CALL ADDABV (UN(NEQN*(LL-1)),MW,-1.0,CORR)
*
      ICIT = 1
*
C   CHECK IF MORE ITERATIONS ARE NEEDED
      IF (LINEAR) THEN
C      READY
         GOTO 990
C
C   NON LINEAR KERNEL, CHECK CONVERGENCE OF NEWTON PROCESS
      ELSE IF (WMXNRM(CORR,UN(NEQN*(LL-1)),MW) .LE. TOLCIT) THEN
C       CONVERGED, NO MORE ITERATIONS NEEDED
         GOTO 990
      ENDIF
C
C LOOP IF NON LINEAR AND AS LONG AS LAST CORRECTION IS TOO LARGE
      DO 190 ITCORR = 2, MAXNIT
C
C   IF TRUE NEWTON UPDATE JACOBIAN
C   COMPUTE RIGHT-HAND-SIDE OF SYSTEM OF EQUATIONS
         IF (NEWTON) CALL UNITM (DSYS, MW)
         DO 200 J = LL, MM
            INDEXJ = NEQN*(J-LL)+1
            CJHN = C(J)*HN
            TNJ  = TN + CJHN
*
            CALL COPYV (UN(NEQN*(J-1)), NEQN, CORR(INDEXJ))
            CALL ADDABV (CORR(INDEXJ),NEQN,-1.0,GLAG(INDEXJ))
            DO 210 K = LL, SS
               TNJK = TN + CJHN*C(K)
C
C      COMPUTE U(TN+CJ.CK.HN) USING LAGRANGE INTERPOLATION
C      STORE IN FIRST NEQN LOCATIONS OF WKAREA
               CALL ZEROV (WKAREA(1),NEQN)
               DO 220 I = 1, MM
                  CALL ADDABV (WKAREA(1),NEQN,
     +                         LC(I,J,K),UN(NEQN*(I-1)))
  220          CONTINUE
C
C      COMPUTE -HN.CJ.WK.K(TNJ,TNJK,U(TNJK));
C      STORE KERNEL VALUES IN WKAREA(NEQN+1:)
               R  = CJHN*W(K)
               CALL KC(TNJ,TNJK,WKAREA(1),WKAREA(I1))
               CALL ADDABV (CORR(INDEXJ),NEQN,-R,WKAREA(I1))
C
C      IF TRUE NEWTON PROCESS
C      COMPUTE -HN.CJ.WK.D/DY(K(TNJ,TNJK,U(TNJK)));
C      STORE JACOBIAN IN WKAREA(NEQN+1:)
               IF (NEWTON) THEN
                  CALL DKCDY(TNJ,TNJK,WKAREA(1),WKAREA(I1))
                  DO 230 I = LL, MM
                     CALL ADDABM (DSYS,MW,INDEXJ-1,(I-LL)*NEQN,NEQN,
     +                            -R*LC(I,J,K),WKAREA(I1),NEQN)
  230             CONTINUE
               ENDIF
  210          CONTINUE
  200    CONTINUE
         IKEV = IKEV + ML*SL
C
C   SOLVE SYSTEM OF LINEAR EQUATIONS  DSYS(MW,MW).X(MW) = CORR(MW)
         IF (NEWTON) CALL DECLUF (DSYS, MW, MW, WKAREA(I2), IERROR)
         IF (IERROR .NE. 0) GOTO 900
         CALL SOLLUF (DSYS, MW, MW, CORR, WKAREA(I2))
C
C   ADJUST U_N WITH CORRECTION VECTOR
         CALL ADDABV (UN(NEQN*(LL-1)),MW,-1.0,CORR)
C
C   CHECK IF MORE ITERATIONS ARE NEEDED
C   NON LINEAR KERNEL, CHECK CONVERGENCE OF NEWTON PROCESS
         IF (WMXNRM(CORR,UN(NEQN*(LL-1)),MW) .LE. TOLCIT) THEN
C       CONVERGED, NO MORE ITERATIONS NEEDED
            ICIT = ITCORR
            GOTO 990
         ENDIF
  190 CONTINUE
*
      ICIT = MAXNIT
C
C NO CONVERGENCE IN "MAXNIT" ITERATIONS.
C IF JACOBIAN IS NOT UP TO DATE, UPDATE IT NOW AND TRY AGAIN
      IF (.NOT. NEWTON .AND. UPDJAC) THEN
         UPDJAC = .FALSE.
         NCIT   = NCIT+ICIT
         WRITE(VAROUT,'(E15.5)') TN
         CALL ERRMSG ('MAXIMUM NUMBER OF NEWTON ITERATIONS'//
     +                ' EXCEEDED IN'//VAROUT)
         CALL ERRMSG ('   UPDATE JACOBIAN AND TRY AGAIN')
         GOTO 10
      ENDIF
C
C (ERROR) RETURNS
C
C CONVERGENCE PROBLEMS IN NEWTON ITERATION PROCESS
      WRITE(VAROUT,'(E15.5)') TN
      CALL ERRMSG ('MAXIMUM NUMBER OF NEWTON ITERATIONS EXCEEDED IN'
     +             //VAROUT)
      CALL ERRMSG ('   ONLY HARD ERROR FOR FIXED STEPSIZE CASE')
      IERROR = 21
      GOTO 990
C
C ERROR IN SOLVING LINEAR SYSTEM OF NEWTON PROCESS
  900 CALL ERRMSG('ERROR WHILE SOLVING COLLOC.SYSTEM WITH NEWTON')
C
C ADJUST SUMMARY VARIABLES AND RETURN
  990 NKEV = NKEV + IKEV
      NCIT = NCIT + ICIT
      RETURN
      END
      LOGICAL FUNCTION YPOLM
     +   (TN,HN, NEQN,G,KC,DKCDY,LINEAR, C,W,LC, LCG,LC0,
     +    LAGN,LAG,LAGNP1, UN2, NYPOLM, GLAG2,CORR,DSYS,MW, WKAREA,
     +    UN, URN, IERROR)
C
C ---------------------------------------------------------------------I
C PURPOSE: CHECK IF VIE2 HAS POLYNOMIAL SOLUTION OF DEGREE < M.        I
C -------  IN THAT CASE THE ORDER OF THE GAUSS APPROXIMATION IS 2*M    I
C I.S.O. M IN THE STEPPOINTS.                                          I
C "YPOLM" IS TRUE IF ONE OF THE COMPONENTS OF THE SOLUTION IS FOUND TO I
C BE POLYNOMIAL "NPGESC" CONSECUTIVE TIMES. (NPGESC = 2)               I
C NOTE: LAG AND UN2 SHARE THE SAME MEMORY LOCATIONS UNLESS LOCAL ERROR I
C ----  CONTROL IS USED.                                               I
C                                                                      I
C COMMON VARIABLES:                                                    I
C ----------------                                                     I
      INTEGER METH, M, S, L, ORDER, ORDERQ, METHR, MR, SR, LR, ORDERR,
     +        ERRWGT, NHFAIL, NERR, NWIR, NSAV,
     +        MAXNC, MAXKEV, MAXCPS, N, NCIT, NKEV, NCPS
      COMMON /COLCMI/ METH, M, S, L, ORDER, ORDERQ,
     +                METHR, MR, SR, LR, ORDERR,
     +                ERRWGT, NHFAIL,
     +                NERR, NWIR, NSAV,
     +                MAXNC, MAXKEV, MAXCPS,
     +                N, NCIT, NKEV, NCPS
*
      LOGICAL VS, GSSCKM, ESCGSS, GEC, ULEC, RLXTOL, GEETE,
     +        FUNCIT, NEWTON
      COMMON /COLCML/ VS, GSSCKM, ESCGSS, GEC, ULEC, RLXTOL, GEETE,
     +                FUNCIT, NEWTON
*
      REAL TOLLE, TOLCIA, TOLCIR, HMIN, HMAX, HC
      COMMON /COLCMR/ TOLLE, TOLCIA, TOLCIR, HMIN, HMAX, HC
*
      SAVE /COLCMI/, /COLCML/, /COLCMR/
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER NEQN, MW, IERROR
      LOGICAL LINEAR
      REAL TN, HN
      REAL C(M), W(M), LC(M,M,M), LCG(0:M+1,M), LC0(M),
     +     LAGN(NEQN), LAG(0:NEQN*M-1), LAGNP1(NEQN), UN2(0:NEQN*M-1),
     +     NYPOLM(NEQN), GLAG2(MW), CORR(MW), DSYS(*), WKAREA(*),
     +     UN(0:NEQN*M-1), URN(NEQN)
      EXTERNAL G, KC, DKCDY
C                                                                      I
C TN     LEFT ENDPOINT OF CURRENT SUBINTERVAL                          I
C HN     LENGTH OF CURRENT SUBINTERVAL                                 I
C LCG    LAGR. COEFF. NEEDED TO COMPUTE THE LAG TERM IN TN+CJ.HN/2     I
C LC0    LAGR. COEFF. TO COMPUTE THE APPROX. VALUE OF U IN TN BY       I
C        INTERPOLATION OVER U(TN+CJ.HN) AND BY INTERPOLATION OVER      I
C        U(TN+CJ.HN/2)                                                 I
C LAGN   APPROX. OF THE LAG TERM IN TN                                 I
C LAG    APPROX. OF THE LAG TERM IN TN+CJ.HN, FOR J=1,...,M            I
C        FCN(TNJ) -> LAG(NEQN*(J-1)+(0:NEQN-1))                        I
C LAGNP1 APPROX. OF THE LAG TERM IN TN+HN                              I
C UN2    WORKING STORAGE FOR U(TN+CJ*HN/2), FOR J=1,...,M              I
C        U(TN+CJ*HN/2) -> UN2(NEQN*(J-1)+(0:NEQN-1))                   I
C NYPOLM CONTAINS FOR EACH COMPONENT THE # CONSECUTIVE TIMES THAT      I
C        COMPONENT IS FOUND TO BE A POLYNOMIAL OF DEGREE < M.          I
C GLAG2  WORKING STORAGE FOR CONSTANT PART OF SYSTEM OF LIN. EQ.       I
C CORR   WORKING STORAGE FOR THE RIGHT HAND SIDE, OR THE SOLUTION, OF  I
C        THE LINEAR SYSTEM IN THE CORRECTOR ITERATION PROCESS.         I
C DSYS   WORKING STORAGE FOR THE DERIVATIVE OF THE SYSTEM OF LIN. EQ.  I
C        IN THE NEWTON PROCESS.                                        I
C MW     DIMENSION OF SYSTEM OF COLL. EQ. (MW=NEQN.M)                  I
C WKAREA WORKING STORAGE USED FOR INTERMEDIATE VECTOR RESULTS (2*NEQN) I
C        ALSO WORKING STORAGE FOR LIN.SYS. SOLVER (CF. "SOLSYS")       I
C UN     CONTAINS THE APPROXIMATED SOLUTION U(TN+CJ.HN)                I
C        U(TNJ) -> UN(NEQN*(J-1)+(0:NEQN-1)                            I
C URN    CONTAINS THE REFERENCE SOLUTION UR(TN)                        I
C IERROR ERROR COMPLETION CODE                                         I
C        ENTRY: SHOULD CONTAIN 0                                       I
C        EXIT:  0: NO ERRORS                                           I
C              31: NEWTON ITERATION PROCESS DID NOT CONVERGE WITHIN    I
C                  "MAXNIT" ITERATIONS.                                I
C               OTHER: ERROR COMPLETION CODE OF "DECLUF"               I
C                                                                      I
C INVOKED BY: SOLVI2                                                   I
C ----------                                                           I
C                                                                      I
C CHANGES IN COMMON VARIABLES: NONE                                    I
C ---------------------------                                          I
C                                                                      I
C CONSTANTS:                                                           I
C ---------                                                            I
      INTEGER NPGESC
      PARAMETER (NPGESC = 2)
      REAL GSSFAC
      PARAMETER (GSSFAC = 2.0)
C                                                                      I
C LOCAL VARIABLES:                                                     I
C ---------------                                                      I
      CHARACTER*15 VAROUT
      LOGICAL YPOLMK
      REAL E1, E2, INV2M
C YPOLMK TRUE IF K-TH COMP. OF SOL. IS FOUND TO BE A POLYNOMIAL IN TN  I
C E1     WEIGHTED GLOBAL ERROR EST. IN TN (UR(TN) - U(TN))             I
C E2     SECOND EST. OF WEIGHTED GLOBAL ERROR IN TN: UR(TN) - UN2(TN)  I
C        WHERE UN2 IS COLLOC. APPROX. OBTAINED BY SOLVING COLLOC.      I
C        SYSTEM OVER HALF THE INTERVAL [TN,TN+HN]                      I
C INV2M  VALUE TO DETERMINE WHETHER SOL. IS POL.; INV2M = GSSFAC/2**M  I
C        IF E2/E1 <= INV2M IT IS ASSUMED THAT THE GLOB.ERR.EST. IS OK  I
C                                                                      I
C ---------------------------------------------------------------------I
C
      INTEGER INDEXJ, I1, J, K
      REAL WMXNRM
      EXTERNAL WMXNRM
*
      YPOLM  = .FALSE.
*
      I1     = NEQN+1
      INV2M  = GSSFAC / (2**M)
C
C COMPUTE LAGTERM FCN(TN+CJ.HN/2) BY LAGRANGE INTERPOLATION OVER 0,CK,1;
C STORE G(TN+CJ.HN/2)+FCN(TN+CJ.HN/2) IN GLAG2(J)
      DO 10 J = 1, M
         INDEXJ = NEQN*(J-1)+1
         CALL G(TN+C(J)*HN/2,GLAG2(INDEXJ))
         CALL ADDABV (GLAG2(INDEXJ), NEQN, LCG(0,J), LAGN)
         DO 20 K = 1, M
            CALL ADDABV (GLAG2(INDEXJ), NEQN, LCG(K,J), LAG(NEQN*(K-1)))
   20    CONTINUE
         CALL ADDABV (GLAG2(INDEXJ), NEQN, LCG(M+1,J), LAGNP1)
   10 CONTINUE
C
C SOLVE SYSTEM OF COLLOCATION EQUATIONS FOR U(TN+CJ.HN/2)
      DO 30 J = 1, M
         INDEXJ = NEQN*(J-1)
         CALL COPYV (UN(INDEXJ), NEQN, UN2(INDEXJ))
   30 CONTINUE
      CALL SOLSYS (TN,HN/2, NEQN,KC,DKCDY,LINEAR, C,W,LC,M,S,L, TOLCIA,
     +             GLAG2,CORR,DSYS,MW, WKAREA, UN2, IERROR)
      IF (IERROR .NE. 0) GOTO 900
C
C COMPUTE UN AND UN2 IN TN BY LAGRANGE INTERPOLATION OVER M POINTS;
C COMPUTE GLOBAL ERRORS GEE(UN), STORED IN WKAREA(1:NEQN), AND
C GEE(UN2), STORED IN WKAREA(NEQN+1:).
      CALL COPYV (URN, NEQN, WKAREA)
      CALL COPYV (URN, NEQN, WKAREA(I1))
      DO 40 J = 1, M
         INDEXJ = NEQN*(J-1)
         CALL ADDABV (WKAREA, NEQN, -LC0(J), UN(INDEXJ))
         CALL ADDABV (WKAREA(I1), NEQN, -LC0(J), UN2(INDEXJ))
   40 CONTINUE
C
C CHECK IF SOLUTION IS POLYNOMIAL, I.E. IF GEE(UN) IS O(H**2M) AND
C GEE(UN2) IS O(H**(M+2)); OTHERWISE GEE(UN)/GEE(UN2) = 2**M.
C IF THE WEIGHTED NORM OF BOTH ERROR VECTORS IS LESS THAN THE CORR.IT.
C TOLERANCE THEN IT IS ASSUMED THAT THE GLOBAL ERROR ESTIMATE WILL
C BE O.K.; IF ONLY GEE(UN) < TOLCIA THEN THE SOLUTION IS ASSUMED TO BE
C A POLYNOMIAL OF DEGREE < M.
      DO 50 K = 1, NEQN
         E1 = WMXNRM (WKAREA(K),      URN(K), 1)
         E2 = WMXNRM (WKAREA(I1+K-1), URN(K), 1)
         IF (E1 .LT. TOLCIA) THEN
            IF (E2 .LT. TOLCIA) THEN
               YPOLMK = .FALSE.
            ELSE
               YPOLMK = .TRUE.
            ENDIF
         ELSE IF (E2/E1 .LE. INV2M) THEN
            YPOLMK = .FALSE.
         ELSE
            YPOLMK = .TRUE.
         ENDIF
*
         IF (YPOLMK) THEN
C    SOLUTION IS FOUND TO BE POLYNOMIAL
            WRITE(VAROUT,'(E15.5)') TN
            CALL ERRMSG ('SOLUTION IS FOUND TO BE POLYNOMIAL AT T ='//
     +                   VAROUT)
            WRITE(VAROUT,'(I5)') K
            CALL ERRMSG ('  COMPONENT:'//VAROUT)
            NYPOLM(K) = NYPOLM(K) + 1
            IF (NINT(NYPOLM(K)) .GE. NPGESC) YPOLM = .TRUE.
         ELSE
            NYPOLM(K) = 0
         ENDIF
   50 CONTINUE
*
      IF (.NOT. YPOLM) RETURN
C
C SOLUTION POLYNOMIAL; PROBLEMS IN CASE OF GAUSS COLL. PARS.
      WRITE(VAROUT,'(I14)') NPGESC
      CALL ERRMSG ('SOLUTION BEHAVED AS A POLYNOMIAL OF DEGREE < M'//
     +             VAROUT//'CONSECUTIVE TIMES')
      RETURN
C
C ERROR IN SOLVING UN WITH HALVED STEPSIZE
  900 CONTINUE
      IF (IERROR .EQ. 21) THEN
         CALL ERRMSG ('   AND WHEN TESTING ON SUPERCONVERGENCE IN ZN'//
     +                ' FOR GAUSS METHOD')
         IERROR = 31
      ELSE
         CALL ERRMSG ('   ERROR OCCURRED WHEN TESTING ON SUPER'//
     +                'CONVERGENCE IN ZN FOR GAUSS METHOD')
      ENDIF
      RETURN
*
      END
      SUBROUTINE UTILIP (NEQN, UI, LC1, UIP1)
C
C ---------------------------------------------------------------------I
C PURPOSE: COMPUTE COLLOCATION SOLUTION IN THE RIGHT ENDPOINT OF THE   I
C -------  I-TH SUBINTERVAL WITH LAGRANGIAN INTERPOLATION.             I
C ONLY USED IN CASE OF GAUSS COLLOCATION.                              I
C                                                                      I
C COMMON VARIABLES:                                                    I
C ----------------                                                     I
      INTEGER METH, M, S, L, ORDER, ORDERQ, METHR, MR, SR, LR, ORDERR,
     +        ERRWGT, NHFAIL, NERR, NWIR, NSAV,
     +        MAXNC, MAXKEV, MAXCPS, N, NCIT, NKEV, NCPS
      COMMON /COLCMI/ METH, M, S, L, ORDER, ORDERQ,
     +                METHR, MR, SR, LR, ORDERR,
     +                ERRWGT, NHFAIL,
     +                NERR, NWIR, NSAV,
     +                MAXNC, MAXKEV, MAXCPS,
     +                N, NCIT, NKEV, NCPS
*
      SAVE /COLCMI/
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER NEQN
      REAL UI(0:NEQN*M-1), LC1(M), UIP1(NEQN)
C UI     CONTAINS THE SOL. IN THE COLL. POINTS OF THE I-TH SUBINT.     I
C        U(TIJ) -> UI(NEQN*(J-1)+(0:NEQN-1)), J=1,M                    I
C UIP1   EXIT: CONTAINS APPROX.COLL.SOL. IN T(I+1)                     I
C                                                                      I
C INVOKED BY: SOLVI2                                                   I
C ----------                                                           I
C                                                                      I
C CHANGES IN COMMON VARIABLES: NONE                                    I
C ---------------------------                                          I
C                                                                      I
C ---------------------------------------------------------------------I
C
      INTEGER J
*
      CALL ZEROV (UIP1, NEQN)
      DO 10 J = 1, M
         CALL ADDABV (UIP1, NEQN, LC1(J), UI(NEQN*(J-1)))
   10 CONTINUE
*
      RETURN
      END
      SUBROUTINE COMPUH (T, NEQN, T0, WKAREA, UH)
C
C ---------------------------------------------------------------------I
C PURPOSE: COMPUTE APPROXIMATION "UH" IN THE POINT "T" WITH            I
C -------  LAGRANGE INTERPOLATION USING THE ARRAY OF APPROXIMATIONS "U"I
C STORED IN "WKAREA".                                                  I
C                                                                      I
C COMMON VARIABLES:                                                    I
C ----------------                                                     I
      INTEGER METH, M, S, L, ORDER, ORDERQ, METHR, MR, SR, LR, ORDERR,
     +        ERRWGT, NHFAIL, NERR, NWIR, NSAV,
     +        MAXNC, MAXKEV, MAXCPS, N, NNIT, NKEV, NCPS
      COMMON /COLCMI/ METH, M, S, L, ORDER, ORDERQ,
     +                METHR, MR, SR, LR, ORDERR,
     +                ERRWGT, NHFAIL,
     +                NERR, NWIR, NSAV,
     +                MAXNC, MAXKEV, MAXCPS,
     +                N, NNIT, NKEV, NCPS
*
      INTEGER IC1,IC2,IC3,IC4,IC5,IC6,IC7,IC8,ICE, IV1,IV2,IV3,IVE,
     +        IL1,IL2,IL3,IL4,IL5,ILAG,IL6,ILE
      COMMON /COLIXW/ IC1,IC2,IC3,IC4,IC5,IC6,IC7,IC8,ICE,
     +                IV1,IV2,IV3,IVE, IL1,IL2,IL3,IL4,IL5,ILAG,IL6,ILE
*
      SAVE /COLCMI/, /COLIXW/
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER NEQN
      REAL T, T0
      REAL WKAREA(*), UH(NEQN)
C                                                                      I
C CHANGES IN COMMON VARIABLES: NONE                                    I
C ---------------------------                                          I
C                                                                      I
C ---------------------------------------------------------------------I
C
      INTEGER I, INDEXI, K
      REAL HI, TAU, TI
*
C DETERMINE LAST STEPPOINT BEFORE "T", STORE IN TI
      I = 0
      TI = T0
      DO 10 K = 0, N-1
         HI = WKAREA(IV1+K)
         IF (TI+HI .GE. T) GOTO 20
         TI = TI + HI
         I = K+1
   10 CONTINUE
*
   20 TAU = T-TI
C COMPUTE LAGRANGIAN INTERPOLATION COEFFICIENTS IN (T-TI)/HI
      CALL COMPLV (TAU/HI, M, WKAREA(1), WKAREA(ILE))
*
C COMPUTE U(T) = SUM LC_K((T-TI)/HI).U(TI+CK.HI)
      INDEXI = IV2 + NEQN*(1+(M-L+1)*I)
      CALL ZEROV (UH, NEQN)
      DO 30 K = 1, M
         CALL ADDABV (UH,NEQN,WKAREA(ILE+K-1),WKAREA(INDEXI+(K-L)*NEQN))
   30 CONTINUE
      RETURN
      END
      SUBROUTINE ITRCOL
     +   (TNP1, NEQN, G, KC, T0, H, C, W, U, WKAREA, LAGNP1, URNP1)
C
C ---------------------------------------------------------------------I
C PURPOSE: COMPUTE ITERATED COLLOCATION SOLUTION IN RIGHT ENDPOINT OF  I
C -------  CURRENT SUBINTERVAL.                                        I
C NOTE: IT IS POSSIBLE THAT LAGNP1 USES THE SAME MEMORY LOCATIONS AS   I
C ----  URNP1.                                                         I
C                                                                      I
C COMMON VARIABLES:                                                    I
C ----------------                                                     I
      INTEGER METH, M, S, L, ORDER, ORDERQ, METHR, MR, SR, LR, ORDERR,
     +        ERRWGT, NHFAIL, NERR, NWIR, NSAV,
     +        MAXNC, MAXKEV, MAXCPS, N, NCIT, NKEV, NCPS
      COMMON /COLCMI/ METH, M, S, L, ORDER, ORDERQ,
     +                METHR, MR, SR, LR, ORDERR,
     +                ERRWGT, NHFAIL,
     +                NERR, NWIR, NSAV,
     +                MAXNC, MAXKEV, MAXCPS,
     +                N, NCIT, NKEV, NCPS
*
      SAVE /COLCMI/
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER NEQN
      REAL TNP1, T0
      REAL H(0:MAXNC), C(M), W(M), U(-NEQN:NEQN*M*MAXNC-1),
     +     WKAREA(*), LAGNP1(NEQN), URNP1(NEQN)
      EXTERNAL G, KC
C TNP1   RIGHT ENDPOINT OF CURRENT SUBINTERVAL                         I
C H      ENTRY: H(0:N) SHOULD CONTAIN THE LENGTH OF THE SUBINTERVALS   I
C U      ENTRY: U(-NEQN:NEQN*M*(N+1)-1) SHOULD CONTAIN THE COLL.APPROX.I
C               OF U(TI+CJ.HI), I=0..N, J=1..M                         I
C WKAREA WORKING STORAGE FOR INTERMEDIATE VECTOR RESULTS (>=NEQN)      I
C LAGNP1 EXIT: FCN(TNP1) (IF DIFFERENT LOCATIONS FROM URNP1)           I
C URNP1  EXIT: ITERATED COLL. SOLUTION IN TNP1                         I
C                                                                      I
C INVOKED BY: COLVI2, SOLVI2                                           I
C ----------                                                           I
C                                                                      I
C CHANGES IN COMMON VARIABLES:                                         I
C ---------------------------                                          I
C NKEV   ADDED: # KERNEL EVAL. NEEDED (1-ST ARGUMENT: TN+HN)           I
C                                                                      I
C LOCAL VARIABLES:                                                     I
C ---------------                                                      I
      INTEGER INDEXI
      REAL HI, TI
C INDEXI POINTER TO APPROX. IN 1-ST COLLOC. POINT OF I-TH SUBINTERVAL  I
C                                                                      I
C ---------------------------------------------------------------------I
C
      INTEGER I, J
C
C COMPUTE LAG TERM  FCN (TNP1); STORE IN LAGNP1
C STORE KERNEL VECTOR IN "WKAREA"
      CALL ZEROV (LAGNP1, NEQN)
      TI = T0
      DO 10 I = 0, N-1
         INDEXI = NEQN*M*I
         HI = H(I)
         DO 20 J = 1, M
            CALL KC(TNP1,TI+C(J)*HI,U(INDEXI+NEQN*(J-1)),WKAREA)
            CALL ADDABV (LAGNP1, NEQN, HI*W(J), WKAREA)
   20    CONTINUE
         TI = TI + HI
   10 CONTINUE
*
C COMPUTE FCNP1(TNP1); STORE IN URNP1
      INDEXI = NEQN*M*N
      HI = H(N)
      CALL COPYV (LAGNP1, NEQN, URNP1)
      DO 30 J = 1, M
         CALL KC(TNP1,TI+C(J)*HI,U(INDEXI+NEQN*(J-1)),WKAREA)
         CALL ADDABV (URNP1, NEQN, HI*W(J), WKAREA)
   30 CONTINUE
*
C COMPUTE THE ITERATED COLLOCATION APPROXIMATION IN TNP1
C STORE G VECTOR IN "WKAREA"
      CALL G(TNP1, WKAREA)
      CALL ADDABV (URNP1, NEQN, 1.0, WKAREA)
      NKEV = NKEV + M*(N+1)
*
      RETURN
      END
      SUBROUTINE CHKINI
     +   (NEQN,G, T0,TE, REQTOL, DEFOPT,IOPT,OPT,CNTRL, WKAREA,IW,
     +    TN, HINIT, ZLEESM, IERROR)
C
C ---------------------------------------------------------------------I
C PURPOSE: CHECK VALIDITY AND CONSISTENCY OF USER SUPPLIED "COLVI2"    I
C -------  PARAMETERS. INITIALIZE COMMON BLOCKS. IN CASE OF A RE-ENTRY I
C AFTER A SAVE BY "SAVALL" RELOAD COMMON BLOCKS AND WKAREA FROM FILE.  I
C (RE)DISTRIBUTE WORKING STORAGE "WKAREA"                              I
C                                                                      I
C COMMON VARIABLES:                                                    I
C ----------------                                                     I
      INTEGER METH, M, S, L, ORDER, ORDERQ, METHR, MR, SR, LR, ORDERR,
     +        ERRWGT, NHFAIL, NERR, NWIR, NSAV,
     +        MAXNC, MAXKEV, MAXCPS, N, NCIT, NKEV, NCPS
      COMMON /COLCMI/ METH, M, S, L, ORDER, ORDERQ,
     +                METHR, MR, SR, LR, ORDERR,
     +                ERRWGT, NHFAIL,
     +                NERR, NWIR, NSAV,
     +                MAXNC, MAXKEV, MAXCPS,
     +                N, NCIT, NKEV, NCPS
*
      LOGICAL VS, GSSCKM, ESCGSS, GEC, ULEC, RLXTOL, GEETE,
     +        FUNCIT, NEWTON
      COMMON /COLCML/ VS, GSSCKM, ESCGSS, GEC, ULEC, RLXTOL, GEETE,
     +                FUNCIT, NEWTON
*
      REAL TOLLE, TOLCIA, TOLCIR, HMIN, HMAX, HC
      COMMON /COLCMR/ TOLLE, TOLCIA, TOLCIR, HMIN, HMAX, HC
*
      INTEGER IC1,IC2,IC3,IC4,IC5,IC6,IC7,IC8,ICE, IV1,IV2,IV3,IVE,
     +        IL1,IL2,IL3,IL4,IL5,ILAG,IL6,ILE
      COMMON /COLIXW/ IC1,IC2,IC3,IC4,IC5,IC6,IC7,IC8,ICE,
     +                IV1,IV2,IV3,IVE, IL1,IL2,IL3,IL4,IL5,ILAG,IL6,ILE
*
      INTEGER IBETA, IOVFLO, NSDEC, IMXLUN
      COMMON /COLMCI/ IBETA, IOVFLO, NSDEC, IMXLUN
*
      REAL SRELPR, SOVFLO, SUNFLO
      COMMON /COLMCR/ SRELPR, SOVFLO, SUNFLO
*
      SAVE /COLCMI/, /COLCML/, /COLCMR/, /COLIXW/, /COLMCI/, /COLMCR/
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER NEQN, DEFOPT, IW, IERROR
      INTEGER IOPT(*), CNTRL(*)
      LOGICAL ZLEESM
      REAL T0, TE, REQTOL, TN, HINIT
      REAL OPT(*), WKAREA(IW)
      EXTERNAL G
C TN     LEFT ENDPOINT OF CURRENT SUBINTERVAL;                         I
C        IF FIRST CALL EXIT, OTHERWISE ENTRY PARAMETER                 I
C HINIT  EXIT: INITIAL GUESS OF LENGTH OF FIRST SUBINTERVAL            I
C ZLEESM EXIT: TRUE IF VECTOR LEESUM HAS TO BE INITIALIZED ON ZERO,    I
C              I.E., IF EITHER THIS IS THE FIRST CALL OF COLVI2 OR IF  I
C              THE PREVIOUS CALL DID NOT RESULT IN A (USABLE) ESTIMATE I
C              OF A PARTIAL SUM OF LOCAL ERRORS.                       I
C IERROR ENTRY: 0                                                      I
C        EXIT : 0: OK                                                  I
C               1: DEFOPT INVALID OR STATUS ERROR_MESSAGE_FILE WRONG   I
C               2: OTHER ERRORS FOUND IN THE PARAMETERS                I
C                                                                      I
C INVOKED BY: COLVI2                                                   I
C ----------                                                           I
C                                                                      I
C CHANGES IN COMMON VARIABLES:                                         I
C ---------------------------                                          I
C ALL VARIABLES IN THE COMMON BLOCKS /COLCMI/, /COLCML/ AND /COLCMR/   I
C ARE INITIALIZED, UNLESS THE VALUES OF PREVIOUS CALLS OF "COLVI2" ARE I
C TO BE PRESERVED.                                                     I
C                                                                      I
C !!!!!!!!! IMPORTANT !!!!!!!!! IMPORTANT !!!!!!!!! IMPORTANT !!!!!!!!!!
C                                                                     !!
C MACHINE DEPENDENCIES:                                               !!
C --------------------                                                !!
C FOR THE DISTRIBUTION OF "WKAREA" IT IS ASSUMED THAT A LIN. SYSTEM OF!!
C X EQUATIONS CAN BE SOLVED USING X EXTRA MEMORY LOCATIONS AS WORKING !!
C STORAGE (AS IS THE CASE WITH IMSL'S "LUDATF"+"LUELMF", AND THE      !!
C INCORPORATED GAUSS ELIMINATION ROUTINES).                           !!
C IF THIS IS NOT THE CASE CHANGE THE INDICATED STATEMENTS BELOW.      !!
C (ONLY IN CASE NEWTON'S METHOD IS USED TO SOLVE THE COLL. SYSTEM)    !!
C                                                                     !!
C !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
C                                                                      I
C CONSTANTS:                                                           I
C ---------                                                            I
      CHARACTER*16 HDR
      INTEGER LSBITS, MCDEF
      REAL HMINFC, TOLFRS
      PARAMETER (HDR    = ' ERROR COLVI2...')
      PARAMETER (LSBITS = 128)
      PARAMETER (MCDEF  = 81)
      PARAMETER (HMINFC = 1.0E-5)
      PARAMETER (TOLFRS = 0.1)
C                                                                      I
C LOCAL VARIABLES:                                                     I
C ---------------                                                      I
      INTEGER MAXNCO, MW, NHC, NIRVEC, NWKSYS
      LOGICAL GECO, NEWOPT, RENTRY, ULECO
      REAL HCO, TEO, TOLMIN
      SAVE TEO
C MAXNCO TOTAL # STEPS ALLOWED IN PREVIOUS CALL                        I
C MW     MAX. DIMENSION COLLOC. SYSTEM TO BE SOLVED                    I
C NHC    MAX. # CHECKPOINTS IN REMAINING INTERVAL WHERE UNIFORM ERROR  I
C        CONTROL IS PERFORMED.                                         I
C NIRVEC AMOUNT OF WORKSPACE NEEDED FOR INTERMEDIATE VECTOR RESULTS    I
C NWKSYS WORKSPACE NEEDED BY "DECLUF" AND "SOLLUF" TO SOLVE LIN.SYSTEM I
C        OF DIM. "MW" IN THE NEWTON PROCESS                            I
C GECO   TRUE IF GLOBAL ERROR CONTROL HAS BEEN SELECTED IN PREV. CALL  I
C NEWOPT IF FALSE "COLVI2" HAS BEEN RE-CALLED WITH THE SAME OPTIONS AS I
C        IN THE LAST CALL.                                             I
C RENTRY IF FALSE, THEN FIRST CALL OF "COLVI2"                         I
C ULECO  TRUE IF UNIFORM ERROR CONTROL HAS BEEN SELECTED IN PREV. CALL I
C HCO    INTERVAL LENGTH BETWEEN TWO CONSECUTIVE CHECKPOINTS FOR THE   I
C        UNIFORM ERROR CONTROL IN PREVIOUS CALL                        I
C TEO    "TE" AS SUPPLIED IN PREVIOUS CALL OF COLVI2                   I
C        ON EXIT THE CURRENT "TE" WILL BE SAVED IN TEO IN CASE COLVI2  I
C        WILL BE CALLED A SECOND TIME FROM THE SAME MAIN PROGRAM.      I
C TOLMIN MINIMUM TOLERANCE POSSIBLE TAKING INTO ACCOUNT THE MACHINE    I
C        PRECISION AND THE ESTIMATED COMPUTATIONAL LOSS.               I
C                                                                      I
C ---------------------------------------------------------------------I
C
      INTEGER IDUM(10)
C NEEDED TO RESOLVE TYPE CONFLICTS WHEN CALLING "RELOAD" IF CNTRL(1) = 2
C
      INTEGER IDENOM, IOPT1,IOPT8,IOPT9,IOPT9A,IOPT9B,IOPT9C,IOPT9D,
     +        METCIT, METOPT, ML, MRL, NCPJOB, NUMER, SL, SRL
      EXTERNAL NCPJOB
C
C
C INITIALIZE COMMON BLOCKS CONTAINING MACHINE CONSTANTS
      CALL INICMC
C
C COMPUTE THE MOST TIGHT REQUIRED_TOLERANCE
      TOLMIN = LSBITS*SRELPR
C
C
C CHECK PARAMETER DEFOPT
      IF ((DEFOPT .LT.  0 .OR.  DEFOPT .GT.  2) .AND.
     +    (DEFOPT .NE. 11 .AND. DEFOPT .NE. 12) .AND.
     +    (DEFOPT .NE. 21 .AND. DEFOPT .NE. 22)) THEN
         PRINT *, HDR, 'INPUT PARAMETER DEFOPT = ', DEFOPT
         PRINT *, HDR, '   DEFAULT OPTIONS SETTING, SHOULD BE:'
         PRINT *, HDR, '      DEFOPT = 0,1,2, 11,12, OR 21,22'
         PRINT *, HDR, '   NO FURTHER CONTROL ON INPUT PARAMETERS'
         IERROR = 1
         RETURN
      ELSE IF (DEFOPT .NE. 0) THEN
         METCIT = DEFOPT/10
         METOPT = DEFOPT - METCIT*10
         IF (METOPT .EQ. 1) THEN
            METH   = 1
            M      = 8
            S      = M
            L      = 1
            ORDER  = M
            ORDERQ = 2*M
            METHR  = 1
            MR     = M
            SR     = MR
            LR     = 1
            ORDERR = 2*MR
*
            GSSCKM = .TRUE.
            ESCGSS = .TRUE.
            ULEC   = .FALSE.
*
            HC     = 0.0
*
            ZLEESM = .FALSE.
         ELSE
            METH   = 3
            M      = 6
            S      = M
            L      = 2
            ORDER  = 2*M-2
            ORDERQ = ORDER
            METHR  = METH
            MR     = M+1
            SR     = MR
            LR     = 2
            ORDERR = 2*MR-2
*
            GSSCKM = .FALSE.
            ESCGSS = .FALSE.
            ULEC = .TRUE.
*
            HC     = 1.0
*
            ZLEESM = .TRUE.
         ENDIF
*
         ERRWGT = 1
         NERR   = 0
         NWIR   = 0
         NSAV   = 0
         MAXKEV = IOVFLO
         MAXCPS = IOVFLO
         N      = 0
*
         VS     = .TRUE.
         GEC    = .TRUE.
         RLXTOL = .TRUE.
         GEETE  = .TRUE.
         IF (METCIT .EQ. 0) THEN
            FUNCIT = .FALSE.
            NEWTON = .TRUE.
         ELSE IF (METCIT .EQ. 1) THEN
            FUNCIT = .FALSE.
            NEWTON = .FALSE.
         ELSE
            FUNCIT = .TRUE.
            NEWTON = .FALSE.
         ENDIF
*
         HINIT  = MIN(TE-T0,1.0)
         HMIN   = MAX(SUNFLO, HINIT*HMINFC)
         HMAX   = 1.0
*
         RENTRY = .FALSE.
         NEWOPT = .TRUE.
         TN     = T0
      ELSE
C
C
C CHECK IF USER PROVIDED FILES HAVE THE CORRECT STATUS
         CALL CHKFIL (CNTRL, IERROR)
C   RETURN IF STATUS ERROR_MESSAGE_FILE WRONG
         IF (IERROR .EQ. 1) RETURN
C
C
C CHECK INPUT PARAMETERS CNTRL, IOPT AND OPT
C
         CALL CHKOPT (CNTRL, IOPT, OPT, MCDEF,
     +                MAX(SUNFLO,MAX(ABS(T0),ABS(TE))*SRELPR), IERROR)
C   RETURN IF ERRORS HAVE BEEN DETECTED THAT PREVENT FURTHER CHECKING
         IF (IERROR .LT. 0) THEN
            IERROR = -IERROR
            RETURN
         ENDIF
*
         RENTRY = CNTRL(1) .NE. 0
         NEWOPT = CNTRL(1) .LE. 2
C
C
C REACT ON RE-ENTRY; STORE COMMON BLOCK VARIABLES
C
         IF (CNTRL(1) .EQ. 2) THEN
C   RE-ENTRY AFTER SAVE BY "SAVALL"; NEW OPTIONS
            CALL RELOAD (CNTRL(4), WKAREA,IW, IDUM(1),IDUM(2),WKAREA,
     +                   TEO, TN, IERROR)
C         RETURN IF RELOAD FAILED
            IF (IERROR .LT. 0) THEN
               IERROR = -IERROR
               RETURN
            ENDIF
         ELSE IF (CNTRL(1) .EQ. 4) THEN
C   RE-ENTRY AFTER SAVE BY "SAVALL"; OLD OPTIONS
            CALL RELOAD (CNTRL(4), WKAREA,IW, DEFOPT,IOPT,OPT, TEO,
     +                   TN, IERROR)
C         RETURN IF RELOAD FAILED
            IF (IERROR .LT. 0) THEN
               IERROR = -IERROR
               RETURN
            ENDIF
         ENDIF
         IF (RENTRY) THEN
            HCO    = HC
            MAXNCO = MAXNC
            GECO   = GEC
            ULECO  = ULEC
         ENDIF
C
C
C CHECK CONSISTENCY OF OPTION VECTORS WITH PREVIOUS CALL OF COLVI2
         IF (CNTRL(1) .EQ. 1 .OR. CNTRL(1) .EQ. 2) THEN
            CALL CHKREC (IOPT, MCDEF, IERROR)
C   RETURN IF ERRORS HAVE BEEN DETECTED THAT PREVENT FURTHER CHECKING
            IF (IERROR .LT. 0) THEN
               IERROR = -IERROR
               RETURN
            ENDIF
         ENDIF
C
C
C   INITIALIZE CONTROL VARIABLES IN COMMON /COLCMI/
C
         NERR   = CNTRL(2)
         NWIR   = CNTRL(3)
         NSAV   = CNTRL(4)
*
         IF (NEWOPT) THEN
C         INITIALIZE COMMON BLOCK VARIABLES AND ,IF NEEDED, TN
C
            IF (.NOT. RENTRY) THEN
C         FIRST ENTRY
               IOPT1  = IOPT(1)
               IF (IOPT1 .EQ. 0) IOPT1  = MCDEF
               M      = IOPT1/10
               METH   = IOPT1 - 10*M
*
               GOTO (10, 20, 30, 40) METH
C GAUSS
   10          S      = M
               L      = 1
               ORDER  = M
               ORDERQ = 2*M
               GOTO 50
C (M-1) GAUSS + CM=1
   20          S      = M-1
               L      = 1
               ORDER  = 2*M-2
               ORDERQ = ORDER
               GOTO 50
C LOBATTO
   30          S      = M
               L      = 2
               ORDER  = 2*M-2
               ORDERQ = ORDER
               GOTO 50
C RADAU
   40          S      = M
               L      = 1
               ORDER  = 2*M-1
               ORDERQ = ORDER
*
   50          CONTINUE
*
               N      = 0
               TN     = T0
            ENDIF
*
            ERRWGT = IOPT(4) + 1
            MAXKEV = IOPT(6)
            IF (MAXKEV .EQ. 0) MAXKEV = IOVFLO
            MAXCPS = IOPT(7)
            IF (MAXCPS .EQ. 0) MAXCPS = IOVFLO
*
            VS     = IOPT(2) .EQ. 0
            GEETE  = IOPT(3) .EQ. 0
            IF (IOPT(5) .EQ. 0) THEN
               FUNCIT = .FALSE.
               NEWTON = .TRUE.
            ELSE IF (IOPT(5) .EQ. 1) THEN
               FUNCIT = .FALSE.
               NEWTON = .FALSE.
            ELSE
               FUNCIT = .TRUE.
               NEWTON = .FALSE.
            ENDIF
*
            IF (VS .OR. GEETE) THEN
C   REF. SOL. REQUIRED
               IOPT8  = IOPT(8)
               IF (IOPT8 .EQ. 0) IOPT8  = MCDEF
               MR     = IOPT8/10
               METHR  = IOPT8 - 10*MR
               GOTO (110, 120, 130, 140) METHR
C ITERATED GAUSS
  110          SR     = MR
               LR     = 1
               ORDERR = 2*MR
               GOTO 150
C (MR-1) GAUSS + CMR=1
  120          SR     = MR-1
               LR     = 1
               ORDERR = 2*MR-2
               GOTO 150
C LOBATTO
  130          SR     = MR
               LR     = 2
               ORDERR = 2*MR-2
               GOTO 150
C RADAU
  140          SR     = MR
               LR     = 1
               ORDERR = 2*MR-1
*
  150          CONTINUE
            ELSE
               METHR  = 0
               MR     = 0
               SR     = 0
               LR     = 1
               ORDERR = 0
            ENDIF
*
            IF (VS) THEN
C   VARIABLES FOR STEPSIZE STRATEGY
               IOPT9  = IOPT(9)
               IOPT9A = IOPT9/1000
               IOPT9  = IOPT9 - 1000*IOPT9A
               IOPT9B = IOPT9/100
               IOPT9  = IOPT9 - 100*IOPT9B
               IOPT9C = IOPT9/10
               IOPT9D = IOPT9 - 10*IOPT9C
               IF (METHR .EQ. 1) THEN
                  GSSCKM = IOPT9C .LT. 2
                  ESCGSS = IOPT9C .EQ. 0
                  GEC    = .TRUE.
                  ULEC   = .FALSE.
               ELSE
                  GEC    = IOPT9B .EQ. 0
                  GSSCKM = IOPT9A .LT. 2 .AND.
     +                     GEC .AND. METH.EQ.1 .AND. ORDERQ.GE.ORDERR
                  ESCGSS = IOPT9A .EQ. 0 .AND. GSSCKM
                  ULEC   = IOPT9C .EQ. 0
               ENDIF
               RLXTOL = IOPT9D .EQ. 0
*
               IF (OPT(1) .NE. 0.0) THEN
                  HINIT  = OPT(1)
               ELSE IF (CNTRL(1) .EQ. 0) THEN
                  HINIT  = MIN(TE-T0,1.0)
               ELSE
                  HINIT  = WKAREA(IV1+N)
               ENDIF
               HMIN   = OPT(2)
               IF (HMIN .EQ. 0.0) HMIN   = MAX(SUNFLO,HINIT*HMINFC)
               HMAX   = OPT(3)
               IF (HMAX .EQ. 0.0) HMAX   = 1.0
               IF (ULEC) THEN
                  HC     = OPT(4)
                  IF (HC .EQ. 0.0) HC     = HMAX
               ELSE
                  HC     = 0.0
               ENDIF
            ELSE
               GSSCKM = .FALSE.
               ESCGSS = .FALSE.
               GEC    = .FALSE.
               ULEC   = .FALSE.
               RLXTOL = .FALSE.
               HINIT  = OPT(1)
               HMIN   = OPT(1)
               HMAX   = OPT(1)
               HC     = 0.0
            ENDIF
         ELSE
C   RE-ENTRY WITH OLD OPTIONS; RESTORE GUESS FOR NEXT STEPSIZE
            IF (OPT(1) .NE. 0.0) THEN
               HINIT  = OPT(1)
            ELSE
               HINIT  = WKAREA(IV1+N)
            ENDIF
         ENDIF
C        ENDIF COMMON BLOCK INITIALIZATION
*
         IF (ULEC) THEN
            IF (.NOT. RENTRY) THEN
               ZLEESM = .TRUE.
            ELSE IF (.NOT. ULECO .OR. TE .NE. TEO .OR. HC .NE. HCO) THEN
               ZLEESM = .TRUE.
            ELSE
               ZLEESM = .FALSE.
            ENDIF
         ELSE
            ZLEESM = .FALSE.
         ENDIF
      ENDIF
C     ENDIF DEFOPT
C
C END RE-ENTRY ACTIONS
C
C
C CHECK DIMENSION AND INTEGRATION BOUNDS OF VIE2, REQUESTED TOLERANCE
C   AND ORDER OF COLL. METH. TO COMPUTE REF.SOL.
      CALL CHKPTO (NEQN, TN, TE, REQTOL, TOLMIN, IERROR)
      IF (IERROR .LT. 0) THEN
         IERROR = -IERROR
         RETURN
      ENDIF
C
C COMPUTE MAX. # STEPS POSSIBLE (CF. "COLDOC" SUB "STORAGE OCCUPIED")
      ML     = M-L+1
      SL     = S-L+1
      MRL    = MR-LR+1
      SRL    = SR-LR+1
      MW     = MAX(ML,MRL)*NEQN
C !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
C !! WORKING STORAGE DIMENSIONS FOR LIN.SYS.SOLVER AND                !!
C !! INTERMEDIATE RESULT VECTORS                                      !!
      NWKSYS = MW
      IF (FUNCIT) THEN
         NIRVEC = 2*NEQN
      ELSE
         NIRVEC = NEQN*(1+NEQN)
      ENDIF
C !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      NUMER  = M+S+M*ML*SL+1+NEQN+MW+MW
      IDENOM = 1+NEQN*ML
      IF (METH .EQ. 1) NUMER = NUMER + M
      IF ((VS .OR. GEETE) .AND. (METHR .NE. 1))
     +   NUMER  = NUMER + MR+SR+MR*MRL*SRL
      IF (GSSCKM) NUMER  = NUMER + M+(M+2)*M+NEQN*(4+M)
      IF (ULEC) NUMER = NUMER + 2*NEQN*((TE-T0)/HC+1)
      IF (METHR .NE. 1 .AND. (GEC .OR. GEETE)) THEN
         NUMER  = NUMER  + NEQN
         IDENOM = IDENOM + NEQN*MRL
      ENDIF
      IF (VS .AND. .NOT. GEC) THEN
         IF (.NOT. GEETE) NUMER = NUMER + NEQN*(1+MRL)
         NUMER = NUMER + NEQN*(M+ML)
      ENDIF
      IF (METHR .EQ. 1) NUMER = NUMER + NEQN
      IF (.NOT. FUNCIT) THEN
         NUMER = NUMER + MW*MW
         IF (NEWTON) THEN
            NUMER = NUMER + MAX(NWKSYS,NIRVEC)
         ELSE
            NUMER = NUMER + NWKSYS+NIRVEC
         ENDIF
      ELSE IF (VS .AND. .NOT.GEC) THEN
         NUMER = NUMER + MAX(M+ML-MW,NIRVEC)
      ELSE
         NUMER = NUMER + NIRVEC
      ENDIF
      MAXNC  = (IW - NUMER) / IDENOM
C
C CHECK SIZE WORKING AREA
      CALL CHKWKA (IW, TN, TE, HINIT, NUMER, IDENOM, IERROR)
C   RETURN IF INPUT ERROR HAS BEEN DETECTED
      IF (IERROR .NE. 0) RETURN
*
C INITIALIZE REMAINING COMMON BLOCK VARIABLES
      NHFAIL = 0
      NCIT   = 0
      NKEV   = 0
      NCPS   = NCPJOB()
      IF (VS) THEN
         TOLLE  = REQTOL
         TOLCIA = MAX(TOLMIN,REQTOL/LSBITS)
         TOLCIR = MAX(TOLMIN,TOLCIA*TOLFRS)
      ELSE
         TOLLE  = 0.0
         TOLCIA = TOLMIN
         TOLCIR = TOLMIN
      ENDIF
C
C (RE) DISTRIBUTE "WKAREA"
      NHC    = 0
      IF (ULEC) NHC = (TE-T0)/HC
      CALL DISWKS (NEQN, NHC, RENTRY, NEWOPT, ZLEESM,
     +             WKAREA, IW, GECO, MAXNCO)
*
      TEO = TE
*
      RETURN
      END
      SUBROUTINE DISWKS
     +   (NEQN, NHC, RENTRY, NEWOPT, ZLEESM, WKAREA, IW, GECO, MAXNCO)
C
C ---------------------------------------------------------------------I
C PURPOSE: DISTRIBUTE WORKING STORAGE "WKAREA". IN CASE OF RE-ENTRY    I
C -------  SHIFT OLD VECTORS TO NEW LOCATIONS IN "WKAREA".             I
C                                                                      I
C COMMON VARIABLES:                                                    I
C ----------------                                                     I
      INTEGER METH, M, S, L, ORDER, ORDERQ, METHR, MR, SR, LR, ORDERR,
     +        ERRWGT, NHFAIL, NERR, NWIR, NSAV,
     +        MAXNC, MAXKEV, MAXCPS, N, NCIT, NKEV, NCPS
      COMMON /COLCMI/ METH, M, S, L, ORDER, ORDERQ,
     +                METHR, MR, SR, LR, ORDERR,
     +                ERRWGT, NHFAIL,
     +                NERR, NWIR, NSAV,
     +                MAXNC, MAXKEV, MAXCPS,
     +                N, NCIT, NKEV, NCPS
*
      LOGICAL VS, GSSCKM, ESCGSS, GEC, ULEC, RLXTOL, GEETE,
     +        FUNCIT, NEWTON
      COMMON /COLCML/ VS, GSSCKM, ESCGSS, GEC, ULEC, RLXTOL, GEETE,
     +                FUNCIT, NEWTON
*
      INTEGER IC1,IC2,IC3,IC4,IC5,IC6,IC7,IC8,ICE, IV1,IV2,IV3,IVE,
     +        IL1,IL2,IL3,IL4,IL5,ILAG,IL6,ILE
      COMMON /COLIXW/ IC1,IC2,IC3,IC4,IC5,IC6,IC7,IC8,ICE,
     +                IV1,IV2,IV3,IVE, IL1,IL2,IL3,IL4,IL5,ILAG,IL6,ILE
*
      SAVE /COLCMI/, /COLCML/, /COLIXW/
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER NEQN, NHC, IW, MAXNCO
      LOGICAL RENTRY, NEWOPT, ZLEESM, GECO
      REAL WKAREA(IW)
C NHC    # CHECK POINTS WHERE UNIFORM ERROR CONTROL WILL BE PERFORMED  I
C RENTRY TRUE IF CNTRL(1) > 0                                          I
C NEWOPT TRUE IF CNTRL(1) <= 2                                         I
C ZLEESM TRUE IF "LEESUM" PART OF "WKAREA" VECTOR WILL BE ZEROED       I
C GECO   TRUE IF GLOBAL ERROR CONTROL HAS BEEN SELECTED IN PREV. CALL  I
C MAXNCO MAX. # SUBINTERVALS ALLOWED IN PREVIOUS CALL OF "COLVI2"      I
C                                                                      I
C INVOKED BY: CHKINI                                                   I
C ----------                                                           I
C                                                                      I
C CHANGES IN COMMON VARIABLES:                                         I
C ---------------------------                                          I
C ALL VARIABLES IN /COLIXW/ ARE SET AS DESCRIBED IN SUBROUTINE "COLDOC"I
C SUB "DISTRIBUTION WKAREA".                                           I
C                                                                      I
C LOCAL VARIABLES:                                                     I
C ---------------                                                      I
      LOGICAL GAUSS, LEC, RSITCL
C                                                                      I
C ---------------------------------------------------------------------I
C
      INTEGER I, IDIF, IH, ILS, IU, IUR, K, ML, MLO, MNCDIF, MRL, MRLO,
     +        NH, NLS, NU, NUR, SL, SRL
*
      GAUSS  = METH .EQ. 1
      LEC    = VS .AND. .NOT. GEC
      RSITCL = METHR .EQ. 1
*
      ML     = M-L+1
      SL     = S-L+1
      MRL    = MR-LR+1
      SRL    = SR-LR+1
*
      IF (.NOT. RENTRY) THEN
C DISTRIBUTE WORKING STORAGE "WKAREA" (CF "COLDOC")
         IC1    =   1 + M
         IC2    = IC1 + S
         IC3    = IC2 + M*ML*SL
         IF (GAUSS) THEN
           IC4    = IC3 + M
         ELSE
           IC4    = IC3
         ENDIF
         IF ((VS .OR. GEETE) .AND. .NOT. RSITCL) THEN
           IC5    = IC4 + MR
           IC6    = IC5 + SR
           IC7    = IC6 + MR*MRL*SRL
         ELSE
           IC5    = IC4
           IC6    = IC5
           IC7    = IC6
         ENDIF
         IF (GSSCKM) THEN
           IC8    = IC7 + M
           ICE    = IC8 + (M+2)*M
         ELSE
           IC8    = IC7
           ICE    = IC8
         ENDIF
*
         IF (ULEC) THEN
           IV1    = ICE + (NHC+1)*NEQN
         ELSE
           IV1    = ICE
         ENDIF
         IV2    = IV1 + MAXNC+1
         IV3    = IV2 + (1+ML*MAXNC)*NEQN
         IF (.NOT.RSITCL .AND. (GEETE .OR. GEC)) THEN
           IVE    = IV3 + (1+MRL*MAXNC)*NEQN
         ELSE IF (LEC) THEN
           IVE    = IV3 + (1+MRL)*NEQN
         ELSE
           IVE    = IV3
         ENDIF
*
         IF (GSSCKM) THEN
           IL1    = IVE + NEQN
           IL2    = IL1 + NEQN
           IL3    = IL2 + NEQN
         ELSE
           IL1    = IVE
           IL2    = IL1
           IL3    = IL2
         ENDIF
         IF (RSITCL) THEN
           IL4    = IL3 + NEQN
         ELSE
           IL4    = IL3
         ENDIF
         IF (ULEC) THEN
           IL5    = IL4 + (NHC+1)*NEQN
         ELSE
           IL5    = IL4
         ENDIF
         IF (LEC) THEN
           ILAG   = IL5 + M*NEQN
           IL6    = IL5 + (M+ML)*NEQN
         ELSE
           ILAG   = IL5
           IL6    = IL5
         ENDIF
         IF (GSSCKM) THEN
           ILE    = IL6 + M*NEQN
         ELSE
           ILE    = IL6
         ENDIF
      ELSE IF (RENTRY .AND. .NOT.NEWOPT) THEN
         IF (MAXNCO .NE. MAXNC) THEN
C         SHIFT U, UR
            IU     = IV2
            NU     = NEQN*(1+ML*N)
            IUR    = IV3
            NUR    = 0
            MNCDIF = MAXNC - MAXNCO
            IV2    = IV2 + MNCDIF
            IDIF   = MNCDIF + ML*MNCDIF*NEQN
            IV3    = IV3 + IDIF
            IF (.NOT. RSITCL .AND. (GEETE .OR. GEC)) THEN
               IDIF   = IDIF + MRL*MNCDIF*NEQN
               NUR    = NEQN*(1+MRL*N)
            ELSE IF (LEC) THEN
               NUR    = NEQN*(1+MRL)
            ENDIF
            IVE    = IVE  + IDIF
            IL1    = IL1  + IDIF
            IL2    = IL2  + IDIF
            IL3    = IL3  + IDIF
            IL4    = IL4  + IDIF
            IL5    = IL5  + IDIF
            ILAG   = ILAG + IDIF
            IL6    = IL6  + IDIF
            ILE    = ILE  + IDIF
            IF (MNCDIF .GT. 0) THEN
C            SHIFT FORWARD
               DO 10 I = NUR-1, 0, -1
                  WKAREA(IV3+I) = WKAREA(IUR+I)
   10          CONTINUE
               DO 20 I = NU-1, 0, -1
                  WKAREA(IV2+I) = WKAREA(IU+I)
   20          CONTINUE
            ELSE
C            SHIFT BACKWARD
               DO 30 I = 0, NU-1
                  WKAREA(IV2+I) = WKAREA(IU+I)
   30          CONTINUE
               DO 40 I = 0, NUR-1
                  WKAREA(IV3+I) = WKAREA(IUR+I)
   40          CONTINUE
            ENDIF
         ENDIF
      ELSE
C      RE-ENTRY WITH NEW OPTION VECTORS
C         SHIFT ALL NEEDED VECTORS TO END OF WORK SPACE
         NLS    = 0
         IF (.NOT.ZLEESM) NLS = IV1-ICE
         NH    = N+1
         MLO   = ((IV3-IV2)/NEQN-1)/MAXNCO
         NU    = NEQN*(1+MLO*N)
         K     = IVE-IV3
         IF (K .EQ. 0) THEN
C         ITER.COLL. OR FIXED STEPSIZES WITHOUT GEETE IN PREVIOUS CALL
            NUR    = 0
         ELSE
            K      = K/NEQN-1
            MRLO   = K/MAXNCO
            IF (MRLO*MAXNCO .EQ. K) THEN
C            GEC OR GEETE IN PREVIOUS CALL
               NUR    = NEQN*(1+MRLO*N)
            ELSE
C            LEC WITHOUT GEETE IN PREVIOUS CALL
               MRLO   = K
            ENDIF
         ENDIF
C
C          SHIFT REF.SOL. TO END OF WKAREA
         IUR    = IW
         IF (LEC) THEN
            IUR    = IW+1-NEQN
            IF (K .EQ. 0) THEN
C            NO REF. SOL. AVAILABLE IN TN; USE APPR. SOL.
               CALL COPYV (WKAREA(IV2+NU-NEQN), NEQN, WKAREA(IUR))
            ELSE
               IF (GECO) THEN
C               GEC IN PREV. CALL
                  CALL COPYV (WKAREA(IV3+NUR-NEQN), NEQN, WKAREA(IUR))
               ELSE
C               LEC IN PREV. CALL
                  CALL COPYV (WKAREA(IV3+MRLO*NEQN), NEQN, WKAREA(IUR))
               ENDIF
            ENDIF
            NUR    = NEQN
         ELSE IF (NUR .NE. 0) THEN
            DO 100 I = NUR-1, 0, -1
               WKAREA(IW+1-NUR+I) = WKAREA(IV3+I)
  100       CONTINUE
            IUR    = IW+1-NUR
         ENDIF
C
C         SHIFT U, H AND LEESUM TO END OF WKAREA
         DO 110 I = NU-1, 0, -1
            WKAREA(IUR-NU+I) = WKAREA(IV2+I)
  110    CONTINUE
         IU     = IUR - NU
         DO 120 I = NH-1, 0, -1
            WKAREA(IU-NH+I) = WKAREA(IV1+I)
  120    CONTINUE
         IH     = IU - NH
         DO 130 I = NLS-1, 0, -1
            WKAREA(IH-NLS+I) = WKAREA(ICE+I)
  130    CONTINUE
         ILS     = IH - NLS
*
C          REDISTRIBUTE WKAREA  (IC1,.., IC4 ARE NOT CHANGED)
         IF ((VS .OR. GEETE) .AND. .NOT. RSITCL) THEN
           IC5    = IC4 + MR
           IC6    = IC5 + SR
           IC7    = IC6 + MR*MRL*SRL
         ELSE
           IC5    = IC4
           IC6    = IC5
           IC7    = IC6
         ENDIF
         IF (GSSCKM) THEN
           IC8    = IC7 + M
           ICE    = IC8 + (M+2)*M
         ELSE
           IC8    = IC7
           ICE    = IC8
         ENDIF
*
         IF (ULEC) THEN
           IV1    = ICE + (NHC+1)*NEQN
         ELSE
           IV1    = ICE
         ENDIF
         IV2    = IV1 + MAXNC+1
         IV3    = IV2 + (1+ML*MAXNC)*NEQN
         IF (.NOT.RSITCL .AND. (GEETE .OR. GEC)) THEN
           IVE    = IV3 + (1+MRL*MAXNC)*NEQN
         ELSE IF (LEC) THEN
           IVE    = IV3 + (1+MRL)*NEQN
         ELSE
           IVE    = IV3
         ENDIF
*
         IF (GSSCKM) THEN
           IL1    = IVE + NEQN
           IL2    = IL1 + NEQN
           IL3    = IL2 + NEQN
         ELSE
           IL1    = IVE
           IL2    = IL1
           IL3    = IL2
         ENDIF
         IF (RSITCL) THEN
           IL4    = IL3 + NEQN
         ELSE
           IL4    = IL3
         ENDIF
         IF (ULEC) THEN
           IL5    = IL4 + (NHC+1)*NEQN
         ELSE
           IL5    = IL4
         ENDIF
         IF (LEC) THEN
           ILAG   = IL5 + M*NEQN
           IL6    = IL5 + (M+ML)*NEQN
         ELSE
           ILAG   = IL5
           IL6    = IL5
         ENDIF
         IF (GSSCKM) THEN
           ILE    = IL6 + M*NEQN
         ELSE
           ILE    = IL6
         ENDIF
*
C          COPY LEESUM, H, U, UR _IF NEEDED_ BACK TO NEW LOCATIONS
         DO 200 I = 0, NLS-1
            WKAREA(ICE+I) = WKAREA(ILS+I)
  200    CONTINUE
         DO 210 I = 0, NH-1
            WKAREA(IV1+I) = WKAREA(IH+I)
  210    CONTINUE
         DO 220 I = 0, NU-1
            WKAREA(IV2+I) = WKAREA(IU+I)
  220    CONTINUE
         DO 230 I = 0, NUR-1
            WKAREA(IV3+I) = WKAREA(IUR+I)
  230    CONTINUE
      ENDIF
*
      RETURN
      END
      SUBROUTINE INIVEC
     +   (IU,IURG,IURL,IURN,ILEESM, NEQN, G, TN, TE, U,UR,URN,LEESUM)
C
C ---------------------------------------------------------------------I
C PURPOSE: INITIALIZATION OF SOLUTION AND ERROR VECTORS.               I
C -------                                                              I
C                                                                      I
C COMMON VARIABLES:                                                    I
C ----------------                                                     I
      INTEGER METH, M, S, L, ORDER, ORDERQ, METHR, MR, SR, LR, ORDERR,
     +        ERRWGT, NHFAIL, NERR, NWIR, NSAV,
     +        MAXNC, MAXKEV, MAXCPS, N, NCIT, NKEV, NCPS
      COMMON /COLCMI/ METH, M, S, L, ORDER, ORDERQ,
     +                METHR, MR, SR, LR, ORDERR,
     +                ERRWGT, NHFAIL,
     +                NERR, NWIR, NSAV,
     +                MAXNC, MAXKEV, MAXCPS,
     +                N, NCIT, NKEV, NCPS
*
      REAL TOLLE, TOLCIA, TOLCIR, HMIN, HMAX, HC
      COMMON /COLCMR/ TOLLE, TOLCIA, TOLCIR, HMIN, HMAX, HC
*
      SAVE /COLCMI/, /COLCMR/
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER NEQN
      LOGICAL IU, IURG, IURL, IURN, ILEESM
      REAL TN, TE
      REAL U(-NEQN:*), UR(-NEQN:*), URN(*), LEESUM(*)
      EXTERNAL G
C                                                                      I
C IU     TRUE, IF THIS IS THE FIRST CALL OF COLVI2                     I
C IURG   TRUE, IF (IU) AND GLOBAL ERROR CONTROL HAS BEEN SELECTED      I
C IURL   TRUE, IF LOCAL ERROR CONTROL HAS BEEN SELECTED                I
C IURN   TRUE, IF IT HAS TO BE CHECKED WHETHER THE SOLUTION            I
C              IS POLYNOMIAL                                           I
C ILEESM TRUE, IF UNIFORM LOCAL ERROR CONTROL HAS BEEN SELECTED        I
C              AND IF NO PREVIOUS SUM OF LOCAL ERRORS IS AVAILABLE     I
C U      EXIT: IF IU,     G(T0)                                        I
C UR     EXIT: IF IURG,   G(T0)                                        I
C              IF IURL,   U(TN)                                        I
C URN    EXIT: IF IURN,   U(TN)                                        I
C LEESUM EXIT: IF ILEESM, ZEROED                                       I
C                                                                      I
C INVOKED BY: COLVI2                                                   I
C ----------                                                           I
C                                                                      I
C CHANGES IN COMMON VARIABLES: NONE                                    I
C ---------------------------                                          I
C                                                                      I
C ---------------------------------------------------------------------I
C
      INTEGER INDEXN
*
*
      INDEXN = NEQN*((M-L+1)*N-1)
*
      IF (IU)     CALL G(TN,U)
      IF (IURG)   CALL COPYV (U, NEQN, UR)
      IF (IURL)   CALL COPYV (U(INDEXN), NEQN, UR)
      IF (IURN)   CALL COPYV (U(INDEXN), NEQN, URN)
      IF (ILEESM) CALL ZEROV (LEESUM, INT((TE-TN)/HC+1)*NEQN)
*
      RETURN
      END
      SUBROUTINE ESCRGS (NEQN, WKAREA,IW, T0,TE, TN, IERROR)
C
C ---------------------------------------------------------------------I
C PURPOSE: CREATE ENVIRONMENT FOR NEW REF.SOL. METHOD BECAUSE SOLUTION I
C -------  APPEARS TO BE POLYNOMIAL OF DEGREE < M.                     I
C DETERMINE NEW REF.SOL. METHOD, CHANGE COMMON BLOCK VALUES, RESHUFFLE I
C WKAREA FOR NEW MAXNC AND NEW VARIABLES.                              I
C INITIALIZE UR(-NEQN:-1), LEESUM, COLL. PARS. REF. SOL.               I
C                                                                      I
C COMMON VARIABLES:                                                    I
C ----------------                                                     I
      INTEGER METH, M, S, L, ORDER, ORDERQ, METHR, MR, SR, LR, ORDERR,
     +        ERRWGT, NHFAIL, NERR, NWIR, NSAV,
     +        MAXNC, MAXKEV, MAXCPS, N, NCIT, NKEV, NCPS
      COMMON /COLCMI/ METH, M, S, L, ORDER, ORDERQ,
     +                METHR, MR, SR, LR, ORDERR,
     +                ERRWGT, NHFAIL,
     +                NERR, NWIR, NSAV,
     +                MAXNC, MAXKEV, MAXCPS,
     +                N, NCIT, NKEV, NCPS
*
      LOGICAL VS, GSSCKM, ESCGSS, GEC, ULEC, RLXTOL, GEETE,
     +        FUNCIT, NEWTON
      COMMON /COLCML/ VS, GSSCKM, ESCGSS, GEC, ULEC, RLXTOL, GEETE,
     +                FUNCIT, NEWTON
*
      REAL TOLLE, TOLCIA, TOLCIR, HMIN, HMAX, HC
      COMMON /COLCMR/ TOLLE, TOLCIA, TOLCIR, HMIN, HMAX, HC
*
      INTEGER IC1,IC2,IC3,IC4,IC5,IC6,IC7,IC8,ICE, IV1,IV2,IV3,IVE,
     +        IL1,IL2,IL3,IL4,IL5,ILAG,IL6,ILE
      COMMON /COLIXW/ IC1,IC2,IC3,IC4,IC5,IC6,IC7,IC8,ICE,
     +                IV1,IV2,IV3,IVE, IL1,IL2,IL3,IL4,IL5,ILAG,IL6,ILE
*
      REAL SRELPR, SOVFLO, SUNFLO
      COMMON /COLMCR/ SRELPR, SOVFLO, SUNFLO
*
      SAVE /COLCMI/, /COLCML/, /COLCMR/, /COLIXW/, /COLMCR/
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER NEQN, IW, IERROR
      REAL T0, TE, TN
      REAL WKAREA(IW)
C TN     ENTRY: POINT TO WHICH INTEGRATION HAS BEEN ADVANCED           I
C        EXIT:  POINT AT WHICH INTEGRATION HAS TO BE RESTARTED         I
C IERROR EXIT:  0: OK                                                  I
C              12: SIZE WORKING AREA TOO SMALL                         I
C              OTHER: ERROR COMPLETION CODE OF COLCWL                  I
C                                                                      I
C INVOKED BY: COLVI2                                                   I
C ----------                                                           I
C                                                                      I
C CHANGES IN COMMON VARIABLES:                                         I
C ---------------------------                                          I
C ORDER  SET TO ORDERQ SINCE INTERPOLATION DOES NOT HAVE AN ORDER      I
C        REDUCING EFFECT                                               I
C METHR  +                                                             I
C MR     I SET TO VALUES FOR NEW COLLOCATION METHOD                    I
C SR     I TO COMPUTE REFERENCE SOLUTION                               I
C LR     I                                                             I
C ORDERR +                                                             I
C NHFAIL ADDED: # STEPS DISCARDED BECAUSE OF POSSIBLY WRONG ERR. EST.  I
C MAXNC  NEW MAXIMUM # SUBINTERVALS ALLOWED BY DIMENSION OF "WKAREA"   I
C N      NUMBER OF INTERVAL AT WHICH INTEGRATION HAS TO BE RESTARTED   I
C        (= OLD N - NPGESC)                                            I
C GSSCKM SET .FALSE.; NO CHECK ON POLYNOMIAL SOLUTION ANYMORE          I
C ESCGSS SET .FALSE.                                                   I
C GEC    SET .FALSE.; FROM NOW ON LOCAL + UNIFORM ERROR CONTROL        I
C ULEC   SET .TRUE.                                                    I
C GEETE  SET .FALSE.; GLOBAL ERROR IN ENDPOINT WILL BE ESTIMATED       I
C        BY SUM OF LOCAL ERRORS                                        I
C TOLCIR SET TO MIN(TOLMIN,TOLCIA*TOLFRS)                              I
C HC     SET TO HMAX                                                   I
C IC5, ..., ILE ARE SET FOR NEW REF.SOL. AND ERROR CONTROL METHOD      I
C        CF. "COLDOC" SUB "DISTRIBUTION WKAREA"                        I
C                                                                      I
C !!!!!!!!! IMPORTANT !!!!!!!!! IMPORTANT !!!!!!!!! IMPORTANT !!!!!!!!!!
C                                                                     !!
C MACHINE DEPENDENCIES:                                               !!
C --------------------                                                !!
C FOR THE DISTRIBUTION OF "WKAREA" IT IS ASSUMED THAT A LIN. SYSTEM OF!!
C X EQUATIONS CAN BE SOLVED USING X EXTRA MEMORY LOCATIONS AS WORKING !!
C STORAGE (AS IS THE CASE WITH IMSL'S "LUDATF"+"LUELMF", AND THE      !!
C INCORPORATED GAUSS ELIMINATION ROUTINES).                           !!
C IF THIS IS NOT THE CASE CHANGE THE INDICATED STATEMENTS BELOW.      !!
C (ONLY IN CASE NEWTON'S METHOD IS USED TO SOLVE THE COLL. SYSTEM)    !!
C                                                                     !!
C !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
C                                                                      I
C CONSTANTS:                                                           I
C ---------                                                            I
      INTEGER LSBITS, NPGESC
      REAL TOLFRS
      PARAMETER (LSBITS = 128)
      PARAMETER (NPGESC = 2)
      PARAMETER (TOLFRS = 0.1)
C                                                                      I
C LOCAL VARIABLES:                                                     I
C ---------------                                                      I
      CHARACTER*10 VAROUT
      INTEGER IH,IU, MW, NHC, NIRVEC, NLR, NMAXNC, NMETHR, NMR, NN,
     +        NORDRR, NSR, NWKSYS
      REAL TOLMIN
C IH     POINTER TO OLD LOCATION OF "H" VECTOR IN "WKAREA"             I
C IU     POINTER TO OLD LOCATION OF "U" VECTOR                         I
C MW     NEW MAX. DIMENSION OF COLLOCATION SYSTEM TO BE SOLVED.        I
C NHC    # CHECKPOINTS AT WHICH UNIF. ERROR CONTROL WILL BE PERFORMED  I
C NIRVEC # MEMORY WORDS NEEDED FOR INTERMEDIATE VECTOR RESULTS         I
C NLR, ..., NSR NEW VALUES FOR OLD /COLCMI/ VARIABLES                  I
C NWKSYS WORKING STORAGE NEEDED BY "DECLUF" AND "SOLLUF" TO SOLVE A    I
C        SYSTEM OF "MW" EQUATIONS                                      I
C TOLMIN MINIMUM TOLERANCE POSSIBLE TAKING INTO ACCOUNT THE MACHINE    I
C        PRECISION AND THE ESTIMATED COMPUTATIONAL LOSS.               I
C                                                                      I
C ---------------------------------------------------------------------I
C
      INTEGER I, IDENOM, NMRL, NUMER, NSRL
*
      ORDER  = ORDERQ
      IF (METHR .EQ. 1) THEN
         NMETHR = 2
      ELSE
         NMETHR = METHR
      ENDIF
      GOTO (10, 20, 30) NMETHR-1
*
C GAUSS + CMR=1
   10 NMR    = M+2
      NSR    = NMR-1
      NLR    = 1
      NORDRR = ORDERQ+2
      GOTO 40
C LOBATTO
   20 NMR    = M+2
      NSR    = NMR
      NLR    = 2
      NORDRR = ORDERQ+2
      GOTO 40
C RADAU
   30 NMR    = M+1
      NSR    = NMR
      NLR    = 1
      NORDRR = ORDERQ+1
*
   40 CONTINUE
      IF (N-NPGESC .LE. 0) THEN
         NN = 0
         TN = T0
      ELSE
         NN = N-NPGESC
         DO 50 I = 1, NPGESC
            TN  = TN - WKAREA(IV1+N-I)
   50    CONTINUE
      ENDIF
      NHFAIL = NHFAIL + N-NN+1
C
C SAVE GUESS FOR REF. SOL. IN NEXT STEP
      IF (METHR .EQ. 1 .OR. .NOT.GEC) THEN
C       USE U(M,NN-1)
         CALL COPYV (WKAREA(IV2+NEQN*M*NN), NEQN, WKAREA(IW-NEQN))
      ELSE
C       USE UR(MR,NN-1)
         CALL COPYV (WKAREA(IV3+NEQN*(MR-LR+1)*NN),NEQN,WKAREA(IW-NEQN))
      ENDIF
C
C CHANGE COMMON BLOCK VALUES
      GSSCKM = .FALSE.
      ESCGSS = .FALSE.
      GEC    = .FALSE.
      ULEC   = .TRUE.
      GEETE  = .FALSE.
*
      HC     = HMAX
*
C
C STORE WKAREA POINTERS; COMPUTE NEW MAXIMUM NUMBER OF STEPS
C CF. "COLDOC" SUB "DISTRIBUTION WKAREA" AND "STORAGE OCCUPIED"
      NMRL   = NMR - NLR + 1
      NSRL   = NSR - NLR + 1
      MW     = NEQN * MAX(M,NMRL)
C !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
C !! WORKING STORAGE DIMENSIONS FOR LIN.SYS.SOLVER AND                !!
C !! INTERMEDIATE RESULT VECTORS                                      !!
      NWKSYS = MW
      IF (FUNCIT) THEN
         NIRVEC = 2*NEQN
      ELSE
         NIRVEC = NEQN*(1+NEQN)
      ENDIF
C !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      NHC    = (TE-TN)/HC
*
      IH     = IV1
      IU     = IV2
      IC5    = IC4 + NMR
      IC6    = IC5 + NSR
      IC7    = IC6 + NMR*NMRL*NSRL
      IC8    = IC7
      ICE    = IC8
      IV1    = ICE + NEQN*(NHC+1)
*
      NUMER  = IV1 + 1 + NEQN + NEQN*(NMRL+1) + NEQN*(NHC+1) +
     +         NEQN*(M+M) + MW + MW
      IF (FUNCIT) THEN
         NUMER = NUMER + MAX(NIRVEC,2*M-MW)
      ELSE
         NUMER = NUMER + MW*MW
         IF (NEWTON) THEN
            NUMER = NUMER + MAX(NWKSYS,NIRVEC)
         ELSE
            NUMER = NUMER + NWKSYS+NIRVEC
         ENDIF
      ENDIF
      IDENOM = 1+NEQN*M
      NMAXNC = (IW-NUMER)/IDENOM
      IF (NMAXNC .LE. NN) GOTO 900
*
      IV2    = IV1 + NMAXNC+1
      IV3    = IV2 + NEQN*(1+M*NMAXNC)
      IVE    = IV3 + NEQN*(1+NMRL)
*
      IL1    = IVE
      IL2    = IL1
      IL3    = IL2
      IL4    = IL3
      IL5    = IL4 + NEQN*(NHC+1)
      ILAG   = IL5 + NEQN*M
      IL6    = IL5 + NEQN*(M+M)
      ILE    = IL6
*
C SHIFT H(0:NN) AND U(K,J,I) I=-1,J=M, I=0:NN-1,J=1:M, K=1:NEQN   TO NEW
C    WKAREA LOCATIONS
      IF (IH .GT. IV1) THEN
C      SHIFT H-VALUES BACKWARDS IN WKAREA
         DO 100 I = 0, NN
            WKAREA(IV1+I) = WKAREA(IH+I)
  100    CONTINUE
         IF (IU .GT. IV2) THEN
C         SHIFT U-VALUES BACKWARDS
            DO 110 I = 0, NEQN*(1+M*NN)-1
               WKAREA(IV2+I) = WKAREA(IU+I)
  110       CONTINUE
         ELSE
C         SHIFT U-VALUES FORWARDS
            DO 120 I = NEQN*(1+M*NN)-1, 0, -1
               WKAREA(IV2+I) = WKAREA(IU+I)
  120       CONTINUE
         ENDIF
      ELSE
         IF (IU .GT. IV2) THEN
C         SHIFT U-VALUES BACKWARDS
            DO 130 I = 0, NEQN*(1+M*NN)-1
               WKAREA(IV2+I) = WKAREA(IU+I)
  130       CONTINUE
         ELSE
C         SHIFT U-VALUES FORWARDS
            DO 140 I = NEQN*(1+M*NN)-1, 0, -1
               WKAREA(IV2+I) = WKAREA(IU+I)
  140       CONTINUE
         ENDIF
C      SHIFT H-VALUES FORWARD
         DO 150 I = NN, 0, -1
            WKAREA(IV1+I) = WKAREA(IH+I)
  150    CONTINUE
      ENDIF
C
C FILL URN(-NEQN:-1) WITH GUESS FOR NEXT STEP
      CALL COPYV (WKAREA(IW-NEQN), NEQN, WKAREA(IV3))
C
C CHANGE COMMON BLOCK VALUES
C INITIALIZE VECTOR FOR SUM OF LOCAL ERRORS ON ZERO
      CALL ZEROV (WKAREA(ICE), NEQN*(NHC+1))
      METHR  = NMETHR
      MR     = NMR
      SR     = NSR
      LR     = NLR
      ORDERR = NORDRR
      MAXNC  = NMAXNC
      N      = NN
*
C   COMPUTE THE MOST TIGHT REQUIRED_TOLERANCE
      TOLMIN = LSBITS*SRELPR
      TOLCIR = MAX(TOLMIN,TOLCIA*TOLFRS)
*
C
C COMPUTE COLLOCATION PARAMETERS FOR REFERENCE SOLUTION
      WRITE(VAROUT,'(1H(,I2,1H,,I2,1H,,I2,1H))') METHR, MR, ORDERR
      CALL COLCWL (METHR, MR, WKAREA(IC4),WKAREA(IC5),
     +             WKAREA(IC6), IERROR)
      IF (IERROR .NE. 0) GOTO 910
*
      CALL ERRMSG ('ESCAPE TO REFSOL (METHOD,M,ORDER): '//VAROUT//
     +             '; LOCAL + UNIFORM ERROR CONTROL')
      RETURN
C
C ERROR RETURNS
  900 CONTINUE
      CALL ERRMSG ('WORKING STORAGE SIZE TOO SMALL TO CONTINUE AFTER'
     +             //' ESCAPE FROM GAUSS')
      IERROR = 12
      RETURN
*
  910 CONTINUE
      CALL ERRMSG ('   TRYING TO ESCAPE TO REFSOL (METHOD,M,ORDER): '//
     +             VAROUT)
      RETURN
      END
      SUBROUTINE INILAG
     +   (TN, NEQN,G,KC, C,W,LC,LOBAT, H, U, WKAREA, LAGSAV)
C
C ---------------------------------------------------------------------I
C PURPOSE: INITIALIZE LAGSAV(0:NEQN*M-1) WITH APPROXIMATION OF         I
C -------  (T0,TN) INT K(TN-H(N-1)+CJ.H(N-1),S,Y).DS     FOR J=1:M.    I
C TO BE USED FOR COMPUTATION OF REF.SOL.LAG TERMS BY INTERPOLATION IN  I
C CASE OF LOCAL ERROR CONTROL.                                         I
C                                                                      I
C COMMON VARIABLES:                                                    I
C ----------------                                                     I
      INTEGER METH, M, S, L, ORDER, ORDERQ, METHR, MR, SR, LR, ORDERR,
     +        ERRWGT, NHFAIL, NERR, NWIR, NSAV,
     +        MAXNC, MAXKEV, MAXCPS, N, NCIT, NKEV, NCPS
      COMMON /COLCMI/ METH, M, S, L, ORDER, ORDERQ,
     +                METHR, MR, SR, LR, ORDERR,
     +                ERRWGT, NHFAIL,
     +                NERR, NWIR, NSAV,
     +                MAXNC, MAXKEV, MAXCPS,
     +                N, NCIT, NKEV, NCPS
*
      SAVE /COLCMI/
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER NEQN
      LOGICAL LOBAT
      REAL TN
      REAL C(M), W(S), LC(M,L:M,L:S),
     +     H(0:MAXNC), U(-NEQN:NEQN*(M-L+1)*MAXNC-1), WKAREA(*),
     +     LAGSAV(0:NEQN*(2*M-L+1)-1)
      EXTERNAL G, KC
C WKAREA WORKING STORAGE FOR INTERMED. RESULT VECTORS (>=2*NEQN)       I
C LAGSAV EXIT: FCN(TNM1+CJ.HNM1)->LAGSAV(NEQN*(J-1)+(0:NEQN-1)) J=1..M I
C                                                                      I
C INVOKED BY: SOLVI2                                                   I
C ----------                                                           I
C                                                                      I
C CHANGES IN COMMON VARIABLES:                                         I
C ---------------------------                                          I
C NKEV   ADDED: # KERNEL EVALUATIONS NEEDED TO APPROX. LAG TERMS       I
C                                                                      I
C LOCAL VARIABLES:                                                     I
C ---------------                                                      I
      INTEGER INDEXN
      REAL HNM1, TNM1, TNM1J
C INDEXN POINTER TO SOL. IN 1-ST (OR 2-ND IF LOBATTO) COLLOC. POINT    I
C        OF (N-1)-ST INTERVAL                                          I
C TNM1J  T(N-1) + C(J).H(N-1)                                          I
C                                                                      I
C ---------------------------------------------------------------------I
C
      INTEGER I, INDEXJ, I1, J, K
*
      I1 = NEQN+1
*
      IF (N .EQ. 0) THEN
C      NO PREVIOUS INTERVAL: LAG TERM = 0.0
         CALL ZEROV (LAGSAV(0), NEQN*M)
      ELSE IF (N .EQ. 1) THEN
C      ONLY 1 PREVIOUS INTERVAL
         HNM1 = H(N-1)
         TNM1 = TN-HNM1
         DO 10 J = 1, M
C         STORE H0.SUM WK.KC(T0J,T0K,U_0J) IN LAGSAV
            INDEXJ = NEQN*(J-1)
            TNM1J = TNM1+C(J)*HNM1
            CALL ZEROV (LAGSAV(INDEXJ), NEQN)
            DO 20 K = 1, S
               CALL KC(TNM1J,TNM1+C(K)*HNM1,U(NEQN*(K-L)),WKAREA)
               CALL ADDABV (LAGSAV(INDEXJ), NEQN, HNM1*W(K), WKAREA)
   20       CONTINUE
   10    CONTINUE
         NKEV = NKEV + M*S
      ELSE
C      STORE APPROX. OF (T0,TN) INT K(TNM1+.,.,.) IN LAGSAV
         INDEXN = NEQN*(M-L+1)*(N-1)
         HNM1 = H(N-1)
         TNM1 = TN-HNM1
         DO 30 J = 1, M
            INDEXJ = NEQN*(J-1)
            TNM1J = TNM1+C(J)*HNM1
C         FCNM1(TNM1J) = U_NM1J - G(TNM1J) -
C            HNM1.SUM CJWK.KC(TNM1J,TNM1+CJCK.HNM1,UNM1(TNM1+CJCK.HNM1))
C         FCN(TNM1J) = FCNM1(TNM1J) +
C            HNM1.SUM WK.KC(TNM1J,TNM1K,U_NM1K)
            CALL G(TNM1J,WKAREA)
            CALL ADDV (LAGSAV(INDEXJ), NEQN, 1.0,U(INDEXN+NEQN*(J-L)),
     +                                      -1.0, WKAREA)
C
C      SUBTRACT (TNM1,TNM1J) INT K(TNM1J,); ADD (TNM1,TN) INT K(TNM1J,)
            IF (LOBAT) THEN
               CALL KC(TNM1J,TNM1,U(INDEXN-NEQN),WKAREA)
               CALL ADDABV (LAGSAV(INDEXJ), NEQN,
     +                      HNM1*W(1)*(1.0-C(J)), WKAREA)
            ENDIF
            DO 40 K = L, S
C          COMPUTE UNM1(TNM1+CJ.CK.HNM1) WITH LAGRANGIAN INTERPOLATION
               CALL ZEROV (WKAREA(I1), NEQN)
               DO 50 I = 1, M
                  CALL ADDABV (WKAREA(I1), NEQN,
     +                         LC(I,J,K), U(INDEXN+NEQN*(I-L)))
   50          CONTINUE
               CALL KC(TNM1J,TNM1+C(J)*C(K)*HNM1,WKAREA(I1),
     +                 WKAREA)
               CALL ADDABV (LAGSAV(INDEXJ), NEQN,
     +                      -HNM1*C(J)*W(K), WKAREA)
               CALL KC(TNM1J,TNM1+C(K)*HNM1,U(INDEXN+NEQN*(K-L)),WKAREA)
               CALL ADDABV (LAGSAV(INDEXJ),NEQN, HNM1*W(K),WKAREA)
   40       CONTINUE
   30    CONTINUE
         NKEV = NKEV + M*S*2
         IF (LOBAT) NKEV = NKEV - M
      ENDIF
      RETURN
      END
      SUBROUTINE INILGN (TN, NEQN, G, U, LC1, WKAREA, LAGN)
C
C ---------------------------------------------------------------------I
C PURPOSE: INITIALIZE "LAGN" WITH AN APPROXIMATION OF                  I
C -------     (T0,TN) INT K(TN,S,Y).DS.                                I
C TO BE USED FOR COMPUTATION OF LAG TERMS BY INTERPOLATION IN CASE     I
C COLVI2 USES GAUSS-LEGENDRE COLLOCATION AND CHECKS IF THE VIE2 HAS A  I
C POLYNOMIAL SOLUTION OF DEGREE < M.                                   I
C                                                                      I
C COMMON VARIABLES:                                                    I
C ----------------                                                     I
      INTEGER METH, M, S, L, ORDER, ORDERQ, METHR, MR, SR, LR, ORDERR,
     +        ERRWGT, NHFAIL, NERR, NWIR, NSAV,
     +        MAXNC, MAXKEV, MAXCPS, N, NCIT, NKEV, NCPS
      COMMON /COLCMI/ METH, M, S, L, ORDER, ORDERQ,
     +                METHR, MR, SR, LR, ORDERR,
     +                ERRWGT, NHFAIL,
     +                NERR, NWIR, NSAV,
     +                MAXNC, MAXKEV, MAXCPS,
     +                N, NCIT, NKEV, NCPS
*
      SAVE /COLCMI/
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER NEQN
      REAL TN
      REAL U(-NEQN:NEQN*M*MAXNC-1), LC1(M), WKAREA(*), LAGN(NEQN)
      EXTERNAL G
C TN     STARTING POINT OF INTEGRATION                                 I
C WKAREA WORKING STORAGE FOR INTERMED.RESULT VECTORS (>=NEQN)          I
C LAGN   EXIT: CONTAINS FCN(TN)                                        I
C                                                                      I
C INVOKED BY: SOLVI2                                                   I
C ----------                                                           I
C                                                                      I
C CHANGES IN COMMON VARIABLES: NONE                                    I
C ---------------------------                                          I
C                                                                      I
C ---------------------------------------------------------------------I
C
      INTEGER I, INDEXN
*
C COMPUTE FCN(TN) = U(TN) - G(TN)
      CALL ZEROV (LAGN, NEQN)
      IF (N .GT. 0) THEN
         INDEXN = NEQN*M*(N-1)
C   COMPUTE U(TN) WITH LAGRANGIAN INTERPOLATION; STORE IN LAGN
         DO 10 I = 1, M
            CALL ADDABV (LAGN, NEQN, LC1(I), U(INDEXN+NEQN*(I-1)))
   10    CONTINUE
C   SUBTRACT G(TN)
         CALL G(TN,WKAREA)
         CALL ADDABV (LAGN, NEQN, -1.0, WKAREA)
      ENDIF
*
      RETURN
      END
      SUBROUTINE COLCWL (COLPAR, M, C, W, LC, IERROR)
C
C ---------------------------------------------------------------------I
C PURPOSE: INITIALIZE THE SET OF COLLOCATION PARAMETERS,THE ASSOCIATED I
C -------  WEIGHT FACTORS FOR THE QUADRATURE AND THE LAGRANGIAN        I
C INTERPOLATION COEFFICIENTS IN (CI.CJ) FOR THE M-POINTS ? METHOD;     I
C WITH ? = GAUSS,        IF COLPAR = 1                                 I
C          GAUSS+CM=1.0, IF COLPAR = 2                                 I
C          LOBATTO,      IF COLPAR = 3                                 I
C          RADAU,        IF COLPAR = 4                                 I
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER COLPAR, M, IERROR
      REAL C(M), W(*), LC(*)
C                                                                      I
C INVOKED BY: COLVI2, ESCRGS                                           I
C ----------                                                           I
C                                                                      I
C ---------------------------------------------------------------------I
C
      INTEGER S, L
*
      S = M
      L = 1
C
C INITIALIZE COLLOCATION PARAMETERS; USE "LC" FOR WORK SPACE
      GOTO (10, 20, 30, 40) COLPAR
   10    CALL GAUSS (M, C, LC, IERROR)
         GOTO 50
   20    CALL GAUSS (M-1, C, LC, IERROR)
         S = M-1
         C(M) = 1.0
         GOTO 50
   30    CALL LOBATO (M, C, LC, IERROR)
         L = 2
         GOTO 50
   40    CALL RADAU (M, C, LC, IERROR)
C
   50 IF (IERROR .NE. 0) RETURN
*
C COMPUTE WEIGHT FACTORS FOR QUADRATURE AND LAGRANGIAN INTERPOLATION
C COEFFICIENTS BASED ON THE COLLOCATION PARAMETERS
      CALL COMPWL (M, S, L, C, W, LC)
      RETURN
      END
      SUBROUTINE GAUSS (M, C, WKAREA, IERROR)
C
C ---------------------------------------------------------------------I
C PURPOSE: INITIALIZE THE SET OF GAUSSIAN COLLOCATION PARAMETERS.      I
C -------                                                              I
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER M, IERROR
      REAL C(M), WKAREA(*)
C                                                                      I
C INVOKED BY: COLCWL                                                   I
C ----------                                                           I
C                                                                      I
C ---------------------------------------------------------------------I
C
      REAL X, S30, S70
*
      IF (M .EQ. 2) THEN
         X = SQRT(3.0)/3.0
         C(1) = 0.5 * (1.0-X)
         C(2) = 0.5 * (1.0+X)
      ELSE IF (M .EQ. 3) THEN
         X = SQRT(15.0)/5.0
         C(1) = 0.5 * (1.0-X)
         C(3) = 0.5 * (1.0+X)
         C(2) = 0.5
      ELSE IF (M .EQ. 4) THEN
         S30 = SQRT(30.0)
         X = SQRT((15.0+2.0*S30)/35.0)
         C(1) = 0.5 * (1.0-X)
         C(4) = 0.5 * (1.0+X)
         X = SQRT((15.0-2.0*S30)/35.0)
         C(2) = 0.5 * (1.0-X)
         C(3) = 0.5 * (1.0+X)
      ELSE IF (M .EQ. 5) THEN
         S70 = SQRT(70.0)
         X = SQRT((35.0+2.0*S70)/63.0)
         C(1) = 0.5 * (1.0-X)
         C(5) = 0.5 * (1.0+X)
         X = SQRT((35.0-2.0*S70)/63.0)
         C(2) = 0.5 * (1.0-X)
         C(4) = 0.5 * (1.0+X)
         C(3) = 0.5
      ELSE
         CALL GAUSSC (M, C, WKAREA, WKAREA(M+2), IERROR)
      ENDIF
*
      RETURN
      END
      SUBROUTINE GAUSSC (M, C, P0, P1, IERROR)
C
C ---------------------------------------------------------------------I
C PURPOSE: INITIALIZE SET OF GAUSS COLLOCATION PARAMETERS FOR M>=6     I
C -------  BY COMPUTING THE ZEROS OF THE LEGENDRE POLYNOMIAL PM(2S-1)  I
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER M, IERROR
      REAL C(M), P0(0:M), P1(0:*)
C P0     CONTAINS COEFFICIENTS OF LEGENDRE POLYNOMIALS                 I
C P1     AS P0                                                         I
C IERROR ENTRY: 0                                                      I
C        EXIT:  0: OK                                                  I
C               3: IMPOSSIBLE TO COMPUTE GAUSS COLLOC. PARAMETERS      I
C                                                                      I
C INVOKED BY: GAUSS                                                    I
C ----------                                                           I
C                                                                      I
C LOCAL VARIABLES:                                                     I
C ---------------                                                      I
      CHARACTER*10 VAROUT
C                                                                      I
C ---------------------------------------------------------------------I
C
      INTEGER J, NP1
      REAL PNJ, PNJM1, PNM1J
C
C BUILD UP LEGENDRE POLYNOMIAL PM(2S-1)
      DO 10 J = 0, M
         P0(J) = 0.0
         P1(J) = 0.0
   10 CONTINUE
      P0(0) = 1.0
      P1(0) = -1.0
      P1(1) = 2.0
      DO 20 NP1 = 2, M
         PNJM1 = 0.0
         DO 30 J = 0, NP1
            PNM1J = P0(J)
            PNJ   = P1(J)
            P0(J) = PNJ
            P1(J) = ((2*NP1-1)*(2*PNJM1-PNJ) - (NP1-1)*PNM1J) / NP1
            PNJM1 = PNJ
   30    CONTINUE
   20 CONTINUE
*
C COMPUTE ZEROS
      DO 50 J = 0, M
         P0(J) = P1(M-J)
   50 CONTINUE
*
      CALL ZERPOL (P0, M, C, IERROR)
      IF (IERROR .NE. 0) GOTO 900
*
      RETURN
C
C ERROR IN FINDING ZEROS OF POLYNOMIAL
  900 WRITE(VAROUT,'(I10)') M
      CALL ERRMSG ('   WHILE COMPUTING THE'//VAROUT//
     +             ' GAUSS COLLOC. PARAMETERS')
      IERROR = 3
      RETURN
      END
      SUBROUTINE LOBATO (M, C, WKAREA, IERROR)
C
C ---------------------------------------------------------------------I
C PURPOSE: INITIALIZE THE SET OF LOBATTO COLLOCATION PARAMETERS        I
C -------                                                              I
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER M, IERROR
      REAL C(M), WKAREA(*)
C                                                                      I
C INVOKED BY: COLCWL                                                   I
C ----------                                                           I
C                                                                      I
C ---------------------------------------------------------------------I
C
      REAL X, S63, S15
*
      IF (M .EQ. 2) THEN
         C(1) = 0.0
         C(2) = 1.0
      ELSE IF (M .EQ. 3) THEN
         C(1) = 0.0
         C(2) = 0.5
         C(3) = 1.0
      ELSE IF (M .EQ. 4) THEN
         X = SQRT(5.0)/5.0
         C(1) = 0.0
         C(2) = 0.5 * (1.0-X)
         C(3) = 0.5 * (1.0+X)
         C(4) = 1.0
      ELSE IF (M .EQ. 5) THEN
         X = SQRT(21.0)/7.0
         C(1) = 0.0
         C(2) = 0.5 * (1.0-X)
         C(3) = 0.5
         C(4) = 0.5 * (1.0+X)
         C(5) = 1.0
      ELSE IF (M .EQ. 6) THEN
         S63 = SQRT(63.0)
         X = SQRT((105.0+10.0*S63)/315.0)
         C(1) = 0.0
         C(2) = 0.5 * (1.0-X)
         C(5) = 0.5 * (1.0+X)
         X = SQRT((105.0-10.0*S63)/315.0)
         C(3) = 0.5 * (1.0-X)
         C(4) = 0.5 * (1.0+X)
         C(6) = 1.0
      ELSE IF (M .EQ. 7) THEN
         S15 = SQRT(15.0)
         X = SQRT((15.0+2*S15)/33.0)
         C(1) = 0.0
         C(2) = 0.5 * (1.0-X)
         C(6) = 0.5 * (1.0+X)
         X = SQRT((15.0-2*S15)/33.0)
         C(3) = 0.5 * (1.0-X)
         C(4) = 0.5
         C(5) = 0.5 * (1.0+X)
         C(7) = 1.0
      ELSE
         CALL LOBATC (M, C, WKAREA, WKAREA(M+1), IERROR)
         C(1) = 0.0
         C(M) = 1.0
      ENDIF
*
      RETURN
      END
      SUBROUTINE LOBATC (M, C, P0, P1, IERROR)
C
C ---------------------------------------------------------------------I
C PURPOSE: INITIALIZE SET OF GAUSS COLLOCATION PARAMETERS FOR M>=8     I
C -------  BY COMPUTING THE ZEROS OF THE DERIVATIVE OF THE LEGENDRE    I
C POLYNOMIAL P(M-1) (2S-1).                                            I
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER M, IERROR
      REAL C(M), P0(0:M-1), P1(0:*)
C P0     CONTAINS COEFFICIENTS OF LEGENDRE POLYNOMIALS                 I
C P1     AS P0                                                         I
C IERROR ENTRY: 0                                                      I
C        EXIT:  0: OK                                                  I
C               3: IMPOSSIBLE TO COMPUTE LOBATTO COLLOC. PARAMETERS    I
C                                                                      I
C INVOKED BY: LOBATO                                                   I
C ----------                                                           I
C                                                                      I
C LOCAL VARIABLES:                                                     I
C ---------------                                                      I
      CHARACTER*10 VAROUT
C                                                                      I
C ---------------------------------------------------------------------I
C
      INTEGER J, NP1
      REAL PNJ, PNJM1, PNM1J
C
C BUILD UP LEGRENDRE POLYNOMIAL P(M-1) (2S-1)
      DO 10 J = 0, M-1
         P0(J) = 0.0
         P1(J) = 0.0
   10 CONTINUE
      P0(0) = 1.0
      P1(0) = -1.0
      P1(1) = 2.0
      DO 20 NP1 = 2, M-1
         PNJM1 = 0.0
         DO 30 J = 0, NP1
            PNM1J = P0(J)
            PNJ   = P1(J)
            P0(J) = PNJ
            P1(J) = ((2*NP1-1)*(2*PNJM1-PNJ) - (NP1-1)*PNM1J) / NP1
            PNJM1 = PNJ
   30    CONTINUE
   20 CONTINUE
C
C COMPUTE ZEROS
      DO 50 J = 0, M-2
C   P0: COEFFICIENTS OF DERIVATIVE OF P(M-1) (2S-1)
         P0(J) = (M-1-J)*P1(M-1-J)
   50 CONTINUE
*
      CALL ZERPOL (P0, M-2, C(2), IERROR)
      IF (IERROR .NE. 0) GOTO 900
*
      RETURN
C
C ERROR IN FINDING ZEROS OF POLYNOMIAL
  900 WRITE(VAROUT,'(I10)') M
      CALL ERRMSG ('   WHILE COMPUTING THE'//VAROUT//
     +             ' LOBATTO COLLOC. PARAMETERS')
      IERROR = 3
      RETURN
      END
      SUBROUTINE RADAU (M, C, WKAREA, IERROR)
C
C ---------------------------------------------------------------------I
C PURPOSE: INITIALIZE THE SET OF RADAU COLLOCATION PARAMETERS          I
C -------                                                              I
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER M, IERROR
      REAL C(M), WKAREA(*)
C                                                                      I
C INVOKED BY: COLCWL                                                   I
C ----------                                                           I
C                                                                      I
C ---------------------------------------------------------------------I
C
      REAL X
*
      IF (M .EQ. 2) THEN
         X = -1.0/3.0
         C(1) = 0.5 * (1.0+X)
         C(2) = 1.0
      ELSE IF (M .EQ. 3) THEN
         X = SQRT(6.0)/5.0
         C(1) = 0.5 * (1.0+(-0.2-X))
         C(2) = 0.5 * (1.0+(-0.2+X))
         C(3) = 1.0
      ELSE
         CALL RADAUC (M, C, WKAREA, WKAREA(M+2), IERROR)
      ENDIF
*
      RETURN
      END
      SUBROUTINE RADAUC (M, C, P0, P1, IERROR)
C
C ---------------------------------------------------------------------I
C PURPOSE: INITIALIZE SET OF RADAU COLLOCATION PARAMETERS FOR M>=4     I
C -------  BY COMPUTING THE ZEROS OF THE DIFFERENCE OF THE LEGENDRE    I
C POLYNOMIALS P(M-1) (2S-1) AND PM (2S-1).                             I
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER M, IERROR
      REAL C(M), P0(0:M), P1(0:*)
C P0     CONTAINS COEFFICIENTS OF LEGENDRE POLYNOMIALS                 I
C P1     AS P0                                                         I
C IERROR ENTRY: 0                                                      I
C        EXIT:  0: OK                                                  I
C               3: IMPOSSIBLE TO COMPUTE RADAU COLLOC. PARAMETERS      I
C                                                                      I
C INVOKED BY: RADAU                                                    I
C ----------                                                           I
C                                                                      I
C LOCAL VARIABLES:                                                     I
C ---------------                                                      I
      CHARACTER*10 VAROUT
C                                                                      I
C ---------------------------------------------------------------------I
C
      INTEGER J, NP1
      REAL PNJ, PNJM1, PNM1J
C
C BUILD UP LEGRENDRE POLYNOMIALS PM-1(2S-1) AND PM(2S-1)
      DO 10 J = 0, M
         P0(J) = 0.0
         P1(J) = 0.0
   10 CONTINUE
      P0(0) = 1.0
      P1(0) = -1.0
      P1(1) = 2.0
      DO 20 NP1 = 2, M-1
         PNJM1 = 0.0
         DO 30 J = 0, NP1
            PNM1J = P0(J)
            PNJ   = P1(J)
            P0(J) = PNJ
            P1(J) = ((2*NP1-1)*(2*PNJM1-PNJ) - (NP1-1)*PNM1J) / NP1
            PNJM1 = PNJ
   30    CONTINUE
   20 CONTINUE
      PNJM1 = 0.0
      DO 40 J = 0, M
         PNM1J = P0(J)
         PNJ   = P1(J)
         P0(J) = ((2*M-1)*(2*PNJM1-PNJ) - (M-1)*PNM1J) / M
         PNJM1 = PNJ
   40 CONTINUE
C
C P1: P(M-1) (2S-1) - PM (2S-1)
      DO 45 J = 0, M
         P1(J) = P1(J) - P0(J)
   45 CONTINUE
C
C COMPUTE ZEROS
      DO 50 J = 0, M
         P0(J) = P1(M-J)
   50 CONTINUE
*
      CALL ZERPOL (P0, M, C, IERROR)
      IF (IERROR .NE. 0) GOTO 900
*
      RETURN
C
C ERROR IN FINDING ZEROS OF POLYNOMIAL
  900 WRITE(VAROUT,'(I10)') M
      CALL ERRMSG ('   WHILE COMPUTING THE'//VAROUT//
     +             ' RADAU COLLOC. PARAMETERS')
      IERROR = 3
      RETURN
      END
      SUBROUTINE COMPWL (M, S, L, C, W, LC)
C
C ---------------------------------------------------------------------I
C PURPOSE: GIVEN THE COLLOC. PARAMETERS C(1:M), COMPUTE THE ASSOCIATED I
C -------  WEIGHT FACTORS FOR THE QUADRATURE AND THE LAGRANGIAN        I
C INTERPOLATION COEFFICIENTS IN (CI.CJ)                                I
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER M, S, L
      REAL C(M), W(S), LC(M,L:M,L:S)
C                                                                      I
C INVOKED BY: COLCWL                                                   I
C ----------                                                           I
C                                                                      I
C ---------------------------------------------------------------------I
C
      INTEGER I, J, K
      REAL INTEGL, LAGPOL, CJK
      EXTERNAL INTEGL, LAGPOL
C
C COMPUTE WEIGHT FACTORS; USE LC AS WORK SPACE
      DO 10 I = 1, S
         W(I) = INTEGL(I, 1.0, S, C, LC)
   10 CONTINUE
C
C COMPUTE LAGRANGIAN INTERPOLATION COEFFICIENTS
      DO 20 K = L, S
         DO 30 J = L, M
            CJK = C(J)*C(K)
            DO 40 I = 1, M
               LC(I,J,K) = LAGPOL (I, CJK, M, C)
   40       CONTINUE
   30    CONTINUE
   20 CONTINUE
*
      RETURN
      END
      SUBROUTINE COMPLV (V, M, C, LCV)
C
C ---------------------------------------------------------------------I
C PURPOSE: GIVEN THE COLLOCATION PARAMETERS C(1:M), COMPUTE THE        I
C -------  LAGRANGIAN INTERPOLATION COEFFICIENTS IN THE POINT "V"      I
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER M
      REAL V
      REAL C(M), LCV(M)
C                                                                      I
C INVOKED BY: COLVI2                                                   I
C ----------                                                           I
C                                                                      I
C ---------------------------------------------------------------------I
C
      INTEGER I
      REAL LAGPOL
      EXTERNAL LAGPOL
*
      DO 10 I = 1, M
         LCV(I) = LAGPOL (I, V, M, C)
   10 CONTINUE
      RETURN
      END
      SUBROUTINE COMPLG (M, C, LCG, WKAREA)
C
C ---------------------------------------------------------------------I
C PURPOSE: GIVEN THE GAUSSIAN COLLOCATION PARAMETERS C(1:M) PLUS THE   I
C -------  POINTS 0.0 AND 1.0, COMPUTE THE LAGRANGIAN INTERPOLATION    I
C COEFFICIENTS IN CJ/2                                                 I
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER M
      REAL C(M), LCG(0:M+1,M), WKAREA(1:M+2)
C                                                                      I
C INVOKED BY: COLVI2                                                   I
C ----------                                                           I
C                                                                      I
C ---------------------------------------------------------------------I
C
      INTEGER I, J
      REAL LAGPOL
      EXTERNAL LAGPOL
*
      WKAREA(1) = 0.0
      DO 10 I = 1, M
         WKAREA(I+1) = C(I)
   10 CONTINUE
      WKAREA(M+2) = 1.0
      DO 20 I = 0, M+1
         DO 30 J = 1, M
            LCG(I,J) = LAGPOL (I+1, C(J)/2, M+2, WKAREA)
   30    CONTINUE
   20 CONTINUE
*
      RETURN
      END
      REAL FUNCTION INTEGL (J, U, M, C, WKAREA)
C
C ---------------------------------------------------------------------I
C PURPOSE: COMPUTE                                                     I
C -------   U                              M                           I
C         INT L_J(V) DV,  WITH L_J(V) = PROD (V-CI)/(CJ-CI)            I
C           0                             I=1                          I
C                                        I/=J                          I
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER J, M
      REAL U
      REAL C(M), WKAREA(0:M)
C                                                                      I
C INVOKED BY: COMPWL                                                   I
C ----------                                                           I
C                                                                      I
C ---------------------------------------------------------------------I
C
      INTEGER N, I, K
      REAL CI, CJ, DENOM, NUMER
C
C
C BUILD NUMERATOR OF L_J
C     WKAREA(I) CONTAINS THE COEFFICIENT OF V**I
      WKAREA(0) = 1.0
      N = 0
      DO 10 I = 1, M
         IF (I .NE. J) THEN
            CI = C(I)
            N = N+1
            WKAREA(N) = 1.0
            DO 20 K = N-1, 1, -1
               WKAREA(K) = WKAREA(K-1) - CI*WKAREA(K)
   20       CONTINUE
            WKAREA(0) = -C(I)*WKAREA(0)
         ENDIF
   10 CONTINUE
C
C
C INTEGRATE NUMERATOR OF L_J AND BUILD UP DENOMINATOR
      CJ = C(J)
      NUMER = 0.0
      DENOM = 1.0
      DO 30 I = M, 1, -1
         NUMER = (NUMER + WKAREA(I-1)/I) * U
         IF (I .NE. J) DENOM = DENOM * (CJ - C(I))
   30 CONTINUE
*
      INTEGL = NUMER / DENOM
*
      RETURN
      END
      REAL FUNCTION LAGPOL (J, V, M, C)
C
C ---------------------------------------------------------------------I
C PURPOSE: COMPUTE                                                     I
C -------             M                                                I
C         L_J(V) = PROD (V-CI)/(CJ-CI)                                 I
C                    I=1                                               I
C                    I/=J                                              I
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER J, M
      REAL V
      REAL C(M)
C                                                                      I
C INVOKED BY: SLICE2, COMPWL, COMPLV, COMPLG                           I
C ----------                                                           I
C                                                                      I
C ---------------------------------------------------------------------I
C
      INTEGER I
      REAL P, CJ
*
      CJ = C(J)
      P = 1.0
      DO 10 I = 1, M
         IF (I .NE. J) P = P * (V-C(I))/(CJ-C(I))
   10 CONTINUE
*
      LAGPOL = P
*
      RETURN
      END
      SUBROUTINE ADJLSV (TN, HN, NEQN, KC, C,W, UN, LAGSAV)
C
C ---------------------------------------------------------------------I
C PURPOSE: ADJUST LAGSAV FOR INTEGRATION STEP FROM T(N+1) TO T(N+2)    I
C -------                                                              I
C                                                                      I
C COMMON VARIABLES:                                                    I
C ----------------                                                     I
      INTEGER METH, M, S, L, ORDER, ORDERQ, METHR, MR, SR, LR, ORDERR,
     +        ERRWGT, NHFAIL, NERR, NWIR, NSAV,
     +        MAXNC, MAXKEV, MAXCPS, N, NCIT, NKEV, NCPS
      COMMON /COLCMI/ METH, M, S, L, ORDER, ORDERQ,
     +                METHR, MR, SR, LR, ORDERR,
     +                ERRWGT, NHFAIL,
     +                NERR, NWIR, NSAV,
     +                MAXNC, MAXKEV, MAXCPS,
     +                N, NCIT, NKEV, NCPS
*
      SAVE /COLCMI/
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER NEQN
      REAL TN, HN
      REAL C(M), W(S), UN(0:NEQN*M-1), LAGSAV(0:NEQN*(2*M-L+1)-1)
      EXTERNAL KC
C TN     LEFT ENDPOINT OF CURRENT SUBINTERVAL                          I
C HN     LENGTH OF CURRENT SUBINTERVAL                                 I
C UN     CONTAINS SOL. IN COLL. POINTS OF N-TH SUBINTERVAL.            I
C        U(TNJ) -> UN(NEQN*(J-1)+(0:NEQN-1), J=1,M                     I
C LAGSAV ENTRY: CONTAINS APPROX. OF (T0,TN) INT K(TNJ,.,.)  J=1,M  IN  I
C               LAST NEQN*M LOCATIONS.                                 I
C        EXIT:  CONTAINS APPROX. OF (T0,TN+HN) INT K(TNJ,.,.)  J=1,M   I
C               IN THE FIRST NEQN*M LOCATIONS.                         I
C                                                                      I
C INVOKED BY: SOLVI2                                                   I
C ----------                                                           I
C                                                                      I
C CHANGES IN COMMON VARIABLES:                                         I
C ---------------------------                                          I
C NKEV   ADDED: # KERNEL EVAL. NEEDED TO COMPUTE                       I
C        (TN,TN+HN) INT K(TN+CJ.HN,.,.)                                I
C                                                                      I
C LOCAL VARIABLES:                                                     I
C ---------------                                                      I
      REAL TNJ
C TNJ    TN + C(J).HN                                                  I
C                                                                      I
C ---------------------------------------------------------------------I
C
      INTEGER INDEXJ, INDMLJ, J, K, ML
*
      ML = M-L+1
C
C SHIFT FCN(TN+CJ.HN) FROM LAST TO FIRST LOCATIONS OF "LAGSAV";
C ADJUST TO GET FCNP1(TN+CJ.HN)
      DO 10 J = 1, M
         INDEXJ = NEQN*(J-1)
         INDMLJ = NEQN*(ML+J-1)
         TNJ = TN + C(J)*HN
*
         CALL COPYV (LAGSAV(INDMLJ), NEQN, LAGSAV(INDEXJ))
*
C ADD APPROX. OF (TN,TNP1) INT K(TNJ,...) TO GET FCNP1(TNJ)
C STORE KERNEL VECTOR IN LAGSAV(ML+J)
         DO 20 K = 1, S
            CALL KC(TNJ,TN+C(K)*HN,UN(NEQN*(K-1)),LAGSAV(INDMLJ))
            CALL ADDABV (LAGSAV(INDEXJ), NEQN, HN*W(K), LAGSAV(INDMLJ))
   20    CONTINUE
   10 CONTINUE
      NKEV = NKEV + M*S
*
      RETURN
      END
      REAL FUNCTION LEEWGT
     +   (TN,HN, NEQN,KC, T0, C,W, CR,WR, UN, URN, WKAREA)
C
C ---------------------------------------------------------------------I
C PURPOSE: ESTIMATE ERROR IN TN+HN BY (TN+HN-T0)/HN.LOCAL_ERROR(TN+HN) I
C -------  WHERE THE LOCAL ERROR IS AN APPROXIMATION OF                I
C      (TN,TN+HN) INT K(TN+HN,S,Y) - HN.SUM WJ.K(TN+HN,TN+CJ.HN,U_NJ). I
C RETURN NORM OF WEIGHTED ERROR VECTOR.                                I
C                                                                      I
C COMMON VARIABLES:                                                    I
C ----------------                                                     I
      INTEGER METH, M, S, L, ORDER, ORDERQ, METHR, MR, SR, LR, ORDERR,
     +        ERRWGT, NHFAIL, NERR, NWIR, NSAV,
     +        MAXNC, MAXKEV, MAXCPS, N, NCIT, NKEV, NCPS
      COMMON /COLCMI/ METH, M, S, L, ORDER, ORDERQ,
     +                METHR, MR, SR, LR, ORDERR,
     +                ERRWGT, NHFAIL,
     +                NERR, NWIR, NSAV,
     +                MAXNC, MAXKEV, MAXCPS,
     +                N, NCIT, NKEV, NCPS
*
      SAVE /COLCMI/
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER NEQN
      REAL TN, HN, T0
      REAL C(M), W(S), CR(MR), WR(SR), UN(0:NEQN*M-1), URN(0:NEQN*MR-1),
     +     WKAREA(*)
      EXTERNAL KC
C TN     LEFT ENDPOINT OF CURRENT SUBINTERVAL                          I
C HN     LENGTH OF CURRENT SUBINTERVAL                                 I
C UN     CONTAINS SOL. IN TN+CJ.HN, J=1,...,M                          I
C        U(TNJ) -> UN(NEQN*(J-1)+(0:NEQN-1))                           I
C URN    CONTAINS SOL. IN TN+CRJ.HN, J=1,...,MR                        I
C        UR(TNJ) -> URN(NEQN*(J-1)+(0:NEQN-1))                         I
C WKAREA WORKING STORAGE FOR INTERMEDIATE VECTOR RESULTS (>=2*NEQN)    I
C                                                                      I
C INVOKED BY: SOLVI2                                                   I
C ----------                                                           I
C                                                                      I
C CHANGES IN COMMON VARIABLES:                                         I
C ---------------------------                                          I
C NKEV   ADDED: # KERNEL EVAL. NEEDED TO COMPUTE LOCAL ERROR ESTIMATE  I
C        IN TN+HN                                                      I
C                                                                      I
C LOCAL VARIABLES:                                                     I
C ---------------                                                      I
      REAL TNP1
C                                                                      I
C ---------------------------------------------------------------------I
C
      INTEGER I1, J
      REAL WMXNRM
      EXTERNAL WMXNRM
*
      I1 = NEQN+1
*
      TNP1 = TN+HN
C
C
C COMPUTE LOCAL ERROR ESTIMATE DIVIDED BY HN; STORE IN "WKAREA(1:NEQN)";
C STORE KERNEL VECTOR IN "WKAREA(NEQN+1:)"
      CALL ZEROV (WKAREA, NEQN)
      DO 10 J = 1, SR
         CALL KC(TNP1,TN+CR(J)*HN,URN(NEQN*(J-1)),WKAREA(I1))
         CALL ADDABV (WKAREA, NEQN, WR(J), WKAREA(I1))
   10 CONTINUE
      DO 20 J = 1, S
         CALL KC(TNP1,TN+C(J)*HN,UN(NEQN*(J-1)),WKAREA(I1))
         CALL ADDABV (WKAREA, NEQN, -W(J), WKAREA(I1))
   20 CONTINUE
      NKEV = NKEV + SR + S
C
C COMPUTE ESTIMATION OF GLOBAL ERROR
      TNP1 = TNP1-T0
      DO 30 J = 1, NEQN
         WKAREA(J) = WKAREA(J) * TNP1
   30 CONTINUE
*
      LEEWGT = WMXNRM (WKAREA, URN(NEQN*(MR-1)), NEQN)
*
      RETURN
      END
      REAL FUNCTION UEEWGT
     +   (TN,HN, NEQN,KC, T0,TE, C,W, CR,WR, UN, URN,
     +    LEESUM, ESTGEE, WKAREA, LEE)
C
C ---------------------------------------------------------------------I
C PURPOSE: APPROXIMATE THE ERROR IN A POINT T BY THE SUM OF THE        I
C -------  ESTIMATED CONTRIBUTION TO THE GLOBAL ERROR OVER THE         I
C INTERVAL [TN,T] AND THE ALREADY APPROXIMATED CONTRIBUTION TO THIS    I
C ERROR OVER [T0,TN]; I.E.,                                            I
C    GLOB.EE(I) = (T-TN)/HN.!LEE(I)! + !LEESUM(I)! ,                   I
C                      FOR T=TI = TE (-HC) TN+HN,  I=0,...     , WHERE I
C    LEE(I) = (TN,TN+1) INT K(T,S,Y) - HN.SUM WJ.K(T,TN+CJ.HN,U_NJ)    I
C RETURN MAXIMUM OF NORM OF WEIGHTED GLOBAL ERROR VECTORS, AND LEE(I). I
C NOTE: IT IS POSSIBLE THAT ON ENTRY LEESUM(I)=0 EVEN IF TN>T0,        I
C ----  (ESTGEE=.TRUE.). IN THIS CASE  GLOB.EE(I) = (T-T0)/HN !LEE(I)! I
C                                                                      I
C COMMON VARIABLES:                                                    I
C ----------------                                                     I
      INTEGER METH, M, S, L, ORDER, ORDERQ, METHR, MR, SR, LR, ORDERR,
     +        ERRWGT, NHFAIL, NERR, NWIR, NSAV,
     +        MAXNC, MAXKEV, MAXCPS, N, NCIT, NKEV, NCPS
      COMMON /COLCMI/ METH, M, S, L, ORDER, ORDERQ,
     +                METHR, MR, SR, LR, ORDERR,
     +                ERRWGT, NHFAIL,
     +                NERR, NWIR, NSAV,
     +                MAXNC, MAXKEV, MAXCPS,
     +                N, NCIT, NKEV, NCPS
*
      REAL TOLLE, TOLCIA, TOLCIR, HMIN, HMAX, HC
      COMMON /COLCMR/ TOLLE, TOLCIA, TOLCIR, HMIN, HMAX, HC
*
      SAVE /COLCMI/, /COLCMR/
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER NEQN
      LOGICAL ESTGEE
      REAL TN, HN, T0, TE
      REAL C(M), W(S), CR(MR), WR(SR), UN(0:NEQN*M-1), URN(0:NEQN*MR-1),
     +     LEESUM(*), WKAREA(*), LEE(*)
      EXTERNAL KC
C TN     LEFT ENDPOINT OF CURRENT SUBINTERVAL                          I
C HN     LENGTH OF CURRENT SUBINTERVAL                                 I
C UN     CONTAINS SOL. IN TN+CJ.HN, J=1,...,M                          I
C        U(TNJ) -> UN(0:NEQN*(J-1)+(NEQN-1))                           I
C URN    CONTAINS SOL. IN TN+CRJ.HN, J=1,...,MR                        I
C        UR(TNJ) -> URN(0:NEQN*(J-1)+(NEQN-1))                         I
C LEESUM ENTRY: LEESUM(I*NEQN+(1:NEQN) CONTAINS                        I
C               (K=0,N-1) SUM LEE_K(I*NEQN+(1:NEQN)),                  I
C               I=0,...; T = TE,(-HC),TN+HN                            I
C ESTGEE INDICATES IF THE APPROX. CONTRIBUTION TO THE GLOBAL ERROR     I
C        OVER [T0,TN] IS AVAILABLE; TRUE IF NOT.                       I
C WKAREA WORKING STORAGE FOR INTERMEDIATE VECTOR RESULTS (>=2*NEQN)    I
C LEE    EXIT:  LEE(I*NEQN+(1:NEQN)) CONTAINS LOCAL ERROR EST. IN T.   I
C               I=0,...; T = TE,(-HC),TN+HN                            I
C               (OR IF ESTGEE: (TN+HN-T0)/HN.LOCAL ERROR(T) )          I
C                                                                      I
C INVOKED BY: SOLVI2                                                   I
C ----------                                                           I
C                                                                      I
C CHANGES IN COMMON VARIABLES:                                         I
C ---------------------------                                          I
C NKEV   ADDED: # KERNEL EVAL. NEEDED TO COMPUTE LOCAL ERROR ESTIMATES I
C        IN ALL THE CHECKPOINTS OF THE INTERVAL [TN+HN,TE]             I
C                                                                      I
C LOCAL VARIABLES:                                                     I
C ---------------                                                      I
      REAL WGEEI
C WGEEI  WEIGHTED ERROR ESTIMATE IN CHECKPOINTS                        I
C                                                                      I
C ---------------------------------------------------------------------I
C
      INTEGER I, INDEXI, INDXIJ, I1, J
      REAL FACLEE, T, TN0, WMXNRM
      EXTERNAL WMXNRM
*
      I1 = NEQN+1
*
      IF (ESTGEE) THEN
         TN0 = T0
      ELSE
         TN0 = TN
      ENDIF
      FACLEE = TN+HN - TN0
*
      I = 0
      UEEWGT = 0.0
      DO 10 T = TE, TN+HN, -HC
         INDEXI = NEQN*I
*
C   COMPUTE LOCAL ERROR ESTIMATE IN T, DIVIDED BY HN;
C   STORE IN WKAREA(1:NEQN); STORE KERNEL VECTOR IN WKAREA(NEQN+1:)
         CALL ZEROV (WKAREA, NEQN)
         DO 20 J = 1, SR
            CALL KC(T,TN+CR(J)*HN,URN(NEQN*(J-1)),WKAREA(I1))
            CALL ADDABV (WKAREA, NEQN, WR(J), WKAREA(I1))
   20    CONTINUE
         DO 30 J = 1, S
            CALL KC(T,TN+C(J)*HN,UN(NEQN*(J-1)),WKAREA(I1))
            CALL ADDABV (WKAREA, NEQN, -W(J), WKAREA(I1))
   30    CONTINUE
         NKEV = NKEV + SR + S
C
C   STORE LOCAL ERROR ESTIMATE IN "LEE";
C   COMPUTE GLOBAL ERROR ESTIMATE; STORE IN WKAREA
         DO 40 J = 1, NEQN
            INDXIJ = INDEXI+J
            LEE(INDXIJ) = WKAREA(J) * FACLEE
            WKAREA(J) = (T-TN0)*ABS(WKAREA(J)) + ABS(LEESUM(INDXIJ))
   40    CONTINUE
*
         WGEEI = WMXNRM (WKAREA, URN(NEQN*(MR-1)), NEQN)
         UEEWGT = MAX(UEEWGT,WGEEI)
         I = I+1
   10 CONTINUE
*
      RETURN
      END
      REAL FUNCTION WMXNRM (ERR, SOL, NDIM)
C
C ---------------------------------------------------------------------I
C PURPOSE: RETURN WEIGHTED MAXIMUM NORM OF THE ABSOLUTE ERROR VECTOR   I
C ------  "ERR" ON SOLUTION VECTOR "SOL".                              I
C USE A WEIGHT FACTOR AS INDICATED BY THE VARIABLE "ERRWGT"            I
C                                                                      I
C COMMON VARIABLES:                                                    I
C ----------------                                                     I
      INTEGER METH, M, S, L, ORDER, ORDERQ, METHR, MR, SR, LR, ORDERR,
     +        ERRWGT, NHFAIL, NERR, NWIR, NSAV,
     +        MAXNC, MAXKEV, MAXCPS, N, NCIT, NKEV, NCPS
      COMMON /COLCMI/ METH, M, S, L, ORDER, ORDERQ,
     +                METHR, MR, SR, LR, ORDERR,
     +                ERRWGT, NHFAIL,
     +                NERR, NWIR, NSAV,
     +                MAXNC, MAXKEV, MAXCPS,
     +                N, NCIT, NKEV, NCPS
*
      SAVE /COLCMI/
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER NDIM
      REAL ERR(NDIM), SOL(NDIM)
C                                                                      I
C INVOKED BY: SOLVI2, SOLSYS, YPOLM, LEEWGT, UEEWGT                    I
C ----------                                                           I
C                                                                      I
C CHANGES IN COMMON VARIABLES: NONE                                    I
C ---------------------------                                          I
C                                                                      I
C ---------------------------------------------------------------------I
C
      INTEGER K
*
      WMXNRM = 0.0
*
      GOTO (10, 20, 30) ERRWGT
*
C  MIXED ERROR CONTROL
   10 DO 15 K = 1, NDIM
         WMXNRM = MAX(WMXNRM, ABS(ERR(K))/MAX(1.0,ABS(SOL(K))))
   15 CONTINUE
      RETURN
*
C  ABSOLUTE ERROR CONTROL
   20 DO 25 K = 1, NDIM
         WMXNRM = MAX(WMXNRM, ABS(ERR(K)))
   25 CONTINUE
      RETURN
*
C  RELATIVE ERROR CONTROL
   30 DO 35 K = 1, NDIM
         WMXNRM = MAX(WMXNRM, ABS(ERR(K)/SOL(K)))
   35 CONTINUE
      RETURN
*
      END
      SUBROUTINE CHKFIL (CNTRL, IERROR)
C
C ---------------------------------------------------------------------I
C PURPOSE: CHECK STATUS OF FILES, THAT SHOULD HAVE BEEN OPENED BY USER I
C -------                                                              I
C                                                                      I
C COMMON VARIABLES:                                                    I
C ----------------                                                     I
      INTEGER METH, M, S, L, ORDER, ORDERQ, METHR, MR, SR, LR, ORDERR,
     +        ERRWGT, NHFAIL, NERR, NWIR, NSAV,
     +        MAXNC, MAXKEV, MAXCPS, N, NCIT, NKEV, NCPS
      COMMON /COLCMI/ METH, M, S, L, ORDER, ORDERQ,
     +                METHR, MR, SR, LR, ORDERR,
     +                ERRWGT, NHFAIL,
     +                NERR, NWIR, NSAV,
     +                MAXNC, MAXKEV, MAXCPS,
     +                N, NCIT, NKEV, NCPS
*
      INTEGER IBETA, IOVFLO, NSDEC, IMXLUN
      COMMON /COLMCI/ IBETA, IOVFLO, NSDEC, IMXLUN
*
      SAVE /COLCMI/, /COLMCI/
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER IERROR
      INTEGER CNTRL(*)
C IERROR ENTRY: 0                                                      I
C        EXIT:  0: OK                                                  I
C               1: STATUS ERROR_MESSAGE_FILE WRONG                     I
C               2: LOGICAL UNIT # OR STATUS OF FILE FOR INTERMEDIATE   I
C                  RESULTS OR SAVE_ALL_FILE WRONG                      I
C                                                                      I
C INVOKED BY: CHKINI                                                   I
C ----------                                                           I
C                                                                      I
C CHANGES IN COMMON VARIABLES: NONE                                    I
C ---------------------------                                          I
C                                                                      I
C CONSTANTS:                                                           I
C ---------                                                            I
      CHARACTER*16 HDR
      PARAMETER (HDR = ' ERROR COLVI2...')
C                                                                      I
C LOCAL VARIABLES:                                                     I
C ---------------                                                      I
      CHARACTER*10 VAROUT
C                                                                      I
C ---------------------------------------------------------------------I
C
      CHARACTER ACC*10, FM*9
      INTEGER LUN, IOS
      LOGICAL OD
C
C
C CHECK ERROR_MESSAGE FILE
      LUN = CNTRL(2)
C
C   CHECK CNTRL(2)
      IF (LUN .LT. 0 .OR. LUN .GT. IMXLUN) THEN
C      WRONG LUN, WRITE MESSAGE TO STANDARD OUTPUT FILE AND RETURN
         PRINT *, HDR, 'INPUT PARAMETER CNTRL(2) = ', LUN
         PRINT *, HDR, '   LOGICAL UNIT # OF ERROR_MESSAGE_FILE, ',
     +                 'SHOULD BE:'
         PRINT *, HDR, '      0 <= CNTRL(2) <= IMXLUN = ', IMXLUN
         PRINT *, HDR, '   NO FURTHER CONTROL ON INPUT PARAMETERS'
         IERROR = 1
         RETURN
      ENDIF
C
C   CHECK STATUS
      IF (LUN .EQ. 0) GOTO 10
      INQUIRE(UNIT=LUN, IOSTAT=IOS, ERR=900, OPENED=OD, ACCESS=ACC,
     +        FORM=FM)
C      CHECK IF OPENED, IF SO CHECK SPECIFICATIONS
      IF (OD) THEN
         IF (ACC .NE. 'SEQUENTIAL') THEN
            PRINT *, HDR, 'ERROR MESSAGE FILE SHOULD BE A SEQUENTIAL ',
     +                    'FILE'
            PRINT *, HDR, '   NO FURTHER CONTROL ON INPUT PARAMETERS'
            IERROR = 1
         ENDIF
         IF (FM .NE. 'FORMATTED') THEN
            PRINT *, HDR, 'ERROR MESSAGE FILE SHOULD BE A FORMATTED ',
     +                    'FILE'
            PRINT *, HDR, '   NO FURTHER CONTROL ON INPUT PARAMETERS'
            IERROR = 1
         ENDIF
      ELSE
         PRINT *, HDR, 'ERROR MESSAGE FILE NOT OPENED'
         PRINT *, HDR, '   NO FURTHER CONTROL ON INPUT PARAMETERS'
         IERROR = 1
      ENDIF
      IF (IERROR .EQ. 0) GOTO 10
      RETURN
*
C SOME ERROR IN INQUIRE, ????????????
C   WRITE IO STATUS AND RETURN
  900 PRINT *, HDR, 'ERROR IN INQUIRE OF ERROR_MESSAGE_FILE, ',
     +              'IO STATUS = ', IOS
      PRINT *, HDR, '   THIS SHOULD NOT HAPPEN, ERROR IN "CHKFIL" ?'
      IERROR = 1
      RETURN
*
C
   10 CONTINUE
C STORE LOGICAL UNIT # ERROR MESSAGE FILE IN COMMON
      NERR = LUN
C
C   CHECK CNTRL(4)
      LUN = CNTRL(4)
      IF (LUN .LT. 0 .OR. LUN .GT. IMXLUN) THEN
         WRITE(VAROUT,'(I10)') LUN
         CALL ERRMSG ('INPUT PARAMETER CNTRL(4) ='//VAROUT)
         WRITE(VAROUT,'(I10)') IMXLUN
         CALL ERRMSG ('   SAVE_ON_ERROR CONTROL, SHOULD BE: '//
     +                '0 <= CNTRL(4) <= IMXLUN ='//VAROUT)
         IERROR = 2
      ENDIF
C
C CHECK FILE FOR INTERMEDIATE WRITING
C
C   CHECK CNTRL(3)
      LUN = CNTRL(3)
      IF (LUN .LT. 0 .OR. LUN .GT. IMXLUN) THEN
         WRITE(VAROUT,'(I10)') LUN
         CALL ERRMSG ('INPUT PARAMETER CNTRL(3) ='//VAROUT)
         WRITE(VAROUT,'(I10)') IMXLUN
         CALL ERRMSG ('   WRITE-INTERMED.-RES. CONTROL, SHOULD BE: '//
     +                '0 <= CNTRL(3) <= IMXLUN ='//VAROUT)
         IERROR = 2
         RETURN
      ENDIF
C
C   CHECK IF FILE IS REQUIRED
      IF (LUN .NE. 0) THEN
C      CHECK IF OPENED, AND IF SO CHECK SPECIFICATIONS
         INQUIRE(UNIT=LUN, IOSTAT=IOS, ERR=910, OPENED=OD, ACCESS=ACC,
     +           FORM=FM)
         IF (OD) THEN
            IF (ACC .NE. 'SEQUENTIAL') THEN
               CALL ERRMSG ('FILE FOR INTERM. RES. SHOULD BE A '//
     +                      'SEQUENTIAL FILE')
               IERROR = 2
            ENDIF
            IF (FM .NE. 'FORMATTED') THEN
               CALL ERRMSG ('FILE FOR INTERM. RES. SHOULD BE A '//
     +                      'FORMATTED FILE')
               IERROR = 2
            ENDIF
         ELSE
            CALL ERRMSG ('FILE FOR INTERM. RES. NOT OPENED')
            IERROR = 2
         ENDIF
      ENDIF
*
      RETURN
*
C SOME ERROR IN INQUIRE, ??????????
C   WRITE IO STATUS AND RETURN
  910 WRITE(VAROUT,'(I10)') IOS
      CALL ERRMSG ('ERROR IN INQUIRE OF FILE FOR INTERM. RES., '//
     +              'IO STATUS ='//VAROUT)
      CALL ERRMSG ('   THIS SHOULD NOT HAPPEN, ERROR IN "CHKFIL" ?')
      IERROR = 2
*
      RETURN
      END
      SUBROUTINE CHKPTO (NEQN, TN, TE, REQTOL, TOLMIN, IERROR)
C
C ---------------------------------------------------------------------I
C PURPOSE: CHECK DIMENSION AND INTEGRATION BOUNDS OF VIE2, REQUESTED   I
C -------  TOLERANCE AND, IF NECESSARY, ORDER OF COLLOC. METHOD TO     I
C COMPUTE REFERENCE SOLUTION.                                          I
C                                                                      I
C COMMON VARIABLES:                                                    I
C ----------------                                                     I
      INTEGER METH, M, S, L, ORDER, ORDERQ, METHR, MR, SR, LR, ORDERR,
     +        ERRWGT, NHFAIL, NERR, NWIR, NSAV,
     +        MAXNC, MAXKEV, MAXCPS, N, NCIT, NKEV, NCPS
      COMMON /COLCMI/ METH, M, S, L, ORDER, ORDERQ,
     +                METHR, MR, SR, LR, ORDERR,
     +                ERRWGT, NHFAIL,
     +                NERR, NWIR, NSAV,
     +                MAXNC, MAXKEV, MAXCPS,
     +                N, NCIT, NKEV, NCPS
*
      LOGICAL VS, GSSCKM, ESCGSS, GEC, ULEC, RLXTOL, GEETE,
     +        FUNCIT, NEWTON
      COMMON /COLCML/ VS, GSSCKM, ESCGSS, GEC, ULEC, RLXTOL, GEETE,
     +                FUNCIT, NEWTON
*
      INTEGER IBETA, IOVFLO, NSDEC, IMXLUN
      COMMON /COLMCI/ IBETA, IOVFLO, NSDEC, IMXLUN
*
      SAVE /COLCMI/, /COLCML/, /COLMCI/
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER NEQN, IERROR
      REAL TN, TE, REQTOL, TOLMIN
C TN     STARTING POINT OF INTEGRATION
C IERROR ENTRY: 0 OR 2                                                 I
C        EXIT:  UNCHANGED: OK                                          I
C              -2: INPUT PARAMETER "NEQN" WRONG                        I
C               2: INPUT ERROR                                         I
C                                                                      I
C INVOKED BY: CHKINI                                                   I
C ----------                                                           I
C                                                                      I
C CHANGES IN COMMON VARIABLES: NONE                                    I
C ---------------------------                                          I
C                                                                      I
C LOCAL VARIABLES:                                                     I
C ---------------                                                      I
      CHARACTER*10 VAROUT
C                                                                      I
C ---------------------------------------------------------------------I
C
C CHECK ORDER OF REFERENCE SOLUTION
      IF (GEC .OR. GEETE) THEN
         IF (ORDERR .LE. ORDER) THEN
            WRITE (VAROUT,'(I10)') ORDERR
            CALL ERRMSG ('ORDER OF APPR. METH. FOR REF. SOL. ='//VAROUT)
            WRITE (VAROUT,'(I10)') ORDER
            CALL ERRMSG ('   SHOULD BE > ORDER APPR. FOR SOL. ='//
     +                   VAROUT)
            IERROR = 2
         ENDIF
      ENDIF
      IF (VS .AND. .NOT.GEC .OR. ULEC) THEN
         IF (ORDERR .LE. ORDERQ) THEN
            WRITE (VAROUT,'(I10)') ORDERR
            CALL ERRMSG ('ORDER OF APPR. METH. FOR REF. SOL. ='//VAROUT)
            WRITE (VAROUT,'(I10)') ORDERQ
            CALL ERRMSG ('   SHOULD BE > ORDER QUAD.METH. SOL. ='//
     +           VAROUT//', IN CASE OF LOCAL / UNIFORM ERROR CONTROL')
            IERROR = 2
         ENDIF
      ENDIF
C
C
C CHECK REQUESTED TOLERANCE IN CASE OF VARIABLE STEPSIZES
      IF (VS .AND. REQTOL .LT. TOLMIN) THEN
         WRITE(VAROUT,'(E10.2)') REQTOL
         CALL ERRMSG ('INPUT PARAMETER REQTOL ='//VAROUT)
         WRITE(VAROUT,'(E10.2)') TOLMIN
         CALL ERRMSG ('   TOLERANCE TOO TIGHT, MIN. TOL. ='//VAROUT)
         IERROR = 2
      ENDIF
C
C
C CHECK INTEGRATION BOUNDS VIE2
      IF (TN .GE. TE) THEN
         WRITE(VAROUT,'(E10.2)') TN
         CALL ERRMSG ('WRONG STARTING POINT OF INTEGRATION; '//
     +                'INPUT PARAMETER T0 OR TNC ='//VAROUT)
         WRITE(VAROUT,'(E10.2)') TE
         CALL ERRMSG ('   SHOULD BE LESS THAN '//
     +                'INPUT PARAMETER TE ='//VAROUT)
         IERROR = 2
      ENDIF
C
C
C CHECK DIMENSION OF VIE2
      IF (NEQN .LT. 0 .OR. NEQN .GT. IOVFLO) THEN
         WRITE(VAROUT,'(I10)') NEQN
         CALL ERRMSG ('INPUT PARAMETER NEQN ='//VAROUT)
         CALL ERRMSG ('   SHOULD BE INTEGER > 0')
         IERROR = -2
      ENDIF
*
      RETURN
      END
      SUBROUTINE CHKOPT (CNTRL, IOPT, OPT, MCDEF, HMINFX, IERROR)
C
C ---------------------------------------------------------------------I
C PURPOSE: CHECK CONTROL AND OPTION VECTORS OF "COLVI2" ON VALIDITY    I
C -------                                                              I
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER MCDEF, IERROR
      INTEGER CNTRL(*), IOPT(*)
      REAL HMINFX
      REAL OPT(*)
C MCDEF  VALUE OF "MC" IF "DEFOPT" PARAM. HAS BEEN CHOSEN EQUAL TO 1   I
C HMINFX MINIMAL INTERVAL LENGTH FOR FIXED STEPSIZE STRATEGY           I
C IERROR ENTRY: 0 OR 2                                                 I
C        EXIT:  UNCHANGED: OK                                          I
C               2: INPUT ERRORS                                        I
C              -2: INPUT ERRORS THAT PREVENT FURTHER CHECKING          I
C                                                                      I
C INVOKED BY: CHKINI                                                   I
C ----------                                                           I
C                                                                      I
C LOCAL VARIABLES:                                                     I
C ---------------                                                      I
      CHARACTER*10 VAROUT
      LOGICAL MINIER
C MINIER TRUE IF ERROR HAS BEEN FOUND THAT PREVENT FURTHER CHECKING    I
C                                                                      I
C ---------------------------------------------------------------------I
C
      INTEGER IOPT1,IOPT1C,IOPT1M, IOPT8,IOPT8C,IOPT8M,
     +        IOPT9,IOPT9G,IOPT9P,IOPT9T,IOPT9U
C
C
C CHECK CONTROL VECTOR
      IF (CNTRL(1) .LT. 0 .OR. CNTRL(1) .GT. 4) THEN
         WRITE(VAROUT,'(I10)') CNTRL(1)
         CALL ERRMSG ('INPUT PARAMETER CNTRL(1) ='//VAROUT)
         CALL ERRMSG ('   RE-ENTRY CONTROL, SHOULD BE: '//
     +                '0 <= CNTRL(1) <= 4')
         IERROR = -2
         RETURN
      ENDIF
C
C IF RE-ENTRY WITH SAME OPTIONS, CHECK FINISHED
      IF (CNTRL(1) .GE. 3) RETURN
C
C
      MINIER = .FALSE.
C
C
C CHECK IOPT VECTOR (INDEPENDENT PART)
      IF (IOPT(1) .LT. 0) THEN
         IERROR = -2
      ELSE
         IOPT1  = IOPT(1)
         IF (IOPT1 .EQ. 0) THEN
            IOPT1  = MCDEF
         ELSE
            IOPT1M = IOPT1/10
            IOPT1C = IOPT1-10*IOPT1M
            IF (IOPT1C .LT. 1 .OR. IOPT1C .GT. 4) THEN
               IERROR = -2
            ELSE IF (IOPT1M .LT. 2 .OR.
     +               (IOPT1M .LT. 3 .AND. IOPT1C .EQ. 2)) THEN
               IERROR = -2
            ENDIF
         ENDIF
      ENDIF
      IF (IERROR .LT. 0) THEN
         WRITE(VAROUT,'(I10)') IOPT(1)
         CALL ERRMSG ('INPUT PARAMETER IOPT(1) ='//VAROUT)
         CALL ERRMSG ('   METHOD DESCRIPTOR, SHOULD BE: '//
     +                '"MC" WITH 1 <= "C" <= 4 AND '//
     +                '"M" >= 2 (OR 3 IF "C"=2)')
         IERROR = -IERROR
         MINIER = .TRUE.
      ENDIF
      IF (IOPT(2) .NE. 0 .AND. IOPT(2) .NE. 1) THEN
         WRITE(VAROUT,'(I10)') IOPT(2)
         CALL ERRMSG ('INPUT PARAMETER IOPT(2) ='//VAROUT)
         CALL ERRMSG ('   VARIABLE / FIXED STEPSIZE, SHOULD BE: '//
     +                'IOPT(2)=0 OR IOPT(2)=1')
         IERROR = 2
      ENDIF
      IF (IOPT(3) .NE. 0 .AND. IOPT(3) .NE. 1) THEN
         WRITE(VAROUT,'(I10)') IOPT(3)
         CALL ERRMSG ('INPUT PARAMETER IOPT(3) ='//VAROUT)
         CALL ERRMSG ('   GLOBAL ERROR IN "TE"?, SHOULD BE: '//
     +                'IOPT(3)=0 OR IOPT(3)=1')
         IERROR = 2
      ENDIF
      IF (IOPT(4) .LT. 0 .OR. IOPT(4) .GT. 2) THEN
         WRITE(VAROUT,'(I10)') IOPT(4)
         CALL ERRMSG ('INPUT PARAMETER IOPT(4) ='//VAROUT)
         CALL ERRMSG ('   ERROR WEIGHT INDICATOR, SHOULD BE: '//
     +                '0 <= IOPT(4) <= 2')
         IERROR = 2
      ENDIF
      IF (IOPT(5) .NE. 0 .AND. IOPT(5) .NE. 1 .AND. IOPT(5) .NE. 2 .AND.
     +    IOPT(5) .NE. 11 .AND. IOPT(5) .NE. 12 .AND.
     +    IOPT(5) .NE. 21 .AND. IOPT(5) .NE. 22) THEN
         WRITE(VAROUT,'(I10)') IOPT(5)
         CALL ERRMSG ('INPUT PARAMETER IOPT(5) ='//VAROUT)
         CALL ERRMSG ('   ERROR WEIGHT INDICATOR, SHOULD BE: '//
     +                'IOPT(5) = 0 OR ?1 OR ?2, WITH ? = 1 OR 2')
         IERROR = 2
      ENDIF
      IF (IOPT(6) .LT. 0) THEN
         WRITE(VAROUT,'(I10)') IOPT(6)
         CALL ERRMSG ('INPUT PARAMETER IOPT(6) ='//VAROUT)
         CALL ERRMSG ('   MAX. # KERNEL EVAL., SHOULD BE: '//
     +                'IOPT(6) >= 0')
         IERROR = 2
      ENDIF
      IF (IOPT(7) .LT. 0) THEN
         WRITE(VAROUT,'(I10)') IOPT(7)
         CALL ERRMSG ('INPUT PARAMETER IOPT(7) ='//VAROUT)
         CALL ERRMSG ('   MAX. # CPU_SECONDS ALLOWED, SHOULD BE: '//
     +                'IOPT(7) >= 0')
         IERROR = 2
      ENDIF
      IF (IOPT(2) .EQ. 0 .OR. IOPT(3) .EQ. 0) THEN
C REF. SOL. REQUIRED
         IF (IOPT(8) .LT. 0) THEN
            IERROR = -2
         ELSE
            IOPT8  = IOPT(8)
            IF (IOPT8 .EQ. 0) THEN
               IOPT8  = MCDEF
               IOPT8C = MOD(MCDEF,10)
            ELSE
               IOPT8M = IOPT8/10
               IOPT8C = IOPT8-10*IOPT8M
               IF (IOPT8C .LT. 1 .OR. IOPT8C .GT. 4) THEN
                  IERROR = -2
               ELSE IF (IOPT8M .LT. 2 .OR.
     +                  (IOPT8M .LT. 3 .AND. IOPT8C .EQ. 2)) THEN
                  IERROR = -2
               ENDIF
            ENDIF
         ENDIF
         IF (IERROR .LT. 0) THEN
            WRITE(VAROUT,'(I10)') IOPT8
            CALL ERRMSG ('INPUT PARAMETER IOPT(8) ='//VAROUT)
            CALL ERRMSG ('   METHOD DESCRIPTOR REF.SOL., SHOULD BE: '//
     +                   '"MC" WITH 1 <= "C" <= 4 AND '//
     +                   '"M" >= 2 (OR 3 IF "C"=2)')
            IERROR = -IERROR
            MINIER = .TRUE.
         ENDIF
      ENDIF
*
C
C CHECK OPT VECTOR
      IF (IOPT(2) .EQ. 1) THEN
C   CONSTANT STEPSIZES
         IF (OPT(1) .LE. HMINFX) THEN
            WRITE(VAROUT,'(E10.1)') OPT(1)
            CALL ERRMSG ('CHOSEN FIXED STEPSIZE TOO SMALL, H ='//VAROUT)
            CALL ERRMSG ('   SHOULD BE AT LEAST  MAX(SUNFLO,!T!.SRELPR)'
     +                   //' TO MAKE ANY ADVANCE AT ALL')
            IERROR = 2
            MINIER = .TRUE.
         ENDIF
      ELSE IF (IOPT(2) .EQ. 0) THEN
C   VARIABLE STEPSIZES
         IF (OPT(1) .LT. 0.0) THEN
            WRITE(VAROUT,'(E10.1)') OPT(1)
            CALL ERRMSG ('INPUT PARAMETER OPT(1) ='//VAROUT)
            CALL ERRMSG ('   INITIAL GUESS FOR STEPSIZE, SHOULD BE: '//
     +                   'OPT(1) >= 0.0')
            IERROR = 2
         ENDIF
         IF (OPT(2) .LT. 0.0) THEN
            WRITE(VAROUT,'(E10.1)') OPT(2)
            CALL ERRMSG ('INPUT PARAMETER OPT(2) ='//VAROUT)
            CALL ERRMSG ('   MIN. STEPSIZE, SHOULD BE: '//
     +                   'OPT(2) >= 0.0')
            IERROR = 2
         ENDIF
         IF (OPT(3) .LT. 0.0) THEN
            WRITE(VAROUT,'(E10.1)') OPT(3)
            CALL ERRMSG ('INPUT PARAMETER OPT(3) ='//VAROUT)
            CALL ERRMSG ('   MAX. STEPSIZE, SHOULD BE: '//
     +                   'OPT(3) >= 0.0')
            IERROR = 2
         ENDIF
         IF (OPT(4) .LT. 0.0) THEN
            WRITE(VAROUT,'(E10.1)') OPT(4)
            CALL ERRMSG ('INPUT PARAMETER OPT(4) ='//VAROUT)
            CALL ERRMSG ('   INTERVAL LENGTH UNIFORM LOCAL ERROR'//
     +                   ' CONTROL, SHOULD BE: '//'OPT(4) >= 0.0')
            IERROR = 2
         ENDIF
      ENDIF
C
C
      IF (MINIER) THEN
         IERROR = -IERROR
         RETURN
      ELSE IF (IOPT(2) .EQ. 0) THEN
         IOPT9  = IOPT(9)
         IF (IOPT8C .EQ. 1) THEN
            IF (IOPT8 .NE. IOPT1) THEN
               CALL ERRMSG ('INPUT PARAMETERS IOPT(1) AND IOPT(8) '//
     +                      'ARE INCONSISTENT')
               CALL ERRMSG ('ITERATED COLLOCATION CAN ONLY BE USED '//
     +                      'IF APPROX. METHOD IS GAUSS AND')
               CALL ERRMSG ('IF THE SAME # OF COL.PARS. IS USED FOR '//
     +                      'THE REF. SOL.')
               IERROR = -2
               RETURN
            ENDIF
*
            IOPT9P = IOPT9/10
            IOPT9T = IOPT9-10*IOPT9P
            IF (IOPT9P.LT.0 .OR. IOPT9P.GT.2 .OR.
     +          IOPT9T.LT.0 .OR. IOPT9T.GT.1) THEN
               WRITE(VAROUT,'(I10)') IOPT9
               CALL ERRMSG ('INPUT PARAMETER IOPT(9) ='//VAROUT)
               CALL ERRMSG ('   STEPSIZE STRATEGY CONTROL, SHOULD BE:'//
     +                      '"PT" WITH "P" 0,1 OR 2 AND "T" 0 OR 1')
               IERROR = 2
            ELSE IF (IOPT9P .LE. 1 .AND. OPT(3) .GT. 1.0) THEN
               CALL ERRMSG ('INPUT PARAMETERS IOPT(9) AND OPT(3) '//
     +                      'ARE INCONSISTENT')
               CALL ERRMSG ('MAX. STEPSIZE SHOULD BE <= 1.0 '//
     +                      'TO DETECT POLYNOMIAL SOLUTION')
               IERROR = 2
            ENDIF
         ELSE
            IOPT9P = IOPT9/1000
            IOPT9  = IOPT9-1000*IOPT9P
            IOPT9G = IOPT9/100
            IOPT9  = IOPT9-100*IOPT9G
            IOPT9U = IOPT9/10
            IOPT9T = IOPT9-10*IOPT9U
            IF (IOPT9P.LT.0 .OR. IOPT9P.GT.2 .OR.
     +          IOPT9G.LT.0 .OR. IOPT9G.GT.1 .OR.
     +          IOPT9U.LT.0 .OR. IOPT9U.GT.1 .OR.
     +          IOPT9T.LT.0 .OR. IOPT9T.GT.1) THEN
               WRITE(VAROUT,'(I10)') IOPT9
               CALL ERRMSG ('INPUT PARAMETER IOPT(9) ='//VAROUT)
               CALL ERRMSG ('   STEPSIZE STRATEGY CONTROL, SHOULD BE:'//
     +                      '"PGUT" WITH "P" 0, 1 OR 2'//
     +                      ' AND WITH "G", "U" AND "T" 0 OR 1')
               IERROR = 2
            ENDIF
         ENDIF
      ENDIF
      RETURN
      END
      SUBROUTINE CHKREC (IOPT, MCDEF, IERROR)
C
C ---------------------------------------------------------------------I
C PURPOSE: IN CASE OF RE-ENTRY WITH NEW OPTION VECTORS CHECK IF NEW    I
C -------  OPTIONS ARE CONSISTENT WITH THOSE IN THE PREVIOUS CALL.     I
C                                                                      I
C COMMON VARIABLES:                                                    I
C ----------------                                                     I
      INTEGER METH, M, S, L, ORDER, ORDERQ, METHR, MR, SR, LR, ORDERR,
     +        ERRWGT, NHFAIL, NERR, NWIR, NSAV,
     +        MAXNC, MAXKEV, MAXCPS, N, NCIT, NKEV, NCPS
      COMMON /COLCMI/ METH, M, S, L, ORDER, ORDERQ,
     +                METHR, MR, SR, LR, ORDERR,
     +                ERRWGT, NHFAIL,
     +                NERR, NWIR, NSAV,
     +                MAXNC, MAXKEV, MAXCPS,
     +                N, NCIT, NKEV, NCPS
*
      LOGICAL VS, GSSCKM, ESCGSS, GEC, ULEC, RLXTOL, GEETE,
     +        FUNCIT, NEWTON
      COMMON /COLCML/ VS, GSSCKM, ESCGSS, GEC, ULEC, RLXTOL, GEETE,
     +                FUNCIT, NEWTON
*
      SAVE /COLCMI/, /COLCML/
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER MCDEF, IERROR
      INTEGER IOPT(*)
C MCDEF  VALUE OF "MC" IF "DEFOPT" PARAM. IS CHOSEN EQUAL TO 1         I
C                                                                      I
C INVOKED BY: CHKINI                                                   I
C ----------                                                           I
C                                                                      I
C CHANGES IN COMMON VARIABLES: NONE                                    I
C ---------------------------                                          I
C                                                                      I
C LOCAL VARIABLES:                                                     I
C ---------------                                                      I
      CHARACTER*20 VAROUT
C                                                                      I
C ---------------------------------------------------------------------I
C
      INTEGER MCN, MCO, MCRN, MCRO
      LOGICAL GECN
C
C
C   ON RE-ENTRY COLL.METHOD AND # COLL.PARS SHOULD BE THE SAME AS IN
C      PREVIOUS CALL OF COLVI2
      MCO    = 10*M+METH
      MCN    = IOPT(1)
      IF (MCN .EQ. 0) MCN = MCDEF
      IF (MCN .NE. MCO) THEN
         WRITE(VAROUT,'(I10)') IOPT(1)
         CALL ERRMSG ('INPUT PARAMETER IOPT(1) ='//VAROUT)
         CALL ERRMSG ('   APPROX. METHOD, SHOULD NOT BE'//
     +                ' CHANGED ON RE-ENTRY')
         IERROR = -2
      ENDIF
      IF (IOPT(2) .EQ. 0) THEN
         MCRO = 10*MR+METHR
         MCRN = IOPT(8)
         IF (MCRN .EQ. 0) MCRN = MCDEF
         GECN = .TRUE.
         IF (MOD(MCRN,10) .NE. 1) GECN = MOD(IOPT(9)/100,10) .EQ. 0
         IF (GECN .AND. .NOT.GEC) THEN
            CALL ERRMSG ('INPUT PARAMETER IOPT(8) INCONSISTENT '//
     +                   'WITH PREVIOUS CALL OF COLVI2')
            CALL ERRMSG ('IMPOSSIBLE TO CHANGE FROM LOCAL TO '//
     +                   'GLOBAL ERROR CONTROL')
            IERROR = -2
         ENDIF
         IF (GECN .AND. MCRN .NE. MCRO) THEN
            WRITE(VAROUT,'(I10)') IOPT(8)
            CALL ERRMSG ('INPUT PARAMETER IOPT(8) ='//VAROUT)
            CALL ERRMSG ('   METHOD TO APPROX. REF.SOL., SHOULD NOT'//
     +                   ' BE CHANGED ON RE-ENTRY')
            IERROR = -2
         ENDIF
      ENDIF
*
      RETURN
      END
      SUBROUTINE CHKWKA (IW, TN, TE, HFX, IWCONS, IWSTEP, IERROR)
C
C ---------------------------------------------------------------------I
C PURPOSE: CHECK, AS FAR AS POSSIBLE, IF DIMENSION OF "WKAREA" IS      I
C -------  SUFFICIENT.                                                 I
C                                                                      I
C COMMON VARIABLES:                                                    I
C ----------------                                                     I
      INTEGER METH, M, S, L, ORDER, ORDERQ, METHR, MR, SR, LR, ORDERR,
     +        ERRWGT, NHFAIL, NERR, NWIR, NSAV,
     +        MAXNC, MAXKEV, MAXCPS, N, NCIT, NKEV, NCPS
      COMMON /COLCMI/ METH, M, S, L, ORDER, ORDERQ,
     +                METHR, MR, SR, LR, ORDERR,
     +                ERRWGT, NHFAIL,
     +                NERR, NWIR, NSAV,
     +                MAXNC, MAXKEV, MAXCPS,
     +                N, NCIT, NKEV, NCPS
*
      LOGICAL VS, GSSCKM, ESCGSS, GEC, ULEC, RLXTOL, GEETE,
     +        FUNCIT, NEWTON
      COMMON /COLCML/ VS, GSSCKM, ESCGSS, GEC, ULEC, RLXTOL, GEETE,
     +                FUNCIT, NEWTON
*
      SAVE /COLCMI/, /COLCML/
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER IW, IWCONS, IWSTEP, IERROR
      REAL TN, TE, HFX
C IW     DIMENSION WORKING STORAGE FOR "COLVI2" AS DECLARED BY USER.   I
C TN     LEFT POINT OF CURR.INT.-I ONLY USED                           I
C TE     UPPERBOUND INTEGRATION  I     IN CASE OF                      I
C HFX    CHOSEN FIXED STEPSIZE   I  CONSTANT STEPSIZES                 I
C IWCONS VARIABLES TO COMPUTE    I                                     I
C IWSTEP REQUIRED DIM. WKAREA   -I                                     I
C IERROR ENTRY: 0 OR 2                                                 I
C        EXIT:  UNCHANGED: OK                                          I
C               2: INPUT ERROR                                         I
C                                                                      I
C INVOKED BY: CHKINI                                                   I
C ----------                                                           I
C                                                                      I
C CHANGES IN COMMON VARIABLES: NONE                                    I
C ---------------------------                                          I
C                                                                      I
C LOCAL VARIABLES:                                                     I
C ---------------                                                      I
      CHARACTER*10 VAROUT
      INTEGER NC
C NC     # INTERVALS IN CASE OF CONSTANT STEPSIZES                     I
C                                                                      I
C ---------------------------------------------------------------------I
C
      REAL R
C
      IF (.NOT. VS) THEN
C    CHECK DIMENSION WORKING STORAGE FOR FIXED STEPSIZE
         R  = (TE-TN)/HFX
         NC = INT(R)
         IF (R-NC .GT. 0.0) NC = NC+1
         NC = NC+N
         IF (MAXNC .LT. NC) THEN
            WRITE(VAROUT,'(I10)') IW
            CALL ERRMSG ('INPUT PARAMETER IW ='//VAROUT)
            WRITE (VAROUT,'(I10)') NC*IWSTEP+IWCONS
            CALL ERRMSG ('   DIMENSION WORKING STORAGE TOO SMALL,'//
     +                   'SHOULD BE'//VAROUT)
            IERROR = 2
         ENDIF
      ELSE IF (MAXNC .LE. N) THEN
C CHECK DIMENSION WORK AREA AS FAR AS POSSIBLE
         WRITE(VAROUT,'(I10)') IW
         CALL ERRMSG ('INPUT PARAMETER IW ='//VAROUT)
         CALL ERRMSG ('   DIMENSION WORKING STORAGE TOO SMALL'//
     +                ' TO TAKE EVEN ONE STEP')
         IERROR = 2
      ENDIF
*
      RETURN
      END
      SUBROUTINE ERRMSG (STRING)
C
C ---------------------------------------------------------------------I
C PURPOSE: WRITE ERROR MESSAGE "STRING" TO FILE WITH LOGICAL UNIT      I
C -------  NUMBER "NERR"                                               I
C                                                                      I
C COMMON VARIABLES:                                                    I
C ----------------                                                     I
      INTEGER METH, M, S, L, ORDER, ORDERQ, METHR, MR, SR, LR, ORDERR,
     +        ERRWGT, NHFAIL, NERR, NWIR, NSAV,
     +        MAXNC, MAXKEV, MAXCPS, N, NCIT, NKEV, NCPS
      COMMON /COLCMI/ METH, M, S, L, ORDER, ORDERQ,
     +                METHR, MR, SR, LR, ORDERR,
     +                ERRWGT, NHFAIL,
     +                NERR, NWIR, NSAV,
     +                MAXNC, MAXKEV, MAXCPS,
     +                N, NCIT, NKEV, NCPS
*
      SAVE /COLCMI/
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      CHARACTER*(*) STRING
C                                                                      I
C INVOKED BY: COLVI2, SOLVI2, SGEVI2, SOLSYS, YPOLM, ESCRGS, GAUSSC,   I
C ----------  LOBATC, RADAUC, CHKFIL, CHKPTO, CHKOPT, CHKREC, CHKWKA,  I
C             SAVALL, RELOAD, DECLUF, ZERPOL                           I
C                                                                      I
C CHANGES IN COMMON VARIABLES: NONE                                    I
C ---------------------------                                          I
C                                                                      I
C ---------------------------------------------------------------------I
C
      IF (NERR .NE. 0) THEN
         WRITE(NERR,'(A16,A)') ' ERROR COLVI2...', STRING
      ELSE
         PRINT '(A16,A)',  ' ERROR COLVI2...', STRING
      ENDIF
*
      RETURN
      END
      SUBROUTINE WRIRES (TN, HN, YNP1, UNP1, NEQN, Y)
C
C ---------------------------------------------------------------------I
C PURPOSE: WRITE RESULTS IN INTERVAL [TN,TN+HN] TO FILE WITH LOG.UN.NR.I
C -------  "NWIR". COMPARE RESULTS TO EXACT SOLUTION GIVEN BY THE      I
C VECTOR "Y" RETURNED BY THE CALL "YEXACT(TN,Y)".                      I
C                                                                      I
C COMMON VARIABLES:                                                    I
C ----------------                                                     I
      INTEGER METH, M, S, L, ORDER, ORDERQ, METHR, MR, SR, LR, ORDERR,
     +        ERRWGT, NHFAIL, NERR, NWIR, NSAV,
     +        MAXNC, MAXKEV, MAXCPS, N, NCIT, NKEV, NCPS
      COMMON /COLCMI/ METH, M, S, L, ORDER, ORDERQ,
     +                METHR, MR, SR, LR, ORDERR,
     +                ERRWGT, NHFAIL,
     +                NERR, NWIR, NSAV,
     +                MAXNC, MAXKEV, MAXCPS,
     +                N, NCIT, NKEV, NCPS
*
      INTEGER IBETA, IOVFLO, NSDEC, IMXLUN
      COMMON /COLMCI/ IBETA, IOVFLO, NSDEC, IMXLUN
*
      SAVE /COLCMI/, /COLMCI/
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER NEQN
      REAL TN, HN
      REAL YNP1(NEQN), UNP1(NEQN), Y(NEQN)
C                                                                      I
C INVOKED BY: SOLVI2                                                   I
C ----------                                                           I
C                                                                      I
C CHANGES IN COMMON VARIABLES: NONE                                    I
C ---------------------------                                          I
C                                                                      I
C ---------------------------------------------------------------------I
C
      INTEGER K, NOLD
      LOGICAL FIRST
      SAVE FIRST, NOLD
      EXTERNAL YEXACT
*
      DATA FIRST /.TRUE./
*
      IF (FIRST) THEN
         FIRST = .FALSE.
         NOLD  = IOVFLO
      ENDIF
*
      IF (N .LT. NOLD) WRITE(NWIR,1000)
      NOLD = N
*
      CALL YEXACT(TN+HN,Y)
      DO 10 K = 1, NEQN
         WRITE(NWIR,1001) N, TN, HN, Y(K), Y(K)-UNP1(K), YNP1(K)-UNP1(K)
   10 CONTINUE
*
      RETURN
 1000 FORMAT('-',T4,'N',T10,'TN',T25,'HN',T40,'Y(TN+HN)',
     +           T57,'YEX-U_N+1',T70,'UR_N+1-U_N+1')
 1001 FORMAT(' ',I4,F9.5,F18.14,E22.14,2E13.5)
      END
      SUBROUTINE ADDABM (A, IA, IO, JO, N, S, B, IB)
      INTEGER IA, IO, JO, N, IB
      REAL S
      REAL A(IA,IA), B(IB,IB)
*
      INTEGER I, J
*
      DO 10 J = 1, N
         DO 20 I = 1, N
            A(IO+I,JO+J) = A(IO+I,JO+J) + S*B(I,J)
   20    CONTINUE
   10 CONTINUE
*
      RETURN
      END
      SUBROUTINE ADDABV (V, N, S, W)
      INTEGER N
      REAL S
      REAL V(*), W(*)
*
      INTEGER I
*
      DO 10 I = 1, N
         V(I) = V(I) + S*W(I)
   10 CONTINUE
*
      RETURN
      END
      SUBROUTINE ADDV (V, N, S1, W1, S2, W2)
      INTEGER N
      REAL S1, S2
      REAL V(*), W1(*), W2(*)
*
      INTEGER I
*
      DO 10 I = 1, N
         V(I) = S1*W1(I) + S2*W2(I)
   10 CONTINUE
*
      RETURN
      END
      SUBROUTINE COPYV (V, N, W)
      INTEGER N
      REAL V(*), W(*)
*
      INTEGER I
*
      DO 10 I = 1, N
         W(I) = V(I)
   10 CONTINUE
*
      RETURN
      END
      SUBROUTINE UNITM (A, N)
      INTEGER N
      REAL A(N,N)
*
      INTEGER I, J
*
      DO 10 J = 1, N
         DO 20 I = 1, N
            A(I,J) = 0.0
   20    CONTINUE
         A(J,J) = 1.0
   10 CONTINUE
*
      RETURN
      END
      SUBROUTINE ZEROV (V, N)
      INTEGER N
      REAL V(*)
*
      INTEGER I
*
      DO 10 I = 1, N
         V(I) = 0.0
   10 CONTINUE
*
      RETURN
      END
      SUBROUTINE SAVALL (WKAREA,IW, DEFOPT, IOPT,OPT, TE, TN)
*
      INTEGER NCMI, NCML, NCMR, NCMIX
      PARAMETER (NCMI = 23, NCML = 9, NCMR = 6, NCMIX = 21)
C
C ---------------------------------------------------------------------I
C PURPOSE: SAVE ALL COMMON VARIABLES, WORKING STORAGE AND OPTION       I
C -------  VECTORS ON A SEQUENTIAL UNFORMATTED FILE NAMED "COLSAV".    I
C NOTE: SOME COMMON VARS ARE OBTAINED BY THEIR NUMBER IN THE COMMON   !!
C !!!!  BLOCK; CHECK IF THIS IS STILL CORRECT WHEN CHANGING COMMONS   !!
C                                                                      I
C COMMON VARIABLES:                                                    I
C ----------------                                                     I
      INTEGER CMIVAR
      COMMON /COLCMI/ CMIVAR(NCMI)
      LOGICAL CMLVAR
      COMMON /COLCML/ CMLVAR(NCML)
      REAL CMRVAR
      COMMON /COLCMR/ CMRVAR(NCMR)
      INTEGER CMINDX
      COMMON /COLIXW/ CMINDX(NCMIX)
      SAVE /COLCMI/, /COLCML/, /COLCMR/, /COLIXW/
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER IW, DEFOPT
      INTEGER IOPT(*)
      REAL TE, TN
      REAL WKAREA(IW), OPT(*)
C                                                                      I
C INVOKED BY: COLVI2                                                   I
C ----------                                                           I
C                                                                      I
C CHANGES IN COMMON VARIABLES: NONE                                    I
C ---------------------------                                          I
C                                                                      I
C !!!!!!!!! IMPORTANT !!!!!!!!! IMPORTANT !!!!!!!!! IMPORTANT !!!!!!!!!!
C                                                                     !!
C MACHINE DEPENDENCIES:                                               !!
C --------------------                                                !!
C IF "COLSAV" IS NOT A LEGITIMATE FILE NAME CHANGE THE PARAMETER      !!
C STATEMENT BELOW.                                                    !!
C                                                                     !!
C IF THE MAXIMUM RECORD LENGTH IN WORDS OF A FILE OPENED FOR          !!
C UNFORMATTED I/O AND SEQUENTIAL ACCESS IS SMALLER THAN "IW"+13 THE   !!
C IOLISTS IN THIS SUBROUTINE AND IN SUBROUTINE "RELOAD" SHOULD BE     !!
C SPLIT INTO SECTIONS OF MAX. RECORD LENGTH.                          !!
C                                                                     !!
C !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
C                                                                      I
C ---------------------------------------------------------------------I
C CONSTANTS:                                                           I
C --------                                                             I
      CHARACTER*6 SAVFIL
      PARAMETER (SAVFIL = 'COLSAV')
C                                                                      I
C LOCAL VARIABLES:                                                     I
C ---------------                                                      I
      CHARACTER*10 VAROUT
      INTEGER NSAV
      LOGICAL GEETE, ULEC, VS
C                                                                      I
C ---------------------------------------------------------------------I
C
      INTEGER I, IOS, NIOPT, NOPT
*
      NSAV   = CMIVAR(16)
      GEETE  = CMLVAR(7)
      ULEC   = CMLVAR(5)
      VS     = CMLVAR(1)
      IF (DEFOPT .EQ. 0) THEN
         NIOPT = 7
         IF (GEETE) NIOPT = 8
         IF (VS) NIOPT = 9
         NOPT = 1
         IF (VS) NOPT = 3
         IF (ULEC) NOPT = 4
      ENDIF
      OPEN(UNIT=NSAV, IOSTAT=IOS, ERR=900, FILE=SAVFIL,
     +     STATUS='UNKNOWN', ACCESS='SEQUENTIAL', FORM='UNFORMATTED')
*
C REWIND "COLSAV" IN CASE IT ALREADY EXISTED
      REWIND(UNIT=NSAV)
*
C WRITE ONE RECORD WITH FIXED LENGTH INFO
      WRITE(NSAV) IW, DEFOPT, NIOPT, NOPT,
     +            (CMIVAR(I), I=1,NCMI), (CMLVAR(I), I=1,NCML),
     +            (CMRVAR(I), I=1,NCMR), (CMINDX(I), I=1,NCMIX), TE, TN
C WRITE ONE RECORD WITH OPTION VECTORS AND WORKING STORAGE
      IF (DEFOPT .EQ. 0) THEN
         WRITE(NSAV) (IOPT(I), I=1,NIOPT), (OPT(I), I=1,NOPT),
     +               (WKAREA(I), I=1,IW)
      ELSE
         WRITE(NSAV) (WKAREA(I), I=1,IW)
      ENDIF
*
      CLOSE(UNIT=NSAV, STATUS='KEEP')
      RETURN
*
C FILE OPEN ERRORS, SHOULD NOT BE POSSIBLE
  900 WRITE(VAROUT,'(I10)') IOS
      CALL ERRMSG ('CANNOT OPEN FILE TO SAVE VARIABLES, ????????, '//
     +             'IO STATUS ='//VAROUT)
      RETURN
      END
      SUBROUTINE RELOAD
     +   (NSAV, WKAREA,IW, DEFOPT,IOPT,OPT, TE, TN, IERROR)
*
      INTEGER NCMI, NCML, NCMR, NCMIX
      PARAMETER (NCMI = 23, NCML = 9, NCMR = 6, NCMIX = 21)
C
C ---------------------------------------------------------------------I
C PURPOSE: RELOAD ALL COMMON VARIABLES, WORKING STORAGE AND OPTION     I
C -------  VECTORS FROM THE SEQUENTIAL UNFORMATTED FILE NAMED "COLSAV".I
C CHECK FILE STATUS "COLSAV" AND SIZE WORKING STORAGE.                 I
C NOTE: IF CNTRL(1)=2 (NEW OPTION VECTORS) OPT SHARES MEMORY LOCATIONS I
C ----  WITH "WKAREA".                                                 I
C                                                                      I
C COMMON VARIABLES:                                                    I
C ----------------                                                     I
      INTEGER CMIVAR
      COMMON /COLCMI/ CMIVAR(NCMI)
      LOGICAL CMLVAR
      COMMON /COLCML/ CMLVAR(NCML)
      REAL CMRVAR
      COMMON /COLCMR/ CMRVAR(NCMR)
      INTEGER CMINDX
      COMMON /COLIXW/ CMINDX(NCMIX)
      SAVE /COLCMI/, /COLCML/, /COLCMR/, /COLIXW/
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER NSAV, IW, DEFOPT, IERROR
      INTEGER IOPT(*)
      REAL TE, TN
      REAL WKAREA(IW), OPT(*)
C IERROR ENTRY: 0 OR 2                                                 I
C        EXIT:  UNCHANGED: NO ERROR                                    I
C              -2: RELOAD ERROR                                        I
C                                                                      I
C INVOKED BY: CHKINI                                                   I
C ----------                                                           I
C                                                                      I
C CHANGES IN COMMON VARIABLES: NONE                                    I
C ---------------------------                                          I
C                                                                      I
C !!!!!!!!! IMPORTANT !!!!!!!!! IMPORTANT !!!!!!!!! IMPORTANT !!!!!!!!!!
C                                                                     !!
C MACHINE DEPENDENCIES:                                               !!
C --------------------                                                !!
C IF "COLSAV" IS NOT A LEGITIMATE FILE NAME CHANGE THE PARAMETER      !!
C STATEMENT BELOW.                                                    !!
C                                                                     !!
C IF THE MAXIMUM RECORD LENGTH IN WORDS OF A FILE OPENED FOR          !!
C UNFORMATTED I/O AND SEQUENTIAL ACCESS IS SMALLER THAN "IW"+13 THE   !!
C IOLISTS IN THIS SUBROUTINE AND IN SUBROUTINE "SAVALL" SHOULD BE     !!
C SPLIT INTO SECTIONS OF MAX. RECORD LENGTH.                          !!
C                                                                     !!
C !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
C                                                                      I
C ---------------------------------------------------------------------I
C CONSTANTS:                                                           I
C ---------                                                            I
      CHARACTER*6 SAVFIL
      PARAMETER (SAVFIL = 'COLSAV')
C                                                                      I
C LOCAL VARIABLES:                                                     I
C ---------------                                                      I
      CHARACTER*10 VAROUT
C                                                                      I
C ---------------------------------------------------------------------I
C
      INTEGER I, IOS, IWOLD, NIOPT, NOPT
      LOGICAL EX
C
C INQUIRE IF "COLSAV" EXISTS, IF NOT GIVE MESSAGE
      INQUIRE (FILE=SAVFIL, IOSTAT=IOS, ERR=900, EXIST = EX)
      IF (.NOT. EX) THEN
         CALL ERRMSG ('FILE "COLSAV" CONTAINING THE VARIABLES TO BE'//
     +                ' RELOADED DOES NOT EXIST')
         IERROR = -2
         RETURN
      ENDIF
C
C OPEN "COLSAV"
      OPEN(UNIT=NSAV, IOSTAT=IOS, ERR=910, FILE='COLSAV',
     +     STATUS='OLD', ACCESS='SEQUENTIAL', FORM='UNFORMATTED')
C
C REWIND "COLSAV"
      REWIND(UNIT=NSAV)
C
C READ ONE RECORD WITH FIXED LENGTH INFO
      READ(NSAV) IWOLD, DEFOPT, NIOPT, NOPT,
     +           (CMIVAR(I), I=1,NCMI), (CMLVAR(I), I=1,NCML),
     +           (CMRVAR(I), I=1,NCMR), (CMINDX(I), I=1,NCMIX), TE, TN
C
C CHECK IF DIMENSION WKAREA LARGE ENOUGH
      IF (IWOLD .GT. IW) THEN
         WRITE(VAROUT,'(I10)') IW
         CALL ERRMSG ('DIMENSION WKAREA ='//VAROUT)
         WRITE(VAROUT,'(I10)') IWOLD
         CALL ERRMSG ('NEEDED TO RELOAD OLD WORKING STORAGE :'//VAROUT)
         CLOSE(UNIT=NSAV)
         IERROR = -2
         RETURN
      ENDIF
C
C READ ONE RECORD WITH OPTION VECTORS AND WORKING STORAGE
      IF (DEFOPT .EQ. 0) THEN
         READ(NSAV) (IOPT(I), I=1,NIOPT), (OPT(I), I=1,NOPT),
     +              (WKAREA(I), I=1,IWOLD)
      ELSE
         READ(NSAV) (WKAREA(I), I=1,IWOLD)
      ENDIF
*
      CLOSE(UNIT=NSAV)
      RETURN
C
C SOME ERROR IN INQUIRE, ????????????
C   WRITE IO STATUS AND RETURN
  900 WRITE(VAROUT,'(I10)') IOS
      CALL ERRMSG ('ERROR IN INQUIRE OF FILE "COLSAV", '//
     +              'IO STATUS ='//VAROUT)
      CALL ERRMSG ('   THIS SHOULD NOT HAPPEN, ERROR IN "RELOAD" ?')
      IERROR = -2
      RETURN
C
C FILE OPEN ERRORS
  910 WRITE(VAROUT,'(I10)') IOS
      CALL ERRMSG ('CANNOT OPEN FILE TO RELOAD VARIABLES, IOSTAT ='//
     +             VAROUT)
      IERROR = -2
      RETURN
*
      END
      INTEGER FUNCTION NCPJOB ()
C
C ---------------------------------------------------------------------I
C PURPOSE: RETURN # CPU-SECONDS USED SINCE BEGINNING OF THIS JOB       I
C -------                                                              I
C                                                                      I
C INVOKED BY: COLVI2, SOLVI2, SGEVI2, CHKINI                           I
C ----------                                                           I
C                                                                      I
C !!!!!!!!! IMPORTANT !!!!!!!!! IMPORTANT !!!!!!!!! IMPORTANT !!!!!!!!!!
C                                                                     !!
C MACHINE DEPENDENCIES:                                               !!
C --------------------                                                !!
C NCPJOB CALLS A REAL FUNCTION "SECOND" THAT IS NOT ANSI STANDARD.    !!
C "SECOND" RETURNS THE CPU-TIME IN SECONDS SINCE THE BEGINNING OF THE !!
C JOB. REPLACE CALL BELOW BY CALL OF APPROPRIATE MACHINE FUNCTION.    !!
C                                                                     !!
C !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
C                                                                      I
C ---------------------------------------------------------------------I
C
      NCPJOB = INT(SECOND())
*
      RETURN
C ------------------- END OF NCPJOB (CYBER) ----------------------------
      END
      INTEGER FUNCTION NCPJOB ()
C
C ---------------------------------------------------------------------I
C PURPOSE: RETURN # CPU-SECONDS USED SINCE BEGINNING OF THIS JOB       I
C -------                                                              I
C                                                                      I
C INVOKED BY: COLVI2, SOLVI2, SGEVI2, CHKINI                           I
C ----------                                                           I
C                                                                      I
C !!!!!!!!! IMPORTANT !!!!!!!!! IMPORTANT !!!!!!!!! IMPORTANT !!!!!!!!!!
C                                                                     !!
C MACHINE DEPENDENCIES:                                               !!
C --------------------                                                !!
C NCPJOB CALLS A REAL FUNCTION "ETIME" THAT IS NOT ANSI STANDARD.     !!
C                                                                     !!
C !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
C                                                                      I
C ---------------------------------------------------------------------I
C
      REAL ETIME
      REAL TARRAY(2)
      EXTERNAL ETIME
*
      NCPJOB = INT(ETIME(TARRAY))
      NCPJOB = TARRAY(1)
*
      RETURN
C ------------------- END OF NCPJOB (VAX) ------------------------------
      END
      SUBROUTINE INICMC
C
C ---------------------------------------------------------------------I
C PURPOSE: INITIALIZE COMMON BLOCKS WITH MACHINE CONSTANTS.            I
C -------                                                              I
C                                                                      I
C COMMON VARIABLES:                                                    I
C ----------------                                                     I
      INTEGER IBETA, IOVFLO, NSDEC, IMXLUN
      COMMON /COLMCI/ IBETA, IOVFLO, NSDEC, IMXLUN
*
      REAL SRELPR, SOVFLO, SUNFLO
      COMMON /COLMCR/ SRELPR, SOVFLO, SUNFLO
*
      SAVE /COLMCI/, /COLMCR/
C                                                                      I
C INVOKED BY: CHKINI                                                   I
C ----------                                                           I
C                                                                      I
C CHANGES IN COMMON VARIABLES:                                         I
C ---------------------------                                          I
C ALL VARIABLES IN THE COMMON BLOCKS /COLMCI/ AND /COLMCR/ ARE         I
C INITIALIZED                                                          I
C                                                                      I
C !!!!!!!!! IMPORTANT !!!!!!!!! IMPORTANT !!!!!!!!! IMPORTANT !!!!!!!!!!
C                                                                     !!
C MACHINE DEPENDENCIES:                                               !!
C --------------------                                                !!
C THE MACHINE CONSTANT "IOVFLO" IS NOT AUTOMATICALLY DETERMINED. THE  !!
C VALUE OF THE LARGEST INTEGER FOR A 32-BIT INTEGER HAS BEEN STORED,  !!
C SINCE THE PACKAGE USES IT ONLY TO HAVE SOME LARGE INTEGER VALUE,    !!
C THIS VALUE CAN ALSO BE USED ON A MACHINE WITH A MUCH LARGER INTEGER !!
C RANGE.                                                              !!
C ALTHOUGH "IMXLUN" IS NO REAL MACHINE CONSTANT IT IS ADDED TO THIS   !!
C LIST, BECAUSE THE COMPILER OF THE CYBER 750 DOES NOT ALLOW A VALUE  !!
C LARGER THAN 999 AS A LOGICAL UNIT NUMBER.                           !!
C                                                                     !!
C !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
C                                                                      I
C ---------------------------------------------------------------------I
C
      INTEGER IEXP,IRND,IT,MACHEP,MAXEXP,MINEXP,NEGEP,NGRD
      REAL EPS,EPSNEG
C
      IOVFLO = 2**30-1+2**30
      IMXLUN = 999
*
      CALL MACHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP, MAXEXP,
     +            EPS,EPSNEG,SUNFLO,SOVFLO)
C
      NSDEC = LOG10(REAL(IBETA)**IT)
*
      SRELPR = MAX(EPSNEG,EPS)
C
      RETURN
C ------------------- END OF INICMC ------------------------------------
      END
      SUBROUTINE DECLUF (A, N, IA, WKAREA, IERROR)
C
C ---------------------------------------------------------------------I
C PURPOSE: DECOMPOSE MATRIX A INTO LU-FORM. STORE LU IN "A".           I
C -------  FOR THE DIMENSION OF "WKAREA" SEE "CHKINI" AND "ESCRGS".    I
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER N, IA, IERROR
      REAL A(IA,*), WKAREA(*)
C                                                                      I
C INVOKED BY: SOLSYS                                                   I
C ----------                                                           I
C                                                                      I
C !!!!!!!!! IMPORTANT !!!!!!!!! IMPORTANT !!!!!!!!! IMPORTANT !!!!!!!!!!
C                                                                     !!
C MACHINE DEPENDENCIES:                                               !!
C --------------------                                                !!
C TO DECOMPOSE MATRIX "A" THE IMSL SUBROUTINE "LUDATF" IS USED.       !!
C TO CHANGE THIS REWRITE THE INDICATED STATEMENTS BELOW.              !!
C                                                                     !!
C !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
C                                                                      I
C ---------------------------------------------------------------------I
C
      REAL D1, D2, WA
C
C !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
C !!  LUDATF IS AN IMSL ROUTINE THAT COMPUTES THE LU-DECOMPOSITION OF !!
C !!  A MATRIX A.                                                     !!
C !!  POSSIBLY NEEDED WORKING STORAGE IN ARRAY WKAREA. SEE ALSO THE   !!
C !!  SUBROUTINE "COLDOC" SUB "DISTRIBUTION WKAREA" AND VARIABLE      !!
C !!  "NWKSYS" IN "CHKINI" AND "ESCRGS".                              !!
C !!                                                                  !!
         CALL LUDATF (A, A, N, IA, 0, D1,D2, WKAREA, WKAREA, WA, IERROR)
         IF (IERROR .NE. 0) GOTO 900
C !!                                                                  !!
C !!  ON EXIT IT IS ASSUMED THAT THE LU-DECOMPOSITION OF "A"          !!
C !!  HAS BEEN STORED IN MATRIX "A" AND THAT THE PERMUTATION MATRIX   !!
C !!  HAS BEEN STORED IN "WKAREA".                                    !!
C !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
C
      RETURN
C
C
C ERROR RETURNS
C
C ERROR WHILE DECOMPOSING MATRIX
  900 CALL ERRMSG ('ERROR WHILE DECOMPOSING A MATRIX WITH'//
     +             ' LUDATF FROM IMSL')
      CALL ERRMSG ('   SEE IMSL MANUAL FOR MEANING OF IERROR VALUE')
      RETURN
      END
      SUBROUTINE SOLLUF (A, N, IA, B, WKAREA)
C
C ---------------------------------------------------------------------I
C PURPOSE: SOLVE A.X = B. IT IS ASSUMED THAT "A" HAS BEEN DECOMPOSED   I
C -------  INTO LU-FORM.                                               I
C FOR THE DIMENSION OF "WKAREA" SEE "CHKINI" AND "ESCRGS".             I
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER N, IA
      REAL A(IA,*), B(*), WKAREA(*)
C                                                                      I
C INVOKED BY: SOLSYS                                                   I
C ----------                                                           I
C                                                                      I
C !!!!!!!!! IMPORTANT !!!!!!!!! IMPORTANT !!!!!!!!! IMPORTANT !!!!!!!!!!
C                                                                     !!
C MACHINE DEPENDENCIES:                                               !!
C --------------------                                                !!
C TO SOLVE THE SYSTEM OF LINEAR EQUATIONS THE IMSL SUBROUTINE "LUELMF"!!
C IS USED. TO CHANGE THIS REWRITE THE INDICATED STATEMENTS BELOW.     !!
C                                                                     !!
C !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
C                                                                      I
C ---------------------------------------------------------------------I
C
C
C !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
C !!  LUELMF IS AN IMSL ROUTINE THAT SOLVES THE LINEAR SYSTEM         !!
C !!           A.X = B                                                !!
C !!  IN THE CALL OF LUELMF VECTOR "X" USES THE SAME STORAGE AS       !!
C !!  VECTOR "B", IT IS ASSUMED THAT A = LU AND THAT WKAREA CONTAINS  !!
C !!  THE PERMUTATION MATRIX AS COMPUTED BY "LUDATF".                 !!
C !!  POSSIBLY NEEDED WORKING STORAGE IN ARRAY WKAREA. SEE ALSO THE   !!
C !!  SUBROUTINE "COLDOC" SUB "DISTRIBUTION WKAREA" AND VARIABLE      !!
C !!  "NWKSYS" IN "CHKINI" AND "ESCRGS".                              !!
C !!                                                                  !!
         CALL LUELMF (A, B, WKAREA, N, IA, B)
C !!                                                                  !!
C !!  ON EXIT IT IS ASSUMED THAT THE SOLUTION OF THE LINEAR SYSTEM    !!
C !!  HAS BEEN STORED IN ARRAY "B".                                   !!
C !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
C
      RETURN
      END
      SUBROUTINE ZERPOL (C, N, S, IERROR)
C
C ---------------------------------------------------------------------I
C PURPOSE: FIND ZEROS OF POLYNOMIAL C(0).Z**N + ... + C(N-1).Z + C(N). I
C -------  SORT (REAL) ZEROS AND STORE THESE IN VECTOR "S".            I
C NB: THE COMPLEX ARRAY Z IS INTERNALLY DECLARED WITH LENGTH 100.      I
C --                                                                   I
C                                                                      I
      REAL SRELPR, SOVFLO, SUNFLO
      COMMON /COLMCR/ SRELPR, SOVFLO, SUNFLO
*
      SAVE /COLMCR/
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------
      INTEGER N, IERROR
      REAL C(0:N), S(N)
C                                                                      I
C INVOKED BY: GAUSSC, LOBATC, RADAUC                                   I
C ----------                                                           I
C                                                                      I
C !!!!!!!!! IMPORTANT !!!!!!!!! IMPORTANT !!!!!!!!! IMPORTANT !!!!!!!!!!
C                                                                     !!
C MACHINE DEPENDENCIES:                                               !!
C --------------------                                                !!
C TO COMPUTE THE ZEROS OF THE POLYNOMIAL THE IMSL SUBROUTINE "ZPOLR"  !!
C IS USED. TO CHANGE THIS REWRITE THE INDICATED STATEMENTS BELOW.     !!
C                                                                     !!
C !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
C                                                                      I
C LOCAL VARIABLES:
C ---------------
      CHARACTER*10 VAROUT
      COMPLEX Z(100)
C
C ---------------------------------------------------------------------I
C
      INTEGER INDEX, J, K
      REAL CZJ, SJ
C
C !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
C !! ZPOLR IS AN IMSL ROUTINE. IF ANOTHER ZERO-FINDER IS DESIRED      !!
C !! CHANGE THE STATEMENTS BELOW. ZPOLR REQUIRES ON ENTRY THE COEFF.  !!
C !! OF THE POL. C(0).Z**N + C(1).Z**(N-1) + .. + C(N-1).Z + C(N)     !!
C !!                                                                  !!
      CALL ZPOLR (C, N, Z, IERROR)
      IF (IERROR .NE. 0) GOTO 900
C !!                                                                  !!
C !! ON EXIT THE COMPLEX VECTOR Z SHOULD CONTAIN REAL ZEROS           !!
C !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
*
C SORT ZEROS AND STORE IN "S"
      DO 10 J = 1, N
         C(J) = REAL(Z(J))
         CZJ   = AIMAG(Z(J))
         IF (ABS(CZJ) .GT. ABS(C(J))*SRELPR) GOTO 910
   10 CONTINUE
*
      DO 20 J = 1, N
         SJ = SOVFLO
         DO 30 K = 1, N
         IF (C(K) .LT. SJ) THEN
            SJ = C(K)
            INDEX = K
         ENDIF
   30    CONTINUE
         S(J) = SJ
         C(INDEX) = SOVFLO
   20 CONTINUE
*
      RETURN
C
C ERROR IN FINDING ZEROS OF POLYNOMIAL
  900 CALL ERRMSG ('ERROR IN ZERO-FINDING PROCESS')
      WRITE(VAROUT,'(I10)') IERROR
      CALL ERRMSG ('   SEE IMSL MANUAL FOR MEANING OF THE RETURNED'//
     +             ' ERROR VALUE:'//VAROUT)
      RETURN
C
C COMPLEX ZERO FOUND
  910 IERROR = 3
      CALL ERRMSG ('COMPLEX ZERO FOUND BY "ZERPOL"')
      RETURN
      END
      SUBROUTINE DECLUF (A, N, IA, P, IERROR)
C
C ---------------------------------------------------------------------I
C PURPOSE: DECOMPOSE MATRIX A INTO LU-FORM USING GAUSSIAN ELIMINATION. I
C -------  STORE LU IN "A".                                            I
C FOR THE DIMENSION OF "WKAREA" SEE "CHKINI" AND "ESCRGS".             I
C                                                                      I
C COMMON VARIABLES:                                                    I
C ----------------                                                     I
      REAL SRELPR, SOVFLO, SUNFLO
      COMMON /COLMCR/ SRELPR, SOVFLO, SUNFLO
      SAVE /COLMCR/
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
        INTEGER N, IA, IERROR
        REAL A(IA,*), P(*)
C P      WORKING STORAGE FOR PIVOT NUMBERS                             I
C IERROR ENTRY: 0                                                      I
C        EXIT:  0: OK                                                  I
C             910: MATRIX "A" (NUMERICALLY) SINGULAR                   I
C                                                                      I
C INVOKED BY: SOLSYS                                                   I
C ----------                                                           I
C                                                                      I
C ---------------------------------------------------------------------I
C
        INTEGER I, K, L, PK
        REAL EPS, PIV, R, S
        REAL V(100)
*
        R = -1.0
        DO 10 I = 1, N
           S = 0.0
           DO 20 L = 1, N
              S = S + A(I,L)*A(I,L)
   20      CONTINUE
           S = SQRT(S)
           IF (S .GT. R) R = S
           V(I) = 1.0/S
   10   CONTINUE
*
        EPS = SRELPR*R
        DO 30 K = 1, N
           R = -1.0
           DO 40 I = K, N
              S = 0.0
              DO 50 L = 1, K-1
                 S = S + A(I,L)*A(L,K)
   50         CONTINUE
              A(I,K) = A(I,K) - S
              S = ABS(A(I,K))*V(I)
              IF (S .GT. R) THEN
                 R = S
                 PK = I
              ENDIF
   40      CONTINUE
*
           P(K) = PK
           V(PK) = V(K)
           PIV = A(PK,K)
           IF (ABS(PIV) .LT. EPS) GOTO 900
           IF (PK .NE. K) THEN
              DO 60 L = 1, N
                 S = A(K,L)
                 A(K,L) = A(PK,L)
                 A(PK,L) = S
   60         CONTINUE
           ENDIF
*
           DO 70 I = K+1, N
              S = 0.0
              DO 80 L = 1, K-1
                 S = S + A(K,L)*A(L,I)
   80         CONTINUE
              A(K,I) = (A(K,I) - S) / PIV
   70      CONTINUE
   30   CONTINUE
*
      RETURN
C
C
C ERROR RETURNS
C
C ERROR WHILE DECOMPOSING MATRIX
  900 IERROR = 910
      CALL ERRMSG ('ERROR WHILE DECOMPOSING A MATRIX, MATRIX IS'//
     +             ' (NUMERICALLY) SINGULAR')
      RETURN
      END
      SUBROUTINE SOLLUF (A, N, IA, B, P)
C
C ---------------------------------------------------------------------I
C PURPOSE: SOLVE A.X = B. IT IS ASSUMED THAT "A" HAS BEEN DECOMPOSED   I
C -------  INTO LU-FORM, AND THAT "P" HOLDS THE PIVOT NUMBERS.         I
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER N, IA
      REAL A(IA,*), B(*), P(*)
C                                                                      I
C INVOKED BY: SOLSYS                                                   I
C ----------                                                           I
C                                                                      I
C ---------------------------------------------------------------------I
C
        INTEGER K, L, PK
        REAL R, S
*
        DO 10 K = 1, N
           R = B(K)
           PK = NINT(P(K))
           S = 0.0
           DO 20 L = 1, K-1
              S = S + A(K,L)*B(L)
   20      CONTINUE
           B(K) = (B(PK) - S) / A(K,K)
           IF (PK .NE. K) B(PK) = R
   10   CONTINUE
        DO 30 K = N, 1, -1
           S = 0.0
           DO 40 L = K+1, N
              S = S + A(K,L)*B(L)
   40      CONTINUE
           B(K) = B(K) - S
   30   CONTINUE
*
      RETURN
      END
      SUBROUTINE ZERPOL (C, N, S, IERROR)
C
C ---------------------------------------------------------------------I
C PURPOSE: FIND ZEROS OF POLYNOMIAL C(0).Z**N + ... + C(N-1).Z + C(N). I
C -------  SORT (REAL) ZEROS AND STORE THESE IN VECTOR "S".            I
C NB: DUE TO INTERNALLY DECLARED ARRAYS NEEDED IN "RPOLY" THE DEGREE   I
C --  OF THE POLYNOMIAL SHOULD BE <=100.                               I
C                                                                      I
      REAL SRELPR, SOVFLO, SUNFLO
      COMMON /COLMCR/ SRELPR, SOVFLO, SUNFLO
*
      SAVE /COLMCR/
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------
      INTEGER N, IERROR
      REAL C(0:N), S(N)
C IERROR ENTRY: 0                                                      I
C        EXIT:  0: OK                                                  I
C               3: COMPLEX ZERO FOUND                                  I
C             950: ERROR RETURN FROM "RPOLY"                           I
C                                                                      I
C INVOKED BY: GAUSSC, LOBATC, RADAUC                                   I
C ----------                                                           I
C                                                                      I
C ---------------------------------------------------------------------I
C
        LOGICAL FAIL
        DOUBLE PRECISION DPC(101), DPZR(100), DPZI(100)
*
      INTEGER INDEX, J, K
      REAL CZJ, SJ
C
C !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
C !! RPOLY IS A ROUTINE FROM ACM TOMS. RPOLY REQUIRES ON ENTRY THE    !!
C !! COEFFICIENTS OF THE POLYNOMIAL                                   !!
C !!     DPC(1).Z**N + DPC(2).Z**(N-1) + .. + DPC(N).Z + DPC(N+1)     !!
C !!                                                                  !!
        DO 1 J = 0, N
           DPC(J+1) = C(J)
    1   CONTINUE
*
      CALL RPOLY (DPC, N, DPZR, DPZI, FAIL)
      IF (FAIL) GOTO 900
C !!                                                                  !!
C !! ON EXIT THE VECTOR DPZR SHOULD CONTAIN THE REAL ZEROS AND        !!
C !! DPZI SHOULD BE ZERO                                              !!
C !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
*
C SORT ZEROS AND STORE IN "S"
      DO 10 J = 1, N
         C(J) = DPZR(J)
         CZJ  = DPZI(J)
         IF (ABS(CZJ) .GT. ABS(C(J))*SRELPR) GOTO 910
   10 CONTINUE
*
      DO 20 J = 1, N
         SJ = SOVFLO
         DO 30 K = 1, N
         IF (C(K) .LT. SJ) THEN
            SJ = C(K)
            INDEX = K
         ENDIF
   30    CONTINUE
         S(J) = SJ
         C(INDEX) = SOVFLO
   20 CONTINUE
*
      RETURN
C
C ERROR IN FINDING ZEROS OF POLYNOMIAL
  900 IERROR = 950
      CALL ERRMSG ('ERROR IN ZERO-FINDING PROCESS')
      CALL ERRMSG ('   SEE DESCRIPTION OF "RPOLY" FOR POSSIBLE REASONS')
      RETURN
C
C COMPLEX ZERO FOUND
  910 IERROR = 3
      CALL ERRMSG ('COMPLEX ZERO FOUND BY "ZERPOL"')
      RETURN
      END
      SUBROUTINE RPOLY(OP, DEGREE, ZEROR, ZEROI,
     * FAIL)
C FINDS THE ZEROS OF A REAL POLYNOMIAL
C OP  - DOUBLE PRECISION VECTOR OF COEFFICIENTS IN
C       ORDER OF DECREASING POWERS.
C DEGREE   - INTEGER DEGREE OF POLYNOMIAL.
C ZEROR, ZEROI - OUTPUT DOUBLE PRECISION VECTORS OF
C                REAL AND IMAGINARY PARTS OF THE
C                ZEROS.
C FAIL  - OUTPUT LOGICAL PARAMETER, TRUE ONLY IF
C         LEADING COEFFICIENT IS ZERO OR IF RPOLY
C         HAS FOUND FEWER THAN DEGREE ZEROS.
C         IN THE LATTER CASE DEGREE IS RESET TO
C         THE NUMBER OF ZEROS FOUND.
C TO CHANGE THE SIZE OF POLYNOMIALS WHICH CAN BE
C SOLVED, RESET THE DIMENSIONS OF THE ARRAYS IN THE
C COMMON AREA AND IN THE FOLLOWING DECLARATIONS.
C THE SUBROUTINE USES SINGLE PRECISION CALCULATIONS
C FOR SCALING, BOUNDS AND ERROR CALCULATIONS. ALL
C CALCULATIONS FOR THE ITERATIONS ARE DONE IN DOUBLE
C PRECISION.
      COMMON /GLOBAL/ P, QP, K, QK, SVK, SR, SI, U,
     * V, A, B, C, D, A1, A2, A3, A6, A7, E, F, G,
     * H, SZR, SZI, LZR, LZI, ETA, ARE, MRE, N, NN
      DOUBLE PRECISION P(101), QP(101), K(101),
     * QK(101), SVK(101), SR, SI, U, V, A, B, C, D,
     * A1, A2, A3, A6, A7, E, F, G, H, SZR, SZI,
     * LZR, LZI
      REAL ETA, ARE, MRE
      INTEGER N, NN
      DOUBLE PRECISION OP(101), TEMP(101),
     * ZEROR(100), ZEROI(100), T, AA, BB, CC, DABS,
     * FACTOR
      REAL PT(101), LO, MAX, MIN, XX, YY, COSR,
     * SINR, XXX, X, SC, BND, XM, FF, DF, DX, INFIN,
     * SMALNO, BASE
      INTEGER DEGREE, CNT, NZ, I, J, JJ, NM1, L
      LOGICAL FAIL, ZEROK
C THE FOLLOWING STATEMENTS SET MACHINE CONSTANTS USED
C IN VARIOUS PARTS OF THE PROGRAM. THE MEANING OF THE
C FOUR CONSTANTS ARE...
C ETA     THE MAXIMUM RELATIVE REPRESENTATION ERROR
C         WHICH CAN BE DESCRIBED AS THE SMALLEST
C         POSITIVE FLOATING POINT NUMBER SUCH THAT
C         1.D0+ETA IS GREATER THAN 1.
C INFINY  THE LARGEST FLOATING-POINT NUMBER.
C SMALNO  THE SMALLEST POSITIVE FLOATING-POINT NUMBER
C         IF THE EXPONENT RANGE DIFFERS IN SINGLE AND
C         DOUBLE PRECISION THEN SMALNO AND INFIN
C         SHOULD INDICATE THE SMALLER RANGE.
C BASE    THE BASE OF THE FLOATING-POINT NUMBER
C         SYSTEM USED.
C THE VALUES BELOW CORRESPOND TO THE BURROUGHS B6700
C     BASE = 8.
C     ETA = .5*BASE**(1-26)
C     INFIN = 4.3E68
C     SMALNO = 1.0E-45
C
C JGB
C     COMMON BLOCKS WITH MACHINE CONSTANTS ADDED TO VALUE
C     BASE, ETA, INFIN AND SMALNO
      INTEGER IBETA, IOVFLO, NSDEC, IMXLUN
      COMMON /COLMCI/ IBETA, IOVFLO, NSDEC, IMXLUN
*
      REAL SRELPR, SOVFLO, SUNFLO
      COMMON /COLMCR/ SRELPR, SOVFLO, SUNFLO
*
      SAVE /COLMCI/, /COLMCR/
C
      BASE = REAL(IBETA)
      ETA = SRELPR
      INFIN = SOVFLO
      SMALNO = SUNFLO
C JGB
C
C ARE AND MRE REFER TO THE UNIT ERROR IN + AND *
C RESPECTIVELY. THEY ARE ASSUMED TO BE THE SAME AS
C ETA.
      ARE = ETA
      MRE = ETA
      LO = SMALNO/ETA
C INITIALIZATION OF CONSTANTS FOR SHIFT ROTATION
      XX = .70710678
      YY = -XX
      COSR = -.069756474
      SINR = .99756405
      FAIL = .FALSE.
      N = DEGREE
      NN = N + 1
C ALGORITHM FAILS IF THE LEADING COEFFICIENT IS ZERO.
      IF (OP(1).NE.0.D0) GO TO 10
      FAIL = .TRUE.
      DEGREE = 0
      RETURN
C REMOVE THE ZEROS AT THE ORIGIN IF ANY
   10 IF (OP(NN).NE.0.0D0) GO TO 20
      J = DEGREE - N + 1
      ZEROR(J) = 0.D0
      ZEROI(J) = 0.D0
      NN = NN - 1
      N = N - 1
      GO TO 10
C MAKE A COPY OF THE COEFFICIENTS
   20 DO 30 I=1,NN
        P(I) = OP(I)
   30 CONTINUE
C START THE ALGORITHM FOR ONE ZERO
   40 IF (N.GT.2) GO TO 60
      IF (N.LT.1) RETURN
C CALCULATE THE FINAL ZERO OR PAIR OF ZEROS
      IF (N.EQ.2) GO TO 50
      ZEROR(DEGREE) = -P(2)/P(1)
      ZEROI(DEGREE) = 0.0D0
      RETURN
   50 CALL QUAD(P(1), P(2), P(3), ZEROR(DEGREE-1),
     * ZEROI(DEGREE-1), ZEROR(DEGREE), ZEROI(DEGREE))
      RETURN
C FIND LARGEST AND SMALLEST MODULI OF COEFFICIENTS.
   60 MAX = 0.
      MIN = INFIN
      DO 70 I=1,NN
        X = ABS(SNGL(P(I)))
        IF (X.GT.MAX) MAX = X
        IF (X.NE.0. .AND. X.LT.MIN) MIN = X
   70 CONTINUE
C SCALE IF THERE ARE LARGE OR VERY SMALL COEFFICIENTS
C COMPUTES A SCALE FACTOR TO MULTIPLY THE
C COEFFICIENTS OF THE POLYNOMIAL. THE SCALING IS DONE
C TO AVOID OVERFLOW AND TO AVOID UNDETECTED UNDERFLOW
C INTERFERING WITH THE CONVERGENCE CRITERION.
C THE FACTOR IS A POWER OF THE BASE
      SC = LO/MIN
      IF (SC.GT.1.0) GO TO 80
      IF (MAX.LT.10.) GO TO 110
      IF (SC.EQ.0.) SC = SMALNO
      GO TO 90
   80 IF (INFIN/SC.LT.MAX) GO TO 110
   90 L = ALOG(SC)/ALOG(BASE) + .5
      FACTOR = (BASE*1.0D0)**L
      IF (FACTOR.EQ.1.D0) GO TO 110
      DO 100 I=1,NN
        P(I) = FACTOR*P(I)
  100 CONTINUE
C COMPUTE LOWER BOUND ON MODULI OF ZEROS.
  110 DO 120 I=1,NN
        PT(I) = ABS(SNGL(P(I)))
  120 CONTINUE
      PT(NN) = -PT(NN)
C COMPUTE UPPER ESTIMATE OF BOUND
      X = EXP((ALOG(-PT(NN))-ALOG(PT(1)))/FLOAT(N))
      IF (PT(N).EQ.0.) GO TO 130
C IF NEWTON STEP AT THE ORIGIN IS BETTER, USE IT.
      XM = -PT(NN)/PT(N)
      IF (XM.LT.X) X = XM
C CHOP THE INTERVAL (0,X) UNTIL FF .LE. 0
  130 XM = X*.1
      FF = PT(1)
      DO 140 I=2,NN
        FF = FF*XM + PT(I)
  140 CONTINUE
      IF (FF.LE.0.) GO TO 150
      X = XM
      GO TO 130
  150 DX = X
C DO NEWTON ITERATION UNTIL X CONVERGES TO TWO
C DECIMAL PLACES
  160 IF (ABS(DX/X).LE..005) GO TO 180
      FF = PT(1)
      DF = FF
      DO 170 I=2,N
        FF = FF*X + PT(I)
        DF = DF*X + FF
  170 CONTINUE
      FF = FF*X + PT(NN)
      DX = FF/DF
      X = X - DX
      GO TO 160
  180 BND = X
C COMPUTE THE DERIVATIVE AS THE INTIAL K POLYNOMIAL
C AND DO 5 STEPS WITH NO SHIFT
      NM1 = N - 1
      DO 190 I=2,N
        K(I) = FLOAT(NN-I)*P(I)/FLOAT(N)
  190 CONTINUE
      K(1) = P(1)
      AA = P(NN)
      BB = P(N)
      ZEROK = K(N).EQ.0.D0
      DO 230 JJ=1,5
        CC = K(N)
        IF (ZEROK) GO TO 210
C USE SCALED FORM OF RECURRENCE IF VALUE OF K AT 0 IS
C NONZERO
        T = -AA/CC
        DO 200 I=1,NM1
          J = NN - I
          K(J) = T*K(J-1) + P(J)
  200   CONTINUE
        K(1) = P(1)
        ZEROK = DABS(K(N)).LE.DABS(BB)*ETA*10.
        GO TO 230
C USE UNSCALED FORM OF RECURRENCE
  210   DO 220 I=1,NM1
          J = NN - I
          K(J) = K(J-1)
  220   CONTINUE
        K(1) = 0.D0
        ZEROK = K(N).EQ.0.D0
  230 CONTINUE
C SAVE K FOR RESTARTS WITH NEW SHIFTS
      DO 240 I=1,N
        TEMP(I) = K(I)
  240 CONTINUE
C LOOP TO SELECT THE QUADRATIC  CORRESPONDING TO EACH
C NEW SHIFT
      DO 280 CNT=1,20
C QUADRATIC CORRESPONDS TO A DOUBLE SHIFT TO A
C NON-REAL POINT AND ITS COMPLEX CONJUGATE. THE POINT
C HAS MODULUS BND AND AMPLITUDE ROTATED BY 94 DEGREES
C FROM THE PREVIOUS SHIFT
        XXX = COSR*XX - SINR*YY
        YY = SINR*XX + COSR*YY
        XX = XXX
        SR = BND*XX
        SI = BND*YY
        U = -2.0D0*SR
        V = BND
C SECOND STAGE CALCULATION, FIXED QUADRATIC
        CALL FXSHFR(20*CNT, NZ)
        IF (NZ.EQ.0) GO TO 260
C THE SECOND STAGE JUMPS DIRECTLY TO ONE OF THE THIRD
C STAGE ITERATIONS AND RETURNS HERE IF SUCCESSFUL.
C DEFLATE THE POLYNOMIAL, STORE THE ZERO OR ZEROS AND
C RETURN TO THE MAIN ALGORITHM.
        J = DEGREE - N + 1
        ZEROR(J) = SZR
        ZEROI(J) = SZI
        NN = NN - NZ
        N = NN - 1
        DO 250 I=1,NN
          P(I) = QP(I)
  250   CONTINUE
        IF (NZ.EQ.1) GO TO 40
        ZEROR(J+1) = LZR
        ZEROI(J+1) = LZI
        GO TO 40
C IF THE ITERATION IS UNSUCCESSFUL ANOTHER QUADRATIC
C IS CHOSEN AFTER RESTORING K
  260   DO 270 I=1,N
          K(I) = TEMP(I)
  270   CONTINUE
  280 CONTINUE
C RETURN WITH FAILURE IF NO CONVERGENCE WITH 20
C SHIFTS
      FAIL = .TRUE.
      DEGREE = DEGREE - N
      RETURN
      END
      SUBROUTINE FXSHFR(L2, NZ)
C COMPUTES UP TO  L2  FIXED SHIFT K-POLYNOMIALS,
C TESTING FOR CONVERGENCE IN THE LINEAR OR QUADRATIC
C CASE. INITIATES ONE OF THE VARIABLE SHIFT
C ITERATIONS AND RETURNS WITH THE NUMBER OF ZEROS
C FOUND.
C L2 - LIMIT OF FIXED SHIFT STEPS
C NZ - NUMBER OF ZEROS FOUND
      COMMON /GLOBAL/ P, QP, K, QK, SVK, SR, SI, U,
     * V, A, B, C, D, A1, A2, A3, A6, A7, E, F, G,
     * H, SZR, SZI, LZR, LZI, ETA, ARE, MRE, N, NN
      DOUBLE PRECISION P(101), QP(101), K(101),
     * QK(101), SVK(101), SR, SI, U, V, A, B, C, D,
     * A1, A2, A3, A6, A7, E, F, G, H, SZR, SZI,
     * LZR, LZI
      REAL ETA, ARE, MRE
      INTEGER N, NN
      DOUBLE PRECISION SVU, SVV, UI, VI, S
      REAL BETAS, BETAV, OSS, OVV, SS, VV, TS, TV,
     * OTS, OTV, TVV, TSS
      INTEGER L2, NZ, TYPE, I, J, IFLAG
      LOGICAL VPASS, SPASS, VTRY, STRY
      NZ = 0
      BETAV = .25
      BETAS = .25
      OSS = SR
      OVV = V
C EVALUATE POLYNOMIAL BY SYNTHETIC DIVISION
      CALL QUADSD(NN, U, V, P, QP, A, B)
      CALL CALCSC(TYPE)
      DO 80 J=1,L2
C CALCULATE NEXT K POLYNOMIAL AND ESTIMATE V
        CALL NEXTK(TYPE)
        CALL CALCSC(TYPE)
        CALL NEWEST(TYPE, UI, VI)
        VV = VI
C ESTIMATE S
        SS = 0.
        IF (K(N).NE.0.D0) SS = -P(NN)/K(N)
        TV = 1.
        TS = 1.
        IF (J.EQ.1 .OR. TYPE.EQ.3) GO TO 70
C COMPUTE RELATIVE MEASURES OF CONVERGENCE OF S AND V
C SEQUENCES
        IF (VV.NE.0.) TV = ABS((VV-OVV)/VV)
        IF (SS.NE.0.) TS = ABS((SS-OSS)/SS)
C IF DECREASING, MULTIPLY TWO MOST RECENT
C CONVERGENCE MEASURES
        TVV = 1.
        IF (TV.LT.OTV) TVV = TV*OTV
        TSS = 1.
        IF (TS.LT.OTS) TSS = TS*OTS
C COMPARE WITH CONVERGENCE CRITERIA
        VPASS = TVV.LT.BETAV
        SPASS = TSS.LT.BETAS
        IF (.NOT.(SPASS .OR. VPASS)) GO TO 70
C AT LEAST ONE SEQUENCE HAS PASSED THE CONVERGENCE
C TEST. STORE VARIABLES BEFORE ITERATING
        SVU = U
        SVV = V
        DO 10 I=1,N
          SVK(I) = K(I)
   10   CONTINUE
        S = SS
C CHOOSE ITERATION ACCORDING TO THE FASTEST
C CONVERGING SEQUENCE
        VTRY = .FALSE.
        STRY = .FALSE.
        IF (SPASS .AND. ((.NOT.VPASS) .OR.
     *   TSS.LT.TVV)) GO TO 40
   20   CALL QUADIT(UI, VI, NZ)
        IF (NZ.GT.0) RETURN
C QUADRATIC ITERATION HAS FAILED. FLAG THAT IT HAS
C BEEN TRIED AND DECREASE THE CONVERGENCE CRITERION.
        VTRY = .TRUE.
        BETAV = BETAV*.25
C TRY LINEAR ITERATION IF IT HAS NOT BEEN TRIED AND
C THE S SEQUENCE IS CONVERGING
        IF (STRY .OR. (.NOT.SPASS)) GO TO 50
        DO 30 I=1,N
          K(I) = SVK(I)
   30   CONTINUE
   40   CALL REALIT(S, NZ, IFLAG)
        IF (NZ.GT.0) RETURN
C LINEAR ITERATION HAS FAILED. FLAG THAT IT HAS BEEN
C TRIED AND DECREASE THE CONVERGENCE CRITERION
        STRY = .TRUE.
        BETAS = BETAS*.25
        IF (IFLAG.EQ.0) GO TO 50
C IF LINEAR ITERATION SIGNALS AN ALMOST DOUBLE REAL
C ZERO ATTEMPT QUADRATIC INTERATION
        UI = -(S+S)
        VI = S*S
        GO TO 20
C RESTORE VARIABLES
   50   U = SVU
        V = SVV
        DO 60 I=1,N
          K(I) = SVK(I)
   60   CONTINUE
C TRY QUADRATIC ITERATION IF IT HAS NOT BEEN TRIED
C AND THE V SEQUENCE IS CONVERGING
        IF (VPASS .AND. (.NOT.VTRY)) GO TO 20
C RECOMPUTE QP AND SCALAR VALUES TO CONTINUE THE
C SECOND STAGE
        CALL QUADSD(NN, U, V, P, QP, A, B)
        CALL CALCSC(TYPE)
   70   OVV = VV
        OSS = SS
        OTV = TV
        OTS = TS
   80 CONTINUE
      RETURN
      END
      SUBROUTINE QUADIT(UU, VV, NZ)
C VARIABLE-SHIFT K-POLYNOMIAL ITERATION FOR A
C QUADRATIC FACTOR CONVERGES ONLY IF THE ZEROS ARE
C EQUIMODULAR OR NEARLY SO.
C UU,VV - COEFFICIENTS OF STARTING QUADRATIC
C NZ - NUMBER OF ZERO FOUND
      COMMON /GLOBAL/ P, QP, K, QK, SVK, SR, SI, U,
     * V, A, B, C, D, A1, A2, A3, A6, A7, E, F, G,
     * H, SZR, SZI, LZR, LZI, ETA, ARE, MRE, N, NN
      DOUBLE PRECISION P(101), QP(101), K(101),
     * QK(101), SVK(101), SR, SI, U, V, A, B, C, D,
     * A1, A2, A3, A6, A7, E, F, G, H, SZR, SZI,
     * LZR, LZI
      REAL ETA, ARE, MRE
      INTEGER N, NN
      DOUBLE PRECISION UI, VI, UU, VV, DABS
      REAL MP, OMP, EE, RELSTP, T, ZM
      INTEGER NZ, TYPE, I, J
      LOGICAL TRIED
      NZ = 0
      TRIED = .FALSE.
      U = UU
      V = VV
      J = 0
C MAIN LOOP
   10 CALL QUAD(1.D0, U, V, SZR, SZI, LZR, LZI)
C RETURN IF ROOTS OF THE QUADRATIC ARE REAL AND NOT
C CLOSE TO MULTIPLE OR NEARLY EQUAL AND  OF OPPOSITE
C SIGN
      IF (DABS(DABS(SZR)-DABS(LZR)).GT..01D0*
     * DABS(LZR)) RETURN
C EVALUATE POLYNOMIAL BY QUADRATIC SYNTHETIC DIVISION
      CALL QUADSD(NN, U, V, P, QP, A, B)
      MP = DABS(A-SZR*B) + DABS(SZI*B)
C COMPUTE A RIGOROUS  BOUND ON THE ROUNDING ERROR IN
C EVALUTING P
      ZM = SQRT(ABS(SNGL(V)))
      EE = 2.*ABS(SNGL(QP(1)))
      T = -SZR*B
      DO 20 I=2,N
        EE = EE*ZM + ABS(SNGL(QP(I)))
   20 CONTINUE
      EE = EE*ZM + ABS(SNGL(A)+T)
      EE = (5.*MRE+4.*ARE)*EE - (5.*MRE+2.*ARE)*
     * (ABS(SNGL(A)+T)+ABS(SNGL(B))*ZM) +
     * 2.*ARE*ABS(T)
C ITERATION HAS CONVERGED SUFFICIENTLY IF THE
C POLYNOMIAL VALUE IS LESS THAN 20 TIMES THIS BOUND
      IF (MP.GT.20.*EE) GO TO 30
      NZ = 2
      RETURN
   30 J = J + 1
C STOP ITERATION AFTER 20 STEPS
      IF (J.GT.20) RETURN
      IF (J.LT.2) GO TO 50
      IF (RELSTP.GT..01 .OR. MP.LT.OMP .OR. TRIED)
     * GO TO 50
C A CLUSTER APPEARS TO BE STALLING THE CONVERGENCE.
C FIVE FIXED SHIFT STEPS ARE TAKEN WITH A U,V CLOSE
C TO THE CLUSTER
      IF (RELSTP.LT.ETA) RELSTP = ETA
      RELSTP = SQRT(RELSTP)
      U = U - U*RELSTP
      V = V + V*RELSTP
      CALL QUADSD(NN, U, V, P, QP, A, B)
      DO 40 I=1,5
        CALL CALCSC(TYPE)
        CALL NEXTK(TYPE)
   40 CONTINUE
      TRIED = .TRUE.
      J = 0
   50 OMP = MP
C CALCULATE NEXT K POLYNOMIAL AND NEW U AND V
      CALL CALCSC(TYPE)
      CALL NEXTK(TYPE)
      CALL CALCSC(TYPE)
      CALL NEWEST(TYPE, UI, VI)
C IF VI IS ZERO THE ITERATION IS NOT CONVERGING
      IF (VI.EQ.0.D0) RETURN
      RELSTP = DABS((VI-V)/VI)
      U = UI
      V = VI
      GO TO 10
      END
      SUBROUTINE REALIT(SSS, NZ, IFLAG)
C VARIABLE-SHIFT H POLYNOMIAL ITERATION FOR A REAL
C ZERO.
C SSS   - STARTING ITERATE
C NZ    - NUMBER OF ZERO FOUND
C IFLAG - FLAG TO INDICATE A PAIR OF ZEROS NEAR REAL
C         AXIS.
      COMMON /GLOBAL/ P, QP, K, QK, SVK, SR, SI, U,
     * V, A, B, C, D, A1, A2, A3, A6, A7, E, F, G,
     * H, SZR, SZI, LZR, LZI, ETA, ARE, MRE, N, NN
      DOUBLE PRECISION P(101), QP(101), K(101),
     * QK(101), SVK(101), SR, SI, U, V, A, B, C, D,
     * A1, A2, A3, A6, A7, E, F, G, H, SZR, SZI,
     * LZR, LZI
      REAL ETA, ARE, MRE
      INTEGER N, NN
      DOUBLE PRECISION PV, KV, T, S, SSS, DABS
      REAL MS, MP, OMP, EE
      INTEGER NZ, IFLAG, I, J, NM1
      NM1 = N - 1
      NZ = 0
      S = SSS
      IFLAG = 0
      J = 0
C MAIN LOOP
   10 PV = P(1)
C EVALUATE P AT S
      QP(1) = PV
      DO 20 I=2,NN
        PV = PV*S + P(I)
        QP(I) = PV
   20 CONTINUE
      MP = DABS(PV)
C COMPUTE A RIGOROUS BOUND ON THE ERROR IN EVALUATING
C P
      MS = DABS(S)
      EE = (MRE/(ARE+MRE))*ABS(SNGL(QP(1)))
      DO 30 I=2,NN
        EE = EE*MS + ABS(SNGL(QP(I)))
   30 CONTINUE
C ITERATION HAS CONVERGED SUFFICIENTLY IF THE
C POLYNOMIAL VALUE IS LESS THAN 20 TIMES THIS BOUND
      IF (MP.GT.20.*((ARE+MRE)*EE-MRE*MP)) GO TO 40
      NZ = 1
      SZR = S
      SZI = 0.D0
      RETURN
   40 J = J + 1
C STOP ITERATION AFTER 10 STEPS
      IF (J.GT.10) RETURN
      IF (J.LT.2) GO TO 50
      IF (DABS(T).GT..001*DABS(S-T) .OR. MP.LE.OMP)
     * GO TO 50
C A CLUSTER OF ZEROS NEAR THE REAL AXIS HAS BEEN
C ENCOUNTERED RETURN WITH IFLAG SET TO INITIATE A
C QUADRATIC ITERATION
      IFLAG = 1
      SSS = S
      RETURN
C RETURN IF THE POLYNOMIAL VALUE HAS INCREASED
C SIGNIFICANTLY
   50 OMP = MP
C COMPUTE T, THE NEXT POLYNOMIAL, AND THE NEW ITERATE
      KV = K(1)
      QK(1) = KV
      DO 60 I=2,N
        KV = KV*S + K(I)
        QK(I) = KV
   60 CONTINUE
      IF (DABS(KV).LE.DABS(K(N))*10.*ETA) GO TO 80
C USE THE SCALED FORM OF THE RECURRENCE IF THE VALUE
C OF K AT S IS NONZERO
      T = -PV/KV
      K(1) = QP(1)
      DO 70 I=2,N
        K(I) = T*QK(I-1) + QP(I)
   70 CONTINUE
      GO TO 100
C USE UNSCALED FORM
   80 K(1) = 0.0D0
      DO 90 I=2,N
        K(I) = QK(I-1)
   90 CONTINUE
  100 KV = K(1)
      DO 110 I=2,N
        KV = KV*S + K(I)
  110 CONTINUE
      T = 0.D0
      IF (DABS(KV).GT.DABS(K(N))*10.*ETA) T = -PV/KV
      S = S + T
      GO TO 10
      END
      SUBROUTINE CALCSC(TYPE)
C THIS ROUTINE CALCULATES SCALAR QUANTITIES USED TO
C COMPUTE THE NEXT K POLYNOMIAL AND NEW ESTIMATES OF
C THE QUADRATIC COEFFICIENTS.
C TYPE - INTEGER VARIABLE SET HERE INDICATING HOW THE
C CALCULATIONS ARE NORMALIZED TO AVOID OVERFLOW
      COMMON /GLOBAL/ P, QP, K, QK, SVK, SR, SI, U,
     * V, A, B, C, D, A1, A2, A3, A6, A7, E, F, G,
     * H, SZR, SZI, LZR, LZI, ETA, ARE, MRE, N, NN
      DOUBLE PRECISION P(101), QP(101), K(101),
     * QK(101), SVK(101), SR, SI, U, V, A, B, C, D,
     * A1, A2, A3, A6, A7, E, F, G, H, SZR, SZI,
     * LZR, LZI
      REAL ETA, ARE, MRE
      INTEGER N, NN
      DOUBLE PRECISION DABS
      INTEGER TYPE
C SYNTHETIC DIVISION OF K BY THE QUADRATIC 1,U,V
      CALL QUADSD(N, U, V, K, QK, C, D)
      IF (DABS(C).GT.DABS(K(N))*100.*ETA) GO TO 10
      IF (DABS(D).GT.DABS(K(N-1))*100.*ETA) GO TO 10
      TYPE = 3
C TYPE=3 INDICATES THE QUADRATIC IS ALMOST A FACTOR
C OF K
      RETURN
   10 IF (DABS(D).LT.DABS(C)) GO TO 20
      TYPE = 2
C TYPE=2 INDICATES THAT ALL FORMULAS ARE DIVIDED BY D
      E = A/D
      F = C/D
      G = U*B
      H = V*B
      A3 = (A+G)*E + H*(B/D)
      A1 = B*F - A
      A7 = (F+U)*A + H
      RETURN
   20 TYPE = 1
C TYPE=1 INDICATES THAT ALL FORMULAS ARE DIVIDED BY C
      E = A/C
      F = D/C
      G = U*E
      H = V*B
      A3 = A*E + (H/C+G)*B
      A1 = B - A*(D/C)
      A7 = A + G*D + H*F
      RETURN
      END
      SUBROUTINE NEXTK(TYPE)
C COMPUTES THE NEXT K POLYNOMIALS USING SCALARS
C COMPUTED IN CALCSC
      COMMON /GLOBAL/ P, QP, K, QK, SVK, SR, SI, U,
     * V, A, B, C, D, A1, A2, A3, A6, A7, E, F, G,
     * H, SZR, SZI, LZR, LZI, ETA, ARE, MRE, N, NN
      DOUBLE PRECISION P(101), QP(101), K(101),
     * QK(101), SVK(101), SR, SI, U, V, A, B, C, D,
     * A1, A2, A3, A6, A7, E, F, G, H, SZR, SZI,
     * LZR, LZI
      REAL ETA, ARE, MRE
      INTEGER N, NN
      DOUBLE PRECISION TEMP, DABS
      INTEGER I, TYPE
      IF (TYPE.EQ.3) GO TO 40
      TEMP = A
      IF (TYPE.EQ.1) TEMP = B
      IF (DABS(A1).GT.DABS(TEMP)*ETA*10.) GO TO 20
C IF A1 IS NEARLY ZERO THEN USE A SPECIAL FORM OF THE
C RECURRENCE
      K(1) = 0.D0
      K(2) = -A7*QP(1)
      DO 10 I=3,N
        K(I) = A3*QK(I-2) - A7*QP(I-1)
   10 CONTINUE
      RETURN
C USE SCALED FORM OF THE RECURRENCE
   20 A7 = A7/A1
      A3 = A3/A1
      K(1) = QP(1)
      K(2) = QP(2) - A7*QP(1)
      DO 30 I=3,N
        K(I) = A3*QK(I-2) - A7*QP(I-1) + QP(I)
   30 CONTINUE
      RETURN
C USE UNSCALED FORM OF THE RECURRENCE IF TYPE IS 3
   40 K(1) = 0.D0
      K(2) = 0.D0
      DO 50 I=3,N
        K(I) = QK(I-2)
   50 CONTINUE
      RETURN
      END
      SUBROUTINE NEWEST(TYPE, UU, VV)
C COMPUTE NEW ESTIMATES OF THE QUADRATIC COEFFICIENTS
C USING THE SCALARS COMPUTED IN CALCSC.
      COMMON /GLOBAL/ P, QP, K, QK, SVK, SR, SI, U,
     * V, A, B, C, D, A1, A2, A3, A6, A7, E, F, G,
     * H, SZR, SZI, LZR, LZI, ETA, ARE, MRE, N, NN
      DOUBLE PRECISION P(101), QP(101), K(101),
     * QK(101), SVK(101), SR, SI, U, V, A, B, C, D,
     * A1, A2, A3, A6, A7, E, F, G, H, SZR, SZI,
     * LZR, LZI
      REAL ETA, ARE, MRE
      INTEGER N, NN
      DOUBLE PRECISION A4, A5, B1, B2, C1, C2, C3,
     * C4, TEMP, UU, VV
      INTEGER TYPE
C USE FORMULAS APPROPRIATE TO SETTING OF TYPE.
      IF (TYPE.EQ.3) GO TO 30
      IF (TYPE.EQ.2) GO TO 10
      A4 = A + U*B + H*F
      A5 = C + (U+V*F)*D
      GO TO 20
   10 A4 = (A+G)*F + H
      A5 = (F+U)*C + V*D
C EVALUATE NEW QUADRATIC COEFFICIENTS.
   20 B1 = -K(N)/P(NN)
      B2 = -(K(N-1)+B1*P(N))/P(NN)
      C1 = V*B2*A1
      C2 = B1*A7
      C3 = B1*B1*A3
      C4 = C1 - C2 - C3
      TEMP = A5 + B1*A4 - C4
      IF (TEMP.EQ.0.D0) GO TO 30
      UU = U - (U*(C3+C2)+V*(B1*A1+B2*A7))/TEMP
      VV = V*(1.+C4/TEMP)
      RETURN
C IF TYPE=3 THE QUADRATIC IS ZEROED
   30 UU = 0.D0
      VV = 0.D0
      RETURN
      END
      SUBROUTINE QUADSD(NN, U, V, P, Q, A, B)
C DIVIDES P BY THE QUADRATIC  1,U,V  PLACING THE
C QUOTIENT IN Q AND THE REMAINDER IN A,B
      INTEGER NN
      DOUBLE PRECISION P(NN), Q(NN), U, V, A, B, C
      INTEGER I
      B = P(1)
      Q(1) = B
      A = P(2) - U*B
      Q(2) = A
      DO 10 I=3,NN
        C = P(I) - U*A - V*B
        Q(I) = C
        B = A
        A = C
   10 CONTINUE
      RETURN
      END
      SUBROUTINE QUAD(A, B1, C, SR, SI, LR, LI)
C CALCULATE THE ZEROS OF THE QUADRATIC A*Z**2+B1*Z+C.
C THE QUADRATIC FORMULA, MODIFIED TO AVOID
C OVERFLOW, IS USED TO FIND THE LARGER ZERO IF THE
C ZEROS ARE REAL AND BOTH ZEROS ARE COMPLEX.
C THE SMALLER REAL ZERO IS FOUND DIRECTLY FROM THE
C PRODUCT OF THE ZEROS C/A.
      DOUBLE PRECISION A, B1, C, SR, SI, LR, LI, B,
     * D, E, DABS, DSQRT
      IF (A.NE.0.D0) GO TO 20
      SR = 0.D0
      IF (B1.NE.0.D0) SR = -C/B1
      LR = 0.D0
   10 SI = 0.D0
      LI = 0.D0
      RETURN
   20 IF (C.NE.0.D0) GO TO 30
      SR = 0.D0
      LR = -B1/A
      GO TO 10
C COMPUTE DISCRIMINANT AVOIDING OVERFLOW
   30 B = B1/2.D0
      IF (DABS(B).LT.DABS(C)) GO TO 40
      E = 1.D0 - (A/B)*(C/B)
      D = DSQRT(DABS(E))*DABS(B)
      GO TO 50
   40 E = A
      IF (C.LT.0.D0) E = -A
      E = B*(B/DABS(C)) - E
      D = DSQRT(DABS(E))*DSQRT(DABS(C))
   50 IF (E.LT.0.D0) GO TO 60
C REAL ZEROS
      IF (B.GE.0.D0) D = -D
      LR = (-B+D)/A
      SR = 0.D0
      IF (LR.NE.0.D0) SR = (C/LR)/A
      GO TO 10
C COMPLEX CONJUGATE ZEROS
   60 SR = -B/A
      LR = SR
      SI = DABS(D/A)
      LI = -SI
      RETURN
      END
      SUBROUTINE MACHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,
     1                   MAXEXP,EPS,EPSNEG,XMIN,XMAX)
C-----------------------------------------------------------------------
C  THIS FORTRAN 77 SUBROUTINE IS INTENDED TO DETERMINE THE PARAMETERS
C   OF THE FLOATING-POINT ARITHMETIC SYSTEM SPECIFIED BELOW.  THE
C   DETERMINATION OF THE FIRST THREE USES AN EXTENSION OF AN ALGORITHM
C   DUE TO M. MALCOLM, CACM 15 (1972), PP. 949-951, INCORPORATING SOME,
C   BUT NOT ALL, OF THE IMPROVEMENTS SUGGESTED BY M. GENTLEMAN AND S.
C   MAROVICH, CACM 17 (1974), PP. 276-277.  AN EARLIER VERSION OF THIS
C   PROGRAM WAS PUBLISHED IN THE BOOK SOFTWARE MANUAL FOR THE
C   ELEMENTARY FUNCTIONS BY W. J. CODY AND W. WAITE, PRENTICE-HALL,
C   ENGLEWOOD CLIFFS, NJ, 1980.  THE PRESENT VERSION IS DOCUMENTED IN
C   W. J. CODY, "MACHAR: A SUBROUTINE TO DYNAMICALLY DETERMINE MACHINE
C   PARAMETERS," TOMS 14, DECEMBER, 1988.
C
C  THE PROGRAM AS GIVEN HERE MUST BE MODIFIED BEFORE COMPILING.  IF
C   A SINGLE (DOUBLE) PRECISION VERSION IS DESIRED, CHANGE ALL
C   OCCURRENCES OF CS (CD) IN COLUMNS 1 AND 2 TO BLANKS.
C
C  PARAMETER VALUES REPORTED ARE AS FOLLOWS:
C
C       IBETA   - THE RADIX FOR THE FLOATING-POINT REPRESENTATION
C       IT      - THE NUMBER OF BASE IBETA DIGITS IN THE FLOATING-POINT
C                 SIGNIFICAND
C       IRND    - 0 IF FLOATING-POINT ADDITION CHOPS
C                 1 IF FLOATING-POINT ADDITION ROUNDS, BUT NOT IN THE
C                   IEEE STYLE
C                 2 IF FLOATING-POINT ADDITION ROUNDS IN THE IEEE STYLE
C                 3 IF FLOATING-POINT ADDITION CHOPS, AND THERE IS
C                   PARTIAL UNDERFLOW
C                 4 IF FLOATING-POINT ADDITION ROUNDS, BUT NOT IN THE
C                   IEEE STYLE, AND THERE IS PARTIAL UNDERFLOW
C                 5 IF FLOATING-POINT ADDITION ROUNDS IN THE IEEE STYLE,
C                   AND THERE IS PARTIAL UNDERFLOW
C       NGRD    - THE NUMBER OF GUARD DIGITS FOR MULTIPLICATION WITH
C                 TRUNCATING ARITHMETIC.  IT IS
C                 0 IF FLOATING-POINT ARITHMETIC ROUNDS, OR IF IT
C                   TRUNCATES AND ONLY  IT  BASE  IBETA DIGITS
C                   PARTICIPATE IN THE POST-NORMALIZATION SHIFT OF THE
C                   FLOATING-POINT SIGNIFICAND IN MULTIPLICATION;
C                 1 IF FLOATING-POINT ARITHMETIC TRUNCATES AND MORE
C                   THAN  IT  BASE  IBETA  DIGITS PARTICIPATE IN THE
C                   POST-NORMALIZATION SHIFT OF THE FLOATING-POINT
C                   SIGNIFICAND IN MULTIPLICATION.
C       MACHEP  - THE LARGEST NEGATIVE INTEGER SUCH THAT
C                 1.0+FLOAT(IBETA)**MACHEP .NE. 1.0, EXCEPT THAT
C                 MACHEP IS BOUNDED BELOW BY  -(IT+3)
C       NEGEPS  - THE LARGEST NEGATIVE INTEGER SUCH THAT
C                 1.0-FLOAT(IBETA)**NEGEPS .NE. 1.0, EXCEPT THAT
C                 NEGEPS IS BOUNDED BELOW BY  -(IT+3)
C       IEXP    - THE NUMBER OF BITS (DECIMAL PLACES IF IBETA = 10)
C                 RESERVED FOR THE REPRESENTATION OF THE EXPONENT
C                 (INCLUDING THE BIAS OR SIGN) OF A FLOATING-POINT
C                 NUMBER
C       MINEXP  - THE LARGEST IN MAGNITUDE NEGATIVE INTEGER SUCH THAT
C                 FLOAT(IBETA)**MINEXP IS POSITIVE AND NORMALIZED
C       MAXEXP  - THE SMALLEST POSITIVE POWER OF  BETA  THAT OVERFLOWS
C       EPS     - THE SMALLEST POSITIVE FLOATING-POINT NUMBER SUCH
C                 THAT  1.0+EPS .NE. 1.0. IN PARTICULAR, IF EITHER
C                 IBETA = 2  OR  IRND = 0, EPS = FLOAT(IBETA)**MACHEP.
C                 OTHERWISE,  EPS = (FLOAT(IBETA)**MACHEP)/2
C       EPSNEG  - A SMALL POSITIVE FLOATING-POINT NUMBER SUCH THAT
C                 1.0-EPSNEG .NE. 1.0. IN PARTICULAR, IF IBETA = 2
C                 OR  IRND = 0, EPSNEG = FLOAT(IBETA)**NEGEPS.
C                 OTHERWISE,  EPSNEG = (IBETA**NEGEPS)/2.  BECAUSE
C                 NEGEPS IS BOUNDED BELOW BY -(IT+3), EPSNEG MAY NOT
C                 BE THE SMALLEST NUMBER THAT CAN ALTER 1.0 BY
C                 SUBTRACTION.
C       XMIN    - THE SMALLEST NON-VANISHING NORMALIZED FLOATING-POINT
C                 POWER OF THE RADIX, I.E.,  XMIN = FLOAT(IBETA)**MINEXP
C       XMAX    - THE LARGEST FINITE FLOATING-POINT NUMBER.  IN
C                 PARTICULAR  XMAX = (1.0-EPSNEG)*FLOAT(IBETA)**MAXEXP
C                 NOTE - ON SOME MACHINES  XMAX  WILL BE ONLY THE
C                 SECOND, OR PERHAPS THIRD, LARGEST NUMBER, BEING
C                 TOO SMALL BY 1 OR 2 UNITS IN THE LAST DIGIT OF
C                 THE SIGNIFICAND.
C
C     LATEST REVISION - DECEMBER 4, 1987
C
C     AUTHOR - W. J. CODY
C              ARGONNE NATIONAL LABORATORY
C
C-----------------------------------------------------------------------
      INTEGER I,IBETA,IEXP,IRND,IT,ITEMP,IZ,J,K,MACHEP,MAXEXP,
     1        MINEXP,MX,NEGEP,NGRD,NXRES
CS    REAL
CD    DOUBLE PRECISION
     1   A,B,BETA,BETAIN,BETAH,CONV,EPS,EPSNEG,ONE,T,TEMP,TEMPA,
     2   TEMP1,TWO,XMAX,XMIN,Y,Z,ZERO
C-----------------------------------------------------------------------
CS    CONV(I) = REAL(I)
CD    CONV(I) = DBLE(I)
      ONE = CONV(1)
      TWO = ONE + ONE
      ZERO = ONE - ONE
C-----------------------------------------------------------------------
C  DETERMINE IBETA, BETA ALA MALCOLM.
C-----------------------------------------------------------------------
      A = ONE
   10 A = A + A
         TEMP = A+ONE
         TEMP1 = TEMP-A
         IF (TEMP1-ONE .EQ. ZERO) GO TO 10
      B = ONE
   20 B = B + B
         TEMP = A+B
         ITEMP = INT(TEMP-A)
         IF (ITEMP .EQ. 0) GO TO 20
      IBETA = ITEMP
      BETA = CONV(IBETA)
C-----------------------------------------------------------------------
C  DETERMINE IT, IRND.
C-----------------------------------------------------------------------
      IT = 0
      B = ONE
  100 IT = IT + 1
         B = B * BETA
         TEMP = B+ONE
         TEMP1 = TEMP-B
         IF (TEMP1-ONE .EQ. ZERO) GO TO 100
      IRND = 0
      BETAH = BETA / TWO
      TEMP = A+BETAH
      IF (TEMP-A .NE. ZERO) IRND = 1
      TEMPA = A + BETA
      TEMP = TEMPA+BETAH
      IF ((IRND .EQ. 0) .AND. (TEMP-TEMPA .NE. ZERO)) IRND = 2
C-----------------------------------------------------------------------
C  DETERMINE NEGEP, EPSNEG.
C-----------------------------------------------------------------------
      NEGEP = IT + 3
      BETAIN = ONE / BETA
      A = ONE
      DO 200 I = 1, NEGEP
         A = A * BETAIN
  200 CONTINUE
      B = A
  210 TEMP = ONE-A
         IF (TEMP-ONE .NE. ZERO) GO TO 220
         A = A * BETA
         NEGEP = NEGEP - 1
      GO TO 210
  220 NEGEP = -NEGEP
      EPSNEG = A
C-----------------------------------------------------------------------
C  DETERMINE MACHEP, EPS.
C-----------------------------------------------------------------------
      MACHEP = -IT - 3
      A = B
  300 TEMP = ONE+A
         IF (TEMP-ONE .NE. ZERO) GO TO 320
         A = A * BETA
         MACHEP = MACHEP + 1
      GO TO 300
  320 EPS = A
C-----------------------------------------------------------------------
C  DETERMINE NGRD.
C-----------------------------------------------------------------------
      NGRD = 0
      TEMP = ONE+EPS
      IF ((IRND .EQ. 0) .AND. (TEMP*ONE-ONE .NE. ZERO)) NGRD = 1
C-----------------------------------------------------------------------
C  DETERMINE IEXP, MINEXP, XMIN.
C
C  LOOP TO DETERMINE LARGEST I AND K = 2**I SUCH THAT
C         (1/BETA) ** (2**(I))
C  DOES NOT UNDERFLOW.
C  EXIT FROM LOOP IS SIGNALED BY AN UNDERFLOW.
C-----------------------------------------------------------------------
      I = 0
      K = 1
      Z = BETAIN
      T = ONE + EPS
      NXRES = 0
  400 Y = Z
         Z = Y * Y
C-----------------------------------------------------------------------
C  CHECK FOR UNDERFLOW HERE.
C-----------------------------------------------------------------------
         A = Z * ONE
         TEMP = Z * T
         IF ((A+A .EQ. ZERO) .OR. (ABS(Z) .GE. Y)) GO TO 410
         TEMP1 = TEMP * BETAIN
         IF (TEMP1*BETA .EQ. Z) GO TO 410
         I = I + 1
         K = K + K
      GO TO 400
  410 IF (IBETA .EQ. 10) GO TO 420
      IEXP = I + 1
      MX = K + K
      GO TO 450
C-----------------------------------------------------------------------
C  THIS SEGMENT IS FOR DECIMAL MACHINES ONLY.
C-----------------------------------------------------------------------
  420 IEXP = 2
      IZ = IBETA
  430 IF (K .LT. IZ) GO TO 440
         IZ = IZ * IBETA
         IEXP = IEXP + 1
      GO TO 430
  440 MX = IZ + IZ - 1
C-----------------------------------------------------------------------
C  LOOP TO DETERMINE MINEXP, XMIN.
C  EXIT FROM LOOP IS SIGNALED BY AN UNDERFLOW.
C-----------------------------------------------------------------------
  450 XMIN = Y
         Y = Y * BETAIN
C-----------------------------------------------------------------------
C  CHECK FOR UNDERFLOW HERE.
C-----------------------------------------------------------------------
         A = Y * ONE
         TEMP = Y * T
         IF (((A+A) .EQ. ZERO) .OR. (ABS(Y) .GE. XMIN)) GO TO 460
         K = K + 1
         TEMP1 = TEMP * BETAIN
         IF ((TEMP1*BETA .NE. Y) .OR. (TEMP .EQ. Y)) THEN
               GO TO 450
            ELSE
               NXRES = 3
               XMIN = Y
         END IF
  460 MINEXP = -K
C-----------------------------------------------------------------------
C  DETERMINE MAXEXP, XMAX.
C-----------------------------------------------------------------------
      IF ((MX .GT. K+K-3) .OR. (IBETA .EQ. 10)) GO TO 500
      MX = MX + MX
      IEXP = IEXP + 1
  500 MAXEXP = MX + MINEXP
C-----------------------------------------------------------------
C  ADJUST IRND TO REFLECT PARTIAL UNDERFLOW.
C-----------------------------------------------------------------
      IRND = IRND + NXRES
C-----------------------------------------------------------------
C  ADJUST FOR IEEE-STYLE MACHINES.
C-----------------------------------------------------------------
      IF (IRND .GE. 2) MAXEXP = MAXEXP - 2
C-----------------------------------------------------------------
C  ADJUST FOR MACHINES WITH IMPLICIT LEADING BIT IN BINARY
C  SIGNIFICAND, AND MACHINES WITH RADIX POINT AT EXTREME
C  RIGHT OF SIGNIFICAND.
C-----------------------------------------------------------------
      I = MAXEXP + MINEXP
      IF ((IBETA .EQ. 2) .AND. (I .EQ. 0)) MAXEXP = MAXEXP - 1
      IF (I .GT. 20) MAXEXP = MAXEXP - 1
      IF (A .NE. Y) MAXEXP = MAXEXP - 2
      XMAX = ONE - EPSNEG
      IF (XMAX*ONE .NE. XMAX) XMAX = ONE - BETA * EPSNEG
      XMAX = XMAX / (BETA * BETA * BETA * XMIN)
      I = MAXEXP + MINEXP + 3
      IF (I .LE. 0) GO TO 520
      DO 510 J = 1, I
          IF (IBETA .EQ. 2) XMAX = XMAX + XMAX
          IF (IBETA .NE. 2) XMAX = XMAX * BETA
  510 CONTINUE
  520 RETURN
C---------- LAST CARD OF MACHAR ----------
      END
      REAL FUNCTION AERE (Y, YA)
C
C ---------------------------------------------------------------------I
C PURPOSE: COMPARISON OF THE APPROXIMATED SOLUTION "YA" WITH THE EXACT I
C -------  SOLUTION "Y". IF Y > 1.0 THE NUMBER OF CORRECT SIGNIFICANT  I
C DIGITS IS RETURNED, OTHERWISE THE NUMBER OF CORRECT DIGITS.          I
C                                                                      I
C COMMON VARIABLES:                                                    I
C ----------------                                                     I
      INTEGER IBETA, IOVFLO, NSDEC, IMXLUN
      COMMON /COLMCI/ IBETA, IOVFLO, NSDEC, IMXLUN
*
      SAVE /COLMCI/
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      REAL Y, YA
C                                                                      I
C ---------------------------------------------------------------------I
C                                                                      I
      REAL AY, ERR
*
      AY = ABS(Y)
      ERR = ABS(Y-YA)
      IF (ERR .EQ. 0.0) THEN
         AERE = REAL(NSDEC+1)
      ELSE
         AERE = -LOG10(ERR/MAX(1.0,AY))
      ENDIF
      RETURN
      END
      SUBROUTINE SUMARY (NOUT, NEQN, WKAREA, YE, T, UE, GEE, IERROR)
C
C ---------------------------------------------------------------------I
C PURPOSE: EXTRACT STATISTICS FROM COMMON BLOCKS AND WRITE SUMMARY OF  I
C -------  RESULTS TO FILE WITH LUN "NOUT".                            I
C                                                                      I
C COMMON VARIABLES:                                                    I
C ----------------                                                     I
      INTEGER METH, M, S, L, ORDER, ORDERQ, METHR, MR, SR, LR, ORDERR,
     +        ERRWGT, NHFAIL, NERR, NWIR, NSAV,
     +        MAXNC, MAXKEV, MAXCPS, N, NNIT, NKEV, NCPS
      COMMON /COLCMI/ METH, M, S, L, ORDER, ORDERQ,
     +                METHR, MR, SR, LR, ORDERR,
     +                ERRWGT, NHFAIL,
     +                NERR, NWIR, NSAV,
     +                MAXNC, MAXKEV, MAXCPS,
     +                N, NNIT, NKEV, NCPS
*
      LOGICAL VS, GSSCKM, ESCGSS, GEC, ULEC, RLXTOL, GEETE,
     +        FUNCIT, NEWTON
      COMMON /COLCML/ VS, GSSCKM, ESCGSS, GEC, ULEC, RLXTOL, GEETE,
     +                FUNCIT, NEWTON
*
      REAL TOLLE, TOLCIA, TOLCIR, HMIN, HMAX, HC
      COMMON /COLCMR/ TOLLE, TOLCIA, TOLCIR, HMIN, HMAX, HC
*
      SAVE /COLCMI/, /COLCML/, /COLCMR/
*
      INTEGER IC1,IC2,IC3,IC4,IC5,IC6,IC7,IC8,ICE, IV1,IV2,IV3,IVE,
     +        IL1,IL2,IL3,IL4,IL5,ILAG,IL6,ILE
      COMMON /COLIXW/ IC1,IC2,IC3,IC4,IC5,IC6,IC7,IC8,ICE,
     +                IV1,IV2,IV3,IVE, IL1,IL2,IL3,IL4,IL5,ILAG,IL6,ILE
      SAVE /COLIXW/
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER NOUT, NEQN, IERROR
      REAL T
      REAL WKAREA(*), YE(NEQN), UE(NEQN), GEE(NEQN)
C                                                                      I
C CHANGES IN COMMON VARIABLES: NONE                                    I
C ---------------------------                                          I
C                                                                      I
C ---------------------------------------------------------------------I
C
      INTEGER I
      REAL AERE, AVH, ERRU, MAXH, MINH, VARH, X, YU
      EXTERNAL AERE
*
      AVH = 0.0
      VARH = 0.0
      MINH = HMAX
      MAXH = HMIN
      DO 10 I = 0, N-1
         AVH = AVH + WKAREA(IV1+I)
         MINH = MIN(MINH, WKAREA(IV1+I))
         MAXH = MAX(MAXH, WKAREA(IV1+I))
   10 CONTINUE
      AVH = AVH / N
      IF (N .GT. 1) THEN
         DO 20 I = 0, N-1
            X = WKAREA(IV1+I)-AVH
            VARH = VARH + X*X
   20    CONTINUE
         VARH = VARH / (N-1)
      ELSE
         VARH = -1.0
      ENDIF
      WRITE(NOUT,1000) IERROR, AVH, VARH, MINH, MAXH, N, NHFAIL,
     +                 NKEV, NNIT, NCPS, T
*
      IF (IERROR .EQ. 0) THEN
         YU     = YE(1) - UE(1)
         ERRU   = AERE (YE(1),UE(1))
         WRITE(NOUT,1001) GEE(1), YU, ERRU
         DO 30 I = 2, NEQN
            YU     = YE(I) - UE(I)
            ERRU   = AERE (YE(I),UE(I))
            WRITE(NOUT,1002) GEE(I), YU, ERRU
   30    CONTINUE
      ENDIF
*
      RETURN
 1000 FORMAT('-','COLVI2 SUMMARY:',/,
     +       ' IERROR =',I4,/,
     +       ' AVERAGE STEP   =',F10.7,T40,'VARIANCE       =',E10.3,/,
     +       ' MIN. STEP      =',F10.7,T40,'MAX. STEP      =',F10.7,/,
     +       ' # SUCC. STEPS  =',I10,  T40,'# FAILURES     =',I10,/,
     +       ' # KEV.         =',I10,  T40,'# CORRECTOR IT.=',I10,/,
     +       ' # CP SECONDS   =',I10,  T40,'LAST T-VALUE   =',E10.3)
 1001 FORMAT('-GLOB.ERR.EST.=',E18.10,
     +                       T38,'GLOB.ERR.=',E18.10,T70,'SD =',F6.2)
 1002 FORMAT(' ',14X,E18.10,T48,E18.10,T74,F6.2)
      END
      SUBROUTINE ACVSUM (IERROR, WKAREA, TN, T0)
C
C ---------------------------------------------------------------------I
C PURPOSE: ACCUMULATE COUNTING VALUES IN COMMON BLOCK /COLCMI/ THAT AREI
C -------  ZEROED WHEN "COLVI2" IS CALLED MORE THAN ONCE.              I
C IF IERROR=15 (POLYNOMIAL SOLUTION) DECREASE "N" BY "NPGESC" TO       I
C DEMAND THAT "COLVI2" RECOMPUTES THE SOLUTION IN THE LAST "NPGESC"    I
C INTERVALS SINCE THE STEPSIZE CHOICE HAS BEEN UNRELIABLE THEREIN.     I
C ENTRY SCVSUM: STORE ACCUMULATED VALUES IN /COLCMI/                   I
C ------------                                                         I
C                                                                      I
C COMMON VARIABLES:                                                    I
C ----------------                                                     I
      INTEGER METH, M, S, L, ORDER, ORDERQ, METHR, MR, SR, LR, ORDERR,
     +        ERRWGT, NHFAIL, NERR, NWIR, NSAV,
     +        MAXNC, MAXKEV, MAXCPS, N, NNIT, NKEV, NCPS
      COMMON /COLCMI/ METH, M, S, L, ORDER, ORDERQ,
     +                METHR, MR, SR, LR, ORDERR,
     +                ERRWGT, NHFAIL,
     +                NERR, NWIR, NSAV,
     +                MAXNC, MAXKEV, MAXCPS,
     +                N, NNIT, NKEV, NCPS
*
      INTEGER IC1,IC2,IC3,IC4,IC5,IC6,IC7,IC8,ICE, IV1,IV2,IV3,IVE,
     +        IL1,IL2,IL3,IL4,IL5,ILAG,IL6,ILE
      COMMON /COLIXW/ IC1,IC2,IC3,IC4,IC5,IC6,IC7,IC8,ICE,
     +                IV1,IV2,IV3,IVE, IL1,IL2,IL3,IL4,IL5,ILAG,IL6,ILE
*
      SAVE /COLCMI/, /COLIXW/
C                                                                      I
C PARAMETER SPECIFICATION:                                             I
C -----------------------                                              I
      INTEGER IERROR
      REAL TN, T0
      REAL WKAREA(*)
C TN     EXIT: IF IERROR=15: TN=T(N-2)                                 I
C                                                                      I
C CHANGES IN COMMON VARIABLES:                                         I
C ---------------------------                                          I
C ACVSUM:                                                              I
C N      IF IERROR=15: N = N-2                                         I
C SCVSUM:                                                              I
C NHFAIL SET TO SUM OF ALL NHFAIL VALUES                               I
C NNIT   SET TO SUM OF ALL NNIT VALUES                                 I
C NKEV   SET TO SUM OF ALL NKEV VALUES                                 I
C NCPS   SET TO SUM OF ALL NCPS VALUES                                 I
C                                                                      I
C CONSTANTS:                                                           I
C ---------                                                            I
      INTEGER NPGESC
      PARAMETER (NPGESC = 2)
C                                                                      I
C ---------------------------------------------------------------------I
C
      INTEGER I, SNCPS, SNHFAI, SNKEV, SNNIT
      SAVE       SNCPS, SNHFAI, SNKEV, SNNIT
*
      IF (IERROR .EQ. -1) THEN
C INITIALIZE SAVE VARIABLES ON ZERO
         SNHFAI = 0
         SNNIT  = 0
         SNKEV  = 0
         SNCPS  = 0
*
         RETURN
      ENDIF
C
C ACCUMULATE NHFAIL, NKEV, NNIT, NCPS
      SNHFAI = SNHFAI + NHFAIL
      SNNIT  = SNNIT  + NNIT
      SNKEV  = SNKEV  + NKEV
      SNCPS  = SNCPS  + NCPS
C
C IF REQUIRED STEP BACK
      IF (IERROR .EQ. 15) THEN
         IF (N-NPGESC .LE. 0) THEN
            SNHFAI = SNHFAI + N+1
            N      = 0
            TN     = T0
         ELSE
            SNHFAI = SNHFAI + NPGESC+1
            DO 10 I = 1, NPGESC
               N      = N-1
               TN     = TN - WKAREA(IV1+N)
   10       CONTINUE
         ENDIF
      ENDIF
*
      RETURN
C
C
      ENTRY SCVSUM
C
C STORE ACCUMULATED VALUES IN /COLCMI/
      NHFAIL = NHFAIL + SNHFAI
      NNIT   = NNIT   + SNNIT
      NKEV   = NKEV   + SNKEV
      NCPS   = NCPS   + SNCPS
*
      RETURN
      END
      SUBROUTINE PRBINI (NEQN, LINEAR, T0, TE)
C
C PROBLEM DEFINITION FOR DRIVER 1-4.
C SEE SECTION 4 OF
C      BLOM, J.G. AND BRUNNER, H.,
C      "DISCRETIZED COLLOCATION AND ITERATED COLLOCATION FOR NONLINEAR
C      VOLTERRA INTEGRAL EQUATIONS OF THE SECOND KIND", REPORT NM-R8618,
C      CWI, AMSTERDAM, 1986. (TO APPEAR IN ACM-TOMS)
C
      INTEGER NEQN
      LOGICAL LINEAR
      REAL T0, TE
*
      NEQN   = 2
      LINEAR = .FALSE.
      T0     =  0.0
      TE     = 50.0
         RETURN
      END
      SUBROUTINE PRBTXT (NOUT, T0, TE)
      INTEGER NOUT
      REAL T0, TE
*
      CHARACTER*10 VAROUT
      CHARACTER*76 ID
      CHARACTER*66 F1, F2
*
      WRITE(NOUT,'(1H1)')
      WRITE(NOUT,1000)
*
      WRITE (VAROUT,'(F4.2,1H,,F5.2)') T0, TE
      ID = 'HETHCOTE AND TUDOR, I = ['//VAROUT//']'
      WRITE(NOUT,1001) ID
*
      F1 = ' .031716689391939'
      F2 = ' .627846272097799'
      WRITE(NOUT,1002) 'Y(50)    =', F1, F2
*
      F1 = '      A^21/ 100'
      F2 = ' (1+(10-A^20).A) / 100'
      WRITE(NOUT,1002) 'G(T)     =', F1, F2
*
      F1 = ' (    B^21          0   ) ( 3.Y(1).(1-Y(1)-Y(2)) )'
      F2 = ' ( (1-B^20).B    B/1000 ) (     1-Y(1)-Y(2)      )'
      WRITE(NOUT,1002) 'K(T,S,Y) =', F1, F2
*
      F1 = ' WHERE A = EXP(-T/20)  AND  B = EXP((S-T)/20)'
      WRITE(NOUT,1002) '          ', F1
      WRITE(NOUT,1000)
*
      RETURN
 1000 FORMAT(' ',79('-'))
 1001 FORMAT(' ','I ',A,T80,'I')
 1002 FORMAT(' ','I ',A10,A66,'I',:,/,
     +       ' ','I ',10X,A66,'I')
      END
      SUBROUTINE YEXACT (T, Y)
      REAL T, Y(*)
*
      IF (ABS(T-50.0) .LT. 1E-10) THEN
         Y(1) = .031716689391939
         Y(2) = .62784627209779
      ELSE
         Y(1) = 0.0
         Y(2) = 0.0
      ENDIF
         RETURN
      END
      SUBROUTINE G (T, GV)
      REAL T, GV(*)
*
      GV(1) = EXP(-21*T/20)/100
      GV(2) = (1+(10-EXP(-T))*EXP(-T/20))/100
         RETURN
      END
      SUBROUTINE KC (T, S, Y, KV)
      REAL T, S, Y(*), KV(*)
*
      REAL A11, A12, A21, A22, V1, V2
*
      A11 = EXP(21*(S-T)/20)
      A12 = 0.0
      A21 = (1-EXP(S-T))*EXP((S-T)/20)
      A22 = EXP((S-T)/20)/1000
      V1  = 3*Y(1)*(1-Y(1)-Y(2))
      V2  = 1-Y(1)-Y(2)
      KV(1) = A11*V1 + A12*V2
      KV(2) = A21*V1 + A22*V2
         RETURN
      END
      SUBROUTINE DKCDY (T, S, Y, DKV)
      REAL T, S, Y(*), DKV(2,*)
*
      REAL A11, A12, A21, A22, V1, V2
*
      A11 = EXP(21*(S-T)/20)
      A12 = 0.0
      A21 = (1-EXP(S-T))*EXP((S-T)/20)
      A22 = EXP((S-T)/20)/1000
      V1  = 3*Y(1)*(1-Y(1)-Y(2))
      V2  = 1-Y(1)-Y(2)
      DKV(1,1) = A11*(3-6*Y(1)-3*Y(2)) - A12
      DKV(1,2) = A11*(-3*Y(1))         - A12
      DKV(2,1) = A21*(3-6*Y(1)-3*Y(2)) - A22
      DKV(2,2) = A21*(-3*Y(1))         - A22
         RETURN
C ------------- END OF PROBLEM DEFINITION FOR DRIVER 1-4 ---------------
      END
      PROGRAM DRIVER
C
C PASS 1 - PASS 6: DEMONSTRATE SIMPLE USE OF "COLVI2"
C      USE DEFOPT = 21, 22, 1, 2 OR SMALL CHANGES ON THE DEFAULT VALUES
C   1: DEFOPT=21 (GAUSS8+ITERATED GAUSS) -I FUNCTIONAL ITERATION (ONLY
C   2: DEFOPT=22 (LOBATTO6+LOBATTO7)     -I DUMMY "DKCDY" ROUT. NEEDED)
C   3: DEFOPT= 1 (AS PASS 1, BUT WITH NEWTON ITERATION)
C   4: DEFOPT= 2 (AS PASS 2, BUT WITH NEWTON ITERATION)
C   SINCE DEFOPT>0, IOPT, OPT AND CNTRL ARRAYS ARE NOT USED IN THE FIRST
C   FOUR PASSES; IN THE NEXT TWO PASSES THEY HAVE TO BE DECLARED BUT CAN
C   MAINLY BE ZEROED.
C   5: SAME OPTIONS AS PASS 4, BUT FOR MAXIMUM STEPSIZE SET TO 10.0
C   6: SAME OPTIONS AS PASS 3, BUT FOR 2-POINTS GAUSS I.S.O. 8-POINTS
C NB: THESE PASSES CAN BE INDEPENDENTLY EXECUTED BY ADAPTING THE LOOP
C --  CONTROL STATEMENT
C        DO 10 IPASS = ..,..
C     BELOW.
C
C   FOR A MORE COMPREHENSIVE DESCRIPTION OF THESE PASSES SEE SECTION 4 O
C      BLOM, J.G. AND BRUNNER, H.,
C      "DISCRETIZED COLLOCATION AND ITERATED COLLOCATION FOR NONLINEAR
C      VOLTERRA INTEGRAL EQUATIONS OF THE SECOND KIND", REPORT NM-R8618,
C      CWI, AMSTERDAM, 1986. (TO APPEAR IN ACM-TOMS)
C
      INTEGER NOUT, NIOPT, NOPT, NCNTRL, MAXNEQ, MAXWS
      PARAMETER (NOUT = 7)
      PARAMETER (NIOPT = 9, NOPT = 4, NCNTRL = 4)
      PARAMETER (MAXNEQ = 2, MAXWS = 2000)
*
      INTEGER DEFOPT, I, IERROR, IPASS, J, NEQN
      INTEGER IOPT(NIOPT), CNTRL(NCNTRL)
      LOGICAL LINEAR
      REAL REQTOL, T0, TE, T
      REAL OPT(NOPT), WKAREA(MAXWS), YV(MAXNEQ), UE(MAXNEQ), GEE(MAXNEQ)
      EXTERNAL G, KC, DKCDY, YEXACT
C
C CHECK IF DOCUMENTATION IS AVAILABLE
      CALL COLDOC
C
C OPEN OUTPUT FILE
      OPEN(UNIT=NOUT, FILE='OUTPUT')
C
C GET INFO ABOUT VIE2
      CALL PRBINI (NEQN, LINEAR, T0, TE)
C
C PRINT PROBLEM INFO
      CALL PRBTXT (NOUT, T0, TE)
C
C RUN TESTS
      DO 10 IPASS = 1, 6
C
C GET INPUT PARAMETERS FOR COLVI2
         REQTOL = 1E-4
         DEFOPT = IPASS
         IF (IPASS .LE. 2) THEN
C           DEFOPT = 21, 22 (FUNCTIONAL ITERATION; GAUSS8+ITER. GAUSS,
C             RESP., LOBATTO6+LOBATTO7)
            DEFOPT = IPASS+20
            WRITE(NOUT,1000) IPASS, REQTOL, DEFOPT
         ELSE IF (IPASS .LE. 4) THEN
C           DEFOPT = 1, 2 (NEWTON'S METHOD, ONE JACOBIAN EACH ITERATION;
C             GAUSS8+ITERATED GAUSS, RESP., LOBATTO6+LOBATTO7)
            DEFOPT = IPASS-2
            WRITE(NOUT,1000) IPASS, REQTOL, DEFOPT
         ELSE
C           NO GENERAL DEFAULTS; IOPT, OPT AND CNTRL ARRAYS HAVE TO BE
C             FILLED, ZERO FOR DEFAULTS)
            DEFOPT = 0
            WRITE(NOUT,1000) IPASS, REQTOL, DEFOPT
            DO 20 I = 1, NIOPT
               IOPT(I) = 0
   20       CONTINUE
            DO 30 I = 1, NOPT
               OPT(I) = 0.0
   30       CONTINUE
            DO 40 I = 1, NCNTRL
               CNTRL(I) = 0
   40       CONTINUE
            IF (IPASS .EQ. 5) THEN
C              PASS 5, OPTIONS AS WHEN  DEFOPT=2, BUT  HMAX = 10.0
C              SOLUTION METHOD: 6-POINT LOBATTO
               IOPT(1) = 63
C              METHOD REFERENCE SOLUTION: 7-POINT LOBATTO
               IOPT(8) = 73
C              MAXIMUM STEPSIZE 10.0
               OPT(3)  = 10.0
C              INTERVAL LENGTH FOR UNIFORM ERROR CONTROL
               OPT(4)  = 1.0
            ELSE
C              PASS 6, OPTIONS AS DEFOPT=1, BUT USE 2-POINT GAUSS COLL.
C              SOLUTION METHOD: 2-POINT GAUSS
               IOPT(1) = 21
C              METHOD REFERENCE SOLUTION: ITERATED GAUSS
               IOPT(8) = 21
            ENDIF
*
            WRITE(NOUT,1001) ( IOPT(I), I=1, NIOPT)
            WRITE(NOUT,1002) (  OPT(I), I=1, NOPT)
            WRITE(NOUT,1003) (CNTRL(I), I=1, NCNTRL)
         ENDIF
C
C SOLVE VIE2
         CALL COLVI2 (NEQN, G, KC, DKCDY, LINEAR, T0, TE, REQTOL,
     +                DEFOPT, IOPT,OPT,CNTRL,
     +                WKAREA, MAXWS, T, UE, GEE, IERROR)
         IF (0 .LT. IERROR .AND. IERROR .LT. 10)
C         INPUT PARAMETER ERRORS
     +      GOTO 10
C
C GIVE SUMMARY OF RESULTS
         CALL YEXACT(T, YV)
         CALL SUMARY (NOUT, NEQN, WKAREA, YV, T, UE, GEE, IERROR)
C
         IF (IERROR .EQ. 0) THEN
C COMPUTE SOLUTION HALFWAY
            CALL YEXACT(T/2, YV)
            CALL COMPUH (T/2, NEQN, T0, WKAREA, UE)
            WRITE(NOUT,1004) T/2, YV(1), UE(1), YV(1) - UE(1)
            DO 60 J = 2, NEQN
               WRITE(NOUT,1005) YV(J), UE(J), YV(J) - UE(J)
   60       CONTINUE
         ENDIF
   10 CONTINUE
*
 1000 FORMAT ('1','PASS:',I2,/,
     +        ' ','REQTOL=',E8.2,', DEFOPT=',I2)
 1001 FORMAT (' ',' IOPT: (',I4,',',I4,',',I4,',',I4,',',I4,',',I4,',',
     +                       I4,',',I4,',',I4,')')
 1002 FORMAT (' ','  OPT: (',E7.1,',',E7.1,',',E7.1,',',E7.1,')')
 1003 FORMAT (' ','CNTRL: (',I4,',',I4,',',I4,',',I4,')')
 1004 FORMAT('-','  T ',10X,'Y(T)',16X,'UH(T)',13X,'Y(T)-UH(T)',/,
     +       ' ',F6.2,2E20.10,E15.3)
 1005 FORMAT(' ',6X,2E20.10,E15.3)
C ------------------- END OF DRIVER 1 ----------------------------------
      END
      PROGRAM DRIVER
C
C SAME PROBLEM DEFINITION AS FOR DRIVER 1.
C
C PASS 7 - PASS 8: DEMONSTRATE RE-ENTRY FACILITY OF "COLVI2"
C      WRITE INTERMEDIATE RESULTS TO FILE TO SHOW TRANSITION
C   7: SAME OPTIONS AS PASS 5; DIVIDE INTEGRATION INTERVAL IN 2 PARTS
C   8: AS PASS 6 BUT WITHOUT AUTOMATIC ESCAPE; NEEDS MORE WORKING SPACE
C      BECAUSE GLOB.ERR.EST. IN "TE" USES SEPARATELY COMPUTED REF.SOL.
C
      INTEGER NOUT, NIOPT, NOPT, NCNTRL, MAXNEQ, MAXWS
      PARAMETER (NOUT = 7)
      PARAMETER (NIOPT = 9, NOPT = 4, NCNTRL = 4)
      PARAMETER (MAXNEQ = 2, MAXWS = 3000)
*
      INTEGER DEFOPT, I, IERROR, IPASS, NEQN
      INTEGER IOPT(NIOPT), CNTRL(NCNTRL)
      LOGICAL LINEAR, WRIFIL
      REAL REQTOL, T0, TE, T
      REAL OPT(NOPT), WKAREA(MAXWS), YV(MAXNEQ), UE(MAXNEQ), GEE(MAXNEQ)
*
      EXTERNAL G, KC, DKCDY, YEXACT
C
C OPEN OUTPUT FILE
      OPEN(UNIT=NOUT, FILE='OUTPUT')
C
C GET INFO ABOUT VIE2
      CALL PRBINI (NEQN, LINEAR, T0, TE)
C
C RUN TESTS
      DO 10 IPASS = 7, 8
C
C INITIALIZING CALL OF ROUTINE "ACVSUM" THAT ACCUMULATES THE COUNTING
C VARIABLES  IN THE COMMON BLOCKS USED BY "COLVI2"
         CALL ACVSUM (-1, WKAREA, T0, T0)
C
C GET INPUT PARAMETERS FOR COLVI2
         WRIFIL = .FALSE.
         REQTOL = 1E-4
         DEFOPT = 0
         WRITE(NOUT,1000) IPASS, REQTOL, DEFOPT
         DO 20 I = 1, NIOPT
            IOPT(I) = 0
   20    CONTINUE
         DO 30 I = 1, NOPT
            OPT(I) = 0.0
   30    CONTINUE
         DO 40 I = 1, NCNTRL
            CNTRL(I) = 0
   40    CONTINUE
C    WRITE INTERMEDIATE RESULTS TO OUTPUT FILE
         CNTRL(3) = NOUT
         IF (IPASS .EQ. 7) THEN
C           PASS 7, OPTIONS AS IN PASS 5, BUT EXIT/RE-ENTRY AT TE/2
            TE = TE/2
            IOPT(1) = 63
            IOPT(8) = 73
             OPT(3) = 10.0
             OPT(4) =  1.0
         ELSE
C           PASS 8, SAME OPTIONS AS PASS 6, BUT RETURN TO MAIN PROGRAM
C                   WHEN POLYNOMIAL SOLUTION IS DETECTED
            IOPT(1) =  21
            IOPT(8) =  21
C           CHECK ON POLYNOMIAL SOLUTION; NO AUTOMATIC ESCAPE -> P=1
C           ALLOW RELAXATION OF TOLERANCE                     -> T=0
C           IOPT(9) = PT
            IOPT(9) = 10
         ENDIF
*
         WRIFIL = CNTRL(3) .NE. 0 .AND. CNTRL(3) .NE. NOUT
         IF (WRIFIL)
     +      OPEN (UNIT=CNTRL(3), FILE='INTRES')
         WRITE(NOUT,1001) ( IOPT(I), I=1, NIOPT)
         WRITE(NOUT,1002) (  OPT(I), I=1, NOPT)
         WRITE(NOUT,1003) (CNTRL(I), I=1, NCNTRL)
C
C SOLVE VIE2
         CALL COLVI2 (NEQN, G, KC, DKCDY, LINEAR, T0, TE, REQTOL,
     +                DEFOPT, IOPT,OPT,CNTRL,
     +                WKAREA, MAXWS, T, UE, GEE, IERROR)
         IF (0 .LT. IERROR .AND. IERROR .LT. 10)
C          INPUT PARAMETER ERRORS
     +      GOTO 50
C
C GIVE SUMMARY OF RESULTS
         CALL YEXACT(T, YV)
         CALL SUMARY (NOUT, NEQN, WKAREA, YV, T, UE, GEE, IERROR)
C
C ACCUMULATE COMMON VALUES THAT WILL BE ZEROED;
C    REACT ON POLYNOMIAL SOLUTION
         CALL ACVSUM (IERROR, WKAREA, T, T0)
C
C PREPARE FOR SECOND CALL OF COLVI2
         IF (IPASS .EQ. 7) THEN
C           PASS 7, ADJUST "TE", SET CNTRL(1)=3 (RE-ENTRY, SAME OPTIONS)
            TE = 2*TE
            IF (IERROR .NE. 0) GOTO 50
            CNTRL(1) = 3
         ELSE
C           PASS 8, SOLVI2 HAD A POLYN. SOL. EXIT,
C                   RE-ENTRY WITH DIFFERENT OPTIONS
            IF (IERROR .NE. 15) GOTO 50
C            ITERATED COLLOCATION IMPOSSIBLE, NEW METHOD FOR REF.SOL.
C            NOTE: IN ACVSUM COMMON VARIABLE "N" -> N-2
C            ----  => STEP BACK "NPGESC" (=2) STEPS ON SUSPICION OF BAD
C                     ERROR EST. AND THUS UNFOUNDED CHOICE OF STEPSIZE
C            THE DIFFERENCES WITH AUTOMATIC ESCAPE ARE:
C               ORDER OF APPROX. METHOD IS TAKEN "M", WHEREAS AFTER AN
C                  AUTOMATIC ESCAPE IT IS SET TO "2*M"
C               THE GLOBAL ERROR IN "TE" WILL BE APPROXIMATED BY THE
C                  DIFFERENCE BETWEEN A REF.SOL. COMPUTED WITH THE SAME
C                  STEPSIZES AS WERE USED IN THE APPROX. AND THE APPROX.
C                  I.S.O. THE SUM OF THE LOCAL ERRORS IN "TE"
C
C          REF.SOL. METHOD 3-POINTS GAUSS + C4=1
             IOPT(8) =  42
C          NO CHECK ON POLYNOMIAL SOLUTION -> P=2 (NOT USED, SINCE G=1)
C          LOCAL ERROR CONTROL             -> G=1
C          UNIFORM ERROR CONTROL           -> U=0
C          ALLOW RELAXATION OF TOLERANCE   -> T=0
C            IOPT(9) = PGUT
             IOPT(9) = 2100
C          ALLOW LARGE STEPS; SET MAXIMUM STEPSIZE TO 10, INTERVAL
C          LENGTH UNIFORM ERROR CONTROL TO 1
              OPT(3) = 10.0
              OPT(4) =  1.0
C          RE-ENTRY NEW OPTIONS
            CNTRL(1) = 1
         ENDIF
         WRITE(NOUT,1001) ( IOPT(I), I=1, NIOPT)
         WRITE(NOUT,1002) (  OPT(I), I=1, NOPT)
         WRITE(NOUT,1003) (CNTRL(I), I=1, NCNTRL)
C
C RE-ENTRY PROCESS OF SOLVING VIE2
         CALL COLVI2 (NEQN, G, KC, DKCDY, LINEAR, T0, TE, REQTOL,
     +                DEFOPT, IOPT,OPT,CNTRL,
     +                WKAREA, MAXWS, T, UE, GEE, IERROR)
         IF (0 .LT. IERROR .AND. IERROR .LT. 10)
C          INPUT PARAMETER ERRORS
     +      GOTO 50
C
C GIVE SUMMARY OF RESULTS
         CALL YEXACT(T, YV)
         CALL SUMARY (NOUT, NEQN, WKAREA, YV, T, UE, GEE, IERROR)
C
C STORE ACCUMULATED COMMON VALUES; GIVE SUMMARY
         CALL SCVSUM
         CALL SUMARY (NOUT, NEQN, WKAREA, YV, T, UE, GEE, IERROR)
C
C IF NECESSARY, CLOSE FILE FOR INTERMEDIATE RESULTS
   50    IF (WRIFIL) CLOSE(UNIT=CNTRL(3))
   10 CONTINUE
*
 1000 FORMAT ('1','PASS:',I2,:,/,
     +        ' ','REQTOL=',E8.2,', DEFOPT=',I2)
 1001 FORMAT (' ',' IOPT: (',I4,',',I4,',',I4,',',I4,',',I4,',',I4,',',
     +                       I4,',',I4,',',I4,')')
 1002 FORMAT (' ','  OPT: (',E7.1,',',E7.1,',',E7.1,',',E7.1,')')
 1003 FORMAT (' ','CNTRL: (',I4,',',I4,',',I4,',',I4,')')
 1004 FORMAT('-','  T ',10X,'Y(T)',16X,'UH(T)',13X,'Y(T)-UH(T)',/,
     +       ' ',F6.2,2E20.10,E15.3)
 1005 FORMAT(' ',6X,2E20.10,E15.3)
C
C ------------------- END OF DRIVER 2 ----------------------------------
      END
      PROGRAM DRIVER
C
C SAME PROBLEM DEFINITION AS FOR DRIVER 1.
C
C PASS 9: DEMONSTRATE SAVE FACILITY OF "COLVI2"
C         SAME OPTIONS AS PASS 5; WORKING STORAGE DIMINISHED TO FORCE
C         AN EXIT BECAUSE OF A LACK OF WORKING STORAGE
C
      INTEGER NOUT, NSAV, NIOPT, NOPT, NCNTRL, MAXNEQ, MAXWS
      PARAMETER (NOUT = 7, NSAV = 99)
      PARAMETER (NIOPT = 9, NOPT = 4, NCNTRL = 4)
      PARAMETER (MAXNEQ = 2, MAXWS = 1000)
*
      INTEGER DEFOPT, I, IERROR, IPASS, NEQN
      INTEGER IOPT(NIOPT), CNTRL(NCNTRL)
      LOGICAL EX, LINEAR, WRIFIL
      REAL REQTOL, T0, TE, T
      REAL OPT(NOPT), WKAREA(MAXWS), YV(MAXNEQ), UE(MAXNEQ), GEE(MAXNEQ)
*
      EXTERNAL G, KC, DKCDY, YEXACT
C
C OPEN OUTPUT FILE
      OPEN(UNIT=NOUT, FILE='OUTPUT')
C
C GET INFO ABOUT VIE2
      CALL PRBINI (NEQN, LINEAR, T0, TE)
C
C RUN TESTS
      DO 10 IPASS = 9, 9
C
C GET INPUT PARAMETERS FOR COLVI2
         WRIFIL = .FALSE.
         REQTOL = 1E-4
         DEFOPT = 0
         WRITE(NOUT,1000) IPASS, REQTOL, DEFOPT
         DO 20 I = 1, NIOPT
            IOPT(I) = 0
   20    CONTINUE
         DO 30 I = 1, NOPT
            OPT(I) = 0.0
   30    CONTINUE
         DO 40 I = 1, NCNTRL
            CNTRL(I) = 0
   40    CONTINUE
         IOPT(1) = 63
         IOPT(8) = 73
          OPT(3) = 10.0
          OPT(4) =  1.0
C    WRITE INTERMEDIATE RESULTS TO OUTPUT FILE
         CNTRL(3) = NOUT
C    SAVE AFTER ERROR ON FILE WITH LOG. UNIT NR. "NSAV" (=99)
         CNTRL(4) = NSAV
*
         WRIFIL = CNTRL(3) .NE. 0 .AND. CNTRL(3) .NE. NOUT
         IF (WRIFIL)
     +      OPEN (UNIT=CNTRL(3), FILE='INTRES')
         WRITE(NOUT,1001) ( IOPT(I), I=1, NIOPT)
         WRITE(NOUT,1002) (  OPT(I), I=1, NOPT)
         WRITE(NOUT,1003) (CNTRL(I), I=1, NCNTRL)
C
C SOLVE VIE2
         CALL COLVI2 (NEQN, G, KC, DKCDY, LINEAR, T0, TE, REQTOL,
     +                DEFOPT, IOPT,OPT,CNTRL,
     +                WKAREA, MAXWS, T, UE, GEE, IERROR)
         IF (0 .LT. IERROR .AND. IERROR .LT. 10)
C          INPUT PARAMETER ERRORS
     +      GOTO 50
C
C GIVE SUMMARY OF RESULTS
         CALL YEXACT(T, YV)
         CALL SUMARY (NOUT, NEQN, WKAREA, YV, T, UE, GEE, IERROR)
C
C IF NECESSARY, CLOSE FILE FOR INTERMEDIATE RESULTS
   50    IF (WRIFIL) CLOSE(UNIT=CNTRL(3))
C
C IF ERROR SAVE, STOP TESTING TO PREVENT OVERWRITE FILE 'SAVFIL'
         INQUIRE(FILE='SAVFIL', EXIST=EX)
         IF (EX) THEN
            WRITE(NOUT,*) ' COLVI2 STOP AFTER PASS', IPASS
            STOP 'SAVE STOP'
         ENDIF
   10 CONTINUE
*
 1000 FORMAT ('1','PASS:',I2,:,/,
     +        ' ','REQTOL=',E8.2,', DEFOPT=',I1)
 1001 FORMAT (' ',' IOPT: (',I4,',',I4,',',I4,',',I4,',',I4,',',I4,',',
     +                       I4,',',I4,',',I4,')')
 1002 FORMAT (' ','  OPT: (',E7.1,',',E7.1,',',E7.1,',',E7.1,')')
 1003 FORMAT (' ','CNTRL: (',I4,',',I4,',',I4,',',I4,')')
 1004 FORMAT('-','  T ',10X,'Y(T)',16X,'UH(T)',13X,'Y(T)-UH(T)',/,
     +       ' ',F6.2,2E20.10,E15.3)
 1005 FORMAT(' ',6X,2E20.10,E15.3)
C ------------------- END OF DRIVER 3 ----------------------------------
      END
      PROGRAM DRIVER
C
C CONTINUATION OF PROBLEM SOLUTION OF DRIVER 3.
C
C PASS 10: DEMONSTRATE RE-ENTRY_AFTER_SAVE FACILITY OF "COLVI2"
C          SAME OPTIONS AS PREV. CALL; WORKING STORAGE ENLARGED
C
      INTEGER NOUT, NSAV, NIOPT, NOPT, NCNTRL, MAXNEQ, MAXWS
      PARAMETER (NOUT = 7, NSAV = 99)
      PARAMETER (NIOPT = 9, NOPT = 4, NCNTRL = 4)
      PARAMETER (MAXNEQ = 2, MAXWS = 2000)
*
      INTEGER DEFOPT, I, IERROR, IPASS, NEQN
      INTEGER IOPT(NIOPT), CNTRL(NCNTRL)
      LOGICAL EX, LINEAR, WRIFIL
      REAL REQTOL, T0, TE, T
      REAL OPT(NOPT), WKAREA(MAXWS), YV(MAXNEQ), UE(MAXNEQ), GEE(MAXNEQ)
*
      EXTERNAL G, KC, DKCDY, YEXACT
C
C OPEN OUTPUT FILE
      OPEN(UNIT=NOUT, FILE='OUTPUT')
C
C GET INFO ABOUT VIE2
      CALL PRBINI (NEQN, LINEAR, T0, TE)
C
C RUN TESTS
      DO 10 IPASS = 10, 10
C
C GET INPUT PARAMETERS FOR COLVI2
         WRIFIL = .FALSE.
         REQTOL = 1E-4
         DEFOPT = 0
         WRITE(NOUT,1000) IPASS, REQTOL, DEFOPT
C    RE-ENTRY AFTER SAVE, SAME OPTIONS
         CNTRL(1) = 4
         CNTRL(2) = 0
C    WRITE INTERMEDIATE RESULTS TO OUTPUT FILE
         CNTRL(3) = NOUT
C    SAVE AFTER ERROR ON FILE WITH LOG. UNIT NR. "NSAV" (=99)
         CNTRL(4) = NSAV
*
         WRIFIL = CNTRL(3) .NE. 0 .AND. CNTRL(3) .NE. NOUT
         IF (WRIFIL)
     +      OPEN (UNIT=CNTRL(3), FILE='INTRES')
         WRITE(NOUT,1003) (CNTRL(I), I=1, NCNTRL)
C
C RESUME PROCESS OF SOLVING VIE2
         CALL COLVI2 (NEQN, G, KC, DKCDY, LINEAR, T0, TE, REQTOL,
     +                DEFOPT, IOPT,OPT,CNTRL,
     +                WKAREA, MAXWS, T, UE, GEE, IERROR)
         IF (0 .LT. IERROR .AND. IERROR .LT. 10)
C          INPUT PARAMETER ERRORS
     +      GOTO 50
C
C GIVE SUMMARY OF RESULTS, NOTE THAT #FAILURES, #KEV, #CORRECTOR_IT.
C    AND #CP_SECONDS ARE ZEROED ON RE-ENTRY
         CALL YEXACT(T, YV)
         CALL SUMARY (NOUT, NEQN, WKAREA, YV, T, UE, GEE, IERROR)
C
C IF NECESSARY, CLOSE FILE FOR INTERMEDIATE RESULTS
   50    IF (WRIFIL) CLOSE(UNIT=CNTRL(3))
C
C IF ERROR SAVE, STOP TESTING TO PREVENT OVERWRITE FILE 'SAVFIL'
         INQUIRE(FILE='SAVFIL', EXIST=EX)
         IF (EX) THEN
            WRITE(NOUT,*) ' COLVI2 STOP AFTER PASS', IPASS
            STOP 'SAVE STOP'
         ENDIF
   10 CONTINUE
*
 1000 FORMAT ('1','PASS:',I2,:,/,
     +        ' ','REQTOL=',E8.2,', DEFOPT=',I1)
 1001 FORMAT (' ',' IOPT: (',I4,',',I4,',',I4,',',I4,',',I4,',',I4,',',
     +                       I4,',',I4,',',I4,')')
 1002 FORMAT (' ','  OPT: (',E7.1,',',E7.1,',',E7.1,',',E7.1,')')
 1003 FORMAT (' ','CNTRL: (',I4,',',I4,',',I4,',',I4,')')
 1004 FORMAT('-','  T ',10X,'Y(T)',16X,'UH(T)',13X,'Y(T)-UH(T)',/,
     +       ' ',F6.2,2E20.10,E15.3)
 1005 FORMAT(' ',6X,2E20.10,E15.3)
C ------------------- END OF DRIVER 4 ----------------------------------
      END
      PROGRAM DRIVER
C
C SOLVE LOGAN PROBLEM OVER THE INTERVAL [0,500].
C FOR PROBLEM DEFINITION SEE BELOW IN SUBROUTINE PRBINI.
C
C PASS 11: DEMONSTRATE SAVE FACILITY OF "COLVI2" AFTER ARITHMETIC ERROR
C          OTHER PROBLEM, LOOOOONG INTEGR. PATH.; USE FUNCTIONAL ITER.
C          NO DKCDY NEEDED. EMPLOY RADAU INTEGRATION; HMAX = 10.0 AND
C          UNIFORM ERROR CONTROL WITH HC=10.0 (=HMAX)
C          FOR THIS DEMONSTRATION WE NEED A SYSTEM ROUTINE THAT ALLOWS
C          THE USER TO REGAIN CONTROL AFTER ARITHMETIC MODE ERRORS
C
      INTEGER NOUT, NSAV, NIOPT, NOPT, NCNTRL, MAXNEQ, MAXWS
      PARAMETER (NOUT = 7, NSAV = 99)
      PARAMETER (NIOPT = 9, NOPT = 4, NCNTRL = 4)
      PARAMETER (MAXNEQ = 1, MAXWS = 5000)
*
      INTEGER DEFOPT, I, IERROR, IPASS, NEQN
      INTEGER IOPT(NIOPT), CNTRL(NCNTRL)
      LOGICAL ERRFIL, EX, LINEAR, WRIFIL
      REAL REQTOL, T0, TE, T
      REAL OPT(NOPT), WKAREA(MAXWS), YV(MAXNEQ), UE(MAXNEQ), GEE(MAXNEQ)
*
      EXTERNAL G, KC, DKCDY, YEXACT
      EXTERNAL ERRSAV
C
C "RECOVR" IS A CYBER-750 SYSTEM ROUTINE THAT ALLOWS A USER TO GAIN
C CONTROL AT THE TIME THAT NORMAL OR ABNORMAL JOB TERMINATION PROCEDURES
C WOULD OTHERWISE OCCUR.
C AT THE BEGINNING OF THE PROGRAM "RECOVR" HAS TO BE INITIALIZED
C FIRST PARAMETER CONTAINS THE ADDRESS OF THE USER RECOVERY RECODE, I.E.
C    THE NAME OF THE SUBROUTINE THAT IS TO BE EXECUTED (MUST BE DECLARED
C    IN AN EXTERNAL STATEMENT)
C SECOND PARAMETER CONTAINS FLAGS FOR CONDITIONS UNDER WHICH RECOVERY
C    CODE IS TO BE EXECUTED. (OCTAL 001 => ARITHMETIC MODE ERROR)
C OTHER PARAMETERS NOT RELEVANT
      CALL RECOVR(ERRSAV, 1, 0,0,0)
C
C OPEN OUTPUT FILE
      OPEN(UNIT=NOUT, FILE='OUTPUT')
C
C GET INFO ABOUT VIE2
      CALL PRBINI (NEQN, LINEAR, T0, TE)
C
C PRINT PROBLEM INFO
      CALL PRBTXT (NOUT, T0, TE)
C
C RUN TESTS
      DO 10 IPASS = 11, 11
C
C GET INPUT PARAMETERS FOR COLVI2
         ERRFIL = .FALSE.
         WRIFIL = .FALSE.
         REQTOL = 1E-4
         DEFOPT = 0
         WRITE(NOUT,1000) IPASS, REQTOL, DEFOPT
         DO 20 I = 1, NIOPT
            IOPT(I) = 0
   20    CONTINUE
         DO 30 I = 1, NOPT
            OPT(I) = 0.0
   30    CONTINUE
C    6-POINT RADAU FOR APPROXIMATION
         IOPT(1) = 64
C    FUNCTIONAL ITERATION
         IOPT(5) = 2
C    7-POINT RADAU FOR REF.SOL.
         IOPT(8) = 74
C    MAX. STEPSIZE = 10 (AS IS INTERVAL LENGTH FOR UNIF. ERROR CONTROL)
          OPT(3) = 10.0
C    FIRST ENTRY
         CNTRL(1) = 0
C    WRITE ERROR MESSAGES TO OUTPUT FILE
         CNTRL(2) = 0
C    WRITE INTERMEDIATE RESULTS TO OUTPUT FILE
         CNTRL(3) = NOUT
C    SAVE AFTER ERROR ON FILE WITH LOG. UNIT NR. "NSAV" (=99)
         CNTRL(4) = NSAV
*
         ERRFIL = CNTRL(2) .NE. 0 .AND. CNTRL(2) .NE. NOUT
         WRIFIL = CNTRL(3) .NE. 0 .AND. CNTRL(3) .NE. NOUT .AND.
     +            CNTRL(3) .NE. CNTRL(2)
         IF (ERRFIL)
     +      OPEN (UNIT=CNTRL(2), FILE='ERRMESS')
         IF (WRIFIL)
     +      OPEN (UNIT=CNTRL(3), FILE='INTRES')
         WRITE(NOUT,1001) ( IOPT(I), I=1, NIOPT)
         WRITE(NOUT,1002) (  OPT(I), I=1, NOPT)
         WRITE(NOUT,1003) (CNTRL(I), I=1, NCNTRL)
*
         CALL CALVI2 (NEQN, G, KC, DKCDY, LINEAR, T0, TE, REQTOL,
     +                DEFOPT, IOPT,OPT,CNTRL,
     +                WKAREA, MAXWS, T, UE, GEE, IERROR)
         IF (0 .LT. IERROR .AND. IERROR .LT. 10)
C          INPUT PARAMETER ERRORS
     +      GOTO 50
C
C GIVE SUMMARY OF RESULTS
         CALL YEXACT(T, YV)
         CALL SUMARY (NOUT, NEQN, WKAREA, YV, T, UE, GEE, IERROR)
C
C IF NECESSARY, CLOSE ERROR_MESSAGE_FILE AND FILE FOR INTERMED. RESULTS
   50    IF (ERRFIL) CLOSE(UNIT=CNTRL(2))
         IF (WRIFIL) CLOSE(UNIT=CNTRL(3))
C
C IF ERROR SAVE, STOP TESTING TO PREVENT OVERWRITE FILE 'SAVFIL'
         INQUIRE(FILE='SAVFIL', EXIST=EX)
         IF (EX) THEN
            WRITE(NOUT,*) ' COLVI2 STOP AFTER PASS', IPASS
            STOP 'SAVE STOP'
         ENDIF
   10 CONTINUE
*
 1000 FORMAT ('-','PASS:',I2,:,/,
     +        ' ','REQTOL=',E8.2,', DEFOPT=',I2)
 1001 FORMAT (' ',' IOPT: (',I4,',',I4,',',I4,',',I4,',',I4,',',I4,',',
     +                       I4,',',I4,',',I4,')')
 1002 FORMAT (' ','  OPT: (',E7.1,',',E7.1,',',E7.1,',',E7.1,')')
 1003 FORMAT (' ','CNTRL: (',I4,',',I4,',',I4,',',I4,')')
 1004 FORMAT('-','  T ',10X,'Y(T)',16X,'UH(T)',13X,'Y(T)-UH(T)',/,
     +       ' ',F6.2,2E20.10,E15.3)
 1005 FORMAT(' ',6X,2E20.10,E15.3)
      END
      SUBROUTINE PRBINI (NEQN, LINEAR, T0, TE)
C
C PROBLEM DEFINITION FOR DRIVER 5
C Y(T) = G(T) - (0,T) INT T/EXP((Y-1)**2) DS
C                        I- (-ERF(1-T))  IF T<=1
C    G(T) = T + ERF(1) + I
C                        I- (ERF(T-1))   IF T>1
C    Y(T) = T
C    (LOGAN, J.E. [1976]. THE APPROXIMATION OF VOLTERRA INTEGRAL
C     EQUATIONS OF THE SECOND KIND, PHD THESIS,
C     UNIVERSITY OF IOWA, IOWA CITY).
C NB IN THE PROBLEM DEFINING ROUTINES BELOW THE FUNCTION ERF IS USED
C -- WHICH IS NOT A STANDARD FORTRAN-77 INTRINSIC FUNCTION. IF IT IS
C    AVAILABLE IN THE FORTRAN RUNTIME SYSTEM IT CAN BE CALLED FROM
C    A MATHEMATICAL LIBRARY.
C
      INTEGER NEQN
      LOGICAL LINEAR
      REAL T0, TE
      COMMON /PROB/ ERF1, SPI2
*
      ERF1  = ERF(1.0)
      SPI2   = SQRT(4*ATAN(1.0))/2
*
      NEQN   = 1
      LINEAR = .FALSE.
      T0     =   0.0
      TE     = 500.0
         RETURN
      END
      SUBROUTINE PRBTXT (NOUT, T0, TE)
      INTEGER NOUT
      REAL T0, TE
*
      CHARACTER*10 VAROUT
      CHARACTER*76 ID
      CHARACTER*66 F1
*
      WRITE(NOUT,'(1H1)')
      WRITE(NOUT,1000)
*
      WRITE (VAROUT,'(F3.1,1H,,F6.1)') T0, TE
      ID = 'RECOVER TEST PROBLEM,        I = ['//VAROUT//']'
      WRITE(NOUT,1001) ID
*
      F1 = ' T'
      WRITE(NOUT,1002) 'Y(T)     =', F1
*
      F1 = ' T - (0,T) INT K(T,S,Y)DS'
      WRITE(NOUT,1002) 'G(T)     =', F1
*
      F1 = ' -T / EXP((Y-1)^2)'
      WRITE(NOUT,1002) 'K(T,S,Y) =', F1
*
      WRITE(NOUT,1000)
*
      RETURN
 1000 FORMAT(' ',79('-'))
 1001 FORMAT(' ','I ',A,T80,'I')
 1002 FORMAT(' ','I ',A10,A66,'I')
      END
      SUBROUTINE YEXACT (T, Y)
      REAL T, Y(*)
*
      Y(1) = T
         RETURN
      END
      SUBROUTINE G (T, GV)
      REAL T, GV(*)
      COMMON /PROB/ ERF1, SPI2
*
      IF (T .LE. 1.0) THEN
         X = -ERF(1-T)
      ELSE
         X = +ERF(T-1)
      ENDIF
      GV(1) = T + T * (ERF1+X)*SPI2
         RETURN
      END
      SUBROUTINE KC (T, S, Y, KV)
      REAL T, S, Y(*), KV(*)
      COMMON /PROB/ ERF1, SPI2
*
      X = Y(1)-1.0
      KV(1) = -T / EXP(X*X)
         RETURN
      END
      SUBROUTINE DKCDY (T, S, Y, DKV)
         RETURN
C ------------- END OF PROBLEM DEFINITION FOR DRIVER 5 -----------------
      END
      SUBROUTINE CALVI2 (NEQN, G, KC, DKCDY, LINEAR, T0, TE, REQTOL,
     +                DEFOPT, IOPT,OPT,CNTRL,
     +                WKAREA, IW, T, UE, GEE, IERROR)
      INTEGER NEQN, DEFOPT, IOPT(*), CNTRL(*), IW, IERROR
      LOGICAL LINEAR
      REAL T0, TE, REQTOL, OPT(*), WKAREA(*), T, UE(*), GEE(*)
      EXTERNAL G, KC, DKCDY
      INTEGER EXCHPK(26), FLAG, MEMORY(*)
*
      CALL COLVI2 (NEQN, G, KC, DKCDY, LINEAR, T0, TE, REQTOL,
     +                DEFOPT, IOPT,OPT,CNTRL,
     +                WKAREA, IW, T, UE, GEE, IERROR)
*
      RETURN
*
      ENTRY ERRSAV (EXCHPK, FLAG, MEMORY)
*
C
C COPY CALL OF "SAVALL" FROM "COLVI2"
      CALL SAVALL (WKAREA, IW, DEFOPT, IOPT, OPT, TE, T)
C
C IF NOTHING HAS BEEN CHANGED IN EXCHANGE PACKAGE "EXCHPK" AND IN "FLAG"
C    JOB CONTINUES AS IF "RECOVR" HAD NOT BEEN CALLED; I.E. WITH AN
C    ABNORMAL TERMINATION BECAUSE OF AN ARITHMETIC MODE ERROR
      RETURN
C ------------------- END OF DRIVER 5 ----------------------------------
      END
      PROGRAM DRIVER
C
C SAME PROBLEM AS IN DRIVER 5, BUT BETTER IMPLEMENTATION OF KERNEL.
C
C PASS 12: DEMONSTRATE SAVE FACILITY OF "COLVI2" AFTER ARITHMETIC ERROR
C          IN PASS 11; ENLARGE HMAX TO 50.0, NO UNIFORM ERROR CONTROL
C
      INTEGER NOUT, NSAV, NIOPT, NOPT, NCNTRL, MAXNEQ, MAXWS
      PARAMETER (NOUT = 7, NSAV = 99)
      PARAMETER (NIOPT = 9, NOPT = 4, NCNTRL = 4)
      PARAMETER (MAXNEQ = 1, MAXWS = 5000)
*
      INTEGER DEFOPT, I, IERROR, IPASS, NEQN
      INTEGER IOPT(NIOPT), CNTRL(NCNTRL)
      LOGICAL ERRFIL, EX, LINEAR, WRIFIL
      REAL REQTOL, T0, TE, T
      REAL OPT(NOPT), WKAREA(MAXWS), YV(MAXNEQ), UE(MAXNEQ), GEE(MAXNEQ)
*
      EXTERNAL G, KC, DKCDY, YEXACT
C
C OPEN OUTPUT FILE
      OPEN(UNIT=NOUT, FILE='OUTPUT')
C
C GET INFO ABOUT VIE2
      CALL PRBINI (NEQN, LINEAR, T0, TE)
C
C RUN TESTS
      DO 10 IPASS = 12, 12
C
C GET INPUT PARAMETERS FOR COLVI2
         ERRFIL = .FALSE.
         WRIFIL = .FALSE.
         REQTOL = 1E-4
         DEFOPT = 0
         WRITE(NOUT,1000) IPASS, REQTOL, DEFOPT
         DO 20 I = 1, NIOPT
            IOPT(I) = 0
   20    CONTINUE
         DO 30 I = 1, NOPT
            OPT(I) = 0.0
   30    CONTINUE
C    6-POINT RADAU FOR APPROXIMATION
         IOPT(1) = 64
C    FUNCTIONAL ITERATION
         IOPT(5) = 2
C    7-POINT RADAU FOR REF.SOL.
         IOPT(8) = 74
C    NO UNIFORM ERROR CONTROL (U=1, P=G=T=0; IOPT(9)=PGUT)
         IOPT(9) = 0010
C    MAX. STEPSIZE = 50
          OPT(3) = 50.0
C    RE-ENTRY AFTER SAVE, NEW OPTIONS
         CNTRL(1) = 2
C    WRITE ERROR MESSAGES TO OUTPUT FILE
         CNTRL(2) = 0
C    WRITE INTERMEDIATE RESULTS TO OUTPUT FILE
         CNTRL(3) = NOUT
C    SAVE AFTER ERROR ON FILE WITH LOG. UNIT NR. "NSAV" (=99)
         CNTRL(4) = NSAV
*
         ERRFIL = CNTRL(2) .NE. 0 .AND. CNTRL(2) .NE. NOUT
         WRIFIL = CNTRL(3) .NE. 0 .AND. CNTRL(3) .NE. NOUT .AND.
     +            CNTRL(3) .NE. CNTRL(2)
         IF (ERRFIL)
     +      OPEN (UNIT=CNTRL(2), FILE='ERRMESS')
         IF (WRIFIL)
     +      OPEN (UNIT=CNTRL(3), FILE='INTRES')
         WRITE(NOUT,1001) ( IOPT(I), I=1, NIOPT)
         WRITE(NOUT,1002) (  OPT(I), I=1, NOPT)
         WRITE(NOUT,1003) (CNTRL(I), I=1, NCNTRL)
*
         CALL COLVI2 (NEQN, G, KC, DKCDY, LINEAR, T0, TE, REQTOL,
     +                DEFOPT, IOPT,OPT,CNTRL,
     +                WKAREA, MAXWS, T, UE, GEE, IERROR)
         IF (0 .LT. IERROR .AND. IERROR .LT. 10)
C          INPUT PARAMETER ERRORS
     +      GOTO 50
C
C GIVE SUMMARY OF RESULTS
         CALL YEXACT(T, YV)
         CALL SUMARY (NOUT, NEQN, WKAREA, YV, T, UE, GEE, IERROR)
C
C IF NECESSARY, CLOSE ERROR_MESSAGE_FILE AND FILE FOR INTERMED. RESULTS
   50    IF (ERRFIL) CLOSE(UNIT=CNTRL(2))
         IF (WRIFIL) CLOSE(UNIT=CNTRL(3))
C
C IF ERROR SAVE, STOP TESTING TO PREVENT OVERWRITE FILE 'SAVFIL'
         INQUIRE(FILE='SAVFIL', EXIST=EX)
         IF (EX) THEN
            WRITE(NOUT,*) ' COLVI2 STOP AFTER PASS', IPASS
            STOP 'SAVE STOP'
         ENDIF
   10 CONTINUE
*
 1000 FORMAT ('-','PASS:',I2,:,/,
     +        ' ','REQTOL=',E8.2,', DEFOPT=',I2)
 1001 FORMAT (' ',' IOPT: (',I4,',',I4,',',I4,',',I4,',',I4,',',I4,',',
     +                       I4,',',I4,',',I4,')')
 1002 FORMAT (' ','  OPT: (',E7.1,',',E7.1,',',E7.1,',',E7.1,')')
 1003 FORMAT (' ','CNTRL: (',I4,',',I4,',',I4,',',I4,')')
 1004 FORMAT('-','  T ',10X,'Y(T)',16X,'UH(T)',13X,'Y(T)-UH(T)',/,
     +       ' ',F6.2,2E20.10,E15.3)
 1005 FORMAT(' ',6X,2E20.10,E15.3)
      END
      SUBROUTINE PRBINI (NEQN, LINEAR, T0, TE)
C
C SAME PROBLEM DEFINITION AS IN DRIVER 5, BUT FOR CHECK IN KERNEL
C FUNCTION TO PREVENT OVERFLOW.
C
      INTEGER NEQN
      LOGICAL LINEAR
      REAL T0, TE
      COMMON /PROB/ ERF1, SPI2
*
      ERF1  = ERF(1.0)
      SPI2   = SQRT(4*ATAN(1.0))/2
*
      NEQN   = 1
      LINEAR = .FALSE.
      T0     =   0.0
      TE     = 500.0
         RETURN
      END
      SUBROUTINE YEXACT (T, Y)
      REAL T, Y(*)
*
      Y(1) = T
         RETURN
      END
      SUBROUTINE G (T, GV)
      REAL T, GV(*)
      COMMON /PROB/ ERF1, SPI2
*
      IF (T .LE. 1.0) THEN
         X = -ERF(1-T)
      ELSE
         X = +ERF(T-1)
      ENDIF
      GV(1) = T + T * (ERF1+X)*SPI2
         RETURN
      END
      SUBROUTINE KC (T, S, Y, KV)
      REAL T, S, Y(*), KV(*)
      COMMON /PROB/ ERF1, SPI2
*
      REAL XMAX
C                XMAX = SQRT(LN(SOVFLO))
      PARAMETER (XMAX = 27.2)
*
      X = Y(1)-1.0
      IF (X .LT. XMAX) THEN
         KV(1) = -T / EXP(X*X)
      ELSE
         KV(1) = 0.0
      ENDIF
         RETURN
      END
*
      SUBROUTINE DKCDY (T, S, Y, DKV)
         RETURN
C ------------------- END OF DRIVER 6 ----------------------------------
      END
1
 -------------------------------------------------------------------------------
 I HETHCOTE AND TUDOR, I = [0.00,50.00]                                        I
 I Y(50)    = .031716689391939                                                 I
 I            .627846272097799                                                 I
 I G(T)     =      A^21/ 100                                                   I
 I            (1+(10-A^20).A) / 100                                            I
 I K(T,S,Y) = (    B^21          0   ) ( 3.Y(1).(1-Y(1)-Y(2)) )                I
 I            ( (1-B^20).B    B/1000 ) (     1-Y(1)-Y(2)      )                I
 I            WHERE A = EXP(-T/20)  AND  B = EXP((S-T)/20)                     I
 -------------------------------------------------------------------------------
-PASS: 1
 REQTOL= .10E-03, DEFOPT=21
-COLVI2 SUMMARY:
 IERROR =   0
 AVERAGE STEP   = 1.0000000            VARIANCE       = 0.
 MIN. STEP      = 1.0000000            MAX. STEP      = 1.0000000
 # SUCC. STEPS  =        50            # FAILURES     =         0
 # KEV.         =    126232            # CORRECTOR IT.=       588
 # CP SECONDS   =        12            LAST T-VALUE   =  .500E+02
-GLOB.ERR.EST.=  -.5782217549E-07    GLOB.ERR.=  -.1165398569E-06    SD =  6.93
                 -.8110902172E-08                 .3514563218E-07          7.45
-  T           Y(T)                UH(T)             Y(T)-UH(T)
  25.00    0.                   .5107873224E-01      -.511E-01
           0.                   .5982258510E+00      -.598E+00
-PASS: 2
 REQTOL= .10E-03, DEFOPT=22
-COLVI2 SUMMARY:
 IERROR =   0
 AVERAGE STEP   = 1.0000000            VARIANCE       = 0.
 MIN. STEP      = 1.0000000            MAX. STEP      = 1.0000000
 # SUCC. STEPS  =        50            # FAILURES     =         0
 # KEV.         =    114010            # CORRECTOR IT.=       717
 # CP SECONDS   =        10            LAST T-VALUE   =  .500E+02
-GLOB.ERR.EST.=  -.9642999266E-07    GLOB.ERR.=  -.1070522393E-06    SD =  6.97
                  .9836778858E-07                 .9877559037E-07          7.01
-  T           Y(T)                UH(T)             Y(T)-UH(T)
  25.00    0.                   .5107872346E-01      -.511E-01
           0.                   .5982259093E+00      -.598E+00
1PASS: 3
 REQTOL= .10E-03, DEFOPT= 1
-COLVI2 SUMMARY:
 IERROR =   0
 AVERAGE STEP   = 1.0000000            VARIANCE       = 0.
 MIN. STEP      = 1.0000000            MAX. STEP      = 1.0000000
 # SUCC. STEPS  =        50            # FAILURES     =         0
 # KEV.         =    106904            # CORRECTOR IT.=       286
 # CP SECONDS   =        16            LAST T-VALUE   =  .500E+02
-GLOB.ERR.EST.=  -.3468336729E-12    GLOB.ERR.=  -.6763478666E-12    SD = 12.17
                 -.4973799150E-13                 .6874500968E-11         11.16
-  T           Y(T)                UH(T)             Y(T)-UH(T)
  25.00    0.                   .5107869518E-01      -.511E-01
           0.                   .5982261634E+00      -.598E+00
-PASS: 4
 REQTOL= .10E-03, DEFOPT= 2
-COLVI2 SUMMARY:
 IERROR =   0
 AVERAGE STEP   = 1.0000000            VARIANCE       = 0.
 MIN. STEP      = 1.0000000            MAX. STEP      = 1.0000000
 # SUCC. STEPS  =        50            # FAILURES     =         0
 # KEV.         =    101230            # CORRECTOR IT.=       307
 # CP SECONDS   =        10            LAST T-VALUE   =  .500E+02
-GLOB.ERR.EST.=  -.1849365105E-10    GLOB.ERR.=  -.1873767808E-10    SD = 10.73
                  .5942624171E-10                 .5998757047E-10         10.22
-  T           Y(T)                UH(T)             Y(T)-UH(T)
  25.00    0.                   .5107869509E-01      -.511E-01
           0.                   .5982261629E+00      -.598E+00
1PASS: 5
 REQTOL= .10E-03, DEFOPT= 0
  IOPT: (  63,   0,   0,   0,   0,   0,   0,  73,   0)
   OPT: (0.     ,0.     , .1E+02, .1E+01)
 CNTRL: (   0,   0,   0,   0)
-COLVI2 SUMMARY:
 IERROR =   0
 AVERAGE STEP   = 4.5454545            VARIANCE       =  .877E+01
 MIN. STEP      = 1.0000000            MAX. STEP      = 9.2240888
 # SUCC. STEPS  =        11            # FAILURES     =         0
 # KEV.         =     10716            # CORRECTOR IT.=        91
 # CP SECONDS   =         2            LAST T-VALUE   =  .500E+02
-GLOB.ERR.EST.=   .6267976120E-05    GLOB.ERR.=   .6438180038E-05    SD =  5.19
                 -.3095359378E-04                -.3239874192E-04          4.49
-  T           Y(T)                UH(T)             Y(T)-UH(T)
  25.00    0.                   .5111419398E-01      -.511E-01
           0.                   .5981278007E+00      -.598E+00
-PASS: 6
 REQTOL= .10E-03, DEFOPT= 0
  IOPT: (  21,   0,   0,   0,   0,   0,   0,  21,   0)
   OPT: (0.     ,0.     ,0.     ,0.     )
 CNTRL: (   0,   0,   0,   0)
 ERROR COLVI2...SOLUTION IS FOUND TO BE POLYNOMIAL AT T =     .24317E+02
 ERROR COLVI2...  COMPONENT:    2
 ERROR COLVI2...SOLUTION IS FOUND TO BE POLYNOMIAL AT T =     .27791E+02
 ERROR COLVI2...  COMPONENT:    1
 ERROR COLVI2...SOLUTION IS FOUND TO BE POLYNOMIAL AT T =     .34808E+02
 ERROR COLVI2...  COMPONENT:    2
 ERROR COLVI2...SOLUTION IS FOUND TO BE POLYNOMIAL AT T =     .40082E+02
 ERROR COLVI2...  COMPONENT:    1
 ERROR COLVI2...SOLUTION IS FOUND TO BE POLYNOMIAL AT T =     .40821E+02
 ERROR COLVI2...  COMPONENT:    1
 ERROR COLVI2...SOLUTION BEHAVED AS A POLYNOMIAL OF DEGREE < M             2 CON
 ERROR COLVI2...ESCAPE TO REFSOL (METHOD,M,ORDER): ( 2, 4, 6); LOCAL + UNIFORM E
-COLVI2 SUMMARY:
 IERROR =   0
 AVERAGE STEP   =  .3703704            VARIANCE       =  .816E-01
 MIN. STEP      =  .0752739            MAX. STEP      = 1.0000000
 # SUCC. STEPS  =       135            # FAILURES     =        10
 # KEV.         =     59100            # CORRECTOR IT.=       721
 # CP SECONDS   =         4            LAST T-VALUE   =  .500E+02
-GLOB.ERR.EST.=  -.3895785859E-06    GLOB.ERR.=  -.8995015336E-05    SD =  5.05
                  .4743861756E-04                 .5475058369E-05          5.26
-  T           Y(T)                UH(T)             Y(T)-UH(T)
  25.00    0.                   .5108357757E-01      -.511E-01
           0.                   .5981845056E+00      -.598E+00
1PASS: 7
 REQTOL= .10E-03, DEFOPT= 0
  IOPT: (  63,   0,   0,   0,   0,   0,   0,  73,   0)
   OPT: (0.     ,0.     , .1E+02, .1E+01)
 CNTRL: (   0,   0,   7,   0)
-  N     TN             HN             Y(TN+HN)         YEX-U_N+1    UR_N+1-U_N+
    0  0.00000  1.00000000000000  0.                    -.47360E-01   .24859E-08
    0  0.00000  1.00000000000000  0.                    -.12037E+00   .16006E-08
    1  1.00000  1.80000000000000  0.                    -.23390E+00  -.96069E-06
    1  1.00000  1.80000000000000  0.                    -.36057E+00  -.34455E-05
    2  2.80000  1.90552064681010  0.                    -.13442E+00   .12395E-05
    2  2.80000  1.90552064681010  0.                    -.69130E+00  -.17923E-05
    3  4.70552  2.05511009097872  0.                    -.43566E-01   .40197E-06
    3  4.70552  2.05511009097872  0.                    -.78092E+00  -.10649E-06
    4  6.76063  2.59679073132250  0.                    -.14059E-01   .85177E-07
    4  6.76063  2.59679073132250  0.                    -.74786E+00   .38698E-06
    5  9.35742  3.78590931967115  0.                    -.70883E-02   .20363E-08
    5  9.35742  3.78590931967115  0.                    -.65319E+00   .43205E-06
    6 13.14333  5.87298521739154  0.                    -.17003E-01  -.23721E-05
    6 13.14333  5.87298521739154  0.                    -.54262E+00   .90103E-06
    7 19.01632  5.98368399382605  0.                    -.51079E-01  -.28386E-06
    7 19.01632  5.98368399382605  0.                    -.59824E+00  -.88653E-05
-COLVI2 SUMMARY:
 IERROR =   0
 AVERAGE STEP   = 3.1250000            VARIANCE       =  .362E+01
 MIN. STEP      = 1.0000000            MAX. STEP      = 5.9836840
 # SUCC. STEPS  =         8            # FAILURES     =         0
 # KEV.         =      5505            # CORRECTOR IT.=        69
 # CP SECONDS   =         2            LAST T-VALUE   =  .250E+02
-GLOB.ERR.EST.=  -.2838590034E-06    GLOB.ERR.=  -.5107906900E-01    SD =  1.29
                 -.8865331345E-05                -.5982351085E+00           .22
  IOPT: (  63,   0,   0,   0,   0,   0,   0,  73,   0)
   OPT: (0.     ,0.     , .1E+02, .1E+01)
 CNTRL: (   3,   0,   7,   0)
    8 25.00000  6.86185698162583  0.                    -.26430E-01  -.22542E-06
    8 25.00000  6.86185698162583  0.                    -.65222E+00   .25760E-05
    9 31.86186  6.73755898998490  0.                    -.25252E-01  -.30507E-05
    9 31.86186  6.73755898998490  0.                    -.60655E+00  -.36755E-07
   10 38.59942  6.79874729823032  0.                    -.34136E-01  -.99603E-06
   10 38.59942  6.79874729823032  0.                    -.61349E+00  -.61080E-05
   11 45.39816  4.60183673015899   .31716689391939E-01   .12159E-05   .12143E-05
   11 45.39816  4.60183673015899   .62784627209779E+00  -.30233E-05  -.30269E-05
-COLVI2 SUMMARY:
 IERROR =   0
 AVERAGE STEP   = 4.1666667            VARIANCE       =  .500E+01
 MIN. STEP      = 1.0000000            MAX. STEP      = 6.8618570
 # SUCC. STEPS  =        12            # FAILURES     =         0
 # KEV.         =      3794            # CORRECTOR IT.=        31
 # CP SECONDS   =         0            LAST T-VALUE   =  .500E+02
-GLOB.ERR.EST.=   .1214291197E-05    GLOB.ERR.=   .1215905503E-05    SD =  5.92
                 -.3026856572E-05                -.3023344043E-05          5.52
-COLVI2 SUMMARY:
 IERROR =   0
 AVERAGE STEP   = 4.1666667            VARIANCE       =  .500E+01
 MIN. STEP      = 1.0000000            MAX. STEP      = 6.8618570
 # SUCC. STEPS  =        12            # FAILURES     =         0
 # KEV.         =      9299            # CORRECTOR IT.=       100
 # CP SECONDS   =         2            LAST T-VALUE   =  .500E+02
-GLOB.ERR.EST.=   .1214291197E-05    GLOB.ERR.=   .1215905503E-05    SD =  5.92
                 -.3026856572E-05                -.3023344043E-05          5.52
-PASS: 8
 REQTOL= .10E-03, DEFOPT= 0
  IOPT: (  21,   0,   0,   0,   0,   0,   0,  21,  10)
   OPT: (0.     ,0.     ,0.     ,0.     )
 CNTRL: (   0,   0,   7,   0)
-  N     TN             HN             Y(TN+HN)         YEX-U_N+1    UR_N+1-U_N+
    0  0.00000  1.00000000000000  0.                    -.41869E-01   .36314E-02
    0  0.00000  1.00000000000000  0.                    -.11553E+00   .37312E-02
    0  0.00000   .45000000000000  0.                    -.19967E-01   .55969E-03
    0  0.00000   .45000000000000  0.                    -.10449E+00   .43218E-03
    0  0.00000   .11250000000000  0.                    -.11965E-01   .28726E-04
    0  0.00000   .11250000000000  0.                    -.10081E+00   .18817E-04
    1   .11250   .18891009552931  0.                    -.16135E-01   .99335E-04
    1   .11250   .18891009552931  0.                    -.10270E+00   .68348E-04
    2   .30141   .17058726810513  0.                    -.21161E-01   .10359E-03
    2   .30141   .17058726810513  0.                    -.10523E+00   .72611E-04
    2   .30141   .15084302499574  0.                    -.20534E-01   .80227E-04
    2   .30141   .15084302499574  0.                    -.10491E+00   .55649E-04
    3   .45225   .15156839319674  0.                    -.26020E-01   .97974E-04
    3   .45225   .15156839319674  0.                    -.10782E+00   .70071E-04
    4   .60382   .13781479216753  0.                    -.32171E-01   .95797E-04
    4   .60382   .13781479216753  0.                    -.11126E+00   .70761E-04
    5   .74164   .12672485692945  0.                    -.38947E-01   .92686E-04
    5   .74164   .12672485692945  0.                    -.11522E+00   .71299E-04
    6   .86836   .11846713174614  0.                    -.46374E-01   .89932E-04
    6   .86836   .11846713174614  0.                    -.11974E+00   .72736E-04
    7   .98683   .11243030289273  0.                    -.54492E-01   .87402E-04
    7   .98683   .11243030289273  0.                    -.12487E+00   .75154E-04
    8  1.09926   .10823422929576  0.                    -.63354E-01   .84913E-04
    8  1.09926   .10823422929576  0.                    -.13069E+00   .78695E-04
    9  1.20749   .10571106248830  0.                    -.73037E-01   .82272E-04
    9  1.20749   .10571106248830  0.                    -.13732E+00   .83665E-04
   10  1.31320   .10401411383336  0.                    -.83557E-01   .77948E-04
   10  1.31320   .10401411383336  0.                    -.14486E+00   .89080E-04
   11  1.41722   .09918497282092  0.                    -.94477E-01   .66376E-04
   11  1.41722   .09918497282092  0.                    -.15308E+00   .87706E-04
   12  1.51640   .09531767030865  0.                    -.10571E+00   .54248E-04
   12  1.51640   .09531767030865  0.                    -.16199E+00   .86327E-04
   13  1.61172   .09232981542214  0.                    -.11720E+00   .41606E-04
   13  1.61172   .09232981542214  0.                    -.17162E+00   .85026E-04
   14  1.70405   .09011760960252  0.                    -.12885E+00   .28372E-04
   14  1.70405   .09011760960252  0.                    -.18202E+00   .83765E-04
   15  1.79417   .08861754026022  0.                    -.14060E+00   .14453E-04
   15  1.79417   .08861754026022  0.                    -.19324E+00   .82512E-04
   16  1.88279   .08780198913701  0.                    -.15234E+00  -.27548E-06
   16  1.88279   .08780198913701  0.                    -.20533E+00   .81228E-04
   17  1.97059   .08767880857101  0.                    -.16400E+00  -.15988E-04
   17  1.97059   .08767880857101  0.                    -.21837E+00   .79871E-04
   18  2.05827   .08829636244771  0.                    -.17547E+00  -.32934E-04
   18  2.05827   .08829636244771  0.                    -.23246E+00   .78386E-04
   19  2.14656   .08975637517473  0.                    -.18664E+00  -.51497E-04
   19  2.14656   .08975637517473  0.                    -.24773E+00   .76696E-04
   20  2.23632   .09224045609852  0.                    -.19738E+00  -.72284E-04
   20  2.23632   .09224045609852  0.                    -.26436E+00   .74680E-04
   21  2.32856   .09606446712047  0.                    -.20756E+00  -.96318E-04
   21  2.32856   .09606446712047  0.                    -.28260E+00   .72133E-04
   22  2.42462   .08809487758008  0.                    -.21577E+00  -.93178E-04
   22  2.42462   .08809487758008  0.                    -.30007E+00   .52331E-04
   23  2.51272   .08213648677090  0.                    -.22237E+00  -.88505E-04
   23  2.51272   .08213648677090  0.                    -.31689E+00   .38063E-04
   24  2.59486   .07857678628978  0.                    -.22766E+00  -.85440E-04
   24  2.59486   .07857678628978  0.                    -.33338E+00   .27979E-04
   25  2.67343   .07650794464586  0.                    -.23181E+00  -.83219E-04
   25  2.67343   .07650794464586  0.                    -.34973E+00   .20024E-04
   26  2.74994   .07548112579309  0.                    -.23491E+00  -.81447E-04
   26  2.74994   .07548112579309  0.                    -.36607E+00   .13211E-04
   27  2.82542   .07527387633171  0.                    -.23703E+00  -.79925E-04
   27  2.82542   .07527387633171  0.                    -.38249E+00   .69917E-05
   28  2.90070   .07577819475656  0.                    -.23819E+00  -.78539E-04
   28  2.90070   .07577819475656  0.                    -.39909E+00   .10026E-05
   29  2.97647   .07695635892374  0.                    -.23842E+00  -.77207E-04
   29  2.97647   .07695635892374  0.                    -.41593E+00  -.50418E-05
   30  3.05343   .07882418455376  0.                    -.23771E+00  -.75864E-04
   30  3.05343   .07882418455376  0.                    -.43310E+00  -.11408E-04
   31  3.13225   .08144885158426  0.                    -.23604E+00  -.74446E-04
   31  3.13225   .08144885158426  0.                    -.45067E+00  -.18388E-04
   32  3.21370   .08495849829523  0.                    -.23339E+00  -.72879E-04
   32  3.21370   .08495849829523  0.                    -.46873E+00  -.26352E-04
   33  3.29866   .08956678621618  0.                    -.22968E+00  -.71064E-04
   33  3.29866   .08956678621618  0.                    -.48741E+00  -.35817E-04
   34  3.38823   .09562360554722  0.                    -.22483E+00  -.68847E-04
   34  3.38823   .09562360554722  0.                    -.50685E+00  -.47589E-04
   35  3.48385   .10372093769961  0.                    -.21870E+00  -.65966E-04
   35  3.48385   .10372093769961  0.                    -.52726E+00  -.63036E-04
   36  3.58757   .11493415598166  0.                    -.21106E+00  -.61915E-04
   36  3.58757   .11493415598166  0.                    -.54897E+00  -.84765E-04
   37  3.70251   .11235261611874  0.                    -.20295E+00  -.42186E-04
   37  3.70251   .11235261611874  0.                    -.56917E+00  -.86127E-04
   38  3.81486   .10895695676388  0.                    -.19467E+00  -.25925E-04
   38  3.81486   .10895695676388  0.                    -.58776E+00  -.84031E-04
   39  3.92382   .10697371151218  0.                    -.18629E+00  -.13768E-04
   39  3.92382   .10697371151218  0.                    -.60502E+00  -.82530E-04
   40  4.03079   .10597736824095  0.                    -.17788E+00  -.42653E-05
   40  4.03079   .10597736824095  0.                    -.62114E+00  -.81406E-04
   41  4.13677   .10571308203660  0.                    -.16948E+00   .33952E-05
   41  4.13677   .10571308203660  0.                    -.63625E+00  -.80516E-04
   42  4.24248   .10603034695335  0.                    -.16113E+00   .97066E-05
   42  4.24248   .10603034695335  0.                    -.65044E+00  -.79782E-04
   43  4.34851   .10683640987856  0.                    -.15287E+00   .14989E-04
   43  4.34851   .10683640987856  0.                    -.66378E+00  -.79156E-04
   44  4.45535   .10807340652373  0.                    -.14472E+00   .19460E-04
   44  4.45535   .10807340652373  0.                    -.67631E+00  -.78607E-04
   45  4.56342   .10970621927551  0.                    -.13671E+00   .23278E-04
   45  4.56342   .10970621927551  0.                    -.68808E+00  -.78112E-04
   46  4.67313   .11171564418343  0.                    -.12886E+00   .26556E-04
   46  4.67313   .11171564418343  0.                    -.69911E+00  -.77658E-04
   47  4.78484   .11409441778594  0.                    -.12118E+00   .29382E-04
   47  4.78484   .11409441778594  0.                    -.70944E+00  -.77231E-04
   48  4.89894   .11684490302563  0.                    -.11370E+00   .31822E-04
   48  4.89894   .11684490302563  0.                    -.71906E+00  -.76825E-04
   49  5.01578   .11997781223427  0.                    -.10643E+00   .33931E-04
   49  5.01578   .11997781223427  0.                    -.72801E+00  -.76431E-04
   50  5.13576   .12351163469515  0.                    -.99371E-01   .35750E-04
   50  5.13576   .12351163469515  0.                    -.73628E+00  -.76044E-04
   51  5.25927   .12747259386759  0.                    -.92543E-01   .37312E-04
   51  5.25927   .12747259386759  0.                    -.74388E+00  -.75659E-04
   52  5.38674   .13189505200170  0.                    -.85953E-01   .38647E-04
   52  5.38674   .13189505200170  0.                    -.75081E+00  -.75271E-04
   53  5.51864   .13682234400443  0.                    -.79608E-01   .39777E-04
   53  5.51864   .13682234400443  0.                    -.75706E+00  -.74876E-04
   54  5.65546   .14230807131074  0.                    -.73514E-01   .40722E-04
   54  5.65546   .14230807131074  0.                    -.76265E+00  -.74468E-04
   55  5.79777   .14841793743090  0.                    -.67676E-01   .41497E-04
   55  5.79777   .14841793743090  0.                    -.76754E+00  -.74045E-04
   56  5.94619   .15523226337956  0.                    -.62099E-01   .42116E-04
   56  5.94619   .15523226337956  0.                    -.77175E+00  -.73600E-04
   57  6.10142   .16284939981717  0.                    -.56786E-01   .42592E-04
   57  6.10142   .16284939981717  0.                    -.77524E+00  -.73128E-04
   58  6.26427   .17139036369077  0.                    -.51739E-01   .42935E-04
   58  6.26427   .17139036369077  0.                    -.77799E+00  -.72623E-04
   59  6.43566   .18100520042250  0.                    -.46959E-01   .43154E-04
   59  6.43566   .18100520042250  0.                    -.78000E+00  -.72077E-04
   60  6.61666   .19188184375110  0.                    -.42447E-01   .43258E-04
   60  6.61666   .19188184375110  0.                    -.78121E+00  -.71481E-04
   61  6.80855   .20425869913852  0.                    -.38203E-01   .43258E-04
   61  6.80855   .20425869913852  0.                    -.78161E+00  -.70822E-04
   62  7.01281   .21844294680066  0.                    -.34225E-01   .43163E-04
   62  7.01281   .21844294680066  0.                    -.78113E+00  -.70085E-04
   63  7.23125   .23483794585494  0.                    -.30512E-01   .42987E-04
   63  7.23125   .23483794585494  0.                    -.77973E+00  -.69247E-04
   64  7.46609   .25398570316353  0.                    -.27061E-01   .42746E-04
   64  7.46609   .25398570316353  0.                    -.77733E+00  -.68279E-04
   65  7.72007   .27663548093806  0.                    -.23868E-01   .42463E-04
   65  7.72007   .27663548093806  0.                    -.77384E+00  -.67136E-04
   66  7.99671   .30386039256668  0.                    -.20929E-01   .42176E-04
   66  7.99671   .30386039256668  0.                    -.76913E+00  -.65748E-04
   67  8.30057   .33726841321026  0.                    -.18239E-01   .41941E-04
   67  8.30057   .33726841321026  0.                    -.76306E+00  -.64004E-04
   68  8.63784   .37941612241471  0.                    -.15792E-01   .41861E-04
   68  8.63784   .37941612241471  0.                    -.75538E+00  -.61704E-04
   69  9.01725   .43471043679819  0.                    -.13582E-01   .42130E-04
   69  9.01725   .43471043679819  0.                    -.74577E+00  -.58463E-04
   70  9.45196   .51168471522757  0.                    -.11601E-01   .43164E-04
   70  9.45196   .51168471522757  0.                    -.73366E+00  -.53405E-04
   71  9.96365   .63016450719896  0.                    -.98408E-02   .46056E-04
   71  9.96365   .63016450719896  0.                    -.71801E+00  -.44057E-04
   72 10.59381   .83570782398779  0.                    -.83176E-02   .52930E-04
   72 10.59381   .83570782398779  0.                    -.69666E+00  -.19637E-04
   73 11.42952  1.00000000000000  0.                    -.73369E-02   .49474E-04
   73 11.42952  1.00000000000000  0.                    -.67104E+00   .38504E-04
   74 12.42952  1.00000000000000  0.                    -.70072E-02   .37703E-04
   74 12.42952  1.00000000000000  0.                    -.64607E+00   .86186E-04
   75 13.42952   .96944735172486  0.                    -.71841E-02   .32928E-04
   75 13.42952   .96944735172486  0.                    -.62299E+00   .11589E-03
   75 13.42952   .81049798041010  0.                    -.71330E-02   .23841E-04
   75 13.42952   .81049798041010  0.                    -.62671E+00   .78173E-04
   76 14.24002   .82502342728000  0.                    -.75919E-02   .26055E-04
   76 14.24002   .82502342728000  0.                    -.60802E+00   .10145E-03
   76 14.24002   .73718421936590  0.                    -.75307E-02   .21056E-04
   76 14.24002   .73718421936590  0.                    -.60997E+00   .79660E-04
   77 14.97720   .74335992441368  0.                    -.82330E-02   .24354E-04
   77 14.97720   .74335992441368  0.                    -.59409E+00   .97206E-04
   78 15.72056   .67856924310050  0.                    -.91898E-02   .24455E-04
   78 15.72056   .67856924310050  0.                    -.58069E+00   .95766E-04
   79 16.39913   .62406683026596  0.                    -.10384E-01   .25043E-04
   79 16.39913   .62406683026596  0.                    -.56942E+00   .94765E-04
   80 17.02320   .57696634640897  0.                    -.11809E-01   .25594E-04
   80 17.02320   .57696634640897  0.                    -.56007E+00   .94005E-04
   81 17.60016   .53557052247656  0.                    -.13456E-01   .25782E-04
   81 17.60016   .53557052247656  0.                    -.55244E+00   .93205E-04
   82 18.13573   .49927468337753  0.                    -.15314E-01   .25441E-04
   82 18.13573   .49927468337753  0.                    -.54637E+00   .92272E-04
   83 18.63501   .46778498314171  0.                    -.17370E-01   .24504E-04
   83 18.63501   .46778498314171  0.                    -.54173E+00   .91199E-04
   84 19.10279   .44085183023548  0.                    -.19608E-01   .22954E-04
   84 19.10279   .44085183023548  0.                    -.53839E+00   .90007E-04
   85 19.54365   .41821306816420  0.                    -.22008E-01   .20799E-04
   85 19.54365   .41821306816420  0.                    -.53625E+00   .88717E-04
   86 19.96186   .39961072205242  0.                    -.24549E-01   .18051E-04
   86 19.96186   .39961072205242  0.                    -.53523E+00   .87343E-04
   87 20.36147   .38482682473671  0.                    -.27207E-01   .14717E-04
   87 20.36147   .38482682473671  0.                    -.53525E+00   .85886E-04
   88 20.74630   .37372117411560  0.                    -.29954E-01   .10788E-04
   88 20.74630   .37372117411560  0.                    -.53627E+00   .84329E-04
   89 21.12002   .36627122848735  0.                    -.32762E-01   .62323E-05
   89 21.12002   .36627122848735  0.                    -.53826E+00   .82638E-04
   90 21.48629   .36262375379988  0.                    -.35594E-01   .98308E-06
   90 21.48629   .36262375379988  0.                    -.54121E+00   .80753E-04
   91 21.84891   .36317776980886  0.                    -.38414E-01  -.50813E-05
   91 21.84891   .36317776980886  0.                    -.54512E+00   .78575E-04
   92 22.21209   .36873903307845  0.                    -.41176E-01  -.12177E-04
   92 22.21209   .36873903307845  0.                    -.55004E+00   .75934E-04
   93 22.58083   .38084171963560  0.                    -.43826E-01  -.20699E-04
   93 22.58083   .38084171963560  0.                    -.55605E+00   .72516E-04
   94 22.96167   .40250502659120  0.                    -.46298E-01  -.31429E-04
   94 22.96167   .40250502659120  0.                    -.56329E+00   .67678E-04
   95 23.36418   .44034120420323  0.                    -.48497E-01  -.46140E-04
   95 23.36418   .44034120420323  0.                    -.57206E+00   .59854E-04
   96 23.80452   .51225321122567  0.                    -.50267E-01  -.69957E-04
   96 23.80452   .51225321122567  0.                    -.58304E+00   .43954E-04
   97 24.31677   .55120358802833  0.                    -.51126E-01  -.82435E-04
   97 24.31677   .55120358802833  0.                    -.59527E+00   .18937E-05
 ERROR COLVI2...SOLUTION IS FOUND TO BE POLYNOMIAL AT T =     .24317E+02
 ERROR COLVI2...  COMPONENT:    2
   98 24.86797   .54638588702396  0.                    -.50926E-01  -.74357E-04
   98 24.86797   .54638588702396  0.                    -.60723E+00  -.43832E-04
   99 25.41436   .57027147673352  0.                    -.49759E-01  -.66141E-04
   99 25.41436   .57027147673352  0.                    -.61899E+00  -.90127E-04
  100 25.98463   .54062686427709  0.                    -.47929E-01  -.43509E-04
  100 25.98463   .54062686427709  0.                    -.62899E+00  -.10822E-03
  100 25.98463   .46772857111467  0.                    -.48196E-01  -.33854E-04
  100 25.98463   .46772857111467  0.                    -.62769E+00  -.79565E-04
  101 26.45236   .47192771871903  0.                    -.46260E-01  -.23593E-04
  101 26.45236   .47192771871903  0.                    -.63547E+00  -.92936E-04
  102 26.92429   .44058073516828  0.                    -.44228E-01  -.12152E-04
  102 26.92429   .44058073516828  0.                    -.64169E+00  -.86460E-04
  103 27.36487   .42644148743850  0.                    -.42155E-01  -.48412E-05
  103 27.36487   .42644148743850  0.                    -.64671E+00  -.82505E-04
  104 27.79131   .42253481189234  0.                    -.40074E-01   .41805E-06
  104 27.79131   .42253481189234  0.                    -.65072E+00  -.79861E-04
 ERROR COLVI2...SOLUTION IS FOUND TO BE POLYNOMIAL AT T =     .27791E+02
 ERROR COLVI2...  COMPONENT:    1
  105 28.21385   .42553786737126  0.                    -.38012E-01   .44954E-05
  105 28.21385   .42553786737126  0.                    -.65380E+00  -.77820E-04
  106 28.63938   .43414417969240  0.                    -.35990E-01   .78166E-05
  106 28.63938   .43414417969240  0.                    -.65599E+00  -.76071E-04
  107 29.07353   .44798945530428  0.                    -.34027E-01   .10634E-04
  107 29.07353   .44798945530428  0.                    -.65733E+00  -.74434E-04
  108 29.52152   .46733161781489  0.                    -.32139E-01   .13123E-04
  108 29.52152   .46733161781489  0.                    -.65780E+00  -.72777E-04
  109 29.98885   .49302654044820  0.                    -.30342E-01   .15434E-04
  109 29.98885   .49302654044820  0.                    -.65739E+00  -.70967E-04
  110 30.48187   .52672398597502  0.                    -.28651E-01   .17723E-04
  110 30.48187   .52672398597502  0.                    -.65605E+00  -.68829E-04
  111 31.00860   .57140041532616  0.                    -.27083E-01   .20200E-04
  111 31.00860   .57140041532616  0.                    -.65373E+00  -.66070E-04
  112 31.58000   .63267635589828  0.                    -.25658E-01   .23212E-04
  112 31.58000   .63267635589828  0.                    -.65030E+00  -.62111E-04
  113 32.21268   .72250460568922  0.                    -.24406E-01   .27468E-04
  113 32.21268   .72250460568922  0.                    -.64557E+00  -.55539E-04
  114 32.93518   .87254025654576  0.                    -.23381E-01   .34828E-04
  114 32.93518   .87254025654576  0.                    -.63910E+00  -.41705E-04
  115 33.80772  1.00000000000000  0.                    -.22801E-01   .39040E-04
  115 33.80772  1.00000000000000  0.                    -.63123E+00  -.30169E-05
  116 34.80772  1.00000000000000  0.                    -.22792E-01   .34466E-04
  116 34.80772  1.00000000000000  0.                    -.62346E+00   .42151E-04
 ERROR COLVI2...SOLUTION IS FOUND TO BE POLYNOMIAL AT T =     .34808E+02
 ERROR COLVI2...  COMPONENT:    2
  117 35.80772  1.00000000000000  0.                    -.23281E-01   .30179E-04
  117 35.80772  1.00000000000000  0.                    -.61632E+00   .79991E-04
  118 36.80772  1.00000000000000  0.                    -.24206E-01   .25429E-04
  118 36.80772  1.00000000000000  0.                    -.61024E+00   .11079E-03
  118 36.80772   .85505985571743  0.                    -.24056E-01   .20103E-04
  118 36.80772   .85505985571743  0.                    -.61107E+00   .78392E-04
  119 37.66278   .86916688804065  0.                    -.25116E-01   .16829E-04
  119 37.66278   .86916688804065  0.                    -.60671E+00   .96988E-04
  120 38.53195   .79430391685447  0.                    -.26287E-01   .10591E-04
  120 38.53195   .79430391685447  0.                    -.60379E+00   .89479E-04
  121 39.32625   .75573428009596  0.                    -.27522E-01   .56305E-05
  121 39.32625   .75573428009596  0.                    -.60201E+00   .84679E-04
  122 40.08199   .73913364055993  0.                    -.28787E-01   .95088E-06
  122 40.08199   .73913364055993  0.                    -.60123E+00   .80801E-04
 ERROR COLVI2...SOLUTION IS FOUND TO BE POLYNOMIAL AT T =     .40082E+02
 ERROR COLVI2...  COMPONENT:    1
  123 40.82112   .74004483510308  0.                    -.30048E-01  -.39504E-05
  123 40.82112   .74004483510308  0.                    -.60140E+00   .76961E-04
 ERROR COLVI2...SOLUTION IS FOUND TO BE POLYNOMIAL AT T =     .40821E+02
 ERROR COLVI2...  COMPONENT:    1
 ERROR COLVI2...SOLUTION BEHAVED AS A POLYNOMIAL OF DEGREE < M             2 CON
 ERROR COLVI2...ENDPOINT NOT REACHED, LAST T-VALUE :     .40821E+02
-COLVI2 SUMMARY:
 IERROR =  15
 AVERAGE STEP   =  .3318790            VARIANCE       =  .715E-01
 MIN. STEP      =  .0752739            MAX. STEP      = 1.0000000
 # SUCC. STEPS  =       123            # FAILURES     =         7
 # KEV.         =     50824            # CORRECTOR IT.=       645
 # CP SECONDS   =         5            LAST T-VALUE   =  .408E+02
  IOPT: (  21,   0,   0,   0,   0,   0,   0,  42,2100)
   OPT: (0.     ,0.     , .1E+02, .1E+01)
 CNTRL: (   1,   0,   7,   0)
-  N     TN             HN             Y(TN+HN)         YEX-U_N+1    UR_N+1-U_N+
  121 39.32625   .75573428009596  0.                    -.27522E-01  -.13635E-03
  121 39.32625   .75573428009596  0.                    -.60201E+00   .22773E-03
  122 40.08199   .80069378357791  0.                    -.28892E-01  -.17007E-03
  122 40.08199   .80069378357791  0.                    -.60120E+00   .26696E-03
  123 40.88268   .84486315208253  0.                    -.30323E-01  -.22787E-03
  123 40.88268   .84486315208253  0.                    -.60154E+00   .32262E-03
  124 41.72754   .85908770035182  0.                    -.31660E-01  -.26965E-03
  124 41.72754   .85908770035182  0.                    -.60306E+00   .34661E-03
  125 42.58663   .80595535638495  0.                    -.32717E-01  -.24060E-03
  125 42.58663   .80595535638495  0.                    -.60538E+00   .28545E-03
  126 43.39259   .79139265439103  0.                    -.33507E-01  -.22745E-03
  126 43.39259   .79139265439103  0.                    -.60828E+00   .24778E-03
  127 44.18398   .80754253813481  0.                    -.34019E-01  -.24553E-03
  127 44.18398   .80754253813481  0.                    -.61164E+00   .24360E-03
  128 44.99152   .79215302905193  0.                    -.34220E-01  -.23834E-03
  128 44.99152   .79215302905193  0.                    -.61507E+00   .21671E-03
  129 45.78367   .76894979192442  0.                    -.34145E-01  -.21436E-03
  129 45.78367   .76894979192442  0.                    -.61832E+00   .17932E-03
  130 46.55262   .76751642832656  0.                    -.33842E-01  -.20508E-03
  130 46.55262   .76751642832656  0.                    -.62129E+00   .16009E-03
  131 47.32014   .76806513567062  0.                    -.33359E-01  -.19979E-03
  131 47.32014   .76806513567062  0.                    -.62384E+00   .14902E-03
  132 48.08820   .75942027880783  0.                    -.32758E-01  -.18669E-03
  132 48.08820   .75942027880783  0.                    -.62587E+00   .13535E-03
  133 48.84763   .75466263528097  0.                    -.32090E-01  -.17480E-03
  133 48.84763   .75466263528097  0.                    -.62733E+00   .12564E-03
  134 49.60229   .39771219281397   .31716689391939E-01  -.89950E-05  -.24061E-04
  134 49.60229   .39771219281397   .62784627209779E+00   .54751E-05   .11005E-04
-COLVI2 SUMMARY:
 IERROR =   0
 AVERAGE STEP   =  .3703704            VARIANCE       =  .816E-01
 MIN. STEP      =  .0752739            MAX. STEP      = 1.0000000
 # SUCC. STEPS  =       135            # FAILURES     =         0
 # KEV.         =    121652            # CORRECTOR IT.=       479
 # CP SECONDS   =         9            LAST T-VALUE   =  .500E+02
-GLOB.ERR.EST.=  -.8970025974E-05    GLOB.ERR.=  -.8995015336E-05    SD =  5.05
                  .5484523495E-05                 .5475058369E-05          5.26
-COLVI2 SUMMARY:
 IERROR =   0
 AVERAGE STEP   =  .3703704            VARIANCE       =  .816E-01
 MIN. STEP      =  .0752739            MAX. STEP      = 1.0000000
 # SUCC. STEPS  =       135            # FAILURES     =        10
 # KEV.         =    172476            # CORRECTOR IT.=      1124
 # CP SECONDS   =        14            LAST T-VALUE   =  .500E+02
-GLOB.ERR.EST.=  -.8970025974E-05    GLOB.ERR.=  -.8995015336E-05    SD =  5.05
                  .5484523495E-05                 .5475058369E-05          5.26
1PASS: 9
 REQTOL= .10E-03, DEFOPT=0
  IOPT: (  63,   0,   0,   0,   0,   0,   0,  73,   0)
   OPT: (0.     ,0.     , .1E+02, .1E+01)
 CNTRL: (   0,   0,   7,  99)
-  N     TN             HN             Y(TN+HN)         YEX-U_N+1    UR_N+1-U_N+
    0  0.00000  1.00000000000000  0.                    -.47360E-01   .24859E-08
    0  0.00000  1.00000000000000  0.                    -.12037E+00   .16006E-08
    1  1.00000  1.80000000000000  0.                    -.23390E+00  -.96069E-06
    1  1.00000  1.80000000000000  0.                    -.36057E+00  -.34455E-05
    2  2.80000  1.90552064681010  0.                    -.13442E+00   .12395E-05
    2  2.80000  1.90552064681010  0.                    -.69130E+00  -.17923E-05
    3  4.70552  2.05511009097872  0.                    -.43566E-01   .40197E-06
    3  4.70552  2.05511009097872  0.                    -.78092E+00  -.10649E-06
    4  6.76063  2.59679073132250  0.                    -.14059E-01   .85177E-07
    4  6.76063  2.59679073132250  0.                    -.74786E+00   .38698E-06
    5  9.35742  3.78590931967115  0.                    -.70883E-02   .20363E-08
    5  9.35742  3.78590931967115  0.                    -.65319E+00   .43205E-06
    6 13.14333  5.87298521739154  0.                    -.17003E-01  -.23721E-05
    6 13.14333  5.87298521739154  0.                    -.54262E+00   .90103E-06
 ERROR COLVI2...SIZE WORKING STORAGE TOO SMALL FOR         8 SUBINTERVALS
 ERROR COLVI2...ENDPOINT NOT REACHED, LAST T-VALUE :     .13143E+02
-COLVI2 SUMMARY:
 IERROR =  12
 AVERAGE STEP   = 2.1905551            VARIANCE       =  .876E+00
 MIN. STEP      = 1.0000000            MAX. STEP      = 3.7859093
 # SUCC. STEPS  =         6            # FAILURES     =         0
 # KEV.         =      7024            # CORRECTOR IT.=        59
 # CP SECONDS   =         1            LAST T-VALUE   =  .131E+02
1PASS:10
 REQTOL= .10E-03, DEFOPT=0
 CNTRL: (   4,   0,   7,  99)
-  N     TN             HN             Y(TN+HN)         YEX-U_N+1    UR_N+1-U_N+
    6 13.14333  5.87298521739154  0.                    -.17003E-01  -.23721E-05
    6 13.14333  5.87298521739154  0.                    -.54262E+00   .90103E-06
    7 19.01632  7.46210803035228  0.                    -.48061E-01  -.82218E-05
    7 19.01632  7.46210803035228  0.                    -.62808E+00   .48835E-05
    8 26.47842  8.62198427748922  0.                    -.22808E-01  -.15004E-04
    8 26.47842  8.62198427748922  0.                    -.62892E+00   .28688E-06
    9 35.10041  9.22408875626542  0.                    -.33618E-01  -.16316E-04
    9 35.10041  9.22408875626542  0.                    -.60898E+00  -.18640E-04
   10 44.32450  5.67550292971919   .31716689391939E-01   .64382E-05   .62680E-05
   10 44.32450  5.67550292971919   .62784627209779E+00  -.32399E-04  -.30954E-04
-COLVI2 SUMMARY:
 IERROR =   0
 AVERAGE STEP   = 4.5454545            VARIANCE       =  .877E+01
 MIN. STEP      = 1.0000000            MAX. STEP      = 9.2240888
 # SUCC. STEPS  =        11            # FAILURES     =         0
 # KEV.         =      4716            # CORRECTOR IT.=        40
 # CP SECONDS   =         1            LAST T-VALUE   =  .500E+02
-GLOB.ERR.EST.=   .6267976120E-05    GLOB.ERR.=   .6438180038E-05    SD =  5.19
                 -.3095359378E-04                -.3239874192E-04          4.49
1
 -------------------------------------------------------------------------------
 I RECOVER TEST PROBLEM,        I = [0.0, 500.0]                               I
 I Y(T)     = T                                                                I
 I G(T)     = T - (0,T) INT K(T,S,Y)DS                                         I
 I K(T,S,Y) = -T / EXP((Y-1)^2)                                                I
 -------------------------------------------------------------------------------
-PASS:11
 REQTOL= .10E-03, DEFOPT= 0
  IOPT: (  64,   0,   0,   0,   2,   0,   0,  74,   0)
   OPT: (0.     ,0.     , .1E+02,0.     )
 CNTRL: (   0,   0,   7,  99)
-  N     TN             HN             Y(TN+HN)         YEX-U_N+1    UR_N+1-U_N+
    0  0.00000  1.00000000000000   .10000000000000E+01  -.15295E-07  -.15702E-07
    1  1.00000   .98415628250642   .19841562825064E+01   .20734E-07   .16671E-07
    1  1.00000   .79943116516969   .17994311651697E+01   .17062E-07   .15767E-07
    2  1.79943   .80385320244424   .26032843676139E+01   .17197E-06   .15683E-06
    2  1.79943   .61300173355942   .24124328987291E+01   .29465E-07   .27154E-07
    2  1.79943   .15325043338986   .19526815985596E+01   .53398E-08   .50250E-10
    3  1.95268   .18310455930066   .21357861578602E+01   .12682E-07   .11961E-07
    3  1.95268   .16195687312727   .21146384716868E+01   .57932E-08   .68596E-10
    4  2.11464   .19177112129262   .23064095929794E+01   .75565E-08   .67122E-08
    5  2.30641   .18299736855266   .24894069615321E+01   .41623E-07   .39795E-07
    5  2.30641   .15289978954058   .24593093825200E+01   .16728E-07   .15597E-07
    5  2.30641   .03822494738515   .23446345403646E+01   .18690E-08   .30705E-09
    6  2.34463   .04100117557649   .23856357159411E+01   .20357E-08   .32547E-09
    7  2.38564   .04412602396736   .24297617399084E+01   .21982E-08   .34552E-09
    8  2.42976   .04769024621800   .24774519861264E+01   .23494E-08   .36707E-09
    9  2.47745   .05181749768591   .25292694838123E+01   .24812E-08   .39039E-09
   10  2.52927   .05667689083926   .25859463746516E+01   .25848E-08   .41528E-09
   11  2.58595   .06250569666268   .26484520713143E+01   .26514E-08   .44228E-09
   12  2.64845   .06964361912814   .27180956904424E+01   .26729E-08   .47083E-09
   13  2.71810   .07859431991469   .27966900103571E+01   .26454E-08   .50171E-09
   14  2.79669   .09012815507934   .28868181654365E+01   .25724E-08   .53471E-09
   15  2.88682   .10547396065254   .29922921260890E+01   .24714E-08   .56980E-09
   16  2.99229   .12669884516272   .31189909712517E+01   .23786E-08   .60784E-09
   17  3.11899   .15750346737941   .32764944386311E+01   .23459E-08   .65015E-09
   18  3.27649   .20506877632550   .34815632149567E+01   .24166E-08   .69888E-09
   19  3.48156   .28483385982468   .37663970747813E+01   .47521E-08   .29125E-08
   20  3.76640   .41933765415227   .41857347289336E+01   .29595E-08   .84944E-09
   21  4.18573   .72777524993390   .49135099788675E+01   .33988E-08   .99718E-09
   22  4.91351  1.30999544988102   .62235054287485E+01   .42955E-08   .12537E-08
   23  6.22351  2.30672450081919   .85302299295677E+01   .58873E-08   .17185E-08
   24  8.53023  4.15210410147452   .12682334031042E+02   .87527E-08   .25545E-08
   25 12.68233  7.47378738265414   .20156121413696E+02   .13910E-07   .40607E-08
0ARGUMENT TOO LARGE, FLOATING OVERFLOW
 FTN - INFORMATIVE ERROR NUMBER 30
 TRACEBACK INITIATED BY SYSERR AT REL(ABS) ADDRESS 122(67432).
 CALLED BY EXP AT ADDRESS 1(45076) WITH NO AP-LIST.
 CALLED BY KC AT LINE 6, ADDRESS 14(12770) WITH APLIST 51745(64721).
 CALLED BY SOLSYS AT LINE 149, ADDRESS 157(17064) WITH APLIST 1113(20020).
 CALLED BY SLQCE2 AT LINE 195, ADDRESS 471(16376) WITH APLIST 605(16512).
 CALLED BY SOLVI2 AT LINE 321, ADDRESS 365(13740) WITH APLIST 1567(15142).
 CALLED BY COLVI2 AT LINE 134, ADDRESS 244(40207) WITH APLIST 653(40616).
 CALLED BY CALVI2 AT LINE 10, ADDRESS 77(13125) WITH APLIST 215(13243).
 CALLED BY DRIVER AT LINE 88, ADDRESS 143(254) WITH APLIST 13056(13167).
1PASS:12
 REQTOL= .10E-03, DEFOPT= 0
  IOPT: (  64,   0,   0,   0,   2,   0,   0,  74,  10)
   OPT: (0.     ,0.     , .5E+02,0.     )
 CNTRL: (   2,   0,   7,  99)
-  N     TN             HN             Y(TN+HN)         YEX-U_N+1    UR_N+1-U_N+
   26 20.15612 10.00000000000000   .30156121413696E+02   .20814E-07   .60772E-08
   27 30.15612 18.00000000000000   .48156121413696E+02   .33237E-07   .97043E-08
   28 48.15612 32.39999999999986   .80556121413696E+02   .55597E-07   .16228E-07
   29 80.55612 50.00000000000000   .13055612141370E+03   .90104E-07   .26303E-07
   30130.55612 50.00000000000000   .18055612141370E+03   .12461E-06   .36365E-07
   31180.55612 50.00000000000000   .23055612141370E+03   .15914E-06   .46468E-07
   32230.55612 50.00000000000000   .28055612141370E+03   .19364E-06   .56541E-07
   33280.55612 50.00000000000000   .33055612141370E+03   .22814E-06   .66597E-07
   34330.55612 50.00000000000000   .38055612141370E+03   .26265E-06   .76681E-07
   35380.55612 50.00000000000000   .43055612141370E+03   .29716E-06   .86744E-07
   36430.55612 46.29591905753591   .47685204047123E+03   .32914E-06   .96094E-07
   37476.85204 23.14795952876739   .50000000000000E+03   .34511E-06   .10074E-06
-COLVI2 SUMMARY:
 IERROR =   0
 AVERAGE STEP   =13.1578947            VARIANCE       =  .410E+03
 MIN. STEP      =  .0382249            MAX. STEP      =50.0000000
 # SUCC. STEPS  =        38            # FAILURES     =         0
 # KEV.         =     34170            # CORRECTOR IT.=        48
 # CP SECONDS   =         1            LAST T-VALUE   =  .500E+03
-GLOB.ERR.EST.=   .1007356332E-06    GLOB.ERR.=   .3451059456E-06    SD =  9.16

