C ALGORITHM 569 C C COLSYS: COLLOCATION SOFTWARE FOR BOUNDARY VALUE ODE'S C C BY U. ASCHER, J. CHRISTIANSEN AND R.D. RUSSELL C C ACM TRANSACTIONS ON MATHEMATICAL SOFTWARE, JUNE 1981 C C THE FILE IS IN TWO PARTS OF ABOUT EQUAL LENGTH AND SEPARATED BY C A LINE CONTAINING 'C###'. THE FIRST PART IS THE SINGLE-PRECISION C VERSION OF THE SOFTWARE. THE SECOND PART IS THE IBM (REAL*8) C VERSION. C C-----------------------------------------------------------------------COL 10 C P A R T 1 COL 20 C MAIN STORAGE ALLOCATION AND PROGRAM CONTROL SUBROUTINES COL 30 C-----------------------------------------------------------------------COL 40 C COL 50 SUBROUTINE COLSYS(NCOMP, M, ALEFT, ARIGHT, ZETA, IPAR, LTOL, TOL, COL 60 * FIXPNT, ISPACE, FSPACE, IFLAG, FSUB, DFSUB, GSUB, DGSUB, SOLUTN) C C C*********************************************************************** C C PURPOSE C C SUBROUTINE COLSYS SOLVES A MULTI-POINT BOUNDARY VALUE C PROBLEM FOR A MIXED ORDER SYSTEM OF ODE-S GIVEN BY C C (M(I)) C U = F ( X; Z(U(X)) ) I = 1, ... ,NCOMP C I I C C ALEFT .LT. X .LT. ARIGHT, C C C G ( ZETA(J); Z(U(ZETA(J))) )= 0 J = 1, ... ,MSTAR C J C MSTAR=M(1)+M(2)+...+M(NCOMP), C C C WHERE T C U = (U , U , ... ,U ) IS THE EXACT SOLUTION VECTOR C 1 2 NCOMP C C (MI) C U IS THE MI=M(I) TH DERIVATIVE OF U C I I C C (1) (M1-1) (MNCOMP-1) T C Z(U(X)) = (U (X),U (X),...,U (X),...,U (X)) C 1 1 1 NCOMP C C F (X,Z(U)) IS A (GENERALLY) NONLINEAR FUNCTION OF C I C Z(U)=Z(U(X)). C C G (ZETA(J);Z(U)) IS A (GENERALLY) NONLINEAR BOUNDARY C J C CONDITION. C C THE BOUNDARY POINTS SATISFY C ALEFT .LE. ZETA(1) .LE. .. .LE. ZETA(MSTAR) .LE. ARIGHT C C THE ORDERS MI OF THE DIFFERENTIAL EQUATIONS SATISFY C M1 .LE. M2 .LE. ... .LE. MNCOMP .LE. 4. C C C*********************************************************************** C C WRITTEN BY C U. ASCHER, C DEPARTMENT OF COMPUTER SCIENCE, C UNIVERSITY OF BRITISH COLUMBIA, C VANCOUVER, B. C., CANADA V6T 1W5 C J. CHRISTIANSEN AND C R. D. RUSSELL, C MATHEMATICS DEPARTMENT, C SIMON FRASER UNIVERSITY, C BURNABY, B. C., CANADA V5A 1S6 C C*********************************************************************** C C METHOD C C THE METHOD USED TO APPROXIMATE THE SOLUTION U IS C COLLOCATION AT GAUSSIAN POINTS, USING B-SPLINES OF C ORDER K+MI AND CONTINUITY MI-1 IN THE I-TH COMPONENT, C I = 1, ..., NCOMP. HERE, K IS THE NUMBER OF COLLOCATION C POINTS PER SUBINTERVAL AND IS CHOSEN SUCH THAT K .GE. M(NCOMP). C C MAIN REFERENCES C C (1) U. ASCHER, J. CHRISTIANSEN AND R.D. RUSSELL, C C A COLLOCATION SOLVER FOR MIXED ORDER C SYSTEMS OF BOUNDARY VALUE PROBLEMS C C TECH. REP. 77-13, DEPT. COMPUTER SC., UNIV. B.C., C VANCOUVER, CANADA. TO APPEAR IN MATH. COMP. C C (2) U. ASCHER, J. CHRISTIANSEN AND R.D. RUSSELL, C C COLSYS - A COLLOCATION CODE FOR BOUNDARY C VALUE PROBLEMS C C PROC. CONF. FOR CODES FOR BVP-S IN ODE-S, C HOUSTON, TEXAS, 1978. C C OTHER REFERENCES C C (3) U. ASCHER AND R. D. RUSSELL C C EVALUATION OF B-SPLINES FOR SOLVING SYSTEMS C OF BOUNDARY VALUE PROBLEMS C C TECH. REP. 77-14, DEPT. COMPUTER SC., UNIV. B.C., C VANCOUVER, CANADA. C C (4) C. DEBOOR AND R. WEISS C C SOLVEBLOK: A PACKAGE FOR SOLVING ALMOST BLOCK DIAGONAL C LINEAR SYSTEMS, WITH APPLICATIONS TO SPLINE APPROXIMATION C AND THE NUMERICAL SOLUTION OF ORDINARY DIFFERENTIAL EQUATIONS C C MRC TECH REPORT 1625, UNIVERSITY OF WISCONSIN - MADISON C C C (5) R. D. RUSSELL AND J. CHRISTIANSEN C C ADAPTIVE MESH SELECTION STRATEGIES FOR C SOLVING BOUNDARY VALUE PROBLEMS C C SIAM J. NUMER. ANAL. 7(1978), 59-80. C C*********************************************************************** C C *************** INPUT TO COLSYS *************** C C VARIABLES C C NCOMP - NO. OF DIFFERENTIAL EQUATIONS (NCOMP .LE. 20) C C M(J) - ORDER OF THE J-TH DIFFERENTIAL EQUATION ( M(J).LE.M(J+1) C AND MSTAR = M(1) + ... + M(NCOMP) .LE. 40 ) C C ALEFT - LEFT END OF INTERVAL C C ARIGHT - RIGHT END OF INTERVAL C C ZETA(J) - J-TH SIDE CONDITION POINT (BOUNDARY POINT). MUST C HAVE ZETA(J) .LE. ZETA(J+1) C C IPAR - AN INTEGER ARRAY DIMENSIONED AT LEAST 11. C A LIST OF THE PARAMETERS IN IPAR AND THEIR MEANING FOLLOWS. C SOME PARAMETERS ARE RENAMED IN COLSYS, THESE NEW NAMES ARE C GIVEN IN PARENTHESES. C C IPAR(1) ( = NONLIN ) C = 0 IF THE PROBLEM IS LINEAR C = 1 IF THE PROBLEM IS NONLINEAR C C IPAR(2) = NO. OF COLLOCATION POINTS PER SUBINTERVAL (= K ) C WHERE M(NCOMP) .LT. K .LE. 7 . IF IPAR(2)=0 THEN C COLSYS SETS K = MAX ( M(NCOMP)+1, 5-M(NCOMP) ) C C IPAR(3) = NO. OF SUBINTERVALS IN THE INITIAL MESH ( = N ). C IF IPAR(3) = 0 THEN COLSYS ARBITRARILY SETS N = 5. C C IPAR(4) = NO. OF SOLUTION AND DERIVATIVE TOLERANCES. ( = NTOL ) C WE REQUIRE 0 .LT. NTOL .LE. MSTAR. C C IPAR(5) = DIMENSION OF FSPACE. ( = NDIMF ) C C IPAR(6) = DIMENSION OF ISPACE. ( = NDIMI ) C C IPAR(7) - OUTPUT CONTROL ( = IPRINT ) C = -1 FOR FULL DIAGNOSTIC PRINTOUT C = 0 FOR SELECTED PRINTOUT C = 1 FOR NO PRINTOUT C C IPAR(8) ( = IREAD ) C = 0 CAUSES COLSYS TO GENERATE A UNIFORM INITIAL MESH. C = 1 IF THE INITIAL MESH IS PROVIDED BY THE USER. IT C IS DEFINED IN FSPACE AS FOLLOWS: THE MESH C ALEFT=X(1).LT.X(2).LT. ... .LT.X(N).LT.X(N+1)=ARIGHT C WILL OCCUPY FSPACE(1), ..., FSPACE(N+1). THE C USER NEEDS TO SUPPLY ONLY THE INTERIOR MESH C POINTS FSPACE(J) = X(J), J = 2, ..., N. C = 2 IF THE INITIAL MESH IS SUPPLIED BY THE USER C AS WITH IPAR(8)=1, AND IN ADDITION NO ADAPTIVE C MESH SELECTION IS TO BE DONE. C C IPAR(9) ( = IGUESS ) C = 0 IF NO INITIAL GUESS FOR THE SOLUTION IS C PROVIDED. C = 1 IF AN INITIAL GUESS IS PROVIDED BY THE USER C IN SUBROUTINE SOLUTN. C = 2 IF AN INITIAL MESH AND APPROXIMATE SOLUTION C COEFFICIENTS ARE PROVIDED BY THE USER IN FSPACE. C (THE FORMER AND NEW MESH ARE THE SAME). C = 3 IF A FORMER MESH AND AN APPROXIMATE SOLUTION C COEFFICIENTS ARE PROVIDED BY THE USER IN FSPACE, C AND THE NEW MESH IS TO BE TAKEN TWICE AS COARSE. C = 4 IF IN ADDITION TO A FORMER INITIAL MESH AND AN C APPROXIMATE SOLUTION COEFFICIENTS, A NEW MESH C IS PROVIDED IN FSPACE AS WELL. C (SEE DESCRIPTION OF OUTPUT FOR FURTHER DETAILS C ON IGUESS = 2, 3, AND 4.) C C IPAR(10)= 0 IF THE PROBLEM IS REGULAR C = 1 IF THE FIRST RELAX FACTOR IS =RSTART, AND THE C NONLINEAR ITERATION DOES NOT RELY ON PAST COVERGENCE C (USE FOR AN EXTRA SENSITIVE NONLINEAR PROBLEM ONLY). C = 2 IF WE ARE TO RETURN IMMEDIATELY UPON (A) TWO C SUCCESSIVE NONCONVERGENCES, OR (B) AFTER OBTAINING C ERROR ESTIMATE FOR THE FIRST TIME. C C IPAR(11)= NO. OF FIXED POINTS IN THE MESH OTHER THAN C ALEFT AND ARIGHT. ( = NFXPNT , THE DIMENSION OF FIXPNT) C C LTOL - AN ARRAY OF DIMENSION IPAR(4). LTOL(J) = L SPECIFIES C THAT THE J-TH TOLERANCE IN TOL CONTROLS THE ERROR C IN THE L-TH COMPONENT OF Z(U). ALSO REQUIRE THAT C 1.LE.LTOL(1).LT.LTOL(2).LT. ... .LT.LTOL(NTOL).LE.MSTAR C C TOL - AN ARRAY OF DIMENSION IPAR(4). TOL(J) IS THE C ERROR TOLERANCE ON THE LTOL(J) -TH COMPONENT C OF Z(U). THUS, THE CODE ATTEMPTS TO SATISFY C FOR J=1,...,NTOL ON EACH SUBINTERVAL C ABS(Z(V)-Z(U)) .LE. TOL(J)*Z(U) +TOL(J) C LTOL(J) LTOL(J) C C IF V(X) IS THE APPROXIMATE SOLUTION VECTOR. C C FIXPNT - AN ARRAY OF DIMENSION IPAR(11). IT CONTAINS C THE POINTS, OTHER THAN ALEFT AND ARIGHT, WHICH C ARE TO BE INCLUDED IN EVERY MESH. C C ISPACE - AN INTEGER WORK ARRAY OF DIMENSION IPAR(6). C ITS SIZE PROVIDES A CONSTRAINT ON NMAX, C THE MAXIMUM NUMBER OF SUBINTERVALS. CHOOSE C IPAR(6) ACCORDING TO THE FORMULA C IPAR(6) .GE. NMAX*NSIZEI C WHERE C NSIZEI = 3 + KDM - NREC C WITH C KDM = KD + MSTAR ; KD = K * NCOMP ; C NREC = NO. OF RIGHT END BOUNDARY CONDITIONS. C C C FSPACE - A REAL WORK ARRAY OF DIMENSION IPAR(5). C ITS SIZE PROVIDES A CONSTRAINT ON NMAX. C CHOOSE IPAR(5) ACCORDING TO THE FORMULA C IPAR(5) .GE. NMAX*NSIZEF C WHERE C NSIZEF = 4 + K + 2 * KD + (4+2*K) * MSTAR + C (KDM-NREC) * (KDM+1). C C C IFLAG - THE MODE OF RETURN FROM COLSYS. C = 1 FOR NORMAL RETURN C = 0 IF THE COLLOCATION MATRIX IS SINGULAR. C =-1 IF THE EXPECTED NO. OF SUBINTERVALS EXCEEDS STORAGE C SPECIFICATIONS. C =-2 IF THE NONLINEAR ITERATION HAS NOT CONVERGED. C =-3 IF THERE IS AN INPUT DATA ERROR. C C C*********************************************************************** C C ********** USER SUPPLIED EXTERNAL SUBROUTINES ******* C C C FSUB - NAME OF SUBROUTINE FOR EVALUATING F(X,Z(U(X))) = C T C (F ,...,F ) AT A POINT X IN (ALEFT,ARIGHT). IT C 1 NCOMP C SHOULD HAVE THE HEADING C C SUBROUTINE FSUB (X , Z , F) C C WHERE F IS THE VECTOR CONTAINING THE VALUE OF FI(X,Z(U)) C IN THE I-TH COMPONENT AND T C Z(U(X))=(Z(1),...,Z(MSTAR)) C IS DEFINED AS ABOVE UNDER PURPOSE . C C C DFSUB - NAME OF SUBROUTINE FOR EVALUATING THE JACOBIAN OF C F(X,Z(U)) AT A POINT X. IT SHOULD HAVE THE HEADING C C SUBROUTINE DFSUB (X , Z , DF) C C WHERE Z(U(X)) IS DEFINED AS FOR FSUB AND THE (NCOMP) BY C (MSTAR) ARRAY DF SHOULD BE FILLED BY THE PARTIAL DERIV- C ATIVES OF F, VIZ, FOR A PARTICULAR CALL ONE CALCULATES C DF(I,J) = DFI / DZJ, I=1,...,NCOMP C J=1,...,MSTAR. C C C GSUB - NAME OF SUBROUTINE FOR EVALUATING THE I-TH COMPONENT OF C G(X,Z(U(X))) = G (ZETA(I),Z(U(ZETA(I)))) AT A POINT X = C I C ZETA(I) WHERE 1.LE.I.LE.MSTAR. IT SHOULD HAVE THE HEADING C C SUBROUTINE GSUB (I , Z , G) C C WHERE Z(U) IS AS FOR FSUB, AND I AND G=G ARE AS ABOVE. C I C NOTE THAT IN CONTRAST TO F IN FSUB , HERE C ONLY ONE VALUE PER CALL IS RETURNED IN G. C C C DGSUB - NAME OF SUBROUTINE FOR EVALUATING THE I-TH ROW OF C THE JACOBIAN OF G(X,U(X)). IT SHOULD HAVE THE HEADING C C SUBROUTINE DGSUB (I , Z , DG) C C WHERE Z(U) IS AS FOR FSUB, I AS FOR GSUB AND THE MSTAR- C VECTOR DG SHOULD BE FILLED WITH THE PARTIAL DERIVATIVES C OF G, VIZ, FOR A PARTICULAR CALL ONE CALCULATES C DG(I,J) = DGI / DZJ J=1,...,MSTAR. C C C SOLUTN- NAME OF SUBROUTINE TO EVALUATE THE INITIAL C APPROXIMATION FOR Z(U(X)) AND FOR DMVAL(U(X))= VECTOR C OF THE MJ-TH DERIVATIVES OF U(X). IT SHOULD HAVE THE C HEADING C C SUBROUTINE SOLUTN (X , Z , DMVAL) C C NOTE THAT THIS SUBROUTINE IS NEEDED ONLY IF USING C IPAR(9) = 1, AND THEN ALL MSTAR COMPONENTS OF Z C AND NCOMP COMPONENTS OF DMVAL SHOULD BE SPECIFIED C FOR ANY X, ALEFT .LE. X .LE. ARIGHT . C C C*********************************************************************** C C *************** OUTPUT FROM COLSYS *************** C C C UPON RETURN FROM COLSYS , THE USER MAY PRODUCE THE C SOLUTION VECTOR Z( U(X) ) AT A POINT X, ALEFT.LE.X.LE.ARIGHT C BY CALLING : C C CALL APPSLN (X, Z, FSPACE, ISPACE) C C THIS SETS UP A STANDARD CALL TO APPROX . FOR A MORE C EFFICIENT OR SOPHISTICATED RETRIEVAL OF THE SOLUTION C VALUES, CALL APPROX DIRECTLY (SEE DOCUMENTATION IN C APPROX - THE PARAMETERS NEEDED IN THE CALL TO APPROX C BY THE USER ARE SAVED IN ISPACE AND FSPACE BEFORE C COLSYS RETURNS). C C IN ORDER TO SAVE THE COEFFICIENTS OF THE SOLUTION FOR LATER C REFERENCE, ISPACE(1), ..., ISPACE(7+MSTAR) AND C FSPACE(1), ..., FSPACE(ISPACE(7)) SHOULD BE C SAVED, SINCE THESE ARE USED IN THE CALL TO APPSLN (APPROX). C C ONE CAN ALSO USE THE FORMERLY OBTAINED APPROXIMATE C SOLUTION AS A FIRST APPROXIMATION FOR THE NONLINEAR ITERATION C ON A NEW PROBLEM (E.G. FOR CONTINUATION PURPOSES). THIS C INVOLVES USING IGUESS = 2, 3, OR 4, AS FOLLOWS: C C FOR IGUESS= 2 OR 3, THE USER SHOULD PUT THE ABOVE SAVED C VALUES BACK INTO FSPACE(1),...,FSPACE(ISPACE(6)). C THE SIZE OF THE FORMER MESH, NOLD, IS PROVIDED IN IPAR(3). IF C IGUESS=2 THEN THE SIZE OF THE NEW MESH, N, IS TAKEN TO BE =NOLD. C IF IGUESS=3 THEN N := NOLD/2 AND THE NEW MESH IS TO BE TWICE AS C COARSE. C FOR IGUESS=4, PUT N IN IPAR(3) AND NOLD IN ISPACE(1). THE C VALUES OF THE FORMER SOLUTION, SAVED AS DESCRIBED ABOVE, C SHOULD BE PUT INTO FSPACE(N+2),...,FSPACE(ISPACE(6)+N+1), AND C A NEW MESH UNRELATED TO THE FORMER ONE IS PRESCRIBED IN C FSPACE(1),...,FSPACE(N+1). C C C*********************************************************************** C C *************** PACKAGE SUBROUTINES *************** C C THE FOLLOWING DESCRIPTION GIVES A BRIEF OVERVIEW OF HOW THE C PROCEDURE IS BROKEN DOWN INTO THE SUBROUTINES WHICH MAKE UP C THE PACKAGE CALLED COLSYS . FOR FURTHER DETAILS THE C USER SHOULD REFER TO DOCUMENTATION IN THE VARIOUS SUBROUTINES C AND TO THE REFERENCES CITED ABOVE. C C THE SUBROUTINES FALL INTO FOUR GROUPS: C C PART 1 - THE MAIN STORAGE ALLOCATION AND PROGRAM CONTROL SUBROUTINES. C C COLSYS - TESTS INPUT VALUES, DOES INITIALIZATION AND BREAKS UP C THE WORK AREAS, FSPACE AND ISPACE, INTO THE ARRAYS C USED BY THE PROGRAM. C C CONTRL - IS THE ACTUAL DRIVER OF THE PACKAGE. THIS ROUTINE C CONTAINS THE STRATEGY FOR NONLINEAR PROBLEMS. C C C PART 2 - MESH SELECTION AND ERROR ESTIMATION SUBROUTINES C C CONSTS - IS CALLED ONCE BY COLSYS TO INITIALIZE CONSTANTS C WHICH ARE USED FOR ERROR ESTIMATION AND MESH SELECTION. C C NEWMSH - GENERATES MESHES. IT CONTAINS THE TEST TO DECIDE C WHETHER OR NOT TO REDISTRIBUTE A MESH. C C ERRCHK - PRODUCES ERROR ESTIMATES AND CHECKS AGAINST THE C TOLERANCES AT EACH SUBINTERVAL C C C PART 3 - COLLOCATION SYSTEM SET-UP SUBROUTINES C C LSYSLV - CONTROLS THE SET-UP AND SOLUTION OF THE LINEAR C ALGEBRAIC SYSTEMS OF COLLOCATION EQUATIONS WHICH C ARISE AT EACH NEWTON ITERATION. C C BLDBLK - IS USED BY LSYSLV TO SET UP THE EQUATION(S) ASSOCIATED C WITH A SIDE CONDITION POINT OR A COLLOCATION POINT. C C C PART 4 - B-SPLINE SUBROUTINES C C APPSLN - SETS UP A STANDARD CALL TO APPROX . C C APPROX - EVALUATES A PIECEWISE POLYNOMIAL SOLUTION. C C BSPFIX - EVALUATES THE MESH INDEPENDENT B-SPLINES C (I.E. THE FIXED B-SPLINES) C C BSPVAR - EVALUATES THE MESH DEPENDENT B-SPLINES (I.E. THE C VARYING B-SPLINES) C C BSPDER - GENERATES VALUES FOR THE DERIVATIVES NEEDED TO SET C UP THE COLLOCATION EQUATIONS. C C APPDIF - GENERATES A DIVIDED DIFFERENCE TABLE FROM THE B-SPLINE C COEFFICIENTS FOR A COLLOCATION SOLUTION. THE TABLE C IS USED IN APPROX . C C HORDER - EVALUATES THE HIGHEST ORDER DERIVATIVES OF THE C CURRENT COLLOCATION SOLUTION USED FOR MESH REFINEMENT. C C C TO SOLVE THE LINEAR SYSTEMS OF COLLOCATION EQUATIONS C CONSTRUCTED IN PART 3, COLSYS USES THE PACKAGE C SOLVEBLOK OF DE BOOR - WEISS (TO APPEAR IN TOMS). C C C---------------------------------------------------------------------- COMMON /ORDER/ K, NC, MSTAR, KD, KDM, MNSUM, MT(20) COMMON /APPR/ N, NOLD, NMAX, NALPHA, MSHFLG, MSHNUM, MSHLMT, * MSHALT COMMON /SIDE/ TZETA(40), TLEFT, TRIGHT, IZETA, IWR COMMON /NONLN/ PRECIS, NONLIN, ITER, LIMIT, ICARE, IPRINT, * IGUESS, IFREEZ COMMON /EQORD/ IND(5), INEQ(20), MND(5), ND, NEQ COMMON /ERRORS/ TTL(40), WGTMSH(40), TOLIN(40), ROOT(40), * JTOL(40), LTTOL(40), NTOL EXTERNAL FSUB, DFSUB, GSUB, DGSUB, SOLUTN DIMENSION M(1), ZETA(1), IPAR(1), LTOL(1), TOL(1), FIXPNT(1), * ISPACE(1), FSPACE(1) C*********************************************************************** C C THE ACTUAL SUBROUTINE COLSYS SERVES AS AN INTERFACE WITH C THE PACKAGE OF SUBROUTINES REFERRED TO COLLECTIVELY AS C COLSYS. THE SUBROUTINE SERVES TO TEST SOME OF THE INPUT C PARAMETERS, RENAME SOME OF THE PARAMETERS (TO MAKE UNDER- C STANDING OF THE CODING EASIER), TO DO SOME INITIALIZATION, C AND TO BREAK THE WORK AREAS FSPACE AND ISPACE UP INTO THE C ARRAYS NEEDED BY THE PROGRAM. C C*********************************************************************** C C... SPECIFY MACHINE DEPENDENT OUTPUT UNIT IWR AND COMPUTE MACHINE C... DEPENDENT CONSTANT PRECIS = 100 * MACHINE UNIT ROUNDOFF C IWR = 6 PRECIS = 1. 10 PRECIS = PRECIS/2. PRECP1 = PRECIS + 1. IF (PRECP1.GT.1.) GO TO 10 PRECIS = PRECIS*100. C C... IN CASE INCORRECT INPUT DATA IS DETECTED, THE PROGRAM RETURNS C... IMMEDIATELY WITH IFLAG=-3. C IFLAG = -3 IF (NCOMP.LT.1 .OR. NCOMP.GT.20) RETURN IF (M(1).LT.1 .OR. M(NCOMP).GT.4) RETURN IF (NCOMP.EQ.1) GO TO 30 DO 20 I=2,NCOMP IF (M(I-1).GT.M(I)) RETURN 20 CONTINUE 30 CONTINUE C C... RENAME SOME OF THE PARAMETERS AND SET DEFAULT VALUES. C NONLIN = IPAR(1) K = IPAR(2) IF (K.EQ.0) K = MAX0(M(NCOMP)+1,5-M(NCOMP)) N = IPAR(3) IF (N.EQ.0) N = 5 IREAD = IPAR(8) IGUESS = IPAR(9) IF (NONLIN.EQ.0 .AND. IGUESS.EQ.1) IGUESS = 0 IF (IGUESS.GE.2 .AND. IREAD.EQ.0) IREAD = 1 ICARE = IPAR(10) NTOL = IPAR(4) NDIMF = IPAR(5) NDIMI = IPAR(6) NFXPNT = IPAR(11) IPRINT = IPAR(7) MSTAR = 0 MNSUM = 0 DO 40 I=1,NCOMP MNSUM = MNSUM + M(I)**2 MSTAR = MSTAR + M(I) 40 CONTINUE DO 50 I=1,NCOMP MT(I) = M(I) 50 CONTINUE DO 60 I=1,MSTAR TZETA(I) = ZETA(I) 60 CONTINUE DO 70 I=1,NTOL LTTOL(I) = LTOL(I) TOLIN(I) = TOL(I) 70 CONTINUE TLEFT = ALEFT TRIGHT = ARIGHT NC = NCOMP KD = K*NCOMP KDM = KD + MSTAR C C... PRINT THE INPUT DATA FOR CHECKING. C IF (IPRINT.GT.(-1)) GO TO 100 IF (NONLIN.GT.0) GO TO 80 WRITE (IWR,99999) NCOMP, (M(IP),IP=1,NCOMP) GO TO 90 80 WRITE (IWR,99998) NCOMP, (M(IP),IP=1,NCOMP) 90 WRITE (IWR,99997) (ZETA(IP),IP=1,MSTAR) WRITE (IWR,99996) K WRITE (IWR,99995) (LTOL(IP),IP=1,NTOL) WRITE (IWR,99994) (TOL(IP),IP=1,NTOL) IF (IGUESS.GE.2) WRITE (IWR,99993) IF (IREAD.EQ.2) WRITE (IWR,99992) IF (NFXPNT.GT.0) WRITE (IWR,99991) NFXPNT, (FIXPNT(IP),IP=1, * NFXPNT) 100 CONTINUE C C... CHECK FOR CORRECTNESS OF DATA C IF (K.LT.0 .OR. K.GT.7) RETURN IF (N.LT.0) RETURN IF (IREAD.LT.0 .OR. IREAD.GT.2) RETURN IF (IGUESS.LT.0 .OR. IGUESS.GT.4) RETURN IF (ICARE.LT.0 .OR. ICARE.GT.2) RETURN IF (NTOL.LT.0 .OR. NTOL.GT.MSTAR) RETURN IF (NFXPNT.LT.0) RETURN IF (IPRINT.LT.(-1) .OR. IPRINT.GT.1) RETURN IF (MSTAR.LT.0 .OR. MSTAR.GT.40) RETURN C C... SET LIMITS ON ITERATIONS AND INITIALIZE COUNTERS. C... LIMIT = MAXIMUM NUMBER OF NEWTON ITERATIONS PER MESH. C... SEE SUBROUTINE NEWMSH FOR THE ROLES OF MSHLMT , MSHFLG , C... MSHNUM , AND MSHALT . C MSHLMT = 3 MSHFLG = 0 MSHNUM = 1 MSHALT = 1 LIMIT = 40 C C... COMPUTE THE MAXIUM POSSIBLE N FOR THE GIVEN SIZES OF C... ISPACE AND FSPACE. C NREC = 0 DO 110 II=1,MSTAR I = MSTAR + 1 - II IF (ZETA(I).LT.ARIGHT) GO TO 110 NREC = II 110 CONTINUE NFIXI = NREC NSIZEI = 3 + KDM - NREC NFIXF = NREC*(KDM+1) + 2*MNSUM + 2*MSTAR + 3 NSIZEF = 4 + K + 2*KD + (4+2*K)*MSTAR + (KDM-NREC)*(KDM+1) NMAXF = (NDIMF-NFIXF)/NSIZEF NMAXI = (NDIMI-NFIXI)/NSIZEI IF (IPRINT.LT.1) WRITE (IWR,99990) NMAXF, NMAXI NMAX = MIN0(NMAXF,NMAXI) IF (NMAX.LT.N) RETURN IF (NMAX.LT.NFXPNT+1) RETURN IF (NMAX.LT.2*NFXPNT+2 .AND. IPRINT.LT.1) WRITE (IWR,99989) C C... GENERATE POINTERS TO BREAK UP FSPACE AND ISPACE . C LXI = 1 LA = LXI + NMAX + 1 LXIOLD = LA + KDM*(NMAX*(KDM-NREC)+NREC) LXIJ = LXIOLD + NMAX + 1 LALPHA = LXIJ + K*NMAX LDLPHA = LALPHA + NMAX*KD + MSTAR LELPHA = LDLPHA + NMAX*KD + MSTAR LALDIF = LELPHA + NMAX*K*MSTAR + MNSUM LRHS = LALDIF + NMAX*K*MSTAR + MNSUM LVALST = LRHS + NMAX*(KDM-NREC) + NREC LSLOPE = LVALST + 4*MSTAR*NMAX LACCUM = LSLOPE + NMAX LIPIV = 1 LINTEG = LIPIV + (LVALST-LRHS) C C... IF IGUESS .GE. 2, MOVE XIOLD AND ALDIF TO THEIR PROPER C... LOCATIONS IN FSPACE. C IF (IGUESS.LT.2) GO TO 160 NOLD = N IF (IGUESS.EQ.4) NOLD = ISPACE(1) NALDIF = NOLD*K*MSTAR + MNSUM NP1 = N + 1 IF (IGUESS.EQ.4) NP1 = NP1 + NOLD + 1 DO 120 I=1,NALDIF FSPACE(LALDIF+I-1) = FSPACE(NP1+I) 120 CONTINUE NP1 = NOLD + 1 IF (IGUESS.EQ.4) GO TO 140 DO 130 I=1,NP1 FSPACE(LXIOLD+I-1) = FSPACE(LXI+I-1) 130 CONTINUE GO TO 160 140 DO 150 I=1,NP1 FSPACE(LXIOLD+I-1) = FSPACE(N+1+I) 150 CONTINUE 160 CONTINUE C C... INITIALIZE COLLOCATION POINTS, CONSTANTS, MESH. C CALL CONSTS CALL NEWMSH(3+IREAD, FSPACE(LXI), FSPACE(LXIOLD), FSPACE(LXIJ), * DUM1, DUM2, DUM3, DUM4, NFXPNT, FIXPNT) C C... DETERMINE WHICH ARE THE DIFFERENT ORDER EQUATIONS AND C... PUT THESE ORDERS IN MND , ALSO GENERATE THE POINTERS C... IND AND INEQ WHICH WILL BE USED IN BSPDER . C IND(1) = 1 MND(1) = M(1) ND = 1 NEQ = 0 IG = (M(1)+1)*(M(1)+K) + 1 IF (NCOMP.LE.1) GO TO 200 DO 190 J=2,NCOMP MJ = M(J) IF (MJ.EQ.M(J-1)) GO TO 170 ND = ND + 1 IND(ND) = IG MND(ND) = MJ GO TO 180 170 NEQ = NEQ + 1 INEQ(NEQ) = IG 180 IG = IG + (MJ+1)*(MJ+K) 190 CONTINUE IND(ND+1) = IND(ND) + IG 200 CONTINUE C C... DETERMINE FIRST APPROXIMATION, IF THE PROBLEM IS NONLINEAR. C IF (IGUESS.GE.2) GO TO 230 NP1 = N + 1 DO 210 I=1,NP1 FSPACE(I+LXIOLD-1) = FSPACE(I+LXI-1) 210 CONTINUE NOLD = N IF (NONLIN.EQ.0 .OR. IGUESS.EQ.1) GO TO 230 C C... SYSTEM PROVIDES FIRST APPROXIMATION OF THE SOLUTION. C... CHOOSE Z(J) = 0 FOR J=1,..,MSTAR. C DO 220 I=1,NALPHA FSPACE(I+LALPHA-1) = 0. 220 CONTINUE CALL APPDIF(FSPACE(LALDIF), FSPACE(LALPHA), FSPACE(LXI), N, K, * NC, MT, MSTAR) 230 CONTINUE IF (IGUESS.GE.2) IGUESS = 0 CALL CONTRL(FSPACE(LXI), FSPACE(LXIOLD), FSPACE(LXIJ), * FSPACE(LALPHA), FSPACE(LALDIF), FSPACE(LRHS), FSPACE(LDLPHA), * FSPACE(LELPHA), FSPACE(LA), FSPACE(LVALST), FSPACE(LSLOPE), * FSPACE(LACCUM), ISPACE(LIPIV), ISPACE(LINTEG), NFXPNT, FIXPNT, * IFLAG, FSUB, DFSUB, GSUB, DGSUB, SOLUTN) C... PREPARE OUTPUT ISPACE(1) = N ISPACE(2) = K ISPACE(3) = NCOMP ISPACE(4) = MSTAR NALDIF = N*K*MSTAR + MNSUM ISPACE(5) = NALDIF ISPACE(6) = NALDIF + N + 2 ISPACE(7) = ISPACE(6) + 65 DO 240 I=1,NCOMP ISPACE(7+I) = M(I) 240 CONTINUE DO 250 I=1,NALDIF FSPACE(N+1+I) = FSPACE(LALDIF-1+I) 250 CONTINUE RETURN C----------------------------------------------------------------------- 99999 FORMAT (///37H THE NUMBER OF (LINEAR) DIFF EQNS IS , I3/1X, * 16HTHEIR ORDERS ARE, 20I3) 99998 FORMAT (///40H THE NUMBER OF (NONLINEAR) DIFF EQNS IS , I3/1X, * 16HTHEIR ORDERS ARE, 20I3) 99997 FORMAT (27H SIDE CONDITION POINTS ZETA, 8F10.6, 4(/27X, 8F10.6)) 99996 FORMAT (37H NUMBER OF COLLOC PTS PER INTERVAL IS, I3) 99995 FORMAT (39H COMPONENTS OF Z REQUIRING TOLERANCES -, 8(7X, I2, * 1X), 4(/38X, 8I10)) 99994 FORMAT (33H CORRESPONDING ERROR TOLERANCES -, 6X, 8E10.2, 4(/39X, * 8E10.2)) 99993 FORMAT (44H INITIAL MESH(ES) AND ALPHA PROVIDED BY USER) 99992 FORMAT (27H NO ADAPTIVE MESH SELECTION) 99991 FORMAT (10H THERE ARE, I5, 27H FIXED POINTS IN THE MESH -, * 10(6E12.4/)) 99990 FORMAT (44H THE MAXIMUM NUMBER OF SUBINTERVALS IS MIN (, I4, * 23H (ALLOWED FROM FSPACE),, I4, 24H (ALLOWED FROM ISPACE) )) 99989 FORMAT (/53H INSUFFICIENT SPACE TO DOUBLE MESH FOR ERROR ESTIMATE) END C CON 10 C.......................................................................CON 20 C CON 30 SUBROUTINE CONTRL(XI, XIOLD, XIJ, ALPHA, ALDIF, RHS, DALPHA, CON 40 * EALPHA, A, VALSTR, SLOPE, ACCUM, IPIV, INTEGS, NFXPNT, FIXPNT, * IFLAG, FSUB, DFSUB, GSUB, DGSUB, SOLUTN) C C********************************************************************** C C PURPOSE C THIS SUBROUTINE IS THE ACTUAL DRIVER. THE NONLINEAR ITERATION C STRATEGY IS CONTROLLED HERE ( SEE (2) ). UPON CONVERGENCE, ERRCHK C IS CALLED TO TEST FOR SATISFACTION OF THE REQUESTED TOLERANCES. C C VARIABLES C C CHECK - MAXIMUM TOLERANCE VALUE, USED AS PART OF CRITERIA FOR C CHECKING FOR NONLINEAR ITERATION CONVERGENCE C RELAX - THE RELAXATION FACTOR FOR DAMPED NEWTON ITERATION C RELMIN - MINIMUM ALLOWABLE VALUE FOR RELAX (OTHERWISE THE C JACOBIAN IS CONSIDERED SINGULAR). C RLXOLD - PREVIOUS RELAX C RSTART - INITIAL VALUE FOR RELAX WHEN PROBLEM IS SENSITIVE C IFRZ - NUMBER OF FIXED JACOBIAN ITERATIONS C LMTFRZ - MAXIMUM VALUE FOR IFRZ BEFORE PERFORMING A REINVERSION C ITER - NUMBER OF ITERATIONS (COUNTED ONLY WHEN JACOBIAN C REINVERSIONS ARE PERFORMED). C XI - CURRENT MESH C XIOLD - PREVIOUS MESH C IPRED = 0 IF RELAX IS DETERMINED BY A CORRECTION C = 1 IF RELAX IS DETERMINED BY A PREDICTION C IFREEZ = 0 IF THE JACOBIAN IS TO BE INVERTED C = 1 IF THE JACOBIAN IS CURRENTLY FIXED (FROZEN) C ICON = 0 IF NO PREVIOUS CONVERGENCE HAS BEEN OBTAINED C = 1 IF CONVERGENCE ON A PREVIOUS MESH HAS BEEN OBTAINED C ICARE =-1 NO CONVERGENCE OCCURRED (USED FOR REGULAR PROBLEMS) C = 0 A REGULAR PROBLEM C = 1 A SENSITIVE PROBLEM C = 2 USED FOR CONTINUATION (SEE DESCRIPTION OF IPAR(10) C IN COLSYS). C RNORM - NORM OF RHS (RIGHT HAND SIDE) FOR CURRENT ITERATION C RNOLD - NORM OF RHS FOR PREVIOUS ITERATION C ANSCL - SCALED NORM OF NEWTON CORRECTION C ANFIX - SCALED NORM OF NEWTON CORRECTION AT NEXT STEP C ANORM - SCALED NORM OF A CORRECTION OBTAINED WITH JACOBIAN FIXED C NALDIF - NUMBER OF COMPONENTS OF ALDIF (SEE SUBROUTINE APPROX) C IMESH - A CONTROL VARIABLE FOR SUBROUTINES NEWMSH AND ERRCHK C C*********************************************************************** C EXTERNAL FSUB, DFSUB, GSUB, DGSUB, SOLUTN DIMENSION XI(1), XIOLD(1), XIJ(1), ALPHA(1), ALDIF(1), RHS(1) DIMENSION A(1), VALSTR(1), SLOPE(1), ACCUM(1), IPIV(1), INTEGS(1) DIMENSION DALPHA(1), EALPHA(1), FIXPNT(1) COMMON /ORDER/ K, NCOMP, MSTAR, KD, KDM, MNSUM, M(20) COMMON /APPR/ N, NOLD, NMAX, NALPHA, MSHFLG, MSHNUM, MSHLMT, * MSHALT COMMON /SIDE/ ZETA(40), ALEFT, ARIGHT, IZETA, IWR COMMON /NONLN/ PRECIS, NONLIN, ITER, LIMIT, ICARE, IPRINT, * IGUESS, IFREEZ COMMON /EQORD/ IND(5), INEQ(20), MND(5), ND, NEQ COMMON /ERRORS/ TOL(40), WGTMSH(40), TOLIN(40), ROOT(40), * JTOL(40), LTOL(40), NTOL C C... CONSTANTS FOR CONTROL OF NONLINEAR ITERATION C RELMIN = 1.E-3 RSTART = 1.E-2 LMTFRZ = 4 C C... COMPUTE THE MAXIMUM TOLERANCE C CHECK = 0. DO 10 I=1,NTOL CHECK = AMAX1(TOLIN(I),CHECK) 10 CONTINUE FALPHA = FLOAT(NALPHA) IMESH = 1 ICON = 0 IF (NONLIN.EQ.0) ICON = 1 ICOR = 0 LCONV = 0 C C... THE MAIN ITERATION BEGINS HERE C... LOOP 20 IS EXECUTED UNTIL ERROR TOLERANCES ARE SATISFIED OR C... THE CODE FAILS (DUE TO A SINGULAR MATRIX OR STORAGE LIMITATIONS) C 20 CONTINUE C C... INITIALIZATION FOR A NEW MESH C ITER = 0 NALDIF = N*K*MSTAR + MNSUM IF (NONLIN.GT.0) GO TO 60 C C... THE LINEAR CASE. C... SET UP AND SOLVE EQUATIONS C CALL LSYSLV(IFLAG, XI, XIOLD, XIJ, ALPHA, ALDIF, RHS, EALPHA, A, * IPIV, INTEGS, RNORM, 0, FSUB, DFSUB, GSUB, DGSUB, SOLUTN) C C... CHECK FOR A SINGULAR MATRIX C IF (IFLAG.NE.0) GO TO 40 30 IF (IPRINT.LT.1) WRITE (IWR,99999) RETURN C C... UPDATE THE OLD MESH C 40 NP1 = N + 1 DO 50 I=1,NP1 XIOLD(I) = XI(I) 50 CONTINUE NOLD = N C C... PREPARE TABLE OF DIVIDED DIFFERENCES AND CALL ERRCHK C CALL APPDIF(ALDIF, ALPHA, XI, N, K, NCOMP, M, MSTAR) GO TO 460 C C... ITERATION LOOP FOR NONLINEAR CASE C... DEFINE THE INITIAL RELAXATION PARAMETER (= RELAX) C 60 RELAX = 1. C C... CHECK FOR PREVIOUS CONVERGENCE AND PROBLEM SENSITIVITY C IF (ICARE.EQ.1 .OR. ICARE.EQ.(-1)) RELAX = RSTART IF (ICON.EQ.0) GO TO 140 C C... CONVERGENCE ON A PREVIOUS MESH HAS BEEN OBTAINED. THUS C... WE HAVE A VERY GOOD INITIAL APPROXIMATION FOR THE NEWTON C... PROCESS. PROCEED WITH ONE FULL NEWTON AND THEN ITERATE C... WITH A FIXED JACOBIAN. C IFREEZ = 0 C C... EVALUATE RIGHT HAND SIDE AND ITS NORM C CALL LSYSLV(IFLAG, XI, XIOLD, XIJ, DALPHA, ALDIF, RHS, ALPHA, A, * IPIV, INTEGS, RNORM, 1, FSUB, DFSUB, GSUB, DGSUB, SOLUTN) C C... SOLVE FOR THE NEXT ITERATE . C... THE VALUE OF IFREEZ DETERMINES WHETHER THIS IS A FULL C... NEWTON STEP (=0) OR A FIXED JACOBIAN ITERATION (=1). C IF (IPRINT.LT.0 .AND. ITER.EQ.0) WRITE (IWR,99995) 70 IF (IPRINT.LT.0) WRITE (IWR,99997) ITER, RNORM RNOLD = RNORM CALL LSYSLV(IFLAG, XI, XIOLD, XIJ, DALPHA, ALDIF, RHS, ALPHA, A, * IPIV, INTEGS, RNORM, 2+IFREEZ, FSUB, DFSUB, GSUB, DGSUB, SOLUTN) C C... CHECK FOR A SINGULAR MATRIX C IF (IFLAG.EQ.0) GO TO 30 IF (IFREEZ.EQ.1) GO TO 90 C C... A FULL NEWTON STEP C ITER = ITER + 1 IFRZ = 0 C C... UPDATE THE OLD MESH. C NP1 = N + 1 DO 80 I=1,NP1 XIOLD(I) = XI(I) 80 CONTINUE NOLD = N 90 CONTINUE C C... UPDATE ALPHA , COMPUTE NEW RHS AND ITS NORM C DO 100 I=1,NALPHA ALPHA(I) = ALPHA(I) + DALPHA(I) 100 CONTINUE CALL APPDIF(ALDIF, ALPHA, XI, N, K, NCOMP, M, MSTAR) CALL LSYSLV(IFLAG, XI, XIOLD, XIJ, DALPHA, ALDIF, RHS, ALPHA, A, * IPIV, INTEGS, RNORM, 1, FSUB, DFSUB, GSUB, DGSUB, SOLUTN) C C... CHECK MONOTONICITY. IF THE NORM OF RHS GETS SMALLER, C... PROCEED WITH A FIXED JACOBIAN; ELSE PROCEED CAUTIOUSLY, C... AS IF CONVERGENCE HAS NOT BEEN OBTAINED BEFORE (ICON=0). C IF (RNORM.LT.PRECIS) GO TO 410 IF (RNORM.LE.RNOLD) GO TO 120 IF (IPRINT.LT.0) WRITE (IWR,99997) ITER, RNORM IF (IPRINT.LT.0) WRITE (IWR,99994) ICON = 0 RELAX = RSTART DO 110 I=1,NALPHA ALPHA(I) = ALPHA(I) - DALPHA(I) 110 CONTINUE CALL APPDIF(ALDIF, ALPHA, XI, N, K, NCOMP, M, MSTAR) ITER = 0 GO TO 140 120 IF (IFREEZ.EQ.1) GO TO 130 IFREEZ = 1 GO TO 70 C C... VERIFY THAT THE LINEAR CONVERGENCE WITH FIXED JACOBIAN C... IS FAST ENOUGH. C 130 IFRZ = IFRZ + 1 IF (IFRZ.GE.LMTFRZ) IFREEZ = 0 IF (RNOLD.LT.4.*RNORM) IFREEZ = 0 GO TO 300 C C... NO PREVIOUS CONVERGENCE HAS BEEN OBTAINED. PROCEED C... WITH THE MODIFIED NEWTON METHOD. C... EVALUATE RHS. C 140 IF (IPRINT.LT.0) WRITE (IWR,99998) CALL LSYSLV(IFLAG, XI, XIOLD, XIJ, DALPHA, ALDIF, RHS, ALPHA, A, * IPIV, INTEGS, RNORM, 1, FSUB, DFSUB, GSUB, DGSUB, SOLUTN) C C... FIND A NEWTON DIRECTION C 150 RNOLD = RNORM IF (ITER.GE.LIMIT) GO TO 430 CALL LSYSLV(IFLAG, XI, XIOLD, XIJ, DALPHA, ALDIF, RHS, ALPHA, A, * IPIV, INTEGS, RNORM, 2, FSUB, DFSUB, GSUB, DGSUB, SOLUTN) C C... CHECK FOR A SINGULAR MATRIX C IF (IFLAG.EQ.0) GO TO 30 IF (ITER.GT.0) GO TO 170 C C... BOOKKEEPING FOR FIRST MESH C IF (IGUESS.EQ.1) IGUESS = 0 C C... UPDATE THE OLD MESH C NP1 = N + 1 DO 160 I=1,NP1 XIOLD(I) = XI(I) 160 CONTINUE NOLD = N GO TO 190 170 CONTINUE C C... PREDICT RELAXATION FACTOR FOR NEWTON STEP. C ANDIF = 0. DO 180 I=1,NALPHA ANDIF = ANDIF + (EALPHA(I)-DALPHA(I))**2/(ALPHA(I)*ALPHA(I) * +PRECIS) 180 CONTINUE RELAX = RELAX*ANSCL/AMAX1(SQRT(ANDIF/FALPHA),PRECIS) IF (RELAX.GT.1.) RELAX = 1. 190 RLXOLD = RELAX IPRED = 1 ITER = ITER + 1 C C... DETERMINE A NEW ALPHA AND FIND NEW RHS AND ITS NORM C DO 200 I=1,NALPHA ALPHA(I) = ALPHA(I) + RELAX*DALPHA(I) 200 CONTINUE 210 CALL APPDIF(ALDIF, ALPHA, XI, N, K, NCOMP, M, MSTAR) CALL LSYSLV(IFLAG, XI, XIOLD, XIJ, DALPHA, ALDIF, RHS, ALPHA, A, * IPIV, INTEGS, RNORM, 1, FSUB, DFSUB, GSUB, DGSUB, SOLUTN) C C... COMPUTE A FIXED JACOBIAN ITERATE (USED TO CONTROL RELAX) C CALL LSYSLV(IFLAG, XI, XIOLD, XIJ, EALPHA, ALDIF, RHS, ALPHA, A, * IPIV, INTEGS, RNORM, 3, FSUB, DFSUB, GSUB, DGSUB, SOLUTN) C C... FIND SCALED NORMS OF VARIOUS TERMS USED TO CORRECT RELAX C ANORM = 0. ANFIX = 0. ANSCL = 0. DO 220 I=1,NALPHA ANSCL = ANSCL + DALPHA(I)*DALPHA(I)/(ALPHA(I)*ALPHA(I)+PRECIS) SCALE = ALPHA(I) - RELAX*DALPHA(I) SCALE = 1./(SCALE*SCALE+PRECIS) ANORM = ANORM + DALPHA(I)*DALPHA(I)*SCALE ANFIX = ANFIX + EALPHA(I)*EALPHA(I)*SCALE 220 CONTINUE ANORM = SQRT(ANORM/FALPHA) ANFIX = SQRT(ANFIX/FALPHA) ANSCL = SQRT(ANSCL/FALPHA) IF (ICOR.EQ.1) GO TO 230 IF (IPRINT.LT.0) WRITE (IWR,99996) ITER, RELAX, ANORM, ANFIX, * RNOLD, RNORM GO TO 240 230 IF (IPRINT.LT.0) WRITE (IWR,99993) RELAX, ANORM, ANFIX, RNOLD, * RNORM 240 ICOR = 0 C C... CHECK FOR MONOTONIC DECREASE IN DALPHA. C IF (ANFIX.LT.PRECIS .OR. RNORM.LT.PRECIS) GO TO 410 IF (ANFIX.GT.ANORM) GO TO 250 C C... WE HAVE A DECREASE. IF EALPHA SMALL, CHECK CONVERGENCE C IF (ANFIX.LE.CHECK) GO TO 290 C C... CORRECT THE PREDICTED RELAX UNLESS THE CORRECTED C... VALUE IS WITHIN 10 PERCENT OF THE PREDICTED ONE. C IF (IPRED.NE.1) GO TO 150 250 IF (ITER.GE.LIMIT) GO TO 430 C C... CORRECT THE RELAXATION FACTOR. C IPRED = 0 ARG = (ANFIX/ANORM-1.)/RELAX + 1. IF (ARG.LT.0.0) GO TO 150 IF (ARG.LE..25*RELAX+.125*RELAX**2) GO TO 260 FACTOR = -1. + SQRT(1.+8.*ARG) IF (ABS(FACTOR-1.).LT..1*FACTOR) GO TO 150 RELAX = RELAX/FACTOR GO TO 270 260 IF (RELAX.GE..9) GO TO 150 RELAX = 1. 270 ICOR = 1 IF (RELAX.LT.RELMIN) GO TO 440 DO 280 I=1,NALPHA ALPHA(I) = ALPHA(I) + (RELAX-RLXOLD)*DALPHA(I) 280 CONTINUE RLXOLD = RELAX GO TO 210 C C... CHECK CONVERGENCE. C... COMPUTE DIVIDED DIFFERENCE TABLES FOR CORRECTION TERMS. C 290 CALL APPDIF(A, EALPHA, XI, N, K, NCOMP, M, MSTAR) GO TO 310 C C... IF ICON = 1 THEN ALSO SAVE A. C 300 CALL APPDIF(EALPHA, DALPHA, XI, N, K, NCOMP, M, MSTAR) 310 CONTINUE INN = 0 JCOL = 0 JINIT = 1 DO 380 I=1,NTOL JEND = JTOL(I) - 1 IF (JEND.LT.JINIT) GO TO 330 DO 320 J=JINIT,JEND MJ = M(J) NALPHJ = N*K + MJ JCOL = JCOL + MJ INN = INN + MJ*NALPHJ 320 CONTINUE 330 JINIT = JEND + 1 NALPHJ = N*K + M(JINIT) INN1 = INN JCOL1 = JCOL + 1 340 IF (JCOL1.EQ.LTOL(I)) GO TO 350 INN1 = INN1 + NALPHJ JCOL1 = JCOL1 + 1 GO TO 340 350 IINIT = JCOL1 - JCOL C C... CHECK THAT TOLERANCES ARE SATISFIED FOR B-SPLINE COEFFS. C DO 370 II=IINIT,NALPHJ IN = INN1 + II IF (ICON.EQ.1) GO TO 360 IF (ABS(A(IN)).GT.TOLIN(I)*(ABS(ALDIF(IN))+1.)) GO TO 420 GO TO 370 360 IF (ABS(EALPHA(IN)).GT.TOLIN(I)*(ABS(ALDIF(IN))+1.)) GO TO 420 370 CONTINUE 380 CONTINUE C C... CONVERGENCE OBTAINED C IF (IPRINT.LT.1) WRITE (IWR,99992) ITER IF (ICON.EQ.1) GO TO 460 C C... SINCE CONVERGENCE OBTAINED, UPDATE COEFFS WITH TERM FROM C... THE FIXED JACOBIAN ITERATION. C DO 390 I=1,NALDIF ALDIF(I) = ALDIF(I) + A(I) 390 CONTINUE DO 400 I=1,NALPHA ALPHA(I) = ALPHA(I) + EALPHA(I) 400 CONTINUE 410 IF ((ANFIX.LT.PRECIS .OR. RNORM.LT.PRECIS) .AND. IPRINT.LT.1) * WRITE (IWR,99992) ITER ICON = 1 IF (ICARE.EQ.(-1)) ICARE = 0 GO TO 460 C C... NO CONVERGENCE. REPEAT C 420 IF (ICON.EQ.0) GO TO 150 GO TO 70 C C... DIAGNOSTICS FOR FAILURE OF NONLINEAR ITERATION. C 430 IF (IPRINT.LT.1) WRITE (IWR,99991) ITER GO TO 450 440 IF (IPRINT.LT.1) WRITE (IWR,99990) RELAX, RELMIN 450 IFLAG = -2 LCONV = LCONV + 1 IF (ICARE.EQ.2 .AND. LCONV.GT.1) RETURN IF (ICARE.EQ.0) ICARE = -1 GO TO 470 C C... CHECK FOR ERROR TOLERANCE SATISFACTION C 460 CALL ERRCHK(IMESH, XIOLD, ALDIF, VALSTR, A, MSTAR, IFIN) IF (IMESH.EQ.1 .OR. IFIN.EQ.0 .AND. ICARE.NE.2) GO TO 470 IFLAG = 1 RETURN C C... PICK A NEW MESH C... CHECK SAFEGUARDS FOR MESH REFINEMENT C 470 IMESH = 1 IF (ICON.EQ.0 .OR. MSHNUM.GE.MSHLMT .OR. MSHALT.GE.MSHLMT) IMESH * = 2 IF (MSHALT.GE.MSHLMT .AND. MSHNUM.LT.MSHLMT) MSHALT = 1 CALL NEWMSH(IMESH, XI, XIOLD, XIJ, ALDIF, VALSTR, SLOPE, ACCUM, * NFXPNT, FIXPNT) C C... EXIT IF EXPECTED N IS TOO LARGE (BUT MAY TRY N=NMAX ONCE) C IF (N.LE.NMAX) GO TO 480 N = N/2 IFLAG = -1 IF (ICON.EQ.0 .AND. IPRINT.LT.1) WRITE (IWR,99989) IF (ICON.EQ.1 .AND. IPRINT.LT.1) WRITE (IWR,99988) RETURN 480 IF (ICON.EQ.0) IMESH = 1 IF (ICARE.EQ.1) ICON = 0 GO TO 20 C --------------------------------------------------------------- 99999 FORMAT (//24H THE MATRIX IS SINGULAR ) 99998 FORMAT (/30H FULL DAMPED NEWTON ITERATION,) 99997 FORMAT (13H ITERATION = , I3, 15H NORM (RHS) = , E10.2) 99996 FORMAT (13H ITERATION = , I3, 22H RELAXATION FACTOR = , * E10.2/33H NORM OF SCALED RHS CHANGES FROM , E10.2, 3H TO, * E10.2/33H NORM OF RHS CHANGES FROM , E10.2, 3H TO, E10.2) 99995 FORMAT (/27H FIXED JACOBIAN ITERATIONS,) 99994 FORMAT (/35H SWITCH TO DAMPED NEWTON ITERATION,) 99993 FORMAT (40H RELAXATION FACTOR CORRECTED TO RELAX = , * E10.2/33H NORM OF SCALED RHS CHANGES FROM , E10.2, 3H TO, * E10.2/33H NORM OF RHS CHANGES FROM , E10.2, 3H TO, E10.2) 99992 FORMAT (/18H CONVERGENCE AFTER, I3, 11H ITERATIONS/) 99991 FORMAT (/22H NO CONVERGENCE AFTER , I3, 11H ITERATIONS/) 99990 FORMAT (/37H NO CONVERGENCE, RELAXATION FACTOR =, E10.3, * 24H IS TOO SMALL (LESS THAN, E10.3, 1H)/) 99989 FORMAT (18H (NO CONVERGENCE)) 99988 FORMAT (50H (PROBABLY TOLERANCES TOO STRINGENT, OR NMAX TOO , * 6HSMALL)) END C-----------------------------------------------------------------------NEW 10 C P A R T 2 NEW 20 C MESH SELECTION, ERROR ESTIMATION, (AND RELATED NEW 30 C CONSTANT ASSIGNMENT) ROUTINES -- SEE (1), (2), (5) NEW 40 C-----------------------------------------------------------------------NEW 50 C NEW 60 SUBROUTINE NEWMSH(MODE, XI, XIOLD, XIJ, ALDIF, VALSTR, SLOPE, NEW 70 * ACCUM, NFXPNT, FIXPNT) C C*********************************************************************** C C PURPOSE C SELECT A MESH ON WHICH A COLLOCATION SOLUTION IS TO BE C DETERMINED C C THERE ARE 5 POSSIBLE MODES OF ACTION: C MODE = 5,4,3 - DEAL MAINLY WITH DEFINITION OF AN INITIAL C MESH FOR THE CURRENT BOUNDARY VALUE PROBLEM C = 2,1 - DEAL WITH DEFINITION OF A NEW MESH, EITHER C BY SIMPLE MESH HALVING OR BY MESH SELECTION C MORE SPECIFICALLY, FOR C MODE = 5 AN INITIAL (GENERALLY NONUNIFORM) MESH IS C DEFINED BY THE USER AND NO MESH SELECTION IS TO C BE PERFORMED C = 4 AN INITIAL (GENERALLY NONUNIFORM) MESH IS C DEFINED BY THE USER C = 3 A SIMPLE UNIFORM MESH (EXCEPT POSSIBLY FOR SOME C FIXED POINTS) IS DEFINED; N= NO. OF SUBINTERVALS C = 1 THE AUTOMATIC MESH SELECTION PROCEDURE IS USED C (SEE (1) AND (5) FOR DETAILS) C = 2 A SIMPLE MESH HALVING IS PERFORMED C C*********************************************************************** C C VARIABLES C C N = NUMBER OF MESH SUBINTERVALS C NOLD = NUMBER OF SUBINTERVALS FOR FORMER MESH C XI - MESH POINT ARRAY C XIOLD - FORMER MESH POINT ARRAY C MSHLMT - MAXIMUM NO. OF MESH SELECTIONS WHICH ARE PERMITTED C FOR A GIVEN N BEFORE MESH HALVING C MSHNUM - NO. OF MESH SELECTIONS WHICH HAVE ACTUALLY BEEN C PERFORMED FOR THE GIVEN N C MSHALT - NO. OF CONSECUTIVE TIMES ( PLUS 1 ) THE MESH C SELECTION HAS ALTERNATELY HALVED AND DOUBLED N. C IF MSHALT .GE. MSHLMT THEN CONTRL REQUIRES C THAT THE CURRENT MESH BE HALVED. C MSHFLG = 1 THE MESH IS A HALVING OF ITS FORMER MESH C (SO AN ERROR ESTIMATE HAS BEEN CALCULATED) C = 0 OTHERWISE C IGUESS - IPAR(9) IN SUBROUTINE COLSYS. IT IS USED C HERE ONLY FOR MODE=5 AND 4, WHERE C = 2 THE SUBROUTINE SETS XI=XIOLD. THIS IS C USED E.G. IF CONTINUATION IS BEING PER- C FORMED, AND A MESH FOR THE OLD DIFFEREN- C TIAL EQUATION IS BEING USED C = 3 SAME AS FOR =2, EXCEPT XI USES EVERY OTHER C POINT OF XIOLD (SO MESH XIOLD IS MESH XI C HALVED) C = 4 XI HAS BEEN DEFINED BY THE USER, AND AN OLD C MESH XIOLD IS ALSO AVAILABLE C OTHERWISE, XI HAS BEEN DEFINED BY THE USER C AND WE SET XIOLD=XI IN THIS SUBROUTINE C SLOPE - AN APPROXIMATE QUANTITY TO BE EQUIDISTRIBUTED FOR C MESH SELECTION (SEE (1)), VIZ, C . (K+MJ) C SLOPE(I)= MAX (WEIGHT(L) *U (XI(I))) C 1.LE.L.LE.NTOL J C C WHERE J=JTOL(L) C SLPHMX - MAXIMUM OF SLOPE(I)*(XIOLD(I+1)-XIOLD(I)) FOR C I = 1 ,..., NOLD. C ACCUM - ACCUM(I) IS THE INTEGRAL OF SLOPE FROM ALEFT C TO XIOLD(I). C VALSTR - IS ASSIGNED VALUES NEEDED IN ERRCHK FOR THE C ERROR ESTIMATE. C*********************************************************************** C COMMON /ORDER/ K, NCOMP, MSTAR, KD, KDM, MNSUM, M(20) COMMON /APPR/ N, NOLD, NMAX, NALPHA, MSHFLG, MSHNUM, MSHLMT, * MSHALT COMMON /ERRORS/ TOL(40), WGTMSH(40), TOLIN(40), ROOT(40), * JTOL(40), LTOL(40), NTOL COMMON /COLLOC/ RHO(7), WGTERR(40) COMMON /SIDE/ ZETA(40), ALEFT, ARIGHT, IZETA, IWR COMMON /NONLN/ PRECIS, NONLIN, ITER, LIMIT, ICARE, IPRINT, * IGUESS, IFREEZ COMMON /BSPLIN/ VNCOL(66,7), VNSAVE(66,5), VN(66) DIMENSION D1(40), D2(40), ZV(40), SLOPE(1), ACCUM(1), VALSTR(1) DIMENSION XI(1), XIOLD(1), XIJ(1), ALDIF(1), FIXPNT(1) C NOLDP1 = NOLD + 1 NFXP1 = NFXPNT + 1 GO TO (190, 100, 50, 20, 10), MODE C C... MODE=5 SET MSHLMT=1 SO THAT NO MESH SELECTION IS PERFORMED C 10 MSHLMT = 1 C C... MODE=4 THE USER-SPECIFIED INITIAL MESH IS ALREADY IN PLACE. C 20 IF (IGUESS.LT.2) GO TO 40 C C... IGUESS=2, 3 OR 4. C IF (IPRINT.LT.1) WRITE (IWR,99997) NOLD, (XIOLD(I),I=1,NOLDP1) IF (IGUESS.NE.3) GO TO 40 C C... IF IREAD ( IPAR(8) ) .GE. 1 AND IGUESS ( IPAR(9) ) C... .EQ. 3 THEN THE FIRST MESH IS EVERY SECOND POINT OF THE C... MESH IN XIOLD . C N = NOLD/2 I = 0 DO 30 J=1,NOLD,2 I = I + 1 XI(I) = XIOLD(J) 30 CONTINUE 40 CONTINUE NP1 = N + 1 XI(1) = ALEFT XI(NP1) = ARIGHT GO TO 330 C C... MODE=3 GENERATE A (PIECEWISE) UNIFORM MESH. IF THERE ARE C... FIXED POINTS THEN ENSURE THAT THE N BEING USED IS LARGE ENOUGH. C 50 IF (N.LT.NFXP1) N = NFXP1 NP1 = N + 1 XI(1) = ALEFT ILEFT = 1 XLEFT = ALEFT C C... LOOP OVER THE SUBREGIONS BETWEEN FIXED POINTS. C DO 90 J=1,NFXP1 XRIGHT = ARIGHT IRIGHT = NP1 IF (J.EQ.NFXP1) GO TO 60 XRIGHT = FIXPNT(J) C C... DETERMINE WHERE THE J-TH FIXED POINT SHOULD FALL IN THE C... NEW MESH - THIS IS XI(IRIGHT) AND THE (J-1)ST FIXED C... POINT IS IN XI(ILEFT) C NMIN = (XRIGHT-ALEFT)/(ARIGHT-ALEFT)*FLOAT(N) + 1.5 IF (NMIN.GT.N-NFXPNT+J) NMIN = N - NFXPNT + J IRIGHT = MAX0(ILEFT+1,NMIN) 60 XI(IRIGHT) = XRIGHT C C... GENERATE EQUALLY SPACED POINTS BETWEEN THE J-1ST AND THE C... J-TH FIXED POINTS. C NREGN = IRIGHT - ILEFT - 1 IF (NREGN.EQ.0) GO TO 80 DX = (XRIGHT-XLEFT)/FLOAT(NREGN+1) DO 70 I=1,NREGN XI(ILEFT+I) = XLEFT + FLOAT(I)*DX 70 CONTINUE 80 ILEFT = IRIGHT XLEFT = XRIGHT 90 CONTINUE GO TO 330 C C... MODE=2 HALVE THE CURRENT MESH (I.E. DOUBLE ITS SIZE) C 100 N2 = 2*N C C... CHECK THAT N DOES NOT EXCEED STORAGE LIMITATIONS C IF (N2.LE.NMAX) GO TO 120 C C... IF POSSIBLE, TRY WITH N=NMAX. REDISTRIBUTE FIRST. C IF (MODE.EQ.2) GO TO 110 N = NMAX/2 GO TO 230 110 IF (IPRINT.LT.1) WRITE (IWR,99996) N = N2 RETURN C C... CALCULATE THE OLD APPROXIMATE SOLUTION VALUES AT C... POINTS TO BE USED IN ERRCHK FOR ERROR ESTIMATES. C... IF MSHFLG =1 AN ERROR ESTIMATE WAS OBTAINED FOR C... FOR THE OLD APPROXIMATION SO HALF THE NEEDED VALUES C... WILL ALREADY BE IN VALSTR . C 120 IF (MSHFLG.EQ.0) GO TO 140 C C... SAVE IN VALSTR THE VALUES OF THE OLD SOLUTION C... AT THE RELATIVE POSITIONS 1/6 AND 5/6 IN EACH SUBINTERVAL. C KSTORE = 1 DO 130 I=1,NOLD HD6 = (XIOLD(I+1)-XIOLD(I))/6. X = XIOLD(I) + HD6 CALL APPROX(I, X, VALSTR(KSTORE), VNSAVE(1,2), XIOLD, NOLD, * ALDIF, K, NCOMP, M, MSTAR, 3, DUMM, 0) X = X + 4.*HD6 KSTORE = KSTORE + 3*MSTAR CALL APPROX(I, X, VALSTR(KSTORE), VNSAVE(1,5), XIOLD, NOLD, * ALDIF, K, NCOMP, M, MSTAR, 3, DUMM, 0) KSTORE = KSTORE + MSTAR 130 CONTINUE GO TO 170 C C... SAVE IN VALSTR THE VALUES OF THE OLD SOLUTION C... AT THE RELATIVE POSITIONS 1/6, 2/6, 4/6 AND 5/6 IN C... EACH SUBINTERVAL. C 140 KSTORE = 1 DO 160 I=1,N X = XI(I) HD6 = (XI(I+1)-XI(I))/6. DO 150 J=1,4 X = X + HD6 IF (J.EQ.3) X = X + HD6 CALL APPROX(I, X, VALSTR(KSTORE), VNSAVE(1,J+1), XIOLD, NOLD, * ALDIF, K, NCOMP, M, MSTAR, 3, DUMM, 0) KSTORE = KSTORE + MSTAR 150 CONTINUE 160 CONTINUE 170 MSHFLG = 0 MSHNUM = 1 MODE = 2 C C... GENERATE THE HALVED MESH. C J = 2 DO 180 I=1,N XI(J) = (XIOLD(I)+XIOLD(I+1))/2. XI(J+1) = XIOLD(I+1) J = J + 2 180 CONTINUE N = N2 GO TO 330 C C... MODE=1 WE DO MESH SELECTION IF IT IS DEEMED WORTHWHILE C 190 IF (NOLD.EQ.1) GO TO 100 IF (NOLD.LE.2*NFXPNT) GO TO 100 C C... THE FIRST INTERVAL HAS TO BE TREATED SEPARATELY FROM THE C... OTHER INTERVALS (GENERALLY THE SOLUTION ON THE (I-1)ST AND ITH C... INTERVALS WILL BE USED TO APPROXIMATE THE NEEDED DERIVATIVE, BUT C... HERE THE 1ST AND SECOND INTERVALS ARE USED.) C I = 1 CALL HORDER(1, D1, XIOLD, ALDIF) CALL HORDER(2, D2, XIOLD, ALDIF) CALL APPROX(I, XIOLD(I), ZV, VNSAVE(1,1), XIOLD, NOLD, ALDIF, K, * NCOMP, M, MSTAR, 3, DUMM, 0) ACCUM(1) = 0. SLOPE(1) = 0. ONEOVH = 2./(XIOLD(3)-XIOLD(1)) DO 200 J=1,NTOL JJ = JTOL(J) JV = LTOL(J) SLOPE(1) = AMAX1(SLOPE(1),(ABS(D2(JJ)-D1(JJ))*WGTMSH(J)*ONEOVH/ * (1.+ABS(ZV(JV))))**ROOT(J)) 200 CONTINUE SLPHMX = SLOPE(1)*(XIOLD(2)-XIOLD(1)) ACCUM(2) = SLPHMX IFLIP = 1 C C... GO THROUGH THE REMAINING INTERVALS GENERATING SLOPE C... AND ACCUM . C DO 220 I=2,NOLD IF (IFLIP.EQ.(-1)) CALL HORDER(I, D1, XIOLD, ALDIF) IF (IFLIP.EQ.1) CALL HORDER(I, D2, XIOLD, ALDIF) CALL APPROX(I, XIOLD(I), ZV, VNSAVE(1,1), XIOLD, NOLD, ALDIF, * K, NCOMP, M, MSTAR, 3, DUMM, 0) ONEOVH = 2./(XIOLD(I+1)-XIOLD(I-1)) SLOPE(I) = 0. C C... EVALUATE FUNCTION TO BE EQUIDISTRIBUTED C DO 210 J=1,NTOL JJ = JTOL(J) JV = LTOL(J) SLOPE(I) = AMAX1(SLOPE(I),(ABS(D2(JJ)-D1(JJ))*WGTMSH(J)* * ONEOVH/(1.+ABS(ZV(JV))))**ROOT(J)) 210 CONTINUE C C... ACCUMULATE APPROXIMATE INTEGRAL OF FUNCTION TO BE C... EQUIDISTRIBUTED C TEMP = SLOPE(I)*(XIOLD(I+1)-XIOLD(I)) SLPHMX = AMAX1(SLPHMX,TEMP) ACCUM(I+1) = ACCUM(I) + TEMP IFLIP = -IFLIP 220 CONTINUE AVRG = ACCUM(NOLD+1)/FLOAT(NOLD) DEGEQU = AVRG/AMAX1(SLPHMX,PRECIS) C C... NACCUM=EXPECTED N TO ACHIEVE .1X USER REQUESTED TOLERANCES C NACCUM = ACCUM(NOLD+1) + 1. IF (IPRINT.LT.0) WRITE (IWR,99998) DEGEQU, NACCUM C C... DECIDE IF MESH SELECTION IS WORTHWHILE (OTHERWISE, HALVE) C IF (AVRG.LT.PRECIS) GO TO 100 IF (DEGEQU.GE..5) GO TO 100 C C... NMX ASSURES MESH HAS AT LEAST HALF AS MANY SUBINTERVALS AS THE C... PREVIOUS MESH C NMX = MAX0(NOLD+1,NACCUM)/2 C C... THIS ASSURES THAT HALVING WILL BE POSSIBLE LATER (FOR ERROR EST) C NMAX2 = NMAX/2 C C... THE MESH IS AT MOST HALVED C N = MIN0(NMAX2,NOLD,NMX) 230 NFXP1 = NFXPNT + 1 IF (N.LT.NFXP1) N = NFXP1 MSHNUM = MSHNUM + 1 C C... IF THE NEW MESH IS SMALLER THAN THE OLD MESH SET MSHNUM C... SO THAT THE NEXT CALL TO NEWMSH WILL PRODUCE A HALVED C... MESH. IF N .EQ. NOLD / 2 INCREMENT MSHALT SO THERE CAN NOT C... BE AN INFINITE LOOP ALTERNATING BETWEEN N AND N/2 POINTS. C IF (N.LT.NOLD) MSHNUM = MSHLMT IF (N.GT.NOLD/2) MSHALT = 1 IF (N.EQ.NOLD/2) MSHALT = MSHALT + 1 MSHFLG = 0 C C... HAVING DECIDED TO GENERATE A NEW MESH WITH N SUBINTERVALS WE NOW C... DO SO, TAKING INTO ACCOUNT THAT THE NFXPNT POINTS IN THE ARRAY C... FIXPNT MUST BE INCLUDED IN THE NEW MESH. C IN = 1 ACCL = 0. LOLD = 2 XI(1) = ALEFT XI(N+1) = ARIGHT DO 320 I=1,NFXP1 IF (I.EQ.NFXP1) GO TO 260 DO 240 J=LOLD,NOLDP1 LNEW = J IF (FIXPNT(I).LE.XIOLD(J)) GO TO 250 240 CONTINUE 250 CONTINUE ACCR = ACCUM(LNEW) + (FIXPNT(I)-XIOLD(LNEW))*SLOPE(LNEW-1) NREGN = (ACCR-ACCL)/ACCUM(NOLDP1)*FLOAT(N) - .5 NREGN = MIN0(NREGN,N-IN-NFXP1+I) XI(IN+NREGN+1) = FIXPNT(I) GO TO 270 260 ACCR = ACCUM(NOLDP1) LNEW = NOLDP1 NREGN = N - IN 270 IF (NREGN.EQ.0) GO TO 310 TEMP = ACCL TSUM = (ACCR-ACCL)/FLOAT(NREGN+1) DO 300 J=1,NREGN IN = IN + 1 TEMP = TEMP + TSUM DO 280 L=LOLD,LNEW LCARRY = L IF (TEMP.LE.ACCUM(L)) GO TO 290 280 CONTINUE 290 CONTINUE LOLD = LCARRY XI(IN) = XIOLD(LOLD-1) + (TEMP-ACCUM(LOLD-1))/SLOPE(LOLD-1) 300 CONTINUE 310 IN = IN + 1 ACCL = ACCR LOLD = LNEW 320 CONTINUE MODE = 1 330 CONTINUE C C... REGARDLESS OF HOW THE NEW MESH IS CHOSEN, THE NEW COLLOCATION C... POINTS XIJ IN (ALEFT,ARIGHT) ARE GENERATED HERE C K2 = 1 DO 350 I=1,N H = (XI(I+1)-XI(I))/2. XM = (XI(I+1)+XI(I))/2. DO 340 J=1,K XIJ(K2) = RHO(J)*H + XM K2 = K2 + 1 340 CONTINUE 350 CONTINUE NP1 = N + 1 IF (IPRINT.LT.1) WRITE (IWR,99999) N, (XI(I),I=1,NP1) NALPHA = N*K*NCOMP + MSTAR RETURN C---------------------------------------------------------------- 99999 FORMAT (/17H THE NEW MESH (OF, I5, 16H SUBINTERVALS), , * 100(/8F12.6)) 99998 FORMAT (/21H MESH SELECTION INFO,/28H DEGREE OF EQUIDISTRIBUTION , * 2H= , F8.5, 28H PREDICTION FOR REQUIRED N =, I8) 99997 FORMAT (/20H THE FORMER MESH (OF, I5, 15H SUBINTERVALS),, * 100(/8F12.6)) 99996 FORMAT (/23H EXPECTED N TOO LARGE ) END C CON 10 C.......................................................................CON 20 C CON 30 SUBROUTINE CONSTS CON 40 C C*********************************************************************** C C PURPOSE C ASSIGN (ONCE) VALUES TO VARIOUS ARRAY CONSTANTS. C C ARRAYS ASSIGNED DURING COMPILATION: C CNSTS1 - WEIGHTS FOR EXTRAPOLATION ERROR ESTIMATE C CNSTS2 - WEIGHTS FOR MESH SELECTION C (THE ABOVE WEIGHTS COME FROM THE THEORETICAL FORM FOR C THE COLLOCATION ERROR -- SEE (5)) C C ARRAYS ASSIGNED DURING EXECUTION: C WGTERR - THE PARTICULAR VALUES OF CNSTS1 USED FOR CURRENT RUN C (DEPENDING ON K, M) C WGTMSH - GOTTEN FROM THE VALUES OF CNSTS2 WHICH IN TURN ARE C THE CONSTANTS IN THE THEORETICAL EXPRESSION FOR THE C ERRORS. THE QUANTITIES IN WGTMSH ARE 10X THE VALUES C IN CNSTS2 SO THAT THE MESH SELECTION ALGORITHM C IS AIMING FOR ERRORS .1X AS LARGE AS THE USER C REQUESTED TOLERANCES. C JTOL - COMPONENTS OF DIFFERENTIAL SYSTEM TO WHICH TOLERANCES C REFER (VIZ, IF LTOL(I) REFERS TO A DERIVATIVE OF U(J), C THEN JTOL(I)=J) C ROOT - RECIPROCALS OF EXPECTED RATES OF CONVERGENCE OF COMPO- C NENTS OF Z(J) FOR WHICH TOLERANCES ARE SPECIFIED C RHO - THE K COLLOCATION POINTS ON (-1,1) C VNCOL - THE MESH INDEPENDENT B-SPLINES VALUES AT COLLOCATION C POINTS C C*********************************************************************** C COMMON /COLLOC/ RHO(7), WGTERR(40) COMMON /ORDER/ K, NCOMP, MSTAR, KD, KDM, MNSUM, M(20) COMMON /BSPLIN/ VNCOL(66,7), VNSAVE(66,5), VN(66) COMMON /ERRORS/ TOL(40), WGTMSH(40), TOLIN(40), ROOT(40), * JTOL(40), LTOL(40), NTOL COMMON /NONLN/ PRECIS, NONLIN, ITER, LIMIT, ICARE, IPRINT, * IGUESS, IFREEZ DIMENSION CNSTS1(28), CNSTS2(28) DATA CNSTS1 /.25,.625E-1,.72169E-1,1.8342E-2,1.9065E-2,5.8190E-2, * 5.4658E-3,5.3370E-3,1.8890E-2,2.7792E-2,1.6095E-3,1.4964E-3, * 7.5938E-3,5.7573E-3,1.8342E-2,4.673E-3,4.150E-4,1.919E-3, * 1.468E-3,6.371E-3,4.610E-3,1.342E-4,1.138E-4,4.889E-4,4.177E-4, * 1.374E-3,1.654E-3,2.863E-3/ DATA CNSTS2 /1.25E-1,2.604E-3,8.019E-3,2.170E-5,7.453E-5,5.208E-4, * 9.689E-8,3.689E-7,3.100E-6,2.451E-5,2.691E-10,1.120E-9,1.076E-8, * 9.405E-8,1.033E-6,5.097E-13,2.290E-12,2.446E-11,2.331E-10, * 2.936E-9,3.593E-8,7.001E-16,3.363E-15,3.921E-14,4.028E-13, * 5.646E-12,7.531E-11,1.129E-9/ C C... ASSIGN WEIGHTS FOR ERROR ESTIMATE C KOFF = K*(K+1)/2 IEXTRA = 1 DO 20 J=1,NCOMP LIM = M(J) DO 10 L=1,LIM WGTERR(IEXTRA) = CNSTS1(KOFF-LIM+L) IEXTRA = IEXTRA + 1 10 CONTINUE 20 CONTINUE C C... ASSIGN ARRAY VALUES FOR MESH SELECTION: WGTMSH, JTOL, AND ROOT C JCOMP = 1 MTOT = M(1) DO 50 I=1,NTOL LTOLI = LTOL(I) 30 CONTINUE IF (LTOLI.LE.MTOT) GO TO 40 JCOMP = JCOMP + 1 MTOT = MTOT + M(JCOMP) GO TO 30 40 CONTINUE JTOL(I) = JCOMP WGTMSH(I) = 1.E1*CNSTS2(KOFF+LTOLI-MTOT)/TOLIN(I) ROOT(I) = 1./FLOAT(K+MTOT-LTOLI+1) 50 CONTINUE C C... SPECIFY COLLOCATION POINTS C GO TO (60, 70, 80, 90, 100, 110, 120), K 60 RHO(1) = 0. GO TO 130 70 RHO(2) = .57735026918962576451 RHO(1) = -RHO(2) GO TO 130 80 RHO(3) = .77459666924148337704 RHO(2) = .0 RHO(1) = -RHO(3) GO TO 130 90 RHO(1) = -.86113631159405257523 RHO(2) = -.33998104358485626480 RHO(3) = -RHO(2) RHO(4) = -RHO(1) GO TO 130 100 RHO(5) = .90617984593866399280 RHO(4) = .53846931010568309104 RHO(3) = .0 RHO(2) = -RHO(4) RHO(1) = -RHO(5) GO TO 130 110 RHO(6) = .93246951420315202781 RHO(5) = .66120938646626451366 RHO(4) = .23861918608319690863 RHO(3) = -RHO(4) RHO(2) = -RHO(5) RHO(1) = -RHO(6) GO TO 130 120 RHO(7) = .949107991234275852452 RHO(6) = .74153118559939443986 RHO(5) = .40584515137739716690 RHO(4) = 0. RHO(3) = -RHO(5) RHO(2) = -RHO(6) RHO(1) = -RHO(7) 130 CONTINUE C C... PUT MESH INDEPENDENT B-SPLINES VALUES AT COLLOCATION POINT C... RHO(J) INTO VNCOL(*,J), J=1,...,K. C DO 140 J=1,K ARG = .5*(1.-RHO(J)) CALL BSPFIX(ARG, VNCOL(1,J), K, NCOMP, M) 140 CONTINUE C C... PUT MESH INDEPENDENT B-SPLINES VALUES AT THE POINTS IN UNIT IN- C... TERVAL 0, 1/6, 1/3, 2/3, 5/6 INTO VNSAVE. THESE VALUES ARE TO C... BE USED IN NEWMSH AND ERRCHK . C CALL BSPFIX(1., VNSAVE(1,1), K, NCOMP, M) CALL BSPFIX(5./6., VNSAVE(1,2), K, NCOMP, M) CALL BSPFIX(2./3., VNSAVE(1,3), K, NCOMP, M) CALL BSPFIX(1./3., VNSAVE(1,4), K, NCOMP, M) CALL BSPFIX(1./6., VNSAVE(1,5), K, NCOMP, M) RETURN END C ERR 10 C.......................................................................ERR 20 C ERR 30 SUBROUTINE ERRCHK(IMESH, XIOLD, ALDIF, VALSTR, WORK, MSTAR, IFIN) ERR 40 C C*********************************************************************** C C PURPOSE C DETERMINE THE ERROR ESTIMATES AND TEST TO SEE IF THE C ERROR TOLERANCES ARE SATISFIED. C C VARIABLES C XIOLD - CURRENT MESH POINTS C VALSTR - VALUES OF THE PREVIOUS SOLUTION WHICH ARE NEEDED C FOR THE EXTRAPOLATION- LIKE ERROR ESTIMATE. C WGTERR - WEIGHTS USED IN THE EXTRAPOLATION-LIKE ERROR C ESTIMATE. THE ARRAY VALUES ARE ASSIGNED IN C SUBROUTINE CONSTS. C ERREST - STORAGE FOR ERROR ESTIMATES C ERR - TEMPORARY STORAGE USED FOR ERROR ESTIMATES C WORK - SPACE TO BE USED TO STORE VALUES OF Z AT THE C MESH POINTS FOR PRINTOUT. ITS DIMENSION IS C MSTAR * NMAX. C Z - APPROXIMATE SOLUTION ON MESH XI C IFIN - A 0-1 VARIABLE. IF IMESH = 2 THEN ON RETURN IT C INDICATES WHETHER THE ERROR TOLERANCES WERE SATISFIED. C IMESH = 1 THE CURRENT MESH RESULTED FROM MESH SELECTION C OR IS THE INITIAL MESH. C = 2 THE CURRENT MESH RESULTED FROM DOUBLING THE C PREVIOUS MESH C MSHFLG - IS SET BY ERRCHK TO INDICATE TO NEWMSH WHETHER C ANY VALUES OF THE CURRENT SOLUTION ARE STORED IN C THE ARRAY VALSTR. (0 FOR NO, 1 FOR YES) C C********************************************************************** C DIMENSION ERR(40), Z(40), ERREST(40), DMVAL(20) COMMON /ORDER/ K, NCOMP, MSTR, KD, KDM, MNSUM, M(20) COMMON /APPR/ N, NOLD, NMAX, NALPHA, MSHFLG, MSHNUM, MSHLMT, * MSHALT COMMON /SIDE/ ZETA(40), ALEFT, ARIGHT, IZETA, IWR COMMON /ERRORS/ TOL(40), WGTMSH(40), TOLIN(40), ROOT(40), * JTOL(40), LTOL(40), NTOL COMMON /COLLOC/ RHO(7), WGTERR(40) COMMON /NONLN/ PRECIS, NONLIN, ITER, LIMIT, ICARE, IPRINT, * IGUESS, IFREEZ COMMON /BSPLIN/ VNCOL(66,7), VNSAVE(66,5), VN(66) DIMENSION XIOLD(1), ALDIF(1), VALSTR(1), WORK(MSTAR,1) C IFIN = 1 NOLDP1 = NOLD + 1 C C... IF FULL OUTPUT HAS BEEN REQUESTED, PRINT VALUES OF THE C... SOLUTION COMPONENTS Z AT THE MESHPOINTS. C IF (IPRINT.GE.0) GO TO 30 DO 10 I=1,NOLD CALL APPROX(I, XIOLD(I), WORK(1,I), VNSAVE(1,1), XIOLD, NOLD, * ALDIF, K, NCOMP, M, MSTAR, 3, DUMM, 0) 10 CONTINUE CALL APPROX(NOLD, XIOLD(NOLDP1), WORK(1,NOLDP1), VN, XIOLD, NOLD, * ALDIF, K, NCOMP, M, MSTAR, 2, DUMM, 0) DO 20 I=1,MSTAR WRITE (IWR,99997) I WRITE (IWR,99996) (WORK(I,J),J=1,NOLDP1) 20 CONTINUE 30 CONTINUE IF (IMESH.EQ.1) RETURN C C... IMESH = 2 SO ERROR ESTIMATES ARE TO BE GENERATED AND TESTED C... TO SEE IF THE TOLERANCE REQUIREMENTS ARE SATISFIED. C DO 40 J=1,MSTAR ERREST(J) = 0. 40 CONTINUE DO 110 IBACK=1,NOLD I = NOLD + 1 - IBACK C C... THE ERROR ESTIMATES ARE OBTAINED BY COMBINING VALUES OF C... THE NUMERICAL SOLUTIONS FOR TWO MESHES. C... FOR EACH VALUE OF IBACK WE WILL CONSIDER THE TWO C... APPROXIMATIONS AT 2 POINTS IN EACH OF C... THE NEW SUBINTERVALS. WE WORK BACKWARDS THROUGH C... THE SUBINTERVAL SO THAT NEW VALUES CAN BE STORED C... IN VALSTR IN CASE THEY PROVE TO BE NEEDED LATER C... FOR AN ERROR ESTIMATE. THE ROUTINE NEWMSH C... FILLED IN THE NEEDED VALUES OF THE OLD SOLUTION C... IN VALSTR. C MSHFLG = 1 DO 50 J=1,MSTAR Z(J) = 0. ERR(J) = 0. 50 CONTINUE DO 70 J=1,2 JJ = 5 - J KNEW = (4*(I-1)+3-J)*MSTAR + 1 KSTORE = (2*(I-1)+2-J)*MSTAR + 1 X = XIOLD(I) + FLOAT(3-J)/3.*(XIOLD(I+1)-XIOLD(I)) CALL APPROX(I, X, VALSTR(KNEW), VNSAVE(1,JJ), XIOLD, NOLD, * ALDIF, K, NCOMP, M, MSTAR, 3, DUMM, 0) DO 60 L=1,MSTAR ERR(L) = ERR(L) + WGTERR(L)*ABS(VALSTR(KNEW)-VALSTR(KSTORE)) Z(L) = Z(L) + .5*ABS(VALSTR(KNEW)) KNEW = KNEW + 1 KSTORE = KSTORE + 1 60 CONTINUE 70 CONTINUE C C... TEST WHETHER THE TOLERANCE REQUIREMENTS ARE SATISFIED C... IN THE I-TH INTERVAL. C IF (IFIN.EQ.0) GO TO 90 DO 80 J=1,NTOL LTOLJ = LTOL(J) IF (ERR(LTOLJ).GT.TOLIN(J)*(Z(LTOLJ)+1.)) IFIN = 0 80 CONTINUE 90 DO 100 L=1,MSTAR ERREST(L) = AMAX1(ERREST(L),ERR(L)) 100 CONTINUE 110 CONTINUE IF (IPRINT.LT.1) WRITE (IWR,99998) LJ = 1 DO 120 J=1,NCOMP MJ = LJ - 1 + M(J) IF (IPRINT.LT.1) WRITE (IWR,99999) J, (ERREST(L),L=LJ,MJ) LJ = MJ + 1 120 CONTINUE RETURN C-------------------------------------------------------------- 99999 FORMAT (3H U(, I2, 3H) -, 4E12.4) 99998 FORMAT (/26H THE ESTIMATED ERRORS ARE,) 99997 FORMAT (19H MESH VALUES FOR Z(, I2, 2H),) 99996 FORMAT (1H , 8E15.7) END C LSY 10 C-----------------------------------------------------------------------LSY 20 C P A R T 3 LSY 30 C COLLOCATION SYSTEM SETUP ROUTINES -- SEE (1) LSY 40 C-----------------------------------------------------------------------LSY 50 C LSY 60 SUBROUTINE LSYSLV(IFLAG, XI, XIOLD, XIJ, ALPHA, ALDIF, RHS, LSY 70 * ALPHO, A, IPIV, INTEGS, RNORM, MODE, FSUB, DFSUB, GSUB, DGSUB, * SOLUTN) C********************************************************************* C C PURPOSE C THIS ROUTINE CONTROLS THE SET UP AND SOLUTION OF A LINEAR C SYSTEM OF COLLOCATION EQUATIONS. C THE MATRIX A IS CAST INTO AN ALMOST BLOCK DIAGONAL C FORM BY AN APPROPRIATE ORDERING OF THE COLUMNS AND SOLVED C USING THE PACKAGE OF DE BOOR-WEISS (4). THE MATRIX IS COMPOSED C OF N BLOCKS. THE I-TH BLOCK HAS THE SIZE C INTEGS(1,I) * INTEGS(2,I). C IT CONTAINS IN ITS LAST ROWS THE LINEARIZED COLLOCATION EQUA- C TIONS (BOTH BUNDARY CONDITIONS AND DIFFERENTIAL EQUATIONS ) C CORRESPONDING TO THE I-TH SUBINTERVAL. INTEGS(3,I) STEPS OF C GAUSSIAN ELIMINATION ARE APPLIED TO IT TO ACHIEVE A PLU C DECOMPOSITION. THE RIGHT HAND SIDE VECTOR IS PUT INTO RHS C AND THE SOLUTION VECTOR IS RETURNED IN ALPHA. C C LSYSLV OPERATES ACCORDING TO ONE OF 5 MODES: C MODE = 0 - SET UP BOTH A AND RHS , AND SOLVE SYSTEM C (FOR LINEAR PROBLEMS). C MODE = 1 - SET UP RHS ONLY AND COMPUTE ITS NORM. C MODE = 2 - SET UP A ONLY AND SOLVE SYSTEM. C MODE = 3 - PERFORM FORWARD AND BACKWARD SUBSTITUTION (DO NOT SET C UP A NOR FORM THE RHS). C C FOR THE FIRST ITERATION ON A PARTICULAR MESH, C INTEGS IS COMPUTED. ALSO, THE INITIAL ALPHA ON C THE NEW MESH IS COMPUTED. C C VARIABLES C C IRHS,IA,IZETA,IALPHO - POINTERS TO RHS,A,ZETA,ALPHO RESPECTIVELY C (NECESSARY TO KEEP TRACK OF BLOCKS OF A C DURING MATRIX MANIPULATIONS) C ALPHO - B-SPLINE COEFFS FOR PREVIOUS SOLUTION C DG - PARTIAL DERIVATIVES OF G FROM DGSUB C DF - PARTIAL DERIVATIVES OF F FROM DFSUB C RNORM - EUCLIDEAN NORM OF RHS C LSIDE - NUMBER OF SIDE CONDITIONS IN CURRENT AND PREVIOUS BLOCKS C ICOLC - POINTER TO CURRENT COLLOCATION POINT ARRAY XIJ C ID - (ANOTHER) POINTER FOR RHS C IGUESS = 1 WHEN CURRENT SOLN IS USER SPECIFIED C = 0 OTHERWISE C C********************************************************************* COMMON /ORDER/ K, NCOMP, MSTAR, KD, KDM, MNSUM, M(20) COMMON /SIDE/ ZETA(40), ALEFT, ARIGHT, IZETA, IWR COMMON /BSPLIN/ VNCOL(66,7), VNSAVE(66,5), VN(66) COMMON /APPR/ N, NOLD, NMAX, NALPHA, MSHFLG, MSHNUM, MSHLMT, * MSHALT COMMON /NONLN/ PRECIS, NONLIN, ITER, LIMIT, ICARE, IPRINT, * IGUESS, IFREEZ COMMON /HI/ DN1, DN2, DN3 EXTERNAL FSUB, DFSUB, GSUB, DGSUB, SOLUTN DIMENSION ALPHO(1), XI(1), XIOLD(1), XIJ(1), ALPHA(1) DIMENSION ALDIF(1), RHS(1), A(1), IPIV(1), INTEGS(3,1) DIMENSION Z(40), F(40), DF(800), DMVAL(20) C M1 = MODE + 1 GO TO (10, 30, 30, 300), M1 C C... LINEAR PROBLEM INITIALIZATION C 10 DO 20 I=1,MSTAR Z(I) = 0. 20 CONTINUE C C... INITIALIZATION C 30 IRHS = 0 IA = 1 IZETA = 1 LSIDE = 0 RNORM = 0. IALPHO = 0 IF (ITER.GE.1 .OR. MODE.EQ.2) GO TO 80 C C... BUILD INTEGS (DESCRIBING BLOCK STRUCTURE OF MATRIX) C DO 70 I=1,N INTEGS(2,I) = KDM IF (I.LT.N) GO TO 40 INTEGS(3,I) = KDM LSIDE = MSTAR GO TO 60 40 INTEGS(3,I) = KD 50 IF (LSIDE.EQ.MSTAR) GO TO 60 IF (ZETA(LSIDE+1).GE.XI(I+1)) GO TO 60 LSIDE = LSIDE + 1 GO TO 50 60 NROW = KD + LSIDE INTEGS(1,I) = NROW 70 CONTINUE C C... THE DO LOOP 290 SETS UP THE LINEAR SYSTEM OF EQUATIONS. C 80 DO 280 I=1,N XIL = XI(1) IF (I.GT.1) XIL = XI(I-1) XIR = XI(N+1) IF (I.LT.N) XIR = XI(I+2) DN1 = 1./(XI(I+1)-XIL) DN2 = 1./(XI(I+1)-XI(I)) DN3 = 1./(XIR-XI(I)) C C... CONSTRUCT A BLOCK OF A AND A CORRESPONDING PIECE OF RHS. C NROW = INTEGS(1,I) II = I ICOLC = (I-1)*K ID = IRHS + IZETA - 1 C C... GO THRU THE NCOMP COLLOCATION EQUATIONS AND SIDE CONDITIONS C... IN THE I-TH SUBINTERVAL C DO 260 LL=1,K XX = XIJ(ICOLC+LL) 90 IF (IZETA.GT.MSTAR) GO TO 150 IF (ZETA(IZETA).GE.XX) GO TO 150 C C... BUILD EQUATION FOR A SIDE CONDITION. C 100 ID = ID + 1 IALPHO = IALPHO + 1 IF (MODE.EQ.0) GO TO 120 IF (IGUESS.NE.1) GO TO 110 C C... CASE WHERE USER PROVIDED CURRENT APPROXIMATION C CALL SOLUTN(ZETA(IZETA), Z, DMVAL) GO TO (120, 130), MODE C C... OTHER NONLINEAR CASE C 110 CALL APPROX(II, ZETA(IZETA), Z, VN, XIOLD, NOLD, ALDIF, K, * NCOMP, M, MSTAR, 1, DUMMY, 0) IF (MODE.EQ.2) GO TO 130 C C... FIND RHS BOUNDARY VALUE. C 120 CALL GSUB(IZETA, Z, G) RHS(ID) = -G RNORM = RNORM + G**2 IF (MODE.EQ.1) GO TO 140 C C... BUILD A ROW OF A CORRESPONDING TO A BOUNDARY POINT C 130 CALL BLDBLK(I, ZETA(IZETA), LL, A(IA), NROW, ID-IRHS, Z, DF, * NCOMP, XI, ALPHO, IALPHO, 1, DFSUB, DGSUB) 140 IZETA = IZETA + 1 C C... CHECK FOR OTHER SIDE CONDITIONS. C IF (IZETA.GT.MSTAR .AND. ZETA(MSTAR).GE.AMIN1(XX,ARIGHT)) GO * TO 270 IF (XX.GT.XI(N+1)) GO TO 250 GO TO 90 C C... THIS VALUE CORRESPONDS TO A COLLOCATION (INTERIOR) C... POINT. BUILD THE CORRESPONDING NCOMP EQUATIONS. C 150 IF (IGUESS.NE.1) GO TO (200, 160, 220), M1 C C... USE INITIAL APPROXIMATION PROVIDED BY THE USER. C CALL SOLUTN(XX, Z, DMVAL) GO TO (180, 240), MODE C C... FIND RHS VALUES C 160 IF (ITER.GE.1) GO TO 170 CALL APPROX(II, XX, Z, VN, XIOLD, NOLD, ALDIF, K, NCOMP, M, * MSTAR, 1, DMVAL, 1) GO TO 180 170 CALL APPROX(I, XX, Z, VNCOL(1,LL), XIOLD, NOLD, ALDIF, K, * NCOMP, M, MSTAR, 3, DMVAL, 1) 180 CALL FSUB(XX, Z, F) C C... FILL IN RHS VALUES (AND ACCUMULATE ITS NORM). C DO 190 J=1,NCOMP ID = ID + 1 VALUE = DMVAL(J) - F(J) RHS(ID) = -VALUE RNORM = RNORM + VALUE**2 IF (ITER.GE.1) GO TO 190 IALPHO = IALPHO + 1 ALPHO(IALPHO) = DMVAL(J) 190 CONTINUE GO TO 250 C C... THE LINEAR CASE C 200 CALL FSUB(XX, Z, F) DO 210 J=1,NCOMP ID = ID + 1 RHS(ID) = F(J) 210 CONTINUE ID = ID - NCOMP GO TO 240 C C... EVALUATE FORMER COLLOCATION SOLN FOR MODE=2 C 220 IF (ITER.GE.1) GO TO 230 CALL APPROX(II, XX, Z, VN, XIOLD, NOLD, ALDIF, K, NCOMP, M, * MSTAR, 1, DUMMY, 0) GO TO 240 230 CALL APPROX(I, XX, Z, VNCOL(1,LL), XIOLD, NOLD, ALDIF, K, * NCOMP, M, MSTAR, 3, DUMMY, 0) C C... FILL IN NCOMP ROWS OF A C 240 CALL BLDBLK(I, XX, LL, A(IA), NROW, ID-IRHS+1, Z, DF, NCOMP, * XI, ALPHO, IALPHO, 2, DFSUB, DGSUB) ID = ID + NCOMP C C... PREPARE TO SET UP SIDE CONDITIONS FOR LAST SUBINTERVAL C 250 IF (LL.LT.K) GO TO 260 IF (I.LT.N .OR. IZETA.GT.MSTAR) GO TO 270 XX = XI(N+1) + 1. GO TO 100 260 CONTINUE C C... UPDATE COUNTERS -- I-TH BLOCK COMPLETED C 270 IRHS = IRHS + NROW IA = IA + NROW*KDM 280 CONTINUE IF (MODE.NE.1) GO TO 290 RNORM = SQRT(RNORM/FLOAT(NALPHA)) RETURN C C... SOLVE THE LINEAR SYSTEM. C C... MATRIX DECOMPOSITION C 290 CALL FCBLOK(A, INTEGS, N, IPIV, ALPHA, IFLAG) C C... CHECK FOR SINGULAR MATRIX C IF (IFLAG.EQ.0) RETURN C C... PERFORM FORWARD AND BACKWARD SUBSTITUTION FOR MODE=0,2, OR 3. C 300 CALL SBBLOK(A, INTEGS, N, IPIV, RHS, ALPHA) C C... FIND THE COEFFICIENTS ALPHA OF THE INITIAL APPROX IF NECESSARY. C IF (ITER.GE.1 .OR. MODE.NE.2) RETURN IALPHO = 0 IRHS = 0 ISTO = 0 DO 320 I=1,N NROW = INTEGS(1,I) IRHS = IRHS + ISTO ISTART = ISTO + 1 ISTO = NROW - KD DO 310 J=ISTART,NROW IRHS = IRHS + 1 IALPHO = IALPHO + 1 RHS(IRHS) = RHS(IRHS) + ALPHO(IALPHO) 310 CONTINUE 320 CONTINUE CALL SBBLOK(A, INTEGS, N, IPIV, RHS, ALPHO) DO 330 I=1,NALPHA ALPHO(I) = ALPHO(I) - ALPHA(I) 330 CONTINUE RETURN END C................................................................... BLD 10 SUBROUTINE BLDBLK(I, X, LL, Q, NROW, NC, Z, DF, NCOMP, XI, ALPHO, BLD 20 * IALPHO, MODE, DFSUB, DGSUB) C C********************************************************************** C C PURPOSE: C C CONSTRUCT COLLOCATION MATRIX ROWS ACCORDING TO MODE: C MODE = 1 - A ROW CORRESPONDING TO A SIDE CONDITION. C MODE = 2 - A GROUP OF NCOMP ROWS CORRESPONDING C AN INTERIOR COLLOCATION POINT. C C VARIABLES: C C ALPHO - USED ONLY ON THE FIRST ITERATION FOR NONLINEAR C PROBLEMS WHEN THE FIRST APPROXIMATION IS OTHER C THAN A B-SPLINE REPRESENTATION ON THE CURRENT MESH. C A RIGHT HAND SIDE IS BEING BUILT UP IN ALPHO WHICH, C WHEN THE INVERTED COLLOCATION MATRIX IS APPLIED TO IT, C WILL PRODUCE A FIRST APPROXIMATION ON THE CURRENT MESH C IN TERMS OF B- SPLINES SO THE STEP-LENGTH ALGORITHM C IN CONTRL CAN OPERATE. C X - THE COLLOCATION OR SIDE CONDITION POINT. C I - THE SUBINTERVAL CONTAINING X C LL - IF X IS A COLLOCATION POINT THEN IT IS THE LL-TH C OF K COLLOCATION POINTS ON THE I-TH SUBINTERVAL. C Q - THE SUB-BLOCK OF THE COLLOCATION MATRIX IN C WHICH THE EQUATIONS ARE TO BE FORMED. C NROW - NO. OF ROWS IN Q. C NC - THE FIRST ROW IN Q TO BE USED FOR EQUATIONS. C Z - Z(X) C DG - THE DERIVATIVES OF THE SIDE CONDITION. C DF - THE JACOBIAN AT X. C ID - THE ROW OF Q BEING CONSTRUCTED. C BASEF - VALUES AND DERIVATIVES OF THE B-SPLINE BASIS C FOR EACH OF THE COMPONENTS. C JCOMP - COUNTER FOR THE COMPONENT BEING DEALT WITH. C L - COUNTER FOR THE B-SPLINES REPRESENTING U(JCOMP). C J - COUNTER FOR THE LOWEST M(JCOMP) DERIVATIVES OF C BSPLINES REPRESENTING U . C JCOMP C C********************************************************************** COMMON /COLLOC/ RHO(7), WGTERR(40) COMMON /APPR/ N, NOLD, NMAX, NALPHA, MSHFLG, MSHNUM, MSHLMT, * MSHALT COMMON /ORDER/ K, ND, MSTAR, KD, KDM, MNSUM, M(20) COMMON /SIDE/ ZETA(40), ALEFT, ARIGHT, IZETA, IWR COMMON /NONLN/ PRECIS, NONLIN, ITER, LIMIT, ICARE, IPRINT, * IGUESS, IFREEZ COMMON /HI/ DN1, DN2, DN3 COMMON /BSPLIN/ VNCOL(66,7), VNSAVE(66,5), VN(66) EXTERNAL DFSUB, DGSUB DIMENSION Q(NROW,1), Z(1), DF(NCOMP,1) DIMENSION XI(1), BASEF(620), ALPHO(1), DG(40) C NK = NC IF (MODE.EQ.2) NK = NC + NCOMP - 1 DO 20 J=NC,NK DO 10 L=1,KDM Q(J,L) = 0. 10 CONTINUE 20 CONTINUE C C... BRANCH ACCORDING TO M O D E C GO TO (30, 140), MODE C C... X IS A BOUNDARY POINT C 30 CALL BSPDER(VN, XI, N, X, I, BASEF, 2) C C... PROVIDE COEFFICIENTS OF THE J-TH LINEARIZED SIDE CONDITION. C... SPECIFICALLY, AT X=ZETA(J) THE J-TH SIDE CONDITION READS C... DG(1)*Z(1) + ... +DG(MSTAR)*Z(MSTAR) + G = 0 C CALL DGSUB(IZETA, Z, DG) IF (ITER.GE.1 .OR. NONLIN.EQ.0) GO TO 50 VALUE = 0. DO 40 J=1,MSTAR VALUE = VALUE + DG(J)*Z(J) 40 CONTINUE ALPHO(IALPHO) = VALUE 50 IQ = 0 IQM = MSTAR IDG = 0 IBASEF = 0 ID = NC C DO 130 JCOMP=1,NCOMP MJ = M(JCOMP) MJ1 = MJ + 1 KMJ = K - MJ C C... INCORPORATE THE VALUES AND DERIVATIVES FOR C... THE B-SPLINES WHICH ARE NONZERO ON THE PRECEEDING C... SUBINTERVAL. C DO 70 L=1,MJ DO 60 J=1,MJ Q(ID,IQ+L) = Q(ID,IQ+L) + DG(IDG+J)*BASEF(IBASEF+J) 60 CONTINUE IBASEF = IBASEF + MJ1 70 CONTINUE C C... THE B-SPLINES WHICH ARE NONZERO ON THE CURRENT C... SUBINTERVAL ONLY. C IF (KMJ.LE.0) GO TO 100 DO 90 L=1,KMJ DO 80 J=1,MJ Q(ID,IQM+L) = Q(ID,IQM+L) + DG(IDG+J)*BASEF(IBASEF+J) 80 CONTINUE IBASEF = IBASEF + MJ1 90 CONTINUE C C... THE B-SPLINES WHICH ARE NONZERO ON THE SUCCEEDING C... SUBINTERVAL AS WELL. C 100 DO 120 L=1,MJ DO 110 J=1,MJ Q(ID,IQ+KD+L) = Q(ID,IQ+KD+L) + DG(IDG+J)*BASEF(IBASEF+J) 110 CONTINUE IBASEF = IBASEF + MJ1 120 CONTINUE C IDG = IDG + MJ IQ = IQ + MJ IQM = IQM + KMJ 130 CONTINUE RETURN C C... BUILD NCOMP ROWS FOR INTERIOR COLLOCATION POINT X. C... THE LINEAR EXPRESSIONS TO BE CONSTRUCTED ARE: C... (M(JJ)) C... U - DF(JJ,1)*Z(1) - ... - DF(JJ,MSTAR)*Z(MSTAR) C... JJ C... FOR JJ = 1 TO NCOMP. C 140 CALL BSPDER(VNCOL(1,LL), XI, N, X, I, BASEF, 3) CALL DFSUB(X, Z, DF) C C... LOOP OVER THE NCOMP EXPRESSIONS TO BE SET UP FOR THE C... CURRENT COLLOCATION POINT. C DO 250 JJ=1,NCOMP IF (ITER.GE.1 .OR. NONLIN.EQ.0) GO TO 160 IALPHO = IALPHO + 1 VALUE = 0. DO 150 J=1,MSTAR VALUE = VALUE + DF(JJ,J)*Z(J) 150 CONTINUE ALPHO(IALPHO) = ALPHO(IALPHO) - VALUE 160 ID = JJ + NC - 1 IQ = 0 IQM = MSTAR IDF = 0 IBASEF = 0 C C... NOTE THAT IF JJ .EQ. JCOMP AN ENTRY HAS TO BE MADE FOR THE C... M(JCOMP)-TH DERIVATIVE OF THE JCOMP-TH COMPONENT. C DO 240 JCOMP=1,NCOMP MJ = M(JCOMP) MJ1 = MJ + 1 KMJ = K - MJ C C... USE THE B-SPLINES WHICH ARE NONZERO ON THE PRECEEDING C... SUBINTERVAL. C DO 180 L=1,MJ IF (JCOMP.EQ.JJ) Q(ID,IQ+L) = BASEF(IBASEF+MJ1) DO 170 J=1,MJ Q(ID,IQ+L) = Q(ID,IQ+L) - DF(JJ,IDF+J)*BASEF(IBASEF+J) 170 CONTINUE IBASEF = IBASEF + MJ1 180 CONTINUE C C... THE B-SPLINES WHICH ARE NONZERO ON THE CURRENT C... SUBINTERVAL ONLY. C IF (KMJ.LE.0) GO TO 210 DO 200 L=1,KMJ IF (JCOMP.EQ.JJ) Q(ID,IQM+L) = BASEF(IBASEF+MJ1) DO 190 J=1,MJ Q(ID,IQM+L) = Q(ID,IQM+L) - DF(JJ,IDF+J)*BASEF(IBASEF+J) 190 CONTINUE IBASEF = IBASEF + MJ1 200 CONTINUE C C... THE B-SPLINES WHICH ARE NONZERO ON THE SUCCEEDING C... SUBINTERVAL AS WELL. C 210 DO 230 L=1,MJ IF (JCOMP.EQ.JJ) Q(ID,IQ+KD+L) = BASEF(IBASEF+MJ1) DO 220 J=1,MJ Q(ID,IQ+KD+L) = Q(ID,IQ+KD+L) - DF(JJ,IDF+J)* * BASEF(IBASEF+J) 220 CONTINUE IBASEF = IBASEF + MJ1 230 CONTINUE C IDF = IDF + MJ IQ = IQ + MJ IQM = IQM + KMJ 240 CONTINUE 250 CONTINUE RETURN END C APP 10 C-----------------------------------------------------------------------APP 20 C P A R T 4 APP 30 C B-SPLINE ROUTINES -- SEE (3) APP 40 C-----------------------------------------------------------------------APP 50 C APP 60 SUBROUTINE APPSLN(X, Z, FSPACE, ISPACE) APP 70 C C***************************************************************** C C PURPOSE C C SET UP A STANDARD CALL TO APPROX TO EVALUATE THE C APPROXIMATE SOLUTION Z = Z( U(X) ) AT A POINT X C (IT HAS BEEN COMPUTED BY A CALL TO COLSYS ). C THE PARAMETERS NEEDED FOR APPROX ARE RETRIEVED C FROM THE WORK ARRAYS ISPACE AND FSPACE . C C***************************************************************** C DIMENSION Z(1), FSPACE(1), ISPACE(1) IS6 = ISPACE(6) + 1 IS5 = ISPACE(1) + 2 CALL APPROX(ISPACE(5), X, Z, FSPACE(IS6), FSPACE, ISPACE, * FSPACE(IS5), ISPACE(2), ISPACE(3), ISPACE(8), ISPACE(4), 1, * DUMM, 0) RETURN END C APP 10 C.................................................................. APP 20 C APP 30 SUBROUTINE APPROX(I, X, Z, VN, XI, N, ALDIF, K, NCOMP, M, MSTAR, APP 40 * MODE, DMVAL, MODHI) C C*********************************************************************** C C PURPOSE C (1) (M1-1) (MNCOMP-1) C EVALUATE Z(U(X))=(U (X),U (X),...,U (X),...,U (X) ) C 1 1 1 MNCOMP C AT ONE POINT X. C IF MODHI=1, EVALUATE MJ-TH DERIVATIVES TOO. C C VARIABLES C VN - TRIANGULAR ARRAY OF B-SPLINE VALUES FILLED IN BY C ROUTINES BSPFIX AND BSPVAR C XI - THE CURRENT MESH (HAVING N SUBINTERVALS) C ALDIF - THE ARRAY OF DIVIDED DIFFERENCES OF THE CURRENT C SOLUTION VECTORS COEFFICIENTS ALPHA (AND PREVIOUSLY C DETERMINED IN THE ROUTINE APPDIF) C MODE - DETERMINES THE AMOUNT OF INITIALIZATION NEEDED C = 5 FORMS Z(U(X)) USING ALDIF AND VN C = 3 AS IN =5, BUT FINISHES FILLING IN VN USING BSPVAR C = 2 AS IN =3, BUT STARTS FILLING IN VN USING BSPFIX C = 1 AS IN =2, BUT DETERMINES I SUCH THAT C XI(I) .LE. X .LT. XI(I+1) (UNLESS X=XI(N+1)) C = 4 A SPECIAL CASE WHICH ONLY DETERMINES I AS ABOVE C DMVAL - ARRAY OF MJ-TH DERIVATIVES OF THE SOLUTION COMPONENTS C UJ (EVALUATED IF MODHI=1) C C*********************************************************************** C COMMON /NONLN/ PRECIS, NONLIN, ITER, LIMIT, ICARE, IPRINT, * IGUESS, IFREEZ COMMON /SIDE/ ZETA(40), ALEFT, ARIGHT, IZETA, IWR DIMENSION Z(1), VN(1), XI(1), ALDIF(1), M(1), DMVAL(1) C GO TO (10, 60, 70, 10, 80), MODE C C... MODE = 1 OR 4, LOCATE I SO XI(I) .LE. X .LT. XI(I+1) C 10 CONTINUE IF (X.GE.XI(1)-PRECIS .AND. X.LE.XI(N+1)+PRECIS) GO TO 20 IF (IPRINT.LT.1) WRITE (IWR,99999) X, XI(1), XI(N+1) IF (X.LT.XI(1)) X = XI(1) IF (X.GT.XI(N+1)) X = XI(N+1) 20 IF (I.GT.N .OR. I.LT.1) I = (N+1)/2 ILEFT = I IF (X.LT.XI(ILEFT)) GO TO 40 DO 30 L=ILEFT,N I = L IF (X.LT.XI(L+1)) GO TO 60 30 CONTINUE GO TO 60 40 IRIGHT = ILEFT - 1 DO 50 L=1,IRIGHT I = IRIGHT + 1 - L IF (X.GE.XI(I)) GO TO 60 50 CONTINUE 60 IF (MODE.EQ.4) RETURN C C... MODE = 1 OR 2 BEGIN FILLING IN VN USING BSPFIX . C... COMPUTE MESH INDEPENDENT SPLINES. C RHOX = (XI(I+1)-X)/(XI(I+1)-XI(I)) CALL BSPFIX(RHOX, VN, K, NCOMP, M) C C... MODE = 1, 2, OR 3 FINISH FILLING IN VN USING BSPVAR C 70 CALL BSPVAR(I, X, VN, XI, N, K, NCOMP, M) C C... MODE .NE. 4 DETERMINE Z(U(X)) C 80 DO 90 L=1,MSTAR Z(L) = 0. 90 CONTINUE INDIF = 0 K5 = 1 IF (MODHI.EQ.0) GO TO 110 C C... INITIALIZE FOR SUBSEQUENT EVALUATION OF MJ-TH DERIVATIVES. C IVNHI = K*(K-1)/2 DNK2 = FLOAT(K)/(XI(I+1)-XI(I)) INCOMP = 0 DO 100 J=1,NCOMP DMVAL(J) = 0. 100 CONTINUE C C... EVALUATE Z( U(X) ). C 110 DO 150 J=1,NCOMP MJ = M(J) NALPHJ = N*K + MJ KMR = K + MJ IVN = KMR*(KMR-1)/2 DO 130 NR=1,MJ LEFT = I*K + MJ - KMR DO 120 L=1,KMR LEFTPL = LEFT + L Z(K5) = Z(K5) + ALDIF(INDIF+LEFTPL)*VN(IVN+L) 120 CONTINUE KMR = KMR - 1 IVN = IVN - KMR K5 = K5 + 1 INDIF = INDIF + NALPHJ 130 CONTINUE IF (MODHI.EQ.0) GO TO 150 C C... EVALUATE DMVAL(J) = MJ-TH DERIVATIVE OF UJ. C INCOMP = INCOMP + (MJ-1)*NALPHJ LEFT = (I-1)*K + MJ - 1 DO 140 L=1,K DMVAL(J) = DMVAL(J) + DNK2*(ALDIF(INCOMP+LEFT+L+1) * -ALDIF(INCOMP+LEFT+L))*VN(IVNHI+L) 140 CONTINUE INCOMP = INCOMP + NALPHJ 150 CONTINUE RETURN C-------------------------------------------------------- 99999 FORMAT (37H ****** DOMAIN ERROR IN APPROX ******/4H X =, D20.10, * 10H ALEFT =, D20.10, 11H ARIGHT =, D20.10) END C BSP 10 C.......................................................................BSP 20 C BSP 30 SUBROUTINE BSPFIX(RHOX, VN, K, NCOMP, M) BSP 40 C C********************************************************************** C C PURPOSE C EVALUATE THE MESH INDEPENDENT BSPLINES AT ONE POINT C C C VARIABLES C VN - TRIANGULAR ARRAY OF B-SPLINE VALUES AT X FOR ORDERS C 1 TO K+M(NCOMP) WHERE XI(I) .LE. X .LE. XI(I+1) , COLUMN C J HAS LENGTH J AND CONTAINS THE J-TH ORDER B-SPLINE C VALUES AND BEGINS IN LOCATION I + J*(J-1)/2. VALUES C NOT COMPUTED HERE ARE COMPUTED IN BSPVAR. C RHOX = (XI(I+1)-X)/(XI(I+1)-XI(I)) C C*********************************************************************** C DIMENSION VN(1), M(1) XRHO = 1. - RHOX IVN = 0 C C... COMPUTE FIRST GROUP OF MESH INDEPENDENT B-SPLINE VALUES C VN(1) = 1. DO 20 L=1,K IVN = IVN + L VNP = 0. DO 10 J=1,L REP = VN(IVN-L+J) VN(IVN+J) = VNP + REP*RHOX VNP = REP*XRHO 10 CONTINUE VN(IVN+L+1) = VNP 20 CONTINUE C C... COMPUTE SECOND GROUP OF MESH INDEPENDENT B-SPLINE VALUES C MD1 = M(NCOMP) - 1 IF (MD1.LE.0) RETURN DO 40 L=1,MD1 IVN = IVN + K + L INC = L + 2 VNP = VN(IVN+1-K)*XRHO IF (K.LT.INC) RETURN DO 30 J=INC,K REP = VN(IVN-L-K+J) VN(IVN+J) = VNP + REP*RHOX VNP = REP*XRHO 30 CONTINUE VN(IVN+K+1) = VNP 40 CONTINUE RETURN END C BSP 10 C.......................................................................BSP 20 C BSP 30 SUBROUTINE BSPVAR(I, X, VN, XI, N, K, NCOMP, M) BSP 40 C C*********************************************************************** C C PURPOSE C EVALUATE THE MESH DEPENDENT B-SPLINES AT ONE POINT X C C VARIABLES C VN - TRIANGULAR ARRAY OF VALUES OF B-SPLINES OF ORDERS 1 C TO K+M(NCOMP) (DESCRIBED IN BSPFIX) C X - SATISFIES XI(I) .LE. X .LE. XI(I+1) C C********************************************************************** C DIMENSION VN(1), XI(1), M(1) MD1 = M(NCOMP) - 1 IF (MD1.LE.0) RETURN XIL = XI(1) IF (I.GT.1) XIL = XI(I-1) XIR = XI(N+1) IF (I.LT.N) XIR = XI(I+2) RHO1 = (XI(I+1)-X)/(XI(I+1)-XI(I)) RHO2 = (XI(I+1)-X)/(XI(I+1)-XIL) RHO3 = (XIR-X)/(XIR-XI(I)) XRHO1 = 1. - RHO1 XRHO2 = 1. - RHO2 XRHO3 = 1. - RHO3 IVN = K*(K+1)/2 C C... RECURSIVELY COMPUTE B-SPLINE VALUES. C DO 30 L=1,MD1 IVN = IVN + K + L VNP = 0. DO 10 J=1,L REP = VN(IVN-L-K+J) VN(IVN+J) = VNP + REP*RHO2 VNP = REP*XRHO2 10 CONTINUE VN(IVN+L+1) = VNP + RHO1*VN(IVN-K+1) VNP = VN(IVN-L)*XRHO1 DO 20 J=1,L REP = VN(IVN+J-L) VN(IVN+K+J) = VNP + REP*RHO3 VNP = REP*XRHO3 20 CONTINUE VN(IVN+K+L+1) = VNP 30 CONTINUE RETURN END C BSP 10 C.......................................................................BSP 20 C BSP 30 SUBROUTINE BSPDER(VN, XMESH, N, X, I, BASEF, MODE) BSP 40 C C*********************************************************************** C C PURPOSE C EVALUATE THE DERIVATIVES OF THE B-SPLINES OF APPROPRIATE C ORDERS AT ONE POINT X (USED TO SET UP THE C COLLOCATION EQUATIONS.) C C VARIABLES C C VN - THE TRIANGULAR ARRAY OF B-SPLINE VALUES CALCULATED IN C BSPFIX AND BSPVAR C BASEF - B-SPLINE DERIVATIVES NEEDED TO SET UP COLLOCATION C EQUATIONS, VIZ, DERIVATIVES OF ORDERS 0,1,...,MJ OF C B-SPLINES OF ORDER K+MJ (J=1,...,NCOMP). THESE C VALUES ARE FOUND USING VN, ALPHD, AND ALPHN (SEE BELOW). C ALPHD - ARRAY OF DIVIDED DIFFERENCES CORRESPONDING TO DERIVA- C TIVES OF B-SPLINES OF ORDER K+MNCOMP C ALPHN - SAME AS ALPHD, BUT FOR OTHER ORDER B-SPLINES C ALPHDO - DIVIDED DIFFERENCES OF ONE LOWER ORDER, USED TO DETER- C MINE ALPHD C ALPHNO - DIVIDED DIFFERENCES OF ONE LOWER ORDER, USED TO DETER- C MINE ALPHN C ND - THE NO. OF DIFFERENTIAL EQUATIONS OF DISTINCT ORDERS C (SO NO. OF OTHER DIFFERENTIAL EQUATIONS =NEQ =NCOMP-ND) C MND - THE DISTINCT ORDERS OF THESE ND DIFFERENTIAL EQUATIONS C XMESH - CURRENT MESH, WITH XMESH(I) .LE. X .LT. XMESH(I+1) (UNLE C X=XMESH(N+1) C MODE - DETERMINES THE AMOUNT OF INITIALIZATION NEEDED C = 4 COMPUTE THE ARRAY BASEF C = 3 AS IN =4, BUT FILL IN SUBINTERVAL DEPENDENT VALUES C OF VN USING BSPVAR C = 2 AS IN =3, BUT FILL IN SUBINTERVAL INDEPENDENT VALUES C OF VN USING BSPFIX C = 1 AS IN =2, BUT CALCULATE CERTAIN SUBINTERVAL DEPEN- C DENT CONSTANTS C C*********************************************************************** C COMMON /ORDER/ K, NCOMP, MSTAR, KD, KDM, MNSUM, M(20) COMMON /HI/ DN1, DN2, DN3 COMMON /EQORD/ IND(5), INEQ(20), MND(5), ND, NEQ DIMENSION BASEF(1), VN(1), XMESH(1) DIMENSION ALPHD(80), ALPHDO(80), ALPHN(280), ALPHNO(280) C GO TO (10, 20, 30, 40), MODE C C... MODE = 1 COMPUTE SUBINTERVAL DEPENDENT CONSTANTS C 10 XIL = XMESH(1) IF (I.GT.1) XIL = XMESH(I-1) XIR = XMESH(N+1) IF (I.LT.N) XIR = XMESH(I+2) DN1 = 1./(XMESH(I+1)-XIL) DN2 = 1./(XMESH(I+1)-XMESH(I)) DN3 = 1./(XIR-XMESH(I)) C C... MODE = 2 COMPUTE SUBINTERVAL INDEPENDENT B-SPLINES C 20 RHOX = (XMESH(I+1)-X)*DN2 CALL BSPFIX(RHOX, VN, K, NCOMP, M) C C... MODE = 3 COMPUTE SUBINTERVAL DEPENDENT B-SPLINES C 30 CALL BSPVAR(I, X, VN, XMESH, N, K, NCOMP, M) C C... MODE = 4 C 40 MD = MND(ND) KMD = K + MD KMD1 = KMD + 1 MD1 = MD + 1 MD2M2 = MD*2 - 2 MD2M1 = MD2M2 + 1 INL = KMD*2 C C... INITIALIZE ARRAYS ALPHDO AND ALPHNO C DO 50 J=1,KMD ALPHDO(J) = 0. ALPHDO(J+KMD) = 1. 50 CONTINUE KUP = KMD*MD DO 60 J=1,KUP ALPHDO(J+INL) = 0. 60 CONTINUE NDM1 = ND - 1 NREST = MD2M2 - K INN = 0 IF (NREST.LE.0) GO TO 100 IF (ND.EQ.1) GO TO 100 INL = 2*MD2M2 DO 90 NN=1,NDM1 MN2 = MND(NN) + 2 DO 70 J=1,MD2M2 ALPHNO(J+INN) = 0. ALPHNO(J+INN+MD2M2) = 1. 70 CONTINUE KUP = MD2M2*MND(NN) DO 80 J=1,KUP ALPHNO(J+INN+INL) = 0. 80 CONTINUE INN = INN + MN2*MD2M2 90 CONTINUE 100 INNS = INN C C... INITIALIZE B-SPLINE DERIVATIVE VALUES BASEF C DO 130 J=1,ND K1 = IND(J) MJ = MND(J) KMJ = K + MJ MJ1 = MJ + 1 IVN = KMJ*(KMJ-1)/2 DO 120 L=1,KMJ BASEF(K1) = VN(IVN+L) DO 110 JJ=1,MJ BASEF(K1+JJ) = 0. 110 CONTINUE K1 = K1 + MJ1 120 CONTINUE 130 CONTINUE C C... FOR EACH DERIVATIVE NR DO LOOP 310 C DO 390 NR=1,MD NR1 = NR + 1 MDR = MD - NR K1 = IND(ND) + NR KMDR = K + MDR IVN = KMDR*(KMDR-1)/2 IF (MDR.EQ.0) GO TO 160 C C... FIRST, DETERMINE NR(TH) DERIVATIVE OF B-SPLINES C... CORRESPONDING TO THE HIGHEST ORDER SOLUTION COMPONENT C... (I.E. OF ORDER MNCOMP=MD). C DO 150 J=1,MDR JR = J + NR JIN = JR + NR1*KMD JINK = JIN + K DO 140 L=J,JR JIN1 = JIN - KMD1 JINK1 = JINK - KMD1 ALPHD(JIN) = DN1*(ALPHDO(JIN)-ALPHDO(JIN1)) ALPHD(JINK) = DN3*(ALPHDO(JINK)-ALPHDO(JINK1)) IN = K1 + (L-1)*MD1 BASEF(IN) = BASEF(IN) + ALPHD(JIN)*VN(IVN+J) IN = IN + K*MD1 BASEF(IN) = BASEF(IN) + ALPHD(JINK)*VN(IVN+J+K) JIN = JIN - KMD JINK = JINK - KMD 140 CONTINUE 150 CONTINUE 160 MDR1 = MDR + 1 IF (MDR1.GT.K) GO TO 190 DO 180 J=MDR1,K JR = J + NR JIN = JR + NR1*KMD DO 170 L=J,JR JIN1 = JIN - KMD1 ALPHD(JIN) = DN2*(ALPHDO(JIN)-ALPHDO(JIN1)) IN = K1 + (L-1)*MD1 BASEF(IN) = BASEF(IN) + ALPHD(JIN)*VN(IVN+J) JIN = JIN - KMD 170 CONTINUE 180 CONTINUE 190 CONTINUE IF (ND.EQ.1) GO TO 270 INN = INNS C C... NOW DETERMINE NR(TH) DERIVATIVE BASEF FOR B-SPLINES C... CORRESPONDING TO ALL OTHER SOLUTION COMPONENTS (NN) C DO 260 NN=1,NDM1 NJ = ND - NN MJ = MND(NJ) INN = INN - (MJ+2)*MD2M2 IF (NR.GT.MJ) GO TO 270 KMJR = K + MJ - NR K1 = IND(NJ) + NR IVN = KMJR*(KMJR-1)/2 MJ1 = MJ + 1 JR1 = KMJR - MD + 1 JR1 = MIN0(JR1,MD-1) C C... COMPUTE PORTION OF B-SPLINE DERIVATIVE VALUES (BASEF) C... USING DIVIDED DIFFERENCES PREVIOUSLY CALCULATED FOR THE C... HIGHEST ORDER SOLUTION COMPONENT IN ALPHD. C DO 210 J=1,JR1 JR = J + NR JIN = JR + NR1*KMD + MD - MJ DO 200 L=J,JR IN = K1 + (L-1)*MJ1 BASEF(IN) = BASEF(IN) + ALPHD(JIN)*VN(IVN+J) JIN = JIN - KMD 200 CONTINUE 210 CONTINUE DO 230 J=MD,KMJR JR = J + NR JIN = JR + NR1*KMD DO 220 L=J,JR IN = K1 + (L-1)*MJ1 BASEF(IN) = BASEF(IN) + ALPHD(JIN)*VN(IVN+J) JIN = JIN - KMD 220 CONTINUE 230 CONTINUE C C... FINISH COMPUTING B-SPLINE DERIVATIVE VALUES USING THE C... NEW NR(TH) DIVIDED DIFFERENCES ALPHN C JR2 = MD2M2 - KMJR IF (JR2.LE.0) GO TO 260 DO 250 JJ=1,JR2 J = JJ + JR1 JR = J + NR JIN = JR + NR1*MD2M2 + INN DO 240 L=J,JR JIN1 = JIN - MD2M1 ALPHN(JIN) = DN2*(ALPHNO(JIN)-ALPHNO(JIN1)) IN = K1 + (L-1)*MJ1 BASEF(IN) = BASEF(IN) + ALPHN(JIN)*VN(IVN+J) JIN = JIN - MD2M2 240 CONTINUE 250 CONTINUE 260 CONTINUE 270 CONTINUE C C... SAVE NR(TH) DIVIDED DIFFERENCE VALUES, ALPHD AND ALPHN, C... TO BE USED TO DETERMINE THE NEXT HIGHER ORDER DIVIDED C... DIFFERENCES, BY STORING THEM IN ALPHDO AND ALPHNO C IF (NR.EQ.MD) GO TO 380 NR2 = NR + 2 INJ = NR DO 290 L=2,NR2 INJ = INJ + KMD DO 280 J=1,KMDR ALPHDO(J+INJ) = ALPHD(J+INJ) 280 CONTINUE 290 CONTINUE IF (ND.EQ.1) GO TO 380 IF (NREST.LE.0) GO TO 380 INN = 0 DO 370 NN=1,NDM1 MN = MND(NN) IF (MN.LE.NR) GO TO 360 KMNR = K + MN - NR JR1 = MIN0(KMNR-MD+1,MD-1) INJ = NR + INN INL = NR + MD - MN DO 310 L=2,NR2 INJ = INJ + MD2M2 INL = INL + KMD DO 300 J=1,JR1 ALPHNO(INJ+J) = ALPHD(INL+J) 300 CONTINUE 310 CONTINUE MUP = MIN0(KMNR,MD2M2) INJ = NR + INN INL = NR DO 330 L=2,NR2 INJ = INJ + MD2M2 INL = INL + KMD DO 320 J=MD,MUP ALPHNO(INJ+J) = ALPHD(INL+J) 320 CONTINUE 330 CONTINUE JR2 = MD2M2 - KMNR IF (JR2.LE.0) GO TO 360 INJ = NR + INN DO 350 L=2,NR2 INJ = INJ + MD2M2 DO 340 JJ=1,JR2 JIN = INJ + JJ + JR1 ALPHNO(JIN) = ALPHN(JIN) 340 CONTINUE 350 CONTINUE 360 INN = INN + (MN+2)*MD2M2 370 CONTINUE 380 CONTINUE 390 CONTINUE C C... PROPERLY NORMALIZE BASEF VALUES C DO 420 J=1,ND IN = IND(J) ICONS = 1 MJ = MND(J) KMJ = K + MJ MJ1 = MJ + 1 DO 410 NR=1,MJ ICONS = ICONS*(KMJ-NR) IN = IN + 1 DO 400 L=1,KMJ LBASEF = IN + (L-1)*MJ1 BASEF(LBASEF) = BASEF(LBASEF)*FLOAT(ICONS) 400 CONTINUE 410 CONTINUE 420 CONTINUE C C... COPY BASEF VALUES CORRESPONDING TO EQUAL ORDER SOLUTION COMPONENTS C IF (NEQ.EQ.0) RETURN JD = 1 DO 460 J=1,NEQ IN1 = INEQ(J) 430 IF (IN1.LT.IND(JD+1)) GO TO 440 JD = JD + 1 GO TO 430 440 MJ = MND(JD) NTOT = (K+MJ)*(1+MJ) IN2 = IND(JD) DO 450 L=1,NTOT BASEF(IN1-1+L) = BASEF(IN2-1+L) 450 CONTINUE 460 CONTINUE RETURN END C APP 10 C.......................................................................APP 20 C APP 30 SUBROUTINE APPDIF(ALDIF, ALPHA, XI, N, K, NCOMP, M, MSTAR) APP 40 C C*********************************************************************** C C PURPOSE C COMPUTE A DIVIDED DIFFERENCE TABLE BASED UPON THE VECTOR C OF SOLUTION COMPONENTS C C VARIABLES C ALPHA - VECTOR OF SOLUTION COEFFICIENTS (FOR ALL COMPONENTS) C CORRESPONDING TO THE MESH XI(1),...,XI(N+1) C ALDIF - THE DIVIDED DIFFERENCE ARRAY BASED UPON ALPHA, VIZ, C ALDIF(I,R,J) = (R-1)ST DIVIDED DIFFERENCE OF ALPHA C CORRESPONDING TO U (X), FOR C J C I=R,...,K+N+MJ; R=1,...,MJ; J=1,...,NCOMP C C*********************************************************************** C DIMENSION ALDIF(1), ALPHA(1), XI(1), M(1) KD = K*NCOMP INCOMP = 0 K3 = 0 K4 = 0 C C... CONSTRUCT THE DIFFERENCE TABLE FOR EACH COMPONENT. C DO 130 J=1,NCOMP MJ = M(J) KMJ = K - MJ MJM1 = MJ - 1 KMR = K + MJ NALPHJ = N*K + MJ INN = INCOMP K1 = MSTAR K2 = KD K5 = INN + 1 C C... COPY ALPHA INTO THE FIRST ROWS (NR=0) OF ALDIF C DO 10 L=1,MJ ALDIF(K5) = ALPHA(K3+L) K5 = K5 + 1 10 CONTINUE DO 50 I=1,N IF (KMJ.EQ.0) GO TO 30 DO 20 L=1,KMJ ALDIF(K5) = ALPHA(K1+K4+L) K5 = K5 + 1 20 CONTINUE 30 DO 40 L=1,MJ ALDIF(K5) = ALPHA(K2+K3+L) K5 = K5 + 1 40 CONTINUE K1 = K1 + KD K2 = K2 + KD 50 CONTINUE C C... FOR EACH DERIVATIVE NR COMPUTE DIVIDED DIFFERENCES C IF (MJM1.EQ.0) GO TO 120 DO 110 NR=1,MJM1 INN1 = INN + NALPHJ KMR = KMR - 1 MJR = MJ - NR KMJR = K - MJR XIP1 = XI(1) DNK2 = FLOAT(KMR)/(XI(2)-XIP1) C C... FOR XI(1),XI(2), THE DIVIDED DIFFERENCE IS A SPECIAL CASE C DO 60 L=1,NR ALDIF(INN1+L) = 0. 60 CONTINUE DO 70 L=NR,MJM1 L1 = L + 1 ALDIF(INN1+L1) = (ALDIF(INN+L1)-ALDIF(INN+L))*DNK2 70 CONTINUE IBEG1 = MJ IBEG2 = K + NR C C... NOW THE DIVIDED DIFFERENCE CALCULATIONS FOR XI(I),XI(I+1), C... I=1,...,N C DO 100 I=1,N XII = XIP1 XIP1 = XI(I+1) DNK1 = FLOAT(KMR)/(XIP1-XII) IF (I.LT.N) DNK2 = FLOAT(KMR)/(XI(I+2)-XII) IF (I.EQ.N) DNK2 = DNK1 C C... THE ACTUAL CALCULATIONS INVOLVE TWO LOOPS C DO 80 L=1,KMJR L1 = IBEG1 + L ALDIF(INN1+L1) = (ALDIF(INN+L1)-ALDIF(INN+L1-1))*DNK1 80 CONTINUE DO 90 L=1,MJR L1 = IBEG2 + L ALDIF(INN1+L1) = (ALDIF(INN+L1)-ALDIF(INN+L1-1))*DNK2 90 CONTINUE IBEG1 = IBEG1 + K IBEG2 = IBEG2 + K 100 CONTINUE INN = INN1 110 CONTINUE 120 CONTINUE K3 = K3 + MJ K4 = K4 + KMJ INCOMP = INCOMP + NALPHJ*MJ 130 CONTINUE RETURN END C HOR 10 C.......................................................................HOR 20 C HOR 30 SUBROUTINE HORDER(I, UHIGH, XIOLD, ALDIF) HOR 40 C C*********************************************************************** C C PURPOSE C DETERMINE HIGHEST ORDER (PIECEWISE CONSTANT) DERIVATIVES C OF THE CURRENT COLLOCATION SOLUTION C C VARIABLES C ALDIF - DIVIDED DIFFERENCES OF THE SOLUTION COEFFICIENTS ALPHA C UHIGH - THE ARRAY OF HIGHEST ORDER (PIECEWISE CONSTANT) C DERIVATIVES OF THE APPROXIMATE SOLUTION ON C (XIOLD(I),XIOLD(I+1)), VIZ, C (K+MJ-1) C UHIGH(J) = U (X) ON (XIOLD(I),XIOLD(I+1)) J=1,...,N C J C C*********************************************************************** C COMMON /APPR/ N, NOLD, NMAX, NALPHA, MSHFLG, MSHNUM, MSHLMT, * MSHALT COMMON /ORDER/ K, NCOMP, MSTAR, KD, KDM, MNSUM, M(20) DIMENSION UHIGH(1), AR(20), ARM1(20) DIMENSION ALDIF(1), XIOLD(1) C DN2 = 1./(XIOLD(I+1)-XIOLD(I)) INCOMP = 0 C C... LOOP THROUGH THE NCOMP SOLUTION COMPONENTS C DO 50 J=1,NCOMP MJ = M(J) NALPHJ = K*NOLD + MJ KPMJ = K + MJ KMR = K + 1 MJM1 = MJ - 1 INCOMP = INCOMP + MJM1*NALPHJ LEFT = I*K + MJ - KMR C C... FURTHER DIVIDED DIFFERENCES OF THE APPROPRIATE ALDIF C... (VIZ. OF THE (MJ-1)ST DIVIDED DIFFERENCES OF THE ALPHA) ARE C... CALCULATED TO OBTAIN THE (K+MJ-1)ST DIVIDED DIFFERENCE C DO 10 L=1,KMR LEFTPL = LEFT + L ARM1(L+MJ-1) = ALDIF(INCOMP+LEFTPL) 10 CONTINUE INCOMP = INCOMP + NALPHJ KPMJ1 = KPMJ - 1 DO 40 NR=MJ,KPMJ1 KMR = KMR - 1 DNK2 = DN2*FLOAT(KMR) DO 20 L=1,KMR AR(L+NR) = DNK2*(ARM1(L+NR)-ARM1(L+NR-1)) 20 CONTINUE DO 30 L=NR,KPMJ ARM1(L) = AR(L) 30 CONTINUE 40 CONTINUE UHIGH(J) = AR(KPMJ) 50 CONTINUE RETURN END C MAN 10 C---------------------------------------------------------------- MAN 20 C MAN 30 C PROBLEM 1 - SEE COMPANION PAPER MAN 40 C MAN 50 REAL FSPACE(2000), ZETA(4), TOL(2), Z(4), U(4), ERR(4) MAN 60 INTEGER ISPACE(200), M(1), IPAR(11), LTOL(2) MAN 70 EXTERNAL FSUB, DFSUB, GSUB, DGSUB MAN 80 C MAN 90 WRITE (6,99999) MAN 100 C MAN 110 C ONE DIFFERENTIAL EQUATION OF ORDER 4. MAN 120 M(1) = 4 MAN 130 C GIVE LOCATION OF BOUNDARY CONDITIONS MAN 140 ZETA(1) = 1. MAN 150 ZETA(2) = 1. MAN 160 ZETA(3) = 2. MAN 170 ZETA(4) = 2. MAN 180 C SET UP PARAMETER ARRAY. MAN 190 C USE DEFAULT VALUES FOR ALL PARAMETERS EXCEPT FOR INITIAL MAN 200 C MESH SIZE, NO. OF TOLERANCES AND SIZES OF WORK ARRAYS MAN 210 DO 10 I=1,11 MAN 220 IPAR(I) = 0 MAN 230 10 CONTINUE MAN 240 IPAR(3) = 1 MAN 250 IPAR(4) = 2 MAN 260 IPAR(5) = 2000 MAN 270 IPAR(6) = 200 MAN 280 C TWO ERROR TOLERANCES (ON U AND ITS SECOND DERIVATIVE) MAN 290 LTOL(1) = 1 MAN 300 LTOL(2) = 3 MAN 310 TOL(1) = 1.E-7 MAN 320 TOL(2) = 1.E-7 MAN 330 C MAN 340 CALL COLSYS(1, M, 1., 2., ZETA, IPAR, LTOL, TOL, DUMMY, ISPACE, MAN 350 * FSPACE, IFLAG, FSUB, DFSUB, GSUB, DGSUB, DUMMY) MAN 360 C MAN 370 IF (IFLAG.NE.1) STOP MAN 380 C CALCULATE THE ERROR AT 101 POINTS USING THE KNOWN MAN 390 C EXACT SOLUTION MAN 400 X = 1. MAN 410 DO 20 I=1,4 MAN 420 ERR(I) = 0. MAN 430 20 CONTINUE MAN 440 DO 40 J=1,101 MAN 450 CALL APPSLN(X, Z, FSPACE, ISPACE) MAN 460 CALL EXACT(X, U) MAN 470 DO 30 I=1,4 MAN 480 ERR(I) = AMAX1(ERR(I),ABS(U(I)-Z(I))) MAN 490 30 CONTINUE MAN 500 X = X + .01 MAN 510 40 CONTINUE MAN 520 WRITE (6,99998) (ERR(I),I=1,4) MAN 530 STOP MAN 540 99999 FORMAT (1H1, 35H EXAMPLE OF A SIMPLE PROBLEM SETUP./10H UNIFORML,MAN 550 * 36HY LOADED BEAM OF VARIABLE STIFFNESS,/21H SIMPLY SUPPORTED AT,MAN 560 * 11H BOTH ENDS./) MAN 570 99998 FORMAT (/27H ERROR TOLERANCES SATISFIED//22H THE EXACT ERRORS ARE,MAN 580 * /7X, 4E12.4) MAN 590 END MAN 600 C................................................................ FSU 10 SUBROUTINE FSUB(X, Z, F) FSU 20 REAL Z(4), F(1) F(1) = (1.-6.*X**2*Z(4)-6.*X*Z(3))/X**3 RETURN END C................................................................ DFS 10 SUBROUTINE DFSUB(X, Z, DF) DFS 20 REAL Z(4), DF(1,4) DF(1,1) = 0. DF(1,2) = 0. DF(1,3) = -6./X**2 DF(1,4) = -6./X RETURN END C................................................................ GSU 10 SUBROUTINE GSUB(I, Z, G) GSU 20 REAL Z(4) GO TO (10, 20, 10, 20), I 10 G = Z(1) - 0. RETURN 20 G = Z(3) - 0. RETURN END C................................................................ DGS 10 SUBROUTINE DGSUB(I, Z, DG) DGS 20 REAL Z(4), DG(4) DO 10 J=1,4 DG(J) = 0. 10 CONTINUE GO TO (20, 30, 20, 30), I 20 DG(1) = 1. RETURN 30 DG(3) = 1. RETURN END C................................................................ EXA 10 SUBROUTINE EXACT(X, U) EXA 20 REAL U(4) C EXACT SOLUTION U(1) = .25*(10.*ALOG(2.)-3.)*(1.-X) + .5*(1./X+(3.+X)*ALOG(X)-X) U(2) = -.25*(10.*ALOG(2.)-3.) + .5*(-1./X/X+ALOG(X)+(3.+X)/X-1.) U(3) = .5*(2./X**3+1./X-3./X/X) U(4) = .5*(-6./X**4-1./X/X+6./X**3) RETURN END C MAN 10 C---------------------------------------------------------------- MAN 20 C MAN 30 C PROBLEM 2 - SEE COMPANION PAPER MAN 40 C MAN 50 REAL ZETA(4), FSPACE(40000), TOL(4), Z(4) MAN 60 INTEGER M(2), IPAR(11), ISPACE(2500), LTOL(4) MAN 70 COMMON EPS, DMU, EPS4MU, GAMMA, XT MAN 80 EXTERNAL SOLUTN, FSUB, DFSUB, GSUB, DGSUB MAN 90 C DEFINE CONSTANTS, PRINT A HEADING. MAN 100 GAMMA = 1.1 MAN 110 EPS = .01 MAN 120 DMU = EPS MAN 130 EPS4MU = EPS**4/DMU MAN 140 XT = SQRT(2.*(GAMMA-1.)/GAMMA) MAN 150 WRITE (6,99999) GAMMA, XT, EPS, DMU, EPS4MU MAN 160 C DEFINE NO. OF DIFFERENTIAL EQUATIONS. MAN 170 NCOMP = 2 MAN 180 C ORDERS MAN 190 M(1) = 2 MAN 200 M(2) = 2 MAN 210 C INTERVAL ENDS MAN 220 ALEFT = 0. MAN 230 ARIGHT = 1. MAN 240 C LOCATIONS OF SIDE CONDITIONS MAN 250 ZETA(1) = 0. MAN 260 ZETA(2) = 0. MAN 270 ZETA(3) = 1. MAN 280 ZETA(4) = 1. MAN 290 C IPAR VALUES MAN 300 C A NONLINEAR PROBLEM MAN 310 IPAR(1) = 1 MAN 320 C 4 COLLOCATION POINTS PER SUBINTERVAL MAN 330 IPAR(2) = 4 MAN 340 C INITIAL UNIFORM MESH OF 10 SUBINTERVALS MAN 350 IPAR(3) = 10 MAN 360 IPAR(8) = 0 MAN 370 C DIMENSION OF REAL WORK ARRAY FSPACE IS 40000 MAN 380 IPAR(5) = 40000 MAN 390 C DIMENSION OF INTEGER WORK ARRAY ISPACE IS 2500 MAN 400 IPAR(6) = 2500 MAN 410 C (THESE DIMENSIONS OF FSPACE AND ISPACE MAN 420 C ENABLE COLSYS TO USE MESHES OF UP TO 192 INTERVALS.) MAN 430 C PRINT FULL OUTPUT. MAN 440 IPAR(7) = -1 MAN 450 C INITIAL APPROXIMATION FOR NONLINEAR ITERATION IS PROVIDED MAN 460 C IN SOLUTN MAN 470 IPAR(9) = 1 MAN 480 C A REGULAR PROBLEM MAN 490 IPAR(10) = 0 MAN 500 C NO FIXED POINTS IN THE MESH MAN 510 IPAR(11) = 0 MAN 520 C TOLERANCES ON ALL COMPONENTS MAN 530 IPAR(4) = 4 MAN 540 DO 10 I=1,4 MAN 550 LTOL(I) = I MAN 560 TOL(I) = 1.E-5 MAN 570 10 CONTINUE MAN 580 C CALL COLSYS MAN 590 CALL COLSYS(NCOMP, M, ALEFT, ARIGHT, ZETA, IPAR, LTOL, TOL, MAN 600 * FIXPNT, ISPACE, FSPACE, IFLAG, FSUB, DFSUB, GSUB, DGSUB, SOLUTN) MAN 610 C PRINT VALUES OF THE OBTAINED APPROXIMATE SOLUTION AT POINTS MAN 620 C X = 0,.05, ..., 1. MAN 630 X = 0. MAN 640 WRITE (6,99998) MAN 650 NP1 = 21 MAN 660 DO 20 III=1,NP1 MAN 670 CALL APPSLN(X, Z, FSPACE, ISPACE) MAN 680 WRITE (6,99997) X, Z MAN 690 X = X + .05 MAN 700 20 CONTINUE MAN 710 STOP MAN 720 99999 FORMAT (1H1, 27HDIMPLING OF SPHERICAL CAPS./8H GAMMA =, MAN 730 * F7.2/6H XT =, E12.5/6H EPS =, E12.5/6H MU =, E12.5/9H EPS**4/M,MAN 740 * 3HU =, E12.5) MAN 750 99998 FORMAT (1H1, 44H X PHI DPHI , MAN 760 * 23H PSI DPSI/) MAN 770 99997 FORMAT (6X, F5.2, 4X, 6E15.5) MAN 780 END MAN 790 C................................................................ SOL 10 SUBROUTINE SOLUTN(X, Z, DMVAL) SOL 20 COMMON EPS, DMU, EPS4MU, GAMMA, XT DIMENSION Z(4), DMVAL(2) CONS = GAMMA*X*(1.-.5*X*X) DCONS = GAMMA*(1.-1.5*X*X) D2CONS = -3.*GAMMA*X IF (X.GT.XT) GO TO 10 Z(1) = 2.*X Z(2) = 2. Z(3) = -2.*X + CONS Z(4) = -2. + DCONS DMVAL(2) = D2CONS GO TO 20 10 Z(1) = 0. Z(2) = 0. Z(3) = -CONS Z(4) = -DCONS DMVAL(2) = -D2CONS 20 DMVAL(1) = 0. RETURN END C................................................................ FSU 10 SUBROUTINE FSUB(X, Z, F) FSU 20 DIMENSION Z(4), F(2) COMMON EPS, DMU, EPS4MU, GAMMA, XT F(1) = Z(1)/X/X - Z(2)/X + (Z(1)-Z(3)*(1.-Z(1)/X)-GAMMA*X*(1.-X*X/ * 2.))/EPS4MU F(2) = Z(3)/X/X - Z(4)/X + Z(1)*(1.-Z(1)/2./X)/DMU RETURN END C................................................................ DFS 10 SUBROUTINE DFSUB(X, Z, DF) DFS 20 DIMENSION Z(4), DF(2,4) COMMON EPS, DMU, EPS4MU, GAMMA, XT DF(1,1) = 1./X/X + (1.+Z(3)/X)/EPS4MU DF(1,2) = -1./X DF(1,3) = -(1.-Z(1)/X)/EPS4MU DF(1,4) = 0. DF(2,1) = (1.-Z(1)/X)/DMU DF(2,2) = 0. DF(2,3) = 1./X/X DF(2,4) = -1./X RETURN END C................................................................ GSU 10 SUBROUTINE GSUB(I, Z, G) GSU 20 DIMENSION Z(4) GO TO (10, 20, 10, 30), I 10 G = Z(1) RETURN 20 G = Z(3) RETURN 30 G = Z(4) - .3*Z(3) + .7 RETURN END C................................................................ DGS 10 SUBROUTINE DGSUB(I, Z, DG) DGS 20 DIMENSION Z(4), DG(4) DO 10 J=1,4 DG(J) = 0. 10 CONTINUE GO TO (20, 30, 20, 40), I 20 DG(1) = 1. RETURN 30 DG(3) = 1. RETURN 40 DG(4) = 1. DG(3) = -.3 RETURN END C MAN 10 C---------------------------------------------------------------- MAN 20 C MAN 30 C PROBLEM 3 - SEE COMPANION PAPER MAN 40 C MAN 50 REAL ZETA(5), FSPACE(40000), TOL(2), SVAL(3), ELVAL(3) MAN 60 INTEGER M(2), ISPACE(2500), LTOL(2), IPAR(11) MAN 70 REAL Z(5) MAN 80 COMMON EN, S, EL, CONS MAN 90 EXTERNAL FSUB, DFSUB, GSUB, DGSUB, SOLUTN MAN 100 DATA SVAL /.2,.1,.05/, ELVAL /60.,120.,200./ MAN 110 C MAN 120 EN = .2 MAN 130 CONS = .5*(3.-EN) MAN 140 NCOMP = 2 MAN 150 M(1) = 2 MAN 160 M(2) = 3 MAN 170 ALEFT = 0. MAN 180 ARIGHT = 1. MAN 190 C MAN 200 ZETA(1) = 0. MAN 210 ZETA(2) = 0. MAN 220 ZETA(3) = 0. MAN 230 ZETA(4) = 1. MAN 240 ZETA(5) = 1. MAN 250 C MAN 260 IPAR(1) = 1 MAN 270 IPAR(2) = 4 MAN 280 IPAR(3) = 10 MAN 290 IPAR(4) = 2 MAN 300 IPAR(5) = 40000 MAN 310 IPAR(6) = 2500 MAN 320 IPAR(7) = 0 MAN 330 IPAR(8) = 0 MAN 340 IPAR(9) = 1 MAN 350 IPAR(10) = 0 MAN 360 IPAR(11) = 0 MAN 370 C MAN 380 LTOL(1) = 1 MAN 390 LTOL(2) = 3 MAN 400 TOL(1) = 1.E-5 MAN 410 TOL(2) = 1.E-5 MAN 420 C MAN 430 C SOLVE A CHAIN OF 3 PROBLEMS MAN 440 DO 30 IJK=1,3 MAN 450 S = SVAL(IJK) MAN 460 EL = ELVAL(IJK) MAN 470 IF (IJK.EQ.1) GO TO 10 MAN 480 C SET CONTINUATION PARAMETERS MAN 490 IPAR(9) = 3 MAN 500 IPAR(3) = ISPACE(1) MAN 510 10 CONTINUE MAN 520 WRITE (6,99999) EN, S, EL MAN 530 C MAN 540 CALL COLSYS(NCOMP, M, ALEFT, ARIGHT, ZETA, IPAR, LTOL, TOL, MAN 550 * FIXPNT, ISPACE, FSPACE, IFLAG, FSUB, DFSUB, GSUB, DGSUB, MAN 560 * SOLUTN) MAN 570 C MAN 580 IF (IFLAG.NE.1) STOP MAN 590 C PRINT VALUES OF THE OBTAINED APPROXIMATE SOLUTION AT POINTS MAN 600 C X = 0,1,2, ..., L. MAN 610 IS6 = ISPACE(6) MAN 620 IS5 = ISPACE(1) + 2 MAN 630 X = 0. MAN 640 WRITE (6,99998) MAN 650 NP1 = EL + 1.5 MAN 660 DO 20 III=1,NP1 MAN 670 CALL APPROX(II, X, Z, FSPACE(IS6), FSPACE(1), ISPACE(1), MAN 680 * FSPACE(IS5), ISPACE(2), NCOMP, M, ISPACE(4), 1, DM, 0) MAN 690 XL = X*EL MAN 700 Z(2) = Z(2)/EL MAN 710 Z(4) = Z(4)/EL MAN 720 Z(5) = Z(5)/EL/EL MAN 730 WRITE (6,99997) XL, Z MAN 740 X = X + 1./EL MAN 750 20 CONTINUE MAN 760 30 CONTINUE MAN 770 STOP MAN 780 99999 FORMAT (1H1, 38H ROTATING FLOW OVER A STATIONARY DISK./8H PARAME,MAN 790 * 11HTERS - N =, F5.2, 6H S =, F5.2, 6H L =, F6.1/) MAN 800 99998 FORMAT (1H1, 44H X G DG , MAN 810 * 38H H DH D2H/) MAN 820 99997 FORMAT (6E15.5) MAN 830 END MAN 840 C................................................................ SOL 10 SUBROUTINE SOLUTN(X, Z, DMVAL) SOL 20 COMMON EN, S, EL, CONS REAL Z(5), DMVAL(2) EX = EXP(-EL*X) Z(1) = 1. - EX Z(2) = EL*EX Z(3) = -EL**2*X**2*EX Z(4) = (EL**3*X**2-2.*EL**2*X)*EX Z(5) = (-EL**4*X**2+4.*EL**3*X-2.*EL**2)*EX DMVAL(1) = -EL*Z(2) DMVAL(2) = (EL**5*X*X-6.*EL**4*X+6.*EL**3)*EX RETURN END C................................................................ FSU 10 SUBROUTINE FSUB(X, Z, F) FSU 20 REAL Z(1), F(1) COMMON EN, S, EL, CONS F(1) = -EL*(CONS*Z(3)*Z(2)+(EN-1.)*Z(4)*Z(1)) + EL**2*S*(Z(1)-1.) F(2) = -EL*(CONS*Z(3)*Z(5)+EN*Z(4)**2) + EL**2*S*Z(4) + * EL**3*(1.-Z(1)**2) RETURN END C................................................................ DFS 10 SUBROUTINE DFSUB(X, Z, DF) DFS 20 REAL Z(1), DF(2,1) COMMON EN, S, EL, CONS DF(1,1) = -EL*(EN-1.)*Z(4) + EL**2*S DF(1,2) = -EL*CONS*Z(3) DF(1,3) = -EL*CONS*Z(2) DF(1,4) = -EL*(EN-1.)*Z(1) DF(1,5) = 0. DF(2,1) = -EL**3*2.*Z(1) DF(2,2) = 0. DF(2,3) = -EL*CONS*Z(5) DF(2,4) = -EL*EN*2.*Z(4) + EL**2*S DF(2,5) = -EL*CONS*Z(3) RETURN END C................................................................ GSU 10 SUBROUTINE GSUB(I, Z, G) GSU 20 REAL Z(1), G GO TO (10, 20, 30, 40, 30), I 10 G = Z(1) RETURN 20 G = Z(3) RETURN 30 G = Z(4) RETURN 40 G = Z(1) - 1. RETURN END C................................................................ DGS 10 SUBROUTINE DGSUB(I, Z, DG) DGS 20 REAL Z(1), DG(1) DO 10 J=1,5 DG(J) = 0. 10 CONTINUE GO TO (20, 30, 40, 20, 40), I 20 DG(1) = 1. RETURN 30 DG(3) = 1. RETURN 40 DG(4) = 1. RETURN END C FCB 10 C---------------------------------------------------------------- FCB 20 C FCB 30 C FCB 40 C---------------------------------------------------------------- FCB 50 C FOR CONVENIENCE OF THE USER WE LIST HERE THE PACKAGE FCB 60 C SOLVEBLOK OF DE BOOR - WEISS (4), USED IN COLSYS. FCB 70 C-----------------------------------------------------------------------FCB 80 C FCB 90 SUBROUTINE FCBLOK(BLOKS, INTEGS, NBLOKS, IPIVOT, SCRTCH, IFLAG) FCB 100 C C****************************************************************** C C CALLS SUBROUTINES FACTRB AND SHIFTB . C C FCBLOK SUPERVISES THE PLU FACTORIZATION WITH PIVOTING OF C SCALED ROWS OF THE ALMOST BLOCK DIAGONAL MATRIX STORED IN THE C ARRAYS BLOKS AND INTEGS . C C FACTRB = SUBPROGRAM WHICH CARRIES OUT STEPS 1,...,LAST OF GAUSS C ELIMINATION (WITH PIVOTING) FOR AN INDIVIDUAL BLOCK. C SHIFTB = SUBPROGRAM WHICH SHIFTS THE REMAINING ROWS TO THE TOP OF C THE NEXT BLOCK C C PARAMETERS C BLOKS AN ARRAY THAT INITIALLY CONTAINS THE ALMOST BLOCK DIAGONA C MATRIX A TO BE FACTORED, AND ON RETURN CONTAINS THE COM- C PUTED FACTORIZATION OF A . C INTEGS AN INTEGER ARRAY DESCRIBING THE BLOCK STRUCTURE OF A . C NBLOKS THE NUMBER OF BLOCKS IN A . C IPIVOT AN INTEGER ARRAY OF DIMENSION SUM (INTEGS(1,N) ; N=1, C ...,NBLOKS) WHICH, ON RETURN, CONTAINS THE PIVOTING STRA- C TEGY USED. C SCRTCH WORK AREA REQUIRED, OF LENGTH MAX (INTEGS(1,N) ; N=1, C ...,NBLOKS). C IFLAG OUTPUT PARAMETER; C = 0 IN CASE MATRIX WAS FOUND TO BE SINGULAR. C OTHERWISE, C = (-1)**(NUMBER OF ROW INTERCHANGES DURING FACTORIZATION) C C*********************************************************************** C INTEGER INTEGS(3,NBLOKS), IPIVOT(1), IFLAG, I, INDEX, INDEXB, * INDEXN, LAST, NCOL, NROW REAL BLOKS(1), SCRTCH(1) IFLAG = 1 INDEXB = 1 INDEXN = 1 I = 1 C C... LOOP OVER THE BLOCKS. I IS LOOP INDEX C 10 INDEX = INDEXN NROW = INTEGS(1,I) NCOL = INTEGS(2,I) LAST = INTEGS(3,I) C C... CARRY OUT ELIMINATION ON THE I-TH BLOCK UNTIL NEXT BLOCK C... ENTERS, I.E., FOR COLUMNS 1,...,LAST OF I-TH BLOCK. C CALL FACTRB(BLOKS(INDEX), IPIVOT(INDEXB), SCRTCH, NROW, NCOL, * LAST, IFLAG) C C... CHECK FOR HAVING REACHED A SINGULAR BLOCK OR THE LAST BLOCK C IF (IFLAG.EQ.0 .OR. I.EQ.NBLOKS) RETURN I = I + 1 INDEXN = NROW*NCOL + INDEX C C... PUT THE REST OF THE I-TH BLOCK ONTO THE NEXT BLOCK C CALL SHIFTB(BLOKS(INDEX), IPIVOT(INDEXB), NROW, NCOL, LAST, * BLOKS(INDEXN), INTEGS(1,I), INTEGS(2,I)) INDEXB = INDEXB + NROW GO TO 10 END C FAC 10 C.......................................................................FAC 20 C FAC 30 SUBROUTINE FACTRB(W, IPIVOT, D, NROW, NCOL, LAST, IFLAG) FAC 40 C C*********************************************************************** C C ADAPTED FROM P.132 OF ELEMENT.NUMER.ANALYSIS BY CONTE-DE BOOR C C CONSTRUCTS A PARTIAL PLU FACTORIZATION, CORRESPONDING TO STEPS C 1,..., LAST IN GAUSS ELIMINATION, FOR THE MATRIX W OF C ORDER ( NROW , NCOL ), USING PIVOTING OF SCALED ROWS. C C PARAMETERS C W CONTAINS THE (NROW,NCOL) MATRIX TO BE PARTIALLY FACTORED C ON INPUT, AND THE PARTIAL FACTORIZATION ON OUTPUT. C IPIVOT AN INTEGER ARRAY OF LENGTH NROW CONTAINING A RECORD OF C THE PIVOTING STRATEGY USED; ROW IPIVOT(I) IS USED C DURING THE I-TH ELIMINATION STEP, I=1,...,LAST. C D A WORK ARRAY OF LENGTH NROW USED TO STORE ROW SIZES C TEMPORARILY. C NROW NUMBER OF ROWS OF W. C NCOL NUMBER OF COLUMNS OF W. C LAST NUMBER OF ELIMINATION STEPS TO BE CARRIED OUT. C IFLAG ON OUTPUT, EQUALS IFLAG ON INPUT TIMES (-1)**(NUMBER OF C ROW INTERCHANGES DURING THE FACTORIZATION PROCESS), IN C CASE NO ZERO PIVOT WAS ENCOUNTERED. C OTHERWISE, IFLAG = 0 ON OUTPUT. C C*********************************************************************** C INTEGER IPIVOT(NROW), NCOL, LAST, IFLAG, I, IPIVI, IPIVK, J, K, * KP1 REAL W(NROW,NCOL), D(NROW), AWIKDI, COLMAX, RATIO, ROWMAX C C... INITIALIZE IPIVOT, D C DO 20 I=1,NROW IPIVOT(I) = I ROWMAX = 0. DO 10 J=1,NCOL ROWMAX = AMAX1(ROWMAX,ABS(W(I,J))) 10 CONTINUE IF (ROWMAX.EQ.0.) GO TO 90 D(I) = ROWMAX 20 CONTINUE C C... GAUSS ELIMINATION WITH PIVOTING OF SCALED ROWS, LOOP OVER C... K=1,.,LAST C K = 1 C C... AS PIVOT ROW FOR K-TH STEP, PICK AMONG THE ROWS NOT YET USED, C... I.E., FROM ROWS IPIVOT(K),...,IPIVOT(NROW), THE ONE WHOSE K-TH C... ENTRY (COMPARED TO THE ROW SIZE) IS LARGEST. THEN, IF THIS ROW C... DOES NOT TURN OUT TO BE ROW IPIVOT(K), REDEFINE IPIVOT(K) AP- C... PROPRIATELY AND RECORD THIS INTERCHANGE BY CHANGING THE SIGN C... OF IFLAG . C 30 IPIVK = IPIVOT(K) IF (K.EQ.NROW) GO TO 80 J = K KP1 = K + 1 COLMAX = ABS(W(IPIVK,K))/D(IPIVK) C C... FIND THE (RELATIVELY) LARGEST PIVOT C DO 40 I=KP1,NROW IPIVI = IPIVOT(I) AWIKDI = ABS(W(IPIVI,K))/D(IPIVI) IF (AWIKDI.LE.COLMAX) GO TO 40 COLMAX = AWIKDI J = I 40 CONTINUE IF (J.EQ.K) GO TO 50 IPIVK = IPIVOT(J) IPIVOT(J) = IPIVOT(K) IPIVOT(K) = IPIVK IFLAG = -IFLAG 50 CONTINUE C C... IF PIVOT ELEMENT IS TOO SMALL IN ABSOLUTE VALUE, DECLARE C... MATRIX TO BE NONINVERTIBLE AND QUIT. C IF (ABS(W(IPIVK,K))+D(IPIVK).LE.D(IPIVK)) GO TO 90 C C... OTHERWISE, SUBTRACT THE APPROPRIATE MULTIPLE OF THE PIVOT C... ROW FROM REMAINING ROWS, I.E., THE ROWS IPIVOT(K+1),..., C... IPIVOT(NROW), TO MAKE K-TH ENTRY ZERO. SAVE THE MULTIPLIER C... IN ITS PLACE. C DO 70 I=KP1,NROW IPIVI = IPIVOT(I) W(IPIVI,K) = W(IPIVI,K)/W(IPIVK,K) RATIO = -W(IPIVI,K) DO 60 J=KP1,NCOL W(IPIVI,J) = RATIO*W(IPIVK,J) + W(IPIVI,J) 60 CONTINUE 70 CONTINUE K = KP1 C C... CHECK FOR HAVING REACHED THE NEXT BLOCK. C IF (K.LE.LAST) GO TO 30 RETURN C C... IF LAST .EQ. NROW , CHECK NOW THAT PIVOT ELEMENT IN LAST ROW C... IS NONZERO. C 80 IF (ABS(W(IPIVK,NROW))+D(IPIVK).GT.D(IPIVK)) RETURN C C... SINGULARITY FLAG SET C 90 IFLAG = 0 RETURN END C SHI 10 C...................................................................... SHI 20 C SHI 30 SUBROUTINE SHIFTB(AI, IPIVOT, NROWI, NCOLI, LAST, AI1, NROWI1, SHI 40 * NCOLI1) C C********************************************************************** C C SHIFTS THE ROWS IN CURRENT BLOCK, AI, NOT USED AS PIVOT ROWS, IF C ANY, I.E., ROWS IPIVOT(LAST+1),...,IPIVOT(NROWI), ONTO THE FIRST C MMAX = NROW-LAST ROWS OF THE NEXT BLOCK, AI1, WITH COLUMN LAST+J C OF AI GOING TO COLUMN J , J=1,...,JMAX=NCOLI-LAST. THE REMAINING C COLUMNS OF THESE ROWS OF AI1 ARE ZEROED OUT. C C PICTURE C C ORIGINAL SITUATION AFTER RESULTS IN A NEW BLOCK I+1 C LAST = 2 COLUMNS HAVE BEEN CREATED AND READY TO BE C DONE IN FACTRB (ASSUMING NO FACTORED BY NEXT FACTRB C INTERCHANGES OF ROWS) CALL. C 1 C X X 1X X X X X X X X C 1 C 0 X 1X X X 0 X X X X C BLOCK I 1 --------------- C NROWI = 4 0 0 1X X X 0 0 1X X X 0 01 C NCOLI = 5 1 1 1 C LAST = 2 0 0 1X X X 0 0 1X X X 0 01 C ------------------------------- 1 1 NEW C 1X X X X X 1X X X X X1 BLOCK C 1 1 1 I+1 C BLOCK I+1 1X X X X X 1X X X X X1 C NROWI1= 5 1 1 1 C NCOLI1= 5 1X X X X X 1X X X X X1 C ------------------------------- 1-------------1 C 1 C C*********************************************************************** C INTEGER IPIVOT(NROWI), LAST, IP, J, JMAX, JMAXP1, M, MMAX REAL AI(NROWI,NCOLI), AI1(NROWI1,NCOLI1) MMAX = NROWI - LAST JMAX = NCOLI - LAST IF (MMAX.LT.1 .OR. JMAX.LT.1) RETURN C C... PUT THE REMAINDER OF BLOCK I INTO AI1 C DO 20 M=1,MMAX IP = IPIVOT(LAST+M) DO 10 J=1,JMAX AI1(M,J) = AI(IP,LAST+J) 10 CONTINUE 20 CONTINUE IF (JMAX.EQ.NCOLI1) RETURN C C... ZERO OUT THE UPPER RIGHT CORNER OF AI1 C JMAXP1 = JMAX + 1 DO 40 J=JMAXP1,NCOLI1 DO 30 M=1,MMAX AI1(M,J) = 0. 30 CONTINUE 40 CONTINUE RETURN END C SBB 10 C...................................................................... SBB 20 C SBB 30 SUBROUTINE SBBLOK(BLOKS, INTEGS, NBLOKS, IPIVOT, B, X) SBB 40 C C********************************************************************** C C CALLS SUBROUTINES SUBFOR AND SUBBAK . C C SUPERVISES THE SOLUTION (BY FORWARD AND BACKWARD SUBSTITUTION) OF C THE LINEAR SYSTEM A*X = B FOR X, WITH THE PLU FACTORIZATION OF C A ALREADY GENERATED IN FCBLOK . INDIVIDUAL BLOCKS OF C EQUATIONS ARE SOLVED VIA SUBFOR AND SUBBAK . C C PARAMETERS C BLOKS, INTEGS, NBLOKS, IPIVOT ARE AS ON RETURN FROM FCBLOK. C B THE RIGHT SIDE, STORED CORRESPONDING TO THE STORAGE OF C THE EQUATIONS. SEE COMMENTS IN S L V B L K FOR DETAILS. C X SOLUTION VECTOR C C*********************************************************************** C INTEGER INTEGS(3,NBLOKS), IPIVOT(1), I, INDEX, INDEXB, INDEXX, J, * LAST, NBP1, NCOL, NROW REAL BLOKS(1), B(1), X(1) C C... FORWARD SUBSTITUTION PASS C INDEX = 1 INDEXB = 1 INDEXX = 1 DO 10 I=1,NBLOKS NROW = INTEGS(1,I) LAST = INTEGS(3,I) CALL SUBFOR(BLOKS(INDEX), IPIVOT(INDEXB), NROW, LAST, * B(INDEXB), X(INDEXX)) INDEX = NROW*INTEGS(2,I) + INDEX INDEXB = INDEXB + NROW INDEXX = INDEXX + LAST 10 CONTINUE C C... BACK SUBSTITUTION PASS C NBP1 = NBLOKS + 1 DO 20 J=1,NBLOKS I = NBP1 - J NROW = INTEGS(1,I) NCOL = INTEGS(2,I) LAST = INTEGS(3,I) INDEX = INDEX - NROW*NCOL INDEXB = INDEXB - NROW INDEXX = INDEXX - LAST CALL SUBBAK(BLOKS(INDEX), IPIVOT(INDEXB), NROW, NCOL, LAST, * X(INDEXX)) 20 CONTINUE RETURN END C SUB 10 C...................................................................... SUB 20 C SUB 30 SUBROUTINE SUBFOR(W, IPIVOT, NROW, LAST, B, X) SUB 40 C C*********************************************************************** C C CARRIES OUT THE FORWARD PASS OF SUBSTITUTION FOR THE CURRENT C BLOCK, I.E., THE ACTION ON THE RIGHT SIDE CORRESPONDING TO THE C ELIMINATION CARRIED OUT IN FACTRB FOR THIS BLOCK. C AT THE END, X(J) CONTAINS THE RIGHT SIDE OF THE TRANSFORMED C IPIVOT(J)-TH EQUATION IN THIS BLOCK, J=1,...,NROW. THEN, SINCE C FOR I=1,...,NROW-LAST, B(NROW+I) IS GOING TO BE USED AS THE RIGHT C SIDE OF EQUATION I IN THE NEXT BLOCK (SHIFTED OVER THERE FROM C THIS BLOCK DURING FACTORIZATION), IT IS SET EQUAL TO X(LAST+I) C HERE. C C PARAMETERS C W, IPIVOT, NROW, LAST ARE AS ON RETURN FROM FACTRB. C B(J) IS EXPECTED TO CONTAIN, ON INPUT, THE RIGHT SIDE OF J-TH C EQUATION FOR THIS BLOCK, J=1,...,NROW. C B(NROW+J) CONTAINS, ON OUTPUT, THE APPROPRIATELY MODIFIED RIGHT C SIDE FOR EQUATION J IN NEXT BLOCK, J=1,...,NROW-LAST. C X(J) CONTAINS, ON OUTPUT, THE APPROPRIATELY MODIFIED RIGHT C SIDE OF EQUATION IPIVOT(J) IN THIS BLOCK, J=1,...,LAST C (AND EVEN FOR J=LAST+1,...,NROW). C C*********************************************************************** C INTEGER IPIVOT(NROW), IP, JMAX, K REAL W(NROW,LAST), B(1), X(NROW), SUM IP = IPIVOT(1) X(1) = B(IP) IF (NROW.EQ.1) GO TO 40 DO 20 K=2,NROW IP = IPIVOT(K) JMAX = MIN0(K-1,LAST) SUM = 0. DO 10 J=1,JMAX SUM = W(IP,J)*X(J) + SUM 10 CONTINUE X(K) = B(IP) - SUM 20 CONTINUE C C... TRANSFER MODIFIED RIGHT SIDES OF EQUATIONS IPIVOT(LAST+1),..., C... IPIVOT(NROW) TO NEXT BLOCK. C NROWML = NROW - LAST IF (NROWML.EQ.0) GO TO 40 LASTP1 = LAST + 1 DO 30 K=LASTP1,NROW B(NROWML+K) = X(K) 30 CONTINUE 40 RETURN END C SUB 10 C...................................................................... SUB 20 C SUB 30 SUBROUTINE SUBBAK(W, IPIVOT, NROW, NCOL, LAST, X) SUB 40 C C*********************************************************************** C C CARRIES OUT BACKSUBSTITUTION FOR CURRENT BLOCK. C C PARAMETERS C W, IPIVOT, NROW, NCOL, LAST ARE AS ON RETURN FROM FACTRB. C X(1),...,X(NCOL) CONTAINS, ON INPUT, THE RIGHT SIDE FOR THE C EQUATIONS IN THIS BLOCK AFTER BACKSUBSTITUTION HAS BEEN C CARRIED UP TO BUT NOT INCLUDING EQUATION IPIVOT(LAST). C MEANS THAT X(J) CONTAINS THE RIGHT SIDE OF EQUATION IPI- C VOT(J) AS MODIFIED DURING ELIMINATION, J=1,...,LAST, C WHILE FOR J .GT. LAST, X(J) IS ALREADY A COMPONENT OF C THE SOLUTION VECTOR. C X(1),...,X(NCOL) CONTAINS, ON OUTPUT, THE COMPONENTS OF THE C SOLUTION CORRESPONDING TO THE PRESENT BLOCK. C C********************************************************************** C INTEGER IPIVOT(NROW), LAST, IP, J, K, KP1 REAL W(NROW,NCOL), X(NCOL), SUM K = LAST IP = IPIVOT(K) SUM = 0. IF (K.EQ.NCOL) GO TO 30 KP1 = K + 1 10 DO 20 J=KP1,NCOL SUM = W(IP,J)*X(J) + SUM 20 CONTINUE 30 X(K) = (X(K)-SUM)/W(IP,K) IF (K.EQ.1) RETURN KP1 = K K = K - 1 IP = IPIVOT(K) SUM = 0. GO TO 10 END C-----------------------------------------------------------------------MAN 10 C### C----------------------------------------------------------------------- C P A R T 1 C MAIN STORAGE ALLOCATION AND PROGRAM CONTROL SUBROUTINES C----------------------------------------------------------------------- C SUBROUTINE COLSYS (NCOMP, M, ALEFT, ARIGHT, ZETA, IPAR, LTOL, 1 TOL, FIXPNT, ISPACE, FSPACE, IFLAG, FSUB, 2 DFSUB, GSUB, DGSUB, SOLUTN) C C C*********************************************************************** C C PURPOSE C C SUBROUTINE COLSYS SOLVES A MULTI-POINT BOUNDARY VALUE C PROBLEM FOR A MIXED ORDER SYSTEM OF ODE-S GIVEN BY C C (M(I)) C U = F ( X; Z(U(X)) ) I = 1, ... ,NCOMP C I I C C ALEFT .LT. X .LT. ARIGHT, C C C G ( ZETA(J); Z(U(ZETA(J))) )= 0 J = 1, ... ,MSTAR C J C MSTAR=M(1)+M(2)+...+M(NCOMP), C C C WHERE T C U = (U , U , ... ,U ) IS THE EXACT SOLUTION VECTOR C 1 2 NCOMP C C (MI) C U IS THE MI=M(I) TH DERIVATIVE OF U C I I C C (1) (M1-1) (MNCOMP-1) T C Z(U(X)) = (U (X),U (X),...,U (X),...,U (X)) C 1 1 1 NCOMP C C F (X,Z(U)) IS A (GENERALLY) NONLINEAR FUNCTION OF C I C Z(U)=Z(U(X)). C C G (ZETA(J);Z(U)) IS A (GENERALLY) NONLINEAR BOUNDARY C J C CONDITION. C C THE BOUNDARY POINTS SATISFY C ALEFT .LE. ZETA(1) .LE. .. .LE. ZETA(MSTAR) .LE. ARIGHT C C THE ORDERS MI OF THE DIFFERENTIAL EQUATIONS SATISFY C M1 .LE. M2 .LE. ... .LE. MNCOMP .LE. 4. C C C*********************************************************************** C C WRITTEN BY C U. ASCHER, C DEPARTMENT OF COMPUTER SCIENCE, C UNIVERSITY OF BRITISH COLUMBIA, C VANCOUVER, B. C., CANADA V6T 1W5 C J. CHRISTIANSEN AND C R. D. RUSSELL, C MATHEMATICS DEPARTMENT, C SIMON FRASER UNIVERSITY, C BURNABY, B. C., CANADA V5A 1S6 C C*********************************************************************** C C METHOD C C THE METHOD USED TO APPROXIMATE THE SOLUTION U IS C COLLOCATION AT GAUSSIAN POINTS, USING B-SPLINES OF C ORDER K+MI AND CONTINUITY MI-1 IN THE I-TH COMPONENT, C I = 1, ..., NCOMP. HERE, K IS THE NUMBER OF COLLOCATION C POINTS PER SUBINTERVAL AND IS CHOSEN SUCH THAT K .GE. M(NCOMP). C C MAIN REFERENCES C C (1) U. ASCHER, J. CHRISTIANSEN AND R.D. RUSSELL, C C A COLLOCATION SOLVER FOR MIXED ORDER C SYSTEMS OF BOUNDARY VALUE PROBLEMS C C TECH. REP. 77-13, DEPT. COMPUTER SC., UNIV. B.C., C VANCOUVER, CANADA. TO APPEAR IN MATH. COMP. C C (2) U. ASCHER, J. CHRISTIANSEN AND R.D. RUSSELL, C C COLSYS - A COLLOCATION CODE FOR BOUNDARY C VALUE PROBLEMS C C PROC. CONF. FOR CODES FOR BVP-S IN ODE-S, C HOUSTON, TEXAS, 1978. C C OTHER REFERENCES C C (3) U. ASCHER AND R. D. RUSSELL C C EVALUATION OF B-SPLINES FOR SOLVING SYSTEMS C OF BOUNDARY VALUE PROBLEMS C C TECH. REP. 77-14, DEPT. COMPUTER SC., UNIV. B.C., C VANCOUVER, CANADA. C C (4) C. DEBOOR AND R. WEISS C C SOLVEBLOK: A PACKAGE FOR SOLVING ALMOST BLOCK DIAGONAL C LINEAR SYSTEMS, WITH APPLICATIONS TO SPLINE APPROXIMATION C AND THE NUMERICAL SOLUTION OF ORDINARY DIFFERENTIAL EQUATIONS C C MRC TECH REPORT 1625, UNIVERSITY OF WISCONSIN - MADISON C C C (5) R. D. RUSSELL AND J. CHRISTIANSEN C C ADAPTIVE MESH SELECTION STRATEGIES FOR C SOLVING BOUNDARY VALUE PROBLEMS C C SIAM J. NUMER. ANAL. 7(1978), 59-80. C C*********************************************************************** C C *************** INPUT TO COLSYS *************** C C VARIABLES C C NCOMP - NO. OF DIFFERENTIAL EQUATIONS (NCOMP .LE. 20) C C M(J) - ORDER OF THE J-TH DIFFERENTIAL EQUATION ( M(J).LE.M(J+1) C AND MSTAR = M(1) + ... + M(NCOMP) .LE. 40 ) C C ALEFT - LEFT END OF INTERVAL C C ARIGHT - RIGHT END OF INTERVAL C C ZETA(J) - J-TH SIDE CONDITION POINT (BOUNDARY POINT). MUST C HAVE ZETA(J) .LE. ZETA(J+1) C C IPAR - AN INTEGER ARRAY DIMENSIONED AT LEAST 11. C A LIST OF THE PARAMETERS IN IPAR AND THEIR MEANING FOLLOWS. C SOME PARAMETERS ARE RENAMED IN COLSYS, THESE NEW NAMES ARE C GIVEN IN PARENTHESES. C C IPAR(1) ( = NONLIN ) C = 0 IF THE PROBLEM IS LINEAR C = 1 IF THE PROBLEM IS NONLINEAR C C IPAR(2) = NO. OF COLLOCATION POINTS PER SUBINTERVAL (= K ) C WHERE M(NCOMP) .LT. K .LE. 7 . IF IPAR(2)=0 THEN C COLSYS SETS K = MAX ( M(NCOMP)+1, 5-M(NCOMP) ) C C IPAR(3) = NO. OF SUBINTERVALS IN THE INITIAL MESH ( = N ). C IF IPAR(3) = 0 THEN COLSYS ARBITRARILY SETS N = 5. C C IPAR(4) = NO. OF SOLUTION AND DERIVATIVE TOLERANCES. ( = NTOL ) C WE REQUIRE 0 .LT. NTOL .LE. MSTAR. C C IPAR(5) = DIMENSION OF FSPACE. ( = NDIMF ) C C IPAR(6) = DIMENSION OF ISPACE. ( = NDIMI ) C C IPAR(7) - OUTPUT CONTROL ( = IPRINT ) C = -1 FOR FULL DIAGNOSTIC PRINTOUT C = 0 FOR SELECTED PRINTOUT C = 1 FOR NO PRINTOUT C C IPAR(8) ( = IREAD ) C = 0 CAUSES COLSYS TO GENERATE A UNIFORM INITIAL MESH. C = 1 IF THE INITIAL MESH IS PROVIDED BY THE USER. IT C IS DEFINED IN FSPACE AS FOLLOWS: THE MESH C ALEFT=X(1).LT.X(2).LT. ... .LT.X(N).LT.X(N+1)=ARIGHT C WILL OCCUPY FSPACE(1), ..., FSPACE(N+1). THE C USER NEEDS TO SUPPLY ONLY THE INTERIOR MESH C POINTS FSPACE(J) = X(J), J = 2, ..., N. C = 2 IF THE INITIAL MESH IS SUPPLIED BY THE USER C AS WITH IPAR(8)=1, AND IN ADDITION NO ADAPTIVE C MESH SELECTION IS TO BE DONE. C C IPAR(9) ( = IGUESS ) C = 0 IF NO INITIAL GUESS FOR THE SOLUTION IS C PROVIDED. C = 1 IF AN INITIAL GUESS IS PROVIDED BY THE USER C IN SUBROUTINE SOLUTN. C = 2 IF AN INITIAL MESH AND APPROXIMATE SOLUTION C COEFFICIENTS ARE PROVIDED BY THE USER IN FSPACE. C (THE FORMER AND NEW MESH ARE THE SAME). C = 3 IF A FORMER MESH AND AN APPROXIMATE SOLUTION C COEFFICIENTS ARE PROVIDED BY THE USER IN FSPACE, C AND THE NEW MESH IS TO BE TAKEN TWICE AS COARSE. C = 4 IF IN ADDITION TO A FORMER INITIAL MESH AND AN C APPROXIMATE SOLUTION COEFFICIENTS, A NEW MESH C IS PROVIDED IN FSPACE AS WELL. C (SEE DESCRIPTION OF OUTPUT FOR FURTHER DETAILS C ON IGUESS = 2, 3, AND 4.) C C IPAR(10)= 0 IF THE PROBLEM IS REGULAR C = 1 IF THE FIRST RELAX FACTOR IS =RSTART, AND THE C NONLINEAR ITERATION DOES NOT RELY ON PAST COVERGENCE C (USE FOR AN EXTRA SENSITIVE NONLINEAR PROBLEM ONLY). C = 2 IF WE ARE TO RETURN IMMEDIATELY UPON (A) TWO C SUCCESSIVE NONCONVERGENCES, OR (B) AFTER OBTAINING C ERROR ESTIMATE FOR THE FIRST TIME. C C IPAR(11)= NO. OF FIXED POINTS IN THE MESH OTHER THAN C ALEFT AND ARIGHT. ( = NFXPNT , THE DIMENSION OF FIXPNT) C C LTOL - AN ARRAY OF DIMENSION IPAR(4). LTOL(J) = L SPECIFIES C THAT THE J-TH TOLERANCE IN TOL CONTROLS THE ERROR C IN THE L-TH COMPONENT OF Z(U). ALSO REQUIRE THAT C 1.LE.LTOL(1).LT.LTOL(2).LT. ... .LT.LTOL(NTOL).LE.MSTAR C C TOL - AN ARRAY OF DIMENSION IPAR(4). TOL(J) IS THE C ERROR TOLERANCE ON THE LTOL(J) -TH COMPONENT C OF Z(U). THUS, THE CODE ATTEMPTS TO SATISFY C FOR J=1,...,NTOL ON EACH SUBINTERVAL C ABS(Z(V)-Z(U)) .LE. TOL(J)*Z(U) +TOL(J) C LTOL(J) LTOL(J) C C IF V(X) IS THE APPROXIMATE SOLUTION VECTOR. C C FIXPNT - AN ARRAY OF DIMENSION IPAR(11). IT CONTAINS C THE POINTS, OTHER THAN ALEFT AND ARIGHT, WHICH C ARE TO BE INCLUDED IN EVERY MESH. C C ISPACE - AN INTEGER WORK ARRAY OF DIMENSION IPAR(6). C ITS SIZE PROVIDES A CONSTRAINT ON NMAX, C THE MAXIMUM NUMBER OF SUBINTERVALS. CHOOSE C IPAR(6) ACCORDING TO THE FORMULA C IPAR(6) .GE. NMAX*NSIZEI C WHERE C NSIZEI = 3 + KDM - NREC C WITH C KDM = KD + MSTAR ; KD = K * NCOMP ; C NREC = NO. OF RIGHT END BOUNDARY CONDITIONS. C C C FSPACE - A REAL WORK ARRAY OF DIMENSION IPAR(5). C ITS SIZE PROVIDES A CONSTRAINT ON NMAX. C CHOOSE IPAR(5) ACCORDING TO THE FORMULA C IPAR(5) .GE. NMAX*NSIZEF C WHERE C NSIZEF = 4 + K + 2 * KD + (4+2*K) * MSTAR + C (KDM-NREC) * (KDM+1). C C C IFLAG - THE MODE OF RETURN FROM COLSYS. C = 1 FOR NORMAL RETURN C = 0 IF THE COLLOCATION MATRIX IS SINGULAR. C =-1 IF THE EXPECTED NO. OF SUBINTERVALS EXCEEDS STORAGE C SPECIFICATIONS. C =-2 IF THE NONLINEAR ITERATION HAS NOT CONVERGED. C =-3 IF THERE IS AN INPUT DATA ERROR. C C C*********************************************************************** C C ********** USER SUPPLIED EXTERNAL SUBROUTINES ******* C C C FSUB - NAME OF SUBROUTINE FOR EVALUATING F(X,Z(U(X))) = C T C (F ,...,F ) AT A POINT X IN (ALEFT,ARIGHT). IT C 1 NCOMP C SHOULD HAVE THE HEADING C C SUBROUTINE FSUB (X , Z , F) C C WHERE F IS THE VECTOR CONTAINING THE VALUE OF FI(X,Z(U)) C IN THE I-TH COMPONENT AND T C Z(U(X))=(Z(1),...,Z(MSTAR)) C IS DEFINED AS ABOVE UNDER PURPOSE . C C C DFSUB - NAME OF SUBROUTINE FOR EVALUATING THE JACOBIAN OF C F(X,Z(U)) AT A POINT X. IT SHOULD HAVE THE HEADING C C SUBROUTINE DFSUB (X , Z , DF) C C WHERE Z(U(X)) IS DEFINED AS FOR FSUB AND THE (NCOMP) BY C (MSTAR) ARRAY DF SHOULD BE FILLED BY THE PARTIAL DERIV- C ATIVES OF F, VIZ, FOR A PARTICULAR CALL ONE CALCULATES C DF(I,J) = DFI / DZJ, I=1,...,NCOMP C J=1,...,MSTAR. C C C GSUB - NAME OF SUBROUTINE FOR EVALUATING THE I-TH COMPONENT OF C G(X,Z(U(X))) = G (ZETA(I),Z(U(ZETA(I)))) AT A POINT X = C I C ZETA(I) WHERE 1.LE.I.LE.MSTAR. IT SHOULD HAVE THE HEADING C C SUBROUTINE GSUB (I , Z , G) C C WHERE Z(U) IS AS FOR FSUB, AND I AND G=G ARE AS ABOVE. C I C NOTE THAT IN CONTRAST TO F IN FSUB , HERE C ONLY ONE VALUE PER CALL IS RETURNED IN G. C C C DGSUB - NAME OF SUBROUTINE FOR EVALUATING THE I-TH ROW OF C THE JACOBIAN OF G(X,U(X)). IT SHOULD HAVE THE HEADING C C SUBROUTINE DGSUB (I , Z , DG) C C WHERE Z(U) IS AS FOR FSUB, I AS FOR GSUB AND THE MSTAR- C VECTOR DG SHOULD BE FILLED WITH THE PARTIAL DERIVATIVES C OF G, VIZ, FOR A PARTICULAR CALL ONE CALCULATES C DG(I,J) = DGI / DZJ J=1,...,MSTAR. C C C SOLUTN- NAME OF SUBROUTINE TO EVALUATE THE INITIAL C APPROXIMATION FOR Z(U(X)) AND FOR DMVAL(U(X))= VECTOR C OF THE MJ-TH DERIVATIVES OF U(X). IT SHOULD HAVE THE C HEADING C C SUBROUTINE SOLUTN (X , Z , DMVAL) C C NOTE THAT THIS SUBROUTINE IS NEEDED ONLY IF USING C IPAR(9) = 1, AND THEN ALL MSTAR COMPONENTS OF Z C AND NCOMP COMPONENTS OF DMVAL SHOULD BE SPECIFIED C FOR ANY X, ALEFT .LE. X .LE. ARIGHT . C C C*********************************************************************** C C *************** OUTPUT FROM COLSYS *************** C C C UPON RETURN FROM COLSYS , THE USER MAY PRODUCE THE C SOLUTION VECTOR Z( U(X) ) AT A POINT X, ALEFT.LE.X.LE.ARIGHT C BY CALLING : C C CALL APPSLN (X, Z, FSPACE, ISPACE) C C THIS SETS UP A STANDARD CALL TO APPROX . FOR A MORE C EFFICIENT OR SOPHISTICATED RETRIEVAL OF THE SOLUTION C VALUES, CALL APPROX DIRECTLY (SEE DOCUMENTATION IN C APPROX - THE PARAMETERS NEEDED IN THE CALL TO APPROX C BY THE USER ARE SAVED IN ISPACE AND FSPACE BEFORE C COLSYS RETURNS). C C IN ORDER TO SAVE THE COEFFICIENTS OF THE SOLUTION FOR LATER C REFERENCE, ISPACE(1), ..., ISPACE(7+MSTAR) AND C FSPACE(1), ..., FSPACE(ISPACE(7)) SHOULD BE C SAVED, SINCE THESE ARE USED IN THE CALL TO APPSLN (APPROX). C C ONE CAN ALSO USE THE FORMERLY OBTAINED APPROXIMATE C SOLUTION AS A FIRST APPROXIMATION FOR THE NONLINEAR ITERATION C ON A NEW PROBLEM (E.G. FOR CONTINUATION PURPOSES). THIS C INVOLVES USING IGUESS = 2, 3, OR 4, AS FOLLOWS: C C FOR IGUESS= 2 OR 3, THE USER SHOULD PUT THE ABOVE SAVED C VALUES BACK INTO FSPACE(1),...,FSPACE(ISPACE(6)). C THE SIZE OF THE FORMER MESH, NOLD, IS PROVIDED IN IPAR(3). IF C IGUESS=2 THEN THE SIZE OF THE NEW MESH, N, IS TAKEN TO BE =NOLD. C IF IGUESS=3 THEN N := NOLD/2 AND THE NEW MESH IS TO BE TWICE AS C COARSE. C FOR IGUESS=4, PUT N IN IPAR(3) AND NOLD IN ISPACE(1). THE C VALUES OF THE FORMER SOLUTION, SAVED AS DESCRIBED ABOVE, C SHOULD BE PUT INTO FSPACE(N+2),...,FSPACE(ISPACE(6)+N+1), AND C A NEW MESH UNRELATED TO THE FORMER ONE IS PRESCRIBED IN C FSPACE(1),...,FSPACE(N+1). C C C*********************************************************************** C C *************** PACKAGE SUBROUTINES *************** C C THE FOLLOWING DESCRIPTION GIVES A BRIEF OVERVIEW OF HOW THE C PROCEDURE IS BROKEN DOWN INTO THE SUBROUTINES WHICH MAKE UP C THE PACKAGE CALLED COLSYS . FOR FURTHER DETAILS THE C USER SHOULD REFER TO DOCUMENTATION IN THE VARIOUS SUBROUTINES C AND TO THE REFERENCES CITED ABOVE. C C THE SUBROUTINES FALL INTO FOUR GROUPS: C C PART 1 - THE MAIN STORAGE ALLOCATION AND PROGRAM CONTROL SUBROUTINES. C C COLSYS - TESTS INPUT VALUES, DOES INITIALIZATION AND BREAKS UP C THE WORK AREAS, FSPACE AND ISPACE, INTO THE ARRAYS C USED BY THE PROGRAM. C C CONTRL - IS THE ACTUAL DRIVER OF THE PACKAGE. THIS ROUTINE C CONTAINS THE STRATEGY FOR NONLINEAR PROBLEMS. C C C PART 2 - MESH SELECTION AND ERROR ESTIMATION SUBROUTINES C C CONSTS - IS CALLED ONCE BY COLSYS TO INITIALIZE CONSTANTS C WHICH ARE USED FOR ERROR ESTIMATION AND MESH SELECTION. C C NEWMSH - GENERATES MESHES. IT CONTAINS THE TEST TO DECIDE C WHETHER OR NOT TO REDISTRIBUTE A MESH. C C ERRCHK - PRODUCES ERROR ESTIMATES AND CHECKS AGAINST THE C TOLERANCES AT EACH SUBINTERVAL C C C PART 3 - COLLOCATION SYSTEM SET-UP SUBROUTINES C C LSYSLV - CONTROLS THE SET-UP AND SOLUTION OF THE LINEAR C ALGEBRAIC SYSTEMS OF COLLOCATION EQUATIONS WHICH C ARISE AT EACH NEWTON ITERATION. C C BLDBLK - IS USED BY LSYSLV TO SET UP THE EQUATION(S) ASSOCIATED C WITH A SIDE CONDITION POINT OR A COLLOCATION POINT. C C C PART 4 - B-SPLINE SUBROUTINES C C APPSLN - SETS UP A STANDARD CALL TO APPROX . C C APPROX - EVALUATES A PIECEWISE POLYNOMIAL SOLUTION. C C BSPFIX - EVALUATES THE MESH INDEPENDENT B-SPLINES C (I.E. THE FIXED B-SPLINES) C C BSPVAR - EVALUATES THE MESH DEPENDENT B-SPLINES (I.E. THE C VARYING B-SPLINES) C C BSPDER - GENERATES VALUES FOR THE DERIVATIVES NEEDED TO SET C UP THE COLLOCATION EQUATIONS. C C APPDIF - GENERATES A DIVIDED DIFFERENCE TABLE FROM THE B-SPLINE C COEFFICIENTS FOR A COLLOCATION SOLUTION. THE TABLE C IS USED IN APPROX . C C HORDER - EVALUATES THE HIGHEST ORDER DERIVATIVES OF THE C CURRENT COLLOCATION SOLUTION USED FOR MESH REFINEMENT. C C C TO SOLVE THE LINEAR SYSTEMS OF COLLOCATION EQUATIONS C CONSTRUCTED IN PART 3, COLSYS USES THE PACKAGE SOLVEBLOK C OF DE BOOR AND WEISS (TO APPEAR IN TOMS). C C C---------------------------------------------------------------------- IMPLICIT REAL*8 (A-H,O-Z) COMMON /ORDER/ K,NC,MSTAR,KD,KDM,MNSUM,MT(20) COMMON /APPR/ N,NOLD,NMAX,NALPHA,MSHFLG,MSHNUM,MSHLMT,MSHALT COMMON /SIDE/ TZETA(40),TLEFT,TRIGHT,IZETA,IWR COMMON /NONLN/ PRECIS,NONLIN,ITER,LIMIT,ICARE,IPRINT,IGUESS,IFREEZ COMMON /EQORD/ IND(5), INEQ(20), MND(5), ND, NEQ COMMON /ERRORS/ TTL(40),WGTMSH(40),TOLIN(40),ROOT(40), 1 JTOL(40),LTTOL(40),NTOL EXTERNAL FSUB, DFSUB, GSUB, DGSUB, SOLUTN DIMENSION M(1), ZETA(1), IPAR(1), LTOL(1), TOL(1), 1 FIXPNT(1), ISPACE(1), FSPACE(1) C*********************************************************************** C C THE ACTUAL SUBROUTINE COLSYS SERVES AS AN INTERFACE WITH C THE PACKAGE OF SUBROUTINES REFERRED TO COLLECTIVELY AS C COLSYS. THE SUBROUTINE SERVES TO TEST SOME OF THE INPUT C PARAMETERS, RENAME SOME OF THE PARAMETERS (TO MAKE UNDER- C STANDING OF THE CODING EASIER), TO DO SOME INITIALIZATION, C AND TO BREAK THE WORK AREAS FSPACE AND ISPACE UP INTO THE C ARRAYS NEEDED BY THE PROGRAM. C C*********************************************************************** C C... SPECIFY MACHINE DEPENDENT OUTPUT UNIT IWR AND COMPUTE MACHINE C... DEPENDENT CONSTANT PRECIS = 100 * MACHINE UNIT ROUNDOFF C IWR = 6 PRECIS = 1.D0 10 PRECIS = PRECIS / 2.D0 PRECP1 = PRECIS + 1.D0 IF (PRECP1 .GT. 1.D0) GO TO 10 PRECIS = PRECIS * 100.D0 C C... IN CASE INCORRECT INPUT DATA IS DETECTED, THE PROGRAM RETURNS C... IMMEDIATELY WITH IFLAG=-3. C IFLAG = -3 IF (NCOMP .LT. 1 .OR. NCOMP .GT. 20) RETURN IF (M(1) .LT. 1 .OR. M(NCOMP) .GT. 4) RETURN IF (NCOMP .EQ. 1) GO TO 30 DO 20 I=2,NCOMP IF (M(I-1) .GT. M(I)) RETURN 20 CONTINUE 30 CONTINUE C C... RENAME SOME OF THE PARAMETERS AND SET DEFAULT VALUES. C NONLIN = IPAR(1) K = IPAR(2) IF (K .EQ. 0) K = MAX0( M(NCOMP)+1, 5-M(NCOMP) ) N = IPAR(3) IF (N .EQ. 0) N = 5 IREAD = IPAR(8) IGUESS = IPAR(9) IF (NONLIN .EQ. 0 .AND. IGUESS .EQ. 1) IGUESS = 0 IF (IGUESS .GE. 2 .AND. IREAD .EQ. 0) IREAD = 1 ICARE = IPAR(10) NTOL = IPAR(4) NDIMF = IPAR(5) NDIMI = IPAR(6) NFXPNT = IPAR(11) IPRINT = IPAR(7) MSTAR = 0 MNSUM = 0 DO 40 I=1,NCOMP MNSUM = MNSUM + M(I)**2 40 MSTAR = MSTAR + M(I) DO 50 I=1,NCOMP 50 MT(I) = M(I) DO 60 I=1,MSTAR 60 TZETA(I) = ZETA(I) DO 70 I=1,NTOL LTTOL(I) = LTOL(I) 70 TOLIN(I) = TOL(I) TLEFT = ALEFT TRIGHT = ARIGHT NC = NCOMP KD = K * NCOMP KDM = KD + MSTAR C C... PRINT THE INPUT DATA FOR CHECKING. C IF (IPRINT .GT. (-1)) GO TO 100 IF (NONLIN .GT. 0) GO TO 80 WRITE (IWR,260) NCOMP, (M(IP), IP=1,NCOMP) GO TO 90 80 WRITE(IWR,270) NCOMP, (M(IP), IP=1,NCOMP) 90 WRITE (IWR,280) (ZETA(IP), IP=1,MSTAR) WRITE (IWR,290) K WRITE (IWR,300) (LTOL(IP), IP=1,NTOL) WRITE (IWR,310) (TOL(IP), IP=1,NTOL) IF (IGUESS .GE. 2) WRITE (IWR,320) IF (IREAD .EQ. 2) WRITE (IWR,330) IF (NFXPNT .GT. 0) WRITE (IWR,340) NFXPNT, 1 (FIXPNT(IP), IP=1,NFXPNT) 100 CONTINUE C C... CHECK FOR CORRECTNESS OF DATA C IF (K .LT. 0 .OR. K .GT. 7) RETURN IF (N .LT. 0) RETURN IF (IREAD .LT. 0 .OR. IREAD .GT. 2) RETURN IF (IGUESS .LT. 0 .OR. IGUESS .GT. 4) RETURN IF (ICARE .LT. 0 .OR. ICARE .GT. 2) RETURN IF (NTOL .LT. 0 .OR. NTOL .GT. MSTAR) RETURN IF (NFXPNT .LT. 0) RETURN IF (IPRINT .LT. (-1) .OR. IPRINT .GT. 1) RETURN IF (MSTAR .LT. 0 .OR. MSTAR .GT. 40) RETURN C C... SET LIMITS ON ITERATIONS AND INITIALIZE COUNTERS. C... LIMIT = MAXIMUM NUMBER OF NEWTON ITERATIONS PER MESH. C... SEE SUBROUTINE NEWMSH FOR THE ROLES OF MSHLMT , MSHFLG , C... MSHNUM , AND MSHALT . C MSHLMT = 3 MSHFLG = 0 MSHNUM = 1 MSHALT = 1 LIMIT = 40 C C... COMPUTE THE MAXIUM POSSIBLE N FOR THE GIVEN SIZES OF C... ISPACE AND FSPACE. C NREC = 0 DO 110 II=1,MSTAR I = MSTAR + 1 - II IF (ZETA(I) .LT. ARIGHT) GO TO 110 NREC = II 110 CONTINUE NFIXI = NREC NSIZEI = 3 + KDM - NREC NFIXF = NREC * (KDM+1) + 2 * MNSUM + 2 * MSTAR + 3 NSIZEF = 4 + K + 2 * KD + (4+2*K) * MSTAR + 1(KDM-NREC) * (KDM+1) NMAXF = (NDIMF - NFIXF) / NSIZEF NMAXI = (NDIMI - NFIXI) / NSIZEI IF (IPRINT .LT. 1) WRITE(IWR,350) NMAXF, NMAXI NMAX = MIN0(NMAXF,NMAXI) IF (NMAX .LT. N) RETURN IF (NMAX .LT. NFXPNT+1) RETURN IF (NMAX .LT. 2*NFXPNT+2 .AND. IPRINT .LT. 1) WRITE(IWR,360) C C... GENERATE POINTERS TO BREAK UP FSPACE AND ISPACE . C LXI = 1 LA = LXI + NMAX + 1 LXIOLD = LA + KDM * (NMAX * (KDM-NREC) + NREC) LXIJ = LXIOLD + NMAX + 1 LALPHA = LXIJ + K * NMAX LDLPHA = LALPHA + NMAX * KD + MSTAR LELPHA = LDLPHA + NMAX * KD + MSTAR LALDIF = LELPHA + NMAX * K * MSTAR + MNSUM LRHS = LALDIF + NMAX * K * MSTAR + MNSUM LVALST = LRHS + NMAX * (KDM - NREC) + NREC LSLOPE = LVALST + 4 * MSTAR * NMAX LACCUM = LSLOPE + NMAX LIPIV = 1 LINTEG = LIPIV + (LVALST - LRHS) C C... IF IGUESS .GE. 2, MOVE XIOLD AND ALDIF TO THEIR PROPER C... LOCATIONS IN FSPACE. C IF (IGUESS .LT. 2) GO TO 160 NOLD = N IF (IGUESS .EQ. 4) NOLD = ISPACE(1) NALDIF = NOLD * K * MSTAR + MNSUM NP1 = N + 1 IF (IGUESS .EQ. 4) NP1 = NP1 + NOLD + 1 DO 120 I=1,NALDIF 120 FSPACE( LALDIF+I-1 ) = FSPACE( NP1+I ) NP1 = NOLD + 1 IF (IGUESS .EQ. 4) GO TO 140 DO 130 I=1,NP1 130 FSPACE( LXIOLD+I-1 ) = FSPACE( LXI+I-1 ) GO TO 160 140 DO 150 I=1,NP1 150 FSPACE( LXIOLD+I-1 ) = FSPACE( N+1+I ) 160 CONTINUE C C... INITIALIZE COLLOCATION POINTS, CONSTANTS, MESH. C CALL CONSTS CALL NEWMSH (3+IREAD, FSPACE(LXI), FSPACE(LXIOLD), 1 FSPACE(LXIJ), DUM1, DUM2, DUM3, DUM4, 2 NFXPNT, FIXPNT) C C... DETERMINE WHICH ARE THE DIFFERENT ORDER EQUATIONS AND C... PUT THESE ORDERS IN MND , ALSO GENERATE THE POINTERS C... IND AND INEQ WHICH WILL BE USED IN BSPDER . C IND(1) = 1 MND(1) = M(1) ND = 1 NEQ = 0 IG = (M(1)+1) * (M(1)+K) + 1 IF (NCOMP .LE. 1) GO TO 200 DO 190 J=2,NCOMP MJ = M(J) IF (MJ .EQ. M(J-1)) GO TO 170 ND = ND + 1 IND(ND) = IG MND(ND) = MJ GO TO 180 170 NEQ = NEQ + 1 INEQ(NEQ) = IG 180 IG = IG + (MJ+1) * (MJ+K) 190 CONTINUE IND(ND+1) =IND(ND) + IG 200 CONTINUE C C... DETERMINE FIRST APPROXIMATION, IF THE PROBLEM IS NONLINEAR. C IF (IGUESS .GE. 2) GO TO 230 NP1 = N + 1 DO 210 I = 1,NP1 210 FSPACE(I + LXIOLD - 1) = FSPACE(I + LXI - 1) NOLD = N IF (NONLIN .EQ. 0 .OR. IGUESS .EQ. 1) GO TO 230 C C... SYSTEM PROVIDES FIRST APPROXIMATION OF THE SOLUTION. C... CHOOSE Z(J) = 0 FOR J=1,..,MSTAR. C DO 220 I = 1,NALPHA 220 FSPACE(I + LALPHA - 1) = 0.D0 CALL APPDIF (FSPACE(LALDIF), FSPACE(LALPHA), FSPACE(LXI), 1 N, K, NC, MT, MSTAR) 230 CONTINUE IF (IGUESS .GE. 2) IGUESS = 0 CALL CONTRL (FSPACE(LXI),FSPACE(LXIOLD),FSPACE(LXIJ), 1 FSPACE(LALPHA),FSPACE(LALDIF),FSPACE(LRHS), 2 FSPACE(LDLPHA), FSPACE(LELPHA), 3 FSPACE(LA),FSPACE(LVALST),FSPACE(LSLOPE), 4 FSPACE(LACCUM),ISPACE(LIPIV),ISPACE(LINTEG), 5 NFXPNT,FIXPNT,IFLAG,FSUB,DFSUB,GSUB,DGSUB, 6 SOLUTN) C... PREPARE OUTPUT ISPACE(1) = N ISPACE(2) = K ISPACE(3) = NCOMP ISPACE(4) = MSTAR NALDIF = N * K * MSTAR + MNSUM ISPACE(5) = NALDIF ISPACE(6) = NALDIF + N + 2 ISPACE(7) = ISPACE(6) + 65 DO 240 I=1,NCOMP 240 ISPACE(7+I) = M(I) DO 250 I=1,NALDIF 250 FSPACE(N+1+I) = FSPACE(LALDIF-1+I) RETURN C----------------------------------------------------------------------- 260 FORMAT(/// 37H THE NUMBER OF (LINEAR) DIFF EQNS IS , I3/ 1X, 1 16HTHEIR ORDERS ARE, 20I3) 270 FORMAT(/// 40H THE NUMBER OF (NONLINEAR) DIFF EQNS IS , I3/ 1X, 1 16HTHEIR ORDERS ARE, 20I3) 280 FORMAT(27H SIDE CONDITION POINTS ZETA, 8F10.6, 4( / 27X, 8F10.6)) 290 FORMAT(37H NUMBER OF COLLOC PTS PER INTERVAL IS, I3) 300 FORMAT(39H COMPONENTS OF Z REQUIRING TOLERANCES -,8(7X,I2,1X), 1 4(/38X,8I10)) 310 FORMAT(33H CORRESPONDING ERROR TOLERANCES -,6X,8D10.2, 1 4(/39X,8D10.2)) 320 FORMAT(44H INITIAL MESH(ES) AND ALPHA PROVIDED BY USER) 330 FORMAT(27H NO ADAPTIVE MESH SELECTION) 340 FORMAT(10H THERE ARE ,I5,27H FIXED POINTS IN THE MESH - , 1 10(6D12.4/)) 350 FORMAT(44H THE MAXIMUM NUMBER OF SUBINTERVALS IS MIN (, I4, 1 23H (ALLOWED FROM FSPACE),,I4, 24H (ALLOWED FROM ISPACE) )) 360 FORMAT(/53H INSUFFICIENT SPACE TO DOUBLE MESH FOR ERROR ESTIMATE) END C C....................................................................... C SUBROUTINE CONTRL(XI, XIOLD, XIJ, ALPHA, ALDIF, RHS, 1 DALPHA, EALPHA, A, VALSTR, SLOPE, 2 ACCUM, IPIV, INTEGS, NFXPNT, FIXPNT, IFLAG, 3 FSUB, DFSUB, GSUB, DGSUB, SOLUTN) C C********************************************************************** C C PURPOSE C THIS SUBROUTINE IS THE ACTUAL DRIVER. THE NONLINEAR ITERATION C STRATEGY IS CONTROLLED HERE ( SEE (2) ). UPON CONVERGENCE, ERRCHK C IS CALLED TO TEST FOR SATISFACTION OF THE REQUESTED TOLERANCES. C C VARIABLES C C CHECK - MAXIMUM TOLERANCE VALUE, USED AS PART OF CRITERIA FOR C CHECKING FOR NONLINEAR ITERATION CONVERGENCE C RELAX - THE RELAXATION FACTOR FOR DAMPED NEWTON ITERATION C RELMIN - MINIMUM ALLOWABLE VALUE FOR RELAX (OTHERWISE THE C JACOBIAN IS CONSIDERED SINGULAR). C RLXOLD - PREVIOUS RELAX C RSTART - INITIAL VALUE FOR RELAX WHEN PROBLEM IS SENSITIVE C IFRZ - NUMBER OF FIXED JACOBIAN ITERATIONS C LMTFRZ - MAXIMUM VALUE FOR IFRZ BEFORE PERFORMING A REINVERSION C ITER - NUMBER OF ITERATIONS (COUNTED ONLY WHEN JACOBIAN C REINVERSIONS ARE PERFORMED). C XI - CURRENT MESH C XIOLD - PREVIOUS MESH C IPRED = 0 IF RELAX IS DETERMINED BY A CORRECTION C = 1 IF RELAX IS DETERMINED BY A PREDICTION C IFREEZ = 0 IF THE JACOBIAN IS TO BE INVERTED C = 1 IF THE JACOBIAN IS CURRENTLY FIXED (FROZEN) C ICON = 0 IF NO PREVIOUS CONVERGENCE HAS BEEN OBTAINED C = 1 IF CONVERGENCE ON A PREVIOUS MESH HAS BEEN OBTAINED C ICARE =-1 NO CONVERGENCE OCCURRED (USED FOR REGULAR PROBLEMS) C = 0 A REGULAR PROBLEM C = 1 A SENSITIVE PROBLEM C = 2 USED FOR CONTINUATION (SEE DESCRIPTION OF IPAR(10) C IN COLSYS). C RNORM - NORM OF RHS (RIGHT HAND SIDE) FOR CURRENT ITERATION C RNOLD - NORM OF RHS FOR PREVIOUS ITERATION C ANSCL - SCALED NORM OF NEWTON CORRECTION C ANFIX - SCALED NORM OF NEWTON CORRECTION AT NEXT STEP C ANORM - SCALED NORM OF A CORRECTION OBTAINED WITH JACOBIAN FIXED C NALDIF - NUMBER OF COMPONENTS OF ALDIF (SEE SUBROUTINE APPROX) C IMESH - A CONTROL VARIABLE FOR SUBROUTINES NEWMSH AND ERRCHK C C*********************************************************************** C IMPLICIT REAL*8 (A-H,O-Z) EXTERNAL FSUB, DFSUB, GSUB, DGSUB, SOLUTN DIMENSION XI(1), XIOLD(1), XIJ(1), ALPHA(1), ALDIF(1), RHS(1) DIMENSION A(1), VALSTR(1), SLOPE(1), ACCUM(1), IPIV(1), INTEGS(1) DIMENSION DALPHA(1), EALPHA(1) , FIXPNT(1) COMMON /ORDER/ K,NCOMP,MSTAR,KD,KDM,MNSUM,M(20) COMMON /APPR/ N,NOLD,NMAX,NALPHA,MSHFLG,MSHNUM,MSHLMT,MSHALT COMMON /SIDE/ ZETA(40),ALEFT,ARIGHT,IZETA,IWR COMMON /NONLN/ PRECIS,NONLIN,ITER,LIMIT,ICARE,IPRINT,IGUESS,IFREEZ COMMON /EQORD/ IND(5), INEQ(20), MND(5), ND, NEQ COMMON /ERRORS/ TOL(40),WGTMSH(40),TOLIN(40),ROOT(40), 1 JTOL(40),LTOL(40),NTOL C C... CONSTANTS FOR CONTROL OF NONLINEAR ITERATION C RELMIN = 1.D-3 RSTART = 1.D-2 LMTFRZ = 4 C C... COMPUTE THE MAXIMUM TOLERANCE C CHECK = 0.D0 DO 10 I=1,NTOL 10 CHECK = DMAX1 (TOLIN(I), CHECK ) FALPHA = DFLOAT(NALPHA) IMESH = 1 ICON = 0 IF (NONLIN .EQ. 0) ICON=1 ICOR = 0 LCONV = 0 C C... THE MAIN ITERATION BEGINS HERE C... LOOP 20 IS EXECUTED UNTIL ERROR TOLERANCES ARE SATISFIED OR C... THE CODE FAILS (DUE TO A SINGULAR MATRIX OR STORAGE LIMITATIONS) C 20 CONTINUE C C... INITIALIZATION FOR A NEW MESH C ITER = 0 NALDIF = N * K * MSTAR + MNSUM IF (NONLIN .GT. 0) GO TO 60 C C... THE LINEAR CASE. C... SET UP AND SOLVE EQUATIONS C CALL LSYSLV (IFLAG, XI, XIOLD, XIJ, ALPHA, ALDIF, RHS, 1 EALPHA, A, IPIV, INTEGS, RNORM, 0, FSUB, 2 DFSUB, GSUB, DGSUB, SOLUTN) C C... CHECK FOR A SINGULAR MATRIX C IF (IFLAG .NE. 0) GO TO 40 30 IF (IPRINT .LT. 1) WRITE (IWR,490 ) RETURN C C... UPDATE THE OLD MESH C 40 NP1 = N + 1 DO 50 I=1,NP1 50 XIOLD(I) = XI(I) NOLD = N C C... PREPARE TABLE OF DIVIDED DIFFERENCES AND CALL ERRCHK C CALL APPDIF (ALDIF, ALPHA, XI, N, K, NCOMP, M, MSTAR) GO TO 450 C C... ITERATION LOOP FOR NONLINEAR CASE C... DEFINE THE INITIAL RELAXATION PARAMETER (= RELAX) C 60 RELAX = 1.D0 C C... CHECK FOR PREVIOUS CONVERGENCE AND PROBLEM SENSITIVITY C IF (ICARE .EQ. 1 .OR. ICARE .EQ. (-1)) RELAX = RSTART IF (ICON .EQ. 0) GO TO 140 C C... CONVERGENCE ON A PREVIOUS MESH HAS BEEN OBTAINED. THUS C... WE HAVE A VERY GOOD INITIAL APPROXIMATION FOR THE NEWTON C... PROCESS. PROCEED WITH ONE FULL NEWTON AND THEN ITERATE C... WITH A FIXED JACOBIAN. C IFREEZ = 0 C C... EVALUATE RIGHT HAND SIDE AND ITS NORM C CALL LSYSLV (IFLAG, XI, XIOLD, XIJ, DALPHA, ALDIF, RHS, 1 ALPHA, A, IPIV, INTEGS, RNORM, 1, FSUB, 2 DFSUB, GSUB, DGSUB, SOLUTN) C C... SOLVE FOR THE NEXT ITERATE . C... THE VALUE OF IFREEZ DETERMINES WHETHER THIS IS A FULL C... NEWTON STEP (=0) OR A FIXED JACOBIAN ITERATION (=1). C IF (IPRINT .LT. 0 .AND. ITER .EQ. 0) WRITE(IWR,530) 70 IF (IPRINT .LT. 0) WRITE (IWR,510) ITER, RNORM RNOLD = RNORM CALL LSYSLV (IFLAG, XI, XIOLD, XIJ, DALPHA, ALDIF, RHS, 1 ALPHA, A, IPIV, INTEGS, RNORM, 2+IFREEZ , 2 FSUB, DFSUB, GSUB, DGSUB, SOLUTN) C C... CHECK FOR A SINGULAR MATRIX C IF (IFLAG .EQ. 0) GO TO 30 IF (IFREEZ .EQ. 1) GO TO 90 C C... A FULL NEWTON STEP C ITER = ITER + 1 IFRZ = 0 C C... UPDATE THE OLD MESH. C NP1 = N + 1 DO 80 I=1,NP1 80 XIOLD(I) = XI(I) NOLD = N 90 CONTINUE C C... UPDATE ALPHA , COMPUTE NEW RHS AND ITS NORM C DO 100 I=1,NALPHA 100 ALPHA(I) = ALPHA(I) + DALPHA(I) CALL APPDIF (ALDIF, ALPHA, XI, N, K, NCOMP, M, MSTAR) CALL LSYSLV (IFLAG, XI, XIOLD, XIJ, DALPHA, ALDIF, RHS, 1 ALPHA, A, IPIV, INTEGS, RNORM, 1, FSUB, 2 DFSUB, GSUB, DGSUB, SOLUTN) C C... CHECK MONOTONICITY. IF THE NORM OF RHS GETS SMALLER, C... PROCEED WITH A FIXED JACOBIAN; ELSE PROCEED CAUTIOUSLY, C... AS IF CONVERGENCE HAS NOT BEEN OBTAINED BEFORE (ICON=0). C IF (RNORM .LT. PRECIS) GO TO 405 IF (RNORM .LE. RNOLD) GO TO 120 IF (IPRINT .LT. 0) WRITE (IWR,510) ITER, RNORM IF (IPRINT .LT. 0) WRITE (IWR,540) ICON = 0 RELAX = RSTART DO 110 I=1,NALPHA 110 ALPHA(I) = ALPHA(I) - DALPHA(I) CALL APPDIF (ALDIF, ALPHA, XI, N, K, NCOMP, M, MSTAR) ITER = 0 GO TO 140 120 IF (IFREEZ .EQ. 1) GO TO 130 IFREEZ = 1 GO TO 70 C C... VERIFY THAT THE LINEAR CONVERGENCE WITH FIXED JACOBIAN C... IS FAST ENOUGH. C 130 IFRZ = IFRZ + 1 IF (IFRZ .GE. LMTFRZ) IFREEZ = 0 IF (RNOLD .LT. 4.D0*RNORM) IFREEZ = 0 GO TO 300 C C... NO PREVIOUS CONVERGENCE HAS BEEN OBTAINED. PROCEED C... WITH THE MODIFIED NEWTON METHOD. C... EVALUATE RHS. C 140 IF(IPRINT .LT. 0) WRITE (IWR,500) CALL LSYSLV (IFLAG, XI, XIOLD, XIJ, DALPHA, ALDIF, RHS, 1 ALPHA, A, IPIV, INTEGS, RNORM, 1, FSUB, 2 DFSUB, GSUB, DGSUB, SOLUTN) C C... FIND A NEWTON DIRECTION C 150 RNOLD = RNORM IF (ITER .GE. LIMIT) GO TO 420 CALL LSYSLV (IFLAG, XI, XIOLD, XIJ, DALPHA, ALDIF, RHS, 1 ALPHA, A, IPIV, INTEGS, RNORM, 2, FSUB, 2 DFSUB, GSUB, DGSUB, SOLUTN) C C... CHECK FOR A SINGULAR MATRIX C IF (IFLAG .EQ. 0) GO TO 30 IF (ITER .GT. 0) GO TO 170 C C... BOOKKEEPING FOR FIRST MESH C IF ( IGUESS .EQ. 1) IGUESS = 0 C C... UPDATE THE OLD MESH C NP1 = N + 1 DO 160 I=1,NP1 160 XIOLD(I) = XI(I) NOLD = N GO TO 190 170 CONTINUE C C... PREDICT RELAXATION FACTOR FOR NEWTON STEP. C ANDIF = 0.D0 DO 180 I=1,NALPHA 180 ANDIF = ANDIF + (EALPHA(I) - DALPHA(I))**2 1 / (ALPHA(I)*ALPHA(I) + PRECIS) RELAX = RELAX * ANSCL / DMAX1( DSQRT(ANDIF/FALPHA), 1 PRECIS) IF (RELAX .GT. 1.D0) RELAX = 1.D0 190 RLXOLD = RELAX IPRED = 1 ITER = ITER + 1 C C... DETERMINE A NEW ALPHA AND FIND NEW RHS AND ITS NORM C DO 200 I=1,NALPHA 200 ALPHA(I) = ALPHA(I) + RELAX * DALPHA(I) 210 CALL APPDIF (ALDIF, ALPHA, XI, N, K, NCOMP, M, MSTAR) CALL LSYSLV (IFLAG, XI, XIOLD, XIJ, DALPHA, ALDIF, RHS, 1 ALPHA, A, IPIV, INTEGS, RNORM, 1, FSUB, 2 DFSUB, GSUB, DGSUB, SOLUTN) C C... COMPUTE A FIXED JACOBIAN ITERATE (USED TO CONTROL RELAX) C CALL LSYSLV (IFLAG, XI, XIOLD, XIJ, EALPHA, ALDIF, RHS, 1 ALPHA, A, IPIV, INTEGS, RNORM, 3, FSUB, 2 DFSUB, GSUB, DGSUB, SOLUTN) C C... FIND SCALED NORMS OF VARIOUS TERMS USED TO CORRECT RELAX C ANORM = 0.D0 ANFIX = 0.D0 ANSCL = 0.D0 DO 220 I=1,NALPHA ANSCL = ANSCL + DALPHA(I) * DALPHA(I) / 1 (ALPHA(I)*ALPHA(I) + PRECIS) SCALE = ALPHA(I) - RELAX*DALPHA(I) SCALE = 1.D0 / (SCALE*SCALE + PRECIS) ANORM = ANORM + DALPHA(I) * DALPHA(I) * SCALE 220 ANFIX = ANFIX + EALPHA(I) * EALPHA(I) * SCALE ANORM = DSQRT(ANORM / FALPHA) ANFIX = DSQRT(ANFIX / FALPHA) ANSCL = DSQRT(ANSCL / FALPHA) IF (ICOR .EQ. 1) GO TO 230 IF (IPRINT .LT. 0) WRITE (IWR,520) ITER, RELAX, ANORM, 1 ANFIX, RNOLD, RNORM GO TO 240 230 IF (IPRINT .LT. 0) WRITE (IWR,550) RELAX, ANORM, ANFIX, 1 RNOLD, RNORM 240 ICOR = 0 C C... CHECK FOR MONOTONIC DECREASE IN DALPHA. C IF (ANFIX.LT.PRECIS .OR. RNORM.LT.PRECIS)GO TO 405 IF (ANFIX .GT. ANORM) GO TO 250 C C... WE HAVE A DECREASE. IF EALPHA SMALL, CHECK CONVERGENCE C IF (ANFIX .LE. CHECK) GO TO 290 C C... CORRECT THE PREDICTED RELAX UNLESS THE CORRECTED C... VALUE IS WITHIN 10 PERCENT OF THE PREDICTED ONE. C IF (IPRED .NE. 1) GO TO 150 250 IF (ITER .GE. LIMIT) GO TO 420 C C... CORRECT THE RELAXATION FACTOR. C IPRED = 0 ARG = (ANFIX/ANORM - 1.D0) / RELAX + 1.D0 IF (ARG .LT. 0.D0) GO TO 150 IF (ARG .LE. .25D0*RELAX+.125D0*RELAX**2 ) GO TO 260 FACTOR = -1.D0 + DSQRT (1.D0+8.D0 * ARG) IF ( DABS(FACTOR-1.D0) .LT. .1D0*FACTOR ) GO TO 150 RELAX = RELAX / FACTOR GO TO 270 260 IF (RELAX .GE. .9D0) GO TO 150 RELAX = 1.D0 270 ICOR = 1 IF (RELAX .LT. RELMIN) GO TO 430 DO 280 I=1,NALPHA 280 ALPHA(I) = ALPHA(I) + (RELAX-RLXOLD) * DALPHA(I) RLXOLD = RELAX GO TO 210 C C... CHECK CONVERGENCE. C... COMPUTE DIVIDED DIFFERENCE TABLES FOR CORRECTION TERMS. C 290 CALL APPDIF (A, EALPHA, XI, N, K, NCOMP, M, MSTAR) GO TO 310 C C... IF ICON = 1 THEN ALSO SAVE A. C 300 CALL APPDIF (EALPHA, DALPHA, XI, N, K, NCOMP, M, MSTAR) 310 CONTINUE INN = 0 JCOL = 0 JINIT = 1 DO 380 I = 1, NTOL JEND = JTOL(I) - 1 IF (JEND .LT. JINIT) GO TO 330 DO 320 J = JINIT, JEND MJ = M(J) NALPHJ = N * K + MJ JCOL = JCOL + MJ INN = INN + MJ * NALPHJ 320 CONTINUE 330 JINIT = JEND + 1 NALPHJ = N * K + M(JINIT) INN1 = INN JCOL1 = JCOL + 1 340 IF (JCOL1 .EQ. LTOL(I)) GO TO 350 INN1 = INN1 + NALPHJ JCOL1 = JCOL1 + 1 GO TO 340 350 IINIT = JCOL1 - JCOL C C... CHECK THAT TOLERANCES ARE SATISFIED FOR B-SPLINE COEFFS. C DO 370 II = IINIT, NALPHJ IN = INN1 + II IF (ICON .EQ. 1) GO TO 360 IF (DABS(A(IN)) .GT. TOLIN(I) * 1 (DABS(ALDIF(IN)) +1.D0)) GO TO 410 GO TO 370 360 IF (DABS(EALPHA(IN)) .GT. TOLIN(I) * 1 (DABS(ALDIF(IN)) + 1.D0)) GO TO 410 370 CONTINUE 380 CONTINUE C C... CONVERGENCE OBTAINED C IF (IPRINT .LT. 1) WRITE (IWR,560) ITER IF (ICON .EQ. 1) GO TO 450 C C... SINCE CONVERGENCE OBTAINED, UPDATE COEFFS WITH TERM FROM C... THE FIXED JACOBIAN ITERATION. C DO 390 I=1,NALDIF 390 ALDIF(I) = ALDIF(I) + A(I) DO 400 I=1,NALPHA 400 ALPHA(I) = ALPHA(I) + EALPHA(I) 405 IF ((ANFIX.LT.PRECIS.OR.RNORM.LT.PRECIS).AND.IPRINT.LT.1) 1 WRITE (IWR,560) ITER ICON = 1 IF (ICARE .EQ. (-1)) ICARE = 0 GO TO 450 C C... NO CONVERGENCE. REPEAT C 410 IF ( ICON .EQ. 0) GO TO 150 GO TO 70 C C... DIAGNOSTICS FOR FAILURE OF NONLINEAR ITERATION. C 420 IF(IPRINT .LT. 1) WRITE (IWR,570) ITER GO TO 440 430 IF(IPRINT .LT. 1) WRITE(IWR,580) RELAX, RELMIN 440 IFLAG = -2 LCONV = LCONV + 1 IF (ICARE .EQ. 2 .AND. LCONV .GT. 1) RETURN IF (ICARE .EQ. 0) ICARE = -1 GO TO 460 C C... CHECK FOR ERROR TOLERANCE SATISFACTION C 450 CALL ERRCHK(IMESH,XIOLD,ALDIF,VALSTR,A,MSTAR,IFIN) IF (IMESH .EQ. 1 .OR. IFIN .EQ. 0 .AND. 1 ICARE .NE. 2) GO TO 460 IFLAG = 1 RETURN C C... PICK A NEW MESH C... CHECK SAFEGUARDS FOR MESH REFINEMENT C 460 IMESH = 1 IF (ICON .EQ. 0 .OR. MSHNUM .GE. MSHLMT 1 .OR. MSHALT .GE. MSHLMT) IMESH = 2 IF (MSHALT .GE. MSHLMT .AND. MSHNUM .LT. MSHLMT) 1 MSHALT = 1 CALL NEWMSH(IMESH, XI, XIOLD, XIJ, ALDIF, VALSTR, 1 SLOPE, ACCUM, NFXPNT, FIXPNT) C C... EXIT IF EXPECTED N IS TOO LARGE (BUT MAY TRY N=NMAX ONCE) C IF (N .LE. NMAX) GO TO 470 N = N / 2 IFLAG = -1 IF (ICON .EQ. 0 .AND. IPRINT .LT. 1) WRITE (IWR,590) IF (ICON .EQ. 1 .AND. IPRINT .LT. 1) WRITE (IWR,600) RETURN 470 IF (ICON .EQ. 0) IMESH = 1 IF (ICARE .EQ. 1) ICON = 0 GO TO 20 C --------------------------------------------------------------- 490 FORMAT(//24H THE MATRIX IS SINGULAR ) 500 FORMAT(/30H FULL DAMPED NEWTON ITERATION,) 510 FORMAT(13H ITERATION = , I3, 15H NORM (RHS) = , D10.2) 520 FORMAT(13H ITERATION = ,I3,22H RELAXATION FACTOR = ,D10.2 1 /33H NORM OF SCALED RHS CHANGES FROM ,D10.2,3H TO,D10.2 2 /33H NORM OF RHS CHANGES FROM ,D10.2,3H TO,D10.2) 530 FORMAT(/27H FIXED JACOBIAN ITERATIONS,) 540 FORMAT(/35H SWITCH TO DAMPED NEWTON ITERATION,) 550 FORMAT(40H RELAXATION FACTOR CORRECTED TO RELAX = , D10.2 1 /33H NORM OF SCALED RHS CHANGES FROM ,D10.2,3H TO,D10.2 2 /33H NORM OF RHS CHANGES FROM ,D10.2,3H TO,D10.2) 560 FORMAT(/18H CONVERGENCE AFTER , I3,11H ITERATIONS /) 570 FORMAT(/22H NO CONVERGENCE AFTER , I3, 11H ITERATIONS/) 580 FORMAT(/37H NO CONVERGENCE. RELAXATION FACTOR =,D10.3 1 ,24H IS TOO SMALL (LESS THAN, D10.3, 1H)/) 590 FORMAT(18H (NO CONVERGENCE) ) 600 FORMAT(50H (PROBABLY TOLERANCES TOO STRINGENT, OR NMAX TOO 1 ,6HSMALL) ) END C----------------------------------------------------------------------- C P A R T 2 C MESH SELECTION, ERROR ESTIMATION, (AND RELATED C CONSTANT ASSIGNMENT) ROUTINES -- SEE (1), (2), (5) C----------------------------------------------------------------------- C SUBROUTINE NEWMSH (MODE, XI, XIOLD, XIJ, ALDIF, VALSTR, 1 SLOPE, ACCUM, NFXPNT, FIXPNT) C C*********************************************************************** C C PURPOSE C SELECT A MESH ON WHICH A COLLOCATION SOLUTION IS TO BE C DETERMINED C C THERE ARE 5 POSSIBLE MODES OF ACTION: C MODE = 5,4,3 - DEAL MAINLY WITH DEFINITION OF AN INITIAL C MESH FOR THE CURRENT BOUNDARY VALUE PROBLEM C = 2,1 - DEAL WITH DEFINITION OF A NEW MESH, EITHER C BY SIMPLE MESH HALVING OR BY MESH SELECTION C MORE SPECIFICALLY, FOR C MODE = 5 AN INITIAL (GENERALLY NONUNIFORM) MESH IS C DEFINED BY THE USER AND NO MESH SELECTION IS TO C BE PERFORMED C = 4 AN INITIAL (GENERALLY NONUNIFORM) MESH IS C DEFINED BY THE USER C = 3 A SIMPLE UNIFORM MESH (EXCEPT POSSIBLY FOR SOME C FIXED POINTS) IS DEFINED; N= NO. OF SUBINTERVALS C = 1 THE AUTOMATIC MESH SELECTION PROCEDURE IS USED C (SEE (1) AND (5) FOR DETAILS) C = 2 A SIMPLE MESH HALVING IS PERFORMED C C*********************************************************************** C C VARIABLES C C N = NUMBER OF MESH SUBINTERVALS C NOLD = NUMBER OF SUBINTERVALS FOR FORMER MESH C XI - MESH POINT ARRAY C XIOLD - FORMER MESH POINT ARRAY C MSHLMT - MAXIMUM NO. OF MESH SELECTIONS WHICH ARE PERMITTED C FOR A GIVEN N BEFORE MESH HALVING C MSHNUM - NO. OF MESH SELECTIONS WHICH HAVE ACTUALLY BEEN C PERFORMED FOR THE GIVEN N C MSHALT - NO. OF CONSECUTIVE TIMES ( PLUS 1 ) THE MESH C SELECTION HAS ALTERNATELY HALVED AND DOUBLED N. C IF MSHALT .GE. MSHLMT THEN CONTRL REQUIRES C THAT THE CURRENT MESH BE HALVED. C MSHFLG = 1 THE MESH IS A HALVING OF ITS FORMER MESH C (SO AN ERROR ESTIMATE HAS BEEN CALCULATED) C = 0 OTHERWISE C IGUESS - IPAR(9) IN SUBROUTINE COLSYS. IT IS USED C HERE ONLY FOR MODE=5 AND 4, WHERE C = 2 THE SUBROUTINE SETS XI=XIOLD. THIS IS C USED E.G. IF CONTINUATION IS BEING PER- C FORMED, AND A MESH FOR THE OLD DIFFEREN- C TIAL EQUATION IS BEING USED C = 3 SAME AS FOR =2, EXCEPT XI USES EVERY OTHER C POINT OF XIOLD (SO MESH XIOLD IS MESH XI C HALVED) C = 4 XI HAS BEEN DEFINED BY THE USER, AND AN OLD C MESH XIOLD IS ALSO AVAILABLE C OTHERWISE, XI HAS BEEN DEFINED BY THE USER C AND WE SET XIOLD=XI IN THIS SUBROUTINE C SLOPE - AN APPROXIMATE QUANTITY TO BE EQUIDISTRIBUTED FOR C MESH SELECTION (SEE (1)), VIZ, C . (K+MJ) C SLOPE(I)= MAX (WEIGHT(L) *U (XI(I))) C 1.LE.L.LE.NTOL J C C WHERE J=JTOL(L) C SLPHMX - MAXIMUM OF SLOPE(I)*(XIOLD(I+1)-XIOLD(I)) FOR C I = 1 ,..., NOLD. C ACCUM - ACCUM(I) IS THE INTEGRAL OF SLOPE FROM ALEFT C TO XIOLD(I). C VALSTR - IS ASSIGNED VALUES NEEDED IN ERRCHK FOR THE C ERROR ESTIMATE. C*********************************************************************** C IMPLICIT REAL*8 (A-H,O-Z) COMMON /ORDER/K,NCOMP,MSTAR,KD,KDM,MNSUM,M(20) COMMON /APPR/ N,NOLD,NMAX,NALPHA,MSHFLG,MSHNUM,MSHLMT,MSHALT COMMON /ERRORS/ TOL(40),WGTMSH(40),TOLIN(40),ROOT(40), 1 JTOL(40),LTOL(40),NTOL COMMON /COLLOC/ RHO(7),WGTERR(40) COMMON /SIDE/ ZETA(40), ALEFT, ARIGHT, IZETA, IWR COMMON /NONLN/ PRECIS,NONLIN,ITER,LIMIT,ICARE,IPRINT,IGUESS,IFREEZ COMMON /BSPLIN/ VNCOL(66,7), VNSAVE(66,5), VN(66) DIMENSION D1(40), D2(40), ZV(40), SLOPE(1), ACCUM(1), VALSTR(1) DIMENSION XI(1), XIOLD(1), XIJ(1), ALDIF(1), FIXPNT(1) C NOLDP1 = NOLD + 1 NFXP1 = NFXPNT +1 GO TO (180, 100, 50, 20, 10), MODE C C... MODE=5 SET MSHLMT=1 SO THAT NO MESH SELECTION IS PERFORMED C 10 MSHLMT = 1 C C... MODE=4 THE USER-SPECIFIED INITIAL MESH IS ALREADY IN PLACE. C 20 IF (IGUESS .LT. 2) GO TO 40 C C... IGUESS=2, 3 OR 4. C IF (IPRINT .LT. 1) WRITE(IWR,360) NOLD, (XIOLD(I), I=1,NOLDP1) IF (IGUESS .NE. 3) GO TO 40 C C... IF IREAD ( IPAR(8) ) .GE. 1 AND IGUESS ( IPAR(9) ) C... .EQ. 3 THEN THE FIRST MESH IS EVERY SECOND POINT OF THE C... MESH IN XIOLD . C N = NOLD /2 I = 0 DO 30 J = 1, NOLD, 2 I = I + 1 30 XI(I) = XIOLD(J) 40 CONTINUE NP1 = N + 1 XI(1) = ALEFT XI(NP1) = ARIGHT GO TO 320 C C... MODE=3 GENERATE A (PIECEWISE) UNIFORM MESH. IF THERE ARE C... FIXED POINTS THEN ENSURE THAT THE N BEING USED IS LARGE ENOUGH. C 50 IF ( N .LT. NFXP1 ) N = NFXP1 NP1 = N + 1 XI(1) = ALEFT ILEFT = 1 XLEFT = ALEFT C C... LOOP OVER THE SUBREGIONS BETWEEN FIXED POINTS. C DO 90 J = 1,NFXP1 XRIGHT = ARIGHT IRIGHT = NP1 IF ( J .EQ. NFXP1 ) GO TO 60 XRIGHT = FIXPNT(J) C C... DETERMINE WHERE THE J-TH FIXED POINT SHOULD FALL IN THE C... NEW MESH - THIS IS XI(IRIGHT) AND THE (J-1)ST FIXED C... POINT IS IN XI(ILEFT) C NMIN = (XRIGHT-ALEFT) / (ARIGHT-ALEFT) * DFLOAT(N) + 1.5D0 IF (NMIN .GT. N-NFXPNT+J) NMIN = N - NFXPNT + J IRIGHT = MAX0 (ILEFT+1, NMIN) 60 XI(IRIGHT) = XRIGHT C C... GENERATE EQUALLY SPACED POINTS BETWEEN THE J-1ST AND THE C... J-TH FIXED POINTS. C NREGN = IRIGHT - ILEFT - 1 IF ( NREGN .EQ. 0 ) GO TO 80 DX = (XRIGHT - XLEFT) / DFLOAT(NREGN+1) DO 70 I = 1,NREGN 70 XI(ILEFT+I) = XLEFT + DFLOAT(I) * DX 80 ILEFT = IRIGHT XLEFT = XRIGHT 90 CONTINUE GO TO 320 C C... MODE=2 HALVE THE CURRENT MESH (I.E. DOUBLE ITS SIZE) C 100 N2 = 2 * N C C... CHECK THAT N DOES NOT EXCEED STORAGE LIMITATIONS C IF (N2 .LE. NMAX) GO TO 120 C C... IF POSSIBLE, TRY WITH N=NMAX. REDISTRIBUTE FIRST. C IF (MODE .EQ. 2) GO TO 110 N = NMAX / 2 GO TO 220 110 IF (IPRINT .LT. 1) WRITE(IWR,370) N = N2 RETURN C C... CALCULATE THE OLD APPROXIMATE SOLUTION VALUES AT C... POINTS TO BE USED IN ERRCHK FOR ERROR ESTIMATES. C... IF MSHFLG =1 AN ERROR ESTIMATE WAS OBTAINED FOR C... FOR THE OLD APPROXIMATION SO HALF THE NEEDED VALUES C... WILL ALREADY BE IN VALSTR . C 120 IF (MSHFLG .EQ. 0) GO TO 140 C C... SAVE IN VALSTR THE VALUES OF THE OLD SOLUTION C... AT THE RELATIVE POSITIONS 1/6 AND 5/6 IN EACH SUBINTERVAL. C KSTORE = 1 DO 130 I = 1,NOLD HD6 = (XIOLD(I+1) - XIOLD(I)) / 6.D0 X = XIOLD(I) + HD6 CALL APPROX (I, X, VALSTR(KSTORE), VNSAVE(1,2), XIOLD, 1 NOLD, ALDIF, K, NCOMP, M, MSTAR, 3,DUMM,0) X = X + 4.D0 * HD6 KSTORE = KSTORE + 3 * MSTAR CALL APPROX (I, X, VALSTR(KSTORE), VNSAVE(1,5), 1 XIOLD, NOLD, ALDIF, K, NCOMP, M, MSTAR, 3,DUMM,0) KSTORE = KSTORE + MSTAR 130 CONTINUE GO TO 160 C C... SAVE IN VALSTR THE VALUES OF THE OLD SOLUTION C... AT THE RELATIVE POSITIONS 1/6, 2/6, 4/6 AND 5/6 IN C... EACH SUBINTERVAL. C 140 KSTORE = 1 DO 150 I = 1,N X = XI(I) HD6 = (XI(I+1) - XI(I)) / 6.D0 DO 150 J = 1,4 X = X + HD6 IF ( J.EQ.3 ) X = X + HD6 CALL APPROX (I, X, VALSTR(KSTORE), VNSAVE(1,J+1), 1 XIOLD, NOLD, ALDIF, K, NCOMP, M, MSTAR, 3, 2 DUMM,0) KSTORE = KSTORE + MSTAR 150 CONTINUE 160 MSHFLG = 0 MSHNUM = 1 MODE = 2 C C... GENERATE THE HALVED MESH. C J = 2 DO 170 I = 1,N XI(J) = (XIOLD(I) + XIOLD(I+1)) / 2.D0 XI(J+1) = XIOLD(I+1) 170 J = J + 2 N = N2 GO TO 320 C C... MODE=1 WE DO MESH SELECTION IF IT IS DEEMED WORTHWHILE C 180 IF ( NOLD .EQ. 1 ) GO TO 100 IF (NOLD .LE. 2*NFXPNT) GO TO 100 C C... THE FIRST INTERVAL HAS TO BE TREATED SEPARATELY FROM THE C... OTHER INTERVALS (GENERALLY THE SOLUTION ON THE (I-1)ST AND ITH C... INTERVALS WILL BE USED TO APPROXIMATE THE NEEDED DERIVATIVE, BUT C... HERE THE 1ST AND SECOND INTERVALS ARE USED.) C I = 1 CALL HORDER (1, D1, XIOLD, ALDIF) CALL HORDER (2, D2, XIOLD, ALDIF) CALL APPROX (I, XIOLD(I), ZV, VNSAVE(1,1), XIOLD, NOLD, 1 ALDIF, K, NCOMP, M, MSTAR, 3, DUMM, 0) ACCUM(1) = 0.D0 SLOPE(1) = 0.D0 ONEOVH = 2.D0 / ( XIOLD(3) - XIOLD(1) ) DO 190 J = 1,NTOL JJ = JTOL(J) JV = LTOL(J) 190 SLOPE(1) = DMAX1(SLOPE(1),(DABS(D2(JJ)-D1(JJ))*WGTMSH(J)* 1ONEOVH / (1.D0 + DABS(ZV(JV)))) **ROOT(J)) SLPHMX = SLOPE(1) * (XIOLD(2) - XIOLD(1)) ACCUM(2) = SLPHMX IFLIP = 1 C C... GO THROUGH THE REMAINING INTERVALS GENERATING SLOPE C... AND ACCUM . C DO 210 I = 2,NOLD IF ( IFLIP .EQ. (-1) ) CALL HORDER ( I, D1, XIOLD, ALDIF) IF ( IFLIP .EQ. 1 ) CALL HORDER ( I, D2, XIOLD, ALDIF) CALL APPROX (I, XIOLD(I), ZV, VNSAVE(1,1), XIOLD, NOLD, 1 ALDIF, K, NCOMP, M, MSTAR, 3, DUMM, 0) ONEOVH = 2.D0 / ( XIOLD(I+1) - XIOLD(I-1) ) SLOPE(I) = 0.D0 C C... EVALUATE FUNCTION TO BE EQUIDISTRIBUTED C DO 200 J = 1,NTOL JJ = JTOL(J) JV = LTOL(J) 200 SLOPE(I) = DMAX1(SLOPE(I),(DABS(D2(JJ)-D1(JJ))*WGTMSH(J)* 1 ONEOVH / (1.D0 + DABS(ZV(JV)))) **ROOT(J)) C C... ACCUMULATE APPROXIMATE INTEGRAL OF FUNCTION TO BE C... EQUIDISTRIBUTED C TEMP = SLOPE(I) * (XIOLD(I+1)-XIOLD(I)) SLPHMX = DMAX1(SLPHMX,TEMP) ACCUM(I+1) = ACCUM(I) + TEMP 210 IFLIP = - IFLIP AVRG = ACCUM(NOLD+1) / DFLOAT(NOLD) DEGEQU = AVRG / DMAX1(SLPHMX,PRECIS) C C... NACCUM=EXPECTED N TO ACHIEVE .1X USER REQUESTED TOLERANCES C NACCUM = ACCUM(NOLD+1) + 1.D0 IF (IPRINT .LT. 0) WRITE(IWR,350) DEGEQU, NACCUM C C... DECIDE IF MESH SELECTION IS WORTHWHILE (OTHERWISE, HALVE) C IF (AVRG .LT. PRECIS) GO TO 100 IF (DEGEQU .GE. .5D0) GO TO 100 C C... NMX ASSURES MESH HAS AT LEAST HALF AS MANY SUBINTERVALS AS THE C... PREVIOUS MESH C NMX = MAX0 (NOLD+1, NACCUM) / 2 C C... THIS ASSURES THAT HALVING WILL BE POSSIBLE LATER (FOR ERROR EST) C NMAX2 = NMAX / 2 C C... THE MESH IS AT MOST HALVED C N = MIN0 (NMAX2, NOLD, NMX) 220 NFXP1 = NFXPNT + 1 IF (N .LT. NFXP1) N=NFXP1 MSHNUM = MSHNUM + 1 C C... IF THE NEW MESH IS SMALLER THAN THE OLD MESH SET MSHNUM C... SO THAT THE NEXT CALL TO NEWMSH WILL PRODUCE A HALVED C... MESH. IF N .EQ. NOLD / 2 INCREMENT MSHALT SO THERE CAN NOT C... BE AN INFINITE LOOP ALTERNATING BETWEEN N AND N/2 POINTS. C IF (N .LT. NOLD) MSHNUM = MSHLMT IF (N .GT. NOLD/2) MSHALT = 1 IF (N .EQ. NOLD/2) MSHALT = MSHALT + 1 MSHFLG = 0 C C... HAVING DECIDED TO GENERATE A NEW MESH WITH N SUBINTERVALS WE NOW C... DO SO, TAKING INTO ACCOUNT THAT THE NFXPNT POINTS IN THE ARRAY C... FIXPNT MUST BE INCLUDED IN THE NEW MESH. C IN = 1 ACCL = 0.D0 LOLD =2 XI(1) = ALEFT XI(N+1) = ARIGHT DO 310 I = 1, NFXP1 IF (I .EQ. NFXP1) GO TO 250 DO 230 J = LOLD, NOLDP1 LNEW = J IF (FIXPNT(I) .LE. XIOLD(J)) GO TO 240 230 CONTINUE 240 CONTINUE ACCR = ACCUM(LNEW) + (FIXPNT(I)-XIOLD(LNEW))*SLOPE(LNEW-1) NREGN = (ACCR-ACCL) / ACCUM(NOLDP1) * DFLOAT(N) - .5D0 NREGN = MIN0(NREGN, N - IN - NFXP1 + I) XI(IN + NREGN + 1) = FIXPNT(I) GO TO 260 250 ACCR = ACCUM(NOLDP1) LNEW = NOLDP1 NREGN = N - IN 260 IF (NREGN .EQ. 0) GO TO 300 TEMP = ACCL TSUM = (ACCR - ACCL) / DFLOAT(NREGN+1) DO 290 J = 1, NREGN IN = IN + 1 TEMP = TEMP + TSUM DO 270 L = LOLD, LNEW LCARRY = L IF (TEMP .LE. ACCUM(L)) GO TO 280 270 CONTINUE 280 CONTINUE LOLD = LCARRY 290 XI(IN) = XIOLD(LOLD-1) + (TEMP - ACCUM(LOLD-1)) / 1 SLOPE(LOLD-1) 300 IN = IN + 1 ACCL = ACCR LOLD = LNEW 310 CONTINUE MODE = 1 320 CONTINUE C C... REGARDLESS OF HOW THE NEW MESH IS CHOSEN, THE NEW COLLOCATION C... POINTS XIJ IN (ALEFT,ARIGHT) ARE GENERATED HERE C K2 = 1 DO 330 I = 1,N H = (XI(I+1) - XI(I)) / 2.D0 XM = (XI(I+1) + XI(I)) / 2.D0 DO 330 J = 1,K XIJ(K2) = RHO(J) * H + XM K2 = K2 + 1 330 CONTINUE NP1 = N + 1 IF (IPRINT .LT. 1) WRITE(IWR,340) N, (XI(I),I=1,NP1) NALPHA = N * K * NCOMP + MSTAR RETURN C---------------------------------------------------------------- 340 FORMAT(/17H THE NEW MESH (OF,I5,16H SUBINTERVALS), ,100(/8F12.6)) 350 FORMAT(/21H MESH SELECTION INFO,/30H DEGREE OF EQUIDISTRIBUTION = 1 , F8.5, 28H PREDICTION FOR REQUIRED N = , I8) 360 FORMAT(/20H THE FORMER MESH (OF,I5,15H SUBINTERVALS),, 1 100(/8F12.6)) 370 FORMAT (/23H EXPECTED N TOO LARGE ) END C C....................................................................... C SUBROUTINE CONSTS C C*********************************************************************** C C PURPOSE C ASSIGN (ONCE) VALUES TO VARIOUS ARRAY CONSTANTS. C C ARRAYS ASSIGNED DURING COMPILATION: C CNSTS1 - WEIGHTS FOR EXTRAPOLATION ERROR ESTIMATE C CNSTS2 - WEIGHTS FOR MESH SELECTION C (THE ABOVE WEIGHTS COME FROM THE THEORETICAL FORM FOR C THE COLLOCATION ERROR -- SEE (5)) C C ARRAYS ASSIGNED DURING EXECUTION: C WGTERR - THE PARTICULAR VALUES OF CNSTS1 USED FOR CURRENT RUN C (DEPENDING ON K, M) C WGTMSH - GOTTEN FROM THE VALUES OF CNSTS2 WHICH IN TURN ARE C THE CONSTANTS IN THE THEORETICAL EXPRESSION FOR THE C ERRORS. THE QUANTITIES IN WGTMSH ARE 10X THE VALUES C IN CNSTS2 SO THAT THE MESH SELECTION ALGORITHM C IS AIMING FOR ERRORS .1X AS LARGE AS THE USER C REQUESTED TOLERANCES. C JTOL - COMPONENTS OF DIFFERENTIAL SYSTEM TO WHICH TOLERANCES C REFER (VIZ, IF LTOL(I) REFERS TO A DERIVATIVE OF U(J), C THEN JTOL(I)=J) C ROOT - RECIPROCALS OF EXPECTED RATES OF CONVERGENCE OF COMPO- C NENTS OF Z(J) FOR WHICH TOLERANCES ARE SPECIFIED C RHO - THE K COLLOCATION POINTS ON (-1,1) C VNCOL - THE MESH INDEPENDENT B-SPLINES VALUES AT COLLOCATION C POINTS C C*********************************************************************** C IMPLICIT REAL*8 (A-H,O-Z) COMMON /COLLOC/ RHO(7),WGTERR(40) COMMON /ORDER/ K,NCOMP,MSTAR,KD,KDM,MNSUM,M(20) COMMON /BSPLIN/ VNCOL(66,7), VNSAVE(66,5), VN(66) COMMON /ERRORS/ TOL(40),WGTMSH(40),TOLIN(40),ROOT(40), 1 JTOL(40),LTOL(40),NTOL COMMON /NONLN/ PRECIS,NONLIN,ITER,LIMIT,ICARE,IPRINT,IGUESS,IFREEZ DIMENSION CNSTS1(28), CNSTS2(28) DATA CNSTS1 / .25D0, .625D-1, .72169D-1, 1.8342D-2, 1 1.9065D-2, 5.8190D-2, 5.4658D-3, 5.3370D-3, 1.8890D-2, 2 2.7792D-2, 1.6095D-3, 1.4964D-3, 7.5938D-3, 5.7573D-3, 3 1.8342D-2, 4.673D-3, 4.150D-4, 1.919D-3, 1.468D-3, 4 6.371D-3, 4.610D-3, 1.342D-4, 1.138D-4, 4.889D-4, 5 4.177D-4, 1.374D-3, 1.654D-3, 2.863D-3 / DATA CNSTS2 / 1.25D-1, 2.604D-3, 8.019D-3, 2.170D-5, 1 7.453D-5, 5.208D-4, 9.689D-8, 3.689D-7, 3.100D-6, 2.451D-5, 2 2.691D-10, 1.120D-9, 1.076D-8, 9.405D-8, 1.033D-6, 3 5.097D-13, 2.290D-12, 2.446D-11, 2.331D-10, 2.936D-9, 4 3.593D-8, 7.001D-16, 3.363D-15, 3.921D-14, 4.028D-13, 5 5.646D-12, 7.531D-11, 1.129D-9 / C C... ASSIGN WEIGHTS FOR ERROR ESTIMATE C KOFF = K * ( K + 1 ) / 2 IEXTRA = 1 DO 10 J = 1,NCOMP LIM = M(J) DO 10 L = 1,LIM WGTERR(IEXTRA) = CNSTS1(KOFF - LIM + L) IEXTRA = IEXTRA + 1 10 CONTINUE C C... ASSIGN ARRAY VALUES FOR MESH SELECTION: WGTMSH, JTOL, AND ROOT C JCOMP = 1 MTOT = M(1) DO 40 I=1,NTOL LTOLI = LTOL(I) 20 CONTINUE IF (LTOLI .LE. MTOT) GO TO 30 JCOMP = JCOMP + 1 MTOT = MTOT + M(JCOMP) GO TO 20 30 CONTINUE JTOL(I) = JCOMP WGTMSH(I) = 1.D1 * CNSTS2(KOFF+LTOLI-MTOT) / TOLIN(I) ROOT(I) = 1.D0 / DFLOAT(K+MTOT-LTOLI+1) 40 CONTINUE C C... SPECIFY COLLOCATION POINTS C GO TO (50,60,70,80,90,100,110),K 50 RHO(1) = 0.D0 GO TO 120 60 RHO(2) = .57735026918962576451D0 RHO(1) = - RHO(2) GO TO 120 70 RHO(3) = .77459666924148337704D0 RHO(2) = .0D0 RHO(1) = - RHO(3) GO TO 120 80 RHO(1) = -.86113631159405257523D0 RHO(2) = -.33998104358485626480D0 RHO(3) = - RHO(2) RHO(4) = - RHO(1) GO TO 120 90 RHO(5) = .90617984593866399280D0 RHO(4) = .53846931010568309104D0 RHO(3) = .0D0 RHO(2) = - RHO(4) RHO(1) = - RHO(5) GO TO 120 100 RHO(6) = .93246951420315202781D0 RHO(5) = .66120938646626451366D0 RHO(4) = .23861918608319690863D0 RHO(3) = -RHO(4) RHO(2) = -RHO(5) RHO(1) = -RHO(6) GO TO 120 110 RHO(7) = .949107991234275852452D0 RHO(6) = .74153118559939443986D0 RHO(5) = .40584515137739716690D0 RHO(4) = 0.D0 RHO(3) = -RHO(5) RHO(2) = -RHO(6) RHO(1) = -RHO(7) 120 CONTINUE C C... PUT MESH INDEPENDENT B-SPLINES VALUES AT COLLOCATION POINT C... RHO(J) INTO VNCOL(*,J), J=1,...,K. C DO 130 J=1,K ARG = .5D0 * (1.D0 - RHO(J)) CALL BSPFIX (ARG, VNCOL(1,J), K, NCOMP, M) 130 CONTINUE C C... PUT MESH INDEPENDENT B-SPLINES VALUES AT THE POINTS IN UNIT IN- C... TERVAL 0, 1/6, 1/3, 2/3, 5/6 INTO VNSAVE. THESE VALUES ARE TO C... BE USED IN NEWMSH AND ERRCHK . C CALL BSPFIX (1.D0, VNSAVE(1,1), K, NCOMP, M) CALL BSPFIX (5.D0/6.D0, VNSAVE(1,2), K, NCOMP, M) CALL BSPFIX (2.D0/3.D0, VNSAVE(1,3), K, NCOMP, M) CALL BSPFIX (1.D0/3.D0, VNSAVE(1,4), K, NCOMP, M) CALL BSPFIX (1.D0/6.D0, VNSAVE(1,5), K, NCOMP, M) RETURN END C C....................................................................... C SUBROUTINE ERRCHK(IMESH,XIOLD,ALDIF,VALSTR,WORK,MSTAR,IFIN) C C*********************************************************************** C C PURPOSE C DETERMINE THE ERROR ESTIMATES AND TEST TO SEE IF THE C ERROR TOLERANCES ARE SATISFIED. C C VARIABLES C XIOLD - CURRENT MESH POINTS C VALSTR - VALUES OF THE PREVIOUS SOLUTION WHICH ARE NEEDED C FOR THE EXTRAPOLATION- LIKE ERROR ESTIMATE. C WGTERR - WEIGHTS USED IN THE EXTRAPOLATION-LIKE ERROR C ESTIMATE. THE ARRAY VALUES ARE ASSIGNED IN C SUBROUTINE CONSTS. C ERREST - STORAGE FOR ERROR ESTIMATES C ERR - TEMPORARY STORAGE USED FOR ERROR ESTIMATES C WORK - SPACE TO BE USED TO STORE VALUES OF Z AT THE C MESH POINTS FOR PRINTOUT. ITS DIMENSION IS C MSTAR * NMAX. C Z - APPROXIMATE SOLUTION ON MESH XI C IFIN - A 0-1 VARIABLE. IF IMESH = 2 THEN ON RETURN IT C INDICATES WHETHER THE ERROR TOLERANCES WERE SATISFIED. C IMESH = 1 THE CURRENT MESH RESULTED FROM MESH SELECTION C OR IS THE INITIAL MESH. C = 2 THE CURRENT MESH RESULTED FROM DOUBLING THE C PREVIOUS MESH C MSHFLG - IS SET BY ERRCHK TO INDICATE TO NEWMSH WHETHER C ANY VALUES OF THE CURRENT SOLUTION ARE STORED IN C THE ARRAY VALSTR. (0 FOR NO, 1 FOR YES) C C********************************************************************** C IMPLICIT REAL*8 (A-H,O-Z) DIMENSION ERR(40),Z(40),ERREST(40) ,DMVAL(20) COMMON /ORDER/K,NCOMP,MSTR,KD,KDM,MNSUM,M(20) COMMON /APPR/ N,NOLD,NMAX,NALPHA,MSHFLG,MSHNUM,MSHLMT,MSHALT COMMON /SIDE/ ZETA(40), ALEFT, ARIGHT, IZETA, IWR COMMON /ERRORS/ TOL(40),WGTMSH(40),TOLIN(40),ROOT(40), 1 JTOL(40),LTOL(40),NTOL COMMON /COLLOC/ RHO(7),WGTERR(40) COMMON /NONLN/ PRECIS,NONLIN,ITER,LIMIT,ICARE,IPRINT,IGUESS,IFREEZ COMMON /BSPLIN/ VNCOL(66,7), VNSAVE(66,5), VN(66) DIMENSION XIOLD(1), ALDIF(1), VALSTR(1), WORK(MSTAR,1) C IFIN = 1 NOLDP1 = NOLD + 1 C C... IF FULL OUTPUT HAS BEEN REQUESTED, PRINT VALUES OF THE C... SOLUTION COMPONENTS Z AT THE MESHPOINTS. C IF ( IPRINT .GE. 0 ) GO TO 30 DO 10 I = 1, NOLD 10 CALL APPROX(I, XIOLD(I), WORK(1,I), VNSAVE(1,1), XIOLD, 1 NOLD, ALDIF, K, NCOMP, M, MSTAR, 3, DUMM, 0) CALL APPROX(NOLD, XIOLD(NOLDP1), WORK(1,NOLDP1), VN, XIOLD, 1 NOLD, ALDIF, K, NCOMP, M, MSTAR, 2, DUMM, 0) DO 20 I = 1, MSTAR WRITE(IWR,140) I 20 WRITE(IWR,150) (WORK(I,J), J=1, NOLDP1) 30 CONTINUE IF (IMESH.EQ.1) RETURN C C... IMESH = 2 SO ERROR ESTIMATES ARE TO BE GENERATED AND TESTED C... TO SEE IF THE TOLERANCE REQUIREMENTS ARE SATISFIED. C DO 40 J = 1,MSTAR 40 ERREST(J) = 0.D0 DO 100 IBACK = 1,NOLD I = NOLD +1 -IBACK C C... THE ERROR ESTIMATES ARE OBTAINED BY COMBINING VALUES OF C... THE NUMERICAL SOLUTIONS FOR TWO MESHES. C... FOR EACH VALUE OF IBACK WE WILL CONSIDER THE TWO C... APPROXIMATIONS AT 2 POINTS IN EACH OF C... THE NEW SUBINTERVALS. WE WORK BACKWARDS THROUGH C... THE SUBINTERVAL SO THAT NEW VALUES CAN BE STORED C... IN VALSTR IN CASE THEY PROVE TO BE NEEDED LATER C... FOR AN ERROR ESTIMATE. THE ROUTINE NEWMSH C... FILLED IN THE NEEDED VALUES OF THE OLD SOLUTION C... IN VALSTR. C MSHFLG = 1 DO 50 J = 1,MSTAR Z(J) = 0.D0 50 ERR(J) = 0.D0 DO 60 J = 1,2 JJ = 5 - J KNEW = ( 4 * (I-1) + 3 - J ) * MSTAR + 1 KSTORE = ( 2 * (I-1) + 2 - J ) * MSTAR + 1 X = XIOLD(I) + DFLOAT(3-J)/3.D0*(XIOLD(I+1)-XIOLD(I)) CALL APPROX (I, X, VALSTR(KNEW), VNSAVE(1,JJ), XIOLD, 1 NOLD, ALDIF, K, NCOMP, M, MSTAR, 3,DUMM,0) DO 60 L = 1,MSTAR ERR(L) = ERR(L) + WGTERR(L) * DABS(VALSTR(KNEW) - 1 VALSTR(KSTORE)) Z(L) = Z(L) + .5D0 * DABS(VALSTR(KNEW)) KNEW = KNEW + 1 KSTORE = KSTORE + 1 60 CONTINUE C C... TEST WHETHER THE TOLERANCE REQUIREMENTS ARE SATISFIED C... IN THE I-TH INTERVAL. C IF (IFIN .EQ. 0) GO TO 80 DO 70 J = 1, NTOL LTOLJ = LTOL(J) 70 IF ( ERR(LTOLJ) .GT. TOLIN(J) * (Z(LTOLJ)+1.D0) ) IFIN = 0 80 DO 90 L = 1,MSTAR 90 ERREST(L) = DMAX1(ERREST(L),ERR(L)) 100 CONTINUE IF (IPRINT .LT. 1) WRITE(IWR,130) LJ = 1 DO 110 J = 1,NCOMP MJ = LJ - 1 + M(J) IF (IPRINT .LT. 1) WRITE(IWR,120) J, (ERREST(L), L= LJ, MJ) LJ = MJ + 1 110 CONTINUE RETURN C-------------------------------------------------------------- 120 FORMAT (3H U(, I2, 3H) -,4D12.4) 130 FORMAT (/26H THE ESTIMATED ERRORS ARE,) 140 FORMAT( 19H MESH VALUES FOR Z(, I2, 2H), ) 150 FORMAT(1H , 8D15.7) END C C----------------------------------------------------------------------- C P A R T 3 C COLLOCATION SYSTEM SETUP ROUTINES -- SEE (1) C----------------------------------------------------------------------- C SUBROUTINE LSYSLV (IFLAG, XI, XIOLD, XIJ, ALPHA, ALDIF, 1 RHS, ALPHO, A, IPIV, INTEGS, RNORM, 2 MODE, FSUB, DFSUB, GSUB, DGSUB, SOLUTN) C********************************************************************* C C PURPOSE C THIS ROUTINE CONTROLS THE SET UP AND SOLUTION OF A LINEAR C SYSTEM OF COLLOCATION EQUATIONS. C THE MATRIX A IS CAST INTO AN ALMOST BLOCK DIAGONAL C FORM BY AN APPROPRIATE ORDERING OF THE COLUMNS AND SOLVED C USING THE PACKAGE OF DE BOOR-WEISS (4). THE MATRIX IS COMPOSED C OF N BLOCKS. THE I-TH BLOCK HAS THE SIZE C INTEGS(1,I) * INTEGS(2,I). C IT CONTAINS IN ITS LAST ROWS THE LINEARIZED COLLOCATION EQUA- C TIONS (BOTH BUNDARY CONDITIONS AND DIFFERENTIAL EQUATIONS ) C CORRESPONDING TO THE I-TH SUBINTERVAL. INTEGS(3,I) STEPS OF C GAUSSIAN ELIMINATION ARE APPLIED TO IT TO ACHIEVE A PLU C DECOMPOSITION. THE RIGHT HAND SIDE VECTOR IS PUT INTO RHS C AND THE SOLUTION VECTOR IS RETURNED IN ALPHA. C C LSYSLV OPERATES ACCORDING TO ONE OF 5 MODES: C MODE = 0 - SET UP BOTH A AND RHS , AND SOLVE SYSTEM C (FOR LINEAR PROBLEMS). C MODE = 1 - SET UP RHS ONLY AND COMPUTE ITS NORM. C MODE = 2 - SET UP A ONLY AND SOLVE SYSTEM. C MODE = 3 - PERFORM FORWARD AND BACKWARD SUBSTITUTION (DO NOT SET C UP A NOR FORM THE RHS). C C FOR THE FIRST ITERATION ON A PARTICULAR MESH, C INTEGS IS COMPUTED. ALSO, THE INITIAL ALPHA ON C THE NEW MESH IS COMPUTED. C C VARIABLES C C IRHS,IA,IZETA,IALPHO - POINTERS TO RHS,A,ZETA,ALPHO RESPECTIVELY C (NECESSARY TO KEEP TRACK OF BLOCKS OF A C DURING MATRIX MANIPULATIONS) C ALPHO - B-SPLINE COEFFS FOR PREVIOUS SOLUTION C DG - PARTIAL DERIVATIVES OF G FROM DGSUB C DF - PARTIAL DERIVATIVES OF F FROM DFSUB C RNORM - EUCLIDEAN NORM OF RHS C LSIDE - NUMBER OF SIDE CONDITIONS IN CURRENT AND PREVIOUS BLOCKS C ICOLC - POINTER TO CURRENT COLLOCATION POINT ARRAY XIJ C ID - (ANOTHER) POINTER FOR RHS C IGUESS = 1 WHEN CURRENT SOLN IS USER SPECIFIED C = 0 OTHERWISE C C********************************************************************* IMPLICIT REAL*8 (A-H,O-Z) COMMON /ORDER/ K, NCOMP, MSTAR, KD, KDM, MNSUM, M(20) COMMON /SIDE/ ZETA(40), ALEFT, ARIGHT, IZETA, IWR COMMON /BSPLIN/ VNCOL(66,7), VNSAVE(66,5), VN(66) COMMON /APPR/ N,NOLD,NMAX,NALPHA,MSHFLG,MSHNUM,MSHLMT,MSHALT COMMON /NONLN/ PRECIS,NONLIN,ITER,LIMIT,ICARE,IPRINT,IGUESS,IFREEZ COMMON /HI/ DN1, DN2, DN3 EXTERNAL FSUB, DFSUB, GSUB, DGSUB, SOLUTN DIMENSION ALPHO(1), XI(1), XIOLD(1), XIJ(1), ALPHA(1) DIMENSION ALDIF(1), RHS(1), A(1), IPIV(1), INTEGS(3,1) DIMENSION Z(40), F(40), DF(800), DMVAL(20) C M1 = MODE + 1 GO TO (10, 30, 30, 310), M1 C C... LINEAR PROBLEM INITIALIZATION C 10 DO 20 I=1,MSTAR 20 Z(I) = 0.D0 C C... INITIALIZATION C 30 IRHS = 0 IA = 1 IZETA = 1 LSIDE = 0 RNORM = 0.D0 IALPHO = 0 IF (ITER .GE. 1 .OR. MODE .EQ. 2) GO TO 80 C C... BUILD INTEGS (DESCRIBING BLOCK STRUCTURE OF MATRIX) C DO 70 I = 1,N INTEGS(2,I) = KDM IF (I .LT. N) GO TO 40 INTEGS(3,I) = KDM LSIDE = MSTAR GO TO 60 40 INTEGS(3,I) = KD 50 IF( LSIDE .EQ. MSTAR ) GO TO 60 IF ( ZETA(LSIDE+1) .GE. XI(I+1) ) GO TO 60 LSIDE = LSIDE + 1 GO TO 50 60 NROW = KD + LSIDE 70 INTEGS(1,I) = NROW C C... THE DO LOOP 290 SETS UP THE LINEAR SYSTEM OF EQUATIONS. C 80 DO 290 I=1,N XIL = XI(1) IF (I .GT. 1) XIL = XI(I-1) XIR = XI(N+1) IF (I .LT. N) XIR = XI(I+2) DN1 = 1.D0 / (XI(I+1) - XIL) DN2 = 1.D0 / (XI(I+1) - XI(I)) DN3 = 1.D0 / (XIR - XI(I)) C C... CONSTRUCT A BLOCK OF A AND A CORRESPONDING PIECE OF RHS. C NROW = INTEGS(1,I) II = I ICOLC = (I-1) * K ID = IRHS + IZETA - 1 C C... GO THRU THE NCOMP COLLOCATION EQUATIONS AND SIDE CONDITIONS C... IN THE I-TH SUBINTERVAL C DO 270 LL=1,K XX = XIJ (ICOLC+LL) 100 IF ( IZETA .GT. MSTAR ) GO TO 160 IF ( ZETA(IZETA) .GE. XX ) GO TO 160 C C... BUILD EQUATION FOR A SIDE CONDITION. C 110 ID = ID + 1 IALPHO = IALPHO + 1 IF (MODE .EQ. 0) GO TO 130 IF (IGUESS .NE. 1) GO TO 120 C C... CASE WHERE USER PROVIDED CURRENT APPROXIMATION C CALL SOLUTN (ZETA(IZETA), Z, DMVAL) GO TO (130, 140), MODE C C... OTHER NONLINEAR CASE C 120 CALL APPROX (II, ZETA(IZETA), Z, VN, XIOLD, NOLD, 1 ALDIF, K, NCOMP, M, MSTAR, 1, DUMMY, 0) IF (MODE .EQ. 2) GO TO 140 C C... FIND RHS BOUNDARY VALUE. C 130 CALL GSUB (IZETA, Z, G) RHS(ID) = -G RNORM = RNORM + G**2 IF (MODE .EQ. 1) GO TO 150 C C... BUILD A ROW OF A CORRESPONDING TO A BOUNDARY POINT C 140 CALL BLDBLK (I, ZETA(IZETA), LL, A(IA), NROW, ID-IRHS, Z, 1 DF, NCOMP, XI, ALPHO, IALPHO, 1, DFSUB, DGSUB) 150 IZETA = IZETA + 1 C C... CHECK FOR OTHER SIDE CONDITIONS. C IF (IZETA .GT. MSTAR .AND. 1 ZETA(MSTAR) .GE. DMIN1(XX,ARIGHT)) GO TO 280 IF (XX .GT. XI(N+1)) GO TO 260 GO TO 100 C C... THIS VALUE CORRESPONDS TO A COLLOCATION (INTERIOR) C... POINT. BUILD THE CORRESPONDING NCOMP EQUATIONS. C 160 IF (IGUESS .NE. 1) GO TO (210, 170, 230), M1 C C... USE INITIAL APPROXIMATION PROVIDED BY THE USER. C CALL SOLUTN(XX, Z, DMVAL) GO TO (190, 250), MODE C C... FIND RHS VALUES C 170 IF (ITER .GE. 1 ) GO TO 180 CALL APPROX (II, XX, Z, VN, XIOLD, NOLD, ALDIF, K, 1 NCOMP, M, MSTAR, 1, DMVAL, 1) GO TO 190 180 CALL APPROX (I, XX, Z, VNCOL(1,LL), XIOLD, NOLD, 1 ALDIF, K, NCOMP, M, MSTAR, 3, DMVAL, 1) 190 CALL FSUB (XX, Z, F) C C... FILL IN RHS VALUES (AND ACCUMULATE ITS NORM). C DO 200 J=1,NCOMP ID = ID + 1 VALUE = DMVAL(J) - F(J) RHS(ID) = -VALUE RNORM = RNORM + VALUE**2 IF (ITER .GE. 1) GO TO 200 IALPHO = IALPHO + 1 ALPHO(IALPHO) = DMVAL(J) 200 CONTINUE GO TO 260 C C... THE LINEAR CASE C 210 CALL FSUB (XX, Z, F) DO 220 J=1,NCOMP ID = ID + 1 220 RHS(ID) = F(J) ID = ID - NCOMP GO TO 250 C C... EVALUATE FORMER COLLOCATION SOLN FOR MODE=2 C 230 IF (ITER .GE. 1 ) GO TO 240 CALL APPROX (II, XX, Z, VN, XIOLD, NOLD, ALDIF, K, 1 NCOMP, M, MSTAR, 1, DUMMY, 0) GO TO 250 240 CALL APPROX (I, XX, Z, VNCOL(1,LL), XIOLD, NOLD, 1 ALDIF, K, NCOMP, M, MSTAR, 3, DUMMY, 0) C C... FILL IN NCOMP ROWS OF A C 250 CALL BLDBLK (I, XX, LL, A(IA), NROW, ID-IRHS+1, Z, 1 DF, NCOMP, XI, ALPHO, IALPHO, 2, DFSUB, DGSUB) ID = ID + NCOMP C C... PREPARE TO SET UP SIDE CONDITIONS FOR LAST SUBINTERVAL C 260 IF (LL .LT. K) GO TO 270 IF (I .LT. N .OR. IZETA .GT. MSTAR) GO TO 280 XX = XI(N+1) + 1.D0 GO TO 110 270 CONTINUE C C... UPDATE COUNTERS -- I-TH BLOCK COMPLETED C 280 IRHS = IRHS + NROW IA = IA + NROW * KDM 290 CONTINUE IF (MODE .NE. 1) GO TO 300 RNORM = DSQRT(RNORM / DFLOAT(NALPHA)) RETURN C C... SOLVE THE LINEAR SYSTEM. C C... MATRIX DECOMPOSITION C 300 CALL FCBLOK (A, INTEGS, N, IPIV, ALPHA, IFLAG) C C... CHECK FOR SINGULAR MATRIX C IF(IFLAG .EQ. 0) RETURN C C... PERFORM FORWARD AND BACKWARD SUBSTITUTION FOR MODE=0,2, OR 3. C 310 CALL SBBLOK (A, INTEGS, N, IPIV, RHS, ALPHA) C C... FIND THE COEFFICIENTS ALPHA OF THE INITIAL APPROX IF NECESSARY. C IF (ITER .GE. 1 .OR. MODE .NE. 2) RETURN IALPHO = 0 IRHS = 0 ISTO = 0 DO 320 I=1,N NROW = INTEGS(1,I) IRHS = IRHS + ISTO ISTART = ISTO + 1 ISTO = NROW - KD DO 320 J=ISTART,NROW IRHS = IRHS + 1 IALPHO = IALPHO + 1 RHS(IRHS) = RHS(IRHS) + ALPHO(IALPHO) 320 CONTINUE CALL SBBLOK (A, INTEGS, N, IPIV, RHS, ALPHO) DO 330 I=1,NALPHA 330 ALPHO(I) = ALPHO(I) - ALPHA(I) RETURN END C................................................................... SUBROUTINE BLDBLK (I, X, LL, Q, NROW, NC, Z, DF, NCOMP, 1 XI, ALPHO, IALPHO, MODE, DFSUB, DGSUB) C C********************************************************************** C C PURPOSE: C C CONSTRUCT COLLOCATION MATRIX ROWS ACCORDING TO MODE: C MODE = 1 - A ROW CORRESPONDING TO A SIDE CONDITION. C MODE = 2 - A GROUP OF NCOMP ROWS CORRESPONDING C AN INTERIOR COLLOCATION POINT. C C VARIABLES: C C ALPHO - USED ONLY ON THE FIRST ITERATION FOR NONLINEAR C PROBLEMS WHEN THE FIRST APPROXIMATION IS OTHER C THAN A B-SPLINE REPRESENTATION ON THE CURRENT MESH. C A RIGHT HAND SIDE IS BEING BUILT UP IN ALPHO WHICH, C WHEN THE INVERTED COLLOCATION MATRIX IS APPLIED TO IT, C WILL PRODUCE A FIRST APPROXIMATION ON THE CURRENT MESH C IN TERMS OF B- SPLINES SO THE STEP-LENGTH ALGORITHM C IN CONTRL CAN OPERATE. C X - THE COLLOCATION OR SIDE CONDITION POINT. C I - THE SUBINTERVAL CONTAINING X C LL - IF X IS A COLLOCATION POINT THEN IT IS THE LL-TH C OF K COLLOCATION POINTS ON THE I-TH SUBINTERVAL. C Q - THE SUB-BLOCK OF THE COLLOCATION MATRIX IN C WHICH THE EQUATIONS ARE TO BE FORMED. C NROW - NO. OF ROWS IN Q. C NC - THE FIRST ROW IN Q TO BE USED FOR EQUATIONS. C Z - Z(X) C DG - THE DERIVATIVES OF THE SIDE CONDITION. C DF - THE JACOBIAN AT X. C ID - THE ROW OF Q BEING CONSTRUCTED. C BASEF - VALUES AND DERIVATIVES OF THE B-SPLINE BASIS C FOR EACH OF THE COMPONENTS. C JCOMP - COUNTER FOR THE COMPONENT BEING DEALT WITH. C L - COUNTER FOR THE B-SPLINES REPRESENTING U(JCOMP). C J - COUNTER FOR THE LOWEST M(JCOMP) DERIVATIVES OF C BSPLINES REPRESENTING U . C JCOMP C C********************************************************************** IMPLICIT REAL*8 (A-H,O-Z) COMMON /COLLOC/ RHO(7), WGTERR(40) COMMON /APPR/ N,NOLD,NMAX,NALPHA,MSHFLG,MSHNUM,MSHLMT,MSHALT COMMON /ORDER/ K, ND, MSTAR, KD, KDM, MNSUM, M(20) COMMON /SIDE/ ZETA(40), ALEFT, ARIGHT, IZETA, IWR COMMON /NONLN/ PRECIS,NONLIN,ITER,LIMIT,ICARE,IPRINT,IGUESS,IFREEZ COMMON /HI/ DN1, DN2, DN3 COMMON /BSPLIN/ VNCOL(66,7), VNSAVE(66,5), VN(66) EXTERNAL DFSUB, DGSUB DIMENSION Q(NROW,1), Z(1), DF(NCOMP,1) DIMENSION XI(1), BASEF(620), ALPHO(1), DG(40) C NK = NC IF (MODE .EQ. 2) NK = NC + NCOMP - 1 DO 10 J=NC,NK DO 10 L=1,KDM 10 Q(J,L)=0.D0 C C... BRANCH ACCORDING TO M O D E C GO TO (20, 130), MODE C C... X IS A BOUNDARY POINT C 20 CALL BSPDER (VN, XI, N, X, I, BASEF, 2) C C... PROVIDE COEFFICIENTS OF THE J-TH LINEARIZED SIDE CONDITION. C... SPECIFICALLY, AT X=ZETA(J) THE J-TH SIDE CONDITION READS C... DG(1)*Z(1) + ... +DG(MSTAR)*Z(MSTAR) + G = 0 C CALL DGSUB (IZETA, Z, DG) IF (ITER .GE. 1 .OR. NONLIN .EQ. 0) GO TO 40 VALUE = 0.D0 DO 30 J=1,MSTAR 30 VALUE = VALUE + DG(J) * Z(J) ALPHO(IALPHO) = VALUE 40 IQ = 0 IQM = MSTAR IDG = 0 IBASEF = 0 ID = NC C DO 120 JCOMP=1,NCOMP MJ = M(JCOMP) MJ1 = MJ + 1 KMJ = K - MJ C C... INCORPORATE THE VALUES AND DERIVATIVES FOR C... THE B-SPLINES WHICH ARE NONZERO ON THE PRECEEDING C... SUBINTERVAL. C DO 60 L=1,MJ DO 50 J=1,MJ 50 Q(ID, IQ+L) = Q(ID, IQ+L) + DG(IDG+J) * 1 BASEF(IBASEF + J) 60 IBASEF = IBASEF + MJ1 C C... THE B-SPLINES WHICH ARE NONZERO ON THE CURRENT C... SUBINTERVAL ONLY. C IF (KMJ .LE. 0) GO TO 90 DO 80 L=1,KMJ DO 70 J=1,MJ 70 Q(ID, IQM+L) = Q(ID, IQM+L) + DG(IDG+J) * 1 BASEF(IBASEF+J) 80 IBASEF = IBASEF + MJ1 C C... THE B-SPLINES WHICH ARE NONZERO ON THE SUCCEEDING C... SUBINTERVAL AS WELL. C 90 DO 110 L=1,MJ DO 100 J=1,MJ 100 Q(ID, IQ+KD+L) = Q(ID, IQ+KD+L) + DG(IDG+J) * 1 BASEF(IBASEF+J) 110 IBASEF = IBASEF + MJ1 C IDG =IDG + MJ IQ = IQ + MJ IQM = IQM + KMJ 120 CONTINUE RETURN C C... BUILD NCOMP ROWS FOR INTERIOR COLLOCATION POINT X. C... THE LINEAR EXPRESSIONS TO BE CONSTRUCTED ARE: C... (M(JJ)) C... U - DF(JJ,1)*Z(1) - ... - DF(JJ,MSTAR)*Z(MSTAR) C... JJ C... FOR JJ = 1 TO NCOMP. C 130 CALL BSPDER (VNCOL(1,LL), XI, N, X , I, BASEF, 3) CALL DFSUB (X, Z, DF) C C... LOOP OVER THE NCOMP EXPRESSIONS TO BE SET UP FOR THE C... CURRENT COLLOCATION POINT. C DO 240 JJ=1,NCOMP IF (ITER .GE. 1 .OR. NONLIN .EQ. 0) GO TO 150 IALPHO = IALPHO + 1 VALUE = 0.D0 DO 140 J=1,MSTAR 140 VALUE = VALUE + DF(JJ,J) * Z(J) ALPHO(IALPHO) = ALPHO(IALPHO) - VALUE 150 ID = JJ + NC - 1 IQ=0 IQM=MSTAR IDF=0 IBASEF=0 C C... NOTE THAT IF JJ .EQ. JCOMP AN ENTRY HAS TO BE MADE FOR THE C... M(JCOMP)-TH DERIVATIVE OF THE JCOMP-TH COMPONENT. C DO 230 JCOMP=1,NCOMP MJ = M(JCOMP) MJ1 = MJ + 1 KMJ = K - MJ C C... USE THE B-SPLINES WHICH ARE NONZERO ON THE PRECEEDING C... SUBINTERVAL. C DO 170 L=1,MJ IF (JCOMP . EQ. JJ) Q(ID, IQ+L) = BASEF(IBASEF+MJ1) DO 160 J=1,MJ 160 Q(ID, IQ+L) = Q(ID, IQ+L) - DF(JJ, IDF+J) * 1 BASEF(IBASEF+J) 170 IBASEF = IBASEF + MJ1 C C... THE B-SPLINES WHICH ARE NONZERO ON THE CURRENT C... SUBINTERVAL ONLY. C IF (KMJ .LE. 0) GO TO 200 DO 190 L=1,KMJ IF (JCOMP .EQ. JJ) Q(ID, IQM+L) = BASEF(IBASEF+MJ1) DO 180 J=1,MJ 180 Q(ID, IQM+L) = Q(ID, IQM+L) - 1 DF(JJ, IDF+J) * BASEF(IBASEF+J) 190 IBASEF = IBASEF + MJ1 C C... THE B-SPLINES WHICH ARE NONZERO ON THE SUCCEEDING C... SUBINTERVAL AS WELL. C 200 DO 220 L=1,MJ IF (JCOMP .EQ. JJ) Q(ID, IQ+KD+L) = BASEF(IBASEF+MJ1) DO 210 J=1,MJ 210 Q(ID, IQ+KD+L) = Q(ID, IQ+KD+L) - DF(JJ, IDF+J) * 1 BASEF(IBASEF+J) 220 IBASEF = IBASEF + MJ1 C IDF = IDF + MJ IQ = IQ + MJ IQM = IQM + KMJ 230 CONTINUE 240 CONTINUE RETURN END C C----------------------------------------------------------------------- C P A R T 4 C B-SPLINE ROUTINES -- SEE (3) C----------------------------------------------------------------------- C SUBROUTINE APPSLN (X, Z, FSPACE, ISPACE) C C***************************************************************** C C PURPOSE C C SET UP A STANDARD CALL TO APPROX TO EVALUATE THE C APPROXIMATE SOLUTION Z = Z( U(X) ) AT A POINT X C (IT HAS BEEN COMPUTED BY A CALL TO COLSYS ). C THE PARAMETERS NEEDED FOR APPROX ARE RETRIEVED C FROM THE WORK ARRAYS ISPACE AND FSPACE . C C***************************************************************** C IMPLICIT REAL*8 (A-H,O-Z) DIMENSION Z(1), FSPACE(1), ISPACE(1) IS6 = ISPACE(6) + 1 IS5 = ISPACE(1) + 2 CALL APPROX (ISPACE(5), X, Z, FSPACE(IS6), FSPACE, ISPACE, 1 FSPACE(IS5), ISPACE(2), ISPACE(3), ISPACE(8), 2 ISPACE(4), 1, DUMM, 0) RETURN END C C.................................................................. C SUBROUTINE APPROX (I, X, Z, VN, XI, N, ALDIF, K, NCOMP, 1 M, MSTAR, MODE, DMVAL, MODHI) C C*********************************************************************** C C PURPOSE C (1) (M1-1) (MNCOMP-1) C EVALUATE Z(U(X))=(U (X),U (X),...,U (X),...,U (X) ) C 1 1 1 MNCOMP C AT ONE POINT X. C IF MODHI=1, EVALUATE MJ-TH DERIVATIVES TOO. C C VARIABLES C VN - TRIANGULAR ARRAY OF B-SPLINE VALUES FILLED IN BY C ROUTINES BSPFIX AND BSPVAR C XI - THE CURRENT MESH (HAVING N SUBINTERVALS) C ALDIF - THE ARRAY OF DIVIDED DIFFERENCES OF THE CURRENT C SOLUTION VECTORS COEFFICIENTS ALPHA (AND PREVIOUSLY C DETERMINED IN THE ROUTINE APPDIF) C MODE - DETERMINES THE AMOUNT OF INITIALIZATION NEEDED C = 5 FORMS Z(U(X)) USING ALDIF AND VN C = 3 AS IN =5, BUT FINISHES FILLING IN VN USING BSPVAR C = 2 AS IN =3, BUT STARTS FILLING IN VN USING BSPFIX C = 1 AS IN =2, BUT DETERMINES I SUCH THAT C XI(I) .LE. X .LT. XI(I+1) (UNLESS X=XI(N+1)) C = 4 A SPECIAL CASE WHICH ONLY DETERMINES I AS ABOVE C DMVAL - ARRAY OF MJ-TH DERIVATIVES OF THE SOLUTION COMPONENTS C UJ (EVALUATED IF MODHI=1) C C*********************************************************************** C IMPLICIT REAL*8 (A-H,O-Z) COMMON /NONLN/ PRECIS,NONLIN,ITER,LIMIT,ICARE,IPRINT,IGUESS,IFREEZ COMMON /SIDE/ ZETA(40), ALEFT, ARIGHT, IZETA, IWR DIMENSION Z(1), VN(1), XI(1), ALDIF(1), M(1), DMVAL(1) C GO TO (10, 60, 70, 10, 80), MODE C C... MODE = 1 OR 4, LOCATE I SO XI(I) .LE. X .LT. XI(I+1) C 10 CONTINUE IF (X .GE. XI(1)-PRECIS .AND. X .LE. XI(N+1)+PRECIS) 1 GO TO 20 IF (IPRINT .LT. 1) WRITE(IWR,160) X, XI(1), XI(N+1) IF (X .LT. XI(1)) X = XI(1) IF (X .GT. XI(N+1)) X = XI(N+1) 20 IF (I .GT. N .OR. I .LT. 1) I = (N+1) / 2 ILEFT = I IF (X .LT. XI(ILEFT)) GO TO 40 DO 30 L=ILEFT,N I = L IF (X .LT. XI(L+1)) GO TO 60 30 CONTINUE GO TO 60 40 IRIGHT = ILEFT - 1 DO 50 L=1,IRIGHT I = IRIGHT + 1 - L IF (X .GE. XI(I)) GO TO 60 50 CONTINUE 60 IF (MODE .EQ. 4) RETURN C C... MODE = 1 OR 2 BEGIN FILLING IN VN USING BSPFIX . C... COMPUTE MESH INDEPENDENT SPLINES. C RHOX = (XI(I+1) - X) / (XI(I+1) - XI(I)) CALL BSPFIX (RHOX, VN, K, NCOMP, M) C C... MODE = 1, 2, OR 3 FINISH FILLING IN VN USING BSPVAR C 70 CALL BSPVAR (I, X, VN, XI, N, K, NCOMP, M) C C... MODE .NE. 4 DETERMINE Z(U(X)) C 80 DO 90 L=1,MSTAR 90 Z(L) = 0.D0 INDIF = 0 K5 = 1 IF (MODHI .EQ. 0) GO TO 110 C C... INITIALIZE FOR SUBSEQUENT EVALUATION OF MJ-TH DERIVATIVES. C IVNHI = K * (K-1) / 2 DNK2 = DFLOAT(K) / (XI(I+1) - XI(I)) INCOMP = 0 DO 100 J=1,NCOMP 100 DMVAL(J) = 0.D0 C C... EVALUATE Z( U(X) ). C 110 DO 150 J = 1, NCOMP MJ = M(J) NALPHJ = N * K + MJ KMR = K + MJ IVN = KMR * (KMR - 1) / 2 DO 130 NR = 1, MJ LEFT = I * K + MJ - KMR DO 120 L = 1, KMR LEFTPL = LEFT + L 120 Z(K5) = Z(K5) + ALDIF(INDIF+LEFTPL) * VN(IVN+L) KMR = KMR - 1 IVN = IVN - KMR K5 = K5 + 1 130 INDIF = INDIF + NALPHJ IF (MODHI .EQ. 0) GO TO 150 C C... EVALUATE DMVAL(J) = MJ-TH DERIVATIVE OF UJ. C INCOMP = INCOMP + (MJ-1) * NALPHJ LEFT = (I-1) * K + MJ - 1 DO 140 L = 1, K 140 DMVAL(J) = DMVAL(J) + DNK2 * (ALDIF(INCOMP+LEFT+L+1) - 1 ALDIF(INCOMP+LEFT+L)) * VN(IVNHI+L) INCOMP = INCOMP + NALPHJ 150 CONTINUE RETURN C-------------------------------------------------------- 160 FORMAT(37H ****** DOMAIN ERROR IN APPROX ****** 1 /4H X =,D20.10, 10H ALEFT =,D20.10, 2 11H ARIGHT =,D20.10) END C C....................................................................... C SUBROUTINE BSPFIX (RHOX, VN, K, NCOMP, M) C C********************************************************************** C C PURPOSE C EVALUATE THE MESH INDEPENDENT BSPLINES AT ONE POINT C C C VARIABLES C VN - TRIANGULAR ARRAY OF B-SPLINE VALUES AT X FOR ORDERS C 1 TO K+M(NCOMP) WHERE XI(I) .LE. X .LE. XI(I+1) , COLUMN C J HAS LENGTH J AND CONTAINS THE J-TH ORDER B-SPLINE C VALUES AND BEGINS IN LOCATION I + J*(J-1)/2. VALUES C NOT COMPUTED HERE ARE COMPUTED IN BSPVAR. C RHOX = (XI(I+1)-X)/(XI(I+1)-XI(I)) C C*********************************************************************** C IMPLICIT REAL*8 (A-H,O-Z) DIMENSION VN(1), M(1) XRHO = 1.D0 - RHOX IVN = 0 C C... COMPUTE FIRST GROUP OF MESH INDEPENDENT B-SPLINE VALUES C VN(1) = 1.D0 DO 20 L=1,K IVN = IVN + L VNP = 0.D0 DO 10 J=1,L REP = VN(IVN-L+J) VN(IVN+J) = VNP + REP * RHOX 10 VNP = REP * XRHO 20 VN(IVN+L+1) = VNP C C... COMPUTE SECOND GROUP OF MESH INDEPENDENT B-SPLINE VALUES C MD1 = M(NCOMP) - 1 IF (MD1 .LE. 0) RETURN DO 40 L=1,MD1 IVN = IVN + K + L INC = L + 2 VNP = VN(IVN+1-K) * XRHO IF (K .LT. INC) RETURN DO 30 J=INC,K REP = VN(IVN-L-K+J) VN(IVN+J) = VNP + REP * RHOX 30 VNP = REP * XRHO 40 VN(IVN+K+1) = VNP RETURN END C C....................................................................... C SUBROUTINE BSPVAR (I, X, VN, XI, N, K, NCOMP, M) C C*********************************************************************** C C PURPOSE C EVALUATE THE MESH DEPENDENT B-SPLINES AT ONE POINT X C C VARIABLES C VN - TRIANGULAR ARRAY OF VALUES OF B-SPLINES OF ORDERS 1 C TO K+M(NCOMP) (DESCRIBED IN BSPFIX) C X - SATISFIES XI(I) .LE. X .LE. XI(I+1) C C********************************************************************** C IMPLICIT REAL*8 (A-H,O-Z) DIMENSION VN(1), XI(1), M(1) MD1 = M(NCOMP) -1 IF(MD1 .LE. 0) RETURN XIL = XI(1) IF (I .GT. 1) XIL = XI(I-1) XIR = XI(N+1) IF (I .LT. N) XIR = XI(I+2) RHO1 = (XI(I+1) - X) / (XI(I+1) - XI(I)) RHO2 = (XI(I+1) - X) / (XI(I+1) - XIL) RHO3 = (XIR - X) / (XIR - XI(I)) XRHO1 = 1.D0 - RHO1 XRHO2 = 1.D0 - RHO2 XRHO3 = 1.D0 - RHO3 IVN = K * (K+1) / 2 C C... RECURSIVELY COMPUTE B-SPLINE VALUES. C DO 30 L=1,MD1 IVN = IVN + K + L VNP = 0.D0 DO 10 J=1,L REP = VN(IVN-L-K+J) VN(IVN+J) = VNP + REP * RHO2 10 VNP = REP * XRHO2 VN(IVN+L+1) = VNP + RHO1 * VN(IVN-K+1) VNP = VN(IVN-L) * XRHO1 DO 20 J=1,L REP = VN(IVN+J-L) VN(IVN+K+J) = VNP + REP * RHO3 20 VNP = REP * XRHO3 30 VN(IVN+K+L+1) = VNP RETURN END C C....................................................................... C SUBROUTINE BSPDER (VN, XMESH, N, X, I, BASEF, MODE) C C*********************************************************************** C C PURPOSE C EVALUATE THE DERIVATIVES OF THE B-SPLINES OF APPROPRIATE C ORDERS AT ONE POINT X (USED TO SET UP THE C COLLOCATION EQUATIONS.) C C VARIABLES C C VN - THE TRIANGULAR ARRAY OF B-SPLINE VALUES CALCULATED IN C BSPFIX AND BSPVAR C BASEF - B-SPLINE DERIVATIVES NEEDED TO SET UP COLLOCATION C EQUATIONS, VIZ, DERIVATIVES OF ORDERS 0,1,...,MJ OF C B-SPLINES OF ORDER K+MJ (J=1,...,NCOMP). THESE C VALUES ARE FOUND USING VN, ALPHD, AND ALPHN (SEE BELOW). C ALPHD - ARRAY OF DIVIDED DIFFERENCES CORRESPONDING TO DERIVA- C TIVES OF B-SPLINES OF ORDER K+MNCOMP C ALPHN - SAME AS ALPHD, BUT FOR OTHER ORDER B-SPLINES C ALPHDO - DIVIDED DIFFERENCES OF ONE LOWER ORDER, USED TO DETER- C MINE ALPHD C ALPHNO - DIVIDED DIFFERENCES OF ONE LOWER ORDER, USED TO DETER- C MINE ALPHN C ND - THE NO. OF DIFFERENTIAL EQUATIONS OF DISTINCT ORDERS C (SO NO. OF OTHER DIFFERENTIAL EQUATIONS =NEQ =NCOMP-ND) C MND - THE DISTINCT ORDERS OF THESE ND DIFFERENTIAL EQUATIONS C XMESH - CURRENT MESH, WITH XMESH(I) .LE. X .LT. XMESH(I+1) (UNLE C X=XMESH(N+1) C MODE - DETERMINES THE AMOUNT OF INITIALIZATION NEEDED C = 4 COMPUTE THE ARRAY BASEF C = 3 AS IN =4, BUT FILL IN SUBINTERVAL DEPENDENT VALUES C OF VN USING BSPVAR C = 2 AS IN =3, BUT FILL IN SUBINTERVAL INDEPENDENT VALUES C OF VN USING BSPFIX C = 1 AS IN =2, BUT CALCULATE CERTAIN SUBINTERVAL DEPEN- C DENT CONSTANTS C C*********************************************************************** C IMPLICIT REAL*8 (A-H,O-Z) COMMON /ORDER/ K, NCOMP, MSTAR, KD, KDM, MNSUM, M(20) COMMON /HI/ DN1, DN2, DN3 COMMON /EQORD/ IND(5), INEQ(20), MND(5), ND, NEQ DIMENSION BASEF(1), VN(1), XMESH(1) DIMENSION ALPHD(80), ALPHDO(80), ALPHN(280) , ALPHNO(280) C GO TO (10, 20, 30, 40), MODE C C... MODE = 1 COMPUTE SUBINTERVAL DEPENDENT CONSTANTS C 10 XIL = XMESH(1) IF (I .GT. 1) XIL = XMESH(I-1) XIR = XMESH(N+1) IF (I .LT. N) XIR = XMESH(I+2) DN1 = 1.D0 / (XMESH(I+1) - XIL) DN2 = 1.D0 / (XMESH(I+1) - XMESH(I)) DN3 = 1.D0 / (XIR - XMESH(I)) C C... MODE = 2 COMPUTE SUBINTERVAL INDEPENDENT B-SPLINES C 20 RHOX = (XMESH(I+1) - X) * DN2 CALL BSPFIX (RHOX, VN, K, NCOMP, M) C C... MODE = 3 COMPUTE SUBINTERVAL DEPENDENT B-SPLINES C 30 CALL BSPVAR (I, X, VN, XMESH, N, K, NCOMP, M) C C... MODE = 4 C 40 MD = MND(ND) KMD = K + MD KMD1 = KMD + 1 MD1 = MD + 1 MD2M2 = MD * 2 - 2 MD2M1 = MD2M2 + 1 INL = KMD * 2 C C... INITIALIZE ARRAYS ALPHDO AND ALPHNO C DO 50 J=1,KMD ALPHDO (J) = 0.D0 50 ALPHDO(J+KMD) = 1.D0 KUP = KMD * MD DO 60 J=1,KUP 60 ALPHDO(J+INL) = 0.D0 NDM1 = ND - 1 NREST = MD2M2 - K INN = 0 IF (NREST .LE. 0) GO TO 100 IF (ND .EQ. 1) GO TO 100 INL = 2 * MD2M2 DO 90 NN = 1,NDM1 MN2 = MND(NN) + 2 DO 70 J = 1,MD2M2 ALPHNO(J+INN) = 0.D0 70 ALPHNO(J+INN+MD2M2) = 1.D0 KUP = MD2M2 * MND(NN) DO 80 J=1,KUP 80 ALPHNO(J+INN+INL) = 0.D0 90 INN = INN + MN2 * MD2M2 100 INNS = INN C C... INITIALIZE B-SPLINE DERIVATIVE VALUES BASEF C DO 120 J=1,ND K1 = IND(J) MJ = MND(J) KMJ = K + MJ MJ1 = MJ + 1 IVN = KMJ * (KMJ-1) / 2 DO 120 L=1,KMJ BASEF(K1) = VN(IVN+L) DO 110 JJ=1,MJ 110 BASEF(K1+JJ) = 0.D0 120 K1 = K1 + MJ1 C C... FOR EACH DERIVATIVE NR DO LOOP 310 C DO 310 NR=1,MD NR1 = NR + 1 MDR = MD - NR K1 = IND(ND) + NR KMDR = K + MDR IVN = KMDR * (KMDR-1) /2 IF (MDR .EQ. 0) GO TO 150 C C... FIRST, DETERMINE NR(TH) DERIVATIVE OF B-SPLINES C... CORRESPONDING TO THE HIGHEST ORDER SOLUTION COMPONENT C... (I.E. OF ORDER MNCOMP=MD). C DO 140 J=1,MDR JR = J + NR JIN = JR + NR1 * KMD JINK = JIN + K DO 130 L=J,JR JIN1 = JIN - KMD1 JINK1 = JINK - KMD1 ALPHD(JIN) = DN1 * (ALPHDO(JIN) - ALPHDO(JIN1)) ALPHD(JINK) = DN3 * (ALPHDO(JINK) - ALPHDO(JINK1)) IN = K1 + (L-1) * MD1 BASEF(IN) = BASEF(IN) + ALPHD(JIN) * VN(IVN+J) IN = IN + K * MD1 BASEF(IN) = BASEF(IN) + ALPHD(JINK) * VN(IVN+J+K) JIN = JIN - KMD 130 JINK = JINK - KMD 140 CONTINUE 150 MDR1 = MDR + 1 IF ( MDR1 .GT. K) GO TO 180 DO 170 J = MDR1,K JR = J + NR JIN = JR + NR1 * KMD DO 160 L = J,JR JIN1 = JIN - KMD1 ALPHD(JIN) = DN2 * (ALPHDO(JIN) - ALPHDO(JIN1)) IN = K1 + (L-1) * MD1 BASEF(IN) = BASEF(IN) + ALPHD(JIN) * VN(IVN+J) 160 JIN = JIN - KMD 170 CONTINUE 180 CONTINUE IF (ND .EQ. 1) GO TO 230 INN = INNS C C... NOW DETERMINE NR(TH) DERIVATIVE BASEF FOR B-SPLINES C... CORRESPONDING TO ALL OTHER SOLUTION COMPONENTS (NN) C DO 220 NN=1,NDM1 NJ = ND - NN MJ = MND(NJ) INN = INN - (MJ+2) * MD2M2 IF (NR .GT. MJ) GO TO 230 KMJR = K + MJ - NR K1 = IND(NJ)+ NR IVN = KMJR * (KMJR-1) / 2 MJ1 = MJ + 1 JR1 = KMJR - MD + 1 JR1 = MIN0 (JR1, MD-1) C C... COMPUTE PORTION OF B-SPLINE DERIVATIVE VALUES (BASEF) C... USING DIVIDED DIFFERENCES PREVIOUSLY CALCULATED FOR THE C... HIGHEST ORDER SOLUTION COMPONENT IN ALPHD. C DO 190 J=1,JR1 JR = J + NR JIN = JR + NR1 * KMD + MD - MJ DO 190 L=J,JR IN = K1 + (L-1) * MJ1 BASEF(IN) = BASEF(IN) + ALPHD(JIN) * VN(IVN+J) JIN = JIN - KMD 190 CONTINUE DO 200 J=MD,KMJR JR = J + NR JIN = JR + NR1 * KMD DO 200 L=J,JR IN = K1 + (L-1) * MJ1 BASEF(IN) = BASEF(IN) + ALPHD(JIN) * VN(IVN+J) JIN = JIN - KMD 200 CONTINUE C C... FINISH COMPUTING B-SPLINE DERIVATIVE VALUES USING THE C... NEW NR(TH) DIVIDED DIFFERENCES ALPHN C JR2 = MD2M2 - KMJR IF (JR2 .LE. 0) GO TO 220 DO 210 JJ=1,JR2 J = JJ + JR1 JR = J + NR JIN = JR + NR1 * MD2M2 + INN DO 210 L=J,JR JIN1 = JIN - MD2M1 ALPHN(JIN) = DN2 * (ALPHNO(JIN) - ALPHNO(JIN1)) IN = K1 + (L-1) * MJ1 BASEF(IN) = BASEF(IN) + ALPHN(JIN) * VN(IVN+J) JIN = JIN - MD2M2 210 CONTINUE 220 CONTINUE 230 CONTINUE C C... SAVE NR(TH) DIVIDED DIFFERENCE VALUES, ALPHD AND ALPHN, C... TO BE USED TO DETERMINE THE NEXT HIGHER ORDER DIVIDED C... DIFFERENCES, BY STORING THEM IN ALPHDO AND ALPHNO C IF (NR .EQ. MD) GO TO 300 NR2 = NR + 2 INJ = NR DO 240 L=2,NR2 INJ = INJ + KMD DO 240 J=1,KMDR 240 ALPHDO(J+INJ) = ALPHD(J+INJ) IF (ND .EQ. 1) GO TO 300 IF (NREST .LE. 0) GO TO 300 INN = 0 DO 290 NN = 1,NDM1 MN = MND(NN) IF (MN .LE. NR) GO TO 280 KMNR = K + MN - NR JR1 = MIN0 (KMNR-MD+1, MD-1) INJ = NR + INN INL = NR + MD - MN DO 250 L=2,NR2 INJ = INJ + MD2M2 INL = INL + KMD DO 250 J=1,JR1 250 ALPHNO(INJ+J) = ALPHD(INL+J) MUP = MIN0 (KMNR, MD2M2) INJ = NR + INN INL = NR DO 260 L=2,NR2 INJ = INJ + MD2M2 INL = INL + KMD DO 260 J =MD,MUP 260 ALPHNO(INJ+J) = ALPHD(INL+J) JR2 = MD2M2 - KMNR IF (JR2 .LE. 0) GO TO 280 INJ = NR + INN DO 270 L=2,NR2 INJ = INJ + MD2M2 DO 270 JJ = 1,JR2 JIN = INJ + JJ + JR1 270 ALPHNO(JIN) = ALPHN(JIN) 280 INN = INN + (MN+2) * MD2M2 290 CONTINUE 300 CONTINUE 310 CONTINUE C C... PROPERLY NORMALIZE BASEF VALUES C DO 320 J=1,ND IN = IND(J) ICONS = 1 MJ = MND(J) KMJ = K + MJ MJ1 = MJ + 1 DO 320 NR = 1,MJ ICONS = ICONS * (KMJ-NR) IN = IN + 1 DO 320 L=1,KMJ LBASEF = IN + (L-1) * MJ1 BASEF(LBASEF) = BASEF(LBASEF) * DFLOAT(ICONS) 320 CONTINUE C C... COPY BASEF VALUES CORRESPONDING TO EQUAL ORDER SOLUTION COMPONENTS C IF (NEQ .EQ. 0) RETURN JD = 1 DO 360 J=1,NEQ IN1 = INEQ(J) 330 IF (IN1 .LT. IND(JD+1)) GO TO 340 JD = JD + 1 GO TO 330 340 MJ = MND(JD) NTOT = (K+MJ)*(1+MJ) IN2 = IND(JD) DO 350 L=1,NTOT 350 BASEF(IN1-1+L) = BASEF(IN2-1+L) 360 CONTINUE RETURN END C C....................................................................... C SUBROUTINE APPDIF (ALDIF, ALPHA, XI, N, K, NCOMP, M, MSTAR) C C*********************************************************************** C C PURPOSE C COMPUTE A DIVIDED DIFFERENCE TABLE BASED UPON THE VECTOR C OF SOLUTION COMPONENTS C C VARIABLES C ALPHA - VECTOR OF SOLUTION COEFFICIENTS (FOR ALL COMPONENTS) C CORRESPONDING TO THE MESH XI(1),...,XI(N+1) C ALDIF - THE DIVIDED DIFFERENCE ARRAY BASED UPON ALPHA, VIZ, C ALDIF(I,R,J) = (R-1)ST DIVIDED DIFFERENCE OF ALPHA C CORRESPONDING TO U (X), FOR C J C I=R,...,K+N+MJ; R=1,...,MJ; J=1,...,NCOMP C C*********************************************************************** C IMPLICIT REAL*8 (A-H,O-Z) DIMENSION ALDIF(1), ALPHA(1), XI(1), M(1) KD = K * NCOMP INCOMP = 0 K3 = 0 K4 = 0 C C... CONSTRUCT THE DIFFERENCE TABLE FOR EACH COMPONENT. C DO 130 J=1,NCOMP MJ = M(J) KMJ = K - MJ MJM1 = MJ - 1 KMR = K + MJ NALPHJ = N * K + MJ INN = INCOMP K1 = MSTAR K2 = KD K5 = INN + 1 C C... COPY ALPHA INTO THE FIRST ROWS (NR=0) OF ALDIF C DO 10 L=1,MJ ALDIF(K5) = ALPHA(K3+L) 10 K5 = K5 + 1 DO 50 I = 1, N IF (KMJ .EQ. 0) GO TO 30 DO 20 L = 1, KMJ ALDIF(K5) = ALPHA(K1+K4+L) 20 K5 = K5 + 1 30 DO 40 L = 1, MJ ALDIF(K5) = ALPHA(K2+K3+L) 40 K5 = K5 + 1 K1 = K1 + KD K2 = K2 + KD 50 CONTINUE C C... FOR EACH DERIVATIVE NR COMPUTE DIVIDED DIFFERENCES C IF (MJM1 .EQ. 0) GO TO 120 DO 110 NR = 1, MJM1 INN1 = INN + NALPHJ KMR = KMR - 1 MJR = MJ - NR KMJR = K - MJR XIP1 = XI(1) DNK2 = DFLOAT(KMR) / (XI(2) - XIP1) C C... FOR XI(1),XI(2), THE DIVIDED DIFFERENCE IS A SPECIAL CASE C DO 60 L=1,NR 60 ALDIF(INN1+L) = 0.D0 DO 70 L = NR, MJM1 L1 = L + 1 70 ALDIF(INN1+L1) = (ALDIF(INN+L1) - ALDIF(INN+L)) * 1 DNK2 IBEG1 = MJ IBEG2 = K + NR C C... NOW THE DIVIDED DIFFERENCE CALCULATIONS FOR XI(I),XI(I+1), C... I=1,...,N C DO 100 I = 1, N XII = XIP1 XIP1 = XI(I+1) DNK1 = DFLOAT(KMR) / (XIP1 - XII) IF (I .LT. N) DNK2 = DFLOAT(KMR) / (XI(I+2) - XII) IF (I .EQ. N) DNK2 = DNK1 C C... THE ACTUAL CALCULATIONS INVOLVE TWO LOOPS C DO 80 L = 1, KMJR L1 = IBEG1 + L 80 ALDIF(INN1+L1) = (ALDIF(INN+L1) - ALDIF(INN+L1-1)) * 1 DNK1 DO 90 L = 1, MJR L1 = IBEG2 + L 90 ALDIF(INN1+L1) = (ALDIF(INN+L1) - ALDIF(INN+L1-1)) * 1 DNK2 IBEG1 = IBEG1 + K IBEG2 = IBEG2 + K 100 CONTINUE INN = INN1 110 CONTINUE 120 CONTINUE K3 = K3 + MJ K4 = K4 + KMJ INCOMP = INCOMP + NALPHJ * MJ 130 CONTINUE RETURN END C C....................................................................... C SUBROUTINE HORDER (I, UHIGH, XIOLD, ALDIF) C C*********************************************************************** C C PURPOSE C DETERMINE HIGHEST ORDER (PIECEWISE CONSTANT) DERIVATIVES C OF THE CURRENT COLLOCATION SOLUTION C C VARIABLES C ALDIF - DIVIDED DIFFERENCES OF THE SOLUTION COEFFICIENTS ALPHA C UHIGH - THE ARRAY OF HIGHEST ORDER (PIECEWISE CONSTANT) C DERIVATIVES OF THE APPROXIMATE SOLUTION ON C (XIOLD(I),XIOLD(I+1)), VIZ, C (K+MJ-1) C UHIGH(J) = U (X) ON (XIOLD(I),XIOLD(I+1)) J=1,...,N C J C C*********************************************************************** C IMPLICIT REAL*8 (A-H,O-Z) COMMON /APPR/ N,NOLD,NMAX,NALPHA,MSHFLG,MSHNUM,MSHLMT,MSHALT COMMON /ORDER/ K,NCOMP,MSTAR,KD,KDM,MNSUM,M(20) DIMENSION UHIGH(1) , AR(20), ARM1(20) DIMENSION ALDIF(1), XIOLD(1) C DN2 = 1.D0 / (XIOLD(I+1) - XIOLD(I)) INCOMP = 0 C C... LOOP THROUGH THE NCOMP SOLUTION COMPONENTS C DO 50 J = 1,NCOMP MJ = M(J) NALPHJ = K * NOLD + MJ KPMJ = K + MJ KMR = K + 1 MJM1 = MJ - 1 INCOMP = INCOMP + MJM1 * NALPHJ LEFT = I * K + MJ - KMR C C... FURTHER DIVIDED DIFFERENCES OF THE APPROPRIATE ALDIF C... (VIZ. OF THE (MJ-1)ST DIVIDED DIFFERENCES OF THE ALPHA) ARE C... CALCULATED TO OBTAIN THE (K+MJ-1)ST DIVIDED DIFFERENCE C DO 10 L=1,KMR LEFTPL = LEFT + L 10 ARM1(L+MJ-1) = ALDIF(INCOMP+LEFTPL) INCOMP = INCOMP + NALPHJ KPMJ1 = KPMJ - 1 DO 40 NR = MJ,KPMJ1 KMR = KMR - 1 DNK2 = DN2 * DFLOAT(KMR) DO 20 L = 1,KMR 20 AR(L+NR) = DNK2 * (ARM1(L+NR) - ARM1(L+NR-1)) DO 30 L=NR,KPMJ 30 ARM1(L) = AR(L) 40 CONTINUE UHIGH(J) = AR(KPMJ) 50 CONTINUE RETURN END C C---------------------------------------------------------------- C C PROBLEM 1 - SEE COMPANION PAPER C IMPLICIT REAL*8 (A-H,O-Z) DOUBLE PRECISION FSPACE(2000), ZETA(4), TOL(2), Z(4), U(4), ERR(4) INTEGER ISPACE(200), M(1), IPAR(11), LTOL(2) EXTERNAL FSUB, DFSUB, GSUB, DGSUB C WRITE (6,99) 99 FORMAT(1H1, 35H EXAMPLE OF A SIMPLE PROBLEM SETUP. . / 46H UNIFORMLY LOADED BEAM OF VARIABLE STIFFNESS, . / 32H SIMPLY SUPPORTED AT BOTH ENDS. /) C C ONE DIFFERENTIAL EQUATION OF ORDER 4. M(1) = 4 C GIVE LOCATION OF BOUNDARY CONDITIONS ZETA(1) = 1.D0 ZETA(2) = 1.D0 ZETA(3) = 2.D0 ZETA(4) = 2.D0 C SET UP PARAMETER ARRAY. C USE DEFAULT VALUES FOR ALL PARAMETERS EXCEPT FOR INITIAL C MESH SIZE, NO. OF TOLERANCES AND SIZES OF WORK ARRAYS DO 10 I=1,11 10 IPAR(I) = 0 IPAR(3) = 1 IPAR(4) = 2 IPAR(5) = 2000 IPAR(6) = 200 C TWO ERROR TOLERANCES (ON U AND ITS SECOND DERIVATIVE) LTOL(1) = 1 LTOL(2) = 3 TOL(1) = 1.D-7 TOL(2) = 1.D-7 C CALL COLSYS (1, M, 1.D0, 2.D0, ZETA, IPAR, LTOL, TOL, . DUMMY, ISPACE, FSPACE, IFLAG, FSUB, . DFSUB, GSUB, DGSUB, DUMMY) C IF (IFLAG .NE. 1) STOP C CALCULATE THE ERROR AT 101 POINTS USING THE KNOWN C EXACT SOLUTION X = 1.D0 DO 20 I=1,4 20 ERR(I) = 0.D0 DO 40 J=1,101 CALL APPSLN (X, Z, FSPACE, ISPACE) CALL EXACT (X, U) DO 30 I=1,4 30 ERR(I) = DMAX1(ERR(I), DABS(U(I)-Z(I))) 40 X = X + .01 WRITE(6,100) (ERR(I),I=1,4) 100 FORMAT(/27H ERROR TOLERANCES SATISFIED//22H THE EXACT ERRORS ARE, . / 7X,4D12.4) STOP END C................................................................ SUBROUTINE FSUB (X, Z, F) DOUBLE PRECISION Z(4), F(1), X F(1) = (1.D0 - 6.D0*X**2*Z(4) - 6.D0*X*Z(3)) / X**3 RETURN END C................................................................ SUBROUTINE DFSUB (X, Z, DF) DOUBLE PRECISION Z(4), DF(1,4), X DF(1,1) = 0.D0 DF(1,2) = 0.D0 DF(1,3) = -6.D0/X**2 DF(1,4) = -6.D0/X RETURN END C................................................................ SUBROUTINE GSUB (I, Z, G) DOUBLE PRECISION Z(4), G GO TO (1, 2, 1, 2), I 1 G = Z(1) - 0.D0 RETURN 2 G = Z(3) - 0.D0 RETURN END C................................................................ SUBROUTINE DGSUB (I, Z, DG) DOUBLE PRECISION Z(4), DG(4) DO 10 J=1,4 10 DG(J) = 0.D0 GO TO (1, 2, 1, 2), I 1 DG(1) = 1.D0 RETURN 2 DG(3) = 1.D0 RETURN END C................................................................ SUBROUTINE EXACT(X, U) IMPLICIT REAL*8 (A-H,O-Z) DOUBLE PRECISION U(4) C EXACT SOLUTION U(1) = .25D0* (10.D0*DLOG(2.D0)-3.D0) * (1.D0-X) + . .5D0* (1.D0/X+ (3.D0+X)*DLOG(X) - X) U(2) = -.25D0* (10.D0*DLOG(2.D0) - 3.D0) + .5D0 * . (-1.D0/X/X + DLOG(X) + (3.D0+X)/X - 1.D0) U(3) = .5D0 * (2.D0/X**3 + 1.D0/X -3.D0/X/X) U(4) = .5D0 * (-6.D0/X**4 - 1.D0/X/X + 6.D0/X**3) RETURN END C C---------------------------------------------------------------- C C PROBLEM 2 - SEE COMPANION PAPER C IMPLICIT REAL*8 (A-H,O-Z) DOUBLE PRECISION ZETA(4), FSPACE(40000), TOL(4), Z(4) INTEGER M(2), IPAR(11), ISPACE(2500), LTOL(4) COMMON EPS, DMU, EPS4MU, GAMMA, XT EXTERNAL SOLUTN,FSUB,DFSUB,GSUB,DGSUB C DEFINE CONSTANTS, PRINT A HEADING. GAMMA = 1.1D0 EPS = .01D0 DMU = EPS EPS4MU = EPS**4/DMU XT = DSQRT(2.D0*(GAMMA-1.D0)/GAMMA) WRITE (6,100) GAMMA, XT, EPS, DMU, EPS4MU 100 FORMAT(1H1,27HDIMPLING OF SPHERICAL CAPS. ./8H GAMMA =,F7.2/ 6H XT =,D12.5/ 6H EPS =,D12.5/ 6H MU =,D12.5/ . 12H EPS**4/MU =,D12.5) C DEFINE NO. OF DIFFERENTIAL EQUATIONS. NCOMP = 2 C ORDERS M(1) = 2 M(2) = 2 C INTERVAL ENDS ALEFT = 0.D0 ARIGHT = 1.D0 C LOCATIONS OF SIDE CONDITIONS ZETA(1) = 0.D0 ZETA(2) = 0.D0 ZETA(3) = 1.D0 ZETA(4) = 1.D0 C IPAR VALUES C A NONLINEAR PROBLEM IPAR(1) = 1 C 4 COLLOCATION POINTS PER SUBINTERVAL IPAR(2) = 4 C INITIAL UNIFORM MESH OF 10 SUBINTERVALS IPAR(3) = 10 IPAR(8) = 0 C DIMENSION OF REAL WORK ARRAY FSPACE IS 40000 IPAR(5) = 40000 C DIMENSION OF INTEGER WORK ARRAY ISPACE IS 2500 IPAR(6) = 2500 C (THESE DIMENSIONS OF FSPACE AND ISPACE C ENABLE COLSYS TO USE MESHES OF UP TO 192 INTERVALS.) C PRINT FULL OUTPUT. IPAR(7) = -1 C INITIAL APPROXIMATION FOR NONLINEAR ITERATION IS PROVIDED C IN SOLUTN IPAR(9) = 1 C A REGULAR PROBLEM IPAR(10) = 0 C NO FIXED POINTS IN THE MESH IPAR(11) = 0 C TOLERANCES ON ALL COMPONENTS IPAR(4) = 4 DO 10 I=1,4 LTOL(I) = I 10 TOL(I) = 1.D-5 C CALL COLSYS CALL COLSYS (NCOMP, M, ALEFT, ARIGHT, ZETA, IPAR, LTOL, . TOL, FIXPNT, ISPACE, FSPACE, IFLAG, . FSUB,DFSUB,GSUB,DGSUB,SOLUTN) C PRINT VALUES OF THE OBTAINED APPROXIMATE SOLUTION AT POINTS C X = 0,.05, ..., 1. X = 0.D0 WRITE (6,201) 201 FORMAT (1H1,44H X PHI DPHI , . 23H PSI DPSI /) 202 FORMAT (6X, F5.2, 4X, 6D15.5) NP1 = 21 DO 555 III=1,NP1 CALL APPSLN (X,Z,FSPACE,ISPACE) WRITE (6,202) X, Z X = X + .05D0 555 CONTINUE STOP END C................................................................ SUBROUTINE SOLUTN (X, Z, DMVAL) IMPLICIT REAL*8 (A-H,O-Z) COMMON EPS, DMU, EPS4MU, GAMMA, XT DIMENSION Z(4) , DMVAL(2) CONS = GAMMA * X * (1.D0-.5D0*X*X) DCONS = GAMMA * (1.D0 - 1.5D0*X*X) D2CONS = -3.D0 * GAMMA * X IF (X .GT. XT) GO TO 10 Z(1) = 2.D0 * X Z(2) = 2.D0 Z(3) = -2.D0*X + CONS Z(4) = -2.D0 + DCONS DMVAL(2) = D2CONS GO TO 20 10 Z(1) = 0.D0 Z(2) = 0.D0 Z(3) = -CONS Z(4) = -DCONS DMVAL(2) = -D2CONS 20 DMVAL(1) = 0.D0 RETURN END C................................................................ SUBROUTINE FSUB (X, Z, F) IMPLICIT REAL*8 (A-H,O-Z) DIMENSION Z(4), F(2) COMMON EPS, DMU, EPS4MU, GAMMA, XT F(1) = Z(1)/X/X - Z(2)/X + (Z(1) - Z(3)*(1.D0-Z(1)/X) - . GAMMA*X*(1.D0-X*X/2.)) / EPS4MU F(2) = Z(3)/X/X - Z(4)/X + Z(1)*(1.D0-Z(1)/2.D0/X) / DMU RETURN END C................................................................ SUBROUTINE DFSUB (X, Z, DF) IMPLICIT REAL*8 (A-H,O-Z) DIMENSION Z(4), DF(2,4) COMMON EPS, DMU, EPS4MU, GAMMA, XT DF(1,1) = 1.D0/X/X +(1.D0 + Z(3)/X) / EPS4MU DF(1,2) = -1.D0/X DF(1,3) = -(1.D0-Z(1)/X) / EPS4MU DF(1,4) = 0.D0 DF(2,1) = (1.D0 - Z(1)/X) / DMU DF(2,2) = 0.D0 DF(2,3) = 1.D0/X/X DF(2,4) = -1.D0/X RETURN END C................................................................ SUBROUTINE GSUB (I, Z, G) IMPLICIT REAL*8 (A-H,O-Z) DIMENSION Z(4) GO TO (1, 2, 1, 3), I 1 G = Z(1) RETURN 2 G = Z(3) RETURN 3 G = Z(4) - .3D0*Z(3) + .7D0 RETURN END C................................................................ SUBROUTINE DGSUB (I, Z, DG) IMPLICIT REAL*8 (A-H,O-Z) DIMENSION Z(4), DG(4) DO 10 J=1,4 10 DG(J) = 0. D0 GO TO (1, 2, 1, 3), I 1 DG(1) = 1.D0 RETURN 2 DG(3) = 1.D0 RETURN 3 DG(4) = 1.D0 DG(3) = -.3D0 RETURN END C C---------------------------------------------------------------- C C PROBLEM 3 - SEE COMPANION PAPER C IMPLICIT REAL*8 (A-H,O-Z) DOUBLE PRECISION ZETA(5), FSPACE(40000), TOL(2), SVAL(3), ELVAL(3) INTEGER M(2), ISPACE(2500), LTOL(2), IPAR(11) DOUBLE PRECISION Z(5) COMMON EN, S, EL, CONS EXTERNAL FSUB, DFSUB, GSUB, DGSUB, SOLUTN DATA SVAL/.2D0, .1D0, .05D0/, ELVAL/60.D0, 120.D0, 200.D0/ C EN = .2D0 CONS = .5D0 * (3.D0-EN) NCOMP = 2 M(1) = 2 M(2) = 3 ALEFT = 0.D0 ARIGHT = 1.D0 C ZETA(1) = 0.D0 ZETA(2) = 0.D0 ZETA(3) = 0.D0 ZETA(4) = 1.D0 ZETA(5) = 1.D0 C IPAR(1) = 1 IPAR(2) = 4 IPAR(3) = 10 IPAR(4) = 2 IPAR(5) = 40000 IPAR(6) = 2500 IPAR(7) = -1 IPAR(8) = 0 IPAR(9) = 1 IPAR(10) = 0 IPAR(11) = 0 C LTOL(1) = 1 LTOL(2) = 3 TOL(1) = 1.D-5 TOL(2) = 1.D-5 C C SOLVE A CHAIN OF 3 PROBLEMS DO 777 IJK = 1,3 S = SVAL(IJK) EL = ELVAL(IJK) IF (IJK .EQ. 1) GO TO 701 C SET CONTINUATION PARAMETERS IPAR(9) = 3 IPAR(3) = ISPACE(1) 701 CONTINUE WRITE (6,100) EN, S, EL 100 FORMAT(1H1,38H ROTATING FLOW OVER A STATIONARY DISK. . /19H PARAMETERS - N =,F5.2, 6H S =,F5.2, . 6H L =,F6.1/) C CALL COLSYS (NCOMP, M, ALEFT, ARIGHT, ZETA, IPAR, LTOL, . TOL, FIXPNT, ISPACE, FSPACE, IFLAG, . FSUB, DFSUB, GSUB, DGSUB, SOLUTN) C IF (IFLAG .NE. 1) STOP C PRINT VALUES OF THE OBTAINED APPROXIMATE SOLUTION AT POINTS C X = 0,1,2, ..., L. IS6 = ISPACE(6) IS5 = ISPACE(1) + 2 X = 0.D0 WRITE (6,201) 201 FORMAT (1H1,44H X G DG , . 38H H DH D2H/) 202 FORMAT (6D15.5) NP1 = EL + 1.5D0 DO 555 III=1,NP1 CALL APPROX (II,X,Z,FSPACE(IS6),FSPACE(1),ISPACE(1), . FSPACE(IS5),ISPACE(2),NCOMP,M,ISPACE(4),1,DM,0) XL = X * EL Z(2) = Z(2) / EL Z(4) = Z(4) / EL Z(5) = Z(5) / EL / EL WRITE (6,202) XL, Z X = X + 1.D0 / EL 555 CONTINUE 777 CONTINUE STOP END C................................................................ SUBROUTINE SOLUTN (X, Z, DMVAL) IMPLICIT REAL*8 (A-H,O-Z) COMMON EN, S, EL, CONS DOUBLE PRECISION Z(5), DMVAL(2) EX = DEXP(-EL*X) Z(1) = 1.D0 - EX Z(2) = EL * EX Z(3) = -EL**2 * X**2 * EX Z(4) = (EL**3 *X**2 - 2.D0 * EL**2 * X) * EX Z(5) = (-EL**4 * X**2 + 4.D0 * EL**3 * X - 2.D0 * EL**2)*EX DMVAL(1) = -EL * Z(2) DMVAL(2) = (EL**5*X*X - 6.D0*EL**4*X + 6.D0*EL**3) * EX RETURN END C................................................................ SUBROUTINE FSUB (X, Z, F) IMPLICIT REAL*8 (A-H,O-Z) DOUBLE PRECISION Z(1), F(1) COMMON EN, S, EL, CONS F(1) = -EL * (CONS * Z(3) * Z(2) + (EN-1.D0) * Z(4) * Z(1)) . + EL**2 * S * (Z(1)-1.D0) F(2) = -EL * (CONS * Z(3) * Z(5) + EN * Z(4)**2) + . EL**2 * S * Z(4) + EL**3 * (1.D0-Z(1)**2) RETURN END C................................................................ SUBROUTINE DFSUB (X, Z, DF) IMPLICIT REAL*8 (A-H,O-Z) DOUBLE PRECISION Z(1), DF(2,1) COMMON EN, S, EL, CONS DF(1,1) = -EL * (EN-1.D0) * Z(4) + EL**2 * S DF(1,2) = -EL * CONS * Z(3) DF(1,3) = -EL * CONS * Z(2) DF(1,4) = -EL * (EN-1.D0) * Z(1) DF(1,5) = 0.D0 DF(2,1) = -EL**3 * 2.D0 * Z(1) DF(2,2) = 0.D0 DF(2,3) = -EL * CONS * Z(5) DF(2,4) = -EL * EN * 2.D0 * Z(4) + EL**2 * S DF(2,5) = -EL * CONS * Z(3) RETURN END C................................................................ SUBROUTINE GSUB (I, Z, G) DOUBLE PRECISION Z(1), G GO TO (1, 2, 3, 4, 3), I 1 G = Z(1) RETURN 2 G = Z(3) RETURN 3 G = Z(4) RETURN 4 G = Z(1) - 1.D0 RETURN END C................................................................ SUBROUTINE DGSUB (I, Z, DG) DOUBLE PRECISION Z(1), DG(1) DO 10 J=1,5 10 DG(J) = 0.D0 GO TO (1, 2, 3, 1, 3), I 1 DG(1) = 1.D0 RETURN 2 DG(3) = 1.D0 RETURN 3 DG(4) = 1.D0 RETURN END C C---------------------------------------------------------------- C C C----------------------------------------------------------------------- C FOR CONVENIENCE OF THE USER WE LIST HERE THE PACKAGE C SOLVEBLOK OF DE BOOR - WEISS (4), USED IN COLSYS. C----------------------------------------------------------------------- C SUBROUTINE FCBLOK ( BLOKS, INTEGS, NBLOKS, IPIVOT, SCRTCH, IFLAG ) C C****************************************************************** C C CALLS SUBROUTINES FACTRB AND SHIFTB . C C FCBLOK SUPERVISES THE PLU FACTORIZATION WITH PIVOTING OF C SCALED ROWS OF THE ALMOST BLOCK DIAGONAL MATRIX STORED IN THE C ARRAYS BLOKS AND INTEGS . C C FACTRB = SUBPROGRAM WHICH CARRIES OUT STEPS 1,...,LAST OF GAUSS C ELIMINATION (WITH PIVOTING) FOR AN INDIVIDUAL BLOCK. C SHIFTB = SUBPROGRAM WHICH SHIFTS THE REMAINING ROWS TO THE TOP OF C THE NEXT BLOCK C C PARAMETERS C BLOKS AN ARRAY THAT INITIALLY CONTAINS THE ALMOST BLOCK DIAGONA C MATRIX A TO BE FACTORED, AND ON RETURN CONTAINS THE COM- C PUTED FACTORIZATION OF A . C INTEGS AN INTEGER ARRAY DESCRIBING THE BLOCK STRUCTURE OF A . C NBLOKS THE NUMBER OF BLOCKS IN A . C IPIVOT AN INTEGER ARRAY OF DIMENSION SUM (INTEGS(1,N) ; N=1, C ...,NBLOKS) WHICH, ON RETURN, CONTAINS THE PIVOTING STRA- C TEGY USED. C SCRTCH WORK AREA REQUIRED, OF LENGTH MAX (INTEGS(1,N) ; N=1, C ...,NBLOKS). C IFLAG OUTPUT PARAMETER; C = 0 IN CASE MATRIX WAS FOUND TO BE SINGULAR. C OTHERWISE, C = (-1)**(NUMBER OF ROW INTERCHANGES DURING FACTORIZATION) C C*********************************************************************** C INTEGER INTEGS(3,NBLOKS),IPIVOT(1),IFLAG, I,INDEX,INDEXB,INDEXN, 1 LAST,NCOL,NROW DOUBLE PRECISION BLOKS(1),SCRTCH(1) IFLAG = 1 INDEXB = 1 INDEXN = 1 I = 1 C C... LOOP OVER THE BLOCKS. I IS LOOP INDEX C 10 INDEX = INDEXN NROW = INTEGS(1,I) NCOL = INTEGS(2,I) LAST = INTEGS(3,I) C C... CARRY OUT ELIMINATION ON THE I-TH BLOCK UNTIL NEXT BLOCK C... ENTERS, I.E., FOR COLUMNS 1,...,LAST OF I-TH BLOCK. C CALL FACTRB ( BLOKS(INDEX), IPIVOT(INDEXB), SCRTCH, NROW, 1 NCOL, LAST, IFLAG) C C... CHECK FOR HAVING REACHED A SINGULAR BLOCK OR THE LAST BLOCK C IF (IFLAG .EQ. 0 .OR. I .EQ. NBLOKS) RETURN I = I+1 INDEXN = NROW*NCOL + INDEX C C... PUT THE REST OF THE I-TH BLOCK ONTO THE NEXT BLOCK C CALL SHIFTB ( BLOKS(INDEX), IPIVOT(INDEXB), NROW, NCOL, 1 LAST, BLOKS(INDEXN), INTEGS(1,I), INTEGS(2,I) ) INDEXB = INDEXB + NROW GO TO 10 END C C....................................................................... C SUBROUTINE FACTRB ( W, IPIVOT, D, NROW, NCOL, LAST, IFLAG ) C C*********************************************************************** C C ADAPTED FROM P.132 OF ELEMENT.NUMER.ANALYSIS BY CONTE-DE BOOR C C CONSTRUCTS A PARTIAL PLU FACTORIZATION, CORRESPONDING TO STEPS C 1,..., LAST IN GAUSS ELIMINATION, FOR THE MATRIX W OF C ORDER ( NROW , NCOL ), USING PIVOTING OF SCALED ROWS. C C PARAMETERS C W CONTAINS THE (NROW,NCOL) MATRIX TO BE PARTIALLY FACTORED C ON INPUT, AND THE PARTIAL FACTORIZATION ON OUTPUT. C IPIVOT AN INTEGER ARRAY OF LENGTH NROW CONTAINING A RECORD OF C THE PIVOTING STRATEGY USED; ROW IPIVOT(I) IS USED C DURING THE I-TH ELIMINATION STEP, I=1,...,LAST. C D A WORK ARRAY OF LENGTH NROW USED TO STORE ROW SIZES C TEMPORARILY. C NROW NUMBER OF ROWS OF W. C NCOL NUMBER OF COLUMNS OF W. C LAST NUMBER OF ELIMINATION STEPS TO BE CARRIED OUT. C IFLAG ON OUTPUT, EQUALS IFLAG ON INPUT TIMES (-1)**(NUMBER OF C ROW INTERCHANGES DURING THE FACTORIZATION PROCESS), IN C CASE NO ZERO PIVOT WAS ENCOUNTERED. C OTHERWISE, IFLAG = 0 ON OUTPUT. C C*********************************************************************** C INTEGER IPIVOT(NROW),NCOL,LAST,IFLAG, I,IPIVI,IPIVK,J,K,KP1 DOUBLE PRECISION W(NROW,NCOL),D(NROW), AWIKDI,COLMAX,RATIO,ROWMAX DOUBLE PRECISION DABS,DMAX1 C C... INITIALIZE IPIVOT, D C DO 20 I=1,NROW IPIVOT(I) = I ROWMAX = 0.D0 DO 10 J=1,NCOL 10 ROWMAX = DMAX1(ROWMAX, DABS(W(I,J))) IF (ROWMAX .EQ. 0.D0) GO TO 90 20 D(I) = ROWMAX C C... GAUSS ELIMINATION WITH PIVOTING OF SCALED ROWS, LOOP OVER C... K=1,.,LAST C K = 1 C C... AS PIVOT ROW FOR K-TH STEP, PICK AMONG THE ROWS NOT YET USED, C... I.E., FROM ROWS IPIVOT(K),...,IPIVOT(NROW), THE ONE WHOSE K-TH C... ENTRY (COMPARED TO THE ROW SIZE) IS LARGEST. THEN, IF THIS ROW C... DOES NOT TURN OUT TO BE ROW IPIVOT(K), REDEFINE IPIVOT(K) AP- C... PROPRIATELY AND RECORD THIS INTERCHANGE BY CHANGING THE SIGN C... OF IFLAG . C 30 IPIVK = IPIVOT(K) IF (K .EQ. NROW) GO TO 80 J = K KP1 = K+1 COLMAX = DABS(W(IPIVK,K))/D(IPIVK) C C... FIND THE (RELATIVELY) LARGEST PIVOT C DO 40 I=KP1,NROW IPIVI = IPIVOT(I) AWIKDI = DABS(W(IPIVI,K))/D(IPIVI) IF (AWIKDI .LE. COLMAX) GO TO 40 COLMAX = AWIKDI J = I 40 CONTINUE IF (J .EQ. K) GO TO 50 IPIVK = IPIVOT(J) IPIVOT(J) = IPIVOT(K) IPIVOT(K) = IPIVK IFLAG = -IFLAG 50 CONTINUE C C... IF PIVOT ELEMENT IS TOO SMALL IN ABSOLUTE VALUE, DECLARE C... MATRIX TO BE NONINVERTIBLE AND QUIT. C IF (DABS(W(IPIVK,K))+D(IPIVK) .LE. D(IPIVK)) 1 GO TO 90 C C... OTHERWISE, SUBTRACT THE APPROPRIATE MULTIPLE OF THE PIVOT C... ROW FROM REMAINING ROWS, I.E., THE ROWS IPIVOT(K+1),..., C... IPIVOT(NROW), TO MAKE K-TH ENTRY ZERO. SAVE THE MULTIPLIER C... IN ITS PLACE. C DO 60 I=KP1,NROW IPIVI = IPIVOT(I) W(IPIVI,K) = W(IPIVI,K)/W(IPIVK,K) RATIO = -W(IPIVI,K) DO 60 J=KP1,NCOL 60 W(IPIVI,J) = RATIO*W(IPIVK,J) + W(IPIVI,J) K = KP1 C C... CHECK FOR HAVING REACHED THE NEXT BLOCK. C IF (K .LE. LAST) GO TO 30 RETURN C C... IF LAST .EQ. NROW , CHECK NOW THAT PIVOT ELEMENT IN LAST ROW C... IS NONZERO. C 80 IF(DABS(W(IPIVK,NROW))+D(IPIVK) .GT. D(IPIVK)) RETURN C C... SINGULARITY FLAG SET C 90 IFLAG = 0 RETURN END C C...................................................................... C SUBROUTINE SHIFTB ( AI, IPIVOT, NROWI, NCOLI, LAST, 1 AI1, NROWI1, NCOLI1 ) C C********************************************************************** C C SHIFTS THE ROWS IN CURRENT BLOCK, AI, NOT USED AS PIVOT ROWS, IF C ANY, I.E., ROWS IPIVOT(LAST+1),...,IPIVOT(NROWI), ONTO THE FIRST C MMAX = NROW-LAST ROWS OF THE NEXT BLOCK, AI1, WITH COLUMN LAST+J C OF AI GOING TO COLUMN J , J=1,...,JMAX=NCOLI-LAST. THE REMAINING C COLUMNS OF THESE ROWS OF AI1 ARE ZEROED OUT. C C PICTURE C C ORIGINAL SITUATION AFTER RESULTS IN A NEW BLOCK I+1 C LAST = 2 COLUMNS HAVE BEEN CREATED AND READY TO BE C DONE IN FACTRB (ASSUMING NO FACTORED BY NEXT FACTRB C INTERCHANGES OF ROWS) CALL. C 1 C X X 1X X X X X X X X C 1 C 0 X 1X X X 0 X X X X C BLOCK I 1 --------------- C NROWI = 4 0 0 1X X X 0 0 1X X X 0 01 C NCOLI = 5 1 1 1 C LAST = 2 0 0 1X X X 0 0 1X X X 0 01 C ------------------------------- 1 1 NEW C 1X X X X X 1X X X X X1 BLOCK C 1 1 1 I+1 C BLOCK I+1 1X X X X X 1X X X X X1 C NROWI1= 5 1 1 1 C NCOLI1= 5 1X X X X X 1X X X X X1 C ------------------------------- 1-------------1 C 1 C C*********************************************************************** C INTEGER IPIVOT(NROWI),LAST, IP,J,JMAX,JMAXP1,M,MMAX DOUBLE PRECISION AI(NROWI,NCOLI),AI1(NROWI1,NCOLI1) MMAX = NROWI - LAST JMAX = NCOLI - LAST IF (MMAX .LT. 1 .OR. JMAX .LT. 1) RETURN C C... PUT THE REMAINDER OF BLOCK I INTO AI1 C DO 10 M=1,MMAX IP = IPIVOT(LAST+M) DO 10 J=1,JMAX 10 AI1(M,J) = AI(IP,LAST+J) IF (JMAX .EQ. NCOLI1) RETURN C C... ZERO OUT THE UPPER RIGHT CORNER OF AI1 C JMAXP1 = JMAX + 1 DO 20 J=JMAXP1,NCOLI1 DO 20 M=1,MMAX 20 AI1(M,J) = 0.D0 RETURN END C C...................................................................... C SUBROUTINE SBBLOK ( BLOKS, INTEGS, NBLOKS, IPIVOT, B, X ) C C********************************************************************** C C CALLS SUBROUTINES SUBFOR AND SUBBAK . C C SUPERVISES THE SOLUTION (BY FORWARD AND BACKWARD SUBSTITUTION) OF C THE LINEAR SYSTEM A*X = B FOR X, WITH THE PLU FACTORIZATION OF C A ALREADY GENERATED IN FCBLOK . INDIVIDUAL BLOCKS OF C EQUATIONS ARE SOLVED VIA SUBFOR AND SUBBAK . C C PARAMETERS C BLOKS, INTEGS, NBLOKS, IPIVOT ARE AS ON RETURN FROM FCBLOK. C B THE RIGHT SIDE, STORED CORRESPONDING TO THE STORAGE OF C THE EQUATIONS. SEE COMMENTS IN S L V B L K FOR DETAILS. C X SOLUTION VECTOR C C*********************************************************************** C INTEGER INTEGS(3,NBLOKS),IPIVOT(1), I,INDEX,INDEXB,INDEXX,J,LAST, 1 NBP1,NCOL,NROW DOUBLE PRECISION BLOKS(1),B(1),X(1) C C... FORWARD SUBSTITUTION PASS C INDEX = 1 INDEXB = 1 INDEXX = 1 DO 10 I=1,NBLOKS NROW = INTEGS(1,I) LAST = INTEGS(3,I) CALL SUBFOR ( BLOKS(INDEX), IPIVOT(INDEXB), NROW, LAST, 1 B(INDEXB), X(INDEXX) ) INDEX = NROW*INTEGS(2,I) + INDEX INDEXB = INDEXB + NROW 10 INDEXX = INDEXX + LAST C C... BACK SUBSTITUTION PASS C NBP1 = NBLOKS + 1 DO 20 J=1,NBLOKS I = NBP1 - J NROW = INTEGS(1,I) NCOL = INTEGS(2,I) LAST = INTEGS(3,I) INDEX = INDEX - NROW*NCOL INDEXB = INDEXB - NROW INDEXX = INDEXX - LAST 20 CALL SUBBAK ( BLOKS(INDEX), IPIVOT(INDEXB), NROW, NCOL, 1 LAST, X(INDEXX) ) RETURN END C C...................................................................... C SUBROUTINE SUBFOR ( W, IPIVOT, NROW, LAST, B, X ) C C*********************************************************************** C C CARRIES OUT THE FORWARD PASS OF SUBSTITUTION FOR THE CURRENT C BLOCK, I.E., THE ACTION ON THE RIGHT SIDE CORRESPONDING TO THE C ELIMINATION CARRIED OUT IN FACTRB FOR THIS BLOCK. C AT THE END, X(J) CONTAINS THE RIGHT SIDE OF THE TRANSFORMED C IPIVOT(J)-TH EQUATION IN THIS BLOCK, J=1,...,NROW. THEN, SINCE C FOR I=1,...,NROW-LAST, B(NROW+I) IS GOING TO BE USED AS THE RIGHT C SIDE OF EQUATION I IN THE NEXT BLOCK (SHIFTED OVER THERE FROM C THIS BLOCK DURING FACTORIZATION), IT IS SET EQUAL TO X(LAST+I) C HERE. C C PARAMETERS C W, IPIVOT, NROW, LAST ARE AS ON RETURN FROM FACTRB. C B(J) IS EXPECTED TO CONTAIN, ON INPUT, THE RIGHT SIDE OF J-TH C EQUATION FOR THIS BLOCK, J=1,...,NROW. C B(NROW+J) CONTAINS, ON OUTPUT, THE APPROPRIATELY MODIFIED RIGHT C SIDE FOR EQUATION J IN NEXT BLOCK, J=1,...,NROW-LAST. C X(J) CONTAINS, ON OUTPUT, THE APPROPRIATELY MODIFIED RIGHT C SIDE OF EQUATION IPIVOT(J) IN THIS BLOCK, J=1,...,LAST C (AND EVEN FOR J=LAST+1,...,NROW). C C*********************************************************************** C INTEGER IPIVOT(NROW), IP,JMAX,K DOUBLE PRECISION W(NROW,LAST),B(1),X(NROW),SUM IP = IPIVOT(1) X(1) = B(IP) IF (NROW .EQ. 1) GO TO 40 DO 20 K=2,NROW IP = IPIVOT(K) JMAX = MIN0(K-1,LAST) SUM = 0.D0 DO 10 J=1,JMAX 10 SUM = W(IP,J)*X(J) + SUM 20 X(K) = B(IP) - SUM C C... TRANSFER MODIFIED RIGHT SIDES OF EQUATIONS IPIVOT(LAST+1),..., C... IPIVOT(NROW) TO NEXT BLOCK. C NROWML = NROW - LAST IF (NROWML .EQ. 0) GO TO 40 LASTP1 = LAST+1 DO 30 K=LASTP1,NROW 30 B(NROWML+K) = X(K) 40 RETURN END C C...................................................................... C SUBROUTINE SUBBAK ( W, IPIVOT, NROW, NCOL, LAST, X ) C C*********************************************************************** C C CARRIES OUT BACKSUBSTITUTION FOR CURRENT BLOCK. C C PARAMETERS C W, IPIVOT, NROW, NCOL, LAST ARE AS ON RETURN FROM FACTRB. C X(1),...,X(NCOL) CONTAINS, ON INPUT, THE RIGHT SIDE FOR THE C EQUATIONS IN THIS BLOCK AFTER BACKSUBSTITUTION HAS BEEN C CARRIED UP TO BUT NOT INCLUDING EQUATION IPIVOT(LAST). C MEANS THAT X(J) CONTAINS THE RIGHT SIDE OF EQUATION IPI- C VOT(J) AS MODIFIED DURING ELIMINATION, J=1,...,LAST, C WHILE FOR J .GT. LAST, X(J) IS ALREADY A COMPONENT OF C THE SOLUTION VECTOR. C X(1),...,X(NCOL) CONTAINS, ON OUTPUT, THE COMPONENTS OF THE C SOLUTION CORRESPONDING TO THE PRESENT BLOCK. C C********************************************************************** C INTEGER IPIVOT(NROW),LAST, IP,J,K,KP1 DOUBLE PRECISION W(NROW,NCOL),X(NCOL), SUM K = LAST IP = IPIVOT(K) SUM = 0.D0 IF (K .EQ. NCOL) GO TO 30 KP1 = K+1 10 DO 20 J=KP1,NCOL 20 SUM = W(IP,J)*X(J) + SUM 30 X(K) = (X(K) - SUM)/W(IP,K) IF (K .EQ. 1) RETURN KP1 = K K = K-1 IP = IPIVOT(K) SUM = 0.D0 GO TO 10 END