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