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
