C      ALGORITHM 652 (NEW VERSION), COLLECTED ALGORITHMS FROM ACM.
C      THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE,
C      VOL. 13, NO. 3, PP. 281-310.
 
C
C      HOMPACK is a suite of FORTRAN 77 subroutines for solving nonlinear
C systems of equations by homotopy methods.  There are subroutines for
C fixed point, zero finding, and general homotopy curve tracking problems,
C utilizing both dense and sparse Jacobian matrices, and implementing
C three different algorithms: ODE-based, normal flow, and augmented
C Jacobian.  The (driver) subroutines called by the user are given in the
C table below, and are well documented internally.  The user need not
C be concerned with any other subroutines in HOMPACK.
C
C
C                  Problem type
C --------|--------|--------|--------|--------|--------|
C      x = f(x)    |    F(x) = 0     |rho(a,lambda,x)=0|
C --------|--------|--------|--------|--------|--------|
C  dense  | sparse | dense  | sparse | dense  | sparse |  Algorithm
C --------|--------|--------|--------|--------|--------|---------------------
C  FIXPDF | FIXPDS | FIXPDF | FIXPDS | FIXPDF | FIXPDS | ODE based
C --------|--------|--------|--------|--------|--------|---------------------
C  FIXPNF | FIXPNS | FIXPNF | FIXPNS | FIXPNF | FIXPNS | normal flow
C --------|--------|--------|--------|--------|--------|---------------------
C  FIXPQF | FIXPQS | FIXPQF | FIXPQS | FIXPQF | FIXPQS | augmented Jacobian
C --------|--------|--------|--------|--------|--------|---------------------
C
C
C The sparse subroutines use the packed skyline storage scheme standard in
C structural mechanics, but any sparse storage scheme can be used by
C replacing some of the low-level HOMPACK routines with user-written
C routines.  The stepping subroutines STEP?? may be of interest to some
C users with special curve tracking needs.
C
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 
ORGANIZATIONAL DETAILS.  HOMPACK is organized in two
different ways: by algorithm/problem type and by subroutine level. There
are three levels of subroutines. The top level consists of drivers, one for
each problem type and algorithm type. Normally these drivers are called by
the user, and the user need know nothing beyond them. They allocate storage
for the lower level routines, and all the arrays are variable dimension, so
there is no limit on problem size. The second subroutine level implements
the major components of the algorithms such as stepping along the homotopy
zero curve, computing tangents, and the end game for the solution at
lambda = 1 . A sophisticated user might call these routines directly to
have complete control of the algorithm, or for some other task such as
tracking an arbitrary parametrized curve over an arbitrary parameter range.
The lowest subroutine level handles the numerical linear algebra, and
includes some BLAS routines. All the linear algebra and associated data
structure handling are concentrated in these routines, so a user could
incorporate his own data structures by writing his own versions of these
low level routines.
 
The organization of HOMPACK by algorithm/problem type is shown in the
above table, which lists the driver name for each algorithm and problem type.
Using brackets to indicate the three subroutine levels described above,
the natural grouping of the HOMPACK routines is:
 
[FIXPDF] [FODE, ROOT, SINTRP, STEPS] [DCPOSE]
 
[FIXPDS] [FODEDS, ROOT, SINTRP, STEPDS] [GMFADS,
     MFACDS, MULTDS, PCGDS, QIMUDS, SOLVDS]
 
[FIXPNF] [ROOTNF, STEPNF, [TANGNF]] [ROOT]
 
[FIXPNS] [ROOTNS, STEPNS, TANGNS] [GMFADS,
     MFACDS, MULTDS, PCGDS, PCGNS, QIMUDS, ROOT, SOLVDS]
 
[FIXPQF] [ROOTQF, STEPQF, TANGQF] [QRFAQF, QRSLQF, R1UPQF, UPQRQF]
 
[FIXPQS] [ROOTQS, STEPQS, TANGQS] [GMFADS, MULTDS, PCGQS, SOLVDS]
 
[POLSYS] [POLYNF, POLYP, ROOTNF, STEPNF, TANGNF]
     [DIVP, FFUNP, GFUNP, HFUNP, HFUN1P, INITP, MULP, OTPUTP, POWP,
     RHO, RHOJAC, ROOT, SCLGNP, STRPTP]
 
The BLAS subroutines used by HOMPACK are DAXPY, DCOPY, DDOT, DNRM2, DSCAL,
D1MACH, IDAMAX.
 
The user written subroutines, of which exactly two must be supplied
depending on the driver chosen, are F, FJAC, FJACS, RHO, RHOA, RHOJAC,
RHOJS.
 
For testing, there are three main test programs MAINF, MAINP, and MAINS,
and one data file INNHP.DAT (read by MAINP).
 
Inquiries should be directed to Layne T. Watson, Department of Computer
Science, VPI & SU, Blacksburg, VA 24061; (703) 961-7540; watson@cs.vt.edu
ltw@vtopus.cs.vt.edu
 
C      MAIN PROGRAM TO TEST FIXPNF, FIXPQF, AND FIXPDF
C       BROWN'S FUNCTION, ZERO FINDING.
C
C       THIS PROGRAM TESTS THE HOMPACK ROUTINES FIXPNF, FIXPQF, AND
C       FIXPDF.  THE USER MAY INSERT CALLS TO A SYSTEM TIMER AT THE
C       DESIGNATED LOCATIONS IN ORDER TO GET EXECUTION TIME FOR THESE
C       ROUTINES.
C
C       THE MODIFICATIONS TO BE MADE FOR THE SYSTEM TIMER ARE INDICATED
C       BY A LINE OF M'S, E.G.
CMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM
C
C
C       THE OUTPUT FROM THIS ROUTINE SHOULD BE AS FOLLOWS, WITH THE
C       EXECUTION TIMES CORRESPONDING TO A VAX 11/785.
C
C       TESTING FIXPQF
C
C LAMBDA = 1.00000000  FLAG = 1       6 JACOBIAN EVALUATIONS
C EXECUTION TIME(SECS) =      0.44    ARCLEN =     2.693
C   1.00000000E+00  1.00000000E+00  1.00000000E+00
C   1.00000000E+00  1.00000000E+00
C
C       TESTING FIXPNF
C
C LAMBDA = 1.00000000  FLAG = 1      22 JACOBIAN EVALUATIONS
C EXECUTION TIME(SECS) =      0.19   ARCLEN =     2.682
C   1.00000000E+00  1.00000000E+00  1.00000000E+00
C   1.00000000E+00  1.00000000E+00
C
C       TESTING FIXPDF
C
C LAMBDA = 1.00000000  FLAG = 1      71 JACOBIAN EVALUATIONS
C EXECUTION TIME(SECS) =      0.57   ARCLEN =     2.712
C   1.00000000E+00  1.00000000E+00  1.00000000E+00
C   1.00000000E+00  1.00000000E+00
C
C
C
       PROGRAM TEST1
       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
       DOUBLE PRECISION WT(101),PHI(101,16),P(101)
       DOUBLE PRECISION ARCLEN,QT(101,101),R(101*52),F0(101)
       DOUBLE PRECISION F1(101),DZ(101),T(101)
       DOUBLE PRECISION Y(101),W(101),WP(101),Z0(101),Z1(101),
     + YP(101),YOLD(101),YPOLD(101),A(100),QR(101,102),
     + ALPHA(100),TZ(101),SSPAR(8),YSAV(101),PAR(1)
       INTEGER PIVOT(101),CODE,TIME,IPAR(1),N,NDIMA,NFE,TRACE,
     +   IFLAG,II,J,NP1
       CHARACTER*6 NAME
       REAL DTIME
       COMMON /SIZE/ N
C
C TEST EACH OF THE THREE ALGORITHMS.
C
       DO 60 II=1,3
C
C INITIALIZE TIMER VARIABLES.
C
          CODE=2
          TIME=0
          DTIME=0.0
C
C DEFINE ARGUMENTS FOR CALL TO HOMPACK PROCEDURE.
C
          N=5
          NP1=N+1
          ARCRE=0.5D-4
          ARCAE=0.5D-4
          ANSRE=1.0D-10
          ANSAE=1.0D-10
          TRACE=0
          DO 30 J=1,8
30           SSPAR(J)=0.0
          IFLAG=-1
          DO 40 J=2,NP1
40           Y(J)=0.0D0
C
CMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM
C
C INSERT CALL TO INITIALIZE SYSTEM TIMER HERE.  FOR EXAMPLE, FOR
C THE VAX, THE FOLLOWING STATEMENT IS USED.
C
C         CALL LIB$INIT_TIMER
C
CMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM
C
C CALL TO HOMPACK ROUTINE.
C
        IF (II .EQ. 1) THEN
           NAME='FIXPQF'
           CALL FIXPQF(N,Y,IFLAG,ARCRE,ARCAE,ANSRE,ANSAE,TRACE,A,NFE,
     +       ARCLEN,YP,YOLD,YPOLD,QT,R,F0,F1,Z0,DZ,W,T,YSAV,
     +       SSPAR,PAR,IPAR)
        ELSE IF (II .EQ. 2) THEN
           NAME='FIXPNF'
           CALL FIXPNF(N,Y,IFLAG,ARCRE,ARCAE,ANSRE,ANSAE,TRACE,A,NFE,
     +       ARCLEN,YP,YOLD,YPOLD,QR,ALPHA,TZ,PIVOT,W,WP,Z0,Z1,
     +       SSPAR,PAR,IPAR)
        ELSE
           NAME='FIXPDF'
           CALL FIXPDF(N,Y,IFLAG,ARCRE,ANSRE,TRACE,A,NDIMA,NFE,
     +       ARCLEN,YP,YPOLD,QR,ALPHA,TZ,PIVOT,WT,PHI,P,PAR,IPAR)
        END IF
C
CMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM
C
C INSERT CALL TO RETURN EXECUTION TIME IN SECONDS IN  DTIME.
C FOR EXAMPLE, THE VAX STATEMENTS ARE AS FOLLOWS.
C      CALL LIB$STAT_TIMER(CODE,TIME)
C      DTIME=TIME/100.0
C
CMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM
C
          WRITE (6,45) NAME
45        FORMAT (//,8X,'TESTING',1X,6A)
          WRITE (6,50) Y(1),IFLAG,NFE,DTIME,ARCLEN,(Y(J),J=2,NP1)
50        FORMAT(//' LAMBDA =',F11.8,'  FLAG =',I2,I8,' JACOBIAN ',
     +    'EVALUATIONS',/,1X,'EXECUTION TIME(SECS) =',F10.2,4X,
     +     'ARCLEN =',F10.3/(1X,1P,3E16.8))
60     CONTINUE
400    STOP
       END
       SUBROUTINE F(X,V)
C********************************************************************
C
C      SUBROUTINE F(X,V) -- EVALUATES BROWN'S FUNCTION AT THE POINT
C         X, AND RETURNS THE VALUE IN V.
C
C********************************************************************
C
       DOUBLE PRECISION X(1),V(1),PROD,SUM
       INTEGER J,N
       COMMON /SIZE/ N
       PROD=1.0D0
       DO 10 J=1,N
10     PROD=PROD*X(J)
       V(1)=PROD-1.0D0
       SUM=0.0D0
       DO 20 J=1,N
20     SUM=SUM+X(J)
       SUM=SUM-DBLE(N+1)
       DO 30 J=2,N
30     V(J)=SUM+X(J)
       RETURN
       END
       SUBROUTINE FJAC(X,V,K)
C********************************************************************
C
C      SUBROUTINE FJAC(X,V,K)  --  EVALUATES THE K-TH COLUMN OF
C         THE JACOBIAN MATRIX FOR BROWN'S FUNCTION EVALUATED AT
C         THE POINT X, RETURNING THE VALUE IN V.
C
C********************************************************************
C
       DOUBLE PRECISION X(1),V(1),PROD
       INTEGER J,K,N
       COMMON /SIZE/ N
       PROD=1.0D0
       DO 10 J=1,K-1
10     PROD=PROD*X(J)
       DO 15 J=K+1,N
15     PROD=PROD*X(J)
       V(1)=PROD
       DO 20 J=2,N
20     V(J)=1.0D0
       IF (K .GT. 1) V(K)=V(K)+1.0D0
       RETURN
       END
C
C MAIN ROUTINE TO TEST POLSYS
C
C THIS ROUTINE REQUIRES ONE INPUT FILE, READ AS UNIT FOR007.
C
C A SAMPLE INPUT FILE AND ASSOCIATED OUTPUT ARE GIVEN
C IN THE COMMENTS THAT FOLLOW.  THIS SAMPLE PROBLEM IS
C CITED IN THE HOMPACK REPORT.
C
C***** SAMPLE INPUT DATA:
C TWO QUADRICS, NO SOLUTIONS AT INFINITY, TWO REAL SOLUTIONS.
C 00001       IFLGHM
C 00001       IFLGSC
C     4       ITOTDG
C                 1.D-04    EPSBIG
C                 1.D-14    EPSSML
C                 1.D-00    SSPAR(5)
C    10       NUMRR
C     2       N
C 00006                     NUMTRM(1)
C 00002                     DEG(1,1,1)
C 00000                     DEG(1,2,1)
C            -.00098D 00
C 00000                     DEG(1,1,2)
C 00002                     DEG(1,2,2)
C            978000.D 00
C 00001                     DEG(1,1,3)
C 00001                     DEG(1,2,3)
C               -9.8D 00
C 00001                     DEG(1,1,4)
C 00000                     DEG(1,2,4)
C             -235.0D 00
C 00000                     DEG(1,1,5)
C 00001                     DEG(1,2,5)
C            88900.0D 00
C 00000                     DEG(1,1,6)
C 00000                     DEG(1,2,6)
C             -1.000D 00
C 00006                     NUMTRM(2)
C 00002                     DEG(2,1,1)
C 00000                     DEG(2,2,1)
C             -.0100D 00
C 00000                     DEG(2,1,2)
C 00002                     DEG(2,2,2)
C             -.9840D 00
C 00001                     DEG(2,1,3)
C 00001                     DEG(2,2,3)
C             -29.70D 00
C 00001                     DEG(2,1,4)
C 00000                     DEG(2,2,4)
C             .00987D 00
C 00000                     DEG(2,1,5)
C 00001                     DEG(2,2,5)
C             -.1240D 00
C 00000                     DEG(2,1,6)
C 00000                     DEG(2,2,6)
C             -.2500D 00
C***** END OF SAMPLE INPUT DATA.
C
C***** ASSOCIATED SAMPLE OUTPUT:
C
C
C  POLYS TEST ROUTINE 5/20/85
C
C
C TWO QUADRICS PBHP0403, NO SOLUTIONS AT INFINITY    .........
C
C IF IFLGHM=1,HOMOGENEOUS;IF IFLGHM=2,INHOMOGENEOUS;IFLGHM= 1
C
C IF IFLGSC=1,SCLGEN USED; IF IFLGSC=2, NO SCALING; IFLGSC= 1
C
C ITOTDG=    4
C
C EPSBIG,EPSSML = 0.100000000000000D-03 0.100000000000000D-13
C NUMBER OF EQUATIONS =    2
C
C
C  NUMBER OF RECALLS WHEN IFLAG=3:     40
C
C
C
C  ****** COEFFICIENT TABLEAU ******
C
C
C  NUMT( 1)=    6
C  KDEG( 1, 1, 1)=    2
C  KDEG( 1, 2, 1)=    0
C  COEF( 1, 1)=-0.980000000000000D-03
C  KDEG( 1, 1, 2)=    0
C  KDEG( 1, 2, 2)=    2
C  COEF( 1, 2)= 0.978000000000000D+06
C  KDEG( 1, 1, 3)=    1
C  KDEG( 1, 2, 3)=    1
C  COEF( 1, 3)=-0.980000000000000D+01
C  KDEG( 1, 1, 4)=    1
C  KDEG( 1, 2, 4)=    0
C  COEF( 1, 4)=-0.235000000000000D+03
C  KDEG( 1, 1, 5)=    0
C  KDEG( 1, 2, 5)=    1
C  COEF( 1, 5)= 0.889000000000000D+05
C  KDEG( 1, 1, 6)=    0
C  KDEG( 1, 2, 6)=    0
C  COEF( 1, 6)=-0.100000000000000D+01
C
C
C  NUMT( 2)=    6
C  KDEG( 2, 1, 1)=    2
C  KDEG( 2, 2, 1)=    0
C  COEF( 2, 1)=-0.100000000000000D-01
C  KDEG( 2, 1, 2)=    0
C  KDEG( 2, 2, 2)=    2
C  COEF( 2, 2)=-0.984000000000000D+00
C  KDEG( 2, 1, 3)=    1
C  KDEG( 2, 2, 3)=    1
C  COEF( 2, 3)=-0.297000000000000D+02
C  KDEG( 2, 1, 4)=    1
C  KDEG( 2, 2, 4)=    0
C  COEF( 2, 4)= 0.987000000000000D-02
C  KDEG( 2, 1, 5)=    0
C  KDEG( 2, 2, 5)=    1
C  COEF( 2, 5)=-0.124000000000000D+00
C  KDEG( 2, 1, 6)=    0
C  KDEG( 2, 2, 6)=    0
C  COEF( 2, 6)=-0.250000000000000D+00
C
C
C
C
C  PATH NUMBER =    1
C
C  FINAL VALUES FOR PATH
C
C  ARCLEN = 0.100553311312353D+02
C  NFE =   53
C  IFLG2 =    1
C  T = 0.100000000000000D+01
C  X = 0.234233851959126D+04 0.791152831437911D-11
C  X =-0.788344824094138D+00-0.268347762088076D-14
C  X =-0.949359459408658D-02-0.106447550900261D-02
C  X =
C
C
C  PATH NUMBER =    2
C
C  FINAL VALUES FOR PATH
C
C  ARCLEN = 0.172112868960496D+01
C  NFE =   37
C  IFLG2 =    1
C  T = 0.100000000000000D+01
C  X = 0.161478579234367D-01 0.168496955498881D+01
C  X = 0.267994739614462D-03 0.442802993973661D-02
C  X =-0.381948972942403D+00 0.372068943457283D+00
C  X =
C
C
C  PATH NUMBER =    3
C
C  FINAL VALUES FOR PATH
C
C  ARCLEN = 0.202329539135269D+01
C  NFE =   35
C  IFLG2 =    1
C  T = 0.100000000000000D+01
C  X = 0.161478579234362D-01-0.168496955498881D+01
C  X = 0.267994739614461D-03-0.442802993973661D-02
C  X =-0.329370493847660D+00 0.556619775523013D+00
C  X =
C
C
C  PATH NUMBER =    4
C
C  FINAL VALUES FOR PATH
C
C  ARCLEN = 0.416327291917901D+01
C  NFE =   46
C  IFLG2 =    1
C  T = 0.100000000000000D+01
C  X = 0.908921229615394D-01-0.111985846294633D-14
C  X =-0.911497098197500D-01 0.117962440099502D-17
C  X =-0.573673395727962D-01 0.136243663709219D+00
C  X =
C
C
C  TOTAL NFE OVER ALL PATHS =        171
C
C***** END OF ASSOCIATED SAMPLE OUTPUT.
C
C *************************************************************
C
C  PROGRAM DESCRIPTION:  1. READS IN DATA.
C                        2. GENERATES POLSYS INPUT.
C                        3. CALLS POLSYS.
C                        4. WRITES POLSYS OUTPUT.
C
C DIMENSIONS SHOULD BE SET AS FOLLOWS:
C
C     DIMENSION NUMT(NN),COEF(NN,MMAXT),KDEG(NN,NN+1,MMAXT)
C     DIMENSION IFLG2(TTOTDG)
C     DIMENSION LAMBDA(TTOTDG),ROOTS(2,NN+1,TTOTDG),ARCLEN(TTOTDG),
C    + NFE(TTOTDG)
C     DIMENSION WK(LENWK),IWK(LENIWK)
C WHERE:
C    N   IS THE NUMBER OF EQUATIONS.  NN .GE. N.
C    MAXT  IS THE MAXIMUM NUMBER OF TERMS IN ANY ONE EQUATION.
C       MMAXT  .GE.  MAXT.
C    TOTDG  IS THE TOTAL DEGREE OF THE SYSTEM.  TTOTDG .GE. TOTDG.
C    LENWK  IS THE DIMENSION OF THE WORKSPACE  WK .  LENWK  MUST
C       BE GREATER THAN OR EQUAL TO
C       21 + 61*N + 10*N**2 + 7*N*MMAXT + 4*N**2*MMAXT.
C    LENIWK  IS THE DIMENSION OF THE WORKSPACE  IWK .  LENIWK  MUST BE
C       GREATER THAN OR EQUAL TO  43 + 7*N + N*(N+1)*MMAXT.
C
C THIS TEST CODE HAS DIMENSIONS SET AS FOLLOWS:
C
C NN=10, MMAXT=30, TTOTDG=999
C LENWK = 21 + 610 + 1000 + 2100 + 12000 = 15731
C LENIWK = 43 + 70 + 3300 = 3413
C
      PROGRAM TESTP
      INTEGER IFLG1,IFLG2,IFLGHM,IFLGSC,ITEST,ITOTIT,IWK,J,K,KDEG,
     + L,LENIWK,LENWK,M,MMAXT,N,NFE,NN,NP1,NT,NUMRR,NUMT,TTOTDG
      DOUBLE PRECISION ARCLEN,COEF,EPSBIG,EPSSML,LAMBDA,ROOTS,
     + SSPAR,WK
      CHARACTER*72 TITLE
C
      DIMENSION ARCLEN(999),COEF(10,30),IFLG2(999),IWK(3413),
     + KDEG(10,11,30),LAMBDA(999),NFE(999),NUMT(10),ROOTS(2,11,999),
     + SSPAR(8),WK(15731)
C
      NN=10
      MMAXT=30
      TTOTDG=999
      LENWK=15731
      LENIWK=3413
C
C
      OPEN (UNIT=7,FILE='INNHP.DAT',STATUS='UNKNOWN')
      OPEN (UNIT=6,FILE='OUTHP.DAT',STATUS='UNKNOWN')
C
          SSPAR(1)=.0
          SSPAR(2)=.0
          SSPAR(3)=.0
          SSPAR(4)=.0
          SSPAR(6)=.0
          SSPAR(7)=.0
          SSPAR(8)=.0
C
 1000 FORMAT(I5)
 2000 FORMAT(D22.15)
C
      WRITE(6,10)
  10  FORMAT( '  POLSYS TEST ROUTINE 8/12/85',//)
C
      READ(7,*) TITLE
      WRITE(6,21) TITLE
 21   FORMAT(' ',A72)
C
      READ(7,1000) IFLGHM
      READ(7,1000) IFLGSC
      READ(7,1000) TTOTDG
C
      READ(7,2000) EPSBIG
      READ(7,2000) EPSSML
      READ(7,2000) SSPAR(5)
      READ(7,1000) NUMRR
      READ(7,1000) N
C
      WRITE(6,100) IFLGHM
 100  FORMAT(/
     +' IF IFLGHM=1,HOMOGENEOUS;IF IFLGHM=0,INHOMOGENEOUS;IFLGHM=',I2)
      WRITE(6,102) IFLGSC
 102  FORMAT(/
     +' IF IFLGSC=1,SCLGNP USED; IF IFLGSC=0, NO SCALING; IFLGSC=',I2)
      WRITE(6,104) TTOTDG
 104  FORMAT(/,' TTOTDG=',I5)
C
C
      WRITE(6,106) EPSBIG,EPSSML,SSPAR(5),N
 106  FORMAT(/,' EPSBIG,EPSSML =',2D22.15,
     +       //,' SSPAR(5) =',D22.15,
     +       //,' NUMBER OF EQUATIONS =',I5)
      WRITE(6,108) NUMRR
 108  FORMAT(/,' NUMBER OF RECALLS WHEN IFLAG=3:  ',I5)
C
      NP1=N+1
C
C NOTE THAT THE DEGREES OF VARIABLES IN EACH TERM OF EACH EQUATION
C ARE DEFINED BY THE FOLLOWING INDEXING SCHEME:
C
C     KDEG(J,  L,  K)
C
C          ^   ^   ^
C
C          E   V   T
C          Q   A   E
C          U   R   R
C          A   I   M
C          T   A
C          I   B
C          O   L
C          N   E
C
C
      WRITE(6,200)
 200  FORMAT(//,'  ****** COEFFICIENT TABLEAU ******')
C
      DO 202 J=1,N
C
         WRITE(6,205)
 205     FORMAT(/)
C
         READ(7,1000) NUMT(J)
         WRITE(6,210) J,NUMT(J)
 210     FORMAT('  NUMT(',I2,')=',I5)
C
         NT=NUMT(J)
C
         DO 215 K=1,NT
C
             DO 218 L=1,N
                READ(7,1000) KDEG(J,L,K)
                WRITE(6,220) J,L,K,KDEG(J,L,K)
 220            FORMAT('  KDEG(',I2,',',I2,',',I2,')=',I5)
C
 218         CONTINUE
C
                READ(7,2000) COEF(J,K)
                WRITE(6,230) J,K,COEF(J,K)
 230            FORMAT('  COEF(',I2,',',I2,')=',D22.15)
C
 215     CONTINUE
C
 202  CONTINUE
C
         WRITE(6,205)
         WRITE(6,205)
C
      IFLG1=10*IFLGHM+IFLGSC
C
      DO 235 M=1,TTOTDG
          IFLG2(M)=-2
 235  CONTINUE
C
      CALL POLSYS(N,NUMT,COEF,KDEG,IFLG1,IFLG2,
     + EPSBIG,EPSSML,SSPAR,
     + NUMRR,NN,MMAXT,TTOTDG,LENWK,LENIWK,
     + LAMBDA,ROOTS,ARCLEN,NFE,WK,IWK)
      WRITE(6,240) IFLG1
 240  FORMAT(/,'  IFLG1=',I5,/)
C
      ITOTIT=0
      DO 250 M=1,TTOTDG
C
         ITOTIT=ITOTIT+NFE(M)
C
         WRITE(6,260) M
 260     FORMAT('  PATH NUMBER =',I5)
         WRITE(6,270)
 270     FORMAT(/'  FINAL VALUES FOR PATH'/)
C
         WRITE(6,280) ARCLEN(M)
 280     FORMAT('  ARCLEN =',D22.15)
         WRITE(6,290) NFE(M)
 290     FORMAT('  NFE =',I5)
         WRITE(6,300) IFLG2(M)
 300     FORMAT('  IFLG2 =',I5)
C
C*******************************
C
C   DESIGNATE SOLUTIONS "REAL" OR "COMPLEX"
C
         ITEST=0
         DO 310 J=1,N
            IF(ABS(ROOTS(2,J,M)).GE.1.E-4) ITEST=1
 310     CONTINUE
         IF( ITEST.EQ.1) THEN
             WRITE(6,779)
 779         FORMAT(' COMPLEX SOLUTION  ')
         ELSE
             WRITE(6,780)
 780         FORMAT(' REAL SOLUTION  ')
         END IF
C
C*******************************
C
C
C   DESIGNATE SOLUTION "FINITE" OR "INFINITE"
C
      IF( ABS(ROOTS(1,NP1,M))+ABS(ROOTS(2,NP1,M)) .LT. 1.E-6) THEN
          WRITE(6,781)
 781      FORMAT(' INFINITE SOLUTION  ')
        ELSE
          WRITE(6,782)
 782      FORMAT('   FINITE SOLUTION  ')
      END IF
C
C*******************************
C
         WRITE(6,320) LAMBDA(M),(ROOTS(1,J,M),ROOTS(2,J,M),J=1,N)
 320     FORMAT('  LAMBDA =',D22.15,/,10(' X    =',2D22.15,/))
         WRITE(6,330) ROOTS(1,NP1,M),ROOTS(2,NP1,M)
 330     FORMAT(/,' XNP1 =',2D22.15,/)
C
         WRITE(6,205)
C
 250  CONTINUE
C
         WRITE(6,400) ITOTIT
 400     FORMAT('  TOTAL NFE OVER ALL PATHS = ',I10)
C
C
      STOP
      END
C       MAIN PROGRAM TO TEST FIXPQS, FIXPNS, AND FIXPDS
C
C       THIS PROGRAM TESTS THE HOMPACK ROUTINES FIXPNS, FIXPQS, AND
C       FIXPDS.  THE USER MAY INSERT CALLS TO A SYSTEM TIMER AT THE
C       DESIGNATED LOCATIONS IN ORDER TO GET EXECUTION TIME FOR THESE
C       ROUTINES.
C
C       THE MODIFICATIONS TO BE MADE FOR THE SYSTEM TIMER ARE INDICATED
C       BY A LINE OF M'S, E.G.
CMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM
C
C
C       THE OUTPUT FROM THIS ROUTINE SHOULD BE AS FOLLOWS, WITH THE
C       EXECUTION TIMES CORRESPONDING TO A VAX 11/785.
C
C       TESTING FIXPQS
C
C LAMBDA = 1.00000000  FLAG = 1      33 JACOBIAN EVALUATIONS
C ARC LENGTH =   1.274   EXECUTION TIME(SECS) =      2.31
C   4.00864019E-01  2.65454893E-01  8.40421103E-02  4.83042527E-01
C   3.01797132E-01  2.32508994E-01  4.96639853E-01  3.00908894E-01
C
C       TESTING FIXPNS
C
C LAMBDA = 1.00000000  FLAG = 1      20 JACOBIAN EVALUATIONS
C ARC LENGTH =   1.275   EXECUTION TIME(SECS) =      1.04
C   4.00864019E-01  2.65454893E-01  8.40421103E-02  4.83042527E-01
C   3.01797132E-01  2.32508994E-01  4.96639853E-01  3.00908894E-01
C
C       TESTING FIXPDS
C
C LAMBDA = 1.00000000  FLAG = 1      70 JACOBIAN EVALUATIONS
C ARC LENGTH =   1.281   EXECUTION TIME(SECS) =      1.78
C   4.00864019E-01  2.65454893E-01  8.40421103E-02  4.83042527E-01
C   3.01797132E-01  2.32508994E-01  4.96639853E-01  3.00908894E-01
C
C
        PROGRAM TEST1
        IMPLICIT DOUBLE PRECISION(A-H,O-Z)
        DOUBLE PRECISION Y(9),
     +  YP(9),YOLD(9),YPOLD(9),A(8),QR(18),WORK(200),
     +  SSPAR(8),PAR(1),PP(8),RHOVEC(9),Z0(9),DZ(9),T(9),
     +  WT(9),PHI(9,16),P(9)
        INTEGER PIVOT(10),IPAR(1)
        INTEGER IFLAG,II,J,LENQR,N,NFE,NP1,NDIMA,TRACE
        DOUBLE PRECISION ARCRE,ARCAE,ANSRE,ANSAE,ARCLEN
        CHARACTER*6 NAME
        INTEGER TIME,CODE
        REAL DTIME
C
C TEST EACH OF THE THREE ALGORITHMS.
C
        DO 60 II=1,3
C
C INITIALIZE TIMER VARIABLES.
C
           CODE=2
           TIME=0
           DTIME=0.0
C
C DFEFINE ARGUMENTS FOR CALL TO HOMPACK PROCEDURE.
C
           N=8
           DO 7 J=1,8
7             SSPAR(J)=0.0D0
           ARCRE=.5D-4
           ARCAE=.5D-4
           ANSRE=1.0D-12
           ANSAE=1.0D-12
           TRACE=0
           IFLAG=-1
           LENQR=18
           NP1=N+1
           DO 40 J=1,N
40            Y(J)=0.5D0
C
CMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM
C
C INSERT CALL TO INITIALIZE SYSTEM TIMER HERE.  FOR EXAMPLE, FOR
C THE VAX, THE FOLLOWING STATEMENT IS USED.
C
C         CALL LIB$INIT_TIMER
C
CMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM
C
C CALL TO HOMPACK ROUTINE.
C
C
          IF (II .EQ. 1) THEN
             NAME='FIXPQS'
             CALL FIXPQS(N,Y,IFLAG,ARCRE,ARCAE,ANSRE,ANSAE,TRACE,
     +         A,NFE,ARCLEN,YP,YOLD,YPOLD,QR,LENQR,PIVOT,PP,RHOVEC,
     +         Z0,DZ,T,WORK,SSPAR,PAR,IPAR)
          ELSE IF (II .EQ. 2) THEN
             NAME='FIXPNS'
             CALL FIXPNS(N,Y,IFLAG,ARCRE,ARCAE,ANSRE,ANSAE,TRACE,A,
     +         NFE,ARCLEN,YP,YOLD,YPOLD,QR,LENQR,PIVOT,WORK,
     +         SSPAR,PAR,IPAR)
          ELSE
             NAME='FIXPDS'
             CALL FIXPDS(N,Y,IFLAG,ARCRE,ANSRE,TRACE,A,NDIMA,NFE,
     +         ARCLEN,YP,YPOLD,QR,LENQR,PIVOT,PP,WORK,WT,PHI,P,
     +         PAR,IPAR)
          END IF
C
CMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM
C
C INSERT CALL TO RETURN EXECUTION TIME IN SECONDS IN DTIME.
C FOR EXAMPLE, THE VAX STATEMENTS ARE AS FOLLOWS.
C      CALL LIB$STAT_TIMER(CODE,TIME)
C      DTIME=TIME/100.0
C
CMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM
C
          WRITE (6,45) NAME
45        FORMAT(//,8X,'TESTING',1X,6A)
          WRITE (6,50) Y(NP1),IFLAG,NFE,ARCLEN,DTIME,(Y(J),J=1,N)
50        FORMAT(/' LAMBDA =',F11.8,'  FLAG =',I2,I8,' JACOBIAN ',
     +    'EVALUATIONS',/,1X,'  ARC LENGTH =',F8.3,
     +    '   EXECUTION TIME(SECS) =',F10.2/(1X,1P,4E16.8))
60     CONTINUE
       STOP
       END
       SUBROUTINE F(X,V)
C
C****************************************************************
C
C      SUBROUTINE F(X,V)  --  COMPUTES F AT THE POINT X,
C        RETURNING THE VALUE IN V.
C
C****************************************************************
       DOUBLE PRECISION X(8),V(8)
       V(1)=X(1)**3+6.0*X(2)*X(3)-1+2.0*X(1)
       V(2)=6.0*X(1)*X(3)+X(2)**4*X(5)-1+3.0*X(2)
       V(3)=6.0*X(1)*X(2)+X(3)*X(5)-1+4.0*X(3)
       V(4)=X(4)**3*X(8)-1+2.0*X(4)
       V(5)=X(2)**5/5.0 + X(3)**2/2.0 + X(8)*X(5)-1+3.0*X(5)
       V(6)=X(6)*X(8)-1+4.0*X(6)
       V(7)=X(7)**2*X(8)**3-1+2.0*X(7)
       V(8)=X(4)**4/4.0 + X(5)**2/2.0 + X(6)**2/2.0 + X(7)**3*
     +    X(8)**2-1+3.0*X(8)
       RETURN
       END
       SUBROUTINE FJACS(X,QR,LENQR,PIVOT)
C******************************************************************
C
C      SUBROUTINE FJACS(X,QR,LENQR,PIVOT)
C
C         -- COMPUTES THE JACOBIAN OF F AT THE POINT X, RETURNING
C            THE JACOBIAN MATRIX IN PACKED SKYLINE FORM IN THE
C            ARRAYS QR, AND PIVOT.
C
C*****************************************************************
       DOUBLE PRECISION X(8),QR(LENQR)
       INTEGER LENQR,PIVOT(9)
       PIVOT(1)=1
       PIVOT(2)=2
       PIVOT(3)=4
       PIVOT(4)=7
       PIVOT(5)=8
       PIVOT(6)=12
       PIVOT(7)=13
       PIVOT(8)=14
       PIVOT(9)=19
       QR(1)=3.0*X(1)**2+2.0
       QR(2)=4.0*X(2)**3*X(5)+3.0
       QR(3)=6.0*X(3)
       QR(4)=X(5)+4.0
       QR(5)=6.0*X(1)
       QR(6)=6.0*X(2)
       QR(7)=3.0*X(4)**2*X(8)+2.0
       QR(8)=X(8)+3.0
       QR(9)=.0
       QR(10)=X(3)
       QR(11)=X(2)**4
       QR(12)=X(8)+4.0
       QR(13)=2.0*X(7)*X(8)**3+2.0
       QR(14)=2.0*X(7)**3*X(8)+3.0
       QR(15)=3.0*X(7)**2*X(8)**2
       QR(16)=X(6)
       QR(17)=X(5)
       QR(18)=X(4)**3
       RETURN
       END
C
C      HOMPACK is a suite of FORTRAN 77 subroutines for solving nonlinea
C systems of equations by homotopy methods.  There are subroutines for
C fixed point, zero finding, and general homotopy curve tracking problem
C utilizing both dense and sparse Jacobian matrices, and implementing
C three different algorithms: ODE-based, normal flow, and augmented
C Jacobian.  The (driver) subroutines called by the user are given in th
C table below, and are well documented internally.  The user need not
C be concerned with any other subroutines in HOMPACK.
C
C
C                  Problem type
C --------|--------|--------|--------|--------|--------|
C      x = f(x)    |    F(x) = 0     |rho(a,lambda,x)=0|
C --------|--------|--------|--------|--------|--------|
C  dense  | sparse | dense  | sparse | dense  | sparse |  Algorithm
C --------|--------|--------|--------|--------|--------|----------------
C  FIXPDF | FIXPDS | FIXPDF | FIXPDS | FIXPDF | FIXPDS | ODE based
C --------|--------|--------|--------|--------|--------|----------------
C  FIXPNF | FIXPNS | FIXPNF | FIXPNS | FIXPNF | FIXPNS | normal flow
C --------|--------|--------|--------|--------|--------|----------------
C  FIXPQF | FIXPQS | FIXPQF | FIXPQS | FIXPQF | FIXPQS | augmented Jacob
C --------|--------|--------|--------|--------|--------|----------------
C
C
C The sparse subroutines use the packed skyline storage scheme standard
C structural mechanics, but any sparse storage scheme can be used by
C replacing some of the low-level HOMPACK routines with user-written
C routines.  The stepping subroutines STEP?? may be of interest to some
C users with special curve tracking needs.
C
C
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
      DOUBLE PRECISION FUNCTION D1MACH(I)
C***BEGIN PROLOGUE  D1MACH
C***DATE WRITTEN   750101   (YYMMDD)
C***REVISION DATE  870717   (YYMMDD)
C***CATEGORY NO.  Q3
C***KEYWORDS  MACHINE CONSTANTS
C***AUTHOR  FOX, P. A., (BELL LABS)
C           HALL, A. D., (BELL LABS)
C           SCHRYER, N. L., (BELL LABS)
C           WATSON, L. T., (VPI & SU)
C***PURPOSE  Returns double precision machine dependent constants
C***DESCRIPTION
C     D1MACH can be used to obtain machine-dependent parameters
C     for the local machine environment.  It is a function
C     subprogram with one (input) argument, and can be called
C     as follows, for example
C
C          D = D1MACH(I)
C
C     where I=1,...,5.  The (output) value of D above is
C     determined by the (input) value of I.  The results for
C     various values of I are discussed below.
C
C  Double-precision machine constants
C  D1MACH( 1) = B**(EMIN-1), the smallest positive magnitude.
C  D1MACH( 2) = B**EMAX*(1 - B**(-T)), the largest magnitude.
C  D1MACH( 3) = B**(-T), the smallest relative spacing.
C  D1MACH( 4) = B**(1-T), the largest relative spacing.
C  D1MACH( 5) = LOG10(B)
C***REFERENCES  FOX P.A., HALL A.D., SCHRYER N.L.,*FRAMEWORK FOR A
C                 PORTABLE LIBRARY*, ACM TRANSACTIONS ON MATHEMATICAL
C                 SOFTWARE, VOL. 4, NO. 2, JUNE 1978, PP. 177-188.
C***END PROLOGUE  D1MACH
C
      INTEGER I
      INTEGER SMALL(4)
      INTEGER LARGE(4)
      INTEGER RIGHT(4)
      INTEGER DIVER(4)
      INTEGER LOG10(4)
C
      DOUBLE PRECISION DMACH(5)
C
      EQUIVALENCE (DMACH(1),SMALL(1))
      EQUIVALENCE (DMACH(2),LARGE(1))
      EQUIVALENCE (DMACH(3),RIGHT(1))
      EQUIVALENCE (DMACH(4),DIVER(1))
      EQUIVALENCE (DMACH(5),LOG10(1))
C
      SAVE DMACH
C
C     MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM.
C
C     DATA SMALL(1) / ZC00800000 /
C     DATA SMALL(2) / Z000000000 /
C
C     DATA LARGE(1) / ZDFFFFFFFF /
C     DATA LARGE(2) / ZFFFFFFFFF /
C
C     DATA RIGHT(1) / ZCC5800000 /
C     DATA RIGHT(2) / Z000000000 /
C
C     DATA DIVER(1) / ZCC6800000 /
C     DATA DIVER(2) / Z000000000 /
C
C     DATA LOG10(1) / ZD00E730E7 /
C     DATA LOG10(2) / ZC77800DC0 /
C
C     MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM.
C
C     DATA SMALL(1) / O1771000000000000 /
C     DATA SMALL(2) / O0000000000000000 /
C
C     DATA LARGE(1) / O0777777777777777 /
C     DATA LARGE(2) / O0007777777777777 /
C
C     DATA RIGHT(1) / O1461000000000000 /
C     DATA RIGHT(2) / O0000000000000000 /
C
C     DATA DIVER(1) / O1451000000000000 /
C     DATA DIVER(2) / O0000000000000000 /
C
C     DATA LOG10(1) / O1157163034761674 /
C     DATA LOG10(2) / O0006677466732724 /
C
C     MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS.
C
C     DATA SMALL(1) / O1771000000000000 /
C     DATA SMALL(2) / O7770000000000000 /
C
C     DATA LARGE(1) / O0777777777777777 /
C     DATA LARGE(2) / O7777777777777777 /
C
C     DATA RIGHT(1) / O1461000000000000 /
C     DATA RIGHT(2) / O0000000000000000 /
C
C     DATA DIVER(1) / O1451000000000000 /
C     DATA DIVER(2) / O0000000000000000 /
C
C     DATA LOG10(1) / O1157163034761674 /
C     DATA LOG10(2) / O0006677466732724 /
C
C     MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES.
C
C     DATA SMALL(1) / 00604000000000000000B /
C     DATA SMALL(2) / 00000000000000000000B /
C     DATA LARGE(1) / 37767777777777777777B /
C     DATA LARGE(2) / 37167777777777777777B /
C     DATA RIGHT(1) / 15604000000000000000B /
C     DATA RIGHT(2) / 15000000000000000000B /
C     DATA DIVER(1) / 15614000000000000000B /
C     DATA DIVER(2) / 15010000000000000000B /
C     DATA LOG10(1) / 17164642023241175717B /
C     DATA LOG10(2) / 16367571421742254654B /
C
C     MACHINE CONSTANTS FOR THE CDC CYBER SERIES.
C
C     DATA SMALL(1) / O"00604000000000000000" /
C     DATA SMALL(2) / O"00000000000000000000" /
C     DATA LARGE(1) / O"37767777777777777777" /
C     DATA LARGE(2) / O"37167777777777777777" /
C     DATA RIGHT(1) / O"15604000000000000000" /
C     DATA RIGHT(2) / O"15000000000000000000" /
C     DATA DIVER(1) / O"15614000000000000000" /
C     DATA DIVER(2) / O"15010000000000000000" /
C     DATA LOG10(1) / O"17164642023241175717" /
C     DATA LOG10(2) / O"16367571421742254654" /
C
C     MACHINE CONSTANTS FOR CONVEX C-1
C
C     DATA SMALL(1),SMALL(2) / '00100000'X, '00000000'X /
C     DATA LARGE(1),LARGE(2) / '7FFFFFFF'X, 'FFFFFFFF'X /
C     DATA RIGHT(1),RIGHT(2) / '3CC00000'X, '00000000'X /
C     DATA DIVER(1),DIVER(2) / '3CD00000'X, '00000000'X /
C     DATA LOG10(1),LOG10(2) / '3FF34413'X, '509F79FF'X /
C
C     MACHINE CONSTANTS FOR THE CRAY 1 (ERIC GROSSE)
C
C     DATA SMALL(1) / 201354000000000000000B /
C     DATA SMALL(2) / 000000000000000000000B /
C     DATA LARGE(1) / 577767777777777777777B /
C     DATA LARGE(2) / 000007777777777777776B /
C     DATA RIGHT(1) / 376434000000000000000B /
C     DATA RIGHT(2) / 000000000000000000000B /
C     DATA DIVER(1) / 376444000000000000000B /
C     DATA DIVER(2) / 000000000000000000000B /
C     DATA LOG10(1) / 377774642023241175717B /
C     DATA LOG10(2) / 000007571421742254654B /
C
C     MACHINE CONSTANTS FOR THE CRAY 1 (SLATEC LIBRARY)
C
C     DATA SMALL(1) / 200004000000000000000B /
C     DATA SMALL(2) / 000000000000000000000B /
C     DATA LARGE(1) / 577777777777777777777B /
C     DATA LARGE(2) / 000007777777777777777B /
C     DATA RIGHT(1) / 377214000000000000000B /
C     DATA RIGHT(2) / 000000000000000000000B /
C     DATA DIVER(1) / 377224000000000000000B /
C     DATA DIVER(2) / 000000000000000000000B /
C     DATA LOG10(1) / 377774642023241175717B /
C     DATA LOG10(2) / 000007571421742254654B /
C
C     MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200
C
C     NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING CARD -
C     STATIC DMACH(5)
C
C     DATA SMALL/20K,3*0/,LARGE/77777K,3*177777K/
C     DATA RIGHT/31420K,3*0/,DIVER/32020K,3*0/
C     DATA LOG10/40423K,42023K,50237K,74776K/
C
C     MACHINE CONSTANTS FOR THE DATA GENERAL MV/8000, 10000
C
C     DATA SMALL(1),SMALL(2) /    1048576,          0 /
C     DATA LARGE(1),LARGE(2) / 2147483647,         -1 /
C     DATA RIGHT(1),RIGHT(2) /  856686592,          0 /
C     DATA DIVER(1),DIVER(2) /  873463808,          0 /
C     DATA LOG10(1),LOG10(2) / 1091781651, 1352628734 /
C
C     MACHINE CONSTANTS FOR THE HARRIS 220
C
C     DATA SMALL(1),SMALL(2) / '20000000, '00000201 /
C     DATA LARGE(1),LARGE(2) / '37777777, '37777577 /
C     DATA RIGHT(1),RIGHT(2) / '20000000, '00000333 /
C     DATA DIVER(1),DIVER(2) / '20000000, '00000334 /
C     DATA LOG10(1),LOG10(2) / '23210115, '10237777 /
C
C     MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES.
C
C     DATA SMALL(1),SMALL(2) / O402400000000, O000000000000 /
C     DATA LARGE(1),LARGE(2) / O376777777777, O777777777777 /
C     DATA RIGHT(1),RIGHT(2) / O604400000000, O000000000000 /
C     DATA DIVER(1),DIVER(2) / O606400000000, O000000000000 /
C     DATA LOG10(1),LOG10(2) / O776464202324, O117571775714 /
C
C      MACHINE CONSTANTS FOR THE HP 2100
C      THREE WORD DOUBLE PRECISION OPTION WITH FTN4
C
C      DATA SMALL(1), SMALL(2), SMALL(3) / 40000B,       0,       1 /
C      DATA LARGE(1), LARGE(2), LARGE(3) / 77777B, 177777B, 177776B /
C      DATA RIGHT(1), RIGHT(2), RIGHT(3) / 40000B,       0,    265B /
C      DATA DIVER(1), DIVER(2), DIVER(3) / 40000B,       0,    276B /
C      DATA LOG10(1), LOG10(2), LOG10(3) / 46420B,  46502B,  77777B /
C
C
C      MACHINE CONSTANTS FOR THE HP 2100
C      FOUR WORD DOUBLE PRECISION OPTION WITH FTN4
C
C      DATA SMALL(1), SMALL(2) /  40000B,       0 /
C      DATA SMALL(3), SMALL(4) /       0,       1 /
C      DATA LARGE(1), LARGE(2) /  77777B, 177777B /
C      DATA LARGE(3), LARGE(4) / 177777B, 177776B /
C      DATA RIGHT(1), RIGHT(2) /  40000B,       0 /
C      DATA RIGHT(3), RIGHT(4) /       0,    225B /
C      DATA DIVER(1), DIVER(2) /  40000B,       0 /
C      DATA DIVER(3), DIVER(4) /       0,    227B /
C      DATA LOG10(1), LOG10(2) /  46420B,  46502B /
C      DATA LOG10(3), LOG10(4) /  76747B, 176377B /
C
C
C     MACHINE CONSTANTS FOR THE IBM 360/370 SERIES,
C     THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND
C     THE PERKIN ELMER (INTERDATA) 7/32.
C
C     DATA SMALL(1),SMALL(2) / Z00100000, Z00000000 /
C     DATA LARGE(1),LARGE(2) / Z7FFFFFFF, ZFFFFFFFF /
C     DATA RIGHT(1),RIGHT(2) / Z33100000, Z00000000 /
C     DATA DIVER(1),DIVER(2) / Z34100000, Z00000000 /
C     DATA LOG10(1),LOG10(2) / Z41134413, Z509F79FF /
C
C   MACHINE CONSTANTS FOR THE INTEL 8087, 80287, SEQUENT BALANCE.
C   ASSUMES  INTEGER*2  AS THE DEFAULT FOR TYPE INTEGER.
C
C      DATA SMALL(1), SMALL(2) /     0,     0/
C      DATA SMALL(3), SMALL(4) /     0,    16/
C      DATA LARGE(1), LARGE(2) /    -1,    -1/
C      DATA LARGE(3), LARGE(4) /    -1, 32751/
C      DATA RIGHT(1), RIGHT(2) /     0,     0/
C      DATA RIGHT(3), RIGHT(4) /     0, 15520/
C      DATA DIVER(1), DIVER(2) /     0,     0/
C      DATA DIVER(3), DIVER(4) /     0, 15536/
C      DATA LOG10(1), LOG10(2) / 31231, 20639/
C      DATA LOG10(3), LOG10(4) / 17427, 16339/
C
C   MACHINE CONSTANTS FOR THE INTEL 8087, 80287, SEQUENT BALANCE.
C   ASSUMES  INTEGER*4  AS THE DEFAULT FOR TYPE INTEGER.
C
C      DATA SMALL(1),SMALL(2) /          0,    1048576 /
C      DATA LARGE(1),LARGE(2) /         -1, 2146435071 /
C      DATA RIGHT(1),RIGHT(2) /          0, 1017118720 /
C      DATA DIVER(1),DIVER(2) /          0, 1018167296 /
C      DATA LOG10(1),LOG10(2) / 1352628735, 1070810131 /
C
C   MACHINE CONSTANTS FOR THE MOTOROLA 68000 SERIES, AT&T 3B SERIES.
C   ASSUMES  INTEGER*2  AS THE DEFAULT FOR TYPE INTEGER.
C
C      DATA SMALL(1), SMALL(2) /    16,     0/
C      DATA SMALL(3), SMALL(4) /     0,     0/
C      DATA LARGE(1), LARGE(2) / 32751,    -1/
C      DATA LARGE(3), LARGE(4) /    -1,    -1/
C      DATA RIGHT(1), RIGHT(2) / 15520,     0/
C      DATA RIGHT(3), RIGHT(4) /     0,     0/
C      DATA DIVER(1), DIVER(2) / 15536,     0/
C      DATA DIVER(3), DIVER(4) /     0,     0/
C      DATA LOG10(1), LOG10(2) / 16339, 17427/
C      DATA LOG10(3), LOG10(4) / 20639, 31231/
C
C   MACHINE CONSTANTS FOR THE MOTOROLA 68000 SERIES, AT&T 3B SERIES.
C   ASSUMES  INTEGER*4  AS THE DEFAULT FOR TYPE INTEGER.
C
C      DATA SMALL(1),SMALL(2) /    1048576,          0 /
C      DATA LARGE(1),LARGE(2) / 2146435071,         -1 /
C      DATA RIGHT(1),RIGHT(2) / 1017118720,          0 /
C      DATA DIVER(1),DIVER(2) / 1018167296,          0 /
C      DATA LOG10(1),LOG10(2) / 1070810131, 1352628735 /
C
C     MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR).
C
C     DATA SMALL(1),SMALL(2) / "033400000000, "000000000000 /
C     DATA LARGE(1),LARGE(2) / "377777777777, "344777777777 /
C     DATA RIGHT(1),RIGHT(2) / "113400000000, "000000000000 /
C     DATA DIVER(1),DIVER(2) / "114400000000, "000000000000 /
C     DATA LOG10(1),LOG10(2) / "177464202324, "144117571776 /
C
C     MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR).
C
C     DATA SMALL(1),SMALL(2) / "000400000000, "000000000000 /
C     DATA LARGE(1),LARGE(2) / "377777777777, "377777777777 /
C     DATA RIGHT(1),RIGHT(2) / "103400000000, "000000000000 /
C     DATA DIVER(1),DIVER(2) / "104400000000, "000000000000 /
C     DATA LOG10(1),LOG10(2) / "177464202324, "476747767461 /
C
C     MACHINE CONSTANTS FOR PDP-11 FORTRAN'S SUPPORTING
C     32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL).
C
C     DATA SMALL(1),SMALL(2) /    8388608,           0 /
C     DATA LARGE(1),LARGE(2) / 2147483647,          -1 /
C     DATA RIGHT(1),RIGHT(2) /  612368384,           0 /
C     DATA DIVER(1),DIVER(2) /  620756992,           0 /
C     DATA LOG10(1),LOG10(2) / 1067065498, -2063872008 /
C
C     DATA SMALL(1),SMALL(2) / O00040000000, O00000000000 /
C     DATA LARGE(1),LARGE(2) / O17777777777, O37777777777 /
C     DATA RIGHT(1),RIGHT(2) / O04440000000, O00000000000 /
C     DATA DIVER(1),DIVER(2) / O04500000000, O00000000000 /
C     DATA LOG10(1),LOG10(2) / O07746420232, O20476747770 /
C
C     MACHINE CONSTANTS FOR PDP-11 FORTRAN'S SUPPORTING
C     16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL).
C
C     DATA SMALL(1),SMALL(2) /    128,      0 /
C     DATA SMALL(3),SMALL(4) /      0,      0 /
C
C     DATA LARGE(1),LARGE(2) /  32767,     -1 /
C     DATA LARGE(3),LARGE(4) /     -1,     -1 /
C
C     DATA RIGHT(1),RIGHT(2) /   9344,      0 /
C     DATA RIGHT(3),RIGHT(4) /      0,      0 /
C
C     DATA DIVER(1),DIVER(2) /   9472,      0 /
C     DATA DIVER(3),DIVER(4) /      0,      0 /
C
C     DATA LOG10(1),LOG10(2) /  16282,   8346 /
C     DATA LOG10(3),LOG10(4) / -31493, -12296 /
C
C     DATA SMALL(1),SMALL(2) / O000200, O000000 /
C     DATA SMALL(3),SMALL(4) / O000000, O000000 /
C
C     DATA LARGE(1),LARGE(2) / O077777, O177777 /
C     DATA LARGE(3),LARGE(4) / O177777, O177777 /
C
C     DATA RIGHT(1),RIGHT(2) / O022200, O000000 /
C     DATA RIGHT(3),RIGHT(4) / O000000, O000000 /
C
C     DATA DIVER(1),DIVER(2) / O022400, O000000 /
C     DATA DIVER(3),DIVER(4) / O000000, O000000 /
C
C     DATA LOG10(1),LOG10(2) / O037632, O020232 /
C     DATA LOG10(3),LOG10(4) / O102373, O147770 /
C
C     MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES.
C
C     DATA SMALL(1),SMALL(2) / O000040000000, O000000000000 /
C     DATA LARGE(1),LARGE(2) / O377777777777, O777777777777 /
C     DATA RIGHT(1),RIGHT(2) / O170540000000, O000000000000 /
C     DATA DIVER(1),DIVER(2) / O170640000000, O000000000000 /
C     DATA LOG10(1),LOG10(2) / O177746420232, O411757177572 /
C
C
C     MACHINE CONSTANTS FOR VAX 11/780
C     (EXPRESSED IN INTEGER AND HEXADECIMAL)
C    ***THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSYEMS***
C    *** THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS***
C
      DATA SMALL(1), SMALL(2) /        128,           0 /
      DATA LARGE(1), LARGE(2) /     -32769,          -1 /
      DATA RIGHT(1), RIGHT(2) /       9344,           0 /
      DATA DIVER(1), DIVER(2) /       9472,           0 /
      DATA LOG10(1), LOG10(2) /  546979738,  -805665541 /
C
C     DATA SMALL(1), SMALL(2) / Z00000080, Z00000000 /
C     DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF /
C     DATA RIGHT(1), RIGHT(2) / Z00002480, Z00000000 /
C     DATA DIVER(1), DIVER(2) / Z00002500, Z00000000 /
C     DATA LOG10(1), LOG10(2) / Z209A3F9A, ZCFFA84FB /
C
C   MACHINE CONSTANTS FOR VAX 11/780 (G-FLOATING)
C     (EXPRESSED IN INTEGER AND HEXADECIMAL)
C    ***THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSYEMS***
C    *** THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS***
C
C      DATA SMALL(1), SMALL(2) /         16,           0 /
C      DATA LARGE(1), LARGE(2) /     -32769,          -1 /
C      DATA RIGHT(1), RIGHT(2) /      15552,           0 /
C      DATA DIVER(1), DIVER(2) /      15568,           0 /
C      DATA LOG10(1), LOG10(2) /  1142112243, 2046775455 /
C
C      DATA SMALL(1), SMALL(2) / Z00000010, Z00000000 /
C      DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF /
C      DATA RIGHT(1), RIGHT(2) / Z00003CC0, Z00000000 /
C      DATA DIVER(1), DIVER(2) / Z00003CD0, Z00000000 /
C      DATA LOG10(1), LOG10(2) / Z44133FF3, Z79FF509F /
C
C***FIRST EXECUTABLE STATEMENT  D1MACH
C
      D1MACH = DMACH(I)
      RETURN
C
      END
      SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY)
C
C     CONSTANT TIMES A VECTOR PLUS A VECTOR.
C     USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      DOUBLE PRECISION DX(1),DY(1),DA
      INTEGER I,INCX,INCY,IX,IY,M,MP1,N
C
      IF(N.LE.0)RETURN
      IF (DA .EQ. 0.0D0) RETURN
      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
C
C        CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS
C          NOT EQUAL TO 1
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        DY(IY) = DY(IY) + DA*DX(IX)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C        CODE FOR BOTH INCREMENTS EQUAL TO 1
C
C
C        CLEAN-UP LOOP
C
   20 M = MOD(N,4)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        DY(I) = DY(I) + DA*DX(I)
   30 CONTINUE
      IF( N .LT. 4 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,4
        DY(I) = DY(I) + DA*DX(I)
        DY(I + 1) = DY(I + 1) + DA*DX(I + 1)
        DY(I + 2) = DY(I + 2) + DA*DX(I + 2)
        DY(I + 3) = DY(I + 3) + DA*DX(I + 3)
   50 CONTINUE
      RETURN
      END
      SUBROUTINE  DCOPY(N,DX,INCX,DY,INCY)
C
C     COPIES A VECTOR, X, TO A VECTOR, Y.
C     USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      DOUBLE PRECISION DX(1),DY(1)
      INTEGER I,INCX,INCY,IX,IY,M,MP1,N
C
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
C
C        CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS
C          NOT EQUAL TO 1
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        DY(IY) = DX(IX)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C        CODE FOR BOTH INCREMENTS EQUAL TO 1
C
C
C        CLEAN-UP LOOP
C
   20 M = MOD(N,7)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        DY(I) = DX(I)
   30 CONTINUE
      IF( N .LT. 7 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,7
        DY(I) = DX(I)
        DY(I + 1) = DX(I + 1)
        DY(I + 2) = DX(I + 2)
        DY(I + 3) = DX(I + 3)
        DY(I + 4) = DX(I + 4)
        DY(I + 5) = DX(I + 5)
        DY(I + 6) = DX(I + 6)
   50 CONTINUE
      RETURN
      END
      SUBROUTINE DCPOSE(NDIM,N,QR,ALPHA,PIVOT,IERR,Y,SUM)
C
C SUBROUTINE  DCPOSE  IS A MODIFICATION OF THE ALGOL PROCEDURE
C DECOMPOSE  IN P. BUSINGER AND G. H. GOLUB, LINEAR LEAST
C SQUARES SOLUTIONS BY HOUSEHOLDER TRANSFORMATIONS,
C NUMER. MATH. 7 (1965) 269-276.
C
      INTEGER NDIM,N,PIVOT(1)
      DOUBLE PRECISION QR(NDIM,1),ALPHA(N)
      INTEGER IERR,I,J,JBAR,K,KP1,NP1
      DOUBLE PRECISION BETA,SIGMA,ALPHAK,QRKK,Y(1),SUM(1)
      DOUBLE PRECISION DDOT
      IERR=0
      NP1=N+1
      DO 20 J=1,NP1
        SUM(J)=DDOT(N,QR(1,J),1,QR(1,J),1)
20    PIVOT(J)=J
      DO 500 K=1,N
        SIGMA=SUM(K)
        JBAR=K
        KP1=K+1
        DO 40 J=KP1,NP1
          IF (SIGMA .GE. SUM(J)) GO TO 40
          SIGMA=SUM(J)
          JBAR=J
40      CONTINUE
        IF (JBAR .EQ. K) GO TO 70
        I=PIVOT(K)
        PIVOT(K)=PIVOT(JBAR)
        PIVOT(JBAR)=I
        SUM(JBAR)=SUM(K)
        SUM(K)=SIGMA
        DO 50 I=1,N
          SIGMA=QR(I,K)
          QR(I,K)=QR(I,JBAR)
          QR(I,JBAR)=SIGMA
50      CONTINUE
C   END OF COLUMN INTERCHANGE.
70      SIGMA=DDOT(N-K+1,QR(K,K),1,QR(K,K),1)
        IF (SIGMA .NE. 0.0) GO TO 60
        IERR=1
        RETURN
60      IF (K .EQ. N) GO TO 500
        QRKK=QR(K,K)
        ALPHAK=-SQRT(SIGMA)
        IF (QRKK .LT. 0.0) ALPHAK=-ALPHAK
        ALPHA(K)=ALPHAK
        BETA=1.0/(SIGMA-QRKK*ALPHAK)
        QR(K,K)=QRKK-ALPHAK
        DO 80 J=KP1,NP1
80      Y(J)=BETA*DDOT(N-K+1,QR(K,K),1,QR(K,J),1)
        DO 100 J=KP1,NP1
          DO 90 I=K,N
            QR(I,J)=QR(I,J)-QR(I,K)*Y(J)
90        CONTINUE
          SUM(J)=SUM(J)-QR(K,J)**2
100     CONTINUE
500   CONTINUE
      ALPHA(N)=QR(N,N)
      RETURN
      END
      DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY)
C
C     FORMS THE DOT PRODUCT OF TWO VECTORS.
C     USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      DOUBLE PRECISION DX(1),DY(1),DTEMP
      INTEGER I,INCX,INCY,IX,IY,M,MP1,N
C
      DDOT = 0.0D0
      DTEMP = 0.0D0
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
C
C        CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS
C          NOT EQUAL TO 1
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        DTEMP = DTEMP + DX(IX)*DY(IY)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      DDOT = DTEMP
      RETURN
C
C        CODE FOR BOTH INCREMENTS EQUAL TO 1
C
C
C        CLEAN-UP LOOP
C
   20 M = MOD(N,5)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        DTEMP = DTEMP + DX(I)*DY(I)
   30 CONTINUE
      IF( N .LT. 5 ) GO TO 60
   40 MP1 = M + 1
      DO 50 I = MP1,N,5
        DTEMP = DTEMP + DX(I)*DY(I) + DX(I + 1)*DY(I + 1) +
     *   DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4)
   50 CONTINUE
   60 DDOT = DTEMP
      RETURN
      END
      SUBROUTINE DIVP(XXXX,YYYY,ZZZZ,IERR)
C
C THIS SUBROUTINE PERFORMS DIVISION  OF COMPLEX NUMBERS:
C ZZZZ = XXXX/YYYY
C
C ON INPUT:
C
C XXXX  IS AN ARRAY OF LENGTH TWO REPRESENTING THE FIRST COMPLEX
C       NUMBER, WHERE XXXX(1) = REAL PART OF XXXX AND XXXX(2) =
C       IMAGINARY PART OF XXXX.
C
C YYYY  IS AN ARRAY OF LENGTH TWO REPRESENTING THE SECOND COMPLEX
C       NUMBER, WHERE YYYY(1) = REAL PART OF YYYY AND YYYY(2) =
C       IMAGINARY PART OF YYYY.
C
C ON OUTPUT:
C
C ZZZZ  IS AN ARRAY OF LENGTH TWO REPRESENTING THE RESULT OF
C       THE DIVISION, ZZZZ = XXXX/YYYY, WHERE ZZZZ(1) =
C       REAL PART OF ZZZZ AND ZZZZ(2) = IMAGINARY PART OF ZZZZ.
C
C IERR =
C  1   IF DIVISION WOULD HAVE CAUSED OVERFLOW.  IN THIS CASE, THE
C      APPROPRIATE PARTS OF ZZZZ ARE SET EQUAL TO THE LARGEST
C      FLOATING POINT NUMBER, AS GIVEN BY FUNCTION  D1MACH .
C
C  0   IF DIVISION DOES NOT CAUSE OVERFLOW.
C
C DECLARATION OF INPUT
      DOUBLE PRECISION XXXX,YYYY
      DIMENSION XXXX(2),YYYY(2)
C
C DECLARATION OF OUTPUT
      INTEGER IERR
      DOUBLE PRECISION ZZZZ
      DIMENSION ZZZZ(2)
C
C DECLARATION OF VARIABLES
      DOUBLE PRECISION DENOM,XNUM,D1MACH
C
      IERR = 0
      DENOM = YYYY(1)*YYYY(1) + YYYY(2)*YYYY(2)
      XNUM    =   XXXX(1)*YYYY(1) + XXXX(2)*YYYY(2)
      IF (ABS(DENOM) .GE. 1.0  .OR.  ( ABS(DENOM) .LT. 1.0   .AND.
     $ ABS(XNUM)/D1MACH(2) .LT. ABS(DENOM) ) ) THEN
            ZZZZ(1) = XNUM/DENOM
          ELSE
            ZZZZ(1) = D1MACH(2)
            IERR =1
          END IF
      XNUM    =   XXXX(2)*YYYY(1) - XXXX(1)*YYYY(2)
      IF (ABS(DENOM) .GE. 1.0  .OR.  ( ABS(DENOM) .LT. 1.0   .AND.
     $ ABS(XNUM)/D1MACH(2) .LT. ABS(DENOM) ) ) THEN
            ZZZZ(2) = XNUM/DENOM
          ELSE
            ZZZZ(2) = D1MACH(2)
            IERR =1
          END IF
      RETURN
      END
*
      DOUBLE PRECISION FUNCTION DNRM2 ( N, DX, INCX)
      INTEGER I,INCX,J,N,NEXT,NN
      DOUBLE PRECISION   DX(1), CUTLO, CUTHI, HITEST, SUM, XMAX
      DOUBLE PRECISION   ONE,ZERO
      PARAMETER (ZERO=0.0D0, ONE=1.0D0)
C
C     EUCLIDEAN NORM OF THE N-VECTOR STORED IN DX() WITH STORAGE
C     INCREMENT INCX .
C     IF    N .LE. 0 RETURN WITH RESULT = 0.
C     IF N .GE. 1 THEN INCX MUST BE .GE. 1
C
C           C.L.LAWSON, 1978 JAN 08
C
C     FOUR PHASE METHOD     USING TWO BUILT-IN CONSTANTS THAT ARE
C     HOPEFULLY APPLICABLE TO ALL MACHINES.
C         CUTLO = MAXIMUM OF  DSQRT(U/EPS)  OVER ALL KNOWN MACHINES.
C         CUTHI = MINIMUM OF  DSQRT(V)      OVER ALL KNOWN MACHINES.
C     WHERE
C         EPS = SMALLEST NO. SUCH THAT EPS + 1. .GT. 1.
C         U   = SMALLEST POSITIVE NO.   (UNDERFLOW LIMIT)
C         V   = LARGEST  NO.            (OVERFLOW  LIMIT)
C
C     BRIEF OUTLINE OF ALGORITHM..
C
C     PHASE 1    SCANS ZERO COMPONENTS.
C     MOVE TO PHASE 2 WHEN A COMPONENT IS NONZERO AND .LE. CUTLO
C     MOVE TO PHASE 3 WHEN A COMPONENT IS .GT. CUTLO
C     MOVE TO PHASE 4 WHEN A COMPONENT IS .GE. CUTHI/M
C     WHERE M = N FOR X() REAL AND M = 2*N FOR COMPLEX.
C
C     VALUES FOR CUTLO AND CUTHI..
C     FROM THE ENVIRONMENTAL PARAMETERS LISTED IN THE IMSL CONVERTER
C     DOCUMENT THE LIMITING VALUES ARE AS FOLLOWS..
C     CUTLO, S.P.   U/EPS = 2**(-102) FOR  HONEYWELL.  CLOSE SECONDS ARE
C                   UNIVAC AND DEC AT 2**(-103)
C                   THUS CUTLO = 2**(-51) = 4.44089E-16
C     CUTHI, S.P.   V = 2**127 FOR UNIVAC, HONEYWELL, AND DEC.
C                   THUS CUTHI = 2**(63.5) = 1.30438E19
C     CUTLO, D.P.   U/EPS = 2**(-67) FOR HONEYWELL AND DEC.
C                   THUS CUTLO = 2**(-33.5) = 8.23181D-11
C     CUTHI, D.P.   SAME AS S.P.  CUTHI = 1.30438D19
C     DATA CUTLO, CUTHI / 8.232D-11,  1.304D19 /
C     DATA CUTLO, CUTHI / 4.441E-16,  1.304E19 /
      DATA CUTLO, CUTHI / 8.232D-11,  1.304D19 /
C
      IF(N .GT. 0) GO TO 10
         DNRM2  = ZERO
         GO TO 300
C
   10 ASSIGN 30 TO NEXT
      SUM = ZERO
      NN = N * INCX
C                                                 BEGIN MAIN LOOP
      I = 1
   20    GO TO NEXT,(30, 50, 70, 110)
   30 IF( DABS(DX(I)) .GT. CUTLO) GO TO 85
      ASSIGN 50 TO NEXT
      XMAX = ZERO
C
C                        PHASE 1.  SUM IS ZERO
C
   50 IF( DX(I) .EQ. ZERO) GO TO 200
      IF( DABS(DX(I)) .GT. CUTLO) GO TO 85
C
C                                PREPARE FOR PHASE 2.
      ASSIGN 70 TO NEXT
      GO TO 105
C
C                                PREPARE FOR PHASE 4.
C
  100 I = J
      ASSIGN 110 TO NEXT
      SUM = (SUM / DX(I)) / DX(I)
  105 XMAX = DABS(DX(I))
      GO TO 115
C
C                   PHASE 2.  SUM IS SMALL.
C                             SCALE TO AVOID DESTRUCTIVE UNDERFLOW.
C
   70 IF( DABS(DX(I)) .GT. CUTLO ) GO TO 75
C
C                     COMMON CODE FOR PHASES 2 AND 4.
C                     IN PHASE 4 SUM IS LARGE.  SCALE TO AVOID OVERFLOW.
C
  110 IF( DABS(DX(I)) .LE. XMAX ) GO TO 115
         SUM = ONE + SUM * (XMAX / DX(I))**2
         XMAX = DABS(DX(I))
         GO TO 200
C
  115 SUM = SUM + (DX(I)/XMAX)**2
      GO TO 200
C
C
C                  PREPARE FOR PHASE 3.
C
   75 SUM = (SUM * XMAX) * XMAX
C
C
C     FOR REAL OR D.P. SET HITEST = CUTHI/N
C     FOR COMPLEX      SET HITEST = CUTHI/(2*N)
C
   85 HITEST = CUTHI/FLOAT( N )
C
C                   PHASE 3.  SUM IS MID-RANGE.  NO SCALING.
C
      DO 95 J =I,NN,INCX
      IF(DABS(DX(J)) .GE. HITEST) GO TO 100
   95    SUM = SUM + DX(J)**2
      DNRM2 = DSQRT( SUM )
      GO TO 300
C
  200 CONTINUE
      I = I + INCX
      IF ( I .LE. NN ) GO TO 20
C
C              END OF MAIN LOOP.
C
C              COMPUTE SQUARE ROOT AND ADJUST FOR SCALING.
C
      DNRM2 = XMAX * DSQRT(SUM)
  300 CONTINUE
      RETURN
      END
      SUBROUTINE  DSCAL(N,DA,DX,INCX)
C
C     SCALES A VECTOR BY A CONSTANT.
C     USES UNROLLED LOOPS FOR INCREMENT EQUAL TO ONE.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      DOUBLE PRECISION DA,DX(1)
      INTEGER I,INCX,M,MP1,N,NINCX
C
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1)GO TO 20
C
C        CODE FOR INCREMENT NOT EQUAL TO 1
C
      NINCX = N*INCX
      DO 10 I = 1,NINCX,INCX
        DX(I) = DA*DX(I)
   10 CONTINUE
      RETURN
C
C        CODE FOR INCREMENT EQUAL TO 1
C
C
C        CLEAN-UP LOOP
C
   20 M = MOD(N,5)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        DX(I) = DA*DX(I)
   30 CONTINUE
      IF( N .LT. 5 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,5
        DX(I) = DA*DX(I)
        DX(I + 1) = DA*DX(I + 1)
        DX(I + 2) = DA*DX(I + 2)
        DX(I + 3) = DA*DX(I + 3)
        DX(I + 4) = DA*DX(I + 4)
   50 CONTINUE
      RETURN
      END
      SUBROUTINE F(X,V)
      DOUBLE PRECISION X(1),V(1)
C
C EVALUATE  F(X)  AND RETURN IN THE VECTOR  V .
C
      RETURN
      END
      SUBROUTINE FFUNP(N,NUMT,MMAXT,KDEG,COEF,CL,X,
     $ XX,TRM,DTRM,CLX,DXNP1,F,DF)
C
C FFUNP  EVALUATES THE SYSTEM "F(X)=0" AND ITS PARTIAL
C DERIVATIVES, USING THE "TABLEAU" INPUT: N,NUMT,KDEG,COEF.
C
C FFUNP  CAN BE MADE MORE EFFICIENT BY CUSTOMIZING IT TO
C PARTICULAR SYSTEM TYPES.  FOR EXAMPLE,
C IF X(1)**2 AND X(1)**3 ARE USED IN SEVERAL
C EQUATIONS, THE CURRENT  FFUNP  RECOMPUTES BOTH OF THESE FOR
C EACH EQUATION.  BUT (OF COURSE) WE CAN COMPUTE
C X1SQ=X(1)**2 AND X1CU=XSQ(1)*X(1), AND
C USE THESE IN EACH OF THE EQUATIONS.
C
C THE PART OF THE CODE BELOW LABELED "BLOCK A" CAN BE
C CUSTOMIZED IN THIS WAY.   (THE CODE OUTSIDE OF
C BLOCK A CONCERNS THE PROJECTIVE TRANSFORMATION AND NEED NOT
C BE CHANGED.)  HOWEVER, BLOCK A REQUIRES THE HOMOGENEOUS FORM
C OF THE POLYNOMIALS RATHER THAN THE STANDARD FORM.  FURTHER,
C THE PARTIAL DERIVATIVES WITH RESPECT TO ALL N+1 PROJECTIVE
C VARIABLES MUST BE COMPUTED.  MORE EXPLICITLY,
C THE ORIGINAL SYSTEM, F(X)=0, IS GIVEN IN "NON-HOMOGENEOUS FORM" AS
C DESCRIBED IN SUBROUTINE POLSYS.  F(X)  IS
C REPRESENTED IN "HOMOGENEOUS FORM" AS FOLLOWS:
C
C              NUMT(J)
C
C    F(J) =     SUM   TRM(J,K)
C
C               K=1
C
C WHERE  TRM(J,K)=COEF(J,K) * XX(J,1,K)*XX(J,2,K)* ... *XX(J,N+1,K)
C
C WITH XX(J,L,K) = X(L)**KDEG(J,L,K) FOR J=1 TO N, L=1 TO N, AND
C K=1 TO NUMT(J), AND WITH XX(J,N+1,K) = XNP1**KDEG(J,N+1,K) FOR J=1 TO
C N AND K=1 TO NUMT(J), WHERE  XNP1  IS THE "HOMOGENEOUS COORDINATE,"
C KDEG(J,N+1,K)=IDEG(J)-(KDEG(J,1,K)+ ... + KDEG(J,N,K)),
C AND IDEG(J) THE DEGREE OF THE J-TH EQUATION.   XNP1  IS GENERATED
C FROM  X  AND  CL  BEFORE BLOCK A.
C
C IN THIS DISCUSSION WE HAVE OMITTED, FOR SIMPLICITY OF
C EXPOSITION, THE LEADING INDEX, WHICH DIFFERENTIATES THE
C REAL AND IMAGINARY PARTS.  HOWEVER, THIS INDEX MUST NOT BE
C OMITTED IN THE CODE.
C
C WE COMPLETE THE EXPOSITION OF "REPLACING BLOCK A WITH MORE EFFICIENT
C CODE" WITH AN EXPLICIT EXAMPLE.  FIRST, THE SYSTEM IS DESCRIBED.
C THEN THE CODE THAT SHOULD BE USED IS GIVEN (COMMENTED OUT).
C IN TESTS  POLSYS  WITH THE MORE EFFICIENT  FFUNP  RAN ABOUT TWICE AS
C FAST AS WITH THE GENERIC  FFUNP .
C
C HERE IS THE SYSTEM TO BE SOLVED:
C
C     F(1) = COEF(1,1) * X(1)**4
C    &     + COEF(1,2) * X(1)**3 * X(2)
C    &     + COEF(1,3) * X(1)**3
C    &     + COEF(1,4) * X(1)
C    &     + COEF(1,5)
C     F(2) = COEF(2,1) * X(1)     * X(2)**2
C    &     + COEF(2,2)              X(2)**2
C    &     + COEF(2,3)
C
C THE REPLACEMENT CODE REQUIRES THE FOLLOWING DECLARATIONS:
C     DOUBLE PRECISION X1SQ,X1CU,X2SQ,X3SQ,X3CU,
C    &  TEMPA,TEMPB,TEMPC,TEMPD,TEMPE,TEMPF
C     DIMENSION X1SQ(2),X1CU(2),X2SQ(2),X3SQ(2),X3CU(2),
C    &  TEMPA(2),TEMPB(2),TEMPC(2),TEMPD(2),TEMPE(2),TEMPF(2)
C
C HERE IS CODE TO REPLACE BLOCK A:
C
C******************  BEGIN BLOCK A  *******************
C
C     CALL MULP(X(1,1),X(1,1),X1SQ)
C     CALL MULP(X1SQ  ,X(1,1),X1CU)
C     CALL MULP(X(1,2),X(1,2),X2SQ)
C     CALL MULP(XNP1,  XNP1,  X3SQ)
C     CALL MULP(X3SQ  ,XNP1,  X3CU)
C
C     DO 1 I=1,2
C       TEMPA(I)=   COEF(1,1) * X(I,1)
C    &            + COEF(1,2) * X(I,2)
C    &            + COEF(1,3) * XNP1(I)
C       TEMPB(I)=   COEF(1,4) * X(I,1)
C    &            + COEF(1,5) * XNP1(I)
C 1   CONTINUE
C
C     CALL MULP(X1SQ,  TEMPA,TEMPC)
C     CALL MULP(X(1,1),TEMPC,TEMPD)
C     CALL MULP(X3SQ,  TEMPB,TEMPE)
C     CALL MULP(XNP1,  TEMPE,TEMPF)
C
C     DO 2 I=1,2
C       F(I,1)=TEMPD(I) + TEMPF(I)
C       DF(I,1,1)= 3. *TEMPC(I) + COEF(1,1)*X1CU(I) + COEF(1,4)*X3CU(I)
C       DF(I,1,2)= COEF(1,2) * X1CU(I)
C       DF(I,1,3)= COEF(1,3)*X1CU(I) + 3. *TEMPE(I) + COEF(1,5)*X3CU(I)
C
C       TEMPA(I) = COEF(2,1) * X(I,1) + COEF(2,2) * XNP1(I)
C  2  CONTINUE
C
C     CALL MULP(TEMPA,X(1,2),TEMPB)
C     CALL MULP(TEMPB,X(1,2),TEMPC)
C
C     DO 3 I=1,2
C       F(I,2) = TEMPC(I) + COEF(2,3) * X3CU(I)
C       DF(I,2,1) = COEF(2,1) * X2SQ(I)
C       DF(I,2,2) = 2. * TEMPB(I)
C       DF(I,2,3) = COEF(2,2) * X2SQ(I) + COEF(2,3) * 3. * X3SQ(I)
C  3  CONTINUE
C******************  END OF BLOCK A  *******************
C
C ON INPUT:
C
C N  IS THE NUMBER OF EQUATIONS AND VARIABLES.
C
C NUMT(J)  IS THE NUMBER OF TERMS IN THE JTH EQUATION.
C
C MMAXT  IS AN UPPER BOUND ON NUMT(J) FOR J=1 TO N.
C
C KDEG(J,L,K)  IS THE DEGREE OF THE L-TH VARIABLE IN THE K-TH TERM
C   OF THE J-TH EQUATION.
C
C COEF(J,K)  IS THE K-TH COEFFICIENT OF THE J-TH EQUATION.
C
C CL  IS USED TO DEFINE THE PROJECTIVE TRANSFORMATION.  IF
C   THE PROJECTIVE TRANSFORMATION IS NOT SPECIFIED, THEN  CL
C   CONTAINS DUMMY VALUES.
C
C X(1,J), X(2,J)  ARE THE REAL AND IMAGINARY PARTS RESPECTIVELY OF
C   THE J-TH INDEPENDENT VARIABLE.
C
C XX, TRM, DTRM, CLX, DXNP1  ARE WORKSPACE VARIABLES.
C
C ON OUTPUT:
C
C F(1,J), F(2,J)  ARE THE REAL AND IMAGINARY PARTS RESPECTIVELY OF
C   THE J-TH EQUATION.
C
C DF(1,J,K), DF(2,J,K)  ARE THE REAL AND IMAGINARY PARTS RESPECTIVELY
C   OF THE K-TH PARTIAL DERIVATIVE OF THE J-TH EQUATION.
C
C
C VARIABLES: XNP1,TEMP1,TEMP2.
C
C NOTE:  XNP1(1), XNP1(2)  ARE THE REAL AND IMAGINARY PARTS,
C   RESPECTIVELY, OF THE PROJECTIVE VARIABLE.  XNP1  IS UNITY
C   IF THE PROJECTIVE TRANSFORMATION IS NOT SPECIFIED.
C
C  SUBROUTINES: MULP,POWP,DIVP.
C
C
C DECLARATION OF INPUT AND OUTPUT:
      INTEGER N,NUMT,MMAXT,KDEG
      DOUBLE PRECISION COEF,CL,X,XX,TRM,DTRM,CLX,DXNP1,F,DF
      DIMENSION NUMT(N),KDEG(N,N+1,MMAXT),
     $  COEF(N,MMAXT),CL(2,N+1),X(2,N),
     $  XX(2,N,N+1,MMAXT),TRM(2,N,MMAXT),DTRM(2,N,N+1,MMAXT),
     $  CLX(2,N),DXNP1(2,N),F(2,N),DF(2,N,N+1)
C
C DECLARATION OF VARIABLES:
      INTEGER I,IERR,J,K,L,M,NNNN,NP1
      DOUBLE PRECISION TEMP1,TEMP2,XNP1
      DIMENSION TEMP1(2),TEMP2(2),XNP1(2)
C
      NP1=N+1
C
C GENERATE XNP1, THE PROJECTIVE COORDINATE, AND ITS DERIVATIVES.
      DO 40 J=1,N
         CALL MULP(CL(1,J),X(1,J),CLX(1,J))
 40   CONTINUE
C
      DO 60 I=1,2
          XNP1(I)=CL(I,NP1)
          DO 50 J=1,N
              XNP1(I) = XNP1(I) + CLX(I,J)
              DXNP1(I,J)=CL(I,J)
 50       CONTINUE
 60   CONTINUE
C
C******************  BEGIN BLOCK A  *******************
C
C "BLOCK A" TAKES  X  AND  XNP1  AS INPUT AND RETURNS  F
C AND  DF  AS OUTPUT.   F  IS THE HOMOGENEOUS FORM OF THE
C ORIGINAL  F, AND  DF  CONSISTS OF THE PARTIAL
C DERIVATIVES OF THE HOMOGENEOUS FORM OF  F  WITH RESPECT
C TO THE N+1 VARIABLES X(1), ... ,X(N), XNP1.
C
C BEGIN "COMPUTE F"
C
      DO 100 J=1,N
        DO 100 K=1,NUMT(J)
          CALL POWP(KDEG(J,NP1,K),XNP1, XX(1,J,NP1,K))
          DO 100 L=1,N
            CALL POWP(KDEG(J, L,K),X(1,L),XX(1,J,  L,K))
 100  CONTINUE
      DO 200 J=1,N
        DO 200 K=1,NUMT(J)
          TRM(1,J,K)=COEF(J,K)
          TRM(2,J,K)=0.0
          DO 120 L=1,NP1
            CALL MULP(XX(1,J,L,K), TRM(1,J,K),TEMP1)
            TRM(1,J,K  )=TEMP1(1)
            TRM(2,J,K  )=TEMP1(2)
 120      CONTINUE
 200  CONTINUE
      DO 300 J=1,N
          F(1,J)=0.0
          F(2,J)=0.0
          DO 220 I=1,2
          DO 220 K=1,NUMT(J)
              F(I,J)= F(I,J) + TRM(I,J,K)
 220      CONTINUE
 300  CONTINUE
C
C END OF "COMPUTE F"
C
C BEGIN "COMPUTE DF"
C
      DO 400 J=1,N
        DO 400 K=1,NUMT(J)
        DO 400 M=1,NP1
C
C IF TERM DOES NOT INCLUDE X(M), SET PARTIAL DERIVATIVE OF TERM
C   EQUAL TO ZERO.
          IF(KDEG(J,M,K) .EQ. 0) THEN
            DTRM(1,J,M,K)=0.0
            DTRM(2,J,M,K)=0.0
          ELSE
C
C IF TERM DOES INCLUDE X(M), TRY COMPUTING THE PARTIAL BY DIVIDING
C   THE TERM BY X(M).
            IF(M.LE.N) CALL DIVP(TRM(1,J,K),X(1,M),DTRM(1,J,M,K),IERR)
            IF(M.EQ.NP1) CALL DIVP(TRM(1,J,K),XNP1,DTRM(1,J,M,K),IERR)
            IF (IERR .EQ. 0) THEN
              DTRM(1,J,M,K)=KDEG(J,M,K)*DTRM(1,J,M,K)
              DTRM(2,J,M,K)=KDEG(J,M,K)*DTRM(2,J,M,K)
            ELSE
C
C IF DIVISION WOULD CAUSE OVERFLOW, GENERATE THE PARTIAL BY
C   THE POLYNOMIAL FORMULA.
              DTRM(1,J,M,K)=COEF(J,K)
              DTRM(2,J,M,K)=0.0
              DO 320 L=1,NP1
                IF (L .EQ. M) GOTO 320
                CALL MULP(XX(1,J,L,K),DTRM(1,J,M,K),TEMP1)
                DTRM(1,J,M,K)=TEMP1(1)
                DTRM(2,J,M,K)=TEMP1(2)
 320          CONTINUE
              NNNN=KDEG(J,M,K)-1
              IF (M .LE. N) CALL POWP(NNNN,X(1,M),TEMP2)
              IF (M .EQ. NP1) CALL POWP(NNNN,XNP1 ,TEMP2)
              CALL MULP(TEMP2,TEMP1,DTRM(1,J,M,K))
              DTRM(1,J,M,K)=KDEG(J,M,K)*DTRM(1,J,M,K)
              DTRM(2,J,M,K)=KDEG(J,M,K)*DTRM(2,J,M,K)
            END IF
          END IF
 400  CONTINUE
      DO 600 J=1,N
      DO 600 M=1,NP1
          DF(1,J,M)=0.0
          DF(2,J,M)=0.0
          DO 420 I=1,2
            DO 420 K=1,NUMT(J)
              DF(I,J,M)= DF(I,J,M) + DTRM(I,J,M,K)
 420      CONTINUE
 600  CONTINUE
C
C END OF "COMPUTE DF"
C*******************  END BLOCK A  ********************
C
C CONVERT  DF  TO BE PARTIALS WITH RESPECT TO  X(1), ... ,X(N),
C BY APPLYING THE CHAIN RULE WITH  XNP1  CONSIDERED A FUNCTION OF
C OF  X(1), ... ,X(N).
C
      DO 700 J=1,N
        DO 700 K=1,N
          CALL MULP(DF(1,J,NP1),DXNP1(1,K),TEMP1)
          DO 700 I=1,2
            DF(I,J,K)=DF(I,J,K)+TEMP1(I)
 700  CONTINUE
      RETURN
      END
*
      SUBROUTINE FIXPDF(N,Y,IFLAG,ARCTOL,EPS,TRACE,A,NDIMA,NFE,
     $     ARCLEN,YP,YPOLD,QR,ALPHA,TZ,PIVOT,WT,PHI,P,PAR,IPAR)
C
C SUBROUTINE  FIXPDF  FINDS A FIXED POINT OR ZERO OF THE
C N-DIMENSIONAL VECTOR FUNCTION F(X), OR TRACKS A ZERO CURVE
C OF A GENERAL HOMOTOPY MAP RHO(A,LAMBDA,X).  FOR THE FIXED
C POINT PROBLEM F(X) IS ASSUMED TO BE A C2 MAP OF SOME BALL
C INTO ITSELF.  THE EQUATION  X = F(X)  IS SOLVED BY
C FOLLOWING THE ZERO CURVE OF THE HOMOTOPY MAP
C
C  LAMBDA*(X - F(X)) + (1 - LAMBDA)*(X - A)  ,
C
C STARTING FROM LAMBDA = 0, X = A.  THE CURVE IS PARAMETERIZED
C BY ARC LENGTH S, AND IS FOLLOWED BY SOLVING THE ORDINARY
C DIFFERENTIAL EQUATION  D(HOMOTOPY MAP)/DS = 0  FOR
C Y(S) = (LAMBDA(S), X(S)).
C
C FOR THE ZERO FINDING PROBLEM F(X) IS ASSUMED TO BE A C2 MAP
C SUCH THAT FOR SOME R > 0,  X*F(X) >= 0  WHENEVER NORM(X) = R.
C THE EQUATION  F(X) = 0  IS SOLVED BY FOLLOWING THE ZERO CURVE
C OF THE HOMOTOPY MAP
C
C   LAMBDA*F(X) + (1 - LAMBDA)*(X - A)
C
C EMANATING FROM LAMBDA = 0, X = A.
C
C  A  MUST BE AN INTERIOR POINT OF THE ABOVE MENTIONED BALLS.
C
C FOR THE CURVE TRACKING PROBLEM RHO(A,LAMBDA,X) IS ASSUMED TO
C BE A C2 MAP FROM E**M X [0,1) X E**N INTO E**N, WHICH FOR
C ALMOST ALL PARAMETER VECTORS A IN SOME NONEMPTY OPEN SUBSET
C OF E**M SATISFIES
C
C  RANK [D RHO(A,LAMBDA,X)/D LAMBDA , D RHO(A,LAMBDA,X)/DX] = N
C
C FOR ALL POINTS (LAMBDA,X) SUCH THAT RHO(A,LAMBDA,X)=0.  IT IS
C FURTHER ASSUMED THAT
C
C           RANK [ D RHO(A,0,X0)/DX ] = N  .
C
C WITH A FIXED, THE ZERO CURVE OF RHO(A,LAMBDA,X) EMANATING
C FROM  LAMBDA = 0, X = X0  IS TRACKED UNTIL  LAMBDA = 1  BY
C SOLVING THE ORDINARY DIFFERENTIAL EQUATION
C D RHO(A,LAMBDA(S),X(S))/DS = 0  FOR  Y(S) = (LAMBDA(S), X(S)),
C WHERE S IS ARC LENGTH ALONG THE ZERO CURVE.  ALSO THE HOMOTOPY
C MAP RHO(A,LAMBDA,X) IS ASSUMED TO BE CONSTRUCTED SUCH THAT
C
C              D LAMBDA(0)/DS > 0  .
C
C THIS CODE IS BASED ON THE ALGORITHM IN L. T. WATSON, A
C GLOBALLY CONVERGENT ALGORITHM FOR COMPUTING FIXED POINTS OF
C C2 MAPS, APPL. MATH. COMPUT., 5 (1979) 297-311.
C
C
C FOR THE FIXED POINT AND ZERO FINDING PROBLEMS, THE USER
C MUST SUPPLY A SUBROUTINE  F(X,V)  WHICH EVALUATES F(X) AT X
C AND RETURNS THE VECTOR F(X) IN V, AND A SUBROUTINE  FJAC(X,V,K)
C WHICH RETURNS IN V THE KTH COLUMN OF THE JACOBIAN MATRIX OF
C F(X) EVALUATED AT X.  FOR THE CURVE TRACKING PROBLEM, THE USER MUST
C SUPPLY A SUBROUTINE  RHOA(V,LAMBDA,X,PAR,IPAR)  WHICH GIVEN
C (LAMBDA,X) RETURNS A PARAMETER VECTOR A IN V SUCH THAT
C RHO(A,LAMBDA,X)=0, AND A SUBROUTINE  RHOJAC(A,LAMBDA,X,V,K,PAR,IPAR)
C WHICH RETURNS IN V THE KTH COLUMN OF THE N X (N+1) JACOBIAN
C MATRIX [D RHO/D LAMBDA, D RHO/DX] EVALUATED AT (A,LAMBDA,X).
C  FIXPDF  DIRECTLY OR INDIRECTLY USES THE SUBROUTINES
C  STEPS , SINTRP , ROOT , FODE , F (OR  RHOA ),
C FJAC (OR  RHOJAC ), DCPOSE , D1MACH , AND THE BLAS FUNCTIONS
C DDOT  AND  DNRM2 .  ONLY  D1MACH  CONTAINS MACHINE
C DEPENDENT CONSTANTS.  NO OTHER MODIFICATIONS BY THE USER ARE
C REQUIRED.
C
C ***WARNING:  THIS SUBROUTINE IS GENERALLY MORE ROBUST THAN  FIXPNF
C AND  FIXPQF , BUT MAY BE SLOWER THAN THOSE SUBROUTINES BY A
C FACTOR OF TWO.
C
C
C ON INPUT:
C
C N  IS THE DIMENSION OF X, F(X), AND RHO(A,LAMBDA,X).
C
C Y  IS AN ARRRAY OF LENGTH  N + 1.  (Y(2),...,Y(N+1)) = A  IS THE
C    STARTING POINT FOR THE ZERO CURVE FOR THE FIXED POINT AND
C    ZERO FINDING PROBLEMS.  (Y(2),...,Y(N+1)) = X0  FOR THE CURVE
C    TRACKING PROBLEM.
C
C IFLAG  CAN BE -2, -1, 0, 2, OR 3.  IFLAG  SHOULD BE 0 ON THE
C    FIRST CALL TO  FIXPDF  FOR THE PROBLEM  X=F(X), -1 FOR THE
C    PROBLEM  F(X)=0, AND -2 FOR THE PROBLEM  RHO(A,LAMBDA,X)=0.
C    IN CERTAIN SITUATIONS  IFLAG  IS SET TO 2 OR 3 BY  FIXPDF,
C    AND  FIXPDF  CAN BE CALLED AGAIN WITHOUT CHANGING  IFLAG.
C
C ARCTOL  IS THE LOCAL ERROR ALLOWED THE ODE SOLVER WHEN
C    FOLLOWING THE ZERO CURVE.  IF  ARCTOL .LE. 0.0  ON INPUT
C    IT IS RESET TO  .5*DSQRT(EPS).  NORMALLY  ARCTOL  SHOULD
C    BE CONSIDERABLY LARGER THAN  EPS.
C
C EPS  IS THE LOCAL ERROR ALLOWED THE ODE SOLVER WHEN VERY
C    NEAR THE FIXED POINT(ZERO).  EPS  IS APPROXIMATELY THE
C    MIXED ABSOLUTE AND RELATIVE ERROR IN THE COMPUTED FIXED
C    POINT(ZERO).
C
C TRACE  IS AN INTEGER SPECIFYING THE LOGICAL I/O UNIT FOR
C    INTERMEDIATE OUTPUT.  IF  TRACE .GT. 0  THE POINTS COMPUTED ON
C    THE ZERO CURVE ARE WRITTEN TO I/O UNIT  TRACE .
C
C A(1:NDIMA) CONTAINS THE PARAMETER VECTOR  A .  FOR THE FIXED POINT
C    AND ZERO FINDING PROBLEMS, A  NEED NOT BE INITIALIZED BY THE
C    USER, AND IS ASSUMED TO HAVE LENGTH  N.  FOR THE CURVE
C    TRACKING PROBLEM, A  HAS LENGTH  NDIMA  AND MUST BE INITIALIZED
C    BY THE USER.
C
C NDIMA  IS THE DIMENSION OF  A, AND IS USED ONLY FOR THE CURVE
C    TRACKING PROBLEM.
C
C YP(1:N+1) IS A WORK ARRAY CONTAINING THE CURRENT TANGENT
C    VECTOR TO THE ZERO CURVE.
C
C YPOLD(1:N+1) IS A WORK ARRAY CONTAINING THE PREVIOUS TANGENT
C    VECTOR TO THE ZERO CURVE.
C
C QR(1:N,1:N+1), ALPHA(1:N), TZ(1:N+1), AND PIVOT(1:N+1) ARE
C    ALL WORK ARRAYS USED BY  FODE  TO CALCULATE THE TANGENT
C    VECTOR YP.
C
C WT(1:N+1), PHI(1:N+1,1:16), AND P(1:N+1) ARE ALL WORK ARRAYS
C    USED BY THE ODE SUBROUTINE  STEPS  .
C
C PAR(1:*) AND IPAR(1:*) ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS,
C    WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES
C    RHOA, RHOJAC.
C
C Y, ARCTOL, EPS, ARCLEN, NFE, AND IFLAG SHOULD ALL BE
C VARIABLES IN THE CALLING PROGRAM.
C
C
C ON OUTPUT:
C
C N  AND  TRACE  ARE UNCHANGED.
C
C Y(1) = LAMBDA, (Y(2),...,Y(N+1)) = X, AND Y IS AN APPROXIMATE
C    ZERO OF THE HOMOTOPY MAP.  NORMALLY LAMBDA = 1 AND X IS A
C    FIXED POINT(ZERO) OF F(X).  IN ABNORMAL SITUATIONS LAMBDA
C    MAY ONLY BE NEAR 1 AND X IS NEAR A FIXED POINT(ZERO).
C
C IFLAG =
C  -2   CAUSES  FIXPDF  TO INITIALIZE EVERYTHING FOR THE PROBLEM
C       RHO(A,LAMBDA,X) = 0 (USE ON FIRST CALL).
C
C  -1   CAUSES  FIXPDF  TO INITIALIZE EVERYTHING FOR THE PROBLEM
C       F(X) = 0 (USE ON FIRST CALL).
C
C   0   CAUSES  FIXPDF  TO INITIALIZE EVERYTHING FOR THE PROBLEM
C       X = F(X) (USE ON FIRST CALL).
C
C   1   NORMAL RETURN.
C
C   2   SPECIFIED ERROR TOLERANCE CANNOT BE MET.  EPS HAS BEEN
C       INCREASED TO A SUITABLE VALUE.  TO CONTINUE, JUST CALL
C       FIXPDF  AGAIN WITHOUT CHANGING ANY PARAMETERS.
C
C   3   STEPS  HAS BEEN CALLED 1000 TIMES.  TO CONTINUE, CALL
C       FIXPDF  AGAIN WITHOUT CHANGING ANY PARAMETERS.
C
C   4   JACOBIAN MATRIX DOES NOT HAVE FULL RANK.  THE ALGORITHM
C       HAS FAILED (THE ZERO CURVE OF THE HOMOTOPY MAP CANNOT BE
C       FOLLOWED ANY FURTHER).
C
C   5   EPS  (OR  ARCTOL ) IS TOO LARGE.  THE PROBLEM SHOULD BE
C       RESTARTED BY CALLING  FIXPDF  WITH A SMALLER  EPS  (OR
C       ARCTOL ) AND  IFLAG = 0 (-1, -2).
C
C   6   I - DF(X)  IS NEARLY SINGULAR AT THE FIXED POINT (DF(X) IS
C       NEARLY SINGULAR AT THE ZERO, OR  D RHO(A,LAMBDA,X)/DX  IS
C       NEARLY SINGULAR AT  LAMBDA = 1 ).  ANSWER MAY NOT BE
C       ACCURATE.
C
C   7   ILLEGAL INPUT PARAMETERS, A FATAL ERROR.
C
C ARCTOL = EPS AFTER A NORMAL RETURN (IFLAG = 1).
C
C EPS  IS UNCHANGED AFTER A NORMAL RETURN (IFLAG = 1).  IT IS
C    INCREASED TO AN APPROPRIATE VALUE ON THE RETURN IFLAG = 2.
C
C A  WILL (NORMALLY) HAVE BEEN MODIFIED.
C
C NFE  IS THE NUMBER OF FUNCTION EVALUATIONS (= NUMBER OF
C    JACOBIAN EVALUATIONS).
C
C ARCLEN  IS THE LENGTH OF THE PATH FOLLOWED.
C
C
      DOUBLE PRECISION AOLD,ARCLEN,ARCTOL,CURSW,CURTOL,EPS,
     1  EPSSTP,EPST,H,HOLD,S,S99,SA,SB,SOUT,SQNP1,XOLD,Y1SOUT
      INTEGER IFLAG,IFLAGC,ITER,IVC,J,JUDY,JW,K,KGI,KOLD,
     1  KSTEPS,LCODE,LIMIT,LIMITD,N,NDIMA,NFE,NFEC,NP1,TRACE
      LOGICAL START,CRASH,ST99
C
C *****  ARRAY DECLARATIONS.  *****
C
C ARRAYS NEEDED BY THE ODE SUBROUTINE  STEPS .
      DOUBLE PRECISION Y(N+1),WT(N+1),PHI(N+1,16),P(N+1),YP(N+1),
     1     ALPHAS(12),W(12),G(13),GI(11)
      INTEGER IV(10)
C
C ARRAYS NEEDED BY  FIXPDF , FODE , AND  DCPOSE .
      DOUBLE PRECISION YPOLD(N+1),A(N),QR(N,N+1),ALPHA(N),TZ(N+1),
     $     PAR(1)
      INTEGER PIVOT(N+1),IPAR(1)
C
C *****  END OF DIMENSIONAL INFORMATION.  *****
C
      SAVE
      EXTERNAL FODE
C
C LIMITD  IS AN UPPER BOUND ON THE NUMBER OF STEPS.  IT MAY BE
C CHANGED BY CHANGING THE FOLLOWING PARAMETER STATEMENT:
      PARAMETER (LIMITD=1000)
C
C
C :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :
      IF (N .LE. 0  .OR.  EPS .LE. 0.0 ) IFLAG=7
      IF (IFLAG .GE. -2  .AND.  IFLAG .LE. 0) GO TO 10
      IF (IFLAG .EQ. 2) GO TO 35
      IF (IFLAG .EQ. 3) GO TO 30
C ONLY VALID INPUT FOR  IFLAG  IS -2, -1, 0, 2, 3.
      IFLAG=7
      RETURN
C
C *****  INITIALIZATION BLOCK.  *****
C
10    ARCLEN=0.0
      S=0.0
      IF (ARCTOL .LE. 0.0) ARCTOL=.5*SQRT(EPS)
      NFEC=0
      IFLAGC=IFLAG
      NP1=N+1
      SQNP1=SQRT(DBLE(NP1))
C
C SWITCH FROM THE TOLERANCE  ARCTOL  TO THE (FINER) TOLERANCE  EPS  IF
C THE CURVATURE OF ANY COMPONENT OF  Y  EXCEEDS  CURSW.
C
      CURSW=10.0
C
      ST99=.FALSE.
      START=.TRUE.
      CRASH=.FALSE.
      HOLD=1.0
      H=.1
      EPSSTP=ARCTOL
      KSTEPS=0
C SET INITIAL CONDITIONS FOR ORDINARY DIFFERENTIAL EQUATION.
      YPOLD(1)=1.0
      YP(1)=1.0
      Y(1)=0.0
      DO 20 J=2,NP1
        YPOLD(J)=0.0
        YP(J)=0.0
20    CONTINUE
C LOAD  A  FOR THE FIXED POINT AND ZERO FINDING PROBLEMS.
      IF (IFLAGC .GE. -1) THEN
        DO 23 J=2,NP1
          A(J-1)=Y(J)
23      CONTINUE
      ENDIF
30    LIMIT=LIMITD
C
C *****  END OF INITIALIZATION BLOCK.  *****
C
C
C *****  MAIN LOOP.  *****
C
35    DO 150 ITER=1,LIMIT
      IF (Y(1) .LT. 0.0) THEN
40      ARCLEN=ARCLEN+S
        IFLAG=5
        RETURN
      ENDIF
50    IF (S .LE. 7.0*SQNP1) GO TO 80
C ARC LENGTH IS GETTING TOO LONG, THE PROBLEM WILL BE
C RESTARTED WITH A DIFFERENT  A  VECTOR.
      ARCLEN=ARCLEN+S
      S=0.0
60    START=.TRUE.
      CRASH=.FALSE.
C COMPUTE A NEW  A  VECTOR.
      IF (IFLAGC .EQ. -2) THEN
        DO 63 JW=1,NDIMA
          QR(JW,1)=A(JW)
63      CONTINUE
        CALL RHOA(A,Y(1),Y(2),PAR,IPAR)
        DO 65 JW=1,NDIMA
          AOLD=QR(JW,1)
C IF NEW AND OLD  A  DIFFER BY TOO MUCH, TRACKING SHOULD NOT CONTINUE.
          IF (ABS(A(JW)-AOLD) .GT. 1.0+ABS(AOLD)) THEN
            ARCLEN=ARCLEN+S
            IFLAG=5
            RETURN
          ENDIF
65      CONTINUE
      ELSE
        CALL F(Y(2),YP)
        DO 70 JW=1,N
          AOLD=A(JW)
          IF (IFLAGC .EQ. -1) THEN
            A(JW)=Y(1)*YP(JW)/(1.0 - Y(1)) + Y(JW+1)
          ELSE
            A(JW)=(Y(JW+1) - Y(1)*YP(JW))/(1.0 - Y(1))
          ENDIF
C IF NEW AND OLD  A  DIFFER BY TOO MUCH, TRACKING SHOULD NOT CONTINUE.
          IF (ABS(A(JW)-AOLD) .GT. 1.0+ABS(AOLD)) THEN
            ARCLEN=ARCLEN+S
            IFLAG=5
            RETURN
          ENDIF
70      CONTINUE
      ENDIF
      GO TO 100
80    IF (Y(1) .LE. .99  .OR. ST99) GO TO 100
C WHEN LAMBDA REACHES .99, THE PROBLEM WILL BE RESTARTED WITH
C A NEW  A  VECTOR.
90    ST99=.TRUE.
      EPSSTP=EPS
      ARCTOL=EPS
      GO TO 60
C
C SET DIFFERENT ERROR TOLERANCE FOR HIGH CURVATURE COMPONENTS OF THE
C TRAJECTORY Y(S).
100   CURTOL=CURSW*HOLD
      EPST=EPS/EPSSTP
      DO 110 JW=1,NP1
        IF (ABS(YP(JW)-YPOLD(JW)) .LE. CURTOL) THEN
          WT(JW)=(ABS(Y(JW))+1.0)
        ELSE
          WT(JW)=(ABS(Y(JW))+1.0)*EPST
        ENDIF
110   CONTINUE
C
C TAKE A STEP ALONG THE CURVE.
      CALL STEPS(FODE,NP1,Y,S,H,EPSSTP,WT,START,HOLD,K,KOLD,CRASH,
     +     PHI,P,YP,ALPHAS,W,G,KSTEPS,XOLD,IVC,IV,KGI,GI,
     +     YPOLD,A,QR,ALPHA,TZ,PIVOT,NFEC,IFLAGC,PAR,IPAR)
C PRINT LATEST POINT ON CURVE IF REQUESTED.
      IF (TRACE .GT. 0) THEN
        WRITE (TRACE,117) ITER,NFEC,S,Y(1),(Y(JW),JW=2,NP1)
117     FORMAT(/' STEP',I5,3X,'NFE =',I5,3X,'ARC LENGTH =',F9.4,3X,
     $  'LAMBDA =',F7.4,5X,'X vector:'/1P,(1X,6E12.4))
      ENDIF
      NFE=NFEC
C CHECK IF THE STEP WAS SUCCESSFUL.
      IF (IFLAGC .EQ. 4) THEN
        ARCLEN=ARCLEN+S
        IFLAG=4
        RETURN
      ENDIF
120   IF (CRASH) THEN
C RETURN CODE FOR ERROR TOLERANCE TOO SMALL.
        IFLAG=2
C CHANGE ERROR TOLERANCES.
        EPS=EPSSTP
        IF (ARCTOL .LT. EPS) ARCTOL=EPS
C CHANGE LIMIT ON NUMBER OF ITERATIONS.
        LIMIT=LIMIT-ITER
        RETURN
      ENDIF
C
130   IF (Y(1) .GE. 1.0) THEN
        IF (ST99) GO TO 160
C
C IF LAMBDA .GE. 1.0 BUT THE PROBLEM HAS NOT BEEN RESTARTED
C WITH A NEW  A  VECTOR, BACK UP AND RESTART.
C
        S99=S-.5*HOLD
C GET AN APPROXIMATE ZERO Y(S) WITH  Y(1)=LAMBDA .LT. 1.0  .
135     CALL SINTRP(S,Y,S99,WT,YP,NP1,KOLD,PHI,IVC,IV,KGI,GI,
     $     ALPHAS,G,W,XOLD,P)
        IF (WT(1) .LT. 1.0) GO TO 140
        S99=.5*(S-HOLD+S99)
        GO TO 135
C
140     DO 144 JUDY=1,NP1
          Y(JUDY)=WT(JUDY)
          YPOLD(JUDY)=YP(JUDY)
144     CONTINUE
        S=S99
        GO TO 90
      ENDIF
C
150   CONTINUE
C
C *****  END OF MAIN LOOP.  *****
C
C LAMBDA HAS NOT REACHED 1 IN 1000 STEPS.
      IFLAG=3
      RETURN
C
C
C USE INVERSE INTERPOLATION TO GET THE ANSWER AT LAMBDA = 1.0 .
C
160   SA=S-HOLD
      SB=S
      LCODE=1
170   CALL ROOT(SOUT,Y1SOUT,SA,SB,EPS,EPS,LCODE)
C ROOT  FINDS S SUCH THAT Y(1)(S) = LAMBDA = 1 .
      IF (LCODE .GT. 0) GO TO 190
      CALL SINTRP(S,Y,SOUT,WT,YP,NP1,KOLD,PHI,IVC,IV,KGI,GI,
     $     ALPHAS,G,W,XOLD,P)
      Y1SOUT=WT(1)-1.0
      GO TO 170
190   IFLAG=1
C SET IFLAG = 6 IF  ROOT  COULD NOT GET  LAMBDA = 1.0  .
      IF (LCODE .GT. 2) IFLAG=6
      ARCLEN=ARCLEN+SA
C LAMBDA(SA) = 1.0 .
      CALL SINTRP(S,Y,SA,WT,YP,NP1,KOLD,PHI,IVC,IV,KGI,GI,
     $     ALPHAS,G,W,XOLD,P)
C
      DO 210 J=1,NP1
210   Y(J)=WT(J)
      RETURN
      END
      SUBROUTINE FIXPDS(N,Y,IFLAG,ARCTOL,EPS,TRACE,A,NDIMA,NFE,
     $     ARCLEN,YP,YPOLD,QR,LENQR,PIVOT,PP,WORK,WT,PHI,P,
     $     PAR,IPAR)
C
C SUBROUTINE  FIXPDS  FINDS A FIXED POINT OR ZERO OF THE
C N-DIMENSIONAL VECTOR FUNCTION F(X), OR TRACKS A ZERO CURVE
C OF A GENERAL HOMOTOPY MAP RHO(A,X,LAMBDA).  FOR THE FIXED
C POINT PROBLEM F(X) IS ASSUMED TO BE A C2 MAP OF SOME BALL
C INTO ITSELF.  THE EQUATION  X = F(X)  IS SOLVED BY
C FOLLOWING THE ZERO CURVE OF THE HOMOTOPY MAP
C
C  LAMBDA*(X - F(X)) + (1 - LAMBDA)*(X - A)  ,
C
C STARTING FROM LAMBDA = 0, X = A.  THE CURVE IS PARAMETERIZED
C BY ARC LENGTH S, AND IS FOLLOWED BY SOLVING THE ORDINARY
C DIFFERENTIAL EQUATION  D(HOMOTOPY MAP)/DS = 0  FOR
C Y(S) = (X(S), LAMBDA(S)).
C
C FOR THE ZERO FINDING PROBLEM F(X) IS ASSUMED TO BE A C2 MAP
C SUCH THAT FOR SOME R > 0,  X*F(X) >= 0  WHENEVER NORM(X) = R.
C THE EQUATION  F(X) = 0  IS SOLVED BY FOLLOWING THE ZERO CURVE
C OF THE HOMOTOPY MAP
C
C   LAMBDA*F(X) + (1 - LAMBDA)*(X - A)
C
C EMANATING FROM LAMBDA = 0, X = A.
C
C  A  MUST BE AN INTERIOR POINT OF THE ABOVE MENTIONED BALLS.
C
C FOR THE CURVE TRACKING PROBLEM RHO(A,X,LAMBDA) IS ASSUMED TO
C BE A C2 MAP FROM E**M X E**N X [0,1) INTO E**N, WHICH FOR
C ALMOST ALL PARAMETER VECTORS A IN SOME NONEMPTY OPEN SUBSET
C OF E**M SATISFIES
C
C  RANK [D RHO(A,X,LAMBDA)/D LAMBDA , D RHO(A,X,LAMBDA)/DX] = N
C
C FOR ALL POINTS (X,LAMBDA) SUCH THAT RHO(A,X,LAMBDA)=0.  IT IS
C FURTHER ASSUMED THAT
C
C           RANK [ D RHO(A,X0,0)/DX ] = N  .
C
C WITH A FIXED, THE ZERO CURVE OF RHO(A,X,LAMBDA) EMANATING
C FROM  LAMBDA = 0, X = X0  IS TRACKED UNTIL  LAMBDA = 1  BY
C SOLVING THE ORDINARY DIFFERENTIAL EQUATION
C D RHO(A,X(S),LAMBDA(S))/DS = 0  FOR  Y(S) = (X(S), LAMBDA(S)),
C WHERE S IS ARC LENGTH ALONG THE ZERO CURVE.  ALSO THE HOMOTOPY
C MAP RHO(A,X,LAMBDA) IS ASSUMED TO BE CONSTRUCTED SUCH THAT
C
C              D LAMBDA(0)/DS > 0  .
C
C THIS CODE IS BASED ON THE ALGORITHM IN L. T. WATSON, A
C GLOBALLY CONVERGENT ALGORITHM FOR COMPUTING FIXED POINTS OF
C C2 MAPS, APPL. MATH. COMPUT., 5 (1979) 297-311.
C
C
C FOR THE FIXED POINT AND ZERO FINDING PROBLEMS, THE USER
C MUST SUPPLY A SUBROUTINE  F(X,V)  WHICH EVALUATES F(X) AT X
C AND RETURNS THE VECTOR F(X) IN V, AND A SUBROUTINE
C  FJACS(X,QR,LENQR,PIVOT)  WHICH EVALUATES THE (SYMMETRIC)
C JACOBIAN MATRIX OF F(X) AT X, AND RETURNS THE SYMMETRIC
C JACOBIAN MATRIX IN PACKED SKYLINE STORAGE FORMAT IN QR.  LENQR
C AND PIVOT DESCRIBE THE DATA STRUCTURE IN QR.  FOR THE CURVE
C TRACKING PROBLEM, THE USER MUST SUPPLY A SUBROUTINE
C  RHOA(V,LAMBDA,X,PAR,IPAR)  WHICH GIVEN (X,LAMBDA) RETURNS A
C PARAMETER VECTOR A IN V SUCH THAT RHO(A,X,LAMBDA)=0, AND A
C SUBROUTINE  RHOJS(A,LAMBDA,X,QR,LENQR,PIVOT,PP,PAR,IPAR)  WHICH
C RETURNS IN QR THE SYMMETRIC N X N JACOBIAN MATRIX [D RHO/DX]
C EVALUATED AT (A,X,LAMBDA) AND STORED IN PACKED SKYLINE FORMAT,
C AND RETURNS IN PP THE VECTOR -(D RHO/D LAMBDA) EVALUATED AT
C (A,X,LAMBDA).  LENQR AND PIVOT DESCRIBE THE DATA STRUCTURE IN QR.
C *** NOTE THE MINUS SIGN IN THE DEFINITION OF PP. ***
C
C
C FUNCTIONS AND SUBROUTINES DIRECTLY OR INDIRECTLY CALLED BY FIXPDS:
C  D1MACH , F (OR  RHOA ), FJACS (OR  RHOJS ), FODEDS , GMFADS ,
C  MFACDS , MULTDS , PCGDS , QIMUDS , ROOT , SINTRP , SOLVDS ,
C  STEPDS , AND THE BLAS FUNCTIONS  DAXPY , DCOPY , DDOT , DNRM2 ,
C  DSCAL , IDAMAX .  ONLY  D1MACH  CONTAINS MACHINE DEPENDENT
C  CONSTANTS.  NO OTHER MODIFICATIONS BY THE USER ARE REQUIRED.
C
C ***WARNING:  THIS SUBROUTINE IS GENERALLY MORE ROBUST THAN  FIXPNS
C AND  FIXPQS , BUT MAY BE SLOWER THAN THOSE SUBROUTINES BY A
C FACTOR OF TWO.
C
C
C ON INPUT:
C
C N  IS THE DIMENSION OF X, F(X), AND RHO(A,X,LAMBDA).
C
C Y  IS AN ARRRAY OF LENGTH  N + 1.  (Y(1),...,Y(N)) = A  IS THE
C    STARTING POINT FOR THE ZERO CURVE FOR THE FIXED POINT AND
C    ZERO FINDING PROBLEMS.  (Y(1),...,Y(N)) = X0  FOR THE CURVE
C    TRACKING PROBLEM.
C
C IFLAG  CAN BE -2, -1, 0, 2, OR 3.  IFLAG  SHOULD BE 0 ON THE
C    FIRST CALL TO  FIXPDS  FOR THE PROBLEM  X=F(X), -1 FOR THE
C    PROBLEM  F(X)=0, AND -2 FOR THE PROBLEM  RHO(A,X,LAMBDA)=0.
C    IN CERTAIN SITUATIONS  IFLAG  IS SET TO 2 OR 3 BY  FIXPDS,
C    AND  FIXPDS  CAN BE CALLED AGAIN WITHOUT CHANGING  IFLAG.
C
C ARCTOL  IS THE LOCAL ERROR ALLOWED THE ODE SOLVER WHEN
C    FOLLOWING THE ZERO CURVE.  IF  ARCTOL .LE. 0.0  ON INPUT
C    IT IS RESET TO  .5*DSQRT(EPS).  NORMALLY  ARCTOL  SHOULD
C    BE CONSIDERABLY LARGER THAN  EPS.
C
C EPS  IS THE LOCAL ERROR ALLOWED THE ODE SOLVER WHEN VERY
C    NEAR THE FIXED POINT(ZERO).  EPS  IS APPROXIMATELY THE
C    MIXED ABSOLUTE AND RELATIVE ERROR IN THE COMPUTED FIXED
C    POINT(ZERO).
C
C TRACE  IS AN INTEGER SPECIFYING THE LOGICAL I/O UNIT FOR
C    INTERMEDIATE OUTPUT.  IF  TRACE .GT. 0  THE POINTS COMPUTED ON
C    THE ZERO CURVE ARE WRITTEN TO I/O UNIT  TRACE .
C
C A(1:NDIMA) CONTAINS THE PARAMETER VECTOR  A .  FOR THE FIXED POINT
C    AND ZERO FINDING PROBLEMS, A  NEED NOT BE INITIALIZED BY THE
C    USER, AND IS ASSUMED TO HAVE LENGTH  N.  FOR THE CURVE
C    TRACKING PROBLEM, A  HAS LENGTH  NDIMA  AND MUST BE INITIALIZED
C    BY THE USER.
C
C NDIMA  IS THE DIMENSION OF  A , AND IS USED ONLY FOR THE CURVE
C    TRACKING PROBLEM.
C
C YP(1:N+1) IS A WORK ARRAY CONTAINING THE CURRENT TANGENT
C    VECTOR TO THE ZERO CURVE.
C
C YPOLD(1:N+1) IS A WORK ARRAY CONTAINING THE PREVIOUS TANGENT
C    VECTOR TO THE ZERO CURVE.
C
C QR(1:LENQR)  IS A WORK ARRAY CONTAINING THE (SYMMETRIC) JACOBIAN
C    MATRIX WITH RESPECT TO X, IN THE PACKED SKYLINE STORAGE FORMAT.
C
C LENQR  IS THE DIMENSION OF  QR .
C
C PIVOT(1:N+2), PP(1:N), AND WORK(1:6*(N+1)+LENQR) ARE ALL WORK
C    ARRAYS USED BY  FODEDS  TO CALCULATE THE TANGENT VECTOR YP.
C
C WT(1:N+1), PHI(1:N+1,1:16), AND P(1:N+1) ARE ALL WORK ARRAYS
C    USED BY THE ODE SUBROUTINE  STEPDS  .
C
C PAR(1:*) AND IPAR(1:*) ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS,
C    WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES
C    RHOA, RHOJS.
C
C Y, ARCTOL, EPS, ARCLEN, NFE, AND IFLAG SHOULD ALL BE
C VARIABLES IN THE CALLING PROGRAM.
C
C
C ON OUTPUT:
C
C N  AND  TRACE  ARE UNCHANGED.
C
C (Y(1),...,Y(N)) = X, Y(N+1) = LAMBDA, AND Y IS AN APPROXIMATE
C    ZERO OF THE HOMOTOPY MAP.  NORMALLY LAMBDA = 1 AND X IS A
C    FIXED POINT(ZERO) OF F(X).  IN ABNORMAL SITUATIONS LAMBDA
C    MAY ONLY BE NEAR 1 AND X IS NEAR A FIXED POINT(ZERO).
C
C IFLAG =
C  -2   CAUSES  FIXPDS  TO INITIALIZE EVERYTHING FOR THE PROBLEM
C       RHO(A,X,LAMBDA) = 0 (USE ON FIRST CALL).
C
C  -1   CAUSES  FIXPDS  TO INITIALIZE EVERYTHING FOR THE PROBLEM
C       F(X) = 0 (USE ON FIRST CALL).
C
C   0   CAUSES  FIXPDS  TO INITIALIZE EVERYTHING FOR THE PROBLEM
C       X = F(X) (USE ON FIRST CALL).
C
C   1   NORMAL RETURN.
C
C   2   SPECIFIED ERROR TOLERANCE CANNOT BE MET.  EPS HAS BEEN
C       INCREASED TO A SUITABLE VALUE.  TO CONTINUE, JUST CALL
C       FIXPDS  AGAIN WITHOUT CHANGING ANY PARAMETERS.
C
C   3   STEPDS  HAS BEEN CALLED 1000 TIMES.  TO CONTINUE, CALL
C       FIXPDS  AGAIN WITHOUT CHANGING ANY PARAMETERS.
C
C   4   JACOBIAN MATRIX DOES NOT HAVE FULL RANK AND/OR THE CONJUGATE
C       GRADIENT ITERATION FOR THE KERNEL OF THE JACOBIAN MATRIX
C       FAILED TO CONVERGE.  THE ALGORITHM HAS FAILED (THE ZERO
C       CURVE OF THE HOMOTOPY MAP CANNOT BE FOLLOWED ANY FURTHER).
C
C   5   EPS  (OR  ARCTOL ) IS TOO LARGE.  THE PROBLEM SHOULD BE
C       RESTARTED BY CALLING  FIXPDS  WITH A SMALLER  EPS  (OR
C       ARCTOL ) AND  IFLAG = 0 (-1, -2).
C
C   6   I - DF(X)  IS NEARLY SINGULAR AT THE FIXED POINT (DF(X) IS
C       NEARLY SINGULAR AT THE ZERO, OR  D RHO(A,X,LAMBDA)/DX  IS
C       NEARLY SINGULAR AT  LAMBDA = 1 ).  ANSWER MAY NOT BE
C       ACCURATE.
C
C   7   ILLEGAL INPUT PARAMETERS, A FATAL ERROR.
C
C ARCTOL = EPS AFTER A NORMAL RETURN (IFLAG = 1).
C
C EPS  IS UNCHANGED AFTER A NORMAL RETURN (IFLAG = 1).  IT IS
C    INCREASED TO AN APPROPRIATE VALUE ON THE RETURN IFLAG = 2.
C
C A  WILL (NORMALLY) HAVE BEEN MODIFIED.
C
C NFE  IS THE NUMBER OF FUNCTION EVALUATIONS (= NUMBER OF
C    JACOBIAN EVALUATIONS).
C
C ARCLEN  IS THE LENGTH OF THE PATH FOLLOWED.
C
C
      DOUBLE PRECISION AOLD,ARCLEN,ARCTOL,CURSW,CURTOL,EPS,
     1  EPSSTP,EPST,H,HOLD,S,S99,SA,SB,SOUT,SQNP1,XOLD,Y1SOUT
      INTEGER IFLAG,IFLAGC,ITER,IVC,J,JW,K,KGI,KOLD,
     1  KSTEPS,LCODE,LENQR,LIMIT,LIMITD,N,NDIMA,NFE,NFEC,NP1,TRACE
      LOGICAL START,CRASH,ST99
C
C *****  ARRAY DECLARATIONS.  *****
C
C ARRAYS NEEDED BY THE ODE SUBROUTINE  STEPDS .
      DOUBLE PRECISION Y(N+1),WT(N+1),PHI(N+1,16),P(N+1),YP(N+1),
     1     ALPHAS(12),W(12),G(13),GI(11)
      INTEGER IV(10)
C
C ARRAYS NEEDED BY  FIXPDS , FODEDS , AND  PCGDS .
      DOUBLE PRECISION YPOLD(N+1),A(N),QR(LENQR),PP(N),
     1     WORK(6*(N+1)+LENQR),PAR(1)
      INTEGER PIVOT(N+2),IPAR(1)
C
C *****  END OF DIMENSIONAL INFORMATION.  *****
C
      SAVE
      EXTERNAL FODEDS
C
C LIMITD  IS AN UPPER BOUND ON THE NUMBER OF STEPS.  IT MAY BE
C CHANGED BY CHANGING THE FOLLOWING PARAMETER STATEMENT:
      PARAMETER (LIMITD=1000)
C
C
C :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :
      IF (N .LE. 0  .OR.  EPS .LE. 0.0 ) IFLAG=7
      IF (IFLAG .GE. -2  .AND.  IFLAG .LE. 0) GO TO 10
      IF (IFLAG .EQ. 2) GO TO 35
      IF (IFLAG .EQ. 3) GO TO 30
C ONLY VALID INPUT FOR  IFLAG  IS -2, -1, 0, 2, 3.
      IFLAG=7
      RETURN
C
C *****  INITIALIZATION BLOCK.  *****
C
10    ARCLEN=0.0
      S=0.0
      IF (ARCTOL .LE. 0.0) ARCTOL=.5*SQRT(EPS)
      NFEC=0
      IFLAGC=IFLAG
      NP1=N+1
      SQNP1=SQRT(DBLE(NP1))
C
C SWITCH FROM THE TOLERANCE  ARCTOL  TO THE (FINER) TOLERANCE  EPS  IF
C THE CURVATURE OF ANY COMPONENT OF  Y  EXCEEDS  CURSW.
C
      CURSW=10.0
C
      ST99=.FALSE.
      START=.TRUE.
      CRASH=.FALSE.
      HOLD=1.0
      H=.1
      EPSSTP=ARCTOL
      KSTEPS=0
C SET INITIAL CONDITIONS FOR ORDINARY DIFFERENTIAL EQUATION.
      YPOLD(NP1)=1.0
      YP(NP1)=1.0
      Y(NP1)=0.0
      WORK(2*NP1)=0.0
      WORK(3*NP1)=0.0
      DO 20 J=1,N
        YPOLD(J)=0.0
        YP(J)=0.0
        WORK(NP1+J)=0.0
        WORK(2*NP1+J)=0.0
20    CONTINUE
C LOAD  A  FOR THE FIXED POINT AND ZERO FINDING PROBLEMS.
      IF (IFLAGC .GE. -1) THEN
        CALL DCOPY(N,Y,1,A,1)
      ENDIF
30    LIMIT=LIMITD
C
C *****  END OF INITIALIZATION BLOCK.  *****
C
C
C *****  MAIN LOOP.  *****
C
35    DO 150 ITER=1,LIMIT
      IF (Y(NP1) .LT. 0.0) THEN
40      ARCLEN=ARCLEN+S
        IFLAG=5
        RETURN
      ENDIF
50    IF (S .LE. 7.0*SQNP1) GO TO 80
C ARC LENGTH IS GETTING TOO LONG, THE PROBLEM WILL BE
C RESTARTED WITH A DIFFERENT  A  VECTOR.
      ARCLEN=ARCLEN+S
      S=0.0
60    START=.TRUE.
      CRASH=.FALSE.
C COMPUTE A NEW  A  VECTOR.
      IF (IFLAGC .EQ. -2) THEN
        DO 63 JW=1,NDIMA
          QR(JW)=A(JW)
63      CONTINUE
        CALL RHOA(A,Y(NP1),Y,PAR,IPAR)
        DO 65 JW=1,NDIMA
          AOLD=QR(JW)
C IF NEW AND OLD  A  DIFFER BY TOO MUCH, TRACKING SHOULD NOT CONTINUE.
          IF (ABS(A(JW)-AOLD) .GT. 1.0+ABS(AOLD)) THEN
            ARCLEN=ARCLEN+S
            IFLAG=5
            RETURN
          ENDIF
65      CONTINUE
      ELSE
        CALL F(Y,YP)
        DO 70 JW=1,N
          AOLD=A(JW)
          IF (IFLAGC .EQ. -1) THEN
            A(JW)=Y(NP1)*YP(JW)/(1.0 - Y(NP1)) + Y(JW)
          ELSE
            A(JW)=(Y(JW) - Y(NP1)*YP(JW))/(1.0 - Y(NP1))
          ENDIF
C IF NEW AND OLD  A  DIFFER BY TOO MUCH, TRACKING SHOULD NOT CONTINUE.
          IF (ABS(A(JW)-AOLD) .GT. 1.0+ABS(AOLD)) THEN
            ARCLEN=ARCLEN+S
            IFLAG=5
            RETURN
          ENDIF
70      CONTINUE
      ENDIF
      GO TO 100
80    IF (Y(NP1) .LE. .99  .OR. ST99) GO TO 100
C WHEN LAMBDA REACHES .99, THE PROBLEM WILL BE RESTARTED WITH
C A NEW  A  VECTOR.
90    ST99=.TRUE.
      EPSSTP=EPS
      ARCTOL=EPS
      GO TO 60
C
C SET DIFFERENT ERROR TOLERANCE FOR HIGH CURVATURE COMPONENTS OF THE
C TRAJECTORY Y(S).
100   CURTOL=CURSW*HOLD
      EPST=EPS/EPSSTP
      DO 110 JW=1,NP1
        IF (ABS(YP(JW)-YPOLD(JW)) .LE. CURTOL) THEN
          WT(JW)=(ABS(Y(JW))+1.0)
        ELSE
          WT(JW)=(ABS(Y(JW))+1.0)*EPST
        ENDIF
110   CONTINUE
C
C TAKE A STEP ALONG THE CURVE.
      CALL STEPDS(FODEDS,NP1,Y,S,H,EPSSTP,WT,START,HOLD,K,KOLD,CRASH,
     +     PHI,P,YP,ALPHAS,W,G,KSTEPS,XOLD,IVC,IV,KGI,GI,
     +     YPOLD,A,QR,LENQR,PIVOT,PP,WORK,NFEC,IFLAGC,PAR,IPAR)
C PRINT LATEST POINT ON CURVE IF REQUESTED.
      IF (TRACE .GT. 0) THEN
        WRITE (TRACE,117) ITER,NFEC,S,Y(NP1),(Y(JW),JW=1,N)
117     FORMAT(/' STEP',I5,3X,'NFE =',I5,3X,'ARC LENGTH =',F9.4,3X,
     $  'LAMBDA =',F7.4,5X,'X vector:'/1P,(1X,6E12.4))
      ENDIF
      NFE=NFEC
C CHECK IF THE STEP WAS SUCCESSFUL.
      IF (IFLAGC .EQ. 4) THEN
        ARCLEN=ARCLEN+S
        IFLAG=4
        RETURN
      ENDIF
120   IF (CRASH) THEN
C RETURN CODE FOR ERROR TOLERANCE TOO SMALL.
        IFLAG=2
C CHANGE ERROR TOLERANCES.
        EPS=EPSSTP
        IF (ARCTOL .LT. EPS) ARCTOL=EPS
C CHANGE LIMIT ON NUMBER OF ITERATIONS.
        LIMIT=LIMIT-ITER
        RETURN
      ENDIF
C
130   IF (Y(NP1) .GE. 1.0) THEN
        IF (ST99) GO TO 160
C
C IF LAMBDA .GE. 1.0 BUT THE PROBLEM HAS NOT BEEN RESTARTED
C WITH A NEW  A  VECTOR, BACK UP AND RESTART.
C
        S99=S-.5*HOLD
C GET AN APPROXIMATE ZERO Y(S) WITH  Y(NP1)=LAMBDA .LT. 1.0  .
135     CALL SINTRP(S,Y,S99,WT,YP,NP1,KOLD,PHI,IVC,IV,KGI,GI,
     $     ALPHAS,G,W,XOLD,P)
        IF (WT(NP1) .LT. 1.0) GO TO 140
        S99=.5*(S-HOLD+S99)
        GO TO 135
C
140     CALL DCOPY(NP1,WT,1,Y,1)
        CALL DCOPY(NP1,YP,1,YPOLD,1)
        S=S99
        GO TO 90
      ENDIF
C
150   CONTINUE
C
C *****  END OF MAIN LOOP.  *****
C
C LAMBDA HAS NOT REACHED 1 IN 1000 STEPS.
      IFLAG=3
      RETURN
C
C
C USE INVERSE INTERPOLATION TO GET THE ANSWER AT LAMBDA = 1.0 .
C
160   SA=S-HOLD
      SB=S
      LCODE=1
170   CALL ROOT(SOUT,Y1SOUT,SA,SB,EPS,EPS,LCODE)
C ROOT  FINDS S SUCH THAT Y(NP1)(S) = LAMBDA = 1 .
      IF (LCODE .GT. 0) GO TO 190
      CALL SINTRP(S,Y,SOUT,WT,YP,NP1,KOLD,PHI,IVC,IV,KGI,GI,
     $     ALPHAS,G,W,XOLD,P)
      Y1SOUT=WT(NP1)-1.0
      GO TO 170
190   IFLAG=1
C SET IFLAG = 6 IF  ROOT  COULD NOT GET  LAMBDA = 1.0  .
      IF (LCODE .GT. 2) IFLAG=6
      ARCLEN=ARCLEN+SA
C LAMBDA(SA) = 1.0 .
      CALL SINTRP(S,Y,SA,WT,YP,NP1,KOLD,PHI,IVC,IV,KGI,GI,
     $     ALPHAS,G,W,XOLD,P)
C
      CALL DCOPY(NP1,WT,1,Y,1)
C
      RETURN
      END
      SUBROUTINE FIXPNF(N,Y,IFLAG,ARCRE,ARCAE,ANSRE,ANSAE,TRACE,A,NFE,
     $   ARCLEN,YP,YOLD,YPOLD,QR,ALPHA,TZ,PIVOT,W,WP,Z0,Z1,SSPAR,
     $   PAR,IPAR)
C
C SUBROUTINE  FIXPNF  FINDS A FIXED POINT OR ZERO OF THE
C N-DIMENSIONAL VECTOR FUNCTION F(X), OR TRACKS A ZERO CURVE
C OF A GENERAL HOMOTOPY MAP RHO(A,LAMBDA,X).  FOR THE FIXED
C POINT PROBLEM F(X) IS ASSUMED TO BE A C2 MAP OF SOME BALL
C INTO ITSELF.  THE EQUATION  X = F(X)  IS SOLVED BY
C FOLLOWING THE ZERO CURVE OF THE HOMOTOPY MAP
C
C  LAMBDA*(X - F(X)) + (1 - LAMBDA)*(X - A)  ,
C
C STARTING FROM LAMBDA = 0, X = A.  THE CURVE IS PARAMETERIZED
C BY ARC LENGTH S, AND IS FOLLOWED BY SOLVING THE ORDINARY
C DIFFERENTIAL EQUATION  D(HOMOTOPY MAP)/DS = 0  FOR
C Y(S) = (LAMBDA(S), X(S)) USING A HERMITE CUBIC PREDICTOR AND A
C CORRECTOR WHICH RETURNS TO THE ZERO CURVE ALONG THE FLOW NORMAL
C TO THE DAVIDENKO FLOW (WHICH CONSISTS OF THE INTEGRAL CURVES OF
C D(HOMOTOPY MAP)/DS ).
C
C FOR THE ZERO FINDING PROBLEM F(X) IS ASSUMED TO BE A C2 MAP
C SUCH THAT FOR SOME R > 0,  X*F(X) >= 0  WHENEVER NORM(X) = R.
C THE EQUATION  F(X) = 0  IS SOLVED BY FOLLOWING THE ZERO CURVE
C OF THE HOMOTOPY MAP
C
C   LAMBDA*F(X) + (1 - LAMBDA)*(X - A)
C
C EMANATING FROM LAMBDA = 0, X = A.
C
C  A  MUST BE AN INTERIOR POINT OF THE ABOVE MENTIONED BALLS.
C
C FOR THE CURVE TRACKING PROBLEM RHO(A,LAMBDA,X) IS ASSUMED TO
C BE A C2 MAP FROM E**M X [0,1) X E**N INTO E**N, WHICH FOR
C ALMOST ALL PARAMETER VECTORS A IN SOME NONEMPTY OPEN SUBSET
C OF E**M SATISFIES
C
C  RANK [D RHO(A,LAMBDA,X)/D LAMBDA , D RHO(A,LAMBDA,X)/DX] = N
C
C FOR ALL POINTS (LAMBDA,X) SUCH THAT RHO(A,LAMBDA,X)=0.  IT IS
C FURTHER ASSUMED THAT
C
C           RANK [ D RHO(A,0,X0)/DX ] = N  .
C
C WITH A FIXED, THE ZERO CURVE OF RHO(A,LAMBDA,X) EMANATING
C FROM  LAMBDA = 0, X = X0  IS TRACKED UNTIL  LAMBDA = 1  BY
C SOLVING THE ORDINARY DIFFERENTIAL EQUATION
C D RHO(A,LAMBDA(S),X(S))/DS = 0  FOR  Y(S) = (LAMBDA(S), X(S)),
C WHERE S IS ARC LENGTH ALONG THE ZERO CURVE.  ALSO THE HOMOTOPY
C MAP RHO(A,LAMBDA,X) IS ASSUMED TO BE CONSTRUCTED SUCH THAT
C
C              D LAMBDA(0)/DS > 0  .
C
C
C FOR THE FIXED POINT AND ZERO FINDING PROBLEMS, THE USER MUST SUPPLY
C A SUBROUTINE  F(X,V)  WHICH EVALUATES F(X) AT X AND RETURNS THE
C VECTOR F(X) IN V, AND A SUBROUTINE  FJAC(X,V,K)  WHICH RETURNS IN V
C THE KTH COLUMN OF THE JACOBIAN MATRIX OF F(X) EVALUATED AT X.  FOR
C THE CURVE TRACKING PROBLEM, THE USER MUST SUPPLY A SUBROUTINE
C  RHO(A,LAMBDA,X,V,PAR,IPAR)  WHICH EVALUATES THE HOMOTOPY MAP RHO AT
C (A,LAMBDA,X) AND RETURNS THE VECTOR RHO(A,LAMBDA,X) IN V, AND A
C SUBROUTINE  RHOJAC(A,LAMBDA,X,V,K,PAR,IPAR)  WHICH RETURNS IN V THE KT
C COLUMN OF THE N X (N+1) JACOBIAN MATRIX [D RHO/D LAMBDA, D RHO/DX]
C EVALUATED AT (A,LAMBDA,X).  FIXPNF  DIRECTLY OR INDIRECTLY USES
C THE SUBROUTINES  STEPNF , TANGNF , ROOTNF , ROOT , F (OR  RHO ),
C FJAC (OR  RHOJAC ), D1MACH , AND THE BLAS FUNCTIONS  DDOT  AND
C DNRM2 .  ONLY  D1MACH  CONTAINS MACHINE DEPENDENT CONSTANTS.
C NO OTHER MODIFICATIONS BY THE USER ARE REQUIRED.
C
C
C ON INPUT:
C
C N  IS THE DIMENSION OF X, F(X), AND RHO(A,LAMBDA,X).
C
C Y  IS AN ARRRAY OF LENGTH  N + 1.  (Y(2),...,Y(N+1)) = A  IS THE
C    STARTING POINT FOR THE ZERO CURVE FOR THE FIXED POINT AND
C    ZERO FINDING PROBLEMS.  (Y(2),...,Y(N+1)) = X0  FOR THE CURVE
C    TRACKING PROBLEM.
C
C IFLAG  CAN BE -2, -1, 0, 2, OR 3.  IFLAG  SHOULD BE 0 ON THE
C    FIRST CALL TO  FIXPNF  FOR THE PROBLEM  X=F(X), -1 FOR THE
C    PROBLEM  F(X)=0, AND -2 FOR THE PROBLEM  RHO(A,LAMBDA,X)=0.
C    IN CERTAIN SITUATIONS  IFLAG  IS SET TO 2 OR 3 BY  FIXPNF,
C    AND  FIXPNF  CAN BE CALLED AGAIN WITHOUT CHANGING  IFLAG.
C
C ARCRE , ARCAE  ARE THE RELATIVE AND ABSOLUTE ERRORS, RESPECTIVELY,
C    ALLOWED THE NORMAL FLOW ITERATION ALONG THE ZERO CURVE.  IF
C    ARC?E .LE. 0.0  ON INPUT IT IS RESET TO  .5*SQRT(ANS?E) .
C    NORMALLY  ARC?E SHOULD BE CONSIDERABLY LARGER THAN  ANS?E .
C
C ANSRE , ANSAE  ARE THE RELATIVE AND ABSOLUTE ERROR VALUES USED FOR
C    THE ANSWER AT LAMBDA = 1.  THE ACCEPTED ANSWER  Y = (LAMBDA, X)
C    SATISFIES
C
C       |Y(1) - 1|  .LE.  ANSRE + ANSAE           .AND.
C
C       ||Z||  .LE.  ANSRE*||X|| + ANSAE          WHERE
C
C    (.,Z) IS THE NEWTON STEP TO Y.
C
C TRACE  IS AN INTEGER SPECIFYING THE LOGICAL I/O UNIT FOR
C    INTERMEDIATE OUTPUT.  IF  TRACE .GT. 0  THE POINTS COMPUTED ON
C    THE ZERO CURVE ARE WRITTEN TO I/O UNIT  TRACE .
C
C A(1:*)  CONTAINS THE PARAMETER VECTOR  A .  FOR THE FIXED POINT
C    AND ZERO FINDING PROBLEMS, A  NEED NOT BE INITIALIZED BY THE
C    USER, AND IS ASSUMED TO HAVE LENGTH  N.  FOR THE CURVE
C    TRACKING PROBLEM, A  MUST BE INITIALIZED BY THE USER.
C
C YP(1:N+1)  IS A WORK ARRAY CONTAINING THE TANGENT VECTOR TO
C    THE ZERO CURVE AT THE CURRENT POINT  Y .
C
C YOLD(1:N+1)  IS A WORK ARRAY CONTAINING THE PREVIOUS POINT FOUND
C    ON THE ZERO CURVE.
C
C YPOLD(1:N+1)  IS A WORK ARRAY CONTAINING THE TANGENT VECTOR TO
C    THE ZERO CURVE AT  YOLD .
C
C QR(1:N,1:N+2), ALPHA(1:N), TZ(1:N+1), PIVOT(1:N+1) , W(1:N+1) ,
C    WP(1:N+1) , Z0(1:N+1) , Z1(1:N+1)  ARE ALL WORK ARRAYS USED BY
C    STEPNF  TO CALCULATE THE TANGENT VECTORS AND NEWTON STEPS.
C
C SSPAR(1:8) = (LIDEAL, RIDEAL, DIDEAL, HMIN, HMAX, BMIN, BMAX, P)  IS
C    A VECTOR OF PARAMETERS USED FOR THE OPTIMAL STEP SIZE ESTIMATION.
C    IF  SSPAR(J) .LE. 0.0  ON INPUT, IT IS RESET TO A DEFAULT VALUE
C    BY  FIXPNF .  OTHERWISE THE INPUT VALUE OF  SSPAR(J)  IS USED.
C    SEE THE COMMENTS BELOW AND IN  STEPNF  FOR MORE INFORMATION ABOUT
C    THESE CONSTANTS.
C
C PAR(1:*) AND IPAR(1:*) ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS,
C    WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES
C    RHO, RHOJAC.
C
C
C ON OUTPUT:
C
C N , TRACE , A  ARE UNCHANGED.
C
C Y(1) = LAMBDA, (Y(2),...,Y(N+1)) = X, AND Y IS AN APPROXIMATE
C    ZERO OF THE HOMOTOPY MAP.  NORMALLY LAMBDA = 1 AND X IS A
C    FIXED POINT(ZERO) OF F(X).  IN ABNORMAL SITUATIONS LAMBDA
C    MAY ONLY BE NEAR 1 AND X IS NEAR A FIXED POINT(ZERO).
C
C IFLAG =
C  -2   CAUSES  FIXPNF  TO INITIALIZE EVERYTHING FOR THE PROBLEM
C       RHO(A,LAMBDA,X) = 0 (USE ON FIRST CALL).
C
C  -1   CAUSES  FIXPNF  TO INITIALIZE EVERYTHING FOR THE PROBLEM
C       F(X) = 0 (USE ON FIRST CALL).
C
C   0   CAUSES  FIXPNF  TO INITIALIZE EVERYTHING FOR THE PROBLEM
C       X = F(X) (USE ON FIRST CALL).
C
C   1   NORMAL RETURN.
C
C   2   SPECIFIED ERROR TOLERANCE CANNOT BE MET.  SOME OR ALL OF
C       ARCRE , ARCAE , ANSRE , ANSAE  HAVE BEEN INCREASED TO
C       SUITABLE VALUES.  TO CONTINUE, JUST CALL  FIXPNF  AGAIN
C       WITHOUT CHANGING ANY PARAMETERS.
C
C   3   STEPNF  HAS BEEN CALLED 1000 TIMES.  TO CONTINUE, CALL
C       FIXPNF  AGAIN WITHOUT CHANGING ANY PARAMETERS.
C
C   4   JACOBIAN MATRIX DOES NOT HAVE FULL RANK.  THE ALGORITHM
C       HAS FAILED (THE ZERO CURVE OF THE HOMOTOPY MAP CANNOT BE
C       FOLLOWED ANY FURTHER).
C
C   5   THE TRACKING ALGORITHM HAS LOST THE ZERO CURVE OF THE
C       HOMOTOPY MAP AND IS NOT MAKING PROGRESS.  THE ERROR TOLERANCES
C       ARC?E  AND  ANS?E  WERE TOO LENIENT.  THE PROBLEM SHOULD BE
C       RESTARTED BY CALLING  FIXPNF  WITH SMALLER ERROR TOLERANCES
C       AND  IFLAG = 0 (-1, -2).
C
C   6   THE NORMAL FLOW NEWTON ITERATION IN  STEPNF  OR  ROOTNF
C       FAILED TO CONVERGE.  THE ERROR TOLERANCES  ANS?E  MAY BE TOO
C       STRINGENT.
C
C   7   ILLEGAL INPUT PARAMETERS, A FATAL ERROR.
C
C ARCRE , ARCAE , ANSRE , ANSAE  ARE UNCHANGED AFTER A NORMAL RETURN
C    (IFLAG = 1).  THEY ARE INCREASED TO APPROPRIATE VALUES ON THE
C    RETURN  IFLAG = 2 .
C
C NFE  IS THE NUMBER OF FUNCTION EVALUATIONS (= NUMBER OF
C    JACOBIAN EVALUATIONS).
C
C ARCLEN  IS THE LENGTH OF THE PATH FOLLOWED.
C
C
C
      DOUBLE PRECISION ABSERR,ANSAE,ANSRE,ARCAE,ARCLEN,ARCRE,
     1   CURSW,CURTOL,D1MACH,DNRM2,H,HOLD,RELERR,S
      INTEGER IFLAG,IFLAGC,ITER,JW,LIMIT,LIMITD,N,NC,NFE,NFEC,NP1,
     1   TRACE
      LOGICAL CRASH,POLSYS,START
C
C ***** ARRAY DECLARATIONS. *****
C
      DOUBLE PRECISION Y(N+1),YP(N+1),YOLD(N+1),YPOLD(N+1),A(N),
     $   QR(N,N+2),ALPHA(N),TZ(N+1),W(N+1),WP(N+1),Z0(N+1),
     $   Z1(N+1),SSPAR(8),PAR(1)
      INTEGER PIVOT(N+1),IPAR(1)
C
C ***** END OF DIMENSIONAL INFORMATION. *****
C
      SAVE
C
C LIMITD  IS AN UPPER BOUND ON THE NUMBER OF STEPS.  IT MAY BE
C CHANGED BY CHANGING THE FOLLOWING PARAMETER STATEMENT:
      PARAMETER (LIMITD=1000)
C
C SWITCH FROM THE TOLERANCE  ARC?E  TO THE (FINER) TOLERANCE  ANS?E  IF
C THE CURVATURE OF ANY COMPONENT OF  Y  EXCEEDS  CURSW.
      PARAMETER (CURSW=10.0)
C
C
C
C :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :
C SET LOGICAL SWITCH TO REFLECT ENTRY POINT.
      POLSYS=.FALSE.
      GO TO 11
      ENTRY POLYNF(N,Y,IFLAG,ARCRE,ARCAE,ANSRE,ANSAE,TRACE,A,NFE,
     $   ARCLEN,YP,YOLD,YPOLD,QR,ALPHA,TZ,PIVOT,W,WP,Z0,Z1,SSPAR,
     $   PAR,IPAR)
      POLSYS=.TRUE.
11    CONTINUE
C
      IF (N .LE. 0  .OR.  ANSRE .LE. 0.0  .OR.  ANSAE .LT. 0.0)
     $                                                     IFLAG=7
      IF (IFLAG .GE. -2  .AND.  IFLAG .LE. 0) GO TO 20
      IF (IFLAG .EQ. 2) GO TO 120
      IF (IFLAG .EQ. 3) GO TO 90
C ONLY VALID INPUT FOR  IFLAG  IS -2, -1, 0, 2, 3.
      IFLAG=7
      RETURN
C
C *****  INITIALIZATION BLOCK.  *****
C
20    ARCLEN=0.0
      IF (ARCRE .LE. 0.0) ARCRE=.5*SQRT(ANSRE)
      IF (ARCAE .LE. 0.0) ARCAE=.5*SQRT(ANSAE)
      NC=N
      NFEC=0
      IFLAGC=IFLAG
      NP1=N+1
C SET INITIAL CONDITIONS FOR FIRST CALL TO  STEPNF .
      START=.TRUE.
      CRASH=.FALSE.
      HOLD=1.0
      H=.1
      S=0.0
      YPOLD(1)=1.0
      YP(1)=1.0
      Y(1)=0.0
      DO 40 JW=2,NP1
        YPOLD(JW)=0.0
        YP(JW)=0.0
40    CONTINUE
C SET OPTIMAL STEP SIZE ESTIMATION PARAMETERS.
C LET Z[K] DENOTE THE NEWTON ITERATES ALONG THE FLOW NORMAL TO THE
C DAVIDENKO FLOW AND Y THEIR LIMIT.
C IDEAL CONTRACTION FACTOR:  ||Z[2] - Z[1]|| / ||Z[1] - Z[0]||
      IF (SSPAR(1) .LE. 0.0) SSPAR(1)= .5
C IDEAL RESIDUAL FACTOR:  ||RHO(A, Z[1])|| / ||RHO(A, Z[0])||
      IF (SSPAR(2) .LE. 0.0) SSPAR(2)= .01
C IDEAL DISTANCE FACTOR:  ||Z[1] - Y|| / ||Z[0] - Y||
      IF (SSPAR(3) .LE. 0.0) SSPAR(3)= .5
C MINIMUM STEP SIZE  HMIN .
      IF (SSPAR(4) .LE. 0.0) SSPAR(4)= (SQRT(N+1.0)+4.0)*D1MACH(4)
C MAXIMUM STEP SIZE  HMAX .
      IF (SSPAR(5) .LE. 0.0) SSPAR(5)= 1.0
C MINIMUM STEP SIZE REDUCTION FACTOR  BMIN .
      IF (SSPAR(6) .LE. 0.0) SSPAR(6)= .1
C MAXIMUM STEP SIZE EXPANSION FACTOR  BMAX .
      IF (SSPAR(7) .LE. 0.0) SSPAR(7)= 3.0
C ASSUMED OPERATING ORDER  P .
      IF (SSPAR(8) .LE. 0.0) SSPAR(8)= 2.0
C
C LOAD  A  FOR THE FIXED POINT AND ZERO FINDING PROBLEMS.
      IF (IFLAGC .GE. -1) THEN
        DO 60 JW=2,NP1
          A(JW-1)=Y(JW)
60      CONTINUE
      ENDIF
90    LIMIT=LIMITD
C
C *****  END OF INITIALIZATION BLOCK.  *****
C
C
C *****  MAIN LOOP.  *****
C
120   DO 400 ITER=1,LIMIT
      IF (Y(1) .LT. 0.0) THEN
        ARCLEN=S
        IFLAG=5
        RETURN
      ENDIF
C
C SET DIFFERENT ERROR TOLERANCE IF THE TRAJECTORY Y(S) HAS ANY HIGH
C CURVATURE COMPONENTS.
140   CURTOL=CURSW*HOLD
      RELERR=ARCRE
      ABSERR=ARCAE
      DO 160 JW=1,NP1
        IF (ABS(YP(JW)-YPOLD(JW)) .GT. CURTOL) THEN
          RELERR=ANSRE
          ABSERR=ANSAE
          GO TO 200
        ENDIF
160   CONTINUE
C
C TAKE A STEP ALONG THE CURVE.
200   CALL STEPNF(NC,NFEC,IFLAGC,START,CRASH,HOLD,H,RELERR,ABSERR,
     +     S,Y,YP,YOLD,YPOLD,A,QR,ALPHA,TZ,PIVOT,W,WP,Z0,Z1,SSPAR,
     +     PAR,IPAR)
C PRINT LATEST POINT ON CURVE IF REQUESTED.
      IF (TRACE .GT. 0) THEN
        WRITE (TRACE,217) ITER,NFEC,S,Y(1),(Y(JW),JW=2,NP1)
217     FORMAT(/' STEP',I5,3X,'NFE =',I5,3X,'ARC LENGTH =',F9.4,3X,
     $  'LAMBDA =',F7.4,5X,'X vector:'/1P,(1X,6E12.4))
      ENDIF
      NFE=NFEC
C CHECK IF THE STEP WAS SUCCESSFUL.
      IF (IFLAGC .GT. 0) THEN
        ARCLEN=S
        IFLAG=IFLAGC
        RETURN
      ENDIF
      IF (CRASH) THEN
C RETURN CODE FOR ERROR TOLERANCE TOO SMALL.
        IFLAG=2
C CHANGE ERROR TOLERANCES.
        IF (ARCRE .LT. RELERR) ARCRE=RELERR
        IF (ANSRE .LT. RELERR) ANSRE=RELERR
        IF (ARCAE .LT. ABSERR) ARCAE=ABSERR
        IF (ANSAE .LT. ABSERR) ANSAE=ABSERR
C CHANGE LIMIT ON NUMBER OF ITERATIONS.
        LIMIT=LIMIT-ITER
        RETURN
      ENDIF
C
      IF (Y(1) .GE. 1.0) THEN
C
C USE HERMITE CUBIC INTERPOLATION AND NEWTON ITERATION TO GET THE
C ANSWER AT LAMBDA = 1.0 .
C
C SAVE  YOLD  FOR ARC LENGTH CALCULATION LATER.
        DO 260 JW=1,NP1
          Z0(JW)=YOLD(JW)
260     CONTINUE
        CALL ROOTNF(NC,NFEC,IFLAGC,ANSRE,ANSAE,Y,YP,YOLD,YPOLD,
     $              A,QR,ALPHA,TZ,PIVOT,W,WP,PAR,IPAR)
C
        NFE=NFEC
        IFLAG=1
C SET ERROR FLAG IF  ROOTNF  COULD NOT GET THE POINT ON THE ZERO
C CURVE AT  LAMBDA = 1.0  .
        IF (IFLAGC .GT. 0) IFLAG=IFLAGC
C CALCULATE FINAL ARC LENGTH.
        DO 290 JW=1,NP1
          W(JW)=Y(JW) - Z0(JW)
290     CONTINUE
        ARCLEN=S - HOLD + DNRM2(NP1,W,1)
        RETURN
      ENDIF
C
C FOR POLYNOMIAL SYSTEMS AND THE  POLSYS  HOMOTOPY MAP,
C D LAMBDA/DS .GE. 0 NECESSARILY.  THIS CONDITION IS FORCED HERE IF
C THE ENTRY POINT WAS  POLYNF .
C
      IF (POLSYS) THEN
        IF (YP(1) .LT. 0.0) THEN
C REVERSE TANGENT DIRECTION SO D LAMBDA/DS = YP(1) > 0 .
          DO 310 JW=1,NP1
            YP(JW)=-YP(JW)
            YPOLD(JW)=YP(JW)
310       CONTINUE
C FORCE  STEPNF  TO USE THE LINEAR PREDICTOR FOR THE NEXT STEP ONLY.
          START=.TRUE.
        ENDIF
      ENDIF
C
400   CONTINUE
C
C *****  END OF MAIN LOOP.  *****
C
C LAMBDA HAS NOT REACHED 1 IN 1000 STEPS.
      IFLAG=3
      ARCLEN=S
      RETURN
C
      END
      SUBROUTINE FIXPNS(N,Y,IFLAG,ARCRE,ARCAE,ANSRE,ANSAE,TRACE,A,
     $   NFE,ARCLEN,YP,YOLD,YPOLD,QR,LENQR,PIVOT,WORK,SSPAR,
     $   PAR,IPAR)
C
C SUBROUTINE  FIXPNS  FINDS A FIXED POINT OR ZERO OF THE
C N-DIMENSIONAL VECTOR FUNCTION F(X), OR TRACKS A ZERO CURVE
C OF A GENERAL HOMOTOPY MAP RHO(A,X,LAMBDA).  FOR THE FIXED
C POINT PROBLEM F(X) IS ASSUMED TO BE A C2 MAP OF SOME BALL
C INTO ITSELF.  THE EQUATION  X = F(X)  IS SOLVED BY
C FOLLOWING THE ZERO CURVE OF THE HOMOTOPY MAP
C
C  LAMBDA*(X - F(X)) + (1 - LAMBDA)*(X - A)  ,
C
C STARTING FROM LAMBDA = 0, X = A.  THE CURVE IS PARAMETERIZED
C BY ARC LENGTH S, AND IS FOLLOWED BY SOLVING THE ORDINARY
C DIFFERENTIAL EQUATION  D(HOMOTOPY MAP)/DS = 0  FOR
C Y(S) = (X(S), LAMBDA(S)) USING A HERMITE CUBIC PREDICTOR AND A
C CORRECTOR WHICH RETURNS TO THE ZERO CURVE ALONG THE FLOW NORMAL
C TO THE DAVIDENKO FLOW (WHICH CONSISTS OF THE INTEGRAL CURVES OF
C D(HOMOTOPY MAP)/DS ).
C
C FOR THE ZERO FINDING PROBLEM F(X) IS ASSUMED TO BE A C2 MAP
C SUCH THAT FOR SOME R > 0,  X*F(X) >= 0  WHENEVER NORM(X) = R.
C THE EQUATION  F(X) = 0  IS SOLVED BY FOLLOWING THE ZERO CURVE
C OF THE HOMOTOPY MAP
C
C   LAMBDA*F(X) + (1 - LAMBDA)*(X - A)
C
C EMANATING FROM LAMBDA = 0, X = A.
C
C  A  MUST BE AN INTERIOR POINT OF THE ABOVE MENTIONED BALLS.
C
C FOR THE CURVE TRACKING PROBLEM RHO(A,X,LAMBDA) IS ASSUMED TO
C BE A C2 MAP FROM E**M X E**N X [0,1) INTO E**N, WHICH FOR
C ALMOST ALL PARAMETER VECTORS A IN SOME NONEMPTY OPEN SUBSET
C OF E**M SATISFIES
C
C  RANK [D RHO(A,X,LAMBDA)/DX , D RHO(A,X,LAMBDA)/D LAMBDA] = N
C
C FOR ALL POINTS (X,LAMBDA) SUCH THAT RHO(A,X,LAMBDA)=0.  IT IS
C FURTHER ASSUMED THAT
C
C           RANK [ D RHO(A,X0,0)/DX ] = N  .
C
C WITH A FIXED, THE ZERO CURVE OF RHO(A,X,LAMBDA) EMANATING
C FROM  LAMBDA = 0, X = X0  IS TRACKED UNTIL  LAMBDA = 1  BY
C SOLVING THE ORDINARY DIFFERENTIAL EQUATION
C D RHO(A,X(S),LAMBDA(S))/DS = 0  FOR  Y(S) = (X(S), LAMBDA(S)),
C WHERE S IS ARC LENGTH ALONG THE ZERO CURVE.  ALSO THE HOMOTOPY
C MAP RHO(A,X,LAMBDA) IS ASSUMED TO BE CONSTRUCTED SUCH THAT
C
C              D LAMBDA(0)/DS > 0  .
C
C
C FOR THE FIXED POINT AND ZERO FINDING PROBLEMS, THE USER
C MUST SUPPLY A SUBROUTINE  F(X,V)  WHICH EVALUATES F(X) AT X
C AND RETURNS THE VECTOR F(X) IN V, AND A SUBROUTINE
C  FJACS(X,QR,LENQR,PIVOT)  WHICH EVALUATES THE (SYMMETRIC)
C JACOBIAN MATRIX OF F(X) AT X, AND RETURNS THE SYMMETRIC
C JACOBIAN MATRIX IN PACKED SKYLINE STORAGE FORMAT IN QR.  LENQR
C AND PIVOT DESCRIBE THE DATA STRUCTURE IN QR.  FOR THE CURVE
C TRACKING PROBLEM, THE USER MUST SUPPLY A SUBROUTINE
C  RHO(A,LAMBDA,X,V,PAR,IPAR)  WHICH EVALUATES THE HOMOTOPY MAP RHO
C AT (A,X,LAMBDA) AND RETURNS THE VECTOR RHO(A,X,LAMBDA) IN V, AND
C A SUBROUTINE  RHOJS(A,LAMBDA,X,QR,LENQR,PIVOT,PP,PAR,IPAR)  WHICH
C RETURNS IN QR THE SYMMETRIC N X N JACOBIAN MATRIX [D RHO/DX]
C EVALUATED AT (A,X,LAMBDA) AND STORED IN PACKED SKYLINE FORMAT, AND
C RETURNS IN PP THE VECTOR -(D RHO/D LAMBDA) EVALUATED AT
C (A,X,LAMBDA).  LENQR AND PIVOT DESCRIBE THE DATA STRUCTURE
C IN QR.
C *** NOTE THE MINUS SIGN IN THE DEFINITION OF PP. ***
C
C
C FUNCTIONS AND SUBROUTINES DIRECTLY OR INDIRECTLY CALLED BY FIXPDS:
C  D1MACH , F (OR  RHO ), FJACS (OR  RHOJS ), GMFADS , MFACDS ,
C  MULTDS , PCGDS , PCGNS , QIMUDS , ROOT , ROOTNS , SOLVDS ,
C  STEPNS , TANGNS , AND THE BLAS FUNCTIONS  DAXPY , DCOPY , DDOT ,
C  DNRM2 , DSCAL , IDAMAX .  ONLY  D1MACH  CONTAINS MACHINE DEPENDENT
C CONSTANTS.  NO OTHER MODIFICATIONS BY THE USER ARE REQUIRED.
C
C
C ON INPUT:
C
C N  IS THE DIMENSION OF X, F(X), AND RHO(A,X,LAMBDA).
C
C Y  IS AN ARRRAY OF LENGTH  N + 1.  (Y(1),...,Y(N)) = A  IS THE
C    STARTING POINT FOR THE ZERO CURVE FOR THE FIXED POINT AND
C    ZERO FINDING PROBLEMS.  (Y(1),...,Y(N)) = X0  FOR THE CURVE
C    TRACKING PROBLEM.
C
C IFLAG  CAN BE -2, -1, 0, 2, OR 3.  IFLAG  SHOULD BE 0 ON THE
C    FIRST CALL TO  FIXPNS  FOR THE PROBLEM  X=F(X), -1 FOR THE
C    PROBLEM  F(X)=0, AND -2 FOR THE PROBLEM  RHO(A,X,LAMBDA)=0.
C    IN CERTAIN SITUATIONS  IFLAG  IS SET TO 2 OR 3 BY  FIXPNS,
C    AND  FIXPNS  CAN BE CALLED AGAIN WITHOUT CHANGING  IFLAG.
C
C ARCRE , ARCAE  ARE THE RELATIVE AND ABSOLUTE ERRORS, RESPECTIVELY,
C    ALLOWED THE NORMAL FLOW ITERATION ALONG THE ZERO CURVE.  IF
C    ARC?E .LE. 0.0  ON INPUT IT IS RESET TO  .5*SQRT(ANS?E) .
C    NORMALLY  ARC?E SHOULD BE CONSIDERABLY LARGER THAN  ANS?E .
C
C ANSRE , ANSAE  ARE THE RELATIVE AND ABSOLUTE ERROR VALUES USED FOR
C    THE ANSWER AT LAMBDA = 1.  THE ACCEPTED ANSWER  Y = (X, LAMBDA)
C    SATISFIES
C
C       |Y(NP1) - 1|  .LE.  ANSRE + ANSAE           .AND.
C
C       ||Z||  .LE.  ANSRE*||X|| + ANSAE          WHERE
C
C    (Z,.) IS THE NEWTON STEP TO Y.
C
C TRACE  IS AN INTEGER SPECIFYING THE LOGICAL I/O UNIT FOR
C    INTERMEDIATE OUTPUT.  IF  TRACE .GT. 0  THE POINTS COMPUTED ON
C    THE ZERO CURVE ARE WRITTEN TO I/O UNIT  TRACE .
C
C A(1:*)  CONTAINS THE PARAMETER VECTOR  A .  FOR THE FIXED POINT
C    AND ZERO FINDING PROBLEMS, A  NEED NOT BE INITIALIZED BY THE
C    USER, AND IS ASSUMED TO HAVE LENGTH  N.  FOR THE CURVE
C    TRACKING PROBLEM, A  MUST BE INITIALIZED BY THE USER.
C
C YP(1:N+1)  IS A WORK ARRAY CONTAINING THE TANGENT VECTOR TO
C    THE ZERO CURVE AT THE CURRENT POINT  Y .
C
C YOLD(1:N+1)  IS A WORK ARRAY CONTAINING THE PREVIOUS POINT FOUND
C    ON THE ZERO CURVE.
C
C YPOLD(1:N+1)  IS A WORK ARRAY CONTAINING THE TANGENT VECTOR TO
C    THE ZERO CURVE AT  YOLD .
C
C QR(1:LENQR)  IS A WORK ARRAY CONTAINING THE N X N SYMMETRIC
C    JACOBIAN MATRIX WITH RESPECT TO X STORED IN PACKED SKYLINE
C    STORAGE FORMAT.  LENQR  AND  PIVOT  DESCRIBE THE DATA
C    STRUCTURE IN  QR .
C
C LENQR  IS THE LENGTH OF THE ONE-DIMENSIONAL ARRAY  QR  .
C
C PIVOT(1:N+2)  IS A WORK ARRAY CONTAINING THE INDICES OF THE
C    DIAGONAL ELEMENTS OF THE N X N SYMMETRIC JACOBIAN MATRIX
C    (WITH RESPECT TO X) WITHIN  QR .
C
C WORK(1:13*(N+1)+2*N+LENQR)  IS A WORK ARRAY SPLIT UP AND USED
C    FOR THE CALCULATION OF THE JACOBIAN MATRIX KERNEL, THE
C    NEWTON STEP, INTERPOLATION, AND THE ESTIMATION OF THE OPTIMAL
C    STEP SIZE  H .
C
C SSPAR(1:8) = (LIDEAL, RIDEAL, DIDEAL, HMIN, HMAX, BMIN, BMAX, P)  IS
C    A VECTOR OF PARAMETERS USED FOR THE OPTIMAL STEP SIZE ESTIMATION.
C    IF  SSPAR(J) .LE. 0.0  ON INPUT, IT IS RESET TO A DEFAULT VALUE
C    BY  FIXPNS .  OTHERWISE THE INPUT VALUE OF  SSPAR(J)  IS USED.
C    SEE THE COMMENTS BELOW AND IN  STEPNS  FOR MORE INFORMATION ABOUT
C    THESE CONSTANTS.
C
C PAR(1:*) AND IPAR(1:*) ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS,
C    WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES
C    RHO, RHOJS.
C
C
C ON OUTPUT:
C
C N , TRACE , A  ARE UNCHANGED.
C
C (Y(1),...,Y(N)) = X, Y(NP1) = LAMBDA, AND Y IS AN APPROXIMATE
C    ZERO OF THE HOMOTOPY MAP.  NORMALLY LAMBDA = 1 AND X IS A
C    FIXED POINT(ZERO) OF F(X).  IN ABNORMAL SITUATIONS LAMBDA
C    MAY ONLY BE NEAR 1 AND X IS NEAR A FIXED POINT(ZERO).
C
C IFLAG =
C  -2   CAUSES  FIXPNS  TO INITIALIZE EVERYTHING FOR THE PROBLEM
C       RHO(A,X,LAMBDA) = 0 (USE ON FIRST CALL).
C
C  -1   CAUSES  FIXPNS  TO INITIALIZE EVERYTHING FOR THE PROBLEM
C       F(X) = 0 (USE ON FIRST CALL).
C
C   0   CAUSES  FIXPNS  TO INITIALIZE EVERYTHING FOR THE PROBLEM
C       X = F(X) (USE ON FIRST CALL).
C
C   1   NORMAL RETURN.
C
C   2   SPECIFIED ERROR TOLERANCE CANNOT BE MET.  SOME OR ALL OF
C       ARCRE , ARCAE , ANSRE , ANSAE  HAVE BEEN INCREASED TO
C       SUITABLE VALUES.  TO CONTINUE, JUST CALL  FIXPNS  AGAIN
C       WITHOUT CHANGING ANY PARAMETERS.
C
C   3   STEPNS  HAS BEEN CALLED 1000 TIMES.  TO CONTINUE, CALL
C       FIXPNS  AGAIN WITHOUT CHANGING ANY PARAMETERS.
C
C   4   THE PRECONDITIONED CONJUGATE GRADIENT ITERATION FAILED TO
C       CONVERGE (PROBABLY BECAUSE THE JACOBIAN MATRIX DID NOT HAVE
C       FULL RANK).  THE ALGORITHM HAS FAILED (THE ZERO CURVE OF
C       THE HOMOTOPY MAP CANNOT BE FOLLOWED ANY FURTHER).
C
C   5   THE TRACKING ALGORITHM HAS LOST THE ZERO CURVE OF THE
C       HOMOTOPY MAP AND IS NOT MAKING PROGRESS.  THE ERROR TOLERANCES
C       ARC?E  AND  ANS?E  WERE TOO LENIENT.  THE PROBLEM SHOULD BE
C       RESTARTED BY CALLING  FIXPNS  WITH SMALLER ERROR TOLERANCES
C       AND  IFLAG = 0 (-1, -2).
C
C   6   THE NORMAL FLOW NEWTON ITERATION IN  STEPNS  OR  ROOTNS
C       FAILED TO CONVERGE.  THE ERROR TOLERANCES  ANS?E  MAY BE TOO
C       STRINGENT.
C
C   7   ILLEGAL INPUT PARAMETERS, A FATAL ERROR.
C
C ARCRE , ARCAE , ANSRE , ANSAE  ARE UNCHANGED AFTER A NORMAL RETURN
C    (IFLAG = 1).  THEY ARE INCREASED TO APPROPRIATE VALUES ON THE
C    RETURN  IFLAG = 2 .
C
C NFE  IS THE NUMBER OF FUNCTION EVALUATIONS (= NUMBER OF
C    JACOBIAN EVALUATIONS).
C
C ARCLEN  IS THE LENGTH OF THE PATH FOLLOWED.
C
C
C
      DOUBLE PRECISION ABSERR,ANSAE,ANSRE,ARCAE,ARCLEN,ARCRE,
     1   CURSW,CURTOL,D1MACH,DNRM2,H,HOLD,RELERR,S
      INTEGER IFLAG,IFLAGC,IPP,IRHO,ITANGW,ITER,ITZ,IW,IWP,
     1   IZ0,IZ1,JW,LENQR,LIMIT,LIMITD,N,NC,NFE,NFEC,NP1,TRACE
      LOGICAL START,CRASH
C
C ***** ARRAY DECLARATIONS. *****
C
      DOUBLE PRECISION Y(N+1),YP(N+1),YOLD(N+1),YPOLD(N+1),A(N),
     $   QR(LENQR),WORK(13*(N+1)+2*N+LENQR),SSPAR(8),PAR(1)
      INTEGER PIVOT(N+2),IPAR(1)
C
C ***** END OF DIMENSIONAL INFORMATION. *****
C
      SAVE
C
C LIMITD  IS AN UPPER BOUND ON THE NUMBER OF STEPS.  IT MAY BE
C CHANGED BY CHANGING THE FOLLOWING PARAMETER STATEMENT:
      PARAMETER (LIMITD=1000)
C
C SWITCH FROM THE TOLERANCE  ARC?E  TO THE (FINER) TOLERANCE  ANS?E  IF
C THE CURVATURE OF ANY COMPONENT OF  Y  EXCEEDS  CURSW.
      PARAMETER (CURSW=10.0)
C
C
C
C :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :
      IF (N .LE. 0  .OR.  ANSRE .LE. 0.0  .OR.  ANSAE .LT. 0.0)
     $                                                     IFLAG=7
      IF (IFLAG .GE. -2  .AND.  IFLAG .LE. 0) GO TO 20
      IF (IFLAG .EQ. 2) GO TO 120
      IF (IFLAG .EQ. 3) GO TO 90
C ONLY VALID INPUT FOR  IFLAG  IS -2, -1, 0, 2, 3.
      IFLAG=7
      RETURN
C
C *****  INITIALIZATION BLOCK.  *****
C
20    ARCLEN=0.0
      IF (ARCRE .LE. 0.0) ARCRE=.5*SQRT(ANSRE)
      IF (ARCAE .LE. 0.0) ARCAE=.5*SQRT(ANSAE)
      NC=N
      NFEC=0
      IFLAGC=IFLAG
      NP1=N+1
C SET INDICES FOR SPLITTING UP WORK ARRAY.
      IPP=1
      IRHO=N+1
      IW=IRHO+N
      IWP=IW+NP1
      ITZ=IWP+NP1
      IZ0=ITZ+NP1
      IZ1=IZ0+NP1
      ITANGW=IZ1+NP1
C SET INITIAL CONDITIONS FOR FIRST CALL TO  STEPNS .
      START=.TRUE.
      CRASH=.FALSE.
      HOLD=1.0
      H=.1
      S=0.0
      YPOLD(NP1)=1.0
      YP(NP1)=1.0
      Y(NP1)=0.0
      DO 40 JW=1,N
        YPOLD(JW)=0.0
        YP(JW)=0.0
40    CONTINUE
      DO 50 JW=ITANGW,ITANGW+NP1+N
        WORK(JW)=0.0
50    CONTINUE
C SET OPTIMAL STEP SIZE ESTIMATION PARAMETERS.
C LET Z[K] DENOTE THE NEWTON ITERATES ALONG THE FLOW NORMAL TO THE
C DAVIDENKO FLOW AND Y THEIR LIMIT.
C IDEAL CONTRACTION FACTOR:  ||Z[2] - Z[1]|| / ||Z[1] - Z[0]||
      IF (SSPAR(1) .LE. 0.0) SSPAR(1)= .5
C IDEAL RESIDUAL FACTOR:  ||RHO(A, Z[1])|| / ||RHO(A, Z[0])||
      IF (SSPAR(2) .LE. 0.0) SSPAR(2)= .01
C IDEAL DISTANCE FACTOR:  ||Z[1] - Y|| / ||Z[0] - Y||
      IF (SSPAR(3) .LE. 0.0) SSPAR(3)= .5
C MINIMUM STEP SIZE  HMIN .
      IF (SSPAR(4) .LE. 0.0) SSPAR(4)= (SQRT(N+1.0)+4.0)*D1MACH(4)
C MAXIMUM STEP SIZE  HMAX .
      IF (SSPAR(5) .LE. 0.0) SSPAR(5)= 1.0
C MINIMUM STEP SIZE REDUCTION FACTOR  BMIN .
      IF (SSPAR(6) .LE. 0.0) SSPAR(6)= .1
C MAXIMUM STEP SIZE EXPANSION FACTOR  BMAX .
      IF (SSPAR(7) .LE. 0.0) SSPAR(7)= 3.0
C ASSUMED OPERATING ORDER  P .
      IF (SSPAR(8) .LE. 0.0) SSPAR(8)= 2.0
C
C LOAD  A  FOR THE FIXED POINT AND ZERO FINDING PROBLEMS.
      IF (IFLAGC .GE. -1) THEN
        CALL DCOPY(N,Y,1,A,1)
      ENDIF
90    LIMIT=LIMITD
C
C *****  END OF INITIALIZATION BLOCK.  *****
C
C
C *****  MAIN LOOP.  *****
C
120   DO 400 ITER=1,LIMIT
      IF (Y(NP1) .LT. 0.0) THEN
        ARCLEN=S
        IFLAG=5
        RETURN
      ENDIF
C
C SET DIFFERENT ERROR TOLERANCE IF THE TRAJECTORY Y(S) HAS ANY HIGH
C CURVATURE COMPONENTS.
140   CURTOL=CURSW*HOLD
      RELERR=ARCRE
      ABSERR=ARCAE
      DO 160 JW=1,NP1
        IF (ABS(YP(JW)-YPOLD(JW)) .GT. CURTOL) THEN
          RELERR=ANSRE
          ABSERR=ANSAE
          GO TO 200
        ENDIF
160   CONTINUE
C
C TAKE A STEP ALONG THE CURVE.
200   CALL STEPNS(NC,NFEC,IFLAGC,START,CRASH,HOLD,H,RELERR,ABSERR,
     +     S,Y,YP,YOLD,YPOLD,A,QR,LENQR,PIVOT,WORK,SSPAR,PAR,IPAR)
C PRINT LATEST POINT ON CURVE IF REQUESTED.
      IF (TRACE .GT. 0) THEN
        WRITE (TRACE,217) ITER,NFEC,S,Y(NP1),(Y(JW),JW=1,NC)
217     FORMAT(/' STEP',I5,3X,'NFE =',I5,3X,'ARC LENGTH =',F9.4,3X,
     $  'LAMBDA =',F7.4,5X,'X vector:'/1P,(1X,6E12.4))
      ENDIF
      NFE=NFEC
C CHECK IF THE STEP WAS SUCCESSFUL.
      IF (IFLAGC .GT. 0) THEN
        ARCLEN=S
        IFLAG=IFLAGC
        RETURN
      ENDIF
      IF (CRASH) THEN
C RETURN CODE FOR ERROR TOLERANCE TOO SMALL.
        IFLAG=2
C CHANGE ERROR TOLERANCES.
        IF (ARCRE .LT. RELERR) ARCRE=RELERR
        IF (ANSRE .LT. RELERR) ANSRE=RELERR
        IF (ARCAE .LT. ABSERR) ARCAE=ABSERR
        IF (ANSAE .LT. ABSERR) ANSAE=ABSERR
C CHANGE LIMIT ON NUMBER OF ITERATIONS.
        LIMIT=LIMIT-ITER
        RETURN
      ENDIF
C
      IF (Y(NP1) .GE. 1.0) THEN
C
C USE HERMITE CUBIC INTERPOLATION AND NEWTON ITERATION TO GET THE
C ANSWER AT LAMBDA = 1.0 .
C
C SAVE  YOLD  FOR ARC LENGTH CALCULATION LATER.
        CALL DCOPY(NP1,YOLD,1,WORK(IZ0),1)
C
        CALL ROOTNS(NC,NFEC,IFLAGC,ANSRE,ANSAE,Y,YP,YOLD,YPOLD,
     $              A,QR,LENQR,PIVOT,WORK,PAR,IPAR)
C
        NFE=NFEC
        IFLAG=1
C SET ERROR FLAG IF  ROOTNS  COULD NOT GET THE POINT ON THE ZERO
C CURVE AT  LAMBDA = 1.0  .
        IF (IFLAGC .GT. 0) IFLAG=IFLAGC
C CALCULATE FINAL ARC LENGTH.
        DO 290 JW=1,NP1
          WORK(JW)=Y(JW) - WORK(IZ0+JW-1)
290     CONTINUE
        ARCLEN=S - HOLD + DNRM2(NP1,WORK,1)
        RETURN
      ENDIF
C
400   CONTINUE
C
C *****  END OF MAIN LOOP.  *****
C
C LAMBDA HAS NOT REACHED 1 IN 1000 STEPS.
      IFLAG=3
      ARCLEN=S
      RETURN
C
C
      END
      SUBROUTINE FIXPQF(N,Y,IFLAG,ARCRE,ARCAE,ANSRE,ANSAE,TRACE,A,
     $     NFE,ARCLEN,YP,YOLD,YPOLD,QT,R,F0,F1,Z0,DZ,W,T,YSAV,
     $     SSPAR,PAR,IPAR)
C
C SUBROUTINE  FIXPQF  FINDS A FIXED POINT OR ZERO OF THE
C N-DIMENSIONAL VECTOR FUNCTION  F(X), OR TRACKS A ZERO CURVE OF A
C GENERAL HOMOTOPY MAP  RHO(A,LAMBDA,X).  FOR THE FIXED POINT PROBLEM
C F(X) IS ASSUMED TO BE A C2 MAP OF SOME BALL INTO ITSELF.  THE
C EQUATION  X=F(X)  IS SOLVED BY FOLLOWING THE ZERO CURVE OF THE
C HOMOTOPY MAP
C
C  LAMBDA*(X - F(X)) + (1 - LAMBDA)*(X - A),
C
C STARTING FROM  LAMBDA = 0, X = A.   THE CURVE IS PARAMETERIZED
C BY ARC LENGTH  S, AND IS FOLLOWED BY SOLVING THE ORDINARY
C DIFFERENTIAL EQUATION  D(HOMOTOPY MAP)/DS = 0  FOR
C Y(S) = (LAMBDA(S), X(S)).  THIS IS DONE BY USING A HERMITE CUBIC
C PREDICTOR AND A CORRECTOR WHICH RETURNS TO THE ZERO CURVE IN A
C HYPERPLANE PERPENDICULAR TO THE TANGENT TO THE ZERO CURVE AT THE
C MOST RECENT POINT.
C
C FOR THE ZERO FINDING PROBLEM  F(X)  IS ASSUMED TO BE A C2 MAP
C SUCH THAT FOR SOME  R > 0,  X*F(X) >= 0  WHENEVER  NORM(X) = R.
C THE EQUATION  F(X) = 0  IS SOLVED BY FOLLOWING THE ZERO CURVE OF
C THE HOMOTOPY MAP
C
C  LAMBDA*F(X) + (1 - LAMBDA)*(X - A)
C
C EMANATING FROM  LAMBDA = 0, X = A.
C
C A  MUST BE AN INTERIOR POINT OF THE ABOVE MENTIONED BALLS.
C
C FOR THE CURVE TRACKING PROBLEM RHO(A,LAMBDA,X) IS ASSUMED TO
C BE A C2 MAP FROM  E**M X [0,1) X E**N  INTO  E**N, WHICH FOR
C ALMOST ALL PARAMETER VECTORS  A  IN SOME NONEMPTY OPEN SUBSET
C OF E**M SATISFIES
C
C  RANK [D RHO(A,LAMBDA,X)/D LAMBDA, D RHO(A,LAMBDA,X)/DX] = N
C
C FOR ALL POINTS  (LAMBDA,X)  SUCH THAT  RHO(A,LAMBDA,X) = 0.  IT IS
C FURTHER ASSUMED THAT
C
C         RANK [ D RHO(A,0,X0)/DX ] = N.
C
C WITH  A  FIXED, THE ZERO CURVE OF  RHO(A,LAMBDA,X)  EMANATING FROM
C LAMBDA = 0, X = X0  IS TRACKED UNTIL  LAMBDA = 1  BY SOLVING THE
C ORDINARY DIFFERENTIAL EQUATION    D RHO(A,LAMBDA(S),X(S))/DS = 0
C FOR  Y(S) = (LAMBDA(S), X(S)), WHERE  S  IS ARC LENGTH ALONG THE
C ZERO CURVE.  ALSO THE HOMOTOPY MAP  RHO(A,LAMBDA,X)  IS ASSUMED TO
C BE CONSTRUCTED SUCH THAT
C
C         D LAMBDA(0)/DS > 0.
C
C FOR THE FIXED POINT AND ZERO FINDING PROBLEMS, THE USER MUST SUPPLY
C A SUBROUTINE  F(X,V)  WHICH EVALUATES  F(X)  AT  X  AND RETURNS THE
C VECTOR F(X) IN  V, AND A SUBROUTINE  FJAC(X,V,K)  WHICH RETURNS IN  V
C THE KTH COLUMN OF THE JACOBIAN MATRIX OF F(X) EVALUATED AT X.  FOR
C THE CURVE TRACKING PROBLEM, THE USER MUST SUPPLY A SUBROUTINE
C RHO(A,LAMBDA,X,V,PAR,IPAR)  WHICH EVALUATES THE HOMOTOPY MAP  RHO AT
C (A,LAMBDA,X)  AND RETURNS THE VECTOR  RHO(A,LAMBDA,X)  IN  V, AND
C A SUBROUTINE  RHOJAC(A,LAMBDA,X,V,K,PAR,IPAR)  WHICH RETURNS IN  V
C THE KTH COLUMN OF THE  N X (N+1)  JACOBIAN MATRIX
C [D RHO/D LAMBDA, D RHO/DX]  EVALUATED AT  (A,LAMBDA,X).  FIXPQF
C DIRECTLY OR INDIRECTLY USES THE SUBROUTINES  D1MACH, F (OR RHO),
C FJAC (OR RHOJAC), QRFAQF, QRSLQF, ROOT, ROOTQF, STEPQF, TANGQF,
C UPQRQF  AND THE BLAS ROUTINES  DAXPY, DCOPY, DDOT, DNRM2, AND  DSCAL.
C ONLY  D1MACH  CONTAINS MACHINE DEPENDENT CONSTANTS.  NO OTHER
C MODIFICATIONS BY THE USER ARE REQUIRED.
C
C
C ON INPUT:
C
C N  IS THE DIMENSION OF X, F(X), AND RHO(A,LAMBDA,X).
C
C Y(1:N+1)  CONTAINS THE STARTING POINT FOR TRACKING THE HOMOTOPY MAP.
C    (Y(2),...,Y(N+1)) = A  FOR THE FIXED POINT AND ZERO FINDING
C    PROBLEMS.  (Y(2),...,Y(N+1)) = X0  FOR THE CURVE TRACKING PROBLEM.
C    Y(1)  NEED NOT BE DEFINED BY THE USER.
C
C IFLAG CAN BE -2, -1, 0, 2, OR 3.  IFLAG SHOULD BE 0 ON THE FIRST
C    CALL TO  FIXPQF  FOR THE PROBLEM  X=F(X), -1 FOR THE PROBLEM
C    F(X)=0, AND -2 FOR THE PROBLEM  RHO(A,LAMBDA,X)=0.   IN CERTAIN
C    SITUATIONS  IFLAG  IS SET TO 2 OR 3 BY  FIXPQF, AND  FIXPQF  CAN
C    BE CALLED AGAIN WITHOUT CHANGING  IFLAG.
C
C ARCRE, ARCAE  ARE THE RELATIVE AND ABSOLUTE ERRORS, RESPECTIVELY,
C    ALLOWED THE QUASI-NEWTON ITERATION ALONG THE ZERO CURVE.  IF
C    ARC?E .LE. 0.0  ON INPUT, IT IS RESET TO  .5*SQRT(ANS?E).
C    NORMALLY  ARC?E  SHOULD BE CONSIDERABLY LARGER THAN  ANS?E.
C
C ANSRE, ANSAE  ARE THE RELATIVE AND ABSOLUTE ERROR VALUES USED FOR
C    THE ANSWER AT  LAMBDA = 1.  THE ACCEPTED ANSWER  Y = (LAMBDA, X)
C    SATISFIES
C
C      |Y(1) - 1| .LE. ANSRE + ANSAE      .AND.
C
C      ||DZ|| .LE. ANSRE*||Y|| + ANSAE      WHERE
C
C      DZ IS THE QUASI-NEWTON STEP TO Y.
C
C TRACE  IS AN INTEGER SPECIFYING THE LOGICAL I/O UNIT FOR
C    INTERMEDIATE OUTPUT.  IF  TRACE .GT. 0  THE POINTS COMPUTED ON
C    THE ZERO CURVE ARE WRITTEN TO I/O UNIT  TRACE .
C
C A(1:*)  CONTAINS THE PARAMETER VECTOR  A.  FOR THE FIXED POINT
C    AND ZERO FINDING PROBLEMS,  A  NEED NOT BE INITIALIZED BY THE
C    USER, AND IS ASSUMED TO HAVE LENGTH  N.  FOR THE CURVE
C    TRACKING PROBLEM,  A  MUST BE INITIALIZED BY THE USER.
C
C YP(1:N+1)  IS A WORK ARRAY CONTAINING THE TANGENT VECTOR TO THE
C    ZERO CURVE AT THE CURRENT POINT  Y.
C
C YOLD(1:N+1) IS A WORK ARRAY CONTAINING THE PREVIOUS POINT FOUND
C    ON THE ZERO CURVE.
C
C YPOLD(1:N+1) IS A WORK ARRAY CONTAINING THE TANGENT VECTOR TO
C    THE ZERO CURVE AT  YOLD.
C
C QT(1:N+1,1:N+1), R((N+1)*(N+2)/2), F0(1:N+1), F1(1:N+1), Z0(1:N+1),
C    DZ(1:N+1), W(1:N+1), T(1:N+1), YSAV(1:N+1)  ARE ALL WORK ARRAYS
C    USED BY  STEPQF, TANGQF AND ROOTQF TO CALCULATE THE TANGENT
C    VECTORS AND QUASI-NEWTON STEPS.
C
C SSPAR(1:4) =  (HMIN, HMAX, BMIN, BMAX)  IS A VECTOR OF PARAMETERS
C    USED FOR THE OPTIMAL STEP SIZE ESTIMATION.  A DEFAULT VALUE
C    CAN BE SPECIFIED FOR ANY OF THESE FOUR PARAMETERS BY SETTING IT
C    .LE. 0.0  ON INPUT.  SEE THE COMMENTS IN  STEPQF  FOR MORE
C    INFORMATION ABOUT THESE PARAMETERS.
C
C PAR(1:*)  AND  IPAR(1:*)  ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS,
C    WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES
C    RHO, RHOJAC.
C
C
C ON OUTPUT:
C
C N , TRACE , A  ARE UNCHANGED.
C
C Y(1) = LAMBDA, (Y(2),...,Y(N+1)) = X, AND  Y  IS AN APPROXIMATE
C    ZERO OF THE HOMOTOPY MAP.  NORMALLY  LAMBDA = 1  AND  X  IS A
C    FIXED POINT OR ZERO OF  F(X).   IN ABNORMAL SITUATIONS,  LAMBDA
C    MAY ONLY BE NEAR 1 AND  X  NEAR A FIXED POINT OR ZERO.
C
C IFLAG =
C
C   1   NORMAL RETURN
C
C   2   SPECIFIED ERROR TOLERANCE CANNOT BE MET.  SOME OR ALL OF
C       ARCRE, ARCAE, ANSRE, ANSAE  HAVE BEEN INCREASED TO
C       SUITABLE VALUES.  TO CONTINUE, JUST CALL  FIXPQF  AGAIN
C       WITHOUT CHANGING ANY PARAMETERS.
C
C   3   STEPQF  HAS BEEN CALLED 1000 TIMES.  TO CONTINUE, CALL
C       FIXPQF  AGAIN WITHOUT CHANGING ANY PARAMETERS.
C
C   4   JACOBIAN MATRIX DOES NOT HAVE FULL RANK.  THE ALGORITHM
C       HAS FAILED (THE ZERO CURVE OF THE HOMOTOPY MAP CANNOT BE
C       FOLLOWED ANY FURTHER).
C
C   5   THE TRACKING ALGORITHM HAS LOST THE ZERO CURVE OF THE
C       HOMOTOPY MAP AND IS NOT MAKING PROGRESS.  THE ERROR
C       TOLERANCES  ARC?E  AND  ANS?E  WERE TOO LENIENT.  THE PROBLEM
C       SHOULD BE RESTRARTED BY CALLING  FIXPQF  WITH SMALLER ERROR
C       TOLERANCES AND  IFLAG = 0 (-1, -2).
C
C   6   THE QUASI-NEWTON ITERATION IN  STEPQF  OR  ROOTQF  FAILED TO
C       CONVERGE.  THE ERROR TOLERANCES  ANS?E  MAY BE TOO STRINGENT.
C
C   7   ILLEGAL INPUT PARAMETERS, A FATAL ERROR.
C
C ARCRE, ARCAE, ANSRE, ANSAE  ARE UNCHANGED AFTER A NORMAL RETURN
C    (IFLAG = 1).  THEY ARE INCREASED TO APPROPRIATE VALUES ON THE
C    RETURN  IFLAG = 2.
C
C NFE  IS THE NUMBER OF JACOBIAN EVALUATIONS.
C
C ARCLEN  IS THE APPROXIMATE LENGTH OF THE ZERO CURVE.
C
C ***** DECLARATIONS *****
C
C     FUNCTION DECLARATIONS
C
        DOUBLE PRECISION D1MACH, DNRM2
C
C     LOCAL VARIABLES
C
        DOUBLE PRECISION ABSERR, H, HOLD, RELERR, S, WK
        INTEGER IFLAGC, ITER, JW, LIMITD, LIMIT, NP1
        LOGICAL CRASH, START
C
C     SCALAR ARGUMENTS
C
        DOUBLE PRECISION ARCRE, ARCAE, ANSRE, ANSAE, ARCLEN
        INTEGER N,IFLAG,TRACE,NFE
C
C     ARRAY DECLARATIONS
C
        DOUBLE PRECISION A(N), Y(N+1), YP(N+1), YOLD(N+1), YPOLD(N+1),
     $    QT(N+1,N+1), R((N+1)*(N+2)/2), F0(N+1), F1(N+1), Z0(N+1),
     $    DZ(N+1), W(N+1), T(N+1), YSAV(N+1), SSPAR(4), PAR(1)
        INTEGER IPAR(1)
C
        SAVE
C
C ***** END OF DECLARATIONS *****
C
C LIMITD IS AN UPPER BOUND ON THE NUMBER OF STEPS.  IT MAY BE
C CHANGED BY CHANGING THE FOLLOWING PARAMETER STATEMENT:
        PARAMETER (LIMITD =1000)
C
C ***** FIRST EXECUTABLE STATEMENT *****
C
C CHECK IFLAG
C
        IF (N .LE. 0 .OR. ANSRE .LE. 0.0 .OR. ANSAE .LT. 0.0)
     $    IFLAG = 7
        IF (IFLAG .GE. -2 .AND. IFLAG .LE. 0) GO TO 10
        IF (IFLAG .EQ. 2) GO TO 50
        IF (IFLAG .EQ. 3) GO TO 40
C
C ONLY VALID INPUT FOR IFLAG IS -2, -1, 0, 2, 3.
C
        IFLAG = 7
        RETURN
C
C ***** INITIALIZATION BLOCK  *****
C
  10    ARCLEN = 0.0
        IF (ARCRE .LE. 0.0) ARCRE = .5*SQRT(ANSRE)
        IF (ARCAE .LE. 0.0) ARCAE = .5*SQRT(ANSAE)
        NFE=0
        IFLAGC = IFLAG
        NP1=N+1
C
C SET INITIAL CONDITIONS FOR FIRST CALL TO STEPQF.
C
        START=.TRUE.
        CRASH=.FALSE.
        RELERR = ARCRE
        ABSERR = ARCAE
        HOLD=1.0
        H=0.1
        S=0.0
        YPOLD(1) = 1.0
        Y(1) = 0.0
        DO 20 JW=2,NP1
          YPOLD(JW)=0.0
  20    CONTINUE
C
C SET OPTIMAL STEP SIZE ESTIMATION PARAMETERS.
C
C     MINIMUM STEP SIZE HMIN
        IF (SSPAR(1) .LE. 0.0) SSPAR(1)= (SQRT(N+1.0)+4.0)*D1MACH(4)
C     MAXIMUM STEP SIZE HMAX
        IF (SSPAR(2) .LE. 0.0) SSPAR(2)= 1.0
C     MINIMUM STEP REDUCTION FACTOR BMIN
        IF (SSPAR(3) .LE. 0.0) SSPAR(3)= 0.1
C     MAXIMUM STEP EXPANSION FACTOR BMAX
        IF (SSPAR(4) .LE. 0.0) SSPAR(4)= 7.0
C
C LOAD  A  FOR THE FIXED POINT AND ZERO FINDING PROBLEMS.
C
        IF (IFLAGC .GE. -1) THEN
          CALL DCOPY(N,Y(2),1,A,1)
        ENDIF
C
  40    LIMIT=LIMITD
C
C ***** END OF INITIALIZATION BLOCK. *****
C
C ***** MAIN LOOP. *****
C
  50    DO 400 ITER=1,LIMIT
        IF (Y(1) .LT. 0.0) THEN
          ARCLEN = S
          IFLAG = 5
          RETURN
        END IF
C
C TAKE A STEP ALONG THE CURVE.
C
        CALL STEPQF(N,NFE,IFLAGC,START,CRASH,HOLD,H,WK,
     $    RELERR,ABSERR,S,Y,YP,YOLD,YPOLD,A,QT,R,F0,F1,Z0,DZ,
     $    W,T,SSPAR,PAR,IPAR)
C
C PRINT LATEST POINT ON CURVE IF REQUESTED.
C
      IF (TRACE .GT. 0) THEN
        WRITE (TRACE,217) ITER,NFE,S,Y(1),(Y(JW),JW=2,NP1)
217     FORMAT(/' STEP',I5,3X,'NFE =',I5,3X,'ARC LENGTH =',F9.4,3X,
     $  'LAMBDA =',F7.4,5X,'X vector:'/1P,(1X,6E12.4))
      ENDIF
C
C CHECK IF THE STEP WAS SUCCESSFUL.
C
        IF (IFLAGC .GT. 0) THEN
          ARCLEN=S
          IFLAG=IFLAGC
          RETURN
        END IF
C
        IF (CRASH) THEN
C
C         RETURN CODE FOR ERROR TOLERANCE TOO SMALL.
C
          IFLAG=2
C
C         CHANGE ERROR TOLERANCES.
C
          IF (ARCRE .LT. RELERR) THEN
            ARCRE=RELERR
            ANSRE=RELERR
          END IF
          IF (ARCAE .LT. ABSERR) ARCAE=ABSERR
C
C         CHANGE LIMIT ON NUMBER OF ITERATIONS.
C
          LIMIT = LIMIT - ITER
          RETURN
        END IF
C
C IF LAMBDA >= 1.0, USE ROOTQF TO FIND SOLUTION.
C
        IF (Y(1) .GE. 1.0) GOTO 500
C
  400   CONTINUE
C
C ***** END OF MAIN LOOP *****
C
C DID NOT CONVERGE IN  LIMIT  ITERATIONS, SET  IFLAG  AND RETURN.
C
        ARCLEN = S
        IFLAG = 3
        RETURN
C
C ***** FINAL STEP -- FIND SOLUTION AT LAMBDA=1 *****
C
C SAVE  YOLD  FOR ARC LENGTH CALCULATION LATER.
C
  500   CALL DCOPY(NP1,YOLD,1,YSAV,1)
C
C FIND SOLUTION.
C
        CALL ROOTQF(N,NFE,IFLAGC,ANSRE,ANSAE,Y,YP,YOLD,
     $    YPOLD,A,QT,R,DZ,Z0,W,T,F0,F1,PAR,IPAR)
C
C CHECK IF SOLUTION WAS FOUND AND SET  IFLAG  ACCORDINGLY.
C
        IFLAG=1
C
C     SET ERROR FLAG IF ROOTQF COULD NOT GET THE POINT ON THE ZERO
C     CURVE AT  LAMBDA = 1.0.
C
        IF (IFLAGC .GT. 0) IFLAG=IFLAGC
C
C CALCULATE FINAL ARC LENGTH.
C
        CALL DCOPY(NP1,Y,1,DZ,1)
        WK=-1.0
        CALL DAXPY(NP1,WK,YSAV,1,DZ,1)
        ARCLEN = S - HOLD + DNRM2(NP1,DZ,1)
C
C ***** END OF FINAL STEP *****
C
        RETURN
C
C ***** END OF SUBROUTINE FIXPQF *****
        END
        SUBROUTINE FIXPQS(N,Y,IFLAG,ARCRE,ARCAE,ANSRE,ANSAE,TRACE,
     $     A,NFE,ARCLEN,YP,YOLD,YPOLD,QR,LENQR,PIVOT,PP,RHOVEC,Z0,DZ,
     $     T,WORK,SSPAR,PAR,IPAR)
C
C SUBROUTINE  FIXPQS  FINDS A FIXED POINT OR ZERO OF THE
C N-DIMENSIONAL VECTOR FUNCTION  F(X), OR TRACKS A ZERO CURVE OF A
C GENERAL HOMOTOPY MAP  RHO(A,X,LAMBDA).  FOR THE FIXED POINT PROBLEM
C F(X) IS ASSUMED TO BE A C2 MAP OF SOME BALL INTO ITSELF.  THE
C EQUATION  X=F(X)  IS SOLVED BY FOLLOWING THE ZERO CURVE OF THE
C HOMOTOPY MAP
C
C  LAMBDA*(X - F(X)) + (1 - LAMBDA)*(X - A),
C
C STARTING FROM  LAMBDA = 0, X = A.   THE CURVE IS PARAMETERIZED
C BY ARC LENGTH  S, AND IS FOLLOWED BY SOLVING THE ORDINARY
C DIFFERENTIAL EQUATION  D(HOMOTOPY MAP)/DS = 0  FOR
C Y(S) = (X(S),LAMBDA(S)).  THIS IS DONE BY USING A HERMITE CUBIC
C PREDICTOR AND A CORRECTOR WHICH RETURNS TO THE ZERO CURVE IN A
C HYPERPLANE PERPENDICULAR TO THE TANGENT TO THE ZERO CURVE AT THE
C MOST RECENT POINT.
C
C FOR THE ZERO FINDING PROBLEM  F(X)  IS ASSUMED TO BE A C2 MAP SUCH
C THAT FOR SOME  R > 0,  X*F(X) >= 0  WHENEVER  NORM(X) = R.
C THE EQUATION  F(X) = 0  IS SOLVED BY FOLLOWING THE ZERO CURVE OF
C THE HOMOTOPY MAP
C
C  LAMBDA*F(X) + (1 - LAMBDA)*(X - A)
C
C EMANATING FROM  LAMBDA = 0, X = A.
C
C A  MUST BE AN INTERIOR POINT OF THE ABOVE MENTIONED BALLS.
C
C FOR THE CURVE TRACKING PROBLEM RHO(A,X,LAMBDA) IS ASSUMED TO
C BE A C2 MAP FROM  E**M X [0,1) X E**N  INTO  E**N, WHICH FOR
C ALMOST ALL PARAMETER VECTORS  A  IN SOME NONEMPTY OPEN SUBSET
C OF E**M SATISFIES
C
C  RANK [D RHO(A,X,LAMBDA)/D LAMBDA, D RHO(A,X,LAMBDA)/DX] = N
C
C FOR ALL POINTS  (X,LAMBDA)  SUCH THAT  RHO(A,X,LAMBDA) = 0.  IT IS
C FURTHER ASSUMED THAT
C
C         RANK [ D RHO(A,X0,0)/DX ] = N.
C
C WITH  A  FIXED, THE ZERO CURVE OF  RHO(A,X,LAMBDA)  EMANATING FROM
C LAMBDA = 0, X = X0  IS TRACKED UNTIL  LAMBDA = 1  BY SOLVING THE
C ORDINARY DIFFERENTIAL EQUATION  D RHO(A,X(S),LAMBDA(S))/DS = 0
C FOR  Y(S) = (X(S),LAMBDA(S)), WHERE  S  IS ARC LENGTH ALONG THE
C ZERO CURVE.  ALSO THE HOMOTOPY MAP  RHO(A,X,LAMBDA)  IS ASSUMED TO
C BE CONSTRUCTED SUCH THAT
C
C         D LAMBDA(0)/DS > 0.
C
C FOR THE FIXED POINT AND ZERO FINDING PROBLEMS, THE USER MUST SUPPLY
C A SUBROUTINE  F(X,V)  WHICH EVALUATES F(X) AT X AND RETURNS THE
C VECTOR F(X) IN  V,  AND A SUBROUTINE  FJACS(X,QR,LENQR,PIVOT)  WHICH
C EVALUATES THE (SYMMETRIC) JACOBIAN MATRIX OF F(X) AT X, AND RETURNS
C THE SYMMETRIC JACOBIAN MATRIX IN PACKED SKYLINE STORAGE FORMAT IN  QR.
C LENQR  AND  PIVOT  DESCRIBE THE DATA STRUCTURE IN  QR.  FOR THE CURVE
C TRACKING PROBLEM, THE USER MUST SUPPLY A SUBROUTINE
C  RHO(A,LAMBDA,X,V,PAR,IPAR)  WHICH EVALUATES THE HOMOTOPY MAP RHO
C AT (A,X,LAMBDA) AND RETURNS THE VECTOR RHO(A,X,LAMBDA) IN  V,
C AND A SUBROUTINE  RHOJS(A,LAMBDA,X,QR,LENQR,PIVOT,PP,PAR,IPAR)  WHICH
C RETURNS IN  QR  THE SYMMETRIC N X N JACOBIAN MATRIX [D RHO/DX]
C EVALUATED AT (A,X,LAMBDA) AND STORED IN PACKED SKYLINE FORMAT,
C AND RETURNS IN  PP  THE VECTOR  -(D RHO/D LAMBDA)  EVALUATED AT
C (A,X,LAMBDA).  LENQR  AND  PIVOT  DESCRIBE THE DATA STRUCTURE IN
C QR.
C *** NOTE THE MINUS SIGN IN THE DEFINITION OF  PP. ***
C
C
C FIXPQS DIRECTLY OR INDIRECTLY USES THE SUBROUTINES  D1MACH, F
C (OR RHO), FJACS (OR RHOJS), GMFADS, MULTDS, PCGQS, ROOTQS, STEPQS,
C SOLVDS,  AND THE BLAS ROUTINES  DAXPY, DCOPY, DDOT, DNRM2, AND  DSCAL.
C ONLY  D1MACH  CONTAINS MACHINE DEPENDENT CONSTANTS.  NO OTHER
C MODIFICATIONS BY THE USER ARE REQUIRED.
C
C
C ON INPUT:
C
C N  IS THE DIMENSION OF X, F(X), AND RHO(A,X,LAMBDA).
C
C Y(1:N+1)  CONTAINS THE STARTING POINT FOR TRACKING THE HOMOTOPY MAP.
C    (Y(1),...,Y(N)) = A  FOR THE FIXED POINT AND ZERO FINDING
C    PROBLEMS.  (Y(1),...,Y(N)) = X0  FOR THE CURVE TRACKING PROBLEM.
C    Y(N+1)  NEED NOT BE DEFINED BY THE USER.
C
C IFLAG  CAN BE -2, -1, 0, 2, OR 3.  IFLAG  SHOULD BE 0 ON THE FIRST
C    CALL TO  FIXPQS  FOR THE PROBLEM  X=F(X), -1 FOR THE PROBLEM
C    F(X)=0, AND -2 FOR THE PROBLEM  RHO(A,X,LAMBDA)=0.   IN CERTAIN
C    SITUATIONS  IFLAG  IS SET TO 2 OR 3 BY  FIXPQS, AND  FIXPQS  CAN
C    BE CALLED AGAIN WITHOUT CHANGING  IFLAG.
C
C ARCRE, ARCAE  ARE THE RELATIVE AND ABSOLUTE ERRORS, RESPECTIVELY,
C    ALLOWED THE ITERATION ALONG THE ZERO CURVE.  IF
C    ARC?E .LE. 0.0  ON INPUT, IT IS RESET TO  .5*SQRT(ANS?E).
C    NORMALLY  ARC?E  SHOULD BE CONSIDERABLY LARGER THAN  ANS?E.
C
C ANSRE, ANSAE  ARE THE RELATIVE AND ABSOLUTE ERROR VALUES USED FOR
C    THE ANSWER AT  LAMBDA = 1.  THE ACCEPTED ANSWER  Y = (X,LAMBDA)
C    SATISFIES
C
C      |Y(1) - 1| .LE. ANSRE + ANSAE      .AND.
C
C      ||DZ|| .LE. ANSRE*||Y|| + ANSAE      WHERE
C
C      DZ IS THE NEWTON STEP TO Y.
C
C TRACE  IS AN INTEGER SPECIFYING THE LOGICAL I/O UNIT FOR
C    INTERMEDIATE OUTPUT.  IF  TRACE .GT. 0  THE POINTS COMPUTED ON
C    THE ZERO CURVE ARE WRITTEN TO I/O UNIT  TRACE .
C
C A(1:*)  CONTAINS THE PARAMETER VECTOR  A.  FOR THE FIXED POINT
C    AND ZERO FINDING PROBLEMS,  A  NEED NOT BE INITIALIZED BY THE
C    USER, AND IS ASSUMED TO HAVE LENGTH  N.  FOR THE CURVE
C    TRACKING PROBLEM,  A  MUST BE INITIALIZED BY THE USER.
C
C YP(1:N+1)  IS A WORK ARRAY CONTAINING THE TANGENT VECTOR TO THE
C    ZERO CURVE AT THE CURRENT POINT  Y.
C
C YOLD(1:N+1) IS A WORK ARRAY CONTAINING THE PREVIOUS POINT FOUND
C    ON THE ZERO CURVE.
C
C YPOLD(1:N+1) IS A WORK ARRAY CONTAINING THE TANGENT VECTOR TO
C    THE ZERO CURVE AT  YOLD.
C
C QR(1:LENQR)  IS A WORK ARRAY CONTAINING THE N X N SYMMETRIC
C    JACOBIAN MATRIX WITH RESPECT TO X STORED IN PACKED SKYLINE
C    STORAGE FORMAT.  LENQR  AND  PIVOT  DESCRIBE THE DATA
C    STRUCTURE IN  QR.  (SEE SUBROUTINE  PCGQS  FOR A DESCRIPTION
C    OF THIS DATA STRUCTURE).
C
C LENQR  IS THE LENGTH OF THE N-DIMENSIONAL ARRAY  QR.  I.E.
C    IT IS THE NUMBER OF NON-ZERO ENTRIES IN THE JACOBIAN
C    MATRIX [DF/DX] (OR [D RHO/DX]).
C
C PIVOT(1:N+2)  IS A WORK ARRAY WHOSE FIRST N+1 COMPONENTS CONTAIN
C    THE INDICES OF THE DIAGONAL ELEMENTS OF THE N X N SYMMETRIC
C    JACOBIAN MATRIX (WITH RESPECT TO X) WITHIN  QR.
C
C PP(1:N)  IS A WORK ARRAY CONTAINING THE NEGATIVE OF THE LAST COLUMN
C    OF THE JACOBIAN MATRIX  -[D RHO/D LAMBDA].
C
C RHOVEC(1:N+1), Z0(1:N+1), DZ(1:N+1), T(1:N+1)  ARE ALL WORK ARRAYS
C    USED BY  STEPQS, TANGQS, AND ROOTQS  TO CALCULATE THE TANGENT
C    VECTORS AND NEWTON STEPS.
C
C WORK(1:8*(N+1)+LENQR)  IS A WORK ARRAY USED BY THE CONJUGATE GRADIENT
C    ALGORITHM TO SOLVE LINEAR SYSTEMS.
C
C SSPAR(1:4) =  (HMIN, HMAX, BMIN, BMAX)  IS A VECTOR OF PARAMETERS
C    USED FOR THE OPTIMAL STEP SIZE ESTIMATION.  A DEFAULT VALUE
C    CAN BE SPECIFIED FOR ANY OF THESE FOUR PARAMETERS BY SETTING IT
C    .LE. 0.0  ON INPUT.  SEE THE COMMENTS IN  STEPQS  FOR MORE
C    INFORMATION ABOUT THESE PARAMETERS.
C
C PAR(1:*)  AND  IPAR(1:*)  ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS,
C    WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES
C    RHO, RHOJS.
C
C
C ON OUTPUT:
C
C N , TRACE , A , LENQR  ARE UNCHANGED.
C
C Y(N+1) = LAMBDA, (Y(1),...,Y(N)) = X, AND  Y  IS AN APPROXIMATE
C    ZERO OF THE HOMOTOPY MAP.  NORMALLY  LAMBDA = 1  AND  X  IS A
C    FIXED POINT OR ZERO OF  F(X).   IN ABNORMAL SITUATIONS,  LAMBDA
C    MAY ONLY BE NEAR 1 AND  X  NEAR A FIXED POINT OR ZERO.
C
C IFLAG =
C
C   1   NORMAL RETURN.
C
C   2   SPECIFIED ERROR TOLERANCE CANNOT BE MET.  SOME OR ALL OF
C       ARCRE, ARCAE, ANSRE, ANSAE  HAVE BEEN INCREASED TO
C       SUITABLE VALUES.  TO CONTINUE, JUST CALL  FIXPQS  AGAIN
C       WITHOUT CHANGING ANY PARAMETERS.
C
C   3   STEPQS  HAS BEEN CALLED 1000 TIMES.  TO CONTINUE, CALL
C       FIXPQS  AGAIN WITHOUT CHANGING ANY PARAMETERS.
C
C   4   JACOBIAN MATRIX DOES NOT HAVE FULL RANK.  THE ALGORITHM
C       HAS FAILED (THE ZERO CURVE OF THE HOMOTOPY MAP CANNOT BE
C       FOLLOWED ANY FURTHER).
C
C   5   THE TRACKING ALGORITHM HAS LOST THE ZERO CURVE OF THE
C       HOMOTOPY MAP AND IS NOT MAKING PROGRESS.  THE ERROR
C       TOLERANCES  ARC?E  AND  ANS?E  WERE TOO LENIENT.  THE PROBLEM
C       SHOULD BE RESTRARTED BY CALLING  FIXPQS  WITH SMALLER ERROR
C       TOLERANCES AND  IFLAG = 0 (-1, -2).
C
C   6   THE NEWTON ITERATION IN  STEPQS  OR  ROOTQS  FAILED TO
C       CONVERGE.  THE ERROR TOLERANCES  ANS?E  MAY BE TOO STRINGENT.
C
C   7   ILLEGAL INPUT PARAMETERS, A FATAL ERROR.
C
C ARCRE, ARCAE, ANSRE, ANSAE  ARE UNCHANGED AFTER A NORMAL RETURN
C    (IFLAG = 1).  THEY ARE INCREASED TO APPROPRIATE VALUES ON THE
C    RETURN  IFLAG = 2.
C
C NFE  IS THE NUMBER OF JACOBIAN EVALUATIONS.
C
C ARCLEN  IS THE APPROXIMATE LENGTH OF THE ZERO CURVE.
C
C ***** DECLARATIONS *****
C
C     FUNCTION DECLARATIONS
C
        DOUBLE PRECISION D1MACH, DNRM2
C
C     LOCAL VARIABLES
C
        DOUBLE PRECISION ABSERR, H, HOLD, RELERR, S, WK
        INTEGER IFLAGC, ITER, JW, LIMITD, LIMIT, NP1, PCGWK
        LOGICAL CRASH, START
C
C     SCALAR ARGUMENTS
C
        DOUBLE PRECISION ARCRE, ARCAE, ANSRE, ANSAE, ARCLEN
        INTEGER N, IFLAG, TRACE, NFE, LENQR
C
C     ARRAY DECLARATIONS
C
        DOUBLE PRECISION A(N), Y(N+1), YP(N+1), YOLD(N+1), YPOLD(N+1),
     $    QR(LENQR), PP(N), RHOVEC(N+1), Z0(N+1), DZ(N+1), T(N+1),
     $    WORK(8*(N+1)+LENQR), SSPAR(4), PAR(1)
        INTEGER PIVOT(N+2), IPAR(1)
C
        SAVE
C
C ***** END OF DECLARATIONS *****
C
C LIMITD  IS AN UPPER BOUND ON THE NUMBER OF STEPS.  IT MAY BE
C CHANGED BY CHANGING THE FOLLOWING PARAMETER STATEMENT:
        PARAMETER (LIMITD =1000)
C
C ***** FIRST EXECUTABLE STATEMENT *****
C
C CHECK IFLAG
C
        IF (N .LE. 0 .OR. ANSRE .LE. 0.0 .OR. ANSAE .LT. 0.0)
     $    IFLAG = 7
        IF (IFLAG .GE. -2 .AND. IFLAG .LE. 0) GO TO 10
        IF (IFLAG .EQ. 2) GO TO 50
        IF (IFLAG .EQ. 3) GO TO 40
C
C ONLY VALID INPUT FOR IFLAG IS -2, -1, 0, 2, 3.
C
        IFLAG = 7
        RETURN
C
C ***** INITIALIZATION BLOCK  *****
C
  10    ARCLEN = 0.0
        IF (ARCRE .LE. 0.0) ARCRE = .5*SQRT(ANSRE)
        IF (ARCAE .LE. 0.0) ARCAE = .5*SQRT(ANSAE)
        NFE=0
        IFLAGC = IFLAG
        NP1=N+1
        PCGWK = 2*N+3
C
C SET INITIAL CONDITIONS FOR FIRST CALL TO STEPQS.
C
        START=.TRUE.
        CRASH=.FALSE.
        RELERR = ARCRE
        ABSERR = ARCAE
        HOLD=1.0
        H=0.1
        S=0.0
        YPOLD(NP1) = 1.0
        Y(NP1) = 0.0
        DO 20 JW=1,N
          YPOLD(JW)=0.0
  20    CONTINUE
C
C SET OPTIMAL STEP SIZE ESTIMATION PARAMETERS.
C
C     MINIMUM STEP SIZE HMIN
        IF (SSPAR(1) .LE. 0.0) SSPAR(1)= (SQRT(N+1.0)+4.0)*D1MACH(4)
C     MAXIMUM STEP SIZE HMAX
        IF (SSPAR(2) .LE. 0.0) SSPAR(2)= 1.0
C     MINIMUM STEP REDUCTION FACTOR BMIN
        IF (SSPAR(3) .LE. 0.0) SSPAR(3)= 0.1
C     MAXIMUM STEP EXPANSION FACTOR BMAX
        IF (SSPAR(4) .LE. 0.0) SSPAR(4)= 7.0
C
C LOAD  A  FOR THE FIXED POINT AND ZERO FINDING PROBLEMS.
C
        IF (IFLAGC .GE. -1) THEN
          CALL DCOPY(N,Y,1,A,1)
        ENDIF
C
  40    LIMIT=LIMITD
C
C ***** END OF INITIALIZATION BLOCK. *****
C
C ***** MAIN LOOP. *****
C
  50    DO 400 ITER=1,LIMIT
        IF (Y(NP1) .LT. 0.0) THEN
          ARCLEN = S
          IFLAG = 5
          RETURN
        END IF
C
C TAKE A STEP ALONG THE CURVE.
C
        CALL STEPQS(N,NFE,IFLAGC,LENQR,START,CRASH,HOLD,H,WK,RELERR,
     $    ABSERR,S,Y,YP,YOLD,YPOLD,A,QR,PIVOT,PP,RHOVEC,Z0,DZ,T,
     $    WORK,SSPAR,PAR,IPAR)
C
C PRINT LATEST POINT ON CURVE IF REQUESTED.
C
      IF (TRACE .GT. 0) THEN
        WRITE (TRACE,217) ITER,NFE,S,Y(NP1),(Y(JW),JW=1,N)
217     FORMAT(/' STEP',I5,3X,'NFE =',I5,3X,'ARC LENGTH =',F9.4,3X,
     $  'LAMBDA =',F7.4,5X,'X vector:'/1P,(1X,6E12.4))
      ENDIF
C
C CHECK IF THE STEP WAS SUCCESSFUL.
C
        IF (IFLAGC .GT. 0) THEN
          ARCLEN=S
          IFLAG=IFLAGC
          RETURN
        END IF
C
        IF (CRASH) THEN
C
C         RETURN CODE FOR ERROR TOLERANCE TOO SMALL.
C
          IFLAG=2
C
C         CHANGE ERROR TOLERANCES.
C
          IF (ARCRE .LT. RELERR) THEN
            ARCRE=RELERR
            ANSRE=RELERR
          ENDIF
          IF (ARCAE .LT. ABSERR) ARCAE=ABSERR
C
C         CHANGE LIMIT ON NUMBER OF ITERATIONS.
C
          LIMIT = LIMIT - ITER
          RETURN
        END IF
C
C IF  LAMBDA >= 1.0,  USE  ROOTQS  TO FIND SOLUTION.
C
        IF (Y(NP1) .GE. 1.0) GOTO 500
C
  400   CONTINUE
C
C ***** END OF MAIN LOOP *****
C
C DID NOT CONVERGE IN  LIMIT  ITERATIONS, SET  IFLAG  AND RETURN.
C
        ARCLEN = S
        IFLAG = 3
        RETURN
C
C ***** FINAL STEP -- FIND SOLUTION AT LAMBDA=1 *****
C
C SAVE  YOLD  FOR ARC LENGTH CALCULATION LATER.
C
  500   CALL DCOPY(NP1,YOLD,1,T,1)
C
C FIND SOLUTION.
C
        CALL ROOTQS(N,NFE,IFLAGC,LENQR,ANSRE,ANSAE,Y,YP,YOLD,YPOLD,
     $    A,QR,PIVOT,PP,RHOVEC,Z0,DZ,WORK(PCGWK),PAR,IPAR)
C
C CHECK IF SOLUTION WAS FOUND AND SET  IFLAG  ACCORDINGLY.
C
        IFLAG=1
C
C     SET ERROR FLAG IF ROOTQS COULD NOT GET THE POINT ON THE ZERO
C     CURVE AT  LAMBDA = 1.0 .
C
        IF (IFLAGC .GT. 0) IFLAG=IFLAGC
C
C CALCULATE FINAL ARC LENGTH.
C
        CALL DCOPY(NP1,Y,1,DZ,1)
        WK=-1.0
        CALL DAXPY(NP1,WK,T,1,DZ,1)
        ARCLEN=S - HOLD + DNRM2(NP1,DZ,1)
C
C ***** END OF FINAL STEP *****
C
        RETURN
C
C ***** END OF SUBROUTINE FIXPQS *****
        END
      SUBROUTINE FJAC(X,V,K)
      DOUBLE PRECISION X(1),V(1)
      INTEGER K
C
C RETURN IN  V  THE KTH COLUMN OF THE JACOBIAN MATRIX OF
C F(X) EVALUATED AT  X .
C
      RETURN
      END
      SUBROUTINE FJACS(X,QR,LENQR,PIVOT)
C     INTEGER LENQR,N,PIVOT(N+2)
C     DOUBLE PRECISION QR(LENQR),X(N)
C
C Evaluate the N x N symmetric Jacobian matrix of F(X) at X, and return
C the result in packed skyline storage format in QR.  LENQR is the lengt
C of QR, and PIVOT contains the indices of the diagonal elements of the
C Jacobian matrix within QR.  PIVOT(N+1) and PIVOT(N+2) are set by
C subroutine FODE.
C
      RETURN
      END
      SUBROUTINE FODE(S,Y,YP,YPOLD,A,QR,ALPHA,TZ,PIVOT,NFE,N,IFLAG,
     $                PAR,IPAR)
C
C SUBROUTINE  FODE  IS USED BY SUBROUTINE  STEPS  TO SPECIFY THE
C ORDINARY DIFFERENTIAL EQUATION  DY/DS = G(S,Y) , WHOSE SOLUTION
C IS THE ZERO CURVE OF THE HOMOTOPY MAP.  S = ARC LENGTH,
C YP = DY/DS, AND  Y(S) = (LAMBDA(S), X(S)) .
C
C PAR(1:*) AND IPAR(1:*) ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS,
C    WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES
C    RHOA, RHOJAC.
C
      DOUBLE PRECISION DDOT,DNRM2,S,SUM,YPNORM
      INTEGER I,IERR,IFLAG,IK,J,K,KP1,KPIV,LW,N,NFE,NP1
C
C *****  ARRAY DECLARATIONS.  *****
C
      DOUBLE PRECISION Y(N+1),YP(N+1),YPOLD(N+1),A(N),PAR(1)
      INTEGER IPAR(1)
C
C ARRAYS FOR COMPUTING THE JACOBIAN MATRIX AND ITS KERNEL.
      DOUBLE PRECISION QR(N,N+1),ALPHA(N),TZ(N+1)
      INTEGER PIVOT(N+1)
C
C *****  END OF DIMENSIONAL INFORMATION.  *****
C
C
      NP1=N+1
      NFE=NFE+1
C NFE CONTAINS THE NUMBER OF JACOBIAN EVALUATIONS.
C   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *
C
C COMPUTE THE JACOBIAN MATRIX, STORE IT IN QR.
C
      IF (IFLAG .EQ. -2) THEN
C
C  QR = ( D RHO(A,LAMBDA,X)/D LAMBDA , D RHO(A,LAMBDA,X)/DX )  .
C
        DO 30 K=1,NP1
          CALL RHOJAC(A,Y(1),Y(2),QR(1,K),K,PAR,IPAR)
30      CONTINUE
      ELSE
        CALL F(Y(2),TZ)
        IF (IFLAG .EQ. 0) THEN
C
C      QR = ( A - F(X), I - LAMBDA*DF(X) )  .
C
          DO 100 J=1,N
100       QR(J,1)=A(J)-TZ(J)
          DO 120 K=1,N
            CALL FJAC(Y(2),TZ,K)
            KP1=K+1
            DO 110 J=1,N
110         QR(J,KP1)=-Y(1)*TZ(J)
120       QR(K,KP1)=1.0+QR(K,KP1)
        ELSE
C
C   QR = ( F(X) - X + A, LAMBDA*DF(X) + (1 - LAMBDA)*I ) .
C
140       DO 150 J=1,N
150       QR(J,1)=TZ(J)-Y(J+1)+A(J)
          DO 170 K=1,N
            CALL FJAC(Y(2),TZ,K)
            KP1=K+1
            DO 160 J=1,N
160         QR(J,KP1)=Y(1)*TZ(J)
170       QR(K,KP1)=1.0-Y(1)+QR(K,KP1)
        ENDIF
      ENDIF
C
C   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *
C REDUCE THE JACOBIAN MATRIX TO UPPER TRIANGULAR FORM.
210   CALL DCPOSE(N,N,QR,ALPHA,PIVOT,IERR,TZ,YP)
      IF (IERR .EQ. 0) GO TO 220
      IFLAG=4
      RETURN
C COMPUTE KERNEL OF JACOBIAN, WHICH SPECIFIES YP=DY/DS.
220   TZ(NP1)=1.0
      DO 240 LW=1,N
        I=NP1-LW
        IK=I+1
        SUM=0.0
        DO 230 J=IK,NP1
230     SUM=SUM+QR(I,J)*TZ(J)
240   TZ(I)=-SUM/ALPHA(I)
      YPNORM=DNRM2(NP1,TZ,1)
      DO 260 K=1,NP1
        KPIV=PIVOT(K)
260   YP(KPIV)=TZ(K)/YPNORM
      IF (DDOT(NP1,YP,1,YPOLD,1) .GE. 0.0) GO TO 280
      DO 270 I=1,NP1
270   YP(I)=-YP(I)
C
C SAVE CURRENT DERIVATIVE (= TANGENT VECTOR) IN  YPOLD .
280   DO 290 I=1,NP1
290   YPOLD(I)=YP(I)
      RETURN
      END
      SUBROUTINE FODEDS(S,Y,YP,YPOLD,A,QR,LENQR,PIVOT,PP,WORK,
     $     NFE,N,IFLAG,PAR,IPAR)
C
C SUBROUTINE  FODEDS  IS USED BY SUBROUTINE  STEPDS  TO SPECIFY THE
C ORDINARY DIFFERENTIAL EQUATION  DY/DS = G(S,Y) , WHOSE SOLUTION
C IS THE ZERO CURVE OF THE HOMOTOPY MAP.  S = ARC LENGTH,
C YP = DY/DS, AND  Y(S) = (X(S), LAMBDA(S)) .
C
C PAR(1:*) AND IPAR(1:*) ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS,
C    WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES
C    RHOA, RHOJS.
C
      DOUBLE PRECISION DDOT,DNRM2,LAMBDA,S,TEMP,YPNORM
      INTEGER IFLAG,J,LENQR,N,NFE,NP1
C
C *****  ARRAY DECLARATIONS.  *****
C
      DOUBLE PRECISION Y(N+1),YP(N+1),YPOLD(N+1),A(N),PAR(1)
      INTEGER IPAR(1)
C
C ARRAYS FOR COMPUTING THE JACOBIAN MATRIX AND ITS KERNEL.
      DOUBLE PRECISION QR(LENQR),PP(N),WORK(6*(N+1)+LENQR)
      INTEGER PIVOT(N+2)
C
C *****  END OF DIMENSIONAL INFORMATION.  *****
C
C
      NP1=N+1
      NFE=NFE+1
C NFE CONTAINS THE NUMBER OF JACOBIAN EVALUATIONS.
      LAMBDA=Y(NP1)
C   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *
C
C COMPUTE THE JACOBIAN MATRIX, STORE IT IN  [QR | -PP] .
C
      IF (IFLAG .EQ. -2) THEN
C
C  [QR | -PP] = [ D RHO(A,X,LAMBDA)/DX | D RHO(A,X,LAMBDA)/D LAMBDA ]  .
C
        CALL RHOJS(A,LAMBDA,Y,QR,LENQR,PIVOT,PP,PAR,IPAR)
C  PP = - (D RHO(A,X,LAMBDA)/D LAMBDA) .
C
      ELSE
        CALL F(Y,PP)
        IF (IFLAG .EQ. 0) THEN
C
C      [QR | -PP] = [ I - LAMBDA*DF(X) | A - F(X) ]  .
C
          CALL DAXPY(N,-1.0D0,A,1,PP,1)
          CALL FJACS(Y,QR,LENQR,PIVOT)
          CALL DSCAL(LENQR,-LAMBDA,QR,1)
          DO 120 J=1,N
            QR(PIVOT(J))=QR(PIVOT(J)) + 1.0
120       CONTINUE
        ELSE
C
C   [QR | -PP] = [ LAMBDA*DF(X) + (1 - LAMBDA)*I | F(X) - X + A ] .
C
          CALL DSCAL(N,-1.0D0,PP,1)
          CALL DAXPY(N,1.0D0,Y,1,PP,1)
          CALL DAXPY(N,-1.0D0,A,1,PP,1)
          CALL FJACS(Y,QR,LENQR,PIVOT)
          CALL DSCAL(LENQR,LAMBDA,QR,1)
          TEMP=1.0 - LAMBDA
          DO 170 J=1,N
            QR(PIVOT(J))=QR(PIVOT(J)) + TEMP
170       CONTINUE
        ENDIF
      ENDIF
C
C   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *
      CALL DCOPY(NP1,YPOLD,1,YP,1)
C COMPUTE KERNEL OF JACOBIAN, WHICH SPECIFIES YP=DY/DS, USING A
C PRECONDITIONED CONJUGATE GRADIENT ALGORITHM.
      CALL PCGDS(N,QR,LENQR,PIVOT,PP,YP,WORK,IFLAG)
      IF (IFLAG .GT. 0) RETURN
C
C NORMALIZE TANGENT VECTOR YP.
      YPNORM=DNRM2(NP1,YP,1)
      CALL DSCAL(NP1,1.0/YPNORM,YP,1)
C
C CHOOSE UNIT TANGENT VECTOR DIRECTION TO MAINTAIN CONTINUITY.
      IF (DDOT(NP1,YP,1,YPOLD,1) .LT. 0.0)
     $     CALL DSCAL(NP1,-1.0D0,YP,1)
C
C SAVE CURRENT DERIVATIVE (= TANGENT VECTOR) IN  YPOLD .
      CALL DCOPY(NP1,YP,1,YPOLD,1)
C
      RETURN
      END
      SUBROUTINE GFUNP(N,IDEG,PDG,QDG,X,
     $ XDGM1,XDG,PXDGM1,PXDG,G,DG)
C
C GFUNP  EVALUATES THE START EQUATION "G".
C
C ON INPUT:
C
C N  IS THE NUMBER OF VARIABLES.
C
C IDEG(J)  IS THE DEGREE OF THE J-TH EQUATION.
C
C PDG(1,J), PDG(2,J)  ARE THE REAL AND IMAGINARY PARTS
C   OF THE POWERS OF P USED TO DEFINE G.
C
C QDG(1,J), QDG(2,J)  ARE THE REAL AND IMAGINARY PARTS
C   OF THE POWERS OF Q USED TO DEFINE G.
C
C X(1,J), X(2,J)  ARE THE REAL AND IMAGINARY PARTS OF THE
C   J-TH INDEPENDENT VARIABLE.
C
C XDGM1,XDG,PXDGM1,PXDG ARE WORKSPACE ARRAYS.
C
C ON OUTPUT:
C
C N,IDEG,PDG,QDG, AND X  ARE UNCHANGED.
C
C G(1,J),G(2,J)  ARE THE REAL AND IMAGINARY PARTS OF THE
C   J-TH START EQUATION.
C
C DG(1,J),DG(2,J)  ARE THE REAL AND IMAGINARY PARTS OF THE
C   PARTIAL DERIVATIVES OF THE J-TH START EQUATION WITH RESPECT TO THE
C   J-TH INDEPENDENT VARIABLE.
C
C SUBROUTINE:  MULP.
C
C DECLARATION OF INPUT AND OUTPUT:
      INTEGER N,IDEG
      DOUBLE PRECISION PDG,QDG,X,XDGM1,XDG,PXDGM1,PXDG,G,DG
      DIMENSION IDEG(N),PDG(2,N),QDG(2,N),X(2,N),
     $  XDGM1(2,N),XDG(2,N),PXDGM1(2,N),PXDG(2,N),
     $  G(2,N),DG(2,N)
C
C DECLARATION OF VARIABLES
      INTEGER I,J
C
C COMPUTE THE (IDEG-1)-TH AND IDEG-TH POWER OF X
      DO 5 J=1,N
        CALL POWP(IDEG(J)-1,X(1,J), XDGM1(1,J))
        CALL MULP(X(1,J),XDGM1(1,J), XDG(1,J))
  5   CONTINUE
C
C COMPUTE THE PRODUCT OF PDG AND XDGM1
      DO 10 J=1,N
          CALL MULP( PDG(1,J), XDGM1(1,J), PXDGM1(1,J) )
  10  CONTINUE
C
C COMPUTE THE PRODUCT OF PDG AND XDG
      DO 20 J=1,N
          CALL MULP( PDG(1,J), XDG(1,J), PXDG(1,J) )
  20  CONTINUE
      DO 30 J=1,N
      DO 30 I=1,2
          G(I,J)=PXDG(I,J) - QDG(I,J)
          DG(I,J)= IDEG(J)*PXDGM1(I,J)
  30  CONTINUE
      RETURN
      END
*
      SUBROUTINE GMFADS(NN,A,NWK,MAXA)
C
C     This subroutine computes the LDU decomposition of a symmetric posi
C     definite matrix B where only the upper triangular skyline structur
C     is stored.  The decomposition is done by the Gill-Murray
C     strategy from P.E. Gill and W. Murray, Newton type Methods
C     for Unconstrained and Linearly Constrained Optimization,
C     Mathematical Programming, 7, 311-350 (1974) and gives an
C     approximate decomposition in the case of a nonpositive
C     definite or ill-conditioned matrix.
C
C     Input variables:
C
C        NN -- dimension of B.
C
C        A -- one dimensional real array containing the upper
C             triangular skyline portion of a symmetric matrix B in
C             packed skyline storage format.
C
C        NWK -- number of elements in A.
C
C        MAXA -- an integer array of dimension NN+1 containing the
C                locations of the diagonal elements of B in A.
C                By convention, MAXA(NN+1)=NWK+1.
C
C     Output variables:
C
C        A -- the upper triangular skyline portion of the LDU
C             decomposition of the symmetric matrix B (or B + E if B
C             was not sufficiently positive definite).
C
C
C     No working storage is required by this routine.
C
C     Subroutines called:  D1MACH
C
      INTEGER I,I0,I1,I2,I3,I4,J,J1,K,K1,K2,KH,KL,KN,KU,KZ,L,L1,
     $   L2,L3,M,M1,MAXA(NN+1),N1,NN,NNN,NWK
      DOUBLE PRECISION A(NWK),BET,DEL,DJ,D1MACH,G,GAM,GAM1,PHI,
     $   THE,THE1,XT1,XT2,ZET,ZET1
C     LOGICAL GMALT
C     GMALT=.FALSE.
      G=0.0
      GAM=0.0
      DO 1 I=1,NN
         K=MAXA(I)
         G=G+A(K)*A(K)
         GAM1=ABS(A(K))
         IF(GAM1.GT.GAM)GAM=GAM1
1     CONTINUE
      ZET=0.0
      DO 3 I=1,NN
         K=MAXA(I)
         K1=MAXA(I+1)-1
         K2=K1-K
         IF(K2.EQ.0)GO TO 3
         L=K+1
         DO 2 J=L,K1
            G=G+2.0*A(J)*A(J)
            ZET1=ABS(A(J))
            IF(ZET1.GT.ZET)ZET=ZET1
2        CONTINUE
3     CONTINUE
      ZET=ZET/NN
      DEL=D1MACH(4)
      BET=DEL
      IF(ZET.GT.BET)BET=ZET
      IF(GAM.GT.BET)BET=GAM
      G=SQRT(G)
      IF(G.GT.1.0)DEL=DEL*G
      DO 4 I=1,NN
         N1=I-1
         KN=MAXA(I)
         KL=KN+1
         KU=MAXA(I+1)-1
         KH=KU-KL
         PHI=A(KN)
         IF(KH.LT.0)GO TO 10
         K1=KN+1
         K2=I
         DO 5 J=K1,KU
            K2=K2-1
            KZ=MAXA(K2)
            PHI=PHI-A(J)*A(J)*A(KZ)
5        CONTINUE
C10      IF(PHI.LE.0.0)GMALT=.TRUE.
10       PHI=ABS(PHI)
         L=I+1
         THE=0.0
         NNN=NN+1
         IF(L.EQ.NNN)GO TO 11
         DO 6 J=L,NN
            L1=MAXA(J)
            L2=MAXA(J+1)
            L3=L2-L1-1
            M=J-I
            IF(L3.LT.M)GO TO 6
            M1=L1+M
            IF(N1.EQ.0)GO TO 7
            DO 8 J1=1,N1
               I0=MAXA(J1)
               I1=MAXA(L)
               I2=I-J1
               I3=I1-KN-1
               I4=J-J1
               IF(I3.LT.I2)GO TO 8
               IF(L3.LT.I4)GO TO 8
               XT1=A(KN+I2)
               XT2=A(L1+I4)
               A(M1)=A(M1)-XT1*XT2*A(I0)
8           CONTINUE
7           THE1=ABS(A(M1))
            IF(THE.LT.THE1)THE=THE1
6        CONTINUE
11       THE=THE*THE/BET
         DJ=DEL
         IF(PHI.GT.DJ)DJ=PHI
         IF(THE.GT.DJ)DJ=THE
C        IF(ABS(DJ).NE.PHI)GMALT=.TRUE.
         A(KN)=DJ
         IF(L.EQ.NNN)GO TO 4
         DO 9 J=L,NN
            L1=MAXA(J)
            L2=MAXA(J+1)
            L3=L2-L1-1
            M=J-I
            IF(L3.LT.M)GO TO 9
            M1=L1+M
            A(M1)=A(M1)/A(KN)
9        CONTINUE
4     CONTINUE
      RETURN
      END
      SUBROUTINE HFUN1P(QDG,LAMBDA,X,
     $ PDG,CL,COEF,RHO,
     $ DRHOX,DRHOL,XDGM1,XDG,
     $ G,DG,PXDGM1,PXDG,
     $ F,DF,XX,TRM,
     $ DTRM,CLX,DXNP1,
     $ N,MMAXT,IDEG,
     $ NUMT,KDEG)
C
C  HFUN1P  EVALUATES THE CONTINUATION EQUATION "RHO".
C
C  NOTE THAT:
C    DRHOX IS THE "REALIFICATION" OF DCRHOX, WHERE
C    DCRHOX DENOTES THE (COMPLEX) PARTIAL
C    DERIVATIVE MATRIX OF THE CONTINUATION SYSTEM
C    WITH RESPECT TO X,  AND
C    DRHOL IS THE "REALIFICATION" OF DCRHOL, WHERE
C    DCRHOL DENOTES THE (COMPLEX) PARTIAL
C    DERIVATIVE MATRIX OF THE CONTINUATION SYSTEM
C    WITH RESPECT TO LAMBDA. THUS
C      DRHOX(2J-1,2K-1) = DCRHOX(1,J,K)
C      DRHOX(2J  ,2K  ) = DCRHOX(1,J,K)
C      DRHOX(2J-1,2K  ) =-DCRHOX(2,J,K)
C      DRHOX(2J  ,2K-1) = DCRHOX(2,J,K)
C      DRHOL(2J-1,N2P1) = DCRHOL(1,J)
C      DRHOL(2J  ,N2P1) = DCRHOL(2,J)
C       RHO(2J-1)      = CRHO(1,J)
C       RHO(2J  )      = CRHO(2,J)
C    WHERE CRHO DENOTES THE (COMPLEX) CONTINUATION SYSTEM,
C    THE INITIAL "1" OR "2" DENOTES REAL OR IMAGINARY PARTS,
C    RESPECTIVELY, "J" INDEXES THE EQUATION, "K" INDEXES THE PARTIAL
C    DERIVATIVE, AND NEITHER DCRHOX NOR DCRHOL ARE PROGRAM VARIABLES.
C
C  ON INPUT:
C
C    QDG  IS THE "RANDOM" PARAMETER "A".
C
C    LAMBDA  IS THE CONTINUATION PARAMETER.
C
C    X    IS THE INDEPENDENT VARIABLE.
C
C    PDG  IS ONE OF THE PARAMETERS THAT DEFINES G (SEE SUBROUTINE
C         GFUNP).
C
C    CL   IS ONE OF THE PARAMETERS THAT DEFINES F (SEE SUBROUTINE
C         FFUNP).
C
C    COEF  IS ONE OF THE PARAMETERS THAT DEFINES F (SEE SUBROUTINE
C         FFUNP).
C
C  ON OUTPUT:
C
C    RHO    IS THE HOMOTOPY.
C
C    DRHOX  CONTAINS THE PARTIAL DERIVATIVES OF RHO WITH RESPECT
C         TO X.
C
C    DRHOL  CONTAINS THE PARTIAL DERIVATIVES OF RHO WITH RESPECT
C         TO LAMBDA.
C
C  THE FOLLOWING ARE VARIABLES WHOSE WORKSPACE IS PASSED FROM HFUNP:
C    XDGM1
C    XDG
C    G
C    DG
C    PXDGM1
C    PXDG
C    F
C    DF
C    XX
C    TRM
C    DTRM
C    CLX
C    DXNP1
C    N
C    MMAXT
C    IDEG
C    NUMT
C    KDEG
C
C  OTHER VARIABLES:
C    ONEML
C
C  SUBROUTINES:  GFUNP, FFUNP.
C
C DECLARATION OF INPUT, WORKSPACE, AND OUTPUT:
      INTEGER N,MMAXT,IDEG,
     $ NUMT,KDEG
      DOUBLE PRECISION QDG,LAMBDA,X,
     $ PDG,CL,COEF,RHO,
     $ DRHOX,DRHOL,XDGM1,XDG,
     $ G,DG,PXDGM1,PXDG,
     $ F,DF,XX,TRM,
     $ DTRM,CLX,DXNP1
      DIMENSION IDEG(N),NUMT(N),KDEG(N,N+1,MMAXT)
      DIMENSION QDG(2,N),X(2,N),
     $  PDG(2,N),CL(2,N+1),COEF(N,MMAXT),RHO(2*N),
     $  DRHOX(2*N,2*N),DRHOL(2*N),XDGM1(2,N),XDG(2,N),
     $  G(2,N),DG(2,N),PXDGM1(2,N),PXDG(2,N),
     $  F(2,N), DF(2,N,N+1),XX(2,N,N+1,MMAXT),TRM(2,N,MMAXT),
     $  DTRM(2,N,N+1,MMAXT),CLX(2,N),DXNP1(2,N)
C
C DECLARATION OF VARIABLES:
      INTEGER J,J2,J2M1,K,K2,K2M1
      DOUBLE PRECISION ONEML
C
      CALL GFUNP(N,IDEG,PDG,QDG,X,XDGM1,XDG,PXDGM1,PXDG,G,DG)
      CALL FFUNP(N,NUMT,MMAXT,KDEG,COEF,CL,X,
     $  XX,TRM,DTRM,CLX,DXNP1,F,DF)
      ONEML=1.0 - LAMBDA
      DO 30 J=1,N
          J2=2*J
          J2M1=J2-1
          DO 20 K=1,N
              K2=2*K
              K2M1=K2-1
              DRHOX(J2M1,K2M1)= LAMBDA*DF(1,J,K)
              DRHOX(J2  ,K2  )= DRHOX(J2M1,K2M1)
              DRHOX(J2  ,K2M1)= LAMBDA*DF(2,J,K)
              DRHOX(J2M1,K2  )=-DRHOX(J2  ,K2M1)
  20      CONTINUE
          DRHOX(J2M1,J2M1)= DRHOX(J2M1,J2M1) + ONEML*DG(1,J)
          DRHOX(J2  ,J2  )= DRHOX(J2M1,J2M1)
          DRHOX(J2  ,J2M1)= DRHOX(J2  ,J2M1) + ONEML*DG(2,J)
          DRHOX(J2M1,J2  )=-DRHOX(J2  ,J2M1)
          DRHOL(J2M1)     =   F(1,J)      -        G(1,J)
          DRHOL(J2)       =   F(2,J)      -        G(2,J)
          RHO(J2M1)      = LAMBDA*F(1,J) + ONEML* G(1,J)
          RHO(J2  )      = LAMBDA*F(2,J) + ONEML* G(2,J)
  30  CONTINUE
      RETURN
      END
*
      SUBROUTINE HFUNP(QDG,LAMBDA,X,PAR,IPAR)
C
C HFUNP ALLOCATES STORAGE FOR SUBROUTINE HFUN1P FROM THE WORK ARRAYS
C PAR AND IPAR, AS FOLLOWS:
C
C DOUBLE PRECISION VARIABLES AND ARRAYS PASSED IN PAR
C
C     PAR INDEX     VARIABLE NAME       LENGTH
C    ----------     -------------    -----------------
C          1              PDG               2*N
C          2               CL               2*(N+1)
C          3             COEF               N*MMAXT
C          4              RHO               N2
C          5              DRHOX             N2*N2
C          6              DRHOL             N2
C          7            XDGM1               2*N
C          8              XDG               2*N
C          9              G                 2*N
C         10             DG                 2*N
C         11           PXDGM1               2*N
C         12             PXDG               2*N
C         13               F                2*N
C         14              DF                2*N*(N+1)
C         15               XX               2*N*(N+1)*MMAXT
C         16              TRM               2*N*MMAXT
C         17             DTRM               2*N*(N+1)*MMAXT
C         18              CLX               2*N
C         19            DXNP1               2*N
C
C INTEGER VARIABLES AND ARRAYS PASSED IN IPAR
C
C    IPAR INDEX     VARIABLE NAME       LENGTH            OFFSET
C    ----------     -------------    -----------------
C          1                N               1               1
C          2             MMAXT              1               2
C          3            PROFF               25              3
C          4           IPROFF               15              28
C          5             IDEG               N               43
C          6             NUMT               N               43+N
C          7             KDEG               N*(N+1)*MMAXT   43+N2+1
C
C ON INPUT:
C
C QDG  IS THE "RANDOM" VECTOR DENOTED  "A"  IN HOMPACK DOCUMENTATION.
C
C LAMBDA  IS THE CONTINUATION PARAMETER.
C
C X  IS THE INDEPENDENT VARIABLE.
C
C PAR  IS THE REAL PARAMETER ARRAY.
C
C IPAR  IS THE INTEGER PARAMETER ARRAY.
C
C ON OUTPUT:
C
C THE WORK ARRAYS PAR AND IPAR HAVE BEEN UPDATED.
C
C SUBROUTINES:  HFUN1P.
C
      INTEGER IPAR
      DOUBLE PRECISION QDG,LAMBDA,X,PAR
      DIMENSION QDG(2,1),X(2,1),PAR(*),IPAR(*)
C
      CALL HFUN1P(QDG,LAMBDA,X,
     $ PAR( IPAR(3 + ( 1-1))), PAR( IPAR(3 + ( 2-1))),
     $ PAR( IPAR(3 + ( 3-1))), PAR( IPAR(3 + ( 4-1))),
     $ PAR( IPAR(3 + ( 5-1))), PAR( IPAR(3 + ( 6-1))),
     $ PAR( IPAR(3 + ( 7-1))), PAR( IPAR(3 + ( 8-1))),
     $ PAR( IPAR(3 + ( 9-1))), PAR( IPAR(3 + (10-1))),
     $ PAR( IPAR(3 + (11-1))), PAR( IPAR(3 + (12-1))),
     $ PAR( IPAR(3 + (13-1))), PAR( IPAR(3 + (14-1))),
     $ PAR( IPAR(3 + (15-1))), PAR( IPAR(3 + (16-1))),
     $ PAR( IPAR(3 + (17-1))), PAR( IPAR(3 + (18-1))),
     $ PAR( IPAR(3 + (19-1))),
     $IPAR( IPAR(28+ ( 1-1))),IPAR( IPAR(28+ ( 2-1))),
     $IPAR( IPAR(28+ ( 5-1))),IPAR( IPAR(28+ ( 6-1))),
     $IPAR( IPAR(28+ ( 7-1))) )
C
      RETURN
      END
*
      INTEGER FUNCTION IDAMAX(N,DX,INCX)
C
C     FINDS THE INDEX OF ELEMENT HAVING MAX. ABSOLUTE VALUE.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      DOUBLE PRECISION DX(1),DMAX
      INTEGER I,INCX,IX,N
C
      IDAMAX = 0
      IF( N .LT. 1 ) RETURN
      IDAMAX = 1
      IF(N.EQ.1)RETURN
      IF(INCX.EQ.1)GO TO 20
C
C        CODE FOR INCREMENT NOT EQUAL TO 1
C
      IX = 1
      DMAX = DABS(DX(1))
      IX = IX + INCX
      DO 10 I = 2,N
         IF(DABS(DX(IX)).LE.DMAX) GO TO 5
         IDAMAX = I
         DMAX = DABS(DX(IX))
    5    IX = IX + INCX
   10 CONTINUE
      RETURN
C
C        CODE FOR INCREMENT EQUAL TO 1
C
   20 DMAX = DABS(DX(1))
      DO 30 I = 2,N
         IF(DABS(DX(I)).LE.DMAX) GO TO 30
         IDAMAX = I
         DMAX = DABS(DX(I))
   30 CONTINUE
      RETURN
      END
*
      SUBROUTINE INITP(IFLG1,N,NUMT,KDEG,COEF,NN,MMAXT,PAR,IPAR,
     $                                 IDEG,FACV,CL,PDG,QDG,R)
C
C INITP  INITIALIZES THE CONSTANTS THAT DEFINE THE POLSYS HOMOTOPY,
C INITIALIZES THE CONSTANTS THAT DEFINE THE PROJECTIVE TRANSFORMATION,
C AND SCALES THE COEFFICIENTS (IF SCALING IS SPECIFIED).
C
C ON INPUT:
C
C IFLG1  IS A FLAG THAT SPECIFIES WHETHER THE COEFFICIENTS ARE TO
C   BE SCALED OR NOT AND WHETHER THE PROJECTIVE TRANSFORMATION IS TO
C   BE USED OR NOT.  IFLG1=A*10+B.  SCALING IS SPECIFIED WHEN B=1.  THE
C   PROJECTIVE TRANSFORMATION IS SPECIFIED WHEN A=1.  OTHERWISE, A AND/O
C   B =0.  SCALING IS EVOKED BY A CALL TO THE SUBROUTINE  SCLGNP.  THE
C   PROJECTIVE TRANSFORMATION IS EVOKED BY SETTING THE  CL  ARRAY EQUAL
C   TO RANDOM COMPLEX NUMBERS.  OTHERWISE,  CL  IS SET TO NOMINAL VALUES
C
C N  IS THE NUMBER OF EQUATIONS AND VARIABLES.
C
C NUMT(J)  IS THE NUMBER OF TERMS IN EQUATION J, FOR J=1 TO N.
C
C KDEG(J,L,K)  IS THE DEGREE OF THE L-TH VARIABLE, X(L), IN THE K-TH
C  TERM OF THE J-TH EQUATION, WHERE J=1 TO N, L=1 TO N+1, AND K=1 TO
C  NUMT(J).  THE CASE "L=N+1" IS SPECIAL, AND  KDEG  IS NOT AN INPUT
C  VALUE TO  POLSYS , BUT RATHER IS COMPUTED IN THIS SUBROUTINE.
C
C COEF(J,K)  IS THE COEFFICIENT OF THE K-TH TERM FOR THE J-TH
C   EQUATION, WHERE J=1 TO N AND K=1 TO NUMT(J).
C
C NN  IS THE DECLARED DIMENSION OF SEVERAL ARRAY INDICES.
C
C MMAXT  IS AN UPPER BOUND FOR NUMT(J) FOR J=1 TO N.
C
C PAR  AND  IPAR  ARE WORKSPACE ARRAYS.
C
C ON OUTPUT:
C
C IDEG(J)  IS THE DEGREE OF THE J-TH EQUATION FOR J=1 TO N.
C
C FACV(J)  IS THE SCALE FACTOR FOR THE J-TH VARIABLE.
C
C CL(2,1:N+1)  IS AN ARRAY USED TO DEFINE THE PROJECTIVE
C   TRANSFORMATION.  IT IS USED IN SUBROUTINES  FFUNP  AND  OTPUTP
C   TO DEFINE THE PROJECTIVE COORDINATE, XNP1.
C
C PDG  IS USED IN SUBROUTINE  GFUNP  TO DEFINE THE INITIAL SYSTEM,
C   G(X)=0.
C
C QDG  IS USED IN SUBROUTINE  GFUNP  TO DEFINE THE INITIAL SYSTEM,
C   G(X)=0.
C
C R  IS USED IN SUBROUTINE  STRPTP  TO GENERATE SOLUTIONS TO G(X)=0.
C
C
C DECLARATIONS OF INPUT AND OUTPUT:
      INTEGER IFLG1,N,NUMT,KDEG,NN,MMAXT,IPAR,IDEG
      DOUBLE PRECISION COEF,PAR,FACV,CL,PDG,QDG,R
      DIMENSION NUMT(NN),KDEG(NN,NN+1,MMAXT),IDEG(N),COEF(NN,MMAXT),
     $  PAR(2 + 28*N + 6*N**2 + 7*N*MMAXT + 4*N**2*MMAXT),
     $  IPAR(42 + 2*N + N*(N+1)*MMAXT),
     $  FACV(N),CL(2,N+1),PDG(2,N),QDG(2,N),R(2,N)
C
C DECLARATIONS OF VARIABLES:
      INTEGER I,IERR,IIDEG,J,JJ,K,L,N2,NP1
      DOUBLE PRECISION P,Q,CCL,ZERO
      DIMENSION P(2,10),Q(2,10),CCL(2,11)
C
      ZERO=0.0
      N2 =2*N
      NP1=N+1
      DO 15 J=1,N
         IDEG(J)=0
         DO 15 K=1,NUMT(J)
             IIDEG=0
             DO 12 L=1,N
                IIDEG=IIDEG+KDEG(J,L,K)
 12          CONTINUE
             IF(IIDEG.GT.IDEG(J))IDEG(J)=IIDEG
 15      CONTINUE
      DO 25 J=1,N
         DO 25 K=1,NUMT(J)
             IIDEG=0
             DO 22 L=1,N
                IIDEG=IIDEG+KDEG(J,L,K)
 22          CONTINUE
             KDEG(J,NP1,K)=IDEG(J)-IIDEG
 25      CONTINUE
      IF ( IFLG1 .EQ. 10  .OR.  IFLG1 .EQ. 00) THEN
C
C       DON'T SCALE THE COEFFICIENTS.  SET  FACV  EQUAL TO NOMINAL
C       VALUES.
C
        DO 30 I=1,N
           FACV(I)=0.0
  30    CONTINUE
      ELSE
C
C SET UP THE WORKSPACE FOR SUBROUTINE  SCLGNP  AND CALL  SCLGNP  TO
C SCALE THE COEFFICIENTS.
C
C*****************************************************************
C VARIABLES THAT ARE PASSED IN ARRAY PAR.
C
C    VARIABLE NAME   LENGTH        OFFSET
C
C    1   CCOEF       N*MMAXT       1
C    2   ALPHA       4*N**2        1+N*MMAXT
C    3   BETA        2*N           1+N*MMAXT+4*N**2
C    4   RWORK       N*(2*N+1)     1+N*MMAXT+4*N**2+2*N
C    5   XWORK       2*N           1+N*MMAXT+4*N**2+2*N+N*(2*N+1)
C    6   FACE        N             1+N*MMAXT+4*N**2+4*N+N*(2*N+1)
C    7   COESCL      N*MMAXT       1+N*MMAXT+4*N**2+5*N+N*(2*N+1)
C
C*****************************************************************
C VARIABLES THAT ARE PASSED IN ARRAY IPAR.
C
C    VARIABLE NAME       LENGTH               OFFSET
C
C    1   NNUMT             N                  1
C    2   KKDEG             N*(N+1)*MMAXT      1+N
C
C*****************************************************************
C
        CALL SCLGNP(N,NN,MMAXT,NUMT,KDEG,0,ZERO,COEF,
     $   IPAR(1),
     $   IPAR(1+N),
     $    PAR(1),
     $    PAR(1+N*MMAXT),
     $    PAR(1+N*MMAXT+4*N**2),
     $    PAR(1+N*MMAXT+4*N**2+2*N),
     $    PAR(1+N*MMAXT+4*N**2+2*N+N*(2*N+1)),
     $     FACV,
     $    PAR(1+N*MMAXT+4*N**2+4*N+N*(2*N+1)),
     $    PAR(1+N*MMAXT+4*N**2+5*N+N*(2*N+1)),
     $     IERR)
C
C       SET COEF EQUAL TO THE SCALED COEFFICIENTS
C
        IF (IERR .EQ. 0) THEN
          DO 40 J=1,N
            DO 40 K=1,NUMT(J)
              COEF(J,K)=PAR(N*MMAXT+4*N**2+5*N+N*(2*N+1) + J + N*(K-1))
 40       CONTINUE
        END IF
      END IF
C
      P(1, 1)= .12324754231D0
          P(2, 1)= .76253746298D0
      P(1, 2)= .93857838950D0
          P(2, 2)=-.99375892810D0
      P(1, 3)=-.23467908356D0
          P(2, 3)= .39383930009D0
      P(1, 4)= .83542556622D0
          P(2, 4)=-.10192888288D0
      P(1, 5)=-.55763522521D0
          P(2, 5)=-.83729899911D0
      P(1, 6)=-.78348738738D0
          P(2, 6)=-.10578234903D0
      P(1, 7)= .03938347346D0
          P(2, 7)= .04825184716D0
      P(1, 8)=-.43428734331D0
          P(2, 8)= .93836289418D0
      P(1, 9)=-.99383729993D0
          P(2, 9)=-.40947822291D0
      P(1,10)= .09383736736D0
          P(2,10)= .26459172298D0
C
      Q(1, 1)= .58720452864D0
          Q(2, 1)= .01321964722D0
      Q(1, 2)= .97884134700D0
          Q(2, 2)=-.14433009712D0
      Q(1, 3)= .39383737289D0
          Q(2, 3)= .41543223411D0
      Q(1, 4)=-.03938376373D0
          Q(2, 4)=-.61253112318D0
      Q(1, 5)= .39383737388D0
          Q(2, 5)=-.26454678861D0
      Q(1, 6)=-.00938376766D0
          Q(2, 6)= .34447867861D0
      Q(1, 7)=-.04837366632D0
          Q(2, 7)= .48252736790D0
      Q(1, 8)= .93725237347D0
          Q(2, 8)=-.54356527623D0
      Q(1, 9)= .39373957747D0
          Q(2, 9)= .65573434564D0
      Q(1,10)=-.39380038371D0
          Q(2,10)= .98903450052D0
C
      CCL(1, 1)=-.03485644332D0
          CCL(2, 1)= .28554634336D0
      CCL(1, 2)= .91453454766D0
          CCL(2, 2)= .35354566613D0
      CCL(1, 3)=-.36568737635D0
          CCL(2, 3)= .45634642477D0
      CCL(1, 4)=-.89089767544D0
          CCL(2, 4)= .34524523544D0
      CCL(1, 5)= .13523462465D0
          CCL(2, 5)= .43534535555D0
      CCL(1, 6)=-.34523544445D0
          CCL(2, 6)= .00734522256D0
      CCL(1, 7)=-.80004678763D0
          CCL(2, 7)=-.009387123644D0
      CCL(1, 8)=-.875432124245D0
          CCL(2, 8)= .00045687651D0
      CCL(1, 9)= .65256352333D0
          CCL(2, 9)=-.12356777452D0
      CCL(1,10)= .09986798321548D0
          CCL(2,10)=-.56753456577D0
      CCL(1,11)= .29674947394739D0
          CCL(2,11)= .93274302173D0
C
C IF THE PROJECTIVE TRANSFORMATION IS TO BE USED, THEN  CL  IS
C SET EQUAL TO THE  CCL  VALUES.  OTHERWISE,  CL  IS SET
C EQUAL TO NOMINAL VALUES.
C
      IF (IFLG1 .EQ. 01  .OR.  IFLG1 .EQ. 00) THEN
          DO 50 I=1,2
          DO 50 J=1,N
            CL(I,J)=0.0
 50       CONTINUE
          CL(1,NP1)=1.0
          CL(2,NP1)=0.0
      ELSE
          DO 60 J=1,NP1
            JJ=MOD(J-1,11)+1
          DO 60 I=1,2
            CL(I,J)=CCL(I,JJ)
  60      CONTINUE
      END IF
C
C COMPUTE POWERS OF P AND Q, AND R=Q/P
      DO 70 J=1,N
        JJ=MOD(J-1,10)+1
        CALL POWP(IDEG(J),P(1,JJ),PDG(1,J))
        CALL POWP(IDEG(J),Q(1,JJ),QDG(1,J))
        CALL DIVP(Q(1,JJ),P(1,JJ),R(1,J),IERR)
  70  CONTINUE
      RETURN
      END
*
      SUBROUTINE MFACDS(NN,Q,LENAA,MAXA)
C
C     SETS UP Q AS THE FACTORIZATION OF THE ENTIRE
C     (NN+1) X (NN+1) MATRIX M.
C
C on input:
C
C NN  is the dimension of the symmetric matrix AA, the upper left corner
C     of the augmented Jacobian matrix B.
C
C Q  contains AA in its first LENAA positions.
C
C LENAA  is the length of the one dimensional packed array AA.
C
C MAXA  is the integer array used for packed skyline storage.  It descri
C       AA and M, the symmetric piece of B.
C
C on output:
C
C NN, LENAA, and MAXA are unchanged.
C
C Q  contains an approximate factorization of M, in packed skyline stora
C    form.
C
C
C Calls  GMFADS .
C
      INTEGER I,IMAX,LENAA,LENQ,NN,MAXA(NN+2),NQ
      DOUBLE PRECISION Q(LENAA+NN+1)
C
      NQ=NN+1
      IMAX=MAXA(NN+2)-LENAA-2
      LENQ=MAXA(NN+2)-1
C
      DO 100 I=1,IMAX,1
         Q(LENAA+I)=0.0
100   CONTINUE
      Q(LENQ)=1.0D0
C
      CALL GMFADS(NQ,Q,LENQ,MAXA)
C
      RETURN
      END
      SUBROUTINE MULP(XXXX,YYYY,ZZZZ)
C
C THIS SUBROUTINE PERFORMS MULTIPLICATION OF COMPLEX NUMBERS:
C ZZZZ = XXXX*YYYY
C
C NOTE:  IN THE CALLING ROUTINE, ZZZZ SHOULD NOT BE THE SAME
C AS XXXX OR YYYY.  HOWEVER, XXXX MAY BE THE SAME AS YYYY.
C THUS, "CALL MULP(X,X,Z)" IS OK, BUT "CALL MULP(X,Y,X)" IS NOT.
C
C ON INPUT:
C
C XXXX  IS AN ARRAY OF LENGTH TWO REPRESENTING THE FIRST COMPLEX
C       NUMBER, WHERE XXXX(1) = REAL PART OF XXXX AND XXXX(2) =
C       IMAGINARY PART OF XXXX.
C
C YYYY  IS AN ARRAY OF LENGTH TWO REPRESENTING THE SECOND COMPLEX
C       NUMBER, WHERE YYYY(1) = REAL PART OF YYYY AND YYYY(2) =
C       IMAGINARY PART OF YYYY.
C
C ON OUTPUT:
C
C ZZZZ  IS AN ARRAY OF LENGTH TWO REPRESENTING THE RESULT OF
C       THE MULTIPLICATION, ZZZZ = XXXX*YYYY, WHERE ZZZZ(1) =
C       REAL PART OF ZZZZ AND ZZZZ(2) = IMAGINARY PART OF ZZZZ.
C
C DECLARATION OF INPUT
      DOUBLE PRECISION XXXX,YYYY
      DIMENSION XXXX(2),YYYY(2)
C
C DECLARATION OF OUTPUT
      DOUBLE PRECISION ZZZZ
      DIMENSION ZZZZ(2)
C
      ZZZZ(1) = XXXX(1)*YYYY(1) - XXXX(2)*YYYY(2)
      ZZZZ(2) = XXXX(1)*YYYY(2) + XXXX(2)*YYYY(1)
      RETURN
      END
*
      SUBROUTINE MULTDS(Y,AA,X,MAXA,NN,LENAA)
C
C     This subroutine accepts a matrix, AA, in packed skyline storage fo
C       a vector, x, and returns the product AA*x in y.
C
C     Input Variables:
C
C       AA -- one dimensional real array containing the NN x NN matrix i
C             packed skyline storage form.
C
C       x -- real vector of length NN to be multiplied by AA.
C
C       MAXA -- integer array used for specifying information about AA.
C               MAXA has length NN+1, and stores the indices of the
C               diagonal elements of the matrix packed in AA.  By
C               convention, MAXA(NN+1) = LENAA + 1 .
C
C       NN -- dimension of the matrix packed in AA .
C
C       LENAA -- number of elements in AA.
C
C
C     Output Variables:
C
C       y -- real vector of length NN containing the product  AA*x .
C
C
C
      INTEGER I,II,KK,KL,KU,LENAA,NN,MAXA(NN+1)
      DOUBLE PRECISION AA(LENAA),B,CC,X(NN),Y(NN)
      IF(LENAA.GT.NN) GO TO 20
      DO 10 I=1,NN
   10 Y(I)=AA(I)*X(I)
      RETURN
   20 DO 40 I=1,NN
   40 Y(I)=0.00
      DO 100 I=1,NN
      KL=MAXA(I)
      KU=MAXA(I+1)-1
      II=I+1
      CC=X(I)
      DO 100 KK=KL,KU
      II=II-1
  100 Y(II)=Y(II)+AA(KK)*CC
      IF(NN.EQ.1) RETURN
      DO 200 I=2,NN
      KL=MAXA(I)+1
      KU=MAXA(I+1)-1
      IF(KU-KL) 200,210,210
  210 II=I
      B=0.00
      DO 220 KK=KL,KU
      II=II-1
  220 B=B+AA(KK)*X(II)
      Y(I)=Y(I)+B
  200 CONTINUE
      RETURN
      END
      SUBROUTINE OTPUTP(N,NUMPAT,CL,FACV,CLX,X,XNP1)
C
C OTPUTP  POSTPROCESSES THE ENDPOINTS OF THE PATHS, UNTRANSFORMING
C AND UNSCALING THEM.
C
C ON INPUT:
C
C N  IS THE NUMBER OF EQUATIONS AND VARIABLES.
C
C NUMPAT  IS THE CURRENT PATH NUMBER.
C
C CL  IS THE ARRAY THAT DEFINES THE PROJECTIVE TRANSFORMATION.
C
C FACV  CONTAINS THE VARIABLE SCALING FACTORS.
C
C X  IS THE ENDPOINT OF THE PATH, POSSIBLY TRANSFORMED AND/OR SCALED
C   DEPENDING ON THE  POLSYS  INPUT FLAG  IFLG1.
C
C CLX  IS WORKSPACE.
C
C ON OUTPUT:
C
C N, NUMPAT, CL, AND  FACV  ARE UNCHANGED.
C
C X  IS THE UNTRANSFORMED AND UNSCALED VERSION OF X.
C
C XNP1  IS THE PROJECTIVE COORDINATE "X(N+1)".  XNP1  EQUALS UNITY IF
C   THE PROJECTIVE TRANSFORMATION IS NOT SPECIFIED.
C
C DECLARATIONS OF INPUT, WORKSPACE, AND OUTPUT:
      INTEGER N,NUMPAT
      DOUBLE PRECISION CL,FACV,CLX,X,XNP1
      DIMENSION CL(2,N+1),FACV(N),CLX(2,N),X(2,N),XNP1(2)
C
C DECLARATION OF VARIABLES
      INTEGER I,IERR,J,NP1
      DOUBLE PRECISION D1MACH,FAC,TEMP
      DIMENSION TEMP(2)
C
      NP1=N+1
C COMPUTE XNP1
      DO 1 J=1,N
        CALL MULP(CL(1,J),X(1,J),CLX(1,J))
 1    CONTINUE
      DO 2  I=1,2
        XNP1(I)=CL(I,NP1)
        DO 2  J=1,N
          XNP1(I) = XNP1(I) + CLX(I,J)
  2   CONTINUE
C UNTRANSFORM VARIABLES
      DO 10  J=1,N
        CALL DIVP(X(1,J),XNP1,TEMP,IERR)
        X(1,J)=TEMP(1)
        X(2,J)=TEMP(2)
  10  CONTINUE
C UNSCALE VARIABLES
      TEMP(1)=D1MACH(2)
      DO 30 J=1,N
        FAC=10.**FACV(J)
        DO 30 I=1,2
          IF( (ABS(X(I,J))/TEMP(1))*FAC .LT. 1.0 ) X(I,J)=FAC*X(I,J)
  30  CONTINUE
      RETURN
      END
*
      SUBROUTINE PCGDS(NN,AA,LENAA,MAXA,PP,START,WORK,IFLAG)
C
C     This subroutine solves a system of equations using the method
C        of Conjugate Gradients.
C
C     The system to be solved is in the form Bx=b, where
C
C        +--          --+        +-   -+
C        |        |     |        |  0  |   T = START(k), where
C        |   AA   | -PP |        | ... |
C    B = |        |     | ,  b = |  0  |    |START(k)|=    max    |START
C        +--------+-----+        +-----+                1<=i<=NN+1
C        |    E(k)**t   |        |  T  |
C        +--          --+        +-   -+
C
C        AA is an (NN x NN) symmetric matrix, PP is an (NN x 1) vector,
C        b is of length NN+1 and E(k)**t is the ( 1 x (NN+1) ) vector
C        consisting of all zeros, except for a '1' in its k-th position.
C        It is assumed that rank [AA,-PP]=NN and B is invertible.
C
C   The system is solved by splitting B into two matrices M and L, where
C
C       +-        -+                                +-     -+
C       |      |   |                                |       |
C       |  AA  | c |                                | -PP-c |
C   M = |      |   |  ,  L = u * [E(NN+1)**t],  u = |       | ,
C       +------+---+                                +-------+
C       |  c   | d |                                |   0   |
C       +-        -+                                +-     -+
C
C   E(NN+1) is the (NN+1) x 1 vector consisting of all zeros except for
C   a '1' in its last position, and x**t is the transpose of x.
C
C    The final solution vector, x, is given by
C
C            +-                                    -+
C            |           [sol(u)]*[E(NN+1)**t]      |
C       x =  | I  -  -----------------------------  | * sol(b)
C            |        {[(sol(u))**t]*E(NN+1)}+1.0   |
C            +-                                    -+
C
C     where sol(a)=[M**(-1)]*a.  The two systems (Mz=u, Mz=b) are solved
C     by a preconditioned conjugate gradient algorithm.
C
C
C
C     Input variables:
C
C        NN -- dimension of the matrix packed in AA.
C
C        AA -- one dimensional real array containing the leading NN x NN
C              submatrix of B in packed skyline storage form.
C
C        LENAA -- number of elements in the packed array AA.
C
C        MAXA -- integer array used for specifying information about AA.
C                Using packed skyline storage, it has length NN+2, and
C                stores the indices of the diagonal elements within AA.
C                MAXA(NN+1) = LENAA + 1 and MAXA(NN+2) = LENAA + NN + 3
C                (k as defined above) by convention.
C                (NOTE:  The value of MAXA(NN+2) is set by this
C                subroutine when the preconditioning matrix Q is
C                initialized.)
C
C                For example, using the packed storage scheme,
C                a symmetric 5 x 5 matrix of the form
C
C                +--             --+
C                |  1  3  0  0  0  |
C                |  3  2  0  7  0  |
C                |  0  0  4  6  0  |
C                |  0  7  6  5  9  |
C                |  0  0  0  9  8  |
C                +--             --+
C
C                would result in NN=5, LENAA=9, MAXA=(1,2,4,5,8,10,*),
C                and AA=(1,2,3,4,5,6,7,8,9).
C
C        PP -- vector of length NN, used for (NN+1)st column of
C              augmented matrix B .
C
C        START -- vector of length NN+1, normally the solution to the
C                 previous linear system; used to determine the index k
C
C     Output variables:
C
C        START -- solution vector x of  B x = b  (defined above).
C
C        IFLAG -- normally unchanged on output.  If the conjugate gradie
C                 iteration fails to converge in 10*(NN+1) iterations (m
C                 likely due to a singular Jacobian matrix), PCGDS retur
C                 with  IFLAG = 4 , and does not compute x.
C
C     Working storage:
C
C        WORK -- array of length 6*(NN+1) + LENAA :
C
C             WORK(1..NN+1) = temporary working storage;
C
C             WORK(NN+2..2NN+2) = intermediate solution vector z for Mz=
C                input value is used as initial estimate for z;
C
C             WORK(2NN+3..3NN+3) = intermediate solution vector z for Mz
C                input value is used as initial estimate for z;
C
C             WORK(3NN+4..4NN+4) = storage for residual vectors;
C
C             WORK(4NN+5..5NN+5) = storage for direction vectors;
C
C             WORK(5NN+6..  *  ) = storage for the preconditioning matri
C                Q, normally of length LENAA+NN+1. A storage scheme for
C                (and AA) other than the default packed skyline storage
C                scheme can be accomodated by simply extending the lengt
C                of WORK (and MAXA), and prodiving different versions of
C                the subroutines MULTDS, MFACDS, and QIMUDS.
C
C
C     Three user-defined subroutines are required:
C
C       MULTDS(y,AA,x,MAXA,NN,LENAA) -- computes y = AA x  .
C
C       MFACDS(NN,Q,LENAA,MAXA) -- computes the preconditioning matrix
C          Q based on M.  A copy of AA is placed in Q before the call;
C          after the call, it is assumed that Q contains some factorizat
C          for the preconditioning matrix Q.  If no preconditioning is
C          required, MFACDS may be a dummy subroutine.
C
C       QIMUDS(Q,f,MAXA,NN,LENAA) -- computes f := [Q**(-1)]*f for any
C          vector f, given the factorization of Q produced by subroutine
C          MFACDS.  Again, if no preconditioning is required, QIMUDS
C          may be a dummy subroutine.
C
C
C     Subroutines and functions called:
C
C        BLAS -- DAXPY, DCOPY, DDOT, DNRM2, DSCAL, IDAMAX
C        D1MACH,MULTDS,MFACDS,QIMUDS
C
C
      INTEGER IFLAG,IMAX,IND,J,K,LENAA,NN,MAXA(NN+2),NP1,NP2,N2P3,
     $   N3P4,N4P5,N5P6
      DOUBLE PRECISION AA(LENAA),AB,AU,BB,BU,DZNRM,PBNPRD,PP(NN),
     $   PUNPRD,RBNPRD,RBTOL,RNPRD,RUNPRD,RUTOL,START(NN+1),
     $   STARTK,TEMP,UNRM,WORK(5*(NN+1)+LENAA+NN+1),
     $   ZLEN,ZTOL
      LOGICAL STILLU,STILLB
C
      DOUBLE PRECISION D1MACH,DDOT,DNRM2
      INTEGER IDAMAX
C
C
C     SET UP BASES FOR VECTORS STORED IN WORK ARRAY.
C
      NP1=NN+1
      NP2=NN+2
      N2P3=(2*NN)+3
      N3P4=(3*NN)+4
      N4P5=(4*NN)+5
      N5P6=(5*NN)+6
C
C     FIND THE ELEMENT OF LARGEST MAGNITUDE IN THE INITIAL VECTOR, AND
C     RECORD ITS POSITION IN K.
C
      K=IDAMAX(NP1,START,1)
      STARTK=START(K)
C
C     INITIALIZE Q, SET VALUES OF MAXA(NN+1) AND MAXA(NN+2),
C     COMPUTE PRECONDITIONER.
C
      CALL DCOPY(LENAA,AA,1,WORK(N5P6),1)
      MAXA(NN+1)=LENAA+1
      MAXA(NN+2)=LENAA+NN+3-K
      CALL MFACDS(NN,WORK(N5P6),LENAA,MAXA)
C
C     COMPUTE ALL TOLERANCES NEEDED FOR EXIT CRITERIA.
C
      CALL DCOPY(NN,PP,1,WORK,1)
      IF (K .LT. NP1) WORK(K)=WORK(K)+1.0D0
      UNRM=DNRM2(NN,WORK,1)
C
      IMAX=10*NP1
      STILLU=.TRUE.
      STILLB=.TRUE.
      ZTOL=100.0*D1MACH(4)
      RBTOL=ZTOL*ABS(STARTK)
      RUTOL=ZTOL*UNRM
C
C     COMPUTE INITIAL RESIDUAL VECTOR FOR THE SYSTEM M z = u .
C
      CALL MULTDS(WORK(N3P4),AA,WORK(NP2),MAXA,NN,LENAA)
      WORK(N3P4+NN)=WORK(NP2+K-1)
      IND=N3P4+K-1
      IF (K .LT. NP1) WORK(IND)=WORK(IND)+WORK(NP2+NN)
      CALL DSCAL(NP1,-1.0D0,WORK(N3P4),1)
      CALL DAXPY(NN,-1.0D0,PP,1,WORK(N3P4),1)
      IF (K .LT. NP1) WORK(IND)=WORK(IND)-1.0D0
      CALL QIMUDS(WORK(N5P6),WORK(N3P4),MAXA,NN,LENAA)
C
C     COMPUTE INITIAL DIRECTION VECTOR, ALL INNER PRODUCTS FOR M z = u .
C
      CALL DCOPY(NP1,WORK(N3P4),1,WORK,1)
      CALL QIMUDS(WORK(N5P6),WORK,MAXA,NN,LENAA)
      CALL MULTDS(WORK(N4P5),AA,WORK,MAXA,NN,LENAA)
      WORK(N4P5+NN)=WORK(K)
      IF (K .LT. NP1) WORK(N4P5+K-1)=WORK(N4P5+K-1)+WORK(NP1)
C
      RUNPRD=DDOT(NP1,WORK(N3P4),1,WORK(N3P4),1)
      PUNPRD=DDOT(NP1,WORK(N4P5),1,WORK(N4P5),1)
C
      J=1
C
C     DO WHILE ((STILLU) .AND. (J .LE. IMAX))
100   IF (.NOT. ((STILLU) .AND. (J .LE. IMAX)) ) GO TO 200
C
C        IF ||RESIDUAL|| IS STILL NOT SMALL ENOUGH, CONTINUE.
         IF (SQRT(RUNPRD) .GT. RUTOL) THEN
            IF (PUNPRD .EQ. 0.0) THEN
               CALL MULTDS(WORK(N3P4),AA,WORK(NP2),MAXA,NN,LENAA)
               WORK(N3P4+NN)=WORK(NP2+K-1)
               IND=N3P4+K-1
               IF (K .LT. NP1) WORK(IND)=WORK(IND)+WORK(NP2+NN)
               CALL DSCAL(NP1,-1.0D0,WORK(N3P4),1)
               CALL DAXPY(NN,-1.0D0,PP,1,WORK(N3P4),1)
               IF (K .LT. NP1) WORK(N3P4+K-1)=WORK(N3P4+K-1)-1.0D0
               CALL QIMUDS(WORK(N5P6),WORK(N3P4),MAXA,NN,LENAA)
               CALL DCOPY(NP1,WORK(N3P4),1,WORK,1)
               CALL QIMUDS(WORK(N5P6),WORK,MAXA,NN,LENAA)
               CALL MULTDS(WORK(N4P5),AA,WORK,MAXA,NN,LENAA)
               WORK(N4P5+NN)=WORK(K)
               IND=N4P5+K-1
               IF (K .LT. NP1) WORK(IND)=WORK(IND)+WORK(NP1)
               RUNPRD=DDOT(NP1,WORK(N3P4),1,WORK(N3P4),1)
               PUNPRD=DDOT(NP1,WORK(N4P5),1,WORK(N4P5),1)
               IF (SQRT(RUNPRD) .LE. RUTOL) THEN
                  STILLU=.FALSE.
               ENDIF
            ENDIF
            IF (STILLU) THEN
C              UPDATE SOLUTION VECTOR; COMPUTE ||DELTA SOL||/||UPDATED||
               AU=RUNPRD/PUNPRD
               CALL DCOPY(NP1,WORK(NP2),1,WORK,1)
               CALL DAXPY(NP1,AU,WORK(N4P5),1,WORK(NP2),1)
               CALL DAXPY(NP1,-1.0D0,WORK(NP2),1,WORK,1)
               ZLEN=DNRM2(NP1,WORK(NP2),1)
               DZNRM=DNRM2(NP1,WORK,1)
C              IF RELATIVE CHANGE IN SOLUTIONS IS SMALL ENOUGH, EXIT.
               IF ( (DZNRM/ZLEN) .LT. ZTOL) STILLU=.FALSE.
            ENDIF
         ELSE
            STILLU=.FALSE.
         ENDIF
C
C        IF NO EXIT CRITERIA FOR Mz=u HAVE BEEN MET, CONTINUE.
         IF (STILLU) THEN
C           UPDATE RESIDUAL VECTOR; COMPUTE (RNEW,RNEW), ||RNEW|| .
            CALL MULTDS(WORK,AA,WORK(N4P5),MAXA,NN,LENAA)
            WORK(NP1)=WORK(N4P5+K-1)
            IF (K .LT. NP1) WORK(K)=WORK(K)+WORK(N4P5+NN)
            CALL QIMUDS(WORK(N5P6),WORK,MAXA,NN,LENAA)
            CALL DAXPY(NP1,-AU,WORK,1,WORK(N3P4),1)
            RNPRD=DDOT(NP1,WORK(N3P4),1,WORK(N3P4),1)
C           UPDATE DIRECTION VECTOR; COMPUTE (PNEW,PNEW).
            BU=RNPRD/RUNPRD
            RUNPRD=RNPRD
            CALL DCOPY(NP1,WORK(N3P4),1,WORK,1)
            CALL QIMUDS(WORK(N5P6),WORK,MAXA,NN,LENAA)
            CALL MULTDS(START,AA,WORK,MAXA,NN,LENAA)
            START(NP1)=WORK(K)
            IF (K .LT. NP1) START(K)=START(K)+WORK(NP1)
            CALL DAXPY(NP1,BU,WORK(N4P5),1,START,1)
            CALL DCOPY(NP1,START,1,WORK(N4P5),1)
            PUNPRD=DDOT(NP1,WORK(N4P5),1,WORK(N4P5),1)
         ENDIF
C
         J=J+1
      GO TO 100
200   CONTINUE
C     END DO
C
C     SET ERROR FLAG IF THE CONJUGATE GRADIENT ITERATION DID NOT CONVERG
C
      IF (J .GT. IMAX) THEN
         IFLAG=4
         RETURN
      ENDIF
C
C     COMPUTE INITIAL RESIDUAL VECTOR FOR THE SYSTEM M z = b .
C
      CALL MULTDS(WORK(N3P4),AA,WORK(N2P3),MAXA,NN,LENAA)
      WORK(N3P4+NN)=WORK(N2P3+K-1)
      IND=N3P4+K-1
      IF (K .LT. NP1) WORK(IND)=WORK(IND)+WORK(N2P3+NN)
      CALL DSCAL(NP1,-1.0D0,WORK(N3P4),1)
      WORK(N3P4+NN)=STARTK+WORK(N3P4+NN)
      CALL QIMUDS(WORK(N5P6),WORK(N3P4),MAXA,NN,LENAA)
C
C     COMPUTE INITIAL DIRECTION VECTOR, ALL INNER PRODUCTS FOR M z = b .
C
      CALL DCOPY(NP1,WORK(N3P4),1,WORK,1)
      CALL QIMUDS(WORK(N5P6),WORK,MAXA,NN,LENAA)
      CALL MULTDS(WORK(N4P5),AA,WORK,MAXA,NN,LENAA)
      WORK(N4P5+NN)=WORK(K)
      IF (K .LT. NP1) WORK(N4P5+K-1)=WORK(N4P5+K-1)+WORK(NP1)
C
      RBNPRD=DDOT(NP1,WORK(N3P4),1,WORK(N3P4),1)
      PBNPRD=DDOT(NP1,WORK(N4P5),1,WORK(N4P5),1)
C
      J=1
C
C     DO WHILE ( STILLB  .AND. (J .LE. IMAX) )
300   IF (.NOT. ( STILLB  .AND. (J .LE. IMAX) ) ) GO TO 400
C
C        IF ||RESIDUAL|| IS STILL NOT SMALL ENOUGH, CONTINUE.
         IF (SQRT(RBNPRD) .GT. RBTOL) THEN
            IF (PBNPRD .EQ. 0.0) THEN
               CALL MULTDS(WORK(N3P4),AA,WORK(N2P3),MAXA,NN,LENAA)
               WORK(N3P4+NN)=WORK(N2P3+K-1)
               IND=N3P4+K-1
               IF (K .LT. NP1) WORK(IND)=WORK(IND)+WORK(N2P3+NN)
               CALL DSCAL(NP1,-1.0D0,WORK(N3P4),1)
               WORK(N3P4+NN)=STARTK+WORK(N3P4+NN)
               CALL QIMUDS(WORK(N5P6),WORK(N3P4),MAXA,NN,LENAA)
               CALL DCOPY(NP1,WORK(N3P4),1,WORK,1)
               CALL QIMUDS(WORK(N5P6),WORK,MAXA,NN,LENAA)
               CALL MULTDS(WORK(N4P5),AA,WORK,MAXA,NN,LENAA)
               WORK(N4P5+NN)=WORK(K)
               IND=N4P5+K-1
               IF (K .LT. NP1) WORK(IND)=WORK(IND)+WORK(NP1)
               RBNPRD=DDOT(NP1,WORK(N3P4),1,WORK(N3P4),1)
               PBNPRD=DDOT(NP1,WORK(N4P5),1,WORK(N4P5),1)
               IF (SQRT(RBNPRD) .LE. RBTOL) THEN
                  STILLB=.FALSE.
               ENDIF
            ENDIF
            IF (STILLB) THEN
C              UPDATE SOLUTION VECTOR; COMPUTE ||DELTA SOL||/||UPDATED||
               AB=RBNPRD/PBNPRD
               CALL DCOPY(NP1,WORK(N2P3),1,WORK,1)
               CALL DAXPY(NP1,AB,WORK(N4P5),1,WORK(N2P3),1)
               CALL DAXPY(NP1,-1.0D0,WORK(N2P3),1,WORK,1)
               ZLEN=DNRM2(NP1,WORK(N2P3),1)
               DZNRM=DNRM2(NP1,WORK,1)
C              IF RELATIVE CHANGE IN SOLUTIONS IS SMALL ENOUGH, EXIT.
               IF ( (DZNRM/ZLEN) .LT. ZTOL) STILLB=.FALSE.
            ENDIF
         ELSE
            STILLB=.FALSE.
         ENDIF
C
C        IF NO EXIT CRITERIA FOR Mz=b HAVE BEEN MET, CONTINUE.
         IF (STILLB) THEN
C           UPDATE RESIDUAL VECTOR; COMPUTE (RNEW,RNEW), ||RNEW|| .
            CALL MULTDS(WORK,AA,WORK(N4P5),MAXA,NN,LENAA)
            WORK(NP1)=WORK(N4P5+K-1)
            IF (K .LT. NP1) WORK(K)=WORK(K)+WORK(N4P5+NN)
            CALL QIMUDS(WORK(N5P6),WORK,MAXA,NN,LENAA)
            CALL DAXPY(NP1,-AB,WORK,1,WORK(N3P4),1)
            RNPRD=DDOT(NP1,WORK(N3P4),1,WORK(N3P4),1)
C        UPDATE DIRECTION VECTOR; COMPUTE (PNEW,PNEW).
            BB=RNPRD/RBNPRD
            RBNPRD=RNPRD
            CALL DCOPY(NP1,WORK(N3P4),1,WORK,1)
            CALL QIMUDS(WORK(N5P6),WORK,MAXA,NN,LENAA)
            CALL MULTDS(START,AA,WORK,MAXA,NN,LENAA)
            START(NP1)=WORK(K)
            IF (K .LT. NP1) START(K)=START(K)+WORK(NP1)
            CALL DAXPY(NP1,BB,WORK(N4P5),1,START,1)
            CALL DCOPY(NP1,START,1,WORK(N4P5),1)
            PBNPRD=DDOT(NP1,WORK(N4P5),1,WORK(N4P5),1)
         ENDIF
C
         J=J+1
      GO TO 300
400   CONTINUE
C     END DO
C
C     SET ERROR FLAG IF THE CONJUGATE GRADIENT ITERATION DID NOT CONVERG
C
      IF (J .GT. IMAX) THEN
         IFLAG=4
         RETURN
      ENDIF
C
C     COMPUTE FINAL SOLUTION VECTOR X, RETURN IT IN START.
C
      TEMP=-WORK(N2P3+NN)/(1.0D0+WORK(NP2+NN))
      CALL DCOPY(NP1,WORK(N2P3),1,START,1)
      CALL DAXPY(NP1,TEMP,WORK(NP2),1,START,1)
C
      RETURN
      END
      SUBROUTINE PCGNS(NN,AA,LENAA,MAXA,PP,RHO,START,WORK,IFLAG)
C
C     This subroutine solves a system of equations using the method
C        of Conjugate Gradients.
C
C     The system to be solved is in the form Bx=b, where
C
C      +--          --+        +-    -+
C      |        |     |        |      |   T = START(k), where
C      |   AA   | -PP |        | -RHO |
C  B = |        |     | ,  b = |      |    |START(k)|=    max    |START(
C      +--------+-----+        +------+                1<=i<=NN+1
C      |    E(k)**t   |        |  T   |
C      +--          --+        +-    -+
C
C   AA is an (NN x NN) symmetric matrix, PP, RHO are (NN x 1) vectors,
C   b is of length NN+1 and E(k)**t is the ( 1 x (NN+1) ) vector
C   consisting of all zeros, except for a '1' in its k-th position.
C   It is assumed that rank [AA,-PP]=NN and B is invertible.
C
C   The system is solved by splitting B into two matrices M and L, where
C
C       +-        -+                                +-     -+
C       |      |   |                                |       |
C       |  AA  | c |                                | -PP-c |
C   M = |      |   |  ,  L = u * [E(NN+1)**t],  u = |       | ,
C       +------+---+                                +-------+
C       |  c   | d |                                |   0   |
C       +-        -+                                +-     -+
C
C   E(NN+1) is the (NN+1) x 1 vector consisting of all zeros except for
C   a '1' in its last position, and x**t is the transpose of x.
C
C    The final solution vector, x, is given by
C
C            +-                                    -+
C            |           [sol(u)]*[E(NN+1)**t]      |
C       x =  | I  -  -----------------------------  | * sol(b)
C            |        {[(sol(u))**t]*E(NN+1)}+1.0   |
C            +-                                    -+
C
C     where sol(a)=[M**(-1)]*a.  The two systems (Mz=u, Mz=b) are solved
C     by a preconditioned conjugate gradient algorithm.
C
C
C
C     Input variables:
C
C        NN -- dimension of the matrix packed in AA.
C
C        AA -- one dimensional real array containing the leading NN x NN
C              submatrix of B in packed skyline storage form.
C
C        LENAA -- number of elements in the packed array AA.
C
C        MAXA -- integer array used for specifying information about AA.
C                Using packed skyline storage, it has length NN+2, and
C                stores the indices of the diagonal elements within AA.
C                MAXA(NN+1) = LENAA + 1 and MAXA(NN+2) = LENAA + NN + 3
C                (k as defined above) by convention.
C                (NOTE:  The value of MAXA(NN+2) is set by this
C                subroutine when the preconditioning matrix Q is
C                initialized.)
C
C                For example, using the packed storage scheme,
C                a symmetric 5 x 5 matrix of the form
C
C                +--             --+
C                |  1  3  0  0  0  |
C                |  3  2  0  7  0  |
C                |  0  0  4  6  0  |
C                |  0  7  6  5  9  |
C                |  0  0  0  9  8  |
C                +--             --+
C
C                would result in NN=5, LENAA=9, MAXA=(1,2,4,5,8,10,*),
C                and AA=(1,2,3,4,5,6,7,8,9).
C
C        PP -- vector of length NN, used for (NN+1)st column of
C              augmented matrix B .
C
C        RHO -- vector of length NN, negative of top part of right hand
C               side b .
C
C        START -- vector of length NN+1, normally the solution to the
C                 previous linear system; used to determine the index k
C
C     Output variables:
C
C        START -- solution vector x of  B x = b  (defined above).
C
C        IFLAG -- normally unchanged on output.  If the conjugate gradie
C                 iteration fails to converge in 10*(NN+1) iterations (m
C                 likely due to a singular Jacobian matrix), PCGNS retur
C                 with  IFLAG = 4 , and does not compute x.
C
C     Working storage:
C
C        WORK -- array of length 6*(NN+1) + LENAA :
C
C             WORK(1..NN+1) = temporary working storage;
C
C             WORK(NN+2..2NN+2) = intermediate solution vector z for Mz=
C                input value is used as initial estimate for z;
C
C             WORK(2NN+3..3NN+3) = intermediate solution vector z for Mz
C                input value is used as initial estimate for z;
C
C             WORK(3NN+4..4NN+4) = storage for residual vectors;
C
C             WORK(4NN+5..5NN+5) = storage for direction vectors;
C
C             WORK(5NN+6..  *  ) = storage for the preconditioning matri
C                Q, normally of length LENAA+NN+1. A storage scheme for
C                (and AA) other than the default packed skyline storage
C                scheme can be accomodated by simply extending the lengt
C                of WORK (and MAXA), and prodiving different versions of
C                the subroutines MULTDS, MFACDS, and QIMUDS.
C
C
C     Three user-defined subroutines are required:
C
C       MULTDS(y,AA,x,MAXA,NN,LENAA) -- computes y = AA x  .
C
C       MFACDS(NN,Q,LENAA,MAXA) -- computes the preconditioning matrix
C          Q based on M.  A copy of AA is placed in Q before the call;
C          after the call, it is assumed that Q contains some factorizat
C          for the preconditioning matrix Q.  If no preconditioning is
C          required, MFACDS may be a dummy subroutine.
C
C       QIMUDS(Q,f,MAXA,NN,LENAA) -- computes f := [Q**(-1)]*f for any
C          vector f, given the factorization of Q produced by subroutine
C          MFACDS.  Again, if no preconditioning is required, QIMUDS
C          may be a dummy subroutine.
C
C
C     Subroutines and functions called:
C
C        BLAS -- DAXPY, DCOPY, DDOT, DNRM2, DSCAL, IDAMAX
C        D1MACH,MULTDS,MFACDS,QIMUDS
C
C
      INTEGER IFLAG,IMAX,IND,J,K,LENAA,NN,MAXA(NN+2),NP1,NP2,N2P3,
     $   N3P4,N4P5,N5P6
      DOUBLE PRECISION AA(LENAA),AB,AU,BB,BU,DZNRM,PBNPRD,PP(NN),
     $   PUNPRD,RBNPRD,RBTOL,RHO(NN),RNPRD,RUNPRD,RUTOL,
     $   START(NN+1),STARTK,TEMP,UNRM,WORK(5*(NN+1)+LENAA+NN+1),
     $   ZLEN,ZTOL
      LOGICAL STILLU,STILLB
C
      DOUBLE PRECISION D1MACH,DDOT,DNRM2
      INTEGER IDAMAX
C
C
C     SET UP BASES FOR VECTORS STORED IN WORK ARRAY.
C
      NP1=NN+1
      NP2=NN+2
      N2P3=(2*NN)+3
      N3P4=(3*NN)+4
      N4P5=(4*NN)+5
      N5P6=(5*NN)+6
C
C     FIND THE ELEMENT OF LARGEST MAGNITUDE IN THE INITIAL VECTOR, AND
C     RECORD ITS POSITION IN K.
C
      K=IDAMAX(NP1,START,1)
      STARTK=START(K)
C
C     INITIALIZE Q, SET VALUES OF MAXA(NN+1) AND MAXA(NN+2),
C     COMPUTE PRECONDITIONER.
C
      CALL DCOPY(LENAA,AA,1,WORK(N5P6),1)
      MAXA(NN+1)=LENAA+1
      MAXA(NN+2)=LENAA+NN+3-K
      CALL MFACDS(NN,WORK(N5P6),LENAA,MAXA)
C
C     COMPUTE ALL TOLERANCES NEEDED FOR EXIT CRITERIA.
C
      CALL DCOPY(NN,PP,1,WORK,1)
      IF (K .LT. NP1) WORK(K)=WORK(K)+1.0D0
      UNRM=DNRM2(NN,WORK,1)
C
      IMAX=10*NP1
      STILLU=.TRUE.
      STILLB=.TRUE.
      ZTOL=100.0*D1MACH(4)
      RBTOL=ZTOL*SQRT(STARTK**2 + DNRM2(NN,RHO,1)**2)
      RUTOL=ZTOL*UNRM
C
C     COMPUTE INITIAL RESIDUAL VECTOR FOR THE SYSTEM M z = u .
C
      CALL MULTDS(WORK(N3P4),AA,WORK(NP2),MAXA,NN,LENAA)
      WORK(N3P4+NN)=WORK(NP2+K-1)
      IND=N3P4+K-1
      IF (K .LT. NP1) WORK(IND)=WORK(IND)+WORK(NP2+NN)
      CALL DSCAL(NP1,-1.0D0,WORK(N3P4),1)
      CALL DAXPY(NN,-1.0D0,PP,1,WORK(N3P4),1)
      IF (K .LT. NP1) WORK(IND)=WORK(IND)-1.0D0
      CALL QIMUDS(WORK(N5P6),WORK(N3P4),MAXA,NN,LENAA)
C
C     COMPUTE INITIAL DIRECTION VECTOR, ALL INNER PRODUCTS FOR M z = u .
C
      CALL DCOPY(NP1,WORK(N3P4),1,WORK,1)
      CALL QIMUDS(WORK(N5P6),WORK,MAXA,NN,LENAA)
      CALL MULTDS(WORK(N4P5),AA,WORK,MAXA,NN,LENAA)
      WORK(N4P5+NN)=WORK(K)
      IF (K .LT. NP1) WORK(N4P5+K-1)=WORK(N4P5+K-1)+WORK(NP1)
C
      RUNPRD=DDOT(NP1,WORK(N3P4),1,WORK(N3P4),1)
      PUNPRD=DDOT(NP1,WORK(N4P5),1,WORK(N4P5),1)
C
      J=1
C
C     DO WHILE ((STILLU) .AND. (J .LE. IMAX))
100   IF (.NOT. ((STILLU) .AND. (J .LE. IMAX)) ) GO TO 200
C
C        IF ||RESIDUAL|| IS STILL NOT SMALL ENOUGH, CONTINUE.
         IF (SQRT(RUNPRD) .GT. RUTOL) THEN
            IF (PUNPRD .EQ. 0.0) THEN
               CALL MULTDS(WORK(N3P4),AA,WORK(NP2),MAXA,NN,LENAA)
               WORK(N3P4+NN)=WORK(NP2+K-1)
               IND=N3P4+K-1
               IF (K .LT. NP1) WORK(IND)=WORK(IND)+WORK(NP2+NN)
               CALL DSCAL(NP1,-1.0D0,WORK(N3P4),1)
               CALL DAXPY(NN,-1.0D0,PP,1,WORK(N3P4),1)
               IF (K .LT. NP1) WORK(N3P4+K-1)=WORK(N3P4+K-1)-1.0D0
               CALL QIMUDS(WORK(N5P6),WORK(N3P4),MAXA,NN,LENAA)
               CALL DCOPY(NP1,WORK(N3P4),1,WORK,1)
               CALL QIMUDS(WORK(N5P6),WORK,MAXA,NN,LENAA)
               CALL MULTDS(WORK(N4P5),AA,WORK,MAXA,NN,LENAA)
               WORK(N4P5+NN)=WORK(K)
               IND=N4P5+K-1
               IF (K .LT. NP1) WORK(IND)=WORK(IND)+WORK(NP1)
               RUNPRD=DDOT(NP1,WORK(N3P4),1,WORK(N3P4),1)
               PUNPRD=DDOT(NP1,WORK(N4P5),1,WORK(N4P5),1)
               IF (SQRT(RUNPRD) .LE. RUTOL) THEN
                  STILLU=.FALSE.
               ENDIF
            ENDIF
            IF (STILLU) THEN
C              UPDATE SOLUTION VECTOR; COMPUTE ||DELTA SOL||/||UPDATED||
               AU=RUNPRD/PUNPRD
               CALL DCOPY(NP1,WORK(NP2),1,WORK,1)
               CALL DAXPY(NP1,AU,WORK(N4P5),1,WORK(NP2),1)
               CALL DAXPY(NP1,-1.0D0,WORK(NP2),1,WORK,1)
               ZLEN=DNRM2(NP1,WORK(NP2),1)
               DZNRM=DNRM2(NP1,WORK,1)
C              IF RELATIVE CHANGE IN SOLUTIONS IS SMALL ENOUGH, EXIT.
               IF ( (DZNRM/ZLEN) .LT. ZTOL) STILLU=.FALSE.
            ENDIF
         ELSE
            STILLU=.FALSE.
         ENDIF
C
C        IF NO EXIT CRITERIA FOR Mz=u HAVE BEEN MET, CONTINUE.
         IF (STILLU) THEN
C           UPDATE RESIDUAL VECTOR; COMPUTE (RNEW,RNEW), ||RNEW|| .
            CALL MULTDS(WORK,AA,WORK(N4P5),MAXA,NN,LENAA)
            WORK(NP1)=WORK(N4P5+K-1)
            IF (K .LT. NP1) WORK(K)=WORK(K)+WORK(N4P5+NN)
            CALL QIMUDS(WORK(N5P6),WORK,MAXA,NN,LENAA)
            CALL DAXPY(NP1,-AU,WORK,1,WORK(N3P4),1)
            RNPRD=DDOT(NP1,WORK(N3P4),1,WORK(N3P4),1)
C           UPDATE DIRECTION VECTOR; COMPUTE (PNEW,PNEW).
            BU=RNPRD/RUNPRD
            RUNPRD=RNPRD
            CALL DCOPY(NP1,WORK(N3P4),1,WORK,1)
            CALL QIMUDS(WORK(N5P6),WORK,MAXA,NN,LENAA)
            CALL MULTDS(START,AA,WORK,MAXA,NN,LENAA)
            START(NP1)=WORK(K)
            IF (K .LT. NP1) START(K)=START(K)+WORK(NP1)
            CALL DAXPY(NP1,BU,WORK(N4P5),1,START,1)
            CALL DCOPY(NP1,START,1,WORK(N4P5),1)
            PUNPRD=DDOT(NP1,WORK(N4P5),1,WORK(N4P5),1)
         ENDIF
C
         J=J+1
      GO TO 100
200   CONTINUE
C     END DO
C
C     SET ERROR FLAG IF THE CONJUGATE GRADIENT ITERATION DID NOT CONVERG
C
      IF (J .GT. IMAX) THEN
         IFLAG=4
         RETURN
      ENDIF
C
C     COMPUTE INITIAL RESIDUAL VECTOR FOR THE SYSTEM M z = b .
C
      CALL MULTDS(WORK(N3P4),AA,WORK(N2P3),MAXA,NN,LENAA)
      WORK(N3P4+NN)=WORK(N2P3+K-1)
      IND=N3P4+K-1
      IF (K .LT. NP1) WORK(IND)=WORK(IND)+WORK(N2P3+NN)
      CALL DSCAL(NP1,-1.0D0,WORK(N3P4),1)
      CALL DAXPY(NN,-1.0D0,RHO,1,WORK(N3P4),1)
      WORK(N3P4+NN)=STARTK+WORK(N3P4+NN)
      CALL QIMUDS(WORK(N5P6),WORK(N3P4),MAXA,NN,LENAA)
C
C     COMPUTE INITIAL DIRECTION VECTOR, ALL INNER PRODUCTS FOR M z = b .
C
      CALL DCOPY(NP1,WORK(N3P4),1,WORK,1)
      CALL QIMUDS(WORK(N5P6),WORK,MAXA,NN,LENAA)
      CALL MULTDS(WORK(N4P5),AA,WORK,MAXA,NN,LENAA)
      WORK(N4P5+NN)=WORK(K)
      IF (K .LT. NP1) WORK(N4P5+K-1)=WORK(N4P5+K-1)+WORK(NP1)
C
      RBNPRD=DDOT(NP1,WORK(N3P4),1,WORK(N3P4),1)
      PBNPRD=DDOT(NP1,WORK(N4P5),1,WORK(N4P5),1)
C
      J=1
C
C     DO WHILE ( STILLB  .AND. (J .LE. IMAX) )
300   IF (.NOT. ( STILLB  .AND. (J .LE. IMAX) ) ) GO TO 400
C
C        IF ||RESIDUAL|| IS STILL NOT SMALL ENOUGH, CONTINUE.
         IF (SQRT(RBNPRD) .GT. RBTOL) THEN
            IF (PBNPRD .EQ. 0.0) THEN
               CALL MULTDS(WORK(N3P4),AA,WORK(N2P3),MAXA,NN,LENAA)
               WORK(N3P4+NN)=WORK(N2P3+K-1)
               IND=N3P4+K-1
               IF (K .LT. NP1) WORK(IND)=WORK(IND)+WORK(N2P3+NN)
               CALL DSCAL(NP1,-1.0D0,WORK(N3P4),1)
               CALL DAXPY(NN,-1.0D0,RHO,1,WORK(N3P4),1)
               WORK(N3P4+NN)=STARTK+WORK(N3P4+NN)
               CALL QIMUDS(WORK(N5P6),WORK(N3P4),MAXA,NN,LENAA)
               CALL DCOPY(NP1,WORK(N3P4),1,WORK,1)
               CALL QIMUDS(WORK(N5P6),WORK,MAXA,NN,LENAA)
               CALL MULTDS(WORK(N4P5),AA,WORK,MAXA,NN,LENAA)
               WORK(N4P5+NN)=WORK(K)
               IND=N4P5+K-1
               IF (K .LT. NP1) WORK(IND)=WORK(IND)+WORK(NP1)
               RBNPRD=DDOT(NP1,WORK(N3P4),1,WORK(N3P4),1)
               PBNPRD=DDOT(NP1,WORK(N4P5),1,WORK(N4P5),1)
               IF (SQRT(RBNPRD) .LE. RBTOL) THEN
                  STILLB=.FALSE.
               ENDIF
            ENDIF
            IF (STILLB) THEN
C              UPDATE SOLUTION VECTOR; COMPUTE ||DELTA SOL||/||UPDATED||
               AB=RBNPRD/PBNPRD
               CALL DCOPY(NP1,WORK(N2P3),1,WORK,1)
               CALL DAXPY(NP1,AB,WORK(N4P5),1,WORK(N2P3),1)
               CALL DAXPY(NP1,-1.0D0,WORK(N2P3),1,WORK,1)
               ZLEN=DNRM2(NP1,WORK(N2P3),1)
               DZNRM=DNRM2(NP1,WORK,1)
C              IF RELATIVE CHANGE IN SOLUTIONS IS SMALL ENOUGH, EXIT.
               IF ( (DZNRM/ZLEN) .LT. ZTOL) STILLB=.FALSE.
            ENDIF
         ELSE
            STILLB=.FALSE.
         ENDIF
C
C        IF NO EXIT CRITERIA FOR Mz=b HAVE BEEN MET, CONTINUE.
         IF (STILLB) THEN
C           UPDATE RESIDUAL VECTOR; COMPUTE (RNEW,RNEW), ||RNEW|| .
            CALL MULTDS(WORK,AA,WORK(N4P5),MAXA,NN,LENAA)
            WORK(NP1)=WORK(N4P5+K-1)
            IF (K .LT. NP1) WORK(K)=WORK(K)+WORK(N4P5+NN)
            CALL QIMUDS(WORK(N5P6),WORK,MAXA,NN,LENAA)
            CALL DAXPY(NP1,-AB,WORK,1,WORK(N3P4),1)
            RNPRD=DDOT(NP1,WORK(N3P4),1,WORK(N3P4),1)
C        UPDATE DIRECTION VECTOR; COMPUTE (PNEW,PNEW).
            BB=RNPRD/RBNPRD
            RBNPRD=RNPRD
            CALL DCOPY(NP1,WORK(N3P4),1,WORK,1)
            CALL QIMUDS(WORK(N5P6),WORK,MAXA,NN,LENAA)
            CALL MULTDS(START,AA,WORK,MAXA,NN,LENAA)
            START(NP1)=WORK(K)
            IF (K .LT. NP1) START(K)=START(K)+WORK(NP1)
            CALL DAXPY(NP1,BB,WORK(N4P5),1,START,1)
            CALL DCOPY(NP1,START,1,WORK(N4P5),1)
            PBNPRD=DDOT(NP1,WORK(N4P5),1,WORK(N4P5),1)
         ENDIF
C
         J=J+1
      GO TO 300
400   CONTINUE
C     END DO
C
C     SET ERROR FLAG IF THE CONJUGATE GRADIENT ITERATION DID NOT CONVERG
C
      IF (J .GT. IMAX) THEN
         IFLAG=4
         RETURN
      ENDIF
C
C     COMPUTE FINAL SOLUTION VECTOR X, RETURN IT IN START.
C
      TEMP=-WORK(N2P3+NN)/(1.0D0+WORK(NP2+NN))
      CALL DCOPY(NP1,WORK(N2P3),1,START,1)
      CALL DAXPY(NP1,TEMP,WORK(NP2),1,START,1)
C
      RETURN
      END
      SUBROUTINE PCGQS(NN,AA,LENAA,MAXA,PP,YP,RHO,START,WORK,IFLAG)
C
C THIS SUBROUTINE SOLVES A SYSTEM OF EQUATION USING THE METHOD OF
C CONJUGATE GRADIENTS.  THE SYSTEM TO BE SOLVED IS IN THE FORM
C
C   (AUG)*X = B,
C
C WHERE
C
C            +--          --+        +-    -+
C            |        |     |        |      |
C            |   AA   | -PP |        |      |
C      AUG = |        |     | ,  B = | -RHO |
C            +--------------+        |      |
C            |      YP      |        |      |
C            +--          --+        +-    -+
C
C
C
C THE SYSTEM IS SOLVED BY SPLITTING  AUG  INTO TWO MATRICES
C AUG = M + L,  WHERE
C
C       +-        -+                                +-     -+
C       |      |   |                                |       |
C       |  AA  | C |                                | -PP-C |
C   M = |      |   |  ,  L = U * [E(NN+1)**T],  U = |       | ,
C       +------+---+                                +-------+
C       |  C   | D |                                |   0   |
C       +-        -+                                +-     -+
C
C E(NN+1) IS THE (NN+1) X 1 VECTOR CONSISTING OF ALL ZEROS EXCEPT FOR
C A '1' IN ITS LAST POSITION.
C
C THE FINAL SOLUTION VECTOR,  X,  IS GIVEN BY
C
C            +-                                    -+
C            |           [SOL(U)]*[E(NN+1)**T]      |
C       X =  | I  -  -----------------------------  | * SOL(B)
C            |        {[(SOL(U))**T]*E(NN+1)}+1.0   |
C            +-                                    -+
C
C WHERE SOL(A)=[M**(-1)]*A.  THE TWO SYSTEMS  (MZ=U, MZ=B) ARE SOLVED
C BY A PRECONDITIONED CONJUGATE GRADIENT ALGORITHM.
C
C
C ON INPUT:
C
C NN  = THE DIMENSION OF THE MATRIX PACKED IN AA.
C
C AA(1:LENAA)  CONTAINS THE MATRIX  AA,  STORED IN PACKED SKYLINE
C    FORMAT.  LENAA  AND  MAXA  DESCRIBE THE DATA STRUCTURE.
C
C LENAA  = THE LENGTH OF THE ONE-DIMENSIONAL ARRAY  AA.
C
C MAXA(1:NN+2)  IN ITS FIRST  N+1  COMPONENTS CONTAINS THE INDICES OF
C    THE DIAGONAL ELEMENTS OF THE MATRIX STORED IN  AA.
C    MAXA(NN+2)  IS ASSIGNED THE VALUE  LENNAA + NN + 2.
C
C    AS AN EXAMPLE OF THE PACKED SKYLINE STORAGE FORMAT, CONSIDER THE
C    SYMMETRIC MATRIX
C
C
C                +--             --+
C                |  1  3  0  0  0  |
C                |  3  2  0  7  0  |
C                |  0  0  4  6  0  |
C                |  0  7  6  5  9  |
C                |  0  0  0  9  8  |
C                +--             --+
C
C    THIS WOULD RESULT IN  NN=5, LENAA=9, MAXA=(1,2,4,5,8,10,16),
C    AND  AA=(1,2,3,4,5,6,7,8,9).
C
C PP(1:NN)  = THE NEGATIVE OF THE LAST COLUMN OF  AUG.
C
C YP(1:NN+1)  = THE LAST ROW OF  AUG.
C
C RHO(1:NN+1)  = THE NEGATIVE OF THE RIGHT HAND SIDE OF THE EQUATION TO
C    BE SOLVED.
C
C WORK(1:6*(NN+1)+LENAA)  IS A WORK ARRAY DIVIDED UP AS FOLLOWS:
C
C    WORK(1:NN+1) = TEMPORARY WORKING STORAGE.
C
C    WORK(NN+2:2*NN+2) = INTERMEDIATE SOLUTION VECTOR Z FOR  MZ=U.
C       THE INPUT VALUE IS USED AS THE INITIAL ESTIMATE FOR Z.
C
C    WORK(2*NN+3:3*NN+3) = INTERMEDIATE SOLUTION VECTOR Z FOR  MZ=B.
C
C    WORK(3*NN+4:4*NN+4) = STORAGE FOR THE RESIDUAL VECTORS.
C
C    WORK(4*NN+5:5*NN+5) = STORAGE FOR THE DIRECTION VECTORS.
C
C    WORK(5*NN+6:6*NN+6+LENAA) = STORAGE FOR THE PRECONDITIONING
C       MATRIX Q.
C
C
C ON OUTPUT:
C
C NN, AA, LENAA, MAXA, PP, YP, AND RHO  ARE UNCHANGED.
C
C START(1:N+1)  CONTAINS THE SOLUTION VECTOR  X.
C
C IFLAG  IS UNCHANGED UNLESS THE CONJUGATE GRADIENT ITERATION
C    FAILS TO CONVERGE IN 10*(NN+1) ITERATIONS (MOST LIKELY DUE
C    TO A SINGULAR JACOBIAN MATRIX).  IN THIS CASE,  PCGQS  RETURNS
C    IFLAG = 4, AND DOES NOT COMPUTE  X.
C
C
C CALLS  D1MACH, DAXPY, DCOPY, DDOT, DNRM2, DSCAL, GMFADS, MULTDS,
C    SOLVDS.
C
C ***** DECLARATIONS *****
C
C     FUNCTION DECLARATIONS
C
        DOUBLE PRECISION D1MACH, DDOT, DNRM2
C
C     LOCAL VARIABLES
C
        DOUBLE PRECISION AB, AU, BB, BU, DZNRM, PBNPRD, PUNPRD,
     $     RBNPRD, RBTOL, RNPRD, RUNPRD, RUTOL, TEMP, ZLEN, ZTOL
        INTEGER DIR, IMAX, J, LENQ, NP1, Q, RES, ZB, ZU
        LOGICAL STILLU, STILLB
C
C     SCALAR ARGUMENTS
C
        INTEGER NN, LENAA, IFLAG
C
C     ARRAY DECLARATIONS
C
        DOUBLE PRECISION AA(LENAA), PP(NN), YP(NN+1), RHO(NN+1),
     $     START(NN+1), WORK(6*(NN+1)+LENAA)
        INTEGER MAXA(NN+2)
C
C ***** END OF DECLARATIONS *****
C
C ***** FIRST EXECUTABLE STATEMENT *****
C
C SET UP BASES FOR VECTORS STORED IN WORK ARRAY.
C
      NP1=NN+1
      ZU=NN+2
      ZB=(2*NN)+3
      RES=(3*NN)+4
      DIR=(4*NN)+5
      Q=(5*NN)+6
C
C INITIALIZE  PRECONDITIONING MATRIX  Q,  SET VALUES OF  MAXA(NN+1)
C AND  MAXA(NN+2),  COMPUTE PRECONDITIONER.
C
      CALL DCOPY(LENAA,AA,1,WORK(Q),1)
      CALL DCOPY(NP1,YP,1,WORK(Q+LENAA),1)
      MAXA(NN+1)=LENAA+1
      MAXA(NN+2)=LENAA+NN+2
      LENQ = MAXA(NN+2)-1
      CALL GMFADS(NP1,WORK(Q),LENQ,MAXA)
C
C COMPUTE ALL TOLERANCES NEEDED FOR EXIT CRITERIA.
C
      CALL DCOPY(NN,PP,1,WORK,1)
      WORK(NP1)=0.0
      CALL DAXPY(NP1,1.0D0,YP,1,WORK,1)
      IMAX=10*NP1
      STILLU=.TRUE.
      STILLB=.TRUE.
      ZTOL=100.0*D1MACH(4)
      RUTOL=ZTOL*DNRM2(NP1,WORK,1)
      RBTOL=ZTOL*DNRM2(NP1,RHO,1)
C
C ***** END OF INITIALIZATION *****
C
C ***** SOLVE SYSTEM  M Z = U *****
C
C COMPUTE INITIAL RESIDUAL VECTOR FOR THE SYSTEM M Z = U .
C     RES = (Q**(-1))*(U - M*Z.)
*
      CALL MULTDS(WORK(RES),AA,WORK(ZU),MAXA,NN,LENAA)
      WORK(RES+NN)= DDOT(NN,YP,1,WORK(ZU),1)
      CALL DAXPY(NP1,WORK(ZU+NN),YP,1,WORK(RES),1)
      CALL DSCAL(NP1,-1.0D0,WORK(RES),1)
      CALL DAXPY(NN,-1.0D0,PP,1,WORK(RES),1)
      CALL DAXPY(NN,-1.0D0,YP,1,WORK(RES),1)
      CALL SOLVDS(NP1,WORK(Q),LENQ,MAXA,WORK(RES))
C
C COMPUTE INITIAL DIRECTION VECTOR.
C     DIR = (A**T)*(Q**(-T))*RES.
C
      CALL DCOPY(NP1,WORK(RES),1,WORK,1)
      CALL SOLVDS(NP1,WORK(Q),LENQ,MAXA,WORK)
      CALL MULTDS(WORK(DIR),AA,WORK,MAXA,NN,LENAA)
      WORK(DIR+NN)=DDOT(NN,YP,1,WORK,1)
      CALL DAXPY(NP1,WORK(NP1),YP,1,WORK(DIR),1)
C
C COMPUTE INITIAL INNER PRODUCTS.
C
      RUNPRD=DDOT(NP1,WORK(RES),1,WORK(RES),1)
      PUNPRD=DDOT(NP1,WORK(DIR),1,WORK(DIR),1)
C
C REPEAT UNTIL CONVERGENCE OR TOO MANY ITERATIONS.
C
      J=1
C
C     DO WHILE ((STILLU) .AND. (J .LE. IMAX))
100   IF (.NOT. ((STILLU) .AND. (J .LE. IMAX)) ) GO TO 200
C
C        IF ||RESIDUAL|| IS STILL NOT SMALL ENOUGH, CONTINUE.
C
         IF (SQRT(RUNPRD) .GT. RUTOL) THEN
C
C           IF DIRECTION VECTOR IS ZERO, THEN RE-COMPUTE RESIDUAL,
C           DIRECTION VECTOR, AND INNER PRODUCTS FROM SCRATCH
C           (RATHER THAN FROM UPDATES OF PREVIOUS VALUES).
C
            IF (PUNPRD .EQ. 0.0) THEN
C
C              COMPUTE RESIDUAL.
C
               CALL MULTDS(WORK(RES),AA,WORK(ZU),MAXA,NN,LENAA)
               WORK(RES+NN)= DDOT(NN,YP,1,WORK(ZU),1)
               CALL DAXPY(NP1,WORK(ZU+NN),YP,1,WORK(RES),1)
               CALL DSCAL(NP1,-1.0D0,WORK(RES),1)
               CALL DAXPY(NN,-1.0D0,PP,1,WORK(RES),1)
               CALL DAXPY(NN,-1.0D0,YP,1,WORK(RES),1)
               CALL SOLVDS(NP1,WORK(Q),LENQ,MAXA,WORK(RES))
C
C              COMPUTE DIRECTION VECTOR.
C
               CALL DCOPY(NP1,WORK(RES),1,WORK,1)
               CALL SOLVDS(NP1,WORK(Q),LENQ,MAXA,WORK)
               CALL MULTDS(WORK(DIR),AA,WORK,MAXA,NN,LENAA)
               WORK(DIR+NN)=DDOT(NN,YP,1,WORK,1)
               CALL DAXPY(NP1,WORK(NP1),YP,1,WORK(DIR),1)
C
C              COMPUTE INNER PRODUCTS
C
               RUNPRD=DDOT(NP1,WORK(RES),1,WORK(RES),1)
               PUNPRD=DDOT(NP1,WORK(DIR),1,WORK(DIR),1)
C
C              CHECK FOR CONVERGENCE.
C
               IF (SQRT(RUNPRD) .LE. RUTOL) THEN
                  STILLU=.FALSE.
               ENDIF
            ENDIF
            IF (STILLU) THEN
C
C              UPDATE SOLUTION VECTOR.
C                Z = Z + AU*DIR, WHERE AU= RUNPRD/PUNPRD.
C
               AU=RUNPRD/PUNPRD
               CALL DAXPY(NP1,AU,WORK(DIR),1,WORK(ZU),1)
C
C              COMPUTE RELATIVE CHANGE IN THE SOLUTION.
C
               DZNRM=AU*SQRT(PUNPRD)
               ZLEN=DNRM2(NP1,WORK(ZU),1)
C
C              IF RELATIVE CHANGE IN SOLUTIONS IS SMALL ENOUGH, EXIT.
C
               IF ( (DZNRM/ZLEN) .LT. ZTOL) STILLU=.FALSE.
            ENDIF
         ELSE
            STILLU=.FALSE.
         ENDIF
C
C        IF NO EXIT CRITERIA FOR  MZ=U  HAVE BEEN MET, UPDATE RESIDUAL,
C          DIRECTION VECTORS, AND INNER PRODUCTS FOR NEXT ITERATION.
C
         IF (STILLU) THEN
C
C           UPDATE RESIDUAL VECTOR; COMPUTE <RES,RES>.
C             RES = RES - AU*(Q**(-1))*M*DIR.
C
            CALL MULTDS(WORK,AA,WORK(DIR),MAXA,NN,LENAA)
            WORK(NP1)=DDOT(NN,YP,1,WORK(DIR),1)
            CALL DAXPY(NP1,WORK(DIR+NN),YP,1,WORK,1)
            CALL SOLVDS(NP1,WORK(Q),LENQ,MAXA,WORK)
            CALL DAXPY(NP1,-AU,WORK,1,WORK(RES),1)
            RNPRD=DDOT(NP1,WORK(RES),1,WORK(RES),1)
C
C           UPDATE DIRECTION VECTOR; COMPUTE <DIR,DIR>.
C             DIR = (M**T)*(Q**(-T))*RES + BU*DIR,
C             WHERE  BU = RNPRD/RUNPRD. (NOTE: START IS USED AS
C             A WORK ARRAY HERE).
C
            BU=RNPRD/RUNPRD
            RUNPRD=RNPRD
            CALL DCOPY(NP1,WORK(RES),1,WORK,1)
            CALL SOLVDS(NP1,WORK(Q),LENQ,MAXA,WORK)
            CALL MULTDS(START,AA,WORK,MAXA,NN,LENAA)
            START(NP1)=DDOT(NN,YP,1,WORK,1)
            CALL DAXPY(NP1,WORK(NP1),YP,1,START,1)
            CALL DAXPY(NP1,BU,WORK(DIR),1,START,1)
            CALL DCOPY(NP1,START,1,WORK(DIR),1)
            PUNPRD=DDOT(NP1,WORK(DIR),1,WORK(DIR),1)
         ENDIF
C
         J=J+1
      GO TO 100
200   CONTINUE
C     END DO
C
C SET ERROR FLAG IF THE CONJUGATE GRADIENT ITERATION DID NOT CONVERGE.
C
      IF (J .GT. IMAX) THEN
         IFLAG=4
         RETURN
      ENDIF
C
C ***** END OF M Z = U SYSTEM *****
C
C ***** SOLVE SYSTEM M Z = B *****
C
C
C COMPUTE INITIAL RESIDUAL VECTOR FOR THE SYSTEM M Z = B .
C
      CALL MULTDS(WORK(RES),AA,WORK(ZB),MAXA,NN,LENAA)
      WORK(RES+NN)=DDOT(NN,YP,1,WORK(ZB),1)
      CALL DAXPY(NP1,WORK(ZB+NN),YP,1,WORK(RES),1)
      CALL DSCAL(NP1,-1.0D0,WORK(RES),1)
      CALL DAXPY(NP1,-1.0D0,RHO,1,WORK(RES),1)
      CALL SOLVDS(NP1,WORK(Q),LENQ,MAXA,WORK(RES))
C
C COMPUTE INITIAL DIRECTION VECTOR.
C
      CALL DCOPY(NP1,WORK(RES),1,WORK,1)
      CALL SOLVDS(NP1,WORK(Q),LENQ,MAXA,WORK)
      CALL MULTDS(WORK(DIR),AA,WORK,MAXA,NN,LENAA)
      WORK(DIR+NN)=DDOT(NN,YP,1,WORK,1)
      CALL DAXPY(NP1,WORK(NP1),YP,1,WORK(DIR),1)
C
C COMPUTE INITIAL INNER PRODUCTS.
C
      RBNPRD=DDOT(NP1,WORK(RES),1,WORK(RES),1)
      PBNPRD=DDOT(NP1,WORK(DIR),1,WORK(DIR),1)
C
C REPEAT UNTIL CONVERGENCE, OR TOO MANY ITERATIONS.
C
      J=1
C
C     DO WHILE ( STILLB  .AND. (J .LE. IMAX) )
300   IF (.NOT. ( STILLB  .AND. (J .LE. IMAX) ) ) GO TO 400
C
C        IF ||RESIDUAL|| IS STILL NOT SMALL ENOUGH, CONTINUE.
C
         IF (SQRT(RBNPRD) .GT. RBTOL) THEN
C
C           IF DIRECTION VECTOR IS ZERO, RE-COMPUTE RESIDUAL,
C             DIRECTION VECTOR, AND INNER PRODUCTS FROM SCRATCH.
C
            IF (PBNPRD .EQ. 0.0) THEN
C
C              COMPUTE RESIDUAL.
C
               CALL MULTDS(WORK(RES),AA,WORK(ZB),MAXA,NN,LENAA)
               WORK(RES+NN)=DDOT(NN,YP,1,WORK(ZB),1)
               CALL DAXPY(NP1,WORK(ZB+NN),YP,1,WORK(RES),1)
               CALL DSCAL(NP1,-1.0D0,WORK(RES),1)
               CALL DAXPY(NP1,-1.0D0,RHO,1,WORK(RES),1)
               CALL SOLVDS(NP1,WORK(Q),LENQ,MAXA,WORK(RES))
C
C              COMPUTE DIRECTION VECTOR.
C
               CALL DCOPY(NP1,WORK(RES),1,WORK,1)
               CALL SOLVDS(NP1,WORK(Q),LENQ,MAXA,WORK)
               CALL MULTDS(WORK(DIR),AA,WORK,MAXA,NN,LENAA)
               WORK(DIR+NN)=DDOT(NN,YP,1,WORK,1)
               CALL DAXPY(NP1,WORK(NP1),YP,1,WORK(DIR),1)
C
C              COMPUTE INNER PRODUCTS.
C
               RBNPRD=DDOT(NP1,WORK(RES),1,WORK(RES),1)
               PBNPRD=DDOT(NP1,WORK(DIR),1,WORK(DIR),1)
C
C              CHECK FOR CONVERGENCE.
C
               IF (SQRT(RBNPRD) .LE. RBTOL) THEN
                  STILLB=.FALSE.
               ENDIF
            ENDIF
            IF (STILLB) THEN
C
C              UPDATE SOLUTION VECTOR.
C                Z = Z + AB*DIR, WHERE AB=RBNPRD/PBNPRD.
C
               AB=RBNPRD/PBNPRD
               CALL DAXPY(NP1,AB,WORK(DIR),1,WORK(ZB),1)
C
C              COMPUTE RELATIVE CHANGE IN SOLUTIONS.
C
               DZNRM=AB*SQRT(PBNPRD)
               ZLEN=DNRM2(NP1,WORK(ZB),1)
C
C              IF RELATIVE CHANGE IN SOLUTIONS IS SMALL ENOUGH, EXIT.
C
               IF ( (DZNRM/ZLEN) .LT. ZTOL) STILLB=.FALSE.
            ENDIF
         ELSE
            STILLB=.FALSE.
         ENDIF
C
C        IF NO EXIT CRITERIA FOR  MZ=B  HAVE BEEN MET, UPDATE RESIDUAL,
C          DIRECTION VECTORS, AND INNER PRODUCTS.
C
         IF (STILLB) THEN
C
C           UPDATE RESIDUAL VECTOR; COMPUTE <RES,RES>.
C             RES = RES - AB*(Q**(-1))*M*DIR.
C
            CALL MULTDS(WORK,AA,WORK(DIR),MAXA,NN,LENAA)
            WORK(NP1)=DDOT(NN,YP,1,WORK(DIR),1)
            CALL DAXPY(NP1,WORK(DIR+NN),YP,1,WORK,1)
            CALL SOLVDS(NP1,WORK(Q),LENQ,MAXA,WORK)
            CALL DAXPY(NP1,-AB,WORK,1,WORK(RES),1)
            RNPRD=DDOT(NP1,WORK(RES),1,WORK(RES),1)
C
C           UPDATE DIRECTION VECTOR; COMPUTE <DIR,DIR>.
C             DIR = (M**T)*(Q**(-T))*RES + BB*DIR,
C             WHERE BB=RNPRD/RBNPRD.
C           (NOTE:  START IS USED AS A WORK ARRAY HERE).
C
            BB=RNPRD/RBNPRD
            RBNPRD=RNPRD
            CALL DCOPY(NP1,WORK(RES),1,WORK,1)
            CALL SOLVDS(NP1,WORK(Q),LENQ,MAXA,WORK)
            CALL MULTDS(START,AA,WORK,MAXA,NN,LENAA)
            START(NP1)=DDOT(NN,YP,1,WORK,1)
            CALL DAXPY(NP1,WORK(NP1),YP,1,START,1)
            CALL DAXPY(NP1,BB,WORK(DIR),1,START,1)
            CALL DCOPY(NP1,START,1,WORK(DIR),1)
            PBNPRD=DDOT(NP1,WORK(DIR),1,WORK(DIR),1)
         ENDIF
C
         J=J+1
      GO TO 300
400   CONTINUE
C     END DO
C
C SET ERROR FLAG IF THE CONJUGATE GRADIENT ITERATION DID NOT CONVERGE.
C
      IF (J .GT. IMAX) THEN
         IFLAG=4
         RETURN
      ENDIF
C
C ***** END OF  M Z = B  SYSTEM *****
C
C COMPUTE FINAL SOLUTION VECTOR  X,  AND RETURN IT IN START.
C
      TEMP=-WORK(ZB+NN)/(1.0D0+WORK(ZU+NN))
      CALL DCOPY(NP1,WORK(ZB),1,START,1)
      CALL DAXPY(NP1,TEMP,WORK(ZU),1,START,1)
C
      RETURN
      END
      SUBROUTINE POLSYS(N,NUMT,COEF,KDEG,IFLG1,IFLG2,EPSBIG,EPSSML,
     $     SSPAR,NUMRR,NN,MMAXT,TTOTDG,LENWK,LENIWK,
     $     LAMBDA,ROOTS,ARCLEN,NFE,WK,IWK)
C
C POLSYS FINDS ALL (COMPLEX) SOLUTIONS TO A SYSTEM
C F(X)=0 OF N POLYNOMIAL EQUATIONS IN N UNKNOWNS
C WITH REAL COEFFICIENTS. IF IFLG=10 OR IFLG=11, POLSYS
C RETURNS THE SOLUTIONS AT INFINITY ALSO.
C
C THE SYSTEM F(X)=0 IS DESCRIBED VIA THE COEFFICENTS,
C "COEF", AND THE PARAMETERS "N, NUMT, KDEG", AS FOLLOWS.
C
C
C       NUMT(J)
C
C F(J) = SUM  COEF(J,K) * X(1)**KDEG(J,1,K)...X(N)**KDEG(J,N,K)
C
C        K=1
C
C FOR J=1, ..., N.
C
C
C POLSYS HAS TWO MAIN RUN OPTIONS:  AUTOMATIC SCALING AND
C THE PROJECTIVE TRANSFORMATION.  THESE ARE EVOKED VIA THE
C FLAG "IFLG1", AS DESCRIBED BELOW.  THE OTHER INPUT
C PARAMETERS ARE THE SAME WHETHER ONE OR BOTH OF THESE OPTIONS
C ARE SPECIFIED, AND THE OUTPUT IS ALWAYS RETURNED UNSCALED
C AND UNTRANSFORMED.
C
C IF AUTOMATIC SCALING IS SPECIFIED, THEN THE INPUT
C COEFFICIENTS ARE MODIFIED BY SUBROUTINE  SCLGNP . THE PROBLEM
C IS SOLVED WITH THE SCALED COEFFICIENTS AND SCALED VARIABLES.
C THE COEFFICIENTS ARE RETURNED SCALED.
C
C IF THE PROJECTIVE TRANSFORMATION IS SPECIFIED, THEN
C ESSENTIALLY THE SYSTEM IS REFORMULATED IN HOMOGENEOUS
C COORDINATES, Z(1), ..., Z(N+1), AND SOLVED IN COMPLEX
C PROJECTIVE SPACE.  THE RESULTING SOLUTIONS ARE
C UNTRANSFORMED VIA
C
C X(J) = Z(J)/Z(N+1)   J=1, ..., N.
C
C ON RETURN,
C
C ROOTS(1,J,M) = REAL PART OF X(J) FOR THE M-TH PATH,
C
C ROOTS(2,J,M) = IMAGINARY PART OF X(J) FOR THE M-TH PATH,
C
C FOR J=1, ..., N, AND
C
C ROOTS(1,N+1,M) = REAL PART OF Z(N+1) FOR THE M-TH PATH,
C
C ROOTS(2,N+1,M) = IMAGINARY PART OF Z(N+1) FOR THE M-TH PATH.
C
C IF ROOTS(*,N+1,M) IS SMALL, THEN THE ASSOCIATED SOLUTION
C SHOULD BE REGARDED AS BEING "NEAR INFINITY".  NOTE THAT,
C WHEN THE PROJECTIVE TRANSFORMATION HAS BEEN SPECIFIED, THE
C ROOTS VALUES HAVE BEEN UNTRANSFORMED -- THAT IS, DIVIDED
C THROUGH BY Z(N+1) -- UNLESS SUCH DIVISION WOULD HAVE CAUSED
C OVERFLOW.  IN THIS LATTER CASE, THE AFFECTED COMPONENTS OF
C ROOTS ARE SET TO THE LARGEST FLOATING POINT NUMBER (MACHINE
C INFINITY).
C
C THE CODE CAN BE MODIFIED EASILY TO SOLVE SYSTEMS WITH COMPLEX
C COEFFICIENTS,  COEF .  ONLY THE SUBROUTINES  INITP  AND  FFUNP
C NEED BE CHANGED.
C
C THE FORTRAN COMPLEX DECLARATION IS NOT USED IN POLSYS.
C COMPLEX VARIABLES ARE REPRESENTED BY REAL ARRAYS WITH FIRST
C INDEX DIMENSIONED 2 AND COMPLEX OPERATIONS ARE EVOKED BY
C SUBROUTINE CALLS.
C
C THE TOTAL NUMBER OF PATHS THAT WILL THE TRACKED (IF
C IFLG2(M)=-2 FOR ALL M) IS EQUAL TO THE "TOTAL DEGREE" OF THE
C SYSTEM, TOTDG.   TOTDG IS EQUAL TO THE PRODUCTS OF THE
C DEGREES OF ALL THE EQUATIONS IN THE SYSTEM.  THE DEGREE OF
C AN EQUATION IS THE MAXIMUM OF THE DEGREES OF ITS TERMS.  THE
C DEGREE OF A TERM IS THE SUM OF THE DEGREES OF THE VARIABLES.
C THUS, TOTDG = IDEG(1) * ... * IDEG(N) WHERE IDEG(J) =
C MAX {JDEG(J,K) | K=1,...,NUMT(J)} WHERE JDEG(J,K) = KDEG(J,1,K) +
C ... + KDEG(J,N,K).
C
C IFLG1  DETERMINES WHETHER THE SYSTEM IS TO BE AUTOMATICALLY
C SCALED BY  POLSYS  AND WHETHER THE PROJECTIVE TRANSFORMATION
C OF THE SYSTEM IS TO BE AUTOMATICALLY EVOKED BY POLSYS.  SEE
C "ON INPUT" BELOW.
C
C IFLG2, EPSBIG, EPSSML, AND  SSPAR  TELL THE PATH TRACKER
C POLYNF  WHICH PATHS TO TRACK AND SET PARAMETERS FOR THE PATH
C TRACKER.
C
C NUMRR  TELLS  POLSYS  HOW MANY MULTIPLES OF 1000 STEPS TO TRY
C BEFORE ABANDONING A PATH.
C
C NN, MMAXT, TTOTDG, LENWK, LENIWK  GIVE THE DIMENSIONS OF ARRAYS.
C
C THE OUTPUT CONSISTS OF  IFLG1, AND OF  LAMBDA, ROOTS, ARCLEN, AND
C NFE  FOR EACH PATH.  IFLG1  RETURNS INPUT DATA ERROR INFORMATION.
C ROOTS  GIVES THE SOLUTIONS THEMSELVES, WHILE  LAMBDA, ARCLEN,
C AND  NFE  GIVE INFORMATION ABOUT THE ASSOCIATED PATHS.
C
C THE FOLLOWING SUBROUTINES ARE USED DIRECTLY OR INDIRECTLY BY
C POLSYS:
C         SPECIAL FOR POLSYS:
C           POLYP , INITP , STRPTP ,
C           OTPUTP , RHO , RHOJAC ,
C           HFUNP , HFUN1P , GFUNP , FFUNP ,
C           MULP , POWP , DIVP,
C           SCLGNP.
C         FROM THE GENERAL HOMPACK ROUTINES:
C           POLYNF , STEPNF , TANGNF , ROOTNF , ROOT ,
C           QRFAQF, QRSLQF , D1MACH , DDOT , DNRM2.
C
C ON INPUT:
C
C N  IS THE NUMBER OF EQUATIONS AND VARIABLES.
C
C NUMT(1:NN)  IS AN INTEGER ARRAY.  NUMT(J)  IS THE NUMBER OF TERMS
C   IN THE JTH EQUATION FOR J=1 TO N.
C
C COEF(1:NN,1:MMAXT)  IS A REAL ARRAY.  COEF(J,K)  IS
C   THE K-TH COEFFICIENT OF THE J-TH EQUATION FOR J=1 TO N,
C   K=1 TO NUMT(J).
C
C KDEG(1:NN,1:NN+1,1:MMAXT)  IS AN INTEGER ARRAY.
C   KDEG(J,L,K)  IS THE DEGREE OF THE L-TH VARIABLE IN THE K-TH
C   TERM OF THE J-TH EQUATION FOR  J=1 TO N, L=1 TO N, K=1 TO NUMT(J).
C
C IFLG1 =
C   00  IF THE PROBLEM IS TO BE SOLVED WITHOUT
C       CALLING POLSYS' SCALING ROUTINE, SCLGNP, AND
C       WITHOUT USING THE PROJECTIVE TRANSFORMTION.
C
C   01  IF SCALING BUT NO PROJECTIVE TRANSFORMATION IS TO BE USED.
C
C   10  IF NO SCALING BUT PROJECTIVE TRANSFORMATION IS TO BE USED.
C
C   11  IF BOTH SCALING AND PROJECTIVE TRANSFORMATION ARE TO BE USED.
C
C IFLG2(1:TTOTDG)  IS AN INTEGER ARRAY.  IF IFLG2(M) = -2, THEN THE
C   M-TH PATH IS TRACKED.  OTHERWISE THE M-TH PATH IS SKIPPED.
C   THUS, TO FIND ALL SOLUTIONS SET IFLG2(M) = -2 FOR M=1,...,TOTDG.
C   SELECTED PATHS CAN BE RERUN BY SETTING IFLG2(M)=-2 FOR
C   THE PATHS TO BE RERUN AND IFLG(M).NE.-2 FOR THE OTHERS.
C
C EPSBIG  IS THE LOCAL ERROR TOLERANCE ALLOWED THE PATH TRACKER ALONG
C   THE PATH.  ARCRE AND ARCAE (IN  POLYNF ) ARE SET TO  EPSBIG.
C
C EPSSML  IS THE ACCURACY DESIRED FOR THE FINAL SOLUTION.  ANSRE AND
C   ANSAE (IN  POLYNF ) ARE SET TO  EPSSML.
C
C SSPAR(1:8) = (LIDEAL, RIDEAL, DIDEAL, HMIN, HMAX, BMIN, BMAX, P)  IS
C    A VECTOR OF PARAMETERS USED FOR THE OPTIMAL STEP SIZE ESTIMATION.
C    IF  SSPAR(J) .LE. 0.0  ON INPUT, IT IS RESET TO A DEFAULT VALUE
C    BY  POLYNF .  OTHERWISE THE INPUT VALUE OF  SSPAR(J)  IS USED.
C    SEE THE COMMENTS IN  POLYNF  AND IN  STEPNF  FOR MORE INFORMATION
C    ABOUT THESE CONSTANTS.
C
C NUMRR  IS THE NUMBER OF MULTIPLES OF 1000 STEPS THAT WILL BE TRIED
C   BEFORE ABANDONING A PATH.
C
C NN  IS THE DECLARED DIMENSION OF  NUMT  AND OF THE
C   FIRST INDEX OF  COEF  AND  KDEG .  THE SECOND INDEX OF
C   KDEG  AND  ROOTS  IS DIMENSIONED NN+1.  NN  MUST
C   BE GREATER THAN OR EQUAL TO N.
C
C MMAXT  IS THE DECLARED DIMENSION OF THE SECOND INDEX OF
C   COEF  AND THE THIRD INDEX OF  KDEG.  MMAXT  MUST BE
C   GREATER THAN OR EQUAL TO THE MAXIMUM NUMBER OF
C   TERMS IN EACH EQUATION.  IN OTHER WORDS,
C   MMAXT .GE. MAX {NUMT(J) | J=1, ..., N} .
C
C TTOTDG  IS THE DECLARED DIMENSION OF  IFLG2 , LAMBDA , ARCLEN ,
C   NFE , AND OF THE THIRD INDEX OF  ROOTS.  TTOTDG
C   MUST BE GREATER THAN OR EQUAL TO TOTDG, THE TOTAL
C   DEGREE OF THE SYSTEM.
C
C LENWK  IS THE DIMENSION OF THE WORKSPACE  WK .  LENWK  MUST
C   BE GREATER THAN OR EQUAL TO
C     21 + 61*N + 10*N**2 + 7*N*MMAXT + 4*N**2*MMAXT.
C
C LENIWK  IS THE DIMENSION OF THE WORKSPACE  IWK .  LENIWK  MUST BE
C   GREATER THAN OR EQUAL TO  43 + 7*N + N*(N+1)*MMAXT.
C
C
C ON OUTPUT:
C
C N, NUMT, COEF, KDEG, NN, MMAXT, TTOTDG, LENWK, AND  LENIWK
C   ARE UNCHANGED.
C
C IFLG1=
C   -1  IF  NN  IS TOO SMALL.
C   -2  IF  MMAXT  IS TOO SMALL.
C   -3  IF  TTOTDG  IS TOO SMALL.
C   -4  IF  LENWK  IS TOO SMALL.
C   -5  IF  LENIWK  IS TOO SMALL.
C   -6  IF  IFLG1  ON INPUT IS NOT 00 OR 01 OR 10 OR 11.
C   UNCHANGED OTHERWISE.
C
C IFLG2(1:TOTDG)  GIVES INFORMATION ABOUT HOW THE M-TH PATH TERMINATED:
C IFLG2(M) =
C   1   NORMAL RETURN.
C
C   2   SPECIFIED ERROR TOLERANCE CANNOT BE MET.  INCREASE  EPSBIG
C       AND  EPSSML  AND RERUN.
C
C   3   MAXIMUM NUMBER OF STEPS EXCEEDED.  TO TRACK THE PATH FURTHER,
C       INCREASE  NUMRR  AND RERUN THE PATH.  HOWEVER, THE PATH MAY
C       BE DIVERGING, IF THE  LAMBDA  VALUE IS NEAR 1 AND THE  ROOTS
C       VALUES ARE LARGE.
C
C   4   JACOBIAN MATRIX DOES NOT HAVE FULL RANK.  THE ALGORITHM
C       HAS FAILED (THE ZERO CURVE OF THE HOMOTOPY MAP CANNOT BE
C       FOLLOWED ANY FURTHER).
C
C   5   THE TRACKING ALGORITHM HAS LOST THE ZERO CURVE OF THE
C       HOMOTOPY MAP AND IS NOT MAKING PROGRESS.  THE ERROR TOLERANCES
C       EPSBIG  AND  EPSSML  WERE TOO LENIENT.  THE PROBLEM SHOULD BE
C       RESTARTED WITH SMALLER ERROR TOLERANCES.
C
C   6   THE NORMAL FLOW NEWTON ITERATION IN  STEPNF  OR  ROOTNF
C       FAILED TO CONVERGE.  THE ERROR TOLERANCE  EPSBIG  MAY BE TOO
C       STRINGENT.
C
C   7   ILLEGAL INPUT PARAMETERS, A FATAL ERROR.
C
C LAMBDA(M)  IS THE FINAL LAMBDA VALUE FOR THE M-TH PATH, M = 1, ...,
C   TOTDG, WHERE LAMBDA IS THE CONTINUATION PARAMETER.
C
C ROOTS(1,J,M), ROOTS(2,J,M)  ARE THE REAL AND IMAGINARY PARTS
C   OF THE JTH VARIABLE RESPECTIVELY, FOR J = 1,...,N, FOR
C   THE M-TH PATH, FOR M = 1,...,TOTDG.  IF  IFLG1 = 10 OR 11, THEN
C   ROOTS(1,N+1,M)  AND  ROOTS(2,N+1,M)  ARE THE REAL AND
C   IMAGINARY PARTS RESPECTIVELY OF THE PROJECTIVE
C   COORDINATE OF THE SOLUTION.
C
C ARCLEN(M)  IS THE ARC LENGTH OF THE M-TH PATH FOR M = 1, ..., TOTDG.
C
C NFE(M)  IS THE NUMBER OF JACOBIAN MATRIX EVALUATIONS REQUIRED TO
C   TRACK THE M-TH PATH FOR M =1, ..., TOTDG.
C
C ----------------------------------------------------------------------
C TYPE DECLARATIONS FOR INPUT AND OUTPUT
      INTEGER N,NUMT,KDEG,IFLG1,IFLG2,NUMRR,NN,MMAXT,
     $  TTOTDG,LENWK,LENIWK,NFE,IWK
      DOUBLE PRECISION COEF,EPSBIG,EPSSML,SSPAR,LAMBDA,ROOTS,
     $  ARCLEN,WK
C
C ARRAY DECLARATIONS FOR INPUT AND OUTPUT
      DIMENSION NUMT(NN),KDEG(NN,NN+1,MMAXT),IFLG2(TTOTDG),
     $  NFE(TTOTDG),IWK(LENIWK)
      DIMENSION COEF(NN,MMAXT),SSPAR(8),LAMBDA(TTOTDG),
     $  ROOTS(2,NN+1,TTOTDG), ARCLEN(TTOTDG),WK(LENWK)
C
C TYPE DECLARATIONS FOR VARIABLES
      INTEGER I,IDEG,IIDEG,IWKOFF,J,K,L,LENIWW,LENWKK,LIWK,LWK,
     $  MAXT,N2,TOTDG,WKOFF
C
C ARRAY DECLARATIONS FOR VARIABLES
      DIMENSION LWK(19),LIWK(4),WKOFF(19),IWKOFF(4)
C
C CHECK THAT BASIC DIMENSIONAL PARAMETERS ARE BIG ENOUGH
C
      IF(NN.LT.N) THEN
        IFLG1=-1
        RETURN
      END IF
      MAXT=0
      DO 50 J=1,N
        IF(MAXT.LT.NUMT(J))MAXT=NUMT(J)
 50   CONTINUE
      IF(MMAXT.LT.MAXT) THEN
        IFLG1=-2
        RETURN
      END IF
      TOTDG=1
      DO 80 J=1,N
         IDEG=0
         DO 70 K=1,NUMT(J)
             IIDEG=0
             DO 60 L=1,N
                IIDEG=IIDEG+KDEG(J,L,K)
 60          CONTINUE
             IF(IIDEG.GT.IDEG)IDEG=IIDEG
 70      CONTINUE
         TOTDG=TOTDG*IDEG
 80   CONTINUE
      IF(TTOTDG.LT.TOTDG) THEN
        IFLG1=-3
        RETURN
      END IF
      LENWKK = 21 + 61*N + 10*N**2 + 7*N*MMAXT + 4*N**2*MMAXT
      IF(LENWK.LT.LENWKK) THEN
        IFLG1=-4
        RETURN
      END IF
      LENIWW = 43 +  7*N + N*(N+1)*MMAXT
      IF(LENIWK.LT.LENIWW) THEN
        IFLG1=-5
        RETURN
      END IF
      IF(IFLG1.NE.0.AND.IFLG1.NE.1.AND.IFLG1.NE.10.AND.IFLG1.NE.11) THEN
        IFLG1=-6
        RETURN
      END IF
C
C VARIABLES THAT ARE PASSED IN ARRAY WK: (LENGTHS ARE IN THE
C INTEGER ARRAY LWK.)
C
C    VARIABLE NAME       LENGTH
C
C    1   PDG               N2
C    2   QDG               N2
C    3   R                 N2
C    4   FACV              N
C    5   CL                2*(N+1)
C    6   Y                 N2+1
C    7   YP                N2+1
C    8   YOLD              N2+1
C    9   YPOLD             N2+1
C   10   QR                N2*(N2+2)
C   11   ALPHA             N2
C   12   TZ                N2+1
C   13   W                 N2+1
C   14   WP                N2+1
C   15   Z0                N2+1
C   16   Z1                N2+1
C   17   SSPAR             8
C   18   PAR               2 + 28*N + 6*N**2 + 7*N*MMAXT + 4*N**2*MMAXT
C
C VARIABLES THAT ARE PASSED IN ARRAY IWK: (LENGTHS ARE IN THE
C INTEGER ARRAY LIWK.)
C
C    VARIABLE NAME       LENGTH
C
C    1   IDEG              N
C    2   ICOUNT            N
C    3   PIVOT             N2+1
C    4   IPAR              42 + 2*N + N*(N+1)*MMAXT
C
      N2=2*N
      LWK(1)= N2
      LWK(2)= N2
      LWK(3)= N2
      LWK(4)= N
      LWK(5)= 2*(N+1)
      LWK(6)= N2+1
      LWK(7)= N2+1
      LWK(8)= N2+1
      LWK(9)= N2+1
      LWK(10)=N2*(N2+2)
      LWK(11)=N2
      LWK(12)=N2+1
      LWK(13)=N2+1
      LWK(14)=N2+1
      LWK(15)=N2+1
      LWK(16)=N2+1
      LWK(17)=8
      LWK(18)= 2 + 28*N + 6* N**2 + 7*N*MMAXT + 4* N**2 *MMAXT
C
      LIWK(1)=N
      LIWK(2)=N
      LIWK(3)=2*N+1
      LIWK(4)= 42 + 2*N + N*(N+1)*MMAXT
C
C WKOFF AND IWKOFF ARE OFFSETS THAT DEFINE THE VARIABLES LISTED ABOVE
C
      WKOFF(1)=1
      DO 100 I=2,18
          WKOFF(I)=WKOFF(I-1)+LWK(I-1)
 100  CONTINUE
      IWKOFF(1)=1
      DO 200 I=2,4
          IWKOFF(I)=IWKOFF(I-1)+LIWK(I-1)
 200  CONTINUE
      DO 300 J=1,8
        WK(WKOFF(17) + (J-1))=SSPAR(J)
 300  CONTINUE
C
      CALL POLYP(N,NUMT,COEF,KDEG,IFLG1,IFLG2,EPSBIG,EPSSML,
     $ NUMRR,NN,MMAXT,TTOTDG,LAMBDA,ROOTS,ARCLEN,NFE,TOTDG,
     $ WK( WKOFF( 1)),WK( WKOFF( 2)),WK( WKOFF( 3)),WK( WKOFF( 4)),
     $ WK( WKOFF( 5)),WK( WKOFF( 6)),WK( WKOFF( 7)),WK( WKOFF( 8)),
     $ WK( WKOFF( 9)),WK( WKOFF(10)),WK( WKOFF(11)),WK( WKOFF(12)),
     $ WK( WKOFF(13)),WK( WKOFF(14)),WK( WKOFF(15)),WK( WKOFF(16)),
     $ WK( WKOFF(17)),WK( WKOFF(18)),
     $IWK(IWKOFF( 1)),IWK(IWKOFF( 2)),IWK(IWKOFF( 3)),IWK(IWKOFF( 4)))
C
      RETURN
      END
      SUBROUTINE POLYP(N,NUMT,COEF,KDEG,IFLG1,IFLG2,EPSBIG,EPSSML,
     $ NUMRR,NN,MMAXT,TTOTDG,LAMBDA,ROOTS,ARCLEN,NFE,TOTDG,
     $ PDG,QDG,R,FACV,CL,Y,YP,YOLD,YPOLD,QR,ALPHA,TZ,W,
     $ WP,Z0,Z1,SSPAR,PAR,IDEG,ICOUNT,PIVOT,IPAR)
C
C THE PURPOSE OF POLYP IS TO ALIAS THE WORKSPACES "WK" AND
C "IWK" IN POLSYS TO THE VARIABLES "PDG" THROUGH "IPAR".
C POLYP GENERATES THE START POINTS FOR THE PATHS AND CALLS THE
C PATH TRACKER  POLYNF .
C
C SUBROUTINES CALLED: INITP, STRPTP, POLYNF, OTPUTP .
C
C ON INPUT:
C
C N,NUMT,COEF,KDEG,IFLG1,IFLG2,EPSBIG,EPSSML,NUMRR,NN,
C   MMAXT,TTOTDG  ARE AS DESCRIBED IN POLSYS.
C
C TOTDG  IS THE TOTAL DEGREE OF THE SYSTEM.
C
C PDG,QDG,R,FACV,CL,Y,YP,YOLD,YPOLD,QR,ALPHA,TZ,W,WP,Z0,
C   Z1,SSPAR,PAR,IDEG,ICOUNT,PIVOT,IPAR  ARE VARIABLES.
C
C ON OUTPUT:
C
C   LAMBDA,ROOTS,ARCLEN,NFE  ARE AS DESCRIBED IN POLSYS.
C ----------------------------------------------------------------------
C
C TYPE DECLARATIONS
      INTEGER N,NUMT,KDEG,IFLG1,IFLG2,NUMRR,NN,MMAXT,
     $  TTOTDG,NFE,TOTDG,IDEG,ICOUNT,PIVOT,IPAR
      INTEGER I,I1,I2,I3,IDUMMY,IFLAG,IJ,IJP1,INDEX,IPROFF,J,LIPAR,
     $ LPAR,N2,N2P1,NNFE,NP1,NUMPAT,PROFF,TRACE
      DOUBLE PRECISION COEF,EPSBIG,EPSSML,LAMBDA,ROOTS,
     $  ARCLEN,PDG,QDG,R,FACV,CL,Y,YP,YOLD,YPOLD,
     $  QR,ALPHA,TZ,W,WP,Z0,Z1,SSPAR,PAR
      DOUBLE PRECISION AARCLN,ANSAE,ANSRE,ARCAE,ARCRE,XNP1
C
C ARRAY DECLARATIONS
      DIMENSION NUMT(NN),KDEG(NN,NN+1,MMAXT),IFLG2(TTOTDG),
     $  NFE(TTOTDG),IDEG(N),ICOUNT(N),PIVOT(2*N+1),
     $  IPAR(42 + 2*N + N*(N+1)*MMAXT)
      DIMENSION IPROFF(15),LIPAR(15),LPAR(25),PROFF(25)
      DIMENSION COEF(NN,MMAXT),LAMBDA(TTOTDG),
     $  ROOTS(2,NN+1,TTOTDG), ARCLEN(TTOTDG),
     $  PDG(2,N),QDG(2,N),R(2,N),FACV(N),CL(2,N+1),
     $  Y(2*N+1),YP(2*N+1),YOLD(2*N+1),YPOLD(2*N+1),
     $  QR(2*N,2*N+2),ALPHA(2*N+1),TZ(2*N+1),W(2*N+1),
     $  WP(2*N+1),Z0(2*N+1),Z1(2*N+1),SSPAR(8),
     $  PAR(2 + 28*N + 6*N**2 + 7*N*MMAXT + 4*N**2*MMAXT)
      DIMENSION XNP1(2)
C
      N2=2*N
      NP1=N+1
      N2P1=N2+1
      IF (NUMRR .LE. 0) NUMRR=1
C
C INITIALIZATION
C
      CALL INITP(IFLG1,N,NUMT,KDEG,COEF,NN,MMAXT,PAR,IPAR,
     $                              IDEG,FACV,CL,PDG,QDG,R)
C
C INTEGER VARIABLES AND ARRAYS TO BE PASSED IN IPAR:
C
C    IPAR INDEX     VARIABLE NAME       LENGTH
C    ----------     -------------    -----------------
C          1                N               1
C          2             MMAXT              1
C          3            PROFF               25
C          4           IPROFF               15
C          5             IDEG               N
C          6             NUMT               N
C          7             KDEG               N*(N+1)*MMAXT
C
C
C DOUBLE PRECISION VARIABLES AND ARRAYS TO BE PASSED IN PAR:
C
C     PAR INDEX     VARIABLE NAME       LENGTH
C    ----------     -------------    -----------------
C          1              PDG               2*N
C          2               CL               2*(N+1)
C          3             COEF               N*MMAXT
C          4                H               N2
C          5              DHX               N2*N2
C          6              DHT               N2
C          7            XDGM1               2*N
C          8              XDG               2*N
C          9              G                 2*N
C         10             DG                 2*N
C         11           PXDGM1               2*N
C         12             PXDG               2*N
C         13               F                2*N
C         14              DF                2*N*(N+1)
C         15               XX               2*N*(N+1)*MMAXT
C         16              TRM               2*N*MMAXT
C         17             DTRM               2*N*(N+1)*MMAXT
C         18              CLX               2*N
C         19            DXNP1               2*N
C
C SET LENGTHS OF VARIABLES
      LIPAR(1)=1
      LIPAR(2)=1
      LIPAR(3)=25
      LIPAR(4)=15
      LIPAR(5)=N
      LIPAR(6)=N
      LIPAR(7)=N*(N+1)*MMAXT
      LPAR( 1)=2*N
      LPAR( 2)=2*NP1
      LPAR( 3)=N*MMAXT
      LPAR( 4)=N2
      LPAR( 5)=N2*N2
      LPAR( 6)=N2
      LPAR( 7)=2*N
      LPAR( 8)=2*N
      LPAR( 9)=2*N
      LPAR(10)=2*N
      LPAR(11)=2*N
      LPAR(12)=2*N
      LPAR(13)=2*N
      LPAR(14)=2*N*NP1
      LPAR(15)=2*N*NP1*MMAXT
      LPAR(16)=2*N*MMAXT
      LPAR(17)=2*N*NP1*MMAXT
      LPAR(18)=2*N
      LPAR(19)=2*N
C
C PROFF AND IPROFF ARE OFFSETS THAT DEFINE THE VARIABLES LISTED ABOVE
      PROFF(1)=1
      DO 10 I=2,19
          PROFF(I)=PROFF(I-1)+LPAR(I-1)
  10  CONTINUE
      IPROFF(1)=1
      DO 11 I=2,7
          IPROFF(I)=IPROFF(I-1)+LIPAR(I-1)
  11  CONTINUE
C
C DEFINE VARIABLES
      IPAR(1)=N
      IPAR(2)=MMAXT
      DO 16 I=1,19
        IPAR(IPROFF(3) + (I-1))= PROFF(I)
  16  CONTINUE
      DO 18 I=1,7
        IPAR(IPROFF(4) + (I-1))= IPROFF(I)
  18  CONTINUE
      DO 20 I=1,N
        IPAR(IPROFF(5) + (I-1))= IDEG(I)
        IPAR(IPROFF(6) + (I-1))= NUMT(I)
  20  CONTINUE
      DO 22 I1=1, N
      DO 22 I2=1, NP1
      DO 22 I3=1, NUMT(I1)
        INDEX=IPROFF(7) + (I1-1) + N*(I2-1) + N*NP1*(I3-1)
        IPAR(INDEX) = KDEG(I1,I2,I3)
  22  CONTINUE
      DO 36 I1=1,2
      DO 36 I2=1,N
        PAR(PROFF( 1) +(I1-1) + 2*(I2-1))= PDG(I1,I2)
  36  CONTINUE
      DO 37 I1=1,2
      DO 37 I2=1,NP1
        PAR(PROFF( 2) +(I1-1) +2*(I2-1))= CL(I1,I2)
  37  CONTINUE
      DO 38 I1=1,N
      DO 38 I2=1, NUMT(I1)
        PAR(PROFF( 3) +(I1-1) + N*(I2-1))=COEF(I1,I2)
  38  CONTINUE
C
C ICOUNT IS A COUNTER USED BY "STRPTP"
      ICOUNT(1)=0
      DO 50 J=2,N
          ICOUNT(J)=1
  50  CONTINUE
C
C PATHS LOOP -- ITERATE THROUGH PATHS
C
      DO 1000 NUMPAT = 1,TOTDG
C         GET A START POINT, Y, FOR THE PATH.
          Y(1) = 0.0
          CALL STRPTP(N,ICOUNT,IDEG,R ,Y(2))
C         CHECK WHETHER PATH IS TO BE FOLLOWED.
          IFLAG = IFLG2(NUMPAT)
          IF (IFLAG .NE. -2) GO TO 1000
          ARCRE = EPSBIG
          ARCAE = ARCRE
          ANSRE = EPSSML
          ANSAE = ANSRE
          TRACE = 0
C         TRACK A HOMOTOPY PATH.
          DO 65 IDUMMY=1,NUMRR
              CALL POLYNF(N2,Y,IFLAG,ARCRE,ARCAE,ANSRE,ANSAE,TRACE,
     $        QDG,NNFE,AARCLN,YP,YOLD,YPOLD,QR,ALPHA,TZ,PIVOT,W,WP,
     $        Z0,Z1,SSPAR,PAR,IPAR)
              IF (IFLAG .NE. 2 .AND. IFLAG .NE. 3) GOTO 66
  65      CONTINUE
  66      CONTINUE
C         UNSCALE AND UNTRANSFORM COMPUTED SOLUTION.
          CALL OTPUTP(N,NUMPAT,CL,FACV,PAR(PROFF(18)),Y(2),XNP1)
          LAMBDA(NUMPAT) = Y(1)
          DO 70 J=1,N
          DO 70 I=1,2
            IJ=2*J+I-2
            IJP1=IJ+1
            ROOTS(I,J,NUMPAT) = Y(IJP1)
  70      CONTINUE
          DO 72 I=1,2
            ROOTS(I,NP1,NUMPAT) = XNP1(I)
  72      CONTINUE
          ARCLEN(NUMPAT)= AARCLN
          NFE(NUMPAT)   = NNFE
          IFLG2(NUMPAT) = IFLAG
 1000 CONTINUE
C
      RETURN
      END
*
      SUBROUTINE POWP(NNNN,XXXX,YYYY)
C
C THIS SUBROUTINE TAKES A NON-NEGATIVE POWER OF A COMPLEX NUMBER:
C YYYY = XXXX**NNNN USING DE MOIVRE'S FORMULA:
C
C     YYYY = R**NNNN * (COS(NNNN*THETA),SIN(NNNN*THETA)),
C
C WHERE R=DNRM2(2,XXXX,1) AND THETA=ATAN2(XXXX(2),XXXX(1)).
C
C NOTE: POWP SETS 0**0 EQUAL TO 1.
C
C ON INPUT:
C
C NNNN  IS A NON-NEGATIVE INTEGER.
C
C XXXX  IS AN ARRAY OF LENGTH TWO REPRESENTING A COMPLEX
C       NUMBER, WHERE XXXX(1) = REAL PART OF XXXX AND XXXX(2) =
C       IMAGINARY PART OF XXXX.
C
C ON OUTPUT:
C
C YYYY  IS AN ARRAY OF LENGTH TWO REPRESENTING THE RESULT OF
C       THE POWER, YYYY = XXXX**NNNN, WHERE YYYY(1) =
C       REAL PART OF YYYY AND YYYY(2) = IMAGINARY PART OF YYYY.
C
C SUBROUTINES: COS, SIN, ATAN2, DNRM2
C
C DECLARATION OF INPUT
      INTEGER NNNN
      DOUBLE PRECISION XXXX
      DIMENSION XXXX(2)
C
C DECLARATION OF OUTPUT
      DOUBLE PRECISION YYYY
      DIMENSION YYYY(2)
C
C DECLARATION OF VARIABLES
      DOUBLE PRECISION R,RR,T,TT
C
C DECLARATION OF FUNCTIONS
      DOUBLE PRECISION  DNRM2
C
      IF (NNNN .EQ. 0) THEN
          YYYY(1)=1.
          YYYY(2)=0.
          RETURN
      ENDIF
      IF (NNNN .EQ. 1) THEN
          YYYY(1)=XXXX(1)
          YYYY(2)=XXXX(2)
          RETURN
      ENDIF
      R = DNRM2(2,XXXX,1)
      IF (R .EQ. 0.0) THEN
          YYYY(1)=0.0
          YYYY(2)=0.0
          RETURN
      END IF
      RR= R**NNNN
      T = ATAN2(XXXX(2),XXXX(1))
      TT= NNNN*T
      YYYY(1) = RR*COS(TT)
      YYYY(2) = RR*SIN(TT)
      RETURN
      END
*
      SUBROUTINE QIMUDS(Q,F,MAXA,NN,LENAA)
C
C  computes  f := [Q**(-1)] * f  .
C
C on input:
C
C Q  is the preconditioning matrix, and contains an approximate
C    factorization of M.
C
C f  is the right hand side vector, Q z = f .
C
C MAXA, NN, LENAA  describe Q in packed skyline storage format.
C
C on output:
C
C Q, MAXA, NN, LENAA  are unchanged.
C
C f  contains the solution z of Q z = f .
C
C
C Calls  SOLVDS .
C
      INTEGER LENAA,LENQ,NN,MAXA(NN+2),NQ
      DOUBLE PRECISION Q(LENAA+NN+1),F(NN+1)
C
      NQ=NN+1
      LENQ=MAXA(NN+2)-1
C
      CALL SOLVDS(NQ,Q,LENQ,MAXA,F)
C
      RETURN
      END
        SUBROUTINE QRFAQF(QT,R,N,IFLAG)
C
C SUBROUTINE  QRFAQF  COMPUTES THE QR FACTORIZATION OF A MATRIX  A,
C WHERE  R  IS AN UPPER TRIANGULAR MATRIX, AND  Q  IS AN ORTHOGONAL
C MATRIX WHICH IS THE PRODUCT OF N-1 HOUSEHOLDER TRANSFORMATIONS
C
C   Q=H1*H2*...*H(N-1).
C
C THE ROUTINE HAS TWO MAJOR STEPS.  FIRST, THE QR FACTORIZATION
C OF  A  IS COMPUTED, RESULTING IN DEFINING THE VECTOR  R,  AND
C STORING INFORMATION IN THE LOWER TRIANGLE OF  QT  WHICH WILL
C ENABLE THE CONSTRUCTION OF  Q TRANSPOSE.
C
C THE SECOND STEP CONSTRUCTS  Q TRANSPOSE FROM THE INFORMATION
C STORED IN  QT,  AND PLACES IT IN  QT.
C
C THE INFORMATION STORED IN THE LOWER TRIANGLE OF  QT  DURING THE FIRST
C STEP ARE THE VECTORS  UJ, WHICH DEFINE THE HOUSEHOLDER TRANSFORMATIONS
C
C                   T
C   HJ = I - (UJ*UJ  / PJ),  WHERE UJ[I]=0 FOR I=1...J-1,
C                             UJ[I]=QT[I,J], FOR I=J...N,
C                             PJ = THE JTH COMPONENT OF UJ.
C
C
C ON INPUT:
C
C QT(1:N,1:N)  CONTAINS THE MATRIX  A  TO BE FACTORED.
C
C R(1:N*(N+1)/2)  IS UNDEFINED.
C
C N  IS THE DIMENSION OF THE MATRIX TO BE FACTORED.
C
C IFLAG  IS UNDEFINED.
C
C
C ON OUTPUT:
C
C QT  CONTAINS  Q TRANSPOSE.
C
C R(1:N*(N+1)/2)  CONTAINS THE UPPER TRIANGLE OF  R  STORED BY ROWS.
C
C N  IS UNCHANGED.
C
C IFLAG = 4  IF THE MATRIX A IS SINGULAR.  OTHERWISE,  IFLAG
C    IS UNCHANGED.
C
C
C CALLS  DAXPY, DCOPY, DDOT, DNRM2, DSCAL.
C
C ***** DECLARATIONS *****
C
C     FUNCTION DECLARATIONS
C
        DOUBLE PRECISION DDOT, DNRM2
C
C     LOCAL VARIABLES
C
        DOUBLE PRECISION ONE, TAU, TEMP
        INTEGER I, J, K, INDEXR, ISIGN
C
C     SCALAR ARGUMENTS
C
        INTEGER N, IFLAG
C
C     ARRAY DECLARATIONS
C
        DOUBLE PRECISION QT(N,N),R(N)
C
C ***** END OF DECLARATIONS *****
C
C ***** FIRST EXECUTABLE STATEMENT *****
C
        ONE = 1.0
C
C ***** CALCULATION OF QR DECOMPOSITION, PLACING R IN THE VECTOR *****
C       R, AND PLACING THE UJ VECTORS IN THE LOWER TRIANGLE OF
C       QT.
C
        INDEXR = 1
        DO 20 K=1,N-1
          TEMP = DNRM2(N-K+1,QT(K,K),1)
          IF (TEMP .EQ. 0.0) THEN
C
C           MATRIX IS SINGULAR, SET  IFLAG  AND RETURN.
C
            IFLAG = 4
            RETURN
          ELSE
C
C           FORM QK AND PREMULTIPLY  QT  BY IT.
C                                                         T
C           UK = EK - ISIGN*X/||X||,  WHERE  HK = I-(UK*UK /PK),
C              PK = THE KTH COMPONENT OF UK,
C              EK = THE KTH NATURAL BASIS VECTOR,
C              X  = THE KTH COLUMN OF THE MATRIX  H(K-1)...H2*H1*QT,
C              ISIGN = THE SIGN OF PK.
C
C           GET SIGN.
C
            ISIGN = SIGN(ONE,QT(K,K))
C
C           COMPUTE R(K,K).
C
            R(INDEXR) = -ISIGN*TEMP
C
C           UPDATE KTH COLUMN.
C
            TEMP = ISIGN/TEMP
            CALL DSCAL(N-K+1,TEMP,QT(K,K),1)
            QT(K,K) = QT(K,K) + 1.0
C
C           UPDATE THE K+1ST - NTH COLUMNS OF  QT, AND  R.
C
            INDEXR = INDEXR + 1
            DO 10 J=K+1,N
              TAU = DDOT(N-K+1,QT(K,K),1,QT(K,J),1)/QT(K,K)
              R(INDEXR) = QT(K,J) - TAU*QT(K,K)
              INDEXR = INDEXR + 1
              CALL DAXPY(N-K,-TAU,QT(K+1,K),1,QT(K+1,J),1)
  10        CONTINUE
          END IF
  20    CONTINUE
        IF (QT(N,N) .EQ. 0.0) THEN
C
C         MATRIX IS SINGULAR, SET  IFLAG  AND RETURN.
C
          IFLAG = 4
          RETURN
        END IF
        R(INDEXR) = QT(N,N)
C
C ***** END OF FACTORING STEP *****
C
C ***** CONSTRUCT Q TRANSPOSE IN QT *****
C
C FORM Q BY MULTIPLYING ((I*H(N-1))*...)*H1.
C THIS IS DONE IN PLACE IN  QT  BY UPDATING ONLY THE LOWER
C RIGHT HAND CORNER OF QT  (QT(K,K) TO QT(N,N)).
C
C
        QT(N,N) = 1.0
        DO 40 K=N-1,1,-1
C
C         MULTIPLY  QT  BY H(K).
C
          TEMP = QT(K,K)
C
C         UPDATE ROW K.
C
          QT(K,K) = 1.0-QT(K,K)
          CALL DCOPY(N-K,QT(K+1,K),1,QT(K,K+1),N)
          CALL DSCAL(N-K,-ONE,QT(K,K+1),N)
C
C         UPDATE REMAINING ROWS.
C
          DO 30 I=N,K+1,-1
            TAU = -DDOT(N-K,QT(I,K+1),N,QT(K,K+1),N)
            QT(I,K) = -TAU
            TAU = TAU/TEMP
            CALL DAXPY(N-K,TAU,QT(K,K+1),N,QT(I,K+1),N)
  30      CONTINUE
  40    CONTINUE
C
C ***** END OF Q TRANSPOSE CONSTRUCTION *****
C
        RETURN
C
C ***** END OF SUBROUTINE QRFAQF *****
        END
        SUBROUTINE QRSLQF(QT,R,B,X,N)
C
C SUBROUTINE QRSLQF SOLVES THE SYSTEM  R*S = QT*B  FOR  S.
C
C
C ON INPUT:
C
C QT(1:N,1:N)  CONTAINS QT IN THE EQUATION ABOVE.
C
C R(1:N*(N+1)/2)  CONTAINS THE UPPER TRIANGLE OF  R  IN THE EQUATION
C     ABOVE, STORED BY ROWS.
C
C B(1:N)  CONTAINS  B  IN THE EQUATION ABOVE.
C
C N   IS THE DIMENSION OF THE PROBLEM.
C
C
C ON OUTPUT:
C
C QT  AND  R  ARE UNCHANGED.
C
C B   CONTAINS THE SOLUTION VECTOR S.
C
C X(1:N)  IS A WORK ARRAY WHICH CONTAINS QT*B ON OUTPUT.
C
C
C CALLS DDOT.
C
C ***** DECLARATIONS *****
C
C     FUNCTION DECLARATIONS
C
        DOUBLE PRECISION DDOT
C
C     LOCAL VARIABLES
C
        DOUBLE PRECISION TAU
        INTEGER INDEXR, I, J
C
C     SCALAR ARGUMENTS
C
        INTEGER N
C
C     ARRAY DECLARATIONS
C
        DOUBLE PRECISION QT(N,N),R(N*(N+1)/2),B(N),X(N)
C
C ***** END OF DECLARATIONS *****
C
C ***** FIRST EXECUTABLE STATEMENT *****
C
C X = QT*B.
C
        DO 10 I=1,N
          X(I) = DDOT(N,QT(I,1),N,B,1)
  10    CONTINUE
C
C COMPUTE S USING BACK SUBSTITUTION.
C
        INDEXR = N*(N+1)/2
        B(N) = X(N)/R(INDEXR)
        INDEXR = INDEXR - 1
        DO 30 I=N-1,1,-1
          TAU = X(I)
          DO 20 J=N,I+1,-1
            TAU = TAU - R(INDEXR)*B(J)
            INDEXR = INDEXR - 1
  20     CONTINUE
          B(I) = TAU/R(INDEXR)
          INDEXR = INDEXR - 1
  30    CONTINUE
        RETURN
C
C ***** END OF SUBROUTINE QRSLQF *****
        END
      SUBROUTINE RHO(A,LAMBDA,X,V,PAR,IPAR)
      DOUBLE PRECISION A(*),LAMBDA,X(*),V(*),PAR(*)
      INTEGER IPAR(*)
C
C PAR(1:*) AND IPAR(1:*) ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS,
C    WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES
C    RHO, RHOJAC.
C
C EVALUATE  RHO(A,LAMBDA,X)  AND RETURN IN THE VECTOR  V .
C
C THE FOLLOWING CODE IS SPECIFICALLY FOR THE POLYNOMIAL SYSTEM DRIVER
C  POLSYS , AND SHOULD BE USED VERBATUM WITH  POLSYS .  IF THE USER IS
C CALLING  FIXP??  OR   STEP??  DIRECTLY, HE MUST SUPPLY APPROPRIATE
C REPLACEMENT CODE HERE.
      INTEGER J,N
C FORCE PREDICTED POINT TO HAVE  LAMBDA .GE. 0  .
      IF (LAMBDA .LT. 0.0) LAMBDA=0.0
      CALL HFUNP(A,LAMBDA,X,PAR,IPAR)
      N=IPAR(1)
      DO 10 J=1,2*N
        V(J)=PAR(IPAR(3 + (4-1)) + (J-1))
   10 CONTINUE
C
      RETURN
      END
      SUBROUTINE RHOA(A,LAMBDA,X,PAR,IPAR)
      DOUBLE PRECISION A(1),LAMBDA,X(1),PAR(1)
      INTEGER IPAR(1)
C
C PAR(1:*) AND IPAR(1:*) ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS,
C    WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES
C    RHOA, RHOJS.
C
C CALCULATE AND RETURN IN  A  THE VECTOR Z SUCH THAT
C  RHO(Z,LAMBDA,X) = 0 .
C
      RETURN
      END
      SUBROUTINE RHOJAC(A,LAMBDA,X,V,K,PAR,IPAR)
      DOUBLE PRECISION A(*),LAMBDA,X(*),V(*),PAR(*)
      INTEGER IPAR(*),K
C
C PAR(1:*) AND IPAR(1:*) ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS,
C    WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES
C    RHO, RHOJAC.
C
C RETURN IN THE VECTOR  V  THE KTH COLUMN OF THE JACOBIAN
C MATRIX [D RHO/D LAMBDA, D RHO/DX] EVALUATED AT THE POINT
C (A, LAMBDA, X).
C
C THE FOLLOWING CODE IS SPECIFICALLY FOR THE POLYNOMIAL SYSTEM DRIVER
C  POLSYS , AND SHOULD BE USED VERBATUM WITH  POLSYS .  IF THE USER IS
C CALLING  FIXP??  OR   STEP??  DIRECTLY, HE MUST SUPPLY APPROPRIATE
C REPLACEMENT CODE HERE.
      INTEGER J,N,N2
      N=IPAR(1)
      N2=2*N
      IF (K .EQ. 1) THEN
C FORCE PREDICTED POINT TO HAVE  LAMBDA .GE. 0  .
        IF (LAMBDA .LT. 0.0) LAMBDA=0.0
        CALL HFUNP(A,LAMBDA,X,PAR,IPAR)
        DO 10 J=1,N2
          V(J)=PAR(IPAR(3 + (6-1)) + (J-1))
   10   CONTINUE
        RETURN
      ELSE
        DO 20 J=1,N2
          V(J)=PAR(IPAR(3 + (5-1)) + (J-1) + N2*(K-2))
   20   CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE RHOJS(A,LAMBDA,X,QR,LENQR,PIVOT,PP,PAR,IPAR)
C     INTEGER IPAR(1),LENQR,N,PIVOT(N+2)
C     DOUBLE PRECISION A(N),LAMBDA,PAR(1),PP(N),QR(LENQR),X(N)
C
C PAR(1:*) AND IPAR(1:*) ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS,
C    WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES
C    RHOA, RHOJS.
C
C Evaluate the N X N symmetric Jacobian matrix [D RHO/DX] at (A,X,LAMBDA
C and return the result in packed skyline storage format in QR.  LENQR i
C the length of QR, and PIVOT contains the indices of the diagonal eleme
C of [D RHO/DX] within QR.  PP contains -[D RHO/D LAMBDA] evaluated at
C (A,X,LAMBDA).  Note the minus sign in the definition of PP.
C
      RETURN
      END
      SUBROUTINE ROOT(T,FT,B,C,RELERR,ABSERR,IFLAG)
C
C  ROOT COMPUTES A ROOT OF THE NONLINEAR EQUATION F(X)=0
C  WHERE F(X) IS A CONTINOUS REAL FUNCTION OF A SINGLE REAL
C  VARIABLE X.  THE METHOD USED IS A COMBINATION OF BISECTION
C  AND THE SECANT RULE.
C
C  NORMAL INPUT CONSISTS OF A CONTINUOS FUNCTION F AND AN
C  INTERVAL (B,C) SUCH THAT F(B)*F(C).LE.0.0.  EACH ITERATION
C  FINDS NEW VALUES OF B AND C SUCH THAT THE INTERVAL(B,C) IS
C  SHRUNK AND F(B)*F(C).LE.0.0.  THE STOPPING CRITERION IS
C
C          DABS(B-C).LE.2.0*(RELERR*DABS(B)+ABSERR)
C
C  WHERE RELERR=RELATIVE ERROR AND ABSERR=ABSOLUTE ERROR ARE
C  INPUT QUANTITIES.  SET THE FLAG, IFLAG, POSITIVE TO INITIALIZE
C  THE COMPUTATION.  AS B,C AND IFLAG ARE USED FOR BOTH INPUT AND
C  OUTPUT, THEY MUST BE VARIABLES IN THE CALLING PROGRAM.
C
C  IF 0 IS A POSSIBLE ROOT, ONE SHOULD NOT CHOOSE ABSERR=0.0.
C
C  THE OUTPUT VALUE OF B IS THE BETTER APPROXIMATION TO A ROOT
C  AS B AND C ARE ALWAYS REDEFINED SO THAT DABS(F(B)).LE.DABS(F(C)).
C
C  TO SOLVE THE EQUATION, ROOT MUST EVALUATE F(X) REPEATEDLY. THIS
C  IS DONE IN THE CALLING PROGRAM.  WHEN AN EVALUATION OF F IS
C  NEEDED AT T, ROOT RETURNS WITH IFLAG NEGATIVE.  EVALUATE FT=F(T)
C  AND CALL ROOT AGAIN.  DO NOT ALTER IFLAG.
C
C  WHEN THE COMPUTATION IS COMPLETE, ROOT RETURNS TO THE CALLING
C  PROGRAM WITH IFLAG POSITIVE=
C
C     IFLAG=1  IF F(B)*F(C).LT.0 AND THE STOPPING CRITERION IS MET.
C
C          =2  IF A VALUE B IS FOUND SUCH THAT THE COMPUTED VALUE
C              F(B) IS EXACTLY ZERO.  THE INTERVAL (B,C) MAY NOT
C              SATISFY THE STOPPING CRITERION.
C
C          =3  IF DABS(F(B)) EXCEEDS THE INPUT VALUES DABS(F(B)),
C              DABS(F(C)).  IN THIS CASE IT IS LIKELY THAT B IS CLOSE
C              TO A POLE OF F.
C
C          =4  IF NO ODD ORDER ROOT WAS FOUND IN THE INTERVAL.  A
C              LOCAL MINIMUM MAY HAVE BEEN OBTAINED.
C
C          =5  IF TOO MANY FUNCTION EVALUATIONS WERE MADE.
C              (AS PROGRAMMED, 500 ARE ALLOWED.)
C
C  THIS CODE IS A MODIFICATION OF THE CODE ZEROIN WHICH IS COMPLETELY
C  EXPLAINED AND DOCUMENTED IN THE TEXT  NUMERICAL COMPUTING:  AN
C  INTRODUCTION,  BY L. F. SHAMPINE AND R. C. ALLEN.
C
C  CALLS  D1MACH .
C
      DOUBLE PRECISION A,ABSERR,ACBS,ACMB,AE,B,C,CMB,D1MACH,FA,FB,
     1  FC,FT,FX,P,Q,RE,RELERR,T,TOL,U
      INTEGER IC,IFLAG,KOUNT
      SAVE
C
      IF(IFLAG.GE.0) GO TO 100
      IFLAG=ABS(IFLAG)
      GO TO (200,300,400), IFLAG
  100 U=D1MACH(4)
      RE=MAX(RELERR,U)
      AE=MAX(ABSERR,0.0D0)
      IC=0
      ACBS=ABS(B-C)
      A=C
      T=A
      IFLAG=-1
      RETURN
  200 FA=FT
      T=B
      IFLAG=-2
      RETURN
  300 FB=FT
      FC=FA
      KOUNT=2
      FX=MAX(ABS(FB),ABS(FC))
    1 IF(ABS(FC).GE.ABS(FB))GO TO 2
C
C  INTERCHANGE B AND C SO THAT ABS(F(B)).LE.ABS(F(C)).
C
      A=B
      FA=FB
      B=C
      FB=FC
      C=A
      FC=FA
    2 CMB=0.5*(C-B)
      ACMB=ABS(CMB)
      TOL=RE*ABS(B)+AE
C
C  TEST STOPPING CRITERION AND FUNCTION COUNT.
C
      IF(ACMB.LE.TOL)GO TO 8
      IF(KOUNT.GE.500)GO TO 12
C
C  CALCULATE NEW ITERATE EXPLICITLY AS B+P/Q
C  WHERE WE ARRANGE P.GE.0.  THE IMPLICIT
C  FORM IS USED TO PREVENT OVERFLOW.
C
      P=(B-A)*FB
      Q=FA-FB
      IF(P.GE.0.0)GO TO 3
      P=-P
      Q=-Q
C
C  UPDATE A, CHECK IF REDUCTION IN THE SIZE OF BRACKETING
C  INTERVAL IS SATISFACTORY.  IF NOT BISECT UNTIL IT IS.
C
    3 A=B
      FA=FB
      IC=IC+1
      IF(IC.LT.4)GO TO 4
      IF(8.0*ACMB.GE.ACBS)GO TO 6
      IC=0
      ACBS=ACMB
C
C  TEST FOR TOO SMALL A CHANGE.
C
    4 IF(P.GT.ABS(Q)*TOL)GO TO 5
C
C  INCREMENT BY TOLERANCE
C
      B=B+SIGN(TOL,CMB)
      GO TO 7
C
C  ROOT OUGHT TO BE BETWEEN B AND (C+B)/2
C
    5 IF(P.GE.CMB*Q)GO TO 6
C
C  USE SECANT RULE.
C
      B=B+P/Q
      GO TO 7
C
C  USE BISECTION.
C
    6 B=0.5*(C+B)
C
C  HAVE COMPLETED COMPUTATION FOR NEW ITERATE B.
C
    7 T=B
      IFLAG=-3
      RETURN
  400 FB=FT
      IF(FB.EQ.0.0)GO TO 9
      KOUNT=KOUNT+1
      IF(SIGN(1.0D0,FB).NE.SIGN(1.0D0,FC))GO TO 1
      C=A
      FC=FA
      GO TO 1
C
C FINISHED.  SET IFLAG.
C
    8 IF(SIGN(1.0D0,FB).EQ.SIGN(1.0D0,FC))GO TO 11
      IF(ABS(FB).GT.FX)GO TO 10
      IFLAG=1
      RETURN
    9 IFLAG=2
      RETURN
   10 IFLAG=3
      RETURN
   11 IFLAG=4
      RETURN
   12 IFLAG=5
      RETURN
      END
      SUBROUTINE ROOTNF(N,NFE,IFLAG,RELERR,ABSERR,Y,YP,YOLD,YPOLD,
     $   A,QR,ALPHA,TZ,PIVOT,W,WP,PAR,IPAR)
C
C ROOTNF  FINDS THE POINT  YBAR = (1, XBAR)  ON THE ZERO CURVE OF THE
C HOMOTOPY MAP.  IT STARTS WITH TWO POINTS YOLD=(LAMBDAOLD,XOLD) AND
C Y=(LAMBDA,X) SUCH THAT  LAMBDAOLD < 1 <= LAMBDA , AND ALTERNATES
C BETWEEN HERMITE CUBIC INTERPOLATION AND NEWTON ITERATION UNTIL
C CONVERGENCE.
C
C ON INPUT:
C
C N = DIMENSION OF X AND THE HOMOTOPY MAP.
C
C NFE = NUMBER OF JACOBIAN MATRIX EVALUATIONS.
C
C IFLAG = -2, -1, OR 0, INDICATING THE PROBLEM TYPE.
C
C RELERR, ABSERR = RELATIVE AND ABSOLUTE ERROR VALUES.  THE ITERATION IS
C    CONSIDERED TO HAVE CONVERGED WHEN A POINT Y=(LAMBDA,X) IS FOUND
C    SUCH THAT
C
C    |Y(1) - 1| <= RELERR + ABSERR              AND
C
C    ||Z|| <= RELERR*||X|| + ABSERR  ,          WHERE
C
C    (?,Z) IS THE NEWTON STEP TO Y=(LAMBDA,X).
C
C Y(1:N+1) = POINT (LAMBDA(S), X(S)) ON ZERO CURVE OF HOMOTOPY MAP.
C
C YP(1:N+1) = UNIT TANGENT VECTOR TO THE ZERO CURVE OF THE HOMOTOPY MAP
C    AT  Y .
C
C YOLD(1:N+1) = A POINT DIFFERENT FROM  Y  ON THE ZERO CURVE.
C
C YPOLD(1:N+1) = UNIT TANGENT VECTOR TO THE ZERO CURVE OF THE HOMOTOPY
C    MAP AT  YOLD .
C
C A(1:*) = PARAMETER VECTOR IN THE HOMOTOPY MAP.
C
C QR(1:N,1:N+2), ALPHA(1:N), TZ(1:N+1), PIVOT(1:N+1), W(1:N+1),
C    WP(1:N+1)  ARE WORK ARRAYS USED FOR THE QR FACTORIZATION (IN THE
C    NEWTON STEP CALCULATION) AND THE INTERPOLATION.
C
C PAR(1:*) AND IPAR(1:*) ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS,
C    WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES
C    RHO, RHOJAC.
C
C ON OUTPUT:
C
C N , RELERR , ABSERR , A  ARE UNCHANGED.
C
C NFE  HAS BEEN UPDATED.
C
C IFLAG
C    = -2, -1, OR 0 (UNCHANGED) ON A NORMAL RETURN.
C
C    = 4 IF A JACOBIAN MATRIX WITH RANK < N HAS OCCURRED.  THE
C        ITERATION WAS NOT COMPLETED.
C
C    = 6 IF THE ITERATION FAILED TO CONVERGE.  Y  AND  YOLD  CONTAIN
C        THE LAST TWO POINTS FOUND ON THE ZERO CURVE.
C
C Y  IS THE POINT ON THE ZERO CURVE OF THE HOMOTOPY MAP AT  LAMBDA = 1 .
C
C
C CALLS  D1MACH , DNRM2 , ROOT , TANGNF .
C
      DOUBLE PRECISION ABSERR,AERR,D1MACH,DD001,DD0011,DD01,DD011,
     $   DELS,DNRM2,F0,F1,FP0,FP1,QOFS,QSOUT,RELERR,RERR,S,SA,SB,
     $   SOUT,U
      INTEGER IFLAG,JUDY,JW,LCODE,LIMIT,N,NFE,NP1
C
C ***** ARRAY DECLARATIONS. *****
C
      DOUBLE PRECISION Y(N+1),YP(N+1),YOLD(N+1),YPOLD(N+1),A(N),
     $   QR(N,N+2),ALPHA(N),TZ(N+1),W(N+1),WP(N+1),PAR(1)
      INTEGER PIVOT(N+1),IPAR(1)
C
C ***** END OF DIMENSIONAL INFORMATION. *****
C
C THE LIMIT ON THE NUMBER OF ITERATIONS ALLOWED MAY BE CHANGED BY
C CHANGING THE FOLLOWING PARAMETER STATEMENT:
      PARAMETER (LIMIT=20)
C
C DEFINITION OF HERMITE CUBIC INTERPOLANT VIA DIVIDED DIFFERENCES.
C
      DD01(F0,F1,DELS)=(F1-F0)/DELS
      DD001(F0,FP0,F1,DELS)=(DD01(F0,F1,DELS)-FP0)/DELS
      DD011(F0,F1,FP1,DELS)=(FP1-DD01(F0,F1,DELS))/DELS
      DD0011(F0,FP0,F1,FP1,DELS)=(DD011(F0,F1,FP1,DELS) -
     $                            DD001(F0,FP0,F1,DELS))/DELS
      QOFS(F0,FP0,F1,FP1,DELS,S)=((DD0011(F0,FP0,F1,FP1,DELS)*(S-DELS) +
     $   DD001(F0,FP0,F1,DELS))*S + FP0)*S + F0
C
C
      U=D1MACH(4)
      RERR=MAX(RELERR,U)
      AERR=MAX(ABSERR,0.0D0)
      NP1=N+1
C
C *****  MAIN LOOP.  *****
C
100   DO 300 JUDY=1,LIMIT
      DO 110 JW=1,NP1
        TZ(JW)=Y(JW)-YOLD(JW)
110   CONTINUE
      DELS=DNRM2(NP1,TZ,1)
C
C USING TWO POINTS AND TANGENTS ON THE HOMOTOPY ZERO CURVE, CONSTRUCT
C THE HERMITE CUBIC INTERPOLANT Q(S).  THEN USE  ROOT  TO FIND THE S
C CORRESPONDING TO  LAMBDA = 1 .  THE TWO POINTS ON THE ZERO CURVE ARE
C ALWAYS CHOSEN TO BRACKET LAMBDA=1, WITH THE BRACKETING INTERVAL
C ALWAYS BEING [0, DELS].
C
      SA=0.0
      SB=DELS
      LCODE=1
130   CALL ROOT(SOUT,QSOUT,SA,SB,RERR,AERR,LCODE)
      IF (LCODE .GT. 0) GO TO 140
      QSOUT=QOFS(YOLD(1),YPOLD(1),Y(1),YP(1),DELS,SOUT) - 1.0
      GO TO 130
C IF LAMBDA = 1 WERE BRACKETED,  ROOT  CANNOT FAIL.
140   IF (LCODE .GT. 2) THEN
        IFLAG=6
        RETURN
      ENDIF
C
C CALCULATE Q(SA) AS THE INITIAL POINT FOR A NEWTON ITERATION.
      DO 150 JW=1,NP1
        W(JW)=QOFS(YOLD(JW),YPOLD(JW),Y(JW),YP(JW),DELS,SA)
150   CONTINUE
C CALCULATE NEWTON STEP AT Q(SA).
      CALL TANGNF(SA,W,WP,YPOLD,A,QR,ALPHA,TZ,PIVOT,NFE,N,IFLAG,
     $            PAR,IPAR)
      IF (IFLAG .GT. 0) RETURN
C NEXT POINT = CURRENT POINT + NEWTON STEP.
      DO 160 JW=1,NP1
        W(JW)=W(JW)+TZ(JW)
160   CONTINUE
C GET THE TANGENT  WP  AT  W  AND THE NEXT NEWTON STEP IN  TZ .
      CALL TANGNF(SA,W,WP,YPOLD,A,QR,ALPHA,TZ,PIVOT,NFE,N,IFLAG,
     $            PAR,IPAR)
      IF (IFLAG .GT. 0) RETURN
C TAKE NEWTON STEP AND CHECK CONVERGENCE.
      DO 170 JW=1,NP1
        W(JW)=W(JW)+TZ(JW)
170   CONTINUE
      IF ((ABS(W(1)-1.0) .LE. RERR+AERR) .AND.
     $    (DNRM2(N,TZ(2),1) .LE. RERR*DNRM2(N,W(2),1)+AERR)) THEN
        DO 180 JW=1,NP1
          Y(JW)=W(JW)
180     CONTINUE
        RETURN
      ENDIF
C IF THE ITERATION HAS NOT CONVERGED, DISCARD ONE OF THE OLD POINTS
C SUCH THAT  LAMBDA = 1  IS STILL BRACKETED.
      IF ((YOLD(1)-1.0)*(W(1)-1.0) .GT. 0.0) THEN
        DO 200 JW=1,NP1
          YOLD(JW)=W(JW)
          YPOLD(JW)=WP(JW)
200     CONTINUE
      ELSE
        DO 210 JW=1,NP1
          Y(JW)=W(JW)
          YP(JW)=WP(JW)
210     CONTINUE
      ENDIF
300   CONTINUE
C
C ***** END OF MAIN LOOP. *****
C
C THE ALTERNATING OSCULATORY CUBIC INTERPOLATION AND NEWTON ITERATION
C HAS NOT CONVERGED IN  LIMIT  STEPS.  ERROR RETURN.
      IFLAG=6
      RETURN
      END
      SUBROUTINE ROOTNS(N,NFE,IFLAG,RELERR,ABSERR,Y,YP,YOLD,YPOLD,
     $   A,QR,LENQR,PIVOT,WORK,PAR,IPAR)
C
C ROOTNS  FINDS THE POINT  YBAR = (XBAR, 1)  ON THE ZERO CURVE OF THE
C HOMOTOPY MAP.  IT STARTS WITH TWO POINTS YOLD=(XOLD,LAMBDAOLD) AND
C Y=(X,LAMBDA) SUCH THAT  LAMBDAOLD < 1 <= LAMBDA , AND ALTERNATES
C BETWEEN HERMITE CUBIC INTERPOLATION AND NEWTON ITERATION UNTIL
C CONVERGENCE.
C
C ON INPUT:
C
C N = DIMENSION OF X AND THE HOMOTOPY MAP.
C
C NFE = NUMBER OF JACOBIAN MATRIX EVALUATIONS.
C
C IFLAG = -2, -1, OR 0, INDICATING THE PROBLEM TYPE.
C
C RELERR, ABSERR = RELATIVE AND ABSOLUTE ERROR VALUES.  THE ITERATION IS
C    CONSIDERED TO HAVE CONVERGED WHEN A POINT Y=(X,LAMBDA) IS FOUND
C    SUCH THAT
C
C    |Y(NP1) - 1| <= RELERR + ABSERR              AND
C
C    ||Z|| <= RELERR*||X|| + ABSERR  ,          WHERE
C
C    (Z,?) IS THE NEWTON STEP TO Y=(X,LAMBDA).
C
C Y(1:N+1) = POINT (X(S), LAMBDA(S)) ON ZERO CURVE OF HOMOTOPY MAP.
C
C YP(1:N+1) = UNIT TANGENT VECTOR TO THE ZERO CURVE OF THE HOMOTOPY MAP
C    AT  Y .
C
C YOLD(1:N+1) = A POINT DIFFERENT FROM  Y  ON THE ZERO CURVE.
C
C YPOLD(1:N+1) = UNIT TANGENT VECTOR TO THE ZERO CURVE OF THE HOMOTOPY
C    MAP AT  YOLD .
C
C A(1:*) = PARAMETER VECTOR IN THE HOMOTOPY MAP.
C
C QR(1:LENQR) = THE N X N SYMMETRIC JACOBIAN MATRIX WITH RESPECT TO X
C    STORED IN PACKED SKYLINE STORAGE FORMAT.  LENQR  AND  PIVOT
C    DESCRIBE THE DATA STRUCTURE IN  QR .
C
C LENQR = LENGTH OF THE ONE-DIMENSIONAL ARRAY  QR  USED TO CONTAIN THE
C    N X N SYMMETRIC JACOBIAN MATRIX WITH RESPECT TO X IN PACKED
C    SKYLINE STORAGE FORMAT.
C
C PIVOT(1:N+2) = INDICES OF THE DIAGONAL ELEMENTS OF THE N X N SYMMETRIC
C    JACOBIAN MATRIX (WITH RESPECT TO X) WITHIN  QR .
C
C WORK(1:13*(N+1)+2*N+LENQR) = WORK ARRAY SPLIT UP AND USED FOR THE
C    CALCULATION OF THE JACOBIAN MATRIX KERNEL, THE NEWTON STEP,
C    AND INTERPOLATION.
C
C PAR(1:*) AND IPAR(1:*) ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS,
C    WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES
C    RHO, RHOJS.
C
C ON OUTPUT:
C
C N , RELERR , ABSERR , A  ARE UNCHANGED.
C
C NFE  HAS BEEN UPDATED.
C
C IFLAG
C    = -2, -1, OR 0 (UNCHANGED) ON A NORMAL RETURN.
C
C    = 4 IF THE PRECONDITIONED CONJUGATE GRADIENT ITERATION FAILED TO
C        CONVERGE (MOST LIKELY DUE TO A JACOBIAN MATRIX WITH RANK < N).
C        THE ITERATION WAS NOT COMPLETED.
C
C    = 6 IF THE INTERPOLATION/NEWTON ITERATION FAILED TO CONVERGE.
C        Y  AND  YOLD  CONTAIN THE LAST TWO POINTS FOUND ON THE
C        ZERO CURVE.
C
C Y  IS THE POINT ON THE ZERO CURVE OF THE HOMOTOPY MAP AT  LAMBDA = 1 .
C
C
C CALLS  D1MACH , DAXPY , DCOPY , DNRM2 , ROOT , TANGNS .
C
      DOUBLE PRECISION ABSERR,AERR,D1MACH,DD001,DD0011,DD01,DD011,
     $   DELS,DNRM2,F0,F1,FP0,FP1,QOFS,QSOUT,RELERR,RERR,S,SA,SB,
     $   SOUT,U
      INTEGER IFLAG,IPP,IRHO,ITANGW,ITZ,IW,IWP,IZ0,IZ1,JUDY,JW,
     $   LCODE,LENQR,LIMIT,N,NFE,NP1
C
C ***** ARRAY DECLARATIONS. *****
C
      DOUBLE PRECISION Y(N+1),YP(N+1),YOLD(N+1),YPOLD(N+1),A(N),
     $   QR(LENQR),WORK(13*(N+1)+2*N+LENQR),PAR(1)
      INTEGER PIVOT(N+2),IPAR(1)
C
C ***** END OF DIMENSIONAL INFORMATION. *****
C
C THE LIMIT ON THE NUMBER OF ITERATIONS ALLOWED MAY BE CHANGED BY
C CHANGING THE FOLLOWING PARAMETER STATEMENT:
      PARAMETER (LIMIT=20)
C
C DEFINITION OF HERMITE CUBIC INTERPOLANT VIA DIVIDED DIFFERENCES.
C
      DD01(F0,F1,DELS)=(F1-F0)/DELS
      DD001(F0,FP0,F1,DELS)=(DD01(F0,F1,DELS)-FP0)/DELS
      DD011(F0,F1,FP1,DELS)=(FP1-DD01(F0,F1,DELS))/DELS
      DD0011(F0,FP0,F1,FP1,DELS)=(DD011(F0,F1,FP1,DELS) -
     $                            DD001(F0,FP0,F1,DELS))/DELS
      QOFS(F0,FP0,F1,FP1,DELS,S)=((DD0011(F0,FP0,F1,FP1,DELS)*(S-DELS) +
     $   DD001(F0,FP0,F1,DELS))*S + FP0)*S + F0
C
C
      U=D1MACH(4)
      RERR=MAX(RELERR,U)
      AERR=MAX(ABSERR,0.0D0)
      NP1=N+1
      IPP=1
      IRHO=N+1
      IW=IRHO+N
      IWP=IW+NP1
      ITZ=IWP+NP1
      IZ0=ITZ+NP1
      IZ1=IZ0+NP1
      ITANGW=IZ1+NP1
C
C *****  MAIN LOOP.  *****
C
100   DO 300 JUDY=1,LIMIT
      DO 110 JW=1,NP1
        WORK(ITZ+JW-1)=Y(JW)-YOLD(JW)
110   CONTINUE
      DELS=DNRM2(NP1,WORK(ITZ),1)
C
C USING TWO POINTS AND TANGENTS ON THE HOMOTOPY ZERO CURVE, CONSTRUCT
C THE HERMITE CUBIC INTERPOLANT Q(S).  THEN USE  ROOT  TO FIND THE S
C CORRESPONDING TO  LAMBDA = 1 .  THE TWO POINTS ON THE ZERO CURVE ARE
C ALWAYS CHOSEN TO BRACKET LAMBDA=1, WITH THE BRACKETING INTERVAL
C ALWAYS BEING [0, DELS].
C
      SA=0.0
      SB=DELS
      LCODE=1
130   CALL ROOT(SOUT,QSOUT,SA,SB,RERR,AERR,LCODE)
      IF (LCODE .GT. 0) GO TO 140
      QSOUT=QOFS(YOLD(NP1),YPOLD(NP1),Y(NP1),YP(NP1),DELS,SOUT) - 1.0
      GO TO 130
C IF LAMBDA = 1 WERE BRACKETED,  ROOT  CANNOT FAIL.
140   IF (LCODE .GT. 2) THEN
        IFLAG=6
        RETURN
      ENDIF
C
C CALCULATE Q(SA) AS THE INITIAL POINT FOR A NEWTON ITERATION.
      DO 150 JW=1,NP1
        WORK(IW+JW-1)=QOFS(YOLD(JW),YPOLD(JW),Y(JW),YP(JW),DELS,SA)
150   CONTINUE
C CALCULATE NEWTON STEP AT Q(SA).
      CALL TANGNS(SA,WORK(IW),WORK(IWP),WORK(ITZ),YPOLD,A,QR,LENQR,
     $   PIVOT,WORK(IPP),WORK(IRHO),WORK(ITANGW),NFE,N,IFLAG,
     $   PAR,IPAR)
      IF (IFLAG .GT. 0) RETURN
C NEXT POINT = CURRENT POINT + NEWTON STEP.
      CALL DAXPY(NP1,1.0D0,WORK(ITZ),1,WORK(IW),1)
C GET THE TANGENT  WP  AT  W  AND THE NEXT NEWTON STEP IN  TZ .
      CALL TANGNS(SA,WORK(IW),WORK(IWP),WORK(ITZ),YPOLD,A,QR,LENQR,
     $   PIVOT,WORK(IPP),WORK(IRHO),WORK(ITANGW),NFE,N,IFLAG,
     $   PAR,IPAR)
      IF (IFLAG .GT. 0) RETURN
C TAKE NEWTON STEP AND CHECK CONVERGENCE.
      CALL DAXPY(NP1,1.0D0,WORK(ITZ),1,WORK(IW),1)
      IF ((ABS(WORK(IW+N)-1.0) .LE. RERR+AERR) .AND.
     $   (DNRM2(N,WORK(ITZ),1) .LE. RERR*DNRM2(N,WORK(IW),1)+AERR))
     $   THEN
        CALL DCOPY(NP1,WORK(IW),1,Y,1)
        RETURN
      ENDIF
C IF THE ITERATION HAS NOT CONVERGED, DISCARD ONE OF THE OLD POINTS
C SUCH THAT  LAMBDA = 1  IS STILL BRACKETED.
      IF ((YOLD(NP1)-1.0)*(WORK(IW+N)-1.0) .GT. 0.0) THEN
        CALL DCOPY(NP1,WORK(IW),1,YOLD,1)
        CALL DCOPY(NP1,WORK(IWP),1,YPOLD,1)
      ELSE
        CALL DCOPY(NP1,WORK(IW),1,Y,1)
        CALL DCOPY(NP1,WORK(IWP),1,YP,1)
      ENDIF
300   CONTINUE
C
C ***** END OF MAIN LOOP. *****
C
C THE ALTERNATING OSCULATORY CUBIC INTERPOLATION AND NEWTON ITERATION
C HAS NOT CONVERGED IN  LIMIT  STEPS.  ERROR RETURN.
      IFLAG=6
      RETURN
      END
        SUBROUTINE ROOTQF(N,NFE,IFLAG,RELERR,ABSERR,Y,YP,YOLD,
     $     YPOLD,A,QT,R,DZ,Z,W,T,F0,F1,PAR,IPAR)
C
C ROOTQF  FINDS THE POINT  YBAR = (1, XBAR)  ON THE ZERO CURVE OF THE
C HOMOTOPY MAP.  IT STARTS WITH TWO POINTS  YOLD=(LAMBDAOLD,XOLD)  AND
C Y=(LAMBDA,X)  SUCH THAT  LAMBDAOLD < 1 <= LAMBDA, AND ALTERNATES
C BETWEEN USING A SECANT METHOD TO FIND A PREDICTED POINT ON THE
C HYPERPLANE  LAMBDA=1, AND TAKING A QUASI-NEWTON STEP TO RETURN TO THE
C ZERO CURVE OF THE HOMOTOPY MAP.
C
C
C ON INPUT:
C
C N = DIMENSION OF X.
C
C NFE = NUMBER OF JACOBIAN MATRIX EVALUATIONS.
C
C IFLAG = -2, -1, OR 0, INDICATING THE PROBLEM TYPE.
C
C RELERR, ABSERR = RELATIVE AND ABSOLUTE ERROR VALUES.  THE ITERATION IS
C    CONSIDERED TO HAVE CONVERGED WHEN A POINT Y=(LAMBDA,X) IS FOUND
C    SUCH THAT
C
C    |Y(1) - 1| <= RELERR + ABSERR              AND
C
C    ||DZ|| <= RELERR*||Y|| + ABSERR,           WHERE
C
C    DZ  IS THE QUASI-NEWTON STEP TO Y.
C
C Y(1:N+1) = POINT (LAMBDA(S), X(S)) ON ZERO CURVE OF HOMOTOPY MAP.
C
C YP(1:N+1) = UNIT TANGENT VECTOR TO THE ZERO CURVE OF THE HOMOTOPY MAP
C    AT  Y.
C
C YOLD(1:N+1) = A POINT DIFFERENT FROM  Y  ON THE ZERO CURVE.
C
C YPOLD(1:N+1) = UNIT TANGENT VECTOR TO THE ZERO CURVE OF THE HOMOTOPY
C    MAP AT  YOLD.
C
C A(1:*) = PARAMETER VECTOR IN THE HOMOTOPY MAP.
C
C QT(1:N+1,1:N+1) CONTAINS  Q  TRANSPOSE OF THE QR FACTORIZATION OF
C    THE AUGMENTED JACOBIAN MATRIX EVALUATED AT THE POINT Y.
C
C R((N+1)*(N+2)/2) CONTAINS THE UPPER TRIANGLE OF THE R PART OF
C    OF THE QR FACTORIZATION, STORED BY ROWS.
C
C DZ(1:N+1), Z(1:N+1), W(1:N+1), T(1:N+1), F0(1:N+1), F1(1:N+1)
C    ARE WORK ARRAYS USED FOR THE QUASI-NEWTON STEP AND THE SECANT
C    STEP.
C
C PAR(1:*)  AND  IPAR(1:*)  ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS,
C    WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES
C    RHO, RHOJAC.
C
C
C ON OUTPUT:
C
C N, RELERR, ABSERR, AND A  ARE UNCHANGED.
C
C NFE  HAS BEEN UPDATED.
C
C IFLAG
C    = -2, -1, OR 0 (UNCHANGED) ON A NORMAL RETURN.
C
C    = 4 IF A SINGULAR JACOBIAN MATRIX OCCURRED.  THE
C        ITERATION WAS NOT COMPLETED.
C
C    = 6 IF THE ITERATION FAILED TO CONVERGE.  Y  AND  YOLD  CONTAIN
C        THE LAST TWO POINTS OBTAINED BY QUASI-NEWTON STEPS, AND  YP
C        CONTAINS A POINT OPPOSITE OF THE HYPERPLANE  LAMBDA=1  FROM
C        Y.
C
C Y  IS THE POINT ON THE ZERO CURVE OF THE HOMOTOPY MAP AT  LAMBDA = 1.
C
C YP  AND  YOLD  CONTAIN POINTS NEAR THE SOLUTION.
C
C CALLS  D1MACH, DAXPY, DCOPY, DDOT, DNRM2, F (OR RHO),
C        QRSLQF, ROOT, UPQRQF.
C
C ***** DECLARATIONS *****
C
C     FUNCTION DECLARATIONS
C
        DOUBLE PRECISION D1MACH, DDOT, DNRM2, QOFS
C
C     LOCAL VARIABLES
C
        DOUBLE PRECISION AERR, DD001, DD0011, DD01, DD011, DELS, ETA,
     $     ONE, P0, P1, PP0, PP1, QSOUT, RERR, S, SA, SB, SOUT,
     $     U, ZERO
        INTEGER ISTEP, I, LCODE, LIMIT,NP1
        LOGICAL BRACK
C
C     SCALAR ARGUMENTS
C
        DOUBLE PRECISION RELERR, ABSERR
        INTEGER N, NFE, IFLAG
C
C     ARRAY DECLARATIONS
C
        DOUBLE PRECISION Y(N+1), YP(N+1), YOLD(N+1), YPOLD(N+1), A(N),
     $     QT(N+1:N+1), R((N+1)*(N+2)/2), DZ(N+1), Z(N+1), W(N+1),
     $     T(N+1), F0(N+1), F1(N+1), PAR(1)
        INTEGER IPAR(1)
C
C ***** END OF DECLARATIONS *****
C
C
C DEFINITION OF HERMITE CUBIC INTERPOLANT VIA DIVIDED DIFFERENCES.
C
        DD01(P0,P1,DELS)=(P1-P0)/DELS
        DD001(P0,PP0,P1,DELS)=(DD01(P0,P1,DELS)-PP0)/DELS
        DD011(P0,P1,PP1,DELS)=(PP1-DD01(P0,P1,DELS))/DELS
        DD0011(P0,PP0,P1,PP1,DELS)=(DD011(P0,P1,PP1,DELS) -
     $                              DD001(P0,PP0,P1,DELS))/DELS
        QOFS(P0,PP0,P1,PP1,DELS,S)=((DD0011(P0,PP0,P1,PP1,DELS)*
     $     (S-DELS) + DD001(P0,PP0,P1,DELS))*S + PP0)*S + P0
C
C ***** FIRST EXECUTABLE STATEMENT *****
C
C ***** INITIALIZATION *****
C
C ETA = PARAMETER FOR BROYDEN'S UPDATE.
C LIMIT = MAXIMUM NUMBER OF ITERATIONS ALLOWED.
C
        ONE=1.0
        ZERO=0.0
        U=D1MACH(4)
        RERR=MAX(RELERR,U)
        AERR=MAX(ABSERR,ZERO)
        NP1=N+1
        ETA = 100.0*U
        LIMIT = 2*(INT(-LOG10(AERR+RERR*DNRM2(NP1,Y,1)))+1)
C
C F0 = (RHO(Y), YP*Y) TRANSPOSE.
C
        IF (IFLAG .EQ. -2) THEN
C
C         CURVE TRACKING PROBLEM.
C
          CALL RHO(A,Y(1),Y(2),F0,PAR,IPAR)
        ELSE IF (IFLAG .EQ. -1) THEN
C
C         ZERO FINDING PROBLEM.
C
          CALL F(Y(2),F0)
          DO 10 I=1,N
            F0(I) = Y(1)*F0(I) + (1.0-Y(1))*(Y(I+1)-A(I))
10        CONTINUE
        ELSE
C
C         FIXED POINT PROBLEM.
C
          CALL F(Y(2),F0)
          DO 20 I=1,N
            F0(I) = Y(1)*(A(I)-F0(I))+Y(I+1)-A(I)
20        CONTINUE
        END IF
        F0(NP1) = DDOT(NP1,YP,1,Y,1)
C
C ***** END OF INITIALIZATION BLOCK *****
C
C ***** COMPUTE FIRST INTERPOLANT WITH A HERMITE CUBIC *****
C
C FIND DISTANCE BETWEEN Y AND YOLD.  DZ=||Y-YOLD||.
C
        CALL DCOPY(NP1,Y,1,DZ,1)
        CALL DAXPY(NP1,-ONE,YOLD,1,DZ,1)
        DELS=DNRM2(NP1,DZ,1)
C
C USING TWO POINTS AND TANGENTS ON THE HOMOTOPY ZERO CURVE, CONSTRUCT
C THE HERMITE CUBIC INTERPOLANT Q(S).  THEN USE  ROOT  TO FIND THE S
C CORRESPONDING TO  LAMBDA = 1.  THE TWO POINTS ON THE ZERO CURVE ARE
C ALWAYS CHOSEN TO BRACKET  LAMBDA=1, WITH THE BRACKETING INTERVAL
C ALWAYS BEING [0, DELS].
C
        SA=0.0
        SB=DELS
        LCODE=1
40      CALL ROOT(SOUT,QSOUT,SA,SB,RERR,AERR,LCODE)
          IF (LCODE .GT. 0) GO TO 50
          QSOUT=QOFS(YOLD(1),YPOLD(1),Y(1),YP(1),DELS,SOUT) - 1.0
          GO TO 40
C
C     IF  LAMBDA = 1  WERE BRACKETED,  ROOT  CANNOT FAIL.
C
50      IF (LCODE .GT. 2) THEN
          IFLAG=6
          RETURN
        ENDIF
C
C CALCULATE  Q(SA)  AS THE INITIAL POINT FOR A NEWTON ITERATION.
C
        DO 60 I=1,NP1
          Z(I)=QOFS(YOLD(I),YPOLD(I),Y(I),YP(I),DELS,SA)
60      CONTINUE
C
C CALCULATE DZ = Z-Y.
C
        CALL DCOPY(NP1,Z,1,DZ,1)
        CALL DAXPY(NP1,-ONE,Y,1,DZ,1)
C
C ***** END OF CALCULATION OF CUBIC INTERPOLANT *****
C
C TANGENT INFORMATION  YPOLD  IS NO LONGER NEEDED.  HEREAFTER,  YPOLD
C REPRESENTS THE MOST RECENT POINT WHICH IS ON THE OPPOSITE SIDE OF
C LAMBDA=1  FROM  Y.
C
C ***** PREPARE FOR MAIN LOOP *****
C
        CALL DCOPY(NP1,YOLD,1,YPOLD,1)
C
C INITIALIZE  BRACK  TO INDICATE THAT THE POINTS  Y  AND  YOLD  BRACKET
C LAMBDA=1,  THUS YOLD = YPOLD.
C
        BRACK = .TRUE.
C
C ***** MAIN LOOP *****
C
        DO 300 ISTEP=1,LIMIT
C
C UPDATE JACOBIAN MATRIX.
C
C       F1=(RHO(Z), YP*Z) TRANSPOSE.
C
          IF (IFLAG .EQ. -2) THEN
            CALL RHO(A,Z(1),Z(2),F1,PAR,IPAR)
          ELSE IF (IFLAG .EQ. -1) THEN
            CALL F(Z(2),F1)
            DO 80 I=1,N
              F1(I) = Z(1)*F1(I) + (1-Z(1))*(Z(I+1)-A(I))
  80        CONTINUE
          ELSE
            CALL F(Z(2),F1)
            DO 90 I=1,N
              F1(I) = Z(1)*(A(I)-F1(I))+Z(I+1)-A(I)
  90        CONTINUE
          END IF
          F1(NP1) = DDOT(NP1,YP,1,Z,1)
C
C
C PERFORM BROYDEN UPDATE.
C
          CALL UPQRQF(NP1,ETA,DZ,F0,F1,QT,R,W,T)
C
C QUASI-NEWTON STEP.
C
C       COMPUTE NEWTON STEP.
C
          CALL DCOPY(N,F1,1,DZ,1)
          CALL DSCAL(N,-ONE,DZ,1)
          DZ(NP1) = 0.0
          CALL QRSLQF(QT,R,DZ,W,NP1)
C
C       TAKE NEWTON STEP.
C
          CALL DCOPY(NP1,Z,1,W,1)
          CALL DAXPY(NP1,ONE,DZ,1,Z,1)
C
C       CHECK FOR CONVERGENCE.
C
          IF ((ABS(Z(1)-1.0) .LE. RERR+AERR) .AND.
     $        (DNRM2(NP1,DZ,1) .LE. RERR*DNRM2(N,Z(2),1)+AERR)) THEN
             CALL DCOPY(NP1,Z,1,Y,1)
             RETURN
          END IF
C
C PREPARE FOR NEXT ITERATION.
C
C       F0 = F1.
C
          CALL DCOPY(NP1,F1,1,F0,1)
C
C       IF  Z(1) = 1.0  THEN PERFORM QUASI-NEWTON ITERATION AGAIN
C       WITHOUT COMPUTING A NEW PREDICTOR.
C
          IF (ABS(Z(1)-1.0) .LE. RERR+AERR) THEN
             CALL DCOPY(NP1,Z,1,DZ,1)
             CALL DAXPY(NP1,-ONE,W,1,DZ,1)
             GOTO 300
          END IF
C
C       UPDATE  Y  AND  YOLD.
C
          CALL DCOPY(NP1,Y,1,YOLD,1)
          CALL DCOPY(NP1,Z,1,Y,1)
C
C       UPDATE  YPOLD  SUCH THAT  YPOLD  IS THE MOST RECENT POINT
C       OPPOSITE OF  LAMBDA=1  FROM  Y.  SET  BRACK = .TRUE.  IFF
C       Y & YOLD  BRACKET  LAMBDA=1  SO THAT  YPOLD=YOLD.
C
          IF ((Y(1)-1.0)*(YOLD(1)-1.0) .GT. 0) THEN
            BRACK = .FALSE.
          ELSE
            BRACK = .TRUE.
            CALL DCOPY(NP1,YOLD,1,YPOLD,1)
          END IF
C
C       COMPUTE DELS = ||Y-YPOLD||.
C
          CALL DCOPY(NP1,Y,1,DZ,1)
          CALL DAXPY(NP1,-ONE,YPOLD,1,DZ,1)
          DELS=DNRM2(NP1,DZ,1)
C
C       COMPUTE  DZ  FOR THE LINEAR PREDICTOR   Z = Y + DZ,
C           WHERE  DZ = SA*(YOLD-Y).
C
          SA = (1.0-Y(1))/(YOLD(1)-Y(1))
          CALL DCOPY(NP1,YOLD,1,DZ,1)
          CALL DAXPY(NP1,-ONE,Y,1,DZ,1)
          CALL DSCAL(NP1,SA,DZ,1)
C
C       TO INSURE STABILITY, THE LINEAR PREDICTION MUST BE NO FARTHER
C       FROM  Y  THAN  YPOLD  IS.  THIS IS GUARANTEED IF  BRACK = .TRUE.
C       IF LINEAR PREDICTION IS TOO FAR AWAY, USE BRACKETING POINTS
C       TO COMPUTE LINEAR PREDICTION.
C
          IF (.NOT. BRACK) THEN
            IF (DNRM2(NP1,DZ,1) .GT. DELS) THEN
C
C             COMPUTE  DZ = SA*(YPOLD-Y).
C
              SA = (1.0-Y(1))/(YPOLD(1)-Y(1))
              CALL DCOPY(NP1,YPOLD,1,DZ,1)
              CALL DAXPY(NP1,-ONE,Y,1,DZ,1)
              CALL DSCAL(NP1,SA,DZ,1)
            END IF
          END IF
C
C       COMPUTE PREDICTOR Z = Y+DZ, AND DZ = NEW Z  - OLD Z (USED FOR
C         QUASI-NEWTON UPDATE).
C
          CALL DAXPY(NP1,ONE,DZ,1,Z,1)
          CALL DCOPY(NP1,Z,1,DZ,1)
          CALL DAXPY(NP1,-ONE,W,1,DZ,1)
  300   CONTINUE
C
C ***** END OF MAIN LOOP. *****
C
C THE ALTERNATING OSCULATORY LINEAR PREDICTION AND QUASI-NEWTON
C CORRECTION HAS NOT CONVERGED IN  LIMIT  STEPS.  ERROR RETURN.
        IFLAG=6
        RETURN
C
C ***** END OF SUBROUTINE ROOTQF *****
        END
        SUBROUTINE ROOTQS(N,NFE,IFLAG,LENQR,RELERR,ABSERR,Y,YP,YOLD,
     $     YPOLD,A,QR,PIVOT,PP,RHOVEC,Z,DZ,WORK,PAR,IPAR)
C
C ROOTQS  FINDS THE POINT  YBAR = (XBAR, 1)  ON THE ZERO CURVE OF THE
C HOMOTOPY MAP.  IT STARTS WITH TWO POINTS  YOLD=(XOLD,LAMBDAOLD)  AND
C Y=(X,LAMBDA)  SUCH THAT  LAMBDAOLD < 1 <= LAMBDA, AND ALTERNATES
C BETWEEN USING A SECANT METHOD TO FIND A PREDICTED POINT ON THE
C HYPERPLANE  LAMBDA=1, AND TAKING A NEWTON STEP TO RETURN TO THE
C ZERO CURVE OF THE HOMOTOPY MAP.
C
C
C ON INPUT:
C
C N = DIMENSION OF X.
C
C NFE = NUMBER OF JACOBIAN MATRIX EVALUATIONS.
C
C IFLAG = -2, -1, OR 0, INDICATING THE PROBLEM TYPE.
C
C LENQR = THE LENGTH OF THE ONE-DIMENSIONAL ARRAY  QR.
C
C RELERR, ABSERR = RELATIVE AND ABSOLUTE ERROR VALUES.  THE ITERATION IS
C    CONSIDERED TO HAVE CONVERGED WHEN A POINT Y=(X,LAMBDA) IS FOUND
C    SUCH THAT
C
C    |Y(N+1) - 1| <= RELERR + ABSERR              AND
C
C    ||DZ|| <= RELERR*||Y|| + ABSERR,           WHERE
C
C    DZ  IS THE NEWTON STEP TO Y.
C
C Y(1:N+1) = POINT (X(S),LAMBDA(S)) ON ZERO CURVE OF HOMOTOPY MAP.
C
C YP(1:N+1) = UNIT TANGENT VECTOR TO THE ZERO CURVE OF THE HOMOTOPY MAP
C    AT  Y.
C
C YOLD(1:N+1) = A POINT DIFFERENT FROM  Y  ON THE ZERO CURVE.
C
C YPOLD(1:N+1) = UNIT TANGENT VECTOR TO THE ZERO CURVE OF THE HOMOTOPY
C    MAP AT  YOLD.
C
C A(1:*) = PARAMETER VECTOR IN THE HOMOTOPY MAP.
C
C QR(1:LENQR)  IS A WORK ARRAY CONTAINING THE N X N SYMMETRIC
C    JACOBIAN MATRIX WITH RESPECT TO X STORED IN PACKED SKYLINE
C    STORAGE FORMAT.  LENQR  AND  PIVOT  DESCRIBE THE DATA
C    STRUCTURE IN  QR.  (SEE SUBROUTINE  PCGQS  FOR A DESCRIPTION
C    OF THIS DATA STRUCTURE).
C
C PIVOT(1:N+2)  IS A WORK ARRAY WHOSE FIRST N+1 COMPONENTS CONTAIN
C    THE INDICES OF THE DIAGONAL ELEMENTS OF THE N X N SYMMETRIC
C    JACOBIAN MATRIX (WITH RESPECT TO X) WITHIN  QR.
C
C PP(1:N)  IS A WORK ARRAY CONTAINING THE NEGATIVE OF THE LAST COLUMN
C    OF THE JACOBIAN MATRIX  -[D RHO/D LAMBDA].
C
C RHOVEC(1:N+1), Z(1:N+1), DZ(1:N+1)  ARE ALL WORK ARRAYS
C    USED TO CALCULATE THE NEWTON STEPS.
C
C WORK(1:6*(N+1)+LENQR)  IS A WORK ARRAY USED BY THE CONJUGATE GRADIENT
C    ALGORITHM TO SOLVE LINEAR SYSTEMS.
C
C PAR(1:*)  AND  IPAR(1:*)  ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS,
C    WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES
C    RHO, RHOJS.
C
C
C ON OUTPUT:
C
C N, LENQR, RELERR, ABSERR, A  ARE UNCHANGED.
C
C NFE  HAS BEEN UPDATED.
C
C IFLAG
C    = -2, -1, OR 0 (UNCHANGED) ON A NORMAL RETURN.
C
C    = 4 IF A SINGULAR JACOBIAN MATRIX HAS OCCURRED.  THE
C        ITERATION WAS NOT COMPLETED.
C
C    = 6 IF THE ITERATION FAILED TO CONVERGE.  Y  AND  YOLD  CONTAIN
C        THE LAST TWO POINTS OBTAINED BY NEWTON STEPS, AND  YP
C        CONTAINS A POINT OPPOSITE OF THE HYPERPLANE  LAMBDA=1  FROM  Y.
C
C Y  IS THE POINT ON THE ZERO CURVE OF THE HOMOTOPY MAP AT  LAMBDA = 1.
C
C YP,  AND  YOLD  CONTAIN POINTS NEAR THE SOLUTION.
C
C CALLS  D1MACH, DAXPY, DCOPY, DNRM2, F (OR RHO),
C        FJACS (OR RHOJS), PCGQS, ROOT
C
C ***** DECLARATIONS *****
C
C     FUNCTION DECLARATIONS
C
        DOUBLE PRECISION D1MACH, DNRM2, QOFS
C
C     LOCAL VARIABLES
C
        DOUBLE PRECISION AERR, DD001, DD0011, DD01, DD011, DELS,
     $     LAMBDA, ONE, P0, P1, PP0, PP1, QSOUT, RERR, S, SA, SB,
     $     SIGMA, SOUT, U, ZERO
        INTEGER ISTEP, I, J, LCODE, LIMIT, NP1, ZU
        LOGICAL BRACK
C
C     SCALAR ARGUMENTS
C
        DOUBLE PRECISION RELERR, ABSERR
        INTEGER N, NFE, IFLAG, LENQR
C
C     ARRAY DECLARATIONS
C
        DOUBLE PRECISION Y(N+1), YP(N+1), YOLD(N+1), YPOLD(N+1), A(N),
     $     QR(LENQR), PP(N), RHOVEC(N+1), Z(N+1), DZ(N+1),
     $     WORK(6*(N+1)+LENQR), PAR(1)
        INTEGER PIVOT(N+2), IPAR(1)
C
C ***** END OF DECLARATIONS *****
C
C
C DEFINITION OF HERMITE CUBIC INTERPOLANT VIA DIVIDED DIFFERENCES.
C
        DD01(P0,P1,DELS)=(P1-P0)/DELS
        DD001(P0,PP0,P1,DELS)=(DD01(P0,P1,DELS)-PP0)/DELS
        DD011(P0,P1,PP1,DELS)=(PP1-DD01(P0,P1,DELS))/DELS
        DD0011(P0,PP0,P1,PP1,DELS)=(DD011(P0,P1,PP1,DELS) -
     $                              DD001(P0,PP0,P1,DELS))/DELS
        QOFS(P0,PP0,P1,PP1,DELS,S)=((DD0011(P0,PP0,P1,PP1,DELS)*
     $     (S-DELS) + DD001(P0,PP0,P1,DELS))*S + PP0)*S + P0
C
C ***** FIRST EXECUTABLE STATEMENT *****
C
C ***** INITIALIZATION *****
C
C LIMIT = MAXIMUM NUMBER OF ITERATIONS ALLOWED.
C
        ONE=1.0
        ZERO=0.0
        U=D1MACH(4)
        RERR=MAX(RELERR,U)
        AERR=MAX(ABSERR,ZERO)
        NP1=N+1
        LIMIT = 2*(INT(-LOG10(AERR+RERR*DNRM2(NP1,Y,1)))+1)
        ZU=N+2
C
C ***** END OF INITIALIZATION BLOCK *****
C
C ***** COMPUTE FIRST INTERPOLANT WITH A HERMITE CUBIC *****
C
C FIND DISTANCE BETWEEN Y AND YOLD.  DZ=||Y-YOLD||.
C
        CALL DCOPY(NP1,Y,1,DZ,1)
        CALL DAXPY(NP1,-ONE,YOLD,1,DZ,1)
        DELS=DNRM2(NP1,DZ,1)
C
C USING TWO POINTS AND TANGENTS ON THE HOMOTOPY ZERO CURVE, CONSTRUCT
C THE HERMITE CUBIC INTERPOLANT Q(S).  THEN USE  ROOT  TO FIND THE  S
C CORRESPONDING TO  LAMBDA = 1.  THE TWO POINTS ON THE ZERO CURVE ARE
C ALWAYS CHOSEN TO BRACKET  LAMBDA=1, WITH THE BRACKETING INTERVAL
C ALWAYS BEING [0, DELS].
C
        SA=0.0
        SB=DELS
        LCODE=1
40      CALL ROOT(SOUT,QSOUT,SA,SB,RERR,AERR,LCODE)
          IF (LCODE .GT. 0) GO TO 50
          QSOUT=QOFS(YOLD(NP1),YPOLD(NP1),Y(NP1),YP(NP1),DELS,SOUT)
     $       - 1.0
          GO TO 40
C
C     IF  LAMBDA = 1  WERE BRACKETED,  ROOT  CANNOT FAIL.
C
50      IF (LCODE .GT. 2) THEN
          IFLAG=6
          RETURN
        ENDIF
C
C CALCULATE  Q(SA)  AS THE INITIAL POINT FOR A NEWTON ITERATION.
C
        DO 60 I=1,NP1
          Z(I)=QOFS(YOLD(I),YPOLD(I),Y(I),YP(I),DELS,SA)
60      CONTINUE
C
C ***** END OF CALCULATION OF CUBIC INTERPOLANT *****
C
C TANGENT INFORMATION  YPOLD  IS NO LONGER NEEDED.  HEREAFTER,  YPOLD
C REPRESENTS THE MOST RECENT POINT WHICH IS ON THE OPPOSITE SIDE OF
C LAMBDA=1  FROM  Y.
C
C ***** PREPARE FOR MAIN LOOP *****
C
        CALL DCOPY(NP1,YOLD,1,YPOLD,1)
C
C INITIALIZE  BRACK  TO INDICATE THAT THE POINTS  Y  AND  YOLD  BRACKET
C LAMBDA=1,  THUS YOLD = YPOLD.
C
        BRACK = .TRUE.
C
C ***** MAIN LOOP *****
C
        DO 300 ISTEP=1,LIMIT
C
C SET STARTING POINTS FOR CONJUGATE GRADIENT ALGORITHM TO ZERO.
C
          DO 70 J=ZU,ZU+2*N+1
            WORK(J) = 0.0
  70      CONTINUE
C
C COMPUTE NEWTON STEP.
C
C       COMPUTE QR = [D RHO/DX], RHOVEC = RHO, -PP = (D RHO/D LAMBDA).
C
          LAMBDA = Z(NP1)
          IF (IFLAG .EQ. -2) THEN
C
C           CURVE TRACKING PROBLEM.
C
            CALL RHOJS(A,LAMBDA,Z,QR,LENQR,PIVOT,PP,PAR,IPAR)
            CALL RHO(A,LAMBDA,Z,RHOVEC,PAR,IPAR)
          ELSE IF (IFLAG .EQ. -1) THEN
C
C           ZERO FINDING PROBLEM.
C
            CALL FJACS(Z,QR,LENQR,PIVOT)
            CALL DSCAL(LENQR,LAMBDA,QR,1)
            SIGMA = 1.0-LAMBDA
            DO 80 J=1,N
              QR(PIVOT(J))=QR(PIVOT(J))+SIGMA
  80        CONTINUE
            CALL DCOPY(N,Z,1,RHOVEC,1)
            CALL DAXPY(N,-ONE,A,1,RHOVEC,1)
            CALL F(Z,PP)
            CALL DSCAL(N,-ONE,PP,1)
            CALL DAXPY(N,ONE,RHOVEC,1,PP,1)
            CALL DAXPY(N,-LAMBDA,PP,1,RHOVEC,1)
          ELSE
C
C           FIXED POINT PROBLEM.
C
            CALL FJACS(Z,QR,LENQR,PIVOT)
            CALL DSCAL(LENQR,-LAMBDA,QR,1)
            DO 90 J=1,N
              QR(PIVOT(J))=QR(PIVOT(J))+1.0
  90        CONTINUE
            CALL DCOPY(N,Z,1,RHOVEC,1)
            CALL DAXPY(N,-ONE,A,1,RHOVEC,1)
            CALL F(Z,PP)
            CALL DAXPY(N,-ONE,A,1,PP,1)
            CALL DAXPY(N,-LAMBDA,PP,1,RHOVEC,1)
          END IF
          RHOVEC(NP1) = 0.0
          NFE = NFE+1
C
C       SOLVE SYSTEM TO FIND NEWTON STEP.
C
          CALL PCGQS(N,QR,LENQR,PIVOT,PP,YP,RHOVEC,DZ,WORK,IFLAG)
          IF (IFLAG .GT. 0) RETURN
C
C       TAKE NEWTON STEP.
C
          CALL DAXPY(NP1,ONE,DZ,1,Z,1)
C
C       CHECK FOR CONVERGENCE.
C
          IF ((ABS(Z(NP1)-1.0) .LE. RERR+AERR) .AND.
     $        (DNRM2(NP1,DZ,1) .LE. RERR*DNRM2(N,Z,1)+AERR)) THEN
             RETURN
          END IF
C
C PREPARE FOR NEXT ITERATION.
C
C       IF LAMBDA COMPONENT OF  Z=1, THEN DO NOT COMPUTE A
C       NEW PREDICTOR, BUT RATHER CONTINUE WITH ANOTHER NEWTON
C       ITERATION.
C
          IF (ABS(Z(NP1)-1.0) .LT. RERR+AERR) GOTO 300
C
C       UPDATE  Y  AND  YOLD.
C
          CALL DCOPY(NP1,Y,1,YOLD,1)
          CALL DCOPY(NP1,Z,1,Y,1)
C
C       UPDATE  YPOLD  SUCH THAT  YPOLD  IS THE MOST RECENT POINT OPPOSI
C       OF  LAMBDA=1  FROM  Y.  SET  BRACK = .TRUE.  IFF  Y & YOLD
C       BRACKET  LAMBDA=1  SO THAT  YPOLD=YOLD.
C
          IF ((YOLD(NP1)-1.0)*(Y(NP1)-1.0) .GT. 0) THEN
            BRACK = .FALSE.
          ELSE
            BRACK = .TRUE.
            CALL DCOPY(NP1,YOLD,1,YPOLD,1)
          END IF
C
C       COMPUTE DELS = ||Y-YPOLD||.
C
          CALL DCOPY(NP1,Y,1,DZ,1)
          CALL DAXPY(NP1,-ONE,YPOLD,1,DZ,1)
          DELS=DNRM2(NP1,DZ,1)
C
C       COMPUTE  DZ  FOR THE LINEAR PREDICTOR   Z = DZ + Y,
C           WHERE  DZ = SA*(YOLD-Y).
C
          SA = (1.0-Y(NP1))/(YOLD(NP1)-Y(NP1))
          CALL DCOPY(NP1,YOLD,1,DZ,1)
          CALL DAXPY(NP1,-ONE,Y,1,DZ,1)
          CALL DSCAL(NP1,SA,DZ,1)
C
C       TO INSURE STABILITY, THE LINEAR PREDICTION MUST BE NO FARTHER
C       FROM  Y  THAN  YPOLD  IS.  THIS IS GUARANTEED IF  BRACK = .TRUE.
C       IF LINEAR PREDICTION IS TOO FAR AWAY, USE BRACKETING POINTS
C       TO COMPUTE LINEAR PREDICTION.
C
          IF (.NOT. BRACK) THEN
            IF (DNRM2(NP1,DZ,1) .GT. DELS) THEN
C
C             COMPUTE DZ = SA*(YPOLD-Y).
C
              SA = (1.0-Y(NP1))/(YPOLD(NP1)-Y(NP1))
              CALL DCOPY(NP1,YPOLD,1,DZ,1)
              CALL DAXPY(NP1,-ONE,Y,1,DZ,1)
              CALL DSCAL(NP1,SA,DZ,1)
            END IF
          END IF
C
C       COMPUTE PREDICTOR Z = DZ+Y.
C
          CALL DCOPY(NP1,Y,1,Z,1)
          CALL DAXPY(NP1,ONE,DZ,1,Z,1)
  300   CONTINUE
C
C ***** END OF MAIN LOOP. *****
C
C THE ALTERNATING OSCULATORY LINEAR PREDICTION AND NEWTON
C CORRECTION HAS NOT CONVERGED IN  LIMIT  STEPS.  ERROR RETURN.
        IFLAG=6
        RETURN
C
C ***** END OF SUBROUTINE ROOTQS *****
        END
      SUBROUTINE SCLGNP(N,NN,MMAXT,NUMT,DEG,MODE,EPS0,COEF,
     $                    NNUMT,DDEG,CCOEF,ALPHA,BETA,RWORK,XWORK,
     $                                      FACV,FACE,COESCL,IERR)
C
C SCLGNP  SCALES THE COEFFICIENTS OF A POLYNOMIAL SYSTEM OF N
C EQUATIONS IN N UNKNOWNS, F(X)=0, WHERE THE JTH TERM OF
C THE ITH EQUATION LOOKS LIKE:
C
C    COEF(I,J) * X(1)**DEG(I,1,J) ... X(N)**DEG(I,N,J)
C
C THE ITH EQUATION IS SCALED BY 10**FACE(I).  THE KTH
C VARIABLE IS SCALED BY 10**FACV(K).  IN OTHER WORDS, X(K) =
C 10**FACV(K) * Y(K), WHERE Y SOLVES THE SCALED EQUATION.
C THE SCALED EQUATION HAS THE SAME FORM AS THE ORIGINAL
C EQUATION, EXCEPT THAT COESCL(I,J) REPLACES COEF(I,J), WHERE
C
C COESCL(I,J)=COEF(I,J)* 10**( FACE(I) + FACV(1)*DEG(I,1,J)+ ...
C                                       +FACV(N)*DEG(I,N,J) )
C
C THE CRITERION FOR GENERATING FACE AND FACV IS THAT OF
C MINIMIZING THE SUM OF SQUARES OF THE EXPONENTS OF THE SCALED
C COEFFICIENTS.  IT TURNS OUT THAT THIS CRITERION REDUCES TO
C SOLVING A SINGLE LINEAR SYSTEM, ALPHA*X = BETA, AS DEFINED
C IN THE CODE BELOW.  FURTHER, THE FORM OF THE POLYNOMIAL
C SYSTEM ALONE DETERMINES THE MATRIX ALPHA.  THUS, IN CASES
C IN WHICH MANY SYSTEMS OF THE SAME FORM, BUT WITH DIFFERENT
C COEFFICIENTS, ARE TO BE SCALED, THE MATRIX ALPHA IS
C UNCHANGED AND MAY BE FACTORED ONLY ONCE (BY  QRFAQF).  WHEN
C SCLGNP  IS CALLED WITH MODE=1,  SCLGNP  DOES NOT RECOMPUTE OR
C REFACTOR THE MATRIX ALPHA.  SEE MEINTJES AND MORGAN "A
C METHODOLOGY FOR SOLVING CHEMICAL EQUILIBRIUM SYSTEMS"
C (GENERAL MOTORS RESEARCH LABORATORIES TECHNICAL REPORT
C GMR-4971).
C
C SUBROUTINES CALLED DIRECTLY:  QRFAQF, QRSLQF.
C SUBROUTINES CALLED INDIRECTLY:  DAXPY, DCOPY, DDOT, DNRM2, DSCAL.
C
C ON INPUT:
C
C N  IS THE NUMBER OF EQUATIONS AND THE NUMBER OF VARIABLES.
C
C NN  IS THE DECLARED DIMENSION OF SEVERAL ARRAY INDICES.
C
C MMAXT  IS AN UPPER BOUND ON THE SET NUMT(I), I=1 TO N.
C
C NUMT(I)  IS THE NUMBER OF TERMS IN THE I-TH EQUATION FOR I=1 TO N.
C
C DEG(I,K,J)  IS THE DEGREE OF THE K-TH VARIABLE IN THE
C   J-TH TERM OF THE I-TH EQUATION FOR I=1 TO N, J=1 TO NUMT(I), AND
C   K=1 TO N.
C
C MODE
C  =1  THIS IS NOT THE FIRST CALL TO  SCLGNP, AND THE FORM OF THE
C      SYSTEM HAS NOT CHANGED.
C  =0  THIS IS THE FIRST CALL TO  SCLGNP.
C
C EPS0  ZERO-EPSILON FOR TERMS (TERMS LESS THAN  EPS0  IN MAGNITUDE
C   ARE TREATED AS ZERO BY THE SCALING ALGORITHM).
C
C COEF(I,J)  IS THE COEFFICIENT OF THE JTH TERM OF THE ITH EQUATION
C   FOR I=1 TO N AND J=1 TO NUMT(N).  (COEF(I,J) MAY BE ZERO.)
C
C NNUMT, DDEG, CCOEF, ALPHA, BETA, RWORK, AND  XWORK  ARE WORKSPACES.
C
C ON OUTPUT:
C
C N, NUMT, DEG, MODE, EPS0, AND  COEF  ARE UNCHANGED.
C
C FACV(I)  IS THE VARIABLE SCALE FACTOR FOR THE I-TH VARIABLE, FOR
C   I=1 TO N.
C
C FACE(I)  IS THE EQUATION SCALE FACTOR FOR THE I-TH EQUATION, FOR
C   I=1 TO N.
C
C COESCL(I,J)  IS THE SCALED VERSION OF COEFFICIENT  COEF(I,J), FOR
C   I=1 TO N, J=1 TO NUMT(I), UNLESS IERR=1.
C
C IERR
C   =0  IF SCALING MATRIX, ALPHA, IS WELL CONDITIONED.
C   =1  OTHERWISE.  IN THIS CASE, ALPHA IS "REPAIRED" AND A
C         SCALING IS COMPUTED.
C
C
C DECLARATION OF INPUT
      INTEGER N,NN,MMAXT,NUMT(NN),DEG(NN,NN+1,MMAXT)
      INTEGER MODE
      DOUBLE PRECISION EPS0,COEF
      DIMENSION COEF(NN,MMAXT)
C
C DECLARATION OF WORKSPACE
      INTEGER NNUMT,DDEG
      DOUBLE PRECISION CCOEF,ALPHA,BETA,RWORK,XWORK
      DIMENSION NNUMT(N),DDEG(N,N+1,MMAXT)
      DIMENSION CCOEF(N,MMAXT),ALPHA(2*N,2*N),BETA(2*N),
     $ RWORK(N*(2*N+1)),XWORK(2*N)
C
C DECLARATION OF OUTPUT
      INTEGER IERR
      DOUBLE PRECISION FACV,FACE,COESCL
      DIMENSION FACV(N),FACE(N),COESCL(N,MMAXT)
C
C DECLARATION OF VARIABLES
      INTEGER I,IDAMAX,IFLAG,INDEX,IRMAX,J,JJ,K,LENR,N2,S
      DOUBLE PRECISION D1MACH,DUM,LMFPN,NTUR,RTOL,SUM
C
      SAVE
C
      IERR=0
      N2=2*N
      LMFPN=D1MACH(2)
      NTUR=D1MACH(4)*N
      LENR=N*(N+1)/2
C
C  DELETE NEAR ZERO TERMS
      DO  60 I=1,N
         JJ=0
         NNUMT(I)=0
         DO 40 J=1,NUMT(I)
             IF(ABS(COEF(I,J)) .GT. EPS0) THEN
                JJ=JJ+1
                NNUMT(I)=NNUMT(I)+1
                  CCOEF(I,JJ)=COEF(I,J)
                  DO 20 K=1,N
                    DDEG(I,K,JJ)=DEG(I,K,J)
  20              CONTINUE
             END IF
  40     CONTINUE
  60  CONTINUE
      DO 90 I=1,N
          DO 80 J=1,NNUMT(I)
              COESCL(I,J)=LOG10(ABS(CCOEF(I,J)))
  80      CONTINUE
  90  CONTINUE
C
C SKIP OVER THE GENERATION AND DECOMPOSITON OF MATRIX ALPHA IF MODE=1
      IF (MODE .EQ. 0) THEN
C
C GENERATE THE MATRIX ALPHA
      DO 110 S=1,N
      DO 110 K=1,N
          ALPHA(S,K)=0
 110  CONTINUE
      DO 200 S=1,N
        ALPHA(S,S)=NNUMT(S)
 200  CONTINUE
      DO 300 S=1,N
        DO 300 I=1,N
          SUM=0
          DO 220 J=1,NNUMT(I)
            SUM=SUM+DDEG(I,S,J)
 220      CONTINUE
          ALPHA(N+S,I)=SUM
 300  CONTINUE
      DO 400 S=1,N
        DO 330 K=1,N
          SUM=0
          DO 320 I=1,N
            DO 310 J=1,NNUMT(I)
              SUM=SUM+DDEG(I,S,J)*DDEG(I,K,J)
 310        CONTINUE
 320      CONTINUE
          ALPHA(N+S,N+K)=SUM
 330    CONTINUE
 400  CONTINUE
      DO 500 S=1,N
        DO 500 K=1,N
          SUM=0
          DO 420 J=1,NNUMT(S)
            SUM=SUM+DDEG(S,K,J)
 420      CONTINUE
          ALPHA(S,N+K)=SUM
 500  CONTINUE
C
C COMPUTE QR FACTORIZATION OF MATRIX ALPHA
      CALL QRFAQF(ALPHA,RWORK,2*N,IFLAG)
C
C REPAIR ILL CONDITIONED SCALING MATRIX
      IRMAX=IDAMAX(LENR,RWORK,1)
      RTOL=RWORK(IRMAX)*NTUR
      INDEX=1
      DO 510 I=N,2,-1
        IF (ABS(RWORK(INDEX)) .LT. RTOL) THEN
          RWORK(INDEX)=LMFPN
          IERR=1
        ENDIF
      INDEX=INDEX+I
 510  CONTINUE
      IF (ABS(RWORK(INDEX)) .LT. RTOL) THEN
        RWORK(INDEX)=LMFPN
        IERR=1
      ENDIF
C
      ENDIF
C
C CONTROL PASSES HERE IF MODE=1
C
C
C GENERATE THE COLUMN BETA
      DO 600 S=1,N
        SUM=0
        DO 550 J=1,NNUMT(S)
          SUM=SUM+COESCL(S,J)
 550    CONTINUE
        BETA(S)=-SUM
 600  CONTINUE
      DO 700 S=1,N
        SUM=0
        DO 620 I=1,N
          DO 610 J=1,NNUMT(I)
            SUM=SUM+COESCL(I,J)*DDEG(I,S,J)
 610      CONTINUE
 620    CONTINUE
        BETA(N+S)=-SUM
 700  CONTINUE
C
C SOLVE THE LINEAR SYSTEM ALPHA * X = BETA
      CALL QRSLQF(ALPHA,RWORK,BETA,XWORK,2*N)
C
C GENERATE FACE, FACV, AND THE MATRIX COESCL
      DO 800 I=1,N
        FACE(I)=BETA(I)
        FACV(I)=BETA(N+I)
 800  CONTINUE
      DO 900 I=1,N
        DO 820 J=1,NUMT(I)
          DUM = ABS(COEF(I,J))
          IF (DUM .EQ. 0.0) THEN
            COESCL(I,J) = 0.0
          ELSE
            SUM = FACE(I) + LOG10( DUM )
            DO 810 K=1,N
              SUM = SUM + FACV(K)*DEG(I,K,J)
 810        CONTINUE
            COESCL(I,J) = SIGN(10.0**(SUM), COEF(I,J))
          ENDIF
 820    CONTINUE
 900  CONTINUE
      RETURN
      END
*
      SUBROUTINE SINTRP(X,Y,XOUT,YOUT,YPOUT,NEQN,KOLD,PHI,IVC,IV,KGI,GI,
     1                                                ALPHA,G,W,XOLD,P)
C
C***BEGIN PROLOGUE  SINTRP
C***DATE WRITTEN   740101   (YYMMDD)
C***REVISION DATE  840201   (YYMMDD)
C***CATEGORY NO.  D2A2
C***KEYWORDS  INITIAL VALUE ORDINARY DIFFERENTIAL EQUATIONS,
C             VARIABLE ORDER ADAMS METHODS, SMOOTH INTERPOLANT FOR
C             DEABM IN THE DEPAC PACKAGE
C***AUTHOR  SHAMPINE, L.F.,  SNLA
C           GORDON, M.K.
C             MODIFIED BY H.A. WATTS
C***PURPOSE  APPROXIMATES THE SOLUTION AT XOUT BY EVALUATING THE
C            POLYNOMIAL COMPUTED IN STEPS AT XOUT.  MUST BE USED IN
C            CONJUNCTION WITH STEPS.
C***DESCRIPTION
C
C   WRITTEN BY L. F. SHAMPINE AND M. K. GORDON
C
C   ABSTRACT
C
C
C   THE METHODS IN SUBROUTINE  STEPS  APPROXIMATE THE SOLUTION NEAR  X
C   BY A POLYNOMIAL.  SUBROUTINE  SINTRP  APPROXIMATES THE SOLUTION AT
C   XOUT  BY EVALUATING THE POLYNOMIAL THERE.  INFORMATION DEFINING THIS
C   POLYNOMIAL IS PASSED FROM  STEPS  SO  SINTRP  CANNOT BE USED ALONE.
C
C   THIS CODE IS COMPLETELY EXPLAINED AND DOCUMENTED IN THE TEXT,
C   COMPUTER SOLUTION OF ORDINARY DIFFERENTIAL EQUATIONS, THE INITIAL
C   VALUE PROBLEM  BY L. F. SHAMPINE AND M. K. GORDON.
C   FURTHER DETAILS ON USE OF THIS CODE ARE AVAILABLE IN *SOLVING
C   ORDINARY DIFFERENTIAL EQUATIONS WITH ODE, STEP, AND INTRP*,
C   BY L. F. SHAMPINE AND M. K. GORDON, SLA-73-1060.
C
C   INPUT TO SINTRP --
C
C   THE USER PROVIDES STORAGE IN THE CALLING PROGRAM FOR THE ARRAYS IN
C   THE CALL LIST
C      DIMENSION Y(NEQN),YOUT(NEQN),YPOUT(NEQN),PHI(NEQN,16),P(NEQN),
C                ALPHA(12),G(13),W(12),GI(11),IV(10)
C   AND DEFINES
C      XOUT -- POINT AT WHICH SOLUTION IS DESIRED.
C   THE REMAINING PARAMETERS ARE DEFINED IN  STEPS  AND PASSED TO
C   SINTRP  FROM THAT SUBROUTINE.
C
C   OUTPUT FROM  SINTRP --
C
C      YOUT(*) -- SOLUTION AT  XOUT
C      YPOUT(*) -- DERIVATIVE OF SOLUTION AT  XOUT
C
C   THE REMAINING PARAMETERS ARE RETURNED UNALTERED FROM THEIR INPUT
C   VALUES.  INTEGRATION WITH  STEPS  MAY BE CONTINUED.
C
C***REFERENCES  SHAMPINE L.F., GORDON M.K., *SOLVING ORDINARY
C                 DIFFERENTIAL EQUATIONS WITH ODE, STEP, AND INTRP*,
C                 SLA-73-1060, SANDIA LABORATORIES, 1973.
C               WATTS H.A., SHAMPINE L.F., *A SMOOTHER INTERPOLANT FOR
C                 DE/STEP,INTRP : II*, SAND84-0293, SANDIA LABORATORIES,
C                 1984.
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  SINTRP
C
      DOUBLE PRECISION ALP,ALPHA,C,G,GAMMA,GDI,GDIF,GI,GTEMP,
     1  H,HI,HMU,P,PHI,RMU,SIGMA,TEMP1,TEMP2,TEMP3,W,WTEMP,
     2  X,XI,XIM1,XIQ,XOLD,XOUT,Y,YOUT,YPOUT
      INTEGER I,IQ,IV,IVC,IW,J,JQ,KGI,KOLD,KP1,KP2,L,M,NEQN
C
      DIMENSION Y(NEQN),YOUT(NEQN),YPOUT(NEQN),PHI(NEQN,16),P(NEQN)
      DIMENSION GTEMP(13),C(13),WTEMP(13),G(13),W(12),ALPHA(12),
     1          GI(11),IV(10)
C
C***FIRST EXECUTABLE STATEMENT
      KP1 = KOLD + 1
      KP2 = KOLD + 2
C
      HI = XOUT - XOLD
      H = X - XOLD
      XI = HI/H
      XIM1 = XI - 1.
C
C   INITIALIZE WTEMP(*) FOR COMPUTING GTEMP(*)
C
      XIQ = XI
      DO 10 IQ = 1,KP1
        XIQ = XI*XIQ
        TEMP1 = IQ*(IQ+1)
 10     WTEMP(IQ) = XIQ/TEMP1
C
C   COMPUTE THE DOUBLE INTEGRAL TERM GDI
C
      IF (KOLD .LE. KGI) GO TO 50
      IF (IVC .GT. 0) GO TO 20
      GDI = 1.0/TEMP1
      M = 2
      GO TO 30
 20   IW = IV(IVC)
      GDI = W(IW)
      M = KOLD - IW + 3
 30   IF (M .GT. KOLD) GO TO 60
      DO 40 I = M,KOLD
 40     GDI = W(KP2-I) - ALPHA(I)*GDI
      GO TO 60
 50   GDI = GI(KOLD)
C
C   COMPUTE GTEMP(*) AND C(*)
C
 60   GTEMP(1) = XI
      GTEMP(2) = 0.5*XI*XI
      C(1) = 1.0
      C(2) = XI
      IF (KOLD .LT. 2) GO TO 90
      DO 80 I = 2,KOLD
        ALP = ALPHA(I)
        GAMMA = 1.0 + XIM1*ALP
        L = KP2 - I
        DO 70 JQ = 1,L
 70       WTEMP(JQ) = GAMMA*WTEMP(JQ) - ALP*WTEMP(JQ+1)
        GTEMP(I+1) = WTEMP(1)
 80     C(I+1) = GAMMA*C(I)
C
C   DEFINE INTERPOLATION PARAMETERS
C
 90   SIGMA = (WTEMP(2) - XIM1*WTEMP(1))/GDI
      RMU = XIM1*C(KP1)/GDI
      HMU = RMU/H
C
C   INTERPOLATE FOR THE SOLUTION -- YOUT
C   AND FOR THE DERIVATIVE OF THE SOLUTION -- YPOUT
C
      DO 100 L = 1,NEQN
        YOUT(L) = 0.0
 100    YPOUT(L) = 0.0
      DO 120 J = 1,KOLD
        I = KP2 - J
        GDIF = G(I) - G(I-1)
        TEMP2 = (GTEMP(I) - GTEMP(I-1)) - SIGMA*GDIF
        TEMP3 = (C(I) - C(I-1)) + RMU*GDIF
        DO 110 L = 1,NEQN
          YOUT(L) = YOUT(L) + TEMP2*PHI(L,I)
 110      YPOUT(L) = YPOUT(L) + TEMP3*PHI(L,I)
 120    CONTINUE
      DO 130 L = 1,NEQN
        YOUT(L) = ((1.0 - SIGMA)*P(L) + SIGMA*Y(L)) +
     1             H*(YOUT(L) + (GTEMP(1) - SIGMA*G(1))*PHI(L,1))
 130    YPOUT(L) = HMU*(P(L) - Y(L)) +
     1                (YPOUT(L) + (C(1) + RMU*G(1))*PHI(L,1))
C
      RETURN
      END
      SUBROUTINE SOLVDS(NN,A,NWK,MAXA,V)
C
C     This subroutine solves a system of linear equations Bx=b, where
C     B is symmetric, and is represented by its LDU factorization.
C
C     Input variables:
C
C        NN  -- dimension of B.
C
C        A -- one dimensional real array containing the upper
C             triangular skyline portion of the LDU decomposition
C             of the symmetric matrix B.
C
C        NWK  -- number of elements in A.
C
C        MAXA -- an integer array of length NN+1 which contains the
C                location in A of the diagonal elements of B.
C                By convention, MAXA(NN+1) = NWK+1 .
C
C        V -- real array of length NN containing the vector b.
C
C
C     Output variables:
C
C        V -- solution of the system of equations B x = b .
C
C
C     No working storage is required by this routine.
C
      INTEGER K,KK,KL,KU,L,NN,MAXA(NN+1),N,NWK
      DOUBLE PRECISION A(NWK),C,V(NN)
      DO 180 N=1,NN
         KL=MAXA(N)+1
         KU=MAXA(N+1)-1
         IF(KU-KL)180,160,160
160      K=N
         C=0.0
         DO 170 KK=KL,KU
            K=K-1
            C=C+A(KK)*V(K)
170      CONTINUE
         V(N)=V(N)-C
180   CONTINUE
800   DO 480 N=1,NN
         K=MAXA(N)
         V(N)=V(N)/A(K)
480   CONTINUE
      IF (NN.EQ.1) RETURN
      N=NN
      DO 500 L=2,NN
         KL=MAXA(N) + 1
         KU=MAXA(N+1) - 1
         IF (KU-KL) 530,510,510
510      K=N
         DO 520 KK=KL,KU
            K=K - 1
            V(K)=V(K) - A(KK)*V(N)
520      CONTINUE
530      N=N - 1
500   CONTINUE
      RETURN
      END
      SUBROUTINE STEPDS(F,NEQN,Y,X,H,EPS,WT,START,HOLD,K,KOLD,
     1   CRASH,PHI,P,YP,ALPHA,W,G,KSTEPS,XOLD,IVC,IV,KGI,GI,
     2   FPWA1,FPWA2,FPWA3,IFPC1,IFPWA1,FPWA4,FPWA5,IFPC2,IFPC3,
     3   PAR,IPAR)
C
C
C   WRITTEN BY L. F. SHAMPINE AND M. K. GORDON
C
C   ABSTRACT
C
C   SUBROUTINE  STEPS  IS NORMALLY USED INDIRECTLY THROUGH SUBROUTINE
C   DEABM .  BECAUSE  DEABM  SUFFICES FOR MOST PROBLEMS AND IS MUCH
C   EASIER TO USE, USING IT SHOULD BE CONSIDERED BEFORE USING  STEPS
C   ALONE.
C
C   SUBROUTINE STEPS INTEGRATES A SYSTEM OF  NEQN  FIRST ORDER ORDINARY
C   DIFFERENTIAL EQUATIONS ONE STEP, NORMALLY FROM X TO X+H, USING A
C   MODIFIED DIVIDED DIFFERENCE FORM OF THE ADAMS PECE FORMULAS.  LOCAL
C   EXTRAPOLATION IS USED TO IMPROVE ABSOLUTE STABILITY AND ACCURACY.
C   THE CODE ADJUSTS ITS ORDER AND STEP SIZE TO CONTROL THE LOCAL ERROR
C   PER UNIT STEP IN A GENERALIZED SENSE.  SPECIAL DEVICES ARE INCLUDED
C   TO CONTROL ROUNDOFF ERROR AND TO DETECT WHEN THE USER IS REQUESTING
C   TOO MUCH ACCURACY.
C
C   THIS CODE IS COMPLETELY EXPLAINED AND DOCUMENTED IN THE TEXT,
C   COMPUTER SOLUTION OF ORDINARY DIFFERENTIAL EQUATIONS, THE INITIAL
C   VALUE PROBLEM  BY L. F. SHAMPINE AND M. K. GORDON.
C   FURTHER DETAILS ON USE OF THIS CODE ARE AVAILABLE IN *SOLVING
C   ORDINARY DIFFERENTIAL EQUATIONS WITH ODE, STEP, AND INTRP*,
C   BY L. F. SHAMPINE AND M. K. GORDON, SLA-73-1060.
C
C
C   THE PARAMETERS REPRESENT --
C      F -- SUBROUTINE TO EVALUATE DERIVATIVES
C      NEQN -- NUMBER OF EQUATIONS TO BE INTEGRATED
C      Y(*) -- SOLUTION VECTOR AT X
C      X -- INDEPENDENT VARIABLE
C      H -- APPROPRIATE STEP SIZE FOR NEXT STEP.  NORMALLY DETERMINED BY
C           CODE
C      EPS -- LOCAL ERROR TOLERANCE
C      WT(*) -- VECTOR OF WEIGHTS FOR ERROR CRITERION
C      START -- LOGICAL VARIABLE SET .TRUE. FOR FIRST STEP,  .FALSE.
C           OTHERWISE
C      HOLD -- STEP SIZE USED FOR LAST SUCCESSFUL STEP
C      K -- APPROPRIATE ORDER FOR NEXT STEP (DETERMINED BY CODE)
C      KOLD -- ORDER USED FOR LAST SUCCESSFUL STEP
C      CRASH -- LOGICAL VARIABLE SET .TRUE. WHEN NO STEP CAN BE TAKEN,
C           .FALSE. OTHERWISE.
C      YP(*) -- DERIVATIVE OF SOLUTION VECTOR AT  X  AFTER SUCCESSFUL
C           STEP
C      KSTEPS -- COUNTER ON ATTEMPTED STEPS
C
C   THE VARIABLES X,XOLD,KOLD,KGI AND IVC AND THE ARRAYS Y,PHI,ALPHA,G,
C   W,P,IV AND GI ARE REQUIRED FOR THE INTERPOLATION SUBROUTINE SINTRP.
C   THE ARRAYS FPWA* AND IFPWA1 AND INTEGER CONSTANTS IFPC* ARE
C   WORKING STORAGE PASSED DIRECTLY THROUGH TO  FODEDS.  THE ARRAYS
C   PAR AND IPAR ARE USER PARAMETERS PASSED THROUGH TO RHOA AND RHOJS.
C
C   INPUT TO STEPS
C
C      FIRST CALL --
C
C   THE USER MUST PROVIDE STORAGE IN HIS CALLING PROGRAM FOR ALL ARRAYS
C   IN THE CALL LIST, NAMELY
C
C     DIMENSION Y(NEQN),WT(NEQN),PHI(NEQN,16),P(NEQN),YP(NEQN),
C    1  ALPHA(12),W(12),G(13),GI(11),IV(10),   FPWA1(NEQN),
C    2  FPWA2(NEQN-1),FPWA3(NEQN-1,NEQN),FPWA4(NEQN-1),
C    3  FPWA5(NEQN),IFPWA1(NEQN)
C                              --                --    **NOTE**
C
C   THE USER MUST ALSO DECLARE  START  AND  CRASH
C   LOGICAL VARIABLES AND  F  AN EXTERNAL SUBROUTINE, SUPPLY THE
C   SUBROUTINE  F(X,Y,YP,FPWA1,FPWA2,FPWA3,IFPC1,IFPWA1,FPWA4,FPWA5,
C                 IFPC2,NEQN-1,IFPC3,PAR,IPAR) TO EVALUATE
C      DY(I)/DX = YP(I) = F(X,Y(1),Y(2),...,Y(NEQN))
C   AND INITIALIZE ONLY THE FOLLOWING PARAMETERS.
C      NEQN -- NUMBER OF EQUATIONS TO BE INTEGRATED
C      Y(*) -- VECTOR OF INITIAL VALUES OF DEPENDENT VARIABLES
C      X -- INITIAL VALUE OF THE INDEPENDENT VARIABLE
C      H -- NOMINAL STEP SIZE INDICATING DIRECTION OF INTEGRATION
C           AND MAXIMUM SIZE OF STEP.  MUST BE VARIABLE
C      EPS -- LOCAL ERROR TOLERANCE PER STEP.  MUST BE VARIABLE
C      WT(*) -- VECTOR OF NON-ZERO WEIGHTS FOR ERROR CRITERION
C      START -- .TRUE.
C      KSTEPS -- SET KSTEPS TO ZERO
C   DEFINE U TO BE THE MACHINE UNIT ROUNDOFF QUANTITY BY CALLING
C   THE FUNCTION ROUTINE  D1MACH,  U = D1MACH(3), OR BY
C   COMPUTING U SO THAT U IS THE SMALLEST POSITIVE NUMBER SUCH
C   THAT 1.0+U .GT. 1.0.
C
C   STEPS  REQUIRES THAT THE L2 NORM OF THE VECTOR WITH COMPONENTS
C   LOCAL ERROR(L)/WT(L)  BE LESS THAN  EPS  FOR A SUCCESSFUL STEP.  THE
C   ARRAY  WT  ALLOWS THE USER TO SPECIFY AN ERROR TEST APPROPRIATE
C   FOR HIS PROBLEM.  FOR EXAMPLE,
C      WT(L) = 1.0  SPECIFIES ABSOLUTE ERROR,
C            = ABS(Y(L))  ERROR RELATIVE TO THE MOST RECENT VALUE OF THE
C                 L-TH COMPONENT OF THE SOLUTION,
C            = ABS(YP(L))  ERROR RELATIVE TO THE MOST RECENT VALUE OF
C                 THE L-TH COMPONENT OF THE DERIVATIVE,
C            = MAX(WT(L),ABS(Y(L)))  ERROR RELATIVE TO THE LARGEST
C                 MAGNITUDE OF L-TH COMPONENT OBTAINED SO FAR,
C            = ABS(Y(L))*RELERR/EPS + ABSERR/EPS  SPECIFIES A MIXED
C                 RELATIVE-ABSOLUTE TEST WHERE  RELERR  IS RELATIVE
C                 ERROR,  ABSERR  IS ABSOLUTE ERROR AND  EPS =
C                 MAX(RELERR,ABSERR) .
C
C      SUBSEQUENT CALLS --
C
C   SUBROUTINE  STEPS  IS DESIGNED SO THAT ALL INFORMATION NEEDED TO
C   CONTINUE THE INTEGRATION, INCLUDING THE STEP SIZE  H  AND THE ORDER
C   K , IS RETURNED WITH EACH STEP.  WITH THE EXCEPTION OF THE STEP
C   SIZE, THE ERROR TOLERANCE, AND THE WEIGHTS, NONE OF THE PARAMETERS
C   SHOULD BE ALTERED.  THE ARRAY  WT  MUST BE UPDATED AFTER EACH STEP
C   TO MAINTAIN RELATIVE ERROR TESTS LIKE THOSE ABOVE.  NORMALLY THE
C   INTEGRATION IS CONTINUED JUST BEYOND THE DESIRED ENDPOINT AND THE
C   SOLUTION INTERPOLATED THERE WITH SUBROUTINE  SINTRP .  IF IT IS
C   IMPOSSIBLE TO INTEGRATE BEYOND THE ENDPOINT, THE STEP SIZE MAY BE
C   REDUCED TO HIT THE ENDPOINT SINCE THE CODE WILL NOT TAKE A STEP
C   LARGER THAN THE  H  INPUT.  CHANGING THE DIRECTION OF INTEGRATION,
C   I.E., THE SIGN OF  H , REQUIRES THE USER SET  START = .TRUE. BEFORE
C   CALLING  STEPS  AGAIN.  THIS IS THE ONLY SITUATION IN WHICH  START
C   SHOULD BE ALTERED.
C
C   OUTPUT FROM STEPS
C
C      SUCCESSFUL STEP --
C
C   THE SUBROUTINE RETURNS AFTER EACH SUCCESSFUL STEP WITH  START  AND
C   CRASH  SET .FALSE. .  X  REPRESENTS THE INDEPENDENT VARIABLE
C   ADVANCED ONE STEP OF LENGTH  HOLD  FROM ITS VALUE ON INPUT AND  Y
C   THE SOLUTION VECTOR AT THE NEW VALUE OF  X .  ALL OTHER PARAMETERS
C   REPRESENT INFORMATION CORRESPONDING TO THE NEW  X  NEEDED TO
C   CONTINUE THE INTEGRATION.
C
C      UNSUCCESSFUL STEP --
C
C   WHEN THE ERROR TOLERANCE IS TOO SMALL FOR THE MACHINE PRECISION,
C   THE SUBROUTINE RETURNS WITHOUT TAKING A STEP AND  CRASH = .TRUE. .
C   AN APPROPRIATE STEP SIZE AND ERROR TOLERANCE FOR CONTINUING ARE
C   ESTIMATED AND ALL OTHER INFORMATION IS RESTORED AS UPON INPUT
C   BEFORE RETURNING.  TO CONTINUE WITH THE LARGER TOLERANCE, THE USER
C   JUST CALLS THE CODE AGAIN.  A RESTART IS NEITHER REQUIRED NOR
C   DESIRABLE.
C***REFERENCES  SHAMPINE L.F., GORDON M.K., *SOLVING ORDINARY
C                 DIFFERENTIAL EQUATIONS WITH ODE, STEP, AND INTRP*,
C                 SLA-73-1060, SANDIA LABORATORIES, 1973.
C
      DOUBLE PRECISION ABSH,ALPHA,BETA,D1MACH,EPS,ERK,ERKM1,ERKM2,
     1  ERKP1,ERR,FOURU,FPWA1,FPWA2,FPWA3,FPWA4,FPWA5,G,GI,GSTR,H,
     2  HNEW,HOLD,P,PAR,P5EPS,PHI,PSI,R,REALI,REALNS,RHO,ROUND,SIG,
     3  SUM,TAU,TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,TEMP6,TWO,TWOU,V,
     4  W,WT,X,XOLD,Y,YP
      INTEGER I,IFAIL,IFPC1,IFPC2,IFPC3,IFPWA1,IM1,IPAR,IP1,IQ,IV,
     1  IVC,J,JV,K,KGI,KM1,KM2,KNEW,KOLD,KP1,KP2,KPREV,KSTEPS,
     2  L,LIMIT1,LIMIT2,NEQN,NS,NSM2,NSP1,NSP2
      LOGICAL START,CRASH,PHASE1,NORND
C
      DIMENSION Y(NEQN),WT(NEQN),PHI(NEQN,16),P(NEQN),YP(NEQN),PSI(12),
     1  ALPHA(12),BETA(12),SIG(13),V(12),W(12),G(13),GI(11),IV(10),
     2  FPWA1(NEQN),FPWA2(NEQN-1),FPWA3(IFPC1),FPWA4(NEQN-1),
     3  FPWA5(6*NEQN+IFPC1),IFPWA1(NEQN+1),PAR(1),IPAR(1)
      DIMENSION TWO(13),GSTR(13)
C
C   ALL LOCAL VARIABLES ARE SAVED, RATHER THAN PASSED, IN THIS
C   SPECIALIZED VERSION OF STEPS.
C
      SAVE
C
      EXTERNAL F
C
      DATA TWO/2.0,4.0,8.0,16.0,32.0,64.0,128.0,256.0,512.0,1024.0,
     1  2048.0,4096.0,8192.0/
      DATA GSTR/0.500,0.0833,0.0417,0.0264,0.0188,0.0143,0.0114,0.00936,
     1  0.00789,0.00679,0.00592,0.00524,0.00468/
C
C
C       ***     BEGIN BLOCK 0     ***
C   CHECK IF STEP SIZE OR ERROR TOLERANCE IS TOO SMALL FOR MACHINE
C   PRECISION.  IF FIRST STEP, INITIALIZE PHI ARRAY AND ESTIMATE A
C   STARTING STEP SIZE.
C                   ***
C
C   IF STEP SIZE IS TOO SMALL, DETERMINE AN ACCEPTABLE ONE
C
C***FIRST EXECUTABLE STATEMENT
      TWOU = 2.0 * D1MACH(4)
      FOURU = TWOU + TWOU
      CRASH = .TRUE.
      IF(ABS(H) .GE. FOURU*ABS(X)) GO TO 5
      H = SIGN(FOURU*ABS(X),H)
      RETURN
 5    P5EPS = 0.5*EPS
C
C   IF ERROR TOLERANCE IS TOO SMALL, INCREASE IT TO AN ACCEPTABLE VALUE
C
      ROUND = 0.0
      DO 10 L = 1,NEQN
 10     ROUND = ROUND + (Y(L)/WT(L))**2
      ROUND = TWOU*SQRT(ROUND)
      IF(P5EPS .GE. ROUND) GO TO 15
      EPS = 2.0*ROUND*(1.0 + FOURU)
      RETURN
 15   CRASH = .FALSE.
      G(1) = 1.0
      G(2) = 0.5
      SIG(1) = 1.0
      IF(.NOT.START) GO TO 99
C
C   INITIALIZE.  COMPUTE APPROPRIATE STEP SIZE FOR FIRST STEP
C
      CALL F(X,Y,YP,FPWA1,FPWA2,FPWA3,IFPC1,IFPWA1,FPWA4,FPWA5,
     $       IFPC2,NEQN-1,IFPC3,PAR,IPAR)
      IF (IFPC3 .GT. 0) RETURN
      SUM = 0.0
      DO 20 L = 1,NEQN
        PHI(L,1) = YP(L)
        PHI(L,2) = 0.0
 20     SUM = SUM + (YP(L)/WT(L))**2
      SUM = SQRT(SUM)
      ABSH = ABS(H)
      IF(EPS .LT. 16.0*SUM*H*H) ABSH = 0.25*SQRT(EPS/SUM)
      H = SIGN(MAX(ABSH,FOURU*ABS(X)),H)
C
C*      U = D1MACH(3)
C*      BIG = SQRT(D1MACH(2))
C*      CALL HSTART (F,NEQN,X,X+H,Y,YP,WT,1,U,BIG,
C*     1             PHI(1,3),PHI(1,4),PHI(1,5),PHI(1,6),RPAR,IPAR,H)
C
      HOLD = 0.0
      K = 1
      KOLD = 0
      KPREV = 0
      START = .FALSE.
      PHASE1 = .TRUE.
      NORND = .TRUE.
      IF(P5EPS .GT. 100.0*ROUND) GO TO 99
      NORND = .FALSE.
      DO 25 L = 1,NEQN
 25     PHI(L,15) = 0.0
 99   IFAIL = 0
C       ***     END BLOCK 0     ***
C
C       ***     BEGIN BLOCK 1     ***
C   COMPUTE COEFFICIENTS OF FORMULAS FOR THIS STEP.  AVOID COMPUTING
C   THOSE QUANTITIES NOT CHANGED WHEN STEP SIZE IS NOT CHANGED.
C                   ***
C
 100  KP1 = K+1
      KP2 = K+2
      KM1 = K-1
      KM2 = K-2
C
C   NS IS THE NUMBER OF STEPS TAKEN WITH SIZE H, INCLUDING THE CURRENT
C   ONE.  WHEN K.LT.NS, NO COEFFICIENTS CHANGE
C
      IF(H .NE. HOLD) NS = 0
      IF (NS.LE.KOLD) NS = NS+1
      NSP1 = NS+1
      IF (K .LT. NS) GO TO 199
C
C   COMPUTE THOSE COMPONENTS OF ALPHA(*),BETA(*),PSI(*),SIG(*) WHICH
C   ARE CHANGED
C
      BETA(NS) = 1.0
      REALNS = NS
      ALPHA(NS) = 1.0/REALNS
      TEMP1 = H*REALNS
      SIG(NSP1) = 1.0
      IF(K .LT. NSP1) GO TO 110
      DO 105 I = NSP1,K
        IM1 = I-1
        TEMP2 = PSI(IM1)
        PSI(IM1) = TEMP1
        BETA(I) = BETA(IM1)*PSI(IM1)/TEMP2
        TEMP1 = TEMP2 + H
        ALPHA(I) = H/TEMP1
        REALI = I
 105    SIG(I+1) = REALI*ALPHA(I)*SIG(I)
 110  PSI(K) = TEMP1
C
C   COMPUTE COEFFICIENTS G(*)
C
C   INITIALIZE V(*) AND SET W(*).
C
      IF(NS .GT. 1) GO TO 120
      DO 115 IQ = 1,K
        TEMP3 = IQ*(IQ+1)
        V(IQ) = 1.0/TEMP3
 115    W(IQ) = V(IQ)
      IVC = 0
      KGI = 0
      IF (K .EQ. 1) GO TO 140
      KGI = 1
      GI(1) = W(2)
      GO TO 140
C
C   IF ORDER WAS RAISED, UPDATE DIAGONAL PART OF V(*)
C
 120  IF(K .LE. KPREV) GO TO 130
      IF (IVC .EQ. 0) GO TO 122
      JV = KP1 - IV(IVC)
      IVC = IVC - 1
      GO TO 123
 122  JV = 1
      TEMP4 = K*KP1
      V(K) = 1.0/TEMP4
      W(K) = V(K)
      IF (K .NE. 2) GO TO 123
      KGI = 1
      GI(1) = W(2)
 123  NSM2 = NS-2
      IF(NSM2 .LT. JV) GO TO 130
      DO 125 J = JV,NSM2
        I = K-J
        V(I) = V(I) - ALPHA(J+1)*V(I+1)
 125    W(I) = V(I)
      IF (I .NE. 2) GO TO 130
      KGI = NS - 1
      GI(KGI) = W(2)
C
C   UPDATE V(*) AND SET W(*)
C
 130  LIMIT1 = KP1 - NS
      TEMP5 = ALPHA(NS)
      DO 135 IQ = 1,LIMIT1
        V(IQ) = V(IQ) - TEMP5*V(IQ+1)
 135    W(IQ) = V(IQ)
      G(NSP1) = W(1)
      IF (LIMIT1 .EQ. 1) GO TO 137
      KGI = NS
      GI(KGI) = W(2)
 137  W(LIMIT1+1) = V(LIMIT1+1)
      IF (K .GE. KOLD) GO TO 140
      IVC = IVC + 1
      IV(IVC) = LIMIT1 + 2
C
C   COMPUTE THE G(*) IN THE WORK VECTOR W(*)
C
 140  NSP2 = NS + 2
      KPREV = K
      IF(KP1 .LT. NSP2) GO TO 199
      DO 150 I = NSP2,KP1
        LIMIT2 = KP2 - I
        TEMP6 = ALPHA(I-1)
        DO 145 IQ = 1,LIMIT2
 145      W(IQ) = W(IQ) - TEMP6*W(IQ+1)
 150    G(I) = W(1)
 199    CONTINUE
C       ***     END BLOCK 1     ***
C
C       ***     BEGIN BLOCK 2     ***
C   PREDICT A SOLUTION P(*), EVALUATE DERIVATIVES USING PREDICTED
C   SOLUTION, ESTIMATE LOCAL ERROR AT ORDER K AND ERRORS AT ORDERS K,
C   K-1, K-2 AS IF CONSTANT STEP SIZE WERE USED.
C                   ***
C
C   INCREMENT COUNTER ON ATTEMPTED STEPS
C
      KSTEPS = KSTEPS + 1
C
C   CHANGE PHI TO PHI STAR
C
      IF(K .LT. NSP1) GO TO 215
      DO 210 I = NSP1,K
        TEMP1 = BETA(I)
        DO 205 L = 1,NEQN
 205      PHI(L,I) = TEMP1*PHI(L,I)
 210    CONTINUE
C
C   PREDICT SOLUTION AND DIFFERENCES
C
 215  DO 220 L = 1,NEQN
        PHI(L,KP2) = PHI(L,KP1)
        PHI(L,KP1) = 0.0
 220    P(L) = 0.0
      DO 230 J = 1,K
        I = KP1 - J
        IP1 = I+1
        TEMP2 = G(I)
        DO 225 L = 1,NEQN
          P(L) = P(L) + TEMP2*PHI(L,I)
 225      PHI(L,I) = PHI(L,I) + PHI(L,IP1)
 230    CONTINUE
      IF(NORND) GO TO 240
      DO 235 L = 1,NEQN
        TAU = H*P(L) - PHI(L,15)
        P(L) = Y(L) + TAU
 235    PHI(L,16) = (P(L) - Y(L)) - TAU
      GO TO 250
 240  DO 245 L = 1,NEQN
 245    P(L) = Y(L) + H*P(L)
 250  XOLD = X
      X = X + H
      ABSH = ABS(H)
      CALL F(X,P,YP,FPWA1,FPWA2,FPWA3,IFPC1,IFPWA1,FPWA4,FPWA5,
     $       IFPC2,NEQN-1,IFPC3,PAR,IPAR)
      IF (IFPC3 .GT. 0) RETURN
C
C   ESTIMATE ERRORS AT ORDERS K,K-1,K-2
C
      ERKM2 = 0.0
      ERKM1 = 0.0
      ERK = 0.0
      DO 265 L = 1,NEQN
        TEMP3 = 1.0/WT(L)
        TEMP4 = YP(L) - PHI(L,1)
        IF(KM2)265,260,255
 255    ERKM2 = ERKM2 + ((PHI(L,KM1)+TEMP4)*TEMP3)**2
 260    ERKM1 = ERKM1 + ((PHI(L,K)+TEMP4)*TEMP3)**2
 265    ERK = ERK + (TEMP4*TEMP3)**2
      IF(KM2)280,275,270
 270  ERKM2 = ABSH*SIG(KM1)*GSTR(KM2)*SQRT(ERKM2)
 275  ERKM1 = ABSH*SIG(K)*GSTR(KM1)*SQRT(ERKM1)
 280  TEMP5 = ABSH*SQRT(ERK)
      ERR = TEMP5*(G(K)-G(KP1))
      ERK = TEMP5*SIG(KP1)*GSTR(K)
      KNEW = K
C
C   TEST IF ORDER SHOULD BE LOWERED
C
      IF(KM2)299,290,285
 285  IF(MAX(ERKM1,ERKM2) .LE. ERK) KNEW = KM1
      GO TO 299
 290  IF(ERKM1 .LE. 0.5*ERK) KNEW = KM1
C
C   TEST IF STEP SUCCESSFUL
C
 299  IF(ERR .LE. EPS) GO TO 400
C       ***     END BLOCK 2     ***
C
C       ***     BEGIN BLOCK 3     ***
C   THE STEP IS UNSUCCESSFUL.  RESTORE  X, PHI(*,*), PSI(*) .
C   IF THIRD CONSECUTIVE FAILURE, SET ORDER TO ONE.  IF STEP FAILS MORE
C   THAN THREE TIMES, CONSIDER AN OPTIMAL STEP SIZE.  DOUBLE ERROR
C   TOLERANCE AND RETURN IF ESTIMATED STEP SIZE IS TOO SMALL FOR MACHINE
C   PRECISION.
C                   ***
C
C   RESTORE X, PHI(*,*) AND PSI(*)
C
      PHASE1 = .FALSE.
      X = XOLD
      DO 310 I = 1,K
        TEMP1 = 1.0/BETA(I)
        IP1 = I+1
        DO 305 L = 1,NEQN
 305      PHI(L,I) = TEMP1*(PHI(L,I) - PHI(L,IP1))
 310    CONTINUE
      IF(K .LT. 2) GO TO 320
      DO 315 I = 2,K
 315    PSI(I-1) = PSI(I) - H
C
C   ON THIRD FAILURE, SET ORDER TO ONE.  THEREAFTER, USE OPTIMAL STEP
C   SIZE
C
 320  IFAIL = IFAIL + 1
      TEMP2 = 0.5
      IF(IFAIL - 3) 335,330,325
 325  IF(P5EPS .LT. 0.25*ERK) TEMP2 = SQRT(P5EPS/ERK)
 330  KNEW = 1
 335  H = TEMP2*H
      K = KNEW
      NS = 0
      IF(ABS(H) .GE. FOURU*ABS(X)) GO TO 340
      CRASH = .TRUE.
      H = SIGN(FOURU*ABS(X),H)
      EPS = EPS + EPS
      RETURN
 340  GO TO 100
C       ***     END BLOCK 3     ***
C
C       ***     BEGIN BLOCK 4     ***
C   THE STEP IS SUCCESSFUL.  CORRECT THE PREDICTED SOLUTION, EVALUATE
C   THE DERIVATIVES USING THE CORRECTED SOLUTION AND UPDATE THE
C   DIFFERENCES.  DETERMINE BEST ORDER AND STEP SIZE FOR NEXT STEP.
C                   ***
 400  KOLD = K
      HOLD = H
C
C   CORRECT AND EVALUATE
C
      TEMP1 = H*G(KP1)
      IF(NORND) GO TO 410
      DO 405 L = 1,NEQN
        TEMP3 = Y(L)
        RHO = TEMP1*(YP(L) - PHI(L,1)) - PHI(L,16)
        Y(L) = P(L) + RHO
        PHI(L,15) = (Y(L) - P(L)) - RHO
 405    P(L) = TEMP3
      GO TO 420
 410  DO 415 L = 1,NEQN
        TEMP3 = Y(L)
        Y(L) = P(L) + TEMP1*(YP(L) - PHI(L,1))
 415    P(L) = TEMP3
 420  CALL F(X,Y,YP,FPWA1,FPWA2,FPWA3,IFPC1,IFPWA1,FPWA4,FPWA5,
     $       IFPC2,NEQN-1,IFPC3,PAR,IPAR)
      IF (IFPC3 .GT. 0) RETURN
C
C   UPDATE DIFFERENCES FOR NEXT STEP
C
      DO 425 L = 1,NEQN
        PHI(L,KP1) = YP(L) - PHI(L,1)
 425    PHI(L,KP2) = PHI(L,KP1) - PHI(L,KP2)
      DO 435 I = 1,K
        DO 430 L = 1,NEQN
 430      PHI(L,I) = PHI(L,I) + PHI(L,KP1)
 435    CONTINUE
C
C   ESTIMATE ERROR AT ORDER K+1 UNLESS:
C     IN FIRST PHASE WHEN ALWAYS RAISE ORDER,
C     ALREADY DECIDED TO LOWER ORDER,
C     STEP SIZE NOT CONSTANT SO ESTIMATE UNRELIABLE
C
      ERKP1 = 0.0
      IF(KNEW .EQ. KM1  .OR.  K .EQ. 12) PHASE1 = .FALSE.
      IF(PHASE1) GO TO 450
      IF(KNEW .EQ. KM1) GO TO 455
      IF(KP1 .GT. NS) GO TO 460
      DO 440 L = 1,NEQN
 440    ERKP1 = ERKP1 + (PHI(L,KP2)/WT(L))**2
      ERKP1 = ABSH*GSTR(KP1)*SQRT(ERKP1)
C
C   USING ESTIMATED ERROR AT ORDER K+1, DETERMINE APPROPRIATE ORDER
C   FOR NEXT STEP
C
      IF(K .GT. 1) GO TO 445
      IF(ERKP1 .GE. 0.5*ERK) GO TO 460
      GO TO 450
 445  IF(ERKM1 .LE. MIN(ERK,ERKP1)) GO TO 455
      IF(ERKP1 .GE. ERK  .OR.  K .EQ. 12) GO TO 460
C
C   HERE ERKP1 .LT. ERK .LT. MAX(ERKM1,ERKM2) ELSE ORDER WOULD HAVE
C   BEEN LOWERED IN BLOCK 2.  THUS ORDER IS TO BE RAISED
C
C   RAISE ORDER
C
 450  K = KP1
      ERK = ERKP1
      GO TO 460
C
C   LOWER ORDER
C
 455  K = KM1
      ERK = ERKM1
C
C   WITH NEW ORDER DETERMINE APPROPRIATE STEP SIZE FOR NEXT STEP
C
 460  HNEW = H + H
      IF(PHASE1) GO TO 465
      IF(P5EPS .GE. ERK*TWO(K+1)) GO TO 465
      HNEW = H
      IF(P5EPS .GE. ERK) GO TO 465
      TEMP2 = K+1
      R = (P5EPS/ERK)**(1.0/TEMP2)
      HNEW = ABSH*MAX(0.5D0,MIN(0.9D0,R))
      HNEW = SIGN(MAX(HNEW,FOURU*ABS(X)),H)
 465  H = HNEW
      RETURN
C       ***     END BLOCK 4     ***
      END
      SUBROUTINE STEPNF(N,NFE,IFLAG,START,CRASH,HOLD,H,RELERR,
     $   ABSERR,S,Y,YP,YOLD,YPOLD,A,QR,ALPHA,TZ,PIVOT,W,WP,
     $   Z0,Z1,SSPAR,PAR,IPAR)
C
C  STEPNF  TAKES ONE STEP ALONG THE ZERO CURVE OF THE HOMOTOPY MAP
C USING A PREDICTOR-CORRECTOR ALGORITHM.  THE PREDICTOR USES A HERMITE
C CUBIC INTERPOLANT, AND THE CORRECTOR RETURNS TO THE ZERO CURVE ALONG
C THE FLOW NORMAL TO THE DAVIDENKO FLOW.  STEPNF  ALSO ESTIMATES A
C STEP SIZE H FOR THE NEXT STEP ALONG THE ZERO CURVE.  NORMALLY
C  STEPNF  IS USED INDIRECTLY THROUGH  FIXPNF , AND SHOULD BE CALLED
C DIRECTLY ONLY IF IT IS NECESSARY TO MODIFY THE STEPPING ALGORITHM'S
C PARAMETERS.
C
C ON INPUT:
C
C N = DIMENSION OF X AND THE HOMOTOPY MAP.
C
C NFE = NUMBER OF JACOBIAN MATRIX EVALUATIONS.
C
C IFLAG = -2, -1, OR 0, INDICATING THE PROBLEM TYPE.
C
C START = .TRUE. ON FIRST CALL TO  STEPNF , .FALSE. OTHERWISE.
C
C HOLD = ||Y - YOLD||; SHOULD NOT BE MODIFIED BY THE USER.
C
C H = UPPER LIMIT ON LENGTH OF STEP THAT WILL BE ATTEMPTED.  H  MUST BE
C    SET TO A POSITIVE NUMBER ON THE FIRST CALL TO  STEPNF .
C    THEREAFTER  STEPNF  CALCULATES AN OPTIMAL VALUE FOR  H , AND  H
C    SHOULD NOT BE MODIFIED BY THE USER.
C
C RELERR, ABSERR = RELATIVE AND ABSOLUTE ERROR VALUES.  THE ITERATION IS
C    CONSIDERED TO HAVE CONVERGED WHEN A POINT W=(LAMBDA,X) IS FOUND
C    SUCH THAT
C
C    ||Z|| <= RELERR*||W|| + ABSERR  ,          WHERE
C
C    Z IS THE NEWTON STEP TO W=(LAMBDA,X).
C
C S = (APPROXIMATE) ARC LENGTH ALONG THE HOMOTOPY ZERO CURVE UP TO
C    Y(S) = (LAMBDA(S), X(S)).
C
C Y(1:N+1) = PREVIOUS POINT (LAMBDA(S), X(S)) FOUND ON THE ZERO CURVE OF
C    THE HOMOTOPY MAP.
C
C YP(1:N+1) = UNIT TANGENT VECTOR TO THE ZERO CURVE OF THE HOMOTOPY MAP
C    AT  Y .
C
C YOLD(1:N+1) = A POINT BEFORE  Y  ON THE ZERO CURVE OF THE HOMOTOPY MAP
C
C YPOLD(1:N+1) = UNIT TANGENT VECTOR TO THE ZERO CURVE OF THE HOMOTOPY
C    MAP AT  YOLD .
C
C A(1:*) = PARAMETER VECTOR IN THE HOMOTOPY MAP.
C
C QR(1:N,1:N+2), ALPHA(1:N), TZ(1:N+1), PIVOT(1:N+1), W(1:N+1),
C    WP(1:N+1)  ARE WORK ARRAYS USED FOR THE QR FACTORIZATION (IN THE
C    NEWTON STEP CALCULATION) AND THE INTERPOLATION.
C
C Z0(1:N+1), Z1(1:N+1)  ARE WORK ARRAYS USED FOR THE ESTIMATION OF THE
C    NEXT STEP SIZE  H .
C
C SSPAR(1:8) = (LIDEAL, RIDEAL, DIDEAL, HMIN, HMAX, BMIN, BMAX, P)  IS
C    A VECTOR OF PARAMETERS USED FOR THE OPTIMAL STEP SIZE ESTIMATION.
C
C PAR(1:*) AND IPAR(1:*) ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS,
C    WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES
C    RHO, RHOJAC.
C
C ON OUTPUT:
C
C N , A , SSPAR  ARE UNCHANGED.
C
C NFE  HAS BEEN UPDATED.
C
C IFLAG
C    = -2, -1, OR 0 (UNCHANGED) ON A NORMAL RETURN.
C
C    = 4 IF A JACOBIAN MATRIX WITH RANK < N HAS OCCURRED.  THE
C        ITERATION WAS NOT COMPLETED.
C
C    = 6 IF THE ITERATION FAILED TO CONVERGE.  W  CONTAINS THE LAST
C        NEWTON ITERATE.
C
C START = .FALSE. ON A NORMAL RETURN.
C
C CRASH
C    = .FALSE. ON A NORMAL RETURN.
C
C    = .TRUE. IF THE STEP SIZE  H  WAS TOO SMALL.  H  HAS BEEN
C      INCREASED TO AN ACCEPTABLE VALUE, WITH WHICH  STEPNF  MAY BE
C      CALLED AGAIN.
C
C    = .TRUE. IF  RELERR  AND/OR  ABSERR  WERE TOO SMALL.  THEY HAVE
C      BEEN INCREASED TO ACCEPTABLE VALUES, WITH WHICH  STEPNF  MAY
C      BE CALLED AGAIN.
C
C HOLD = ||Y - YOLD||.
C
C H = OPTIMAL VALUE FOR NEXT STEP TO BE ATTEMPTED.  NORMALLY  H  SHOULD
C    NOT BE MODIFIED BY THE USER.
C
C RELERR, ABSERR  ARE UNCHANGED ON A NORMAL RETURN.
C
C S = (APPROXIMATE) ARC LENGTH ALONG THE ZERO CURVE OF THE HOMOTOPY MAP
C    UP TO THE LATEST POINT FOUND, WHICH IS RETURNED IN  Y .
C
C Y, YP, YOLD, YPOLD  CONTAIN THE TWO MOST RECENT POINTS AND TANGENT
C    VECTORS FOUND ON THE ZERO CURVE OF THE HOMOTOPY MAP.
C
C
C CALLS  D1MACH , DNRM2 , TANGNF .
C
      DOUBLE PRECISION ABSERR,D1MACH,DCALC,DD001,DD0011,DD01,
     $   DD011,DELS,DNRM2,F0,F1,FOURU,FP0,FP1,H,HFAIL,HOLD,HT,
     $   LCALC,QOFS,RCALC,RELERR,RHOLEN,S,TEMP,TWOU
      INTEGER IFLAG,ITNUM,J,JUDY,LITFH,N,NFE,NP1
      LOGICAL CRASH,FAIL,START
C
C ***** ARRAY DECLARATIONS. *****
C
      DOUBLE PRECISION Y(N+1),YP(N+1),YOLD(N+1),YPOLD(N+1),A(N),
     $   QR(N,N+2),ALPHA(N),TZ(N+1),W(N+1),WP(N+1),Z0(N+1),
     $   Z1(N+1),SSPAR(8),PAR(1)
      INTEGER PIVOT(N+1),IPAR(1)
C
C ***** END OF DIMENSIONAL INFORMATION. *****
C
C THE LIMIT ON THE NUMBER OF NEWTON ITERATIONS ALLOWED BEFORE REDUCING
C THE STEP SIZE  H  MAY BE CHANGED BY CHANGING THE FOLLOWING PARAMETER
C STATEMENT:
      PARAMETER (LITFH=4)
C
C DEFINITION OF HERMITE CUBIC INTERPOLANT VIA DIVIDED DIFFERENCES.
C
      DD01(F0,F1,DELS)=(F1-F0)/DELS
      DD001(F0,FP0,F1,DELS)=(DD01(F0,F1,DELS)-FP0)/DELS
      DD011(F0,F1,FP1,DELS)=(FP1-DD01(F0,F1,DELS))/DELS
      DD0011(F0,FP0,F1,FP1,DELS)=(DD011(F0,F1,FP1,DELS) -
     $                            DD001(F0,FP0,F1,DELS))/DELS
      QOFS(F0,FP0,F1,FP1,DELS,S)=((DD0011(F0,FP0,F1,FP1,DELS)*(S-DELS) +
     $   DD001(F0,FP0,F1,DELS))*S + FP0)*S + F0
C
C
      TWOU=2.0*D1MACH(4)
      FOURU=TWOU+TWOU
      NP1=N+1
      CRASH=.TRUE.
C THE ARCLENGTH  S  MUST BE NONNEGATIVE.
      IF (S .LT. 0.0) RETURN
C IF STEP SIZE IS TOO SMALL, DETERMINE AN ACCEPTABLE ONE.
      IF (H .LT. FOURU*(1.0+S)) THEN
        H=FOURU*(1.0+S)
        RETURN
      ENDIF
C IF ERROR TOLERANCES ARE TOO SMALL, INCREASE THEM TO ACCEPTABLE VALUES.
      TEMP=DNRM2(NP1,Y,1)
      IF (.5*(RELERR*TEMP+ABSERR) .GE. TWOU*TEMP) GO TO 40
      IF (RELERR .NE. 0.0) THEN
        RELERR=FOURU*(1.0+FOURU)
        ABSERR=MAX(ABSERR,0.0D0)
      ELSE
        ABSERR=FOURU*TEMP
      ENDIF
      RETURN
 40   CRASH=.FALSE.
      IF (.NOT. START) GO TO 300
C
C *****  STARTUP SECTION(FIRST STEP ALONG ZERO CURVE.  *****
C
      FAIL=.FALSE.
      START=.FALSE.
C DETERMINE SUITABLE INITIAL STEP SIZE.
      H=MIN(H, .10D0, SQRT(SQRT(RELERR*TEMP+ABSERR)))
C USE LINEAR PREDICTOR ALONG TANGENT DIRECTION TO START NEWTON ITERATION
      YPOLD(1)=1.0
      DO 50 J=2,NP1
        YPOLD(J)=0.0
 50   CONTINUE
      CALL TANGNF(S,Y,YP,YPOLD,A,QR,ALPHA,TZ,PIVOT,NFE,N,IFLAG,
     $            PAR,IPAR)
      IF (IFLAG .GT. 0) RETURN
 70   DO 80 J=1,NP1
        TEMP=Y(J) + H * YP(J)
        W(J)=TEMP
        Z0(J)=TEMP
 80   CONTINUE
      DO 200 JUDY=1,LITFH
        RHOLEN=-1.0
C CALCULATE THE NEWTON STEP  TZ  AT THE CURRENT POINT  W .
        CALL TANGNF(RHOLEN,W,WP,YPOLD,A,QR,ALPHA,TZ,PIVOT,NFE,N,IFLAG,
     $              PAR,IPAR)
        IF (IFLAG .GT. 0) RETURN
C
C TAKE NEWTON STEP AND CHECK CONVERGENCE.
        DO 90 J=1,NP1
          W(J)=W(J) + TZ(J)
 90     CONTINUE
        ITNUM=JUDY
C COMPUTE QUANTITIES USED FOR OPTIMAL STEP SIZE ESTIMATION.
        IF (JUDY .EQ. 1) THEN
          LCALC=DNRM2(NP1,TZ,1)
          RCALC=RHOLEN
          DO 110 J=1,NP1
            Z1(J)=W(J)
110       CONTINUE
        ELSE IF (JUDY .EQ. 2) THEN
          LCALC=DNRM2(NP1,TZ,1)/LCALC
          RCALC=RHOLEN/RCALC
        ENDIF
C GO TO MOP-UP SECTION AFTER CONVERGENCE.
        IF (DNRM2(NP1,TZ,1) .LE. RELERR*DNRM2(NP1,W,1)+ABSERR)
     $                                                 GO TO 600
C
200   CONTINUE
C
C NO CONVERGENCE IN  LITFH  ITERATIONS.  REDUCE  H  AND TRY AGAIN.
      IF (H .LE. FOURU*(1.0 + S)) THEN
        IFLAG=6
        RETURN
      ENDIF
      H=.5 * H
      GO TO 70
C
C ***** END OF STARTUP SECTION. *****
C
C ***** PREDICTOR SECTION. *****
C
300   FAIL=.FALSE.
C COMPUTE POINT PREDICTED BY HERMITE INTERPOLANT.  USE STEP SIZE  H
C COMPUTED ON LAST CALL TO  STEPNF .
320   DO 330 J=1,NP1
        TEMP=QOFS(YOLD(J),YPOLD(J),Y(J),YP(J),HOLD,HOLD+H)
        W(J)=TEMP
        Z0(J)=TEMP
330   CONTINUE
C
C ***** END OF PREDICTOR SECTION. *****
C
C ***** CORRECTOR SECTION. *****
C
      DO 500 JUDY=1,LITFH
        RHOLEN=-1.0
C CALCULATE THE NEWTON STEP  TZ  AT THE CURRENT POINT  W .
        CALL TANGNF(RHOLEN,W,WP,YP,A,QR,ALPHA,TZ,PIVOT,NFE,N,IFLAG,
     $              PAR,IPAR)
        IF (IFLAG .GT. 0) RETURN
C
C TAKE NEWTON STEP AND CHECK CONVERGENCE.
        DO 420 J=1,NP1
           W(J)=W(J) + TZ(J)
420     CONTINUE
        ITNUM=JUDY
C COMPUTE QUANTITIES USED FOR OPTIMAL STEP SIZE ESTIMATION.
        IF (JUDY .EQ. 1) THEN
          LCALC=DNRM2(NP1,TZ,1)
          RCALC=RHOLEN
          DO 440 J=1,NP1
            Z1(J)=W(J)
440       CONTINUE
        ELSE IF (JUDY .EQ. 2) THEN
          LCALC=DNRM2(NP1,TZ,1)/LCALC
          RCALC=RHOLEN/RCALC
        ENDIF
C GO TO MOP-UP SECTION AFTER CONVERGENCE.
        IF (DNRM2(NP1,TZ,1) .LE. RELERR*DNRM2(NP1,W,1)+ABSERR)
     $                                                 GO TO 600
C
500   CONTINUE
C
C NO CONVERGENCE IN  LITFH  ITERATIONS.  RECORD FAILURE AT CALCULATED  H
C SAVE THIS STEP SIZE, REDUCE  H  AND TRY AGAIN.
      FAIL=.TRUE.
      HFAIL=H
      IF (H .LE. FOURU*(1.0 + S)) THEN
        IFLAG=6
        RETURN
      ENDIF
      H=.5 * H
      GO TO 320
C
C ***** END OF CORRECTOR SECTION. *****
C
C ***** MOP-UP SECTION. *****
C
C YOLD  AND  Y  ALWAYS CONTAIN THE LAST TWO POINTS FOUND ON THE ZERO
C CURVE OF THE HOMOTOPY MAP.  YPOLD  AND  YP  CONTAIN THE TANGENT
C VECTORS TO THE ZERO CURVE AT  YOLD  AND  Y , RESPECTIVELY.
C
600   DO 620 J=1,NP1
        YOLD(J)=Y(J)
        YPOLD(J)=YP(J)
        Y(J)=W(J)
        YP(J)=WP(J)
        W(J)=Y(J) - YOLD(J)
620   CONTINUE
C UPDATE ARC LENGTH.
      HOLD=DNRM2(NP1,W,1)
      S=S+HOLD
C
C ***** END OF MOP-UP SECTION. *****
C
C ***** OPTIMAL STEP SIZE ESTIMATION SECTION. *****
C
C CALCULATE THE DISTANCE FACTOR  DCALC .
700   DO 710 J=1,NP1
        TZ(J)=Z0(J) - Y(J)
        W(J)=Z1(J) - Y(J)
710   CONTINUE
      DCALC=DNRM2(NP1,TZ,1)
      IF (DCALC .NE. 0.0) DCALC=DNRM2(NP1,W,1)/DCALC
C
C THE OPTIMAL STEP SIZE HBAR IS DEFINED BY
C
C   HT=HOLD * [MIN(LIDEAL/LCALC, RIDEAL/RCALC, DIDEAL/DCALC)]**(1/P)
C
C     HBAR = MIN [ MAX(HT, BMIN*HOLD, HMIN), BMAX*HOLD, HMAX ]
C
C IF CONVERGENCE HAD OCCURRED AFTER 1 ITERATION, SET THE CONTRACTION
C FACTOR  LCALC  TO ZERO.
      IF (ITNUM .EQ. 1) LCALC = 0.0
C FORMULA FOR OPTIMAL STEP SIZE.
      IF (LCALC+RCALC+DCALC .EQ. 0.0) THEN
        HT = SSPAR(7) * HOLD
      ELSE
        HT = (1.0/MAX(LCALC/SSPAR(1), RCALC/SSPAR(2), DCALC/SSPAR(3)))
     $       **(1.0/SSPAR(8)) * HOLD
      ENDIF
C  HT  CONTAINS THE ESTIMATED OPTIMAL STEP SIZE.  NOW PUT IT WITHIN
C REASONABLE BOUNDS.
      H=MIN(MAX(HT,SSPAR(6)*HOLD,SSPAR(4)), SSPAR(7)*HOLD, SSPAR(5))
      IF (ITNUM .EQ. 1) THEN
C IF CONVERGENCE HAD OCCURRED AFTER 1 ITERATION, DON'T DECREASE  H .
        H=MAX(H,HOLD)
      ELSE IF (ITNUM .EQ. LITFH) THEN
C IF CONVERGENCE REQUIRED THE MAXIMUM  LITFH  ITERATIONS, DON'T
C INCREASE  H .
        H=MIN(H,HOLD)
      ENDIF
C IF CONVERGENCE DID NOT OCCUR IN  LITFH  ITERATIONS FOR A PARTICULAR
C H = HFAIL , DON'T CHOOSE THE NEW STEP SIZE LARGER THAN  HFAIL .
      IF (FAIL) H=MIN(H,HFAIL)
C
C
      RETURN
      END
*
      SUBROUTINE STEPNS(N,NFE,IFLAG,START,CRASH,HOLD,H,RELERR,
     $   ABSERR,S,Y,YP,YOLD,YPOLD,A,QR,LENQR,PIVOT,WORK,SSPAR,
     $   PAR,IPAR)
C
C  STEPNS  TAKES ONE STEP ALONG THE ZERO CURVE OF THE HOMOTOPY MAP
C USING A PREDICTOR-CORRECTOR ALGORITHM.  THE PREDICTOR USES A HERMITE
C CUBIC INTERPOLANT, AND THE CORRECTOR RETURNS TO THE ZERO CURVE ALONG
C THE FLOW NORMAL TO THE DAVIDENKO FLOW.  STEPNS  ALSO ESTIMATES A
C STEP SIZE H FOR THE NEXT STEP ALONG THE ZERO CURVE.  NORMALLY
C  STEPNS  IS USED INDIRECTLY THROUGH  FIXPNS , AND SHOULD BE CALLED
C DIRECTLY ONLY IF IT IS NECESSARY TO MODIFY THE STEPPING ALGORITHM'S
C PARAMETERS.
C
C ON INPUT:
C
C N = DIMENSION OF X AND THE HOMOTOPY MAP.
C
C NFE = NUMBER OF JACOBIAN MATRIX EVALUATIONS.
C
C IFLAG = -2, -1, OR 0, INDICATING THE PROBLEM TYPE.
C
C START = .TRUE. ON FIRST CALL TO  STEPNS , .FALSE. OTHERWISE.
C
C HOLD = ||Y - YOLD||; SHOULD NOT BE MODIFIED BY THE USER.
C
C H = UPPER LIMIT ON LENGTH OF STEP THAT WILL BE ATTEMPTED.  H  MUST BE
C    SET TO A POSITIVE NUMBER ON THE FIRST CALL TO  STEPNS .
C    THEREAFTER  STEPNS  CALCULATES AN OPTIMAL VALUE FOR  H , AND  H
C    SHOULD NOT BE MODIFIED BY THE USER.
C
C RELERR, ABSERR = RELATIVE AND ABSOLUTE ERROR VALUES.  THE ITERATION IS
C    CONSIDERED TO HAVE CONVERGED WHEN A POINT W=(X,LAMBDA) IS FOUND
C    SUCH THAT
C
C    ||Z|| <= RELERR*||W|| + ABSERR  ,          WHERE
C
C    Z IS THE NEWTON STEP TO W=(X,LAMBDA).
C
C S = (APPROXIMATE) ARC LENGTH ALONG THE HOMOTOPY ZERO CURVE UP TO
C    Y(S) = (X(S), LAMBDA(S)).
C
C Y(1:N+1) = PREVIOUS POINT (X(S), LAMBDA(S)) FOUND ON THE ZERO CURVE OF
C    THE HOMOTOPY MAP.
C
C YP(1:N+1) = UNIT TANGENT VECTOR TO THE ZERO CURVE OF THE HOMOTOPY MAP
C    AT  Y .
C
C YOLD(1:N+1) = A POINT BEFORE  Y  ON THE ZERO CURVE OF THE HOMOTOPY MAP
C
C YPOLD(1:N+1) = UNIT TANGENT VECTOR TO THE ZERO CURVE OF THE HOMOTOPY
C    MAP AT  YOLD .
C
C A(1:*) = PARAMETER VECTOR IN THE HOMOTOPY MAP.
C
C QR(1:LENQR) = THE N X N SYMMETRIC JACOBIAN MATRIX WITH RESPECT TO X
C    STORED IN PACKED SKYLINE STORAGE FORMAT.  LENQR  AND  PIVOT
C    DESCRIBE THE DATA STRUCTURE IN  QR .
C
C LENQR = LENGTH OF THE ONE-DIMENSIONAL ARRAY  QR  USED TO CONTAIN THE
C    N X N SYMMETRIC JACOBIAN MATRIX WITH RESPECT TO X IN PACKED
C    SKYLINE STORAGE FORMAT.
C
C PIVOT(1:N+2) = INDICES OF THE DIAGONAL ELEMENTS OF THE N X N SYMMETRIC
C    JACOBIAN MATRIX (WITH RESPECT TO X) WITHIN  QR .
C
C WORK(1:13*(N+1)+2*N+LENQR) = WORK ARRAY SPLIT UP AND USED FOR THE
C    CALCULATION OF THE JACOBIAN MATRIX KERNEL, THE NEWTON STEP,
C    INTERPOLATION, AND THE ESTIMATION OF THE NEXT STEP SIZE  H .
C
C SSPAR(1:8) = (LIDEAL, RIDEAL, DIDEAL, HMIN, HMAX, BMIN, BMAX, P)  IS
C    A VECTOR OF PARAMETERS USED FOR THE OPTIMAL STEP SIZE ESTIMATION.
C
C PAR(1:*) AND IPAR(1:*) ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS,
C    WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES
C    RHO, RHOJS.
C
C ON OUTPUT:
C
C N , A , SSPAR  ARE UNCHANGED.
C
C NFE  HAS BEEN UPDATED.
C
C IFLAG
C    = -2, -1, OR 0 (UNCHANGED) ON A NORMAL RETURN.
C
C    = 4 IF THE CONJUGATE GRADIENT ITERATION FAILED TO CONVERGE
C        (MOST LIKELY DUE TO A JACOBIAN MATRIX WITH RANK < N).  THE
C        ITERATION WAS NOT COMPLETED.
C
C    = 6 IF THE NEWTON ITERATION FAILED TO CONVERGE.  W  CONTAINS
C        THE LAST NEWTON ITERATE.
C
C START = .FALSE. ON A NORMAL RETURN.
C
C CRASH
C    = .FALSE. ON A NORMAL RETURN.
C
C    = .TRUE. IF THE STEP SIZE  H  WAS TOO SMALL.  H  HAS BEEN
C      INCREASED TO AN ACCEPTABLE VALUE, WITH WHICH  STEPNS  MAY BE
C      CALLED AGAIN.
C
C    = .TRUE. IF  RELERR  AND/OR  ABSERR  WERE TOO SMALL.  THEY HAVE
C      BEEN INCREASED TO ACCEPTABLE VALUES, WITH WHICH  STEPNS  MAY
C      BE CALLED AGAIN.
C
C HOLD = ||Y - YOLD||.
C
C H = OPTIMAL VALUE FOR NEXT STEP TO BE ATTEMPTED.  NORMALLY  H  SHOULD
C    NOT BE MODIFIED BY THE USER.
C
C RELERR, ABSERR  ARE UNCHANGED ON A NORMAL RETURN.
C
C S = (APPROXIMATE) ARC LENGTH ALONG THE ZERO CURVE OF THE HOMOTOPY MAP
C    UP TO THE LATEST POINT FOUND, WHICH IS RETURNED IN  Y .
C
C Y, YP, YOLD, YPOLD  CONTAIN THE TWO MOST RECENT POINTS AND TANGENT
C    VECTORS FOUND ON THE ZERO CURVE OF THE HOMOTOPY MAP.
C
C
C CALLS  D1MACH , DAXPY , DCOPY , DNRM2 , TANGNS .
C
      DOUBLE PRECISION ABSERR,D1MACH,DCALC,DD001,DD0011,DD01,
     $   DD011,DELS,DNRM2,F0,F1,FOURU,FP0,FP1,H,HFAIL,HOLD,HT,
     $   LCALC,QOFS,RCALC,RELERR,RHOLEN,S,TEMP,TWOU
      INTEGER IFLAG,IPP,IRHO,ITANGW,ITNUM,ITZ,IW,IWP,IZ0,IZ1,
     $   J,JUDY,LENQR,LITFH,N,NFE,NP1
      LOGICAL CRASH,FAIL,START
C
C ***** ARRAY DECLARATIONS. *****
C
      DOUBLE PRECISION Y(N+1),YP(N+1),YOLD(N+1),YPOLD(N+1),A(N),
     $   QR(LENQR),WORK(13*(N+1)+2*N+LENQR),SSPAR(8),PAR(1)
      INTEGER PIVOT(N+2),IPAR(1)
C
C ***** END OF DIMENSIONAL INFORMATION. *****
C
C THE LIMIT ON THE NUMBER OF NEWTON ITERATIONS ALLOWED BEFORE REDUCING
C THE STEP SIZE  H  MAY BE CHANGED BY CHANGING THE FOLLOWING PARAMETER
C STATEMENT:
      PARAMETER (LITFH=4)
C
C DEFINITION OF HERMITE CUBIC INTERPOLANT VIA DIVIDED DIFFERENCES.
C
      DD01(F0,F1,DELS)=(F1-F0)/DELS
      DD001(F0,FP0,F1,DELS)=(DD01(F0,F1,DELS)-FP0)/DELS
      DD011(F0,F1,FP1,DELS)=(FP1-DD01(F0,F1,DELS))/DELS
      DD0011(F0,FP0,F1,FP1,DELS)=(DD011(F0,F1,FP1,DELS) -
     $                            DD001(F0,FP0,F1,DELS))/DELS
      QOFS(F0,FP0,F1,FP1,DELS,S)=((DD0011(F0,FP0,F1,FP1,DELS)*(S-DELS) +
     $   DD001(F0,FP0,F1,DELS))*S + FP0)*S + F0
C
C
      TWOU=2.0*D1MACH(4)
      FOURU=TWOU+TWOU
      NP1=N+1
      IPP=1
      IRHO=N+1
      IW=IRHO+N
      IWP=IW+NP1
      ITZ=IWP+NP1
      IZ0=ITZ+NP1
      IZ1=IZ0+NP1
      ITANGW=IZ1+NP1
      CRASH=.TRUE.
C THE ARCLENGTH  S  MUST BE NONNEGATIVE.
      IF (S .LT. 0.0) RETURN
C IF STEP SIZE IS TOO SMALL, DETERMINE AN ACCEPTABLE ONE.
      IF (H .LT. FOURU*(1.0+S)) THEN
        H=FOURU*(1.0+S)
        RETURN
      ENDIF
C IF ERROR TOLERANCES ARE TOO SMALL, INCREASE THEM TO ACCEPTABLE VALUES.
      TEMP=DNRM2(NP1,Y,1)
      IF (.5*(RELERR*TEMP+ABSERR) .GE. TWOU*TEMP) GO TO 40
      IF (RELERR .NE. 0.0) THEN
        RELERR=FOURU*(1.0+FOURU)
        ABSERR=MAX(ABSERR,0.0D0)
      ELSE
        ABSERR=FOURU*TEMP
      ENDIF
      RETURN
 40   CRASH=.FALSE.
      IF (.NOT. START) GO TO 300
C
C *****  STARTUP SECTION(FIRST STEP ALONG ZERO CURVE.  *****
C
      FAIL=.FALSE.
      START=.FALSE.
C DETERMINE SUITABLE INITIAL STEP SIZE.
      H=MIN(H, .10D0, SQRT(SQRT(RELERR*TEMP+ABSERR)))
C USE LINEAR PREDICTOR ALONG TANGENT DIRECTION TO START NEWTON ITERATION
      YPOLD(NP1)=1.0
      DO 50 J=1,N
        YPOLD(J)=0.0
 50   CONTINUE
      CALL TANGNS(S,Y,YP,WORK(ITZ),YPOLD,A,QR,LENQR,PIVOT,
     $   WORK(IPP),WORK(IRHO),WORK(ITANGW),NFE,N,IFLAG,PAR,IPAR)
      IF (IFLAG .GT. 0) RETURN
 70   DO 80 J=1,NP1
        TEMP=Y(J) + H * YP(J)
        WORK(IW+J-1)=TEMP
        WORK(IZ0+J-1)=TEMP
 80   CONTINUE
      DO 200 JUDY=1,LITFH
        RHOLEN=-1.0
C CALCULATE THE NEWTON STEP  TZ  AT THE CURRENT POINT  W .
        CALL TANGNS(RHOLEN,WORK(IW),WORK(IWP),WORK(ITZ),YPOLD,A,
     $     QR,LENQR,PIVOT,WORK(IPP),WORK(IRHO),WORK(ITANGW),
     $     NFE,N,IFLAG,PAR,IPAR)
        IF (IFLAG .GT. 0) RETURN
C
C TAKE NEWTON STEP AND CHECK CONVERGENCE.
        CALL DAXPY(NP1,1.0D0,WORK(ITZ),1,WORK(IW),1)
        ITNUM=JUDY
C COMPUTE QUANTITIES USED FOR OPTIMAL STEP SIZE ESTIMATION.
        IF (JUDY .EQ. 1) THEN
          LCALC=DNRM2(NP1,WORK(ITZ),1)
          RCALC=RHOLEN
          CALL DCOPY(NP1,WORK(IW),1,WORK(IZ1),1)
        ELSE IF (JUDY .EQ. 2) THEN
          LCALC=DNRM2(NP1,WORK(ITZ),1)/LCALC
          RCALC=RHOLEN/RCALC
        ENDIF
C GO TO MOP-UP SECTION AFTER CONVERGENCE.
        IF ( DNRM2(NP1,WORK(ITZ),1) .LE.
     $     RELERR*DNRM2(NP1,WORK(IW),1)+ABSERR )  GO TO 600
C
200   CONTINUE
C
C NO CONVERGENCE IN  LITFH  ITERATIONS.  REDUCE  H  AND TRY AGAIN.
      IF (H .LE. FOURU*(1.0 + S)) THEN
        IFLAG=6
        RETURN
      ENDIF
      H=.5 * H
      GO TO 70
C
C ***** END OF STARTUP SECTION. *****
C
C ***** PREDICTOR SECTION. *****
C
300   FAIL=.FALSE.
C COMPUTE POINT PREDICTED BY HERMITE INTERPOLANT.  USE STEP SIZE  H
C COMPUTED ON LAST CALL TO  STEPNS .
320   DO 330 J=1,NP1
        TEMP=QOFS(YOLD(J),YPOLD(J),Y(J),YP(J),HOLD,HOLD+H)
        WORK(IW+J-1)=TEMP
        WORK(IZ0+J-1)=TEMP
330   CONTINUE
C
C ***** END OF PREDICTOR SECTION. *****
C
C ***** CORRECTOR SECTION. *****
C
      DO 500 JUDY=1,LITFH
        RHOLEN=-1.0
C CALCULATE THE NEWTON STEP  TZ  AT THE CURRENT POINT  W .
        CALL TANGNS(RHOLEN,WORK(IW),WORK(IWP),WORK(ITZ),YP,A,
     $     QR,LENQR,PIVOT,WORK(IPP),WORK(IRHO),WORK(ITANGW),
     $     NFE,N,IFLAG,PAR,IPAR)
        IF (IFLAG .GT. 0) RETURN
C
C TAKE NEWTON STEP AND CHECK CONVERGENCE.
        CALL DAXPY(NP1,1.0D0,WORK(ITZ),1,WORK(IW),1)
        ITNUM=JUDY
C COMPUTE QUANTITIES USED FOR OPTIMAL STEP SIZE ESTIMATION.
        IF (JUDY .EQ. 1) THEN
          LCALC=DNRM2(NP1,WORK(ITZ),1)
          RCALC=RHOLEN
          CALL DCOPY(NP1,WORK(IW),1,WORK(IZ1),1)
        ELSE IF (JUDY .EQ. 2) THEN
          LCALC=DNRM2(NP1,WORK(ITZ),1)/LCALC
          RCALC=RHOLEN/RCALC
        ENDIF
C GO TO MOP-UP SECTION AFTER CONVERGENCE.
        IF ( DNRM2(NP1,WORK(ITZ),1) .LE.
     $     RELERR*DNRM2(NP1,WORK(IW),1)+ABSERR )  GO TO 600
C
500   CONTINUE
C
C NO CONVERGENCE IN  LITFH  ITERATIONS.  RECORD FAILURE AT CALCULATED  H
C SAVE THIS STEP SIZE, REDUCE  H  AND TRY AGAIN.
      FAIL=.TRUE.
      HFAIL=H
      IF (H .LE. FOURU*(1.0 + S)) THEN
        IFLAG=6
        RETURN
      ENDIF
      H=.5 * H
      GO TO 320
C
C ***** END OF CORRECTOR SECTION. *****
C
C ***** MOP-UP SECTION. *****
C
C YOLD  AND  Y  ALWAYS CONTAIN THE LAST TWO POINTS FOUND ON THE ZERO
C CURVE OF THE HOMOTOPY MAP.  YPOLD  AND  YP  CONTAIN THE TANGENT
C VECTORS TO THE ZERO CURVE AT  YOLD  AND  Y , RESPECTIVELY.
C
600   CALL DCOPY(NP1,Y,1,YOLD,1)
      CALL DCOPY(NP1,YP,1,YPOLD,1)
      CALL DCOPY(NP1,WORK(IW),1,Y,1)
      CALL DCOPY(NP1,WORK(IWP),1,YP,1)
      CALL DAXPY(NP1,-1.0D0,YOLD,1,WORK(IW),1)
C UPDATE ARC LENGTH.
      HOLD=DNRM2(NP1,WORK(IW),1)
      S=S+HOLD
C
C ***** END OF MOP-UP SECTION. *****
C
C ***** OPTIMAL STEP SIZE ESTIMATION SECTION. *****
C
C CALCULATE THE DISTANCE FACTOR  DCALC .
700   CALL DAXPY(NP1,-1.0D0,Y,1,WORK(IZ0),1)
      CALL DAXPY(NP1,-1.0D0,Y,1,WORK(IZ1),1)
      DCALC=DNRM2(NP1,WORK(IZ0),1)
      IF (DCALC .NE. 0.0) DCALC=DNRM2(NP1,WORK(IZ1),1)/DCALC
C
C THE OPTIMAL STEP SIZE HBAR IS DEFINED BY
C
C   HT=HOLD * [MIN(LIDEAL/LCALC, RIDEAL/RCALC, DIDEAL/DCALC)]**(1/P)
C
C     HBAR = MIN [ MAX(HT, BMIN*HOLD, HMIN), BMAX*HOLD, HMAX ]
C
C IF CONVERGENCE HAD OCCURRED AFTER 1 ITERATION, SET THE CONTRACTION
C FACTOR  LCALC  TO ZERO.
      IF (ITNUM .EQ. 1) LCALC = 0.0
C FORMULA FOR OPTIMAL STEP SIZE.
      IF (LCALC+RCALC+DCALC .EQ. 0.0) THEN
        HT = SSPAR(7) * HOLD
      ELSE
        HT = (1.0/MAX(LCALC/SSPAR(1), RCALC/SSPAR(2), DCALC/SSPAR(3)))
     $       **(1.0/SSPAR(8)) * HOLD
      ENDIF
C  HT  CONTAINS THE ESTIMATED OPTIMAL STEP SIZE.  NOW PUT IT WITHIN
C REASONABLE BOUNDS.
      H=MIN(MAX(HT,SSPAR(6)*HOLD,SSPAR(4)), SSPAR(7)*HOLD, SSPAR(5))
      IF (ITNUM .EQ. 1) THEN
C IF CONVERGENCE HAD OCCURRED AFTER 1 ITERATION, DON'T DECREASE  H .
        H=MAX(H,HOLD)
      ELSE IF (ITNUM .EQ. LITFH) THEN
C IF CONVERGENCE REQUIRED THE MAXIMUM  LITFH  ITERATIONS, DON'T
C INCREASE  H .
        H=MIN(H,HOLD)
      ENDIF
C IF CONVERGENCE DID NOT OCCUR IN  LITFH  ITERATIONS FOR A PARTICULAR
C H = HFAIL , DON'T CHOOSE THE NEW STEP SIZE LARGER THAN  HFAIL .
      IF (FAIL) H=MIN(H,HFAIL)
C
C
      RETURN
      END
*
        SUBROUTINE STEPQF(N,NFE,IFLAG,START,CRASH,HOLD,H,
     $            WK,RELERR,ABSERR,S,Y,YP,YOLD,YPOLD,A,QT,R,
     $            F0,F1,Z0,DZ,W,T,SSPAR,PAR,IPAR)
C
C SUBROUTINE  STEPQF  TAKES ONE STEP ALONG THE ZERO CURVE OF THE
C HOMOTOPY MAP  RHO(LAMBDA,X)  USING A PREDICTOR-CORRECTOR ALGORITHM.
C THE PREDICTOR USES A HERMITE CUBIC INTERPOLANT, AND THE CORRECTOR
C RETURNS TO THE ZERO CURVE USING A QUASI-NEWTON ALGORITHM, REMAINING
C IN A HYPERPLANE PERPENDICULAR TO THE MOST RECENT TANGENT VECTOR.
C  STEPQF  ALSO ESTIMATES A STEP SIZE  H  FOR THE NEXT STEP ALONG THE
C ZERO CURVE.
C
C
C ON INPUT:
C
C N = DIMENSION OF  X.
C
C NFE = NUMBER OF JACOBIAN MATRIX EVALUATIONS.
C
C IFLAG = -2, -1, OR 0, INDICATING THE PROBLEM TYPE.
C
C START = .TRUE. ON FIRST CALL TO  STEPQF, .FALSE. OTHERWISE.
C         SHOULD NOT BE MODIFIED BY THE USER AFTER THE FIRST CALL.
C
C HOLD = ||Y - YOLD|| ; SHOULD NOT BE MODIFIED BY THE USER.
C
C H = UPPER LIMIT ON LENGTH OF STEP THAT WILL BE ATTEMPTED.  H  MUST
C    BE SET TO A POSITIVE NUMBER ON THE FIRST CALL TO  STEPQF.
C    THEREAFTER,  STEPQF  CALCULATES AN OPTIMAL VALUE FOR  H, AND  H
C    SHOULD NOT BE MODIFIED BY THE USER.
C
C WK = APPROXIMATE CURVATURE FOR THE LAST STEP (COMPUTED BY PREVIOUS
C    CALL TO  STEPQF).  UNDEFINED ON FIRST CALL.  SHOULD NOT BE
C    MODIFIED BY THE USER.
C
C RELERR, ABSERR = RELATIVE AND ABSOLUTE ERROR VALUES.  THE ITERATION
C    IS CONSIDERED TO HAVE CONVERGED WHEN A POINT  Z=(LAMBDA,X)  IS
C    FOUND SUCH THAT
C       ||DZ|| .LE. RELERR*||Z|| + ABSERR,
C    WHERE  DZ  IS THE LAST QUASI-NEWTON STEP.
C
C S  = (APPROXIMATE) ARC LENGTH ALONG THE HOMOTOPY ZERO CURVE UP TO
C    Y(S) = (LAMBDA(S), X(S)).
C
C Y(1:N+1) = PREVIOUS POINT (LAMBDA(S),X(S)) FOUND ON THE ZERO CURVE
C    OF THE HOMOTOPY MAP.
C
C YP(1:N+1) = UNIT TANGENT VECTOR TO THE ZERO CURVE OF THE HOMOTOPY
C    MAP AT  Y.  INPUT IN THIS VECTOR IS NOT USED ON THE FIRST CALL
C    TO  STEPQF.
C
C YOLD(1:N+1) = A POINT BEFORE  Y  ON THE ZERO CURVE OF THE HOMOTOPY
C    MAP.  INPUT IN THIS VECTOR IS NOT USED ON THE FIRST CALL TO
C    STEPQF.
C
C YPOLD(1:N+1) = UNIT TANGENT VECTOR TO THE ZERO CURVE OF THE
C    HOMOTOPY MAP AT  YOLD.
C
C A(1:N) = PARAMETER VECTOR IN THE HOMOTOPY MAP.
C
C QT(1:N+1,1:N+1) = HOLDS  Q TRANSPOSE  OF THE QR FACTORIZATION OF
C    THE AUGMENTED JACOBIAN MATRIX AT  Y.
C
C R((N+1)*(N+2)/2) = HOLDS THE UPPER TRIANGLE OF  R  OF THE QR
C    FACTORIZATION, STORED BY ROWS.
C
C F0(1:N+1), F1(1:N+1), Z0(1:N+1), DZ(1:N+1), W(1:N+1), T(1:N+1) ARE
C    WORK ARRAYS.
C
C SSPAR(1:4) = PARAMETERS USED FOR COMPUTATION OF THE OPTIMAL STEP SIZE.
C    SSPAR(1) = HMIN, SSPAR(2) = HMAX, SSPAR(3) = BMIN, SSPAR(4) = BMAX.
C    THE OPTIMAL STEP  H  IS RESTRICTED SUCH THAT
C       HMIN .LE. H .LE. HMAX, AND  BMIN*HOLD .LE. H .LE. BMAX*HOLD.
C
C PAR(1:*)  AND  IPAR(1:*)  ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS,
C    WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES
C    RHO, RHOJAC.
C
C
C ON OUTPUT:
C
C NFE HAS BEEN UPDATED.
C
C IFLAG
C
C    = -2, -1, OR 0 (UNCHANGED) ON A NORMAL RETURN.
C
C    = 4 IF A JACOBIAN MATRIX WITH RANK <  N  HAS OCCURRED.  THE
C        ITERATION WAS NOT COMPLETED.
C
C    = 6 IF THE ITERATION FAILED TO CONVERGE.
C
C START = .FALSE. ON A NORMAL RETURN.
C
C CRASH
C
C    = .FALSE. ON A NORMAL RETURN.
C
C    = .TRUE. IF THE STEP SIZE  H  WAS TOO SMALL.  H  HAS BEEN
C      INCREASED TO AN ACCEPTABLE VALUE, WITH WHICH  STEPQF  MAY BE
C      CALLED AGAIN.
C
C    = .TRUE. IF  RELERR  AND/OR  ABSERR  WERE TOO SMALL.  THEY HAVE
C      BEEN INCREASED TO ACCEPTABLE VALUES, WITH WHICH  STEPQF  MAY
C      BE CALLED AGAIN.
C
C HOLD = ||Y-YOLD||.
C
C H = OPTIMAL VALUE FOR NEXT STEP TO BE ATTEMPTED.  NORMALLY  H  SHOULD
C     NOT BE MODIFIED BY THE USER.
C
C WK = APPROXIMATE CURVATURE FOR THE STEP TAKEN BY  STEPQF.
C
C S = (APPROXIMATE) ARC LENGTH ALONG THE ZERO CURVE OF THE HOMOTOPY
C     MAP UP TO THE LATEST POINT FOUND, WHICH IS RETURNED IN  Y.
C
C RELERR, ABSERR  ARE UNCHANGED ON A NORMAL RETURN.  THEY ARE POSSIBLY
C     CHANGED IF  CRASH  = .TRUE. (SEE DESCRIPTION OF  CRASH  ABOVE).
C
C Y, YP, YOLD, YPOLD  CONTAIN THE TWO MOST RECENT POINTS AND TANGENT
C     VECTORS FOUND ON THE ZERO CURVE OF THE HOMOTOPY MAP.
C
C QT, R  STORE THE QR FACTORIZATION OF THE AUGMENTED JACOBIAN MATRIX
C     EVALUATED AT  Y.
C
C
C CALLS  D1MACH, DAXPY, DCOPY, DDOT, DNRM2, DSCAL, F (OR RHO), FJAC
C     (OR RHOJAC), QRFAQF, QRSLQF, TANGQF, UPQRQF.
C
C ***** DECLARATIONS *****
C
C     FUNCTION DECLARATIONS
C
        DOUBLE PRECISION D1MACH, DDOT, DNRM2, QOFS
C
C     LOCAL VARIABLES
C
        DOUBLE PRECISION ALPHA, DD001, DD0011, DD01, DD011, DELS, ETA,
     $    FOURU, GAMMA, HFAIL, HTEMP, IDLERR, ONE, P0, P1, PP0, PP1,
     $    TEMP, TWOU, WKOLD
        INTEGER I, ITCNT, LITFH, J, JP1, NP1
        LOGICAL FAILED
C
C     SCALAR ARGUMENTS
C
        INTEGER N, NFE, IFLAG
        LOGICAL START, CRASH
        DOUBLE PRECISION HOLD, H, WK, RELERR, ABSERR, S
C
C     ARRAY DECLARATIONS
C
        DOUBLE PRECISION Y(N+1), YP(N+1), YOLD(N+1), YPOLD(N+1),
     $    A(N), QT(N+1,N+1), R((N+1)*(N+2)/2), F0(N+1), F1(N+1),
     $    Z0(N+1), DZ(N+1), W(N+1), T(N+1), SSPAR(4), PAR(1)
        INTEGER IPAR(1)
C
        SAVE
C
C ***** END OF DECLARATIONS *****
C
C DEFINITION OF HERMITE CUBIC INTERPOLANT VIA DIVIDED DIFFERENCES.
C
        DD01(P0,P1,DELS) = (P1-P0)/DELS
        DD001(P0,PP0,P1,DELS) = (DD01(P0,P1,DELS)-PP0)/DELS
        DD011(P0,P1,PP1,DELS) = (PP1-DD01(P0,P1,DELS))/DELS
        DD0011(P0,PP0,P1,PP1,DELS) = (DD011(P0,P1,PP1,DELS) -
     $                                DD001(P0,PP0,P1,DELS))/DELS
        QOFS(P0,PP0,P1,PP1,DELS,S) = ((DD0011(P0,PP0,P1,PP1,DELS)*
     $    (S-DELS) + DD001(P0,PP0,P1,DELS))*S + PP0)*S + P0
C
C ***** FIRST EXECUTABLE STATEMENT *****
C
C
C ***** INITIALIZATION *****
C
C ETA = PARAMETER FOR BROYDEN'S UPDATE.
C LITFH = MAXIMUM NUMBER OF QUASI-NEWTON ITERATIONS ALLOWED.
C
        ONE = 1.0
        TWOU = 2.0*D1MACH(4)
        FOURU = TWOU + TWOU
        NP1 = N+1
        FAILED = .FALSE.
        CRASH = .TRUE.
        ETA = 50.0*TWOU
        LITFH = 2*(INT(-LOG10(ABSERR+RELERR*DNRM2(NP1,Y,1)))+1)
C
C CHECK THAT ALL INPUT PARAMETERS ARE CORRECT.
C
C     THE ARCLENGTH  S MUST BE NONNEGATIVE.
C
        IF (S .LT. 0.0) RETURN
C
C     IF STEP SIZE IS TOO SMALL, DETERMINE AN ACCEPTABLE ONE.
C
        IF (H .LT. FOURU*(1.0+S)) THEN
          H=FOURU*(1.0 + S)
          RETURN
        END IF
C
C     IF ERROR TOLERANCES ARE TOO SMALL, INCREASE THEM TO ACCEPTABLE
C     VALUES.
C
        TEMP=DNRM2(NP1,Y,1) + 1.0
        IF (.5*(RELERR*TEMP+ABSERR) .LT. TWOU*TEMP) THEN
          IF (RELERR .NE. 0.0) THEN
            RELERR = FOURU*(1.0+FOURU)
            TEMP = 0.0
            ABSERR = MAX(ABSERR,TEMP)
          ELSE
            ABSERR=FOURU*TEMP
          END IF
          RETURN
        END IF
C
C     INPUT PARAMETERS WERE ALL ACCEPTABLE.
C
        CRASH = .FALSE.
C
C COMPUTE  YP  ON FIRST CALL.
C NOTE:  DZ  IS USED SIMPLY AS A WORK ARRAY HERE.
C
        IF (START) THEN
          CALL TANGQF(Y,YP,YPOLD,A,QT,R,W,DZ,T,N,IFLAG,NFE,PAR,IPAR)
          IF (IFLAG .GT. 0) RETURN
        END IF
C
C F0 = (RHO(Y), YP*Y) TRANSPOSE (DIFFERENT FOR EACH PROBLEM TYPE).
C
         IF (IFLAG .EQ. -2) THEN
C
C          CURVE TRACKING PROBLEM.
C
           CALL RHO(A,Y(1),Y(2),F0,PAR,IPAR)
         ELSE IF (IFLAG .EQ. -1) THEN
C
C          ZERO FINDING PROBLEM.
C
           CALL F(Y(2),F0)
           DO 5 I=1,N
             F0(I) = Y(1)*F0(I) + (1.0-Y(1))*(Y(I+1)-A(I))
  5        CONTINUE
         ELSE
C
C          FIXED POINT PROBLEM.
C
           CALL F(Y(2),F0)
           DO 10 I=1,N
             F0(I) = Y(1)*(A(I)-F0(I))+Y(I+1)-A(I)
  10       CONTINUE
         END IF
C
C        DEFINE LAST ROW OF F0  =  YP*Y.
C
           F0(NP1) = DDOT(NP1,YP,1,Y,1)
C
C ***** END OF INITIALIZATION *****
C
C ***** COMPUTE PREDICTOR POINT Z0 *****
C
  20    IF (START) THEN
C
C         COMPUTE Z0 WITH LINEAR PREDICTOR USING Y, YP --
C         Z0 = Y+H*YP.
C
          CALL DCOPY(NP1,Y,1,Z0,1)
          CALL DAXPY(NP1,H,YP,1,Z0,1)
C
        ELSE
C
C         COMPUTE Z0 WITH CUBIC PREDICTOR.
C
          DO 30 I=1,NP1
            Z0(I) = QOFS(YOLD(I),YPOLD(I),Y(I),YP(I),HOLD,HOLD+H)
  30      CONTINUE
C
        END IF
C
C F1 = (RHO(Z0), YP*Z0) TRANSPOSE.
C
        IF (IFLAG .EQ. -2) THEN
          CALL RHO(A,Z0(1),Z0(2),F1,PAR,IPAR)
        ELSE IF (IFLAG .EQ. -1) THEN
          CALL F(Z0(2),F1)
          DO 40 I=1,N
            F1(I) = Z0(1)*F1(I) + (1.0-Z0(1))*(Z0(I+1)-A(I))
  40      CONTINUE
        ELSE
          CALL F(Z0(2),F1)
          DO 50 I=1,N
            F1(I) = Z0(1)*(A(I)-F1(I))+Z0(I+1)-A(I)
  50      CONTINUE
        END IF
        F1(NP1) = DDOT(NP1,YP,1,Z0,1)
C
C ***** END OF PREDICTOR SECTION *****
C
C ***** SET-UP FOR QUASI-NEWTON ITERATION *****
C
        IF (FAILED) THEN
C
C GENERATE QT = AUGMENTED JACOBIAN MATRIX FOR POINT Z0=(LAMBDA,X).
C
          IF (IFLAG .EQ. -2) THEN
C
C           CURVE TRACKING PROBLEM:
C           D(RHO) = (D RHO(A,LAMBDA,X)/D LAMBDA, D RHO(A,LAMBDA,X)/DX).
C
            DO 60 J = 1,NP1
              CALL RHOJAC(A,Z0(1),Z0(2),QT(1,J),J,PAR,IPAR)
  60        CONTINUE
          ELSE IF (IFLAG .EQ. -1) THEN
C
C           ZERO FINDING PROBLEM:
C           D(RHO) = (F(X) - X + A, LAMBDA*DF(X) + (1-LAMBDA)*I).
C
            CALL F(Z0(2),QT(1,1))
            DO 70 I=1,N
              QT(I,1) = A(I) - Z0(I+1) + QT(I,1)
  70        CONTINUE
            DO 80 J= 1,N
              JP1 = J+1
              CALL FJAC(Z0(2),QT(1,JP1),J)
              CALL DSCAL(N, Z0(1), QT(1,JP1), 1)
              QT(J,JP1) = 1.0 - Z0(1) + QT(J,JP1)
  80        CONTINUE
          ELSE
C
C           FIXED POINT PROBLEM:
C           D(RHO) = (A - F(X), I - LAMBDA*DF(X)).
C
            CALL F(Z0(2),QT(1,1))
            CALL DSCAL(N,-ONE,QT(1,1),1)
            CALL DAXPY(N,ONE,A,1,QT(1,1),1)
            DO 90 J=1,N
              JP1 = J+1
              CALL FJAC(Z0(2),QT(1,JP1),J)
              CALL DSCAL(N, -Z0(1), QT(1,JP1), 1)
              QT(J,JP1) = 1.0 + QT(J,JP1)
  90        CONTINUE
          END IF
C
C       DEFINE LAST ROW OF QT = YP.
C
          CALL DCOPY(NP1, YP, 1, QT(NP1,1), NP1)
C
C       COUNT JACOBIAN EVALUATION.
C
          NFE = NFE+1
C
C DO FIRST QUASI NEWTON STEP.
C
C       FACTOR AUG.
C
          CALL QRFAQF(QT,R,NP1,IFLAG)
          IF (IFLAG .GT. 0) RETURN
C
C       COMPUTE NEWTON STEP.
C
          CALL DCOPY(N,F1,1,DZ,1)
          CALL DSCAL(N,-ONE,DZ,1)
          DZ(NP1) = 0.0
          CALL QRSLQF(QT,R,DZ,W,NP1)
C
C       TAKE STEP AND SET F0 = F1.
C
          CALL DAXPY(NP1, ONE, DZ, 1, Z0, 1)
          CALL DCOPY(NP1, F1, 1, F0, 1)
C
C       F1 = (RHO(Z0), YP*Z0) TRANSPOSE.
C
          IF (IFLAG .EQ. -2) THEN
            CALL RHO(A,Z0(1),Z0(2),F1,PAR,IPAR)
          ELSE IF (IFLAG .EQ. -1) THEN
            CALL F(Z0(2),F1)
            DO 100 I=1,N
              F1(I) = Z0(1)*F1(I) + (1.0-Z0(1))*(Z0(I+1)-A(I))
  100       CONTINUE
          ELSE
            CALL F(Z0(2),F1)
            DO 110 I=1,N
              F1(I) = Z0(1)*(A(I)-F1(I))+Z0(I+1)-A(I)
  110       CONTINUE
          END IF
          F1(NP1) = DDOT(NP1,YP,1,Z0,1)
C
        ELSE
C
C IF NOT FAILED THEN DEFINE  DZ=Z0-Y  PRIOR TO MAIN LOOP.
C
          CALL DCOPY(NP1,Z0,1,DZ,1)
          CALL DAXPY(NP1,-ONE,Y,1,DZ,1)
        END IF
C
C ***** END OF PREPARATION FOR QUASI-NEWTON ITERATION *****
C
C ***** QUASI-NEWTON ITERATION *****
C
        DO 140 ITCNT = 1,LITFH
C
C PERFORM UPDATE FOR NEWTON STEP JUST TAKEN.
C
          CALL UPQRQF(NP1,ETA,DZ,F0,F1,QT,R,W,T)
C
C COMPUTE NEXT NEWTON STEP.
C
          CALL DCOPY(N,F1,1,DZ,1)
          CALL DSCAL(N,-ONE,DZ,1)
          DZ(NP1) = 0.0
          CALL QRSLQF(QT,R,DZ,W,NP1)
C
C TAKE STEP.
C
          CALL DAXPY(NP1, ONE, DZ, 1, Z0, 1)
C
C CHECK FOR CONVERGENCE.
C
          IF (DNRM2(NP1,DZ,1) .LE. RELERR*DNRM2(NP1,Z0,1)+ABSERR) THEN
             GO TO 160
          END IF
C
C IF NOT CONVERGED, PREPARE FOR NEXT ITERATION.
C
C       F0 = F1.
C
          CALL DCOPY(NP1, F1, 1, F0, 1)
C
C       F1 = (RHO(Z0), YP*Z0) TRANSPOSE.
C
          IF (IFLAG .EQ. -2) THEN
            CALL RHO(A,Z0(1),Z0(2),F1,PAR,IPAR)
          ELSE IF (IFLAG .EQ. -1) THEN
            CALL F(Z0(2),F1)
            DO 120 I=1,N
              F1(I) = Z0(1)*F1(I) + (1.0-Z0(1))*(Z0(I+1)-A(I))
  120       CONTINUE
          ELSE
            CALL F(Z0(2),F1)
            DO 130 I=1,N
              F1(I) = Z0(1)*(A(I)-F1(I))+Z0(I+1)-A(I)
  130       CONTINUE
          END IF
          F1(NP1) = DDOT(NP1,YP,1,Z0,1)
C
  140   CONTINUE
C
C ***** END OF QUASI-NEWTON LOOP *****
C
C ***** DIDN'T CONVERGE OR TANGENT AT NEW POINT DID NOT MAKE
C       AN ACUTE ANGLE WITH YPOLD -- TRY AGAIN WITH A SMALLER H *****
C
  150   FAILED = .TRUE.
        HFAIL = H
        IF (H .LE. FOURU*(1.0 + S)) THEN
          IFLAG = 6
          RETURN
        ELSE
          H = .5 * H
        END IF
        GO TO 20
C
C ***** END OF CONVERGENCE FAILURE SECTION *****
C
C ***** CONVERGED -- MOP UP AND RETURN *****
C
C COMPUTE TANGENT & AUGMENTED JACOBIAN AT  Z0.
C NOTE:  DZ  AND  F1  ARE USED SIMPLY AS WORK ARRAYS HERE.
C
  160   CALL TANGQF(Z0,T,YP,A,QT,R,W,DZ,F1,N,IFLAG,NFE,PAR,IPAR)
        IF (IFLAG .GT. 0) RETURN
C
C CHECK THAT COMPUTED TANGENT  T  MAKES AN ANGLE NO LARGER THAN
C 60 DEGREES WITH CURRENT TANGENT  YP.  (I.E. COS OF ANGLE < .5)
C IF NOT, STEP SIZE WAS TOO LARGE, SO THROW AWAY Z0, AND TRY
C AGAIN WITH A SMALLER STEP.
C
        ALPHA = DDOT(NP1,T,1,YP,1)
        IF (ALPHA .LT. 0.5) GOTO 150
        ALPHA = ACOS(ALPHA)
C
C SET UP VARIABLES FOR NEXT CALL.
C
        CALL DCOPY(NP1,Y,1,YOLD,1)
        CALL DCOPY(NP1,Z0,1,Y,1)
        CALL DCOPY(NP1,YP,1,YPOLD,1)
        CALL DCOPY(NP1,T,1,YP,1)
C
C UPDATE ARCLENGTH   S = S + ||Y-YOLD||.
C
        HTEMP = HOLD
        CALL DAXPY(NP1,-ONE,YOLD,1,Z0,1)
        HOLD = DNRM2(NP1,Z0,1)
        S = S+HOLD
C
C COMPUTE OPTIMAL STEP SIZE.
C   IDLERR = DESIRED ERROR FOR NEXT PREDICTOR STEP.
C   WK = APPROXIMATE CURVATURE = 2*SIN(ALPHA/2)/HOLD  WHERE
C        ALPHA = ARCCOS(YP*YPOLD).
C   GAMMA = EXPECTED CURVATURE FOR NEXT STEP, COMPUTED BY
C        EXTRAPOLATING FROM CURRENT CURVATURE  WK, AND LAST
C        CURVATURE  WKOLD.  GAMMA IS FURTHER REQUIRED TO BE
C        POSITIVE.
C
        WKOLD = WK
        IDLERR = SQRT(SQRT(ABSERR + RELERR*DNRM2(NP1,Y,1)))
C
C     IDLERR SHOULD BE NO BIGGER THAN 1/2 PREVIOUS STEP.
C
        IDLERR = MIN(.5*HOLD,IDLERR)
        WK = 2.0*ABS(SIN(.5*ALPHA))/HOLD
        IF (START) THEN
           GAMMA = WK
        ELSE
           GAMMA = WK + HOLD/(HOLD+HTEMP)*(WK-WKOLD)
        END IF
        GAMMA = MAX(GAMMA, 0.01*ONE)
        H = SQRT(2.0*IDLERR/GAMMA)
C
C     ENFORCE RESTRICTIONS ON STEP SIZE SO AS TO ENSURE STABILITY.
C        HMIN <= H <= HMAX, BMIN*HOLD <= H <= BMAX*HOLD.
C
        H = MIN(MAX(SSPAR(1),SSPAR(3)*HOLD,H),SSPAR(4)*HOLD,SSPAR(2))
        IF (FAILED) H = MIN(HFAIL,H)
        START = .FALSE.
C
C ***** END OF MOP UP SECTION *****
C
        RETURN
C
C ***** END OF SUBROUTINE STEPQF *****
        END
        SUBROUTINE STEPQS(N,NFE,IFLAG,LENQR,START,CRASH,HOLD,H,
     $            WK,RELERR,ABSERR,S,Y,YP,YOLD,YPOLD,A,QR,PIVOT,PP,
     $            RHOVEC,Z0,DZ,T,WORK,SSPAR,PAR,IPAR)
C
C SUBROUTINE  STEPQS  TAKES ONE STEP ALONG THE ZERO CURVE OF THE
C HOMOTOPY MAP  RHO(X,LAMBDA)  USING A PREDICTOR-CORRECTOR ALGORITHM.
C THE PREDICTOR USES A HERMITE CUBIC INTERPOLANT, AND THE CORRECTOR
C RETURNS TO THE ZERO CURVE USING A NEWTON ITERATION, REMAINING
C IN A HYPERPLANE PERPENDICULAR TO THE MOST RECENT TANGENT VECTOR.
C  STEPQS  ALSO ESTIMATES A STEP SIZE  H  FOR THE NEXT STEP ALONG THE
C ZERO CURVE.
C
C
C ON INPUT:
C
C N = DIMENSION OF  X.
C
C NFE = NUMBER OF JACOBIAN MATRIX EVALUATIONS.
C
C IFLAG = -2, -1, OR 0, INDICATING THE PROBLEM TYPE.
C
C LENQR = THE LENGTH OF THE ONE DIMENSIONAL ARRAY  QR.
C
C START = .TRUE. ON FIRST CALL TO  STEPQS, .FALSE. OTHERWISE.
C         SHOULD NOT BE MODIFIED BY THE USER AFTER THE FIRST CALL.
C
C HOLD = ||Y - YOLD|| ; SHOULD NOT BE MODIFIED BY THE USER.
C
C H = UPPER LIMIT ON LENGTH OF STEP THAT WILL BE ATTEMPTED.  H  MUST
C    BE SET TO A POSITIVE NUMBER ON THE FIRST CALL TO  STEPQS.
C    THEREAFTER,  STEPQS  CALCULATES AN OPTIMAL VALUE FOR  H, AND  H
C    SHOULD NOT BE MODIFIED BY THE USER.
C
C WK = APPROXIMATE CURVATURE FOR THE LAST STEP (COMPUTED BY PREVIOUS
C    CALL TO  STEPQS).  UNDEFINED ON FIRST CALL.  SHOULD NOT BE
C    MODIFIED BY THE USER.
C
C RELERR, ABSERR = RELATIVE AND ABSOLUTE ERROR VALUES.  THE ITERATION
C    IS CONSIDERED TO HAVE CONVERGED WHEN A POINT  Z=(X,LAMBDA)  IS
C    FOUND SUCH THAT
C       ||DZ|| .LE. RELERR*||Z|| + ABSERR,
C    WHERE  DZ  IS THE LAST NEWTON STEP.
C
C S  = (APPROXIMATE) ARC LENGTH ALONG THE HOMOTOPY ZERO CURVE UP TO
C    Y(S) = (X(S),LAMBDA(S)).
C
C Y(1:N+1) = PREVIOUS POINT (X(S),LAMBDA(S)) FOUND ON THE ZERO CURVE
C    OF THE HOMOTOPY MAP.
C
C YP(1:N+1) = UNIT TANGENT VECTOR TO THE ZERO CURVE OF THE HOMOTOPY
C    MAP AT  Y.  INPUT IN THIS VECTOR IS NOT USED ON THE FIRST CALL
C    TO  STEPQS.
C
C YOLD(1:N+1) = A POINT BEFORE  Y  ON THE ZERO CURVE OF THE HOMOTOPY
C    MAP.  INPUT IN THIS VECTOR IS NOT USED ON THE FIRST CALL TO
C    STEPQS.
C
C YPOLD(1:N+1) = UNIT TANGENT VECTOR TO THE ZERO CURVE OF THE
C    HOMOTOPY MAP AT  YOLD.
C
C A(1:N) = PARAMETER VECTOR IN THE HOMOTOPY MAP.
C
C QR(1:LENQR)  IS A WORK ARRAY CONTAINING THE N X N SYMMETRIC
C    JACOBIAN MATRIX WITH RESPECT TO X STORED IN PACKED SKYLINE
C    STORAGE FORMAT.  LENQR  AND  PIVOT  DESCRIBE THE DATA
C    STRUCTURE IN  QR.  (SEE SUBROUTINE  PCGQS  FOR A DESCRIPTION
C    OF THIS DATA STRUCTURE).
C
C PIVOT(1:N+2)  IS A WORK ARRAY WHOSE FIRST N+1 COMPONENTS CONTAIN
C    THE INDICES OF THE DIAGONAL ELEMENTS OF THE N X N SYMMETRIC
C    JACOBIAN MATRIX (WITH RESPECT TO X) WITHIN  QR.
C
C PP(1:N)  IS A WORK ARRAY CONTAINING THE NEGATIVE OF THE LAST COLUMN
C    OF THE JACOBIAN MATRIX  -[D RHO/D LAMBDA].
C
C RHOVEC(1:N+1), Z0(1:N+1), DZ(1:N+1), T(1:N+1)  ARE ALL WORK ARRAYS
C    USED BY  STEPQS, TANGQS, AND ROOTQS  TO CALCULATE THE TANGENT
C    VECTORS AND NEWTON STEPS.
C
C WORK(1:8*(N+1)+LENQR)  IS A WORK ARRAY USED BY THE CONJUGATE GRADIENT
C    ALGORITHM TO SOLVE LINEAR SYSTEMS.
C
C SSPAR(1:4) = PARAMETERS USED FOR COMPUTATION OF THE OPTIMAL STEP SIZE.
C    SSPAR(1) = HMIN, SSPAR(2) = HMAX, SSPAR(3) = BMIN, SSPAR(4) = BMAX.
C    THE OPTIMAL STEP  H  IS RESTRICTED SUCH THAT
C       HMIN .LE. H .LE. HMAX, AND  BMIN*HOLD .LE. H .LE. BMAX*HOLD.
C
C PAR(1:*)  AND  IPAR(1:*)  ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS,
C    WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES
C    RHO, RHOJS.
C
C
C ON OUTPUT:
C
C N, LENQR, A  ARE UNCHANGED.
C
C NFE HAS BEEN UPDATED.
C
C IFLAG
C
C    = -2, -1, OR 0 (UNCHANGED) ON A NORMAL RETURN.
C
C    = 4 IF A JACOBIAN MATRIX WITH RANK <  N  HAS OCCURRED.  THE
C        ITERATION WAS NOT COMPLETED.
C
C    = 6 IF THE ITERATION FAILED TO CONVERGE.
C
C START = .FALSE. ON A NORMAL RETURN.
C
C CRASH
C
C    = .FALSE. ON A NORMAL RETURN.
C
C    = .TRUE. IF THE STEP SIZE  H  WAS TOO SMALL.  H  HAS BEEN
C      INCREASED TO AN ACCEPTABLE VALUE, WITH WHICH  STEPQS  MAY BE
C      CALLED AGAIN.
C
C    = .TRUE. IF  RELERR  AND/OR  ABSERR  WERE TOO SMALL.  THEY HAVE
C      BEEN INCREASED TO ACCEPTABLE VALUES, WITH WHICH  STEPQS  MAY
C      BE CALLED AGAIN.
C
C HOLD = ||Y-YOLD||.
C
C H = OPTIMAL VALUE FOR NEXT STEP TO BE ATTEMPTED.  NORMALLY  H  SHOULD
C     NOT BE MODIFIED BY THE USER.
C
C WK = APPROXIMATE CURVATURE FOR THE STEP TAKEN BY  STEPQS.
C
C S = (APPROXIMATE) ARC LENGTH ALONG THE ZERO CURVE OF THE HOMOTOPY
C     MAP UP TO THE LATEST POINT FOUND, WHICH IS RETURNED IN  Y.
C
C RELERR, ABSERR  ARE UNCHANGED ON A NORMAL RETURN.  THEY ARE POSSIBLY
C     CHANGED IF  CRASH  = .TRUE. (SEE DESCRIPTION OF  CRASH  ABOVE).
C
C Y, YP, YOLD, YPOLD  CONTAIN THE TWO MOST RECENT POINTS AND TANGENT
C     VECTORS FOUND ON THE ZERO CURVE OF THE HOMOTOPY MAP.
C
C
C CALLS  D1MACH, DAXPY, DCOPY, DDOT, DNRM2, DSCAL, F (OR RHO), FJACS
C     (OR RHOJS), PCGQS, TANGQS.
C
C ***** DECLARATIONS *****
C
C     FUNCTION DECLARATIONS
C
        DOUBLE PRECISION D1MACH, DDOT, DNRM2, QOFS
C
C     LOCAL VARIABLES
C
        DOUBLE PRECISION ALPHA, CORDIS, DD001, DD0011,DD01,DD011,DELS,
     $    FOURU, GAMMA, HFAIL, HTEMP, IDLERR, LAMBDA, OMEGA, ONE, P0,
     $    P1, PP0, PP1, SIGMA, TEMP, THETA, TWOU, WKOLD, XSTEP
        INTEGER I, ITCNT, LITFH, J, LK, LST, NP1, PCGWK, ZU
        LOGICAL FAILED
C
C     SCALAR ARGUMENTS
C
        INTEGER N, NFE, IFLAG, LENQR
        LOGICAL START, CRASH
        DOUBLE PRECISION HOLD, H, WK, RELERR, ABSERR, S
C
C     ARRAY DECLARATIONS
C
        DOUBLE PRECISION Y(N+1), YP(N+1), YOLD(N+1), YPOLD(N+1),
     $    A(N), QR(LENQR), PP(N), RHOVEC(N+1), Z0(N+1), DZ(N+1),
     $    T(N+1), WORK(8*(N+1)+LENQR), SSPAR(4), PAR(1)
        INTEGER PIVOT(N+2), IPAR(1)
        REAL WRGE(8),ACOF(12)
C
        SAVE
C
        DATA WRGE  /
     $   .8735115E+00, .1531947E+00, .3191815E-01, .3339946E-10,
     $   .4677788E+00, .6970123E-03, .1980863E-05, .1122789E-08/
        DATA ACOF  /
     $   .9043128E+00,-.7075675E+00,-.4667383E+01,-.3677482E+01,
     $   .8516099E+00,-.1953119E+00,-.4830636E+01,-.9770528E+00,
     $   .1040061E+01, .3793395E-01, .1042177E+01, .4450706E-01/
C
C ***** END OF DECLARATIONS *****
C
C DEFINITION OF HERMITE CUBIC INTERPOLANT VIA DIVIDED DIFFERENCES.
C
        DD01(P0,P1,DELS) = (P1-P0)/DELS
        DD001(P0,PP0,P1,DELS) = (DD01(P0,P1,DELS)-PP0)/DELS
        DD011(P0,P1,PP1,DELS) = (PP1-DD01(P0,P1,DELS))/DELS
        DD0011(P0,PP0,P1,PP1,DELS) = (DD011(P0,P1,PP1,DELS) -
     $                                DD001(P0,PP0,P1,DELS))/DELS
        QOFS(P0,PP0,P1,PP1,DELS,S) = ((DD0011(P0,PP0,P1,PP1,DELS)*
     $    (S-DELS) + DD001(P0,PP0,P1,DELS))*S + PP0)*S + P0
C
C ***** FIRST EXECUTABLE STATEMENT *****
C
C
C ***** INITIALIZATION *****
C
C LITFH = MAXIMUM NUMBER OF NEWTON ITERATIONS ALLOWED.
C
        ONE = 1.0
        TWOU = 2.0*D1MACH(4)
        FOURU = TWOU + TWOU
        NP1 = N+1
        FAILED = .FALSE.
        CRASH = .TRUE.
        LITFH = 10
        PCGWK = 2*N+3
        ZU = 3*N+4
C
C CHECK THAT ALL INPUT PARAMETERS ARE CORRECT.
C
C     THE ARCLENGTH  S  MUST BE NONNEGATIVE.
C
        IF (S .LT. 0.0) RETURN
C
C     IF STEP SIZE IS TOO SMALL, DETERMINE AN ACCEPTABLE ONE.
C
        IF (H .LT. FOURU*(1.0+S)) THEN
          H=FOURU*(1.0 + S)
          RETURN
        END IF
C
C     IF ERROR TOLERANCES ARE TOO SMALL, INCREASE THEM TO ACCEPTABLE
C     VALUES.
C
        TEMP=DNRM2(NP1,Y,1) + 1.0
        IF (.5*(RELERR*TEMP+ABSERR) .LT. TWOU*TEMP) THEN
          IF (RELERR .NE. 0.0) THEN
            RELERR = FOURU*(1.0+FOURU)
            TEMP = 0.0
            ABSERR = MAX(ABSERR,TEMP)
          ELSE
            ABSERR=FOURU*TEMP
          END IF
          RETURN
        END IF
C
C     INPUT PARAMETERS WERE ALL ACCEPTABLE.
C
        CRASH = .FALSE.
C
C COMPUTE  YP  ON FIRST CALL.
C
        IF (START) THEN
C
C         INITIALIZE THE IDEAL ERROR USED FOR STEP SIZE ESTIMATION.
C
          IDLERR=SQRT(SQRT(ABSERR))
C
C         INITIALIZE STARTING POINTS FOR THE CONJUGATE GRADIENT
C         ALGORITHM TO ZERO.
C
          DO 10 J=1,2*N+2
            WORK(J)=0.0
  10      CONTINUE
          CALL TANGQS(Y,YP,YPOLD,A,QR,PIVOT,PP,RHOVEC,WORK,
     $              N,LENQR,IFLAG,NFE,PAR,IPAR)
          IF (IFLAG .GT. 0) RETURN
        END IF
C
C ***** COMPUTE PREDICTOR POINT Z0 *****
C
  20    IF (START) THEN
C
C         COMPUTE Z0 WITH LINEAR PREDICTOR USING Y, YP --
C         Z0 = Y+H*YP.
C
          CALL DCOPY(NP1,Y,1,Z0,1)
          CALL DAXPY(NP1,H,YP,1,Z0,1)
C
        ELSE
C
C         COMPUTE Z0 WITH CUBIC PREDICTOR.
C
          DO 30 I=1,NP1
            Z0(I) = QOFS(YOLD(I),YPOLD(I),Y(I),YP(I),HOLD,HOLD+H)
  30      CONTINUE
C
        END IF
C
C ***** END OF PREDICTOR SECTION *****
C
C ***** NEWTON ITERATION *****
C
        DO 140 ITCNT = 1,LITFH
C
C SET STARTING POINTS FOR CONJUGATE GRADIENT ALGORITHM.
C
        DO 40 J=ZU,ZU+2*N+1
          WORK(J) = 0.0
  40    CONTINUE
C
C COMPUTE QR = [D RHO/DX], RHOVEC=RHO, -PP= (D RHO/D LAMBDA).
C
        LAMBDA = Z0(NP1)
        IF (IFLAG .EQ. -2) THEN
C
C         CURVE TRACKING PROBLEM.
C
          CALL RHOJS(A,LAMBDA,Z0,QR,LENQR,PIVOT,PP,PAR,IPAR)
          CALL RHO(A,LAMBDA,Z0,RHOVEC,PAR,IPAR)
        ELSE IF (IFLAG .EQ. -1) THEN
C
C         ZERO FINDING PROBLEM.
C
          CALL FJACS(Z0,QR,LENQR,PIVOT)
          CALL DSCAL(LENQR,LAMBDA,QR,1)
          SIGMA=1.0-LAMBDA
          DO 50 J=1,N
            QR(PIVOT(J))=QR(PIVOT(J))+SIGMA
  50      CONTINUE
          CALL DCOPY(N,Z0,1,RHOVEC,1)
          CALL DAXPY(N,-ONE,A,1,RHOVEC,1)
          CALL F(Z0,PP)
          CALL DSCAL(N,-ONE,PP,1)
          CALL DAXPY(N,ONE,RHOVEC,1,PP,1)
          CALL DAXPY(N,-LAMBDA,PP,1,RHOVEC,1)
        ELSE
C
C         FIXED POINT PROBLEM.
C
          CALL FJACS(Z0,QR,LENQR,PIVOT)
          CALL DSCAL(LENQR,-LAMBDA,QR,1)
          DO 60 J=1,N
            QR(PIVOT(J)) = QR(PIVOT(J))+1.0
  60      CONTINUE
          CALL DCOPY(N,Z0,1,RHOVEC,1)
          CALL DAXPY(N,-ONE,A,1,RHOVEC,1)
          CALL F(Z0,PP)
          CALL DAXPY(N,-ONE,A,1,PP,1)
          CALL DAXPY(N,-LAMBDA,PP,1,RHOVEC,1)
        END IF
        RHOVEC(NP1) = 0.0
        NFE = NFE+1
C
C SOLVE SYSTEM TO FIND NEWTON STEP  DZ.
C
          CALL PCGQS(N,QR,LENQR,PIVOT,PP,YP,RHOVEC,DZ,
     $         WORK(PCGWK),IFLAG)
          IF (IFLAG .GT. 0) RETURN
C
C TAKE STEP.
C
          CALL DAXPY(NP1, ONE, DZ, 1, Z0, 1)
C
C CHECK FOR CONVERGENCE.
C
          XSTEP=DNRM2(NP1,DZ,1)
          IF (XSTEP .LE. RELERR*DNRM2(NP1,Z0,1)+ABSERR) THEN
             GO TO 160
          END IF
C
  140   CONTINUE
C
C ***** END OF NEWTON LOOP *****
C
C ***** DIDN'T CONVERGE OR TANGENT AT NEW POINT DID NOT MAKE *****
C       AN ANGLE SMALLER THAN 60 DEGREES WITH  YPOLD --
C       TRY AGAIN WITH A SMALLER H
C
  150   FAILED = .TRUE.
        HFAIL = H
        IF (H .LE. FOURU*(1.0 + S)) THEN
          IFLAG = 6
          RETURN
        ELSE
          H = .5 * H
        END IF
        GO TO 20
C
C ***** END OF CONVERGENCE FAILURE SECTION *****
C
C ***** CONVERGED -- MOP UP AND RETURN *****
C
C COMPUTE TANGENT AT Z0.
C
  160   CALL TANGQS(Z0,T,YP,A,QR,PIVOT,PP,RHOVEC,WORK,N,
     $       LENQR,IFLAG,NFE,PAR,IPAR)
        IF (IFLAG .GT. 0) RETURN
C
C CHECK THAT COMPUTED TANGENT  T  MAKES AN ANGLE NO LARGER THAN
C 60 DEGREES WITH CURRENT TANGENT  YP.  (I.E., COS OF ANGLE < .5)
C IF NOT, STEP SIZE WAS TOO LARGE, SO THROW AWAY Z0, AND TRY
C AGAIN WITH A SMALLER STEP.
C
        ALPHA = DDOT(NP1,T,1,YP,1)
        IF (ALPHA .LT. 0.5) GOTO 150
        ALPHA = ACOS(ALPHA)
C
C COMPUTE CORRECTOR DISTANCE.
C
      IF (START) THEN
        CALL DCOPY(NP1,Y,1,WORK(PCGWK),1)
        CALL DAXPY(NP1,H,YP,1,WORK(PCGWK),1)
      ELSE
        DO 170 I=1,NP1
          WORK(PCGWK+I-1)=QOFS(YOLD(I),YPOLD(I),Y(I),YP(I),HOLD,HOLD+H)
  170   CONTINUE
      ENDIF
        CALL DAXPY(NP1,-ONE,Z0,1,WORK(PCGWK),1)
        CORDIS=DNRM2(NP1,WORK(PCGWK),1)
C
C SET UP VARIABLES FOR NEXT CALL.
C
        CALL DCOPY(NP1,Y,1,YOLD,1)
        CALL DCOPY(NP1,Z0,1,Y,1)
        CALL DCOPY(NP1,YP,1,YPOLD,1)
        CALL DCOPY(NP1,T,1,YP,1)
C
C UPDATE ARCLENGTH   S = S + ||Y-YOLD||.
C
        HTEMP = HOLD
        CALL DAXPY(NP1,-ONE,YOLD,1,Z0,1)
        HOLD = DNRM2(NP1,Z0,1)
        S = S+HOLD
C
C COMPUTE IDEAL ERROR FOR STEP SIZE ESTIMATION.
C
        IF (ITCNT .LE. 1) THEN
          THETA = 8.0
        ELSE IF (ITCNT .EQ. 4) THEN
          THETA = 1.0
        ELSE
          OMEGA=XSTEP/CORDIS
          IF (ITCNT .LT. 4) THEN
            LK = 4*ITCNT-7
            IF (OMEGA .GE. WRGE(LK)) THEN
              THETA = 1.0
            ELSE IF (OMEGA .GE. WRGE(LK+1)) THEN
              THETA = ACOF(LK) + ACOF(LK+1)*LOG(OMEGA)
            ELSE IF (OMEGA .GE. WRGE(LK+2)) THEN
              THETA = ACOF(LK+2) + ACOF(LK+3)*LOG(OMEGA)
            ELSE
              THETA = 8.0
            END IF
          ELSE IF (ITCNT .GE. 7) THEN
            THETA = 0.125
          ELSE
            LK = 4*ITCNT - 16
            IF (OMEGA .GT. WRGE(LK)) THEN
              LST = 2*ITCNT - 1
              THETA = ACOF(LST) + ACOF(LST+1)*LOG(OMEGA)
            ELSE
              THETA = 0.125
            END IF
          END IF
        END IF
        IDLERR=THETA*IDLERR
C
C     IDLERR SHOULD BE NO BIGGER THAN 1/2 PREVIOUS STEP.
C
        IDLERR = MIN(.5*HOLD,IDLERR)
C
C COMPUTE OPTIMAL STEP SIZE.
C   WK = APPROXIMATE CURVATURE = 2*SIN(ALPHA/2)/HOLD  WHERE
C        ALPHA = ARCCOS(YP*YPOLD).
C   GAMMA = EXPECTED CURVATURE FOR NEXT STEP, COMPUTED BY
C        EXTRAPOLATING FROM CURRENT CURVATURE  WK, AND LAST
C        CURVATURE  WKOLD.  GAMMA  IS FURTHER REQUIRED TO BE
C        POSITIVE.
C
        WKOLD = WK
        WK = 2.0*ABS(SIN(.5*ALPHA))/HOLD
        IF (START) THEN
           GAMMA = WK
        ELSE
           GAMMA = WK + HOLD/(HOLD+HTEMP)*(WK-WKOLD)
        END IF
        GAMMA = MAX(GAMMA, 0.01*ONE)
        H = SQRT(2.0*IDLERR/GAMMA)
C
C     ENFORCE RESTRICTIONS ON STEP SIZE SO AS TO ENSURE STABILITY.
C        HMIN <= H <= HMAX, BMIN*HOLD <= H <= BMAX*HOLD.
C
        H = MIN(MAX(SSPAR(1),SSPAR(3)*HOLD,H),SSPAR(4)*HOLD,SSPAR(2))
        IF (FAILED) H = MIN(HFAIL,H)
        START = .FALSE.
C
C ***** END OF MOP UP SECTION *****
C
        RETURN
C
C ***** END OF SUBROUTINE STEPQS *****
        END
      SUBROUTINE STEPS(F,NEQN,Y,X,H,EPS,WT,START,HOLD,K,KOLD,CRASH,PHI,
     1   P,YP,ALPHA,W,G,KSTEPS,XOLD,IVC,IV,KGI,GI,  FPWA1,FPWA2,FPWA3,
     2   FPWA4,FPWA5,IFPWA1,IFPC1,IFPC2,PAR,IPAR)
C
C
C
C   WRITTEN BY L. F. SHAMPINE AND M. K. GORDON
C
C   ABSTRACT
C
C   SUBROUTINE  STEPS  IS NORMALLY USED INDIRECTLY THROUGH SUBROUTINE
C   DEABM .  BECAUSE  DEABM  SUFFICES FOR MOST PROBLEMS AND IS MUCH
C   EASIER TO USE, USING IT SHOULD BE CONSIDERED BEFORE USING  STEPS
C   ALONE.
C
C   SUBROUTINE STEPS INTEGRATES A SYSTEM OF  NEQN  FIRST ORDER ORDINARY
C   DIFFERENTIAL EQUATIONS ONE STEP, NORMALLY FROM X TO X+H, USING A
C   MODIFIED DIVIDED DIFFERENCE FORM OF THE ADAMS PECE FORMULAS.  LOCAL
C   EXTRAPOLATION IS USED TO IMPROVE ABSOLUTE STABILITY AND ACCURACY.
C   THE CODE ADJUSTS ITS ORDER AND STEP SIZE TO CONTROL THE LOCAL ERROR
C   PER UNIT STEP IN A GENERALIZED SENSE.  SPECIAL DEVICES ARE INCLUDED
C   TO CONTROL ROUNDOFF ERROR AND TO DETECT WHEN THE USER IS REQUESTING
C   TOO MUCH ACCURACY.
C
C   THIS CODE IS COMPLETELY EXPLAINED AND DOCUMENTED IN THE TEXT,
C   COMPUTER SOLUTION OF ORDINARY DIFFERENTIAL EQUATIONS, THE INITIAL
C   VALUE PROBLEM  BY L. F. SHAMPINE AND M. K. GORDON.
C   FURTHER DETAILS ON USE OF THIS CODE ARE AVAILABLE IN *SOLVING
C   ORDINARY DIFFERENTIAL EQUATIONS WITH ODE, STEP, AND INTRP*,
C   BY L. F. SHAMPINE AND M. K. GORDON, SLA-73-1060.
C
C
C   THE PARAMETERS REPRESENT --
C      F -- SUBROUTINE TO EVALUATE DERIVATIVES
C      NEQN -- NUMBER OF EQUATIONS TO BE INTEGRATED
C      Y(*) -- SOLUTION VECTOR AT X
C      X -- INDEPENDENT VARIABLE
C      H -- APPROPRIATE STEP SIZE FOR NEXT STEP.  NORMALLY DETERMINED BY
C           CODE
C      EPS -- LOCAL ERROR TOLERANCE
C      WT(*) -- VECTOR OF WEIGHTS FOR ERROR CRITERION
C      START -- LOGICAL VARIABLE SET .TRUE. FOR FIRST STEP,  .FALSE.
C           OTHERWISE
C      HOLD -- STEP SIZE USED FOR LAST SUCCESSFUL STEP
C      K -- APPROPRIATE ORDER FOR NEXT STEP (DETERMINED BY CODE)
C      KOLD -- ORDER USED FOR LAST SUCCESSFUL STEP
C      CRASH -- LOGICAL VARIABLE SET .TRUE. WHEN NO STEP CAN BE TAKEN,
C           .FALSE. OTHERWISE.
C      YP(*) -- DERIVATIVE OF SOLUTION VECTOR AT  X  AFTER SUCCESSFUL
C           STEP
C      KSTEPS -- COUNTER ON ATTEMPTED STEPS
C
C   THE VARIABLES X,XOLD,KOLD,KGI AND IVC AND THE ARRAYS Y,PHI,ALPHA,G,
C   W,P,IV AND GI ARE REQUIRED FOR THE INTERPOLATION SUBROUTINE SINTRP.
C   THE ARRAYS FPWA* AND IFPWA1 AND INTEGER CONSTANTS IFPC* ARE
C   WORKING STORAGE PASSED DIRECTLY THROUGH TO  FODE.  THE ARRAYS
C   PAR AND IPAR ARE USER PARAMETERS PASSED THROUGH TO RHOA AND RHOJAC.
C
C   INPUT TO STEPS
C
C      FIRST CALL --
C
C   THE USER MUST PROVIDE STORAGE IN HIS CALLING PROGRAM FOR ALL ARRAYS
C   IN THE CALL LIST, NAMELY
C
C     DIMENSION Y(NEQN),WT(NEQN),PHI(NEQN,16),P(NEQN),YP(NEQN),
C    1  ALPHA(12),W(12),G(13),GI(11),IV(10),   FPWA1(NEQN),
C    2  FPWA2(NEQN-1),FPWA3(NEQN-1,NEQN),FPWA4(NEQN-1),
C    3  FPWA5(NEQN),IFPWA1(NEQN)
C                              --                --    **NOTE**
C
C   THE USER MUST ALSO DECLARE  START  AND  CRASH
C   LOGICAL VARIABLES AND  F  AN EXTERNAL SUBROUTINE, SUPPLY THE
C   SUBROUTINE  F(X,Y,YP,FPWA1,FPWA2,FPWA3,FPWA4,FPWA5,IFPWA1,IFPC1,
C                 NEQN-1,IFPC2,PAR,IPAR) TO EVALUATE
C      DY(I)/DX = YP(I) = F(X,Y(1),Y(2),...,Y(NEQN))
C   AND INITIALIZE ONLY THE FOLLOWING PARAMETERS.
C      NEQN -- NUMBER OF EQUATIONS TO BE INTEGRATED
C      Y(*) -- VECTOR OF INITIAL VALUES OF DEPENDENT VARIABLES
C      X -- INITIAL VALUE OF THE INDEPENDENT VARIABLE
C      H -- NOMINAL STEP SIZE INDICATING DIRECTION OF INTEGRATION
C           AND MAXIMUM SIZE OF STEP.  MUST BE VARIABLE
C      EPS -- LOCAL ERROR TOLERANCE PER STEP.  MUST BE VARIABLE
C      WT(*) -- VECTOR OF NON-ZERO WEIGHTS FOR ERROR CRITERION
C      START -- .TRUE.
C      KSTEPS -- SET KSTEPS TO ZERO
C   DEFINE U TO BE THE MACHINE UNIT ROUNDOFF QUANTITY BY CALLING
C   THE FUNCTION ROUTINE  D1MACH,  U = D1MACH(3), OR BY
C   COMPUTING U SO THAT U IS THE SMALLEST POSITIVE NUMBER SUCH
C   THAT 1.0+U .GT. 1.0.
C
C   STEPS  REQUIRES THAT THE L2 NORM OF THE VECTOR WITH COMPONENTS
C   LOCAL ERROR(L)/WT(L)  BE LESS THAN  EPS  FOR A SUCCESSFUL STEP.  THE
C   ARRAY  WT  ALLOWS THE USER TO SPECIFY AN ERROR TEST APPROPRIATE
C   FOR HIS PROBLEM.  FOR EXAMPLE,
C      WT(L) = 1.0  SPECIFIES ABSOLUTE ERROR,
C            = ABS(Y(L))  ERROR RELATIVE TO THE MOST RECENT VALUE OF THE
C                 L-TH COMPONENT OF THE SOLUTION,
C            = ABS(YP(L))  ERROR RELATIVE TO THE MOST RECENT VALUE OF
C                 THE L-TH COMPONENT OF THE DERIVATIVE,
C            = MAX(WT(L),ABS(Y(L)))  ERROR RELATIVE TO THE LARGEST
C                 MAGNITUDE OF L-TH COMPONENT OBTAINED SO FAR,
C            = ABS(Y(L))*RELERR/EPS + ABSERR/EPS  SPECIFIES A MIXED
C                 RELATIVE-ABSOLUTE TEST WHERE  RELERR  IS RELATIVE
C                 ERROR,  ABSERR  IS ABSOLUTE ERROR AND  EPS =
C                 MAX(RELERR,ABSERR) .
C
C      SUBSEQUENT CALLS --
C
C   SUBROUTINE  STEPS  IS DESIGNED SO THAT ALL INFORMATION NEEDED TO
C   CONTINUE THE INTEGRATION, INCLUDING THE STEP SIZE  H  AND THE ORDER
C   K , IS RETURNED WITH EACH STEP.  WITH THE EXCEPTION OF THE STEP
C   SIZE, THE ERROR TOLERANCE, AND THE WEIGHTS, NONE OF THE PARAMETERS
C   SHOULD BE ALTERED.  THE ARRAY  WT  MUST BE UPDATED AFTER EACH STEP
C   TO MAINTAIN RELATIVE ERROR TESTS LIKE THOSE ABOVE.  NORMALLY THE
C   INTEGRATION IS CONTINUED JUST BEYOND THE DESIRED ENDPOINT AND THE
C   SOLUTION INTERPOLATED THERE WITH SUBROUTINE  SINTRP .  IF IT IS
C   IMPOSSIBLE TO INTEGRATE BEYOND THE ENDPOINT, THE STEP SIZE MAY BE
C   REDUCED TO HIT THE ENDPOINT SINCE THE CODE WILL NOT TAKE A STEP
C   LARGER THAN THE  H  INPUT.  CHANGING THE DIRECTION OF INTEGRATION,
C   I.E., THE SIGN OF  H , REQUIRES THE USER SET  START = .TRUE. BEFORE
C   CALLING  STEPS  AGAIN.  THIS IS THE ONLY SITUATION IN WHICH  START
C   SHOULD BE ALTERED.
C
C   OUTPUT FROM STEPS
C
C      SUCCESSFUL STEP --
C
C   THE SUBROUTINE RETURNS AFTER EACH SUCCESSFUL STEP WITH  START  AND
C   CRASH  SET .FALSE. .  X  REPRESENTS THE INDEPENDENT VARIABLE
C   ADVANCED ONE STEP OF LENGTH  HOLD  FROM ITS VALUE ON INPUT AND  Y
C   THE SOLUTION VECTOR AT THE NEW VALUE OF  X .  ALL OTHER PARAMETERS
C   REPRESENT INFORMATION CORRESPONDING TO THE NEW  X  NEEDED TO
C   CONTINUE THE INTEGRATION.
C
C      UNSUCCESSFUL STEP --
C
C   WHEN THE ERROR TOLERANCE IS TOO SMALL FOR THE MACHINE PRECISION,
C   THE SUBROUTINE RETURNS WITHOUT TAKING A STEP AND  CRASH = .TRUE. .
C   AN APPROPRIATE STEP SIZE AND ERROR TOLERANCE FOR CONTINUING ARE
C   ESTIMATED AND ALL OTHER INFORMATION IS RESTORED AS UPON INPUT
C   BEFORE RETURNING.  TO CONTINUE WITH THE LARGER TOLERANCE, THE USER
C   JUST CALLS THE CODE AGAIN.  A RESTART IS NEITHER REQUIRED NOR
C   DESIRABLE.
C***REFERENCES  SHAMPINE L.F., GORDON M.K., *SOLVING ORDINARY
C                 DIFFERENTIAL EQUATIONS WITH ODE, STEP, AND INTRP*,
C                 SLA-73-1060, SANDIA LABORATORIES, 1973.
C
      DOUBLE PRECISION ABSH,ALPHA,BETA,D1MACH,EPS,ERK,ERKM1,ERKM2,
     1  ERKP1,ERR,FOURU,FPWA1,FPWA2,FPWA3,FPWA4,FPWA5,G,GI,GSTR,H,
     2  HNEW,HOLD,P,PAR,P5EPS,PHI,PSI,R,REALI,REALNS,RHO,ROUND,SIG,
     3  SUM,TAU,TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,TEMP6,TWO,TWOU,V,
     4  W,WT,X,XOLD,Y,YP
      INTEGER I,IFAIL,IFPC1,IFPC2,IFPWA1,IM1,IPAR,IP1,IQ,IV,IVC,
     1  J,JV,K,KGI,KM1,KM2,KNEW,KOLD,KP1,KP2,KPREV,KSTEPS,
     2  L,LIMIT1,LIMIT2,NEQN,NS,NSM2,NSP1,NSP2
      LOGICAL START,CRASH,PHASE1,NORND
C
      DIMENSION Y(NEQN),WT(NEQN),PHI(NEQN,16),P(NEQN),YP(NEQN),PSI(12),
     1  ALPHA(12),BETA(12),SIG(13),V(12),W(12),G(13),GI(11),IV(10),
     2  FPWA1(NEQN),FPWA2(NEQN-1),FPWA3(NEQN-1,NEQN),FPWA4(NEQN-1),
     3  FPWA5(NEQN),IFPWA1(NEQN),PAR(1),IPAR(1)
      DIMENSION TWO(13),GSTR(13)
C
C   ALL LOCAL VARIABLES ARE SAVED, RATHER THAN PASSED, IN THIS
C   SPECIALIZED VERSION OF STEPS.
C
      SAVE
C
      EXTERNAL F
C
      DATA TWO/2.0,4.0,8.0,16.0,32.0,64.0,128.0,256.0,512.0,1024.0,
     1  2048.0,4096.0,8192.0/
      DATA GSTR/0.500,0.0833,0.0417,0.0264,0.0188,0.0143,0.0114,0.00936,
     1  0.00789,0.00679,0.00592,0.00524,0.00468/
C
C
C       ***     BEGIN BLOCK 0     ***
C   CHECK IF STEP SIZE OR ERROR TOLERANCE IS TOO SMALL FOR MACHINE
C   PRECISION.  IF FIRST STEP, INITIALIZE PHI ARRAY AND ESTIMATE A
C   STARTING STEP SIZE.
C                   ***
C
C   IF STEP SIZE IS TOO SMALL, DETERMINE AN ACCEPTABLE ONE
C
C***FIRST EXECUTABLE STATEMENT
      TWOU = 2.0 * D1MACH(4)
      FOURU = TWOU + TWOU
      CRASH = .TRUE.
      IF(ABS(H) .GE. FOURU*ABS(X)) GO TO 5
      H = SIGN(FOURU*ABS(X),H)
      RETURN
 5    P5EPS = 0.5*EPS
C
C   IF ERROR TOLERANCE IS TOO SMALL, INCREASE IT TO AN ACCEPTABLE VALUE
C
      ROUND = 0.0
      DO 10 L = 1,NEQN
 10     ROUND = ROUND + (Y(L)/WT(L))**2
      ROUND = TWOU*SQRT(ROUND)
      IF(P5EPS .GE. ROUND) GO TO 15
      EPS = 2.0*ROUND*(1.0 + FOURU)
      RETURN
 15   CRASH = .FALSE.
      G(1) = 1.0
      G(2) = 0.5
      SIG(1) = 1.0
      IF(.NOT.START) GO TO 99
C
C   INITIALIZE.  COMPUTE APPROPRIATE STEP SIZE FOR FIRST STEP
C
      CALL F(X,Y,YP,FPWA1,FPWA2,FPWA3,FPWA4,FPWA5,IFPWA1,
     $       IFPC1,NEQN-1,IFPC2,PAR,IPAR)
      IF (IFPC2 .GT. 0) RETURN
      SUM = 0.0
      DO 20 L = 1,NEQN
        PHI(L,1) = YP(L)
        PHI(L,2) = 0.0
 20     SUM = SUM + (YP(L)/WT(L))**2
      SUM = SQRT(SUM)
      ABSH = ABS(H)
      IF(EPS .LT. 16.0*SUM*H*H) ABSH = 0.25*SQRT(EPS/SUM)
      H = SIGN(MAX(ABSH,FOURU*ABS(X)),H)
C
C*      U = D1MACH(3)
C*      BIG = SQRT(D1MACH(2))
C*      CALL HSTART (F,NEQN,X,X+H,Y,YP,WT,1,U,BIG,
C*     1             PHI(1,3),PHI(1,4),PHI(1,5),PHI(1,6),RPAR,IPAR,H)
C
      HOLD = 0.0
      K = 1
      KOLD = 0
      KPREV = 0
      START = .FALSE.
      PHASE1 = .TRUE.
      NORND = .TRUE.
      IF(P5EPS .GT. 100.0*ROUND) GO TO 99
      NORND = .FALSE.
      DO 25 L = 1,NEQN
 25     PHI(L,15) = 0.0
 99   IFAIL = 0
C       ***     END BLOCK 0     ***
C
C       ***     BEGIN BLOCK 1     ***
C   COMPUTE COEFFICIENTS OF FORMULAS FOR THIS STEP.  AVOID COMPUTING
C   THOSE QUANTITIES NOT CHANGED WHEN STEP SIZE IS NOT CHANGED.
C                   ***
C
 100  KP1 = K+1
      KP2 = K+2
      KM1 = K-1
      KM2 = K-2
C
C   NS IS THE NUMBER OF STEPS TAKEN WITH SIZE H, INCLUDING THE CURRENT
C   ONE.  WHEN K.LT.NS, NO COEFFICIENTS CHANGE
C
      IF(H .NE. HOLD) NS = 0
      IF (NS.LE.KOLD) NS = NS+1
      NSP1 = NS+1
      IF (K .LT. NS) GO TO 199
C
C   COMPUTE THOSE COMPONENTS OF ALPHA(*),BETA(*),PSI(*),SIG(*) WHICH
C   ARE CHANGED
C
      BETA(NS) = 1.0
      REALNS = NS
      ALPHA(NS) = 1.0/REALNS
      TEMP1 = H*REALNS
      SIG(NSP1) = 1.0
      IF(K .LT. NSP1) GO TO 110
      DO 105 I = NSP1,K
        IM1 = I-1
        TEMP2 = PSI(IM1)
        PSI(IM1) = TEMP1
        BETA(I) = BETA(IM1)*PSI(IM1)/TEMP2
        TEMP1 = TEMP2 + H
        ALPHA(I) = H/TEMP1
        REALI = I
 105    SIG(I+1) = REALI*ALPHA(I)*SIG(I)
 110  PSI(K) = TEMP1
C
C   COMPUTE COEFFICIENTS G(*)
C
C   INITIALIZE V(*) AND SET W(*).
C
      IF(NS .GT. 1) GO TO 120
      DO 115 IQ = 1,K
        TEMP3 = IQ*(IQ+1)
        V(IQ) = 1.0/TEMP3
 115    W(IQ) = V(IQ)
      IVC = 0
      KGI = 0
      IF (K .EQ. 1) GO TO 140
      KGI = 1
      GI(1) = W(2)
      GO TO 140
C
C   IF ORDER WAS RAISED, UPDATE DIAGONAL PART OF V(*)
C
 120  IF(K .LE. KPREV) GO TO 130
      IF (IVC .EQ. 0) GO TO 122
      JV = KP1 - IV(IVC)
      IVC = IVC - 1
      GO TO 123
 122  JV = 1
      TEMP4 = K*KP1
      V(K) = 1.0/TEMP4
      W(K) = V(K)
      IF (K .NE. 2) GO TO 123
      KGI = 1
      GI(1) = W(2)
 123  NSM2 = NS-2
      IF(NSM2 .LT. JV) GO TO 130
      DO 125 J = JV,NSM2
        I = K-J
        V(I) = V(I) - ALPHA(J+1)*V(I+1)
 125    W(I) = V(I)
      IF (I .NE. 2) GO TO 130
      KGI = NS - 1
      GI(KGI) = W(2)
C
C   UPDATE V(*) AND SET W(*)
C
 130  LIMIT1 = KP1 - NS
      TEMP5 = ALPHA(NS)
      DO 135 IQ = 1,LIMIT1
        V(IQ) = V(IQ) - TEMP5*V(IQ+1)
 135    W(IQ) = V(IQ)
      G(NSP1) = W(1)
      IF (LIMIT1 .EQ. 1) GO TO 137
      KGI = NS
      GI(KGI) = W(2)
 137  W(LIMIT1+1) = V(LIMIT1+1)
      IF (K .GE. KOLD) GO TO 140
      IVC = IVC + 1
      IV(IVC) = LIMIT1 + 2
C
C   COMPUTE THE G(*) IN THE WORK VECTOR W(*)
C
 140  NSP2 = NS + 2
      KPREV = K
      IF(KP1 .LT. NSP2) GO TO 199
      DO 150 I = NSP2,KP1
        LIMIT2 = KP2 - I
        TEMP6 = ALPHA(I-1)
        DO 145 IQ = 1,LIMIT2
 145      W(IQ) = W(IQ) - TEMP6*W(IQ+1)
 150    G(I) = W(1)
 199    CONTINUE
C       ***     END BLOCK 1     ***
C
C       ***     BEGIN BLOCK 2     ***
C   PREDICT A SOLUTION P(*), EVALUATE DERIVATIVES USING PREDICTED
C   SOLUTION, ESTIMATE LOCAL ERROR AT ORDER K AND ERRORS AT ORDERS K,
C   K-1, K-2 AS IF CONSTANT STEP SIZE WERE USED.
C                   ***
C
C   INCREMENT COUNTER ON ATTEMPTED STEPS
C
      KSTEPS = KSTEPS + 1
C
C   CHANGE PHI TO PHI STAR
C
      IF(K .LT. NSP1) GO TO 215
      DO 210 I = NSP1,K
        TEMP1 = BETA(I)
        DO 205 L = 1,NEQN
 205      PHI(L,I) = TEMP1*PHI(L,I)
 210    CONTINUE
C
C   PREDICT SOLUTION AND DIFFERENCES
C
 215  DO 220 L = 1,NEQN
        PHI(L,KP2) = PHI(L,KP1)
        PHI(L,KP1) = 0.0
 220    P(L) = 0.0
      DO 230 J = 1,K
        I = KP1 - J
        IP1 = I+1
        TEMP2 = G(I)
        DO 225 L = 1,NEQN
          P(L) = P(L) + TEMP2*PHI(L,I)
 225      PHI(L,I) = PHI(L,I) + PHI(L,IP1)
 230    CONTINUE
      IF(NORND) GO TO 240
      DO 235 L = 1,NEQN
        TAU = H*P(L) - PHI(L,15)
        P(L) = Y(L) + TAU
 235    PHI(L,16) = (P(L) - Y(L)) - TAU
      GO TO 250
 240  DO 245 L = 1,NEQN
 245    P(L) = Y(L) + H*P(L)
 250  XOLD = X
      X = X + H
      ABSH = ABS(H)
      CALL F(X,P,YP,FPWA1,FPWA2,FPWA3,FPWA4,FPWA5,IFPWA1,
     $       IFPC1,NEQN-1,IFPC2,PAR,IPAR)
      IF (IFPC2 .GT. 0) RETURN
C
C   ESTIMATE ERRORS AT ORDERS K,K-1,K-2
C
      ERKM2 = 0.0
      ERKM1 = 0.0
      ERK = 0.0
      DO 265 L = 1,NEQN
        TEMP3 = 1.0/WT(L)
        TEMP4 = YP(L) - PHI(L,1)
        IF(KM2)265,260,255
 255    ERKM2 = ERKM2 + ((PHI(L,KM1)+TEMP4)*TEMP3)**2
 260    ERKM1 = ERKM1 + ((PHI(L,K)+TEMP4)*TEMP3)**2
 265    ERK = ERK + (TEMP4*TEMP3)**2
      IF(KM2)280,275,270
 270  ERKM2 = ABSH*SIG(KM1)*GSTR(KM2)*SQRT(ERKM2)
 275  ERKM1 = ABSH*SIG(K)*GSTR(KM1)*SQRT(ERKM1)
 280  TEMP5 = ABSH*SQRT(ERK)
      ERR = TEMP5*(G(K)-G(KP1))
      ERK = TEMP5*SIG(KP1)*GSTR(K)
      KNEW = K
C
C   TEST IF ORDER SHOULD BE LOWERED
C
      IF(KM2)299,290,285
 285  IF(MAX(ERKM1,ERKM2) .LE. ERK) KNEW = KM1
      GO TO 299
 290  IF(ERKM1 .LE. 0.5*ERK) KNEW = KM1
C
C   TEST IF STEP SUCCESSFUL
C
 299  IF(ERR .LE. EPS) GO TO 400
C       ***     END BLOCK 2     ***
C
C       ***     BEGIN BLOCK 3     ***
C   THE STEP IS UNSUCCESSFUL.  RESTORE  X, PHI(*,*), PSI(*) .
C   IF THIRD CONSECUTIVE FAILURE, SET ORDER TO ONE.  IF STEP FAILS MORE
C   THAN THREE TIMES, CONSIDER AN OPTIMAL STEP SIZE.  DOUBLE ERROR
C   TOLERANCE AND RETURN IF ESTIMATED STEP SIZE IS TOO SMALL FOR MACHINE
C   PRECISION.
C                   ***
C
C   RESTORE X, PHI(*,*) AND PSI(*)
C
      PHASE1 = .FALSE.
      X = XOLD
      DO 310 I = 1,K
        TEMP1 = 1.0/BETA(I)
        IP1 = I+1
        DO 305 L = 1,NEQN
 305      PHI(L,I) = TEMP1*(PHI(L,I) - PHI(L,IP1))
 310    CONTINUE
      IF(K .LT. 2) GO TO 320
      DO 315 I = 2,K
 315    PSI(I-1) = PSI(I) - H
C
C   ON THIRD FAILURE, SET ORDER TO ONE.  THEREAFTER, USE OPTIMAL STEP
C   SIZE
C
 320  IFAIL = IFAIL + 1
      TEMP2 = 0.5
      IF(IFAIL - 3) 335,330,325
 325  IF(P5EPS .LT. 0.25*ERK) TEMP2 = SQRT(P5EPS/ERK)
 330  KNEW = 1
 335  H = TEMP2*H
      K = KNEW
      NS = 0
      IF(ABS(H) .GE. FOURU*ABS(X)) GO TO 340
      CRASH = .TRUE.
      H = SIGN(FOURU*ABS(X),H)
      EPS = EPS + EPS
      RETURN
 340  GO TO 100
C       ***     END BLOCK 3     ***
C
C       ***     BEGIN BLOCK 4     ***
C   THE STEP IS SUCCESSFUL.  CORRECT THE PREDICTED SOLUTION, EVALUATE
C   THE DERIVATIVES USING THE CORRECTED SOLUTION AND UPDATE THE
C   DIFFERENCES.  DETERMINE BEST ORDER AND STEP SIZE FOR NEXT STEP.
C                   ***
 400  KOLD = K
      HOLD = H
C
C   CORRECT AND EVALUATE
C
      TEMP1 = H*G(KP1)
      IF(NORND) GO TO 410
      DO 405 L = 1,NEQN
        TEMP3 = Y(L)
        RHO = TEMP1*(YP(L) - PHI(L,1)) - PHI(L,16)
        Y(L) = P(L) + RHO
        PHI(L,15) = (Y(L) - P(L)) - RHO
 405    P(L) = TEMP3
      GO TO 420
 410  DO 415 L = 1,NEQN
        TEMP3 = Y(L)
        Y(L) = P(L) + TEMP1*(YP(L) - PHI(L,1))
 415    P(L) = TEMP3
 420  CALL F(X,Y,YP,FPWA1,FPWA2,FPWA3,FPWA4,FPWA5,IFPWA1,
     $       IFPC1,NEQN-1,IFPC2,PAR,IPAR)
      IF (IFPC2 .GT. 0) RETURN
C
C   UPDATE DIFFERENCES FOR NEXT STEP
C
      DO 425 L = 1,NEQN
        PHI(L,KP1) = YP(L) - PHI(L,1)
 425    PHI(L,KP2) = PHI(L,KP1) - PHI(L,KP2)
      DO 435 I = 1,K
        DO 430 L = 1,NEQN
 430      PHI(L,I) = PHI(L,I) + PHI(L,KP1)
 435    CONTINUE
C
C   ESTIMATE ERROR AT ORDER K+1 UNLESS:
C     IN FIRST PHASE WHEN ALWAYS RAISE ORDER,
C     ALREADY DECIDED TO LOWER ORDER,
C     STEP SIZE NOT CONSTANT SO ESTIMATE UNRELIABLE
C
      ERKP1 = 0.0
      IF(KNEW .EQ. KM1  .OR.  K .EQ. 12) PHASE1 = .FALSE.
      IF(PHASE1) GO TO 450
      IF(KNEW .EQ. KM1) GO TO 455
      IF(KP1 .GT. NS) GO TO 460
      DO 440 L = 1,NEQN
 440    ERKP1 = ERKP1 + (PHI(L,KP2)/WT(L))**2
      ERKP1 = ABSH*GSTR(KP1)*SQRT(ERKP1)
C
C   USING ESTIMATED ERROR AT ORDER K+1, DETERMINE APPROPRIATE ORDER
C   FOR NEXT STEP
C
      IF(K .GT. 1) GO TO 445
      IF(ERKP1 .GE. 0.5*ERK) GO TO 460
      GO TO 450
 445  IF(ERKM1 .LE. MIN(ERK,ERKP1)) GO TO 455
      IF(ERKP1 .GE. ERK  .OR.  K .EQ. 12) GO TO 460
C
C   HERE ERKP1 .LT. ERK .LT. MAX(ERKM1,ERKM2) ELSE ORDER WOULD HAVE
C   BEEN LOWERED IN BLOCK 2.  THUS ORDER IS TO BE RAISED
C
C   RAISE ORDER
C
 450  K = KP1
      ERK = ERKP1
      GO TO 460
C
C   LOWER ORDER
C
 455  K = KM1
      ERK = ERKM1
C
C   WITH NEW ORDER DETERMINE APPROPRIATE STEP SIZE FOR NEXT STEP
C
 460  HNEW = H + H
      IF(PHASE1) GO TO 465
      IF(P5EPS .GE. ERK*TWO(K+1)) GO TO 465
      HNEW = H
      IF(P5EPS .GE. ERK) GO TO 465
      TEMP2 = K+1
      R = (P5EPS/ERK)**(1.0/TEMP2)
      HNEW = ABSH*MAX(0.5D0,MIN(0.9D0,R))
      HNEW = SIGN(MAX(HNEW,FOURU*ABS(X)),H)
 465  H = HNEW
      RETURN
C       ***     END BLOCK 4     ***
      END
      SUBROUTINE STRPTP(N,ICOUNT,IDEG,R ,X)
C
C COMPUTES INITIAL POINTS FOR PATHS.
C
C ON INPUT:
C
C N  IS THE NUMBER OF (COMPLEX) VARIABLES.
C
C ICOUNT  IS A COUNTER USED TO INCREMENT EACH
C   VARIABLE AROUND THE UNIT CIRCLE SO THAT EVERY
C   COMBINATION OF START VALUES IS CHOSEN.  ICOUNT  IS
C   INITIALIZED IN  POLYP.
C
C IDEG(J)  IS THE DEGREE OF THE J-TH EQUATION.
C
C R(I,J)  IS A (COMPLEX) ARRAY GENERATED BY SUBROUTINE  INITP.
C   R(1,J), AND R(2,J) ARE THE REAL AND IMAGINARY PARTS, RESPECTIVELY.
C
C ON OUTPUT:
C
C X(I,J)  IS INITIALIZED TO THE START VALUES FOR THE CURRENT PATH,
C   WITH X(1,J) AND X(2,J) THE REAL AND IMAGINARY PARTS OF THE
C   J-TH VARIABLE, RESPECTIVELY.
C
C SUBROUTINES:  ATAN, COS, MULP, SIN.
C
C DECLARATION OF INPUT AND OUTPUT:
      INTEGER N,ICOUNT,IDEG
      DOUBLE PRECISION R ,X
      DIMENSION ICOUNT(N),IDEG(N)
      DIMENSION R(2,N),X(2,N)
C
C DECLARATION OF VARIABLES:
      INTEGER J
      DOUBLE PRECISION TWOPI,ANGLE,XXXX
      DIMENSION XXXX(2)
C
      DO 10 J=1,N
         IF(ICOUNT(J) .GE. IDEG(J) ) THEN
             ICOUNT(J)=1
           ELSE
             ICOUNT(J)=ICOUNT(J)+1
             GOTO 20
         END IF
  10  CONTINUE
  20  CONTINUE
      TWOPI = 8.0*ATAN(1.0)
      DO 30 J=1,N
          ANGLE = ( TWOPI/IDEG(J) )*ICOUNT(J)
          XXXX(1) = COS(ANGLE)
          XXXX(2) = SIN(ANGLE)
          CALL MULP(XXXX,R(1,J),X(1,J))
  30  CONTINUE
      RETURN
      END
      SUBROUTINE TANGNF(RHOLEN,Y,YP,YPOLD,A,QR,ALPHA,TZ,PIVOT,
     $                  NFE,N,IFLAG,PAR,IPAR)
C
C THIS SUBROUTINE BUILDS THE JACOBIAN MATRIX OF THE HOMOTOPY MAP,
C COMPUTES A QR DECOMPOSITION OF THAT MATRIX, AND THEN CALCULATES THE
C (UNIT) TANGENT VECTOR AND THE NEWTON STEP.
C
C ON INPUT:
C
C RHOLEN < 0 IF THE NORM OF THE HOMOTOPY MAP EVALUATED AT
C    (A, LAMBDA, X) IS TO BE COMPUTED.  IF  RHOLEN >= 0  THE NORM IS NOT
C    COMPUTED AND  RHOLEN  IS NOT CHANGED.
C
C Y(1:N+1) = CURRENT POINT (LAMBDA(S), X(S)).
C
C YPOLD(1:N+1) = UNIT TANGENT VECTOR AT PREVIOUS POINT ON THE ZERO
C    CURVE OF THE HOMOTOPY MAP.
C
C A(1:*) = PARAMETER VECTOR IN THE HOMOTOPY MAP.
C
C QR(1:N,1:N+2), ALPHA(1:N), TZ(1:N+1), PIVOT(1:N+1)  ARE WORK ARRAYS
C    USED FOR THE QR FACTORIZATION.
C
C NFE = NUMBER OF JACOBIAN MATRIX EVALUATIONS = NUMBER OF HOMOTOPY
C    FUNCTION EVALUATIONS.
C
C N = DIMENSION OF X.
C
C IFLAG = -2, -1, OR 0, INDICATING THE PROBLEM TYPE.
C
C PAR(1:*) AND IPAR(1:*) ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS,
C    WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES
C    RHO, RHOJAC.
C
C ON OUTPUT:
C
C RHOLEN = ||RHO(A, LAMBDA(S), X(S)|| IF  RHOLEN < 0  ON INPUT.
C    OTHERWISE  RHOLEN  IS UNCHANGED.
C
C Y, YPOLD, A, N  ARE UNCHANGED.
C
C YP(1:N+1) = DY/DS = UNIT TANGENT VECTOR TO INTEGRAL CURVE OF
C    D(HOMOTOPY MAP)/DS = 0  AT  Y(S) = (LAMBDA(S), X(S)) .
C
C TZ = THE NEWTON STEP = -(PSEUDO INVERSE OF  (D RHO(A,Y(S))/D LAMBDA ,
C    D RHO(A,Y(S))/DX)) * RHO(A,Y(S)) .
C
C NFE  HAS BEEN INCRMENTED BY 1.
C
C IFLAG  IS UNCHANGED, UNLESS THE QR FACTORIZATION DETECTS A RANK < N,
C    IN WHICH CASE THE TANGENT AND NEWTON STEP VECTORS ARE NOT COMPUTED
C    AND  TANGNF  RETURNS WITH  IFLAG = 4 .
C
C
C CALLS  DDOT , DNRM2 , F (OR  RHO ), FJAC (OR  RHOJAC ).
C
      DOUBLE PRECISION ALPHAK,BETA,DDOT,DNRM2,LAMBDA,QRKK,RHOLEN,
     $       SIGMA,SUM,YPNORM
      INTEGER I,IFLAG,J,JBAR,K,KP1,N,NFE,NP1,NP2
C
C *****  ARRAY DECLARATIONS.  *****
C
      DOUBLE PRECISION Y(N+1),YP(N+1),YPOLD(N+1),A(N),PAR(1)
      INTEGER IPAR(1)
C
C ARRAYS FOR COMPUTING THE JACOBIAN MATRIX AND ITS KERNEL.
      DOUBLE PRECISION QR(N,N+2),ALPHA(N),TZ(N+1)
      INTEGER PIVOT(N+1)
C
C *****  END OF DIMENSIONAL INFORMATION.  *****
C
C
      LAMBDA=Y(1)
      NP1=N+1
      NP2=N+2
      NFE=NFE+1
C NFE CONTAINS THE NUMBER OF JACOBIAN EVALUATIONS.
C   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *
C
C COMPUTE THE JACOBIAN MATRIX, STORE IT AND HOMOTOPY MAP IN QR.
C
      IF (IFLAG .EQ. -2) THEN
C
C  QR = ( D RHO(A,LAMBDA,X)/D LAMBDA , D RHO(A,LAMBDA,X)/DX ,
C                                              RHO(A,LAMBDA,X) )  .
C
        DO 30 K=1,NP1
          CALL RHOJAC(A,LAMBDA,Y(2),QR(1,K),K,PAR,IPAR)
30      CONTINUE
        CALL RHO(A,LAMBDA,Y(2),QR(1,NP2),PAR,IPAR)
      ELSE
        CALL F(Y(2),TZ)
        IF (IFLAG .EQ. 0) THEN
C
C      QR = ( A - F(X), I - LAMBDA*DF(X) ,
C                                 X - A + LAMBDA*(A - F(X)) )  .
C
          DO 100 J=1,N
            SIGMA=A(J)
            BETA=SIGMA-TZ(J)
            QR(J,1)=BETA
100       QR(J,NP2)=Y(J+1)-SIGMA+LAMBDA*BETA
          DO 120 K=1,N
            CALL FJAC(Y(2),TZ,K)
            KP1=K+1
            DO 110 J=1,N
110         QR(J,KP1)=-LAMBDA*TZ(J)
120       QR(K,KP1)=1.0+QR(K,KP1)
        ELSE
C
C   QR = ( F(X) - X + A, LAMBDA*DF(X) + (1 - LAMBDA)*I ,
C                                  X - A + LAMBDA*(F(X) - X + A) )  .
C
140       DO 150 J=1,N
            SIGMA=Y(J+1)-A(J)
            BETA=TZ(J)-SIGMA
            QR(J,1)=BETA
150       QR(J,NP2)=SIGMA+LAMBDA*BETA
          DO 170 K=1,N
            CALL FJAC(Y(2),TZ,K)
            KP1=K+1
            DO 160 J=1,N
160         QR(J,KP1)=LAMBDA*TZ(J)
170       QR(K,KP1)=1.0-LAMBDA+QR(K,KP1)
        ENDIF
      ENDIF
C
C   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *
C COMPUTE THE NORM OF THE HOMOTOPY MAP IF IT WAS REQUESTED.
      IF (RHOLEN .LT. 0.0) RHOLEN=DNRM2(N,QR(1,NP2),1)
C
C REDUCE THE JACOBIAN MATRIX TO UPPER TRIANGULAR FORM.
C
C THE FOLLOWING CODE IS A MODIFICATION OF THE ALGOL PROCEDURE
C DECOMPOSE  IN P. BUSINGER AND G. H. GOLUB, LINEAR LEAST
C SQUARES SOLUTIONS BY HOUSEHOLDER TRANSFORMATIONS,
C NUMER. MATH. 7 (1965) 269-276.
C
      DO 220 J=1,NP1
        YP(J)=DDOT(N,QR(1,J),1,QR(1,J),1)
220   PIVOT(J)=J
      DO 300 K=1,N
        SIGMA=YP(K)
        JBAR=K
        KP1=K+1
        DO 240 J=KP1,NP1
          IF (SIGMA .GE. YP(J)) GO TO 240
          SIGMA=YP(J)
          JBAR=J
240     CONTINUE
        IF (JBAR .EQ. K) GO TO 260
        I=PIVOT(K)
        PIVOT(K)=PIVOT(JBAR)
        PIVOT(JBAR)=I
        YP(JBAR)=YP(K)
        YP(K)=SIGMA
        DO 250 I=1,N
          SIGMA=QR(I,K)
          QR(I,K)=QR(I,JBAR)
          QR(I,JBAR)=SIGMA
250     CONTINUE
C   END OF COLUMN INTERCHANGE.
260     SIGMA=DDOT(N-K+1,QR(K,K),1,QR(K,K),1)
        IF (SIGMA .EQ. 0.0) THEN
          IFLAG=4
          RETURN
        ENDIF
270     IF (K .EQ. N) GO TO 300
        QRKK=QR(K,K)
        ALPHAK=-SQRT(SIGMA)
        IF (QRKK .LT. 0.0) ALPHAK=-ALPHAK
        ALPHA(K)=ALPHAK
        BETA=1.0/(SIGMA-QRKK*ALPHAK)
        QR(K,K)=QRKK-ALPHAK
        DO 290 J=KP1,NP2
          SIGMA=BETA*DDOT(N-K+1,QR(K,K),1,QR(K,J),1)
          DO 280 I=K,N
            QR(I,J)=QR(I,J)-QR(I,K)*SIGMA
280       CONTINUE
          IF (J .LT. NP2) YP(J)=YP(J)-QR(K,J)**2
290     CONTINUE
300   CONTINUE
      ALPHA(N)=QR(N,N)
C
C
C COMPUTE KERNEL OF JACOBIAN, WHICH SPECIFIES YP=DY/DS.
      TZ(NP1)=1.0
      DO 340 I=N,1,-1
        SUM=0.0
        DO 330 J=I+1,NP1
330     SUM=SUM+QR(I,J)*TZ(J)
340   TZ(I)=-SUM/ALPHA(I)
      YPNORM=DNRM2(NP1,TZ,1)
      DO 360 K=1,NP1
360   YP(PIVOT(K))=TZ(K)/YPNORM
      IF (DDOT(NP1,YP,1,YPOLD,1) .GE. 0.0) GO TO 380
      DO 370 I=1,NP1
370   YP(I)=-YP(I)
C YP  IS THE UNIT TANGENT VECTOR IN THE CORRECT DIRECTION.
C
C COMPUTE THE MINIMUM NORM SOLUTION OF [D RHO(Y(S))] V = -RHO(Y(S)).
C V IS GIVEN BY  P - (P,Q)Q  , WHERE P IS ANY SOLUTION OF
C [D RHO] V = -RHO  AND Q IS A UNIT VECTOR IN THE KERNEL OF [D RHO].
C
380   DO 440 I=N,1,-1
        SUM=QR(I,NP1)+QR(I,NP2)
        DO 430 J=I+1,N
430     SUM=SUM+QR(I,J)*ALPHA(J)
440   ALPHA(I)=-SUM/ALPHA(I)
      DO 450 K=1,N
450   TZ(PIVOT(K))=ALPHA(K)
      TZ(PIVOT(NP1))=1.0
C TZ NOW CONTAINS A PARTICULAR SOLUTION P, AND YP CONTAINS A VECTOR Q
C IN THE KERNEL(THE TANGENT).
      SIGMA=DDOT(NP1,TZ,1,YP,1)
      DO 470 J=1,NP1
        TZ(J)=TZ(J)-SIGMA*YP(J)
470   CONTINUE
C TZ IS THE NEWTON STEP FROM THE CURRENT POINT Y(S) = (LAMBDA(S), X(S)).
      RETURN
      END
      SUBROUTINE TANGNS(RHOLEN,Y,YP,TZ,YPOLD,A,QR,LENQR,PIVOT,
     $     PP,RHOVEC,WORK,NFE,N,IFLAG,PAR,IPAR)
C
C THIS SUBROUTINE BUILDS THE JACOBIAN MATRIX OF THE HOMOTOPY MAP,
C AND THEN CALCULATES THE (UNIT) TANGENT VECTOR AND THE NEWTON STEP
C USING A PRECONDITIONED CONJUGATE GRADIENT ALGORITHM.
C
C ON INPUT:
C
C RHOLEN < 0 IF THE NORM OF THE HOMOTOPY MAP EVALUATED AT
C    (A, X, LAMBDA) IS TO BE COMPUTED.  IF  RHOLEN >= 0  THE NORM IS NOT
C    COMPUTED AND  RHOLEN  IS NOT CHANGED.
C
C Y(1:N+1) = CURRENT POINT (X(S), LAMBDA(S)).
C
C YPOLD(1:N+1) = UNIT TANGENT VECTOR AT PREVIOUS POINT ON THE ZERO
C    CURVE OF THE HOMOTOPY MAP.
C
C A(1:*) = PARAMETER VECTOR IN THE HOMOTOPY MAP.
C
C QR(1:LENQR), PIVOT(1:N+2), PP(1:N), RHOVEC(1:N), WORK(1:8*(N+1)+LENQR)
C    ARE WORK ARRAYS USED FOR THE JACOBIAN MATRIX AND CONJUGATE GRADIENT
C    ITERATION.
C
C LENQR = LENGTH OF THE ONE-DIMENSIONAL ARRAY  QR  USED TO CONTAIN THE
C    N X N SYMMETRIC JACOBIAN MATRIX WITH RESPECT TO X IN PACKED SKYLINE
C    STORAGE FORMAT.
C
C NFE = NUMBER OF JACOBIAN MATRIX EVALUATIONS = NUMBER OF HOMOTOPY
C    FUNCTION EVALUATIONS.
C
C N = DIMENSION OF X.
C
C IFLAG = -2, -1, OR 0, INDICATING THE PROBLEM TYPE.
C
C PAR(1:*) AND IPAR(1:*) ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS,
C    WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES
C    RHO, RHOJS.
C
C ON OUTPUT:
C
C RHOLEN = ||RHO(A, X(S), LAMBDA(S)|| IF  RHOLEN < 0  ON INPUT.
C    OTHERWISE  RHOLEN  IS UNCHANGED.
C
C Y, YPOLD, A, N  ARE UNCHANGED.
C
C YP(1:N+1) = DY/DS = UNIT TANGENT VECTOR TO INTEGRAL CURVE OF
C    D(HOMOTOPY MAP)/DS = 0  AT  Y(S) = (X(S), LAMBDA(S)) .
C
C TZ(1:N+1) = THE NEWTON STEP = -(PSEUDO INVERSE OF  (D RHO(A,Y(S))/DX ,
C    D RHO(A,Y(S))/D LAMBDA)) * RHO(A,Y(S)) .
C
C NFE  HAS BEEN INCRMENTED BY 1.
C
C IFLAG  IS UNCHANGED, UNLESS THE PRECONDITIONED CONJUGATE GRADIENT
C    ITERATION FAILS TO CONVERGE, IN WHICH CASE THE TANGENT AND NEWTON
C    STEP VECTORS ARE NOT COMPUTED AND  TANGNS  RETURNS WITH  IFLAG = 4
C
C
C CALLS  F (OR  RHO ), FJACS (OR  RHOJS ), PCGDS , PCGNS , AND THE BLAS
C    ROUTINES  DAXPY , DCOPY , DDOT , DNRM2 , DSCAL .
C
      DOUBLE PRECISION DDOT,DNRM2,LAMBDA,RHOLEN,SIGMA,YPNORM
      INTEGER IFLAG,J,LENQR,N,NFE,NP1,NP2,N2P3,N3P4,N4P5
C
C *****  ARRAY DECLARATIONS.  *****
C
      DOUBLE PRECISION Y(N+1),YP(N+1),TZ(N+1),YPOLD(N+1),A(N),PAR(1)
      INTEGER IPAR(1)
C
C ARRAYS FOR COMPUTING THE JACOBIAN MATRIX AND ITS KERNEL.
      DOUBLE PRECISION QR(LENQR),PP(N),RHOVEC(N),
     $     WORK(8*(N+1)+LENQR)
      INTEGER PIVOT(N+2)
C
C *****  END OF DIMENSIONAL INFORMATION.  *****
C
C
      NP1=N+1
      NP2=N+2
      N2P3=2*N+3
      N3P4=3*N+4
      N4P5=4*N+5
      NFE=NFE+1
C NFE CONTAINS THE NUMBER OF JACOBIAN EVALUATIONS.
C   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *
C
C COMPUTE THE JACOBIAN MATRIX, STORE IT IN  [QR | -PP] .
C
      LAMBDA=Y(NP1)
      IF (IFLAG .EQ. -2) THEN
C
C  [QR | -PP] = ( D RHO(A,X,LAMBDA)/DX , D RHO(A,X,LAMBDA)/D LAMBDA ) ,
C  RHOVEC = RHO(A,X,LAMBDA) .
C
        CALL RHOJS(A,LAMBDA,Y,QR,LENQR,PIVOT,PP,PAR,IPAR)
        CALL RHO(A,LAMBDA,Y,RHOVEC,PAR,IPAR)
      ELSE
        CALL F(Y,PP)
        CALL DCOPY(N,Y,1,RHOVEC,1)
        CALL DAXPY(N,-1.0D0,A,1,RHOVEC,1)
        IF (IFLAG .EQ. 0) THEN
C
C      [QR | -PP] = ( I - LAMBDA*DF(X) , A - F(X) ) ,
C      RHOVEC = X - A + LAMBDA*(A - F(X)) .
C
          CALL DAXPY(N,-1.0D0,A,1,PP,1)
          CALL FJACS(Y,QR,LENQR,PIVOT)
          CALL DSCAL(LENQR,-LAMBDA,QR,1)
          DO 120 J=1,N
            QR(PIVOT(J))=QR(PIVOT(J)) + 1.0
120       CONTINUE
          CALL DAXPY(N,-LAMBDA,PP,1,RHOVEC,1)
        ELSE
C
C   [QR | -PP] = ( LAMBDA*DF(X) + (1 - LAMBDA)*I , F(X) - X + A ) ,
C   RHOVEC = X - A + LAMBDA*(F(X) - X + A) .
C
          CALL DSCAL(N,-1.0D0,PP,1)
          CALL DAXPY(N,1.0D0,RHOVEC,1,PP,1)
          CALL FJACS(Y,QR,LENQR,PIVOT)
          CALL DSCAL(LENQR,LAMBDA,QR,1)
          SIGMA=1.0 - LAMBDA
          DO 170 J=1,N
            QR(PIVOT(J))=QR(PIVOT(J)) + SIGMA
170       CONTINUE
          CALL DAXPY(N,-LAMBDA,PP,1,RHOVEC,1)
        ENDIF
      ENDIF
C
C   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *
C COMPUTE THE NORM OF THE HOMOTOPY MAP IF IT WAS REQUESTED.
      IF (RHOLEN .LT. 0.0) RHOLEN=DNRM2(N,RHOVEC,1)
C
C COMPUTE KERNEL OF JACOBIAN, WHICH SPECIFIES YP=DY/DS, BY A
C PRECONDITIONED CONJUGATE GRADIENT ALGORITHM.  THIS IS DONE BY SOLVING
C SEVERAL AUXILLARY SYSTEMS, WHOSE PREVIOUS SOLUTIONS HAVE BEEN LEFT IN
C WORK(1:N+1) AND WORK(N+2:2*N+2).
      CALL DCOPY(2*NP1,WORK,1,WORK(N3P4),1)
      CALL DCOPY(NP1,YPOLD,1,YP,1)
      CALL PCGDS(N,QR,LENQR,PIVOT,PP,YP,WORK(N2P3),IFLAG)
      IF (IFLAG .GT. 0) RETURN
      CALL DCOPY(2*NP1,WORK(N3P4),1,WORK,1)
      YPNORM=DNRM2(NP1,YP,1)
      CALL DSCAL(NP1,1.0/YPNORM,YP,1)
      IF (DDOT(NP1,YP,1,YPOLD,1) .LT. 0.0)
     $     CALL DSCAL(NP1,-1.0D0,YP,1)
C YP  IS THE UNIT TANGENT VECTOR IN THE CORRECT DIRECTION.
C
C COMPUTE THE MINIMUM NORM SOLUTION OF [D RHO(Y(S))] V = -RHO(Y(S)).
C V IS GIVEN BY  P - (P,Q)Q  , WHERE P IS ANY SOLUTION OF
C [D RHO] V = -RHO  AND Q IS A UNIT VECTOR IN THE KERNEL OF [D RHO].
C
      CALL DSCAL(2*NP1,0.0D0,WORK(N3P4),1)
      CALL DCOPY(NP1,YPOLD,1,TZ,1)
      CALL PCGNS(N,QR,LENQR,PIVOT,PP,RHOVEC,TZ,WORK(N2P3),IFLAG)
      IF (IFLAG .GT. 0) RETURN
C TZ NOW CONTAINS A PARTICULAR SOLUTION P, AND YP CONTAINS A VECTOR Q
C IN THE KERNEL(THE TANGENT).
      SIGMA=DDOT(NP1,TZ,1,YP,1)
      CALL DAXPY(NP1,-SIGMA,YP,1,TZ,1)
C
C TZ IS THE NEWTON STEP FROM THE CURRENT POINT Y(S) = (X(S), LAMBDA(S)).
C
      RETURN
      END
        SUBROUTINE TANGQF(Y,YP,YPOLD,A,QT,R,W,S,T,N,IFLAG,NFE,PAR,IPAR)
C
C SUBROUTINE  TANGQF  COMPUTES THE UNIT TANGENT VECTOR  YP  TO THE
C ZERO CURVE OF THE HOMOTOPY MAP AT  Y  BY GENERATING THE AUGMENTED
C JACOBIAN MATRIX
C
C           --           --
C           |  D(RHO(Y))  |
C     AUG = |        T    |,   WHERE RHO IS THE HOMOTOPY MAP,
C           |   YPOLD     |
C           --           --
C
C SOLVING THE SYSTEM
C                                T
C         AUG*YPT = (0,0,...,0,1)    FOR YPT,
C
C AND FINALLY COMPUTING  YP = YPT/||YPT||.
C
C IN ADDITION, THE MATRIX AUG IS UPDATED SO THAT THE LAST ROW IS
C YP  INSTEAD OF  YPOLD  ON RETURN.
C
C
C ON INPUT:
C
C Y(1:N+1) = CURRENT POINT (LAMBDA(S), X(S)).
C
C YP(1:N+1)  IS UNDEFINED ON INPUT.
C
C YPOLD(1:N+1) = UNIT TANGENT VECTOR AT THE PREVIOUS POINT ON THE
C    ZERO CURVE OF THE HOMOTOPY MAP.
C
C A(1:N)  IS THE PARAMETER VECTOR IN THE HOMOTOPY MAP.
C
C W(1:N+1), S(1:N+1), T(1:N+1)  ARE WORK ARRAYS.
C
C N  IS THE DIMENSION OF X, WHERE  Y=(LAMBDA(S),X(S)).
C
C IFLAG  IS -2, -1, OR 0, INDICATING THE PROBLEM TYPE.
C
C NFE  IS THE NUMBER OF JACOBIAN EVALUATIONS.
C
C PAR(1:*)  AND  IPAR(1:*)  ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS,
C    WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES
C    RHO, RHOJAC.
C
C
C ON OUTPUT:
C
C Y, YPOLD, A, N  ARE UNCHANGED.
C
C YP(1:N+1)  CONTAINS THE NEW UNIT TANGENT VECTOR TO THE ZERO
C    CURVE OF THE HOMOTOPY MAP AT  Y(S) = (LAMBDA(S), X(S)).
C
C QT(1:N+1,1:N+1)  CONTAINS  Q TRANSPOSE  OF THE QR FACTORIZATION OF
C    THE JACOBIAN MATRIX OF RHO EVALUATED AT  Y  AUGMENTED BY
C    YP TRANSPOSE.
C
C R(1:(N+1)*(N+2)/2)  CONTAINS THE UPPER TRIANGLE (STORED BY ROWS)
C    OF THE  R  PART OF THE QR FACTORIZATION OF THE AUGMENTED JACOBIAN
C    MATRIX.
C
C IFLAG  = -2, -1, OR 0, (UNCHANGED) ON A NORMAL RETURN.
C        = 4 IF THE AUGMENTED JACOBIAN MATRIX HAS RANK LESS THAN N+1.
C
C NFE  HAS BEEN INCREMENTED BY 1.
C
C
C CALLS  DCOPY, DNRM2, DSCAL, F (OR RHO IF IFLAG = -2), FJAC
C    (OR RHOJAC, IF IFLAG = -2), R1UPQF (WHICH IS AN ENTRY POINT OF
C    UPQRQF), QRFAQF, QRSLQF.
C
C ***** DECLARATIONS *****
C
C     FUNCTION DECLARATIONS
C
        DOUBLE PRECISION DNRM2
C
C     LOCAL VARIABLES
C
        DOUBLE PRECISION LAMBDA, ONE, YPNRM
        INTEGER I, J, JP1, NP1
C
C     SCALAR ARGUMENTS
C
        INTEGER N, IFLAG, NFE
C
C     ARRAY DECLARATIONS
C
        DOUBLE PRECISION Y(N+1), YP(N+1), YPOLD(N+1), A(N),
     $    QT(N+1,N+1), R((N+1)*(N+2)/2), W(N+1), S(N+1), T(N+1),PAR(1)
        INTEGER IPAR(1)
C
C ***** END OF DECLARATIONS *****
C
C ***** FIRST EXECUTABLE STATEMENT *****
C
        ONE = 1.0
        NFE = NFE + 1
        NP1 = N + 1
        LAMBDA = Y(1)
C
C ***** DEFINE THE AUGMENTED JACOBIAN MATRIX *****
C
C QT = AUG.
C
        IF (IFLAG .EQ. -2) THEN
C
C         CURVE TRACKING PROBLEM:
C         D(RHO) = (D RHO(A,LAMBDA,X)/D LAMBDA, D RHO(A,LAMBDA,X)/DX).
C
          DO 10 J = 1,NP1
            CALL RHOJAC(A,LAMBDA,Y(2),QT(1,J),J,PAR,IPAR)
  10      CONTINUE
        ELSE IF (IFLAG .EQ. -1) THEN
C
C         ZERO FINDING PROBLEM:
C         D(RHO) = (F(X) - X + A, LAMBDA*DF(X) + (1-LAMBDA)*I)
C
          CALL F(Y(2),QT(1,1))
          DO 20 I=1,N
            QT(I,1) = A(I) - Y(I+1) + QT(I,1)
  20      CONTINUE
          DO 30 J= 1,N
            JP1 = J+1
            CALL FJAC(Y(2),QT(1,JP1),J)
            CALL DSCAL(N,LAMBDA,QT(1,JP1),1)
            QT(J,JP1) = 1.0 - LAMBDA + QT(J,JP1)
  30      CONTINUE
        ELSE
C
C         FIXED POINT PROBLEM:
C         D(RHO) = (A - F(X), I - LAMBDA*DF(X)).
C
          CALL F(Y(2),QT(1,1))
          CALL DSCAL(N,-ONE,QT(1,1),1)
          CALL DAXPY(N,ONE,A,1,QT(1,1),1)
          DO 50 J=1,N
            JP1 = J+1
            CALL FJAC(Y(2),QT(1,JP1),J)
            CALL DSCAL(N,-LAMBDA,QT(1,JP1),1)
            QT(J,JP1) = 1.0 + QT(J,JP1)
  50      CONTINUE
        END IF
C
C     DEFINE LAST ROW OF QT  = YPOLD.
C
        CALL DCOPY(NP1,YPOLD,1,QT(NP1,1),NP1)
C
C ***** END OF DEFINITION OF AUGMENTED JACOBIAN MATRIX *****
C
C                                          T
C ***** SOLVE SYSTEM  AUG*YPT = (0,...,0,1)  *****
C
C FACTOR MATRIX.
C
        CALL QRFAQF(QT,R,NP1,IFLAG)
C
C IF MATRIX IS SINGULAR, THEN QUIT.
C
C       IF (IFLAG .EQ. 4) RETURN
C
C ELSE SOLVE SYSTEM  R*YP = QT*(0,...,0,1)  FOR YP.
C
        DO 70 J=1,N
          YP(J) = 0.0
  70    CONTINUE
        YP(NP1) = 1.0
        CALL QRSLQF(QT,R,YP,W,NP1)
C
C     COMPUTE UNIT VECTOR.
C
        YPNRM = 1.0/DNRM2(NP1,YP,1)
        CALL DSCAL(NP1,YPNRM,YP,1)
C
C ***** SYSTEM SOLVED *****
C
C ***** UPDATE AUGMENTED SYSTEM SO THAT LAST ROW IS YP *****
C
C S=YP-YPOLD,  T = QT*E(NP1).
C
        CALL DCOPY(NP1,YP,1,S,1)
        CALL DAXPY(NP1,-ONE,YPOLD,1,S,1)
        CALL DCOPY(NP1,QT(1,NP1),1,T,1)
        CALL R1UPQF(NP1,S,T,QT,R,W)
C
        RETURN
C
C ***** END OF SUBROUTINE TANGQF *****
        END
        SUBROUTINE TANGQS(Y,YP,YPOLD,A,QR,PIVOT,PP,RHOVEC,WORK,N,LENQR,
     $     IFLAG,NFE,PAR,IPAR)
C
C SUBROUTINE  TANGQS  COMPUTES THE UNIT TANGENT VECTOR  YP  TO THE
C ZERO CURVE OF THE HOMOTOPY MAP AT  Y  BY GENERATING THE AUGMENTED
C JACOBIAN MATRIX
C
C           --           --
C           |  D(RHO(Y))  |
C     AUG = |        T    |,   WHERE RHO IS THE HOMOTOPY MAP
C           |   YPOLD     |
C           --           --
C
C SOLVING THE SYSTEM
C                                T
C         AUG*YPT = (0,0,...,0,1)    FOR YPT.
C
C AND FINALLY COMPUTING  YP = YPT/||YPT||.
C
C
C ON INPUT:
C
C Y(1:N+1) = CURRENT POINT (X(S), LAMBDA(S)).
C
C YP(1:N+1)  IS UNDEFINED ON INPUT.
C
C YPOLD(1:N+1) = UNIT TANGENT VECTOR AT THE PREVIOUS POINT ON THE
C    ZERO CURVE OF THE HOMOTOPY MAP.
C
C A(1:N)  IS THE PARAMETER VECTOR IN THE HOMOTOPY MAP.
C
C QR(1:LENQR)  IS A WORK ARRAY CONTAINING THE N X N SYMMETRIC
C    JACOBIAN MATRIX WITH RESPECT TO X STORED IN PACKED SKYLINE
C    STORAGE FORMAT.  LENQR  AND  PIVOT  DESCRIBE THE DATA
C    STRUCTURE IN  QR.  (SEE SUBROUTINE  PCGQS  FOR A DESCRIPTION
C    OF THIS DATA STRUCTURE).
C
C PIVOT(1:N+2)  IS A WORK ARRAY WHOSE FIRST N+1 COMPONENTS CONTAINI
C    THE INDICES OF THE DIAGONAL ELEMENTS OF THE N X N SYMMETRIC
C    JACOBIAN MATRIX (WITH RESPECT TO X) WITHIN  QR.
C
C PP(1:N)  IS A WORK ARRAY CONTAINING THE NEGATIVE OF THE LAST COLUMN
C    OF THE JACOBIAN MATRIX  -[D RHO/D LAMBDA].
C
C RHOVEC(1:N+1), IS A WORK ARRAY USED TO CALCULATE THE TANGENT
C    VECTOR.
C
C WORK(1:8*(N+1)+LENQR)  IS A WORK ARRAY USED BY THE CONJUGATE GRADIENT
C    ALGORITHM TO SOLVE LINEAR SYSTEMS.
C
C N  IS THE DIMENSION OF X, WHERE  Y=(X(S),LAMBDA(S)).
C
C LENQR  IS THE LENGTH OF THE ONE-DIMENSIONAL ARRAY  QR.
C
C IFLAG  IS -2, -1, OR 0, INDICATING THE PROBLEM TYPE.
C
C NFE  IS THE NUMBER OF JACOBIAN EVALUATIONS.
C
C PAR(1:*)  AND  IPAR(1:*)  ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS,
C    WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES
C    RHO, RHOJS.
C
C
C ON OUTPUT:
C
C Y, YPOLD, A, N, LENQR  ARE UNCHANGED.
C
C YP(1:N+1) CONTAINS THE NEW UNIT TANGENT VECTOR TO THE ZERO
C    CURVE OF THE HOMOTOPY MAP AT  Y(S) = (X(S),LAMBDA(S)).
C
C IFLAG  = -2, -1, OR 0, (UNCHANGED) ON A NORMAL RETURN.
C        = 4 IF THE AUGMENTED JACOBIAN MATRIX HAS RANK LESS THAN N+1.
C
C NFE  HAS BEEN INCREMENTED BY 1.
C
C
C CALLS  DCOPY, DNRM2, DSCAL, F (OR RHO IF IFLAG = -2), FJACS
C    (OR RHOJS, IF IFLAG = -2), PCGQS.
C
C ***** DECLARATIONS *****
C
C     FUNCTION DECLARATIONS
C
        DOUBLE PRECISION DNRM2
C
C     LOCAL VARIABLES
C
        DOUBLE PRECISION LAMBDA, ONE, SIGMA, YPNRM
        INTEGER J, NP1, PCGWK, ZU
C
C     SCALAR ARGUMENTS
C
        INTEGER N, LENQR, IFLAG, NFE
C
C     ARRAY DECLARATIONS
C
        DOUBLE PRECISION Y(N+1), YP(N+1), YPOLD(N+1), A(N),
     $    QR(LENQR), PP(N), RHOVEC(N+1), WORK(8*(N+1)+LENQR),PAR(1)
        INTEGER PIVOT(N+2), IPAR(1)
C
C ***** END OF DECLARATIONS *****
C
C ***** FIRST EXECUTABLE STATEMENT *****
C
        ONE = 1.0
        NFE = NFE + 1
        NP1 = N + 1
        LAMBDA = Y(NP1)
        PCGWK = 2*N+3
        ZU = 3*N+4
C
C ***** DEFINE THE AUGMENTED JACOBIAN MATRIX *****
C
C COMPUTE JACOBIAN MATRIX, STORE IT IN [QR|-PP].
C
        IF (IFLAG .EQ. -2) THEN
C
C         CURVE TRACKING PROBLEM.
C
          CALL RHOJS(A,LAMBDA,Y,QR,LENQR,PIVOT,PP,PAR,IPAR)
        ELSE IF (IFLAG .EQ. -1) THEN
C
C         ZERO FINDING PROBLEM.
C
          CALL F(Y,PP)
          CALL DSCAL(N,-ONE,PP,1)
          CALL DAXPY(N,ONE,Y,1,PP,1)
          CALL DAXPY(N,-ONE,A,1,PP,1)
          CALL FJACS(Y,QR,LENQR,PIVOT)
          CALL DSCAL(LENQR,LAMBDA,QR,1)
          SIGMA = 1.0-LAMBDA
          DO 10 J=1,N
            QR(PIVOT(J))=QR(PIVOT(J))+SIGMA
  10      CONTINUE
        ELSE
C
C         FIXED POINT PROBLEM
C
          CALL F(Y,PP)
          CALL DAXPY(N,-ONE,A,1,PP,1)
          CALL FJACS(Y,QR,LENQR,PIVOT)
          CALL DSCAL(LENQR,-LAMBDA,QR,1)
          DO 20 J=1,N
            QR(PIVOT(J))=QR(PIVOT(J)) + 1.0
  20      CONTINUE
        ENDIF
C
C ***** END OF DEFINITION OF AUGMENTED JACOBIAN MATRIX *****
C
C                                          T
C ***** SOLVE SYSTEM  AUG*YPT = (0,...,0,1)  *****
C
C INITIALIZE STARTING POINT FOR THE CONJUGATE GRADIENT ALGORITHM
C TO BE THE SOLUTIONS FROM THE PREVIOUS CALL TO  TANGQS.
C
        CALL DCOPY(2*NP1,WORK,1,WORK(ZU),1)
C
C RHOVEC = -(0,...,0,1)**T
C
        DO 30 J=1,N
          RHOVEC(J)=0.0
30      CONTINUE
        RHOVEC(NP1) = -1.0
C
C SOLVE SYSTEM.
C
        CALL PCGQS(N,QR,LENQR,PIVOT,PP,YPOLD,RHOVEC,YP,WORK(PCGWK),
     $      IFLAG)
        IF (IFLAG .GT. 0) RETURN
C
C NORMALIZE THE TANGENT.
C
        YPNRM = 1.0/DNRM2(NP1,YP,1)
        CALL DSCAL(NP1,YPNRM,YP,1)
C
C SAVE SOLUTIONS FROM CONJUGATE GRADIENT ALGORITHM FOR NEXT CALL
C TO TANGQS.
C
        CALL DCOPY(2*NP1,WORK(ZU),1,WORK,1)
C
        RETURN
C
C ***** END OF SUBROUTINE TANGQS *****
        END
        SUBROUTINE UPQRQF(N,ETA,S,F0,F1,QT,R,W,T)
C
C SUBROUTINE  UPQRQF  PERFORMS A BROYDEN UPDATE ON THE  Q R
C FACTORIZATION OF A MATRIX  A, (AN APPROXIMATION TO J(X0)),
C RESULTING IN THE FACTORIZATION  Q+ R+ OF
C
C       A+  =  A  +  (Y - A*S) (ST)/(ST * S),
C
C (AN APPROXIMATION TO J(X1))
C WHERE S = X1 - X0, ST = S TRANSPOSE,  Y = F(X1) - F(X0).
C
C THE ENTRY POINT  R1UPQF  PERFORMS THE RANK ONE UPDATE ON THE QR
C FACTORIZATION OF
C
C       A+ =  A + Q*(T*ST).
C
C
C ON INPUT:
C
C N  IS THE DIMENSION OF X AND F(X).
C
C ETA  IS A NOISE PARAMETER.  IF (Y-A*S)(I) .LE. ETA*(|F1(I)|+|F0(I)|)
C    FOR 1 .LE. I .LE. N, THEN NO UPDATE IS PERFORMED.
C
C S(1:N) = X1 - X0   (OR S FOR THE ENTRY POINT R1UPQF).
C
C F0(1:N) = F(X0).
C
C F1(1:N) = F(X1).
C
C QT(1:N,1:N)  CONTAINS THE OLD Q TRANSPOSE, WHERE  A = Q*R .
C
C R(1:N*(N+1)/2)  CONTAINS THE OLD R, STORED BY ROWS.
C
C W(1:N), T(1:N)  ARE WORK ARRAYS ( T  CONTAINS THE VECTOR T FOR THE
C    ENTRY POINT  R1UPQF ).
C
C
C ON OUTPUT:
C
C N  AND  ETA  ARE UNCHANGED.
C
C QT  CONTAINS Q+ TRANSPOSE.
C
C R   CONTAINS R+, STORED BY ROWS.
C
C S, F0, F1, W, AND T  HAVE ALL BEEN CHANGED.
C
C
C CALLS  DAXPY, DDOT, AND DNRM2.
C
C ***** DECLARATIONS *****
C
C     FUNCTION DECLARATIONS
C
        DOUBLE PRECISION DDOT, DNRM2
C
C     LOCAL VARIABLES
C
        DOUBLE PRECISION C, DEN, ONE, SS, WW, YY
        INTEGER I, INDEXR, INDXR2, J, K
        LOGICAL SKIPUP
C
C     SCALAR ARGUMENTS
C
        DOUBLE PRECISION ETA
        INTEGER N
C
C     ARRAY DECLARATIONS
C
        DOUBLE PRECISION  S(N), F0(N), F1(N), QT(N,N), R(N*(N+1)/2),
     $    W(N), T(N), TT(2)
C
C ***** END OF DECLARATIONS *****
C
C ***** FIRST EXECUTABLE STATEMENT *****
C
        ONE = 1.0
        SKIPUP = .TRUE.
C
C ***** DEFINE T AND S SUCH THAT *****
C
C           A+ = Q*(R + T*ST).
C
C T = R*S.
C
        INDEXR = 1
        DO 10 I=1,N
          T(I) = DDOT(N-I+1,R(INDEXR),1,S(I),1)
          INDEXR = INDEXR + N - I + 1
  10    CONTINUE
C
C W = Y - Q*T  = Y - A*S.
C
        DO 20 I=1,N
          W(I) = F1(I) - F0(I) - DDOT(N,QT(1,I),1,T,1)
C
C         IF W(I) IS NOT SMALL, THEN UPDATE MUST BE PERFORMED,
C         OTHERWISE SET W(I) TO 0.
C
          IF (ABS(W(I)) .GT. ETA*(ABS(F1(I)) + ABS(F0(I)))) THEN
            SKIPUP = .FALSE.
          ELSE
            W(I) = 0.0
          END IF
  20    CONTINUE
C
C  IF NO UPDATE IS NECESSARY, THEN RETURN.
C
        IF (SKIPUP) RETURN
C
C T = QT*W = QT*Y - R*S.
C
        DO 30 I=1,N
          T(I) = DDOT(N,QT(I,1),N,W,1)
  30    CONTINUE
C
C S = S/(ST*S).
C
        DEN = 1.0/DDOT(N,S,1,S,1)
        CALL DSCAL(N,DEN,S,1)
C
C ***** END OF COMPUTATION OF  T & S      *****
C       AT THIS POINT,  A+ = Q*(R + T*ST).
C
        ENTRY R1UPQF(N,S,T,QT,R,W)
C
C ***** COMPUTE THE QR FACTORIZATION Q- R- OF (R + T*S).  THEN,  *****
C       Q+ = Q*Q-,  AND  R+ = R-.
C
C FIND THE LARGEST  K  SUCH THAT  T(K) .NE. 0.
C
        K = N
  50    IF (T(K) .NE. 0.0 .OR. K .LE. 1) GOTO 60
          K=K-1
          GOTO 50
  60    CONTINUE
C
C COMPUTE THE INDEX OF R(K-1,K-1).
C
        INDEXR = (N + N - K + 3)*(K - 2) / 2 + 1
C
C ***** TRANSFORM R+T*ST INTO AN UPPER HESSENBERG MATRIX *****
C
C DETERMINE JACOBI ROTATIONS WHICH WILL ZERO OUT ROWS
C N, N-1,...,2  OF THE MATRIX  T*ST,  AND APPLY THESE
C ROTATIONS TO  R.  (THIS IS EQUIVALENT TO APPLYING THE
C SAME ROTATIONS TO  R+T*ST, EXCEPT FOR THE FIRST ROW.
C THUS, AFTER AN ADJUSTMENT FOR THE FIRST ROW, THE
C RESULT IS AN UPPER HESSENBERG MATRIX.  THE
C SUBDIAGONAL ELEMENTS OF WHICH WILL BE STORED IN  W.
C
C NOTE:  ROWS N,N-1,...,K+1 ARE ALREADY ALL ZERO.
C
        DO 90 I=K-1,1,-1
C
C         DETERMINE THE JACOBI ROTATION WHICH WILL ZERO OUT
C         ROW  I+1  OF THE  T*ST  MATRIX.
C
          IF (T(I) .EQ. 0.0) THEN
            C = 0.0
C         SS = SIGN(-T(I+1))= -T(I+1)/|T(I+1)|
            SS = -SIGN(ONE,T(I+1))
          ELSE
            DEN = DNRM2(2,T(I),1)
            C = T(I) / DEN
            SS = -T(I+1)/DEN
          END IF
C
C         PREMULTIPLY  R  BY THE JACOBI ROTATION.
C
          YY = R(INDEXR)
          WW = 0.0
          R(INDEXR) = C*YY - SS*WW
          W(I+1) = SS*YY + C*WW
          INDEXR = INDEXR + 1
          INDXR2 = INDEXR + N - I
          DO 70 J= I+1,N
C           YY = R(I,J)
C           WW = R(I+1,J)
              YY = R(INDEXR)
              WW = R(INDXR2)
C           R(I,J) = C*YY - SS*WW
C           R(I+1,J) = SS*YY + C*WW
              R(INDEXR) = C*YY - SS*WW
              R(INDXR2) = SS*YY + C*WW
            INDEXR = INDEXR + 1
            INDXR2 = INDXR2 + 1
  70      CONTINUE
C
C         PREMULTIPLY  QT  BY THE JACOBI ROTATION.
C
          DO 80 J=1,N
            YY = QT(I,J)
            WW = QT(I+1,J)
            QT(I,J) = C*YY - SS*WW
            QT(I+1,J) = SS*YY + C*WW
  80      CONTINUE
C
C         UPDATE  T(I)  SO THAT  T(I)*ST(J)  IS THE  (I,J)TH  COMPONENT
C         OF  T*ST, PREMULTIPLIED BY ALL OF THE JACOBI ROTATIONS SO
C         FAR.
C
          IF (T(I) .EQ. 0.0) THEN
            T(I) = ABS(T(I+1))
          ELSE
            T(I) = DNRM2(2,T(I),1)
          END IF
C
C         LET INDEXR = THE INDEX OF R(I-1,I-1).
C
          INDEXR = INDEXR - 2*(N - I) - 3
C
  90    CONTINUE
C
C     UPDATE THE FIRST ROW OF  R  SO THAT  R  HOLDS  (R+T*ST)
C     PREMULTIPLIED BY ALL OF THE ABOVE JACOBI ROTATIONS.
C
        CALL DAXPY(N,T(1),S,1,R,1)
C
C ***** END OF TRANSFORMATION TO UPPER HESSENBERG *****
C
C
C ***** TRANSFORM UPPER HESSENBERG MATRIX INTO UPPER *****
C       TRIANGULAR MATRIX.
C
C       INDEXR = INDEX OF R(1,1).
C
          INDEXR = 1
          DO 120 I=1,K-1
C
C           DETERMINE APPROPRIATE JACOBI ROTATION TO ZERO OUT
C           R(I+1,I).
C
            IF (R(INDEXR) .EQ. 0.0) THEN
              C = 0.0
              SS = -SIGN(ONE,W(I+1))
            ELSE
              TT(1) = R(INDEXR)
              TT(2) = W(I+1)
              DEN = DNRM2(2,TT,1)
              C = R(INDEXR) / DEN
              SS = -W(I+1)/DEN
            END IF
C
C           PREMULTIPLY  R  BY JACOBI ROTATION.
C
            YY = R(INDEXR)
            WW = W(I+1)
            R(INDEXR) = C*YY - SS*WW
            W(I+1) = 0.0
            INDEXR = INDEXR + 1
            INDXR2 = INDEXR + N - I
            DO 100 J= I+1,N
C             YY = R(I,J)
C             WW = R(I+1,J)
                YY = R(INDEXR)
                WW = R(INDXR2)
C             R(I,J) = C*YY -SS*WW
C             R(I+1,J) = SS*YY + C*WW
                R(INDEXR) = C*YY - SS*WW
                R(INDXR2) = SS*YY + C*WW
              INDEXR = INDEXR + 1
              INDXR2 = INDXR2 + 1
  100       CONTINUE
C
C           PREMULTIPLY  QT  BY JACOBI ROTATION.
C
            DO 110 J=1,N
              YY = QT(I,J)
              WW = QT(I+1,J)
              QT(I,J) = C*YY - SS*WW
              QT(I+1,J) = SS*YY + C*WW
  110       CONTINUE
  120     CONTINUE
C
C ***** END OF TRANSFORMATION TO UPPER TRIANGULAR *****
C
C
C ***** END OF UPDATE *****
C
C
        RETURN
C
C ***** END OF SUBROUTINE UPQRQF *****
        END
'TWO QUADRICS PBHP0403, NO SOLUTIONS AT INFINITY    .............'
00001       IFLGHM
00001       IFLGSC
    4       ITOTDG
                1.D-04    EPSBIG
                1.D-14    EPSSML
                1.D-00    SSPAR(5)
   00       NUMRR
    2       N
00006                     NUMTRM(1)
00002                     DEG(1,1,1)
00000                     DEG(1,2,1)
           -.00098D 00
00000                     DEG(1,1,2)
00002                     DEG(1,2,2)
           978000.D 00
00001                     DEG(1,1,3)
00001                     DEG(1,2,3)
              -9.8D 00
00001                     DEG(1,1,4)
00000                     DEG(1,2,4)
            -235.0D 00
00000                     DEG(1,1,5)
00001                     DEG(1,2,5)
           88900.0D 00
00000                     DEG(1,1,6)
00000                     DEG(1,2,6)
            -1.000D 00
00006                     NUMTRM(2)
00002                     DEG(2,1,1)
00000                     DEG(2,2,1)
            -.0100D 00
00000                     DEG(2,1,2)
00002                     DEG(2,2,2)
            -.9840D 00
00001                     DEG(2,1,3)
00001                     DEG(2,2,3)
            -29.70D 00
00001                     DEG(2,1,4)
00000                     DEG(2,2,4)
            .00987D 00
00000                     DEG(2,1,5)
00001                     DEG(2,2,5)
            -.1240D 00
00000                     DEG(2,1,6)
00000                     DEG(2,2,6)
            -.2500D 00
SXXXXXXXXXXXXXXXX.DSYY
 
#### OUTPUT FOLLOWS
 
 
  POLYS TEST ROUTINE 5/20/85
 
 
 TWO QUADRICS PBHP0403, NO SOLUTIONS AT INFINITY    .........
 
 IF IFLGHM=1,HOMOGENEOUS;IF IFLGHM=2,INHOMOGENEOUS;IFLGHM= 1
 
 IF IFLGSC=1,SCLGEN USED; IF IFLGSC=2, NO SCALING; IFLGSC= 1
 
 ITOTDG=    4
 
 EPSBIG,EPSSML = 0.100000000000000D-03 0.100000000000000D-13
 NUMBER OF EQUATIONS =    2
 
 
 NUMBER OF RECALLS WHEN IFLAG=3:     40
 
 
 
  ****** COEFFICIENT TABLEAU ******
 
 
  NUMT( 1)=    6
  KDEG( 1, 1, 1)=    2
  KDEG( 1, 2, 1)=    0
  COEF( 1, 1)=-0.980000000000000D-03
  KDEG( 1, 1, 2)=    0
  KDEG( 1, 2, 2)=    2
  COEF( 1, 2)= 0.978000000000000D+06
  KDEG( 1, 1, 3)=    1
  KDEG( 1, 2, 3)=    1
  COEF( 1, 3)=-0.980000000000000D+01
  KDEG( 1, 1, 4)=    1
  KDEG( 1, 2, 4)=    0
  COEF( 1, 4)=-0.235000000000000D+03
  KDEG( 1, 1, 5)=    0
  KDEG( 1, 2, 5)=    1
  COEF( 1, 5)= 0.889000000000000D+05
  KDEG( 1, 1, 6)=    0
  KDEG( 1, 2, 6)=    0
  COEF( 1, 6)=-0.100000000000000D+01
 
 
  NUMT( 2)=    6
  KDEG( 2, 1, 1)=    2
  KDEG( 2, 2, 1)=    0
  COEF( 2, 1)=-0.100000000000000D-01
  KDEG( 2, 1, 2)=    0
  KDEG( 2, 2, 2)=    2
  COEF( 2, 2)=-0.984000000000000D+00
  KDEG( 2, 1, 3)=    1
  KDEG( 2, 2, 3)=    1
  COEF( 2, 3)=-0.297000000000000D+02
  KDEG( 2, 1, 4)=    1
  KDEG( 2, 2, 4)=    0
  COEF( 2, 4)= 0.987000000000000D-02
  KDEG( 2, 1, 5)=    0
  KDEG( 2, 2, 5)=    1
  COEF( 2, 5)=-0.124000000000000D+00
  KDEG( 2, 1, 6)=    0
  KDEG( 2, 2, 6)=    0
  COEF( 2, 6)=-0.250000000000000D+00
 
 
 
 
  PATH NUMBER =    1
 
  FINAL VALUES FOR PATH
 
  ARCLEN = 0.100553311312353D+02
  NFE =   53
  IFLG2 =    1
  T = 0.100000000000000D+01
  X = 0.234233851959126D+04 0.791152831437911D-11
  X =-0.788344824094138D+00-0.268347762088076D-14
  X =-0.949359459408658D-02-0.106447550900261D-02
  X =
 
 
  PATH NUMBER =    2
 
  FINAL VALUES FOR PATH
 
  ARCLEN = 0.172112868960496D+01
  NFE =   37
  IFLG2 =    1
  T = 0.100000000000000D+01
  X = 0.161478579234367D-01 0.168496955498881D+01
  X = 0.267994739614462D-03 0.442802993973661D-02
  X =-0.381948972942403D+00 0.372068943457283D+00
  X =
 
 
  PATH NUMBER =    3
 
  FINAL VALUES FOR PATH
 
  ARCLEN = 0.202329539135269D+01
  NFE =   35
  IFLG2 =    1
  T = 0.100000000000000D+01
  X = 0.161478579234362D-01-0.168496955498881D+01
  X = 0.267994739614461D-03-0.442802993973661D-02
  X =-0.329370493847660D+00 0.556619775523013D+00
  X =
 
 
  PATH NUMBER =    4
 
  FINAL VALUES FOR PATH
 
  ARCLEN = 0.416327291917901D+01
  NFE =   46
  IFLG2 =    1
  T = 0.100000000000000D+01
  X = 0.908921229615394D-01-0.111985846294633D-14
  X =-0.911497098197500D-01 0.117962440099502D-17
  X =-0.573673395727962D-01 0.136243663709219D+00
  X =
 
 
  TOTAL NFE OVER ALL PATHS =        171
0 MESSAGE SUMMARY: MESSAGE NUMBER - COUNT
0                           208      70